diff --git a/lispusers/0001READ-ME-BEFORE-YOU-TRY-TO-PRINT.TEDIT b/lispusers/0001READ-ME-BEFORE-YOU-TRY-TO-PRINT.TEDIT new file mode 100644 index 00000000..d54254d0 Binary files /dev/null and b/lispusers/0001READ-ME-BEFORE-YOU-TRY-TO-PRINT.TEDIT differ diff --git a/lispusers/001-TITLE-PAGE.TEDIT b/lispusers/001-TITLE-PAGE.TEDIT new file mode 100644 index 00000000..4d5d51bd Binary files /dev/null and b/lispusers/001-TITLE-PAGE.TEDIT differ diff --git a/lispusers/002TABLE-OF-CONTENTS.TEDIT b/lispusers/002TABLE-OF-CONTENTS.TEDIT new file mode 100644 index 00000000..cb3f2789 Binary files /dev/null and b/lispusers/002TABLE-OF-CONTENTS.TEDIT differ diff --git a/lispusers/ACE b/lispusers/ACE new file mode 100644 index 00000000..a8018f00 --- /dev/null +++ b/lispusers/ACE @@ -0,0 +1,1893 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-Nov-93 14:13:50" {DSK}export>lispcore>lispusers>ACE.;3 148254 + + changes to%: (VARS ACE.BITMAP.MASK ACE-EDITCOMS ACELOGOMAP) + (FNS ACE ACE.ANIMATE ACE.RUN ACEGETFRAME# ACERUNLOOP ACE.NEW.SEQUENCE + ACE.NEW.FRAME ACE.QUIT.ACE ACE.RESET.SEQ ACE.RUN.CURRENT.SEQ ACE.DELAY + ACE.DELAY.FRAME ACE.DELAY.SEQ ACE.DECREMENT.FRAME ACE.INCREMENT.FRAME + ACE.DELETE.FRAME ACE.SET.DEVICE ACE.QUICKDRAW&UPD ACE.RECONSTRUCT.FRAME + SUBLIST ACE.TRILLIUM ACE.TRILLIUM.LOOP ACE.RUN.TRILLIUM ACE.QUIT.TRILLIUM + ACE.CREATE.EDITING.BORDER ACE.GET.SEQ.FILE ACE.PUT.SEQ.FILE + ACE.GET.A.FILE.NAME ACE.ASKEM ACE.TELLEM ACE.CONFIRMIT ACE.DEFINE.SEQ.WINDOW + ACE.FIGURE.OUT.WINDOW ACE.RETURN.CLOSEST.VERTEX ACE.NEW.SEQ.ASST + ACE.DELAY.FRAME.ASST ACE.SETUP.CW.CLIPPING.REGIONS ACE.CHECKSTUFF + ACE.UPD.CONTROL.WINDOW ACE.UPD.CW.MULE ACE.UPD.CLEAR.SET.LINE + ACE.CREATE.CONTROL.MENU ACE.SEQ.FETCH.WIDTH ACE.SEQ.FETCH.HEIGHT + ACE.SET.SEQ.CLIP.REGION ACE.ASKEM2 ACE.TELLEM2 ACE.UPD.CONTROL.WINDOW2 + ACE.COMPILE.FRAME ACE.EXTRACT ACESETTHRESHOLD ACE.MAX.REGIONS + ACE.PICK.BEST.REGION ACE.COMPUTE.AREA ACE.SCAN.BITMAPS ACE.SCAN.PRIMBLOCKS + ACE.FETCH.BLOCK) + + previous date%: "16-Nov-93 13:52:56" {DSK}export>lispcore>lispusers>ACE.;2) + + +(* ; " +Copyright (c) 1988, 1993 by Michel Denber. All rights reserved. +") + +(PRETTYCOMPRINT ACECOMS) + +(RPAQQ ACECOMS + ( + (* ;; "Animation Compiler and Environment") + + + (* ;; "THIS IS THE START UP FILE FOR THE ACE SYSTEM") + + (DECLARE%: DONTCOPY (RECORDS ACE.FRAME ACE.BLIT) + (MACROS ACE.MT.SCRX.SEQX ACE.MT.SCRY.SEQY ACE.MT.SCRX.AWX ACE.MT.SCRY.AWY + ACE.MT.SEQ.SCR.REGION ACE.MT.SEQ.AW.REGION ACE.MT.AW.SCR.POINT ACE.MT.AWX.SCRX + ACE.MT.AWY.SCRY ACE.MT.AWX.SEQX ACE.MT.AWY.SEQY ACE.MT.SEQX.SCRX + ACE.MT.SEQY.SCRY ACE.MT.SEQX.AWX ACE.MT.SEQY.AWY)) + + (* ;; "ANIMATION FILES") + + (COMS * ACE-MAINCOMS) + (COMS * ACE-PRIMCOMS) + (COMS * ACE-EDITCOMS))) + + + +(* ;; "Animation Compiler and Environment") + + + + +(* ;; "THIS IS THE START UP FILE FOR THE ACE SYSTEM") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD ACE.FRAME (DELAY BLITS)) + +(RECORD ACE.BLIT (BITMAP XCOOR . YCOOR)) +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS ACE.MT.SCRX.SEQX MACRO ((SCREENXCOOR) + (IDIFFERENCE [IDIFFERENCE SCREENXCOOR (DSPXOFFSET + NIL + (WINDOWPROP ACE.SEQ.WINDOW + 'DSP] + ACE.SEQ.WINDOW.XOFF))) + +(PUTPROPS ACE.MT.SCRY.SEQY MACRO ((SCREENYCOOR) + (IDIFFERENCE [IDIFFERENCE SCREENYCOOR (DSPYOFFSET + NIL + (WINDOWPROP ACE.SEQ.WINDOW + 'DSP] + ACE.SEQ.WINDOW.YOFF))) + +[PUTPROPS ACE.MT.SCRX.AWX MACRO ((SCREENXCOOR) + (IDIFFERENCE SCREENXCOOR (DSPXOFFSET NIL (WINDOWPROP ACE.SEQ.WINDOW + 'DSP] + +[PUTPROPS ACE.MT.SCRY.AWY MACRO ((SCREENYCOOR) + (IDIFFERENCE SCREENYCOOR (DSPYOFFSET NIL (WINDOWPROP ACE.SEQ.WINDOW + 'DSP] + +(PUTPROPS ACE.MT.SEQ.SCR.REGION MACRO (NIL (CREATEREGION (ACE.MT.SEQX.SCRX 0) + (ACE.MT.SEQY.SCRY 0) + ACE.SEQ.WIDTH ACE.SEQ.HEIGHT))) + +(PUTPROPS ACE.MT.SEQ.AW.REGION MACRO (NIL (CREATEREGION ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF + ACE.SEQ.WIDTH ACE.SEQ.HEIGHT))) + +[PUTPROPS ACE.MT.AW.SCR.POINT MACRO ((POINT) + (CONS (ACE.MT.AWX.SCRX (CAR POINT)) + (ACE.MT.AWY.SCRY (CDR POINT] + +[PUTPROPS ACE.MT.AWX.SCRX MACRO ((WINDOWXCOOR) + (IPLUS WINDOWXCOOR (DSPXOFFSET NIL (WINDOWPROP ACE.SEQ.WINDOW + 'DSP] + +[PUTPROPS ACE.MT.AWY.SCRY MACRO ((WINDOWYCOOR) + (IPLUS WINDOWYCOOR (DSPYOFFSET NIL (WINDOWPROP ACE.SEQ.WINDOW + 'DSP] + +(PUTPROPS ACE.MT.AWX.SEQX MACRO ((WINDOWX) + (IDIFFERENCE WINDOWX ACE.SEQ.WINDOW.XOFF))) + +(PUTPROPS ACE.MT.AWY.SEQY MACRO ((WINDOWY) + (IDIFFERENCE WINDOWY ACE.SEQ.WINDOW.YOFF))) + +[PUTPROPS ACE.MT.SEQX.SCRX MACRO ((SEQXCOOR) + (IPLUS ACE.SEQ.WINDOW.XOFF (ACE.MT.AWX.SCRX SEQXCOOR] + +[PUTPROPS ACE.MT.SEQY.SCRY MACRO ((SEQYCOOR) + (IPLUS ACE.SEQ.WINDOW.YOFF (ACE.MT.AWY.SCRY SEQYCOOR] + +(PUTPROPS ACE.MT.SEQX.AWX MACRO ((SEQXCOOR) + (IPLUS SEQXCOOR ACE.SEQ.WINDOW.XOFF))) + +(PUTPROPS ACE.MT.SEQY.AWY MACRO ((SEQYCOOR) + (IPLUS SEQYCOOR ACE.SEQ.WINDOW.YOFF))) +) +) + + + +(* ;; "ANIMATION FILES") + + +(RPAQQ ACE-MAINCOMS + [(* MAIN TOP LEVEL STUFF) + (FNS ACE ACE.ANIMATE ACE.RUN ACEGETFRAME# ACERUNLOOP ACE.NEW.SEQUENCE ACE.NEW.FRAME + ACE.QUIT.ACE ACE.RESET.SEQ ACE.RUN.CURRENT.SEQ ACE.DELAY ACE.DELAY.FRAME ACE.DELAY.SEQ + ACE.DECREMENT.FRAME ACE.INCREMENT.FRAME ACE.DELETE.FRAME ACE.SET.DEVICE + ACE.QUICKDRAW&UPD ACE.RECONSTRUCT.FRAME SUBLIST) + (* TRILLIUM STUFF) + (FNS ACE.TRILLIUM ACE.TRILLIUM.LOOP ACE.RUN.TRILLIUM ACE.QUIT.TRILLIUM + ACE.CREATE.EDITING.BORDER) + (* I/O STUFF) + (FNS ACE.GET.SEQ.FILE ACE.PUT.SEQ.FILE ACE.GET.A.FILE.NAME) + (* HELPER FNS) + (FNS ACE.ASKEM ACE.TELLEM ACE.CONFIRMIT ACE.DEFINE.SEQ.WINDOW ACE.FIGURE.OUT.WINDOW + ACE.RETURN.CLOSEST.VERTEX ACE.NEW.SEQ.ASST ACE.DELAY.FRAME.ASST + ACE.SETUP.CW.CLIPPING.REGIONS ACE.CHECKSTUFF ACE.UPD.CONTROL.WINDOW ACE.UPD.CW.MULE + ACE.UPD.CLEAR.SET.LINE ACE.CREATE.CONTROL.MENU ACE.SEQ.FETCH.WIDTH ACE.SEQ.FETCH.HEIGHT + ACE.SET.SEQ.CLIP.REGION ACE.ASKEM2 ACE.TELLEM2 ACE.UPD.CONTROL.WINDOW2) + (* The following Macros set up restricting clipping regions) + (MACROS ACE.MAC.CW.INFO.CLIP ACE.MAC.CW.PROMPT.CLIP ACE.MAC.SEQ.CLIP) + (MACROS ACE.MAC.FETCH.WIDTH ACE.MAC.FETCH.HEIGHT) + (CURSORS ACE.LEFTMOUSE.CURSOR ACE.MIDDLEMOUSE.CURSOR ACE.RIGHTMOUSE.CURSOR + ACE.ALLMOUSE.CURSOR) + (GLOBALVARS ACE.CONTROL.WINDOW ACE.DIRECTORY ACE.SEQ.WINDOW ACE.SEQ.WIDTH ACE.SEQ.HEIGHT + ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF ACE.CURRENT.SEQUENCE ACE.CURRENT.SEQUENCE.NAME + ACE.FRAME.TAIL ACE.CURRENT.FRAME ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD + ACE.RUNNING.UNDER.TRILLIUM ACE.LEFTMOUSE.CURSOR ACE.MIDDLEMOUSE.CURSOR + ACE.RIGHTMOUSE.CURSOR ACE.ALLMOUSE.CURSOR) + (* MENUS IN MAIN) + (GLOBALVARS ACE.CONTROL.MENU ACE.DELAY.MENU ACE.SET.DEVICE.MENU) + (P (SETQ ACE.CONTROL.WINDOW NIL) + (SETQ ACE.CONTROL.MENU NIL) + (SETQ ACE.DELAY.MENU NIL) + (SETQ ACE.SET.DEVICE.MENU NIL)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA]) + + + +(* MAIN TOP LEVEL STUFF) + +(DEFINEQ + +(ACE + [LAMBDA (SEQUENCE WINDOW POSITION APPLICATION) (* MD "14-Jun-85 17:34") + + (* Top level function to run animation. + All ARGs are optional (No ARGs means just run "normal" ACE); + Current APPLICATIONs are NIL (Normal) and TRILLIUM. + If TRILLIUM, then POSITION is necessary + (and WINDOW very highly reccommended!); + ACE creates ACE.CONTROL.WINDOW and menu if necessary; + then decides about APPLICATION) + + (PROG (FONT TEMP.REGION) + (OR ACE.CONTROL.MENU (ACE.CREATE.CONTROL.MENU)) + (SETQ FONT (FONTCREATE 'HELVETICA 10 'BOLD)) + (COND + ((WINDOWP ACE.CONTROL.WINDOW) + (TOTOPW ACE.CONTROL.WINDOW)) + (T (SETQ ACE.CONTROL.WINDOW (CREATEW (LIST 500 500 (IPLUS 2 (fetch IMAGEWIDTH + of ACE.CONTROL.MENU)) + (IPLUS (ITIMES 4 (FONTPROP FONT 'HEIGHT)) + (fetch IMAGEHEIGHT of + ACE.CONTROL.MENU + ) + 25)) + (CONCAT "ACE v. " "2.1" " Control Window") + 1)) + (DSPFONT FONT ACE.CONTROL.WINDOW) + (WINDOWPROP ACE.CONTROL.WINDOW 'RESHAPEFN 'DON'T) + (WINDOWPROP ACE.CONTROL.WINDOW 'REPAINTFN 'DON'T) + (ACE.SETUP.CW.CLIPPING.REGIONS ACE.CONTROL.MENU))) + (ACE.TELLEM "Position This Window" T) + (WINDOWPROP ACE.CONTROL.WINDOW 'MOVEFN NIL) + (MOVEW ACE.CONTROL.WINDOW) + (SETQ ACE.AREA.THRESHOLD 50) + (SETQ ACE.VERTICAL.BLOCK 16) + (SETQ ACE.CURRENT.SEQUENCE.NAME NIL) + (COND + ((EQ APPLICATION 'TRILLIUM) + (RETURN (ACE.TRILLIUM WINDOW SEQUENCE POSITION))) + (T (SETQ ACE.RUNNING.UNDER.TRILLIUM NIL) + (SETQ ACE.DIRECTORY (ACE.ASKEM "Animation Directory? " T LOGINHOST/DIR)) + (ACE.TELLEM "If using the Tablet," T) + (ACE.TELLEM "Be sure and Initialize it." 'L) + (SETQ ACE.SEQ.WINDOW NIL) + (SETQ ACE.SEQ.WIDTH NIL) + (SETQ ACE.SEQ.HEIGHT NIL) + (SETQ ACE.SEQ.WINDOW.XOFF 0) + (SETQ ACE.SEQ.WINDOW.YOFF 0) + (SETQ ACE.CURRENT.SEQUENCE NIL) + (SETQ ACE.FRAME.TAIL NIL) + (SETQ ACE.CURRENT.FRAME NIL) + (replace (MENU WHENSELECTEDFN) of ACE.CONTROL.MENU with 'ACE.ANIMATE) + (ADDMENU ACE.CONTROL.MENU ACE.CONTROL.WINDOW (CONS 0 0)) + (ACE.UPD.CONTROL.WINDOW 'RESET]) + +(ACE.ANIMATE + [LAMBDA (ITEM WHO CARES) (* MD "26-Jun-85 14:21") + + (* When running "normal" ACE, this is the WHENSELECTEDFN for deciding what to + do. ITEM is the only ARG of significance + (WHO & CARES just to keep MENU package happy); + "TRILLIUM ACE" has its own loop thingy) + + (ACE.TELLEM "" T) + (SELECTQ (CADADR ITEM) + (NIL NIL) + (FRAME (ACE.NEW.FRAME)) + (EDIT (ACE.EDIT)) + (RUN (ACE.RUN.CURRENT.SEQ)) + (LOOP (ACERUNLOOP 1 'END)) + (SUBLOOP (ACEGETFRAME#)) + (NEW (ACE.NEW.SEQUENCE)) + (I/O%:GET (ACE.GET.SEQ.FILE)) + (I/O%:PUT (ACE.PUT.SEQ.FILE)) + (DEL (ACE.DELETE.FRAME)) + (RESET (ACE.RESET.SEQ)) + (INC (ACE.INCREMENT.FRAME)) + (DEC (ACE.DECREMENT.FRAME)) + (TIME (ACE.DELAY)) + (INIT.MM1201 (ACE.MM1201.INIT T)) + (DEVICE (ACE.SET.DEVICE)) + (ACESETTHRESHOLD + (ACESETTHRESHOLD)) + (QUIT (ACE.QUIT.ACE)) + NIL) + (AND (OPENWP ACE.CONTROL.WINDOW) + (ACE.UPD.CONTROL.WINDOW 'UPD)) + (TTY.PROCESS T]) + +(ACE.RUN + [LAMBDA (SEQ WINDOW XOFFSET YOFFSET TIMER) (* PmT "18-Apr-85 18:21") + + (* This runs animation sequences. Simple, eh? Gots to have a SEQ and a WINDOW + to show it in, and where in the window to show it + (i.e. XOFFSET YOFFSET); TIMER is wholly unecessary NOTE%: this thang doesn't + use any clipping region, just an offset) + + (for FRAME in SEQ do ((SETQ TIMER (SETUPTIMER (fetch (ACE.FRAME DELAY) + of FRAME) + TIMER + 'MILLISECONDS)) + (for FRAME.PART in (fetch (ACE.FRAME BLITS) + of FRAME) + do (BITBLT (fetch (ACE.BLIT BITMAP) of + FRAME.PART + ) + NIL NIL WINDOW (IPLUS XOFFSET + (fetch (ACE.BLIT + XCOOR) + of FRAME.PART)) + (IPLUS YOFFSET (fetch (ACE.BLIT YCOOR) + of FRAME.PART)) + NIL NIL 'INPUT 'REPLACE)) + (until (TIMEREXPIRED? TIMER 'MILLISECONDS) do]) + +(ACEGETFRAME# + [LAMBDA NIL (* MD "27-Jun-85 12:51") + (ACERUNLOOP (RNUMBER "From frame #") + (RNUMBER "To frame #:"]) + +(ACERUNLOOP + [LAMBDA (START END) (* MD "26-Jun-85 17:07") + (if (EQ END 'END) + then (SETQ END (LENGTH ACE.CURRENT.SEQUENCE))) + [ACE.QUICKDRAW&UPD (LIST (CAR (NTH ACE.CURRENT.SEQUENCE START] + (until (KEYDOWNP 'SPACE) do (ACE.RUN (SUBLIST ACE.CURRENT.SEQUENCE START END) + ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF + ]) + +(ACE.NEW.SEQUENCE + [LAMBDA (REGION) (* PmT "30-Apr-85 16:21") + (PROG (TEMP.REGION) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "NEW") + (COND + ((OR (NULL ACE.CURRENT.SEQUENCE) + (ACE.TELLEM "Creating a NEW Sequence will ERASE" T) + (ACE.TELLEM "the Current Animation Sequence." 'L) + (ACE.CONFIRMIT "Click LEFT to Create NEW Sequence." 'L)) + [COND + ((REGIONP REGION) + (SETQ TEMP.REGION REGION)) + (T (ACE.TELLEM "Specify SIZE of the NEW Sequence." T) + (ACE.TELLEM "Watch ACE window for COORs." 'L) + (SETQ TEMP.REGION (GETREGION NIL NIL NIL 'ACE.NEW.SEQ.ASST NIL] + (SETQ ACE.SEQ.WIDTH (fetch (REGION WIDTH) of TEMP.REGION)) + (SETQ ACE.SEQ.HEIGHT (fetch (REGION HEIGHT) of TEMP.REGION)) + [SETQ ACE.CURRENT.SEQUENCE (LIST (create ACE.FRAME + DELAY _ 0 + BLITS _ + (LIST (create ACE.BLIT + BITMAP _ (BITMAPCREATE + ACE.SEQ.WIDTH + ACE.SEQ.HEIGHT 1) + XCOOR _ 0 + YCOOR _ 0] + (ACE.FIGURE.OUT.WINDOW) + (ACE.QUICKDRAW&UPD (LIST (CAR ACE.CURRENT.SEQUENCE]) + +(ACE.NEW.FRAME + [LAMBDA NIL (* PmT "24-Jan-85 13:22") + (ACE.UPD.CONTROL.WINDOW 'OPERATION "FRAME") + (COND + ([NULL (AND (ACE.CHECKSTUFF 'SEQ) + (OR (ACE.CHECKSTUFF 'FRAME) + (ACE.TELLEM "Can't put a frame before the First Frame." T] + NIL) + (T (RPLACD ACE.CURRENT.FRAME (CONS (create ACE.FRAME + DELAY _ 0 + BLITS _ NIL) + (CDR ACE.CURRENT.FRAME))) + (SETQ ACE.CURRENT.FRAME (CDR ACE.CURRENT.FRAME)) + (SETQ ACE.FRAME.TAIL (CDR ACE.CURRENT.FRAME)) + (ACE.TELLEM "Going to EDIT ..." T) + (ACE.EDIT]) + +(ACE.QUIT.ACE + [LAMBDA NIL (* MD "24-Jun-85 14:49") + (ACE.UPD.CONTROL.WINDOW 'OPERATION "QUIT") + (ACE.TELLEM "QUITing will Close All Animation Windows;" T) + (ACE.TELLEM "All Images and Data will be LOST." 'L) + (COND + ((ACE.CONFIRMIT "Click LEFT to QUIT." 'L) + (CLOSEW ACE.SEQ.WINDOW) + (CLOSEW ACE.CONTROL.WINDOW) + ACE.CURRENT.SEQUENCE) + (T + + (* MAKE THIS BE SOME KINDA ICON IN THE FUTURE; + ASK%: DO YOU WANT TO QUIT COMPLETELY OR JUST STOP FOR A WHILE) + + (ACE.TELLEM "QUIT Aborted." T]) + +(ACE.RESET.SEQ + [LAMBDA NIL (* PmT "30-Apr-85 16:37") + (ACE.UPD.CONTROL.WINDOW 'OPERATION "RESET") + (COND + [(AND ACE.SEQ.WINDOW (ACE.CHECKSTUFF 'SEQ)) + (ACE.QUICKDRAW&UPD (LIST (CAR ACE.CURRENT.SEQUENCE] + (T (ACE.TELLEM "There is No Current Sequence." T]) + +(ACE.RUN.CURRENT.SEQ + [LAMBDA NIL (* PmT "18-Apr-85 18:23") + (* just a pretty interface to + ACE.RUN) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "RUN") + (COND + ((ACE.CHECKSTUFF 'SEQ) + (RECLAIM) + (ACE.RUN ACE.FRAME.TAIL ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF) + (SETQ ACE.FRAME.TAIL NIL) + (SETQ ACE.CURRENT.FRAME (LAST ACE.CURRENT.SEQUENCE]) + +(ACE.DELAY + [LAMBDA NIL (* PmT " 2-May-85 20:53") + (* For setting delays + (in MSECs) between frames. + Lots of work needed here; + esp. delay in-betweening) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "DELAY") + (SELECTQ [MENU (OR ACE.DELAY.MENU (SETQ ACE.DELAY.MENU (create MENU + ITEMS _ + '(("Set Delay on a Frame" + 'FDELAY + "Adjust the delay on any frame by number" + ) + ("Reset Entire Sequence" + 'SDELAY + "Set the delay on every frame")) + CENTERFLG _ T + TITLE _ + "Sequence Timing Adjustments"] + (NIL NIL) + (SDELAY (ACE.DELAY.SEQ)) + (FDELAY (ACE.DELAY.FRAME)) + NIL]) + +(ACE.DELAY.FRAME + [LAMBDA NIL (* MD "21-Jun-85 14:14") + (PROG (CHOICE FRAME) + LOOP + [SETQ CHOICE (MENU (create MENU + ITEMS _ (NCONC1 (for FRAME in ACE.CURRENT.SEQUENCE + bind (COUNT _ 0) + collect + ((SETQ COUNT (ADD1 COUNT)) + (LIST (CONCAT "Frame " COUNT " : " + (fetch (ACE.FRAME DELAY) + of FRAME)) + COUNT))) + '(Quit 'QUIT "Stop adjusting delays")) + TITLE _ "Frame Delays" + WHENHELDFN _ 'ACE.DELAY.FRAME.ASST] + [COND + ((NULL CHOICE) + NIL) + ((EQ CHOICE 'QUIT) + (RETURN NIL)) + (T (SETQ FRAME (CAR (NTH ACE.CURRENT.SEQUENCE CHOICE))) + (AND FRAME (replace (ACE.FRAME DELAY) of FRAME + with (SETQ CHOICE (RNUMBER (CONCAT "Frame " CHOICE "; New Delay: "] + (GO LOOP]) + +(ACE.DELAY.SEQ + [LAMBDA NIL (* MD "21-Jun-85 14:31") + (PROG (NEW.DELAY.VALUE) + (COND + [(FIXP (SETQ NEW.DELAY.VALUE (RNUMBER "Delay for entire sequence:"] + (T (RETURN NIL))) + (for FRAME in ACE.CURRENT.SEQUENCE do (replace (ACE.FRAME DELAY) + of FRAME with NEW.DELAY.VALUE]) + +(ACE.DECREMENT.FRAME + [LAMBDA NIL (* PmT "21-Dec-84 14:12") + (ACE.UPD.CONTROL.WINDOW 'OPERATION "DEC") + (AND (ACE.CHECKSTUFF 'SEQ) + (ACE.CHECKSTUFF 'FRAME) + (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME]) + +(ACE.INCREMENT.FRAME + [LAMBDA NIL (* MD "18-Jun-85 16:12") + (PROG (CUR.FRAME) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "INC") + (COND + ([NULL (AND (ACE.CHECKSTUFF 'SEQ) + (ACE.CHECKSTUFF 'TAIL] + NIL) + (T (SETQ CUR.FRAME (CAR ACE.FRAME.TAIL)) + (SETQ ACE.CURRENT.FRAME ACE.FRAME.TAIL) + (SETQ ACE.FRAME.TAIL (CDR ACE.FRAME.TAIL)) + (COND + ((NULL (fetch (ACE.FRAME BLITS) of CUR.FRAME)) + NIL) + (T (ACE.MAC.SEQ.CLIP (for FRAME.PART in (fetch (ACE.FRAME BLITS) + of CUR.FRAME) + do (BITBLT (fetch (ACE.BLIT BITMAP) of + FRAME.PART + ) + NIL NIL ACE.SEQ.WINDOW + (IPLUS ACE.SEQ.WINDOW.XOFF + (fetch (ACE.BLIT XCOOR) + of FRAME.PART)) + (IPLUS ACE.SEQ.WINDOW.YOFF + (fetch (ACE.BLIT YCOOR) + of FRAME.PART)) + NIL NIL 'INPUT 'REPLACE]) + +(ACE.DELETE.FRAME + [LAMBDA NIL (* PmT "24-Apr-85 14:19") + (* Deletes the current frame; + recompiles the previous frame with + the successor frame) + (PROG (BEFORE.BM AFTER.BM) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "DELETE") + (COND + ([NULL (AND (ACE.CHECKSTUFF 'SEQ) + (ACE.CHECKSTUFF 'FRAME] + NIL) + ((EQ ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME) + (ACE.TELLEM "Can't DELETE first frame. Aborted." T)) + ((NULL (ACE.CONFIRMIT "Click LEFT to Confirm Delete" T)) + NIL) + ((NULL ACE.FRAME.TAIL) + (SETQ ACE.CURRENT.SEQUENCE (LDIFF ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME)) + (ACE.QUICKDRAW&UPD ACE.CURRENT.SEQUENCE)) + (T (SETQ BEFORE.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE + ACE.CURRENT.FRAME))) + [SETQ AFTER.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE (CDR + ACE.FRAME.TAIL + ] + (replace (ACE.FRAME BLITS) of (CAR ACE.CURRENT.FRAME) + with (ACE.COMPILE.FRAME BEFORE.BM AFTER.BM ACE.VERTICAL.BLOCK + ACE.AREA.THRESHOLD)) + (RPLACD ACE.CURRENT.FRAME (CDR ACE.FRAME.TAIL)) + (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE (CDR ACE.CURRENT.FRAME]) + +(ACE.SET.DEVICE + [LAMBDA NIL (* PmT "23-Apr-85 13:44") + (* Selects MOUSE or TABLET as the + primary input device) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "SET DEVICE") + (ACE.UPD.CONTROL.WINDOW 'DEVICE) + (ACE.UPD.CONTROL.WINDOW 'DEVICE (MENU (OR ACE.SET.DEVICE.MENU + (SETQ ACE.SET.DEVICE.MENU + (create MENU + ITEMS _ '(("Mouse" 'MOUSE + "Use the standard mouse for drawing and such" + ) + ("Tablet" 'MM1201 + "Use the MM1201 Tablet as the input device" + )) + TITLE _ "Select Input Device" + CENTERFLG _ T]) + +(ACE.QUICKDRAW&UPD + [LAMBDA (PARTIAL.SEQ) (* PmT "30-Apr-85 16:11") + + (* Updates the frame showing in the A.S.Window and update sequence pointers and + stuff. PARTIAL.SEQ is a list of frames to show; + The last frame in PARTIAL.SEQ becomes the new current frame) + + (COND + (PARTIAL.SEQ [ACE.MAC.SEQ.CLIP + (for FRAME in PARTIAL.SEQ + do (COND + ((NULL (fetch (ACE.FRAME BLITS) of FRAME)) + NIL) + (T (for FRAME.PART in (fetch (ACE.FRAME BLITS) + of FRAME) + do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART + ) + NIL NIL ACE.SEQ.WINDOW + (IPLUS ACE.SEQ.WINDOW.XOFF (fetch + (ACE.BLIT XCOOR) + of FRAME.PART + )) + (IPLUS ACE.SEQ.WINDOW.YOFF (fetch + (ACE.BLIT YCOOR) + of FRAME.PART + )) + NIL NIL 'INPUT 'REPLACE] + (SETQ ACE.CURRENT.FRAME ACE.CURRENT.SEQUENCE) + (for X from 1 to (SUB1 (LENGTH PARTIAL.SEQ)) do (SETQ ACE.CURRENT.FRAME + (CDR ACE.CURRENT.FRAME + ))) + (SETQ ACE.FRAME.TAIL (CDR ACE.CURRENT.FRAME]) + +(ACE.RECONSTRUCT.FRAME + [LAMBDA (SEQ) (* PmT "18-Apr-85 18:54") + + (* Creates a bitmap out of SEQ; Essentially, the last virtual frame in SEQ is + converted to a "real" frame and returned) + + (PROG (ABITMAP) + [SETQ ABITMAP (BITMAPCOPY (fetch (ACE.BLIT BITMAP) of (CAR (fetch (ACE.FRAME + BLITS) + of (CAR SEQ] + [for FRAME in (CDR SEQ) + do (COND + ((NULL (fetch (ACE.FRAME BLITS) of FRAME))) + (T (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) + do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) + NIL NIL ABITMAP (fetch (ACE.BLIT XCOOR) of + FRAME.PART + ) + (fetch (ACE.BLIT YCOOR) of FRAME.PART) + NIL NIL 'INPUT 'REPLACE] + (RETURN ABITMAP]) + +(SUBLIST + [LAMBDA (L M N) (* MD "26-Jun-85 16:00") + (LDIFF (NTH L M) + (NTH L (ADD1 N]) +) + + + +(* TRILLIUM STUFF) + +(DEFINEQ + +(ACE.TRILLIUM + [LAMBDA (WINDOW SEQUENCE POSITION) (* PmT "30-Apr-85 16:44") + + (* This here sets up stuff for running animation + (functionally) from Trillium. ARGS%: WINDOW is opt + (but really should be given)%, SEQUENCE is opt, POSITION *MUST* be given; + if not, ACE bags it (Trillium must always supply a place to put the animation!) + %: This FN just checks args and sets the state of ACE, then calls the actual "polling" + FN NOTE%: This should only be called from ACE; + take a look at ACE) + + (PROG NIL + (SETQ ACE.RUNNING.UNDER.TRILLIUM T) + (DISPLAY.FRAME CURRENT.FRAME) (* See if got a valid window or not) + [COND + ((WINDOWP WINDOW) + (SETQ ACE.SEQ.WINDOW WINDOW)) + (T (ACE.TELLEM "There is no Window Specification" T) + (COND + ((ACE.CONFIRMIT "Click LEFT to use Current Interface Window." 'L) + (SETQ ACE.SEQ.WINDOW CURRENT.INTERFACE.WINDOW)) + (T (ACE.TELLEM "Error in Window Specification." T) + (ACE.TELLEM "Likely a Trillium error. ACE aborted." 'L) + (ACE.CONFIRMIT "Click any button to Exit." 'L 'ANY) + (RETURN NIL] (* The following *might* be used + instead of a window error; + you decide) + (* SETQ ACE.SEQ.WINDOW + (EVAL (ACE.ASKEM + "Enter the Name of the Window: " T + NIL 60))) + (* Was given a valid postion?) + (COND + ((POSITIONP POSITION) + (SETQ ACE.SEQ.WINDOW.XOFF (fetch (POSITION XCOORD) of POSITION)) + (SETQ ACE.SEQ.WINDOW.YOFF (fetch (POSITION YCOORD) of POSITION))) + (T (ACE.TELLEM "No Position Specification. Aborted." T) + (ACE.TELLEM "This is likely a Trillium error." 'L) + (ACE.CONFIRMIT "Click any button to Exit." 'L 'ANY) + (RETURN NIL))) (* Now check if given a sequence) + (COND + ((LISTP SEQUENCE) + (SETQ ACE.CURRENT.SEQUENCE SEQUENCE) + (SETQ ACE.CURRENT.FRAME ACE.CURRENT.SEQUENCE) + (SETQ ACE.FRAME.TAIL (CDR ACE.CURRENT.FRAME)) + (SETQ ACE.SEQ.WIDTH (ACE.SEQ.FETCH.WIDTH)) + (SETQ ACE.SEQ.HEIGHT (ACE.SEQ.FETCH.HEIGHT)) + (ACE.CREATE.EDITING.BORDER) + (ACE.SET.SEQ.CLIP.REGION)) + (T (SETQ ACE.CURRENT.SEQUENCE NIL) + (SETQ ACE.FRAME.TAIL NIL) + (SETQ ACE.CURRENT.FRAME NIL))) (* The WHENSELECTEDFN is different + for Trillium; make it act like a + regular old menu) + (replace (MENU WHENSELECTEDFN) of ACE.CONTROL.MENU with 'DEFAULTWHENSELECTEDFN) + (SETQ ACE.DIRECTORY (DIRECTORYNAME T T)) + (AND ACE.CURRENT.SEQUENCE (ACE.RESET.SEQ)) + (ACE.UPD.CONTROL.WINDOW 'RESET) (* Lock down window so menu coors + only figured once; + see ACE.TRILLIUM.LOOP) + (WINDOWPROP ACE.CONTROL.WINDOW 'MOVEFN 'DON'T) + (RETURN (ACE.TRILLIUM.LOOP]) + +(ACE.TRILLIUM.LOOP + [LAMBDA NIL (* PmT "18-Apr-85 18:41") + (* This is the repeating loop for + Trillium-Ace; just sits in here till + QUIT) + (PROG (CHOICE MENU.POS) + [SETQ MENU.POS (CONS (DSPXOFFSET NIL (WINDOWPROP ACE.CONTROL.WINDOW 'DSP)) + (DSPYOFFSET NIL (WINDOWPROP ACE.CONTROL.WINDOW 'DSP] + LOOP + (ACE.TELLEM "" T) + (SELECTQ (SETQ CHOICE (MENU ACE.CONTROL.MENU MENU.POS)) + (NIL NIL) + (FRAME (ACE.NEW.FRAME)) + (EDIT (ACE.EDIT)) + (RUN (ACE.RUN.CURRENT.SEQ)) + (NEW (ACE.NEW.SEQUENCE)) + (I/O%:GET (ACE.GET.SEQ.FILE)) + (I/O%:PUT (ACE.PUT.SEQ.FILE)) + (DEL (ACE.DELETE.FRAME)) + (RESET (ACE.RESET.SEQ)) + (INC (ACE.INCREMENT.FRAME)) + (DEC (ACE.DECREMENT.FRAME)) + (TIME (ACE.DELAY)) + (INIT.MM1201 (ACE.MM1201.INIT T)) + (DEVICE (ACE.SET.DEVICE)) + (QUIT NIL) + NIL) + (ACE.UPD.CONTROL.WINDOW 'UPD) + (OR (EQ CHOICE 'QUIT) + (GO LOOP)) + (RETURN (ACE.QUIT.TRILLIUM]) + +(ACE.RUN.TRILLIUM + [LAMBDA (SEQ WINDOW XOFFSET YOFFSET UPTO TIMER) (* PmT "18-Apr-85 18:45") + + (* Just like ACE.RUN except UPTO can be a FIXP denoting a frame; + If UPTO is given, that frame is displayed + (without delays); Good for initializing in Trillium) + + (COND + [(NULL UPTO) + (for FRAME in SEQ do ((SETQ TIMER (SETUPTIMER (fetch (ACE.FRAME DELAY) + of FRAME) + TIMER + 'MILLISECONDS)) + (for FRAME.PART in (fetch (ACE.FRAME BLITS) + of FRAME) + do (BITBLT (fetch (ACE.BLIT BITMAP) of + FRAME.PART) + NIL NIL WINDOW (IPLUS XOFFSET + (fetch + (ACE.BLIT XCOOR) + of FRAME.PART + )) + (IPLUS YOFFSET (fetch (ACE.BLIT YCOOR) + of FRAME.PART)) + NIL NIL 'INPUT 'REPLACE)) + (until (TIMEREXPIRED? TIMER 'MILLISECONDS) do] + ((AND (FIXP UPTO) + (IGREATERP (ADD1 (LENGTH SEQ)) + UPTO) + (IGREATERP UPTO 0)) + (for FRAME in (LDIFF SEQ (NTH SEQ (ADD1 UPTO))) + do (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) + do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) + NIL NIL WINDOW (IPLUS XOFFSET (fetch (ACE.BLIT XCOOR) + of FRAME.PART)) + (IPLUS YOFFSET (fetch (ACE.BLIT YCOOR) of FRAME.PART)) + NIL NIL 'INPUT 'REPLACE]) + +(ACE.QUIT.TRILLIUM + [LAMBDA NIL (* PmT "15-Mar-85 13:48") + (CLOSEW ACE.CONTROL.WINDOW) + (SETQ ACE.RUNNING.UNDER.TRILLIUM NIL) + ACE.CURRENT.SEQUENCE]) + +(ACE.CREATE.EDITING.BORDER + [LAMBDA (MODE) (* PmT "30-Apr-85 16:42") + (PROG (X1 X2 Y1 Y2) + (OR MODE (SETQ MODE 'PAINT)) + (COND + ((AND (NUMBERP ACE.SEQ.WIDTH) + (NUMBERP ACE.SEQ.HEIGHT)) + (SETQ X1 (IDIFFERENCE ACE.SEQ.WINDOW.XOFF 2)) + (SETQ X2 (IPLUS ACE.SEQ.WINDOW.XOFF ACE.SEQ.WIDTH)) + (SETQ Y1 (IDIFFERENCE ACE.SEQ.WINDOW.YOFF 2)) + (SETQ Y2 (IPLUS ACE.SEQ.WINDOW.YOFF ACE.SEQ.HEIGHT)) + (DRAWLINE X1 Y1 X1 Y2 2 MODE ACE.SEQ.WINDOW) + (DRAWLINE X1 Y2 X2 Y2 2 MODE ACE.SEQ.WINDOW) + (DRAWLINE X2 Y2 X2 Y1 2 MODE ACE.SEQ.WINDOW) + (DRAWLINE X2 Y1 X1 Y1 2 MODE ACE.SEQ.WINDOW]) +) + + + +(* I/O STUFF) + +(DEFINEQ + +(ACE.GET.SEQ.FILE + [LAMBDA NIL (* PmT "25-Apr-85 21:18") + (* Gets an animation sequence. + Resets ACE.CURRENT.SEQUENCE and the + sequence clipping region) + (RESETFORM (TTYDISPLAYSTREAM \TopLevelTtyWindow) + (PROG (FILENAME TEMP.SEQUENCE.NAME) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "GET FILE") + (OR (NULL ACE.CURRENT.SEQUENCE) + (ACE.TELLEM "Loading a Sequence will ERASE the Current" T) + (ACE.CONFIRMIT "Sequence; Click LEFT to confirm LOAD." 'L) + (ACE.TELLEM "Get Sequence ABORTED." T) + (RETURN NIL)) + (SETQ FILENAME (ACE.GET.A.FILE.NAME)) + [COND + ((NULL FILENAME) + (ACE.TELLEM "No NAME. Aborted" T) + (RETURN NIL)) + (T (SETQ FILENAME (PACKFILENAME 'BODY FILENAME 'HOST (FILENAMEFIELD ACE.DIRECTORY + 'HOST) + 'DIRECTORY + (FILENAMEFIELD ACE.DIRECTORY 'DIRECTORY] + (ACE.TELLEM "Loading: " T) + (ACE.TELLEM (CONCAT FILENAME " ... ") + 'L) + (RESETLST + [RESETSAVE (PROGN (CURSOR WAITINGCURSOR) + (SETTOPVAL 'HELPFLAG NIL)) + (LIST 'PROGN (LIST 'CURSOR 'DEFAULTCURSOR) + (LIST 'SETTOPVAL ''HELPFLAG (KWOTE (GETTOPVAL 'HELPFLAG] + [SETQ TEMP.SEQUENCE.NAME (CAR (ERRORSET '(LOAD FILENAME 'SYSLOAD) + 'NOBREAK]) + (COND + (TEMP.SEQUENCE.NAME (SETQ ACE.CURRENT.SEQUENCE.NAME TEMP.SEQUENCE.NAME) + (SETQ ACE.SEQ.WIDTH (ACE.SEQ.FETCH.WIDTH)) + (SETQ ACE.SEQ.HEIGHT (ACE.SEQ.FETCH.HEIGHT)) + (ACE.FIGURE.OUT.WINDOW) + (ACE.RESET.SEQ)) + (T (ACE.TELLEM "Not Found.") + (ACE.TELLEM "No Such File or File Server Problems." 'L]) + +(ACE.PUT.SEQ.FILE + [LAMBDA NIL (* PmT " 2-May-85 20:50") + (* Writes a sequence to a file; + the file is NOT pretty printed) + (PROG (FILENAME TEMP.SEQUENCE.NAME) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "PUT FILE") + [COND + ((NULL (ACE.CHECKSTUFF 'SEQ)) + (RETURN NIL)) + ((AND ACE.CURRENT.SEQUENCE.NAME (ACE.CONFIRMIT "Click LEFT to Keep Same Name." T)) + (SETQ FILENAME ACE.CURRENT.SEQUENCE.NAME)) + (T (SETQ FILENAME (ACE.GET.A.FILE.NAME)) + (COND + ((NULL FILENAME) + (ACE.TELLEM "NIL ain't no good. Aborted." T) + (RETURN NIL))) + (SETQ FILENAME (PACKFILENAME 'BODY FILENAME 'HOST (FILENAMEFIELD ACE.DIRECTORY + 'HOST) + 'DIRECTORY + (FILENAMEFIELD ACE.DIRECTORY 'DIRECTORY] + (COND + ((AND (FILENAMEFIELD FILENAME 'VERSION) + (NULL (ACE.TELLEM "Click LEFT to Write a New Version." T)) + (ACE.CONFIRMIT "Click any Other to Write Over Existing Version." 'L)) + (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY FILENAME))) + (T NIL)) + [SET (PACK* (FILENAMEFIELD FILENAME 'NAME) + 'COMS) + '((UGLYVARS ACE.CURRENT.SEQUENCE] + (PUTPROP (FILENAMEFIELD FILENAME 'NAME) + 'FILETYPE + '(DON'TLIST DON'TCOMPILE)) + (ACE.TELLEM "Putting to File: " T) + (ACE.TELLEM (CONCAT FILENAME " ... ") + 'L) + (RESETLST + [RESETSAVE (PROGN (CURSOR WAITINGCURSOR) + (SETTOPVAL 'HELPFLAG NIL)) + (LIST 'PROGN (LIST 'CURSOR 'DEFAULTCURSOR) + (LIST 'SETTOPVAL ''HELPFLAG (KWOTE (GETTOPVAL 'HELPFLAG] + [SETQ TEMP.SEQUENCE.NAME (CAR (ERRORSET '(MAKEFILE FILENAME '(NEW FAST)) + 'NOBREAK]) + (COND + (TEMP.SEQUENCE.NAME (SETQ ACE.CURRENT.SEQUENCE.NAME TEMP.SEQUENCE.NAME) + (ACE.TELLEM "Done") + (DREMOVE (FILENAMEFIELD FILENAME 'NAME) + FILELST)) + (T (ACE.TELLEM "Aborted.") + (ACE.TELLEM "Nothing doing. Can't write this File out." 'L) + (ACE.TELLEM "Check the Name. Is the File Server Down?" 'L]) + +(ACE.GET.A.FILE.NAME + [LAMBDA NIL (* PmT "18-Apr-85 19:44") + (ACE.ASKEM "Enter FILENAME: " T NIL 120]) +) + + + +(* HELPER FNS) + +(DEFINEQ + +(ACE.ASKEM + [LAMBDA (STRING FLG DEFAULTANSWER TIMELIMIT? SPACES?) (* MD "14-Jun-85 16:48") + + (* a prompting fn. STRING is the prompt string; + FLG either T,L or NIL (T means clear before prompting, L means new line); + DEFAULTANSWER just what it sounds like. + TIMELIMIT? number or seconds to wait for answer + (defaults to 120); if SPACES? is T, then the answer can have spaces in it) + (* TIMELIMIT? removed - + now waits forever. + - + MJD) + (ACE.MAC.CW.PROMPT.CLIP (PROGN (OR TIMELIMIT? (SETQ TIMELIMIT? 120)) + (COND + ((EQ FLG T) + (DSPRESET ACE.CONTROL.WINDOW)) + ((EQ FLG 'L) + (TERPRI ACE.CONTROL.WINDOW))) + (MKATOM (PROMPTFORWORD STRING DEFAULTANSWER NIL ACE.CONTROL.WINDOW + NIL NIL (AND SPACES? (CHARCODE (EOL ESCAPE LF]) + +(ACE.TELLEM + [LAMBDA (STRING FLG) (* PmT "23-Apr-85 13:49") + + (* Writes STRING in the A.C.W prompt region; + FLG=T means clear prompt region first; L means new line; + NIL means put it at the next char position) + + (ACE.MAC.CW.PROMPT.CLIP (PROGN (COND + ((EQ FLG T) + (DSPRESET ACE.CONTROL.WINDOW)) + ((EQ FLG 'L) + (TERPRI ACE.CONTROL.WINDOW))) + (printout ACE.CONTROL.WINDOW STRING) + NIL]) + +(ACE.CONFIRMIT + [LAMBDA (CONFIRMSTRING FLG WHICHKEYS?) (* PmT "25-Apr-85 17:47") + + (* Prints CONFIRMSTRING in A.C.W prompt region; + then waits for the button form WHICHKEYS? to become true. + WHICHKEYS? defaults to LEFT. Code identfies the valid button forms) + + (OR WHICHKEYS? (SETQ WHICHKEYS? 'LEFT)) + (ACE.TELLEM CONFIRMSTRING FLG) + (DISMISS 100 NIL T) + (RESETFORM (CURSOR (SELECTQ WHICHKEYS? + (LEFT ACE.LEFTMOUSE.CURSOR) + (MIDDLE ACE.MIDDLEMOUSE.CURSOR) + (RIGHT ACE.RIGHTMOUSE.CURSOR) + (ANY (PROGN (SETQ WHICHKEYS? '(NOT UP)) + ACE.ALLMOUSE.CURSOR)) + NIL)) + (do (GETMOUSESTATE) until (NEQ LASTMOUSEBUTTONS 0)) + (PROG1 (EVAL (MOUSESTATE-EXPR WHICHKEYS? T)) + (do (GETMOUSESTATE) until (EQP LASTMOUSEBUTTONS 0)))]) + +(ACE.DEFINE.SEQ.WINDOW + [LAMBDA NIL (* PmT " 2-May-85 20:32") + [COND + ((ACE.CONFIRMIT "Click LEFT to Create a Sequence Window." T) + (AND ACE.SEQ.WINDOW (CLOSEW ACE.SEQ.WINDOW)) + (SETQ ACE.SEQ.WINDOW (CREATEW (LIST 50 50 (IPLUS ACE.SEQ.WIDTH 8) + (IPLUS ACE.SEQ.HEIGHT 17)) + '"Animation Sequence Window" 4)) + (ACE.TELLEM "Position the Sequence Window" T) + (MOVEW ACE.SEQ.WINDOW)) + ((AND ACE.SEQ.WINDOW (ILEQ ACE.SEQ.WIDTH (WINDOWPROP ACE.SEQ.WINDOW 'WIDTH)) + (ILEQ ACE.SEQ.HEIGHT (WINDOWPROP ACE.SEQ.WINDOW 'HEIGHT)) + (ACE.CONFIRMIT "Click LEFT to Keep Current Window." T)) + (* CLEARW ACE.SEQ.WINDOW) + ) + (T (ACE.TELLEM "CAUTION: Enter NIL if Unsure at this Stage." T) + (SETQ ACE.SEQ.WINDOW (EVAL (ACE.ASKEM "Enter the Window: " 'L NIL 120] + (OR ACE.SEQ.WINDOW (ACE.DEFINE.SEQ.WINDOW]) + +(ACE.FIGURE.OUT.WINDOW + [LAMBDA (REGION/POSITION) (* PmT "22-Apr-85 19:05") + + (* This is where all reasoning about which window to use and where offsets + should be placed goes. Right now (|4/20/85|) Trillium's just gonna go with + positions; but that should (?) change) + + (COND + (ACE.RUNNING.UNDER.TRILLIUM (DISPLAY.FRAME CURRENT.FRAME) + (ACE.CREATE.EDITING.BORDER 'INVERT) (* KEEP OFFSETS THE SAME FOR NOW) + ) + ((POSITIONP REGION/POSITION) + (SETQ ACE.SEQ.WINDOW.XOFF (CAR REGION/POSITION)) + (SETQ ACE.SEQ.WINDOW.YOFF (CDR REGION/POSITION))) + (T (SETQ ACE.SEQ.WINDOW.XOFF 0) + (SETQ ACE.SEQ.WINDOW.YOFF 0) + (ACE.DEFINE.SEQ.WINDOW))) + (ACE.SET.SEQ.CLIP.REGION]) + +(ACE.RETURN.CLOSEST.VERTEX + [LAMBDA (POINT REGION) (* PmT "28-Nov-84 16:15") + (PROG (NEW.XCOOR NEW.YCOOR) + [COND + [(IGREATERP (CAR POINT) + (SETQ NEW.XCOOR (fetch (REGION RIGHT) of REGION] + [(ILESSP (CAR POINT) + (SETQ NEW.XCOOR (fetch (REGION LEFT) of REGION] + (T (SETQ NEW.XCOOR (CAR POINT] + [COND + [(IGREATERP (CDR POINT) + (SETQ NEW.YCOOR (fetch (REGION TOP) of REGION] + [(ILESSP (CDR POINT) + (SETQ NEW.YCOOR (fetch (REGION BOTTOM) of REGION] + (T (SETQ NEW.YCOOR (CDR POINT] + (RETURN (CONS NEW.XCOOR NEW.YCOOR]) + +(ACE.NEW.SEQ.ASST + [LAMBDA (FIXED MOVE DUM) (* PmT "23-Jan-85 19:52") + (COND + ((NULL MOVE) + (ACE.UPD.CONTROL.WINDOW 'CURSOR FIXED) + FIXED) + (T [ACE.UPD.CONTROL.WINDOW 'CURSOR (CONS (ABS (IDIFFERENCE (fetch (POSITION XCOORD) + of MOVE) + (fetch (POSITION XCOORD) + of FIXED))) + (ABS (IDIFFERENCE (fetch (POSITION YCOORD) + of MOVE) + (fetch (POSITION YCOORD) + of FIXED] + MOVE]) + +(ACE.DELAY.FRAME.ASST + [LAMBDA (ITEM MENU MOUSE) (* PmT "21-Dec-84 16:42") + (COND + [(FIXP (CADR ITEM)) + (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE (CDR (NTH ACE.CURRENT.SEQUENCE + (CADR ITEM] + (T NIL]) + +(ACE.SETUP.CW.CLIPPING.REGIONS + [LAMBDA (MENU) (* PmT "23-Apr-85 13:47") + + (* Sets the clipping region on ACE.CONTROL.WINDOW; + There is a menu region, prompt region and status region) + + (PROG (NORMAL ABOVEMENU INFO) + (WINDOWPROP ACE.CONTROL.WINDOW 'NORMAL.CLIP.REGION (SETQ NORMAL (DSPCLIPPINGREGION NIL + ACE.CONTROL.WINDOW)) + ) + [WINDOWPROP ACE.CONTROL.WINDOW 'ABOVEMENU.CLIP.REGION (SETQ ABOVEMENU + (CREATEREGION + (fetch (REGION LEFT) + of NORMAL) + (fetch IMAGEHEIGHT of + MENU) + (fetch (REGION WIDTH) + of NORMAL) + (IDIFFERENCE (fetch + (REGION HEIGHT) + of NORMAL) + (fetch IMAGEHEIGHT + of MENU] + [WINDOWPROP ACE.CONTROL.WINDOW 'INFO.CLIP.REGION (SETQ INFO + (CREATEREGION (fetch (REGION LEFT) + of ABOVEMENU) + (fetch (REGION BOTTOM) + of ABOVEMENU) + 130 + (IDIFFERENCE (fetch + (REGION HEIGHT) + of ABOVEMENU) + 5] + (WINDOWPROP ACE.CONTROL.WINDOW 'PROMPT.CLIP.REGION (CREATEREGION + (IPLUS 3 (fetch (REGION RIGHT) + of INFO)) + (fetch (REGION BOTTOM) of + ABOVEMENU) + (IDIFFERENCE (fetch (REGION RIGHT) + of ABOVEMENU) + (IPLUS 3 (fetch (REGION + RIGHT) + of INFO))) + (IDIFFERENCE (fetch (REGION HEIGHT) + of ABOVEMENU) + 5))) + (DRAWLINE (ADD1 (fetch (REGION RIGHT) of INFO)) + (fetch (REGION BOTTOM) of ABOVEMENU) + (ADD1 (fetch (REGION RIGHT) of INFO)) + (fetch (REGION TOP) of ABOVEMENU) + 1 + 'PAINT ACE.CONTROL.WINDOW) + (DSPFILL (CREATEREGION 0 0 (fetch IMAGEWIDTH of MENU) + (fetch IMAGEHEIGHT of MENU)) + 38505 + 'PAINT ACE.CONTROL.WINDOW]) + +(ACE.CHECKSTUFF + [LAMBDA (CONDITIONS) (* PmT "26-Oct-84 16:10") + (COND + ((EQ CONDITIONS 'SEQ) + (OR ACE.CURRENT.SEQUENCE (ACE.TELLEM "No Current Sequence defined. Aborted" T))) + ((EQ CONDITIONS 'FRAME) + (OR ACE.CURRENT.FRAME (ACE.TELLEM "No Current Frame. Aborted" T))) + ((EQ CONDITIONS 'TAIL) + (OR ACE.FRAME.TAIL (ACE.TELLEM "Sequence is at End." T]) + +(ACE.UPD.CONTROL.WINDOW + [LAMBDA (ITEM VALUE) (* MD "18-Jun-85 16:19") + + (* This puts info in the status region of the control window; + ITEM one of%: CURSOR, FRAME, DEVICE, OPERATION, UPD, T, RESET. + VALUE is the value for the ITEM; The ITEMs and VALUEs are stored as WINDOWPROPs + on A.C.W) + + (ACE.MAC.CW.INFO.CLIP (COND + ((AND (KEYDOWNP 'T) + (EQ ITEM 'CURSOR)) + (ACE.UPD.CW.MULE 'ACE.CURSOR VALUE)) + ((EQ ITEM 'FRAME) + [COND + ((EQ VALUE T) + (SETQ VALUE (COND + ((NULL ACE.CURRENT.SEQUENCE) + 'NA) + ((EQ ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL) + 'START) + (T (LENGTH (LDIFF ACE.CURRENT.SEQUENCE + ACE.FRAME.TAIL] + (ACE.UPD.CW.MULE 'ACE.FRAME VALUE)) + ((EQ ITEM 'DEVICE) + (ACE.UPD.CW.MULE 'ACE.DEVICE VALUE)) + ((EQ ITEM 'OPERATION) + (ACE.UPD.CW.MULE 'ACE.OPERATION VALUE)) + ((EQ ITEM 'UPD) + (ACE.UPD.CONTROL.WINDOW2 'FRAME T) + (ACE.UPD.CW.MULE 'ACE.DEVICE) + (ACE.UPD.CW.MULE 'ACE.OPERATION 'OK) + (ACE.UPD.CW.MULE 'ACE.CURSOR 'NA)) + ((EQ ITEM T) + (ACE.UPD.CW.MULE 'ACE.FRAME) + (ACE.UPD.CW.MULE 'ACE.DEVICE) + (ACE.UPD.CW.MULE 'ACE.OPERATION) + (ACE.UPD.CW.MULE 'ACE.CURSOR)) + ((EQ ITEM 'RESET) + (ACE.UPD.CONTROL.WINDOW2 'FRAME T) + (ACE.UPD.CW.MULE 'ACE.DEVICE 'MOUSE) + (ACE.UPD.CW.MULE 'ACE.OPERATION 'NA) + (ACE.UPD.CW.MULE 'ACE.CURSOR 'NA]) + +(ACE.UPD.CW.MULE + [LAMBDA (ITEM VALUE) (* MD "18-Jun-85 16:49") + + (* An elaborate WINDOWPROPer. If VALUE is given, it's put on A.C.W as prop + ITEM; if VALUE = NIL, returns the current value of ITEM. + Also, writes the value in the status region of A.C.W. + ITEM one of%: ACE.CURSOR ACE.FRAME ACE.OPERATION ACE.DEVICE. + Some restrictions of what VALUE can be (see code); + Returns VALUE) + + (COND + [(AND (KEYDOWNP 'T) + (EQ ITEM 'ACE.CURSOR)) + [COND + ((OR (POSITIONP VALUE) + (EQ VALUE 'NA)) + (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE)) + (T (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM] + (ACE.UPD.CLEAR.SET.LINE 4) + (COND + ((POSITIONP VALUE) + (printout ACE.CONTROL.WINDOW " Cursor: " (CAR VALUE) + " " + (CDR VALUE) + .SP 10)) + (T (printout ACE.CONTROL.WINDOW " Cursor: " VALUE .SP 10] + ((EQ ITEM 'ACE.FRAME) + [COND + ((OR (FIXP VALUE) + (EQ VALUE 'START) + (EQ VALUE 'NA)) + (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE)) + (T (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM] + (ACE.UPD.CLEAR.SET.LINE 1) + (printout ACE.CONTROL.WINDOW " Frame: " VALUE .SP 20)) + ((EQ ITEM 'ACE.OPERATION) + (COND + ((NULL VALUE) + (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM))) + (T (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE))) + (ACE.UPD.CLEAR.SET.LINE 3) + (printout ACE.CONTROL.WINDOW " State: " VALUE .SP 20)) + ((EQ ITEM 'ACE.DEVICE) + [COND + ((OR (EQ VALUE 'MOUSE) + (EQ VALUE 'MM1201)) + (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE)) + (T (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM] + (ACE.UPD.CLEAR.SET.LINE 2) + (printout ACE.CONTROL.WINDOW " Device: " (COND + ((EQ VALUE 'MOUSE) + 'MOUSE) + ((EQ VALUE 'MM1201) + 'TABLET) + (T 'NA)) + .SP 10))) + VALUE]) + +(ACE.UPD.CLEAR.SET.LINE + [LAMBDA (LINES) (* PmT "17-Dec-84 19:11") + (MOVETOUPPERLEFT ACE.CONTROL.WINDOW) + (RELMOVETO 0 (ITIMES (DSPLINEFEED NIL ACE.CONTROL.WINDOW) + (SUB1 LINES)) + ACE.CONTROL.WINDOW]) + +(ACE.CREATE.CONTROL.MENU + [LAMBDA NIL (* MD "26-Jun-85 14:11") + (SETQ ACE.CONTROL.MENU (create MENU + ITEMS _ '(("Get Sequence" 'I/O%:GET "Fetch a sequence-file") + ("Edit Frame" 'EDIT "Edits the CURRENT frame") + ("Run Sequence" 'RUN "Runs the sequence" + (SUBITEMS ("Loop" 'LOOP + "Runs sequence repeatedly until you type a space" + ) + ("Loop part" 'SUBLOOP + "Runs part of the sequence repeatedly " + ))) + ("Put Sequence" 'I/O%:PUT + "Writes current sequence out to a file") + ("New Frame" 'FRAME + "Adds in another frame AFTER the current one") + ("Increment Frame" 'INC + "Moves forward one frame and displays") + ("New Sequence" 'NEW "Make a new sequence from scratch") + ("Delete Frame" 'DEL + "Removes CURRENT frame and smoothes over") + ("Decrement Frame" 'DEC "Goes back one frame") + ("Reset Sequence" 'RESET + "Clears window and resets to start of sequence") + (" Adjust Timing Delays " 'TIME + "Manipulate the timing adjustments") + ("Initialize MM1201 Tablet" 'INIT.MM1201 + "Sets up the Tablet for use") + ("Change compression %%" 'ACESETTHRESHOLD + "Changes the space compression factor: 0 to 100 (100 = max compression)" + ) + ("Change Input Device" 'DEVICE + "Select Mouse or Tablet (for now)") + ("Quit" 'QUIT + "Exit ACE; Trillium user's MUST quit when done")) + CENTERFLG _ T + MENUCOLUMNS _ 3]) + +(ACE.SEQ.FETCH.WIDTH + [LAMBDA NIL (* PmT "22-Apr-85 19:12") + (fetch (BITMAP BITMAPWIDTH) of (fetch (ACE.BLIT BITMAP) + of (CAR (fetch (ACE.FRAME BLITS) + of (CAR ACE.CURRENT.SEQUENCE]) + +(ACE.SEQ.FETCH.HEIGHT + [LAMBDA NIL (* PmT "22-Apr-85 19:14") + (fetch (BITMAP BITMAPHEIGHT) of (fetch (ACE.BLIT BITMAP) + of (CAR (fetch (ACE.FRAME BLITS) + of (CAR ACE.CURRENT.SEQUENCE]) + +(ACE.SET.SEQ.CLIP.REGION + [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* "PmT" "17-Apr-85 18:03") + (OR LEFT (SETQ LEFT ACE.SEQ.WINDOW.XOFF)) + (OR BOTTOM (SETQ BOTTOM ACE.SEQ.WINDOW.YOFF)) + (OR WIDTH (SETQ WIDTH ACE.SEQ.WIDTH)) + (OR HEIGHT (SETQ HEIGHT ACE.SEQ.HEIGHT)) + (WINDOWPROP ACE.CONTROL.WINDOW 'SEQUENCE.CLIPPING.REGION (CREATEREGION LEFT BOTTOM WIDTH HEIGHT]) + +(ACE.ASKEM2 + [LAMBDA (STRING FLG DEFAULTANSWER TIMELIMIT? SPACES?) (* PmT "22-Apr-85 15:56") + (* Like ASKEM but uses whole control + window (use cautiously)) + (OR TIMELIMIT? (SETQ TIMELIMIT? 60)) + (COND + ((EQ FLG T) + (DSPRESET ACE.CONTROL.WINDOW)) + ((EQ FLG 'L) + (TERPRI ACE.CONTROL.WINDOW))) + (MKATOM (PROMPTFORWORD STRING DEFAULTANSWER NIL ACE.CONTROL.WINDOW NIL TIMELIMIT? + (AND SPACES? (CHARCODE (EOL ESCAPE LF]) + +(ACE.TELLEM2 + [LAMBDA (STRING FLG) (* PmT "19-Dec-84 19:15") + (COND + ((EQ FLG T) + (DSPRESET ACE.CONTROL.WINDOW)) + ((EQ FLG 'L) + (TERPRI ACE.CONTROL.WINDOW))) + (printout ACE.CONTROL.WINDOW STRING) + NIL]) + +(ACE.UPD.CONTROL.WINDOW2 + [LAMBDA (ITEM VALUE) (* PmT "19-Dec-84 15:49") + (COND + ((EQ ITEM 'FRAME) + [COND + ((EQ VALUE T) + (SETQ VALUE (COND + ((NULL ACE.CURRENT.SEQUENCE) + 'NA) + ((EQ ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL) + 'START) + (T (LENGTH (LDIFF ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL] + (ACE.UPD.CW.MULE 'ACE.FRAME VALUE)) + ((EQ ITEM 'DEVICE) + (ACE.UPD.CW.MULE 'ACE.DEVICE VALUE)) + ((EQ ITEM 'OPERATION) + (ACE.UPD.CW.MULE 'ACE.OPERATION VALUE)) + ((EQ ITEM 'CURSOR) + (ACE.UPD.CW.MULE 'ACE.CURSOR VALUE)) + ((EQ ITEM 'UPD) + (ACE.UPD.CONTROL.WINDOW2 'FRAME T) + (ACE.UPD.CW.MULE 'ACE.DEVICE) + (ACE.UPD.CW.MULE 'ACE.OPERATION 'OK) + (ACE.UPD.CW.MULE 'ACE.CURSOR 'NA)) + ((EQ ITEM T) + (ACE.UPD.CW.MULE 'ACE.FRAME) + (ACE.UPD.CW.MULE 'ACE.DEVICE) + (ACE.UPD.CW.MULE 'ACE.OPERATION) + (ACE.UPD.CW.MULE 'ACE.CURSOR)) + ((EQ ITEM 'RESET) + (ACE.UPD.CONTROL.WINDOW2 'FRAME T) + (ACE.UPD.CW.MULE 'ACE.DEVICE 'MOUSE) + (ACE.UPD.CW.MULE 'ACE.OPERATION 'NA) + (ACE.UPD.CW.MULE 'ACE.CURSOR 'NA]) +) + + + +(* The following Macros set up restricting clipping regions) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS ACE.MAC.CW.INFO.CLIP MACRO ((FORM) + (RESETLST + [RESETSAVE (PROGN (DSPCLIPPINGREGION (WINDOWPROP + ACE.CONTROL.WINDOW + 'INFO.CLIP.REGION) + ACE.CONTROL.WINDOW) + (DSPLEFTMARGIN (fetch (REGION LEFT) + of + (WINDOWPROP + ACE.CONTROL.WINDOW + 'INFO.CLIP.REGION)) + ACE.CONTROL.WINDOW)) + '(PROGN (DSPCLIPPINGREGION (WINDOWPROP + ACE.CONTROL.WINDOW + + ' + NORMAL.CLIP.REGION + ) + ACE.CONTROL.WINDOW) + (DSPLEFTMARGIN (fetch (REGION LEFT) + of (WINDOWPROP + ACE.CONTROL.WINDOW + + ' + NORMAL.CLIP.REGION + )) + ACE.CONTROL.WINDOW] + FORM))) + +(PUTPROPS ACE.MAC.CW.PROMPT.CLIP MACRO + ((FORM) + (RESETLST + [RESETSAVE (PROGN (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW 'PROMPT.CLIP.REGION) + ACE.CONTROL.WINDOW) + (DSPLEFTMARGIN (fetch (REGION LEFT) of (WINDOWPROP + ACE.CONTROL.WINDOW + + ' + PROMPT.CLIP.REGION + )) + ACE.CONTROL.WINDOW)) + '(PROGN (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW 'NORMAL.CLIP.REGION) + ACE.CONTROL.WINDOW) + (DSPLEFTMARGIN (fetch (REGION LEFT) of (WINDOWPROP + ACE.CONTROL.WINDOW + 'NORMAL.CLIP.REGION) + ) + ACE.CONTROL.WINDOW] + FORM))) + +[PUTPROPS ACE.MAC.SEQ.CLIP MACRO ((FORM) + (COND + ((WINDOWPROP ACE.CONTROL.WINDOW 'SEQUENCE.CLIPPING.REGION) + (RESETLST + (RESETSAVE (DSPCLIPPINGREGION (WINDOWPROP + ACE.CONTROL.WINDOW + + ' + SEQUENCE.CLIPPING.REGION + ) + ACE.SEQ.WINDOW) + (LIST 'DSPCLIPPINGREGION (DSPCLIPPINGREGION NIL + ACE.SEQ.WINDOW) + ACE.SEQ.WINDOW)) + FORM)) + (T FORM] +) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS ACE.MAC.FETCH.WIDTH MACRO (NIL (fetch (BITMAP BITMAPWIDTH) + of (fetch (ACE.BLIT BITMAP) + of (CAR (fetch (ACE.FRAME BLITS) + of (CAR ACE.CURRENT.SEQUENCE + ] + +[PUTPROPS ACE.MAC.FETCH.HEIGHT MACRO (NIL (fetch (BITMAP BITMAPHEIGHT) + of (fetch (ACE.BLIT BITMAP) + of (CAR (fetch (ACE.FRAME BLITS) + of (CAR + ACE.CURRENT.SEQUENCE + ] +) +(RPAQ ACE.LEFTMOUSE.CURSOR (CURSORCREATE (QUOTE #*(16 16)GOOLD@@DELIDELIDELIDELIDELIDELIDELIDD@@DD@@DD@@DD@@DD@@DD@@DGOOL +) (QUOTE NIL) 8 8)) +(RPAQ ACE.MIDDLEMOUSE.CURSOR (CURSORCREATE (QUOTE #*(16 16)GOOLD@@DECIDECIDECIDECIDECIDECIDECIDD@@DD@@DD@@DD@@DD@@DD@@DGOOL +) (QUOTE NIL) 8 8)) +(RPAQ ACE.RIGHTMOUSE.CURSOR (CURSORCREATE (QUOTE #*(16 16)GOOLD@@DEBGDEBGDEBGDEBGDEBGDEBGDEBGDD@@DD@@DD@@DD@@DD@@DD@@DGOOL +) (QUOTE NIL) 8 8)) +(RPAQ ACE.ALLMOUSE.CURSOR (CURSORCREATE (QUOTE #*(16 16)GOOLD@@DDMKDDMKDDMKDDMKDDMKDDMKDDMKDD@@DD@@DD@@DD@@DD@@DD@@DGOOL +) (QUOTE NIL) 8 8)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS ACE.CONTROL.WINDOW ACE.DIRECTORY ACE.SEQ.WINDOW ACE.SEQ.WIDTH ACE.SEQ.HEIGHT + ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF ACE.CURRENT.SEQUENCE ACE.CURRENT.SEQUENCE.NAME + ACE.FRAME.TAIL ACE.CURRENT.FRAME ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD + ACE.RUNNING.UNDER.TRILLIUM ACE.LEFTMOUSE.CURSOR ACE.MIDDLEMOUSE.CURSOR ACE.RIGHTMOUSE.CURSOR + ACE.ALLMOUSE.CURSOR) +) + + + +(* MENUS IN MAIN) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS ACE.CONTROL.MENU ACE.DELAY.MENU ACE.SET.DEVICE.MENU) +) + +(SETQ ACE.CONTROL.WINDOW NIL) + +(SETQ ACE.CONTROL.MENU NIL) + +(SETQ ACE.DELAY.MENU NIL) + +(SETQ ACE.SET.DEVICE.MENU NIL) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA ) +) + +(RPAQQ ACE-PRIMCOMS ((* COMPILER STUFF) + (VARS ACE.PIXPERWORD ACE.BITMAP.MASK) + (* LOW LEVEL COMPILER FNS) + (FNS ACE.COMPILE.FRAME ACE.EXTRACT ACESETTHRESHOLD) + (* REGION MAXING ROUTINES) + (FNS ACE.MAX.REGIONS ACE.PICK.BEST.REGION ACE.COMPUTE.AREA) + (* LOW LEVEL BITMAP COMPARISON) + (FNS ACE.SCAN.BITMAPS ACE.SCAN.PRIMBLOCKS ACE.FETCH.BLOCK))) + + + +(* COMPILER STUFF) + + +(RPAQQ ACE.PIXPERWORD 16) + +(RPAQ ACE.BITMAP.MASK (READARRAY-FROM-LIST 16 (QUOTE SMALLPOSP) 0 (QUOTE (65535 32768 49152 57344 +61440 63488 64512 65024 65280 65408 65472 65504 65520 65528 65532 65534 NIL)))) + + + + +(* LOW LEVEL COMPILER FNS) + +(DEFINEQ + +(ACE.COMPILE.FRAME + [LAMBDA (BM.ORIG BM.CHANGED VERTICAL.BLOCK THRESHOLD) (* MJD "28-May-86 16:35") + (* MAIN ENTRY POINT FOR DIFFERENTIAL + BITMAP COMPILING) + (* WARNING%: NO ERROR CHECKING DONE + FROM HERE DOWN!) + (* RETURNS A FRAMEPATCH LIST OF + ACTUAL BITMAP CHANGES) + (* RETURN FORMAT%: + ((BM X . Y) (BM X . Y) |...|)) + (PROG (CHANGES) + (SETQ CHANGES (ACE.SCAN.BITMAPS BM.ORIG BM.CHANGED VERTICAL.BLOCK)) + (AND CHANGES (SETQ CHANGES (ACE.MAX.REGIONS CHANGES THRESHOLD))) + (SETQ CHANGES (ACE.EXTRACT CHANGES BM.CHANGED)) + (ACE.UPD.CONTROL.WINDOW 'OPERATION "DONE") + (RETURN CHANGES]) + +(ACE.EXTRACT + [LAMBDA (REGIONS BITMAP) (* MJD "28-May-86 13:12") + + (* TAKES LIST OF REGIONS OF CHANGED AREAS AND MAKES INTO ACTUAL FRAMEPATCH LIST + BY EXTRACTING FROM NEW BM) + + (PROG (TEMP.BITMAP LEFT BOTTOM WIDTH HEIGHT (FRAMEBLITLIST (CONS))) + [COND + ((NULL REGIONS) + NIL) + (T (for X in REGIONS + do (BLOCK) + (SETQ LEFT (fetch (REGION LEFT) of X)) + (SETQ BOTTOM (fetch (REGION BOTTOM) of X)) + (SETQ WIDTH (fetch (REGION WIDTH) of X)) + (SETQ HEIGHT (fetch (REGION HEIGHT) of X)) + (SETQ TEMP.BITMAP (BITMAPCREATE WIDTH HEIGHT 1)) + (BITBLT BITMAP LEFT BOTTOM TEMP.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) + (NCONC1 FRAMEBLITLIST + (create ACE.BLIT + BITMAP _ TEMP.BITMAP + XCOOR _ LEFT + YCOOR _ BOTTOM] + (RETURN (CDR FRAMEBLITLIST]) + +(ACESETTHRESHOLD + [LAMBDA NIL (* MD "19-Jun-85 15:46") + (PROG NIL + LOOP + (SETQ ACE.AREA.THRESHOLD (RNUMBER (CONCAT "Compression factor(0-100), currently " + ACE.AREA.THRESHOLD ": "))) + (IF (OR (ILESSP ACE.AREA.THRESHOLD 0) + (IGREATERP ACE.AREA.THRESHOLD 100)) + THEN (GO LOOP)) + (RETURN ACE.AREA.THRESHOLD]) +) + + + +(* REGION MAXING ROUTINES) + +(DEFINEQ + +(ACE.MAX.REGIONS + [LAMBDA (REGIONS THRESHOLD) (* MJD "28-May-86 13:11") + + (* Merges the changed regions picked out by ACE.SCAN.BITMAPS; + REGIONS are small areas of change, THRESHOLD specifies how much bitmap area + must by "good" for a combination (i.e. 100 - + THRESHOLD is how much space may be wasted in combining two REGIONS); + Both ARGS required!) + (* RETURNS A LIST OF + (REGION REGION |...|)) + (PROG (BEST.POSS) + LOOP + (BLOCK) + (COND + [(IGREATERP (LENGTH REGIONS) + 1) + (SETQ BEST.POSS (ACE.PICK.BEST.REGION REGIONS)) + (COND + ((IGEQ (CADDR BEST.POSS) + THRESHOLD) + (NCONC1 REGIONS (CONS (UNIONREGIONS (CAAR BEST.POSS) + (CAADR BEST.POSS)) + (CADDR BEST.POSS))) + (DREMOVE (CAR BEST.POSS) + REGIONS) + (DREMOVE (CADR BEST.POSS) + REGIONS)) + (T (GO DONE] + (T (GO DONE))) + (GO LOOP) + DONE + (RETURN (for X in REGIONS collect (CAR X]) + +(ACE.PICK.BEST.REGION + [LAMBDA (REGIONS) (* MJD "28-May-86 13:11") + + (* SLOWest part of animation! Selects the most efficient + (i.e. least amount of wasted space resulting from combining two regions) + combination of two regions from REGIONS; + First tries to find 100% match up; failing that goes for highest efficiency) + + (PROG (EFFICIENCY BEST.SO.FAR) + [COND + [(for X in REGIONS + thereis + (AND (EQP (CDR X) + 100) + (for Y in (CDR (MEMB X REGIONS)) + thereis (AND (PROG1 T (BLOCK)) + (EQP (CDR Y) + 100) + [OR [AND (EQP (fetch (REGION LEFT) of (CAR X)) + (fetch (REGION LEFT) of (CAR Y))) + (OR [EQP (fetch (REGION BOTTOM) + of (CAR Y)) + (ADD1 (fetch (REGION TOP) + of (CAR X] + (EQP (ADD1 (fetch (REGION TOP) + of (CAR Y))) + (fetch (REGION BOTTOM) + of (CAR X] + (AND (EQP (fetch (REGION BOTTOM) + of (CAR X)) + (fetch (REGION BOTTOM) + of (CAR Y))) + (OR [EQP (fetch (REGION LEFT) + of (CAR Y)) + (ADD1 (fetch (REGION RIGHT) + of (CAR X] + (EQP (ADD1 (fetch (REGION RIGHT) + of (CAR Y))) + (fetch (REGION LEFT) + of (CAR X] + (SETQ BEST.SO.FAR (LIST X Y 100] + (T (SETQ BEST.SO.FAR '(NIL NIL -1)) + (for X in REGIONS + do (for Y in (CDR (MEMB X REGIONS)) + do ((SETQ EFFICIENCY (IQUOTIENT [ITIMES 100 + (IPLUS (ACE.COMPUTE.AREA + (CAR X) + (CDR X)) + (ACE.COMPUTE.AREA + (CAR Y) + (CDR Y] + (ACE.COMPUTE.AREA + (UNIONREGIONS (CAR X) + (CAR Y)) + 100))) + (AND (IGREATERP EFFICIENCY (CADDR BEST.SO.FAR)) + (SETQ BEST.SO.FAR (LIST X Y EFFICIENCY] + (RETURN BEST.SO.FAR]) + +(ACE.COMPUTE.AREA + [LAMBDA (REGION EFF) (* MJD "28-May-86 13:10") + (BLOCK) + (IQUOTIENT (ITIMES (ffetch (REGION WIDTH) of REGION) + (ffetch (REGION HEIGHT) of REGION) + EFF) + 100]) +) + + + +(* LOW LEVEL BITMAP COMPARISON) + +(DEFINEQ + +(ACE.SCAN.BITMAPS + [LAMBDA (BM.ORIG BM.NEW BLOCKINGHEIGHT) (* PmT "25-Apr-85 15:14") + + (* Compares BM.ORIG and BM.NEW in one word + (ACE.PIXPERWORD bits; 16) by BLOCKINGHEIGHT rectangles. + Note masking when get to last word in bitmap and compression of region below + ACE.PIXPERWORD (16); All ARGS required; + BM.ORIG and BM.NEW must have the same dimensions!) + (* RETURNS A LIST OF TYPE + (REGION . 100)) + (PROG [TEMP.ENTRY (BM.WIDTH (ffetch BITMAPWIDTH of BM.ORIG)) + (CHANGED.REGIONS (CONS)) + (RASTERWIDTH (SUB1 (ffetch BITMAPRASTERWIDTH of BM.ORIG))) + (HEIGHT (SUB1 (ffetch BITMAPHEIGHT of BM.ORIG))) + (ALLMASK (ELT ACE.BITMAP.MASK 0)) + (PARTIALMASK (ELT ACE.BITMAP.MASK (IMOD (ffetch BITMAPWIDTH of BM.ORIG) + ACE.PIXPERWORD] + [while (ILESSP Y HEIGHT) bind (Y _ 0) + do [for HORZ.BLOCK from 0 to RASTERWIDTH + do (AND [SETQ TEMP.ENTRY (COND + ((EQP HORZ.BLOCK RASTERWIDTH) + (ACE.SCAN.PRIMBLOCKS BM.ORIG BM.NEW + HORZ.BLOCK Y BLOCKINGHEIGHT + PARTIALMASK)) + (T (ACE.SCAN.PRIMBLOCKS BM.ORIG BM.NEW + HORZ.BLOCK Y BLOCKINGHEIGHT ALLMASK] + (NCONC1 CHANGED.REGIONS + (CONS [CREATEREGION (ITIMES HORZ.BLOCK ACE.PIXPERWORD) + (CAR TEMP.ENTRY) + (IMIN ACE.PIXPERWORD (IDIFFERENCE BM.WIDTH + (ITIMES HORZ.BLOCK + + ACE.PIXPERWORD + ))) + (ADD1 (IDIFFERENCE (CDR TEMP.ENTRY) + (CAR TEMP.ENTRY] + 100] + (SETQ Y (IPLUS Y BLOCKINGHEIGHT)) + (SETQ BLOCKINGHEIGHT (IMIN BLOCKINGHEIGHT (ADD1 (IDIFFERENCE HEIGHT Y] + (RETURN (CDR CHANGED.REGIONS]) + +(ACE.SCAN.PRIMBLOCKS + [LAMBDA (BM1 BM2 WORDOFFSET Y0 BLOCKH MASK) (* MJD "28-May-86 13:05") + + (* Does the actual comparison of primitive areas in the two bitmaps BM1 and BM2 + ; WORDOFFSET is the raster word offset; + Y0 is the low scanline and (IPLUS Y0 BLOCKH) is the hi one; + MASK is usually $FFFF, otherwise it is used to ignore extra bits trailing off + the end of the last raster word) + + (PROG [TEMP1 (MAXY (SUB1 (IPLUS Y0 BLOCKH] + [SETQ TEMP1 (for Y from Y0 to MAXY + thereis (NOT (EQP (LOGAND (LOGXOR (ACE.FETCH.BLOCK BM1 WORDOFFSET Y) + (ACE.FETCH.BLOCK BM2 WORDOFFSET Y)) + MASK) + 0] + (RETURN (AND TEMP1 (CONS TEMP1 + (for Y from MAXY to TEMP1 by -1 + thereis (NOT (EQP (LOGAND (LOGXOR (ACE.FETCH.BLOCK + BM1 WORDOFFSET Y) + (ACE.FETCH.BLOCK + BM2 WORDOFFSET Y)) + MASK) + 0]) + +(ACE.FETCH.BLOCK + [LAMBDA (BITMAP WORDOFFSET VERTICAL) (* MJD "28-May-86 13:04") + (* Nabs a word from bitmap on line + VERTICAL with word offset WORDOFFSET) + (BLOCK) + (\GETBASE (\ADDBASE (ffetch BITMAPBASE of BITMAP) + (ITIMES (IDIFFERENCE (ffetch BITMAPHEIGHT of BITMAP) + (ADD1 VERTICAL)) + (ffetch BITMAPRASTERWIDTH of BITMAP))) + WORDOFFSET]) +) + +(RPAQQ ACE-EDITCOMS + [(FILES (LOADCOMP) + ACE) + (* TOP LEVEL EDITING STUFF) + (FNS ACE.EDIT ACE.EDIT.FRAME ACE.EDIT.SETUP.EDIT.MENU ACEGETREGIONFACTOR ACEROTATEREGION + ACESCALEREGION) + (* LINEART FNS) + (FNS ACE.EDIT.LINEART ACE.EDIT.LINEART.DRAW ACE.EDIT.LINEART.ADJ ACE.EDIT.LINEART.TRACKLINE) + (* OTHER EDITING STUFF) + (FNS ACE.EDIT.MOVE.REGION ACE.EDIT.COMBINE.REGION ACE.EDIT.TEXT ACE.EDIT.TEXTURE.REGION + ACE.EDIT.TEXTURE.AREA ACE.EDIT.PAINT ACE.FILLWITHTEXTURE ACE.SCANLINESEEDFILL + ACE.EDIT.CREATE.MENU.TEXTURES ACE.EDIT.PUTDOWN.BITMAP ACE.EDIT.MOVE.REGION.ASST + ACEEDITBM ACE.READBRUSHSHAPE) + (* TABLET AND SUPPORT FNS) + (FNS ACE.EDIT.POINT&CODE ACE.GET.DEVICE.STATE ACE.GET.DEVICE.STATE&CURSOR ACE.EXTRACTBM + ACE.EDIT.REDRAW.ABITMAP ACE.SCALE.BITMAP ACE.COMPILE.FRAME.ACE ACE.MM1201.INIT + ACE.MM1201POLL ACE.MM1201.PROBLEM ACE.EDIT.CLEAR.ALL.MENUS ROTATEBM SIGN TEXTURELINE + \TEXTURELINE RS232LOSTCHARFN) + (MACROS ACE.POPPOS ACE.PUSHPOS) + (CURSORS ACE.EDIT.LINEART.SQUARE.CURSOR) + (BITMAPS ACELOGOMAP) + (VARS (RS232LOSTCHARFN 'RS232LOSTCHARFN)) + (* MENUS FOR ACE-EDIT) + (GLOBALVARS ACE.CONTROL.WINDOW ACE.EDIT.FRAME.MENU ACE.EDIT.LINEART.ADJ.MENU + ACE.EDIT.MOVE.MENU ACE.EDIT.TEXT.FONT.MENU ACE.EDIT.TEXT.SIZE.MENU + ACE.EDIT.TEXT.FACE.MENU ACE.EDIT.TEXTURE.MENU ACE.EDIT.PUTDOWN.MENU) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ACE.EDIT.CLEAR.ALL.MENUS]) + +(FILESLOAD (LOADCOMP) + ACE) + + + +(* TOP LEVEL EDITING STUFF) + +(DEFINEQ + +(ACE.EDIT (LAMBDA (FLG) (* PmT "24-Apr-85 14:51") (* Entry into frame editing. Reconstructs CURRENT frame, previous (if any) ; and successor (if any) ; Calls ACE.EDIT.FRAME on the recontructed CURRENT frame (a bitmap) ; when editing is complete, recompiles current frame with previous and successor) (PROG (BEFORE.BM PRESENT.BM AFTER.BM) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "EDIT") (COND ((NULL (AND (ACE.CHECKSTUFF (QUOTE SEQ)) (ACE.CHECKSTUFF (QUOTE FRAME)))) NIL) (T (COND ((EQ ACE.CURRENT.FRAME ACE.CURRENT.SEQUENCE) (SETQ BEFORE.BM NIL)) (T (SETQ BEFORE.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME))))) (COND (BEFORE.BM (SETQ PRESENT.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL)))) (T (SETQ PRESENT.BM (fetch (ACE.BLIT BITMAP) of (CAR (fetch (ACE.FRAME BLITS) of (CAR ACE.CURRENT.SEQUENCE))))))) (COND ((NULL ACE.FRAME.TAIL) (SETQ AFTER.BM NIL)) (T (SETQ AFTER.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE (CDR ACE.FRAME.TAIL)))))) (COND ((ACE.MAC.SEQ.CLIP (ACE.EDIT.FRAME PRESENT.BM)) (COND ((NULL (OR BEFORE.BM AFTER.BM)) NIL) ((NULL BEFORE.BM) (replace (ACE.FRAME BLITS) of (CAR ACE.FRAME.TAIL) with (ACE.COMPILE.FRAME.ACE PRESENT.BM AFTER.BM ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD))) ((NULL AFTER.BM) (replace (ACE.FRAME BLITS) of (CAR ACE.CURRENT.FRAME) with (ACE.COMPILE.FRAME.ACE BEFORE.BM PRESENT.BM ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD))) (T (replace (ACE.FRAME BLITS) of (CAR ACE.CURRENT.FRAME) with (ACE.COMPILE.FRAME.ACE BEFORE.BM PRESENT.BM ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD)) (replace (ACE.FRAME BLITS) of (CAR ACE.FRAME.TAIL) with (ACE.COMPILE.FRAME.ACE PRESENT.BM AFTER.BM ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD)))))) (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL)))))) ) + +(ACE.EDIT.FRAME (LAMBDA (ABITMAP) (* MJD "23-May-86 15:51") (* Does editing on ABITMAP (this suppose to be a frame; but not necessarily) ; Loops through an options menu until QUIT is selected. The BITBLT just redraws the frame as it really is after every editing option) (PROG NIL LOOP (BITBLT ABITMAP 0 0 ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF NIL NIL (QUOTE INPUT) (QUOTE REPLACE) NIL NIL) (ACE.UPD.CONTROL.WINDOW (QUOTE FRAME) T) (SELECTQ (MENU (OR ACE.EDIT.FRAME.MENU (ACE.EDIT.SETUP.EDIT.MENU))) (NIL NIL) (PAINT (ACE.EDIT.PAINT ABITMAP)) (EDITBM (ACEEDITBM)) (LINEART (ACE.EDIT.LINEART ABITMAP)) (MOVE.REG (ACE.EDIT.MOVE.REGION ABITMAP)) (COMBINE.REG (ACE.EDIT.COMBINE.REGION ABITMAP)) (SNAPREG (SNAPW)) (TEXT (ACE.EDIT.TEXT ABITMAP)) (TEXTURE.AREA (ACE.EDIT.TEXTURE.AREA ABITMAP)) (TEXTURE.REG (ACE.EDIT.TEXTURE.REGION ABITMAP)) (CLEAR (ACE.EDIT.TEXTURE.REGION ABITMAP WHITESHADE)) (SCALEREG (ACESCALEREGION (QUOTE SWEEP))) (SCALEREGXY (ACESCALEREGION (QUOTE XY))) (SCALEREGX (ACESCALEREGION (QUOTE X))) (SCALEREGY (ACESCALEREGION (QUOTE Y))) (ROTATEREG (ACEROTATEREGION)) (|2D| (EDIT.SEQ.2D ABITMAP)) (|3D| (EDIT.SEQ.3D ABITMAP)) (QUIT (RETURN T)) (ABORT (AND (ACE.CONFIRMIT "Click LEFT to Ignore Changes." T) (RETURN NIL))) NIL) (GO LOOP))) ) + +(ACE.EDIT.SETUP.EDIT.MENU (LAMBDA NIL (* MJD "23-May-86 15:42") (SETQ ACE.EDIT.FRAME.MENU (create MENU ITEMS _ (QUOTE (("Paint" (QUOTE PAINT) "Does standard Paint on frame") ("Line art" (QUOTE LINEART) "Enter lines through various devices") ("Text" (QUOTE TEXT) "Put text into frame") ("Edit bits" (QUOTE EDITBM) "Calls the Bitmap Editor on frame") (" " NIL "Just a Spacer") ("Move region" (QUOTE MOVE.REG) "Move a rectangular region in frame") ("Combine region" (QUOTE COMBINE.REG) "Combine any region on screen into frame") ("Snap region" (QUOTE SNAPREG) "Save a region in a scratch window") ("Scale region" (QUOTE SCALEREG) "Change size of a region in the frame" (SUBITEMS ("To a new region" (QUOTE SCALEREG)) ("In x and y" (QUOTE SCALEREGXY)) ("In x only" (QUOTE SCALEREGX)) ("In y only" (QUOTE SCALEREGY)))) ("Rotate region" (QUOTE ROTATEREG) "Rotates a region any number of degrees") ("Texture region fill" (QUOTE TEXTURE.AREA) "Texture any closed area within frame") ("Texture box fill" (QUOTE TEXTURE.REG) "Fills a bounded rectangle with a texture.") ("Clear region" (QUOTE CLEAR) "Erases a specified Region") (" " NIL "Just a Spacer") ("Compile frame" (QUOTE QUIT) "Exits the editor and compiles the frame.") ("Quit - ABORT" (QUOTE ABORT) "Stops editor; frame reverts to original state."))) CENTERFLG _ T TITLE _ "Edit Options" CHANGEOFFSETFLG _ T))) ) + +(ACEGETREGIONFACTOR (LAMBDA (W H) (* MD "19-Jun-85 14:29") (PROG (TEMPREGION) (ACE.TELLEM "Select desired size for new region" T) (SETQ TEMPREGION (GETREGION NIL NIL NIL (QUOTE ACE.EDIT.MOVE.REGION.ASST) NIL)) (RETURN (CONS (FQUOTIENT (fetch (REGION WIDTH) of TEMPREGION) W) (FQUOTIENT (fetch (REGION HEIGHT) of TEMPREGION) H))))) ) + +(ACEROTATEREGION (LAMBDA (TYPE) (* MJD "23-May-86 15:15") (PROG (TEMPREGION TEMPBM NEWBM) (ACE.TELLEM "Select a Region inside the Sequence" T) (SETQ TEMPREGION (GETREGION NIL NIL NIL (QUOTE ACE.EDIT.MOVE.REGION.ASST) NIL)) (SETQ TEMPBM (BITMAPCREATE (fetch (REGION WIDTH) of TEMPREGION) (fetch (REGION HEIGHT) of TEMPREGION) 1)) (BITBLT ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) TEMPBM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (SETQ NEWBM (BITMAPCREATE (fetch (REGION WIDTH) of TEMPREGION) (fetch (REGION HEIGHT) of TEMPREGION) 1)) (ROTATEBM TEMPBM NEWBM (RNUMBER "Angle in degrees:")) (BITBLT TEMPBM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (BITBLT NEWBM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE)))) ) + +(ACESCALEREGION (LAMBDA (TYPE) (* MD "19-Jun-85 14:29") (PROG (TEMPREGION TEMPBM NEWBM) (ACE.TELLEM "Select a Region inside the Sequence" T) (SETQ TEMPREGION (GETREGION NIL NIL NIL (QUOTE ACE.EDIT.MOVE.REGION.ASST) NIL)) (SETQ TEMPBM (BITMAPCREATE (fetch (REGION WIDTH) of TEMPREGION) (fetch (REGION HEIGHT) of TEMPREGION) 1)) (BITBLT ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) TEMPBM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (SETQ NEWBM (COND ((EQ TYPE (QUOTE SWEEP)) (ACE.SCALE.BITMAP TEMPBM (ACEGETREGIONFACTOR (fetch (REGION WIDTH) of TEMPREGION) (fetch (REGION HEIGHT) of TEMPREGION)))) ((EQ TYPE (QUOTE XY)) (ACE.SCALE.BITMAP TEMPBM (CONS (RNUMBER "%% scale in x") (RNUMBER "%% scale in y")))) ((EQ TYPE (QUOTE X)) (ACE.SCALE.BITMAP TEMPBM (CONS (RNUMBER "%% scale in x") 100))) ((EQ TYPE (QUOTE Y)) (ACE.SCALE.BITMAP TEMPBM (CONS 100 (RNUMBER "%% scale in y")))))) (BITBLT TEMPBM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (BITBLT NEWBM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE)))) ) +) + + + +(* LINEART FNS) + +(DEFINEQ + +(ACE.EDIT.LINEART (LAMBDA (ABITMAP) (* MD "19-Jun-85 17:23") (* Entry into Lineart on ABITMAP. LSHIFT brings up options menu) (RESETFORM (CURSOR ACE.EDIT.LINEART.SQUARE.CURSOR) (PROG (POINT&CODE DEVICE BRUSH MODE) (DECLARE (SPECVARS BRUSH MODE)) (* So ...LINEART.ADJ sees them. Overkill but a good reminder) (SETQ DEVICE (ACE.UPD.CONTROL.WINDOW (QUOTE DEVICE))) (COND ((EQ DEVICE (QUOTE MOUSE)) (ACE.TELLEM "LEFT button Draws (puts Vertices)" T) (ACE.TELLEM "MIDDLE Stops drawing; IDLES (Square cursor)" (QUOTE L))) ((EQ DEVICE (QUOTE MM1201)) (ACE.TELLEM "STYLUS Draws (puts down Vertices)" T) (ACE.TELLEM "BARREL Stops; IDLES (Square cursor)" (QUOTE L)))) (ACE.TELLEM "Right button selects drawing options" (QUOTE L)) (ACE.TELLEM "To exit, use right button, or stylus + barrel (tablet)" (QUOTE L)) LOOP (SETQ POINT&CODE (ACE.EDIT.POINT&CODE DEVICE)) (COND ((EQUAL (CAR POINT&CODE) (QUOTE VERTEX)) (ACE.EDIT.LINEART.DRAW ABITMAP POINT&CODE DEVICE BRUSH MODE)) ((EQUAL (CAR POINT&CODE) (QUOTE OPTIONS)) (if (NOT (ACE.EDIT.LINEART.ADJ)) then (RETURN NIL))) ((KEYDOWNP (QUOTE RSHIFT)) (RETURN NIL))) (forDuration 30 timerUnits (QUOTE MILLISECONDS)) (GO LOOP)))) ) + +(ACE.EDIT.LINEART.DRAW (LAMBDA (ABITMAP POINT&CODE DEVICE BRUSH MODE) (* PmT "24-Apr-85 15:02") (* The actual mule for LineArt. Draws the lines on ABITMAP and in the Sequence Window) (PROG ((LASTVERTEX NIL) (LASTPOINT NIL) STUPID.DSP.FOR.ABITMAP TEMP.CURSOR) (SETQ STUPID.DSP.FOR.ABITMAP (DSPCREATE ABITMAP)) (SETQ TEMP.CURSOR (CURSOR CROSSHAIRS)) LOOP (AND LASTPOINT (ACE.EDIT.LINEART.TRACKLINE LASTVERTEX LASTPOINT BRUSH)) (COND ((EQUAL (CAR POINT&CODE) (QUOTE VERTEX)) (AND LASTVERTEX (DRAWLINE (ACE.MT.SEQX.AWX (CADR POINT&CODE)) (ACE.MT.SEQY.AWY (CDDR POINT&CODE)) (ACE.MT.SEQX.AWX (CAR LASTVERTEX)) (ACE.MT.SEQY.AWY (CDR LASTVERTEX)) BRUSH MODE ACE.SEQ.WINDOW) (DRAWLINE (CADR POINT&CODE) (CDDR POINT&CODE) (CAR LASTVERTEX) (CDR LASTVERTEX) BRUSH MODE STUPID.DSP.FOR.ABITMAP)) (SETQ LASTVERTEX (CDR POINT&CODE)) (SETQ LASTPOINT NIL)) ((EQUAL (CAR POINT&CODE) (QUOTE TOGGLE)) (CURSOR TEMP.CURSOR) (RETURN NIL)) ((KEYDOWNP (QUOTE RSHIFT)) (CURSOR TEMP.CURSOR) (RETURN NIL)) (T (SETQ LASTPOINT (CDR POINT&CODE)) (ACE.EDIT.LINEART.TRACKLINE LASTVERTEX LASTPOINT BRUSH))) (SETQ POINT&CODE (ACE.EDIT.POINT&CODE DEVICE)) (GO LOOP))) ) + +(ACE.EDIT.LINEART.ADJ (LAMBDA NIL (* MD "19-Jun-85 17:26") (* Options for changing how lineart draws; affects brush and drawing mode) (SELECTQ (MENU (OR ACE.EDIT.LINEART.ADJ.MENU (SETQ ACE.EDIT.LINEART.ADJ.MENU (create MENU ITEMS _ (QUOTE (("Replace Mode" (QUOTE REPLACE) "Puts bits there") ("Paint Mode" (QUOTE PAINT) "Cause lines to OR with background") ("Invert Mode" (QUOTE INVERT) "Lines will XOR with background") ("Erase Mode" (QUOTE ERASE) "Erases whats there") (" " NIL "Ah! you found the magic command: nothing") ("Line width 1" 1 "Sets the Brush width to 1 pixel") ("Line width 2" 2 "Brush width 2 pixels") ("Line width 3" 3 "Brush width 3 pixels") ("Line width 4" 4 "Brush width 4 pixels") ("Line width 5" 5 "Brush width 5 pixels") ("Quit" (QUOTE QUIT) "Returns to Edit menu"))) CENTERFLG _ T TITLE _ "Drawing Adjustments")))) (NIL NIL) (PAINT (SETQ MODE (QUOTE PAINT))) (INVERT (SETQ MODE (QUOTE INVERT))) (REPLACE (SETQ MODE (QUOTE REPLACE))) (ERASE (SETQ MODE (QUOTE ERASE))) (1 (SETQ BRUSH 1)) (2 (SETQ BRUSH 2)) (3 (SETQ BRUSH 3)) (4 (SETQ BRUSH 4)) (5 (SETQ BRUSH 5)) (QUIT NIL) NIL)) ) + +(ACE.EDIT.LINEART.TRACKLINE (LAMBDA (VERTEX POINT BRUSH) (* PmT "24-Apr-85 15:25") (* Makes a line from the current vertex to the cursor; shows where a line would go and what it looks like) (AND VERTEX POINT (DRAWLINE (ACE.MT.SEQX.AWX (CAR VERTEX)) (ACE.MT.SEQY.AWY (CDR VERTEX)) (ACE.MT.SEQX.AWX (CAR POINT)) (ACE.MT.SEQY.AWY (CDR POINT)) BRUSH (QUOTE INVERT) ACE.SEQ.WINDOW))) ) +) + + + +(* OTHER EDITING STUFF) + +(DEFINEQ + +(ACE.EDIT.MOVE.REGION (LAMBDA (ABITMAP) (* MD "21-Jun-85 13:52") (* Moves a region inside the sequence; similar to COMBINE.REGION except the old image may be erased (thus MOVE) ; region is confined to sequence by ACE.EDIT.MOVE.REGION.ASST) (PROG (TEMP.REGION TEMP.BM) (ACE.TELLEM "Select a region inside the sequence" T) (SETQ TEMP.REGION (GETREGION NIL NIL NIL (QUOTE ACE.EDIT.MOVE.REGION.ASST) NIL)) (SETQ TEMP.BM (BITMAPCREATE (fetch (REGION WIDTH) of TEMP.REGION) (fetch (REGION HEIGHT) of TEMP.REGION) 1)) (BITBLT ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMP.REGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMP.REGION)) TEMP.BM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (SELECTQ (MENU (OR ACE.EDIT.MOVE.MENU (SETQ ACE.EDIT.MOVE.MENU (create MENU ITEMS _ (QUOTE ((Erase (QUOTE ERASE) "NAND the old image") (Invert (QUOTE XOR) "XOR the old image with itself") (Nothing NIL "Just leave the old image as is"))) CENTERFLG _ T TITLE _ "Do What with Old Image?" CHANGEOFFSETFLG _ T)))) (NIL NIL) (ERASE (BITBLT TEMP.BM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMP.REGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMP.REGION)) NIL NIL (QUOTE INPUT) (QUOTE ERASE))) (XOR (BITBLT TEMP.BM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMP.REGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMP.REGION)) NIL NIL (QUOTE INPUT) (QUOTE INVERT))) NIL) (ACE.EDIT.PUTDOWN.BITMAP TEMP.BM ABITMAP))) ) + +(ACE.EDIT.COMBINE.REGION (LAMBDA (ABITMAP) (* PmT "25-Apr-85 15:22") (* Grabs a region from the screen; makes it into a bitmap, then pastes it into the current frame; see ACE.EDIT.PUTDOWN.BITMAP) (PROG (TEMP.BM TEMP.REGION) (ACE.TELLEM "Select a Region from Screen" T) (SETQ TEMP.REGION (GETREGION)) (SETQ TEMP.BM (BITMAPCREATE (fetch (REGION WIDTH) of TEMP.REGION) (fetch (REGION HEIGHT) of TEMP.REGION) 1)) (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of TEMP.REGION) (fetch (REGION BOTTOM) of TEMP.REGION) TEMP.BM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (ACE.EDIT.PUTDOWN.BITMAP TEMP.BM ABITMAP))) ) + +(ACE.EDIT.TEXT (LAMBDA (ABITMAP) (* PmT "25-Apr-85 17:57") (* Puts text into current frame; actually, puts text into ABITMAP and the sequence window) (PROG ((FONT.FAMILY NIL) (FONT.SIZE NIL) (FONT.FACE NIL) (DUMB.DSP.FOR.BM (DSPCREATE ABITMAP)) BMX BMY USERSTRING POSITION POINT&CODE FONT) (GETMOUSESTATE) (* This so MENUs stay in one (the same) place!) (SETQ POSITION (CONS LASTMOUSEX LASTMOUSEY)) (SETQ FONT.FAMILY (MENU (OR ACE.EDIT.TEXT.FONT.MENU (SETQ ACE.EDIT.TEXT.FONT.MENU (create MENU ITEMS _ (QUOTE ((Classic (QUOTE CLASSIC)) (Cream (QUOTE CREAM)) (Gacha (QUOTE GACHA)) (Helvetica (QUOTE HELVETICA)) (Modern (QUOTE MODERN)) (TimesRoman (QUOTE TIMESROMAN)) (" " NIL) ("* Same *" (QUOTE SAME) "Use same descriptor as last time") ("* Other *" (QUOTE OTHER)))) TITLE _ "Select a Font Family" CENTERFLG _ T))) POSITION)) (COND ((EQ FONT.FAMILY (QUOTE SAME)) (SETQ FONT.FAMILY (FONTPROP (DSPFONT NIL ACE.SEQ.WINDOW) (QUOTE FAMILY))) (SETQ FONT.SIZE (FONTPROP (DSPFONT NIL ACE.SEQ.WINDOW) (QUOTE SIZE))) (SETQ FONT.FACE (FONTPROP (DSPFONT NIL ACE.SEQ.WINDOW) (QUOTE FACE)))) ((EQ FONT.FAMILY (QUOTE OTHER)) (SETQ FONT.FAMILY (ACE.ASKEM "Enter a Font Family: " T))) ((NULL FONT.FAMILY) (RETURN NIL))) (COND (FONT.SIZE NIL) ((NEQ (QUOTE OTHER) (SETQ FONT.SIZE (MENU (OR ACE.EDIT.TEXT.SIZE.MENU (SETQ ACE.EDIT.TEXT.SIZE.MENU (create MENU ITEMS _ (QUOTE (6 8 10 12 14 16 18 24 36 ("* Other *" (QUOTE OTHER)))) TITLE _ "Select Font Size" CENTERFLG _ T MENUROWS _ 2))) POSITION)))) (T (SETQ FONT.SIZE (ACE.ASKEM "Enter a Font Size: " T)))) (COND (FONT.FACE NIL) ((NEQ (QUOTE OTHER) (SETQ FONT.FACE (MENU (OR ACE.EDIT.TEXT.FACE.MENU (SETQ ACE.EDIT.TEXT.FACE.MENU (create MENU ITEMS _ (QUOTE (("Standard" (QUOTE STANDARD) "Normal font face") ("Italic" (QUOTE ITALIC) "A standard face in italic") ("Expanded" (QUOTE MRE)) ("Bold" (QUOTE BOLD) "A heavy bold face") ("Bold Italic" (QUOTE BIR)) ("Compressed" (QUOTE MRC)) (" " NIL) ("* Other *" (QUOTE OTHER)) (" " NIL))) TITLE _ "Select a Font Face" CENTERFLG _ T MENUROWS _ 3 MENUCOLUMNS _ 3))) POSITION)))) (T (SETQ FONT.FACE (ACE.ASKEM "Enter a Font Face: " T)))) (COND ((SETQ FONT (FONTCREATE FONT.FAMILY FONT.SIZE FONT.FACE NIL NIL T)) (ACE.TELLEM "Ready to start Entering Text." T) (ACE.TELLEM "Position Mouse and Click LEFT." (QUOTE L)) (until (EQ (CAR (SETQ POINT&CODE (ACE.EDIT.POINT&CODE (QUOTE MOUSE)))) (QUOTE VERTEX)) do) (ACE.TELLEM "A RETURN Stops Text." T) (SETQ BMX (CADR POINT&CODE)) (SETQ BMY (CDDR POINT&CODE)) (MOVETO (ACE.MT.SEQX.AWX BMX) (ACE.MT.SEQY.AWY BMY) ACE.SEQ.WINDOW) (MOVETO BMX BMY DUMB.DSP.FOR.BM) (RESETFORM (DSPFONT FONT ACE.SEQ.WINDOW) (SETQ USERSTRING (PROMPTFORWORD NIL NIL NIL ACE.SEQ.WINDOW NIL NIL (CHARCODE (EOL ESCAPE LF))))) (RESETFORM (DSPFONT FONT DUMB.DSP.FOR.BM) (AND USERSTRING (PRIN1 USERSTRING DUMB.DSP.FOR.BM)))) (T (ACE.TELLEM "Can't find any such Font. Aborted." T))))) ) + +(ACE.EDIT.TEXTURE.REGION (LAMBDA (ABITMAP SHADE) (* PmT "25-Apr-85 15:33") (* Textures a region in ABITMAP; SHADE is optional; if not given, user is asked for a shade) (PROG (OPERATION SHADEREGION) (COND (SHADE NIL) ((NEQ (QUOTE OTHER) (SETQ SHADE (MENU (OR ACE.EDIT.TEXTURE.MENU (SETQ ACE.EDIT.TEXTURE.MENU (ACE.EDIT.CREATE.MENU.TEXTURES))))))) (T (SETQ SHADE (EDITSHADE)))) (OR SHADE (RETURN NIL)) (ACE.TELLEM "Select a Region in the Sequence" T) (SETQ SHADEREGION (GETREGION)) (SETQ OPERATION (COND ((EQ SHADE WHITESHADE) (QUOTE REPLACE)) ((MENU (OR ACE.EDIT.PUTDOWN.MENU (SETQ ACE.EDIT.PUTDOWN.MENU (create MENU ITEMS _ (QUOTE (("Paint" (QUOTE PAINT) "ORs with Frame") ("Replace" (QUOTE REPLACE) "Puts onto Frame") ("Invert" (QUOTE INVERT) "XORs with Frame") ("Erase" (QUOTE ERASE) "NANDs with Frame"))) CENTERFLG _ T TITLE _ "Select a Drawing Mode"))))))) (replace (REGION LEFT) of SHADEREGION with (ACE.MT.SCRX.AWX (fetch (REGION LEFT) of SHADEREGION))) (replace (REGION BOTTOM) of SHADEREGION with (ACE.MT.SCRY.AWY (fetch (REGION BOTTOM) of SHADEREGION))) (BITBLT NIL NIL NIL ACE.SEQ.WINDOW (fetch (REGION LEFT) of SHADEREGION) (fetch (REGION BOTTOM) of SHADEREGION) (fetch (REGION WIDTH) of SHADEREGION) (fetch (REGION HEIGHT) of SHADEREGION) (QUOTE TEXTURE) OPERATION SHADE (ACE.MT.SEQ.AW.REGION)) (BITBLT NIL NIL NIL ABITMAP (ACE.MT.AWX.SEQX (fetch (REGION LEFT) of SHADEREGION)) (ACE.MT.AWY.SEQY (fetch (REGION BOTTOM) of SHADEREGION)) (fetch (REGION WIDTH) of SHADEREGION) (fetch (REGION HEIGHT) of SHADEREGION) (QUOTE TEXTURE) OPERATION SHADE))) ) + +(ACE.EDIT.TEXTURE.AREA (LAMBDA (ABITMAP SHADE) (* PmT " 2-May-85 19:47") (* Does an area flood on a bounded region. ABITMAP is the frame (required) ; SHADE is an optional shade arg (SMALLP) ; Works by making a bitmap copy of a user selected region. Then flooding whatever area is enclosed with a user seed point.) (PROG (BOUNDING.REGION SEED.POINT TEMP.BM) (ACE.TELLEM "Select a Maximum Bounding Region." T) (SETQ BOUNDING.REGION (GETREGION NIL NIL NIL (QUOTE ACE.EDIT.MOVE.REGION.ASST) NIL)) (ACE.TELLEM "Select a Starting Point Inside the Region." T) (SETQ SEED.POINT (GETPOSITION)) (ACE.TELLEM "Select a Fill Shade." T) (COND (SHADE) ((NEQ (QUOTE OTHER) (SETQ SHADE (MENU (OR ACE.EDIT.TEXTURE.MENU (SETQ ACE.EDIT.TEXTURE.MENU (ACE.EDIT.CREATE.MENU.TEXTURES))))))) (T (SETQ SHADE (EDITSHADE)))) (COND ((NOT (INSIDEP BOUNDING.REGION SEED.POINT)) (ACE.TELLEM "Your Seed Point lies Outside of your Region." T) (ACE.TELLEM "Texture Area Fill Aborted." (QUOTE L)) (RETURN NIL)) ((NULL SHADE) (ACE.TELLEM "No Shade selected. Aborted." T) (RETURN NIL)) (T (SETQ SEED.POINT (CONS (IDIFFERENCE (CAR SEED.POINT) (fetch (REGION LEFT) of BOUNDING.REGION)) (IDIFFERENCE (CDR SEED.POINT) (fetch (REGION BOTTOM) of BOUNDING.REGION)))))) (SETQ TEMP.BM (BITMAPCREATE (fetch (REGION WIDTH) of BOUNDING.REGION) (fetch (REGION HEIGHT) of BOUNDING.REGION) 1)) (BITBLT ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of BOUNDING.REGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of BOUNDING.REGION)) TEMP.BM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (ACE.TELLEM "Texturing Area..." T) (RESETFORM (CURSOR WAITINGCURSOR) (ACE.FILLWITHTEXTURE TEMP.BM SHADE (CAR SEED.POINT) (CDR SEED.POINT) (LOGXOR 1 (BITMAPBIT TEMP.BM (CAR SEED.POINT) (CDR SEED.POINT))))) (BITBLT TEMP.BM 0 0 ACE.SEQ.WINDOW (ACE.MT.SCRX.AWX (fetch (REGION LEFT) of BOUNDING.REGION)) (ACE.MT.SCRY.AWY (fetch (REGION BOTTOM) of BOUNDING.REGION)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE) NIL NIL) (COND ((ACE.CONFIRMIT "Click LEFT to Confirm Fill as Shown." T) (BITBLT TEMP.BM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of BOUNDING.REGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of BOUNDING.REGION)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE) NIL NIL)) (T (ACE.TELLEM "Texture Area Fill Aborted." T))))) ) + +(ACE.EDIT.PAINT [LAMBDA (ABITMAP) (* ; "Edited 3-Sep-88 15:00 by masinter") (* Hacked from rrb "18-OCT-83 18:37") (* Paint on current frame with  either Mouse or Tablet) (* should make sure cursor has moved or a button has change before proceeding  with the inner loop.) (* has some of the stuff to allow the brush to be an arbitrary bitmap but not  all.) (ACE.TELLEM "Left (Mouse), Stylus (Tablet) Paints." T) (ACE.TELLEM "Middle (Mouse), Barrel (Tablet) Erases." 'L) (ACE.TELLEM "Right (Mouse) or Left Shift for Menu." 'L) (ACE.TELLEM "To Quit, select Quit from Menu." 'L) (BITBLT ABITMAP 0 0 ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF NIL NIL 'INPUT 'REPLACE NIL NIL) (PROG (OLDX OLDY (NEWBRUSHQ T) BRUSH WINDOW (ORIG.CURSOR (CURSOR)) (ORIG.REGION (DSPCLIPPINGREGION NIL ACE.SEQ.WINDOW))) (SETQ WINDOW ACE.SEQ.WINDOW) (SETQ WINDOW (\INSUREWINDOW WINDOW)) (RESETLST (RESETSAVE NIL (LIST 'CURSOR (CURSOR))) (PROG (DS HOTX HOTY) (TOTOPW WINDOW) (* look for a previously stored  brush.) [COND ((SETQ BRUSH (WINDOWPROP WINDOW 'PAINTBRUSH)) (SETQ PAINTCOMMANDMODE (CAR BRUSH)) (SETQ PAINTCOMMANDSHADE (CADR BRUSH)) (SETQ PAINTCOMMANDBRUSH (CADDR BRUSH] (SETQ DS (WINDOWPROP WINDOW 'DSP)) BRUSHLP [AND NEWBRUSHQ (SETQ BRUSH (COND ((BITMAPP PAINTCOMMANDBRUSH)) ((EQ (CAR PAINTCOMMANDBRUSH) 'other) (SETQ NEWBRUSHQ NIL) (ACE.EXTRACTBM)) (T (\GETBRUSH PAINTCOMMANDBRUSH] [AND (BITMAPP PAINTCOMMANDBRUSH) (SETQ PAINTCOMMANDBRUSH '(SQUARE 2] (* clear cursor) (BITBLT NIL NIL NIL (CURSORBITMAP) 0 0 16 16 'TEXTURE 'REPLACE WHITESHADE) (* put lower left part of brush  shape in cursor) (* BITBLT BRUSH 0 0  (SCREENBITMAP) 0 0 NIL NIL  (QUOTE INPUT) (QUOTE REPLACE)) (* set the hot spot to the middle of  the brush.) [CURSORHOTSPOT (create POSITION XCOORD _ (SETQ HOTX (IDIFFERENCE (IMIN (fetch BITMAPWIDTH of BRUSH) 16) 2)) YCOORD _ (SETQ HOTY (IDIFFERENCE (IMIN (fetch BITMAPHEIGHT of BRUSH) 16) 2] PAINTLP (ACE.GET.DEVICE.STATE&CURSOR) [COND ((KEYDOWNP 'RSHIFT) (RETURN)) ((OR (LASTMOUSESTATE RIGHT) (KEYDOWNP 'LSHIFT)) (COND ((OR (INSIDE? (DSPCLIPPINGREGION NIL DS) (LASTMOUSEX DS) (LASTMOUSEY DS)) (NOT (WHICHW LASTMOUSEX LASTMOUSEY))) (* inside the interior, give command  menu) (SELECTQ [MENU (COND ((type? MENU PAINTCOMMANDMENU) PAINTCOMMANDMENU) (T (SETQ PAINTCOMMANDMENU (create MENU ITEMS _ '((HardCopy 'HARDCOPY "Makes a press file of the window and prints it" ) (SetMode 'MODE "Allows specification of how new bits are merged" ) (SetShade 'SHADE "Allows specification of new shade." ) (SetShape 'SHAPE "Allows specification of brush shape" ) (SetSize 'SIZE "Allows specification of the brush size" ) (QUIT 'QUIT "Exits painting mode") ) CHANGEOFFSETFLG _ T] (SHADE (SETQ PAINTCOMMANDSHADE (OR (PAINTW.READBRUSHSHADE) PAINTCOMMANDSHADE)) (GO BRUSHLP)) (MODE (SETQ PAINTCOMMANDMODE (OR (PAINTW.READMODE) PAINTCOMMANDMODE)) (GO BRUSHLP)) (SHAPE (RPLACA PAINTCOMMANDBRUSH (OR (ACE.READBRUSHSHAPE) (CAR PAINTCOMMANDBRUSH))) (SETQ NEWBRUSHQ T) (GO BRUSHLP)) (SIZE (RPLACA (CDR PAINTCOMMANDBRUSH) (OR (PAINTW.READBRUSHSIZE) (CADR PAINTCOMMANDBRUSH))) (GO BRUSHLP)) (QUIT (WINDOWPROP ACE.SEQ.WINDOW 'PAINTBRUSH (LIST PAINTCOMMANDMODE PAINTCOMMANDSHADE (OR (BITMAPP BRUSH) PAINTCOMMANDBRUSH))) (SETQ PAINTCOMMANDBRUSH '(ROUND 16)) (RETURN)) (HARDCOPY (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (HARDCOPYW WINDOW))) NIL)) (T (* do NOT do the window menu) NIL))) [(AND (LASTMOUSESTATE LEFT) (OR (EQ PAINTCOMMANDMODE 'REPLACE) (NEQ PAINTCOMMANDSHADE BLACKSHADE))) (* painting in grey is slightly  harder.) (COND ((EQ PAINTCOMMANDMODE 'REPLACE) (* erase what is there now) (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'INPUT 'ERASE) (* put in grey) (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'MERGE 'PAINT PAINTCOMMANDSHADE)) (T (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'MERGE PAINTCOMMANDMODE PAINTCOMMANDSHADE] [(LASTMOUSESTATE (OR MIDDLE LEFT)) (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'INPUT (COND ((LASTMOUSESTATE MIDDLE) 'ERASE) (T PAINTCOMMANDMODE] ((LASTMOUSESTATE UP) (* Idle -  just mark brush loc.) (BITBLT BRUSH 0 0 DS (SETQ OLDX (IDIFFERENCE (LASTMOUSEX DS) HOTX)) (SETQ OLDY (IDIFFERENCE (LASTMOUSEY DS) HOTY)) NIL NIL 'INPUT 'INVERT) (DISMISS 2) (BITBLT BRUSH 0 0 DS OLDX OLDY NIL NIL 'INPUT 'INVERT] (GO PAINTLP)) (WINDOWPROP WINDOW 'PAINTBRUSH (LIST PAINTCOMMANDMODE PAINTCOMMANDSHADE (COPY PAINTCOMMANDBRUSH ))) (BITBLT WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF ABITMAP 0 0 ACE.SEQ.WIDTH ACE.SEQ.HEIGHT 'INPUT 'REPLACE NIL NIL)) (WINDOWPROP ACE.SEQ.WINDOW 'PAINTBRUSH (LIST PAINTCOMMANDMODE PAINTCOMMANDSHADE (OR (BITMAPP BRUSH) PAINTCOMMANDBRUSH]) + +(ACE.FILLWITHTEXTURE (LAMBDA (BitmapOrWindow Texture X Y BoundaryValue) (* PmT " 2-May-85 18:45") (* hdj " 5-Mar-85 15:53") (* This code created by Herb Jellinek and Kelly Roach. Renamed for organizational purposes. Paints in TEXTURE into supplied BitmapOrWindow (Only a bitmap here) ; BoundaryValue should be either a 1 or 0 (No color bitmaps or anything fancy for now) ; X and Y specify the seed point for the fill) (PROG ((COPYBM (COPYALL BitmapOrWindow))) (ACE.SCANLINESEEDFILL COPYBM X Y BoundaryValue BoundaryValue) (BITBLT BitmapOrWindow 0 0 COPYBM 0 0 NIL NIL (QUOTE INPUT) (QUOTE INVERT)) (BITBLT COPYBM 0 0 COPYBM 0 0 NIL NIL (QUOTE MERGE) (QUOTE TEXTURE) Texture) (BITBLT COPYBM 0 0 BitmapOrWindow 0 0 NIL NIL (QUOTE INPUT) (QUOTE PAINT)) BitmapOrWindow)) ) + +(ACE.SCANLINESEEDFILL (LAMBDA (BitmapOrWindow X Y BoundaryValue FillValue) (* PmT " 2-May-85 20:19") (* hdj "30-Jan-85 15:01") (* This code created by Herb Jellinek and Kelly Roach. Renamed for organizational purposes) (PROG (Xcoord Ycoord STACK SaveX SaveY XLeft XRight XMax YMax) (if (BITMAPP BitmapOrWindow) then (SETQ XMax (SUB1 (BITMAPWIDTH BitmapOrWindow))) (SETQ YMax (SUB1 (BITMAPHEIGHT BitmapOrWindow))) else (SETQ XMax (SUB1 (WINDOWPROP BitmapOrWindow (QUOTE WIDTH)))) (SETQ YMax (SUB1 (WINDOWPROP BitmapOrWindow (QUOTE HEIGHT))))) (* "initialize stack") (ACE.PUSHPOS X Y STACK) (while STACK do (* get seed pixel and set to new value) (ACE.POPPOS STACK SaveX SaveY) (BITMAPBIT BitmapOrWindow SaveX SaveY FillValue) (* fill span to right of seed pixel) (SETQ XRight XMax) (for Xcoord from (ADD1 SaveX) while (ILEQ Xcoord XMax) do (if (NEQ (BITMAPBIT BitmapOrWindow Xcoord SaveY) BoundaryValue) then (BITMAPBIT BitmapOrWindow Xcoord SaveY FillValue) else (* save the extreme right pixel) (SETQ XRight (SUB1 Xcoord)) (RETURN))) (* fill span to left of seed pixel) (SETQ XLeft 0) (for Xcoord from (SUB1 SaveX) by -1 while (IGEQ Xcoord 0) do (if (NEQ (BITMAPBIT BitmapOrWindow Xcoord SaveY) BoundaryValue) then (BITMAPBIT BitmapOrWindow Xcoord SaveY FillValue) else (* save the extreme left pixel) (SETQ XLeft (ADD1 Xcoord)) (RETURN))) (* Push seed points for scan line above. *) (COND ((ILESSP SaveY YMax) (SETQ Ycoord (ADD1 SaveY)) (for Xcoord from XLeft to XRight when (AND (NEQ (BITMAPBIT BitmapOrWindow Xcoord Ycoord) BoundaryValue) (OR (EQ Xcoord XRight) (OR (EQ (BITMAPBIT BitmapOrWindow (ADD1 Xcoord) Ycoord) BoundaryValue) (EQ (BITMAPBIT BitmapOrWindow (ADD1 Xcoord) Ycoord) FillValue)))) do (ACE.PUSHPOS Xcoord Ycoord STACK)))) (* Push seed points for scan line below. *) (COND ((IGREATERP SaveY 0) (SETQ Ycoord (SUB1 SaveY)) (for Xcoord from XLeft to XRight when (AND (NEQ (BITMAPBIT BitmapOrWindow Xcoord Ycoord) BoundaryValue) (OR (EQ Xcoord XRight) (OR (EQ (BITMAPBIT BitmapOrWindow (ADD1 Xcoord) Ycoord) BoundaryValue) (EQ (BITMAPBIT BitmapOrWindow (ADD1 Xcoord) Ycoord) FillValue)))) do (ACE.PUSHPOS Xcoord Ycoord STACK))))))) ) + +(ACE.EDIT.CREATE.MENU.TEXTURES (LAMBDA NIL (* PmT "25-Apr-85 15:27") (* Creates a textures menu for TEXTURE.REGION and FILL routines) (PROG (TEMP.BM) (RETURN (create MENU ITEMS _ (NCONC1 (for TEXTURE in (QUOTE (65535 34850 43605 63624 42405 4080 64250 26214 65488 34925 15 4680 33825 1185 1 3784 3591)) collect (PROGN (BITBLT NIL NIL NIL (SETQ TEMP.BM (BITMAPCREATE 36 36 1)) 4 4 28 28 (QUOTE TEXTURE) (QUOTE REPLACE) TEXTURE NIL) (LIST TEMP.BM TEXTURE))) (QUOTE ("* Other *" (QUOTE OTHER) "Make your own shade"))) TITLE _ "Texture Menu" CENTERFLG _ T MENUROWS _ 3)))) ) + +(ACE.EDIT.PUTDOWN.BITMAP (LAMBDA (IMAGE.BM TARGET.BM) (* MD "21-Jun-85 13:56") (* Pastes IMAGE.BM onto TARGET.BM; IMAGE.BM is tied to mouse until left click; asks user how to combine the two) (PROG (MODE POINT) (ACE.TELLEM "Click Left to paste down image." T) (SETQ POINT (PROG (OLD.X OLD.Y) LOOP (BITBLT IMAGE.BM 0 0 ACE.SEQ.WINDOW (SETQ OLD.X (LASTMOUSEX ACE.SEQ.WINDOW)) (SETQ OLD.Y (LASTMOUSEY ACE.SEQ.WINDOW)) NIL NIL (QUOTE INPUT) (QUOTE INVERT) NIL (ACE.MT.SEQ.AW.REGION)) (GETMOUSESTATE) (ACE.UPD.CONTROL.WINDOW (QUOTE CURSOR) (CONS (ACE.MT.SCRX.SEQX LASTMOUSEX) (ACE.MT.SCRY.SEQY LASTMOUSEY))) (COND ((LASTMOUSESTATE LEFT) (do (GETMOUSESTATE) until (LASTMOUSESTATE UP)) (BITBLT IMAGE.BM 0 0 ACE.SEQ.WINDOW OLD.X OLD.Y NIL NIL (QUOTE INPUT) (QUOTE INVERT) NIL (ACE.MT.SEQ.AW.REGION)) (RETURN (CONS (LASTMOUSEX ACE.SEQ.WINDOW) (LASTMOUSEY ACE.SEQ.WINDOW)))) (T (BITBLT IMAGE.BM 0 0 ACE.SEQ.WINDOW OLD.X OLD.Y NIL NIL (QUOTE INPUT) (QUOTE INVERT) NIL (ACE.MT.SEQ.AW.REGION)))) (GO LOOP))) (SETQ MODE (MENU (OR ACE.EDIT.PUTDOWN.MENU (SETQ ACE.EDIT.PUTDOWN.MENU (create MENU ITEMS _ (QUOTE (("Paint" (QUOTE PAINT) "ORs with Frame") ("Replace" (QUOTE REPLACE) "Puts onto Frame") ("Invert" (QUOTE INVERT) "XORs with Frame") ("Erase" (QUOTE ERASE) "NANDs with Frame"))) CENTERFLG _ T TITLE _ "Select a Drawing Mode" CHANGEOFFSETFLG _ T))))) (BITBLT IMAGE.BM 0 0 ACE.SEQ.WINDOW (CAR POINT) (CDR POINT) NIL NIL (QUOTE INPUT) MODE NIL (ACE.MT.SEQ.AW.REGION)) (BITBLT IMAGE.BM 0 0 TARGET.BM (ACE.MT.AWX.SEQX (CAR POINT)) (ACE.MT.AWY.SEQY (CDR POINT)) NIL NIL (QUOTE INPUT) MODE NIL))) ) + +(ACE.EDIT.MOVE.REGION.ASST (LAMBDA (FIXED MOVE EXTRA) (* PmT "23-Jan-85 20:03") (COND ((NULL MOVE) (ACE.NEW.SEQ.ASST (CONS (ACE.MT.SCRX.SEQX (CAR FIXED)) (ACE.MT.SCRY.SEQY (CDR FIXED))) MOVE EXTRA) (COND ((INSIDEP (ACE.MT.SEQ.SCR.REGION) FIXED) FIXED) (T (ACE.RETURN.CLOSEST.VERTEX FIXED (ACE.MT.SEQ.SCR.REGION))))) (T (ACE.NEW.SEQ.ASST FIXED MOVE EXTRA) (COND ((INSIDEP (ACE.MT.SEQ.SCR.REGION) MOVE) MOVE) (T (ACE.RETURN.CLOSEST.VERTEX MOVE (ACE.MT.SEQ.SCR.REGION))))))) ) + +(ACEEDITBM (LAMBDA (TYPE) (* MJD "23-May-86 15:51") (PROG (TEMPREGION TEMPBM NEWBM) (ACE.TELLEM "Select a Region inside the Sequence" T) (SETQ TEMPREGION (GETREGION NIL NIL NIL (QUOTE ACE.EDIT.MOVE.REGION.ASST) NIL)) (SETQ TEMPBM (BITMAPCREATE (fetch (REGION WIDTH) of TEMPREGION) (fetch (REGION HEIGHT) of TEMPREGION) 1)) (BITBLT ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) TEMPBM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (SETQ NEWBM (EDITBM TEMPBM)) (BITBLT TEMPBM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (BITBLT NEWBM 0 0 ABITMAP (ACE.MT.SCRX.SEQX (fetch (REGION LEFT) of TEMPREGION)) (ACE.MT.SCRY.SEQY (fetch (REGION BOTTOM) of TEMPREGION)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE)))) ) + +(ACE.READBRUSHSHAPE (LAMBDA NIL (* MJD "15-May-86 15:15") (MENU (create MENU ITEMS _ (QUOTE (DIAGONAL VERTICAL HORIZONTAL SQUARE ROUND other))))) ) +) + + + +(* TABLET AND SUPPORT FNS) + +(DEFINEQ + +(ACE.EDIT.POINT&CODE (LAMBDA (DEVICE) (* MD "19-Jun-85 16:56") (* THIS MESS RETURNS (CODE X NIL) FOR THE DEVICE SELECTED) (* CODE IS NIL, VERTEX OR TOGGLE) (* X AND Y ARE RELATIVE TO THE SEQUENCE. USUALLY THE SEQUENCE'S 0,0 IS AT THE WINDOW'S 0,0 THEREFORE, COORS IN THE A.C.W ARE SEQUENCE COORS, NOT WINDOW COORS. E.S.L.DRAW TAKES CARE TO CORRECT FOR ANY DIFFERENCE) (PROG (POINT&CODE XCOOR YCOOR) (ACE.GET.DEVICE.STATE DEVICE) (SETQ XCOOR (ACE.MT.SCRX.SEQX LASTMOUSEX)) (SETQ YCOOR (ACE.MT.SCRY.SEQY LASTMOUSEY)) (SETQ POINT&CODE (DECODEBUTTONS (QUOTE (LEFT MIDDLE RIGHT)))) (COND (POINT&CODE (FLIPCURSOR) (until (EQP LASTMOUSEBUTTONS 0) do (ACE.GET.DEVICE.STATE DEVICE)) (FLIPCURSOR) (SETQ POINT&CODE (COND ((EQUAL POINT&CODE (QUOTE (LEFT))) (QUOTE VERTEX)) ((EQUAL POINT&CODE (QUOTE (MIDDLE))) (QUOTE TOGGLE)) ((EQUAL POINT&CODE (QUOTE (RIGHT))) (QUOTE OPTIONS)))))) (COND ((EQ DEVICE (QUOTE MOUSE)) NIL) ((EQ DEVICE (QUOTE MM1201)) (\SETCURSORPOSITION LASTMOUSEX LASTMOUSEY))) (ACE.UPD.CONTROL.WINDOW (QUOTE CURSOR) (CONS XCOOR YCOOR)) (RETURN (CONS POINT&CODE (CONS XCOOR YCOOR))))) ) + +(ACE.GET.DEVICE.STATE (LAMBDA (DEVICE) (* PmT "24-Apr-85 16:57") (* Updates LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS LASTKEYBOARD based on DEVICE (mouse or tablet (MM1201))) (PROG (POINT&CODE) (COND ((EQ DEVICE (QUOTE MOUSE)) (GETMOUSESTATE)) ((EQ DEVICE (QUOTE MM1201)) (SETQ POINT&CODE (ACE.MM1201POLL 1)) (COND ((BITTEST (CDR POINT&CODE) 64) NIL) (T (COND ((BITTEST (CDR POINT&CODE) 2) (SETQ LASTMOUSEBUTTONS 1)) ((BITTEST (CDR POINT&CODE) 1) (SETQ LASTMOUSEBUTTONS 4)) (T (SETQ LASTMOUSEBUTTONS 0))) (SETQ LASTMOUSEX (CAAR POINT&CODE)) (SETQ LASTMOUSEY (CDAR POINT&CODE)) (SETQ LASTKEYBOARD (\EVENTKEYS)))))))) ) + +(ACE.GET.DEVICE.STATE&CURSOR (LAMBDA NIL (* PmT "25-Apr-85 14:10") (* Updates LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS LASTKEYBOARD based on the window prop value of DEVICE; Also, puts cursor info in status window (sequence referrenced)) (PROG (DEVICE POINT&CODE) (SETQ DEVICE (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE ACE.DEVICE))) (COND ((EQ DEVICE (QUOTE MOUSE)) (GETMOUSESTATE)) ((EQ DEVICE (QUOTE MM1201)) (SETQ POINT&CODE (ACE.MM1201POLL 1)) (COND ((BITTEST (CDR POINT&CODE) 64) NIL) (T (COND ((BITTEST (CDR POINT&CODE) 2) (SETQ LASTMOUSEBUTTONS 1)) ((BITTEST (CDR POINT&CODE) 1) (SETQ LASTMOUSEBUTTONS 4)) (T (SETQ LASTMOUSEBUTTONS 0))) (SETQ LASTMOUSEX (CAAR POINT&CODE)) (SETQ LASTMOUSEY (CDAR POINT&CODE)) (\SETCURSORPOSITION LASTMOUSEX LASTMOUSEY) (SETQ LASTKEYBOARD (\EVENTKEYS)))))) (ACE.MAC.CW.INFO.CLIP (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) (CONS (ACE.MT.SCRX.SEQX LASTMOUSEX) (ACE.MT.SCRY.SEQY LASTMOUSEY)))))) ) + +(ACE.EXTRACTBM (LAMBDA NIL (* MJD "22-May-86 15:16") (PROG (SHAPE BMNAME) (SETQ SHAPE (GETREGION 4 4 (QUOTE (32 . 32)))) (SETQ BMNAME (BITMAPCREATE (CADDR SHAPE) (CADDDR SHAPE))) (BITBLT (SCREENBITMAP) (CAR SHAPE) (CADR SHAPE) (EVAL BMNAME) 0 0 (CADDR SHAPE) (CADDDR SHAPE) (QUOTE INPUT) (QUOTE REPLACE)) (RETURN BMNAME))) ) + +(ACE.EDIT.REDRAW.ABITMAP (LAMBDA (ABITMAP) (* PmT " 2-Jan-85 18:28") (BITBLT ABITMAP 0 0 ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF NIL NIL (QUOTE INPUT) (QUOTE REPLACE) NIL NIL)) ) + +(ACE.SCALE.BITMAP (LAMBDA (BITMAP FACTOR) (* PmT " 2-May-85 20:19") (* SCALES BITMAPS BY AN ARBITRARY AMOUNT OF 2 DECIMAL PLACES. FACTOR CAN BE OF THE FOLLOWING FORMS%: I (AN INTEGER REPRESENTING A PERCENTAGE AMOUNT; E.G. I=67 MEANS REDUCE THE X AND Y AXIS TO 67% OF THEIR ORIGINAL) ; R (A REAL; E.G. R=1.3 MEANS INCREASE THE X AND Y AXIS BY A FACTOR OF 1.3) ; (IX . IY) (A DOTTED PAIR OF INTEGERS; E.G. (75 . 125) MEANS REDUCE THE X AXIS TO 75% OF ORIGINAL; INCREASE Y TO 125% OF ORIGINAL) ; (RX . RY) (A DOTTED PAIR OF REALS; E.G. (2.3 . 0.81) MEANS 2.3 TIMES ORIGINAL X AXIS, 0.81 TIMES ORIGINAL Y)) (PROG (XFACTOR YFACTOR DELTAX DELTAY XROUND YROUND BITMAPWIDTH BITMAPHEIGHT HEIGHT-1 RASTERWIDTH BITMAPBASE NEWBITMAP NEWHEIGHT-1 NEWBITMAPBASE NEWRASTERWIDTH ORIGBASE NEWBASE ORIGWORD NEWWORD XSTART YSTART ENDX ENDY ONLINE) (OR (type? BITMAP BITMAP) (\ILLEGAL.ARG BITMAP)) (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (COND ((NUMBERP FACTOR) (SETQ XFACTOR FACTOR) (SETQ YFACTOR FACTOR)) ((POSITIONP FACTOR) (SETQ XFACTOR (CAR FACTOR)) (SETQ YFACTOR (CDR FACTOR))) (T (\ILLEGAL.ARG FACTOR))) (AND (FLOATP XFACTOR) (SETQ XFACTOR (FIX (FTIMES XFACTOR 100)))) (AND (FLOATP YFACTOR) (SETQ YFACTOR (FIX (FTIMES YFACTOR 100)))) (SETQ XFACTOR (IMIN SCREENWIDTH XFACTOR)) (SETQ YFACTOR (IMIN SCREENHEIGHT YFACTOR)) (COND ((ILESSP XFACTOR 101) (SETQ DELTAX 100) (SETQ XROUND (IQUOTIENT XFACTOR 2))) (T (SETQ DELTAX XFACTOR) (SETQ XROUND 50))) (COND ((ILESSP YFACTOR 101) (SETQ DELTAY 100) (SETQ YROUND (IQUOTIENT YFACTOR 2))) (T (SETQ DELTAY YFACTOR) (SETQ YROUND 50))) (SETQ NEWBITMAP (BITMAPCREATE (IQUOTIENT (IPLUS XROUND DELTAX (ITIMES (SUB1 BITMAPWIDTH) XFACTOR)) 100) (IQUOTIENT (IPLUS YROUND DELTAY (ITIMES (SUB1 BITMAPHEIGHT) YFACTOR)) 100) 1)) (* MAKE ALL VALUES QUICKLY AVAILABLE) (SETQ HEIGHT-1 (SUB1 BITMAPHEIGHT)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (* AND THE NEW BITMAP VALUES) (SETQ NEWHEIGHT-1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of NEWBITMAP))) (SETQ NEWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of NEWBITMAP)) (SETQ NEWBITMAPBASE (fetch (BITMAP BITMAPBASE) of NEWBITMAP)) (* OK, CRANK IT OUT) (* ORIGWORD AND NEWWORD ARE SORTA CACHED FOR SPEED PURPOSES) (for Y from 0 to HEIGHT-1 do (SETQ ORIGBASE (\ADDBASE BITMAPBASE (ITIMES RASTERWIDTH (IDIFFERENCE HEIGHT-1 Y)))) (SETQ ONLINE NIL) (for X from 0 to (SUB1 BITMAPWIDTH) do (AND (ZEROP (IMOD X 16)) (SETQ ORIGWORD (\GETBASE ORIGBASE (LRSH X 4)))) (* LOOK FOR STRINGS OF "ON" BITS; THEN TREAT AS A LINE FOR TRANSLATIONAL PURPOSES) (COND ((BITTEST ORIGWORD (\WORDELT BITMASKARRAY (IMOD X 16))) (OR ONLINE (AND (SETQ ONLINE T) (SETQ XSTART X) (SETQ YSTART Y)))) ((NULL ONLINE) (* JUST SKIP OVER BLANKS)) (T (* SPELL THIS ALL OUT SO I CAN SEE WHAT'S GOIN' ON HERE) (SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR)) 100)) (SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR) YROUND DELTAY) 100)) (SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR)) 100)) (SETQ ENDX (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 X) XFACTOR)) 100)) (for NY from YSTART to (SUB1 ENDY) do (SETQ NEWWORD (\GETBASE (SETQ NEWBASE (\ADDBASE NEWBITMAPBASE (ITIMES NEWRASTERWIDTH (IDIFFERENCE NEWHEIGHT-1 NY)))) (LRSH XSTART 4))) (for NX from XSTART to ENDX do (AND (ZEROP (IMOD NX 16)) (SETQ NEWWORD (\GETBASE NEWBASE (LRSH NX 4)))) (SETQ NEWWORD (LOGOR NEWWORD (\WORDELT BITMASKARRAY (IMOD NX 16)))) (AND (ZEROP (IMOD (ADD1 NX) 16)) (\PUTBASE NEWBASE (LRSH NX 4) NEWWORD))) (\PUTBASE NEWBASE (LRSH ENDX 4) NEWWORD)) (SETQ ONLINE NIL)))) (COND (ONLINE (* GOTTA CLEANUP AFTER THE LAST CASE) (* THIS IN CASE WORKING ON A LINE THAT GOES TO END OF BITMAP) (* GAWD! WHAT A WASTE O SPACE THIS IS. FIX LATER) (SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR)) 100)) (SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR) YROUND DELTAY) 100)) (SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR)) 100)) (SETQ ENDX (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 BITMAPWIDTH) XFACTOR)) 100)) (for NY from YSTART to (SUB1 ENDY) do (SETQ NEWWORD (\GETBASE (SETQ NEWBASE (\ADDBASE NEWBITMAPBASE (ITIMES NEWRASTERWIDTH (IDIFFERENCE NEWHEIGHT-1 NY)))) (LRSH XSTART 4))) (for NX from XSTART to ENDX do (AND (ZEROP (IMOD NX 16)) (SETQ NEWWORD (\GETBASE NEWBASE (LRSH NX 4)))) (SETQ NEWWORD (LOGOR NEWWORD (\WORDELT BITMASKARRAY (IMOD NX 16)))) (AND (ZEROP (IMOD (ADD1 NX) 16)) (\PUTBASE NEWBASE (LRSH NX 4) NEWWORD))) (\PUTBASE NEWBASE (LRSH ENDX 4) NEWWORD))))) (RETURN NEWBITMAP))) ) + +(ACE.COMPILE.FRAME.ACE (LAMBDA (PREC SUCC VERTICAL THRESHOLD) (* MJD "28-May-86 17:14") (* Calls the frame compiler on PREC and SUCC (bitmaps) ; returns the changes required to go from PREC to SUCC; supplies defaults if not given. VERTICAL and THRESHOLD are special args to the compiler) (* NEXT TWO ARE ARBITRARY DEFAULTS) (OR VERTICAL (SETQ VERTICAL 16)) (OR THRESHOLD (SETQ THRESHOLD 50)) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "COMPILING") (* ACE.COMPILE.FRAME PREC SUCC VERTICAL THRESHOLD) (SETQ ACE.COMPILER (ADD.PROCESS (BQUOTE (ACE.COMPILE.FRAME %, PREC %, SUCC %, VERTICAL %, THRESHOLD))))) ) + +(ACE.MM1201.INIT (LAMBDA (INIT?) (* PmT "24-Apr-85 17:16") (* Inits the RS232 port and the MM1201 graphics tablet; If INIT? = ASK then the user is asked if s/he wants to init; If = T then else auto init; else just the tablet is initialized) (* DEFAULT RS232 IS 4800; DOESN'T QUITE WORK AT 9600) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "INIT TABLET") (COND ((OR (EQ INIT? T) (AND (EQ INIT? (QUOTE ASK)) (ACE.CONFIRMIT "Click LEFT to Initialize Tablet." T))) (RS232INIT (COND ((KEYDOWNP (QUOTE LSHIFT)) (OR (MENU (create MENU ITEMS _ (QUOTE (9600 4800 2400 1200 600 300 150 75)) TITLE _ "Select Baud Rate" CENTERFLG _ T)) 4800)) (T 4800)) 8 NIL 1) (forDuration 50 timerUnits (QUOTE MILLISECONDS)) (RS232CLEARBUFFER (QUOTE BOTH)) (RS232WRITEBYTE 32 T) (* set tablet baud rate%:) (forDuration 50 timerUnits (QUOTE MILLISECONDS)))) (RS232CLEARBUFFER (QUOTE BOTH)) (* Set x and y scale factors%: USE SCREEN SIZE (Scaling to window size is an interesting idea)) (RS232WRITEBYTE 114) (RS232WRITEBYTE (LOGAND SCREENWIDTH 255)) (RS232WRITEBYTE (LRSH SCREENWIDTH 8)) (RS232WRITEBYTE (LOGAND SCREENHEIGHT 255)) (RS232WRITEBYTE (LRSH SCREENHEIGHT 8) T) (forDuration 50 timerUnits (QUOTE MILLISECONDS)) (RS232WRITEBYTE 68 T) (* SET TABLET FOR POLLING MODE)) ) + +(ACE.MM1201POLL (LAMBDA (COUNT) (* PmT "24-Apr-85 17:22") (* Returns a point in the form ((X . Y) . CODE) Sends out the command to poll the pen; receives data describing the pen's current state) (* HACKED FROM MD "13-Jun-84 16:08") (PROG (PT) (AND (EQP COUNT 3) (RETURN (ACE.MM1201.PROBLEM (QUOTE NODATA)))) (RS232WRITEBYTE 80 T) (* CONDUCT A POLL!) (SETQ PT (LIST (RS232READBYTE 30 (QUOTE MILLISECONDS)) (RS232READBYTE 15 (QUOTE MILLISECONDS)) (RS232READBYTE 15 (QUOTE MILLISECONDS)) (RS232READBYTE 15 (QUOTE MILLISECONDS)) (RS232READBYTE 15 (QUOTE MILLISECONDS)))) (COND ((FMEMB NIL PT) (RETURN (ACE.MM1201POLL (ADD1 COUNT))) (* If read screws up, try again (up to 3 times) ; then tell user trouble)) (T (RETURN (CONS (CONS (LOGOR (CADR PT) (LLSH (CADDR PT) 7)) (LOGOR (CADDDR PT) (LLSH (CAR (LAST PT)) 7))) (CAR PT))))))) ) + +(ACE.MM1201.PROBLEM (LAMBDA (PROBLEM) (* PmT "24-Apr-85 17:25") (* Called if tablet ain't woikin right; try a re-init) (ACE.TELLEM "Tablet (MM1201) data problem." T) (ACE.TELLEM "Will try to Re-Initialize Tablet" (QUOTE L)) (ACE.CONFIRMIT "Click ANY to continue." (QUOTE L) (QUOTE ANY)) (ACE.MM1201.INIT (QUOTE ASK)) (ACE.MM1201POLL 1)) ) + +(ACE.EDIT.CLEAR.ALL.MENUS (LAMBDA NIL (* PmT "24-Apr-85 17:27") (* THIS JUST ZAPS ALL MENUS AT LOAD TIME) (* MAKE THIS NICER SOME TIME) (SETQ ACE.EDIT.FRAME.MENU NIL) (SETQ ACE.EDIT.LINEART.ADJ.MENU NIL) (SETQ ACE.EDIT.MOVE.MENU NIL) (SETQ ACE.EDIT.TEXT.FONT.MENU NIL) (SETQ ACE.EDIT.TEXT.SIZE.MENU NIL) (SETQ ACE.EDIT.TEXT.FACE.MENU NIL) (SETQ ACE.EDIT.TEXTURE.MENU NIL) (SETQ ACE.EDIT.PUTDOWN.MENU NIL)) ) + +(ROTATEBM (LAMBDA (SOURCE DEST ANGLE) (* MJD "23-May-86 15:20") (* Original code by Kelly Roach (Roach.pa)) (PROG (SWIDTH SWIDTH2 SHEIGHT2 DWIDTH DWIDTH2 DHEIGHT2 DHEIGHT SIN COS AU BU CU AV BV CV U1 V1 U2 V2 DELTAU DELTAV) (CURSOR WAITINGCURSOR) (SETQ SWIDTH (COND ((WINDOWP SOURCE) (WINDOWPROP SOURCE (QUOTE WIDTH))) ((BITMAPP SOURCE) (BITMAPWIDTH SOURCE)) (T (\ILLEGAL.ARG SOURCE)))) (SETQ SWIDTH2 (IQUOTIENT SWIDTH 2)) (SETQ SHEIGHT2 (IQUOTIENT (COND ((WINDOWP SOURCE) (WINDOWPROP SOURCE (QUOTE HEIGHT))) ((BITMAPP SOURCE) (BITMAPHEIGHT SOURCE)) (T (\ILLEGAL.ARG SOURCE))) 2)) (SETQ DWIDTH (COND ((WINDOWP DEST) (WINDOWPROP DEST (QUOTE WIDTH))) ((BITMAPP DEST) (BITMAPWIDTH DEST)) (T (\ILLEGAL.ARG DEST)))) (SETQ DWIDTH2 (IQUOTIENT DWIDTH 2)) (SETQ DHEIGHT (COND ((WINDOWP DEST) (WINDOWPROP DEST (QUOTE HEIGHT))) ((BITMAPP DEST) (BITMAPHEIGHT DEST)) (T (\ILLEGAL.ARG DEST)))) (SETQ DHEIGHT2 (IQUOTIENT DHEIGHT 2)) (SETQ SIN (SIN ANGLE)) (SETQ COS (COS ANGLE)) (SETQ AU COS) (SETQ BU SIN) (SETQ CU (FPLUS SWIDTH2 (FTIMES (FMINUS DWIDTH2) COS) (FTIMES (FMINUS DHEIGHT2) SIN))) (SETQ AV (FMINUS SIN)) (SETQ BV COS) (SETQ CV (FPLUS SHEIGHT2 (FTIMES DWIDTH2 SIN) (FTIMES (FMINUS DHEIGHT2) COS))) (SETQ U1 CU) (SETQ V1 CV) (SETQ U2 (FPLUS (FTIMES AU DWIDTH) CU)) (SETQ V2 (FPLUS (FTIMES AV DWIDTH) CV)) (for Y from 0 to DHEIGHT do (SETQ DELTAU (FTIMES Y BU)) (SETQ DELTAV (FTIMES Y BV)) (TEXTURELINE SOURCE (FIXR (FPLUS U1 DELTAU)) (FIXR (FPLUS V1 DELTAV)) (FIXR (FPLUS U2 DELTAU)) (FIXR (FPLUS V2 DELTAV)) DEST 0 Y DWIDTH)) (CURSOR T))) ) + + + + +(RS232LOSTCHARFN (LAMBDA NIL (* PmT "20-Nov-84 14:19") NIL)) +) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS ACE.POPPOS MACRO ((STACK X Y) + (SETQ Y (pop STACK)) + (SETQ X (fetch (POSITION XCOORD) of Y)) + (SETQ Y (fetch (POSITION YCOORD) of Y] + +[PUTPROPS ACE.PUSHPOS MACRO ((X Y STACK) + (push STACK (CREATEPOSITION X Y] +) +(RPAQ ACE.EDIT.LINEART.SQUARE.CURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@OOONHA@BHA@BHA@BHA@BHA@BHA@BOOONHA@BHA@BHA@BHA@BHA@BHA@BOOON +) (QUOTE NIL) 7 7)) + +(RPAQQ ACELOGOMAP #*(64 128)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@CG@@@@@@@@@@@@@@CAL@@@@@@@@@@@@@B@G@@@@@@@@@@@@@F@AL@@@@@@@@@@@@FC@F@@@@@@@@@@@@DG@CH@@@@@@@@@@@LM@AL@@@@@@@@@@@IM@@G@@@@@@@@@@@KG@@AL@@@@@@C@@MJC@@@F@@@@@@C@@M@A@@@CH@@@@@@@AI@A@@@@L@@@G@C@AK@@@@@@C@@@EHCCKB@@@@@@AH@CLHCBNF@@@@@@@F@NDMCFFD@@@@@@@K@BFMCFDL@@@@@@CILCFEJFLH@@@@@@GHFAB@NCIH@@@@@@OHAAH@@@A@@@B@@@OHG@@GO@C@@@F@@@OHL@CLAON@@@N@@@OAH@N@@@D@@AN@@@LC@AH@@@L@@CN@@@HF@B@@@@H@@GN@@@@L@C@@@AH@@ON@@@AH@C@@@O@@AON@@@C@@B@@AJ@@CMN@@@F@@B@@AF@@GIN@@@L@@B@@AL@@OAN@@AH@@B@@AH@ANAN@@A@@@C@@@H@CLAN@@C@@@A@@@H@GHAN@@B@@@AH@@L@ONAN@@F@@@@L@@FAOOIN@@OH@@@O@@CCLOOL@@MH@@@GH@AOHCOL@AHN@@@CN@@C@AOL@A@CH@@AO@@AH@GL@CL@L@@@OL@@N@CL@FF@F@@@GN@@CHCL@DB@C@@@COH@@OCL@HC@@H@@COL@@AOLAHA@@L@@FGO@@@CLA@CH@F@@FAOL@@@FC@CH@C@@F@OO@@@CJ@O@@A@@L@COL@@@GOH@@A@@L@@ON@@@@@@@@A@@L@@GOL@@@@@@@A@@H@@AOO@@@@@@@C@AH@@@CON@@@@@@G@AH@@@@OOH@@@@GO@AH@@@@COOHAOOON@A@@@@@@OOOOOOOL@C@@@@@@COOOOOOH@B@@@@@@FGOOOOO@@B@@@@@@DOOOOO@@@D@@@@@@LONGL@@@@D@@@@@@HOL@@@LH@L@@@@@AIOH@@@EH@H@@@@@ACOA@HDO@@H@@@@@CCNCNNNN@AH@@@@@BGNCBONB@A@@@@@@FGLFFICCAA@@@@@@DOLFDIKAKC@@@@@@LOHOLLIHNB@@@@@@IOHL@LHH@F@@@@@AKOAH@@@@@F@@@@@ACNAH@@@@@D@@@@@CGNA@@@@@@D@@@@@FGL@@@@@@@D@@@@@DOH@@@@@@@D@@@@@MOH@@@@@@@D@@@@@IO@@@@@@@@F@@@@AKO@@@@@@AHC@@@@CCN@@@@@@C@AH@@@BGL@@@@@@F@AL@@@FGL@@@@CLD@@N@@@LOH@@@@FFL@@OH@AIOH@@@@FFO@@GN@CGO@@@@@BDIH@AOOOOL@@@@@CLHH@@GOOOH@@@@@FFOH@@AOON@@@@@@FFG@@@@@@@@@@@@@FF@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@ +) + +(RPAQQ RS232LOSTCHARFN RS232LOSTCHARFN) + + + +(* MENUS FOR ACE-EDIT) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS ACE.CONTROL.WINDOW ACE.EDIT.FRAME.MENU ACE.EDIT.LINEART.ADJ.MENU ACE.EDIT.MOVE.MENU + ACE.EDIT.TEXT.FONT.MENU ACE.EDIT.TEXT.SIZE.MENU ACE.EDIT.TEXT.FACE.MENU ACE.EDIT.TEXTURE.MENU + ACE.EDIT.PUTDOWN.MENU) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(ACE.EDIT.CLEAR.ALL.MENUS) +) +(PUTPROPS ACE COPYRIGHT ("Michel Denber" 1988 1993)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (8402 32042 (ACE 8412 . 11427) (ACE.ANIMATE 11429 . 12643) (ACE.RUN 12645 . 14531) ( +ACEGETFRAME# 14533 . 14721) (ACERUNLOOP 14723 . 15234) (ACE.NEW.SEQUENCE 15236 . 17042) (ACE.NEW.FRAME + 17044 . 17853) (ACE.QUIT.ACE 17855 . 18494) (ACE.RESET.SEQ 18496 . 18848) (ACE.RUN.CURRENT.SEQ 18850 + . 19432) (ACE.DELAY 19434 . 21072) (ACE.DELAY.FRAME 21074 . 22544) (ACE.DELAY.SEQ 22546 . 23005) ( +ACE.DECREMENT.FRAME 23007 . 23324) (ACE.INCREMENT.FRAME 23326 . 25083) (ACE.DELETE.FRAME 25085 . 26954 +) (ACE.SET.DEVICE 26956 . 28256) (ACE.QUICKDRAW&UPD 28258 . 30527) (ACE.RECONSTRUCT.FRAME 30529 . +31887) (SUBLIST 31889 . 32040)) (32070 41108 (ACE.TRILLIUM 32080 . 36038) (ACE.TRILLIUM.LOOP 36040 . +37514) (ACE.RUN.TRILLIUM 37516 . 40110) (ACE.QUIT.TRILLIUM 40112 . 40326) (ACE.CREATE.EDITING.BORDER +40328 . 41106)) (41131 46621 (ACE.GET.SEQ.FILE 41141 . 43680) (ACE.PUT.SEQ.FILE 43682 . 46452) ( +ACE.GET.A.FILE.NAME 46454 . 46619)) (46645 69991 (ACE.ASKEM 46655 . 47960) (ACE.TELLEM 47962 . 48645) +(ACE.CONFIRMIT 48647 . 49654) (ACE.DEFINE.SEQ.WINDOW 49656 . 50754) (ACE.FIGURE.OUT.WINDOW 50756 . +51595) (ACE.RETURN.CLOSEST.VERTEX 51597 . 52368) (ACE.NEW.SEQ.ASST 52370 . 53315) ( +ACE.DELAY.FRAME.ASST 53317 . 53657) (ACE.SETUP.CW.CLIPPING.REGIONS 53659 . 57954) (ACE.CHECKSTUFF +57956 . 58409) (ACE.UPD.CONTROL.WINDOW 58411 . 60894) (ACE.UPD.CW.MULE 60896 . 63307) ( +ACE.UPD.CLEAR.SET.LINE 63309 . 63600) (ACE.CREATE.CONTROL.MENU 63602 . 66540) (ACE.SEQ.FETCH.WIDTH +66542 . 66912) (ACE.SEQ.FETCH.HEIGHT 66914 . 67288) (ACE.SET.SEQ.CLIP.REGION 67290 . 67696) ( +ACE.ASKEM2 67698 . 68307) (ACE.TELLEM2 68309 . 68593) (ACE.UPD.CONTROL.WINDOW2 68595 . 69989)) (78287 +81190 (ACE.COMPILE.FRAME 78297 . 79466) (ACE.EXTRACT 79468 . 80697) (ACESETTHRESHOLD 80699 . 81188)) ( +81226 87040 (ACE.MAX.REGIONS 81236 . 82654) (ACE.PICK.BEST.REGION 82656 . 86738) (ACE.COMPUTE.AREA +86740 . 87038)) (87081 92213 (ACE.SCAN.BITMAPS 87091 . 90057) (ACE.SCAN.PRIMBLOCKS 90059 . 91588) ( +ACE.FETCH.BLOCK 91590 . 92211)) (93893 101007 (ACE.EDIT 93903 . 95686) (ACE.EDIT.FRAME 95688 . 96959) +(ACE.EDIT.SETUP.EDIT.MENU 96961 . 98326) (ACEGETREGIONFACTOR 98328 . 98664) (ACEROTATEREGION 98666 . +99692) (ACESCALEREGION 99694 . 101005)) (101032 104846 (ACE.EDIT.LINEART 101042 . 102207) ( +ACE.EDIT.LINEART.DRAW 102209 . 103346) (ACE.EDIT.LINEART.ADJ 103348 . 104458) ( +ACE.EDIT.LINEART.TRACKLINE 104460 . 104844)) (104879 132278 (ACE.EDIT.MOVE.REGION 104889 . 106327) ( +ACE.EDIT.COMBINE.REGION 106329 . 106937) (ACE.EDIT.TEXT 106939 . 109812) (ACE.EDIT.TEXTURE.REGION +109814 . 111378) (ACE.EDIT.TEXTURE.AREA 111380 . 113636) (ACE.EDIT.PAINT 113638 . 125658) ( +ACE.FILLWITHTEXTURE 125660 . 126432) (ACE.SCANLINESEEDFILL 126434 . 128587) ( +ACE.EDIT.CREATE.MENU.TEXTURES 128589 . 129163) (ACE.EDIT.PUTDOWN.BITMAP 129165 . 130752) ( +ACE.EDIT.MOVE.REGION.ASST 130754 . 131231) (ACEEDITBM 131233 . 132123) (ACE.READBRUSHSHAPE 132125 . +132276)) (132314 145153 (ACE.EDIT.POINT&CODE 132324 . 133418) (ACE.GET.DEVICE.STATE 133420 . 134038) ( +ACE.GET.DEVICE.STATE&CURSOR 134040 . 134964) (ACE.EXTRACTBM 134966 . 135294) (ACE.EDIT.REDRAW.ABITMAP +135296 . 135493) (ACE.SCALE.BITMAP 135495 . 140087) (ACE.COMPILE.FRAME.ACE 140089 . 140697) ( +ACE.MM1201.INIT 140699 . 141950) (ACE.MM1201POLL 141952 . 142782) (ACE.MM1201.PROBLEM 142784 . 143126) + (ACE.EDIT.CLEAR.ALL.MENUS 143128 . 143539) (ROTATEBM 143541 . 145082) (RS232LOSTCHARFN 145087 . +145151))))) +STOP diff --git a/lispusers/ACE-APPLEDEMO.ACE b/lispusers/ACE-APPLEDEMO.ACE new file mode 100644 index 00000000..b121a692 --- /dev/null +++ b/lispusers/ACE-APPLEDEMO.ACE @@ -0,0 +1 @@ +(FILECREATED "11-Jan-85 14:00:00" {ICE}LISP>ACE>APPLE1.;4 206417 previous date: "10-Jan-85 15:25:13" {ICE}LISP>ACE>APPLE1.;1) (* Copyright (c) by NIL. All rights reserved.) (PRETTYCOMPRINT APPLE1COMS) (RPAQQ APPLE1COMS ((VARS ACE.SEQ.WIDTH ACE.SEQ.HEIGHT) (UGLYVARS ACE.CURRENT.SEQUENCE))) (RPAQQ ACE.SEQ.WIDTH 400) (RPAQQ ACE.SEQ.HEIGHT 225) (READVARS ACE.CURRENT.SEQUENCE) (((1000 (({(READBITMAP)(400 225 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@C@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@C" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CN@@@AOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CN@@@OOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMEEGGEEEEEEGGGGGGGGGGGGGGOGGOGOGGGO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AJJJJJJJJJJJJJJJJJJJJJJJJKNJKJOJJJNO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AKJKKCJJJJJKKCKCCCCCKKKKCKOKKKOKKCFO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOMOMMMEEEEGMMMMOOOMMMMMOOOMOOOOOOMO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGGGOEEEEEGGGGGGGGGGGGGGOGGOGGGGGGO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AJJJKNJJJJJJJJJJJJJJJJJJOJJNJJOJJJMK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AKKKKOJJJJJKKKCCCCCKKKKCOKKOKKOKCCFK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMOOOOMEEEEEMMMMMOOMMMMMOMMOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGGGOGEEEEEGGGGGGGGGGGGGGGOGGGGGGKG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AJJJONJJJJJJJJJJJJJJJJJJJKNIOJJJJKOK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AKKKOOKJJJJJKKCCCCCKKKKKKKKOMKKKCCMC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMOOOOMEEEGGEMMMMMOMMMMMMMOOOOMOOOCO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOGOOGEEEEEGGGGGGGGGGGGGGGGGGGGGGOG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AKNKNJJJJJJJJJJJJJJJJJJJOJJJJOJJJKLK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AKOKOKCJJJJKKKCCCCCKKKKKOKKOKOKCCBOF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOMMMEEGGMMMMMMMMMMMMOMOOOOOOOOMN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGGOGGGEEEEGGGGGGGGGGGGGGGOGGGGGGGF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANOJOJJJJJJJJJJJJJJJJJJKJJJNJJJJJKJN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AIOKOKCJJJJKKKCCCCCKKKKCOCKKKKKCCBKF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOMMMEEGGOMMMMMMMMMMOOOOOOOOOOOMN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOGGGEEEEEGGGGGGGGGGGGOGGGGGGGGGGD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AJOJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJMNL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OCKKCCJJJJJKKCCCCCKKKKKKKKKKKKCCGCD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOMMMMOGGGGMMMMMMMMMMMOOOOMOOOOOML@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MGOGGGGEEEEEGGGGGGGGGGGGGGGGGGG@KGL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NKOJJJJJJJJJJJJJJJJJJJNJJJJOJJJ@NJH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GCOKCCKJJJJKKCCCCKKKKKOKKOKOKK@@GCH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOMMMGGGGMMMMMMMMMMMOMOOMOOOLAMMH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGGOGGGEEEEEGGGGGGGGGGGGGOGGGGFBOGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANKJJJJJJJJJJJJJJJJJKJJJJOJJJJJJJKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOKKCCJJJJJKCKCCCCKKKOCKKOKKKKCGCC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOMMMGGGGEMMMMOOMMOMMMMOOOOOMLMO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGOGGGGEEEGGGGGGGGGGOOGGGGGGGGGGG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FKNJJJJJJJJJJJJJJJJKKNJOJJJJJJNKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GCOCCCJJJKKCKCCKKKKKKOKOKKKKKKCCN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOMMOGGGMMMMOOMMMOMMOOMOOOOMJLL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGOGGGEGEGGGGGGGGGGOGGGGGGGGGAOAL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FKOJJJJJJJJJJJJJJJJOJJJJJJJJJ@JKL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GCOKCCKKJKKKCCCKKKKOKKKKKKKKJ@KCH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOMMMOGGEMMMMOOMMMMOOOOOOMONAEMH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGOGGGGEEGGGGGGGGGGGGGGOOGGGGCOG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CJJJJJJJJJJJJJJJJJJJJJJONJJJJKBK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOKKCCKKKKKCCKKKKKKCCCKOOKKKKBKO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMOMMMMOOMMMMOOMMMMOOOOOOOMOOOMG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OGGGGGGGGGGGGGGGGGGGGGGGGGGGANN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJJJJJJJJJJJJJJJJJJJJJJJJJJJAIF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GKKKCCCCKKCCKKKKKKCCKKKKKKKJ@JL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOMMOOMMMMOOMMMMOOOMMOOOMMCLL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGOGGGGGGGGGGGGGGGGGOGGGGGGGMGL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COJJJJJJJJJJJJJJJJJKOJJJJJJJJKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CKKKKCCCCCCCCCKKKKCKOKKKKKKKOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMOOMOMMMMMMMMMMOOOOOOOOOOMMOGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGGGGGGGGGGGGGGOGGGGGGGGGGEEO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJJJJJJJJJJJJJOJJJNJJJJJJJJKKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OKKKCCCCCCCCCKKKJKKKKKKKKJJKKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GMOOOOMMMOOMMMOGOOGEMMMMOOGGO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGGGGGGGGGGGGGEEEEEOEEGGGEEEG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GJJJJJJJJJKKJJJNJJOKNJJJJJJKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CCKKCCCCKKCKKJJJJJJNKKKKJJJKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CMOOOMOOGGOMMOOGGOOGGGOOGGGGL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGGGGGGGEGGGGGMEEEEGOGEEEGOEL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CBJJJJJJJJJJKKNJNJJKJKNJJOOKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COKKCCCJJKCKKNOJJJJJJJKJJOOKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CMOOMMOOGGOMEEGEEEEEEOOGKGOGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGGGGGGEEEGGEEEEGEDEGGEMGGEG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CBJJJJJJJJJJJJJJJJHBJJKKNJJK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOKKCKKJJJJJJJJJJJH@JJKNJKJN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMMOMMMGGGGEEEEEMEDDEGGGOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMGGGGGEEEEMEEEDJMEDEEEEEOOD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOJJJJJKNNKJJJJK@@JJJJJNJKOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NKKCKKJJJJJJJJJ@@BJJJNJJKJL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OMOOMMGGGGGGGGE@@AGGGGGGOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MGGGGGEEEEEEEEE@@AEEEEEEGOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MJJJJJJKJJJJJJJL@BJNKJJJOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NKKCKKKNJJJJJJJJMJJKJKKKOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NMOOOMMEOGGEGEEEJFEGGGOMMN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NGGGGGEEEEEEEEEEEEEEEGOGNN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GJJKJJJJNNJJJJJJJJJKJKNKOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FCKOKKKKKKKJJJJJJJNKKKOKOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GMOOMMMMMEEMMEEEGEEEOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGGGGGGGGEGGEEEEEEGOGGOGKH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CJJJJJJJJJJJJJJJJJJJJKNOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CCKKKKKKKKKKJJJJJOKKKKOKO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CMMOOMMMMMMMMMEGGGEMOOOKF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGGGGGGGGGGGGEEEEOOGGOEOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOJJJKJJJJJJJJJJJJNJJJKNNOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CKKKKOKKKKKKKKKJJJKKKCOEN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMMMOMMMMMMMMMMMEEEMOOONL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGGOOGGGGCGGGGGEEGGGONKL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AJJKNJJJJJAJJJJJJJJJKOJML@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOKKOKKKKJHGKCCKJKKKCOCGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMOOMMMMMNCOOMOOMMMMOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OGGGGGGGOGGGGGGGGGGGONGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJJJKHNHBJJJJJJJJJKOOKM@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GKKKKHGDGKKKCCCCCKKOONG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GMOOMDE@OOOMMOOOMMOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGGGG@OGGGGGOGGGGGGOOFG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CJJJJOJJJJJOOJJJJJKONNN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CKKKKKKKKKKGCCCCCCKOOKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMOOOGOOOOEOCMOOOOOOOMF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOGGGGGGGGOLAOGGGOOGOGL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NJJJJJJJKOH@FJJKONKNIL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GCCKKKKKKO@@AKCCOOKKKL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GMOOOOOOOL@@AMOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COGGGGGGO@@@@OGGGGGGCH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OJJJJJKN@@@@GNJJJJJO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COCCEGGH@@@@COCCCCFO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOMOOOOH@@@@AOMMONKN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOON@@@@@@GOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOH@@@@@@COOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 0 . 0))) (40 (({(READBITMAP)(16 14 "H@@@" "L@@@" "N@@@" "N@@@" "O@@@" "O@@@" "O@@@" "O@@@" "O@@@" "O@@@" "N@@@" "N@@@" "L@@@" "H@@@")} 0 . 93))) (40 (({(READBITMAP)(16 18 "L@@@" "O@@@" "IH@@" "OL@@" "ON@@" "ON@@" "OO@@" "OO@@" "OO@@" "OO@@" "OO@@" "OO@@" "ON@@" "ON@@" "OL@@" "OH@@" "O@@@" "N@@@")} 0 . 91))) (40 (({(READBITMAP)(16 18 "OL@@" "JO@@" "@AH@" "JKL@" "OON@" "OON@" "OOO@" "OOO@" "OOO@" "OOO@" "OOO@" "OOO@" "OON@" "OON@" "OOL@" "OOH@" "OO@@" "ON@@")} 0 . 91))) (40 (({(READBITMAP)(16 18 "OOL@" "JJO@" "@@AH" "JJKL" "OOON" "OOON" "OOOO" "OOOO" "OOOO" "OOOO" "OOOO" "OOOO" "OOON" "OOON" "OOOL" "OOOH" "OOO@" "OON@")} 0 . 91))) (40 (({(READBITMAP)(32 18 "OOOL@@@@" "JJJO@@@@" "@@@AH@@@" "JJJKL@@@" "OOOON@@@" "OOOON@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOON@@@" "OOOON@@@" "OOOOL@@@" "OOOOH@@@" "OOOO@@@@" "OOON@@@@")} 0 . 91))) (40 (({(READBITMAP)(32 18 "OOOOL@@@" "JJJJO@@@" "@@@@AH@@" "JJJJKL@@" "OOOOON@@" "OOOOON@@" "OOOOOO@@" "OOOOOO@@" "OOOOOO@@" "OOOOOO@@" "OOOOOO@@" "OOOOOO@@" "OOOOON@@" "OOOOON@@" "OOOOOL@@" "OOOOOH@@" "OOOOO@@@" "OOOON@@@")} 0 . 91))) (40 (({(READBITMAP)(16 18 "OL@@" "JO@@" "@AH@" "JKL@" "OON@" "OON@" "OOO@" "OOO@" "OOO@" "OOO@" "OOO@" "OOO@" "OON@" "OON@" "OOL@" "OOH@" "OO@@" "ON@@")} 16 . 91))) (40 (({(READBITMAP)(16 18 "OOL@" "JJO@" "@@AH" "JJKL" "OOON" "OOON" "OOOO" "OOOO" "OOOO" "OOOO" "OOOO" "OOOO" "OOON" "OOON" "OOOL" "OOOH" "OOO@" "OON@")} 16 . 91))) (40 (({(READBITMAP)(32 18 "OOOL@@@@" "JJJO@@@@" "@@@AH@@@" "JJJKL@@@" "OOOON@@@" "OOOON@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOON@@@" "OOOON@@@" "OOOOL@@@" "OOOOH@@@" "OOOO@@@@" "OOON@@@@")} 16 . 91))) (40 (({(READBITMAP)(48 18 "GOOOOOOOL@@@" "FJJJJJJJO@@@" "D@@@@@@@AH@@" "FJJJJJJJKL@@" "GOOOOOOOON@@" "GOOOOOOOON@@" "GOOOOOOOOO@@" "GOOOOOOOOO@@" "GOOOOOOOOO@@" "GOOOOOOOOO@@" "GOOOOOOOOO@@" "GOOOOOOOOO@@" "GOOOOOOOON@@" "GOOOOOOOON@@" "GOOOOOOOOL@@" "GOOOOOOOOH@@" "GOOOOOOOO@@@" "GOOOOOOON@@@")} 0 . 91))) (40 (({(READBITMAP)(48 18 "@GOOOOOOOL@@" "@FJJJJJJJO@@" "@D@@@@@@@AH@" "@FJJJJJJJKL@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOL@" "@GOOOOOOOOH@" "@GOOOOOOOO@@" "@GOOOOOOON@@")} 0 . 91))) (40 (({(READBITMAP)(48 18 "@@GOOOOOOOL@" "@@FJJJJJJJO@" "@@D@@@@@@@AH" "@@FJJJJJJJKL" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOL" "@@GOOOOOOOOH" "@@GOOOOOOOO@" "@@GOOOOOOON@")} 0 . 91))) (40 (({(READBITMAP)(64 18 "@@@GOOOOOOOL@@@@" "@@@FJJJJJJJO@@@@" "@@@D@@@@@@@AH@@@" "@@@FJJJJJJJKL@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOL@@@" "@@@GOOOOOOOOH@@@" "@@@GOOOOOOOO@@@@" "@@@GOOOOOOON@@@@")} 0 . 91))) (40 (({(READBITMAP)(64 18 "@@@@GOOOOOOOL@@@" "@@@@FJJJJJJJO@@@" "@@@@D@@@@@@@AH@@" "@@@@FJJJJJJJKL@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOL@@" "@@@@GOOOOOOOOH@@" "@@@@GOOOOOOOO@@@" "@@@@GOOOOOOON@@@")} 0 . 91))) (40 (({(READBITMAP)(48 18 "@GOOOOOOOL@@" "@FJJJJJJJO@@" "@D@@@@@@@AH@" "@FJJJJJJJKL@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOL@" "@GOOOOOOOOH@" "@GOOOOOOOO@@" "@GOOOOOOON@@")} 16 . 91))) (40 (({(READBITMAP)(48 18 "@@GOOOOOOOL@" "@@FJJJJJJJO@" "@@D@@@@@@@AH" "@@FJJJJJJJKL" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOL" "@@GOOOOOOOOH" "@@GOOOOOOOO@" "@@GOOOOOOON@")} 16 . 91))) (40 (({(READBITMAP)(64 18 "@@@GOOOOOOOL@@@@" "@@@FJJJJJJJO@@@@" "@@@D@@@@@@@AH@@@" "@@@FJJJJJJJKL@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOL@@@" "@@@GOOOOOOOOH@@@" "@@@GOOOOOOOO@@@@" "@@@GOOOOOOON@@@@")} 16 . 91))) (40 (({(READBITMAP)(64 18 "@@@@GOOOOOOOL@@@" "@@@@FJJJJJJJO@@@" "@@@@D@@@@@@@AH@@" "@@@@FJJJJJJJKL@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOL@@" "@@@@GOOOOOOOOH@@" "@@@@GOOOOOOOO@@@" "@@@@GOOOOOOON@@@")} 16 . 91))) (40 (({(READBITMAP)(48 18 "@GOOOOOOOL@@" "@FJJJJJJJO@@" "@D@@@@@@@AH@" "@FJJJJJJJKL@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOL@" "@GOOOOOOOOH@" "@GOOOOOOOO@@" "@GOOOOOOON@@")} 32 . 91))) (40 (({(READBITMAP)(48 18 "@@GOOOOOOOL@" "@@FJJJJJJJO@" "@@D@@@@@@@AH" "@@FJJJJJJJKL" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOL" "@@GOOOOOOOOH" "@@GOOOOOOOO@" "@@GOOOOOOON@")} 32 . 91))) (40 (({(READBITMAP)(64 18 "@@@GOOOOOOOL@@@@" "@@@FJJJJJJJO@@@@" "@@@D@@@@@@@AH@@@" "@@@FJJJJJJJKL@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOL@@@" "@@@GOOOOOOOOH@@@" "@@@GOOOOOOOO@@@@" "@@@GOOOOOOON@@@@")} 32 . 91))) (40 (({(READBITMAP)(64 18 "@@@@GOOOOOOOL@@@" "@@@@FJJJJJJJO@@@" "@@@@D@@@@@@@AH@@" "@@@@FJJJJJJJKL@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOL@@" "@@@@GOOOOOOOOH@@" "@@@@GOOOOOOOO@@@" "@@@@GOOOOOOON@@@")} 32 . 91))) (40 (({(READBITMAP)(48 18 "@GOOOOOOOL@@" "@FJJJJJJJO@@" "@D@@@@@@@AH@" "@FJJJJJJJKL@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOL@" "@GOOOOOOOOH@" "@GOOOOOOOO@@" "@GOOOOOOON@@")} 48 . 91))) (40 (({(READBITMAP)(48 18 "@@GOOOOOOOL@" "@@FJJJJJJJO@" "@@D@@@@@@@AH" "@@FJJJJJJJKL" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOL" "@@GOOOOOOOOH" "@@GOOOOOOOO@" "@@GOOOOOOON@")} 48 . 91))) (40 (({(READBITMAP)(64 18 "@@@GOOOOOOOL@@@@" "@@@FJJJJJJJO@@@@" "@@@D@@@@@@@AH@@@" "@@@FJJJJJJJKL@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOL@@@" "@@@GOOOOOOOOH@@@" "@@@GOOOOOOOO@@@@" "@@@GOOOOOOON@@@@")} 48 . 91))) (40 (({(READBITMAP)(64 18 "@@@@GOOOOOOOL@@@" "@@@@FJJJJJJJO@@@" "@@@@D@@@@@@@AH@@" "@@@@FJJJJJJJKL@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOL@@" "@@@@GOOOOOOOOH@@" "@@@@GOOOOOOOO@@@" "@@@@GOOOOOOON@@@")} 48 . 91))) (40 (({(READBITMAP)(48 18 "@OOOOOOOOH@@" "@MEEEEEEEN@@" "@H@@@@@@@C@@" "@MEEEEEEEGH@" "@OOOOOOOOOL@" "@OOOOOOOOOL@" "@OOOOOOOOON@" "@OOOOOOOOON@" "@OOOOOOOOON@" "@OOOOOOOOON@" "@OOOOOOOOON@" "@OOOOOOOOON@" "@OOOOOOOOOL@" "@OOOOOOOOOL@" "@OOOOOOOOOH@" "@OOOOOOOOO@@" "@OOOOOOOON@@" "@OOOOOOOOL@@")} 64 . 91))) (40 (({(READBITMAP)(48 18 "@@OOOOOOOOH@" "@@MEEEEEEEN@" "@@H@@@@@@@C@" "@@MEEEEEEEGH" "@@OOOOOOOOOL" "@@OOOOOOOOOL" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOOL" "@@OOOOOOOOOL" "@@OOOOOOOOOH" "@@OOOOOOOOO@" "@@OOOOOOOON@" "@@OOOOOOOOL@")} 64 . 91))) (40 (({(READBITMAP)(64 18 "@@@OOOOOOOOH@@AJ" "@@@MEEEEEEEN@@AK" "@@@H@@@@@@@C@@AO" "@@@MEEEEEEEGH@AO" "@@@OOOOOOOOOL@AJ" "@@@OOOOOOOOOL@AK" "@@@OOOOOOOOON@AM" "@@@OOOOOOOOON@AO" "@@@OOOOOOOOON@AJ" "@@@OOOOOOOOON@AK" "@@@OOOOOOOOON@AM" "@@@OOOOOOOOON@AO" "@@@OOOOOOOOOL@AK" "@@@OOOOOOOOOL@AK" "@@@OOOOOOOOOH@AO" "@@@OOOOOOOOO@@AO" "@@@OOOOOOOON@@AN" "@@@OOOOOOOOL@@AI")} 64 . 91))) (40 (({(READBITMAP)(64 18 "@@@@OOOOOOOOH@AJ" "@@@@MEEEEEEEN@AK" "@@@@H@@@@@@@C@AO" "@@@@MEEEEEEEGHAO" "@@@@OOOOOOOOOLAJ" "@@@@OOOOOOOOOLAK" "@@@@OOOOOOOOONAM" "@@@@OOOOOOOOONAO" "@@@@OOOOOOOOONAJ" "@@@@OOOOOOOOONAK" "@@@@OOOOOOOOONAM" "@@@@OOOOOOOOONAO" "@@@@OOOOOOOOOLAK" "@@@@OOOOOOOOOLAK" "@@@@OOOOOOOOOHAO" "@@@@OOOOOOOOO@AO" "@@@@OOOOOOOON@AN" "@@@@OOOOOOOOL@AI")} 64 . 91))) (40 (({(READBITMAP)(48 18 "@OOOOOOOOHAJ" "@MEEEEEEENAK" "@H@@@@@@@CAO" "@MEEEEEEEGIO" "@OOOOOOOOOMJ" "@OOOOOOOOOMK" "@OOOOOOOOOOM" "@OOOOOOOOOOO" "@OOOOOOOOOOJ" "@OOOOOOOOOOK" "@OOOOOOOOOOM" "@OOOOOOOOOOO" "@OOOOOOOOOMK" "@OOOOOOOOOMK" "@OOOOOOOOOIO" "@OOOOOOOOOAO" "@OOOOOOOONAN" "@OOOOOOOOLAI")} 80 . 91))) (40 (({(READBITMAP)(48 32 "@@@@@@@@@@MN" "@@@@@@@@@@MM" "@@@@@@@@GHAO" "@@@@@@@@GIIJ" "@@@@@@@@AIMN" "@@@@@@@@@AMO" "@@@@@@@@@@AM" "@@OOOOOOOOIJ" "@@MEEEEEEEOK" "@@H@@@@@@@BO" "@@MEEEEEEEFG" "@@OOOOOOOONF" "@@OOOOOOOONG" "@@OOOOOOOONC" "@@OOOOOOOONA" "@@OOOOOOOOND" "@@OOOOOOOONE" "@@OOOOOOOONC" "@@OOOOOOOONA" "@@OOOOOOOONG" "@@OOOOOOOONG" "@@OOOOOOOONG" "@@OOOOOOOONO" "@@OOOOOOOOON" "@@OOOOOOOOMI" "@@@@@@@@@@AO" "@@@@@@@@@@AO" "@@@@@@@@@AMJ" "@@@@@@@@@MLO" "@@@@@@@@AL@O" "@@@@@@@@AKHM" "@@@@@@@@@CHN")} 80 . 84))) (40 (({(READBITMAP)(32 4 "@@ALALAM" "@@ANANAM" "@@@G@NAN" "@@@G@NMN")} 96 . 115) ({(READBITMAP)(64 29 "@@@OOOOOOONBJJJJ" "@@@MEEEEEEDEJKKC" "@@@H@@@@@@ALMOMM" "@@@MEEEEEEDHOGGO" "@@@OOOOOOONEFJKN" "@@@OOOOOOONDGKKO" "@@@OOOOOOONBAOOO" "@@@OOOOOOON@IGGO" "@@@OOOOOOONEDJON" "@@@OOOOOOONDEKOO" "@@@OOOOOOONBAOOO" "@@@OOOOOOON@AGOO" "@@@OOOOOOONDBKNJ" "@@@OOOOOOONDCKOK" "@@@OOOOOOON@GOOM" "@@@OOOOOOON@GGOG" "@@@OOOOOOON@OJOJ" "@@@OOOOOOONEOKOK" "@@@@@@@@@@AOOOOM" "@@@@@@@@@@AOOOGG" "@@@@@@@@LAMJOJJJ" "@@@@@@@ALMLOCKKC" "@@@@@@@AML@OOOMM" "@@@@@@@@AKHMGOGG" "@@@@@@@@@CHNKOJJ" "@@@@@@@@AH@GCOKC" "@@@@@@@@CHCGOOOM" "@@@@@@@@GHCCGGOG" "@@@@@@@@G@@ANKJJ")} 80 . 80))) (40 (({(READBITMAP)(32 30 "OONEBJJJ" "EEDNDKKC" "@@AONOMM" "EEDJ@OGO" "OONEEFKN" "OONDDGKO" "OONB@AOO" "OON@HIGO" "OONEEDON" "OONDDEOO" "OONB@AOO" "OON@@IOO" "OONDAGNJ" "OOND@GOK" "OON@@GOM" "OON@HGOG" "OONAAJOJ" "OONFCKOK" "@@AOOOOM" "@@AOOOGG" "LAMJOJJJ" "LMLOCKKC" "ML@OOOMM" "AKHMGOGG" "@CHNKOJJ" "AH@GCOKC" "CHCGOOOM" "GHCCGGOG" "GC@ANKJJ" "@C@AOKKC")} 112 . 79) ({(READBITMAP)(48 22 "@@@@@@@FGIIJ" "@@@@@@@FAIMN" "@@@@@@@@@AMO" "@@@@@@@@@@AM" "@@@@OOOOOONE" "@@@@MEEEEEDN" "@@@@H@@@@@AO" "@@@@MEEEEEDJ" "@@@@OOOOOONE" "@@@@OOOOOOND" "@@@@OOOOOONB" "@@@@OOOOOON@" "@@@@OOOOOONE" "@@@@OOOOOOND" "@@@@OOOOOONB" "@@@@OOOOOON@" "@@@@OOOOOOND" "@@@@OOOOOOND" "@@@@OOOOOON@" "@@@@OOOOOON@" "@@@@OOOOOONA" "@@@@OOOOOONF")} 80 . 91))) (40 (({(READBITMAP)(48 45 "@@@@AH@MED@@" "@@CLCH@NJL@A" "@@CLCH@NJH@J" "@@AOALAMEDAE" "@@AOAHAMEDEE" "@@@@@HANJHJJ" "@@@A@BMNJLJK" "@@@@@@MMMGEM" "@@@@GHAOEEEG" "@@@FGIIJJJJJ" "@@@FAIMNJJKK" "@@@@@AMOMEMM" "@@@@@@AMEEGG" "@OOOOONEEBJJ" "@MEEEEDNOEKC" "@H@@@@AOMLMM" "@MEEEEDJB@OO" "@OOOOONEEEGN" "@OOOOONDDDGO" "@OOOOONB@@AO" "@OOOOON@HHIO" "@OOOOONEEEAN" "@OOOOONDDDAO" "@OOOOONB@@AO" "@OOOOON@@HAO" "@OOOOONDADBJ" "@OOOOOND@DCK" "@OOOOON@@@GM" "@OOOOON@HHOG" "@OOOOONA@DOJ" "@OOOOONF@GOK" "@@@@@@AOOOOM" "@@@@@@AOOOGG" "@@@@LAMJOJJJ" "@@@ALMLOCKKC" "@@@AML@OOOMM" "@@@AIKHMGOGG" "@@@@@CHNKOJJ" "@@@@@H@GCOKC" "@@@@@@@GOOOM" "@@@AL@@CGGOG" "@@@AOC@ANKJJ" "@@@@NCCAOKKC" "@@@ANCC@OOOM" "@@@AHC@@GGOG")} 96 . 77))) (40 (({(READBITMAP)(48 51 "@@@@F@@GEE@@" "@@@@F@@GJJ@@" "@@@@GH@OJJ@@" "@AO@GH@MMD@@" "@AOHGH@MED@@" "@AOLC@LNJL@A" "@@CLC@LNJH@J" "@@@DALMMEDAE" "@@@@@@AMEDEE" "@@C@@@ANJHJJ" "@@CA@BMNJLJK" "@@@@@@MMMGEM" "@@@@GHAOEEEG" "@@@FGIIJJJJJ" "@@@FAIMNJJKK" "@@@@@AMOMEMM" "@@@@@@AMEEGG" "@@OOOONEEEBJ" "@@MEEEDNONEC" "@@H@@@AOMONM" "@@MEEEDJBB@G" "@@OOOONEEEDB" "@@OOOONDDDDC" "@@OOOONB@@@A" "@@OOOON@HHHA" "@@OOOONEEE@@" "@@OOOONDDD@A" "@@OOOONB@@@A" "@@OOOON@@H@A" "@@OOOONDADAF" "@@OOOOND@D@G" "@@OOOON@@@@E" "@@OOOON@HH@G" "@@OOOONA@EAJ" "@@OOOONF@DCK" "@@@@@@AOOOOM" "@@@@@@AOOOGG" "@@@@LAMJOJJJ" "@@@ALMLOCKKC" "@@@AML@OOOMM" "@@@GIKHMGOGG" "@@@F@CHNKOJJ" "@@@@@H@GCOKC" "@@@@@@CGOOOM" "@@@CH@CCGGOG" "@@@CHC@ANKJJ" "@@@CHCFAOKKC" "@@@OHGF@OOOM" "@@@OHOL@GGOG" "@@@F@LN@FKNJ" "@@@F@@N@GCOC")} 96 . 75))) (40 (({(READBITMAP)(32 19 "JJJJJJJJ" "EDDKJJJJ" "HJHCMEEE" "GGGLEEEE" "OONIBJJJ" "DDD@FJJJ" "@@@@AEEE" "HHH@IEEE" "EE@ADJJJ" "DD@@EJJJ" "@@@@CEEE" "@H@@IEEE" "ADAEDJJJ" "@D@DOJJJ" "@@@BAMEE" "HH@HOGEE" "@E@EJJJJ" "@D@ECJJJ" "@@@AMMEE")} 128 . 90) ({(READBITMAP)(32 57 "@@@@F@@A" "@@@AN@@C" "@@@AN@@C" "@@AINAHG" "@@CILAHG" "@@OHLIHO" "@AOHN@@M" "@GOHFF@M" "@GL@@@LN" "@F@@@@LN" "@@@@ALMM" "@@@@@@AM" "@@C@@@AN" "@CCA@BMN" "@G@@@@MM" "@G@@GHAO" "@C@FGIIJ" "@@@FAIMN" "@@@@@AMO" "@@@@@@AM" "@@@@@@AJ" "@@@OOOND" "@@@MEEDJ" "@@@H@@AO" "@@@MEEDO" "@@@OOOND" "@@@OOONB" "@@@OOON@" "@@@OOONE" "@@@OOOND" "@@@OOONB" "@@@OOON@" "@@@OOOND" "@@@OOOND" "@@@OOON@" "@@@OOON@" "@@@OOONA" "@@@OOONF" "@@@OOON@" "@@@@@@AO" "@@@AHAMJ" "@@@AHMLO" "@@@@AL@O" "@@@GIKHM" "@@GNCCHN" "@@GHCH@G" "@@G@F@CG" "@@@BFFCC" "@@@F@F@A" "@@@F@@FA" "@@COHDF@" "@@COHOL@" "@@GN@OB@" "@@GNAOB@" "@@AHAL@@" "@@@@@L@@" "@@@@@L@@")} 96 . 72))) (40 (({(READBITMAP)(16 18 "BJJJ" "DJJJ" "NEEE" "BMEE" "EFJJ" "EFJJ" "BKEE" "HKEE" "EDJJ" "DDJJ" "BKEE" "HKEE" "EFJJ" "LFJJ" "BEEE" "HGEE" "DJJJ" "OJJJ")} 144 . 91) ({(READBITMAP)(48 65 "@@@@F@@@NJJJ" "@@@@F@@@OJJJ" "@@@AN@LAMMEE" "@@@AN@LAOEEH" "@@@ANANANJJ@" "@@AINANCJJL@" "@@GIH@FCME@@" "@@GIH@DGEE@@" "@@OHDC@GJJ@@" "@AOH@C@OJJ@@" "@AN@@@@MMD@@" "@GN@AN@MED@@" "@GH@AHLNJL@A" "@F@@AHLNJH@J" "@@@@ALMMEDAE" "@@@CH@AMEDEE" "@@COH@ANJHJJ" "@@COHBMNJLJK" "@@@@@@MMMGEM" "@@@@GHAOEEEG" "@@@FGIIJJJJJ" "CLANAIMNJJKK" "CLAL@AMOMEMM" "ALAH@@AMEEGG" "@L@@OONEEEEE" "@@@@MEDNONNF" "@@@@H@AOMOMM" "@@@@MEDJBBBJ" "@@@@OONEEEDA" "@@@@OONDDDD@" "@@@@OONB@@@@" "@@@@OON@HHH@" "@@@@OONEEE@A" "@@@@OONDDD@@" "@@@@OONB@@@@" "@@@@OON@@H@@" "@@@@OONDADAE" "@@@@OOND@D@D" "@@@@OON@@@@B" "@@@@OON@HH@H" "@@@@OONA@E@E" "@@@@OONF@D@D" "@@@@@@AOOOOM" "@@@@@@AOOOGG" "@@@@@AMJOJJJ" "@@AH@MLOCKKC" "@@AHAL@OOOMM" "@@@@AKHMGOGG" "@@GHCCHNKOJJ" "@@OHCH@GCOKC" "@OOFF@CGOOOM" "@OLFFFCCGGOG" "@AH@@F@ANKJJ" "@@@@@@FAOKKC" "@@B@@@F@OOOM" "@@B@@@D@GGOG" "@@FAHCN@FKNJ" "@ANAICN@GCOC" "@AN@A@L@GOOO" "@AO@ALL@GGOG" "@AOHAL@@FKOJ" "@COHCL@@GCOK" "@CMHCL@@COOM" "@CL@AL@@CGOG" "@@@@AH@@CJJJ")} 96 . 68))) (40 (({(READBITMAP)(16 2 "@@@A" "@@@A")} 80 . 80) ({(READBITMAP)(16 18 "EBJJ" "ODJJ" "MFEE" "@BME" "EEFJ" "EEFJ" "BJKE" "HJKE" "EEDJ" "DEDJ" "BJKE" "HJKE" "EEFJ" "LEFJ" "BBME" "HHEE" "EDJJ" "LFJJ")} 144 . 91) ({(READBITMAP)(32 75 "@@@@@@F@" "@@@@@@GH" "@@@@@@OH" "@@@@F@OH" "@@@AN@C@" "@@@CN@C@" "@@@CN@@@" "@@@AN@DA" "@ANAH@@A" "@CNAH@@A" "@GNA@@LC" "@GNA@@LC" "@GH@@@LG" "@OH@D@LG" "AOH@FCLO" "AO@@F@@M" "AN@@GN@M" "AL@@GH@N" "@@@@GH@N" "@@ANALMM" "@@AOH@AM" "@@COH@AN" "@@COHBMN" "@@@@@@MM" "@@@@GHAO" "@@@FGIIJ" "CLANAIMN" "CLAL@AMO" "ALAH@@AM" "@L@@@ONE" "@@@@@MDN" "@@@@@HAO" "@@@@@MDJ" "@@@@@ONE" "@@@@@OND" "@@@@@ONB" "@@@@@ON@" "@@@@@ONE" "@@@@@OND" "@@@@@ONB" "@@@@@ON@" "@@@@@OND" "@@@@@OND" "@@@@@ON@" "@@@@@ON@" "@@@@@ONA" "@@@@@ONF" "@@@@@@AO" "@@@@@@AO" "@@@@@AMJ" "@@AH@MLO" "@@AHML@O" "@@@CMKHM" "@O@GCCHN" "@O@FCH@G" "AOANF@CG" "OOMNFFCC" "OMH@@F@A" "N@@@@@@A" "@@B@@@@@" "@@@@@@@@" "@@@AHBFL" "@A@AKBFL" "@AL@O@N@" "@AL@N@N@" "AOL@LCL@" "AOL@LCL@" "AOL@CKL@" "AOL@COH@" "AOHFCH@@" "@OHFGL@@" "@@@NGL@@" "@@@NGL@@" "@@@@CL@@" "@@@@CH@@")} 96 . 63))) (40 (({(READBITMAP)(32 9 "@@@@B@AN" "@@@@@@AL" "@@@G@@AH" "@@@OH@@@" "@@@OH@@@" "@@@GH@@@" "@@@GN@@@" "@@@AN@@@" "@@@@F@@@")} 80 . 103) ({(READBITMAP)(48 29 "@@@@@I@GCCHN" "@@@@@@@FCH@G" "@@@@F@ANF@CG" "@@@AN@ANFFCC" "@@@AL@@@@F@A" "@@COL@@@@@@A" "@@CO@@B@@@@@" "@AOL@@@@@@@@" "@CO@@@@AHBBL" "@CK@@A@AKBBO" "@@@@@@D@O@NC" "@@@@@@@@N@NC" "@@@@@@@@@C@C" "@@@@@@@@@C@C" "@@@@AN@@@KL@" "@@@@AO@@@GH@" "@@@@GO@F@GL@" "@@@ANO@F@GL@" "@@@AOH@N@GH@" "@@@AOH@N@GH@" "@@@AOH@GH@@@" "@@@@@@@GJ@@@" "@@@@@@@GL@@@" "@@@@@@@GL@@@" "@@@@@@@OL@@@" "@@@@@@@OL@@@" "@@@@@@@OL@@@" "@@@@@@@GH@@@" "@@@@@@@G@@@@")} 80 . 56) ({(READBITMAP)(32 23 "@@@@@AL@" "@@@@@AL@" "@@@@N@OH" "@@@@N@OH" "@@@AO@GH" "@@@AO@GH" "@@@AO@AH" "@@@AO@H@" "@@@AN@H@" "@@@AN@@@" "@F@CN@C@" "GN@@@@@@" "GO@@@@DA" "GO@@@@@A" "GH@@@@@A" "GN@@@@LC" "GN@@@@LC" "GL@@@@LG" "GL@@D@LG" "GL@@FCLO" "GL@@F@@M" "G@@@GN@M" "AH@@GH@N")} 96 . 120) ({(READBITMAP)(48 18 "@@NEEEEEEEBJ" "@@LNONNFOODJ" "@@IOMOMMMEFE" "@@LJBBBJ@@BM" "@@NEEEDAEEEF" "@@NDDDD@EEEF" "@@NB@@@@BJJK" "@@N@HHH@HJJK" "@@NEEE@AEEED" "@@NDDD@@DEED" "@@NB@@@@BJJK" "@@N@@H@@HJJK" "@@NDADAEEEEF" "@@ND@D@DLEEF" "@@N@@@@BBBJM" "@@N@HH@HHHJE" "@@NA@E@EEEDJ" "@@NF@D@DLEFJ")} 112 . 91))) (40 (({(READBITMAP)(32 18 "EEEBJJJJ" "OOODJKKC" "MEEFEGMM" "@@@BMGGG" "EEEEFJJJ" "EEEEFKKK" "BJJJKEMM" "HJJJKEGG" "EEEEDJJJ" "DEEEDJKK" "BJJJIGEM" "HJJJKEGG" "EEEEFJJJ" "LEEEFKKK" "BBJJOGMM" "HHJJEEGG" "EEEDJJJJ" "LEEFJKKK")} 144 . 91) ({(READBITMAP)(64 98 "@@@@@@@@@@@C@@@@" "@@@@@@@@@@@CH@@@" "@@@@@@@@@@AOH@@@" "@@@@@@@@@@AOH@@@" "@@@@@@@@@@AOHAL@" "@@@@@@@@@@AOHAL@" "@@@@@@@@@@AOJ@OH" "@@@@@@@@@@@OH@OH" "@@@@@@@@@@@C@@GH" "@@@@@@@@@@@C@@GH" "@@@@@@@@@@@C@@AH" "@@@@@@@@@@@@@@H@" "@@@@@@@@@@@@@@H@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@C@" "@@@@@@@AL@@@@@@@" "@@@@@@@GN@@AH@DA" "@@@@@@@GN@@AH@@A" "@@@@@@@GN@@AO@@A" "@@@@@@@GOALAO@LC" "@@@@@@@GOAL@C@LC" "@@@@@@@GOHN@@@LG" "@@@@@@@AOHO@D@LG" "@@@@@@@AOHGHFCLO" "@@@@@@@@GHGH@@@M" "@@@@@@@@G@@@AN@M" "@@@@@@@@AH@@DH@N" "@@@@@@@@@@@@D@@N" "@@@@@@@@@@ANA@MM" "@@@@@@@@@@CN@@AM" "@@@@@@@@@AON@@AN" "@@@@@@@@@AOOHBMN" "@@@@@@@@@@@@@@MM" "@@@@@@@@@@@@GHAO" "@@@@@@@@@@@@GIIJ" "@@@@@@@@B@@@AIMN" "@@@@@@@@@@A@@AMO" "@@@@@@@@@GO@@@AM" "@@@@@@@@@GN@@@AE" "@@@@@@@@@G@@@@AF" "@@@@@AO@@G@@@@AG" "@@@@@AO@@@@@@@AB" "@@@@@AO@@@@@@@AE" "@@@@@AO@@@@@@@AD" "@@@@@AOH@@@@@@AB" "@@@@@@OH@@@@@@A@" "@@@@@@CH@@@@@@AE" "@@@@@@@@@@@@@@AD" "@@@@@@@@@@@@@@AB" "@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@AD" "@@@@@@@@@@@@@@AD" "@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@AA" "@@@@@@@@@@@@@@AF" "@@@@@@@@@@@@@@AO" "@@@@@@@@@@@@@@AO" "@@@@@@@@@@@@@AMJ" "@@@@@@@@@@AH@MLO" "@@@@@@@@@@AHML@O" "@@@@@@@@@@@CMKHM" "@@@@@@@@@A@GCCHN" "@@@@@@@@@@@FCH@G" "@@@@@@@@@@ANF@CG" "@@@@@@@A@@ANFFCC" "@@@@@@@@@@@@@F@A" "@@@@@@C@@L@@@@@A" "@@@@@@C@@LB@@@@@" "@@@@@AOL@@@@@@@@" "@@@@AOO@@@@AHBBL" "@@@AOOK@@A@AKBBO" "@@@AOL@@@@D@O@NC" "@@@AK@@@@@@@N@NA" "@@@CN@@@@@@@@B@A" "@@@CN@@@@@@@@@@@" "@@@@@@@@@@@@@H@@" "@@@@@@@@@@@@@@@L" "@@@@@@@@@@C@@@DN" "@@@@@@@CK@C@@@DF" "@@@@@@@CK@@L@@HF" "@@@@@@@CG@@N@GH@" "@@@@@@@GOH@F@CH@" "@@@@@@GON@@F@CL@" "@@@@@@GOH@@G@GL@" "@@@@@@GOH@@GHGL@" "@@@@@@GMH@@OIOL@" "@@@@@@OOH@@OIO@@" "@@@@@@OO@@@OH@@@" "@@@@@@@@@@@GH@@@" "@@@@@@@@@@AOH@@@" "@@@@@@@@@@CNL@@@" "@@@@@@@@@@GOL@@@" "@@@@@@@@@@GOH@@@" "@@@@@@@@@@GO@@@@" "@@@@@@@@@@GL@@@@" "@@@@@@@@@@AH@@@@" "@@@@@@@@@@AH@@@@")} 64 . 49))) (40 (({(READBITMAP)(48 18 "EEEEEEEEBJJJ" "GNNFOOOODKKC" "EOMMMEEEFGMM" "JBBJ@@@@BOGG" "EEDAEEEEEFJJ" "DDD@EEEEEGKK" "@@@@BJJJJKMM" "HHH@HJJJJKGG" "EE@AEEEEEDJJ" "DD@@DEEEEDKK" "@@@@BJJJHIEM" "@H@@HJJJJKGG" "ADAEEEEEEFJJ" "@D@DLEEEEGKK" "@@@BBBJJHOMM" "HH@HHHJJJEGG" "@E@EEEEEDJJJ" "@D@DLEEEFKKK")} 128 . 91) ({(READBITMAP)(64 89 "@@@@@@@A@@@@@@@@" "@@@@@@@@@@@AH@DA" "@@@@@@N@@@@AH@@A" "@@@@@GOL@@@AO@@A" "@@@@@GOL@ALAO@LC" "@@@@AOOH@AL@C@LC" "@@@@AOOH@@N@@@LG" "@@@@@CON@@O@D@LG" "@@@@@CON@@GHFCLO" "@@@@@@GN@@GH@@@M" "@@@@@@GO@@@@AN@M" "@@@@@@GO@@@@DH@N" "@@@@@@GO@@@@D@@N" "@@@@@@@@@@ANA@MM" "@@@@@@@@@@@N@@AM" "@@@@@@@@@@@N@@AN" "@@@@@@@@AHAOHBMN" "@@@@@@@@AI@@@@MM" "@@@@@@@@AH@@GHAO" "@@@@@@@@@@@@GIIJ" "@@@@@@@@B@@@AIMN" "@@@@@@@@@@@@@AMO" "@@@@@@@@GG@AN@AM" "@@@@@@@@GG@AN@AJ" "@@@@@@@ANG@@@@AK" "@@@@@AAAOG@@@LAO" "@@@@@@ACO@@@@LAO" "@@@@@@@CN@@@@@AJ" "@@@@@@@CN@@@@@AK" "@@@@L@@CH@@@@@AM" "@@@GL@@@@@@@@@AO" "@@@GL@@@@@@@@@AJ" "@@@CN@@@@@@@@@AK" "@@@CN@@@@@@@@@AM" "@@@AN@@@@@@@@@AO" "@@@@OH@@@@@@@@AK" "@@@@OH@@@@@@@@AK" "@@@@OH@@@@@@@@AO" "@@@@CH@@@@@@@@AO" "@@@@@@@@@@@@@@AN" "@@@@@@@@@@@@@@AI" "@@@@@@@@@@@@@@AO" "@@@@@@@@@@@@@@AO" "@@@@@@@@@@@@@AMJ" "@@@@@@@@@@AH@MLO" "@@@@@@@@@@AHML@O" "@@@@@@@@@@@@MKHM" "@@@@@@@@@A@@CCHN" "@@@@@@@@@@@@CH@G" "@@@@@@@@@@ABF@CG" "@@@@@@@@@@ABFFCC" "@@@@@@@@@@@@@F@A" "@@@@@@C@@O@@@@@A" "@@@@@@@@@OB@@@@@" "@@@@@AH@@@L@@@@@" "@@@@@CH@@ALAHBBL" "@@@AB@C@@AHAKBBO" "@@@CL@@@@CD@O@NC" "@@COH@@@@C@CN@NA" "@CGON@@@@@@G@B@A" "@GGKL@@@@@@G@@@@" "@GO@@@@@@@@@@H@@" "@GN@@@@@@@@@@@@L" "@GH@@@@@@@B@@@DN" "@OH@@@@CC@C@@@DN" "@N@@@@@@A@@@@@@F" "@@@@@@@@@@@B@G@N" "@@@@@@@@@H@B@@@L" "@@@@@@FDB@@B@@AL" "@@@@@@GL@@@C@DAH" "@@@@@@GL@@@CHD@@" "@@@@@@GLH@@CIL@@" "@@@@@@OOH@@CIN@@" "@@@@@COO@@@B@@@L" "@@@@@GON@@@CH@@L" "@@@@AOON@@@OH@AL" "@@@AAOL@@@ANDCOL" "@@@@@MOH@@@ODCON" "@@@@@OOL@@@O@CON" "@@@@@OOL@@AO@COL" "@@@@@CCH@@GO@@C@" "@@@@@@@@@@AO@@@@" "@@@@@@@@@@CN@@@@" "@@@@@@@@@CON@@@@" "@@@@@@@@@CON@@@@" "@@@@@@@@@COL@@@@" "@@@@@@@@@CO@@@@@" "@@@@@@@@@CL@@@@@" "@@@@@@@@@CL@@@@@")} 64 . 43))) (40 (({(READBITMAP)(16 3 "@@FO" "@@FO" "@@FO")} 96 . 137) ({(READBITMAP)(48 18 "JEEEEEEEEBJJ" "JFNFOOOOOEKC" "MGMMMEEEEDMM" "GJBJ@@@@@@OG" "JEDAEEEEEEFJ" "KDD@EEEEEDGK" "O@@@BJJJJJCM" "GHH@HJJJJJIG" "JE@AEEEEEEDJ" "KD@@DEEEEEEK" "O@@@BJJJHHKM" "OH@@HJJJJJIG" "NDAEEEEEEEFJ" "OD@DLEEEEDGK" "O@@BBBJJHHEM" "GH@HHHJJJJGG" "OE@EEEEEEDJJ" "OD@DLEEEEGKK")} 128 . 91) ({(READBITMAP)(48 29 "@@@@@@@@@@@@" "@@@@@@@H@@@@" "@@@@@ADIN@@@" "@@@@@G@IL@@@" "@@@@@GH@@@@@" "@@@@AOL@@@@@" "@@@AIOH@@@@@" "@@@CKOH@@@@C" "@@@CON@@@@@@" "@@@COH@@@@@@" "@@@GO@@@@@@@" "@@@GF@@@@@@@" "@@@ON@@@@@DL" "@@@OH@@@@@DL" "@@@G@@@@@@DH" "@@@G@@@@@@L@" "@@@F@@@@@CL@" "@@@@@@@@@GLH" "@@@@@@@@AOLH" "@@@@@@@AAOL@" "@@@@@@@@@MOH" "@@@@@@@@@OOL" "@@@@@@@@@OOL" "@@@@@@@@AOCH" "@@@@@@@COL@@" "@@@@@@@COOL@" "@@@@@@@@GOL@" "@@@@@@@@GOH@" "@@@@@@@@G@@@")} 48 . 46) ({(READBITMAP)(48 31 "@@F@@@DNCJJJ" "C@G@@@DNAOKK" "A@@@@@@FAMOM" "@@@B@G@N@OGG" "@H@@@@@L@NJJ" "B@@@@@AL@GKK" "@@@A@D@@@GOO" "@@@AHD@@@CGO" "H@@AIL@@@COJ" "H@@AIN@@@CKK" "@@@@@@@@@AMO" "@@@CH@@@@AOG" "@@@AH@@@@@NJ" "@F@@DCHD@@OK" "@F@CDCHF@@GM" "@@@C@C@F@@GG" "@@@C@CAL@@GJ" "@@FC@@C@@@CC" "@@@C@@@L@@CM" "@@BB@@AO@@CG" "@COB@@AO@@CB" "@CON@@GOH@CO" "@COO@@GGH@CM" "@COC@@OKH@CG" "@COC@@OK@@CB" "@COF@@GH@@AO" "@GLN@@F@@@AM" "@GLL@@@@@@AM" "@COL@@@@@@AO" "@COO@@@@@@@N" "@COO@@@@@@@O")} 96 . 38) ({(READBITMAP)(64 37 "@@@@@@@@@@@AH@@A" "@@@@@@@D@@@AO@@A" "@@@@@@BD@ALAO@LC" "@@@@AOJ@@AL@C@LC" "@@@@GOKH@@N@@@LG" "@@@COOOK@@O@D@LG" "@@@COOOC@@GHFCLO" "@@@@GOON@@GH@@@M" "@@@AOOOOL@@@AN@M" "@@@COOOOL@@@DH@N" "@@@CNLGOL@@@@@@N" "@@@@@@@@@@ANA@MM" "@@@@@@@@@@@N@@AM" "@@@@@@@@@@@N@@AN" "@@@@@@@@AHAOHBMN" "@@@@@@@@AI@@@@MM" "@@@@@@@@AH@@@HAO" "@@@@@@@@@@@@DIIJ" "@@@@@@@@B@@@AIMN" "@@@@@@@@@@@@@AMO" "@@@@@@@@GG@AN@AM" "@@@@@@@@DG@AN@AJ" "@@@@@@@M@G@C@@AK" "@@@@@ACLCG@C@LAO" "@@@@@@C@G@@@@LAO" "@@@@@@G@N@F@@@AJ" "@@@@@@NCN@F@@@AK" "@@@@L@LCH@@@@@AM" "@@@D@@@@@@L@@@AO" "@@@G@@@@@@L@@@AJ" "@@@@@@@@@@@@@@AK" "@@GL@@@@@@@@@@AM" "@@OMH@@@@@@@@@AO" "@@OOIH@@@@@@@@AK" "@@OON@@@@@@@@@AK" "@@OLN@@@@@@@@@AO" "@@CLB@@@@@@@@@AO")} 64 . 93))) (40 (({(READBITMAP)(32 5 "@@@@@@LF" "@@@@@@@F" "@@@@@@@@" "H@@AN@@@" "IH@AN@@@")} 80 . 96) ({(READBITMAP)(32 12 "@@@@@@@D" "@@@@@@@@" "@@@@@@@@" "@@@@F@C@" "@@@@OOO@" "@@@AOOON" "@@AIOOOO" "@@AIOOOO" "@@AKNOGO" "@@COFO@@" "@@OONMH@" "@@OONMH@")} 64 . 116) ({(READBITMAP)(48 18 "JJEEEEEEEEBJ" "JKFFOOOOONEC" "MOEMMEEEEGNM" "GGJJ@@@@@B@O" "JJDAEEEEEEEF" "KKD@EEEEEDDG" "OO@@BJJJJJBC" "GGH@HJJJJJHI" "JJ@AEEEEEEED" "KK@@DEEEEEDE" "OO@@BJJJHHJC" "OG@@HJJJJJHI" "NKAEEEEEEEEF" "OK@DLEEEEDDG" "OO@BBBJJHHBE" "GG@HHHJJJJHG" "OJ@EEEEEEEDJ" "OK@DLEEEEDGK")} 128 . 91) ({(READBITMAP)(32 21 "@@@@@@@I" "@@@@@@@I" "@@@@@GH@" "@@@@@O@@" "@@@AHO@@" "@@@@KOH@" "@@@@LN@@" "@@@@LH@@" "@@@LOH@@" "@@@OGH@@" "@@@ON@@@" "@@GOH@@@" "@@OO@@@@" "@@OO@@@@" "@GMN@@@@" "@GOH@@@@" "@AK@@@@@" "@CL@@@@A" "@GL@@@@@" "@G@@@@@@" "@F@@@@@@")} 48 . 52) ({(READBITMAP)(16 51 "FBDO" "@@@M" "@D@M" "D@@N" "@@@N" "A@EM" "@@AM" "@@AN" "H@MN" "@@MM" "@@AO" "D@IJ" "@@MN" "@@MO" "L@AM" "L@AJ" "@@AK" "FLAO" "FLAO" "@@AJ" "@@AK" "@@AM" "@@AO" "@@AJ" "@@AK" "@@AM" "@@AO" "@@AK" "@@AK" "@@AO" "@@AO" "@@AN" "@@AI" "@@AO" "@@AO" "@AMJ" "@ALO" "M@@O" "MAHM" "C@HN" "B@@G" "F@CG" "F@AC" "@@@A" "@@@A" "@@@@" "@@@@" "HB@L" "KBBO" "O@BC" "N@@A")} 112 . 73) ({(READBITMAP)(80 33 "H@@@@@@L@@@AHD@@@CGO" "@@@@@@@HH@@AIL@@@COJ" "@@@@@@@@H@@AIN@@@CKK" "@@@@@@@@@@@@@@@@@AMO" "@@@@@F@H@@@CH@@@@AOG" "@@@@AO@H@@@AH@@@@@NJ" "@@@AAL@@@F@@DCHD@@OK" "@@@@@@@H@F@CDC@F@@GM" "@@@@@CIL@@@C@C@F@@GG" "@@@@@COL@@@C@BAL@@GJ" "@@@@ACCH@@@@@@C@@@CC" "@@@COL@@@@@@@@@L@@CM" "@@@COOL@@@@@@@AO@@CG" "@@@@GOL@@BA@@@@G@@CB" "@@ALGOH@@BAN@@@GH@CO" "@@AMOH@@@@AO@@GGH@CM" "@@AKOL@@@@AC@@OKH@CG" "@@@OOL@@@BAC@@OK@@CB" "@@@OOL@@@CCF@@GMH@AO" "@@@COH@@@G@N@@GOH@AM" "@@@CH@@@@GLL@@GON@AM" "@@@@@@@@@COL@@GNN@AO" "@@@@@@@@@COO@@GLN@@N" "@@@@@@@@@COO@@GOL@@O" "@@@@@@@@@OH@@@AOH@@M" "@@@@@@@@@OOFL@@O@@@M" "@@@@@@@@@AONL@@@@@@N" "@@@@@@@@@CKN@@@@@@@N" "@@@@@@@@@CKN@@@@@@@N" "@@@@@@@@@CKF@@@@@@@G" "@@@@@@@@@COF@@@@@@@F" "@@@@@@@@@@OOL@@@@@@G" "@@@@@@@@@@MOL@@@@@@C")} 64 . 29))) (40 (({(READBITMAP)(32 6 "@CON@AOO" "@GOOL@AO" "@GOOL@@@" "@CGH@@@@" "@@FLNAH@" "@@CLNAH@")} 96 . 26) ({(READBITMAP)(64 18 "JJJEEEEEEEEBJJJJ" "JKKNOOOOONNMKCCC" "MOMEMEEEEGMNMMOO" "GGGB@@@@@BB@OGGG" "JJKAEEEEEEEEFJJJ" "KKK@EEEEEDDDOCCC" "OOO@BJJJJJBBCMMO" "GGG@HJJJJJHHIGGG" "JJOAEEEEEEEEDJJJ" "KKO@DEEEEEDDMCCC" "OOO@BJJJHHJBCMMM" "OGO@HJJJJJHHIGGG" "NKNEEEEEEEEEFJJJ" "OKODLEEEEDDDOCCC" "OOOBBBJJHHBBEMMM" "GGOHHHJJJJHHGGGG" "OJOEEEEEEEEDJJJJ" "OKODLEEEEDDGCCCC")} 128 . 91) ({(READBITMAP)(32 33 "@D@L@GOO" "HD@@@CGO" "IL@@@COJ" "IN@@@CKK" "@@@@@AMO" "H@@@@AOG" "H@@C@@NJ" "DCHG@@OK" "DC@F@@GM" "@C@F@@GG" "@B@L@@GJ" "@@@@@@CC" "@@@L@@CM" "@@AC@@CG" "@@@C@@CB" "@@@CH@CO" "@@ACH@CM" "@@CAH@CG" "@@NA@@CB" "@@FAH@AO" "@@@AH@AM" "@@@CN@AM" "@@FFN@AO" "@@GLN@@N" "@@GOL@@O" "@@AOK@@M" "L@@OK@@M" "L@COO@@N" "@@COO@@N" "@@CON@@N" "@AOOH@@G" "@AOOH@@F" "L@AOH@@G")} 112 . 30) ({(READBITMAP)(48 24 "@@@@@F@@@@@C" "@@@@AO@@@@@A" "@@@AAL@@@F@@" "@@@@@@@H@F@C" "@@@@@A@L@@@C" "@@@@@CIL@@@C" "@@@@@@CH@@@@" "@@@CH@@@@@@@" "@@@CH@L@@@@@" "@@@@GIL@@BA@" "@@ALGOH@@B@H" "@@AMOH@@@@@G" "@@AKOL@@@@@C" "@@COOL@@@B@C" "@@COOL@@@B@@" "@@CCOH@@@@@@" "@@CCHL@@@@@@" "@@C@GL@@@@A@" "@@COGH@@@@GI" "@@COOH@@@BGO" "@@COO@@@@OH@" "@COOH@@@@OOF" "@COIH@@@@AON" "@@AIH@@@@CKN")} 64 . 34) ({(READBITMAP)(80 57 "@@@@@@@D@@@AO@LCJJL@" "@@@@@@@@@@@@C@LCME@@" "@@@@@@@@@@@@@@LGEE@@" "@@@@@@@@@L@@D@LGJJ@@" "@@@@@@@@AL@@FBDOJJ@@" "@@@@@@@HAL@@@@@MMD@@" "@@A@O@CHEL@@@D@MED@@" "@@A@ODOBAOH@D@@NJL@A" "@@AKOGO@@OH@@@@NJH@J" "@@COGN@@@OHBA@EMEDAE" "@@OOONL@@AHB@@AMEDEE" "@MOOOOL@@AHB@@ANJHJJ" "@MOKOK@@AH@CH@MNJLJK" "@OOOOH@@AI@@@@MMMGEM" "@OOOOH@@AH@@@@AOEEEG" "@COO@@@@@@@@D@IJJJJJ" "@@G@@@@@B@C@@@MNJJKK" "@@@@@@@@AIKH@@MOMEMM" "@@@@@@@@GKKIL@AMEEGG" "@@@@@@@@DAHAH@AJJJJE" "@@@@@@@L@@@C@@AKJKKN" "@@@@@ACLA@@C@DAOMOME" "@@@@@@C@@@@@@DAOGGGB" "@@@@@@D@D@F@@@AJJJKA" "@@@@@@HAN@F@@LAKKKK@" "@@@@L@HCH@@@@LAMOOO@" "@@@D@@CH@@L@@LAOGGG@" "@@@G@@CH@@NF@LAJJJOA" "@@@@AIIH@@FF@LAKKKO@" "@@A@AOIL@@N@@@AMOOO@" "@@A@ANAMN@L@@@AOOGO@" "@@N@A@@CNAL@@@AKNKNE" "@@NB@@@C@AH@@@AKOKOD" "@GOLN@@G@@@@@@AOOOOB" "AOKLB@@G@@@@@@AOGGOH" "AOON@@@@@@@@@@ANOJOE" "AOOO@@@@@@@@@@AIOKOD" "AOOO@@@@@@@@@@AOOOOM" "@NGO@@@@@@@@@@AOOOGG" "@@@@@@@@@@@@@@AJOJJJ" "@@@@@@@@@@@@@@@OCKKC" "@@@@@@@@@@AHM@@OOOMM" "@@@@@@@@@@@@A@@MGOGG" "@@@@@@@@@A@@@@@NKOJJ" "@@@@@@@@@@@@@@@GCOKC" "@@@@@@@@@@A@@@@GOOOM" "@@@@@@@@@@A@B@@CGGOG" "@@@@@@@@@@@@@@@ANKJJ" "@@@@@@C@@O@@@@@AOKKC" "@@@@@@@@@OB@@@@@OOOM" "@@@@@AH@@@L@@@@AOGOG" "@@@@@CH@@ALAHB@ENKNJ" "@@@AB@C@@AHAABBDOCOC" "@@@@@@@@@CD@A@BCGOOO" "@@@H@@@@@C@CL@@@FGOG" "@@@IN@@@@@@G@B@@GKOJ" "@@@IL@@@@@@G@@@@CCOK")} 64 . 71) ({(READBITMAP)(48 27 "@@@@@@@@@D@@" "@@@@@@@@@@@@" "@@@@@@@AH@@@" "@@@@@@@@K@@@" "@@@@@@@@L@@@" "@@@@@@@@@@@@" "@@@@@@@H@H@@" "@@@@@@@OGH@@" "@@@@@@@NF@@@" "@@@@@@GN@@@@" "@@@@@@O@@@@@" "@@@@@@O@@@@@" "@@@@@GMN@@@@" "@@@@@GOH@@@@" "@@@@@AK@@@@@" "@@@@GKL@@@@A" "@@@@GOL@@@@@" "@@@AOO@@@@@@" "@@@AMN@@@@@@" "@@@AN@@@@@@@" "@@@AO@@@@@@C" "@@@@O@@@@@@C" "@@@CO@@@@@@@" "@@@CL@@@@@AL" "@@@AL@@@@@AM" "@@@@L@@@@@AK" "@@@@L@@@@@CO")} 32 . 44))) (40 (({(READBITMAP)(16 4 "@@@C" "@@@G" "@@@G" "@@@G")} 48 . 104) ({(READBITMAP)(48 27 "@@@C@@C@H@CG" "@B@C@@N@@@CB" "@B@@@@F@@@AO" "@@@@@@@@@@AM" "@@@@@@@@@@AM" "@@A@@@F@@@AO" "@@BA@@F@B@@N" "@@@G@@FD@@@O" "@N@@@@@FD@@M" "@I@@@@@CL@@M" "@@D@D@CCL@@N" "@@@B@@COO@@N" "@AKB@@CON@@N" "@COF@AOOL@@G" "@COOHAOOL@@F" "@GOOL@AOL@@G" "@GOOL@AOL@@C" "@CGOH@COL@@C" "@COONAKOL@@C" "@AOONAKOH@@C" "OOOOOOOOOOOO" "OOOOOOOOOOOO" "@AOOH@@O@@@C" "@AOOH@@O@@@A" "@AON@@@L@@@A" "@@GH@@@C@@@A" "@@G@@@@C@@@A")} 96 . 19) ({(READBITMAP)(80 39 "@@@@@@@A@@@@@@@@@@B@" "@@@@@@@@C@@@@@@CB@G@" "@@@@@@@@@@@C@@@@@@@@" "@@@@@@@@@@@C@@@@@@@B" "@@@@@@@@@H@@@@@@@H@@" "@@@@@@@@GH@@@@@@B@@@" "@@@@@@@HF@@@@@DL@@@A" "@@@@@@CH@@L@@@@L@@@A" "@@@@@@@@@@L@@@@HH@@A" "@@@@@@@@@@@@L@@@H@@A" "@@@@@A@F@@@@L@@@@@@@" "@@@@@@HH@@@@@F@@@@@C" "@@@@@@@@@@@@AO@@@@@A" "@@@@@@@@@@@AAL@@@F@@" "@@@@@GL@@@@@@@@H@F@C" "@@@ACD@@@@@@@A@L@@@C" "@@@ACD@@@@@@@CIL@@@C" "@@@AN@@@@@@@@@CN@@@@" "@@@GN@@@@@@@@@@F@@@@" "@@@GO@@@@@@@@@@@F@@@" "@@@OO@@@@@@@@@L@FBA@" "@@@OL@@@@@A@@CH@@B@H" "@@@OL@@@@@@DDH@@@@@G" "@@AOL@@@@@@@D@@@@@@C" "@@AOL@@@@@A@G@@@@B@C" "@@AO@@@@@@ANG@@@@B@@" "@@AN@@@@@@C@G@@@@@@@" "@@MN@@@@@@CCKL@@@@@@" "@AMN@@@@@@CCOL@@@@A@" "@AIH@@@@@@COGH@@@@BA" "@@AH@@@@@@COOH@@@@@G" "@@@@@@@@@@COO@@@@N@@" "@@@@@@@@@COOOH@@@I@@" "@@@@@@@@@COKKH@@@@D@" "@@@@@@@@@@GOO@@@@@@B" "@@@@@@@@@@GOO@@@@AKB" "@@@@@@@@@@GOK@@@@COF" "@@@@@@@@@@CO@@@@@COO" "@@@@@@@@@@CO@@@@@GOO")} 32 . 30) ({(READBITMAP)(80 18 "H@AJJJJJEEEEEEEEBJJJ" "@@AKJKKCGOOOONNFECCC" "@@AOMOMMEEEEEGMMNMOO" "@DAOGGGOH@@@@BBB@OGG" "@@AJJJKNEEEEEEEEEFJJ" "@@AKKKKOEEEEEDDDLOCC" "@@AMOOOOBJJJJJBBBCMO" "@@AOGGGOHJJJJJHHHIGG" "@LAJJJONEEEEEEEEEDJJ" "@LAKKKOODEEEEEDDLMCC" "@@AMOOOOBJJJHHJBBCMM" "@@AOOGOOHJJJJJHHHIGG" "L@AKNKNJEEEEEEEEEFJJ" "L@AKOKOKLEEEEDDDLOCC" "L@AOOOOMBBJJHHBBBEMM" "L@AOGGOGHHJJJJHHHGGG" "@@ANOJOJEEEEEEEEDJJJ" "@@AIOKOKLEEEEDDDOCCC")} 112 . 91) ({(READBITMAP)(64 86 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@HAH@" "@@@@@@@@@@AHHAH@" "@@@@@@@@@@AOH@MH" "@@@@@@@@@@FOHAMH" "@@@@@@@@@@GO@ANH" "@@@@@@@@@@OO@AON" "@@@@@@@@@@OG@AON" "@@@@@@@@@@ON@AON" "@@@@@@@@@@ON@ALN" "@@@@@@@@@@AN@@ON" "@@@@@@@@@@AN@@GL" "@@@@@@@A@@@@@@@@" "@@@@@@@@@@@@@@DA" "@@@@@@@@@@@@@@@A" "@@@@@@@D@@@@D@@A" "@@@@@@@D@@@@F@@C" "@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@@@@G" "@@@@@@@@@L@AL@DG" "@@@@@@@@AL@AN@DO" "@@@@@@@HAL@AH@@M" "@@@@C@AHEL@AHF@M" "@@@@BDGBAOHALF@N" "@@@@NGO@@OH@@F@N" "@@@@GN@@@OHBAFEM" "@@DAONL@@AHB@FAM" "@MOOOOL@@AHB@@AN" "@MOKOK@@AH@CH@MN" "@OOOOH@@AI@@@@MM" "@OOOOH@@AH@@@@AO" "@OOO@@@@@@@@D@IJ" "@OOH@@@@B@C@@@MN" "AOONC@@@AIKH@@MO" "AOLNC@@@GKKIL@AM" "LOLO@@@@DAHAH@AJ" "OO@C@@@L@@@C@@AK" "GK@@@ACLA@@C@@AO" "OH@@@@C@@@@@@DAO" "IH@@@@D@D@@@@@AJ" "AH@@@@HAN@@@@@AK" "@@@@L@HCH@@@@@AM" "@@@D@@CH@@D@@@AO" "@@@G@@CH@@FF@LAJ" "@@@@AIIH@@FF@LAK" "@@A@AOIL@@F@@@AM" "@@A@ANAMN@D@@@AO" "@@B@A@@CN@N@L@AK" "@@BB@@@C@AN@L@AK" "@ACLN@@G@@N@L@AO" "@A@DB@@G@@N@L@AO" "A@@D@@@@@@@@@@AN" "AL@@@@@@@@@@@@AI" "ANDC@@L@@@@@@@AO" "@OLA@@N@AH@@@@AO" "GON@@@GHGH@@@@AJ" "GOO@@@AHGH@@@@@O" "GON@@@@@@@@HM@@O" "GOL@@@@@@@@@A@@M" "@@@@@@@@@A@@@@@N" "@@@@@@@@@@@@@@@G" "@@@@@@@@@@@@@@@G" "@@@@@@@@@@@@B@@C" "@@@@@@@@@@@@@@@A" "@@@@@@C@@@@@@@@A" "@@@@@@@@@H@@@@@@" "@@@@@AH@@@L@@@@A" "@@@@@CH@@@DAHB@E" "@@@AB@C@@@@@@@BD" "@@@@@@@@@B@@@@BC" "@@@H@@@@@A@C@@@@" "@@@IN@@@@@@A@@@@" "@@@IL@@@@@@@@@@@" "@D@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@D" "@@@@@@@@@@B@@@@F" "C@@@@@@CB@G@@@@B" "@@@C@@@@@@@@@@@B" "@@@C@@@@@@@B@G@@" "@H@@@@@@@H@@@@@@" "GH@@@@@@B@@@@@@@" "F@@@@@DL@@@A@D@C" "@@L@@@@L@@@AHD@C")} 64 . 61))) (40 (({(READBITMAP)(48 18 "JEEEEEEEEBJJ" "JGOOONNFNMCC" "MMEEEGMMMNOO" "EH@@@BBBB@OG" "JEEEEEEEEEFJ" "JEEEEDDDLLOC" "MJJJJJBBBBCO" "GJJJJJHHHHIG" "JEEEEEEEEEDJ" "KEEEEEDDLLMC" "MJJJHHJBBBCM" "GJJJJJHHHHIG" "JEEEEEEEEEFJ" "CEEEEDDDLLOC" "MBJJHHBBBBEM" "GHJJJJHHHHGG" "JEEEEEEEEDJJ" "CEEEEDDDLOCC")} 144 . 91) ({(READBITMAP)(32 33 "@@@@@@@@" "@@@@@@B@" "@@@@@@@@" "@@@@@@@@" "@@@@@A@F" "@@@@@@HH" "@@@@@@@@" "@@@@@@@@" "@@@@@CL@" "@@@A@D@@" "@@@ACD@@" "@@@AN@@@" "@@@DB@@@" "@@@DC@@@" "@@@LA@@@" "@@@LH@@@" "@@@OL@@@" "@@AOL@@@" "@@AO@@@@" "@@MO@@@@" "@@MN@@@@" "@@MN@@@@" "@AON@@@@" "@AOL@@@@" "@@OH@@@@" "@@O@@@@@" "@@O@@@@@" "@@N@@@@@" "@@N@@@@@" "@AL@@@@@" "@AL@@@@@" "@N@@@@@@" "@N@@@@@@")} 32 . 30) ({(READBITMAP)(96 129 "@@@@@@@@@@@@@@@@@@@@@@CO" "@@@@@@@@@@@@@@@@@@@@@@OJ" "@@@@@@@@@@@@@@@@@@@@@ANN" "@@@@@@@@@@@@@@@@@@@@@CMK" "@@@@@@@@@@@@@@@H@@@@@OOG" "@@@@@@@@@@@@@@CI@@@BAOGO" "@@@@@@@@@@@@@@CA@A@BCNKJ" "@@@@@@@@@@@@@@OH@@CNCOKJ" "@@@@@@@@@@@@@@ON@@DNGOOE" "@@@@@@@@@@@@@@MN@@ONGGEE" "@@@@@@@@@@@@@@ON@@OLNJJJ" "@@@@@@@@@@@A@@OF@@ONOJJJ" "@@@@@@@@@@@@@@ON@AOOMMEE" "@@@@@@@@@@@@@@ON@AOOOEEH" "@@@@@@@@@@@D@@OND@CONJJ@" "@@@@@@@@@@@D@@GNF@AOJJL@" "@@@@@@@@@@@@@@AL@@AOME@@" "@@@@@@@@@@@@@@@L@@@GEE@@" "@@@@@@@@@@@@@@@AL@DGJJ@@" "@@@@@@@@@@@@@@@@B@DOJJ@@" "@@@@@@@@@@@HAH@@@@@MMD@@" "@@@@@@@@@@AH@@@AHB@MED@@" "@@@@@@@@@@CB@@@@LB@NJL@A" "@@@@@@@@FAA@@N@@@B@NJH@J" "@@@@@@@@@B@@@B@BABEMEDAE" "@@@@@@D@AB@@@AHB@BAMEDEE" "@@@@@ABLB@@@@F@B@@ANJHJJ" "@@@@@L@LD@@@AN@CH@MNJLJK" "@@@@@@OLLH@@AN@@@@MMMGEM" "@@@@@AOLIH@@AO@@@@AOEEEG" "@@@@AOGK@@@@@OH@D@IJJJJJ" "@@@@COOH@@@@BOH@@@MNJJKK" "@@@@COOHC@@@AIH@@@MOMEMM" "@@@AKOLLC@@@GCJAL@AMEEGG" "@@@AOOLL@@@@DAHAH@AJJJJJ" "@@@COO@@@@@L@@@C@@AKJKKC" "@@@GGK@@@AC@A@@C@@AOMOMM" "@@@GOH@@@@C@@@@@@DAOGGGO" "@@@GOH@@@@D@D@@@@@AJJJKN" "@@@COH@@@@HAN@@@@@AKKKKO" "@@@COH@@L@HCH@@@@@AMOOOO" "@@@ON@@D@@CH@@@@@@AOGGGO" "@@AON@@G@@CH@@@F@HAJJJON" "@@AON@@@AIIH@@@B@@AKKKOO" "@@@CH@A@AOIL@@D@@@AMOOOO" "@@@@@@A@ANAMN@@@@@AOOGOO" "@@@@@@B@A@@CN@BAH@AKNKNJ" "@@@@@@BB@@@C@ABAH@AKOKOK" "@@@@@ACLN@@G@@BAH@AOOOOM" "@@@@@A@DB@@G@@N@@@AOGGOG" "@@@@@@@D@@@@@@L@@@ANOJOJ" "@@@@@@@@@@@@@@L@@CAIOKOK" "@@@@AB@C@@@@@@L@@CAOOOOM" "@@@@@N@A@@@@@@L@@@AOOOGG" "@@@@@@F@@@@@@@L@@@AJOJJJ" "@@@@DAO@@@AHB@L@@@@OCKKC" "@@@@GON@@@@@@@LH@@@OOOMM" "@@@AOON@@@@@@@@@@@@MGOGG" "@@@AOON@@@@@@@@@@@@NKOJJ" "@@@AOOL@@@@@@@@@@@@GCOKC" "@@@@OLN@@N@@CL@@@@@GOOOM" "@@@@OLN@@NOHCL@@@@@CGGOG" "@@@@@@@@@@OH@@@@@@@ANKJJ" "@@@@@@@@@@B@@@@@@@@AOKKC" "@@@@@@@@@@@@@H@@@@@@OOOM" "@@@@@@@@@@@@@@@@@@@AOGOG" "@@@@@@@@@@@@@@@@@@@ANKNJ" "@@@@@@@@B@B@@@@@@@@@OCOC" "@@@@@@@@@@@@@@@@@@@AGOOO" "@@@@@@@@@@@@@@@@@@@@FGOG" "@@@@@@@@@@@@@@@@@@@@GKOJ" "@@@@@@@@H@@@@@@@@@@@CCOK" "@@@@@D@@@@@@@@@@@@@@COOM" "@@@@@@@@@@@@@@@@@@@@CGOG" "@@@A@@@@@@@@@@@@@@@@CJJJ" "@@@@C@@@@@@C@@@@@@@FAOKK" "@@@@@@C@C@@@@@@@@@@FAMOM" "@@@@@@CCC@@@@@@B@G@@@OGG" "@@@@@@@@@@@@@H@@@@@@@NJJ" "@@@@B@@@@@@@B@@@@@@@@GKK" "@@@@B@@@@@DL@@@A@D@C@GOO" "@@B@@@L@@@@L@@@AHD@C@CGO" "@@@@@@L@@@@HH@@AIL@@@COJ" "@@@@@@@@L@@@H@@AIN@@@CKK" "@A@F@@@@L@@@@@@@@@@@@AMO" "@@HH@@@@@F@@@@@CH@@@@AOG" "@@@@@@@@AO@@@@@AH@@C@@NJ" "@@@@@@@AAL@@@F@@DCHG@@OK" "@CL@@@@@@@@H@F@CDC@F@@GM" "@D@@@@@@@A@L@@@C@C@F@@GG" "CD@@@@@@@CIL@@@C@B@L@@GJ" "N@@@@@@@@@CN@@@@@@@@@@CC" "B@@@@@@@@@@F@@@@@@@L@@CM" "C@@@@@@@@@@@F@@@@@AC@@CG" "A@@@@@@@@@L@FBA@@@@C@@CB" "H@@@@@@@@CH@@B@H@@@CH@CO" "L@@@@@@D@H@@@@@G@@ACH@CM" "L@@@@@@@@@@@@@@C@@C@H@CG" "@@@@@@A@C@@@@B@C@@N@@@CB" "@@@@@@AN@@@@@B@@@@F@@@AO" "@@@@@@@@@@@@@@@@@@@CH@AM" "@@@@@@@@@@F@@@@@@@@CH@AM" "@@@@@@@@H@F@@@A@@@F@@@AO" "@@@@@@@@@@@@@@BA@@F@@@@N" "@@@@@@@@@@@@@@@G@@F@@@@O" "@@@@@@CIH@@@@N@@@@@AH@@M" "@@@@@@GOH@@@@H@@@@@AH@@M" "@@@@@COKKH@@@@@@D@C@L@@N" "@@@@@@GOO@@@@@@@@@B@@@@N" "@@@@@@GOO@@@@@@@@@B@@@@N" "@@@@@@GOK@@@@@@@@ALC@@@G" "@@@@@@COL@@@@B@L@ALO@@@F" "@@@@@@CON@@@@DD@@@@OL@@G" "@@@@@@OKO@@@@DLB@@AOL@@C" "@@@@@@OOO@@@@CGCH@COL@@C" "@@@@@COOL@@@@COCNAKOL@@C" "@@@@@COOL@@@@AOONAKOH@@C" "OOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOLOOOOOOOOO" "@@@@@@@@@@@@@AOOH@@O@@@C" "@@@@@@@@@@@@@AOOH@@O@@@A" "@@@@@@@@@@@@@AOO@@AO@@@A" "@@@@@@@@@@@@@GOK@@AOH@@A" "@@@@@@@@@@@@@GOO@@AOH@@A" "@@@@@@@@@@@@@GOO@@AOH@@A" "@@@@@@@@@@@@@GOO@@AOH@@@" "@@@@@@@@@@@@@GOO@@AO@@@@" "@@@@@@@@@@@@@COH@@AN@@@@" "@@@@@@@@@@@@@AO@@@@@@@@@")} 48 . 14))) (40 (({(READBITMAP)(16 4 "KNKJ" "KOKJ" "OOOE" "OGEE")} 128 . 133) ({(READBITMAP)(16 28 "@@@@" "@@@@" "@@@@" "@@@D" "@@@@" "@@@H" "@@@H" "@@@H" "@@AH" "@@A@" "@@ML" "@@OH" "@@OH" "@@OH" "@@OH" "@@OH" "@@O@" "@GO@" "@ON@" "AON@" "@OL@" "COL@" "COL@" "COH@" "CO@@" "CN@@" "CN@@" "AL@@")} 32 . 26) ({(READBITMAP)(48 18 "IIEEEEEEDLJJ" "IAOOONNFLBKC" "OOEEEGMMMBCO" "FN@@@BBBBKAG" "IIEEEEEEEEIJ" "IIEEEDDDLL@C" "NFJJJJBBBBDG" "DFJJJJHHHHNO" "IIEEEEEEEECB" "HIEEEEDDLLJK" "NFJJHHJBBBDE" "DFJJJJHHHHNO" "IIEEEEEEEEIJ" "@IEEEDDDLL@C" "NNJJHHBBBCKM" "DDJJJJHHHKKG" "IIEEEEEEECBJ" "@IEEEDDDL@CC")} 144 . 91) ({(READBITMAP)(80 94 "@@@@@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@@A@@@B" "@@@@@@@@@@@@@@B@@@@C" "@@@@@@@@@@@@@@B@@@CO" "@@@@@@@@@@@@@@A@@D@O" "@@@@@@@@@@@@@@@@@DIO" "@@@@@@@@@@@@@@N@@NOO" "@@@@@@@@@@@A@@N@@NON" "@@@@@@@@@@@@@@NH@OOO" "@@@@@@@@@@@@@@OHAKOO" "@@@@@@@@@@@D@AOHAHGO" "@@@@@@@@@@@D@AOHF@GO" "@@@@@@@@@@@@@AOL@@GO" "@@@@@@@@@@@@@COL@@GO" "@@@@@@@@@@@@@COH@@GO" "@@@@@@@@@@@@@AOHB@GO" "@@@@@@@@@@@HAHOH@@GM" "@@@@@@@@@@AH@@OH@@GM" "@@@@@@@@@@CB@@GH@@@N" "@@@@@@@@DAA@@N@@@@@N" "@@@@@@@@@B@@@B@B@@AM" "@@@@@@@@AB@@@AHB@@AM" "@@@@@A@L@@@@@F@B@@AN" "@@@@@@@L@@@@AN@CH@AN" "@@@@@@L@LH@@AN@@@@AM" "@@@@@@@@IH@@AO@@@@AO" "@@@@AO@H@@@@@OH@@@AJ" "@@@@CA@H@@@@BOH@@@AN" "@@@@CAAHC@@@AIH@@@AO" "@@@AJC@LC@@@GCJA@@AM" "@@@ANG@L@@@@DAHA@@AJ" "@@@COO@@@@@L@@@C@@AK" "@@@GGK@@@AC@A@@C@@AO" "@@@GOH@@@@C@@@@@@DAO" "@@@GOH@@@@D@D@@@@@AJ" "@@@COH@@@@HAN@@@@@AK" "@@@OOH@@L@HCH@@@@@AM" "@@@ON@@D@@CH@@@@@@AO" "@@AON@@G@@CH@@@F@HAJ" "@@AON@@@AIIH@@@B@@AK" "@@@OL@A@AOIL@@@@@@AM" "@@AOL@A@ANAMN@@@@@AO" "@@AOH@B@A@@CN@@AH@AK" "@@CO@@BB@@@C@A@AH@AK" "@@GO@ACLN@@G@@@AH@AO" "@@ON@A@DB@@G@@H@@@AO" "@@OF@@@D@@@@@@H@@@AN" "@@O@@@@@@@@@@@H@@@AI" "@@@@AB@C@@@@@@@@@@AO" "@@@@@N@A@@@@@@@@@@AO" "@@@@@@B@@@@@@@@@@@AJ" "@@@@@@@@@@AHB@@@@@@O" "@@@@@@@@@@@@@@HH@@@O" "@@@AOON@@@@@@@@@@@@M" "@@@AOON@@@@@@@@@@@@N" "@@@AOOL@@@@@@@@@@@@G" "@@@@OLN@@N@@B@AH@@@G" "@@@@OON@@@@@@@AH@@@C" "@@@@OOH@@@@@@@@@@@@A" "@@@OOO@@@@@@@@@@@@@A" "@@@OON@@@@@@@H@@@@@@" "@@@GON@@@@@@@@@@@@@A" "@@@GOH@@@@@@@@@@@@@A" "@@@@@@@@BAO@@OL@@@@@" "@@@@@@@@@AO@COL@@@@A" "@@@@@@@@@AN@CL@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@D@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@C@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@A@@@@@@@@@@@@@" "@@@@@@@@@@@@@H@@@@@@" "@@@@B@@@@@@@B@@@@@@@" "@@@@@@@@@@DL@@@@@@@@" "@@B@@@H@@@@L@@@@@@@@" "@@@@@@@@@@@H@@@@@@@@" "@@@@@@@@L@@@H@@@@@@@" "@@@D@@@@L@@@@@@@@@@@" "@@@H@@@@@F@@@@@@@@@@" "@@@@@@@@@L@@@@@@@@@@" "@@@@@@@@@L@@@F@@@@@G" "@A@@@@@@@@@@@F@A@A@F" "@D@@F@@@@A@L@@@A@@@F" "CD@@F@@@@AA@@@@A@@@D" "F@@@F@@@@@CB@@@@@@L@" "@@@@F@@@@@@@@@@@@ALL" "@@@@@@@@@@@@F@@@@AHC" "@@@@@@@@@@L@F@A@@@@C" "@@@@@@@@@CH@@B@H@@@C" "@@@@@@@D@H@@@@@G@@AC" "D@@@@C@@@@@@@@@C@@C@")} 48 . 45) ({(READBITMAP)(80 36 "@C@@@@@@@@@C@@C@H@CG" "@CA@C@@@@B@C@@N@@@CB" "@@AH@@@@@B@@@@F@@@AO" "@@@@@@@@@@@@@@@CH@AM" "@@@@@@F@@@@@@@@CH@AM" "@@@@H@F@@@A@@@F@@@AO" "@@@@@@@@@@BA@@F@@@@N" "@@@@@@@@@@@G@@B@@@@O" "@@@I@@@@@N@@@@@AH@@M" "@@@I@@@@@H@@@@@AH@@M" "@B@AL@@@@@@@D@@@L@@N" "@@@@L@@@@@@@@@B@@@@N" "@@@DN@@@@@@@@@B@@@@N" "@@FGN@@@@@@@@ALAC@@G" "@@BCH@@@@B@L@AL@C@@F" "@@BOH@@@@@@@@@@@C@@G" "@@OOO@@@@@@@@@@@@@@C" "@@OOO@@@@@@@@@@@@@@C" "@COOL@@@@@@CNAH@@@@C" "@COOL@@@@AOONAKOH@@C" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOLOOOOOOOOO" "AOOO@@@@@AOOH@@O@@@C" "AOOO@@@@@AOOH@@O@@@A" "AOOO@@@@@AOO@@AO@@@A" "AOOO@@@@@GOK@@AOH@@A" "@NOGL@@@@GOO@@AOH@@A" "@NOOH@@@@GOO@@AON@@A" "@@OH@@@@AOOO@@AON@@@" "@@@@@@@@COOO@@AON@@@" "@@@@@@@@GOOO@@AOH@@@" "@@@@@@@@OOOOH@@OH@@@" "@@@@@@@@AONGH@@OH@@@" "@@@@@@@@@@@@@@@OH@@@" "@@@@@@@@@@@@@@@N@@@@" "@@@@@@@@@@@@@@@F@@@@")} 64 . 10))) (40 (({(READBITMAP)(16 4 "OO@@" "ON@@" "ON@@" "OL@@")} 32 . 26) ({(READBITMAP)(16 2 "@@@@" "@@@@")} 96 . 26) ({(READBITMAP)(48 8 "AOOOH@@OH@@@" "@OON@@@ON@@@" "@MON@@@OO@@@" "@@OH@@AOO@@@" "@@@@@@AMO@@@" "@@@@@@COOH@@" "@@@@@@COOH@@" "@@@@@@@@D@@@")} 96 . 6) ({(READBITMAP)(32 12 "@AH@@@@C" "@AKOH@@C" "OOOOOOOO" "OOOOOOOO" "H@@H@@@C" "H@C@@@@A" "@@C@@@@A" "@@OO@@@A" "@@OO@@@A" "@@CN@@@A" "@@AO@@@@" "@@AOL@@@")} 112 . 16) ({(READBITMAP)(64 24 "EFJJNNLONIGGGGGG" "IJCNCIC@@DLJJJJJ" "ICLJJKJKIG@KCCKK" "OLBALBOHHGMCOMMM" "FMLJJHHHHAKIGGGG" "IJIEEEEEEEIEJJJJ" "IJIEEDDDLL@DCKKK" "NEFJJJBBBB@@GMMM" "FEFJJJHHHHNHOGGG" "OJIEEEEEEECEBJJJ" "HJIEEEDDLLJLKKKK" "NEFJHHJBB@DBGMMM" "FEFJJJHHHHN@OGGG" "OJIEEEEEEEIEJJJJ" "@JIEEDDDLLALCKKK" "NMFJHHBBBCHCMMMM" "DGFJJJHHHJDKGGGG" "OJIEEEEEABEBJJJJ" "FIFJJKKKANDCCKKK" "MMEEGGOMOMMMMMMM" "GEEEEEGOGGGGGGGG" "JJJJJJKKJJJJJJJJ" "CJJJJJKKKCGCCKKK" "MMOGGGGMMMOMMMMM")} 144 . 86) ({(READBITMAP)(48 12 "@@@@@@@@F@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@H@@@@@@@@" "@@@H@@@@@@@D" "@@AH@@@@@C@@" "@@@@@@@@@CA@" "@@@@@@@AH@AH" "@@@@@@@AH@@@" "@@@@@@@AH@@@" "@@L@@@@@@@@@" "@@L@@@@@@@@@")} 32 . 39) ({(READBITMAP)(32 62 "@@@@AH@H" "@@@@B@@H" "@@@@@@AH" "@@@AHA@L" "@@@A@@@D" "@@@@A@@@" "@@@@@@@@" "@@@@@@@@" "@@@AH@@@" "@@@AH@@@" "@@@IL@@@" "@@@OL@@D" "@@@OL@@G" "@@@OL@@@" "@@@OL@A@" "@@AOL@@@" "@@AOH@B@" "@@CO@@BB" "@@GO@ACL" "@@ON@A@D" "@AON@@@D" "@AOH@@@@" "@CO@AB@C" "@GN@@N@A" "AOH@@@B@" "GOH@@@@@" "GOH@@@@@" "AO@@@BB@" "@G@@C@B@" "@F@@H@@@" "@@@@@@B@" "@@@@@CB@" "@@@@OO@@" "@@@OOO@@" "@@@OON@@" "@@@GOOH@" "@@@GOOH@" "@@@CMOH@" "@@@AOL@@" "@@@GOL@@" "@@@OOL@@" "@@@OOH@@" "@@@OOD@@" "@@@GN@@@" "@@@CL@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@A@" "@@@@@@@@" "@@@@B@@@" "@@@@@@@@" "@@B@@@H@" "@@@@@@@@" "@@@@@@@@" "@@@D@@@@" "@@@H@@@@" "@@@@@@@@" "@@@@@@@@" "@A@@@@@@" "@D@@@@@@" "CD@@@@@@" "F@@@@@@@")} 48 . 51) ({(READBITMAP)(48 76 "@@@@@@@@@NOO" "@@@A@@@@@NON" "@@@@@@B@@OOO" "@@@@@@B@AKOO" "@@@D@@B@AHGO" "@@@D@@AHF@GO" "@@@@@@CH@@GO" "@@@@@BGH@@GO" "@@@@@CO@@@GO" "@@@@@AO@B@GO" "@@@HAHOH@@GM" "@@AH@AOH@@GM" "@@CB@AOH@@@N" "DAA@@OOH@@@N" "@B@@@COJ@@AM" "AB@@@AOJ@@AM" "@@@@@GOJ@@AN" "@@@@@GOKH@AN" "DH@@@AOH@@AM" "IH@@@AOH@@AO" "@@@@@@OH@@AJ" "@@@@@DGH@@AN" "C@@@AH@@@@AO" "C@@@G@@A@@AM" "@@@@D@@A@@AJ" "@@@L@@@A@@AK" "@AC@A@@@@@AO" "@@C@@@@@@@AO" "@@D@@@@@@@AJ" "@@HAB@@@@@AK" "L@H@H@@@@@AM" "@@@@@@@@@@AO" "@@@@@@@@@@AJ" "@@@@@@@@@@AK" "AN@D@@@@@@AM" "@@@EB@@@@@AO" "@@@@B@@@@@AK" "@@@@@A@@@@AK" "L@@@@@@@@@AO" "B@@D@@H@@@AO" "@@@@@@H@@@AN" "@@@@@@H@@@AI" "AH@@@@@@@@AO" "CHAO@@@@@@AO" "CHCO@@@@@@AJ" "C@GHB@@@@@@O" "C@F@@@HH@@@O" "@@F@@@@@@@@M" "@@@@@@@@@@@N" "@@@@@@@@@@@G" "@N@@B@AH@@@G" "@@@@@@AH@@@C" "@@@@@@@@@@@A" "@@@@@@@@@@@A" "@@@@@H@@@@@@" "@@@@@@@@@@@A" "@@@@@@@@@@@A" "B@D@@@@@@@@@" "@@@@@@@@@@@A" "@@@@@D@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@AH@@@@@@@@@" "@AN@@@@@@@@@" "@ANC@@@@@@@@" "@@@@@@L@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@B@@@@@@@" "@@DL@@@@@@@@" "@@@L@@@@@@@@" "@@@H@@@@@@@@" "L@@@H@@@@@@@" "L@@@@GN@@@@@" "@F@@@GN@@@@@")} 80 . 57) ({(READBITMAP)(32 5 "AOOOH@@@" "AOOOH@@@" "@OOGL@@@" "@OOOH@@@" "@@OK@@@@")} 64 . 17))) (40 (({(READBITMAP)(64 18 "IJ@ALFLOOKBJJJJJ" "ICOOONONLBGCCCKK" "OL@ALBOHHGMOOMMM" "FMOOOMMMMDNGGGGG" "IJJJJJJJJJFJJJJJ" "IJJJJKKKCCOKCKKK" "NEEEEEMMMMOOOMMM" "FEEEEEGGGGAGGGGG" "OJJJJJJJJJLJJJJJ" "HJJJJJKKCCECCKKK" "NEEEGGEMMOKMOMMM" "FEEEEEGGGGAOGGGG" "OJJJJJJJJJFJJJJJ" "@JJJJKKKCCNCCKKK" "NMEEGGMMMLGMMMMM" "DGEEEEGGGEKGGGGG" "OJJJJJJJNMJJJJJJ" "FIEEEDDDNAKCCKKK")} 144 . 91) ({(READBITMAP)(112 114 "@@@@@@@@@@@@@@@D@@@@F@GOJJL@" "@@@@@@@@@@@@@@@@@@@@@@GOME@@" "@@@@@@@@@@@@@@@@@B@H@@GOEE@@" "@@@@@@@@@@@@@@@@@C@@@@GOJJ@@" "@@@@@@@@@@@@@@@@@@C@@@GOJJ@@" "@@@@@@@@@@@@@@@@AHC@@@GMMD@@" "@@@@@@@@@@@@@@@@@AC@@@GMED@@" "@@@@@@@@@@@@@@@B@AC@@@@NJL@A" "@@@@@@@@@@@@DA@@@CCH@@@NJH@J" "@@@@@@@@@@@@@B@@@COH@@AMEDAE" "@@@@@@@@@@@@@B@@@AOH@@AMEDEE" "@@@@@@@@@A@H@@@@@GOH@@ANJHJJ" "@@@@@@@@@@@@@@@@@GOJ@@ANJLJK" "@@@@@@@@@@@@@@@@@AOH@@AMMGEM" "@@@@@@@@@@@@@@@@@AOH@@AOEEEG" "@@@@@@@@A@@@@@@@@AOH@@AJJJJJ" "@@@@@@@@@@@@@@@@@DOH@@ANJJKK" "@@@@@@@@@@@@B@@@AHOH@@AOMEMM" "@@@@@@@@@@@@B@@@GCOH@@AMEEGG" "@@@@@@@A@@@@@@@@DCOH@@AJJJJJ" "@@@@@@@@A@@@@@@L@COH@@AKJKKC" "@@@@@@@@@@@@@A@@@@OH@@AOMOMM" "@@@@@@@@@@@@@@A@@@CH@@AOGGGO" "@@@@@@@@@@@@@@@@@@C@@@AJJJKN" "@@@@@@@AH@@@@@HAB@@@@@AKKKKO" "@@@@@@@@@@@@H@H@H@@@@@AMOOOO" "@@@@@@@@@@@D@@@@@@@@@@AOGGGO" "@@@@@@@@H@@D@@@@@@@@@@AJJJON" "@@@@@@@@H@@@@@@@@@@@@@AKKKOO" "@@@@@@@@L@@@A@@D@@@@@@AMOOOO" "@@@@@@@@L@@@@@@DB@@@@@AOOGOO" "@@@@@@AHH@@@@@@@B@@@@@AKNKNJ" "@@@@@@CH@@@@@@@@@A@@@@AKOKOK" "@@@@@@GH@AALL@@@@@@@@@AOOOOM" "@@@@@@OL@@@D@@@D@@H@@@AOGGOG" "@@@@@AOH@@@D@@@@@@H@@@ANOJOJ" "@@@@@ALH@@@@@@@@@@H@@@AIOKOK" "@@@@@CL@A@@C@@@@@@@@@@AOOOOM" "@@@@@GN@@N@A@@@@@@@@@@AOOOGG" "@@@@AOH@@@@@@@B@@@@@@@AJOJJJ" "@@@@GOH@@@@@C@@@B@@@@@@OCKKC" "@@@@GOH@@@@@C@D@@@@H@@@OOOMM" "@@@@AO@@@@B@@@D@@@@@@@@MGOGG" "@@@@CO@@B@B@@@@@@@@@@@@NKOJJ" "@@@@CN@@@@@@@@@@@@@@@@@GCOKC" "@@@@GL@@@@B@@B@@B@@H@@@GOOOM" "@@@COH@@@A@@@@@@@@@H@@@CGGOG" "@@@COH@@@A@@L@@C@@@@@@@ANKJJ" "@@@@G@@H@A@@L@AO@@@@@@@AOKKC" "@@@@F@@H@H@@O@CN@@@@@@@@OOOM" "@@@@@@@@N@H@O@C@@@@@@@@AOGOG" "@@@@@@@AN@H@C@@@@@@@@@@ANKNJ" "@@@@@@@CL@@@CHD@@@@@@@@@OCOC" "@@@@@@@AO@@@AH@@@@@@@@@AGOOO" "@@@@@@@GOH@@AH@@@@@@@@@@FGOG" "@@@@@@@OOH@@@@@@@@@@@@@@GKOJ" "@@@@@@@OOH@@@@@@@@@@@@@@CCOK" "@@@@@@@OOL@@@@@@@@@@@@@@COOM" "@@@@@@AOOH@@@@@@@@@@@@@@CGOG" "@@@@@@AOOH@@@@@@@@@@@@@@CJJJ" "@@@@@@AOOH@@@@@@@@@@@@@@AOKK" "@@@@@@AOO@@@@@@@@@@@@@@@AMOM" "@@@@@@@OO@A@@@@@@@@@@@@@@OGG" "@@@@@@@CN@@@@@@@@@@@@@@@@NJJ" "@@@@@@@@B@@@@@@@@@@@@@@@@GKK" "@@@@@@@@@@@@@@@@@@@@@@@@@GOO" "@@@@@@B@@@H@@@@@@@@@@@@@@CGO" "@@@@@@@@@@@@@@@H@@@@@@@@@COJ" "@@@@@@@@@@@@@@@@@@@@@@@@@CKK" "@@@@@@@@@@@@@@@@@@@@@@@@@AMO" "@@@@@@@H@@@@@B@@@@@@@@@@@AOG" "@@@@@@@@@@@@@L@@@@@@@@@@@@NJ" "@@@@@@@@@@@@@@@@@@@@@@@A@@OK" "@@@@@@@@@@@@@@@@@D@A@@@B@@GM" "@@@@@D@@@@@@@A@L@@@@@@@@@@GG" "@@@@AD@@@@@@@AA@@GN@@@@@@@GJ" "@@@@@@@@@@@@@@CB@GN@@@D@@@CC" "@@@@@@@@F@@@@@@@@@@@@@H@@@CM" "@@@@@@@@@@@@@@@@F@@@@@@@@@CG" "@@@@@@@@@@@@@@L@F@A@@@@@@@CB" "@@@@@@@@@@@@@CH@@G@H@@@B@@CO" "@@@@@@@@@@@D@H@@@GHG@@@@@@CM" "@@AH@@@@@C@@@@@@@AHC@@@@@@CG" "@@@@@@@@@CA@C@@@@B@C@@N@@@CB" "@@@@@L@AH@AH@@@@@B@@@@F@@@AO" "@@@@@L@AH@@@@@@@@@@@@@@B@@AM" "@@@@@@@AH@@@@@F@@@@@@@@B@@AM" "@@@@@@@@@@@@H@F@@@A@@@F@@@AO" "@@HAH@@@@@@@@@@@@@BA@@F@@@@N" "@@@AHF@@C@@@@@@@@@@G@@B@@@@O" "@@@@@F@@C@@A@@@@@N@@@@@@@@@M" "@D@@@@@@@@@H@@C@@H@@@@@@@@@M" "@D@@@@@GHB@@@@C@L@@@D@@@L@@N" "@CL@@@@GH@@@D@CAL@@@@@B@@@@N" "@CL@@@@AH@@D@@@AH@@@@@B@@@@N" "AOL@@@@AH@@G@@@C@@@@@ALAC@@G" "AOL@@@@@@@BCH@@C@B@L@ML@C@@F" "COH@@@@@@@BOH@@@@@@@@L@@C@@G" "OO@@@@@@@@OOO@@@@@@@AH@@L@@C" "ON@@@@@@@@OOO@@@@@@@AH@@L@@C" "ON@@@@@@@COOL@@@@@@@@@@@@@@C" "OL@@@@@@@COOL@@@@@@@@@@@@@@C" "OOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@AOOO@@@@@@@@@@@@@@@C" "@@@@@@@@AOOO@@@@@@@@@@@@@@@A" "@@@@@@@@AOOOH@@@@@@C@@@@@@@A" "@@@@@@@@AOOOH@@@@COK@@@@@@@A" "@@@@@@@@@OOGL@@@@GOO@@OI@@@A" "@@@@@@@@@OOOH@@@@GOO@@ON@@@A" "@@@@@@@@@@OK@@@@AOOO@@OO@@@@" "@@@@@@@@@@@@@@@@COOO@@OO@@@@" "@@@@@@@@@@@@@@@@GOOO@@MOH@@@" "@@@@@@@@@@@@@@@@OOOOH@LOH@@@")} 32 . 14))) (40 (({(READBITMAP)(16 2 "CAHG" "LAHC")} 128 . 29) ({(READBITMAP)(16 10 "@@@A" "@@@C" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@AO" "@@AO" "@@AH")} 32 . 73) ({(READBITMAP)(48 18 "NDMEEEEEEJJK" "MHMIIIAA@GCK" "IGMOOMMMMKOO" "LNDMMMMMMHGO" "KEIEEEEEEEGJ" "BL@DLDDDDLGK" "LB@@@BBBBBCM" "FHNHHHHHHHKG" "KECEEEEEEEFK" "BLJLLDDDDDGK" "L@DB@BBBBBAM" "FHN@HHHHHHKG" "KEIEEEEEEEGJ" "BLALLDDDDDGK" "LCHBBBBBBBOM" "FJDHHHHHHIGG" "OBEEEEEEEGJJ" "ONDLLDDDDKOC")} 176 . 91) ({(READBITMAP)(32 15 "@@@@@D@A" "@@@@@@@A" "@@@@@@@A" "@@@@@@@@" "@@H@@@@@" "@@@@@B@@" "@@@@@B@@" "@@@@@@@@" "@@@@@@@G" "@@@@@@@G" "@@@@@@@A" "@@@@@@@A" "@@@@L@@@" "@F@@LF@@" "AN@@@F@@")} 32 . 29) ({(READBITMAP)(80 111 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@A" "@@@@@@@@@@@@@@@@@@@A" "@@@@@@@@@@@@@@@@@@@G" "@@@@@@@@@@@@@@@@@@@F" "@@@@@@@@@@@@@@@@@@@G" "@@@@@@@@@@@@@@@@@@@O" "@@@@@@@@@@@@@@@@@@@O" "@@@@@@@@@@@@@@@@@@CO" "@@@@@@@@@@@@@@@@@@CO" "@@@@@@@@@@@@@@@@@@CO" "@@@@@@@@@@@@@@@@@@GO" "@@@@@@@@@@@@@@@@@@GO" "@@@@@@@@@@@@@@@@@@GM" "@@@@@@@@@@@@@@@@@@GM" "@@@@@@@@@@@@@@@@@@@N" "@@@@@@@@@@@@@@@@@@@N" "@@@@@@@@@@@@@@@@@@AM" "@@@@@@@@@@@@@@@@@@AM" "@@@@@@@@@@@@@@@@@@AN" "@@@@@@@@@@@@@@@@@@AN" "@@@@@@@@@@@@@@D@@@AM" "@@@@@@@@@@@@@AL@@@AO" "@@@@@@@@@@@@@@@@@@AJ" "@@@@@@@@@@@@@D@@@@AN" "@@@@@@@@B@@@AHCH@@AO" "@@@@@@@@B@@@GBGH@@AM" "@@@@@@@@@@@@DBGH@@AJ" "@@@@@@@@@@@L@COH@@AK" "@@@@@@@@@A@@@AOH@@AO" "@@@@@@@@@@A@@AOH@@AO" "@@@@@@@@@@@@@AO@@@AJ" "@@@AH@@@@@HABAOL@@AK" "@@@@@@@@H@H@@AON@@AM" "@@@@@@@D@@@@@@ON@@AO" "@@@@H@@D@@@@@COL@@AJ" "@@@@H@@@@@@@@AGL@@AK" "@@@@L@@@A@@D@@OL@@AM" "@@@@L@@@@@@D@@OL@@AO" "@@@@H@@@@@@@@@OL@@AK" "@@@@@@@@@@@@@COL@@AK" "@@@@@AALL@@@@@L@@@AO" "@@@@@@@D@@@D@@L@@@AO" "@@@@@@@D@@@@@@@@@@AN" "@@@H@@@@@@@@@@@@@@AI" "@@@@A@@C@@@@@@@@@@AO" "@D@@@N@A@@@@@@@@@@AO" "AOH@@@@@@@B@@@@@@@AJ" "GOH@@@@@C@@@@@@@@@@O" "GOH@@@@@A@D@@@@H@@@O" "AO@@@@B@@@D@@@@@@@@M" "OO@@B@B@@@@@@@@@@@@N" "ON@@@@@@@@@@@@@@@@@G" "OL@@@@B@@B@AH@@@@@@G" "OH@@@A@@@@@AN@@H@@@C" "OH@@@A@@@@@@F@@@@@@A" "O@@H@A@@@@@@@@@@@@@A" "L@@H@H@@A@@@@@@@@@@@" "L@@@@@H@A@@@@@@@@@@A" "MH@@@@H@@@@@@@@@@@@A" "I@@B@@@@@@D@@@CH@@@@" "@@@@@@@@A@@@@@CH@@@A" "@@@@@H@@@@@@@@@@@@@@" "@@@@@H@@@@@@@@@@@@@@" "@@@A@@@@@@@@@@C@@@@@" "@@@CLD@@@@@@@@C@@@@@" "@@AON@@@@@@@@@@@@@@@" "@@AOOH@@@@@@@@@F@@@@" "@@AOOH@C@@@@@@@F@@@@" "@@AOO@@C@@AL@@@@@@@@" "@@@OO@ACH@AL@@@F@@@@" "@@AOO@@AL@@@@@@F@@@@" "@@AOO@@@L@@@@@@@@@@@" "@@AOO@@@L@@@@@@@@@@@" "@@CON@H@@@@@@@@@@@@@" "@@AOL@@@@@@@@@@@@@@@" "@@@GL@@@@@@@@@@@@@@@" "@@@@L@@@@@@@@@@@@@@@" "@@@H@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "A@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@F@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@D@@@@@@HC@@@@" "@@@@@C@@@@@@@@H@@@@@" "@@@@@CA@C@@@@B@@@@@@" "@D@AH@AH@@@@@B@@@@F@" "@@@AH@@@@@@@@@@@@@@B" "@@@AH@@@@@F@@@@@@@@@" "@@@@@@@@H@F@@@A@@@F@" "@@@@@@@@@@@AHGNA@@F@" "@B@@C@@@@@@AHGNG@@B@" "@B@@C@@A@@@@@N@@@@@@" "@@@@@@@H@@C@@H@@@@@@" "@@@GHB@@@@C@L@@@D@@@" "@@@GH@@@D@CAL@AH@@B@" "@@@AH@@D@@@AH@AH@@B@" "@@@AH@@G@@@C@@C@@ALA" "L@@@@@BCH@@C@BCL@ML@" "LF@@@@BOH@@@@AH@@L@@" "@F@@@@OOO@L@@AH@AH@@" "@@@@@@OOO@L@@@@@AH@@")} 48 . 28))) (40 (({(READBITMAP)(16 9 "@@AO" "@@AO" "@@CO" "@@GO" "@@OO" "@@ON" "@AOL" "@AO@" "@@F@")} 32 . 68) ({(READBITMAP)(32 5 "@@AOO@@@" "@@COOH@@" "@@COOH@@" "@@@GL@@@" "@@@G@@@@")} 112 . 5) ({(READBITMAP)(64 63 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@LF" "@@@@@@@@@@@@@CHL" "@@@@@@@@@@@@@AAL" "@@@@@@@@@@@@@@OL" "@@@@@@@@@@@@@@OL" "@@@@@@@@@@@@@@OL" "@@@@@@@@@@@@@COL" "@@@@@@@D@@@@@@ON" "@@@@@@@@@@@D@@ON" "@@@@@@@@@@@@@@ON" "@@@H@@@@@@@@@@ON" "@@@@A@@C@@@@@@ON" "@@@@@N@A@@@@@@OL" "@B@@@@@@@@B@@@OL" "@B@@@@@@A@@@@@OL" "@@@@@@@@A@D@@@GL" "A@@@@@B@@@D@@@C@" "AH@@B@B@@@@@@@C@" "OL@@@@@@@@@@@@C@" "ML@@@@B@@B@AH@@@" "OH@@@A@@@@@AN@@H" "KH@@@A@@@@@@F@@@" "IH@H@A@@@@@@@@@@" "IH@H@H@@A@@@@@@@" "MH@@@@H@A@@@@@@@" "MH@@@@H@@@@@@@@@" "I@@B@@@@@@D@@@@H" "@@@@@@@@A@@@@@@@" "@@@@@H@@@@@@@@@@" "@@@@@H@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@D@@@@@@@@C@" "@@@L@@@@@@@@@@@@" "@@@L@@@@@@@@@@@@" "@@@LL@@@@@@@@@@@" "@@@HD@@B@@@@@C@@" "@@@CL@A@@@@@@C@B" "@@@CL@@@@@@@@@@B" "@@AML@@@@@@@@@@@" "@@AMO@@@@@@@@C@@" "@@CON@H@@@@@@C@@" "@@AOL@@@@@@@@C@@" "@@AOL@@@@@@@@@@@" "@@AOL@@@@@@@@@@@" "@@AOL@@L@@@@@@CL" "@@AOL@@L@@@@@@CL" "@@COL@@L@@@L@@@@" "@@CK@@@N@@OL@@@@" "@@@@@@@G@@OL@@@@" "A@@@@@@G@@@@@@@@")} 48 . 52) ({(READBITMAP)(32 16 "@@@@CNKJ" "@@@@COKJ" "@@@@GOOE" "@@@@OGEE" "@@@@NJJJ" "@@@@OJJJ" "@@@AMMEE" "@@@COEEH" "@@@CNJJ@" "@@@GJJL@" "@@@OME@@" "@@@OEE@@" "@@@OJJ@@" "@@@OJJ@@" "@@AMMD@@" "@@AMED@@")} 112 . 121))) (40 (({(READBITMAP)(16 24 "@@@@" "@C@@" "@@@@" "@@@@" "@@@@" "@@CH" "@BB@" "@@B@" "@@GB" "@@G@" "@@G@" "@@O@" "@AOH" "@AOL" "@AOL" "@AOL" "@AOH" "@AOH" "@AOH" "@AOH" "BAOH" "FAOH" "@@N@" "@@N@")} 96 . 78) ({(READBITMAP)(48 18 "OKBJJJJJJJJK" "LBGCCCKKKKCK" "HGMOOMMMMMOO" "MDNGGGGGGGGO" "JJFJJJJJJJOJ" "CCOKCKKKKCOK" "MMOOOMMMMMOM" "GGAGGGGGGGGG" "JJLJJJJJJJJK" "CCECCKKKKKKK" "MOKMOMMMMMMM" "GGAOGGGGGGGG" "JJFJJJJJJJOJ" "CCNCCKKKKKOK" "MLGMMMMMMMOM" "GEKGGGGGGGGG" "NMJJJJJJJKJJ" "NAKCCKKKKCOC")} 176 . 91) ({(READBITMAP)(48 7 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "OOHH@OOOOOOO")} 16 . 25) ({(READBITMAP)(64 48 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@B@@@@@@@@@@" "@@@@@B@@@@@@A@@@" "@@@@@@@@@@@@A@D@" "@@@@@@@@@@B@@@D@" "@@@@@@@@@@B@@@@@" "@@@@LD@@@@@@@@@@" "@@@AHD@@@@B@@B@A" "@@@B@@@@@A@@@@@A" "@@@DC@@@@A@@@@@@" "@@@@H@@H@A@@@@@@" "@@@@@@@H@H@@@@@@" "@@@FD@@@@@H@@@@@" "@@AOH@@@@@H@@@@@" "@@AOH@@B@@@@@@D@" "@@CO@@@@@@@@@@@@" "@@GN@@@@@H@@@@@@" "@@OLA@@@@H@@@@@@" "@@OL@@@@@@@@@@@@" "@AOL@@@@@D@@@@@@" "@AOLH@@@@@@@@@@@" "@AOH@@@@@@@@@@@@" "@COH@@@@L@@@@@@@" "@COH@@@HD@@B@@@@" "@COH@@@CH@A@@@@@" "@CN@@@@C@@@@@@@@" "@@N@@@AM@@@@@@@@" "@CH@@@A@A@@@@@@@" "@C@@@@C@@@H@@@@@" "@C@@@@AH@@@@@@@@" "@@@@@@AI@@@@@@@@" "@@@@@@ACL@@@@@@@" "@@@@@@@CL@@@@@@@" "@@@@@@@GL@@@@@@@" "@@@@@@@OL@@@@@@@" "@@@@@@COO@@@@@@@" "@@@@@@AOOH@@@@@@" "@@@@A@COOH@@@@@@" "@@@@@@CON@@@@@@@" "@@@@@@AON@@@@@@@" "@@@@@@AOL@AH@@@@" "@@@@@@AOL@AL@@AN" "@@@@@@@@@@AN@@AN" "@@@@@@@@@@@G@@@@" "@@AH@@@@@C@CH@@@" "@@@@@@@@@CAAK@@@")} 32 . 44))) (40 (({(READBITMAP)(64 18 "OKCEEEEEEEEKNJKJ" "LBFIIIAAAAHGOKKK" "HGLOOMMMMMOIOMOO" "MDOMMMMMMMM@GGOG" "JJGEEEEEEE@EBNJJ" "CCNDLDDDDL@DCOKK" "MMN@@BBBBB@BAOOO" "GG@HHHHHHHHHKOGG" "JJMEEEEEEEEDBIOJ" "CCDLLDDDDDDDGOMK" "MOJB@BBBBBBBCOOO" "GG@@HHHHHHHHKGGG" "JJGEEEEEEE@EBJJO" "CCOLLDDDDD@DCOKO" "MLFBBBBBBB@BOOOO" "GEJHHHHHHHHIGOGG" "NMKEEEEEEDEFJNJJ" "NAJLLDDDDL@KKKKK")} 176 . 91) ({(READBITMAP)(80 74 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@G@" "@@@@@@@@@@@@@@@@@@O@" "@@@@@@@@@@@@@@@@@@N@" "@@@@@D@@@@@@@@@@@@O@" "@@@@HD@@@@@@@@@@@AO@" "@@@@@@@@@@@@@@@@@AO@" "@@@@@@@@@A@@@@@@@AO@" "@@@@@@@@@@@@@@@@@AO@" "@@@@@@@H@@@@@@@@@CO@" "@@@@@@@@@@H@@@@@@CO@" "@@AA@@@@@@@@@@@@@CO@" "@@@A@@@B@@@@@@@@@COH" "@@@B@@@@@@@@@@@@@CO@" "@@@@@@@@@H@@@@@@@CO@" "@@N@A@@@@H@@@@@@@@O@" "@@ND@@@@@@@@@@@@@@O@" "@AN@@@@@@D@@@@@@@@O@" "@AO@H@@@@@@@@@@@@@L@" "@AOH@@@@@@@@@@@@@@@@" "@CO@@@@@L@@@@@@@@@@@" "@GO@@@@H@@@B@@@@@B@@" "AOOH@@@@@@A@@@@@@C@@" "AKN@@@@@@@@@@@@@@@@@" "AON@@@A@@@@@@@@@@@@@" "AON@@@A@A@@@@@@@@@@@" "COL@@@@@@@H@@@@@@A@@" "COH@@@@@@@@@@@@@@A@@" "COH@@@@@@@@@@@@@@@@@" "CN@@@@@@H@@@@@@@@@@@" "GN@@@@@@H@@@@@@@@@@@" "GH@@@@@D@@@@@@@@@@@@" "GH@@@@@O@@@@@@@@@@@@" "F@@@@@CO@@@@@@@@@@@@" "F@@@@@AO@@@@@@@@@@@@" "@@@@A@CO@@@@@@@@@@@@" "@@@@@@COL@@@@@@@@@@@" "@@@@@@AOL@@@@@@@@@@@" "@@@@@@AOL@@@@@@@@@@@" "@@@@@@GOL@@@@@@@@@OK" "@@@@@@GOH@@@@@@F@@OK" "@@@@@@GOL@@A@@@@@@HC" "@@AH@@GOLC@@@@@@@@H@" "@@@@@@COHCA@@@@@@B@@" "@@@@@DCOH@AH@@@@@B@@" "@@@@@@@AH@F@@@@@@@@@" "@@@@@@@AH@G@@@F@@@@@" "@@@@@@@@@@GHH@FL@@@@" "@@H@@@@@@@CL@@CMH@BA" "@@@@@B@@C@AO@COMH@CO" "@@@@@B@@C@@G@GO@@BCH" "@@@@@@@@@@@H@FB@@HG@" "@@@@@@@GHB@@@@@@L@G@" "@@@@@@@GH@@@D@@ALCMH" "@@@@@@@AH@@D@@@AHGMH" "@@@@@@@AH@@G@@@C@GC@" "@@@@@@@@@@BCH@@C@BCL" "@@@@@@@@@@BOH@@C@AH@" "@@@@@@@@@@OOO@LG@AH@" "@@@@@@@@@@OOO@LN@@@@" "@@@@@@@@@COOL@@L@@@@")} 32 . 27))) (40 (({(READBITMAP)(16 2 "@AHC" "@@@C")} 128 . 28) ({(READBITMAP)(48 10 "@@AMH@@A@@@@" "@CHAH@@G@@@@" "@GN@@B@H@@@@" "@FB@@H@@@@@@" "@@@@@@A@D@@@" "D@@@@@AH@@@@" "@@@@@DAH@@@@" "@@@C@DC@@@@A" "H@@A@BCL@LD@" "H@@A@AH@@L@@")} 80 . 30) ({(READBITMAP)(96 55 "@@@@@@@@@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@D@@@@@@@@@@@@@@" "@@@@@@@@HD@@@@@@@@@@@@A@" "@@@@@@@@@@@@@@@@@@@@@@A@" "@@@@@@@@@@@@@A@@@@@@@@F@" "@@@@@@@@@@@@@@@@@@@@@@F@" "@@@@@@@@@@@H@@@@@@@@@@O@" "@@@@@@@@@@@@@@H@@@@@@@O@" "@@@@@@AA@@@@@@@@@@@@@AO@" "@@@@@@@A@@@B@@@@@@@@@AOH" "@@@@@@@B@@@@@@@@@@@@@CO@" "@@@@@@@@@@@@@H@@@@@@@CO@" "@@@@@@H@A@@@@H@@@@@@@CO@" "@@@@@@HD@@@@@@@@@@@@@CO@" "@@@@@A@@@@@@@D@@@@@@@CO@" "@@@@@A@@H@@@@@@@@@@@@CN@" "@@@@@A@@@@@@@@@@@@@@@CN@" "@@@@@OA@@@@@L@@@@@@@@CN@" "@@@@@O@@@@@H@@@B@@@@@CN@" "@@@@AO@@@@@@@@A@@@@@@CN@" "@@@AAK@@@@@@@@@@@@@@@CN@" "@@@@AOB@@@@@@@@@@@@@@CN@" "@@@@GOB@@@@@A@@@@@@@@CH@" "@@@@GO@@@@@@@@H@@@@@@A@@" "@@@@CO@@@@@@@@@@@@@@@A@@" "@@@@OO@@@@@@@@@@@@@@@@@@" "@@@@ON@@@@@@H@@@@AH@@@@@" "@@@GON@@@@@@H@@@@AH@@@@@" "@@@GOH@@@@@@@@@@@@@@@@@@" "@@@EOH@@@@@@@@@@@@@@@@@@" "@@@ON@@@@@C@@@@@@@AH@@@@" "@@@ON@@@@@@A@@@@AHAH@@@@" "@@@ON@@@A@@A@@@@AH@@@@@@" "@@@ON@@@@@@OH@@@@@@@@@@@" "@@@OL@@@@@AOH@@@@@@@@H@@" "@@@OL@@@@@AN@@@@@@@@@H@@" "@@AOL@@@@@GN@@@@@@@@A@CH" "@@AOH@@@@@GOH@@@@@@FA@OH" "@@AOH@@@@@GOL@@A@@@@@@@B" "@@@C@@AH@@GOLC@@@@@@@@@@" "@@@@@@@@@LGOHCA@@@@@@B@@" "@@@@@@@@@LOOL@AH@@@@@B@@" "@@@@@@@@@@OOL@F@@@@@@@@@" "@@@@@@@@@@MMH@G@@@F@@@@@" "@@@@@@@L@@GO@@GHH@FL@@@@" "@@@@@@HL@@GO@@CL@@AMH@@A" "@@@@@@@@@B@@C@AO@CHAH@@G" "@@@@@@@@@B@@C@@G@GN@@B@H" "@@@@@@@@@@@@@@@H@FB@@H@@" "@@@@@@@@@@@GHB@@@@@@@@A@" "@@@@@@@@@@@GH@@@D@@@@@AH" "@@@@@@@@@@@AH@@D@@@@@DAH" "@@@@@@@@@@@AH@@G@@@C@DC@")} 16 . 32))) (40 (({(READBITMAP)(64 18 "OKBJJEEEEEEDABKJ" "LBGCCNNNNNFNJEKK" "HGMOOEMMMMOOONOO" "MDNGGJBBBBBJB@GG" "JJFJJEEEEE@EEAFJ" "CCOKCDDDDL@DD@GK" "MMOOOBBBBB@BB@AO" "GGAGGHHHHHHHH@IG" "JJLJJEEEEEEDAFAJ" "CCECCDDDDDDDD@CK" "MOKMOBBBBBBB@@AO" "GGAOGHHHHHHHHHIG" "JJFJJEEEEE@EEEFO" "CCNCCDDDDD@DD@GO" "MLGMMBBBBB@B@@GO" "GEKGGHHHHHHHH@GG" "NMJJJEEEEDEEE@JJ" "NAKCCDDDDL@LDGKK")} 176 . 91) ({(READBITMAP)(16 58 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@AH@" "@@A@" "@@D@" "@@D@" "@B@@" "@C@@" "@C@@" "@CN@" "@CN@" "@CN@" "@CN@" "@CN@" "@ON@" "@ON@" "@ON@" "@ON@" "@CN@" "@CN@" "@CN@" "@CN@" "@CF@" "@CN@" "@AN@" "@@@@" "@@@@" "@@@@" "@H@@" "@H@@" "A@CH" "@@L@" "@@@@" "@@@@" "@B@@" "@B@@" "@@@@" "@@@@" "@@@@" "H@@A" "@@@A" "@B@@" "@@@@" "@@@@" "@@@H" "@@@H" "@D@@" "@BB@" "@@@@" "@@@@")} 96 . 29) ({(READBITMAP)(64 52 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@H@@@@" "@@@@@@@@@@@@@@H@" "@@@@@@A@@@@@@@@@" "@@@@@@@@@@@B@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@H@@" "@@@@@@@@A@@@@H@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@D@@" "@@@@@@@@H@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@A@@@@@@@@@" "@@@@@@@@@@@H@@@B" "@@@@@@@@@@@@@@A@" "@@@A@@@@@@@@@@@@" "@@@@@AB@@@@@@@@@" "@@@@@AB@@@@@A@@@" "@@@@@@@@@@@@@@H@" "@@@@@@@@@@@@@@@@" "@@@@@A@@@@@@@@@@" "@@@@@@@@@@@@H@@@" "@@@@@@@@@@@@H@@@" "@@@G@@@@@@@@@@@@" "@@@@L@@@@@@@@@@@" "@@@@H@@@@@C@@@@@" "@@@AH@@@@@@@@@@@" "@@@AL@@@A@@@@@@@" "@@@AH@@@@@@AH@@@" "@@@OH@@@@@@@@@@@" "@@AOH@@@@@@@@@@@" "@@AOH@@@@@C@@@@@" "@@COH@@@@@D@H@@@" "@@GOH@@@@@DLH@@A" "@@GO@@AH@@GLLC@@" "@@GN@@@@@LGL@CA@" "@@GN@@@@@HOL@@AH" "@@GN@@@@@@OLL@F@" "@@GN@@@@@AONH@@@" "@@CN@@@L@AON@@@@" "@@CN@@HL@AOO@@@@" "@@CN@@@@@COOC@@@" "@@CH@@@@@COLC@@@" "@@CH@@@@@GOL@@@@" "@@AH@@@@@GON@B@@" "@@@@@@@@@GOO@@@@" "@@@@@@@@@@LA@@@D" "@@@@@@@@@@L@@@@G")} 16 . 32) ({(READBITMAP)(64 25 "@@B@@@@@@@@@@@AM" "@@BH@@@@@@@@@@AO" "@@@@H@@A@@@@@@@N" "@@@@@@@A@@@@@@@O" "@@D@@B@@@@@@@@@M" "@@B@@@@@@@@@@@@M" "@@@@@@@@@@@@L@@N" "D@@@@@@H@@@@@@@N" "@@@@@@@H@@@@@@@N" "@@@C@D@@@@@A@@@G" "H@@@@BB@@@@@@@@F" "H@@@@@@@@@@@B@HG" "O@LB@@@@@H@@@@@C" "O@LB@@@@@@@@@@@C" "L@@L@@@@@@@@@@@C" "L@@@@@@@@@@@@@@C" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@C" "@@@@@@@@@@@@@@@A" "H@@L@@@C@@@@@@@A" "H@@L@COKC@@@C@@A" "L@@@@GOOC@OICH@A" "H@@@@GOO@@ONCL@A" "@@@@AOOO@@OO@L@@")} 80 . 17))) (40 (({(READBITMAP)(112 68 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@A" "@@@@@@@@@@@@@@@@@@@@@@@@@@@A" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@A" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@G@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@" "@@@@@@@@@@@@@@@@@@@@@OH@@@@@" "@@@@@@@@@@@@@@H@@@@@@ON@@@@@" "@@@@@@@@@@@@@@@@@@@@@CN@@@@@" "@@@@@@@@@@@@@@@@@@@@@CN@@@@@" "@@@@@@@@@@@@@@@@@@@@@GN@@@@@" "@@@@@@@@@@@@@@@@@@@@@GN@@@@@" "@@@@@@@@@@@@@@@@@@@@@GF@@@@@" "@@@@D@@@@@@@@@@@@@@@@ON@@@@@" "@@@@H@@@@@@@@@@@@@AH@ON@@@@@" "@@@@H@@@@@@@@@@@@@A@@ON@@@@@" "@@@@@@@@A@@@@@@@@@@@@ON@@@@@" "@@@@@@@@@@@@@@@@@@@@@ON@@@@@" "@@@LH@@@@@@@@@@@@@@@AOL@@@@@" "@@@DH@@@@@@@@@@@@@@@AOL@@@@@" "@@@D@@@@@@@@@@@@@L@@AOOH@@@@" "@@BD@@@@@@D@@@@@@L@BAOL@@@@@" "@@FDH@@@@@DD@@@A@@@@@OL@@@@@" "@@G@@@AH@@@D@@@@@@@@@OL@@@@@" "@@G@@@@@@H@D@@@@@@@@@O@@@@@@" "@@GH@@@@@HL@@@@H@@@@@B@@@@F@" "@AOL@@@@@@@@@@D@L@@@@@@@@@@B" "@AOL@@@@@@@BH@@@L@B@@@@@@@@@" "@AOL@@@@@@@B@@@@@@BH@@@@@@@@" "@AOL@@@D@ANC@@@@@@@@H@@A@@@@" "@COL@@@@@ANCA@@@@@@@@@@A@@@@" "@COH@@@@@AN@A@@@@@D@@B@@@@@@" "@COH@@@@@AO@@@@@@@B@@@@@@@@@" "@COH@@@@@AON@B@@@@@@@@@@@@@@" "@CO@@@@@@AOO@@@@D@@@@@@H@@@@" "@AO@@@@@@GMI@@@D@@@@@@@H@@@@" "@AO@@AHH@OOH@@@G@@@C@D@@@@@A" "@AO@@AHH@OOL@@BCH@@@@BB@@@F@" "@AO@@@@@@OOL@@BOH@@@@@@@@@F@" "@AO@@@@@AOO@@@OOO@LB@@@@@H@@" "@AO@@@@@AOO@@@OOO@LB@@@@@@@@" "@AN@@@@@AOO@@COOL@@L@@@@@@@@" "@@@@@@@@@OO@@COOL@@@@@@@@@@@" "OOHH@OOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@AOOO@@@@@@@@@@@@" "@@@@@@@@@@@@AOOO@@@@@@@@@@@@" "@@@@@@@@@@@@AOOOH@@L@@@C@@@@" "@@@@@@@@@@@@AOOOH@LL@COKC@@@" "@@@@@@@@@@@@@OOGL@L@@GOOC@OI" "@@@@@@@@@@@@@OOOH@L@@GOO@@ON" "@@@@@@@@@@@@@@OK@@L@AOOO@@OO" "@@@@@@@@@@@@@@@@@@@@COOO@@OO" "@@@@@@@@@@@@@@@@@@@@GOOO@@MO" "@@@@@@@@@@@@@@@@@@@@OOOOHLLO" "@@@@@@@@@@@@@@@@@@@@AOOOHN@O" "@@@@@@@@@@@@@@@@@@@@@OON@F@O" "@@@@@@@@@@@@@@@@@@@@@MON@F@O")} 16 . 11))) (40 (({(READBITMAP)(64 18 "JJJEEEEDAEDBOJJJ" "CCKFNNFNJNNEOKKC" "OMMEMMOOOMOLOOOO" "GGGJBBBJBBJ@OGGG" "JJJEEE@EEAEECJJJ" "CKKDDL@DD@DDCKCC" "OMMBBB@BB@@@AOOO" "GGGHHHHHH@HHIGGG" "JJJEEEEDAF@EDJJK" "CKKDDDDDD@BDEKCC" "OMMBBBBB@@@@COOO" "GGGHHHHHHHHHIGGG" "JJJEEE@EEEE@FJJK" "CKKDDD@DD@D@GCCB" "MMMBBB@B@@@@GOOO" "GGGHHHHHH@HHGGGG" "JJJEEDEEEAEDJJJK" "CKKDDL@LDDDGKCCB")} 192 . 91) ({(READBITMAP)(32 31 "@@@@@@AO" "@@@@@@AM" "@@@@@@AM" "@@@@@@AO" "@@@@@@@N" "@@@@@@@O" "@@@@@@@M" "@@@@@@@M" "@@@@@@@N" "@@@@@@@N" "@@@@@@@N" "@@@@@@@G" "@@@@@@@F" "@@@@@@@G" "@@@@@@@C" "@@@@@@@C" "@@@@@@@C" "@@@@@@@C" "OOOOOOOO" "OOOOOOOO" "@@@@CH@C" "@@@@OH@A" "@@AHO@@A" "C@@@A@@A" "C@OICH@A" "@@ONCL@A" "@@OO@L@@" "@@OO@@@@" "@@MOH@@@" "HLLOH@@@" "HN@OH@B@")} 112 . 13) ({(READBITMAP)(48 31 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@B@@" "@@@@@@@@@B@@" "@@@@@@@@@A@@" "@@@@@@@@@A@@" "@@@@@@@@@A@@" "@@@@@@@@@C@@" "@@@@@@@@@CH@" "@@@@@@@@@CH@" "@@@@@@@@@GH@" "@@@@@@@@@GN@" "@@@@@@@@@OL@" "@@@@@@@@@OL@" "@@@@@@@@AOO@" "@@@@@@@B@OL@" "@@@@@@@@@OL@" "@@@@@@@@@OL@" "@@@@@@@@AO@@" "@@@H@@@@CO@@" "@@D@D@@@CO@@" "@@@@@@B@CO@@" "@@@@@@BHGOH@" "@@@@@@@@OOHA" "A@@@@@@@GOHA" "A@@@@@D@FOH@" "@@@@@@B@AOH@" "@B@@@@@@AKH@" "@@@@D@@@@CHH")} 64 . 34) ({(READBITMAP)(48 36 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@D@" "@@D@H@@@@@@D" "@@F@@@A@@@@@" "@@D@@@@@@@@@" "@@D@@@@@@HL@" "@@OH@@@@@@@@" "@@M@@@@@@@@B" "@@M@@@@@@@@@" "@@GH@@@D@@@@" "@AOH@@@@@@DA" "@COH@@@@@@@@" "@COH@@@@@@@@" "@COH@@@@@AL@" "@CO@@@@@@ALA" "@AO@@@@@@GOA" "@CO@@AHH@OOH" "@CO@@AHH@OIH" "@GO@@@@@@OOL" "@GO@@@@@AOO@" "@GO@@@@@AOO@" "@GN@@@@@AOO@" "@@@@L@@@@OO@" "OOHHOOOOOOOO" "OOOOOOOOOOOO" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@L@@@D" "@@@@@@OL@@@D" "@@@@@@O@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@AH")} 16 . 15))) (40 (({(READBITMAP)(16 1 "@L@@")} 80 . 8) ({(READBITMAP)(96 48 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@D@@" "@@@@@@@@@@@@@@@@@@@@@F@@" "@@@@@@@@@@@@@@@@@@@@@N@@" "@@@@@@@@@@@@@@@@@@@@@L@@" "@@@@@@@@@@@@@@@@@@@@CN@@" "@@@@@@@@@@@@@@@@@@@@AN@@" "@@@@@@@@@@@@@@@@@@@@CN@@" "@@@@@@@@@@@@@@@@@@@@CO@@" "@@@@@@@@@@@@@@@@@@@HCOH@" "@@@@@@@@@@@@@@@@@@@@COH@" "@@@@@@@@@@@@@@@@@@@@COH@" "@@A@@@@@@@@@@@@@@@D@BOH@" "@@@@@@@@@@@@@@@@@@@@COH@" "@@D@@@@@@@@@@@@@@@@@COH@" "@@L@@@@@@@@@@@@@D@@@CGL@" "@@L@@@@@@@@@@@@D@@@@AGL@" "@@L@@@@@@@@@@@@G@@@CAOL@" "@CL@@@@@@@@@@@BCH@@@AON@" "@GO@@@@@@@@@@@BOH@@@ANL@" "@GO@@@@@@CI@@@OOO@LBAOL@" "@GO@@@@@AOO@@@OOO@LB@OH@" "@GN@@@@@AOO@@COOL@@L@G@@" "@@@@@@@@@OO@@COOL@@@@@@@" "OOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@AOOO@@@@@@@@" "@@@@@@@@@@@@AOOO@@@@@@@@" "@@@AL@@L@@@DAOOOH@@LD@@C" "@@@@@@OL@@@DAOOOH@LLDCOK" "@@@B@@O@@@@@@OOGL@L@HGOO" "@CH@@@@@@@@@@OOOH@LAHGOO" "@C@@@@@@@@@@@@OK@@L@AOOO" "@@@@@@@@@@@@@@@@@@@@COOO" "@@@@@@@@@@AH@@@@@@@@GOOO" "@@B@@@@@@@@@@@@@@@@@OOOO" "@@CH@@@@@@@@@@@@@@@@AOOO")} 16 . 13))) (40 (({(READBITMAP)(16 1 "@@@A")} 32 . 12) ({(READBITMAP)(16 1 "@@@B")} 80 . 32) ({(READBITMAP)(64 18 "JJJJJEEDAEDE@BJJ" "CCKKKFFNJNNNJEKC" "OMMMMEOOOMOOOLOO" "GGGGGJBJBBJBB@OG" "JJJJJE@EEAEE@EFJ" "CKKKKL@DD@DD@DOC" "OMMMMB@BB@@@@@AO" "GGGGGHHHH@HHHHIG" "JJJJJEEDAF@EEEDK" "CKKKKDDDD@BDDDMC" "OMMMMBBB@@@@B@AO" "GGGGGHHHHHHHHHIG" "JJJJJE@EEEE@EEFK" "CKKKKD@DD@D@DLOB" "MMMMMB@B@@@@@@GO" "GGGGGHHHH@HHHHGG" "JJJJJDEEEAEEEDJK" "CKKKKL@LDDDDDOCB")} 192 . 91) ({(READBITMAP)(16 20 "@L@@" "@L@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "OOOO" "OOOO" "@@@@" "@@@@" "@@@D" "@@@D" "@@@@" "@L@@" "@L@@" "@@@@" "L@AH" "L@@@" "L@@@")} 48 . 13) ({(READBITMAP)(32 11 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@C" "@@@@@@@C" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@")} 16 . 27) ({(READBITMAP)(32 23 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "B@H@@@@@" "@@@@@@@@" "@C@@@@@@" "@GL@@@@@" "@GN@@@@@" "ACL@AH@@" "BCL@AH@@" "BGN@@@@@" "COOH@@@@" "COOH@@@@")} 96 . 26))) (40 (({(READBITMAP)(16 22 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "OOOO" "OOOO" "@@@@" "@@@@" "L@@L" "@AOL" "@AO@" "@AO@" "@@O@" "@@G@" "@@@@" "@@@@" "AOH@" "AOHA" "@AH@" "@AH@")} 32 . 10) ({(READBITMAP)(32 5 "C@@@@L@@" "CH@@@L@@" "AH@@@@H@" "@@@@@@L@" "@@@@@@A@")} 64 . 10) ({(READBITMAP)(80 10 "@@@@@@ML@@@@B@@@@@@@" "@@@@@@OLD@@@@@@@@@@@" "@@@@@@GL@@@@@B@@@@@@" "@@@@@@GN@@@B@@@@@@@@" "@@@@@@GK@@@@@@B@@@@@" "@@@@@@BOH@@@@A@@@@@@" "@@@@@@OOH@LB@@@@@@@@" "@@@@@@LOH@LB@@@@@@@@" "@@@@@CLOH@@L@@@@@@@@" "@@@@@COOH@@@@@@@@@@@")} 48 . 26))) (40 (({(READBITMAP)(16 4 "@@H@" "@@L@" "@@C@" "@@C@")} 48 . 6) ({(READBITMAP)(16 2 "@@@C" "@@@C")} 0 . 20) ({(READBITMAP)(48 18 "JJEDAEDE@EBJ" "KKNNJNNNJNEC" "MMGOOMOOOOLO" "GGJJBBJBBB@O" "JJ@EEAEE@EEF" "KC@DD@DD@DLO" "MM@BB@@@@@@A" "GGHHH@HHHHHI" "JJEDAF@EEEEE" "KKDDD@BDDDLM" "MMBB@@@@B@@A" "GGHHHHHHHHHI" "JJ@EEEE@EEEG" "KK@DD@D@DLLN" "MM@B@@@@@@@G" "GGHHH@HHHHHG" "JKEEEAEEEEDK" "KC@LDDDDDLOB")} 208 . 91) ({(READBITMAP)(32 14 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "H@@@@@@@" "H@@@@@@@" "H@@@@@@@" "H@@@@@@@")} 80 . 27))) (40 (({(READBITMAP)(64 18 "JJJDAEDE@EEBNO@@" "KKCFJNNNJNNMFO@@" "MMOGOMOOOOOLMO@@" "GGGBBBJBBBB@OO@@" "JJOEEAEE@EEEAK@@" "KCODD@DD@DLLJK@@" "MMOBB@@@@@@@AO@@" "GGGHH@HHHHHHEG@@" "JJJDAF@EEEEDAK@@" "KKKDD@BDDDLLCC@@" "MMMB@@@@B@@@MO@@" "GGGHHHHHHHHHAG@@" "JJOEEEE@EEED@K@@" "KKODD@D@DLLMCF@@" "MMOB@@@@@@@@EN@@" "GGGHH@HHHHHHGF@@" "JKJEEAEEEEEEJN@@" "KCOLDDDDDLLNKF@@")} 208 . 91))) (40 (({(READBITMAP)(80 21 "JJJKNJKJOJJJNO@@@@@@" "KKCJ@DDD@DDLFO@@@@@@" "MMONEGEEEEEDAO@AH@@@" "GGGNGGOGGGGGAONOH@@@" "JJOK@D@@E@@@BKOOH@@@" "KCOJD@DD@DLLICOOL@@@" "MMOLB@@@@@@@@GOOL@@@" "GGGFH@HHHHHHDKOOH@@@" "JJJJAF@EEEED@GOOH@@@" "KKKJD@BDDDLLBOOL@@@@" "MMML@@@@B@@@LCGN@@@@" "GGGFHHHHHHHH@KCI@@@@" "JJOKEEE@EEEDCG@@@@@@" "KKOJD@D@DLLM@N@L@@@@" "MMOL@@@@@@@@BFOL@@@@" "GGGFH@HHHHHHHFOL@@@@" "JKJKEAEEEEEDDOON@@@@" "KCOBDDDDDLLMGGOO@@@@" "MOON@@@@@@@@EOOOH@@@" "GGOGGGGGGGGGGGOCH@@@" "JJJJJJJJJJJMNONCH@@@")} 208 . 88))) (40 (({(READBITMAP)(32 26 "OO@@N@@@" "GO@AN@@@" "NOGOO@@@" "FOGOO@@@" "AOOOH@@@" "AOOOK@@@" "BK@OOH@@" "ICAOOH@@" "@GCOL@@@" "DKCON@@@" "@GION@@@" "BOLOL@@@" "LCOAKL@@" "@KOMOL@@" "CGNOO@@@" "@ONGN@@@" "BFCOGL@@" "HFGOOL@@" "DNGGL@@@" "GFGNO@@@" "EOONO@@@" "GEON@@@@" "NLCN@@@@" "CDCN@@@@" "ML@F@@@@" "GL@F@@@@")} 256 . 85))) (40 (({(READBITMAP)(64 22 "JJJKNJKJOJJJNO@G" "KKCKODDD@DDLIGGO" "MMOOO@JJJJJJHAOO" "GGGOGOOGGGGGGLHO" "JJOJJCOOJOOOHLHG" "KCOKK@DD@DLLIDLO" "MMOMM@@@@@@@@@LO" "GGGGG@HHHHHHDHNO" "JJJKNF@EEEED@DNG" "KKKKK@BDDDLLBLNC" "MMMMO@@@B@@@L@NC" "GGGGGHHHHHHH@HNG" "JJOJJEE@EEEDCDNG" "KKOKK@D@DLLM@HMO" "MMOMO@@@@@@@BAOK" "GGGGG@HHHHHHHIKO" "JKJJJAEEEEEDEACO" "KCOCKDDDDLLMDIKN" "MOOOO@@@@@@@BCON" "GGOGGGGGGGGGGDOO" "JJJJJJJJJJJMNLCO" "KKKKKKKKKCCGCDAN")} 208 . 87) ({(READBITMAP)(16 33 "AH@@" "AH@@" "CH@@" "OOOH" "OOOH" "O@GH" "O@OH" "H@O@" "K@O@" "OHO@" "OH@@" "L@@@" "N@@@" "N@@@" "L@@@" "KL@@" "OL@@" "O@@@" "N@@@" "GL@@" "OL@@" "L@@@" "O@@@" "O@@@" "AH@@" "CN@@" "ON@@" "ON@@" "GN@@" "@N@@" "@N@@" "@N@@" "@N@@")} 272 . 81))) (40 (({(READBITMAP)(80 48 "KKKKKOCCCL@@@@@@AL@@" "MMOOMOOOON@@@@@AIL@@" "GGOGGGOGGF@@@@@AH@@@" "JJJNJMJJKN@@@@@C@@@@" "KKKOKOKCCF@@@@AK@@@@" "MOOOOOOOOF@@@@CH@@@@" "OOGOGMOGGN@@@@G@@@@@" "ONKJJOJJKN@@CHFAL@@@" "LOKKKOKCBO@@ONGIL@@@" "MOOOOOOONO@@OOOKL@@@" "OOGOGOGGGO@@GKIK@@@@" "KJNJJNJJJG@AOCAH@@@@" "KKKKKKKCCO@AO@@@@@@@" "OOOOOOOOOO@OOOOH@@@@" "OGGOGOGGGO@OOOOH@@@@" "NJKJOJJJNO@@O@GH@@@@" "OKDD@DDLI@HAL@OH@@@@" "OMBJJJJJHJFCO@O@@@@@" "GGGGGGGGGOKCO@O@@@@@" "JNGOJOOOHNGHGHO@@@@@" "KODD@DLLIDOMKL@@@@@@" "MO@@@@@@@@OMKL@@@@@@" "GOHHHHHHDHON@L@@@@@@" "NI@EEEED@DONN@F@@@@@" "KOBDDDLLBLONN@F@MH@@" "OO@@B@@@L@ONMLF@MH@@" "GGHHHHHH@IOOML@@@@@@" "JJE@EEEDCEOOI@CL@@@@" "KOD@DLLM@IOMN@COH@@@" "OO@@@@@@BAOLOLCOH@@@" "GOHHHHHHHIOHGL@O@@@@" "JNEEEEEDEAO@G@@L@@@@" "KKDDDLLMDIN@C@@@@@@@" "OO@@@@@@BAL@CH@@@@@@" "GGGGGGGGGDALCKHCH@@@" "JJJJJJJMNLAOOOIKH@@@" "KKKKKCCGCD@OONCOH@@@" "OOMOOOOOML@OKNCOH@@@" "GGGGGG@KGL@OONCO@@@@" "JJOJJJ@NJH@@ONCO@@@@" "OKOKK@@GCHC@CLCOL@@@" "OMOOOLAMMHCOOLCCL@@@" "OGGGGFBOGHGOLN@AL@@@" "OJJJJJJJKHGOLLGN@@@@" "OKKKKCGCC@CO@@GN@@@@" "OOOOOMLMO@OO@@GO@@@@" "GGGGGGGGGCOK@@@G@@@@" "JJJJJJNKNCO@@@@C@@@@")} 224 . 76))) (40 (({(READBITMAP)(16 18 "OKKD" "OMOB" "GGOO" "JNJG" "KOKD" "MOO@" "GOGH" "NIOE" "KOMD" "OOO@" "GGGH" "JJJ@" "KOK@" "OOO@" "GOGH" "JNJE" "KKKD" "OOO@")} 224 . 90) ({(READBITMAP)(48 61 "GH@@@@@@@@GH" "KH@@@@@@@AOH" "CH@@@@@@AKH@" "ML@@@@@@AKL@" "GL@@@@@@CIL@" "JL@@@@@@C@@@" "CL@@@@L@AL@@" "ON@@@@LAIL@@" "GF@@@@@AH@@@" "KN@@@@@C@@@@" "CF@@@@AK@@@@" "OF@@@@CH@@@@" "GN@@@@G@@@@@" "KN@@CHFAL@@@" "BO@@ONGIL@@@" "NO@@OOOKL@@@" "GO@@GKIK@@@@" "JG@@OCAH@@@@" "CO@@O@@@@O@@" "OO@@OOOIOO@@" "GO@@OOOAOO@@" "NO@@GGOHOO@@" "I@OH@COHCO@@" "HJMNAAOHCO@@" "GOHCAAOHC@@@" "HNEGIIN@@@@@" "IDOOMLN@@@@@" "@@OOML@@@@@@" "DHOONL@@@@@@" "@DOON@F@@@@@" "BLOON@F@MH@@" "L@OONLF@MH@@" "@IOONL@@@@@@" "CEOON@CL@@@@" "@IOOL@COOH@@" "BAOOMLCOOH@@" "HIOOOLAOO@@@" "EAOOC@AON@@@" "DIONC@AON@@@" "BAOLCHAOH@@@" "GD@@CKIO@@@@" "NL@HCOIN@@@@" "CD@HCNB@@@@@" "ML@ACNBAH@@@" "GL@GONBA@@@@" "JH@@ON@@AO@@" "CHF@CL@@AO@@" "MHF@OL@@GO@@" "GH@@DN@@OO@@" "KHF@DLDFOO@@" "C@FF@@DDGO@@" "O@@F@@@@GO@@" "GBF@@@@@GO@@" "N@F@CH@@GO@@" "N@@@OL@@GO@@" "L@@AOL@@GN@@" "L@@GOH@@GN@@" "L@AOO@@@@F@@" "H@AON@@@@@@@" "H@AOH@@@@@@@" "@@@CH@@@@@@@")} 256 . 69))) (40 (({(READBITMAP)(16 18 "OKKK" "OMOO" "GGOG" "JNJJ" "KOKK" "MOOO" "GOGG" "NIOJ" "KOMK" "OOOO" "GGGG" "JJJO" "KOKO" "OOOO" "GOGG" "JNJJ" "KKKK" "OOOO")} 224 . 90) ({(READBITMAP)(80 76 "OKOL@@@@@@@@F@@@@@@@" "MMMN@@@@@@@@F@@@@@@@" "GGGO@@@@@@@@F@@@@@@@" "JJJOH@@@@@@AN@@@@@@@" "KKKCL@@@@@@CH@@@@@@@" "OMOMN@@@@@@C@@@OH@@@" "GGGGG@@@@@@C@@AOH@@@" "JJJJK@@@@@@L@@AON@@@" "KKKKC@@@@@@L@@CON@@@" "OOMMOH@@@@@@@COOL@@@" "GGGGGH@@@@@@@COOH@@@" "JJJJKH@@@CA@@@KOH@@@" "KKKKCH@@@DC@A@H@@@@@" "MOOOML@@@DC@A@H@@@@@" "GGGGGL@@@@L@@@@@@@@@" "NNNJJL@@@@L@@@@@@@@@" "KOCCCL@@AKL@@@@@@@@@" "MOOOON@@AOLAH@@@@@@@" "GGOGGF@@MLLAH@@@@@@@" "JMJJKN@@D@@C@@@@@@@@" "KOKCCF@@D@AK@@@@@@@@" "OOOOOF@L@@CH@@@@@@@@" "GMOGGN@L@@G@@AH@@@@@" "JOJJKN@LCHFALAH@L@@@" "KOKCBO@@ONGIL@@AOH@@" "OOOONO@ALOOKL@@COH@@" "GOGGGO@ALAIKC@@CON@@" "JNJJJG@@@AAHC@@OON@@" "KKKCCO@N@@@@CFLOOL@@" "OOOOOO@NFMOK@@LGOH@@" "GOGGGO@@FLOG@@@GN@@@" "OJJJNO@@@@OO@@@CN@@@" "@DDLI@OOH@OO@@@@@@@@" "BJJJHJMEN@OOB@@@@@@@" "OGGGGOH@C@OOC@@@@@@@" "BOOOHNEEGHNG@@@@@@@@" "@DLLIDOOOLNC@@@@@@@@" "@@@@@@OOOL@@@@@@@@@@" "HHHHDHOOON@@@@@@@@@@" "EEED@DOOONF@@@@@@@@@" "DDLLBLOOONF@MH@@@@@@" "B@@@L@OOONF@MH@@@@@@" "HHHH@IOOON@@@@@@@@@@" "EEEDCEOOON@@@@@@@@@@" "DLLM@IOOOLB@AH@@@@@@" "@@@@BAOOOLBGGOH@@@@@" "HHHHHIOOOH@GGOH@@@@@" "EEEDEAOOO@@FGON@@@@@" "DLLMDIOOO@@FGON@@@@@" "@@@@BAOOMH@COOH@@@@@" "GGGGGD@@CKI@OOH@@@@@" "JJJMNL@HCOI@OO@@@@@@" "KCCGCD@HCNC@ON@@@@@@" "OOOOML@ACNBAOL@@@@@@" "GG@KGL@GONBAG@@@@@@@" "JJ@NJH@@ON@@@@@@@@@@" "K@@GCHF@CL@@@@AH@@@@" "OLAMMHF@OL@@@@AH@@@@" "GFBOGH@@DN@@@@CH@@@@" "JJJJKHF@DLDF@@OH@@@@" "KCGCC@FF@@DD@AON@@@@" "OMLMO@@F@@@@@CON@@@@" "GGGGGBF@@@@@@AON@@@@" "JJNKN@F@@@@@@AON@@@@" "KKCCN@@@C@@@@AON@@@@" "OMJLL@@@C@L@@AON@@@@" "GAOAL@@@@@L@@AON@@@@" "J@JKL@@D@@@@@AON@@@@" "J@KCH@@@@IH@@AOL@@@@" "NAEMH@@@@IH@@COH@@@@" "GCOG@@@@@OH@@@OH@@@@" "JKBK@@@@COH@@@@@@@@@" "KBKO@@@@COH@@@@@@@@@" "OOMG@@@AOOH@@@@@@@@@" "GANN@@@COOH@@@@@@@@@" "JAIF@@@COOH@@@@@@@@@")} 240 . 64))) (40 (({(READBITMAP)(80 86 "COH@@@@@@@@@@AN@@@@@" "MON@@@@@@@@@@GN@@@@@" "GGO@@@@@@@@@@OL@@@@@" "OJKH@@@@@@@@@OL@@@@@" "OKOL@@@@@@@@FGH@@@@@" "MMMN@@@@@@@@GO@@@@@@" "GGGO@@@@@@@@GL@@@L@@" "JJJOH@@@@@@AN@@@OL@@" "KKKCL@@@@@@CH@@@OO@@" "OMOMN@@@@@@C@@@HOO@@" "GGGGG@@@@@@C@@AHOO@@" "JJJJK@@@@@@L@@@@ON@@" "KKKKC@@@@@@L@@@AOO@@" "OOMMOH@@@@@@@@@GOO@@" "GGGGGH@@@@@@@@@A@@@@" "JJJJKH@@@CA@@F@@@@@@" "KKKKCH@@@DC@AF@@@@@@" "MOOOML@@@DC@A@@@@@@@" "GGGGGL@@@@L@@F@L@@@@" "NNNJJL@@@@L@@F@L@@@@" "KOCCCL@@AKL@@@@L@@@@" "MOOOON@@AOLAH@@@@@@@" "GGOGGF@@MLLAHCL@@@@@" "JMJJKN@@D@@C@CL@@@@@" "KOKCCF@@D@AK@@@@@@@@" "OOOOOF@L@@CH@@@@AH@@" "GMOGGN@L@@G@@AH@AL@@" "JOJJKN@LCHFALAH@CL@@" "KOKCBO@@ONGIL@@ACON@" "OOOONO@ALOOKLN@COON@" "GOGGGO@ALAIKCO@COON@" "JNJJJG@@@AAHCO@COON@" "KKKCCO@N@@@@GOL@OON@" "OOOOOO@NFMOKGOL@C@@@" "GOGGGO@@FLOGGO@@@@@@" "OJJJNO@@@@@GGO@@@@@@" "OLDLI@OOOL@AON@@@@@@" "OIEEGEBJJO@AN@@@@@@@" "GCGGGOH@@AH@A@@@@@@@" "OL@@GAJJJKL@@@@@@@@@" "OLLLIDOOOON@@@@@@@@@" "OH@@@@OOOON@@@@L@@@@" "G@HHDHOOOOO@@@@L@@@@" "JMED@DOOOOO@@@@@@@@@" "KLLLBLOOOOO@@F@@@@@@" "MH@@L@OOOOO@@F@@@@@@" "G@HH@IOOOOO@@@@@@@@@" "JMEDCEOOOOO@@@AH@@@@" "KDLM@IOOOON@@@AH@@@@" "OH@@BAOOOONADGKH@@@@" "G@HHHIOOOOL@@OOH@@@@" "JMEDEAOOOOH@@OOH@@@@" "KDLMDIOOOO@FAOOH@@@@" "OH@@BAOOOFCCAOOH@@@@" "GGGGGD@@BAK@COOH@@@@" "JJJMNL@HBCK@COMH@@@@" "KCCGCD@HBBC@COOL@@@@" "OOOOML@A@BCLCMOL@@@@" "GG@KGL@GHHCLC@CL@@@@" "JJ@NJH@@@A@L@@@H@@@@" "K@@GCHF@@GFL@@@@@@@@" "OLAMMHF@OMOL@@@@@@@@" "GFBOGH@@DOOL@@@@@@@@" "JJJJKHF@DMON@AH@@@@@" "KCGCC@FF@AOL@AHN@@@@" "OMLMO@@F@ON@L@@N@@@@" "GGGGGBF@@ON@@@DOL@@@" "JJNKN@F@@CH@AHGOL@@@" "KKCCN@@@CCL@AHGOL@@@" "OMJLL@@@C@LAIHOON@@@" "GAOAL@@C@@@CIHOON@@@" "J@JKL@@G@@@C@@GON@@@" "J@KCH@@@@AH@@@GON@@@" "NAEMH@@@@@H@@@GON@@@" "GCOG@@@@@@H@@@OON@@@" "JKBK@@@@@@AH@@AOL@@@" "KBKO@@@LC@@N@@AOL@@@" "OOMG@@@L@D@N@@AMH@@@" "GANN@@@L@D@N@@@AH@@@" "JAIF@@@C@OON@@@@@@@@" "J@JL@@@@@@ON@@@@@@@@" "MCLL@@@@AOON@@@@@@@@" "GMGL@@@NAOOL@@@@@@@@" "JJKH@@@NAOON@@@@@@@@" "KOOH@@@@AOOOL@@@@@@@" "MOGH@@@@AOIML@@@@@@@")} 240 . 58))) (40 (({(READBITMAP)(16 5 "IJFA" "ICOO" "OL@A" "FMOO" "IJKJ")} 144 . 104) ({(READBITMAP)(80 99 "@@@@@@@@@@@@@@AN@@@@" "@@@@@@@@@@@@@@COH@@@" "N@@@@@@@@@@@@@GOH@@@" "OL@@@@@@@@@@@@GOH@@@" "COH@@@@@@@@@@AON@@@@" "MON@@@@@@@@@@GOH@@@@" "GGO@@@@@@@@@@NF@@@@@" "OJKH@@@@@@@@@LD@@GL@" "OKOL@@@@@@@@FDH@AOL@" "MMMN@@@@@@@@GI@@AOL@" "GGGO@@@@@@@@GH@@@OL@" "JJJOH@@@@@@AN@@@COL@" "KKKCL@@@@@@CH@@@GOL@" "OMOMN@@@@@@C@@@HCOL@" "GGGGG@@@@@@C@@AHCOL@" "JJJJK@@@@@@L@@@@COL@" "KKKKC@@@@@@L@@@@COL@" "OOMMOH@@@@@@@@@FGO@@" "GGGGGH@@@@@@@@@@@@@@" "JJJJKH@@@CA@@F@CH@@@" "KKKKCH@@@DC@AGOCH@@@" "MOOOML@@@DC@AAO@@@@@" "GGGGGL@@@@L@@F@L@@@@" "NNNJJL@@@@L@@F@L@@@@" "KOCCCL@@AKL@@@@L@@@@" "MOOOON@@AOLAHGH@@@@@" "GGOGGF@@MLLAHGML@@@@" "JMJJKN@@D@@C@CML@@@@" "KOKCCF@@D@AK@OMH@@LH" "OOOOOF@L@@CH@MOHAHOL" "GMOGGN@L@@G@@MN@ALGH" "JOJJKN@LCHFAMOL@CMOH" "KOKCBO@@ONGIMOLACOOH" "OOOONO@ALOOKMOLCOOOH" "GOGGGO@ALAIKCOHCOOO@" "JNJJJG@@@AAH@B@COOO@" "KKKCCO@N@@@@D@@@OON@" "OOOOOO@NFMOKF@@@C@@@" "GOGGGO@@FLOG@@@F@@@@" "OJJJNO@@@@@F@@@F@@@@" "OKLLI@OOOOL@@AH@@@@@" "OOIEGEBJJJO@@AH@@@@@" "GGCGGOH@@@AH@@@@@@@@" "OJL@GAJJJJKL@@@@@@@@" "OKDLIDOOOOON@@@@@@@@" "OOH@@@OOOOON@@@L@@@@" "GG@HDHOOOOOO@@@L@@@@" "JJMD@DOOOOOO@@@@@@@@" "KKDLBLOOOOOO@@@@@@@@" "MOH@L@OOOOOO@@@@@@@@" "GG@H@IOOOOOO@@@@@@@@" "JJMDCEOOOOOO@@AH@@@@" "KCDM@IOOOOON@@@@@@@@" "OOH@BAOOOOON@L@@@@@@" "GG@HHIOOOOOL@L@H@@@@" "JJMDEAOOOOOH@LGH@@@@" "KCDMDIOOOOO@@LGO@@@@" "OOH@BAOOOON@AHGOH@@@" "GGGGGD@@@@@@AHGOH@@@" "JJJMNL@H@@A@@@GOH@@@" "KCCGCD@HBBC@AHOOL@@@" "OOOOML@A@BCL@EOOL@@@" "GG@KGL@GHHCH@@OOL@@@" "JJ@NJH@@@A@H@@OOL@@@" "K@@GCHF@@GFH@@OOL@@@" "OLAMMHF@OMOH@@NOH@@@" "GFBOGH@@DOOL@@@@@@@@" "JJJJKH@@DMON@AH@@@@@" "KCGCC@@F@AOL@AHN@@@@" "OMLMO@@F@ON@L@@H@@@@" "GGGGGBD@@ON@@@D@D@@@" "JJNKOLF@@CH@AHF@L@@@" "KKCCOLF@CCL@AHF@L@@@" "OMJLL@G@C@LAIH@@N@@@" "GAOAMHCC@@@CIH@GO@@@" "J@JKMH@G@@@C@@@GO@@@" "J@KCHF@@@AH@@@@OO@@@" "NAEMHFCH@@H@@@BOOL@@" "GCOGALCH@@H@@@CIOL@@" "JKBKALG@@@@H@@AOOL@@" "KBKOAL@LC@@F@@AOOL@@" "OOMGAH@L@D@D@@AOOL@@" "GANNAHCL@D@D@@@GOL@@" "JAIF@@@C@N@D@@@GOL@@" "J@JL@@@@@@@@@@@GN@@@" "MCLL@AL@A@@B@@@GN@@@" "GMGL@ALL@@@D@@@GN@@@" "JJKH@@@L@H@N@@@@F@@@" "KOOH@@@@A@DOL@@@F@@@" "MOGH@@@@A@HML@@@@@@@" "EEO@@@@@@@@OL@@@@@@@" "JKKH@@@@@@AOL@@@@@@@" "JKKH@@@@@COOL@@@@@@@" "GGO@@@@@@COOH@@@@@@@" "EEG@@@@@@GOOH@@@@@@@" "JKN@@@@@@OOK@@@@@@@@" "JKN@@@@@@OOL@@@@@@@@" "GGL@@@@@ALLL@@@@@@@@" "OEL@@@@@AL@@@@@@@@@@")} 240 . 49))) (40 (({(READBITMAP)(16 15 "NL@@" "CDAI" "MLCI" "GLCK" "JHCC" "CHF@" "MHN@" "GHL@" "KH@@" "C@@F" "OAHF" "GCL@" "OLF@" "OOF@" "LCG@")} 256 . 74) ({(READBITMAP)(32 24 "@AL@A@@@" "@ALL@@@@" "@@@L@@@H" "@@@@A@D@" "@@@@A@H@" "@C@@@@@@" "@CK@@@@L" "@BC@@C@C" "CBAN@B@@" "C@@@@D@@" "CH@@@D@@" "AHMH@N@D" "@IO@@DLL" "@OI@@D@@" "@@@@@@@@" "@@@@@@@G" "@@@@@@AO" "@@@@@COO" "@@@@@COO" "@@@@@@GO" "@@@@@@ON" "@@@@@@N@" "@@@@@AH@" "@@@@@AH@")} 256 . 39) ({(READBITMAP)(32 112 "@@@@CO@@" "@@@@OO@@" "@@@CON@@" "@@@GOH@@" "@@@GO@@@" "@@@GN@@@" "@@AOL@@@" "@@COL@@@" "@@GOH@@@" "@@GOH@@@" "@AON@@@@" "@GOH@@@@" "@NF@@@OH" "@LD@@GOH" "FDH@AOOH" "GI@LAOOH" "GH@L@OOH" "N@C@COOH" "HFC@AOOH" "@F@HAOO@" "F@AHAON@" "F@@@AON@" "@@@@AON@" "@@@F@G@@" "@@@@@@@@" "@F@CK@@@" "AGOCK@@@" "AAO@@@@@" "@F@L@@@@" "@F@L@@@@" "@@@L@@N@" "HGH@@@OL" "HGML@AOL" "@CML@AOH" "@OMIHCOH" "@MOIIOOL" "@MN@AOOH" "MOL@COOH" "MOLACOOH" "MOLCOON@" "COHCOOH@" "@B@CON@@" "D@@@O@@@" "F@B@@@@@" "@@B@@@@@" "@@@@@@@@" "@A@@@@@@" "@@@@@@@@" "H@@@@@@@" "L@@@@@@@" "N@@@@@@@" "N@@@@@@@" "O@@@@@@@" "O@@@@@@@" "O@@@@@@@" "O@@@@@@@" "O@@@@@@@" "O@@@@@@@" "N@@@@@@@" "N@@@@@@@" "L@@@@@@@" "H@@@@@@@" "@@@@@@@@" "@@@D@@@@" "@@@@@@@@" "@L@@@@@@" "@LAOL@@@" "@MIOL@@@" "@LOOO@@@" "AHOOO@@@" "AHOOO@@@" "N@OOO@@@" "N@GOO@@@" "@AOOL@@@" "@AOOH@@@" "L@CL@@@@" "@@DLD@@@" "AHF@L@@@" "AHF@H@@@" "IH@@H@@@" "IH@GA@@@" "@@@B@@@@" "@@@@B@@@" "@@@@GL@@" "@@BAOL@@" "@@@AOL@@" "@@@AOL@@" "@@@COL@@" "AN@GOL@@" "AN@GON@@" "@@@GON@@" "@@@GON@@" "@@@GON@@" "@@@CON@@" "D@@CON@@" "@@@CON@@" "@@@@ON@@" "@@@@C@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "AH@@@@@@" "AH@@@@@@" "GH@@@@@@" "OL@@@@@@" "OL@@@@@@" "OH@@@@@@" "O@@@@@@@" "N@@@@@@@" "L@@@@@@@" "L@@@@@@@")} 288 . 42) ({(READBITMAP)(48 24 "OKKDI@OOOOOL" "OOOIGEBJJJJO" "GGGCGOH@@@@A" "OJJLGAJJJJJK" "OKCDIDOOOOOO" "OOOH@@OOOOOO" "GGG@DHOOOOOO" "JJJL@DOOOOOO" "KKCDBLOOOOOO" "MOOHL@OOOOOO" "GGG@@IOOOOOO" "JJJLCEOOOOOO" "KCCE@IOOOOOO" "OOOHBAOOOOOO" "GGG@HIOOOOOO" "JJJLEAOOOOOO" "KCCEDIOOOOOO" "OOOHBAOOOOON" "GGGGGD@@@@@@" "JJJMNL@@@@@@" "KCCGCDAIL@C@" "OOOOMLCIL@C@" "GG@KGLCKKH@H" "JJ@NJHCCK@@H")} 240 . 84))) (40 (({(READBITMAP)(80 123 "@@@@@@@@@@@@@@@@@AH@" "@@@@@@@@@@@@@@@@AOH@" "@@@@@@@@@@@@@@@@AOL@" "@@@@@@@@@@@@@@@@AOL@" "@@@@@@@@@@@@@@@@COL@" "@@@@@@@@@@@@@@@@OO@@" "@@@@@@@@@@@@@@@CON@@" "@@@@@@@@@@@@@@@GOH@@" "@@@@@@@@@@@@@@@GO@@@" "@@@@@@@@@@@@@@@GN@@@" "@@@@@@@@@@@@@@AOL@@@" "@@@@@@@@@@@@@@COL@@@" "N@@@@@@@@@@@@@GOH@@@" "OL@@@@@@@@@@@@GOH@CL" "COH@@@@@@@@@@AON@@CL" "MON@@@@@@@@@@GOH@@CL" "GGO@@@@@@@@@@NF@@@OL" "OJKH@@@@@@@@@LD@@GOL" "OKOL@@@@@@@@FDH@AOON" "MMMN@@@@@@@@GI@LAOOO" "GGGO@@@@@@@@GH@L@OOO" "JJJOH@@@@@@AN@C@COOO" "KKKCL@@@@@@CHFC@AOOO" "OMOMN@@@@@@C@F@H@OOL" "GGGGG@@@@@@CF@AH@ON@" "JJJJK@@@@@@LF@@@@H@@" "KKKKC@@@@@@L@@@@@@@@" "OOMMOH@FL@@@@@@F@@@@" "GGGGGH@FL@@@@@@@@@@@" "JJJJKH@F@CA@@F@CK@@@" "KKKKCH@@@DC@AGOCK@@@" "MOOOMLAH@DC@AAO@@@@@" "GGGGGLAN@@L@@F@L@F@@" "NNNJJLAN@@L@@F@L@FF@" "KOCCCL@@AKL@@@@L@FN@" "MOOOON@FAOLAHGH@@GOL" "GGOGGF@FMLLAHGMLAOOL" "JMJJKN@FD@@C@CMLAOOH" "KOKCCF@@D@AK@OMIOOOH" "OOOOOF@L@@CH@MOIOOOL" "GMOGGN@L@@G@@MNGOOOH" "JOJJKN@LCHFAMOLGOON@" "KOKCBO@@ONGIMOLAOOL@" "OOOONO@ALOOKMOLCOO@@" "GOGGGO@ALAIKCOHCON@@" "JNJJJG@@@AAH@B@CL@@@" "KKKCCO@@@@@@@@@@@@@@" "OOOOOL@@@@@@@@@@@@@@" "GOGGGL@@@@@@@@F@@@@@" "OJJJNO@@@@@@@@FF@@@@" "OKKCA@OOOOOOL@@N@@@@" "OOOOKEBJJJJJO@@N@@@@" "GGGGCOH@@@@@AH@@@@@@" "OJJJKAJJJJJJKL@AH@@@" "OKCCADOOOOOOON@AL@@@" "OOOOH@OOOOOOON@AL@@@" "GGGGLHOOOOOOOO@@@@@@" "JJJKHDOOOOOOOO@@@@@@" "KKCCJLOOOOOOOO@@@@@@" "MOOOD@OOOOOOOO@@@@@@" "GGGGHIOOOOOOOO@@@@@@" "JJJKKEOOOOOOOO@@@@@@" "KCCBHIOOOOOOON@@@@@@" "OOOOJAOOOOOOON@@@@@@" "GGGG@IOOOOOOOL@AH@@@" "JJJKMAOOOOOOOH@AH@@@" "KCCBLIOOOOOOO@AH@L@@" "OOOOJAOOOOOON@AH@L@@" "GGGGGD@@@@@@@@@@@L@@" "JJJMNL@@@@@@@L@@@@@@" "KCCGCDAIL@C@@LAOH@@@" "OOOOMLCIL@C@@MHHH@@@" "GG@KGLCKKH@H@LL@L@@@" "JJ@NJHCCK@@HAHH@@@@@" "K@@GCHF@@GFHAHH@@@@@" "OLAMMHN@LMN@N@@@OH@@" "GFBOGHL@@ONDH@@OOH@@" "JJJJKH@@@LCN@@@OON@@" "KCGCC@@F@@CL@@@OON@@" "OMLMOAHF@ON@L@CMON@@" "GGGGGCL@@LN@@@DOON@@" "JJNKOLF@@@@@AHFCON@@" "KKCCOOF@@@@@AHFAON@@" "OMJLLCG@C@@AIH@CON@@" "GAOAMHCC@@@CIH@GOL@@" "J@JKMH@G@@@C@@@COH@@" "J@KCHF@@@AJ@@@@@B@@@" "NAEMHFCH@@I@FN@@@D@@" "GCOGALCH@@H@FNB@@@@@" "JKBKALG@@C@IH@@@@@@@" "KBKOAL@LGO@GOL@@@@@@" "OOMGAH@LF@FDIN@CAL@@" "GANNAHCMI@@@IN@DCN@@" "JAIF@@@CKL@CIN@DOOH@" "J@JL@@@AK@AH@@@@OOL@" "MCLL@AL@A@GHF@@@OOL@" "GMGL@ALD@LB@F@@@OOL@" "JJKH@@@D@L@H@@@@OON@" "KOOH@@@@A@@@@@@@OOOH" "MOGH@@@@A@@@@@@@OOOH" "EEO@@@@@@L@@@@@@OON@" "JKKH@@H@AL@L@@@DOOL@" "JKKH@@C@AK@C@@@DOOL@" "GGO@C@@N@B@@@@@AOOH@" "EEG@C@@@@D@@@@@@COH@" "JKN@C@@@@D@@@@@@COH@" "JKN@AHAH@N@@@@@@@@@@" "GGL@@IO@@DLH@@@@@@@@" "OEL@@OI@@D@@DH@@@@@@" "OKH@@@@@@@@@DL@@@@@@" "OKH@@@@@@@@DGL@@@@@@" "OGHAH@@@@@A@DH@@@@@@" "EG@ALGBDH@@@D@@@@@@@" "JK@@FGN@H@H@@@@@@@@@" "JN@@@AH@H@D@@GH@@@@@" "ON@@@AKD@ALHMOKH@@@@" "OD@@@@CF@AN@AOOH@@@@" "OL@@@@@@@ALAONF@@@@@" "JL@@@@@@@AOOOO@@@@@@" "OH@@@@@@@OOOOOH@@@@@" "OH@@@@@@@OOOOOH@@@@@" "O@@@@@@@@@@OOL@@@@@@" "O@@@@@@@@@@MN@@@@@@@")} 240 . 35))) (40 (({(READBITMAP)(96 129 "@@@@@@@@@@@@@@@@AOOH@@@@" "@@@@@@@@@@@@@@@@AOOO@@@@" "@@@@@@@@@@@@@@@@AOOO@@@@" "@@@@@@@@@@@@@@@@COOL@@@@" "@@@@@@@@@@@@@@@@OOO@@@@@" "@@@@@@@@@@@@@@@CON@@@@@@" "@@@@@@@@@@@@@@@GOH@@@@@@" "@@@@@@@@@@@@@@@GO@@@@@@@" "@@@@@@@@@@@@@@@CN@@@@@@@" "@@@@@@@@@@@@@@@@@@@OH@@@" "@@@@@@@@@@@@@@B@@@@ON@@@" "N@@@@@@@@@@@@@D@H@@ON@@@" "OL@@@@@@@@@@@@@GH@COH@@@" "COH@@@@@@@@@@A@N@@COL@@@" "MON@@@@@@@@@@F@H@@CON@@@" "GGO@@@@@@@@@@NF@@@OON@@@" "OJKH@@@L@@@@@LD@@AMON@@@" "OKOL@@@L@@@@FDH@AAOON@@@" "MMMN@@@@C@@@GI@LAAOOH@@@" "GGGO@@@@C@@@GH@L@AOOH@@@" "JJJOH@@@H@@AN@C@A@GO@@@@" "KKKCL@CL@@@CHFC@A@GO@@@@" "OMOMN@CN@@@C@FAH@@@D@@@@" "GGGGG@@@@F@CF@AH@CH@@@@@" "JJJJK@@@@F@LF@AH@@@@@@@@" "KKKKC@@@@@@L@@@GL@@@@@@@" "OOMMOH@@L@@@@AHOL@@@@@@@" "GGGGGH@F@@@@@AOOL@@@@@@@" "JJJJKH@D@CA@@OOOO@@@@@@@" "KKKKCH@@@DC@AOOOK@AIH@@@" "MOOOMLAH@DC@AAOOH@GON@@@" "GGGGGLAH@@L@@GOMHGOON@@@" "NNNJJLAN@@L@@FNL@GOON@@@" "KOCCCL@@@KL@@@@L@GOOL@@@" "MOOOON@@AOLAHGH@@GOOH@@@" "GGOGGF@FILL@@GMLAOOOH@@@" "JMJJKN@F@@@B@CMLAOOO@@@@" "KOKCCF@@@@AJ@OAIOOON@@@@" "OOOOOF@L@@B@@LCIOOOH@@@@" "GMOGGN@L@@@@@@BGOON@@@@@" "JOJJKN@LCH@@@@@GOOH@@@@@" "KOKCBO@@OLBAH@DAOL@@@@@@" "OOOONO@ALLBCH@DCN@@@@@@@" "GOGGGO@AL@AKCOHCB@@@@@@@" "JNJJJG@@@@AH@B@@@@@@@@@@" "KKKCCO@@@@@@@@@@@@@@@@@@" "OOOOOL@@@@@@@@@@@@@@@@@@" "GOGGGL@@@@@@@@@@@@@@@@@@" "OJJJNO@@@@@@@@@@@@@@@@@@" "OKKCFHOOOOOOOL@@@@@@@@@@" "OOOOMIBJJJJJJO@@@@@@@@@@" "GGGGGKH@@@@@@AH@@@@@@@@@" "OJJJMMJJJJJJJKL@@@@@@@@@" "OKCCFLOOOOOOOON@@@@@@@@@" "OOOOOHOOOOOOOON@@@@@@@@@" "GGGGK@OOOOOOOOO@@@@@@@@@" "JJJKOLOOOOOOOOO@@@@@@@@@" "KKCCMDOOOOOOOOO@@@@@@@@@" "MOOOCHOOOOOOOOO@@@@@@@@@" "GGGGOAOOOOOOOOO@@@@@@@@@" "JJJKLMOOOOOOOOO@@@@@@@@@" "KCCBOAOOOOOOOON@@@@@@@@@" "OOOOMIOOOOOOOON@@@@@@@@@" "GGGGGAOOOOOOOOL@@@@@@@@@" "JJJKJIOOOOOOOOH@@@@@@@@@" "KCCBKAOOOOOOOO@@@@@@@@@@" "OOOOMIOOOOOOON@@@@@@@@@@" "GGGGGD@@@@@@@@@@@@@@@@@@" "JJJMNL@@@@@@@@@@@@@@@@@@" "KCCGCDAIH@@@@@@@H@@@@@@@" "OOOOMLB@@@@@@@@HH@@@@@@@" "GG@KGLB@@@@@@@@@L@@@@@@@" "JJ@NJHB@A@@@AH@@@@@@@@@@" "K@@GCHF@@B@@AH@@@@@@@@@@" "OLAMMHN@H@@@@@@@@@@@@@@@" "GFBOGHL@@CBD@@L@@@@@@@@@" "JJJJKH@@@@CN@@O@@@@@@@@@" "KCGCC@@D@@AH@@CNAN@@@@@@" "OMLMOAHF@CH@L@@LAO@@@@@@" "GGGGGAL@@GN@@@@@GOH@@@@@" "JJNKOHD@AH@@AH@@OON@@@@@" "KKCCOID@AN@@AHDAOON@@@@@" "OMJLLCD@GN@AIH@COON@@@@@" "GAOAM@@COH@CIH@GOOL@@@@@" "J@JKMH@AH@@C@@@COOL@@@@@" "J@KCH@@C@AJ@@@@GOOL@@@@@" "NAEMH@AK@@I@FNAOOOL@@@@@" "GCOGAL@@@@H@FNCOOOH@@@@@" "JKBK@D@@@C@IH@@GO@@@@@@@" "KBKO@DC@GO@GOL@@@@@@@@@@" "OOMG@HC@F@FDIN@C@@@@@@@@" "GANN@@@EI@@@IN@DCB@@@@@@" "JAIF@@@CKL@CIN@DH@@@@@@@" "J@JL@@@AK@AH@@@@@@L@@@@@" "MCLL@AL@A@GHF@@@C@L@@@@@" "GMGL@ALD@LB@F@@@@CMH@@@@" "JJKH@@@D@L@H@@@@@COH@@@@" "KOOH@@@@A@@@@@@@@GOL@@@@" "MOGH@@@@A@@@@@@@IOOL@@@@" "EEO@@@@@@L@@@@@@AOOL@@@@" "JKKH@@@@AL@L@@@@COOL@@@@" "JKKH@@C@AK@C@@@DOOOL@@@@" "GGO@C@@N@B@@@@CIOOOH@@@@" "EEG@C@@@@D@@@@CHCOOH@@@@" "JKN@C@@@@D@@@@AHCOO@@@@@" "JKN@AHAH@N@@@@@@COO@@@@@" "GGL@@HG@@DLH@@@@GOO@@@@@" "OEL@@NA@@D@@DH@@GOL@@@@@" "OKH@@@@@@@@@DL@@CO@@@@@@" "OKH@@@@@@@@DGL@@@@@@@@@@" "OGHAH@@@@@A@DH@@@@@@@@@@" "EG@AL@BDH@@@D@@@@@@@@@@@" "JK@@F@N@H@H@@@@@@@@@@@@@" "JN@@@AH@H@D@@@@@@@@@@@@@" "ON@@@AKD@ALHMHCH@@@@@@@@" "OD@@@@CF@AB@@GOH@@@@@@@@" "OL@@@@@@@A@@@F@@@@@@@@@@" "JL@@@@@@@A@BA@@@@@@@@@@@" "OH@@@@@@@OL@F@@@@@@@@@@@" "OH@DHA@@@OLLF@H@@@@@@@@@" "O@@DDI@@@@@ACL@@@@@@@@@@" "O@@@AOL@@L@A@@CG@@@@@@@@" "N@@AAKLI@@@DL@CL@@@@@@@@" "N@@AAHIIH@@DAHOL@@@@@@@@" "L@@@@@@@@@@FGOOOH@@@@@@@" "L@@@@@@@@@COOOOO@@@@@@@@" "H@@@@@@@@@OOOOON@@@@@@@@" "H@@@@@@@@@OOOOON@@@@@@@@" "@@@@@@@@@@@CIKOL@@@@@@@@")} 240 . 28))) (40 (({(READBITMAP)(16 2 "H@@@" "H@@@")} 320 . 52) ({(READBITMAP)(16 4 "H@@@" "@@@@" "@@@@" "H@@@")} 320 . 151) ({(READBITMAP)(16 3 "N@@@" "N@@@" "L@@@")} 320 . 127) ({(READBITMAP)(80 128 "@@@@@@@@@@@@@@@@COOO" "@@@@@@@@@@@@@@@@@LOO" "@@@@@@@@@@@@@@@B@D@@" "@@@@@@@@@@@@@@@A@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@BD@@@" "@@@@@@@@@@@@@@@@@@@O" "@@@@@@@@@@@@@@B@@@@O" "N@@@@@@@@@@@@@D@H@@O" "OL@@@@@@@@@@@@@GK@CO" "COH@@@@@@@@@@A@NC@CO" "MON@@@@@@@FF@F@H@@CO" "GGO@@@@@@ANF@NF@@@OO" "OJKH@@@L@AN@@LD@@AMO" "OKOL@@@L@CF@FDH@AAOO" "MMMN@@@@CCF@GI@LAAOO" "GGGO@@@@CCF@GH@L@AOO" "JJJOH@@@H@@AN@C@A@GO" "KKKCL@CL@@@CHFC@A@GO" "OMOMN@CN@@@C@FAH@@@D" "GGGGG@@@@F@CF@AH@CH@" "JJJJK@@@@F@LF@AH@@@@" "KKKKC@@@@@@L@@@GL@@@" "OOMMOH@@L@@@@AHOL@@@" "GGGGGH@F@@@@@AOOL@OO" "JJJJKH@D@CA@@OOOO@OO" "KKKKCH@@@DB@AOOOKAOO" "MOOOMLAH@DB@AAOOHCOO" "GGGGGLAH@@L@@GOMHGOO" "NNNJJLAN@@@@@FNL@OOO" "KOCCCL@@@I@@@@@L@OOO" "MOOOON@@AIHAHGH@@GOO" "GGOGGF@FI@@@@GMLAOOO" "JMJJKN@F@@@B@CMLAOON" "KOKCCF@@@@AJ@OAIOOOH" "OOOOOF@L@@B@@LCIOOA@" "GMOGGN@L@@@@@@BF@@@@" "JOJJKN@LAH@@@@@D@@@@" "KOKCBO@@L@@@@@D@@@@@" "OOOONO@@H@@A@@D@@@@@" "GOGGGO@@H@@@@@@@@@@@" "JNJJJG@@@@@@@B@@@@@@" "KKKCCO@@@@@@@@@@@@@@" "OOOOOL@@@@@@@@@@@@@@" "GOGGGL@@@@@@@@@@@@@@" "OJJJNO@@@@@@@@@@@@@@" "OKKCFOAOOOOOOOO@@@@@" "OOOOMOIJJJJJJJKL@@@@" "GGGGGOI@@@@@@@@F@@@@" "OJJJMKAJJJJJJJJO@@@@" "OKCCFKAOOOOOOOOOH@@@" "OOOOOOAOOOOOOOOOH@@@" "GGGGKGAOOOOOOOOOL@@@" "JJJKOKAOOOOOOOOOL@@@" "KKCCMCAOOOOOOOOOL@@@" "MOOOCOAOOOOOOOOOL@@@" "GGGGOFAOOOOOOOOOL@@@" "JJJKLJAOOOOOOOOOL@@@" "KCCBOFAOOOOOOOOOH@@@" "OOOOMNAOOOOOOOOOH@@@" "GGGGGFAOOOOOOOOO@@@@" "JJJKJNAOOOOOOOON@@@@" "KCCBKFAOOOOOOOOL@@@@" "OOOOMNAOOOOOOOOH@@@@" "GGGGGD@@@@@@@@@@@@@@" "JJJMNL@@@@@@@@@@@@@@" "KCCGCD@@@@@@@@@@@@@@" "OOOOML@@@@@@@@@@@@@@" "GG@KGL@@@@@@@@@@@@@@" "JJ@NJH@@@@@@@@@@@@@@" "K@@GCHF@@@@@@@@@@@@@" "OLAMMHH@H@@@@@@@@@@@" "GFBOGH@@@@B@@@@@@@@@" "JJJJKH@@@@CN@@@@@@@@" "KCGCC@@@@@@@@@B@A@@@" "OMLMO@@@@CH@D@@@@@@@" "GGGGG@@@@F@@@@@@D@@@" "JJNKOH@@@@@@AH@@H@D@" "KKCCOI@@@B@@AHDA@@@@" "OMJLLC@@BD@AIH@CAO@@" "GAOAM@@@B@@CI@@FALN@" "J@JKMH@AH@@@@@@@G@N@" "J@KCH@@A@AJ@@@@DOCN@" "NAEMH@AK@@I@FNALLOO@" "GCOGAH@@@@H@BNACLOOL" "JKBK@@@@@C@L@@@CLOOL" "KBKO@DC@@D@DIL@@@OOL" "OOMG@HC@@@FL@F@ALOOL" "GANN@@@DA@@L@GHAIOOL" "JAIF@@@CKL@@HOH@HOGH" "J@JL@@@AK@@@@@@@AOOH" "MCLL@@D@A@DKB@@@COOH" "GMGL@@DD@LB@B@@@AOOH" "JJKH@@@D@L@HF@L@AOH@" "KOOH@@@@A@@@@@L@AH@@" "MOGH@@@@A@@@@@C@I@F@" "EEO@@@@@@L@@@@O@@ALB" "JKKH@@@@AL@L@@L@@ALN" "JKKH@@C@AK@C@@@@LAOO" "GGO@C@@N@B@@@@OILGOO" "EEG@C@@@@D@@@@OHBCOO" "JKN@C@@@@D@@@@MHBCOO" "JKN@AHAH@N@@@@L@AOOO" "GGL@@HG@@DLH@@L@AOOO" "OEL@@NA@@D@@DH@@EOON" "OKH@@@@@@@@@DLL@COOL" "OKH@@@@@@@@DGLL@GMOL" "OGHAH@@@@@A@DHL@OOOL" "EG@AL@BDH@@@D@LAMOOL" "JK@@F@N@H@H@@@@AMOOL" "JN@@@AH@H@D@@@LAOOOH" "ON@@@AKD@ALHMHOIOON@" "OD@@@@CF@AB@@GOH@CL@" "OL@@@@@@@A@@@F@@@C@@" "JL@@@@@@@A@BA@@@@C@@" "OH@@@@@@@OL@F@@@@C@@" "OH@DHA@@@OLLB@@@@@@@" "O@@DDI@@@@@AC@@@@@@@" "O@@@AOL@@L@A@@@G@@@@" "N@@AAKLI@@@@@@AL@@@@" "N@@AAHIIH@@@@@GH@@@@" "L@@@@@@@@@@@@ABAH@@@" "L@CC@@@@@@@D@IBG@@@@" "H@CCL@@@@@@LOION@@@@" "H@@COH@@@@OOOOON@@@@" "@@@@CH@@@@COOOOL@@@@" "@@@@AH@@@@GOOOOL@@@@" "@@@@@@@@@@GOOOO@@@@@")} 240 . 26))) (40 (({(READBITMAP)(16 1 "@@@@")} 320 . 53) ({(READBITMAP)(32 4 "L@@@@AO@" "L@CC@AO@" "H@COL@C@" "H@AOOHC@")} 240 . 29) ({(READBITMAP)(64 88 "FO@AOOOOOOOO@@@@" "MOFIJJJJJJJKL@@@" "GOFI@@@@@@@@F@@@" "MKFAJJJJJJJJO@@@" "FKFAOOOOOOOOOH@@" "OOAIOOOOOOOOOH@@" "KGAIOOOOOOOOOL@@" "OK@AOOOOOOOOOL@@" "MC@AOOOOOOOOOL@@" "COAIOOOOOOOOOL@@" "OFAIOOOOOOOOOL@@" "LJ@AOOOOOOOOOL@@" "OF@AOOOOOOOOOH@@" "MN@AOOOOOOOOOH@@" "GFCAOOOOOOOOO@@@" "JNGIOOOOOOOON@@@" "KFGIOOOOOOOOL@@@" "MNCIOOOOOOOOH@@@" "GDAH@@@@@@@@@@@@" "NL@@@@@@@@@@@@@@" "CD@@@@@@@@@@@@@@" "ML@@@@@@@@@@@@@@" "GL@@@@@@@@@@@@@@" "JH@@@@@@@@@@@@@@" "CHF@@@@@@@@@@@@@" "MHH@H@@@@@@@@@@@" "GH@@@@B@@@@@@@@@" "KH@@@@CN@AH@@@@@" "C@@@@@@@@AJ@A@@@" "O@@@@CH@D@@@@@@@" "G@@@@F@@@@@@D@@@" "OH@@@@@@AH@@H@D@" "OI@@@B@@AHDA@@@@" "LC@@BD@AIH@C@G@@" "M@@@B@@AI@@F@D@@" "MH@AH@@@@@@@@@B@" "H@@A@AJ@@@@@GC@@" "H@AK@@I@FN@DLI@@" "AH@@@@H@BN@CLA@@" "@@@@@C@L@@@CL@A@" "@DC@@D@DHD@@@@GN" "@HC@@@FL@D@AL@ON" "@@@DA@@L@D@AHCON" "@@@CKL@@HN@@HGGN" "@@@AK@@@@@@@@CON" "@@D@A@DCB@@@ACON" "@@DD@LB@B@@@AOON" "@@@D@L@@F@@@AOON" "@@@@A@@@@@@@@GOO" "@@@@A@@@@@C@HGOO" "@@@@LO@@@@O@@GOO" "@@@@MOHL@@L@@AOL" "@@C@AKHC@@@@LAOH" "C@@N@CH@@@LILAHA" "C@@@@D@@@@OHBAIA" "C@@@@D@@@@MHB@@@" "AHAHFON@@@L@AH@H" "@HG@FENH@@L@@@GA" "@NA@@G@@DH@@@@O@" "@@@@@C@@DLL@@GOL" "@@@@@@@DGLL@@EOL" "H@@@F@A@DHL@DGOL" "L@BDN@@@D@L@LGOL" "F@N@O@N@@@@AMOOL" "@AH@O@N@@@L@GOOH" "@AKD@ALHMHOHGOOH" "@@CF@AB@@GOHOKOH" "@@@@@A@@@F@@OOOH" "@@@@@A@BA@@@GOOH" "@@@@@OL@F@@@GOMH" "HA@@@OLLB@@@@@@@" "DI@@@@@AC@@@@@@@" "AOL@@L@A@@@G@@@@" "AKLI@@@@@@@@@@@@" "AHIIH@@@@@@@@@@@" "@AO@@@@@@@@AH@@@" "@AO@@@@@@A@C@@@@" "L@C@@@@@@@CN@@@@" "OHC@@@@@@HGN@@@@" "CH@@@@B@OHOL@@@@" "AH@@@@GOOOOL@@@@" "@@@@@@GOOOO@@@@@" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "@@@@@GOOOON@@@@@" "@@@@@@OOOOL@@@@@" "@@@@@@OOOOL@@@@@" "@@@@@@COOO@@@@@@")} 256 . 20))) (40 (({(READBITMAP)(80 116 "@@@@@@@@F@@BD@@@@@@@" "@@@@@F@FF@@@@@@OH@@@" "@@@@@F@FF@B@@@@ON@@@" "@@@@@@@@F@D@H@@ON@@@" "@@@@@@@@F@@GK@COH@@@" "@@@@@@@@GA@NC@COL@@@" "@@@@@@FFCF@H@@CON@@@" "@@@@@ANF@NF@@@OON@@@" "@@@L@AN@@LDC@AMON@@@" "@@@L@CF@FDHCAAOON@@@" "@@@@CCF@GI@LAAOOH@@@" "@@@@CCF@GH@L@AOOH@@@" "H@@@H@@AN@C@A@GO@@@@" "L@CL@@@CHFC@CNGO@@@@" "N@CN@@@C@FANGN@D@@@@" "G@@@@F@CF@ANGCH@@@@@" "K@@@@F@LF@GNFAH@@@@@" "C@@@@@@L@@GONAH@@@@@" "OH@@L@@@@AHONGH@@@@@" "GH@F@@@@@AOOLGOON@@@" "KH@D@CA@@OOIO@OON@@@" "CH@@@DB@AO@IKAOOL@@@" "MLAH@DB@AA@B@COON@@@" "GLAH@@L@@A@@@GOON@@@" "JLAN@@@@@@@@@OOON@@@" "CL@@@I@@@@@L@OOOL@@@" "ON@@AIHAHGH@@GOOH@@@" "GF@FI@@@@GMLAOOOH@@@" "KN@F@@@B@CMLAOON@@@@" "CF@@@@AJ@OAIOOOH@@@@" "OF@H@@B@@LCIOOA@@@@@" "GN@@@@@@@@BF@@@@@@@@" "KN@@@@@@@@@D@@@@@@@@" "BO@@@@@@@@@@@@@@@@@@" "NO@@@@@A@@@@@@@@@@@@" "GO@@@@@@@@@@@@@@@@@@" "JG@@@@@@@@@@@@@@@@@@" "CO@@@@@@@@@@@@@@@@@@" "OL@@@@@@@@@@@@@@@@@@" "GL@@@@@@@@@@@@@@@@@@" "NO@@@@@@@@@@@@@@@@@@" "FO@@@OOOOOOOOH@@@@@@" "MOF@DMEEEEEEEN@@@@@@" "GOF@DH@@@@@@@C@@@@@@" "MKFC@MEEEEEEEGH@@@@@" "FKFC@OOOOOOOOOL@@@@@" "OO@CLOOOOOOOOOL@@@@@" "KG@CLOOOOOOOOON@@@@@" "OK@C@OOOOOOOOON@@@@@" "MC@@@OOOOOOOOON@@@@@" "CO@@LOOOOOOOOON@@@@@" "OF@FLOOOOOOOOON@@@@@" "LJ@N@OOOOOOOOON@@@@@" "OF@L@OOOOOOOOOL@@@@@" "MN@@@OOOOOOOOOL@@@@@" "GFB@HOOOOOOOOOH@@@@@" "JNF@LOOOOOOOOO@@@@@@" "KFFLLOOOOOOOON@@@@@@" "MNBOLOOOOOOOOL@@@@@@" "GD@OL@@@@@@@@@@@@@@@" "NL@@@@@@@@@@@@@@@@@@" "CD@@@@@@@@@@@@@@@@@@" "ML@@@@@@@@@@@@@@@@@@" "GL@@@@@@@@@@@@@@@@@@" "JH@@@@@@@@@@@@@@@@@@" "CHF@@@@@@@@@@@@@@@@@" "MHH@H@@@@@@@@@@@@@@@" "GH@@@@@@@@@@@@@@@@@@" "KH@@@@@H@@@@@@@@@@@@" "C@@@@@@@@@H@@@@@@@@@" "O@@@@B@@@@@@@@@@@@@@" "G@@@@@@@@@@@@@@@@@@@" "OH@@@@@@@@@@@@@@@@@@" "OI@@@B@@A@@A@@@@@@@@" "LA@@@D@AH@@A@@@@@@@@" "M@@@@@@AH@@F@@@@@@@@" "M@@@@@@@@@@@@@B@@@@@" "H@@A@@B@@@@@F@@@@@@@" "H@@K@@A@@D@@@A@@@@@@" "@@@@@@H@@H@@@@@@@@@@" "@@@@@C@D@@@@@@@@@@@@" "@DC@@D@@HD@@@@@@@@@@" "@@A@@@@@@D@@@@@@@@@@" "@@@DA@@D@D@@HCHHL@@@" "@@@@IL@@HF@@H@AHL@@@" "@@@@C@@@@DF@@@HOL@@@" "@@@@A@@CC@F@@@HON@@@" "@@DD@@B@A@@@@LION@@@" "@@@D@@@@@@@@A@AON@@@" "@@@@@@@@@A@@@@CON@@@" "@@@@@@@@@GC@HDCON@@@" "@@@@LO@@@FC@@GCON@@@" "@@@@LAHL@@@@@ACON@@@" "@@C@@@@C@O@@LAOON@@@" "C@@N@B@@@OMIL@CON@@@" "C@@@@D@@@AOHB@CON@@@" "C@@@@@@AH@MHB@AMH@@@" "AH@HD@DAH@MHAH@L@@@@" "@HD@FELHF@MHAHGM@@@@" "@NA@@G@@FNL@L@A@@@@@" "@@@@@C@@DNLANFAH@@@@" "@@@@@@@DGLLAO@CH@@@@" "H@@@F@A@FHL@G@A@@@@@" "L@BDN@@MN@L@L@AB@@@@" "F@N@O@NMH@CAL@CN@@@@" "@AH@O@O@AHO@@DON@@@@" "@AKD@GOHMIOH@@ON@@@@" "@@CF@GBAIOOH@COO@@@@" "@@@@@A@AIN@@@GOO@@@@" "@@@@@A@BA@@@DGOOH@@@" "@@@@LOL@F@@@@OMOH@@@" "HAF@LOLLB@@@@GOOH@@@" "DIF@@@@AC@@@@GOOH@@@" "AOL@@L@A@@@F@AOO@@@@" "AKLI@@@@@@@@@@ON@@@@" "AHIIH@@@@@@@@@OL@@@@")} 256 . 33))) (40 (({(READBITMAP)(16 2 "OH@@" "L@@@")} 256 . 74) ({(READBITMAP)(64 130 "@@@@@@@@@GH@@@@@" "@@@@@@@@AOOH@@@@" "@@@@@@@O@NOON@@@" "@@@@@@@OGCNDN@@@" "@@@@@@@NGCND@@@@" "@@@@@@@AOOOO@@@@" "@@@@@@@CLD@@H@@@" "@@G@CB@A@@@@@@@@" "@AO@BB@@@@COH@@@" "@CH@B@@BD@GOL@@@" "@N@@G@@@@ANOL@@@" "AN@@D@B@@AHON@@@" "AH@@D@D@HAHNN@@@" "@@@@A@@GKAINL@@@" "@@@@AA@NCAIIL@@@" "@@FDBF@H@AKBF@@@" "@ABF@@F@@@OBF@@@" "@AB@@HDC@AM@F@@@" "@CB@FDHCAAOAN@@@" "CCB@GH@LAAOOL@@@" "CCF@GH@L@AOOL@@@" "H@@AC@@@A@GO@@@@" "@@@C@FC@@IOO@@@@" "@@@C@F@FDOIO@@@@" "@F@CF@@FGCH@AK@@" "@F@LF@GNFAH@AK@@" "@@@LA@AOLAH@@@@@" "L@@@AAHGLGH@@@@@" "@@@@@A@GLGOONCL@" "@CA@@OAII@OONCL@" "@DB@AO@IIAOOLC@@" "@DB@AALB@COLNC@@" "@@L@CAL@@GOLNC@@" "@@@@C@LAHOLON@@@" "@I@@@CLAHOLOL@@@" "AIHAAGH@@GOOHC@@" "I@@@@GLLAOCOHG@@" "@@@B@CLLAOCN@F@@" "@@AJCOAIOOOH@@@@" "@@BCCLCIOOA@@@@@" "@@@C@@BF@@@@@@@@" "@@@@@@@D@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@A@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@OOOOOOOOH@@@@@" "@DMEEEEEEEN@@@@@" "@DH@@@@@@@C@@@@@" "@@MEEEEEEEGH@@@@" "C@OOOOOOOOOL@@@@" "CLOOOOOOOOOL@@@@" "@LOOOOOOOOON@@@@" "@@OOOOOOOOON@@@@" "@@OOOOOOOOON@@@@" "@LOOOOOOOOON@@@@" "LLOOOOOOOOON@@@@" "L@OOOOOOOOON@@@@" "L@OOOOOOOOOL@@@@" "@@OOOOOOOOOL@@@@" "@HOOOOOOOOOH@@@@" "@LOOOOOOOOO@@@@@" "@LOOOOOOOON@@@@@" "@LOOOOOOOOL@@@@@" "@L@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "H@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@" "@@@A@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@B@@@@@" "@@B@@@@@F@@@@@@@" "@@@@@D@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@C@D@@@@@@@@@@@@" "@@@@@D@@@@@@@@@@" "@@@@@D@@@@@@@@@@" "@@@D@D@@HCHHD@@@" "HL@@@F@@H@@HD@@@" "C@@@@DD@@@H@@@@@" "A@@CC@D@@@H@B@@@" "@@B@@@@@@LH@F@@@" "@@@@@@@@A@@IN@@@" "@@@@@@@@@@@ON@@@" "@@@@@DB@HD@OO@@@" "LO@@@@B@@FAOO@@@" "LAHL@@@@@@AOO@@@" "@@@C@O@@L@OOO@@@" "@B@@@OMIL@COO@@@" "@D@@@AOHB@COO@@@" "@@@AH@MHB@GOO@@@" "D@DAH@MHAHGOO@@@" "FELHF@MHAHGOO@@@" "@G@@FNL@L@AAO@@@" "@C@@DNLANFAIO@@@" "@@@DGLLAO@AHN@@@" "F@A@FHL@G@A@@@@@" "N@@MN@L@L@A@@@@@" "O@NMH@CAL@@H@@@@" "O@O@AHO@@D@H@@@@" "@GOHMIOH@@ABA@@@" "@GBAIOOH@BAOA@@@" "@A@AIN@@@@COH@@@" "@A@BA@@@D@CKH@@@" "LOL@F@@@@BCOH@@@" "LOLLB@@@@BGON@@@" "@@@AC@@@@@GON@@@" "@L@A@@@F@@OON@@@" "@@@@@@@@@@OOL@@@" "H@@@@@@@@@OOL@@@" "@@@@@@@AH@OOL@@@" "@@@@@A@C@@OOL@@@" "@@@@@@CN@@OOH@@@" "@@@@@HGN@@AO@@@@" "@@B@OHOL@@AL@@@@")} 272 . 28))) (40 (({(READBITMAP)(48 31 "OH@@@@@@@@@@" "L@@@@@@A@@@@" "M@@@@@@@@@@@" "M@@@@@@@@@@@" "H@@A@@@@@@@@" "H@@@@@@@@D@@" "@@@@@@@@@@@@" "@@@@@B@D@@@@" "@@@@@@@@@@@@" "@@A@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@L@@@@@@" "@@@@A@@@@D@@" "@@@@A@@CB@D@" "@@D@@@@@@@@@" "@@@D@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@DB@" "@@@@LO@@@@B@" "@@@@LAHL@@@@" "@@C@@@@C@O@@" "C@@N@B@@@OLA" "C@@@@D@@@AO@" "C@@@@@@@@@IH" "AH@H@@D@@@IH" "@HD@@ALHF@EH" "@NA@@G@@FLD@" "@@@@@C@@D@LA" "@@@@@@@DD@LA" "H@@@B@A@DHL@" "L@B@N@@MN@L@")} 256 . 45) ({(READBITMAP)(32 19 "FO@@C@@O" "MOF@C@DM" "GOF@@CDH" "MKFCAO@M" "FKFCCO@O" "OO@CCFLO" "KG@C@@LO" "OK@O@@@O" "MC@L@@@O" "CO@@@LLO" "OFANLLLO" "LJANLL@O" "OFALL@@O" "MN@@@@@O" "GFB@@@HO" "JNF@C@LO" "KFFLC@LO" "MNBO@@LO" "GD@O@@L@")} 256 . 89) ({(READBITMAP)(32 82 "OOOH@@@@" "EEEN@@@@" "@@@C@@@@" "EEEGH@@@" "OOOOL@@@" "OOOOL@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOOL@@@" "OOOOL@@@" "OOOOH@@@" "OOOO@@@@" "OOON@@@@" "OOOL@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "F@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "HCH@D@@@" "H@@@D@@@" "@@H@@@@@" "@@@@B@@@" "@@@@B@@@" "A@@@B@@@" "@@@AB@@@" "HD@@BC@@" "@FAHBC@@" "@@@OCO@@" "L@@DCO@@" "L@@@OO@@" "@@@@OO@@" "B@AAOO@@" "AHCAON@@" "AHCOON@@" "L@AAON@@" "L@AKON@@" "L@AOON@@" "G@AOON@@" "L@AIOL@@" "L@@H@@@@" "@D@H@@@@" "@@A@@@@@" "@BA@@@@@" "@@@@@@@@" "D@@@@@@@" "@B@CH@@@" "@B@ON@@@" "@@@ON@@@" "@@OON@@@" "@@OOL@@@" "@@OOO@@@" "H@OOOH@@" "@@OOOH@@" "@@OOOH@@" "@@OOO@@@" "@@COO@@@" "@@FON@@@" "@@GOL@@@")} 304 . 26) ({(READBITMAP)(80 42 "@@@@@@@O@FOOOH@@@@@@" "@@@@@@LODCNDON@@@@@@" "@@@@L@LNGCND@F@@@@@@" "@@@@L@GMOOOOCF@@@@@@" "@@@@@@GOLD@@K@@@@@@@" "@@G@CB@A@@@@@@L@@@@@" "@AO@BB@@@@COH@L@@@@@" "@CK@B@@BD@GOL@@@@@@@" "@NC@G@@@@ANOO@@@@@@@" "AN@@D@B@@GHOOF@@@@@@" "AH@@D@D@IOHNNF@@@@@@" "@@@@A@@GKIINLF@@@@@@" "@@@@AA@NCAIILF@@@@@@" "@@FDBF@KHAKBFF@@@@@@" "@ABF@@FCH@OBFF@@@@@@" "@AB@@HDC@AM@F@F@@@@@" "@CB@FDHCAAOAN@F@@@@@" "CCB@GH@LAAOOLNF@@@@@" "CCF@GH@L@AOOLN@@@@@@" "H@@AC@@@A@DC@@@@@@@@" "@@@C@FC@@ILC@@@@@@@@" "@@@C@F@FDOIO@@@@@@@@" "@F@CF@@FGCHAIK@F@@@@" "@F@LF@GNFAHAKO@G@@@@" "@@@LA@AOLAH@CL@C@@@@" "L@@@AAHGLGH@CL@@@@@@" "@@@@@A@GLGOLNCL@@@@@" "@CA@@OAII@GLNCMH@@@@" "@DB@AO@II@GOLCGH@@@@" "@DB@AALBCCOLNCFAH@@@" "@@L@CAL@CGOLNC@AH@@@" "@@@@C@LAHLDONC@@@@@@" "@I@@@CLAHLDLNC@@@@@@" "AIHAAGH@@GOLLC@@@@@@" "I@@@@GLLAOCOHG@GL@@@" "@@@B@CLLAO@GHF@GL@@@" "@@AJCOAIOOLGN@@@@@@@" "@@BCCLCIOOA@F@@@@@@@" "@@@C@@BF@@@CHOL@@@@@" "@@@@@@@D@F@CHOL@@@@@" "@@@@@@L@LF@@@@@@@@@@" "@@@A@@L@L@@@@@@@@@@@")} 272 . 114))) (40 (({(READBITMAP)(16 6 "L@GH" "N@FA" "FC@A" "FC@@" "BC@@" "@C@@")} 320 . 122) ({(READBITMAP)(16 2 "GH@@" "GH@@")} 288 . 137) ({(READBITMAP)(16 52 "@FOC" "DCN@" "DCND" "COON" "@D@@" "@@@@" "@@CN" "D@GL" "@ANL" "@GHL" "IOHN" "KIHL" "CAAH" "HAA@" "H@A@" "@AM@" "A@IA" "@@IO" "@ANG" "A@@C" "@I@C" "DOIO" "DCHA" "@AHA" "HAH@" "LDH@" "L@OL" "I@GL" "I@GL" "CCOL" "CGND" "HDDB" "HDD@" "@GL@" "ACAC" "@C@G" "LCLG" "OOA@" "@@@C" "@F@C" "LF@@" "L@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "OOOO" "EEEE" "@@@@" "EEEE")} 304 . 104) ({(READBITMAP)(32 17 "@@L@C@@@" "@@L@C@@@" "D@@@@@@@" "O@@@@@@@" "OFAH@@@@" "NFAK@@@@" "LF@C@@@@" "LF@@@@@@" "FF@@AH@@" "@F@@AH@@" "@@F@@@@@" "N@FCL@@@" "LNFCL@@@" "LN@@@@@@" "@@@@@@@@" "@@@@@F@@" "@@@@@F@@")} 320 . 134) ({(READBITMAP)(80 81 "FO@@C@@@OOOOOOOOH@@@" "MOF@C@@DMEEEEEEEN@@@" "GOF@@@@D@@@@@@@@C@@@" "MKF@@HL@EEEEEEEEGH@@" "FKFA@OH@OOOOOOOOOL@@" "OO@DMCIDGOOOOOOOOL@@" "KG@DL@ADGOOOOOOOON@@" "OJ@H@@@@OOOOOOOOON@@" "MB@@@@A@OOOOOOOOON@@" "CO@@LLCDOOOOOOOOON@@" "OFA@LH@DOOOOOOOOON@@" "LJAHL@C@OOOOOOOOON@@" "OFAH@CC@OOOOOOOOOL@@" "MN@@@@C@OOOOOOOOOL@@" "GF@@@@C@OOOOOOOOOH@@" "JNF@C@@DOOOOOOOOO@@@" "KFDDC@@DOOOOOOOON@@@" "MN@D@@HDOOOOOOOOL@@@" "GD@L@AHD@@@@@@@@@@@@" "NL@@@AH@@@@@@@@@@@@@" "CD@@@@@@@@@@@@@@@@@@" "ML@@@@@@@@@@@@@@@@@@" "GL@@@@@@@@@@@@@@@@@@" "JH@@@@@@@@@@@@@@@@@@" "CHF@@@@@@@@@@@@@@@@@" "MHH@H@@@@@@@@@@@@@@@" "GH@@@@@@@@@@@@@@@@@@" "KH@@@@@@@@@@@@@@@@@@" "C@@@@@@@@@@@@@@@@@@@" "O@@@@@@@@@@@@@@@@@@@" "G@@@@@@@@@@@@@@@@@@@" "OH@@@@@@@@@@@@@@@@@@" "OH@@@@@@@@@@@@@@@@@@" "L@@@@@@A@@@@@@@@@@@@" "M@@@@@@@@@@@@@@@@@@@" "M@@@@@@@@@@@@@@@@@@@" "H@@A@@@@@@@@F@@@@@@@" "H@@@@@@@@D@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@B@D@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@A@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@HCH@D@@@" "@@@@@L@@@@@@H@@@@@@@" "@@@@A@@@@D@@@@H@@@@@" "@@@@A@@C@@D@@@@@B@@@" "@@D@@@@@@@@@@@@@B@@@" "@@@D@@@@@@@@@@@@B@@@" "@@@@@@@@@@@@@@@@B@@@" "@@@@@@@@@@B@HD@@B@@@" "@@@@LO@@@@B@@@AHB@@@" "@@@@LAHL@@@@@@@L@A@@" "@@A@@@@C@O@@L@@D@O@@" "C@@N@@@@@LH@@@@@@C@@" "C@@@@D@@@@@@@@@@@CL@" "B@@@@@@@@@AHB@A@AOL@" "@@@@@@D@@@AHAHA@@NL@" "@@D@@AL@@@AHAH@@DOL@" "@L@@@G@@@@@@L@@AAOL@" "@@@@@C@@D@HAL@@AAOL@" "@@@@@@@@D@H@D@@CAOL@" "H@@@B@@@D@@@@@@OIOL@" "L@B@N@@@N@@@H@@AOOL@" "F@N@O@NAH@CAL@@@COL@" "@AH@O@O@AHO@@D@HCOL@" "@AKD@GOHMIOH@@A@COL@" "@@CF@GBAIOOH@BA@GKH@" "@@@@@A@AIN@@@@@@GOH@" "@@@@@A@BA@@@D@@@GN@@" "@@@@LOL@F@@@@B@BAH@@" "HAF@LOLLBAH@@B@N@@@@" "DIF@@@@MCAN@@@@@@@@@" "AOL@@N@A@@FGHLH@@@@@" "AKLI@FGO@@@AHL@A@@@@" "AHIIH@GO@@@@@@@A@@@@" "@AO@@@@@@@@AH@DCH@@@" "@AO@@@@@@A@C@@DOL@@@" "L@C@@@@@@@CN@@OOL@@@" "OHC@@@@@@HGN@@OOO@@@" "CH@@@@B@OHOL@@COO@@@" "AH@@@@GOOOOL@@GON@@@")} 256 . 27))) (40 (({(READBITMAP)(96 50 "JJNKO@@@@@@@@@@@@@@@@@@@" "KKCCN@@@@@@@@@@@@@@@@@@@" "OMJLL@@@@@@@@@@@@@@@@@@@" "GAOAL@@@@@@@@@@@@@@@@@@@" "J@JKL@@@@@@@@@@@@@@@@@@@" "J@KCH@@@@@@@@@@@@@@@@@@@" "NAEMH@@@@@@@@@@@@@@@@@@@" "GCOG@@@@@@@@@@@@@@@@@@@@" "JKBK@@@@@@@@@@@@@@@@@@@@" "KBKO@@@@@@@@@@@@@@@@@@@@" "OOMG@@@@@@@@@@@@@@@@@@@@" "GANN@@@@@@@@@@@@@@@@@@@@" "JAIF@@@@@@@@@@@@@@@@@@@@" "J@JL@@@@@@@@@@@@@@@@@@@@" "MCLL@@@@@@@A@@D@@@@@@@@@" "GMGL@@D@@@@@@@@@@@@@@@@@" "JJKH@@@D@@@@@@@@@@@@@@@@" "KOOH@@@@@@@@@@@@@@@@B@@@" "MOGH@@@@@@@@@@@@HD@@@@@@" "EEO@@@@@L@@@@@B@@@@@@@@@" "JKKH@@@@LAHL@@@@@@@@@@@@" "JKKH@@A@@@@A@O@@L@@@@@@@" "GGO@C@@N@@@@@LH@@@@@@@@@" "EEG@C@@@@D@@@@@@@@@@@@H@" "JKN@B@@@@@@@@@AHB@A@AH@@" "JKN@@@@@@@D@@@AHAHA@@@@@" "GGL@@@D@@AL@@@AHAH@@@@@@" "OEL@@L@@@D@@@@@@D@@@@D@@" "OKH@@@@@@@@@D@H@D@@AA@N@" "OKH@@@@@@@@@D@H@D@@CA@N@" "OGHAH@@@B@@@D@@@@@@OI@N@" "EG@AL@B@N@@@N@@@H@@@F@N@" "JK@@F@N@O@NAH@AAL@@@BGOH" "JN@@@AH@G@O@A@I@@D@H@GOH" "ON@@@AK@@GN@IACH@@A@@GOH" "OD@@@@@@@CB@@LB@@BA@CKOH" "OL@@@@@@@A@@@L@@@@@@COO@" "JL@@@@@@@A@BA@@@D@@@@OO@" "OH@@@@@@@HL@@@@@@B@B@KO@" "OH@DHA@@@H@@@@@@@B@N@OO@" "O@@DD@@@@@@EB@B@@@@@@ON@" "O@@@@@H@@N@A@@FGHLH@CON@" "N@@A@@HI@FGO@@@AHL@@COL@" "N@@A@@@IH@GO@@@@@@@@@OL@" "L@@@@@@@@@@@@@@AH@@@@O@@" "L@C@@@@@@@@@@A@C@@@@@@@@" "H@B@@@@@@@@@@@CN@@@L@@@@" "H@@@B@@@@@@@@HGN@@DL@@@@" "@@@@B@@@@@B@OHOL@@COH@@@" "@@@@@@@@@@GOOOOL@@GOL@@@")} 240 . 27) ({(READBITMAP)(96 68 "@@@@@@@@@@@@@DEH@@@@@@@@" "@@@@@@@@@@@O@BOCH@@@@@@@" "@@@@@@@@@@LHDCJ@KN@@@@@@" "@@@@@@@@L@LDD@FD@B@@@@@@" "@@@@@@@@L@CEC@NDCF@@@@@@" "@@@@@@@@@@GO@@@@K@@@@@@@" "@@@@@@G@CB@A@@@@@@L@C@@@" "@@@@@AO@BB@@@@AN@@L@C@@@" "@@@@@CK@B@@BD@DH@@@@@@@@" "@@@@@NC@G@@@@@JLI@@@@@@@" "@@@@AN@@D@B@@EHHGDAH@D@@" "@@@@AH@@D@D@IOHNNFAI@@@@" "@@@@@@@@A@@FKHHLHF@C@@@@" "@@@@@@@@AA@NCAAHLF@@@D@@" "@@@A@@FDBF@KHAA@FF@@AH@@" "@@@@DEBF@@FCH@A@@F@@AH@@" "@@@L@AB@@HDC@AM@@@F@@@@@" "@@@L@CB@FDHCA@IAN@DCLAB@" "@@@@CCB@GH@@@@IO@BFCL@@@" "@@@@CCF@GH@@@AFGLN@@@@@@" "H@@@H@@AC@@@A@@C@@@@@@@@" "L@CL@@@C@FC@@I@B@@@@@F@@" "N@CN@@@C@F@FDOII@@@@@F@@" "G@@@@F@CF@@FDB@@AK@F@@@@" "K@@@@F@LF@GN@A@AKC@G@@@@" "C@@@@@@LA@AOHAH@CL@C@@@@" "OH@@L@@@AAHGLDH@CL@@@@@@" "GH@F@@@C@A@FL@OLNCL@@@@@" "KH@D@CA@@OAIH@EHNCMH@A@@" "CH@@@DB@AO@AI@AH@@GH@@A@" "MLAH@DB@AALBCAKLB@FAH@A@" "GLAH@@L@CAL@AGJDFC@AH@A@" "JLAN@@@@C@@AHDD@FC@@@D@@" "CL@@@I@A@CL@@DD@BC@@@@@@" "ON@@AIHAAF@@@DD@@C@@@@A@" "GF@FI@@@@CHDAAACHC@GL@@@" "KN@F@@@B@CDL@C@GHF@EL@@@" "CF@@@@AJCOAILCHGN@@AE@M@" "OF@I@@BCCLCIOOA@F@@D@@@@" "GN@@@@HC@@BF@@@CHAD@@@@@" "KN@@@A@@@@@D@F@C@GL@@@@@" "BO@@@L@@@@L@LF@@@@@@@@@@" "NO@@@@@A@@L@L@@@@@@@D@@@" "GO@@@@@@@@@@@@@@@@@@@@@@" "JG@@@@@@@@@@@@@@@@@@@@@@" "CO@@@@D@@@@@@@@@@@@@@@@@" "OL@@@@@@@@@@@@@@@@@@@@@@" "GL@@@@@@@@@@@@@@@@@@@@@@" "NO@@@@@@@@@@@@@@@@@@@@@@" "FO@@C@@@@OOOOOOOOH@@@@@@" "MOF@C@@@DMEEEEEEEN@@@@@@" "GOF@@@@@D@@@@@@@@C@@@@@@" "MKF@@HD@@EEEEEEEEGH@@@@@" "FKFA@GH@@OOOOOOOOOL@@@@@" "OO@DLCA@DGOOOOOOOOL@@@@@" "KG@DL@A@DGOOOOOOOON@@@@@" "OJ@H@@@@@OOOOOOOOON@@@@@" "MB@@@@A@@OOOOOOOOON@@@@@" "CO@@LHC@DOOOOOOOOON@@@@@" "OFA@LH@@DOOOOOOOOON@@@@@" "LJAHL@A@@OOOOOOOOON@@@@@" "OFAH@CC@@OOOOOOOOOL@@@@@" "MN@@@@C@@OOOOOOOOOL@@@@@" "GF@@@@@@@OOOOOOOOOH@@@@@" "JNF@A@@@DOOOOOOOOO@@@@@@" "KFDDC@@@DOOOOOOOON@@@@@@" "MN@D@@H@DOOOOOOOOL@@@@@@" "GD@L@AH@D@@@@@@@@@@@@@@@")} 256 . 89))) (40 (({(READBITMAP)(32 24 "D@@@@@@@" "D@@A@@@@" "D@@C@@@@" "@@@N@@@@" "H@@@@@@@" "L@@@@@@H" "@D@H@@GH" "@@A@@@OH" "@BA@@@OH" "@@@@@AOH" "D@@@@AOL" "@B@B@COL" "@B@N@COL" "@@@@@COL" "HLH@@COL" "HL@@@GOL" "@@@@@OON" "H@@@@OOO" "@@@@@COO" "@@@@@COO" "@@@@@AOO" "@@@@@@OO" "@@@@@@GN" "@@@@@@@@")} 304 . 26) ({(READBITMAP)(80 19 "FO@@C@@@@@GOOOOOOOL@" "MOF@C@@@D@FJJJJJJJO@" "GOF@@@@B@@@@@@@@@@AH" "MKF@@HDD@@BJJJJJJJKL" "FKFA@GH@@@GOOOOOOOON" "OO@DLCA@A@COOOOOOOON" "KG@DL@A@@@COOOOOOOOO" "OJ@H@H@@@BGOOOOOOOOO" "MB@@@BAB@BGOOOOOOOOO" "CO@@LHCAD@GOOOOOOOOO" "OFA@LH@@D@GOOOOOOOOO" "LJAHLBA@DBGOOOOOOOOO" "OFAH@CC@H@GOOOOOOOON" "MN@@@AC@H@GOOOOOOOON" "GF@@@HHB@@GOOOOOOOOL" "JNFFAB@@@@GOOOOOOOOH" "KFDLC@@@F@GOOOOOOOO@" "MN@F@@H@@@GOOOOOOON@" "GDBO@AH@@@@@@@@@@@@@")} 256 . 89) ({(READBITMAP)(80 42 "@@@@@@@@@FH@@@@@@@@@" "@@@@@@@@@DEH@@@@@@@@" "@@@@@@@H@BFAH@@@@@@@" "@@@@@@LHDCH@BF@@@@@@" "@@@@L@LD@@DD@B@@@@@@" "@@@@L@BEA@FDCF@@@@@@" "@@@@@@GO@@@@H@@@@@@@" "@@F@CB@A@@@@@@L@C@@@" "@AM@BB@@@@@N@@L@C@@@" "@CK@@@@BD@DH@@@@@@@@" "@J@@G@@@@@JLI@@@@@@@" "AN@@D@B@@A@HGDAH@D@@" "AH@@D@@@HB@DBB@A@@@@" "@@@@A@@FC@HLH@@C@@@@" "@@@@AA@NCAAHLF@@@D@@" "@@FDBF@KHAA@@@@@AH@@" "DEBF@@DAH@@@@F@@AH@@" "@AB@@HDA@AL@@@B@@@@@" "@CB@F@@BA@IAJ@DCLAB@" "CCB@GH@@@@HH@@FCL@@@" "CCF@GH@@@ADGLN@@@@@@" "H@@AC@@@A@@C@@@@@@@@" "@@@C@FC@@I@@@@@@@F@@" "@@@C@F@FDO@I@@@@@F@@" "@F@CF@@FDB@@AC@F@@@@" "@F@LF@GN@A@AKC@F@@@@" "@@@LA@AKHAH@CD@C@@@@" "L@@@AAHFLDH@BD@@@@@@" "@@@C@A@FL@OLJCL@@@@@" "@CA@@OAIH@EHNCLH@A@@" "@DB@AK@AI@AH@@CH@@A@" "@DB@AAHBBAKL@@F@H@A@" "@@L@AAD@@GB@F@@A@@A@" "@@@@C@@AHDD@FC@@@D@@" "@I@A@CH@@D@@B@@@@@@@" "AIHAAF@@@DD@@C@@@@A@" "I@@@@@HDAAAA@C@EH@@@" "@@@B@@@L@A@C@D@D@@@@" "@@AJCGAILCHC@@@@D@M@" "@@BCCLCIOLA@D@@@@@@@" "@@HC@@@D@@@CHAD@@@@@" "@A@@@@@D@F@B@FD@@@@@")} 272 . 116))) (40 (({(READBITMAP)(16 1 "NL@A")} 256 . 88) ({(READBITMAP)(32 18 "OOOL@@@@" "JJJO@@@@" "@@@AH@@@" "JJJKL@@@" "OOOON@@@" "OOOON@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOOO@@@" "OOOON@@@" "OOOON@@@" "OOOOL@@@" "OOOOH@@@" "OOOO@@@@" "OOON@@@@")} 320 . 90) ({(READBITMAP)(80 21 "MCLL@@@@@@@@@@@@@@@@" "GMGL@@@@@@@@@@@@@@@@" "JJKH@@@@@@@@@@@@@@@@" "KOOH@@@@@@@@@@@@@@@@" "MOGH@@@@@@@@@@@@@@@@" "EEO@@@@@@@@@@@@@@@@@" "JKKH@@@@@@@@@@@@@@@@" "JKKH@@@@@@@@@@@@@@@@" "GGO@@@@@@@@@@@@@@@@@" "EEG@@@@@@@@@@@@@@@@@" "JKN@@@@@@@@@@@@@@@@@" "JKN@@@@@@@@@@@@@@@@@" "GGL@@@@@@@@@@@@@@@@@" "OEL@@@@@@@@@@@@@@@@@" "OKH@@@@@@@@@D@@@@@@@" "OKH@@@@@@@@@@@@@D@@@" "OGH@@@@@@@@@@@@@@@@L" "EG@@@@B@N@@@L@@@H@@@" "JK@@@@N@O@NAH@AAL@@@" "JN@@@@H@G@O@A@I@@D@H" "ON@@@@K@@GN@IACH@@A@")} 240 . 42) ({(READBITMAP)(32 26 "A@@@@@@G" "@@@@D@@F" "@B@B@@A@" "@@DD@H@B" "@GH@@ICG" "LCA@AAAG" "L@A@@@@G" "@H@@@KBG" "@BABAC@G" "LHCAD@@G" "LH@@D@@G" "LBA@DJ@G" "@CC@HI@G" "@AC@LN@G" "@HHB@H@G" "AB@@CB@G" "C@@@G@@G" "@@I@A@@G" "@AI@@@@@" "@AJ@AH@@" "@@@@@@@@" "B@@@@@@@" "AH@H@@@@" "@BF@@@@@" "@@@@@@@@" "H@@D@@@@")} 272 . 82) ({(READBITMAP)(80 35 "@@A@BB@@@@@N@@L@C@@@" "@BK@@@@BD@DH@@@@@@@@" "@J@@G@@@@@JLI@@@@@@@" "AL@@D@B@@A@HGDAH@D@@" "AH@@D@@@HB@DBB@A@@@@" "@@@@A@@FC@HLH@@C@@@@" "@@@@AA@NCAAHLF@@@@@@" "@@FDBF@KHAA@@@@@@H@@" "DEBF@@DAH@@@@D@@AH@@" "@@@@@HDA@AL@@@@@@@@@" "@BB@F@@BA@IAJ@D@@@B@" "CBB@G@@@@@@H@@FCL@@@" "CC@@D@@@@ADGLN@@@@@@" "H@@@A@@@A@@C@@@@@@@@" "@@@C@FA@@I@@@@@@@B@@" "@@@B@F@DDG@H@@@@@F@@" "@F@CD@@FD@@@AC@FB@@@" "@F@LB@EJ@A@AKCBF@@@@" "@@@LA@@KHAH@BD@@@@@@" "L@@@AAHDLDH@@@@@@@@@" "@@@C@A@@L@ELJA@@@@@@" "@BA@@OAIH@D@NBDH@A@@" "@DB@AJ@AH@AH@@CH@@A@" "@DB@AA@B@AAL@@F@H@A@" "@@L@@AD@@D@@F@@A@@A@" "@@@@C@@AH@D@FC@@@D@@" "@A@A@CH@@D@@B@@@@@@@" "AIHAAB@@@DD@@C@@@@A@" "I@@@@@HDAAAA@C@EH@@@" "@@@B@@@D@A@C@D@D@@@@" "@@AJCCAADCHC@@@@D@M@" "@@BCCHCAGLA@D@@@@@@@" "@@HC@@@@@@@C@AD@@@@@" "@A@@@@@D@F@B@FD@@@@@" "@L@@@@D@DD@@@@@@@@@@")} 272 . 115) ({(READBITMAP)(32 34 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@H@@@@" "@@@@@@@@" "@@@@@@@@" "@A@L@@@@" "@@AN@@@@" "@BAN@@@@" "@@AO@@@@" "@@AOH@@@" "@@COH@@@" "@@COH@@@" "@IOOH@@@" "@OOGH@@@" "@COOH@@@" "@COOH@@@" "@COOL@@@" "@GOOH@@@" "@GOOH@@@" "@COO@@@@")} 320 . 26) ({(READBITMAP)(32 3 "@@@H@@D@" "@@LHDB@@" "L@@D@@DD")} 288 . 153))) (40 (({(READBITMAP)(32 18 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@A@@@@@@" "@@C@@@@@" "@BGH@@@@" "@@GH@@@@" "@@GH@@@@" "@AOL@@@@" "@COL@@@@" "@COL@@@@" "@COL@@@@" "@CON@@@@" "@GON@@@@" "@GON@@@@" "@CON@@@@" "@@OO@@@@" "@AOO@@@@")} 320 . 26) ({(READBITMAP)(80 16 "OKH@@@@@@@@@@@@@@@@@" "OKH@@@@@@@@@@@@@@@@@" "OGH@@@@@@@@@@@@@@@@@" "EG@@@@@@@@@@@@@@@@@@" "JK@@@@@@@@@@@@@@@@@@" "JN@@@@@@@@@@@@@@@@@@" "ON@@@@@@@@@@@@@@@@@@" "OD@@@@@@@@@@@@B@@@@@" "OL@@@@@@@@@@@@@@@@@@" "JL@@@@@@@@@@@@@@D@@@" "OH@@@@@@@@@@@@@@@@@@" "OH@@@@@@@@@@@@@@@B@@" "O@@@@@@@@@@@B@B@@@@@" "O@@@@@@@@@@@@@FGHLH@" "N@@@@@@H@B@A@@@AHL@@" "N@@@@@@IH@@C@@@@@@@@")} 240 . 33) ({(READBITMAP)(80 33 "A@@@@@@@GOOOOOOOL@@@" "@@@@D@@@FJJJJJJJO@@@" "@B@B@@@A@@@@@@@@AH@@" "@@D@@@@@BJJJJJJJKL@@" "@EH@@I@CGOOOOOOOON@@" "L@A@AA@AGOOOOOOOON@@" "L@A@@@@@GOOOOOOOOO@@" "@@@@@@@BGOOOOOOOOO@@" "@BABAC@@GOOOOOOOOO@@" "DHCAD@@@GOOOOOOOOO@@" "@H@@D@@@GOOOOOOOOO@@" "DBA@DJ@@GOOOOOOOOO@@" "@CC@HI@@GOOOOOOOON@@" "@AC@LN@@GOOOOOOOON@@" "@HHB@HH@GOOOOOOOOL@@" "AB@@CB@@GOOOOOOOOH@@" "C@@@G@@@GOOOOOOOO@@@" "@@I@A@@HGOOOOOOON@@@" "@AI@@@@@@@@@@@@@@@@@" "@AJ@AH@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "B@@@@@@@@@@@@@@@@@@@" "AH@H@@B@@@@@@@@@@@@@" "@BF@B@@@@@@@@@@@@@@@" "@@@@@@H@@@@@@@@@@@@@" "H@@D@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@L@@@@@@@@@@@@@@@@" "@@@@BH@@@@@@@@@@@@@@" "B@D@@@@@@@@@@@@@@@@@" "DA@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@D@@@@@@@@@@@@")} 272 . 75) ({(READBITMAP)(112 41 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@H@@@@@@@@@@@" "@@@@@@@@@@L@@@@@BF@@@@@@@@@@" "@@@@@@@@L@@D@@@D@B@@@@@@@@@@" "@@@@@@@@H@@EA@F@CF@@@@@@@@@@" "@@@@@@@@@@AO@@@@@@@@D@@@@@@@" "@@@@B@F@@@@A@@@@@@L@CB@@@@@@" "@@@@@@@@BB@@@@@N@@L@I@@@@@@@" "@@@@@@I@@@@@D@@@@@@H@@@@@@@@" "@@@@@H@@C@@@@@H@A@@@@@@@@@@@" "@@@L@D@@D@B@@A@HCDAH@D@@@@@@" "@@@@@@@@D@@@@B@@BB@A@@@@@@@@" "@@@@@@@@A@@DA@@@H@@C@@@@@@@@" "@@@@@@@@AA@DC@AHH@@@@@@@@@@@" "@@@A@@FDBF@B@@@@@@@@@H@@@@@@" "@@@@DEBF@@@@@@@@@D@@AH@@@@@@" "@@@L@@@@@H@@@@L@@@@@@@@@@@@@" "@@@L@BB@F@@@A@HAB@D@@@B@@@@@" "@@@@CBB@D@@@@@@H@@FCL@@@D@@@" "@@@@CC@@@@@@@AD@LN@@@@@@@@@@" "H@@@H@@@A@@@A@@C@@@@@@@@@@@@" "L@CL@@@C@FA@@I@@@@@@@B@B@@@@" "N@CN@@@B@F@D@G@H@@@@@F@@@B@@" "G@@@@F@CD@@@@@@@AC@FB@@@@@@@" "K@@@@F@LB@AH@A@@HB@F@@@@@@@@" "C@@@@@@LA@@H@A@@@@@@@@@@@@@@" "OH@@L@@@AA@DDD@@@@@@@@@@H@@@" "GH@F@@@C@A@@D@D@JA@@@@@@@@@@" "KH@D@BA@@IA@@@@@L@@@@A@@@@H@" "CH@@@DB@A@@@@@@H@@CH@@A@@@D@" "MLAH@DB@AA@@@A@H@@F@H@A@@@@@" "GLAH@@L@@@D@@D@@@@@A@@A@@D@@" "JLAN@@@@C@@@@@@@FC@@@D@@A@@@" "CL@@@A@@@B@@@D@@B@@@@@@@@@@@" "ON@@AIHAAB@@@D@@@@@@@@AB@@B@" "GF@FI@@@@@H@AAA@@@@DH@@B@@@@" "KN@F@@@B@@@@@A@@@@@D@@@@@@A@" "CF@@@@AHC@@ADC@A@@@@D@M@D@@@" "OF@I@@BA@HBA@H@@D@@@@@@@@H@@" "GN@@@@HC@@@@@@@@@@D@@@@@@@@@")} 256 . 117))) (40 (({(READBITMAP)(96 67 "@@@@@@@@@@@@@@@@BD@@@@@@" "@@@@@@@@@@@@@@@D@@@@@@@@" "@@@@@@@@@@@@@@D@@F@@@@@@" "@@@@@@@@@@@A@@@@@@@@@@@@" "@@@@B@@@@@@@@@@@@@@@@@@@" "@@@@@@@@B@@@@@@F@@D@@@@@" "@@@@@@A@@@@@D@@@@@@@@@@@" "@@@@@@@@@@@@@@H@@@@@@@@@" "@@@@@D@@@@B@@A@H@D@H@D@@" "@@@@@@@@D@@@@B@@@B@A@@@@" "@@@@@@@@@@@DA@@@H@@C@@@@" "@@@@@@@@A@@@B@A@H@@@@@@@" "@@@A@@F@B@@@@@@@@@@@@H@@" "@@@@DEB@@@@@@@@@@D@@@H@@" "@@@@@@@@@H@@@@@@@@@@@@@@" "@@@@@BB@F@@@A@H@@@@@@@B@" "@@@@CBB@@@@@@@@@@@@@D@@@" "@@@@C@@@@@@@@A@@LH@@@@@@" "H@@@H@@@@@@@A@@A@@@@@@@@" "L@@@@@@C@@A@@I@@@@@@@B@B" "N@@@@@@B@@@D@G@@@@@@@F@@" "G@@@@D@C@@@@@@@@AC@@B@@@" "K@@@@F@DB@AH@@@@HB@@@@@@" "C@@@@@@D@@@H@A@@@@@@@@@@" "OH@@L@@@AA@DD@@@@@@@@@@@" "GH@@@@@C@A@@D@D@BA@@@@@@" "KH@@@BA@@IA@@@@@@@@@@A@@" "CH@@@DB@@@@@@@@H@@@@@@A@" "MLA@@DB@@A@@@A@H@@@@H@A@" "GLA@@@L@@@@@@D@@@@@A@@A@" "JLA@@@@@C@@@@@@@FA@@@D@@" "CL@@@A@@@B@@@D@@@@@@@@@@" "ON@@AIH@AB@@@D@@@@@@@@AB" "GF@BI@@@@@H@AAA@@@@DH@@B" "KN@B@@@B@@@@@A@@@@@D@@@@" "CF@@@@AHC@@ADC@A@@@@D@M@" "OF@@@@B@@HBA@H@@D@@@@@@@" "GN@@@@HC@@@@@@@@@@D@@@@@" "KN@@@A@@@@@@@F@B@FD@@@@@" "BO@@@L@@@@D@@D@@@@@@@@@@" "NO@@@@@A@@L@L@@@@@@@D@@@" "GO@@@@@@@@@@@@@@@@@@@@@@" "JG@@@@@@@@@@@@@@@@@@@@@@" "CO@@@@D@@@@@@@@@@@@@@@@@" "OL@@@@@@@@@@@@@@@@@@@@@@" "GL@@@@@@@@@@@@@@@@@@@@@@" "NO@@@@@@@@@@@@@@@@@@@@@@" "FO@@A@@@@@@@@GOOOOOOOL@@" "MOD@@@@@D@@@@FJJJJJJJO@@" "GOD@@B@B@@@@A@@@@@@@@AH@" "MKD@@@@@@@@@@BJJJJJJJKL@" "FKDA@E@@@I@@CGOOOOOOOON@" "OO@@@@A@AA@@AGOOOOOOOON@" "KG@@L@A@@@@@@GOOOOOOOOO@" "OJ@@@@@@@@@@BGOOOOOOOOO@" "MB@@@B@@@A@@@GOOOOOOOOO@" "CO@@D@@AD@@@@GOOOOOOOOO@" "OFA@@@@@D@@@@GOOOOOOOOO@" "LJAHD@@@@@@@@GOOOOOOOOO@" "OFAH@@@@@@@@@GOOOOOOOON@" "MN@@@@@@@N@@@GOOOOOOOON@" "GF@@@@@@@@H@@GOOOOOOOOL@" "JNFFA@@@@@@@@GOOOOOOOOH@" "KFD@B@@@@@@@@GOOOOOOOO@@" "MN@B@@@@A@@H@GOOOOOOON@@" "GDBB@@@@@@@@@@@@@@@@@@@@" "NL@@@AJ@AH@@@@@@@@@@@@@@")} 256 . 88) ({(READBITMAP)(80 14 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@B@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@D@" "@@@@@@@@@A@@@@@@@@N@" "@@@@@@@@@@CN@@@@@@OH" "B@@@@@@@@HGN@@@@@@ON" "B@@@@@B@OHOL@@@@@@ON")} 256 . 28))) (40 (({(READBITMAP)(16 1 "B@@@")} 288 . 79) ({(READBITMAP)(16 1 "@@@@")} 352 . 124) ({(READBITMAP)(16 2 "@@@@" "@@@@")} 336 . 141) ({(READBITMAP)(32 35 "NO@@@@@@" "GO@@@@@@" "JG@@@@@@" "CO@@@@@@" "OL@@@@@@" "GL@@@@@@" "NO@@@@@@" "FO@@@@@@" "MOD@@@@@" "GOD@@@@@" "MKD@@@@@" "FKD@@@@@" "OO@@@@@@" "KG@@@@@@" "OJ@@@@@@" "MB@@@B@@" "CO@@@@@@" "OF@@@@@@" "LJ@@@@@@" "OF@@@@@@" "MN@@@@@@" "GF@@@@@@" "JNF@@@@@" "KFD@B@@@" "MN@@@@@@" "GD@B@@@@" "NL@@@AJ@" "CD@@@@@@" "ML@@B@@@" "GL@@AH@H" "JH@@@BF@" "CHF@@@@@" "MHH@H@@D" "GH@@@@@@" "KH@@@@@@")} 256 . 80) ({(READBITMAP)(96 20 "N@@@@@@@@@@@@@@@@@@@@@@@" "N@@@@@@@@@@@@@@@@@@@@@@@" "L@@@@@@@@@@@@@@@@@@@@@@@" "L@@@@@@@@@@@@@@@@@@@@@@@" "H@@@@@@@@@@@@@AN@@@@@@@@" "H@@@@@@@@@@@@HGN@@@@@@@@" "@@@@@@@@@@B@OHOL@@@@@@@@" "@@@@@@@@@@GOOOOL@@@@@@@@" "@@@@@@@@@@GOOOO@@@@@@@@@" "OOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@GOOOON@@@@@@@@@" "@@@@@@@@@@OOOOL@@@@@@@F@" "@@@@L@@@@@OOOOL@@@@@C@G@" "@@@H@@@@@@COOO@@@@@@CHG@" "@@@H@@DG@@@@@@@AH@@@AL@@" "@@@@@@@G@@@@@@@AH@@@AL@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@B@@@@@@@@@@@@@@@@@@@@@" "@@L@@@@@@@@@@@@@@@@@@@@@")} 240 . 15) ({(READBITMAP)(16 22 "@@@@" "FA@@" "@@@@" "@@@@" "@@@D" "@@@D" "@@@@" "@@@@" "@@D@" "@D@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "OOOO" "EEEE" "@@@@" "EEEE")} 320 . 104) ({(READBITMAP)(16 33 "@@A@" "H@@B" "@@@@" "D@M@" "@@@@" "@@@@" "@@@@" "@@@@" "D@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "OOH@" "EEN@" "@@C@" "EEGH" "OOOL" "OOOL" "OOON" "OOON" "OOON" "OOON" "OOON" "OOON" "OOOL" "OOOL" "OOOH" "OOO@" "OON@" "OOL@")} 336 . 90) ({(READBITMAP)(32 32 "@@H@A@@@" "@@@@@@@@" "C@@A@@@A" "@@B@@H@@" "@@@@@@@@" "@@@@@B@B" "@@D@@@@@" "@@L@D@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@OO" "@@@@@@ME" "@@@@@@@@" "@@@@@@EE" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "@N@@@@OO" "@@@@@@OO" "@@@@@@OO" "@@@@@@OO" "A@@H@@OO")} 288 . 90) ({(READBITMAP)(80 13 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@H@@@@@@@@@" "@@@@@@B@@@@@@@@@@@@@" "@@@@D@@@@@@@@@@@@@@@" "@@@@@@@D@@@@@@@@@@@@" "@@@@A@@@@@A@@@@@@@@@")} 272 . 143))) (40 (({(READBITMAP)(16 1 "@@@@")} 272 . 99) ({(READBITMAP)(48 11 "JL@@@@@@C@@@" "CL@@@@@@@B@@" "ON@@@@@@@B@@" "GF@@@@@@@@H@" "KN@@@@@@@@@@" "CF@@@@A@C@@A" "OF@@@@@@@@B@" "GN@@@@HC@@@@" "KN@@@@@@@@@@" "BO@@@@@@@@@@" "NO@@@@@@@@@@")} 256 . 114) ({(READBITMAP)(64 18 "@@@OOOOOOOOH@@@@" "@@@MEEEEEEEN@@@@" "@@@@@@@@@@@C@@@@" "@@@EEEEEEEEGH@@@" "@@@OOOOOOOOOL@@@" "@@@OOOOOOOOOL@@@" "@@@OOOOOOOOON@@@" "@@@OOOOOOOOON@@@" "@@@OOOOOOOOON@@@" "@@@OOOOOOOOON@@@" "@@@OOOOOOOOON@@@" "@@@OOOOOOOOON@@@" "@@@OOOOOOOOOL@@@" "@@@OOOOOOOOOL@@@" "@@@OOOOOOOOOH@@@" "@@@OOOOOOOOO@@@@" "@@@OOOOOOOON@@@@" "@@@OOOOOOOOL@@@@")} 304 . 90) ({(READBITMAP)(32 10 "AHHG@@@@" "AI@@@@@@" "A@@@@@@@" "A@@@@@@F" "AH@@@@@@" "@@@@@@@@" "@@@@@@@F" "@@@@@@@D" "@@@@@@@D" "@@@@@@@B")} 256 . 9) ({(READBITMAP)(32 20 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "B@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@AH@@@@@" "@@@@@@@@" "B@@@@@@@" "AH@@@@@@" "@B@@B@@@" "@@@@@@@@" "H@@D@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "B@D@@@@@" "DA@@@@@@" "@@@@@@@@" "@@@@@@@@")} 272 . 75) ({(READBITMAP)(16 8 "@@L@" "H@HH" "H@@@" "@@@@" "@@@@" "@@@@" "@AH@" "@AH@")} 304 . 13) ({(READBITMAP)(96 27 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@@@@B@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@B@@A@@H@@@@@@@B@@@@@@" "@@@@@@@D@F@@@@@@@D@@@B@@" "@D@@@@@@@@@@@@@@@@@@@@@@" "@F@DB@AH@@@@H@@@@@@@@@@@" "@@@D@@@H@A@@@@@@@@@@@@@@" "L@@@AA@@@@@@@@@@@@@@@@@@" "@@@C@A@@D@D@BA@@@@@@@@@@" "@BA@@IA@@@@@@@@@@@@@@@H@" "@DB@@@@@@@@H@@@@@@@@@@D@" "@DB@@A@@@A@H@@@@H@@@@@@@" "@@L@@@@@@@@@@@@@@@@@@D@@" "@@@@C@@@@@@@FA@@@@@@@@@@" "@@@@@B@@@D@@@@@@@@@@@@@@" "@@@@@B@@@D@@@@@@@@A@@@B@" "@@@@@@H@A@@@@@@D@@@B@@@@")} 272 . 121))) (40 (({(READBITMAP)(16 2 "GD@F" "NL@G")} 256 . 88) ({(READBITMAP)(16 1 "@@@@")} 288 . 84) ({(READBITMAP)(16 1 "@@@@")} 256 . 142) ({(READBITMAP)(16 6 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 336 . 134) ({(READBITMAP)(16 9 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@B@" "@@@@" "@@@@")} 352 . 120) ({(READBITMAP)(16 15 "@@@@" "@@@@" "@@@@" "H@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 272 . 77) ({(READBITMAP)(16 29 "@@@@" "@@@@" "@@@B" "@@@@" "D@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 304 . 90) ({(READBITMAP)(48 18 "OOOOOOOOH@@@" "MEEEEEEEN@@@" "@@@@@@@@C@@@" "EEEEEEEEGH@@" "OOOOOOOOOL@@" "OOOOOOOOOL@@" "OOOOOOOOON@@" "OOOOOOOOON@@" "OOOOOOOOON@@" "OOOOOOOOON@@" "OOOOOOOOON@@" "OOOOOOOOON@@" "OOOOOOOOOL@@" "OOOOOOOOOL@@" "OOOOOOOOOH@@" "OOOOOOOOO@@@" "OOOOOOOON@@@" "OOOOOOOOL@@@")} 320 . 90) ({(READBITMAP)(80 15 "L@@@@@@@@@@@@@@@@@@@" "N@@@@@@@@@@@@D@@@@@@" "G@@@@@@@@@@@@@@@@@@@" "K@@@@@@@B@@@@@@@@@@@" "C@@@@@@D@@@@@A@@@@@@" "OH@@@@@@@@@@@@@@@@@@" "GH@@@@@@@@@@@@D@B@@@" "KH@@@@@@@H@@@@@@@@@@" "CH@@@@@@@@@@@@@H@@@@" "ML@@@DB@@A@@@A@H@@@@" "GL@@@@@@@@@@@@@@@@@@" "JL@@@@@@C@@@@@@@DA@@" "CL@@@@@@@B@@@D@@@@@@" "ON@@@@@@@B@@@D@@@@@@" "GF@@@@@@@@H@A@@@@@@@")} 256 . 121) ({(READBITMAP)(64 1 "C@@@@@@A@@@@D@A@")} 288 . 119))) (40 (({(READBITMAP)(16 1 "@@H@")} 272 . 117) ({(READBITMAP)(16 18 "@OOO" "@MEE" "@@@@" "@EEE" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO" "@OOO")} 320 . 90) ({(READBITMAP)(64 18 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@H@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@A@" "@@H@@@@@@@@@@@@B" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@D@@@" "@@B@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@D@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 288 . 114) ({(READBITMAP)(32 11 "JN@@@@@@" "KF@@@@@@" "MN@@@@@@" "GD@@@@@@" "NL@@@@@@" "CD@@@@@@" "ML@@@@@@" "GL@@@@@@" "JH@@@@@@" "CH@@@@@@" "MH@@@@@@")} 256 . 82) ({(READBITMAP)(16 45 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@H@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "OH@@" "EN@@" "@C@@" "EGH@" "OOL@" "OOL@" "OON@" "OON@" "OON@" "OON@" "OON@" "OON@" "OOL@" "OOL@" "OOH@" "OO@@" "ON@@" "OL@@")} 352 . 90))) (40 (({(READBITMAP)(16 8 "OO@@" "GO@@" "NO@@" "FO@@" "MO@@" "GO@@" "MK@@" "FK@@")} 256 . 103) ({(READBITMAP)(16 1 "@D@@")} 272 . 126) ({(READBITMAP)(16 6 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 336 . 121) ({(READBITMAP)(16 6 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 304 . 134) ({(READBITMAP)(48 18 "@@OOOOOOOOH@" "@@MEEEEEEEN@" "@@@@@@@@@@C@" "@@EEEEEEEEGH" "@@OOOOOOOOOL" "@@OOOOOOOOOL" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOON" "@@OOOOOOOOOL" "@@OOOOOOOOOL" "@@OOOOOOOOOH" "@@OOOOOOOOO@" "@@OOOOOOOON@" "@@OOOOOOOOL@")} 320 . 90) ({(READBITMAP)(32 2 "@@@@@@@@" "@@@@@@@@")} 272 . 131))) (40 (({(READBITMAP)(16 1 "@@@@")} 336 . 119) ({(READBITMAP)(16 35 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@O" "@@@M" "@@@@" "@@@E" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O" "@@@O")} 320 . 90) ({(READBITMAP)(32 10 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@")} 272 . 117) ({(READBITMAP)(32 29 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "OOOH@@@@" "EEEN@@@@" "@@@C@@@@" "EEEGH@@@" "OOOOL@@@" "OOOOL@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOON@@@" "OOOOL@@@" "OOOOL@@@" "OOOOH@@@" "OOOO@@@@" "OOON@@@@" "OOOL@@@@")} 352 . 90))) (40 (({(READBITMAP)(64 18 "@@@@GOOOOOOOL@@@" "@@@@FJJJJJJJO@@@" "@@@@@@@@@@@@AH@@" "@@@@BJJJJJJJKL@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOL@@" "@@@@GOOOOOOOOH@@" "@@@@GOOOOOOOO@@@" "@@@@GOOOOOOON@@@")} 320 . 90))) (40 (({(READBITMAP)(48 19 "@GOOOOOOOL@@" "@FJJJJJJJO@@" "@@@@@@@@@AH@" "@BJJJJJJJKL@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOL@" "@GOOOOOOOOH@" "@GOOOOOOOO@@" "@GOOOOOOON@@" "@@@@@@@@@@@@")} 336 . 90))) (40 (({(READBITMAP)(48 18 "@@GOOOOOOOL@" "@@FJJJJJJJO@" "@@@@@@@@@@AH" "@@BJJJJJJJKL" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOL" "@@GOOOOOOOOH" "@@GOOOOOOOO@" "@@GOOOOOOON@")} 336 . 91))) (40 (({(READBITMAP)(64 18 "@@@GOOOOOOOL@@@@" "@@@FJJJJJJJO@@@@" "@@@@@@@@@@@AH@@@" "@@@BJJJJJJJKL@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOL@@@" "@@@GOOOOOOOOH@@@" "@@@GOOOOOOOO@@@@" "@@@GOOOOOOON@@@@")} 336 . 91))) (40 (({(READBITMAP)(64 18 "@@@@GOOOOOOOL@@@" "@@@@FJJJJJJJO@@@" "@@@@@@@@@@@@AH@@" "@@@@BJJJJJJJKL@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOOO@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOON@@" "@@@@GOOOOOOOOL@@" "@@@@GOOOOOOOOH@@" "@@@@GOOOOOOOO@@@" "@@@@GOOOOOOON@@@")} 336 . 91))) (40 (({(READBITMAP)(48 18 "@GOOOOOOOL@@" "@FJJJJJJJO@@" "@@@@@@@@@AH@" "@BJJJJJJJKL@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOOO@" "@GOOOOOOOON@" "@GOOOOOOOON@" "@GOOOOOOOOL@" "@GOOOOOOOOH@" "@GOOOOOOOO@@" "@GOOOOOOON@@")} 352 . 91))) (40 (({(READBITMAP)(48 18 "@@GOOOOOOOL@" "@@FJJJJJJJO@" "@@@@@@@@@@AH" "@@BJJJJJJJKL" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOOO" "@@GOOOOOOOON" "@@GOOOOOOOON" "@@GOOOOOOOOL" "@@GOOOOOOOOH" "@@GOOOOOOOO@" "@@GOOOOOOON@")} 352 . 91))) (40 (({(READBITMAP)(48 18 "@@@GOOOOOOOL" "@@@FJJJJJJJO" "@@@@@@@@@@@A" "@@@BJJJJJJJK" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOOO" "@@@GOOOOOOON")} 352 . 91))) (40 (({(READBITMAP)(48 18 "@@@@GOOOOOOO" "@@@@FJJJJJJK" "@@@@@@@@@@@A" "@@@@BJJJJJJK" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO" "@@@@GOOOOOOO")} 352 . 91))) (40 (({(READBITMAP)(16 18 "@GOO" "@FJJ" "@@@@" "@BJJ" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO")} 368 . 91))) (40 (({(READBITMAP)(16 18 "@@GO" "@@FJ" "@@@@" "@@BJ" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO" "@@GO")} 368 . 91))) (40 (({(READBITMAP)(16 18 "@@@G" "@@@F" "@@@@" "@@@B" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G")} 368 . 91))) (40 (({(READBITMAP)(32 18 "@@@@GOOO" "@@@@FJJK" "@@@@@@@A" "@@@@BJJK" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO" "@@@@GOOO")} 368 . 91))) (40 (({(READBITMAP)(16 18 "@GOO" "@FJK" "@@@A" "@BJK" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO" "@GOO")} 384 . 91))) (40 (({(READBITMAP)(16 18 "@@CO" "@@CE" "@@@A" "@@AE" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO" "@@CO")} 384 . 91))) (40 (({(READBITMAP)(16 18 "@@@G" "@@@G" "@@@A" "@@@C" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G" "@@@G")} 384 . 91))) (40 (({(READBITMAP)(16 18 "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A" "@@@A")} 384 . 91))) (500 (({(READBITMAP)(16 18 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 384 . 91))) (40 (({(READBITMAP)(160 90 "@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@GL@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AN@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@AOOOOON@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@OOOOOOON@@@@@@@" "@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@" "@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@" "@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@" "@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@" "@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@" "@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@" "@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@" "@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@" "@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@" "@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@" "@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@" "@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@" "@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@" "@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@" "@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@" "@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@" "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 86))) (40 (({(READBITMAP)(160 90 "@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AN@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@AOOOOON@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@OOOOOOON@@@@@@@" "@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@" "@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@" "@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@" "@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@" "@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@" "@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@" "@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@" "@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@" "@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@" "@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@" "@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@" "@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@" "@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@" "@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@" "@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@" "@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@" "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 88))) (40 (({(READBITMAP)(160 90 "@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AN@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@AOOOOON@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@OOOOOOON@@@@@@@" "@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@" "@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@" "@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@" "@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@" "@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@" "@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@" "@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@" "@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@" "@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@" "@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@" "@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@" "@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@" "@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@" "@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@" "@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@" "@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@" "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 90))) (40 (({(READBITMAP)(160 90 "@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@@@O@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AN@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@AOOOOON@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CN@@@OOOOOOON@@@@@@@" "@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@" "@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@" "@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@" "@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@" "@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@" "@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@" "@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@" "@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@" "@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@" "@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@" "@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@" "@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@" "@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@" "@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@" "@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@" "@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@" "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 92))) (40 (({(READBITMAP)(160 92 "@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAO@@@@@@@@@@@@@@AH@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO" "@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@@@" "@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@" "@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@" "@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@" "@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@" "@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@" "@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@" "@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@" "@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@" "@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@" "@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@" "@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@" "@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@" "@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@" "@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@" "@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@" "@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@" "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 94))) (40 (({(READBITMAP)(160 105 "AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C" "AHOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOLCC" "@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOLC@" "@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AHC@" "@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@" "OOL@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AHGO" "OOL@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AHGO" "@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@" "@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@" "CHL@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@" "CHL@@@@@@@@@@@@@@@@LAO@@@@@@@@@@@@@@AHAH" "ALOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOLAH" "@LOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOLF@" "@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@GH" "AH@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@GH" "AH@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@" "@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@" "OO@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@GO" "OO@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@GO" "@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@" "@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@" "@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@" "@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@" "@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@" "@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@" "@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@" "@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@" "@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@" "@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@" "@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@" "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 98))) (40 (({(READBITMAP)(192 107 "@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@" "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@F@@@" "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@F@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@L@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@L@@@@" "@@AN@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@" "@@AN@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@@@@@" "OOOOOOL@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AHGOOOOO" "OOOOOOL@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AHGOOOOO" "@@@@@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LAO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@@@N@@@" "@@AN@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@AN@@@" "@@AN@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@CH@@@" "@@@@@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@C@@@@" "@@@@@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@@@@@" "@@@@@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@HC@@@" "@@G@@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@CL@@" "@@G@@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@AL@@" "@@@@@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@@@@@" "@@@@@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@@@@@" "@@@@@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@@@@@" "@@@@@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@@@@@" "OOOOOO@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@GOOOOO" "OOOOOO@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@GOOOOO" "@@@@@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@@@@@" "@@@@@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@@@@@" "@@@@@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@@@@@" "@@@@@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@@@@@" "@@@@@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@@@@@" "@@@@@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@@@@@" "@@@@@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@@@@@" "@@@@@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@@@@@" "@@@@@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@@@@@" "@@@@@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@@@@@" "@@@@@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@@@@@" "@@@@@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@@@@@" "@@@@@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@@@@@" "@@@@@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@@@@@" "@@@@@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@@@@@" "@@@@@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@@@@@" "@@@@@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@@@@@" "@@@@@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@@@@@" "@@@@@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@@@@@" "@@@@@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@@@@@" "@@@@@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@@@@@" "@@@@@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@@@@@" "@@@@@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@@@@@" "@@@@@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@@@@@" "@@@@@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@@@@@" "@@@@@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@@@@@" "@@@@@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@@@@@" "@@@@@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@@@@@" "@@@@@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@@@@@" "@@@@@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@@@@@" "@@@@@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@@@@@" "@@@@@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@@@@@" "@@@@@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@@@@@" "@@@@@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@@@@@" "@@@@@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@@@@@" "@@@@@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@@@@@" "@@@@@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@@@@@" "@@@@@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@@@@@" "@@@@@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@@@@@" "@@@@@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@@@@@" "@@@@@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@@@@@" "@@@@@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@@@@@" "@@@@@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@@@@@" "@@@@@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@@@@@" "@@@@@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@@@@@" "@@@@@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 96 . 104))) (40 (({(READBITMAP)(192 103 "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@C@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@C@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@" "@@C@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@@AH@" "@@@@@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@@AH@" "@@@@@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@@F@@" "@@@@@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@@F@@" "@@@@@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@@@@@" "@G@@@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@@@@@" "@G@@@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@C@@@" "@@@@@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@C@@@" "@@@@@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "OOOOOOL@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@AHGOOOOO" "OOOOOOL@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AHGOOOOO" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@L@@@@@@@@@@@@@@@@LAO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@@@@@@@" "@@@@@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@@@@@" "@@@@@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@@@F@" "@@@@@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@@@F@" "@@@@@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@@CH@" "@@O@@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@@CH@" "@@O@@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@@C@@" "@@@@@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@@@@@" "@@@@@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@@@@@" "@@@@@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@@@@@" "@@@@@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@@@@@" "@@@@@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@@@@@" "@@@@@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@@@@@" "@@@@@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@@@@@" "@@@@@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@@@@@" "@@@@@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@@@@@" "@@@@@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@@@@@" "@@@@@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@@@AN" "@@@@@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@@@AN" "@@@@@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@@@@@" "@@@@@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@@@@@" "@@@@@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@@@@@" "OOOOOO@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCLGOOOOO" "OOOOOOAMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOONGOOOOO" "@@@@@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@@@@@" "@@@@@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@@@@@" "@@@@@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@@@@@" "@@@@@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@@@@@" "@@@@@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@@@@@" "@@@@@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@@@@@" "@@@@@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBO@@@@@@" "@@@@@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONO@@@@@@" "@@@@@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGO@@@@@@" "@@@@@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJG@@@@@@" "@@@@@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCO@@@@@@" "@@@@@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOOO@@@@@@" "@@@@@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGO@@@@@@" "@@@@@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNO@@@@@@" "@@@@@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFO@@@@@@" "@@@@@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMO@@@@@@" "@@@@@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGO@@@@@@" "@@@@@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMK@@@@@@" "@@@@@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@@@@@" "@@@@@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@@@@@" "@@@@@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@@@@@" "@@@@@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@@@@@" "@@@@@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@@@@@" "@@@@@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@@@@@" "@@@@@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@@@@@" "@@@@@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@@@@@" "@@@@@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@@@@@" "@@@@@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@@@@@" "@@@@@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@@@@@" "@@@@@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@@@@@" "@@@@@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@@@@@" "@@@@@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@@@@@" "@@@@@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@@@@@" "@@@@@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@@@@@" "@@@@@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@@@@@" "@@@@@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 96 . 112))) (40 (({(READBITMAP)(208 102 "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LF@@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LO@@@@@@@@@@@@@@@AH@@@@@@" "@@@@C@@@@@L@@@@@@@@@@@@@@@@MO@@@@@@@@@@@@@@@AH@@@@@@" "@@@@C@@@@@L@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@OOL@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@MOL@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LON@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LOO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LGO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LCOH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@B@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@AH@" "@@B@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@AH@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@B@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@B@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LAO@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@@@@@@@" "@@@@@@@@@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@@@@@" "@@@@@@@@@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@@@@@" "OOOOOOOOOO@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@GOOOOO" "OOOOOOOOOO@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@GOOOOO" "@@@@@@@@@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@@@@@" "@@@@@@@@@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@@@@@" "@@@@@@@@@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@@@@@" "@@@@@@@@@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@@@@@" "@@@@@@@@@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@@@@@" "@@@@@@@@@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@@@@@" "@@@@@@@@@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@@@@@" "@@@@@@@@@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@@@@@" "@@@@@@@@@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@@@@@" "@@@@@@@@@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@@@F@" "@@@@@@@@@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@@@F@" "@@@@@@@@@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@@@@@" "@@@@@@N@@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@@@@@" "@@@@@@N@@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@@@@@" "@@@@@@@@@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@@@@@" "@@@@@@@@@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@@@@@" "@@@@@@@@@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@@@@@" "@@@@@@@@@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@@@@@" "@@@@@@@@@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@@@@@" "@@@@@@@@@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@@@@@" "@@@@@@@@@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@@@@@" "@@@@@@@@@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@@@@@" "@@@@@@@@@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@@@@@" "@@@@@@@@@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@@@@@" "@@@@@@@@@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@@@@B" "@@@@@@@@@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBN@@@@@F" "@@@@@@@@@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONN@@@@@@" "@@@@@@@@@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGN@@@@@@" "@@@@@@@@@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJF@@@@@@" "OOOOOOOOOOANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCNGOOOOO" "OOOOOOOOOOAOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOONGOOOOO" "@@@@@@@@@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGN@@@@@@" "@@@@@@@@@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNN@@@@@@" "@@@@@@@@@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFN@@@@@@" "@@@@@@@@@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMN@@@@@@" "@@@@@@@@@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGN@@@@@@" "@@@@@@@@@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMJ@@@@@@" "@@@@@@@@@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@@@@@" "@@@@@@@@@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@@@@@" "@@@@@@@@@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@@@@@" "@@@@@@@@@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOK@@@@@@" "@@@@@@@@@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMC@@@@@@" "@@@@@@@@@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@@@@@" "@@@@@@@@@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOG@@@@@@" "@@@@@@@@@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLK@@@@@@" "@@@@@@@@@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOG@@@@@@" "@@@@@@@@@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMO@@@@@@" "@@@@@@@@@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGG@@@@@@" "@@@@@@@@@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJO@@@@@@" "@@@@@@@@@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKG@@@@@@" "@@@@@@@@@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMO@@@@@@" "@@@@@@@@@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGG@@@@@@" "@@@@@@@@@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNO@@@@@@" "@@@@@@@@@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@@@@@" "@@@@@@@@@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOMM@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 80 . 122))) (40 (({(READBITMAP)(208 90 "@@@@@@@@@@L@@@@@@@@@@@@@@@@LAOL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@B@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@B@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@GL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OL@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@OH@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@L@O@@@@@@@@@@@@@@AH@@@@@@" "@@@@@@@@@@L@@@@@@@@@@@@@@@@LAO@@@@@@@@@@@@@@AH@@@@B@" "@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@B@" "@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@@@@@@@" "@@@@@@@@@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@@@@@" "@@@@@@@@@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@@@@@" "@@@@@@@@@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@@@@@" "@@@@@@@@@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@@@@@" "@@@@@@@@@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@@@@@" "@@@@@@@@@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@@@@@" "@@@@@@@@@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@@@@@" "@@@@@@@@@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@@@@@" "@@@@@@@@@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@@@@@" "@@@@@@@@@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@@@@@" "@@@@@@@@@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@@@@@" "@@@@@@@@@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@@@@@" "@@@@@@@@@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@@@@@" "@@@@@@@@@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@@@@@" "@@@@@@@@@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@@@@@" "OOOOOOOOOO@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGHGOOOOO" "OOOOOOOOOO@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKHGOOOOO" "@@@@@@@@@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@@@@@" "@@@@@@@@@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@@@@@" "@@@@@@@@@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@@@@@" "@@@@@@@@@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@@@@@" "@@@@@@@@@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@@@@@" "@@@@@@@@@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@@@@@" "@@@@@@@@@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@@@@@" "@@@@@@@@@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@@@@L" "@@@@@@@@@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@@@@L" "@@@@@@@@@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@@@@@" "@@@@@@@@@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@@@@@" "@@@@@@@@@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@@@@@" "@@@@@@B@@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBN@@@@@@" "@@@@@@B@@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONN@@@@@@" "@@@@@@@@@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGN@@@@@@" "@@@@@@@@@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJF@@@@@@" "@@@@@@@@@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCN@@@@@@" "@@@@@@@@@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOON@@@@@@" "@@@@@@@@@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGN@@@@@@" "@@@@@@@@@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNN@@@@@@" "@@@@@@@@@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFN@@@@@@" "@@@@@@@@@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMN@@@@@@" "@@@@@@@@@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGN@@@@@@" "@@@@@@@@@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMJ@@@@@@" "@@@@@@@@@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@@@@@" "@@@@@@@@@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@@@@@" "@@@@@@@@@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@@@@@" "@@@@@@@@@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOK@@@@@@" "@@@@@@@@@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMC@@@@@@" "OOOOOOOOOOAMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCOGOOOOO" "OOOOOOOOOOAOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOGGOOOOO" "@@@@@@@@@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLK@@@@@@" "@@@@@@@@@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOG@@@@@@" "@@@@@@@@@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMO@@@@@@" "@@@@@@@@@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGG@@@@@@" "@@@@@@@@@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJO@@@@@@" "@@@@@@@@@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKG@@@@@@" "@@@@@@@@@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMO@@@@@@" "@@@@@@@@@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGG@@@@@@" "@@@@@@@@@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNO@@@@@@" "@@@@@@@@@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@@@@@" "@@@@@@@@@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOMM@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 80 . 134))) (40 (({(READBITMAP)(192 77 "@@@@@@@@@@@@@@@@@@@@@@@LCN@@@OOOOOOON@@@@@@@@@@@" "@@@@@@@@@@@@OOOOOOL@@@@@CL@@CONJJJJOOL@@@@@@@@@@" "@@@@@@@@@@@OKOOOOGOL@@@@GL@@OOCCCCCCCOH@@@@@@@@@" "@@@@@@@@@@COMOOOOOOOH@@@GH@COHMMMMMMMON@@@@@@@@@" "@@@@@@@@@@OJKGGGOGOGN@@@GH@GOGGGGGGGGGO@@@@@@@@@" "@@@@@@@@@ANNJKJKOKOKOL@@OHAOJJJKJOKNOJKH@@@@@@@@" "@@@@@@@@@CMKCOKKOCOCOO@@OHCOCCKKKOKOOKOL@@@@@@@@" "@@@@@@@@@OOGOOOOOOOOMOH@O@OMOOOOOMMMMMMN@@@@@@@@" "@@@@@@@@AOGOGGGGGGGGOGL@OAOOGGEEEEGGGGGO@@@@@@@@" "@@@@@@@@CNKJJJJJJJJJJKN@OCNJJJJJH@@JJJJOH@@@@@@@" "@@@@@@@@COKJJJJJKKCCCKO@OGOOCJJH@@CKKKKCL@@@@@@@" "@@@@@@@@GOOEEEEEEOOOOOOIOOMGOED@@@OOOMOMN@@@@@@@" "@@@@@@@@OGEEEEEEEGGGGOOIOOFKEE@@@AGGGGGGG@@@@@@@" "@@@@@@@@NJJJJJJJJJJJOJKOONKNJH@@@@JJJJJJK@@@@@@@" "@@@@@@@@OJJJK@FJJKKKOCBOOKCJJH@@@CKKKKKKC@@@@@@@" "@@@@@@@AMMEE@@@MEGOOOOMGOMOOD@@@@OOOOOMMOH@@@@@@" "@@@@@@@COEEH@@CEEGGGGGGGOGGED@@@AGGGGGGGGH@@@@@@" "@@@@@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@@@@@" "@@@@@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@@@@@" "@@@@@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@@@@@" "@@@@@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@@@@@" "@@@@@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@@@@@" "@@@@@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@@@@@" "@@@@@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@@@@@" "@@@@@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@@@@@" "@@@@@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@@@@@" "@@@@@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@@@@@" "@@@@@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@@@@@" "@@@@@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@@@@@" "@@@@@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@@@@@" "@@@@@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBN@@@@@@" "@@@@@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONN@@@@@@" "@@@@@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGN@@@@@@" "OOOOOOAJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJFGOOOOO" "OOOOOOANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCNGOOOOO" "@@@@@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOON@@@@@@" "@@@@@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGN@@@@@@" "@@@@@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNN@@@@@@" "@@@@@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFN@@@@@@" "@@@@@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMN@@@@@@" "@@@@@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGN@@@@@@" "@@@@@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMJ@@@@@@" "@@@@@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFK@@@@@@" "@@@@@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOOO@@@@@@" "@@@@@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKG@@@@@@" "@@@@@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOK@@@@@@" "@@@@@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMC@@@@@@" "@@@@@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCO@@@@@@" "@@@@@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOG@@@@@@" "@@@@@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLK@@@@@@" "@@@@@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOG@@@@@@" "@@@@@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMO@@@@@@" "@@@@@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGG@@@@@@" "@@@@@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJO@@@@@@" "@@@@@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKG@@@@@@" "@@@@@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMO@@@@@@" "@@@@@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGG@@@@@@" "@@@@@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNO@@@@@@" "@@@@@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@@@@@" "@@@@@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOMM@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "OOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOO" "OOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOO" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 96 . 147))) (40 (({(READBITMAP)(160 60 "@@@CNJJ@@@BJJJJJNONOOJJJ@@@@JJJJJJJJKH@@" "@@@GJJL@@@NJKKKCCMOCOCBJ@@@BKKKKKKKKCH@@" "@@@OME@@@AEEEMOOOMOOOOOD@@@MMMOMMOOOML@@" "@@@OEE@@@EEEEGGGGOOCOGED@@EGGGGGGGGGGL@@" "@@@OJJ@@@JJJJJJJJOJKNNJJ@JJJJJJJNNNJJL@@" "@@@OJJ@@AJJJKKCCCGCCOOJHBJKKKKKKKOCCCL@@" "@@AMMD@@CEEEEMMOOOMOOOMFMEOOMMOOMOOOON@@" "@@AMED@@EEEEEGGGGGGGOOGDEGGGGGOGGGOGGF@@" "@@@NJL@AJJJJJJJJJJJKNNJJJJJJJJJNJMJJKN@@" "@@@NJH@JJJJJKKKKCCKCOKJJKKKKKKKOKOKCCF@@" "@@AMEDAEEEEEEMMMOOOOOGOEMMOOMOOOOOOOOF@@" "@@AMEDEEEEEEEGGGGGGGOOGEGGGGOOGOGMOGGN@@" "@@ANJHJJJJJJJJJJJJJKNBJJJJJKONKJJOJJKN@@" "@@ANJLJKJJJKJKKCKCKCOKKKKKKKLOKKKOKCBN@@" "@@AMMGEMMEEEEEMMMOOONOMMMMONMOOOOOOONN@@" "@@AOEEEGGEEEEEGGGGOGOGGGGGGGOOGOGOGGGN@@" "@@AJJJJJJJJJJJJJJKNKNJJJJJJKKJNJJNJJJF@@" "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCN@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOON@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGN@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNN@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFN@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMN@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGN@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMJ@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFJ@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOON@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKF@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCN@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "OOAKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOFGO" "OOAOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMNGO" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 164))) (40 (({(READBITMAP)(160 43 "@@ANJJKKJJJJJKKCKCOCMCKKKKKKKKKKKKKCCN@@" "@@AOMEMMMEEEEEOOMMOMLMMMMOOOOOOOOOOOON@@" "@@AMEEGGEFJJNNLONIGGGGGGGGGGOGGOGOGGGN@@" "@@AJJJJJIJFALFLOOKBJJJJJJJJKNJKJOJJJNN@@" "@@AKJKKCICOOONONLBGCCCKKKKCKOKKKOKKCFN@@" "@@AOMOMMOL@ALBOHHGMOOMMMMMOOOMOOOOOOMN@@" "@@AOGGGOFMOOOMMMMDNGGGGGGGGOGGOGGGGGGN@@" "@@AJJJKNIJKJJJJJJJFJJJJJJJOJJNJJOJJJMJ@@" "@@AKKKKOIJJJJKKKCCOKCKKKKCOKKOKKOKCCFJ@@" "@@AMOOOONEEEEEMMMMOOOMMMMMOMMOOOOOOOON@@" "@@AOGGGOFEEEEEGGGGAGGGGGGGGGGOGGGGGGKF@@" "@@AJJJONOJJJJJJJJJLJJJJJJJJKNIOJJJJKOJ@@" "@@AKKKOOHJJJJJKKCCECCKKKKKKKKOMKKKCCMB@@" "@@AMOOOONEEEGGEMMOKMOMMMMMMMOOOOMOOOCN@@" "@@AOOGOOFEEEEEGGGGAOGGGGGGGGGGGGGGGGOF@@" "@@AKNKNJOJJJJJJJJJFJJJJJJJOJJJJOJJJKLJ@@" "@@AKOKOK@JJJJKKKCCNCCKKKKKOKKOKOKCCBOF@@" "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GO" "OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GO" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 181))) (40 (({(READBITMAP)(160 26 "@@AOOOOMNMEEGGMMMLGMMMMMMMOMOOOOOOOOMN@@" "@@AOGGOGDGEEEEGGGEKGGGGGGGGGGOGGGGGGGF@@" "@@ANOJOJOJJJJJJJNMJJJJJJJKJJJNJJJJJKJN@@" "@@AIOKOKFIEEEDDDNAKCCKKKKCOCKKKKKCCBKF@@" "@@AOOOOMMMEEGGOMOMMMMMMMMOOOOOOOOOOOMN@@" "@@AOOOGGGEEEEEGOGGGGGGGGGGOGGGGGGGGGGD@@" "@@AJOJJJJJJJJJKKJJJJJJJJJJJJJJJJJJJMNL@@" "@@@OCKKCCJJJJJKKKCGCCKKKKKKKKKKKKCCGCD@@" "@@@OOOMMMMOGGGGMMMOMMMMMMMOOOOMOOOOOML@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 198))) (40 (({(READBITMAP)(160 9 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 215))))) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/ACE-BOUNCINGBALL.ACE b/lispusers/ACE-BOUNCINGBALL.ACE new file mode 100644 index 00000000..79f0605a --- /dev/null +++ b/lispusers/ACE-BOUNCINGBALL.ACE @@ -0,0 +1 @@ +(FILECREATED "16-Oct-85 14:36:45" {ICE}LISP>BOUNCINGBALL.ACE;1 36754 ) (PRETTYCOMPRINT BOUNCINGBALLCOMS) (RPAQQ BOUNCINGBALLCOMS ((UGLYVARS ACE.CURRENT.SEQUENCE))) (READVARS ACE.CURRENT.SEQUENCE) (((100 (({(READBITMAP)(358 304 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 0 . 0))) (100 (({(READBITMAP)(80 72 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@AOO@@@@@@@@@" "@@@@@@@AOOOO@@@@@@@@" "@@@@@@@GOOOOL@@@@@@@" "@@@@@@AOOOOOO@@@@@@@" "@@@@@@GOOOOOOL@@@@@@" "@@@@@@OOOOOOON@@@@@@" "@@@@@AOOOOOOOO@@@@@@" "@@@@@COOOOOOOOH@@@@@" "@@@@@GOOOOOOOOL@@@@@" "@@@@@OOOOOOOOON@@@@@" "@@@@AOOOOOOOOOO@@@@@" "@@@@COOOOOOOOOOH@@@@" "@@@@COOOOOOOOOOH@@@@" "@@@@GOOOOOOOOOOL@@@@" "@@@@GOOOOOOOOOOL@@@@" "@@@@OOOOOOOOOOON@@@@" "@@@@OOOOOOOOOOON@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@COOOOOOOOOOOOH@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@AOOOOOOOOOOOO@@@@" "@@@@OOOOOOOOOOON@@@@" "@@@@OOOOOOOOOOON@@@@" "@@@@GOOOOOOOOOOL@@@@" "@@@@GOOOOOOOOOOL@@@@" "@@@@COOOOOOOOOOH@@@@" "@@@@COOOOOOOOOOH@@@@" "@@@@AOOOOOOOOOO@@@@@" "@@@@@OOOOOOOOON@@@@@" "@@@@@GOOOOOOOOL@@@@@" "@@@@@COOOOOOOOH@@@@@" "@@@@@AOOOOOOOO@@@@@@" "@@@@@@OOOOOOON@@@@@@" "@@@@@@GOOOOOOL@@@@@@" "@@@@@@AOOOOOO@@@@@@@" "@@@@@@@GOOOOL@@@@@@@" "@@@@@@@AOOOO@@@@@@@@" "@@@@@@@@AOO@@@@@@@@@")} 128 . 102))) (100 (({(READBITMAP)(96 76 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@COOOOH@@@@@@@" "@@@@@@@@@AOOOOOOOO@@@@@@" "@@@@@@@@COOOOOOOOOOH@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@OOOOOOOOOOOOON@@@" "@@@@@@GOOOOOOOOOOOOOOL@@" "@@@@@AOOOOOOOOOOOOOOOO@@" "@@@@@COOOOOOOOOOOOOOOOH@" "@@@@@OOOOOOOOOOOOOOOOON@" "@@@@AOOOOOOOOOOOOOOOOOO@" "@@@@COOOOOOOOOOOOOOOOOOH" "@@@@GOOOOOOOOOOOOOOOOOOL" "@@@@OOOOOOOOOOOOOOOOOOON" "@@@@OOOOOOOOOOOOOOOOOOON" "@@@AOOOOOOOOOOOOOOOOOOOO" "@@@AOOOOOOOOOOOOOOOOOOOO" "@@@AOOOOOOOOOOOOOOOOOOOO" "@@@AOOOOOOOOOOOOOOOOOOOO" "@@@AOOOOOOOOOOOOOOOOOOOO" "@@@@OOOOOOOOOOOOOOOOOOON" "@@@@OOOOOOOOOOOOOOOOOOON" "@@@@GOOOOOOOOOOOOOOOOOOL" "@@@@COOOOOOOOOOOOOOOOOOH" "@@@@AOOOOOOOOOOOOOOOOOO@" "@@@@@OOOOOOOOOOOOOOOOON@" "@@@@@COOOOOOOOOOOOOOOOH@" "@@@@@AOOOOOOOOOOOOOOOO@@" "@@@@@@GOOOOOOOOOOOOOOL@@" "@@@@@@@OOOOOOOOOOOOON@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@@COOOOOOOOOOH@@@@" "@@@@@@@@@AOOOOOOOO@@@@@@" "@@@@@@@@@@@COOOOH@@@@@@@")} 112 . 77))) (100 (({(READBITMAP)(96 76 "@@@@@@@@@@@@AOO@@@@@@@@@" "@@@@@@@@@@@AOOOO@@@@@@@@" "@@@@@@@@@@@GOOOOL@@@@@@@" "@@@@@@@@@@AOOOOOO@@@@@@@" "@@@@@@@@@@GOOOOOOL@@@@@@" "@@@@@@@@@@OOOOOOON@@@@@@" "@@@@@@@@@AOOOOOOOO@@@@@@" "@@@@@@@@@COOOOOOOOH@@@@@" "@@@@@@@@@GOOOOOOOOL@@@@@" "@@@@@@@@@OOOOOOOOON@@@@@" "@@@@@@@@AOOOOOOOOOO@@@@@" "@@@@@@@@COOOOOOOOOOH@@@@" "@@@@@@@@COOOOOOOOOOH@@@@" "@@@@@@@@GOOOOOOOOOOL@@@@" "@@@@@@@@GOOOOOOOOOOL@@@@" "@@@@@@@@OOOOOOOOOOON@@@@" "@@@@@@@@OOOOOOOOOOON@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@COOOOOOOOOOOOH@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@AOOOOOOOOOOOO@@@@" "@@@@@@@@OOOOOOOOOOON@@@@" "@@@@@@@@OOOOOOOOOOON@@@@" "@@@@@@@@GOOOOOOOOOOL@@@@" "@@@@@@@@GOOOOOOOOOOL@@@@" "@@@@@@@@COOOOOOOOOOH@@@@" "@@@@@@@@COOOOOOOOOOH@@@@" "@@@@@@@@AOOOOOOOOOO@@@@@" "@@@@@@@@@OOOOOOOOON@@@@@" "@@@@@@@@@GOOOOOOOOL@@@@@" "@@@@@@@@@COOOOOOOOH@@@@@" "@@@@@@@@@AOOOOOOOO@@@@@@" "@@@@@@@@@@OOOOOOON@@@@@@" "@@@@@@@@@@GOOOOOOL@@@@@@" "@@@@@@@@@@AOOOOOO@@@@@@@" "@@@@@@@@@@@GOOOOL@@@@@@@" "@@@@@@@@@@@AOOOO@@@@@@@@" "@@@@@@@@@@@@AOO@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@")} 112 . 77))) (100 (({(READBITMAP)(80 72 "@@@@@@@@@OOH@@@@@@@@" "@@@@@@@@OOOOH@@@@@@@" "@@@@@@@COOOON@@@@@@@" "@@@@@@@OOOOOOH@@@@@@" "@@@@@@COOOOOON@@@@@@" "@@@@@@GOOOOOOO@@@@@@" "@@@@@@OOOOOOOOH@@@@@" "@@@@@AOOOOOOOOL@@@@@" "@@@@@COOOOOOOON@@@@@" "@@@@@GOOOOOOOOO@@@@@" "@@@@@OOOOOOOOOOH@@@@" "@@@@AOOOOOOOOOOL@@@@" "@@@@AOOOOOOOOOOL@@@@" "@@@@COOOOOOOOOON@@@@" "@@@@COOOOOOOOOON@@@@" "@@@@GOOOOOOOOOOO@@@@" "@@@@GOOOOOOOOOOO@@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@AOOOOOOOOOOOOL@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@OOOOOOOOOOOOH@@@" "@@@@GOOOOOOOOOOO@@@@" "@@@@GOOOOOOOOOOO@@@@" "@@@@COOOOOOOOOON@@@@" "@@@@COOOOOOOOOON@@@@" "@@@@AOOOOOOOOOOL@@@@" "@@@@AOOOOOOOOOOL@@@@" "@@@@@OOOOOOOOOOH@@@@" "@@@@@GOOOOOOOOO@@@@@" "@@@@@COOOOOOOON@@@@@" "@@@@@AOOOOOOOOL@@@@@" "@@@@@@OOOOOOOOH@@@@@" "@@@@@@GOOOOOOO@@@@@@" "@@@@@@COOOOOON@@@@@@" "@@@@@@@OOOOOOH@@@@@@" "@@@@@@@COOOON@@@@@@@" "@@@@@@@@OOOOH@@@@@@@" "@@@@@@@@@OOH@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 128 . 102))))) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/ACE-FOUETTE.ACE b/lispusers/ACE-FOUETTE.ACE new file mode 100644 index 00000000..3a40c563 --- /dev/null +++ b/lispusers/ACE-FOUETTE.ACE @@ -0,0 +1 @@ +(FILECREATED "25-Sep-85 15:41:11" {ICE}LISP>FOUETTE.ACE;1 69626 ) (PRETTYCOMPRINT FOUETTECOMS) (RPAQQ FOUETTECOMS ((UGLYVARS ACE.CURRENT.SEQUENCE))) (READVARS ACE.CURRENT.SEQUENCE) (((200 (({(READBITMAP)(456 360 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CNCO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GN@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@GN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GFGL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CHC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GHCH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GO@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GN@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@LLN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@OOG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@GOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@COOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@OOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@G@GN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@CNAO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@L@@@OLCL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@OL@@GOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@CON@@COOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@OOH@@GOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@CO@@@COOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@OOH@@OOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@COOL@COOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@@@OOO@AOOHAO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@@ALCOOONCOHOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@@GH@AOOOLGHAH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@@N@@@@@GNCHAL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@AL@@@@@@G@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOON@@@@OL@G@@@@CO@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOH@AOOOOOOH@@@OOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOHOOOOOOOOLOH@@@@OON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@GOOOLAH@@CH@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@@@@@@@@@@CH@@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@@CON@@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OL@@FOOOOOH@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OH@@GOOOHCO@@AO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@OLF@@AOOLCN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@O@@@@ALGOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@O@@@@AH@ON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@AO@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@@COH@@@AOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@OKH@@@AMOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@ANCH@@@@@AO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@CLCH@@@@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@O@AH@@@@@@CL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@GN@@L@@@@@@@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@AOH@@O@@@@@@@GN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@GH@@@O@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@O@@@@O@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NAL@@@@CH@@@@@@@@OOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ALCH@@@@CH@AOON@@@@F@OOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ALC@@@@@CN@OOOO@@@@@@@@OOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ALF@@@@@AOOOLGOL@@@@@@@@ON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ALN@@@@@@GO@@@GO@@@@@@@@GOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOL@@@@@@GH@@@GON@@@@@@@@AO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OH@@@@@@C@@@@CAOL@@N@@@@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@@C@@@@AHCOOOOOH@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@@@AH@GOOIOL@@@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@AH@@@@@AOIOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@AH@@@@@@COOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@AH@@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@CL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@OL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@GO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@CON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@@FOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OF@COOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ONMOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COMO@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 0 . 0))) (200 (({(READBITMAP)(32 9 "@@@@O@@@" "@@AOON@@" "@@GOOOOO" "@@GH@COO" "@@G@@@@@" "@@GO@OKH" "@@AOOOOL" "@@@GOOOO" "@@@@@@@O")} 128 . 184) ({(READBITMAP)(48 29 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@C" "@@@@@@@@@@@O" "@@@@@@@@@@AO" "@@@@@@@@@@GN" "@@@@@@@@GOO@" "@@@@@@@OOOL@" "@@@@@@COON@@" "@@@@@AOL@@@@" "@@@@AOO@@@@@" "@@@COOH@@@@@" "@@GOO@@@@@@@" "@AOO@@@@@@@A" "@CO@@@@@CMKG" "@GHL@@@AOOOO" "@GOOOH@AOOON" "@GOOON@GH@@@" "@@@@@OHG@@@@" "@@@@@CLN@@@@" "@@@@@ANN@@@@" "@@@@@@OL@@@@" "@@@@@@AH@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 112 . 130) ({(READBITMAP)(112 142 "@@@@@LL@@@@@@@@@@@@@@@@@@@@@" "@@@@@OO@@@@@@@@@@@@@@@@@@@@@" "@@@@@OON@@@@@@@@@@@@@@@@@@@@" "@@@@@OOO@@@@@@@@@@@@@@@@@@@@" "@@@@AO@GH@@@@@@@@@@@@@@@@@@@" "@@@@AL@CH@@@@@@@@@@@@@@@@@@@" "@@@@CH@AH@@@@@@@@@@@@@@@@@@@" "@@@@CH@AL@@@@@@@@@@@@@@@@@@@" "@@@@CH@@L@@@@@@@@@@@@@@@@@@@" "@@@@CL@@N@@@@@@@@@@@@@@@@@@@" "@@@@AL@@F@@@@@@@@@@@@@@@@@@@" "@@@@AL@@F@@@@@@@@@@@@@@@@@@@" "@@@@AN@@F@@@@@@@@@@@@@@@@@@@" "@@@@@O@@O@@@@@@@@@@@@@@@@@@@" "@@@@@GHAO@@@@@@@@@@@@@@@@@@@" "@@@@@COON@@@@@@@@@@@@@@@@@@@" "@@@@@AOOF@@@@@@@@@@@@@@@@@@@" "@@@@@@@@F@@@@@@@@@@@@@@@@@@@" "@@@@@C@@G@@@@@@@@@@@@@@@@@@@" "@@@@@CH@G@@@@@@@@@@@@@@@@@@@" "@@@@@CH@C@@@@@@@@@@@@@@@@@@@" "@@@@@G@@C@@@@@@@@@@@@@@@@@@@" "@@@@CO@@CHL@@@@@@@@@@@@@@@@@" "@@@GON@@AMOH@@@@@@@@@@@@@@@@" "@@AOO@@@AOOOH@@@@@@@@@@@@@@@" "@@ON@@@@@OOON@@@@@@@@@@@@@@@" "OOO@@@@@@@COOOL@@@@@@@@@@@@@" "OOH@@@@@@@@AOOOH@@@@@@@@@@@@" "@@@@@@@@@@@@@GGOL@@@@@@@@@@@" "@@@GL@@@@@@@@@@OOOOON@@@@@@@" "@@CON@@@@@@@@@@AOOOOOO@@@@@@" "NGOLN@@@@@@@@@@@@@@OOOL@@@@@" "OON@N@@@@@@@@@@@@GOOOGOK@@@@" "CN@@N@@@@@@@@@@@COOOOOOOH@@@" "@@@@F@@@@@@GOH@GON@@AOHOL@@@" "@@@@F@@@@@@GOOOOOH@@@AOAO@@@" "@@@@G@@@@@@FOOON@@@@@@OOO@@@" "@@@@C@@@@@@F@@F@@@@@@@COL@@@" "@@@@C@@@@@@N@@@@@@@@@@@@@@@@" "@@@@C@@@@@@N@@@@@@@@@@@@@@@@" "@@@@C@@@@@AL@@@@@@@@@@@@@@@@" "@@@@CH@@@@CH@@@@@@@@@@@@@@@@" "@@@@CH@@@@G@@@@@@@@@@@@@@@@@" "@@@@CH@@@@F@@@@@@@@@@@@@@@@@" "@@@@AH@@@@N@@@@@@@@@@@@@@@@@" "@@@@AL@@@@N@@@@@@@@@@@@@@@@@" "@@@@AOL@@AL@@@@@@@@@@@@@@@@@" "@@@@AOOO@AL@@@@@@@@@@@@@@@@@" "@@@@CLOOOOL@@@@@@@@@@@@@@@@@" "@@@@GH@COOL@@@@@@@@@@@@@@@@@" "@@@@O@@@@CN@@@@@@@@@@@@@@@@@" "@@@AN@@@@AO@@@@@@@@@@@@@@@@@" "@@@GH@@@@@GH@@@@@@@@@@@@@@@@" "@@@OH@@@@@AL@@@@@@@@@@@@@@@@" "@@ON@@@@@@@N@@@@@@@@@@@@@@@@" "@@OL@@@@@@@N@@@@@@@@@@@@@@@@" "@AON@@@@@@@N@@@@@@@@@@@@@@@@" "@GNO@@@@@@@N@@@@@@@@@@@@@@@@" "AOHGH@@@@@@GH@@@@@@@@@@@@@@@" "OOHCH@@@@@@CH@@@@@@@@@@@@@@@" "OL@AL@@@@AOOH@@@@@@@@@@@@@@@" "H@@AN@@@@GOOH@@@@@@@@@@@@@@@" "@@@@N@@@@GON@@@@@@@@@@@@@@@@" "@@@@F@@@@NAH@@@@@@@@@@@@@@@@" "@@@@G@@@GLAL@@@@@@@@@@@@@@@@" "@@@COH@@OHAL@@@@@@@@@@@@@@@@" "@@@GOL@AL@AL@@@@@@@@@@@@@@@@" "@@AOKN@AL@AL@@@@@@@@@@@@@@@@" "@OOL@G@CH@AH@@@@@@@@@@@@@@@@" "COO@@COO@@AH@@@@@@@@@@@@@@@@" "GH@@@CON@@AH@@@@@@@@@@@@@@@@" "OH@@@@OL@@AH@@@@@@@@@@@@@@@@" "N@@@@@GH@@AH@@@@@@@@@@@@@@@@" "H@@@@@CH@@AH@@@@@@@@@@@@@@@@" "@@@@@@CH@@AH@@@@@@@@@@@@@@@@" "@@@@@@AH@@CH@@@@@@@@@@@@@@@@" "@@@@@@AH@@CH@@@@@@@@@@@@@@@@" "@@@@@@CH@@CH@@@@@@@@@@@@@@@@" "@@@@@@CH@@C@@@@@@@@@@@@@@@@@" "@@@@@@C@@@G@@@@@@@@@@@@@@@@@" "@@@@@@C@@@G@@@@@@@@@@@@@@@@@" "@@@@@@C@@@G@@@@@@@@@@@@@@@@@" "@@@@@@G@@@N@@@@@@@@@@@@@@@@@" "@@@@@@G@@@L@@@@@@@@@@@@@@@@@" "@@@@@@G@@@L@@@@@@@@@@@@@@@@@" "@@@@@@F@@AL@@@@@@@@@@@@@@@@@" "@@@@@@F@@AL@@@@@@@@@@@@@@@@@" "@@@@@@N@@CH@@@@@@@@@@@@@@@@@" "@@@@@@N@@CH@@@@@@@@@@@@@@@@@" "@@@@@@L@@C@@@@@@@@@@@@@@@@@@" "@@@@@AL@@G@@@@@@@@@@@@@@@@@@" "@@@@@AL@@F@@@@@@@@@@@@@@@@@@" "@@@@@AH@@N@@@@@@@@@@@@@@@@@@" "@@@@@AH@@L@@@@@@@@@@@@@@@@@@" "@@@@@AH@@L@@@@@@@@@@@@@@@@@@" "@@@@@CH@AL@@@@@@@@@@@@@@@@@@" "@@@@@C@@AL@@@@@@@@@@@@@@@@@@" "@@@@@G@@CH@@@@@@@@@@@@@@@@@@" "@@@@@N@@CH@@@@@@@@@@@@@@@@@@" "@@@@@N@@C@@@@@@@@@@@@@@@@@@@" "@@@@AL@@C@@@@@@@@@@@@@@@@@@@" "@@@@AL@AK@@@@@@@@@@@@@@@@@@@" "@@@@AL@CO@@@@@@@@@@@@@@@@@@@" "@@@@AH@CN@@@@@@@@@@@@@@@@@@@" "@@@@AH@AN@@@@@@@@@@@@@@@@@@@" "@@@@AH@CN@@@@@@@@@@@@@@@@@@@" "@@@@CH@CN@@@@@@@@@@@@@@@@@@@" "@@@@C@@GL@@@@@@@@@@@@@@@@@@@" "@@@@C@@GL@@@@@@@@@@@@@@@@@@@" "@@@@C@@OL@@@@@@@@@@@@@@@@@@@" "@@@@C@@OH@@@@@@@@@@@@@@@@@@@" "@@@@C@AL@@@@@@@@@@@@@@@@@@@@" "@@@@G@AL@@@@@@@@@@@@@@@@@@@@" "@@@@F@CH@@@@@@@@@@@@@@@@@@@@" "@@@@G@CH@@@@@@@@@@@@@@@@@@@@" "@@@@G@C@@@@@@@@@@@@@@@@@@@@@" "@@@@N@G@@@@@@@@@@@@@@@@@@@@@" "@@@@L@G@@@@@@@@@@@@@@@@@@@@@" "@@@AL@F@@@@@@@@@@@@@@@@@@@@@" "@@@AL@N@@@@@@@@@@@@@@@@@@@@@" "@@@CHAN@@@@@@@@@@@@@@@@@@@@@" "@@@CHAL@@@@@@@@@@@@@@@@@@@@@" "@@@G@AL@@@@@@@@@@@@@@@@@@@@@" "@@@G@AH@@@@@@@@@@@@@@@@@@@@@" "@@@N@AH@@@@@@@@@@@@@@@@@@@@@" "@@@L@AH@@@@@@@@@@@@@@@@@@@@@" "@@@L@AL@@@@@@@@@@@@@@@@@@@@@" "@@@L@AL@@@@@@@@@@@@@@@@@@@@@" "@@@N@AL@@@@@@@@@@@@@@@@@@@@@" "@@@O@AN@@@@@@@@@@@@@@@@@@@@@" "@@@GL@O@@@@@@@@@@@@@@@@@@@@@" "@@@AN@GH@@@@@@@@@@@@@@@@@@@@" "@@@@GHCL@@@@@@@@@@@@@@@@@@@@" "@@@@COAN@@@@@@@@@@@@@@@@@@@@" "@@@@AOHN@@@@@@@@@@@@@@@@@@@@" "@@@@@GMO@@@@@@@@@@@@@@@@@@@@" "@@@@@FOO@@@@@@@@@@@@@@@@@@@@" "@@@@@@GO@@@@@@@@@@@@@@@@@@@@" "@@@@@@CO@@@@@@@@@@@@@@@@@@@@" "@@@@@@@L@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 160 . 75))) (200 (({(READBITMAP)(64 13 "@@@@@@@@@@@@@@@A" "@@@@@@@@@@@COOOO" "@@@@@@@@@@COOOOO" "@@@@@@@@AKOOH@F@" "@@@@@@@COON@@@@A" "@@@@@AOOOO@@@@@G" "@@@@AOOO@@@@@@CO" "@@@GOO@@OL@@AOOH" "@@AOOHANOOOOKON@" "@@CN@@GNMOOOKH@@" "@@COOOO@@@@@@@@@" "@@@GOOH@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 96 . 184) ({(READBITMAP)(48 148 "@@@@COL@@@@@" "@@@@GOO@@@@@" "@@@@OHGL@@@@" "@@@AN@CN@@@@" "@@@AL@@N@@@@" "@@@AH@@F@@@@" "@@@AH@@G@@@@" "@@@CH@@G@@@@" "@@@CH@@C@@@@" "@@@AH@@CH@@@" "@@@AL@@CH@@@" "@@@AL@@CH@@@" "@@@@L@@C@@@@" "@@@@N@@C@@@@" "@@@@O@@G@@@@" "@@@@OMOO@@@@" "@@@@GOOL@@@@" "@@@@COLL@@@@" "@@@@AH@L@@@@" "@@@@AN@N@@@@" "@@@@@N@OL@@@" "@@@@AL@COL@@" "@@@@OL@@OOOO" "@@@OOH@@@GOO" "@@GON@@@@AL@" "@AOH@@@@@@@@" "@GN@@@@@@@@@" "COH@@@@@@@@@" "ON@@@@@@@@@@" "O@@@@@@@@@@G" "@@@@@@@@@@CO" "@OH@@@@@@@CN" "OOOH@@@@@@CH" "OOGL@@@@@@C@" "H@AN@@@@@@C@" "@@@O@@@@@@C@" "@@@G@@@@@@C@" "@@@G@@@@@@C@" "@@@CH@@@@@C@" "@@@CH@@@@@G@" "@@@AH@@@@@F@" "@@@AH@@@@@F@" "@@@AL@@@@@F@" "@@@@N@@@@@F@" "@@@@F@@@@@N@" "@@@@F@@@@@O@" "@@@@G@@@@@G@" "@@@@G@@@@@N@" "@@@@G@@@@@N@" "@@@AOON@@AL@" "@@@CLOOOOON@" "@@@CH@GOOOO@" "@@@G@@@@AHG@" "@@AO@@@@@@C@" "@@ON@@@@@@CH" "@OO@@@@@@@AH" "OOH@@@@@@@AL" "OL@@@@@@@@@L" "L@@@@@@@@@@N" "@@@@@@@@@@@F" "@@@@@@@@@@@G" "MH@@@@@@@@@G" "OOH@@@@@@@@C" "OON@@@@@@@@C" "@AOOL@@@@@@A" "@@GOO@@@@@@@" "@@@AO@@@@@@@" "@@@AH@@@@@@@" "@@@CO@@@@@@@" "GOOOOL@@@@@@" "OOOOIOH@@@@@" "O@@@@ON@@@@@" "GL@@@CN@@@@@" "COOH@AON@@@@" "@OOO@AOON@@@" "@@AO@@LCN@@@" "@@@CH@L@OO@C" "@@@AH@L@COOO" "@@@AH@L@@COO" "@@@AL@L@@C@@" "@@@AN@L@@C@@" "@@@@OOO@@COO" "@@@@COO@@COO" "@@@@@OO@@C@C" "@@@@@@N@@C@@" "@@@@@@F@@C@@" "@@@@@@F@@C@@" "@@@@@@N@@C@@" "@@@@@@N@@G@@" "@@@@@@N@@G@@" "@@@@@@N@@G@@" "@@@@@@N@@F@@" "@@@@@@N@@N@@" "@@@@@@N@@N@@" "@@@@@@L@@L@@" "@@@@@@L@@N@@" "@@@@@@L@@N@@" "@@@@@@L@@L@@" "@@@@@@L@@L@@" "@@@@@@N@@L@@" "@@@@@@F@@N@@" "@@@@@@F@@N@@" "@@@@@@N@@L@@" "@@@@@@N@@L@@" "@@@@@@F@AL@@" "@@@@@@N@AL@@" "@@@@@@N@@L@@" "@@@@@AL@@L@@" "@@@@@AL@AL@@" "@@@@@@L@AH@@" "@@@@@AL@AH@@" "@@@@@AL@AH@@" "@@@@@@L@AH@@" "@@@@@@L@AH@@" "@@@@@@N@AH@@" "@@@@@@F@CH@@" "@@@@@@F@CH@@" "@@@@@@F@CH@@" "@@@@@@N@C@@@" "@@@@@@N@C@@@" "@@@@@@N@C@@@" "@@@@@@N@G@@@" "@@@@@@F@G@@@" "@@@@@@N@F@@@" "@@@@@@N@F@@@" "@@@@@@L@N@@@" "@@@@@@L@L@@@" "@@@@@AL@L@@@" "@@@@@CH@L@@@" "@@@@@CH@L@@@" "@@@@@C@@L@@@" "@@@@@C@@L@@@" "@@@@@C@@N@@@" "@@@@@C@@N@@@" "@@@@@CH@N@@@" "@@@@@AH@O@@@" "@@@@@AH@O@@@" "@@@@@AL@O@@@" "@@@@@AL@O@@@" "@@@@@@L@O@@@" "@@@@@@L@G@@@" "@@@@@@N@G@@@" "@@@@@@N@G@@@" "@@@@@@N@F@@@" "@@@@@@N@N@@@" "@@@@@@GGL@@@" "@@@@@@GOL@@@" "@@@@@@GN@@@@")} 160 . 77) ({(READBITMAP)(80 26 "@@@@@@CAOO@@C@@@@@@@" "@@@@@AOOOOOOOON@@@@@" "OL@@@OOOOMOONOOL@@@@" "OON@AMOOOOOGHAON@@@@" "CONGOMH@COOOO@@O@@@@" "@AOOOH@COHGOOLAOH@@@" "@@@@@@GON@@@AOOOH@@@" "@@@@@@ON@@@@@OON@@@@" "@@@@@GOL@@@@@CH@@@@@" "OOOOOOH@@@@@@@@@@@@@" "OOOOOL@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 208 . 179) ({(READBITMAP)(160 40 "@@@@@@@@@@@@@@@@@@@@@@@@@@@AOON@@AL@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@CLOOOOON@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@GOOOO@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@AHG@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@AO@@@@@@C@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@ON@@@@@@CH@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@OO@@@@@@@AH@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@OOH@@@@@@@AL@@@@" "@@@@@@@@@@@@@@@@@@@@@@@COL@@@@@@@@@L@@@@" "@@@@@@@@@@@@@@@@@@@@@@@OL@@@@@@@@@@N@@@@" "@@@@@@@@@@@@@@@@@@@@@FOO@@@@@@@@@@@F@@@@" "@@@@@@@@@@@@@@@@@@@@@FOH@@@@@@@@@@@G@@@@" "@@@@@@@@@@@@@@@@@@@GKOOOMH@@@@@@@@@G@@@@" "@@@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@CH@@@" "@@@@@@@@@@@@@@@@@OONGH@COON@@@@@@@@CL@@@" "@@@@@@@@@@@@@L@AOOL@@@@@@AOOL@@@@@@AN@@@" "@@@@@@@@FLGONOOOOL@@@@@@@@GOO@@@@@@@OH@@" "@@@@@@AOOOOONOON@@@@@@@@@@@AO@@@@@@@GN@@" "@@@@@GOOMOOH@@@@@@@@@@@@@@@AH@@@@@@@AO@@" "@@@AOOOH@@@@@@@@@@@@@@@@@@@CO@@@@@@@@CL@" "@@@CON@@@@@@@@@@@@@@@CONGOOOOL@@@@@@@@N@" "@@@COO@@@@@N@@@@COHCOOOOOOOOIOH@@@@@@@O@" "@@@COON@@@OO@OOOOOOOOOHGO@@@@ON@@@@@@@CH" "@@@@@CN@@@OOOOOOO@OOH@@@GL@@@CN@@@@@@@AH" "@@@@@@GL@AL@ON@@@@@@@@@@COOH@AON@@@@@@AL" "@@@@@@AO@CH@@@@@@@@@@@@@@OOO@AOON@@@@@@L" "@@@@@@@OHO@@@@@@@@@@@@@@@@AO@@LCN@@@@@@L" "@@@@@@@AON@@@@@@@@@@@@@@@@@CH@L@OO@CLCNN" "@@@@@@@AOL@@@@@@@@@@@@@@@@@AH@L@COOOOOON" "@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@L@@COOOLGN" "@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@L@@C@@@@AN" "@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@L@@C@@@@@N" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOO@@COOO@@N" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@COO@@COOOOKN" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@C@CKOOH" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@C@@@@N@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@C@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@C@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@C@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@G@@@@@@")} 64 . 136))) (200 (({(READBITMAP)(64 15 "@@@@@@@@@@@@@@CO" "@@@@GL@@@@@@@OOO" "@@@COOOKOOOOOONF" "@@@COOOKOOOOOH@@" "@@@CL@@@@AIN@@@@" "@@@AOH@@@@@@@@@A" "@@@AOOOOOOOOOOGO" "@@@@COOOOOOOOOOO" "@@@@@O@@@L@N@AL@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 96 . 185) ({(READBITMAP)(64 13 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "N@@@@@@@@@@@@@@@" "OO@@CKOLOOO@@@@@" "GOOOOOOOOOOOLO@@" "@GOONOOOGOOOOON@" "@@@@@@GOOOONCOO@" "OF@@@OOOLOGOOOO@" "OOOOOOH@@@@OOIO@" "AKOOOL@@@@@@C@@@" "@@AH@@@@@@@@@@@@")} 224 . 192) ({(READBITMAP)(64 14 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 64 . 147) ({(READBITMAP)(112 153 "@@@@@@@@@@@@@@@@GN@@@@@@@@@@" "@@@@@@@@@@@@@@@CON@@@@@@@@@@" "@@@@@@@@@@@@@@@GOOH@@@@@@@@@" "@@@@@@@@@@@@@@@OHCL@@@@@@@@@" "@@@@@@@@@@@@@@@N@AN@@@@@@@@@" "@@@@@@@@@@@@@@@L@@G@@@@@@@@@" "@@@@@@@@@@@@@@AL@@C@@@@@@@@@" "@@@@@@@@@@@@@@AL@@CH@@@@@@@@" "@@@@@@@@@@@@@@AH@@CH@@@@@@@@" "@@@@@@@@@@@@@@AH@@C@@@@@@@@@" "@@@@@@@@@@@@@@AH@@C@@@@@@@@@" "@@@@@@@@@@@@@@CH@@C@@@@@@@@@" "@@@@@@@@@@@@@@CH@@G@@@@@@@@@" "@@@@@@@@@@@@@@CL@@F@@@@@@@@@" "@@@@@@@@@@@@@@AO@AN@@@@@@@@@" "@@@@@@@@@@@@@@@ONCN@@@@@@@@@" "@@@@@@@@@@@@@@@GOOL@@@@@@@@@" "@@@@@@@@@@@@@@@COOL@@@@@@@@@" "@@@@@@@@@@@@@@@AH@N@@@@@@@@@" "@@@@@@@@@@@@@@@AH@F@@@@@@@@@" "@@@@@@@@@@@@@@@AH@F@@@@@@@@@" "@@@@@@@@@@@@@@@AH@F@@@@@@@@@" "@@@@@@@@@@@@@@@GH@F@@@@@@@@@" "@@@@@@@@@@@@@@@G@@N@@@@@@@@@" "@@@@@@@@@@@@@MOF@@O@@@@@@@@@" "@@@@@@@@@@@@OOO@@@GH@@@@@@@@" "@@@@@@@@@@@AOOH@@@CN@@@@@@@@" "@@@@@@@@@@COL@@@@@@OH@C@@@@@" "@@@@@@@@@COOH@@@@@@COOON@@@@" "@@@@@@@@CON@@@@@@@@@OOOON@@@" "@@@@@@COOO@@@@@@@@@@@@@COO@@" "@@@@@OOOL@@@@@@@@@@@@@@@GOOO" "OOOOOONF@@@@F@@@@@@@@CH@@GOO" "OOOOOH@@@OMOO@@@@@@@@GK@@@@@" "@AIN@@@@OOMOOO@@@@@@@GOOOF@@" "@@@@@@@AON@@CO@@@@@@@CMOOOOO" "OOOOOOGOL@@@@N@@@@@@@G@@AKOO" "OOOOOOOO@@@@@F@@@@@@@G@@@@AH" "@L@N@AL@@@@@@G@@@@@@@G@@@@@@" "@@@@@@@@@@@@@C@@@@@@@F@@@@@@" "@@@@@@@@@@@@@C@@@@@@@F@@@@@@" "@@@@@@@@@@@@@C@@@@@@@F@@@@@@" "@@@@@@@@@@@@@CH@@@@@@N@@@@@@" "@@@@@@@@@@@@@AH@@@@@@N@@@@@@" "@@@@@@@@@@@@@AH@@@@@AL@@@@@@" "@@@@@@@@@@@@@AH@@@@@AL@@@@@@" "@@@@@@@@@@@@@AL@@@@@CL@@@@@@" "@@@@@@@@@@@@@@N@@@@@CH@@@@@@" "@@@@@@@@@@@@@@N@@@@@C@@@@@@@" "@@@@@@@@@@@@@@F@@@@@G@@@@@@@" "@@@@@@@@@@@@@@GOL@@@G@@@@@@@" "@@@@@@@@@@@@@@GOOON@C@@@@@@@" "@@@@@@@@@@@@@COIOOOOOH@@@@@@" "@@@@@@@@@@@@@CN@@COOON@@@@@@" "@@@@@@@@@@@@@O@@@@@@@O@@@@@@" "@@@@@@@@@@@@CN@@@@@@@GH@@@@@" "@@@@@@@@@@@@OH@@@@@@@AL@@@@@" "@@@@@@@@@@@AN@@@@@@@@@N@@@@@" "@@@@@@@@@@@OL@@@@@@@@@GH@@@@" "@@@@@@@@@@CO@@@@@@@@@@CN@@@@" "@@@@@@@@@OOL@@@@@@@@@@AO@@@@" "@@@@@@@AOOO@@@@@@@@@@@@CL@@@" "@@@@@@AOOMKL@@@@@@@@@@@AN@@@" "@@@@AOOO@@AO@@@@@@@@@@@@GL@@" "@@@AOOO@@@@GH@@@@@@@@@@@CN@@" "@@@GNL@@@@@CN@@@@@@@@@@@@G@@" "@@@GH@@@@@@@OL@@@@@@@@@@@CL@" "@@@G@@@@@@@@CO@@@@@@@@@@@AN@" "@@@N@@@@@@@@AOH@@@@@@@@@@@O@" "@@AL@@@@@@@@@CN@@@@@@@@@@@CH" "@@AL@@@@@@@@@GOC@@@@@@@@@@CH" "@@CH@@@@@@OOOOOOHLF@@@@@@ON@" "@@CH@@@@GOOOOO@ONOO@@@@@COOH" "@@G@@@COOONOMH@COOOL@@@@G@GH" "@@G@@@GOOL@CH@@@ONAO@@@CN@AH" "@@O@@AON@@@AL@@@L@@GHFCOL@C@" "@@N@@CN@@@@AL@@AL@@ALNOL@@G@" "@AN@@GL@@@@@L@@AL@@@OOO@@@G@" "@AL@@G@@@@@@O@@@L@@@OOL@OLF@" "@AH@@F@@@@@@OO@@L@@@AOOOONG@" "@AH@@N@@@@@@CON@L@@@AOOOHOG@" "@CH@CL@@@@@@@CO@N@@@GH@@@CO@" "@G@@CH@@@@@@@@GLN@@@G@@@@AN@" "@O@@G@@@@@@@@@COOH@@N@@@@@@@" "@N@@F@@@@@@@@@@GOH@@N@@@@@@@" "@N@@N@@@@@@@@@@@N@@@N@@@@@@@" "AL@AN@@@@@@@@@@@L@@AL@@@@@@@" "AL@OL@@@@@@@@@@@L@@CH@@@@@@@" "AHGOL@@@@@@@@@@@L@@CH@@@@@@@" "AIONL@@@@@@@@@@@L@@C@@@@@@@@" "CIOAL@@@@@@@@@@AL@@G@@@@@@@@" "CILCL@@@@@@@@@@AL@@G@@@@@@@@" "C@@OH@@@@@@@@@@AH@@F@@@@@@@@" "G@GO@@@@@@@@@@@AH@@N@@@@@@@@" "GAOL@@@@@@@@@@@CH@@L@@@@@@@@" "GON@@@@@@@@@@@@CH@@L@@@@@@@@" "GOH@@@@@@@@@@@@C@@AL@@@@@@@@" "GL@@@@@@@@@@@@@G@@AH@@@@@@@@" "@@@@@@@@@@@@@@@G@@AH@@@@@@@@" "@@@@@@@@@@@@@@@G@@AH@@@@@@@@" "@@@@@@@@@@@@@@@G@@AH@@@@@@@@" "@@@@@@@@@@@@@@@G@@AH@@@@@@@@" "@@@@@@@@@@@@@@@G@@AH@@@@@@@@" "@@@@@@@@@@@@@@@C@@CH@@@@@@@@" "@@@@@@@@@@@@@@@C@@CH@@@@@@@@" "@@@@@@@@@@@@@@@CH@C@@@@@@@@@" "@@@@@@@@@@@@@@@CH@C@@@@@@@@@" "@@@@@@@@@@@@@@@C@@GH@@@@@@@@" "@@@@@@@@@@@@@@@G@@GH@@@@@@@@" "@@@@@@@@@@@@@@@F@@G@@@@@@@@@" "@@@@@@@@@@@@@@@F@@G@@@@@@@@@" "@@@@@@@@@@@@@@@N@@G@@@@@@@@@" "@@@@@@@@@@@@@@AL@@O@@@@@@@@@" "@@@@@@@@@@@@@@AL@@N@@@@@@@@@" "@@@@@@@@@@@@@@@L@@N@@@@@@@@@" "@@@@@@@@@@@@@@@L@@L@@@@@@@@@" "@@@@@@@@@@@@@@@L@AL@@@@@@@@@" "@@@@@@@@@@@@@@@N@AL@@@@@@@@@" "@@@@@@@@@@@@@@@N@AH@@@@@@@@@" "@@@@@@@@@@@@@@@N@AH@@@@@@@@@" "@@@@@@@@@@@@@@@N@C@@@@@@@@@@" "@@@@@@@@@@@@@@@L@G@@@@@@@@@@" "@@@@@@@@@@@@@@@L@G@@@@@@@@@@" "@@@@@@@@@@@@@@@L@G@@@@@@@@@@" "@@@@@@@@@@@@@@@L@G@@@@@@@@@@" "@@@@@@@@@@@@@@@L@F@@@@@@@@@@" "@@@@@@@@@@@@@@@L@N@@@@@@@@@@" "@@@@@@@@@@@@@@@L@L@@@@@@@@@@" "@@@@@@@@@@@@@@AL@L@@@@@@@@@@" "@@@@@@@@@@@@@@AL@L@@@@@@@@@@" "@@@@@@@@@@@@@@CHAL@@@@@@@@@@" "@@@@@@@@@@@@@@G@AL@@@@@@@@@@" "@@@@@@@@@@@@@@N@AH@@@@@@@@@@" "@@@@@@@@@@@@@@N@CH@@@@@@@@@@" "@@@@@@@@@@@@@AL@CH@@@@@@@@@@" "@@@@@@@@@@@@@AL@CH@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@G@@@@@@@@@@@" "@@@@@@@@@@@@@@L@G@@@@@@@@@@@" "@@@@@@@@@@@@@@L@G@@@@@@@@@@@" "@@@@@@@@@@@@@@L@C@@@@@@@@@@@" "@@@@@@@@@@@@@@L@G@@@@@@@@@@@" "@@@@@@@@@@@@@@L@F@@@@@@@@@@@" "@@@@@@@@@@@@@@N@N@@@@@@@@@@@" "@@@@@@@@@@@@@@OMN@@@@@@@@@@@" "@@@@@@@@@@@@@@OOH@@@@@@@@@@@" "@@@@@@@@@@@@@@GO@@@@@@@@@@@@")} 128 . 77))) (200 (({(READBITMAP)(48 7 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 240 . 193) ({(READBITMAP)(144 153 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@AOOLC@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@AOL@CH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@CN@@CH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GN@@AL@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GN@@AL@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GO@@@L@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GGN@@L@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GCO@@L@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@F@CH@L@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@N@AHAL@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@N@AHAH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@F@AHMH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@F@AHOH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@G@COO@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@G@GOO@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GNFGN@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GN@@N@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@AN@@N@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@N@@OH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@AL@@GO@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@AOL@@AOL@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@GO@@@@ON@@@@@@@@@@@" "@@@@@@@@@@@@@@@@COH@@@@@GH@@@@@@@@@@" "@@@@@@@@@@@@@@@@OL@@@@@@CH@@@@@@@@@@" "@@@@@@@@@@@@@@GOO@@@@@@@AL@@@@@@@@@@" "@@@@@@@@@@@@@AOOH@@@@@@@@N@@@@@@@@@@" "@@@@@@@@@@@@@GL@@@@@@@@@@N@@@@@@@@@@" "@@@@@@@@@@@@@OH@@@@@@@@@@G@@@@@@@@@@" "@@@@@@@@@@@@AL@@@@@@@@@@@C@@@@@@@@@@" "@@@@@@@@@@@@CHAH@@@@@@@@CKH@@@@@@@@@" "@@@@@@@@@@@@OHCOOL@@@@@@CIH@@@@@@@@@" "@@@@@@@@@@@CNAOOON@@@@@@CIH@@@@@@@@@" "@@@@@@@@@@@GHGO@@N@@@@@@CIH@@@@@@@@@" "@@@@@@@@@@CNCOH@@F@@@@@@GAH@@@@@@@@@" "@@@@@@@@@@OMOL@@@N@@@@@@GAH@@@@@@@@@" "@@@@@@@@@AOAN@@@@N@@@@@@FAH@@@@@@@@@" "@@@@@@@@@CLGH@@@@N@@@@@@NAL@@@@@@@@@" "@@@@@@@@@GAO@@@@@N@@@@@@LAL@@@@@@@@@" "@@@@@@@@@OON@@@@@G@@@@@ALCL@@@@@@@@@" "@@@@@@@@@OO@@@@@@G@@@@@ALGH@@@@@@@@@" "@@@@@@@@@OH@@@@@@CH@@@@ALN@@@@@@@@@@" "@@@@@@@@@O@@@@@@@CH@@@@ALN@@@@@@@@@@" "@@@@@@@@@N@@@@@@@AL@@OOOML@@@@@@@@@@" "@@@@@@@@@@@@@@@@@AL@OOOOOL@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@LCOL@@OH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@NO@@@@GH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@OO@@@@CN@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@GH@@@@AO@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@C@@@@@@CN@@@@@@@@@" "@@@@@@@@@@@@@@@@@@C@@@@@@AOH@@@@@@@@" "@@@@@@@@@@@@@@@@@@C@@@@@@@GN@@@@@@@@" "@@@@@@@@@@@@@@@@@@G@@@@@@@@O@@@@@@@@" "@@@@@@@@@@@@@@@@@@F@@@@@@@@CH@@@@@@@" "@@@@@@@@@@@@@@@@@@N@@@@@@@@CL@@@@@@@" "@@@@@@@@@@@@@@@@@AL@@@@@@@@@N@@@@@@@" "@@@@@@@@@@@@@@@@@AL@@@@@@@@@G@@@@@@@" "@@@@@@@@@@@@@@@@@AH@@@@@@@@@GH@@@@@@" "@@@@@@@@@@@@@@@@@AH@@@@@@@@@AL@@@@@@" "@@@@@@@@@@@@@@@@@OH@@@@@@@@@@O@@@@@@" "@@@@@@@@@@@@@@@@GOH@@@@@@@@@@GH@@@@@" "@@@@@@@@@@@@@@@@GL@@@@@@@@@@@CH@@@@@" "@@@@@@@@@@@@@@@@G@@@@@@@@@@@@AN@@@@@" "@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@O@@@@@" "@@@@@@@@@@@@@@@@F@@@@@GOOOOO@@GO@@@@" "@@@@@@@@@@@@@@@@GH@@@AOOOOOOL@AON@@@" "@@@@@@@@@@@@@@@@CN@@AOO@AOL@OH@GO@@@" "@@@@@@@@@@@@@@@@@OLAONG@@CN@GL@@CH@@" "@@@@@@@@@@@@@@@@@OOOO@G@@@N@AL@@AH@@" "@@@@@@@@@@@@@@@@@@ONL@CH@@N@@N@@CH@@" "@@@@@@@@@@@@@@@@@@L@@@CH@@N@AN@AOH@@" "@@@@@@@@@@@@@@@@@@F@@@CH@AL@AO@CN@@@" "@@@@@@@@@@@@@@@@@@F@@@CH@CL@AOOO@@@@" "@@@@@@@@@@@@@@@@@@F@@@CH@CH@AIOO@@@@" "@@@@@@@@@@@@@@@@@@G@@@AH@CH@CIKH@@@@" "@@@@@@@@@@@@@@@@@@G@@@AH@O@@G@@@@@@@" "@@@@@@@@@@@@@@@@@@CH@@AL@N@@O@@@@@@@" "@@@@@@@@@@@@@@@@@@AL@@ALAL@AN@@@@@@@" "@@@@@@@@@@@@@@@@@@AL@@@LAL@AL@@@@@@@" "@@@@@@@@@@@@@@@@@@AL@@@LCH@CH@@@@@@@" "@@@@@@@@@@@@@@@@@@AN@@@LC@@GH@@@@@@@" "@@@@@@@@@@@@@@@@@@AN@@@LG@@N@@@@@@@@" "@@@@@@@@@@@@@@@@@@@F@@@LG@CL@@@@@@@@" "@@@@@@@@@@@@@@@@@@@F@@@NF@GH@@@@@@@@" "@@@@@@@@@@@@@@@@@@@GH@@FF@G@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@GH@@GN@O@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@CH@@GLCL@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@AL@@GHCH@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@L@@CHG@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@N@@CHG@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@F@@CHN@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@F@@CIL@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@G@@CKH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@G@@CCH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@F@@CO@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@F@@CN@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@G@@AL@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@G@@GH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@G@@GH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@C@@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@G@@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@GH@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@CH@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AH@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AH@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AH@AH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AH@AL@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AL@AL@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@L@AL@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@N@@L@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@F@@L@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@G@@L@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@C@@L@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@CH@N@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@AH@N@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@AL@N@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@AL@N@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@F@G@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@G@G@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@G@CL@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHCN@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CH@N@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@AH@N@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@AH@N@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@AH@L@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHAL@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHCH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHCH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHGH@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHO@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CIL@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CCH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CGH@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@CN@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 96 . 77))) (200 (({(READBITMAP)(112 150 "@@@@@@@@@@AH@@@@@@@@@@@@@@@@" "@@@@@@@@@@OON@@@@@@@@@@@@@@@" "@@@@@@@@@COOOH@@@@@@@@@@@@@@" "@@@@@@@@@CL@GH@@@@@@@@@@@@@@" "@@@@@@@@@CH@AH@@@@@@@@@@@@@@" "@@@@@@@@@G@@@L@@@@@@@@@@@@@@" "@@@@@@@@@G@@@N@@@@@@@@@@@@@@" "@@@@@@@@@G@@@F@@@@@@@@@@@@@@" "@@@@@@@@@G@@@G@@@@@@@@@@@@@@" "@@@@@@@@@G@@@CH@@@@@@@@@@@@@" "@@@@@@@@@G@@@CH@@@@@@@@@@@@@" "@@@@@@@@@GH@@CH@@@@@@@@@@@@@" "@@@@@@@@@CN@@AL@@@@@@@@@@@@@" "@@@@@@@@@AO@@@L@@@@@@@@@@@@@" "@@@@@@@@@AONL@N@@@@@@@@@@@@@" "@@@@@@@@@@COLCN@@@@@@@@@@@@@" "@@@@@@@@@@GCOON@@@@@@@@@@@@@" "@@@@@@@@@@GAOO@@@@@@@@@@@@@@" "@@@@@@@@@@CAL@@@@@@@@@@@@@@@" "@@@@@@@@@@CAL@@@@@@@@@@@@@@@" "@@@@@@@@@@LAOOH@@@@@@@@@@@@@" "@@@@@@@@@AL@OOOH@@@@@@@@@@@@" "@@@@@@@@@CL@@COH@@@@@@@@@@@@" "@@@@@@@@@CH@@@CL@@@@@@@@@@@@" "@@@@@@@@@CH@@@@O@@@@@@@@@@@@" "@@@@@@@@@CH@@@@G@@@@@@@@@@@@" "@@@@@@@@@CH@@@@CN@@@@@@@@@@@" "@@@@@@@@@CH@@@@AO@@@@@@@@@@@" "@@@@@@@@@CH@@@@@GL@@@@@@@@@@" "@@@@@@@@@CH@@@@@AO@@@@@@@@@@" "@@@@@@@@@G@@@@@@@GN@@@@@@@@@" "@@@@@@@@@G@@@OOH@AOH@@@@@@@@" "@@@@@@@@@G@@AOON@@GL@@@@@@@@" "@@@@@@@@@F@@CNCOH@AOH@@@@@@@" "@@@@@@@@@F@@O@OCL@@GN@@@@@@@" "@@@@@@@@@F@ANAO@L@@AN@@@@@@@" "@@@@@@@@@F@AHAN@O@@@G@@@@@@@" "@@@@@@@@@N@@@AN@CH@@G@@@@@@@" "@@@@@@@@@N@@@@N@CO@@GH@@@@@@" "@@@@@@@@@L@@@AN@@GH@CH@@@@@@" "@@@@@@@@@L@@@AH@@CN@CH@@@@@@" "@@@@@@@@@L@@@AH@@@ONN@@@@@@@" "@@@@@@@@@L@@@AL@@@GOL@@@@@@@" "@@@@@@@@@L@@@@L@@@@@@@@@@@@@" "@@@@@@@@@L@@@AL@@@@@@@@@@@@@" "@@@@@@@@AL@@@AL@@@@@@@@@@@@@" "@@@@@@@@AL@@@AL@@@@@@@@@@@@@" "@@@@@@@@AL@@@@L@@@@@@@@@@@@@" "@@@@@@@@AH@@@@L@@@@@@@@@@@@@" "@@@@@@@@ANOOO@L@@@@@@@@@@@@@" "@@@@@@@@COOOO@N@@@@@@@@@@@@@" "@@@@@@@@GON@CHN@@@@@@@@@@@@@" "@@@@@@@@G@@@CON@@@@@@@@@@@@@" "@@@@@@@@N@@@AOOH@@@@@@@@@@@@" "@@@@@@@AL@@@@AOO@@@@@@@@@@@@" "@@@@@@@AL@@@@@@OHOOL@@@@@@@@" "@@@@@@@CH@@@@@@AOOOOOH@@@@@@" "@@@@@@@CH@@@@@@@OOOOOL@@@@@@" "@@@@@@@C@@@@@@@@@@@@GO@@@@@@" "@@@@@@@G@@@@@@@@@@@@CO@@@@@@" "@@@@@@@G@@@@@@@@@@@@GK@@@@@@" "@@@@@@@F@@@@@@@@@@@@OKH@@@@@" "@@@@@@@F@@@@@@@@@@@@OOH@@@@@" "@@@@@@@N@@@@@@@@@@@AMOL@@@@@" "@@@@@@AL@@@@@@@@@@@ALAL@@@@@" "@@@@@@OL@@@@@@@@@@@CH@L@@@@@" "@@@@@OOH@@@@@@@@@@@C@@L@@@@@" "@@@@OOH@@@@@@@@@@@@O@@N@@@@@" "@@@COH@@@@@@@@@@@@CN@@F@@@@@" "@@@OL@@@@@@@@@@@@AOO@@G@@@@@" "@@AO@@@@@@@@@@@@@AOOH@G@@@@@" "@@AL@@@@@@@@@@@@@AOKH@G@@@@@" "@@CH@@@@@@@@@@@@@GLCH@C@@@@@" "@@CH@@@@@@@@@@FAOOLAL@C@@@@@" "@@G@@@@@@@@@@@GOOO@AL@C@@@@@" "@@F@@@AOOOH@@@COL@@AL@C@@@@@" "@@F@@@COOOL@@@CN@@@AL@CH@@@@" "@@N@@@GOCOO@@@OH@@@@N@AH@@@@" "@@L@@@G@@COH@COH@@@@N@AL@@@@" "@@L@@@F@@CKH@OIH@@@@G@AL@@@@" "@@L@@@F@@AIOOOAH@@@@G@AL@@@@" "@@N@@@F@@ALOOHAH@@@@CHAL@@@@" "@@GH@@F@@ALO@@AH@@@@AH@L@@@@" "@@GL@@F@@@N@@@AL@@@@AH@N@@@@" "@@AO@@F@@@N@@@AL@@@@AH@N@@@@" "@@@GOON@@@N@@@AL@@@@AH@F@@@@" "@@@@OOL@@@F@@@AL@@@@AL@G@@@@" "@@@@AOH@@@F@@@AH@@@@@N@G@@@@" "@@@@@@@@@@G@@@AH@@@@@F@CH@@@" "@@@@@@@@@@C@@@AL@@@@@G@AH@@@" "@@@@@@@@@@CH@@AL@@@@@GHAH@@@" "@@@@@@@@@@CH@@AH@@@@@AHAL@@@" "@@@@@@@@@@AL@@AL@@@@@AH@L@@@" "@@@@@@@@@@AL@@AL@@@@@AL@O@@@" "@@@@@@@@@@AL@@AL@@@@@@L@G@@@" "@@@@@@@@@@@L@@AH@@@@@@N@CH@@" "@@@@@@@@@@@N@@AL@@@@@@N@AN@@" "@@@@@@@@@@@G@@AL@@@@@@N@@N@@" "@@@@@@@@@@@G@@CH@@@@@@N@@G@@" "@@@@@@@@@@@G@@CH@@@@@@N@@GH@" "@@@@@@@@@@@C@@C@@@@@@@G@@CH@" "@@@@@@@@@@@O@@C@@@@@@@G@@CH@" "@@@@@@@@@@@N@@G@@@@@@@CH@AH@" "@@@@@@@@@@AN@@N@@@@@@@CL@AH@" "@@@@@@@@@@AL@@L@@@@@@@AN@AH@" "@@@@@@@@@@AL@@L@@@@@@@@O@AL@" "@@@@@@@@@@CH@AL@@@@@@@@G@AL@" "@@@@@@@@@@CH@AH@@@@@@@@G@AH@" "@@@@@@@@@@C@@CH@@@@@@@@C@AH@" "@@@@@@@@@@G@@C@@@@@@@@@C@CH@" "@@@@@@@@@@G@@C@@@@@@@@@CHC@@" "@@@@@@@@@@G@@G@@@@@@@@@CHG@@" "@@@@@@@@@@G@@G@@@@@@@@@AON@@" "@@@@@@@@@@G@@F@@@@@@@@@@ON@@" "@@@@@@@@@@G@@N@@@@@@@@@@GL@@" "@@@@@@@@@@G@@L@@@@@@@@@@@@@@" "@@@@@@@@@@C@@L@@@@@@@@@@@@@@" "@@@@@@@@@@CHAL@@@@@@@@@@@@@@" "@@@@@@@@@@CHAL@@@@@@@@@@@@@@" "@@@@@@@@@@CHAH@@@@@@@@@@@@@@" "@@@@@@@@@@AHAH@@@@@@@@@@@@@@" "@@@@@@@@@@CHAH@@@@@@@@@@@@@@" "@@@@@@@@@@CHAH@@@@@@@@@@@@@@" "@@@@@@@@@@AHAH@@@@@@@@@@@@@@" "@@@@@@@@@@CHAH@@@@@@@@@@@@@@" "@@@@@@@@@@CHAH@@@@@@@@@@@@@@" "@@@@@@@@@@AHAH@@@@@@@@@@@@@@" "@@@@@@@@@@AHAH@@@@@@@@@@@@@@" "@@@@@@@@@@CHCH@@@@@@@@@@@@@@" "@@@@@@@@@@CHCH@@@@@@@@@@@@@@" "@@@@@@@@@@CHAH@@@@@@@@@@@@@@" "@@@@@@@@@@GHAH@@@@@@@@@@@@@@" "@@@@@@@@@@G@AH@@@@@@@@@@@@@@" "@@@@@@@@@@C@AL@@@@@@@@@@@@@@" "@@@@@@@@@@G@AL@@@@@@@@@@@@@@" "@@@@@@@@@@F@@L@@@@@@@@@@@@@@" "@@@@@@@@@@N@@N@@@@@@@@@@@@@@" "@@@@@@@@@@N@@G@@@@@@@@@@@@@@" "@@@@@@@@@@L@@G@@@@@@@@@@@@@@" "@@@@@@@@@AL@@CH@@@@@@@@@@@@@" "@@@@@@@@@AL@@CH@@@@@@@@@@@@@" "@@@@@@@@@@N@@CN@@@@@@@@@@@@@" "@@@@@@@@@@GH@@N@@@@@@@@@@@@@" "@@@@@@@@@@GN@@GH@@@@@@@@@@@@" "@@@@@@@@@@AOH@GH@@@@@@@@@@@@" "@@@@@@@@@@@GOHAN@@@@@@@@@@@@" "@@@@@@@@@@@@OO@N@@@@@@@@@@@@" "@@@@@@@@@@@@@OLF@@@@@@@@@@@@" "@@@@@@@@@@@@@AON@@@@@@@@@@@@" "@@@@@@@@@@@@@@GN@@@@@@@@@@@@")} 128 . 78))))) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/ACE-MAIN b/lispusers/ACE-MAIN new file mode 100644 index 00000000..2293e53c --- /dev/null +++ b/lispusers/ACE-MAIN @@ -0,0 +1 @@ +(FILECREATED "28-Jul-85 21:16:32" {ICE}LISP>ACE-MAIN.;4 55935 changes to: (VARS ACE-MAINCOMS) (FNS ACEGETFRAME# ACE.DELAY.FRAME ACE.DELAY.SEQ ACE.QUIT.ACE ACE.ANIMATE ACE.CREATE.CONTROL.MENU SUBLIST ACERUNLOOP ACE.INCREMENT.FRAME ACE.UPD.CONTROL.WINDOW ACE.UPD.CW.MULE ACE.ASKEM ACE) previous date: " 2-May-85 20:56:43" {ICE}LISP>ACE>ACE-MAIN.;25) (PRETTYCOMPRINT ACE-MAINCOMS) (RPAQQ ACE-MAINCOMS [(* MAIN TOP LEVEL STUFF) (FNS ACE ACE.ANIMATE ACE.RUN ACEGETFRAME# ACERUNLOOP ACE.NEW.SEQUENCE ACE.NEW.FRAME ACE.QUIT.ACE ACE.RESET.SEQ ACE.RUN.CURRENT.SEQ ACE.DELAY ACE.DELAY.FRAME ACE.DELAY.SEQ ACE.DECREMENT.FRAME ACE.INCREMENT.FRAME ACE.DELETE.FRAME ACE.SET.DEVICE ACE.QUICKDRAW&UPD ACE.RECONSTRUCT.FRAME SUBLIST) (* TRILLIUM STUFF) (FNS ACE.TRILLIUM ACE.TRILLIUM.LOOP ACE.RUN.TRILLIUM ACE.QUIT.TRILLIUM ACE.CREATE.EDITING.BORDER) (* I/O STUFF) (FNS ACE.GET.SEQ.FILE ACE.PUT.SEQ.FILE ACE.GET.A.FILE.NAME) (* HELPER FNS) (FNS ACE.ASKEM ACE.TELLEM ACE.CONFIRMIT ACE.DEFINE.SEQ.WINDOW ACE.FIGURE.OUT.WINDOW ACE.RETURN.CLOSEST.VERTEX ACE.NEW.SEQ.ASST ACE.DELAY.FRAME.ASST ACE.SETUP.CW.CLIPPING.REGIONS ACE.CHECKSTUFF ACE.UPD.CONTROL.WINDOW ACE.UPD.CW.MULE ACE.UPD.CLEAR.SET.LINE ACE.CREATE.CONTROL.MENU ACE.SEQ.FETCH.WIDTH ACE.SEQ.FETCH.HEIGHT ACE.SET.SEQ.CLIP.REGION ACE.ASKEM2 ACE.TELLEM2 ACE.UPD.CONTROL.WINDOW2) (* The following Macros set up restricting clipping regions) (MACROS ACE.MAC.CW.INFO.CLIP ACE.MAC.CW.PROMPT.CLIP ACE.MAC.SEQ.CLIP) (MACROS ACE.MAC.FETCH.WIDTH ACE.MAC.FETCH.HEIGHT) (CURSORS ACE.LEFTMOUSE.CURSOR ACE.MIDDLEMOUSE.CURSOR ACE.RIGHTMOUSE.CURSOR ACE.ALLMOUSE.CURSOR) (GLOBALVARS ACE.CONTROL.WINDOW ACE.DIRECTORY ACE.SEQ.WINDOW ACE.SEQ.WIDTH ACE.SEQ.HEIGHT ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF ACE.CURRENT.SEQUENCE ACE.CURRENT.SEQUENCE.NAME ACE.FRAME.TAIL ACE.CURRENT.FRAME ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD ACE.RUNNING.UNDER.TRILLIUM ACE.LEFTMOUSE.CURSOR ACE.MIDDLEMOUSE.CURSOR ACE.RIGHTMOUSE.CURSOR ACE.ALLMOUSE.CURSOR) (* MENUS IN MAIN) (GLOBALVARS ACE.CONTROL.MENU ACE.DELAY.MENU ACE.SET.DEVICE.MENU) (P (SETQ ACE.CONTROL.WINDOW NIL) (SETQ ACE.CONTROL.MENU NIL) (SETQ ACE.DELAY.MENU NIL) (SETQ ACE.SET.DEVICE.MENU NIL)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* MAIN TOP LEVEL STUFF) (DEFINEQ (ACE [LAMBDA (SEQUENCE WINDOW POSITION APPLICATION) (* MD "14-Jun-85 17:34") (* Top level function to run animation. All ARGs are optional (No ARGs means just run "normal" ACE); Current  APPLICATIONs are NIL (Normal) and TRILLIUM. If TRILLIUM, then POSITION is necessary (and WINDOW very highly  reccommended!); ACE creates ACE.CONTROL.WINDOW and menu if necessary; then decides about APPLICATION) (PROG (FONT TEMP.REGION) (OR ACE.CONTROL.MENU (ACE.CREATE.CONTROL.MENU)) (SETQ FONT (FONTCREATE (QUOTE HELVETICA) 10 (QUOTE BOLD))) (COND ((WINDOWP ACE.CONTROL.WINDOW) (TOTOPW ACE.CONTROL.WINDOW)) (T (SETQ ACE.CONTROL.WINDOW (CREATEW (LIST 500 500 (IPLUS 2 (fetch IMAGEWIDTH of ACE.CONTROL.MENU)) (IPLUS (ITIMES 4 (FONTPROP FONT (QUOTE HEIGHT)) ) (fetch IMAGEHEIGHT of ACE.CONTROL.MENU) 25)) (CONCAT "ACE v. " "2.1" " Control Window") 1)) (DSPFONT FONT ACE.CONTROL.WINDOW) (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE RESHAPEFN) (QUOTE DON'T)) (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE REPAINTFN) (QUOTE DON'T)) (ACE.SETUP.CW.CLIPPING.REGIONS ACE.CONTROL.MENU))) (ACE.TELLEM "Position This Window" T) (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE MOVEFN) NIL) (MOVEW ACE.CONTROL.WINDOW) (SETQ ACE.AREA.THRESHOLD 50) (SETQ ACE.VERTICAL.BLOCK 16) (SETQ ACE.CURRENT.SEQUENCE.NAME NIL) (COND ((EQ APPLICATION (QUOTE TRILLIUM)) (RETURN (ACE.TRILLIUM WINDOW SEQUENCE POSITION))) (T (SETQ ACE.RUNNING.UNDER.TRILLIUM NIL) (SETQ ACE.DIRECTORY (ACE.ASKEM "Animation Directory? " T LOGINHOST/DIR)) (ACE.TELLEM "If using the Tablet," T) (ACE.TELLEM "Be sure and Initialize it." (QUOTE L)) (SETQ ACE.SEQ.WINDOW NIL) (SETQ ACE.SEQ.WIDTH NIL) (SETQ ACE.SEQ.HEIGHT NIL) (SETQ ACE.SEQ.WINDOW.XOFF 0) (SETQ ACE.SEQ.WINDOW.YOFF 0) (SETQ ACE.CURRENT.SEQUENCE NIL) (SETQ ACE.FRAME.TAIL NIL) (SETQ ACE.CURRENT.FRAME NIL) (replace (MENU WHENSELECTEDFN) of ACE.CONTROL.MENU with (QUOTE ACE.ANIMATE)) (ADDMENU ACE.CONTROL.MENU ACE.CONTROL.WINDOW (CONS 0 0)) (ACE.UPD.CONTROL.WINDOW (QUOTE RESET]) (ACE.ANIMATE [LAMBDA (ITEM WHO CARES) (* MD "26-Jun-85 14:21") (* When running "normal" ACE, this is the WHENSELECTEDFN for deciding what to do. ITEM is the only ARG of  significance (WHO & CARES just to keep MENU package happy); "TRILLIUM ACE" has its own loop thingy) (ACE.TELLEM "" T) (SELECTQ (CADADR ITEM) (NIL NIL) (FRAME (ACE.NEW.FRAME)) (EDIT (ACE.EDIT)) (RUN (ACE.RUN.CURRENT.SEQ)) (LOOP (ACERUNLOOP 1 (QUOTE END))) (SUBLOOP (ACEGETFRAME#)) (NEW (ACE.NEW.SEQUENCE)) (I/O:GET (ACE.GET.SEQ.FILE)) (I/O:PUT (ACE.PUT.SEQ.FILE)) (DEL (ACE.DELETE.FRAME)) (RESET (ACE.RESET.SEQ)) (INC (ACE.INCREMENT.FRAME)) (DEC (ACE.DECREMENT.FRAME)) (TIME (ACE.DELAY)) (INIT.MM1201 (ACE.MM1201.INIT T)) (DEVICE (ACE.SET.DEVICE)) (ACESETTHRESHOLD (ACESETTHRESHOLD)) (QUIT (ACE.QUIT.ACE)) NIL) (AND (OPENWP ACE.CONTROL.WINDOW) (ACE.UPD.CONTROL.WINDOW (QUOTE UPD))) (TTY.PROCESS T]) (ACE.RUN [LAMBDA (SEQ WINDOW XOFFSET YOFFSET TIMER) (* PmT "18-Apr-85 18:21") (* This runs animation sequences. Simple, eh? Gots to have a SEQ and a WINDOW to show it in, and where in the window to show it (i.e. XOFFSET YOFFSET); TIMER is wholly unecessary NOTE: this thang doesn't use any clipping region, just an offset) (for FRAME in SEQ do ((SETQ TIMER (SETUPTIMER (fetch (ACE.FRAME DELAY) of FRAME) TIMER (QUOTE MILLISECONDS))) (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) NIL NIL WINDOW (IPLUS XOFFSET (fetch (ACE.BLIT XCOOR) of FRAME.PART)) (IPLUS YOFFSET (fetch (ACE.BLIT YCOOR) of FRAME.PART)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE))) (until (TIMEREXPIRED? TIMER (QUOTE MILLISECONDS)) do]) (ACEGETFRAME# [LAMBDA NIL (* MD "27-Jun-85 12:51") (ACERUNLOOP (RNUMBER "From frame #") (RNUMBER "To frame #:"]) (ACERUNLOOP [LAMBDA (START END) (* MD "26-Jun-85 17:07") (if (EQ END (QUOTE END)) then (SETQ END (LENGTH ACE.CURRENT.SEQUENCE))) [ACE.QUICKDRAW&UPD (LIST (CAR (NTH ACE.CURRENT.SEQUENCE START] (until (KEYDOWNP (QUOTE SPACE)) do (ACE.RUN (SUBLIST ACE.CURRENT.SEQUENCE START END) ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF]) (ACE.NEW.SEQUENCE [LAMBDA (REGION) (* PmT "30-Apr-85 16:21") (PROG (TEMP.REGION) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "NEW") (COND ((OR (NULL ACE.CURRENT.SEQUENCE) (ACE.TELLEM "Creating a NEW Sequence will ERASE" T) (ACE.TELLEM "the Current Animation Sequence." (QUOTE L)) (ACE.CONFIRMIT "Click LEFT to Create NEW Sequence." (QUOTE L))) [COND ((REGIONP REGION) (SETQ TEMP.REGION REGION)) (T (ACE.TELLEM "Specify SIZE of the NEW Sequence." T) (ACE.TELLEM "Watch ACE window for COORs." (QUOTE L)) (SETQ TEMP.REGION (GETREGION NIL NIL NIL (QUOTE ACE.NEW.SEQ.ASST) NIL] (SETQ ACE.SEQ.WIDTH (fetch (REGION WIDTH) of TEMP.REGION)) (SETQ ACE.SEQ.HEIGHT (fetch (REGION HEIGHT) of TEMP.REGION)) [SETQ ACE.CURRENT.SEQUENCE (LIST (create ACE.FRAME DELAY _ 0 BLITS _(LIST (create ACE.BLIT BITMAP _(BITMAPCREATE ACE.SEQ.WIDTH ACE.SEQ.HEIGHT 1) XCOOR _ 0 YCOOR _ 0] (ACE.FIGURE.OUT.WINDOW) (ACE.QUICKDRAW&UPD (LIST (CAR ACE.CURRENT.SEQUENCE]) (ACE.NEW.FRAME [LAMBDA NIL (* PmT "24-Jan-85 13:22") (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "FRAME") (COND ([NULL (AND (ACE.CHECKSTUFF (QUOTE SEQ)) (OR (ACE.CHECKSTUFF (QUOTE FRAME)) (ACE.TELLEM "Can't put a frame before the First Frame." T] NIL) (T (RPLACD ACE.CURRENT.FRAME (CONS (create ACE.FRAME DELAY _ 0 BLITS _ NIL) (CDR ACE.CURRENT.FRAME))) (SETQ ACE.CURRENT.FRAME (CDR ACE.CURRENT.FRAME)) (SETQ ACE.FRAME.TAIL (CDR ACE.CURRENT.FRAME)) (ACE.TELLEM "Going to EDIT ..." T) (ACE.EDIT]) (ACE.QUIT.ACE [LAMBDA NIL (* MD "24-Jun-85 14:49") (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "QUIT") (ACE.TELLEM "QUITing will Close All Animation Windows;" T) (ACE.TELLEM "All Images and Data will be LOST." (QUOTE L)) (COND ((ACE.CONFIRMIT "Click LEFT to QUIT." (QUOTE L)) (CLOSEW ACE.SEQ.WINDOW) (CLOSEW ACE.CONTROL.WINDOW) ACE.CURRENT.SEQUENCE) (T (* MAKE THIS BE SOME KINDA ICON IN THE FUTURE; ASK: DO YOU WANT TO QUIT COMPLETELY OR JUST STOP FOR A  WHILE) (ACE.TELLEM "QUIT Aborted." T]) (ACE.RESET.SEQ [LAMBDA NIL (* PmT "30-Apr-85 16:37") (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "RESET") (COND [(AND ACE.SEQ.WINDOW (ACE.CHECKSTUFF (QUOTE SEQ))) (ACE.QUICKDRAW&UPD (LIST (CAR ACE.CURRENT.SEQUENCE] (T (ACE.TELLEM "There is No Current Sequence." T]) (ACE.RUN.CURRENT.SEQ [LAMBDA NIL (* PmT "18-Apr-85 18:23") (* just a pretty interface to ACE.RUN) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "RUN") (COND ((ACE.CHECKSTUFF (QUOTE SEQ)) (RECLAIM) (ACE.RUN ACE.FRAME.TAIL ACE.SEQ.WINDOW ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF) (SETQ ACE.FRAME.TAIL NIL) (SETQ ACE.CURRENT.FRAME (LAST ACE.CURRENT.SEQUENCE]) (ACE.DELAY [LAMBDA NIL (* PmT " 2-May-85 20:53") (* For setting delays (in MSECs) between frames. Lots of work needed here; esp. delay in-betweening) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "DELAY") (SELECTQ [MENU (OR ACE.DELAY.MENU (SETQ ACE.DELAY.MENU (create MENU ITEMS _(QUOTE (("Set Delay on a Frame" (QUOTE FDELAY) "Adjust the delay on any frame by number") ("Reset Entire Sequence" (QUOTE SDELAY) "Set the delay on every frame"))) CENTERFLG _ T TITLE _ "Sequence Timing Adjustments"] (NIL NIL) (SDELAY (ACE.DELAY.SEQ)) (FDELAY (ACE.DELAY.FRAME)) NIL]) (ACE.DELAY.FRAME [LAMBDA NIL (* MD "21-Jun-85 14:14") (PROG (CHOICE FRAME) LOOP[SETQ CHOICE (MENU (create MENU ITEMS _(NCONC1 (for FRAME in ACE.CURRENT.SEQUENCE bind (COUNT _ 0) collect ((SETQ COUNT (ADD1 COUNT)) (LIST (CONCAT "Frame " COUNT " : " (fetch (ACE.FRAME DELAY) of FRAME)) COUNT))) (QUOTE (Quit (QUOTE QUIT) "Stop adjusting delays"))) TITLE _ "Frame Delays" WHENHELDFN _(QUOTE ACE.DELAY.FRAME.ASST] [COND ((NULL CHOICE) NIL) ((EQ CHOICE (QUOTE QUIT)) (RETURN NIL)) (T (SETQ FRAME (CAR (NTH ACE.CURRENT.SEQUENCE CHOICE))) (AND FRAME (replace (ACE.FRAME DELAY) of FRAME with (SETQ CHOICE (RNUMBER (CONCAT "Frame " CHOICE "; New Delay: "] (GO LOOP]) (ACE.DELAY.SEQ [LAMBDA NIL (* MD "21-Jun-85 14:31") (PROG (NEW.DELAY.VALUE) (COND [(FIXP (SETQ NEW.DELAY.VALUE (RNUMBER "Delay for entire sequence:"] (T (RETURN NIL))) (for FRAME in ACE.CURRENT.SEQUENCE do (replace (ACE.FRAME DELAY) of FRAME with NEW.DELAY.VALUE]) (ACE.DECREMENT.FRAME [LAMBDA NIL (* PmT "21-Dec-84 14:12") (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "DEC") (AND (ACE.CHECKSTUFF (QUOTE SEQ)) (ACE.CHECKSTUFF (QUOTE FRAME)) (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME]) (ACE.INCREMENT.FRAME [LAMBDA NIL (* MD "18-Jun-85 16:12") (PROG (CUR.FRAME) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "INC") (COND ([NULL (AND (ACE.CHECKSTUFF (QUOTE SEQ)) (ACE.CHECKSTUFF (QUOTE TAIL] NIL) (T (SETQ CUR.FRAME (CAR ACE.FRAME.TAIL)) (SETQ ACE.CURRENT.FRAME ACE.FRAME.TAIL) (SETQ ACE.FRAME.TAIL (CDR ACE.FRAME.TAIL)) (COND ((NULL (fetch (ACE.FRAME BLITS) of CUR.FRAME)) NIL) (T (ACE.MAC.SEQ.CLIP (for FRAME.PART in (fetch (ACE.FRAME BLITS) of CUR.FRAME) do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) NIL NIL ACE.SEQ.WINDOW (IPLUS ACE.SEQ.WINDOW.XOFF (fetch (ACE.BLIT XCOOR) of FRAME.PART)) (IPLUS ACE.SEQ.WINDOW.YOFF (fetch (ACE.BLIT YCOOR) of FRAME.PART)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE]) (ACE.DELETE.FRAME [LAMBDA NIL (* PmT "24-Apr-85 14:19") (* Deletes the current frame; recompiles the previous frame with the successor frame) (PROG (BEFORE.BM AFTER.BM) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "DELETE") (COND ([NULL (AND (ACE.CHECKSTUFF (QUOTE SEQ)) (ACE.CHECKSTUFF (QUOTE FRAME] NIL) ((EQ ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME) (ACE.TELLEM "Can't DELETE first frame. Aborted." T)) ((NULL (ACE.CONFIRMIT "Click LEFT to Confirm Delete" T)) NIL) ((NULL ACE.FRAME.TAIL) (SETQ ACE.CURRENT.SEQUENCE (LDIFF ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME)) (ACE.QUICKDRAW&UPD ACE.CURRENT.SEQUENCE)) (T (SETQ BEFORE.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE ACE.CURRENT.FRAME))) [SETQ AFTER.BM (ACE.RECONSTRUCT.FRAME (LDIFF ACE.CURRENT.SEQUENCE (CDR ACE.FRAME.TAIL] (replace (ACE.FRAME BLITS) of (CAR ACE.CURRENT.FRAME) with (ACE.COMPILE.FRAME BEFORE.BM AFTER.BM ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD)) (RPLACD ACE.CURRENT.FRAME (CDR ACE.FRAME.TAIL)) (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE (CDR ACE.CURRENT.FRAME]) (ACE.SET.DEVICE [LAMBDA NIL (* PmT "23-Apr-85 13:44") (* Selects MOUSE or TABLET as the primary input device) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "SET DEVICE") (ACE.UPD.CONTROL.WINDOW (QUOTE DEVICE)) (ACE.UPD.CONTROL.WINDOW (QUOTE DEVICE) (MENU (OR ACE.SET.DEVICE.MENU (SETQ ACE.SET.DEVICE.MENU (create MENU ITEMS _(QUOTE (("Mouse" (QUOTE MOUSE) "Use the standard mouse for drawing and such") ("Tablet" (QUOTE MM1201) "Use the MM1201 Tablet as the input device"))) TITLE _ "Select Input Device" CENTERFLG _ T]) (ACE.QUICKDRAW&UPD [LAMBDA (PARTIAL.SEQ) (* PmT "30-Apr-85 16:11") (* Updates the frame showing in the A.S.Window and update sequence pointers and stuff. PARTIAL.SEQ is a list of  frames to show; The last frame in PARTIAL.SEQ becomes the new current frame) (COND (PARTIAL.SEQ [ACE.MAC.SEQ.CLIP (for FRAME in PARTIAL.SEQ do (COND ((NULL (fetch (ACE.FRAME BLITS) of FRAME)) NIL) (T (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) NIL NIL ACE.SEQ.WINDOW (IPLUS ACE.SEQ.WINDOW.XOFF (fetch (ACE.BLIT XCOOR) of FRAME.PART)) (IPLUS ACE.SEQ.WINDOW.YOFF (fetch (ACE.BLIT YCOOR) of FRAME.PART)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE] (SETQ ACE.CURRENT.FRAME ACE.CURRENT.SEQUENCE) (for X from 1 to (SUB1 (LENGTH PARTIAL.SEQ)) do (SETQ ACE.CURRENT.FRAME (CDR ACE.CURRENT.FRAME))) (SETQ ACE.FRAME.TAIL (CDR ACE.CURRENT.FRAME]) (ACE.RECONSTRUCT.FRAME [LAMBDA (SEQ) (* PmT "18-Apr-85 18:54") (* Creates a bitmap out of SEQ; Essentially, the last virtual frame in SEQ is converted to a "real" frame and returned) (PROG (ABITMAP) [SETQ ABITMAP (BITMAPCOPY (fetch (ACE.BLIT BITMAP) of (CAR (fetch (ACE.FRAME BLITS) of (CAR SEQ] [for FRAME in (CDR SEQ) do (COND ((NULL (fetch (ACE.FRAME BLITS) of FRAME))) (T (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) NIL NIL ABITMAP (fetch (ACE.BLIT XCOOR) of FRAME.PART) (fetch (ACE.BLIT YCOOR) of FRAME.PART) NIL NIL (QUOTE INPUT) (QUOTE REPLACE] (RETURN ABITMAP]) (SUBLIST [LAMBDA (L M N) (* MD "26-Jun-85 16:00") (LDIFF (NTH L M) (NTH L (ADD1 N]) ) (* TRILLIUM STUFF) (DEFINEQ (ACE.TRILLIUM [LAMBDA (WINDOW SEQUENCE POSITION) (* PmT "30-Apr-85 16:44") (* This here sets up stuff for running animation (functionally) from Trillium. ARGS: WINDOW is opt  (but really should be given), SEQUENCE is opt, POSITION *MUST* be given; if not, ACE bags it  (Trillium must always supply a place to put the animation!): This FN just checks args and sets the state of ACE,  then calls the actual "polling" FN NOTE: This should only be called from ACE; take a look at ACE) (PROG NIL (SETQ ACE.RUNNING.UNDER.TRILLIUM T) (DISPLAY.FRAME CURRENT.FRAME) (* See if got a valid window or not) [COND ((WINDOWP WINDOW) (SETQ ACE.SEQ.WINDOW WINDOW)) (T (ACE.TELLEM "There is no Window Specification" T) (COND ((ACE.CONFIRMIT "Click LEFT to use Current Interface Window." (QUOTE L)) (SETQ ACE.SEQ.WINDOW CURRENT.INTERFACE.WINDOW)) (T (ACE.TELLEM "Error in Window Specification." T) (ACE.TELLEM "Likely a Trillium error. ACE aborted." (QUOTE L)) (ACE.CONFIRMIT "Click any button to Exit." (QUOTE L) (QUOTE ANY)) (RETURN NIL] (* The following *might* be used instead of a window  error; you decide) (* SETQ ACE.SEQ.WINDOW (EVAL  (ACE.ASKEM "Enter the Name of the Window: " T NIL 60))) (* Was given a valid postion?) (COND ((POSITIONP POSITION) (SETQ ACE.SEQ.WINDOW.XOFF (fetch (POSITION XCOORD) of POSITION)) (SETQ ACE.SEQ.WINDOW.YOFF (fetch (POSITION YCOORD) of POSITION))) (T (ACE.TELLEM "No Position Specification. Aborted." T) (ACE.TELLEM "This is likely a Trillium error." (QUOTE L)) (ACE.CONFIRMIT "Click any button to Exit." (QUOTE L) (QUOTE ANY)) (RETURN NIL))) (* Now check if given a sequence) (COND ((LISTP SEQUENCE) (SETQ ACE.CURRENT.SEQUENCE SEQUENCE) (SETQ ACE.CURRENT.FRAME ACE.CURRENT.SEQUENCE) (SETQ ACE.FRAME.TAIL (CDR ACE.CURRENT.FRAME)) (SETQ ACE.SEQ.WIDTH (ACE.SEQ.FETCH.WIDTH)) (SETQ ACE.SEQ.HEIGHT (ACE.SEQ.FETCH.HEIGHT)) (ACE.CREATE.EDITING.BORDER) (ACE.SET.SEQ.CLIP.REGION)) (T (SETQ ACE.CURRENT.SEQUENCE NIL) (SETQ ACE.FRAME.TAIL NIL) (SETQ ACE.CURRENT.FRAME NIL))) (* The WHENSELECTEDFN is different for Trillium; make it act like a regular old menu) (replace (MENU WHENSELECTEDFN) of ACE.CONTROL.MENU with (QUOTE DEFAULTWHENSELECTEDFN)) (SETQ ACE.DIRECTORY (DIRECTORYNAME T T)) (AND ACE.CURRENT.SEQUENCE (ACE.RESET.SEQ)) (ACE.UPD.CONTROL.WINDOW (QUOTE RESET)) (* Lock down window so menu coors only figured once; see ACE.TRILLIUM.LOOP) (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE MOVEFN) (QUOTE DON'T)) (RETURN (ACE.TRILLIUM.LOOP]) (ACE.TRILLIUM.LOOP [LAMBDA NIL (* PmT "18-Apr-85 18:41") (* This is the repeating loop for Trillium-Ace; just sits in here till QUIT) (PROG (CHOICE MENU.POS) [SETQ MENU.POS (CONS (DSPXOFFSET NIL (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE DSP))) (DSPYOFFSET NIL (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE DSP] LOOP(ACE.TELLEM "" T) (SELECTQ (SETQ CHOICE (MENU ACE.CONTROL.MENU MENU.POS)) (NIL NIL) (FRAME (ACE.NEW.FRAME)) (EDIT (ACE.EDIT)) (RUN (ACE.RUN.CURRENT.SEQ)) (NEW (ACE.NEW.SEQUENCE)) (I/O:GET (ACE.GET.SEQ.FILE)) (I/O:PUT (ACE.PUT.SEQ.FILE)) (DEL (ACE.DELETE.FRAME)) (RESET (ACE.RESET.SEQ)) (INC (ACE.INCREMENT.FRAME)) (DEC (ACE.DECREMENT.FRAME)) (TIME (ACE.DELAY)) (INIT.MM1201 (ACE.MM1201.INIT T)) (DEVICE (ACE.SET.DEVICE)) (QUIT NIL) NIL) (ACE.UPD.CONTROL.WINDOW (QUOTE UPD)) (OR (EQ CHOICE (QUOTE QUIT)) (GO LOOP)) (RETURN (ACE.QUIT.TRILLIUM]) (ACE.RUN.TRILLIUM [LAMBDA (SEQ WINDOW XOFFSET YOFFSET UPTO TIMER) (* PmT "18-Apr-85 18:45") (* Just like ACE.RUN except UPTO can be a FIXP denoting a frame; If UPTO is given, that frame is displayed  (without delays); Good for initializing in Trillium) (COND [(NULL UPTO) (for FRAME in SEQ do ((SETQ TIMER (SETUPTIMER (fetch (ACE.FRAME DELAY) of FRAME) TIMER (QUOTE MILLISECONDS))) (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) NIL NIL WINDOW (IPLUS XOFFSET (fetch (ACE.BLIT XCOOR) of FRAME.PART)) (IPLUS YOFFSET (fetch (ACE.BLIT YCOOR) of FRAME.PART)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE))) (until (TIMEREXPIRED? TIMER (QUOTE MILLISECONDS)) do] ((AND (FIXP UPTO) (IGREATERP (ADD1 (LENGTH SEQ)) UPTO) (IGREATERP UPTO 0)) (for FRAME in (LDIFF SEQ (NTH SEQ (ADD1 UPTO))) do (for FRAME.PART in (fetch (ACE.FRAME BLITS) of FRAME) do (BITBLT (fetch (ACE.BLIT BITMAP) of FRAME.PART) NIL NIL WINDOW (IPLUS XOFFSET (fetch (ACE.BLIT XCOOR) of FRAME.PART)) (IPLUS YOFFSET (fetch (ACE.BLIT YCOOR) of FRAME.PART)) NIL NIL (QUOTE INPUT) (QUOTE REPLACE]) (ACE.QUIT.TRILLIUM [LAMBDA NIL (* PmT "15-Mar-85 13:48") (CLOSEW ACE.CONTROL.WINDOW) (SETQ ACE.RUNNING.UNDER.TRILLIUM NIL) ACE.CURRENT.SEQUENCE]) (ACE.CREATE.EDITING.BORDER [LAMBDA (MODE) (* PmT "30-Apr-85 16:42") (PROG (X1 X2 Y1 Y2) (OR MODE (SETQ MODE (QUOTE PAINT))) (COND ((AND (NUMBERP ACE.SEQ.WIDTH) (NUMBERP ACE.SEQ.HEIGHT)) (SETQ X1 (IDIFFERENCE ACE.SEQ.WINDOW.XOFF 2)) (SETQ X2 (IPLUS ACE.SEQ.WINDOW.XOFF ACE.SEQ.WIDTH)) (SETQ Y1 (IDIFFERENCE ACE.SEQ.WINDOW.YOFF 2)) (SETQ Y2 (IPLUS ACE.SEQ.WINDOW.YOFF ACE.SEQ.HEIGHT)) (DRAWLINE X1 Y1 X1 Y2 2 MODE ACE.SEQ.WINDOW) (DRAWLINE X1 Y2 X2 Y2 2 MODE ACE.SEQ.WINDOW) (DRAWLINE X2 Y2 X2 Y1 2 MODE ACE.SEQ.WINDOW) (DRAWLINE X2 Y1 X1 Y1 2 MODE ACE.SEQ.WINDOW]) ) (* I/O STUFF) (DEFINEQ (ACE.GET.SEQ.FILE [LAMBDA NIL (* PmT "25-Apr-85 21:18") (* Gets an animation sequence. Resets ACE.CURRENT.SEQUENCE and the sequence clipping  region) (RESETFORM (TTYDISPLAYSTREAM \TopLevelTtyWindow) (PROG (FILENAME TEMP.SEQUENCE.NAME) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "GET FILE") (OR (NULL ACE.CURRENT.SEQUENCE) (ACE.TELLEM "Loading a Sequence will ERASE the Current" T) (ACE.CONFIRMIT "Sequence; Click LEFT to confirm LOAD." (QUOTE L)) (ACE.TELLEM "Get Sequence ABORTED." T) (RETURN NIL)) (SETQ FILENAME (ACE.GET.A.FILE.NAME)) [COND ((NULL FILENAME) (ACE.TELLEM "No NAME. Aborted" T) (RETURN NIL)) (T (SETQ FILENAME (PACKFILENAME (QUOTE BODY) FILENAME (QUOTE HOST) (FILENAMEFIELD ACE.DIRECTORY (QUOTE HOST)) (QUOTE DIRECTORY) (FILENAMEFIELD ACE.DIRECTORY (QUOTE DIRECTORY] (ACE.TELLEM "Loading: " T) (ACE.TELLEM (CONCAT FILENAME " ... ") (QUOTE L)) [RESETLST [RESETSAVE (PROGN (CURSOR WAITINGCURSOR) (SETTOPVAL (QUOTE HELPFLAG) NIL)) (LIST (QUOTE PROGN) (LIST (QUOTE CURSOR) (QUOTE DEFAULTCURSOR)) (LIST (QUOTE SETTOPVAL) (QUOTE (QUOTE HELPFLAG)) (KWOTE (GETTOPVAL (QUOTE HELPFLAG] (SETQ TEMP.SEQUENCE.NAME (CAR (ERRORSET (QUOTE (LOAD FILENAME (QUOTE SYSLOAD))) (QUOTE NOBREAK] (COND (TEMP.SEQUENCE.NAME (SETQ ACE.CURRENT.SEQUENCE.NAME TEMP.SEQUENCE.NAME) (SETQ ACE.SEQ.WIDTH (ACE.SEQ.FETCH.WIDTH)) (SETQ ACE.SEQ.HEIGHT (ACE.SEQ.FETCH.HEIGHT)) (ACE.FIGURE.OUT.WINDOW) (ACE.RESET.SEQ)) (T (ACE.TELLEM "Not Found.") (ACE.TELLEM "No Such File or File Server Problems." (QUOTE L]) (ACE.PUT.SEQ.FILE [LAMBDA NIL (* PmT " 2-May-85 20:50") (* Writes a sequence to a file; the file is NOT pretty printed) (PROG (FILENAME TEMP.SEQUENCE.NAME) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "PUT FILE") [COND ((NULL (ACE.CHECKSTUFF (QUOTE SEQ))) (RETURN NIL)) ((AND ACE.CURRENT.SEQUENCE.NAME (ACE.CONFIRMIT "Click LEFT to Keep Same Name." T)) (SETQ FILENAME ACE.CURRENT.SEQUENCE.NAME)) (T (SETQ FILENAME (ACE.GET.A.FILE.NAME)) (COND ((NULL FILENAME) (ACE.TELLEM "NIL ain't no good. Aborted." T) (RETURN NIL))) (SETQ FILENAME (PACKFILENAME (QUOTE BODY) FILENAME (QUOTE HOST) (FILENAMEFIELD ACE.DIRECTORY (QUOTE HOST)) (QUOTE DIRECTORY) (FILENAMEFIELD ACE.DIRECTORY (QUOTE DIRECTORY] (COND ((AND (FILENAMEFIELD FILENAME (QUOTE VERSION)) (NULL (ACE.TELLEM "Click LEFT to Write a New Version." T)) (ACE.CONFIRMIT "Click any Other to Write Over Existing Version." (QUOTE L))) (SETQ FILENAME (PACKFILENAME (QUOTE VERSION) NIL (QUOTE BODY) FILENAME))) (T NIL)) [SET (PACK* (FILENAMEFIELD FILENAME (QUOTE NAME)) (QUOTE COMS)) (QUOTE ((UGLYVARS ACE.CURRENT.SEQUENCE] (PUTPROP (FILENAMEFIELD FILENAME (QUOTE NAME)) (QUOTE FILETYPE) (QUOTE (DON'TLIST DON'TCOMPILE))) (ACE.TELLEM "Putting to File: " T) (ACE.TELLEM (CONCAT FILENAME " ... ") (QUOTE L)) [RESETLST [RESETSAVE (PROGN (CURSOR WAITINGCURSOR) (SETTOPVAL (QUOTE HELPFLAG) NIL)) (LIST (QUOTE PROGN) (LIST (QUOTE CURSOR) (QUOTE DEFAULTCURSOR)) (LIST (QUOTE SETTOPVAL) (QUOTE (QUOTE HELPFLAG)) (KWOTE (GETTOPVAL (QUOTE HELPFLAG] (SETQ TEMP.SEQUENCE.NAME (CAR (ERRORSET [QUOTE (MAKEFILE FILENAME (QUOTE (NEW FAST] (QUOTE NOBREAK] (COND (TEMP.SEQUENCE.NAME (SETQ ACE.CURRENT.SEQUENCE.NAME TEMP.SEQUENCE.NAME) (ACE.TELLEM "Done") (DREMOVE (FILENAMEFIELD FILENAME (QUOTE NAME)) FILELST)) (T (ACE.TELLEM "Aborted.") (ACE.TELLEM "Nothing doing. Can't write this File out." (QUOTE L)) (ACE.TELLEM "Check the Name. Is the File Server Down?" (QUOTE L]) (ACE.GET.A.FILE.NAME [LAMBDA NIL (* PmT "18-Apr-85 19:44") (ACE.ASKEM "Enter FILENAME: " T NIL 120]) ) (* HELPER FNS) (DEFINEQ (ACE.ASKEM [LAMBDA (STRING FLG DEFAULTANSWER TIMELIMIT? SPACES?) (* MD "14-Jun-85 16:48") (* a prompting fn. STRING is the prompt string; FLG either T,L or NIL (T means clear before prompting, L means new  line); DEFAULTANSWER just what it sounds like. TIMELIMIT? number or seconds to wait for answer  (defaults to 120); if SPACES? is T, then the answer can have spaces in it) (* TIMELIMIT? removed - now waits forever. - MJD) (ACE.MAC.CW.PROMPT.CLIP (PROGN (OR TIMELIMIT? (SETQ TIMELIMIT? 120)) (COND ((EQ FLG T) (DSPRESET ACE.CONTROL.WINDOW)) ((EQ FLG (QUOTE L)) (TERPRI ACE.CONTROL.WINDOW))) (MKATOM (PROMPTFORWORD STRING DEFAULTANSWER NIL ACE.CONTROL.WINDOW NIL NIL (AND SPACES? (CHARCODE (EOL ESCAPE LF]) (ACE.TELLEM [LAMBDA (STRING FLG) (* PmT "23-Apr-85 13:49") (* Writes STRING in the A.C.W prompt region; FLG=T means clear prompt region first; L means new line; NIL means put it at the next char position) (ACE.MAC.CW.PROMPT.CLIP (PROGN (COND ((EQ FLG T) (DSPRESET ACE.CONTROL.WINDOW)) ((EQ FLG (QUOTE L)) (TERPRI ACE.CONTROL.WINDOW))) (printout ACE.CONTROL.WINDOW STRING) NIL]) (ACE.CONFIRMIT [LAMBDA (CONFIRMSTRING FLG WHICHKEYS?) (* PmT "25-Apr-85 17:47") (* Prints CONFIRMSTRING in A.C.W prompt region; then waits for the button form WHICHKEYS? to become true. WHICHKEYS? defaults to LEFT. Code identfies the valid button forms) (OR WHICHKEYS? (SETQ WHICHKEYS? (QUOTE LEFT))) (ACE.TELLEM CONFIRMSTRING FLG) (DISMISS 100 NIL T) (RESETFORM (CURSOR (SELECTQ WHICHKEYS? (LEFT ACE.LEFTMOUSE.CURSOR) (MIDDLE ACE.MIDDLEMOUSE.CURSOR) (RIGHT ACE.RIGHTMOUSE.CURSOR) (ANY (PROGN (SETQ WHICHKEYS? (QUOTE (NOT UP))) ACE.ALLMOUSE.CURSOR)) NIL)) (do (GETMOUSESTATE) until (NEQ LASTMOUSEBUTTONS 0)) (PROG1 (EVAL (MOUSESTATE-EXPR WHICHKEYS? T)) (do (GETMOUSESTATE) until (EQP LASTMOUSEBUTTONS 0]) (ACE.DEFINE.SEQ.WINDOW [LAMBDA NIL (* PmT " 2-May-85 20:32") [COND ((ACE.CONFIRMIT "Click LEFT to Create a Sequence Window." T) (AND ACE.SEQ.WINDOW (CLOSEW ACE.SEQ.WINDOW)) (SETQ ACE.SEQ.WINDOW (CREATEW (LIST 50 50 (IPLUS ACE.SEQ.WIDTH 8) (IPLUS ACE.SEQ.HEIGHT 17)) (QUOTE "Animation Sequence Window") 4)) (ACE.TELLEM "Position the Sequence Window" T) (MOVEW ACE.SEQ.WINDOW)) ((AND ACE.SEQ.WINDOW (ILEQ ACE.SEQ.WIDTH (WINDOWPROP ACE.SEQ.WINDOW (QUOTE WIDTH))) (ILEQ ACE.SEQ.HEIGHT (WINDOWPROP ACE.SEQ.WINDOW (QUOTE HEIGHT))) (ACE.CONFIRMIT "Click LEFT to Keep Current Window." T)) (* CLEARW ACE.SEQ.WINDOW) ) (T (ACE.TELLEM "CAUTION: Enter NIL if Unsure at this Stage." T) (SETQ ACE.SEQ.WINDOW (EVAL (ACE.ASKEM "Enter the Window: " (QUOTE L) NIL 120] (OR ACE.SEQ.WINDOW (ACE.DEFINE.SEQ.WINDOW]) (ACE.FIGURE.OUT.WINDOW [LAMBDA (REGION/POSITION) (* PmT "22-Apr-85 19:05") (* This is where all reasoning about which window to use and where offsets should be placed goes. Right now (4/20/85) Trillium's just gonna go with positions; but that should (?) change) (COND (ACE.RUNNING.UNDER.TRILLIUM (DISPLAY.FRAME CURRENT.FRAME) (ACE.CREATE.EDITING.BORDER (QUOTE INVERT)) (* KEEP OFFSETS THE SAME FOR NOW) ) ((POSITIONP REGION/POSITION) (SETQ ACE.SEQ.WINDOW.XOFF (CAR REGION/POSITION)) (SETQ ACE.SEQ.WINDOW.YOFF (CDR REGION/POSITION))) (T (SETQ ACE.SEQ.WINDOW.XOFF 0) (SETQ ACE.SEQ.WINDOW.YOFF 0) (ACE.DEFINE.SEQ.WINDOW))) (ACE.SET.SEQ.CLIP.REGION]) (ACE.RETURN.CLOSEST.VERTEX [LAMBDA (POINT REGION) (* PmT "28-Nov-84 16:15") (PROG (NEW.XCOOR NEW.YCOOR) [COND [(IGREATERP (CAR POINT) (SETQ NEW.XCOOR (fetch (REGION RIGHT) of REGION] [(ILESSP (CAR POINT) (SETQ NEW.XCOOR (fetch (REGION LEFT) of REGION] (T (SETQ NEW.XCOOR (CAR POINT] [COND [(IGREATERP (CDR POINT) (SETQ NEW.YCOOR (fetch (REGION TOP) of REGION] [(ILESSP (CDR POINT) (SETQ NEW.YCOOR (fetch (REGION BOTTOM) of REGION] (T (SETQ NEW.YCOOR (CDR POINT] (RETURN (CONS NEW.XCOOR NEW.YCOOR]) (ACE.NEW.SEQ.ASST [LAMBDA (FIXED MOVE DUM) (* PmT "23-Jan-85 19:52") (COND ((NULL MOVE) (ACE.UPD.CONTROL.WINDOW (QUOTE CURSOR) FIXED) FIXED) (T [ACE.UPD.CONTROL.WINDOW (QUOTE CURSOR) (CONS (ABS (IDIFFERENCE (fetch (POSITION XCOORD) of MOVE) (fetch (POSITION XCOORD) of FIXED))) (ABS (IDIFFERENCE (fetch (POSITION YCOORD) of MOVE) (fetch (POSITION YCOORD) of FIXED] MOVE]) (ACE.DELAY.FRAME.ASST [LAMBDA (ITEM MENU MOUSE) (* PmT "21-Dec-84 16:42") (COND [(FIXP (CADR ITEM)) (ACE.QUICKDRAW&UPD (LDIFF ACE.CURRENT.SEQUENCE (CDR (NTH ACE.CURRENT.SEQUENCE (CADR ITEM] (T NIL]) (ACE.SETUP.CW.CLIPPING.REGIONS [LAMBDA (MENU) (* PmT "23-Apr-85 13:47") (* Sets the clipping region on ACE.CONTROL.WINDOW; There is a menu region, prompt region and status  region) (PROG (NORMAL ABOVEMENU INFO) (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE NORMAL.CLIP.REGION) (SETQ NORMAL (DSPCLIPPINGREGION NIL ACE.CONTROL.WINDOW))) [WINDOWPROP ACE.CONTROL.WINDOW (QUOTE ABOVEMENU.CLIP.REGION) (SETQ ABOVEMENU (CREATEREGION (fetch (REGION LEFT) of NORMAL) (fetch IMAGEHEIGHT of MENU) (fetch (REGION WIDTH) of NORMAL) (IDIFFERENCE (fetch (REGION HEIGHT) of NORMAL) (fetch IMAGEHEIGHT of MENU] [WINDOWPROP ACE.CONTROL.WINDOW (QUOTE INFO.CLIP.REGION) (SETQ INFO (CREATEREGION (fetch (REGION LEFT) of ABOVEMENU) (fetch (REGION BOTTOM) of ABOVEMENU) 130 (IDIFFERENCE (fetch (REGION HEIGHT) of ABOVEMENU) 5] (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE PROMPT.CLIP.REGION) (CREATEREGION (IPLUS 3 (fetch (REGION RIGHT) of INFO)) (fetch (REGION BOTTOM) of ABOVEMENU) (IDIFFERENCE (fetch (REGION RIGHT) of ABOVEMENU) (IPLUS 3 (fetch (REGION RIGHT) of INFO))) (IDIFFERENCE (fetch (REGION HEIGHT) of ABOVEMENU) 5))) (DRAWLINE (ADD1 (fetch (REGION RIGHT) of INFO)) (fetch (REGION BOTTOM) of ABOVEMENU) (ADD1 (fetch (REGION RIGHT) of INFO)) (fetch (REGION TOP) of ABOVEMENU) 1 (QUOTE PAINT) ACE.CONTROL.WINDOW) (DSPFILL (CREATEREGION 0 0 (fetch IMAGEWIDTH of MENU) (fetch IMAGEHEIGHT of MENU)) 38505 (QUOTE PAINT) ACE.CONTROL.WINDOW]) (ACE.CHECKSTUFF [LAMBDA (CONDITIONS) (* PmT "26-Oct-84 16:10") (COND ((EQ CONDITIONS (QUOTE SEQ)) (OR ACE.CURRENT.SEQUENCE (ACE.TELLEM "No Current Sequence defined. Aborted" T))) ((EQ CONDITIONS (QUOTE FRAME)) (OR ACE.CURRENT.FRAME (ACE.TELLEM "No Current Frame. Aborted" T))) ((EQ CONDITIONS (QUOTE TAIL)) (OR ACE.FRAME.TAIL (ACE.TELLEM "Sequence is at End." T]) (ACE.UPD.CONTROL.WINDOW [LAMBDA (ITEM VALUE) (* MD "18-Jun-85 16:19") (* This puts info in the status region of the control window; ITEM one of: CURSOR, FRAME, DEVICE, OPERATION, UPD, T, RESET. VALUE is the value for the ITEM; The ITEMs and VALUEs are stored as WINDOWPROPs on A.C.W) (ACE.MAC.CW.INFO.CLIP (COND ((AND (KEYDOWNP (QUOTE T)) (EQ ITEM (QUOTE CURSOR))) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) VALUE)) ((EQ ITEM (QUOTE FRAME)) [COND ((EQ VALUE T) (SETQ VALUE (COND ((NULL ACE.CURRENT.SEQUENCE) (QUOTE NA)) ((EQ ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL) (QUOTE START)) (T (LENGTH (LDIFF ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL] (ACE.UPD.CW.MULE (QUOTE ACE.FRAME) VALUE)) ((EQ ITEM (QUOTE DEVICE)) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE) VALUE)) ((EQ ITEM (QUOTE OPERATION)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION) VALUE)) ((EQ ITEM (QUOTE UPD)) (ACE.UPD.CONTROL.WINDOW2 (QUOTE FRAME) T) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION) (QUOTE OK)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) (QUOTE NA))) ((EQ ITEM T) (ACE.UPD.CW.MULE (QUOTE ACE.FRAME)) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR))) ((EQ ITEM (QUOTE RESET)) (ACE.UPD.CONTROL.WINDOW2 (QUOTE FRAME) T) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE) (QUOTE MOUSE)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION) (QUOTE NA)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) (QUOTE NA]) (ACE.UPD.CW.MULE [LAMBDA (ITEM VALUE) (* MD "18-Jun-85 16:49") (* An elaborate WINDOWPROPer. If VALUE is given, it's put on A.C.W as prop ITEM; if VALUE = NIL, returns the current value of ITEM. Also, writes the value in the status region of A.C.W. ITEM one of: ACE.CURSOR ACE.FRAME ACE.OPERATION ACE.DEVICE. Some restrictions of what VALUE can be (see code); Returns VALUE) (COND [(AND (KEYDOWNP (QUOTE T)) (EQ ITEM (QUOTE ACE.CURSOR))) [COND ((OR (POSITIONP VALUE) (EQ VALUE (QUOTE NA))) (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE)) (T (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM] (ACE.UPD.CLEAR.SET.LINE 4) (COND ((POSITIONP VALUE) (printout ACE.CONTROL.WINDOW " Cursor: " (CAR VALUE) " " (CDR VALUE) .SP 10)) (T (printout ACE.CONTROL.WINDOW " Cursor: " VALUE .SP 10] ((EQ ITEM (QUOTE ACE.FRAME)) [COND ((OR (FIXP VALUE) (EQ VALUE (QUOTE START)) (EQ VALUE (QUOTE NA))) (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE)) (T (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM] (ACE.UPD.CLEAR.SET.LINE 1) (printout ACE.CONTROL.WINDOW " Frame: " VALUE .SP 20)) ((EQ ITEM (QUOTE ACE.OPERATION)) (COND ((NULL VALUE) (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM))) (T (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE))) (ACE.UPD.CLEAR.SET.LINE 3) (printout ACE.CONTROL.WINDOW " State: " VALUE .SP 20)) ((EQ ITEM (QUOTE ACE.DEVICE)) [COND ((OR (EQ VALUE (QUOTE MOUSE)) (EQ VALUE (QUOTE MM1201))) (WINDOWPROP ACE.CONTROL.WINDOW ITEM VALUE)) (T (SETQ VALUE (WINDOWPROP ACE.CONTROL.WINDOW ITEM] (ACE.UPD.CLEAR.SET.LINE 2) (printout ACE.CONTROL.WINDOW " Device: " (COND ((EQ VALUE (QUOTE MOUSE)) (QUOTE MOUSE)) ((EQ VALUE (QUOTE MM1201)) (QUOTE TABLET)) (T (QUOTE NA))) .SP 10))) VALUE]) (ACE.UPD.CLEAR.SET.LINE [LAMBDA (LINES) (* PmT "17-Dec-84 19:11") (MOVETOUPPERLEFT ACE.CONTROL.WINDOW) (RELMOVETO 0 (ITIMES (DSPLINEFEED NIL ACE.CONTROL.WINDOW) (SUB1 LINES)) ACE.CONTROL.WINDOW]) (ACE.CREATE.CONTROL.MENU [LAMBDA NIL (* MD "26-Jun-85 14:11") (SETQ ACE.CONTROL.MENU (create MENU ITEMS _(QUOTE (("Get Sequence" (QUOTE I/O:GET) "Fetch a sequence-file") ("Edit Frame" (QUOTE EDIT) "Edits the CURRENT frame") ("Run Sequence" (QUOTE RUN) "Runs the sequence" (SUBITEMS ("Loop" (QUOTE LOOP) "Runs sequence repeatedly until you type a space") ("Loop part" (QUOTE SUBLOOP) "Runs part of the sequence repeatedly "))) ("Put Sequence" (QUOTE I/O:PUT) "Writes current sequence out to a file") ("New Frame" (QUOTE FRAME) "Adds in another frame AFTER the current one") ("Increment Frame" (QUOTE INC) "Moves forward one frame and displays") ("New Sequence" (QUOTE NEW) "Make a new sequence from scratch") ("Delete Frame" (QUOTE DEL) "Removes CURRENT frame and smoothes over") ("Decrement Frame" (QUOTE DEC) "Goes back one frame") ("Reset Sequence" (QUOTE RESET) "Clears window and resets to start of sequence") (" Adjust Timing Delays " (QUOTE TIME) "Manipulate the timing adjustments") ("Initialize MM1201 Tablet" (QUOTE INIT.MM1201) "Sets up the Tablet for use") ("Change compression %%" (QUOTE ACESETTHRESHOLD) "Changes the space compression factor: 0 to 100 (100 = max compression)") ("Change Input Device" (QUOTE DEVICE) "Select Mouse or Tablet (for now)") ("Quit" (QUOTE QUIT) "Exit ACE; Trillium user's MUST quit when done"))) CENTERFLG _ T MENUCOLUMNS _ 3]) (ACE.SEQ.FETCH.WIDTH [LAMBDA NIL (* PmT "22-Apr-85 19:12") (FETCH (BITMAP BITMAPWIDTH) OF (FETCH (ACE.BLIT BITMAP) OF (CAR (FETCH (ACE.FRAME BLITS) OF (CAR ACE.CURRENT.SEQUENCE]) (ACE.SEQ.FETCH.HEIGHT [LAMBDA NIL (* PmT "22-Apr-85 19:14") (fetch (BITMAP BITMAPHEIGHT) of (fetch (ACE.BLIT BITMAP) of (CAR (fetch (ACE.FRAME BLITS) of (CAR ACE.CURRENT.SEQUENCE]) (ACE.SET.SEQ.CLIP.REGION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* "PmT" "17-Apr-85 18:03") (OR LEFT (SETQ LEFT ACE.SEQ.WINDOW.XOFF)) (OR BOTTOM (SETQ BOTTOM ACE.SEQ.WINDOW.YOFF)) (OR WIDTH (SETQ WIDTH ACE.SEQ.WIDTH)) (OR HEIGHT (SETQ HEIGHT ACE.SEQ.HEIGHT)) (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE SEQUENCE.CLIPPING.REGION) (CREATEREGION LEFT BOTTOM WIDTH HEIGHT]) (ACE.ASKEM2 [LAMBDA (STRING FLG DEFAULTANSWER TIMELIMIT? SPACES?) (* PmT "22-Apr-85 15:56") (* Like ASKEM but uses whole control window  (use cautiously)) (OR TIMELIMIT? (SETQ TIMELIMIT? 60)) (COND ((EQ FLG T) (DSPRESET ACE.CONTROL.WINDOW)) ((EQ FLG (QUOTE L)) (TERPRI ACE.CONTROL.WINDOW))) (MKATOM (PROMPTFORWORD STRING DEFAULTANSWER NIL ACE.CONTROL.WINDOW NIL TIMELIMIT? (AND SPACES? (CHARCODE (EOL ESCAPE LF]) (ACE.TELLEM2 [LAMBDA (STRING FLG) (* PmT "19-Dec-84 19:15") (COND ((EQ FLG T) (DSPRESET ACE.CONTROL.WINDOW)) ((EQ FLG (QUOTE L)) (TERPRI ACE.CONTROL.WINDOW))) (printout ACE.CONTROL.WINDOW STRING) NIL]) (ACE.UPD.CONTROL.WINDOW2 [LAMBDA (ITEM VALUE) (* PmT "19-Dec-84 15:49") (COND ((EQ ITEM (QUOTE FRAME)) [COND ((EQ VALUE T) (SETQ VALUE (COND ((NULL ACE.CURRENT.SEQUENCE) (QUOTE NA)) ((EQ ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL) (QUOTE START)) (T (LENGTH (LDIFF ACE.CURRENT.SEQUENCE ACE.FRAME.TAIL] (ACE.UPD.CW.MULE (QUOTE ACE.FRAME) VALUE)) ((EQ ITEM (QUOTE DEVICE)) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE) VALUE)) ((EQ ITEM (QUOTE OPERATION)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION) VALUE)) ((EQ ITEM (QUOTE CURSOR)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) VALUE)) ((EQ ITEM (QUOTE UPD)) (ACE.UPD.CONTROL.WINDOW2 (QUOTE FRAME) T) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION) (QUOTE OK)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) (QUOTE NA))) ((EQ ITEM T) (ACE.UPD.CW.MULE (QUOTE ACE.FRAME)) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR))) ((EQ ITEM (QUOTE RESET)) (ACE.UPD.CONTROL.WINDOW2 (QUOTE FRAME) T) (ACE.UPD.CW.MULE (QUOTE ACE.DEVICE) (QUOTE MOUSE)) (ACE.UPD.CW.MULE (QUOTE ACE.OPERATION) (QUOTE NA)) (ACE.UPD.CW.MULE (QUOTE ACE.CURSOR) (QUOTE NA]) ) (* The following Macros set up restricting clipping regions) (DECLARE: EVAL@COMPILE (PUTPROPS ACE.MAC.CW.INFO.CLIP MACRO ((FORM) (RESETLST [RESETSAVE (PROGN (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE INFO.CLIP.REGION)) ACE.CONTROL.WINDOW) (DSPLEFTMARGIN (fetch (REGION LEFT) of (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE INFO.CLIP.REGION))) ACE.CONTROL.WINDOW)) (QUOTE (PROGN (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE NORMAL.CLIP.REGION)) ACE.CONTROL.WINDOW) (DSPLEFTMARGIN (fetch (REGION LEFT) of (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE NORMAL.CLIP.REGION))) ACE.CONTROL.WINDOW] FORM))) (PUTPROPS ACE.MAC.CW.PROMPT.CLIP MACRO ((FORM) (RESETLST [RESETSAVE (PROGN (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE PROMPT.CLIP.REGION)) ACE.CONTROL.WINDOW) (DSPLEFTMARGIN (fetch (REGION LEFT) of (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE PROMPT.CLIP.REGION))) ACE.CONTROL.WINDOW)) (QUOTE (PROGN (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE NORMAL.CLIP.REGION)) ACE.CONTROL.WINDOW) (DSPLEFTMARGIN (fetch (REGION LEFT) of (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE NORMAL.CLIP.REGION))) ACE.CONTROL.WINDOW] FORM))) (PUTPROPS ACE.MAC.SEQ.CLIP MACRO ((FORM) (COND ((WINDOWPROP ACE.CONTROL.WINDOW (QUOTE SEQUENCE.CLIPPING.REGION)) (RESETLST (RESETSAVE (DSPCLIPPINGREGION (WINDOWPROP ACE.CONTROL.WINDOW (QUOTE SEQUENCE.CLIPPING.REGION)) ACE.SEQ.WINDOW) (LIST (QUOTE DSPCLIPPINGREGION) (DSPCLIPPINGREGION NIL ACE.SEQ.WINDOW) ACE.SEQ.WINDOW)) FORM)) (T FORM)))) ) (DECLARE: EVAL@COMPILE (PUTPROPS ACE.MAC.FETCH.WIDTH MACRO [NIL (fetch (BITMAP BITMAPWIDTH) of (fetch (ACE.BLIT BITMAP) of (CAR (fetch (ACE.FRAME BLITS) of (CAR ACE.CURRENT.SEQUENCE]) (PUTPROPS ACE.MAC.FETCH.HEIGHT MACRO [NIL (fetch (BITMAP BITMAPHEIGHT) of (fetch (ACE.BLIT BITMAP) of (CAR (fetch (ACE.FRAME BLITS) of (CAR ACE.CURRENT.SEQUENCE]) ) (RPAQ ACE.LEFTMOUSE.CURSOR (CURSORCREATE (READBITMAP) 8 8)) (16 16 "GOOL" "D@@D" "ELID" "ELID" "ELID" "ELID" "ELID" "ELID" "ELID" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "GOOL")(RPAQ ACE.MIDDLEMOUSE.CURSOR (CURSORCREATE (READBITMAP) 8 8)) (16 16 "GOOL" "D@@D" "ECID" "ECID" "ECID" "ECID" "ECID" "ECID" "ECID" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "GOOL")(RPAQ ACE.RIGHTMOUSE.CURSOR (CURSORCREATE (READBITMAP) 8 8)) (16 16 "GOOL" "D@@D" "EBGD" "EBGD" "EBGD" "EBGD" "EBGD" "EBGD" "EBGD" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "GOOL")(RPAQ ACE.ALLMOUSE.CURSOR (CURSORCREATE (READBITMAP) 8 8)) (16 16 "GOOL" "D@@D" "DMKD" "DMKD" "DMKD" "DMKD" "DMKD" "DMKD" "DMKD" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "D@@D" "GOOL")(DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ACE.CONTROL.WINDOW ACE.DIRECTORY ACE.SEQ.WINDOW ACE.SEQ.WIDTH ACE.SEQ.HEIGHT ACE.SEQ.WINDOW.XOFF ACE.SEQ.WINDOW.YOFF ACE.CURRENT.SEQUENCE ACE.CURRENT.SEQUENCE.NAME ACE.FRAME.TAIL ACE.CURRENT.FRAME ACE.VERTICAL.BLOCK ACE.AREA.THRESHOLD ACE.RUNNING.UNDER.TRILLIUM ACE.LEFTMOUSE.CURSOR ACE.MIDDLEMOUSE.CURSOR ACE.RIGHTMOUSE.CURSOR ACE.ALLMOUSE.CURSOR) ) (* MENUS IN MAIN) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ACE.CONTROL.MENU ACE.DELAY.MENU ACE.SET.DEVICE.MENU) ) (SETQ ACE.CONTROL.WINDOW NIL) (SETQ ACE.CONTROL.MENU NIL) (SETQ ACE.DELAY.MENU NIL) (SETQ ACE.SET.DEVICE.MENU NIL) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (2486 20306 (ACE 2496 . 5159) (ACE.ANIMATE 5161 . 6340) (ACE.RUN 6342 . 7336) ( ACEGETFRAME# 7338 . 7525) (ACERUNLOOP 7527 . 7999) (ACE.NEW.SEQUENCE 8001 . 9336) (ACE.NEW.FRAME 9338 . 10040) (ACE.QUIT.ACE 10042 . 10763) (ACE.RESET.SEQ 10765 . 11153) (ACE.RUN.CURRENT.SEQ 11155 . 11693) (ACE.DELAY 11695 . 12629) (ACE.DELAY.FRAME 12631 . 13715) (ACE.DELAY.SEQ 13717 . 14134) ( ACE.DECREMENT.FRAME 14136 . 14487) (ACE.INCREMENT.FRAME 14489 . 15586) (ACE.DELETE.FRAME 15588 . 17033 ) (ACE.SET.DEVICE 17035 . 17826) (ACE.QUICKDRAW&UPD 17828 . 19115) (ACE.RECONSTRUCT.FRAME 19117 . 20142) (SUBLIST 20144 . 20304)) (20334 27610 (ACE.TRILLIUM 20344 . 23762) (ACE.TRILLIUM.LOOP 23764 . 25048) (ACE.RUN.TRILLIUM 25050 . 26596) (ACE.QUIT.TRILLIUM 26598 . 26820) (ACE.CREATE.EDITING.BORDER 26822 . 27608)) (27633 32897 (ACE.GET.SEQ.FILE 27643 . 29909) (ACE.PUT.SEQ.FILE 29911 . 32728) ( ACE.GET.A.FILE.NAME 32730 . 32895)) (32921 51702 (ACE.ASKEM 32931 . 33917) (ACE.TELLEM 33919 . 34458) (ACE.CONFIRMIT 34460 . 35379) (ACE.DEFINE.SEQ.WINDOW 35381 . 36490) (ACE.FIGURE.OUT.WINDOW 36492 . 37362) (ACE.RETURN.CLOSEST.VERTEX 37364 . 38107) (ACE.NEW.SEQ.ASST 38109 . 38672) ( ACE.DELAY.FRAME.ASST 38674 . 38964) (ACE.SETUP.CW.CLIPPING.REGIONS 38966 . 41073) (ACE.CHECKSTUFF 41075 . 41565) (ACE.UPD.CONTROL.WINDOW 41567 . 43687) (ACE.UPD.CW.MULE 43689 . 45893) ( ACE.UPD.CLEAR.SET.LINE 45895 . 46183) (ACE.CREATE.CONTROL.MENU 46185 . 48212) (ACE.SEQ.FETCH.WIDTH 48214 . 48500) (ACE.SEQ.FETCH.HEIGHT 48502 . 48784) (ACE.SET.SEQ.CLIP.REGION 48786 . 49245) ( ACE.ASKEM2 49247 . 49835) (ACE.TELLEM2 49837 . 50140) (ACE.UPD.CONTROL.WINDOW2 50142 . 51700))))) STOP \ No newline at end of file diff --git a/lispusers/ACE-PRIM b/lispusers/ACE-PRIM new file mode 100644 index 00000000..66aabc69 --- /dev/null +++ b/lispusers/ACE-PRIM @@ -0,0 +1 @@ +(FILECREATED "28-May-86 17:27:25" {ICE}LISP>ACE-PRIM.;3 11267 changes to: (FNS ACE.SCAN.PRIMBLOCKS ACE.FETCH.BLOCK ACE.MAX.REGIONS ACE.PICK.BEST.REGION ACE.COMPUTE.AREA ACE.COMPILE.FRAME ACE.EXTRACT) previous date: "20-Jun-85 10:39:15" {ICE}LISP>ACE-PRIM.;2) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT ACE-PRIMCOMS) (RPAQQ ACE-PRIMCOMS ((* COMPILER STUFF) (VARS ACE.PIXPERWORD ACE.BITMAP.MASK) (* LOW LEVEL COMPILER FNS) (FNS ACE.COMPILE.FRAME ACE.EXTRACT ACESETTHRESHOLD) (* REGION MAXING ROUTINES) (FNS ACE.MAX.REGIONS ACE.PICK.BEST.REGION ACE.COMPUTE.AREA) (* LOW LEVEL BITMAP COMPARISON) (FNS ACE.SCAN.BITMAPS ACE.SCAN.PRIMBLOCKS ACE.FETCH.BLOCK))) (* COMPILER STUFF) (RPAQQ ACE.PIXPERWORD 16) (RPAQ ACE.BITMAP.MASK (READARRAY 16 (QUOTE SMALLPOSP) 0)) (65535 32768 49152 57344 61440 63488 64512 65024 65280 65408 65472 65504 65520 65528 65532 65534 NIL ) (* LOW LEVEL COMPILER FNS) (DEFINEQ (ACE.COMPILE.FRAME [LAMBDA (BM.ORIG BM.CHANGED VERTICAL.BLOCK THRESHOLD) (* MJD "28-May-86 16:35") (* MAIN ENTRY POINT FOR DIFFERENTIAL BITMAP COMPILING) (* WARNING: NO ERROR CHECKING DONE FROM HERE DOWN!) (* RETURNS A FRAMEPATCH LIST OF ACTUAL BITMAP CHANGES) (* RETURN FORMAT: ((BM X . Y)  (BM X . Y) ...)) (PROG (CHANGES) (SETQ CHANGES (ACE.SCAN.BITMAPS BM.ORIG BM.CHANGED VERTICAL.BLOCK)) (AND CHANGES (SETQ CHANGES (ACE.MAX.REGIONS CHANGES THRESHOLD))) (SETQ CHANGES (ACE.EXTRACT CHANGES BM.CHANGED)) (ACE.UPD.CONTROL.WINDOW (QUOTE OPERATION) "DONE") (RETURN CHANGES]) (ACE.EXTRACT [LAMBDA (REGIONS BITMAP) (* MJD "28-May-86 13:12") (* TAKES LIST OF REGIONS OF CHANGED AREAS AND MAKES  INTO ACTUAL FRAMEPATCH LIST BY EXTRACTING FROM NEW BM) (PROG (TEMP.BITMAP LEFT BOTTOM WIDTH HEIGHT (FRAMEBLITLIST (CONS))) [COND ((NULL REGIONS) NIL) (T (for X in REGIONS do (BLOCK) (SETQ LEFT (fetch (REGION LEFT) of X)) (SETQ BOTTOM (fetch (REGION BOTTOM) of X)) (SETQ WIDTH (fetch (REGION WIDTH) of X)) (SETQ HEIGHT (fetch (REGION HEIGHT) of X)) (SETQ TEMP.BITMAP (BITMAPCREATE WIDTH HEIGHT 1)) (BITBLT BITMAP LEFT BOTTOM TEMP.BITMAP 0 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (NCONC1 FRAMEBLITLIST (create ACE.BLIT BITMAP _ TEMP.BITMAP XCOOR _ LEFT YCOOR _ BOTTOM] (RETURN (CDR FRAMEBLITLIST]) (ACESETTHRESHOLD [LAMBDA NIL (* MD "19-Jun-85 15:46") (PROG NIL LOOP(SETQ ACE.AREA.THRESHOLD (RNUMBER (CONCAT "Compression factor(0-100), currently " ACE.AREA.THRESHOLD ": "))) (IF (OR (ILESSP ACE.AREA.THRESHOLD 0) (IGREATERP ACE.AREA.THRESHOLD 100)) THEN (GO LOOP)) (RETURN ACE.AREA.THRESHOLD]) ) (* REGION MAXING ROUTINES) (DEFINEQ (ACE.MAX.REGIONS [LAMBDA (REGIONS THRESHOLD) (* MJD "28-May-86 13:11") (* Merges the changed regions picked out by ACE.SCAN.BITMAPS; REGIONS are small areas of change, THRESHOLD  specifies how much bitmap area must by "good" for a combination (i.e. 100 - THRESHOLD is how much space may be wasted in combining two REGIONS); Both ARGS required!) (* RETURNS A LIST OF (REGION REGION ...)) (PROG (BEST.POSS) LOOP(BLOCK) (COND [(IGREATERP (LENGTH REGIONS) 1) (SETQ BEST.POSS (ACE.PICK.BEST.REGION REGIONS)) (COND ((IGEQ (CADDR BEST.POSS) THRESHOLD) (NCONC1 REGIONS (CONS (UNIONREGIONS (CAAR BEST.POSS) (CAADR BEST.POSS)) (CADDR BEST.POSS))) (DREMOVE (CAR BEST.POSS) REGIONS) (DREMOVE (CADR BEST.POSS) REGIONS)) (T (GO DONE] (T (GO DONE))) (GO LOOP) DONE(RETURN (for X in REGIONS collect (CAR X]) (ACE.PICK.BEST.REGION [LAMBDA (REGIONS) (* MJD "28-May-86 13:11") (* SLOWest part of animation! Selects the most efficient (i.e. least amount of wasted space resulting from  combining two regions) combination of two regions from REGIONS; First tries to find 100% match up; failing that goes for highest efficiency) (PROG (EFFICIENCY BEST.SO.FAR) [COND [(for X in REGIONS thereis (AND (EQP (CDR X) 100) (for Y in (CDR (MEMB X REGIONS)) thereis (AND (PROG1 T (BLOCK)) (EQP (CDR Y) 100) [OR [AND (EQP (fetch (REGION LEFT) of (CAR X)) (fetch (REGION LEFT) of (CAR Y))) (OR [EQP (fetch (REGION BOTTOM) of (CAR Y)) (ADD1 (fetch (REGION TOP) of (CAR X] (EQP (ADD1 (fetch (REGION TOP) of (CAR Y))) (fetch (REGION BOTTOM) of (CAR X] (AND (EQP (fetch (REGION BOTTOM) of (CAR X)) (fetch (REGION BOTTOM) of (CAR Y))) (OR [EQP (fetch (REGION LEFT) of (CAR Y)) (ADD1 (fetch (REGION RIGHT) of (CAR X] (EQP (ADD1 (fetch (REGION RIGHT) of (CAR Y))) (fetch (REGION LEFT) of (CAR X] (SETQ BEST.SO.FAR (LIST X Y 100] (T (SETQ BEST.SO.FAR (QUOTE (NIL NIL -1))) (for X in REGIONS do (for Y in (CDR (MEMB X REGIONS)) do ((SETQ EFFICIENCY (IQUOTIENT [ITIMES 100 (IPLUS (ACE.COMPUTE.AREA (CAR X) (CDR X)) (ACE.COMPUTE.AREA (CAR Y) (CDR Y] (ACE.COMPUTE.AREA (UNIONREGIONS (CAR X) (CAR Y)) 100))) (AND (IGREATERP EFFICIENCY (CADDR BEST.SO.FAR)) (SETQ BEST.SO.FAR (LIST X Y EFFICIENCY] (RETURN BEST.SO.FAR]) (ACE.COMPUTE.AREA [LAMBDA (REGION EFF) (* MJD "28-May-86 13:10") (BLOCK) (IQUOTIENT (ITIMES (ffetch (REGION WIDTH) of REGION) (ffetch (REGION HEIGHT) of REGION) EFF) 100]) ) (* LOW LEVEL BITMAP COMPARISON) (DEFINEQ (ACE.SCAN.BITMAPS [LAMBDA (BM.ORIG BM.NEW BLOCKINGHEIGHT) (* PmT "25-Apr-85 15:14") (* Compares BM.ORIG and BM.NEW in one word (ACE.PIXPERWORD bits; 16) by BLOCKINGHEIGHT rectangles. Note masking when get to last word in bitmap and compression of region below ACE.PIXPERWORD  (16); All ARGS required; BM.ORIG and BM.NEW must have the same dimensions!) (* RETURNS A LIST OF TYPE (REGION . 100)) (PROG [TEMP.ENTRY (BM.WIDTH (ffetch BITMAPWIDTH of BM.ORIG)) (CHANGED.REGIONS (CONS)) (RASTERWIDTH (SUB1 (ffetch BITMAPRASTERWIDTH of BM.ORIG))) (HEIGHT (SUB1 (ffetch BITMAPHEIGHT of BM.ORIG))) (ALLMASK (ELT ACE.BITMAP.MASK 0)) (PARTIALMASK (ELT ACE.BITMAP.MASK (IMOD (ffetch BITMAPWIDTH of BM.ORIG) ACE.PIXPERWORD] [while (ILESSP Y HEIGHT) bind (Y _ 0) do [for HORZ.BLOCK from 0 to RASTERWIDTH do (AND [SETQ TEMP.ENTRY (COND ((EQP HORZ.BLOCK RASTERWIDTH) (ACE.SCAN.PRIMBLOCKS BM.ORIG BM.NEW HORZ.BLOCK Y BLOCKINGHEIGHT PARTIALMASK)) (T (ACE.SCAN.PRIMBLOCKS BM.ORIG BM.NEW HORZ.BLOCK Y BLOCKINGHEIGHT ALLMASK] (NCONC1 CHANGED.REGIONS (CONS [CREATEREGION (ITIMES HORZ.BLOCK ACE.PIXPERWORD) (CAR TEMP.ENTRY) (IMIN ACE.PIXPERWORD (IDIFFERENCE BM.WIDTH (ITIMES HORZ.BLOCK ACE.PIXPERWORD))) (ADD1 (IDIFFERENCE (CDR TEMP.ENTRY) (CAR TEMP.ENTRY] 100] (SETQ Y (IPLUS Y BLOCKINGHEIGHT)) (SETQ BLOCKINGHEIGHT (IMIN BLOCKINGHEIGHT (ADD1 (IDIFFERENCE HEIGHT Y] (RETURN (CDR CHANGED.REGIONS]) (ACE.SCAN.PRIMBLOCKS [LAMBDA (BM1 BM2 WORDOFFSET Y0 BLOCKH MASK) (* MJD "28-May-86 13:05") (* Does the actual comparison of primitive areas in the two bitmaps BM1 and BM2 ; WORDOFFSET is the raster word  offset; Y0 is the low scanline and (IPLUS Y0 BLOCKH) is the hi one; MASK is usually $FFFF, otherwise it is used to  ignore extra bits trailing off the end of the last raster word) (PROG [TEMP1 (MAXY (SUB1 (IPLUS Y0 BLOCKH] [SETQ TEMP1 (for Y from Y0 to MAXY thereis (NOT (EQP (LOGAND (LOGXOR (ACE.FETCH.BLOCK BM1 WORDOFFSET Y) (ACE.FETCH.BLOCK BM2 WORDOFFSET Y)) MASK) 0] (RETURN (AND TEMP1 (CONS TEMP1 (for Y from MAXY to TEMP1 by -1 thereis (NOT (EQP (LOGAND (LOGXOR (ACE.FETCH.BLOCK BM1 WORDOFFSET Y) (ACE.FETCH.BLOCK BM2 WORDOFFSET Y)) MASK) 0]) (ACE.FETCH.BLOCK [LAMBDA (BITMAP WORDOFFSET VERTICAL) (* MJD "28-May-86 13:04") (* Nabs a word from bitmap on line VERTICAL with word  offset WORDOFFSET) (BLOCK) (\GETBASE (\ADDBASE (ffetch BITMAPBASE of BITMAP) (ITIMES (IDIFFERENCE (ffetch BITMAPHEIGHT of BITMAP) (ADD1 VERTICAL)) (ffetch BITMAPRASTERWIDTH of BITMAP))) WORDOFFSET]) ) (PUTPROPS ACE-PRIM COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1061 3539 (ACE.COMPILE.FRAME 1071 . 2018) (ACE.EXTRACT 2020 . 3087) (ACESETTHRESHOLD 3089 . 3537)) (3575 7485 (ACE.MAX.REGIONS 3585 . 4741) (ACE.PICK.BEST.REGION 4743 . 7211) ( ACE.COMPUTE.AREA 7213 . 7483)) (7526 11188 (ACE.SCAN.BITMAPS 7536 . 9541) (ACE.SCAN.PRIMBLOCKS 9543 . 10652) (ACE.FETCH.BLOCK 10654 . 11186))))) STOP \ No newline at end of file diff --git a/lispusers/ACE.TEDIT b/lispusers/ACE.TEDIT new file mode 100644 index 00000000..b1eaace8 Binary files /dev/null and b/lispusers/ACE.TEDIT differ diff --git a/lispusers/ADDRESSBOOK b/lispusers/ADDRESSBOOK new file mode 100644 index 00000000..ee68f09c --- /dev/null +++ b/lispusers/ADDRESSBOOK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Jul-88 16:36:22" |{FS8:PARC:XEROX}LISP>ADDRESSBOOK.;2| 4326 changes to%: (FILES LOOKUPINFILES) previous date%: "19-Nov-86 15:02:45" |{FS8:PARC:XEROX}LISP>ADDRESSBOOK.;1|) (* " Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ADDRESSBOOKCOMS) (RPAQQ ADDRESSBOOKCOMS ((FNS MakeAddressBook) (INITVARS (*Address-Book-Pos* (create POSITION XCOORD _ 970 YCOORD _ (DIFFERENCE SCREENHEIGHT 90))) (*Address-Book-Region* (CREATEREGION 300 (DIFFERENCE SCREENHEIGHT 500) 400 200)) (*AddressBookFiles* (COND ((BOUNDP (QUOTE PHONELISTFILES)) PHONELISTFILES)))) (VARS AddressBookBM AddressBookMask) (FILES LOOKUPINFILES) (P (MakeAddressBook))) ) (DEFINEQ (MakeAddressBook (LAMBDA NIL (* dgb%: "19-Nov-86 10:34") (* * Create a lookup window for address books) (MakeLookupWindow *AddressBookFiles* (QUOTE Address% Book) *Address-Book-Region* AddressBookBM AddressBookMask *Address-Book-Pos*)) ) ) (RPAQ? *Address-Book-Pos* (create POSITION XCOORD _ 970 YCOORD _ (DIFFERENCE SCREENHEIGHT 90))) (RPAQ? *Address-Book-Region* (CREATEREGION 300 (DIFFERENCE SCREENHEIGHT 500) 400 200)) (RPAQ? *AddressBookFiles* (COND ((BOUNDP (QUOTE PHONELISTFILES)) PHONELISTFILES))) (RPAQQ AddressBookBM #*(50 87)@COOOOOOOOO@@@@@@OOOOOOOOOOL@@@@AN@@@@@@@@AN@@@@CH@@@@@@@@@G@@@@G@@@@@@@@@@CH@@@F@@@@@@@@@@AH@@@NCOOOOOOOOOAL@@@LB@@@@@B@AA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@GOHL@@@LB@@@@@B@OOHL@@@LB@@@@@BAOOHL@@@LB@@@@@BC@GHL@@@LB@@@@@BAOOHL@@@LB@@@@@B@OOHL@@@LB@@@@@B@GOHL@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@BAIA@L@@@LB@@@@@BAIA@L@@@LB@@@@@B@AA@L@@@LB@@@@@B@AA@L@@@LB@@@@@COOA@L@@@LB@@@@@@@@A@L@@@LB@@@@@@@@A@L@@@LB@@@@@@@@A@L@@@LB@@@@@@@@A@L@@@LB@@@@@@@@A@L@@@LCOOOOOOOOO@L@@@N@@D@@@@@H@AL@@@F@@D@@@@@H@AH@@@G@@D@@@@@H@CH@@@CH@GOOOOOH@G@@@@AN@@@@@@@@AN@@@@@OOOOOOOOOOL@@@@@COOOOOOOOO@@@@@ ) (RPAQQ AddressBookMask #*(50 87)@COOOOOOOOO@@@@@@OOOOOOOOOOL@@@@AOOOOOOOOOON@@@@COOOOOOOOOOO@@@@GOOOOOOOOOOOH@@@GOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOH@@@GOOOOOOOOOOOH@@@GOOOOOOOOOOO@@@@COOOOOOOOOON@@@@AOOOOOOOOOOL@@@@@OOOOOOOOOOH@@@@@COOOOOOOON@@@@@ ) (FILESLOAD LOOKUPINFILES) (MakeAddressBook) (PUTPROPS ADDRESSBOOK COPYRIGHT ("Xerox Corporation" 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (798 1051 (MakeAddressBook 808 . 1049))))) STOP \ No newline at end of file diff --git a/lispusers/ADDRESSBOOK.TEDIT b/lispusers/ADDRESSBOOK.TEDIT new file mode 100644 index 00000000..76d38834 Binary files /dev/null and b/lispusers/ADDRESSBOOK.TEDIT differ diff --git a/lispusers/AIREGIONS b/lispusers/AIREGIONS new file mode 100644 index 00000000..68927400 --- /dev/null +++ b/lispusers/AIREGIONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Dec-87 13:48:32" {ERINYES}LYRIC>AIREGIONS.;1 37025 changes to%: (VARS AIREGIONSCOMS) previous date%: " 9-Mar-87 16:37:52" {DANTE}LYRIC>AIREGIONS.;1) (* " Copyright (c) 1985, 1986, 1987 by XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT AIREGIONSCOMS) (RPAQQ AIREGIONSCOMS [(FILES FILLREGION) (FNS ADD.IREGION ALL.IREGIONS CREATEIR REMOVE.IREGION DOSELECTED.IREGION EDIT.MASK IREGIONP IREGIONPROP SHOW.ALL.IREGIONS INTERSECTING.IREGIONS? INVERT.IREGION WHICH.IREGIONS SURROUNDIR) (FNS IN.CURSOR.REGION \IR.CLIP.REGION \IR.SHOW.REGION \VALID.POSITION.LIST \SAME.IREGIONS.LIST \WITH.INTERSECTION \IREGION.ON.WINDOWP) (RECORDS IREGION) (PROP ARGNAMES IREGIONPROP) (VARS (DEFAULT.IREGION.SHADE 65535)) (GLOBALVARS DEFAULT.IREGION.SHADE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA IREGIONPROP]) (FILESLOAD FILLREGION) (DEFINEQ (ADD.IREGION [LAMBDA (WINDOW IREGION) (* GWexler " 7-Feb-86 10:22") (if (AND (NOT (\IREGION.ON.WINDOWP IREGION WINDOW)) (IREGIONP IREGION) (WINDOWP WINDOW)) then (WINDOWPROP WINDOW 'BUTTONEVENTFN 'IN.CURSOR.REGION) (WINDOWADDPROP WINDOW 'IREGIONSLIST IREGION T) IREGION]) (ALL.IREGIONS [LAMBDA (WINDOW) (* GWexler " 7-Feb-86 10:23") (* * This function returns all the IREGIONs of WINDOW.) (if (WINDOWP WINDOW) then (WINDOWPROP WINDOW 'IREGIONSLIST) else NIL]) (CREATEIR [LAMBDA (WINDOW SHADE BUTTONEVENTFN HELPSTRING REGION POSLIST) (* GWexler " 7-Feb-86 10:30") (* * This function is the top-level interface to creating IREGIONS and  associating them with a given window.) (PROG (TEMP-REGION TEMP-BITMAP POS MASK POSITIONS) (* If WINDOW is not a window, then return.  If the user wants just an IREGION record, he/she should use  (create IREGION BUTTONEVENTFN _ ??? USERDATA _ ??? REGION _ ??? MASK _ ???  SHADE _ ??? HELPSTRING _ ???)) (OR (WINDOWP WINDOW) (RETURN NIL)) (WINDOWPROP WINDOW 'BUTTONEVENTFN 'IN.CURSOR.REGION) (SETQ TEMP-REGION (if (REGIONP REGION) then (* Here, the user passes us a REGION relative to WINDOW and we translate it to  screen coordinates. (We need this in screen coordinates since that is what  GETREGION returns.)) (LIST [IPLUS (CAR REGION) (CAR (WINDOWPROP WINDOW 'REGION] [IPLUS (CADR REGION) (CADR (WINDOWPROP WINDOW 'REGION] (CADDR REGION) (CADDDR REGION)) else (* If REGION was not a region, then we prompt the user for one.) (PROMPTPRINT "Please closely surround the irregular region " "without cutting off the region's borders") (TOTOPW WINDOW) (GETREGION))) (* Here, we clip TEMP-REGION so that it fits inside the window so that we don't  waste any space with too large bitmaps. If the region did not fall inside the  window at all, then \IR.CLIP.REGION returns NIL and we return from CREATEIR.) (SETQ TEMP-REGION (OR (\IR.CLIP.REGION TEMP-REGION WINDOW) (RETURN NIL))) (* We create two bitmaps the size of TEMP-REGION that will contain the mask for  the IREGION. We need one extra just for temporary storage in CREATEIR.) (SETQ TEMP-BITMAP (BITMAPCREATE (CADDR TEMP-REGION) (CADDDR TEMP-REGION) 1)) (* We save the window image in  TEMP-REGION in TEMP-BITMAP.) (TOTOPW WINDOW) (BITBLT WINDOW (CAR TEMP-REGION) (CADR TEMP-REGION) TEMP-BITMAP 0 0) (* MASK is just a copy of TEMP-BITMAP) (SETQ MASK (BITMAPCOPY TEMP-BITMAP)) (* The user can pass either NIL or a list of positions to fill from in the  argument POSLIST. \VALID.POSITION.LIST returns either NIL %, ERROR, or a list  of positions. ERROR means to abort the call to CREATEIR since POSLIST was not  in any valid form.) (SETQ POSITIONS (\VALID.POSITION.LIST POSLIST)) (OR (NOT (EQ 'ERROR POSITIONS)) (RETURN NIL)) (* If the user did not specify POSLIST %, then we box out TEMP-REGION to let  him/her know where they are working.) (OR POSITIONS (\IR.SHOW.REGION WINDOW TEMP-REGION)) [if (NOT POSITIONS) then (* This part prompts for positions to area fill from until the user buttons  outside of TEMP-REGION.) (PROMPTPRINT "Point your mouse to the inside of the region and " "left-button the irregular shapes in that region. " "To stop selection(s), left-button anywhere away " "from the squared-off region.") (TOTOPW WINDOW) (until (NOT (INSIDEP TEMP-REGION (CAR (SETQ POS (GETPOSITION WINDOW))) (CDR POS))) do (FILL.REGION MASK (CONS (IDIFFERENCE (CAR POS) (CAR TEMP-REGION)) (IDIFFERENCE (CDR POS) (CADR TEMP-REGION))) 65535) (* Show in WINDOW, what was just  filled.) (BITBLT MASK 0 0 WINDOW (CAR TEMP-REGION) (CADR TEMP-REGION)) (TOTOPW WINDOW)) else (* Here, the user has given us a list of positions, and we just go through each  one and fill.) (for P in POSITIONS do (if (INSIDEP TEMP-REGION P) then (FILL.REGION MASK (CONS (IDIFFERENCE (CAR P) (CAR TEMP-REGION)) (IDIFFERENCE (CDR P) (CADR TEMP-REGION))) 65535] (PROMPTPRINT) (* Unbox the region if need be.) (OR POSITIONS (\IR.SHOW.REGION WINDOW TEMP-REGION)) (* Set up MASK to have only black where the area fill filled.) (BITBLT TEMP-BITMAP 0 0 MASK 0 0 NIL NIL 'INPUT 'ERASE) (* Restore the window to its original  image.) (BITBLT TEMP-BITMAP 0 0 WINDOW (CAR TEMP-REGION) (CADR TEMP-REGION)) (* Add the appropriate IREGION to the  windows IREGIONSLIST...) (RETURN (ADD.IREGION WINDOW (create IREGION BUTTONEVENTFN _ BUTTONEVENTFN USERDATA _ NIL REGION _ TEMP-REGION MASK _ MASK SHADE _ (if (NOT (OR (NUMBERP SHADE) (BITMAPP SHADE))) then DEFAULT.IREGION.SHADE else SHADE) HELPSTRING _ HELPSTRING]) (REMOVE.IREGION [LAMBDA (WINDOW IREGION) (* GWexler " 7-Feb-86 10:24") (* Given a window and an IREGION, remove it from that windows IREGIONSLIST) (if (\IREGION.ON.WINDOWP IREGION WINDOW) then (WINDOWDELPROP WINDOW 'IREGIONSLIST IREGION) IREGION]) (DOSELECTED.IREGION [LAMBDA (WINDOW IREGION BUTTON) (* GWexler " 7-Feb-86 10:24") (if (AND (\IREGION.ON.WINDOWP IREGION WINDOW) (IREGIONPROP IREGION 'BUTTONEVENTFN)) then (APPLY* (IREGIONPROP IREGION 'BUTTONEVENTFN) WINDOW IREGION BUTTON]) (EDIT.MASK [LAMBDA (IREGION) (* GWexler " 7-Feb-86 10:24") (* A way of simply editing the MASK of an IREGION) (if (IREGIONP IREGION) then (EDITBM (fetch (IREGION MASK) of IREGION]) (IREGIONP [LAMBDA (IREGION) (* GWexler " 7-Feb-86 10:24") (* Tests to see if IREGION is a valid IREGION.  Returns IREGION if true NIL otherwise.) (if (type? IREGION IREGION) then IREGION else NIL]) (IREGIONPROP [LAMBDA X (* GWexler " 7-Feb-86 10:24") (* Modeled after WINDOWPROP. This is a convenient way of associating  information with an IREGION. If the property of the IREGION is not one of the  fields, then it is stored on the USERDATA field in property list format.) (PROG (IREGION PROP NEWVALUE) (SETQ IREGION (ARG X 1)) (SETQ PROP (ARG X 2)) (* Abort if we do not have an IREGION.) (OR (IREGIONP IREGION) (RETURN NIL)) (if (EQ X 3) then (* In this case, we have a value to set, so do replaces or LISTPUTs.) (SETQ NEWVALUE (ARG X 3)) [if [NOT (MEMB PROP (RECORDFIELDNAMES 'IREGION] then (* In this case, we store the property on the USERDATA field.) (if (NOT (fetch (IREGION USERDATA) of IREGION)) then (* If USERDATA is NIL, we need to set it to  (PROPNAME VALUE)) (replace (IREGION USERDATA) of IREGION with (LIST PROP NEWVALUE) ) else (* USERDATA should already be in proplist format so just do a LISTPUT) (LISTPUT (fetch (IREGION USERDATA) of IREGION) PROP NEWVALUE)) [if (NOT NEWVALUE) then (replace (IREGION USERDATA) of IREGION with (for X on (fetch (IREGION USERDATA) of IREGION) by (CDDR X) when (NOT (EQ (CAR X) PROP)) join (LIST (CAR X) (CADR X] (RETURN NEWVALUE) else (* Here, PROP is one of the IREGIONS fields, so we just replace it.) (RETURN (SELECTQ PROP (BUTTONEVENTFN (replace (IREGION BUTTONEVENTFN) of IREGION with NEWVALUE)) (USERDATA (replace (IREGION USERDATA) of IREGION with NEWVALUE)) (REGION (replace (IREGION REGION) of IREGION with NEWVALUE)) (MASK (replace (IREGION MASK) of IREGION with NEWVALUE)) (SHADE (replace (IREGION SHADE) of IREGION with NEWVALUE)) (HELPSTRING (replace (IREGION HELPSTRING) of IREGION with NEWVALUE)) (ERROR "Not a valid IREGION prop: " PROP] else (* No NEWVALUE was specified so we just want to fetch the right info.) (if [NOT (MEMB PROP (RECORDFIELDNAMES 'IREGION] then (* PROP is not one of IREGIONs fields, so we need to get it off of USERDATA) (RETURN (LISTGET (fetch (IREGION USERDATA) of IREGION) PROP)) else (* Simply fetch the right field of  IREGION.) (RETURN (SELECTQ PROP (BUTTONEVENTFN (fetch (IREGION BUTTONEVENTFN) of IREGION)) (USERDATA (fetch (IREGION USERDATA) of IREGION)) (REGION (fetch (IREGION REGION) of IREGION)) (MASK (fetch (IREGION MASK) of IREGION)) (SHADE (fetch (IREGION SHADE) of IREGION)) (HELPSTRING (fetch (IREGION HELPSTRING) of IREGION)) (ERROR "Not a valid IREGION prop: " PROP]) (SHOW.ALL.IREGIONS [LAMBDA (WINDOW SHADE DELAY) (* GWexler " 7-Feb-86 10:24") (* This function cycles through each IREGION on WINDOW and flashes it in black  and waits DELAY milliseconds. There is code here to do the right thing when the  user aborts.) (LET ((IRS (ALL.IREGIONS WINDOW))) (for X in IRS do (RESETLST [RESETSAVE NIL (LIST 'IREGIONPROP X 'SHADE (IREGIONPROP X 'SHADE] (IREGIONPROP X 'SHADE (OR SHADE 65535)) (INVERT.IREGION WINDOW X) (RESETSAVE NIL (LIST 'INVERT.IREGION WINDOW X)) (BLOCK (OR (NUMBERP DELAY) 500]) (INTERSECTING.IREGIONS? [LAMBDA (WINDOW FLG) (* GWexler " 7-Feb-86 10:24") (* This sets up WINDOW to specify whether or not its overlapping active regions  all get called when buttoned in the overlapping area %.  NIL means no overlapping and T means yes.) (WINDOWPROP WINDOW 'IR.INTERSECTIONFLG FLG]) (INVERT.IREGION [LAMBDA (WINDOW IREGION) (* GWexler " 7-Feb-86 10:25") (* Simply inverts IREGION associated with WINDOW %.  Doesn't do anything if IREGION is not on the window's IREGIONLIST.) (if (\IREGION.ON.WINDOWP IREGION WINDOW) then (TOTOPW WINDOW) (BITBLT (fetch (IREGION MASK) of IREGION) 0 0 WINDOW (CAR (fetch (IREGION REGION) of IREGION)) (CADR (fetch (IREGION REGION) of IREGION)) NIL NIL 'MERGE 'INVERT (fetch (IREGION SHADE) of IREGION]) (WHICH.IREGIONS [LAMBDA (WINDOW POSORX Y) (* GWexler " 7-Feb-86 10:25") (* Returns all the IREGIONS of WINDOW in a list.  NIL if there were none.) (* * IF CURSOR IN REGION'S WINDOW AND REGION'S MASK, IDENTIFY REGION) (* * X AND Y are optional arguments. Same with WINDOW.  The user could just say (WHICHIR) and it would notice where it is, or  Programmatically, the user could pass a window and an X and Y to get which  Iregion.) (LET* [(W (OR (WINDOWP WINDOW) (WHICHW))) (POSITION (if (POSITIONP POSORX) then POSORX else (if (OR (NOT (NUMBERP POSORX)) (NOT (NUMBERP Y))) then (CONS (LASTMOUSEX W) (LASTMOUSEY W)) else (CONS POSORX Y] (for SOME-IREGION in (WINDOWPROP W 'IREGIONSLIST) when [NOT (ZEROP (BITMAPBIT (fetch (IREGION MASK) of SOME-IREGION) (IDIFFERENCE (CAR POSITION) (CAR (fetch (IREGION REGION) of SOME-IREGION))) (IDIFFERENCE (CDR POSITION) (CADR (fetch (IREGION REGION) of SOME-IREGION] collect SOME-IREGION]) (SURROUNDIR [LAMBDA (WINDOW SHADE BUTTONEVENTFN HELPSTRING POSLIST INSIDE.POS) (* GWexler " 7-Feb-86 10:46") (* * This function is the top-level interface to creating IREGIONS inwhich the  innereds specified are ignored and the entire surround regions becomes the  AIREGION which is associated with the given window) (PROG (TEMPW TEMP-REGION TEMP-BITMAP POS MASK POSITIONS POINTS.LST TEMPPOS) (* If WINDOW is not a window, then return.  If the user wants just an IREGION record, he/she should use  (create IREGION BUTTONEVENTFN _ ??? USERDATA _ ??? REGION _ ??? MASK _ ???  SHADE _ ??? HELPSTRING _ ???)) (OR (WINDOWP WINDOW) (RETURN NIL)) (WINDOWPROP WINDOW 'BUTTONEVENTFN 'IN.CURSOR.REGION) (PROMPTPRINT "Please button the area around the particular region. To end, hold the SHIFT key when hitting the last point with the mouse." ) (FLASHWINDOW PROMPTWINDOW 2) (TOTOPW WINDOW) [OR (LISTP POSLIST) (while [AND (NOT (KEYDOWNP 'LSHIFT)) (NOT (KEYDOWNP 'RSHIFT] do [SETQ POSLIST (APPEND POSLIST (LIST (SETQ TEMPPOS (GETPOSITION WINDOW] (BITBLT (CAR CROSSHAIRS) 0 0 WINDOW (DIFFERENCE (CAR TEMPPOS) (CADR CROSSHAIRS)) (DIFFERENCE (CDR TEMPPOS) (CDDR CROSSHAIRS)) NIL NIL 'INPUT 'INVERT] [OR [NLSETQ (SETQ TEMP-REGION (WINDOWPROP (SETQ TEMPW (CREATEW (LIST 0 0 (PLUS (APPLY 'MAX (for I in POSLIST collect (CAR I))) 50) (PLUS (APPLY 'MAX (for I in POSLIST collect (CDR I))) 50)) NIL NIL T)) 'REGION] (SETQ TEMP-REGION (WINDOWPROP (SETQ TEMPW (CREATEW '(0 0 10 10) NIL NIL T)) 'REGION] (PROMPTPRINT "Please button once INSIDE the region") (FLASHWINDOW PROMPTWINDOW 2) [OR (POSITIONP INSIDE.POS) (AND (SETQ INSIDE.POS (GETPOSITION WINDOW)) (for POSITION in POSLIST do (BITBLT (CAR CROSSHAIRS) 0 0 WINDOW (DIFFERENCE (CAR POSITION) (CADR CROSSHAIRS)) (DIFFERENCE (CDR POSITION) (CDDR CROSSHAIRS)) NIL NIL 'INPUT 'INVERT] (* * MAYBE TEMPORARILY XOR IT ON...) (DRAWCURVE POSLIST T 1 NIL TEMPW) (* * Note that having the window open when drawing the curve is kludgy.  In the KOTO release, DIG will be implemented in the system so rather than  having the TEMPW, use an IMAGESTREAM via OPENIMAGESTREAM and do a IMDRAWCURVE  and IMBITBLT. In this mannor, all drawing is hidden from the user and it makes  the package a lot cleaner.) (SETQ TEMP-BITMAP (BITMAPCREATE (CADDR TEMP-REGION) (CADDDR TEMP-REGION) 1)) (* We save the window image in  TEMP-REGION in TEMP-BITMAP.) (TOTOPW TEMPW) (BITBLT TEMPW (CAR TEMP-REGION) (CADR TEMP-REGION) TEMP-BITMAP 0 0) (CLOSEW TEMPW) (* MASK is just a copy of TEMP-BITMAP) (SETQ MASK (BITMAPCOPY TEMP-BITMAP)) (* The user can pass either NIL or a list of positions to fill from in the  argument POSLIST. \VALID.POSITION.LIST returns either NIL %, ERROR, or a list  of positions. ERROR means to abort the call to CREATEIR since POSLIST was not  in any valid form.) (FILL.REGION MASK (CONS (IDIFFERENCE (CAR INSIDE.POS) (CAR TEMP-REGION)) (IDIFFERENCE (CDR INSIDE.POS) (CADR TEMP-REGION))) 65535) (* (BITBLT MASK 0 0 WINDOW  (CAR TEMP-REGION) (CADR TEMP-REGION))) (* * Removing the border) (BITBLT TEMP-BITMAP 0 0 MASK 0 0 NIL NIL 'INPUT 'ERASE) (* (BITBLT TEMP-BITMAP 0 0 WINDOW  (CAR TEMP-REGION) (CADR TEMP-REGION))) (RETURN (ADD.IREGION WINDOW (create IREGION BUTTONEVENTFN _ BUTTONEVENTFN USERDATA _ NIL REGION _ TEMP-REGION MASK _ MASK SHADE _ (if (NOT (OR (NUMBERP SHADE) (BITMAPP SHADE))) then DEFAULT.IREGION.SHADE else SHADE) HELPSTRING _ HELPSTRING]) ) (DEFINEQ (IN.CURSOR.REGION [LAMBDA (WINDOW) (* GWexler " 7-Feb-86 10:27") (* This is WINDOWs BUTTONEVENTFN that gets called for windows with IREGIONS.) (* * IF CURSOR IN REGION'S WINDOW AND REGION'S MASK, SHADE REGION) (PROG [OLD-REGIONS TEMPX TEMPY BUTTON ALLREADY.PROMPT (TIMEOUT.WAIT 1500) (TIMEOUT (SETUPTIMER 1500 NIL 'TICKS 'MILLISECONDS)) (INTERSECTIONFLG (WINDOWPROP WINDOW 'IR.INTERSECTIONFLG] (TOTOPW WINDOW) (* OLD-REGIONS starts out to be all the IREGIONS currently pointed to.  \WITH.INTERSECTION is used to determine whether this is a list of all the  IREGIONS or just one.) (SETQ OLD-REGIONS (\WITH.INTERSECTION (WHICH.IREGIONS WINDOW) INTERSECTIONFLG)) (SETQ TEMPX (LASTMOUSEX WINDOW)) (SETQ TEMPY (LASTMOUSEY WINDOW)) (* Start out and invert all the IREGIONS being pointed to.) (for IR in OLD-REGIONS do (INVERT.IREGION WINDOW IR)) (* BUTTON is set so that the user can use this value.) (SETQ BUTTON (SELECTQ LASTMOUSEBUTTONS (4 'LEFT) (2 'RIGHT) (1 'MIDDLE) (NULL))) (* Now we loop until the mouse comes  back up.) [while (NOT (MOUSESTATE UP)) do (PROG NIL (if (OR (if (EQ TEMPX (SETQ TEMPX (LASTMOUSEX WINDOW))) then (EQ TEMPY (SETQ TEMPY (LASTMOUSEY WINDOW))) else (SETQ TEMPY (LASTMOUSEY WINDOW)) NIL) (\SAME.IREGIONS.LIST OLD-REGIONS (\WITH.INTERSECTION (WHICH.IREGIONS WINDOW (CONS TEMPX TEMPY)) INTERSECTIONFLG))) then (COND ((AND (NOT ALLREADY.PROMPT) (TIMEREXPIRED? TIMEOUT 'TICKS) (NOT (NULL OLD-REGIONS))) (PROMPTPRINT) (for IR in OLD-REGIONS do (printout PROMPTWINDOW (OR (fetch (IREGION HELPSTRING) of IR) "Will select this IRREGULAR region when you release the button." ) T)) (SETQ ALLREADY.PROMPT T))) else (* * WE have moved AND we are at a new Iregion) (if ALLREADY.PROMPT then (PROMPTPRINT)) (for IR in OLD-REGIONS do (INVERT.IREGION WINDOW IR)) (SETQ OLD-REGIONS (\WITH.INTERSECTION (WHICH.IREGIONS WINDOW (CONS TEMPX TEMPY)) INTERSECTIONFLG)) (for IR in OLD-REGIONS do (INVERT.IREGION WINDOW IR)) (SETQ TIMEOUT (SETUPTIMER 1500 TIMEOUT 'TICKS 'MILLISECONDS)) (SETQ ALLREADY.PROMPT NIL] (if ALLREADY.PROMPT then (PROMPTPRINT)) (for IR in OLD-REGIONS do (INVERT.IREGION WINDOW IR)) (for IR in OLD-REGIONS do (DOSELECTED.IREGION WINDOW IR BUTTON]) (\IR.CLIP.REGION [LAMBDA (REG WINDOW) (* GWexler " 7-Feb-86 10:27") (* This function takes a regions and a window and returns a new region that  fits inside the window. If region starts out completely outside of window, then  NIL is returned.) (PROG [LEFT RIGHT TOP BOTTOM (W.REG (WINDOWPROP WINDOW 'REGION] [SETQ W.REG (LIST (CAR W.REG) (CADR W.REG) [IDIFFERENCE (CADDR W.REG) (ITIMES 2 (WINDOWPROP WINDOW 'BORDER] (IDIFFERENCE (CADDDR W.REG) (ITIMES 2 (WINDOWPROP WINDOW 'BORDER] (if (OR (GREATERP (fetch (REGION LEFT) of REG) (fetch (REGION PRIGHT) of W.REG)) (GREATERP (fetch (REGION BOTTOM) of REG) (fetch (REGION PTOP) of W.REG)) (ILESSP (fetch (REGION PRIGHT) of REG) (fetch (REGION LEFT) of W.REG)) (ILESSP (fetch (REGION PTOP) of REG) (fetch (REGION BOTTOM) of W.REG))) then (printout T "None of the region was inside the window." T) (RETURN NIL)) (SETQ LEFT (IMAX (fetch (REGION LEFT) of REG) (fetch (REGION LEFT) of W.REG))) (SETQ RIGHT (IMIN (fetch (REGION PRIGHT) of REG) (fetch (REGION PRIGHT) of W.REG))) (SETQ TOP (IMIN (fetch (REGION PTOP) of REG) (fetch (REGION PTOP) of W.REG))) (SETQ BOTTOM (IMAX (fetch (REGION BOTTOM) of REG) (fetch (REGION BOTTOM) of W.REG))) (RETURN (LIST (IDIFFERENCE LEFT (fetch (REGION LEFT) of W.REG)) (IDIFFERENCE BOTTOM (fetch (REGION BOTTOM) of W.REG)) (IDIFFERENCE RIGHT LEFT) (IDIFFERENCE TOP BOTTOM]) (\IR.SHOW.REGION [LAMBDA (WINDOW REGION) (* GWexler " 7-Feb-86 10:27") (* This function draws a box specified by REGION on WINDOW using invert mode.) (LET ((REG (COPY REGION)) (W (IPLUS (CADDR REGION) (CAR REGION) 1)) (H (IPLUS (CADDDR REGION) (CADR REGION) 1))) (RPLACA REG (SUB1 (CAR REG))) (RPLACA (CDR REG) (SUB1 (CADR REG))) (DRAWLINE (CAR REG) (CADR REG) W (CADR REG) 1 'INVERT WINDOW) (DRAWLINE (CAR REG) H W H 1 'INVERT WINDOW) (DRAWLINE (CAR REG) (CADR REG) (CAR REG) H 1 'INVERT WINDOW) (DRAWLINE W (CADR REG) W H 1 'INVERT WINDOW]) (\VALID.POSITION.LIST [LAMBDA (POSITIONLIST) (* GWexler " 7-Feb-86 10:34") (* Checks out to see if POSITIONLIST is either NIL a valid position, or a list  of valid positions. Returns either NIL ERROR or a list of positions  (maybe only one element list.)) (if (NOT POSITIONLIST) then NIL else (if (POSITIONP POSITIONLIST) then (LIST POSITIONLIST) else (if (LISTP POSITIONLIST) then (if (for P in POSITIONLIST always (POSITIONP P)) then POSITIONLIST else (printout T "Not all elements in this list are positions." T) 'ERROR) else (printout T "POSITIONLIST must be NIL, a position, or a list of positions." T) 'ERROR]) (\SAME.IREGIONS.LIST [LAMBDA (LIST1 LIST2) (* GWexler " 7-Feb-86 10:27") (* Tests to see if two lists of regions are lists of the same regions.) (if (NEQ (LENGTH LIST1) (LENGTH LIST2)) then NIL else (for ELT in LIST1 always (FMEMB ELT LIST2]) (\WITH.INTERSECTION [LAMBDA (IRLIST FLG) (* GWexler " 7-Feb-86 10:34") (* If FLG is T then return IRLIST, otherwise return NIL or a list with just one  element.) (if FLG then IRLIST else (if (NOT IRLIST) then NIL else (LIST (CAR IRLIST]) (\IREGION.ON.WINDOWP [LAMBDA (IREGION WINDOW) (* GWexler " 7-Feb-86 10:27") (if [AND (IREGIONP IREGION) (WINDOWP WINDOW) (FMEMB IREGION (WINDOWPROP WINDOW 'IREGIONSLIST] then IREGION else NIL]) ) (DECLARE%: EVAL@COMPILE (DATATYPE IREGION (BUTTONEVENTFN (* The users function to be called.) USERDATA (* This is where the users data is kept in proplist format.) REGION (* The region relative to the window where the IREGION is located.) MASK (* The mask is the same size as region and contains black where ever the  IREGION is to be active.) SHADE (* The shade which IREGION inverts to  %.) HELPSTRING (* The helpstring to be printed when the button is held down in this IREGION) ) (* there used to be a TYPE? here but it was useless and removed) ) ) (/DECLAREDATATYPE 'IREGION '(POINTER POINTER POINTER POINTER POINTER POINTER) '((IREGION 0 POINTER) (IREGION 2 POINTER) (IREGION 4 POINTER) (IREGION 6 POINTER) (IREGION 8 POINTER) (IREGION 10 POINTER)) '12) (PUTPROPS IREGIONPROP ARGNAMES (NIL (IREGION PROP {NEWVALUE}) . U)) (RPAQQ DEFAULT.IREGION.SHADE 65535) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULT.IREGION.SHADE) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA IREGIONPROP) ) (PUTPROPS AIREGIONS COPYRIGHT ("XEROX Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1346 25783 (ADD.IREGION 1356 . 1755) (ALL.IREGIONS 1757 . 2056) (CREATEIR 2058 . 9584) (REMOVE.IREGION 9586 . 9944) (DOSELECTED.IREGION 9946 . 10291) (EDIT.MASK 10293 . 10586) (IREGIONP 10588 . 10913) (IREGIONPROP 10915 . 15583) (SHOW.ALL.IREGIONS 15585 . 16587) (INTERSECTING.IREGIONS? 16589 . 16998) (INVERT.IREGION 17000 . 17666) (WHICH.IREGIONS 17668 . 19254) (SURROUNDIR 19256 . 25781 )) (25784 35336 (IN.CURSOR.REGION 25794 . 30072) (\IR.CLIP.REGION 30074 . 32280) (\IR.SHOW.REGION 32282 . 33233) (\VALID.POSITION.LIST 33235 . 34254) (\SAME.IREGIONS.LIST 34256 . 34630) ( \WITH.INTERSECTION 34632 . 35031) (\IREGION.ON.WINDOWP 35033 . 35334))))) STOP \ No newline at end of file diff --git a/lispusers/AIREGIONS-DEMO b/lispusers/AIREGIONS-DEMO new file mode 100644 index 00000000..748e1234 --- /dev/null +++ b/lispusers/AIREGIONS-DEMO @@ -0,0 +1 @@ +(FILECREATED "24-Jun-85 08:59:13" {DANTE}LISP>AIREGIONS-DEMO.;3 97308 changes to: (VARS AIREGIONS-DEMOCOMS \AIR.DEMO.BM \ALL.AIR.IREGIONS) (FNS AIREGIONS.CIRCLES.DEMO SETUP.AIREGION.DEMO IREGION.DEMOFN) previous date: "23-Jun-85 18:27:53" {DANTE}LISP>AIREGIONS-DEMO.;2) (* Copyright (c) 1985 by XEROX Corporation. All rights reserved.) (PRETTYCOMPRINT AIREGIONS-DEMOCOMS) (RPAQQ AIREGIONS-DEMOCOMS ((FILES AIREGIONS) (UGLYVARS \ALL.AIR.IREGIONS) (VARS \AIR.DEMO.BM) (FNS AIREGIONS.CIRCLES.DEMO IREGION.DEMOFN SETUP.AIREGION.DEMO) (P (SETUP.AIREGION.DEMO) (AIREGIONS.CIRCLES.DEMO)))) (FILESLOAD AIREGIONS) (READVARS \ALL.AIR.IREGIONS) (({$IREGION (POINTER POINTER POINTER POINTER POINTER POINTER)IREGION.DEMOFN (NAME "Delaware") (383 151 21 24) {(READBITMAP)(21 24 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@D@@@@@@" "@D@@@@@@" "@D@@@@@@" "@F@@@@@@" "@F@@@@@@" "@G@@@@@@" "@GH@@@@@" "@G@@@@@@" "@GH@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@")} 36181 NIL } {$IREGION IREGION.DEMOFN (NAME "Rhode Island") (417 181 15 18) {(READBITMAP)(15 18 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "L@@@" "L@@@" "N@@@" "O@@@" "H@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")} 25343 NIL } {$IREGION IREGION.DEMOFN (NAME "Connecticut") (398 179 25 23) {(READBITMAP)(25 23 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@COOL@@@" "@COOL@@@" "@COOL@@@" "@COOL@@@" "@COOL@@@" "@COOH@@@" "@CL@@@@@" "@B@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@")} 63153 NIL } {$IREGION IREGION.DEMOFN (NAME "Massachusetts") (402 185 35 20) {(READBITMAP)(35 20 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@OOOOH@@@@@@" "AOOOO@@@@@@@" "AOOOO@@@@@@@" "AOOOO@@@@@@@" "AOOOOL@@@@@@" "COOOOL@@@@@@" "@@@@GN@@@@@@" "@@@@CN@@@@@@" "@@@@CN@@@@@@" "@@@@AOL@@@@@" "@@@@@N@@@@@@" "@@@@@B@@@@@@" "@@@@@@@@@@@@")} 48938 NIL } {$IREGION IREGION.DEMOFN (NAME "Maine") (415 200 41 60) {(READBITMAP)(41 60 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@I@@@@@@" "@@@@AOO@@@@@" "@@@@COOH@@@@" "@@@@GOOL@@@@" "@@@@OOOL@@@@" "@@@@OOON@@@@" "@@@AOOON@@@@" "@@@AOOON@@@@" "@@@AOOON@@@@" "@@@COOON@@@@" "@@@GOOON@@@@" "@@@GOOOL@@@@" "@@@GOOOL@@@@" "@@@GOOOL@@@@" "@@@GOOOL@@@@" "@@@OOOOL@@@@" "@@@OOOON@@@@" "@@COOOOO@@@@" "@@COOOOO@@@@" "@@COOOOOH@@@" "@@OOOOOOH@@@" "@AOOOOOOH@@@" "@AOOOOOON@@@" "@AOOOOOON@@@" "@AOOOOOON@@@" "@AOOOOOON@@@" "@AOOOOOO@@@@" "@AOOOOOL@@@@" "@AOOOOL@@@@@" "@AOOOL@@@@@@" "@AOOOH@@@@@@" "@@OOOH@@@@@@" "@@OON@@@@@@@" "@@OOL@@@@@@@" "@@ON@@@@@@@@" "@@O@@@@@@@@@" "@@O@@@@@@@@@" "@@N@@@@@@@@@" "@@N@@@@@@@@@" "@@L@@@@@@@@@" "@@L@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 21942 NIL } {$IREGION IREGION.DEMOFN (NAME "New Hampshire") (410 195 21 34) {(READBITMAP)(21 34 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@F@@@@@" "@@F@@@@@" "@@N@@@@@" "@@N@@@@@" "@@N@@@@@" "@@N@@@@@" "@CN@@@@@" "@GN@@@@@" "@GO@@@@@" "@OO@@@@@" "@OO@@@@@" "@OO@@@@@" "AOO@@@@@" "AOO@@@@@" "COO@@@@@" "COO@@@@@" "COO@@@@@" "COO@@@@@" "COOH@@@@" "GOOL@@@@" "GOOH@@@@" "GOOH@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@")} 30297 NIL } {$IREGION IREGION.DEMOFN (NAME "Vermont") (400 199 25 33) {(READBITMAP)(25 33 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@GL@@@" "@GOOL@@@" "@GOOH@@@" "@GOOH@@@" "@GOOH@@@" "@GOO@@@@" "@GON@@@@" "@GOL@@@@" "@GOL@@@@" "@GOH@@@@" "@GOH@@@@" "@GOH@@@@" "@GO@@@@@" "@GO@@@@@" "@CN@@@@@" "@CN@@@@@" "@CN@@@@@" "@CN@@@@@" "@CN@@@@@" "@CL@@@@@" "@CL@@@@@" "@CL@@@@@")} 61806 NIL } {$IREGION IREGION.DEMOFN (NAME "New York") (356 179 58 57) {(READBITMAP)(58 57 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@OOO@@@@" "@@@@@@@@COOO@@@@" "@@@@@@@@COOO@@@@" "@@@@@@@@OOOO@@@@" "@@@@@@@AOOOO@@@@" "@@@@@@@AOOOO@@@@" "@@@@@@@COOOO@@@@" "@@@@@@@COOOO@@@@" "@@@@@@@GOOOO@@@@" "@@@@@@@GOOOO@@@@" "@@@@@@@OOOOO@@@@" "@@@@@@@OOOOO@@@@" "@@@@@@@OOOOO@@@@" "@@@@@@AOOOOO@@@@" "@@@@@@COOOOOH@@@" "@@CL@@GOOOOOH@@@" "@AOOOOOOOOOOH@@@" "@AOOOOOOOOOOH@@@" "@@OOOOOOOOOOH@@@" "@@GOOOOOOOOOH@@@" "@@GOOOOOOOOOH@@@" "@@OOOOOOOOOOH@@@" "@AOOOOOOOOOOH@@@" "@COOOOOOOOOO@@@@" "@GOOOOOOOOOO@@@@" "AOOOOOOOOOOO@@@@" "COOOOOOOOOOO@@@@" "COOOOOOOOOON@@@@" "@@@@@@@@COON@@@@" "@@@@@@@@AOON@@@@" "@@@@@@@@@OON@@@@" "@@@@@@@@@GON@@@@" "@@@@@@@@@GON@@@@" "@@@@@@@@@CON@@@@" "@@@@@@@@@AON@@@@" "@@@@@@@@@@GN@@@@" "@@@@@@@@@@CL@@@@" "@@@@@@@@@@@D@@@@" "@@@@@@@@@@@D@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 41374 NIL } {$IREGION IREGION.DEMOFN (NAME "Maryland") (358 150 45 31) {(READBITMAP)(45 31 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "COOOOOOH@@@@" "CHCOOOOH@@@@" "C@AOOOOH@@@@" "B@@OOOKH@@@@" "@@@@GOCH@@@@" "@@@@GOCH@@@@" "@@@@COCH@@@@" "@@@@@OCH@@@@" "@@@@@FCH@@@@" "@@@@@NCH@@@@" "@@@@@LCH@@@@" "@@@@ALAH@@@@" "@@@@@NAL@@@@" "@@@@@NAOH@@@" "@@@@@BAOH@@@" "@@@@@@@O@@@@" "@@@@@@@H@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 16880 NIL } {$IREGION IREGION.DEMOFN (NAME "New Jersey") (383 162 25 37) {(READBITMAP)(25 37 "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@AL@@@@" "@@CN@@@@" "@@GOH@@@" "@@COH@@@" "@@GOH@@@" "@@GOH@@@" "@@GOH@@@" "@@COH@@@" "@@AOH@@@" "@@AOH@@@" "@@@OH@@@" "@@AO@@@@" "@@CO@@@@" "@@GO@@@@" "@AOO@@@@" "@AON@@@@" "@COL@@@@" "@AOL@@@@" "@@O@@@@@" "@@G@@@@@" "@@C@@@@@" "@@@@@@@@")} 44104 NIL } {$IREGION IREGION.DEMOFN (NAME "Pennsylvania") (340 167 63 37) {(READBITMAP)(63 37 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@H@@@@@@@@@@@" "@@@CH@@@@@@@@@@@" "@@@GOOOOOOOOL@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOOH@@" "@@@GOOOOOOOOOL@@" "@@@GOOOOOOOOOL@@" "@@@GOOOOOOOOOH@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOOOH@@" "@@@GOOOOOOOOOH@@" "@@@GOOOOOOOOOL@@" "@@@GOOOOOOOOO@@@" "@@@GOOOOOOOON@@@" "@@@GOOOOOOOO@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 24883 NIL } {$IREGION IREGION.DEMOFN (NAME "Florida") (289 19 88 76) {(READBITMAP)(88 76 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@OOOOL@@@@@@@@@@@@@@@@" "@@@OOOON@@@@@D@@@@@@@@@@" "@@@GOOON@@@@@G@@@@@@@@@@" "@@@GOOOOOOOL@G@@@@@@@@@@" "@@@EOOOOOOOOLG@@@@@@@@@@" "@@@@@COOOOOONO@@@@@@@@@@" "@@@@@@OOOOOOOO@@@@@@@@@@" "@@@@@@COOOOOOOH@@@@@@@@@" "@@@@@@AONAOOOOH@@@@@@@@@" "@@@@@@@OH@OOOOH@@@@@@@@@" "@@@@@@@O@@GOOOH@@@@@@@@@" "@@@@@@@H@@COOOL@@@@@@@@@" "@@@@@@@@@@AOOOL@@@@@@@@@" "@@@@@@@@@@AOOOL@@@@@@@@@" "@@@@@@@@@@@OOON@@@@@@@@@" "@@@@@@@@@@@OOON@@@@@@@@@" "@@@@@@@@@@@GOON@@@@@@@@@" "@@@@@@@@@@@AOOO@@@@@@@@@" "@@@@@@@@@@@@OOO@@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@@OOOH@@@@@@@@" "@@@@@@@@@@@AOOOL@@@@@@@@" "@@@@@@@@@@@AOOOL@@@@@@@@" "@@@@@@@@@@@@OOON@@@@@@@@" "@@@@@@@@@@@@COON@@@@@@@@" "@@@@@@@@@@@@COON@@@@@@@@" "@@@@@@@@@@@@GOON@@@@@@@@" "@@@@@@@@@@@@GOOO@@@@@@@@" "@@@@@@@@@@@@OOOO@@@@@@@@" "@@@@@@@@@@@@OOOOH@@@@@@@" "@@@@@@@@@@@@GOOOH@@@@@@@" "@@@@@@@@@@@@GOOCH@@@@@@@" "@@@@@@@@@@@@COOAL@@@@@@@" "@@@@@@@@@@@@@GNAL@@@@@@@" "@@@@@@@@@@@@@GNAL@@@@@@@" "@@@@@@@@@@@@@GOAL@@@@@@@" "@@@@@@@@@@@@@COKL@@@@@@@" "@@@@@@@@@@@@@COOL@@@@@@@" "@@@@@@@@@@@@@COOL@@@@@@@" "@@@@@@@@@@@@@COOL@@@@@@@" "@@@@@@@@@@@@@COOL@@@@@@@" "@@@@@@@@@@@@@AOOL@@@@@@@" "@@@@@@@@@@@@@AOOL@@@@@@@" "@@@@@@@@@@@@@AOOL@@@@@@@" "@@@@@@@@@@@@@@COL@@@@@@@" "@@@@@@@@@@@@@@COH@@@@@@@" "@@@@@@@@@@@@@@CO@@@@@@@@" "@@@@@@@@@@@@@@AO@@@@@@@@" "@@@@@@@@@@@@@@AO@@@@@@@@" "@@@@@@@@@@@@@@@O@@@@@@@@" "@@@@@@@@@@@@@@@N@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@")} 3049 NIL } {$IREGION IREGION.DEMOFN (NAME "South Carolina") (330 88 48 51) {(READBITMAP)(48 51 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@GOOL@@@@@@@" "@OOOO@@@@@@@" "AOOOO@@@@@@@" "COOOOOO@@@@@" "AOOOOOOL@@@@" "@OOOOOOL@@@@" "@GOOOOON@@@@" "@COOOOOO@@@@" "@COOOOOOH@@@" "@AOOOOOOL@@@" "@@OOOOOON@@@" "@@GOOOOOO@@@" "@@COOOOON@@@" "@@COOOOOL@@@" "@@AOOOOO@@@@" "@@@OOOOO@@@@" "@@@GOOON@@@@" "@@@GOOON@@@@" "@@@GOOON@@@@" "@@@COOOL@@@@" "@@@AOOO@@@@@" "@@@@OOO@@@@@" "@@@@OOL@@@@@" "@@@@OOL@@@@@" "@@@@GO@@@@@@" "@@@@CN@@@@@@" "@@@@CL@@@@@@" "@@@@CL@@@@@@" "@@@@CH@@@@@@" "@@@@A@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 9930 NIL } {$IREGION IREGION.DEMOFN (NAME "North Carolina") (328 112 66 38) {(READBITMAP)(66 38 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@OOOOOOOOOOH@@@@@" "@@@@OOOOOOOOOOH@@@@@" "@@@COOOOOOOOOO@@@@@@" "@@@COOOOOOOOOM@@@@@@" "@@AOOOOOOOOOOH@@@@@@" "@@COOOOOOOOOOH@@@@@@" "@AOOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@OOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOOH@@@@@" "OOOOOOOOOOOOLAH@@@@@" "OOOOOOOOOOOON@@@@@@@" "OOOOOOOOOOOOOH@@@@@@" "ON@@@OOOOOOOK@@@@@@@" "OH@@@COOOOOOL@@@@@@@" "@@@@@AOOOOOOND@@@@@@" "@@@@@@@COOOOOL@@@@@@" "@@@@@@@@OOOLL@@@@@@@" "@@@@@@@@GOON@@@@@@@@" "@@@@@@@@GOOL@@@@@@@@" "@@@@@@@@COOH@@@@@@@@" "@@@@@@@@AOO@@@@@@@@@" "@@@@@@@@@OO@@@@@@@@@" "@@@@@@@@@GN@@@@@@@@@" "@@@@@@@@@CN@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 1855 NIL } {$IREGION IREGION.DEMOFN (NAME "Virginia") (331 134 66 36) {(READBITMAP)(66 36 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@B@@@@@@@@@@" "@@@@@@@@@GN@@@@@@@@@" "@@@@@@@@@OO@@@@@@@@@" "@@@@@@@@@OOH@@@@@@@@" "@@@@@@@@COOL@@@@@@@@" "@@@@@@@@OOOL@@@@@@@@" "@@@@@@@@OOOH@@@@@@@@" "@@@@@@@AOOOH@@@@@@@@" "@@@@@@@COOOL@@@@@@@@" "@@@@@@AOOOOL@@@@@@@@" "@@@@@@AOOOON@@@@@@@@" "@@@@@@COOOOH@@@@@@@@" "@@@@@@COOOOH@@@@@@@@" "@@@@@@GOOOOL@@@@@@@@" "@@@@@@OOOOOOH@@@@@@@" "@@@@@AOOOOOOL@@@@@@@" "@@@@@AOOOOOON@@@@@@@" "@@@@@AOOOOOOH@@@@@@@" "@@B@@COOOOOOH@@@@@@@" "@@O@COOOOOOOL@@@@@@@" "@AOIOOOOOOOOO@@@@@@@" "@COOOOOOOOOOOL@@@@@@" "@GOOOOOOOOOON@@@@@@@" "@GOOOOOOOOOON@@@@@@@" "OOOOOOOOOOOOO@@@@@@@" "OOOOOOOOOOOOOH@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 39005 NIL } {$IREGION IREGION.DEMOFN (NAME "West Virginia") (334 144 43 41) {(READBITMAP)(43 41 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@D@@@@@@@" "@@@@D@@@@@@@" "@@@@D@@@@@@@" "@@@@D@@@@@@@" "@@@@OOH@@@@@" "@@@AOOH@@@@@" "@@@AOOHGL@@@" "@@@COOHOL@@@" "@@AOOOIOL@@@" "@@COOOOOH@@@" "@@GOOOOO@@@@" "@@COOOON@@@@" "@@OOOOOH@@@@" "@AOOOOO@@@@@" "@AOOOOO@@@@@" "@COOOOJ@@@@@" "@GOOOO@@@@@@" "@OOOON@@@@@@" "@OOOON@@@@@@" "AOOOOL@@@@@@" "@OOOOL@@@@@@" "@GOOOH@@@@@@" "@GOOO@@@@@@@" "@COON@@@@@@@" "@AOON@@@@@@@" "@@OON@@@@@@@" "@@GN@@@@@@@@" "@@C@@@@@@@@@" "@@@@@@@@@@@@")} 24190 NIL } {$IREGION IREGION.DEMOFN (NAME "Georgia") (311 70 44 66) {(READBITMAP)(44 66 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@GOOO@@@@@@@" "@GOOO@@@@@@@" "@GOOO@@@@@@@" "@GOOOL@@@@@@" "@GOOOL@@@@@@" "@GOOON@@@@@@" "@COOOO@@@@@@" "@COOOOH@@@@@" "@COOOOL@@@@@" "@COOOOL@@@@@" "@COOOON@@@@@" "@COOOOO@@@@@" "@AOOOOO@@@@@" "@AOOOOOL@@@@" "@AOOOOON@@@@" "@AOOOOON@@@@" "@AOOOOON@@@@" "@AOOOOOO@@@@" "@@OOOOOOH@@@" "@@OOOOOOL@@@" "@@OOOOOOL@@@" "@@OOOOOOL@@@" "@@OOOOOON@@@" "@@GOOOOOO@@@" "@@GOOOOOO@@@" "@@GOOOOOO@@@" "@@GOOOOOO@@@" "@@OOOOOOOH@@" "@@GOOOOOOL@@" "@@OOOOOOOL@@" "@@OOOOOON@@@" "@@OOOOOOO@@@" "@@OOOOOOO@@@" "@@OOOOOON@@@" "@@OOOOOOL@@@" "@@OOOOOON@@@" "@@OOOOOON@@@" "@@GOOOOOL@@@" "@@GOOOOOL@@@" "@@AOOOONL@@@" "@@COOOOL@@@@" "@@@@@@OL@@@@" "@@@@@@@L@@@@" "@@@@@@@D@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 6013 NIL } {$IREGION IREGION.DEMOFN NIL (338 140 39 38) {(READBITMAP)(39 38 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 52911 NIL } {$IREGION IREGION.DEMOFN (NAME "Ohio") (315 157 47 44) {(READBITMAP)(47 44 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@H@@" "@@@@@@@@CH@@" "@@@@@@@@OH@@" "@COOH@@AOH@@" "@COON@@OOH@@" "@COONNGOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOOH@@" "@COOOOOOO@@@" "@COOOOOOO@@@" "@COOOOOON@@@" "@COOOOOON@@@" "@COOOOOON@@@" "@COOOOOON@@@" "@COOOOOOL@@@" "@COOOOOOH@@@" "@COOOOOOH@@@" "@COOOOOL@@@@" "@COOOOO@@@@@" "@COOOOO@@@@@" "@@COOOL@@@@@" "@@COOOH@@@@@" "@@@GOOH@@@@@" "@@@CMOH@@@@@" "@@@@@GH@@@@@" "@@@@@C@@@@@@")} 3846 NIL } {$IREGION IREGION.DEMOFN (NAME "Alabama") (292 72 40 61) {(READBITMAP)(40 61 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@GOOON@@@@@@" "@GOOON@@@@@@" "@GOOON@@@@@@" "@GOOON@@@@@@" "@GOOON@@@@@@" "@GOOON@@@@@@" "@GOOON@@@@@@" "@GOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOOH@@@@@" "@OOOOOH@@@@@" "@OOOOOH@@@@@" "@OOOOOH@@@@@" "@OOOOOH@@@@@" "@OOOOOH@@@@@" "AOOOOOH@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOON@@@@@" "AOOOOON@@@@@" "AOOOOON@@@@@" "AOOOOON@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "COOOOOL@@@@@" "COOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOOL@@@@@" "AOOOOON@@@@@" "AO@@@@@@@@@@" "AO@@@@@@@@@@" "AO@@@@@@@@@@" "AOH@@@@@@@@@" "AOH@@@@@@@@@" "AOH@@@@@@@@@" "@E@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 4772 NIL } {$IREGION IREGION.DEMOFN (NAME "Mississippi") (266 74 41 59) {(READBITMAP)(41 59 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@AOOOL@@@@" "@@@COOOL@@@@" "@@@GOOOL@@@@" "@@@GOOOL@@@@" "@@@GOOOL@@@@" "@@@GOOOL@@@@" "@@AOOOOL@@@@" "@@AOOOOL@@@@" "@@COOOOH@@@@" "@@COOOOH@@@@" "@@COOOOH@@@@" "@@COOOOH@@@@" "@@GOOOOH@@@@" "@@GOOOOH@@@@" "@@GOOOOH@@@@" "@@GOOOOH@@@@" "@@GOOOOH@@@@" "@@GOOOOH@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@COOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@GOOOO@@@@@" "@@OOOON@@@@@" "@AOOOON@@@@@" "@AOOOOO@@@@@" "@COOOOO@@@@@" "@COOOOO@@@@@" "@COOOOO@@@@@" "@COOOOO@@@@@" "@GOOOOO@@@@@" "@GOOOOO@@@@@" "@@@@AOO@@@@@" "@@@@AOO@@@@@" "@@@@AOO@@@@@" "@@@@AOO@@@@@" "@@@@AOO@@@@@" "@@@@AOC@@@@@" "@@@@@L@@@@@@" "@@@@@H@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 19282 NIL } {$IREGION IREGION.DEMOFN (NAME "Tennessee") (281 118 71 31) {(READBITMAP)(71 31 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@GOOO@@@@@@@@@@@@" "@@@@OOOOOOOOOOOL@@@@" "@COOOOOOOOOOOOOH@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOL@@@@@" "@GOOOOOOOOOOOOH@@@@@" "@OOOOOOOOOOOOL@@@@@@" "@OOOOOOOOOOOOH@@@@@@" "@OOOOOOOOOOON@@@@@@@" "AOOOOOOOOOOOL@@@@@@@" "AOOOOOOOOOON@@@@@@@@" "COOOOOOOOOOL@@@@@@@@" "COOOOOOOOOOH@@@@@@@@" "COOOOOOOOOO@@@@@@@@@" "COOOOOOOOON@@@@@@@@@" "GOOOOOOOOON@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 50710 NIL } {$IREGION IREGION.DEMOFN (NAME "Kentucky") (287 136 62 30) {(READBITMAP)(62 30 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@CH@@@@@@" "@@@@@@@@CL@@@@@@" "@@@@@@@@GOH@@@@@" "@@@@@@@COOL@@@@@" "@@@@@@@GOOOO@@@@" "@@@@@@@OOOOOH@@@" "@@@@@@@OOOOOL@@@" "@@@@@@COOOOOL@@@" "@@@@@@COOOOOH@@@" "@@@@@BGOOOOOL@@@" "@@@@@COOOOOON@@@" "@@AOGGOOOOOON@@@" "@@COOOOOOOOOO@@@" "@@COOOOOOOOOOH@@" "@@GOOOOOOOOOOL@@" "@@OOOOOOOOOOO@@@" "@AOOOOOOOOOON@@@" "@COOOOOOOOOOL@@@" "COOOOOOOOOOO@@@@" "AOOOOOOOOOON@@@@" "AOOOOOOOOOO@@@@@" "AOOOOOOOOON@@@@@" "COL@@@COOOL@@@@@" "GOH@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 24831 NIL } {$IREGION IREGION.DEMOFN (NAME "Indiana") (296 146 33 55) {(READBITMAP)(33 55 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@GOOO@@@@@@" "@DOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOOO@@@@@@" "@GOOO@@@@@@@" "@GOOO@@@@@@@" "@GOON@@@@@@@" "@OOOL@@@@@@@" "AOOOH@@@@@@@" "COOO@@@@@@@@" "COOC@@@@@@@@" "COO@@@@@@@@@" "@AA@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 56068 NIL } {$IREGION IREGION.DEMOFN (NAME "Illinois") (266 140 45 69) {(READBITMAP)(45 69 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@COOOO@@@@" "@@@COOOO@@@@" "@@@AOOOO@@@@" "@@@@OOOOH@@@" "@@@@OOOOH@@@" "@@@@OOOOL@@@" "@@@@OOOOL@@@" "@@@AOOOOL@@@" "@@@AOOOOL@@@" "@@@COOOOL@@@" "@@AOOOOOL@@@" "@@COOOOOL@@@" "@@GOOOOOL@@@" "@@COOOOOL@@@" "@@COOOOOL@@@" "@@COOOOOL@@@" "@@GOOOOOL@@@" "@@GOOOOOL@@@" "@AOOOOOOL@@@" "@AOOOOOOL@@@" "@AOOOOOOL@@@" "@COOOOOOL@@@" "@COOOOOOL@@@" "@COOOOOOL@@@" "@AOOOOOOL@@@" "@AOOOOOOL@@@" "@AOOOOOOL@@@" "@@OOOOOOL@@@" "@@GOOOOOL@@@" "@@COOOOOL@@@" "@@AOOOOOL@@@" "@@@OOOOOL@@@" "@@@GOOOOL@@@" "@@@GOOOOL@@@" "@@@COOOOL@@@" "@@@@OOOOL@@@" "@@@@OOOOL@@@" "@@@@OOOOL@@@" "@@@@OOOOL@@@" "@@@AOOOOH@@@" "@@@AOOOO@@@@" "@@@AOOON@@@@" "@@@@OOON@@@@" "@@@@OOON@@@@" "@@@@AOON@@@@" "@@@@@OON@@@@" "@@@@@OOL@@@@" "@@@@@GOL@@@@" "@@@@@GOH@@@@" "@@@@@GO@@@@@" "@@@@@GN@@@@@" "@@@@@F@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 62612 NIL } {$IREGION IREGION.DEMOFN (NAME "Michigan") (279 183 68 68) {(READBITMAP)(68 68 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@D@@@@@@@@@@@@@@@@" "@@@N@@@@@@@@@@@@@@@@" "@@GO@@@@@@@@@@@@@@@@" "@@OOOH@@@@@@@@@@@@@@" "@GOOOH@@@C@@@@@@@@@@" "COOOOL@AOO@@@@@@@@@@" "AOOOON@COO@@@@@@@@@@" "AOOOOOOOOOOH@@@@@@@@" "@COOOOOOOOON@@@@@@@@" "@@AOOOOOOOOOH@@@@@@@" "@@@OOOOOOHON@@@@@@@@" "@@@@OOON@@D@@@@@@@@@" "@@@@COKL@@@@@@@@@@@@" "@@@@@OH@@@@@@@@@@@@@" "@@@@@O@@@@F@@@@@@@@@" "@@@@@N@@@@GL@@@@@@@@" "@@@@@N@@@@GN@@@@@@@@" "@@@@@L@@@@OOH@@@@@@@" "@@@@@@@@@COOO@@@@@@@" "@@@@@@@@@COOO@@@@@@@" "@@@@@@@@@GOOO@@@@@@@" "@@@@@@@@COOOO@@@@@@@" "@@@@@@@@GOOOO@@@@@@@" "@@@@@@@@GOOOO@@@@@@@" "@@@@@@@@OOOOO@@@@@@@" "@@@@@@@@OOOOO@@@@@@@" "@@@@@@@@OOOOO@@@@@@@" "@@@@@@@@OOOOO@@@@@@@" "@@@@@@@AOOOON@@@@@@@" "@@@@@@@COOOON@@@@@@@" "@@@@@@@COOOOH@@@@@@@" "@@@@@@@COOOO@CH@@@@@" "@@@@@@@COOOO@GH@@@@@" "@@@@@@@COOOO@OH@@@@@" "@@@@@@@COOOOAOH@@@@@" "@@@@@@@COOOOOOL@@@@@" "@@@@@@@COOOOOOL@@@@@" "@@@@@@@AOOOOOOL@@@@@" "@@@@@@@AOOOOOOL@@@@@" "@@@@@@@AOOOOOOL@@@@@" "@@@@@@@@OOOOOON@@@@@" "@@@@@@@@OOOOOON@@@@@" "@@@@@@@@OOOOOON@@@@@" "@@@@@@@@OOOOOOL@@@@@" "@@@@@@@@OOOOOO@@@@@@" "@@@@@@@@OOOOON@@@@@@" "@@@@@@@@OOOOON@@@@@@" "@@@@@@@AOOOOOL@@@@@@" "@@@@@@@COOOOOH@@@@@@" "@@@@@@@COOOOOH@@@@@@" "@@@@@@@GOOOOOH@@@@@@" "@@@@@@@GOOOOO@@@@@@@" "@@@@@@@@@@CON@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 35489 NIL } {$IREGION IREGION.DEMOFN (NAME "Wisconsin") (256 192 57 53) {(READBITMAP)(57 53 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@GH@@@@@@@@@@" "@@@AO@@@@@@@@@@@" "@@COO@@@@@@@@@@@" "@@COOO@@@@@@@@@@" "@@COOOH@@@@@@@@@" "@@COOOL@@@@@@@@@" "@@COOOOH@@@@@@@@" "@@COOOOOL@@@@@@@" "@@GOOOOON@@@@@@@" "@@OOOOOOON@@@@@@" "@AOOOOOOOO@@@@@@" "@AOOOOOOOOL@@@@@" "@AOOOOOOOOL@@@@@" "@@OOOOOOOOL@@@@@" "@@OOOOOOOOL@@@@@" "@AOOOOOOOON@@@@@" "@AOOOOOOOON@@@@@" "@AOOOOOOOOO@@@@@" "@AOOOOOOOOL@@@@@" "@AOOOOOOOOL@@@@@" "@AOOOOOOOOLL@@@@" "@@OOOOOOOOHL@@@@" "@@COOOOOOOOH@@@@" "@@@OOOOOOOOH@@@@" "@@@GOOOOOOO@@@@@" "@@@COOOOOOO@@@@@" "@@@COOOOOOO@@@@@" "@@@AOOOOOON@@@@@" "@@@@COOOOON@@@@@" "@@@@COOOOON@@@@@" "@@@@COOOOON@@@@@" "@@@@COOOOON@@@@@" "@@@@COOOOOL@@@@@" "@@@@COOOOOL@@@@@" "@@@@AOOOOOL@@@@@" "@@@@AOOOOOL@@@@@" "@@@@AOOOOOL@@@@@" "@@@@AOOOOOL@@@@@" "@@@@AOOOOOL@@@@@" "@@@@AOOOOOL@@@@@" "@@@@@GOOOOL@@@@@" "@@@@@COOOOL@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 57326 NIL } {$IREGION IREGION.DEMOFN (NAME "Louisiana") (250 63 47 51) {(READBITMAP)(47 51 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOOH@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOOO@@@@@@" "@OOOON@@@@@@" "@GOOOL@@@@@@" "@COOOL@@@@@@" "@AOOOH@@@@@@" "@AOOOH@@@@@@" "@AOOOH@@@@@@" "@AOOOH@@@@@@" "@AOOO@@@@@@@" "@AOOO@@@@@@@" "@AOOO@@@@@@@" "@AOOOOOOL@@@" "@AOOOOOOL@@@" "@COOOOOOL@@@" "@COOOOOOL@@@" "@COOOOOOL@@@" "@COOOOOLF@@@" "@COOOOOH@@@@" "@COOOOOL@@@@" "@COOOOOL@@@@" "@GOOOOOH@@@@" "@GOOLOOO@@@@" "@@AOHGOOH@@@" "@@@GHGOOH@@@" "@@@@@@ON@@@@" "@@@@@@OO@@@@" "@@@@@@GK@@@@" "@@@@@@GA@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 57715 NIL } {$IREGION IREGION.DEMOFN (NAME "Arkansas") (246 96 46 52) {(READBITMAP)(46 52 "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@OOOOOOOO@@@" "@OOOOOOON@@@" "@OOOOOOON@@@" "@OOOOOOOL@@@" "@OOOOOOON@@@" "@OOOOOOOOL@@" "@OOOOOOOOH@@" "@GOOOOOOOH@@" "@GOOOOOOOH@@" "@GOOOOOON@@@" "@GOOOOOON@@@" "@GOOOOOON@@@" "@GOOOOOON@@@" "@GOOOOOOL@@@" "@GOOOOOOL@@@" "@GOOOOOOH@@@" "@GOOOOOO@@@@" "@GOOOOOO@@@@" "@GOOOOOO@@@@" "@GOOOOOO@@@@" "@GOOOOOL@@@@" "@GOOOOOH@@@@" "@GOOOOOH@@@@" "@GOOOOOH@@@@" "@OOOOOOH@@@@" "@OOOOOO@@@@@" "@OOOOOO@@@@@" "@AOOOOO@@@@@" "@@OOOOO@@@@@" "@@OOOOO@@@@@" "@@OOOOO@@@@@" "@@OOOOO@@@@@" "@@OOOOO@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@" "@@@@@@@@@@@@")} 54342 NIL } {$IREGION IREGION.DEMOFN (NAME "Missouri") (238 131 60 55) {(READBITMAP)(60 55 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@" "@OOOOOOOH@@@@@@@" "@OOOOOOOL@@@@@@@" "@OOOOOOOH@@@@@@@" "@GOOOOOOH@@@@@@@" "@COOOOOOH@@@@@@@" "@COOOOOOL@@@@@@@" "@@OOOOOOL@@@@@@@" "@@GOOOOOL@@@@@@@" "@@OOOOOON@@@@@@@" "@@OOOOOOO@@@@@@@" "@@GOOOOOOH@@@@@@" "@@GOOOOOOL@@@@@@" "@@COOOOOON@@@@@@" "@@AOOOOOOO@@@@@@" "@@AOOOOOOO@@@@@@" "@@AOOOOOOOH@@@@@" "@@AOOOOOOOL@@@@@" "@@AOOOOOOON@@@@@" "@@AOOOOOOON@@@@@" "@@AOOOOOOON@@@@@" "@@AOOOOOOOL@@@@@" "@@AOOOOOOOL@@@@@" "@@AOOOOOOOL@@@@@" "@@AOOOOOOON@@@@@" "@@AOOOOOOON@@@@@" "@@AOOOOOOOO@@@@@" "@@AOOOOOOOOL@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOOO@@@@" "@@AOOOOOOOOO@@@@" "@@AOOOOOOOOO@@@@" "@@AOOOOOOOOO@@@@" "@@AOOOOOOOOO@@@@" "@@AOOOOOOOOOH@@@" "@@AOOOOOOOOOL@@@" "@@AOOOOOOOOON@@@" "@@AOOOOOOOOON@@@" "@@AOOOOOOOOOL@@@" "@@AOOOOOOOOOH@@@" "@@@@@@@@@@@N@@@@" "@@@@@@@@@@@G@@@@" "@@@@@@@@@@@N@@@@" "@@@@@@@@@@@N@@@@" "@@@@@@@@@@AN@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 23596 NIL } {$IREGION IREGION.DEMOFN (NAME "Iowa") (229 173 65 41) {(READBITMAP)(65 41 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@COOOOOOOOO@@@@@@@@@" "@COOOOOOOOO@@@@@@@@@" "@COOOOOOOOOH@@@@@@@@" "@AOOOOOOOOOH@@@@@@@@" "@AOOOOOOOOOH@@@@@@@@" "@COOOOOOOOOH@@@@@@@@" "@COOOOOOOOOH@@@@@@@@" "@COOOOOOOOOL@@@@@@@@" "@COOOOOOOOOO@@@@@@@@" "@AOOOOOOOOOOH@@@@@@@" "@AOOOOOOOOOOL@@@@@@@" "@@OOOOOOOOOOL@@@@@@@" "@@OOOOOOOOOON@@@@@@@" "@@OOOOOOOOOOO@@@@@@@" "@@GOOOOOOOOOO@@@@@@@" "@@GOOOOOOOOOO@@@@@@@" "@@COOOOOOOOOO@@@@@@@" "@@COOOOOOOOON@@@@@@@" "@@COOOOOOOOON@@@@@@@" "@@AOOOOOOOOO@@@@@@@@" "@@AOOOOOOOOL@@@@@@@@" "@@AOOOOOOOOL@@@@@@@@" "@@AOOOOOOOOH@@@@@@@@" "@@AOOOOOOOOL@@@@@@@@" "@@@OOOOOOOOL@@@@@@@@" "@@@OOOOOOOOL@@@@@@@@" "@@AOOOOOOOOH@@@@@@@@" "@@@OOOOOOOC@@@@@@@@@" "@@@@@@@@@@B@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 22243 NIL } {$IREGION IREGION.DEMOFN (NAME "Minnesota") (224 205 68 67) {(READBITMAP)(68 67 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@AOOON@@@@@@@@@@@@@@" "@AOOOOH@@@@@@@@@@@@@" "@AOOOOO@@@@@@@@@@@@@" "@AOOOOONC@@@@@@@@@@@" "@AOOOOOOO@@@@@@@@@@@" "@AOOOOOOOO@@@@@@@@@@" "@AOOOOOOOOK@@@@@@@@@" "@AOOOOOOOOOHA@@@@@@@" "@@OOOOOOOOONGOL@@@@@" "@@OOOOOOOOOOOOO@@@@@" "@@OOOOOOOOOOOOH@@@@@" "@@OOOOOOOOOOOL@@@@@@" "@@GOOOOOOOOOO@@@@@@@" "@@GOOOOOOOOON@@@@@@@" "@@GOOOOOOOOOL@@@@@@@" "@@GOOOOOOOOOH@@@@@@@" "@@GOOOOOOOOO@@@@@@@@" "@@GOOOOOOOON@@@@@@@@" "@@GOOOOOOOOH@@@@@@@@" "@@COOOOOOOO@@@@@@@@@" "@@COOOOOOON@@@@@@@@@" "@@COOOOOOOH@@@@@@@@@" "@@COOOOOOOH@@@@@@@@@" "@@COOOOOOOH@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@" "@@AOOOOOOO@@@@@@@@@@" "@@AOOOOOOL@@@@@@@@@@" "@@AOOOOOOL@@@@@@@@@@" "@@COOOOOOL@@@@@@@@@@" "@@GOOOOOOH@@@@@@@@@@" "@@COOOOOON@@@@@@@@@@" "@@AOOOOOON@@@@@@@@@@" "@@@OOOOOOL@@@@@@@@@@" "@@@OOOOOOL@@@@@@@@@@" "@@@OOOOOOL@@@@@@@@@@" "@@@OOOOOOL@@@@@@@@@@" "@@@OOOOOOL@@@@@@@@@@" "@@@OOOOOOL@@@@@@@@@@" "@@@OOOOOON@@@@@@@@@@" "@@@OOOOOON@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@" "@@@OOOOOOOO@@@@@@@@@" "@@@OOOOOOOOH@@@@@@@@" "@@@OOOOOOOOH@@@@@@@@" "@@@OOOOOOOOL@@@@@@@@" "@@@OOOOOOOON@@@@@@@@" "@@@OOOOOOOOOH@@@@@@@" "@@@OOOOOOOOOH@@@@@@@" "@@@OOOOOOOOOH@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 24413 NIL } {$IREGION IREGION.DEMOFN (NAME "Texas") (160 33 106 113) {(READBITMAP)(106 113 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOOH@@@@@@@@@@@@@@@" "@@@@@@@OOOOON@@@@@@@@@@@@@@@" "@@@@@@@OOOOOOL@@@@@@@@@@@@@@" "@@@@@@@OOOOOON@@@@@@@@@@@@@@" "@@@@@@@OOOOOOOL@@@@@@@@@@@@@" "@@@@@@@OOOOOOOOL@@@@@@@@@@@@" "@@@@@@@OOOOOOOOOH@@@@@@@@@@@" "@@@@@@@OOOOOOOOOOA@AIH@@@@@@" "@@@@@@@OOOOOOOOOOONGON@@@@@@" "@@@@@@@OOOOOOOOOOOOOOOH@@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "@@@@@@@OOOOOOOOOOOOOOOOH@@@@" "COOOOOOOOOOOOOOOOOOOOOOH@@@@" "AOOOOOOOOOOOOOOOOOOOOOOL@@@@" "@OOOOOOOOOOOOOOOOOOOOOON@@@@" "@OOOOOOOOOOOOOOOOOOOOOOO@@@@" "@GOOOOOOOOOOOOOOOOOOOOOO@@@@" "@COOOOOOOOOOOOOOOOOOOOOO@@@@" "@AOOOOOOOOOOOOOOOOOOOOOO@@@@" "@@OOOOOOOOOOOOOOOOOOOOOO@@@@" "@@GOOOOOOOOOOOOOOOOOOOOO@@@@" "@@COOOOOOOOOOOOOOOOOOOOO@@@@" "@@AOOOOOOOOOOOOOOOOOOOOO@@@@" "@@@GOOOOOOOOOOOOOOOOOOOO@@@@" "@@@GOOOOOOOOOOOOOOOOOOON@@@@" "@@@COOOOOOOOOOOOOOOOOOON@@@@" "@@@COOOOOOOOOOOOOOOOOOON@@@@" "@@@AOOOOOOOOOOOOOOOOOOON@@@@" "@@@AOOOOOOOOOOOOOOOOOOON@@@@" "@@@@OOOOOOOOOOOOOOOOOOON@@@@" "@@@@OOOOOOOOOOOOOOOOOOOL@@@@" "@@@@OOOOOOOOOOOOOOOOOOOL@@@@" "@@@@OOONAIOOOOOOOOOOOOOL@@@@" "@@@@GOOL@@OOOOOOOOOOONOL@@@@" "@@@@GOOH@@GOOOOOOOOOONF@@@@@" "@@@@AOOH@@COOOOOOOOOOLD@@@@@" "@@@@@OO@@@COOOOOOOOOOL@@@@@@" "@@@@@CO@@@AOOOOOOOOOOL@@@@@@" "@@@@@AN@@@@OOOOOOOOOOH@@@@@@" "@@@@@@N@@@@GOOOOOOOOOH@@@@@@" "@@@@@@@@@@@GOOOOOOOOO@@@@@@@" "@@@@@@@@@@@COOOOOOOON@@@@@@@" "@@@@@@@@@@@COOOOOOOOL@@@@@@@" "@@@@@@@@@@@AOOOOOOLO@@@@@@@@" "@@@@@@@@@@@AOOOOOOL@@@@@@@@@" "@@@@@@@@@@@AOOOOOOF@@@@@@@@@" "@@@@@@@@@@@@OOOOOOH@@@@@@@@@" "@@@@@@@@@@@@OOOOOOH@@@@@@@@@" "@@@@@@@@@@@@GOOOOO@@@@@@@@@@" "@@@@@@@@@@@@COOOOH@@@@@@@@@@" "@@@@@@@@@@@@COOOOL@@@@@@@@@@" "@@@@@@@@@@@@AOOOOH@@@@@@@@@@" "@@@@@@@@@@@@AOOOOH@@@@@@@@@@" "@@@@@@@@@@@@@OOOOH@@@@@@@@@@" "@@@@@@@@@@@@@GOOOH@@@@@@@@@@" "@@@@@@@@@@@@@COOK@@@@@@@@@@@" "@@@@@@@@@@@@@COOM@@@@@@@@@@@" "@@@@@@@@@@@@@COON@@@@@@@@@@@" "@@@@@@@@@@@@@COOO@@@@@@@@@@@" "@@@@@@@@@@@@@COOO@@@@@@@@@@@" "@@@@@@@@@@@@@AOON@@@@@@@@@@@" "@@@@@@@@@@@@@AOON@@@@@@@@@@@" "@@@@@@@@@@@@@@OOO@@@@@@@@@@@" "@@@@@@@@@@@@@@OOO@@@@@@@@@@@" "@@@@@@@@@@@@@@OOO@@@@@@@@@@@" "@@@@@@@@@@@@@@GOO@@@@@@@@@@@" "@@@@@@@@@@@@@@AOO@@@@@@@@@@@" "@@@@@@@@@@@@@@@OOH@@@@@@@@@@" "@@@@@@@@@@@@@@@COH@@@@@@@@@@" "@@@@@@@@@@@@@@@@CH@@@@@@@@@@" "@@@@@@@@@@@@@@@@A@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 38605 NIL } {$IREGION IREGION.DEMOFN (NAME "Oklahoma") (182 105 81 48) {(READBITMAP)(81 48 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@COOOOOOOOOOOOOOL@@@@@@@" "@COOOOOOOOOOOOOOL@@@@@@@" "@COOOOOOOOOOOOOOL@@@@@@@" "@COOOOOOOOOOOOOOL@@@@@@@" "@@@@@@@OOOOOOOOOL@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOON@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@OOOOOOOOOO@@@@@@@" "@@@@@@@GOOOOOOOOO@@@@@@@" "@@@@@@@@OOOOOOOOO@@@@@@@" "@@@@@@@@COOOOOOOO@@@@@@@" "@@@@@@@@@OOOOOOOO@@@@@@@" "@@@@@@@@@@GOOOOOO@@@@@@@" "@@@@@@@@@@AOOOOOO@@@@@@@" "@@@@@@@@@@@CKOIIN@@@@@@@" "@@@@@@@@@@@@@F@@F@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@")} 45278 NIL } {$IREGION IREGION.DEMOFN (NAME "Kansas") (188 138 71 44) {(READBITMAP)(71 44 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@AOOOOOOOOOOOO@@@@@@" "@AOOOOOOOOOOOOL@@@@@" "@AOOOOOOOOOOOOH@@@@@" "@AOOOOOOOOOOOOH@@@@@" "@AOOOOOOOOOOOOL@@@@@" "@AOOOOOOOOOOOOL@@@@@" "@AOOOOOOOOOOOON@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@AOOOOOOOOOOOOO@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 63785 NIL } {$IREGION IREGION.DEMOFN (NAME "Nebraska") (174 169 80 45) {(READBITMAP)(80 45 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@COOOOOOOOON@@@@@@@@" "@COOOOOOOOOO@C@@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOO@@@@@" "@COOOOOOOOOOOOOH@@@@" "@COOOOOOOOOOOOOH@@@@" "@COOOOOOOOOOOOOL@@@@" "@COOOOOOOOOOOOOL@@@@" "@COOOOOOOOOOOOOL@@@@" "@AOOOOOOOOOOOOON@@@@" "@AOOOOOOOOOOOOON@@@@" "@AOOOOOOOOOOOOOO@@@@" "@AOOOOOOOOOOOOOO@@@@" "@AOOOOOOOOOOOOOO@@@@" "@AOOOOOOOOOOOOOO@@@@" "@AOOOOOOOOOOOOOOH@@@" "@AOOOOOOOOOOOOOOH@@@" "@AOOOOOOOOOOOOOOH@@@" "@AOOOOOOOOOOOOOOH@@@" "@@@@@GOOOOOOOOOOL@@@" "@@@@@GOOOOOOOOOOL@@@" "@@@@@GOOOOOOOOOOH@@@" "@@@@@GOOOOOOOOOOL@@@" "@@@@@GOOOOOOOOOOL@@@" "@@@@@GOOOOOOOOOON@@@" "@@@@@GOOOOOOOOOON@@@" "@@@@@GOOOOOOOOOON@@@" "@@@@@GOOOOOOOOOOO@@@" "@@@@@GOOOOOOOOOOOH@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 17409 NIL } {$IREGION IREGION.DEMOFN (NAME "South Dakota") (175 195 71 44) {(READBITMAP)(71 44 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOO@@@@@" "@COOOOOOOOOOOOO@@@@@" "@COOOOOOOOOOOOO@@@@@" "@COOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@GOOOOOOOOOOOON@@@@@" "@GOOOOOOOOOOOON@@@@@" "@GOOOOOOOOOOOON@@@@@" "@GOOOOOOOOOOOON@@@@@" "@GOOOOOOOOOOOOO@@@@@" "@@@@@@@@@@@COOO@@@@@" "@@@@@@@@@@@AOIN@@@@@" "@@@@@@@@@@@@@@N@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 57427 NIL } {$IREGION IREGION.DEMOFN (NAME "North Dakota") (175 220 72 52) {(READBITMAP)(72 52 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@COOOOOOOOOOOO@@@@@@" "@COOOOOOOOOOOO@@@@@@" "@COOOOOOOOOOOO@@@@@@" "@COOOOOOOOOOOO@@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOON@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 40967 NIL } {$IREGION IREGION.DEMOFN (NAME "New Mexico") (136 79 63 75) {(READBITMAP)(63 75 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOOOOOOON@@@" "@@OOOOGOOOOON@@@" "@@OOOO@@@@@@@@@@" "@@OOOOH@@@@@@@@@" "@@OH@@@@@@@@@@@@" "@@OH@@@@@@@@@@@@" "@@OH@@@@@@@@@@@@" "@@OH@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 46505 NIL } {$IREGION IREGION.DEMOFN (NAME "Colorado") (142 139 62 51) {(READBITMAP)(62 51 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "COOOOOOOOOOOO@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 62023 NIL } {$IREGION IREGION.DEMOFN (NAME "Arizona") (98 79 59 75) {(READBITMAP)(59 75 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@HGOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@AOOOOOOOOOH@@@@" "@@OOOOOOOOOH@@@@" "@@OOOOOOOOOH@@@@" "@@OOOOOOOOOH@@@@" "@AOOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@GOOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "@OOOOOOOOOOH@@@@" "AOOOOOOOOOOH@@@@" "@COOOOOOOOOH@@@@" "@@GOOOOOOOOH@@@@" "@@@OOOOOOOOH@@@@" "@@@COOOOOOOH@@@@" "@@@@GOOOOOOH@@@@" "@@@@AOOOOOOH@@@@" "@@@@@GOOOOOH@@@@" "@@@@@@OOOOOH@@@@" "@@@@@@AOOOOH@@@@" "@@@@@@@OOOOH@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 42623 NIL } {$IREGION IREGION.DEMOFN (NAME "Utah") (96 131 61 74) {(READBITMAP)(61 74 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@AOOOOO@@@@@@@@" "@@AOOOOO@@@@@@@@" "@@AONOOO@@@@@@@@" "@@AOLGOO@@@@@@@@" "@@AOLGOO@@@@@@@@" "@@AOLGOO@@@@@@@@" "@@AOLCOO@@@@@@@@" "@@AON@OO@@@@@@@@" "@@AON@GO@@@@@@@@" "@@AOOLCO@@@@@@@@" "@@AOOLOOOOON@@@@" "@@AOOLGOOOON@@@@" "@@AOONOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 17392 NIL } {$IREGION IREGION.DEMOFN (NAME "Wyoming") (118 173 71 63) {(READBITMAP)(71 63 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOH@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@AOOOOOOOOOOOOL@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 26681 NIL } {$IREGION IREGION.DEMOFN (NAME "Montana") (89 213 112 57) {(READBITMAP)(112 57 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "AOOOOOOOOOOOOOOOOOOOOOL@@@@@" "@OOOOOOOOOOOOOOOOOOOOON@@@@@" "@GOOOOOOOOOOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOOOOOOOOON@@@@@" "@@OOOOOOOOOOOOOOOOOOOON@@@@@" "@@GOOOOOOOOOOOOOOOOOOON@@@@@" "@@COOOOOOOOOOOOOOOOOOON@@@@@" "@@AOOOOOOOOOOOOOOOOOOON@@@@@" "@@@OOOOOOOOOOOOOOOOOOON@@@@@" "@@@OOOOOOOOOOOOOOOOOOON@@@@@" "@@@COOOOOOOOOOOOOOOOOON@@@@@" "@@@@OOOOOOOOOOOOOOOOOON@@@@@" "@@@@OOOOOOOOOOOOOOOOOON@@@@@" "@@@@OOOOOOOOOOOOOOOOOON@@@@@" "@@@AOOOOOOOOOOOOOOOOOON@@@@@" "@@@AOOOOOOOOOOOOOOOOOON@@@@@" "@@@AOOOOOOOOOOOOOOOOOON@@@@@" "@@@AOOOOOOOOOOOOOOOOOON@@@@@" "@@@AOOOOOOOOOOOOOOOOOON@@@@@" "@@@AOOOOOOOOOOOOOOOOOON@@@@@" "@@@AKOOOOOOOOOOOOOOOOON@@@@@" "@@@@@OOOOOOOOOOOOOOOOON@@@@@" "@@@@@OOOOOOOOOOOOOOOOON@@@@@" "@@@@@OOOOOOOOOOOOOOOOON@@@@@" "@@@@@GOOOOOOOOOOOOOOOON@@@@@" "@@@@@COOOOOOOOOOOOOOOON@@@@@" "@@@@@AOOOOOOOOOOOOOOOON@@@@@" "@@@@@AOOON@@@@@@@@@@@@@@@@@@" "@@@@@COOON@@@@@@@@@@@@@@@@@@" "@@@@@@GOOL@@@@@@@@@@@@@@@@@@" "@@@@@@GOO@@@@@@@@@@@@@@@@@@@" "@@@@@@GL@@@@@@@@@@@@@@@@@@@@" "@@@@@@B@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@")} 21401 NIL } {$IREGION IREGION.DEMOFN (NAME "Nevada") (59 122 62 78) {(READBITMAP)(62 78 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@OOOOOOOOOON@@@@" "@GOOOOOOOOON@@@@" "@COOOOOOOOON@@@@" "@AOOOOOOOOON@@@@" "@@OOOOOOOOON@@@@" "@@COOOOOOOON@@@@" "@@AOOOOOOOON@@@@" "@@@OOOOOOOON@@@@" "@@@GOOOOOOON@@@@" "@@@COOOOOOON@@@@" "@@@AOOOOOOON@@@@" "@@@AOOOOOOON@@@@" "@@@@GOOOOOON@@@@" "@@@@COOOOOON@@@@" "@@@@AOOOOOON@@@@" "@@@@@OOOOOON@@@@" "@@@@@GOOOOON@@@@" "@@@@@COOOOON@@@@" "@@@@@AOOOOON@@@@" "@@@@@@OOOOON@@@@" "@@@@@@GOOOON@@@@" "@@@@@@COOOON@@@@" "@@@@@@AOOOON@@@@" "@@@@@@@OOOON@@@@" "@@@@@@@GOOON@@@@" "@@@@@@@COOON@@@@" "@@@@@@@AOOON@@@@" "@@@@@@@@OOON@@@@" "@@@@@@@@GONN@@@@" "@@@@@@@@COL@@@@@" "@@@@@@@@AOL@@@@@" "@@@@@@@@@ON@@@@@" "@@@@@@@@@GL@@@@@" "@@@@@@@@@GN@@@@@" "@@@@@@@@@CN@@@@@" "@@@@@@@@@AN@@@@@" "@@@@@@@@@@N@@@@@" "@@@@@@@@@@B@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 35762 NIL } {$IREGION IREGION.DEMOFN (NAME "Idaho") (76 184 62 86) {(READBITMAP)(62 86 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GN@@@@@@@@@@@@" "@@GO@@@@@@@@@@@@" "@@GOH@@@@@@@@@@@" "@@GOL@@@@@@@@@@@" "@@GOL@@@@@@@@@@@" "@@GOL@@@@@@@@@@@" "@@GOL@@@@@@@@@@@" "@@GON@@@@@@@@@@@" "@@GOOH@@@@@@@@@@" "@@GOOL@@@@@@@@@@" "@@GOON@@@@@@@@@@" "@@GOOO@@@@@@@@@@" "@@GOOO@@@@@@@@@@" "@@GOOOH@@@@@@@@@" "@@GOOON@@@@@@@@@" "@@GOOOO@@@@@@@@@" "@@GOOOO@@@@@@@@@" "@@GOOON@@@@@@@@@" "@@COOON@@@@@@@@@" "@@COOON@@@@@@@@@" "@@COOON@@@@@@@@@" "@@AOOON@@@@@@@@@" "@@@OOON@@@@@@@@@" "@@@GOON@@@@@@@@@" "@@@GOONB@@@@@@@@" "@@@GOOOO@@@@@@@@" "@@@OOOOO@@@@@@@@" "@@@OOOOOH@@@@@@@" "@@@OOOOOL@@@@@@@" "@@AOOOOON@@@@@@@" "@@AOOOOON@@@@@@@" "@@COOOOOL@@@@@@@" "@@GOOOOON@@@@@@@" "@@GOOOOOOH@@@@@@" "@@OOOOOOOH@@C@@@" "@@OOOOOOOLAOO@@@" "@@OOOOOOONOOO@@@" "@@COOOOOOOOOO@@@" "@@COOOOOOOOOO@@@" "@@COOOOOOOOOO@@@" "@@COOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@GOOOOOOOOOO@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@")} 30635 NIL } {$IREGION IREGION.DEMOFN (NAME "California") (21 91 94 111) {(READBITMAP)(94 111 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@GOOOOOOH@@@@@@@@@@@@@" "@@@GOOOOOOH@@@@@@@@@@@@@" "@@@GOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@GOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@@@@@" "@@AOOOOOOOH@@@@@@@@@@@@@" "@@@OOOOOOOH@@@@@@@@@@@@@" "@@@GOOOOOOH@@@@@@@@@@@@@" "@@@COOOOOOH@@@@@@@@@@@@@" "@@@COOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@AOOOOOOH@@@@@@@@@@@@@" "@@@@OOOOOOL@@@@@@@@@@@@@" "@@@@OOOOOON@@@@@@@@@@@@@" "@@@@GOOOOOO@@@@@@@@@@@@@" "@@@@COOOOOOH@@@@@@@@@@@@" "@@@@AOOOOOOL@@@@@@@@@@@@" "@@@@@OOOOOOO@@@@@@@@@@@@" "@@@@@OOOOOOOH@@@@@@@@@@@" "@@@@@GOOOOOOL@@@@@@@@@@@" "@@@@@GOOOOOON@@@@@@@@@@@" "@@@@@BOOOOOOO@@@@@@@@@@@" "@@@@@@GOOOOOO@@@@@@@@@@@" "@@@@@@COOOOOOH@@@@@@@@@@" "@@@@@@COOOOOON@@@@@@@@@@" "@@@@@@AOOOOOOO@@@@@@@@@@" "@@@@@@AOOOOOOOH@@@@@@@@@" "@@@@@@GOOOOOOOL@@@@@@@@@" "@@@@@@GOOOOOOON@@@@@@@@@" "@@@@@@GOOOOOOOO@@@@@@@@@" "@@@@@@COOOOOOOOH@@@@@@@@" "@@@@@@@GOOOOOOOL@@@@@@@@" "@@@@@@@GOOOOOOON@@@@@@@@" "@@@@@@@COOOOOOOO@@@@@@@@" "@@@@@@@COOOOOOOOH@@@@@@@" "@@@@@@@OOOOOOOOOL@@@@@@@" "@@@@@@@GOOOOOOOON@@@@@@@" "@@@@@@@GOOOOOOOOO@@@@@@@" "@@@@@@@GOOOOOOOOOH@@@@@@" "@@@@@@@COOOOOOOOOL@@@@@@" "@@@@@@@AOOOOOOOOON@@@@@@" "@@@@@@@@OOOOOOOOOO@@@@@@" "@@@@@@@@OOOOOOOOOOH@@@@@" "@@@@@@@@GOOOOOOOOOL@@@@@" "@@@@@@@@GOOOOOOOOOL@@@@@" "@@@@@@@@COOOOOOOOON@@@@@" "@@@@@@@@@OOOOOOOOOO@@@@@" "@@@@@@@@@OOOOOOOOOOH@@@@" "@@@@@@@@@OOOOOOOOOOL@@@@" "@@@@@@@@@GOOOOOOOOOO@@@@" "@@@@@@@@@COOOOOOOOOOH@@@" "@@@@@@@@@COOOOOOOOOOH@@@" "@@@@@@@@@COOOOOOOOOOH@@@" "@@@@@@@@@COOOOOOOOOOL@@@" "@@@@@@@@@COOOOOOOOOOL@@@" "@@@@@@@@@COOOOOOOOOON@@@" "@@@@@@@@@@@COOOOOOOOO@@@" "@@@@@@@@@@@AOOOOOOOOO@@@" "@@@@@@@@@@@@OOOOOOOOO@@@" "@@@@@@@@@@@@OOOOOOOON@@@" "@@@@@@@@@@@@@GOOOOOOL@@@" "@@@@@@@@@@@@@COOOOOOL@@@" "@@@@@@@@@@@@@COOOOOOL@@@" "@@@@@@@@@@@@@@GOOOOOL@@@" "@@@@@@@@@@@@@@COOOOOH@@@" "@@@@@@@@@@@@@@AOOOOOH@@@" "@@@@@@@@@@@@@@@OOOOO@@@@" "@@@@@@@@@@@@@@@GOOOO@@@@" "@@@@@@@@@@@@@@@GOOOO@@@@" "@@@@@@@@@@@@@@@COOOO@@@@" "@@@@@@@@@@@@@@@COOOOH@@@" "@@@@@@@@@@@@@@@AOOOOL@@@" "@@@@@@@@@@@@@@@AOOOOH@@@" "@@@@@@@@@@@@@@@AOOH@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@")} 20396 NIL } {$IREGION IREGION.DEMOFN (NAME "Oregon") (28 188 70 52) {(READBITMAP)(70 52 "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@AOH@@@@@@@@@@@@@@@@" "@AOL@@@@@@@@@@@@@@@@" "@AOL@@@@@AOOOOL@@@@@" "@AOL@@@@@OOOOON@@@@@" "@AOL@@@BGOOOOOO@@@@@" "@AON@OOOOOOOOOO@@@@@" "@COOOOOOOOOOOOO@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOON@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOOL@@@@@" "@COOOOOOOOOOOOH@@@@@" "@COOOOOOOOOOOO@@@@@@" "@COOOOOOOOOOOO@@@@@@" "@COOOOOOOOOOON@@@@@@" "@COOOOOOOOOOON@@@@@@" "@COOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOON@@@@@@" "@GOOOOOOOOOOOOH@@@@@" "@GOOOOOOOOOOOOH@@@@@" "@GOOOOOOOOOOOOH@@@@@" "@GOOOOOOOOOOOO@@@@@@" "@GOOOOOOOOOOOO@@@@@@" "@GOOOOOOOOOOOO@@@@@@" "@OOOOOOOOOOOOO@@@@@@" "@OOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "COOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "AOOOOOOOOOOOOO@@@@@@" "@OOOOOOOOOOOOO@@@@@@" "@OOOOOOOOOOOOO@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@")} 13978 NIL } {$IREGION IREGION.DEMOFN (NAME "Washington") (21 223 82 45) {(READBITMAP)(82 45 "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@COOOOOOOOON@@@@@@@@" "@@@@@@OOOOOOOOON@@@@@@@@" "@@@@@@OOOOOOOOON@@@@@@@@" "@@@@@@OOOOOOOOON@@@@@@@@" "@@@@@@OOOOOOOOON@@@@@@@@" "@@@@@@OOOOOOOOON@@@@@@@@" "@@H@@@GOOOOOOOON@@@@@@@@" "@@O@@@GOOOOOOOON@@@@@@@@" "@@OON@COOOOOOOON@@@@@@@@" "@@GOOLCOOOOOOOON@@@@@@@@" "@@GOOHGOOOOOOOON@@@@@@@@" "@@COO@GOOOOOOOON@@@@@@@@" "@@AOO@GOOOOOOOON@@@@@@@@" "@@AON@GOOOOOOOON@@@@@@@@" "@@AOL@GOOOOOOOON@@@@@@@@" "@@AOOHGOOOOOOOON@@@@@@@@" "@@@OO@OOOOOOOOON@@@@@@@@" "@@@ONGOOOOOOOOON@@@@@@@@" "@@@OOOOOOOOOOOON@@@@@@@@" "@@@OOOOOOOOOOOON@@@@@@@@" "@@@OOOOOOOOOOOON@@@@@@@@" "@@@GOOOOOOOOOOON@@@@@@@@" "@@@GOOOOOOOOOOON@@@@@@@@" "@@@GOOOOOOOOOOON@@@@@@@@" "@@@GOOOOOOOOOOON@@@@@@@@" "@@@GOOOOOOOOOOON@@@@@@@@" "@@@@@OOOOOOOOOOO@@@@@@@@" "@@@@@GOOOOOOOOOO@@@@@@@@" "@@@@@COOOOOL@@@@@@@@@@@@" "@@@@@COOOOL@@@@@@@@@@@@@" "@@@@@COOOK@@@@@@@@@@@@@@" "@@@@@CN@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@")} 64926 NIL })) (RPAQ \AIR.DEMO.BM (READBITMAP)) (502 291 "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@AN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@LJ@@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@AH@@@@@@@@@@DKL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@LMH@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@G@B@@@@@@@@GJCOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@MLH@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@@NCN@@@@@@@KH@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@N@GLH@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@@ALO@@@@@@GN@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@MHCCH@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@@@@OH@@@@@IL@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@OOOAH@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@KH@@@@H@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@KOLCD@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@DHAH@@H@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@HGOCL@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@FFOLA@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@H@@NN@@@@@@@@@HA@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@A@@@@@@@@@AH@CN@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@D@@AN@@@@@@@@@H@H@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@H@@@@@@GOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@D@@CL@@@@@@@@@H@D@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@G@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@GD@@@@@@@@@H@B@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@CH@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@ED@@@@@@@@@H@B@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@@L@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@HL@@@@@@@@@H@B@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@A@@@@@L@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@ALL@@@@@@@@@H@B@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@B@@@@AD@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@CK@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@CL@@@@@@@@@H@AH@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@D@@@@BD@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@BMN@@@@@@@@@@@@@@@@@" "@@@@@@@@H@GH@@@@@@@@@H@@D@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@H@@@@OH@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@D@AH@@@@@@@@@@@@@@@@" "@@@@@@@@H@L@@@@@@@@@@H@@B@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@A@@@@AF@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@L@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@H@@A@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@F@@@@NB@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@H@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@D@@@@@@@@HGN@A@AO@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@H@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@L@@@@@@@AAHD@N@@@H@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@F@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@D@@@@@@@GN@HG@@@@H@COI@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@AH@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@D@@@@@@@D@@OH@@@@D@D@AD@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@@H@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@D@@@@@@@D@@@L@@@@COH@AON@@@@@@@@@@@@@@@@@@@@@@@@@D@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@@H@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@F@@@@@@@D@@@D@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@H@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@A@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@B@@@@@@@D@@@CH@@@@@@@@@CL@@@@@@@@@@@@@@@@@@@@@@@A@@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@GOH@@@@@@@@@@D@@@A@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@B@@@@@@@D@@@@GL@@@@@@@@@KOOH@@@@@@@@@@@@@@@@@@@@A@@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@B@D@@@@@@@@@@D@@@A@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@B@@@@@@@D@@@@@B@@@@@@N@CN@@D@@@@@@@@@@@@@@@@@@@@A@@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@B@B@@@@@AOOOOL@@@A@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOON@@@@@@@H@@@@@AN@@@COAGOO@@COH@@@@@@@@@@@@@@@@@@A@@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@B@B@@@@AN@@@@B@@@A@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@B@@@@@@C@@@@@@@AH@HD@@H@COOM@G@@@@@@@@@@@@@@@@@@A@@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@B@B@@@BG@@@@@A@@@A@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@B@@@@@@B@@@@@@@@N@OL@AL@@@F@HA@@@@@@@@@@@@@@@@@@B@@@@D@@@@@@@@@@@@@@@@" "@@@@@@@@B@B@OOMH@@@@@@H@@AB@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@L@@@@@@B@@@@@@@@BA@@@ACH@@BC@A@@@@@@@@@@@@@@@@@@N@@@@B@@@@@@@@@@@@@@@@" "@@@@@@@@B@AO@@@@@@@@@@H@@AMH@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@H@@@@@@F@@@@@@@@BB@@@A@D@@AN@@L@@@@@@@@@@@@@@@@@H@@@@AH@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@@H@@@@H@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@D@@@@@@A@@@@@@@@BB@@@C@C@@@@@@D@@@@@@@@@@@@@@@@@H@@@@A@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@A@@@@@H@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@B@@@@@@A@@@@@@@@BD@@@F@@N@@@@@G@@@@@@@@@@@@@@@@AH@@@@@H@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@A@@@@@D@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@A@@@@@@B@@@@@@@@AIH@@H@@A@@@L@A@@@@@@@@@@@@@@@AN@@@@@@H@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@A@@@@@B@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@A@@@@@@B@@@@@@@@AJH@@H@@A@@AJ@@H@@@@@@@@@@@@@@BL@@@@@@N@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@B@@@@@A@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@A@@@@@@B@@@@@@@@@K@@G@@@A@@@F@@H@@@@@@@@@@@@@GOL@@@@@@B@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@B@@@@@A@@@@OOOOOOOOOOOOOH@@@@@@@@@@@@A@@@@@@B@@@@@@@@CK@@H@@@A@@@C@@D@@@@@@@@OOOOOHBD@@@@@@B@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@D@@@@@B@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@B@@@@@@@@BN@A@@@@A@@@BH@D@@@@@@@C@@@H@@BD@@@@@@B@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@@@AL@@AH@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@B@@@@@@@@CB@A@@@@A@@@BL@N@@@@@@@D@@@H@@DD@@@@@@B@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@@H@@@@@@D@@GH@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@A@@@@@@@@GB@B@@@@A@@@BC@H@@@@@@@L@@@H@@DD@@@@@AL@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@A@@@@@@@DAOLH@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@AL@@@@@@@@D@B@@@@A@@@B@OH@@@@@@A@@@@H@@DD@@@@@F@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@A@@@@@@@BN@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@G@@@@@@@@D@B@@@@A@@@D@@@@@@@@@F@@@@H@@LD@@@@GL@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@@@@@@A@@@@@@@A@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@H@@@@@@@H@B@@@@A@@@H@@@@@@@@AN@@@@H@A@D@@@GM@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@AL@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@D@@@@@@@H@D@@@@C@@@H@@@@@@@@NL@@@@H@B@D@@@H@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@D@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@D@@@@@@@H@H@@@@B@@A@@@@@@@AO@D@@@@H@B@B@@@H@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@D@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@B@@@@@@A@@H@@@@LG@A@@@@@@@N@@H@@@@H@D@B@@C@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@D@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@AL@@@@@A@@H@@@A@HHA@@@@@GO@@@H@@@@H@D@B@@D@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@@D@@@@@A@@H@@@AA@HA@@@@CH@@@A@@@@@H@D@B@CL@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@@D@@@@@A@@H@@@AB@HA@@@@D@@@@A@@@@@H@H@BAL@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@@D@@@@@A@@H@@@AL@HA@@@AH@@@@A@@@@@H@H@BA@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@COOOOOOOOOL@@@@@B@@H@@@@@@DA@@@B@@@@@B@@@@@LA@@BC@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@B@@@@@@@@@D@@@@@B@@H@@@@@@DA@@@B@CL@@D@@@@@DA@@BB@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@B@@@@@@@@@F@@@@@B@@D@@@@@@DB@@@BCLCOOH@@@@@DA@@BD@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@B@@@@@@@@@B@@@@@B@@D@@@@@@DD@@@CN@@@@@@@@@@DA@@BD@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@@B@@@@@B@@D@@@@@@FH@@@@B@@@@@@@@@@DA@@AH@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@AOOOOOOOOOOH@@A@@@@@@@@@B@@@@@B@@B@@@@@@C@@@@@A@@@@@@@@@@DB@@@H@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@D@LB@@@@@@@@@B@@@@@B@@B@@@@@@B@@@@AIH@@@@@@@@@DB@@A@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@D@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@COBB@@@@@@@@@B@@@@@B@@B@@@@@@B@@@CNGH@@@@@@@@@DB@@A@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@AN@@@@@@@@@AH@@@@B@@B@@@@@@D@A@D@C@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@B@@@@@@@@@@D@@@@B@@B@@@@@AL@NOL@B@@@@@@@@@@D@@@A@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@@@COOOON@@B@@@@@BNA@@@@D@@@@@@@@@@H@@@B@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@A@@@@@@@@@@A@@@@B@@B@@@@@CBC@@@AH@@@@@@@@@@H@@@B@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@@H@@@@@@@@@A@@@@B@@D@@@@@GND@@@F@@@@@@@@@@@H@@@C@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@@H@@@@@@@@@@H@@@B@@H@@@@@L@H@@@L@@@@@@@@@@@H@@@@H@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@@@@@@@H@@@@@@@@@@H@@@@@@@@@@@A@@@@@@@@@@@@@@H@@@@@@@@@@D@@@A@@H@@@@@LC@@@CD@@@@@@@@@@A@@@@@I@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@AH@@@@@@@@@@@@@D@@@@@@@@@@D@@@A@A@@@@@@KL@@ALGOOOOOOOL@@AOOON@DL@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@@@@@H@@@@@@@@@@@@H@@@@@@@@@@@@@D@@@@@@@@@@D@@@@HA@@@@@A@@@@FH@@@@@@@@B@@A@@@I@DD@@@@@@@@@@@@@@@@@@@@" "@@@@@@@AH@@@@@@B@@@@@@@@@@B@@@@@H@@@@@@@@@@@@H@@@@@@@@@@@@@B@@@@@@@@@@D@@@@HGOOOH@B@@@AHH@@@@@@@@A@@A@@@I@GL@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@A@@@H@@@@@@@@@@@@H@@@@@@@@@@@@@B@@@@@@@@@@H@@@@LH@@@OOO@@@B@H@@@@@@@@@H@A@@@HH@L@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@B@@@@@@@@@@B@BH@@H@@@@@@@@@@@@H@@@@@@@@@@@@@B@@@@@@@@@@H@@@@K@@@@H@@L@AL@H@@@@@@@@@H@A@@@HDG@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@B@@@@@@@@@@B@BH@@H@@@@@@@@@@@@H@@@@@@@@@@@@@C@@@@@@@@@G@@@@@H@@@@H@@CLN@@H@@@@@@@@@D@A@@@KOD@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@B@@@@@@@@@@B@BH@@H@@@@@@@@@@@@H@@@@@@@@@@@@@A@@@@@@@@AH@@@@@H@@@@H@@BC@@@H@@@@@@@@@B@A@@AF@H@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@BD@@H@@@@@@@@@@@@H@@@@@@@@@@@@@A@@@@@@@@A@@@@@@H@@@@H@@@@@@@H@@@@@@@@@CHA@OOH@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@AC@@H@@@@@@@@@@@@H@@@@@@@@@@@@@A@@@@@@@@B@@@@@@H@@@@H@@@@@@@H@@@@@@@@@DDCG@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@ALH@H@@@@@@@@@@@@H@@@@@@@@@@@@@A@@@@@@@@A@@@@@@H@@@@H@@@@@@@H@@@@@@@@@HCJHAO@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@@BL@OOOOOOOOOOOOOOOON@@@@@@@@@@@H@@@@@@@A@@@@@@H@@@@H@@@@@@@H@@@@@@@@A@@JCNF@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@B@@@@@@@@@@B@@C@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@H@@@@@@@A@@@@@@H@@@@H@@@@@@@H@@@@@@@@@H@LLAH@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@@BH@@@@A@@@@@@@@@@@@B@@@@@@@@@@A@@@@@@@@B@@@@@@H@@@@H@@@@@@@H@@@@@@@@A@@HGN@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@B@@@@@@@@@@B@@A@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@H@@@@@@FF@@@@@@H@@@@H@@@@@@@H@@@@@@@@A@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@OOOOOOOJH@@@@@@H@@@@H@@@@@@@H@@@@@@@@A@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@D@@@@@@AH@@@@@@H@@@@H@@@@@@@H@@@@@@@@@H@H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@D@@@@@@@H@@@@@@H@@@@H@@@@@@@H@@@@@@@@@D@H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@A@@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@D@@@@@@A@@@@@@@H@@@@H@@@@@@AH@@@@@@@@@D@H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@H@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@A@@@@@@@H@@@@H@@@@@@AH@@@@@@@@@B@H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@D@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@A@@@@@@A@@@@@@@H@@@@H@@@@@@BH@@@@@@@@@LA@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@B@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@COOOOOOOOOOOO@@@@@@@H@@@@@@H@@@@H@@@@@@BH@@@@@@@@AHA@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@B@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@L@@@@@@H@@@@@@H@@@@H@@@@@@BH@@@@@@@@O@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@B@@@@@@H@@@@@@H@@@@H@@@@@@BOOOOOOOOOD@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@D@@@@@@D@@@@@@H@@@@H@@@@@@D@A@@@@@@AL@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@D@@@@@@B@@@@@@H@@@@H@@@@@@H@AAO@@@@AH@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@B@@@@@@A@@@@@@H@@@@H@@@@@@H@AB@H@@@AL@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@B@@@@@@@H@@@@@H@@@@H@@@@@G@@AD@L@@AAFAL@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@A@@@@@@@D@@@@@H@@@@H@@@@AH@@AH@KN@CAEA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@B@@@@@H@@@@H@@@@A@@@@@A@B@CADI@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@A@@@@@@B@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@B@@@@@H@@@@OH@@@F@@@@@B@A@CABF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@H@@@@@A@@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@A@@@@@H@@@@HH@@@O@@@@@F@@LCABD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@H@@@@@@H@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@L@@@@H@@@@HG@@@L@@@@AH@@FEAA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@D@@@@@@D@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@D@@@@H@@@O@@HD@H@@@@B@@@DEA@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@B@@@@@@B@@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@D@@@@H@@@H@@GO@H@@@@B@@@LMAA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@A@@@@@@AH@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@D@@@@H@@A@@@@AI@@@@AD@@@HII@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@H@@@@@@D@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@H@@@A@@@B@@@@@N@@@@CH@@@DDHOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@H@@@@@@B@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@H@@@B@@@F@@@@@D@@@@D@@@@DDHAH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@D@@@@@@A@@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@H@@@D@@@H@@@@@D@@@@D@@@@CDHA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@D@@@@@@@H@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@D@@@D@@LH@@@@@H@@@@H@@@@OLLC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@BH@@@@@@D@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@D@@@D@@K@@@@@@D@@@@H@@@@HFEO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@AL@@@@@@D@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@CH@@GNNH@@@@@@B@@@A@@@@@G@CF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@B@@@@@@C@@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@L@@DAA@@@@@@@B@@@B@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@J@@@@@@@H@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@D@@H@@@@@@@@@A@@@D@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@M@@@@@@@D@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@B@@H@@@@@@@@@@H@@D@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@G@@@@@@@B@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@B@A@@@@@@@@@@@D@@D@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@D@@@@@@@A@@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@B@B@@@@@@@@@@AJ@GH@@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@D@@@@@@@@H@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@B@D@@@@@@@@@@BACH@@@@@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@D@@@@@@@@D@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@BGH@@@@@@@@@@D@L@@@@@@@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@B@@@@@@@@B@@@@@B@@@@@@@@A@@@@@@@@@@@@B@@@@@@@@@@@@@H@@@@@@@@AH@@@@@@@@@@AH@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@AL@@@@@@@A@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@L@@@@@@@@@@C@@@@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@D@@@@@@@@H@@@@B@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@H@@@@@@@@@D@@@@@@@@@AO@@@@@@@@@@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@B@@@@@@@@D@@@@B@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@H@@@@@@@@@D@@@@@@@@@B@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@F@@@@@@@@B@@@@B@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@H@@@@@@@@@H@GOOOH@@@F@@@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@H@@@@@@@@A@@@@B@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@H@@@@@@@@A@@L@@@GOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@D@@@@@@@@@H@@@B@@@@@@@@A@@@@@@@@@@AOOOOOL@@@@@@@@@OOOOOOOOLGOOH@@@@@@@@@@A@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@D@@@@@@@@@D@@@B@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@BB@@@@@@@@@@@@@C@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@D@@@@@@@@@B@@@B@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@DD@@@@@@@@@@@@@D@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@B@@@@@@@@@A@@BB@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@DD@@@@@@@@@@@@AL@@@@@@@@@BK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@A@@@@@@@@@@H@EN@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@HD@@@@@@@@@@@@B@@@@@@@@@@GA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@H@@@@@@@@@D@D@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@GH@@@@@@@@@@@AL@@@@@@@@@@GIH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@H@@@@@@@@@B@B@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@@H@@@@@@@@@@@B@@@@@@@@@@@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@D@@@@@@@@@A@D@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@D@@@@@@@AH@@@@@@@@@@@L@@@@@@@@@@@@EH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@D@@@@@@@@@A@B@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@@@ID@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@B@@@@@@@@@@HB@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@A@@@@@@@@@@@N@@@@@@@@@@@@@GD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@AH@@@@@@@@@DB@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@F@@@@@@@@@@A@@@@@@@@@@@@CNDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@H@@@@@@@@@BB@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@F@@@@@@@@@@B@@@@@@@@@@@@AIHD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@H@@@@@@@@@AJ@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@F@@@@@@@@@@D@@@@@@@@@@@@@D@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@D@@@@@@@@@@F@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@F@@@@@@@@@@H@AOOO@@@@@@@DHC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@B@@@@@@@@@@B@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@L@@@@@@@@@@H@F@@@L@@@@@@CLD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@B@@@@@@@@@@B@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@@OOOOOOOOOOOOOL@@@B@@@@@@AK@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@B@@@@@@@@@@B@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@AH@@@H@@@A@@@AH@@@COL@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@B@@@@@@@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@C@@@@H@@@A@@@A@@@@@@C@@@CCN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@B@@@@@@@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@D@@@@@@@@@B@@@@@@B@@@@H@@@A@@@AH@@@@@@H@@AOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@B@@@@@@@@@@@H@@@@@@@@A@@@@@@@@@@A@@@@@F@@@@@@@@@B@@@@@@B@@@@H@@@A@@@@D@@@@@@H@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@AON@@@@@@@@@D@@@@@@@@A@@@@@@@@@@A@@@@@AL@@@@@@@@B@@@@@@B@@@@H@@@A@@@@F@@@@@@D@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@A@@@@@@@@@D@@@@@@@@A@@@@@@@@@@A@@@@@@C@@@@@@@@B@@@@@@N@@@@H@@@A@@@@C@@@@@@B@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@H@@@@@@@@D@@@@@@@@A@@@@@@@@@@A@@@@@@AL@@@@@@@B@@@@@AH@@@@H@@@AH@@@A@@@@@@A@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@H@@@@@@@@H@@@@@@@@A@@@@@@@@@@A@@@@@@@CN@@@@@@B@@@@@AH@@@@H@@@@H@@@@H@@@@@@HA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@GL@@@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@@@@CH@@@@@B@@@@@A@@@@A@@@@@H@@@@D@@@@@@DA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@B@@@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@GA@AIHD@@@@@A@@@@A@@@@@H@@@@F@@@@@@CO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@B@@@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@NNFFFD@@@@@C@@@@A@@@@@H@@@@C@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@AL@@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@AH@AL@@@@@C@@@@A@@@@@H@@@@A@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@B@@@@@C@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@GH@@@@B@@@@A@@@@@D@@@@AH@@@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@A@@@@@B@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@A@@@@@D@@@@@D@@@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@H@@@@D@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@A@@@@@D@@@@@B@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@D@@@@D@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@A@@@@@D@@@@@B@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@D@@@@D@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@A@@@@@D@@@@@B@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@B@@@@D@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@A@@@@@D@@@@@A@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@B@@@@B@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@GOOOON@@@@B@@@@@F@@@@@@H@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@A@@@@A@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@B@@@@@@D@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@A@@@@C@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@B@@@@@@D@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@A@@COL@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@B@@@@@@D@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@AOOL@D@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@B@@@@@@B@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@A@@@@@@A@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@A@@@@B@@@@@A@@@@@@A@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@A@@@@@@A@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@A@@@@@@AA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@@@@@A@@@@H@@@@@A@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@B@@@@@@@J@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@@@A@@@@OOOOOOO@@@@@@@@@@@@@@@@D@@@@B@@@@B@@@@@C@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@A@@@@D@@@@@@@@@@@@@@@@@@@@@@D@@@@D@@@@D@@@@@B@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@@A@GOON@@@@@@@@@@@@@@@@@@@@@@B@@@@H@@@@D@@@@@B@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@@@A@D@@C@@@@@@@@@@@@@@@@@@@@@@A@@@@H@@@@B@@@@@B@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@A@D@@A@@@@@@@@@@@@@@@@@@@@@@@H@@A@@@@@B@@@@@B@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@A@D@@AH@@@@@@@@@@@@@@@@@@@@@@H@@A@@@@@B@@@@@B@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOL@@@L@@@@@@@@@@@@@@@@@@@@@@H@@A@@@@@B@@@@@B@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@@@@@@@@@@@@@@@@@H@@A@@@@@B@@@@@B@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@H@@B@@@@@B@@@@@B@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@H@@B@@@@@B@@@@@A@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@H@@COOOH@B@OOOOO@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@H@@@@@@H@B@H@@@AL@@@@BD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@H@@@@@@H@B@H@@@@H@@@@EL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@A@@@@@@@H@B@D@@@@OOON@DD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@A@@@@@@@H@B@D@@@@@@@ANDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@A@@@@@@@HCB@E@@@@@@@@ADD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@A@@@@@@NDLOJNON@@@@@@@HD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@@@@@@@@@@@@@@A@@@@@ACM@@G@@AH@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@A@@@@@@HN@@@@@@F@@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@C@@@@@@OG@@@@@@A@@O@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@B@@@@@AOJ@@@@@@@HCHH@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@ANF@@@@@@@@@@@@@B@@@L@@BA@@@@@@@HD@D@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@BAI@@@@@@@@@@@A@COHAB@@AF@@@@@@@KL@B@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@D@@H@@@@@@@@@@AIL@FAB@@AN@@@@@@@D@@A@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@D@@D@@@@@@@@@@CJ@@ANOL@FL@@@@@@@@@@A@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@H@@D@@@@@@@@@@BL@@@@@D@CO@@@@@@@@@@@H@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@H@@B@@@@@@@@@@C@@@@@@NABKH@@@@@@@@@@H@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FAH@@A@@@@@@@@@@F@@@@@@FBJGD@@@@@@@@@@D@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AA@@@@H@@@@@@@@@D@@@@@@ALDBL@@@@@@@@@@C@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@H@@@@@@@@@H@@@@@@@@@AH@@@@@@@@@@@H@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@A@@@@@@@@@@A@@@@@@@@@@@@H@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@H@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@H@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@CO@@@@@@@@@@@@@@@@@@@@@@@@H@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@IB@@@@@@@@@@@@@@@@@@@@@@@@H@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@H@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@H@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@A@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@GL@@@@@@@@@@@@@@@@@@@@@@@@A@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@AH@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@AJ@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@DL@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@BL@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@D@@FB@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@B@@EA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@CL@IA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@AL@IA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@D@EA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@B@BA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@D@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CLD@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@BL@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@B@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@") (DEFINEQ (AIREGIONS.CIRCLES.DEMO [LAMBDA NIL (* edited: "24-Jun-85 08:57") (LET [W (REG (GETBOXREGION 300 300)) (POS1 (QUOTE (153 . 222))) (POS2 (QUOTE (238 . 76))) (POS3 (QUOTE (74 . 73))) (POS4 (QUOTE (100 . 153))) (POS5 (QUOTE (200 . 159))) (POS6 (QUOTE (148 . 71))) (POS7 (QUOTE (152 . 131] (SETQ W (CREATEW REG "Intersecting Circles")) (DRAWCIRCLE 100 100 90 2 NIL W) (DRAWCIRCLE 200 100 90 2 NIL W) (DRAWCIRCLE 150 190 90 2 NIL W) (CURSOR WAITINGCURSOR) (CREATEIR W 33284 NIL NIL (QUOTE (62 98 186 186)) (LIST POS1 POS4 POS5 POS7)) (CREATEIR W 18458 NIL NIL (QUOTE (112 9 185 188)) (LIST POS6 POS2 POS5 POS7)) (CREATEIR W 13793 NIL NIL (QUOTE (12 10 184 186)) (LIST POS6 POS3 POS4 POS7)) (INTERSECTING.IREGIONS? W T) (CURSOR T]) (IREGION.DEMOFN [LAMBDA (WINDOW IREGION BUTTON) (* edited: "23-Jun-85 17:38") (BITBLT NIL 0 0 WINDOW 0 0 300 (IPLUS (ITIMES (FONTPROP (DSPFONT NIL WINDOW) (QUOTE HEIGHT)) 2) (FONTPROP (DSPFONT NIL WINDOW) (QUOTE DESCENT))) (QUOTE TEXTURE) NIL 0) (DSPXPOSITION 0 WINDOW) (DSPYPOSITION (IPLUS (FONTPROP (DSPFONT NIL WINDOW) (QUOTE HEIGHT)) (FONTPROP (DSPFONT NIL WINDOW) (QUOTE DESCENT))) WINDOW) (PRINTOUT WINDOW "State: " (IREGIONPROP IREGION (QUOTE NAME)) T) (PRINTOUT WINDOW "Population: " (ITIMES 80 (STRINGHASHBITS (IREGIONPROP IREGION (QUOTE NAME]) (SETUP.AIREGION.DEMO [LAMBDA NIL (* edited: "23-Jun-85 18:23") (SETQ \AIREGION.DEMOW (CREATEW (QUOTE (100 100 502 291)) "AIRegion Demo")) (BITBLT \AIR.DEMO.BM 0 0 \AIREGION.DEMOW) (WINDOWPROP \AIREGION.DEMOW (QUOTE IREGIONSLIST) \ALL.AIR.IREGIONS) (WINDOWPROP \AIREGION.DEMOW (QUOTE BUTTONEVENTFN) (QUOTE IN.CURSOR.REGION]) ) (SETUP.AIREGION.DEMO) (AIREGIONS.CIRCLES.DEMO) (PUTPROPS AIREGIONS-DEMO COPYRIGHT ("XEROX Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (94937 97176 (AIREGIONS.CIRCLES.DEMO 94947 . 95934) (IREGION.DEMOFN 95936 . 96729) ( SETUP.AIREGION.DEMO 96731 . 97174))))) STOP \ No newline at end of file diff --git a/lispusers/AIREGIONS.TEDIT b/lispusers/AIREGIONS.TEDIT new file mode 100644 index 00000000..6caa433c --- /dev/null +++ b/lispusers/AIREGIONS.TEDIT @@ -0,0 +1,70 @@ +enˇvĹos AIREGIONS 2 4 1 AIREGIONS (Active Irregular Regions) 1 4 By: Greg Wexler (Wexler.pasa@Xerox) and By: Jim Wogulis (Wogulis@ICS.UCI.EDU) New Owner: James Turner (Turner.Lexington@Xerox.com) Uses: FILLREGION, AIREGIONS-DEMO INTRODUCTION The purpose of this package is to provide menu-like operations on irregularly shaped regions within a window and make available general functions that allow users to create their own applications using irregularly shaped active regions. An added feature of AIRegions is that multiple IREGIONs may be activated by selecting the intersecting area of those IREGIONs. (Throughout this document an irregularly shaped region will be referred to as an IREGION). DESCRIPTION Virtually all of the features of menu selection have been implemented in this package: ease of menu creation, item-selected shading, quick response to selection, and execution of an associated function. Yet, this package adds one additional feature without any degradation to the quality and efficiency of menu implementation: the selection of any irregularly shaped region from any point within that region, and without any unsightly cosmetic change. In describing the package by means of an example, picture a map of the world, or better yet, of a particular country broken up into its individual states and/or provinces. Suffice it to say that these regions are not square but irregular in shape and that they are bordered by solid lines, as they are on a common map. Unlike the menu package or ACTIVEREGIONS package, AIRegions allows you to select any of these pre-set states/provinces just as if your are making a menu selection of an item. One of the nice aspects of this package lies in the fact that the package does NOT make any costmetic changes to the irregularly shaped region, like providing some small box within the region to button in. Simply button your mouse within the solidly bordered region, anywhere in the region, and it will shade it to your particular shade and execute your defined function. Functionality provided: The functions in this package allow the user to work with familiar concepts: creating and implementing windows and menus. The examples provided within this documentation should be sufficient for the user to begin setting up irregularly shaped regions. (CREATEIR window shade buttoneventfn helpstring region poslist) [Function] window: the window which will contain the irregular region. shade: can be either a number between 0 and 65535 for a 4 by 4 shading or a 16 by 16 bitmap (if shade is NIL then the default is black, 65535). buttoneventfn: the function called when the region is selected. The arguments that are passed to the function are: the window containing the IREGION, the IREGION record itself, and the button which selected the IREGION. helpstring: the string that is placed in the PROMPTWINDOW when the mouse is held over the item for a few seconds. region: if specified, will be the region relative to window in which the IREGION can be found. (If region is NIL, the user will be prompted to sweep out a region within window.) poslist: If specified, will be either a position or list of positions relative to window that are the starting points for the FILLREGION routine (i.e. a point within the desired IREGION). (if poslist is NIL, the user will be prompted for a position until he/she selects outside of region.) Description of use: This is the first function that is called when actually setting up an irregularly shaped region to become sensitive to button activity. If the region argument is not set, then the cursor changes its shape and prompts for a region to completely surround the IREGION within the desired active window.(Note: That it is best to surround the desired IREGION as close as possible since this will save on execution time and memory useage.) A thin box will appear temporarily where the IREGION was scanned. If poslist is NIL, then the cursor changes into a TARGET symbol. The user should left-button mouse within desired active IREGION. Note: the IREGION must be surrounded by a border that FILLREGION can use to define the active area. Any gaps in the IREGION will cause the next routine to fill the region and anything outside with the shade provided. Mistakes can be corrected by using the REMOVE.IREGION function described below and PAINTing in the gap to retry. After left-buttoning within the desired active IREGION, the cursor continues to remain in its TARGET state. If the IREGION is split up into many different parts, those parts may be selected with the left-button also making them all active concurrently. However, when one is finished activating that one IREGION, then she/he should left-button outside of region. This function must be called for each desired IREGION. Examples: (CREATEIR window 21930 'myfunction "This is the helpstring") (CREATEIR (WHICHW) 1234 'MY.SELECTED.FN "This is the helpstring" '(0 0 20 30) '((12 . 15)(2 . 29)) (SURROUNDIR window shade buttoneventfn helpstring poslist inside.pos) [Function] window: the window which will contain the irregular region. shade: can be either a number between 0 and 65535 for a 4 by 4 shading or a 16 by 16 bitmap (if shade is NIL then the default is black, 65535). buttoneventfn: the function called when the region is selected. The arguments that are passed to the function are: the window containing the IREGION, the IREGION record itself, and the button which selected the IREGION. helpstring: the string that is placed in the PROMPTWINDOW when the mouse is held over the item for a few seconds. poslist: If specified, a list of positions relative to window that are the edge points for the FILLREGION routine. If NIL, the user will be prompted to define the outer border of the region desired to be active. Holding the SHIFT key will define the last point used in defining the edge. If this field is non-nil, Inside.pos must be specified. Inside.pos: If specified, this would be the inside position in which the Fillregion routine would begin filling from. If poslist is non-nil, then this field must be specified. Description of use: Like the CREATEIR function, this function creates IREGIONS. However, the functionality of this routine is quite different. There are times when you do not care what is within a particular region. Say, for example, you have a map of some country and you wish to surround a particular region of the country with an IREGION as you wish to denote an area rich in some mineral deposit or some other characteristic. Such a characteristic is oblivious of the borders of the country's states or provinces, streams, rivers,etc., yet you would like to make active a very general area. Upon calling this function, you are prompted to button around the area of interest. And so, in viewing the crosshairs cursor, you begin buttoning about specifying the border of the area you wish to make active, independant of what is inside it. To stop being prompted for the next edge, simply hold the SHIFT key on the keyboard, (either one will do), as you make your last button selection. At this point, the lisp DRAWCURVE function will take effect and draw the closed region you've defined. Note that the first and last points do not have to touch as the DRAWCURVE routine will connect them for you. You will also be prompted to button within the region you've marked. It is here that the Fillregion routine will begin filling your region from. When complete, this function adds the IREGION to the window and returns the iregion added. Examples: (SURROUNDIR window 21930 'myfunction "This is the helpstring") (SURROUNDIR (WHICHW) 1234 'MY.SELECTED.FN "This is the helpstring" '((5 . 5)(6 . 50)(50 . 50)(50 . 7)) '(10 . 10))) (ADD.IREGION window iregion) [Function] window: the window to which the iregion is to be added. iregion: the IREGION to be added to window. Description: This function will add iregion to window which will then allow mouse selection of that IREGION. (REMOVE.IREGION window iregion) [Function] window: the window in which the iregion exists. iregion: the IREGION you wish to remove from window. Description: This function removes the region from a list of active irregular regions which is stored as a window property of the window. The list of irregular active regions can be found by evaluating: (ALL.IREGIONS window)). (INTERSECTING.IREGIONS? window flg) [Function] window: a window. flg: either T or NIL Description: This function sets up window to allow selection of intersecting iregions. If two or more iregions overlap and this function had been called with flg = T, then when the overlapping region is selected, all of those iregions will be high-lighted and each IREGIONs BUTTONEVENTFN will be called. If flg is set to NIL, then the last IREGION created in that intersection of iregions will be selected. (Please be aware that intersecting iregions might generate effects that you do not wish to have. That is, if you leave the iregion "ON" (the exact same thing you see when you hold the mouse button down on the iregion, done by inverting that iregion) and create another iregion intersecting with the first, then the mask of the second would have a partial image of the first. At this point, buttoning in an area where both regions interesect might show everything but the intersection of those regions. Sometimes, it all depends on the order that they are created and what iregion's mask is left on or off. Shades that are "negatives" or "equals" of one another might make matters more complex than necessary when they are intersected. It is recommend that you play with this function in order to understand how it actually works so that when you work it into your application you'll have a better idea of the functionality and end-results). If this becomes a problem, an EDIT.MASK function has been provided so that you may edit the mask of the iregion by hand. Currently, there are no programmatic methods for doing this. (ALL.IREGIONS window) (Function) window: a window containing IREGIONS. Description: This function returns a list of all the IREGIONS attached to window. (DOSELECTED.IREGION window iregion button) (Function) window: the window associated with iregion. iregion: the iregion to be activated button: the button which selected iregion. Description: Applied iregions BUTTONEVENTFN to window, iregion and button. This provides a programmatic way of activating a given IREGION. This does not invert the iregion. (EDIT.MASK iregion) (Function) iregion: the IREGION whose mask you want to edit. Description: This function is provided for buttoning in places where the MASK is not set. More explicitly, TARGETing a region (while creating the regions) specifies the places where the FILLREGION routine is to create a mask. For example, if a US state contains many rivers one pixel wide, the FILLREGION routine will fill around the river, but not the river itself. This means that when the mouse is positioned on the river, the region will not shade because the mask does not have that bit turned on. However, if the mask is edited and the rivers filled in, buttoning on those rivers will activate the IREGION. (INVERT.IREGION window iregion) (Function) window: the window in which the iregion exists. iregion: the IREGION targeted for shading. Description: This will highlight the iregion with that iregions shade. Calling it a second time will low-light it. (IREGIONP iregion) (Function) iregion: the IREGION to be tested. Description: This function returns NIL if iregion is not an IREGION datatype and returns iregion if it is an IREGION. (IREGIONPROP iregion prop newvalue) (Function) iregion: the region of which you are setting/requesting the property. prop: the property in which you are interested. newvalue: the new value to be assigned to prop. Description: As with WINDOWPROP, if newvalue is not specified, it will return the current value of the iregion's property. If newvalue is specified, then the property will be reassigned with that value. If a prop name is not one of the fields of an IREGION record, it will be stored in property-list format on the USERDATA field of the iregion record. IREGION fields: BUTTONEVENTFN - function called when iregion is selected. USERDATA - property list format for user properties (similar to WINDOWPROP). REGION - region relative to the window that surrounds the iregion. MASK - a bitmap the same size of REGION that is blackened where the iregion is active. SHADE - the shade number or bitmap used to shade the region. HELPSTRING - the string that is printed in the PROMPTWINDOW when a region is held. Examples: (IREGIONPROP iregion 'SHADE) -- returns shade of iregion (IREGIONPROP iregion 'SHADE 21930) - assigns new shade to iregion. (SHOW.ALL.IREGIONS window shade delay) (Function) window: the window in which the IREGIONs exist. shade: the shade with which the iregions will be shown. delay: the time (in milliseconds) between which each IREGION is displayed . (if delay is NIL, then a default of 500 is used.) Description: This function will shade and unshade in shade (black is used if shade is NIL), each IREGION that has been created in the particular window. This is especially useful when the user has lost track of the number of IREGIONS within a window. (WHICH.IREGIONS window posorx y) (Function) window: the window in which the IREGIONs lie. (if window is NIL, default is window to which mouse points). posorx, y: the location within the window where the IREGIONs can be found. These points must be local to the window's coordinates...not the screen. (if posorx is a position, then it will be used, otherwise if x or y are not numbers then the current mouse position is used.) Description: Will return either NIL or the list of IREGIONs found in window and specified by posorx, y. Examples: (WHICH.IREGIONS) (WHICH.IREGIONS MY.WINDOW 50 23) (WHICH.IREGIONS MY.WINDOW '(50 . 23)) Saving IRegions IREGIONS can be saved on a file by setting a variable to be the value returned by ALL.IREGIONS. This variable can be saved by using the file package command, UGLYVARS. Example: (SETQ IRS (ALL.IREGIONS (WHICHW))) (SETQ SAVEIRSCOMS '((UGLYVARS IRS))) (MAKEFILE 'SAVEIRS) The file SAVEIRS can be loaded and IRS will be set. You can then add IRS to a window by doing: (WINDOWPROP (WHICHW) 'IREGIONSLIST IRS) (WINDOWPROP (WHICHW) 'BUTTONEVENTFN 'IN.CURSOR.REGION) Caution: Some properties on the USERDATA field of an IREGION might not be saved correctly such as a window which can not be saved on a file. Window images can be saved on a file by creating a bitmap the same size as the window, BITBLT from the window to the bitmap, and then saving the bitmap with the file package command VARS. Example use of the AIRegions package: 1. Open a window...about 1/4 of a screen. 2. Use the paint function provided when you right-button in the window and paint a picture. qw˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙€Ŕ@ŕa€Ŕ@A€Ŕ @Ŕ€Ŕ@@€Ŕ@8.€ŔŔ@Ŕ€Ŕ +<@€Ŕ@€Ŕ@€Ŕ@€Ŕ˙˙˙˙˙˙˙˙˙˙˙€Ŕŕ€Ŕ €Ŕ €Ŕ A€Ŕ A€Ŕ A€Ŕ !€Ŕ@0™€Ŕ pĺ€Ŕ#€Ŕ4€Ŕ€Ŕ  €Ŕ €Ŕ€Ŕ€Ŕ€Ŕ€Ŕ€Ŕ€Ŕ€Ŕ€€Ŕ€€Ŕ€€Ŕ€€Ŕ€€Ŕ€€Ŕ€€Ŕ€€Ŕ@€Ŕ@€Ŕ €€Ŕ€€Ŕ€Ŕ€Ŕ€ €Ŕ€€Ŕ€€Ŕ=€€Ŕ_@€Ŕŕ €Ŕ €€ŔP@€Ŕh €Ŕ8€Ŕ `€Ŕ €Ŕ ˆ€Ŕƒ€Ŕ‚€˙˙€ŔD@€Ŕx €Ŕ€Ŕ€Ŕ€Ŕ q€Ŕ ‘€Ŕ€† €Ŕ€@/Č€Ŕ@ (€Ŕ@8€Ŕ  €Ŕ €Ŕ€Ŕ €Ŕ€ŔĐ€Ŕ0€Ŕ€Ŕ€Ŕ€Ŕ€Ŕ€Ŕ€Ŕ˙€Ŕ€€Ŕ@€Ŕ@€Ŕ>>€Ŕ€Ŕ€Ŕŕ€Ŕ€Ŕ@€Ŕ„  €ŔP €Ŕ( €Ŕ €Ŕ€Ŕ€€Ŕ€€Ŕŕ€Ŕżŕ €ŔŔ@€Ŕ@¸€Ŕ ‡€Ŕ ŕ€Ŕ €Ŕ €€ŔŔÁ€Ŕ`1€ŔX€€ŔFŔ€ŔA €Ŕ@ €˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ 3. With your mouse in this painted window, type in: (CREATEIR (WHICHW) 21930) 4. The cursor changes shape and prompts for creating a region similar to the prompt for creating a window. In this case, span a region that contains California. 5. When you are done, and the mouse button is released, the region spanned will remain temporarily on the screen. The cursor changes into a target and now prompts for a left-button within the region. Select somewhere in California. When done, left-button the mouse outside and away from the temporarily blocked off region. (If you want to continue selecting areas of the same irregular region, in this example, the upper left corner of California, then button that area within the squared off region. As you can see, your irregular region does not necessarily have to be connected). 6. To test it out, simply button anywhere in California and it will fill to a nice shade of grey, as we have just set it up to do: qw˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙€Ŕ@ŕa€Ŕ@A€Ŕ @Ŕ€Ŕ@@€Ŕ@8.€ŔŔ@Ŕ€Ŕ +<@€Ŕ@€Ŕ@€Ŕ@€Ŕ˙˙˙˙˙˙˙˙˙˙˙€ŔUőUP€ŔżŞŞ°€ŔŞŞŞ°€ŔuUUĐA€ŔuUWPA€ŔŞŞŞ°A€ŔŞŞş°!€ŔUuUP™€ŔUuuPĺ€ŔŞŤş°€ŔŞžŞ°€ŔU]UP€Ŕ UuUP €Ŕ +ŞŞŞ°€Ŕ +ŞşŞ°€Ŕ UUUP€Ŕ U]UP€ŔŞŞŞ°€ŔŞŞŞ°€ŔU]UP€ŔU]UP€ŔŞŽŞ°€ŔŞŽŞ°€ŔŐUUP€ŔŐUUP€ŔŞŽŞ°€ŔŞŽŞ¸€ŔŐWUX€ŔŐWUX€ŔjŞŞ¨€ŔjŤŞŹ€Ŕ5UŐV€ŔUŐU€Ŕ +ŞŞŞŔ€ŔŞŞŞ €ŔUŐUP€ŔUŐUX€ŔżŞŞŹ€Ŕßꪪ€ŔőuUV€ŔuUU€€ŔZşŞŞŔ€ŔjşŞŞ €Ŕ=UUUP€Ŕ5]UuX€Ŕ*ŽŞşŹ€Ŕ*ŞŞŞŞ€ŔW×UU€ŔU×UU€˙˙€ŔŞîŞŞŔ€ŔŞúŞŞ €ŔUUUUP€ŔUUUUX€ŔŞŞŞŞŹ€ŔŞŞŞŞŞ q€ŔUUUUW ‘€ŔUUUŐU€† €ŔŞŞŤęŞŔ/Č€ŔjŞŤúŞ  (€ŔUUUőUP8€Ŕ5UUýUX €Ŕ*ŞŤţި€ŔŞŤęŞŹ€Ŕ UUőUV€ŔUUuUU€ŔŞŞşŞŞĐ€ŔŞŞşŞŞ°€ŔUU]UUP€ŔUU]UUP€ŔŞŞŽŞŞ°€ŔŞŞŽŞŞ¨€ŔUUUUUX€ŔUUUUUT€Ŕ˙ŞŞŞŞŽ€ŔŞŞŞŞŤ€ŔUUUUV€ŔUUUUT€Ŕ>>ŞŞŞ¨€ŔŞŞŞ¨€ŔUUUX€ŔőUUX€ŔŞŞ¸€Ŕ +Şę°€Ŕ…Uľ`€ŔUU`€ŔŞŞ €ŔŞş €ŔUUP€ŔŐUX€ŔŞŞ¸€ŔŞżŕ€Ŕ˙ŕ €ŔŔ@€Ŕ@¸€Ŕ ‡€Ŕ ŕ€Ŕ €Ŕ €€ŔŔÁ€Ŕ`1€ŔX€€ŔFŔ€ŔA €Ŕ@ €˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ 7. To create more active irregularly shaped regions, follow steps 3 through 5 above. If you want to set the selection of one of the regions to activate the execution of some function that calls RINGBELLS, and have the region shade to black upon selection, type in the following in the top level typescript window keeping the mouse within the painted window. (CREATEIR (WHICHW) 65535 'IR.TESTFN) (DEFINEQ (IR.TESTFN (LAMBDA (WINDOW IREGION BUTTON) (If (EQ (QUOTE LEFT) BUTTON) then (RINGBELLS 2))))) Span the cursor out over another state/region and repeat steps 3-5 above. When you button in this IREGION, the IREGION will temporarily shade black, and call the RINGBELLS function. Note that like menu selection, the function is called only when you release the button within the region. If the mouse button is held down and you move over the created IREGIONs, they will shade and unshade as you enter and exit them. Note: if you wish to create your own shades but don't know what shades correspond to which numbers, call the function (EDITSHADE) and begin selecting points that you want shaded. When you are done, the function will return the appropriate shade number. You can also use 16x16 bitmaps for the shade of an IREGION (try (EDITBM (BITMAPCREATE 16 16))) DEMO PACKAGE: To run the demo package, load AIRegions-Demo. Intersecting Iregions 1. Create a window and paint in the following: ݒ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙řŔŔŔŔŔŔŔ˙ř˙˙Ŕ˙˙˙ŕ?˙˙üŔüţ˙€˙ŔŔ˙?ŔŕřŔđđ~~Ŕ€~đŔŔ~€ŔđŔđŕ>|ŔŔđxŔ<ŕ€ŔŔŔŔxđŔđŢxŔŔřŔ€řŔü€ŔŽŔŔ8ŕŔp€pŔŕŔ8ŔŔ8ŕŔ€ppŔ`0Ŕŕ8ŔŔ€Ŕ€ŔŔŔŔ8ŕŔp€pŔ` €0ŔŕŔ8ŔŔ8ŕŔ€0` Ŕ€ppŔ`0Ŕŕ8ŔŔŔŔŔŔ€Ŕ € €Ŕ€ŔŔŔŔŔŔ8ŕŔ0`Ŕ0`Ŕ0`Ŕp€pŔ` €0Ŕ` €0Ŕ` €0Ŕ` €0Ŕ` €0ŔŕŔ8ŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŔŕŔ8Ŕ` €0Ŕ` €0Ŕ` €0Ŕ` €0Ŕ` €0Ŕp€pŔ0`Ŕ0`Ŕ0`Ŕ8ŕŔŔŔŔŔ€ŔŔ € €ŔŔ€ŔŔŔŔŔŕ8Ŕ`0Ŕ€ppŔ€0` ŔŔ8ŕŔŕŔ8Ŕ` €0Ŕp€pŔ8ŕŔŔŔ€ŔŔŔ€Ŕŕ8Ŕ`0Ŕ€ppŔŔ8ŕŔŕŔ8Ŕp€pŔ8ŕŔŽŔŔü€Ŕ€řŔŔřŔđŢxŔxđŔŔŔŔ<ŕ€ŔŔđxŔđŕ>|Ŕ~€ŔđŔ€~đŔŔđđ~~Ŕ˙?ŔŕřŔüţ˙€˙ŔŔ˙˙˙ŕ?˙˙üŔ˙ř˙˙ŔŔŔŔŔŔŔŔŔŔŔŔŔŔ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř 2. Now call CREATEIR passing in this window and a shade of 4747 and surround the left circle and select inside that circle and also in the intersecting area for the area fill. Repeat this for the right circle but use a different shade (say 42405). 3. Now, with your mouse in the window, call the function (INTERSECTING.IREGIONS? (WHICHW) T). When you button in the intersection of the two circles, you should get: ݒ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙řŔŔŔŔŔŔŔ˙ř˙˙Ŕ˙˙˙ŕ?˙˙üŔţ"/ţ˙ŐU˙ŔŔ˙ˆˆˆżŔꪪŻřŔűťťťťđUUUU~Ŕ‘~úŞŞŞŞŻŔŔ~"""""?€ŐUUUUWđŔřˆˆˆˆˆ‹ŕ>ŞŞŞŞŞŞüŔűťťťťťťđ}UUUUUU^Ŕ<ęŞŞŞŞŞŞŻ€Ŕ""""""">ŐUUUUUUWŔŔxˆˆˆˆˆˆˆŞŞŞŞŞŞŞŞđŔűťťťťťťťťßUUUUUUUUxŔŃúŞŞŞŞŞŞŞŞźŔ˘""""""""ýUUUUUUUU_Ŕˆˆˆˆˆˆˆˆ‰ţŞŞŞŞŞŞŞŞŻ€ŔťťťťťťťťťďUUUUUUUUUŔŔ9żŞŞŞŞŞŞŞŞŞŕŔr""""""""/wŐUUUUUUUUpŔ興ˆˆˆˆˆˆž#ęŞŞŞŞŞŞŞŞ¸ŔűťťťťťťťťžîőUUUUUUUU\Ŕ‘{ťúŞŞŞŞŞŞŞŞŽŔ"""""""""wwuUUUUUUUUVŔˆˆˆˆˆˆˆˆˆâ":ŞŞŞŞŞŞŞŞŻŔťťťťťťťťťîîýUUUUUUUUW€ŔťťžŞŞŞŞŞŞŞŞŤŔŔ""""""""#wwwUUUUUUUUUŔŔ8ˆˆˆˆˆˆˆˆ""'ŞŞŞŞŞŞŞŞŞŕŔ{ťťťťťťťťžîîďŐUUUUUUUUpŔqťťťŞŞŞŞŞŞŞŞŞ°Ŕâ""""""""?wwwŐUUUUUUUUxŔȈˆˆˆˆˆˆˆş"""ęŞŞŞŞŞŞŞŞźŔťťťťťťťťťžîîîőUUUUUUUU\Ŕ‘{ťťťúŞŞŞŞŞŞŞŞŽŔ"""""""""wwwwuUUUUUUUUVŔˆˆˆˆˆˆˆˆˆâ""":ŞŞŞŞŞŞŞŞŻŔťťťťťťťťťîîîîýUUUUUUUUWŔűťťťşŞŞŞŞŞŞŞŞŤŔ""""""""#÷www}UUUUUUUUW€Ŕ ˆˆˆˆˆˆˆˆ‰˘""".ŞŞŞŞŞŞŞŞŤ€ŔťťťťťťťťťîîîîďUUUUUUUUUŔŔťťťťžŞŞŞŞŞŞŞŞŞŔŔ""""""""#wwwwwUUUUUUUUUŔŔ8ˆˆˆˆˆˆˆˆ""""'ŞŞŞŞŞŞŞŞŞŕŔ;ťťťťťťťťžîîîîďUUUUUUUUU`Ŕ1ťťťťťŞŞŞŞŞŞŞŞŞŕŔ2""""""""'wwwwwUUUUUUUUU`ŔxˆˆˆˆˆˆˆˆŽ""""#ŞŞŞŞŞŞŞŞŞđŔ{ťťťťťťťťžîîîîďŐUUUUUUUUpŔqťťťťťŞŞŞŞŞŞŞŞŞ°Ŕb""""""""/wwwwwŐUUUUUUUUpŔhˆˆˆˆˆˆˆˆŽ""""#ŞŞŞŞŞŞŞŞŞ°Ŕ{ťťťťťťťťžîîîîďŐUUUUUUUUpŔńťťťťťęŞŞŞŞŞŞŞŞ¸Ŕâ""""""""?wwwwwŐUUUUUUUUXŔȈˆˆˆˆˆˆˆš"""""ęŞŞŞŞŞŞŞŞ¸ŔűťťťťťťťťžîîîîîŐUUUUUUUUXŔŃťťťťťęŞŞŞŞŞŞŞŞ¸Ŕâ""""""""?wwwwwŐUUUUUUUUXŔȈˆˆˆˆˆˆˆš"""""ęŞŞŞŞŞŞŞŞ¸ŔűťťťťťťťťžîîîîîŐUUUUUUUUXŔŃťťťťťęŞŞŞŞŞŞŞŞ¸Ŕâ""""""""?wwwwwŐUUUUUUUUXŔȈˆˆˆˆˆˆˆš"""""ęŞŞŞŞŞŞŞŞ¸ŔűťťťťťťťťžîîîîîŐUUUUUUUUXŔŃťťťťťęŞŞŞŞŞŞŞŞ¸Ŕâ""""""""?wwwwwŐUUUUUUUUXŔȈˆˆˆˆˆˆˆš"""""ęŞŞŞŞŞŞŞŞ¸ŔűťťťťťťťťžîîîîďŐUUUUUUUUxŔqťťťťťŞŞŞŞŞŞŞŞŞ°Ŕb""""""""/wwwwwŐUUUUUUUUpŔhˆˆˆˆˆˆˆˆŽ""""#ŞŞŞŞŞŞŞŞŞ°Ŕ{ťťťťťťťťžîîîîďŐUUUUUUUUpŔqťťťťťŞŞŞŞŞŞŞŞŞ°Ŕr""""""""/wwwwwŐUUUUUUUUpŔ8ˆˆˆˆˆˆˆˆŽ""""#ŞŞŞŞŞŞŞŞŞŕŔ;ťťťťťťťťžîîîîďUUUUUUUUU`Ŕ1ťťťťťŞŞŞŞŞŞŞŞŞŕŔ:""""""""'wwwwwUUUUUUUUUŕŔˆˆˆˆˆˆˆˆ‹""""&ŞŞŞŞŞŞŞŞŞŔŔťťťťťťťťťîîîîďUUUUUUUUUŔŔťťťťžŞŞŞŞŞŞŞŞŤŔŔ""""""""#÷www}UUUUUUUUU€Ŕˆˆˆˆˆˆˆˆ‰â""">ŞŞŞŞŞŞŞŞŤ€ŔťťťťťťťťťîîîîýUUUUUUUUWŔűťťťşŞŞŞŞŞŞŞŞŤŔ"""""""""÷www}UUUUUUUUWŔˆˆˆˆˆˆˆˆˆâ""":ŞŞŞŞŞŞŞŞŽŔťťťťťťťťťţîîîőUUUUUUUU^Ŕ‘;ťťťęŞŞŞŞŞŞŞŞŹŔâ""""""""?wwwőUUUUUUUU\Ŕ興ˆˆˆˆˆˆž""#ęŞŞŞŞŞŞŞŞ¸Ŕ{ťťťťťťťťžîîďŐUUUUUUUUpŔqťťťŞŞŞŞŞŞŞŞŞđŔ:""""""""'wwwUUUUUUUUUŕŔˆˆˆˆˆˆˆˆ‹""&ŞŞŞŞŞŞŞŞŞŔŔťťťťťťťťťîîďUUUUUUUUUŔŔűťžŞŞŞŞŞŞŞŞŤ€Ŕ"""""""""÷w}UUUUUUUUWŔˆˆˆˆˆˆˆˆˆâ":ŞŞŞŞŞŞŞŞŽŔťťťťťťťťťţîőUUUUUUUU^ŔŃ;ťęŞŞŞŞŞŞŞŞźŔâ""""""""?wŐUUUUUUUUxŔxˆˆˆˆˆˆˆˆŽ#ŞŞŞŞŞŞŞŞŞđŔ;ťťťťťťťťżďUUUUUUUUUŕŔžŞŞŞŞŞŞŞŞŤŔŔ""""""""#ýUUUUUUUUW€ŔˆˆˆˆˆˆˆˆˆúŞŞŞŞŞŞŞŞŻŔűťťťťťťťťýUUUUUUUU\ŔńŢŞŞŞŞŞŞŞŞřŔz"""""""'UUUUUUUUđŔˆˆˆˆˆˆˆžęŞŞŞŞŞŞŤŔŔťťťťťťťźőUUUUUUW€ŔŃđzŞŞŞŞŞŞžŔň"""""#ŕ?UUUUUU|Ŕ~ˆˆˆˆˆŸ€ęŞŞŞŞŤđŔťťťťťţőUUUU_ŔŔńđ~ŞŞŞŞţŔ˙"""?ŔőUUWřŔüˆţ˙ŞŤ˙ŔŔ˙˙˙ŕ?˙˙üŔ˙ř˙˙ŔŔŔŔŔŔŔŔŔŔŔŔŔŔ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř 4. When the mouse is released inside of the intersecting region, both IREGIONs BUTTONEVENTFN will be called. Comments and suggestions are welcome. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 11) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))),Č, Č- ČT, Č,Ú,66ě- ČT, Č, Č, Č3ČČT2ČČ-T- ČT3ČČT, Č, Č,HHÚ,,,Č, ě,,,ŠŠ8,Č ,ŠŠ8HČČ PAGEHEADING RUNNINGHEADCLASSICCLASSICCLASSICMODERN +TERMINAL + +TIMESROMAN €MODERN +€GACHA ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +TERMINAL + HELVETICA +MODERN +MODERN +MODERN MODERNMODERN + +  HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN + + HRULE.GETFNMODERN  HRULE.GETFNMODERN +%  ' 6"    Č   Ĺ  f    ţ  + 4   +7  +[ +  +Ń  + i  +/ ( @   +K h R    ’ a % ;  A +l + 8   +7  +[ +  +Ń  + i  +0  +  + o 0   –  C +y +    1  $  b        %   Í   +      ş 3˝ M      ?     %   $  Ą    *  \           3  +       (   /  >  +  !   [ â   %  M :  D  = /   @ +F +   +)  +2  +K )  *  Š    ++ 3  +  t  :      +$ +( +  ¨   # +% + +_  +( +7 +… ź  &  *  \ | BMOBJ.GETFN3MODERN + 4  +Ą J ƒ | BMOBJ.GETFN3MODERN +i  % + +5 + + + + ¤  ]  <    /   BMOBJ.GETFN3MODERN +ř Ś   BMOBJ.GETFN3?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +  l   & uŕzş \ No newline at end of file diff --git a/lispusers/AISBLT b/lispusers/AISBLT new file mode 100644 index 00000000..1c7f79f0 --- /dev/null +++ b/lispusers/AISBLT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "11-Nov-88 14:17:22" {ERINYES}LYRIC>AISBLT.\;1 35120 |previous| |date:| "23-Sep-88 20:28:25" {PHYLUM}MEDLEY>AISBLT.\;1) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT AISBLTCOMS) (RPAQQ AISBLTCOMS ((* |;;| "") (* |;;| "The AISBLT module") (* |;;| "") (* |;;| "The exported interface is via the following functions") (FNS AISBLT.BITMAP AISFILEHEADER WRITEAIS) (* |;;| "Internal functions") (FNS AISBLT1TO1.BITMAP AISBLT8TO1FSA.BITMAP AISBLT8TO8.BITMAP AISBLTNTO1FSA.BITMAP AISBLTNTO1TRUNCATE.BITMAP SETUPPILOTBBT) (* |;;| "Useful constants") (COMS (* \; "AIS file identifying word") (VARIABLES AIS-PASSWORD)) (COMS (* \; "Attribute part header types") (VARIABLES AIS-RASTER-TYPE AIS-PLACEMENT-TYPE AIS-PHOTOMETRY-TYPE AIS-COMMENT-TYPE)) (COMS (* \; "Raster coding types") (VARIABLES AIS-RASTER-CODING-UCA AIS-RASTER-CODING-CA)) (COMS (* \; "Photometry sense ") (VARIABLES AIS-PHOTOMETRY-SENSE-LARGER-DARKER AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER)) (COMS (* \; "Photometry signal ") (VARIABLES AIS-PHOTOMETRY-SIGNAL-BLACK-AND-WHITE AIS-PHOTOMETRY-SIGNAL-RED-SEPARATION AIS-PHOTOMETRY-SIGNAL-BLUE-SEPARATION AIS-PHOTOMETRY-SIGNAL-GREEN-SEPARATION AIS-PHOTOMETRY-SIGNAL-CYAN-SEPARATION AIS-PHOTOMETRY-SIGNAL-MAGENTA-SEPARATION AIS-PHOTOMETRY-SIGNAL-YELLOW-SEPARATION AIS-PHOTOMETRY-SIGNAL-X-CIE AIS-PHOTOMETRY-SIGNAL-Y-CIE AIS-PHOTOMETRY-SIGNAL-IN-COMMENT AIS-PHOTOMETRY-SIGNAL-UNSPECIFIED)) (COMS (* \; "Photometry spot type") (VARIABLES AIS-PHOTOMETRY-SPOT-TYPE-RECTANGULAR AIS-PHOTOMETRY-SPOT-TYPE-CIRCULAR AIS-PHOTOMETRY-SPOT-TYPE-IN-COMMENTS AIS-PHOTOMETRY-SPOT-TYPE-UNSPECIFIED)) (COMS (* \; "Photometry scale") (VARIABLES AIS-PHOTOMETRY-SCALE-RELECTANCE-TRANSMITTANCE AIS-PHOTOMETRY-SCALE-OPTICAL-DENSITY AIS-PHOTOMETRY-SCALE-IN-COMMENT AIS-PHOTOMETRY-SCALE-UNSPECIFIED)) (COMS (* \; "Photometry") (VARIABLES AIS-PHOTOMETRY-UNSPECIFIED)) (COMS (* \; "Header information when writing AIS format") (VARIABLES AIS-DEFAULT-HEADER-LENGTH)))) (* |;;| "") (* |;;| "The AISBLT module") (* |;;| "") (* |;;| "The exported interface is via the following functions") (DEFINEQ (AISBLT.BITMAP (LAMBDA (FILE SOURCE-LEFT SOURCE-BOTTOM DESTINATION DESTINATION-LEFT DESTINATION-BOTTOM WIDTH HEIGHT HOW FILTER) (* \; "Edited 23-Sep-88 19:48 by Briggs") (* \; "Edited 2-May-88 16:51 by Briggs") (* \; "Edited 2-May-88 16:06 by Briggs") (* |;;;| "Puts an AIS image from a file onto the destination, which may be a bitmap, or a window/imagestream. ") (* |;;;| "The arguments are the same as BITBLTs for the most part.") (* |;;| "HOW specifies how the number of bits per pixel is condensed if reduction is necessary: TRUNCATE is truncate; FSA is Floyd-Steinberg algorithm; MODULATE is modulated with a random function") (RESETLST (PROG (AIS-HEADER RASTER-PART PHOTOMETRY-PART PHOTOMETRY-SENSE CLIP-BOTTOM CLIP-HEIGHT CLIP-LEFT CLIP-RIGHT CLIP-TOP CLIP-WIDTH DESTINATION-BASE DESTINATION-BITS-PER-PIXEL DESTINATION-RASTER-WIDTH DESTINATION-WIDTH S-TO-D-X S-TO-D-Y SCAN-DIRECTION SOURCE-BITS-PER-PIXEL SOURCE-HEIGHT SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH SOURCE-WIDTH STREAM) (* |;;| "check and default some of the parameters") (OR (TYPEP DESTINATION (QUOTE BITMAP)) (\\ILLEGAL.ARG DESTINATION)) (OR SOURCE-LEFT (SETQ SOURCE-LEFT 0)) (OR SOURCE-BOTTOM (SETQ SOURCE-BOTTOM 0)) (OR DESTINATION-LEFT (SETQ DESTINATION-LEFT 0)) (OR DESTINATION-BOTTOM (SETQ DESTINATION-BOTTOM 0)) (OR HOW (SETQ HOW (QUOTE FSA))) (* |;;| "find the file, and get the AIS image parameters") (COND ((STREAMP FILE) (SETQ STREAM FILE)) ((SETQ STREAM (FINDFILE FILE T AISDIRECTORIES)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ STREAM (OPENSTREAM STREAM (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (T (ERROR "Can't find file" FILE))) (* |;;| "interesting point here -- INSUREAISFILE should probably also check for Photometry information and indicate whether the sense of the samples is increasing values implies increasing lightness or the other way around. Currently, for the 1 bpp case we invert the bitmap so that it displays correctly on the screen.") (SETQ AIS-HEADER (AISFILEHEADER STREAM)) (SETQ RASTER-PART (CADR (ASSOC :RASTER AIS-HEADER))) (* |;;| "dispose of some of the cases we can't handle") (COND ((NOT (EQ (LISTGET RASTER-PART :CODING-TYPE) AIS-RASTER-CODING-UCA)) (ERROR "Can't AISBLT AIS files of raster coding type" (LISTGET RASTER-PART :CODING-TYPE)))) (* |;;| "extract the information we need from the raster attribute") (SETQ SOURCE-BITS-PER-PIXEL (LISTGET RASTER-PART :BITS-PER-SAMPLE)) (SETQ SOURCE-WIDTH (LISTGET RASTER-PART :SCAN-LENGTH)) (SETQ SOURCE-HEIGHT (LISTGET RASTER-PART :SCAN-COUNT)) (SETQ SOURCE-RASTER-WIDTH (LISTGET RASTER-PART :WORDS-PER-SCAN-LINE)) (SETQ SCAN-DIRECTION (LISTGET RASTER-PART :SCAN-DIRECTION)) (* |;;| "Dispose of another case we don't want to handle right now") (COND ((NOT (EQ SCAN-DIRECTION 3)) (ERROR "Scan direction is not top-left to bottom-right(3) - " SCAN-DIRECTION))) (* |;;| "extract the information we need from the photometry part") (SETQ PHOTOMETRY-PART (CADR (ASSOC :PHOTOMETRY AIS-HEADER))) (* |;;| "the photometry sense will indicate whether we need to invert the bitmap to get it into Lisp's 0->white 1-> black sense (larger darker).") (SETQ PHOTOMETRY-SENSE (OR (LISTGET PHOTOMETRY-PART :SENSE) (COND ((EQ SOURCE-BITS-PER-PIXEL 0) (* |;;| "this is a gross kludge by Cedar to avoid specifying the photometry information") (SETQ SOURCE-BITS-PER-PIXEL 1) AIS-PHOTOMETRY-SENSE-LARGER-DARKER) (T AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER)))) (* |;;| "calculate some additional destination information") (SETQ DESTINATION-WIDTH (|fetch| (BITMAP BITMAPWIDTH) |of| DESTINATION)) (SETQ DESTINATION-RASTER-WIDTH (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| DESTINATION)) (SETQ DESTINATION-BITS-PER-PIXEL (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| DESTINATION)) (SETQ DESTINATION-BASE (|fetch| (BITMAP BITMAPBASE) |of| DESTINATION)) (* |;;| "clipping region is initially all of the destination. Clipping coordinates are *inclusive* left and bottom, exclusive right and top -- origin 0.") (SETQ CLIP-LEFT 0) (SETQ CLIP-BOTTOM 0) (SETQ CLIP-RIGHT DESTINATION-WIDTH) (SETQ CLIP-TOP (|fetch| (BITMAP BITMAPHEIGHT) |of| DESTINATION)) (* |;;| "reduce the region if required by specified destination left, bottom, width, or height") (SETQ CLIP-LEFT (IMAX CLIP-LEFT DESTINATION-LEFT)) (SETQ CLIP-BOTTOM (IMAX CLIP-BOTTOM DESTINATION-BOTTOM)) (COND (WIDTH (SETQ CLIP-RIGHT (IMIN (IPLUS DESTINATION-LEFT WIDTH) CLIP-RIGHT)))) (COND (HEIGHT (SETQ CLIP-TOP (IMIN (IPLUS DESTINATION-BOTTOM HEIGHT) CLIP-TOP)))) (* |;;| "") (SETQ S-TO-D-X (IDIFFERENCE DESTINATION-LEFT SOURCE-LEFT)) (SETQ S-TO-D-Y (IDIFFERENCE DESTINATION-BOTTOM SOURCE-BOTTOM)) (* |;;| "reduce the region if required by source size. We know source origin is (0,0)") (SETQ CLIP-LEFT (IMAX S-TO-D-X CLIP-LEFT)) (* \; "was 0") (SETQ CLIP-BOTTOM (IMAX S-TO-D-Y CLIP-BOTTOM)) (* \; "was 0") (SETQ CLIP-RIGHT (IMIN (IPLUS S-TO-D-X SOURCE-WIDTH) CLIP-RIGHT)) (SETQ CLIP-TOP (IMIN (IPLUS S-TO-D-Y SOURCE-HEIGHT) CLIP-TOP)) (* |;;| "calculate width and height of clipped region") (SETQ CLIP-WIDTH (IDIFFERENCE CLIP-RIGHT CLIP-LEFT)) (SETQ CLIP-HEIGHT (IDIFFERENCE CLIP-TOP CLIP-BOTTOM)) (COND ((OR (ILEQ CLIP-WIDTH 0) (ILEQ CLIP-HEIGHT 0)) (* \; "nothing to do") (RETURN))) (* |;;| "\"align\" the source file and destination base so that we need only pass in pixel offsets, width, and height") (SETQ DESTINATION-BASE (\\ADDBASE DESTINATION-BASE (ITIMES DESTINATION-RASTER-WIDTH (|\\SFInvert| DESTINATION CLIP-TOP)))) (\\SETFILEPTR STREAM (IPLUS (\\GETFILEPTR STREAM) (ITIMES SOURCE-RASTER-WIDTH BYTESPERWORD (- SOURCE-HEIGHT (- CLIP-TOP S-TO-D-Y))))) (SETQ SOURCE-PIXEL-OFFSET (- CLIP-LEFT S-TO-D-X)) (* |;;| "") (SELECTQ SOURCE-BITS-PER-PIXEL (8 (SELECTQ DESTINATION-BITS-PER-PIXEL (8 (AISBLT8TO8.BITMAP STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE CLIP-LEFT DESTINATION-RASTER-WIDTH DESTINATION-WIDTH CLIP-WIDTH CLIP-HEIGHT)) (1 (SELECTQ HOW ((FSA :FSA) (AISBLT8TO1FSA.BITMAP STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE CLIP-LEFT DESTINATION-RASTER-WIDTH DESTINATION-WIDTH CLIP-WIDTH CLIP-HEIGHT PHOTOMETRY-SENSE)) ((TRUNCATE :TRUNCATE) (AISBLTNTO1TRUNCATE.BITMAP STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE CLIP-LEFT DESTINATION-RASTER-WIDTH DESTINATION-WIDTH CLIP-WIDTH CLIP-HEIGHT SOURCE-BITS-PER-PIXEL PHOTOMETRY-SENSE)) NIL)) NIL)) (4 (SELECTQ DESTINATION-BITS-PER-PIXEL (1 (SELECTQ HOW ((FSA :FSA) (AISBLTNTO1FSA.BITMAP STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE CLIP-LEFT DESTINATION-RASTER-WIDTH DESTINATION-WIDTH CLIP-WIDTH CLIP-HEIGHT SOURCE-BITS-PER-PIXEL PHOTOMETRY-SENSE)) ((TRUNCATE :TRUNCATE) (AISBLTNTO1TRUNCATE.BITMAP STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE CLIP-LEFT DESTINATION-RASTER-WIDTH DESTINATION-WIDTH CLIP-WIDTH CLIP-HEIGHT SOURCE-BITS-PER-PIXEL PHOTOMETRY-SENSE)) NIL)) NIL)) (1 (SELECTQ DESTINATION-BITS-PER-PIXEL (1 (AISBLT1TO1.BITMAP STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE CLIP-LEFT DESTINATION-RASTER-WIDTH DESTINATION-WIDTH CLIP-WIDTH CLIP-HEIGHT PHOTOMETRY-SENSE)) NIL)) NIL)))) ) (AISFILEHEADER (LAMBDA (STREAM) (* \; "Edited 21-Sep-88 19:05 by Briggs") (* |;;| "make sure a file is an ais file and put fileptr at beginning of data.") (* |;;| "returns a property list format description of the file format") (LET (HEADERLENGTH ATTRIBUTE-PART-HEADER ATTRIBUTE-FILE-POINTER SCRATCH CODING-TYPE) (\\SETFILEPTR STREAM 0) (|if| (NEQ (\\WIN STREAM) AIS-PASSWORD) |then| (* \; "not an AIS file") NIL |else| (SETQ HEADERLENGTH (ITIMES (\\WIN STREAM) BYTESPERWORD)) (* \; "length in bytes ") (PROG1 (|while| (AND (< (\\GETFILEPTR STREAM) HEADERLENGTH) (NOT (EQ 0 (SETQ ATTRIBUTE-PART-HEADER (\\WIN STREAM))))) |collect| (SETQ ATTRIBUTE-FILE-POINTER (\\GETFILEPTR STREAM)) (PROG1 (SELECTC (LRSH ATTRIBUTE-PART-HEADER 10) (AIS-RASTER-TYPE (* |;;| "The raster part of an AIS file is mandatory") (SETQ SCRATCH (LIST :SCAN-COUNT (\\WIN STREAM) :SCAN-LENGTH (\\WIN STREAM) :SCAN-DIRECTION (\\WIN STREAM) :SAMPLES-PER-PIXEL (\\WIN STREAM) :CODING-TYPE (SETQ CODING-TYPE (\\WIN STREAM)))) (* |;;| "UnCompressedArray is the only known coding type") (SELECTC CODING-TYPE (AIS-RASTER-CODING-UCA (LISTPUT SCRATCH :BITS-PER-SAMPLE (\\WIN STREAM)) (LISTPUT SCRATCH :WORDS-PER-SCAN-LINE (\\WIN STREAM)) (LISTPUT SCRATCH :SCAN-LINES-PER-BLOCK (SIGNED (\\WIN STREAM) BITSPERWORD)) (LISTPUT SCRATCH :PADDING-PER-BLOCK (SIGNED (\\WIN STREAM) BITSPERWORD))) NIL) (LIST :RASTER SCRATCH)) (AIS-PLACEMENT-TYPE (LIST :PLACEMENT (LIST :LEFT (\\WIN STREAM) :BOTTOM (\\WIN STREAM) :WIDTH (\\WIN STREAM) :HEIGHT (\\WIN STREAM)))) (AIS-PHOTOMETRY-TYPE (* |;;| "Ignoring the optional photometry histogram data") (LIST :PHOTOMETRY (LIST :SIGNAL (\\WIN STREAM) :SENSE (\\WIN STREAM) :SCALE (\\WIN STREAM) :SCALE-A (CONS (SIGNED (\\WIN STREAM) BITSPERWORD) (SIGNED (\\WIN STREAM) BITSPERWORD)) :SCALE-B (CONS (SIGNED (\\WIN STREAM) BITSPERWORD) (SIGNED (\\WIN STREAM) BITSPERWORD)) :SCALE-C (CONS (SIGNED (\\WIN STREAM) BITSPERWORD) (SIGNED (\\WIN STREAM) BITSPERWORD)) :SPOT-TYPE (SIGNED (\\WIN STREAM) BITSPERWORD) :SPOT-WIDTH (SIGNED (\\WIN STREAM) BITSPERWORD) :SPOT-LENGTH (SIGNED (\\WIN STREAM) BITSPERWORD) :SAMPLE-MIN (\\WIN STREAM) :SAMPLE-MAX (\\WIN STREAM)))) (AIS-COMMENT-TYPE (* |;;| "(SETQ SCRATCH (ALLOCSTRING (\\BIN STREAM))) (LIST :COMMENT (AIN SCRATCH 0 (NCHARS SCRATCH)))") NIL) NIL) (\\SETFILEPTR STREAM (PLUS ATTRIBUTE-FILE-POINTER (ITIMES (SUB1 (LOGAND ATTRIBUTE-PART-HEADER 1023)) BYTESPERWORD))))) (\\SETFILEPTR STREAM HEADERLENGTH))))) ) (WRITEAIS (LAMBDA (BITMAP FILE REGION) (* \; "Edited 21-Sep-88 18:34 by Briggs") (* |;;;| "writes a bitmap on to a file in AIS format.") (* |;;| "simple checks on the arguments before we proceed") (OR (TYPEP BITMAP (QUOTE BITMAP)) (\\ILLEGAL.ARG BITMAP)) (OR (AND REGION (REGIONP REGION)) (AND REGION (\\ILLEGAL.ARG REGION))) (PROG (STREAM TEMP-BITMAP BITSPERPIXEL RASTERWIDTH WIDTH HEIGHT) (SETQ BITSPERPIXEL (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| BITMAP)) (COND ((REGIONP REGION) (* |;;| "Get copy of selected REGION of BITMAP into temporary bitmap to avoid having to deal with odd boundary problems when writing contents of BITMAP to STREAM *") (SETQ TEMP-BITMAP (BITMAPCREATE (|fetch| (REGION WIDTH) |of| REGION) (|fetch| (REGION HEIGHT) |of| REGION) BITSPERPIXEL)) (BITBLT BITMAP (|fetch| (REGION LEFT) |of| REGION) (|fetch| (REGION BOTTOM) |of| REGION) TEMP-BITMAP) (SETQ BITMAP TEMP-BITMAP))) (SETQ RASTERWIDTH (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| BITMAP)) (SETQ HEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| BITMAP)) (SETQ WIDTH (|fetch| (BITMAP BITMAPWIDTH) |of| BITMAP)) (SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT))) (\\WOUT STREAM AIS-PASSWORD) (* \; "write AIS password") (\\WOUT STREAM (FOLDLO AIS-DEFAULT-HEADER-LENGTH BYTESPERWORD)) (* |;;| "Generate raster part") (\\WOUT STREAM (LOGOR (LLSH AIS-RASTER-TYPE 10) 10)) (* \; "set type and length of raster part header") (\\WOUT STREAM HEIGHT) (* \; "Scan count") (\\WOUT STREAM WIDTH) (* \; "ScanLength") (\\WOUT STREAM 3) (* \; "Scan Dir") (\\WOUT STREAM 1) (* \; "samples per pixel.") (\\WOUT STREAM 1) (* \; "coding type: UnCompressedArray") (\\WOUT STREAM BITSPERPIXEL) (* \; "bits per sample") (\\WOUT STREAM RASTERWIDTH) (* \; "words per sample line.") (\\WOUT STREAM (UNSIGNED -1 16)) (* \; "Sample lines per block: no blocks is 16 bit -1") (\\WOUT STREAM (UNSIGNED -1 16)) (* \; "padding words per block: no blocks is 16 bit -1") (* |;;| "Generate photometry part") (\\WOUT STREAM (LOGOR (LLSH AIS-PHOTOMETRY-TYPE 10) 16)) (\\WOUT STREAM AIS-PHOTOMETRY-SIGNAL-BLACK-AND-WHITE) (\\WOUT STREAM AIS-PHOTOMETRY-SENSE-LARGER-DARKER) (\\WOUT STREAM AIS-PHOTOMETRY-SCALE-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-SPOT-TYPE-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM AIS-PHOTOMETRY-UNSPECIFIED) (\\WOUT STREAM 0) (* \; "sample min") (\\WOUT STREAM 1) (* \; "sample max") (\\WOUT STREAM 0) (* \; "no histogram") (* |;;| "position to start of data") (\\SETFILEPTR STREAM AIS-DEFAULT-HEADER-LENGTH) (\\BOUTS STREAM (|fetch| (BITMAP BITMAPBASE) |of| BITMAP) 0 (ITIMES HEIGHT RASTERWIDTH BYTESPERWORD)) (RETURN (CLOSEF STREAM)))) ) ) (* |;;| "Internal functions") (DEFINEQ (AISBLT1TO1.BITMAP (LAMBDA (STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE DESTINATION-PIXEL-OFFSET DESTINATION-RASTER-WIDTH DESTINATION-WIDTH WIDTH HEIGHT PHOTOMETRY-SENSE) (* \; "Edited 22-Sep-88 10:58 by Briggs") (* |;;;| "Internal function called by AISBLT.BITMAP to move 1 bpp source file to 1 bpp bitmap") (LET ((SOURCE-BYTES-PER-LINE (ITIMES SOURCE-RASTER-WIDTH 2)) (DESTINATION-BYTE-OFFSET) (WIDTH-BYTES) (PILOT-BBT (|create| PILOTBBT)) (SCRATCH-BITMAP) (SCRATCH-BITMAP-BASE)) (* |;;| "look for some special cases that we can handle much faster") (COND ((AND (EQ SOURCE-RASTER-WIDTH DESTINATION-RASTER-WIDTH) (EQ SOURCE-PIXEL-OFFSET 0) (EQ DESTINATION-PIXEL-OFFSET 0) (EQ WIDTH DESTINATION-WIDTH)) (* |;;| "source and destination have same raster width") (* |;;| "and the full scan line is being being moved to the full destination scan line") (\\BINS STREAM DESTINATION-BASE 0 (ITIMES HEIGHT SOURCE-BYTES-PER-LINE))) ((AND (EQ (IMOD SOURCE-PIXEL-OFFSET BITSPERBYTE) 0) (EQ (IMOD DESTINATION-PIXEL-OFFSET BITSPERBYTE) 0) (OR (EQ (IMOD WIDTH BITSPERBYTE) 0) (EQ WIDTH DESTINATION-WIDTH))) (* |;;| "Pixel offsets give byte alignment, and the width is an integral number of bytes, or is the destination width (we can run into the slack bits in the last word with no problem)") (SETQ DESTINATION-BYTE-OFFSET (FOLDHI DESTINATION-PIXEL-OFFSET BITSPERBYTE)) (SETQ WIDTH-BYTES (FOLDHI WIDTH BITSPERBYTE)) (|for| ROW |from| 1 |to| HEIGHT |as| FILE-POINTER |from| (IPLUS (FOLDHI SOURCE-PIXEL-OFFSET BITSPERBYTE) (\\GETFILEPTR STREAM)) |by| SOURCE-BYTES-PER-LINE |bind| (LINE-BASE _ DESTINATION-BASE) |do| (\\SETFILEPTR STREAM FILE-POINTER) (\\BINS STREAM LINE-BASE DESTINATION-BYTE-OFFSET WIDTH-BYTES) (COND ((NOT (EQ ROW HEIGHT)) (SETQ LINE-BASE (\\ADDBASE LINE-BASE DESTINATION-RASTER-WIDTH)))))) (T (* |;;| "We have to do bit level realignment -- use a temporary bitmap and let Pilot bitblt deal with it") (SETQ SCRATCH-BITMAP (BITMAPCREATE WIDTH 1 1)) (SETQ SCRATCH-BITMAP-BASE (|fetch| (BITMAP BITMAPBASE) |of| SCRATCH-BITMAP)) (SETUPPILOTBBT PILOT-BBT (|fetch| (BITMAP BITMAPBASE) |of| SCRATCH-BITMAP) 0 (UNFOLD (FOLDHI WIDTH BITSPERWORD) BITSPERWORD) DESTINATION-BASE DESTINATION-PIXEL-OFFSET (UNFOLD DESTINATION-RASTER-WIDTH BITSPERWORD) WIDTH 1 0 T T (QUOTE INPUT) (QUOTE REPLACE)) (SETQ WIDTH-BYTES (FOLDHI WIDTH BITSPERBYTE)) (|for| ROW |from| 1 |to| HEIGHT |as| FILE-POINTER |from| (IPLUS (FOLDHI SOURCE-PIXEL-OFFSET BITSPERBYTE) (\\GETFILEPTR STREAM)) |by| SOURCE-BYTES-PER-LINE |bind| (LINE-BASE _ DESTINATION-BASE) |do| (\\SETFILEPTR STREAM FILE-POINTER) (\\BINS STREAM SCRATCH-BITMAP-BASE 0 WIDTH-BYTES) (\\PILOTBITBLT PILOT-BBT NIL) (COND ((NOT (EQ ROW HEIGHT)) (|freplace| (PILOTBBT PBTDEST) |of| PILOT-BBT |with| (SETQ LINE-BASE (\\ADDBASE LINE-BASE DESTINATION-RASTER-WIDTH)))))))) (|if| (EQ PHOTOMETRY-SENSE AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER) |then| (SETUPPILOTBBT PILOT-BBT DESTINATION-BASE DESTINATION-PIXEL-OFFSET (UNFOLD DESTINATION-RASTER-WIDTH BITSPERWORD) DESTINATION-BASE DESTINATION-PIXEL-OFFSET (UNFOLD DESTINATION-RASTER-WIDTH BITSPERWORD) WIDTH HEIGHT 0 NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) (\\PILOTBITBLT PILOT-BBT NIL)))) ) (AISBLT8TO1FSA.BITMAP (LAMBDA (STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE DESTINATION-PIXEL-OFFSET DESTINATION-RASTER-WIDTH DESTINATION-WIDTH WIDTH HEIGHT PHOTOMETRY-SENSE) (* \; "Edited 23-Sep-88 20:01 by Briggs") (* \; "Edited 2-May-88 17:00 by Briggs") (* |;;;| "Internal function called by AISBLT.BITMAP to move 8 bpp source file to 1 bpp bitmap using Floyd-Steinberg algorithm") (* |;;| "") (* |;;| "Use of the Error Table") (* |;;| "") (* |;;| "See Newman & Sproull, Principles of Interactive Computer Graphics, pg. 226 for a description of the Floyd-Steinberg algorithm.") (* |;;| "") (* |;;| "The error for the current pixel being processed (0<= n < WIDTH) is maintained in ERROR-CURRENT-PIXEL. The error for the pixel directly below the current pixel is stored in ERROR-TABLE[n], while ERROR-TABLE[n+1] represents the error for the pixel to the right. Once ERROR-CURRENT-PIXEL has been used in the calculation it is loaded from ERROR-TABLE[n+1], which frees this cell in the error table to hold the error for the pixel below and to the right of the current pixel.") (* |;;| " ") (LET ((SOURCE-BYTES-PER-LINE (UNFOLD SOURCE-RASTER-WIDTH BYTESPERWORD)) (INTERMEDIATE-WORD-BUFFER (\\ALLOCBLOCK (FOLDHI WIDTH WORDSPERCELL))) (INTERMEDIATE-WORD-BASE) (ERROR-CURRENT-PIXEL) (ERROR-TABLE (\\ALLOCBLOCK (ADD1 WIDTH))) (ERROR-BASE) (16-TO-1-PILOTBBT (|create| PILOTBBT)) (PIXEL) (ERROR) (QUARTER-ERROR) (THREE-EIGHTHS-ERROR)) (* |;;| "Setup for turning words to final destination bits. Note that we conditionally invert the bits -- if the AIS file had bits in the sense 0=black, 255=white, because Lisp bitmaps are 0=white, 1=black when displayed.") (SETUPPILOTBBT 16-TO-1-PILOTBBT INTERMEDIATE-WORD-BUFFER 15 16 DESTINATION-BASE DESTINATION-PIXEL-OFFSET 1 1 WIDTH 0 T T (COND ((EQ PHOTOMETRY-SENSE AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER) (QUOTE INVERT)) (T (QUOTE INPUT))) (QUOTE REPLACE)) (* |;;| "clear the error table initially") (|for| COLUMN |from| 0 |to| (TIMES 2 WIDTH) |by| 2 |do| (\\PUTBASEPTR ERROR-TABLE COLUMN 0)) (* |;;| "") (|for| ROW |from| 1 |to| HEIGHT |as| FILE-POINTER |from| (IPLUS SOURCE-PIXEL-OFFSET (\\GETFILEPTR STREAM)) |by| SOURCE-BYTES-PER-LINE |do| (* |;;| "position the file at the beginning of the new scan line") (\\SETFILEPTR STREAM FILE-POINTER) (* |;;| "reset the roving pointer in the error table for this row, and load the current pixel error, clearing the table entry since it will be accumulated into.") (SETQ ERROR-BASE ERROR-TABLE) (SETQ ERROR-CURRENT-PIXEL (\\GETBASEPTR ERROR-BASE 0)) (\\PUTBASEPTR ERROR-BASE 0 0) (* |;;| "reset the roving pointer to the intermediate result buffer") (SETQ INTERMEDIATE-WORD-BASE INTERMEDIATE-WORD-BUFFER) (|for| COLUMN |from| 1 |to| WIDTH |do| (* |;;| "take pixel value as read in plus error accumulated to this pixel -- see note re: error calculations above") (SETQ PIXEL (IPLUS ERROR-CURRENT-PIXEL (\\BIN STREAM))) (* |;;| "threshold") (COND ((IGREATERP PIXEL 127) (\\PUTBASE INTERMEDIATE-WORD-BASE 0 1) (SETQ ERROR (IDIFFERENCE PIXEL 255))) (T (\\PUTBASE INTERMEDIATE-WORD-BASE 0 0) (SETQ ERROR (IDIFFERENCE PIXEL 0)))) (* |;;| "distribute the error (3/8ths to each of pixels to right, and down, 1/4 to pixel diagonally down)") (* |;;| "we can use fast logical shifts only if we bias the number to make it positive (we use a bias of 32768 here)") (* |;;| "calculate 3/8ths error as half of (error - error/4) -- this way we will incur less error due to rounding in the error calculation.") (SETQ QUARTER-ERROR (IDIFFERENCE (LRSH (IPLUS 32768 ERROR) 2) (LRSH 32768 2))) (SETQ THREE-EIGHTHS-ERROR (IDIFFERENCE (LRSH (IPLUS 32768 (IDIFFERENCE ERROR QUARTER-ERROR)) 1) (LRSH 32768 1))) (* |;;| "pre-load the current pixel error so that the next entry in the error table can be used to store the error for the next line down") (SETQ ERROR-CURRENT-PIXEL (\\GETBASEPTR ERROR-BASE 2)) (* |;;| "3/8ths of the error to the right (the next \"current\")") (SETQ ERROR-CURRENT-PIXEL (IPLUS ERROR-CURRENT-PIXEL THREE-EIGHTHS-ERROR)) (* |;;| "3/8ths of the error down") (\\PUTBASEPTR ERROR-BASE 0 (IPLUS (\\GETBASEPTR ERROR-BASE 0) THREE-EIGHTHS-ERROR)) (* |;;| "1/4 of the error down to the right") (\\PUTBASEPTR ERROR-BASE 2 QUARTER-ERROR) (* |;;| "advance the roving pointer for error table") (SETQ ERROR-BASE (\\ADDBASE ERROR-BASE 2)) (* |;;| "advance pointer to intermediate result scan line buffer") (SETQ INTERMEDIATE-WORD-BASE (\\ADDBASE INTERMEDIATE-WORD-BASE 1))) (* |;;| " Pack the bits from the intermediate scan line buffer into the destination bitmap at the appropriate line and advance the destination scan line pointer.") (|freplace| (PILOTBBT PBTDEST) |of| 16-TO-1-PILOTBBT |with| DESTINATION-BASE) (\\PILOTBITBLT 16-TO-1-PILOTBBT NIL) (SETQ DESTINATION-BASE (\\ADDBASE DESTINATION-BASE DESTINATION-RASTER-WIDTH)))) T) ) (AISBLT8TO8.BITMAP (LAMBDA (STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE DESTINATION-PIXEL-OFFSET DESTINATION-RASTER-WIDTH DESTINATION-WIDTH WIDTH HEIGHT) (* \; "Edited 28-Apr-88 11:02 by Briggs") (* |;;;| "Internal function called by AISBLT.BITMAP to move 8 bpp source file to 8 bpp bitmap") (* |;;| "look for some special cases that we can handle much faster") (LET ((SOURCE-BYTES-PER-LINE (ITIMES SOURCE-RASTER-WIDTH 2))) (COND ((AND (EQ SOURCE-RASTER-WIDTH DESTINATION-RASTER-WIDTH) (EQ SOURCE-PIXEL-OFFSET 0) (EQ DESTINATION-PIXEL-OFFSET 0) (EQ WIDTH DESTINATION-WIDTH)) (* |;;| "source and destination have same raster width") (* |;;| "and the full scan line is being moved to the full destination scan line") (\\BINS STREAM DESTINATION-BASE 0 (ITIMES HEIGHT SOURCE-BYTES-PER-LINE))) (T (|for| ROW |from| 1 |to| HEIGHT |as| FILE-POINTER |from| (IPLUS SOURCE-PIXEL-OFFSET (\\GETFILEPTR STREAM)) |by| SOURCE-BYTES-PER-LINE |do| (\\SETFILEPTR STREAM FILE-POINTER) (\\BINS STREAM DESTINATION-BASE DESTINATION-PIXEL-OFFSET WIDTH) (COND ((NOT (EQ ROW HEIGHT)) (SETQ DESTINATION-BASE (\\ADDBASE DESTINATION-BASE DESTINATION-RASTER-WIDTH))))))))) ) (AISBLTNTO1FSA.BITMAP (LAMBDA (STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE DESTINATION-PIXEL-OFFSET DESTINATION-RASTER-WIDTH DESTINATION-WIDTH WIDTH HEIGHT SOURCE-BITS-PER-PIXEL PHOTOMETRY-SENSE) (* \; "Edited 23-Sep-88 20:11 by Briggs") (* \; "Edited 2-May-88 15:40 by Briggs") (* |;;;| "Internal function called by AISBLT.BITMAP to move N bpp source file to 1 bpp bitmap using Floyd-Steinberg algorithm. For N=8, use the special case version AISBLT8TO1FSA.BITMAP.") (* |;;| "") (* |;;| "Use of the Error Table") (* |;;| "") (* |;;| "See Newman & Sproull, Principles of Interactive Computer Graphics, pg. 226 for a description of the Floyd-Steinberg algorithm.") (* |;;| "") (* |;;| "The error for the current pixel being processed (0<= n < WIDTH) is maintained in ERROR-CURRENT-PIXEL. The error for the pixel directly below the current pixel is stored in ERROR-TABLE[n], while ERROR-TABLE[n+1] represents the error for the pixel to the right. Once ERROR-CURRENT-PIXEL has been used in the calculation it is loaded from ERROR-TABLE[n+1], which frees this cell in the error table to hold the error for the pixel below and to the right of the current pixel.") (* |;;| " ") (LET* ((SOURCE-BYTES-PER-LINE (ITIMES SOURCE-RASTER-WIDTH 2)) (SOURCE-LINE-BYTE-BUFFER-BASE (\\ALLOCBLOCK (FOLDHI SOURCE-RASTER-WIDTH WORDSPERCELL))) (INTERMEDIATE-WORD-BUFFER (\\ALLOCBLOCK (FOLDHI WIDTH WORDSPERCELL))) (INTERMEDIATE-WORD-BASE) (ERROR-CURRENT-PIXEL) (ERROR-TABLE (\\ALLOCBLOCK (ADD1 WIDTH))) (ERROR-BASE) (ERROR-FRACTIONAL-POINT 7) (N-TO-16-PILOTBBT (|create| PILOTBBT)) (16-TO-1-PILOTBBT (|create| PILOTBBT)) (PIXEL) (BLACK 0) (WHITE (SUB1 (EXPT 2 SOURCE-BITS-PER-PIXEL))) (THRESHOLD (LRSH (IPLUS BLACK WHITE) 1)) (ERROR) (QUARTER-ERROR) (THREE-EIGHTHS-ERROR)) (* |;;| "do the setup for expanding source pixels to words.") (SETUPPILOTBBT N-TO-16-PILOTBBT SOURCE-LINE-BYTE-BUFFER-BASE (ITIMES SOURCE-PIXEL-OFFSET SOURCE-BITS-PER-PIXEL) SOURCE-BITS-PER-PIXEL INTERMEDIATE-WORD-BUFFER (IDIFFERENCE 16 SOURCE-BITS-PER-PIXEL) 16 SOURCE-BITS-PER-PIXEL WIDTH 0 T T (QUOTE INPUT) (QUOTE REPLACE)) (* |;;| "Setup for turning words to final destination bits. Note that we conditionally invert the bits -- if the AIS file had bits in the sense 0=black, larger=lighter, because Lisp bitmaps are 0=white, 1=black when displayed.") (SETUPPILOTBBT 16-TO-1-PILOTBBT INTERMEDIATE-WORD-BUFFER 15 16 DESTINATION-BASE DESTINATION-PIXEL-OFFSET 1 1 WIDTH 0 T T (COND ((EQ PHOTOMETRY-SENSE AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER) (QUOTE INVERT)) (T (QUOTE INPUT))) (QUOTE REPLACE)) (* |;;| "clear the error table initially") (|for| COLUMN |from| 0 |to| (TIMES 2 WIDTH) |by| 2 |do| (\\PUTBASEPTR ERROR-TABLE COLUMN 0)) (* |;;| "") (|for| ROW |from| 1 |to| HEIGHT |do| (* |;;| "We read a full scan line, and extract the bits we need as we expand to 16 bits per pixel") (\\BINS STREAM SOURCE-LINE-BYTE-BUFFER-BASE 0 SOURCE-BYTES-PER-LINE) (* |;;| "expand the pixels to words to make them easier to deal with") (\\PILOTBITBLT N-TO-16-PILOTBBT NIL) (* |;;| "reset the roving pointer in the error table for this row, and load the current pixel error, resetting the table entry to 0 because it will be accumulated to as error for the next line") (SETQ ERROR-BASE ERROR-TABLE) (SETQ ERROR-CURRENT-PIXEL (\\GETBASEPTR ERROR-BASE 0)) (\\PUTBASEPTR ERROR-BASE 0 0) (* |;;| "reset the roving pointer to the intermediate result buffer") (SETQ INTERMEDIATE-WORD-BASE INTERMEDIATE-WORD-BUFFER) (|for| COLUMN |from| 1 |to| WIDTH |do| (* |;;| "take pixel value as read in plus error accumulated to this pixel") (SETQ PIXEL (IPLUS ERROR-CURRENT-PIXEL (\\GETBASE INTERMEDIATE-WORD-BASE 0))) (* |;;| "threshold") (COND ((IGREATERP PIXEL THRESHOLD) (\\PUTBASE INTERMEDIATE-WORD-BASE 0 1) (SETQ ERROR (IDIFFERENCE PIXEL WHITE))) (T (\\PUTBASE INTERMEDIATE-WORD-BASE 0 0) (SETQ ERROR (IDIFFERENCE PIXEL BLACK)))) (* |;;| "distribute the error (3/8ths to each of pixels to right, and down, 1/4 to pixel diagonally down)") (* |;;| "we can use fast logical shifts only if we bias the number to make it positive") (SETQ QUARTER-ERROR (IDIFFERENCE (LRSH (IPLUS 32768 ERROR) 2) (LRSH 32768 2))) (SETQ THREE-EIGHTHS-ERROR (IDIFFERENCE (LRSH (IPLUS 32768 (IDIFFERENCE ERROR QUARTER-ERROR)) 1) (LRSH 32768 1))) (* |;;| "pre-load the current pixel error so that the next entry in the error table can be used to store the error for the next line down") (SETQ ERROR-CURRENT-PIXEL (\\GETBASEPTR ERROR-BASE 2)) (* |;;| "3/8ths of the error to the right (the next \"current\")") (SETQ ERROR-CURRENT-PIXEL (IPLUS ERROR-CURRENT-PIXEL THREE-EIGHTHS-ERROR)) (* |;;| "3/8ths of the error down") (\\PUTBASEPTR ERROR-BASE 0 (IPLUS (\\GETBASEPTR ERROR-BASE 0) THREE-EIGHTHS-ERROR)) (* |;;| "1/4 of the error down to the right") (\\PUTBASEPTR ERROR-BASE 2 QUARTER-ERROR) (* |;;| "advance the roving pointer for error table") (SETQ ERROR-BASE (\\ADDBASE ERROR-BASE 2)) (* |;;| "advance pointer to intermediate result scan line buffer") (SETQ INTERMEDIATE-WORD-BASE (\\ADDBASE INTERMEDIATE-WORD-BASE 1))) (* |;;| " Pack the bits from the intermediate scan line buffer into the destination bitmap at the appropriate line and advance the destination scan line pointer.") (|freplace| (PILOTBBT PBTDEST) |of| 16-TO-1-PILOTBBT |with| DESTINATION-BASE) (\\PILOTBITBLT 16-TO-1-PILOTBBT NIL) (SETQ DESTINATION-BASE (\\ADDBASE DESTINATION-BASE DESTINATION-RASTER-WIDTH)))) T) ) (AISBLTNTO1TRUNCATE.BITMAP (LAMBDA (STREAM SOURCE-PIXEL-OFFSET SOURCE-RASTER-WIDTH DESTINATION-BASE DESTINATION-PIXEL-OFFSET DESTINATION-RASTER-WIDTH DESTINATION-WIDTH WIDTH HEIGHT SOURCE-BITS-PER-PIXEL PHOTOMETRY-SENSE) (* \; "Edited 22-Sep-88 10:23 by Briggs") (* \; "Edited 2-May-88 15:40 by Briggs") (* |;;;| "Internal function called by AISBLT.BITMAP to move N bpp source file to 1 bpp bitmap using truncation.") (LET* ((SOURCE-BYTES-PER-LINE (ITIMES SOURCE-RASTER-WIDTH 2)) (SOURCE-LINE-BYTE-BUFFER-BASE (\\ALLOCBLOCK (FOLDHI SOURCE-RASTER-WIDTH WORDSPERCELL))) (HIGH-N-TO-1-PILOTBBT (|create| PILOTBBT)) (16-TO-1-PILOTBBT (|create| PILOTBBT))) (* |;;| "Setup for turning source pixels to destination pixels. Note that we conditionally invert the bits -- if the AIS file had bits in the sense 0=black, larger=lighter, because Lisp bitmaps are 0=white, 1=black when displayed.") (SETUPPILOTBBT HIGH-N-TO-1-PILOTBBT SOURCE-LINE-BYTE-BUFFER-BASE (ITIMES SOURCE-PIXEL-OFFSET SOURCE-BITS-PER-PIXEL) SOURCE-BITS-PER-PIXEL DESTINATION-BASE DESTINATION-PIXEL-OFFSET 1 1 WIDTH 0 T T (COND ((EQ PHOTOMETRY-SENSE AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER) (QUOTE INVERT)) (T (QUOTE INPUT))) (QUOTE REPLACE)) (|for| ROW |from| 1 |to| HEIGHT |do| (* |;;| "We read a full scan line, and extract the bits we need.") (\\BINS STREAM SOURCE-LINE-BYTE-BUFFER-BASE 0 SOURCE-BYTES-PER-LINE) (* |;;| "Pack the bits from the source scan line buffer into the destination bitmap at the appropriate line and advance the destination scan line pointer.") (|freplace| (PILOTBBT PBTDEST) |of| HIGH-N-TO-1-PILOTBBT |with| DESTINATION-BASE) (\\PILOTBITBLT HIGH-N-TO-1-PILOTBBT NIL) (SETQ DESTINATION-BASE (\\ADDBASE DESTINATION-BASE DESTINATION-RASTER-WIDTH)))) T) ) (SETUPPILOTBBT (LAMBDA (PILOT-BBT SOURCE-BASE SOURCE-BIT SOURCE-BPL DESTINATION-BASE DESTINATION-BIT DESTINATION-BPL WIDTH HEIGHT FLAGS DISJOINT DISJOINT-ITEMS SOURCE OPERATION) (* \; "Edited 28-Apr-88 18:21 by Briggs") (|freplace| (PILOTBBT PBTDEST) |of| PILOT-BBT |with| DESTINATION-BASE) (|freplace| (PILOTBBT PBTDESTBIT) |of| PILOT-BBT |with| DESTINATION-BIT) (|freplace| (PILOTBBT PBTDESTBPL) |of| PILOT-BBT |with| DESTINATION-BPL) (|freplace| (PILOTBBT PBTSOURCE) |of| PILOT-BBT |with| SOURCE-BASE) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOT-BBT |with| SOURCE-BIT) (|freplace| (PILOTBBT PBTSOURCEBPL) |of| PILOT-BBT |with| SOURCE-BPL) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOT-BBT |with| WIDTH) (|freplace| (PILOTBBT PBTHEIGHT) |of| PILOT-BBT |with| HEIGHT) (|freplace| (PILOTBBT PBTFLAGS) |of| PILOT-BBT |with| FLAGS) (|freplace| (PILOTBBT PBTDISJOINT) |of| PILOT-BBT |with| DISJOINT) (|freplace| (PILOTBBT PBTDISJOINTITEMS) |of| PILOT-BBT |with| DISJOINT-ITEMS) (|freplace| (PILOTBBT PBTUSEGRAY) |of| PILOT-BBT |with| NIL) (\\SETPBTFUNCTION PILOT-BBT SOURCE OPERATION)) ) ) (* |;;| "Useful constants") (* \; "AIS file identifying word") (CL:DEFCONSTANT AIS-PASSWORD 33962) (* \; "Attribute part header types") (CL:DEFCONSTANT AIS-RASTER-TYPE 1) (CL:DEFCONSTANT AIS-PLACEMENT-TYPE 2) (CL:DEFCONSTANT AIS-PHOTOMETRY-TYPE 3) (CL:DEFCONSTANT AIS-COMMENT-TYPE 4) (* \; "Raster coding types") (CL:DEFCONSTANT AIS-RASTER-CODING-UCA 1) (CL:DEFCONSTANT AIS-RASTER-CODING-CA 2) (* \; "Photometry sense ") (CL:DEFCONSTANT AIS-PHOTOMETRY-SENSE-LARGER-DARKER 1) (CL:DEFCONSTANT AIS-PHOTOMETRY-SENSE-LARGER-LIGHTER 0) (* \; "Photometry signal ") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-BLACK-AND-WHITE 0 "Photometry signal is black and white") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-RED-SEPARATION 1 "Photometry signal is red separation") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-BLUE-SEPARATION 2 "Photometry signal is blue separation") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-GREEN-SEPARATION 3 "Photometry signal is green separation") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-CYAN-SEPARATION 4 "Photometry signal is cyan separation") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-MAGENTA-SEPARATION 5 "Photometry signal is magenta separation") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-YELLOW-SEPARATION 6 "Photometry signal is yellow separation") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-X-CIE 7 "Photometry signal is x signal (CIE)") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-Y-CIE 8 "Photometry signal is y signal (CIE)") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-IN-COMMENT (UNSIGNED -2 16) "Photometry signal specified in comment part") (CL:DEFCONSTANT AIS-PHOTOMETRY-SIGNAL-UNSPECIFIED (UNSIGNED -1 16) "Photometry signal unspecified") (* \; "Photometry spot type") (CL:DEFCONSTANT AIS-PHOTOMETRY-SPOT-TYPE-RECTANGULAR 1 "Photometry spot type is rectangular") (CL:DEFCONSTANT AIS-PHOTOMETRY-SPOT-TYPE-CIRCULAR 2 "Photometry spot type is circular") (CL:DEFCONSTANT AIS-PHOTOMETRY-SPOT-TYPE-IN-COMMENTS (UNSIGNED -2 16) "Photometry spot type is specified in comments") (CL:DEFCONSTANT AIS-PHOTOMETRY-SPOT-TYPE-UNSPECIFIED (UNSIGNED -1 16) "Photometry spot type is unspecified") (* \; "Photometry scale") (CL:DEFCONSTANT AIS-PHOTOMETRY-SCALE-RELECTANCE-TRANSMITTANCE 1 "Photometry scale is reflectance or transmittance x 1000") (CL:DEFCONSTANT AIS-PHOTOMETRY-SCALE-OPTICAL-DENSITY 2 "Photometry scale is optical density x 1000") (CL:DEFCONSTANT AIS-PHOTOMETRY-SCALE-IN-COMMENT (UNSIGNED -2 16) "Photometry scale is specified in comments") (CL:DEFCONSTANT AIS-PHOTOMETRY-SCALE-UNSPECIFIED (UNSIGNED -1 16) "Photometry scale is unspecified") (* \; "Photometry") (CL:DEFCONSTANT AIS-PHOTOMETRY-UNSPECIFIED (UNSIGNED -1 16) "Photometry general unspecified value") (* \; "Header information when writing AIS format") (CL:DEFCONSTANT AIS-DEFAULT-HEADER-LENGTH (CL:* 1024 BYTESPERWORD) "Length in bytes of the header to write in AIS files") (PUTPROPS AISBLT COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2241 14630 (AISBLT.BITMAP 2251 . 9292) (AISFILEHEADER 9294 . 11739) (WRITEAIS 11741 . 14628)) (14669 32114 (AISBLT1TO1.BITMAP 14679 . 17862) (AISBLT8TO1FSA.BITMAP 17864 . 22694) ( AISBLT8TO8.BITMAP 22696 . 23865) (AISBLTNTO1FSA.BITMAP 23867 . 29280) (AISBLTNTO1TRUNCATE.BITMAP 29282 . 31022) (SETUPPILOTBBT 31024 . 32112))))) STOP \ No newline at end of file diff --git a/lispusers/AISBLT.TEDIT b/lispusers/AISBLT.TEDIT new file mode 100644 index 00000000..9a5b937a Binary files /dev/null and b/lispusers/AISBLT.TEDIT differ diff --git a/lispusers/ANALYZER b/lispusers/ANALYZER new file mode 100644 index 00000000..f423dbf5 --- /dev/null +++ b/lispusers/ANALYZER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Mar-89 15:24:58" {ERINYES}MEDLEY>ANALYZER.;9 86708 changes to%: (FNS Analyzer.ReadWordList) previous date%: "13-Jan-89 15:50:22" {ERINYES}MEDLEY>ANALYZER.;8) (* " Copyright (c) 1985, 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ANALYZERCOMS) (RPAQQ ANALYZERCOMS [(COMS (* ;;; "THE ANALYZER CLASS") (RECORDS Morphalyzer) (* ;; "renamed record to avoid a conflict.") (MACROS Analyzer.Open Analyzer.Close Analyzer.Corrections Analyzer.Proofread Analyzer.Analyze Analyzer.Lookup Analyzer.FindWord Analyzer.AddEntry Dict.DisplayEntry) (* ;; "MACROS that call apply the methods of the analyzer class.") (FNS AnalyzerFromName Analyzer.CountWords Analyzer.DefaultCorrections Analyzer.DefaultNextWord Analyzer.Name Analyzer.DefaultAddEntry Analyzer.DefaultAnalyze Analyzer.DefaultProofread) (* ;;  "Functions implementing the default case for various methods of the analyzer class.") (FNS Analyzer.DefaultLoadWordList Analyzer.DefaultStoreWordList Analyzer.ReadWordList Analyzer.WriteWordList CREATEWORDLISTRDTBL) (INITVARS WORDLISTRDTBL) (FNS Analyzer.Prop Analyzer.PushProp) (MACROS Analyzer.AlphaCharP \Analyzer.TestCorruption Analyzer.Capitalization Analyzer.UCaseP) (* ;; "Service MACROS.") (FNS STREAM.FETCHSTRING) (MACROS Stream.Init Stream.NextChar) (FNS Analyzer.CorruptWord) (GLOBALVARS WORDLISTRDTBL)) [COMS (* ;;; "TEDIT interface to analyzer.") (FNS Analyzer.Establish AnalyzerForStream Analyzer.QuitFn Analyzer.BeforeLogout) (FNS TEdit.ProofreadMenu PROOFREADER.WHENSELECTEDFN WITH-TEDIT TEdit.Correct TEdit.CountWords TEdit.AddEntry TEdit.Proofread TEdit.SetAnalyzer TEdit.LoadWordList TEdit.StoreWordList Analyzer.TEditMenuItems) (INITVARS Analyzer.List Proofreader.AutoCorrect (Proofreader.AutoDelete T) (Proofreader.MenuEdge 'LEFT) Analyzer.TimeProofreader Proofreader.UserFns) (GLOBALVARS Analyzer.List Proofreader.AutoCorrect Proofreader.AutoDelete Proofreader.MenuEdge Analyzer.TimeProofreader Proofreader.UserFns) (P (Analyzer.TEditMenuItems) (COND ((NOT (FASSOC 'Analyzer.BeforeLogout BEFORELOGOUTFORMS)) (push BEFORELOGOUTFORMS '(Analyzer.BeforeLogout] (COMS (* ;;; "THE Dict CLASS") (RECORDS Dict) (MACROS Dict.Open Dict.Close Dict.GetEntry Dict.PutEntry Dict.PrintEntry Dict.MapEntries) (* ;;; "utility functions") (FNS DictFromName Dict.Establish Dict.Prop Dict.Name) (INITVARS Dict.DictionaryList) (GLOBALVARS Dict.DictionaryList) (* ;;; "a simple dictionary.") (FNS SimpleDict.New SimpleDict.PutEntry SimpleDict.Lookup SimpleDict.MapEntries SimpleDict.PrintEntries SimpleDict.Test) (RECORDS SimpleDict.Node)) (COMS (* ;;; "the INVERTEDDICT class") (RECORDS INVERTEDDICT) (FNS InvertedDictFromName InvertedDict.Establish InvertedDict.Prop InvertedDict.Name InvertedDict.Open) (INITVARS InvertedDict.List) (GLOBALVARS InvertedDict.List)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA InvertedDict.Prop Dict.Prop Analyzer.Prop]) (* ;;; "THE ANALYZER CLASS") (DECLARE%: EVAL@COMPILE (DATATYPE Morphalyzer (analyzerName grammar index analyzerProps openFn closeFn proofreadFn analyzeFn lookupFn correctionsFn generateFn conjugateFn findWordFn addEntryFn) openFn _ (FUNCTION NILL) closeFn _ (FUNCTION NILL) proofreadFn _ (FUNCTION Analyzer.DefaultProofread) analyzeFn _ (FUNCTION Analyzer.DefaultAnalyze) lookupFn _ (FUNCTION NILL) correctionsFn _ (FUNCTION Analyzer.DefaultCorrections) generateFn _ (FUNCTION NILL) conjugateFn _ (FUNCTION NILL) findWordFn _ (FUNCTION NILL) addEntryFn _ (FUNCTION Analyzer.DefaultAddEntry)) ) (/DECLAREDATATYPE 'Morphalyzer '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((Morphalyzer 0 POINTER) (Morphalyzer 2 POINTER) (Morphalyzer 4 POINTER) (Morphalyzer 6 POINTER) (Morphalyzer 8 POINTER) (Morphalyzer 10 POINTER) (Morphalyzer 12 POINTER) (Morphalyzer 14 POINTER) (Morphalyzer 16 POINTER) (Morphalyzer 18 POINTER) (Morphalyzer 20 POINTER) (Morphalyzer 22 POINTER) (Morphalyzer 24 POINTER) (Morphalyzer 26 POINTER)) '28) (* ;; "renamed record to avoid a conflict.") (DECLARE%: EVAL@COMPILE (PUTPROPS Analyzer.Open MACRO ((analyzer) (APPLY* (fetch (Morphalyzer openFn) of analyzer) analyzer))) (PUTPROPS Analyzer.Close MACRO ((analyzer) (APPLY* (fetch (Morphalyzer closeFn) of analyzer) analyzer))) (PUTPROPS Analyzer.Corrections MACRO ((analyzer stream start length) (* * returns a list of possible corrections for the string starting at "start"  that is "length" characters long.) (APPLY* (fetch (Morphalyzer correctionsFn) of analyzer) analyzer stream start length))) (PUTPROPS Analyzer.Proofread MACRO ((analyzer stream start length prFn) (* * The user interface to Analyzer.Analyze.) (APPLY* (fetch (Morphalyzer proofreadFn) of analyzer) analyzer stream start length prFn))) (PUTPROPS Analyzer.Analyze MACRO ((analyzer stream start length analFn allowWildCards) (* * break up the stream into legal lexical items.  calls analFn (analyzer stream start len entries) on each item, where "entries"  is the analysis of that item. If "entries" is NIL, then the item could not be  analyzed.) (APPLY* (fetch (Morphalyzer analyzeFn) of analyzer) analyzer stream start length analFn allowWildCards))) (PUTPROPS Analyzer.Lookup MACRO ((analyzer stream start length) (* * Look up the substring of stream between start and length in dict.  "stream" can be a stream, a string, or a list of characters.) (APPLY* (fetch (Morphalyzer lookupFn) of analyzer) analyzer stream start length))) (PUTPROPS Analyzer.FindWord MACRO ((analyzer word stream start length) (APPLY* (fetch (Morphalyzer findWordFn) of analyzer ) analyzer word stream start length))) (PUTPROPS Analyzer.AddEntry MACRO ((analyzer lemma entry dontRecord) (* * add lemma to the dictionary with entry "entry" %.  If dontRecord is non-NIL, don't worry about keeping track of this word for the  word list.) (APPLY* (fetch (Morphalyzer addEntryFn) of analyzer ) analyzer lemma entry dontRecord))) (PUTPROPS Dict.DisplayEntry MACRO ((dict entry newwindowflg) (APPLY* (OR [COND ((type? Dict dict) (Dict.Prop dict 'DISPLAYENTRYFN)) ((type? INVERTEDDICT dict) (InvertedDict.Prop dict 'DISPLAYENTRYFN] 'NILL) dict entry newwindowflg))) ) (* ;; "MACROS that call apply the methods of the analyzer class.") (DEFINEQ (AnalyzerFromName [LAMBDA (dictName remoteName) (* ; "Edited 6-Oct-88 09:56 by jtm:") (* * find the analyzer corresponding to the dictionary.) (PROG (analyzer COLONPOS) [COND ((NULL dictName) (SETQ analyzer (CAR Analyzer.List))) [(for i in Analyzer.List do (COND ([AND (EQ dictName (fetch (Morphalyzer analyzerName) of i)) (EQ remoteName (Analyzer.Prop i 'RemoteDict] (SETQ analyzer i) (RETURN T] ((SETQ COLONPOS (STRPOS ":" dictName)) (SETQ analyzer (AnalyzerFromName (SUBATOM dictName 1 (SUB1 COLONPOS)) (SUBATOM dictName (IPLUS COLONPOS 2) -1] (RETURN analyzer]) (Analyzer.CountWords [LAMBDA (analyzer stream start length) (* jtm%: "13-Nov-86 13:32") (LET [(n 0) (FN (Analyzer.Prop analyzer 'CountWords] (COND (FN (APPLY* FN analyzer stream start length)) (T [Analyzer.Analyze analyzer stream start length (FUNCTION (LAMBDA (analyzer stream start length entries) (add n 1) NIL] n]) (Analyzer.DefaultCorrections [LAMBDA (analyzer stream start length) (* jtm%: " 7-Apr-87 08:23") (* * returns a list of possible spelling corrections for the given word.) (PROG [form word wordList caps periods (userDict (Analyzer.Prop analyzer 'UserDict] [COND [(STREAMP stream) (SETFILEPTR stream start) (SETQ word (for i from 1 to length collect (BIN stream] ((STRINGP stream) (SETQ word (for i from 1 to (NCHARS stream) collect (NTHCHARCODE stream i] (SETQ caps (Analyzer.Capitalization word)) (SETQ periods (FMEMB (CHARCODE %.) word)) (* * first try transpositions) (for tail temp on word while (CDR tail) do (SETQ temp (CAR tail)) (RPLACA tail (CADR tail)) (RPLACA (CDR tail) temp) (COND ((AND (EQ caps 'FIRST) (EQ tail word)) (* don't transpose the first letters  of a capitalized word.) NIL) (T (\Analyzer.TestCorruption analyzer word wordList userDict))) (RPLACA (CDR tail) (CAR tail)) (RPLACA tail temp)) (* * next try deletions) (COND ((CDR word) (\Analyzer.TestCorruption analyzer (CDR word) wordList userDict))) (for tail temp on word while (CDR tail) do (SETQ temp (CDR tail)) (RPLACD tail (CDDR tail)) (\Analyzer.TestCorruption analyzer word wordList userDict) (RPLACD tail temp)) (* * prepend a character.) (SETQ word (CONS (CHARCODE A) word)) (SELECTQ caps (FIRST (* don't prepend a character before  a capitalized word.) NIL) (ALL (* prepend a capital letter.) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA word c) (\Analyzer.TestCorruption analyzer word wordList userDict))) (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA word c) (\Analyzer.TestCorruption analyzer word wordList userDict))) (SETQ word (CDR word)) (* * insert characters.) (for tail on word do (RPLACD tail (CONS (CHARCODE A) (CDR tail))) [COND ((EQ caps 'ALL) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA (CDR tail) c) (\Analyzer.TestCorruption analyzer word wordList userDict))) (T (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA (CDR tail) c) (\Analyzer.TestCorruption analyzer word wordList userDict] (COND (periods (RPLACA (CDR tail) (CHARCODE %.)) (\Analyzer.TestCorruption analyzer word wordList userDict))) (RPLACD tail (CDDR tail))) (* * replace characters) (for tail temp on word do (SETQ temp (CAR tail)) [COND ((OR (EQ caps 'ALL) (AND (EQ caps 'FIRST) (EQ tail word))) (for c from (CHARCODE A) to (CHARCODE Z) do (COND ((NEQ temp c) (RPLACA tail c) (\Analyzer.TestCorruption analyzer word wordList userDict] [COND ((OR (EQ caps NIL) (NOT (ALPHACHARP (CHCON1 temp))) (AND (EQ caps 'FIRST) (NEQ tail word))) (for c from (CHARCODE a) to (CHARCODE z) do (COND ((NEQ temp c) (RPLACA tail c) (\Analyzer.TestCorruption analyzer word wordList userDict] (COND (periods (RPLACA tail (CHARCODE %.)) (\Analyzer.TestCorruption analyzer word wordList userDict))) (RPLACA tail temp)) (SETQ wordList (SORT wordList)) [for i on wordList do (while (STREQUAL (CAR i) (CADR i)) do (RPLACD i (CDDR i] (RETURN wordList]) (Analyzer.DefaultNextWord [LAMBDA (analyzer stream startPtr searchLength NWFn) (* jtm%: "29-Oct-85 15:23") (* * Scans the stream looking for a word, i.e.  a sequence of alphabetic charqacters. If the file ptr is already in the middle  of such a sequence, it backs up to the beginning of that sequence.  The function applies NWFn to (stream start stop) for each such word.) (SETFILEPTR stream (OR startPtr (SETQ startPtr 0))) (bind char end endPtr word length start value quote (filePtr _ (GETFILEPTR stream)) (EOFPtr _ (GETEOFPTR stream)) first (SETQ endPtr (COND (searchLength (IPLUS startPtr searchLength) ) (T EOFPtr))) (OR (ILEQ endPtr EOFPtr) (SETQ endPtr EOFPtr)) do (SETQ char (AND (ILESSP (GETFILEPTR stream) endPtr) (BIN stream))) (COND [(AND char (AND (NUMBERP char) (ILESSP char 128) (Analyzer.AlphaCharP char))) (OR start (SETQ start (SUB1 (GETFILEPTR stream] (start (SETQ end (GETFILEPTR stream)) (SETQ length (IDIFFERENCE end start)) (AND char (add length -1)) (* back up to the last legal char.) [COND (NWFn (SETQ value (APPLY* NWFn analyzer stream start length] (COND ((OR (NULL NWFn) (EQ value T)) (RETURN (CONS start length))) (value (RETURN value))) (SETFILEPTR stream end) (SETQ start NIL))) (OR char (RETURN]) (Analyzer.Name [LAMBDA (analyzer) (* jtm%: "13-Oct-87 10:44") (COND [(Analyzer.Prop analyzer 'RemoteDict) (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) ": " (Analyzer.Prop analyzer 'RemoteDict] (T (fetch (Morphalyzer analyzerName) of analyzer]) (Analyzer.DefaultAddEntry [LAMBDA (analyzer lemma entry dontRecord errorStream) (* jtm%: " 7-Apr-87 07:57") (LET [(userDict (Analyzer.Prop analyzer 'UserDict] (COND ((NULL userDict) (SETQ userDict (SimpleDict.New)) (Analyzer.Prop analyzer 'UserDict userDict))) (Dict.PutEntry userDict lemma entry) (COND ((NOT dontRecord) (Analyzer.PushProp analyzer 'WordList lemma))) lemma]) (Analyzer.DefaultAnalyze [LAMBDA (analyzer stream startPtr searchLength NWFn allowWildCards) (* ; "Edited 23-Nov-88 08:17 by jtm:") (* * Scans the stream looking for a word, i.e.  a sequence of alphabetic charqacters. If the file ptr is already in the middle  of such a sequence, it backs up to the beginning of that sequence.  The function applies NWFn to (stream start stop) for each such word.) [COND ((STRINGP stream) (SETQ stream (OPENSTRINGSTREAM stream] (SETFILEPTR stream (OR startPtr (SETQ startPtr 0))) (bind char end endPtr length start lookup number initialQuote seprs (userDict _ (Analyzer.Prop analyzer 'UserDict)) [optSeprCodes _ (OR (Analyzer.Prop analyzer 'OPT-SEPR-CODES) '(39 46 45 47] (addAlphaCharCodes _ (Analyzer.Prop analyzer 'ADD-ALPHA-CHAR-CODES)) (word _ (ALLOCSTRING 100 32)) (i _ startPtr) first (DECLARE (LOCALVARS . T)) [SETQ endPtr (COND (searchLength (IMIN (GETEOFPTR stream) (IPLUS startPtr searchLength))) (T (GETEOFPTR stream] do (SETQ char (AND (add i 1) (ILEQ i endPtr) (BIN stream))) (COND ((AND start (NUMBERP char) (ILESSP char 128)) (RPLCHARCODE word (IDIFFERENCE i start) char))) [COND [[AND char (OR (AND (NUMBERP char) (ILESSP char 128) (Analyzer.AlphaCharP char)) (FMEMB char addAlphaCharCodes) (AND allowWildCards (EQ char (CONSTANT (CHARCODE *] (COND ((NULL start) [COND (number (SETQ start (IDIFFERENCE i 2)) (* we have a number followed by some characters.  (e.g. 7th, 21st, etc.) Take in the last digit of the number.) (RPLCHARCODE word 1 number) (SETQ number NIL)) (T (SETQ start (SUB1 i] (RPLCHARCODE word (IDIFFERENCE i start) char] [(AND char (NUMBERP char) (IGEQ char 48) (ILEQ char 57)) (* a number) (COND ((NULL start) (SETQ number char) (SETQ initialQuote NIL)) (T (RPLCHARCODE word (IDIFFERENCE i start) char] ((AND start char (FMEMB char optSeprCodes)) (* optSeprCodes may or may not be a  part of the word.) (push seprs i)) [start (* AND char (add length -1)) (* back up to the last legal char.) (* * find the longest string of characters seperated by seprs that the analyzer  accepts.) (COND ((NULL seprs) (SETQ seprs i)) (T (push seprs i))) [for stop inside seprs do (SETQ length (SUB1 (IDIFFERENCE stop start))) (COND ([SETQ lookup (OR (Analyzer.Lookup analyzer word 0 length) (AND userDict (SimpleDict.Lookup userDict word length] (RETURN)) ((AND initialQuote (EQP length 1) (EQ (NTHCHARCODE word 1) (CHARCODE s))) (SETQ lookup 'possessive) (RETURN] (* * apply NWFn and return its value if non-NIL.) (COND ((AND (NULL NWFn) (NEQ lookup 'possessive)) (RETURN (CONS start length))) ((AND (NEQ lookup 'possessive) (SETQ lookup (APPLY* NWFn analyzer stream start length lookup))) (RETURN lookup)) (T (COND ((NEQ i (IPLUS start length 1)) (* we regressed.) (SETQ i (IPLUS start length)) (* don't add 1 so that we will see the quote and initialQuote will get set  ("time's")) (SETFILEPTR stream i) (* set char to T to prevent the  RETURN at the end of the loop.) (SETQ char T))) (SETQ start NIL) (SETQ seprs NIL) (SETQ initialQuote NIL] (T (SETQ number NIL) (SETQ initialQuote (EQ char (CHARCODE %'] (OR char (RETURN]) (Analyzer.DefaultProofread [LAMBDA (analyzer stream begin length) (* jtm%: "16-Dec-87 13:07") (PROG (start.length correction startTime stopTime char (n 0)) (TEDIT.PROMPTPRINT stream "Proofreading . . . " T) (* * initialize and back up to the beginning of a word.) (SETQ startTime (CLOCK 0)) (Stream.Init stream begin length) [COND ((NEQ length 0) (while (AND (NUMBERP (SETQ char (BIN stream))) (ALPHACHARP char)) do (COND ((EQUAL begin 0) (RETURN)) (T (add begin -1) (add length 1) (SETFILEPTR stream begin] (* * look for the next spelling error.) [while [SETQ start.length (Analyzer.Analyze analyzer stream begin length (FUNCTION (LAMBDA (analyzer stream start length entries) (add n 1) (COND ((NULL entries) (CONS start length] do (* * start.length is a CONS pair of locations delimiting an unrecognizable  word. Set the selection to it and display it.) [COND ((AND Proofreader.UserFns (for fn (word _ (STREAM.FETCHSTRING stream (CAR start.length) (CDR start.length))) inside Proofreader.UserFns thereis (APPLY* fn word))) (SETQ correction '*SKIP*)) (T (TEDIT.SETSEL stream (ADD1 (CAR start.length)) (CDR start.length) 'RIGHT T) (TEDIT.SHOWSEL stream NIL) (TEDIT.NORMALIZECARET stream) (TEDIT.SHOWSEL stream T) (COND ([NOT (AND Proofreader.AutoCorrect (SETQ correction (TEdit.Correct stream analyzer T] (RETURN] (COND [(FMEMB correction '(*SKIP* *INSERT*)) [add length (IDIFFERENCE begin (IPLUS (CAR start.length) (CDR start.length] (SETQ begin (IPLUS (CAR start.length) (CDR start.length] ((STRINGP correction) (add length (IDIFFERENCE begin (CAR start.length))) (* move start point.) (add length (IDIFFERENCE (NCHARS correction) (CDR start.length))) (* adjust for correction.) (SETQ begin (CAR start.length))) (T (SHOULDNT] (SETQ stopTime (CLOCK 0)) (COND (Analyzer.TimeProofreader (TEDIT.PROMPTPRINT stream (CONCAT "Elapsed Time: " (QUOTIENT (DIFFERENCE stopTime startTime) 1000.0) " seconds."))) (start.length (TEDIT.PROMPTPRINT stream "Error found.")) (T (* (ADD1 (GETEOFPTR stream))) (TEDIT.SETSEL stream (IPLUS begin length 1) 0 'RIGHT) (TEDIT.SHOWSEL stream NIL) (TEDIT.NORMALIZECARET stream) (TEDIT.SHOWSEL stream T) (TEDIT.PROMPTPRINT stream (COND ((EQUAL n 0) "No Errors.") (T (CONCAT n " words proofread."))) T]) ) (* ;; "Functions implementing the default case for various methods of the analyzer class.") (DEFINEQ (Analyzer.DefaultLoadWordList [LAMBDA (analyzer file) (* jtm%: "17-Sep-86 09:39") (* * adds a word list to the given analyzer.) (PROG (wordList) (SETQ wordList (Analyzer.ReadWordList file)) (for i in wordList do (Analyzer.AddEntry analyzer i T T)) (Analyzer.PushProp analyzer 'WordListFile file]) (Analyzer.DefaultStoreWordList [LAMBDA (analyzer file) (* jtm%: "23-Sep-86 09:08") (* * adds the current word list to the remote file.) (PROG (wordList) (SETQ wordList (Analyzer.Prop analyzer 'WordList)) [COND ((DIRECTORY file) (SETQ wordList (APPEND wordList (Analyzer.ReadWordList file] (Analyzer.WriteWordList wordList file) (Analyzer.PushProp analyzer 'WordListFile file) (Analyzer.Prop analyzer 'WordList NIL]) (Analyzer.ReadWordList [LAMBDA (file) (* ; "Edited 9-Mar-89 15:22 by jtm:") (PROG (firstWord word words stream) (SETQ stream (OPENSTREAM file 'INPUT)) (SETFILEPTR stream 0) (SETQ firstWord (READ stream)) (SETFILEPTR stream 0) (COND [(LISTP firstWord) (* old style format.) (RETURN (CDR (READFILE stream] (T (* new style format) [COND ((NULL WORDLISTRDTBL) (SETQ WORDLISTRDTBL (CREATEWORDLISTRDTBL] [while (SKIPSEPRCODES stream WORDLISTRDTBL) do (SETQ word (RSTRING stream WORDLISTRDTBL)) (COND ((EQ 0 (NCHARS word)) (BIN stream)) (T (push words word] (CLOSEF stream) (RETURN words]) (Analyzer.WriteWordList [LAMBDA (wordList file) (* jtm%: "17-Sep-86 10:11") (PROG (stream) (SETQ stream (OPENSTREAM file 'OUTPUT)) (SETFILEPTR stream 0) (for word in wordList do (printout stream word T)) (CLOSEF stream]) (CREATEWORDLISTRDTBL [LAMBDA NIL (* jtm%: "17-Sep-86 10:55") (LET (RDTBL) (SETQ RDTBL (COPYREADTABLE 'ORIG)) (for SEPR in (GETSEPR RDTBL) do (SETSYNTAX (CHARACTER SEPR) 'OTHER RDTBL)) (for BREAK in (GETBRK RDTBL) do (SETSYNTAX (CHARACTER BREAK) 'OTHER RDTBL)) (SETSYNTAX (CHARACTER (CHARCODE CR)) 'SEPR RDTBL) RDTBL]) ) (RPAQ? WORDLISTRDTBL NIL) (DEFINEQ (Analyzer.Prop [LAMBDA a (* jtm%: "13-Oct-87 11:54") (LET (p (analyzer (ARG a 1)) (prop (ARG a 2))) (SETQ p (FASSOC prop (fetch (Morphalyzer analyzerProps) of analyzer))) (COND ((ILEQ a 2) (CDR p)) [p (PROG1 (CDR p) (RPLACD p (ARG a 3)))] (T (CDAR (push (fetch (Morphalyzer analyzerProps) of analyzer) (CONS prop (ARG a 3]) (Analyzer.PushProp [LAMBDA (analyzer prop value) (* jtm%: "13-Oct-87 10:59") (* * pushes value onto a list of values stored at prop.) (LET [(prop.values (FASSOC prop (fetch (Morphalyzer analyzerProps) of analyzer] (COND [(NULL prop.values) (push (fetch (Morphalyzer analyzerProps) of analyzer) (CONS prop (LIST value] ((NOT (for i in (CDR prop.values) thereis (EQUAL i value))) (push (CDR prop.values) value))) value]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS Analyzer.AlphaCharP MACRO [(CHAR) (OR (EQ (LRSH CHAR 8) 241) ([LAMBDA (UCHAR) (DECLARE (LOCALVARS UCHAR)) (OR (EQ (LRSH UCHAR 8) 241) (AND (IGEQ UCHAR (CHARCODE A)) (ILEQ UCHAR (CHARCODE Z] (LOGAND CHAR 95]) (PUTPROPS \Analyzer.TestCorruption MACRO [(analyzer word wordList userDict) (COND ((OR (Analyzer.Lookup analyzer word) (AND userDict (SimpleDict.Lookup userDict word))) (push wordList (CONCATCODES word]) (PUTPROPS Analyzer.Capitalization MACRO [(word) (* * returns NIL, ALL or FIRST) (COND ((AND (CAR word) (Analyzer.UCaseP (CAR word))) (COND ((AND (CADR word) (Analyzer.UCaseP (CADR word))) 'ALL) (T 'FIRST]) (PUTPROPS Analyzer.UCaseP MACRO [(UCHAR) (OR (AND (IGEQ UCHAR (CHARCODE 361,041)) (ILEQ UCHAR (CHARCODE 361,160))) (AND (IGEQ UCHAR (CHARCODE A)) (ILEQ UCHAR (CHARCODE Z]) ) (* ;; "Service MACROS.") (DEFINEQ (STREAM.FETCHSTRING [LAMBDA (stream start length buffer restorePtr) (* jtm%: " 3-Apr-87 11:28") (LET (pos) [COND (restorePtr (SETQ pos (GETFILEPTR stream] [COND ((OR (NULL buffer) (IGREATERP length (NCHARS buffer))) (SETQ buffer (ALLOCSTRING length] (SETFILEPTR stream start) (for i from 1 to length do (RPLCHARCODE buffer i (BIN stream))) (COND (restorePtr (SETFILEPTR stream pos))) (SUBSTRING buffer 1 length]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS Stream.Init MACRO [(stream start length) (COND [(STRINGP stream) (OR start (SETQ start 0)) (OR length (SETQ length (NCHARS stream] ((NOT (LISTP stream)) (COND ((NULL start) (SETQ start 0))) [COND ((NULL length) (SETQ length (IDIFFERENCE (GETEOFPTR stream) start] (SETFILEPTR stream start]) (PUTPROPS Stream.NextChar MACRO [(stream length index) (COND ((LISTP stream) (pop stream)) ((OR (NULL stream) (ILEQ length 0)) NIL) ((STRINGP stream) (add length -1) (add index 1) (NTHCHARCODE stream index)) (T (add length -1) (BIN stream]) ) (DEFINEQ (Analyzer.CorruptWord [LAMBDA (analyzer stream start length) (* jtm%: " 5-Feb-87 11:23") (* * returns a list of possible spelling corrections for the given word.) (PROG (form word wordList caps) (SETQ word (for i from 1 to length collect (BIN stream))) (SETQ caps (Analyzer.Capitalization word)) (* * first try transpositions) (for tail temp on word while (CDR tail) do (SETQ temp (CAR tail)) (RPLACA tail (CADR tail)) (RPLACA (CDR tail) temp) (COND ((AND (EQ caps 'FIRST) (EQ tail word)) (* don't transpose the first letters  of a capitalized word.) NIL) (T (\Analyzer.TestCorruption analyzer word wordList))) (RPLACA (CDR tail) (CAR tail)) (RPLACA tail temp)) (* * next try deletions) (COND ((CDR word) (\Analyzer.TestCorruption analyzer (CDR word) wordList))) (for tail temp on word while (CDR tail) do (SETQ temp (CDR tail)) (RPLACD tail (CDDR tail)) (\Analyzer.TestCorruption analyzer word wordList) (RPLACD tail temp)) (* * prepend a character.) (SETQ word (CONS 'A word)) (SELECTQ caps (FIRST (* don't prepend a character before  a capitalized word.) NIL) (ALL (* prepend a capital letter.) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA word c) (\Analyzer.TestCorruption analyzer word wordList))) (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA word c) (\Analyzer.TestCorruption analyzer word wordList))) (SETQ word (CDR word)) (* * insert characters.) (for tail on word do (RPLACD tail (CONS 'A (CDR tail))) [COND ((EQ caps 'ALL) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA (CDR tail) c) (\Analyzer.TestCorruption analyzer word wordList))) (T (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA (CDR tail) c) (\Analyzer.TestCorruption analyzer word wordList] (RPLACD tail (CDDR tail))) (* * replace characters) (for tail temp on word do (SETQ temp (CAR tail)) [COND ((OR (EQ caps 'ALL) (AND (EQ caps 'FIRST) (EQ tail word))) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA tail c) (COND ((EQ temp c)) (T (\Analyzer.TestCorruption analyzer word wordList] [COND ((OR (EQ caps NIL) (NOT (ALPHACHARP temp)) (AND (EQ caps 'FIRST) (NEQ tail word))) (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA tail c) (COND ((EQ temp (CHARACTER c))) (T (\Analyzer.TestCorruption analyzer word wordList] (RPLACA tail temp)) (SETQ wordList (SORT wordList)) [for i on wordList do (while (STREQUAL (CAR i) (CADR i)) do (RPLACD i (CDR i] (RETURN wordList]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WORDLISTRDTBL) ) (* ;;; "TEDIT interface to analyzer.") (DEFINEQ (Analyzer.Establish [LAMBDA (analyzer) (* jtm%: "13-Oct-87 10:44") (AND analyzer (OR (AND (BOUNDP 'Analyzer.List) (bind (analyzerName _ (fetch (Morphalyzer analyzerName) of analyzer)) for tail on Analyzer.List when (EQUAL analyzerName (fetch (Morphalyzer analyzerName) of (CAR tail))) do (RPLACA tail analyzer) (RETURN T))) (push Analyzer.List analyzer]) (AnalyzerForStream [LAMBDA (stream) (* jtm%: " 2-Oct-85 14:00") (* * comment) (COND ((STREAMPROP stream 'analyzer)) (T (TEdit.SetAnalyzer stream]) (Analyzer.QuitFn [LAMBDA (window stream textObj) (* jtm%: "14-Jan-86 15:58") (* * ask the user if he wants to save the word list.) (PROG ((analyzer (AnalyzerForStream stream))) (COND ((AND analyzer (Analyzer.Prop analyzer 'WordList) (STREQUAL "yes" (TEDIT.GETINPUT stream "Do you want to save the word list? " "yes" ))) (TEdit.StoreWordList stream]) (Analyzer.BeforeLogout [LAMBDA NIL (* jtm%: "13-Oct-87 10:45") (for analyzer file in Analyzer.List do (COND ([AND (Analyzer.Prop analyzer 'WordList) (EQ 'Y (ASKUSER 10 'N (CONCAT "Do you want to save the word list for " (fetch (Morphalyzer analyzerName) of analyzer) "? "] (COND ([NULL (SETQ file (PROMPTFORWORD "Store word list on file:" (CAR (Analyzer.Prop analyzer 'WordListFile] (printout T "Aborted.")) (T (RESETLST (printout T (CONCAT "Storing word list on " file "...")) (Analyzer.DefaultStoreWordList analyzer file) (printout T "Deleting old version...") (RESETSAVE (TTYDISPLAYSTREAM (OPENTEXTSTREAM))) (* to swallow up the output of  DIRECTORY) (DIRECTORY file '(DELVER))) (printout T "done."]) ) (DEFINEQ (TEdit.ProofreadMenu [LAMBDA (stream) (* ; "Edited 11-Jul-88 11:02 by jop") (* ;;; "TEDIT interface to the current analyzer.") (PROG (menuWindow menu analyzer W) (* ;; "COND ((WINDOWPROP W (QUOTE DEFWINDOW)) (* so they don't interfere.) (CLOSEW (WINDOWPROP W (QUOTE DEFWINDOW))))") [SETQ W (CAR (fetch \WINDOW of (TEXTOBJ stream] (SETQ menuWindow (WINDOWPROP W 'Proofreader.Menu)) (COND ((NULL menuWindow) (SETQ menu (create MENU ITEMS _ '(("Proofread" Proofread "looks for the next spelling error starting from the caret." ) ("Correct" Correct "generates a list of possible corrections for the current selection." ) ("Insert" Insert "inserts the selected word into the analyzer's word list." ) ("CountWords" Countwords "counts the words in the current selection.")) CENTERFLG _ T MENUOUTLINESIZE _ 2 WHENSELECTEDFN _ (FUNCTION PROOFREADER.WHENSELECTEDFN))) (SETQ menuWindow (MENUWINDOW menu T)) (* ;; "WINDOWPROP menuWindow (QUOTE RESHAPEFN) (QUOTE DON'T)") (* ;; "(addmenu |menu| |menuWindow|)") (WINDOWPROP W 'Proofreader.Menu menuWindow) (CLOSEW menuWindow))) (COND ((NOT (OPENWP menuWindow)) (ATTACHWINDOW menuWindow W Proofreader.MenuEdge 'TOP 'LOCALCLOSE) (* ;; "(CAR (WINDOWPROP W (QUOTE PROMPTWINDOW)))") (* ;;  "if you attach the menuWindow to W, then it gets attached to the top-most TEdit menu.") (OPENW menuWindow))) [COND ((SETQ analyzer (AnalyzerForStream stream)) (Analyzer.Proofread analyzer stream (SUB1 (TEDIT.GETPOINT stream] (RETURN menuWindow]) (PROOFREADER.WHENSELECTEDFN [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 11-Jul-88 10:58 by jop") (LET [(W (MAINWINDOW (WFROMMENU MENU] (SELECTQ (CADR ITEM) (Proofread (WITH-TEDIT W (FUNCTION TEdit.Proofread))) (Correct (WITH-TEDIT W (FUNCTION TEdit.Correct))) (Insert (WITH-TEDIT W (FUNCTION TEdit.AddEntry))) (Countwords (WITH-TEDIT W (FUNCTION TEdit.CountWords))) NIL]) (WITH-TEDIT [LAMBDA (TEXTOBJ FUNCTION) (* jtm%: "30-Mar-87 14:07") (LET (EDITOP) [COND ((WINDOWP TEXTOBJ) (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ] (COND ((SETQ EDITOP (fetch EDITOPACTIVE of TEXTOBJ)) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (COND ((EQ EDITOP T) "Edit operation") (T EDITOP)) " in progress; please wait."))) (T (RESETLST [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) '(AND (\TEDIT.MARKINACTIVE OLDVALUE] (replace EDITOPACTIVE of TEXTOBJ with FUNCTION) (APPLY* FUNCTION TEXTOBJ))]) (TEdit.Correct [LAMBDA (stream analyzer autoCorrect) (* jtm%: "30-Mar-87 14:09") (PROG (selection correction start length items menuWindow) [COND ((WINDOWP stream) (SETQ menuWindow (WINDOWPROP stream 'Proofreader.Menu)) (SETQ stream (TEXTSTREAM stream))) ((type? TEXTOBJ stream) (SETQ stream (TEXTSTREAM stream))) (T (SETQ menuWindow (WINDOWPROP (CAR (fetch \WINDOW of (TEXTOBJ stream))) 'Proofreader.Menu] (COND ([AND (NULL analyzer) (NULL (SETQ analyzer (AnalyzerForStream stream] (TEDIT.PROMPTPRINT stream "No analyzer selected." T) (RETURN))) (SETQ selection (TEDIT.GETSEL stream)) (SETQ start (fetch (SELECTION CH#) of selection)) (SETQ length (IDIFFERENCE (fetch (SELECTION CHLIM) of selection) start)) (TEDIT.PROMPTPRINT stream (CONCAT "Looking for corrections for %"" (STREAM.FETCHSTRING stream (SUB1 start) length) "%" . . . ") T) (SETQ items (Analyzer.Corrections analyzer stream (SUB1 start) length)) [AND autoCorrect (SETQ items (APPEND items '(*INSERT* *SKIP*] (COND (items [SELECTQ (SETQ correction (MENU (create MENU ITEMS _ items CENTERFLG _ T MENUOFFSET _ (create POSITION XCOORD _ 6 YCOORD _ 6) TITLE _ "corrections"))) (*INSERT* (TEdit.AddEntry stream analyzer)) (*SKIP* NIL) (COND (correction (TEDIT.DELETE stream) (TEDIT.INSERT stream correction] (TEDIT.PROMPTPRINT stream "" T)) (T (TEDIT.PROMPTPRINT stream (CONCAT "No corrections for the word %"" (STREAM.FETCHSTRING stream (SUB1 start) length) "%".") T))) (RETURN correction]) (TEdit.CountWords [LAMBDA (stream) (* jtm%: "30-Mar-87 14:11") (LET (selection n) [COND ((OR (WINDOWP stream) (type? TEXTOBJ stream)) (SETQ stream (TEXTSTREAM stream] (SETQ selection (TEDIT.GETSEL stream)) (TEDIT.PROMPTPRINT stream "Counting words in selection . . . " T) [SETQ n (Analyzer.CountWords (AnalyzerForStream stream) stream (SUB1 (fetch (SELECTION CH#) of selection)) (IDIFFERENCE (fetch (SELECTION CHLIM) of selection) (fetch (SELECTION CH#) of selection] [COND ((STRINGP n) (TEDIT.PROMPTPRINT stream n T)) (T (TEDIT.PROMPTPRINT stream (CONCAT n " words counted."] n]) (TEdit.AddEntry [LAMBDA (stream analyzer) (* jtm%: "30-Mar-87 14:11") (PROG (word) [COND ((OR (WINDOWP stream) (type? TEXTOBJ stream)) (SETQ stream (TEXTSTREAM stream] [COND ((NULL analyzer) (SETQ analyzer (AnalyzerForStream stream] (SETQ word (TEDIT.SEL.AS.STRING stream)) (COND [analyzer (COND ((Analyzer.AddEntry analyzer word T NIL stream) (TEDIT.PROMPTPRINT stream (CONCAT "%"" word "%"" " inserted into local word list.") T)) (T (TEDIT.PROMPTPRINT stream "Insert not implemented for this analyzer." T] (T (TEDIT.PROMPTPRINT stream "No analyzer selected." T]) (TEdit.Proofread [LAMBDA (W) (* jtm%: "16-Dec-87 13:06") (LET (sel string (stream (TEXTSTREAM W))) (SETQ sel (TEDIT.GETSEL stream)) (SETQ string (STREAM.FETCHSTRING stream (SUB1 (fetch (SELECTION CH#) of sel)) (fetch (SELECTION DCH) of sel))) (COND ((STRPOS " " string) (* just analyze the selection.) (Analyzer.Proofread (AnalyzerForStream stream) stream (SUB1 (fetch (SELECTION CH#) of sel)) (fetch (SELECTION DCH) of sel))) (T (Analyzer.Proofread (AnalyzerForStream stream) stream (SUB1 (TEDIT.GETPOINT stream]) (TEdit.SetAnalyzer [LAMBDA (stream analyzer) (* jtm%: "28-Aug-86 09:15") (* * sets the analyzer property for the window) (PROG (quitFn menuItems) [COND ((NULL analyzer) [SETQ menuItems (for i in Analyzer.List collect (LIST (Analyzer.Name i) (LIST 'QUOTE i) (if (Analyzer.Prop i 'RemoteDict) then "Calls the remote dictionary server"] [COND ((NULL menuItems)) ((EQ 1 (LENGTH menuItems)) (SETQ analyzer (CAR Analyzer.List))) (T (SETQ analyzer (MENU (create MENU ITEMS _ menuItems TITLE _ "analyzers" CENTERFLG _ T] (COND ((NULL analyzer) (SETQ analyzer (STREAMPROP stream 'analyzer)) (TEDIT.PROMPTPRINT stream (CONCAT "Proofreader is " (AND analyzer (Analyzer.Name analyzer)) ".") T) (RETURN] (TEDIT.PROMPTPRINT stream (CONCAT "Setting proofreader to " (Analyzer.Name analyzer) "...") T) (Analyzer.Open analyzer) (STREAMPROP stream 'analyzer analyzer) (SETQ quitFn (TEXTPROP stream 'QUITFN)) [COND ((OR (EQ quitFn 'Analyzer.QuitFn) (FMEMB 'Analyzer.QuitFn quitFn)) NIL) ((NULL quitFn) (TEXTPROP stream 'QUITFN 'Analyzer.QuitFn)) (T (TEXTPROP stream 'QUITFN (CONS 'Analyzer.QuitFn quitFn] (* push the function onto the list.) (TEDIT.PROMPTPRINT stream "done.")) analyzer]) (TEdit.LoadWordList [LAMBDA (stream) (* jtm%: " 9-Oct-85 10:39") (* * reads a word list from a remote file and adds it to the given analyzer.) (PROG (file (analyzer (AnalyzerForStream stream))) (COND ((NULL analyzer) (TEDIT.PROMPTPRINT stream "Please select a proofreader." T)) ((NULL (SETQ file (TEDIT.GETINPUT stream "Fetch word list on file: "))) (TEDIT.PROMPTPRINT stream "Aborted." T)) (T (TEDIT.PROMPTPRINT stream (CONCAT "Reading " file "...") T) (Analyzer.DefaultLoadWordList analyzer file) (TEDIT.PROMPTPRINT stream "done."]) (TEdit.StoreWordList [LAMBDA (stream) (* jtm%: "28-Jan-87 08:59") (* * stores the word list for the given analyzer on a remote file.) (PROG (file (analyzer (AnalyzerForStream stream))) (COND ((NULL analyzer) (TEDIT.PROMPTPRINT stream "Please select a proofreader." T)) ((NULL (Analyzer.Prop analyzer 'WordList)) (TEDIT.PROMPTPRINT stream "No words to be stored." T)) ([NULL (SETQ file (TEDIT.GETINPUT stream "Store word list on file: " (CAR (Analyzer.Prop analyzer 'WordListFile] (TEDIT.PROMPTPRINT stream "Aborted." T)) (T (RESETLST (RESETSAVE (TTYDISPLAYSTREAM (OPENTEXTSTREAM))) (* to swallow up the output of  DIRECTORY) (TEDIT.PROMPTPRINT stream (CONCAT "Storing word list on " file "...") T) (Analyzer.DefaultStoreWordList analyzer file) [COND (Proofreader.AutoDelete (TEDIT.PROMPTPRINT stream "Deleting old version..." T) (DIRECTORY file '(DELVER] (TEDIT.PROMPTPRINT stream "done."))]) (Analyzer.TEditMenuItems [LAMBDA NIL (* jtm%: "23-Oct-87 08:58") (AND (BOUNDP 'TEDIT.DEFAULT.MENU) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Proofread (FUNCTION TEdit.ProofreadMenu) "Looks for the next spelling error after the caret." (SUBITEMS (Proofread (FUNCTION TEdit.ProofreadMenu) "Looks for the next spelling error after the caret." (SUBITEMS (SetProofreader (FUNCTION TEdit.SetAnalyzer) "Gives a menu of possible proofreaders to use." ) (LoadWordList (FUNCTION TEdit.LoadWordList) "Loads a file of words into the proofreader.") (StoreWordList (FUNCTION TEdit.StoreWordList) "Stores the words added to the proofreader by the user on a remote file." ) (AutoCorrect [FUNCTION (LAMBDA (stream) (SETQ Proofreader.AutoCorrect T) (TEDIT.PROMPTPRINT stream "AutoCorrection is ON." T] "The proofreader automatically generates a menu of corrections for the user." ) (ManualCorrect [FUNCTION (LAMBDA (stream) (SETQ Proofreader.AutoCorrect) (TEDIT.PROMPTPRINT stream "AutoCorrection is OFF." T] "The user must ask for a menu of corrections from the proofreader if he wants one." ))) (Correct (FUNCTION TEdit.Correct) "generates a list of possible corrections for the current selection." ) (Insert (FUNCTION TEdit.AddEntry) "inserts the selected word into the analyzer's word list.") (CountWords (FUNCTION TEdit.CountWords) "Counts the number of words in the currect selection."]) ) (RPAQ? Analyzer.List NIL) (RPAQ? Proofreader.AutoCorrect NIL) (RPAQ? Proofreader.AutoDelete T) (RPAQ? Proofreader.MenuEdge 'LEFT) (RPAQ? Analyzer.TimeProofreader NIL) (RPAQ? Proofreader.UserFns NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS Analyzer.List Proofreader.AutoCorrect Proofreader.AutoDelete Proofreader.MenuEdge Analyzer.TimeProofreader Proofreader.UserFns) ) (Analyzer.TEditMenuItems) [COND ((NOT (FASSOC 'Analyzer.BeforeLogout BEFORELOGOUTFORMS)) (push BEFORELOGOUTFORMS '(Analyzer.BeforeLogout] (* ;;; "THE Dict CLASS") (DECLARE%: EVAL@COMPILE (DATATYPE Dict (dictName contents analyzer dictProps subDictionaries openFn closeFn getEntryFn putEntryFn mapFn printEntryFn) openFn _ (FUNCTION NILL) closeFn _ (FUNCTION NILL) getEntryFn _ (FUNCTION NILL) putEntryFn _ (FUNCTION NILL) mapFn _ (FUNCTION NILL) printEntryFn _ (FUNCTION NILL)) ) (/DECLAREDATATYPE 'Dict '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((Dict 0 POINTER) (Dict 2 POINTER) (Dict 4 POINTER) (Dict 6 POINTER) (Dict 8 POINTER) (Dict 10 POINTER) (Dict 12 POINTER) (Dict 14 POINTER) (Dict 16 POINTER) (Dict 18 POINTER) (Dict 20 POINTER)) '22) (DECLARE%: EVAL@COMPILE (PUTPROPS Dict.Open MACRO ((dict) (APPLY* (fetch (Dict openFn) of dict) dict))) (PUTPROPS Dict.Close MACRO ((dict) (APPLY* (fetch (Dict closeFn) of dict) dict))) (PUTPROPS Dict.GetEntry MACRO ((dict uniqueID prop) (APPLY* (fetch (Dict getEntryFn) of dict) dict uniqueID prop))) (PUTPROPS Dict.PutEntry MACRO ((dict uniqueID entry prop) (APPLY* (fetch putEntryFn of dict) dict uniqueID entry prop))) (PUTPROPS Dict.PrintEntry MACRO ((dict entry stream) (APPLY* [COND ((type? Dict dict) (fetch (Dict printEntryFn) of dict)) ((type? INVERTEDDICT dict) (InvertedDict.Prop dict 'PRINTENTRYFN] dict entry stream))) (PUTPROPS Dict.MapEntries MACRO ((dict MpFn prop topOnly) (* MpFn (dict uniqueId entry prop)) (APPLY* (fetch (Dict mapFn) of dict) dict MpFn prop topOnly))) ) (* ;;; "utility functions") (DEFINEQ (DictFromName [LAMBDA (dictName remoteName) (* ; "Edited 6-Oct-88 09:42 by jtm:") (PROG (dict COLONPOS) [COND ((NULL dictName) (SETQ dict (CAR Dict.DictionaryList))) [(for i in Dict.DictionaryList do (COND ([AND (EQ dictName (fetch (Dict dictName) of i)) (EQ remoteName (Dict.Prop i 'RemoteDict] (SETQ dict i) (RETURN T] [(for i in InvertedDict.List do (COND ([AND (EQ dictName (fetch (INVERTEDDICT INVERTEDDICTNAME ) of i)) (EQ remoteName (InvertedDict.Prop i 'RemoteDict)) (SETQ dict (InvertedDict.Prop i 'DICTIONARY] (RETURN T] ((SETQ COLONPOS (STRPOS ":" dictName)) (SETQ dict (DictFromName (SUBATOM dictName 1 (SUB1 COLONPOS)) (SUBATOM dictName (IPLUS COLONPOS 2) -1] (RETURN dict]) (Dict.Establish [LAMBDA (dict) (* jtm%: "13-Oct-87 10:45") (OR (AND (BOUNDP 'Dict.DictionaryList) (bind (dictName _ (fetch (Dict dictName) of dict)) for tail on Dict.DictionaryList when (EQUAL dictName (fetch (Dict dictName) of (CAR tail))) do (RPLACA tail dict) (RETURN T))) (push Dict.DictionaryList dict]) (Dict.Prop [LAMBDA a (* jtm%: "13-Oct-87 11:54") (LET (p (dict (ARG a 1)) (prop (ARG a 2))) (SETQ p (FASSOC prop (fetch (Dict dictProps) of dict))) (COND ((ILEQ a 2) (CDR p)) [p (PROG1 (CDR p) (RPLACD p (ARG a 3)))] (T (CDAR (push (fetch (Dict dictProps) of dict) (CONS prop (ARG a 3]) (Dict.Name [LAMBDA (dict) (* jtm%: "13-Oct-87 10:45") (COND [(Dict.Prop dict 'RemoteDict) (MKATOM (CONCAT (fetch (Dict dictName) of dict) ": " (Dict.Prop dict 'RemoteDict] (T (fetch (Dict dictName) of dict]) ) (RPAQ? Dict.DictionaryList NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS Dict.DictionaryList) ) (* ;;; "a simple dictionary.") (DEFINEQ (SimpleDict.New [LAMBDA (name) (* jtm%: "13-Oct-87 10:40") (create Dict dictName _ name getEntryFn _ (FUNCTION SimpleDict.Lookup) putEntryFn _ (FUNCTION SimpleDict.PutEntry) mapFn _ (FUNCTION SimpleDict.MapEntries) contents _ (create SimpleDict.Node]) (SimpleDict.PutEntry [LAMBDA (dict entry value) (* jtm%: " 5-Feb-87 11:29") (* * adds the value to dict under entry.) (LET (subNode (node (fetch (Dict contents) of dict))) [COND ((LITATOM entry) (SETQ entry (MKSTRING entry] (COND ((STRINGP entry) (for i char from 1 to (NCHARS entry) do (SETQ char (NTHCHAR entry i)) (COND ([NOT (SETQ subNode (FASSOC char (fetch (SimpleDict.Node subnodes) of node] (SETQ subNode (create SimpleDict.Node char _ char)) (push (fetch (SimpleDict.Node subnodes) of node) subNode))) (SETQ node subNode)) (replace (SimpleDict.Node value) of node with value)) ((LISTP entry) (for char in entry do (COND ([NOT (SETQ subNode (FASSOC char (fetch ( SimpleDict.Node subnodes) of node] (SETQ subNode (create SimpleDict.Node char _ char)) (push (fetch (SimpleDict.Node subnodes) of node) subNode))) (SETQ node subNode)) (replace (SimpleDict.Node value) of node with value))) value]) (SimpleDict.Lookup [LAMBDA (dict entry length) (* jtm%: " 7-Apr-87 08:28") (* * looks up entry in the dictionary) (PROG ((node (fetch (Dict contents) of dict))) (COND [(OR (STRINGP entry) (LITATOM entry)) [for i from 1 to (OR length (NCHARS entry)) do (COND ([NOT (SETQ node (FASSOC (NTHCHAR entry i) (fetch (SimpleDict.Node subnodes) of node] (RETURN] (AND node (RETURN (fetch (SimpleDict.Node value) of node] ((LISTP entry) [for i in entry do (COND [(AND (NUMBERP i) (IGREATERP i 9)) (* a character code.) (COND ([NOT (SETQ node (FASSOC (CHARACTER i) (fetch ( SimpleDict.Node subnodes) of node] (RETURN] ([NOT (SETQ node (FASSOC i (fetch ( SimpleDict.Node subnodes) of node] (RETURN] (AND node (RETURN (fetch (SimpleDict.Node value) of node]) (SimpleDict.MapEntries [LAMBDA (dict fn node path) (* jtm%: "11-Apr-86 15:45") (* * maps all of the entries in the dictionary in arbitrary order.) [COND ((NULL node) (SETQ node (fetch (Dict contents) of dict] [COND ((fetch (SimpleDict.Node value) of node) (APPLY* fn dict path (fetch (SimpleDict.Node value) of node] (for i in (fetch (SimpleDict.Node subnodes) of node) do (SimpleDict.MapEntries dict fn i (APPEND path (LIST (fetch (SimpleDict.Node char) of i]) (SimpleDict.PrintEntries [LAMBDA (dict stream noValues) (* jtm%: "31-Mar-87 07:37") [Dict.MapEntries dict (FUNCTION (LAMBDA (dict entry value) (COND (noValues (printout stream (CONCATLIST entry) T)) (T (printout stream (CONCATLIST entry) %, value T] dict]) (SimpleDict.Test [LAMBDA NIL (* jtm%: "11-Apr-86 15:49") (* * tests the SimpleDict implementation.) (LET [(dict (SimpleDict.New 'test] (for i in '(asdf asd asdfg asde bfdas) do (Dict.PutEntry dict i i)) [Dict.MapEntries dict (FUNCTION (LAMBDA (dict entry value) (printout T entry %, value T] dict]) ) (DECLARE%: EVAL@COMPILE (RECORD SimpleDict.Node (char value . subnodes)) ) (* ;;; "the INVERTEDDICT class") (DECLARE%: EVAL@COMPILE (TYPERECORD INVERTEDDICT (INVERTEDDICTNAME HEADERINDEX KEYINDEX INDEXFILE FILEDIR FILENAME FILEEXT FILEARRAY INVERTEDDICTPROPS)) ) (DEFINEQ (InvertedDictFromName [LAMBDA (dictName remoteName) (* ; "Edited 6-Oct-88 09:57 by jtm:") (PROG (dict COLONPOS) [COND ((NULL dictName) (SETQ dict (CAR InvertedDict.List))) [(for i in InvertedDict.List do (COND ([AND (EQ dictName (fetch (INVERTEDDICT INVERTEDDICTNAME ) of i)) (EQ remoteName (InvertedDict.Prop i 'RemoteDict] (SETQ dict i) (RETURN T] ((SETQ COLONPOS (STRPOS ":" dictName)) (SETQ dict (InvertedDictFromName (SUBATOM dictName 1 (SUB1 COLONPOS)) (SUBATOM dictName (IPLUS COLONPOS 2) -1] (RETURN dict]) (InvertedDict.Establish [LAMBDA (dict) (* jtm%: "13-Oct-87 10:32") (OR (bind (name _ (fetch (INVERTEDDICT INVERTEDDICTNAME) of dict)) for tail on InvertedDict.List when (EQUAL name (fetch (INVERTEDDICT INVERTEDDICTNAME) of (CAR tail))) do (RPLACA tail dict) (RETURN T)) (push InvertedDict.List dict]) (InvertedDict.Prop [LAMBDA a (* jtm%: "13-Oct-87 11:54") (LET (p (dict (ARG a 1)) (prop (ARG a 2))) (SETQ p (FASSOC prop (fetch (INVERTEDDICT INVERTEDDICTPROPS) of dict))) (COND ((ILEQ a 2) (CDR p)) [p (PROG1 (CDR p) (RPLACD p (ARG a 3)))] (T (CDAR (push (fetch (INVERTEDDICT INVERTEDDICTPROPS) of dict) (CONS prop (ARG a 3]) (InvertedDict.Name [LAMBDA (dict) (* jtm%: "13-Oct-87 10:33") (COND [(InvertedDict.Prop dict 'RemoteDict) (MKATOM (CONCAT (fetch (INVERTEDDICT INVERTEDDICTNAME) of dict) ": " (InvertedDict.Prop dict 'RemoteDict] (T (fetch (INVERTEDDICT INVERTEDDICTNAME) of dict]) (InvertedDict.Open [LAMBDA (invertedDict) (* jtm%: " 7-Apr-87 09:01") (LET [(OPENFN (InvertedDict.Prop invertedDict 'OPENFN] (AND OPENFN (APPLY* OPENFN invertedDict]) ) (RPAQ? InvertedDict.List NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS InvertedDict.List) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA InvertedDict.Prop Dict.Prop Analyzer.Prop) ) (PUTPROPS ANALYZER COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10141 33876 (AnalyzerFromName 10151 . 11522) (Analyzer.CountWords 11524 . 12266) ( Analyzer.DefaultCorrections 12268 . 19753) (Analyzer.DefaultNextWord 19755 . 21975) (Analyzer.Name 21977 . 22384) (Analyzer.DefaultAddEntry 22386 . 22896) (Analyzer.DefaultAnalyze 22898 . 28734) ( Analyzer.DefaultProofread 28736 . 33874)) (33977 36948 (Analyzer.DefaultLoadWordList 33987 . 34397) ( Analyzer.DefaultStoreWordList 34399 . 34975) (Analyzer.ReadWordList 34977 . 36038) ( Analyzer.WriteWordList 36040 . 36361) (CREATEWORDLISTRDTBL 36363 . 36946)) (36980 38146 (Analyzer.Prop 36990 . 37522) (Analyzer.PushProp 37524 . 38144)) (40472 41057 (STREAM.FETCHSTRING 40482 . 41055)) ( 42763 48941 (Analyzer.CorruptWord 42773 . 48939)) (49054 52044 (Analyzer.Establish 49064 . 49864) ( AnalyzerForStream 49866 . 50101) (Analyzer.QuitFn 50103 . 50618) (Analyzer.BeforeLogout 50620 . 52042) ) (52045 69400 (TEdit.ProofreadMenu 52055 . 54471) (PROOFREADER.WHENSELECTEDFN 54473 . 54976) ( WITH-TEDIT 54978 . 55882) (TEdit.Correct 55884 . 58740) (TEdit.CountWords 58742 . 59650) ( TEdit.AddEntry 59652 . 60583) (TEdit.Proofread 60585 . 61433) (TEdit.SetAnalyzer 61435 . 63680) ( TEdit.LoadWordList 63682 . 64427) (TEdit.StoreWordList 64429 . 65858) (Analyzer.TEditMenuItems 65860 . 69398)) (72647 76175 (DictFromName 72657 . 74663) (Dict.Establish 74665 . 75318) (Dict.Prop 75320 . 75814) (Dict.Name 75816 . 76173)) (76323 82812 (SimpleDict.New 76333 . 76705) (SimpleDict.PutEntry 76707 . 78907) (SimpleDict.Lookup 78909 . 81109) (SimpleDict.MapEntries 81111 . 81815) ( SimpleDict.PrintEntries 81817 . 82348) (SimpleDict.Test 82350 . 82810)) (83131 86330 ( InvertedDictFromName 83141 . 84639) (InvertedDict.Establish 84641 . 85146) (InvertedDict.Prop 85148 . 85682) (InvertedDict.Name 85684 . 86097) (InvertedDict.Open 86099 . 86328))))) STOP \ No newline at end of file diff --git a/lispusers/ANALYZER.TEDIT b/lispusers/ANALYZER.TEDIT new file mode 100644 index 00000000..b30e528b Binary files /dev/null and b/lispusers/ANALYZER.TEDIT differ diff --git a/lispusers/AUTOSAMEDIR b/lispusers/AUTOSAMEDIR new file mode 100644 index 00000000..4c092ed6 --- /dev/null +++ b/lispusers/AUTOSAMEDIR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Sep-87 19:37:29" {PHYLUM}LYRIC>AUTOSAMEDIR.;2 1551 changes to%: (VARS AUTOSAMEDIRCOMS) (FNS AUTOSAMEDIR) previous date%: "15-Dec-85 13:02:11" {PHYLUM}LYRIC>AUTOSAMEDIR.;1) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT AUTOSAMEDIRCOMS) (RPAQQ AUTOSAMEDIRCOMS ((* ; "extension to SAMEDIR") (FILES (SYSLOAD FROM LISPUSERS) SAMEDIR) (INITVARS (AUTOSAMEDIRFLG)) (FNS AUTOSAMEDIR) (P (EDITV MAKEFILEFORMS F CHECKSAMEDIR (IF (NEQ (QUOTE AUTOSAMEDIR) (%## 0 2 1)) ((MBD (OR (AUTOSAMEDIR FILE) &))) NIL)) (UNMARKASCHANGED (QUOTE MAKEFILEFORMS) T))) ) (* ; "extension to SAMEDIR") (FILESLOAD (SYSLOAD FROM LISPUSERS) SAMEDIR) (RPAQ? AUTOSAMEDIRFLG ) (DEFINEQ (AUTOSAMEDIR (LAMBDA (FILE) (* ; "Edited 17-Sep-87 19:33 by Rao") (LET (LOADEDFILE DIR) (* ;; "Ramana Rao - ensure that the getprop uses a symbol in the IL package.") (AND AUTOSAMEDIRFLG (SETQ LOADEDFILE (CDAR (GETPROP (CL:INTERN (CL:SYMBOL-NAME FILE) "IL") (QUOTE FILEDATES)))) (NEQ (DIRECTORYNAME T T) (SETQ DIR (PACKFILENAME (QUOTE HOST) (FILENAMEFIELD LOADEDFILE (QUOTE HOST)) (QUOTE DIRECTORY) (FILENAMEFIELD LOADEDFILE (QUOTE DIRECTORY))))) (/CNDIR DIR)))) ) ) (EDITV MAKEFILEFORMS F CHECKSAMEDIR (IF (NEQ (QUOTE AUTOSAMEDIR) (%## 0 2 1)) ((MBD (OR (AUTOSAMEDIR FILE) &))) NIL)) (UNMARKASCHANGED (QUOTE MAKEFILEFORMS) T) (PUTPROPS AUTOSAMEDIR COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (828 1308 (AUTOSAMEDIR 838 . 1306))))) STOP \ No newline at end of file diff --git a/lispusers/AUTOSAMEDIR.TEDIT b/lispusers/AUTOSAMEDIR.TEDIT new file mode 100644 index 00000000..b1e14c9f Binary files /dev/null and b/lispusers/AUTOSAMEDIR.TEDIT differ diff --git a/lispusers/AUXMENU b/lispusers/AUXMENU new file mode 100644 index 00000000..c9ad1950 --- /dev/null +++ b/lispusers/AUXMENU @@ -0,0 +1 @@ +(FILECREATED "15-Apr-86 12:18:47" {DANTE}LISP>AUXMENU.;19 6842 changes to: (VARS AUXMENUCOMS DefaultMiddleButtonBackgroundMenuCommands) (FNS BackgroundButtonFN CreateMiddleButtonBackgroundMenu Auxmenu.Other.Directory) previous date: "14-Apr-86 11:40:55" {DANTE}LISP>AUXMENU.;18) (PRETTYCOMPRINT AUXMENUCOMS) (RPAQQ AUXMENUCOMS [(* * This file sets up the Middle button background menu. It could very easily set up a Left button background menu also. The variable DefaultMiddleButtonBackgroundMenuCommands contains a set of default commands for the middle button background menu. The variable MiddleButtonBackgroundMenuCommands is the actual list of commands that is used to create the menu. The menu is contained in the global variable MiddleButtonBackgroundMenu. The function CreateMiddleButtonBackgroundMenu accepts a list of commands and returns a menu.) (VARS DefaultMiddleButtonBackgroundMenuCommands) (GLOBALVARS MiddleButtonBackgroundMenuCommands MiddleButtonBackgroundMenu) (FNS BackgroundButtonFN CreateMiddleButtonBackgroundMenu Auxmenu.Other.Directory) (INITVARS (MiddleButtonBackgroundMenuCommands DefaultMiddleButtonBackgroundMenuCommands) (MiddleButtonBackgroundMenu NIL)) (P (SETQ BACKGROUNDBUTTONEVENTFN (QUOTE BackgroundButtonFN]) (* * This file sets up the Middle button background menu. It could very easily set up a Left button background menu also. The variable DefaultMiddleButtonBackgroundMenuCommands contains a set of default commands for the middle button background menu. The variable MiddleButtonBackgroundMenuCommands is the actual list of commands that is used to create the menu. The menu is contained in the global variable MiddleButtonBackgroundMenu. The function CreateMiddleButtonBackgroundMenu accepts a list of commands and returns a menu.) (RPAQQ DefaultMiddleButtonBackgroundMenuCommands ((Greet (GREET) " Do a (GREET)") (Login (LOGIN) " Do a (LOGIN)") (Logout (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) [PROMPTPRINT (CONCAT " Logging out at " (MKSTRING (DATE] (TERPRI PROMPTWINDOW) (LOGOUT)) " Do a (LOGOUT) " (SUBITEMS (Fast (LOGOUT T) " Do (LOGOUT T) ") (Safe (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) [PROMPTPRINT (CONCAT " Logging out at " (MKSTRING (DATE] (TERPRI PROMPTWINDOW) (LOGOUT (QUOTE ?))) " Do (LOGOUT '?) "))) (Reclaim (RPT 5 (QUOTE (RECLAIM))) " Perform a garbage collection. ") (Cleanup (CLEANUP) " Do a (CLEANUP)") (Connect (DIRECTORYNAME T) " Show the current connected directory. " (SUBITEMS ({DSK} (/CNDIR (QUOTE {DSK})) " Connect to the local DSK.") (Default (/CNDIR LOGINHOST/DIR) " Connect to LOGINHOST/DIR. ") (Other (Auxmenu.Other.Directory) " Prompt for the directory to connect to. "))) (Closeall (CLOSEALL) " Close all open files.") (Open% Files (OPENP) " List Open Files") (VMem% Size (VMEMSIZE) " Find the current size of the Virtual Memory.") (Free% Pages (DISKFREEPAGES) " List the number of free pages on the local file volume.") (Disk% Partition (DISKPARTITION) " Display the name of the current partition.") (Volume% Display (DSKDISPLAY (QUOTE ON)) " Open the local disk descriptor window. ") (Default% Printers DEFAULTPRINTINGHOST " List the default printers. ") (File% Changes (FILEPKGCHANGES) " List the changes made to the loaded files. ") (Loaded% Files FILELST " List the loaded files. ") (Lafite%(ON%) (LAFITE (QUOTE ON)) " Turn Lafite On "))) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MiddleButtonBackgroundMenuCommands MiddleButtonBackgroundMenu) ) (DEFINEQ (BackgroundButtonFN [LAMBDA NIL (* Marshall "14-Apr-86 11:40") (* * This function actually calls the middle-button background menu. It is the value of the variable  BACKGROUNDBUTTONEVENTFN) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PROMPTWINDOW)) (PROG (Result) [COND ((OR (NOT (BOUNDP (QUOTE MiddleButtonBackgroundMenu))) (NULL MiddleButtonBackgroundMenu)) (* If the menu is NIL, reset it) (SETQ MiddleButtonBackgroundMenu (CreateMiddleButtonBackgroundMenu MiddleButtonBackgroundMenuCommands] (COND ((AND (MOUSESTATE MIDDLE) (SETQ Result (MENU MiddleButtonBackgroundMenu))) (* If there is a result, print it to the PROMPTWINDOW) (TERPRI PROMPTWINDOW) (PRIN1 (CONCAT " " Result) PROMPTWINDOW) (TERPRI PROMPTWINDOW]) (CreateMiddleButtonBackgroundMenu [LAMBDA (CommandList) (* edited: "28-Mar-85 15:34") (* * Create the middle-button background menu.) (create MENU ITEMS _ CommandList MENUCOLUMNS _ 1 CENTERFLG _ T WHENSELECTEDFN _(QUOTE DEFAULTWHENSELECTEDFN]) (Auxmenu.Other.Directory [LAMBDA NIL (* edited: "28-Mar-85 15:42") (* * This function destructively modifies the MiddleButtonBackgroundMenuCommands variable to include the new  directories typed in after "Other" is selected in the "Connect" submenu so that the user can connect to that  directory via the menu later.) (PROG ((Directory (PROMPTFORWORD " Enter the name of the directory to connect to: " NIL NIL PROMPTWINDOW))) [RPLACD (CDDR (CADDDR (ASSOC (QUOTE Connect) MiddleButtonBackgroundMenuCommands))) (CONS (LIST (MKATOM Directory) (LIST (QUOTE /CNDIR) Directory) (CONCAT " Connect to " (MKSTRING Directory))) (COPY (CDDDR (CADDDR (ASSOC (QUOTE Connect) MiddleButtonBackgroundMenuCommands] (* Destructuve modification) (SETQ MiddleButtonBackgroundMenu (CreateMiddleButtonBackgroundMenu MiddleButtonBackgroundMenuCommands)) (* reset menu variables) (RETURN (/CNDIR Directory)) (* connect to the directory) ]) ) (RPAQ? MiddleButtonBackgroundMenuCommands DefaultMiddleButtonBackgroundMenuCommands) (RPAQ? MiddleButtonBackgroundMenu NIL) (SETQ BACKGROUNDBUTTONEVENTFN (QUOTE BackgroundButtonFN)) (PUTPROPS AUXMENU COPYRIGHT (NONE)) (DECLARE: DONTCOPY (FILEMAP (NIL (3785 6592 (BackgroundButtonFN 3795 . 4886) (CreateMiddleButtonBackgroundMenu 4888 . 5235) (Auxmenu.Other.Directory 5237 . 6590))))) STOP \ No newline at end of file diff --git a/lispusers/AUXMENU.TEDIT b/lispusers/AUXMENU.TEDIT new file mode 100644 index 00000000..88155fd2 Binary files /dev/null and b/lispusers/AUXMENU.TEDIT differ diff --git a/lispusers/BACKGROUND-DurerCats.BITMAP b/lispusers/BACKGROUND-DurerCats.BITMAP new file mode 100644 index 00000000..26cbb85a --- /dev/null +++ b/lispusers/BACKGROUND-DurerCats.BITMAP @@ -0,0 +1 @@ +{(READBITMAP)(981 642 "AABBIDEAAEIJJDHCBBDHHBEAEBJ@JHDJFDIBBJBBDBBECDABH@BDHBDJBICBBEBIDB@@BEEDMDHHDDF@BAABE@D@BDHJCIEE@EEJMFBEBJEDJNLDIAEDEBJEDJJJIEBJEAEDDIAKJIEBJEBCEJME@EEDNBHIB@A@EBDDB@CAA@HIEIEEB@@BADJEBBFDJBIB@IB@@JDAFEBBABBBJBDICBI@JHBJEDEB@HIBBF@IBJLMDDEADJBDD@@@" "FGEEBEDJFBBB@IEDDLIEFMDFBEAEIEI@HMBLLBMEAEDIDIDJEEDJEEIDIBDEDJEBEDKKIBDIAABEIJHNLJJJJEIGEEEEDNEAGJJMJINJIFJMEJKKFJJKJMFJIEMMDJKEJNJJKFNJMEJKDJKLJMJJODECIEEEEGDMBJJJIKHJLMBDDDIBDNNIEBEBIEABDIDMEBIEEBIDIDIEDEEJAIJEHHDMDMDEBCAEKEDIIAEDHBBBCBIEBEEGC@@@" "HHBDDIADHHJHKCBJIABDI@JHHJDDBBBGB@EAADABFDIBBBKDHIBIEDCAFDIDBHJDICDDEDJBFGEJBAEAABDDDJBHJHJJKIJFHBJJKGELFHEEEDODHJJDEBIEBJJJJEDJEABJHIGIEEE@KAMGFJJJ@KBLNJJHJHJBIAABDDEDBBMGCBBIEAAFDIBHJADICDFAEDJDHIFJBBDICBDADDE@BGBBBAABHHJHDIBDDJJFFHJHHIDDIAB@HH@@" "EEDIIBFBEGDEHDDABDEABGBECDJIDIDHDJJDJEJDHJBEEEDACBEBDILEAABIDEDIBDBIBBHJHHDAEJDJDDIII@IBIEIBEBBICDIEELOIIEJIEMJMCEDKEEFJMEEEEJKEEFIEFEJMMDJMDLOIMEDIFDJBEBDMDJDHDLLIABIBMDA@HJHJBDJABDIEADJDDEALIBEBFDAEEEBBHIBMBIBJI@IDIDJIFEBGBDEABDAA@MAGEBCBDLIEE@@@" "ABIBBDHHI@BHBIBNDJJFDHDHDADJEDIJI@HJDHBIEDLJDDAFDDHDJBABDFIBEDABEADJLMCBEFIDDABIJMDBBEBEB@BDMEDDDEBJDEABEJEDIBEBDHJDJJIEBFJKBEDJJIBHIBEBDIEBMBDEABJEAAAEEIB@BEBEBBAEJLJDAADKEBFEIJIDEBDAEBDKABDBBI@IACDAABIIEDJ@IBHHDJLIEBIDA@I@ICBJICJDJ@J@DHHIBBDJD@@@" "JDDIDMECBEICEBE@IHHHMBIBJJA@HIBABGBIIBJEAAADIIJHJICEDMJLIHDDHIFMDJIIA@HEBHJKJJDDA@IEDJMDIGJJJLKBJLMBIJNFJJIEGMJMMCEKEEFJMIEDMJKEEFMFEMJMOEDJJKCJLJEIJJFIJJJODIEJIEDHDAABJNJHJE@HDDLJIEKDHIA@LIJMIEFDJHJLLIDDDEBJDLJGBDBDHHDBJJDJEHHHLHEBEFDMBFEEIDIABH@@" "BIABEABDDJBDDDHEBCBEBECDIDJEECDJDHDDBDIBJFKABBBBIBD@IBBABBIICBH@IBJBDJC@ICA@ADIIDEBDIH@IBHDJMCDHIABDJE@IEMGDJBEBADJDEBHGBFHKBG@JEABIDBEBBIGEMDHEBIBDDHIFEJI@JDH@LIBEADLID@DFDHFBIBBJDH@JFDLJBDBBDHABDJBBBDFKBJDIBAA@IBIFEEBIDIFEBEBFBE@IAABBIABDEBDDJ@@@" "DBEDHJDJIHHIIICADHEIDJDABABIBHBDIBIIDJDDBHHFEEDJDDJKBDLJEDJBHDBMBD@LJDLKBDFEKABBJJDIBCEEEBJIIDICBFHKBHKJJLJJMLIDJEEAEEEJLHG@IJMEEDEEBIDIMJJIJJNHJFHKBFDIDLJJEEEFBDIBJJBDFMCABFIIBIHABEJA@JBIEBIIBFJIABIEEC@HJAABIDLJDIB@JDJDBDABIDM@IDFDLLHHLJIBHIEBA@@@" "AEJBBDIDJCCBBBDFAEDBBDIBDJDBDEDIBBBBE@IJLEC@IAADIED@DIADIAABBIE@FIKABIBDEBHJDBDH@HIBDHDJ@BJKKCBDDHEDDG@EGKNIBAJIDHHFJKBEEGHOEEBFJK@HIDJLBDKNOE@GAAE@IABFFNJJ@BI@IBDHH@IBABHJEABDJDFLK@EDJBDDDIDDI@AEDIDDDHFEAJLHEBBBBDIEABABIBDIBBAEDCABBBFFBIDIBBBMD@@@" "JDADMIBAADDDHIBHJIADLIBFIBIDIABDFLMDHDJBAIDEBFEABHIGABDIBEFDMBDEHB@JDDIABEEABLIEECBDIBI@OMBNDDEBIFIBIEFJOOKBJNJJICBIDJEEJLGAJMEBIDJFDJJKJJFOOJKEDJDKDJEAACJEOHDJDIBFEEDIJDEEBDDIABHB@MABEICEBDIBDGDHJDECBEADLBBI@IEIKABDDIDJDKBDIIDDJHJDHIAADDBDMIDABH@@" "BIDI@BDJDJJIEBDEBBEBAEFHCDBICFHIHA@IBIHHJBBJDHJFDEBHEFIBEE@J@DIHBMFEABDJLJBJEBJJIDDMJEBE@BMCBIDIBHDIBJAENKFDEAAAEDDJKDJKFJHJKFJIFJIAEDDDEACFKMDBJDI@JDIDJFEJ@EBEBMIADJJJEBJBIJIBDECEJ@LI@BHEEBDKE@JEACBHIBJBBHHLJDHD@LHKFDJAF@KEDBEBBEABEDJJIBIB@DIDJ@@@" "DBJBEDMDI@IBIDJIDMBDJB@EDAFBD@EJBJEBDJAEEDJDIEDHIADBI@BJI@EDJIBCJA@HFDJBADHBHHIDBBI@@LHIGMFMDJIBJEKBDMJIGJMIJEFNEBKEEBJFIEGEDKBJEEFJECKEBLMJODJMIBFMBJDJIEKEODHIH@DJBADHHJ@IDBBIC@HDBNBDJIE@DJJ@DJADDHIEDIBIEEDBIBEBJBM@ABCDAE@BBIBEIDJIDJDHDIEIEBBJA@@@" "IE@JHI@ABKBDBBIBA@HIIDJIBK@HMEHADDJDI@KBAADIBBABBJBJBJL@BFJADJED@JEBIBDLLIBLEBBADIDEEAAFMBIBJIBDDH@DIJBBOEJBDJAADIDBJEDMEC@FEEIEBJADIDDBIBBMGJBBLI@@IABDJJDJEKDDEEADIDBBEAJDIIIBDJEBHAEBIDBKB@AJJBJBJBDBBDIDDBFHDIBIAD@MEHHFJDJIDLHHDBDJBABFJD@DHJHEDH@@" "BDEDEBKJE@DIEDDEFKEDBEBDDHEC@DEDIIDIBEDDMFABDLJEFEDHJBAMJHIBIBHJKBIEBDIAABEBIBNJIBAJDJFIIFJEABJIIEJIEEEENMJMEDLJEBEFIDKFJNGCJKFIDKEBEBIIEEJMKMEEEDJMDLJJDEBKDLKBIBLBDJKJDJEBDDDIBEDJFJHJDJDHJMLBBHIECEBIIBDCEIAEBDIDLIEA@FE@IABEBAEFKEAAEDI@EBNJEAEAB@@@" "DIIBIEDDJFIBDIIJ@HBADIDIECBDEIBIBBABDIACB@JDIADHHHIBIDJBDEBFDDC@HDFBEBDJJLHDBD@JDDJ@IBICBHJKFDHBBJBJIDJKMKMBDIADJEBHKEEAEEMMEDEEFHJEBIDDIBENMNJIDJJBJB@ICFJHJFDJDHBIABHABA@IJJIBEBCA@HFAACBEABBIDJDHHHIDDIBHBFDDIBDBBDJDMABFEDIDIDB@HBLLIBDKBIAEDJDLI@@@" "BBBIBDIADHBDIBB@JBHKBDABHHDIDBHBIDJDIBFHDJDIBJACBEBEDIDIABDHIIDEBIHLJDIDBABIHIEABMEEBJDJMEEFHKCEEAF@JIAEKDFIJKFCDHJGDJJNJJJJJKJJIGBHIFCFJLKAFMDDJHCDEEFFHKEEEJIBJEEEJDEDHLJDBADIBIHLJEADLHIBDDIDIEBEBFDBJDIBI@KBDIBIDJ@JADI@HJDABFHJBHBBDIB@IDDIBDJBB@@@" "IDHDDIBFIBLIBDHJDLJHDIJIBEBBIDEEBAAAJDHBIBIBHDJDDIFHBBABFDIBDEABDBBA@IBADJDJCBDFH@IBDDIGBAAEBHDDHLHI@BEGGJLBA@@LEFJJIEEBIEEEDJEEDJJKEAH@DBAJOGEB@DHIHIA@JEDDBGDIABDH@KABFBIBIDBDHDBBABDEABDICBDBB@KDIABI@JDJDJ@IBLDDBEEADJBEBDJLI@JIIBHIBDIJDKBDIA@IDH@@" "BACAIBDHBEAEDICBIAABIBBDEBDJDIIBDJFF@IBEBDDICABIAA@CIDJDHIBDI@JDIEDJEBDMBDI@HDIHCEBDIAELHJFJDJIACCECENJKEEGEFMECJINEKFBLFIGDKAJCFMCLJNEEKEGEEFJKMFEFFDDJIBKBHIMDDIBEF@LI@HDIBEIBEBIEDIBHDIBDHIBIDN@DDDJDFDIABEBDHCCBIBDLIBIBEABBDJDDDJFDIEDEB@IBDLFDB@@@" "DJDJBBIELHDJABDDDKDEBDHIHHIDIBBDIBHHIBDLEEIBDFDBJFEDDIDIEBDJDEBMBDIDJDI@HKBJJIBBLDHIBJBBEDIDIBBFDLBDB@EFKDJJIBJMBD@JEIMBHFHK@JELMBHABEJJDJJIFKE@BABAICBBDIDIEBBBJDHIAJBDJJJFHHDIBIDIBEJEABIBEDIDIAECBJACABDMEAIBDHHJDIBBDIDHHLHIBEAFIAABDBI@IMDJBBIBI@@@" "A@MADLB@ABI@JLJJI@BHDICBBEBIBIDIDDBECDIAHHBDI@JJDHJIACABBDI@IJD@DIBIDIBECHEAABEDAACBDEGJIAFIDHLHIBIBLMIEEIEEBDJJDKEEJFBMEIGDMEJCBMEFIBJIBEEDMEDMIJDJDHIHIDKDDJOEABFDDAEBDDE@NEBDIDJDI@ABLHDIBBDFDDJHIBJHDIB@HLDIFEBAADIDJDJEBBFDI@J@DJJIJHDJD@BAIDEHD@@@" "FK@JEADJJEBJBADIBFICEBDDJHDBDDIBAIDHDABDCBJIBE@HIBHBJHFDIABEBAAEEBIBABDJDBHFFDIAJJHDIBLDBEBBAEABDDBEABEGEDKJDJJJJDIBEHLHJEEEBHIHMBDIBJJJIBNIEGEBDEBAABDEDBBEBAAJDI@JJLDICC@JABIBDBDJEEDDBEBDDIC@JJ@JDHHEBDJJFABDA@IDLBDIABA@JIABEFDKBDIDBBJEBJIDEBHFK@@@" "@DEA@DEDIDDBLJBDHHJDHJIBDBJLIBBDJBEBIJFIDDHBIDMCBFBJDK@KDJDJDJFDHDDDMDI@JIBHHIFFBDBIBJIAFHJLMBJDIJLHJJJJFIEEIEEDEKCEBCCCIDJIDNFFBEFFMAEEDMEDKBJJJHIJLIBJEIJHKDDJJDJABCCDHHJDJHDIEIAA@ICBIBIBIFHFIBJCBFEIDJ@IADKBLJEBBIBBDIJJABDJHIBHHIBBIJAADIEA@DEA@@@@" "EABDFJHIBAEDADHICEABC@BDIDIABDHIDHHEFA@BIABLDB@DDHLDI@E@A@M@IDHIBIAI@ABM@JDBEB@HIAFDDMBF@BEABHIEBAAEBDELMDJNBDJIKBDDMDHLFIEDKAHIEIABFLJIBCJIEIMABEDDBEDHJDEB@CBEIACDDHHBEBABHEJD@DLDJDHIDHEHD@E@DIAHIA@BAAJDDJ@DCE@HIDHIBDDIDIB@FBDEFDHIDAEDBDHJKABDE@@@" "IFDIHHKBDJHJJICBDBFDHEEIBEBDHIEBAKBJ@JEEBFEAJEEIAEAIBEBEFE@EBAEBDJJBEFD@EABMBDMBDE@IJHDHNJMDHEB@DJJADJIEBIDLHKECBMEEBEFJIBHJDJKEBEEEJFEFHIIDJEDJIDBJI@BE@IEJKHI@JLHEABEIBEJDE@ACEBBJIBEDBE@ECEBEBDLEDDMEBLECBEEBHBJFLBEDHIBEBDME@ICBABFDJJHJIBFHHLICDH@@" "J@IBBE@DIBB@IBDDIDHIEDDBDHDJEFHDJ@DHJHJDDIBD@LDBJHDDDJDI@JEIDJADIAADI@IEIFD@DIBEAJEBAFJB@HJBE@HJIBDJIBCFMJICCBJDE@IBEDIABIGDJDDIEBDHEABJFFDJMKFBDJIBDJHHEBBHHBBKDBEBLEBDI@ACDMDHDIDDDIDBIDMBHDIBIAA@JJAAHABDIABHJHI@BI@KEBI@IBAAEDHIDIABDHBBDI@EBBDHBH@@" "AEBDIBFIBDLMBDJJBIBEBIIDIBIAB@BJDJICBCAAIDDIEAADJBIAK@JBEABBADJABDDIBEBDB@IJIBHHF@HIFHIEEBLIAFKBDDIEJLNLKABJLFMJJKFDLJJNFFHKCCJJIICFJJMKAJJDFIKIJMDIABFKDDIJEEDHKDHHC@HJDJLHBABEBDIABDBIDBBDEBBHFLDJBIDDEDIADLDFBFDJIBJ@BDDJDIDLJEBDJBJIBEIIBDKBDIBED@@@" "DJDJDDHJDIAADIA@JDDHDDBEBDDDHIDIADFHEDDFBBJBDDJI@MCB@FIFJDDHMABMDIIBEADIDJB@JDEDHJBDIEBDDDIDEA@DIJDIDACIDJDKA@JABDHKCEB@HIBDHHBEFFHIBDBHDFIBIDNDADIBLI@DEADIAABEDIBBHIEABHBBIDIDEBDLIEJDEHIABKDK@BFEHDJIABBJBCAAE@KADDIDHIAABEBAA@IABHDDIDDDIBHIABIBI@@@" "I@IABJB@JDJJBJDEDIIBIADHIAAICCBDFA@BHBJHHLIDIEBBE@DFJHD@DJJC@DD@ABBHHFABABLKDIDIEEDIE@DIIBJBJDEAB@JKMJNDKBJINKLLDIEDLIDKBJEBJFIDIIEDIAINKLJJFICJMNJHBDEABJBJDLI@EDIEEDIDIFIJDBDC@HJBD@AA@FBJI@A@JKA@EBBEDIDIHHJJ@J@DCABFFDLDDHIDDJDLIEABJBJIBHBBJDDHDH@@" "BEBDDEDMDIDDI@IIABBDBJABBFFBDDEBHJJDBDIEEABEBHDLJKA@BBIEIA@HFIIBKDIEBHJDJJA@BJIBI@EEJKIBBEDLHIHJHJIGDAEIDHDBMFIAIBABCFBDDJJJIABCFBDBDLDKEJA@IDMDAGDJHJHLHIIEBBDNJME@DJDJJ@DBJIBHJEDIFJDLK@HDDMDJB@DFJII@JEBDEEDIBABJHJEAABCCBBDBJABBDDLHDIADIEIEAABEB@@@" "DIDHJHIAABBHJEBBDIDIJDNEBHIDJJHHEBDMDMBAADDHJBIA@DFEEDJDBFEC@JBFDAB@DEBIBCNEDEBDBEHJJDCDHNJABBCBEEBFNKNKKKJJJJJJBDJHLIDIADEADDIDIHJIBBJJJJJNNNKNKKBEEBFBBDBKHIFABJHMBABEAECNBDJEA@BDACBBHFECBABIEECA@DDJBHIADDBEIEIBE@HJJIDHJECIBLIDIBBEBHJBDDDHJHIDI@@@" "IBBCEBBJFDICABEEBBAJEA@JFEDJDIECBIA@A@HJDAIBIDJDFI@JDE@IDHHDE@IHIEDJIHHBDNJLIJLIJDCBHIDACD@JIDHDIBDKHJDHDDDHGE@DHMBCCEAEFK@FKEDEFFBEHI@EG@IAA@IBHNIBDI@IDJHAFDADHJFABLIJLIJKIB@HLJIEDHLHEA@HIDHEABHDKABIDJDLABHHD@DDJFEDIBIECBHDEBLBBEEBDFDICBJBEFBBDH@@" "BDHL@DLDHIBDDIABDLJA@FEDIBE@IBBDDBDEFEADJJBEBE@JIBJHIHJJIEBJIEDCBBABBCBHMEEKFIIB@IDMEBIFDIEDBECABDIFMFOOKOKGNJGIC@DHDBFE@HG@HECBA@I@FDOBKOFONOOKEKDIBDFEBAEDICDJEEIDHBDLKFMEEHJFBBDBBFAEDJJEDJJHLHJJDJHEBEBBJIDECEABAABBDHEBDIEC@DBIIBDDIABDHIAI@AHIB@@@" "JIEAFIAIBDEBJDFDIADJFHJBDHHJJDHIADI@@IGADIDLDHEDDDBEBBIABBDHJDIDDLJEEDDK@KBBMCFDMFKHHMBHKDDIDHDFDIBGJMOJJNLJOEHBDEIBIDHJEBHJEBHIDJDMAB@MGJIKJJOMJOBDICA@IDIAFHJEHHNKEICFEJBFHFIAEEBIIADIBHIBBDDJBEBAAAE@IAIDIDGDH@DIDDHIBJHHIBBHKBIDDICABJEABDLDKDEDJH@@" "DJDJHJJBFIJJEAHJJJIBICDIBCEAAEEBFIBFJB@EABEAIBIBIIDIEEBFDLICAABJIAEDBIAHEDDMFDEEAABEC@JBEAJBIEJHIBEFOMEKGMBDOJGLJJBEBGFDJEEEBICGBEBBJIOBOIBEOFMEOKEBDHJMDJBLEBBHFEBDDEEACEIAE@LDJAEDDJJDDFDIICBEEDIDLJDJDLEBDE@BBKBDKBEEDDEFBDIFDJDJJJHLEBJLKBBJHJIBI@@@" "IAAABIADHJ@DHFBIABBDDDAEDLBFFHJFHBDHHHJJFDHJCEFDJBJJBDJHIABDEFE@JE@ILAFBJKE@HIFHJEEIDEAEKFAECBBEDEJKNCGNJODJKDOGJHJLDHHIDJBBIDHHIAJHJOGIFJIGJKOFCNJMAEBBFEDCFMDEADMEBHKDHHEFJJCDALHEBHECEABDDHJIBBJJBICEFBHICBJHHHIB@KBHKCBAIEDAAABBDDJC@I@BHIDDJDDDDH@@" "BJFFEBFEE@KIBIEBFDLJJJKBEADHHE@HEDIBACBDHMEDLB@IAEAADIBBDJJJJ@JGBJGBAK@HHLJEBKEMDKJBBJFKD@LDDDHIAJGNMNNIDHIHNIDMDCBAIGCBIDMIDJFGDLBFAEIDKHLHIDKKMKOBLDHIAAAHAFKBJBBNIEMFJEBIHHHFLBGBJGBHBJJJIBBDIDDEDDHBAIEEHIBFDBDIE@HE@HIDEBFJJJIICBEDJDNHEECBECCBJ@@@" "DDHHHDHI@EHBEDJDHIADIBDDHJIECBEBIABLJLFIE@IAADKFFDFFIBDFIBDDHMDHDDHDJDEKCIBLE@BCEFIEDHHDIEBIIEEFFEOEKDKGEGBCABEIOLDJBHDEFIBDKEA@JBIAOLMBDFBGEGFIFMGMCCEEDLJEDI@HIEDKEFB@EAJDNFMABI@IA@IEHIABDKABDKCACCFIDDDHEDKAJIJDDJEBFEDJHIABDIDDHIBIEB@M@DHI@HHIA@@@" "IIEECKBDELBLLE@KEBJIBDIEEACADDLEBEDABA@DDKBFJBD@HIHHBEEHJDIIC@IBJIBIIAD@EBMJLGDLMEBDEECEBDHJBDI@HKJMFKFJI@EDKDKBJJIEEBMIABEBDDMJEEDJJJFIFIE@DJKFKEJNHHDIBBHIBEFEEABEEIIGAJMJE@ADDLJDJJDHFDLIBHMEB@HLHHABBKBFIA@DBDAEBEAIADFDEEDIBDJJEFHEAIJAMABFNEEDLH@@" "BBBBD@DJJAEAAHJHBFEBDIBDJFDFBJALIBADDHFIIDDHHLIEEJBEFJDE@JBBDEBDHJEBBJIJJE@EAHEABNJIIBDDHJEAEIBEBOGJKDMBJEDJDIDFOMBHDE@BJDJIBJ@EA@JEOKADIBIEBJEIFJOGJEBDMDEBHIABDLJKJDE@LE@EBJLJJBEBHIBEABBBHEABKEBBMEDIHHIADLK@IADBDILBJCACBIBDIBECB@JHLDEDBJI@ABBBB@@@" "MEDHIFJHIEBDJBIBLHHHKBEI@HJHJBLABDJKABHJBAABCABDHAEI@DIAEHMDJJJKCBJDJBBBAJEFJBHJEEDFBDJJKDJFDBHJEGECDKJMDJIAABI@IDICEDEEBMEEJEEAEFDIDHDJDDDJIEJNIFEGEBHJACBIFJJIBCAEEBHJBKEBLBBBBIBJFFJJJIEHMDDI@DMD@IBDFBDDBBHJDFJIBDAJBHJHHDMBFHHHIJDJBIBEDHJKDHIEEH@@" "@IBKBHIBDJDJIEDEAEFBHDLBECABDJBJDIE@FHFIDMFEDEDICJDBEIBJDCAEDHDHDDDIIEEDKDJDEEBIDBKIDJBH@A@HJJEHLOGOMEGEKMJFJJBEGJJDDIIBEABDEBDLIABJOEBBJKBMNMGEEOOGIHMBJHHD@@JBIDNJADJEEABIFIEEDLIAA@I@IEDFABJDMBABNDIEAECEIDK@K@EDIBJBIBDFEBAI@JCEDEAEDJIBIBDHJFJDH@@@" "KBE@EBBDI@JIBBBJEA@MBIADIDFDIDHIAB@JHEHDIA@IBJCBDDIDJBEBIDJ@IBIBJIIBBDDIBJIEHDFEBMEFKEOCNNEEEEDCAMDHKKLMFCEHABLLIAAIEBBHJFECBHJBEDLDDIIJD@MFCEINNHIELFAEEEECKNGMFKEEJECA@MDJJDIABBDLJJDJDHBIDJEBBIDIABFBJDHDDI@M@JHBDDHIDICADIDDJEHDEBJBBDJHDIBBE@EBFH@@" "HDHFJDLIJJIBDLHHJFEBEFJIBBHIBBEDFJMBBHBIBJEBDDHDIAFJIDLDEBEGBDJEDJBEDIIBFIBBBIHHDABIFJHLIIMBJFIDDKKKEFGANNLBJDACGFDBHDJEDHJHIEBI@JACGFDABJAKKLGCEFNNIADKBJELLIHJKDJDA@HLJBBDKBDLIEBBIEBIBGEBEAAIDJKDDI@IABEBJDJ@JBEJKAEBBDHJBDJKEBECBHHIIBDJJLIIBK@I@H@@" "BIC@DIBDBBBDIAEBHHLHJ@DDDICBEDHIIBAEDIEBJDJFIIFIIEAABEAIIDHHDIAJBIEDIBDHIBEEEBBBIJDFJEGACFJMMIFJIOEFJIHKJKIEDJJJIHIJBIDIEE@EEDIDJBLHLJJJIEDNJNHLJKEGLJKDMMJKFDGEBKABLJBBEEEBDHIBDIEDJBLDI@HIDLLEBDDEDLKDLKBIBJEDIEDBDLHIEBFDIAA@BHIHHJEDDIBBBABDI@FDJ@@@" "EBDEEBHJHLMEDJDECEABHJIIMDDDJEKBDDJBACBDHIDHBB@DBBDDDHJBBBEBIJF@JBDIBMBKDIDDDIDLJBJHIDHFHAABBDIFKFNMEGGEGGBJA@HEOEBDLBIBHDGA@JDJAIBEGM@HDBJGGEGGEEKKFKDIBBDD@K@IDHJJBIIDIAADIFJEJDIBBHCBLJEBBBBHIAABBA@BB@IDHIBFDBBIABFMBIAAELLJHJDEFEABIEEIHJHJEEABE@@@" "JDIBHDK@KA@DIBIJDDJBEBDB@IIIDH@EBIADJHDICBBBMDMIDLJJIEBHLLIED@HKDLIBJ@I@CFIJJEAAADIEBJEHJNFLJIBMHMINJJEEMFM@JGCKJIEAAMBECIHLNEBELDEDJNNGBHEKEMEBJKLMHMJDJIKCJHMBJEDIDDDEBJLKF@DHBJDIIFHHAEDIIHJEDJJIIDMIEJBBFDI@JIDDJE@@IDLLHBABEBBIABLJDI@DFHFI@JDIBH@@" "DIBDBJHE@DKIBDD@JIDLHFIHJBBDIBJHIBFEABIBDEDJ@EBBIADHDHLKAABBAEEDBABHIEDJLHBAEBFJFEBBJDJEA@HADJJCFKGOMDJIBEBGDHDBMKBFJ@DHLDGAAHI@BKBFMJA@IGBEBDJIEOOFKFBJID@HDEBIBJBECBKBEDB@IJIEDHJDBAEEDBBDDFIHI@IDDJBE@BIEABDJDECBDHJJDIBBBHLK@IIDJHAABDNI@E@JJABDI@@@" "IBDIDIBJFJDBDIAE@JAABHBEDIEABFHEDDHHDECDJHJIDHHHBDIBIBA@DDIDJDDIDJEEBDIBABLLHHHDHHIDDIEDJEBJIAADIJJJJKNBIBLHAFJKKDDHIDJEAC@FDEBIDHIAFNJKD@IJDJCNJJJJLIDDDJJEBIEDIADHHI@HHIIJDBDIBEEBIDIABIDIA@DBDJDIB@HHIDJHJIFEA@HIAE@KBDEDIEB@JDDBHEDDIBABKBJDIDIBDH@@" "BDIBEBDHHIIDJBF@E@LJEEEAABDJDHAIAAEBIHDBBF@BABEADMBDJDLJIEBEDJIBADJADIBHJBAABEBIFEDJIDHIDJDIBDDJGFKNEEBIFEABK@HIEICEDIHHJHG@JHHLIEFDMDHHFJDECDJEECNKGBIABDIBIDHIDJIECDJEBDDBBHJDIDBIDBDJIEBEDJIIBIBEIDEBDB@CBBA@LJEDDDL@IBIBDDEEEBIHE@CBBIDLHHIBEBDIB@@@" "JIBDHDICBDBI@LHJIEA@LBDJJDIBIEFBJKBEBBJJM@NIDEBFAADI@IBIBHEDIDDHKBHNEBICDNJJEDEB@IBABBCBA@IBDIEBIKDMMFMB@LEFHECDMKDAABBJIBHJDJJBDDAFMIFE@KEAHBEKEMIFLJEDIBDHDBFBBDBDHBEAEBJKIFDJECHJFHIADIE@JDJDHDIDDCBEADKHEJJJBEBFJJCEDJDIBJIBAHDEDJHIHDJABFDI@IBDJH@@" "DDEAEIBDDIDDEAB@B@DEAHJBDIEDBBHJ@@DJEDI@@E@BA@DHFDCBEBIBDC@IBAABHDEA@EBDI@DDHIDDMBDNDLLEFEBDIBHHEEKHBIEEEEDCCADAA@IFEEDIBDJIBDIEECDHDDADFFAEEEEDJ@NME@HJDIBECEAIICIBEIADHIA@DIBE@DEA@JDDBDHFABDJEBFAC@I@DB@E@@DIEBI@@BHJBAEDIBBHLEA@B@BDEAADIABDMDEAA@@@" "AADJDBDIABE@IDDEDJHLDC@LICBAEDA@JJJEBADFJJDHJDJBHIHDHDDEADFBDJFDJK@JFJDKBEAAEFEI@DI@IAAHHJDIJDBBJMEGMGFJDHINDFBJEKBHJBIBDIEDIBDJBHJFMBJCACLHIBKGEOEEJJBABLIBHHLDDHDI@DMCEDDEBFIBKBHFJICBIBCADEAA@I@LHJBIBHIBJKADBEBJJHDAEDBFDIHFAAHJIEAADHEBDDIBABIDD@@@" "JJI@IDIBJDHIBA@HB@AAIDEABDDJIBDJ@A@HDJCABDIB@AIDEBBIAJJHDA@LIDHIA@EDHDIBDJFFBDHBEIBEBJJCBHIBBADLIJJHBLEDIBBAAHJEEDEBEDBDIBHJDIBAEBEAEEBHLDBBDIEAJ@JJLIIDBBDHJFBJJEBDMB@IBCCBIBDI@IE@DDHIDIHDA@JJLDJBEADL@BDIBDFBI@HD@BIBDJIABDEADLD@B@HDBDHIBJDIDHDJJH@@" "BBBEDIBF@JEBDKEBHIBDBBJDHIADBDI@JFEEIBHDDIBDIBDJHDIBJ@IBJJEABABBDJIADIBEBDHHICCDJBDIE@IDECBEDJIABJKOMAJIBFMDFBDHEIBDIEHIBEBEBDHMDIBDM@IBCAEKBDJLEONJJDDJIEBFEADHEDIBBIFFDHHIBEBDIDDJIBBDBDEBJJDHBJDI@JIBDIBDIA@JDMECBHDIBADDHIBJBABDHJEFIBEBHCBDIEBBB@@@" "HIEAABDHJHHHID@DEBDIDJ@HBBEADIBE@HIDBDBIADDIBEA@BIDD@JDDH@HDDJDHJBBDABDJDIBBDFDJHHIB@FBEBDDIBDBJEMJHFNEBDH@BHHIBIBHIEDEEDIEDIEEAEDHJDJDHHJ@@IBECK@JMMBJABDIABEBC@BDHHJICABBDIBIBDABBBHIBIA@H@IABHAADJ@DEBDIADDJABADHHEBDIDEBB@HBIDIBEA@ADHHHJHIBDDEDHH@@" "EBBDJHMEEECBBBJI@DIAABMCLLJJEBD@BCBADIDBFCEBBHJIDJAAEBJJAFJIEDIEDIFIJDIEABEDIDIECCBDJHLIEAABDII@IJEGMHIEABJMECDDJLEDEBIBBEEEBBDJEAEAJIAFEEJJDEDHMOEBLHDLIBDDEDIHJIBFFEDIDIEBDEDIBLKDIEDIEDJKDBJJEDDBIDJHJBEFCBADIDBFB@ABEBJIINEJDDDI@DJJBBFEEEEHJIBBE@@@" "@DHIAB@@@@DDLH@BDHHDBD@HAA@@HE@JDDDJABADHH@DHB@BA@JD@D@@J@@B@ACAAB@BAABFJEDEBBJHDDDIBEAB@BEDIBBEEBJLIGFJJMFKJDBKAIIAEDDHLHHHIHIAEDDLLFJABNKEJJKGDIJJEEBBDIEB@BDEBDIAA@JJBEAEBKBDDB@BDDFD@B@@BH@A@ABHDB@B@I@@HIDBDBIAABHE@H@DD@HABA@HIB@@IIA@@@@BDDHI@@@@" "DIEBDEEEIDIAAKBDIBAADJJBJJJIBHE@@IEBLDJAEBFIBHEEBE@HIAEE@EDLNLDDBDJHDFEHBIBHEEKBIBIJDHJDIFMABEEBILECGMMKEKDFMJHHEDBEBBJBACBFDBBJBEBAE@HJMKAFMFMMOFEALJEEBDEKDIBHIBLJDJFME@JDJ@MCA@JIBAAAKIIE@EEDDHHEBEE@JDKBEDBIAJEDH@E@JDJJJJBJIDDBDIBFLDDIDMEEABEDI@@@" "IDBHI@@@AABJD@DJBHJDA@@I@@@BHB@BE@@DAA@J@DHBHBJ@DHJABJ@@BHAA@AAADIBBI@LBDBDJDDDDIDB@IE@IC@@DDHHDBIBJNJHJM@CHKEFBIIEBDHIEFHMHKEDHIBEDLJCEFHN@EJHJKJJDJA@HIA@@FDHEDHBADIAAABIBABAHDJBDIDDD@DD@J@@BJDBHI@BJ@J@I@BHDDA@@EB@B@J@@@DH@DABHJBI@ABJDD@@@DHJADH@@" "BCDCBJMBJDD@IFA@HB@IDEDDDJEDBDMDHEDJHDE@EABDAD@EBB@JD@JJLBDDEDBJABDEBEADMDI@IIBIBBDJB@EDDFJIIBBHMOFJKNGKFNLKGNHLJBDDIABDHE@E@IBDDIABBIHKOFIKKFOCNJKGMHJBDLJKAAE@BBIBBDJDLHDIEIDEBEABDBJAEAABAJJHABHBBE@ADABDE@EA@JIE@IEIBAEBIAAEADHB@HDCDHAABJEJJFAFB@@@" "DHEHDD@DAA@JB@LBBHJ@A@AHI@HA@H@BBHA@AA@BHDDMB@DHDHIAAD@@@HIA@@H@JDIHDLFE@EBIBBDJDHI@DKBII@ABBEDJALEEOEJDKAADDENIAHIIBCDICJJJNDIFBDLHLDKMAADDFIBMGMEALBIEBBD@DLJFI@DHIBIBBDJE@ECAI@LIBH@H@DDHH@@ADDDHI@I@BEIA@J@DD@D@JB@@HD@HDHL@D@BHJBAHBBHDDA@AA@M@I@@@" "IBHBIAJHLBE@DMADDB@JJEBAJEEJECJHDEDFJDEDEJJ@DJMCABBDDAEBIBBDFJBEBIBCAAJHJHDBEFI@IBBJIDDBBJFDI@B@KGKOJJNOFOGKKOEKEEDBDLABEGEGEBDAIBAEEFMGNNOGKGKJJONOFHB@DICBJBAADJJBDHDKEBA@JHJLDFBDJEBBKABBDJEDAABBDFEJI@BJMAEABKAEA@JNEBMEBLBEBJHBAADEI@EBAHJLDJ@JDH@@" "EEBIBD@CAE@JI@D@IDJ@@JDJ@HH@HD@BI@A@@I@A@@@JI@@DEDMAAD@DBHHI@ADDDDDHDJDE@JIDJDBEEDJDJAADI@HIBEDJIJEONOKJNJIBJJKDAIADJAFHKNJKNHKDBIDDLAFJJJDJKJNOKOMBLJIEBDHHDIDDBIBIEEBABIDJHEABI@IAAAAD@DHHJA@ADDEIEA@@DJH@@D@DH@D@DJ@A@H@HHBIBH@BIDHA@DJHEDF@ABDJEE@@@" "BBDJDJJHD@B@BEBKBA@FJ@I@EBBJBIEDBBJEBBBJEBEEDEEHHB@JDADHHBABED@HKEMCEEKJKABIDKDIBAAA@LKABEEBDIABBFMKEDFDIEBEEEDOEFEA@JIGEGOOEGDJHDECEGIEEEBEDICAEFMKBBDDIBEEBDFIHDDDBDIFIDJDFJNMEFEMFHHAEBDB@HIDABHB@HMEAEEBEBJBBEBJBAEDJBJBE@DHBK@DBFJEB@B@A@JJIBIBB@@@" "DHIABHHBIBHEE@H@@DDH@JBBHHH@JB@ADD@HDHDE@DH@A@@CCDJ@ADAABHIDHAEBHBHNJJDEDDDBEBABDJJDEA@BFJIDIBDDKLKNHIHIFJNIJJIJIHJFKAGJKMGENJODFKBHLJLJJLKJKDHLHKNINIABDIDJKB@DEABJIBDBEBAAAEABJKHJ@JED@IDHJDDAD@BIFF@@D@@I@EA@I@HAAD@BBH@HHJBBH@IA@@@HEE@JDJ@HJDDHI@@@" "IBJDICCDJDBH@DJJJIAEE@HDBBAE@HJJ@JJBIBI@EAEJJDJHDEBJJADDDABABJ@EBMCABDIDIJILHKDIABBIDJFM@DBBBDIIBKEEJBCBHIAFBJFMCOA@HDNGGKONOGCI@HDGNEKBJCDDHJFBBMEFJDLIBBBA@EKBIDJBDDIFHILJLIDIBDFEJE@BJDBDAAADBJJEA@JIBJMDE@DJDJBJHBJHHEDBBA@HEEDDJJJI@@JABIFFDIBJDH@@" "FDDIBDDA@I@AEA@B@@J@@DDJHHJ@BB@@JH@HDD@E@E@@@IABI@D@@D@I@HDJD@E@DBDDHIEABEBEJJABFDHBA@H@EADHLIBDEMJOEDHEBDDIMDHJDHLKGIKJJFMKBJNLOFIHIBHIELIABE@IEGJMMABDIHIDE@@HDB@ICBDBJMBEBDEDHIABA@E@ABI@HDHA@@A@DJDDH@@E@E@AA@H@JH@BB@BHHJIA@@BH@B@DED@DHDAABDIAC@@@" "DJIJBIEFJBDJ@FIEEF@JJHI@BB@EDHIE@AEAABJHBHEEE@DDBBIDJIE@EBHHBJHDILIBEBHDIBMLD@JHHIBLJEEDJJAKABEAIJEEJEBLDIJOEIBMIJKANKFJNKJNKJKFKLFJLMJDMGJLIAJEBMEBLLEBDFLBJIEEBIJDHHJHAAMJDI@JEBDILI@JJ@HJE@EDJIDJBAA@EEE@J@JJDDED@EDHIE@BB@DHJJHCEEDK@BIBBKEDJBLJI@@@" "J@D@HB@@BMA@DHB@@@D@@A@DHHJHAAB@BJ@IDH@@HA@@@BHHHDBA@@@E@@BBL@BIDABDHFAABEAAIEBABBDAE@HA@@J@DDHDCDJJHHNKIBAFOJDJAEBKIEMJIEEEDJMMDNJEDBIBOKDBDNKHHJJIFA@IA@BH@D@HEDABBDBEDLDEBDDC@IBDADJ@AJB@@E@@@DBA@HHJ@@@D@H@@IDHBJ@BDD@JHHI@D@@A@@@B@I@DEJ@@B@HA@BH@@" "EBIEBHMED@DBIBLIDJIBMBFIBB@BJB@MD@JBAEECBJFJKDBABMDJEEE@EEDJACDBKLDIBHJFEADEEADJDHID@EBJEE@JIIJJJKMKMEKOBEDOMDIOKLIFOOGMFJOJKEOGOKDINOLIEOIEBGNMENMNJJJLLJHEEBJE@ADHIBIDEEADECBHJDIANJAFDBIEE@EEEBIEJDBAFJKBJFEEDBBHAEHBBJ@BBDKBEJDJIDIJDJA@AEEHJEDJE@@@" "@EB@DB@@AEADAD@BA@BD@DHJHHJH@EE@AEAED@@DD@H@@ADJD@A@H@@BH@A@JDAEDBIBEE@HHBEJ@FAABCBEEBHHH@E@BB@@JFIFJABJHJAMKIBNDIBKKJOFEEBEECGJNNJDICJDNMLBHJJDBKDKBH@BB@E@@HHJEEBFBDDC@BMB@HHEEBDJAEDABHD@@J@@@HD@ABID@@@HAA@@AEDED@EE@@JHHJHI@AB@DB@ADADED@@BA@BE@@@@" "M@DEAEEED@DAE@IHJBHHJHB@BA@BJH@BJ@D@@IJIAKEBJJA@IEBDBIBDBIBJ@@JBIEBDJBEEBDHACABDHDLHIDEBBI@DIDJGEMFIMBNOI@JKGBIMKNMMOENKMKMNMNKMGMMKNMLJGFJHDOKJELKEMGBIDI@DJBEADHII@IBDFD@IBEEBBIBEDJBH@BJDJABDJABEDHDBJJEFLDJLH@A@BJ@@JJ@DB@B@JHHJBHLHEDA@AEEEDEA@EH@@" "@EBHD@@@BE@HBABB@DBAHBHJHBED@BID@E@JJB@BD@@D@@JEB@D@HBDHHBD@DI@LABDIDHIBDIADHDDIBKABBA@HHBEABADHJIMGLEEJBEABEFCOLKKGENKFBEBEBCFKMGFNIONCEBDEBBMEAOELJHIDBDEB@HHDBBDFJDIA@IDDIBDHIDIBDAHDI@AB@HIB@HA@BEBH@A@@AB@BBJHE@ADJ@AEB@JHJ@LBA@BBDB@HEB@@@A@JE@@@@" "K@DAAFJJHHEBLJEDJIDJBHB@AE@ADHBADHE@@IEDJJJHJJ@HEEAEBHJABHIBIBKBJHIDIEBDICFEBIABDHEDLKECFHHBDLIGOENMBHIBLIBEJHMDOGENKBOADJEBIDGJFKMGGIEHJMBDIJDHJEKMGODIIB@HKFEFIIE@IBDDJECFDIBEDIDHJJFJDJDHJDBHJEDEE@HBJHJJJIEDH@E@IDB@ID@ED@B@JBIDJIEBIJE@HJJKDDA@FH@@" "DEBJD@@@BBHBADLIBBA@IBEEB@EDAAEDABHJJD@EDD@B@@JBH@D@DB@JDBJDID@L@CBABDEABD@HJDDDIBJAA@BD@JBDIABJJKJKHEDDABDJBECCMEIEBLLJIIBDLJIIJEDMENFEBBIBDAAE@NJNJJJDDIBBHAB@DDBJDIAABHHABDEABDBF@AHADIBJABHBA@A@@JBH@B@AAE@ABJHJDAEDDAE@BEEBDHDBBDIIDB@JB@@@ABJEA@@@" "BHD@IJEEDDBDMAABDLJEDDH@DE@ADB@ADDB@@AE@AAJHEE@HBJIE@HJ@HHAABACAEDDJDIHJEEEBDHIIBDHJJFHJJ@HIBBKGKMFMFHAJDLIEMJHDICBNECBIBBEBBDJFECJFDI@JMMDIIBL@KEKENOFJBDHHBJHKBJHIBDLHIBEEEBHLIBIAEDFDBDD@HHBHHEDJJ@HEE@JLD@ED@@BAAD@BAD@EA@@IAEBIIBDDEIBAAEEBLHA@J@@@" "DBJJB@H@@IDJ@JJHIA@HAABJHHEDAEEDAADJJJHEDD@@H@BED@B@EB@EAADDIDFL@AADIBBA@DHDICBBDIKBDHB@DJEBDMFKEJJKHBH@JADJBGFKFDM@JDDJEJJJMBIABHEICFKGBBIDBH@J@NJJMFKEIBEBI@B@IBFLIBBFDI@I@DBBDIDD@AKADIADDE@BE@B@AEB@@H@AAE@JJJIDDAEEDAE@HJJDD@HDDHJJHBIDH@@HBBJJA@@@" "JHD@HJBJIDA@KBJEBDBBJDD@AA@AD@@ADDA@@@A@AAEEBJD@BDHJHDDHBBAABABAAKEABEDJFJBIBDDHIB@DIEDJIA@DIBMFKEEEEDCEDJIADHLH@EBE@JIBHBBB@JDJHEBE@@IHIDDJIEFAEEEEFKEJDI@DDJIEDI@BDHIABDJBKBIEBDEFLDBDBDDBB@IA@JHIB@ABJEEDD@D@@@DAAD@@AD@DD@AABJBABEBJFHDADJJBHHA@JH@@" "@A@JB@D@BADE@D@HHHMDEAAEBBEDAEEDAADEEEBBJB@@D@HJHIB@E@IEDDJDDJEDB@@BDIABHDIBDJIBFEJIBBJIBDEADIOGJJJODAD@EIBFIGIBJHHIE@JDELOIMABHEDHHJJDODKBDM@ADAGJJJOGLIDEABDJJBDJMCBDJIBDI@JDDIB@@BAEBIABIAEDHE@BDHJHHA@@BBJBEEEADDAEEDAEBBEDDEAEHHHHA@EADB@A@BBHD@@@@" "JJE@HJIEEDBHEBMECE@A@BJ@DDHAD@@ADBBH@@DD@DIE@JA@BBDE@ED@@IAAI@CADKCDIBFDBIBDIDBM@HABDH@DDJHDACJOJJJIJJEBJBDIBHJEECEB@E@IBEBEBDHE@BEFEEBHJDIBBJEBJLJJJOJNDA@JIA@@IBD@HEJADIBDJACBDIFFIDF@DLDDH@AE@EABB@DBHEDI@AA@@@JBAD@@AD@IA@BJ@D@EFEEJE@JAEEDJHHEBJH@@" "@@@EA@@@@@HBHDABD@DJED@EAAADAEEDADHBJJHHJIB@A@JBHHHHE@AEEDDDBAEDA@DBDDHJLDDIBAB@ECFDJKEII@A@JOCFEFJOD@HDDLIFMBIBJFDHLHEFIJOJLKE@IHICBJDJEKDIIA@HAGJKECFGJHD@DLMFJICFE@BDBDIAAJHIABA@DAEDBAAAEED@E@HHHJBHD@BDJHHJJJ@IDAEEDADDDE@AEBI@ABDA@J@H@@@@DE@@@@@@" "JLM@BBEEEEBHAAJHJJIA@@JHDDB@J@@@JABH@@AA@B@JJE@DBBAJHED@@AAAEFAIDEADJEBEAJIBDJFJJDHIJ@BBBEECBAOGJIEAMDJIAAJJJDJMBIOAACEBEBJJEBEFDDGLJEJIBJJLDDJIELEDJOGLBFEEBBB@BLHIBJKBIBDJLEBEBIDEADLCEDDD@@AE@JLBBA@EBJHB@DD@@@JDBH@@BHBAA@JH@DDJJHJLD@JEEEEBB@EIJH@@" "@A@EDHH@@@DABB@B@@DDBE@BIADE@EEE@DHBEEBBEDE@@HBIDHJ@A@@JJHDDB@OBA@BA@HDHDDDDI@HB@JBD@JHIDH@DDMDBIFJOHA@BDJAEEK@HDDHBJDFDJMOMJICABJ@IA@HFMEDBIB@D@OJKDJAEIA@@IDHJHABBHB@HDIAAA@I@HDB@DBGHBAA@JJH@D@BHIDJ@H@EAEBBEEB@I@EEE@EADDJ@EBAA@@B@BBDA@@@@HIE@D@@@@" "EDE@ABABJJJJDEEDJJJIDHED@B@HE@@@BJBHH@DDH@HEEBDBAB@IDEE@@BHIDE@DJEEDECACEAEIBEEDE@IAFBCBEEFIAAJOFJEEMDEDIAFEEHBJJIEEDLHIKJGBNLHIIEEDJJJ@MECDDIEAEMEBKGJLDDKEEBFBCDDHEAEEBDMDEFDFEAEEBI@EADHJ@@EEADHBDBABEE@H@IA@@HJBJ@@@E@HB@AE@IDJJJIEEABJJJJDBD@EAE@@@" "H@HED@JD@@@@HH@J@@HB@A@@JHIB@EDJH@HBBE@HBIA@@DHDD@JBA@@DJHADEJJI@JD@HDDDDD@BDI@BHEBI@HDDH@@BDEEBIDJK@@HABEFIKBDBDKKEAABJKEOMFJJDDEFNIBABFLKEBD@H@FJIDJEEAB@@@IA@HDJE@J@DIB@AAAAA@HABHDJJMAD@JI@@DBBHAA@I@@DDJ@HEBB@H@JIE@BDHJH@D@B@H@BH@HH@@@ABHAE@H@H@@" "EEBHAB@@IFJJABJ@JJBHJJBI@BBDE@A@BJBHHHAA@BBDMAAHIE@DJEEA@AFADE@BB@IEFIABHJMDIBEDBIDBEBJJCEEDBJJNFJEDMEBJDJEJJLIEABEFDJICLJOJINDJICEBDEDIJJMBIBJEEIEBKCJJJAEEFBJJEBADJAEBDIEJHJDDKEDHBB@EADCD@DEEBI@EDHLDEIBB@DD@HHJBJ@D@EABB@DJBJHJBJHBJDBJKDH@BD@JEE@@@" "H@DBDDEEB@@@J@AE@@HB@@DBBHH@HEDBH@HBBBDBBHHI@DBBJ@DIA@@DBJADAJBHHKBA@DBJEHABEDHAHBA@LDDID@@ADHMDMEIEHADECAEEAABDDDHAAIBMCJJJNEJDLD@IAABDDEEDFEAD@MDMEIEHID@@ADIAAHDB@L@IEBD@MBJA@DBFHHJBLADBJA@@DDI@BJBA@DHHJBABBB@H@JAE@H@HJBA@@B@H@ED@BH@@BEEAABA@@H@@" "EJJHHHH@DEDJ@ED@JJBHJJIDDB@JA@@DAEADHDIDDABDEIDH@IADDBJ@D@LAGA@BADBJEADDHBJEBBEBBFJI@JIDAEEFJEJJEDBEBJEHHDJHJJHIIMADBBDJEEGEEBIBBADELLHJJHJI@HMBJEBAEBJMBKEEDADJHDJKBBEBBEBJ@IADEBJADB@DGDAHA@BJAADDH@IDMABDAADI@IDEDA@@DBHBAADJJHJBJHAE@BIEA@@HHHJJM@@@" "@@DDABAE@LA@DH@J@@HA@@B@HDE@BEDHJ@B@BH@@HJ@HHBBAB@BAAD@JHJADDDBDJBD@HDAADH@HDHHDHH@BI@BAB@@AAHBJJEEIDADFBIEEBABGBBBADLIEKEGEFMDIIDBBBGBDBEEDJCADADMEBJJ@LD@@BDB@DJ@@HI@HI@H@IDDA@HABBIBAAADBHJHADDB@BDBB@HHBHH@@J@B@BHIEB@EA@HB@@D@H@BH@I@DAHEDBDAA@@@@@" "JIA@JHJ@E@JDIAK@JJABDDHIBHHBD@AB@EDJHAEAA@MEBJMFDIHJD@J@A@J@MIDI@HIEBIFJIJEEECEACEJHCFIBDJJDDCJMMIEEJJAAECEJDNDJDHHJAAFEBJOJJECDDBHHIBICIBMFEDDBJMEDMMJNAABJIBDKF@JMFDEFEEEBLJKDJEDHHDIDMHBHD@BHABHLICEJJEEHDDED@JIE@BD@AB@HJDHIABDBJHFLDIBHE@BHJHDDJH@@" "BBFE@E@K@E@H@B@E@@BE@HJB@AADHJH@JHA@BJ@B@EA@DDA@IBBHHJ@DJBAEJB@DBBBBDB@EJ@IADDAFD@@AH@BEA@@IAHBJBGBKH@NLJDB@I@IEEBB@JD@LDJJJIAHABHBBEEDHDHBABIKH@NJGBBJ@LDH@DEB@@L@@ACDAADDHBM@BABBBBA@BBMDBBI@BHHJBDHDAA@DE@B@BJ@D@JH@JHIDD@BBHHEB@@E@B@@HE@FHE@ECBB@@@" "DHHHA@E@FHB@JDE@EBD@BA@HBBB@A@BJ@ADDH@JDE@DEAIDEDE@AA@JI@JJBHIBADDHHIEEBHJBD@IF@JJIJBJDHBJJADBIEDHEEBJ@A@IEEBJJKFDHJ@IEAJIGDJLEDHBHICFJJJEEDHD@BJEE@IEDJADBJJ@IBJBLJJHCDHABBHJEEDHHIADBDHJBJHDJHDD@EAEADLEA@EABH@IAD@BJ@D@BBB@HDB@ABE@EABHB@K@E@D@HHI@@@" "HBEBFE@E@BDE@HHE@DIEDDBADDDEBDH@JJAABJ@@HAA@DBBJA@BJDB@@B@@MDBDJ@IACBH@IJ@DHME@J@@B@H@IDH@@JADJJEBJJL@JJKBJNEEEFHIB@JBDDEBOJEAABBHBDHKEEECJJFJJHAJJJEBJIDBH@@IDH@HB@@BHEEHI@BLH@JFDDHBIBAEH@B@@BABJ@DBJBA@DD@H@BJDDBJH@IBEAAADBAAEDI@E@HHEAB@E@ECBEB@H@@" "ADJDHHFHEDHHBBA@E@B@@HDJ@HHIDIAB@@DD@@EEAFJJJHLHJEF@IDJJDEBJ@JIDEBBDDACEHJIC@HEBEE@IBJBABKE@JIEDJFKEHIFOEMGEKLKHB@@EAEIK@MGEHFLMDE@@B@NINMGEMGKDHMFKBIEDJHEFJDBBJDHEEBE@HFDJHMFDAABBEADJHBJEABJIDHCEBHIHJJJKDEE@@AA@@BDDIDHHHBI@H@B@E@DBB@HIE@K@HIBID@@@" "JAAABBHBH@A@D@DBH@HJJBI@JAA@@@BDBJI@EE@@B@@@@BABHH@JB@@@HHDEE@D@HDDI@JDCJ@KDFEADD@EBD@HD@@@E@BJEEIDEEBAMKFMKJMMBEBJHDGFFEBJJECCGA@JJEBEMJNMKFMLBEEADMEBJ@E@@@A@HABE@AADECAFHBNABHDIA@HA@EEA@HH@@BBH@HJDB@@@@B@@EE@DJJAB@@@DDBHDJBJHH@JA@A@D@@J@JBDDDBH@@" "@JDJDDDHBIBBHJHHAEB@@HBB@DBBBJH@D@BBH@EEDIDIDHJ@AAEDLIEDBBML@EAEAAABI@IEHJAE@HJBIE@DHJBIEBJHEDDJJEJMLDDEELKGCMCLHD@A@IHMHJGBHMHLHD@A@INENGFIMEAAAMJMBJIAE@JJEDJBHI@EDJBHHEDBHMDHDJDDDEDE@AMJBAEDIIEDD@BHIDIDIEE@@JB@A@@JJBBA@BB@H@BED@HJHJBDJ@IAABIBH@@@" "E@IABIABHBDHA@AAD@DEEA@DDIDDD@ADIEDDAE@@ABABAB@EDD@AAB@AHHIAE@B@BDB@BEEGJ@JNEBDHB@EAE@@B@D@B@AMDEKJJI@HMJJMBBIOAA@IBEGMOA@JHDGMOEBDHDDGLJBEJJMHHDJJNMAEL@B@A@B@@EDE@B@IBECJHBOEEB@BAB@B@EDDHHL@BDD@AAE@BDBDBD@@EDAAEDID@AAADIA@DEEA@ADD@D@IB@JDDJDDHE@@@" "HEBDDBDDBH@ABEDB@JHH@BBHI@@HHJDAB@@HJ@ADJBJ@DEE@A@JJD@EDFCBD@FHJDADKDJJMLICMDJIBHE@D@EFDEBMDIJEGJCEFHBAEINKGGFELBABDHBJEFFJKCEBJ@IBDBAMCGGFKLMDB@KEFBOEBLIEJEACE@A@E@JDJIENDIMJJIFIDABHK@ABFCAE@ABJHD@EEA@BJBID@BHH@BDABHHH@DHJB@@HJHBAEBD@@JAABAABE@H@@" "BHFIADIADBJJD@@DI@BAEDDB@AABA@HH@EEB@DJA@H@JJH@EDEADIE@A@HHIE@B@HHADAGOKIBFJJ@DDJHBHJH@HHD@ABAIMDJLMBHJFK@DJHHKADB@IBKHKHHJHHNHNJDHBADFHHJI@FKBHJEIJIELLBD@A@HH@JHJ@JIA@BJKBDNOODAD@HHB@EDHHHD@EDIDEAE@@JJH@HDBI@BEE@@HHDBDD@BAAEDB@DI@@ABJJADDIDDK@J@@@" "LJHDFIBD@H@@@JHIDE@E@@HHBBB@BBAADH@@BI@HBBE@@CE@A@DAD@EDDCAB@DHIBBDADKEEJDEMDJIA@CDA@EEEAAEDDJJCAKJIDB@HHEJEBIDLIDEBDBEDEBBBEAEBABEADIIDJEBM@HHBADJNLFBJIAEDDEEE@DAF@DDJIEMABMEFIDABBDHI@BDFAAE@ADA@D@EF@@EBB@HDJ@@@IDDBB@BBB@HH@E@EADHJH@@@HABDKA@JIH@@" "A@EAHBHHIADIE@ABA@BHABAADDDEDDDBAAEED@BBEDHBID@EDBIDAE@A@JDDBIBB@HHJAFJKOAGBJBBJEDABBH@@DJJA@IHOFBEGI@IEBH@HDBAAB@HDJLHA@DJI@D@IJI@HBDDBA@H@JEDHDOEBCGHLHDBJI@@@JBDAEBJBBJGDGNJKDBHHHBBDJAABHD@EDADJAE@ADJ@IEBB@AEEDDBAAAEAAADDBD@J@DBD@EDIDDHHJ@LE@D@@@" "DJHJCDBABBAB@ABHJEDABDJBA@I@@HIDHB@@@JD@HABDBAB@@DBAD@EEEEABLBHDEAAAEFDBHNLHDLD@H@DDDEEEA@@JEACFIMJKBBBAEEEE@HJEDIBI@BJJEAGDEBJJ@DJDIEBHHEEEEDBBBFJMLKFDEBH@DEEEAAA@@HAAI@IKHJACEDDDEA@JAJDEEEE@ADBA@@BDBABD@HABH@@B@IDHH@DHDBBIBDAEBHJD@BDBBDBAFBHJI@@@" "E@EADBHJHDD@DJDE@@ABD@@DDA@BIB@@ADJEB@HJBH@HHJDHJHHJAE@@@BADADBHHBBJ@LIEECBAAJJJBIA@I@@@BBI@HALEBBEMDD@@@@@@EA@HBB@@DH@@HDMI@H@@I@@BB@HDE@@@@@@AAEMBBEAL@HDJB@@@DHDDJBJJLDBFEEDIHBJB@HJADADB@@@EDBHHJHIBHHH@JBHHBEBID@@BDJ@DAA@@ABD@@EABI@AA@JHJADE@E@@@" "@DJD@HB@BHHBI@A@BEBDHJJHHBBHB@BJJ@@HDJA@HABAAA@A@AA@J@ADJHJADA@AADHAEI@@@DDJBF@@HBDA@DIEDDBABKAFLLJBHHEEBEBJHBBBHDBKIBIEEKEFMEDJDNJA@JBB@JJEBEE@HJBIIKDFJDBAAEDI@DAB@H@CBBIA@@@DMD@IDD@DADBHJID@BHDD@D@DDDBD@HDBI@H@BJJ@B@JB@HJJHIBEB@D@DJ@HJ@B@HABI@@@@" "JI@@E@HJHAAD@ADADHD@A@@AADDBHED@@EDA@@BBABDBBDDJDHJD@JBAAJ@H@JBJBBABADBJBIA@EAEEBH@JAA@@@HHJ@@JJIIEMI@H@DHD@ADDHAAD@@@BAGFBCGDB@@@ADD@IAD@A@I@@HDMMDLJJH@BHHH@@DDBH@JEEDE@DDJBJADBDBBBJBH@HBLDBBHABHIBIABBABDBB@@DAE@@AE@JAADD@@D@A@IDAD@ADD@JHHE@@DJH@@" "D@DHHEB@@JB@JBAB@A@EDBIBB@I@@H@HJHABEEDDDD@HDAA@AB@HJ@DDE@JBI@D@HHBDKAD@DBJBHFH@@@J@BBAEEA@@EEAEBBJCDABJIA@JJ@HABD@IDJDDDHMHIAABIDHABD@HBJHDDJJDAFBJBEDEE@@DEEDBB@BH@@@K@JBJA@ADFIB@HHA@DJBHEAA@BHHBD@DDA@HAAAAEEBD@JHH@H@DHBBDJAE@D@BDBBHBBH@BE@HI@A@@@" "ABIAE@@BE@DE@DDDJJ@HADBDDE@EEBIA@ADD@@A@I@IBHJDAD@JA@HHHJE@H@FIEADDKHJAE@J@DBIEBEE@EDDD@@BBI@@LJDJEMHJ@@@BB@@IABDAEBI@HJIB@BDJHHDJEDABDDH@BB@@@BHMMBIBIH@DJB@@AAAE@EEBEDJA@BHEDBHNIADEDK@@HEBHHHHDBHADABHJDHDHD@@AAD@DDJEE@EAABAD@HBJIAA@EA@EB@@EDDJD@@@" "DDDB@EEDHBHHBIAA@@EADAD@HHB@@D@BEBAAEEDBBAB@A@@J@J@DBAAAA@BAE@B@B@IEG@D@B@JHHDLDH@A@@HIEBHDBBEJDIFLBI@EBJHDIBBBD@D@DJJB@DDJIA@BBJI@A@ABBBDI@JJE@DJAKDIBMBBA@JEDHH@D@@IAI@HJHB@A@GEDHB@B@EDB@DDDDBA@BHBH@D@BDBBAEEDDBEB@A@@B@HHADADE@@DDDJ@HJ@IEE@BAAA@@@" "E@IDI@@@ADBBD@DDEDHFAD@EABDJJHED@@JD@@ADHD@BHBJ@E@EADJDDLEDJ@EDEDICHJDKJDJ@ABIA@ABBBIB@@DBHHDIDJEEAEJBHD@BHBDHDABHECJI@JKIHLNJHDJNE@JDA@IB@J@A@JBMDEEBIDI@HJA@@BDJBBD@DDJD@BIBNIBHNDIEAE@BIEAIABIDE@E@BJ@J@A@ID@@ABH@AE@JJIBDE@ADC@IEAA@ABBAD@@@DIDHE@@@" "HED@BJEED@HHABIA@ABHH@JHB@H@@BH@JJ@IEEEEBIEDAD@JHDHDA@A@I@A@JHBH@@DJLIE@IADJIBFJJDDDBDJJ@HAA@AMDKDLJHJAAE@BHIBHDDAHJEJEAFFBCCDEBMBHLAA@JDHJ@EDDBHJIIFIEL@DD@HBJIBAAABJKBDJIDDHEDIJI@@@J@JHD@DHD@DA@I@JHADAEDJEEEEDHBJH@J@@@HB@JH@HJD@DDJD@HHAEEBJ@AE@H@@" "DHAAH@H@AE@BHD@DED@EBI@ADJAEE@AE@@E@@@AEDBH@JAE@AAEADEDADEDEDBHBIAAHCDBEBDA@BDE@@A@IHA@@EABBBJIAEAAEJ@JDHBHBBDBI@DEDJDHD@IHLHA@IBIEA@DJABB@J@IBHBMDDEDDJJBBDE@@D@LHD@@EAB@DABEBAF@LDDJ@JAEAEADAEADEDD@EDBH@JAED@@@E@@ED@EEDBID@DJE@AEA@A@J@ED@@H@LD@I@@@" "I@LBBJBID@BHAAEA@AC@HBBJ@@D@@EB@BJHEEEBAIHAE@J@BJD@DA@ABI@A@@HBHBBBBLIDHHIDEEBJOJDE@BLBJHDBLH@JDJFJKDJ@HBJEMHJH@DIJJHKBINDBACLJFHJJLI@@JHMMBJ@HBIFJKBIBH@IJA@JJAJ@EABOJJEEADHHIDIJBBB@J@H@D@DJD@DA@ABJ@BHED@LLBEEE@JJ@BE@@A@@BJB@HFD@DEDD@J@ADJBJBAHDH@@" "BAAED@HBAEDBJD@DDJDGBHD@JJIEE@EED@BH@HDJFBJ@B@ED@HJIDBJDJBHEEADBHDMDBBAACAAABDALLI@CJAD@BAD@AEDIDIEEIAFBHEKBB@EEABEFKDLB@IEDHBAIFKEBDEE@BBFM@JCDDMEDIDIED@ADB@ADBN@DIILABDDDFDDBBAEI@JADEE@JBIBJADJHHAE@B@BJCBI@H@J@AEE@EEDJJHA@JGABIA@ABJAEDB@HAEDDB@@@" "HJD@ABBHJ@@H@@JEI@BHDBJJ@@B@@BH@@JHBKEA@IHAEDJHAEA@DAD@@HDBH@BADAIH@I@JBDJFJDIDIIBBDDJ@JHJAJJ@MCBJHIDDADBJBDHI@@DDJINIIEEDEAEEDLKLJIA@@DHIBBJADAADHJJFEHBJLBHJHBIABBDLIDIBKBIBBHDH@LLADB@@JA@H@ADA@DED@JIED@LHDEFJ@JH@@J@@B@@BJJA@J@DMBH@@H@BHJBD@ABHH@@" "B@JJDDHB@JJAEE@HBDHEAD@@JJHJJDBJI@BIFHEEBGD@A@BJ@BEHJADJNI@BIDJABCBIDGDEBHHDIBCBFDDIIHE@B@D@@EJLJJKGIADAD@HIBBJJAAJKMKBH@A@D@@JFMNJLDBJJBDHHADADDOFJJIJM@@A@B@E@LLIACBFBDI@HJEAGADJFBDBIDJ@DKJIDBHMB@BJ@D@AGBEE@KDJ@DJJABJHJJH@ADE@IB@HEEDBJHB@IABJHB@@@" "DJ@@IABHJ@@J@@EBHIEHDAEB@@B@@ID@BBHBHA@@DJAEDBH@JHHA@JA@HBBHBA@DDLDBC@@HDJAAE@HHLHJBFBHBHDIEDHMBEEDJKJAD@JBBDH@@DD@FJLDBIBEBDJAAJK@AA@@@IBBBHADBNJIEEBEHIEDI@J@JCBBHIHHHEDDBI@H@FBAAIA@DB@JB@HDBHD@HJH@JAEDBI@@D@J@JB@ADH@B@@BEDA@MDHJE@@BH@BHJDDH@BI@@@" "A@FJADDBAEB@EE@DBB@BID@DJIDEEBAEDDBDJJBIADL@ADBJ@BBJE@DDMDDBHJDIIJHHHEEAJABEBEBBKBHJHIBDBIE@MEHEDJEGH@JAEHJIABJJKIBIOJJLBEEEBAJJOLJDNJJJDDJHMDBH@OEBIE@MEHEDJABDHJHJFJBEBEBDBLEE@HHJLLIBHJAAEIA@EBJB@BJAD@AIDDJBJIBAAEDBEEADJI@ADJ@BBA@EE@BEDBAADBK@D@@@" "DDH@JAADD@DJH@EADHJHBAEA@B@H@HJ@@IDK@@DBDABJJAD@JED@HBKHJ@IDAA@KB@AAEA@J@EDJNJDDFHEEEDDJMBJICHEDJHJMAC@J@EBDDD@@FJDBEBIJHIEDHJLJEBABK@@AAABE@BHFDEJHJIE@NDJJEJIAEEE@KAABKJIE@BHDEDD@BFHDDADHBHNJ@HAEBHADBJJDABA@@FIDH@BHH@HB@DEDB@JHIDE@@JI@AADDBH@IA@@@" "AABJ@JD@JJH@BJHBBE@BHJ@DEEEBJB@DJ@ABJJHHIDD@@JAE@HABBDBKLE@ABFOJLJJJ@FB@JHAELM@IAKHHHAAJIEEBDELIECIGJFJ@INGIA@JJIMAGODBJABBBDBJAGODELJJHDDOCLHBKBODNEDIMABEEDJLD@HHNLDHEIMD@JHBC@BJJIJOKBD@EANJABBD@HEDBH@AADHHJJJD@BI@BBJEEEA@BHJ@EBB@JJ@@JJHABHBJDD@@@" "DDD@J@HI@@AED@ADI@EDB@EA@@@D@HJI@EDD@@ABBAAEB@D@EEDDHIFLDHBJDHJMA@@@JHEE@BJEIBMBDNGEADFJFMDDHHIBJDBKDHHJCFKDDE@@CJJCCIELJEEEBIMDNFBJN@@EAAFKFBHHIFJABJDHHIAEKBKADEGCIBEJDMBJ@EE@JH@@DEJHIBJ@IAKDHIAEE@A@BEDDBBD@@AAE@DJHHA@@@DE@BAE@DID@AED@@DHHBHAAA@@@" "A@IE@JABBJJ@AEBADDHADJHDBJJHJB@BBHAJJJJHHJJ@DJIE@@AABBJCIED@JGEBJEEE@BH@JJ@IBEHDA@HJJIHI@@IAAAKFDKMFIKA@HOEIA@EEBLEGFBAJADEADBLBCGEAJEE@DDMGHHDFLKENICFLDDDH@DHLJJHHDA@MBDHBJH@J@EEEBJEGBHAEDNBJBDD@@EDJI@BJHHJJJJL@JB@BBHJJJA@JID@IADBED@BJJBDBHEDHD@@@" "JIB@E@JHD@@JJHDJEAEDA@BAD@@A@HJHDBI@@@@BIBDEA@B@EEDDDIDHD@AEADHH@H@@EHBJ@@JBLIBHJFEGMFEDBJ@DBBLIMKJEE@BEANGJDBH@EI@BKDDLJA@DBIIAFJ@DM@@JABOCLEB@EEBNMLIJBA@BJAECEOECBHJDIJBH@BJ@M@@@H@HIDED@A@IDIAAEE@B@DEABDJ@@@@DJA@JHHD@@ADB@DAEDEBI@JJH@A@JHE@BDJH@@" "@BDI@E@BIED@@AA@HD@ADEDDAEEBBE@BHHBJJJJHBDJHBDHJH@BJHBJBIED@LJBBJAEE@BHAFJHDAADA@HHDHIBID@EADEIFLEJMHJDHB@JHIDBIAJEEF@IG@DEA@GDHCEEBLDJADHJHB@IBHMJMAKDMADE@ADJDHI@HHDADDA@JKD@J@EEDBJBBIHAEDJBJ@JJ@@JHIB@JIB@JJJJJ@HJ@EBBEEDAAEAD@A@HDD@@AEDJ@E@DIB@@@@" "JHJBE@JHB@AEEBDBJIFJA@@HD@@DE@EDAAE@@@@BHJEADAB@BDH@AC@D@@AEADHD@J@@BHBJ@@AIDBIBEBBIEDEBCNHD@HJOIKICE@JBHK@JBADBB@HBHIBLDJHJIAJDHJ@HBBADBBHFHJBHEFDNLOJHHA@KNBEAEDJBEBDJADL@@BJ@J@@BHA@IDED@@A@FD@@IB@BDADEBHJ@@@@EDDAE@EA@@A@H@DBKDJJABEED@B@JHEBBHJH@@" "@B@HHB@BDED@@DED@B@ADEEAAEE@HE@ABBJJJJBHBEBD@JHJHIEEBBI@IEDAKI@HJ@BJHAD@JBJBAEBD@DHB@ADDDAKIEBLMNKDNHB@HA@E@HJ@HEEEDBBDJIDJIDJIBBAEEE@HBHHE@D@HB@KIFKMIJEDNLAAAD@B@I@ABEDBBJBHAD@JJ@BHHDNLAEDHDJBEEDHJHJHABEB@JBJJJJBD@E@HEEDDEEAD@B@AEA@@AEAB@B@HHB@@@@" "DHJBADJHHH@JJHHAEDEDA@@BD@@EA@EDDEJ@@@DBHHMAEAE@BB@@DGBEB@ACBDEB@ID@BJ@MDD@IB@H@I@BHED@HIFDFHBIGMEOEIFJBJE@BB@IBHAEAEBKEOKEFOMFJEDED@JDHBB@EBJBKDMGMEODJ@KACDHHAE@J@DH@HBDHAAEHBJ@ADHBEABFD@BEBGA@@BB@EDEDEHHJA@@@BMAAE@DE@@AB@@DAEAED@HJJH@HHJIDBBHI@@@" "AC@HJA@BAAE@@AADB@HADBJH@IE@BE@A@J@IEDI@BBDJ@DBBHDEE@JD@@JDFIA@DJB@JH@IA@JMDDJBJBBHBHAEABA@HEDLOJJ@EJIDMHJBHHJBDBJ@B@FLNJDJIBKIK@B@BJABBHHJBHMIDJM@BJOIIE@HDBDED@J@JBBJBIAEJHDDH@JHBBI@DDKABH@ABHEEA@JBA@BIBB@DIEDHBHD@EB@EDH@JJAD@HBADD@@EDDB@DBHHFD@@@" "DDEB@DEDJD@EEDB@HEAD@D@@IB@BE@EDEEBB@ABEDEI@EADDA@H@BE@JE@JIBDBH@HI@BEBJE@AAAAD@HD@HAD@B@DAABIJMDEOKIEBJB@DBB@HA@@BHENAIDIEDIDLCM@J@@D@HBBA@BBJEDNOMAEJLJDDA@B@AD@HA@HADDDD@EBJEB@DHH@JABDJHEBHEB@@HDAADE@DMAEBD@BBEEAE@EB@BDH@A@ADE@HBAEE@ABIEA@BEAA@@@" "IAJ@HHHA@HJ@@ADDJHBABHHIB@ID@E@@J@DHED@@@HBBHD@IFEBJHJE@@EAFD@HBJBBDHHCFHCDDDBABBHEBJAEDJHJJDFHJKJ@G@JM@HJHHHEBLEDDBK@JBAB@BDBBHFJAAEAJE@HHJHHEJHG@BNJHKABJHJIEDBJE@JBDBAAAF@KF@HIBBBJ@HACDE@@EBHJJECDHA@JB@H@@AE@I@BH@E@ADHBDHHJDB@JIAD@@BHHD@HHHBLDH@@" "BB@EAAADEA@JJH@I@BDHDAAB@EBAE@BE@E@@HABEEBDDAAE@AJD@BE@JE@OHHMBH@HHIBBNIEDAAADJDHDJD@D@@@A@@HKKEJEKOEE@CBIEBADMBI@I@BI@HJHE@JHHDJ@DHDJEIDBEDJF@EEGNMBMFNHH@D@@@A@ABI@IBIDDDAEDKJBDHHH@JEHHOHEBHEB@ABL@EDDAABEEBD@H@E@EB@EDBE@BDDA@IB@DH@JJHDEADDDE@BB@@@" "@HJHBBBA@BE@@ABBEDAEABB@DH@DBEDDBHEEBJDH@DHIED@BJEAEDJB@HEHBA@DEEBBBFH@BJEDBJADAEIFHJIDIDJABAELNDJEE@OGLEFJHJA@DBIBGFBEBIBHJDJEBCGBDJA@DBHJKEAOGHEEBICIMDBDBIDIDJHKDMDADBJAEBJ@@KBBBEEA@DB@M@HBBIEDEBJ@AEDHI@@IBJEE@JAAEBA@@I@BBDEDAEBBD@@EB@DBBB@JHH@@@" "BA@BHDDDEDHBJJDHH@J@DDDDIBJHHH@MDA@@D@ABEAA@@AED@JL@AMDJBICEBI@H@EEMJBJDDJAD@JAB@BEA@BABA@JDJACAEIJKJIDABJ@B@DDHDBELLE@FJD@ABK@EAIMBA@IA@B@BJDADJNJLMDFDBIBHDBDB@DEB@BDBHADBIABJBMME@@HDJEFDJBIEL@AJHAED@@DDEBD@A@@DAEH@HHJJDIAAA@BH@HIBJJ@IEAAA@J@DB@@@" "DBE@BHHI@AAD@@HBBI@JI@HH@@@ABBI@ADBE@ID@HDDBJH@ABHCEDH@@DGD@DBEEEHLBFH@IAEDADIDBJHKFBHD@DB@A@HLJJBEGAGJJH@DHEAABIJJEABILAIEDLALJDEBJLJDDE@I@@JJODGEBBJIHHD@BA@A@JCFHJJADIDAEDDH@KBAHMEEBA@AGA@@@IEF@JD@@JJAA@HADHEBAD@DJBD@@@@HHDJHDJB@H@ADD@DHHJ@EBA@@@" "IDHBHAA@EDB@JIADHBB@BIAABJJJIOBBD@HHEBHJBIAD@BIFDAEHGIEJILJDHLI@BEADKBJBEFIBAB@H@KLIDBHJHDIDECIEHIJJJKEEGDIA@DHJJBEDBEKIEG@GEDNMBAEBBJHI@DDIGEEFJJJLHMDNEADI@JHJADINH@HBDBDKEBBJFIDEB@DIHIBILJMDO@MDACDJ@ADDJBHJE@HHABBGLJJJJDDDJ@BB@IDDJHBAE@DD@J@IDH@@" "AABDABJBH@DIEBD@BHDJHBBBD@@BJ@DDIABBHHA@HBB@JHA@ABBEDBHBFI@IBJJELHDADEDHIIBDJHJBIEEGJHE@AABJHDJECBFKKNLLHA@DEACB@HIADKDBJNECJJAFIDDHHBFDEA@D@IIKNNKBFEBI@JJDD@E@JOEEDJBHJIBDLHIEADA@IMBJJDHDKB@JAEBBD@D@JHBB@HD@HJBDDIA@BJ@@ABBB@JI@J@ABEDI@@JBJDABDD@@@" "BDHIDD@DEBJB@@HIHBI@A@DDABMEDJHH@B@HBBJBDHDJHABDJDDJMHBMIBEDDHEJABHJBJKKFAFMHB@LBOKODA@DJEE@EKDJDIDGBJIKBJC@JJLDIBFDCDMEEEJMEEEIFACBDIAJJHFBJFLJJGADIBIFM@EEBI@DAGNOJAHB@MKDCFNJJBHJDBM@IAEBDMJ@MJIABIBD@JI@IBBJB@HB@@HJIEEJDAA@D@DJ@LHH@BBJEA@AADHIB@@@" "DIB@AADI@DA@DBABBHBBJJI@HEC@A@AAEDBAHH@EIDID@JDA@@ICDADJDDHAAEJDJHA@JJDFIC@ICLJ@HJNILJBA@JNGKEMEEDMNHLFBDEDGMGEAKDIALMDJIJMJLJIEILDIFLEGEOAEABCAHKMIEEEMFOCJHDBBILKJHHBINDHFDKABJHD@JIBMDD@IABIDAFDH@DABHADIDM@@HLBAEDD@D@FE@HDJJJB@JBDBA@DA@DIDD@BDI@@@" "IDDJDDA@EADEHLJ@HJID@@BEBLHCDBIB@ADJABJHDABAEBIFJIBEIBKBJJEFFKEEMKNKEAADFDEBJABIAEOOI@DDEAJMFKEECJDKKHHHIHEMJHHJ@ABBGCEDKFJKFIEFGBBD@BHHJMM@LHHHNNIBNEEFKEJLEAA@DOOMDDJDBJEACADDEFKNMMEFKCEBJJFJDMBDJKDJEDBDA@JJDBID@BDJAF@IJEB@@ADJHHBIHMADE@DAABIADH@@" "BAI@IADBHDA@AA@EB@BABJDA@JBDADB@ID@@JE@BHDEDADB@@BDKBELED@H@HDFBABADDDBJHI@DDJJBBN@BJE@JJOFKEFLJLIIOFEEEDBKIEEB@JJEELN@KDHE@IFHCIMEBJHBEEDNJAEEECGLLIJIKEFKGJJHEBJ@CJBBJIA@DHJJAAADBDBCA@H@HAEAMBFIB@@BADAEA@J@EBH@ADHBADABBHDABJDB@BE@DD@DA@JADDHDLB@@@" "HJBEBDA@B@JEDDJJDEDJD@HJGIDHDA@EB@EE@DE@AJHHJBHJDHJFHJABJICBOIMMBDJIAAD@JBBIABBLLEONHHAAAKMEGIKECGEFDH@@IEKAH@EG@IHAEIKOOOEGOONLMD@LHGE@@LFMDH@@ICEGFEFLOEENLDD@HKOMAIJBDDJBBHADDDJIBEMLOJFDJJDBHKBHIBHJBHHJL@EA@EE@BE@DA@IDOBHHABIEABJIAEBHB@DABEBBHH@@" "B@H@HIDDHE@@A@@@JHAAAECBID@AADE@@HH@DI@EF@B@@MB@IB@L@EDDDBDDBGBDDA@BDDAE@HEBDDDABKEENBDDGEDJHE@JJLJBJBJKJGBCEELDEBBDKFEJJJJJJJMCFIBBEAAMEFBGBNJJBJBIJJHE@JIEGAABCMEFJDAAABE@HEDAAB@DAABGBAABAAAE@AHBDHBEH@B@CE@DI@@HH@EADD@ADJFEDDD@JH@@D@@E@IADHH@HB@@@" "LKBJBBAABHKEDEJJ@DJDDADMDIEBDA@EBAAEABDIADHJIJ@EBDJIBJEACHIALHJJADEDIADBFBHDHHJJEEJJHHICMJIKGONEMIJKAD@IAMGEJBAM@EDKEIICEOJOMFDLMFIE@ELBBMGELDHADFJLMMCOOFLJMNDHHJJMEBJHHI@JCBADDIEADBJHILDHNDEBJDJIBE@BLJHIDDIBDEDDBE@DABEDIEIDAABI@BJMAEFHJDDBBBJFIH@@" "ADD@IEDD@B@AA@A@EADIBJI@AB@D@HA@DJB@DDIBDAA@CDJH@J@JDM@DDEJFIBADJABBBDADHHBIEE@@DKDINBBJOEBDHABMCEEJLIBBFKLIGDJADHA@JBNLKDMIFIKJBHD@IDBIGDINKBBDIJMEFEJD@IBEGJJBCLIFI@@EEDJ@HIDABBBDBIDBDKBMAA@EIBHBH@JIF@DDABDIA@BBI@D@HA@BD@DJJDIDE@D@DD@B@AAEDHAAD@@@" "HIBKD@AABHJDDENJIFBBMIBJJDJIEBJA@@HJAEBDJJJEDE@BJ@KDIJBHJJAMDDJB@JHHHABBBEEB@@EJIFGGJMOOMMDMKOMBMKCCCFDDMKEABA@J@EDGGEMKKMJMNNMMGGAE@BHDBDEFMIACFFFFMJEONMIEMOOMJOGCDJM@@BEEBBBD@HHJHBBIAELBJHJBLIFHBJ@EAEBJJIBEDBHH@DBJEDJIBJJDMJBCDJKMAABHJDD@AFJDHH@@" "CBI@AJDDDB@IACEDB@HMJBD@@J@BH@@DBJB@F@DI@@@HAJAB@JBABDHA@@KAA@@HJ@BBADDID@@DMBH@BMHMDCFEEBIAFA@FADNFHEHIEGJBDDBAIHADHKBIFJOJKDJFHID@LLBAABBOEDHM@KCIDC@DCDDJEECFAEHMJ@@JEI@@ADIADBB@BHH@DDFH@D@IBDBBHBDBL@H@@DI@C@BBJA@@@J@BH@ABBMHHBAEFDDHBAAABL@DJF@@@" "DDDFJ@JAAHEBFHHMDJEJADIEB@JHADJID@@DHJIEDJEBJ@FDJ@FJFJBJEBJEDEEE@JDEFAABBLJI@DAJMKGEOEMJOEDMHJOLKK@IBKABJKDJJEDCBEDAGHJEKGJOFMBHODAEBFAEBJIFJJDFJDHFNIOJHMIEGJMMGMGFMJLA@DJIJBDDCEABHEEEAEBJEBJBKBK@BIC@BJEBIEDJHI@@ADJID@JHBEDIDBMBIEHHKBE@LDBHBKAAA@@@" "ABI@AB@JBDHEMBECAEKDJAD@HE@BJA@@@JJHJ@@@A@HD@JHI@JMDIJL@HEEDA@A@E@HH@JDDHA@BEACGFFIGFOJE@@J@EEBKLFEEHDJEEGIKDF@KDLAGAE@IJJOJJLHEDGDAIFHCAFLOEEBI@MECANJEE@BH@EBOKGDKCGFDEB@D@IABH@HHE@D@DAEE@HAJLIEJHDHJHA@HD@@@BHJJH@@DBJ@E@HADBIFMDFEBEM@IBBHBD@DJD@@@" "HHBDJDJ@EIBNEM@JKFJIACAFBHBHBDBJI@@A@EBJJAA@J@DBBAJ@JDABADHADEDJHEBCJ@IIBJBDIDEI@IFMOMEJNO@JK@NEEHJKCKLEEKEE@LI@AMDAEJJFOGJOGKBJMDAEL@DIHEEFMEANNFJHMECHFJHGKJMEOMKDHDMADIBBJDLHBNBE@JIEAD@IDBDABHBLBBA@BHDDBJJE@D@@DJJAB@J@JCDFDDJKFJHEMCJDM@BIBIB@HH@@" "CADIAA@DHEECBHBCFIBBDDF@HADADHH@BBEBBHD@@JBEBIAEFIEEMADDJCBLA@A@BHHDEDJBD@DIBACCEBEOMKOMA@EEFGHJJBDEDBAJMCJKEAJED@AMKJ@MEFOKEEHBNML@AEBLEFJNEJLBAEABBJHOCEE@DEONMOMBEFFDBDI@ABBIEA@HJ@D@DAJFBIADEMEDKEDDJEBBH@A@JBEBB@@HIDAD@HCAABBDKFB@JFEE@I@DDDIDF@@@" "DFEBJBBIBHAFHMEEMBDHIA@JBJAFIBBJHDHDDBAEE@HHDBDD@CJODJBI@LDAEDJFHBECHA@HJJIBJJENJEGOONBJJNMBMMCFEDIKADJEFGMMGGBH@MDCFMODIEJMDIGMKFAEH@JGGEMOCEBIDFLIECFEMJEKJJJCOOOEBKMBJJDJJHHD@NEB@KBIEDAAHDJBIGJN@AABA@HHEEDBAA@I@JJBDKDBJBHDDHIBEMEEHKD@JDJBBJECA@@@" "A@HDDDDDD@JHBH@ABDIBBDE@H@J@BHH@@JAAJHJ@@DBBIDHIDLEHO@HBEC@J@A@HEDHDBDDK@@BD@DKI@LMDIEOCGIKMJBLIHHBKFIBMHOKOJ@DJI@AFKBHEBJGBJE@JFKD@DJI@BONOHMJDKFJ@HLIJBMNLOFGMDIEIHDNI@AB@@FIABA@IE@HD@BHFEB@HGHMAIDHIDJBA@@BHJLDBH@@HJ@BH@HEABBDIBD@@J@JHAAAAAA@HD@@@" "JEBI@JEAAECJJIEELIBDHHJEEE@EDBBJE@DB@B@JEADDBAEBAJNEAEBDJLEBJJEEIEBADDIHFJJIEANNOKKOOOFDMKGFOOEFCANFIBDJGFJIFMKEJEBKGMGMFMOMKEOEOFJEBMFMKDJKGBIBDKCLFCEGOKGFMICGOONNOKKLEDJJK@LIADBEDMEBJJEAJIBEDECJLBEDBAADEBHB@BA@EBJBAE@EEEBHHIBDIMEDJJNEDDEBHDJEBH@@" "BHDDDHHDD@FB@B@@IBDIEBI@@@DIBHH@@DIDJHJ@HB@HHJ@HJMHHJBHJEBHDDHIBBFHJ@IBBHI@BBOIMMFNKDAMMIBLNMBNHLJAKEDKDHKMOEABB@HEDFOMBHBMJ@JEOKAE@HBBDEGMNHIFIEFLBIHKJEKIJDMMLAFKKEMLOJB@DHJBDHBHKBBDHIA@JEBHJBHHMJHHBHHHB@HBHJIDI@@@HJDI@@@DJEDIBDH@B@BC@AA@HIAA@J@@@" "LBIBIBE@JJKDJHJMJJIBHDJFJDMBDJBJEA@A@J@JADECE@NCMKFKBLBHIJFJIBDDLKCDMBLJEBEDLKGGKEEOMEFJKMGMJNIBBINKHADMCGKMNEMEEBDAGOCGJDJIBOFGODABEEEMCMNOFEID@NKLJBDKJMOENJKEEOMEFOGFIIEBEBIJEIFFIIABDJKBLHJAJFKFMNCHEFEADBHBHD@DEBJBIBEIBKBI@JDJJMJHJIFJJHEBDJDJAH@@" "AEBHBDHI@DFJDA@ABDDDCIA@@I@IE@H@HDDJE@E@B@HD@EANANHHDADEFA@BDJIIAFDA@DADJDIECMMINGGNJKHEKFKCDAGFICEGEGGAFOFKAKABDHIGFNONHMOMHKOKKGDHIBDFLFKGKDGGEGEFDKGDAFFKFM@NJKOGCLMMNEDIBIDA@DACDDLJIB@DCEADA@HKLCLE@A@HB@E@EBIA@H@HEDHDH@DDNAAABD@DABKA@DHIB@JED@@@" "KBEADIBBEAEAAFEDLHJINNJJJBEE@EAEBIA@HDHBLIBIEJODKEEBIJAJHJEDJ@DBJGHJBIDIHIB@FKEGDKMCMFBKBIFFAJNIBEMF@@JKEFMLN@FDJJDHGOJEEDMIEEBOO@IBJIC@CIMKEFJH@CEMBDKJLCCDJFJCENENIGEFK@BDHLIDJBHOBJA@BIEBHJLBLJEEFIGJMDJDIJ@I@HDDJEDE@EEBBJJKKLJHIIECDDEDEBBDIDEBFH@@" "HDHBBBEEHDKDBIDAAEHJKAJ@@HH@BHB@DBDEAABDABDBB@JIBNBJBAFFEDHJABIFBNAADBBBEDIGNMJLGGGNAENIFBMGNBIFFIDEJOLJJOGKNONKJAKFNMEJIEGEDJMEKKFLBNKOKNOGJJIOJMADKCDJCOEJCDKMDCOGGAJMKODIEBBBADDCJCDJDBHIECCDBBJCJDJHBBABDABDDEABA@B@J@@HH@BLFJHMDDADJAFI@MEBBB@I@H@@" "BJBLLLH@BICAEFIDFDCGLEDMCEBIDEDEADIAFDDIDE@HMODJEJHDOOKMBAE@JDK@LEBFADMEJKBDEBOOMJJGOJMBHMDJKFNIHEMKEKEFMFMFIJIMCOBIMKIEFIMLKEDNMLJGNELJLKEKEKEFMFMM@LKKFJIEHJEJOOBJMOOJEABFJMEIDCBEAHFIBHEDBENOOI@JMBIGMHHEADIACDDIDEAEADJEFEIEAOFACADKEDFDJ@@IIIJBJ@@@" "DHMAAABJJBJJJEJBMIFMFII@D@DBA@@HDADJ@IABA@CCJDI@KNKKJEDLIJ@CBI@EAGDHHB@JBKENOOIKCGEOJGJEE@IGMMMGBKJCKFHMNJNMNNJBJ@MNGOFJMEOMEJKGOCMHBJBKKMKJKMHKFNBNJGEMMODHEEBOBOMGFFLOOKMFJBHB@HIGDE@DJF@BLIIEBNNKNHDIBNF@DBDDHBIDA@H@DBA@A@DLKEKDMJBMBJJJBJJDDDEHI@@@" "IC@DFDDDHFCI@JDLJDEJLKDJJJIDJIEBHJ@@MBBDDEDFDIBEAKMEDHBKD@JDDBJJJFABCBJEMJMIJ@GDDMOKEHBIDEGJKCFHDJLIFIJKIKEMEBMLMOJJNJJIAE@EDDJJKJJOMIMJEEMFLNJLKDIJI@KFFJOEADJ@MFOMIAG@BLMJMMBJFBDCBJJJAABHAFJ@IEENLEBDICAEAABBEH@BHJEDJIDJJJIFIJMABIIBHDNC@IAACA@FDH@@" "EDEHHIAABHMBFMKAJINEADJ@@@BA@B@DA@IB@DDHHHCJIDHJOJIEACDNAEDIABDHHNJHHDDHAGIOGEJKOBCFKGMGMJJAJNGCIGEGKEGCGGOJJMNKKJIMFJDBD@OHABABKELJNNKMJJOOGFGEFOEGDNGCJLBJMOEOFKFBGNJMGGLOD@IA@HJKHHIBDDIEDCIFDEDJOJHIDJN@HHIA@BDHDA@B@DB@@@BIDECLJLFMKBEHJDDDHHMAE@@@" "JBJCBDJJDEKDIADNEKEJDKHIEBDJEDJJJEJDMHJEAEMEEBEECMBJFDBKJIBBJLICCEDEBIACE@OEJKEL@DLEJKCNNEDJICNLEMJKDIENJHMEGNAMEEBBIEIHIEBEDHLMDJBEEELCOEEHJKMDIFJMMAKNDJIECKNFJMAI@AMFJMGHEFDDJEAEFFDIJJBDJNJACBJENEEBEEEMDEBHMIBMBJJIEBIBEDHNIBMFMCIDDIFMABJIBFBJBH@@" "DI@HFI@BINDIBECHKBNDJLBB@DII@ID@@J@I@AABBHEDHHJJOCIA@IDNEBDDBABDDGA@EBDDEOJLEKMKOMBHLJDMDJAFBMMAMIEDIJJJECKGMANKMJMNGKFBBAEDBBCFOCMJMNKLEOFNEBJJLIEDMLEMJCDBIEIBIHJEONMNMAJOMAABE@DGAABDBAABECIDHDDNGJJHHIE@JBDD@DHBH@ADHDLI@BBAJICJFHNEBDICLJ@DK@HDI@@@" "IBEE@BEDBDIFLJDBBKAB@IDEEABBIB@EE@JBJJDHEOEICGEEBIBEEBDKHHHIDDLJJNHDHBHIGJMKKKGGFHOCCNIJNEBKHBJJBNIMFECMOEBHBNEJJEFHIBLHHDJI@HIJDHKEBJMCJ@JEGMNECELKJBJJ@NJECJLKNFGHKGGFNNMJODHJ@I@KJJIIADHHHNIBEEBDJEEGFDMGM@IBJJBHEE@BDJBDEEADHBDFJBABIKDIBAEB@EEBDH@@" "BDI@FDHIEIBJMDJHKFDDMEDH@JDOBHIH@J@HHHIBJHJBDHHHGCED@DIMBIAB@IADIEBEBDBJMJJFOJLNMOKLLEBCMLDEBHJHIJJJMJNJEBFEEIJEHHIEBEKAAAMLDDFMBEDHHMBLMECBEBKJMJJJLHJHJEAAMNBEAINOMKIJOKBJMJJABEBEDIDDHBDDJELI@AEFG@HHIBBHJJDHHHHBH@LHJGIBH@IEEIACFHJIEJJDMDHIC@DIB@@@" "LIBE@JJCBBDMKKLJJJMA@KABJ@IMDFBCJ@JBBBBDMNIEIBCCFJHKEBBJJCFJEBDABGDHDMDINMDMFCOAKEOKKMEONKAMDBMGKKIMIEKDJDIJBB@HBAD@EJ@BBFJKBB@BM@ADB@HBBBLIBIFMDMLNNOEJAELFKOMENNOMFLGNCEIEKLIEI@IGBDABEBKFBJJBEFHJKFFBDMDKMIBBBBBHBNBCAELHBJDFHDEJJJINNMIBBFBJHEBDIH@@" "ABDHEDHNHNIJDDIJCEHFKEFD@JBKAMDH@J@EEDJNI@JDBDLDGEJL@DLIJH@@IDJMDMEBI@EBMMBJOLLEEEBKOGKNMDGCAEOIBNBOFIGNDJB@DDJBHJAEJMFHDIOLI@KEJMDBHJBIA@BBICODKGJCJDOMDFGAEKNOGNJEEEAIOJJEMJE@DJEEIEJIDH@@JLII@AJMGAAIBABHDKJIEE@BH@IELFJBHACEFK@MFBLIABLKHKHIE@IBD@@@" "JFIBIACDC@BIJIMDMJOH@JJIE@JOFNHBE@LHBAEIBNABHIAAEAEJJIAMBBJJBBDBCGLDDDHEODJMOGJJKBOGFOGKNJHMHBJNMCEJLGN@J@HHHH@HB@D@GJ@BHBBB@J@BO@A@B@H@HHHHBHCOAJMFEKJJ@MHJKNOGKGGJFJJOGMJIGM@IAAAOFBABBBJJBELDJJMDEDDDHJDCJDMDB@IHEB@KKGJHEDJJH@OJMIELJLJ@FAFDDJDKBH@@" "BHBEBEDIDDHL@JIBCELGODID@AGNKIEBHEEBLJJBEHJ@BBDKGKNN@BGMODAEEHHHMMMABIEKMGFJLMMEEEFEONOGM@OKKDGJIOOOKOEM@JBAAADBHJIDHMMDBHMHJAEMHIDJHJADDDBBHEMGNOOOLJOAFNOHEOGKOMCEEEEMIJKGENMDJDEMMHHHMEDAGMOB@CKNOFIBB@BHMBBJIJEE@JEDNKOD@ADIGOAMFBDJHAHIADIEBEB@J@@@" "JEDHFJJJ@IBKOKOLKKKKHICIDJMKNEHDBHLEAFLHKGDDIDIBKFKMDLFCNAD@DBKFCOFIDDEFJFNKICNJJEOKAMMONBLEDAEEFBOFMDJDM@HJDBADA@BAEBCJHB@B@JNBEDB@DADBABHHEIBIEKGJCEEDAEAJCOMMLFOMBJKNDNKKBKEAADKGNCFJA@ADCNCAIENKFJDIDIAGFHIKDEAHJA@MCNMJIDNDHNNNNIONONJDHBJJK@IEBH@@" "DHEBHEA@IBDJIGJGEEFEGBEBEBKGMDNMGKEJEIABCM@IBEBEGIJMA@MNJJADIDH@OFLBAAKEBMMOFNMEEMFFOBKGGLIJMBGJHKJEBIAI@BB@@DDABEDD@EDMEDJIEEIE@AAEBDAA@@BB@DLDJEBNHJOBEJLIOGFJGKCEMEEKKGMMJEFLDBAKGH@IDIDBJKMHDEJLOEBEBDHENBDDMBMFOEKIEOFJEBEBGECEEGBODJIBDHDE@JE@I@@@" "IBHEBJLIBDIGFJMJCJJJHMJHHEGKJIEJLDNDKBDDFOFBDHDHNJCOJACEO@KAKABMCMMDBNFNMGKDMKKJJHNMEOOMNAOEJEGMEDDHEEF@EDHDJHHDE@@JKNI@@A@D@@DKNJH@EA@HJI@IE@CEE@IAEEOEBMGLCMOOMEKHJJNNMIFOEKKCJAEMNEJDFLFHGMFDBONBKHI@IBCGKAABFICIAJMDJNOE@HJMHJJJNBMJKGDIBDIJJE@JDH@@" "DECDEDACDIBFICJOGDMEGBMB@KNKDEGEAAEA@DI@IJ@LMBICMBJMHFGKFE@D@BD@GGJIOAGIGM@CCNDAGMHIDBEGMBJCCBOADJIBHB@DH@BH@BBH@BJIDIB@JJGBJHBDIDJJ@@JB@@J@@I@B@JDJIDGJFFBJEOEBADHMODACNF@EODODGLJOG@AB@A@ECFOC@MJJENDJEIHBLHDI@DEDDEGEAFKNHBEJGEEIGGJNDKBDIFDAEAFEA@@@" "BNNOMMMDABEEFOEJECMJJNKNOOEGIMILJENJJIBEGBMA@EBDODKKDIGONHFKJLIJKOFCFNMGOBFNNIIJKJFJIEKFNFMNLFLNILB@BHJI@JHAJHHBJDEFIBDKB@HHBFIBDKEABJ@HJL@JHDJHJ@BALKIKAKMKCKFMDJKBNJLLKKKBGOEKKFCGNJLIJNK@KOODIFNIGIBE@DEJGEBDJJKMBILMLOEGOKNKJJMNEBMGKEEBDAEMMOKKJ@@@" "DIDHJKEKBE@GKFJBKEKEJKGEEJMJJMEI@IN@DJDHBK@DJNDIMIBDIDEGKBHGGIBBGMMNMJJJNMIEHJBAFLIABEBMLJIAEFI@BADBHB@BB@BD@BEEBJIEBEA@DKBFI@DEBEDJJEEB@AB@BB@B@JADB@DKEDDJIMJEBDDIKDBBHMDMKJJJMKMMOBBDOG@JFOEADIBDMLICJI@FJ@IBI@CLHDMEJJMJMEGFJMFMFJBKFO@EBFMFJHIDI@@@" "EFIDHJKFLHEEDKOMGGJKEFJNIGKGEKDFEAFIAAABFBEBDJIBKBCIKEONNDAFOJIDEGGEGEEOMKGGGIDJKIFJHIDKOJOMOINJDJ@DADEDDJHIEEJJDEE@DIFJKFMKFJKDI@EEABJMEDHJIAEADA@BIBKLOMOJONIDHJKDNJIDOGGFMOMEGEGGEADJOKDACKOMFLNBFJDJIBEBCBDDDDKDECAFMGFODKJKEFJOGEONIEE@IKFJHIDKE@@@" "HIBICBDIGA@GCOEFLIOEKOCECEFL@@IGHELBJDDDJK@HJOKENDFGJKFOKIFGMDJEOMOMJKEFGFHOMBIADLK@BBKOGEJK@DI@H@BHJ@HHIDBDIEBDID@FIEJIJD@ABLJMDK@ADIBEDIBADHHHBHJ@@HDI@FJMGGNJB@FIIDDJEOHKGCEFJMOMOMBIEOCDNOKFJOCACMFOJHHFJIAABJAM@ODH@AKEFEFGNMGLIKEGNG@DGDIBFDJDHH@@" "CCEBDHMBMFJJOFJKMOEGFNEOFOKLMFFIGAEIBJIECBEAONJHLHJKENMGEEEOKIAGGEKCGJOMJHKMJIJNIEFKJMMFNJMNOKJEAADB@IBCBBHIBBHIBIGIJIDJEBHJEBIDJLODJDHJBDHJBFBDHBADDEBNOKMJKKEMJNKEDKJLJMNHJMOJOFFMGGDDNOMEEGEKMFJHIHJKOLEBFEDJJDMDGDKCEINOKGMCKGEGMNJKGJJKEJEHIBEFF@@@" "DDDHJB@EG@BEJMMFHBJJMJKEMKGIJMEBLEFBLBE@FJHJKEOEKACEOEGNKBOEGFDJKNFNNEHFMGJKNFIIBOOMEKOMJKICJDDHBB@HIBELJHBBDDBAEBHDDBA@HHB@HHDBAA@JEDBAABB@JIMBDHHBB@IABNDNJMONMEOOJDLKCNJOEK@MCKKCNJICGEGJFKOEGMFDFMGMFJHJK@EBAJCEAJEEJLOFMMFJMJJJ@KEMJMB@GE@BBHIAA@@@" "JIBAADMIFMMOOKNOELKJJDKOKNODFFGEKINKKDHFJEEGONJIFBJKHIEKOOKOOHJGGEMKOMGKMOOONMKGEOICCOKGMFOOOEABHDEBBJJB@ADD@IEFJFEIADJEBBEBBEBIDDMCBKEDHAAD@BBJJBEA@JDEGOOKEOFONFDOMGFMKOOOMNOEONMMGGBHOONOONMDHNJJCDJKOOEEBK@IFNKLNMGCCAGKNONIBJNIMGKNOOMMKDMIDDBDJH@@" "ABEBJABGMFKOMGIIJJDEKJFOGCMHNLNHNJJBNKGMGKENKKKDLJD@ODGODGGEMEMNNNIOJKMECDBJEADHGODDCGNJAEOKE@J@AADDI@@HDJAAEFJHHI@@B@@HDHMHI@H@B@@DHHJKEDDBI@H@DIADD@BHEFOMDBKOFAAGO@IDEBJAFEENJOLKKKMMEMGGAGOAGHABIIFNNKMFOEOFKJBJKHKIKHMNGGKBNMABJLLOEONKEOBDBJEBD@@@" "JDJFBOELBIBMCKDFOLJJDKKMONOE@EJOKMOOONJJJOOOOGOKGGKOMMNLKIBKOOKOKJKFFFKKDKMFNOMOMKKKOOKHOMGJJGMFJJKMEDJJI@DDBABEEDAADOMEAA@DDEEOIDDAEEBDBAA@DJJIEENJJKEOBJOEOHNOONNNMOMOKKENIFNKCCFJNONOONJDNIKMMONOGFOOGOOOJJJKOOOMNOJM@EGKOMNNIBJIOKAFNEJDJAMGJCBIBH@@" "DIDHNJFCD@EJKOJHJI@@IDDJBEM@EMABFMFJMEEDFKFKFOEDNKDDKFMKDFKOKNNCNKJNMMEEGNGMLJAACODBEOFOEJNMFHBIEAD@BA@@BBIAIFDJ@@JBCIBJNBEBCJJDNBBH@BICDLDJB@@DB@ADEDJ@KEKJMGKGMBAGNDDBIMOCOEEEMKJNKNCKNONKAFMKFIAFKIEGKFKFKAEEEJKEKBDEM@EMBBIADH@DJHJONJM@AFCBKHIDI@@@" "JBIGIDHHEBJEDGHGEDDJEAEAE@GONHDHIKDIBJJKKOHJMFKMEBKKOMKDJHCDJKOOOOGKEDKOMEIBAADDIFADIFKLOOMJHEMBNAAEDJDJHDBBBHJHJI@DHBDBJDHIBJAB@I@DJHJHJBBA@JIBIEDDCJEM@JMOOINKDIDCDIADDBDMEONIEFOGOOONJIF@JIFMONNJEENKEJHONNJJJDIFLHI@KOO@EDEDEBIAEG@OAEBJE@HIDODJBH@@" "ADC@EABE@DBJAEBJOIAA@B@D@DHJIAACCDABD@BNECGEBDHBJKNOOBDI@@JKGMMEJJJDJKFJJLFDJJIIBDJEBIEIAFOOBJBE@JB@B@AACIDEEB@B@BBJEDHHBH@@J@HIEBJB@B@BEEADNDD@B@BBHEBBJGOKDDMDJEBIBDLJJICAJJKFJIBJJMEMOFJH@DIBGOKNJJ@IBEGFECJ@ABDAFFDDDJHI@A@B@DDDOJJEDBJA@EBDE@FAD@@@" "DILFHJDIDIEHICLBJJBDJHMAEAEEDJJDDIDEADE@JKEGDIEDFCEOFNIBKGKMJGNJEJ@KJEEEEAHIHBBBDIBIEDIBEOOFOELHD@DJHJJNNBI@@@JHIEFKKEEBDBJJABEEFNKEDHJH@@DJCKJJHJI@A@IMGKGOMBDIEDJDIBBB@LHLEEEEBNHBMBKOBMNOFJDKKGMFCAEDIGEFJHEADEADIABJIEEDEDEHJIBBJJANDHMDIDIBHKALI@@@" "JBA@B@IBAB@CBOJMEBME@B@D@D@@J@@IADADD@HE@EBEKKABMENNMEEFLJEJMIEMKDMJEDHDHJCDCEFMAJDD@ADHJECE@BBBIBIBE@BI@J@BIE@BB@@DBJDDJ@@@BIABJA@@BB@EDJ@BHDJ@EBDJDJBB@EFEBHID@AABLEKEFAFBHI@IEBMIFMMDMJMBIKEEEKKMEJDFNMBE@E@HAADADDH@BH@A@A@B@EEJEEJOJF@BDBDHB@DBBH@@" "EDJEDEBDJJJNONMBJMBIE@IAEAEEAEEBHBJ@HIBHEBEBEFNMFKKOFKIMAMKBJEKADI@ADEGKOMNOMOMJOEKKKFIEAJMNEDLHBEED@EEBE@JDB@BIDEEEFMMJ@MEEHBMMKEEEADJ@BABHEBEE@AEEB@IIECMJLEDKFNNMGJMOMOKMONOEAD@DIDFMBJFMLELNKGNNKEKKEBEBE@JDHHBJ@JEEDEEDEDDHEDJEJJEKOKJJJIBEAEBIE@@@" "DE@HADHIFMOMJMMOMJMDHBBD@D@@D@DBAH@JAEDJHDJDHIKFFBJMABJKOBHM@JDJKBKNKOOGCGDHKFOGJMEEEOEJLEK@JAAEI@@@JH@D@J@HHJDJ@H@IEJJKL@@@ANJJMDH@HBIBHHHBHA@@JH@@DMDDBHFMAJMGMEEEJOGKFHIGFGGONKNJFJIBHEHJGNJJDEJJCCFLHIBI@JIEDBH@LBA@A@@A@ABB@IEJMOMMJMOMKDHID@HEA@@@" "IIEBJAABMKGOOOOFKF@AIDHJJHJJIEADJBE@J@B@BI@ICBFHMOJMFMED@LB@KEKGEONIEIHLLEAOEMMNOKOOOFJGKOFO@MDHBEEE@CBHJ@JAA@IEEAEBBEKOCMEENGNMBBEDEEDHDDBHBHJF@EEEB@IEHGKGNOBKGOONOKMMMGLEAIHLMDKOMGFMFHBAHAEEKEJOMHKBFDHDJ@B@BHEBBIDEDJJHJJHIDL@CFKGOOOOFMJDDBJEDLH@@" "JBADHJD@KNLABEOLDIMDBBA@@I@@B@BABHHE@IDIDBEBDEKOOGEGMBJAEAMOFMFNOFKOKFOKCKO@KJKEMOOOEMKJNNEBM@KBHH@@BHBA@J@DFEFH@I@EMKFFO@@@GKCFMM@DH@KECA@BHDB@J@@@HJFHEJECKJNMMGOOMMFJNHGNNFOKFONKGKKEKGMLEDBJEOEGGONMABEBADIDHE@HJDB@B@@DH@DBBAELIAOMBDAKNHABHIDBBH@@" "HJJAEDMOOGKOMMMCEFHADIBBJBBEHLDJDAE@EBICALJDI@@IJHKLAEEJMNJENKEEEOGEEEIBNOHNJEJLMDJMOGFOEEEEJJJMABEBHBDJB@JHHIEBOBDHBDOLHMEEHIOIB@IBGJEDHHJHBBIB@JEBDEJJJMEEEGKGGMJIEIJMBKHOKJDMEEGGMEEFKMBKMJMEDANHJLH@DIBILFDJE@EDABIAHMBBBJBDID@KEFEMMONOGOMIEDBJHH@@" "KBDJ@KEDJLBJBBJDD@EDADDD@HDHBAI@IB@EBEBDFA@IDDEEGBHBMEGOOKNOMNMFKDMOJMFMMFGKNOECEKLIBMMMGBKFKEDBKDHDBMI@LJDEBCJODNMKMIDKK@@@FNIDMNMKIGJNBEABIHDMJA@IFJAEFKFJGEMMJDINMFEGKNOCEMKEJOMIFKEKMOKNOOOEEJ@JGEEAADHDCABEBE@BDHDLB@I@HAAADAE@AABJBBJAJIEFHBIBFH@@" "HDIIMFJKEKOEDJEBIM@ADA@IEDICDJBCBDKJLJDJHJJBIIIBIMGMKONKOFKKCE@MEKJJOGKGKMIFEFOLJJKOMOFKLDDEENOMMCBAD@BECBIIFMFKOJMBBBKDLEEEAIFJBBEJONKEKDLJFEB@ADBFEMOKMEAAANKGMONJJIOKECDMNOFOGJJNMEHEFFNKGNKONMOELJDLLJBJHJIBIJNIBFBBIFDIEDHDAD@ELJEBIEGNMFJKELLI@H@@" "BJFBBMGDKEBNI@HMB@JJEDJJBABDADHLEEJNADIEEDEEBBBDEGOOOOOOMNMFOOOKEGEOMOEOOKGKNMFKMMMCKKOGBOJJMFAFKELJCFIBJNOGMOMJJEAEDH@ABH@@JD@@IEDEBJMOMOGKJJDKFBIMFKDCEJJOJGGNNNEMMNKEKNOFOOMGMOMGEFOOOKEKMOOOOOOOEABBBEEAEEDIDCJMEAHIDABDBBJIEBJHBEHHDKJEFIGEJBCBJ@@@" "E@IEFIDIDJE@BJB@DJ@@HB@@HJEABIBA@@EEJABHAAHDIEBIANHBGFOGOECOLGMFKMOEKOJMEENNOJKMFCCOFFFMJHJFBDLJH@IELMNEBA@IAABC@JJ@AAEBDEEEABEDD@BJHFBDDDHDBECMIMDH@JIIBCBHJMKCCGNFCENJOKKMEEJONMGMNKEOAONEGOGKGB@KLDJEDI@LD@JDBME@@DBDJDEBHH@B@H@BI@BBJ@EBIDIDKEDHE@@@" "JEFHHDJJI@JDHADJEACEEDJJBE@BEBEDENNKDJICFFBJDBDBEEGMMONOMNKOGOOONKNOFNAGMKGKJKOKOMOFNKNKBKMDNOADBEFIGBDLDDEBJJDDE@AEDB@DI@@@DI@BAED@EAABJJEAAAIBGDKEBADGKIENJFKNKKGMONONJNOFMODCKGKNKOOOOGNKMOKOMMOEEBABABJCCFDJIFKKMAEBEB@EBBJIEEFDEBID@IBHDJJI@HKEBH@@" "DJHCBJIABEHIBFA@HJD@@A@@E@EDHDHBJKJMIEED@IDHJLIEDKMGGKMMGGFMNJJMKOIFOMBJKDOGNFMGDNEGOFMNLEACEJJBHHMDHJIBHHHE@@@I@ED@ADJIBEEEBDJID@AE@DH@@E@HHJDJHIEHHJBJMFDEAKMKGOECIGEKCOGIFJJEOKDONMJJKMKGGEMNOGENIEDIJHIDHAEEDMJNJJ@I@IE@E@@D@@ABHHDCBDHMBDDJJF@JI@@@" "JDEDDIBFDLBBDHJEC@IEEDEDHE@ABIBIAMGJJHIBGDIBIABDABBJOOGFMNGNCOOKFKBEMNDGOAECDIOMMGOFMKOGCNNLKLHHBAHABDDDAABHEEEBJHBJJA@BI@@@DJ@DBJJ@JJEEE@JDDAAABD@LB@HINIKKNGGNMKGOEMOLIFEDGOACMMBFKFOONCOCMKGGOJJBDABDDJDIGBDHJJOELDJDJD@E@IEAEEDHFEBHIBBAICBDIAEABH@@" "BJJIABEHJADHIB@JDFB@@A@AC@EFFJDBGKLEMCBDHJBBBBDIDEDIGNLMMMMLOEMDOOLKKMAFKDGNODNJKG@NKLNMFAFKFCEEDJBDEA@MBDDE@@@D@BH@@DEFOEEEGKEA@@@J@A@@@EAABEHDEABBIEEFCFKDCEKINKHGFJKIGKOAFKDENNIOOIEMGIMMMMIKODIEADIBBBBBHIBFEMANOBABKCE@FD@D@@BCABHBDHIDBHMBDDJJJ@@@" "MDDBJDHBDJABDDI@JHHEDJEDDFH@HBIEOMEKJDDIGHHDIDIBADIBEOKOAJKMCGKIKOECFLBEOAEGLAMEHEOFCKMOINKBLNH@B@HI@DE@DIA@DIBAEDEEDJHEB@HHBE@JIEEAEDBDI@DDI@EA@DHHB@@KIJFKLOMNNCGM@MELAOEDGMBAKFEGNLNOFENJLGNOMBDIDBDIDI@HODIABNMEOMDJ@H@KAAEBIE@HJHDIABDBIB@IBJAAEH@@" "BAIJECBJIBLEBIBFJEBHA@HAA@BEBLBCECEEEBIJHEBMBABIBABDKOGMEGOJEOKBONHBOODGODCNKEFOJKJLKMEJFIFLEGMJMEBBCA@EA@DEABDD@A@@A@BNMJBBMKJ@D@@D@AABDEA@DE@DFBBEEJMOEAKDKBMENIJNJOKEFKNAGOAGOJ@KOJFOMBOOEEOGNIBDBDJDBEJE@JLJEEEFEFBAJEB@DD@HD@JEBKBDJEAJDJJFEBLLB@@@" "DJBDHDDHBDADDDDH@HDBDBDHDDHLJADKFJENLEBABID@IBJDDJDIANOKHNOJKOODNMJKML@KNAFNLBMKDGOFCNMGIJKCODBCK@@DDBBHDBI@DD@IEDJJJBH@CAMLF@@JBJJIEDHAA@DJA@JBAA@@FNBAGNFJLOEKNCGOAFMJAKKDCNHAMNJMKIGONJOKHNOKLDIBIABJDHADJDBEAKMBKFIDBIHIA@IBABA@H@IAAADAB@IA@IBBI@@@" "EEEIBJIBJIBIIAADJBHHIEABIIBA@JACEGKEIDDJEBBJ@DABIAABJEOEBONLCEJAKODCENEGODCHMLOCIAHNKFKOCEFMDBMMDEDHIDDBID@EAAEB@B@@@DBKDCGFAFJA@@@B@BEDDE@ADJAADHIEAEMJAEKEFGNKFKHLDNGIMHNAGOECMFAGNLBMFAKOJEGMBJDDDJDA@BJBEBIADMFOEFDBHDBDLJDEDHHJBIDDDLJDJJDJJDMEE@@@" "DHJBDECEBBEBBBDI@HABJ@DDBBDJEBNFJLGOBIIIBDHDJJND@DJLAOOMEONMGOMJGGMGMMIGFHKONEFMJGOMBNEELLKKNIBBIHAEBAHHBAE@DD@@JHJEDHHEGBEBGE@HIEBHJH@AA@EDB@HLBED@LJBDKNNIIMECJEOOBMKECONHKGDMMOEOGBMOOEKOMEOOLAJI@ACJJI@IBDLLJGOAJKCJEBIBBAA@BJD@HDIBBBEBBEFEABBHI@@@" "KBHIAHEDDJJEDJIBFKBD@EAADHIBJD@MEKMENBBBDIFIAA@IJJDBJGOKAGGLGGK@ONHGONBNOKFOLLOKDKOGCMMOJKGOJBDJBBD@EDADHD@FJIEB@B@HAAEEDEBEAEEDD@HB@BEDJK@A@IDAE@ABBBIBBOOFJOMMNGGNIFOIIOKFOKJCOO@KOHFOGAOGDFOOBJABJLHDDDKDIBBBCMENMEHABJDHIDDE@ABFKBDJIEBJIAE@LDHJFH@@" "DECDJCDIEDIBEDFDHHDIEDDDACBDDJJJKECDHLIDJDHJFFEBBEJHHMEJINNIGMKEKOBKKMIMOHAOOFOGMEMNMOCGODGKEDIBHHHJ@ABAE@JH@D@DJHJBDEBFE@E@ECBEABBHJI@A@@JHEDBD@BHHHJDIEFOAGOFGMKMMEOGKGOL@OMLMNNJGNMFMODKKLJMEHHJMBBECCBHIBIDIHIFEFJJJIABFDAAAEDI@HICAEBDIEDIFBIFEA@@@" "JJDIADABHIBDHI@JEBIBD@HHJDBIBDIJJJNOEABEAABI@HJDIGOOBKOKBOKNFKJ@FDLCGKGGOOONMEMODCKGCNNNHJOBDABDEEA@JJDJ@E@ADIEA@B@HI@MFHDHI@KEHDHHB@DEDID@E@BIBJHDEEABDABGJHKKKNGFNAGMMEKOOOOGFOFAIC@BNKCNOJFONJGOODIBHHDJDDEBDEGKJJJLIBDJABHHHABDJEBHDHIBDHJDADDIBJH@@" "BEICFIBDCBDIEBEBIEDDHIAE@IDBJICEDEAJJLFHFEEBEBDIJEJJMOKGENNNOOOOOMKOMNKOOMKJOOONMKONOGMOGEFOIDDA@@BJ@A@HJ@BJ@J@DBHJBBAJHBIJLJ@JLBBBHJA@BHBJ@BHHD@BJ@@DAADOKEGGMOGKONMKOOOJNMOONKMONMOOOOOKKKMGFOMJJMBLIBEBEEC@KAJJLEAEFDJJADHEDDHIAEDJEBEDIBFABDKFDMB@@@" "EBJHHBDJHEEBDHMDEBABBBD@EBDLDBEJIJNGMGMJHIBDIDIBEGEMKEGNEEOMJJMDEGEEGKNONKOONOKMOGNOJMJFNKMJJAEDEDH@EBEE@JH@I@EADB@HDBFEDJ@BIECBA@HBADE@DH@JHEEBE@@IEAEDBJMNKKBMJOKOGMNOKOONKOKNOEEGEAEJJMOMECOEFMMGEBDIDIBDHJMOEOCJLJMBAAIBE@ABBBDBEAEHIBEE@JIB@HJJE@@@" "DMABBLIABHDDJE@BJDJHHHIEBDIAIDKNBEAJGJNMEBDIBADDONJBEGNNIGEKGGKKOEOGNOKOOOKFMIFOMGKNOKOOEOGODBHBHA@JHEB@E@AJBDHBADJA@DLIAAEDDDII@DBIDB@IBBL@E@BE@JHD@J@JAGOGMGONOKNOEOKDMKFOOONOKOGMGNNOGFMGDKKOEBBKOIADBDIBEEKJOBLEBCNIDLDIBEDHHHJIBJ@EBIA@JDDIJBDEI@@@" "EBFEIABFEEIEDHJM@IBEBBB@HIDJBIFIEOGFHDDBJDIBDJIIKHIFJOIMONOGNNNNMOJMEMEMDNNOOGMKKEGMEGNFOJOHDHBHBDE@AJDDHBB@HIBDD@@DBKACFDEACFDFJA@@AABDHHBB@IABL@EAB@J@I@OJOKCOEEOEFNMOGOKKIEMEMEJOMKKKKOGKOMLOJKDHNLLJIBDIBJAA@KGGMDKDJBIDHHBBBEBDHEJHIEDMECBDDMCBE@@@" "JDHHBFDIBBBDIEB@EBDIDIDEBJIAEBEFJHEEBIJK@IJDIBBCFKDDKJMKBMMNMMKKONOKOKOOOMONOMGGEBGJJOKMKOOEABHBDI@BD@JIADDJBB@DIBIADBNLEMHMMAKJADDJDI@BBBIADDJHAB@DIB@JDEGONMNOJJOBEGGEOKOMOOONONOKONNMMKMMJFMJNIAFKFBBDIBLHFJLJEE@JKEBEDDJJEADIDIBE@BEDIBBBDICB@HIBH@@" "DJEBLHIBDIDIBIDJIDIBAB@JDIBFELNCOON@EB@JMBBIBDMFODBIBGKGEGKMGGGFOMMOMFDOOGJMJKDKKEOOCOFOOMOMDDEDJBDDIBDBJ@I@HDEADDBDAOKKJJBBJNNOLABAADEA@HDHBJABDIABBIEAAEOMOOKGNGOMFNIFJMJOGOICEOMMOKGGGENOEGFOBDJAGKEIBDJBEJHBE@COONCIMCBDIBHBDBDIDJIDJDIDIBDHIJEBI@@@" "KDJFABBDJFEBDBEBBABDJDI@IBDHIEEOMMLJLDKAJDHBDI@LJIEEDKFLIENBNMMDMKCBKHJMNJEOLIGFDJGDFNMJKKNJAJHB@HHIBEAD@EBEBHHDA@H@JKEEEEEEEEEFJH@HDA@HJEBE@ADEBDHHHB@JLBKNNJMKKAGBICGDIOMBKMJHNJFFMIEMKJCMDIKFIEEDJIHDIB@IBLFIAJIMMOMEDHIBDHDIBIBDBBEBABECBIBBDCBIFH@@" "DAA@JIDMA@HHII@EEJDI@IBEBDIBDNKBDOIBBI@EIAEDIBFMNB@BBCIBBGJICOBICFHKOMAGMIAJIBEMIAFMHOGKOGMLJ@HHJAAB@HDDJH@H@EAADBAEANFOENECMGKCLEDBADDE@@H@JIA@HBDDBHHHBIMOGNOGHMKDDMMBDJLDMODEONHKFDJGNDJOBBDNBB@BCMKBDIEDDM@DJBDOIBFKIBDIBEBDHDIBME@DLHHHDEIDJHDDA@@@" "JJDEFBA@JEBCBBE@@DIDBBDIDIBDIMFOKMBDIBJIDJIAFDHJ@HJHHEDHHOOBDJJBOMEBJJDGODEGJEGKBJOOGLOONOKOBJCB@JDDEBIA@BEBE@BBADJ@EKMDJLHIJIENM@BIDBB@EBEB@DDJEAABHBFBJGNOKOOIOGOJJFOEBOEAGOABJJEEOJBJIBGOHHIE@HJHHBHICDDJIDJJDIBENOKELIBDIDIBBADI@@EBBFBEBHDBCEABJH@@" "DHII@LLFDJDLDHHFJIJIDDIBABDIBNMJNJLJDDBBMBBE@IEGEC@JEIICEEFDKODHJIAGOMAENBINDLOGLJMJMMECEOGMMJHEEDIBHIBDEDHBHJHDJ@@ECLEODKEFIGMANE@@BI@JHJ@IEABDHJDIEE@JMMOGMFEEMJMJIOGIICLJCMDEOODDJHIGNICEEFDLMBHFEGEDHEBBEJBAABIJKJMKJDIBDBDIADJLJK@HIAIBICAIHDLHI@@@" "ECBBEAAHIBI@IFEHIB@BJIBDJDKBEJJOMOA@IJLLJLLJJBINHDE@HCJDEGMAFKBBFNF@J@DCKHEKIAENKEOGIFMNKJJKEGMH@KJDEBDIHAADB@AAAEDHDKKDKN@CNIFNI@IEDDD@BADD@LIBEABNH@MOEFJJNKMKDOGMFKMDDNM@NNA@BHCCKBBFKDEOEABN@HEA@KLJBJIIJIIJLHDGMOJJMBFIBIBDJJ@BDHMCDHDJDHLDEBBFE@@@" "HHDHJJDBDJBEB@HBBEEB@BDIBI@DOGMEKGDEBABAMEAA@MCDA@HIBHMA@OFDKNLDDI@KOJIEOCBOFJKENONNKMGEEGONJHKFKFDIBMADAJJAHJBDD@AAANEKHEGE@NMCLDD@AABBHLBJLADEJDICFKFHJKOOEEGENKKOKMFJKGJFGMDJONHDIAAKNICGHDEHJDHHDAFEHDDEELBDBEAGFMEOGI@DJDIB@BEEBB@HBEBBIBABJHI@HH@@" "BEAED@JHIEDJIEEFLH@DIDICDDMBBMEOENI@EDIEDJJFE@HMBEBBDCFDFHJIFOHHKJEBNDBOJDEOHIFNJJIENJIMJOFLOBJJNMINGBNKJ@@JB@HA@IDBBEGFGNECOCGEBBADHD@HBBH@BNKJGCLMKJJJGIKGJMLJKMDJJKKDHOMABOJACJEBNHHOKDJHKACFABBEBEHHECBJIEDIE@DKMGMEJBEIAFDIDI@@IKEEDJIEDHJHAEDEB@@@" "FHEBIEICJIBDFDA@ABMJBEBHBIGEDMOMODJFJEDDICHHJJKJDIDMADMAHKOJHJJJMFHEMJHJOJMMGGKOOONKEEGJKNOMJMFMKOGKNOELEGGEEMBLEFIDEJHDKMJMNI@JMADKEAJEMEGGEAMGKNOGNMKEJMOKNJOEEFKOOONOGEMJOJHJMM@KEJJJHJONHLEIDEIDIBNJJHHNDIAEBKBIGMOMIEGDJ@JEBBMJD@DACABDJNDMDJE@K@@@" "HEJDDJBDDJDI@IEEDDB@HHDBHJNMFKEGEOM@IEBIJIEF@JDDIBB@DAGFBDEEGJE@CLKOKDBKNKBKIGGGEEDJOJMGDKMOEBEIFHLFEJOGNMMJJBDAEAF@JECKGGGGGFNEBHCDEDABBJMMKOGJMCAHKDMBEGMNIGEJOJIEEGGGDNJFKNJAFONIN@EBOEEABCGDA@BBDIABHCEDJLJEDHEOMGEFKEKJHJA@HHBAAEEDHDIBIABBIABM@H@@" "GBDIAAEBIBIBEBBDEIHIBAIDJ@HMOKGMOJKEBJMEBCIAEAEMJDIFHDEMEKOJJJNOOKFIFIJOMOMOONJNNOOKMGOMJOCJEDHBJKCDJMILKGKGOMJJJFMOMOOEMOOOMMGOMOMKBJJMOOFOFILMJIFFJJ@IEBNGJMOOENOOKKJKOOMOMOJLKDKFOOKJJJONMEMA@KDIBMMDEDDNBEEJJEFJOMOFOMHHBIDLBDHLMABBEBDJDJEDDDIBG@@@" "HIABDFDIBDDDDDLI@BBBDJBEACDJFJNGEGJBDIJJDEBDIFJBAADHBICBIFJMOGMMJFMGMGEJCBOGEFJMJIDDIDOKENOGKEBJDDDMBBFADHEEBJEJMMKEKMOOONOKOOOMNMFMMJMBJEE@IDCBBEIAABJEFOGKMFOIDIADJMJKEGGJFBMGEOEKBMMOGMJKDJFDJ@IDDBBKDIBEABJLIBBOEGCJKBIFDEBBIBBB@DIIAAAABDICABDDHH@@" "FEFJMHIBDIAIIIABEDIDIDHHEDALMONKOOJMKFAEINIKBIEDJEABDKDGEMOJKMKKFOOOGNOKNOMOMIJKOOMKOOMNKMGFNHEHJKCHDNIOGGNNMEOGOOGOMKOOOOOOOOONMOOGOOGMEKKOGGLKI@NFJHM@KKGENKMOONMOONJLMOMOKNOKOGOOKFNMNJOMMGAFIBDEBIEDJFLKLMDCFMJOONKOMILAE@HIDIDIEBDDLLLDIBDHMJKEC@@@" "HI@D@ECFIBJBBBDJIABABABBJABAEJIMEGKFEMNJBAD@FKFI@HDDM@EEKGOOOGFJIHEDLMMGEJK@@BJJJEEFKKKAJOJOMGMCAFMNDMB@HMAEEKBIBIEECCD@ADOID@AFFEEDJDJFMEDEHHBEICMKDFEOEOJOJLFNNKEEBJJJ@@FJMGEMIIE@LJKGGOOOFME@EIA@HDKFK@ADBBKMMCFOEELJMDBDBJBDBDBDDJIBBBBJDKFE@A@DHH@@" "EDEEEDD@BE@IDHJDBFDLDLDDHJFKOGNOJJFIFGMMDKEEAEEBECAE@EAKJJMKOOOOFGNKKKJOOGNOMMEEEBIEGFFNAGCEOMKNNOKEMOEEE@DJJDJDLJEEDDKOOMEEOONIAEEBIIBIBJI@EEEGMMFOKKNMOMFGDCKCGEDJEEEEMOKOGOJNNNKOCGOOONMJJNLE@EDFEBEEDEEFIEMOCDKBJOKOGNKBHIAAIAICBABHIDHEB@AAEEEAE@@@" "JBJDI@IEEJEBAEIAFHJAEAIIA@HDJOGMOOMNKMBIIEHJJKCDHHE@OJOGMOKOOOOOOMEOFOGKCMEEGGJJIEFHH@I@NMFOMGOCEIOOOMNNJJIEMKEKKGKJJJDIJJJJJLIBJJNOFNMFMMDJJKKMOOOLMFGOEOKEKHDH@HKEDJJOGEEENFOGKGMEOOOOOONOMOGJOHE@HIFFJJHMDLJENKMOOMOGJI@HDDLLEDBHKDDMDBEBMEDHDIBJBH@@" "DMDJBMJJDABDJHBF@EDJDJBBFGGKEJMOOOKMOGMFKOBEEDGECBIGJOOOGIGFJKEEEGOIMJMEGGJJHJECFDICCONOBNKMKOKFJOGONKOMOOOOKNOOMONOMEKGGOMOOGFMEOKOMOOKNOOOOMONKOOGJKFONMNKJGKONFDICFEBHJJOGEEJMLOOEEEFJKGDOGOOJODJFEGAEEBGNKEOGMNOOOMJMFOGCBBBIBIE@CB@JIBDABJMJBIEI@@@" "I@JDL@BHIDDIBBHHMB@HJEDHHNMFIDJAGCFJNMGMDHDJBAHHDEBMGMMKMGMOMNOOOMEGBKEKHHDJMA@D@IBLMAA@DEFGNKGMGJMGKNJKECGMGGOEGMKMKOONMFMKEKOONMNMOEGOGEOFEFJKNOEJOEOFKOCEA@DDEIJDHA@DEJI@HNMFJGEEOOOKMOMOENMMOEJEA@HLBBI@IEOEKJKFGDBIDKEKHHIEBHHBEHHJBDIADHJ@AIBHDH@@" "BKEIAMEEBIJDIEEEAEEBHHACE@JDJKEOJNOOMKMOINIEEFCNJHMKOGKOKMOMGFMMBAEJOFJDEBIABJEAFEECFNNNJOEMEFNJMEIEGKONKOOKOOMOMGGOGKOMKOJONMONOGOGEOMOONOONKONOEDMEJKKEEMGJKKKKFEECDEBJDDJEABKGJMDBEMKGEOMNONOGNMHJKNCEEDKLOMNMOOKJOMFJIBHEFD@HJEEDEEEDIBLJEEELDMFJ@@@" "FDJFL@JBJBAABBBBEBJECBMDDJJKABOJKKONKOGOFIEBIAHMEEKOMMCGNKCBHIK@LJJD@IEIBEBJDDJFKBBHIIEIEFKGNKKKCIFMGOEKFOOGKOKNOOOOONJKONOKONJKOOOOOKNONOGOKFMGOEKDNFNNKOFKEDMDLHJBFKBIABJEBDMDHABJIHFLHJFFKOFEMONMEEHLDJEDKGOGNKONNJOJDFJJIAEJFEBJEBBBBDDBBJBHAKBIC@@@" "HKEHAEADDLJJIEDHJDDLNOKGKEGFMEEGKFNMOFOFMJBMBGEIMONOOFNOENNOGFJOKGEKOFJJIDEBIA@LFHHEFBJBIFJMEOENNGMNMNKLEMJMFHFIJJJBJJNOOKONOOKJJJBJJLK@KEJMMANKMKMOCKMGMEJKDJBJCE@HKAHDDJEADJJKGNMGFOJKGGKKMGKKGOKOMLMGBEJBMKGKGMKKFOEEEKGEFOFOKIIABHIEDJJIIADED@MFHH@@" "MDJBJJDJIABDJBIEDIIA@DFMEDJIBJJDBEKKMMNOJEMBMIDGKKKKFMKMNMOJDMGEDJJDDIEIDIJDBDOKOEE@@JDIBEGKONKEAIABEEDKKEEBIGINEGEMBMMOOOOOOOMMJEMGECLODJEEFNIEEBDDLEFKONOEBDIBH@EEGNOIBABLIDMDIABJIEGEIBOMKMNMKFNNNOADMJEMBOKMMNNMBABJJDJIEEKA@DDLIEDJBIBDDJIBJJBIEH@@" "BKDMBDMAEFJIBEBIBBBJKIIBDIAAEBDIFJFJJBIEOJDMBEIKGGNLI@EGAJIDI@HHBBDIMBDBAB@IDIEGOOMGMMIBEGEEJHJJJFNMJOKFFEGGGHFINJHBEBJLOGOOGIJJEB@JKLK@OGGECCFOJMKKBJJHJMEGEBDMMOEOOOEDIDHBDBABELIBB@HHDIDJLGE@DIKOGFLMBEIBOMDJBJKBKDIBEDDDIBDLNJJBBDJEBDJKEDEIBEIFJ@@@" "MDK@FI@JB@DJHLECEEDI@BBDJCFKBEAB@DHEDJBEAEKBEKJFKMEKNOIDFAEABBBBIEAB@DIDJDKBIBIEOKIECAFMBFIOGOMFKIEFEEDMKMLMDEMJKNKMNMNMJOJOJMKMKMNKNJMMAEIMNMIEECEDNKEOOGLKBEKDFEDNOMDJDJFIBIDI@BDEDJBBBDEDCADOKNMENKBNMBFMDEBBIE@I@BDEBFKFBIBB@DIEEFEAHJI@BBHDK@FIEH@@" "JKDKIJKEDKIBEAJDBECBFMEIIDI@DJFDMACHEEDJDJDIEEEIMEEFKEGIHJDJDLHIBDLDJMDIEEDEBLKGLOFBNOKBLMGDLKCMJFI@HEEBDBBACGFKFIDAA@IKGNOKOFLHDDADKFKGFDBBABEE@HDKBMNFIIGEIJFOKJCGIOFIJEAEEDIEJIAIBDHIIBIBHLOEFKEEELMEEDIBIBIEE@NDEICBI@DIDLMEKBFEBABLEBDNIEFJLNIFJH@@" "EDKDFED@IDBMIFBJJJDDI@JBBEFFJDHIBJOEDHEAAEKECKIBBJMKDMJOEBIAI@KBDJAEB@IBHIBJDAEEKOHMA@DJAGEMOJLBDIEFKJJMKMMNNJNOEGKENONNOKONOKKOKMFOEGKJKKMMNMJJNKEDIBAJOMMGDBI@DEHONMEDABJDHJDHBEDBIBFHDLDJEGJMIFMJJBDNNEFMDDE@IEGJJDHIBKCEBBBHDIABJJJCDMJADHAECAFIE@@@" "JIDJHHIGBAE@B@MDJDJIJFIDIK@HIBEBHBJIACDJGBDBEFBEMBIDOBGJEEBDBE@EA@JDLJBIBDIDIDHJ@ME@JKJIFLNKIKINKFJMEEEKBJJMJOHJNJDJA@IKOGJOGNLHDBIBKJHOJMJJJFMEEEJKFKLNLNKIKDJNJHEEHBHIDIDIBDJBIIBHDE@EBABEEBOBGIDJEMBCEBABGBIFDDJJ@JEBDHHFLIDKBLJIBIEHB@EDBGDHHJIDJH@@" "JKEICEBHEGBEMM@IDIEJDIBIBFMEBDIDFLODFLABHMIMKIEDFLKC@MKGDADIDHFIDI@JAADBDIBABEEEGCLJEFKFJJIKGDCABIDHBHHDEAAJB@EE@HI@JEJFNOGGKKBMBHDHHEE@BBLDEA@HJ@IDJDFAGFLJJKFKEBINGEEEBDBDIBADDBHDIDK@IDIDAGFMHFFIKAEDNMLMHJDAKAGIKADIBEEKBDJDIBMDIDHEMMBGE@JEFDMFJH@@" "IDJFDIEEDHDJ@BKBJJHEBDIBEIBHJIBCEAJA@ADJGKGCGFIAMKNNOAFD@JBBIFHBABEADJADICFLJDEDHDKDKENJJOGEHKDFFDIKEKEKLMFEEFJIEEBEFJNMKNJKNMKJKEBEEDJKEECEINMFMFLICCAFHMGGJJKMFIFI@IEABIKFDIDBIDEBDB@KDJBBHACDGKKNMLDKGFGFOBID@DBLEFBDJHJDMBDIBE@JJJFJ@BI@IEEDICBIDH@@" "EEBHKBJICEEIJHIEEABHIBBDIFDBHBDHMGDNONKEJFMDBIFFJMABIKKOEADHBAEDJDDDIAECBD@A@IBIBIHA@EADIBEKG@JHHIBDJHIDACEJNMMGOJMIBHMGOEOMGOEHJDMJOOEMKJMFDADHJIBDHHJHGFMBDIDE@D@LJDJDHD@ABFEDDIAABIEDB@IDEGNNLJDEJKCDJAEKBMFKOKIGEHIB@JACDIBBDHJDEEDHJLMEFDJJFHJEE@@@" "JKMEDJDJL@JBECFBJJEGDLJICDIECFIGFNOMIELJJHJKEBHHINBDBEGDHDAKELDIAAHIBMBHDIEDJBDBFBBJFLJACEEELBIEBBIAEBJGNNJOIEBJDEBBOONMDOGGIEKOOJBEABJEDOJKKOBJEDDJBEDJAMEEFDBIKBJBCBABBIEDI@JEJDHLDDIAMFLA@IGEBABCLHHJEFJHJJIMDMOKKGDKFEDIFDJIIGEBJJCFEBBHAJIBIEENJH@@" "EEBDIDKEAGAE@DIDJDJHBABBFABHDHBOMENJFJCEEEBHDEEEGNNJLJBEBIB@DAAAFDCBD@DCACBIADIE@HHDHADJDBEKBEBBDIFMEOEK@EE@BJLIJHEMD@MGGMHMOGEHAEM@JLIJJ@EE@FMGMEKDIBBEBFMBABID@I@HHEDIDDJFDFA@ABFACDDDA@BDJEBBIJKKOEEEA@JEEEFBKBKMEOJ@I@JDCBBDB@JIBIDI@EDGDEFIDIBEE@@@" "JJMIEEHLE@JDFJJEEAEEDJDJHJECJBDJOOOLH@H@@@IFIIDAEEJIEDLJHBDMBJDJ@IDDJJIDJDDBBAEDJEKMCOMECHMELJLLKBIBK@HDKH@OFKKOEONBKFNMJMGEJMKKFJCOMGNNKGH@NI@HFJDJFIIJIMEHNEEONENMBIEDBBAABIDJJIADHBIBJEIB@JIIEDJMEDADLKDH@@@H@IOOOJIBBNEBHJIBIEEDEEBJKABHEAHMEDMJJH@@" "EEBFDJBIJEHIHIDIDEDIA@IBBHJDADIMMOKAGOKOOOEIBBKOEJABHIA@JIAJDHI@JJAA@EBBDJJLJJBIBI@@MI@EDKEOAEABDDDIDOEGEFEIDJFDEDEMDIMFOKEFOKELIEMAEACBIDMCEGEGIDIAABDEDGMFIE@DMH@DJDJBJIJJIBBE@DDBJHDHIBLDJHDDHJDBMGNJBDMGOONOODFOMMLIDABHJBDHDDIEADIDHLHMBLJBICBEE@@@" "DIE@JJMBDJBJBDJJKJMBJEBEEBIBDEBCOOEOJJOEMGKGEEGGKAFJEEDE@DDJIEBMAADBA@DIADIABEDBHBDM@BEBI@EJNDJHIIEFKJIDJHJBAEHIJIJBKCEEKBGBFMEFFJBLJLHMDBBHJIDJNKEDLHJICJM@DJEB@EIB@JAEBDDIDDI@DBADDEJEDJIA@EAEEBKDFOGEEGFOEMGJJOMGONBEABDJEEBEBJEJNJJIBBJBIBEJJHEDI@@@" "JJMEAE@EBDHIEBHIDE@JDJFJBFFMMLFMGJKJOOJOGMGOOGNJEFMJJBA@IAIDEDJ@DDADJJJBDIBDDHEHBDI@EDHDBBKCECFNFJ@IBDJA@B@HH@BJ@J@HHDFEFDHICECA@HHBHBJ@@HHB@DBIBDHBKCKFEFFJBA@IE@DIB@M@IABDIBBJJIDAA@BIEADLDHDBBJMKEBKOGOOEOGJOOJNJOEKAMMKCBBKBIBHEADHJEDHIBE@EDEEJJH@@" "AEBJKDKHIAEDHMCBKCEDIHHDDIMKGCMCNONJKOOOMONMGOOEJIBEJLJEBDBIDJDIBIDEBB@LJDHIABHADJBEBEBIDFJKLLIAIAEBDIDLEEBECJHIG@JGGEEMEJJJMEMEGGBHGDHJNEBEEAIDIBEDDLDIINJKADJEBEBBID@JDDHIBIHBBEADJDIBIDJABEBIJMBDJMGOOEKOMOOONJKOKNENGFMLIA@HLIEFFJFEHIEDDHNIFJJED@@@" "NIED@A@EDEABB@LMDLDIJBKKKEEBIGJMGLHHJKMKGGIBMEOLABDJBA@HDIDDIBIBDDEHDHKAEABBFDEFJIEFMJEBJHIGBADDBDABJEBAKBEJDDIFIGGLHEFAOEEEGLCE@IOGDKDIABMBFLBEBJDABAADBGDHJJEBMKEDJKEACBBDEDFHI@MAABDJDIADI@HDBBIBDAOMEJDOGFMNJHHIOEJODJEEFNNJBLIAIEIHBBDEAE@D@AEDKH@@" "AFIAFOFIEJFEDJAAFBID@JNNNMEEBFFKDABJKOKNMMGOKKGCLDIADJEBIB@KBDDDII@BIBHJHFDLHKJIABDHJDHDIECIFJ@KEEOFMJJJDDJEIKA@F@HAEDKOFKEFKGNIED@HC@DFLMBIABJJMKGMEFHBKDNEDI@IBHIBDDJNHIIC@JHJDJ@DLIAABFHBDJEBIDDIANGFNOOEMKNONJJDAFKCBEEEKKKJHADJCDDBIECBMDKGKDDKD@@@" "JIFJI@ACDEHJIDJFIIBIEIAEEDIAEEIBHJEAONOKGGJKGFNNKJBDEDHHJDJHDIBIBBEDBEBABHIAEDEDDDIEAAAAB@IGHIJDLH@A@B@@IA@HB@FEHJCFJMFEMFMKEMCEJKFBHMC@B@HDDH@B@D@@IIBLHODHBDDDDEDIAAEAEDDHJDBEBAEBBDJDI@JIBHHIEABBNKKKGFJOGFOKOLEBHJDMEDDIEEDDMDJDLKBIDJHMAFD@DJKDJH@@" "EFIEJEFDIBBDCADHJBEBDBFJDIBEBDBJK@HDMKMNMEDJJMKIBDJIHKJEAA@JIBHBDHJIDHJNDEBJAABE@AB@DDBFJJCBEDHIABJNKLOGBJJGMOLKGFLIAAEJJB@BBJMDDDIKGFIOMOBJJGGINKJJDDHIEBFBJKBAA@BD@EBDDBJEACJHIDJHIB@JDJHDDEBNHLJIBDNMJJIEEKMNMI@HFJJABEBDIBKBABEBBHIDFABBDICEBMDKE@@@" "BMBJDJHIBIDIDBIFEDHHIDIDMDDJDID@HBBKOOOMIOKKEBEFDI@DBD@JDJEBDDBDIBAJJB@@IBDDJEDHGNIFJMDIABJMIAJJJEEEDIDHMBA@JIADLLADFDBAEDMIEDBACADAIIDDJHDBEHIDIEEEBJJLDMJJDDIEJKDKO@IEBIABDH@BBJLBDIBAABEBIBHABA@DICEBEFNOLMOOONJB@HADIBIAEIDIDHHIECDJADIDJDHJIBJEJ@@@" "EBMEIABKEBIEBNEAJEEEBIBADIA@JBACBEDBMJKOGGFONMBHJJEAEBI@I@JIBIDMBEFJ@IBNJDIIBJEBHACDJHIJFEGKGFAADIBHIBABBDJE@BEAABKKHIOGJG@GBOGLHNNJDDEB@EBIBBDBDHJDIDDCGFOECBLHJIFD@JEBJDLIBKJDHBKEBEIDJDJHDHDJEDEBJHJEKOKGGGNJMJAEBFDBBHDDIDBDJEEEBLECJEDJEFJDDMEJE@@@" "DMBDFFEDBECDI@JFDIBBEBDJIBFEAEDDDHBMKKOFMMMJMDDE@EEGBEBEBE@BHBB@DH@IFBD@@IBBDDHEEDDEBABHHHIBDIDGADJCBHKFMK@JKDLFNHDDEDBIFLJIKDJAEAA@KKAIFJHFMKFHJFBIDGADIBDHHHJDBEAAEE@IABBDH@ABCDH@I@BB@J@EBEBEBGEE@EAAEJMMMKGNNMJ@IAAEDECBDJIBEBBDICBHDIFEBAECCABEI@@@" "EBMIIHJEFJDBEFJHJKDLJDIBBLHJFDJIEBLBONMEEGKGJOKNOJIJDJDIDJEGBJHIABJD@NIEEDDJJIBH@@IDEFEEJEJIJFIMOKBNIEBKGDKCDIIMIEEBJAFEDIEDIECDBJEEDMLLIFFIGFJEDKJFOMLKBLJMBMECEADH@@JDJJIAEEDKHABJDDHJJGEBIDIBIBLJOKNOJOFOEEEKOJAJEDJICBHIJBDIBIIFJHJKEBABKEBHLLMJE@@@" "BJJBBBIJEDIDH@JEEDAADIBDLABHHI@@@DAOMAKIBOFNGMEJJEFJM@IBB@@@DDCBEDHJJ@BBDJI@HJJEKGLIJHH@@HHJBICCKEEABKOONOHDMFDKFJJJ@OEEGFHKGEEGHBJJKFICEI@OKOONJDEEFNFDJBHHH@@HJLIOFMBJHHDJIBB@BJHIEBFAA@@@BBDHEJKEBJMEOCKGJDNLEOLA@@@DHHJDAIBDIDDAEEBH@IDIEBLJBBBJJ@@@" "EEBIDJBHIADEBNEBJAJFABDJAJDEFBJKKOOMKONOENJMMBJEDJ@@@BBDHLJKHIDEJCAAEEDDIABGCEHIDHABABCKEECBMFDDFLDJEBDDDIGKKKJDIEDDOKGGNMBEKOGFOIAEDIBNNNODIAABEBIAKAACEJFEEFNBDBD@IDHMFGBDDIAEEDDFBMADHNJIHIBB@@@BIEBJEMJKMGKONMOONNJJCEABLBIBDCBLBJECJEADDHJBIDJEE@@@" "EBLDIEECBEBJJ@MDDNDHJDHHJ@HJMMENOOOIDJINKMEABEEKEFOONMDIBA@EEBID@HJF@AAJDJDHDBBJABJJJMNLHBHDBEIAMKIMLMICABHFDFFIBHEA@BEAEBEBEDEB@DE@JDKCAC@JDFDMIMLNMLDMBA@J@IKMJJJJDBJBA@IBIBLD@CBHHADJEE@DBDIEKOOKEFMEBDEENKLJIDOOOKMEMJHHBHHIBHICIAEHBJJEBFEEDIAJE@@@" "EFJJBHDHDJIEDMBEK@JEBICCDMKJOGOMOKGJIJOKOONOOONNMIFJIBEEDJEBHDBAEEDHJDBAA@IBIED@JJIGEJEBEDBJLJEFHFOJCBBDFDEHJHIKFLHDJOGGJJHJJOGGJI@IKFLHJHMACABBFBOK@KEBIJJAEBEBMGDJJHAEDJDHDDBABHIEEDBA@JEBIEEBDJKDMKKOOOKOONOJLJOFOMOOGJNMIFFDJEBHFMBEIEDJI@I@JBJKE@@@" "DJI@MBIBIBDIA@JJDEHIDDDDAABOLNJKEGOGMNJOFEONJCEJKBHMEDI@AHHEBIHJBJAB@HLJFEBEFJIMBDDJBADHHAD@AEJEBIC@HLIA@I@BHABGEACA@EKNBGGGBCNM@DFDEGBD@J@DHDDIHHFDJEBMD@AD@HIDBBIABELJKEBECBIHHBDBJBHLJE@HL@DIEEHJFJMFBKOMCGJKMOGOEFJKIOJDDAAAADHMABJHDDIBDJDJEHDJI@@@" "IEBGAEBEBICEFEDJJJBJAIJJJDJMNIKBOOFLCEOOMOIEOONONOGIKKFKJABJMBCDHBJDJEAJHIDJHEBBDIIEEEACBJAEJ@BNDBDDJABJJBKDJFDLFLDFMJKDMNMKMIFJMKAAKAICBIFJBJJDBIABACJ@BMDBJFDEEEDLIBBE@JIDHJLEBIBJ@IFBEJJDBNKFNLOGKOKOOMDOMOOMFAKGOJFLKMJIBJJLLBJBJJIECEFDJEBEDGBEDH@@" "JJJHEBJHDBDM@HIIFAE@JBABDKEOJOFOKEMKJJKABDBJ@@AHAJJFEDJDAJIA@DHACDDIA@J@BDIECEDHIBBJJMEDDHJJAFMDHHJIBJDDAD@A@HIAMGIAFOGKKEGEFNOGKDDOELDHHD@ADAABJDJHHIEKDBJHIAEEJJJBDHIEFEDIB@BHDDIAFD@I@DDJLABIECBJL@L@@BJABDFJJNMMFOKGJOMFIBDBBHEDCDLHHEIBA@JJE@JJJH@@" "EEEFJEBKEEKJKEBBHL@EBIDJKNOIEEDIGOGLOOMMEEEEOOOGOGEILJHIDADGEABJDEABDBHJDBBADBEEJMHEGJIBIC@IFEAEEB@BHBIADAEKEBBDBFKJIBKFOJHJOKFJDJNKBABBEFMDADDJ@J@BEEDECDHFDJDJOE@MJMEBADBBABHJABDEABJDEGADADHJILMGGOGOOMEEEEMOOIOGODIEEDOKNJIDJE@AHJBEFJNMEFJEBKEEE@@@" "HMJAEJEDHJJEDADKCCKJMFKGNKIGAFKFMENIABKGNOOCDJJMFNOFKMGFKFABJFFHIHFDIDADMLLLKMIEABBJHABDBHEDEJDBJBJHADBDAB@@@DHJHIJEDDNEKEGEFMCIAEBLHJHI@@@BDABAD@JJBJABMAE@JABD@JJBDEDMNIIIMIDADIC@LHKCBJDCFKGENKGKKEJJIFGOKOFJDDKMEKFKDGDNKOFKEJNNFFIDAEBJHIEBMDBMHH@@" "KEEDJBJIEEEKBNBHDFNOGKMKEIGMGMFKKODBJMEDKJBNMKGJMDHKBKKMNHJDHHHBJJHIBAFI@AACDBEDJEEEKFLIDBIAJFIFDDABJIDIJEEBJIE@EBEBOJCGBJHJJGFBOJEBE@EDJJEEBLIDJJDAACDKBLDJADIKFMEEBIEBAFDD@DKDBDHJJJ@HHIBHKMNNJFHIEJOFMKJBNIEEJJAGNNKEOEODMFMNOGKKA@JCJFMEEDJJBIEEFH@@" "DJJEBJABJIDDE@IBIEEADJBBEFDEHJLJMGOMKBJMD@HAB@HE@ECDE@DBEJBKEBBIAAEBDJ@DJJJLKKJJNKEGDMABDMFFDJD@IADHBBIB@H@F@B@E@BHE@ADHFHJHK@ID@E@J@E@B@C@@HBDJB@IDDHABICCEIBDEIGEFKJJNNIJJJI@BIBEDDDJBEFJBMBA@EAFE@E@HBD@HAEJJFMOOEJIJHMACEBBBIDEEDJDHEAADJJDBJEBJI@@@" "EEEEEDMFHBKJLMKMJKFNMELMDHMDBIADKMECFKEBIGCNNOGJNJFBJKBMFDLBJEFFDJADJ@MKMKEKONNMIBMDIAFFIJMKIDHJJFABHMBLJEJHJLJHEDBLEDEBMK@FMJEAEAJAE@JIJHJMBIJEHJDCBJHIDNMJLKCDDIEJDMKKONMFMNMHBIDBICCEBJAICEJFJJCBKJOGKKNGDJEFKFEENIDDJAEHIEIMEKKFJMNMIJNJ@KEIEEEEE@@@" "IJJJJA@IFNHECEFJKNMKKFKJOKIKOFJIJGNNMOONOJOEIJMGMOMMDHD@HIAEDDI@JBJAAEBFAEEEBAHJBDABKEA@EA@DJBEB@HJDB@DAI@AE@ADEDADAIA@DKEOMFI@DDLADAEAD@ED@DLA@BABHHBEBBI@DE@DEFJDABBHLBEEEDCBEDDBJBHDIAEDDHHA@IEMOMOEJLMGJOKOOMKKOBLJKGNLNOJNKFNMKNJKEFE@KKDHDBJJJLH@@" "EEJEENOJIJKJNJMDEEKFFMFKDMFFJMEGGOMKKFKJIEDEGFJMAAFJKBIECBJJ@JBEDLDJFAEMNJFJDJFJNKJIDBDEKNEAADHDIA@IEEBJBBJBEJA@@JHJBBBJBJJJJBJBBBHJH@DBMBBJBBJEEDHDDI@IDDECNMABADJNKJKBIBKBKMMDCBIAIEBBHBJJFEDJFJKDDEJKGEAEDJNKFNMOOGEEJKCEIFKEKCFMEAEJKJNJLJOKMEBME@@@" "KONOOGMOOGOOOOKOMJDHH@@DCBHHJIBLJNKOEDJEFJKJHIBJMEAADDJIDDEAEEDJAAIBHJJJIEIEMMJGDIDJKHKLEDJJDEBJJBEBDJDIDEDIBADEEDBHHLE@MDGAEHEAHHJAEEADBDIEADIBIBEBBJJEABJIEANHNJIDIGBMMMDMDJJJHJDLDBIEEDEAADJIADDEEJJDHJNJKEBIEGNKJIJDJHHJFA@@@HIBMONOOOOOGOMOGOKONH@@" "DJKEEMGJIMEMOGOOKEKGGOOKLLECEEEKGOOEFKKJJKMGGFMEBBJJJIBBBJHFJHEDNJBJEEFMFJFKBDDLEBIAFKFAJGDDJHHI@JHDJDJBJJADIFA@@ADAC@LE@IHLHEAHFDAD@@DCDIDBJJBIBI@JHDHHJIAGBLCFKDDJEAIABFKBKEKEEBJBKIE@JK@JJBBDJJJJBEEKGGENJJNNKEGOOFMEEFEAINOOOGFMFOOOGMMELJOEMEFJI@@@" "GGLKJJJEGCGKNOONOOOMNJKFKENOONKBMFENMEEGONJJJNEHEDHIEBHLJEEIDBLI@DJDIEEJIEIDIEIAHIBJAD@LDNAABECBGBCIAADMADJAB@DEED@JDEA@KBBBFHDEABHAEEA@BDBIDEIDDDNBGBFEBDDCIAHADBJDHLDMDIDMDJMEDIBI@DIJADMEBIHJEDHIE@MCJJJKOOEEEKMCEJFKOOKMFKFJKMOOOKOOKNOFGEBJJNIOG@@@" "@JADDBEJJOLOAOCMNODBAEGEDNIFIAMOJMKEEJJH@AEEEANFLICBJFEADHJBIMABEIDICFIEFDBABHBJBBEAOKEAA@JLEBDDHDLFFFI@DIEJDNI@@AEBMBDE@EEE@EABEJED@@DKIBMDI@DKCCAI@IABEAJHDDEFOLEBBBJ@JDBACEDKFDIDMBDELJBHIDECBJFDIKCLEEED@@JJMEFMJOMLDKDKIEGEDBAGKMNGLGIOJJMBAADBH@@@" "GEOKKOOKMFKEFBNKEEOONNOGKMKMOOKOOOFOGFMOONJJIFAABBDE@HJJIEAEJBDDJBIDLIJDHIFNJKMJJOOO@DJJDEBADHIABIA@HIEEIBHDI@BDJD@D@DHHJHHHJHHI@A@ABIB@DI@JDMEDHHDDJDDHIDBEABJI@GOOJJMNJKKDHIBLIIDJBIABBMDEDJJHHEABBDDCDJJKOOMKGGKGOONOOMNMNOGKKOOMEFKJCEFKENOONNOMG@@@" "HJHGFJBDBIEJMJ@HJIJJMENNOGOGBIE@@JMJNKKEEEOKDIDJHNJJGBIEBDJEADIJHJBBABACEOMKEBBAEJHHMIDEBJDJICBJEBJJEBJDCECABEEA@JIAFICB@KBFHBFDKDDJHDEEBDFEFABJEBJJEBJFDJIBJEADMHHJMDBBEFMOMFDBDBBBHJLIDEBIBEDJGBJKHJIDIFOMEEFNKJMJH@EDJGGOGKKMEJJLJHHBMJMDJABBKG@JHH@@" "EEMNKOOKMOGGOOOGKOOOOOMOOOOOOOKOOOJKEEDIDKEFIFEFK@BDHEC@JIDIFEBECDMMNOOMKACBAFMFJEBKBBIHDDIHBDDHJDIBJMDIDDDJDLHDE@BFHBDDK@E@FIAB@KB@EA@IIBIAADIEJJDIBHIAB@LIA@LJBFJEBKEKDBFDFMOOKMMIFEBECDIDJHFE@IB@FKECDKEFIDIEEFJOOONOOOOOOOMOOOOONOGOOOGGMNOONKMME@@@" "JJBKNHJEKBNMJDMNGCEEEBKEDIA@BJEFDMENKFKBIDDIBHHHHEDIEJDGBJJJHJE@DIKBBH@BBNLFNMAADIDHDDBBHIBBLJIADIBEAAEBKABDIAAA@EDHAEAA@FHK@DDED@IE@DDDDIBDFJEDDEBDIDDJIJBDHJBAA@IDIDDEKKAKJB@@JBFLI@EBHJJJJGABMDIE@HHHJDIADJFKFKMEICEBJ@DDIEFJEEEFGCMIBMKJFMBHKNJBJH@@" "DIJJIGCFLMIBEKABJNJJJODJKFNOOGKEKJKEFKDDJIKEFEGKBJEEB@IHEAABKEDOKFMMOGOOOKKMDHJDIBABIIDHABEDABBKABEBFFIE@DMABJBDDHAABDBDBIBDJABABDD@IABBJDEI@EDKCBEBDFJBDAEBD@IDLJDBDIBHIENNOOOOGMMKFOIEFJDDE@LHBEEBJFOECEFLJIAFKEFJNMFOGOKKFJIGJJJKJJDFMBDMIKFGDJJLI@@@" "KFFEOMNMKGGOOFOMEAOMOEOONOKMFLNNNONOIDJJJB@JHJ@@D@HLEOGGLFNMEDODFMKEJNIECGOEKEEABDJMBEACBDJBJDHHFFDDHHJBFIBFDADJIEDFEABIEDEAEDJDECAEDJIDACBDKBBHHIACC@HIBJBIBFDEBEJIBDEEFMGOFEDKJMFMKAGIEEKKAOGGMAHHA@@BHJHBBJJIDOKOKKKIKENOKOOMGMOLEEOKGOOGFMKMOMCCFH@@" "DIKGJKGOONOFMEKCNNJKBOBJKJFELKIJIDDIBIEE@MOEOEOOKOGKOJNMKKJJOKIKGJNKEAFMFM@D@A@FHIB@IAFDDJDLEECBHHIIEBIDIBDIBDE@BHA@LDDBJBHJBJAAAHD@J@EABDIBDIDJEDLHHJFEEAIBIACDDHBDHK@D@A@EKEKDEFKJOFLNOJJNNMKJONOGNOOMGMGMHEEDJDIADJLNIMCBNJJGJFJKKNFMEKGKOOOFJOFLI@@@" "KFFNOOMKJKNMKONNAAEDM@JD@@HHA@B@JJKDJGJMFJJOJMKDNMNOGGKKDD@ADDFEHAADBNMLMJJIEFFICBDKBJ@IAABA@DDFEEBBIEFIBDIDDIHJDEJE@HID@MBEHADHHEBMABHLIADIBDKEDJBEECAA@DBDDDHBJFIBFDKCEDJJMIMKJADD@MCAAD@AAFNOGGKMKIFMJOJJKEJOBIFJJHB@D@HH@ABHEIEDDCKONMKNJNMOOKKCFH@@" "DIMMJJONONMOOECMNJJEBOGMOOKGOOMOJMEAEHEBIEFKBJFMEGKONMGMOKONOKMOGONKOKOKMABJJHIDDBIHDDMFDDDJGBJHJBDIEA@BDIBEIBB@I@@HIABAE@E@EDBDDHH@DHBBDMBDIB@DEDIBBHJJGBIAACEIA@LJAADHJJJDENONONKOOGMNOKONOMOEKONOEEKBJFKEDJE@MDEEJOMOOOFOOMOGJEBJKMNEGOMKOKOJJMMLI@@@" "KGCKGOIMOEKEJMNKEGEOOELKFKFMJJKDKDEGDBJIEE@JMGLKGMFNEKEAEFIGMFKJOEENIEJNHDDA@BDBIDBBIIA@JII@HDIBIFIJ@JGEIEDJBDHIBEECBJHJ@JHJHBHJJFEEBDHIBBIEDMGBHBLKDJDI@HDLJHDDLJBADJAB@DAA@KJMDKMEGJNKEODKEDEFMCKEOFIOEJHEEDJJAGEAFIFJJMKFKFIMGOMGEFKMJMFMGMLOOFNGFH@@" "JNOGOOOBJNMOGOONONOFMNKJEFIBEEDKJIB@AEEDHBFIBHCD@AIDJDLKFMGMGKOGMONKFKGKBJJJEDIHIAEDDDJEDBBEEABEBEBAFHHDBHAIDJABHHHDD@DHIEBEDHI@AA@HHJDBIDL@JA@HKDBEBEBDEEBBAEBIAAEDDHLIEBJJJFOFKFKOMOGNOEOEKFIIBIDL@AF@JDKB@IEED@BDJNIEEBDKEBNKMKGKOKOOOGMKJJGOOOGKJH@@" "JHKFMAIMNKGONMMOOOMMKKNOOEGONKEDFJMOOFJKKNMOMGNKOOFOOOKNLHJGNOFLKEEDIGNLDHIDIEBCBFHIIBDLAEDJBFDJDHEEACEIDBJBE@JDKBBIAEABBBEBBBDEDDJBFIBHEBBJADMFDEE@IBICBBIEDAIBDLHKBFBEDIDHIAKODIEEFIKGKOBHIKNOOOKGONKOEOMKNNJKGOMJKAEFKOOEGOKNNMMOOOMMKOOFKMLLEKFHJH@@" "KFJEFKGKKOOOOOKOOOOOOFMJJKOJJNKOMOKNJMOOEDKIGMENFMONJNOEMEKLMHHJEOFKGLAAABJAB@DHE@CBBHIAJDE@LHI@EBIBDDBBADIDHEAA@DHBJHJDIE@EDIBHJJ@I@DDE@IDIDBBAABDJE@DHIHEABLDHJBF@E@I@BDBJDDDAOFKGMBHHMINMEMGKJKOMKCMEODNIEGOMJKNOMONKJJONJJMKGOOOOONOOOOONNOFKEBKFH@@" "JJKEKEMEGMKFEOONONOOKOOOOGOGONNJKKGEOOMMOKOGMKOKMOMNOMNOOOFCFCEAO@MEOAFEFDIFDMIFJEDEDKBDDI@EBEBFLFBDIIMDJEBABHDJFIADDBHIBDJIBDHJAADDKBI@JDBEBIELLIBCAKBEBE@DIABFIEAEBKDMICDICECDGMEHGLEFCFCGOOKMOKMOMNONMOGNOMMOOMGFNJKKOOGOGOOONOOKOKOOMCFMOEEMFMFJJH@@" "EEFOEGEEDBODJJJMNEJIGMMGONMOOMIEDDJOBJMCBDJJEEABJ@JJECAHIBJJONOOEO@JBJIA@IBHI@BHHLIHI@DIABDHI@DIAHEBBBAADHDJDDI@HJBAADABDI@DIBDADDBBHHDIABI@IDDBBBE@LDI@DHIBDDI@DHLIHHJ@DHJDHDDJJBHGMGOKOJJJDHLFEBJHBJDEEBJIBFEJJGJIAEDMOOMKOOEMODJMCMJJJIGJAEEGEGKEE@@@" "BOMDMDJOKOMOOOOONOOOOGGNJOOJNONJJJE@MEADEEDEEBOEEOKGJLNGBLIGMFKDJ@KADBBFEBDEBEEBBABBBJIBDDICBEIDDBLIEDJFIBJBKABEE@LJLEJDIBEBDIBMAJIHEEBDFJBJDKBIEDIJAADMBFDIABDJJBBDBBEEBEABECBBADFHBIFKEODIJGCIJOFOMEGJEEAEEADEEHEBJJKOKJOOJKOGGOOOKOOOOOMONOJIEIEOJ@@@" "OJBIBEE@EEKMDJEEAJIJMOOMKMMGKJJJLIBGBIFKMEKNMOJONBNNMOMMMCJJJDJEEJHDEDLHJHIBDLDEEDEDJDIDEABDDJBBJJABAADHJDHDDHDH@E@JA@BIBFHKBDJ@DBHE@@I@IA@IBHIDDBDBJJBBIABDEADIBIEAEEAAIBDHJHIIEA@JMEBIBJJNEMMOMKKJCOJOMKNMENKDJGBDIJJJNOEMNMOOMJLJLEEBIENME@EEBDJBOH@@" "EEECDIDMJEBKKFOOOKGEJHHCGKONNOKKEDMHNONJKNNMMAFIAMEKKECKKMFOFIDI@DKBJBABDCBJIAEDDIDIDICAHJDIAADLHHJDLJKCHIBMACBBFHI@IEDBE@JHEBAEDHDHKBBFDEJDHNFJIIBHHIIDDDIBHLFDIDIDIAEDDJJFABDBBJFI@DIDKGKENNNEFNMELDKDEMKKNJKOKHMIEFNOKKONOF@HJMGFOOOKFNJEBMIDIFEEE@@@" "NJNDEDEBBIEBDIFJJEMOGOGMKGKEJJMDMEBCA@ADLAAB@JIENADEDINEFJIJDJIBEB@DHLJDIDFBBDHIBFIBABDDBBICFDIABKAAABDDEBDAGDEDHCBIBBADHE@E@IDBBDJF@IEAGDABEAABDDDFJDDICFDJBAABDBDKBDHIBBCADIBIHI@BEBDJIBLJKECLIEADCMDJHBDDAID@DFBEEIEJJMFOFMOGOGMMBJKDIBEDJBEAEACJKH@@" "EEDJLIHHEBAEADNOEKBOOEMFNMGOEEBKOIENNONOKNNMOGBJENOKIGENIABBKEEDIDJJBADIBA@LLJCBE@BDJDIAEDBD@MBJE@FFDHJIIEBJ@BDADHDCDHJIABEBDDJHIFA@IDAB@BJEDLJHICC@EBJEHABAEDDIBIB@EBFBIIHDBDIDBBJIDIEEFJBDDKMGDNOKMBJGGMKKNOKOKKMDONJEEGOEKKEMGOJFMGKIDEDBE@HLIJIEE@@@" "JKIEBBCDJDKBFAIMNJOMOOKIABJBOJEDIFFIEEEHFKEJHNOKOKMGGNJABJDNJEBABBBEDMABDJEABDHDLJLIDIBBHBDIE@HDHE@HIEEBBHDEBJHJABIDAB@DFDMICA@BDADJDBHJJEA@JBEEDHHE@I@HEDIB@JBDIDIJII@IBDEBIBDEIEBBBDBEBKIBJDBKOGENONOKHJMFK@MEEDKCDIEBOJBJDDNOOMOJKMLLCBFIBIFBBEDNJH@@" "EEEEEEDADIDE@JBGKOOOKKGONMEM@JKCFMIEFJIGIEEGKMKGMGKNMEDJEDI@DIDJDLLJI@DDIDJJHIBJABABACDMBHIBDJKABJFEBDIDIBI@DHC@IDB@IFIBHJ@BHJDKDHBADHF@I@DJDIDIBECBJDFJIBDHJEIFDBDBDBJDHJJIDIA@DJIIIBIDI@DIEBIEEKNOEOFMNOEEDODJKEDMKFFJHEMEKOOFNOOONOBBHEADIDAEEEEEE@@@" "EJJIBLIEABADJBJHDMNNOENEEKKBOENNMKFKMKGJONKNOGOOGIEKJKIBMEBNKJIDIAAEBEBKBIHICBE@JDJEFDA@DCBDIB@JDHHIDIBBDJBJIBHEABDIB@BHEAEDE@J@BDIBDE@JDJJBIBBDIDHHIBHBDIBFA@DACEBIBHEBFDHLJFJEBEDDDIDJNKJEEJDNJNMDOGOOGKNKOJOFMNKFMKKMGJFNMECMGKKMI@JJBIDBDEDIJDJJM@@@" "KEEJDBJJFEEBHJDKCCEMOOEGMFJOEFIEAFAFKFJEKBMEJMGFNNKDEGCEBDF@IBFABJEBHLHHFJEBDFHEDIDJHIDJHHHIBEJDIEBDADEEA@J@BDB@BDHBDEDB@JHJHBAEAB@IB@BAB@BHDEEADABEDIBMBDHHHJIDHJIDIE@KABEBK@HIHJEBJDCBDHCABEFGEAFKKKGEJMEJFMBKFKDCDEDKEGJKEOEGOMMFFFIBHJEECBJJABMEFH@@" "GFKBIEC@IDDECBIDDDIBJHBJKLE@JIFDOMOMKFOMFMCDJJMMEKHIMDLBEDHKBFIEDDHEEACBHADDJHIIABA@CBIAEBBEDHBIB@DIDIJDEEBJLIDLIAC@HHAHJBBBBHL@HHFDDIIDIJJEEABLIDI@BDJ@IEBBEDDJF@DBDDLHJIAD@JFDEE@IAEDKBFHIEBAIELHNMEMJJIFEKEOKFMOMOICDJHEANJJ@JJDIAADJFEAADHFEDJFKG@@@" "JJJEEBDFJAIJDMBJKEBIEBNJJOEGKGMOJKEKFMJKOGLKEEGEMDGBJKBLKKJHEHJJBJBJBDDEBNIIACFBDHJKDFBDBIEABCJDJJIBEBBJIBDBABIADFDECDJBEEEEEBBIFEACADDJDBABDJJBEBDJJIBNBDEDJABCAFJHIBCFDDLKJEAABBJBJBJHM@JNNIJFJJGAEMGEEFIOGNJMKFMFJOMOFOEGJJKJEDJEFJJEIBLLBKABEEBJJH@@" "EEDMBDII@JBDKCEADIEBBE@BEAOMFNAEEDJ@KCNNENKDJJIEBBHECBJAEDABKCEADIEBIIKBEABDJDIDICDDI@HIHBBFDLDI@ABDJDIDDHIDJDBDA@JJDAAE@DEA@EDDABJHDABABIDHIADIBIBD@DIAICBB@LHHDIAFDIDIBIBDEBFLLJEDIDEFFJDAEDBJFE@JBEDJJIFKMCKNFHBIEEDCKEOLEB@EBBEDIDEFFIBBHDLIBEIEE@@@" "EEMEEECBGAEEDMAFABBDJHEHIEEEEEMDJKEONMEEJOOKMOFELMBHLDDJJJJIBDJJIBDDJJ@DJDMBBIBICDAABECBCDLHMABJEJDJBIBEAEBEDIDJJE@HHJD@DIHLI@ABHHHEBJIDIEBEDEBDJBIBMBJDEHIIFBFEBDDAFDJDJBEIBI@BJIABDJJIBDJJJJIAAHJEIMCGMNOOJMEEKOMFJIEMEEEEDHM@JIBBDCDEIEEDGBFEEEEME@@@" "JJIEDEDDHFAEEBFHNDIADCDBBJDIDOGKEFKEBBIIEAAF@@HHA@BBABIEEDIBEEBDBJII@IJIDJ@HJBDBDBJDDMDDHAAB@ED@JABDJBFHDHJDABE@BJEBC@IBIBBBDJDHFBEBJ@EBDABHI@KBBIBDBHAE@BDD@IAEIABJABABBHHBIDJLHDLJJABEEBDIEEDJDBB@D@HH@CDDEDLJBEFKEFOGIDIBJBAFADDICHKBEEDC@IAEAEDJJH@@" "MGFJEJBIBHNJJJICAIDEADAEFDIBI@HJJMDJMMBCAFFHKKECFEEDJDJJIEBDJJIAEDDBEFAEEEECEDJLII@II@AABJEDIDBJHJDIDLIBIBHIBDHFHDJIDBBDBEEEBABBADJI@K@IBDHJDJDIIDIBHJJADIEBJDD@DLHDLIJIEFEEEEDCEBAAEDDJJIBEDJJIBIEECFEFNHKCDFBEMJIEJJHHDJDICEDADEADLFDJJJKHJDJBMBKGEH@@" "BJIFJDLJDE@JJIDDJBBJJBJDHIBJBJCBE@HI@BDHNHIEHDBD@JJAHIBICEDICEBEBAJJHIFBHHBFDIDABBEBBEBJDIBACADBCBEDIABDJEADDIBHEA@BADHJHJEBHJHIDB@DE@JDIADEBIBDDIEBFBADFDBDIBJEBBEBBDADICB@HJCDHJJLBEBEFDIEFDJDHLBJHABA@MDHKHIB@DHHEBFBJBJDHIBJBJJBBIADJJHEABIIBKDJJ@@@" "OENJEEBDIJEEDECJEEDH@LBIBJDHLDLDHKCDFJIE@BBHBKDIE@DJEFDJDIBJFHDJEFDHCBIEFEFIABIDEDIEDJFBIBDJDFEEDDHJBJJIADC@JDIB@DJDJAB@JDHIBHBDBIBI@BDIBHFADDJJJBHIAEECABIBDJCBIEDIEADJDDKECEDJF@ICEBI@KBJDIBICEBI@EDIFJ@JB@EDJKAFFHIAIAHIBJDJAH@IEEBNEAEEBLIBEEBKMGH@@" "DJEDJIEAB@JJJJHA@DBBIADDHHICAAABBDDHHHBBNLJEDHBJIFKEJHIBIFHHICIDJHICHIBJHJIFJMBIHEBAA@HHBDIDJHHDIBE@HBJJDIDE@IBDLA@I@JEB@IBDHBEBHDHDAIBDHEADIBJJ@HEBDI@HJIDIB@HHDDBE@LJEJKDJHJJDHNDHJIDNDHHKDJDHJMFKDJJ@IEBIKJB@HHIABBDDDFDHHIADDJBA@D@JJJJHBDEDJIEBI@@@" "KGJMEBJKEGEEEEGDJMLMBJIEECKDDJJHMABCECDM@ABJIBJ@BIDBDEBLJJECFDBBBEJDBBJEEDF@BBJBBHFLFFECDIBAABBIBHIEEEEDIBJJEDIBAJEDIBHDJBEBBI@JDIEBLBDIEBJJDIEEEEDHJDJBDDBDIFECCAK@JBBJB@CAEEBJBABMBBBACFEBJIJEABADJ@BJDJJD@EIFEFBDEHJJIAFNEEDJJEIMJIGEEEEGEFJJEEJOFH@@" "DJEBJEDHA@IFKHHKE@BAFIBI@H@ABBHE@JEDHDIAEJMDBDHKEDIDJJJKEEJDAKDHLLEADDHJJKIFLIEEEBHA@HHDIEDJJEDJDCBBJHIABI@HJEBDJ@HIBDEBHIBDHJEABDHHBIBEBHHDJDDHJJBFABIEBJIEDI@HHD@JEEEDIKDNJJHIADEAIHIFLABMEFJJJIDIEFHIBAEJMDDI@IEBHE@JBD@@HDJDKDB@EFHHNKDHD@IEBJEBI@@@" "KENMDJKGNOGEOGOFJOMNIFMEEGONMMGIGEICFKFNJEBINKEDDIJKIEE@IB@JNDIKABHFIJKJJHDICBIBDEBKEBKJBBABEDK@IDEDIEBEFBEBHHLHIEBBDI@DAFECDA@DIBBEDHIHHJEBCEBEDIEADHFIEBDBBBNJEFJEABDJFDI@JJNJLK@JDFLICJHBDHEEDNJLIAEFKLJEBKKFKFDMGDOEMKOOEEEKDKMOJKGOGMGGKOFJIEKMFH@@" "EJIBIEEMEIIKJEJJOBIEFIJJMJ@BIFHFJMFNIJIICJMKDNKKKGGGGKJOFMOECKB@JIBIBE@EDEBEDJFDIDDHBDHADLKDHI@EBJHIBHJLIDJIEBACBDHLIBEAB@HHBDEBDIHIBFDBEDJIDIJHJDHJJE@DHIFIID@IB@IADICBIEBEAE@EBDJDJHBFNEGMKGJNOGGGFNNKIFMJNDLJLKKEJK@KDJ@BMJJLKEDJGJJMBNLLMEMEDJDJM@@@" "JEFMJEEBJFFFEKBI@JBJIFEEBEMIBICIEBIABEFEDECFGDJFJJLNNOGJKKEJOFOOEFFBEDJJEJIJIDHICAEBLIBJEADEEBEAEBCCEBEAFBIBBDJDEACABE@FDJEBIC@EBDFDEABIBBDJCDEBEFFBEDEBEEADEBJDIJEDFDHIDJLJMBJIEBCCEGOKGJMFNJOGKKIJJKBIGCFEAECEBDDJEDNDJDMMBEECDJJBHDJFMCCCBJEEBMKEBH@@" "MJIBEEFDHIIEJDMEBJMABHHHMHBBJBDBDMBJJHIJJJE@HKEIELJIEBJKJJOGKFJJOMMOJKEEJEFAFIEBDFIEBEEDHJIHJDJKBDLDDIJJIJBDLIHJHBDEDHJHIDHIDHJHIEAB@JHLIIBBLJJLIAAIBFJIBHLJHIEEBEDKABEDKDCEBMEFJOMMOJJKFOGJJNJJEDJIMDMFHHEBJJLHJJJEIBABBJB@MHHHJDEJJEEIBMDLHICEEBDJMH@@" "JEDLJIDMCBBJEJJJFE@FJCEBJCDJDLIDI@JEBGBDEDJEENJFBAIFHMEDBIBJGEEEDJJJFEOOEJAJIFJJJHDDHJDIBIBC@IDDDMBJKBEBFDMAABAABMBLBB@JBIJLJBHBBAJEJDDBDDEICBEBFJJEIAADHFBDJDIBHIA@JJJKDJLBMGOMCBJJIEEEGBJDJAEEHKDLBCBKMEBIEABGBEBHDIDIIBIFBJEFBK@ECBJJMBJBFEIDJIIEBH@@" "EJKAJFIADFJMBAJHHJEHDLBEEDEBIBJIFKDHHHEAHIFJEIE@MJFHFJJJMFJDJMBJIEIDIMABJIGGGLMLMGKKGMKBEDIDEBIBI@HHLEJDII@JJDJJD@DADIE@IB@BDHEDIDA@ABJIBJHDLIBMAHHHDJDJEADIEBFMOFNOEIMIOGGDJJDELIDMDJJEJIBKEJJJK@KBMHEDMBKDHLE@HHIFKDJJDJEAEEBAI@MBHHJLBEJKADDKBLFJM@@@" "JEHJEIDMEIEBJJEBJHJCIBLJEBJDJIAC@DAEBJJJCCAHKFDEBEIFJJJIAEEMEBNJFJBIF@NNKFJIEKFCKJEJEKNMJEEBJJBDBEEEBJBIFBKBDMBEBEJJIB@JJDMIBJHBDJJMBEBEIBFJCDJBJEEEBABBJJEEBMKNMBMBNNCFMDJKFKKHCDJBKBKJEEMEDDJJJKDMBEACFHLFFBJJJEDA@FDDJIBJEBIJDNBHJJEBJJEDMEIDMBHMBH@@" "EJGDJFJBJBEIEEJEABEDBIBIJJHKDNFDEIFEDHJEDDFEEIAJLJDIDEEBNEEEBLAEIDIBIEAADIECE@ILDEBCJB@KEKJNJJMMNNJJMINFMMDDI@M@HLA@BEE@AE@ED@EEB@DAHHEHDIAEMKCLMJJKKMMJJKJNMFHBBNBEAALHEFEDIDDEDJDIDMDAJEEECJEEADIBIJLDMECAAEBHIECDMACCIFHJJLJDJAEBDEBMEDMBBJBKBIGBM@@@" "JKJIDHHHIEEBHJDLEDJBMBJBEBEHIDHJJBHJABDJIIHICJFAEDJEBJBMBJJJEAJJBAFEBDJDKBHLJKBABHIDAFNHBDEAEEJBJIKMGGEJJDKJJJ@FEADFHH@EDHJHIE@@HKADEC@BJJNIBJMGGENLJJBMEDEAB@KKDADHJDBFJIHJFIBIBECDBBJLEBJJJEJBJEBIEDCBNDHLLJIBDBHJBJHIDHMBEBBJEJBIEAIBHJEEDHHHIDJNJH@@" "KJNOEGEKEBKNCBJAEEDJIFDLHIBCBGBHHJCDJLIDBBBJGDIFDJIMDJMBDEBJJJEEDN@JDIEBDECABDDJICBIFIABLJJDKEEEEFEBJJJDMEEEEEMIDEBHEBE@IBHJDHEBE@JEADMMEEEEEIBJJJECEEEEFIBJIJDDKDJFDJIABDFEABEDIBHCIEEBJJJEABEJIELJICDIGBJBBADIJIFBHHJGBFBDHIICDJIEEDBJFCNJEFMGEGKJNH@@" "ECJJOJJDIEFJLMFMBIEBE@IAEGEDDMECCHLAB@JJMEEJMEE@IAFJEEBLJKMFIEKEE@JHIBIEJJDJIJIDFDFBHFDEABDJHDIBA@IEEDJIBJJIBJJFKJDE@HHFBJBBJC@HHEABNKBJJDJJJDJIEEDHDBDI@JIBDEAC@JCACADJLJIBJMDJDHJHEEFMDKENJIJEEBKDDHEEEJMEEJJHBDAHNFEEIAEGEDDHEBEDJEKEIJKEDIBJOJJNE@@@" "JEBJIEGEFJNLCBI@JJEFJEDEBHDIECJDHCBJIEIE@JJDGMBEFDIBJJJAEEBMFJDJJEECBJFDDIBHJECA@JHJBHJJDDIBBIBDJEJIECADIEBBEBEIDDKJJEBHMAEDEHJEBJNIADMBEBBEDIDFEDJMBIBDJBDIABJHJBHJHDFEBHJDIACBJFEEBJIBKEJEEDBJJJDICEBEOABJHEDMDJJF@IBNEDI@JEAEBKEBJHDJFAKJKEGEDJJEBH@@" "DMEEFBHJIEMKNMEEEFJDDIELEBIBHHMBEDDIBDBDEADJODDI@IFJJIEMCEMJIEJJHLHHFA@IIFECAJDFJICDMCADIIBDMBDIEDEBBDFABDDLJDJBEEDEEKEE@JEBHEEFMEAEEBBIBIIABDCABBEAEDIBEIBDLIDFEIFDJKABLFECDLHDC@HIHJJMDJMMFEMDJJKDHDIAGJIDEABABDIAEBEHHJDJEAMDIABKEEEEKNMMDJHJCEEEI@@@" "KCEDHMEJKBJHEEJJKLMKKFDAEEFEBELJHIEBDIDJHJEHNKJDEBLDEJJCFCFMNJEEEAEBHJEBBHLHNDJHEBDA@DDBBB@I@DKCAAHDMBHJEEIAHIHHHHABBBDJOBHJGJIBBBD@HHHLHLDMEBHJEI@LDFFI@DHBBBAA@DABE@JICHIHJBEBHJEDEEEBKMKFCFBJMAAJEABNKHMBHJIDIBEDHJIMBECEEDACFNMINJJME@JJFJMEHIEFFH@@" "DDIEEABE@EDKIEEEFKEDJIJLJBIEDIGDCBBLIJBJJIHCODEBJEBJIAENELECCEJMBLIECDJMEEAE@JJEBHJJEJIDLHGBJIHDFJBIDDKBIDBDCDCEBEFLMDIE@IJLHEDIEIKEBEFAFABADJFIADJBKA@LJJG@IIDJMBJHJEBJHEDEEEJIFEDIJEJMFFEAMCMDDJJEBJEAGN@LJJJBLIJBFAGDIEDJBIJLJIEFKEEEDNIE@EBDEEDIA@@@" "BKBJIFDHEBI@FEBBIDJIDNMIJMFJEDOJLDJAD@LJABEDNIHIDJMJFNK@JAJNNJBBDABBDBIBLJDHJDDJDCADJABIADHFEBBI@AEBIE@DBIDIDBH@DH@AHEBHEBEBE@JE@L@@I@@JADIDJA@EDJED@DJBEC@IDDJDBIDFABIABHIBIJDJABBDABBBKKJLBHFKKBMJIDHLKIEBDBIHADBIAJOIEBKEJLMKIDJIDJBEC@DJE@ICDJJFJ@@@" "EDEDJIEJIDDM@JMMDIDFKA@GEBMEJJOIBIDJKEAEFLICNJBBJIFMIABNIJDHIEELJJIDJJDJA@MCBII@JLFADJDBDAE@HEEBEJHDJDJJEBEBJDJJIAEJBHDDHEEE@IA@JBMDDJJIBJEBEBJIBI@JMBEE@HEDABABIDCAJHDLJFEHDBIBJIDJJIMEDHIBLKJDDMKDJJBBKNDIKEDEFJIDJDOJJMEJEG@DFKADIEMJHEIADJMDJIEAE@@@" "JKJJDJJBCBIBEFBHIIAI@FKHJFBJLMNNHJJIDDDJHABEMAEEBKKBBMEABACGBBJCDDJIBDIDJMADDBBMBC@IABIE@J@ECBDDJ@BIBIFHJJHD@I@@BB@EEBIABJ@BJDDJEE@BB@@DHA@JJHKDJDJ@BIABFE@BHEDJDDHFBEJBAADEJIDIBDJIAFBJBGFDBDEEJBFNJEEDEMBD@JIAADJJHKKMIJJCBHNK@DLDLHJCEBDJFBBJIBJNJH@@" "BJEEIEADLEBLJ@IBBBNBNHDBDHMECJENKFKFOJJJBJDKJEBJE@DLMBJEEDLHNLJMEAAEDIBIJ@JJMFN@EDEBDDJDIDJJDDIIDMECDDHEEDGAJDEKDDK@J@@DDHMHIA@@BHFIAFMABLGAEE@IAFEEIDLIABJIDIBIABEAE@CKEJJHBLJDIEDDEEJIKHIIEEBJEII@EBJEBNIBJBJJOKFKFKMBNEEHIBA@KJCJBBDHBIJEAIDEDMEBJ@@@" "EDJDFJFIABDKEJJIDMAJ@JIDIE@JLDKMDLJKJMJMMKKGLJDDJKIA@DDEDIAEEBEBIFDHBDEBDJEA@I@JJBJDII@ECBHHIABBA@HDEIEHEA@D@I@@BH@B@JEBAB@BDBEBHB@@J@@DHA@DE@MDMA@HDBBDDHHJFE@DLIBJBJHDHDEBIBEAB@ICDJEBEEDDIEAA@DDNJIABIOFNMMJMJNJIIENIAJHEDIDJHBLEIDJJMFIBDDKBKABIE@@@" "EEEC@DHJEDJDHEEBE@JAE@JIB@EBBJEOAAEEBJEKGDDOCDIEEDBFEEIJEBJJMJJJJ@ICIELDI@HJEDMBDJEDJBDJDDECBJDIDKBJJBDBJFFMEBBJHBJDI@HHFEEEC@HHDIBJ@JJBEEKCBJABBJJFIDIBJFEAABIBBIEBIBEIEBHHDIAMDNDHBJJJMJJJEBLMECBAEEDIFGIAGFMBJEEDDGMBJBE@BDJHEDBHEBEE@IBIEBHI@FEEE@@@" "JJJDEAE@JCDJEE@DHJAFDIBDIFJEDHIGFDDHIIBDJCKODOFJHELIBHBEEEABJDEAEEBDBBBIDJJEJIBDIDHIADIDIBHDF@IDADDHDHIDJHH@@DD@BH@IBBBBHHE@HJBBBDH@J@AA@@@HJIDHI@IADADHCA@JDIDIDDHIDIBDJMBJIDJBBABEEDEABJDEEEB@JDIM@JKGIGNNBIBDLHIACGDHIEBKDIBDICDBHI@EEBIFBHEDEABJJH@@" "EADJJF@NDLIBJJKKBDM@JCDIB@IDECEOHJIBJBMKEDBOEJMKOKCFMEFJMDJEMKBFJ@JJHLLJMDIDIBDIBABBJBBIBJEI@KBEFAABIBJIEEDIEAABHABBHDHHJJHJJHHI@JBD@JDDEDIEEDJJDJDDCEBFHDMBJDJBBJBDBDIBDIDIEJIIHJJHBKBFMMBIEJKEEKFFONMJMGJAEFMJBJDJHOMFEADHBDIFBHEIBFNJJJDIICHCBJIDE@@@" "JEEA@IE@IABDJJD@MABDIDBBDJDEJD@GM@DIIDCDJEENJEBNJOEMBJIEBIEMBFFIDKABKAAAAABEBDIBJJDJBEDBDHHBE@EB@JFDBE@BJBAB@DDDABDHBHBB@EBE@BB@J@IBDAAA@BDBBJ@EBACBHBE@EB@HIBAEBBIBJJDIBEBDDDDDFJDFIDKCBEMDJEDJJEMGJKJEBKMEBIFADLI@EO@ABMABIBBADIBDEHABJIBDDHEDHDEEBH@@" "DJIFMDEFDJHIEDIE@FHIBEDLIAAH@IFOJKBDBAFKDICNADEAEEFJMEFJMJKKMIHBIHNE@DLJJFDIDIBD@ACEDLIIBBBJJFHHEBHKEBJM@LJDIJIADDABH@HHJHHHJHHH@JDAADDJLIBIHEJJEFHJE@HKBJJBBDLIIEFD@ABDIDICBJII@ECHLJ@LMNNJMJKEEJKEEDEADCNDIFKDBABFJOKDH@LDDIIEBDHK@EDIEDHJICEAEKDJI@@@" "BJEABBHHIDKCDIBJEHEBDHIABFBCKB@GNHDIDJFLIFGNJAIFHJIEBDJJJJOFBGEIBB@JFIAEDHKEEBEAEDHDEBBDHMDHDHBBJEBHFDB@EA@ID@BJA@JEAE@K@BEB@FHEDEBHDBJ@ADHDE@BAC@JEBJB@I@IEHIBBEA@IEDEBEEFHIEDDKBHBBDMGBCGJJJJIBEDJHKDLBKOCDIKBIDI@KO@BFNBCBDDHIBE@MBJDIFFIDHHJBDEBJ@@@" "MEDJHMCEDIDHKEE@JEBDIBBDDHMDDEEGKBIBEADIEACMEFBHCADDDI@JKEDMMJKGEMEDHJK@IBDJHEBJABBI@EEAE@ABICDM@HEBNJIKIDKBAED@DE@@D@E@EDHIE@E@A@@EA@AEDBFIDNLJKJE@HEIFDJD@EDEE@DJBDBJE@JIBDHFJHIEEMGFJMMIEFJHDIAADF@JCEENDEDIDEBDJFOEEAAEHIABBDIBEBHEEFHIDIEFEHJIEEH@@" "BJIEE@DBIEBEDHEEEDLIBDLIIB@IADDEGDJDHDKBJDGFH@JCDDAIBBGFJJKKEEJMGBJKEBJKEDKAEHJ@JDHBEJHJ@FLFBDEDEEDDDIBDBBDDJ@AEBHDIIE@E@EBE@E@EDLI@JED@BIABBABDIAAEEAEABCAK@BHJMB@IBHBHMDFIEFJJEFJJGEJMEFNJJKGBBDLAAFBH@KGABJFI@IBIGEAADDHBDLIIBDIIEEE@IEBEDJA@EEDJJ@@@" "EECDJJIDBHEKACHIBIABFIAJBEEBJIBKOM@IBJDDHJOOEMHLBJJBDLHKEFDJIOEAJNJJBLKFJI@GBCAE@IEDHECDJH@HDI@I@@IIGBDJMEI@@JJ@DAABB@DHBHE@J@I@BBDDA@BJH@DMEJIBGDLH@DHDI@H@JIFE@IEDHEDFBG@DJKFIJBJKJLEGLJICEFHIIBBJJAHMMGOJHIABJDHEONJDJJEEBBLDKBDDJDHNDFM@JADJJIFEE@@@" "JBHIDDJJJBJDMDEBEBDDHBDAEDDLBBDFOFEBD@KACAONBBC@MAADJAEBJHJJJEDJAAEEMBDEEFKHEDDHJEB@IBDABDIEJBFJGJBBNEAE@DBCB@@I@DDFHJABDBHJABDBHKAA@DH@BFBA@EDECJBBOBKBBMDIBDABDHBEBHIAE@NKEEABEMEDDBIEBJJHJJEDBIDDEHFBBCOLFDFHABECGKABBAIAEDAB@IABEBEAEIBJBJJIADHJBH@@" "EMFJIIBBDJJI@JJDJDJIEDIEDIIEDLJKNOJDHMDFDGOFIDHM@DFIEDJFJJJJEIJDJFA@BDKOFMFGNKKB@HHIBFIDDIBDADH@HBHJEHJJKBIDDIEBBIA@A@JHIDBADHJHD@DDJBEDIADJFJJHMBHJ@H@IDABDIADKBDHHHBFNKOCEKGNIB@DCBIBLMBJJJKBIEDKA@EHIDKGOACAEHIBOKNJIIEDLIEDIEDJIBIBJHDJJIBBDLJKEM@@@" "DBIEBEDLIEBBODJJIAABBIBDIBBHIA@FOMHIEABHICJNBEGAFIHJJKEEEE@JHFMADHJEDID@HIEJJJDMKEBBHHFBJBDIDEBKEDE@MFIEDHDAAB@DDBBCDBBBBAEDBBBBAFBBAA@BDDA@IEDKEHEAEFJEADIBBJC@HJBEFMIBJJMDHHADIEBHIDEK@JHEEEEFJJHLKDGEBCJNDHJDEDHMOK@DDHJBDIBDJBDDDJJIGJBEDIIEBEDJA@@@" "IEEDFJIBEDJI@CEDDJJDLDDIBDJJDJBGOKFBHJEBDNOMDJHF@JGEEDLIEDEDGIBFAEBJIDKOCBJEEEKKDIDMEK@DDHIBBHDHAABJN@CEBBHJB@E@HHDDIEDHLJEBIHIEDIA@HHE@BBHJBEF@CJJDD@I@JBDHIA@FMEIDIFNMEEBJFGNIDJJEDCBDOAEAEDIIEEGBHC@JIEOKIBEBHJCFOOBBIBJIBDIAAIBJIAEF@DJIEBDJKAEEDH@@" "JJJIHJDDHBDJEDIBJFBIA@IBDIABIBDNMGJLBADEIGJNADEHMDHDDJABBJIEHDMHJJJDJCD@DDIBJJDFJKEBJEJIABBHDDICFCDBLMDEDJA@EBHEE@HJ@@BAA@HHDDB@@BHHEE@JE@DBIEAEIJAFCFDIA@JBDDJMBJEFJKABJJDIA@AFBIBJJHMI@MDJJBDBIA@IEHMADCJODMADBAJOEKIBDJDDIBDHDDJCBJDIEBIB@IABHLJJJH@@" "JEIDFJIIGMIEJJJDIAEDJKBEEBFDBDJCONNAHNE@CNMNJIJBAABIJEEEMHKJFKBBI@BIBLIMIABEFECHEDIECGEBMDJEIACDHLAGEBMJI@JJHDBH@EBABJHJDEEEABHJJDBE@@JA@JJHDJMJEGDAHIFDDMBIEJEGFEDIE@NECEBDDMLIJDJ@DJBFKBNHMMEEBLJDDBBLJKMKN@ECHLCKONBIBACBEEBFJIEDDIBJJMDMODLJKADMBH@@" "DJFIHJFDHBBJEBEJBFBAA@DI@DIBDI@JNMKKGEMEEOKKBB@HJFEBDHIBBCBBHHEEBJLDDAJBBKDJDMDEEABADJBEKCDJBJDACAEBMDCEBED@AADAE@DDD@B@JJJJJHB@AAA@EDADD@AEBEFAEJEDFDABJBIFFMBBIDBDEEAEIBIFJBBLAAAJJEE@HJBFBBDHIBECBHHBBFNOMEEMGFNMKJHDIBDI@DI@DDBCBBMBEBJB@ICBHLKBI@@@" "AIIDKDIEEEEELJJ@LHHJJEAJFIBDMBECKJOFNOEKCNMNEDKEDIBECCBDIDEIEBFHI@AAIFBIDDBDKABJBFHIBJLJBDKEFJMCDJ@CNBHHDH@JJBHJ@E@IAE@J@@E@@BHEDDHE@BHJBJH@I@HJCN@BIFEJKEFIBBIJJDHKBBJDFIBAADJCDLD@DHKBEDMADIBFFEBDIEFIECMKNFMGKKGJNNEBEIBDKBLEBJHHIHBJIMEEEEDIFIDLL@@@" "FFFA@EEBBDJJADIECECDBHF@IBDI@DHEGOJOMOONGEKLIADJIBJHDDEEFJJFKDMBJDJJEAEBIIIADJEHLHDCDAA@DIDDIFJMIEDGKIBEIBI@@EA@E@BBH@B@IA@DDHB@@JB@E@DE@@DJDMBDNOAEDMJKDIADI@DDAFA@IHMBIDDLLJEDEBJIBJEIFKBJKEEAA@JJDJIDDINMGCOOMOJOOE@I@DIBDHC@JAFEFEDIDBJIBBEE@DCCC@@@" "IEINJIBLHK@JJIBIDBDADCHLJDIFFIBINIEMONOOOOMMBJIEBJJEJJJJIEEIDICEDIIAAFDEBBBFIBJKABIHAEDDIBIABIECGJIOEJEJBDJEDHBDHDHHBJDIBFJKBDIBJ@HI@IB@IEBIBBMBMGLJOFEDJDDJDIAED@LJDFJJDKBBBEACDDDLIEFDIDMEDJJJJMBJJEDJJEMOOOOKOMMDKLJDKCDIBIHNADABADJDJJHFHIJDJKLMDH@@" "FJFADKEABDGDEBNBIDIJEDBAHIBHHBDCENMOKOOMOGCJEEDJEAEDBEECFJIECBDJKBBBJ@ILDHHICEEDDJBBJJIACDBBDJBIDBJKOFJDIA@DAABIBIBBH@AADHE@IDD@@JBDJDJDDA@DDIBKGNJJADJBIBBAFDDJJJBBIAEEFDHHIALHBJBBFJIBFEDJKFEEBAEDEBIEEBNGGMOONOMKMFAB@HJDHLBAEBLIDJCJEAGABDEFIDCBK@@@" "HEHJIDJDEBHJJE@JKBBAIBJJCBEEBJIMKNKKONOKNNOLJDKDJJBIDHJDIEFJLLKADEFNBKBAIJKFDBBJJAEDJIBDDADNI@MBIE@OKOKKKDJHJBD@DDDHBEDBAE@EDBAEB@IAA@ABBHJIFNNONOHEDJEHDKIDAABDJIEDBJJBACFJLLBFJCKEADFIIJKEDIBHIDJBJIFIBIOKKNOKONNKNMLJJEEBFBJJDLBBFJHEBJHJEABIDJHM@H@@" "JJEEBKBJHJE@JJEEDDJLBJDDLDKBEDBKKKLOOMOGOOOMDJHKDEEEEBICBDMECAIEBIA@LHDJB@HAIMDDDNDIDBDIIDI@BE@ECBEOJJMEBKEC@EAFIAABDHADJDEABID@IBDDDKDE@FEFJEEJJOMBFE@EB@DIDLIBADICIAAELL@HBBI@IHDDJEDLFEEIBFDJEEEEAFHJIEOOOOGMOOINNNJAEBFIAIABJAJIAEEBJHEBHJJFJEEBJH@@" "EBJKFDEABEJEEFJJIEEBJDIIAEDDLIEOEGGOGGGOMOOEBIEDBHJBJLJEFIJJLFCDEBFEACBIEGBNBBJII@IBBLIBBEBEJJFJDDJOCEBJNHJLMNJ@ADDDIBJI@IHLHDJJDIAAD@BKMIJHKJJEFGJIABKBJMBEBBDIJBDHDLJJBCJGEDJFDECBEAFCAJJLKEBIJJBHJAEDJEGOMOOGGGOGEGMDIIAEDDLIBJEEDJJKEEBMBDEACFJJE@@@" "JEED@JHJEBDJJIEEBIADIBBBJHJIABGONKMKNOOOOONJDEAEIBJJEEDJHKFECHJIJDHJJLEBDHE@MEABBEBIEBJEDHDJBDHHIBANIBLIABICCAEMJBIBJHABEDBAEBD@JJDJBMMDFFDJDDIJDKLBDHHIBBI@IEBJEDJEBBDEEHE@IBEAJJHIBLJHNECFHJIEEBJJDMDEABKOOOOOKNMNKOOBDDJHJJBBDIDDJEEDJJIBEBHJHAEEBH@@" "IBJIFEGBHMIFJFJJEBFADEDJBE@JJHMKLOJCKOJGJMMHIJEBBEEDHJKEEJHJDCEBDIBDBBJEEBHEBJFDJJFBDI@DICIDHIBKBHJMFEABFDFDHFJBEMBE@BDDIAEDDIAB@EBEMBBK@ICACBDECEJHJFJDHIDNDI@DIBCBJICBJE@JEEBJBABDIBEFABHJMEFJHIEEBBEBLHMMJOBONNBOINMHJJHEBBIEADCBEBJKBKDMHJGECDJJDH@@" "FEEBHJHFCBBIDIDJJJIKALEDLIGBDKKOIGMOOOFOKOKEBBIEEBJIEDLJJJOEJLEDICEIJMEDIECJLHHIDDHMADEABDBICBE@FBAM@NFDHI@JBH@HDBDJJHIJJJHJJJLHJJIBA@H@JBHDHICCHELBC@EBFDJABDEADEHIADHHIJNEDIEEJLMFDIEAJMGJJJIIEDJJEEDJBEFONOKGOOMODONNIBGDIIEALFLJJJIDIDJBFC@JHJEEC@@@" "HJJJEEBJLDJEEFKEAEFDFA@IABHDI@OGOONEGKENDCOHIECEEEFEEEIEEJHJEAJMFDBFBBDIBBDECBKBIICAFCJDDJJBDDHJHLJNEDHJEBJ@EEEEIEEDDBKEBHB@JEFJAAEEDMEEE@BJEBHIECJIHJHIABBJIABNCDFDLJFJFEABBDIBBCBACEJLEBHJMEDMEECEEEFEDHONACMFOECOOOGHDI@JDDHDCACEDEFKEEBIAJJEEBJJHH@@" "EEEDIBEDAKDJIEDJGBII@JEBEEBJJGONLOMMOGMEOOOEBEDBJJIBBBFJJEGENFAI@IIADJIEEDKEDDHEBBDEAD@BJBDLJICBBAEJJJEAJDHDH@@@BHHAAB@MMBMJEMHBDD@HJ@@@@I@IBLEBJJMDBBFDJIIBBJ@ADEABBE@IAEFIEEDJIDDLHDLCCMGEBJKBBBDJJJAEBEGOOMEOGMMOIKOOBJJEEBEBHDLJGBIEDJIFLAEBDIEEE@@@" "JJJJJDJJJDEEFJCEHEDBMDJEEBEEBKJOOFJALOFKCMKJDJBLHEDLMMMDDHHI@HKFGBBJJIBJJJHJJMCDEEBJDABL@LIAIBDHHJIL@EDJ@IBIBJDJHBBJDDKBBEBEBBFIABJB@JIBJDJDHBIE@ALJHHIBDLDIHAJDABJEEAFEJJHJJJJDJJJBGCFHHDHHIAEMMIIE@IJBIBNMNFKGILBKGOJNJEEBEEBIEJAE@MFBKEEABJJIBJJJJH@@" "EBJEDIDIEBLJIEDJEEBJABDLHDJBDNONNOMGMNONOKGLEHMACEAABBJJICCBOEELHEEEABEDIBBJICDAJIEEAFDAEABDBDJBBBOOONIAEBHBD@I@BHH@JH@DIBEBDI@@JH@HJ@DHAB@JEDDKOOOJBBBIBABDEDACDEEDJLAFDJJBDIEBDEEE@IMEGJFFDJJJBDDEFDEHMAOFOKOKMOEOKKOKIBBI@IIBDBJEEBIEDJIJEDIDIEBJE@@@" "JKDHIEAFBMAEFIELIAEDJDIABIDLJEOKOADENMKKCFOELC@JHJNJDIBADDLJJJKACBBBJEEEJDMEBDJJDBBHJHIFBJDJIAEDHDNMMGJFADCDHJBJHABM@AJIDDJIADJL@EJD@JJBHIFADCBOEMKI@IEDDJIBJCDHJHJBABJIBEEIBMEEBJBBFDFJJJIIADBDIBKJHJHFAMGKFFNMKMADGNOMBIIDJDDIBIEDDIMDKEDEJCDEDHIFJH@@" "DDEEBJFHMBNJJJJIBEEADIDJEFAAEONOGNJOMOFNMNNNADEBBDADIJDNAKEEFJJNDLLMFHJJEI@IDJIEAFIGBBB@HAAEBFBIBJMNBOLHDHHBA@H@BJH@EBBBABHJDBBBE@@JJ@@HDB@HI@IOJCMJJDJCBEDD@HBBBGDKDEDJIDHDMBJHKEIIICJJKEEFLCIBLIDABBEADCKKMKKGMOJKOGKOMDDCEBIDIDEEBDJJJJKJEHKBJEEAA@@@" "JKEBJBIEBEAEFEEBDJHJIBEBJ@JFCGOKMJEJOOMOBNKMDJJJMJKEFEE@JDIBMEEHJAABHKEEDBKEBIB@JHJ@DLHJBJJHDHDJDHOKIKIBIABHJFBJJ@BJHDHHJDEABHHI@JJ@BJJCBHJDDJDNLNOHIBI@I@JJJBHII@BHJHBDJEFJAEEFHJDDBHMEEJDIBHEECEFJMJJJIENKJGMOOJMBMNOOFCBHBJEBDJHJIBEECEDEBEDJBJEFJH@@" "EDJHDLFHEJJJHHJJKBBBBDHJDMBHNOOOKOKGNMNNGCMOJEDHBEDKEHDEDJBIBEEEAJJEE@KEAEDBEBDKBEAJIABBJBBBIBI@JBOFBADJBJDA@HH@@JHBBIEEBJHJJEEDJB@JH@@HHDABJBIDBCGJBHDJDJBBBJBDDJLEBFIBEBAEDEFHEEBJLEEEBDJBIEA@MFIEB@IEBOMNGCKMKOFONOOOKHJEIBHIBBBBFJJHHJJJM@KAI@JIE@@@" "JJJBICACJEEBKEEB@FMLLIBDIAFEAOKGENNLOKKMMOCODJJKHJKDDEELIJMBJJJJFBEJJKFFJJBJJEA@DJDBBDEDDLLLJEBMIDNGDKJDHHIJJEBKF@BHJAABDAGDABDDBHJ@CFJEBJLHHIBNIGCIDMJEBIIIIAEABBABI@DEBJJBJKCFJJMBCBJJJJEJLIMEAAFJHNJJIGNGMMNNOIKKMGFOLECDDIBDIIMK@BEEFJEEBNDFDJBJJH@@" "JEDMBLFDEJJMEEEDKIBAABDIBEEJOOONKEEGNOGKCGMMIEEDGEDKJJJCBDBEDBDJIHJEADIEEDLEEEFFI@IDLJHBIAAAHJE@BAONEEEBBEB@@HD@@EDB@DJDIDEADIBI@BAE@@A@H@BEBBEEECOLB@EBHLDDDJ@JIIDHDKCEEEAIEEDIDEBHLJIBAEBABFBJJNIEGAEEDMMOFFOGKOEEFKOOOJMEBDIBDDBDNIEEEEJJMACAJEIEBH@@" "DIEBJBIBJEBBJIDKDBDJJDIBDJOKCFOMOMDEFINJLJIOBDIAHKKDABEDMJLJBNIHDCEBFBFMAAABJA@HJFBIAHBHJJJDBI@EDJME@IHEDHDJJEBJJH@HJIABBEJMBBDDJHH@JJJEBJI@IE@LHEEJIE@DJABJJHJ@LDJCBHHDBJDDDEKBCBEFA@LKJBIJMIEBDAFNHLDIBGLJIJKLKEAEOMOKFFOJIBDIBJIBAFIDJJBEBJDJBJEDI@@@" "KBJJBIBJEEEMBEEEAEABDIBDIENNOOMOGGKJHMEMJEMOLKEECDFIDLHMAEADM@BGCDBDHHJHFJJE@JEBHHIBJBHC@IDMHDJJIAKJJMCDEJI@@HH@@AEA@BBDHHE@HIBB@DED@@@HH@DJMAFEJJNLDJJI@MIDHF@JBJDHHJEBHEBJK@JHHIBAFGB@EIDEDEHIIDKAFEEFIOMMBMMEHJNOGGMOOKKMDIBDIBDEDEEEBEMEEBJDJBJJFH@@" "DFIDLFDHJEDBJKDJFJFDIBDIBOOOOOOHONNMFKJMECKEEHJIDKJBJAEBJDJI@EEHLJMEEGDDIBDJFBMEBEBEBHKDEBA@CABDBDOEHKLBHACEEBJEJB@BBHJICCBFFDJHJB@BBMBJEEFD@JANHMGIBABDF@DBEAFHJEBEBEEJCBIBDIAGEEEJIHME@DJIBJEDBJBNIDJHMEFNEEJNKEKKOHOOOOOOJDIBDICBKBIFJJAEBHICAIDKA@@@" "EADKAHIBJMBJJEIDI@HIBDIBEGMNOOMKOMEKMJKJIODOLBIBKBEFIDJLEJEDJJDFK@BEBHJIJDIE@J@@DHDHHB@A@DJEDFDIEAMDBIADEDD@@DHH@HEDEABBDDEAABBDEAE@H@HI@@AAEADDJAELEDICAEBI@D@B@HI@I@@BHEDIBLJHJEB@FKABJIEBMAJIDKEBFJDJAOIGLJNJMNMEONMOOKMOEBDIBDHHDIDMBJJEJJDHLFIDE@@@" "JFJHFEBIDDMBIJJJJKEBDIBDIOKONMKNMAEFJGNFJJOOMEJBDEB@JKEBJBJCEDIAENLLMEDJABJCEEEFIEBKEDMBFIBIBHIBDEFIEBJAHAABEABBIBHA@BDLIABDDIIB@D@JDJBDEBDD@LBJEDKEABDHJDJDKBEIEFJEDKEEEFBJDBIEEIIKMDDIEFBJBJEFJHBEABBMEOOJJKCOBKEDEKNMKONOLIBDIBEFJJJJLJEIADJEC@JKBH@@" "DIBBHJDDJIBEBBJEA@IDIBDIGOOOOOOGOLHMNLMIDMNKKBDMADNJI@JHIDKLBABJMECCBDAADIDMDBI@BBD@@I@DHBJDDBJDIANJDEHJCBFEHD@HB@@JBHAABFHKBDD@JBH@B@HA@MCBFBHMABKLDIBJAABJ@I@DH@ABB@DJAEIDIDDABFFEEJJDBANIDHJHDJKIDEIBFNKMIDMIKMHIOOGOOOOOODIBDIDHDEBJBEBDJIABHJBDI@@@" "EJEIBDJI@JDJJIBJFFJABDIEKMKMGOMEMJCBMKOFMCGFLEEBGAEEBEOEDABADLIEAHLDIIJFKDIBAIBJLLJKEBEDJM@IIDHIBJMDIAEBHDIDE@BBHIE@EBJJEABDEBJJE@EDHJB@EADI@JEDDIEJJDHIDLHEJIEBEFJIIJJDLBDIFKBLLIAHLEDIIDBDAEGMBEEDGBEEAKGFEKGNMJFBMMEOOENMNMDIBDBKCBJDJJIBHDJIBDMBM@@@" "JBHDDIABEDIADEDHIHHJDMJJGOFOOFOKKDHDKDNHJIOGMJLLHEEBJKJMEJDNKABBFEBJBB@HDABDLBJ@AAADDHHI@@FBEEBJDANHJEHDEBDA@AEDBB@E@HBHHDEA@HJ@HE@BBAED@DABEA@MBHKLABJEEBC@@DHHIADDD@BJAIBDA@HBBBJECBBDFKIBMEJNJJEE@IIJMOGLJHKIFI@IFNOKGOKGOBJMIBHHLHIEADDIEBDDIA@JBH@@" "NLJJIBJDHIDEAIBBDBC@KKEOOMCOOOOENICJOOMEGGNMJECCEEFIAGEJHEI@DFDJIJEDLIEEIJHIAE@KJNJAABBDJIAEB@D@JIMAHIJIDIABJJBHHHI@CEEEDJJJIEEEF@DHHHJBJJDDIDJLHLELJHA@BEDDJIBBDDBKJNHEDDHJLMEDIIEBLJICA@DM@JMGDDKEEFFEBMKOGEEOOJNDKMGOOONEOOMFNHFBABBDLEADHIBJDJJIKH@@" "@AAHBFDICBCDJBEDIDHEEGOONJOMOONKMBEDKOJ@KJIKJJDDEBKBJJJGCJEFJHIED@JAAFIDBBEBDBKDB@BJFDHIABDDHJHIHEJKBC@BIBFD@@KMABBBELBJAAEDDBJAMBBBDENH@ACBDJ@FBFJM@LHJHIABDDHICBJ@BAFJABEBBADKDDBHAEDHJKEBNGBJJJFJEAABJNLJNHBONIEBENKOOMOJKOOOEE@IDIEBBIFBFDICB@LD@@@@" "NJJBLIEBDJLAEDJIBEKJGOOOGOCONMOKNDIEJOMECGNOLDKMIFJEENIDLE@JICBEBM@JDICAEIBDIIDIHMDBHICBDDIACDIJFIOBDMJJBDHEEBCJBDHHKIEBDFBCABEDNHHIBBNBEE@IBBJMIBGLKBLIFDDIABFDHJAEHLIDLIBDMDFDIBHEJEBFDJHEAIDKMEBKDMNIAOKOFEEOJMDICNOMKONGOGOOOBNMBDJIEDAJIBEDIJBJKH@@" "JDAEADHDJBAEBEJJDHBGMOONOONOMOMOKIBDEFFJEMLKIADFFAFJJMEFKIEEBDDJEBEDKBDE@BHIBBJJEBEDBFDDIBBFDABA@BJDIAH@HIEH@DJLLIABFL@DJHMHJI@AKBDDIIJI@@MDHH@LDIBJ@DBDACBBDIACBAEBEBJJBDHJ@EABFIEBEBIABEEDNKEEJJKDCCADDNIMMBKCEABDNOMOMOKOOKOOMOB@IBJMBEDBBI@IDEDABH@@" "DMJJFIBJDLJJJJE@IEOOGKNMOOIOKOKIFBDIFKONJKIOBFIHHNIECJJIEDIEDJIDJDJB@DIIGDEBEEEABDHIE@IBBIDHIDDLJILIBEDJBJBBM@CKIFFJKIFI@BBB@DKDNJKCDNN@EJBBJBIEBDILJIIADHIDJBDHEDHIBDEEEBEAGDLI@BBIBIDJIEDIEDJJNEDKHHLKBGLNJKONKDIBCDNONOLOOMKNOGOMDHEBJJJIIBJDKBJMI@@@" "MBBE@BEDIBIDEIJEBKENOOMOOKGMOLGNMLKJLFBNHONKDIBEE@FJGCEGJJEDI@JBIA@IFIBEHIJDHKBDDICBDJBDJDABBAJB@KKFEIIDI@HH@BINFIMEGM@JDIEDIBHEOEELKCLJ@@HHDIDLMCFNHBBLBBDABIBBIBFDIABFHIBLHMBDKDHDDJBHDIEBJOEFGBK@EEBDIFKOHKJCAJNIMKOAOMOFOOMOOKMFJEBLMADJDIEB@EBBEH@@" "JMDJEEDAEEBBLBBIGJOMOGKOKGOKOMOJKJILJJOMOCHOIJEIDJMEFDEEGMDEEFIEEFGDABKKBBAAC@MIIBDDMBDI@IDEEF@HMANEKOJABEEABDGHIJBKGJEDIBEBDIEBOFJBLHOABDEEBDBONMCLEHHCEEADHDIBEIABDLMHFDDBBFNJDAGCEEDKEEAEOEEACEEJIDMBLOHNGMOJJILJNJOMONOOFONOGMOJODJBAJBEEDAEEBIEJH@@" "DJIJJDIJJDDIAHIBAGKKNNOGGOGGGKEDO@CIBE@ONOJKBBEBIBBJEKMIEDIIA@JDI@HADDDDIDJFDKBBBDIA@DIBEBAHB@MB@OIEGIDJDJIDDJNOOEEDFGJBBDHIBBBOCAEEGOKJIADJIBIDOEDOHBEHB@LBEBDI@DDIBBBFICBIDIAAAD@HDIBHDDLIEDMNMBJBDJEBBFJOKOHEBDN@GIEFOGGGOGGKKNNODBDHLDIABJLIBJLJI@@@" "KEBDJKBBEEEEFCBDKNOOKONOOOMMONOOJOEEEBMKOCHJLLJIBJMFKJJONMBDJJAABOOJJIBJKABHIDLIDIBJDIBDIDJEDJBGOKB@EGI@I@BAALKBOFKMHNLMDJJJIEIKHMNKGJFILDB@DHDOE@BFOOBBIEBIDIBDIBJDIDIIDHJDFJJDJJOOJDDBJIBEKOJJNKEJJDJIIJHNGNMJEEEGJOOKOMMOOOKONOOKNIBFCEEEEBBFJIBEFH@@" "DJEEBDDIMDIBIDDIGEOOOOKOGFOONMNNOHDKCMDEJOBEIAEBEEFLCGGBEM@I@DLEDIJGHKEJHJDKBAABEBH@IJDIDIABA@HJKFEGINNEBELJBINELJOOGOB@BBHJB@BGOGOJIMCLJBIMBECKLOECFJHHDBDDIDIBLH@JEBDDBFIBHJMFHOBLIEAI@DHEMBGGFAKEEBEDDMBGJMAENFI@OKKMKOOKGGNOOOOMGDIADJDIELIABEEBI@@@" "KBJIDIABBEBEEBIFNOOMKFOFOOKOGOGOFNIEMHKAGODMLJJDHIJAG@HOKJGJKIBJOOBNG@BECBI@DOEE@ECBB@IBABFHLDJCDHJ@FMKIDHAAEMHDKMKFMELMIEBEDMIMEKFMNI@MMDD@IDNMK@BHIFBIAHKBDBDHBBFE@EEGI@DJFEB@GCJGOJJDNJOBNOHHGDBLHIBJIMIGODFHMMDKKGOGOGNOOKGKFMOOKKDJEEBEBBDDIDJJFH@@" "DEDJEBFJLJJLJEFKMOOKOOEEJOGNOCONMIBCINDLOFIABIDICBEOBOKDFNHFDBIMG@EANEFJDDBJK@JBFLDBLJBDJDHBAA@JIEAFHKOFABNF@MJIDAFMJOEADFECADEGJMKDADJMHCCJDCGNHKDEDJHDDB@IBIBBIJAAKBBHFJJAABKECLE@GELJAC@KKAFOJGMBFDIDJDDKGIICLNBDMKONGKOGJMEGONOOMNKEBIJJIJKBEBIEA@@@" "MJCAHDIEADJCIDKOOOKGKMKKOJMMNOFKOFEGCIIMNMBKLBABDMB@OJFKMMEHIDGKLJMFAM@IBIDE@GHNHAADA@DIBIBLJBECBJFHEDFMDE@HKLHBAJABEFJJIA@DDJJKEBDBLB@INHHEAEKAE@KBJFEBBIJDJDI@DADD@KHO@EADJDHELCEJINOADHMEMNKBOHBEIBDBANJEKMLLNGECGNKGKMMJONNMNOFOOONIDNBIDEDI@LFBMH@@" "BEDJBIBEFKELFKFNOMOOFGNJIEGKGNONJDJEEEBBNJLBNLJEBJLKDMLLKFBCBJJGKBA@NHGEEDIDJKEFBJFAJJIBDBB@HHHJLOIMGAGOJDEDAOMEJADEKFGCNJGBKNGCFMADBMEOLAEABOODGELOIJHHHHBBABDJJLCBJCEFJIDIEEG@KHDBFOBJJFBCFIIMIFIJJEBIKJAJKJBEEEBIBKOKOFOEDJKOCGOMOKKFKAMFKEBDJBIEB@@@" "MBKEDKEJDEEEIMOONOOOMJKOOEMOOMMKOMDKKMLKKKIEEABJEBCDKKGCJNHLJAGODDJEABHBBEDIENNODHHJADJDI@DEABBCAGCJMJONMKJIKBJFIDEBJEAEJDHIBMDEBJEADKBJFLJNMKOJMJNGDFBBDEA@DIBIDBHHIGKKMDIEBB@JDEBIAGODBIHKJNGFNIFBEBJDEEDNNNIMNNIEONMMOOMMGONJMOOOKOOMLMEEABMFIEFJEH@@" "DEBJI@JACEBJFKOMONKFGGOOLKGGNOKOJBOEAIIDEFNINJDBKELJNEDJGMEAAFIKBIBLJJBLLHABKKMNECBDJAABBE@HJDDJDNJLKDBKKEGFELHEJCHGEFFMLIBDIMKCEG@NBM@IMCGEFNJAFIJKIBIABHHEBBDDBIBFECMNNJD@IIJBJIJDJFLKDDEEOBIECJIMFJABKLKKEADLLEGJBONOKOGFIOOOGCFKOMONKBJEFDBHDJJEA@@@" "IEEBJJHJLDEDIOFONOJMMMGNKGNNKMOMFMMKGKCENANEFJJLDJBJMJCBHNBJFEOELJJACEFBBEJKOEKMKDDI@LDEDHJKAAACIDIJG@DDECDMMBACLKJNJM@OMEEEEOHEJKJNINDBEMIFEAA@GBLIDNDDDFJHIEAAHDIAFMNMGNJMBBCEFDBJIMGMCBJCHJFBMJJBIAJJKECLCMFFOFMMKEOMNKKOFKOEMMJOKOKGLIEAAJHJJJEEDH@@" "JJJJDDKBBIBAGGOOMNOOOONONOMENKOKJJKEABJODKDJOBEABJMDOENMGIIDIGJMAIDJJJHHIDAEMODKFIBDEAIHCBA@DDFBDAB@JJJMHLIBBHJFJFECKFGCJHB@JNGCFNECBKBHJBDIHMJJJHBDABCAA@DBF@LLEABDKFIGMMDADHHJJJIDLEJODIDLOEKMGIEJJDEBGJIFIGJJDEFJJNONKMEOKOKOOOOKMOOOGDBDJBFIABJJJH@@" "MDJJIEDDIEDNNOOOOKJMENKMONJOMONMDJNOOMONMHOMMLJFEI@IJJEENNDIJNOKOBADIGECJEBOKFKBMJHIBJCGDDJFI@HKHMDJDHANOKLMDI@HHIJGHDNEMCMNEMCI@OBLHHHDIEINOKL@IBIEHNHHDKBIAGFBJDHJMJFKFOJEBNEGDIDBGNOKJLICKMEBJLHDMCBIMMOHMKOMOOKJIEKOMOJKOMNKMEJNOOOOKKIEDIAEDJJIEH@@" "AEBJJIAEJAAAOOKOONOIKEFOJOOOOGOKKKKKIKKILCADGKEMKFMBKEJJLIBJBOMGJLJIFEJLBHEONJHGCFBBHIBLEADHJEBCAABBIBDMMNMNJBEEEB@KGIFKJDBABNKDOFHBEEEBBKMKMMIBDJBDDFBEBHIDEAJDHJBCFG@JKOM@JAJMCDJIJOEOJBJDIJJMFJEKFMMFOADFALNNLNNNNNOOGOOOJOKEFLOKOONOOLDDBMDDJJJED@@@" "NBMFIBEBAFFEFOGOIKOFFKEKGLJKMNKODEFGGEKOODGOKDJBFLAEEFFMKNLIDJAKKEBBHKDADEIMILJHEHDJBAENHJAEA@DFJJDHBDKJKEJJNHHA@DJDJBEDFMEEKAEBBIBI@D@HKJJMFJNIB@IBJKA@DEDBHKMDBBI@M@JILMLMADAFHJBEFNLBIDIKNMKCEEDAKBBIFOOAGONMGGCEAGNKMNJIOFMFKCGNLOOGKECCDBEBDKEJCH@@" "AJBIBEBDLHHJOOOOGOMOKDNJOOAEKENGAJENKGFKDNKNOMMLIIMECMKJN@IDIOOGDHEFE@MJIDCKKKKFKFMDMFCEB@F@DBIBIFIBDJDOFGEOMBADEA@KDLOEGBJJGEGIIFHDEADBEOMGCGIBIBDKDJDJA@C@BEFCEIEKFKFNNNNADJMHECE@IGGOLIDHCJNMNEELLIMMOKNKIFKGFKMBLGCMFMDGOJKIFOMOOGOOOJHHIIBEBDJBL@@@" "NEMCEJDIABEENNJNMFKEFKEOMDOKEOKNFEJJNIOJOIEMNKKJJCKLKGGEKKBIBLEMMEJ@JGBBCAEGNEFIOGMKABINDJHJMDDEBIFDIAABIDNJEDJA@DBFOA@KDM@EIFHDGKBA@DBIEBKIDJDDDICDJEAAEJHJICLJDFMOGLKECOEDFBBGBHBMEMMAJDJFNMGGFINNBJNNKMMDOJOLKJJMCCNOMFOIEOMFKEFKEKJKKMEBDDIBMFEMCH@@" "DJAFEBIBIDICOOOMJMOEDJOGKMHOOCNNJJEEMGMC@GKGNNJAAGOOBONMGFEBEMIG@JDJ@INIDJJNMKEOKNJIOOGNI@J@@AACDD@IDDFHBI@HJA@JJIDIBDCFIJEBLKFABDIDJJHDBHHDJ@KAADHAAFDD@@BHDKOGOLJKNOMFMKJJIDKLHBIBHGDMMBECGEKOJGOODDBKKOFO@FEOEMEBJKKNGOHMNOGJIEGMJMOOONDIDJDJECDBI@@@" "IENMJMFMGEDOKOOOOKJOOFHOGEGBNNKMFJJOJEINOLJONIMNKNKJMMKMN@JEDJKLKJMBNFIFEBIMKBEMGFOOKEEFJK@JJJDGEIEFJIHKBBMDHDE@@BAFNJDCNNJKKNABKKDB@@EA@IEJBFHLJKEDMGABJJHFJKEEFOOKGEMBFMLJECDKCJEJNINJIEBHCMNMMJNKNKMLKOJIOKLMBOJJKENKKJGEGGHKGOJNOOOONOIEGEKEJMKMDH@@" "KEEJCBIEICKOOMGOJFFIJHKKNINOOKNLDJEEDKJIOKMOMOKKCKOKIAGKEMADIGOJHEFMA@EDJICEBEJJJMBIFKNMNHE@@@JJ@BDADBB@DB@ABJHBIDJKKDIFEDHIECDIFNJIDJ@JJD@BA@BBADAB@BJH@@E@KMKNKDJEJJJMBEFDJIE@DEKE@JOODIDEMFODDNONNFNOMOMNOLJNIEEBIAKNOOKLKNNHJLKCBOOEOONNDMDJFBMEFH@@" "DJIADEJIFLDOGOMMOMIGOGNOIBE@NOGMFDHKIGGOOEEOFIFOFNIELFKDOAFIBMIHGJMEDNJIEFIONKDDICDNIDDJNJHBME@CGDIFBMDIANJDD@EDAEBDLJBDNMEEKIBBIIBEDAE@AABKLDIEJCDIGF@EEJ@JKJIADKIFDIAFKOLKEDJKIEEJO@LMJDKDGIFKAMDKKGKDKGMEGOOGDNHICEOGKHEBDOKOGODMOMMOOGIAKDJMADDJI@@@" "KEFJIEEBIGKNOJNKEKGEDIFJNBOOMKNNDJBJFNKIONOMIFIAEOKMJHFIAEBBDKGKLJMBKAEDM@BKJIBIBHBAEAKMMNCD@@DK@JB@J@ABD@@IAE@ABHEKO@HIDJHJIDHHGNM@JD@EDDH@ABD@BHBBHFI@@AFCMMNLEDB@JDJDJNJ@EIEDFJEJINOFIBBEDDK@JMNOMDDKDMOKOLNKKBJBICKNMOOJCJKDIEGFMFKJOKNODJEEDJKEFH@@" "JJDIBJBJBIGMOOKNKDHJIGOOIEGBKOGHMBECIMGOMOMGDKLJKMNOEAENJDDHIBHJKEEGDDMAAEELNCIBDELLHJEDJLLADJABE@DJDJJECEEBJ@EDDDHBAEABEMBEMBDEDB@IAAE@BJEEFEBJIBI@EBDBIDAIJIEBHIIMABDNCIMEDDEIAGEEFJHJDHIABKMDEGKMNJINIGEOMOOELNEBEHOGNJGEDOOODJHIFKNOOMODJBJBJDIBJH@@" "IEEBE@IDMDNOOGEMFIGEEEFJEBFMNBMOFFHJEJOLJOOJIEAEDJMJKOKKEJMCBGOGJJNHMKFFFDKMBKDEACEACFJOEMMDA@DC@DIBIB@HH@BD@E@AAACJO@BHIFECDHJ@GJNDDD@E@AB@@HHBDJDI@FA@DAEMMGJKFDEFDEAFJENICCCFMHKJJOGOBFEJMFNONJMJIEDEDJOOJIOJMBHKCGMJCMKBEBKEEEGDKEMGGOKIEIDHEBEEDH@@" "JJJFJEBABBMOMOOEMGLJJKOMLDMCEKKDLJJEKGOGANMDJBFECEKKFJNFOGJDDMHNNKLCB@JHHIACLJBHJFOLJMOJMJK@JBAGEEJDBDFJBJHIDHEDDDDEJIDEBLHIJEADJMAAAAE@IDHJJBKABABMEGDBBHFJMJOMJIOKBHJBINDDHHJHBFANKKHMIABOGKCJKFNMFECBBIEKLGGOFMBJIIFNMFEIAMONJJIOEMGOMOMJBDBEBKBJJH@@" "EDDHHJEFIEKOKOJNIMKBJNOGJOBFJFINEFAJBOOOOOMA@LHLLJEFEGKOOJGKAFGEJMJHEEEBEDENJKIEAENJ@IEL@@MOADDB@G@JJJHABBDJABHAA@IBBBAHEJBBM@LBBBDHDD@JDBIBBD@JJJHG@BAADGMH@AMDHBKMDEDNJKMAEBEEE@JMJMGCDFOBOONOECEBIIHIHDEOOOOOJBLCECLKBKBGJOGKJJFMLKJONONMDKEBHHIAE@@@" "JKECCDJ@DEGOGOGKNKFENKHMDJMNMIGMNDDDKNOOOODJEAEABIDHJDJHJDJNNLHCECLJJMJDIBKICFDJJGMFFGNJJIJJL@IFIFENAMDJHHI@JDBJ@EBDLLDBEDMIEBAAIIBE@BJABHDHHJIELCMCDKDHAJJLJJKOCCEOBJICFDNJDIBMJJINEF@IKKJIBHJIBHIDJDEDEBIGOOOKNIAACMODMKMJIEHNKMCFKNOGOGOEA@BIFFEFJH@@" "EDJLDAIFIKOOOJNOMDJMEFKKMGBOKFONMFIEFONKJNJBHDHDIBAEDIIGOIDKHKGFJMMBE@LIJHIBMEJNJJKDMLKL@JAGEDBAAGALKDABBJBEDJH@E@HIBJIDHMBEHIDJJDHHE@@JIEBBJBDAFILGDDBAEGDBHANIMIFJJKJMEJDHJLIHEBEMJKGFHNIDOODLIEDBDI@I@JBKJNKOKEDKEKOKFOJGENNKEEJIEOKJOOONLKDLAAJIE@@@" "JKEBIJBABEGNJOMKJEECOMGFHFJKNMLMFNBMBNOOOHHJBKBJJJJJEOGLBFONONJOOKJDMKIBABCOCK@KGEOJGOEME@DDNHHFJDIEAMDGGIDKKHBJHGMGEDBIBNOKJDJAEGEO@JJ@NNIDOGAELEDIBK@HKIA@EEMGOBOMGFHFNGNBDBDNMIBNOOJKOKOKBAOGMBJJJJJFJBHHOOOKJEJCKEIMKNJK@KGEONEEBNMOJKOEBDBBLJEFJH@@" "EDBJJBIDDMOMOJKFLJDEEEFKNJJFIOKNMDHLGMOOJEBMMNMMKDJHKIJBJHHMOGMJIGJICFJDJEEMNOJONJMDOMJH@DHIMMDJ@IBJCDBLCDABOBHFAADEDMLFHKJNHKAMIEADDC@JGJDAFAJAFBJDHBIEMLHI@@JMOIEJKOJOKMMEBIBKFDJODJMOGMHHJJBLNHJIFMMKMMJEBOOMOAHIEKNOLKBJKNKEEEABIKFJOMOMIADJBJJAE@@@" "JKJEEDBEJKOKOOOEKDIEGNOMEFJMNMBOFMBJJOMGNHHJGECGFONENFDLIBGKFOFEBEFBJEDIDHKGMK@JE@KHMJGJJIABBMEBJB@DEBMBFIDGNHAEBBMCHJJHBLGAJ@JJHNEJBED@KOADKBEJEA@BBJEEJBDDJJOBMHNHEBHFMOFHIDIEBJCEBECGKFOBDIICCMCOKGFEGBHHKOEOJJJEKGJEKMJKEEOKOEDIFMGOONONJMBAEEBNJH@@" "A@BJHIEBAGGGGFNMDABJJKNGHIEBHKONKGEFGMONLBE@HEDHIJJOKHIBBBMDHJMBDHMMCO@JABAMEFABJEDECEDL@BDDIKNFADEDHDCDIB@IIEBFDELGIMGEFKONKEGELOAMACBEDLHBDIFA@IEADCCNLIAB@AIEFEAEBJDCEELBDBHGNEMHIBEJHIEJBBDHNOJJLHIE@HEBAKOMOCEGFKONHJEDHOCNJJJDAEKKGGGGDBEDHJJ@D@@@" "JFLBEBDLJNOONMOJCFIEEOMNKGCMGGEFOD@MCOOOODJKFJBJJEAADEDHLKMBBIBIACBKGFI@JDKJJKDEE@ABLJKIBDIABFMNNJHKBIEIFIEBBHDHHIECBDMMHNJKHMMIBFEDHHI@JBEDKDMDJFHJKKMKBDDIBDNJIJD@EEAFJJNIBHDKGFJFDDJDJBENIHIEADDEBJJBKFJIGOOONEHAGKEGGENGFKMOMEDKFBOMKOOKJIIBEBAKBH@@" "DIAEHIBAEEOFKKNMLDBBMCCFJJOFHJJMJOCFGMNMOCMFIEMAEDJFBIBEACJDHJJDDHIFNJBEBICEEFI@@BJHBJNLDJBDDIJLBJBLDJKFJB@EFA@BAADFHMOKFJOJKFOMHKADDB@DCE@BBKFJIAJBJAJLIABBIAKJJ@JJ@@DKEEFDJEBBKKDHIABJHIBNDEBDJCBIEDEMDKENGMKMOCFGJMJJHKGJJKFFEJBAAMKNNKGMEDBDHMDDI@@@" "IDDBBJEFCONONOMJBMDMBNNMLOFIOGEKGFDMCKEONDBEGJMNHEDHIDIDJKFIBJDIEBBDEDJIDBKOJKDIED@CEEAEEIDIADGNMEGFMJMEEEFHHJAEBBIIEDKGNMJMKOFIEDLJBEDBHHKEEEEJMKGEEKOADDIDMEDEEF@AEDIFJONJADJIEABBEDIBJDKFJIDIDHIE@KMJOEBACOMFNEICGFMGGLKGIMKKJEIEJBMOKOKONCEBJBAADH@@" "JBILJED@LOGNKMCDIKAAFJIGCHONJNNGKNKFGGOJMADHHBIEGMIEDABA@CMBE@IBHEDIEGDFKFCKEG@B@AGLJJNMNNKBN@MM@BHMEEIGBKECF@B@@DBB@MFMMDEAEMKEHBBA@@B@CFEFJGDMEEHJ@EMHCJFKKMKJJIOD@B@GEFNCFKAGEDIE@JDHEBEN@DBDAEDMOEDJ@HIDEJOOGCFKNOCKJKOHNGDJKDDFLIFENKOGIHAEBILJBH@@" "IEBA@JEECNOMMENMKGOGEEONNKMEGMIKGFIFJOEGOJBEBIDEMFKMKKLJKONLHEBFCBABHIIMNMOFLNIDID@BBEAOEMOGLKONKMBMFJJNOGDIJJLJBHLJKJDOFLJIKGIBNJIHJBIJJLIGGKJJKEJENKONIOGMMGLEBB@ADIDKIKGMKMLLHJDBFCBE@IKONJINNMNKEMADJEBBOOEGJKDKGFLMOEENKKOMEGGOFMKMEMOKNEEBHDBEDH@@" "JJEJECDJEKOGKOEHBM@DHKBMINKKNJBBOOBJCOOONHLIEBBKBIDKFOCGFKGIBJDHHHFDBCFKKGKOKCBABAGILJOJOKJICMMN@HEFNOKEDDJBN@CDDAAJJJKANKHNKLFJJJLDAAF@CJBIAEFOKKE@HCMMNDJNOJOJILODBDBFFONOFNKFBAC@HHIBJDOFKGFGKFIDJFJBEDIHKOOONBJGOJBBKNNKLMJFHI@EJ@MGNOGNMBIFEBMBJH@@" "IE@BIDJ@OONONJKEEFEKCFOKJONOGNMIJODFJNKOKIBBBDLHJKADIBLLDJMBEHIEBBHKDLMOOOGGFODJHD@BCMJKLOKONKGMBEBMABLIBK@IDJJHHJNDDL@EFLBAKE@AIACJHHJJIDHFJDIJDEJEBEOFKONOINJMNB@A@JIGKGGGOOMIIFHJBEDHMBEJIAIJDIDFJHIIBBBDNONKJKAGJLMKOGKOJNOKFFMCEEFJKOKOOHBIDJ@EDH@@" "BDFIBBDJ@OKJKMDKBHJJHMEOMMEJMMJKGNIECOOGFJIDHIAEEDMBBDACMJILHCBDEDDHAACFIDNNNKIEBHEBHACDIJJKGMOJDHENLICBL@DJM@@AA@AKODJIEFHKEDJIGNL@DD@@EJI@AJFDIKM@IBOMOFJJLIFD@JE@JEDNKKKIDKFDD@IAEABF@ILJMNDABBEIEEDDHIDJKGGONEDKOFJMMJMEMOMEHJJHJFIENJNOHBIBBDKAB@@@" "IJIBDIIDKONOOOKFMCEEEJOEGGOGGOO@FMJKIKOOOLEACBDABIBDMADEDABAEDDI@AIBFDEMOOKOOOGBL@LDCDDIBFIBEFJIAABAAFLMIECMFECJBBJD@MBBBMOMJBBEHABJBBNECENEDMIKDDBDDDJKEBDKBDIAFAAHAJGGOONOOMMACBDL@DIAEDBDAEADEIBDJDABFDEAOOONLNJMK@GOOGGOGEGJMEEFEKFOOOKONIDLIBDJLH@@" "BJDDIDBAGOGMFHJEJDEEIEMONLJMLJFMCGLKENNOFI@DDDIDIDHI@FAKIDMJHJIDBJBDHIIGKENNJNMEIAGAFIIBHH@DI@DFDBDNKMGEE@H@I@DDDDBIKJHDLOBGII@JNLJAAAA@DH@HEEGENKIBACA@DI@@HJDLKDGDDMEKJKKMFODLHIBBJADJHJMIDNLC@DHIDIDIAA@DKGKKMFIOFEKBIMJIKOMMDMEABMBHKEOGODBADIABJ@@@" "EABIJADJJNOMFODGBIJMJMCNMEFOEMMIFMNFKKONOEBIJIBEBAEBDHJCBE@BBDJAEDHIBBBJOMEMOKOODBNDAJBJ@BBIBDJH@HIEDBIMJJAEDBJJHIDBBLEAALMILDEAJBADHJJJAEDBJMLJAEDHH@JIBDJB@BJBLACJAGONOMMEOJJBBDHIEDBIBB@EBFBHIBEDBEBDJLJEGKONNKCMKDMMMGKEEKNEJMJLJGAGKEOKJJIDBLJDE@@@" "DLIB@JIAGONKMABJFBKCABOMKKMMKBCOBKGENJOKNLBB@JJHDJDDIB@JBHKDLIAFBAABHDHIBJJONNNMJHEAGHMECLD@@A@BEAFJHHJJNHJ@IDBBBJKLJK@DDMBEIA@FJINJJBBADHBHKJJHHJKDEB@D@@AANEEHODE@JMKKKOJJJDHI@JDDBCDDIIFHJBHBDIABI@JJHBBAKNOJKMGFJGNBFMMNNMOJDFFJCBJDENKOODDJHBDII@@@" "AADDIDBFONOMJNME@HDNNGKEFNKOFMEJEGNGKONOMEDDKDDDJEIIJDJCLEDEABD@LJKDEAECEGEACMMONBJDAEBJBJHEDOG@HCLDOJIEHJAEHAIEEEFCFLE@BNECJ@EAKFCEEEDL@MDBHMDJOIAN@HGGIE@JJBJEDABJCOMMNDEGEFEDEAFJIHABDEAEANBIBLLMBIAAFIAEEOKONOCOEBMEKGNKKEFOCKI@HEEKJMOKOKBADIADD@@@" "FEBIBIDHOMNJOOEFBCKBJLDJOIOEMBAEBBOMOLMMOL@IHIAA@HBB@A@IAAA@DDJJA@@BJF@H@IHJLKKMMD@HJHH@EL@HAJEBADKC@KLIGEJIBJB@@IMHEINGDLHIIGCLM@MLH@BBJDJMGDINHFFIDBEBL@HAM@@HJHHAEMNNIJHLH@HCBJ@@DBJIA@DDDDHD@BB@HDDDHLHAOMMIOMOJBEDBEMGLOJIAJJFNBCEGOJKMOHIDJDJEC@@@" "HJDJEBECMGNKONKHDDJONCKCJOKGKME@EEOCMIKONIABBBEEEBHIDJECDJFEBIAEEGNHDHBBIBEBAEFOGHIA@BABAIEADGGDDALDKMIBINOKD@KNJGOBJNJLEMBEMAJKJJGOBKNHAFOKLJDMNIALAAGGADEDLBDB@DDHOGKEDBEBDJB@I@KOEEDDJECBIFEBIDHJEEEBBBDDKONLMNGME@EENOFOJNFNCOJIA@NKONKOENEBEBIBHH@@" "EDIDHDJEGOONJMOJIIFILHFFCONLOH@BEKFNKOGMMJBDHJIBBECDIBHGEBHJHDJ@HMKNIBDHBDNDJ@IMMGBBEEFDEB@D@ME@HIEJEIJEEMMH@N@MMGCMLHNONJEBKOKHIMNGEMHCH@MMMEBLMBMDHHEEHA@BEACEEBBGEMLHBICIB@IBDKNMHHBI@JHJEG@JDIFEBBDJHIBBMMOGNKKFMB@@OIKONCC@ILKDLJOMJKOOOEBI@IDIE@@@" "BIBKBJIEONKEOJOMBCAOKEHNNOKKOGEDMEOJOLKOODDIEDJHHJDBBDCFLHEDBIDKCKFMBDIEDIBI@JBKONHEBMLHJHE@JIFEA@HEIBHJJMOMI@KMDJOCKONLFNHKKAKONNGJIENHDMOMJJHJDM@HDECDJHE@JHIMJE@KONJBHDJDIEDIBEKFNFIDJAE@IKFABBABHHJIEDIAGONIOJOMEIEGGNNOKKHMFOLFBEOJOMFKOMDJJFJDJ@@@" "DJEFFFDCOOOEDFKJMBOEMABKDMFEEODADKGCNIEFNHJE@IBEBDIDHIFIECAEDJA@FJMOHME@IJDNEBDELMBJMBKIDDHE@E@HDAEDDHBCAECJBE@JMOBMFEEOOFECGOMECEJGMJHEBBNEDFB@IAEDA@HE@E@IADNJEJJEIMABECIBLHEEHOMJK@DBIEDFEDKDHIDIBEBDHEBHKKEDKNGFIDAGMECEIFJDEMGJEJNKAEGOONACCCEBI@@@" "KEDLHHILNJKKMMJEJNJOOMFNJKMNOMJJIMMEGNKMOEIAEBJJDIBIEBEOFDEBKADEDOJNMBJOCDJIIDJLIMEMJDMGAADHDHEAAFJEJKENJJLEHKEEGBGKMOEFJMEEJKEGMNOBGEEFHMAJJKMFJMBKDDE@I@IDDGEIBMMELIJIDLJIFGJJEKJOIEADFJEACGMBEDJDIBJJEDDMGMNKOEEMLJJMOKMNJKKEOOJKJMBMMNNJKILHHIIEFH@@" "DBIBEEBCMOOOKJEKGIENKHIEGMFKMCDIBKGGNLJNKDBBBFEDIDEBBEKEMBIE@EBIGIGMKMMJJOEEBBBACBE@@I@LEEABIBHBDEEJJHKDJMCHAD@@DFKEGMBHDFJKA@JEOEFKA@@AD@NEJIFHJJMEAB@JDJDEEAHDH@EBFDBBBEEGJJMMNMODODJE@EDJEMFMBBEADIECBBBAFKJIKOGFJDIFENKEOEDHNKMDOFMBNOOOMNBEEBDJA@@@" "ADJJJBDMOOFKBKMBOEBMOBFJLJNFMJOFEENOOJCMNADDHHKBIBJDHH@KCECBFJDKJEEGNALOKMLIDHHJDDHJMBIGJJJDBDBDIIBFOCJKEBDCBAEBKEGEMNOFMNMKMKGKMMGEFJEDBFABEFJNGKBDLIBABABJJODJEJHIABHHIDIMNOILCOEEBNIBKBFEFFH@HIBJDJFHHIADCMNBOOKMECGJMKCJIJKBGMJEGJENJFKGOMIBBJJID@@@" "GEBDEDJKKNMOOOFMEDEKOLIKKCMOJAKLIGAJFLJOEJ@IEBDDBDHIECGNNJHDHIBAFMFMOKKKJJKFHBB@IBA@@DACGJMBHILMJBDHDDCEEMKLDDH@BKKFJHKMJKJNJMNHJKFNJ@@IAANMMEFAA@IBBMILHJEJOFDA@@DBDHBB@KFJJNNNOMKEKDBDHI@JKKOFEDHIBAABEDHBMGJIKBLGDINLBOMNFNLIONMAEEKGOOMKNNJIEABEG@@@" "HHHIHJDEOKGOKNMKJIIGGIGFEMKDFJGIBHFGOMDLJ@IBJEJMDJCB@DMCAAFIEBDKEDMGOBKOGMDMIDHBBDJBEABFOOMMKGCEA@IBIIDJHJFK@IBGJKKMEJEAGEOMGDEBMENNJOBDHFKBHJIDLJDHDEFGFMMOOKBDEBBIBB@IDMIEOGNJGOEIEFIBEDKDDFEI@BFBIEJMBJDHBIIEOOC@JDOBKAFMMCGDOGDLJNMKNOOFOMABHLHHHH@@" "KCDJE@IOONMOFKKJJJBEOFDKFCGOJ@JBEFLNNHAJMEBE@JAABIDDMBKNEJICBDIEEEJMNMOEMIEKCEFLIC@DLDEAKGKGFMMEMGDEFBCACLHHEJHHEGFJNMCLNJHJKINEKJKGE@HJM@HINDFBCEAGEMEMKGFOFLEAAI@FDIKEFFMDMMGMKMJMEEDIBFDJMCNJEIADJDDBHEBEEJL@KKIKEBBHBOOFCFICGMBBJJNNKGMKOOLHEBIFFH@@" "FDEIBKECOGKEEMOGE@IEFJJNMEOMEEEDJIIGMJJE@@DJEIDDDBAAJOFJJLFHDJBBJBEFMIJMMFDEHJIEEJOEJJHBFNMKOOCOKIIIEJLJDEKBIEEEAEEDIJEAMAOLELEBLIEEDEEEDJFMABIJMDLLNONGONMKKB@JJMGJMEDJHMACEMJLMKEBBJBBI@KAJJKGJLDBAAADMBI@@EBJMODLJIEEEEOMEKJJKEDHEGGMMEFOGNEFJDMAC@@@" "HJHBDDBONOEOGCBJMDEFOLIMJKGKN@@AEFDNFL@LIEA@JBJIIHJEJBMKIJMBIADM@LJKKMOKELIJONJKKMEBGFBDIMKFJINMKGFMOKKEID@EFMJBJJJKKJJJJE@EBJJJNNJJJJBMKE@ADMFNOMKGFMKLJKFMLIBCGBEENNJKOJLIMFOMNNJIHEIDDJEJLNMJBMBHLLJJBHDEDIHAKCICED@@CNOFJMLIOKEAEJJFGGMGKOJAAB@JHH@@" "EEBLJIDGMOKJLNMFJIIMFMBBMFNFMDJJBIIGMJJBB@DBDJABBAEHDLJGFDKEBJADJAKECEEEOEBBMCMFKDMFNMHIBCBKNOCEFEMOOGEEFJJJEMKDADMDBGKFJJEBJKFOBAEIDAFMMBJJKEEGGOMMCEFGKNJFBDHMKKEIFKENEJBEGMEEFEFLBIDBJEFICGBII@MDBBDBIBA@BBBJMODLJBJIEKCKEJBEKELLJKEKIJNOMOADJIJEE@@@" "EBFADJEOOMGGEJJMGBBBOJDMGEEMGA@AFFDFNH@HHJIDI@LBMGGGMKLIJICBD@JK@JBGGMIJJNDLIFEKFMJBDKBBEEOGEMNMIKMMOOOKMMDNOMDMEAABONOMONJKOMOKOJDDEEIEOKIEMNOOOMMNLMKMMGGMEBBFIBBMKFMCDIICJJLMOGBBHFJHABFDJLINMOGGEJAHDIDJHHH@KKACCD@DGEMEGEIBOJBBGEJJMGGEOOMBIDCBE@@@" "IDHJIBDKMONNNKJBLLIMOMAFNMKBHNDJJMIGMJHJB@AADIAEFNKFMJKGFJJEAEBFJEEDMJCBNJIBMJIFMIDJOLME@BJNNCCJOGEGNNOOGGIJJJKD@BFMAEBGEEEEEGBEDEKB@AFJJJLOGGOKKOEGGJNFCKJJ@EEIOJIDMKDJMJDJKJFBMIEEBKBEDEBJKGFJMKFKKEDDIDD@BBHJMODMJJICHJFMKKDEOMLIIJBNKKKOMNIBDJHIDH@@" "FEEEBDIGKOGMEMEEKEBCFHEJMBMNKNIAFKBFMDA@DLJDECDEJMOOKMFMOAGHJJFKAABKKFLNKGEMEEGGGEABJKAEGD@A@LNEIBJMMKMGFLOOCGNJJDIEOFMHJJHJJHMKGMDIBJKOFGOIKGENMMJJDMCIHD@AGEDFJJDEGGGEEEMGFKIKFNJDDFKBJHODGMKENOOMJMAFEABII@DAEKBFKDDKNKMJEJM@KFBEFMEEMEOGNODIBEEEC@@@" "@LIBEJCONINJKGJOFKEDMLIEOMJIBMJEEFEOJJJEAA@IIDBOEOEFOGKOFNMBBBINDEEEFMJIFHIBLIDMEENJJJOGEJEDKA@HDJDKGGGMMKEKMLMM@IEBCEDBEDBAEBAEFBEDHEMIMNMFMMOGGFIBI@HDFIEBMGGJJJKMEEIDIJDHKDJMKEEEACLJBBEKKGNOGKEGMGJADLHDDEBJJOMCEEBMJDJMOMDIMIEFKGJOFJKLKONBMBDIH@@@" "MABIB@JKEOOMMNKJMDBGKIBKECOFHKDBNINEJH@HDDEJDBMMKKFOMNOOMLKOLJGDIABJKNEDKGBMEKEKMK@JJMEJOFHA@DEEA@JEFJGKGEMFKGGAEBBMHGEDHJMJHIEG@MJBEDGGFKEMGFOBKEBHDEEA@D@KGJMEJJHFMNMFMEJGFIECNJJDDIGBIONIMOOKMOKFNMMJABMAA@H@JMCLKJAFHKGNEFJDNOBAEJNKMMOOMFJHBDJDEH@@" "BJHEDKBOOGMJKGNNIELLOJDDJGNDBBHMJO@OEBJAAFKACKJKGFJNKCCIGEOFKELI@BDIFEFAGDIEDIEBCFKBKGIEEMKJFKH@JOHJBDJFJJFIGNNEBJMBGENACEJMFDCMGBEJJECKODKBJKBIBBHOJH@NKBNMMEDOFJFKFBEDIEDIGDCECDIB@DIMFKGMGDNFFKJKGFJNNDFKDDBJEGHGJMHJBACOBIABOIIMDKKOFJMOGOJFIE@JJ@@@" "LDJJADEONMGFJMEMNJAIFLHJJKMJHDANEIEKLH@JJJCONOIGMMKMMKNMLMFOMCEJEDIGMNJJ@KEEEEJONKDDMEEJKGEEMNGJMFKHEBDHJKIMIEFOEEEGJNLDNKONKIAKJOEEEGKEDMLNJHIBE@NKEJOCMMEGFJMEEIAFKOJMEEEFHBJKMODIEBMFEOKEIMKNMMNMMODOKONBJJH@INMDMCLA@JMNJJHIKDLBKMMEJKGEKOMADBJIAH@@" "ABDHJHJOOOJLJJKEEMFOOJDIEOJEBHJAGB@BJBJ@BGNKKFKGGNJKGGBMFOGFKKF@HBEDKFJ@GJJMDMFJJLKBICEEJMGGGEMFKMGFJLIEDMFICGMIFBJMGEHIMFOKELHMGEJJCDMOFDKEIEDIJKGENKEMGGGEJMEFDJFIJJKEIEJJO@BKFIEB@HCFNKGGKEJGGFJKOGFKFNKOB@BJBJ@BGDBHJEBOMDIBOOKEMEFJJIJOOOJHJHIBD@@@" "KDICBAEMKEGKMEJJIBEMGEABMFIEDA@NMLEGLH@JEFEOFMJJJMKFDMKEMKJFJKFK@KMONNOJHJDIBIDJJKNKGFIKEKDMFKEEEGFMGKF@ACEFJJCKLNMBNMECKMOMNNEEKJEKINNBJKEFD@CFOEKGEEEFKEIFMFLKGFKNJJIDJDIBHJOKKOMNHFKFJKBNMMFMICFMJJJMKGMCEBH@IOEAMKHDAEDKEJDEGEMBDJJMENOEFMMDBFDIFH@@" "JAJDDJBOOOEEGEEOGGHKFJDGBMOE@JEEI@HIJBI@JMOBJGMGOKIKOJJMGGFNOMMDKGKJOKE@EENNJNJKMEONMEFJKEGJMNOMKEEJIEMIDHIIGFOGKEEGHMHFNOHOKK@MHOEEFOGKGDLHIDMMDJMEFMOKMJOEFJKEEKOMENJKJKKME@EFOJNOFIEMOKKGGEJJONLNOOEOBJGMJHDJBLHHDMEBHEGMJGABKFHOGGMEGEEGOOJBIABLBH@@" "DNDJIDJMOEGGMJNJEEGEMNIFMKFJOD@BNMKCDHJFKBJOOFMJJNMGBMIFNNNADKNK@EGDMEIEAKAEE@JJBNJFIFICFJIEKEMEFKFKGGGBBBBDAEDOHABHGI@KKNGCNNHDO@JD@OIEDABBBBGGGFKFKEEMFMDJKFDKDKBKJBJHEEDFLEDMEIGE@FKNIDCKKKDMJGEKJJMKGOJJFKBHIFFMKJ@AGJKFMKDKMMGEEBKJMOGEGMJIDJICI@@@" "I@IDB@EKMOJMCEMEMCDJGEBIKFMEJHDMLHEEMAEJNKKIEEMGKEJJJMBEKKHOOLLBMCGIGGFHD@DDJGEEOEOOOMNMEJNHKEGOEFJJLHLNLHDHJJMEGDMGJOIJOMJMOJLOJOEIGEEJJHI@IKIHIJJKEGOEFHKJMEKMOOOMGMEGBIA@A@KGGDOFEJAIOOHNNMBEJJJMFOEMEDNNKJMDEME@IMI@JMEKFLJEGBIFEMEMFEJOMNM@BADHDH@@" "BFBADJJOKMFKOOHJKNIEMODOEMOJOJMBIMFKFCMFGBEOKGKJMMEMKDMLNJOEBONKHFFJOEJAAEIBIDDEBOOFACEOOGKONOOLJMJKEKKDICIA@GEKMKBIFIBGGGGGGGBDKDJFMNMG@DDNDIFNMFJMJIOOKONOGOMFDCGOJEAADJDMDDBMGJKC@NKOJEGJKIMIFMMEMJNOFOMBGCENCFKELJEJOJOMMGIGMMDKNJHOONKENOJJIDBCB@@@" "DHMDA@AOGCOMCJLKEEJBOMIBGOGJA@COL@@AMDEMMKG@KCFMIELEIMICKGHNOLLCEBODFOFJB@DELKMBMKLMNNJ@DJFIKJMGFKFMEEFKMEGDBIMEGLMFNJHMNNMKKMHJKKEIOEELJAGEENKEEEKFKGEJNLKBI@BKKMINMJENIMA@BBKGKAGJEFAIOKHOFNDMLMAMDMKFFHGFMMMAEL@@AON@DBOGOBDMOJBMEFIJNEONGGL@DAEHI@@@" "IE@JJDKNOONKNMJDKNBKJKBMOJGDJEDMIEENNGMFFIEMIFNKGMFJKDELFMGIEKOFHGE@OJI@DMEBADBEBOKKKJOOKJMEEDKNKJJDJJKFKFLMDBCCKKIE@MAFMOBGMKDEHEDNNNFBAEIKFKFJJIBJNKNIEEEJNOOJNNNOJEBADBEEI@DJOHEG@KGNMDOEKAMAFJKEOFKKDMMDKCEOCKMEDMIEBIGBOMJFJNJCNIBMKNKOOKNIBJHEDH@@" "DBE@@IAKOGEOKKEEFEMEGJMCEGO@@HAKLHBKOJJMEKFJMKJJLJNMEFMCMGEFOFNCFNOIGOGGJ@DEFKKHOEOGFKJJNMJKGCNNONMEBKFMLEKM@EDNMGGEOI@MKNECNMHDOMGGEKIE@ENMAMKFJEEKOKKNGFJMKJJNKGGMGHNNKEA@BOGGODOKKFCKGKEGENEKEEKJIJJNMJKFMEJJONJ@INL@H@GOEFEJOEEMCEEFNOMGGNLDH@EBA@@@" "ALJENBEGKNKJFFMEEMBJMGGNMNJJJADKIBEBLGDKDIEEIBKNIDJFEJHLCDNKFKFJMMKJNFJMEMJH@EBKEGJFLJEEKKGMJNMMEBHIJLONKJNMDHAIKMLBAGEJJLHIJJMGDBAMNLL@IEKJNKOIJLHJEEMKJMOFNMEBIKBOEFJE@@JMMEJKCJNMMJKFKFKIFAHJMCBIDKNJDMEDIFIGAJEBDNIDBJJKMKOGEJJEMEEKCBNKNOEBCMBIL@@@" "DAHJJHKOFKGMMMJKMCECKJOCKEOAHDAJLENEKBNMGEFOEMMDNMODMEFKGGIJNNMCCGG@OOEJJJKKOMMJJMONKGJKKEEEFKMOKOOCCKKOMFJNKIDCJKNMFLIEGMBEOEDIKEKNJNADNKJKEONNNFGONOMNKEEEFNJOFKOMJJMMONNJJJMGOHGGFFEKKJLOGFKEEIGMKIEMMGKEGEKJFMCMAJLA@LGMFNGJNNEFENJMMMOFKGNHJJHLA@@@" "KJEEEMGNNNGKJJKNJLKFNGNJFOIFJIDKJ@AEBELKDIJBMCFKEBBKEJJEEDNGFIGEINMMNJOEEKEFDCEGMCJJJMGEFEBKDJKDMEEGGEGFNHNIFCAEGOMBHMAEMLGAMMDEHJEOOEDFCDKHKKGEGGEEEIFJIFJECEGEJJJNEOEFACEFMEGJKMMKLMGDKGCIEEBJMFJBEFKFEJBLIFIMBED@BNIDJKDOKBKOCKFIJKNJJNOCKKOEMEEBNH@@" "MGLOJEEKOMMGGKJNKCBMIMMOMNOAONHJHDDCCJKEFJKOEOEFEEGBLKFMFKENMFMACOCHGOJOEFJOKNMECFNOJIEGEMMMCGMOJFMJNOOMIKKFMLD@IJLIGJCGGJJJOGFBODIJLHAAMKFNLMOOKJMKBOMOFEMMMGEDJOKKFEEKNOJKEGJOO@NGNDEKEKMFKEKFIJGEECEGMGNJKEFJNFAA@JHKOLGKMOMMLMJFFKJNOGEMONMEBOIOEH@@" "KEACEIOONMGNJMGEJDMBGKKGGEHOMEEMDHIDNAFFIDJEDIBJGBOJJJEEEJJECMKKJMOBOGGKOOOJNKJJFKKKEGMEEBJFNJMECJJKMKMOGEBAOI@JBOI@EDJMEDOIEEJIE@DOJBHDOLBEGGMNMNJJNEEJKKBJEEEOEFNNKBJNKJOOONOGGJGMJNNMNEBJMEEBJJOJGBJDIEBIDKCDCIDHIEMEEOHMGGFNOBEIBMGEJKOEKOOLMFDEFH@@" "JBLJJFKFMOKMOKMMCJJOKGNLNOC@JOHJIAFOAEEDKEEKENGGMGCGFLJKJKGKOFKIHFOLNJJJDKEOKLIELJKGEEEMGEEMIOKOFONNJKGNJJOMKOEAEFOCKMAFFMHMKCDENNGKEDEGNMOJJKOFJKKOKGNOLMMEGEMEEGFJIMDINOMFIBJJKIOK@LNKGNOFJNJIKGFGEOGCMFMEFIEEDGKDDJHOJHFGKIKOFOJJNEMNOMNOMKFKBJIJBH@@" "FNAEJHOOOOGGKBKEEEMBFOJKMMFEEEEIDJMNNIJKDDJKFAJCCBFHNICDBJMFJMCEBNMBEFJMJJOBOGOGGOJOEGGENOOGGKJOENEKONMEEEADGFLNBMKDKHENIEOMDKM@NIFMJCIKGADEEEEKONMCMGJNOGGOKMGGEGJOOGGOGJGJJMJKEBEKJEFEJKEJJAFDKHKBFFBLCFJIAFJLKKMJIDMEEECEMNJOKBEMEEFJFOGGOOOHJMDCK@@@" "IAMDJIOOGKFMFOFJNOJOMOEJMJJMDEECADGMADIBMJEEJMEJLNEFJJMBJOKEKJMLMDKLOEJFKEKEJMJLMEOMFJMOEKKLIFAADIFJBIONMDNKOMJKMNNIGMALGEEEGALEODKKMNJMONKIEKOLJBKDIDDCDINNMGMJKEOMEIJMJMFMFKBMGINIEIMJNMFOJJEJJKECIJMEJMEBMJDIDEOADFEEAEJJMJMGMOJOKJKGKEKFOGOLJIELDH@@" "FJBBJCKEOEMOJIMOKKGJCMJGKGEABHBLCJKGFICJBHEKCEKCKBGDNFJGKEFKEMEIJNOHKJIDMCBEFKEKFKJKKOKEODFID@JDACDHMGMMKEAOEKONKEGIOGKM@MOMHENOGLOEFKONMGLEFMMOEHIFDABHADKAGMFONNJNKFMFKEBFEIDJNHOKJLMEMFKEFOBKCIGBFNFMFFM@JBNDKGFJNAJ@JDEGFOBMNBOFNOMLJOMMGMFNBJBBK@@@" "EEMDMEOONOGMGOGFNJFFOOANNMNODEKADDCMJNLILJLJNFIDHKJCEDIJBMFJMFMOILMBNOEKEFMHMMFNMOKONJNJJBHJAE@BJDEKEMA@@@CEOGEGMNFKFJIJEGJOEBLJKFKCMOEGGMF@@@DEMFMABJ@EDBHJBJKJKONOMKKEMHMKEFMGKJEILOMKEJKEJBLIEFBNHIDKCJIJILIKJMNAADFMAGKMKKLGOKCBKKGGOEOGKOOMEIEME@@@" "JIBAACOMJMKJJEOOKKMMGEDDKGMEMDEJAEEGBJADCDCDJLMIJJBJFKFMMEIMLMGDJIGHKAFJBIFMCFJKGENJ@@@@BHB@D@EDIJMFIDJBIDJIEMONKKMJOOKFJLMIJKFOOJMNNKOMMDJIDJBIDKEJLIE@A@B@J@@@@BKMGFJKFEKDJBKDFHODJIGEIMLMEMKFKBJBJLMIJIFAFADBJGEEDBMAEMEOFIAEGEMNNOOMBJNMJMONDDBDJH@@" "KFJJFGKMNOGEIOKMOOKENOAKNMEKGNKDDDBLMFDIFMDKECEDMKCBNDDKCJECMMHOINOBOGNMNFMJMJJNOK@@JJJJHBHJME@KGEGA@A@DBABJJIBEEFJKNJNMECJNEEKJKNJKEEBDJJJDBA@D@DGEGFHEEJHJ@JJJJH@FOKJJMJMKCMKOGJGKLOHMMNEBNFIACJFFMIEFEFIEKDICEIJAAAFKOFMEKNLGKMFOOMNOLMGGKMNOCBJKFH@@" "IEEDIGGEKMJGFIFKECGKGNCFJKKGEMFAAMEFJFKDMJADMJJIHIJKBFFJLFMLJKGFFHODJODIBMIFBKOKJDEB@@@@B@BA@JIDJJ@DEDBHHDEL@BJI@HEDKOIKNH@@KNLONIE@HDJJ@AMA@HJAEA@BJIDJHDB@B@@@@BEABNONJCDMJDIGJIGHKCGFJIMKAJKCBFJLHLJJMIDBMIFKBKEELDCEMGFNJKFCOFOFEFKDKGBMNMGGDIEEDH@@" "JJEEDNNOOGGJKGKDJJNNOMJMFLNHGJNJEDBMIEAOBFKFICFNNOCBFJMEILKGFNJMEFNAOJKFMHKEGMOFHHHDJJJBHJHJBHBEL@DH@ADAAEEAED@BBBHAEEGBEOOOMBGEED@JBB@AEDEEDDAD@@I@AMB@JBHJHJBJJI@HHKGMOEFHMKFJOLCKEEJKKGFILMEJKBFGKKKFDKFKBGLEDMJAEBKJO@KIKEJMOKKJJIFOFJOGGOKKIEEBJH@@" "EFIDIGOKMFJOMFFEEBKMKKABMKEJLGL@KMCJEIKHNDIEKEBHHIEIEBBGBKDLJJMGFLOLIKMEECJFHKFHEBA@@@@H@@B@EBHIBHHAED@EFJDD@AEDDDBJAHHDJNJKJI@HLBJAAAED@AABKE@AED@HJDHJE@B@@@H@@@DBE@KFHKBNEEENLIOIKGEJJIIFJGBBEDMDHHJEFMDICHNLMBNENHAOAJMFMJDFNMNJEECCEOJKENOODIDKE@@@" "JKEGEOOGGMOEKLHH@ELOONJJKJND@KIEE@EFJKACIKDJDKFFMEICCGKDMFOJGFJMKEOAGEGJJNEKKOME@@DAEBJBKJHDJDA@EEEJ@AEJHFHH@B@@HHH@JBBIFMGEKDJBBH@HHH@B@@HK@JMD@BMEE@DABI@JNJBJEDA@@EEONNMCJJOEGDGMFMJKGBOKEIFOFFDMEKCFIBIFLNDFJKE@EEDNHACJNJJKOOIM@@HINMGMOGGOMGEFJH@@" "JNJHHMNNOKEOECBBECGJMGEEOGIIEBNBOLKNDLIMCEEGGDJLJEEJJABKEIBEEGGGBMNLMFLIEIFJMJD@DJI@@D@JJEBI@IBE@A@@JMDMFHABJHIEAAAB@JKGMKONMOFJHBDDDEDHJJD@KEIEJH@D@EBDHDJEBJHA@@DJI@ABMJKDMDIKEIKMJGGGEEBDMFJDBJMEBIJIGGEEFELIICNIOJCJEDLOGMEGEJOFEBBFEGMFOKKMHHJKJH@@" "BEIGCKMONOOOJMHHHJHMONJGDNNBHGHMMAEHJIE@KBFIBMKFLNJIKKEBMGMNGFIMKLMIKMOGGGEOOEAEA@BBJHMGE@@BBBEAGEDJBJKB@AED@@B@BBBDEGONGGJOGCOOEABBB@B@@AED@BFJJBIEGDEBBB@@EGEHJJB@DEDEGOMGGGGMNLMINMLKGCMOEJEFNLJKIKFMJDKBFHEDJHMDEMHO@JCKIGBKOMHJHHHMJOOOKOMNNGDMB@@@" "MKFJJOOMOOKNOHBKEEGKKMMIMMKEDMMBKDOOCFIMLKJOEBMDEELKAEIKEICCJIGCEIKDGCFLIEKOJJD@DEDD@ABH@BJHDD@D@EAAEK@MEB@@EBHIDDDKONKEMDOIEMFKONIAADHJE@@BEEHFMDDE@A@AA@JJ@@JD@AAEA@ABJONMDIKFGAFLMFGDJNFDMFLMDFIMEAEJEGJNIMLKFGOIFJEMIEFMMLMMNNOEEFJ@OKNOOMOOJJKFMH@@" "EBLJMONOMNOEICBFJIMGOCKGEKDGMCIGNJEMEEFBIIFDJLMKNFELMICBJJLJKOJNOJOINNMJOEFM@BIEA@@HIBECFD@BHHJ@JJDDBDE@@DJH@@BB@HMNAGJJBKMNJBJODCMHHBB@@@JI@@EABAABJHBHHJ@ACFEBDHH@DEDJ@EKEGJMKKLOJOKJONJIJJJFDMIMCCNMIJICDLJCEEEMBKODNEOAFMGFNGOELJKBFDMGKMOKOMJIJE@@@" "KMMEKOKKOMNOFFNLIFKNOOENNNK@HGFMN@KIIFHLJMAFLENJBDLMIJLMELIEKBKCJHODMIFNDKONEDB@BEEABDBD@HJHAA@E@@IEMJHBBH@@@IDHOONEKOFHHDJI@HKGNMCOOHIDH@@@JB@JMMDH@E@DD@JHHABABDEEB@BAECONICKDMIGHJNFJFMDIMEIJLMIIBBKMAKDEJIHKDLNHCMKG@HFKKKMGOKNKDIKKCGKMONNONMEMNH@@" "FKKODONOOKEL@MECFIFIJGOHINNEBLMKEJAFAJFIEBNKMOEGFKEHEIIJJBMIEMLNNNMIKFKJKFJHHBHJH@@BDINJJB@BJ@@@FJBJBHCDH@JHJBEGNHAMBKGMJKONJMOFJEL@KOEBBHJH@IF@JBJBK@@@BJ@BBJKLIB@@@JHJ@HJKFJNKFLMKKKIMMDMJBJLLM@MFKGEGMNKJEDKBLCDBMFMIJECKLHOOBLKDKFEEHAMFOOKOIGNNK@@@" "EEB@KOGKMOOJNANHAFEFOMEKGNI@DGOOJDELNMJJFDICNDOJJBJFMJJIJLHFMGGEGHOEGMJOFOME@HA@AEEEAD@@@HED@BIEA@H@HBH@BI@A@HKNMGNJFJML@@OH@AMJKBKOEKNHHD@DJ@@J@H@HDEDJ@AE@H@@ADEEED@D@HEEOKGJMOEGHOEGGEK@IJLJJMKBJBJOICNDICBJMKIMABOOOA@DKOFMEOKECD@KLCJOOMNOGNHBEE@@@" "BDDJBOOOGOKEJKAIDKJEEOOEIIOEAJMKFHIGAICDMEDKFKHECCCDHMFMCGFMFMHFMBMHMDKJMJM@EBJJJ@@@DIDJJ@HADD@@DBBKA@BE@@BJBFNIKMEAMGGAFOHOKDGGELEENLKKBBJ@@EB@DFJBA@@AAD@HBJIDI@@@BJJJE@EJMJNIEHMJEK@MKEKGFEKEHIFFFE@NKFIEEIFDLGDHKFMJLEGLLMGOMEBNIDLFJMFOOGOOJBIAB@@@" "DHJ@IFOGMOEOFDOBAEFMGKFMGFM@BGOGEECJNEJCBFEJIFMOJEFFEDLJMDDBEOCKKLOAKKEOOBHE@D@@@GFMBDA@@EAD@H@EADJD@EDHAAD@EOMFEGNJKMFNI@OHDKKENJKOECEOM@ADD@IE@ABIDE@@HADE@@DABEKG@@@A@E@JGOMFNLGINNNGMBAAEJIIECCEBOMKDJMCBFBMCJNEEGGOB@EKGEKFOEKEDBGICGMGMOGKDHBHI@@@" "IABJBONOGNGEMKEFJCLJOGOJKEKEKNMMFBJJBNIJJEFEMBJIKIIDJMGEIKFKFBNFGJMEGMFFJDE@EADJI@@JM@DEDHB@J@H@JAEEA@@ADBBMKEOMLJOEEGEABEHMBDEGEEGJIMOMFMJBAD@@DEEDBH@HBHB@IEA@EJH@DJIDE@EABKCEOEEJOCCJCFKFLMGEJIDLNLJJEMCEBJLKJBJJCEMKNMFMFJOOGJINBKEFMMGCOGKOJBJDDH@@" "BFD@EOOOOMEJNNKKDIAEDKNIGFJCAEOOIEOMEDMECFDLIMFOACCCBJEFKFEBJOJKKDO@OEKMAA@DHDA@@BD@JHI@ABEE@E@J@D@HBBJJADJKGOOOOEOJKNOEDMOMIEGKNJOMGOOOOFJIDBJJB@HA@BHE@EEBD@DHJHAB@@DA@I@DDENMGHGIFNJOJJECFKEBJFFFDGKELIICFEEIEEOMDOOMDFBKGDKNIEDDIFNKKJMEOOOOM@ACB@@@" "DHIDIJONEKJKMANFJBGEJOKGDEFGDONAFBIIBIDJJJNKEBJDMDMFCFJEEKBEECGEFMJIMNKDGFEEEADDIDIM@A@B@@H@DH@@JKEBDD@@D@ONOEKFIODFKEFJIM@ELJKEFKAGLKFMGKOHA@@AABEFJH@@I@@H@B@D@ELIDIADEEECGAFKMLJMKEGFEEBFMEBKFCEIEIBJEFKJJJIDJDLJCDCOIGCEAGFOJMGBBKCLENJNMCOJLIDHI@@@" "IBBAEGMOOEEDJGKLHBLCGGNHGKLDAKOOAEKEECFIEEAFJMJMIIIIDJCKMJKAIGMKEHOAKLN@LA@HHDBIB@FJEDADBJBIAB@IED@D@IEBHKGEJKNMOJNMKNOABJMJJDGKNMKJOMKNJMGFHJEDHA@AEDHBDDJBJADAEBK@BDJA@HHDAHCINLGHMFMODLFJMNNBIDLLLMJMJKDEEDKFEEFMDGONLAANO@KOGFAJ@INOBIEEGOMOEDBBDH@@" "BEDJAGONMNIODMNIBLADHOKJLOHIDGFJD@AHIEDFJIFDFDKCFJJBKKGCFKBIBIMEJNMKGKEEABEBBHH@@KMDH@JAD@HBD@DCJIE@HB@DABNMENLONKKBKFJJDOJOIBJKFJFNKOIKMEKJDA@B@HEDJNA@AB@HADBH@IENH@@HJBEBDEEFOFMKJMELJDJFKFGFNJBJKFFICACDJKAEDHL@ABKGADHOIJNOHIDAJDKMIGLKMKOODBIEB@@@" "A@A@JNOMGFKJKGKNHADIGOGDCMBB@OMMHECMDABIEEIIBJMJHLJMHJJJEEKBMKIMGHO@MEF@DD@DDABEEFJMEE@D@JBH@EABEF@EBHE@JOOJKEOKEOJECFOMKMOMNMOKFEBOMFOMFJOOJHE@JE@CEBDE@@JBHA@EEEJKEEBDAA@AA@CEEHGHOELNMJFMEBJJHMJIHJMJJDLMEDJDAENE@MMOHBBENAGGODID@KNOFJNKGEOKJHD@D@@@" "LEBEAIMOLMCFNMGAANAJAFNJJKDHAOGMDHDJEEICFJMBMEFCDHDHBMACJGDLIEFMLMNICOHI@ADI@JHH@EA@@@BIB@HBJH@BL@JH@BHA@MMGNODOOJKMFMDNDKJNICIEKENJOOIGKOEMHD@J@@JHAJ@@JJ@HBDJ@@@DE@@HJHDID@DHONDKMIMKEDIIGBNDEJ@I@IFCEEJEJKFDMEBI@IEOGL@IFJJKKDBLCLDGEKKFEIOMLLEBEAH@@" "@HDIDKOHKBFNKOMLCDDFJOOHCLJ@NELJAECLH@EFIEIDAJDMJGFMLKEICFIJNJLKGIMAOJB@ADADB@BAEBKDJJHBDBBH@AEECD@ABHBJEKJKENMOKKMEEKMMKMOMNMMNMEENNOMKMFJNMBJ@JD@AFEED@@JBAB@JJIFJEDB@BADAD@BBOLELOFIJKJLKFDMFIMKGBMIBLADMDKE@@INEDBIMCHBIN@OOJKAAFAMONKKBFHONIDI@H@@@" "EBKDAGGONNKMOJMADMMA@JOEGOJFJOKMOHNKEJIIKGBIKCGKDLBJIEAEJMBLDMFNNMKEGODIBBJEDIDD@FDE@@BH@DHAEB@@D@IBDBH@KOJNOMHOGFJKGFMFEOOOMCEKGFJKGGHMOKJONH@JABDHA@@BED@I@@J@@EAC@AADIEBJBDIGOEFMKKKEIAJEJMDEDJJAIFOFFLJGFLLJMFKHOMNOJKBOOEGJHDEMIDEJOMNKKOOGDAFJE@@@" "DD@AEOOMKMNKEOMJA@JFKGMDE@HMFKENBEGMKENDJJDBHLJDICDLLFJJKCDHJEEEGHOANJABDDDHIB@HJDKMEB@@JIAD@@JJIEB@@HBDJOMIHKEJJINMEOLOOGHOGOIOMEKLJJMFHLMOJIB@H@BEDJJH@ADDJH@BEENIBHHBDHIAABDBKLGHOEEEBHIFFJJKAIIFDIBIHJABJICMFMOEBCMFKEHHEAEOFKBHDBMOMFKMNMOOMD@AA@@@" "JIDJ@GGCNNIOOFJ@HEF@DOGIGOBLDENMDIMDBGEOBMHHJEEJLJCBDMDMEFEGCFGFLILBMHD@AAAE@DIB@JB@@DJB@@BABJ@@J@@BJ@@AKOGGGNIGGNNJKMEMAOGGLEMENJKKOGDKOGGGNL@@BJ@@BH@BJDB@@BBI@@BBHBDI@EDDD@A@MJALIKGCFGECEEIEIBFBIJMEBHHMJGMGBAELIEKMAAJGODOGI@CE@HBKGOLKKNGG@BIDJH@@" "BBA@ENONOMFKLMEDAALECGMDEEDJIOCJACKIDHJJGEEBDJJBIBJFKCADMJNDBEEEKIKCKBHJDDD@EAB@K@DJJA@DJBDDD@EEABED@AECGJMNKOEMMKOEGELGONHKOOAMGEGNMMMGNKMJOFED@AEBDEE@AAABBI@DBJI@FHBDE@AAABHJFNFLNMEEBACJMIDFFKBJDJBJIBEEGBJHIDNNDBNGLJIEEAEOFEALDAEEINKEOKOKM@DBB@@@" "LHJJHKNENMICKJMAJD@JNFOJGMHHBJNNJBJL@BDFKGDHLJJJFECIFFNIIEBKCJJJJINBO@A@HACE@D@J@DID@DBH@DHIA@H@DDHADJ@FOGKJOJIFKENJMNJMKOOONMJKMJKMFKDJOJNOGK@BID@IA@@HDDHI@@JA@ADI@BHA@EFD@HD@GJCLJJJJNFJEDLKKCDNECBJJIHIGFKAB@AJJBKKJJ@HMOBOKCJHABLEJNNDMKMCNHJJHIH@@" "ACD@AOOGMOBEMOBD@@I@EKODJKAAAOAJ@IAJIDIEDDKACAEBIBIBHJHFFKKBDCCKGJLKNHJBBNHBE@J@EA@ADHHABJA@DEA@J@BJA@JKNMOGOGENNNMBCDLKGEJMGFIIFBEKKKMGGOGMKNJHDBJ@BHDEA@DBJD@HID@DE@BHEB@KJBBHKNIJOFNFABFNKC@JHJDJDJEDFDFIAEDIDJLDHBLGLDDFJIGNM@DH@ABGMMBGMOGOL@AFD@@@" "DDAEECNOOFLMKMMAMEBGJKNMGLJBCJGEB@E@BAB@BJDOFDJDKEEEECFEDMFEILMDMINDNADDD@CMHEAE@DBHAABJD@DEA@BG@JH@DB@GECEOLOIKKEOKOOEEFOOOKEEGONOMFNLOIOMFEG@BA@@JHGB@DEA@ABJDD@JA@EDE@MN@AAADCICLMIEILMCEIECFEEEEFIBICGIBJ@BDB@E@BEGBNBBIOEKNJOBEELEMNMIKGOKNEEDAA@@@" "BJJ@@MKMFOKCEKBBD@@IEJMNBKDDFOAJEJKJHHDDHHJEKKDJJBJIAHLJFKIIDEJJKDMCLH@JIEDBADD@EJMADB@@ABI@BAD@J@BI@@BMMDB@ENMGFNILKDLCDKJNIFAIFILKKGEKM@BAEMJ@@DJ@BHADB@DJD@@BADEJM@AADBAEDJH@INEIFJJMADLNKBIHLDJJBJIFNMBHHIA@HJNJMBLGKAAFJCMJMDH@ABBFMFFOKENMH@BJJ@@@" "DH@IEGNJMONMOODEOBJFMEOLKLI@INGEG@E@BBJIAB@JEFM@EKELJJMCEFMBILIDNINDOAA@B@ADJ@IA@DJJADJDJD@DDD@E@JH@EDJOGEJMLKIOMMKKOOJMOOOOOMJOONNMMOLNIMJMGGJIE@@JHE@AAA@ABIBIDBJI@DDHBID@B@DDGICLKIDILJEKEFEJJIMFM@EKEBHBDDJJB@E@GEGCLHDINIOMEKBJGMAGOMKOMJKOEDH@I@@@" "IBJB@KMEKEEKDBHHJD@IEMGFBCFAKMEJF@KNHD@@B@JA@MBNJDJEEDJFJGDLNADKGKMCLBBBHDDE@D@BCA@@J@@I@@I@HIFJB@BE@ACKNOEJMNIFNMCLKENJKEHMFJKMFINEKKDKMJMGKNND@EB@BBKDHHDH@DH@BH@DFB@A@EAA@JBBANENOFIDCIIGBKBIEEBIBKJEHDBHB@@A@KNHCBMENLCFBCGEMDHABHHJAFMEFMENHBBJDH@@" "ED@DEGNKDOMBMMABNIBFOEOLGN@OENCFHKMBB@JEDJ@DEGDEKJFHDJGACNKJEFGEOHKFJDDJBHJHDHJDDDBJ@HJ@BIBAB@A@DJH@@H@ONFOGJMOONMNJJOJOOGGGGOJOJJKMKOOMJOGKCOH@H@@JI@D@BDBDJ@BHHBJAAABHI@JHJBIABKFHOMGCEBNKNDGBI@KBNMAGEA@BIEBHBBENHKFCMGHCOAOMGKBDKJDEMJEOIFKOEA@AE@@@" "HBJHJNJMOEEOJIBGD@DEJKFJH@IHMIFLB@ODHE@HA@JHHJHKNLIFMDKBJMFDJFHFGCNALHJ@HA@JAA@JI@H@DA@EDB@D@EGFA@ABJBEGEMKNLOIBKMONGOMJOFMKGJMOOCOMNJDOIKNMMGEBBJD@DCGE@A@BAE@DA@@HDJHDDBHD@HBHILCNGC@KBICEJJFIEKDIKNHJHHJHD@HE@IGHBAKDMHLH@JKFJMA@AGBDJOMEGMJKJHJJ@H@@" "BH@AAKOKDJKJJJDEMBHOFNONGOCEEJKK@KJJBHBBJE@BBMA@@KEJCCFEDKBNBIEANIKGJADJBME@EDB@BBABHJBHA@HHJHDILEBD@DHGOOOGMMCOOJOGEMJONOBGKOJMMGGJOONEMOGOOO@I@ABEALI@JHHHD@JBHJDBB@BAE@EEJBIDBOFLKLEDJCJFIECFFBMFH@DEJB@EBJB@JBJNHFNJMEFGOCOKKGHJEMABJJNJIFONLD@@J@@@" "IEBJFGFJOKGGKHHKB@EBKCFMBH@HIOFHEAG@HADHBHBHL@DAEEEEJBAHMGECMBKKECFDLBBADB@DH@DJLJNDA@D@JEAA@BIBB@D@EEAGD@DNJNJIFMNNGGMJONECOJMOGCKMKDJKJKI@AGDEE@A@BBDJ@DDEBHA@DACJIJI@@I@BADBBAICFEFNJENEGEHLBBMEEEDA@AHJ@J@ID@HGDE@KGLHH@JEKFFJE@BFHHNOGFOJKGCBJEDH@@" "F@D@HOOMJJKNMGAKDFJEFJONEGJIALENHBMDBJ@BHADBADHJ@EFMCEFDHNIL@MH@OFOGIDDD@HJIBIH@AD@@JAAE@@BBA@CEDDAE@BBEOOFKDKKNKKMMMOGENMEEKMGGMMMNNKNNIFKGOMBB@EDAAEF@DBB@@EDDBH@AD@@LJDJHHAAADOGKGH@MHALKHICEFEKE@BHIDBAD@J@BJAEJ@KMALDJOECOJKEBKAFLGEKNJJMOOHHA@C@@@" "KDHJGKFKCGMKKLBJAEBEECGJJL@BCKGH@DG@H@EDED@HDAA@E@AJLIHIBEJILHBJJIJDL@JJIBADDBBJJILD@BD@EE@DJBHBHHD@EDDCMDMNMNKAFMGKGBMNKNJKNKMJGFOEKDFKMKMIENAAE@A@HJ@JBI@EE@AB@AALJJJBAADBDJJHAIBLJJJ@ILJMBDHLIJL@E@DDA@HAEAE@@HGA@@OFNB@AJJOFEEBEDBJANNMOFFKFOBHIFH@@" "NKI@EGONMGBBGEEKDBDOKKOOEKBHENKECANEADHA@AJBIDBBHEDEIBGFFOJJJEFDOCGEGE@@B@D@HHHAMFHIDDHI@@BH@DAAA@HI@AAGKCKFLNNNKLMMLMKENOOOKMFMIMMINKKKIKFNFODD@DHHDDDA@@J@@DHIADHKEL@HHHA@B@@EGEGFGICEBJJOKCGBDMAE@JBADJBL@D@IDECLFEFKM@JFMGONNOIBAFMEGBBGEKOOE@DNKH@@" "MNEEOOKGJJONKLKDABKDICFOBLDACDNLFFN@BAADED@D@AEDA@@KFDDLIBDFEBICMFNCM@EEDJIEBABJBAA@@HABBEDAEABFJEB@EDD@BMBNIGEKDJKKJKBOEJBBMGJFJNNJIFMGDKJEJ@AAE@BEBKBDEDAEBBD@H@DDBBJDBEDJIEE@ENCKENDJECABDIIACFH@DAED@A@AEADDB@CKCAKIFDAAJGKFDIFJDAFINKOJJOFOOMECMH@@" "OMMJFOFMDKEDNCEHJMFIEJKNJKACGOEJMFMFDDBA@@HHJJ@@JBE@MEKCCGJMBMCHGBMFJB@@@@BH@J@@HLBBA@J@D@@H@D@ID@@JHA@INJEMDNOFKOJLGJMEKOOONMEJOAJONKGKIEMBKLHD@JH@ADHA@@H@A@BHDBBAHH@BH@J@@@@BBKEJG@NEJEJOFFFMEHEBBH@BJHHH@DBAACEKEJMGOFDFJKNJMDKEJHMFCIEFIEKGKBMMOH@@" "OGOMMOFOGFONADJACAMFECONILEEADKDBEJ@HHHDEEAA@@DI@DHDOODEFOBJMJMCONNEMDNNKBDAB@EECCDDJA@JHJJBJIEBEDD@BDEBEFMFMGKMMOEKJOJJEAEDEBJOJNMGMMNOEKEKEBEAB@AAEBEDJJBJHJHDBIAFFEE@BDABFKKIEMCKONEJMJJGKEAGOI@I@DI@@DDEEA@HHHBMBAFIDEEALKONECELFDBIDCOKGGKGMMOOGH@@" "NOOGONJMJNMHDJMBMNKDJMGGBJJKKONHHIGFAABJH@BBDJIBBHAAHJOBMBOMCJJDMCMADBAADDHJDDH@DN@H@DD@A@@D@@@@L@HJDI@@JMKMDOGOGFKNOMGFJNJKJKGEOKNKGGOGIENMJH@DIBHHAH@@@A@@D@AA@@HCI@@IABHIADDBADENEIBJNEOJEJGJHLD@JBDJIBB@@JJDDCGDHHKONNJJJGGEJIFKMJEJI@MKJMJKOOGOKH@@" "KMEOEMFOEEKFEAJDJIOCEIONIJBBKLMEBBNHEDD@BJDDI@BHDBFBBEJLOGJDEGMIOOJJI@JDABCD@IBBIEIADIAEDBHJJJJJCBA@JBBJCKEJMNEAOMJKICLMOJOJOMINDNJMOLECMJMFNBJBBHDBFBJJJJHJAEDDIDDMDJBDHAFBDABHDJJOOLMOEABOGIJMBBCBA@J@DIABJ@AAE@KJBEEINJBBLKOLMFGLJIBLECFMEGKEMGMENH@@" "OOOJOOMLKMFIHGDIKOEFJKGNKDDHAKKD@EMDHAAED@HHBDHBHHIEDKGMDCANNKNMMLN@JD@IEDDIEDDDBIBB@@D@ADA@@@@@JLDB@HD@HGJKKGOBMGENLDKB@NJKHBFIAKMGEJGOFNJO@HA@HBAAJH@@@@DAD@A@@BBDJAAAEDIAEDHABHCIMMKNKKLFAEOFIEDHHJ@IB@HHAEDD@IEM@AFNL@IAFKOFJKEGNLIG@LKENIMOOJOOOH@@" "OOKEKFKKFKDOAEMGEDOMANMKBJIEGFNJDJKIAJD@ABABIABHEBB@@DHHJJIEIBAKJIHJ@@JB@@IB@M@HHBHHDJIED@BEEEEEBI@HIE@JBKFDBLNEOMFMAMDMEKONMEIELEKEOMCIJACFJBHEDHHDJEEEEEB@AEDJI@HJ@HHEHBDH@BBH@BHLJNLBDMDJJHHI@@BBE@JDDJDBD@ABLDNJIBKKGEDJJFMKLEOIEGEMDGIFKFNKFMFOOH@@" "KMGOGONEMOFKFKJ@MONOKIONODB@CMKHLONNB@IEBDJDDDDE@HEEBIEB@CEFBDJEHJB@EE@HJIBBIDECEHB@I@B@ADJH@@@@EBEBB@E@HBNIDKFIMGIFKECBNNHKKJFEFKDOELKFIDKJ@HE@BBEBE@@@@@JID@B@DHB@MFEADJBDJHHEE@BBHMBIBCEF@BEDJEE@HEAAAABIBEDHBCKOIHNMN@BAGKOLNOKOMHBNKFKGMMCOOGOENH@@" "OKOEEGOOJJENMEDNJMEICGKMBM@JOGGEEKLLHJB@FI@IIAA@EDJ@DBBHEE@@HI@IBJHJH@BB@BDDBB@HFKBI@BHJJABBJEBI@HHEDJHEADOFK@EAKOGGFONEIKEFLMCOKGGGNLE@FKGIDE@JIE@HHDJEBJBDBJHJ@DJFK@HBBAAB@BB@@JHJJDHDHH@EE@JBA@BIE@DDDLHDK@BBHIINMEGGGJHEJENOFDMEJKIEEKMBJOOOEEGNOH@@" "JOENGNNMEEFOIGMBHKNOMNGNDJF@CJNJMGEKA@HJHBMBBJDE@@HIADHDH@JJBBBBL@B@AEDHJHIIDHJBIDBBBDE@@DDH@HDBEBA@A@BHBA@MLONCLMLLKAEOFD@ACGMDFIIMINCOIMHDB@J@D@DBEBA@H@IA@@EABBBADJBHIDLHJHIED@B@AJBBBBJH@I@IDDHH@EABJBEJ@JHHDFMGEJKJN@CBICOCMOKNHJEODOKEEEKKOCMGJH@@" "OOOMMMKKONMMKMGNJOKKKNONKLIGGGKEEJNBMEB@JD@ED@I@DIEBDAAABJ@@HHDJ@JHJD@AB@BBBAB@HBNH@DI@BJHIEBA@@@DJEDEDAEDBKKOKEKKNMJOODJIJLJIGOJMKNNMFONNJAEDAEAEBI@@@DBEDHJJ@DI@@KJ@HBDBBB@BD@ABHJHBI@HH@BJDDDABEDI@DHAE@ABHBEEJCJMEFOGGDINKOKNNNOJKOENMMKONNMMMOOOH@@" "KOOKCKNONJKKCJLE@KFOKNMJJMFFKKFLHGKIB@DJ@IEDIJBBIBDDIDJD@@JJBBI@I@A@IEDDEDHHDDBBMEJJHDED@AFBDJBJIA@HA@AF@BDEOMFGFMKJKIBM@BGB@EJDNJNMKGCEOMAB@CD@D@HDDJJBIBCD@AEA@JJMEJBAA@HIEAAEDHD@DHDJBBJH@ABIDIABDJBBLIEDHBI@BDNO@IKFNKCEJJMKNOKFHEAJNFNJKOKNNFOONH@@" "OOJNONKFKOMJKEKNNFMKMMOOEL@LEGGBAKEBDIB@JB@ABDHFDDIA@A@HJJ@@HHBJBEFD@@A@JADJIAEBKF@@ABH@JJHHI@H@BDEADDJ@FHI@EKMEOKFOLGKJEGMOEBNOAOKFOMENM@DHK@BIADEAB@@HDHHJJH@JD@@CFJEDDJIDBHD@@ACEBBJ@HH@BJHHD@DDIAC@IBD@BBHBDIBEFLBGGEAHAMGOMMNMKCKNMFJMONKFKOKJOOH@@" "GOGMNONKNNKEOEDJDMOOGGEMKKJAGMLLEEJLEBDJADIDIBBHIABBBIEE@@EBBBH@HH@JJJJBHJAIBD@BBEMBJHBD@AEBBJAE@A@BIA@JHBBECOJCJNKKEMFDKJBBNICEMFNKJNBONEBB@JHDDJ@D@EDBJBED@AB@JJEMBB@ABDLBHJBJJJH@HH@JBBE@@EEDJBBDDHJBDIDIDBIBEAJMEAIMODBNNMMGGGOMIBIEGMFKKNKOKMOGO@@@" "ONNOMOMOGKEJNBKOGCJKMOGKJN@JCGEBHOEDHDI@JABADHHBJDDDHB@@BDHDHDAEEAEE@@@DE@DBDIEDHIBD@BHHJJDED@B@ONBEBJJ@BHHHEGDIJKLJFBHIDEMMADHJCBINJLIGE@HHJ@BJJEBCOHB@AEABJHHJ@ABDHIEDIBA@EA@@@EEDEEDA@I@IB@@B@IAABJ@HIDBDBHDI@IEGHJEGFBHCJNOGMNJNGGNJCJMFOGMOMOKKOH@@" "NMOMKJKFMNNKHJNKFFONMOKOEMA@NMKNCNJLJKBEEEDIEEEDJIBIADJJDIA@BIB@@B@@BJJI@DIDIBEEEAE@IDEB@BHHAEDFJILHEAAE@BB@HOEBNOMMMOEBAKBFLBEGMMMOKJEGHHBB@EDDE@ILJKAED@HJ@BEADHEDEEEBDIDI@DJJJ@@B@@BDJ@DDIBJIDDJDJIEEEDIEEEBFJIJKNCNMKHDEMGNOMKOKCFKJHNKKMKFJNMOMKH@@" "MOOOOOOMGKENOEMOEOMEKMOOEJJEGGFDJJHI@@FHI@EBIADIEBHBBA@@JBBEDDDJJDEBD@@BEABI@EAF@B@ABA@DJHABJ@@HJFAADDB@KDHEAEDELGKGKJ@DGDEAGA@BNOFOAMAEDE@IFHBAADDCBHH@BJD@JI@DBD@B@CDE@DJDEB@@ABEABJIAAEBBBH@DBB@JEDIDDJE@DHK@@DHJJICGGEBJMGOMNMEOMGMMGKMFOEOOOOOOMH@@" "CMONKKOGNJNKIGKKGBKOMOKNJGE@FMDIGOBBBJHEBEHIBJEBJJDHHJEB@DDHAAA@HHHD@JME@DDBGKD@EDDJEDE@@BJFHIEAHHJBAADJ@A@HBOMAKMNLFDEELI@DIMEACAKMNLEOJ@HD@BIDDBBHHLEDHKBJ@@EAEBIAE@AFOBAA@EEJHA@HHHDDD@IA@BEBHHIBJJEBJDHMBE@JJBBGODIEK@EGBKNOMONJGFNODNKJKOGNNKOMN@@@" "OGOGOGNOOOKNOFNOKGOEGJOKMNJBMOEFJJIDLABIDHEBDBHJEEABBHHDDHHADDDEEEBIE@@DEAADHDIDH@H@HA@AED@HBBBBBELHJD@@IDEADGBBJBMCKHHJABJJDBHHNNEJBJBGADEADH@ABHIMBBBBB@HAED@D@H@H@IDI@IDDEA@@EDJEEEAAAD@HIA@HJBDEEBHJABE@IDJDAIDJJKEGMJBKMNOJOEGOFOKKGKNOOOKOGOGOGH@@" "JKJOOOMOMKFKKMKOGOJOMGMGHGJMCFJMEOFOADDDABHIKDB@HBDDDAE@IEADAAABH@DB@EDI@BDABJBEBIAEADBJ@ADBHHDFINJCBHIEBA@DAMLIMMJFNAOLKNHKNIOLCKBMMLIMLA@DBEDHJFBKLKA@HJAD@BJADEDDJEBBJDAB@DIE@BA@@JDDDADEDHEDAAAB@HBAFLHJDAAADGKGMEJKFEJO@OEOEOJOOGNMNNKFMOMOOOJNJH@@" "EGGONNKNKFMNOFEMNMEFFNKOGJOAGOGJOBJJLAIADDEB@AHJJHI@HJ@BB@B@JDDDAE@HBHABEDIBD@HHDBB@D@DAED@HBBHHBEHHDAB@@JA@JGACGECIGGAEJAEDBMDGGDNEGFDGBHDBH@BDA@HMB@HJB@HAEDA@A@BBA@HHABDIEBD@J@HEDAAABHB@BB@BHHDHJJHL@BEAADDLAJJJGJOGODGJOGNKKCEEKMMCGKMKFKNKKOOGE@@@" "MMHMEMOMOOJONMMCMMHMLMDOMCJLKGJKEDOKKDBDBI@EFJAB@ABEA@IDHEDEAAAAB@EBDADE@ADEKEBAA@DFHIAD@AEBHHAADJBBIBDIE@JI@EFBNNNFLJJNEE@EECJJIKCKKJCE@DJHEDIBDJBBIDD@HJED@ADDHKA@DDBEFMAD@EADABE@BDDDDEAE@IDHDEBD@BDBKE@DJABAFNOIEFJOFIJNEOIEIMHMMNEMKOJOOMOMMEHMMH@@" "JKGJOOOGJNMNMJBOKICBGKKFJDOKFNONJACGNODHHBBHHABDJJ@@DCB@BH@HDEDDDJHDJJAJBJBJD@@JDE@HABDAED@DABJBA@HJDBIB@BB@DOMBHKBIJ@@HMDEAEHH@BLJFHJEOI@BB@BDJABHHDBBJDA@AEDABD@HEABH@ABJBJBLBJI@JIAAEA@H@J@BFA@@BJIBD@HJB@HIGKOFDBKOKKFOIBKFNOBFDNOJBMKMKJOGOOJOFJH@@" "EJMEBBINOMOMKEMGFODKKGGONKKMIOKEDJENKMMEBMDCEBEE@@IDIDDJHBIAA@AA@@EA@@J@D@HHJJE@M@EEB@AD@AE@J@@HHE@HADDDIDHJIGDCNJMGDEGGEE@EEGGEAGEJKNAGDJHIDIAAD@HE@HH@BHED@AD@BEE@EHEBJHHHA@BH@DE@@DD@DDDJ@JIADIDH@EEBEFAEJEEMNKMBIEFOLMNNKOOGFNIGKGEMFMOMOKLJBEEJM@@@" "JDKBEMGGOOOGFEBNMJJFNNMGKEFIGGNNIBJMDJCJL@BLIDHDEBBABA@HBHBBBKDDBI@DBJ@JIEFA@@HE@E@@DED@JD@E@EEBBHEADAAABAA@BKEEIMJOHH@LIDEADIH@HOJMLMEFJ@DDBDDDADE@JBEE@E@ABHAEA@@E@E@H@DCEDJHBJA@DJAAFJBB@J@HDBDBBEA@IDIJ@AJNBIEJJDKKOGDKEFOEKKKBJMKJECGGOOOGEMBFIBH@@" "EBMNNENOOGMMONNMCEDIKKAOFEEODFKMKNEKAEDGKNICBAAIHDIBIBDJHBDDEDIADBBID@ED@@ELJJA@E@EI@HAB@AE@BH@AGG@F@JJIDJBBHGDAOAEODAGIFI@DKDODAGMDGLAG@JBBIDJJHC@GGD@@J@ED@BD@HDM@E@DBJIM@@AE@ADJBADDIEAAB@JIBDJDI@LLDBFDKNOAEDFMCNMNKAGMECGLFNLIEFEKKOMMOGOKMCKMJE@@@" "DIBAEKEMEOOOJKEONJKBOFJNMJFMKMOKJCEFJDA@EEFDEFJBEADDBDA@BHJHHBJD@D@BABHICBDA@@JEDE@BBBHDID@ED@JMDDDHK@@BB@HDBJMCJOGJ@JDCIBEBDNABHBOGJNEJJA@HBB@@FHIAAEJHAE@ADI@JBB@EAEBH@DABFDHJDB@A@ABJ@HJHJ@DABAADEBBKEACEE@DABKEFBNOMNMKBMKJKGJFJKOMFJOOOMEMFMDBDI@@@" "KFMNJDOKONKKONMNKEMGJOGMNLIKEBKODJNHHFJE@JMME@@I@DABDIJDHBAECE@I@HJHJDADDDIJDJ@@A@BHDHA@BAE@AEEBJIAEDDMDHJAADGJEEKOOI@IJFL@AKBLHDOONMEBOADDBHIEIAEDDJJEED@EDB@D@I@J@D@@BIBLIAADABHJHHDHEFEDB@IBLIBDA@DH@EEMJHEBK@HKJIGNJEFLIKMOGJOEMFKMKONNKONOIBKMKFH@@" "DIA@EKJNKKOGKEKEDJJEOAHOMABEEDNMNCNCLM@@DIBKHEJBJIDDJD@IADH@D@B@EA@B@KFBJJBDI@JIDDHA@BBBHD@DHAIEDJBAJA@BC@DD@MDCKFOEBBBEIAEDDMBBBEGKFNAEHAA@FB@DBLBBIEDL@I@A@JBB@D@IADJHDIBBJJCFHB@DE@B@A@@IDDHABIADJJBM@NJDI@@EINCNCMKIEEBDEOHLGMBJIEFMFOGNNKJNM@DDI@@@" "ADJJJEEIEGOOGONNKEKJ@FOKKNDKEAICJDMDIBJIADEFGL@D@BAB@JJABAADJDDE@FBHE@HMJHHIBE@BAIADBHDDBHJAADBAAEDJDJEHDBHIEGHIFKMOEEEKDDEAAFMEEGMNKDHOEDHJA@MBIBIEDDBADDBHJAA@JADDLB@EBDHHJMHHE@JC@EAABIDDBDBJHBDB@A@AOCEADDJJDIEIBNDLEFICNNOK@BNMFKKOOGOOEDMEBJJID@@@" "GEEDJMGOONMOONJKNOEEDIDGNKIBBNNJDIFAJG@BEAJEJKJIFIBDJ@@DDDBADHHHE@DE@GEAEFADD@DHF@BADBA@HA@JBHMJBBJ@IBHBIDA@@JBCKGKAGBKDAM@ELAFJGDFOFNBBH@DADJ@JDHBJBBMHJBHD@HDBADB@C@I@AADCEDEG@EA@E@HHIDBAAA@@BIBDKDJNJMBLEB@GBLCDIBKKJBDNKOADIEEGKNJKOOMKOOOEJIEEG@@@" "HDIEKAEDJIKGOMOOEFOBABOOKNCDMIA@NANJLME@HJ@HAFMJ@BHI@JJI@JHJBABBLMJHBDJJBLJA@JIBHIHJ@HDEBJB@KEBEMDHIDDBHB@JBBGLEDMFJ@GGIFJMJKDOG@BKEIEAOBBBHB@JAADHIEMBEFHBBJEA@HBHLHJDJHDBIJBJIB@JMIJBDBBHJHDJJHDHJ@BMKD@HBHHEEIJKLCHDDMIFCNOOJDBGKEGOMOOFLJIEDFMDI@H@@" "BIJJFKBKGGNLECNOOMJLNDENNJHJCFKMBJN@JK@BBAEBDIAGMDABB@@BE@E@HJHHIBEFLICDHA@JB@DDBBB@E@IH@@DIDJJBBJBBBIFEDD@DHNIABKH@E@KJMEBEEJNHE@@NJDDKHI@AAECDJBBBJBBJIDI@@@LHE@BBBAA@BBHD@IFDIKEBDHHJHHE@EB@@BBDAEODDIBEDBB@FJHCJJENKFBHJKKMACIJMOOKNEAKOGFJFKBJLJ@@@" "IBAJIDIBHJACJNMNOOGIKHNMMNCEDM@HFAEJMFADHN@DMBEEFIJEDMEE@E@IJ@EABDJ@AJLI@JE@DE@HHH@DHBJ@MBHAAAEMEBMDLB@H@HJHBGDEENMDHEGOBJEBJGOE@IEKMEAGB@JHH@HBAIEJEEMDDD@JEHBJ@I@@HHHEA@EBHDIJL@BIBDE@BLHE@EEEIEBLKEEBEI@CHIDCEJMDC@HEIEFCMMKHNLOGOKMKJNDBHJDIDJLBDH@@" "BDJ@JIFDCENNMIKKKJOGNKOOOJHNABEFEMMGKLEAAADI@JHBEF@HI@A@E@BB@JJBME@JECABE@@E@HEABDJIADIB@DABBBBFJE@AADJ@JA@@HNMBKE@AAAEHLHHHIHMDDD@EFJEKHH@DBHBIDD@EBKBBBBDA@BDIDDJIBDE@HE@@EBDFEBHEEJBJHBB@E@D@DHHCEB@JHDIDDDEANOEMMCEBDCHJOOONKOGJNNNLMKKMFACDJHBIB@@@" "DI@MAB@ILMBIJKOFNOOMGNLNJNAJJGBDOKENKBHBJDABFBBHJMKBBEBE@DLHI@@D@HE@HEDDHEE@EA@BDI@@BA@DJHJDDFE@LHABBADC@JEEAJJEBMEDBDKFCEEEFCFIBAEEJEBJLEEBHFADBBD@IHECAABHJI@DB@@DIB@DE@EE@IAE@HE@HA@@DHII@EBEBBFMJHJBCBDABJ@JFKMFOIBGBJLCJKIKOEOOKKGNJLJEILHBDEHDI@@@" "IBD@JHJBB@HFABBEKKFGMEOEOMBO@EDNBFOKFLAB@IDDHLHAEBMDHHD@DIAABDJIEBJJBJAAB@@IDBDDJDBJDDBJ@A@@HHDEBBJDHJADE@@@EGEEEJ@ADAFML@@@AMKDAD@BMEEGE@@@EADBHIBJBEA@HH@D@BJAABJABIABADH@BDDBJBJJEDJIBDDDI@A@HIEJED@IHIADHBDAKFOKBCIE@GJEOMGMEOCFNMBBDC@HBBBHJHABDH@@" "BDIJBC@JHJBHJDHJFDMJKOEKBKENBGBHMMAFMAFDIBJIEABE@EBKKBIEAIDBDA@BHD@@H@JI@JMBADIJ@ID@HID@EDFIA@IJIDBIB@JI@BEE@EFIKEEBIJBKBIEDJFJBLJEEFLKE@EEB@DJHBDJADJLHDDKAE@ADHHADHBLIDBEJHDJH@H@A@J@DABADLEDJFNJE@EBDEDJJDICDEKDEMHJGBCMFJFMGNJMICBHIBHJBHJHFBBLIB@@@" "FJBBHHE@A@HBBIDHHIBDJJNBGNNMDEIFJBEL@JDIBJAB@JDHKDDHEFB@DB@EADEDA@JJBEBBB@ADJAD@JDADBEAE@A@BBEBABADBDKDBEBH@ABIGGD@CFFMFMF@CEKEKCF@AGGDJD@@JEBAFIBADBDBEBB@D@EDEBADABHADBID@BBBEBBJHDAEADE@BA@BCE@IAFHIBHBDBJDIBHAMBBKDMAEKKOBCJJIBDHHIDJB@HD@E@HJBBK@@@" "HAEDCE@EBEBHHBAEBBHIABEDMKKJAGFIEDDBE@IBD@DEEDIA@IJBJIJI@HJHDA@ADEA@HHDDDBJ@@BBI@HD@LHD@EDEHDHDDDDADJHAEJNEMFOOMNMEFMLAEBJJJJEDAMKEEKMOOKEMCJMD@JIDAAAA@I@MAE@A@IHA@HDJB@@BJAAA@HHDEAD@DA@JHHDJLJJBLHDDIEEA@ABDHEBAAEDKGDBNNMIEBDDHJBEDB@HJEBE@EFAED@H@@" "BJAAD@A@E@DBA@J@@HBBDHIABGJDJFHOJ@IDHJBIABIBJADBJBAADBNBEE@AABEDA@DE@BHIJD@IEDHBIBHIAC@J@@JJIBHI@JJADBJJEIDBKNJKENHGEGDJOF@CGJIGEG@KMFJKNJADMBJJADBJHDHJDJJH@BHFDDHJDJ@IEDHABLHJ@EA@DAEBDD@EEBCJADDBBJADBJDJDDJBHIDHBOHKBIBOBDDHIBB@H@BHDBA@E@D@ADDBJ@@@" "MHJDADJBHAADFE@DJA@H@BBBHIKMHKGJLE@@B@DBBDBE@JADAEDFAEALHABJJD@@HEA@BHAB@IE@@AADCDA@DDB@EAA@B@A@BDIOGNJKJFIHFIMNKEBIBMAEEKEFMEDEJDJEFKMLK@LKBNJKOGLIB@D@B@DDE@BAA@DAFADD@@EDHBD@J@DE@H@ABJJD@ILEDCAEDADBHEBABBA@B@@EAJOFHMNLHJBB@@HDBI@ECADD@JBIDABHMH@@" "KGFIDA@DABH@HHJI@JEBIDDDAEEGGMMAJHBJHDIDDIDJEABADJA@J@DCEDD@@IEEA@BDHBJDEBABEDB@H@JA@JDHLBDDHDJEEIB@HEMNEMFEMFB@NHHBDAEFOF@CGKEDAB@HKHBCEMCEMCMM@HBDMEBI@IABAHIBHDBH@HBAEBDBEABJ@IB@DEEDH@AAEFA@BHDBIDBDEBIDIADI@JJ@JLEMOGEEDAAADJEBHDJHHH@JDA@DADKGFH@@" "NMEBADDHJEBIBB@BB@@@BA@IB@@ILCFBHBH@BHJ@HCABIFDJA@DEBEKDJJIEBB@@BBHAA@@@HDDDHADEAE@EE@HAADJJBIH@@BDEEBA@KDHHADKKKKMANJBKLIEDINJBKLENNNNID@HIFHDBEEAB@@@LJBJIDD@HEE@EDEAD@IAA@H@@DD@JB@@BBEDJJIFMBEA@DBICDJDF@HBHJ@@J@JCFALH@BDHDB@@@BB@BBDJEBHIADBEEKH@@" "E@NNMJ@A@@DCDHIDDJJJHDE@DJJBADHDI@BJHA@JAHDDEHJ@JDHHDH@A@BK@@HIEDDADBBJJBII@BD@HB@DH@DCFLKBMOFENMFILJLJDHBBAFKDDGJHGC@EOJB@BBOM@FG@JOAAFKDBB@IBIJILKEKMCGMJFIKFA@@I@B@HAB@DLJBJJBADAAEDHH@FJ@D@@I@HIBHBHMAA@LBHD@JJ@DI@IDBBJI@EA@JJJIADHIFA@@D@BMKKHE@@@" "JEEIBBNJBJHHABBAA@@@BI@E@@@DJAE@BBH@BJE@JBIBOFAE@ICBJGFNOONJOKB@@@JKDD@@HBEBHHIEDE@BJHHDJDEBDEJABIGBJB@ICMEFEDKBJFGMNOID@DEA@ADOKMOCBJFIECEENDHBBJGDJDBMABEABI@HJJ@EAEDHHJEB@H@AAFJH@@BFOJKOOKKGBJFDHEDCGJDJBHEBJ@@JB@EDBI@@@E@DJ@@@DDBBD@HJJBKJBDMEBH@@" "IADDEMIED@ABDEEDDEEED@BJBJJI@J@BHD@JH@HD@HDEBMNMGBDDIJMIHJEOJJMFJM@JJHJJBHHDBAB@A@BHDKGI@JHLJH@JEB@E@LJBDEEANIDEEIJKEEGNI@HHDKOEEFJLMEADKLEEABBIHE@BEBH@JIHJHDOFI@J@D@BDBA@HJBJHJJHEJKEJJOMBHLMJLIABGEKMJEA@HA@H@JHA@J@BHDJJJBJ@AEEEAAEEABD@AEDMMAADDH@@" "FDKI@BDJBMBDI@@AA@@@ABD@D@@@B@JDBIA@AEBHMABJLJBKENJKFEBDBJIDOEBMMBNJMC@@HACADJHJDEDAEJHDE@BB@EE@HDK@EA@HJH@B@BIIBEEDJJJMBE@EBEJJJIEEBDLJ@B@@JHHDE@FI@HEE@BB@EA@JMDAEABHJIDFD@H@FEJKJEMJEGIDJJABECFJKMFJBIJJDEHJED@DDJABHB@@@A@ABD@@@DD@@DIBEJBIB@DNIC@@@" "HIBFDHI@MJNIBEEDDDIEJDHJHJJEDJ@HHBBED@JA@BDAAIDDICFJHHIADHJIBJIBBIIECBNKJGEDABA@I@AKODEA@EDHE@@BAA@BHDECABJEEEBBEKEOOEGHDHB@I@OEGOMFMBBEEEBJDFEA@J@DDB@@E@IE@DEAGNL@DHDBDAEGBNKJFEDLJBDJJDJHIDDHHJKFDIADLDAB@DBHAEBB@HHBIEBJHJHIBMDIAAEEBDKJMHDHICBDHH@@" "EBDHIBBEBAANE@@AAAB@@AA@A@@HA@BABHDHBJ@DEEADDBJJBDDIABBIAEABINBDHBBDDEAJELNCNDJBBEKB@BHDE@A@HEEDJDEDBI@DDD@H@@DDGDBIBJIAAAEDDDDJJDJAGAA@@@HAAA@DJAEABIEE@HD@EA@J@BFMBBBICNCIMBLEAABB@IBCLJDEDDJBDDIABBJJAADEEA@BJ@I@JDB@D@H@D@DD@@BDDD@@ECLDBEBBDHIBE@@@" "JHICBEECNJGEMJMDDDDEEDBEDAEADEDJDBABH@JIH@FAAEE@HIEBJDHBBBJDBDMBBHLIEHFEJAANAK@LHJDDJDBA@EDCBHBA@I@ADBBBLHJAEE@HH@IFOOGJDB@BABOGOKDH@HHEEDBHIJBBAD@DHDB@JFAE@DBABIABHIHFLCLDBMC@MDIHJBEIBABJBB@IBJEDHHEEDDC@@LJH@JDBABIEADEDAEBAEEAAAAEJMMGBKNEEBFDHJH@@" "EEBDNH@DEDLIFF@AAA@H@@HH@J@B@HAA@@DDAE@BBJHJEADECB@E@IEEDHBIEE@FHJIBDBHJ@JN@NJOICDIA@JHJJHADBBHDBBBDBHDMAE@J@@BAAEBMEBL@JDGABHAJEEJEDDB@@BHEDEI@JABBBA@JBAD@JJHJHDDIFDOJKHCJHBHJABDJHK@EEDJ@IEEDHE@BFEADEBHJJB@EDAA@@DD@HB@BH@HH@@HDDD@CCDIIEA@@KIBEE@@@" "MHJIEEEAAEABAEMJDBEBJEABI@IDE@JDJBI@J@EHH@B@HJBHDDJHDE@@AAD@@HE@A@DJIDJAECMO@EBGJBBBE@B@@BJADHBIDHDHLBIBD@EADDDLB@FJOEAE@HHHHEDEGJK@BAIAADE@ABDJAHI@IDJ@IDBJ@@B@EBBBBOBE@GMNEDBIDJI@D@E@H@ADD@@EA@JIA@JBHHB@@HM@BHDJBIBHEADHDJDEBJEBABMMDBDEDDEEEDJHMH@@" "JB@B@@BJD@DONHCFID@@@HB@BE@@@B@A@DBB@JJCBIDJB@HAAA@BHHEEJBABJA@EBDH@BA@D@EG@I@DHDHHHHBDEED@JABHBAAIA@HBEEDHB@@ABMEAEJHD@EABDE@A@JMDEEJD@@B@IEEB@HDDLDB@JDBHAEEAB@HHHI@I@DHGE@A@DB@@IBE@DBJDBBME@HJ@DDD@HBBIDJFBJHBBA@D@B@@@EB@B@H@@ADKF@KOI@ABJ@@B@BBH@@" "IDIDIEEEAEA@DADEJ@IDJBDB@@BDED@DD@HDICEDDBA@HJBJDBDHAE@@ADJD@JEDEABJHDBIECMFBBIBJBBBBDHD@@J@JDBHDJBBEBHJHABH@HHIBBGOMCAE@BEB@EDFEOOBBDHHH@JD@JHJEBBBI@JABHBH@A@IBBBBBJDJBCENEDJA@JJDEAEBHABID@@ED@IBABJBHHDBAAEFDI@HAA@AEAB@@BABBIDHBMADA@DEDEEEDIDIDH@@" "FMBMB@@JJ@DEJJ@HBEBA@HADBE@HH@@A@D@HBJJBIDMEB@DHADADJ@EBDA@IFH@A@DD@BIDB@DJIDIDD@HHHHHBHJE@JAADBH@HHHDBBBJ@@H@BBLMEEEDD@BE@EB@AAEEEEIJB@@H@BJBBA@HHH@JADDBHEBHJ@HHHHHAADIDJI@BADJ@AA@D@@KDHDABE@BIDAD@I@BEEIDJBJJ@HA@D@@@HHEBAD@HDBEB@HBJMA@BJH@BEJEK@@@" "IBEBLJJI@EE@@BECNH@HB@D@HHE@B@E@@@@A@@ABJA@@EEEAGAJK@E@DIDB@@EEDEA@BHBADECNNJBAAE@BABBHA@HB@DDADADJBJHHID@BAAA@HAJMMFKAEDHE@IEDFKEMJL@HDDDB@ADHHJJBIDADAA@B@HD@JBDB@EDDBBKKNEADB@J@DEAEE@@BADI@E@FJLGDEEE@@DBJD@@D@@@@E@B@E@HHA@B@H@KNEB@@EE@DJJIJEBDH@@" "BEJEI@@BBHLEBJLBAFJBHHIDBB@AD@HADHEDBEDD@JBJH@@B@DDDDHEADADJI@@A@DEDADD@HFKK@HJD@ADDD@@JEADJI@J@JA@H@AEBAEDB@@BBJAEFMED@AE@ED@AEEKEDBJB@@BAEDBED@@HDBHBHDJIDEBH@AAAD@ABHHFNK@HAADAEA@D@@DJIDADE@IAAA@B@@@JJBHAAEBAE@ID@HAD@BBADHHJBKDBAJJEAHJB@@DMBMB@@@" "FHDHBAAEDAA@D@CDJIDHB@@@HHJJAE@BABHA@HA@J@D@BJJDEA@JIA@FADA@BMBDFHH@J@IEA@NEMJ@HEB@IAEB@HBA@BEAE@JBAEB@ED@@DBBHHIFOIEFOED@B@AEGKEDOKDHHJBA@@AE@BEDBBHEDEB@DB@HBEDDHBE@HBMMCHDEDHBH@HKABEJ@DADC@DDJHDEABJJ@A@BHD@HD@JDB@EDBJHHH@@B@IDJIF@A@DDAEDDB@I@K@@@" "HJBBHJNEJJBBIEDA@BIADBHJ@B@@D@@@D@ADABJE@JIDH@@HHFIADBE@DBJED@DHHAAE@JB@BEHIEFJA@DJ@D@DJBDJJHHD@E@EB@DJH@JHADHBKNIEFMMADABEBDADEMKEDKNJ@ID@JH@JI@BE@E@A@HJJIBBI@A@BI@DBKEDHMB@BBHEDD@HI@AEBJA@EBADDK@HH@@IDJHEBJDAD@A@@@A@@B@BHJADDJ@DAEDJBBJMCJHJBBHH@@" "GHFHKFA@EHDDO@@JNHBJADA@I@EDI@ADH@BABAA@B@BAEEJABHBD@DHDHH@@@I@CEBB@E@HDHJOJKE@BBH@E@I@@HH@@BBHJHBHEEA@AE@AD@AEEBJOOABNODDHIAGKJDGOJJEED@AD@ED@DEE@J@JHJB@@@HH@DHE@@JB@EFJOJHI@HE@BBEF@DH@@@HI@I@AB@JDBMEDB@B@DDBDB@@ID@DIE@DHDADBJ@KJH@GIA@M@DCFHK@O@@@" "HFHBDAEEBBIA@ME@ABDHD@HB@B@AD@D@@DHDDDDEDKDJ@@@JHEDIEJBHAADJIB@H@DDE@EBIBAHKNJJDDADHEBBIBAEEDHA@ADBH@DEB@BHADBDJMFJMEEFJBIBDJBKEEEJKEJIBAD@J@BEA@@JAD@D@IEEDBDJBE@IDAABJKNHLBDJE@EAA@@HBDJIDD@JBMDIE@JH@@BIFIEAAAA@I@@A@AD@B@B@HA@IBD@EEHDDJBEEDAB@K@H@@" "GKFLKJMDDHFDE@@EDLIAMEADADEDAAA@IABI@IA@ADB@IEE@BHEB@@HABBA@BHEBJHHHE@@B@KELAE@HJIAA@@HADD@@ABJJJAD@II@DJDA@@MAEEKNJBJIOMAEDEOLJJBKNMEDEH@DABI@DLHADBJJJD@@AAD@H@DDDJHHEDAMFHB@@E@HHJJE@J@DBBD@H@BE@J@EEDHBAD@DDHDJDDHDDDAEADADEELDIIE@@EAC@IAEJNIKFO@@@" "MEICDEBKKEIJHEE@@A@BJHB@JA@ADB@A@@@BE@EEDBHJB@@BHBH@FIEBDHJAEAAD@EBJHBBHJ@JKG@BA@BBBBJBJ@IFJDD@@@JAEJBDI@JJBJJOEJEGDIFOKDD@AAFOKDIGEBMGJJJBJHDIBBMDBH@@AABKDHBJBJBBB@DB@GFJHBHJB@JJE@ADDEDBHIBEDK@@J@J@@BBHJAEE@EB@@@D@BAD@DBHB@JJ@D@@EE@JLMFNJEAFDMEH@@" "ENONKCEDLJDEBHEBJHBHEBHJ@DEDA@JDABJHHBH@@HB@DEED@HBJHB@DAB@B@BDAE@D@ADDB@JKNMEDJBHDDD@H@I@@@IABJJ@D@@HABB@@D@NJJBLJBADJOIAEDDOJIDBBIJBJKHA@@BBD@H@A@BJJDDH@@DH@HAAA@JBIEEKNJHBAAD@A@EDAB@B@BDA@B@JJ@HAEEA@B@H@@J@HJJDABHDAEA@BHJE@J@JJE@JEABIIEFFKOKM@@@" "OMFKMNIKCEKFHAADABDC@GB@BH@ADB@@D@@B@D@JIBHJHH@AEAD@BHJID@DDDHAD@E@ID@HHBLDFKJ@@DBI@JJ@HBBEDBBD@@JHIFBDDJEEAEMEEIKFHDKKNHD@A@KNNI@KFLMEEMDEEBIABCDHJH@ABBAEBB@HBJHDJA@@BNKAAJ@HHADHE@AD@IAA@ADJHJ@ADED@@HJHJDJHA@B@@A@@BAD@@J@BG@FABDADD@KFMFFLKMNKEOH@@" "GKMJKKOFLJLHEBBIBLHEE@MDHAEDA@@HHJJHE@E@BDB@BBEDABAEHB@BADHHIBHAE@EB@EAAEKHGEBKDHH@B@@BAHDHADDAEB@ABHHHJ@H@D@BNBBBMOABMIAAEDDDMJDGMJBBCJ@A@@HBHHHJD@BEDAAD@I@LB@@B@@HIFJEG@NMDDE@BE@ED@JDHHIDB@B@MDBDAEBB@BAB@E@E@JJHHH@DAED@IEHEE@IJDJBE@IJIKGNNJMNO@@@" "NEGOOFKOKMGGKEFBDCBJDEAABJ@ADBJAA@@BHBHDHIEDDHHADED@BHJHDAABBHCD@E@DJHBBCOGHNEMAEBBHDIEBBHBHBHD@EDJFEEA@JBI@HE@MLIKJDMGFBD@ABCGEIBNLIMHE@HDJBHDEECBIE@A@J@J@JBEDI@JBEDEMCHOGNBB@JI@E@AF@JBDDA@JHJ@AEAD@HIAEDHI@J@J@@DDBJAD@BJDDEABJFABCEFOGENONKGOOECH@@" "EKECFMNJGFMLMIALHHL@I@BFH@EDA@@DBDIDADBABB@AAB@JA@@JHE@@IDB@HBHBEDFI@EDDFINOJJJJ@DD@IB@DH@HBHA@E@A@HH@DJ@HBBBHECEBBFIGLHEAEDE@IODKBBEFE@JBB@HBI@@HHD@E@D@J@H@I@BDHAA@BJJJOKLKAAE@DKAEB@J@HBADH@E@JH@DBHBDD@BBDBADADIBA@@DAE@@KB@DHAHHILDMIMKGBKMKFEFM@@@" "KEFJIJEIMKKOOGEEEBAEAEEAGDH@JABHHABADA@DADEBDHE@JBI@EDEAB@HJBHBHH@HNE@@HIGDMF@ADI@HI@@E@BIIDBJBHADEFEE@HJBHDHE@BJELK@NE@HD@A@HECHFIMBJ@E@I@JBHHEECEAD@JBJADLJ@E@@DHHDID@CEIGDHH@ECHH@HJ@JBHHBDEAE@DJBHE@IBEADA@DADBD@HJDBH@IGDEEDEDBEEEGGONNMLMBLJKEFH@@" "DBIADHIFEFNKMNKFJHD@AD@JHIBJ@DDAAD@DADBIF@HDI@HE@DBE@IBBEEB@LBHEBIBEBEEABMJF@JHFBBABBJH@HBB@D@EBJAA@J@AE@HBH@JDJ@HCNBI@EAAEDDE@DJCN@HBIBH@J@HED@BHDDBJE@A@BB@H@JJBDBBC@JHCBMJDEEBEBDJE@JAHBEEBBDHEBA@E@HDI@HCDJADA@ADDAA@BJDHJHAD@A@JKFKMNKKECDHIDDJA@@@" "NLDFICEEECENKMNA@JHJJ@MBBNH@JIA@B@JIFADAAEAABEA@JID@EBDDH@DE@HA@@BECDH@B@BMLM@ALHHJ@D@CBA@HJIA@@@JFEAEDHGBHACEH@DALAMFM@DEEEA@EKELALA@@MFD@JG@IEDECBH@@DDJHHDBF@A@BHHIL@EIMJ@B@@IFEB@@D@HEA@@IABE@ADJHDEBDDEDDADCDJHB@DDJH@KJBEHBJHJHDCMNKMFEEEFDKAAKH@@" "@BI@BDBBBJIENKEEOABADEBAHIJB@@DBHE@C@J@JJ@BBDHBB@B@JHHIAEFI@EBJBJI@E@AEDBHKG@EBBBB@DIBHDJBB@@BJJJ@HHD@AEEFABBKDJIBCGFM@BA@@@DB@EKGFBDJIFJBDCEED@A@HHBJJJ@@BBBI@JDI@BBBBE@GFHJAED@E@DJJBJE@DKEDDHHJHB@BB@IBB@BJHBHF@E@JA@@BBLHLBEADBDGMEFKMDJJBBAB@DJ@@@@" "JHBDDJNMEEJKEMOGEDHDJHEBBBGLJB@DBHBHD@E@@EDEAADDHLE@BABD@@BEDD@D@BA@MB@@DADNJHDLD@DI@DB@@DDEED@@@JABKDHHAKJ@EDI@BFLOMBLDJEEEBIAJEOIKB@DIE@BNL@HIFJDBH@@AEEAA@@BA@DI@AAI@JKIDA@@BEHDB@A@AAEB@@ABDB@EAHIADDEAE@@E@A@J@JA@BBIOBBBE@JI@IEGGMMFJMEEKJIAB@JH@@" "BBHHJIABJJDJJFMEONJEAE@EDBHE@DJI@A@A@JHEDH@HDB@IABHBDJDAEE@@AAEADLJEJEDJHJBNOAAI@JIJE@HEDHJJ@ADJJ@EDHABDEB@BHA@BJIA@JK@H@@@@@@HFJHDDJJ@D@J@BEABD@IE@BJID@BJHIE@HEBLJHDLDGKJBHJIEBMBIIDEDD@@EEDABIB@JDDHBA@H@IE@JHD@D@DJI@E@JAE@EDEBKOMEKBJIBJJDDJHHJB@@@" "DHBAABDDBEKGBLOOEMDIEDBHMEEODH@@EBBJA@E@ABBBIDE@BHBDI@@J@@EEDD@BAB@HE@A@BADMFJFJE@FFHBB@AADHIDA@@JHABJ@HIDID@DBDMDDEKFMBIHHHLJEKFMAAEIBA@ADIDHHBJD@JH@DADHIDD@BB@KC@EBKBKEIDB@D@E@HBDB@AAEE@@BH@DIB@J@EADJBBD@E@DBJBE@@@IGMEEHJAEDIEMGOIJGFMBAABDDB@I@@@" "IADJDDI@H@@@IADJOCKJJEDBBJJHJ@JI@@DHJBHEDDHHD@HEEBHHDDJ@JJ@@@JJHHIBABBJGDEEFLMA@@BLIADDJDBJBCADDJ@BDD@EABABBJHHAJI@AEMNDFCBFCACMMD@DJL@HJJBDBDE@AAB@BIADFBBJABIADDIJ@@DEIKEEAGBJBDBDHHJJH@@BJHBIA@HJEE@HA@HIAE@JBHI@@DJHBHJJJBAEBJNNGJIDDH@@@HDIABIDDH@@" "JBB@BI@EAGFNDMEEDNNIBHJHIDBJMI@BBE@B@HBHAIBAAEBH@@BAAA@E@@EEE@@BBBDDGDAMMOBOMJNJJEIEJ@I@ID@LHD@I@JHHJJHJ@H@H@BBOEFEDNKFIADEADDKFKIECEGJB@@H@HBHJJHHJHDHA@IHADHDHBMDMBJKJMOJGMMLAGAABBB@@EEE@@E@DDDB@@@JEDDBDL@J@HB@EBB@DMJJADHJHJDKKIEEEICKGDE@DJ@BBBH@@" "@DDID@A@B@IIJADHJKDOKEBEFEDHBBADDHBHBBHBJBDJJ@DABE@BDDE@DJH@@BE@HJHHLAEB@EMICABH@EFKDJDDAAEAAAE@E@BA@@A@CBJAE@IDOMH@KNNDDEHMAACKNH@MOIDHEDBJF@D@@DB@E@EDDDEDDAABIFKE@@JDFDMM@BEDAHHJHHEB@@@JI@EAAB@EBDA@BJIBBJ@JB@J@IADBB@IECEBEFOIFJHIDBLLHB@D@ADIA@@@@" "FIBB@HJEDEGGENIB@FOEDJEBIJAEHLJ@HADADDA@ADH@@JIDDHEDIA@AA@BJJHHFB@BBJDAMOKGFNOECJ@EFH@I@JDDDBJ@A@EDJBJJJDD@J@DGIEHDKMKNIA@B@DDKNMNI@MDOA@BHAABJJJBIE@D@BJAAABHDH@KE@BNEGKKGFOMLABJB@BC@HJJJ@DD@DDIE@IADJH@@ID@DAADAD@HBIHMDBLJEBIEGK@BDKMGGEAEBHHBBDK@@@" "@AD@EA@H@H@HHAFLM@EKJDJEE@D@FA@JBJ@JA@JEEA@JE@@AABHABDHJDBH@@BA@HEDHDIEBJDHDIJIFMDDIAA@DA@IJD@DJCHA@D@@@I@JAE@JFKFIDKNNBBEEEBBCKNIDKFKBHEDBHDH@@A@D@NBI@ABLHDA@DDDIAEKDJLI@IBJEDI@IE@HDB@@@JABHIBD@JDD@@EBHDEEBHDBHBJBHDC@A@EEBIBNM@EIKD@HH@H@HDE@AD@@@@" "EB@JHBBBJ@JBBD@A@DHGEKDJJLKDIEE@H@I@DE@H@BI@HEBJDDBDAAA@HDBJJHDDBHABMB@EDGFOJNJHK@IBJBEADED@HJI@DEDDIBHJBE@D@ABMFMOOGKKLDH@@IANNOGOMKEJD@A@EBBHJDIAEA@DJHHAEADEBBJDHFHJKJOKGAE@BEJD@JAA@JJJA@HDDDABAABJE@HDJ@@HEA@DH@HEEDIFIJJIFMG@I@D@ABBBHBJBB@JHBE@@@" "BDI@ADDH@I@DLKKJEABHKGGEEA@MBHBDBJ@BI@BAEDBBA@D@IADHLDBABJH@@BAA@BKDBHDH@INJFJJGBE@DJE@DA@ADAB@BIDIADBC@HHBHJEDJMKEEMBN@IBEBDHCJEMEFMJIEBHJ@HHFBADDIDJ@BDAD@DA@EBI@EBGBJKBKLH@I@JAFJ@DDB@@@JJDBAAHIDDHA@DBBAEDB@DJ@BJAB@JEHDEEGGFHJDEBNNII@DH@IAD@DIB@@@" "DIBBJ@HBJBBIB@DEJF@BDJMEEJKDEAEI@@FD@BEG@ADDBEABBBIEAADJD@AEBHJJE@IHJJKBICDMEOEMEDBJNHJHJBJABDEDBBJFBDHEBBDCAKEJCFJOGE@MBDHIBEHEGGJKFBMFLFABBE@IBCBJBAEABDBJBHJHKJJAEEMGMEIFDJFJJHLHEBJHJED@ABIDDEDJBBDEBAAD@GEB@AC@@DMDEAFJMEEJIB@CBMA@BDJBBJ@HBJBDI@@@" "IDHD@EBH@HDDDFJHA@DHJFKOBF@A@BAFEDHJIDD@JJI@DHDDHLB@DDABHIB@DB@@@EBE@DEDBDEAJAAA@EEGEA@E@DABDI@@HDHMDJBHDHIDEFJLDEGALBE@DIEDI@EBALGEAAJKEADHI@JBIEHI@H@DIBDA@E@DEGEE@DDDBLEABAEA@EBE@@@BA@BDHJDAA@BAHIA@I@DJJHAADJHIECDB@D@CBGNKBHI@D@JKAAA@H@JE@A@IDH@@" "CADJJH@BJBA@JH@BNMAB@HOFMIFDEDJE@AB@BJHJH@JIIBIABBHJBIJDCBDJIDEEE@BNJCEIDJJJEJDLEBADNBC@EIDEADBEAEEABADAABBAABMEMFJNJI@EAJ@BLE@DJKJKEMEJDDBBDDADBDEEDEBADEADM@FBCIDBEAIBMBJJIDMFBKJ@EEEADJIBFABLJBHJBDDJDLJH@JHJJ@BD@EBIEACDMKGHHBDEKJ@@JHDBBJ@@JJIDF@@@" "HDA@@AFH@HJE@BDHABJDJBBMKEIMBA@IMDEED@ABAEDBBDBDDHAADB@IHDA@BBH@@BDAFMML@MFEB@II@DFI@IDE@B@HBBDHB@@JDDABD@HJDEIFJLEJIDBHB@E@B@JADJMAJKDMABHHABDAABH@B@IBB@HB@EADHDKA@DLHBECEHAMMKDAB@@@JB@DA@LHBADD@IABABBAEDBD@AEEAELHDBELMFMJBBIBJD@IB@EBHH@KD@@DA@H@@" "EAFDJJ@BJB@HBHIADD@B@HMGJOBHMDEBCAHDAJJDJHIEDHHIEBJDADJJBIJDHHJJJHHJKFK@IJMJMJKDDILBEBJHEDKBDHHDIEKDJIBDJKADIKDHABJEDADBDJHJIBADAEBJD@IFLIDFJIBDJIFMDI@HIBFIE@JJEBALIAFJMJMJLHFKFJHHJJJHHIBLJBJIDABJEDHHIEDHJIBJLA@LFBEAEHJGJOEHHB@AADDHJ@HBBJ@BJICDE@@@" "JM@ID@ED@HJBDBBDAAELJB@KCJMGAAAFHJBIBA@KBCJHICFB@E@IBAJAEDAAJB@A@BEABHMEBGGEBJJKABIDIGBE@A@DIEAABB@A@DDI@DBKGBCEDD@HABADI@B@DIDBD@HAAEFBGFJA@DIA@D@BBDDEDI@D@EBGDIDJDFJJJEGGBEEHJDEB@D@BBLDAEDBLBDHE@BCFDHJNBFHDBDJBHKDDDGEJNFHBBIMDDABBABBHHAE@ADHEJH@@" "BBEDADHAFA@IADHIDD@AEDIDNOJJLLJ@CJHBEJEDDLACBD@HEDEBDJ@MBAFD@LMD@HHDEOCIDJJJEBMDNIBABIHHLJJJBBBDDHJJKBIEGKODIMDHAAEADDJIBJEBJDJIADEDD@IELIGNOEDJFJJHIABBBBJJIHHLJDBDKIEJEBJJIDNGMA@HHAEIHACDBEHBIBEAE@HABFDAIAEBMB@JN@BIIJJOKIDIED@AADHIDDHDCD@IDAEBB@@@" "MMJKMACD@JIBBAB@AAED@EFACMKEIB@LHGBHHBHBIAMDFJMBHCBIAAEBDM@IJGJJOKE@IDOJABJHHEBJAEDJJGFBA@IDDHDIAC@JDEBFJF@KB@AADD@JAAEJDDHIABMDDBHAADD@BFHCBKBEABHFDDI@IADHDBCGBJIEDBJE@HJJDBOIDHEFOJJOBLHEIBEDDDJF@JEJKAELDJ@J@HJG@IHBDMFMNDCE@AEDD@BDBBDJHAFDENJMMH@@" "JJEDBFDAEBCEDJDKED@ADJLHEKENBLIABMDKADBIBJ@JHIBJCLDJFFDHI@EB@MFKDJDIBCEGLEOGJJIEJJA@DK@HJEB@JBIBBDEABJDMEHJDDJJBA@E@NF@@IIBDLH@CCHE@DBBJIABHMEIBJDEABBDJBHBEBHHFI@DBJMDJJOGMAOEFBDIBIFKEHBE@DHICCBIANBJDHJHBJDJADFIEJDDIJCMFM@IJID@AEFIBIEFBEDACBAEBJH@@" "KEJKJHJJBDLEADI@D@BJ@NIBJFGMNBBDDAE@GAEFDEKEEFHADBIBHHMCBJHDI@HJKEKBBLOBKMGOELCBFEKCOFJE@HHJ@HJHDE@JDJKJJEBIA@@DDADD@HEJBBEBBBM@HAADAA@@DDJEBJNJIBHEA@JHHBHHHEBKGNFMCBFAMGOENJGIJBFMFJHHDI@JJFEHHJDJAD@KEEFMACEDG@EDAABBCMOCBJDKHBJ@A@DIDEAIBBJHJNJMFH@@" "FJEEEGD@HIAABBBE@ID@IIGD@IMBALHI@JJE@EBAA@@DAABD@JBIECADDHCIBEBEFOLMDJJDDENMOKLEIJJFNEDHEEC@JB@JHHJBIDJBDJDJDADHIB@IJDLAEDHIEDAIBLHBDHIDABIBIBBIDJBHHJHBBHFEE@IECKBJLMANOMKMAABJIEIOKEBEBDN@IADFEDJBHABDDA@@DDBE@EBJHDHILBELHAGDLHADHEBBBDDDHHAGEEEBK@@@" "KEEEBHBECBFFEHHHEB@JBFDKMBEGOABFE@JHBJDJJEEIJJDJIEEB@DFBEBDBHIDHEMJFJJENOOEKEBCDBDKKLEABJBDDADM@EB@HCCJMAAB@IBABB@IBAA@J@JBBHBHDDBDHBBDBDHBDDEJNF@HBE@EIDAABBJDEANNIBAFBEFMGOKMBJKBMM@IDHJABEBCA@BEEDJIBJLMEBJIBJ@JHECBDGOEBENICBBHBE@HHMCCBFEB@JEEEFH@@" "NFNJMKDHDDHHHEBEHDI@HHI@BEKJFNHJHEEIFAEDDJHDDEIAAEBDKIHJHHIBBBBBKKMMLBJCIENFMMNKDKDMBHJE@HIADA@E@EECFNE@JLDMDDD@HBBDJJEAFDMICDEBJIBB@HAAAEIAJHECKFEE@E@DADDHHEBHJEIFIFKMMKCMDNBJAMMNNJBBBBDHHJHLNIBEDDDMAA@JIAEDCDME@JHKKBNMB@DHHHDI@MBE@HHIA@IFMJKKCH@@" "KMEECDKCAABEC@DHABBBBBDOMHAEMJEJBIBJ@LHAJIAEADDDB@DI@BEDCABEDDHDJJJKJIDKNJGAMKODIDMBMB@HBBBD@JD@BDDDM@HEEAEAA@HJBDHI@DHFAIBDLC@I@DHIBBHHDDEDEE@HEIAAB@ABHABBB@HBEJEIDIGNMLGBKNIDJNJJJI@IAEBDFAEB@DI@BAAADEDDJL@IHBJDJBMBMMD@MOIBBBBBD@I@FEBDDFFIFEEENH@@" "NJHADIFLNNDIDEIABDHDHIA@JECJKEKELBEIBACJBBBJEAAADOIBFIA@HFDH@JBI@AEODBJBKHHFIFJOJCKJJDKBLDDIABHMDIABJEEJJFDJDAA@HHBBEABHDBEBA@JDEBB@HHDDABICBJMEBJDDIEHJDDIAAJFIBJNNBOJKDK@HNJBJAGMD@DJBH@IC@HDDKBDOIDDDEBJBBBNDBDMBAMFMFJNEBHDDHI@IBDDMADICKIKDID@JKH@@" "AOGOEA@CAAABBJBJEABJBBJKDHDE@OJJ@HJFDJDBHIDHJJJJA@BDHBJEBHIEDHJBJMFEMMMENCEACKOEEDMEKI@DA@IBFDA@ABDGDIBAEHJDIBBBB@HHHFDDKDJIFIAC@HHHBBBBDIBHMDBDIGABD@DACBDHDA@DNMEIEEGNNDEFCMEMMMCEJJBHIEDHJEBJ@IB@DBJJJHIDHJABICBHHBJOHEA@IFJJBBJDEBJBJBDDDF@DEGOGL@@@" "JEJJKOGLFNMEDHH@HBD@DK@BKKIBIEFKGEFIJHIEEBEBDDB@MEDIEDEBJEDHEEEFKFHJKBDALMBLHEJNOJBBFLEBJCBE@JJDJJMKEBDJNEDIDDDDHEAAA@IA@EEE@DDHDDDE@IAAADIECJIBEFMJJIBJHEBFBJEAKBBBOKJM@IJEILABFJHKFKEEE@IEBJEAEDIEEHBAABEBEEDHJLKEGFKEDJDNNJ@FI@AB@H@HIEEKKAOGNJJMBH@@" "GMEADDJCMIEDICBJBDIDHHDI@JGDBJMJH@IBIBCBIE@HIIEE@JJKABJDDJABHHIEFHBDNDIBKBMABJOHBNMDIADJ@DDHE@@IJJJDDEIEMBAFA@HHA@BJBEBDBJJJJABEBBJ@D@HHDCDBEMDMAABJJLH@E@IA@BIDDIEKJ@OJJDEJFJDICIB@KEDHHJDBIABJDFJJHEEDLHHEDJFBDJDH@JMJJAGBHDI@HIDIBBJFDIEDMNBIADEEO@@@" "HBKFBIDLBFJKFDDHLIBABBIAGDHJDAFJJJFJNDLJBBEBJBDHJIA@FDJJIHLHJGFIAMNIDMBEDMANIEMDKEJJBIA@JJIBDIECECECBHBIFDJHJEABJEDIDJDIDJEBIDIBIDIEBJDEBHJICDJ@JFEFEFEDIBDJJHDDJBJMFIEMDKLEIEBEIDKMLDKGBHIHLJJIC@DDJHIBBJEBBBIICJKBJJKDABHIGDDJBDBDIHIACFJKBAIDJCFJ@H@@" "GOMIMDAADIED@JJAABHB@HJNHJE@JJJLHEHHKAAADHIDIDIBADFE@IBBDBAA@MJBEKBJI@DHIFKFNEEIDIGEFBEFDECDJBHF@DHDDJIBLIBE@HB@@@ABAAABEDJIEBDDDBD@@@B@HEBDIJDJIA@I@C@JBIFEACEBCEGDIDMECKFKDHI@DJJFMBBMHDDBABBDHECADBDIDIDHIDDDFHHM@IJJJHEBHKJHHB@JDDBJHAEDIDDAELMOO@@@" "MDBGFKNJBDBBNHDNBDBDEEAACDHI@@KKFJFEFJJJEGBADAEDNJIAEDEDJHJJIBDDIFMJODKCBINMKMNBKBHEELI@ILDADJEJJIBJIADFIBDJJBDFJJJIBDJDHJEBHIBIBDJJJKABBJIBDKADDJJDJJMBIDAALHDIME@JFJCMNMKLJFFIGJMKDIABDJJHJIEAEDDJKIEDADBGEBJJKECBKFNH@DHIFDDEEABABCI@KJBABBKNKGBAEH@@" "EKMHIE@MLKDH@BI@HIDID@JDDICBEBIFMFJIII@BI@DJABJA@IDJDIDE@KABBIBKBEEEKIHMLFCJNKIMDEGJKIBEEEIDAEMFBBJBBDDIBFED@HJH@@ADDJAEBDMIBEDBIAD@@@JHHAECBDIABBBJBCEMDADMEEBDNJOEAELNKJNCAMHLNMEEBFJDJBDFHEADIBIDHDBJDBI@DJ@DLLJKEKDJEBFDIABHADIDHHDJ@@IFIMHEDHMNM@@@" "OECGFNOFCHIBMLDICBAB@J@IABDMHELK@IFBFNEMFFIEBFDJECC@IBA@EHFDMBHBMOKEGGCJOKOEEOGFKI@BOFEBJHBENMBHJJHHDIIFDHLIIB@BJJDBIDJDDI@DIABIDJABJJ@BDLIHICDLI@HJJHJEKMB@JJECGJ@DNKGGMEGNOJNGGEFOMJ@JEIC@M@DBDHFFEBICBEDKCEMCKBCDHFIM@MIBDDHBHBDBFDIAMJDHNCGKKGFEGH@@" "NKNLIAEALBBEBAJBHDJEEDJBJDIBEKEJOJIDMDJBIIEDFHIDIDDEBHJJJBHI@DGOJOFNJLNOMNODKEBMFNMEBHHOECDEEEDBDDBCIDBEEEAFB@HH@@EDBIDJIFECDJIDJAE@@@HHBCDEEEBADNBAABAEEEAFEGHHJEEKKEJEFIGKMOKIJKKGJOOA@DHJBJJHJEAADIDHKAEDLJBIEIDJOJMFMBDIBJBIEEBI@JBLBEBBALEDDIKNKH@@" "MNEKGNFNABJHIDADBIDH@AAL@IBJJ@JEJMFIBKHJFBBHHEDABAIBECB@HJBDJJLNOJKIOKIMGEMMHOMFMKEFJECDJHIOBJAEAADLBAHMDJJHHJCEBDHHDDI@BM@EJ@DIA@HIBEFBHHJJIEHLBAIDDEDBJGLHJIFEBKEFMKEOHMMMGELNOLNJOKIJJIBBHHBFEBDLBDAE@HJBCBHNJDKEJMBHBJJDHALD@@IDJADADHJJDCKCOFMCMH@@" "KFJJMEMEONDBFIEADJABIDDAEBIEHMDIGEIEEJKFJIMCEBKJILBDJDDKBEEJDHIAJOLFBBGCENOKCEJIFJMEDLFKDGFBDDJHDJEAEFCBEDABB@H@DIJEIBBFMBGBEKBBDMBLI@@HBBDAEBFCEDEBI@JIABCGAFKAIEEJKDJMFFOKMFGBBCAOJLDHIBMEBFIABIBALJNJEFELJKFJMEDMGDIEHMDJEDAADJDBIDEDKBACOMEMEJJKFH@@" "EMEEBBBEBAIFHBBFEDJDBBJJ@DBBCBEBJOFIEELJJKADJEHDBAHIDIADEHIEIBFEGJJIEMMNFMJNDOEGMKBJMIJLKJMOJIBBI@DJHHHMHIJDHJBDIBA@BDLI@LHIHDIIB@DBDIBBHIBLHMHHHJI@DJBDJOMJNIJLMJJFMOEGICJMKCMMMDJJOECBDMDHMADDIDHLBA@MBIDFJJIMEDKGJJEBFBBA@BJJBABIECBB@KDLBEBBBEEEM@@@" "KGOJMONLMNBIEMDHHIDHHHDIFJHLLDHDCMMJJKGEE@NKDJGKDJEBIBFIABJJBDHIDEIBEGBLMMGEJMIABEMEKGGOEEBEDDIEBJJBBBBBEB@IBADIBDIEDIBBEBGBEBBDIEDIBDIDBDHBEBBBBBBJJEDIAEBEEGOGFMEMBDDMJMGEMIJGEBDMADHIBBJJDDKBDJEBIFOBIFKHEEGFJJMMNA@IAIHJKDI@HHIDHHIEMDJCMIKOMJOOFH@@" "NMNOKDEGKEOFJ@IBBBAEBFIB@ICACEJIJKEFFLNJJKADIEJDIBJFFLHJFDIEDIBDIJDEJHGIJKKGEKJJOMBJLMKDJJIEIBD@DBDMDLMMJJKBDDABDIBAADIEBMEEJEDIDDBDIBDAABFJJMMIIEIBA@ABDMDJJIFMIJJEOJJNMGFNJLO@JMABLIBDIEDICBHIKCBJDIBMDIDFJJKIKCEFJLJMFDFDHBDKBEDBBBDHBKGMFOEAFOKMKH@@" "IGOIFOEHFMDMDJBFLME@E@DIEDDDLJEDAGNHKKFJEDEEBJEKBDDHLAEAHIBJIBDIBEJEEEJOFODJJGEE@CLMKKBMDIBBEDIJIDIBEADBE@DE@IBDIBHJFADDDBJJAAADCBHJDIBDHEA@EBADEBDIDJLIEBBDIEJFNMIN@EEGBJIGKGJMEEBMBDIBDJJDHLEDAHIABFMBJEEAEBKFNHKODAEBIIAAEDI@E@EEIKBBIEIEK@MGKDOODH@@" "GMMGMHNGEDMJIDLHA@BDHFIDDJJJAEJJJKDNEEEMBJJJEEFDDHJBJNDNEEDEFHIJIMEMGKGOMEIJJNJJMHKGEDKDIBDLICBEEBDLJJIJJE@HIBDMBDCA@JBIIMEELLJBHDFABEIBDHHEBJLJJIIBEEBFDIIBDIFIEGFHMJJKJJLMEOOFOEMELJLHKEAEECICJJBHIACEEBJJJEMEECIFJJJMDBJJIADK@IB@D@IIDJMIEGCHMOEMO@@@" "EFOMJGEJNKJMDIABJJLIBHJAAABEJMBHHEOEGJOJMBJJJBHIECHIA@I@JJJJMCBEBCDBHDMAFKFEEEEBJEBLJI@IBDIBDHEDBIAADEFEDJKJBDM@DIDDJDHJBBJJBBHIBIADI@EIBBNJIECEADDDJAE@IBDIBDHDJIJEBJEEEECFKDEI@JAFBEBFEJJJJHDHDDHNEDHJBJJJEJOJOEGM@HJEJMBDDDBHJDIJJJDDIEJNKJMGBMOKE@@@" "JIMKDMJMEECKJJDDIBABDJ@JFFDJEBMGJJMNEMMOEMFJHJEEADEBJEJEDIDJIDDJEFIDEAEOIFIJJKENEJICABGBDIBDKBLIJJFNJJJJKEDEDJ@DIBJJDIEAIJHJLLEDIBJJDI@BIEAEFJJJJKKBJLIJFIBDIBGBDFDJMCMFJJLKDOMDEADKEBIADJIDIEBMBJEADEEBHJKEMGMMMCMJJOEJEBICCBHBIBDBDIABJNNEEEJMIFMLJH@@" "JOGOKJEEFJNFBDJIDDJDIAEBHHIKJE@IDIODOKKFKBJMBJJJDBJEED@HIBAEFEE@HIBIBFKBBDJIBJBAJEDFLDHDIBDI@ECBEDIABJMEDJJHBIEIBD@@IB@DBEEEBA@BDH@ABDMDJ@JJIEEJJDDIEBFE@DIBDI@IAKAEBLBBJDJIBBFKBDJDHHEECEDBDHHAEEBJABJJJEJJFKFNOIGLIDHEBNLHHJEDDIBIADJIBCCJKEEBNOOGJH@@" "EIMMEKOMMIALHI@CBIDIBLDDEBBFBIGNJBEOKFNODMFJEDEEIDHJJBJBBDNMIDHEBBHBDHBMEEGFMEEJJHJHJIFJEDIFJMDDHIBEFEBJKJEEEBDBDIDJJDJMEBBBEEJIBJIDIBABEEEBNJJECEBDHIAEJKDIEBKDJHJHJJMEEKGEEEJ@IB@JBE@IDMKIBBBJBJHIDMEAEBKEIGKKFOMBBKODJCBBEAAAJDIDJF@DHILDMMONMEMLM@@@" "JGGKOFJKBNOCJDJHDJBDJAHIBEEGMBBIEDKJFLMFKBIEJJJFCBKDHMEDHIACFKBJEJCDJEBJHJHIEBJFJBEGEBA@HBK@BBEBCBFJ@JMEBIJJHDIDIBABBIBABLMIJDBDJBDBDIDI@JJLJEEJHBKBFBEBB@FJ@HDBEGEBBKBJEDHJHJJEBIFBMBJFKFDDHIEEHIFJFCBJJMDJFKEIKBNIEDJBEOEEBDHLBIBBI@JIBNGKJFJKGNOGBH@@" "HIINKMOMOEDNGJHJIAIABJCCDJDDBDMEFMFOMMJKFIEEEEEDLEDIEBBAJJDLILEDLFLAABFBEEEEEFEIELHHIDJEBI@EDLHIDDHHOBBJMBFBBIBBBDJHLJDJEE@EEBIBIHJIBBBDJBCBEJJBGHHIADHIIE@DJEBIDHHIMDMCEEEEEBCBDDAKAIEALIIBJLBBEDIEAIEEEEEDKFJMMOKEKEEIBAABIFFBJDDLDJHJOCIEGMOMNKLLHH@@" "EECENEBBJMKKLEC@JDBDDDHDBHJIEBAE@IENGJEELFJJJJJIABIBJDJJ@HJABBJAAEADDDHNJJJJMDJEFCCCBEDHDJFJBABDIIGE@FLEAEHMDDDIEE@EB@IDJJJJJIDHBE@EEDIAAEHMDEAK@EGDLIBDBBKBI@IEBFFFCEBIEJJJJKHIAADEDDBJBDBHHBJIBJDJDDJJJJJKAMEBOCMDHEDBEDJHJA@IAABABHFEANNMJJBECMFEE@@@" "DBLOKKOOKJMFKJDE@IDJIAFIECABJDNJOJJONKJKIIEBKFEEFJBMDIDEEFHJDHHJDHJAJME@IICACKDJMDLDDHICIA@DHJEIBBH@BIBJJJC@IIID@@EHIEJBEDEAEBBMDHM@@ADLLHFBJJJDJ@@JBDMBHI@DDNDHIAAIEJIFNDFDLHEEJLBHIBHHIBHKEEADIEJBKEECFJEDLNJNKOJJOJKIBJDFEDKDDJIDHEABNKEJNOONNOIJA@@@" "JMGEGFIJNKGMOFJHECAABE@EBDLEDMAEEGEMMNFJNBJOFIJHHDJBIBIDI@EDIEEDIBDJBABEBFDNHDEJJEBIABBDBDJICDJBEEBKMEEEFHHGBBBADLHBDHADICEFDID@IB@IIDBBBG@HKEEEENJEEBBIFDJIBABBDDJEBJMA@KICBEBDBBIBDIEEDIE@DIDJDJBI@HJLKGJJCJKCMMMGEEDEIEAIBE@EBDDFE@JKGMOFKJLKGEGEJH@@" "EALENOOGIMMGMMEBIDBDDJFHHIBJK@ODJHOGGKIEMEEEMGEECEELJMBKBEDIBDIABDMADJHJDKIAECJIBHJBFDHKDJDJDMDLJIEDCBJJIEBHDHIDAAIEBCDBBDJIBBAFBEDLDADHI@JEDJJJFAEDJIIEIBIBIFHICBBHJDJNEDDNIBHJIDEIBDDIBDIEBFJEJIMEFEEGEMEEEMDNOGGHJIGHFJJDHHKBIABADJEEMOEMLOGOKMALE@@@" "NNJKGLJIFKGJKBEEBBLJIDHBKBICDEDIMGDJMOGJJJJJJJJHLJJBIBIDDIBBDIBFHIDDIBIDIDBJEDEKFBIDHIBFIDIDK@AAEBBIDEEEBBDKABDADJBHHHBLMAEDEIJ@HHJBIDABDFIBBEEEADJBEDD@FIDIDKBDHIDJCFMAEBJADIDJDIADHKBDIBBDIADJDJBJIHJJJJJJJJOGMJIGELIEAFDJFJ@IDJIJBEEBFJOFKDJIOFJKKH@@" "IEEDKGMFIJJGGEJJLIA@JIEEDJDDJIOCCEOEOLMEOEDKOBJKBEEEEDJIEBHLIJDHJEBIBECEBADACEBH@IBEBBDMJIBIDKNJKDJJKJIEEDJDJDHJ@HHBEJJABEEEBDBJMB@HHBHIBIBIEEDJNJJIFJKNIDJDJMIBBEBDH@JEFDADBEFEBDJEBHIBLIHJEDJIEEEEBFJJGNIEGMEIOMGMFFGLJIABIEEDJHDDIJJMGGBJLKEOFIEEDH@@" "BHJIBDEDFBEHHDABABDE@BBJEAKEABHDDJEKKOOKFJKFLOEDEJBEDKEFJECABBMBEDEBDJDBDJEFDJIBKBDHDNIKDBEDIDAADIEEFEBJJEDK@ICDECCDH@HJIJBBLJHH@IFFEAFDHFIEBJJECEEDIDDADIEBAFLKI@IBFJDJICEBIBABIBEAEBEJBDFEBKEFIEBBMAEGIKFJKFOONNMBIA@JDEFLEBJB@EABDBDA@HMBCAEABDJHJ@@@" "EBDBDIHJIDJBBIBDJEAJEDM@IFDIFEFJJEFKGMEEMMDMIJKJJBLJIDJIDJDFED@JHA@EIDIEADHHIEJDHJIBI@DBIEDABJNFKEDJIJJJJIEEEEDBIDDABKCDFAEDCAFFJDAADJAEEEEDJJJJLJIEFKCJJDAEDJA@DJDJHIBMDHHIDEDIDM@D@JHAECABIDJIDJIJBJNJLMIEMMEEOFKEBJKECDICDHEIEBLEBIBDJBBIDJHLIBABE@@@" "JDHLJJCADA@IDJFI@JJ@HA@EBHIDHJIBDHMNNOOKGEGGGCJAAMBJKBDJI@I@IBK@EBGDBIBBFABBEB@IBDCFBEAEBDAODI@HFJBJFKEEEFJJI@BHJAAFDHDBHJEBHJA@ICDDBHJ@DJJKEEEFKBJBK@HDIGLABEDEBCFABDHBEBBDCBBDJAGBE@FJDHDHDJIBFJJELDBNGGGEGFOOKKMHIBDJHIDHJE@D@HBJHDKBIDHDADFBJIHIBH@@" "DIAA@@HFBJJBA@HEE@@EAFJJMEEAEDBDHKB@IEBDEHHJLMENFBJEDMKFCGBNJDHGBDHIEBDLHLDLJHJJEAD@HJJJIBJ@AJMBMEEDIFJJJIBJBFLE@JE@IBIDEIJLMADJDHEBHEAKBBJDJJJKDIEEEJEJL@BJDJJJHHADEBJHJIIAHIIBEDHIBG@IBKJGFCFMIEBJCCMEIJHHMABEDHBFHIBAEDEEEJJKDE@@EE@HDBBJJC@H@DDDI@@@" "ABBJFIBHH@@JJIC@@EE@B@@@@@@B@EDIE@DJDDMILEBBAAB@HJDHIBDID@FAHIBHDIBBDDIAB@IADEDDIBEEEDBJBDAMD@BMBIBKFKDEEEEEE@A@EDHEBDJEHBEB@MBIBE@IE@D@EEEEEEAFKFJDJEJ@AELABBJAEEEBDIAEADDHBDDIABBDI@JDHLC@ADIBDHIBHHBDDBBEALMIABI@EDIE@B@@@@@@B@EE@@FDJJH@@HJDKBJBD@@@" "EDD@HBFBJFJ@BBDDJH@FDEEKDJIDI@EBHFIEAE@BAEDLJJEEEIABJHJBHJHLCBEBJBDLIIBDDKJJIJBIBFIBAABHJIGBIEI@LJDDIEEKFJLJDDJFJACJDI@HCDHIF@HDIBNDBKBIABIJKFMEDIABIHDMDJGDJHJDDBDKBDJBLJJNIABDLIIBBJEBFAHJHJBHJJDDMEEBJIIEDB@EDEDK@JE@DIDJIFMEAC@@JIABB@BKBJCB@HAAE@@@" "JBIBAE@D@H@JHLJI@DI@E@@@A@BABJHHBHD@B@BHI@AADHHDDBFE@B@JAAEADDHD@HIADBDJI@@IBDHBDHDDJFFBIBHDBDBGCEKGGFJFIACDIIDHDJDAEBEEDEBEAEEBEDABI@IDLIFDDKBKGGFMFGBABA@JDJCCBIA@IB@IBDH@DJIBADDHHA@IADEDDBHB@ECBAA@HIDD@DHJ@B@A@J@HJJDB@D@@@E@DI@DJIHJH@HA@EDBDJBH@@" "ADBDB@DJMAE@EAABEABDHDJEDEDJDBBADE@JDJDCBEFDIBJIADHHEDJDJDBDAABJJBBDIDIDJEEBEABDICBI@HHIBIBMDIDHDDDHHIDIBJLIFBIBIBJJHFJDIHE@LIBK@JJJDJDJCDIJJDIDHHIAA@IDIEJDJDHHHDJFDIBDEBEEBIDIDIBBBJJDDABABIBIE@HIDDJJDICEBFABIBHEADBBABIEAEBI@IBDEBDDE@EDEJI@BABAD@@@" "JIDIDJHI@IBEIDFE@DDIBI@H@I@HIDIBI@E@I@IDDI@IBE@JJIBEHI@I@IDIBJI@DHDIBIBI@HBDHJHIBDDDIBEBEBE@IBIBJIBEBDIBEEBJHHBEBDDEBHDJEBHJEBI@JEAABEB@HJJEEBDIBEBDJJDJDHEBEBEBDIAABDHJHIB@HDJDJDI@I@DJJDIDHDHDHMBDJJHEBDHDIADHDHE@DJDIDHHDH@HDJDIA@ECADMBDHDHJIDIDJH@@" "BBEBEBEBEBIBBBIBEBIBEBEBEBEBBEBEBEBEBEBBIBEBEBEBBBEBBBEBEBBBEBBEABIBIBEBEBIBEBBBEBIBBEBEBEBEBEBEBBIBEBBEBBEBEBEBEBIBEBIABEBEBDDJEBDJEBEBEBEBBEBBEBDJBEBEBEBEBEBEBBDJEBBBEBDJEBEBDJDJDEBBEBBBEBEBBBEBBBEBEBEBDJBEBEBEBEBEBBEBEBEBEBDJEBDJBBDJEBEBEBEBB@@@")} \ No newline at end of file diff --git a/lispusers/BACKGROUND-RHINE.PRESS b/lispusers/BACKGROUND-RHINE.PRESS new file mode 100644 index 00000000..26eb5732 Binary files /dev/null and b/lispusers/BACKGROUND-RHINE.PRESS differ diff --git a/lispusers/BACKGROUND-STEINHEIM.PRESS b/lispusers/BACKGROUND-STEINHEIM.PRESS new file mode 100644 index 00000000..971e457e Binary files /dev/null and b/lispusers/BACKGROUND-STEINHEIM.PRESS differ diff --git a/lispusers/BACKGROUND-TIFFANY.PRESS b/lispusers/BACKGROUND-TIFFANY.PRESS new file mode 100644 index 00000000..4fd0e761 Binary files /dev/null and b/lispusers/BACKGROUND-TIFFANY.PRESS differ diff --git a/lispusers/BACKGROUND-moonwithstars.press b/lispusers/BACKGROUND-moonwithstars.press new file mode 100644 index 00000000..e0944497 Binary files /dev/null and b/lispusers/BACKGROUND-moonwithstars.press differ diff --git a/lispusers/BACKGROUND-parc.PRESS b/lispusers/BACKGROUND-parc.PRESS new file mode 100644 index 00000000..7fa19fce Binary files /dev/null and b/lispusers/BACKGROUND-parc.PRESS differ diff --git a/lispusers/BACKGROUND-twodollar.PRESS b/lispusers/BACKGROUND-twodollar.PRESS new file mode 100644 index 00000000..1b898051 Binary files /dev/null and b/lispusers/BACKGROUND-twodollar.PRESS differ diff --git a/lispusers/BACKGROUNDIMAGES b/lispusers/BACKGROUNDIMAGES new file mode 100644 index 00000000..dfa133bf --- /dev/null +++ b/lispusers/BACKGROUNDIMAGES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED " 2-Mar-87 16:07:23" {ERIS}LYRIC>BACKGROUNDIMAGES.;6 17437 changes to%: (FNS BACKGROUND.SETUP) (VARS BACKGROUNDIMAGESCOMS) previous date%: "11-Feb-87 21:26:26" {ERIS}LYRIC>BACKGROUNDIMAGES.;5) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BACKGROUNDIMAGESCOMS) (RPAQQ BACKGROUNDIMAGESCOMS [ (* ;;; "Enables you to load interesting backgrounds. Simplest entry is just to call (BACKGROUND.SETUP).") (FNS BACKGROUND.SETUP BACKGROUND.FILES BACKGROUND.FILE BACKGROUND.FETCH BACKGROUND.SHORTNAME BACKGROUND.MODE BACKGROUND.SHADE) (FNS BACKGROUND.CENTER BACKGROUND.REFLECT BACKGROUND.TILE BACKGROUND.LESS) (INITVARS (BACKGROUNDS NIL) (BACKGROUND.MODE 'CENTER) (BACKGROUND.SHADE 34850)) (GLOBALVARS BACKGROUNDS BackgroundMenuCommands LISPUSERSDIRECTORIES BACKGROUND.MODE BACKGROUND.SHADE) [ADDVARS (GAINSPACEFORMS ((LISTP BACKGROUNDS) "Delete saved background bitmaps" (SETQ BACKGROUNDS NIL] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;;; "Enables you to load interesting backgrounds. Simplest entry is just to call (BACKGROUND.SETUP).") (DEFINEQ (BACKGROUND.SETUP [LAMBDA (NAMES) (* ; "Edited 2-Mar-87 15:57 by Stansbury") (* ;;; "Background decoration. Puts stuff on the background menu that will let you stick up fun backgrounds on the screen.") (LET [(IMAGES (if (LISTP NAMES) then NAMES else (BACKGROUND.FILES NAMES] (if (LISTP IMAGES) then (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) BACKGROUNDMENU) (BkgMenu.remove.item 'Background) [BkgMenu.add.item `(Background '(CHANGEBACKGROUND BACKGROUND.SHADE) "Change background" (SUBITEMS [Change '(CHANGEBACKGROUND BACKGROUND.SHADE) "Change background" ,(CONS 'SUBITEMS (for IMAGE in IMAGES collect (LET ((NAME (if (LISTP IMAGE) then (CAR IMAGE) else IMAGE)) (FILENAME (if (LISTP IMAGE) then (CDR IMAGE) else NIL))) (LIST NAME `'(BACKGROUND.FETCH (QUOTE %, NAME) (QUOTE %, FILENAME) BACKGROUND.MODE) (CONCAT "Change background to " NAME] [Mode '(PROMPTPRINT (BACKGROUND.MODE)) "Change mode of applying background images" (SUBITEMS [Center '(BACKGROUND.MODE 'CENTER] [Tile '(BACKGROUND.MODE 'TILE] (Reflect '(BACKGROUND.MODE 'REFLECT] (Shade '(BACKGROUND.SHADE (EDITSHADE BACKGROUND.SHADE)) "Change the default background shade"] (BkgMenu.fixup) T else NIL]) (BACKGROUND.FILES [LAMBDA (WHICH) (* ; "Edited 11-Feb-87 20:29 by Stansbury") (* ;;; "Returns a list of names of press files which contain background-sized images") (for filename in [SELECTQ WHICH (T (* ;; "Find all images on all lispusersdirectories") (for DIR in LISPUSERSDIRECTORIES bind IMAGES first (SETQ IMAGES NIL) do (for image in (APPEND (FILDIR (PACK* DIR "background-*.bitmap")) (FILDIR (PACK* DIR "background-*.press"))) do (pushnew IMAGES image)) finally (RETURN (SORT IMAGES)))) (PROGN (* ;; "Find just the clump of images on the first lispusersdirectory that has any images on it. (Useful because usually images will be on just one lispusersdirectory.)") (for DIR in LISPUSERSDIRECTORIES do (LET [(images (APPEND (FILDIR (PACK* DIR "background-*.bitmap")) (FILDIR (PACK* DIR "background-*.press"] (if (LISTP images) then (RETURN images] collect (CONS (BACKGROUND.SHORTNAME filename ) filename]) (BACKGROUND.FILE [LAMBDA (NAME) (* ; "Edited 11-Feb-87 20:29 by Stansbury") (* ;;; "Finds the file containing a press encoding of the named background.") (for DIR in LISPUSERSDIRECTORIES do (LET ((BITMAP.FILENAME (PACKFILENAME 'DIRECTORY DIR 'NAME (CONCAT "background-" NAME) 'EXTENSION "bitmap")) (PRESS.FILENAME (PACKFILENAME 'DIRECTORY DIR 'NAME (CONCAT "background-" NAME) 'EXTENSION "press"))) (if (INFILEP BITMAP.FILENAME) then (RETURN BITMAP.FILENAME) elseif (INFILEP PRESS.FILENAME) then (RETURN PRESS.FILENAME]) (BACKGROUND.FETCH [LAMBDA (NAME FILENAME MODE) (* ; "Edited 11-Feb-87 20:30 by Stansbury") (* ;;; "Puts up the specified background. If it is cached, just grabs it off the cache; else reads the press file off the server, translates it into a bitmap, slams it up, and caches it.") (LET ((BITMAP (LISTGET BACKGROUNDS NAME))) [if (NOT (BITMAPP BITMAP)) then (* ;; "Find background: either off a Lisp bitmap file, or off an old Press file") (CLRPROMPT) (PRINTOUT PROMPTWINDOW "Fetching background " NAME " ... ") (if (NULL FILENAME) then (SETQ FILENAME (BACKGROUND.FILE NAME))) (if (OR (NULL FILENAME) (NOT (INFILEP FILENAME))) then (PROMPTPRINT "Background " FILENAME " not available.") else (if (PRESSFILEP FILENAME) then (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) BITMAPFNS) (SETQ BITMAP (READPRESS FILENAME)) else (LET [(STREAM (OPENSTREAM FILENAME 'INPUT] (SETQ BITMAP (HREAD STREAM)) (CLOSEF STREAM))) (PRINTOUT PROMPTWINDOW "done." T) (* ;; "Cache it (before modifying it)") (if (LISTP BACKGROUNDS) then (LISTPUT BACKGROUNDS NAME BITMAP) else (SETQ BACKGROUNDS (LIST NAME BITMAP] (* ;; "Adjust bitmap and apply to background of screen") (PRINTOUT PROMPTWINDOW "Adjusting background ... ") (SETQ BITMAP (SELECTQ MODE (TILE (BACKGROUND.TILE BITMAP)) (REFLECT (BACKGROUND.REFLECT BITMAP)) ((NIL CENTER) (BACKGROUND.CENTER BITMAP)) (\ILLEGAL.ARG MODE))) (CHANGEBACKGROUND BITMAP) (PRINTOUT PROMPTWINDOW "done." T) BITMAP]) (BACKGROUND.SHORTNAME [LAMBDA (IMAGE) (* ; "Edited 11-Feb-87 20:30 by Stansbury") (* ;;; "Parses the IMAGE file name to find the short name of a background. IMAGE file names are of the form {server}SHORTNAME-background.press") (MKATOM (L-CASE (LET [(LONGNAME (FILENAMEFIELD IMAGE 'NAME] (SUBSTRING LONGNAME (LET ((start (STRPOS "-" LONGNAME))) (if (FIXP start) then (ADD1 start) else start)) NIL)) T]) (BACKGROUND.MODE [LAMBDA (NEWVAL) (* ; "Edited 11-Feb-87 20:42 by Stansbury") (* ;;; "Finds the value of or resets the background image applying mode.") (if (NULL NEWVAL) then BACKGROUND.MODE else (SELECTQ NEWVAL ((CENTER TILE REFLECT) (PROG1 BACKGROUND.MODE (SETQ BACKGROUND.MODE NEWVAL))) (\ILLEGAL.ARG NEWVAL]) (BACKGROUND.SHADE [LAMBDA (NEW-SHADE) (* ; "Edited 11-Feb-87 21:26 by Stansbury") (* ;;; "returns the old value of the default background shade. Also, if new-shade is a texture, makes it be the new default background shade.") (if (NULL NEW-SHADE) then BACKGROUND.SHADE elseif (TEXTUREP NEW-SHADE) then (PROG1 BACKGROUND.SHADE (SETQ BACKGROUND.SHADE NEW-SHADE)) else (\ILLEGAL.ARG NEW-SHADE]) ) (DEFINEQ (BACKGROUND.CENTER [LAMBDA (BITMAP) (* ; "Edited 11-Feb-87 21:12 by Stansbury") (* ;;; "Returns a new bitmap the size of the screen which has the argument bitmap centered in it and a gray border. This will center the bitmap on the screen, regardless of the screen size.") (LET ((NEWBITMAP (BITMAPCREATE SCREENWIDTH SCREENHEIGHT 1)) (X (QUOTIENT (DIFFERENCE SCREENWIDTH (BITMAPWIDTH BITMAP)) 2)) (Y (QUOTIENT (DIFFERENCE SCREENHEIGHT (BITMAPHEIGHT BITMAP)) 2))) (BLTSHADE BACKGROUND.SHADE NEWBITMAP) (BITBLT BITMAP 1 1 NEWBITMAP X Y) NEWBITMAP]) (BACKGROUND.REFLECT [LAMBDA (BITMAP) (* ; "Edited 11-Feb-87 20:56 by Stansbury") (* ;;; "Centers BITMAP on a screen-sized bitmap and tiles the remaining space with reflections of BITMAP") (LET* ((WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP)) (MAXWIDTH (TIMES 3 WIDTH)) (MAXHEIGHT (TIMES 2 HEIGHT)) (TOO.SMALL (OR (GREATERP SCREENWIDTH MAXWIDTH) (GREATERP SCREENHEIGHT MAXHEIGHT))) (NEWBITMAP (BITMAPCREATE (if TOO.SMALL then MAXWIDTH else SCREENWIDTH) (if TOO.SMALL then MAXHEIGHT else SCREENHEIGHT) 1)) (X (IQUOTIENT (DIFFERENCE (BITMAPWIDTH NEWBITMAP) WIDTH) 2)) (Y (if (GREATERP HEIGHT (BITMAPHEIGHT NEWBITMAP)) then (IQUOTIENT (DIFFERENCE (BITMAPHEIGHT NEWBITMAP) HEIGHT) 2) else 0))) (* ;; "Stick original bitmap in middle") (BITBLT BITMAP NIL NIL NEWBITMAP X Y) (if (OR (GREATERP SCREENWIDTH WIDTH) (GREATERP SCREENHEIGHT HEIGHT)) then (* ;; "Build reflections") (LET ((HORIZ (BITMAPCREATE WIDTH HEIGHT 1)) (VERT (BITMAPCREATE WIDTH HEIGHT 1)) (HORIZ.VERT (BITMAPCREATE WIDTH HEIGHT 1))) (for I from 0 to (SUB1 WIDTH) do (BITBLT BITMAP I 0 HORIZ (DIFFERENCE (SUB1 WIDTH) I) 0 1 HEIGHT)) (for I from 0 to (SUB1 HEIGHT) do (BITBLT BITMAP 0 I VERT 0 (DIFFERENCE (SUB1 HEIGHT) I) WIDTH 1)) (for I from 0 to (SUB1 HEIGHT) do (BITBLT HORIZ 0 I HORIZ.VERT 0 (DIFFERENCE (SUB1 HEIGHT) I) WIDTH 1)) (* ;; "Upper left hand corner") (BITBLT HORIZ.VERT NIL NIL NEWBITMAP (DIFFERENCE X WIDTH) (PLUS Y HEIGHT)) (* ;; "Above, center") (BITBLT VERT NIL NIL NEWBITMAP X (PLUS Y HEIGHT)) (* ;; "Upper right hand corner") (BITBLT HORIZ.VERT NIL NIL NEWBITMAP (PLUS X WIDTH) (PLUS Y HEIGHT)) (* ;; "left") (BITBLT HORIZ NIL NIL NEWBITMAP (DIFFERENCE X WIDTH) Y) (* ;; "Right") (BITBLT HORIZ NIL NIL NEWBITMAP (PLUS X WIDTH) Y) (* ;;  "If resulting reflected bitmap is still too small, recurse till it gets as big as the screen.") (if TOO.SMALL then (BACKGROUND.REFLECT NEWBITMAP) else NEWBITMAP)) else NEWBITMAP]) (BACKGROUND.TILE [LAMBDA (BITMAP) (* hts%: " 1-Apr-86 18:13") (bind (NEWBITMAP _ (BITMAPCREATE SCREENWIDTH SCREENHEIGHT 1)) for LEFT from (BACKGROUND.LESS SCREENWIDTH (BITMAPWIDTH BITMAP)) by (BITMAPWIDTH BITMAP) to SCREENWIDTH do (for BOTTOM from (if (GREATERP (BITMAPHEIGHT BITMAP) SCREENHEIGHT) then (BACKGROUND.LESS SCREENHEIGHT (BITMAPHEIGHT BITMAP)) else 0) by (BITMAPHEIGHT BITMAP) to SCREENHEIGHT do (BITBLT BITMAP NIL NIL NEWBITMAP LEFT BOTTOM)) finally (RETURN NEWBITMAP]) (BACKGROUND.LESS [LAMBDA (BOXSIZE IMAGESIZE) (* ; "Edited 11-Feb-87 20:56 by Stansbury") (* ;;; "Tells where you have to start drawing to end up with a centered, tiled image") (bind START first (SETQ START (ADD1 (QUOTIENT (DIFFERENCE BOXSIZE IMAGESIZE) 2))) until (LEQ START 1) do (add START (MINUS IMAGESIZE)) finally (RETURN START]) ) (RPAQ? BACKGROUNDS NIL) (RPAQ? BACKGROUND.MODE 'CENTER) (RPAQ? BACKGROUND.SHADE 34850) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BACKGROUNDS BackgroundMenuCommands LISPUSERSDIRECTORIES BACKGROUND.MODE BACKGROUND.SHADE) ) (ADDTOVAR GAINSPACEFORMS ((LISTP BACKGROUNDS) "Delete saved background bitmaps" (SETQ BACKGROUNDS NIL))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS BACKGROUNDIMAGES COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1897 10963 (BACKGROUND.SETUP 1907 . 4149) (BACKGROUND.FILES 4151 . 5706) ( BACKGROUND.FILE 5708 . 6973) (BACKGROUND.FETCH 6975 . 9284) (BACKGROUND.SHORTNAME 9286 . 10006) ( BACKGROUND.MODE 10008 . 10460) (BACKGROUND.SHADE 10462 . 10961)) (10964 16807 (BACKGROUND.CENTER 10974 . 11668) (BACKGROUND.REFLECT 11670 . 15603) (BACKGROUND.TILE 15605 . 16340) (BACKGROUND.LESS 16342 . 16805))))) STOP \ No newline at end of file diff --git a/lispusers/BACKGROUNDMENU b/lispusers/BACKGROUNDMENU new file mode 100644 index 00000000..d4379814 --- /dev/null +++ b/lispusers/BACKGROUNDMENU @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "31-Jan-87 18:09:00" {ERIS}LYRIC>BACKGROUNDMENU.;1 7367 previous date%: "31-Jan-86 11:36:13" {ERIS}KOTO>LISPUSERS>BACKGROUNDMENU.;1) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BACKGROUNDMENUCOMS) (RPAQQ BACKGROUNDMENUCOMS ((INITVARS BackgroundMenuFixupMode BackgroundMenuSuperItem BackgroundMenuTopLevelItems) (FNS BkgMenu.add.item BkgMenu.fixup BkgMenu.move.item BkgMenu.remove.item BkgMenu.rename.item BkgMenu.reorder.items BkgMenu.subitems \BkgMenu.locate \BkgMenu.locater \BkgMenu.remove.item \BkgMenu.scan.item.list \BkgMenu.unremove.item))) (RPAQ? BackgroundMenuFixupMode NIL) (RPAQ? BackgroundMenuSuperItem NIL) (RPAQ? BackgroundMenuTopLevelItems NIL) (DEFINEQ (BkgMenu.add.item [LAMBDA (item superitem atend) (* mdd "31-Jan-86 11:32") (if (NULL superitem) then (if atend then (NCONC1 BackgroundMenuCommands item) else (SETQ BackgroundMenuCommands (CONS item BackgroundMenuCommands))) (SETQ BackgroundMenu NIL) T elseif (SETQ superitem (CDDAR (\BkgMenu.locate superitem))) then [if (NULL (CDR superitem)) then (RPLACD superitem (LIST (LIST 'SUBITEMS item))) else (if atend then (NCONC1 (CADR superitem) item) else (RPLACD (CADR superitem) (CONS item (CDADR superitem] (SETQ BackgroundMenu NIL) T]) (BkgMenu.fixup [LAMBDA NIL (* mdd "23-Sep-85 19:09") (bind stack (stacking _ (NEQ BackgroundMenuFixupMode 'bottom)) (result _ T) for x in (BkgMenu.subitems) do [if (for i in BackgroundMenuTopLevelItems thereis (EQUAL (MKSTRING i) (MKSTRING x))) then (if (AND stacking (NEQ BackgroundMenuFixupMode 'top)) then (for i in stack do (OR (BkgMenu.move.item i BackgroundMenuSuperItem) (SETQ result NIL))) (SETQ stacking NIL)) else (if stacking then (SETQ stack (CONS x stack)) else (OR (BkgMenu.move.item x BackgroundMenuSuperItem T) (SETQ stacking NIL] finally [if stacking then (for i in stack do (OR (BkgMenu.move.item i BackgroundMenuSuperItem) (SETQ result NIL] (RETURN result]) (BkgMenu.move.item [LAMBDA (item superitem atend) (* mdd "31-Jan-86 11:32") (if (SETQ item (\BkgMenu.locate item)) then (\BkgMenu.remove.item item) (if (BkgMenu.add.item (CAR item) superitem atend) then T else (\BkgMenu.unremove.item item) NIL]) (BkgMenu.remove.item [LAMBDA (item) (* mdd "23-Sep-85 17:13") (if (SETQ item (\BkgMenu.locate item)) then (\BkgMenu.remove.item item) (SETQ BackgroundMenu NIL) T]) (BkgMenu.rename.item [LAMBDA (item new.name) (* mdd "23-Sep-85 16:58") (if (SETQ item (\BkgMenu.locate item)) then (RPLACA (CAR item) new.name) (SETQ BackgroundMenu NIL) T]) (BkgMenu.reorder.items [LAMBDA (itemlist superitem atend) (* mdd "23-Sep-85 20:26") (NOT (for i in (if atend then itemlist else (REVERSE itemlist)) do (OR (BkgMenu.move.item i superitem atend) (SETQ $$VAL T]) (BkgMenu.subitems [LAMBDA (item) (* mdd "23-Sep-85 18:33") (if item then (if (SETQ item (\BkgMenu.locate item)) then (MAPCAR (CDR (CADDDR (CAR item))) (FUNCTION CAR)) else 'NotAnItem) else (MAPCAR BackgroundMenuCommands (FUNCTION CAR]) (\BkgMenu.locate [LAMBDA (item menu) (* mdd "23-Sep-85 20:58") (if [AND (LISTP item) (CDR item) (NOT (SETQ menu (CADDDR (CAR (\BkgMenu.locate (CDR item) menu] then NIL else (\BkgMenu.locater (MKSTRING (if (LISTP item) then (CAR item) else item)) (OR (CDR menu) BackgroundMenuCommands) menu]) (\BkgMenu.locater [LAMBDA (name items preitems) (* mdd "23-Sep-85 20:44") (bind (queue _ (CONS NIL NIL)) until (OR (SETQ $$VAL (\BkgMenu.scan.item.list name items preitems queue)) (NULL (CAR queue))) do (SETQ preitems (CAAR queue)) (SETQ items (CDR preitems)) (RPLACA queue (CDAR queue)) (if (NULL (CAR queue)) then (RPLACD queue NIL]) (\BkgMenu.remove.item [LAMBDA (item) (* mdd "23-Sep-85 17:12") (if (CDR item) then (RPLACD (CDR item) (CDDDR item)) else (SETQ BackgroundMenuCommands (CDR BackgroundMenuCommands]) (\BkgMenu.scan.item.list [LAMBDA (name items preitems queue) (* mdd "23-Sep-85 15:39") (for i in old items do (if (EQUAL (MKSTRING (CAR i)) name) then (RETURN (CONS i preitems)) else (if (CDDDR i) then (TCONC queue (CADDDR i))) (SETQ preitems items]) (\BkgMenu.unremove.item [LAMBDA (item) (* mdd "23-Sep-85 17:17") (if (CDR item) then (RPLACD (CDR item) (CONS (CAR item) (CDDR item))) else (SETQ BackgroundMenuCommands (CONS (CAR item) BackgroundMenuCommands]) ) (PUTPROPS BACKGROUNDMENU COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1008 7271 (BkgMenu.add.item 1018 . 1910) (BkgMenu.fixup 1912 . 3131) (BkgMenu.move.item 3133 . 3557) (BkgMenu.remove.item 3559 . 3834) (BkgMenu.rename.item 3836 . 4128) ( BkgMenu.reorder.items 4130 . 4505) (BkgMenu.subitems 4507 . 4907) (\BkgMenu.locate 4909 . 5520) ( \BkgMenu.locater 5522 . 6089) (\BkgMenu.remove.item 6091 . 6378) (\BkgMenu.scan.item.list 6380 . 6877) (\BkgMenu.unremove.item 6879 . 7269))))) STOP \ No newline at end of file diff --git a/lispusers/BICLOCK b/lispusers/BICLOCK new file mode 100644 index 00000000..1e5937a8 --- /dev/null +++ b/lispusers/BICLOCK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Sep-88 01:29:15" {ERINYES}MEDLEY>BICLOCK.;5 38172 changes to%: (FNS BICLOCK BICLOCKPROCESS) (VARS BICLOCKCOMS) previous date%: "14-Dec-87 17:32:47" {ERINYES}MEDLEY>BICLOCK.;2) (* " Copyright (c) 1984, 1985, 1986, 1987, 1988 by Bernt Nilsson @ University of Linkoeping. All rights reserved. ") (PRETTYCOMPRINT BICLOCKCOMS) (RPAQQ BICLOCKCOMS [(FNS BICLOCK BICLOCKBEFN BICLOCKCFN BICLOCKFINDFONT BICLOCKNRFN BICLOCKPROCESS BICLOCKRPFN BICLOCKRSFN BICLOCKSETALARM BICLOCKSETALARM1 BICLOCKSETALARM2 IDLE.BICLOCK) (RECORDS BICLOCKPARMS UPTIMEREC) [INITVARS (BICLOCKWINDOW) (BICLOCKDEFAULTPROPS '(SECONDS T COLOR SHADOW MARKS NIL DIGITS 1 CHIME NIL ALARM NIL SIZE 152 HORIZONTAL LEFT-OF-LOGO VERTICAL TOP CREATE T)) (BICLOCKUSERPROPS) (BICLOCKINITIALPROPS) (BICLOCKIDLEPROPS '(HORIZONTAL CENTER VERTICAL CENTER] [P (CL:PROCLAIM '(CL:SPECIAL BICLOCKWINDOW BICLOCKDEFAULTPROPS BICLOCKUSERPROPS BICLOCKINITIALPROPS BICLOCKIDLEPROPS] [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (BICLOCKWINDOW (BICLOCK BICLOCKINITIALPROPS] (ADDVARS (IDLE.FUNCTIONS (Biclock 'IDLE.BICLOCK)) (IDLE.SUSPEND.PROCESS.NAMES BICLOCKPROCESS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA BICLOCK]) (DEFINEQ (BICLOCK [LAMBDA PROPS (* ; "Edited 12-Sep-88 01:25 by masinter") (LET ((PLIST (APPEND (if [AND (EQ PROPS 1) (OR (NULL (ARG PROPS 1)) (LISTP (ARG PROPS 1] then (ARG PROPS 1) else (for I from 1 to PROPS collect (ARG PROPS I))) BICLOCKUSERPROPS BICLOCKDEFAULTPROPS))) (if [OR (ODDP (LENGTH PLIST)) (find P in PLIST by (CDDR P) suchthat (NOT (LITATOM P] then (ERROR "ARG NOT PROPLIST IN BICLOCK" PLIST)) (if (LISTGET PLIST 'CREATE) then (LET ((W (OR (LISTGET PLIST 'WINDOW) (CREATEW (OR (for P in PLIST by (CDDR P) as V in (CDR PLIST) by (CDDR V) do (SELECTQ P (SIZE (RETURN (if V then (CREATEREGION (SELECTQ (LISTGET PLIST 'HORIZONTAL) (LEFT 0) (CENTER (QUOTIENT (DIFFERENCE SCREENWIDTH V) 2)) (LEFT-OF-LOGO (- SCREENWIDTH V (if LOGOW then (WINDOWPROP LOGOW 'WIDTH) else 0))) (RIGHT (DIFFERENCE (DIFFERENCE SCREENWIDTH V) 1)) (OR (NUMBERP (LISTGET PLIST 'HORIZONTAL)) 0)) (SELECTQ (LISTGET PLIST 'VERTICAL) (BOTTOM 0) (CENTER (QUOTIENT (DIFFERENCE SCREENHEIGHT V) 2)) (BELOW-LOGO (- SCREENHEIGHT V (if LOGOW then (WINDOWPROP LOGOW 'HEIGHT) else 0))) (TOP (DIFFERENCE (DIFFERENCE SCREENHEIGHT V) 1)) (OR (NUMBERP (LISTGET PLIST 'VERTICAL)) 0)) V V)))) (REGION (RETURN V)) NIL)) (GETREGION 20 20 NIL 'BICLOCKNRFN)) NIL 0))) [PARMS (create BICLOCKPARMS SECONDSMODE _ (LISTGET PLIST 'SECONDS) COLORMODE _ (LISTGET PLIST 'COLOR) MARKMODE _ [SELECTQ (LISTGET PLIST 'MARKS) (HOUR 5) ((HOUR&MINUTE MINUTE) 1) (|3/6/9/12| 15) (NUMBERP (LISTGET PLIST 'MARKS] DIGMODE _ [SELECTQ (LISTGET PLIST 'DIGITS) (HOUR 1) (|3/6/9/12| 3) (NUMBERP (LISTGET PLIST 'DIGITS] CHIMEMODE _ [SELECTQ (LISTGET PLIST 'CHIME) (HOUR 60) (QUORTER 15) (NUMBERP (LISTGET PLIST 'CHIME] ROMANDIGS _ (for P in PLIST by (CDDR P) as V in (CDR PLIST) by (CDDR V) do (SELECTQ P (ROMAN (RETURN V)) (ARABIC (RETURN (NOT V))) NIL)) ADJUSTEVENT _ (CREATE.EVENT) ALARMTIME _ (if (LISTGET PLIST 'ALARMTIME) then (IDATE (LISTGET PLIST 'ALARMTIME] P) (if (NOT (LISTGET PLIST 'IDLE)) then (DEL.PROCESS 'BICLOCKPROCESS) (AND BICLOCKWINDOW (CLOSEW BICLOCKWINDOW))) (SETQ P (ADD.PROCESS (LIST (FUNCTION BICLOCKPROCESS) (KWOTE W) (KWOTE PARMS)) 'RESTARTABLE 'HARDRESET)) (WINDOWPROP W 'PROCESS P) (WINDOWPROP W 'NEWREGIONFN (FUNCTION BICLOCKNRFN)) (WINDOWPROP W 'RESHAPEFN (FUNCTION BICLOCKRSFN)) (WINDOWPROP W 'REPAINTFN (FUNCTION BICLOCKRPFN)) (WINDOWPROP W 'CLOSEFN (FUNCTION BICLOCKCFN)) (WINDOWPROP W 'AFTERMOVEFN (FUNCTION BICLOCKRPFN)) (WINDOWPROP W 'PARMS PARMS) (WINDOWPROP W 'WINDOWENTRYFN (FUNCTION BICLOCKBEFN)) (WINDOWPROP W 'BUTTONEVENTFN (FUNCTION BICLOCKBEFN)) W]) (BICLOCKBEFN [LAMBDA (W) (* lmm "19-Nov-86 07:41") (LET [(PROC (WINDOWPROP W 'PROCESS] [if (PROCESS.FINISHEDP PROC) then (PRINTOUT PROMPTWINDOW T "RESTARING BICLOCK PROCESS") (WINDOWPROP W 'PROCESS (SETQ PROC (ADD.PROCESS [LIST (FUNCTION BICLOCKPROCESS) (KWOTE W) (KWOTE (WINDOWPROP W 'PARMS] 'RESTARTABLE 'HARDRESET] (if (.COPYKEYDOWNP.) then (SUSPEND.PROCESS PROC) (INVERTW W) (UNTILMOUSESTATE (NOT (OR LEFT MIDDLE))) (BKSYSBUF (DATE)) (INVERTW W) (WAKE.PROCESS PROC) else (with BICLOCKPARMS (WINDOWPROP W 'PARMS) (if (MOUSESTATE LEFT) then (if ALARMTIME then (PROMPTPRINT (DATE) " ALARM AT " (GDATE ALARMTIME)) else (PROMPTPRINT (DATE) " NO ALARM SET")) elseif (MOUSESTATE MIDDLE) then (LET [(SEL (MENU (create MENU ITEMS _ `(("Seconds On" 'SON) ("Seconds Off" 'SOFF) ("White" 'WHITE "White with border" (SUBITEMS ("Shadow" 'SHADOW "White with shadow")) ) ("Black" 'BLACK) ["Markers" 'MINSEC "Use Submenu to Change number of Markers" (SUBITEMS ("No markers" 'NOMARKER) ("3/6/9/12 Markers" '3HOURMARKS) ("Only hours" 'HOURMARKS) ("Hours and minutes" 'MINHOURMARKS] ["Digits" 'HOUR "Use Submenu to Change number of Digits" (SUBITEMS ("No Digits" 'NODIG) ("3/6/9/12 Hours" '3HOUR) ("All Hours" 'HOUR) ("Arabic digits" 'ARABIC) ("Roman digits" 'ROMAN] ["Chime" 'CHIME "Use Submenu to Change Chime interval" (SUBITEMS ("No chime" 'NOCHIME) ("Hours" 'CHIME) ("Hours and quarters" 'CHIME15MIN] ("Set Alarm" 'ALARM) ("Alarm Off" 'AOFF] (SELECTQ SEL (SON (SETQ SECONDSMODE T)) (SOFF (SETQ SECONDSMODE NIL)) ((WHITE BLACK SHADOW) (SETQ COLORMODE SEL)) (NOMARKER (SETQ MARKMODE NIL)) (3HOURMARKS (SETQ MARKMODE 15)) (HOURMARKS (SETQ MARKMODE 5)) (MINHOURMARKS (SETQ MARKMODE 1)) (NODIG (SETQ DIGMODE NIL)) (3HOUR (SETQ DIGMODE 3)) (HOUR (SETQ DIGMODE 1)) (ARABIC (SETQ ROMANDIGS NIL)) (ROMAN (SETQ ROMANDIGS T)) (NOCHIME (SETQ CHIMEMODE NIL)) (CHIME (SETQ CHIMEMODE 60)) (CHIME15MIN (SETQ CHIMEMODE 15)) (ALARM (BICLOCKSETALARM W)) (AOFF (SETQ ALARMTIME NIL)) NIL) (if (MEMB SEL '(NOMARKER 3HOURMARKS HOURMARKS MINHOURMARKS NODIG 3HOUR HOUR ARABIC ROMAN)) then (RESTART.PROCESS (WINDOWPROP W 'PROCESS)) else (WAKE.PROCESS (WINDOWPROP W 'PROCESS]) (BICLOCKCFN [LAMBDA (W) (DEL.PROCESS (WINDOWPROP W 'PROCESS]) (BICLOCKFINDFONT [LAMBDA (SIZE MODERNCLASSIC) (* ; "Edited 26-Nov-86 14:46 by Pavel") (LET [(ALLFONTS (FONTSAVAILABLE '* '* 'MRR 0 'DISPLAY] [SORT ALLFONTS (FUNCTION (LAMBDA (F1 F2) (OR [AND MODERNCLASSIC (MEMB (CAR F1) '(MODERN CLASSIC)) (NOT (MEMB (CAR F2) '(MODERN CLASSIC] (GREATERP (CADR F1) (CADR F2)) (AND (EQP (CADR F1) (CADR F2)) (for FAM in '(MODERN CLASSIC GACHA HELVETICA HELVETICAD TERMINAL) do (if (EQ FAM (CAR F1)) then (RETURN T) elseif (EQ FAM (CAR F2)) then (RETURN NIL] (find FONT in ALLFONTS suchthat (LEQ (CADR FONT) SIZE]) (BICLOCKNRFN [LAMBDA (FP MP) (* BN "17-Sep-84 10:40") (COND [MP (with POSITION MP (PROG [(DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP))) (DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP] [COND [(IGREATERP (IABS DX) (IABS DY)) (SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP) (ITIMES DX (COND ((MINUSP (ITIMES DX DY)) -1) (T 1] (T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP) (ITIMES DY (COND ((MINUSP (ITIMES DX DY)) -1) (T 1] (RETURN MP] (T FP]) (BICLOCKPROCESS [LAMBDA (W PARMS) (* ; "Edited 12-Sep-88 01:26 by masinter") (CENTERPRINTINREGION "Wait" NIL W) (with BICLOCKPARMS PARMS (PROG [(WIDTH (WINDOWPROP W 'WIDTH)) (HEIGHT (WINDOWPROP W 'HEIGHT] (while T bind S (BM _ (BITMAPCREATE WIDTH HEIGHT)) (BG _ (BITMAPCREATE WIDTH HEIGHT)) (BM1 _ (BITMAPCREATE WIDTH HEIGHT)) (SHADOW _ (BITMAPCREATE WIDTH HEIGHT)) (XC _ (IQUOTIENT WIDTH 2)) (YC _ (IQUOTIENT HEIGHT 2)) (SX _ (ARRAY 60 'FIXP 0 0)) (SY _ (ARRAY 60 'FIXP 0 0)) MX MY HX HY MP HP R MARKUR MARKLR MARK1LR DOTR SECR MINR HOURR CIRCW MARKW MARK1W SECW MINW HOURW DIGW DIGFONT NOW SECS (SLOWMODE _ T) (SMODE _ T) (MEAN _ 50) (LIMIT _ 1000) CL0 REF NOSEC INVERTFLG LASTCHIME (CHIMECOUNT _ 0) first (* ; "First set up some relations") (BLOCK) (WINDOWPROP W 'ICONIMAGE BM) (WINDOWPROP W 'ICONMASK BG) (SETQ R (- (IMIN XC YC) 4)) (SETQ MARKUR (CL:* R 1.0)) (SETQ MARKLR (CL:* R 0.9)) (SETQ MARK1LR (CL:* R 0.98)) (SETQ DOTR (CL:* R 0.05)) (SETQ SECR (CL:* R 1.0)) (SETQ MINR (CL:* R 0.9)) (BLOCK) (SETQ HOURR (CL:* R 0.6)) (SETQ CIRCW (CL:* R 0.03)) (SETQ MARKW (CL:* R (SELECTQ COLORMODE (SHADOW 0.05) 0.0375))) (SETQ MARK1W (CL:* R 0.009)) (SETQ SECW (IMAX 1 (CL:* R 0.01))) (SETQ MINW (IMAX 2 (CL:* R 0.037))) (SETQ HOURW (IMAX 3 (CL:* R 0.07))) (SETQ DIGW (CL:* R (if (NUMBERP MARKMODE) then 0.75 else 0.9))) (SETQ S (DSPCREATE BM)) (DSPXOFFSET XC S) (DSPYOFFSET YC S) (* ;; "Generate signature") (if (SETQ DIGFONT (BICLOCKFINDFONT (TIMES R 0.15))) then (DSPFONT DIGFONT S) (CENTERPRINTINREGION "BN" (CREATEREGION (MINUS XC) (MINUS (QUOTIENT (TIMES YC 4) 5)) WIDTH (QUOTIENT (TIMES YC 4) 5)) S)) (SETQ DIGFONT (BICLOCKFINDFONT (CL:* R (if (NUMBERP MARKMODE) then 0.2 else 0.25)) ROMANDIGS)) (DSPFONT DIGFONT S) (DSPOPERATION 'PAINT S) (* ; "Generate background Hour Marks") (for H from 1 to 12 as V from 60 by -30 bind SYM do (BLOCK) (SETQ HX (COS V)) (SETQ HY (SIN V)) (if (AND (NUMBERP MARKMODE) (ZEROP (IMOD (CL:* H 5) MARKMODE))) then (DRAWLINE (CL:* HX MARKUR) (CL:* HY MARKUR) (CL:* HX MARKLR) (CL:* HY MARKLR) MARKW 'REPLACE S)) (if (AND DIGFONT (NUMBERP DIGMODE) (ZEROP (IMOD H DIGMODE))) then (SETQ SYM (if ROMANDIGS then (CAR (NTH '(˙ďÁ˙ ˙ďÂ˙ ˙ďĂ˙ ˙ďÄ˙ ˙ďĹ˙ ˙ďĆ˙ ˙ďÇ˙ ˙ďČ˙ ˙ďÉ˙ ˙ďĘ˙ ˙ďĘÁ˙ ˙ďĘÂ˙) H)) else H)) (MOVETO (- (CL:* HX DIGW) (QUOTIENT (STRINGWIDTH SYM S) 2)) (- (CL:* HY DIGW) (if ROMANDIGS then (- (QUOTIENT (FONTPROP S 'HEIGHT) 2) (FONTPROP S 'DESCENT)) else (QUOTIENT (FONTPROP S 'ASCENT) 2))) S) (PRIN1 SYM S))) (* ;  "Generate background Second Marks") (for I from 0 to 59 as V from 90 by -6 do (BLOCK) (SETA SX I (FIX (CL:* (SETQ MX (COS V)) SECR))) (SETA SY I (FIX (CL:* (SETQ MY (SIN V)) SECR))) (if (AND (NUMBERP MARKMODE) (ZEROP (IMOD I MARKMODE))) then (DRAWLINE (CL:* MX SECR) (CL:* MY SECR) (CL:* MX MARK1LR) (CL:* MY MARK1LR) MARK1W 'REPLACE S))) (BLOCK) (FILLCIRCLE 0 0 DOTR BLACKSHADE S) (* ;  "Let this be the Background to be used in the loop") (BITBLT BM NIL NIL BG) (* ;  "Determine a reference point for millisecond clock, that is half a second ahead...") (while (= (DAYTIME) T1) bind (T1 _ (DAYTIME)) do (BLOCK) finally (SETQ REF (IPLUS (CLOCK 0) 500))) do (BITBLT BG NIL NIL BM) (* ;  "Compute number of seconds since midnight") (SETQ NOW (DAYTIME)) (SETQ SECS (with UPTIMEREC (\UNPACKDATE (if ADJUSTALARM then ALARMTIME else NOW)) (IPLUS (CL:* HOUR 3600) (CL:* MINUTE 60) SECOND))) (if SLOWMODE then (BLOCK)) (* ; "Draw Hour Arm") (COND ((EQP HP (IQUOTIENT SECS 120)) (DRAWLINE 0 0 HX HY HOURW 'REPLACE S)) (T (DRAWLINE 0 0 (SETQ HX (FIX (CL:* (SIN (SETQ HP (IQUOTIENT SECS 120))) HOURR))) (SETQ HY (FIX (CL:* (COS HP) HOURR))) HOURW 'REPLACE S))) (if SLOWMODE then (BLOCK)) (* ; "Draw Minute Arm") (COND ((EQP MP (IQUOTIENT SECS 10)) (DRAWLINE 0 0 MX MY MINW 'REPLACE S)) (T (DRAWLINE 0 0 (SETQ MX (FIX (CL:* (SIN (SETQ MP (IQUOTIENT SECS 10))) MINR))) (SETQ MY (FIX (CL:* (COS MP) MINR))) MINW 'REPLACE S))) (if SLOWMODE then (BLOCK)) (* ; "Draw Seconds Arm") (COND ((NOT NOSEC) (DRAWLINE 0 0 (ELT SX (IMOD SECS 60)) (ELT SY (IMOD SECS 60)) SECW 'REPLACE S))) (* ; "Now, Generate The Shadow") (if SLOWMODE then (BLOCK)) [SELECTQ COLORMODE (SHADOW (BITBLT BM NIL NIL SHADOW) [for DX from 0 to 1 do (for DY from -2 to 0 do (if SLOWMODE then (BLOCK)) (BITBLT SHADOW NIL NIL SHADOW DX DY NIL NIL 'INPUT 'PAINT) when (OR (NEQ DX 0) (NEQ DY 0]) (PROGN (BITBLT BM NIL NIL SHADOW) (for DX from -1 to 1 do (for DY from -1 to 1 do (if SLOWMODE then (BLOCK)) (BITBLT SHADOW NIL NIL SHADOW DX DY NIL NIL 'INPUT 'PAINT) when (OR (NEQ DX 0) (NEQ DY 0] (if SLOWMODE then (BLOCK)) (* ; "Find the Real background") (TOTOPW W) (BITBLT (WINDOWPROP W 'IMAGECOVERED) NIL NIL BM1) (BITBLT SHADOW NIL NIL BM1 NIL NIL NIL NIL 'INPUT (SELECTQ COLORMODE ((WHITE SHADOW) 'PAINT) (BLACK 'ERASE) NIL)) (if SLOWMODE then (BLOCK)) (BITBLT BM NIL NIL BM1 NIL NIL NIL NIL 'INPUT (SELECTQ COLORMODE ((WHITE SHADOW) 'ERASE) (BLACK 'PAINT) NIL)) (* ; "Now, at last, Output it") (BITBLT BM1 NIL NIL W NIL NIL NIL NIL (if INVERTFLG then 'INVERT else 'INPUT) 'REPLACE) [if SLOWMODE then (if [AND CHIMEMODE (OR (NULL LASTCHIME) (NOT (= (IQUOTIENT LASTCHIME (CL:* CHIMEMODE 60)) (IQUOTIENT SECS (CL:* CHIMEMODE 60] then (if LASTCHIME then (SETQ CHIMECOUNT (if (= (IMOD (IQUOTIENT SECS 60) 60) 0) then (IPLUS (IMOD (- (IQUOTIENT SECS (CL:* 60 60)) 1) 12) 1) else 1))) (SETQ LASTCHIME SECS)) (if (> CHIMECOUNT 0) then (add CHIMECOUNT -1) (BEEPON 440) (BLOCK 25) (BEEPON 220) (BLOCK 25) (BEEPOFF)) (for N from 1 to (COND (SMODE 10) (T 1)) bind (DEL _ (COND ((OR SMODE (AND ALARMTIME (<= ALARMTIME NOW)) (> CHIMECOUNT 0)) 1000) (T 60000))) until (OR ADJUSTALARM (AND ALARMTIME (<= ALARMTIME NOW) )) repeatwhile (AND NOSEC (> MEAN LIMIT)) do (BLOCK (- DEL (IMOD (- (CLOCK 0) REF) DEL))) (SETQ CL0 (CLOCK 0)) (BLOCK) (SETQ MEAN (IQUOTIENT (IPLUS (CL:* MEAN 8) (CL:* (IMAX (IMIN (- (CLOCK 0) CL0) 500) 0) 2)) 10] (SETQ SLOWMODE (NOT ADJUSTALARM)) (SETQ SMODE SECONDSMODE) (SETQ NOSEC (AND (OR (NOT SMODE) (> MEAN LIMIT)) (NOT ADJUSTALARM))) (SETQ INVERTFLG (if (AND ALARMTIME (ILEQ ALARMTIME NOW)) then (BEEPON (if INVERTFLG then 440 else 880)) (BLOCK 50) (BEEPOFF) (NOT INVERTFLG) elseif ADJUSTALARM then (AWAIT.EVENT ADJUSTEVENT) NIL)) (SETQ LIMIT (IMIN (if (> LIMIT (/ (CL:* MEAN 10) 9)) then (- LIMIT 1) else (+ LIMIT 1)) 50]) (BICLOCKRPFN [LAMBDA (W) (WAKE.PROCESS (WINDOWPROP W 'PROCESS]) (BICLOCKRSFN [LAMBDA (W) (* lmm "24-Oct-86 15:17") (RESTART.PROCESS (WINDOWPROP W 'PROCESS]) (BICLOCKSETALARM [LAMBDA (W) (* lmm "24-Oct-86 15:21") (LET [(M (OR (WINDOWPROP W 'ADJUSTMENUW) (MENUWINDOW (create MENU ITEMS _ `(("
") ("") ("") ,@[for I1 in '(24 12 3 1 -1 -3 -12 -24) as I2 in '(30 15 5 1 -1 -5 -15 -30) join (for QQQ in '(T NIL NIL) as SCALE in (CONSTANT (LIST (TIMES 60 60) 60 1)) as HELP in '("Will Increment/Decrement Hours by that Amount" "Will Increment/Decrement Minutes by that Amount" "Will Increment/Decrement Seconds by that Amount") collect (LET ((I (if QQQ then I1 else I2))) (LIST I (LIST (FUNCTION BICLOCKSETALARM1) (KWOTE W) (KWOTE (TIMES I SCALE))) HELP] ("OK!" (BICLOCKSETALARM2 ,(KWOTE W)) "Will Exit Adjust Mode") ("_0" (BICLOCKSETALARM1 ,(KWOTE W) 3600 T) "Will Reset Alarm Time to Hr:00:00") ("_0" (BICLOCKSETALARM1 ,(KWOTE W) 60 T) "Will Reset Alarm Time to Hr:Min:00")) TITLE _ "Adjust Alarm" CENTERFLG _ T MENUCOLUMNS _ 3] (WINDOWPROP W 'ADJUSTMENUW M) (ATTACHWINDOW M W 'BOTTOM 'JUSTIFY) (with BICLOCKPARMS (WINDOWPROP W 'PARMS) (SETQ ALARMTIME (OR ALARMTIME (PLUS (DAYTIME) 60))) (SETQ ADJUSTALARM T) (NOTIFY.EVENT ADJUSTEVENT) (PROMPTPRINT (GDATE ALARMTIME]) (BICLOCKSETALARM1 [LAMBDA (W DSEC MODULOFLG) (* lmm "24-Oct-86 15:21") (with BICLOCKPARMS (WINDOWPROP W 'PARMS) [LET [(OLDTIME (OR ALARMTIME (PLUS (DAYTIME) 60] (SETQ ALARMTIME (if MODULOFLG then (DIFFERENCE OLDTIME (IMOD (with UPTIMEREC (\UNPACKDATE ALARMTIME) (IPLUS (ITIMES HOUR 3600) (ITIMES MINUTE 60) SECOND)) DSEC)) else (IPLUS OLDTIME DSEC] (NOTIFY.EVENT ADJUSTEVENT) (PROMPTPRINT (GDATE ALARMTIME]) (BICLOCKSETALARM2 [LAMBDA (W) (* lmm "24-Oct-86 15:17") (with BICLOCKPARMS (WINDOWPROP W 'PARMS) (SETQ ADJUSTALARM NIL) (NOTIFY.EVENT ADJUSTEVENT) (DETACHWINDOW (WINDOWPROP W 'ADJUSTMENUW)) (CLOSEW (WINDOWPROP W 'ADJUSTMENUW]) (IDLE.BICLOCK [LAMBDA (W) (* BKN "17-Jun-86 14:22") (RESETLST (LET ((BW (BICLOCK BICLOCKIDLEPROPS))) (RESETSAVE NIL (LIST (FUNCTION CLOSEW) BW)) (while T do (BLOCK 5000) (if (NEQ (\GETBASEPTR BW 2) W) then (TOTOPW W)) (MOVEW BW [RAND 0 (DIFFERENCE SCREENWIDTH (WINDOWPROP BW 'WIDTH] (RAND 0 (DIFFERENCE SCREENHEIGHT (WINDOWPROP BW 'HEIGHT]) ) (DECLARE%: EVAL@COMPILE (DATATYPE BICLOCKPARMS (SECONDSMODE COLORMODE MARKMODE DIGMODE CHIMEMODE ROMANDIGS ALARMTIME ADJUSTALARM ADJUSTEVENT)) (RECORD UPTIMEREC (YEAR MONTH DAY HOUR MINUTE SECOND QQQ)) ) (/DECLAREDATATYPE 'BICLOCKPARMS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((BICLOCKPARMS 0 POINTER) (BICLOCKPARMS 2 POINTER) (BICLOCKPARMS 4 POINTER) (BICLOCKPARMS 6 POINTER) (BICLOCKPARMS 8 POINTER) (BICLOCKPARMS 10 POINTER) (BICLOCKPARMS 12 POINTER) (BICLOCKPARMS 14 POINTER) (BICLOCKPARMS 16 POINTER)) '18) (RPAQ? BICLOCKWINDOW ) (RPAQ? BICLOCKDEFAULTPROPS '(SECONDS T COLOR SHADOW MARKS NIL DIGITS 1 CHIME NIL ALARM NIL SIZE 152 HORIZONTAL LEFT-OF-LOGO VERTICAL TOP CREATE T)) (RPAQ? BICLOCKUSERPROPS ) (RPAQ? BICLOCKINITIALPROPS ) (RPAQ? BICLOCKIDLEPROPS '(HORIZONTAL CENTER VERTICAL CENTER)) (CL:PROCLAIM '(CL:SPECIAL BICLOCKWINDOW BICLOCKDEFAULTPROPS BICLOCKUSERPROPS BICLOCKINITIALPROPS BICLOCKIDLEPROPS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ BICLOCKWINDOW (BICLOCK BICLOCKINITIALPROPS)) ) (ADDTOVAR IDLE.FUNCTIONS (Biclock 'IDLE.BICLOCK)) (ADDTOVAR IDLE.SUSPEND.PROCESS.NAMES BICLOCKPROCESS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA BICLOCK) ) (PUTPROPS BICLOCK COPYRIGHT ("Bernt Nilsson @ University of Linkoeping" 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1744 36493 (BICLOCK 1754 . 7779) (BICLOCKBEFN 7781 . 13339) (BICLOCKCFN 13341 . 13412) (BICLOCKFINDFONT 13414 . 14853) (BICLOCKNRFN 14855 . 16271) (BICLOCKPROCESS 16273 . 32113) ( BICLOCKRPFN 32115 . 32188) (BICLOCKRSFN 32190 . 32347) (BICLOCKSETALARM 32349 . 34451) ( BICLOCKSETALARM1 34453 . 35474) (BICLOCKSETALARM2 35476 . 35811) (IDLE.BICLOCK 35813 . 36491))))) STOP \ No newline at end of file diff --git a/lispusers/BICLOCK.TEDIT b/lispusers/BICLOCK.TEDIT new file mode 100644 index 00000000..45e8802a Binary files /dev/null and b/lispusers/BICLOCK.TEDIT differ diff --git a/lispusers/BIGGER-FONT b/lispusers/BIGGER-FONT new file mode 100644 index 00000000..8403b9f0 --- /dev/null +++ b/lispusers/BIGGER-FONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Jan-89 11:18:56" {QV}LISP>BIGGER-FONT.;5 2459 changes to%: (VARS BIGGER-FONTCOMS) previous date%: "25-Jan-89 12:04:51" {QV}LISP>BIGGER-FONT.;4) (* " Copyright (c) 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BIGGER-FONTCOMS) (RPAQQ BIGGER-FONTCOMS ((ALISTS (FONTDEFS BIGGER)) (DECLARE%: DONTEVAL@LOAD DOCOPY (APPENDVARS (FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT))))) (P (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T)))))) (ADDTOVAR FONTDEFS (BIGGER (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (GACHA 8) (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 12) NIL (CLASSIC 10))))) (DECLARE%: DONTEVAL@LOAD DOCOPY (APPENDTOVAR FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT))) ) (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T)) ) (PUTPROPS BIGGER-FONT COPYRIGHT ("Xerox Corporation" 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/BITMAP-GALLERY b/lispusers/BITMAP-GALLERY new file mode 100644 index 00000000..75c34eae --- /dev/null +++ b/lispusers/BITMAP-GALLERY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10) (il:filecreated "17-Aug-89 14:12:04" il:|{FS8:PARC:XEROX}LISP>USERS>BITMAP-GALLERY.;12| 122749 il:|changes| il:|to:| (il:vars il:bitmap-gallerycoms) (il:fns il:rbg) il:|previous| il:|date:| "23-Mar-88 17:08:02" il:|{FS8:PARC:XEROX}LISP>USERS>BITMAP-GALLERY.;11|) ; Copyright (c) 1987, 1988, 1989 by Gregg Foster. All rights reserved. (il:prettycomprint il:bitmap-gallerycoms) (il:rpaqq il:bitmap-gallerycoms ((il:* il:|;;;| "New file") (il:declare\: il:dontcopy (il:props (il:bitmap-gallery il:makefile-environment) (il:bitmap-gallery il:filetype)) (il:coms (il:* il:|;;| "(il:|MakePseudoRandomBitmap) from Granite is useful for generating bitmaps") (il:files (il:from il:|{FS8:}Lisp>USERS>|) il:granite) (il:fns il:rbg il:fabricize) (il:* il:|;;| " Stu's old Rooms bitmaps") (il:bitmaps il:room.bm il:line1.bm il:line2.bm il:line3.bm il:line4.bm il:line5.bm il:square1.bm il:square2.bm il:square3.bm il:square4.bm il:square5.bm il:square6.bm il:square7.bm il:square8.bm il:square9.bm il:shirt1.bm il:curly il:curly1 il:woven il:woven1 il:woven2 il:woven3) (il:* il:|;;| "Stan's Wallpapers and room backgrounds") (il:bitmaps il:wallpaper il:lightwallpaper il:darkwallpaper il:*stamp-bitmap* il:*phone-bitmap*) (il:* il:|;;| " Andreas' Avants") (il:bitmaps il:avantbackground0 il:avantbackground1 il:avantbackground2 il:avantbackground3 il:avantbackground4 il:avantbackground5 il:avantbackground6 il:avantbackground7 il:avantbackground8 il:avantbackground9 il:avantbackground10 il:avantbackground11) (il:* il:|;;| "Other bitmaps") (il:bitmaps *eye-bm* *fract-bm* *mandala-bm* *static1-bm* *static2-bm*) (il:* il:|;;| "Some new ones") (il:* il:|;;| "*random-bm* is rather large, pieces of it might be useful") (il:bitmaps *tessel-bm* *random-bm*) (il:bitmaps *granite-light-bm* *granite-medium-bm* *granite-dark-bm* *tweed-bm* *chambray-bm* *canvas-bm* *corduroy-bm* *seersucker-bm* *burlap-bm*) (il:vars il:defaultscreenshade il:grayshade il:grayshade1 il:grayshade2 il:grayshade3 il:grayshade4 (il:plainshade 23130) (il:wave-texture 26880) (il:wave2-texture 27010) (il:mesh-texture 51219) (il:di-texture 33810) (il:dark-di-texture 31725)))))) (il:* il:|;;;| "New file") (il:declare\: il:dontcopy (il:putprops il:bitmap-gallery il:makefile-environment (:package "XCL-USER" :readtable "XCL" :base 10)) (il:putprops il:bitmap-gallery il:filetype :compile-file) (il:* il:|;;| "(il:|MakePseudoRandomBitmap) from Granite is useful for generating bitmaps") (il:filesload (il:from il:|{FS8:}Lisp>USERS>|) il:granite) (il:defineq (il:rbg (il:lambda (il:|bgList|) (il:* il:\; "Edited 17-Aug-89 14:04 by gsf") (let* ((il:|bgs| (or il:|bgList| (quote (il:plainshade il:grayshade il:di-texture il:dark-di-texture *tessel-bm* *random-bm* *granite-light-bm* *granite-medium-bm* *granite-dark-bm* il:lightwallpaper il:wallpaper il:darkwallpaper il:avantbackground0 il:avantbackground1 il:avantbackground2 il:avantbackground5 il:avantbackground7 il:avantbackground8 il:line4.bm il:line5.bm il:square4.bm il:square6.bm il:square8.bm il:square9.bm il:shirt1.bm il:woven2 il:woven3 *mandala-bm* *tweed-bm* *burlap-bm* *canvas-bm*)))) (il:|bg| (il:eval (car (il:nth il:|bgs| (il:rand 1 (il:length il:|bgs|))))))) (il:changebackground il:|bg|))) ) (il:fabricize (il:lambda (il:|bm| il:|weave|) (il:* il:\; "Edited 22-Mar-88 17:37 by gsf") (let* ((il:|bm| (il:bitmapcopy il:|bm|)) (il:|width| (il:bitmapwidth il:|bm|)) (il:|height| (il:bitmapheight il:|bm|))) (case il:|weave| (1 (il:bltshade 2570 il:|bm| 0 0 il:|width| il:|height| (quote il:erase))) (2 (il:bltshade 204 il:|bm| 0 0 il:|width| il:|height| (quote il:erase))) (t (il:bltshade (il:rand 64000) il:|bm| 0 0 il:|width| il:|height| (quote il:erase)))) il:|bm|)) ) ) (il:* il:|;;| " Stu's old Rooms bitmaps") (il:rpaqq il:room.bm #*(50 35)L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@) (il:rpaqq il:line1.bm #*(22 16)JJJJJH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@EEEEED@@) (il:rpaqq il:line2.bm #*(28 54)@@@@@@@@OOOOOOO@OOOOOOO@@@@@@@@@@@@@@@@@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@EEEEEEE@JJJJJJJ@) (il:rpaqq il:line3.bm #*(26 68)OOOOOOL@BA@@@H@@@@A@@@H@B@@A@@@@DB@@A@@@@@B@@A@@D@@B@@@@HD@@B@@@@@@@@@@@OOOOOOL@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@EEEEEED@JJJJJJH@MEEEEED@JJJJJJH@OOOOOOL@OOOOOOL@OOOOOOL@OOOOOOL@OOOOOOL@OOOOOOL@EMEEEED@OOOOOOL@EEEEEED@OOOOOOL@EMEEEED@OOOOOOL@EEEEEED@OOOOOOL@EMEEEED@OOOOOOL@EEEEEED@OOOOOOL@EMEEEED@OOOOOOL@OOOOOOL@) (il:rpaqq il:line4.bm #*(20 24)OOOOO@@@OOOOO@@@JJJJJ@@@EEEEE@@@JJJJJ@@@EEEEE@@@OOOOO@@@OOOOO@@@JJJJJ@@@EEEEE@@@JJJJJ@@@EEEEE@@@OOOOO@@@OOOOO@@@JJJJJ@@@EEEEE@@@JJJJJ@@@EEEEE@@@OOOOO@@@OOOOO@@@JJJJJ@@@EEEEE@@@JJJJJ@@@EEEEE@@@) (il:rpaqq il:line5.bm #*(12 12)GEM@NKJ@MGE@JNK@EMG@KJN@GEM@NKJ@MGE@JNK@EMG@KJN@) (il:rpaqq il:square1.bm #*(50 50)@@@@@@@@@@@@L@@@@@@@@@@@@@@@L@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEED@@@GOOOOOOOOOOOL@@@GOOOOOOOOOOOL@@@) (il:rpaqq il:square2.bm #*(50 50)@@@@@@@@@@@@D@@@H@@@@@@@@@@@L@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@EEEEEEEEEEEEL@@@GOOOOOOOOOOOL@@@GOOOOOOOOOOOL@@@) (il:rpaqq il:square3.bm #*(50 50)@@@@@@@@@@@@D@@@H@@@@@@@@@@@L@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@BJJJJJJJJJJJL@@@AEEEEEEEEEEEL@@@COOOOOOOOOOOL@@@GOOOOOOOOOOOL@@@) (il:rpaqq il:square4.bm #*(72 76)EEEEEEEEEEEEEEEEEE@@JJJJJJJJJJJJJJJJJJ@@EEEEEEEEEEEEEEEEEE@@JJJJJJJJJJJJJJJJJJ@@EEEEEEEEEEEEEEEEEE@@JJJJJJJJJJJJJJJJJJ@@EEEEEEEEEEEEEEEEEE@@JOOOOOOOOOOOOOOOOJ@@EOOOOOOOOOOOOOOOOM@@JOOOOOOOOOOOOOOOLJ@@EOOOOOOOOOOOOOOOLM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJOOOOOOOOOOJJHJ@@EOEEOOOOOOOOOOMEHM@@JOJJOOOOOOOOOLJJHJ@@EOEEOOOOOOOOOHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJKOOOOJJHJJHJ@@EOEEOEEOOOOEEHMEHM@@JOJJOJKOOOIJJHJJHJ@@EOEEOEEOOOAEEHMEHM@@JOJJOJKNJKAJJHJJHJ@@EOEEOEEOEEAEEHMEHM@@JOJJOJKNJKAJJHJJHJ@@EOEEOEEOEEAEEHMEHM@@JOJJOJKNJKAJJHJJHJ@@EOEEOEEOEEAEEHMEHM@@JOJJOJKNJKAJJHJJHJ@@EOEEOEEOEEAEEHMEHM@@JOJJOJKOOOAJJHJJHJ@@EOEEOEEL@@IEEHMEHM@@JOJJOJKH@@EJJHJJHJ@@EOEEOEEH@@AEEHMEHM@@JOJJOJKOOOOJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOJJJJJJJJHJJHJ@@EOEEOEEEEEEEEHMEHM@@JOJJOOOOOOOOOHJJHJ@@EOEEO@@@@@@@@DMEHM@@JOJJN@@@@@@@@BJJHJ@@EOEEL@@@@@@@@@MEHM@@JOJJOOOOOOOOOOJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOJJJJJJJJJJJJJJHJ@@EOEEEEEEEEEEEEEEHM@@JOOOOOOOOOOOOOOOHJ@@EN@@@@@@@@@@@@@@DM@@JL@@@@@@@@@@@@@@BJ@@EH@@@@@@@@@@@@@@@M@@JOOOOOOOOOOOOOOOOJ@@EEEEEEEEEEEEEEEEEE@@JJJJJJJJJJJJJJJJJJ@@EEEEEEEEEEEEEEEEEE@@JJJJJJJJJJJJJJJJJJ@@) (il:rpaqq il:square5.bm #*(122 122)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJ@@@@@@@@@@@@@@@@JJJJJJOL@HAEEEEE@@@@@@@@@@@@@@@AMEEEEEOL@HBJJJJJ@@@@@@@@@@@@@@@CJJJJJJOL@HAEEEEE@@@@@@@@@@@@@@@CMEEEEEOL@HBJJJJJ@OOOOOOOOOOOOOOOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEE@@@@@@@AEEEGMEEEEEOL@HBJJJJJ@JJJH@@@@@@CJJJOJJJJJJOL@HAEEEEE@MEE@@@@@@@GEEEGMEEEEEOL@HBJJJJJ@JJJHOOOOOOOJJJOJJJJJJOL@HAEEEEE@MEE@MEEEEEGEEEGMEEEEEOL@HBJJJJJ@JJJHJJJJJJOJJJOJJJJJJOL@HAEEEEE@MEE@MEEEEEGEEEGMEEEEEOL@HBJJJJJ@JJJHJJJJJJOJJJOJJJJJJOL@HAEEEEE@MEE@MEEEEEGEEEGMEEEEEOL@HBJJJJJ@JJJHJH@@BJOJJJOJJJJJJOL@HAEEEEE@MEE@MD@@AEGEEEGMEEEEEOL@HBJJJJJ@JJJHJHOONJOJJJOJJJJJJOL@HAEEEEE@MEE@MDMEGEGEEEGMEEEEEOL@HBJJJJJ@JJJHJHJKNJOJJJOJJJJJJOL@HAEEEEE@MEE@MDLAGEGEEEGMEEEEEOL@HBJJJJJ@JJJHJHJNNJOJJJOJJJJJJOL@HAEEEEE@MEE@MDLOGEGEEEGMEEEEEOL@HBJJJJJ@JJJHJHJNNJOJJJOJJJJJJOL@HAEEEEE@MEE@MDMEGEGEEEGMEEEEEOL@HBJJJJJ@JJJHJHJJNJOJJJOJJJJJJOL@HAEEEEE@MEE@MDOOOEGEEEGMEEEEEOL@HBJJJJJ@JJJHJJOONJOJJJOJJJJJJOL@HAEEEEE@MEE@MEEEEEGEEEGMEEEEEOL@HBJJJJJ@JJJHJJJJJJOJJJOJJJJJJOL@HAEEEEE@MEE@MEEEEEGEEEGMEEEEEOL@HBJJJJJ@JJJHJJJJJJOJJJOJJJJJJOL@HAEEEEE@MEE@MEEEEEGEEEGMEEEEEOL@HBJJJJJ@JJJHJJJJJJOJJJOJJJJJJOL@HAEEEEE@MEEAOOOOOOOEEEGMEEEEEOL@HBJJJJJ@JJJKOOOOOOOJJJOJJJJJJOL@HAEEEEE@MEEEOOOOOOOEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@MEEEEEEEEEEEEEGMEEEEEOL@HBJJJJJ@JJJJJJJJJJJJJJOJJJJJJOL@HAEEEEE@OOOOOOOOOOOOOOOMEEEEEOL@HBJJJJJ@OOOOOOOOOOOOOOOJJJJJJOL@HAEEEEEAOOOOOOOOOOOOOOOMEEEEEOL@HBJJJJJCOOOOOOOOOOOOOOOJJJJJJOL@HAEEEEEGOOOOOOOOOOOOOOOMEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJJOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HBJJJJJJJJJJJJJJJJJJJJJJJJJJKOL@HAEEEEEEEEEEEEEEEEEEEEEEEEEEEOL@HCOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@HGOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@HOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@IOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@KOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@) (il:rpaqq il:square6.bm #*(66 66)JJJJJJJJJJJJJJJJH@@@EEEEEEEEEEEEEEEED@@@H@@@@@@@@@@@@@@@H@@@D@@@@@@@@@@@@@@AD@@@H@@@@@@@@@@@@@@CH@@@D@@@@@@@@@@@@@@GD@@@HCOOOOOOOOOOOOOOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HBJJJJJJJJJJJJJOH@@@DCEEEEEEEEEEEEEOD@@@HCOOOOOOOOOOOOOOH@@@DGOOOOOOOOOOOOOOD@@@HOOOOOOOOOOOOOOOH@@@EOOOOOOOOOOOOOOOD@@@JJJJJJJJJJJJJJJJH@@@EEEEEEEEEEEEEEEED@@@) (il:rpaqq il:square7.bm #*(26 26)@@@@@@@@H@@@@@D@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@BJJJJJL@AEEEEED@COOOOOL@GOOOOOL@) (il:rpaqq il:square8.bm #*(24 24)HJJJJJ@@EEEAEE@@@@@@@@@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@@@@@@@@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@HJJJJJ@@EEEAEE@@) (il:rpaqq il:square9.bm #*(16 18)JJJJGEGEOOOOGEGEJJJJGEGEJJJJGEGEJJJJGEGEOOOOGEGEJJJJGEGEJJJJGEGEJJJJGEGE) (il:rpaqq il:shirt1.bm #*(21 8)ADBHE@@@@JADBH@@ADBHE@@@@JADBH@@ADBHE@@@@JADBH@@ADBHE@@@@JADBH@@) (il:rpaqq il:curly #*(80 80)L@DL@@@@@AL@DL@@@@@BH@DF@@@@@AH@DF@@@@@CH@DCH@@@@AH@DC@@@@@A@@D@OON@@A@@DAOON@@A@@D@@@CH@A@@D@@@CH@A@@D@@@CL@A@@D@@@CL@A@@D@@@NF@A@@D@@@NF@A@@D@@AHB@A@@D@@AHB@A@@L@@C@C@A@@L@@C@C@A@@H@@B@A@A@@H@@B@A@A@AH@@F@A@AHAH@@F@A@A@C@@@D@A@@HC@@@D@A@A@N@@@D@A@@LN@@@D@A@@OH@@@D@A@@GH@@@D@A@@CH@@@D@A@@CH@@@D@A@@@OON@D@A@@@OON@D@A@@@@@CHD@C@@@@@CHD@C@@@@@@LD@C@@@@@@LD@C@@@@@@FD@GH@@@@@FD@GH@@@@@BD@DH@@@@@BD@DH@@@@@CL@DL@@@@@CL@DL@@@@@AH@DF@@@@@AH@DF@@@@@AH@DCH@@@@AH@DCHON@@C@@D@OON@@C@@D@O@CH@N@@D@@@B@@N@@D@@@COOH@@D@@@COOH@@D@@@N@@@@@D@@@N@@@@@D@@AH@@@@@D@@AH@@@@@D@@C@@@@@@L@@C@@@@@@L@@B@@@@@@H@@B@@@@@@H@@F@@@@@AH@@F@@@@@AH@@D@@@@@C@@@D@@@@@C@@@D@@@@@N@@@D@@@@@N@@@D@@COOH@@@D@@COOH@@@D@@N@CH@@@D@@N@CH@@@D@AH@@OON@D@AH@@OON@D@C@@@@@CHD@C@@@@@CHD@C@@@@@@LD@C@@@@@@LD@GH@@@@@FD@GH@@@@@FD@DH@@@@@BD@DH@@@@@BL@DL@@@@@CL@DL@@@@@CH@DF@@@@@AH@DF@@@@@AH@DCH@@@@AH@DCH@@@@A@@D@OON@@A@@D@OON@@A@@D@@@CH@A@@D@@@CH@A@@D@@@CL@A@@D@@@CL@A@@D@@@NF@A@@D@@@NF@A@@D@@AHB@A@@D@@AHB@A@@L@@C@C@A@@L@@C@C@A@@H@@B@A@A@@H@@B@A@AHAH@@F@A@AHAH@@F@A@AHC@@@D@A@@HC@@@D@A@@LN@@@D@A@@NN@@@D@A@@GL@@@D@A@@GH@@@D@A@@CH@@@D@A@@CH@@@D@A@@@OON@D@A@@@OON@D@A@@@@@CHD@C@@@@@CHD@C@@@@@@LD@C@@@@@@LD@C@@@@@@FD@GH@@@@@FD@GH@@@@@BD@DH@@@@@BD@DH@@@@@CL@DL@@@@@CL@DL@@@@@AH@DF@@@@@AH@DF@@@@@AH@DCH@@@@AH@DCHON@@C@@D@OON@@C@@D@O@CH@N@@D@@@CH@N@@D@@@COOH@@D@@@COOH@@D@@@N@@@@@D@@@N@@@@@D@@AH@@@@@D@@AH@@@@@D@@C@@@@@@L@@C@@@@@@D@@B@@@@@@H@@B@@@@@@L@@F@@@@@AH@@F@@@@@@H@@D@@@@@C@@@D@@@@@AH@@D@@@@@N@@@D@@@@@G@@@D@@COOH@@@D@@COOL@@@D@@N@CH@@@D@@N@B@@@@D@AH@@OON@D@AH@CH@@@D@C@@@@@CHD@C@@@OON@D@C@@@@@@LD@C@@@@@CHD@GH@@@@@FD@GH@@@@@LD@DH@@@@@BD@DH@@@@@F) (il:rpaqq il:curly1 #*(80 80)L@GL@@@@@AL@GL@@@@@CH@GN@@@@@AH@GN@@@@@CH@GOH@@@@AH@GO@@@@@A@@GOOON@@A@@GOOON@@A@@GOOOOH@A@@GOOOOH@A@@GOOOOL@A@@GOOOOL@A@@GOOONF@A@@GOOONF@A@@GOOOHB@A@@GOOOHB@A@@OOOO@C@A@@OOOO@C@A@@OOON@A@A@@OOON@A@A@AOOON@A@AHAOOON@A@A@COOOL@A@@HCOOOL@A@A@OOOOL@A@@LOOOOL@A@@OOOOOL@A@@GOOOOL@A@@COOOOL@A@@COOOOL@A@@@OOOOL@A@@@OOOOL@A@@@@@COL@C@@@@@COL@C@@@@@@OL@C@@@@@@OL@C@@@@@@GL@GH@@@@@GL@GH@@@@@CL@GH@@@@@CL@GH@@@@@CL@GL@@@@@CL@GL@@@@@AH@GN@@@@@AH@GN@@@@@AH@GOH@@@@AH@GOHON@@C@@GOOON@@C@@GOOOOH@N@@GOOON@@N@@GOOOOOOH@@GOOOOOOH@@GOOON@@@@@GOOON@@@@@GOOOH@@@@@GOOOH@@@@@GOOO@@@@@@OOOO@@@@@@OOON@@@@@@OOON@@@@@@OOON@@@@@AOOON@@@@@AOOOL@@@@@COOOL@@@@@COOOL@@@@@OOOOL@@@@@OOOOL@@COOOOOOL@@COOOOOOL@@N@COOOOL@@N@COOOOL@AH@@OOOOL@AH@@OOOOL@C@@@@@COL@C@@@@@COL@C@@@@@@OL@C@@@@@@OL@GH@@@@@GL@GH@@@@@GL@GH@@@@@CL@GH@@@@@CL@GL@@@@@CL@GL@@@@@CH@GN@@@@@AH@GN@@@@@AH@GOH@@@@AH@GOH@@@@A@@GOOON@@A@@GOOON@@A@@GOOOOH@A@@GOOOOH@A@@GOOOOL@A@@GOOOOL@A@@GOOONF@A@@GOOONF@A@@GOOOHB@A@@GOOOHB@A@@OOOO@C@A@@OOOO@C@A@@OOON@A@A@@OOON@A@AHAOOON@A@AHAOOON@A@AHCOOOL@A@@HCOOOL@A@@LOOOOL@A@@NOOOOL@A@@GOOOOL@A@@GOOOOL@A@@COOOOL@A@@COOOOL@A@@@OOOOL@A@@@OOOOL@A@@@@@COL@C@@@@@COL@C@@@@@@OL@C@@@@@@OL@C@@@@@@GL@GH@@@@@GL@GH@@@@@CL@GH@@@@@CL@GH@@@@@CL@GL@@@@@CL@GL@@@@@AH@GN@@@@@AH@GN@@@@@AH@GOH@@@@AH@GOHON@@C@@GOOON@@C@@GOOOOH@N@@GOOOOH@N@@GOOOOOOH@@GOOOOOOH@@GOOON@@@@@GOOON@@@@@GOOOH@@@@@GOOOH@@@@@GOOO@@@@@@OOOO@@@@@@GOON@@@@@@OOON@@@@@@OOON@@@@@AOOON@@@@@@OOOL@@@@@COOOL@@@@@AOOOL@@@@@OOOOL@@@@@GOOOL@@COOOOOOL@@COOOOOOL@@N@COOOOL@@N@COOOOL@AH@@OOOOL@AH@COOOOL@C@@@@@COL@C@@@OOOOL@C@@@@@@OL@C@@@@@COL@GH@@@@@GL@GH@@@@@OL@GH@@@@@CL@GH@@@@@G) (il:rpaqq il:woven #*(22 22)B@@@AH@@A@@@BD@@HH@@DD@@DD@@HH@@BB@AA@@@AA@BB@@@@HHDD@@@@DDHH@@@@BCA@@@@@ABB@@@@@@LD@@@@@@HL@@@@@AAB@@@@@BCA@@@@@DDHH@@@@HHDD@@@AA@BB@@@BB@AA@@@DD@@HH@@HH@@DD@@I@@@B@@@F@@@A@@@) (il:rpaqq il:woven1 #*(22 22)COOOOH@@AOOOND@@HOOOLD@@LGOOHL@@NCOOAL@@OAONCL@@OHOLGL@@OLGHOL@@ONCAOL@@OOBCOL@@OOLGOL@@OOHOOL@@OOACOL@@ONCAOL@@OLGHOL@@OHOLGL@@OAONCL@@NCOOAL@@LGOOHL@@HOOOLD@@IOOON@@@GOOOO@@@) (il:rpaqq il:woven2 #*(22 22)BJJJKH@@AEEEFD@@HJJJLD@@LEEEHH@@FBJKAD@@KAEFBH@@EHJLED@@JLEHJH@@EFCAED@@JKBBJH@@EELEED@@JJHNJH@@EEACED@@JJCAJH@@EDFHMD@@JHMDFH@@EAJJCD@@JCEEAH@@DFJJHL@@HMEEDD@@IJJJJ@@@GEEEE@@@) (il:rpaqq il:woven3 #*(22 22)BA@DAH@@AB@HBD@@HLA@DD@@DDB@HH@@BBDAA@@@AAHBC@@@@HHDDH@@@DDHHD@@HBCAH@@@DABBD@@@B@LDB@@@A@HLA@@@@IAB@H@@@FCA@D@@HDDHH@@@DHHDD@@@CA@FB@@@BB@IA@@@DDA@HH@@HHB@LD@@I@DAB@@@F@HBA@@@) (il:* il:|;;| "Stan's Wallpapers and room backgrounds") (il:rpaqq il:wallpaper #*(16 16)BDJDIBDIDIABBDJDIBDIDIABBDJDIBDIDIABBDHIDIBDIBEBBDHIDIBDIBEBBDHI) (il:rpaqq il:lightwallpaper #*(16 16)HIDHDDIABBBBAADDHHHHDDAABBBBAADDHHHHDDAABBBBDDAAHHHHAADDBBBBDDIA) (il:rpaqq il:darkwallpaper #*(16 16)MKEKFMKFKFNMMKEKFMKFKFNMMKEKFMKFKFNMMKGFKFMKFMJMMKGFKFMKFMJMMKGF) (il:rpaqq il:*stamp-bitmap* #*(26 30)@@@@@@@@GCCCCCH@DLLLLLH@EOKKD@H@BKJDMM@@BFEOIE@@DIOEELH@EKANMDH@BFGAMM@@BJLJHA@@DFLAEIH@EHJNEJH@CFLAEG@@CAH@OG@@GIJDGBH@DM@@ELH@BCI@NI@@CBH@KE@@DEIHIDH@DJD@GHH@BJGMLO@@B@HCDI@@FMJCE@H@DBCMBHH@CDHNAI@@BIBBIE@@DBD@@HH@DLLLLLH@GCCCCCH@@@@@@@@@) (il:rpaqq il:*phone-bitmap* #*(16 16)IEBBB@HIAMBDKNHJCOB@AOHDHMMABAN@@HODJBCIA@GLDDGLAACMHDEHBA@BHDDH) (il:* il:|;;| " Andreas' Avants") (il:rpaqq il:avantbackground0 #*(48 42)@@@A@@BJJJJ@@@@@HEEEE@@@@@@@HJJJH@@@@@@@EEED@@@@@@@BJJJ@@@@@@@EEEE@B@@@@@BJJJH@A@@@@@EEED@@A@@@@JJJJI@@@H@@@EEED@H@@H@@AJJH@@H@@D@@JED@@@D@@DAEEJ@@@@D@@BJJJ@@@@@@@@EEEED@@@@@@JJJJJB@@@@AEEEEE@B@@@@JJJJJH@A@@@EEEEE@@@A@@JJJJJHD@@@HEEEEE@@D@@@JJJJJH@@B@@AEEEE@@@@B@@JJJJH@@@@A@@EEE@@@@@@A@EJJH@@@@@@@JJED@@@@@@@AEEJ@@@@@@@@JJJ@@H@@@@EEEEE@@H@@@@JJJJH@@D@@EEEEED@@@D@@JJJJJA@@@B@EEEEE@A@@@BJJJJJ@@@H@AEEEED@@@@H@JJJJH@@@@@@EEEED@H@@@@@JJJH@@D@@@@BEED@@@D@@@AEJH@D@@B@@@JJD@@B@@B@AEEEH@@B@@A@BJJJ@@@A@@AEEEE@) (il:rpaqq il:avantbackground1 #*(32 42)CBJJJJIHFEEEEEDLLJJJJJJFIEEEEEECLJJJJJJIFEEEEEECCBJJJJJFFEEEEEDLLJJJBJIHIEEDIEDMBJJILJJGAEECFEECLJJFCBJIFEDLAIECCBJF@LJFFEECAIECLJJIKBJFIEECFEDMLJJFLJIHFEDMIEC@CBIKBJIHFEDMIEC@LJJFLJF@IEECFDLALJJFCBF@FEDLFEC@CBIHLJIHFEDMIEC@LJJGBJIHFEEBEEC@CBJHJJF@AIEEEDL@@LJJJIH@AIEEEDL@CBJJJJF@FEEEEEC@LJJJJJIHIEEEEEDMLJJJJJJFFEEEEEDLCBJJJJIHAIEEEEC@) (il:rpaqq il:avantbackground2 #*(48 42)HLIHLIKFCBJIMIDLFDNCAIEDHLJFLJDIHLJI@FECIEADLFECHCBIBHJJFCBIMAIDEBEECFEDKHLJJGBJFLJIFLFEDMIDMIECLFCBIHLIHLJFICAIDLFDLFECBIHLJFCBFCBIEDMIECAICAIDJJGBJIKBIHLJAEBEEDNEDLFEDJHJJILJJFLJNEEEECFEDMIDKBJJJFCBIHLIAIEEECAIDLFC@LJJJIHLJFCF@FEDEDLFECAL@CBIBJFLJIHHAAICIECFEDHDCHLFLJFCBIHNFLFLFECAICAKLFCHCBIKBFCAICA@AIDNDLFDBIH@@LJDIHLJEDL@AIEADMIEJJF@CBJJJGBJEEC@FEEEEBEEJJIHLJJJJHJJEEDMIAEEEEDEJBJGBDJJJJIBDIEBDNEEEECIILJHIKBBJJFLCFEECFDIEDLFFCBJFLILJJFCLFEDMICFEECAHLJIKBFCBJIHAIECFDLAIEDLCBJFLIHHLJJFAIDMICALFEEC) (il:rpaqq il:avantbackground3 #*(64 64)JH@@JJJN@@CJJJJJE@@@EEEF@@CEEEEEJH@@JJJKH@NJJJJJE@AAEEEEOOMEEEEEJHBJJJJJOOJJJJJJE@EEEEEEEEEEEEEEJ@BJJJJJJJJJJJJJE@EEEEEEEEEEEGOEJHJJJJJJJJJJJOOJE@EEEEEEEEEEEEEEJ@@@JJHJJJJ@JJJJE@@@EDAEEED@AOOEJ@@@JJBBJJH@@OOJEDDAE@@EEED@@EEEJJJJJHHHJJH@@JJJEEEED@@AEED@BKOOJJJJJBBBJJJ@AEOOEEEE@@@EEEE@EEEEJJJJHHHJJJJHJJJJEEED@@AEEEEDJJKOJJJJBBBJJJJKEEEOEEE@@@EEEEEEEEDEJJJHHHJJJJJJJJHBEED@@AEEEEMGNJHAJJJBBBJJJKNOOD@BEE@@@EEEEGGEED@EJHHHHJJJJOAJJHBJE@@@AEEEEJCOODEEJBBBBJJJKEKKNJJJD@@@EE@@F@CEEEEEJHHHJH@@LAFJJJJJD@@AE@@A@@EEEEEEJBBBJ@@BD@JJJJJJ@@@EE@BDHIMEEEEEHHHJJ@FIAKBJJJJJ@@AED@L@@FEEEEE@BB@JJAH@@LBJJJJB@@AEDA@@HHAEEEE@HHJJJ@HAA@BJJJJH@AEEDA@B@LAEEEE@BJJJJB@DALBJJJJJAEEEDDAL@HAEEEEEJJJJJ@CHC@BJJJJJEEEEEHF@N@AEEEEEJJJJKALAH@BJJJJJEEEEG@@A@@EEEEEEJJJJN@@B@@BJJJJJEEEELH@L@@EEEEEEJJJKHD@H@BJJJJJJEEEG@DE@AEEEEEEEJJJN@@N@JJJJJJJJEEEL@AMEEEEGOEEEJJJH@CJJJJJKONJJEEEH@GEEEEEEEEEEJJKH@NJJJJJJJJJJEEGHCMEEEEEEGOMEJJKHGJJJOOJJJKNJEECOOEEEOOMEEEEEJJBONJJKL@OJJJJJEE@@EEEG@@CEEEGEJH@@BJJN@@AJJJJJED@@AEEF@@AEEEEEJH@@BJJL@@AJJJJJE@@@AEED@@AEEEEE) (il:rpaqq il:avantbackground4 #*(64 64)KKOOOOOOKKKKKKKKNNNNNJNNNNNNNNNNKOOOMGOKKKKKKKKKNNNNJNNNNNNNNNNNKOOOEEGKKKKKKKKKNNNNJJNNL@@@BNNNKOOMEEGKH@@@CKKKNNNJJJNNL@@@BNNNKKOEEEOKH@@@CKKKNNNJJJNNL@@@BNNNKOMEEGKKH@@@CKKKNNJJJNNNLBJHBNNNKOEEEOKKHEE@CKKKNNJJJNNNLBJHBNNNOMEEGKKKHEE@CKKKNJJJNNNNLBJHBNNNOEEEOKKKHEE@CKKKNJJJNNNNLBJHBNNNMEEGKKKKHEE@CKKKNJJNNNNNL@@@BNNNMEEOKKKKL@@@CKKKJJJNNNNNNNNNNNNNMEGKKKKOOOOOKKKKJJNNNNNNNNNNNNNNMEOKKKKOOOOOKKKKNNNNNN@@@@NNNNNNOOKKKK@@@@OOKKKKNNNNNN@@@@NNNNNNOOKKKKAED@OOKKKKNNNNNN@JJ@NNNNNNOKKKKOAED@OOKKKKNNNNNN@JJ@NNNNNNOKKKKOAED@OOKKKKNNNNNN@JJ@NNNNNNKKKKOOAED@OOKKKKNNNNNN@JJ@NNNNNNKKKKOO@@@@OKKKKKNNNNNN@@@@NNNNNNKKKKKO@@@@OKKKKKNNNNNN@@@@NNNNNNKKKKOO@@@@KKKKKKNNNNNNNNNNNNNNNNKKKKKOOOOOKKKKKK@BNNNNNNNNNNNL@@DCKKKKOOOKKKKHAEHBNNNNNNNNNNNLBJDCKKKKKOOKKKKHAEHBNNNNNNNNNNNLBJDCKKKKKOKKKKKHAEHBNNNNNNNNNNNLBJDCKKKKKKKKKKKHAEHBNNNNNNNNNNNLBJ@CKKKKKKKKKKKH@@@BNNNNNNNNNNNL@@@CKKKKKKKKJKKH@@@BNNNNNNHF@NNL@@@CKKKKKKKBKKKH@@@BNNNNNNNFNNNL@@@CKKKKKKK@KKKH@@NNNNNNNNNNNNNNNNKKKKKKKKKKKKKKKKNNNNNNNNNNNNNNNNKKKKKKKKKKKKKKKKNNNNNNNNNNNNNNNN) (il:rpaqq il:avantbackground5 #*(96 94)@@@@@@@@@@BNNNH@BHJJJJH@@@@@@@@@@@AKKK@@@@EEEED@@@@@@@@@@@@NNN@@@@BJJJH@@@@@@@@@@@@CKH@AEDEEEED@@@@@@@JJJJJ@D@@BJHBJJJH@@@@AEEEEEEEE@@@@@@EEEED@@@@BJJJJJJJJH@@@@@BJJJH@@@AEEEEEEEEEE@AEEDEEEED@@@BJJJJJJJJJJ@BJJJJJJJH@@@EEEEEEEEEEED@@@@EEEED@@@JJJJJJJJJJJJ@@@@BJJJH@@EEEEEEEEEEEEEEEEEEEEED@@BJJJJJJJJJJJJJJJJJJJJH@@EEEEEEEEEEEEE@@@@EEEED@@BJJJJJJJJJJJJ@@@@BJJJH@@EEEEEEEEEEEEEEEEEEEEED@@BJJJJJJJJJJJJJJJJJJJJH@@EEEEEEEEEEEEED@@@EEEED@@BJJJJJJJJJJJJH@@@BJJJH@@EEEEEEEEEEEEEEEEEEEEED@@BJJJJJJJJJJJJJJJJJJJJH@@EEEEEEDEEEEEED@@@EEEED@@BJJJJJ@@JJJJJH@@@BJJJH@@EEEEED@@AEEEEEEEEEEEE@@@BJJJJ@@@BJJJJJJJJBJJJH@@EEEEE@@@@EEEED@@@EEEE@@@BJJJH@@@@JJJJH@@@BJJJH@@EEEED@@@AEEEEEEE@@@AE@@@BJJJH@@@@JJJJHJJ@@@@@@@@EEEED@@@AEEEED@@@@@@@@@@BJJJH@@@BJJJJH@@@@@@@@@@AEEED@@@EEEEED@@@@@@@@@@@@@@@@@@JJJJJH@@@@@@@@@@@@@@@@@AEEEEED@@@@@@@@@@@@@@@@@BJJJJJH@@@@@@@@@@@@@@@@@EEEEEED@@@@@@@@@@@@@@@@@JJJJJJH@@@@@@@@@@@@@@@@AEEEEEE@@@@@@@@@@@@@@@@@BJJJJJJH@@@BJ@@@@@@@@@@AEEEEEEE@@@@EEEE@@@@@@@@@JJJJJJJ@@@@BJJJH@@@JJJJEEEEEEED@@@@EEEED@@AEEEDJJJJJJJH@@@@BJJJH@@@@@@AEEEEEEED@@@@EEEED@@@@@@@JJJJJJJH@@@@BJJJH@@JJJJAEEEEEEE@@@@@EEEED@AEEEDJJJJJJJJ@@@@@BJJJH@@@@@@EEEEEEED@CK@@EEEE@@@@@@@JJJJJJJH@NNL@JJJJH@JJJJAEEEEEEE@CKKJ@EEEE@@EEEDBJJJJJJJ@BNNN@JJJJH@@@@@AEEEEEED@CKKK@EEEE@@@@@@BJJJJJJH@FNNN@JJJJH@JJJ@EEEEEEE@@CKKK@EEEE@@EED@JJJJJJJ@@FNNN@BJJJH@@@@@EEEEEED@@CKKK@@@AE@@@@@@JJJJJJH@@FNNN@@@@@@@@@@@EEEEED@@@CKKK@@@@@@@@@@@JJJJJH@@@BNNN@@@@@@@@@@@EEEEED@@@CKKJ@@@@@@@@@@@JJJJJH@@@@NNL@@@@@@@@@@@EEEEE@@@@@CK@@@@@@@@@@@@JJJJJ@@@@@@@@@@@@@@@@@@@EEEED@@@@@@AEED@@@@@@@@@JJJJH@@@@@@BJJJ@@@@@@@@@EEEED@@@@@@@@@@@@@@@@@@@JJJJH@@@@@@@@@@@@@@@@@@@EEEE@@@@@@AEEE@@@@@@@@@@JJJJ@@@@@@BJJJ@@@@@@@@@@EEEE@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AKH@@@@@@@@@@AEEE@@@@@@@FNN@@@@@@@@@@BJJJ@BJJJ@@KKKH@@@@@@@@@@@@@@EEEE@ANNNH@@@@@@@@@@@@@@BJJJHBKKKH@@@@@@@@AEEE@@EEEE@CNNNL@@@@@@@@BJJJ@@BJJJHFKKKH@@@@@@@@@@@@@@EEEE@CNNNL@@@@@@@@@@@@@@BJJJHFKKKHAEEED@@AEEE@@@EEEE@CNNNLBJJJH@@BJJJ@@@BJJJHFKKKHAEEED@@@@@@@@@EEEE@CNNNHBJJJH@@@@@@@@@BJJJHBKKKHAEEED@@CKI@@@@EEEE@AFNN@BJJJH@@NNN@@@@BJJJH@AKH@AEEED@AKKK@@@@EEEE@@@@@@BJJJH@@NNN@@@@BJJJH@@@@@AEEED@CKKKH@@@EEEE@@@@@@BJJJH@BNNNH@@BJJJJH@@@@@AEEED@CKKKH@@@EEEE@@@@@@BJJJH@BNNNH@@@BJJJH@@@@@AEEED@CKKKH@EEEEEE@@@@@@BJJJH@BNNNH@JJJJJJH@@@@@AEEED@CKKKH@@@EEEE@@) (il:rpaqq il:avantbackground6 #*(96 84)KKKKKKKKKKKKKKKKKKKKKKKKNNNNNNN@FNNNNNNNNNNNNNNNKKK@@KH@@@CKKKKKKKKKOKKJ@@@@@HH@@@@@@@@NNNNNNNH@@@@@@@@@@@@@@@AEEMMEEE@@@@BBBBB@@@@@@@BJJJJJJJH@@@@@@@@@@@@@@@EEEEEEEE@@@@HHJHH@@@@@@@JJJJJJJJH@@@@AED@@@@@@@@MEEEOFJJJ@@@BBJJB@@@@@@AJJJJNKEEE@@@@EED@@@@@@@EEEEEEEEEE@@@HJJJH@@@@@@JJJJJJJJJJ@@@@EEE@@@@@@@JJJJJJJJJJ@@@BJJJB@@@@@AEEEEEEEEEE@@@@EEE@@@@@@EEEEEEEEEEE@@@HJJJHH@@@@BJJJJJJJJJJ@@@@EEE@@@@@@BJJJJJJJJJJ@@@BJJJB@@@@@EEEEEEEEEEE@@@@EED@@@@@@EEEEEEEEEEE@@@HJJHHH@@@@BJJJJJJJJJJ@@@@AE@@@@@@@@JJJJJJJJJH@@@BBBBB@@@@@@EEEEEEEEE@@@@@@@@@@@@@@@EEEEDEEEE@@@@@HHHH@@@@@@BJJJHBJJJ@@@@@@@@@@@@@@@@JJJ@@BJH@@@@BBBB@@@@@@@@EED@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@KKKJ@@@@@@@@@@@@@@@@@@@FNNNN@@@@@@@@@@@@@@@@@@CKKKKKH@@@@@@@@@@@@@@@@@FNNNNNN@@@@@@@@@@@@@@@@@KKKKKKKH@@@@@@@@@@@@@@@@NNNNNNNL@@@@@@@@@@@@@@@CKKK@CKKH@@@@@@@@@@@@@@@FNNN@@NNN@@@@@@@@@@@@@@@CKIO@@CKK@@@@@@@@@@@@@@@FNAO@@BNN@@@@@@@@@@@@@@@KKBOH@AKK@@@@@@@@@@@@@@@NNGOH@@NN@@@HHH@@@@@@@@AKKCOH@@CJ@@@@@@@@B@@@@@@NLCOH@@FN@BBBBBB@@@@@@@AKHCO@@@CJ@@@@@@@HHHHHH@BNH@N@H@FN@HHHHHH@@@@@@@CK@AM@@@CJ@@@@@@@BBBBBBNNN@BJJBBFN@BBBBBB@@@@@CKKKKME@@@KK@@@@@@@HHHHHNNNNNNJHHNNNNHHHHHH@@@@AKKKKKKKKKKKKK@@@@@@BBBBFNNNNNNNNNNNNNJBBBBB@@@@CKKKKKKKKKKKKKJ@@@@@HHHHNNNNNNNNNNNNNNNHHHHHD@@@CKKKKKKKKKKKKKJ@@@AEJBBBNNNNNNNNNN@@NNNBBBBJD@@@KKJ@CKKKKIOLCKKH@AEEJHHHNNKOHNNNNOOOBNNLHJJJE@@AKKOONCKKKOOOKKKH@EEEJJB@NOOOOFNNNOOOHNNNJJJJED@AKKOOOCKKKOOOMKKHEEEEJHHHNOOOOJNNOOOOLNNLJJJJED@AKKOOOKKKKOOOMKKHEEEEJJBBNOOOOJNNOOOOLNNNJJJJ@@@@KKOOOKKKKOOOMKKH@EEAHHHHFOOOOJNNOOOOLNNLHHHH@@@@CKOOOKKKKOOONCKH@@@@BBB@@COOONBFNOOOHBBFBBBB@@@@@AOOO@@@@OOOL@@@@@@@LGOL@AOOOHHHHGOOHHHHHHHHKKKKKKOON@@KKKON@@@@@CHAOOOOOOOOKNOOOOO@@BBBCOOONNNNNNNNNNNNNNNNFL@@NNNNOOOOOOOOOOOOOOOOOOOOOOOOKKKKKKKKKKKKKKKKKKKKKKKKOOOOOOOOOOOOOOOOOOOOOOOONNNNNNNNNNNNNNNNNNNNNNNNOOOOOOOOOOOOOOOOOOOOOOOOKKKKKKKKKKKKKKKKKKKKKKKKOOOOOOOOOOOOOOOOOOOOOOOONNNNNOOKNNNNOONNNOONNNNOOOOONNNNOOONOOOOOONOOOONKKKKKKKKKKKKKKKKKKKKKKKKNNNNNNNNNNNNNNONLNNNNNNNKKKKKKKKKKKKKKKKKKKKKKKKNNNLNNNNNNNNNNNNNNNNNNNN) (il:rpaqq il:avantbackground7 #*(64 42)JJJJJJJJJJJJJJJJEEEOMEEEEEEEEEEEJJJ@JJJJJJJJJJJJEEE@MEEEEEEEEEEEJJJ@JJJJJJJJJJJJEEE@MEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEGOEEEEEGOJJJJJJJHBJJJJJHBEEEEEEEDCEEEEEDCJJJJJJJHBJJJJJHBEEEEEEEDCEEEEEDCJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEOMEEEEJJJJJJJJJJ@JJJJJEEEEEEEEEE@MEEEEJJJJJJJJJJ@JJJJJEEEEEEEEEE@MEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEGOEEEEEEEEEEEEEJHBJJJJJJJJJJJJJEDCEEEEEEEEEEEEEJHBJJJJJJJJJJJJJEDCEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEEJJJJJJJJJJJJJJJJEEEEEEEEEEEEEEEE) (il:rpaqq il:avantbackground8 #*(50 60)OOOOOOOOOLOO@@@@OOOOOOOIO@OLL@@@OOOOOOOKMAOCL@@@OOOOOOOO@ALOL@@@OCOOOOOLBCCOL@@@LOOOOOOB@@OOL@@@COOOOON@DCOOL@@@OOOOOOLD@GOO@@@@OOMOOOH@HOOLL@@@OO@OOOHH@OOCL@@@OLAOOO@AAOLOL@@@O@AOOOA@AOCOL@@@L@COON@@CLOOL@@@@@COON@@CCOOL@@@@@GOOL@@DOOO@@@@@@OOOL@@COOL@@@@@COOOH@@OOO@@@@@@LOOOH@@OOL@@@@@CAOOO@@AOO@@@@@@LAOMO@@AOL@@@@@@@COON@@CO@@@L@@@@CKKN@@CL@@C@@@@@GOOL@@A@@@L@@@@@OGGL@@@@@C@@@@@COOOH@@@@@L@@@@@LNNN@@@@@C@@@@@@AOOH@@@@@@@@L@@@AMN@@@@@@@@C@@@@COH@@@@@@@@L@@@@CNC@@@@@@@C@@@@@GHA@@@@@@@L@@@@@F@@@@@@@@C@@@@@@@@@@@@@@@L@@@@@@N@@@@@@@@@@@L@@@GL@@@@@@@@@CL@@@GOH@@@@@@@@OH@@@COO@@@@@@@COH@@@CMON@@@@@@OOH@@@AOMN@@@@@COO@@@@ANOO@@@@@OL@L@@@HONOH@@@CO@@L@@@LOGOH@@@ONAAL@@@LGOGL@@@OLFAL@@@NGKON@@@OLHAL@@@NCOKN@@@GIHCL@@@NCOOO@D@GI@CL@@@FAOOOH@@CI@CL@@@FAOOOHBBCI@GL@@@N@OOOL@@AH@GH@@@L@OOONAAAL@GH@@@L@GOON@@@L@OD@@@HAOOOO@HHN@NL@@@@GOOOOH@@GAOL@@@AOOOOON@DGMO@@@@GOOOOOOH@CN@@@@@OOOOOOON@CL@D@@@OLOOOOOOHALAL@@@OCOOOOOONALGL@@@LOOOOOOOOHIOL@@@COOOOOOOONOOL@@@) (il:rpaqq il:avantbackground9 #*(30 30)@@@@@F@@@F@@AL@@AN@@GL@@GN@AOH@@OL@CO@@DOH@GO@ALOH@ON@GLO@AOLAOLN@COHGOLL@GOAOOLH@OOGOOL@AOOOOOL@OOOOOOLGOOOOOOLOOOOOOOLGOOOOOOL@OOOOOOLHAOOOOOLL@OOGOOLN@GOAOOLN@COHGOLO@AOLAOLOH@ON@GLOH@GN@ALOL@CO@@DGN@AOH@@AN@@OH@@@G@@CL@@@A@@@N@@@@@@@C@@) (il:rpaqq il:avantbackground10 #*(60 50)@EEEEEEEEEEEEEE@OJJJOOOOJJJJJJJ@HGOO@@@@MEEEEEE@H@@@@@@@GJJJJJJ@F@@@@@@@AMEEEEE@KH@@@@@@@JJJJJJ@EF@@@@@@@EEEEEE@JK@@@@@@@BJJJJJ@EEH@@@@@@AEEEEE@JJH@@@@@@AJJJJJ@EED@@@@@@@MEEEE@JJN@@@@@@@FJJJJ@EEE@@@@@@@EEEEE@JJK@@@@@@@BJJJJ@EEEH@@@@@@CEEEE@JJJL@@@@@@AJJJJ@EEEF@@@@@@AEEEE@ONJKH@@@@@@JJJJ@@COEL@@AOL@EEEN@@@@NJ@CN@COCKO@@@@@ANAL@@@@ON@@@@@@@BN@@@@@@@@@@@@@GO@@@@@@@@@@@@COJL@@@@@@@@@@@OMEG@@@@@@@@@@@@JJJL@@@@@@@@@@@@EEG@@@@@@@@@@OO@JJL@@@@@@@@COJJ@EE@@@@@@@@@EEEE@JN@@@@@@@@@JJJJ@EH@@@@@@@@@MEEE@J@@@@@@@@@AJJJJ@D@@@@@@@@@AEEEE@L@@@@@@@@@BJJJJ@GL@@@@@@@@CEEEE@JKN@@@@@@@BJJJJ@EEEL@@@@@@GEEEE@JJJL@@@@@@FJJJJ@EEEH@@@@@@EEEEE@JJK@@@@@@@JJJJJ@EEF@@@@@@@MEEEE@JJL@@@@@@CJJJJJ@EEH@@@@@AMEEEEE@JK@@@@@ANJJJJJJ@EF@@@@OOEEEEEEE@JL@AOOJJJJJJJJJ@EHCOEEEEEEEEEEE@O@FJJJJJJJJJJJJ@HAMEEEEEEEEEEEE@HBJJJJJJJJJJJJJ@) (il:rpaqq il:avantbackground11 #*(60 44)HGOIOOOOOOONNAO@L@GMOOOOOONOOMO@N@AOOOOOOOO@GLA@OK@GON@@OOOO@OO@OL@@@@@@AONAOOO@ONB@@@@@@GOOKOO@OOLB@@@@@COHMNH@HGL@H@@@@AOON@O@OON@GNAOH@GOOOO@OMOH@BJ@@@AONCO@OLGLFMED@@@GOOO@OOCN@@@@@@@AOOO@@GOJ@@@@LN@@COH@@AOK@@@GOH@@@@@@A@GOL@GL@@@@@@@@AH@GHGN@@G@@@@@@@@@@MH@@@HD@@@@@@@@OL@@MOCL@@@@@OOOO@@C@@@@@@@C@OOOL@@@@@@@@@OO@OOO@@@@G@@@AOOO@OOL@@@@D@@@GOOO@AOH@@@@@@@@OOOO@ON@AN@@@A@AOOH@@CL@G@FFNF@CO@OO@OH@D@H@@@@COOIO@O@@@A@@@@@GOK@A@N@@@BAO@@@GOLGO@L@@@D@@@CHNCO@I@KN@@D@CGN@NOAOO@GOO@HF@@@AOOL@G@GOOO@@N@@AOOOOO@ONOOAHAOLCOAHCN@ONON@GN@@CONCOM@OIOL@@@@@GOOOOC@OCOH@@CL@GOAAAO@OOO@CJL@@OOOOOO@OOL@@@@@AOOOOOO@OO@GOOL@COONNGO@OL@@F@@AOON@OOO@O@@@@@@OOLOOOOM@N@@@@OOOOMOOOOO@HGOOOOOOOOOOHKN@IOOOOOOOOOOHGO@@) (il:* il:|;;| "Other bitmaps") (il:rpaqq *eye-bm* #*(54 30)@IJN@@AA@@@@@D@@BBJIDKH@@HDBD@@@HIBOKNOLDA@BE@@@@LHJMKOO@@AA@@@@ABEFDDIEGM@@@D@@HAEKBJNMMDHAE@@@KFH@@KONCJA@@@@@@IEEECOJMFHAE@@@DF@BGOOOONEDH@@@@KEACOOOOEBBED@@A@HGNOOOMOOKJH@@@J@JMOOOOONJN@@@JABCBOEOEOOOJH@@ADAGDKONKOONN@@@@DJMAGONHGOOJH@@BHJNDKONAGOON@@@BBCI@GOJHKNIA@@@D@KLACEMAEOMDH@@IDDA@IJH@K@@@@@@B@ADBDODEGNIB@@@H@H@A@@EBD@@@@@@EBA@DBI@IEJB@@@@@@@@B@BEBE@@@H@@@DDD@D@@@H@DD@@@B@B@A@D@HBI@BD@@@DA@JA@@A@@@@@@@DA@@@@A@@DHEA@@@BHBB@@DAD@A@@@@@@C@@HL@H@@@@J@@@I@@@@@@@@D@@@@@@) (il:rpaqq *fract-bm* #*(128 128)DADADAA@AA@D@AA@HHH@B@HH@HHBHBHBHBJ@J@HJBB@HHJBA@DEAA@DDEA@E@EDA@ADDEADEDDEAAE@BL@JHHJBBJBHJBBH@HBH@JHHBJBBBHJHA@AEADDDEDAAE@ADADE@@A@DDDDDEAE@NO@JHJBBBBB@H@@JBHJ@HHJHBH@HJ@H@MA@A@EA@ADAEAA@EAAD@@AA@EDAADE@BJMD@JBHHBJ@HH@@BHBHHBJB@BHBHHH@@A@@@AAADAD@DEDAADEADE@D@E@DAA@@ONOO@@HHB@J@B@JBHJBBJJBH@B@HBJH@MMAM@AEDA@D@ADEEDDDDEDE@@@AAD@@BOJMOD@@BHH@@@JBJBBJ@@J@J@HBBJB@@GA@G@@DEDDA@E@E@@ED@ADAAA@DEDD@NNNOGG@BBJB@HHHBH@BHH@HBBBBHJH@@LLMAAC@@AEADDDDA@AAA@@@DDDDAE@@BJJJMEED@@JHBBBB@@@H@@H@B@@J@HH@@@@A@@@@@AA@E@@D@A@@DA@@EAAADEA@OOONOOOO@HJBHHHJ@@HBJ@JBHH@BBB@@MMMMAMMO@@DDD@AADE@EEAAAEA@E@EDBOOOJMOOODBJ@J@HJHHHJJHHHJHHHBBB@GGGA@GGG@DDDAAAEAAAEE@EEEAAADDDNOONNOGOOGBBBHHHJJJ@J@JBHJJB@JB@LMMLMAAMMC@DE@DEEADE@A@EAEDDA@EBJOOJJMEOOEDJ@HBBJHJ@HH@JH@J@JHJ@@GG@A@@GG@@EAE@E@AE@ADA@@DEADEDONONONOOGOGOBJBHJB@@HB@B@JJJJJHHMLMLMMAMAMAMAAEEEEE@D@@DAAEDDAEBOJOJOJMOEOEODJHBBJHHB@JBBBJHHBB@G@G@GA@G@G@G@DDAAEDDDEDADEAA@DDNNNNNNNOGGGGGGBB@HHJBHBHBHBB@BHHLLLLLLMAAAAAACAAD@DDADA@E@DDDEEBJJJJJJJMEEEEEEDJJBBB@J@JB@BBH@J@@@@@@@A@@@@@@@@E@ADD@DEDE@E@EADOOOOOOONOOOOOOOOBHJ@J@JBJ@BBHJ@HOMMMMMMMAMMMMMMOA@EADD@E@A@DE@@BOOOOOOOJMOOOOOOOD@@JB@H@BBBJB@B@GGGGGGGA@GGGGGGG@D@DEDDDDDEEDD@NOOOOOONNOGOOOOOOG@BBJJBBHHJJ@H@LMMMMMMLMAAMMMMMMC@A@EEAAEAADAABJOOOOOOJJMEOOOOOOEDHHBHHJ@@@BHJ@@GGGGGG@A@@GGGGGG@@EAD@@@E@@DDDONOOOOONONOOGOOOOOGOBBB@@JH@HBJHMLMMMMMLMMAMAMMMMMAOAEDA@A@ADDABOJOOOOOJOJMOEOOOOOEODHBBH@@BJHJ@G@GGGGG@GA@G@GGGGG@G@EAED@DEAADNNNOOOONNNNOGGGOOOOGGGBHHJB@H@BHLLLMMMMLLLMAAAAMMMMAAAAD@A@ADEAFJJJOOOOJJJJMEEEOOOOEEEFHJBH@HHB@@@@GGGG@@@A@@@@GGGG@@@ADAA@EDDEOOONOOONOOONOOOOGOOOGOOOJBBJ@HHJMMMLMMMLMMMMAMMMAMMMAMMMEAA@AE@FOOOJOOOJOOOJMOOOEOOOEOOOF@JHBJ@@GGG@GGG@GGGA@GGG@GGG@GGGA@EDE@ENOONNOONNOONNOGOOGGOOGGOOGJ@JBHBLMMLLMMLLMMLMAAMMAAMMAAMMCDADE@FJOOJJOOJJOOJJMEOOEEOOEEOOEF@JHHH@GG@@GG@@GG@A@@GG@@GG@@GG@AAADAONONONONONONONOOGOGOGOGOGOGOHBHBMLMLMLMLMLMLMMAMAMAMAMAMAMAMDA@FOJOJOJOJOJOJOJMOEOEOEOEOEOEOF@@HG@G@G@G@G@G@GA@G@G@G@G@G@G@OA@ANNNNNNNNNNNNNNNOGGGGGGGGGGGGGGHBLLLLLLLLLLLLLLMAAAAAAAAAAAAAAADBJJJJJJJJJJJJJJJMEEEEEEEEEEEEEED@@@@@@@@@@@@@@@AEEEEDEEEEEEEEEEEDADADAA@AA@D@AA@JJJJJJJJJJJJJJJJHBJ@J@HJBB@HHJBAEEEEEEEEEEEEEEED@ADDEADEDDEAAE@BKCCCCCCCCCCCCCCDHBH@JHHBJBBBHJHAGGGGGGGGGGGGGGG@DE@@A@DDDDDEAE@NHO@O@O@O@O@O@OA@HJ@HHJHBH@HJ@H@MEMEMEMEMEMEMEMD@AD@@AA@EDAADE@BJKOCOCOCOCOCOCODABHHBJB@BHBHHH@@AGGGGGGGGGGGGGOHBEADE@D@E@DAA@@ONH@OO@@OO@@OO@AAABBJJBH@B@HBJH@MMEEMMEEMMEEMMED@JDDEDE@@@AAD@@BOJKCOOCCOOCCOOCDADJ@@J@J@HBBJB@@GAGGGGGGGGGGGGGJ@JD@ADAAA@DEDD@NNNHOOO@OOO@OOOA@EDHH@HBBBBHJH@@LLMEMMMEMMMEMMMF@JHA@@@DDDDAE@@BJJJKOOOCOOOCOOOEAA@@@H@B@@J@HH@@@@AGGGGGGGGGGGGJBBJDA@@EAAADEA@OOONH@@@OOOO@@@ADAA@J@JBHH@BBB@@OMMMEEEEMMMMEEEFHJBHEAAAEA@E@EDBOOOJKCCCOOOOCCCAD@A@JHHHJHHHBBB@OGGAGGGGGGGGGGGBHHJBE@EEEAAADDDNOONNHO@OOOOO@O@EAED@@JBHJJB@JB@LMMLMEMEMMMMMEMDHBBH@A@EAEDDA@EBJOOJJKOCOOOOOCOAEDA@AH@JH@J@JHJ@@GG@AGGGGGGGGGGBBB@@JDA@@DEADEDONONONH@OOOOOO@@EAD@@@@B@JJJJJHHMLMLMMEEMMMMMMEDHHBHHJ@DAAEDDAEBOJOJOJKCOOOOOOC@A@EEAAJBBBJHHBB@O@G@GAGGGGGGGGG@BBJJBBDADEAA@DDNNNNNNNHOOOOOOO@D@DEDDDHBHBB@BHHLLLLLLMEMMMMMMMD@@JB@H@@E@DDDEEBJJJJJJJKOOOOOOOA@EADD@EJB@BBH@J@@@@@@@AGGGGGGGGBHJ@J@JBDE@E@EADOOOOOOONH@@@@@@@E@ADD@DEJ@BBHJ@HMMMMMMMMEEEEEEEDJJBBB@J@@A@DE@@BOOOOOOOJKCCCCCCAAD@DDADABBBJB@B@GGGGGGGAGGGGGGGBB@HHJBHBDDEEDD@NOOOOOONNHO@O@O@DDAAEDDDEHHJJ@H@LMMMMMMLMEMEMEMDJHBBJHHB@EAADAABJOOOOOOJJKOCOCOAAEEEEE@D@@@@BHJ@@GGGGGG@AGGGGGGBJBHJB@@HBE@@DDDONOOOOONONH@OO@@EAE@E@AE@AH@HBJHMLMMMMMLMMEEMMEDJ@HBBJHJ@H@ADDABOJOOOOOJOJKCOOC@DE@DEEADE@@BJHJ@G@GGGGG@GAGGGGGBBBHHHJJJ@JDEAADNNNOOOONNNNHOOO@DDDAAAEAAAE@H@BHLLLMMMMLLLMEMMMDBJ@J@HJHHHJADEAFJJJOOOOJJJJKOOO@@DDD@AADE@E@HHBH@@@GGGG@@@AGGGG@HJBHHHJ@@HBEDDEOOONOOONOOONH@@@@AA@E@@D@A@@@HHJOMMLMMMLMMMMEEED@@JHBBBB@@@HAE@FOOOJOOOJOOOJKCC@@AEADDDDA@AABJ@@GGG@GGG@GGGAGGG@BBJB@HHHBH@BE@ENOONNOONNOONNHO@@DEDDA@E@E@@EBHBLMMLLMMLLMMLMEMD@@BHH@@@JBJBBE@FJOOJJOOJJOOJJKO@AEDA@D@ADEEDDHH@@GG@@GG@@GG@AGG@@HHB@J@B@JBHJDAONONONONONONONH@@AAADAD@DEDAADHBMLMLMLMLMLMLMMED@JBHHBJ@HH@@BH@FOJOJOJOJOJOJOJK@A@EA@ADAEAA@EA@HG@G@G@G@G@G@GAG@JHJBBBBB@H@@JBANNNNNNNNNNNNNNNHAEADDDEDAAE@ADA@LLLLLLLLLLLLLLMD@JHHJBBJBHJBBH@BJJJJJJJJJJJJJJJHDEAA@DDEA@E@EDA@@@@@@@@@@@@@@@A@HH@B@HH@HHBHBHB) (il:rpaqq *mandala-bm* #*(42 42)KGKB@DAAKMH@MKJH@D@DKKD@FMFDDDDEEFL@KFJ@AE@@MMH@EKE@EEDAFKD@FLM@FNJAGFL@KDN@KOJ@NKL@NKF@IOB@MLL@IGKAOEOAKO@@GIMANDOAGBL@LFFJLDJJLMD@B@A@EEGA@@@@I@@AIOC@@AH@D@AAHHCA@@@@@@FFJNFNL@D@@AOGBGIOOH@@AFGHBNIBLE@@HCFALDFAMH@@@MLL@NBFGF@@@CHGEEGDCH@@OOOOOKOOOOL@@CHGEEGDCH@@@MLL@NBFGF@@HCFALDFAMH@@AFGHBNIBLE@@@AOGBGIOOH@@@@FFJNFNL@D@D@AAHHCA@@@@I@@AIOC@@AH@B@A@EEGA@@@@LFFJLDJJLMD@GIMANDOAGBL@IGKAOEOAKO@@NKF@IOB@MLL@ODN@KOJ@NKL@FLM@FNJAGFL@EKE@EEDAFKD@KFJ@AE@@MMH@FMFDDDDEEFL@MKJH@D@DKKD@KGKB@DAAKMH@FIMDB@@EGBL@) (il:rpaqq *static1-bm* #*(79 27)CIBJGIGNBOMGJEEFJAHHECHGML@CIOKHIICLFLBLGHAHGN@GALFOLOLHIHMFOFOIMMOAOJHHBEBNIOJNJMNNHJNCLMILD@HCLDCFCADCAMLGKEELKOO@AGMFC@AHCBG@JCMMDBDLLFAFCBJNFMANHNMNKONHFAIDCGLBMCLBMDMID@DABNI@CMAKJNGJF@MFKOACK@IJBHJIEE@K@HLIDAKFHLHN@CLLJCNIMHOFKLOLODJDEE@GDNBLGHHIDFFH@DOBOHI@IEJGCHGFKCDANDELJCKOBBKAKIHIEIABBE@BAEN@DLILKJGFHMKEJGKLGIENI@LFKMHIBDOJJBLBJ@BCBHGBKBGFGFFDJHCLABMHEIAJJMHHMCEHKMLBGGBNKKLJIBGEIIB@IFCLKLLCGNFJNMHO@MM@LALBBKAHOEBJABGJBDC@FNCN@DJONCJKNMI@GGOACAL@EKLALNJHABDDM@GCHNONNEAMIDJONMNMIOONCJLBHGCAABHDO@FOAIDAEKMFGOHLJNLNKKFNHLFECHNF) (il:rpaqq *static2-bm* #*(79 60)JB@ICCCBGJAGE@DEBK@LOLONDMG@HIAHFHELDA@HOLEOA@KLF@IKJDF@GHGDNL@O@AKIIONH@BFOBOOHND@G@AKLIOOOOOJAH@@DN@DC@AKNAOOOOOONGOOLNBF@AAKOEOOOOOONGOOLNFGEIIKOOOOOOOONGOOHNLGOGMKOOOOOOOONF@OJNIGN@OKOOOOOOOONFOGHNKONHEKOOOOOOOOJFHKHNJOFH@KOOOOOOOOHFKEJNJOBH@COOOOOOOMIFKEJNJO@HDGOOOOOOOLANKIJNJNALFGOOOOMOOHNNKLJFJNINGGOOOOLOCJIJKNJJJNMOGOOOOOLGEKHBKOJLJFOOOOOOOOLBFB@FKONIJBOOOOOOOOL@ONHGKONKJ@OOOOOOOOLEJLLGOONJJAOOOOOOOOLO@ENGOONJBAOOOOOOOOMJDANGOONJCAOOOOOONOM@NCNGOONJAAOOOOOONKMEOCNGOONOGLKOEOOONJEGOKNGOON@CGJJOJOMBJIGOONGOONEFOMGMNJJIOKMOONGOONOCODBKOENINKGJOLOOONGNJJKOMEOGAGENJJFKODFL@@@JJM@DHBKOENOJJNFD@@@@BFHANKOM@JBHGLN@@@@ACN@K@@JJJOHKONJ@@@@AK@@O@@@@@BH@@@H@@@@AKGJM@@@@@@@@@F@@@@@CKFGL@@@@@@AO@B@@@@@BJFAD@@@@@@@OH@@@@@BBCN@@@@@@@D@GL@@@@@CFOF@@@@@@@B@CN@@@@@GLKB@@@@@@BA@@@@@@@@EII@@@@@@@AHH@LF@@@@LA@@@@@B@@DOAOED@@@@HM@@@@@A@LBGE@JB@@BAJO@@@@@@HFAEHHEF@@CACN@@@@@@ECINEKB@@@GKFN@@@@@@BINK@CIL@@MNDF@@@@@@EEAIICL@@CHNLB@@@@@BJJLCGDAH@FBBH@@@@@@BEH@L@D@B@LO@H@@@@A@AB@BKOLCLAIIIH@@@@@DBHDNNL@ALCCAM@@@@@@AKEFHDFALHNDIO@@@@@D@OOFLOH@MBMJIJ@J@@ABACBFOBLMIDLNAGEJE@BA@F@CJEKICDFAIAMHD@BNLAGGGMJCFFLG@L@FDMLCEEHEKHNNKB@NLHALAADINFBA@DMOHBJFC@CJCHMEIDEOIJAGGNJHMBIHDNOOMLNJCHLBBJEJOFJCDMMKDMNMINJGED) (il:* il:|;;| "Some new ones") (il:* il:|;;| "*random-bm* is rather large, pieces of it might be useful") (il:rpaqq *tessel-bm* #*(64 64)DDDDOLDDDDGGOLDOHHHHOMHHHHHOOKHOBBBBBJNBBBBGOGGBAAAAAAOIAAACOOOOLDDDDDGOOLDDEMMMNHHHHHIOOMNHHKKKNNBBBBBBCKOOBBGGIKIAAAAAAACOIAAOOGGNDDDDDDDGFDDONNOLOHHHHHHHOHHKCOOKOGOBBBBBGNBBACOCOOKOAAAACMKADDDGMOGONDDDDGEFLHHHKNOOMOMOOHJMOFBBBBOOKOKGOGBBGKGIAAAOGOGOOOMAEFOLDDDDONMOMMODHHIOHHKOLLHHOKNLBBBONBGOKOJBBGONIAAAMACAGOCAACKMDDDDGDDDDDEDDDGOKLHHILHHHHKOLHKOOOJBCKJBBBCOKNBOMOGAAGMAAAAAGKAEONNLDEODDDDDDFOGOMMKHHNOHHHHHINMCCKFNBCNOBBBBBCJAAGMMMAAOOAAAAAADDEOOODDEMOLDDDDHHHOONNHHKOHHHHHBBBBNOOJBBBOJBBBKKAAAKKGAAAOEAAAOENDDGFNLDDDOMGNHKMNHHMMKHHHOJOMBBCOBBCKGNBBBBBBAAACKAAGOIMAAAAAMDDEFLDEOGONDEDOKOHHILHHNOOMNOOOFONBBOJBBNOJOOOKMOGAAOOAAAOEKOOGONNLDEOEDDDOGONOOMMIHHJJOLHHHHIKBKKCGNBCONBBBBBBAAGGOKIAAKOAAAAADDDMOGFDDGOLDDDDHHHKNNMLHHINHHHHKFBBCOKKNBBOOBBBMKAAACGGKIACOOGMDOFDDDNOGMDDEMOOHJKOOHINOKLHHKHHNBNONONCOFKJBBBBMIAAAOMIGMGGMAAAONDDDDGGLNNOOOMGOMIHHHHOOIMOOOJOOKONBBBBOBCNOOGOOGOMMAAACOAAOOKOLOOOOLDDGOLDDDDEHOOOONHHHKOHHHHHBBBNNONBBBONBBBBAAAAMKKOAACIAAAADDDDGGGODDDGNDDDINHHHNOOOHHOMNHHCNBBBCOONJBBCOJBAEMAAAAOMCIAACCA) (il:rpaqq *random-bm* #*(200 200)A@NMFOONDILDIFAMODBLFIDOAOBMBBLEEBNFMHB@@FIIIONMK@@@BEJELBGICOEJDCNHNLJFG@AJFMMOKM@BK@NLDEHK@MIJN@NJLB@@DIL@JGGEABLC@EANCFLAOLCFGMKGJCOHKB@ILFACIKGJDJDGBE@@DD@@MJKOBEGHNGIDDKDN@FFMOIBIAIJDBKHFHMAAM@GO@LACMK@@LJ@CCGNEJODK@IHGEHFDGG@AOMG@D@DNCOJCKLLICIJBKLDICH@@M@N@@GODGEKKD@LMJNAO@KNFHBGABFCLFNBDOC@CCELAMANDLA@@FDHDAJ@ICEGKLLGGJMBDN@MG@EDGIC@INOEOKLOCDFALLKMMME@@IAIIELAFHBFIENLIOEABOEAHGHJOGDEBOAJMEDBJOHFLO@OAKO@@DGNFFAN@NJG@CNODKMJJECNAKCLGHMNMJFOFNIDLBAIGBDHHCN@@JACHHFLLDNOLAGNMOBODBLHFELIJDEMDNINHBIC@MJGNAAHMIE@@MIDHAIGBCG@FDJNGJAKAKGFIOHDOCDLFD@GCIAHCDLDEFGOBJB@@LLJEJGNBDLHFJM@ALDMAMMCAAEIECMNAOOJCALKDFONKJACIJF@@D@JFDDEECKBKMECNKHNDLAKMBNH@BFO@ICALGIMHEBCAHIDAIN@@ICJOONKJ@OIFLA@LDM@MGMDHFFBEMBNLKKCA@IAODJGO@LJJNB@@CNKNBCAHIDACD@NLLCNFAMBIOLCO@@@H@ABAOEJDOKFOM@KBDI@@IFA@JGO@LJKEIDDDJJHJMGNOEODNGLMOCDEHEMEDGNHKKBIIEL@@BKJKNOEM@KCFCGMAE@LLOEOKNNLEDOAOL@AFAOKFAAN@MK@DKJ@@CNODD@MKBIIOIKD@EAKKM@DDCEHLKHEBGCFIHNBGNNIABMCHGH@@NJMKAN@MK@DLBOLMHNLJKOKOF@JJ@LJIKDOEBHENCOLMFAICJN@@BJICNIABMCHCCFMCMICJHHOLGGMDEFOMBLOGGFEECIDNKHGNKM@@NEBJOLMFAICFNLKCMNHDGEGMF@CCLBKKAIG@LIMDDD@INJDFAA@@ADHKIDNKHGNGJLFELCMDENHGJFJMKD@AEDAIODBCKIGDMKAKJH@@EJH@D@IKLBGI@EE@FD@MLHFMHOODCJBOJHHNANJANKODLOJNOD@@C@AHMGDKMDK@KNJBCKABEOGK@LNMNDE@FGIMOFN@@OKCL@GJMK@@JLGDCL@@CENK@AINF@MF@DDKMGNCIBJMEKFDK@MKJIELDMHJI@@@HLDGNAOCHNKMCEFMI@NKCJGOKA@MLADONOJIENAAJK@ICIIEBK@@OCLLDMCLBFJLGOKNIGIKL@ADMNJIOLNIMMIKMBJIOOJKHFNDHI@@CMKCKANGE@EHFGGFFNDJFNNMBHC@LMFOLDAMFNOHJOMGEGIJHB@@KOMBJ@HKAMENKOA@EG@@HL@AFCIBKH@BAGJMENLNDBLO@FMFNG@@ENLLAENFHIKMHHENHGOBBAKNJCAHBCMMEMC@KAI@GLGEMLNKKH@@KB@JKHDMLGFFOEGDNCCMMDCDHHGOLEN@FDFJICJELFAGJJLHDM@@@CM@ANAAABJIDAIAHJNGCGHJECLKHNKGB@@CDFG@IONCOBGEMN@@DKHHOFHBF@HKAOH@@@HKKEENJGCEHHHFCHHNJNOFOBAMKOFDBD@@CBCMGHBLNLKEAINBCOAAMFMMEBFLOAA@OCBEF@DDHODJEKDMJH@@DEGKOMLON@NDDALLHNCGHLM@JEDLCIJJA@LI@IMJEJF@GHM@HD@@MNANHHNMOJIKJNDCCDIEFGEJIAFHFEIKNKAADELCADBOOCMLMM@@ELIAJBEAGGENFIJLDDECEFCCE@@LOGMJIILJGMGHNGDFGKKBOC@@DLCED@KLAKAKFHFD@IOGIDONMLICCEKDCOHAFIDK@FCM@EBHMK@@MOIJGDEBBEGCJIFBLLMBBLAEGGDNLBLBEL@JOMKKDBAMHKGCIM@@GJCHFAOIJLBKAHDCBLJDNM@A@IJK@H@OC@IAKMGKLDKFO@GAEH@@JNB@BGJIMGLKMMFGKOILNOAIFJCNCNENNBFIDHLGHICHFGDFEC@@GMKDDM@ACLOIEGAIJLELBNBALHIDMKJGIHHGHBDONAKAKHJOLK@@EAN@ICH@MCFNKGKFAGDIEOBICGEHMLNDEAKOHIAHCCFMOALCGG@@BIIJNIJAKCNMIGIHD@JKMNFJKLMCMNLLFDJBCLKKKH@OJJIGFM@@OG@GH@EONGLI@@FDJAAGAKFNNN@GGDGOHBIJGCH@EOCFABDFDI@@GAJOCNEHCGNKNAAKGAHODJC@AGLKIFNILOJCBFBG@FKHBJHBHA@@OAMBJGEKKLACNHKANCGELJDILAJE@CHJ@FI@OMAGJHLCLECLFN@@LECNCLF@EHBJDBFHDOEGKJBENJBNN@LEDECDBGIBIO@MINMIOH@@N@EOAADG@CLEBMMLILLBCKEDJGMJLO@EILOAHNFAFDCBNDBNGC@@DBACKLKGJLINFILDJOOECENHEIADMFCDL@JAK@@MKKDOLBMLBJ@@FOIGJAFDFMFDJHEJIEMNNCFCFNMJCFAHCJCJKD@NNIHHJLNJNC@@CMAEHMKKDKDBBMLCJMEKDIJCKJFFGBBILGIFMAFF@MOMGDNGGA@@@NCJHNNILFBLLDOKGEEBDALIHCGIHHHLHJNNAJFKNJDFCACOND@@OELCBF@MMEGDGLHJMMJEEJAJOJHAO@DCNOOGLGCI@LKIFAIA@I@@FBFHFKNJFJCABHCIOBIAFGLLCJDMNFNACKHFEHHNMCO@OJNNJI@@FF@OC@NIAINAIECK@AM@AEHMJOMCFIHFGHMAMKCJFBBKGMB@CC@@BEDDEFKOEFNBAFDIFDJBJGAINKOJEIIELNICMNFCGOEMBCKGAO@@HJHFFGJOOKNJECBKIHH@JDDOJ@IFCBLAAFFO@OMJIAHLEMBIFB@@@BHEMNHBGFLJF@IGBMAKAHBHMGFBJHGNBCGKHDOJECOHGOJGFK@@FL@MEEOMMCOIJG@ODCJGKEOHEAOOEAALFNFOJIFOMKGNOBOOGK@@INKIMDDGOHLACBGENJNGKNFJKIL@LODIBJLLFKNANJAFHHAHOC@@INNCBCNGBIGD@OMGM@LKHFEDMJCJKFNAC@NGAMGBBFDNM@JAGJ@@BNAFJAFHKJ@O@DLBAAJ@LHFCHLGOMOFJEMGHDMEMOELNOAEIO@@@HC@OF@CAIJAEJIGEFNLDGAJFAGACKKAJOGLNJ@K@EA@ANB@DHG@@AAHCEHNHFAAONKMNIICLLEFNKLCOHHDGEFAFCJHHGOLBOBCIMF@@OCAJABAJLDCG@MEKGNMKBA@@CILDBOACEDFOMODKJGICNFFAAJ@@FLK@ONAM@JOGLMEBFCOMBMGIIEGHOJBHBIJCKKCGGGEHIFNNHE@@ODJCGIGCOGLM@@JEDDNLMJNENDNALHHNJDAOH@DOJKOAJCKIHE@@KCDHGE@ENNJDDJIAGJILJIGBMLHLD@DDMDGDCGACOGDDJMHKEM@@HBKCKOB@AEDGMCE@@OGE@HG@AMHNGAFCKGFJKJGAL@HBH@LFMM@@ODDDCINCG@OGCOGLM@KHIFCBBLB@LHHIEMO@LHLE@IEOJHEFML@@EBH@HBDIEG@ABGIGAGBCMJJDDF@CLAC@DBKND@@@BFNFH@HGMM@@DHKA@DLEC@FJLJDIJNEGJGMJ@BOLIFGFEJDLGAAOHHNECOEOIA@@JH@BFNEOGNLIMOBJEGNANOJAONA@NLDEFIHANFDGAJILNDMBNG@@FMMOKKKEBBIAAEBHJGLI@INOBAOJDKJBEIIDBAIJDJB@HNM@FN@@KMKGJDLJDODNH@CGGLBC@OBHODMC@ANF@MLGMFBBBHHFBHEKEG@@HIBIAFNILOLGIEMLHJLONDBEJFBAFMC@JJOECB@DOKOALFHH@J@@KMG@DFGHF@EDLOAFMGDBFOFIDBKJB@@ODAAFCAFFFIOF@DGHOM@@NBGACHBOLBC@CNFGFCABHBBFGDCANCJHMOLLBAIFECIFIDCKGE@@IEDGILMGFGFNJ@EFGNAIE@LHFCI@NMKFJNNNKCMOLOMGHAFIDG@@ENFECJIJDCFFMKIDMOJAGDCLBAAKCHFDFICGFDMFAHHOABC@CH@@AKFLOAMHMFGDOAOBIGFECABDDKOHNOAJHBKAOC@KJCMGIAKLAL@@GCJ@HKFEHFMAJFMMLAKF@NHHICAOCINOLEMBH@B@GHGLFKOHF@@@BKAK@I@COOKCFGMKBBEJGANDHOMLKAIJLMLIEFE@JFAFHLDIGG@@LJGFDIN@MAFFMOIBIJLCBBKIIHBIHGMONB@AFEKHOFOEOCEHAN@@OIFJFKLFKGE@AOMGAMG@OKOMKKECM@HK@KLDMEKAJIJNDLNLNL@@FNONIOLLBBANFHBGACGHDNN@L@OEMOMOJNINONNGKMOGKKNO@G@@NMKKMBHHNIFMFKEDFJGAINCEBGMBMDGJCBCMMMDNF@KMJL@IKN@@LIDKMLG@JNAAHIHJH@LEGCJDIGGGMHALI@@OAKMGNMOBNHNBCE@@NKHFHJBONBGNA@CLCH@@DEIKLKHMDMIKALDHHCDJOOJAKF@HHK@@ACHNMOGDD@NHGCLIBAAOHHMNHFLDIKJDGIIHMIMMAILDJEMGEI@@BJCNGKAH@@MFII@DFFDGAKIKACDBFEDBHHGOBJCEBFKHLAOLMO@@LEG@AMH@NMGC@GMIOIIJDJKCNCIFNJGGKMEOIJFIALDME@JNMG@@INACNHJ@ODAKNIFHDNBBBIJKCDC@FMJJMGJAAIODODLCMLELOK@@NDI@LGHEOCMDHDNBEB@DOKLJ@OIHIFJJKBAKJN@LDLJJNGGO@M@@LBCNLLGDFA@@IJACBIFFFI@LJJBNK@KFOGMNBDKCMAE@HOJMMH@@JLODDIBECLDAHGLDBIIFEBENNCCGELFHJAABHDLDDHEAKAHIAM@@GDBMAEHGCGAAEE@JBCMOLNFFJFNLMNAN@NIOFNACLMHNMFNGKJ@@CABD@DIDMMLBJAHNLDMF@HAHEKBLONNIA@@EHNMNLCMIBBH@OO@@KIKLMJFKBGMHJCFBDK@KJBBA@DNMJCOLMKKKABIAFGMNHLGLNE@@GJFMCOHEBOCCAMHJFDB@GHIBIGEOGCIDNKHFOKDKGALCMD@MA@@@JODKCMNMEGKOKINMAJE@JNBMLAHBKDD@IKLBEHFBKNFDDJHNCE@@KNLFEOBACEAGJNEK@MKHONMKHBFNIHMGDKMDJOAL@LCKNI@E@O@@A@EE@FDHFEKKHGKEMCGAKIJECJNDGDCL@@CENIF@E@F@JHICEN@@JKNJBONKHDODLHHDEDJGKMNJGMEBHMGIOCHNKGFHCKA@OOLCJE@@ODCINDACHHCHGGLEKMDNFHKGACGL@NIECLBFJOGHLHEGDOBNGL@@MKDFMHBJCOM@LADGAJJDONODFJFDKIOANGE@EHOAGDJNOBK@KN@@ICNCNCLGKIHNBANDLADJIMMJH@NAHBOHHKAMDIOLMFAGDIOD@G@@BJGGFMIIKMIHJNHJOEBBOLDLCHAMI@AMNFHIJC@FAMHGOEBBHK@@HKLI@BNNA@IAEMMHJFJ@BAGIBADJFJBLDMLGEGGOMBFCHNEBDA@@H@HENOL@EBBLBNJKAMKIAHHDFFF@BFCHMLDJK@BCMADJ@JHEC@@@NGEKDHJDKH@K@OMHDJNNJCMIOIJON@MBEEJDHDMHGO@@DMMKAO@@KHACAMGKFAJ@LGAAHBACGHGHDNDF@IAADLC@JBOEEHCOAALLOH@@DMLD@FCFNJDDEDBOKBMDFCHBEBCMFLBGMOKJOBFC@B@NLON@MM@@EAKLBONIEFGLOKBJBCIA@OCCBIAMLKCCDHJ@HLBDONCGAFGNOI@@DDBBLMMALLGKBDNIABFNJA@DBIKFJDKBICIKFHKKHLDELLFAK@@@KJHDCABKIAAMCJACCEGIKNKHJCKHCBONGCKAAN@MLNDHIKAMBM@@NFOJLLG@DFJLLOEAHLFMJII@BGKAHNGDD@BGFMHIMDLNBBCKAH@@KFJFD@KJHIJ@IA@@GELNKAHKCCFMK@FCLGFFAOJMFFNNHDJAEH@@CJLFBLHFGMKM@OAMD@JLFA@LKBHOKDBAMKGENGBAMDGLMHNGJB@@KAHDCBMEKFJILGFMKGBIOEIILKCFCLDKDJFLMAMJCDJLA@AHFD@@JGMFGKONOLFCBMBINCNEJEFONKKHGHICH@MGFGDLBLEFLDBMEC@@IFIIIJMMMMB@@N@CDMKKOFMLDG@EKLHONAIANNOKAFHAGACONE@@NOLGFAGLDFJDGOHFLOKFOEFCFFEIGIIHCCJJLHDAEKN@MLFKGF@@MKLMHDBAGIMIB@LMKOBEBCIOALAELMKKKJLHNJJOJFO@OMNJCK@@IDIFDJEEAFAFNNN@COJN@INCNAKJ@HL@ELNKICM@FHNAGCEJEH@@KHCGKG@GD@DC@AGLM@DOOJAKIMFLOGNG@FLHBJCLIIDMGKNJCE@@CHHFFNGC@C@DILAJN@JI@DNECLMCCEIGJJGELEGKKJILMAGKFM@@JFJOADOGEFJBENJC@OAD@KFJGGNNLBOBIOFDANANCGJOMKNEMG@@EAHMJILKOGKEDJGLCFGHO@ENKEAK@H@AFGDMNDIA@FIELODCE@@@NFKIOJOGINENHEI@LKICFFAJEBCLIDBMKHM@LBCAKCKJ@CHIIF@@DI@DFIE@BDCFCFNKOO@HKIDNOC@OFNBNNKMLJLOC@NFJGMEJAL@@BCAKCKJ@CHIJCKJEFBKCOAEAJIOFALFF@OKBOGFLH@MBAHILIC@@LONADFJGHNBCOHCGOEM@BJMEJFFCNINKNIBHKABHCCNIMIJAJK@@DBGCDMBAKLLHNOJIABDEEMDLFIFEAOC@NKGCNAIEELAHHIGLNC@@ABHCCNIMHDCCDEGKCDHGHLGANNBGIDEFKOFMOJAFDIFGJBKHJN@@AIEELAHHONODEBFIKDFHJABEMHHIHFFGJOMAGFECBKHFH@KAKH@@JAFDIFGL@J@FCJG@DEMIKNJJID@@LMMNHBCLAKF@IGCGIKBDJK@@FECBKHFIED@BANOLO@FMJINMKHFLGFEEOMMKAEJG@ODMJGJBIH@@KF@IGCGOODODKG@FDHIFK@GHCHINLIMDDGOOELCBGENIFGHOKO@@EJG@ODMLLGFKCLHFNFK@F@DCJCINODBCNGBOJG@OMGMHKOOJIA@@LCBGEOCMOABNEKBKJGEMB@LDEGBNANJAFHHNFGICA@@JHINEBG@@G@OMGLJFOB@E@FBB@DMOKKOHN@HCBBF@CAJ@IGGLDOKMAMMDNG@@GHDLBAMBNOICJ@LFKJEOK@ILGEAAMOEHNHGAE@AKGJ@GFJOLC@@@GNACEGH@@MBD@CJAN@@@ODJ@@LOC@EABAJONBFJBDEJGGOIGNA@@@EFENHGLNONBFHFKLOMEMJEEJKFLHGENIEBJGHFMBMC@OOMCOI@@GCJAGGLOAKHAGHGDJIKGAHEIOMODKMGMHKNCLONAHJDAFHBGGC@@HAHHBFKHGBBEBELOHOG@HADLKKKCFLB@JMOAAFGLG@BIO@EJAO@@NO@NEDNNLFBJADAGLDFHMJDEOHHBKGEGM@CKLLFEH@ACDENHIJ@@FGM@MGNCBLB@MLH@NODIHAD@DBODCMNHCDEHHIAMJADOEJKLLO@@MCKA@A@HAODHNGEAFBENDCGCJJBGAEKFJHHLAFCMNBBJLFOJLA@@KHMILNJO@FIJFIBBC@MLAMML@NHHEEBGOD@ECLJCLECOELDCOK@@BABOG@CFCEMNKCA@ADGBJLBFNF@@@JEDNKOLBNNGOCILGNJFLC@@KNA@IKIFFAOCAHDLCA@KBEJHLFFMNIAGNFDCIMDLAHAOIJEMGN@@@NIFJCALDGNBCKGHDNLAIGBBANFDGE@A@INICNEMMNJIMFF@@J@@FKALHHEIIALFNBDGJKDHDIGMDBAIJMLNJKDLBLC@BOJJAAHHAF@@GJICGEA@FFIBJMBMCIMCH@ACGMFBCGG@CBHDJFDCHAMEDNAOAO@@NHJKLOEA@HHJFAHJ@DMACLNKECB@DOKOALNIHCKKMDOGDDKHCD@@CEFCFLLO@ACNOLGCJJ@IGG@AFAEKFJIAF@LEHF@IDM@GFJKIDI@@ADJIBNKFMIIJDEHC@CJI@IKHLAEBGOBGFHDCKA@@KBOFKMCOCI@@JN@AOKMOFFEAEBFAAACEFJCCNHJEDNNGGHIFHEGFMNINFLEHB@@@CFKJGCKKCAGJJC@FEHNMLHHGDJIEGNH@OABG@JNGGFIOCDFNHH@@NCANBKHHCE@LCIFHHBEECGECNOD@A@BAGIAOLAGC@FN@DGNDJD@@HEFLFDBODBIOOCK@G@OBKLMMNJLDNJHIOCC@GHGEODAAIAOEL@@@OFGMEBKJDLEKIBCLLDHJCFMFDEFC@CNCEKGGFFCLHG@DOFHILF@@@MONJ@LHMGJBNKDIMAHNNGEHAA@NBINOEANHHBJGFIABDMIEAL@@HAOIINFONLGHCJJJ@GO@EFC@DIEOLAIJMBELGGMMC@GICBNBKK@@LFHBGACDMKJDCOFOOACIJFIANDJEDGMOEAAOEAKKNLOGGECIJA@@CG@EDGICBOOCALDMCIDAIODOMMGLG@HKMJJDANBA@DCLFOEOK@@@AHGHJOEOEFECM@KMCLJJNDDDJIKNBOMOBODNLHFELIBB@MBKIN@@NAKCLCONOA@BFLJIKKBAI@LDNH@GGDGJAK@HHFIOHDFCFGGD@D@@HFELI@HHMCEMACJHDMMJBDCANFHKAHALDMGDDCAAEIOLJHMDOI@@FIOHDBCFG@O@FHDFLGDLGMFGKIAAH@NKHNDLAKOJNHDNFIJDCE@@CAAEIODJHINGLNCIC@FOOBHAABH@J@LDLHIJHDHLFBE@FGOGIM@@KOJNHBFFINEDO@IKEOEBFMNIEGGOHELLCEGFNAHOLCBJKHE@BG@@DHLFCALFGKLGIMDAHGDJFFNLJNLHGDDJKHCFKOOKODBLIBJ@CH@@BIOLCF@KHGNBBLGBKEOKG@A@IOCMBEAEABCNLICBNLJFEGJGHN@@NMKOEFHI@LOGIJKFJICHHJCBNKFIHG@E@HOLMADHCFLABNBAKL@@OJBNMGHEBKF@ADEJJHKMHDEKBNE@IDMHOCKNLDJDDKDNANIMHD@@DGHCFLABOMOCFCLBMHIDMJ@MB@AJFKCMIDDACHKCEHFDNKHHOJ@@KJDDHDNAKKKDOFGAJC@KIOFAIOOCHECMNLLBNFMCBNAOJOGLHK@@OOCEHFDNJHNLOGGHGHFKADKHGF@MNMELCNCLCFHBFO@IHDFICK@@NECJOAOJOBFK@@OKJDGD@KKL@KMCBA@FDAMIKJMLBOEBNJGOCK@@@NJFL@IHCFKBLAAC@CCGNBKMEKNNLJBCKMBNCAKAH@MGKMML@G@@MFKBLEBNJO@HIFOJLGENI@@CAGHCNENF@JCLCENFLNCJKFIA@K@@IHD@BMGKM@HOKAJHIALICICHNCNE@DMI@OLJKJEEG@IJJDHLDO@@CEELOCJKFMAKIILOO@NHOALB@@CBJLNIGDMGFGLFIMDADJJOAJ@@@AJO@IJJDOGK@GOCLKILBFGEDBDBLMFFNNOC@KNCJLGEBBMGGJ@@DGEIMDADJINECHAKJHBOHHKALDBJFG@EGEGND@GFAJBFJ@CDMF@@IBJBLGEBBOGKIAMEOI@AMNFHHJL@IENHGNOCJHK@CGAMKIJNOJ@@FDIIJBFJ@BJHGLBKLNJBLDMLFIDGGKLNCH@DIAAILDDJNNODFC@@HKACGAMKIMM@ICH@ABDDFAANG@AH@DIHJA@IHHCLAIHB@ONMOL@@AAHDDDJNN@ECDKMDBFB@BHBEOLBMOE@@@DMLBGN@EKKBMDN@DN@@H@J@IHBACGB@JIDCG@IONBLN@FGAHNBCOAAMKLIEIBBCIK@JE@@@GOHKCKBMDFCHM@KDGFOBAMHHGG@DCLLHNCGABCLAEMABFJJCBJ@@LHGFBBCIA@OCLFMMLDHODIGG@KOJHDCCDIEFIFKKJGCEGCKLBL@@CMBEMABFNJA@DGGEEJEJF@CLN@LFOJLDDEC@LE@FLIHLFIJII@@@FIH@OCEGIKNKIC@DLCADBMJFCAKFJFD@IOGNCILMC@GEMHKAHK@@E@KFIHLFMJII@BGMOHNGDD@AMGCJLFBLLMBBLAKNNMD@KHFA@L@@IMA@@GELNKAHKCCDHK@FCLGE@BKAHDCBLJDNM@HAKEKGBOOEIN@@) (il:rpaqq *granite-light-bm* #*(100 100)JJJNJJJJJJJNJJJJNJJNJJJJN@@@JJJJJJKJJJKJJKKJJJKJKJJJJ@@@JJNJNJJJJJJNNJNJNJJJJNNJJ@@@JJJJJJJJJJJJJKKJJJJJJJJJJ@@@JJNJNNNJJJJJJJJJJJJJJJJJN@@@JJJJKJJJJKJJKJJJKJJJKJJJJ@@@JJJNNNJJNJNJNJJJJJJJJJNJN@@@JJKJKKJJKJKJJJJJJJJJJKJJK@@@JJNJNJJJJJJJJJNNJNJNJJNJN@@@JJJJJJJJJJJJJJJJJKKKKJJKJ@@@NJNNJNJJNNNJNJNJNJNNNJJJJ@@@JJKKJKJJKJKJJJJJJKJJJKKJK@@@JJJJJJJJJJJJJJJJJJNJJJJJJ@@@JKJJJJJJJKJKKKJJJKKJJJJJK@@@NJJJJNJNJJJJJNJJJJJJNJJJJ@@@JKKJJKJJJJJJJJJJJKJKJJKJK@@@JJJNJJNNNJJJJNJJJJJJJJJJJ@@@JJKJKJJJJJJJJKJJKJJJJJJJJ@@@JJJJJJJJJJJJJJJJJJJNJJJJJ@@@JJJKJJJJJJJJJJJJKJJJJJJJJ@@@NNJNNJJJNJNJJJNJNJJJJNNNJ@@@JKJJJJKJJJJJJJJJJJJJJJJJJ@@@JJNJJNNJNJJJNNJJJNJNJNJJN@@@JJJJKKKJJJJJJJKJKJJJJKKJJ@@@JJNNJJJJJJJJJJJJJNJJJJNJN@@@KJJJJJKKKKKJJJJKKJJJJKKJJ@@@JJNJNJNJJJJNNNJJJJJJJJNNJ@@@JKJJJKKKKKJJJJJJJKJJJJJKJ@@@JJJJJJJJJJJJJJNJJJJJJJJJJ@@@JJJKJJKJJJKJJKJJJJKJKJJJK@@@NJJJJJNJJJJJJJJJJNJJNNNJJ@@@KJKJJKJKKKJJJJJJJJJJJJJKJ@@@NJJJJJJJJJJNJJJNJJJJJNJJJ@@@JJJJKJJJJJJJJJJJJKJKJKJJJ@@@JJJNJJJJNJNJJJJNJJJJJJJJJ@@@KJKJKKJJKJJJJJKKJKJJJJJJJ@@@JJJNJJJJJJNJJJJJJJJNJNJJN@@@JJJJJJJKKJJJKKJJJJJKKJKJJ@@@JJJJNJJJNJNJJJJJJJJJNJNJJ@@@JJJJJJJJKKJJJKJKJJKJKJJJJ@@@JJJNJJJJJJJNNJNJJJNJJJJNJ@@@JJJJKJJJJJJKJJKJJJJKJJJJK@@@JJJJNNJJNJJJJJJJNJNJNJJJJ@@@JJJKKJKKJKJJKJJKJJKJKJKJJ@@@JJJNNNJJJJNJJJNJNNJJJJJJJ@@@KJJJJJJJJJJKJJJJJJKKJJKJJ@@@NJJNJNJJJJJJJJJJJJJNJJJNJ@@@JJJKJKJJJKJJKJJKJJJKJJJKJ@@@JNNJJJNJNNJJNNJNJJJJJJJJN@@@KJJJJJJJJJKKJKJJJKJJJJJJJ@@@JNJNJJJNNJNNNNNJJJJJJNJJJ@@@JKJJJJJJJJKKJJKJJKKJKJJKJ@@@JJNJJJJJJNJJNJNJJJJJJJJJJ@@@JJJJKKJJJJKJJJJJKKJJJKJJJ@@@JNNJJJNJNJJNJJNJJJJNJNJJJ@@@JJJJJJKJJJJKJJJJJJJJKKJJJ@@@NJJNJNJJJJJNJJJNJJJJJNJJJ@@@JJJJJJJJKKJJJJJJJJKKJJJJJ@@@JNJJNJNNJNNJNJJJJNJJJNJNJ@@@JJKKJJJKJKJJJKJKJJJKJKJJK@@@JJNJNJNJJJJNJJJJJJJJJJJJJ@@@JJJKJJKJKJKJJKJJJJJJKKKJJ@@@NNJJNJJJJNJJJJJJNJJJJNJJN@@@KJJKKJJKJJJJKKJJJKJJJJKKK@@@JJJNJJNNJJJJNJJJJJNNJJJJJ@@@JJKJJJJJJJJJJJJJJKJJKJKJK@@@JJJJJJNNNJJJJJJNNNJJNJJNJ@@@JJKKKJJJJKKJJKJJJJKKJJJJJ@@@JNNJJNJJNJNJJJJNJJJNJJJNN@@@JJKJJJJKJJKJJJJJJJJJKKJJJ@@@JNJNJJJNNJNNJJJNJNJJNJJJJ@@@JJJKJKKKJKKKKJKJKJKJJJJKK@@@JJJJJNJJJNJNJJJJJJJJJJJJJ@@@JJJJJJJJJJJJJJJJJJJJJKJJJ@@@JJJNNJJJNJNJNJJJJJJJNJJJJ@@@JJKJJKJJKJKJJKKKJKJJJJJJK@@@JNJNJJJJJJJJJNJNJJJJJJJNJ@@@KJJJJJJJJJJJJJJJKJKJJJJJJ@@@JJJJJJJJJJJJNNNJJJJJJJNNN@@@JJJJJJJJJJKJJJJKJJJKKKJJJ@@@JJNNJJJJJJNJJJNJNJJJNJJNJ@@@JJJJKJKJJJJJJKJJJJJJKJKKJ@@@JNJNJJJJJJJJJJJJJJJJNNNJJ@@@KJKJKJJKJJJJKJJJJJJJJJJJJ@@@JJNJJJNJJJJJJJJJJNNJJJJJN@@@JKJJKKJKJKJJJJKJJKJJKJJJJ@@@JNJJJNJNJNNJJJNJJJJJJJJJN@@@JJJJJJJJJJJKJJJJKJJKJJJJJ@@@NJNNJNNNJJJJJNJJJNJJJJJJN@@@JJJJJKJKKKJJJKJKKJJKJJJJJ@@@JNJJJJNJNNNNNJJJNJNJNJNJJ@@@JJKJJJKJJKJKJJKJKJJJJJJJJ@@@NJJJJNJJJNJJJNJJJJNJJJJNJ@@@JJJJJJJJJKJKKKJJJJJKJKJJJ@@@JJJJJJJJJJJJJJJJJJJJJJJJN@@@JJJJJKJJJJKKKJJJJKJKKJJJJ@@@NJJJNJNNJJJJNNJJJJNNJJNJJ@@@JKKKJKJJKJKJJKJKKKJJJJJJK@@@NJJJJJJJNJJJJJJJJNNJJJJJJ@@@JJJJJJJJJJKJJJJJJKJJJJJJK@@@) (il:rpaqq *granite-medium-bm* #*(100 100)JJJNNJNNJNNJNJJJJNJNJNJJJ@@@KKKJJJJJKKJJKKKKKJJJJJJJK@@@NJJNJJJNNJJJJJJJJJNJNJNJJ@@@KJKJKJJKKJJKJJJKKKKJKJJKJ@@@JJNNNNJNNJNNNJNJJNJJJJJNJ@@@JJJKKJJJJJJJJJKJJJKJJJKJJ@@@JJJJNNJNJJJNJNJJNJNJNNNJJ@@@JJKKJKJKKJKKKJJKJKJKJJKKK@@@NJNJJJNNNJNJJJNJJJJJJNNJN@@@KJJJJJJKKJJJKKKJKKJKKJJJJ@@@NJJNNJJNNJJJNNNNNJJJJJNJN@@@JJKJJJKJKJJJKJKKJJJJKJJJJ@@@JNJNJJNJNJJJJNNJJNJJJJJJJ@@@JJKKJJKJJJJKJKJJJKKKJJJKJ@@@JJJJNJJNJJJNJNJJNJJJNNNJN@@@JKJKKKJJKKKJKJJKKJJJKJKJJ@@@JJJJNJJJNNJNJJJJNNJJJNNJJ@@@JKJJKJKJJJJJKJJJJJJKKKKJJ@@@NJNJJJNJJNJJJJJJNNJNJNJJN@@@KKJJKJJJJKKJKKJJJKJKJJKJK@@@JJJJJJJNJJJJJJJJJJNJJJNNJ@@@KJKJJJJJJKJKJKJKKJKJJJJJK@@@JJJNJJJJJJNJJNJNJNJJJNJJJ@@@KJKJKKJJKJKJJJJJJKJJJJKJJ@@@JJJNNNJJJNNJNNJJJNNNNJJJN@@@JJKJJKJKJJJKJJKKJJJJJJJJJ@@@JJNJNNNNJNJNJJJJJJJJJJNJJ@@@JJKJJKJJKKKJJJKJJJJJKJKJK@@@JJNJNJJJJJJJJJNNNJNJJJJJJ@@@JJKKKJJJKJJKJJJJJJJKJJJKJ@@@JJNJNNJNNJJJJNJNJJJNNJJJN@@@KJJJKKKJJKJKKJJJJJJKJJKKK@@@JJNNNJNNNJNNNJNJNJJJJJNJN@@@JJKJJJJKJJKKKJKJJJJKJKJKK@@@NNJNNJNNJJJJNJNJJJJNNNJNN@@@JKKKKJKJJJJKJKJJJJJJJKJKK@@@JJJJNNJNJJJJJNJJJNJJNJNJJ@@@JJJKJJJJJJJJJKKJJKJJJJKKJ@@@JJNJJJJJNJNNNJNNJJJJJNNJN@@@KJJKJJKKKJJJKKKKJKJKJJJJJ@@@JNNJJNJNNJJJNJNNJJJJJNNJJ@@@JJJJKKJJJJJJJJJJJJJKJJKJJ@@@NNNJJJJJJNJJNJJJJNNJJJNJN@@@KJJKJKKJKKJJKJJJKJJJKJJJK@@@JNJJNJJNJNNJJJNNNNNNNJJJJ@@@JJKJJJJJKJJJKJJJJJJJKJJKJ@@@NJJJNNJJJNNNJJJJJJJJNJJNJ@@@JKJJJJJJKKJJKKKKJJJKJKJJJ@@@JNJJJNJJJJJNNJJJJNNJNJJJN@@@JKKJJJKJKKKJJKJJJJJJJKJJJ@@@JJJNNNJNJJJJJNNJNJJNNJJJJ@@@JJJJKKJJKJJJKJJJKKJJKJJJK@@@JNNJJJJNJNJJJNJNNNJJNJNNJ@@@KJJJJJJKKJJKJJKJJJJJJJJKJ@@@NNNJJJJNJNNJJJJJNJJJJNJNJ@@@KJJJKJJJKKJJJKJJKJKKJJJJJ@@@JJNNJNJJJJJJNJJNJJJJJNJJJ@@@JKJJKJJJJJKJJKKJJJKJKJKKK@@@JNJJJJNJJJNJNJNNJJJJJJNNJ@@@JKJKJJJJJJJKJJJJJJKJKJKJJ@@@JNJJJJJJJNJNNJNJJJNJJNJJJ@@@KJKJKJJJKJKJJKJJJJJKKKJJJ@@@JJJJNNNNJJJJJJJNNNNJJJJJN@@@KJKJKKJJKJJJJKJJKKJJJJJJJ@@@NNNJJJJJJNJJJJNJNNNNNJJNN@@@JKJKJKKJJJKKJJJJJJKJKJJKJ@@@JJJJJJJJJNJJNJJNJJNJJJJJJ@@@KKJJJJJJKJJJJKJJKJJJJJKKJ@@@NNNJNJJJJNJNNNJJJJJJJJNNJ@@@KKJJJKJJJJKJJKJJJJJKKJJKJ@@@JJNNNJJJJJJJJNJJNJNJJJJNJ@@@JJKJJJJKKJJJKJJJJKKKJKKKJ@@@JNJJJNJNJNJNJNNNNNJJJNJNJ@@@KJKJKJJJKJJJJJJJJJKJJKJKJ@@@NJJJNJJJNJNNNJJJJNJJNNJJJ@@@KKJJJJKKKJJJJJJKKJJJJJJJJ@@@JNNJJJJJNJNJJNNJNNNJNJNJJ@@@JJJKKJJKJJJJJJJJKKKJKJJJK@@@JJJJJJJJJJJJJJNNJJNJJJNJJ@@@KKKJJJJJJKKKJJKKJKJJJJKJJ@@@NJJNJNJJJJNJJJJJNNJNJJJNN@@@JJJJKKJKKJJJKKJJJJKJJKJJJ@@@JJJJNNJJJJNNNJJNJJJJJJJJJ@@@KJKJKJJKKJJKJJJJJJJKKKJJJ@@@JJNJJJJJJJNNJJJNNNJJJJNJJ@@@JKJJKKJKKJKJJJJKJJKJJJJJJ@@@JJJJJNJJJJNJJNJJJJJJJJNJJ@@@JJJJJJKJKJJJJKJKJKJJJKJJK@@@JJNNJJNJNJJNNNNJNNJJJJJJN@@@JKJKJJJJJJJJJJKJKJKJJJJJK@@@JJJNJNJJJNJJNNJJNJJJNJJJJ@@@JKJJKJJJJJKJJKKJJJJJJJJJK@@@JNJJNNJNNNJNJJJJJJJJJJJJN@@@JKJJJJJKJJKJKKJJKKKJJJJJK@@@JNJJNNJJJNJNNNJJJNJNJJNJN@@@JKJJKKJJKJKJKJJJJJJKKJKJJ@@@JJJNJJJNJJJNJNNJNNJJNJJJJ@@@JKKJKJKJJJJKJJJJJKJJJJJJK@@@NJJNJJJJJJNJNJNJJJJJJJJJJ@@@KJJKKJJJJKJJJJJJJJKJKJJJK@@@) (il:rpaqq *granite-dark-bm* #*(100 100)NNJNNJJJJNNNNNNNJNJNJNJNJ@@@KJJJKKJJJKJJKKKKJKJKJJJKJ@@@NNNNNNJJNJJJNJJJNNJJJNNNJ@@@JKKJJJKKJKKJKJKKKJKJJKKJK@@@JJJNJNNJJJJJNJJNJNJJJJJJN@@@KJJJJKJKKJKJKKKKJKKKKJKKK@@@JNJNJJJNJNNNJJJNNJJJJNNJN@@@KJKKKKKKKJKKJKJJKJKKKJKJJ@@@JNJNJJJJNJJNJJJJJNJJNNJNN@@@KKKJKJKKJJJJKKJJJJKJKJJKJ@@@JJNJJJJJJNNJNJNNNNNJJJNJN@@@JJKKJJKJJJJJKKKJJJKKJKKKJ@@@JJNNNNJNJJJJJJJJJNNJNNJJJ@@@KKKJJKJKJJJKJJKKJKJKKKJJK@@@NJJNNJJNNNJNJNJNNNJNNJNNN@@@KJJJJKJKKKKJKJKKJJKKJJJJJ@@@JNJNNNNJNNJJNJNNJNNNJJNNN@@@JJKJKKKKKJJKJKJKJKJKKKJJJ@@@NNNNNJJJNJJJNJJJJJNNJNNNN@@@KJJJJKKKJKJJJJJKKKKKKJKJK@@@NNJJJJNNJNJJNNNJJJJJJNJJJ@@@JKJKJKKKKJJKKKKKKKKKJKKKJ@@@JNNJJNJNNJJJJNJNNNJNJNNNJ@@@KKJJJJJJJJKKKJJKJJKKKKJJK@@@JNJNJNNJJNJJJJNJJJJJJNJNJ@@@KKJKKJJJKJKKJJKKKJJJKJJKK@@@NNNJJJNJNJNJNJJJJNJJNJJJJ@@@JJKJJJKJJKKKJKJKKJJJJKKJJ@@@NJNNJNJNNNJNJJNNJNJJNNJNN@@@KJJJKJJJKKJJJKKKJJKKJKKJK@@@NJJJNNJNJJNJJNNJJJJJNNJNJ@@@KKJKKJKKJJKKJKJJJKJKJKJJK@@@JNNJJJJJNNNJNNJJJNNNNJNNN@@@JKJJKKKKKKJKKJJKKJJKKKKJK@@@JNJJNJJNNJNNNNNNJNNNNJJJJ@@@KKJJJKKKKJJJJJKJJJKJKJJJJ@@@JNNJNNJNNNNNNNJJJNJJJNJJJ@@@JJJKKKJKJKJJJJKKKJKJJJJJK@@@NJJJNJJNNJNJNNNJJNNJNJNJN@@@JJJJJJJJJKKJKKJJJKKJJKJKK@@@JJNJNNNJNNNNNNJJJJJJJJJJJ@@@KKJKJKKJJKJKKKJJJJJKKJJKK@@@NNNNJNJJNNJJNNJNJNNJNNJNJ@@@KJKKJKJJKJJJJKKJJJKJKJJJK@@@NJJJNJNNNNJJNJJJJNNNNNJJN@@@KKKJJJKJJJJKKKJJKKKJJKKJJ@@@JJJNNJJJNNJNNJNJNNNJNJJNN@@@JKKKKKKJJKJJJKJJJKKJJJKKK@@@JJJNNNJJNJJNNNNJJNJNJJNJN@@@KJJJJKJKKKJKJKKKJJJJKJJKJ@@@JJNNNNNJNJJJJNNNNJNNJJJNJ@@@JKJKJJKKKKJKKJKKJKJJKKJJJ@@@JNNNJJJNNNNNNNNJNJJNJNNJN@@@KJKJJJJKKJJKJKJJJJKKJKJKJ@@@NJNJNJNNJJJJJJNNJJNJJNNNJ@@@KKKJJJKKKJJJJKJKJKJKKKKKK@@@JJNNNJJNJNJJJNJJNNJNJNNNJ@@@JJJKKKKJKJJJJJJJJJKKJKKJJ@@@NNNJNNJJNNJJNNNNJNJJNNNNJ@@@KKKJKKJJJKKKKJKKKKKJJJJKJ@@@JNNNJNJJJNJNNJNNNNNJJNNJN@@@JJJJKKKJKJKKKKKKKKJJKKJJK@@@NJNJJJNJNNNJJJNNJJJJNNJNN@@@JKKKKKKKJKKJKJJKJKKKJKJJJ@@@JJJJNJNJJNNNJJNNNNNJJJJJN@@@JJKJKKJJJKJKJKKJKKJJKJKJK@@@NJNNJJJJJJJJNNNJJNJJNNNNJ@@@JJKKJJKJKKJJJJKJKKKJKJKKK@@@JNJJJJNNJJJNJNJJJNJNJJNNJ@@@KKJJKKJKJKKJKKJKJKJJKJJJK@@@NNJNJJJNJJNJNJNNNNJNJJJNN@@@JJKJJKJKJKJJJKKJJJJJJKJKK@@@NJNNNNJNNJJNJNNJNNNJJNNNN@@@JKJKKKKKJJKJKJKJKJKKKJJJK@@@JNJJNJNJJNNNNNJJNNNJNNNJN@@@JKKJKKKJKKKKJJKKJJJJKKKJJ@@@NJJNJJNNNNNNJNNJJNNJJNNNN@@@KJKKJJJJJKKKJKKJJJKKKKJKK@@@NNJJNJNJJJJNNJNJNJJJJJJJN@@@KKKKKKKJKJJKJKKJKJKJJJKKK@@@JJJNNJJNNNNNJNNNNNNNNNNJJ@@@JJJJKJKJJJKKJKKKKJKJKJKKJ@@@NNJJJNJNJNJNJJJJNJJNJJJJJ@@@JKJJJKJJKKKJKJKKJJJJKKJJJ@@@NNJJJNNNJNJJNNNJNNNNJNJJN@@@KJKKJJKKKJKKJKJKKJKJKJKKJ@@@NJNJNNJNJJNJJJJNNJJJNJNJJ@@@KKKKKJKJJKKJJKKJKJKKJKKJK@@@NJNNJNJJNJNNNJNJJJJNJJJNN@@@KKKJJJKKJJJJKKJKKKJJKJJJK@@@JNNNNJJJNNNJNNNJJNJNNJJNN@@@JJJKJKKKJJKJJKJJJKJKJKKKJ@@@NNJNNJNNNNNNNJJJNJJJNJJJJ@@@JJKKKJKJKJJJJKKKJKJJJJJKK@@@JJJJJNJNNNNNJNJNJJNJNNJJN@@@KJKKJKKJKKKJJJJJJJKKKKKJK@@@JNNJNJJJJNNJJNJNJJJJNNJNJ@@@KJKKKJJJKKKKKKKKJKJJKJKKJ@@@NJJNJNJNJNJNNNJJJNJNNNJNN@@@KJJKJKKJKKKJJKKKKJKKKJJKK@@@) (il:rpaqq *tweed-bm* #*(200 200)@@HH@HHH@HH@H@@HH@@H@H@H@H@H@@H@@@H@HH@@@@HHHHHHH@@@BDBDDBF@BFDBDBF@FDBFF@@BFDDFBD@BB@FDDD@B@D@BF@FBDB@@DAD@BGGEABDC@EAFCFDAGDCFGECGBCG@CB@ADFACACGBDBDGBE@@DD@@DBBFBDF@FF@DDBDF@FFDF@B@@@BDBB@F@D@@D@FF@D@BDB@@HH@@@@H@HH@H@HH@@H@@@@@@HH@@@@@H@HH@HHHH@HH@HH@H@H@@D@F@@FFDFDBBD@DDBF@F@BFF@BF@BFBDFFBDFB@BBDD@D@FDD@@@FD@DAB@ACEGCDDGGBEBDF@EG@EDGAC@AFGEGCDGCDFADDCEEEE@@@@@@DD@F@BF@DFD@FD@BFD@@F@BFFDDBF@BDDDBBF@FDF@F@BF@@@@H@@@H@HH@@@HH@HHHH@@H@H@H@HHHHH@H@HH@H@@H@@@HH@H@@B@B@@FDDDFFD@FFDFBFDBD@FDD@BDDDDF@F@B@B@DBFF@@@D@D@@EAD@AAGBCG@FDBFGBACACGFAG@DGCDDFD@GCAA@CDDDEFGGBBB@@DDBDBFFBDD@FBD@@DDD@DDB@@D@DBDF@FFBB@DBDFFFBB@B@BF@@@@H@@@@@@H@HH@@HHHH@H@HH@HH@@@H@H@@H@HHH@@@@HH@@HH@@@BBFFFBB@F@FD@@DDD@DFDD@FFBDDBFDBBB@@@@FDBFF@DBBFB@@CFCFBCA@ADACD@FDDCFFAEBAGDCG@@@@@ABAGEBDGCFGE@CBDA@@@F@@BFF@DBBD@DDDBB@BDFFFDFDFFDDFBDD@DDDDFF@BBB@@DD@@@HHHHH@H@H@@@@H@@@HHH@HHHHH@@H@HH@@@@HH@@@H@HH@@HH@@BFFDD@DBB@@F@BD@D@BBD@DDBD@DB@DBFBF@@FBFFF@@BDB@F@@@FBECAF@EC@DDBGDE@FDBCGCGF@BB@DBACDGEB@EFCGDEFAACBF@@BB@BF@@BDB@BBFDBD@BB@@FDFFDDDFFDBDFFFFDDB@DFB@FFBD@@H@@HHHH@@H@@HHH@HHH@@@@H@@@@H@HH@H@@HHH@@@@HHH@@@@@@@D@B@DFB@FFFBDFDDBDDDF@FBFBDBD@@DD@@FDBBB@FDDB@BB@@@EB@@D@ACDBGA@EE@FD@ED@FE@GGDCBBGB@@FAFBAFCGDDGBFGD@@B@@@DFDBDDB@BFBBBB@BDFFB@DFDFDD@FF@DFFF@@FBBD@FBDB@@HH@@@H@@@@HH@@HH@@H@@@@HH@H@H@HH@H@@H@HHHH@H@HHHH@@@@DDFF@FB@FBDBDFD@@FBBBFFB@@DD@DFFFB@DF@@BB@@B@@DBB@@GCDDDECDBFBDGGCFAGACD@ADEFBAGDFAEEACEBBAGGBC@FFD@A@@BDBBB@FFD@D@FFFFFFDBFFFDB@B@DDFFDD@DFFF@BFDFDF@B@B@@HHH@H@HH@H@HHH@@@@@@HH@@@@H@HH@@@@HH@HHH@@HH@@H@H@@@DFDD@DFF@@BD@@DF@FFBB@BFBB@@BBDDDDB@B@@@FDFDDDFBB@@@CB@BC@DEDGFFGEGDFCCEEDCD@@GGDEF@FDFBACBEDFAGBBD@DE@@@BD@@F@@@BB@D@@@@BFFBF@BDBDB@FBFB@@BDFF@@FFBFBFDDF@@@HHHH@H@@@HH@HH@@@HHH@@HH@@@HHH@@HHHHHH@H@@HHH@@@@@@BBBDF@BDFDBD@@FBBF@@DFDDDBFDF@@@FBBDF@DD@FDBDBDDB@@@DEGCGEDGF@FDDADD@FCG@DE@BEDDCABBA@DA@AEBEBF@G@E@@D@@DF@F@@FDFB@BBFDBBD@DFFDB@@F@FD@BFB@@DDDB@DBFFBDDDD@@@HH@H@@@@@@H@HHH@@@@@@@@@@@HH@HHHHHH@H@HH@@@@HH@H@@@DDBDD@BD@B@BF@FD@@FF@DFFDD@BBDBDBF@@F@DB@FBD@DB@DB@@EGABGDEBBEGCBAFBDDEBBDAEGGDFDBDBED@BGECCDBAE@CGCAE@@FBB@F@F@BDBB@@DBBDBDFD@@@@BB@@@FB@@@BDFBDDBFF@F@D@@@HH@@@@HHH@HHHH@@HHHHHH@H@H@H@H@HH@@H@HH@HH@H@@@@@@@@FDBDDD@@BDF@DF@@BDDDBFB@D@@DDBBF@@@F@BDFF@B@B@BFDB@@EAF@AC@@ECFFCGCFAGDAEGBACGE@EDFDEACG@AA@CCFEGADCGG@@B@@BF@B@BBFD@F@@D@BBDFFBBDDBDFDDFDBBBDBBB@@FBB@FFD@@H@@@H@@HH@HH@@@@H@@@@H@HHH@@@@@HH@HH@@H@@H@@@@@@@H@@F@BFBFD@BFFBF@@BF@@FDBB@@FDB@FF@DFBBBFBF@FB@BB@B@@@@GAEBBGECCDACF@CAFCGEDBDADABE@C@B@FA@GEAGB@DCDECDFF@@DDBFBDF@D@BBDBF@DFDFBBBDFBBFF@DDDDBDBF@B@F@D@FD@F@@@H@@H@@@@@@H@@HHHHHH@@H@@H@HHHH@@HHH@HH@@@@@@H@@H@@@@DB@BBDBFBD@FF@DDBFFDBDF@D@@DDFBDD@B@B@@DBBDFDBDDBB@@FGAGBAFDFEFDB@EBAEEFFCFCFFEBCFA@CBCBCD@FFA@@BDFBFC@@BD@D@DBBDBDBBDDBBDDBD@BBBBFFFBB@DF@FD@FF@DFDFDFFF@@@@H@HHHHHH@@HH@HH@@@@@@HHH@@HHHHHHHHH@H@HHH@@@@@HH@@@FDDBBF@DDDFDFD@BDDBDDB@BFB@@F@DBFFFFDFB@@DB@F@@@@@@@FBF@FCFBFBCAB@CAGBAAFGDDCBDEFFFACC@FE@@FECG@GBFFBA@@FF@FB@F@@@F@@DBB@@D@@D@DBFDBF@@FF@D@DBBBFBBBFDB@BB@@@@@@@@HH@@H@@@@H@@H@H@@HHHHH@HH@HHH@HH@@@H@H@@H@@H@@@B@FFFBFFBFBDBBB@@@@BDDFB@@FBBD@@FFF@FDB@@@DDDB@FB@@@B@EEF@BGFDBF@AGBEACA@B@EGFBB@GFBCGC@DGBECG@GGBGFC@@FD@DDDFDDBF@BF@FDBBFBDF@D@FFD@@DFFFFB@FFDBFFFBFFFB@@HHHHH@@@HHH@@@@@HHH@HH@HHHH@HH@H@HHH@HH@HH@@HH@HH@@@@FFBBBFFB@FD@FDFD@DB@FDDDBBBBFF@B@FF@DFBBFDFD@B@FB@@BFAFBAF@CB@G@DDBAAB@D@FC@DGGEGFBEEG@DEEEGEDFGAEAG@@@@B@FF@B@@B@DB@FDFFDDF@BF@F@BBB@BFFDFB@B@D@@@FB@D@F@@@@H@@HHH@@@HHHHHHH@HH@@HHH@HHH@@@@@@@HHH@HH@H@@HH@@@FB@B@B@BDDBF@DDBFFDBB@@@B@DDBF@BDDFFDFDBBF@BFFF@@B@@FDC@GFAE@BGGDEEBFCGEBEGAAEG@GBB@BABCCCCGGGE@AFFF@E@@FDBBF@FBFFDD@@BDDDFDDBFDFDF@D@@FBD@F@@DFBBF@BBB@@D@@H@@H@@@@HHH@@HH@@HHHHH@@HHHH@@@@H@@@@@@@H@@@HHHH@H@@@BBBBFB@@DDFDBD@@FFD@@F@@D@FF@FBBFFBBBF@D@@B@@DFDD@@GDDDCAFCG@GGCGGDE@C@AFCBBDB@D@@AEEG@D@DE@AEGB@EFED@@DB@@@BD@DF@@BF@F@FBBDBBDDF@BD@B@DBBFD@@@BFFF@@@FDD@@@HH@@@H@@@@HHH@HHH@@H@HH@@HHH@@@@H@H@@@HHHH@@H@HH@@@B@@BFFDFFFD@DFBBDFF@FFB@FF@@FDDDF@@@FFDF@B@DFDDBFF@@FEEGCCCEBBAAAEB@BGDA@AFGBAGBDCBBEAADBAABDBB@@FE@FF@@BDBFBDDBDFDF@@BFFDBB@FB@FDDB@@FF@DDFDFBBB@@FB@DBDF@@HH@H@@HHHHH@H@HHHHHHH@@@H@@@@H@@HHH@@@@@HHH@H@HH@H@@BDF@DFF@F@DDDF@FDFDBFFF@DBBBB@@FD@@FB@FFF@FF@DF@FD@@FBGAC@BGDBC@CFFGFCAB@BBFGDCAFCB@EGDDBAAFECAFADCCGE@@@DDF@DDFFFFFB@DFFF@@D@D@FB@@FDBFBFFFBBDFDFDF@@F@DF@@@H@@@HHH@@@@HHH@HHH@@@@H@@@H@H@@@H@@@@H@@HHH@@@@@H@@@BFDF@D@DFFDF@FB@FFDB@BDDBF@FF@B@BB@FB@BBBDF@@BD@D@@GCB@@CFE@FEABFEEDACF@F@@ACAGCAFGDEEB@@B@G@GDFCG@F@@@BB@B@@@BFFBBFFDBBBDBF@FD@FDDB@@BDDD@DFD@BF@F@DD@FF@@HH@@@HH@H@@@HHH@HHH@@@HHHH@HH@HHH@@@@@HHH@H@H@@H@H@@F@FBFBDFBFD@@FDF@DF@FBFDBBDBD@@B@BDDDDB@B@BFDDFDFD@@FFGFAGDDBBAFF@BGACG@DFF@D@GEEGEGBFAFGFFGCEGGCCFG@G@@FDBBDB@@F@FDFBDDFBF@@FBDBFDBDDFBBBBDDDDFF@BDBD@@BF@@HH@HHH@@HH@@HHHHH@H@@@H@H@@@HH@HH@@H@HH@HHH@HHH@@@@@FB@F@BBFFBFF@@BDB@@@DD@BDB@DDD@B@DD@@BDBFFB@BF@@@B@@AC@FEGGDD@F@GCDABAAG@@EF@FDDACBDGAA@EAEEAADDBEEGEA@@BBBFFB@@@@DF@@@DFFDF@B@B@BDBFDDB@@FFBBBDBFB@D@FDDF@@H@@@@HH@HH@@@@HHHHHH@HH@H@H@HH@@HH@HHH@H@H@H@@HHH@@@@F@BF@B@FD@BF@F@DFBBB@BBBDB@FDBBDFB@@@FDFDDBDDDDFB@@FDA@DG@EGCED@DFBEB@DGCDB@GA@AFBBCBACBF@DDDBBFGGG@E@@DBBFDDFDF@@@@B@BB@FFF@@DBBBFB@BFFFDFBDBBD@D@@FBDD@@@HHH@@H@@@H@@H@H@@HH@@@@HH@@@@H@HH@@@H@H@@H@@H@HH@H@@FDBD@D@FBF@@DD@BBBDFDFFFBFFDDF@F@F@FFF@BDD@FDFFFBB@@CABD@DADEEDBBA@FDDEF@@A@ECBDGFFAA@@E@FEFDCEABB@@GG@@B@BDDBFBBFD@BBFBDB@BBBB@@DFDBBFDDBBB@B@@FFDF@DFDFD@@@H@H@HH@@H@@@HHH@@@@@HH@H@@H@@H@HHH@HH@H@@H@H@@H@@@@BFDBBDFDDFBFB@FD@BD@BFBDD@@BBDD@@BDBD@FBBFFDDB@FBD@@CFDFEGBACEAGBFEC@EC@GFEC@BFFA@EGDCEDBGAD@DCCFA@E@G@@@@DD@FD@FDBB@FBDDBF@B@BDBBFDFDBD@@BDF@F@D@F@B@@BDF@@HHHH@HHHH@H@HHH@@@H@HHHH@H@@HH@HH@HHH@@H@H@@HHH@H@@@FDB@FD@B@@B@FFDDBDDFF@BF@BFD@F@DBDBFBFF@D@DFDFBFFD@@ECDFE@BBCGE@DADGABBDGFGDFBFDCAGAFGE@E@GAGDBFGBC@CF@@@BFBFBDFB@@FB@FDD@DB@DDB@@F@@BF@@B@DD@FDDF@FD@FD@F@@@H@@@HHHHHHHHHHHH@@@HH@H@H@HH@@HH@HHH@@@@HH@H@@@HH@@@BD@@BFF@@@@DDD@BFB@B@F@B@DBFBBDDDDFDFFFDBFB@FDBD@@@@@@EFGD@EBBDBFBCAECAA@@DFFF@BFC@EDDBC@BCEADB@B@EC@@@FFDBD@BDB@@B@FD@DBFFBBD@F@BFF@DBDDBD@DD@FF@@DDDB@F@@HH@@@H@H@@H@H@@@H@@@@H@H@H@@@H@@@H@@H@H@@H@H@@HHHH@@DDDD@FBFFBDDDDBFBBDDFB@BDBBDFDBFDFBBFBFB@B@FDFF@DD@@EACDBGFAEFGDGCBBBCAA@GCCBAAEDCCCD@B@@DBDGFCGAFGFGA@@DDBBDDD@DDFBBDF@@BFFB@@DB@BFBDBB@B@BF@BB@DDDDDF@B@@@HHH@@@@HH@@H@H@@@@@HHHHHH@HH@@HH@@H@@H@HHH@HHH@H@H@@FFFBDDF@DFBDDFD@@DFDB@@@BFB@@FFDD@BFFD@@DDDFBBBB@@@@CFBFD@CB@AB@AA@@GEDFCA@CCCFEC@FCDGFFAGBEFFFF@DBAE@@@BBDFBD@FFDBD@F@DD@BDF@@DBB@FBDB@DBFDFFB@DDFDD@FFBB@@H@H@@@H@H@HHH@@HH@@HH@HHHH@@@H@H@H@HH@HH@@HH@@@H@@@@BFDFFBFFFDFBBDB@FBFDBDFFFBB@F@@B@@DFFFDDBDDFDDBDDB@@AFAAABEEEEB@@F@CDECCGFEDDG@ECD@GFAAAFFGCAF@AGACGFE@@FFDFF@FDDFBDFF@FDFBFFDFBFFD@F@@@BBBBD@D@DBF@DDFBFF@@HHHHH@@@@HHH@@HHHH@@@@HH@H@@HHHHHHHHHHHHH@H@HHHH@H@@@D@FDBDD@F@FFFF@BFBF@@FBF@BB@@D@DDFB@BD@F@F@FBDBD@@@C@CGCG@GD@DC@AGDE@DGGBACAEFDGGFG@FD@BBCDAADEGCFBCE@@B@@FFFFB@B@D@D@BF@B@@DFDBDDBBD@FBBFDDDFBBB@DD@FBFD@@H@HH@@H@@@H@@HH@@H@@@H@H@@HHH@H@HH@@@H@H@@HHHHH@H@@@D@@DB@DBFFBDDBFDBFF@F@DFBD@B@@@@FFDDFD@@@F@DDFDBD@@@FFCAGBGGAFEF@EA@DCACFFABEBCDADBEC@E@DBCACCCB@C@AAF@@D@@DF@D@BDBFBFFBFF@@B@DFFB@FFFBFFBDDBDFB@FFBFDDB@D@@@@@H@HH@@HHH@HH@@@H@H@@@HHH@@H@@@HH@H@@HH@H@@HHHH@@@DFF@DFBF@FBBF@BFFDD@BBDDBFFBF@FBF@B@B@B@BBF@D@B@BB@@DBGCDEBACDD@FGBAABDEEEDDFAFEAGC@FCGCFAAEEDA@@AGDFC@@@B@BBF@D@DBBDDFBBD@F@DF@FFBF@DDFBFFDFB@FD@FFBBB@BF@@@H@@H@HHHHH@@@@HH@@HH@@@HHHHH@@@HHH@@@@@@HH@H@H@HH@@B@FD@FFD@B@FBBF@DDD@BFBB@D@@DDDF@BBD@BF@@FBF@BBDBB@@FECBC@FAED@BAFGDG@FEBAFEC@FDGFEEGEECAEBG@GDEBGBBA@@@BF@@FBFFFDFDBF@FD@@FB@F@B@@FD@DDDFFFDDBBFDF@FF@FBF@@@H@@H@HHH@@H@HH@H@H@@@@@H@HHH@@@H@@HH@@HH@HHHHHHH@@@DBBFDFBDF@BFDBBBBFDDB@DDDFBF@FB@F@@FFF@B@@@B@@FDBF@@G@GEGDBFGB@E@FBB@DEGCCG@F@@CBBF@CAB@AGGDDGCEAEEDFG@@F@DDB@DBFF@BB@DFBBDFB@@DFD@@DFD@F@F@D@@BFB@FFBFDB@@@@H@@@@H@@H@@@@H@H@@@H@H@@HH@@@@@@HHH@@H@@@H@@HH@H@@@@DFDF@FDFFFBF@FBDFDDDBDDBBFD@FDF@DBBF@FDBDB@FFDBF@@@GCBAGGDGAC@AG@GDBACGA@EAGEGDCEGE@CFCDGFA@BDAF@BGGC@@@@@@BFB@FBBDBDDF@FF@@@DDBBBBFDB@BDF@@FFDF@B@F@DB@F@@HH@H@@HHH@@H@@@@H@@HHH@@HHH@H@@@H@@HHH@@H@@@@@HHHH@@FFD@DFFBBDB@DD@@FFD@@@D@DBFDBDF@BDD@@@@DB@DFDBBDDF@@ECCA@A@@AGD@FGEAFBEFDCGCBBBGAECFB@@DAFCEFBBBDFGBDA@@B@D@DFBF@F@BF@BBB@DD@DDD@F@@DDBFFD@DBDBBDDBFDDDBFB@@@@@H@@@@@@HHH@@@@@@@HH@@H@@@@H@@HHHH@HH@H@HH@HH@H@@@BF@@@B@FF@FB@@DDB@@BBDB@DFFDF@@FFFDB@DDD@@@F@BDDFF@@@FAFBCADDGFBCCG@DFDAAGBBAFFDGE@A@AFACFEEEFBAEFF@@B@@FB@D@@D@@@DFFBDFBBD@D@FDDB@@BDDFBBDDBDB@BFBB@@@@@F@@@HH@@@@@@@H@HH@H@HH@H@@@@H@@@@@@@@H@H@@@H@H@@H@H@H@@F@BBDFD@@@@BF@@B@DD@BDFBDBB@DFBF@DF@@BBBDDFFDDB@BD@@CEFCFDDG@ACFGDGCBB@AGG@AFAECFBAAF@DE@F@ADE@GFBCADA@@@DB@BFBFD@@BDD@B@BB@@@B@D@DBFFBFF@DBB@@@BBFFBDBFB@@@HH@@HHHH@@@@@@@@@@@@@H@@HHH@@HH@@HH@H@@@HHHH@H@H@@@@BFBBFBBBB@FBBB@FD@FDD@@FDB@DFF@@F@BF@BFFFF@FBDFF@@@@FCAFBC@@CE@DCAF@@BEECGECFGD@A@BAGAAGDAGC@FF@DGFDBD@@@DFDFDBFDB@FFBB@F@FBBDDDFBDDFB@@FBB@F@FDFD@@@@FDD@@@H@@H@@HH@H@HH@@HH@HH@@H@@@@@@@H@@H@@@@@HH@@@H@HHH@@@@DFFB@D@DFBBFBD@D@@FFFD@@@@FB@FFD@F@@BBFF@@BDD@D@D@@@AGAAFFGFDG@CBBB@GG@EFC@DAEGDAABEBEDGGEEC@GACBFBCC@@DF@BF@BDDBBDBFFFF@B@BF@@FDBDDFDFD@@FD@BBFDFFFDB@B@@@@@@@@@H@@HH@@H@H@H@@HH@HHH@H@@HHHHH@@H@@@@@H@H@HH@@@@@F@BFDFDFDBD@BDBDBBFDDDB@BFBFDFBFDFD@FDD@BB@DBB@F@@FACCDCGFGA@BFDBACCBAA@DDF@@GGDGBAC@@@FAG@DFCFGGD@D@@@FDD@@@@DBDD@BB@DDDBBDB@FF@B@@@DDDFDDB@@D@FDB@DDF@@@@HHH@@@@@@H@@H@@H@@H@H@@HH@@H@HHHH@H@HHHHH@H@HH@@@@@B@@D@FDB@@FFDFB@B@FFFB@@@B@@B@DDD@@B@D@DFBD@FFFF@D@@CGBF@BFFAFEDG@ACEGEBFEFAEGGG@EDDCEGFFA@GDCBBC@E@BG@@D@DFB@DFFBDF@DD@@FDBFFFDBFD@FDDBB@BFBFFBFDBD@BB@B@@@@HHH@@@HH@H@@H@@H@HH@@@@HH@H@@@@@@@HHH@@HHH@@@H@HH@@FDBFDF@@@DFF@BBFB@B@@BBBFBF@@F@D@@FDD@D@BFD@BFB@BD@@GBBFEG@EBCF@ADEBB@CE@DECBFE@ADE@GCCFDDBDDCDFAFAE@D@@DF@BFD@BFDFBFBDBD@@DDB@DB@@BFBBD@DD@B@BBD@FDFB@@FB@@HH@@H@H@HHH@H@@@H@@HHH@@HHH@H@@HHHH@H@H@@H@HHH@HHH@@FFBD@FDFB@FDFFF@F@FB@DB@FF@DFDDDBFBDBF@BFF@@@DF@BB@@FECBGAGBGBFC@@GCBDGD@CCD@CECBA@FDAEACBEDBGEBFBGGCC@@@FBFD@@@BFBBD@@B@BBFFBBDDBFFDBBBBDBFB@B@@@DFBDDD@F@@H@H@H@@HHH@HH@HHH@@HH@@@@@H@H@H@@H@H@@H@HH@HH@H@@H@@@@D@BDFBD@@FB@B@@@D@B@B@FBFD@DD@@FDBBBDDF@@BBD@DDF@@CEEDGCBCFEACAADGG@F@GADB@@CBBDFAGDEGFGDFAEDADBBGAB@@@@BF@@BBDFFB@FFBDB@DBFFDDBDBDDFFFFFB@BFBBDFDBBDFFB@@@@@HH@@@HHH@@H@HHH@HHHH@H@@H@@@@@@@H@@@@@H@@H@@@H@@@@BBBDFDBBFFB@@DDF@@@DFF@@BD@@DF@FFFBB@B@BF@DB@BFFB@@FDAABBFB@BB@GDBCDFBBDDEDFADGGCDFC@@DAAAADDDBFFGDFC@@@B@BF@DB@DD@@B@@@BDDF@@FF@@@@D@@B@@@@@BD@@@B@FFDFD@@@@H@@@HHH@@@@HH@@@@@@H@@HH@HH@@@@@HH@@H@@HH@H@H@@H@@@@B@@@B@BFB@B@DBF@@FFBDF@FF@@FBBF@@DBD@D@BBB@B@BD@@@GG@CCCBEDFC@E@CDGFGBAE@@GG@DCDD@FCGABCDAEEABFBBCBB@@D@FFBBB@@@FBDFDDDD@FD@FF@BFB@DBBD@DF@FBBBFBDFBBDBD@@@H@@H@@@HH@@@@@@@H@H@@@HH@H@HHH@@@@@H@@@HHHH@HHHH@@@F@@@FBDF@BFB@B@DDB@DBDBFB@BFBFD@@FFFB@DDB@FDD@B@@B@@E@CFA@DFEBAA@BGEG@FGDD@AEGCBDFBDDEBBDACFFED@C@FA@D@@@D@@@FDDFB@@BBBD@B@FBDFD@BB@@DBBDBDFD@@@BDBFBFFD@F@@) (il:rpaqq *chambray-bm* #*(200 200)@@LLDLLLDHLDHD@LLD@LDHDL@L@L@@LDD@LDLH@@@DHHHLLLH@@@@A@A@@AAAAA@@A@@@@@@A@A@@AAAAA@@A@@@@A@A@AA@@@@@@@@@D@D@@DDD@@D@@D@D@DD@DD@DDD@D@@D@@@@@DD@@@@D@D@DD@D@@@@@@IJKKBACHJCI@@K@J@BBIKIBIAIJ@BKHBHIAAI@CK@HACIK@@LH@@@DLDHLDH@HHDDHDDDD@@LLD@D@DL@LH@HLLH@HH@HLDH@H@@A@@@@AA@AAAA@@@A@@AA@A@@@@AA@@A@@@@@AA@AAA@AAA@@@A@@DD@D@@@@@DD@DDDD@D@DD@DD@DDD@@@@DDDD@DD@DD@DD@DDDD@@IAIIAHABHBBIAJHIKAABKAAHCHJKC@ABKAJIA@BJKHBHK@KAKK@@DDLDD@L@LHD@@LLDHLHHD@L@H@LDHLLLHDLDLHDL@@HD@DHH@L@@@AA@@@@@@@A@AA@AA@A@@@@@A@A@@AA@@A@@@AA@A@A@AA@AAA@@D@D@@@D@@D@DD@DD@@@@@DD@D@DD@DDDD@D@@@@@DDDDDDD@@@@@HHJAJCJB@HHBJI@AH@IAIICAAAIACIJAKKJCAHK@BKJKJACIJB@@D@HDDDDD@H@HLD@LHHLDL@HL@LH@@DL@H@@LDHLHD@@@HHD@HL@@AA@AA@A@@AA@@A@@@A@AAA@@@@@AA@@@AAAA@AAA@@AA@@@@@@@@@D@D@@@@@D@@D@DDD@DD@D@@DD@D@@@@@@@@DD@DD@DDD@@@D@@@IBA@JCK@HJKAI@@@JJHJICJKAK@JCHIKC@AHAIA@CJHKKBIIAH@@@HHHLLDL@H@D@DL@D@LLLDLHLLLDDL@LL@@D@LHD@@L@LH@DHH@@A@A@@@AA@AAAAA@@AAAAA@@@AA@@A@A@AA@A@@@A@@AA@AA@A@@@D@D@@D@D@@DD@DDD@DD@@D@DD@@@@D@@@DDD@@DD@DDDD@@@@D@@BJICJIABICHCCBICIICJHHKHCCI@ABKIBHKCCBAACI@JKHCJKI@@LD@HLLLD@H@DLLH@LLHDDDDLD@@@L@HH@HD@LHLDDD@HLHDD@@@@A@@AA@@A@A@A@@@A@AA@A@@A@@@AA@@AA@AAA@@AAAA@AAAA@@@@D@@@D@@@D@D@@DD@DD@DD@DD@DDD@@@D@@@D@D@@D@DDDD@DDD@@C@AHIC@KI@K@KJJBCKABAKCK@HJIJ@A@BCIIKBJ@@KKCH@CJIK@@HLDD@L@@@DLH@@HLD@LD@DDHLDL@H@HLDHDDH@LHHHDLDLHHH@@@@@@A@AAA@@AAAA@AA@@AA@AAAA@A@A@A@A@AA@AA@A@AAAAA@A@@D@DDDD@D@D@DDD@D@D@@D@@DDD@@DDD@DD@@D@@@DD@@@DDD@@@@CIKCKAJCA@AHBCCBBJ@JBJJIBHC@HIBKH@AIBJKHJKICACIJHB@@HLL@H@HH@LDLHL@@DD@@HL@@D@H@HH@@@DHLDLLLD@LL@DLDLD@@A@@@AA@@@AAA@@A@@AA@@AA@@AA@@AAAAAA@AAA@A@AAA@@AA@@@@@@@@@DDDDDDDDDDD@@DDD@D@@DDDDD@DDD@@@@DDD@D@@D@DD@@@CI@AJAAABJI@AIAHJJCCCHJACHKHJKCB@@C@BC@IKJCKBCAIJ@@DHHHLDH@D@HH@LH@@@HHHDDLHD@DHHHD@HHLHLLDL@@LHLDD@D@@A@AAA@@@@@AAAA@@AAAAA@AAA@@@AAA@AA@A@@@@@A@@AA@A@@@@DDD@DDDDD@DDD@DD@D@D@DD@@DDD@@@@@@D@@@D@D@D@D@D@@D@@IJAJHHJIKJIKJJ@CC@IABCAJIABHBAIKJKAA@AHCA@BKKCIHII@@DLH@H@D@DDDLDHHLDDD@DD@@D@@LLDLHHHLHDLDHLDDDDHH@L@@@@@AA@@A@AAAA@@@@@AAAA@A@A@AAAAA@AA@A@A@A@@AA@A@@AA@@DD@@DDD@@DD@@@D@DDD@@D@DDDDDD@D@DD@@DD@@D@@D@@D@@D@@CJCHBAKIJHBKAH@CBHJ@JI@A@IJK@H@KC@IAKICKH@KBK@CAAH@@HL@@@DHHLDLHLLDDHLHLLL@HDH@L@LDLL@DHDHLDHH@HDDDDD@@@AAA@@A@AA@AAAAAA@@A@@@@A@@A@AA@AA@@A@@@A@AAAA@@A@A@@D@D@@@@@D@DD@D@D@DD@DD@@@DD@DDDDD@@D@@@@@@DDD@D@DD@@BIIJJIJAKCJIICIH@@JKIJBJKHICIJHHB@JBCHKKKH@KJJICBI@@LD@DH@DLLDLH@@DDH@@D@HDLLL@DDDDLH@HHD@H@DL@D@@DDDH@@AA@AA@A@AA@A@AAAAA@A@@A@AA@AA@@A@A@A@@@A@@A@@@@@@A@@D@D@@DD@@D@@D@@@D@DDD@D@D@@D@@@@@D@@DD@D@@D@DD@DDD@@HACJCHB@AHBJ@BBH@KACKJBAJJBJJ@HA@AC@BCIBIK@IIJIIKH@@L@DL@@DD@@LD@LLLHLL@@HDDHDLHLL@DHLL@HLD@DD@@LD@LD@@@@@AAA@AA@@A@@A@@@AAAAA@@AAA@A@A@@@@AA@@AAA@A@@A@@@@@DD@D@@DDDDDD@@D@@DDDD@D@DDD@@D@@@@@@@D@DD@@@@DD@D@@@CIAAHIKK@K@BBIHCJIAK@IJCKJBBCBBIHCIBIABB@IKIC@JCCA@@@L@HHLLHLD@LLDLHDDD@D@LHH@DHHHHLHHLL@HDHLHDD@@@LLD@@AA@A@@@AAAA@A@@@AA@AA@A@A@@AA@@A@AAA@AAA@@AA@AAA@A@@D@D@D@D@D@@@@@@@D@@@DDDD@@DDDDD@@@@DD@@DD@D@D@DD@@@@BB@KC@JIAIJAIACK@AI@AAHIJKICBIHBCHIAIKCJBBBKCIB@CC@@@DDDDDHLDDL@@DDHDDH@HD@HLHLHDHHDLLH@LLD@DLDL@@HD@L@@@@@@@A@AAA@@AA@AA@@@@@@A@@A@A@@AA@@A@AA@AA@@AA@A@@@@@@@DDD@@DDD@D@@D@D@@@@@@DDD@@@DD@@D@@DD@D@D@DD@DD@@@BH@IAAKIICKIJC@K@CJCKAKHAAKKAAAHBJBKJIBKIKCJKBKKCK@@HLHHLDDDLHL@@@DDLHLDHLDHHHL@LLDH@HLLDHL@LH@DHH@HL@@@A@@A@A@A@AA@@AAAA@@A@@A@A@A@A@@AA@@AAAA@@@@@A@@AA@@@@D@D@@D@@@@D@DD@@@@@D@D@@DDDDDD@DDD@DDDDDDDDD@D@D@@@HC@KB@CAIJAAJICABJH@CAJBACACKKAJKCHJJ@K@AA@AJB@@HC@@@@H@DHLHD@@LLHLLHH@LLDDLHL@LHHDDDD@D@HHHDLL@L@@HLD@@AAA@A@A@@@AA@AAAA@AA@A@@AA@@@AAAA@@AAA@A@AAA@@@AA@@@DD@@DD@D@@DDDDD@D@DD@DD@@DD@D@@@@@@@@@@DDDD@@DDD@D@@K@JCCICCKCHI@@JA@@JHIJJAJ@JAHHHJJ@AKH@@KJKKAJCKIHA@@H@DHDD@DLLHDDHH@DHHLHHD@LLHLD@DDLDDD@D@@LDDDHLHHDL@@@@AAAA@@AA@AAAA@@AAA@@A@AA@@AA@AAA@@A@AA@@@@@@@@AA@@DDDD@@D@D@DD@DDDD@@@@D@@@D@@D@@@DDD@D@DD@@DD@@DDDD@@ABH@HB@IAC@ABCICACBCIJJ@@B@CHAC@@BKJ@@@@BBJBH@HCII@@DHH@@DLD@@DHLHDHHLDDHDLH@@LLHDDDDHDLD@@LHHLD@LDLH@@@@@@@@@AAA@@AAA@@AA@A@A@AA@A@@@@A@A@A@@@AA@A@@@A@@A@@DDDD@@@D@@@@@D@@@DD@@@DD@@D@D@@@D@@D@@@@D@@@@DD@DD@@KIKCJ@HJ@K@JH@CCCHBC@KBHK@IC@AJB@IHCIBBBBHHBBHAKAC@@HH@H@DLHLLLDHDLLHHLLLD@DHD@@DL@@HHLD@@@DLHL@LDHH@H@@AAA@@@A@@@A@@AA@AA@@@A@A@@A@@@@A@AA@AA@@@AA@@@A@AA@@D@D@@@@DD@@@@DDDD@@@@@@DDD@@D@@@DDDD@@@DD@@D@D@@DD@@IA@CIHICBCBJJ@ABCJAIA@HHBCI@JIKBJJJJKCIKHKICHABI@C@@DLDD@HHHD@DDLHHDLLH@DD@L@@@H@HDDDH@DDDLD@HHL@@@@@H@@AA@@AAA@A@A@AAA@AA@AAA@@@AA@@AA@@@AAAA@A@AAAAAA@A@@@D@@@@@DD@DD@@DDDD@@D@D@@@@@D@@DDDDD@@@@@D@DDD@D@D@@@BKAK@I@CKKKCBCIKBBAJCAJ@HKIHKAIJHIHIABA@JBABHH@ICC@@LHDDDHL@L@DDLLH@HHL@@@HHHH@HHDLLL@@@DDHHLDLDL@DH@L@@AA@@@A@@AAA@AAAAAAA@AAAAAAAAA@@A@A@@AAAA@A@@@@@@@@@@DDDD@DDD@@@DD@@D@@D@DDD@D@DDDDDD@D@DDDDD@DDD@@DD@D@@JIKKIBHHJIBIBKA@BJCAIJCABCIBI@CJCBCIII@JB@KIJH@IKJ@@LHDHLLD@HL@@HHHHH@LDD@HDHDDDLH@LH@@L@HLDLLL@LHL@@D@@@A@@@@@A@@A@A@A@A@@@@AAA@A@A@AAAA@@@@A@@AA@AA@@@@A@@@@@DDDDDD@D@D@D@@@@D@@DD@DDD@@@DD@@@D@DD@@DD@DDDD@@@BJCJCKAH@@IBII@@BB@CAKIKAC@BBA@BHHCKBJCABBKHHAKHIK@@LDD@@LH@LLD@@DLHLHHHDHH@L@HDLHDDHLDLHHDH@LDLD@HLLD@@A@AA@@@@A@AA@A@@@@@@@A@AA@A@@A@@AA@AAAA@A@@AA@A@AA@@DD@@DD@DD@DD@DD@D@@DD@D@@D@@@D@@@@@@@D@DDD@@DDDD@D@@HBCJHHC@BA@@IJACBIBBBI@HJJBJK@KBKCIJB@KCIAA@HKJIIH@@HLLDDH@D@LD@HDLD@HHDD@DLL@@DDLDHH@@@HDLDDHD@H@HH@L@@A@@AAA@AAAAAAA@@@AAA@@@@@@@@A@A@@@AA@@AA@A@@A@@AA@@@@@@D@D@DDDD@@@@DDDDD@@@@D@@DDDD@@@@D@DDDD@D@@@@@DD@@KIKHIJBKBCIHJCBB@K@KJBBA@@JIJCKHIKKKABIABCIJHHCHJA@@DHDL@LHD@L@@@LHHDD@@DHH@HDDLD@HDLHHDLHDHD@L@LD@L@@@@@A@AAA@AAAAAAA@AA@A@@@@A@A@@A@@@AA@@A@@@A@@@@@@@AA@@@DDDDD@@@D@D@DD@@D@@DDD@@@DD@@DDD@DD@D@D@D@@D@@D@D@@A@AA@B@HBAKKHCKAICCAKIJACJJ@C@CH@@CAJIB@A@B@JHICAJ@@HHLH@LLHHDLDLHHDDDHDHLLHDLD@HLDHL@HLHDDH@H@@LLL@HD@@A@AA@@AA@@A@AA@AAA@@@@AAAAA@@@AAA@@@@AA@@@AA@A@@A@@@D@DDD@@@@DD@D@DD@@@DDDDDD@DD@@D@DDD@D@D@DD@DD@@@@D@@ICJCJCHCKIHJBAJ@HA@JIIIJH@JAHBKHHKAI@IKHIBAC@IK@@C@@@HDDDLHHHLHHHLHHLD@@LLDL@H@LH@@LLDHHH@@D@LHDLD@@HH@@@A@A@@@@A@AAAAA@@@@@@AAA@A@@@@@@@A@AAAAAA@@A@@A@@A@@@@@DDDD@D@@D@D@@@D@@@@@DDDD@@D@@DDD@@@@@D@D@@@@D@@@@JCAK@HJ@KH@K@KIH@JJJJCIIKIJKJ@IBAAJ@H@IHCK@@@IIKAK@@HH@@@LDHD@H@LD@@H@@@DHDHDLDD@H@@DL@@H@LDDH@L@@LLLH@@@A@@@@A@@@@@A@@AA@A@@A@@A@AA@@@AAAA@A@@A@@@@@A@@AA@@D@@D@DD@DDDDD@@@@@@@@D@@@@@DD@@@D@@@@D@DDD@D@DDDD@@@@@BBHIIAHHCKB@JIABBJJA@@BIKBJ@KBICIKBHKKHH@AHHBAK@@@HHHD@@@HH@@L@H@@@DDHHLHHH@HH@@LLD@H@@L@LLLDHHH@L@L@@@@A@@@A@@@@@@AAA@@@A@AA@@AAA@@A@@@@A@A@AA@@@@@AAA@@@@D@DD@@@@@@@@@@@DDDD@@@@@@DD@@D@DDDD@D@DDDDD@D@@D@@@CJHBBHHBCIKI@KAI@@JHBA@HKBHKK@BAIKCAJCBAI@CHIHJCJB@@H@HD@@LDHDHHLDDLHD@HLDHHLH@D@LDHDHDLL@LH@DHL@@@HDD@@@AA@AAA@A@@A@A@A@A@A@A@A@AA@A@AA@@AA@A@@@@A@@@@AAA@@@D@@@@DDDD@@@D@@DD@@DDDDDD@D@D@DD@@@DDD@@D@@D@@DDD@@JKHCBACH@BJ@CKHBHKKBKABCBBAICIIHCCJJHH@AAKJ@IHBKCB@@LHLLHD@@DHLH@@LLHL@D@@HL@L@DLLHHHHLHLHHLHDL@LLLH@H@@A@A@@@AAA@A@@@@@AA@@@A@A@AA@@@@@A@@AAAA@@@@AAAA@A@@@@@@D@D@DD@D@@@DDD@DDD@@@@DDDDDDD@DD@@@@D@@DDD@D@@D@@CHHBBJCC@C@@IHAJJ@JI@@JACHICCAICJJCAHACKKJIHIACKBI@@HDHL@DLDDDH@DLH@@L@D@HDHDDLLL@L@HLDD@L@L@DHLLHLDLD@@AA@A@A@AAAAA@@A@A@A@A@A@AAAA@@@A@A@A@@AA@@AA@A@AA@@@DD@@D@DD@DDD@D@@D@@@DD@@D@@D@D@D@@D@D@@@@@@@@@@@@D@@@I@@BIA@B@CBCBJKKK@HKI@JKC@KBJBJJKIHJHKC@JBJCIAJAH@@@@@H@HH@@HHH@HHDD@H@L@D@HHLD@LDD@LH@LDDLH@L@@HHLH@@@@A@A@@@A@@@AA@AAAAA@@@AA@@@A@A@A@A@@AA@@AA@AAA@A@A@@D@D@DD@@@DD@DD@@@@DDDDDDD@DD@D@@D@D@D@@DDD@@@@DDD@@@ABHCCJIIH@CC@ACKC@HCHHCAJJBCI@ABKKBIKJAB@IBCJBKHJJ@@@HDDL@HHLLLDD@DHHDDHH@@DLHHHHDDDHLL@DDD@@HHDH@H@HH@@@A@@A@A@@@@@A@A@@AAAA@@@A@@@@AA@@@A@AA@@AAAAAA@@@A@@DD@@@@D@DD@@@DDDD@DD@@DD@@DDDDDDDDD@@D@D@DDD@D@@@@@@KB@ICCCKK@K@KC@B@HIBK@CHCHIJHII@@CKKAHCBCAJIBCHKKK@@DHD@LDLLLDDH@LHDLDH@D@D@H@HLLD@@LD@LHD@LLDLHHLLHH@@@@A@AAAAAAA@@AA@A@AAA@@@@AA@@A@@A@@@@@AAAA@@@@A@A@A@@D@DDDD@DD@@D@D@@@DDD@@D@D@@@@@D@@@@@@DDDDD@D@DDDDD@@CH@HBAIBJKICJ@HBKJAKK@IHCAAAIKAHJHCAA@AKCJ@CBJKHC@@@DL@@DDH@@L@D@@H@L@@@LDH@@LL@@D@@@HLL@DH@DDHDDLHDL@@@@A@A@@A@@A@@@@@A@AAAA@AA@A@@@AA@AA@@A@@A@AA@AAAAAA@@D@@@DDDD@@@@D@DD@@@D@@D@DDDD@DDD@@D@DDD@@@D@D@@DD@@@HAHHBBKHCBBABAHKHKC@HA@HKKKCBHB@JIKAABCHC@BIK@AJAK@@LL@LDDLLLD@H@D@DLDDHLHDDLHH@HDDDL@@HLLDDH@@@DDLHHH@@@AA@AA@A@@@@A@@@@A@A@A@@@@A@AA@@A@A@@AAA@A@AA@A@@A@@D@@@@@@@@DD@DDD@D@DDD@D@@@@D@D@D@@@D@D@DD@@@DDD@D@@@KHIIHJJK@BIJBIBBC@IHAIIH@JHHAABCK@@ACHJCHACKAH@CKK@@@@@LD@@D@DLLH@@@@DD@HL@DLD@@@HDDLHLL@LLDL@HLDLHDL@@@A@A@AAA@@AAAA@@@AA@A@A@@@@@A@AAA@@@AAA@@A@AAA@AAA@@@@D@D@@@DDDD@@@D@DDD@@D@@@DDDDD@@@@D@@DDDDD@@DDD@@@@@BKAHHHAIIAHBJB@CJK@H@ICI@BAIJIHJJK@HBHC@BKJJAAHHAB@@DHH@DD@@DDH@HL@L@HL@H@@@DLD@@DD@@@HDHDD@H@LDDL@L@L@@@@@A@AAA@@@@@A@@@@AAA@@AAA@@@AAAA@@A@AAAA@AA@@A@A@@@@DD@DDDD@@@DDDD@@@@@DD@@D@D@D@@@D@DD@D@@DD@DD@@@D@@@A@JIBJKBIIIJ@AHC@CJI@IKHHAABCKBCBH@CKA@@KBKBKICKCI@@HL@@LHLLDDD@D@D@@@@DDH@@LHHDDLLDDHHDHDDDLLHLDLDH@@@@A@A@AAAAAAA@@A@@A@@A@@@A@@AAA@@@AA@A@@@AA@AAA@@@@@@@D@@D@@@@@D@D@@D@@@DD@DD@DDD@@@@@D@@DD@D@@DD@DDDD@D@@HABHB@BK@BIKKCK@C@KBKHIIJJH@JJHIKCC@CHCAK@AAIAKAH@@@LDDLD@HHDLDHH@@LLDHH@DLDDDD@@@L@DHDDDD@LHD@DLDHHLD@@@AA@@@@@AA@@@A@AAA@@@AA@AA@@@A@AAA@@@@@A@AA@@AAAA@@@@@D@@DDDDDD@@@@@@DD@DD@@D@DDD@@@D@DDDDDD@@D@@@D@@@@@HBHBCAC@IKJ@CKBKKACIJBIAJ@JA@CIKAAAKAAKKJHKCCACIJA@@@D@DDDH@@LL@@LDL@HD@HLDLLLDLD@HHLHHD@L@@@D@LDLDLH@@@A@A@@AAAA@AAA@AAA@@@@@@@@AA@@AAA@A@@@@@A@A@@@A@AA@@@D@@@D@DDD@@@DD@@@@@@@@DDD@@DDDD@@@@@@D@D@DD@DDDD@D@@HBAHI@HHICAIACJH@IIJB@CAJBHKAHAH@IC@@CAAAIKHJHI@KI@@DHLHD@@DD@L@DHDDLDDLDLDDHH@@H@LHHLDL@HLHLHDLDHHD@D@@AAAAAA@@@A@A@@AAA@@AA@@AA@@@@@@@@@A@@@@@@@A@@AAAAA@@@D@D@@DD@DDDD@@@DDD@DDD@DDDD@DDD@DDDD@@DD@@@@@D@@D@@@HHBCAHBCKHCII@AHC@JBBJHJJHHC@@JKHCBKKKKK@BHIBJ@CH@@@HLL@D@HHDL@@LD@HDLHD@@@HL@L@D@D@@@LLH@@LLHDDDHDHL@@@AAAA@@A@@AAA@A@@AA@@@A@@A@A@A@A@@A@AA@@A@@A@@@AA@@@D@@DDD@D@@D@@DD@@@@D@DD@@DD@@DD@D@@DDD@DD@DD@D@D@D@@@CHCBHABKIKCBCHBIHI@IJ@IB@AJBKCII@@ACHKCAHB@JKHHKJ@@HHDDHDL@HHHDLDD@H@@HHLD@HLL@HD@LLLL@LDL@@L@LHLDLHH@@AAAA@@@@@@@@AAA@A@@AA@A@A@@A@AA@A@A@A@@@@A@A@@@AAA@@DD@@D@D@D@D@@@D@@DDD@@@D@@D@@@@DD@D@@@DD@DD@D@DD@@@@@JJBH@IHCBKBHAAC@CCCJBKIAKJJHJBCKIBJCAKAH@ICKIIH@C@@LDH@LD@LHL@HHDLHLDDLH@@@@DH@LDLD@H@L@DLDLL@HHDH@@H@@A@@@@AAAA@@AAA@@AA@AAAA@@A@A@@AA@A@@A@AAA@A@@@@@@A@@@DDDD@@@DD@@@@DDD@D@D@D@@@@@@DD@DDDDDDDD@DD@D@@D@@@@@AJK@IJJ@KCK@CKCHKIHBBCA@B@BHIBBJJKC@KJCJHCABBICCJ@@DDDHLD@DHHLD@H@HHH@LHHH@LD@HDD@DDDDLD@DD@H@DH@@DLD@@A@@@@AA@@AAAAAAAAA@AA@@@@@@@AA@@A@AA@@A@AAAAAA@@A@@@DD@@@@D@@@@@DD@@DD@@DDDDD@DDD@DD@@@D@@@@DDD@DDDDD@@@HKACCAIKIII@ICH@AB@@BAAJC@AH@@IHJA@IHHCHAIHB@KJIKH@@@@HDDDHLL@D@DHLD@D@@@H@DLL@LLD@@@DLL@DL@DHH@LDL@DL@@@@@@A@@AAA@@@A@AA@AA@@@@@@AA@@@AAAAAA@AAA@@AAA@@A@@@DD@@@@@DDD@@D@@DDDD@@D@@DD@D@DD@D@D@@@D@DD@@D@@@@@@@HHCBBBCIA@KCHBIIH@HK@ICC@KKJH@CC@IABIBKKJCCACCKHBH@@@L@DL@@DLH@@DDDDDHDHD@@LL@LDLHLDDD@@LD@DLHHLDHHHH@@@@A@@AAAAAA@AAA@@@AA@@A@@AAA@@@@@AAA@AA@AA@AAA@AA@A@@D@@D@@DDD@@@@@DDD@DDDD@@DD@@DD@DDD@@D@@DDDD@@@D@@D@@IIA@@CAHJKAHKCC@HK@BCHCA@BKAH@CBHJ@JI@HAKAKCBKKAIJ@@) (il:rpaqq *canvas-bm* #*(200 200)A@@A@AA@@A@@A@AAA@@@@A@AAA@A@@@AA@@@A@@@@@AAAA@AA@@@BDBDDBF@BFDBDBF@FDBFF@@BFDDFBD@BB@FDDD@B@D@BF@FBDB@@DHL@HDDD@@L@@D@L@DL@LL@DDLHDH@LHH@@HLD@@HHDHDHDD@D@@@@@@ABCCBAC@BCA@@C@B@BBACABAAAB@BC@B@AAAA@CC@@ACAC@@@@@AAA@A@A@A@A@AA@@@AA@AAAA@@@@@AA@AA@@AAA@@A@@AA@@@D@F@@FFDFDBBD@DDBF@F@BFF@BF@BFBDFFBDFB@BBDD@D@FDD@@@DDHD@H@H@DDHLLDDHL@DL@LD@DDDH@@HLLDLHLL@DD@LLHLLLD@@AAAAA@AB@BBAAB@ACAABCAA@C@BCC@ABCABAA@BBC@B@C@CACC@@@A@@@A@@@@A@A@A@AA@@AA@AAA@A@A@A@@A@@A@@@AAA@@@@A@@@B@B@@FDDDFFD@FFDFBFDBD@FDD@BDDDDF@F@B@B@DBFF@@@D@D@@LHDH@HD@@D@DDHLDH@H@HDDHLHDL@DLDD@D@H@H@DLDDDDL@H@@@@@BABCBB@@@BBA@A@@AAAACAAAAACABACCBCA@C@BCBCBACABB@@@@@@@@AAAA@AAAA@A@@@@AAA@@@@@@A@AAA@AAA@A@AA@A@AA@@@@BBFFFBB@F@FD@@DDD@DFDD@FFBDDBFDBBB@@@@FDBFF@DBBFB@@@LHL@@@HHD@@D@LLL@LD@L@HLL@L@@@H@@@@LDHDLHDLL@H@DH@@ABA@BCC@@BCAA@@@BB@BACBCAC@BC@ACC@A@AAA@CB@CCBAAA@@@@A@A@AAA@AA@AAAAA@@@AAAA@@@A@AAA@@A@AAA@AA@@AA@@A@@@BFFDD@DBB@@F@BD@D@BBD@DDBD@DB@DBFBF@@FBFFF@@BDB@F@@@LHLH@L@LH@DL@LLLHLLHHLHLD@HH@LHHHDLD@HDL@LLLD@H@HL@@BBACBAABAC@CCBACAACB@@C@CCA@ABCAB@CCCBAACA@BC@CBCA@@@A@@A@A@AAA@@@AAA@@@AAAA@@AA@@AAAAA@@AA@@@@A@@@@AA@@@D@B@DFB@FFFBDFDDBDDDF@FBFBDBD@@DD@@FDBBB@FDDB@BB@@@DHH@D@HHL@DH@DD@DD@LLHDLHLLD@H@LHHHL@LH@LHLDLLHLLD@@C@A@AC@CA@C@CBBBCCABACCC@@BAB@A@BCAACBB@@CCC@@CBAC@@@@A@A@@@AA@A@AA@@@A@@@@AAA@AA@@AAA@@A@AA@AA@@A@@A@@@@DDFF@FB@FBDBDFD@@FBBBFFB@@DD@DFFFB@DF@@BB@@B@@DBB@@L@LLDL@L@DHLDLHLHDHHL@@DLLHHLLLHLLHHL@HHLLHHHDLDHH@@CACCCABCA@A@BCCBBB@BBBBAB@C@@ABC@@AABBC@BCACACAB@B@@AAA@@@@AAAA@AAA@AA@@@@@A@AA@A@@@AA@AA@@@@@@A@@A@@A@@DFDD@DFF@@BD@@DF@FFBB@BFBB@@BBDDDDB@B@@@FDFDDDFBB@@@H@@HHHDLLDDDLDDDL@@LLD@DHHDLLDL@DDDHH@HDLD@DHHLHDL@@@CA@ABAAABBA@AAA@BBCCC@BAC@C@BCCB@@C@BC@ACBCCBCAAB@@@A@@A@@@@@@AAA@@@@@AAAA@@AAA@@@@A@@@@@A@A@AAAA@@@@@@BBBDF@BDFDBD@@FBBF@@DFDDDBFDF@@@FBBDF@DD@FDBDBDDB@@@DDDHLLLLL@LDD@LLHL@DHLL@HDDL@HHH@@LH@HLHDHD@DHL@HD@@ABAB@@BACBACBB@CC@AABCABAAB@BAACBCAA@A@CA@BCCCA@AA@@A@AA@@AAAAA@@A@@@@AAA@AAA@@@AAA@AA@@AAA@@A@@AAA@AA@@DDBDD@BD@B@BF@FD@@FF@DFFDD@BBDBDBF@@F@DB@FBD@DB@DB@@LLHHDDD@@DD@HHD@LLL@@L@DDDDLL@L@DL@HLLHHD@@LHHD@HL@@CBC@BACAB@BCA@@CB@B@BA@A@ABC@@@CC@AACACC@@CBC@CAA@@@@@@@@A@AAA@AAA@AAAA@@AAA@@A@A@A@@@@A@@@A@AA@@A@@AA@@FDBDDD@@BDF@DF@@BDDDBFB@D@@DDBBF@@@F@BDFF@B@B@BFDB@@D@L@H@H@L@DLHDHD@DDHDL@H@DDHLLLDD@HLHH@H@@DLL@L@DD@@BAABBABACCBAACA@@@BCABBBC@ACAB@@B@BBC@CCC@@CBBACBA@@AA@A@@AA@A@A@@@@@AAAAA@@@@@AA@AA@@A@AA@@AAA@A@@@@A@@F@BFBFD@BFFBF@@BF@@FDBB@@FDB@FF@DFBBBFBF@FB@BB@B@@@@L@L@HDDHHL@@LHH@L@DDLHDHL@HD@@HH@DH@LL@DHHL@LD@LDL@@@ACBC@B@A@BB@BB@@CACCBBABBBBB@@A@AC@BCABAC@AABAAC@@@@@AAAA@A@A@A@AA@A@@@AAA@@AA@@A@AA@AA@@@A@@A@@@@@AA@@DB@BBDBFBD@FF@DDBFFDBDF@D@@DDFBDD@B@B@@DBBDFDBDDBB@@DLHDH@DDDLDDHHDHHDLLL@D@DLLH@D@H@H@HHD@LLHHHHLLHL@@@CAAA@ACC@C@BBA@CBAAC@ABCCBBBCBBA@CABAABB@ACAC@BCCA@@@@A@@@@A@@@@@@AAAAA@@A@A@AAA@@@@@@@@A@@A@@@@AAAA@@@@FDDBBF@DDDFDFD@BDDBDDB@BFB@@F@DBFFFFDFB@@DB@F@@@@@@@D@DHDHLHDH@@@H@HL@H@DDLL@HDLLDL@@HHDDHHLL@L@LHLLHH@@BB@CC@BAAABAAACC@AA@AA@ABCACBA@BC@AAACCBBBBCCAB@CC@@@A@@A@AAA@@@A@@A@@@@@AAA@AA@AAAA@@AAA@@AAAAA@AAAAA@@@B@FFFBFFBFBDBBB@@@@BDDFB@@FBBD@@FFF@FDB@@@DDDB@FB@@@@HDLLH@DDLHD@HD@L@H@H@HLDD@HHDL@@DHHDLHD@LHDLHDDH@@B@@AAACAACCABC@C@CBCCAC@AACCAAA@BBBCBABCACCBCBCCCC@@A@AAA@@AA@@AA@AA@@@AA@@@AA@@@A@A@@@@@A@A@@A@@@A@AA@@@FFBBBFFB@FD@FDFD@DB@FDDDBBBBFF@B@FF@DFBBFDFD@B@FB@@@L@DH@DHHH@L@DL@@@H@LHD@HLDLLLDHDLDHDLDLLDLLL@DHL@@@@C@CB@CAABAABACABB@@CABBACACCCABCC@BB@C@AA@ABB@@@C@@AA@AA@@@@AAA@AA@AAA@@A@@A@AA@@@AA@A@A@@@AA@@A@AAA@@@FB@B@B@BDDBF@DDBFFDBB@@@B@DDBF@BDDFFDFDBBF@BFFF@@B@@DLH@LL@L@HLDLLD@D@LL@LDHHDDHLH@H@HH@HH@DDDDHHDLLHD@@C@BCCACCCC@A@@BA@@B@ABBAB@BA@@@BB@AC@@@CBCCABCCA@A@@AA@@AA@A@@@@@@AAA@A@@AA@A@@@@@@@A@A@AAAAAA@@@A@AAA@@@BBBBFB@@DDFDBD@@FFD@@F@@D@FF@FBBFFBBBF@D@@B@@DFDD@@LDDD@HL@D@LD@LDLL@HHHD@@@L@@LHHHDLL@LHLD@HDLHHDDLL@@AB@@@B@AAC@ABCACACBCABB@@B@C@AC@@BCB@@@@BBBB@@@CAA@@@@AA@@@AA@@@@@@A@@AA@AA@@@A@A@A@A@@@AAAA@@@AAAAAAA@@B@@BFFDFFFD@DFBBDFF@FFB@FF@@FDDDF@@@FFDF@B@DFDDBFF@@DLLLHHHD@@H@@D@HHDLH@HLL@@LHDHH@DHHD@@HHDH@@HLL@DL@@CACCB@@B@C@B@@CCC@BC@CB@C@AC@ABB@A@CABBBB@@BB@ACAC@@@A@AA@@A@A@AAAA@@@@A@@@A@@@A@AA@@@AAA@@@AAAA@@@@@@@@BDF@DFF@F@DDDF@FDFDBFFF@DBBBB@@FD@@FB@FFF@FF@DF@FD@@L@D@@H@LL@@@@LDDD@@@H@@DDD@@L@HHLLLL@@HDD@HDHD@HDD@@AA@CA@ACBCBBB@ABCBAAA@@@BCA@BACBBBBBCCAC@CAC@ABA@C@@A@@AA@A@@A@@AAA@AA@AA@A@@AAAA@@@@AAA@@A@A@@AA@A@A@@@@BFDF@D@DFFDF@FB@FFDB@BDDBF@FF@B@BB@FB@BBBDF@@BD@D@@D@H@HHDDHDL@HDLLL@HD@LHHH@@L@HLLLDL@H@@@DHDLDHLHD@@@BCAC@A@CCCCCBCACBBABCAB@@CA@CAAB@A@AABA@BBAB@@@ACC@@@@A@@A@@AA@@AAA@A@@A@@AAA@@A@AAA@@@A@AA@A@AAAAA@A@@@F@FBFBDFBFD@@FDF@DF@FBFDBBDBD@@B@BDDDDB@B@BFDDFDFD@@DLLLHLLL@@@LDH@D@@DHDLL@L@LDLLLLHLHLLLLDHLLDHHLL@D@@BACCAB@@BABABCA@BBCAABCABCABA@CBCBCAAA@BB@CAB@@ACB@@@A@AA@A@@@AA@A@@@@@AAA@@AAAAA@A@A@@AAAAA@AA@@@@@AA@@FB@F@BBFFBFF@@BDB@@@DD@BDB@DDD@B@DD@@BDBFFB@BF@@@B@@@@HLLLDDD@LHD@LH@@@LHHLLHDLDHHHDDHHHLHLL@HLDHDLDDH@@BBCBCCA@@@ABAA@@BB@CACACAC@BBA@B@@CCBBCABBC@@AC@AC@@@AA@AA@@@AAA@AAAAAA@@@AA@AA@@@AAAAAAA@@AA@@AA@@@AA@@@F@BF@B@FD@BF@F@DFBBB@BBBDB@FDBBDFB@@@FDFDDBDDDDFB@@LDH@LDHDL@LDHDL@D@@DLHLH@LHHHDHHH@@HHL@LDLHHLDDL@L@@@BCB@@C@BA@@ABACBABBBA@@BBBBC@CBCCABB@CCAAA@@CBAA@@@@@A@@A@AA@@A@A@@@AA@A@A@@AAAA@@@@AA@@@@@@@AAAA@AAA@@FDBD@D@FBF@@DD@BBBDFDFFFBFFDDF@F@F@FFF@BDD@FDFFFBB@@@@@D@DHDLLL@H@HLLDLD@H@HDH@LLLLH@@@DHLLLL@LH@@H@LL@@CAC@ABBCBCA@BCBB@C@CBBBA@@BABCC@ACCCABAABCAB@@C@BA@@A@@AAA@A@AAAAA@@@@@@A@A@AAAAAAA@@A@@AA@AAA@AA@@AA@@@BFDBBDFDDFBFB@FD@BD@BFBDD@@BBDD@@BDBD@FBBFFDDB@FBD@@HLLDDL@@@D@DHLDH@LHHLLLHH@DLHHLDDHLDHL@L@L@HLH@D@L@@A@AA@B@@BACC@CCAACCACABACBB@C@C@@@CABAB@A@B@B@ACAB@@@A@@@A@A@@A@@@@@A@@AAA@@AAA@@AAAAA@@AA@@AAA@AA@A@A@@FDB@FD@B@@B@FFDDBDDFF@BF@BFD@F@DBDBFBFF@D@DFDFBFFD@@LHDDLH@H@LL@L@DD@HHDLLLDDHDDHHL@LDD@DHL@DDHLL@H@HL@@ACBCBC@CCA@BBAB@@A@BAAAB@@BA@BC@@CAA@AC@ABAC@AC@@C@@@@AA@AAAAAA@@@@@AA@@A@@@A@AAA@AA@@@A@A@@AA@AAA@@@A@@@BD@@BFF@@@@DDD@BFB@B@F@B@DBFBBDDDDFDFFFDBFB@FDBD@@@H@HDLLL@D@@L@LHH@LHH@HHDDDD@@D@HLLDHH@@@L@DH@HHD@@@@BCAC@@B@C@@C@CA@@BBBBCAACABCB@ABAAB@@@A@CC@@@AACAC@@A@AAAAAA@A@@@AAA@@AAA@A@@@@@@AAA@@A@@@AAA@AAAA@@A@@@DDDD@FBFFBDDDDBFBBDDFB@BDBBDFDBFDFBBFBFB@B@FDFF@DD@@D@HL@LLHDDDLLH@H@@H@@L@@@H@LLH@@DHH@HL@DLL@D@DDLLH@@@@BB@AAA@@CCB@BAABBBBA@@BACBB@CBACACB@CC@@@A@@BAC@@@A@@@AA@AAAAAA@AAAAAAA@A@@AA@A@A@AAAAA@@A@@@@AAAA@A@@FFFBDDF@DFBDDFD@@DFDB@@@BFB@@FFDD@BFFD@@DDDFBBBB@@@@HDHDD@HHHHH@H@@@DDLLH@HH@@DLH@D@LDDD@LHLDDLLHDH@DH@@CB@BB@@BCACA@CAA@@B@BA@@CB@CC@BAACCABCBAA@C@A@BCBB@@AA@@A@AAA@@A@A@AAA@AAAAA@AA@A@@A@@@@AAA@A@@@A@A@@@@@BFDFFBFFFDFBBDB@FBFDBDFFFBB@F@@B@@DFFFDDBDDFDDBDDB@@HDHHHHLLLL@@@L@@DLHHLDLLDD@DHLHLL@H@LLLH@DH@D@@LLD@@BC@CBAC@@BB@CC@B@CCBCABCBBAACAA@CCBB@@@AACB@A@BCCB@@AA@A@@@AAAAA@@@AAA@A@AAAA@AA@AAAA@@@@@@A@@A@AA@@AA@@@D@FDBDD@F@FFFF@BFBF@@FBF@BB@@D@DDFB@BD@F@F@FBDBD@@@HH@DHD@DD@D@@@DLL@DLLH@HHLDLLDLD@DLH@H@LHHDLDHLH@D@@C@@BBBCC@C@@A@ABB@BA@@BAC@ACCAACBBCA@ACCCBA@AACCBA@@@@@AA@AAA@@@A@@A@AA@@A@@AA@@@@A@AA@@A@A@AA@AAA@AAA@@D@@DB@DBFFBDDBFDBFF@F@DFBD@B@@@@FFDDFD@@@F@DDFDBD@@@LDHHLHLDHLDLHDH@LHH@DD@HD@@LHD@LHHL@L@@@H@HH@@HHHD@@@A@@BAA@B@CBCBBCCC@@CA@BCC@CBBBBBCA@B@CC@BBBCAABA@@@@AAAAA@@A@A@AA@A@@AAAAAA@AA@A@@@@AA@AA@@@@A@A@A@AA@@DFF@DFBF@FBBF@BFFDD@BBDDBFFBF@FBF@B@B@B@BBF@D@B@BB@@D@D@DL@@HLLHLLHH@@DDDLDLDHDD@L@@LHD@L@HDDL@HHHDLL@@@AB@CCBAA@@CC@ACCC@@C@@CABBBCA@ABCCBACBAB@ABCBBC@BB@@AAAA@A@@A@A@A@@AA@@@@A@AA@@A@@@A@AAAA@AA@A@@@@AAA@@@B@FD@FFD@B@FBBF@DDD@BFBB@D@@DDDF@BBD@BF@@FBF@BBDBB@@DD@@HHDHDD@@@LLLL@DLHHLLHHDLDDDDLLLH@DHD@LDLHDH@HH@@CB@ACCCCC@C@CC@B@@ABC@C@C@AB@AA@@CCCA@CBCABABC@CCC@@A@A@A@A@@A@AA@@@@@A@@@@A@AA@A@@A@A@A@A@AAAA@AAA@AA@@DBBFDFBDF@BFDBBBBFDDB@DDDFBF@FB@F@@FFF@B@@@B@@FDBF@@D@LLDLHDL@@D@D@@@DLLHHLHL@H@@@D@@@H@HDDLDLHL@LLDLD@@C@@@BAABBCACB@@BCBACC@A@CAAAACA@B@CAA@ACCB@CBBC@C@@@A@AAAA@@@A@@@A@A@@@@A@@@@@AA@AA@A@A@@@@@@A@AAAAA@A@@@DFDF@FDFFFBF@FBDFDDDBDDBBFD@FDF@DBBF@FDBDB@FFDBF@@@D@H@DDLL@HH@DHDDHHHD@HDHLLLDHLDLHHL@LLL@HHD@DH@DD@@@@A@@BBC@CBBABA@C@CC@@A@@CCCCB@B@BACAABC@C@BAC@ABAC@@@A@@A@@@@@@@A@AA@@@@A@@AA@@@AAAAA@AA@@@A@@AA@A@@A@@@FFD@DFFBBDB@DD@@FFD@@@D@DBFDBDF@BDD@@@@DB@DFDBBDDF@@L@H@@@@H@LDHLDD@D@DLD@D@HH@D@DHDHHHL@D@LL@@HLDLHL@@@C@AA@BBC@BABBABBC@A@AAA@@B@@AABCC@@AC@BC@ACCA@@CCC@@@A@AA@A@AAA@AAA@A@A@@@@@@@@@@@A@@AA@@@@AAAA@A@@@@A@@BF@@@B@FF@FB@@DDB@@BBDB@DFFDF@@FFFDB@DDD@@@F@BDDFF@@@LHDH@@LDDL@@HDHDLL@HD@@@LDDDD@@@HLH@LDLLLHHLDD@@H@@BCA@@@AAAA@BBB@CBC@@@ACA@BAABA@BBC@@B@C@BCBBAA@@AB@@A@AAAAA@@@A@@A@AAAAA@@AAAA@@AAA@A@@@@@@A@AAA@@AAAA@@F@BBDFD@@@@BF@@B@DD@BDFBDBB@DFBF@DF@@BBBDDFFDDB@BD@@@DD@DLLL@@@LLLD@HH@HDD@@D@DHDHH@D@LDHD@HDL@DDHHHDH@@A@BABBCBAAAB@A@C@CBA@AC@@AABCCBCB@@CCA@@CBCBCACCCA@@@@@AAAAA@@AAA@@AAAAA@@AA@@@A@@@AA@A@@AA@A@A@@@A@@@@@BFBBFBBBB@FBBB@FD@FDD@@FDB@DFF@@F@BF@BFFFF@FBDFF@@@@L@@L@HHH@D@L@HDHH@DD@DD@LLD@@@@@DH@LL@D@@DL@DDLDHD@@@AB@B@BC@BACCCC@C@CBC@AABB@@BB@ACCC@C@CAC@AAAACA@@@@A@AAA@A@@@AAA@A@@@@@A@A@@A@A@A@AAAAA@@A@@A@@A@@A@@@@@DFFB@D@DFBBFBD@D@@FFFD@@@@FB@FFD@F@@BBFF@@BDD@D@D@@H@LHHLDLLLDH@HHH@DL@DD@@DHDLL@HHL@DLDDLL@@DH@@L@HH@@@B@BCAC@ACB@CCBCCACABBAAB@BA@CACAAACAACCB@CCCACABA@@AA@A@AAA@AAAA@@AAA@AAA@AAAA@A@@AA@@@A@@A@@A@@AAAA@@@@@F@BFDFDFDBD@BDBDBBFDDDB@BFBFDFBFDFD@FDD@BB@DBB@F@@L@H@L@LLL@@@DLHHHH@@H@LDLH@DDDDH@H@HHDHLHDD@DDDD@D@@@BA@A@@@ACAAACB@@AABB@CABB@CA@A@@AC@@CAAAAC@B@A@CA@@@AA@@@A@A@A@@@@@@A@@AA@AAAAA@@@A@@@@AAA@@@@@@A@@AA@@B@@D@FDB@@FFDFB@B@FFFB@@@B@@B@DDD@@B@D@DFBD@FFFF@D@@HLHLH@DDHLDDL@HHDLD@DLLHDDDLHDLL@DDDL@HLL@@HHHD@@D@@@@@BCA@BCC@CAA@A@C@BBBB@BB@@C@@BC@CBCCCCC@B@ABB@C@@@@AA@A@@A@A@@@@A@AAAAA@A@AAAA@AAAA@A@@AA@@@@@AA@A@@@@FDBFDF@@@DFF@BBFB@B@@BBBFBF@@F@D@@FDD@D@BFD@BFB@BD@@LH@LLDHD@HD@@DDHHHHLHDDH@LD@HDLHL@HLLDHDDHDL@LHLHD@@@C@CB@ABCACCBC@BA@A@AB@AB@ABBCCAA@@AC@CCA@B@BC@@CB@@A@@@@@@AAAA@A@AA@A@AAA@AAAAA@AAA@@@@@@AA@@AA@AA@@A@@FFBD@FDFB@FDFFF@F@FB@DB@FF@DFDDDBFBDBF@BFF@@@DF@BB@@LD@HL@LHL@DH@@LHHDDD@HHL@HL@@@@DD@LHHHLL@LD@LHDL@H@@@BBB@@A@CBCB@AAC@CCCBBCAACBB@BBCCABBCACA@@ACCAA@@C@@A@A@@A@@@A@@A@A@@AA@A@@AAA@A@A@@@@A@AA@@@@A@A@AA@A@@@@D@BDFBD@@FB@B@@@D@B@B@FBFD@DD@@FDBBBDDF@@BBD@DDF@@@DDLL@HHDL@HHHLLL@LHL@L@@@@@HLLHDDLDDDLDHLD@DHHL@H@@@ABC@ABB@CCC@CCC@CA@BBCA@B@B@ABBBBCC@CBCB@CABBACCB@@@AAAA@A@@A@AA@AA@@@A@@AA@@@@@A@AAAA@@@A@A@@@@@A@A@@@@BBBDFDBBFFB@@DDF@@@DFF@@BD@@DF@FFFBB@B@BF@DB@BFFB@@DDHHH@DH@@HHDL@HLLH@LDLLDHDDDHLL@H@DH@@HLDDHLLLDD@@@@CACCAACAAA@AC@@AB@@BAABC@A@@@A@BA@A@@C@AA@B@CBAC@@@AA@@@@@@@@AA@AA@@@@@@@@AA@@AAA@@@@A@@A@@AAA@A@@@@@@@@@B@@@B@BFB@B@DBF@@FFBDF@FF@@FBBF@@DBD@D@BBB@B@BD@@@DLHH@H@LDD@HL@HDDDL@@LHHDD@D@LLHL@D@@@L@DL@@DHH@@H@@@@CBBBCAA@CC@BAA@@@C@ACC@CCB@@CC@AABABCCBCCACCC@B@@@AA@AAA@@@@A@@AAAA@A@@@A@@@@@A@@@@AA@@A@@@A@@@A@AA@@@F@@@FBDF@BFB@B@DDB@DBDBFB@BFBFD@@FFFB@DDB@FDD@B@@B@@D@HDHHLDLHHH@@DLLHLDDD@@LD@HLD@LLL@@L@HLLLD@HHD@@L@@AAA@@CA@BCA@CCC@@C@BC@CA@BCA@@CB@B@BA@@ACACCBCCAAB@@) (il:rpaqq *corduroy-bm* #*(200 200)@@JHBJJJ@HH@HB@HJ@BHBH@J@JBHBBH@@BJBHHB@@BHHHJJHJ@@@@DHDL@DH@LDHD@LHLLHDD@@HDLLLHL@@H@LLDDHH@LHHL@LHL@@@D@D@@DDD@@D@@D@D@DD@DD@DDD@D@@D@@@@@DD@@@@D@D@DD@D@@DD@@DBBFBDF@FF@DDBDF@FFDF@B@@@BDBB@F@D@@D@FF@D@BDB@@HJ@BBBJ@JJ@J@HHB@HB@BB@@JHB@@@@JBJJBJHHHBHJBJH@HBH@@L@L@@DLDDDHHD@LLHL@L@HLDH@D@@D@LDL@DL@@@@DL@L@LDL@@@DD@D@@@@@DD@DDDD@D@DD@DD@DDD@@@@DDDD@DD@DD@DD@DDDD@@@@@@DD@F@BF@DFD@FD@BFD@@F@BFFDDBF@BDDDBBF@FDF@F@BF@@@BJBB@J@JJB@BJJ@JHJJ@BJ@JBHBHHJHJBJBJH@HB@HBB@HHBJ@@H@@HHDLLDLLL@DLLL@LD@LHDDLHHDDLDLHLH@H@@LHDL@@HLHD@@D@D@@@D@@D@DD@DD@@@@@DD@D@DD@DDDD@D@@@@@DDDDDDD@@@@@DDBDBFFBDD@FBD@@DDD@DDB@@D@DBDF@FFBB@DBDFFFBB@B@BF@@@@JB@@@@BJBJH@BJJHJ@H@JHBJH@BBJ@HB@HBHHH@BB@HH@@HJ@@H@HLLLHH@LHDL@@LDL@LDLDHDD@DL@LLHH@@@H@LDHDL@LHHL@@@@D@D@@@@@D@@D@DDD@DD@D@@DD@D@@@@@@@@DD@DD@DDD@@@D@@@@F@@BFF@DBBD@DDDBB@BDFFFDFDFFDDFBDD@DDDDFF@BBB@@DD@@BJJJJJ@H@JBBBBH@@@HHJ@JJJJH@@J@JH@@B@JJB@@J@HJ@@JJ@@@LLDD@LH@HHLHHD@D@HHL@DD@DHLHHD@D@DHHL@DLLH@@L@HDH@@D@D@@D@D@@DD@DDD@DD@@D@DD@@@@D@@@DDD@@DD@DDDD@@@@D@@BB@BF@@BDB@BBFDBD@BB@@FDFFDDDFFDBDFFFFDDB@DFB@FFBD@@J@BJJHHB@HBBJHJBHJH@B@BHB@BBHBJJ@HB@HHH@@@@HJJ@B@@@@@DHHHDLHHDLDHLDDL@LDDLHDHDHLHD@@DD@HLD@@HHDDLH@HHH@@D@@@D@@@D@D@@DD@DD@DD@DD@DDD@@@D@@@D@D@@D@DDDD@DDD@@B@@@DFDBDDB@BFBBBB@BDFFB@DFDFDD@FF@DFFF@@FBBD@FBDB@@JHB@BH@@B@JJ@@HJB@HB@@@JHBJBHBJH@JB@J@HJJH@H@HHJH@@@HLDDL@L@HLHL@DDLH@LH@HDLH@@LL@DLLLHHDL@@HH@H@HHD@H@@D@DDDD@D@D@DDD@D@D@@D@@DDD@@DDD@DD@@D@@@DD@@@DDD@@@@BDBBB@FFD@D@FFFFFFDBFFFDB@B@DDFFDD@DFFF@BFDFDF@B@B@@JJHBJ@HJ@H@JJJ@@@B@@HH@@BBHBJH@B@BJH@JHJ@BHJ@BHBJB@@DLLL@DLDHHHLHHDLHDL@@@HLH@@H@@LLDL@@H@H@DLDDLLLHHH@@@@@@@@DDDDDDDDDDD@@DDD@D@@DDDDD@DDD@@@@DDD@D@@D@DD@@@BD@@F@@@BB@D@@@@BFFBF@BDBDB@FBFB@@BDFF@@FFBFBFDDF@@@JHHJBHBB@HJ@JH@@@HJJ@@JJBB@HHHBBHHJJJJBJB@HJJB@B@@@@@@LDH@LLLHD@HL@@L@@LDLLD@DLL@@@L@@DD@DDHLDHDHDLHH@@DDD@DDDDD@DDD@DD@D@D@DD@@DDD@@@@@@D@@@D@D@D@D@D@@D@@DF@F@@FDFB@BBFDBBD@DFFDB@@F@FD@BFB@@DDDB@DBFFBDDDD@@@HH@JB@@BB@JBHJH@@@B@BBB@@@HJBHJHHHJBHBHJB@BBJJBJB@@DL@DD@HL@H@HDHDD@HLDHDLLLLH@@DHD@LH@DHDH@D@L@D@HLH@@DD@@DDD@@DD@@@D@DDD@@D@DDDDDD@D@DD@@DD@@D@@D@@D@@D@@FBB@F@F@BDBB@@DBBDBDFD@@@@BB@@@FB@@@BDFBDDBFF@F@D@@@JJB@BBJHHBHJHHBBJJHHJJ@HBJBJBJ@JJBBH@HHBHHBHBB@B@B@@DLHDDL@@@LLHDD@HHLDL@L@@LHHDLHHDHHHDH@DLL@H@HHHLLH@@D@D@@@@@D@DD@D@D@DD@DD@@@DD@DDDDD@@D@@@@@@DDD@D@DD@@B@@BF@B@BBFD@F@@D@BBDFFBBDDBDFDDFDBBBDBBB@@FBB@FFD@@JB@BH@@JJBHH@@B@J@@B@JBJJJ@BB@BJHBHJBBH@@JBB@B@B@H@@D@HL@LDH@DLHL@@HD@HLDH@@@DLHHDLHLLH@@D@D@DHH@HH@H@@@D@D@@DD@@D@@D@@@D@DDD@D@D@@D@@@@@D@@DD@D@@D@DD@DDD@@DDBFBDF@D@BBDBF@DFDFBBBDFBBFF@DDDDBDBF@B@F@D@FD@F@@@J@@J@@@B@BH@BHHHHHHBBJ@@JBHJHJ@@HHJ@HJB@B@BBJ@BJBB@@D@@@HLHDHLHLDHLDHLLD@DLHDH@DLD@DL@H@H@@LHHDLL@LL@H@@DD@D@@DDDDDD@@D@@DDDD@D@DDD@@D@@@@@@@D@DD@@@@DD@D@@@BD@D@DBBDBDBBDDBBDDBD@BBBBFFFBB@DF@FD@FF@DFDFDFFF@@@@JBJHJJHHBBHH@JJB@@B@@HHHBBHHHHHHJJJ@JBJJJ@BB@BJJ@@@LDL@@D@LLDDDDLHHLLHDDH@HLHH@L@D@LLLDLD@H@LHHD@H@@H@@D@D@D@D@D@@@@@@@D@@@DDDD@@DDDDD@@@@DD@@DD@D@D@DD@@@@FF@FB@F@@@F@@DBB@@D@@D@DBFDBF@@FF@D@DBBBFBBBFDB@BB@@B@@@@BJJ@BJB@B@HB@JBJB@HJJJJ@HH@HJHBHJBBBJ@HBBJB@J@@HHHDDDHLLHLHD@@HHHH@HDDLH@HD@@L@@DDL@LLHH@HLDL@HD@@@@@@DDD@@DDD@D@@D@D@@@@@@DDD@@@DD@@D@@DD@D@D@DD@DD@@@FD@DDDFDDBF@BF@FDBBFBDF@D@FFD@@DFFFFB@FFDBFFFBFFFB@@HJJHH@@BJHH@BBB@JJJBJJBJJHH@HJ@HBJHHBJJ@JJ@BHH@HJB@@HLL@@@LD@HDD@LLDL@LHHDDDLH@HHDL@@@LD@LD@@DDLL@H@DH@@@D@D@@D@@@@D@DD@@@@@D@D@@DDDDDD@DDD@DDDDDDDDD@D@D@@@@B@FF@B@@B@DB@FDFFDDF@BF@F@BBB@BFFDFB@B@D@@@FB@D@F@@@@HB@HJHB@@JJJHJHHBHH@BJJHBJHH@B@B@BBJHHBJHBJBBHHB@@L@@H@@@HLD@D@LDHDLLH@@@@@HLD@L@@DDDLLLDHHDH@LDD@@H@@DD@@DD@D@@DDDDD@D@DD@DD@@DD@D@@@@@@@@@@DDDD@@DDD@D@@FDBBF@FBFFDD@@BDDDFDDBFDFDF@D@@FBD@F@@DFBBF@BBB@@D@@JB@HB@@@JJJ@@JH@BJHHJHBBHHHH@@@@H@B@BB@BJB@@JHHJ@H@@H@H@HL@@@DDDL@D@@LDD@HD@@LHLD@D@HDDHHHD@L@H@H@LDLL@@DDDD@@D@D@DD@DDDD@@@@D@@@D@@D@@@DDD@D@DD@@DD@@DDDD@@DB@@@BD@DF@@BF@F@FBBDBBDDF@BD@B@DBBFD@@@BFFF@@@FDD@@@HJ@@@H@B@BJHJ@HJJ@BJBHJ@BJHHBBB@J@HB@@JHHJ@BJ@JH@@@HH@@DLDLDLLHLL@HDDL@LLH@LL@@LLDDDHH@LDDD@HHLLDL@LD@@DDDD@@@D@@@@@D@@@DD@@@DD@@D@D@@@D@@D@@@@D@@@@DD@DD@@BDBFBDDBDFDF@@BFFDBB@FB@FDDB@@FF@DDFDFBBB@@FB@DBDF@@HHBH@BJHHJHBH@HHHJHJJ@B@JBB@BHB@JJJ@BB@@JJJ@HBHH@J@@HLD@DDDHD@DDLL@DLDD@DLDHD@HH@@@LD@@D@@DDDHLD@DDHLL@@D@D@@@@DD@@@@DDDD@@@@@@DDD@@D@@@DDDD@@@DD@@D@D@@DD@@@DDF@DDFFFFFB@DFFF@@D@D@FB@@FDBFBFFFBBDFDFDF@@F@DF@@@JB@BJHJ@BBBHJH@HJJ@B@BHB@@JBHB@BHBBB@HB@HHJ@BB@BH@@@HDLL@LHLDDDL@L@HDDD@@@DDHLHLL@HH@H@L@@HH@LDH@HL@L@@D@@@@@DD@DD@@DDDD@@D@D@@@@@D@@DDDDD@@@@@D@DDD@D@D@@@BB@B@@@BFFBBFFDBBBDBF@FD@FDDB@@BDDD@DFD@BF@F@DD@FF@@HJBB@HJ@H@BBHJHBHJHBBBJHHHBHHBHJJB@@B@JHJBJ@JB@H@J@@LHDHDHLDHDD@@LLD@LD@LHLLHHD@L@HH@HLDLDH@HHHLDLLLLL@@DDDD@DDD@@@DD@@D@@D@DDD@D@DDDDDD@D@DDDDD@DDD@@DD@D@@FDBBDB@@F@FDFBDDFBF@@FBDBFDBDDFBBBBDDDDFF@BDBD@@BF@@HH@JHHB@JJ@@HHHJH@H@BBJ@HBBBHH@HH@@J@JHBJHJBJHJBB@@@LHHDHH@LL@DL@@@L@H@@DDHHLHHLDLHH@LDHH@DHLLH@HD@HHH@@@@@DDDDDD@D@D@D@@@@D@@DD@DDD@@@DD@@@D@DD@@DD@DDDD@@@BBBFFB@@@@DF@@@DFFDF@B@B@BDBFDDB@@FFBBBDBFB@D@FDDF@@H@B@@HH@JHBB@BHHJHHJ@JJBJBHBJJBBJH@JHJBH@H@H@@JJHB@@HL@@LHH@LD@HLHDHDL@@@HHH@D@@DLHHLDH@@HLDLDL@LLDLLH@@DD@@DD@DD@DD@DD@D@@DD@D@@D@@@D@@@@@@@D@DDD@@DDDD@D@@DBBFDDFDF@@@@B@BB@FFF@@DBBBFB@BFFFDFBDBBD@D@@FBDD@@@JHJ@@HB@BH@@HBH@BHHB@B@JJBBB@HBHJ@@BH@H@@H@@J@HH@H@@DD@L@DHD@D@@DD@H@@LLLLDDHDLLLL@L@LHLDL@@LLHLLDLDHH@@@@@D@D@DDDD@@@@DDDDD@@@@D@@DDDD@@@@D@DDDD@D@@@@@DD@@B@BDDBFBBFD@BBFBDB@BBBB@@DFDBBFDDBBB@B@@FFDF@DFDFD@@BJBHBJH@BJBB@HHJB@B@BHHBHB@JBBH@JJHBJJ@JB@HBH@@H@@@@HLDH@LLLDDHLHHLL@HD@HL@LL@H@HDD@HHL@DHD@HLDDDHHL@D@@@DDDDD@@@D@D@DD@@D@@DDD@@@DD@@DDD@DD@D@D@D@@D@@D@D@@@@DD@FD@FDBB@FBDDBF@B@BDBBFDFDBD@@BDF@F@D@F@B@@BDF@@JJJJBJJJH@J@HHH@@@JBJHJJBH@BHHBHJBHJJBBHBJ@@JJHBJ@@@LD@HLD@@HH@HDDLDHLDLDHHD@@DL@LHD@L@DHLDHLHDDDL@LDL@@D@DDD@@@@DD@D@DD@@@DDDDDD@DD@@D@DDD@D@D@DD@DD@@@@D@@@BFBFBDFB@@FB@FDD@DB@DDB@@F@@BF@@B@DD@FDDF@FD@FD@F@@BJBBBHHHJHHHJJHJJ@BBJH@HBH@HH@@HJBHHJB@B@HHBJ@BBHJ@@HHLH@@LL@@H@DLLHHDH@@@DH@@DHDH@LDLLDDDDLL@D@HLD@D@@@@@@DDDD@D@@D@D@@@D@@@@@DDDD@@D@@DDD@@@@@D@D@@@@D@@@@FFDBD@BDB@@B@FD@DBFFBBD@F@BFF@DBDDBD@DD@FF@@DDDB@F@@JH@B@HBJB@J@HB@@HB@BBHBH@J@B@H@@@HB@JBJ@@HBJ@@HHJH@@DLLD@D@DLHDDDD@LH@LDD@H@D@@LDL@DLLHHL@D@@@@LLLL@LL@@D@@D@DD@DDDDD@@@@@@@@D@@@@@DD@@@D@@@@D@DDD@D@DDDD@@@DDBBDDD@DDFBBDF@@BFFB@@DB@BFBDBB@B@BF@BB@DDDDDF@B@@@JJH@B@BJH@@HBJ@BB@BHJJJHJBJHBBJJBBJ@@J@HHJ@HHJ@HBH@@LDLHLLD@DDHLLLD@HLDLHHH@@DH@HLDDD@@DDLHHLDLL@@@H@H@@@D@DD@@@@@@@@@@@DDDD@@@@@@DD@@D@DDDD@D@DDDDD@D@@D@@@BBDFBD@FFDBD@F@DD@BDF@@DBB@FBDB@DBFDFFB@DDFDD@FFBB@@J@H@BBH@JBJHHBBHJBBHJ@HHHJBBBH@J@JBHH@HJB@JH@@@HB@@@HDLDDHLLLLD@@L@HL@LDHDDLLHHHDHH@H@LDDDDL@LDDLD@LD@@@@D@@@@DDDD@@@D@@DD@@DDDDDD@D@D@DD@@@DDD@@D@@D@@DDD@@FFDFF@FDDFBDFF@FDFBFFDFBFFD@F@@@BBBBD@D@DBF@DDFBFF@@HJHHH@B@BHHHB@HHJJB@BBHJ@H@@HHJJJJHHJJJJJBJ@JHJJBJ@@HDHDDHDD@D@DLLL@@LHL@HL@L@HH@HL@DLLHH@L@DHL@D@DHDH@@@@@D@D@DD@D@@@DDD@DDD@@@@DDDDDDD@DD@@@@D@@DDD@D@@D@@B@@FFFFB@B@D@D@BF@B@@DFDBDDBBD@FBBFDDDFBBB@DD@FBFD@@JBJJ@@JB@BJB@JJB@J@@@JBJBBJJHBJBHJB@@J@JBBJJHJJ@HB@@D@HLHHLHLDHDDHDL@DDHL@DLHD@H@H@@DDDLLDH@@DHDLLD@D@@@DD@@D@DD@DDD@D@@D@@@DD@@D@@D@D@D@@D@D@@@@@@@@@@@@D@@D@@DF@D@BDBFBFFBFF@@B@DFFB@FFFBFFBDDBDFB@FFBFDDB@D@@BB@JBJJ@BHHJBJJ@BBJBJ@@@JHJB@HBB@JJBJBBHH@HB@HHHHB@@LLL@DDHDHL@@LH@DLDL@@HLDHDD@LHLHLH@HH@@H@@LHLHH@HH@@D@D@DD@@@DD@DD@@@@DDDDDDD@DD@D@@D@D@D@@DDD@@@@DDD@@@@B@BBF@D@DBBDDFBBD@F@DF@FFBF@DDFBFFDFB@FD@FFBBB@BF@@@H@@H@HHJJJ@@BBHJ@BHJ@B@HHHHHBBBJJH@BB@BBJHBH@J@JH@@H@DDHDDL@H@D@HD@DDLHHLHHHD@@LLLLH@@L@HD@HD@DHH@DHH@@DD@@@@D@DD@@@DDDD@DD@@DD@@DDDDDDDDD@@D@D@DDD@D@@@@@@BF@@FBFFFDFDBF@FD@@FB@F@B@@FD@DDDFFFDDBBFDF@FF@FBF@@@JB@J@HHHBBJBHHBJBJ@B@@BJBHJJ@BBJBBJJB@JHBHHJJJJH@@@L@@DDL@LL@@LDH@HHDDL@@LDDD@L@LH@DHHLDDH@@@@HHHLD@D@@D@DDDD@DD@@D@D@@@DDD@@D@D@@@@@D@@@@@@DDDDD@D@DDDDD@@F@DDB@DBFF@BB@DFBBDFB@@DFD@@DFD@F@F@D@@BFB@FFBFDB@@@BJ@B@BH@@HB@@BJ@J@@@J@J@@HJB@@@B@JJJBBJB@@JBBJHBJ@@@@DDDLHDLLLL@DHDHLLLDLHDDHHDLHDDLHD@HDHDL@L@@LLL@LH@@D@@@DDDD@@@@D@DD@@@D@@D@DDDD@DDD@@D@DDD@@@D@D@@DD@@@@@@@BFB@FBBDBDDF@FF@@@DDBBBBFDB@BDF@@FFDF@B@F@DB@F@@JJ@J@@JJHBBJ@@@BH@BHHJ@@JHHBJB@BH@BJHHB@H@@B@@JHHJ@@DDL@LDL@@L@@LLH@LLDHH@D@D@LD@LLH@DDHHH@LH@DLDHHLLL@@D@@@@@@@@DD@DDD@D@DDD@D@@@@D@D@D@@@D@D@DD@@@DDD@D@@@B@D@DFBF@F@BF@BBB@DD@DDD@F@@DDBFFD@DBDBBDDBFDDDBFB@@B@BJB@BBB@HJJB@@@@BBJHBBJB@@@J@@JJJHBJJBJBHHBJJBHB@@HL@@HHHDD@L@@HDL@@@H@DHHLDDLLH@DLDD@HLDL@H@LHHDLDL@@@D@D@@@DDDD@@@D@DDD@@D@@@DDDDD@@@@D@@DDDDD@@DDD@@@@@FB@D@@D@@@DFFBDFBBD@D@FDDB@@BDDFBBDDBDB@BFBB@@@@@F@@BJHBB@@@BBHBJHBHBHHBH@@BBHBBBBB@BBH@JB@BH@H@@J@J@J@@LHHHLLD@@HHHD@HH@DL@@LLHD@@@DLHL@LLHH@HHLDLDDDHH@D@@@DD@DDDD@@@DDDD@@@@@DD@@D@D@D@@@D@DD@D@@DD@DD@@@D@@@@DB@BFBFD@@BDD@B@BB@@@B@D@DBFFBFF@DBB@@@BBFFBDBFB@@@JJ@@JJHJBB@@@BB@@@B@BJBBJHJ@@JJBBHHBH@BBHJHJBH@HB@@@@DHHD@HH@@DHH@@DDHLLLHHDDHHDDLH@L@@D@HLDDDHL@DDLHH@@D@@D@@@@@D@D@@D@@@DD@DD@DDD@@@@@D@@DD@D@@DD@DDDD@D@@@DFDFDBFDB@FFBB@F@FBBDDDFBDDFB@@FBB@F@FDFD@@@@FDD@@@JBBH@BJJ@H@JHBBHH@HJBBHB@@BB@BJB@JBBBBBHHB@@JBHHHB@@@LLLH@LHLDH@LHDHL@HLLDDH@@@L@HLLD@LHH@HDDH@@DLHD@L@@@@D@@DDDDDD@@@@@@DD@DD@@D@DDD@@@D@DDDDDD@@D@@@D@@@@@DF@BF@BDDBBDBFFFF@B@BF@@FDBDDFDFD@@FD@BBFDFFFDB@B@@@BB@@@BHBBJJB@H@HBH@@HJ@JHHBHB@HJHJJ@@JB@@@BHBJ@JJ@@@@HDHHLDLDDD@L@HL@LHHLDDDHHHL@LLL@LDLLHDDLH@@@L@HHL@@D@@@D@DDD@@@DD@@@@@@@@DDD@@DDDD@@@@@@D@D@DD@DDDD@D@@@FDD@@@@DBDD@BB@DDDBBDB@FF@B@@@DDDFDDB@@D@FDB@DDF@@@BHJH@BBBB@J@BH@BHB@HBHBBJH@@H@JJHJ@H@JJJJH@JBHJ@B@@@@@@DHLDHHHLDLL@H@@DLL@H@@@H@H@LDLHHHHDHLD@D@DDLDHL@@@D@D@@DD@DDDD@@@DDD@DDD@DDDD@DDD@DDDD@@DD@@@@@D@@D@@D@DFB@DFFBDF@DD@@FDBFFFDBFD@FDDBB@BFBFFBFDBD@BB@B@@@BHJHBB@JHBJBBHBBJ@JJB@@@HJBHB@@@@BBJHHBBJHJB@BJBHJ@@LLHLDDHH@LLDHHHDHH@HHH@@LHDHHD@D@HLLL@DH@DL@@L@@HL@@D@@DDD@D@@D@@DD@@@@D@DD@@DD@@DD@D@@DDD@DD@DD@D@D@D@@DF@BFD@BFDFBFBDBD@@DDB@DB@@BFBBD@DD@B@BBD@FDFB@@FB@@JJ@@H@J@JJJ@JBB@JB@JHJB@HJJBH@BHJHHBJBHBBJ@JJJBHHJ@@LL@DHDDLHHLLLDDHDHDH@DHHDD@LLLDL@L@L@DH@DL@HHDDH@H@@DD@@D@D@D@D@@@D@@DDD@@@D@@D@@@@DD@D@@@DD@DD@D@DD@@@@@FBFD@@@BFBBD@@B@BBFFBBDDBFFDBBBBDBFB@B@@@DFBDDD@F@@HBJBH@BJJJ@HHBJJHB@JH@@B@BHBJ@JB@JBHB@JBHJBJJBH@@J@@HHD@@LDHL@HLH@HHH@LH@H@HL@LD@DLH@LLHHHDDD@HHHDHLDL@@@DDDD@@@DD@@@@DDD@D@D@D@@@@@@DD@DDDDDDDD@DD@D@@D@@@@@@BF@@BBDFFB@FFBDB@DBFFDDBDBDDFFFFFB@BFBBDFDBBDFFB@@@B@HH@@@JHJ@BH@JJHBJHHJ@H@BJBB@@B@BJ@@BB@JBBJ@B@HB@@H@H@LDD@@LDHH@LDLH@@LLDHHHL@HDLHDLL@HHH@@D@LHHHLLH@@DD@@@@D@@@@@DD@@DD@@DDDDD@DDD@DD@@@D@@@@DDD@DDDDD@@@@B@BF@DB@DD@@B@@@BDDF@@FF@@@@D@@B@@@@@BD@@@B@FFDFD@@@@H@@@JJJ@@B@JH@BBB@BHB@JHBHJ@@@@@HHBBJ@@JJBH@J@@J@@H@H@HH@@@D@@HHD@D@HLL@LL@DD@HL@@L@@LHLHDH@@@HH@HD@@@DD@@@@@DDD@@D@@DDDD@@D@@DD@D@DD@D@D@@@D@DD@@D@@@@@@@D@FFBBB@@@FBDFDDDD@FD@FF@BFB@DBBD@DF@FBBBFBDFBBDBD@@BHB@H@BBJJ@@@BB@@J@JB@BHJ@HBJJH@@@B@H@@BHHHHBHJHH@@@DHH@L@DDHHLHH@@DL@@D@LHD@@HDHDD@HLDL@HLL@@DDLHH@HH@@D@@D@@DDD@@@@@DDD@DDDD@@DD@@DD@DDD@@D@@DDDD@@@D@@D@@@D@@@FDDFB@@BBBD@B@FBDFD@BB@@DBBDBDFD@@@BDBFBFFD@F@@) (il:rpaqq *seersucker-bm* #*(200 200)@@LLDLLLDHLDHD@LLD@LDHDL@L@L@@LDD@LDLH@@@DHHHLLLH@@@BEJELBGICOEJDCNHNLJFG@AJFMMOKM@BK@NLDEHK@MIJN@NJLB@@DAD@@EEEA@DA@EADADDAEDADEEAE@AE@A@@ADDAAAAE@D@DE@E@@@@@@@BBBB@B@BB@@@B@B@BB@B@B@@@B@BB@B@@@@@@BB@@@B@B@@LH@@@DLDHLDH@HHDDHDDDD@@LLD@D@DL@LH@HLLH@HH@HLDH@H@@M@N@@GODGEKKD@LMJNAO@KNFHBGABFCLFNBDOC@CCELAMANDLA@@DD@DA@@AAEEADDEE@E@DD@EE@EDEAA@ADEEEADEADDADDAEEEE@@@@@@@@@B@BB@@B@@B@@BB@@@B@BBB@@BB@B@@@BBB@B@B@B@BB@@DDLDD@L@LHD@@LLDHLHHD@L@H@LDHLLLHDLDLHDL@@HD@DHH@L@@JACHHFLLDNOLAGNMOBODBLHFELIJDEMDNINHBIC@MJGNAAHMIE@@EAD@AAE@AE@DD@DE@AAAAEDAE@DEADDDD@EAAA@ADDDEDEE@@@@@@@B@BBBB@@@BB@@@@@@@@@B@@@@@B@B@BBBB@@B@BBBBB@B@BB@@D@HDDDDD@H@HLD@LHHLDL@HL@LH@@DL@H@@LDHLHD@@@HHD@HL@@ICJOONKJ@OIFLA@LDM@MGMDHFFBEMBNLKKCA@IAODJGO@LJJNB@@ADAD@AA@ADAAD@DDDADDAE@AEDAE@@@@@A@AEE@DEADEE@A@DA@@@B@@BBB@@BB@@@@@BB@B@BBB@B@BB@@BB@@@@@@@BB@BBB@@@@@@@HHHLLDL@H@D@DL@D@LLLDLHLLLDDL@LL@@D@LHD@@L@LH@DHH@@CNODD@MKBIIOIKD@EAKKM@DDCEHLKHEBGCFIHNBGNNIABMCHGH@@D@EAAD@EA@DD@EDE@DD@AEAED@@@@D@AADEE@@EDAEDEDAAA@D@@BB@BB@@B@B@BBB@B@@BB@@B@BB@@@BB@B@BBBB@@B@@BB@BBB@@@LD@HLLLD@H@DLLH@LLHDDDDLD@@@L@HH@HD@LHLDDD@HLHDD@@@@ADHKIDNKHGNGJLFELCMDENHGJFJMKD@AEDAIODBCKIGDMKAKJH@@E@@@D@AAD@EA@EE@DD@ED@DE@EEDA@@E@@@DAD@ADAEDDE@DED@@B@@@@B@B@@B@BBBBBB@B@BBB@@B@B@@@BB@@BBB@@BBB@@BB@B@@HLDD@L@@@DLH@@HLD@LD@DDHLDL@H@HLDHDDH@LHHHDLDLHHH@@@HLDGNAOCHNKMCEFMI@NKCJGOKA@MLADONOJIENAAJK@ICIIEBK@@EADDDEAD@D@DEEADAEAAD@ADED@AEDDAEEAAE@@AEE@A@DDD@A@@B@BBB@BB@@@@BBBBBB@BBBB@B@B@@@BB@@@@BBB@BB@B@B@B@B@@HLL@H@HH@LDLHL@@DD@@HL@@D@H@HH@@@DHLDLLLD@LL@DLDLD@@ENLLAENFHIKMHHENHGOBBAKNJCAHBCMMEMC@KAI@GLGEMLNKKH@@A@@@A@DEDEDDEEEDDAAEEDAD@@EEDED@DDD@AA@EDDAE@@D@DE@@@B@@@B@@@BB@@@@@@BBBBB@B@B@B@BBBB@@B@BB@@BBBBBB@@B@@DHHHLDH@D@HH@LH@@@HHHDDLHD@DHHHD@HHLHLLDL@@LHLDD@D@@CBCMGHBLNLKEAINBCOAAMFMMEBFLOAA@OCBEF@DDHODJEKDMJH@@DEEAEEDED@DDDADD@DAE@DE@@EDDAA@@A@DA@AE@E@D@E@E@@D@@@B@B@@B@BB@BBB@BB@@@BB@B@@B@B@@BBB@@@@@B@@BBBB@@@@@@DLH@H@D@DDDLDHHLDDD@DD@@D@@LLDLHHHLHDLDHLDDDDHH@L@@@DLCED@KLAKAKFHFD@IOGIDONMLICCEKDCOHAFIDK@FCM@EBHMK@@EEA@EDE@@EEA@AD@DDE@@DAEEEDDD@D@ED@@EEAAD@AE@AEAAE@@BBB@B@B@B@BB@@@BB@B@B@@@@@BB@@@BB@@@B@BB@@BBB@B@@@@@HL@@@DHHLDLHLLDDHLHLLL@HDH@L@LDLL@DHDHLDHH@HDDDDD@@@GMKDDM@ACLOIEGAIJLELBNBALHIDMKJGIHHGHBDONAKAKHJOLK@@EAD@AA@@EADDAEADAEDAEE@AAEE@EDDDEAAE@AA@AADEEADAEE@@B@@BB@B@BBB@@B@@@@BB@BBBB@@B@B@@B@BBB@BBB@@BBB@BB@@@LD@DH@DLLDLH@@DDH@@D@HDLLL@DDDDLH@HHD@H@DL@D@@DDDH@@GAJOCNEHCGNKNAAKGAHODJC@AGLKIFNILOJCBFBG@FKHBJHBHA@@EAE@@EEAADAAD@AADAEED@DADA@E@A@@@DA@EEAE@@DADEADDD@@@@BBB@B@@@BB@BB@@B@BBBB@BBBBB@@@@@B@BB@B@B@@@B@@B@@@L@DL@@DD@@LD@LLLHLL@@HDDHDLHLL@DHLL@HLD@DD@@LD@LD@@@DBACKLKGJLINFILDJOOECENHEIADMFCDL@JAK@@MKKDOLBMLBJ@@DEAE@ADDDEDD@@E@AEEDDADADDE@ADA@A@A@AD@DDA@@@DD@DA@@B@@@@@BB@B@BB@@BB@@B@@BBBBBBBBB@@B@B@@BB@@B@B@BBB@@@@L@HHLLHLD@LLDLHDDD@D@LHH@DHHHHLHHLL@HDHLHDD@@@LLD@@OELCBF@MMEGDGLHJMMJEEJAJOJHAO@DCNOOGLGCI@LKIFAIA@I@@D@D@DAD@D@AA@@AAE@AADEDDA@DEDDDAAA@DE@@DEAE@E@DD@A@@BB@BB@B@@@B@@@BB@@@@@@@@BB@BB@@BB@@@@BBBBBBBB@B@BB@@@DDDDDHLDDL@@DDHDDH@HD@HLHLHDHHDLLH@LLD@DLDL@@HD@L@@HJHFFGJOOKNJECBKIHH@JDDOJ@IFCBLAAFFO@OMJIAHLEMBIFB@@@@@EED@@EDD@D@AE@EAAA@@@EED@@@ED@AEA@DE@EAE@EE@EDA@@B@@@@@B@@BB@BB@B@BBBB@B@@@BB@@@@BBBBB@BB@BBBBBBBBB@@HLHHLDDDLHL@@@DDLHLDHLDHHHL@LLDH@HLLDHL@LH@DHH@HL@@@INNCBCNGBIGD@OMGM@LKHFEDMJCJKFNAC@NGAMGBBFDNM@JAGJ@@@DAD@AD@A@@E@DD@AA@@D@DA@DEEEED@EEE@DEEEEEDDEAEAE@@@@B@BB@B@@B@@B@B@BB@@B@BB@B@BBB@BBB@BB@B@@@@@BB@@@B@@@@H@DHLHD@@LLHLLHH@LLDDLHL@LHHDDDD@D@HHHDLL@L@@HLD@@OCAJABAJLDCG@MEKGNMKBA@@CILDBOACEDFOMODKJGICNFFAAJ@@DDA@EDAE@@EEDEE@DAEE@EEAAEE@E@@@@A@AAAAEEEE@ADDD@E@@B@BBB@BBBB@@@@B@@@B@@BB@B@B@@@@BB@@B@@@BBBB@BBB@@@@@H@DHDD@DLLHDDHH@DHHLHHD@LLHLD@DDLDDD@D@@LDDDHLHHDL@@HBKCKOB@AEDGMCE@@OGE@HG@AMHNGAFCKGFJKJGAL@HBH@LFMM@@EDDDAADAE@EEAEEDE@A@ADA@@D@@D@@AEEE@D@DE@AEE@@EDED@@@B@@@B@@@B@@BB@B@BBB@BB@@B@B@@B@@BBB@@@@BBBB@@@B@@@@DHH@@DLD@@DHLHDHHLDDHDLH@@LLHDDDDHDLD@@LHHLD@LDLH@@@JH@BFNEOGNLIMOBJEGNANOJAONA@NLDEFIHANFDGAJILNDMBNG@@DEEEAAAE@@AAAE@@@EDA@ADE@AE@DA@@EAAD@AA@D@@@@DE@DD@@B@BBB@@B@B@B@@BBB@BB@BB@B@@B@@BB@@@B@BBBB@@BB@@B@B@@HH@H@DLHLLLDHDLLHHLLLD@DHD@@DL@@HHLD@@@DLHL@LDHH@H@@KMG@DFGHF@EDLOAFMGDBFOFIDBKJB@@ODAAFCAFFFIOF@DGHOM@@D@EAA@@ED@A@ADDEDAA@@@@DEDAADA@@EEDD@AADEAADADAAEE@@@@@B@@@BBBBBB@@BBB@@@@@@BB@@B@BBBBBBBB@B@B@B@@B@@B@@DLDD@HHHD@DDLHHDLLH@DD@L@@@H@HDDDH@DDDLD@HHL@@@@@H@@AKFLOAMHMFGDOAOBIGFECABDDKOHNOAJHBKAOC@KJCMGIAKLAL@@EA@@@ADE@DEA@DEEDAAD@D@@AAAEAADEDEE@@@@@E@EDDAE@D@@@BB@B@@@BBBBBBB@BBB@BB@B@@B@@B@@B@@@@@B@@BB@B@@@@BB@@LHDDDHL@L@DDLLH@HHL@@@HHHH@HHDLLL@@@DDHHLDLDL@DH@L@@OIFJFKLFKGE@AOMGAMG@OKOMKKECM@HK@KLDMEKAJIJNDLNLNL@@DDEDAEDD@@ADD@@EAAE@DDD@D@EEEEEE@DADEDDEAEEEAADE@E@@B@BB@B@@B@B@BB@@BBB@@BB@BB@B@@BBBBB@@@@BB@B@B@@@BB@@LHDHLLD@HL@@HHHHH@LDD@HDHDDDLH@LH@@L@HLDLLL@LHL@@D@@NKHFHJBONBGNA@CLCH@@DEIKLKHMDMIKALDHHCDJOOJAKF@HHK@@AA@DEEEDD@D@EADA@AAE@@ED@DDDAA@DEAA@EAEEAADD@EEEEA@@BBBBBB@@@@@B@@@@BB@B@B@B@B@BB@@B@@BBBBB@BBB@@@B@@B@@LDD@@LH@LLD@@DLHLHHHDHH@L@HDLHDDHLDLHHDH@LDLD@HLLD@@INACNHJ@ODAKNIFHDNBBBIJKCDC@FMJJMGJAAIODODLCMLELOK@@DDA@DE@EEAED@DD@E@@DEAD@@EA@AD@@A@AA@D@DDD@@DEEE@E@@@BBB@@B@B@@@@B@BB@BBB@@@BBBBB@BBBB@BB@BB@@@@@BB@@@@@HLLDDH@D@LD@HDLD@HHDD@DLL@@DDLDHH@@@HDLDDHD@H@HH@L@@GDBMAEHGCGAAEE@JBCMOLNFFJFNLMNAN@NIOFNACLMHNMFNGKJ@@AA@D@DADEED@@A@DDDED@@A@EA@DEDDAA@@E@DEDDAEA@@@@EE@@B@B@@BBBBB@@BBBB@B@BBBB@@@B@BBB@@BBB@B@@BB@B@@B@B@@@DHDL@LHD@L@@@LHHDD@@DHH@HDDLD@HDLHHDLHDHD@L@LD@L@@@@JODKCMNMEGKOKINMAJE@JNBMLAHBKDD@IKLBEHFBKNFDDJHNCE@@ADDDEE@AAEAE@DEA@EA@EDEA@@DDA@EEDAED@EAD@DAADA@E@E@@@@@@@B@@B@BB@BB@@BB@B@B@BBB@B@B@@@B@B@B@@@B@B@@B@B@@HHLH@LLHHDLDLHHDDDHDHLLHDLD@HLDHL@HLHDDH@H@@LLL@HD@@ODCINDACHHCHGGLEKMDNFHKGACGL@NIECLBFJOGHLHEGDOBNGL@@EADDE@@@AEE@DADEA@@DEDEDD@DDAAEADEE@E@EAED@DE@A@AD@@@BBBBB@BB@@BB@B@@@@B@@@B@@B@@BB@@B@@@@B@@B@B@@B@@B@@@HDDDLHHHLHHHLHHLD@@LLDL@H@LH@@LLDHHH@@D@LHDLD@@HH@@HKLI@BNNA@IAEMMHJFJ@BAGIBADJFJBLDMLGEGGOMBFCHNEBDA@@@@@EDED@E@@D@D@AAEAAA@@DDDD@@DA@EDD@A@@AEAD@@@@EA@@@BB@B@@B@B@@B@B@@@BBBBB@@B@BBB@@B@@B@@@@@BB@@@@@B@B@@HH@@@LDHD@H@LD@@H@@@DHDHDLDD@H@@DL@@H@LDDH@L@@LLLH@@DMLD@FCFNJDDEDBOKBMDFCHBEBCMFLBGMOKJOBFC@B@NLON@MM@@EAAD@EDAEDEDEA@@@AAA@EAA@AAEDAAAD@@@@D@DEDAEADEDEA@@@@BB@@@@@@BBB@B@@BBBB@@@B@BBB@BB@B@BB@BB@@@@@@B@B@@@HHHD@@@HH@@L@H@@@DDHHLHHH@HH@@LLD@H@@L@LLLDHHH@L@L@@NFOJLLG@DFJLLOEAHLFMJII@BGKAHNGDD@BGFMHIMDLNBBCKAH@@AD@DD@A@@A@@AA@@EEDDAA@AAADEA@DADEDDAE@EDDDD@D@AE@@@BB@BB@@BB@B@@B@@@@B@B@@@BB@BB@B@@BB@BBB@@@B@@@BBBB@@H@HD@@LDHDHHLDDLHD@HLDHHLH@D@LDHDHDLL@LH@DHL@@@HDD@@JGMFGKONOLFCBMBINCNEJEFONKKHGHICH@MGFGDLBLEFLDBMEC@@ADAAA@EEEE@@@D@ADEAAEDEDDE@EAD@EDAAADDEAAD@AEAAEDE@@BB@BB@B@@BB@BB@B@BBBB@BBBB@@B@@@BBBB@@@@@BB@@@BBBB@@LHLLHD@@DHLH@@LLHL@D@@HL@L@DLLHHHHLHLHHLHDL@LLLH@H@@IDIFDJEEAFAFNNN@COJN@INCNAKJ@HL@ELNKICM@FHNAGCEJEH@@A@AEAE@ED@DA@AEDE@DEE@AAAEDDEEDE@DD@@@ADAADEEAD@AE@@B@@BBBBB@B@@@@@BB@B@@@B@B@@BB@@BBBB@@@BBBB@@@@BBB@@@HDHL@DLDDDH@DLH@@L@D@HDHDDLLL@L@HLDD@L@L@DHLLHLDLD@@EAHMJILKOGKEDJGLCFGHO@ENKEAK@H@AFGDMNDIA@FIELODCE@@@DDAAE@EEADED@EA@DAAADDA@E@ADAD@EA@E@D@AAAAA@@A@AAD@@@@@@B@@@B@BBBBBBBB@@B@@BBB@BBBBBBB@@B@BB@BBBB@@B@@@@@@@H@HH@@HHH@HHDD@H@L@D@HHLD@LDD@LH@LDDLH@L@@HHLH@@@LONADFJGHNBCOHCGOEM@BJMEJFFCNINKNIBHKABHCCNIMIJAJK@@D@EADE@AADD@DE@AA@DEEEDDDADEAEA@DAEADAAEEDA@@AEDDA@@@B@BBB@@@@BB@@BBB@@B@@B@BBBB@@@BBBB@BB@B@@BBBBB@BB@@@HDDL@HHLLLDD@DHHDDHH@@DLHHHHDDDHLL@DDD@@HHDH@H@HH@@JAFDIFGL@J@FCJG@DEMIKNJJID@@LMMNHBCLAKF@IGCGIKBDJK@@DEA@A@DAED@@ADEDE@DE@ADEA@DDEDEEEEEAAE@E@EDE@E@@A@@@BB@@BBBBB@B@BB@B@@@BB@B@B@@B@@@@@BBB@@BBB@B@BB@BBB@@DHD@LDLLLDDH@LHDLDH@D@D@H@HLLD@@LD@LHD@LLDLHHLLHH@@@LCBGEOCMOABNEKBKJGEMB@LDEGBNANJAFHHNFGICA@@JHINEBG@@E@EEED@DE@@E@D@@@DEEAAE@D@@A@@D@AA@@AEEDDEAEAEEDDE@@B@@@B@@BBB@BB@@BBB@BB@@@B@@@@B@@B@B@@@@BBB@BBBB@B@@@DL@@DDH@@L@D@@H@L@@@LDH@@LL@@D@@@HLL@DH@DDHDDLHDL@@@@EFENHGLNONBFHFKLOMEMJEEJKFLHGENIEBJGHFMBMC@OOMCOI@@EA@AEEDEAA@AE@ED@AAEA@EAEEEDAEEE@ADADEDA@@DAD@@EEA@@@@@@BBB@BBB@B@@B@BB@@@@@BBBBB@B@B@B@@BB@B@B@B@@B@B@@LL@LDDLLLD@H@D@DLDDHLHDDLHH@HDDDL@@HLLDDH@@@DDLHHH@@FGM@MGNCBLB@MLH@NODIHAD@DBODCMNHCDEHHIAMJADOEJKLLO@@EAAA@A@@AED@DEEAD@EDDAEA@@@EAEAD@@@DADAED@@@DDE@DA@@B@@@@BBB@B@BB@BBB@@@@@@@@B@@@@BBB@@@B@BB@@BB@@@BBB@@@@@LD@@D@DLLH@@@@DD@HL@DLD@@@HDDLHLL@LLDL@HLDLHDL@@@KNA@IKIFFAOCAHDLCA@KBEJHLFFMNIAGNFDCIMDLAHAOIJEMGN@@@DAD@AADDED@AAE@DDDAAE@@ADDDEE@A@ADAADEEED@AEDD@@@@@BB@@@@@@@@@BBB@BBB@@@@B@@B@@B@@BBB@@B@B@BBBB@@@@@B@@DHH@DD@@DDH@HL@L@HL@H@@@DLD@@DD@@@HDHDD@H@LDDL@L@L@@NHJKLOEA@HHJFAHJ@DMACLNKECB@DOKOALNIHCKKMDOGDDKHCD@@AEDADDDE@AADEDEA@@@AEE@ADAEAD@AAD@DE@D@ADE@ED@AADA@@@@B@BBBB@@@B@@@B@BB@@@B@@@@BBBBBB@@BB@@@BBBBB@BBB@@@HL@@LHLLDDD@D@D@@@@DDH@@LHHDDLLDDHHDHDDDLLHLDLDH@@@@CFKJGCKKCAGJJC@FEHNMLHHGDJIEGNH@OABG@JNGGFIOCDFNHH@@DAAD@A@@AE@DAAD@@@EEAEEADED@A@@AEAAEDAEA@DD@DEDD@D@@@@B@B@BB@B@BBBB@B@BBB@@@BB@@BB@@BBB@B@B@B@@@@@B@@@@@LDDLD@HHDLDHH@@LLDHH@DLDDDD@@@L@DHDDDD@LHD@DLDHHLD@@@MONJ@LHMGJBNKDIMAHNNGEHAA@NBINOEANHHBJGFIABDMIEAL@@@AEAADDEDDE@A@@@@EE@EDA@DAEEDAA@E@EDEEEEA@EAA@D@AA@@@B@BB@B@@BB@BBBBB@B@BB@@B@B@@B@B@@@B@@BBB@BBB@B@B@@@@D@DDDH@@LL@@LDL@HD@HLDLLLDLD@HHLHHD@L@@@D@LDLDLH@@@AHGHJOEOEFECM@KMCLJJNDDDJIKNBOMOBODNLHFELIBB@MBKIN@@DAAADAEDEA@@DD@AAA@AA@DDD@@EEDE@AA@@@DAE@DDADEED@D@@@B@@@@@@@B@@@BB@@@@BB@B@BB@B@@@@@@B@@B@@@@B@B@@@B@@@DHLHD@@DD@L@DHDDLDDLDLDDHH@@H@LHHLDL@HLHLHDLDHHD@D@@CAAEIODJHINGLNCIC@FOOBHAABH@J@LDLHIJHDHLFBE@FGOGIM@@AE@D@@DDADEDE@AAEEE@DEDAEEEE@EDDAEEDDA@EDA@@A@E@@E@@@@@BB@@BBB@B@@@@@B@BBBB@BB@@B@@BB@BBBBBBB@B@@BB@B@@@@HLL@D@HHDL@@LD@HDLHD@@@HL@L@D@D@@@LLH@@LLHDDDHDHL@@NMKOEFHI@LOGIJKFJICHHJCBNKFIHG@E@HOLMADHCFLABNBAKL@@E@@DEE@E@AD@ADE@@@AE@DEA@DE@ADE@EAADDD@DDADDADAE@D@@@B@BB@@BB@BBBB@B@@@@@B@@B@@BBBB@@@@@B@BB@@B@BB@@BB@@HHDDHDL@HHHDLDD@H@@HHLD@HLL@HD@LLLL@LDL@@L@LHLDLHH@@OOCEHFDNJHNLOGGHGHFKADKHGF@MNMELCNCLCFHBFO@IHDFICK@@DEA@EAE@E@DA@@EA@DED@AAD@AEA@A@DDAEAA@ED@EE@D@EEAA@@@BBB@@@@BBBB@@@B@BBBBBB@@BBB@BBBB@BBB@B@@@@BB@@@@B@@LDH@LD@LHL@HHDLHLDDLH@@@@DH@LDLD@H@L@DLDLL@HHDH@@H@@IHD@BMGKM@HOKAJHIALICICHNCNE@DMI@OLJKJEEG@IJJDHLDO@@AEEDEA@ADEAAAADEE@D@EAD@@@A@@DDAEDEEDEDDAEDAD@@EA@@@@@BB@@BB@BBB@BBB@B@@BBB@@B@B@@BBBBBB@BBBB@B@BB@BBB@@DDDHLD@DHHLD@H@HHH@LHHH@LD@HDD@DDDDLD@DD@H@DH@@DLD@@IBJBLGEBBOGKIAMEOI@AMNFHHJL@IENHGNOCJHK@CGAMKIJNOJ@@DDAA@@D@@@@@ED@ADD@@DDEDDADEEADDA@@DAAAADDD@DDEDDA@@@B@BB@@B@@@@@B@@@B@@B@@BB@@@@@@@B@@@@@B@@@@B@BB@B@@@@@HDDDHLL@D@DHLD@D@@@H@DLL@LLD@@@DLL@DL@DHH@LDL@DL@@H@J@IHBACGB@JIDCG@IONBLN@FGAHNBCOAAMKLIEIBBCIK@JE@@@EE@AAA@EDDA@E@ADEDE@AE@@EE@DADD@DAEA@ADAEEA@D@@A@@@@@@BBBBB@@@BB@B@@@@@B@@BB@BBB@@BB@@@B@BBBBBB@BBB@B@@@@L@DL@@DLH@@DDDDDHDHD@@LL@LDLHLDDD@@LD@DLHHLDHHHH@@@FIH@OCEGIKNKIC@DLCADBMJFCAKFJFD@IOGNCILMC@GEMHKAHK@@E@ADA@DDE@AA@@EEE@DEDD@AEEA@DD@DDE@@DAADDED@A@DA@D@@@@@@@B@@BB@@BBB@@B@BB@B@@BB@@@BB@B@B@@@@B@BBBBB@@B@@) (il:rpaqq *burlap-bm* #*(200 200)@@HH@HHH@HH@H@@HH@@H@H@H@H@H@@H@@@H@HH@@@@HHHHHHH@@@@A@A@@AAAAA@@A@@@@@@A@A@@AAAAA@@A@@@@A@A@AA@@@@@@@@@DHL@JFFD@BLB@D@NBFL@NLBFFLJFJBNHJB@HLF@BHJFJDJDFBD@@@@@@IHII@AAHHAI@@I@H@@@III@IAIH@@IH@HIAAI@AI@HAAII@@HH@@@@H@HH@H@HH@@H@@@@@@HH@@@@@H@HH@HHHH@HH@HH@H@H@@A@@@@AA@AAAA@@@A@@AA@A@@@@AA@@A@@@@@AA@AAA@AAA@@@A@@FDHD@J@HBDFJLLFFJLBDN@LF@DDFHB@HNNDNJLNBDF@LLJLLLD@@IAIIAHA@H@@IAHHIIAA@IAAHAHHIA@A@IAHIA@@HIH@HI@IAII@@@@H@@@H@HH@@@HH@HHHH@@H@H@H@HHHHH@H@HH@H@@H@@@HH@H@@@AA@@@@@@@A@AA@AA@A@@@@@A@A@@AA@@A@@@AA@A@A@AA@AAA@@LHDH@HFBBF@FDJNFJ@J@JFFHNHDNBDLFD@FBH@HBDLDDFFNBJB@@HHHAHAH@@HH@HI@AH@IAIIAAAAIAAIHAIIHAAHI@@IHIHAAIH@@@@@H@@@@@@H@HH@@HHHH@H@HH@HH@@@H@H@@H@HHH@@@@HH@@HH@@AA@AA@A@@AA@@A@@@A@AAA@@@@@AA@@@AAAA@AAA@@AA@@@@@@@@BNJNBB@HHD@BD@NLLBNF@LBHNLBN@@@H@@B@NDJDNJFNL@JBDH@@I@A@HAI@HHIAI@@@HHHHIAHIAI@HAHIIA@AHAIA@AHHII@IIAH@@@HHHHH@H@H@@@@H@@@HHH@HHHHH@@H@HH@@@@HH@@@H@HH@@HH@@A@A@@@AA@AAAAA@@AAAAA@@@AA@@A@A@AA@A@@@A@@AA@AA@A@@@NJLJ@N@LJ@DLBNLLHNLJJNJNF@JJ@LJHJDNDBHDNBNLLF@HBJN@@@HIAHIA@IAHAA@IAIIAHHHIHAAI@A@II@HIAA@AAAI@HIHAHII@@H@@HHHH@@H@@HHH@HHH@@@@H@@@@H@HH@H@@HHH@@@@HHH@@@@@@A@@AA@@A@A@A@@@A@AA@A@@A@@@AA@@AA@AAA@@AAAA@AAAA@@@@DJH@D@HJLBFH@DD@FD@LLHFLHNNDBJBNJHHN@NJ@NJNDLNJNND@@A@AHIA@II@I@IHH@AIA@AIAI@HHIH@A@@AIII@H@@IIAH@AHII@@HH@@@H@@@@HH@@HH@@H@@@@HH@H@H@HH@H@@H@HHHH@H@HHHH@@@@@@A@AAA@@AAAA@AA@@AA@AAAA@A@A@A@A@AA@AA@A@AAAAA@A@@NBLLDLBLBFJLFNJNHFHJL@@DLNJHNLNHLLHJLBJHNNJJHFNDHH@@AIIAIAHAA@AH@AA@@H@H@HHI@HA@HI@IH@AI@HIHHIIAAAIHH@@@HHH@H@HH@H@HHH@@@@@@HH@@@@H@HH@@@@HH@HHH@@HH@@H@H@@@A@@@AA@@@AAA@@A@@AA@@AA@@AA@@AAAAAA@AAA@A@AAA@@AA@@@JB@JJHDLLFFFNDFDNBBLLDBDHHFNLDN@FDFJHBJDLF@FJJLHDL@@@AI@AHAAA@HI@AIAHHHAAAHHAAHIHHIA@@@A@@A@IIHAI@AAIH@@@HHHH@H@@@HH@HH@@@HHH@@HH@@@HHH@@HHHHHH@H@@HHH@@@@@@A@AAA@@@@@AAAA@@AAAAA@AAA@@@AAA@AA@A@@@@@A@@AA@A@@@@DDFJNLLNN@NDD@LLHNBFHLL@JDDLBHJJ@@LH@HLJDJF@FHL@HD@@IHAHHHHIIHIIHH@AA@IA@AAHIA@H@AIIHIAA@AHAA@@IIAIHII@@@HH@H@@@@@@H@HHH@@@@@@@@@@@HH@HHHHHH@H@HH@@@@HH@H@@@@@AA@@A@AAAA@@@@@AAAA@A@A@AAAAA@AA@A@A@A@@AA@A@@AA@@LNHJFDDBBDFBJHFBLLLBBL@DFFDNLBLBDL@JNLJJDB@LHJFBHL@@AHAH@AIIHH@IAH@A@HH@HI@A@IHI@H@IA@IAIIAIH@I@I@AAAH@@HH@@@@HHH@HHHH@@HHHHHH@H@H@H@H@HH@@H@HH@HH@H@@@@@@@@AAA@@A@AA@AAAAAA@@A@@@@A@@A@AA@AA@@A@@@A@AAAA@@A@A@@D@N@HBH@LBFNJFJF@FDHDNBHBFDHLLNDD@JNHH@HBBFLN@LBFF@@@IIHHIHAIAHIIAIH@@HIIH@HIHIAIHHH@@H@AHIIIH@IHHIA@I@@H@@@H@@HH@HH@@@@H@@@@H@HHH@@@@@HH@HH@@H@@H@@@@@@@H@@AA@AA@A@AA@A@AAAAA@A@@A@AA@AA@@A@A@A@@@A@@A@@@@@@A@@N@LBJFDJJL@BNHJ@NBFDLJDHL@JD@BHJ@FH@NL@FJHLBLDBLFN@@HAAHAH@@AH@H@@@H@IAAIH@AHH@HH@HA@AA@@AI@II@IIHIIIH@@H@@H@@@@@@H@@HHHHHH@@H@@H@HHHH@@HHH@HH@@@@@@H@@H@@@@@@AAA@AA@@A@@A@@@AAAAA@@AAA@A@A@@@@AA@@AAA@A@@A@@@@@FNHFJ@FDFLFDJHDJHDLNNBFBFNLJBF@HBJBJJD@NNHHHJLNJNB@@AIAAHIII@I@@@IHAHIAI@IHAIH@@A@@IHAI@IA@@@IIIA@HAAA@@@H@HHHHHH@@HH@HH@@@@@@HHH@@HHHHHHHHH@H@HHH@@@@@HH@@@AA@A@@@AAAA@A@@@AA@AA@A@A@@AA@@A@AAA@AAA@@AA@AAA@A@@FBFHFJNJFJB@BHBHNBH@FFLLBJDLNFN@BJHFDHHNLBN@NJNNJH@@@@@IA@HIAIHAIAAI@AI@AAHIHIIA@IH@AHIAIIAH@@@IAI@@AA@@@@@@@@HH@@H@@@@H@@H@H@@HHHHH@HH@HHH@HH@@@H@H@@H@@H@@@@@@@A@AAA@@AA@AA@@@@@@A@@A@A@@AA@@A@AA@AA@@AA@A@@@@@BHDLNHBFFLJF@HFBL@J@HBHLFFBJHFNBBFJHDNJDBNHFNJFFJ@@@H@IAAIIIAIIHA@I@AHAIAIHAAIIAAAH@H@IHI@IIIAHI@IIAI@@HHHHH@@@HHH@@@@@HHH@HH@HHHH@HH@H@HHH@HH@HH@@HH@HH@@@A@@A@A@A@AA@@AAAA@@A@@A@A@A@A@@AA@@AAAA@@@@@A@@AA@@@BN@FJ@FHJJ@N@DLB@@J@LHFBHLFNLNFJDLFHDLDLNDLNN@DHN@@@HA@I@@AAIHAAHIAA@HH@AAH@AAAAIIAHIAHHH@I@AA@AH@@@HA@@@@H@@HHH@@@HHHHHHH@HH@@HHH@HHH@@@@@@@HHH@HH@H@@HH@@@AAA@A@A@@@AA@AAAA@AA@A@@AA@@@AAAA@@AAA@A@AAA@@@AA@@@FLJ@NN@L@JNFLLDBFBNLBLFHHDFHNJBHBHJBJJBFFFDHHFNNHD@@I@HAAIAAIAHI@@HA@@HHIHHAH@HAHHHHH@AIH@@IHIIAHAIIHA@@H@@H@@@@HHH@@HH@@HHHHH@@HHHH@@@@H@@@@@@@H@@@HHHH@H@@@@AAAA@@AA@AAAA@@AAA@@A@AA@@AA@AAA@@A@AA@@@@@@@@AA@@NDDDBHNBF@NFBNFLL@JHHFBBBLB@LHHHDLN@LHLD@HDNJHDFLL@@A@H@H@@IAA@A@AIAAA@AIHH@@@@AHAA@@@IH@@@@@@H@H@HAII@@@HH@@@H@@@@HHH@HHH@@H@HH@@HHH@@@@H@H@@@HHHH@@H@HH@@@@@@@@@AAA@@AAA@@AA@A@A@AA@A@@@@A@A@A@@@AA@A@@@A@@A@@FLLNJJJDBBH@@DBHJFLH@HNNB@NJDJJBDHHDB@HJDJB@HNL@FN@@IIIAH@HH@I@HH@AAAH@A@I@HI@IA@AH@@IHAI@@@@HH@@HAIAA@@HH@H@@HHHHH@H@HHHHHHH@@@H@@@@H@@HHH@@@@@HHH@H@HH@H@@AAA@@@A@@@A@@AA@AA@@@A@A@@A@@@@A@AA@AA@@@AA@@@A@AA@@NBF@BHBNLBB@BNFFFB@BHBBFFDB@NBJHLNLLB@HFDBHFHDBJFD@@IA@AIHIA@A@HH@A@AHAIA@HH@AI@HII@HHHHIAIIHIIAHA@I@A@@@H@@@HHH@@@@HHH@HHH@@@@H@@@H@H@@@H@@@@H@@HHH@@@@@H@@AA@@AAA@A@A@AAA@AA@AAA@@@AA@@AA@@@AAAA@A@AAAAAA@A@@@FBJ@HJFDHFL@JFLLL@JF@NHHHB@NBHNNLDLBH@B@FHFLFJNHF@@@@IAI@I@AIIIA@AII@@AHAAH@HIIHIAIHHIHIA@A@H@A@HH@IAA@@HH@@@HH@H@@@HHH@HHH@@@HHHH@HH@HHH@@@@@HHH@H@H@@H@H@@AA@@@A@@AAA@AAAAAAA@AAAAAAAAA@@A@A@@AAAA@A@@@@@@@@@@FNNNHNLLBB@NFHBF@BFHDNN@L@NDLNLNJNHNNNNFJLNFJJNN@F@@HIIII@HHHI@I@IA@@HAAIHAA@AI@I@AHA@AIII@H@@IIHH@IIH@@HH@HHH@@HH@@HHHHH@H@@@H@H@@@HH@HH@@H@HH@HHH@HHH@@@@@@A@@@@@A@@A@A@A@A@@@@AAA@A@A@AAAA@@@@A@@AA@AA@@@@A@@@BHNLNFDD@NHFBLHB@@NHHLNHFLDHJJDFHHHLHLL@HLDJDLFDH@@@HAHAIAH@@I@II@@@@@AAIIIAA@@@A@@HHAI@HAA@@IHHAIHII@@H@@@@HH@HH@@@@HHHHHH@HH@H@H@HH@@HH@HHH@H@H@H@@HHH@@@A@AA@@@@A@AA@A@@@@@@@A@AA@A@@A@@AA@AAAA@A@@AA@A@AA@@NDH@LFHDNBLDHDNBDB@DNJLJ@NHHHFJJJB@JJN@LDLJJNFFN@L@@H@AHHHA@@A@@IHAA@I@@@I@HHH@HI@I@IAIH@@IAIAA@HIHIIH@@HHH@@H@@@H@@H@H@@HH@@@@HH@@@@H@HH@@@H@H@@H@@H@HH@H@@A@@AAA@AAAAAAA@@@AAA@@@@@@@@A@A@@@AA@@AA@A@@A@@AA@@@B@BD@DHDLLLBJ@HNLDLF@H@HDJBLNNNH@@@DHNLNLBLHBBH@NN@@IIIHIH@I@AIHHA@@@I@IH@@A@@HIHAIHIIIIA@IA@AIHHHAHHA@@@H@H@HH@@H@@@HHH@@@@@HH@H@@H@@H@HHH@HH@H@@H@H@@H@@@@@A@AAA@AAAAAAA@AA@A@@@@A@A@@A@@@AA@@A@@@A@@@@@@@AA@@JNLFDNB@BD@FJNDJ@LJHNNLJHBFNHHLFDJLDJN@L@LBJNH@D@N@@A@AA@@@H@AIIHAIAIAAAIIHAAHH@A@AH@@AAHI@@A@@@HHIAAH@@HHHH@HHHH@H@HHH@@@H@HHHH@H@@HH@HH@HHH@@H@H@@HHH@H@@@A@AA@@AA@@A@AA@AAA@@@@AAAAA@@@AAA@@@@AA@@@AA@A@@A@@@LJDFLHBJBNL@L@DF@JJDNNNDFJFDJHN@NFD@DHN@FDJNNBJ@JN@@IAHAHAHAIIHH@AH@HA@HIIIHH@HAH@IHHIAI@IIHI@AA@II@@A@@@H@@@HHHHHHHHHHHH@@@HH@H@H@HH@@HH@HHH@@@@HH@H@@@HH@@@A@A@@@@A@AAAAA@@@@@@AAA@A@@@@@@@A@AAAAAA@@A@@A@@A@@H@HDNNL@DBBLBNJJ@LJH@HHDFFF@BFBHLLDJJ@BBL@DJ@JHDB@@@HAAI@HH@IH@I@IIH@HHHHAIIIIHIH@I@AAH@H@IHAI@@@IIIAI@@HH@@@H@H@@H@H@@@H@@@@H@H@H@@@H@@@H@@H@H@@H@H@@HHHH@@@A@@@@A@@@@@A@@AA@A@@A@@A@AA@@@AAAA@A@@A@@@@@A@@AA@@D@JLBNNHDFFLNJBJBBH@@NBBBH@LLJBBDHJ@HLBDNNBF@FFNNH@@@@@@HIIAHHAI@@HIA@@HHA@@@II@H@I@IAII@HIIHH@AHH@AI@@@HHH@@@@HH@@H@H@@@@@HHHHHH@HH@@HH@@H@@H@HHH@HHH@H@H@@@@A@@@A@@@@@@AAA@@@A@AA@@AAA@@A@@@@A@A@AA@@@@@AAA@@@JFJFD@JJHHJ@H@@@FDLNJ@HJBBFLJ@FBLFFF@NJLFFNNHDJ@DH@@AHH@@HH@AIII@IAI@@HH@A@HI@HII@@AIIAAHA@AI@AHIHHAH@@@H@H@@@H@H@HHH@@HH@@HH@HHHH@@@H@H@H@HH@HH@@HH@@@H@@@@@AA@AAA@A@@A@A@A@A@A@A@A@AA@A@AA@@AA@A@@@@A@@@@AAA@@HFHHHJLLLLB@@N@BDLJJNFLLDF@DJLHNN@H@NNNJ@FH@F@BNND@@HIHA@AAH@@H@AIH@HII@IA@A@@AIAIIHAAHHHH@AAIH@IH@IA@@@HHHHH@@@@HHH@@HHHH@@@@HH@H@@HHHHHHHHHHHHH@H@HHHH@H@@A@A@@@AAA@A@@@@@AA@@@A@A@AA@@@@@A@@AAAA@@@@AAAA@A@@@JHBFJF@FD@DB@@FLL@DNNJ@JHLFLNFNF@FLHBJBLHHDLFJNJBD@@AHH@@HAA@A@@IHAHH@HI@@HAAHIAAAIAHHAAHAAIIHIHIAAI@I@@H@HH@@H@@@H@@HH@@H@@@H@H@@HHH@H@HH@@@H@H@@HHHHH@H@@@AA@A@A@AAAAA@@A@A@A@A@A@AAAA@@@A@A@A@@AA@@AA@A@AA@@@NFJHNJNFHNDNHDH@LJHBFF@JDBBLHDBLJHL@LBB@JBJJ@BHHHF@@@I@@@IA@@@A@A@HIII@HII@HIA@I@H@HHIIHHHIA@H@HAIAHAH@@@@@H@HH@@HHH@HH@@@H@H@@@HHH@@H@@@HH@H@@HH@H@@HHHH@@@@A@A@@@A@@@AA@AAAAA@@@AA@@@A@A@A@A@@AA@@AA@AAA@A@A@@DBFBDLB@JLLHNNJH@BDDDLDLFHFD@NB@NJFBN@HDDL@HHHFLNB@@A@HAAHIIH@AA@AAIA@HAHHAAHH@AI@A@II@IIHA@@I@AH@IHHH@@@H@@H@HHHHH@@@@HH@@HH@@@HHHHH@@@HHH@@@@@@HH@H@H@HH@@@A@@A@A@@@@@A@A@@AAAA@@@A@@@@AA@@@A@AA@@AAAAAA@@@A@@FDBBJHFHDD@B@NNLN@FLJHNLJHFLFFDDNLLJ@DJF@NDLJFJBHH@@I@@IAAAII@I@IA@@@HI@I@AHAHIHHII@@AIIAHA@AAHI@AHIII@@@H@@H@HHH@@H@HH@H@H@@@@@H@HHH@@@H@@HH@@HH@HHHHHHH@@@@A@AAAAAAA@@AA@A@AAA@@@@AA@@A@@A@@@@@AAAA@@@@A@A@A@@F@NLFLJFNB@D@FBB@DLNJJNHN@HBBBF@B@J@HFFLDNJL@LLDNF@@AH@H@AI@HIIAH@H@IHAII@IHAAAAIIAHHHAAA@AIAH@A@HIHA@@@@H@@@@H@@H@@@@H@H@@@H@H@@HH@@@@@@HHH@@H@@@H@@HH@H@@@@A@A@@A@@A@@@@@A@AAAA@AA@A@@@AA@AA@@A@@A@AA@AAAAAA@@FBJ@FFLN@JH@FHFDJHJF@HDHNLNDJLFLHJNBLNN@HJD@FHBFFB@@HAHH@@IHA@@A@AHIHIA@HA@HIIIA@H@@HIIAA@AHA@@II@AHAI@@HH@H@@HHH@@H@@@@H@@HHH@@HHH@H@@@H@@HHH@@H@@@@@HHHH@@@AA@AA@A@@@@A@@@@A@A@A@@@@A@AA@@A@A@@AAA@A@AA@A@@A@@LBJ@@@@H@NDHNFD@FBDNDBFBJJBF@DJFJHHL@FBLNBBJLFNJL@@@IHIIHHHI@@IH@I@@A@IHAIIH@HHHAA@AI@@AAHHAHAAIAH@AII@@@@@H@@@@@@HHH@@@@@@@HH@@H@@@@H@@HHHH@HH@H@HH@HH@H@@@A@A@AAA@@AAAA@@@AA@A@A@@@@@A@AAA@@@AAA@@A@AAA@AAA@@@@NHFJB@LDFNBBJFHDNL@HFBB@NFDFD@@@HNHBNDLLNJHLFF@@J@@@IAHHHAIIAH@H@@AHI@H@IAI@@AIHIHHHI@H@HA@@IHHAAHHA@@@@HH@@@@@@@H@HH@H@HH@H@@@@H@@@@@@@@H@H@@@H@H@@H@H@H@@@@@A@AAA@@@@@A@@@@AAA@@AAA@@@AAAA@@A@AAAA@AA@@A@A@@@BDFBFLLN@@BNNLFBJJ@HFF@@F@DJFJH@F@LDHF@HDL@FFJJHDH@@A@HI@HI@IIIH@AHA@AHI@IIHHAA@AI@A@H@AIA@@I@I@IIAIAI@@HH@@HHHH@@@@@@@@@@@@@H@@HHH@@HH@@HH@H@@@HHHH@H@H@@@@A@A@AAAAAAA@@A@@A@@A@@@A@@AAA@@@AA@A@@@AA@AAA@@@@@@@NB@NBJHHBD@LBHFHHBDDBFDBNND@@@B@FH@NL@FB@FN@DFNDJD@@HA@H@@@I@@IIIAI@A@I@IHIIHHH@HHHIIAA@AHAAI@AAIAIAH@@@H@@H@@HH@H@HH@@HH@HH@@H@@@@@@@H@@H@@@@@HH@@@H@HHH@@@@AA@@@@@AA@@@A@AAA@@@AA@AA@@@A@AAA@@@@@A@AA@@AAAA@@@H@NHHNFNNLFHBJJJ@FN@DFB@DHDNL@HJLBDLFFLLB@FHBBNBJJ@@H@H@AAA@IIH@AI@IIAAIH@IAH@HA@AIIAAAIAAIIHHIAAAAIHA@@@@@@@@H@@HH@@H@H@H@@HH@HHH@H@@HHHHH@@H@@@@@H@H@HH@@@A@A@@AAAA@AAA@AAA@@@@@@@@AA@@AAA@A@@@@@A@A@@@A@AA@@@N@JBLBNNN@@BFLJHJJB@H@LDNH@FFDFJ@J@HHFHNHDFBFFFD@D@@H@AHI@HHIAAIAAHH@IIH@@AAH@HIAHAH@IA@@AAAAIIHHHI@II@@@HHH@@@@@@H@@H@@H@@H@H@@HH@@H@HHHH@H@HHHHH@H@HH@@@@@AAAAAA@@@A@A@@AAA@@AA@@AA@@@@@@@@@A@@@@@@@A@@AAAAA@@JNJNHBFFHNDDN@HJDNDBFLNHDFFNHDLLBDFFN@HNLBBJJHD@BF@@@HH@AAH@AIHAII@AHA@H@@HHHHHHA@@HIHA@IIIII@@HI@H@AH@@@HHH@@@HH@H@@H@@H@HH@@@@HH@H@@@@@@@HHH@@HHH@@@H@HH@@@AAAA@@A@@AAA@A@@AA@@@A@@A@A@A@A@@A@AA@@A@@A@@@AA@@@NJBNLFHDBJF@@DDJJHJLHDDJBND@HDLHNBJNLDJDDJDN@NHLHD@@@AHA@HA@IIIA@AH@IHI@IH@I@@AH@IAII@@AAHIAAH@@HIHHIH@@HH@@H@H@HHH@H@@@H@@HHH@@HHH@H@@HHHH@H@H@@H@HHH@HHH@@AAAA@@@@@@@@AAA@A@@AA@A@A@@A@AA@A@A@A@@@@A@A@@@AAA@@NDBJN@NJNBFJ@@NJJDFD@JJL@JLBB@@FD@LHJJLLBNDBNJFNBJ@@@HH@H@IHA@I@HAAA@AAAH@IIAIHHHH@AII@HAAIAH@IAIIIH@A@@H@H@H@@HHH@HH@HHH@@HH@@@@@H@H@H@@H@H@@H@HH@HH@H@@H@@A@@@@AAAA@@AAA@@AA@AAAA@@A@A@@AA@A@@A@AAA@A@@@@@@A@@BDDLNBJJFL@JHHLNN@NHN@LB@@BBJLNHFDLFFFLFHLD@DJJN@J@@@AHI@IHH@IAI@AIAHIIH@@AA@@@@HI@@HHIA@IHAHHAA@@IAAH@@@@@HH@@@HHH@@H@HHH@HHHH@H@@H@@@@@@@H@@@@@H@@H@@@H@@@A@@@@AA@@AAAAAAAAA@AA@@@@@@@AA@@A@AA@@A@AAAAAA@@A@@@FDHHJBFJ@BJHFLBJLNJBLDLLFHDFFJLNBH@DH@@HLDDJNNNDFB@@HIAAAAIIIII@IAH@A@@@@AAHA@AH@@IHHA@IHHAHAIH@@IHIIH@@@@H@@@HHH@@@@HH@@@@@@H@@HH@HH@@@@@HH@@H@@HH@H@H@@H@@@@@@A@@AAA@@@A@AA@AA@@@@@@AA@@@AAAAAA@AAA@@AAA@@A@@@FNHJBJBLDFBHL@JDFFNB@LHHFF@DBLLHNBF@BBL@DL@BFJJBBJ@@HHA@@@AIA@IAH@IIH@HI@IAA@IIHH@AA@IA@I@IIHAAAAAIH@H@@@H@@H@@@HH@@@@@@@H@H@@@HH@H@HHH@@@@@H@@@HHHH@HHHH@@@@A@@AAAAAA@AAA@@@AA@@A@@AAA@@@@@AAA@AA@AA@AAA@AA@A@@D@JFHHLFLJHH@BFLNHNFDD@@LFBJLFBLLLBBL@JNNLD@JHF@@L@@IIA@@AAHHIAHIAA@HI@@AHAA@@IAH@A@HH@HI@HAIAIA@IIAIH@@) (il:rpaqq il:defaultscreenshade 8840) (il:rpaqq il:grayshade 43605) (il:rpaqq il:grayshade1 1) (il:rpaqq il:grayshade2 1025) (il:rpaqq il:grayshade3 64510) (il:rpaqq il:grayshade4 65534) (il:rpaqq il:plainshade 23130) (il:rpaqq il:wave-texture 26880) (il:rpaqq il:wave2-texture 27010) (il:rpaqq il:mesh-texture 51219) (il:rpaqq il:di-texture 33810) (il:rpaqq il:dark-di-texture 31725) ) (il:putprops il:bitmap-gallery il:copyright ("Gregg Foster" 1987 1988 1989)) (il:declare\: il:dontcopy (il:filemap (nil (2641 3837 (il:rbg 2654 . 3358) (il:fabricize 3360 . 3835))))) il:stop \ No newline at end of file diff --git a/lispusers/BITMAP-GALLERY.TEDIT b/lispusers/BITMAP-GALLERY.TEDIT new file mode 100644 index 00000000..aa14181e Binary files /dev/null and b/lispusers/BITMAP-GALLERY.TEDIT differ diff --git a/lispusers/BITMAPFNS b/lispusers/BITMAPFNS new file mode 100644 index 00000000..2a759b90 --- /dev/null +++ b/lispusers/BITMAPFNS @@ -0,0 +1 @@ +(FILECREATED " 3-Jun-86 14:13:59" {ERIS}LIBRARY>BITMAPFNS.;6 6278 changes to: (MACROS RPCHK) (FNS READPRESS) previous date: " 2-Jun-86 22:35:15" {ERIS}LIBRARY>BITMAPFNS.;5) (* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT BITMAPFNSCOMS) (RPAQQ BITMAPFNSCOMS ((FNS READBINARYBITMAP WRITEBINARYBITMAP WRITEBM WRITEBMLST READBMLST READBM READPRESS WINDOWBM) (DECLARE: DONTCOPY (MACROS RPCHK)))) (DEFINEQ (READBINARYBITMAP [LAMBDA (WIDTH HEIGHT FILE) (* lmm " 4-JAN-83 00:19") (* reads a bitmap from the output file.) (PROG ((BM (BITMAPCREATE WIDTH HEIGHT))) (\BINS (GETSTREAM FILE (QUOTE INPUT)) (fetch BITMAPBASE of BM) 0 (ITIMES (fetch BITMAPRASTERWIDTH of BM) (fetch BITMAPHEIGHT of BM) 2)) (RETURN BM]) (WRITEBINARYBITMAP [LAMBDA (BITMAP FILE) (* JWogulis "26-Dec-84 15:06") (\BOUTS FILE [ffetch BITMAPBASE of (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP] 0 (ITIMES (ffetch BITMAPHEIGHT of BITMAP) (ffetch BITMAPRASTERWIDTH of BITMAP) BYTESPERWORD]) (WRITEBM [LAMBDA (FILE BITMAP) (* lmm " 6-Jun-85 16:46") [BOUT16 FILE (ffetch BITMAPWIDTH of (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP] (BOUT16 FILE (ffetch BITMAPHEIGHT of BITMAP)) (WRITEBINARYBITMAP BITMAP FILE]) (WRITEBMLST [LAMBDA (FILE LST) (* JWogulis "26-Dec-84 15:06") (PROG [(F (OPENSTREAM FILE (QUOTE OUTPUT) (QUOTE NEW] (for I in LST do (WRITEBM F I)) (CLOSEF F]) (READBMLST [LAMBDA (FILE) (* JWogulis "26-Dec-84 15:08") (bind (F _(OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD))) until (EOFP F) collect (READBM F) finally (CLOSEF F]) (READBM [LAMBDA (FILE) (* lmm " 6-Jun-85 16:46") (READBINARYBITMAP (BIN16 FILE) (BIN16 FILE) FILE]) (READPRESS [LAMBDA (FILENAME) (* lmm " 2-Jun-86 22:34") (RESETLST (PROG (WW HT MICAWIDTH MICAHEIGHT BITMAP TOTCOUNT (OFD (GETSTREAM (OPENFILE FILENAME (QUOTE INPUT) (QUOTE OLD)) (QUOTE INPUT))) X WIDTH) (RESETSAVE NIL (LIST (QUOTE CLOSEF) OFD)) (RPCHK 256) (* Edotcode) (SETQ WW (IQUOTIENT (BIN16 OFD) 16)) (* Width) (SETQ HT (BIN16 OFD)) (* Height) (until (SELECTC (SETQ X (BIN16 OFD)) ((IPLUS 512 3) (* Edotmode and 3) (RPCHK 2) (* Edotsize) (SETQ MICAWIDTH (BIN16 OFD)) (SETQ MICAHEIGHT (BIN16 OFD)) NIL) (1 (* Edotwindow) (BIN16 OFD) (SETQ WIDTH (BIN16 OFD)) (RPCHK 0) (RPCHK HT) NIL) (3 T) (GO ERROR))) [\BINS OFD (fetch BITMAPBASE of (SETQ BITMAP (BITMAPCREATE (ITIMES WW 16) HT))) 0 (ITIMES 2 (SETQ TOTCOUNT (ITIMES HT WW] (RPCHK 0) (* Entity list terminator) [COND (NIL (* more checks, not necessary) (PROGN (RPCHK (IPLUS 65280 238)) (* Nop, setx) (RPCHK 0) (RPCHK (IPLUS 65280 239)) (* Nop, sety) (RPCHK 0) (RPCHK (IPLUS 65280 252)) (* Nop, show dots) (RPCHK 0] (RETURN BITMAP) ERROR (ERROR "Sorry, unrecognized PRESS file format. READPRESS isn't very general."]) (WINDOWBM [LAMBDA (BITMAP POSITION) (* JWogulis "26-Dec-84 15:37") (IF (AND POSITION (NOT (POSITIONP POSITION))) THEN (ERROR "NOT A POSITION" POSITION)) [IF (NOT POSITION) THEN (SETQ POSITION (GETBOXPOSITION (IPLUS 8 (BITMAPWIDTH BITMAP)) (IPLUS 8 (BITMAPHEIGHT BITMAP] (PROG ((WIND (CREATEW (LIST (CAR POSITION) (CDR POSITION) (IPLUS 8 (BITMAPWIDTH BITMAP)) (IPLUS 8 (BITMAPHEIGHT BITMAP))) NIL 4))) (BITBLT BITMAP 0 0 WIND) (RETURN WIND]) ) (DECLARE: DONTCOPY (DECLARE: EVAL@COMPILE [PUTPROPS RPCHK MACRO ((N) (OR (EQ (BIN16 OFD) N) (GO ERROR] ) ) (PUTPROPS BITMAPFNS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (564 5993 (READBINARYBITMAP 574 . 1075) (WRITEBINARYBITMAP 1077 . 1437) (WRITEBM 1439 . 1752) (WRITEBMLST 1754 . 2028) (READBMLST 2030 . 2305) (READBM 2307 . 2492) (READPRESS 2494 . 5342) ( WINDOWBM 5344 . 5991))))) STOP \ No newline at end of file diff --git a/lispusers/BITMAPFNS.TEDIT b/lispusers/BITMAPFNS.TEDIT new file mode 100644 index 00000000..386d1dc6 Binary files /dev/null and b/lispusers/BITMAPFNS.TEDIT differ diff --git a/lispusers/BLACKBOX b/lispusers/BLACKBOX new file mode 100644 index 00000000..437cc7ae --- /dev/null +++ b/lispusers/BLACKBOX @@ -0,0 +1 @@ +(FILECREATED "10-Jan-86 08:27:39" {PHYLUM}LISP>BLACKBOX.;7 17547 changes to: (FNS InitializeGuessArray BlackBoxChoices InitializeBallArray NewGame AskQuestion BlackBoxWindowFn OnEdge ProbeBallArray FillBox DrawBlackBox RedisplayBox) (VARS BLACKBOXCOMS HintTime) previous date: " 3-Jan-86 19:12:57" {PHYLUM}LISP>BLACKBOX.;5) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT BLACKBOXCOMS) (RPAQQ BLACKBOXCOMS ((VARS BlackBoxSquare HintTime) (FNS AskQuestion BlackBox BlackBoxChoices BlackBoxTitle FillBox InitializeBallArray InitializeGuessArray LeftAhead LeftTurn MakeBlackBoxWindow MoveAhead MoveBall DrawBlackBox BallAhead BallDownOrUp BBBoxNumber BlackBoxWindowFn MakeBallArray NewGame OnEdge ProbeBallArray RedisplayBox RightAhead RightTurn SetSquareArray ShowBalls SquareArray))) (RPAQQ BlackBoxSquare 40) (RPAQQ HintTime 5000) (DEFINEQ (AskQuestion [LAMBDA (window xBox yBox) (* edited: "10-Jan-86 07:15") (LET* ((boxSize (WINDOWPROP window (QUOTE BoxSize))) (guessArray (WINDOWPROP window (QUOTE GuessArray))) (answer (ProbeBallArray (WINDOWPROP window (QUOTE BallArray)) xBox yBox boxSize))) (AND answer (SetSquareArray guessArray xBox boxSize yBox (if (LISTP answer) then (* use a number) (LET [(g (WINDOWPROP window (QUOTE LastGuessNumber) (PLUS (WINDOWPROP window (QUOTE LastGuessNumber)) 1] (SetSquareArray guessArray (CAR answer) (CDR answer) boxSize g) g) else answer))) answer]) (BlackBox [LAMBDA (numRows numBalls) (* edited: " 3-Jan-86 16:19") (* * This is a game in which one guesses where balls are hidden) (if (NOT (NUMBERP numRows)) then (SETQ numRows 8)) (if (NOT (NUMBERP numBalls)) then (SETQ numBalls 4)) (if (GREATERP numRows 16) then (PRINTOUT T "Too big. Using " numRows " rows.") (SETQ numRows 16)) (if (GREATERP numBalls numRows) then (PRINTOUT T "You chose too many balls. I will use " numRows T) (SETQ numBalls numRows)) (LET* ((boxSize (PLUS 2 numRows)) (boxWidth (TIMES BlackBoxSquare boxSize)) (boxWindow (MakeBlackBoxWindow boxSize boxWidth numBalls))) (MOVEW boxWindow 0 0]) (BlackBoxChoices [LAMBDA (window) (* edited: "10-Jan-86 08:25") (LET [(ballArray (WINDOWPROP window (QUOTE BallArray))) (guessArray (WINDOWPROP window (QUOTE GuessArray] (SELECTQ [MENU (create MENU ITEMS _(QUOTE (ShowCorrect ShowAll NewGame ("New Game Using Balls Shown" (QUOTE NewGameFrom) "Use the balls shown to initialize game") ChangeNumberOfBalls ChangeNumberOfRows] (ShowAll (ShowBalls window ballArray guessArray T) (DISMISS HintTime) (REDISPLAYW window)) (ShowCorrect (ShowBalls window ballArray guessArray NIL) (DISMISS HintTime) (REDISPLAYW window)) (NewGame (NewGame window)) (NewGameFrom (NewGame window NIL (BallsDisplayed window))) (ChangeNumberOfBalls (LET ((numRows (DIFFERENCE (WINDOWPROP window (QUOTE BoxSize)) 2)) (numBalls (RNUMBER "How many hidden balls"))) (WINDOWPROP window (QUOTE NumBalls) (COND ((GREATERP 1 numBalls) (PRINTOUT T .FONT (HELVETICA 18) "You need to hide some balls." T) (WINDOWPROP window (QUOTE NumBalls))) ((GREATERP numBalls numRows) (PRINTOUT T .FONT (HELVETICA 18) "You are asking for too many balls. Using " numRows T) numRows) (T numBalls))) (WINDOWPROP window (QUOTE TITLE) (CONCAT "Black Box with " numBalls " balls"))) (NewGame window)) [ChangeNumberOfRows (LET ((numRows (RNUMBER "How many rows?"))) (CLOSEF window) (BlackBox numRows (WINDOWPROP window (QUOTE NumBalls] NIL]) (BlackBoxTitle [LAMBDA (numBalls) (* edited: "30-Dec-85 17:51") (CONCAT "Black Box with " numBalls " balls -- Click Here For Help"]) (FillBox [LAMBDA (window x y symbol) (* edited: "10-Jan-86 07:59") (LET ((xPos (TIMES x BlackBoxSquare)) (yPos (TIMES y BlackBoxSquare))) (SELECTQ symbol (Black (DSPFILL (CREATEREGION xPos yPos BlackBoxSquare BlackBoxSquare) BLACKSHADE NIL window)) (Ball (FILLCIRCLE (PLUS xPos (TIMES .5 BlackBoxSquare)) (PLUS yPos (TIMES .5 BlackBoxSquare)) (TIMES .45 BlackBoxSquare) BLACKSHADE window)) (NIL (DSPFILL (CREATEREGION (PLUS xPos 2) (PLUS yPos 2) (DIFFERENCE BlackBoxSquare 2) (DIFFERENCE BlackBoxSquare 2)) WHITESHADE (QUOTE REPLACE) window)) (PROGN (MOVETO (PLUS xPos (TIMES .25 BlackBoxSquare)) (PLUS yPos (TIMES .25 BlackBoxSquare)) window) (PRIN1 symbol window]) (InitializeBallArray [LAMBDA (array numBalls boxSize ballPositions) (* edited: "10-Jan-86 08:27") (for I from 0 to (SUB1 (ARRAYSIZE array)) do (SETA array I NIL)) (for position in ballPositions do (SetSquareArray array (CAR position) (CDR position) boxSize (QUOTE Ball))) (for i from (LENGTH ballPositions) to (SUB1 numBalls) do (PROG (randX randY) doAgain (SETQ randX (RAND 1 (DIFFERENCE boxSize 2))) (SETQ randY (RAND 1 (DIFFERENCE boxSize 2))) (if (SquareArray array randX randY boxSize) then (GO doAgain) else (SetSquareArray array randX randY boxSize (QUOTE Ball]) (InitializeGuessArray [LAMBDA (guessArray boxSize) (* edited: "10-Jan-86 08:06") (LET ((maxIndex (SUB1 boxSize))) (for i from 0 to maxIndex do (for j from 0 to maxIndex do (SetSquareArray guessArray i j boxSize (if [OR (AND (EQ i 0) (OR (EQ j 0) (EQ j maxIndex))) (AND (EQ i maxIndex) (OR (EQ j 0) (EQ j maxIndex] then (QUOTE Black]) (LeftAhead [LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 18:17") (EQ (QUOTE Ball) (SquareArray array (SELECTQ direction ((L U) (SUB1 x)) ((D R) (ADD1 x)) x) (SELECTQ direction ((L D) (SUB1 y)) ((R U) (ADD1 y)) y) boxSize]) (LeftTurn [LAMBDA (direction) (* edited: "29-Dec-85 18:08") (SELECTQ direction (U (QUOTE L)) (R (QUOTE U)) (D (QUOTE R)) (L (QUOTE D)) (ERROR "Bad Direction" direction]) (MakeBlackBoxWindow [LAMBDA (boxSize boxWidth numBalls) (* edited: " 3-Jan-86 18:51") (* * Draw the window, and install a buttonFunction that will make the right moves for the game) (LET ((window (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW boxWidth 4) (HEIGHTIFWINDOW boxWidth T 4)) (BlackBoxTitle numBalls) 4))) (DSPFONT (FONTCREATE (QUOTE (HELVETICA 18 BOLD))) window) (WINDOWPROP window (QUOTE BoxWidth) boxWidth) (WINDOWPROP window (QUOTE BoxSize) boxSize) (WINDOWPROP window (QUOTE NumBalls) numBalls) (WINDOWPROP window (QUOTE REPAINTFN) (QUOTE DrawBlackBox)) (WINDOWPROP window (QUOTE BUTTONEVENTFN) (QUOTE BlackBoxWindowFn)) (NewGame window boxSize) window]) (MoveAhead [LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 18:03") (MoveBall array (SELECTQ direction (L (SUB1 x)) (R (ADD1 x)) x) (SELECTQ direction (D (SUB1 y)) (U (ADD1 y)) y) boxSize direction]) (MoveBall [LAMBDA (array xPos yPos boxSize direction) (* edited: "29-Dec-85 18:22") (LET ((edge (OnEdge xPos yPos boxSize))) (if edge then (* Coming Out) (CONS xPos yPos) elseif (BallAhead array xPos yPos boxSize direction) then (QUOTE H) elseif (LeftAhead array xPos yPos boxSize direction) then (if (RightAhead array xPos yPos boxSize direction) then (QUOTE R) else (MoveAhead array xPos yPos boxSize (RightTurn direction))) elseif (RightAhead array xPos yPos boxSize direction) then (MoveAhead array xPos yPos boxSize (LeftTurn direction)) else (MoveAhead array xPos yPos boxSize direction]) (DrawBlackBox [LAMBDA (window) (* edited: "10-Jan-86 07:40") (LET* [(boxSize (WINDOWPROP window (QUOTE BoxSize))) (boxWidth (WINDOWPROP window (QUOTE BoxWidth))) (lastLinePos (DIFFERENCE boxWidth BlackBoxSquare)) (guessArray (WINDOWPROP window (QUOTE GuessArray] (for bottom from BlackBoxSquare by BlackBoxSquare to boxWidth do (DRAWLINE 0 bottom boxWidth bottom (if (OR (EQ bottom BlackBoxSquare) (EQ bottom lastLinePos)) then 4 else 2) NIL window) (DRAWLINE bottom 0 bottom boxWidth (if (OR (EQ bottom BlackBoxSquare) (EQ bottom lastLinePos)) then 4 else 2) NIL window)) (for xPos from 0 to (SUB1 boxSize) do (for yPos from 0 to (SUB1 boxSize) do (FillBox window xPos yPos (SquareArray guessArray xPos yPos boxSize]) (BallAhead [LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 17:29") (EQ (QUOTE Ball) (SquareArray array (SELECTQ direction (L (SUB1 x)) (R (ADD1 x)) x) (SELECTQ direction (D (SUB1 y)) (U (ADD1 y)) y) boxSize]) (BallDownOrUp [LAMBDA (window xBox yBox) (* edited: "29-Dec-85 14:33") (LET* [(array (WINDOWPROP window (QUOTE GuessArray))) (boxSize (WINDOWPROP window (QUOTE BoxSize] (SetSquareArray array xBox yBox boxSize (if (SquareArray array xBox yBox boxSize) then NIL else (QUOTE Ball]) (BBBoxNumber [LAMBDA (window place) (* dgb: "25-Dec-85 16:54") (IQUOTIENT place BlackBoxSquare]) (BlackBoxWindowFn [LAMBDA (window) (* edited: "10-Jan-86 07:49") (LET [(buttons (DECODEBUTTONS)) (xBox (BBBoxNumber window (LASTMOUSEX window))) (yBox (BBBoxNumber window (LASTMOUSEY window))) (lastRow (SUB1 (WINDOWPROP window (QUOTE BoxSize] (if (EQ yBox (WINDOWPROP window (QUOTE BoxSize))) then (AND buttons (BlackBoxChoices window)) elseif buttons elseif (OR (EQ xBox 0) (EQ yBox 0) (EQ xBox lastRow) (EQ yBox lastRow)) then [LET ((answer (AskQuestion window xBox yBox))) (RedisplayBox window xBox yBox) (AND (LISTP answer) (RedisplayBox window (CAR answer) (CDR answer] else (BallDownOrUp window xBox yBox) (RedisplayBox window xBox yBox]) (MakeBallArray [LAMBDA (numBalls) (* edited: "29-Dec-85 14:15") (ARRAY (TIMES numBalls numBalls) NIL NIL 0]) (NewGame [LAMBDA (window boxSize ballPositions) (* edited: "10-Jan-86 08:27") [OR boxSize (SETQ boxSize (WINDOWPROP window (QUOTE BoxSize] (LET [(ballArray (OR (WINDOWPROP window (QUOTE BallArray)) (LET ((V (MakeBallArray boxSize))) (WINDOWPROP window (QUOTE BallArray) V) V))) (guessArray (OR (WINDOWPROP window (QUOTE GuessArray)) (LET ((V (MakeBallArray boxSize))) (WINDOWPROP window (QUOTE GuessArray) V) V] (InitializeGuessArray guessArray boxSize ballPositions) (InitializeBallArray ballArray (WINDOWPROP window (QUOTE NumBalls)) boxSize ballPositions) (WINDOWPROP window (QUOTE LastGuessNumber) 1) (REDISPLAYW window]) (OnEdge [LAMBDA (x y boxSize) (* edited: "10-Jan-86 06:01") (if (EQ y 0) then (QUOTE U) elseif (EQ x 0) then (QUOTE R) elseif (EQ y (SUB1 boxSize)) then (QUOTE D) elseif (EQ x (SUB1 boxSize)) then (QUOTE L) else NIL]) (ProbeBallArray [LAMBDA (array xPos yPos boxSize) (* edited: "10-Jan-86 07:06") (* * Returns NIL if at corner, H, R, or for a detour a dotted pair of final postion for x and y) (LET* [(lastIndex (SUB1 boxSize)) [atCorner (OR (AND (EQ xBox 0) (OR (EQ yBox 0) (EQ yBox lastIndex))) (AND (EQ xBox lastIndex) (OR (EQ yBox 0) (EQ yBox lastIndex] (direction (AND (NOT atCorner) (OnEdge xPos yPos boxSize] (AND direction (if (BallAhead array xPos yPos boxSize direction) then (QUOTE H) elseif (OR (LeftAhead array xPos yPos boxSize direction) (RightAhead array xPos yPos boxSize direction)) then (QUOTE R) else (MoveAhead array xPos yPos boxSize direction]) (RedisplayBox [LAMBDA (window xBox yBox) (* edited: "10-Jan-86 07:48") (FillBox window xBox yBox (SquareArray (WINDOWPROP window (QUOTE GuessArray)) xBox yBox (WINDOWPROP window (QUOTE BoxSize]) (RightAhead [LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 17:35") (EQ (QUOTE Ball) (SquareArray array (SELECTQ direction ((D L) (SUB1 x)) ((U R) (ADD1 x)) x) (SELECTQ direction ((R D) (SUB1 y)) ((L U) (ADD1 y)) y) boxSize]) (RightTurn [LAMBDA (direction) (* edited: "29-Dec-85 18:07") (SELECTQ direction (U (QUOTE R)) (R (QUOTE D)) (D (QUOTE L)) (L (QUOTE U)) (ERROR "Bad Direction" direction]) (SetSquareArray [LAMBDA (array x y rowSize newValue) (* edited: "29-Dec-85 13:27") (SETA array (PLUS x (TIMES rowSize y)) newValue]) (ShowBalls [LAMBDA (window ballArray gameArray showAll) (* edited: "29-Dec-85 17:00") (LET [(boxSize (WINDOWPROP window (QUOTE BoxSize] (for xPos from 0 to (SUB1 boxSize) do (for yPos from 0 to (SUB1 boxSize) do (if (AND (EQ (QUOTE Ball) (SquareArray ballArray xPos yPos boxSize)) (OR showAll (SquareArray gameArray xPos yPos boxSize))) then (DSPFILL (CREATEREGION (PLUS (TIMES xPos BlackBoxSquare) 2) (PLUS (TIMES yPos BlackBoxSquare) 2) (DIFFERENCE BlackBoxSquare 2) (DIFFERENCE BlackBoxSquare 2)) BLACKSHADE (QUOTE INVERT) window]) (SquareArray [LAMBDA (array x y rowSize) (* edited: "29-Dec-85 13:26") (ELT array (PLUS x (TIMES rowSize y]) ) (PUTPROPS BLACKBOX COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (966 17463 (AskQuestion 976 . 1847) (BlackBox 1849 . 2672) (BlackBoxChoices 2674 . 4665) (BlackBoxTitle 4667 . 4858) (FillBox 4860 . 5816) (InitializeBallArray 5818 . 6634) ( InitializeGuessArray 6636 . 7212) (LeftAhead 7214 . 7615) (LeftTurn 7617 . 7903) (MakeBlackBoxWindow 7905 . 8852) (MoveAhead 8854 . 9164) (MoveBall 9166 . 10000) (DrawBlackBox 10002 . 11120) (BallAhead 11122 . 11469) (BallDownOrUp 11471 . 11868) (BBBoxNumber 11870 . 12020) (BlackBoxWindowFn 12022 . 12947) (MakeBallArray 12949 . 13125) (NewGame 13127 . 14008) (OnEdge 14010 . 14382) (ProbeBallArray 14384 . 15301) (RedisplayBox 15303 . 15579) (RightAhead 15581 . 15983) (RightTurn 15985 . 16272) ( SetSquareArray 16274 . 16459) (ShowBalls 16461 . 17294) (SquareArray 17296 . 17461))))) STOP \ No newline at end of file diff --git a/lispusers/BLACKBOX.TEDIT b/lispusers/BLACKBOX.TEDIT new file mode 100644 index 00000000..77c8d2c7 Binary files /dev/null and b/lispusers/BLACKBOX.TEDIT differ diff --git a/lispusers/BLOCKS-HKB b/lispusers/BLOCKS-HKB new file mode 100644 index 00000000..310ad05b --- /dev/null +++ b/lispusers/BLOCKS-HKB @@ -0,0 +1 @@ +(FILECREATED " 6-Feb-87 10:18:07" {DSK}H.ALFA>BLOCKS.HKB;2 4571 changes to: (VARS *functions1* *predicates1* *variables1* *temp-foo* *temp-pred*) previous date: " 3-Nov-86 11:06:40" {DSK}H>BLOCKS.HKB;9) (PRETTYCOMPRINT BLOCKSCOMS) (RPAQQ BLOCKSCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)) (RPAQQ *functions1* (HRPRINT LISTMEMB MEMBER fail true noteq)) (RPAQQ *predicates1* (color-of showworld SPLIT putdown pickup please ART PREP GoOnNp PARTIC OPTPARTIC VP VERB NP1 NP NOM BLOCK on clear puton)) (RPAQQ *variables1* (:d :c :color :bl :a4 :a3 :a2 :a1 :e :q :s :m :string :e4 :e3 :e2 :e1 :rest1 :block2 :q4 :q3 :q2 :q1 :block1 :rest :block :oper :vf :b :a :w2 :w1 :x1 :y1 :u :r :v :z :i :h :j :l :w :y :x :k :p)) (RPAQQ *temp-foo* [[LAMBDA (y) (PRINTOUT T y T] [LAMBDA (x y) (PROG ((temp x)) loop (COND ((NULL temp) (RETURN T)) (T (COND ([OR (MEMBER (CAR temp) y) (EQ (CAR temp (QUOTE one] (SETQ temp (CDR temp)) (GO loop)) (T (RETURN NIL] [LAMBDA (x y) (MEMBER x y] [LAMBDA NIL NIL] [LAMBDA NIL T] (LAMBDA (x y) (NOT (EQ x y]) (RPAQQ *temp-pred* [(((color-of :block :color) < (BLOCK :block :color :a :b :c :d))) (((showworld) < (on :x :y) (HRPRINT (on :x :y)) (fail))) (((SPLIT (:a . :b) :a :b))) (((putdown :x) < (puton :x table))) (((pickup :x) < (puton :x hand))) (((please :string) < (VP :string))) (((ART the)) ((ART a)) ((ART an))) (((PREP on on))) (((GoOnNp (:x . :y) :v :rest) < (PREP :x :x1) (NP :y :v :rest))) (((PARTIC down)) ((PARTIC up)) ((PARTIC to))) (((OPTPARTIC NIL :x)) ((OPTPARTIC (:x . :y) :z) < (PARTIC :x))) (((VP (:x :y . :z)) < (VERB :x :vf :oper) (PARTIC :y) (MEMBER :y :vf) (NP :z :block NIL) (:oper :block)) ((VP (:x . :y)) < (VERB :x :vf :oper) (MEMBER one :vf) (NP :y :block :rest) (OPTPARTIC :rest :vf) (:oper :block)) ((VP (:x . :y)) < (VERB :x :vf :oper) (MEMBER two :vf) (NP :y :block1 :rest) (BLOCK :block1 :q1 :q2 :q3 :q4 stackable) (GoOnNp :rest :block2 :rest1) (BLOCK :block2 :e1 :e2 :e3 supportive :e4) (:oper :block1 :block2))) (((VERB pickup (one) pickup)) ((VERB pick (up one) pickup)) ((VERB put (two) puton)) ((VERB stack (two) puton)) ((VERB put (down one) putdown))) (((NP1 (:x :y . :z) :w :u :r) < (PREP :y :y1) (NOM :x :x1) (NP :z :v :r) (:y1 :w :v) (BLOCK . :w1) (LISTMEMB (:x1 . :u) :w1) (SPLIT :w1 :w :w2)) ((NP1 (:x . :y) :v :u :r) < (NOM :x :x1) (NP1 :y :v (:x1 . :u) :r)) ((NP1 (:x . :y) :w :u :y) < (NOM :x :x1) (BLOCK . :w1) (LISTMEMB (:x1 . :u) :w1) (SPLIT :w1 :w :w2))) (((NP (:x . :y) :v :r) < (ART :x) (NP1 :y :v NIL :r)) ((NP :x :v :r) < (NP1 :x :v NIL :r))) (((NOM red red)) ((NOM block cube)) ((NOM cube cube)) ((NOM cube1 cube1)) ((NOM cube2 cube2)) ((NOM cube3 cube3)) ((NOM big large)) ((NOM small small)) ((NOM blue blue)) ((NOM white white)) ((NOM green green)) ((NOM pyramid1 pyramid)) ((NOM pyramid pyramid)) ((NOM sphere sphere))) (((BLOCK pyramid1 white pyramid 3 NIL stackable)) ((BLOCK cube2 blue cube 5 supportive stackable)) ((BLOCK cube3 green cube 1 supportive stackable)) ((BLOCK cube1 red cube 10 supportive stackable)) ((BLOCK sphere black sphere 3 NIL stackable)) ((BLOCK table NIL NIL NIL supportive NIL)) ((BLOCK hand NIL NIL NIL supportive NIL))) (((on cube3 hand)) ((on sphere table)) ((on cube1 table)) ((on cube2 table)) ((on pyramid1 table))) (((clear table)) ((clear :x) < (on :y :x) (puton :y table)) ((clear :x))) (((puton :x :y) < (noteq :x table) (clear :x) (noteq :y pyramid) (noteq :y sphere) (clear :y) (on :x :w) (delete (on :x :w)) (assert (on :x :y]) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/BMENCODE b/lispusers/BMENCODE new file mode 100644 index 00000000..f985a6a2 --- /dev/null +++ b/lispusers/BMENCODE @@ -0,0 +1 @@ +(FILECREATED "14-Jan-87 17:50:00" {MCS:MCS:STANFORD}BMENCODE.;13 previous date: "19-Dec-86 14:46:44" {MCS:MCS:STANFORD}BMENCODE.;11) (* Copyright (c) 1986, 1987 by Stanford University. All rights reserved.) (PRETTYCOMPRINT BMENCODECOMS) (RPAQQ BMENCODECOMS ((* User function) (FNS BITMAP.ENCODE) (* Internal functions) (FNS FILE.TO.BITMAP BITMAP.TO.FILE) (ADDVARS (BMC.MAKEFILE.OPTIONS NEW)) (INITVARS (BMC.EXTENSION 'BMC) (BMC.BYTESPERLINE 64)) (GLOBALVARS BMC.MAKEFILE.OPTIONS BMC.EXTENSION BMC.BYTESPERLINE))) (* User function) (DEFINEQ (BITMAP.ENCODE [LAMBDA (FILES) (* cdl "19-Dec-86 14:43") (LET [FILENAME (FILENAMES (bind NAME for FILE inside FILES collect (PROG1 (SETQ NAME (NAMEFIELD FILE T)) (SETATOMVAL NAME (FILE.TO.BITMAP FILE] (DECLARE (SPECVARS FILENAME)) [SETATOMVAL [FILECOMS (NAMEFIELD (SETQ FILENAME (PACKFILENAME 'EXTENSION BMC.EXTENSION 'BODY (CAR FILENAMES] (BQUOTE ((BITMAPS ,@ FILENAMES) (P (for FILE in (QUOTE , FILENAMES) do (PRIN1 "Restoring file ") (PRIN1 (BITMAP.TO.FILE (EVALV FILE) FILE)) (TERPRI] (RESETVAR FONTCHANGEFLG NIL (MAKEFILE FILENAME BMC.MAKEFILE.OPTIONS]) ) (* Internal functions) (DEFINEQ (FILE.TO.BITMAP [LAMBDA (FILE) (* cdl "19-Dec-86 13:37") (DECLARE (SPECVARS FILE)) (LET (STREAM) (DECLARE (SPECVARS STREAM)) (RESETLST [RESETSAVE NIL (BQUOTE (CLOSEF? , (SETQ STREAM (OPENSTREAM FILE 'INPUT] (LET (BITMAP (LENGTH (GETFILEINFO STREAM 'LENGTH)) (BYTESPERLINE (QUOTIENT BMC.BYTESPERLINE 2))) (with BITMAP (SETQ BITMAP (BITMAPCREATE (TIMES BYTESPERLINE BITSPERBYTE) (QUOTIENT (PLUS (TIMES 2 BYTESPERWORD) BYTESPERLINE LENGTH) BYTESPERLINE))) (\PUTBASE BITMAPBASE 0 LENGTH) (\PUTBASE BITMAPBASE 1 (RSH LENGTH BITSPERWORD)) (\BINS STREAM BITMAPBASE (TIMES 2 BYTESPERWORD) LENGTH)) BITMAP]) (BITMAP.TO.FILE [LAMBDA (BITMAP FILE) (* cdl "19-Dec-86 13:40") (DECLARE (SPECVARS BITMAP FILE)) (LET (STREAM) (DECLARE (SPECVARS STREAM)) (RESETLST [RESETSAVE NIL (BQUOTE (CLOSEF? , (SETQ STREAM (OPENSTREAM FILE 'OUTPUT] [with BITMAP (\DTEST BITMAP 'BITMAP) (\BOUTS STREAM BITMAPBASE (TIMES 2 BYTESPERWORD) (PLUS (\GETBASE BITMAPBASE 0) (LSH (\GETBASE BITMAPBASE 1) BITSPERWORD] (FULLNAME STREAM]) ) (ADDTOVAR BMC.MAKEFILE.OPTIONS NEW) (RPAQ? BMC.EXTENSION 'BMC) (RPAQ? BMC.BYTESPERLINE 64) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BMC.MAKEFILE.OPTIONS BMC.EXTENSION BMC.BYTESPERLINE) ) (PUTPROPS BMENCODE COPYRIGHT ("Stanford University" 1986 1987)) STOP \ No newline at end of file diff --git a/lispusers/BOYERMOORE b/lispusers/BOYERMOORE new file mode 100644 index 00000000..c6eb98ae --- /dev/null +++ b/lispusers/BOYERMOORE @@ -0,0 +1 @@ +(FILECREATED "30-Sep-86 14:09:43" {ERIS}LISPCORE>BOYERMOORE.;1 842932 changes to: (VARS BASISCOMS CODE-S-ZCOMS) (FNS BM-UPCASE BM-PRIN1 BM-NTH BM-COUNT CREATE-EVENT BM-NEGATE BM-PPR BM-REDUCE BM-SUBST MAKE-LIB) (FUNCTIONS BM-MATCH) previous date: " 6-Jul-86 10:30:08" {ERIS}KOTO>BOYERMOORE.;5) (* " Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BOYERMOORECOMS) (RPAQQ BOYERMOORECOMS ((* * The Boyer Moore Theorem Prover -- By Boyer and Moore -- Translated from Zetalisp to Interlisp-D by Kelly Roach. *) (COMS (* My personal hacks to BOYERMOORE. *) (INITVARS (DEBUGFLG T)) (FNS UNDEFN UNPROVE-LEMMA)) (COMS * BASISCOMS) (COMS * CODE-1-ACOMS) (COMS * CODE-B-DCOMS) (COMS * CODE-E-MCOMS) (COMS * CODE-N-RCOMS) (COMS * CODE-S-ZCOMS) (COMS * EVENTSCOMS) (COMS * GENFACTCOMS) (COMS * IOCOMS) (COMS * PPRCOMS) (FILES COMPILEBANG) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA TOGGLE REFLECT PROVE-LEMMA ENABLE DISABLE DEFN DCL ADD-SHELL ADD-AXIOM) (NLAML) (LAMA))))) (* * The Boyer Moore Theorem Prover -- By Boyer and Moore -- Translated from Zetalisp to Interlisp-D by Kelly Roach. *) (* My personal hacks to BOYERMOORE. *) (RPAQ? DEBUGFLG T) (DEFINEQ (UNDEFN [LAMBDA (NAME) (* kbr: " 6-Jul-86 09:46") (* A personal hack. Take back a  BOYERMOORE defined function.  *) (PROG (*1*NAME) (SETQ PROVED-THMS (for THM in PROVED-THMS when (NOT (AND (EQ (CAR THM) (QUOTE DEFN)) (EQ (CADR THM) NAME))) collect THM)) (SETQ *1*NAME (PACK* "*1*" NAME)) (SETQ LIB-ATOMS-WITH-PROPS (DREMOVE NAME LIB-ATOMS-WITH-PROPS)) (SETQ LIB-ATOMS-WITH-PROPS (DREMOVE *1*NAME LIB-ATOMS-WITH-PROPS)) (SETQ LIB-ATOMS-WITH-DEFS (DREMOVE NAME LIB-ATOMS-WITH-DEFS)) (SETQ CHRONOLOGY (DREMOVE NAME CHRONOLOGY)) (for PROP in LIB-PROPS do (REMPROP NAME PROP)) (for PROP in LIB-PROPS do (REMPROP *1*NAME PROP)) (REMPROP *1*NAME (QUOTE EXPR)) (PUTD *1*NAME NIL]) (UNPROVE-LEMMA [LAMBDA (NAME) (* kbr: " 6-Jul-86 09:47") (* A personal hack. Take back a  BOYERMOORE lemma *) (PROG (TERM) (SETQ TERM (CADDDR (GETPROP NAME (QUOTE EVENT)))) (for X in (UNPRETTYIFY TERM) do (SETQ CONCL (CDR X)) (COND ((GETPROP (TOP-FNNAME CONCL) (QUOTE LEMMAS)) (PUTPROP (TOP-FNNAME CONCL) (QUOTE LEMMAS) (for RULE in (GETPROP (TOP-FNNAME CONCL) (QUOTE LEMMAS)) when (NOT (EQ (fetch (REWRITE-RULE NAME) of OLD-RULE) NAME)) collect RULE))))) (SETQ PROVED-THMS (for THM in PROVED-THMS when (NOT (EQ TERM THM)) collect THM)) (SETQ LIB-ATOMS-WITH-PROPS (DREMOVE NAME LIB-ATOMS-WITH-PROPS)) (SETQ CHRONOLOGY (DREMOVE NAME CHRONOLOGY)) (SETQ PROCESS-HIST (DREMOVE NAME PROCESS-HIST)) (for PROP in LIB-PROPS do (REMPROP NAME PROP]) ) (RPAQQ BASISCOMS ((* BASIS *) (FUNCTIONS GET1 *1*IF ADD-SUB-FACT-BODY ACCESS ARGN BINDINGS CHANGE DISABLEDP FARGN FARGS FCONS-TERM FCONS-TERM* FFN-SYMB FN-SYMB FQUOTEP LOGBIT LOGDIFF BM-MATCH MATCH! NVARIABLEP PQUOTE PRIND QUOTEP TYO1 TYPE-PRESCRIPTION VALUEP VARIABLEP) (VARS (THEOREM-PROVER-FILES (QUOTE (BASIS GENFACT EVENTS CODE-1-A CODE-B-D CODE-E-M CODE-N-R CODE-S-Z IO BM-PPR))) (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T) (PROVE-FILE NIL) (ADD-TERM-TO-POT-LST-TEMP (LIST NIL)) (ALL-LEMMAS-USED NIL) (ALMOST-SUBSUMES-CONSTANT (CONS NIL NIL)) (ANCESTORS NIL) (ARITY-ALIST NIL) (BOOK-SYNTAX-FLG NIL) BOOT-STRAP-INSTRS (BOOT-STRAP-MACRO-FNS (QUOTE (GREATERP LEQ GEQ))) (BROKEN-LEMMAS NIL) (CLAUSE-ALIST NIL) (COMMUTED-EQUALITY-FLG NIL) (CULPRIT-FUNCTION NIL) (CURRENT-ATM 0) (CURRENT-LIT 0) (DO-NOT-USE-INDUCTION-FLG NIL) (DOTCONS (LIST NIL NIL)) (ELIM-VARIABLE-NAMES (QUOTE (X Z V W D C X1 Z1 V1 W1 D1 C1 X2 Z2 V2 W2 D2 C2))) (ELIM-VARIABLE-NAMES1 NIL) (EXECUTE-PROCESSES (QUOTE (SIMPLIFY-CLAUSE SETTLED-DOWN-CLAUSE FERTILIZE-CLAUSE ELIMINATE-DESTRUCTORS-CLAUSE GENERALIZE-CLAUSE ELIMINATE-IRRELEVANCE-CLAUSE STORE-SENT))) (EXPAND-LST NIL) (FAILED-THMS NIL) (FAILURE-MSG "************** F A I L E D **************") (FALSE (QUOTE (QUOTE *1*FALSE))) (FNS-TO-BE-IGNORED-BY-REWRITE NIL) (FORCEIN 38) (GEN-VARIABLE-NAMES (QUOTE (Y A U B E G H P Q R S))) (GENERALIZE-LEMMA-NAMES NIL) (GENERALIZING-SKOS NIL) (HEURISTIC-TYPE-ALIST NIL) (HINT NIL) (HINT-VARIABLE-ALIST (QUOTE ((DISABLE TEMPORARILY-DISABLED-LEMMAS NIL NIL) (EXPAND HINTED-EXPANSIONS T NIL) (HANDS-OFF FNS-TO-BE-IGNORED-BY-REWRITE NIL NIL) (NO-BUILT-IN-ARITH NO-BUILT-IN-ARITH-FLG NIL NIL)))) (HINTED-EXPANSIONS NIL) (INDUCTION-HYP-TERMS NIL) (IN-ADD-AXIOM-FLG NIL) (IN-BOOT-STRAP-FLG NIL) (IN-REDO-UNDONE-EVENTS-FLG NIL) (IN-PROVE-LEMMA-FLG NIL) (IO-FN (QUOTE IO1)) (IOTHMTIME 0) (IPOSITION-ALIST NIL) (LAST-PRINEVAL-CHAR (QUOTE %.)) (LAST-PROCESS NIL) (LEFTMARGINCHAR NIL) (LEMMA-DISPLAY-FLG NIL) (LEMMA-TYPES (QUOTE (REWRITE ELIM GENERALIZE META))) (LITATOM-FORM-COUNT-ALIST NIL) (LITS-THAT-MAY-BE-ASSUMED-FALSE NIL) (LITS-TO-BE-IGNORED-BY-LINEAR NIL) (META-NAMES (QUOTE (APPLY MEANING MEANING-LST ARITY FORMP FORM-LSTP))) (MUST-BE-FALSE NIL) (MUST-BE-TRUE NIL) (NILCONS (CONS NIL NIL)) (NO-BUILT-IN-ARITH-FLG NIL) (OBVIOUS-RESTRICTIONS NIL) (ORIGEVENT NIL) (PPR-MACRO-LST (QUOTE ((NOT . CONVERT-NOT) (CONS . CONVERT-CONS) (CAR . CONVERT-CAR-CDR) (CDR . CONVERT-CAR-CDR) (QUOTE . CONVERT-QUOTE)))) (PPRFIRSTCOL 35) (PPRMAXLNS 10000) (PRINEVAL-FNS (QUOTE (IEQP AND EQUAL OR NOT EQ EQLENGTH !CLAUSE !CLAUSE-SET !PPR LENGTH LENGTH-TO-ATOM !PPR-LIST !LIST PLURALP QUOTE QUOTE PQUOTE CAR CDR FN-SYMB FFN-SYMB ARGN FARGN ARGS FARGS QUOTEP FQUOTEP))) (PROVED-THMS NIL) (R-ALIST NIL) (STACK NIL) (TAB-SIZE 8.0) (TEMPORARILY-DISABLED-LEMMAS NIL) (TERMS-TO-BE-IGNORED-BY-REWRITE NIL) (TRANSLATE-TO-LISP-TIME 0) (TRUE (QUOTE (QUOTE *1*TRUE))) (TRUE-CLAUSE (LIST TRUE)) (TRUE-TYPE-ALIST NIL) (TTY-FILE NIL) (TYPE-ALIST NIL) (UN-PRODUCTIVE-PROCESSES (QUOTE (SETTLED-DOWN-CLAUSE STORE-SENT POP SUBSUMED-ABOVE SUBSUMED-BY-PARENT SUBSUMED-BELOW FINISHED))) (UNDONE-BATCH-COMMANDS NIL) (UNDONE-EVENTS-STACK NIL) (USE-NO-LEMMAS-FLG NIL) (WELL-ORDERING-RELATIONS (QUOTE (LESSP LEX2 LEX3))) (ZERO (QUOTE (QUOTE 0)))) (CONSTANTS (EVENT-SEPARATOR-STRING (CHARACTER (CHARCODE CR))) (*1*F (QUOTE *1*FALSE)) (*1*SHELL-QUOTE-MARK (QUOTE *1*QUOTE)) (*1*T (QUOTE *1*TRUE)) (PARAGRAPH-INDENT 5) (STRING-WEIRD (QUOTE *1*)) (STRING-WEIRD2 (QUOTE *2*)) (STRING-WEIRD3 (QUOTE *3*)) (TREE-INDENT 2) (TREE-LINES 2) (TYPE-SET-BOOLEAN 3) (TYPE-SET-CONS 16) (TYPE-SET-FALSE 1) (TYPE-SET-LITATOMS 8) (TYPE-SET-NEGATIVES 32) (TYPE-SET-NUMBERS 4) (TYPE-SET-TRUE 2) (TYPE-SET-UNKNOWN -1)) (INITVARS (LIB-FILE NIL) (LIB-VARS NIL) (LIB-ATOMS-WITH-PROPS NIL) (LIB-ATOMS-WITH-DEFS NIL) (LIB-PROPS NIL) (*ALIST* NIL) (*ARGLIST* NIL) (*CONTROLLER-COMPLEXITIES* NIL) (*FILE* NIL) (*FNNAME* NIL) (*INDENT* 0) (*TYPE-ALIST* NIL) (*1*BTM-OBJECTS NIL) (ABBREVIATIONS-USED NIL) (ADD-EQUATIONS-TO-DO NIL) (ALIST NIL) (ALISTS NIL) (ALL-FNS-FLG NIL) (ALMOST-SUBSUMES-LITERAL NIL) (ANS NIL) (ARGS NIL) (CHRONOLOGY NIL) (CL2 NIL) (COMMONSUBTERMS NIL) (CURRENT-CL NIL) (CURRENT-SIMPLIFY-CL NIL) (CURRENT-TYPE-NO NIL) (DECISIONS NIL) (DEFINITELY-FALSE NIL) (DEFN-FLG NIL) (DESCENDANTS NIL) (DISABLED-LEMMAS NIL) (DLHDFMLA NIL) (ELAPSEDTHMTIME NIL) (ENDLIST NIL) (EVENT-LST NIL) (FAILURE-ACTION NIL) (FALSE-TYPE-ALIST NIL) (FILE NIL) (FLATSIZE NIL) (FMLA NIL) (FNS NIL) (FNSTACK NIL) (FORM NIL) (GEN-VARIABLE-NAMES1 NIL) (GENERALIZE-LEMMAS NIL) (GENRLTLIST NIL) (HIGHER-PROPS NIL) (HINTS NIL) (HIST-ENTRY NIL) (ID-IFF NIL) (INDENT NIL) (INDUCTION-CONCL-TERMS NIL) (INST-HYP NIL) (LAST-CLAUSE NIL) (LAST-EXIT NIL) (LAST-HYP NIL) (LAST-PRIN5-WORD NIL) (LAST-PRINT-CLAUSES NIL) (LINEARIZE-ASSUMPTIONS-STACK NIL) (LEMMA-STACK NIL) (LEMMAS-USED-BY-LINEAR NIL) (LINEAR-ASSUMPTIONS NIL) (MAIN-EVENT-NAME NIL) (MARG2 NIL) (MASTER-ROOT-NAME NIL) (MATCH-TEMP NIL) (MATCH-X NIL) (MINREM NIL) (NAME NIL) (NAMES NIL) (NEXT-MEMO-KEY NIL) (NEXT-MEMO-VAL NIL) (NEXTIND NIL) (NEXTNODE NIL) (NONCONSTRUCTIVE-AXIOM-NAMES NIL) (NUMBER-OF-VARIABLES NIL) (OBJECTIVE NIL) (ORIG-LEMMA-STACK NIL) (ORIG-LINEARIZE-ASSUMPTIONS-STACK NIL) (ORIGTHM NIL) (PARENT NIL) (PARENT-HIST NIL) (POS NIL) (PPR-MACRO-MEMO NIL) (PPRFILE NIL) (PROCESS NIL) (PROCESS-CLAUSES NIL) (PROCESS-HIST NIL) (PROP NIL) (PROPLIST NIL) (PROVE-TERMINATION-LEMMAS-USED NIL) (RECOGNIZER-ALIST NIL) (RECORD-DECLARATIONS NIL) (RECORD-TEMP NIL) (RELIEVE-HYPS-NOT-OK-ANS NIL) (REMAINDER NIL) (SCRIBE-FLG NIL) (SETQ-LST NIL) (SHELL-ALIST NIL) (SHELL-POCKETS NIL) (SIMPLIFY-CLAUSE-MAXIMALLY-CLAUSES NIL) (SIMPLIFY-CLAUSE-MAXIMALLY-HIST NIL) (SIMPLIFY-CLAUSE-POT-LST NIL) (SINGLETON-TYPE-SETS NIL) (SPACELEFT NIL) (STARTLIST NIL) (T2 NIL) (TEMP-TEMP NIL) (TEMP1 NIL) (TEST-LST NIL) (THM NIL) (TYPE-SET-TERM1 NIL) (UNDONE-EVENTS NIL) (UNIFY-SUBST NIL) (UNIVERSE NIL) (VAL NIL) (VAR-ALIST NIL)) (RECORDS CANDIDATE GENERALIZE-LEMMA JUSTIFICATION LINEAR-LEMMA LINEAR-POT MEASURE-RULE POLY REWRITE-RULE TESTS-AND-ALISTS TESTS-AND-CASE TESTS-AND-CASES TYPE-PRESCRIPTION-NAME-AND-PAIR TYPE-RESTRICTION) (FNS BM-UPCASE COMPILE-IF-APPROPRIATE-AND-POSSIBLE COPYLIST EXTEND-FILE-NAME FIND-CHAR-IN-FILE FIND-STRING-IN-FILE GET-TOTAL-STATS GET-FROM-FILE GET-PLIST-FROM-FILE GET-STATS-FILE BM-PRIN1 PRINT-SYSTEM PRINT-DATE-LINE RANDOM-INITIALIZATION RANDOM-NUMBER READ-FILE REMQ STORE-DEFINITION SWAP-OUT R-LOOP TIME-IT TIME-IN-60THS XSEARCH *1*CAR *1*CDR ADD-TO-SET ARGN-MACRO BINDINGS-MACRO CELL CREATE-LEMMA-STACK CREATE-LINEARIZE-ASSUMPTIONS-STACK CREATE-STACK1 FARGN-MACRO FN-SYMB-MACRO HLOAD IPOSITION ITERPRI ITERPRIN ITERPRISPACES IPRIN1 IPRINC IPRINT ISPACES KILL-DEFINITION LINEL MAKE-LIB MATCH-MACRO MATCH!-MACRO MATCH1-MACRO MATCH2-MACRO NOTE-LIB BM-NTH PREPARE-FOR-THE-NIGHT SPELL-NUMBER SUB-PAIR UNIONQ) (P (SETQ LEMMA-STACK (CREATE-LEMMA-STACK 10)) (SETQ LINEARIZE-ASSUMPTIONS-STACK (CREATE-LINEARIZE-ASSUMPTIONS-STACK 10))))) (* BASIS *) (DEFMACRO GET1 (ATM PROP) #M (BQUOTE (GET11 (\, ATM) (\, PROP))) #Q (BQUOTE (GETPROP (\, ATM) (\, PROP)))) (DEFMACRO *1*IF (X Y Z) (BQUOTE (COND ((EQ (\, X) *1*F) (\, Z)) (T (\, Y))))) (DEFMACRO ADD-SUB-FACT-BODY X (GENERATE-ADD-SUB-FACT1 X)) (DEFMACRO ACCESS X (ACCESS-MACRO (CAR X) (CADR X) (CADDR X))) (DEFMACRO ARGN TAIL (ARGN-MACRO TAIL)) (DEFMACRO BINDINGS TAIL (BINDINGS-MACRO TAIL)) (DEFMACRO CHANGE X (CHANGE-MACRO (CAR X) (CADR X) (CADDR X) (CADDDR X))) (DEFMACRO DISABLEDP (NAME) (BQUOTE (OR (MEMB (SETQ TEMP-TEMP (\, NAME)) TEMPORARILY-DISABLED-LEMMAS) (CDDR (ASSOC TEMP-TEMP DISABLED-LEMMAS))))) (DEFMACRO FARGN TAIL (FARGN-MACRO TAIL)) (DEFMACRO FARGS (X) (BQUOTE (CDR (\, X)))) (DEFMACRO FCONS-TERM TAIL (CONS (QUOTE CONS) TAIL)) (DEFMACRO FCONS-TERM* TAIL (CONS (QUOTE LIST) TAIL)) (DEFMACRO FFN-SYMB (X) (BQUOTE (CAR (\, X)))) (DEFMACRO FN-SYMB TAIL (FN-SYMB-MACRO TAIL)) (DEFMACRO FQUOTEP (X) (BQUOTE (EQ (CAR (\, X)) (QUOTE QUOTE)))) (DEFMACRO LOGBIT (N) (BQUOTE (LSH 1 (\, N)))) (DEFMACRO LOGDIFF (X Y) (BQUOTE (BOOLE 4 (\, X) (\, Y)))) (DEFMACRO BM-MATCH X (* Matchs FORM against PATTERN where X =  (FORM PATTERN) FORM is evaluated and the free variables in PATTERN are bound to  parts of FORM. (BM-MATCH (QUOTE (EQUAL 34 56))  (EQUAL XX YY)) returns T and causes XX and YY to be bound to 34 and 56 *) (MATCH-MACRO (CAR X) (CADR X))) (DEFMACRO MATCH! X (MATCH!-MACRO (CAR X) (CADR X))) (DEFMACRO NVARIABLEP (X) (BQUOTE (LISTP (\, X)))) (DEFMACRO PQUOTE (X) (BQUOTE (QUOTE (\, X)))) (DEFMACRO PRIND (X FILE) (BQUOTE (LET ((TEMP (\, X))) (PRIN1 TEMP (\, FILE)) (SETQ POS (IPLUS POS (NCHARS TEMP)))))) (DEFMACRO QUOTEP (X) (BQUOTE (AND (LISTP (SETQ TEMP-TEMP (\, X))) (EQ (CAR TEMP-TEMP) (QUOTE QUOTE))))) (DEFMACRO TYO1 (X FILE) (BQUOTE (PROGN (TYO (\, X) (\, FILE)) (SETQ POS (ADD1 POS))))) (DEFMACRO TYPE-PRESCRIPTION (X) (BQUOTE (CDAR (GETPROP (\, X) (QUOTE TYPE-PRESCRIPTION-LST))))) (DEFMACRO VALUEP (X) (BQUOTE (QUOTEP (\, X)))) (DEFMACRO VARIABLEP (X) (BQUOTE (NLISTP (\, X)))) (RPAQQ THEOREM-PROVER-FILES (BASIS GENFACT EVENTS CODE-1-A CODE-B-D CODE-E-M CODE-N-R CODE-S-Z IO BM-PPR)) (RPAQQ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T) (RPAQQ PROVE-FILE NIL) (RPAQ ADD-TERM-TO-POT-LST-TEMP (LIST NIL)) (RPAQQ ALL-LEMMAS-USED NIL) (RPAQ ALMOST-SUBSUMES-CONSTANT (CONS NIL NIL)) (RPAQQ ANCESTORS NIL) (RPAQQ ARITY-ALIST NIL) (RPAQQ BOOK-SYNTAX-FLG NIL) (RPAQQ BOOT-STRAP-INSTRS ((ADD-SHELL0 FALSE NIL FALSEP NIL) (ADD-SHELL0 TRUE NIL TRUEP NIL) (DEFN0 NOT (P) (IF P (FALSE) (TRUE)) NIL T) (DEFN0 AND (P Q) (IF P (IF Q (TRUE) (FALSE)) (FALSE)) NIL T) (DEFN0 OR (P Q) (IF P (TRUE) (IF Q (TRUE) (FALSE))) NIL T) (DEFN0 IMPLIES (P Q) (IF P (IF Q (TRUE) (FALSE)) (TRUE)) NIL T) (ADD-SHELL0 ADD1 ZERO NUMBERP ((SUB1 (ONE-OF NUMBERP) ZERO))) (DEFN0 LESSP (X Y) (IF (OR (EQUAL Y 0) (NOT (NUMBERP Y))) (FALSE) (IF (OR (EQUAL X 0) (NOT (NUMBERP X))) (TRUE) (LESSP (SUB1 X) (SUB1 Y)))) NIL T) (PUT1 LESSP 0 LEVEL-NO) (DEFN0 GREATERP (X Y) (LESSP Y X) NIL NIL) (DEFN0 LEQ (X Y) (NOT (LESSP Y X)) NIL NIL) (DEFN0 GEQ (X Y) (NOT (LESSP X Y)) NIL NIL) (DEFN0 LEX2 (L1 L2) (OR (LESSP (CAR L1) (CAR L2)) (AND (EQUAL (CAR L1) (CAR L2)) (LESSP (CADR L1) (CADR L2)))) NIL NIL) (DEFN0 LEX3 (L1 L2) (OR (LESSP (CAR L1) (CAR L2)) (AND (EQUAL (CAR L1) (CAR L2)) (LEX2 (CDR L1) (CDR L2)))) NIL NIL) (DEFN0 ZEROP (X) (IF (EQUAL X 0) T (IF (NUMBERP X) F T)) NIL T) (DEFN0 FIX (X) (IF (NUMBERP X) X 0) NIL T) (DEFN0 PLUS (X Y) (IF (ZEROP X) (FIX Y) (ADD1 (PLUS (SUB1 X) Y))) NIL T) (ADD-AXIOM1 COUNT-NUMBERP (REWRITE) (IMPLIES (NUMBERP I) (EQUAL (COUNT I) I))) (ADD-AXIOM1 COUNT-NOT-LESSP (REWRITE) (NOT (LESSP (COUNT I) I))) (ADD-SHELL0 PACK NIL LITATOM ((UNPACK (NONE-OF) ZERO))) (ADD-SHELL0 CONS NIL LISTP ((CAR (NONE-OF) ZERO) (CDR (NONE-OF) ZERO))) (DEFN0 NLISTP (X) (NOT (LISTP X)) NIL T) (ADD-SHELL0 MINUS NIL NEGATIVEP ((NEGATIVE-GUTS (ONE-OF NUMBERP) ZERO))) (DEFN0 DIFFERENCE (I J) (IF (ZEROP I) 0 (IF (ZEROP J) I (DIFFERENCE (SUB1 I) (SUB1 J)))) NIL T) (DEFN0 TIMES (I J) (IF (ZEROP I) 0 (PLUS J (TIMES (SUB1 I) J))) NIL T) (DEFN0 QUOTIENT (I J) (IF (ZEROP J) 0 (IF (LESSP I J) 0 (ADD1 (QUOTIENT (DIFFERENCE I J) J)))) NIL T) (DEFN0 REMAINDER (I J) (IF (ZEROP J) (FIX I) (IF (LESSP I J) (FIX I) (REMAINDER (DIFFERENCE I J) J))) NIL T) (DEFN0 LEGAL-CHAR-CODES NIL (QUOTE (45 48 49 50 51 52 53 54 55 56 57 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90)) NIL NIL) (DEFN0 ILLEGAL-FIRST-CHAR-CODES NIL (QUOTE (45 48 49 50 51 52 53 54 55 56 57)) NIL NIL) (DEFN0 LENGTH (LST) (IF (LISTP LST) (ADD1 (LENGTH (CDR LST))) 0) NIL NIL) (DEFN0 MEMBER (X LST) (IF (NLISTP LST) F (IF (EQUAL X (CAR LST)) T (MEMBER X (CDR LST)))) NIL NIL) (DEFN0 SUBSETP (X Y) (IF (NLISTP X) T (IF (MEMBER (CAR X) Y) (SUBSETP (CDR X) Y) F)) NIL NIL) (DEFN0 LAST (L) (IF (LISTP L) (IF (LISTP (CDR L)) (LAST (CDR L)) L) L) NIL NIL) (DEFN0 LEGAL-CHAR-CODE-SEQ (LST) (AND (LISTP LST) (SUBSETP LST (LEGAL-CHAR-CODES)) (NOT (MEMBER (CAR LST) (ILLEGAL-FIRST-CHAR-CODES))) (EQUAL (CDR (LAST LST)) 0)) NIL NIL) (DEFN0 SYMBOLP (X) (AND (LITATOM X) (LEGAL-CHAR-CODE-SEQ (UNPACK X))) NIL NIL) (DEFN0 LOOKUP (X ALIST) (IF (NLISTP ALIST) NIL (IF (AND (LISTP (CAR ALIST)) (EQUAL X (CAAR ALIST))) (CDAR ALIST) (LOOKUP X (CDR ALIST)))) NIL NIL) (DCL0 ARITY (X)) (DCL0 FORMP (X)) (DEFN0 FORM-LSTP (X) (IF (NLISTP X) (EQUAL X NIL) (AND (FORMP (CAR X)) (FORM-LSTP (CDR X)))) NIL NIL) (DCL0 APPLY (X LST)) (DCL0 MEANING (X ALIST)) (DEFN0 MEANING-LST (X ALIST) (IF (NLISTP X) NIL (CONS (MEANING (CAR X) ALIST) (MEANING-LST (CDR X) ALIST))) NIL NIL) (SETUP-META-NAMES) (DEFN0 SPLIT (X) X NIL NIL) (DEFN0 CHECK (X) X NIL NIL))) (RPAQQ BOOT-STRAP-MACRO-FNS (GREATERP LEQ GEQ)) (RPAQQ BROKEN-LEMMAS NIL) (RPAQQ CLAUSE-ALIST NIL) (RPAQQ COMMUTED-EQUALITY-FLG NIL) (RPAQQ CULPRIT-FUNCTION NIL) (RPAQQ CURRENT-ATM 0) (RPAQQ CURRENT-LIT 0) (RPAQQ DO-NOT-USE-INDUCTION-FLG NIL) (RPAQ DOTCONS (LIST NIL NIL)) (RPAQQ ELIM-VARIABLE-NAMES (X Z V W D C X1 Z1 V1 W1 D1 C1 X2 Z2 V2 W2 D2 C2)) (RPAQQ ELIM-VARIABLE-NAMES1 NIL) (RPAQQ EXECUTE-PROCESSES (SIMPLIFY-CLAUSE SETTLED-DOWN-CLAUSE FERTILIZE-CLAUSE ELIMINATE-DESTRUCTORS-CLAUSE GENERALIZE-CLAUSE ELIMINATE-IRRELEVANCE-CLAUSE STORE-SENT)) (RPAQQ EXPAND-LST NIL) (RPAQQ FAILED-THMS NIL) (RPAQ FAILURE-MSG "************** F A I L E D **************") (RPAQQ FALSE (QUOTE *1*FALSE)) (RPAQQ FNS-TO-BE-IGNORED-BY-REWRITE NIL) (RPAQQ FORCEIN 38) (RPAQQ GEN-VARIABLE-NAMES (Y A U B E G H P Q R S)) (RPAQQ GENERALIZE-LEMMA-NAMES NIL) (RPAQQ GENERALIZING-SKOS NIL) (RPAQQ HEURISTIC-TYPE-ALIST NIL) (RPAQQ HINT NIL) (RPAQQ HINT-VARIABLE-ALIST ((DISABLE TEMPORARILY-DISABLED-LEMMAS NIL NIL) (EXPAND HINTED-EXPANSIONS T NIL) (HANDS-OFF FNS-TO-BE-IGNORED-BY-REWRITE NIL NIL) (NO-BUILT-IN-ARITH NO-BUILT-IN-ARITH-FLG NIL NIL))) (RPAQQ HINTED-EXPANSIONS NIL) (RPAQQ INDUCTION-HYP-TERMS NIL) (RPAQQ IN-ADD-AXIOM-FLG NIL) (RPAQQ IN-BOOT-STRAP-FLG NIL) (RPAQQ IN-REDO-UNDONE-EVENTS-FLG NIL) (RPAQQ IN-PROVE-LEMMA-FLG NIL) (RPAQQ IO-FN IO1) (RPAQQ IOTHMTIME 0) (RPAQQ IPOSITION-ALIST NIL) (RPAQQ LAST-PRINEVAL-CHAR %.) (RPAQQ LAST-PROCESS NIL) (RPAQQ LEFTMARGINCHAR NIL) (RPAQQ LEMMA-DISPLAY-FLG NIL) (RPAQQ LEMMA-TYPES (REWRITE ELIM GENERALIZE META)) (RPAQQ LITATOM-FORM-COUNT-ALIST NIL) (RPAQQ LITS-THAT-MAY-BE-ASSUMED-FALSE NIL) (RPAQQ LITS-TO-BE-IGNORED-BY-LINEAR NIL) (RPAQQ META-NAMES (APPLY MEANING MEANING-LST ARITY FORMP FORM-LSTP)) (RPAQQ MUST-BE-FALSE NIL) (RPAQQ MUST-BE-TRUE NIL) (RPAQ NILCONS (CONS NIL NIL)) (RPAQQ NO-BUILT-IN-ARITH-FLG NIL) (RPAQQ OBVIOUS-RESTRICTIONS NIL) (RPAQQ ORIGEVENT NIL) (RPAQQ PPR-MACRO-LST ((NOT . CONVERT-NOT) (CONS . CONVERT-CONS) (CAR . CONVERT-CAR-CDR) (CDR . CONVERT-CAR-CDR) (QUOTE . CONVERT-QUOTE))) (RPAQQ PPRFIRSTCOL 35) (RPAQQ PPRMAXLNS 10000) (RPAQQ PRINEVAL-FNS (IEQP AND EQUAL OR NOT EQ EQLENGTH !CLAUSE !CLAUSE-SET !PPR LENGTH LENGTH-TO-ATOM !PPR-LIST !LIST PLURALP QUOTE QUOTE PQUOTE CAR CDR FN-SYMB FFN-SYMB ARGN FARGN ARGS FARGS QUOTEP FQUOTEP)) (RPAQQ PROVED-THMS NIL) (RPAQQ R-ALIST NIL) (RPAQQ STACK NIL) (RPAQQ TAB-SIZE 8.0) (RPAQQ TEMPORARILY-DISABLED-LEMMAS NIL) (RPAQQ TERMS-TO-BE-IGNORED-BY-REWRITE NIL) (RPAQQ TRANSLATE-TO-LISP-TIME 0) (RPAQQ TRUE (QUOTE *1*TRUE)) (RPAQ TRUE-CLAUSE (LIST TRUE)) (RPAQQ TRUE-TYPE-ALIST NIL) (RPAQQ TTY-FILE NIL) (RPAQQ TYPE-ALIST NIL) (RPAQQ UN-PRODUCTIVE-PROCESSES (SETTLED-DOWN-CLAUSE STORE-SENT POP SUBSUMED-ABOVE SUBSUMED-BY-PARENT SUBSUMED-BELOW FINISHED)) (RPAQQ UNDONE-BATCH-COMMANDS NIL) (RPAQQ UNDONE-EVENTS-STACK NIL) (RPAQQ USE-NO-LEMMAS-FLG NIL) (RPAQQ WELL-ORDERING-RELATIONS (LESSP LEX2 LEX3)) (RPAQQ ZERO (QUOTE 0)) (DECLARE: EVAL@COMPILE (RPAQ EVENT-SEPARATOR-STRING (CHARACTER (CHARCODE CR))) (RPAQQ *1*F *1*FALSE) (RPAQQ *1*SHELL-QUOTE-MARK *1*QUOTE) (RPAQQ *1*T *1*TRUE) (RPAQQ PARAGRAPH-INDENT 5) (RPAQQ STRING-WEIRD *1*) (RPAQQ STRING-WEIRD2 *2*) (RPAQQ STRING-WEIRD3 *3*) (RPAQQ TREE-INDENT 2) (RPAQQ TREE-LINES 2) (RPAQQ TYPE-SET-BOOLEAN 3) (RPAQQ TYPE-SET-CONS 16) (RPAQQ TYPE-SET-FALSE 1) (RPAQQ TYPE-SET-LITATOMS 8) (RPAQQ TYPE-SET-NEGATIVES 32) (RPAQQ TYPE-SET-NUMBERS 4) (RPAQQ TYPE-SET-TRUE 2) (RPAQQ TYPE-SET-UNKNOWN -1) (CONSTANTS (EVENT-SEPARATOR-STRING (CHARACTER (CHARCODE CR))) (*1*F (QUOTE *1*FALSE)) (*1*SHELL-QUOTE-MARK (QUOTE *1*QUOTE)) (*1*T (QUOTE *1*TRUE)) (PARAGRAPH-INDENT 5) (STRING-WEIRD (QUOTE *1*)) (STRING-WEIRD2 (QUOTE *2*)) (STRING-WEIRD3 (QUOTE *3*)) (TREE-INDENT 2) (TREE-LINES 2) (TYPE-SET-BOOLEAN 3) (TYPE-SET-CONS 16) (TYPE-SET-FALSE 1) (TYPE-SET-LITATOMS 8) (TYPE-SET-NEGATIVES 32) (TYPE-SET-NUMBERS 4) (TYPE-SET-TRUE 2) (TYPE-SET-UNKNOWN -1)) ) (RPAQ? LIB-FILE NIL) (RPAQ? LIB-VARS NIL) (RPAQ? LIB-ATOMS-WITH-PROPS NIL) (RPAQ? LIB-ATOMS-WITH-DEFS NIL) (RPAQ? LIB-PROPS NIL) (RPAQ? *ALIST* NIL) (RPAQ? *ARGLIST* NIL) (RPAQ? *CONTROLLER-COMPLEXITIES* NIL) (RPAQ? *FILE* NIL) (RPAQ? *FNNAME* NIL) (RPAQ? *INDENT* 0) (RPAQ? *TYPE-ALIST* NIL) (RPAQ? *1*BTM-OBJECTS NIL) (RPAQ? ABBREVIATIONS-USED NIL) (RPAQ? ADD-EQUATIONS-TO-DO NIL) (RPAQ? ALIST NIL) (RPAQ? ALISTS NIL) (RPAQ? ALL-FNS-FLG NIL) (RPAQ? ALMOST-SUBSUMES-LITERAL NIL) (RPAQ? ANS NIL) (RPAQ? ARGS NIL) (RPAQ? CHRONOLOGY NIL) (RPAQ? CL2 NIL) (RPAQ? COMMONSUBTERMS NIL) (RPAQ? CURRENT-CL NIL) (RPAQ? CURRENT-SIMPLIFY-CL NIL) (RPAQ? CURRENT-TYPE-NO NIL) (RPAQ? DECISIONS NIL) (RPAQ? DEFINITELY-FALSE NIL) (RPAQ? DEFN-FLG NIL) (RPAQ? DESCENDANTS NIL) (RPAQ? DISABLED-LEMMAS NIL) (RPAQ? DLHDFMLA NIL) (RPAQ? ELAPSEDTHMTIME NIL) (RPAQ? ENDLIST NIL) (RPAQ? EVENT-LST NIL) (RPAQ? FAILURE-ACTION NIL) (RPAQ? FALSE-TYPE-ALIST NIL) (RPAQ? FILE NIL) (RPAQ? FLATSIZE NIL) (RPAQ? FMLA NIL) (RPAQ? FNS NIL) (RPAQ? FNSTACK NIL) (RPAQ? FORM NIL) (RPAQ? GEN-VARIABLE-NAMES1 NIL) (RPAQ? GENERALIZE-LEMMAS NIL) (RPAQ? GENRLTLIST NIL) (RPAQ? HIGHER-PROPS NIL) (RPAQ? HINTS NIL) (RPAQ? HIST-ENTRY NIL) (RPAQ? ID-IFF NIL) (RPAQ? INDENT NIL) (RPAQ? INDUCTION-CONCL-TERMS NIL) (RPAQ? INST-HYP NIL) (RPAQ? LAST-CLAUSE NIL) (RPAQ? LAST-EXIT NIL) (RPAQ? LAST-HYP NIL) (RPAQ? LAST-PRIN5-WORD NIL) (RPAQ? LAST-PRINT-CLAUSES NIL) (RPAQ? LINEARIZE-ASSUMPTIONS-STACK NIL) (RPAQ? LEMMA-STACK NIL) (RPAQ? LEMMAS-USED-BY-LINEAR NIL) (RPAQ? LINEAR-ASSUMPTIONS NIL) (RPAQ? MAIN-EVENT-NAME NIL) (RPAQ? MARG2 NIL) (RPAQ? MASTER-ROOT-NAME NIL) (RPAQ? MATCH-TEMP NIL) (RPAQ? MATCH-X NIL) (RPAQ? MINREM NIL) (RPAQ? NAME NIL) (RPAQ? NAMES NIL) (RPAQ? NEXT-MEMO-KEY NIL) (RPAQ? NEXT-MEMO-VAL NIL) (RPAQ? NEXTIND NIL) (RPAQ? NEXTNODE NIL) (RPAQ? NONCONSTRUCTIVE-AXIOM-NAMES NIL) (RPAQ? NUMBER-OF-VARIABLES NIL) (RPAQ? OBJECTIVE NIL) (RPAQ? ORIG-LEMMA-STACK NIL) (RPAQ? ORIG-LINEARIZE-ASSUMPTIONS-STACK NIL) (RPAQ? ORIGTHM NIL) (RPAQ? PARENT NIL) (RPAQ? PARENT-HIST NIL) (RPAQ? POS NIL) (RPAQ? PPR-MACRO-MEMO NIL) (RPAQ? PPRFILE NIL) (RPAQ? PROCESS NIL) (RPAQ? PROCESS-CLAUSES NIL) (RPAQ? PROCESS-HIST NIL) (RPAQ? PROP NIL) (RPAQ? PROPLIST NIL) (RPAQ? PROVE-TERMINATION-LEMMAS-USED NIL) (RPAQ? RECOGNIZER-ALIST NIL) (RPAQ? RECORD-DECLARATIONS NIL) (RPAQ? RECORD-TEMP NIL) (RPAQ? RELIEVE-HYPS-NOT-OK-ANS NIL) (RPAQ? REMAINDER NIL) (RPAQ? SCRIBE-FLG NIL) (RPAQ? SETQ-LST NIL) (RPAQ? SHELL-ALIST NIL) (RPAQ? SHELL-POCKETS NIL) (RPAQ? SIMPLIFY-CLAUSE-MAXIMALLY-CLAUSES NIL) (RPAQ? SIMPLIFY-CLAUSE-MAXIMALLY-HIST NIL) (RPAQ? SIMPLIFY-CLAUSE-POT-LST NIL) (RPAQ? SINGLETON-TYPE-SETS NIL) (RPAQ? SPACELEFT NIL) (RPAQ? STARTLIST NIL) (RPAQ? T2 NIL) (RPAQ? TEMP-TEMP NIL) (RPAQ? TEMP1 NIL) (RPAQ? TEST-LST NIL) (RPAQ? THM NIL) (RPAQ? TYPE-SET-TERM1 NIL) (RPAQ? UNDONE-EVENTS NIL) (RPAQ? UNIFY-SUBST NIL) (RPAQ? UNIVERSE NIL) (RPAQ? VAL NIL) (RPAQ? VAR-ALIST NIL) [DECLARE: EVAL@COMPILE (DATATYPE CANDIDATE (SCORE CONTROLLERS CHANGED-VARS UNCHANGEABLE-VARS TESTS-AND-ALISTS-LST JUSTIFICATION INDUCTION-TERM OTHER-TERMS)) (DATATYPE GENERALIZE-LEMMA (NAME TERM)) (DATATYPE JUSTIFICATION (SUBSET MEASURE-TERM RELATION LEMMAS)) (DATATYPE LINEAR-LEMMA (NAME HYPS CONCL MAX-TERM)) (DATATYPE LINEAR-POT (VAR POSITIVES NEGATIVES)) (DATATYPE MEASURE-RULE (CONDITION-LIST THE-LESSER STRENGTH-SIGN THE-GREATER INDUCTION-LEMMA-NAME MEASURE)) (DATATYPE POLY (CONSTANT ALIST ASSUMPTIONS LITERALS LEMMAS)) (DATATYPE REWRITE-RULE (NAME HYPS CONCL LOOP-STOPPER)) (DATATYPE TESTS-AND-ALISTS (TESTS ALISTS)) (DATATYPE TESTS-AND-CASE (TESTS CASE)) (DATATYPE TESTS-AND-CASES (TESTS CASES)) (DATATYPE TYPE-PRESCRIPTION-NAME-AND-PAIR (NAME PAIR)) (DATATYPE TYPE-RESTRICTION (TERM TYPE-SET DEFAULT)) ] (/DECLAREDATATYPE (QUOTE CANDIDATE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((CANDIDATE 0 POINTER) (CANDIDATE 2 POINTER) (CANDIDATE 4 POINTER) (CANDIDATE 6 POINTER) (CANDIDATE 8 POINTER) (CANDIDATE 10 POINTER) (CANDIDATE 12 POINTER) (CANDIDATE 14 POINTER))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE GENERALIZE-LEMMA) (QUOTE (POINTER POINTER)) (QUOTE ((GENERALIZE-LEMMA 0 POINTER) (GENERALIZE-LEMMA 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE JUSTIFICATION) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((JUSTIFICATION 0 POINTER) (JUSTIFICATION 2 POINTER) (JUSTIFICATION 4 POINTER) (JUSTIFICATION 6 POINTER))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE LINEAR-LEMMA) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((LINEAR-LEMMA 0 POINTER) (LINEAR-LEMMA 2 POINTER) (LINEAR-LEMMA 4 POINTER) (LINEAR-LEMMA 6 POINTER))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE LINEAR-POT) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((LINEAR-POT 0 POINTER) (LINEAR-POT 2 POINTER) (LINEAR-POT 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE MEASURE-RULE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((MEASURE-RULE 0 POINTER) (MEASURE-RULE 2 POINTER) (MEASURE-RULE 4 POINTER) (MEASURE-RULE 6 POINTER) (MEASURE-RULE 8 POINTER) (MEASURE-RULE 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE POLY) (QUOTE (POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((POLY 0 POINTER) (POLY 2 POINTER) (POLY 4 POINTER) (POLY 6 POINTER) (POLY 8 POINTER))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE REWRITE-RULE) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((REWRITE-RULE 0 POINTER) (REWRITE-RULE 2 POINTER) (REWRITE-RULE 4 POINTER) (REWRITE-RULE 6 POINTER))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TESTS-AND-ALISTS) (QUOTE (POINTER POINTER)) (QUOTE ((TESTS-AND-ALISTS 0 POINTER) (TESTS-AND-ALISTS 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE TESTS-AND-CASE) (QUOTE (POINTER POINTER)) (QUOTE ((TESTS-AND-CASE 0 POINTER) (TESTS-AND-CASE 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE TESTS-AND-CASES) (QUOTE (POINTER POINTER)) (QUOTE ((TESTS-AND-CASES 0 POINTER) (TESTS-AND-CASES 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE TYPE-PRESCRIPTION-NAME-AND-PAIR) (QUOTE (POINTER POINTER)) (QUOTE ((TYPE-PRESCRIPTION-NAME-AND-PAIR 0 POINTER) (TYPE-PRESCRIPTION-NAME-AND-PAIR 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE TYPE-RESTRICTION) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((TYPE-RESTRICTION 0 POINTER) (TYPE-RESTRICTION 2 POINTER) (TYPE-RESTRICTION 4 POINTER))) (QUOTE 6)) (DEFINEQ (BM-UPCASE [LAMBDA (N) (* kbr: "19-Oct-85 16:31") (COND ((AND (IGEQ N (CHARCODE a)) (ILEQ N (CHARCODE z))) (IDIFFERENCE N 32)) (T N]) (COMPILE-IF-APPROPRIATE-AND-POSSIBLE [LAMBDA (FNS) (* kbr: " 6-Jul-86 09:53") (* If a function foo is defined in our theory, a function *1*foo is defined in  Lisp. Sometimes during the course of a proof, *1*foo may be executed to compute  the value of foo on certain values. There is a speed benefit to compiling  *1*foo. In Maclisp, the compiler is not in the same Lisp with the  theorem-prover in Zetalisp, the compiler is resident.  The *.LISP files produced by MAKE-LIB may be compiled after loading the  compilation of BASIS into the compiler. Hence it is possible to obtain the  speed of compiled functions in the Maclisp version of the theorem-prover, at  the expense of making a library, running a separate compilation, and using  NOTE-LIB to load the *.LIB file and the compilation of the .LISP file.  *) (for FN in FNS do (COND ((NOT (CCODEP (GETD FN))) (COMPILE! FN]) (COPYLIST [LAMBDA (L) (* kbr: " 6-Jul-86 09:54") (* Top level copy of list L *) (for X in L collect X]) (EXTEND-FILE-NAME [LAMBDA (FILE EXTENSION) (* kbr: "19-Oct-85 16:31") (PACKFILENAME (APPEND (LIST (QUOTE EXTENSION) EXTENSION) (UNPACKFILENAME FILE]) (FIND-CHAR-IN-FILE [LAMBDA (CHAR FILE) (* kbr: "25-Oct-85 14:33") (* Assumes that FILE is a stream for a file.  Searches for the next occurrence of CHAR past current position, if any.  If one is found, the file pointer is left just after the occurrence and the  file pointer is returned. Otherwise NIL is returned.  *) (while T bind CH do (SETQ CH (TYI FILE -1)) (COND ((IEQP CH -1) (RETURN NIL)) ((IEQP CH CHAR) (RETURN (FILEPOS FILE]) (FIND-STRING-IN-FILE [LAMBDA (STRING FILE) (* kbr: "25-Oct-85 14:34") (LET ((STRING-LEN-1 (SUB1 (NCHARS STRING)))) (COND ((EQUAL STRING-LEN-1 -1) (GETFILEPTR FILE)) (T (bind (POS _ (CHCON STRING)) (CHARS _ (CHCON STRING)) (FIRST-CHAR _ (CAR CHARS)) (OTHER-CHARS _ (CDR CHARS)) (*1*+FILE-LEN-STR-LEN _ (IPLUS (GETEOFPTR FILE) (MINUS STRING-LEN-1))) while (SETQ POS (FIND-CHAR-IN-FILE FIRST-CHAR FILE)) do (COND ((AND (NOT (IGREATERP POS *1*+FILE-LEN-STR-LEN)) (for CHAR in OTHER-CHARS always (IEQP CHAR (TYI FILE)))) (RETURN (SUB1 POS))) (T (SETFILEPTR FILE POS]) (GET-TOTAL-STATS [LAMBDA (DIR) (* kbr: "25-Oct-85 14:39") (PROG (TP-TIME IO-TIME STATS) (for ROOT in (QUOTE (PROVEALL RSA WILSON GAUSS FORTRAN CONTROLLER PR TMI UNSOLV ZTAK)) do (SETQ STATS (SUM-STATS-ALIST (GET-STATS-FILE (PACKFILENAME (LIST (QUOTE DIRECTORY) DIR (QUOTE NAME) ROOT (QUOTE EXTENSION) (QUOTE PROOFS)))))) (SETQ TP-TIME (IPLUS (CAR STATS) TP-TIME)) (SETQ IO-TIME (IPLUS (CADR STATS) IO-TIME))) (RETURN (LIST TP-TIME IO-TIME]) (GET-FROM-FILE [LAMBDA (ATM PROP) (* kbr: "25-Oct-85 14:39") (for TAIL on (GET-PLIST-FROM-FILE ATM) by (QUOTE CDDR) when (EQ PROP (CAR TAIL)) do (RETURN (CADR TAIL]) (GET-PLIST-FROM-FILE [LAMBDA (ATM) (* kbr: " 6-Jul-86 09:57") (LET ((LOC (GETPROP ATM (QUOTE LIB-LOC)))) (COND ((NULL LOC) NIL) ((NOT (BOUNDP (QUOTE LIB-FILE))) NIL) (T (SETFILEPTR LIB-FILE LOC) (CADR (CADDR (READ LIB-FILE]) (GET-STATS-FILE [LAMBDA (FILE) (* kbr: "25-Oct-85 14:41") (* Returns a list of triplets  (event cpu io), where cpu is the  number of elapsed seconds minus io  seconds. *) (LET ((EVENT-CHAR (NTHCHARCODE EVENT-SEPARATOR-STRING 1)) (EOF-CONS (CONS NIL NIL)) TEMP TP-TIME IO-TIME) (SETQ FILE (OPENSTREAM FILE (QUOTE INPUT))) (SETFILEPTR FILE 0) (while (AND (FIND-CHAR-IN-FILE EVENT-CHAR FILE) (NEQ EOF-CONS (SETQ TEMP (READ FILE EOF-CONS))) (FIND-CHAR-IN-FILE #/ FILE) (NUMBERP (SETQ TP-TIME (READ FILE EOF-CONS))) (NUMBERP (SETQ IO-TIME (READ FILE EOF-CONS)))) collect (CONS TEMP (LIST TP-TIME IO-TIME]) (BM-PRIN1 [LAMBDA (DATA FILE) (* kbr: "19-Oct-85 16:31") (PATOM DATA FILE]) (PRINT-SYSTEM [LAMBDA (FILE) (* kbr: "24-Oct-85 16:32") (PRIN1 (QUOTE SYSTEM) FILE) (TERPRI FILE) (PRIN1 "0.0 0.0" FILE) (for FL in THEOREM-PROVER-FILES do (PRINT (CDR (CAR (GETPROP FL (QUOTE FILEDATES)))))) (PRIN1 MAKESYSNAME FILE) (PRIN1 " " FILE) (PRIN1 MAKESYSDATE FILE) (TERPRI FILE]) (PRINT-DATE-LINE [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (PRIN1 (GDATE) PROVE-FILE]) (RANDOM-INITIALIZATION [LAMBDA (EVENT) (* kbr: "19-Oct-85 16:31") (RANDSET (QUOTE (14106 39422 64835 57733 34919 5315 12110 15116 10133 10816 60097 23088 5624 21340 53921 15106 4684 41739 64042 23754 16272 2980 45652 52345 2362 36658 65286 43318 47346 39405 37667 44583 35376 23651 7908 33877 32302 22146 63687 45438 51385 11636 43707 59964 45045 48385 64260 37257 4475 14893 14979 48212 48490 22654 29015]) (RANDOM-NUMBER [LAMBDA (N) (* kbr: "24-Oct-85 17:15") (RAND 0 (SUB1 N]) (READ-FILE [LAMBDA (FILE-NAME) (* kbr: "25-Oct-85 14:42") (LET ((FILE (OPENSTREAM FILE-NAME (QUOTE INPUT))) (MY-CONS (CONS NIL NIL))) (bind TEMP while (NEQ MY-CONS (SETQ TEMP (READ FILE MY-CONS))) collect TEMP]) (REMQ [LAMBDA (I L) (* kbr: "19-Oct-85 16:31") (for X in L unless (EQ X I) collect X]) (STORE-DEFINITION [LAMBDA (ATM EXPR) (* kbr: " 6-Jul-86 10:05") (PUTD ATM EXPR) (COMPILE! ATM]) (SWAP-OUT [LAMBDA (NAME) (* kbr: " 3-Nov-85 17:04") (APPLY (FUNCTION NOTE-LIB) (MAKE-LIB NAME]) (R-LOOP [LAMBDA NIL (* kbr: "20-Oct-85 17:25") (while T do (TERPRI NIL) (PRIN2 (QUOTE *) NIL) (BM-PPR (R (PROG1 (READ NIL) (TERPRI NIL))) NIL]) (TIME-IT [LAMBDA (FORM) (* kbr: "19-Oct-85 16:31") (LET ((START-TIME (TIME-IN-60THS))) (LIST (EVAL FORM) (QUOTIENT (DIFFERENCE (TIME-IN-60THS) START-TIME) 60.0]) (TIME-IN-60THS [LAMBDA NIL (* kbr: " 6-Jul-86 10:10") (IQUOTIENT (ITIMES 60 (CLOCK 2)) 1000]) (XSEARCH [LAMBDA (STRINGS FILE-SPECS) (* kbr: "25-Oct-85 14:28") (COND ((NLISTP STRINGS) (SETQ STRINGS (LIST STRINGS)))) (COND ((NLISTP FILE-SPECS) (SETQ FILE-SPECS (LIST FILE-SPECS)))) (for L in (for FILE-SPEC in FILE-SPECS join (LIST (LIST FILE-SPEC))) bind NAME FILE when (AND (CAR L) (PROGN (TERPRI T) (SETQ NAME (CAR L)) (PRIN1 NAME T) (SETQ FILE (OPENSTREAM NAME (QUOTE INPUT))) (PROG1 (for STRING in STRINGS thereis (PROGN (SETFILEPTR FILE 0) (FIND-STRING-IN-FILE STRING FILE ))) (CLOSE? FILE)))) collect (PROGN (PRIN1 "Yes." T) NAME]) (*1*CAR [LAMBDA (X1) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP X1) 0) ((EQ (CAR X1) (QUOTE *1*QUOTE)) 0) (T (CAR X1]) (*1*CDR [LAMBDA (X1) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP X1) 0) ((EQ (CAR X1) (QUOTE *1*QUOTE)) 0) (T (CDR X1]) (ADD-TO-SET [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (COND ((MEMBER X Y) Y) (T (CONS X Y]) (ARGN-MACRO [LAMBDA (TAIL) (* kbr: "19-Oct-85 16:31") (COND ((FIXP (CADR TAIL)) (SUB-PAIR (QUOTE (TERM CELL N)) (LIST (CAR TAIL) (CELL (CADR TAIL) (QUOTE TEMP-TEMP)) (CADR TAIL)) (QUOTE (COND ((NEQ (CAR (SETQ TEMP-TEMP TERM)) (QUOTE QUOTE)) (CAR CELL)) (T (ARGN0 TEMP-TEMP N)))))) (T (CONS (QUOTE ARGN0) TAIL]) (BINDINGS-MACRO [LAMBDA (TAIL) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP TAIL) NIL) (T (BQUOTE (CONS (CONS (\, (CAR TAIL)) (\, (CADR TAIL))) (\, (BINDINGS-MACRO (CDDR TAIL]) (CELL [LAMBDA (N FIELD) (* kbr: "19-Oct-85 16:31") (COND ((IEQP N 0) FIELD) (T (LIST (QUOTE CDR) (CELL (SUB1 N) FIELD]) (CREATE-LEMMA-STACK [LAMBDA (N) (* kbr: "19-Oct-85 21:55") (SETQ ORIG-LEMMA-STACK (SETQ LEMMA-STACK NIL)) NIL]) (CREATE-LINEARIZE-ASSUMPTIONS-STACK [LAMBDA (N) (* kbr: "19-Oct-85 22:00") (SETQ ORIG-LINEARIZE-ASSUMPTIONS-STACK (SETQ LINEARIZE-ASSUMPTIONS-STACK NIL)) NIL]) (CREATE-STACK1 [LAMBDA (N) (* kbr: "19-Oct-85 16:31") (LET (STK) (SETQ STK (for I from 1 to (ITIMES 2 N) collect NIL)) (for TAIL on STK by (QUOTE CDDR) until (NULL (CDDR TAIL)) do (RPLACA (CDDDR TAIL) TAIL)) STK]) (FARGN-MACRO [LAMBDA (TAIL) (* kbr: "20-Oct-85 13:40") (* (BM-NTH (CADR TAIL)  (CAR TAIL)) *) (COND ((FIXP (CADR TAIL)) (LIST (QUOTE CAR) (CELL (CADR TAIL) (CAR TAIL)))) (T (LIST (QUOTE BM-NTH) (CADR TAIL) (CAR TAIL]) (FN-SYMB-MACRO [LAMBDA (TAIL) (* kbr: "19-Oct-85 16:31") (SUBST (CAR TAIL) (QUOTE TERM) (QUOTE (COND ((NEQ (QUOTE QUOTE) (CAR (SETQ TEMP-TEMP TERM))) (CAR TEMP-TEMP)) (T (FN-SYMB0 (CADR TEMP-TEMP]) (HLOAD [LAMBDA (FILE) (* kbr: " 6-Jul-86 10:16") (* Horrible LOAD. *) (PROG (STREAM EXPR) (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT))) (until (EQ (SETQ EXPR (HREAD STREAM)) (QUOTE STOP)) do (EVAL EXPR)) (RETURN (CLOSEF STREAM]) (IPOSITION [LAMBDA (FILE N FLG) (* kbr: "19-Oct-85 16:31") (LET (PAIR) (COND ((NULL (SETQ PAIR (ASSOC FILE IPOSITION-ALIST))) (SETQ IPOSITION-ALIST (CONS (SETQ PAIR (CONS FILE 0)) IPOSITION-ALIST)))) (COND ((NULL N) (CDR PAIR)) (FLG (PROG1 (CDR PAIR) (RPLACD PAIR (IPLUS N (CDR PAIR))))) (T (PROG1 (CDR PAIR) (RPLACD PAIR N]) (ITERPRI [LAMBDA (FILE) (* kbr: "19-Oct-85 16:31") (IPOSITION FILE 0 NIL) (TERPRI FILE]) (ITERPRIN [LAMBDA (N FILE) (* kbr: "19-Oct-85 16:31") (for I from 1 to N do (ITERPRI FILE]) (ITERPRISPACES [LAMBDA (N FILE) (* kbr: "19-Oct-85 16:31") (ITERPRI FILE) (TABULATE N FILE]) (IPRIN1 [LAMBDA (X FILE) (* kbr: "19-Oct-85 16:31") (IPOSITION FILE (NCHARS X) T) (PRIN2 X FILE]) (IPRINC [LAMBDA (X FILE) (* kbr: "19-Oct-85 16:31") (IPOSITION FILE (NCHARS X) T) (PRIN1 X FILE]) (IPRINT [LAMBDA (X FILE) (* kbr: "19-Oct-85 16:31") (IPOSITION FILE (NCHARS X) NIL) (PRINT X FILE]) (ISPACES [LAMBDA (N FILE) (* kbr: "19-Oct-85 16:31") (COND ((ILEQ N 0) NIL) (T (IPOSITION FILE N T) (for I from 1 to N do (PRIN1 " " FILE]) (KILL-DEFINITION [LAMBDA (FN) (* kbr: "17-Nov-85 15:37") (PUTD FN NIL]) (LINEL [LAMBDA (FILE N) (* kbr: "19-Oct-85 16:31") (LINELENGTH N FILE]) (MAKE-LIB [LAMBDA (FILE) (* kbr: "30-Sep-86 14:05") (PROG (TEMP PROP-FILE FN-FILE FILE-PLIST REVERSED-LIB-PROPS) (SETQ REVERSED-LIB-PROPS (REVERSE LIB-PROPS)) (SETQ PROP-FILE (OPENSTREAM (EXTEND-FILE-NAME FILE (QUOTE LIB)) (QUOTE OUTPUT))) (PRINT (LIST (QUOTE INIT-LIB) (KWOTE LIB-PROPS) (KWOTE LIB-VARS)) PROP-FILE) (for VAR in LIB-VARS do (PRINT (LIST (QUOTE SETQ) VAR (KWOTE (GETTOPVAL VAR))) PROP-FILE)) (PRINT (LIST (QUOTE SETQ) (QUOTE LIB-ATOMS-WITH-PROPS) (KWOTE LIB-ATOMS-WITH-PROPS)) PROP-FILE) (PRINT (LIST (QUOTE SETQ) (QUOTE LIB-ATOMS-WITH-DEFS) (KWOTE LIB-ATOMS-WITH-DEFS)) PROP-FILE) (for ATM in LIB-ATOMS-WITH-PROPS do (HPRINT (LIST (QUOTE PUT1-LST) (KWOTE ATM) (KWOTE (for PROP in REVERSED-LIB-PROPS join (COND ((SETQ TEMP (MEMB PROP (GETPROPLIST ATM))) (LIST PROP (CADR TEMP))))))) PROP-FILE)) (for ATM in (REVERSE LIB-ATOMS-WITH-DEFS) do (HPRINT (LIST (QUOTE PUT1-LST) (KWOTE ATM) (KWOTE (LIST (QUOTE SEXPR) (LIST (QUOTE LAMBDA) (CADR (SETQ TEMP (GETPROP ATM (QUOTE SEXPR)))) (CADDR TEMP))))) PROP-FILE)) (PRINT (QUOTE STOP) PROP-FILE) (SETQ PROP-FILE (CLOSEF PROP-FILE)) (SETQ FILECOMS (FILECOMS FILE)) (SET FILECOMS (LIST (CONS (QUOTE FNS) (REVERSE LIB-ATOMS-WITH-DEFS)))) (SETQ FN-FILE (BCOMPL (MAKEFILE FILE (QUOTE NEW)))) (RETURN (LIST PROP-FILE FN-FILE]) (MATCH-MACRO [LAMBDA (TERM PAT) (* kbr: "19-Oct-85 16:31") (COND ((LISTP TERM) (LIST (QUOTE PROGN) (LIST (QUOTE SETQ) (QUOTE MATCH-TEMP) TERM) (MATCH1-MACRO (QUOTE MATCH-TEMP) PAT))) (T (MATCH1-MACRO TERM PAT]) (MATCH!-MACRO [LAMBDA (TERM PAT) (* kbr: "24-Oct-85 16:37") (LIST (QUOTE OR) (MATCH-MACRO TERM PAT) (QUOTE (ERROR "MATCH! failed!"]) (MATCH1-MACRO [LAMBDA (TERM PAT) (* kbr: "19-Oct-85 16:31") (LET (TEST-LST SETQ-LST) (MATCH2-MACRO TERM PAT) (LIST (QUOTE COND) (CONS (COND ((NULL TEST-LST) T) ((NULL (CDR TEST-LST)) (CAR TEST-LST)) (T (CONS (QUOTE AND) TEST-LST))) (NCONC1 SETQ-LST T]) (MATCH2-MACRO [LAMBDA (TERM PAT) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP PAT) (COND ((EQ PAT (QUOTE &)) NIL) ((OR (EQ PAT T) (EQ PAT NIL)) (PRIN1 "***** Attempt to smash T or NIL ignored *****" T) (TERPRI T) (SPACES 6 T) (PRIN2 (CONS (QUOTE BM-MATCH) MATCH-X) T) (ITERPRI T)) ((LITATOM PAT) (SETQ SETQ-LST (NCONC1 SETQ-LST (LIST (QUOTE SETQ) PAT TERM)))) (T (SETQ TEST-LST (NCONC1 TEST-LST (LIST (QUOTE EQUAL) PAT TERM)))))) ((EQ (QUOTE CONS) (CAR PAT)) (SETQ TEST-LST (NCONC1 TEST-LST (LIST (QUOTE LISTP) TERM))) (MATCH2-MACRO (LIST (QUOTE CAR) TERM) (CADR PAT)) (MATCH2-MACRO (LIST (QUOTE CDR) TERM) (CADDR PAT))) ((EQ (QUOTE QUOTE) (CAR PAT)) (COND ((LITATOM (CADR PAT)) (SETQ TEST-LST (NCONC1 TEST-LST (LIST (QUOTE EQ) (LIST (QUOTE QUOTE) (CADR PAT)) TERM)))) (T (SETQ TEST-LST (NCONC1 TEST-LST (LIST (QUOTE EQUAL) (LIST (QUOTE QUOTE) (CADR PAT)) TERM)))))) (T (COND ((NEQ (CAR PAT) (QUOTE LIST)) (SETQ PAT (CONS (QUOTE LIST) (CONS (LIST (QUOTE QUOTE) (CAR PAT)) (CDR PAT)))))) (for SUBPAT in (CDR PAT) do (SETQ TEST-LST (NCONC1 TEST-LST (LIST (QUOTE LISTP) TERM))) (MATCH2-MACRO (LIST (QUOTE CAR) TERM) SUBPAT) (SETQ TERM (LIST (QUOTE CDR) TERM))) (SETQ TEST-LST (NCONC1 TEST-LST (LIST (QUOTE EQ) TERM NIL]) (NOTE-LIB [LAMBDA (FILE) (* kbr: " 8-Nov-85 15:47") (PROG (FILE1 FILE2) (SETQ FILE1 (EXTEND-FILE-NAME FILE (QUOTE LIB))) (SETQ FILE2 (EXTEND-FILE-NAME FILE (QUOTE DCOM))) (COND ((BOUNDP (QUOTE LIB-FILE)) (KILL-LIB))) (RETURN (LIST (SETQ LIB-FILE (HLOAD FILE1)) (LOAD FILE2]) (BM-NTH [LAMBDA (N LIST) (* kbr: "19-Oct-85 18:37") (CAR (NTH LIST N]) (PREPARE-FOR-THE-NIGHT [LAMBDA NIL (* kbr: "19-Oct-85 16:31") NIL]) (SPELL-NUMBER [LAMBDA (N) (* kbr: "26-Oct-85 16:31") (SELECTQ N (0 (QUOTE ZERO)) (1 (QUOTE ONE)) (2 (QUOTE TWO)) (3 (QUOTE THREE)) (4 (QUOTE FOUR)) (5 (QUOTE FIVE)) (6 (QUOTE SIX)) (7 (QUOTE SEVEN)) (8 (QUOTE EIGHT)) (9 (QUOTE NINE)) (10 (QUOTE TEN)) N]) (SUB-PAIR [LAMBDA (L1 L2 X) (* kbr: " 6-Jul-86 10:21") (* * Substitution function. This is like  (SUBLIS (PAIRLIST L1 L2) X) *) (COND ((for Z in L2 as Y in L1 when (EQUAL Y X) thereis (PROGN (SETQ TEMP-TEMP Z) T)) TEMP-TEMP) ((NLISTP X) X) (T (CONS (SUB-PAIR L1 L2 (CAR X)) (SUB-PAIR L1 L2 (CDR X]) (UNIONQ [LAMBDA (LIST1 LIST2) (* kbr: "17-Nov-85 15:41") (PROG (ANSWER) (SETQ ANSWER LIST2) (for ELEMENT in LIST1 when (NOT (MEMB ELEMENT ANSWER)) do (push ANSWER ELEMENT)) (RETURN ANSWER]) ) (SETQ LEMMA-STACK (CREATE-LEMMA-STACK 10)) (SETQ LINEARIZE-ASSUMPTIONS-STACK (CREATE-LINEARIZE-ASSUMPTIONS-STACK 10)) (RPAQQ CODE-1-ACOMS ((* CODE-1-A *) (FNS *1*ADD1 *1*AND *1*CONS *1*COUNT *1*DIFFERENCE *1*EQUAL *1*FALSE *1*FALSEP *1*FIX *1*IMPLIES *1*LESSP *1*LISTP *1*LITATOM *1*MINUS *1*NEGATIVE-GUTS *1*NEGATIVEP *1*NLISTP *1*NOT *1*NUMBERP *1*OR *1*PACK *1*PLUS *1*QUOTIENT *1*REMAINDER *1*SUB1 *1*TIMES *1*TRUE *1*TRUEP *1*UNPACK *1*ZERO *1*ZEROP ABBREVIATIONP ABBREVIATIONP1 ACCEPTABLE-TYPE-PRESCRIPTION-LEMMAP ACCESS-ERROR ADD-AXIOM1 ADD-DCELL ADD-ELIM-LEMMA ADD-EQUATION ADD-EQUATIONS ADD-EQUATIONS-TO-POT-LST ADD-FACT ADD-GENERALIZE-LEMMA ADD-LEMMA ADD-LEMMA0 ADD-LESSP-ASSUMPTION-TO-POLY ADD-LINEAR-TERM ADD-LINEAR-VARIABLE ADD-LINEAR-VARIABLE1 ADD-LITERAL ADD-META-LEMMA ADD-NOT-EQUAL-0-ASSUMPTION-TO-POLY ADD-NOT-LESSP-ASSUMPTION-TO-POLY ADD-NUMBERP-ASSUMPTION-TO-POLY ADD-PROCESS-HIST ADD-REWRITE-LEMMA ADD-SHELL-ROUTINES ADD-SHELL0 ADD-SUB-FACT ADD-TERM-TO-POT-LST ADD-TERMS-TO-POT-LST ADD-TO-SET-EQ ADD-TYPE-SET-LEMMAS ALL-ARGLISTS ALL-FNNAMES ALL-FNNAMES-LST ALL-FNNAMES1 ALL-FNNAMES1-EVG ALL-INSERTIONS ALL-PATHS ALL-PERMUTATIONS ALL-PICKS ALL-SUBSEQUENCES ALL-VARS ALL-VARS-BAG ALL-VARS-BAG1 ALL-VARS-LST ALL-VARS1 ALMOST-SUBSUMES ALMOST-SUBSUMES-LOOP ALMOST-VALUEP ALMOST-VALUEP1 APPLY-HINTS APPLY-INDUCT-HINT APPLY-USE-HINT ARG1-IN-ARG2-UNIFY-SUBST ARGN0 ARITY ASSOC-OF-APPEND ASSUME-TRUE-FALSE ATTEMPT-TO-REWRITE-RECOGNIZER))) (* CODE-1-A *) (DEFINEQ (*1*ADD1 [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (FIXP X) (LESSEQP 0 X)) (ADD1 X)) (T 1]) (*1*AND [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (*1*IF X (*1*IF Y *1*T *1*F) *1*F]) (*1*CONS [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (CONS X Y]) (*1*COUNT [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP X) (COND ((EQ X *1*T) 0) ((EQ X *1*F) 0) ((LITATOM X) (ADD1 (*1*COUNT (DTACK-0-ON-END (CHCON X))))) ((LESSP X 0) (ADD1 (MINUS X))) (T X))) ((EQ *1*SHELL-QUOTE-MARK (CAR X)) (COND ((MEMB (CADR X) *1*BTM-OBJECTS) 0) (T (ADD1 (for ARG in (CDDR X) sum (*1*COUNT ARG)))))) (T (ADD1 (PLUS (*1*COUNT (CAR X)) (*1*COUNT (CDR X]) (*1*DIFFERENCE [LAMBDA (I J) (* kbr: "19-Oct-85 16:31") (COND ((GREATERP (SETQ I (*1*FIX I)) (SETQ J (*1*FIX J))) (DIFFERENCE I J)) (T 0]) (*1*EQUAL [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (COND ((EQUAL X Y) *1*T) (T *1*F]) (*1*FALSE [LAMBDA NIL (* kbr: "19-Oct-85 16:31") *1*F]) (*1*FALSEP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((EQ X *1*F) *1*T) (T *1*F]) (*1*FIX [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (FIXP X) (LESSEQP 0 X)) X) (T 0]) (*1*IMPLIES [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (*1*IF X (*1*IF Y *1*T *1*F) *1*T]) (*1*LESSP [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (COND ((LESSP (*1*FIX X) (*1*FIX Y)) *1*T) (T *1*F]) (*1*LISTP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (LISTP X) (NEQ (CAR X) *1*SHELL-QUOTE-MARK)) *1*T) (T *1*F]) (*1*LITATOM [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((OR (AND (LITATOM X) (NEQ X *1*T) (NEQ X *1*F)) (AND (LISTP X) (EQ (CAR X) *1*SHELL-QUOTE-MARK) (EQ (CADR X) (QUOTE PACK)))) *1*T) (T *1*F]) (*1*MINUS [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (FIXP X) (LESSP 0 X)) (MINUS X)) (T (LIST *1*SHELL-QUOTE-MARK (QUOTE MINUS) 0]) (*1*NEGATIVE-GUTS [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (FIXP X) (LESSP X 0)) (MINUS X)) (T 0]) (*1*NEGATIVEP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((OR (AND (FIXP X) (LESSP X 0)) (AND (LISTP X) (EQ (CAR X) *1*SHELL-QUOTE-MARK) (EQ (CADR X) (QUOTE MINUS)))) *1*T) (T *1*F]) (*1*NLISTP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (LISTP X) (NEQ (CAR X) *1*SHELL-QUOTE-MARK)) *1*F) (T *1*T]) (*1*NOT [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (*1*IF X *1*F *1*T]) (*1*NUMBERP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (FIXP X) (LESSEQP 0 X)) *1*T) (T *1*F]) (*1*OR [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (*1*IF X *1*T (*1*IF Y *1*T *1*F]) (*1*PACK [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (LEGAL-CHAR-CODE-SEQ X) (EQUAL 0 (CDR (LAST X)))) (TP-IMPLODE (for TAIL on X until (NLISTP TAIL) collect (CHARACTER (CAR TAIL))))) (T (LIST *1*SHELL-QUOTE-MARK (QUOTE PACK) X]) (*1*PLUS [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (PLUS (*1*FIX X) (*1*FIX Y]) (*1*QUOTIENT [LAMBDA (I J) (* kbr: "19-Oct-85 16:31") (COND ((EQUAL 0 (SETQ J (*1*FIX J))) 0) (T (QUOTIENT (*1*FIX I) J]) (*1*REMAINDER [LAMBDA (I J) (* kbr: "19-Oct-85 16:31") (COND ((EQUAL 0 (SETQ J (*1*FIX J))) (*1*FIX I)) (T (REMAINDER (*1*FIX I) J]) (*1*SUB1 [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (FIXP X) (LESSP 0 X)) (SUB1 X)) (T 0]) (*1*TIMES [LAMBDA (I J) (* kbr: "19-Oct-85 16:31") (TIMES (*1*FIX I) (*1*FIX J]) (*1*TRUE [LAMBDA NIL (* kbr: "19-Oct-85 16:31") *1*T]) (*1*TRUEP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((EQ X *1*T) *1*T) (T *1*F]) (*1*UNPACK [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((AND (LITATOM X) (NEQ X *1*T) (NEQ X *1*F)) (LET ((TEMP (CHCON X))) (RPLACD (LAST TEMP) 0) TEMP)) ((AND (LISTP X) (EQ *1*SHELL-QUOTE-MARK (CAR X)) (EQ (CADR X) (QUOTE PACK))) (CADDR X)) (T 0]) (*1*ZERO [LAMBDA NIL (* kbr: "19-Oct-85 16:31") 0]) (*1*ZEROP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((FIXP X) (COND ((LESSP X 1) *1*T) (T *1*F))) (T *1*T]) (ABBREVIATIONP [LAMBDA (VARS TERM) (* kbr: "19-Oct-85 16:31") (* Suppose VARS is the bag of vars in a term LHS.  Then we say LHS=TERM is an abbreviation if the bag of vars occurring in TERM is  a subbag of VARS and TERM contains no IF, AND, OR, NOT, or IMPLIES.  The property of VARS that we actually check is that the number of occurrences  of vars in TERM is no greater than the length of VARS.  *) (LET ((ANS VARS)) (ABBREVIATIONP1 TERM]) (ABBREVIATIONP1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (COND ((NLISTP ANS) NIL) (T (SETQ ANS (CDR ANS)) T))) ((FQUOTEP TERM) T) ((MEMB (FFN-SYMB TERM) (QUOTE (IF AND OR NOT IMPLIES))) NIL) (T (for X in (FARGS TERM) always (ABBREVIATIONP1 X]) (ACCEPTABLE-TYPE-PRESCRIPTION-LEMMAP [LAMBDA (HYPS CONCL) (* kbr: "20-Oct-85 19:47") (* If (IMPLIES HYPS CONCL) is a type prescription lemma for some function  symbol, compute the function symbol and return the function symbol consed onto  the type prescription described by the lemma.  Otherwise return NIL. *) (PROG (TERM RECOG CLAUSES VARS NEGFLG CONST ARG VAR) (* Set TERM to the IF form of  (IMPLIES HYP CONCL) . *) (SETQ TERM (EXPAND-NON-REC-FNS (FCONS-TERM* (QUOTE IF) (CONJOIN HYPS T) (FCONS-TERM* (QUOTE IF) CONCL TRUE FALSE) TRUE))) (* Acceptable type prescription lemmas  must contain exactly one function  symbol other than IF, EQUAL,  recognizers and singleton  constructors. *) (COND ((NOT (IEQP 1 (for FN in (ALL-FNNAMES TERM) count (AND (NOT (ASSOC FN RECOGNIZER-ALIST)) (NOT (  SINGLETON-CONSTRUCTOR-TO-RECOGNIZER FN)))))) (RETURN NIL))) (* Consider a clause in the clausification of a type prescription lemma.  You should be able to divide the literals into two sets.  The first set should consist entirely of recognizers applied to some term  (fn v1 ... vn) or of negations of recognizers applied to such a term.  The second set should consist entirely of equations between that term and some  of the variables vi. Actually, some literals are of the form  (EQUAL term (TRUE)) but these are equivalent to  (TRUEP term) . *) (SETQ CLAUSES (CLAUSIFY TERM)) (* We now map over CLAUSES and replace all atoms of the form  (EQUAL & (singleton)) by (singletonp &) just to reduce the number of cases.  *) (SETQ CLAUSES (for CL in CLAUSES collect (for LIT in CL collect (PROGN (SETQ NEGFLG (BM-MATCH LIT (NOT LIT))) (SETQ LIT (COND ((OR (AND (BM-MATCH LIT (EQUAL TERM CONST)) (NVARIABLEP CONST) (SETQ TEMP-TEMP (  SINGLETON-CONSTRUCTOR-TO-RECOGNIZER (FN-SYMB CONST)))) (AND (BM-MATCH LIT (EQUAL CONST TERM)) (NVARIABLEP CONST) (SETQ TEMP-TEMP (  SINGLETON-CONSTRUCTOR-TO-RECOGNIZER (FN-SYMB CONST))))) (FCONS-TERM* TEMP-TEMP TERM)) (T LIT))) (COND (NEGFLG (FCONS-TERM* (QUOTE NOT) LIT)) (T LIT)))))) (* We now try to find the function that this supposed type prescription is  about. We look at the first literal of the first clause and it had better be a  recognizer applied to something, a NOT recognizer applied to something, or the  equality of a non variable something and another term.  If we can find such a something, we set it to TERM.  Otherwise, we say this is not a type prescription lemma.  *) (COND ((NOT (AND (LISTP CLAUSES) (LISTP (CAR CLAUSES)) (OR (AND (BM-MATCH (CAAR CLAUSES) (NOT (LIST RECOG TERM))) (ASSOC RECOG RECOGNIZER-ALIST)) (AND (BM-MATCH (CAAR CLAUSES) (LIST RECOG TERM)) (ASSOC RECOG RECOGNIZER-ALIST)) (AND (BM-MATCH (CAAR CLAUSES) (EQUAL TERM &)) (NVARIABLEP TERM)) (AND (BM-MATCH (CAAR CLAUSES) (EQUAL & TERM)) (NVARIABLEP TERM))))) (RETURN NIL))) (* TERM must be a function application  to distinct variables.  *) (COND ((NOT (AND (NVARIABLEP TERM) (for ARG in (SARGS TERM) always (VARIABLEP ARG)) (NO-DUPLICATESP (SARGS TERM)))) (RETURN NIL))) (* Every literal of every clause must be a recognizer applied to TERM, the  negation of a recognizer applied to TERM, or the equality between TERM and one  of the vars in its arglist. As a side-effect of this check, we collect in VARS  all of the variables equated to TERM. *) (COND ((NOT (for CL in CLAUSES always (for LIT in CL always (OR (AND (BM-MATCH LIT (LIST RECOG ARG)) (ASSOC RECOG RECOGNIZER-ALIST) (EQUAL ARG TERM)) (AND (BM-MATCH LIT (NOT (LIST RECOG ARG))) (ASSOC RECOG RECOGNIZER-ALIST) (EQUAL ARG TERM)) (AND (BM-MATCH LIT (EQUAL ARG VAR)) (EQUAL ARG TERM) (MEMB VAR (SARGS TERM)) (SETQ VARS (ADD-TO-SET VAR VARS))) (AND (BM-MATCH LIT (EQUAL VAR ARG)) (EQUAL ARG TERM) (MEMB VAR (SARGS TERM)) (SETQ VARS (ADD-TO-SET VAR VARS))))))) (RETURN NIL))) (* Every clause must contain the same set of equations of TERM with vars.  Since VARS contains all of the vars ever equated with TERM in any clause, all  that remains is to make sure that every clause contains an equation with each  var in VARS. *) (COND ((NOT (for VAR in VARS always (for CL in CLAUSES always (OR (MEMBER (FCONS-TERM* (QUOTE EQUAL) TERM VAR) CL) (MEMBER (FCONS-TERM* (QUOTE EQUAL) VAR TERM) CL))))) (RETURN NIL))) (* So we believe that (IMPLIES HYP CONCL) is a type prescription lemma.  Return the function symbol of TERM, consed onto the type prescription.  The type prescription is itself a cons of the type bits and flags indicating  which args are in VARS. The type bits are obtained by anding together the  disjunction of recognizers in each clause.  *) (RETURN (CONS (FN-SYMB TERM) (CONS (for CL in CLAUSES bind (LOOP-ANS _ -1) do (SETQ LOOP-ANS (LOGAND LOOP-ANS (for LIT in CL bind (LOOP-ANS _ 0) when (NEQ (FN-SYMB LIT) (QUOTE EQUAL)) do (SETQ LOOP-ANS (LOGOR LOOP-ANS (COND ((BM-MATCH LIT (NOT LIT)) (LOGNOT (CDR (SASSOC (FN-SYMB LIT) RECOGNIZER-ALIST)))) (T (CDR (SASSOC (FN-SYMB LIT) RECOGNIZER-ALIST)))))) finally (RETURN LOOP-ANS)))) finally (RETURN LOOP-ANS)) (for V in (SARGS TERM) collect (COND ((MEMB V VARS) T) (T NIL]) (ACCESS-ERROR [LAMBDA (REC) (* kbr: "19-Oct-85 16:31") (ERROR1 (PQUOTE (PROGN ATTEMPT TO USE A RECORD OF THE WRONG TYPE (!PPR REC NIL))) (BINDINGS (QUOTE REC) REC) (QUOTE HARD]) (ADD-AXIOM1 [LAMBDA (NAME TYPES TERM) (* kbr: "19-Oct-85 16:31") (* Note that this function is not really a subroutine of ADD-AXIOM which must  check that the term is a legal axiom of the types requested and then set up for  an event. This function is used by ADD-SHELL0 and the boot strapping to add  axioms without creating events. If the system were static those calls of  ADD-AXIOM1 could be replaced by ADD-LEMMA0 since we know the lemmas we add are  always acceptable. However, we still run the acceptability checks just in case  we someday change the criteria for acceptance but forget to change the built in  additions of axioms. *) (CHK-ACCEPTABLE-LEMMA NAME TYPES TERM) (ADD-LEMMA0 NAME TYPES TERM]) (ADD-DCELL [LAMBDA (NAME *1*NAME EXPR) (* kbr: "19-Oct-85 16:31") (ADD-FACT NAME (QUOTE LISP-CODE) *1*NAME) (ADD-FACT *1*NAME (QUOTE DCELL) EXPR]) (ADD-ELIM-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "20-Oct-85 15:45") TYPE (LET (HYPS CONCL REWRITE-RULE DESTS) (SETQ TEMP-TEMP (UNPRETTYIFY TERM)) (SETQ HYPS (CAR (CAR TEMP-TEMP))) (SETQ CONCL (CDR (CAR TEMP-TEMP))) (SETQ DESTS (DESTRUCTORS (LIST (ARGN CONCL 1)))) (SETQ REWRITE-RULE (CREATE-REWRITE-RULE NAME HYPS CONCL NIL)) (for X in DESTS do (ADD-FACT (FN-SYMB X) (QUOTE ELIMINATE-DESTRUCTORS-SEQ) REWRITE-RULE) (ADD-FACT (FN-SYMB X) (QUOTE ELIMINATE-DESTRUCTORS-DESTS) (CONS X (REMOVE X DESTS)))) NIL]) (ADD-EQUATION [LAMBDA (EQUATION POT-LST) (* kbr: "22-Oct-85 14:08") (* This function returns an EQ POT-LST  in the event that EQUATION caused  nothing to change. *) (LET (ADD-EQUATION-ANS TO-DO-NEXT NEW-POT-- NEW-POT-+) (COND ((OR (NULL POT-LST) (NOT (TERM-ORDER (fetch (LINEAR-POT VAR) of (CAR POT-LST)) (FIRST-VAR EQUATION)))) (SETQ ADD-EQUATIONS-TO-DO (COND ((SETQ TEMP-TEMP (CANCEL-POSITIVE EQUATION)) (LIST TEMP-TEMP)) (T NIL))) (CONS (COND ((GREATERP (FIRST-COEFFICIENT EQUATION) 0) (create LINEAR-POT VAR _ (FIRST-VAR EQUATION) POSITIVES _ (LIST EQUATION))) (T (create LINEAR-POT VAR _ (FIRST-VAR EQUATION) NEGATIVES _ (LIST EQUATION)))) POT-LST)) ((EQUAL (fetch (LINEAR-POT VAR) of (CAR POT-LST)) (FIRST-VAR EQUATION)) (COND ((POLY-MEMBER EQUATION (COND ((GREATERP (FIRST-COEFFICIENT EQUATION) 0) (fetch (LINEAR-POT POSITIVES) of (CAR POT-LST))) (T (fetch (LINEAR-POT NEGATIVES) of (CAR POT-LST))))) (SETQ ADD-EQUATIONS-TO-DO NIL) POT-LST) (T (SETQ ADD-EQUATIONS-TO-DO (for EQUATION1 in (COND ((GREATERP (FIRST-COEFFICIENT EQUATION) 0) (fetch (LINEAR-POT NEGATIVES) of (CAR POT-LST))) (T (fetch (LINEAR-POT POSITIVES) of (CAR POT-LST)))) bind TEMP unless (OR (TO-BE-IGNOREDP EQUATION1) (NULL (SETQ TEMP (CANCEL EQUATION EQUATION1)))) collect TEMP)) (COND ((SETQ TEMP-TEMP (CANCEL-POSITIVE EQUATION)) (SETQ ADD-EQUATIONS-TO-DO (CONS TEMP-TEMP ADD-EQUATIONS-TO-DO)))) (CONS (COND ((GREATERP (FIRST-COEFFICIENT EQUATION) 0) (create LINEAR-POT VAR _ (fetch (LINEAR-POT VAR) of (CAR POT-LST)) POSITIVES _ (CONS EQUATION (fetch (LINEAR-POT POSITIVES) of (CAR POT-LST))) NEGATIVES _ (fetch (LINEAR-POT NEGATIVES) of (CAR POT-LST)))) (T (create LINEAR-POT VAR _ (fetch (LINEAR-POT VAR) of (CAR POT-LST)) POSITIVES _ (fetch (LINEAR-POT POSITIVES) of (CAR POT-LST)) NEGATIVES _ (CONS EQUATION (fetch (LINEAR-POT NEGATIVES) of (CAR POT-LST)))))) (CDR POT-LST))))) (T (SETQ ADD-EQUATION-ANS (ADD-EQUATION EQUATION (CDR POT-LST))) (SETQ TO-DO-NEXT NIL) (SETQ NEW-POT-+ (fetch (LINEAR-POT POSITIVES) of (CAR POT-LST))) (SETQ NEW-POT-- (fetch (LINEAR-POT NEGATIVES) of (CAR POT-LST))) (for EQUATION in ADD-EQUATIONS-TO-DO do (COND ((EQUAL (fetch (LINEAR-POT VAR) of (CAR POT-LST)) (FIRST-VAR EQUATION)) (for EQUATION1 in (COND ((GREATERP (FIRST-COEFFICIENT EQUATION) 0) (COND ((POLY-MEMBER EQUATION NEW-POT-+) NIL) (T (COND ((SETQ TEMP-TEMP (CANCEL-POSITIVE EQUATION)) (SETQ TO-DO-NEXT (CONS TEMP-TEMP TO-DO-NEXT) ))) (SETQ NEW-POT-+ (CONS EQUATION NEW-POT-+)) NEW-POT--))) (T (COND ((POLY-MEMBER EQUATION NEW-POT--) NIL) (T (SETQ NEW-POT-- (CONS EQUATION NEW-POT--)) NEW-POT-+)))) bind TEMP unless (OR (TO-BE-IGNOREDP EQUATION1) (NULL (SETQ TEMP (CANCEL EQUATION EQUATION1)))) do (SETQ TO-DO-NEXT (CONS TEMP TO-DO-NEXT)))) (T (SETQ TO-DO-NEXT (CONS EQUATION TO-DO-NEXT))))) (SETQ ADD-EQUATIONS-TO-DO TO-DO-NEXT) (COND ((AND (EQ ADD-EQUATION-ANS (CDR POT-LST)) (EQ (fetch (LINEAR-POT POSITIVES) of (CAR POT-LST)) NEW-POT-+) (EQ (fetch (LINEAR-POT NEGATIVES) of (CAR POT-LST)) NEW-POT--)) (* This is where we make sure we  return an EQ POT-LST if nothing  happened. *) POT-LST) (T (CONS (create LINEAR-POT VAR _ (fetch (LINEAR-POT VAR) of (CAR POT-LST)) POSITIVES _ NEW-POT-+ NEGATIVES _ NEW-POT--) ADD-EQUATION-ANS]) (ADD-EQUATIONS [LAMBDA (EQUATIONS POT-LST) (* kbr: "19-Oct-85 16:31") (LET (NEW-EQUATIONS ADD-EQUATIONS-TO-DO) (SETQ EQUATIONS (for EQUATION in EQUATIONS when (COND ((IMPOSSIBLE-POLYP EQUATION) (SETQ LINEAR-ASSUMPTIONS (fetch (POLY ASSUMPTIONS) of EQUATION)) (SETQ LEMMAS-USED-BY-LINEAR (UNIONQ (fetch (POLY LEMMAS) of EQUATION) (fetch (POLY LITERALS) of EQUATION))) (RETFROM (QUOTE ADD-EQUATIONS) (QUOTE CONTRADICTION))) ((TRUE-POLYP EQUATION) NIL) (T T)) collect EQUATION)) (while EQUATIONS do (for EQUATION in EQUATIONS do (SETQ POT-LST (ADD-EQUATION EQUATION POT-LST)) (SETQ NEW-EQUATIONS (NCONC ADD-EQUATIONS-TO-DO NEW-EQUATIONS)) ) (SETQ EQUATIONS NEW-EQUATIONS) (SETQ NEW-EQUATIONS NIL)) POT-LST]) (ADD-EQUATIONS-TO-POT-LST [LAMBDA (POLY-LST POT-LST ALL-NEW-FLG) (* kbr: "24-Oct-85 14:24") (PROG (NEW-POT-LST NEW-VARS LST) (SETQ NEW-POT-LST (ADD-EQUATIONS POLY-LST POT-LST)) (COND ((EQ NEW-POT-LST (QUOTE CONTRADICTION)) (RETURN (QUOTE CONTRADICTION)))) TOP (SETQ NEW-VARS (for X in NEW-POT-LST when (AND (NOT (VARIABLEP (fetch (LINEAR-POT VAR) of X))) (OR ALL-NEW-FLG (NOT (for POT in POT-LST thereis (EQUAL (fetch (LINEAR-POT VAR) of POT) (fetch (LINEAR-POT VAR) of X)))))) collect (fetch (LINEAR-POT VAR) of X))) (SETQ ALL-NEW-FLG NIL) (COND ((NULL NEW-VARS) (RETURN NEW-POT-LST))) (SETQ POT-LST NEW-POT-LST) (for VAR in NEW-VARS do (for LEMMA in (GETPROP (FN-SYMB VAR) (QUOTE LINEAR-LEMMAS)) unless (DISABLEDP (fetch (LINEAR-LEMMA NAME) of LEMMA)) do (* We will rewrite the conclusion of the linear lemma and rewrite the hyps to  relieve them. This will generate both a list of lemmas used and some linear  assumptions. They will be collected in the frames pushed here and will be  popped and smashed into the polys we add to the pot should we succeed.  *) (PUSH-LEMMA-FRAME) (PRINT-TO-DISPLAY (QUOTE LINEAR) NIL NIL) (PUSH-LINEARIZE-ASSUMPTIONS-FRAME) (COND ((AND (ONE-WAY-UNIFY (fetch (LINEAR-LEMMA MAX-TERM) of LEMMA) VAR) (LET ((SIMPLIFY-CLAUSE-POT-LST NEW-POT-LST)) (RELIEVE-HYPS (fetch (LINEAR-LEMMA HYPS) of LEMMA) (fetch (LINEAR-LEMMA NAME) of LEMMA))) (SETQ LST (LET ((SIMPLIFY-CLAUSE-POT-LST NEW-POT-LST)) (LINEARIZE (REWRITE-LINEAR-CONCL (fetch (LINEAR-LEMMA CONCL) of LEMMA)) T))) (NULL (CDR LST)) (for POLY in (CAR LST) never (for PAIR1 in (fetch (POLY ALIST) of POLY) thereis (for POT in POT-LST always (AND (NOT (EQUAL (CAR PAIR1) (fetch (LINEAR-POT VAR) of POT))) (GREATEREQP (FORM-COUNT (CAR PAIR1)) (FORM-COUNT (fetch (LINEAR-POT VAR) of POT))) (WORSE-THAN-OR-EQUAL (CAR PAIR1) (fetch (LINEAR-POT VAR) of POT))))))) (for POLY in (CAR LST) bind (LEMMAS _ (ADD-TO-SET (fetch (LINEAR-LEMMA NAME) of LEMMA) (POP-LEMMA-FRAME))) AND (HYPS _ (POP-LINEARIZE-ASSUMPTIONS-FRAME)) do (replace (POLY LEMMAS) of POLY with LEMMAS) (replace (POLY ASSUMPTIONS) of POLY with (UNION-EQUAL HYPS (fetch (POLY ASSUMPTIONS) of POLY)))) (SETQ NEW-POT-LST (ADD-EQUATIONS (CAR LST) NEW-POT-LST)) (COND ((EQ NEW-POT-LST (QUOTE CONTRADICTION)) (RETFROM (QUOTE ADD-EQUATIONS-TO-POT-LST) (QUOTE CONTRADICTION))))) (T (POP-LEMMA-FRAME) (POP-LINEARIZE-ASSUMPTIONS-FRAME))))) (GO TOP]) (ADD-FACT [LAMBDA (ATM PROP VAL) (* kbr: "19-Oct-85 16:31") (COND (ATM (GUARANTEE-CITIZENSHIP ATM))) (ADD-SUB-FACT ATM PROP VAL NIL NIL]) (ADD-GENERALIZE-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "19-Oct-85 16:31") TYPE (ADD-FACT NIL (QUOTE GENERALIZE-LEMMAS) (create GENERALIZE-LEMMA NAME _ NAME TERM _ TERM]) (ADD-LEMMA [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (IPRINT (QUOTE (ADD-LEMMA IS UNDEFINED. USE EITHER ADD-AXIOM OR PROVE-LEMMA.)) T]) (ADD-LEMMA0 [LAMBDA (NAME TYPES TERM) (* kbr: "17-Nov-85 15:45") (GUARANTEE-CITIZENSHIP NAME) (SETQ TYPES (SCRUNCH TYPES)) (SETQ TERM (TRANSLATE TERM)) (for TYPE in TYPES do (APPLY* (PACK (LIST (QUOTE ADD-) (COND ((LISTP TYPE) (CAR TYPE)) (T TYPE)) (QUOTE -LEMMA))) NAME TYPE TERM]) (ADD-LESSP-ASSUMPTION-TO-POLY [LAMBDA (X Y POLY) (* kbr: "19-Oct-85 16:31") (* We add the assumption  (LESSP X Y) to POLY.  See the comment in  ADD-NUMBERP-ASSUMPTION-TO-POLY.  *) (PROG (TEMP TERM) (SETQ TEMP (TYPE-SET (SETQ TERM (FCONS-TERM* (QUOTE LESSP) X Y)))) (COND ((IEQP TEMP TYPE-SET-TRUE) NIL) ((IEQP TEMP TYPE-SET-FALSE) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((AND HEURISTIC-TYPE-ALIST (IEQP (LET ((TYPE-ALIST HEURISTIC-TYPE-ALIST)) (TYPE-SET TERM)) TYPE-SET-FALSE)) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((SETQ TEMP-TEMP (for LIT in LITS-THAT-MAY-BE-ASSUMED-FALSE when (COMPLEMENTARYP TERM LIT) do (RETURN LIT))) (replace (POLY LEMMAS) of POLY with (ADD-TO-SET-EQ TEMP-TEMP (fetch (POLY LEMMAS) of POLY)))) (T (replace (POLY ASSUMPTIONS) of POLY with (ADD-TO-SET TERM (fetch (POLY ASSUMPTIONS) of POLY))))) (RETURN POLY]) (ADD-LINEAR-TERM [LAMBDA (TERM PARITY POLY) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (ADD-LINEAR-VARIABLE TERM PARITY POLY)) ((FQUOTEP TERM) (COND ((AND (FIXP (CADR TERM)) (GREATERP (CADR TERM) -1)) (COND ((EQ PARITY (QUOTE POSITIVE)) (replace (POLY CONSTANT) of POLY with (PLUS (fetch (POLY CONSTANT) of POLY) (CADR TERM)))) (T (replace (POLY CONSTANT) of POLY with (DIFFERENCE (fetch (POLY CONSTANT) of POLY) (CADR TERM)))))))) (T (SELECTQ (FFN-SYMB TERM) (ADD1 (replace (POLY CONSTANT) of POLY with (COND ((EQ PARITY (QUOTE POSITIVE)) (ADD1 (fetch (POLY CONSTANT) of POLY))) (T (SUB1 (fetch (POLY CONSTANT) of POLY))))) (ADD-LINEAR-TERM (FARGN TERM 1) PARITY POLY)) (ZERO NIL) (SUB1 (COND ((EQ PARITY (QUOTE POSITIVE)) (replace (POLY CONSTANT) of POLY with (SUB1 (fetch (POLY CONSTANT) of POLY))) (ADD-LINEAR-TERM (FARGN TERM 1) PARITY POLY)) (T (ADD-NOT-LESSP-ASSUMPTION-TO-POLY (FARGN TERM 1) (QUOTE (QUOTE 1)) POLY) (replace (POLY CONSTANT) of POLY with (ADD1 (fetch (POLY CONSTANT) of POLY))) (ADD-LINEAR-TERM (FARGN TERM 1) PARITY POLY)))) (PLUS (ADD-LINEAR-TERM (FARGN TERM 2) PARITY POLY) (ADD-LINEAR-TERM (FARGN TERM 1) PARITY POLY)) (DIFFERENCE (COND ((EQ PARITY (QUOTE POSITIVE)) (ADD-LINEAR-TERM (FARGN TERM 2) (QUOTE NEGATIVE) POLY) (ADD-LINEAR-TERM (FARGN TERM 1) PARITY POLY)) (T (ADD-NOT-LESSP-ASSUMPTION-TO-POLY (FARGN TERM 1) (FARGN TERM 2) POLY) (ADD-LINEAR-TERM (FARGN TERM 2) (QUOTE POSITIVE) POLY) (ADD-LINEAR-TERM (FARGN TERM 1) PARITY POLY)))) (ADD-LINEAR-VARIABLE TERM PARITY POLY)))) POLY]) (ADD-LINEAR-VARIABLE [LAMBDA (VAR PARITY POLY) (* kbr: "19-Oct-85 16:31") (LET (N TERM) (COND ((AND (BM-MATCH VAR (TIMES N TERM)) (QUOTEP N) (FIXP (CADR N)) (GREATERP (CADR N) -1)) (COND ((LOGSUBSETP TYPE-SET-NUMBERS (TYPE-SET TERM)) (replace (POLY ALIST) of POLY with (ADD-LINEAR-VARIABLE1 (CADR N) TERM PARITY (fetch (POLY ALIST) of POLY)))))) ((LOGSUBSETP TYPE-SET-NUMBERS (TYPE-SET VAR)) (replace (POLY ALIST) of POLY with (ADD-LINEAR-VARIABLE1 1 VAR PARITY (fetch (POLY ALIST) of POLY))))) POLY]) (ADD-LINEAR-VARIABLE1 [LAMBDA (N VAR PARITY ALIST) (* kbr: "20-Oct-85 15:47") (COND ((NLISTP ALIST) (CONS (CONS VAR (COND ((EQ PARITY (QUOTE POSITIVE)) N) (T (MINUS N)))) NIL)) ((TERM-ORDER VAR (CAAR ALIST)) (COND ((EQUAL VAR (CAAR ALIST)) (COND ((EQ PARITY (QUOTE POSITIVE)) (RPLACD (CAR ALIST) (PLUS N (CDR (CAR ALIST))))) (T (RPLACD (CAR ALIST) (DIFFERENCE (CDR (CAR ALIST)) N)))) ALIST) (T (RPLACD ALIST (ADD-LINEAR-VARIABLE1 N VAR PARITY (CDR ALIST)))))) (T (CONS (CONS VAR (COND ((EQ PARITY (QUOTE POSITIVE)) N) (T (MINUS N)))) ALIST]) (ADD-LITERAL [LAMBDA (LIT CL AT-END-FLG) (* kbr: "19-Oct-85 16:31") (* We assume that LIT has been subjected to NEGATE-LIT or PEGATE-LIT before  passed to ADD-LITERAL, and that CL is the result of previous such ADD-LITERALS.  Thus, we make the trivial checks that LIT is neither T nor F, but do not use a  full blown FALSE-NONFALSEP. *) (COND ((EQUAL LIT FALSE) CL) ((EQUAL LIT TRUE) TRUE-CLAUSE) ((EQUAL CL TRUE-CLAUSE) TRUE-CLAUSE) ((for LIT2 in CL thereis (COMPLEMENTARYP LIT LIT2)) TRUE-CLAUSE) ((MEMBER LIT CL) CL) (AT-END-FLG (APPEND CL (LIST LIT))) (T (CONS LIT CL]) (ADD-META-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "19-Oct-85 16:31") (LET (FN) (BM-MATCH TERM (IMPLIES & (AND (EQUAL & (MEANING (LIST FN &) &)) &))) (for X in (CDR TYPE) do (ADD-FACT X (QUOTE LEMMAS) (create REWRITE-RULE NAME _ NAME CONCL _ (GETPROP FN (QUOTE LISP-CODE]) (ADD-NOT-EQUAL-0-ASSUMPTION-TO-POLY [LAMBDA (TERM POLY) (* kbr: "19-Oct-85 16:31") (* We add the assumption  (NOT (EQUAL TERM 0)) to POLY.  See the comment in  ADD-NUMBERP-ASSUMPTION-TO-POLY.  *) (LET (X Y TEMP EQUALITY) (COND ((BM-MATCH TERM (DIFFERENCE X Y)) (ADD-LESSP-ASSUMPTION-TO-POLY Y X POLY)) ((EQUAL TERM ZERO) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE)) POLY) ((OR (BM-MATCH TERM (ADD1 &)) (AND (QUOTEP TERM) (NOT (EQUAL (CADR TERM) 0)))) POLY) (T (SETQ EQUALITY (FCONS-TERM* (QUOTE EQUAL) TERM ZERO)) (SETQ TEMP (TYPE-SET EQUALITY)) (COND ((IEQP TEMP TYPE-SET-TRUE) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((IEQP TEMP TYPE-SET-FALSE) NIL) ((AND HEURISTIC-TYPE-ALIST (IEQP (LET ((TYPE-ALIST HEURISTIC-TYPE-ALIST)) (TYPE-SET EQUALITY)) TYPE-SET-TRUE)) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((SETQ TEMP-TEMP (MEMBER EQUALITY LITS-THAT-MAY-BE-ASSUMED-FALSE)) (replace (POLY LEMMAS) of POLY with (ADD-TO-SET-EQ (CAR TEMP-TEMP) (fetch (POLY LEMMAS) of POLY)))) (T (replace (POLY ASSUMPTIONS) of POLY with (ADD-TO-SET (FCONS-TERM* (QUOTE NOT) EQUALITY) (fetch (POLY ASSUMPTIONS) of POLY))))) POLY]) (ADD-NOT-LESSP-ASSUMPTION-TO-POLY [LAMBDA (X Y POLY) (* kbr: "19-Oct-85 16:31") (* We add the assumption  (NOT (LESSP X Y)) to POLY.  See the comment in  ADD-NUMBERP-ASSUMPTION-TO-POLY.  *) (PROG (TEMP TERM) (COND ((EQUAL Y (QUOTE (QUOTE 1))) (COND ((IEQP (TYPE-SET X) TYPE-SET-NUMBERS) (RETURN (ADD-NOT-EQUAL-0-ASSUMPTION-TO-POLY X POLY))) ((SETQ TEMP-TEMP (for LIT in LITS-THAT-MAY-BE-ASSUMED-FALSE bind (TERM _ (FCONS-TERM* (QUOTE NUMBERP) X)) when (COMPLEMENTARYP TERM LIT) do (RETURN LIT))) (replace (POLY LEMMAS) of POLY with (ADD-TO-SET-EQ TEMP-TEMP (fetch (POLY LEMMAS) of POLY))) (RETURN (ADD-NOT-EQUAL-0-ASSUMPTION-TO-POLY X POLY)))))) (SETQ TEMP (TYPE-SET (SETQ TERM (FCONS-TERM* (QUOTE LESSP) X Y)))) (COND ((IEQP TEMP TYPE-SET-FALSE) NIL) ((IEQP TEMP TYPE-SET-TRUE) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((AND HEURISTIC-TYPE-ALIST (IEQP (LET ((TYPE-ALIST HEURISTIC-TYPE-ALIST)) (TYPE-SET TERM)) TYPE-SET-TRUE)) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((SETQ TEMP-TEMP (MEMBER TERM LITS-THAT-MAY-BE-ASSUMED-FALSE)) (replace (POLY LEMMAS) of POLY with (ADD-TO-SET-EQ (CAR TEMP-TEMP) (fetch (POLY LEMMAS) of POLY)))) (T (replace (POLY ASSUMPTIONS) of POLY with (ADD-TO-SET (FCONS-TERM* (QUOTE NOT) TERM) (fetch (POLY ASSUMPTIONS) of POLY))))) (RETURN POLY]) (ADD-NUMBERP-ASSUMPTION-TO-POLY [LAMBDA (TERM POLY) (* kbr: "19-Oct-85 16:31") (* We add the assumption (NUMBERP TERM) to the assumptions field of POLY but we  first check to see if the assumption is obviously true or false.  We assume TYPE-ALIST is correctly set. If the HEURISTIC-TYPE-ALIST is set and  says the assumption is false, we add the false assumption --  this is sound, even though HEURISTIC-TYPE-ALIST may be irrelevant, because we  can always add a false assumption to a poly which will prevent the poly from  being used. We assume that LITS-THAT-MAY-BE-ASSUMED-FALSE is NIL unless we are  under the ADD-TERMS-TO-POT-LST in SIMPLIFY-CLAUSE0.  If the complement of the assumption we wish to add is in  LITS-THAT-MAY-BE-ASSUMED-FALSE then the assumption is true but we record the  literal that makes it true in the LEMMAS field of POLY.  We assume that if (NUMBERP TERM) is in LITS-THAT-MAY-BE-ASSUMED-FALSE then it  was false under the HEURISTIC-TYPE-ALIST and we do not bother to check.  *) (LET (TEMP) (SETQ TEMP (TYPE-SET TERM)) (COND ((IEQP TEMP TYPE-SET-NUMBERS) NIL) ((NOT (LOGSUBSETP TYPE-SET-NUMBERS TEMP)) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) ((AND HEURISTIC-TYPE-ALIST (NOT (LOGSUBSETP TYPE-SET-NUMBERS (LET ((TYPE-ALIST HEURISTIC-TYPE-ALIST )) (TYPE-SET TERM))))) (* On heuristic grounds, we here  decide not to use this poly.  *) (replace (POLY ASSUMPTIONS) of POLY with (LIST FALSE))) (T (SETQ TEMP (FCONS-TERM* (QUOTE NUMBERP) TERM)) (COND ((SETQ TEMP-TEMP (for LIT in LITS-THAT-MAY-BE-ASSUMED-FALSE when (COMPLEMENTARYP LIT TEMP) do (RETURN LIT))) (replace (POLY LEMMAS) of POLY with (ADD-TO-SET-EQ TEMP-TEMP (fetch (POLY LEMMAS) of POLY)))) (T (replace (POLY ASSUMPTIONS) of POLY with (ADD-TO-SET TEMP (fetch (POLY ASSUMPTIONS ) of POLY))))))) POLY]) (ADD-PROCESS-HIST [LAMBDA (PROCESS PARENT PARENT-HIST DESCENDANTS HIST-ENTRY)(* kbr: "19-Oct-85 16:31") (IO PROCESS PARENT PARENT-HIST DESCENDANTS HIST-ENTRY) (CONS (CONS PROCESS (CONS PARENT HIST-ENTRY)) PARENT-HIST]) (ADD-REWRITE-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "19-Oct-85 16:31") TYPE (for X in (UNPRETTYIFY TERM) bind (LEMMA ALL-VARS-HYPS ALL-VARS-CONCL MAX-TERMS LST TEMP HYPS CONCL) do (SETQ HYPS (CAR X)) (SETQ CONCL (CDR X)) (COND ((SETQ TEMP (ACCEPTABLE-TYPE-PRESCRIPTION-LEMMAP HYPS CONCL)) (ADD-FACT (CAR TEMP) (QUOTE TYPE-PRESCRIPTION-LST) (CONS NAME (CDR TEMP)))) ((AND (NOT NO-BUILT-IN-ARITH-FLG) (OR (BM-MATCH CONCL (NOT (LESSP & &))) (BM-MATCH CONCL (LESSP & &)))) (SETQ LST (EXTERNAL-LINEARIZE CONCL T)) (SETQ ALL-VARS-HYPS (ALL-VARS-LST HYPS)) (SETQ ALL-VARS-CONCL (ALL-VARS CONCL)) (SETQ MAX-TERMS (for PAIR in (fetch (POLY ALIST) of (CAR (CAR LST))) when (AND (NVARIABLEP (CAR PAIR)) (SUBSETP ALL-VARS-CONCL (UNIONQ (ALL-VARS (CAR PAIR)) ALL-VARS-HYPS)) (for PAIR2 in (fetch (POLY ALIST) of (CAR (CAR LST))) when (NEQ PAIR2 PAIR) never (AND (LESSP (FORM-COUNT (CAR PAIR)) (FORM-COUNT (CAR PAIR2))) (SUBBAGP (ALL-VARS-BAG (CAR PAIR)) (ALL-VARS-BAG (CAR PAIR2)))))) collect (CAR PAIR))) (for TERM in MAX-TERMS do (SETQ LEMMA (create LINEAR-LEMMA NAME _ NAME HYPS _ (PREPROCESS-HYPS HYPS) CONCL _ CONCL MAX-TERM _ TERM)) (ADD-FACT (FN-SYMB TERM) (QUOTE LINEAR-LEMMAS) LEMMA))) (T (for REWRITE-RULE in (MAKE-REWRITE-RULES NAME HYPS CONCL) do (ADD-FACT (TOP-FNNAME CONCL) (QUOTE LEMMAS) REWRITE-RULE]) (ADD-SHELL-ROUTINES [LAMBDA (SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (* kbr: "20-Oct-85 19:45") (PROG NIL (COND (IN-BOOT-STRAP-FLG (for NAME in (CONS SHELL-NAME (CONS RECOGNIZER (APPEND (for X in DESTRUCTOR-TUPLES collect (CAR X)) (COND (BTM-FN-SYMB (LIST BTM-FN-SYMB )) (T NIL))))) do (ADD-FACT NAME (QUOTE LISP-CODE) (PACK (LIST STRING-WEIRD NAME)))) (RETURN NIL))) (ADD-DCELL SHELL-NAME (PACK (LIST STRING-WEIRD SHELL-NAME)) (LIST (QUOTE LAMBDA) (for X in DESTRUCTOR-TUPLES collect (CAR X)) (CONS (QUOTE LIST) (CONS (QUOTE *1*SHELL-QUOTE-MARK) (CONS (LIST (QUOTE QUOTE) SHELL-NAME) (for TUPLE in DESTRUCTOR-TUPLES bind TEMP collect (PROGN (SETQ TEMP (CONS (QUOTE OR) (for R in (CDR (CADR TUPLE)) collect (LIST (QUOTE EQ) (QUOTE *1*T) (LIST (PACK (LIST STRING-WEIRD R)) (CAR TUPLE)))))) (LIST (QUOTE COND) (LIST (COND ((EQ (CAR (CADR TUPLE)) (QUOTE ONE-OF)) TEMP) (T (LIST (QUOTE NOT) TEMP))) (CAR TUPLE)) (LIST T (LIST (PACK (LIST STRING-WEIRD (CADDR TUPLE) )))))))))))) [AND BTM-FN-SYMB (ADD-DCELL BTM-FN-SYMB (PACK (LIST STRING-WEIRD BTM-FN-SYMB)) (SUB-PAIR (QUOTE (*1*SHELL-QUOTE-MARK BTM)) (LIST *1*SHELL-QUOTE-MARK BTM-FN-SYMB) (QUOTE (LAMBDA NIL (QUOTE (*1*SHELL-QUOTE-MARK BTM] [ADD-DCELL RECOGNIZER (PACK (LIST STRING-WEIRD RECOGNIZER)) (COND [BTM-FN-SYMB (SUB-PAIR (QUOTE (SHELL-NAME BTM)) (LIST SHELL-NAME BTM-FN-SYMB) (QUOTE (LAMBDA (X) (COND ((AND (LISTP X) (EQ (CAR X) *1*SHELL-QUOTE-MARK) (OR (EQ (CADR X) (QUOTE SHELL-NAME)) (EQ (CADR X) (QUOTE BTM)))) *1*T) (T *1*F] (T (SUB-PAIR (QUOTE (SHELL-NAME)) (LIST SHELL-NAME) (QUOTE (LAMBDA (X) (COND ((AND (LISTP X) (EQ (CAR X) *1*SHELL-QUOTE-MARK) (EQ (CADR X) (QUOTE SHELL-NAME))) *1*T) (T *1*F] [for TUPLE in DESTRUCTOR-TUPLES as I from 2 do (ADD-DCELL (CAR TUPLE) (PACK (LIST STRING-WEIRD (CAR TUPLE))) (SUB-PAIR (QUOTE (R CELL DV BTM)) (LIST (PACK (LIST STRING-WEIRD RECOGNIZER)) (CELL I (QUOTE X)) (PACK (LIST STRING-WEIRD (CADDR TUPLE))) BTM-FN-SYMB) (COND [BTM-FN-SYMB (QUOTE (LAMBDA (X) (COND ((AND (EQ (R X) *1*T) (NEQ (CADR X) (QUOTE BTM))) (CAR CELL)) (T (DV] (T (QUOTE (LAMBDA (X) (COND ((EQ (R X) *1*T) (CAR CELL)) (T (DV] (RETURN NIL]) (ADD-SHELL0 [LAMBDA (SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (* kbr: "26-Nov-85 15:28") (LET (DEST-EXPRS-X SHELL-EXPR CURRENT-TYPE-NO DESTRUCTOR-ALIST RENAMED-SHELL-EXPR DESTRUCTOR-NAMES DV TERM NEW-TYPE-NO NAMES DEST-NAME ARG-NAME) (SETQ NEW-TYPE-NO (NEXT-AVAILABLE-TYPE-NO)) (SETQ DESTRUCTOR-NAMES (for TUPLE in DESTRUCTOR-TUPLES collect (CAR TUPLE))) (ADD-SHELL-ROUTINES SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (SETQ DESTRUCTOR-ALIST (for X in DESTRUCTOR-TUPLES collect (CONS (CAR X) (MAKE-TYPE-RESTRICTION (CADR X) (CADDR X) RECOGNIZER NEW-TYPE-NO)))) (ADD-TYPE-SET-LEMMAS SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-ALIST) (COND (DESTRUCTOR-NAMES (SETQ SHELL-EXPR (CONS-TERM SHELL-NAME DESTRUCTOR-NAMES)) (for PAIR in DESTRUCTOR-ALIST do (SETQ DEST-NAME (CAR PAIR)) (SETQ ARG-NAME DEST-NAME) (SETQ TERM (fetch (TYPE-RESTRICTION TERM) of (CDR PAIR))) (SETQ DV (fetch (TYPE-RESTRICTION DEFAULT) of (CDR PAIR))) (ADD-AXIOM1 (PACK (LIST DEST-NAME "-" SHELL-NAME)) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE EQUAL) (FCONS-TERM* DEST-NAME SHELL-EXPR) (COND ((EQUAL TERM TRUE) ARG-NAME) (T (FCONS-TERM* (QUOTE IF) (SUBST-VAR ARG-NAME (QUOTE X) TERM) ARG-NAME DV))))) (ADD-AXIOM1 (PACK (LIST DEST-NAME (QUOTE -N) RECOGNIZER)) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE IMPLIES) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* RECOGNIZER (QUOTE X))) (FCONS-TERM* (QUOTE EQUAL) (FCONS-TERM* DEST-NAME (QUOTE X)) DV))) (AND (NOT (EQUAL TERM TRUE)) (ADD-AXIOM1 (PACK (LIST DEST-NAME (QUOTE -TYPE-RESTRICTION))) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE IMPLIES) (BM-NEGATE (SUBST-VAR DEST-NAME (QUOTE X) TERM)) (FCONS-TERM* (QUOTE EQUAL) SHELL-EXPR (SUBST-VAR DV DEST-NAME SHELL-EXPR))))) (ADD-AXIOM1 (PACK (LIST DEST-NAME (QUOTE -LESSP))) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE IMPLIES) (COND (BTM-FN-SYMB (FCONS-TERM* (QUOTE AND) (FCONS-TERM* RECOGNIZER (QUOTE X)) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE EQUAL) (QUOTE X) (CONS-TERM BTM-FN-SYMB NIL))))) (T (FCONS-TERM* RECOGNIZER (QUOTE X)))) (FCONS-TERM* (QUOTE LESSP) (FCONS-TERM* (QUOTE COUNT) (FCONS-TERM* DEST-NAME (QUOTE X))) (FCONS-TERM* (QUOTE COUNT) (QUOTE X))))) (ADD-AXIOM1 (PACK (LIST DEST-NAME (QUOTE -LESSEQP))) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE LESSP) (FCONS-TERM* (QUOTE COUNT) (QUOTE X)) (FCONS-TERM* (QUOTE COUNT) (FCONS-TERM* DEST-NAME (QUOTE X))))))) (SETQ RENAMED-SHELL-EXPR (CONS-TERM SHELL-NAME (for DEST in DESTRUCTOR-NAMES collect (PACK (LIST DEST "-"))))) (ADD-AXIOM1 (PACK (LIST SHELL-NAME "-EQUAL")) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE EQUAL) (FCONS-TERM* (QUOTE EQUAL) SHELL-EXPR RENAMED-SHELL-EXPR) (CONJOIN (for ARG1 in (FARGS SHELL-EXPR) as ARG2 in (FARGS RENAMED-SHELL-EXPR) as PAIR in DESTRUCTOR-ALIST collect (PROGN (SETQ TERM (fetch (TYPE-RESTRICTION TERM) of (CDR PAIR))) (SETQ DV (fetch (TYPE-RESTRICTION DEFAULT) of (CDR PAIR))) (COND ((EQUAL TERM TRUE) (FCONS-TERM* (QUOTE EQUAL) ARG1 ARG2)) (T (FCONS-TERM* (QUOTE IF) (SUBST-VAR ARG1 (QUOTE X) TERM) (FCONS-TERM* (QUOTE IF) (SUBST-VAR ARG2 (QUOTE X) TERM) (FCONS-TERM* (QUOTE EQUAL) ARG1 ARG2) (FCONS-TERM* (QUOTE EQUAL) ARG1 DV)) (FCONS-TERM* (QUOTE IF) (SUBST-VAR ARG2 (QUOTE X) TERM) (FCONS-TERM* (QUOTE EQUAL) DV ARG2) TRUE)))))) NIL))) (SETQ DEST-EXPRS-X (for DEST-NAME in DESTRUCTOR-NAMES collect (FCONS-TERM* DEST-NAME (QUOTE X)))) (ADD-AXIOM1 (PACK (CONS SHELL-NAME (for DEST-NAME in DESTRUCTOR-NAMES join (LIST "-" DEST-NAME)))) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE EQUAL) (CONS-TERM SHELL-NAME DEST-EXPRS-X) (FCONS-TERM* (QUOTE IF) (COND (BTM-FN-SYMB (FCONS-TERM* (QUOTE AND) (FCONS-TERM* RECOGNIZER (QUOTE X)) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE EQUAL) (QUOTE X) (CONS-TERM BTM-FN-SYMB NIL)))) ) (T (FCONS-TERM* RECOGNIZER (QUOTE X)))) (QUOTE X) (CONS-TERM SHELL-NAME (for X in DESTRUCTOR-ALIST collect (fetch (TYPE-RESTRICTION DEFAULT) of (CDR X))))))) (ADD-AXIOM1 (PACK (NCONC1 (CDR (for DEST-NAME in DESTRUCTOR-NAMES join (LIST "-" DEST-NAME))) "-ELIM")) (QUOTE (ELIM)) (FCONS-TERM* (QUOTE IMPLIES) (COND (BTM-FN-SYMB (FCONS-TERM* (QUOTE AND) (FCONS-TERM* RECOGNIZER (QUOTE X)) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE EQUAL) (QUOTE X) (CONS-TERM BTM-FN-SYMB NIL))))) (T (FCONS-TERM* RECOGNIZER (QUOTE X)))) (FCONS-TERM* (QUOTE EQUAL) (CONS-TERM SHELL-NAME DEST-EXPRS-X) (QUOTE X)))) (ADD-AXIOM1 (PACK (LIST (QUOTE COUNT-) SHELL-NAME)) (QUOTE (REWRITE)) (FCONS-TERM* (QUOTE EQUAL) (FCONS-TERM* (QUOTE COUNT) SHELL-EXPR) (FCONS-TERM* (QUOTE ADD1) (PLUSJOIN (for X in (FARGS SHELL-EXPR) as PAIR in DESTRUCTOR-ALIST collect (PROGN (SETQ TERM (fetch (TYPE-RESTRICTION TERM) of (CDR PAIR))) (SETQ DV (fetch (TYPE-RESTRICTION DEFAULT) of (CDR PAIR))) (COND ((EQUAL TERM TRUE) (FCONS-TERM* (QUOTE COUNT) X)) (T (FCONS-TERM* (QUOTE IF) (SUBST-VAR X (QUOTE X) TERM) (FCONS-TERM* (QUOTE COUNT) X) ZERO))))))))))) SHELL-NAME]) (ADD-SUB-FACT [LAMBDA (ATM PROP VAL TUPLE INIT) (* kbr: "19-Oct-85 16:31") (* Here is the spec for ADD-SUB-FACT. It takes 5 args ATM PROP VAL TUPLE and  INIT but only a few of these make sense in combination.  To store a new fact you call ADD-SUB-FACT using ATM PROP and VAL.  If PROP is a variable declared below we either CONS VAL to the front of PROPs  top level value or set PROP to VAL depending on whether PROP is ADDITIVE or  SINGLE. SET is used in both cases. If PROP is DCELL it means PUTD1 ATM to VAL.  Otherwise, PROP had better be an additive or single property declared below and  if so the appropriate ADDITIVE or SINGLE PUT1 is done.  If you want to delete a previously added fact you call ADD-SUB-FACT with all  args but TUPLE NIL. TUPLE should be the undo tuple produced by the adding of  the fact in question. Before you begin to add or sub facts you must first  initialize the library file. You do that by calling ADD-SUB-FACT with INIT T  and all other args NIL. The initialization sets LIB-PROPS to the list of  properties declared below in the reverse order of declaration --  making the first property declared the one of highest priority.  Because the list of declarations is used to generated LIB-PROPS you must  include in it all of the properties used by the event level abstraction itself,  even those these properties aren't technically yours.  These properties are IDATE SATELLITES MAIN-EVENT EVENT and LOCAL-UNDO-TUPLES.  They should all be declared with type HIDDEN rather than ADDITIVE or SINGLE.  The code will cause an error if you leave out any built-in prop or use HIDDEN  on any nonbuilt-in one -- the whole purpose of your knowing about these  properties and the token HIDDEN is just to allow you to specify where in the  list of priorities they should be kept. The other thing that initialization  does is set all variables declared below to NIL.  The HIDDEN variable CHRONOLOGY should be declared explicitly.  We force you to do that so you'll always remember we've claimed that variable  name. No property or variable name may contain lower case letters or be NIL.  If this convention is violated the code produced for ADD-SUB-FACT is garbage  because we generate the code with SUBST's that hit lower case names and we  sometimes generate SELECTQs with NIL first elements of clauses.  For ADDITIVE data you must supply a form, which may involve VAL as a free var,  for computing from VAL some datum to be stored in the undo tuple.  This datum must be sufficient for distinguishing that VAL from all others in  that ADDITIVE pot. In particular, to find the VAL in question the undoing  mechanism scans the pot and evaluates the form again for each entry, with VAL  bound to the entry, and removes from the pot the first entry for which that  form computes an EQUAL datum. The form in question must not contain any free  variables other than VAL and must not cause any side-effects.  *) (ADD-SUB-FACT-BODY (TYPE-PRESCRIPTION-LST ADDITIVE PROPERTY (CAR VAL)) (LEMMAS ADDITIVE PROPERTY (fetch (REWRITE-RULE NAME) of VAL)) (LINEAR-LEMMAS ADDITIVE PROPERTY (fetch (LINEAR-LEMMA NAME) of VAL)) (QUICK-BLOCK-INFO SINGLE PROPERTY) (SDEFN SINGLE PROPERTY) (LISP-CODE SINGLE PROPERTY) (TYPE-RESTRICTIONS SINGLE PROPERTY) (INDUCTION-MACHINE SINGLE PROPERTY) (LEVEL-NO SINGLE PROPERTY) (JUSTIFICATIONS SINGLE PROPERTY) (IDATE HIDDEN PROPERTY) (ELIMINATE-DESTRUCTORS-SEQ SINGLE PROPERTY) (ELIMINATE-DESTRUCTORS-DESTS SINGLE PROPERTY) (CONTROLLER-POCKETS SINGLE PROPERTY) (SATELLITES HIDDEN PROPERTY) (MAIN-EVENT HIDDEN PROPERTY) (IMMEDIATE-DEPENDENTS0 ADDITIVE PROPERTY VAL) (EVENT HIDDEN PROPERTY) (LOCAL-UNDO-TUPLES HIDDEN PROPERTY) (NONCONSTRUCTIVE-AXIOM-NAMES ADDITIVE VARIABLE VAL) (*1*BTM-OBJECTS ADDITIVE VARIABLE VAL) (RECOGNIZER-ALIST ADDITIVE VARIABLE VAL) (SHELL-ALIST ADDITIVE VARIABLE VAL) (SINGLETON-TYPE-SETS ADDITIVE VARIABLE VAL) (GENERALIZE-LEMMAS ADDITIVE VARIABLE (fetch (GENERALIZE-LEMMA NAME) of VAL)) (SHELL-POCKETS ADDITIVE VARIABLE VAL) (DISABLED-LEMMAS ADDITIVE VARIABLE VAL) (CHRONOLOGY HIDDEN VARIABLE]) (ADD-TERM-TO-POT-LST [LAMBDA (TERM POT-LST FLG ALL-NEW-FLG) (* kbr: "19-Oct-85 16:31") (PROG NIL (COND ((EQ CURRENT-LIT CURRENT-ATM) (COND ((AND (EQ FLG NIL) (EQUAL TERM CURRENT-LIT)) (RETURN POT-LST)))) (T (COND ((AND FLG (EQUAL TERM CURRENT-ATM)) (RETURN POT-LST))))) (RPLACA ADD-TERM-TO-POT-LST-TEMP TERM) (RETURN (ADD-TERMS-TO-POT-LST ADD-TERM-TO-POT-LST-TEMP POT-LST FLG ALL-NEW-FLG]) (ADD-TERMS-TO-POT-LST [LAMBDA (TERM-LST POT-LST FLG ALL-NEW-FLG) (* kbr: "20-Oct-85 17:30") (* Only called with POT-LST EQ to SIMPLIFY-CLAUSE-POT-LST.  Either returns (QUOTE CONTRADICTION,) in which case there is a proof of F from  TYPE-ALIST, the assumption of the members of TERM-LST true or false according  as FLG is T or NIL, LINEAR-ASSUMPTIONS, and a subset S of the polys in POT-LST  such that if ITIMES IEQP (LIST (QUOTE MARK)) is a MEMB of the LEMMAS of a  member of S then ITIMES is in LEMMAS-USED-BY-LINEAR, or returns a new pot lst  such that for each poly p in the new pot lst there is a proof of p from  TYPE-ALIST, the assumption of the members of TERM-LST true or false according  as FLG is T or NIL, and a subset S of the polys in the input POT-LST such that  if ITIMES IEQP (LIST (QUOTE MARK)) is a MEMB of the lemmas of a member of S,  then ITIMES is in the LEMMAS field of p.  In no case is the lemma stack or linearize assumptions stack visibly affected  by this call. Not necessary for soundness, but true, are the facts that the  lemmas (ignoring typeset lemmas, of course) that are used in the proofs are  included in the LEMMAS fields. Furthermore, the LITERALS fields contain the  literals that were passed in TERM-LST to ADD-TERMS-TO-POT-LST and used to  construct, with LINEARIZE, the original polynomials.  If ALL-NEW-FLG is T then every addend in the pot list is treated as new for the  consideration of lemmas to be added. Otherwise, we add lemmas for the addends  that are introduced by this call. *) (PROG (POLY-LST SPLIT-LST LST BASIC-POT-LST UNIFY-SUBST POT-LST1 POT-LST2) (COND (NO-BUILT-IN-ARITH-FLG (RETURN NIL))) (for TERM in TERM-LST do (SETQ LST (LINEARIZE TERM FLG)) (COND ((NULL LST)) ((NULL (CDR LST)) (SETQ POLY-LST (APPEND (CAR LST) POLY-LST))) ((NULL (CDDR LST)) (SETQ SPLIT-LST (CONS LST SPLIT-LST))) (T (ERROR1 (PQUOTE (PROGN LINEARIZE RETURNED A LIST WITH MORE THAN 2 ELEMENTS !)) NIL (QUOTE HARD))))) (SETQ BASIC-POT-LST (ADD-EQUATIONS-TO-POT-LST POLY-LST POT-LST ALL-NEW-FLG)) (for PAIR in SPLIT-LST bind (MARK _ (LIST (QUOTE MARK))) while (NEQ BASIC-POT-LST (QUOTE CONTRADICTION)) do (* We will add both branches separately and hope at least one gives a  contradiction. Suppose the first branch does not but the second does.  Then we will use the first branch's pot list in the future.  But we must add to the assumptions and lemmas of the first branch those of the  second. To recognize the polys in the first branch's pot lst that descend from  the polys in the first branch we will mark them by putting a unique CONS in the  lemmas field. *) (for POLY in (CAR PAIR) do (replace (POLY LEMMAS) of POLY with (LIST MARK))) (SETQ POT-LST1 (ADD-EQUATIONS-TO-POT-LST (CAR PAIR) BASIC-POT-LST ALL-NEW-FLG)) (COND ((EQ POT-LST1 (QUOTE CONTRADICTION)) (for POLY in (CADR PAIR) do (replace (POLY LEMMAS) of POLY with (REMQ MARK LEMMAS-USED-BY-LINEAR)) (replace (POLY ASSUMPTIONS) of POLY with (UNION-EQUAL LINEAR-ASSUMPTIONS (fetch (POLY ASSUMPTIONS) of POLY)))) (SETQ BASIC-POT-LST (ADD-EQUATIONS-TO-POT-LST (CADR PAIR) BASIC-POT-LST ALL-NEW-FLG))) (T (SETQ POT-LST2 (ADD-EQUATIONS-TO-POT-LST (CADR PAIR) BASIC-POT-LST ALL-NEW-FLG)) (COND ((EQ POT-LST2 (QUOTE CONTRADICTION)) (for POT in POT-LST1 do (for POLY in (fetch (LINEAR-POT POSITIVES) of POT) when (MEMB MARK (fetch (POLY LEMMAS) of POLY)) do (replace (POLY ASSUMPTIONS) of POLY with (UNION-EQUAL LINEAR-ASSUMPTIONS (fetch (POLY ASSUMPTIONS ) of POLY))) (replace (POLY LEMMAS) of POLY with (UNIONQ LEMMAS-USED-BY-LINEAR (REMQ MARK (fetch (POLY LEMMAS) of POLY))))) (for POLY in (fetch (LINEAR-POT NEGATIVES) of POT) when (MEMB MARK (fetch (POLY LEMMAS) of POLY)) do (replace (POLY ASSUMPTIONS) of POLY with (UNION-EQUAL LINEAR-ASSUMPTIONS (fetch (POLY ASSUMPTIONS ) of POLY))) (replace (POLY LEMMAS) of POLY with (UNIONQ LEMMAS-USED-BY-LINEAR (REMQ MARK (fetch (POLY LEMMAS) of POLY)))))) (SETQ BASIC-POT-LST POT-LST1)))))) (RETURN BASIC-POT-LST]) (ADD-TO-SET-EQ [LAMBDA (X LST) (* kbr: "19-Oct-85 16:31") (COND ((MEMB X LST) LST) (T (CONS X LST]) (ADD-TYPE-SET-LEMMAS [LAMBDA (SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-ALIST) (* kbr: "19-Oct-85 16:31") (LET (CURRENT-TYPE-NO) (SETQ CURRENT-TYPE-NO (NEXT-AVAILABLE-TYPE-NO)) (ADD-FACT NIL (QUOTE SHELL-ALIST) (CONS SHELL-NAME CURRENT-TYPE-NO)) (ADD-FACT NIL (QUOTE SHELL-POCKETS) (CONS SHELL-NAME (for X in DESTRUCTOR-ALIST collect (CAR X)))) (ADD-FACT SHELL-NAME (QUOTE TYPE-PRESCRIPTION-LST) (CONS SHELL-NAME (CONS (LOGBIT CURRENT-TYPE-NO) (for X in DESTRUCTOR-ALIST collect NIL)))) (AND DESTRUCTOR-ALIST (ADD-FACT SHELL-NAME (QUOTE TYPE-RESTRICTIONS) (for X in DESTRUCTOR-ALIST collect (CDR X)))) (COND ((AND (NULL DESTRUCTOR-ALIST) (NULL BTM-FN-SYMB)) (ADD-FACT NIL (QUOTE SINGLETON-TYPE-SETS) (LOGBIT CURRENT-TYPE-NO)))) (AND BTM-FN-SYMB (ADD-FACT NIL (QUOTE *1*BTM-OBJECTS) BTM-FN-SYMB)) (AND BTM-FN-SYMB (ADD-FACT BTM-FN-SYMB (QUOTE TYPE-PRESCRIPTION-LST) (CONS SHELL-NAME (CONS (LOGBIT CURRENT-TYPE-NO) NIL)))) (ADD-FACT NIL (QUOTE RECOGNIZER-ALIST) (CONS RECOGNIZER (LOGBIT CURRENT-TYPE-NO))) (ADD-FACT RECOGNIZER (QUOTE TYPE-PRESCRIPTION-LST) (CONS SHELL-NAME (CONS TYPE-SET-BOOLEAN (QUOTE (NIL))))) (for PAIR in DESTRUCTOR-ALIST do (ADD-FACT (CAR PAIR) (QUOTE TYPE-PRESCRIPTION-LST) (CONS SHELL-NAME (CONS (fetch (TYPE-RESTRICTION TYPE-SET) of (CDR PAIR)) (QUOTE (NIL)))))) NIL]) (ALL-ARGLISTS [LAMBDA (FNNAME TERM) (* kbr: "19-Oct-85 16:31") (* Returns the set of arglists of all  subterms of TERM with function symbol  FNNAME. *) (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) (COND ((OR (ASSOC FNNAME SHELL-ALIST) (MEMB FNNAME *1*BTM-OBJECTS)) (ERROR1 (PQUOTE (PROGN ALL-ARGLISTS DOES NOT KNOW HOW TO GO INTO QUOTED CONSTANTS FOR BOTTOM OBJECTS AND SHELL CONSTRUCTORS %.)) NIL (QUOTE HARD))) (T NIL))) ((EQ (FFN-SYMB TERM) FNNAME) (ADD-TO-SET (FARGS TERM) (for ARG in (FARGS TERM) bind LOOP-ANS do (SETQ LOOP-ANS (UNION-EQUAL (ALL-ARGLISTS FNNAME ARG) LOOP-ANS)) finally (RETURN LOOP-ANS)))) (T (for ARG in (FARGS TERM) bind LOOP-ANS do (SETQ LOOP-ANS (UNION-EQUAL (ALL-ARGLISTS FNNAME ARG) LOOP-ANS)) finally (RETURN LOOP-ANS]) (ALL-FNNAMES [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (ANS) (ALL-FNNAMES1 TERM) ANS]) (ALL-FNNAMES-LST [LAMBDA (LST) (* kbr: "19-Oct-85 16:31") (LET (ANS) (for X in LST do (ALL-FNNAMES1 X)) ANS]) (ALL-FNNAMES1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) (ALL-FNNAMES1-EVG (CADR TERM))) (T (COND ((AND (NEQ (QUOTE IF) (FFN-SYMB TERM)) (NEQ (QUOTE EQUAL) (FFN-SYMB TERM))) (SETQ ANS (ADD-TO-SET (FFN-SYMB TERM) ANS)))) (for ARG in (FARGS TERM) do (ALL-FNNAMES1 ARG]) (ALL-FNNAMES1-EVG [LAMBDA (EVG) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP EVG) (SETQ ANS (UNIONQ ANS (COND ((EQ EVG *1*T) (QUOTE (TRUE))) ((EQ EVG *1*F) (QUOTE (FALSE))) ((FIXP EVG) (COND ((LESSP EVG 0) (QUOTE (MINUS ADD1 ZERO))) ((EQUAL EVG 0) (QUOTE (ZERO))) (T (QUOTE (ADD1 ZERO))))) (T (QUOTE (PACK CONS ADD1 ZERO))))))) ((EQ (CAR EVG) *1*SHELL-QUOTE-MARK) (SETQ ANS (ADD-TO-SET (CADR EVG) ANS)) (for X in (CDDR EVG) do (ALL-FNNAMES1-EVG X))) (T (SETQ ANS (ADD-TO-SET (QUOTE CONS) ANS)) (ALL-FNNAMES1-EVG (CAR EVG)) (ALL-FNNAMES1-EVG (CDR EVG]) (ALL-INSERTIONS [LAMBDA (X FINAL-SEG INIT-SEG) (* kbr: "19-Oct-85 16:31") (* Inserts X into FINAL-SEG in all  possible ways IDIFFERENCE assuming  INIT-SEG is NIL at the top most call.  *) (COND ((NULL FINAL-SEG) (LIST (APPEND INIT-SEG (LIST X)))) (T (CONS (APPEND INIT-SEG (LIST X) FINAL-SEG) (ALL-INSERTIONS X (CDR FINAL-SEG) (NCONC1 INIT-SEG (CAR FINAL-SEG]) (ALL-PATHS [LAMBDA (FORM) (* kbr: "19-Oct-85 16:31") (* This function is used only by OPTIMIZE-COMMON-SUBTERMS.  It is assumed that FORM is as described in the documentation of  OPTIMIZE-COMMON-SUBTERMS. In particular, *2*IF and QUOTE are the only symbols  used as function symbols in FORM that are not spread LAMBDAs.  A real-path through FORM is defined to be a list of all of the subterms of FORM  that are MEMBers of COMMONSUBTERMS and that are evaluated in the evaluation of  FORM under some assignment of values to the variables in FORM.  The terms are listed in reverse order of evaluation completion, with FORM  coming first. ALL-PATHS returns a list L of pairs.  Each pair consists of a flag doted with a list of subterms of FORM that are  members of COMMONSUBTERMS. For each real-path P through FORM, there exists a  member (FLG) of L such that L1 is PATH-EQ to P and  (a) if FLG is NIL, then any evaluation of FORM whose real-path is P returns NIL  and (b) if FLG is T, then any such evaluation returns something other than NIL.  If FLG is ?, nothing is asserted. Not every member of L need correspond to  real-path. For example, even if FOO always returns T,  (ALL-PATHS (*2*IF (FOO X) (G X) (H X))) will return a list of length two.  In the documentation of OPTIMIZE-COMMON-SUBTERMS, we define the concepts FIRST,  SECOND, and ISOLATED on a path. From the foregoing specification of the output  of ALL-PATHS, we may conclude that if a MEMBer of COMMONSUBTERMS is SECOND on  every path in (ALL-PATHS FORM) on which it occurs, then it is SECOND on any  real-path through FORM on which it occurs.  Furthermore, we may conclude that if a MEMBer of COMMON-SUBTERMS is ever FIRST  on any real-path through FORM, then it is FIRST on some path in  (ALL-PATHS FORM)%. These two observations are the key to the soundness of  OPTIMIZE-COMMON-SUBTERMS. (A) If a term is ever FIRST on any path of ALL-PATHS,  then the appropriate *2*variable is set when it is executed  (if it has not already been set.) (B) If a term is SECOND on each path of  (ALL-PATHS FORM), then we assume that the appropriate *2*variable has been set  and we use it. If a term is FIRST on each path of ALL-PATHS on which it occurs,  then it is first on each real-path. Thus there is no loss of efficiency in  simply SETting the appropriate *2*variable.  *) (LET (TEMP) (COND ((OR (EQ FORM NIL) (EQUAL FORM (QUOTE (QUOTE NIL)))) (LIST (CONS NIL NIL))) ((OR (EQ FORM T) (AND (LISTP FORM) (EQ (CAR FORM) (QUOTE QUOTE))) (FIXP FORM)) (LIST (CONS T NIL))) ((NLISTP FORM) (LIST (CONS (QUOTE ?) NIL))) ((NEQ (FFN-SYMB FORM) (QUOTE *2*IF)) (for PICK in (ALL-PICKS (for ARG in (REVERSE (FARGS FORM)) collect (CDR-ALL (ALL-PATHS ARG)))) bind LOOP-ANS do (SETQ LOOP-ANS (PATH-ADD-TO-SET (CONS (QUOTE ?) (COND ((MEMB FORM COMMONSUBTERMS) (CONS FORM (APPLY (FUNCTION APPEND) PICK))) (T (APPLY (FUNCTION APPEND) PICK)))) LOOP-ANS)) finally (RETURN LOOP-ANS))) (T (PATH-UNION (for PICK in (ALL-PICKS (LIST (ALL-PATHS (CADDR FORM)) (for X in (SETQ TEMP (ALL-PATHS (CADR FORM)) ) unless (EQ (CAR X) NIL) collect (CDR X)))) bind LOOP-ANS do (SETQ LOOP-ANS (PATH-ADD-TO-SET (CONS (CAR (CAR PICK)) (COND ((MEMB FORM COMMONSUBTERMS) (CONS FORM (APPEND (CDR (CAR PICK)) (CADR PICK)))) (T (APPEND (CDR (CAR PICK)) (CADR PICK))))) LOOP-ANS)) finally (RETURN LOOP-ANS)) (for PICK in (ALL-PICKS (LIST (ALL-PATHS (CADDDR FORM)) (for X in TEMP unless (EQ T (CAR X)) collect (CDR X)))) bind LOOP-ANS do (SETQ LOOP-ANS (PATH-ADD-TO-SET (CONS (CAR (CAR PICK)) (COND ((MEMB FORM COMMONSUBTERMS) (CONS FORM (APPEND (CDR (CAR PICK)) (CADR PICK)))) (T (APPEND (CDR (CAR PICK)) (CADR PICK))))) LOOP-ANS)) finally (RETURN LOOP-ANS]) (ALL-PERMUTATIONS [LAMBDA (L) (* kbr: "19-Oct-85 19:58") (* Returns the list of all  permutations of list L.  *) (COND ((NULL L) (LIST NIL)) (T (for PERM in (ALL-PERMUTATIONS (CDR L)) join (ALL-INSERTIONS (CAR L) PERM NIL]) (ALL-PICKS [LAMBDA (POCKET-LIST) (* kbr: "19-Oct-85 20:03") (* POCKET-LIST is a list of pockets  and this fn returns all of the  possible ways you can pick one thing  from each pocket. *) (COND ((NULL POCKET-LIST) (LIST NIL)) (T (for PICK in (ALL-PICKS (CDR POCKET-LIST)) join (for CHOICE in (CAR POCKET-LIST) collect (CONS CHOICE PICK]) (ALL-SUBSEQUENCES [LAMBDA (L MAX) (* kbr: "19-Oct-85 16:31") (* Returns all subsets of L which have  length less than or equal to MAX,  preserving the order of the elements  in L. *) (LET (TEMP) (COND ((NULL L) (LIST NIL)) (T (SETQ TEMP (ALL-SUBSEQUENCES (CDR L) MAX)) (APPEND TEMP (for X in TEMP unless (EQLENGTH X MAX) collect (CONS (CAR L) X]) (ALL-VARS [LAMBDA (TERM) (* kbr: " 6-Jul-86 09:29") (* Free variables in TERM.  Collects vars in TERM in reverse print  order of first occurrences.  This ordering is exploited in  LOOP-STOPPER. *) (LET (ANS) (ALL-VARS1 TERM) ANS]) (ALL-VARS-BAG [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (ANS) (ALL-VARS-BAG1 TERM) ANS]) (ALL-VARS-BAG1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (SETQ ANS (CONS TERM ANS))) ((FQUOTEP TERM) NIL) (T (for ARG in (FARGS TERM) do (ALL-VARS-BAG1 ARG]) (ALL-VARS-LST [LAMBDA (LST) (* kbr: " 6-Jul-86 09:31") (* Free variables occuring in a LST of  terms. *) (for TERM in LST bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (ALL-VARS TERM) LOOP-ANS)) finally (RETURN LOOP-ANS]) (ALL-VARS1 [LAMBDA (TERM) (* kbr: " 6-Jul-86 09:31") (* Called by ALL-VARS.  Add free variables in TERM to the  growing answer ANS bound by ALL-VARS.  *) (COND ((VARIABLEP TERM) (SETQ ANS (ADD-TO-SET TERM ANS))) ((FQUOTEP TERM) NIL) (T (for ARG in (FARGS TERM) do (ALL-VARS1 ARG]) (ALMOST-SUBSUMES [LAMBDA (CL1 CL2) (* kbr: "19-Oct-85 16:31") (COND ((NULL CL1) (SETQ ALMOST-SUBSUMES-LITERAL ALMOST-SUBSUMES-CONSTANT) T) ((MEMBER (CAR CL1) CL2) (ALMOST-SUBSUMES (CDR CL1) CL2)) ((MEMB-NEGATIVE (CAR CL1) CL2) (COND ((SUBSETP (CDR CL1) CL2) (SETQ ALMOST-SUBSUMES-LITERAL (CAR CL1)) T) (T NIL))) (T NIL]) (ALMOST-SUBSUMES-LOOP [LAMBDA (LST) (* kbr: "19-Oct-85 16:31") (LET (HITFLG ANS DEADLST) (SETQ HITFLG T) (while HITFLG do (SETQ HITFLG NIL) (SETQ ANS NIL) (SETQ DEADLST NIL) (for CL1 in LST do (COND ((for CL2 in LST when (AND (NEQ CL1 CL2) (NOT (MEMB CL2 DEADLST))) thereis (COND ((ALMOST-SUBSUMES CL2 CL1) (SETQ DEADLST (CONS CL1 DEADLST)) (COND ((EQ ALMOST-SUBSUMES-LITERAL ALMOST-SUBSUMES-CONSTANT) T) (T (SETQ HITFLG T) (SETQ ANS (CONS (REMOVE-NEGATIVE ALMOST-SUBSUMES-LITERAL CL1) ANS)) T))) (T NIL)))) (T (SETQ ANS (CONS CL1 ANS))))) (SETQ LST ANS)) ANS]) (ALMOST-VALUEP [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (AND (NVARIABLEP TERM) (ALMOST-VALUEP1 TERM]) (ALMOST-VALUEP1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) T) ((FQUOTEP TERM) T) ((SHELLP TERM) (for ARG in (FARGS TERM) always (ALMOST-VALUEP1 ARG))) (T NIL]) (APPLY-HINTS [LAMBDA (HINTS TERM) (* kbr: "19-Oct-85 16:31") (SETQ TERM (APPLY-USE-HINT (CDR (ASSOC (QUOTE USE) HINTS)) (APPLY-INDUCT-HINT (CADR (ASSOC (QUOTE INDUCT) HINTS)) TERM))) (for X in HINT-VARIABLE-ALIST when (ASSOC (CAR X) HINTS) do (SET (CADR X) (COND ((CADDR X) (for Y in (CDR (ASSOC (CAR X) HINTS)) collect (TRANSLATE Y))) (T (CDR (ASSOC (CAR X) HINTS)))))) TERM]) (APPLY-INDUCT-HINT [LAMBDA (HINT TERM) (* kbr: "19-Oct-85 16:31") (PROG (FORMALS) (COND ((NULL HINT) (RETURN TERM))) (SETQ HINT (TRANSLATE HINT)) (SETQ FORMALS (CADR (GETPROP (FFN-SYMB HINT) (QUOTE SDEFN)))) (RETURN (CONJOIN (for CL in (IND-FORMULA (for TA in (GETPROP (FN-SYMB HINT) (QUOTE INDUCTION-MACHINE)) collect (create TESTS-AND-ALISTS TESTS _ (SUB-PAIR-VAR-LST FORMALS (FARGS HINT) (fetch (TESTS-AND-CASES TESTS) of TA)) ALISTS _ (for ARGLIST in (fetch (TESTS-AND-CASES CASES) of TA) collect (for ARG in ARGLIST as ACTUAL in (FARGS HINT) collect (CONS ACTUAL (SUB-PAIR-VAR FORMALS (FARGS HINT) ARG)))))) (LIST HINT) (LIST (LIST (TRANSLATE TERM)))) collect (DISJOIN CL NIL)) NIL]) (APPLY-USE-HINT [LAMBDA (HINT TERM) (* kbr: "20-Oct-85 19:41") (COND ((NULL HINT) TERM) (T (DUMB-IMPLICATE-LITS (CONJOIN (for PAIR in HINT bind EVENT collect (PROGN (SETQ EVENT (GETPROP (CAR PAIR) (QUOTE EVENT))) (SUBLIS-VAR (for X in (CDR PAIR) collect (CONS (TRANSLATE (CAR X)) (TRANSLATE (CADR X)))) (TRANSLATE (SELECTQ (CAR EVENT) (DEFN (LIST (QUOTE EQUAL) (CONS (CADR EVENT) (CADDR EVENT)) (CADDDR EVENT))) (REFLECT (SETQ TEMP-TEMP (GETPROP (CADR EVENT) (QUOTE SDEFN))) (LIST (QUOTE EQUAL) (CONS (CADR EVENT) (CADR TEMP-TEMP)) (CADDR TEMP-TEMP))) (CADDDR EVENT)))))) NIL) TERM]) (ARG1-IN-ARG2-UNIFY-SUBST [LAMBDA (ARG1 ARG2) (* kbr: "19-Oct-85 16:31") (COND ((OR (VARIABLEP ARG2) (FQUOTEP ARG2)) NIL) ((ONE-WAY-UNIFY ARG2 ARG1) T) (T (for ARG in (FARGS ARG2) thereis (ARG1-IN-ARG2-UNIFY-SUBST ARG1 ARG]) (ARGN0 [LAMBDA (TERM N) (* kbr: "19-Oct-85 16:31") (COND ((NEQ (CAR TERM) (QUOTE QUOTE)) (BM-NTH N TERM)) ((LITATOM (CADR TERM)) (LIST (QUOTE QUOTE) (DTACK-0-ON-END (CHCON (CADR TERM))))) ((FIXP (CADR TERM)) (COND ((LESSP (CADR TERM) 0) (LIST (QUOTE QUOTE) (MINUS (CADR TERM)))) (T (LIST (QUOTE QUOTE) (SUB1 (CADR TERM)))))) ((EQ (CAR (CADR TERM)) *1*SHELL-QUOTE-MARK) (LIST (QUOTE QUOTE) (BM-NTH N (CDR (CADR TERM))))) (T (COND ((IEQP N 1) (LIST (QUOTE QUOTE) (CAR (CADR TERM)))) (T (LIST (QUOTE QUOTE) (CDR (CADR TERM]) (ARITY [LAMBDA (FNNAME) (* kbr: "19-Oct-85 16:31") (COND ((SETQ TEMP-TEMP (TYPE-PRESCRIPTION FNNAME)) (LENGTH (CDR TEMP-TEMP))) ((SETQ TEMP-TEMP (ASSOC FNNAME ARITY-ALIST)) (CDR TEMP-TEMP)) (T NIL]) (ASSOC-OF-APPEND [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (REDO-UNDONE-EVENTS (QUOTE ((DEFN APPEND (X Y) (IF (LISTP X) (CONS (CAR X) (APPEND (CDR X) Y)) Y)) (PROVE-LEMMA ASSOC-OF-APPEND (REWRITE) (EQUAL (APPEND (APPEND A B) C) (APPEND A (APPEND B C)))))) T (QUOTE Q) NIL NIL NIL]) (ASSUME-TRUE-FALSE [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (NOT-FLG TYPE-ARG1 TYPE-ARG2 TRUE-SEG FALSE-SEG PAIR ARG1 ARG2 INTERSECTION SWAPPED-TERM SWAP-FLG LOCAL-MUST-BE-TRUE LOCAL-MUST-BE-FALSE) (COND ((BM-MATCH TERM (NOT TERM)) (SETQ NOT-FLG T))) (COND ((AND (NVARIABLEP TERM) (NOT (FQUOTEP TERM)) (SETQ PAIR (ASSOC (FFN-SYMB TERM) RECOGNIZER-ALIST))) (SETQ TYPE-ARG1 (TYPE-SET (FARGN TERM 1))) (COND ((IEQP 0 (LOGAND TYPE-ARG1 (CDR PAIR))) (SETQ LOCAL-MUST-BE-FALSE T)) ((LOGSUBSETP TYPE-ARG1 (CDR PAIR)) (SETQ LOCAL-MUST-BE-TRUE T)) (T (SETQ TRUE-SEG (LIST (CONS (FARGN TERM 1) (CDR PAIR)))) (SETQ FALSE-SEG (LIST (CONS (FARGN TERM 1) (LOGAND (LOGNOT (CDR PAIR)) TYPE-ARG1))))))) ((BM-MATCH TERM (EQUAL ARG1 ARG2)) (COND ((EQUAL ARG1 ARG2) (SETQ LOCAL-MUST-BE-TRUE T)) ((AND (SETQ TEMP-TEMP (CDR (SASSOC TERM TYPE-ALIST))) (IEQP TEMP-TEMP TYPE-SET-TRUE)) (SETQ LOCAL-MUST-BE-TRUE T)) ((AND TEMP-TEMP (IEQP TEMP-TEMP TYPE-SET-FALSE)) (SETQ LOCAL-MUST-BE-FALSE T)) ((AND (SETQ TEMP-TEMP (CDR (SASSOC (SETQ SWAPPED-TERM (FCONS-TERM* (QUOTE EQUAL) ARG2 ARG1)) TYPE-ALIST))) (EQUAL TEMP-TEMP TYPE-SET-TRUE)) (SETQ LOCAL-MUST-BE-TRUE T)) ((AND TEMP-TEMP (IEQP TEMP-TEMP TYPE-SET-FALSE)) (SETQ LOCAL-MUST-BE-FALSE T)) (T (SETQ SWAP-FLG (TERM-ORDER ARG1 ARG2)) (SETQ TYPE-ARG1 (TYPE-SET ARG1)) (SETQ TYPE-ARG2 (TYPE-SET ARG2)) (SETQ INTERSECTION (LOGAND TYPE-ARG1 TYPE-ARG2)) (COND ((IEQP 0 INTERSECTION) (SETQ LOCAL-MUST-BE-FALSE T)) ((AND (IEQP TYPE-ARG1 TYPE-ARG2) (MEMBER TYPE-ARG1 SINGLETON-TYPE-SETS)) (SETQ LOCAL-MUST-BE-TRUE T)) (T (SETQ TRUE-SEG (COND (SWAP-FLG (LIST (CONS SWAPPED-TERM TYPE-SET-TRUE))) (T (LIST (CONS TERM TYPE-SET-TRUE))))) (OR (IEQP TYPE-ARG1 INTERSECTION) (NOT SWAP-FLG) (SETQ TRUE-SEG (CONS (CONS ARG1 INTERSECTION) TRUE-SEG))) (OR (IEQP TYPE-ARG2 INTERSECTION) SWAP-FLG (SETQ TRUE-SEG (CONS (CONS ARG2 INTERSECTION) TRUE-SEG))) (SETQ FALSE-SEG (LIST (CONS TERM TYPE-SET-FALSE) (CONS SWAPPED-TERM TYPE-SET-FALSE))) (OR (NOT (MEMBER TYPE-ARG2 SINGLETON-TYPE-SETS)) (SETQ FALSE-SEG (CONS (CONS ARG1 (LOGAND (LOGNOT TYPE-ARG2) TYPE-ARG1)) FALSE-SEG))) (OR (NOT (MEMBER TYPE-ARG1 SINGLETON-TYPE-SETS)) (SETQ FALSE-SEG (CONS (CONS ARG2 (LOGAND (LOGNOT TYPE-ARG1) TYPE-ARG2)) FALSE-SEG)))))))) (T (SETQ TYPE-ARG1 (TYPE-SET TERM)) (COND ((IEQP TYPE-ARG1 TYPE-SET-FALSE) (SETQ LOCAL-MUST-BE-FALSE T)) ((IEQP 0 (LOGAND TYPE-ARG1 TYPE-SET-FALSE)) (SETQ LOCAL-MUST-BE-TRUE T)) (T (SETQ TRUE-SEG (LIST (CONS TERM (LOGAND TYPE-ARG1 (LOGNOT TYPE-SET-FALSE))))) (SETQ FALSE-SEG (LIST (CONS TERM TYPE-SET-FALSE))))))) (COND (NOT-FLG (swap LOCAL-MUST-BE-TRUE LOCAL-MUST-BE-FALSE) (swap TRUE-SEG FALSE-SEG))) (SETQ TRUE-TYPE-ALIST (NCONC TRUE-SEG TYPE-ALIST)) (SETQ FALSE-TYPE-ALIST (NCONC FALSE-SEG TYPE-ALIST)) (SETQ MUST-BE-TRUE LOCAL-MUST-BE-TRUE) (SETQ MUST-BE-FALSE LOCAL-MUST-BE-FALSE) NIL]) (ATTEMPT-TO-REWRITE-RECOGNIZER [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (BM-MATCH TERM (NOT TERM)) (AND (NVARIABLEP TERM) (ASSOC (FN-SYMB TERM) RECOGNIZER-ALIST) (VARIABLEP (ARGN TERM 1]) ) (RPAQQ CODE-B-DCOMS ((* CODE-B-D *) (FNS BATCH-PROVEALL BOOLEAN BOOT-STRAP0 BREAK-LEMMA BTM-OBJECT BTM-OBJECT-OF-TYPE-SET BTM-OBJECTP BUILD-SUM CANCEL CANCEL-POSITIVE CANCEL1 CAR-CDRP CDR-ALL CHK-ACCEPTABLE-DEFN CHK-ACCEPTABLE-DCL CHK-ACCEPTABLE-ELIM-LEMMA CHK-ACCEPTABLE-GENERALIZE-LEMMA CHK-ACCEPTABLE-HINTS CHK-ACCEPTABLE-LEMMA CHK-ACCEPTABLE-META-LEMMA CHK-ACCEPTABLE-REFLECT CHK-ACCEPTABLE-REWRITE-LEMMA CHK-ACCEPTABLE-SHELL CHK-ACCEPTABLE-TOGGLE CHK-ARGLIST CHK-MEANING CHK-NEW-*1*NAME CHK-NEW-NAME CLAUSIFY CLAUSIFY-INPUT CLAUSIFY-INPUT1 CLEAN-UP-BRANCHES CNF-DNF COMMON-SWEEP COMMUTE-EQUALITIES COMPARE-STATS COMPLEMENTARY-MULTIPLEP COMPLEMENTARYP COMPLEXITY COMPRESS-POLY COMPRESS-POLY1 COMPUTE-VETOES COMSUBT1 COMSUBTERMS CONJOIN CONJOIN-CLAUSE-SETS CONJOIN2 CONS-PLUS CONS-TERM CONSJOIN CONTAINS-REWRITEABLE-CALLP CONVERT-CAR-CDR CONVERT-CONS CONVERT-NOT CONVERT-QUOTE CONVERT-TYPE-NO-TO-RECOGNIZER-TERM BM-COUNT COUNT-IFS CREATE-REWRITE-RULE DCL0 DECODE-IDATE DEFN-ASSUME-TRUE-FALSE DEFN-LOGIOR DEFN-SETUP DEFN-TYPE-SET DEFN-TYPE-SET2 DEFN-WRAPUP DEFN0 DELETE1 DELETE-TAUTOLOGIES DELETE-TOGGLES DEPEND DEPENDENT-EVENTS DEPENDENTS-OF DEPENDENTS-OF1 DESTRUCTORS DESTRUCTORS1 DETACH DETACHED-ERROR DETACHEDP DISJOIN DISJOIN-CLAUSES DISJOIN2 DTACK-0-ON-END DUMB-CONVERT-TYPE-SET-TO-TYPE-RESTRICTION-TERM DUMB-IMPLICATE-LITS DUMB-NEGATE-LIT DUMB-OCCUR DUMB-OCCUR-LST DUMP DUMP-ADD-AXIOM DUMP-ADD-SHELL DUMP-BEGIN-GROUP DUMP-DCL DUMP-DEFN DUMP-END-GROUP DUMP-HINTS DUMP-LEMMA-TYPES DUMP-OTHER DUMP-PROVE-LEMMA DUMP-TOGGLE))) (* CODE-B-D *) (DEFINEQ (BATCH-PROVEALL [LAMBDA (FILE) (* kbr: "19-Oct-85 16:31") (* FILE should contain a sequence of  forms such as (PROVEALL ...)  (PROVEALL ...)%. Each is executed.  *) (RESTART-BATCH (READ-FILE FILE]) (BOOLEAN [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LOGSUBSETP (TYPE-SET TERM) TYPE-SET-BOOLEAN]) (BOOT-STRAP0 [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (ADD-SUB-FACT NIL NIL NIL NIL T) (ADD-SUB-FACT NIL NIL NIL NIL T) (MAKUNBOUND (QUOTE LIB-FILE]) (BREAK-LEMMA [LAMBDA (NAME WHEN) (* kbr: "26-Oct-85 14:57") (OR WHEN (SETQ WHEN T)) (APPLY (FUNCTION TRACE) (LIST (LIST (QUOTE RELIEVE-HYPS) (QUOTE BREAK) (QUOTE (AND (SETQ TEMP-TEMP (ASSOC (CADR LEMMA) BROKEN-LEMMAS)) (EVAL (CDR TEMP-TEMP)) (PROGN (BM-PPR (LIST (LIST (QUOTE LEMMA) (CADR LEMMA)) (LIST (QUOTE TERM) TERM) (LIST (QUOTE UNIFY-SUBST) UNIFY-SUBST)) T) T)))))) (SETQ BROKEN-LEMMAS (ADD-TO-SET (CONS NAME WHEN) BROKEN-LEMMAS]) (BTM-OBJECT [LAMBDA (CONST) (* kbr: "19-Oct-85 16:31") (* If the shell for which CONST is the constructor has a bottom object return  the term that is that bottom object. Else, return NIL.  *) (LET (TYPE-SET ANS) (SETQ TYPE-SET (LSH 1 (CDR (ASSOC CONST SHELL-ALIST)))) (COND ((for FN in *1*BTM-OBJECTS thereis (IEQP (TYPE-SET (SETQ ANS (CONS-TERM FN NIL))) TYPE-SET)) ANS) (T NIL]) (BTM-OBJECT-OF-TYPE-SET [LAMBDA (TYPE-SET) (* kbr: "19-Oct-85 16:31") (* Returns the btm object fn symb with  the specified type set, or NIL if no  such btm object exists.  *) (COND ((NULL (CDR *1*BTM-OBJECTS)) (COND ((IEQP TYPE-SET TYPE-SET-NUMBERS) (QUOTE ZERO)) (T NIL))) (T (for X in *1*BTM-OBJECTS when (IEQP TYPE-SET (CAR (TYPE-PRESCRIPTION X))) do (RETURN X]) (BTM-OBJECTP [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) (COND ((NLISTP (CADR TERM)) (EQUAL 0 (CADR TERM))) (T (AND (EQ *1*SHELL-QUOTE-MARK (CAR (CADR TERM))) (MEMB (CADR (CADR TERM)) *1*BTM-OBJECTS))))) (T (MEMB (FFN-SYMB TERM) *1*BTM-OBJECTS]) (BUILD-SUM [LAMBDA (WINNING-PAIR ALIST) (* kbr: "20-Oct-85 15:48") (COND ((NLISTP ALIST) ZERO) ((EQUAL WINNING-PAIR (CAR ALIST)) (BUILD-SUM WINNING-PAIR (CDR ALIST))) (T (CONS-PLUS (COND ((EQUAL 1 (ABS (CDR (CAR ALIST)))) (CAR (CAR ALIST))) (T (FCONS-TERM* (QUOTE TIMES) (LIST (QUOTE QUOTE) (ABS (CDR (CAR ALIST)))) (CAR (CAR ALIST))))) (BUILD-SUM WINNING-PAIR (CDR ALIST]) (CANCEL [LAMBDA (EQ1 EQ2) (* kbr: "19-Oct-85 16:31") (LET (CO1 CO2 POLY) (SETQ CO1 (ABS (FIRST-COEFFICIENT EQ1))) (SETQ CO2 (ABS (FIRST-COEFFICIENT EQ2))) (* See ADD-TERMS-TO-POT-LST for an  explanation of why we UNIONQ rather  than UNION-EQUAL the LITERALS and  LEMMAS. *) (SETQ POLY (create POLY CONSTANT _ (PLUS (TIMES CO2 (fetch (POLY CONSTANT) of EQ1)) (TIMES CO1 (fetch (POLY CONSTANT) of EQ2))) ALIST _ (CANCEL1 CO2 (CDR (fetch (POLY ALIST) of EQ1)) CO1 (CDR (fetch (POLY ALIST) of EQ2))) ASSUMPTIONS _ (UNION-EQUAL (fetch (POLY ASSUMPTIONS) of EQ1) (fetch (POLY ASSUMPTIONS) of EQ2)) LITERALS _ (UNIONQ (fetch (POLY LITERALS) of EQ1) (fetch (POLY LITERALS) of EQ2)) LEMMAS _ (UNIONQ (fetch (POLY LEMMAS) of EQ1) (fetch (POLY LEMMAS) of EQ2)))) (COND ((IMPOSSIBLE-POLYP POLY) (SETQ LINEAR-ASSUMPTIONS (fetch (POLY ASSUMPTIONS) of POLY)) (SETQ LEMMAS-USED-BY-LINEAR (UNIONQ (fetch (POLY LEMMAS) of POLY) (fetch (POLY LITERALS) of POLY))) (RETFROM (QUOTE ADD-EQUATIONS) (QUOTE CONTRADICTION))) ((TRUE-POLYP POLY) NIL) (T POLY]) (CANCEL-POSITIVE [LAMBDA (EQUATION) (* kbr: "19-Oct-85 16:31") (COND ((GREATERP (FIRST-COEFFICIENT EQUATION) 0) (SETQ EQUATION (create POLY CONSTANT _ (fetch (POLY CONSTANT) of EQUATION) ALIST _ (CDR (fetch (POLY ALIST) of EQUATION)) ASSUMPTIONS _ (fetch (POLY ASSUMPTIONS) of EQUATION) LITERALS _ (fetch (POLY LITERALS) of EQUATION) LEMMAS _ (fetch (POLY LEMMAS) of EQUATION))) (COND ((IMPOSSIBLE-POLYP EQUATION) (SETQ LINEAR-ASSUMPTIONS (fetch (POLY ASSUMPTIONS) of EQUATION)) (SETQ LEMMAS-USED-BY-LINEAR (UNIONQ (fetch (POLY LEMMAS) of EQUATION) (fetch (POLY LITERALS) of EQUATION))) (RETFROM (QUOTE ADD-EQUATIONS) (QUOTE CONTRADICTION))) ((TRUE-POLYP EQUATION) NIL) (T EQUATION))) (T NIL]) (CANCEL1 [LAMBDA (CO1 AL1 CO2 AL2) (* kbr: "20-Oct-85 15:50") (LET (TEMP) (COND ((NULL AL1) (for PAIR in AL2 collect (CONS (CAR PAIR) (TIMES (CDR PAIR) CO2)))) ((NULL AL2) (for PAIR in AL1 collect (CONS (CAR PAIR) (TIMES (CDR PAIR) CO1)))) ((NOT (TERM-ORDER (CAAR AL1) (CAR (CAR AL2)))) (CONS (CONS (CAR (CAR AL1)) (TIMES (CDR (CAR AL1)) CO1)) (CANCEL1 CO1 (CDR AL1) CO2 AL2))) ((EQUAL (CAR (CAR AL1)) (CAR (CAR AL2))) (SETQ TEMP (PLUS (TIMES CO1 (CDR (CAR AL1))) (TIMES CO2 (CDR (CAR AL2))))) (COND ((EQUAL TEMP 0) (CANCEL1 CO1 (CDR AL1) CO2 (CDR AL2))) (T (CONS (CONS (CAR (CAR AL1)) TEMP) (CANCEL1 CO1 (CDR AL1) CO2 (CDR AL2)))))) (T (CONS (CONS (CAR (CAR AL2)) (TIMES (CDR (CAR AL2)) CO2)) (CANCEL1 CO1 AL1 CO2 (CDR AL2]) (CAR-CDRP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET ((FLAT (NCHARS X))) (AND (EQ (NTHCHAR X 1) (QUOTE C)) (EQ (NTHCHAR X FLAT) (QUOTE R)) (IGREATERP FLAT 2) (for I from 2 by 1 to (SUB1 FLAT) always (MEMB (NTHCHAR X I) (QUOTE (A D)))) (CDR (DREVERSE (CDR (UNPACK X]) (CDR-ALL [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (for X1 in X collect (CDR X1]) (CHK-ACCEPTABLE-DEFN [LAMBDA (NAME ARGS BODY RELATION-MEASURE-LST) (* kbr: "26-Oct-85 15:30") (LET ((ARITY-ALIST (CONS (CONS NAME (LENGTH-TO-ATOM ARGS)) ARITY-ALIST))) (CHK-NEW-NAME NAME NIL) (CHK-NEW-*1*NAME NAME) (CHK-ARGLIST NAME ARGS) (COND ((IGREATERP (LENGTH ARGS) 32) (ERROR1 (PQUOTE (PROGN TOO MANY ARGS ! BECAUSE OF OUR USE OF 32-BIT WORDS TO ENCODE SETS OF RECURSION CONTROLLERS WE CANNOT ACCEPT FUNCTIONS , SUCH AS (!PPR NAME NIL) , WITH MORE THAN 32 ARGUMENTS %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT)))) (SETQ BODY (TRANSLATE BODY)) (COND ((NOT IN-BOOT-STRAP-FLG) (CHK-MEANING NAME (ALL-FNNAMES BODY)))) (FREE-VAR-CHK NAME ARGS BODY) (for X in RELATION-MEASURE-LST do (COND ((NOT (AND (LISTP X) (MEMB (CAR X) WELL-ORDERING-RELATIONS) (LISTP (CDR X)) (NULL (CDDR X)) (SUBSETP (ALL-VARS (TRANSLATE (CADR X))) ARGS))) (ERROR1 (PQUOTE (PROGN EACH MEMBER OF THE FOURTH ARGUMENT TO DEFN MUST BE OF THE FORM (!PPR (QUOTE (REL TERM)) NIL) , WHERE REL IS THE NAME OF A WELL-FOUNDED RELATION AND TERM IS A TERM ALL OF WHOSE VARIABLES ARE AMONG THE FORMALS OF THE FUNCTION BEING DEFINED %.)) NIL (QUOTE SOFT))))) NIL]) (CHK-ACCEPTABLE-DCL [LAMBDA (NAME ARGS) (* kbr: "19-Oct-85 16:31") (CHK-ARGLIST NAME ARGS) (CHK-NEW-NAME NAME NIL) (COND ((IGREATERP (LENGTH ARGS) 32) (ERROR1 (PQUOTE (PROGN TOO MANY ARGS ! BECAUSE OF OUR USE OF 32-BIT WORDS TO ENCODE SETS OF RECURSION CONTROLLERS WE CANNOT ACCEPT FUNCTIONS , SUCH AS (!PPR NAME NIL) , WITH MORE THAN 32 ARGUMENTS %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT]) (CHK-ACCEPTABLE-ELIM-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "20-Oct-85 15:51") TYPE (LET (LST ALLVARS LHS RHS DESTS) (SETQ LST (UNPRETTYIFY TERM)) (COND ((NOT (AND LST (NULL (CDR LST)) (BM-MATCH (CDR (CAR LST)) (EQUAL LHS RHS)) (VARIABLEP RHS) (NVARIABLEP LHS) (for ARG in (SARGS LHS) thereis (NVARIABLEP ARG)))) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE ELIM LEMMA BECAUSE ITS CONCLUSION IS NOT AN EQUALITY OF THE FORM IQUOTIENT (EQUAL TERM VAR/) WHERE TERM CONTAINS SOME NON-VARIABLE ARGUMENTS AND VAR IS A VARIABLE %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT)))) (SETQ ALLVARS (ALL-VARS TERM)) (COND ((NOT (SETQ DESTS (DESTRUCTORS (LIST LHS)))) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE ELIM LEMMA BECAUSE THE LEFT HAND SIDE OF THE CONCLUSION DOES NOT CONTAIN ANY TERMS OF THE FORM IQUOTIENT (FN VAR1 VAR2 ... VARN/) WHERE FN IS A RECURSIVE FUNCTION AND THE VARI ARE ALL DISTINCT VARIABLES %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))) ((NOT (NO-DUPLICATESP (for X in DESTS collect (FN-SYMB X)))) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE ELIM LEMMA BECAUSE THE LEFT HAND SIDE OF THE CONCLUSION CONTAINS TWO OR MORE DESTRUCTOR TERMS WITH THE SAME FUNCTION SYMBOL %.)) NIL (QUOTE SOFT))) ((NOT (for X in DESTS always (SUBSETP ALLVARS (SARGS X)))) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS NOT AN ACCEPTABLE ELIM LEMMA BECAUSE SOME OF THE DESTRUCTOR NESTS DO NOT MENTION ALL OF THE VARIABLES IN THE LEMMA %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))) ((OCCUR RHS (SUB-PAIR-EXPR DESTS (for X in DESTS collect (TRUE X)) LHS)) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE ELIM LEMMA BECAUSE THE RIGHT-HAND SIDE OF THE CONCLUSION , (!PPR RHS NIL) , OCCURS IN THE LEFT-HAND SIDE IN PLACES OTHER THAN THE DESTRUCTOR (PLURAL? DESTS TERMS TERM) (!PPR-LIST DESTS) %.)) (BINDINGS (QUOTE NAME) NAME (QUOTE RHS) RHS (QUOTE DESTS) DESTS) (QUOTE SOFT))) (T (for X in DESTS when (GETPROP (CAR X) (QUOTE ELIMINATE-DESTRUCTORS-DESTS)) do (ERROR1 (PQUOTE (PROGN WE DO NOT KNOW HOW TO HANDLE MULTIPLE ELIMINATION LEMMAS FOR THE SAME FUNCTION SYMBOL, E.G., (!PPR (CAR X) NIL) %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))))) NIL]) (CHK-ACCEPTABLE-GENERALIZE-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "19-Oct-85 16:31") NAME TYPE TERM T]) (CHK-ACCEPTABLE-HINTS [LAMBDA (HINTS) (* kbr: "26-Oct-85 17:49") (LET (EVENT) (for X in HINTS do (COND ((NLISTP X) (ERROR1 (PQUOTE (PROGN EACH ELEMENT OF THE HINTS ARGUMENT TO PROVE-LEMMA MUST BE A PAIR BUT (!PPR X NIL) IS NOT %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) (T (SELECTQ (CAR X) (USE (for PAIR in (CDR X) do (OR (AND (LISTP PAIR) (LITATOM (CAR PAIR)) (SETQ EVENT (GETPROP (CAR PAIR) (QUOTE EVENT))) (MEMB (CAR EVENT) (QUOTE (ADD-AXIOM PROVE-LEMMA DEFN REFLECT))) (NULL (CDR (LAST PAIR))) (for X in (CDR PAIR) always (AND (VARIABLEP (TRANSLATE (CAR X))) (PROGN (TRANSLATE (CADR X)) T)))) (ERROR1 (PQUOTE (PROGN THE USE HINT MUST HAVE THE FORM (!PPR H NIL) WHERE EACH EVENTI IS THE NAME OF AN ADD-AXIOM , PROVE-LEMMA , DEFN , OR REFLECT EVENT , EACH VI IS A VARIABLE NAME , AND EACH TI IS A TERM %. THE ENTRY (!PPR PAIR NIL) IS THUS UNACCEPTABLE %.)) (BINDINGS (QUOTE H) (QUOTE (USE (EVENT1 (V1 T1) ... (VN TN)) ... (EVENTK (VK TK) ... (VM TM)))) (QUOTE PAIR) PAIR) (QUOTE SOFT))))) (EXPAND (for X in (CDR X) bind Y do (SETQ Y (TRANSLATE X)) (OR (AND (NVARIABLEP Y) (NOT (FQUOTEP Y)) (GETPROP (FFN-SYMB Y) (QUOTE SDEFN))) (ERROR1 (PQUOTE (PROGN EVERY ELEMENT OF AN EXPAND HINT MUST BE AN APPLICATION OF A DEFINED FUNCTION TO SOME ARGUMENTS AND (!PPR Y NIL) IS NOT %.)) (BINDINGS (QUOTE Y) Y) (QUOTE SOFT))))) (DISABLE (for X in (CDR X) do (OR (LITATOM X) (ERROR1 (PQUOTE (PROGN EVERY ELEMENT OF A DISABLE HINT MUST BE A LITERAL NLISTP AND (!PPR X NIL) IS NOT %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))))) (INDUCT (OR (NULL (CADR X)) (AND (SETQ HINT (TRANSLATE (CADR X))) (NVARIABLEP HINT) (NOT (FQUOTEP HINT)) (GETPROP (FFN-SYMB HINT) (QUOTE INDUCTION-MACHINE)) (GETPROP (FFN-SYMB HINT) (QUOTE SDEFN)) (for X in (FARGS HINT) always (VARIABLEP X)) (NO-DUPLICATESP (FARGS HINT))) (ERROR1 (PQUOTE (PROGN THE INDUCT HINT MUST HAVE EITHER THE FORM (!PPR G NIL) OR THE FORM (!PPR H NIL) WHERE FN IS A RECURSIVELY DEFINED FUNCTION AND THE VI ARE DISTINCT VARIABLES %. THUS, (!PPR X NIL) IS AN INAPPROPRIATE INDUCT HINT %.)) (BINDINGS (QUOTE G) (QUOTE (INDUCT NIL)) (QUOTE H) (QUOTE (INDUCT (FN V1 ... VN))) (QUOTE X) X) (QUOTE SOFT)))) (COND ((ASSOC (CAR X) HINT-VARIABLE-ALIST) (COND ((CADDR (ASSOC (CAR X) HINT-VARIABLE-ALIST)) (for Y in (CDR X) do (TRANSLATE Y))))) (T (ERROR1 (PQUOTE (PROGN EACH ENTRY IN THE HINTS ARGUMENT OF PROVE-LEMMA MUST BE A LIST BEGINNING WITH ONE OF THE ATOMS USE , EXPAND , DISABLE , INDUCT , OR TIME. THE PROPOSED HINT (!PPR X NIL) IS THUS INAPPROPRIATE %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT]) (CHK-ACCEPTABLE-LEMMA [LAMBDA (NAME TYPES TERM) (* kbr: "26-Nov-85 15:39") (CHK-NEW-NAME NAME NIL) (SETQ TERM (TRANSLATE TERM)) (COND (IN-ADD-AXIOM-FLG (CHK-MEANING NAME (ALL-FNNAMES TERM)))) (for TYPE in TYPES do (COND ((MEMB (COND ((LISTP TYPE) (CAR TYPE)) (T TYPE)) LEMMA-TYPES) (APPLY* (PACK (LIST "CHK-ACCEPTABLE-" (COND ((LISTP TYPE) (CAR TYPE)) (T TYPE)) "-LEMMA")) NAME TYPE TERM)) (T (ERROR1 (PQUOTE (PROGN (!PPR TYPE NIL) IS NOT AMONG THE LEGAL TYPES, VIZ. , (!LIST LEMMA-TYPES) %.)) (BINDINGS (QUOTE TYPE) TYPE (QUOTE LEMMA-TYPES) LEMMA-TYPES) (QUOTE SOFT]) (CHK-ACCEPTABLE-META-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "19-Oct-85 16:31") (LET (FN1 V1 A1 V2 A2 FN2 V3 V4) (COND ((AND (NOT IN-ADD-AXIOM-FLG) NONCONSTRUCTIVE-AXIOM-NAMES) (ERROR1 (PQUOTE (PROGN META LEMMAS MUST BE PROVED IN A CONSTRUCTIVE HISTORY %. THE CURRENT HISTORY CONTAINS THE NONCONSTRUCTIVE (PLURAL? LST AXIOMS AXIOM) (!LIST LST) %. IF THIS METALEMMA IS PROVED USING UNSOUND AXIOMS YOU MAY GETPROP WIPED OUT BY THE APPLICATION OF THE METAFUNCTION %.)) (BINDINGS (QUOTE LST) NONCONSTRUCTIVE-AXIOM-NAMES) (QUOTE WARNING))) ((NOT (AND (BM-MATCH TERM (IMPLIES (FORMP V1) (AND (EQUAL (MEANING V2 A1) (MEANING (LIST FN1 V3) A2)) (FORMP (LIST FN2 V4))))) (VARIABLEP V1) (VARIABLEP A1) (EQ V1 V2) (EQ V1 V3) (EQ V1 V4) (EQ A1 A2) (NEQ V1 A1) (GETPROP FN1 (QUOTE LISP-CODE)) (EQ FN1 FN2))) (ERROR1 (PQUOTE (PROGN META LEMMAS HAVE TO HAVE THE FORM (!PPR X NIL) WHERE V AND A ARE DISTINCT VARIABLES AND FN IS AN EXPLICIT VALUE PRESERVING FUNCTION %. (!PPR NAME NIL) DOES NOT HAVE THIS FORM %.)) (BINDINGS (QUOTE X) (QUOTE (IMPLIES (FORMP V) (AND (EQUAL (MEANING V A) (MEANING (FN V) A)) (FORMP (FN V))))) (QUOTE NAME) NAME) (QUOTE SOFT))) ((NOT (AND (BM-MATCH TYPE (CONS (QUOTE META) FNS)) (for FN in FNS always (AND (LITATOM FN) (GETPROP FN (QUOTE TYPE-PRESCRIPTION-LST)))))) (ERROR1 (PQUOTE (PROGN META LEMMAS MUST BE STORED UNDER ONE OR MORE FUNCTIONS NAMED BY THE USER IN A LEMMA TYPE OF THE FORM (!PPR X NIL) WHERE THE FNI ARE FUNCTION NAMES %. (!PPR TYPE NIL) IS NOT OF THIS FORM %.)) (BINDINGS (QUOTE X) (QUOTE (META FN1 FN2 ... FNN)) (QUOTE TYPE) TYPE) (QUOTE SOFT)))) T]) (CHK-ACCEPTABLE-REFLECT [LAMBDA (NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST)(* kbr: "26-Oct-85 17:50") (LET (FN ARGS BODY) (CHK-NEW-NAME NAME NIL) (CHK-NEW-*1*NAME NAME) (COND ((OR (NOT (BM-MATCH (FORMULA-OF SATISFACTION-LEMMA-NAME) (EQUAL (CONS FN ARGS) BODY))) (MEMB FN *1*BTM-OBJECTS) (ASSOC FN SHELL-ALIST)) (ERROR1 (PQUOTE (PROGN THE SECOND ARGUMENT OF REFLECT MUST BE THE NAME OF A LEMMA OF THE FORM (!PPR (QUOTE (EQUAL (FN ARG1 ... ARGN) BODY)) NIL) WHERE FN IS NOT A SHELL CONSTRUCTOR OR BOTTOM OBJECT FUNCTION SYMBOL %. (!PPR LEMMA NIL) IS NOT OF THIS FORM %.)) (BINDINGS (QUOTE LEMMA) SATISFACTION-LEMMA-NAME) (QUOTE SOFT)))) (CHK-ARGLIST NAME ARGS) (SETQ BODY (TRANSLATE BODY)) (COND ((NOT IN-BOOT-STRAP-FLG) (CHK-MEANING NAME (ALL-FNNAMES BODY)))) (FREE-VAR-CHK NAME ARGS BODY) (for X in RELATION-MEASURE-LST do (COND ((NOT (AND (LISTP X) (MEMB (CAR X) WELL-ORDERING-RELATIONS) (LISTP (CDR X)) (NULL (CDDR X)) (SUBSETP (ALL-VARS (TRANSLATE (CADR X))) ARGS))) (ERROR1 (PQUOTE (PROGN EACH MEMBER OF THE THIRD ARGUMENT TO REFLECT MUST BE OF THE FORM (!PPR (QUOTE (REL TERM)) NIL) , WHERE REL IS THE NAME OF A WELL-FOUNDED RELATION AND TERM IS A TERM ALL OF WHOSE VARIABLES ARE AMONG THE FORMALS OF THE FUNCTION BEING DEFINED %.)) NIL (QUOTE SOFT))))) NIL]) (CHK-ACCEPTABLE-REWRITE-LEMMA [LAMBDA (NAME TYPE TERM) (* kbr: "20-Oct-85 15:53") TYPE (for X in (UNPRETTYIFY TERM) bind (TOP-FNNAME-VAR REWRITE-RULE LHS ALL-VARS-HYPS ALL-VARS-CONCL MAX-TERMS LST HYPS CONCL) do (SETQ HYPS (CAR X)) (SETQ CONCL (CDR X)) (SETQ TOP-FNNAME-VAR (TOP-FNNAME CONCL)) (COND ((ACCEPTABLE-TYPE-PRESCRIPTION-LEMMAP HYPS CONCL) T) ((NULL TOP-FNNAME-VAR) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE REWRITE LEMMA BECAUSE IT REWRITES A VARIABLE %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))) ((EQ TOP-FNNAME-VAR (QUOTE IF)) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE REWRITE LEMMA BECAUSE IT REWRITES AN IF-EXPRESSION %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))) ((FQUOTEP CONCL) NIL) ((AND (NOT NO-BUILT-IN-ARITH-FLG) (OR (BM-MATCH CONCL (NOT (LESSP & &))) (BM-MATCH CONCL (LESSP & &)))) (SETQ LST (EXTERNAL-LINEARIZE CONCL T)) (COND ((OR (NOT (AND LST (NULL (CDR LST)))) (NOT (AND (CAR LST) (NULL (CDR (CAR LST)))))) (ERROR1 (PQUOTE (PROGN LINEARIZE RETURNED A LIST OF MORE THAN ONE THING , EVEN THOUGH CALLED ON A LESSP NLISTP !)) NIL (QUOTE HARD)))) (SETQ ALL-VARS-HYPS (ALL-VARS-LST HYPS)) (SETQ ALL-VARS-CONCL (ALL-VARS CONCL)) (SETQ MAX-TERMS (for PAIR in (fetch (POLY ALIST) of (CAR (CAR LST))) when (AND (NVARIABLEP (CAR PAIR)) (SUBSETP ALL-VARS-CONCL (UNIONQ (ALL-VARS (CAR PAIR)) ALL-VARS-HYPS)) (for PAIR2 in (fetch (POLY ALIST) of (CAR (CAR LST))) when (NEQ PAIR2 PAIR) never (AND (LESSP (FORM-COUNT (CAR PAIR)) (FORM-COUNT (CAR PAIR2))) (SUBBAGP (ALL-VARS-BAG (CAR PAIR)) (ALL-VARS-BAG (CAR PAIR2)))))) collect (CAR PAIR))) (COND ((NULL MAX-TERMS) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN UNACCEPTABLE REWRITE LEMMA BECAUSE THE NLISTP OF ITS CONCLUSION IS A LESSP AND IT CANNOT BE HANDLED BY OUR LINEAR ARITHMETIC PACKAGE. TO BE ACCEPTABLE, AT LEAST ONE NONVARIABLE ADDEND OF THE CONCLUSION MUST SATISFY TWO PROPERTIES. FIRST, IT MUST CONTAIN ALL THE VARIABLES OF THE LEMMA THAT ARE NOT IN THE HYPOTHESES. SECOND, IT MUST NOT BE THE CASE THAT UNDER EVERY SUBSTITUTION, THE TERM IS SMALLER THAN ANOTHER ADDEND OF THE CONCLUSION. %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT)))) (for X in MAX-TERMS when (NON-RECURSIVE-DEFNP (FFN-SYMB X)) do (ERROR1 (PQUOTE (PROGN NOTE THAT THE LINEAR LEMMA (!PPR NAME NIL) IS BEING STORED UNDER THE TERM (!PPR X NIL) , WHICH IS UNUSUAL BECAUSE (!PPR FN NIL) IS A NONRECURSIVE FUNCTION SYMBOL %.)) (BINDINGS (QUOTE NAME) NAME (QUOTE X) X (QUOTE FN) (FFN-SYMB X)) (QUOTE WARNING))) (for X in MAX-TERMS when (NOT (SUBSETP ALL-VARS-HYPS (ALL-VARS X))) do (ERROR1 (PQUOTE (PROGN WHEN THE LINEAR LEMMA (!PPR NAME NIL) IS STORED UNDER (!PPR X NIL) IT CONTAINS THE FREE (PLURAL? VARS VARIABLES VARIABLE) (!LIST VARS) WHICH WILL BE CHOSEN BY INSTANTIATING THE (PLURAL? LST HYPOTHESES HYPOTHESIS) (!PPR-LIST LST) %.)) (BINDINGS (QUOTE NAME) NAME (QUOTE X) X (QUOTE VARS) (SET-DIFF ALL-VARS-HYPS (ALL-VARS X)) (QUOTE LST) (for HYP in HYPS bind (VARS _ (SET-DIFF ALL-VARS-HYPS (ALL-VARS X))) when (INTERSECTP VARS (ALL-VARS HYP)) collect (PROGN (SETQ VARS (SET-DIFF VARS (ALL-VARS HYP))) HYP))) (QUOTE WARNING))) T) (T (SETQ REWRITE-RULE (CREATE-REWRITE-RULE NAME HYPS CONCL NIL)) (SETQ ALL-VARS-HYPS (ALL-VARS-LST HYPS)) (SETQ ALL-VARS-CONCL (ALL-VARS (COND ((BM-MATCH CONCL (EQUAL LHS &)) LHS) (T CONCL)))) (COND ((NON-RECURSIVE-DEFNP (TOP-FNNAME CONCL)) (ERROR1 (PQUOTE (PROGN NOTE THAT THE REWRITE RULE (!PPR NAME NIL) WILL BE STORED SO AS TO APPLY ONLY TO TERMS WITH THE NONRECURSIVE FUNCTION SYMBOL (!PPR FN NIL) %.)) (BINDINGS (QUOTE NAME) NAME (QUOTE FN) (TOP-FNNAME CONCL)) (QUOTE WARNING)))) (COND ((NOT (SUBSETP ALL-VARS-HYPS ALL-VARS-CONCL)) (ERROR1 (PQUOTE (PROGN NOTE THAT (!PPR NAME NIL) CONTAINS THE FREE (PLURAL? VARS VARIABLES VARIABLE) (!LIST VARS) WHICH WILL BE CHOSEN BY INSTANTIATING THE (PLURAL? LST HYPOTHESES HYPOTHESIS) (!PPR-LIST LST) %.)) (BINDINGS (QUOTE NAME) NAME (QUOTE VARS) (SET-DIFF ALL-VARS-HYPS ALL-VARS-CONCL) (QUOTE LST) (for HYP in HYPS bind (VARS _ (SET-DIFF ALL-VARS-HYPS ALL-VARS-CONCL)) when (INTERSECTP VARS (ALL-VARS HYP)) collect (PROGN (SETQ VARS (SET-DIFF VARS (ALL-VARS HYP))) HYP))) (QUOTE WARNING))) ((AND (ATTEMPT-TO-REWRITE-RECOGNIZER CONCL) HYPS) (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) WILL SLOW DOWN THE THEOREM-PROVER BECAUSE IT WILL CAUSE BACKWARD CHAINING ON EVERY INSTANCE OF A PRIMITIVE TYPE EXPRESSION %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE WARNING)))) (for OLD-RULE in (GETPROP (TOP-FNNAME CONCL) (QUOTE LEMMAS)) unless (OR (DISABLEDP (fetch (REWRITE-RULE NAME) of OLD-RULE)) (META-LEMMAP OLD-RULE)) do (COND ((SUBSUMES-REWRITE-RULE OLD-RULE REWRITE-RULE) (ERROR1 (PQUOTE (PROGN THE PREVIOUSLY ADDED LEMMA , (!PPR OLDNAME NIL) , COULD BE APPLIED WHENEVER THE NEWLY PROPOSED (!PPR NAME NIL) COULD !)) (BINDINGS (QUOTE NAME) NAME (QUOTE OLDNAME) (fetch (REWRITE-RULE NAME) of OLD-RULE)) (QUOTE WARNING))) ((SUBSUMES-REWRITE-RULE REWRITE-RULE OLD-RULE) (ERROR1 (PQUOTE (PROGN THE NEWLY PROPOSED LEMMA , (!PPR NAME NIL) , COULD BE APPLIED WHENEVER THE PREVIOUSLY ADDED LEMMA (!PPR OLDNAME NIL) COULD %. // //)) (BINDINGS (QUOTE NAME) NAME (QUOTE OLDNAME) (fetch (REWRITE-RULE NAME) of OLD-RULE)) (QUOTE WARNING]) (CHK-ACCEPTABLE-SHELL [LAMBDA (SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (* kbr: "26-Nov-85 15:43") (LET (DESTRUCTOR-NAMES NAMES AXIOM-NAMES AC DV TR L FLG) (* Check that there is a type no  available. *) (NEXT-AVAILABLE-TYPE-NO) (for TUPLE in DESTRUCTOR-TUPLES unless (BM-MATCH TUPLE (LIST & & &)) do (ERROR1 (PQUOTE (PROGN THE DESTRUCTOR-TUPLES ARGUMENT TO ADD-SHELL MUST BE A LIST OF TRIPLES OF THE FORM (!PPR (QUOTE (NAME (FLG RECOGNIZER ...) DEFAULT-FN-SYMB)) NIL) WHERE NAME IS THE NAME OF THE ACCESSOR , FLG IS EITHER ONE-OF OR NONE-OF , AND DEFAULT-FN-SYMB IS THE FUNCTION SYMBOL FOR THE DEFAULT VALUE %.)) (BINDINGS) (QUOTE SOFT))) (SETQ DESTRUCTOR-NAMES (for TUPLE in DESTRUCTOR-TUPLES collect (CAR TUPLE))) (SETQ NAMES (CONS SHELL-NAME (CONS RECOGNIZER DESTRUCTOR-NAMES))) (COND (BTM-FN-SYMB (SETQ NAMES (CONS BTM-FN-SYMB NAMES)))) (for NAME in NAMES do (CHK-NEW-NAME NAME NIL) (CHK-NEW-*1*NAME NAME) (COND ((EQ (CAR (LAST (UNPACK NAME))) (QUOTE -)) (ERROR1 (PQUOTE (PROGN HYPHEN , AS IN (!PPR NAME NIL) , IS NOT ALLOWED AS THE LAST CHARACTER IN A SHELL NAME !)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))))) (COND ((NOT (NO-DUPLICATESP NAMES)) (ERROR1 (PQUOTE (PROGN MULTIPLE USE OF THE SAME NAME !)) (BINDINGS) (QUOTE SOFT)))) (for TUPLE in DESTRUCTOR-TUPLES do (BM-MATCH TUPLE (LIST AC TR DV)) (COND ((AND (NEQ DV (QUOTE TRUE)) (NEQ DV (QUOTE FALSE)) (NOT (MEMB DV *1*BTM-OBJECTS)) (OR (NULL BTM-FN-SYMB) (NEQ DV BTM-FN-SYMB))) (ERROR1 (PQUOTE (PROGN THE DEFAULT OBJECT FOR A TYPE-RESTRICTED SHELL COMPONENT MUST BE A BOTTOM OBJECT FUNCTION SYMBOL OR ELSE MUST BE TRUE OR FALSE ! (!PPR DV NIL) IS NOT SUCH AN OBJECT %.)) (BINDINGS (QUOTE DV) DV) (QUOTE SOFT)))) (COND ((NOT (AND (BM-MATCH TR (CONS FLG L)) (OR (EQ FLG (QUOTE ONE-OF)) (EQ FLG (QUOTE NONE-OF))) (for X in L always (ASSOC X (CONS (CONS RECOGNIZER 0) RECOGNIZER-ALIST))))) (ERROR1 (PQUOTE (PROGN THE TYPE RESTRICTION TERM FOR A SHELL COMPONENT MUST BE A LIST OF THE FORM (!PPR (QUOTE (ONE-OF ...)) NIL) OR (!PPR (QUOTE (NONE-OF ...)) NIL) WHERE ... IS A LIST OF RECOGNIZER NAMES %.)) NIL (QUOTE SOFT)))) (COND ((NOT (OR (AND (EQ DV BTM-FN-SYMB) (OR (AND (EQ FLG (QUOTE ONE-OF)) (MEMB RECOGNIZER L)) (AND (EQ FLG (QUOTE NONE-OF)) (NOT (MEMB RECOGNIZER L))))) (AND (NEQ DV BTM-FN-SYMB) (EQUAL (EQUAL FLG (QUOTE ONE-OF)) (LOGSUBSETP (CAR (TYPE-PRESCRIPTION DV)) (for X in L bind (LOOP-ANS _ 0) when (NEQ X RECOGNIZER) do (SETQ LOOP-ANS (LOGOR LOOP-ANS (CDR (ASSOC X RECOGNIZER-ALIST )))) finally (RETURN LOOP-ANS))))))) (ERROR1 (PQUOTE (PROGN THE DEFAULT VALUE (!PPR DV NIL) DOES NOT SATISFY THE TYPE RESTRICTION (!PPR TR NIL) SPECIFIED FOR THE (!PPR AC NIL) COMPONENT %.)) (BINDINGS (QUOTE TR) TR (QUOTE DV) DV (QUOTE AC) AC) (QUOTE SOFT))))) (COND (DESTRUCTOR-NAMES (for TUPLE in DESTRUCTOR-TUPLES do (BM-MATCH TUPLE (LIST AC TR DV)) (SETQ AXIOM-NAMES (CONS (PACK (LIST AC "-" SHELL-NAME)) AXIOM-NAMES)) (SETQ AXIOM-NAMES (CONS (PACK (LIST AC "-N" RECOGNIZER)) AXIOM-NAMES)) (AND (NOT (EQUAL TR (QUOTE (NONE-OF)))) (SETQ AXIOM-NAMES (CONS (PACK (LIST AC "-TYPE-RESTRICTION")) AXIOM-NAMES))) (SETQ AXIOM-NAMES (CONS (PACK (LIST AC "-LESSP")) AXIOM-NAMES)) (SETQ AXIOM-NAMES (CONS (PACK (LIST AC "-LESSEQP")) AXIOM-NAMES))) (SETQ AXIOM-NAMES (CONS (PACK (LIST SHELL-NAME "-EQUAL")) AXIOM-NAMES)) (SETQ AXIOM-NAMES (CONS (PACK (CONS SHELL-NAME (for AC in DESTRUCTOR-NAMES join (LIST "-" AC)))) AXIOM-NAMES)) (SETQ AXIOM-NAMES (CONS (PACK (NCONC1 (CDR (for AC in DESTRUCTOR-NAMES join (LIST "-" AC))) "-ELIM")) AXIOM-NAMES)) (SETQ AXIOM-NAMES (CONS (PACK (LIST "COUNT-" SHELL-NAME)) AXIOM-NAMES)))) (COND ((NOT (NO-DUPLICATESP (APPEND NAMES AXIOM-NAMES))) (ERROR1 (PQUOTE (PROGN THE ADDITION OF A SHELL INTRODUCES MANY NEW AXIOM NAMES %. THE NEW NAMES ARE CREATED FROM THE SHELL NAME , RECOGNIZER , BOTTOM OBJECT , AND DESTRUCTOR NAMES SUPPLIED IN THE ADD-SHELL COMMAND %. THE NAMES SUPPLIED IN THIS INSTANCE OF THE ADD-SHELL COMMAND DO NOT LEAD TO DISTINCT AXIOM NAMES %. THE AXIOM NAMES GENERATED ARE : (!LIST AXIOM-NAMES ) %.)) (BINDINGS (QUOTE AXIOM-NAMES) AXIOM-NAMES) (QUOTE SOFT)))) (for X in AXIOM-NAMES do (CHK-NEW-NAME X NIL)) T]) (CHK-ACCEPTABLE-TOGGLE [LAMBDA (NAME OLDNAME FLG) (* kbr: "19-Oct-85 16:31") (CHK-NEW-NAME NAME NIL) (MAIN-EVENT-OF OLDNAME) (OR (EQ FLG T) (EQ FLG NIL) (ERROR1 (PQUOTE (PROGN THE THIRD ARGUMENT OF TOGGLE MUST BE T OR NIL AND (!PPR FLG NIL) IS NOT %.)) (BINDINGS (QUOTE FLG) FLG) (QUOTE SOFT]) (CHK-ARGLIST [LAMBDA (NAME ARGS) (* kbr: "19-Oct-85 16:31") (COND ((OR (NOT (NO-DUPLICATESP ARGS)) (for ARG in ARGS thereis (OR (ILLEGAL-NAME ARG) (MEMB ARG (QUOTE (T F NIL))))) (CDR (LAST ARGS))) (* T and F are merely confusing, not  illegal. *) (ERROR1 (PQUOTE (PROGN THE ARGUMENT LIST TO (!PPR NAME NIL) , I.E., (!PPR ARGS NIL) , IS NOT A LIST OF DISTINCT VARIABLES NAMES %.)) (BINDINGS (QUOTE ARGS) ARGS (QUOTE NAME) NAME) (QUOTE SOFT]) (CHK-MEANING [LAMBDA (NAME LST) (* kbr: "19-Oct-85 16:31") (LET (FNS) (SETQ FNS (INTERSECTION LST META-NAMES)) (COND (FNS (ERROR1 (PQUOTE (PROGN USE OF THE (PLURAL? FNS FUNCTIONS FUNCTION) (!LIST FNS) IN AN AXIOM OR DEFINITION MAY RENDER THE THEORY INCONSISTENT %.)) (BINDINGS (QUOTE FNS) FNS) (QUOTE WARNING)))) NIL]) (CHK-NEW-*1*NAME [LAMBDA (NAME) (* kbr: "22-Oct-85 15:57") (COND ((OR (NOT (LITATOM (PACK (LIST STRING-WEIRD NAME)))) (AND (NOT IN-BOOT-STRAP-FLG) (OR (GETD (PACK (LIST STRING-WEIRD NAME))) (HAS-LIB-PROPS (PACK (LIST STRING-WEIRD NAME)))))) (ERROR1 (PQUOTE (PROGN THE NLISTP (!PPR FN NIL) , WHICH IS DERIVED FROM (!PPR NAME NIL) AND USED FOR INTERNAL PURPOSES , IS NOT A LITERAL ATOM, HAS A LISP FUNCTION DEFINITION OR LIB-PROP PROPERTIES %. YOU SHOULD CHANGE THE NAME OF YOUR FUNCTION TO AVOID CLASHES OF THIS SORT %.)) (BINDINGS (QUOTE NAME) NAME (QUOTE FN) (PACK (LIST STRING-WEIRD NAME))) (QUOTE SOFT]) (CHK-NEW-NAME [LAMBDA (NAME QUIET-FLG) (* kbr: "24-Oct-85 18:11") (* Checks that NAME has the correct syntax for use as a symbol in the theory  (and hence as an event name)%. Further checks that the name has no properties  and is not one of the symbols about which there are syntactic conventions  (e.g., LIST, CADR, NIL, QUOTE)%. Thus there are no axioms about NAME.  *) (COND ((ILLEGAL-NAME NAME) (COND (QUIET-FLG NIL) (T (ERROR1 (PQUOTE (PROGN (!PPR NAME NIL) IS AN ILLEGAL OBJECT TO USE FOR A NAME !)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))))) ((PROPERTYLESS-SYMBOLP NAME) (COND (QUIET-FLG NIL) (T (ERROR1 (PQUOTE (PROGN THE NAME (!PPR NAME NIL) IS A RESERVED SYMBOL AND CANNOT BE USED AS A USER NAME %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))))) ((HAS-LIB-PROPS NAME) (COND (QUIET-FLG NIL) (T (ERROR1 (PQUOTE (PROGN NAME CURRENTLY IN USE : (!PPR NAME NIL) %.)) (BINDINGS (QUOTE NAME) NAME) (COND (IN-BOOT-STRAP-FLG (QUOTE WARNING)) (T (QUOTE SOFT))))))) (T T]) (CLAUSIFY [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((EQUAL TERM TRUE) NIL) ((EQUAL TERM FALSE) (LIST NIL)) ((FNNAMEP-IF TERM) (CLEAN-UP-BRANCHES (STRIP-BRANCHES TERM))) (T (LIST (LIST TERM]) (CLAUSIFY-INPUT [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* In addition to clausifying TERM, we  expand ANDs in the hyps and ORs in the  concl, adding entries to  ABBREVIATIONS-USED. *) (for TERM1 in (CLAUSIFY-INPUT1 TERM FALSE) collect (CLAUSIFY-INPUT1 (DUMB-NEGATE-LIT TERM1) TRUE]) (CLAUSIFY-INPUT1 [LAMBDA (TERM BOOL) (* kbr: "19-Oct-85 16:31") (* If BOOL is TRUE, returns a list of terms whose disjunction is equivalent to  TERM. IF BOOL is FALSE, returns a list of terms whose disjunction is equivalent  to the negation of TERM. Opens up some nonrec fns and applies some  unconditional rewrite rules -- according to BOOL --  and side-effects ABBREVIATIONS-USED. *) (LET (C1 C2 C3) (COND ((EQUAL TERM (BM-NEGATE BOOL)) NIL) ((BM-MATCH TERM (COND ((C1 C2 C3)))) (COND ((EQUAL BOOL TRUE) (COND ((EQUAL C3 TRUE) (DISJOIN-CLAUSES (CLAUSIFY-INPUT1 C1 FALSE) (CLAUSIFY-INPUT1 C2 TRUE))) ((EQUAL C2 TRUE) (DISJOIN-CLAUSES (CLAUSIFY-INPUT1 C1 TRUE) (CLAUSIFY-INPUT1 C3 TRUE))) (T (LIST TERM)))) (T (COND ((EQUAL C3 FALSE) (DISJOIN-CLAUSES (CLAUSIFY-INPUT1 C1 FALSE) (CLAUSIFY-INPUT1 C2 FALSE))) ((EQUAL C2 FALSE) (DISJOIN-CLAUSES (CLAUSIFY-INPUT1 C1 TRUE) (CLAUSIFY-INPUT1 C3 FALSE))) (T (LIST (DUMB-NEGATE-LIT TERM))))))) ((SETQ C1 (EXPAND-AND-ORS TERM BOOL)) (CLAUSIFY-INPUT1 C1 BOOL)) ((EQUAL BOOL FALSE) (LIST (DUMB-NEGATE-LIT TERM))) (T (LIST TERM]) (CLEAN-UP-BRANCHES [LAMBDA (LST) (* kbr: "19-Oct-85 19:59") (LET (PARTITIONS) (SETQ PARTITIONS (PARTITION-CLAUSES LST)) (SETQ TEMP-TEMP (for POCKET in PARTITIONS join (ALMOST-SUBSUMES-LOOP POCKET))) (COND ((NULL (CDR PARTITIONS)) TEMP-TEMP) (T (ALMOST-SUBSUMES-LOOP TEMP-TEMP]) (CNF-DNF [LAMBDA (TERM FLG) (* kbr: "19-Oct-85 16:31") (* If FLG is (QUOTE C), returns a list of lists, say:  ((p11 p12 ...) (p21 p22 ...) ... (pn1 pn2 ...)) such that TERM is not equal to  F iff (AND (OR p11 p12 ...) (OR p21 p22 ...) ...  (OR pn1 pn2 ...)) is not equal to F. The latter term is the TERM.  If FLG is (QUOTE D) computes the disjunctive normal form.  *) (LET (P Q NF-Q) (COND ((OR (AND (EQ FLG (QUOTE C)) (BM-MATCH TERM (AND P Q))) (AND (EQ FLG (QUOTE D)) (BM-MATCH TERM (OR P Q)))) (APPEND (CNF-DNF P FLG) (CNF-DNF Q FLG))) ((OR (AND (EQ FLG (QUOTE C)) (BM-MATCH TERM (OR P Q))) (AND (EQ FLG (QUOTE D)) (BM-MATCH TERM (AND P Q)))) (SETQ NF-Q (CNF-DNF Q FLG)) (for L1 in (CNF-DNF P FLG) bind LOOP-ANS do (SETQ LOOP-ANS (UNION-EQUAL (for L2 in NF-Q collect (UNION-EQUAL L1 L2)) LOOP-ANS)) finally (RETURN LOOP-ANS))) ((BM-MATCH TERM (NOT P)) (for L1 in (CNF-DNF P (SELECTQ FLG (D (QUOTE C)) (QUOTE D))) collect (for TERM in L1 collect (DUMB-NEGATE-LIT TERM)))) ((BM-MATCH TERM (IMPLIES P Q)) (CNF-DNF (FCONS-TERM* (QUOTE OR) (DUMB-NEGATE-LIT P) Q) FLG)) (T (LIST (LIST TERM]) (COMMON-SWEEP [LAMBDA (FORM) (* kbr: "19-Oct-85 16:31") (LET (VAR DECISION) (COND ((OR (NLISTP FORM) (EQ (CAR FORM) (QUOTE QUOTE))) FORM) ((SETQ DECISION (ASSOC FORM DECISIONS)) (SETQ VAR (CDR (SASSOC FORM VAR-ALIST))) (SUBLIS (LIST (CONS (QUOTE VAR) VAR) (CONS (QUOTE FORM) (CONS (CAR FORM) (for ARG in (CDR FORM) collect (COMMON-SWEEP ARG))))) (SELECTQ (CDR DECISION) (TEST-AND-SET (QUOTE (*2*IF (NEQ VAR (QUOTE *1*X)) VAR (SETQ VAR FORM)))) (SET (QUOTE (SETQ VAR FORM))) (TEST (QUOTE (*2*IF (NEQ VAR (QUOTE *1*X)) VAR FORM))) (VAR (QUOTE VAR)) (ERROR (LIST (QUOTE COMMON-SWEEP) (CDR DECISION)))))) (T (CONS (CAR FORM) (for ARG in (CDR FORM) collect (COMMON-SWEEP ARG]) (COMMUTE-EQUALITIES [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) TERM) ((FQUOTEP TERM) TERM) ((EQ (FFN-SYMB TERM) (QUOTE EQUAL)) (FCONS-TERM* (QUOTE EQUAL) (FARGN TERM 2) (FARGN TERM 1))) (T (CONS-TERM (CAR TERM) (for ARG in (FARGS TERM) collect (COMMUTE-EQUALITIES ARG]) (COMPARE-STATS [LAMBDA (ALIST-NEW ALIST-OLD TOTALS-NEW TOTALS-OLD LST) (* kbr: "24-Oct-85 16:39") (* LST is a 4 tuple of integers indicating which events are considered  interesting. The first two numbers deal with the cons counts, the second two  with the cpu times. The first and third integers are percentages by which the  appropriate measures in NEW should differ from those of OLD.  The second and fourth are the absolute value of the differences between NEW and  OLD. An event must be both relatively and absolutely interesting to be printed  out. *) (OR LST (SETQ LST (QUOTE (10 1000 10 30)))) (COND ((NOT (AND (IEQP (LENGTH ALIST-NEW) (LENGTH ALIST-OLD)) (for PAIR-NEW in ALIST-NEW as PAIR-OLD in ALIST-OLD always (EQUAL (CAR PAIR-NEW) (CAR PAIR-OLD))))) [SETQ ALIST-NEW (SORT (for PAIR-NEW in ALIST-NEW when (for PAIR-OLD in ALIST-OLD thereis (EQUAL (CADAR PAIR-NEW) (CADAR PAIR-OLD))) collect PAIR-NEW) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CADAR X) (CADAR Y] [SETQ ALIST-OLD (SORT (for PAIR-OLD in ALIST-OLD when (for PAIR-NEW in ALIST-NEW thereis (EQUAL (CADAR PAIR-NEW) (CADAR PAIR-OLD))) collect PAIR-OLD) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CADAR X) (CADAR Y] (SETQ TOTALS-NEW (SUM-STATS-ALIST ALIST-NEW)) (SETQ TOTALS-OLD (SUM-STATS-ALIST ALIST-OLD)) (PRINEVAL (PQUOTE (PROGN THE TWO FILES DO NOT CONTAIN THE SAME SEQUENCE OF EVENT NAMES %. THE COMPARISON WILL BE ON THE INTERSECTION OF THE TWO SEQUENCES , WHICH HAS LENGTH (!PPR N NIL) %. // //)) (BINDINGS (QUOTE N) (LENGTH ALIST-NEW)) 0 T))) (IPRINC "OLD =" T) (IPRINC "NEW =" T) (ITERPRI T) (IPRINC "CONSES CPU GC IO ELAPSED" T) (ITERPRI T) (ITERPRI T) (for X in (LIST TOTALS-NEW TOTALS-OLD) as Y in (QUOTE (NEW OLD)) do (IPRINC Y T) (for PAIR in X as Z in (QUOTE ((FIX 12) (FLOAT 9 1) (FLOAT 9 1) (FLOAT 9 1) (FIX 12))) do (PRIN2 (CADR PAIR) T) (SPACES 3 T)) (ITERPRI T)) (ITERPRI T) (IPRINC "N/O" T) (for X in TOTALS-NEW as Y in TOTALS-OLD as Z in (QUOTE ((FLOAT 12 1) (FLOAT 9 1) (FLOAT 9 1) (FLOAT 9 1) (FLOAT 12 1))) do (PRIN2 (QUOTIENT (CADR X) (CADR Y)) T) (SPACES 3 T)) (ITERPRI T) (PRINEVAL (PQUOTE (PROGN // // EVENTS WHOSE CONS COUNTS ARE MORE THAN (!PPR X NIL) PERCENT AND (!PPR N NIL) CONSES DIFFERENT, PRINTED AS IQUOTIENT (N//O NEW OLD IQUOTIENT) AND ORDERED BY N//O : //)) (BINDINGS (QUOTE X) (CAR LST) (QUOTE N) (CADR LST)) 0 T) (PPRIND [DREVERSE (SORT (for X in ALIST-NEW as Y in ALIST-OLD when (AND (OR (GREATERP (QUOTIENT (CADR X) (CADR Y)) (QUOTIENT (PLUS 100 (CAR LST)) 100)) (LESSP (QUOTIENT (CADR X) (CADR Y)) (QUOTIENT (DIFFERENCE 100 (CAR LST)) 100))) (OR (GREATERP (CADR X) (PLUS (CADR Y) (CADR LST))) (LESSP (PLUS (CADR X) (CADR LST)) (CADR Y)))) collect (LIST (QUOTIENT (CADR X) (CADR Y)) (CONS (CADR (CAR X)) (CDR X)) (CONS (CADR (CAR Y)) (CDR Y)))) (FUNCTION (LAMBDA (X Y) (LESSP (CAR X) (CAR Y] 0 0 NIL T) (ITERPRI T) (PRINEVAL (PQUOTE (PROGN // // EVENTS WHOSE CPU TIMES ARE MORE THAN (!PPR X NIL) PERCENT AND (!PPR N NIL) SECONDS DIFFERENT, PRINTED AS IQUOTIENT (N//O NEW OLD IQUOTIENT) AND ORDERED BY N//O : //)) (BINDINGS (QUOTE X) (CADDR LST) (QUOTE N) (CADDDR LST)) 0 T) (PPRIND [DREVERSE (SORT (for X in ALIST-NEW as Y in ALIST-OLD when (AND (OR (GREATERP (QUOTIENT (CADDR X) (CADDR Y)) (QUOTIENT (PLUS 100 (CADDR LST)) 100)) (LESSP (QUOTIENT (CADDR X) (CADDR Y)) (QUOTIENT (DIFFERENCE 100 (CADDR LST)) 100))) (OR (GREATERP (CADDR X) (PLUS (CADDR Y) (CADDDR LST))) (LESSP (PLUS (CADDR X) (CADDDR LST)) (CADDR Y)))) collect (LIST (QUOTIENT (CADDR X) (CADDR Y)) (CONS (CADR (CAR X)) (CDR X)) (CONS (CADR (CAR Y)) (CDR Y)))) (FUNCTION (LAMBDA (X Y) (LESSP (CAR X) (CAR Y] 0 0 NIL T) (ITERPRI T]) (COMPLEMENTARY-MULTIPLEP [LAMBDA (WINNING-PAIR POLY1 POLY2) (* kbr: "19-Oct-85 16:31") (* Return T iff multiplying POLY1 by  some negative integer produces POLY2.  WINNING-PAIR is a member of POLY1 with  coefficient IPLUS or -1.0 *) (PROG (FACTOR) (COND ((NULL (SETQ TEMP-TEMP (SASSOC (CAR WINNING-PAIR) (fetch (POLY ALIST) of POLY2)))) (RETURN NIL))) (SETQ FACTOR (COND ((EQUAL (CDR WINNING-PAIR) 1) (CDR TEMP-TEMP)) (T (MINUS (CDR TEMP-TEMP))))) (COND ((NOT (LESSP FACTOR 0)) (RETURN NIL))) (RETURN (AND (EQUAL (fetch (POLY CONSTANT) of POLY2) (TIMES FACTOR (fetch (POLY CONSTANT) of POLY1))) (IEQP (LENGTH (fetch (POLY ALIST) of POLY2)) (LENGTH (fetch (POLY ALIST) of POLY1))) (for PAIR1 in (fetch (POLY ALIST) of POLY1) as PAIR2 in (fetch (POLY ALIST) of POLY2) always (AND (EQUAL (CAR PAIR1) (CAR PAIR2)) (EQUAL (CDR PAIR2) (TIMES FACTOR (CDR PAIR1]) (COMPLEMENTARYP [LAMBDA (LIT1 LIT2) (* kbr: "20-Oct-85 13:43") (* Is LIT2 the syntactic NOT of LIT1?  *) (OR (AND (NVARIABLEP LIT1) (NOT (FQUOTEP LIT1)) (EQ (FFN-SYMB LIT1) (QUOTE NOT)) (EQUAL (FARGN LIT1 1) LIT2)) (AND (NVARIABLEP LIT2) (NOT (FQUOTEP LIT2)) (EQ (FFN-SYMB LIT2) (QUOTE NOT)) (EQUAL (FARGN LIT2 1) LIT1]) (COMPLEXITY [LAMBDA (TERM) (* kbr: "24-Oct-85 15:49") (COND ((VARIABLEP TERM) 0) ((FQUOTEP TERM) (* The level number of all function symbols in evgs is 0, so even if we  recursed into them with FN-SYMBs and ARGS we'd compute 0.0 *) 0) (T (IPLUS (GET-LEVEL-NO (FFN-SYMB TERM)) (PROG (MAX) (SETQ MAX 0) (for ARG in (FARGS TERM) do (SETQ MAX (IMAX (COMPLEXITY ARG) MAX))) (RETURN MAX]) (COMPRESS-POLY [LAMBDA (POLY) (* kbr: "19-Oct-85 16:31") (COND ((IMPOSSIBLE-POLYP POLY) (replace (POLY ALIST) of POLY with NIL)) ((TRUE-POLYP POLY) (replace (POLY ALIST) of POLY with NIL)) (T (replace (POLY ALIST) of POLY with (COMPRESS-POLY1 (fetch (POLY ALIST) of POLY))))) POLY]) (COMPRESS-POLY1 [LAMBDA (ALIST) (* kbr: "20-Oct-85 15:44") (* Return ALIST with buckets whose  CDRs are 0 removed. *) (COND ((NLISTP ALIST) NIL) ((EQUAL (CDR (CAR ALIST)) 0) (COMPRESS-POLY1 (CDR ALIST))) (T (RPLACD ALIST (COMPRESS-POLY1 (CDR ALIST]) (COMPUTE-VETOES [LAMBDA (CANDLST) (* kbr: "19-Oct-85 16:31") (* This function weeds out behind the notion competing with it for  instantiation of its variables. What we actually do is throw out any candidate  whose changing induction variables -- that is the induction variables as  computed by INDUCT-VARS intersected with the changed vars of candidate --  intersect the changed or unchanged variables of another candidate.  The reason we do not care about the first candidates unchanging vars is as  follows. The reason you want a candidate clean is so that the terms riding on  that cand will reoccur in both the hypothesis and conclusion of an induction.  There are two ways to assure (or at least make likely) this, change the  variables in the terms as specified or leave them constant.  Thus, if the first cands changing vars are clean but its unchanging vars  intersect another cand it means that the first cand is keeping those other  terms constant which is fine. (Note that the first cand would be clean here.  The second might be clean or dirty depending on whether its changed vars or  unchanged vars intersected the first cands vars.) The reason we check only the  induction vars and not all of the changed vars is if cand1's changed vars  include some induction vars and some accumulators and the accumulators are  claimed by another cand2 we believe that cand1 is still clean.  The motivating example was (IMPLIES (MEMBER A C)  (MEMBER A (UNION: B C))) where the induction on C is dirty because the  induction on B and C claims C, but the induction on B and C is clean because  the B does not occur in the C induction.  We do not even bother to check the C from the  (B C) induction because since it is necessarily an accumulator it is probably  being constructed and thus, if it occurs in somebody elses ind vars it is  probably being eaten so it will be ok. In formulating this heuristic we did not  consider the possibility that the accums of one candidate occur as constants in  the other. Oh well. JULY 20, 1978.0 We have added an additional heuristic, to  be applied if the above one eliminates all cands.  We consider a cand flawed if it changes anyone elses constants.  The motivating example was GREATEST-FACTOR-LESSP --  which was previously proved only by virtue of a very ugly use of the no-op fn  ID to make a certain induction flawed. *) (OR (for CAND1 in CANDLST bind CHANGING-INDVARS unless (PROGN (SETQ CHANGING-INDVARS (INTERSECTION (fetch (CANDIDATE CHANGED-VARS) of CAND1) (INDUCT-VARS CAND1))) (for CAND2 in CANDLST when (NEQ CAND1 CAND2) thereis (OR (INTERSECTP CHANGING-INDVARS (fetch (CANDIDATE CHANGED-VARS) of CAND2)) (INTERSECTP CHANGING-INDVARS (fetch (CANDIDATE UNCHANGEABLE-VARS) of CAND2))))) collect CAND1) (for CAND1 in CANDLST bind CHANGING-VARS unless (PROGN (SETQ CHANGING-VARS (fetch (CANDIDATE CHANGED-VARS) of CAND1)) (for CAND2 in CANDLST when (NEQ CAND1 CAND2) thereis (INTERSECTP CHANGING-VARS (fetch (CANDIDATE UNCHANGEABLE-VARS) of CAND2)))) collect CAND1) CANDLST]) (COMSUBT1 [LAMBDA (T1) (* kbr: "19-Oct-85 16:31") (* We add to GENRLTLIST every common subterm t of T1 and T2 such that t has  property p, and no subterm of t has property p.  Property (p ITIMES) is ITIMES is not a variable and the function symbol of  ITIMES is not a btm object, constructor, or destructor.  We return T iff T1 is a common subterm of T2, but neither T1 nor any subterm of  T1 has property p. *) (PROG (FAILED) (COND ((OR (VARIABLEP T1) (FQUOTEP T1)) (RETURN (OCCUR T1 T2)))) (* After the following FOR, FAILED is set to T iff COMSUBT1 returned NIL on at  least one of the arguments of T1. GENRLTLIST now contains all of proper  subterms of T1 that occur in T2, have property p, and have no subterms with  property p, by inductive hypothesis. *) (for ARG in (FARGS T1) when (NOT (COMSUBT1 ARG)) do (SETQ FAILED T)) (COND (FAILED (* One of T1's arguments returned NIL. So either the argument is not a subterm  of T2, in which case neither is T1, or the argument or one of its subterms has  property p, in which case one of T1's subterms also has property p.  So we return NIL and do not add T1 to GENRLTLIST.  *) (RETURN NIL)) ((NOT (OCCUR T1 T2)) (* If T1 does not occur in T2, then its not a common subterm --  regardless of what properties its args have --  and so we return NIL and do not add T1 to GENRLTLIST.  *) (RETURN NIL)) ((AND (NOT (SHELLP T1)) (NOT (AND (SETQ TEMP-TEMP (GETPROP (FFN-SYMB T1) (QUOTE ELIMINATE-DESTRUCTORS-SEQ))) (NOT (DISABLEDP (fetch (REWRITE-RULE NAME) of TEMP-TEMP)))))) (* The test above checks that T1 has property p.  We know that T1 occurs in T2. We also know that every argument of T1  recursively returned T and so no argument nor any subterm has property p.  Therefore we add T1 to GENRLTLIST. We return NIL because T1 has property p.  *) (SETQ GENRLTLIST (ADD-TO-SET T1 GENRLTLIST)) (RETURN NIL)) (T (* T1 does not have property p.  It is a subterm of T2, and no subterm  of it has property p.  *) (RETURN T]) (COMSUBTERMS [LAMBDA (T1 T2) (* kbr: "19-Oct-85 16:31") (* We add to GENRLTLIST every common subterm t of T1 and T2 such that t has  property p, and no subterm of t has property p.  Property (p ITIMES) is ITIMES is not a variable and the function symbol of  ITIMES is not a btm object, constructor, or destructor.  *) (COND ((GREATERP (COUNT T1) (COUNT T2)) (swap T1 T2))) (COMSUBT1 T1]) (CONJOIN [LAMBDA (LST IF-FLG) (* kbr: "19-Oct-85 16:31") (COND ((NULL LST) TRUE) (T (CONJOIN2 (CAR LST) (CONJOIN (CDR LST) IF-FLG) IF-FLG]) (CONJOIN-CLAUSE-SETS [LAMBDA (LST1 LST2) (* kbr: "19-Oct-85 16:31") (LET (ANS) (for CL in LST1 when (AND (NOT (EQUAL CL TRUE-CLAUSE)) (NOT (MEMBER CL ANS))) do (SETQ ANS (CONS CL ANS))) (for CL in LST2 when (AND (NOT (EQUAL CL TRUE-CLAUSE)) (NOT (MEMBER CL ANS))) do (SETQ ANS (CONS CL ANS))) ANS]) (CONJOIN2 [LAMBDA (P Q IF-FLG) (* kbr: "19-Oct-85 16:31") (COND ((FALSE-NONFALSEP P) (COND (DEFINITELY-FALSE FALSE) ((FALSE-NONFALSEP Q) (COND (DEFINITELY-FALSE FALSE) (T TRUE))) ((NOT (BOOLEAN Q)) (FCONS-TERM* (QUOTE IF) Q TRUE FALSE)) (T Q))) ((FALSE-NONFALSEP Q) (COND (DEFINITELY-FALSE FALSE) ((BOOLEAN P) P) (T (FCONS-TERM* (QUOTE IF) P TRUE FALSE)))) (IF-FLG (FCONS-TERM* (QUOTE IF) P (COND ((BOOLEAN Q) Q) (T (FCONS-TERM* (QUOTE IF) Q TRUE FALSE))) FALSE)) (T (FCONS-TERM* (QUOTE AND) P Q]) (CONS-PLUS [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (COND ((EQUAL X ZERO) Y) ((EQUAL Y ZERO) X) (T (FCONS-TERM* (QUOTE PLUS) X Y]) (CONS-TERM [LAMBDA (FN ARGS) (* kbr: "19-Oct-85 16:31") (* After great deliberation, we have decided to guarantee throughout the  theorem-prover that every explicit value term should be represented as an evg.  Unless the function symbol of a term being constructed is known not to be a  constructor or bottom object, the term should be constructed using CONS-TERM  rather than with FCONS-TERM or FCONS-TERM*.  *) (COND ((AND (for ARG in ARGS always (QUOTEP ARG)) (OR (MEMB FN *1*BTM-OBJECTS) (ASSOC FN SHELL-ALIST))) (* We wish to apply the LISP-CODE for this shell constructor or btm object to  the guts of each arg and QUOTE the result.  To avoid having to cons up the list of guts, we will consider the common cases  separately. *) (COND ((NULL ARGS) (LIST (QUOTE QUOTE) (APPLY* (GETPROP FN (QUOTE LISP-CODE))))) ((NULL (CDR ARGS)) (LIST (QUOTE QUOTE) (APPLY* (GETPROP FN (QUOTE LISP-CODE)) (CADR (CAR ARGS))))) ((NULL (CDDR ARGS)) (LIST (QUOTE QUOTE) (APPLY* (GETPROP FN (QUOTE LISP-CODE)) (CADR (CAR ARGS)) (CADR (CADR ARGS))))) ((NULL (CDDDR ARGS)) (LIST (QUOTE QUOTE) (APPLY* (GETPROP FN (QUOTE LISP-CODE)) (CADR (CAR ARGS)) (CADR (CADR ARGS)) (CADR (CADDR ARGS))))) (T (LIST (QUOTE QUOTE) (APPLY (GETPROP FN (QUOTE LISP-CODE)) (for ARG in ARGS collect (CADR ARG))))))) (T (CONS FN ARGS]) (CONSJOIN [LAMBDA (LST) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP (CDR LST)) (CAR LST)) (T (CONS-TERM (QUOTE CONS) (LIST (CAR LST) (CONSJOIN (CDR LST]) (CONTAINS-REWRITEABLE-CALLP [LAMBDA (NAME TERM) (* kbr: "19-Oct-85 16:31") (* This function scans the nonQUOTE  part of TERM and determines whether it  contains a call of NAME not on  TERMS-TO-BE-IGNORED-BY-REWRITE.  *) (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) NIL) ((AND (EQ (FFN-SYMB TERM) NAME) (NOT (MEMBER TERM TERMS-TO-BE-IGNORED-BY-REWRITE))) T) (T (for X in (FARGS TERM) thereis (CONTAINS-REWRITEABLE-CALLP NAME X]) (CONVERT-CAR-CDR [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (ANS (GUTS X)) (while (OR (BM-MATCH GUTS (CAR &)) (BM-MATCH GUTS (CDR &))) do (SETQ ANS (CONS (NTHCHAR (CAR GUTS) 2) ANS)) (SETQ GUTS (CADR GUTS))) (COND ((IGREATERP (LENGTH ANS) 1) (LIST (PACK (CONS (QUOTE C) (DREVERSE (CONS (QUOTE R) ANS)))) GUTS)) (T X]) (CONVERT-CONS [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((SETQ TEMP-TEMP (LISTABLE X)) (APPEND (QUOTE (LIST)) TEMP-TEMP)) (T X]) (CONVERT-NOT [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (U V) (COND ((BM-MATCH X (NOT (LESSP U V))) (LIST (QUOTE LEQ) V U)) (T X]) (CONVERT-QUOTE [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (SETQ PPR-MACRO-LST NIL) (COND ((EQ (CADR X) *1*T) T) ((EQ (CADR X) *1*F) (QUOTE F)) ((FIXP (CADR X)) (CADR X)) ((EQ (CADR X) NIL) NIL) ((AND (LISTP (CADR X)) (EQ (CAR (CADR X)) *1*SHELL-QUOTE-MARK)) (CONS (CADR (CADR X)) (for ARG in (CDDR (CADR X)) collect (CONVERT-QUOTE (LIST (QUOTE QUOTE) ARG))))) (T X]) (CONVERT-TYPE-NO-TO-RECOGNIZER-TERM [LAMBDA (TYPE-NO ARG) (* kbr: "19-Oct-85 16:31") (LET (TYPE-SET) (SETQ TYPE-SET (LOGBIT TYPE-NO)) (COND ((SETQ TEMP-TEMP (for PAIR in RECOGNIZER-ALIST when (IEQP TYPE-SET (CDR PAIR)) do (RETURN PAIR))) (FCONS-TERM* (CAR TEMP-TEMP) ARG)) (T (ERROR1 (PQUOTE (PROGN CONVERT-TYPE-NO-TO-RECOGNIZER-TERM CALLED WITH A NUMBER NOT ASSIGNED AS A TYPE NO !)) (BINDINGS) (QUOTE HARD]) (BM-COUNT [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP X) 0) (T (PLUS 1 (COUNT (CAR X)) (COUNT (CDR X]) (COUNT-IFS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) 0) ((FQUOTEP TERM) 0) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (ADD1 (for ARG in (FARGS TERM) sum (COUNT-IFS ARG)))) (T (for ARG in (FARGS TERM) sum (COUNT-IFS ARG]) (CREATE-REWRITE-RULE [LAMBDA (NAME HYPS CONCL LOOP-STOPPER-ARG) (* kbr: "19-Oct-85 16:31") (create REWRITE-RULE NAME _ NAME HYPS _ (PREPROCESS-HYPS HYPS) CONCL _ CONCL LOOP-STOPPER _ (OR LOOP-STOPPER-ARG (LOOP-STOPPER CONCL]) (DCL0 [LAMBDA (NAME ARGS) (* kbr: "19-Oct-85 16:31") (ADD-FACT NAME (QUOTE TYPE-PRESCRIPTION-LST) (CONS NAME (CONS TYPE-SET-UNKNOWN (for X in ARGS collect NIL)))) (ADD-FACT NAME (QUOTE LEVEL-NO) 0]) (DECODE-IDATE [LAMBDA (N) (* kbr: "19-Oct-85 16:31") (POWER-REP N 100.0]) (DEFN-ASSUME-TRUE-FALSE [LAMBDA (TERM) (* kbr: "24-Oct-85 15:34") (LET (TYPE-ARG1 TYPE-ARG2 TRUE-SEG FALSE-SEG PAIR ARG1 ARG2 INTERSECTION LOCAL-MUST-BE-TRUE LOCAL-MUST-BE-FALSE) (COND ((AND (NVARIABLEP TERM) (NOT (FQUOTEP TERM)) (SETQ PAIR (ASSOC (FFN-SYMB TERM) RECOGNIZER-ALIST))) (SETQ TYPE-ARG1 (DEFN-TYPE-SET (FARGN TERM 1))) (COND ((AND (NULL (CDR TYPE-ARG1)) (IEQP 0 (LOGAND (CAR TYPE-ARG1) (CDR PAIR)))) (SETQ LOCAL-MUST-BE-FALSE T)) ((AND (NULL (CDR TYPE-ARG1)) (LOGSUBSETP (CAR TYPE-ARG1) (CDR PAIR))) (SETQ LOCAL-MUST-BE-TRUE T)) (T (SETQ TRUE-SEG (LIST (CONS (FARGN TERM 1) (CONS (CDR PAIR) NIL)))) (SETQ FALSE-SEG (LIST (CONS (FARGN TERM 1) (CONS (LOGAND (CAR TYPE-ARG1) (LOGNOT (CDR PAIR))) (CDR TYPE-ARG1)))))))) ((BM-MATCH TERM (EQUAL ARG1 ARG2)) (SETQ TYPE-ARG1 (DEFN-TYPE-SET ARG1)) (SETQ TYPE-ARG2 (DEFN-TYPE-SET ARG2)) (SETQ INTERSECTION (LOGAND (CAR TYPE-ARG1) (CAR TYPE-ARG2))) (COND ((AND (IEQP 0 INTERSECTION) (NULL (CDR TYPE-ARG1)) (NULL (CDR TYPE-ARG2))) (SETQ LOCAL-MUST-BE-FALSE T)) ((AND (NULL (CDR TYPE-ARG1)) (NULL (CDR TYPE-ARG2)) (IEQP (CAR TYPE-ARG1) (CAR TYPE-ARG2)) (MEMBER (CAR TYPE-ARG1) SINGLETON-TYPE-SETS)) (SETQ LOCAL-MUST-BE-TRUE T)) ((AND (EQUAL TYPE-ARG1 TYPE-ARG2) (IEQP 0 (CAR TYPE-ARG1)) (IEQP (LENGTH (CDR TYPE-ARG1)) 1)) (SETQ LOCAL-MUST-BE-TRUE T)) (T (SETQ TRUE-SEG (LIST (CONS TERM (CONS TYPE-SET-TRUE NIL)))) (COND ((NOT (IEQP (CAR TYPE-ARG1) INTERSECTION)) (SETQ TRUE-SEG (CONS (CONS ARG1 (CONS INTERSECTION (CDR TYPE-ARG1))) TRUE-SEG)))) (COND ((NOT (IEQP (CAR TYPE-ARG2) INTERSECTION)) (SETQ TRUE-SEG (CONS (CONS ARG2 (CONS INTERSECTION (CDR TYPE-ARG2))) TRUE-SEG)))) (SETQ FALSE-SEG (LIST (CONS TERM (CONS TYPE-SET-FALSE NIL)))) (COND ((AND (MEMBER (CAR TYPE-ARG2) SINGLETON-TYPE-SETS) (NULL (CDR TYPE-ARG2))) (SETQ FALSE-SEG (CONS (CONS ARG1 (CONS (LOGAND (CAR TYPE-ARG1) (LOGNOT (CAR TYPE-ARG2))) (CDR TYPE-ARG1))) FALSE-SEG)))) (COND ((AND (MEMBER (CAR TYPE-ARG1) SINGLETON-TYPE-SETS) (NULL (CDR TYPE-ARG1))) (SETQ FALSE-SEG (CONS (CONS ARG2 (CONS (LOGAND (CAR TYPE-ARG2) (LOGNOT (CAR TYPE-ARG1))) (CDR TYPE-ARG2))) FALSE-SEG)))) (COND ((AND (IEQP 0 (CAR TYPE-ARG2)) (IEQP (LENGTH (CDR TYPE-ARG2)) 1) (MEMB (CADR TYPE-ARG2) (CDR TYPE-ARG1))) (SETQ FALSE-SEG (CONS (CONS ARG1 (CONS (CAR TYPE-ARG1) (REMOVE (CADR TYPE-ARG2) (CDR TYPE-ARG1)))) FALSE-SEG)))) (COND ((AND (IEQP 0 (CAR TYPE-ARG1)) (IEQP (LENGTH (CDR TYPE-ARG1)) 1) (MEMB (CADR TYPE-ARG1) (CDR TYPE-ARG2))) (SETQ FALSE-SEG (CONS (CONS ARG2 (CONS (CAR TYPE-ARG2) (REMOVE (CADR TYPE-ARG1) (CDR TYPE-ARG2)))) FALSE-SEG))))))) (T (SETQ TYPE-ARG1 (DEFN-TYPE-SET TERM)) (COND ((AND (IEQP (CAR TYPE-ARG1) TYPE-SET-FALSE) (NULL (CDR TYPE-ARG1))) (SETQ LOCAL-MUST-BE-FALSE T)) ((AND (NULL (CDR TYPE-ARG1)) (IEQP 0 (LOGAND (CAR TYPE-ARG1) TYPE-SET-FALSE))) (SETQ LOCAL-MUST-BE-TRUE T)) (T (SETQ TRUE-SEG (LIST (CONS TERM (CONS (LOGAND (CAR TYPE-ARG1) (LOGNOT TYPE-SET-FALSE)) (CDR TYPE-ARG1))))) (SETQ FALSE-SEG (LIST (CONS TERM (CONS TYPE-SET-FALSE NIL)))))))) (SETQ TRUE-TYPE-ALIST (NCONC TRUE-SEG TYPE-ALIST)) (SETQ FALSE-TYPE-ALIST (NCONC FALSE-SEG TYPE-ALIST)) (SETQ MUST-BE-TRUE LOCAL-MUST-BE-TRUE) (SETQ MUST-BE-FALSE LOCAL-MUST-BE-FALSE) NIL]) (DEFN-LOGIOR [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (CONS (LOGOR (CAR X) (CAR Y)) (UNIONQ (CDR X) (CDR Y]) (DEFN-SETUP [LAMBDA (EVENT) (* kbr: "19-Oct-85 16:31") (SETQ ORIGEVENT EVENT) (SETQ LAST-PROCESS (QUOTE SETUP)) (COND ((NOT (MEMBER ORIGEVENT FAILED-THMS)) (SETQ FAILED-THMS (CONS ORIGEVENT FAILED-THMS)))) (SETQ EXPAND-LST HINTED-EXPANSIONS) (SETQ TERMS-TO-BE-IGNORED-BY-REWRITE NIL) (SETQ INDUCTION-HYP-TERMS NIL) (SETQ INDUCTION-CONCL-TERMS NIL) (SETQ STACK NIL) (SETQ FNSTACK NIL) (SETQ TYPE-ALIST NIL) (SETQ LITS-THAT-MAY-BE-ASSUMED-FALSE NIL) (SETQ CURRENT-LIT 0) (SETQ CURRENT-ATM 0) (SETQ ANCESTORS NIL) (INIT-LEMMA-STACK) (INIT-LINEARIZE-ASSUMPTIONS-STACK) (SETQ LAST-PRINEVAL-CHAR NIL) (RANDOM-INITIALIZATION ORIGEVENT) EVENT]) (DEFN-TYPE-SET [LAMBDA (TERM) (* kbr: "24-Oct-85 15:44") (COND ((SETQ TEMP-TEMP (SASSOC TERM TYPE-ALIST)) (CDR TEMP-TEMP)) ((VARIABLEP TERM) (ERROR1 (PQUOTE (PROGN DEFN-TYPE-SET HAS FOUND AN UNBOUND VARIABLE IN THE TERM (!PPR TERM NIL) %.)) (BINDINGS (QUOTE TERM) TERM) (QUOTE HARD))) ((EQ (FN-SYMB TERM) (QUOTE IF)) (DEFN-ASSUME-TRUE-FALSE (FARGN TERM 1)) (COND (MUST-BE-TRUE (DEFN-TYPE-SET (FARGN TERM 2))) (MUST-BE-FALSE (DEFN-TYPE-SET (FARGN TERM 3))) (T (DEFN-LOGIOR (DEFN-TYPE-SET2 (FARGN TERM 2) TRUE-TYPE-ALIST) (DEFN-TYPE-SET2 (FARGN TERM 3) FALSE-TYPE-ALIST))))) ((SETQ TEMP-TEMP (TYPE-PRESCRIPTION (FN-SYMB TERM))) (DEFN-LOGIOR (CONS (CAR TEMP-TEMP) NIL) (COND ((CDR TEMP-TEMP) (for ARG in (SARGS TERM) as FLG in (CDR TEMP-TEMP) bind ANS first (SETQ ANS (CONS 0 NIL)) when FLG do (SETQ ANS (DEFN-LOGIOR (DEFN-TYPE-SET ARG) ANS)) finally (RETURN ANS))) (T (CONS 0 NIL))))) (T (CONS TYPE-SET-UNKNOWN NIL]) (DEFN-TYPE-SET2 [LAMBDA (TERM TYPE-ALIST) (* kbr: "19-Oct-85 16:31") (LET (FALSE-TYPE-ALIST) (DEFN-TYPE-SET TERM]) (DEFN-WRAPUP [LAMBDA (WON-FLG) (* kbr: "19-Oct-85 16:31") (SETQ WON-FLG (COND (WON-FLG (QUOTE DEFN-OK)) (T NIL))) (COND ((NEQ LEMMA-STACK ORIG-LEMMA-STACK) (ITERPRI T) (ERROR1 (PQUOTE (PROGN DEFN-WRAPUP FOUND A NON-TRIVIAL LEMMA-STACK !)) (BINDINGS) (QUOTE WARNING)))) (COND ((NEQ LINEARIZE-ASSUMPTIONS-STACK ORIG-LINEARIZE-ASSUMPTIONS-STACK) (ITERPRI T) (ERROR1 (PQUOTE (PROGN DEFN-WRAPUP FOUND A NON-TRIVIAL LINEARIZE-ASSUMPTIONS-STACK !)) (BINDINGS) (QUOTE WARNING)))) (COND (WON-FLG (SETQ FAILED-THMS (REMOVE ORIGEVENT FAILED-THMS)) (SETQ PROVED-THMS (CONS ORIGEVENT PROVED-THMS)))) (IO (QUOTE FINISHED) NIL NIL NIL (LIST WON-FLG]) (DEFN0 [LAMBDA (NAME ARGS BODY RELATION-MEASURE-LST FLG) (* kbr: " 4-Jul-86 18:16") (LET (TRANSLATED-BODY CONTROL-VARS (ARITY-ALIST (CONS (CONS NAME (LENGTH ARGS)) ARITY-ALIST)) (META-NAMES (CONS NAME META-NAMES))) (* The list of comments on this function do not necessarily describe the code  below. They have been left around in reverse chronology order to remind us of  the various combinations of preprocessing we have tried.  If we ever get blown out of the water while normalizing IFs in a large defn,  read the following comment before abandoning normalization.  18 August 1982.0 Here we go again! At the time of this writing the  preprocessing of defns is as follows, we compute the induction and type info on  the translated body and store under sdefn the translated body.  This seems to slow down the system a lot and we are going to change it so that  we store under sdefn the result of expanding boot strap nonrec fns and  normalizing IFs. As nearly as we can tell from the comments below, we have not  previously tried this. According to the record, we have tried expanding all  nonrec fns, and we have tried expanding boot strap fns and doing a little  normalization. The data that suggests this will speed things up is as follows.  Consider the first call of SIMPLIFY-CLAUSE in the proof of  PRIME-LIST-TIMES-LIST. The first three literals are trivial but the fourth call  of SIMPLIFY-CLAUSE1 is on (NOT (PRIME1 C  (SUB1 C)))%. With SDEFNs not expanded and normalized --  i.e., under the processing as it was immediately before the current change --  there are 2478 calls of REWRITE and 273 calls of RELIEVE-HYPS for this literal.  With all defns preprocessed as described here those counts drop to 1218 and  174.0 On a sample of four theorems, PRIME-LIST-TIMES-LIST,  PRIME-LIST-PRIME-FACTORS, FALSIFY1-FALSIFIES, and ORDERED-SORT, the use of  normalized and expanded sdefns saves us 16\ of the conses over the use of  untouched sdefns, reducing the cons counts for those theorems from 880K to  745K. It seems unlikely that this preprocessing will blow us out of the water  on large defns. For the EV used in UNSOLV and for the 386L M with subroutine  call this new preprocessing only marginally increases the size of the sdefn.  It would be interesting to see a function that blows us out of the water.  When one is found perhaps the right thing to do is to so preprocess small defns  and leave big ones alone. 17 December 1981.0 Henceforth we will assume that the  very body the user supplies (modulo translation) is the body that the  theorem-prover uses to establish that there is one and only one function  satisfying the definition equation by determining that the given body provides  a method for computing just that function.  This prohibits our such as (f ITIMES) IEQP  (if (f ITIMES) a a) to (f ITIMES) IEQP a.  18 November 1981.0 We are sick of having to disable nonrec fns in order to get  large fns processed, e.g., the interpreter for our 386L class.  Thus, we have decided to adopt the policy of not touching the user's typein  except to TRANSLATE it. The induction and type analysis as well as the final  SDEFN are based on the translated typein.  Before settling with the preprocessing used below we tried several different  combinations and did provealls. The main issue was whether we should normalize  sdefns. Unfortunately, the incorporation of META0-LEMMAS was also being  experimented with, and so we do not have a precise breakdown of who is  responsible for what. However, below we give the total stats for three separate  provealls. The first, called 1PROVEALL, contained exactly the code below --  except that the ADD-DCELL was given the SDEFN with all the fn names replaced by  1fns instead of a fancy TRANSLATE-TO-INTERLISP call.  Here are the 1PROVEALL stats. Elapsed time IEQP 9532.957, CPU time IEQP  4513.88, GC time IEQP 1423.261, IO time IEQP 499.894, CONSes consumed IEQP  6331517.0 We then incorporated META0-LEMMAS.  Simultaneously, we tried running the RUN fns through DEFN and found that we  exploded. The expansion of nonrec fns and the normalization of IFs before the  induction analysis transformed functions of COUNT 300 to functions of COUNT  exceeding 18K. We therefore decided to expand only BOOT-STRAP fns --  and not NORMALIZE-IFS for the purposes of induction analysis.  After the induction and type analyses were done, we put down an SDEFN with some  trivial IF simplification performed -- e.g., IF X Y Y => Y and IF bool T F =>  bool -- but not a NORMALIZE-IFs version.  We then ran a proveall with CANCEL around as a META0-LEMMA.  The result was about 20\ slower than the 1PROVEALL and used 15\ more CONSes.  At first this was attributed to CANCEL. However, we then ran two simultaneous  provealls, one with META0-LEMMAS set to NIL and one with it set to  ((1CANCEL))%. The result was that the version with CANCEL available used  slightly fewer CONSes than the other one --  7303311 to 7312505 That was surprising because the implementation of  META0-LEMMAS uses no CONSes if no META0-LEMMAS are available, so the entire 15\  more CONSes had to be attributed to the difference in the defn processing.  This simultaneous run was interesting for two other reasons.  The times -- while still 20\ worse than 1PROVEALL --  were one half of one percent different, with CANCEL being the slower.  That means having CANCEL around does not cost much at all --  and the figures are significant despite the slop in the operating system's  timing due to thrashing because the two jobs really were running  simultaneously. The second interesting fact is that CANCEL can be expected to  save us a few CONSes rather than cost us.  We therefore decided to return the DEFN0 processing to its original state.  Only we did it in two steps. First, we put NORMALIZE-IFs into the pre-induction  processing and into the final SDEFN processing.  Here are the stats on the resulting proveall, which was called  PROVEALL-WITH-NORM-AND-CANCEL but not saved.  Elapsed time IEQP 14594.01, CPU time IEQP 5024.387, GC time IEQP 1519.932, IO  time IEQP 593.625, CONSes consumed IEQP 6762620.0 While an improvement, we were  still 6\ worse than 1PROVEALL on CONSes.  But the only difference between 1PROVEALL and PROVEALL-WITH-NORM-AND-CANCEL --  if you discount CANCEL which we rightly believed was paying for itself --  was that in the former induction analyses and type prescriptions were being  computed from fully expanded bodies while in the latter they were computed from  only BOOT-STRAP-expanded bodies. We did not believe that would make a  difference of over 400,000 CONSes, but had nothing else to believe.  So we went to the current state, where we do the induction and type analyses on  the fully expanded and normalized bodies --  bodies that blow us out of the water on some of the RUN fns.  Here are the stats for PROVEALL-PROOFS.79101, which was the proveall for that  version. Elapsed time IEQP 21589.84, CPU time IEQP 4870.231, GC time IEQP  1512.813, IO time IEQP 554.292, CONSes consumed= 6356282.0 Note that we are  within 25K of the number of CONSes used by 1PROVEALL.  But to TRANSLATE-TO-INTERLISP all of the defns in question costs 45K.  So -- as expected -- CANCEL actually saved us a few CONSes by shortening  proofs. It takes only 18 seconds to TRANSLATE-TO-INTERLISP the defns, so a  similar argument does not explain why the latter proveall is 360 seconds slower  than 1PROVEALL. But since the elapsed time is over twice as long, we believe it  is fair to chalk that time up to the usual slop involved in measuring cpu time  on a time sharing system. We now explain the formal justification of the  processing we do on the body before testing it for admissibility.  We do not work with the body that is typed in by the user but with an  equivalent body' produced by normalization and the expansion of nonrecursive  function calls in body. We now prove that if  (under no assumptions about NAME except that it is a function symbol of the  correct arity) (a) body is equivalent to body' and  (b) (name) IEQP body' is accepted under our principle of definition, then there  exists exactly one function satisfying the original equation  (name) IEQP body. First observe that since the definition  (name) IEQP body' is accepted by our principle of definition, there exists a  function satisfying that equation. But the accepted equation is equivalent to  the equation (name) IEQP body by the hypothesis that body is equivalent to  body'. We prove that there is only one such function by induction.  Assume that the definition (name) IEQP body has been accepted under the  principle of definition. Suppose that f is a new name and that  (f) IEQP bodyf, where bodyf results from replacing every use of name as a  function symbol in body with f. It follows that  (f) IEQP bodyf', where bodyf' results from replacing every use of name as a  function symbol in body' with f. We can now easily prove that  (f) IEQP (name) by induction according to the definition of name.  Q.E.D. One might be tempted to think that if the defn with body' is accepted  under the principle of definition then so would be the defn with body and that  the use of body' was merely to make the implementation of the defn principle  more powerful. This is not the case. For example  (R X) IEQP (IF (R X) T T) is not accepted by the definitional principle, but we  would accept the body'-version (R X) IEQP T, and by our proof, that function  uniquely satisfies the equation the user typed in.  One might be further tempted to think that if we changed normalize so that  (IF X Y Y) IEQP Y was not applied, then the two versions were inter-acceptable  under the defn principle. This is not the case either.  The function (F X) IEQP (IF (IF (X.ne.0)  (F X-1) F) (F X-1) T) is not accepted under the principle of defn.  Consider its normalized body. *) (DEFN-SETUP (LIST (QUOTE DEFN) NAME ARGS BODY RELATION-MEASURE-LST)) (SETQ TRANSLATED-BODY (TRANSLATE BODY)) (SETQ RELATION-MEASURE-LST (for TEMP in RELATION-MEASURE-LST collect (LIST (CAR TEMP) (TRANSLATE (CADR TEMP))))) (PUT-INDUCTION-INFO NAME ARGS TRANSLATED-BODY RELATION-MEASURE-LST NIL) (ADD-FACT NAME (QUOTE SDEFN) (LIST (QUOTE LAMBDA) ARGS (NORMALIZE-IFS (EXPAND-BOOT-STRAP-NON-REC-FNS TRANSLATED-BODY) NIL NIL))) (PUT-TYPE-PRESCRIPTION NAME) (PUT-LEVEL-NO NAME) (* CONTROLLER-POCKETS of NAME is a  list of bit encodings.  Each bit encoding summarizes a SUBSET  of some JUSTIFICATION for NAME to  terminate. *) (AND (GETPROP NAME (QUOTE JUSTIFICATIONS)) (ADD-FACT NAME (QUOTE CONTROLLER-POCKETS) (SCRUNCH (for TEMP in (GETPROP NAME (QUOTE JUSTIFICATIONS)) collect (PROGN (SETQ CONTROL-VARS (fetch (JUSTIFICATION SUBSET) of TEMP)) (for FORMAL in ARGS as I from 0 bind (LOOP-ANS _ 0) when (MEMB FORMAL CONTROL-VARS ) do (SETQ LOOP-ANS (LOGOR LOOP-ANS (LSH 1 I))) finally (RETURN LOOP-ANS))))))) (COND (FLG (ADD-FACT NAME (QUOTE LISP-CODE) (PACK (LIST STRING-WEIRD NAME)))) ((for FN in (ALL-FNNAMES TRANSLATED-BODY) always (OR (EQ FN NAME) (GETPROP FN (QUOTE LISP-CODE)))) (ADD-DCELL NAME (PACK (LIST STRING-WEIRD NAME)) (LIST (QUOTE LAMBDA) (SETQ TEMP-TEMP (for ARG in ARGS collect (PACK (LIST STRING-WEIRD3 ARG)))) (TRANSLATE-TO-LISP (SUB-PAIR-VAR ARGS TEMP-TEMP TRANSLATED-BODY)))))) (COND ((NOT (TOTAL-FUNCTIONP NAME)) (ERROR1 (PQUOTE (PROGN THE RECURSION IN (!PPR NAME NIL) IS UNJUSTIFIED %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE WARNING)))) NIL]) (DELETE1 [LAMBDA (X L) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP L) NIL) ((EQUAL X (CAR L)) (CDR L)) (T (CONS (CAR L) (DELETE1 X (CDR L]) (DELETE-TAUTOLOGIES [LAMBDA (CLAUSE-SET) (* kbr: "19-Oct-85 16:31") (for CL in CLAUSE-SET unless (for TAIL on CL thereis (OR (AND (FALSE-NONFALSEP (CAR TAIL)) (NOT DEFINITELY-FALSE)) (MEMBER (NEGATE-LIT (CAR TAIL)) (CDR TAIL)))) collect CL]) (DELETE-TOGGLES [LAMBDA (XXX) (* kbr: "19-Oct-85 16:31") (for X in XXX bind N collect (COND ((BM-MATCH X (TOGGLE & N (QUOTE T))) (LIST (QUOTE DISABLE) N)) ((OR (BM-MATCH X (TOGGLE & N (QUOTE NIL))) (BM-MATCH X (TOGGLE & N))) (LIST (QUOTE ENABLE) N)) (T X]) (DEPEND [LAMBDA (DEPENDENT SUPPORTERS) (* kbr: "19-Oct-85 16:31") (COND ((NOT (GETPROP DEPENDENT (QUOTE EVENT))) (ERROR1 (PQUOTE (PROGN DEPEND SHOULD NOT BE CALLED ON A NONEVENT SUCH AS (!PPR DEPENDENT NIL) %.)) (BINDINGS (QUOTE DEPENDENT) DEPENDENT) (QUOTE HARD)))) (SETQ SUPPORTERS (REMOVE (QUOTE GROUND-ZERO) (for X in SUPPORTERS bind LOOP-ANS do (SETQ LOOP-ANS (ADD-TO-SET (MAIN-EVENT-OF X) LOOP-ANS)) finally (RETURN LOOP-ANS)))) (COND ((MEMB DEPENDENT SUPPORTERS) (ERROR1 (PQUOTE (PROGN ATTEMPT TO MAKE (!PPR DEPENDENT NIL) DEPEND UPON ITSELF !)) (BINDINGS (QUOTE DEPENDENT) DEPENDENT) (QUOTE HARD)))) (for X in SUPPORTERS do (ADD-FACT X (QUOTE IMMEDIATE-DEPENDENTS0) DEPENDENT]) (DEPENDENT-EVENTS [LAMBDA (EVENT) (* kbr: "19-Oct-85 16:31") (for X in (DEPENDENTS-OF EVENT) collect (GETPROP X (QUOTE EVENT]) (DEPENDENTS-OF [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (COND ((EQ NAME (QUOTE GROUND-ZERO)) (REVERSE CHRONOLOGY)) ((NOT (GETPROP NAME (QUOTE EVENT))) (ERROR1 (PQUOTE (PROGN DEPENDENTS-OF MUST BE GIVEN AN EVENT AND (!PPR NAME NIL) IS NOT ONE %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE HARD))) (T (SORT (DEPENDENTS-OF1 NAME) (FUNCTION (LAMBDA (X Y) (EVENT1-OCCURRED-BEFORE-EVENT2 X Y CHRONOLOGY]) (DEPENDENTS-OF1 [LAMBDA (NAME) (* kbr: "19-Oct-85 19:59") (COND ((EQ NAME (QUOTE GROUND-ZERO)) (* We never expect this fn to be  called on GROUND-ZERO because its  silly, but we make it behave correctly  anyway. *) (COPYLIST CHRONOLOGY)) (T (CONS NAME (SCRUNCH (for X in (IMMEDIATE-DEPENDENTS-OF NAME) join (DEPENDENTS-OF1 X]) (DESTRUCTORS [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (* This function returns the set of subterms of CL such that every member is  the application of a function to one or more distinct variables.  *) (LET (ANS) (for LIT in CL do (DESTRUCTORS1 LIT)) ANS]) (DESTRUCTORS1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((OR (VARIABLEP TERM) (FQUOTEP TERM)) NIL) (T (for ARG in (FARGS TERM) do (DESTRUCTORS1 ARG)) (COND ((AND (FARGS TERM) (for ARG in (FARGS TERM) always (VARIABLEP ARG)) (NO-DUPLICATESP (FARGS TERM))) (SETQ ANS (ADD-TO-SET TERM ANS]) (DETACH [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (ERROR1 (PQUOTE (PROGN DETACH IS NOT YET IMPLEMENTED)) NIL (QUOTE HARD]) (DETACHED-ERROR [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (CLOSE? TTY-FILE) (CLOSE? PROVE-FILE) (SETQ PROVE-FILE NIL) (SETQ TTY-FILE NIL) (CL:BREAK (QUOTE DETACHED-ERROR]) (DETACHEDP [LAMBDA NIL (* kbr: "19-Oct-85 16:31") NIL]) (DISJOIN [LAMBDA (LST IF-FLG) (* kbr: "19-Oct-85 16:31") (COND ((NULL LST) FALSE) (T (DISJOIN2 (CAR LST) (DISJOIN (CDR LST) IF-FLG) IF-FLG]) (DISJOIN-CLAUSES [LAMBDA (CL1 CL2) (* kbr: "20-Oct-85 16:25") (* The OR of clause CL1 and clause  CL2. *) (COND ((OR (EQUAL CL1 TRUE-CLAUSE) (EQUAL CL2 TRUE-CLAUSE)) TRUE-CLAUSE) ((for LIT1 in CL1 thereis (for LIT2 in CL2 thereis (COMPLEMENTARYP LIT1 LIT2))) TRUE-CLAUSE) (T (APPEND CL1 (SET-DIFF CL2 CL1]) (DISJOIN2 [LAMBDA (P Q IF-FLG) (* kbr: "19-Oct-85 16:31") (COND ((FALSE-NONFALSEP P) (COND (DEFINITELY-FALSE (COND ((FALSE-NONFALSEP Q) (COND (DEFINITELY-FALSE FALSE) (T TRUE))) ((NOT (BOOLEAN Q)) (FCONS-TERM* (QUOTE IF) Q TRUE FALSE)) (T Q))) (T TRUE))) ((FALSE-NONFALSEP Q) (COND (DEFINITELY-FALSE (COND ((BOOLEAN P) P) (T (FCONS-TERM* (QUOTE IF) P TRUE FALSE)))) (T TRUE))) (IF-FLG (FCONS-TERM* (QUOTE IF) P TRUE (COND ((BOOLEAN Q) Q) (T (FCONS-TERM* (QUOTE IF) Q TRUE FALSE))))) (T (FCONS-TERM* (QUOTE OR) P Q]) (DTACK-0-ON-END [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (RPLACD (LAST X) 0) X]) (DUMB-CONVERT-TYPE-SET-TO-TYPE-RESTRICTION-TERM [LAMBDA (TYPE-SET ARG) (* kbr: "19-Oct-85 16:31") (* WARNING: This function does not return a legal term.  In particular, it might return (AND a b c ...)%.  It should be used only for io purposes. *) (LET (LST) (COND ((IEQP TYPE-SET TYPE-SET-UNKNOWN) TRUE) ((IEQP TYPE-SET 0) FALSE) ((IEQP 0 (LSH TYPE-SET -31)) (SETQ LST (for I from 0 to 30 when (NOT (IEQP (LOGAND TYPE-SET (LOGBIT I)) 0)) collect (  CONVERT-TYPE-NO-TO-RECOGNIZER-TERM I ARG))) (COND ((NULL LST) FALSE) ((NULL (CDR LST)) (CAR LST)) (T (CONS (QUOTE OR) LST)))) (T (SETQ LST (for I from 0 to 30 when (IEQP 0 (LOGAND TYPE-SET (LOGBIT I))) collect (DUMB-NEGATE-LIT (CONVERT-TYPE-NO-TO-RECOGNIZER-TERM I ARG)))) (COND ((NULL LST) TRUE) ((NULL (CDR LST)) (CAR LST)) (T (CONS (QUOTE AND) LST]) (DUMB-IMPLICATE-LITS [LAMBDA (L1 L2) (* kbr: "19-Oct-85 16:31") (* Like DUMB-NEGATE-LIT, this function  may be called when TYPE-ALIST is not  valid. Hence this function should not  be modified to use TYPE-SET.  *) (COND ((QUOTEP L1) (COND ((EQUAL L1 FALSE) TRUE) (T L2))) (T (FCONS-TERM* (QUOTE IF) L1 L2 TRUE]) (DUMB-NEGATE-LIT [LAMBDA (TERM) (* kbr: "20-Oct-85 16:27") (* Syntactic NOT of TERM. Like DUMB-IMPLICATE-LITS, this function may be called  when TYPE-ALIST is not valid. Hence this function should not be modified to use  TYPE-SET. *) (COND ((VARIABLEP TERM) (FCONS-TERM* (QUOTE NOT) TERM)) ((FQUOTEP TERM) (COND ((EQUAL TERM FALSE) TRUE) (T FALSE))) ((EQ (FN-SYMB TERM) (QUOTE NOT)) (FARGN TERM 1)) (T (FCONS-TERM* (QUOTE NOT) TERM]) (DUMB-OCCUR [LAMBDA (X Y) (* kbr: " 4-Jul-86 17:01") (* Does X syntactically occur in Y? *) (COND ((EQUAL X Y) T) ((VARIABLEP Y) NIL) ((FQUOTEP Y) NIL) (T (for ARG in (FARGS Y) thereis (DUMB-OCCUR X ARG]) (DUMB-OCCUR-LST [LAMBDA (X LST) (* kbr: "19-Oct-85 16:31") (for TERM in LST thereis (DUMB-OCCUR X TERM]) (DUMP [LAMBDA (LST FILE INDENT WIDTH INDEX-FLG SCRIBE-FLG) (* kbr: "20-Oct-85 19:39") (LET (PAIRS) (OR INDENT (SETQ INDENT 5)) (OR WIDTH (SETQ WIDTH 68)) (SETQ FILE (OPENSTREAM FILE (QUOTE OUTPUT))) (LINEL FILE WIDTH) (SETQ PAIRS (for L in LST as I from 1 collect (PROGN (COND ((LITATOM L) (SETQ L (GETPROP L (QUOTE EVENT))))) (SELECTQ (CAR L) (DEFN (DUMP-DEFN (BM-NTH 1 L) (BM-NTH 2 L) (BM-NTH 3 L) (BM-NTH 4 L) (AND INDEX-FLG I))) (PROVE-LEMMA (DUMP-PROVE-LEMMA (BM-NTH 1 L) (BM-NTH 2 L) (BM-NTH 3 L) (BM-NTH 4 L) (AND INDEX-FLG I))) (ADD-AXIOM (DUMP-ADD-AXIOM (BM-NTH 1 L) (BM-NTH 2 L) (BM-NTH 3 L) (AND INDEX-FLG I))) (ADD-SHELL (DUMP-ADD-SHELL (BM-NTH 1 L) (BM-NTH 2 L) (BM-NTH 3 L) (BM-NTH 4 L) (AND INDEX-FLG I))) (DCL (DUMP-DCL (BM-NTH 1 L) (BM-NTH 2 L) (AND INDEX-FLG I))) (TOGGLE (DUMP-TOGGLE (BM-NTH 1 L) (BM-NTH 2 L) (BM-NTH 3 L) (AND INDEX-FLG I))) (DISABLE (DUMP-TOGGLE NIL (BM-NTH 1 L) NIL (AND INDEX-FLG I))) (ENABLE (DUMP-TOGGLE NIL (BM-NTH 1 L) T (AND INDEX-FLG I))) (DUMP-OTHER L (AND INDEX-FLG I))) (CONS (BM-NTH 1 L) I)))) NIL]) (DUMP-ADD-AXIOM [LAMBDA (NAME TYPES THM INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (IPRINC "AXIOM." FILE) (IPRINC NAME FILE) (COND (TYPES (SPACES 1 FILE) (DUMP-LEMMA-TYPES TYPES))) (IPRINT (QUOTE :) FILE) (SPACES INDENT FILE) (PPRINDENT THM INDENT 0 FILE) (ITERPRI FILE) (DUMP-END-GROUP FILE]) (DUMP-ADD-SHELL [LAMBDA (CONSTRUCTOR BTM RECOG ACCESSORS INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (PRINEVAL (PQUOTE (PROGN SHELL DEFINITION %. // ADD THE SHELL (!PPR CONSTRUCTOR NIL) OF (@ N) (PLURAL? ACCESSORS ARGUMENTS ARGUMENT) WITH // (COND (BTM BOTTOM OBJECT (!PPR BTM (PQUOTE ,) NIL) //)) RECOGNIZER (!PPR RECOG NIL) , // (PLURAL? ACCESSORS ACCESSORS ACCESSOR) (!PPR-LIST NAMES) , // (COND (FLG TYPE (PLURAL? ACCESSORS RESTRICTIONS RESTRICTION) (!PPR-LIST RESTRICTIONS) , //)) AND DEFAULT (PLURAL? ACCESSORS VALUES VALUE) (!PPR-LIST DEFAULTS NIL) %.)) (BINDINGS (QUOTE RECOG) RECOG (QUOTE BTM) BTM (QUOTE ACCESSORS) ACCESSORS (QUOTE CONSTRUCTOR) CONSTRUCTOR (QUOTE N) (LENGTH ACCESSORS) (QUOTE NAMES) (for X in ACCESSORS collect (CAR X)) (QUOTE FLG) (for X in ACCESSORS thereis (AND (NEQ (CADR X) T) (NOT (EQUAL (CADR X) TRUE)))) (QUOTE RESTRICTIONS) (for X in ACCESSORS collect (CADR X)) (QUOTE DEFAULTS) (for X in ACCESSORS collect (CADDR X))) INDENT FILE) (ITERPRI FILE) (DUMP-END-GROUP FILE]) (DUMP-BEGIN-GROUP [LAMBDA (FILE) (* kbr: "19-Oct-85 16:31") (COND (SCRIBE-FLG (PRIN1 (QUOTE @BEGIN (GROUP)) FILE) (ITERPRI FILE) (PRIN1 (QUOTE @BEGIN (VERBATIM)) FILE) (ITERPRI FILE]) (DUMP-DCL [LAMBDA (FN ARGS INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (IPRINC "UNDEFINED FUNCTION." FILE) (ITERPRI FILE) (ISPACES INDENT FILE) (IPRINT (CONS FN ARGS) FILE) (DUMP-END-GROUP FILE]) (DUMP-DEFN [LAMBDA (FN ARGS BODY HINT INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (IPRINC "DEFINITION." FILE) (ITERPRI FILE) (ISPACES INDENT FILE) (IPRINT (CONS FN ARGS) FILE) (ISPACES (IPLUS INDENT 3) FILE) (IPRINT (QUOTE IEQP) FILE) (ISPACES INDENT FILE) (PPRINDENT BODY INDENT 0 FILE) (ITERPRI FILE) (COND (HINT (ISPACES INDENT FILE) (IPRINC "HINT:" FILE) (COND ((NULL (CDR HINT)) (IPRINC "CONSIDER THE WELL-FOUNDED RELATION" FILE) (IPRINT (CAR (CAR HINT)) FILE) (ISPACES (IPLUS 7 INDENT) FILE) (IPRINC "AND THE MEASURE" FILE) (IPRINT (CADR (CAR HINT)) FILE)) (T (PPRINDENT HINT (IPLUS 7 INDENT) 0 FILE) (ITERPRI FILE))))) (DUMP-END-GROUP FILE]) (DUMP-END-GROUP [LAMBDA (FILE) (* kbr: "19-Oct-85 16:31") (COND (SCRIBE-FLG (PRIN1 (QUOTE @END (VERBATIM)) FILE) (ITERPRI FILE) (PRIN1 (QUOTE @END (GROUP)) FILE) (ITERPRI FILE) (ITERPRI FILE]) (DUMP-HINTS [LAMBDA (HINT) (* kbr: "19-Oct-85 20:06") (LET (USED DISABLED ENABLED (INDENT INDENT)) (SETQ USED (CDR (ASSOC (QUOTE USE) HINT))) (SETQ DISABLED (CDR (ASSOC (QUOTE DISABLE) HINT))) (SETQ ENABLED (for X in USED when (NOT (MEMB (CAR X) DISABLED)) collect (CAR X))) (SETQ DISABLED (for X in DISABLED when (NOT (ASSOC X USED)) collect X)) (SETQ HINT (for X in HINT join (SELECTQ (CAR X) (USE (COND ((NULL ENABLED) (LIST (CONS (QUOTE USE) USED))) (T (LIST (CONS (QUOTE USE) USED) (CONS (QUOTE ENABLE) ENABLED))))) (DISABLE (COND ((NULL DISABLED) NIL) (T (LIST (CONS (QUOTE DISABLE) DISABLED))))) (LIST X)))) (ISPACES INDENT FILE) (COND ((OR (LISTP (CDR HINT)) (AND USED (LISTP (CDR USED)))) (IPRINC "HINTS:" FILE) (SETQ INDENT (IPLUS INDENT 8))) (T (IPRINC "HINT:" FILE) (SETQ INDENT (IPLUS INDENT 7)))) (for X in HINT do (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE) (SELECTQ (CAR X) (INDUCT (IPRINC "INDUCT AS FOR" FILE) (IPRINC (CADR X) FILE) (IPRINC "." FILE) (ITERPRI FILE)) (USE (IPRINC "CONSIDER:" FILE) (ITERPRI FILE) (for PAIR in (CDR X) do (ISPACES (ADD1 INDENT) FILE) (IPRINC (CAR PAIR) FILE) (COND ((CDR PAIR) (IPRINC "WITH {" FILE) (for TL on (CDR PAIR) do (IPRINC (CAAR TL) FILE) (IPRINC "/" FILE) (IPRINC (CADR (CAR TL)) FILE) (COND ((CDR TL) (IPRINC "," FILE)))) (IPRINC "}" FILE))) (ITERPRI FILE))) (ENABLE (IPRINC "ENABLE" FILE) (PRINEVAL (PQUOTE (!LIST X)) (BINDINGS (QUOTE X) (CDR X)) (IPOSITION FILE NIL NIL) FILE) (ITERPRI FILE)) (DISABLE (IPRINC "DISABLE" FILE) (PRINEVAL (PQUOTE (!LIST X)) (BINDINGS (QUOTE X) (CDR X)) (IPOSITION FILE NIL NIL) FILE) (ITERPRI FILE)) (PROGN (PPRIND X (IPOSITION FILE NIL NIL) 0 PPR-MACRO-LST FILE) (ITERPRI FILE]) (DUMP-LEMMA-TYPES [LAMBDA (TYPES) (* kbr: "26-Oct-85 17:18") (IPRINC "(" FILE) (for TAIL on TYPES do (IPRINC (COND ((EQ (CAR TAIL) (QUOTE ELIM)) (QUOTE ELIMINATION)) (T (L-CASE (CAR TAIL)))) FILE) (COND ((NULL (CDR TAIL)) NIL) ((NULL (CDDR TAIL)) (IPRINC "AND" FILE)) (T (IPRINC "," FILE) (ISPACES 1 FILE)))) (IPRINC ")" FILE]) (DUMP-OTHER [LAMBDA (X INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (PPRIND X (IPOSITION FILE NIL NIL) 0 NIL FILE) (ITERPRI FILE) (DUMP-END-GROUP FILE]) (DUMP-PROVE-LEMMA [LAMBDA (NAME TYPES THM HINT INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (IPRINC "THEOREM." FILE) (IPRINC NAME FILE) (COND (TYPES (ISPACES 1 FILE) (DUMP-LEMMA-TYPES TYPES))) (IPRINT (QUOTE :) FILE) (ISPACES INDENT FILE) (PPRINDENT THM INDENT 0 FILE) (ITERPRI FILE) (COND (HINT (DUMP-HINTS HINT))) (DUMP-END-GROUP FILE]) (DUMP-TOGGLE [LAMBDA (NAME OLDNAME FLG INDEX) (* kbr: "19-Oct-85 16:31") (DUMP-BEGIN-GROUP FILE) (COND (INDEX (IPRINC INDEX FILE) (IPRINC "." FILE) (ISPACES (IDIFFERENCE INDENT (IPOSITION FILE NIL NIL)) FILE)) (T (ISPACES INDENT FILE))) (COND (FLG (IPRINC "DISABLE" FILE)) (T (IPRINC "ENABLE" FILE))) (IPRINC OLDNAME FILE) (IPRINC "." FILE) (ITERPRI FILE) (DUMP-END-GROUP FILE]) ) (RPAQQ CODE-E-MCOMS ((* CODE-E-M *) (FNS ELIMINABLE-VAR-CANDS ELIMINABLEP ELIMINATE-DESTRUCTORS-CANDIDATEP ELIMINATE-DESTRUCTORS-CANDIDATES ELIMINATE-DESTRUCTORS-CANDIDATES1 ELIMINATE-DESTRUCTORS-CLAUSE ELIMINATE-DESTRUCTORS-CLAUSE1 ELIMINATE-DESTRUCTORS-SENT ELIMINATE-IRRELEVANCE-CLAUSE ELIMINATE-IRRELEVANCE-SENT EQUATIONAL-PAIR-FOR ERASE-EOL ERASE-EOP ERROR1 EVENT-FORM EVENT1-OCCURRED-BEFORE-EVENT2 EVENTS-SINCE EVG EVG-OCCUR-LEGAL-CHAR-CODE-SEQ EVG-OCCUR-NUMBER EVG-OCCUR-OTHER EXECUTE EXPAND-ABBREVIATIONS EXPAND-AND-ORS EXPAND-BOOT-STRAP-NON-REC-FNS EXPAND-NON-REC-FNS EXPAND-PPR-MACROS EXTEND-ALIST EXTERNAL-LINEARIZE EXTRACT-DEPENDENCIES-FROM-HINTS FALSE-NONFALSEP FAVOR-COMPLICATED-CANDIDATES FERTILIZE-CLAUSE FERTILIZE-FEASIBLE FERTILIZE-SENT FERTILIZE1 FILTER-ARGS FIND-EQUATIONAL-POLY FIRST-COEFFICIENT FIRST-VAR FITS FIXCAR-CDR FLATTEN-ANDS-IN-LIT FLESH-OUT-IND-PRIN FLUSH-CAND1-DOWN-CAND2 FN-SYMB0 FNNAMEP FNNAMEP-IF FORM-COUNT FORM-COUNT-EVG FORM-COUNT1 FORM-INDUCTION-CLAUSE FORMP-SIMPLIFIER FORMULA-OF FREE-VAR-CHK FREE-VARSP GEN-VARS GENERALIZE-CLAUSE GENERALIZE-SENT GENERALIZE1 GENERALIZE2 GENRLT1 GENRLTERMS GET-CANDS GET-LISP-SEXPR GET-LEVEL-NO GET-STACK-NAME GET-STACK-NAME1 GET-TYPES GREATEREQP GUARANTEE-CITIZENSHIP GUESS-RELATION-MEASURE-LST HAS-LIB-PROPS ILLEGAL-CALL ILLEGAL-NAME IMMEDIATE-DEPENDENTS-OF IMPLIES? IMPOSSIBLE-POLYP IND-FORMULA INDUCT INDUCT-VARS INDUCTION-MACHINE INFORM-SIMPLIFY INIT-LEMMA-STACK INIT-LIB INIT-LINEARIZE-ASSUMPTIONS-STACK INTERESTING-SUBTERMS INTERSECTP INTRODUCE-ANDS INTRODUCE-LISTS JUMPOUTP KILL-EVENT KILL-LIB KILLPROPLIST1 LEGAL-CHAR-CODE-SEQ LENGTH-TO-ATOM LESSEQP LEXORDER LINEARIZE LISTABLE LOGSUBSETP LOOKUP-HYP LOOP-STOPPER MAIN-EVENT-OF CREATE-EVENT MAKE-FLATTENED-MACHINE MAKE-NEW-NAME MAKE-REWRITE-RULES MAKE-TYPE-RESTRICTION MAX-FORM-COUNT MAXIMAL-ELEMENTS MEANING-SIMPLIFIER MEMB-NEGATIVE MENTIONSQ MENTIONSQ-LST MERGE-CAND1-INTO-CAND2 MERGE-CANDS MERGE-DESTRUCTOR-CANDIDATES MERGE-TESTS-AND-ALISTS MERGE-TESTS-AND-ALISTS-LSTS META-LEMMAP MULTIPLE-PIGEON-HOLE))) (* CODE-E-M *) (DEFINEQ (ELIMINABLE-VAR-CANDS [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") HIST (SET-DIFF (ALL-VARS-LST CL) ELIM-VARIABLE-NAMES1]) (ELIMINABLEP [LAMBDA (SET) (* kbr: "19-Oct-85 16:31") (OR (for LIT in SET always (PRIMITIVEP LIT)) (AND (IEQP (LENGTH SET) 1) (OR (AND (for ARG in (SARGS (CAR SET)) always (VARIABLEP ARG)) (NO-DUPLICATESP (SARGS (CAR SET)))) (AND (EQ (FN-SYMB (CAR SET)) (QUOTE NOT)) (for ARG in (SARGS (ARGN (CAR SET) 1)) always (VARIABLEP ARG)) (NO-DUPLICATESP (SARGS (ARGN (CAR SET) 1]) (ELIMINATE-DESTRUCTORS-CANDIDATEP [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* Recognizes candidates for destructor elimination.  It is assumed the input term is NVARIABLEP and not QUOTEP.  To be a candidate the term must have an enabled destructor elim lemma.  Furthermore, the crucial argument position of the term must be occupied by a  variable or must itself be a candidate for elimination.  Finally, if occupied by a variable, that variable must occur nowhere else in  the arguments. Note that if the crucial arg is an eliminable term then the  process of eliminating it will introduce a suitable distinct var.  The answer returned is either NIL or else is the innermost term to be  eliminated -- possibly TERM itself. *) (PROG (LEMMA VAR) (SETQ LEMMA (GETPROP (FFN-SYMB TERM) (QUOTE ELIMINATE-DESTRUCTORS-SEQ))) (COND ((OR (NULL LEMMA) (DISABLEDP (fetch (REWRITE-RULE NAME) of LEMMA))) (RETURN NIL))) (* We now identify the crucial arg.  *) (SETQ VAR (for ARG in (FARGS TERM) as V in (FARGS (CAR (GETPROP (FFN-SYMB TERM) (QUOTE ELIMINATE-DESTRUCTORS-DESTS )))) when (EQ V (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 2)) do (RETURN ARG))) (RETURN (COND ((VARIABLEP VAR) (* If it is a variable, we make sure  it occurs nowhere else.  *) (COND ((for ARG in (FARGS TERM) as V in (FARGS (CAR (GETPROP (FFN-SYMB TERM) (QUOTE ELIMINATE-DESTRUCTORS-DESTS)))) unless (EQ V (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 2)) never (OCCUR VAR ARG)) TERM) (T NIL))) (T (ELIMINATE-DESTRUCTORS-CANDIDATEP VAR]) (ELIMINATE-DESTRUCTORS-CANDIDATES [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (* Returns a list of pockets. The CAR of each pocket is an eliminable  destructor term. The CDR of each pocket is a list of all destructor terms that  will in turn be eliminated as a result of eliminating the CAR.  *) (LET (ANS) (for LIT in CL do (ELIMINATE-DESTRUCTORS-CANDIDATES1 LIT)) (MERGE-DESTRUCTOR-CANDIDATES ANS]) (ELIMINATE-DESTRUCTORS-CANDIDATES1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* This function adds some lists to ANS.  Each list has two elements. The first is a term that can be eliminated.  The second is a term containing the first which will be eliminated in the same  round as the first is eliminated. *) (COND ((OR (VARIABLEP TERM) (FQUOTEP TERM)) NIL) (T (for ARG in (FARGS TERM) do (ELIMINATE-DESTRUCTORS-CANDIDATES1 ARG)) (COND ((SETQ TEMP-TEMP (ELIMINATE-DESTRUCTORS-CANDIDATEP TERM)) (SETQ ANS (ADD-TO-SET (LIST TEMP-TEMP TERM) ANS]) (ELIMINATE-DESTRUCTORS-CLAUSE [LAMBDA (CL HIST) (* kbr: "20-Oct-85 19:34") (LET (ELIMINABLES NEW-CL TO-DO CANDS REWRITE-RULE HYPS LHS RHS DESTS ALIST INST-DESTS INST-RHS INST-LHS INST-HYPS) (* TO-DO is a list that controls the elimination.  The invariant maintained is that the all the clauses in PROCESS-CLAUSES and all  the clauses in TO-DO are theorems then so is the initial CL.  When a clause is removed from TO-DO either it is added to PROCESS-CLAUSES or  else an elimination is performed on it and the resulting cases are all added to  TO-DO for any additional elims required on the new variables introduced.  TO-DO is a list of pockets. Each pocket contains a clause, the list of all  variables in the clause not introduced by an elim, and some candidate  destructor pockets. The candidate destructor pockets each contain in their CAR  a term that might be eliminated and in their CDR all of the terms that could  recursively be eliminated should the CAR be eliminated.  These pockets are ordered from most desirable elim to least desirable elim.  At the moment the ordering is determined by the sum of the level numbers of the  terms in the CDRs. *) (SETQ TO-DO (LIST (LIST CL (ELIMINABLE-VAR-CANDS CL HIST) (SORT-DESTRUCTOR-CANDIDATES (ELIMINATE-DESTRUCTORS-CANDIDATES CL))))) (SETQ PROCESS-CLAUSES NIL) (SETQ PROCESS-HIST NIL) (while TO-DO do (SETQ CL (CAAR TO-DO)) (SETQ ELIMINABLES (CADAR TO-DO)) (SETQ CANDS (CADDAR TO-DO)) (SETQ TO-DO (CDR TO-DO)) (COND ((OR (NULL ELIMINABLES) (NULL CANDS)) (SETQ PROCESS-CLAUSES (CONS CL PROCESS-CLAUSES))) ((for CAND-TAIL on CANDS bind CAND thereis (PROGN (* CAND is the candidate destructor  term to be eliminated.  *) (SETQ CAND (CAR (CAR CAND-TAIL))) (SETQ REWRITE-RULE (GETPROP (FFN-SYMB CAND) (QUOTE ELIMINATE-DESTRUCTORS-SEQ))) (* We know this rule is not disabled  because  ELIMINATE-DESTRUCTORS-CANDIDATES  checks DISABLED-LEMMAS before saying a  term is a candidate.  *) (SETQ HYPS (fetch (REWRITE-RULE HYPS) of REWRITE-RULE)) (SETQ LHS (FARGN (fetch (REWRITE-RULE CONCL) of REWRITE-RULE) 1)) (SETQ RHS (FARGN (fetch (REWRITE-RULE CONCL) of REWRITE-RULE) 2)) (SETQ DESTS (GETPROP (FFN-SYMB CAND) (QUOTE ELIMINATE-DESTRUCTORS-DESTS))) (SETQ ALIST (for VAR in (FARGS (CAR DESTS)) as VAL in (FARGS CAND) collect (CONS VAR VAL))) (SETQ INST-RHS (SUBLIS-VAR ALIST RHS)) (COND ((AND (MEMB INST-RHS ELIMINABLES) (for HYP in HYPS never (MEMBER (SUBLIS-VAR ALIST HYP) CL))) (SETQ INST-DESTS (SUBLIS-VAR-LST ALIST DESTS)) (SETQ INST-HYPS (SUBLIS-VAR-LST ALIST HYPS)) (SETQ INST-LHS (SUBLIS-VAR ALIST LHS)) (SETQ TO-DO (APPEND (for HYP in INST-HYPS unless (EQUAL TRUE-CLAUSE (SETQ NEW-CL (ADD-LITERAL HYP CL NIL))) collect (LIST NEW-CL ELIMINABLES (COND (PROCESS-HIST (for POCKET in (CDR CAND-TAIL) unless (MEMBER (CAR POCKET) INST-DESTS) collect POCKET)) (T NIL)))) TO-DO)) (SETQ NEW-CL (ELIMINATE-DESTRUCTORS-CLAUSE1 CL INST-HYPS INST-LHS INST-RHS INST-DESTS)) (COND ((NOT (EQUAL TRUE-CLAUSE NEW-CL)) (SETQ TO-DO (CONS (LIST NEW-CL (UNIONQ GENERALIZING-SKOS (REMOVE INST-RHS ELIMINABLES)) (SORT-DESTRUCTOR-CANDIDATES (MERGE-DESTRUCTOR-CANDIDATES (UNION-EQUAL (COND (PROCESS-HIST (for POCKET in (CDR CAND-TAIL) when (OCCUR-LST (CAR POCKET) NEW-CL) collect POCKET )) (T NIL)) (for POCKET in (ELIMINATE-DESTRUCTORS-CANDIDATES NEW-CL) when (for VAR in (FARGS (CAR POCKET)) thereis (MEMB VAR GENERALIZING-SKOS)) collect POCKET))))) TO-DO)))) (SETQ PROCESS-HIST (CONS (LIST (fetch (REWRITE-RULE NAME) of REWRITE-RULE) INST-DESTS OBVIOUS-RESTRICTIONS GENERALIZE-LEMMA-NAMES INST-RHS (SUB-PAIR-EXPR INST-DESTS GENERALIZING-SKOS INST-LHS)) PROCESS-HIST)) T) (T NIL))))) (T (SETQ PROCESS-CLAUSES (CONS CL PROCESS-CLAUSES))))) (for PAIR in PROCESS-HIST do (SETQ ALL-LEMMAS-USED (UNION-EQUAL (CADDDR PAIR) (ADD-TO-SET (CAR PAIR) ALL-LEMMAS-USED)))) (SETQ PROCESS-CLAUSES (SCRUNCH-CLAUSE-SET PROCESS-CLAUSES)) (NOT (NULL PROCESS-HIST]) (ELIMINATE-DESTRUCTORS-CLAUSE1 [LAMBDA (CL HYPS LHS RHS DESTS) (* kbr: "19-Oct-85 16:31") (LET (GEN-CL GEN-LHS CL1) (SETQ CL1 CL) (* We preserve the order of the hyps  just for the hell of it.  *) (for HYP in (REVERSE HYPS) do (SETQ CL1 (ADD-LITERAL (NEGATE-LIT HYP) CL1 NIL))) (SETQ GEN-CL (GENERALIZE1 CL1 DESTS ELIM-VARIABLE-NAMES1)) (SETQ GEN-LHS (SUB-PAIR-EXPR DESTS GENERALIZING-SKOS LHS)) (SUBST-VAR-LST GEN-LHS RHS GEN-CL]) (ELIMINATE-DESTRUCTORS-SENT [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (EXECUTE (QUOTE ELIMINATE-DESTRUCTORS-CLAUSE) CL HIST (QUOTE SIMPLIFY-SENT) (QUOTE FERTILIZE-SENT]) (ELIMINATE-IRRELEVANCE-CLAUSE [LAMBDA (CL HIST) (* kbr: "19-Oct-85 20:00") HIST (PROG (PARTITION ELIMINABLES) (COND ((NOT (ASSOC (QUOTE BEING-PROVED) STACK)) (RETURN NIL))) [SETQ PARTITION (TRANSITIVE-CLOSURE (for LIT in CL collect (CONS (ALL-VARS LIT) (LIST LIT))) (FUNCTION (LAMBDA (X Y) (COND ((INTERSECTP (CAR X) (CAR Y)) (CONS (UNION-EQUAL (CAR X) (CAR Y)) (UNION-EQUAL (CDR X) (CDR Y)))) (T NIL] (SETQ ELIMINABLES (for PAIR in PARTITION when (ELIMINABLEP (CDR PAIR)) join (CDR PAIR))) (COND ((NULL ELIMINABLES) (RETURN NIL)) (T (SETQ PROCESS-CLAUSES (LIST (for LIT in CL unless (MEMB LIT ELIMINABLES) collect LIT))) (SETQ PROCESS-HIST NIL) (RETURN T]) (ELIMINATE-IRRELEVANCE-SENT [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (EXECUTE (QUOTE ELIMINATE-IRRELEVANCE-CLAUSE) CL HIST (QUOTE STORE-SENT) (QUOTE STORE-SENT]) (EQUATIONAL-PAIR-FOR [LAMBDA (WINNING-PAIR POLY) (* kbr: "19-Oct-85 16:31") (CONS (CAR WINNING-PAIR) (CONS-PLUS (LIST (QUOTE QUOTE) (ABS (fetch (POLY CONSTANT) of POLY))) (BUILD-SUM WINNING-PAIR (fetch (POLY ALIST) of POLY]) (ERASE-EOL [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (CURSORPOS (QUOTE L]) (ERASE-EOP [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (CURSORPOS (QUOTE E]) (ERROR1 [LAMBDA (SENTENCE ALIST HARDNESS) (* kbr: "20-Apr-86 16:18") (SETQ ALIST (CONS (CONS (QUOTE SENTENCE) SENTENCE) (CONS (CONS (QUOTE HARDNESS) HARDNESS) ALIST))) (COND ((NULL HARDNESS) (SETQ HARDNESS (QUOTE HARD)))) (PRINEVAL (PQUOTE (PROGN // (COND ((EQ HARDNESS (QUOTE WARNING)) WARNING) ((EQ HARDNESS (QUOTE HARD)) FATAL ERROR) (T ERROR)) : (@ SENTENCE) // //)) ALIST 0 PROVE-FILE) (COND ((NEQ TTY-FILE PROVE-FILE) (PRINEVAL (PQUOTE (PROGN // (COND ((EQ HARDNESS (QUOTE WARNING)) WARNING) ((EQ HARDNESS (QUOTE HARD)) FATAL ERROR) (T ERROR)) : (@ SENTENCE) // //)) ALIST 0 TTY-FILE))) (COND (DEBUGFLG (HELP))) (COND ((EQ HARDNESS (QUOTE WARNING)) NIL) ((DETACHEDP) (DETACHED-ERROR) (ERROR1 SENTENCE (CDDR ALIST) HARDNESS)) ((AND (EQ HARDNESS (QUOTE SOFT)) IN-REDO-UNDONE-EVENTS-FLG) (RETFROM (QUOTE APPLY) (QUOTE *****ERROR*****))) (T (ERROR (LIST (QUOTE ERROR1) SENTENCE ALIST]) (EVENT-FORM [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (AND (LITATOM X) (OR (GETPROP X (QUOTE EVENT)) (AND (GETPROP X (QUOTE MAIN-EVENT)) (GETPROP (GETPROP X (QUOTE MAIN-EVENT)) (QUOTE EVENT]) (EVENT1-OCCURRED-BEFORE-EVENT2 [LAMBDA (EVENT1 EVENT2 EVENT-LST) (* kbr: "19-Oct-85 16:31") (COND ((MEMB EVENT1 (CDR (MEMB EVENT2 EVENT-LST))) T) (T NIL]) (EVENTS-SINCE [LAMBDA (EVENT) (* kbr: "19-Oct-85 16:31") (COND ((MEMB EVENT CHRONOLOGY) (CONS (GETPROP EVENT (QUOTE EVENT)) (DREVERSE (for E in CHRONOLOGY until (EQ E EVENT) collect (GETPROP E (QUOTE EVENT]) (EVG [LAMBDA (Y) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP Y) (COND ((FIXP Y) (COND ((GREATEREQP Y 0) TYPE-SET-NUMBERS) (T TYPE-SET-NEGATIVES))) ((EQ Y *1*T) TYPE-SET-TRUE) ((EQ Y *1*F) TYPE-SET-FALSE) ((ILLEGAL-NAME Y) NIL) (T TYPE-SET-LITATOMS))) ((EQ (CAR Y) *1*SHELL-QUOTE-MARK) (COND ((AND (LISTP (CDR Y)) (EQ (CDR (LAST Y)) NIL) (IEQP (LENGTH (CDDR Y)) (ARITY (CADR Y))) (OR (MEMB (CADR Y) *1*BTM-OBJECTS) (AND (ASSOC (CADR Y) SHELL-ALIST) (for RESTRICTION in (GETPROP (CADR Y) (QUOTE TYPE-RESTRICTIONS)) as ARG in (CDDR Y) always (AND (SETQ TEMP-TEMP (EVG ARG)) (LOGSUBSETP TEMP-TEMP (fetch (TYPE-RESTRICTION TYPE-SET) of RESTRICTION)))))) (COND ((EQ (CADR Y) (QUOTE PACK)) (NOT (LEGAL-CHAR-CODE-SEQ (CADDR Y)))) ((EQ (CADR Y) (QUOTE MINUS)) (EQUAL (CADDR Y) 0)) (T (NOT (MEMB (CADR Y) (QUOTE (ADD1 ZERO CONS))))))) (CAR (TYPE-PRESCRIPTION (CADR Y)))) (T NIL))) ((AND (EVG (CAR Y)) (EVG (CDR Y))) TYPE-SET-CONS) (T NIL]) (EVG-OCCUR-LEGAL-CHAR-CODE-SEQ [LAMBDA (L EVG) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP EVG) (COND ((EQ EVG *1*T) NIL) ((EQ EVG *1*F) NIL) ((FIXP EVG) NIL) ((LESSP (NCHARS EVG) (LENGTH-TO-ATOM L)) NIL) (T (for TAIL on L until (NLISTP TAIL) as J from (ADD1 (IDIFFERENCE (NCHARS EVG) (LENGTH-TO-ATOM L))) always (IEQP (CAR TAIL) (NTHCHARCODE EVG J)))))) ((EQ (CAR EVG) *1*SHELL-QUOTE-MARK) (for ARG in (CDDR EVG) thereis (EVG-OCCUR-LEGAL-CHAR-CODE-SEQ L ARG))) ((EQUAL L EVG) T) (T (OR (EVG-OCCUR-LEGAL-CHAR-CODE-SEQ L (CAR EVG)) (EVG-OCCUR-LEGAL-CHAR-CODE-SEQ L (CDR EVG]) (EVG-OCCUR-NUMBER [LAMBDA (N EVG) (* kbr: "17-Nov-85 17:08") (COND ((NLISTP EVG) (COND ((EQ EVG *1*T) NIL) ((EQ EVG *1*F) NIL) ((FIXP EVG) (COND ((LESSP N 0) (EQUAL N EVG)) (T (LESSEQP N (ABS EVG))))) ((LESSP N 0) NIL) ((GREATERP N (CHARCODE Z)) NIL) ((LESSEQP N (CHARCODE -)) T) (T (for I from 1 to (NCHARS EVG) thereis (LESSEQP N (NTHCHARCODE EVG I)))))) ((EQ (CAR EVG) *1*SHELL-QUOTE-MARK) (for ARG in (CDDR EVG) thereis (EVG-OCCUR-NUMBER N ARG))) (T (OR (EVG-OCCUR-NUMBER N (CAR EVG)) (EVG-OCCUR-NUMBER N (CDR EVG]) (EVG-OCCUR-OTHER [LAMBDA (X EVG) (* kbr: "19-Oct-85 16:31") (* X must be an evg other than a FIXP  or a LEGAL-CHAR-CODE-SEQ with 0 final  CDR. *) (COND ((EQUAL X EVG) T) ((NLISTP EVG) NIL) ((EQ (CAR EVG) *1*SHELL-QUOTE-MARK) (for ARG in (CDDR EVG) thereis (EVG-OCCUR-OTHER X ARG))) (T (OR (EVG-OCCUR-OTHER X (CAR EVG)) (EVG-OCCUR-OTHER X (CDR EVG]) (EXECUTE [LAMBDA (PROCESS CL HIST NORMAL-EXIT NO-CHANGE-EXIT) (* kbr: "19-Oct-85 16:31") (LET (NEW-HIST) (COND ((APPLY* PROCESS CL HIST) (SETQ NEW-HIST (ADD-PROCESS-HIST PROCESS CL HIST PROCESS-CLAUSES PROCESS-HIST)) (for CL1 in PROCESS-CLAUSES do (APPLY* NORMAL-EXIT CL1 NEW-HIST))) (T (APPLY* NO-CHANGE-EXIT CL HIST]) (EXPAND-ABBREVIATIONS [LAMBDA (TERM ALIST) (* kbr: "19-Oct-85 16:31") (* Apply all unconditional rewrite  rules and nonrec defns that are  ABBREVIATIONPs. Adds to  ABBREVIATIONS-USED the names of the  lemmas and fns applied.  *) (LET (TEMP LEMMA RHS LHS) (COND ((VARIABLEP TERM) (COND ((SETQ TEMP (ASSOC TERM ALIST)) (CDR TEMP)) (T TERM))) ((FQUOTEP TERM) TERM) ((MEMB (FFN-SYMB TERM) FNS-TO-BE-IGNORED-BY-REWRITE) (CONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (EXPAND-ABBREVIATIONS ARG ALIST)))) ((AND (SETQ TEMP (NON-RECURSIVE-DEFNP (FFN-SYMB TERM))) (ABBREVIATIONP (CADR TEMP) (CADDR TEMP))) (SETQ ABBREVIATIONS-USED (ADD-TO-SET (FFN-SYMB TERM) ABBREVIATIONS-USED)) (EXPAND-ABBREVIATIONS (CADDR TEMP) (for V in (CADR TEMP) as ARG in (FARGS TERM) collect (CONS V (  EXPAND-ABBREVIATIONS ARG ALIST))))) (T (SETQ TERM (CONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (EXPAND-ABBREVIATIONS ARG ALIST)))) (COND ((FQUOTEP TERM) TERM) ((SETQ LEMMA (for LEMMA in (GETPROP (FFN-SYMB TERM) (QUOTE LEMMAS)) when (AND (NOT (DISABLEDP (fetch (REWRITE-RULE NAME) of LEMMA))) (NOT (META-LEMMAP LEMMA)) (NULL (fetch (REWRITE-RULE HYPS) of LEMMA)) (NULL (fetch (REWRITE-RULE LOOP-STOPPER) of LEMMA)) (BM-MATCH (fetch (REWRITE-RULE CONCL) of LEMMA) (EQUAL LHS RHS)) (ABBREVIATIONP (ALL-VARS-BAG LHS) RHS) (ONE-WAY-UNIFY LHS TERM)) do (RETURN LEMMA))) (SETQ ABBREVIATIONS-USED (ADD-TO-SET (fetch (REWRITE-RULE NAME) of LEMMA) ABBREVIATIONS-USED)) (EXPAND-ABBREVIATIONS RHS UNIFY-SUBST)) (T TERM]) (EXPAND-AND-ORS [LAMBDA (TERM BOOL) (* kbr: "19-Oct-85 16:31") (* Expands the top-level fn symbol of TERM provided the expansion produces an  AND -- when BOOL is FALSE -- or OR -- when BOOL is TRUE --  or returns NIL if no expansion is appropriate.  Side-effects ABBREVIATIONS-USED. *) (LET (TEMP LEMMA RHS LHS C2 C3) (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) NIL) ((AND (SETQ TEMP (NON-RECURSIVE-DEFNP (FFN-SYMB TERM))) (OR (AND (BM-MATCH (CADDR TEMP) (COND ((& C2 C3)))) (OR (EQUAL C2 BOOL) (EQUAL C3 BOOL))) (COND ((EQUAL BOOL FALSE) (BM-MATCH (CADDR TEMP) (AND & &))) (T (BM-MATCH (CADDR TEMP) (OR & &)))))) (SETQ ABBREVIATIONS-USED (ADD-TO-SET (FFN-SYMB TERM) ABBREVIATIONS-USED)) (EXPAND-ABBREVIATIONS (SUB-PAIR-VAR (CADR TEMP) (FARGS TERM) (CADDR TEMP)) NIL)) ((SETQ LEMMA (for LEMMA in (GETPROP (FFN-SYMB TERM) (QUOTE LEMMAS)) when (AND (NOT (DISABLEDP (fetch (REWRITE-RULE NAME) of LEMMA))) (NOT (META-LEMMAP LEMMA)) (NULL (fetch (REWRITE-RULE HYPS) of LEMMA)) (NULL (fetch (REWRITE-RULE LOOP-STOPPER) of LEMMA)) (BM-MATCH (fetch (REWRITE-RULE CONCL) of LEMMA) (EQUAL LHS RHS)) (BM-MATCH RHS (COND ((& C2 C3)))) (OR (EQUAL C2 BOOL) (EQUAL C3 BOOL)) (ONE-WAY-UNIFY LHS TERM)) do (RETURN LEMMA))) (SETQ ABBREVIATIONS-USED (ADD-TO-SET (fetch (REWRITE-RULE NAME) of LEMMA) ABBREVIATIONS-USED)) (EXPAND-ABBREVIATIONS (SUBLIS-VAR UNIFY-SUBST RHS) NIL)) (T NIL]) (EXPAND-BOOT-STRAP-NON-REC-FNS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) TERM) ((FQUOTEP TERM) TERM) ((MEMB (FFN-SYMB TERM) (QUOTE (AND OR NOT IMPLIES FIX ZEROP NLISTP))) (EXPAND-BOOT-STRAP-NON-REC-FNS (SUB-PAIR-VAR (CADR (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN))) (FARGS TERM) (CADDR (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN)))))) (T (CONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (EXPAND-BOOT-STRAP-NON-REC-FNS ARG]) (EXPAND-NON-REC-FNS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) TERM) ((FQUOTEP TERM) TERM) ((NON-RECURSIVE-DEFNP (FFN-SYMB TERM)) (EXPAND-NON-REC-FNS (SUB-PAIR-VAR (CADR (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN))) (FARGS TERM) (CADDR (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN)))))) (T (CONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (EXPAND-NON-REC-FNS ARG]) (EXPAND-PPR-MACROS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* As currently defined and used, this fn is a crock.  It binds PPR-MACRO-LST apparently so that the macro defns on PPR-MACRO-LST can  smash the list so that while processing the value delivered by a macro macros  are not expanded. This appears to be used by CONVERT-QUOTE so that after  (QUOTE evg) has been processed at the top level --  possibly changing into something like a number or NIL or TRUE but possibly  being unchanged -- the recursive processing of evg does not cause macro  expansion -- e.g., (QUOTE (CAR (CAR X))) is otherwise changed into  (* As *) *) (LET ((PPR-MACRO-LST PPR-MACRO-LST)) (COND ((NLISTP TERM) TERM) ((SETQ TEMP-TEMP (ASSOC (CAR TERM) PPR-MACRO-LST)) (SETQ TEMP-TEMP (APPLY* (CDR TEMP-TEMP) TERM)) (COND ((NLISTP TEMP-TEMP) TEMP-TEMP) ((EQ (CAR TEMP-TEMP) (QUOTE QUOTE)) TEMP-TEMP) (T (CONS (CAR TEMP-TEMP) (for ARG in (CDR TEMP-TEMP) collect (EXPAND-PPR-MACROS ARG)))))) (T (CONS (CAR TERM) (for ARG in (CDR TERM) collect (EXPAND-PPR-MACROS ARG]) (EXTEND-ALIST [LAMBDA (ALIST1 ALIST2) (* kbr: "19-Oct-85 16:31") (* Extend ALIST2 by adding to it every  pair from ALIST1 that does not  conflict with an existing pair in  ALIST2. *) (APPEND ALIST2 (for X in ALIST1 unless (ASSOC (CAR X) ALIST2) collect X]) (EXTERNAL-LINEARIZE [LAMBDA (TERM FLG) (* kbr: "19-Oct-85 16:31") (LET (HEURISTIC-TYPE-ALIST LITS-THAT-MAY-BE-ASSUMED-FALSE) (LINEARIZE TERM FLG]) (EXTRACT-DEPENDENCIES-FROM-HINTS [LAMBDA (HINTS) (* kbr: "19-Oct-85 16:31") (for HINT in HINTS bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (SELECTQ (CAR HINT) (USE (for X in (CDR HINT) collect (CAR X))) (INDUCT (LIST (FFN-SYMB (TRANSLATE (CADR HINT))))) (NIL)) LOOP-ANS)) finally (RETURN LOOP-ANS]) (FALSE-NONFALSEP [LAMBDA (TERM) (* kbr: "29-Jun-86 17:51") (* Returns T if TERM is definitely true or false.  As a side effect, DEFINITELY-FALSE is set to T to indicate which of definitely  true or false. *) (LET (TEMP) (COND ((VALUEP TERM) (SETQ DEFINITELY-FALSE (EQUAL TERM FALSE)) T) (T (SETQ TEMP (TYPE-SET TERM)) (COND ((IEQP TEMP TYPE-SET-FALSE) (SETQ DEFINITELY-FALSE T) T) ((IEQP 0 (LOGAND TEMP TYPE-SET-FALSE)) (SETQ DEFINITELY-FALSE NIL) T) (T NIL]) (FAVOR-COMPLICATED-CANDIDATES [LAMBDA (CANDLST) (* kbr: "19-Oct-85 16:31") (MAXIMAL-ELEMENTS CANDLST (FUNCTION (LAMBDA (CAND) (for TERM in (CONS (fetch (CANDIDATE INDUCTION-TERM) of CAND) (fetch (CANDIDATE OTHER-TERMS) of CAND)) count (NOT (PRIMITIVE-RECURSIVEP (FN-SYMB TERM]) (FERTILIZE-CLAUSE [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (PROG (LIT LHS1 RHS1 LHS2 RHS2 DONT-DELETE-LIT-FLG MASS-SUBST-FLG CROSS-FERT-FLG DIRECTION) (SETQ LIT (for LIT in CL when (AND (BM-MATCH LIT (NOT (EQUAL LHS1 RHS1))) (SETQ DIRECTION (FERTILIZE1 LIT CL LHS1 RHS1 HIST))) do (RETURN LIT))) (COND ((NULL LIT) (RETURN NIL))) (SETQ MASS-SUBST-FLG (OR (VALUEP LHS1) (VALUEP RHS1))) (SETQ DONT-DELETE-LIT-FLG (OR (VALUEP LHS1) (VALUEP RHS1) (AND (NOT (AND IN-PROVE-LEMMA-FLG (ASSOC (QUOTE INDUCT) HINTS))) (NOT (ASSOC (QUOTE BEING-PROVED) STACK))))) (SETQ CROSS-FERT-FLG (AND (ASSOC (QUOTE BEING-PROVED) STACK) (for LIT2 in CL thereis (AND (BM-MATCH LIT2 (EQUAL LHS2 RHS2)) (COND ((EQ DIRECTION (QUOTE LEFT-FOR-RIGHT )) (OCCUR RHS1 RHS2)) (T (OCCUR LHS1 LHS2))))) (for LIT2 in CL thereis (AND (BM-MATCH LIT2 (EQUAL LHS2 RHS2)) (COND ((EQ DIRECTION (QUOTE LEFT-FOR-RIGHT )) (OCCUR RHS1 LHS2)) (T (OCCUR LHS1 RHS2))))))) (SETQ PROCESS-CLAUSES (LIST (for LIT2 in CL when (OR DONT-DELETE-LIT-FLG (NEQ LIT LIT2)) collect (COND ((EQ LIT LIT2) LIT) ((OR MASS-SUBST-FLG (NOT CROSS-FERT-FLG) (BM-MATCH LIT2 (NOT (EQUAL & &)))) (COND ((EQ DIRECTION (QUOTE LEFT-FOR-RIGHT)) (BM-SUBST LHS1 RHS1 LIT2)) (T (BM-SUBST RHS1 LHS1 LIT2)))) ((BM-MATCH LIT2 (EQUAL LHS2 RHS2)) (COND ((EQ DIRECTION (QUOTE LEFT-FOR-RIGHT)) (FCONS-TERM* (QUOTE EQUAL) LHS2 (BM-SUBST LHS1 RHS1 RHS2))) (T (FCONS-TERM* (QUOTE EQUAL) (BM-SUBST RHS1 LHS1 LHS2) RHS2)))) (T LIT2))))) (SETQ PROCESS-HIST (LIST MASS-SUBST-FLG CROSS-FERT-FLG DIRECTION LHS1 RHS1 DONT-DELETE-LIT-FLG)) (RETURN T]) (FERTILIZE-FEASIBLE [LAMBDA (LIT CL TERM HIST) (* kbr: "19-Oct-85 16:31") (AND (NOT (ALMOST-VALUEP TERM)) (OR (VARIABLEP TERM) (NOT (SKO-DEST-NESTP TERM NIL))) (for LIT2 in CL when (NEQ LIT2 LIT) thereis (OCCUR TERM LIT2)) (NOT (for ENTRY in HIST bind (LHS RHS) thereis (AND (BM-MATCH ENTRY (FERTILIZE-CLAUSE & & & & LHS RHS &)) (EQUAL (FARGN (FARGN LIT 1) 1) LHS) (EQUAL (FARGN (FARGN LIT 1) 2) RHS]) (FERTILIZE-SENT [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (EXECUTE (QUOTE FERTILIZE-CLAUSE) CL HIST (QUOTE SIMPLIFY-SENT) (QUOTE GENERALIZE-SENT]) (FERTILIZE1 [LAMBDA (LIT CL LHS RHS HIST) (* kbr: "19-Oct-85 16:31") (COND ((FERTILIZE-FEASIBLE LIT CL LHS HIST) (COND ((FERTILIZE-FEASIBLE LIT CL RHS HIST) (COND ((LESSP (COMPLEXITY LHS) (COMPLEXITY RHS)) (QUOTE LEFT-FOR-RIGHT)) (T (QUOTE RIGHT-FOR-LEFT)))) (T (QUOTE RIGHT-FOR-LEFT)))) ((FERTILIZE-FEASIBLE LIT CL RHS HIST) (QUOTE LEFT-FOR-RIGHT)) (T NIL]) (FILTER-ARGS [LAMBDA (SUBSET FORMALS ARGS) (* kbr: "19-Oct-85 16:31") (for VAR in SUBSET collect (for TERM in ARGS as FORMAL in FORMALS when (EQ FORMAL VAR) do (RETURN TERM]) (FIND-EQUATIONAL-POLY [LAMBDA (HIST POT) (* kbr: "19-Oct-85 16:31") (* Look for an equation to be derived from this pot.  If one is found, add to LEMMAS-USED-BY-LINEAR and LINEAR-ASSUMPTIONS the  appropriate entries from the two polys involved.  In addition, add an extra entry to LEMMAS-USED-BY-LINEAR to store the fact that  this equation has been deduced. Finally, do not do any of this if HIST records  that the deduced equation has been previously deduced.  See the comment in PROCESS-EQUATIONAL-POLYS for details.  *) (for POLY1 in (fetch (LINEAR-POT POSITIVES) of POT) bind (WINNING-PAIR POLY2 PAIR HYP1 HYP2) when (SETQ TEMP-TEMP (TRIVIAL-POLYP POLY1)) do (SETQ WINNING-PAIR (CAR TEMP-TEMP)) (SETQ POLY1 (CDR TEMP-TEMP)) (* POLY1 is in lowest form now.  *) (COND ((SETQ POLY2 (for POLY2 in (fetch (LINEAR-POT NEGATIVES) of POT) when (COMPLEMENTARY-MULTIPLEP WINNING-PAIR POLY1 POLY2) do (RETURN POLY2))) (SETQ PAIR (EQUATIONAL-PAIR-FOR WINNING-PAIR POLY1)) (SETQ HYP1 (NUMBERP? (CAR PAIR))) (SETQ HYP2 (NUMBERP? (CDR PAIR))) (COND ((AND (NOT (EQUAL HYP1 FALSE)) (NOT (EQUAL HYP2 FALSE)) (for HIST-ENTRY in HIST never (AND (EQ (CAR HIST-ENTRY) (QUOTE SIMPLIFY-CLAUSE)) (for X in (CDDR HIST-ENTRY) thereis (AND (LISTP X) (LISTP (CAR X)) (EQ (CAR (CAR X)) (QUOTE FIND-EQUATIONAL-POLY)) (OR (EQUAL PAIR (CDR (CAR X))) (AND (EQUAL (CDR PAIR) (CAR (CDR (CAR X)))) (EQUAL (CAR PAIR) (CDR (CDR (CAR X))))))))))) (SETQ LINEAR-ASSUMPTIONS (UNION-EQUAL (UNION-EQUAL (fetch (POLY ASSUMPTIONS) of POLY1) (fetch (POLY ASSUMPTIONS) of POLY2)) LINEAR-ASSUMPTIONS)) (OR (EQUAL TRUE HYP1) (SETQ LINEAR-ASSUMPTIONS (ADD-TO-SET HYP1 LINEAR-ASSUMPTIONS))) (OR (EQUAL TRUE HYP2) (SETQ LINEAR-ASSUMPTIONS (ADD-TO-SET HYP2 LINEAR-ASSUMPTIONS))) (SETQ LEMMAS-USED-BY-LINEAR (CONS (LIST (CONS (QUOTE FIND-EQUATIONAL-POLY) PAIR)) (UNIONQ (UNIONQ (fetch (POLY LEMMAS) of POLY1) (fetch (POLY LEMMAS) of POLY2)) LEMMAS-USED-BY-LINEAR))) (RETURN PAIR]) (FIRST-COEFFICIENT [LAMBDA (EQUATION) (* kbr: "20-Oct-85 15:53") (CDR (CAR (fetch (POLY ALIST) of EQUATION]) (FIRST-VAR [LAMBDA (EQUATION) (* kbr: "19-Oct-85 16:31") (CAAR (fetch (POLY ALIST) of EQUATION]) (FITS [LAMBDA (ALIST1 ALIST2 VARS) (* kbr: "19-Oct-85 16:31") (* Return T iff the two alists agree  on every var in VARS.  *) (for VAR in VARS always (EQUAL (COND ((SETQ TEMP-TEMP (ASSOC VAR ALIST1)) (CDR TEMP-TEMP)) (T VAR)) (COND ((SETQ TEMP-TEMP (ASSOC VAR ALIST2)) (CDR TEMP-TEMP)) (T VAR]) (FIXCAR-CDR [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (TEMP) (COND ((SETQ TEMP (CAR-CDRP (CAR TERM))) (SETQ TERM (CADR TERM)) (for A-D in TEMP do (SETQ TERM (LIST (COND ((EQ A-D (QUOTE A)) (QUOTE CAR)) (T (QUOTE CDR))) TERM))))) TERM]) (FLATTEN-ANDS-IN-LIT [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (C1 C2 C3) (COND ((EQUAL TERM TRUE) NIL) ((BM-MATCH TERM (IF C1 C2 C3)) (COND ((EQUAL C2 FALSE) (APPEND (FLATTEN-ANDS-IN-LIT (DUMB-NEGATE-LIT C1)) (FLATTEN-ANDS-IN-LIT C3))) ((EQUAL C3 FALSE) (APPEND (FLATTEN-ANDS-IN-LIT C1) (FLATTEN-ANDS-IN-LIT C2))) (T (LIST TERM)))) ((BM-MATCH TERM (AND C1 C2)) (APPEND (FLATTEN-ANDS-IN-LIT C1) (FLATTEN-ANDS-IN-LIT C2))) (T (LIST TERM]) (FLESH-OUT-IND-PRIN [LAMBDA (TERM FORMALS MACHINE JUSTIFICATION MASK QUICK-BLOCK-INFO) (* kbr: "19-Oct-85 16:31") QUICK-BLOCK-INFO (* Constructs a CANDIDATE record for TERM given, for the fn symbol of TERM, the  FORMALS, the INDUCTION-MACHINE property, a JUSTIFICATION, a sound induction  principle MASK, and the QUICK-BLOCK-INFO.  *) (create CANDIDATE SCORE _ (QUOTIENT (FLOAT (for FLG in MASK count FLG)) (LENGTH FORMALS)) CONTROLLERS _ (for A in (FARGS TERM) as V in FORMALS bind LOOP-ANS when (MEMB V (fetch (JUSTIFICATION SUBSET) of JUSTIFICATION)) do (SETQ LOOP-ANS (UNIONQ (ALL-VARS A) LOOP-ANS)) finally (RETURN LOOP-ANS)) CHANGED-VARS _ (for ACTUAL in (SARGS TERM) as FLG in MASK when (EQ FLG (QUOTE CHANGEABLE)) collect ACTUAL) UNCHANGEABLE-VARS _ (for ACTUAL in (SARGS TERM) as FLG in MASK bind LOOP-ANS when (EQ FLG (QUOTE UNCHANGEABLE)) do (SETQ LOOP-ANS (UNIONQ (ALL-VARS ACTUAL) LOOP-ANS)) finally (RETURN LOOP-ANS)) TESTS-AND-ALISTS-LST _ (for X in MACHINE collect (create TESTS-AND-ALISTS TESTS _ (SUB-PAIR-VAR-LST FORMALS (SARGS TERM) (fetch (TESTS-AND-CASES TESTS) of X)) ALISTS _ (for ARGLIST in (fetch (TESTS-AND-CASES CASES) of X) collect (for ACTUAL in (SARGS TERM) as FLG in MASK as ARG in ARGLIST bind LOOP-ANS do (SETQ LOOP-ANS (UNION-EQUAL (COND ((NULL FLG) NIL) ((EQ FLG (QUOTE CHANGEABLE)) (LIST (CONS ACTUAL (SUB-PAIR-VAR FORMALS (SARGS TERM) ARG)))) (T (for VAR in (ALL-VARS ACTUAL) collect (CONS VAR VAR)))) LOOP-ANS)) finally (RETURN LOOP-ANS))))) JUSTIFICATION _ JUSTIFICATION INDUCTION-TERM _ TERM]) (FLUSH-CAND1-DOWN-CAND2 [LAMBDA (CAND1 CAND2) (* kbr: "19-Oct-85 16:56") (LET (SCORE1 CONTROLLERS1 CHANGED-VARS1 UNCHANGEABLES1 TESTS-AND-ALISTS-LST1 JUSTIFICATION1 TERM1 OTHER-TERMS1 SCORE2 CONTROLLERS2 CHANGED-VARS2 UNCHANGEABLES2 TESTS-AND-ALISTS-LST2 JUSTIFICATION2 TERM2 OTHER-TERMS2) (SETQ SCORE1 (fetch (CANDIDATE SCORE) of CAND1)) (SETQ CONTROLLERS1 (fetch (CANDIDATE CONTROLLERS) of CAND1)) (SETQ CHANGED-VARS1 (fetch (CANDIDATE CHANGED-VARS) of CAND1)) (SETQ UNCHANGEABLES1 (fetch (CANDIDATE UNCHANGEABLE-VARS) of CAND1)) (SETQ TESTS-AND-ALISTS-LST1 (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of CAND1)) (SETQ JUSTIFICATION1 (fetch (CANDIDATE JUSTIFICATION) of CAND1)) (SETQ TERM1 (fetch (CANDIDATE INDUCTION-TERM) of CAND1)) (SETQ OTHER-TERMS1 (fetch (CANDIDATE OTHER-TERMS) of CAND1)) (SETQ SCORE2 (fetch (CANDIDATE SCORE) of CAND2)) (SETQ CONTROLLERS2 (fetch (CANDIDATE CONTROLLERS) of CAND2)) (SETQ CHANGED-VARS2 (fetch (CANDIDATE CHANGED-VARS) of CAND2)) (SETQ UNCHANGEABLES2 (fetch (CANDIDATE UNCHANGEABLE-VARS) of CAND2)) (SETQ TESTS-AND-ALISTS-LST2 (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of CAND2)) (SETQ JUSTIFICATION2 (fetch (CANDIDATE JUSTIFICATION) of CAND2)) (SETQ TERM2 (fetch (CANDIDATE INDUCTION-TERM) of CAND2)) (SETQ OTHER-TERMS2 (fetch (CANDIDATE OTHER-TERMS) of CAND2)) (COND ((AND (SUBSETP CHANGED-VARS1 CHANGED-VARS2) (SUBSETP UNCHANGEABLES1 UNCHANGEABLES2) (PIGEON-HOLE TESTS-AND-ALISTS-LST1 TESTS-AND-ALISTS-LST2 [FUNCTION (LAMBDA (TA1 TA2) (AND (SUBSETP (fetch (TESTS-AND-ALISTS TESTS) of TA1) (fetch (TESTS-AND-ALISTS TESTS) of TA2)) (OR (AND (NULL (fetch (TESTS-AND-ALISTS ALISTS) of TA1)) (NULL (fetch (TESTS-AND-ALISTS ALISTS) of TA2))) (PIGEON-HOLE (fetch (TESTS-AND-ALISTS ALISTS) of TA1) (fetch (TESTS-AND-ALISTS ALISTS) of TA2) [FUNCTION (LAMBDA (ALIST1 ALIST2) (PIGEON-HOLE ALIST1 ALIST2 [FUNCTION (LAMBDA (PAIR1 PAIR2) (AND (EQ (CAR PAIR1) (CAR PAIR2)) (OCCUR (CDR PAIR1) (CDR PAIR2] T T] T T] T T)) (create CANDIDATE SCORE _ (PLUS SCORE1 SCORE2) CONTROLLERS _ (UNIONQ CONTROLLERS1 CONTROLLERS2) CHANGED-VARS _ CHANGED-VARS2 UNCHANGEABLE-VARS _ UNCHANGEABLES2 TESTS-AND-ALISTS-LST _ TESTS-AND-ALISTS-LST2 JUSTIFICATION _ JUSTIFICATION2 INDUCTION-TERM _ TERM2 OTHER-TERMS _ (ADD-TO-SET TERM1 (UNION-EQUAL OTHER-TERMS1 OTHER-TERMS2)))) (T NIL]) (FN-SYMB0 [LAMBDA (X) (* kbr: "20-Oct-85 13:49") (* What type of constant is  (QUOTE X) ? *) (COND ((LITATOM X) (COND ((EQ X *1*T) (QUOTE TRUE)) ((EQ X *1*F) (QUOTE FALSE)) (T (QUOTE PACK)))) ((FIXP X) (COND ((LESSP X 0) (QUOTE MINUS)) ((EQUAL X 0) (QUOTE ZERO)) (T (QUOTE ADD1)))) ((EQ (CAR X) *1*SHELL-QUOTE-MARK) (CADR X)) (T (QUOTE CONS]) (FNNAMEP [LAMBDA (FN TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) (COND ((OR (MEMB FN *1*BTM-OBJECTS) (ASSOC FN SHELL-ALIST)) (MEMB FN (ALL-FNNAMES TERM))) (T NIL))) ((EQ FN (FFN-SYMB TERM)) T) (T (for X in (FARGS TERM) thereis (FNNAMEP FN X]) (FNNAMEP-IF [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) NIL) ((EQ (FFN-SYMB TERM) (QUOTE IF)) T) (T (for X in (FARGS TERM) thereis (FNNAMEP-IF X]) (FORM-COUNT [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* Returns the number of open  parentheses in the unabbreviated  presentation of TERM.  Also sets NUMBER-OF-VARIABLES to the  number of variables in TERM.  *) (SETQ NUMBER-OF-VARIABLES 0) (FORM-COUNT1 TERM]) (FORM-COUNT-EVG [LAMBDA (EVG) (* kbr: "20-Oct-85 15:59") (COND ((NLISTP EVG) (COND ((EQ EVG *1*T) 1) ((EQ EVG *1*F) 1) ((FIXP EVG) (COND ((LESSP EVG 0) (PLUS 2 (MINUS EVG))) (T (ADD1 EVG)))) (T (SETQ TEMP-TEMP (ASSOC EVG LITATOM-FORM-COUNT-ALIST)) (COND (TEMP-TEMP (CDR TEMP-TEMP)) (T (SETQ LITATOM-FORM-COUNT-ALIST (CONS (CONS EVG (PLUS 2 (TIMES 2 (NCHARS EVG)) (for I NUMBER from 1 to (NCHARS EVG) sum (NTHCHARCODE EVG I)))) LITATOM-FORM-COUNT-ALIST)) (CDR (CAR LITATOM-FORM-COUNT-ALIST))))))) ((EQ (CAR EVG) *1*SHELL-QUOTE-MARK) (ADD1 (for X in (CDDR EVG) sum (FORM-COUNT-EVG X)))) (T (PLUS 1 (FORM-COUNT-EVG (CAR EVG)) (FORM-COUNT-EVG (CDR EVG]) (FORM-COUNT1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (SETQ NUMBER-OF-VARIABLES (ADD1 NUMBER-OF-VARIABLES)) 0) ((FQUOTEP TERM) (FORM-COUNT-EVG (CADR TERM))) (T (ADD1 (for T1 in (FARGS TERM) sum (FORM-COUNT1 T1]) (FORM-INDUCTION-CLAUSE [LAMBDA (TESTS HYPS CONCL TERMS) (* kbr: "19-Oct-85 16:31") TERMS (* We once implemented the idea of both induction, opening up of the recursive  fns in the conclusion, and generalizing away some recursive calls.  This function did the expansion and generalization.  If the idea is reconsidered the following theorems are worthy of consideration:  (ORDERED (SORT X)), (IMPLIES (ORDERED X)  (ORDERED (ADDTOLIST I X))), (IMPLIES (AND  (NUMBER-LISTP X) (ORDERED X) (NUMBERP I)  (NOT (LESSP (CAR X) I))) (EQUAL (ADDTOLIST I X)  (CONS I X))), and (IMPLIES (AND (NUMBER-LISTP X)  (ORDERED X)) (EQUAL (SORT X) X)) . *) (APPEND TESTS HYPS CONCL]) (FORMP-SIMPLIFIER [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (X FN TL) (MATCH! TERM (FORMP X)) (COND ((VARIABLEP X) TERM) ((SHELLP X) (COND ((NEQ (FN-SYMB X) (QUOTE CONS)) (CONS-TERM (QUOTE LITATOM) (FARGS TERM))) (T (SETQ FN (ARGN X 1)) (SETQ TL (ARGN X 2)) (COND ((AND (QUOTEP FN) (LITATOM (CADR FN))) (COND ((EQ (CADR FN) (QUOTE QUOTE)) (BM-SUBST TL (QUOTE TL) (QUOTE (IF (LISTP TL) (EQUAL (CDR TL) (QUOTE NIL)) (QUOTE *1*FALSE))))) ((AND (GETPROP (CADR FN) (QUOTE TYPE-PRESCRIPTION-LST)) (NOT (MEMB (CADR FN) META-NAMES))) (SUBLIS-VAR (LIST (CONS (QUOTE TL) TL) (CONS (QUOTE A) (LIST (QUOTE QUOTE) (ARITY (CADR FN))))) (QUOTE (IF (EQUAL A (LENGTH TL)) (FORM-LSTP TL) (QUOTE *1*FALSE))))) (T TERM))) (T TERM))))) (T TERM]) (FORMULA-OF [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (LET (TEMP) (SETQ TEMP (GETPROP NAME (QUOTE EVENT))) (SELECTQ (CAR TEMP) ((ADD-AXIOM PROVE-LEMMA) (CADDDR TEMP)) (NIL]) (FREE-VAR-CHK [LAMBDA (NAME ARGS FORM) (* kbr: "19-Oct-85 16:31") (LET (TEMP) (SETQ FORM (ALL-VARS FORM)) (SETQ TEMP (SET-DIFF FORM ARGS)) (COND (TEMP (ERROR1 (PQUOTE (PROGN ILLEGAL FREE (PLURAL? TEMP VARIABLES VARIABLE) , (!PPR-LIST TEMP) , IN THE DEFINITION OF (!PPR NAME NIL) !)) (BINDINGS (QUOTE NAME) NAME (QUOTE TEMP) TEMP) (QUOTE SOFT)))) (SETQ TEMP (SET-DIFF ARGS FORM)) (COND (TEMP (ERROR1 (PQUOTE (PROGN (!LIST TEMP) (PLURAL? TEMP ARE IS) IN THE ARGLIST BUT NOT IN THE BODY OF THE DEFINITION OF (!PPR NAME NIL) !)) (BINDINGS (QUOTE NAME) NAME (QUOTE TEMP) TEMP) (QUOTE WARNING)))) NIL]) (FREE-VARSP [LAMBDA (TERM ALIST) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (NOT (ASSOC TERM ALIST))) ((FQUOTEP TERM) NIL) (T (for ARG in (FARGS TERM) thereis (FREE-VARSP ARG ALIST]) (GEN-VARS [LAMBDA (CL N VARIABLE-NAMES) (* kbr: "19-Oct-85 16:31") (* Generates N skolem constants not  occurring in clause CL.  *) (SET-DIFF-N VARIABLE-NAMES (for LIT in CL bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (ALL-VARS LIT) LOOP-ANS)) finally (RETURN LOOP-ANS)) N]) (GENERALIZE-CLAUSE [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") HIST (* Generalize the smallest common  subterms in CL -- as defined by  COMSUBTERMS -- using the lemmas on  GENERALIZE-LEMMAS to supply typing  info. *) (PROG (COMMONSUBTERMS) (COND ((NOT (ASSOC (QUOTE BEING-PROVED) STACK)) (RETURN NIL))) (SETQ COMMONSUBTERMS (GENRLTERMS CL)) (COND ((NULL COMMONSUBTERMS) (RETURN NIL)) (T (SETQ PROCESS-CLAUSES (LIST (GENERALIZE1 CL COMMONSUBTERMS GEN-VARIABLE-NAMES1))) (SETQ PROCESS-HIST (LIST GENERALIZING-SKOS COMMONSUBTERMS OBVIOUS-RESTRICTIONS GENERALIZE-LEMMA-NAMES)) (SETQ ALL-LEMMAS-USED (UNIONQ GENERALIZE-LEMMA-NAMES ALL-LEMMAS-USED)) (RETURN T]) (GENERALIZE-SENT [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (EXECUTE (QUOTE GENERALIZE-CLAUSE) CL HIST (QUOTE SIMPLIFY-SENT) (QUOTE ELIMINATE-IRRELEVANCE-SENT]) (GENERALIZE1 [LAMBDA (CL SUBTERMLST VARIABLE-NAMES) (* kbr: "19-Oct-85 16:31") (* Replaces all occurrences of the subterms in SUBTERMLST in CL by new vars,  and qualifies each var with all the information known to GET-TYPES.  *) (SETQ GENERALIZING-SKOS (GEN-VARS CL (LENGTH SUBTERMLST) VARIABLE-NAMES)) (SETQ OBVIOUS-RESTRICTIONS NIL) (SETQ GENERALIZE-LEMMA-NAMES NIL) (GENERALIZE2 SUBTERMLST GENERALIZING-SKOS CL]) (GENERALIZE2 [LAMBDA (TERMLST VARLST CL) (* kbr: "19-Oct-85 20:00") (for LIT in (SCRUNCH (NCONC (for SUBTERM in TERMLST join (for HYP in (GET-TYPES SUBTERM CL) collect (DUMB-NEGATE-LIT HYP))) CL)) collect (SUB-PAIR-EXPR TERMLST VARLST LIT]) (GENRLT1 [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (LET (LHS RHS) (for LIT in CL when (OR (BM-MATCH LIT (EQUAL LHS RHS)) (BM-MATCH LIT (NOT (EQUAL LHS RHS)))) do (COMSUBTERMS LHS RHS)) (for TAIL on CL do (for LIT2 in (CDR TAIL) do (COMSUBTERMS (CAR TAIL) LIT2))) NIL]) (GENRLTERMS [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (LET (GENRLTLIST) (GENRLT1 CL) GENRLTLIST]) (GET-CANDS [LAMBDA (TERM) (* kbr: "19-Oct-85 20:06") (* Returns all of the induction  principles -- see  POSSIBLE-IND-PRINCIPLES --  connected to terms in TERM, which is  the conjecture to be proved.  *) (COND ((VARIABLEP TERM) NIL) ((QUOTEP TERM) NIL) (T (NCONC (POSSIBLE-IND-PRINCIPLES TERM) (for ARG in (FARGS TERM) join (GET-CANDS ARG]) (GET-LISP-SEXPR [LAMBDA (FN) (* kbr: "19-Oct-85 16:31") (LET (SEXPR) (COND ((NULL (GETPROP FN (QUOTE LISP-CODE))) (ERROR1 (PQUOTE (PROGN (!PPR FN NIL) DOES NOT HAVE A RUNNABLE LISP DEFINITION %.)) (BINDINGS (QUOTE FN) FN) (QUOTE SOFT)))) (SETQ SEXPR (GETPROP (GETPROP FN (QUOTE LISP-CODE)) (QUOTE SEXPR))) (COND ((NULL SEXPR) (ERROR1 (PQUOTE (PROGN (!PPR FN NIL) IS PART OF THE BASIC SYSTEM AND HAS A HAND-CODED LISP DEFINITION %.)) (BINDINGS (QUOTE FN) FN) (QUOTE SOFT))) (T SEXPR]) (GET-LEVEL-NO [LAMBDA (FNNAME) (* kbr: "19-Oct-85 16:31") (OR (GETPROP FNNAME (QUOTE LEVEL-NO)) 0]) (GET-STACK-NAME [LAMBDA (STACKV) (* kbr: "26-Oct-85 13:59") (PACK (CONS (QUOTE *) (CDR (for I in (DREVERSE (GET-STACK-NAME1 STACKV)) join (CONS (QUOTE %.) (UNPACK I]) (GET-STACK-NAME1 [LAMBDA (STACKV) (* kbr: "19-Oct-85 16:31") (LET (ANS) (COND ((NULL STACKV) (LIST 1)) ((EQ (CAAR STACKV) (QUOTE TO-BE-PROVED)) (SETQ ANS (GET-STACK-NAME1 (CDR STACKV))) (RPLACA ANS (ADD1 (CAR ANS)))) (T (CONS 1 (GET-STACK-NAME1 (CDR STACKV]) (GET-TYPES [LAMBDA (TERM CL) (* kbr: "19-Oct-85 16:31") (LET (TYPE-RESTRICTION LEMMA-RESTRICTIONS TYPE PAIR INST-LEMMA) CL (SETQ TYPE (TYPE-SET TERM)) (SETQ TYPE-RESTRICTION (COND ((SETQ PAIR (for PAIR in RECOGNIZER-ALIST when (IEQP TYPE (CDR PAIR)) do (RETURN PAIR))) (FCONS-TERM* (CAR PAIR) TERM)) (T NIL))) (COND (TYPE-RESTRICTION (SETQ OBVIOUS-RESTRICTIONS (ADD-TO-SET TYPE-RESTRICTION OBVIOUS-RESTRICTIONS)))) (SETQ LEMMA-RESTRICTIONS (for LEMMA in GENERALIZE-LEMMAS unless (DISABLEDP (fetch (GENERALIZE-LEMMA NAME) of LEMMA)) when (AND (ARG1-IN-ARG2-UNIFY-SUBST TERM (fetch (GENERALIZE-LEMMA TERM) of LEMMA)) (NOT (FREE-VARSP (fetch (GENERALIZE-LEMMA TERM) of LEMMA) UNIFY-SUBST)) (NOT (FNNAMEP (FN-SYMB TERM) (SUBST-EXPR (QUOTE X) TERM (SETQ INST-LEMMA (SUBLIS-VAR UNIFY-SUBST (fetch (GENERALIZE-LEMMA TERM) of LEMMA))))))) collect (PROGN (SETQ GENERALIZE-LEMMA-NAMES (CONS (fetch (GENERALIZE-LEMMA NAME) of LEMMA) GENERALIZE-LEMMA-NAMES)) INST-LEMMA))) (COND (TYPE-RESTRICTION (CONS TYPE-RESTRICTION LEMMA-RESTRICTIONS)) (T LEMMA-RESTRICTIONS]) (GREATEREQP [LAMBDA (I J) (* kbr: "19-Oct-85 16:31") (NOT (LESSP I J]) (GUARANTEE-CITIZENSHIP [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (COND ((AND (NOT (GETPROP NAME (QUOTE EVENT))) (NOT (GETPROP NAME (QUOTE MAIN-EVENT)))) (PUT1 MAIN-EVENT-NAME (CONS NAME (GETPROP MAIN-EVENT-NAME (QUOTE SATELLITES))) (QUOTE SATELLITES)) (PUT1 NAME MAIN-EVENT-NAME (QUOTE MAIN-EVENT]) (GUESS-RELATION-MEASURE-LST [LAMBDA (FORMALS MACHINE) (* kbr: "19-Oct-85 16:31") (* We assume MACHINE is a list of TESTS-AND-CASE.  We will guess that the COUNT goes down with LESSP on formal tested and changed  in every line of the machine. *) (for VAR in FORMALS as I from 0 when (for X in MACHINE always (AND (OCCUR-LST VAR (fetch (TESTS-AND-CASE TESTS) of X)) (NEQ VAR (BM-NTH I (fetch (TESTS-AND-CASE CASE) of X))))) collect (LIST (QUOTE LESSP) (LIST (QUOTE COUNT) VAR]) (HAS-LIB-PROPS [LAMBDA (ATM) (* kbr: "19-Oct-85 16:31") (for TAIL on (GETPROPLIST ATM) by (QUOTE CDDR) thereis (AND (MEMB (CAR TAIL) LIB-PROPS) (CADR TAIL]) (ILLEGAL-CALL [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (ERROR1 (PQUOTE (PROGN SOME FUNCTION WAS CALLED WITH INAPPROPRIATE ARGUMENTS %.)) NIL (QUOTE HARD]) (ILLEGAL-NAME [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (NOT (AND (LITATOM NAME) (LITATOM NAME) (LEGAL-CHAR-CODE-SEQ (CHCON NAME]) (IMMEDIATE-DEPENDENTS-OF [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (LET (ATM) (COND ((EQ NAME (QUOTE GROUND-ZERO)) (REMOVE1 (QUOTE GROUND-ZERO) CHRONOLOGY)) ((NOT (GETPROP NAME (QUOTE EVENT))) (ERROR1 (PQUOTE (PROGN IMMEDIATE-DEPENDENTS-OF WAS CALLED ON A NONEVENT , (!PPR NAME NIL) %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE HARD))) ((SETQ ATM (TYPE-PRESCRIPTION-LEMMAP NAME)) (* NAME is a type prescription lemma hung under ATM.  In this case, we must include in the dependents of NAME all events dependent  upon ATM that occurred after NAME was introduced.  This clause in the UNDO mechanism is the source of doubt that the mechanism  correctly identifies all of the dependents of an event.  The problem starts with the fact that the use of type set lemmas is not tracked  like other lemmas. In fact, no code in the theorem prover actually notes when  or how a particular type set lemma is used.  How then can we hope to determine which proofs  (or other events) depend upon a type set lemma? We have tried several  approaches to the question. Some have turned out incorrect.  We believe the current one to be correct.  Our hand-waving proof of its correctness is this.  If a type set lemma about the function FN is used in the proof of THM, then  either (1) THM mentions FN, (2) some lemma used in the proof of THM  (other than a type set lemma) mentions FN,  (3) some lemma used in the proof of THM mentions a function whose definition  mentions FN, (3.a) some lemma used in the proof of THM uses a function whose  definition mentions a function that either  (3.b) mentions FN or (3.c) mentions a function whose definition mentions FN, or  ... But we believe that any such lemma introducing FN into the proof is in  ALL-LEMMAS-USED when the proof is done and thus has THM as one of its  IMMEDIATE-DEPENDENTS0. To put it in terms of the following code, we believe  that there is a an IMMEDIATE-DEPENDENTS0 path, from FN to THM.  Given that hypothesis, we then correctly identify a superset of the dependents  of a type set lemma by the draconian strategy of claiming as a dependent event  any event on a tree-path that took place later than the type set lemma.  Note that this computation is not trying to get all of the theorems dependent  (somehow) upon the type set lemma in question but only those immediately  dependent -- i.e., whose proofs might have actually appealed to this type set  lemma. It is assumed that any function using IMMEDIATE-DEPENDENTS-OF to explore  the logical graph of events will recurse on each of the dependent events, and  thus catch things like THMs dependent upon type set lemmas dependent upon the  type set lemma in question. *) (UNION-EQUAL (for X in (TREE-DEPENDENTS (MAIN-EVENT-OF ATM)) when (EVENT1-OCCURRED-BEFORE-EVENT2 NAME X CHRONOLOGY) collect X) (for X in (GETPROP NAME (QUOTE IMMEDIATE-DEPENDENTS0)) collect X))) (T (for X in (GETPROP NAME (QUOTE IMMEDIATE-DEPENDENTS0)) collect X]) (IMPLIES? [LAMBDA (TESTS TERM) (* kbr: "19-Oct-85 16:31") (MEMBER TERM TESTS]) (IMPOSSIBLE-POLYP [LAMBDA (POLY) (* kbr: "19-Oct-85 16:31") (AND (GREATERP (fetch (POLY CONSTANT) of POLY) 0) (for PAIR in (fetch (POLY ALIST) of POLY) always (GREATEREQP (CDR PAIR) 0]) (IND-FORMULA [LAMBDA (TESTS-AND-ALISTS-LST TERMS CL-SET) (* kbr: "19-Oct-85 20:08") (* TESTS-AND-ALISTS-LST is a such a list that the disjunction of the  conjunctions of the TESTS components of the members is T.  Furthermore, there exists a measure M, a well-founded relation R, and a  sequence of variables x1, ..., xn such that for each T&Ai in  TESTS-AND-ALISTS-LST, for each alist alst in the ALISTS component of T&Ai, the  conjunction of the TESTS component, say qi, implies that  (R (M x1 ... xn) /alst (M x1 ... xn))%. To prove thm, the conjunction of the  disjunctions of the members of CL-SET, it is sufficient, by the principle of  induction, to prove instead the conjunction of the terms qi & thm' & thm'' ...  -> thm, where the primed terms are the results of substituting the alists in  the ALISTS field of the ith member of TESTS-AND-ALISTS-LST into thm.  If thm1, thm2, ..., thmn are the disjunctions of the members of CL-SET, then it  is sufficient to prove all of the formulas qi & thm' & thm'' ...  -> thmj. This is a trivial proposition fact, to prove  (IMPLIES A (AND B C)) it is sufficient to prove  (IMPLIES A B) and (IMPLIES A C) The (FOR PICK ...) expression below returns a  list of clauses whose conjunction propositionally implies qi & thm' & thm'' ...  -> thmj, where TA is the ith member of TESTS-AND-ALISTS-LST and CL is the jth  member of CL-SET. Proof: Let THM have the form:  (AND (OR a1 ...) (OR b1 ...) ... (OR z1 ...))%.  Then qi & thm' & thm'' ... -> thmj has the form:  (IMPLIES (AND qi (AND (OR a1 ...) (OR b1 ...) ...  (OR z1 ...)) (QUOTE (AND (OR a1 ...) (OR b1 ...) ...  (OR z1 ...))) (QUOTE (QUOTE ...)) (AND (OR a1 ...)  (OR b1 ...) ... (OR z1 ...))) (QUOTE (QUOTE  (QUOTE ...'))) thmj)%. Suppose this formula is false for some values of the  free variables. Then under those values, each disjunction in the hypothesis is  true. Thus there exists a way of choosing one literal from each of the  disjunctions, all of which are true. This choice is one of the PICKs below.  But we prove that (IMPLIES (AND qi PICK) thmj) . *) (DELETE-TAUTOLOGIES (SCRUNCH-CLAUSE-SET (for CL in CL-SET join (for TA in TESTS-AND-ALISTS-LST join (for PICK in (ALL-PICKS (for CL1 in CL-SET join (for ALIST in (fetch (TESTS-AND-ALISTS ALISTS) of TA) collect (for LIT in CL1 collect (NEGATE-LIT (SUBLIS-VAR ALIST LIT)))) )) collect (FORM-INDUCTION-CLAUSE (for TEST in (fetch (TESTS-AND-ALISTS TESTS) of TA) collect (NEGATE-LIT TEST)) PICK CL TERMS]) (INDUCT [LAMBDA (CL-SET) (* kbr: "19-Oct-85 20:09") (LET (GET-CANDS-ANS MERGED-CANDS-ANS PICK-HIGH-SCORES-ANS WINNING-CAND INDUCT-ANS COMPUTE-VETOES-ANS FAVOR-COMPLICATED-CANDIDATES-ANS) (SETQ WINNING-CAND (CAR (SETQ PICK-HIGH-SCORES-ANS (PICK-HIGH-SCORES (SETQ FAVOR-COMPLICATED-CANDIDATES-ANS (FAVOR-COMPLICATED-CANDIDATES (SETQ COMPUTE-VETOES-ANS (COMPUTE-VETOES (SETQ MERGED-CANDS-ANS (TRANSITIVE-CLOSURE (SETQ GET-CANDS-ANS (REMOVE-UNCHANGING-VARS (for CL in CL-SET join (for LIT in CL join (GET-CANDS LIT))) CL-SET)) (FUNCTION MERGE-CANDS))))))))))) (COND (WINNING-CAND (SETQ INDUCT-ANS (IND-FORMULA (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of WINNING-CAND) (CONS (fetch (CANDIDATE INDUCTION-TERM) of WINNING-CAND) (fetch (CANDIDATE OTHER-TERMS) of WINNING-CAND )) CL-SET)) (INFORM-SIMPLIFY (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of WINNING-CAND) (CONS (fetch (CANDIDATE INDUCTION-TERM) of WINNING-CAND) (fetch (CANDIDATE OTHER-TERMS) of WINNING-CAND)))) (T (IO (QUOTE INDUCT) CL-SET NIL (LIST NIL) (LIST (GET-STACK-NAME (CDR STACK)) NIL 0 0 0 0 0)) (WRAPUP NIL))) (SETQ ALL-LEMMAS-USED (UNIONQ (fetch (JUSTIFICATION LEMMAS) of (fetch (CANDIDATE JUSTIFICATION) of WINNING-CAND)) ALL-LEMMAS-USED)) (IO (QUOTE INDUCT) CL-SET NIL INDUCT-ANS (LIST (GET-STACK-NAME (CDR STACK)) WINNING-CAND (LENGTH GET-CANDS-ANS) (LENGTH MERGED-CANDS-ANS) (COND ((EQ COMPUTE-VETOES-ANS MERGED-CANDS-ANS) 0) (T (LENGTH COMPUTE-VETOES-ANS))) (LENGTH PICK-HIGH-SCORES-ANS) (LENGTH FAVOR-COMPLICATED-CANDIDATES-ANS))) INDUCT-ANS]) (INDUCT-VARS [LAMBDA (CAND) (* kbr: "19-Oct-85 16:31") (* Get all skos occupying controller  slots in any of the terms associated  with this candidate.  *) (for TERM in (CONS (fetch (CANDIDATE INDUCTION-TERM) of CAND) (fetch (CANDIDATE OTHER-TERMS) of CAND)) bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (for ARG in (FARGS TERM) as I from 0 when (AND (VARIABLEP ARG) (for MASK in (GETPROP (FFN-SYMB TERM) (QUOTE CONTROLLER-POCKETS)) thereis (NOT (IEQP 0 (LOGAND 1 (LSH MASK (MINUS I))))))) collect ARG) LOOP-ANS)) finally (RETURN LOOP-ANS]) (INDUCTION-MACHINE [LAMBDA (FNNAME TERM TESTS) (* kbr: "24-Oct-85 14:57") (* See the comment for  TERMINATION-MACHINE.  *) (COND ((OR (VARIABLEP TERM) (FQUOTEP TERM) (NEQ (FFN-SYMB TERM) (QUOTE IF))) (LIST (create TESTS-AND-CASES TESTS _ (REMOVE-REDUNDANT-TESTS TESTS NIL) CASES _ (UNION-EQUAL (PROG (LOOP-ANS) (for TEST in TESTS do (SETQ LOOP-ANS (UNION-EQUAL (ALL-ARGLISTS FNNAME TEST) LOOP-ANS))) (RETURN LOOP-ANS)) (ALL-ARGLISTS FNNAME TERM))))) (T (NCONC (INDUCTION-MACHINE FNNAME (FARGN TERM 2) (APPEND TESTS (LIST (FARGN TERM 1)))) (INDUCTION-MACHINE FNNAME (FARGN TERM 3) (APPEND TESTS (LIST (NEGATE-LIT (FARGN TERM 1]) (INFORM-SIMPLIFY [LAMBDA (TESTS-AND-ALISTS-LST TERMS) (* kbr: "19-Oct-85 20:10") (* Two of the variables effecting REWRITE are TERMS-TO-BE-IGNORED-BY-REWRITE  and EXPAND-LST. When any term on the former is encountered REWRITE returns it  without rewriting it. Terms on the latter must be calls of defined fns and when  encountered are replaced by the rewritten body.  We believe that the theorem prover will perform significantly faster on many  theorems if, after an induction, it does not waste time  (a) trying to simplify the recursive calls introduced in the induction  hypotheses and (b) trying to decide whether to expand the terms inducted for in  the induction conclusion. This suspicion is due to some testing done with the  idea of generalizing the recursive calls away at INDUCT time after expanding  the induction terms in the conclusion. Homographication speeded the  theorem-prover on many theorems but lost on several others because of the  premature generalization. See the comment in FORM-INDUCTION-CLAUSE.  To avoid the generalization at INDUCT time we are going to try using  TERMS-TO-BE-IGNORED-BY-REWRITE. The idea is this, during the initial  simplification of a clause produced by INDUCT we will have the recursive terms  on TERMS-TO-BE-IGNORED-BY-REWRITE. When the clause settles down --  hopefully it will often be proved first --  we will restore TERMS-TO-BE-IGNORED-BY-REWRITE to its pre-INDUCT value.  Note however that we have to mess with TERMS-TO-BE-IGNORED-BY-REWRITE on a  clause by clause basis, not just once in INDUCT.  So here is the plan. INDUCT will set INDUCTION-HYP-TERMS to the list of  instances of the induction terms, and will set INDUCTION-CONCL-TERMS to the  induction terms themselves. SIMPLIFY-CLAUSE will look at the history of the  clause to determine whether it has settled down since induction.  If not it will bind TERMS-TO-BE-IGNORED-BY-REWRITE to the concatenation of  INDUCTION-HYP-TERMS and its old value and will analogously bind EXPAND-LST.  A new process, called SETTLED-DOWN-SENT, will be used to mark when in the  history the clause settled down. *) (SETQ INDUCTION-CONCL-TERMS TERMS) (SETQ INDUCTION-HYP-TERMS (for TA in TESTS-AND-ALISTS-LST join (for ALIST in (fetch (TESTS-AND-ALISTS ALISTS) of TA) join (SUBLIS-VAR-LST ALIST TERMS]) (INIT-LEMMA-STACK [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (SETQ LEMMA-STACK ORIG-LEMMA-STACK) NIL]) (INIT-LIB [LAMBDA (PROPS VARS) (* kbr: "19-Oct-85 16:31") (* Initialize the variables used to  keep track of what is on the lib file.  *) (KILL-LIB) (SETQ LIB-PROPS PROPS) (SETQ LIB-VARS VARS) (for VAR in LIB-VARS do (SET VAR NIL)) (SETQ LIB-ATOMS-WITH-PROPS NIL) (SETQ LIB-ATOMS-WITH-DEFS NIL) (SETQ LIB-FILE NIL]) (INIT-LINEARIZE-ASSUMPTIONS-STACK [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (SETQ LINEARIZE-ASSUMPTIONS-STACK ORIG-LINEARIZE-ASSUMPTIONS-STACK) NIL]) (INTERESTING-SUBTERMS [LAMBDA (FORM) (* kbr: "19-Oct-85 16:31") (* Returns a list of all of the subterms of FORM that are not variables or  quotes or terms whose function symbol is CAR CDR LISTP EQ NEQ NOT.  Returns the EQ subterms. This fact is used to catch and optimize common  subexpression evaluation. *) (COND ((VARIABLEP FORM) NIL) ((FQUOTEP FORM) NIL) ((MEMB (FFN-SYMB FORM) (QUOTE (CAR CDR LISTP EQ NEQ NOT))) (for ARG in (FARGS FORM) do (APPEND (INTERESTING-SUBTERMS ARG)))) (T (CONS FORM (for ARG in (FARGS FORM) do (APPEND (INTERESTING-SUBTERMS ARG]) (INTERSECTP [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (for E in X thereis (MEMBER E Y]) (INTRODUCE-ANDS [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (REST1 REST2) (COND ((NLISTP X) X) ((EQ (CAR X) (QUOTE QUOTE)) X) ((BM-MATCH X (*2*IF & & (QUOTE NIL))) (SETQ REST1 (INTRODUCE-ANDS (CADR X))) (SETQ REST2 (INTRODUCE-ANDS (CADDR X))) (COND ((AND (LISTP REST1) (EQ (CAR REST1) (QUOTE AND))) (COND ((AND (LISTP REST2) (EQ (CAR REST2) (QUOTE AND))) (APPEND REST1 (CDR REST2))) (T (APPEND REST1 (CONS REST2 NIL))))) ((AND (LISTP REST2) (EQ (CAR REST2) (QUOTE AND))) (CONS (QUOTE AND) (CONS REST1 (CDR REST2)))) (T (LIST (QUOTE AND) REST1 REST2)))) (T (CONS (CAR X) (for ARG in (CDR X) collect (INTRODUCE-ANDS ARG]) (INTRODUCE-LISTS [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (REST) (COND ((NLISTP X) X) ((EQ (CAR X) (QUOTE QUOTE)) (KWOTE (CADR X))) ((EQ (CAR X) (QUOTE CONS)) (SETQ REST (INTRODUCE-LISTS (CADDR X))) (COND ((NULL REST) (LIST (QUOTE LIST) (INTRODUCE-LISTS (CADR X)))) ((AND (LISTP REST) (EQ (CAR REST) (QUOTE LIST))) (CONS (QUOTE LIST) (CONS (INTRODUCE-LISTS (CADR X)) (CDR REST)))) (T (LIST (QUOTE CONS) (INTRODUCE-LISTS (CADR X)) REST)))) (T (CONS (CAR X) (for ARG in (CDR X) collect (INTRODUCE-LISTS ARG]) (JUMPOUTP [LAMBDA (OLD NEW) (* kbr: " 4-Jul-86 17:22") (* It is claimed that JUMPOUTP is a mere optimization of the book version of  the rewriter. The proof rests on two observations.  The first is that if any subterm of the rewritten function body fails to  satisfy REWRITE-FNCALLP then the entire body fails --  i.e., it does not matter if other parts are super-good.  This means that as soon as we lay our hands on a subterm that is GUARANTEED to  survive future rewriting and be returned as part of the value of the REWRITE  call in REWRITE-FNCALL we can check that it satisfies REWRITE-FNCALLP and if  not, abort then and there. The second lemma is that if the DEFN-FLG of REWRITE  is T then the value of that rewrite will survive to be part of the value  computed by the REWRITE call in REWRITE-FNCALL.  Proof of this is by inspection of the places REWRITE is called.  In particular, if REWRITE's value is that of a recursive call, the call may be  passed the same value of the DEFN-FLG, the DEFN-FLG may be turned on only by  REWRITE-FNCALL, and must be NIL in rewriting arguments to non-IFs  (which might disappear as a result of higher level rewrites), tests to IF's  even on the main path through a defn (because the tests may be eliminated by  (IF ITIMES y y)) and in rewrite calls to relieve hyps  (which do not have any relation to what is seen by the REWRITE-FNCALLP check in  REWRITE-FNCALL) the most subtle part of the proof is that if you are  simplifying an (IF test left right) that is guaranteed to participate in the  value returned to REWRITE-FNCALL, then both the values of left and right will  be -- at least, they will be when they are non-trivial values that might  possible offend REWRITE-FNCALLP. The proof of this is by inspection of  REWRITE-IF1 which either returns the newly consed up IF of the values, which is  perfect, or else returns pieces (i.e., test, or left, or right's value alone)  under conditions that guarantee that nothing is lost.  Thus, if the DEFN-FLG is on, JUMPOUTP can call REWRITE-FNCALLP and jump out of  the lowest REWRITE-FNCALL if the newly computed value offends it.  Since JUMPOUTP is only called on the branches of IFs there must still be a call  of REWRITE-FNCALLP on the final answer in REWRITE-FNCALL since tests  (which could have been eliminated by (IF ITIMES y y)) might still offend.  Finally, to avoid calling REWRITE-FNCALLP exponentially while backing out of an  IF-tree, we do not even bother to call it if the old value of the term was  itself an IF, since JUMPOUTP okay'd its branches --  but not its test -- earlier. *) (COND (NIL (NOT (EQUAL NEW (SUBLIS ALIST OLD))) (SHOWPRINT (SUBLIS ALIST OLD)) (SHOWPRINT NEW) (\GETKEY))) (COND ((AND DEFN-FLG (NVARIABLEP OLD) (NEQ (FN-SYMB OLD) (QUOTE IF)) (NOT (REWRITE-FNCALLP (CAR FNSTACK) NEW))) (POP-LEMMA-FRAME) (RETFROM (QUOTE REWRITE-FNCALL) (LET ((TYPE-ALIST *TYPE-ALIST*)) (REWRITE-SOLIDIFY (CONS-TERM *FNNAME* *ARGLIST*))))) (T NEW]) (KILL-EVENT [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (COND ((EQ NAME (QUOTE GROUND-ZERO)) (KILL-LIB)) (T (for TUPLE in (GETPROP NAME (QUOTE LOCAL-UNDO-TUPLES)) do (ADD-SUB-FACT NIL NIL NIL TUPLE NIL)) (for SATELLITE in (GETPROP NAME (QUOTE SATELLITES)) do (KILLPROPLIST1 SATELLITE)) (KILLPROPLIST1 NAME) (SETQ CHRONOLOGY (REMOVE1 NAME CHRONOLOGY)) NAME]) (KILL-LIB [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (* Erase all trace of the lib file.  *) (COND ((BOUNDP (QUOTE LIB-PROPS)) (for ATM in LIB-ATOMS-WITH-PROPS do (KILLPROPLIST1 ATM)) (for FN in LIB-ATOMS-WITH-DEFS do (KILL-DEFINITION FN)) (for VAR in LIB-VARS do (MAKUNBOUND VAR)) (MAKUNBOUND (QUOTE LIB-VARS)) (MAKUNBOUND (QUOTE LIB-ATOMS-WITH-PROPS)) (MAKUNBOUND (QUOTE LIB-ATOMS-WITH-DEFS)) (MAKUNBOUND (QUOTE LIB-PROPS)) (MAKUNBOUND (QUOTE LIB-FILE]) (KILLPROPLIST1 [LAMBDA (ATM) (* kbr: "19-Oct-85 16:31") (* Kill all properties of ATM that are  maintained by the lib file.  *) (for PROP in LIB-PROPS do (REMPROP ATM PROP)) (REMPROP ATM (QUOTE LIB-LOC]) (LEGAL-CHAR-CODE-SEQ [LAMBDA (LST) (* kbr: "17-Nov-85 15:38") (* WARNING The EVG-OCCUR functions  make delicate use of the ascii codes  permitted in litatoms in evgs.  *) (AND (LISTP LST) (for TAIL on LST bind C until (NLISTP TAIL) always (PROGN (SETQ C (CAR TAIL)) (AND (FIXP C) (OR (AND (LESSEQP (CHARCODE A) C) (LESSEQP C (CHARCODE Z))) (AND (LESSEQP (CHARCODE 0) C) (LESSEQP C (CHARCODE 9))) (EQUAL C (CHARCODE -)))))) (NOT (EQUAL (CAR LST) (CHARCODE -))) (NOT (AND (LESSEQP (CHARCODE 0) (CAR LST)) (LESSEQP (CAR LST) (CHARCODE 9]) (LENGTH-TO-ATOM [LAMBDA (L) (* kbr: "19-Oct-85 16:31") (for TAIL on L until (NLISTP TAIL) count T]) (LESSEQP [LAMBDA (I J) (* kbr: "19-Oct-85 16:31") (NOT (LESSP J I]) (LEXORDER [LAMBDA (X Y) (* kbr: "20-Oct-85 18:47") (* LEXORDER is a total ordering on  LISP objects constructed from numbers,  litatoms, and conses.  See the comment in TERM-ORDER for the  definitions of *) (COND ((NLISTP X) (COND ((NLISTP Y) (* From the VM one can conclude that  ALPHORDER is a total ordering when  restricted to ATOMs.  *) (ALPHORDER X Y)) (T T))) ((NLISTP Y) NIL) ((EQUAL (CAR X) (CAR Y)) (LEXORDER (CDR X) (CDR Y))) (T (LEXORDER (CAR X) (CAR Y]) (LINEARIZE [LAMBDA (TERM FLG) (* kbr: "22-Oct-85 15:27") (* If FLG is T linearize TERM, else linearize the negation of TERM.  We store TERM in the LITERALS field regardless of FLG.  ADD-EQUATIONS looks in the LITERALS field to see if the CURRENT-LIT is a father  of a POLY and if so does not use it in cancellation.  Similarly ADD-EQUATIONS looks in the LEMMAS field for members of the original  clause, i.e., LITS-THAT-MAY-BE-ASSUMED-FALSE.  *) (LET (LHS RHS LST CONTRA) (SETQ LST (COND ((COND (FLG (BM-MATCH TERM (LESSP LHS RHS))) (T (BM-MATCH TERM (NOT (LESSP LHS RHS))))) (LIST (LIST (COMPRESS-POLY (ADD-LINEAR-TERM (CONS-TERM (QUOTE ADD1) (LIST LHS)) (QUOTE POSITIVE) (ADD-LINEAR-TERM RHS (QUOTE NEGATIVE) (ZERO-POLY TERM))))))) ((COND (FLG (BM-MATCH TERM (EQUAL LHS RHS))) (T (BM-MATCH TERM (NOT (EQUAL LHS RHS))))) (COND ((OR (POSSIBLY-NUMERIC LHS) (POSSIBLY-NUMERIC RHS)) (LIST (LIST (COMPRESS-POLY (ADD-LINEAR-TERM LHS (QUOTE POSITIVE) (ADD-LINEAR-TERM RHS (QUOTE NEGATIVE) (ZERO-POLY TERM)))) (COMPRESS-POLY (ADD-LINEAR-TERM RHS (QUOTE POSITIVE) (ADD-LINEAR-TERM LHS (QUOTE NEGATIVE) (ZERO-POLY TERM))))))) (T NIL))) ((COND (FLG (BM-MATCH TERM (NOT (LESSP LHS RHS)))) (T (BM-MATCH TERM (LESSP LHS RHS)))) (LIST (LIST (COMPRESS-POLY (ADD-LINEAR-TERM RHS (QUOTE POSITIVE) (ADD-LINEAR-TERM LHS (QUOTE NEGATIVE) (ZERO-POLY TERM))))))) ((COND (FLG (BM-MATCH TERM (NOT (EQUAL LHS RHS)))) (T (BM-MATCH TERM (EQUAL LHS RHS)))) (COND ((OR (POSSIBLY-NUMERIC LHS) (POSSIBLY-NUMERIC RHS)) (LIST (LIST (ADD-NUMBERP-ASSUMPTION-TO-POLY LHS (ADD-NUMBERP-ASSUMPTION-TO-POLY RHS (COMPRESS-POLY (ADD-LINEAR-TERM (CONS-TERM (QUOTE ADD1) (LIST LHS)) (QUOTE POSITIVE) (ADD-LINEAR-TERM RHS (QUOTE NEGATIVE) (ZERO-POLY TERM))))))) (LIST (ADD-NUMBERP-ASSUMPTION-TO-POLY LHS (ADD-NUMBERP-ASSUMPTION-TO-POLY RHS (COMPRESS-POLY (ADD-LINEAR-TERM (CONS-TERM (QUOTE ADD1) (LIST RHS)) (QUOTE POSITIVE) (ADD-LINEAR-TERM LHS (QUOTE NEGATIVE) (ZERO-POLY TERM))))))))) (T NIL))) (T NIL))) (SETQ LST (for L in LST collect (for POLY in L unless (MEMBER FALSE (fetch (POLY ASSUMPTIONS ) of POLY)) collect POLY))) (COND ((IEQP (LENGTH LST) 2) (* If either member of LST contains a contradiction, we delete that member from  LST after moving into each member of the other member of LST the assumptions  and lemmas upon which the contradiction depends.  *) (COND ((SETQ CONTRA (for POLY in (CAR LST) when (IMPOSSIBLE-POLYP POLY) do (RETURN POLY))) (for POLY in (CADR LST) do (replace (POLY ASSUMPTIONS) of POLY with (UNION-EQUAL (fetch (POLY ASSUMPTIONS) of CONTRA) (fetch (POLY ASSUMPTIONS) of POLY))) (replace (POLY LEMMAS) of POLY with (UNIONQ (fetch (POLY LEMMAS) of CONTRA) (fetch (POLY LEMMAS) of POLY)))) (SETQ LST (LIST (CADR LST)))) ((SETQ CONTRA (for POLY in (CADR LST) when (IMPOSSIBLE-POLYP POLY) do (RETURN POLY))) (for POLY in (CAR LST) do (replace (POLY ASSUMPTIONS) of POLY with (UNION-EQUAL (fetch (POLY ASSUMPTIONS) of CONTRA) (fetch (POLY ASSUMPTIONS) of POLY))) (replace (POLY LEMMAS) of POLY with (UNIONQ (fetch (POLY LEMMAS) of CONTRA) (fetch (POLY LEMMAS) of POLY)))) (SETQ LST (LIST (CAR LST))))))) LST]) (LISTABLE [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (LHS RHS) (COND ((VARIABLEP X) NIL) ((FQUOTEP X) NIL) ((BM-MATCH X (LIST (QUOTE CONS) LHS RHS)) (COND ((EQUAL RHS (QUOTE (QUOTE NIL))) (LIST LHS)) ((SETQ TEMP-TEMP (LISTABLE RHS)) (CONS LHS TEMP-TEMP)) (T NIL))) (T NIL]) (LOGSUBSETP [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (IEQP (LOGAND X Y) X]) (LOOKUP-HYP [LAMBDA (HYP) (* kbr: "19-Oct-85 16:31") (* See if HYP is true by type alist or LITS-THAT-MAY-BE-ASSUMED-FALSE  considerations -- possibly extending the UNIFY-SUBST if necessary.  If successful return T and side-effect UNIFY-SUBST and the current lemma frame  appropriately. If unsuccessful, return NIL and side-effect nothing.  *) (PROG (TERM NOT-FLG TYPE NEG-HYP LIT) (COND ((BM-MATCH HYP (NOT TERM)) (SETQ NOT-FLG T)) (T (SETQ NOT-FLG NIL) (SETQ TERM HYP))) (COND ((AND (NVARIABLEP TERM) (NOT (FQUOTEP TERM)) (SETQ TEMP-TEMP (ASSOC (FFN-SYMB TERM) RECOGNIZER-ALIST))) (SETQ TYPE (CDR TEMP-TEMP)) (SETQ TERM (FARGN TERM 1))) (T (SETQ TYPE (LOGNOT TYPE-SET-FALSE)))) (COND (NOT-FLG (COND ((for PAIR in TYPE-ALIST thereis (AND (IEQP 0 (LOGAND TYPE (CDR PAIR))) (ONE-WAY-UNIFY1 TERM (CAR PAIR)))) (RETURN T)))) (T (COND ((for PAIR in TYPE-ALIST thereis (AND (LOGSUBSETP (CDR PAIR) TYPE) (ONE-WAY-UNIFY1 TERM (CAR PAIR)))) (RETURN T))))) (* Having failed to find HYP on the  type alist, we now try  LITS-THAT-MAY-BE-ASSUMED-FALSE.  *) (COND (LITS-THAT-MAY-BE-ASSUMED-FALSE (SETQ NEG-HYP (DUMB-NEGATE-LIT HYP)) (COND ((SETQ LIT (for LIT in LITS-THAT-MAY-BE-ASSUMED-FALSE when (ONE-WAY-UNIFY1 NEG-HYP LIT) do (RETURN LIT))) (PUSH-LEMMA LIT) (RETURN T)) (T (RETURN NIL)))) (T (RETURN NIL]) (LOOP-STOPPER [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (LHS RHS ALL-VARS) (COND ((AND (BM-MATCH TERM (EQUAL LHS RHS)) (VARIANTP LHS RHS)) (SETQ ALL-VARS (ALL-VARS LHS)) (for PAIR in UNIFY-SUBST when (MEMB (CAR PAIR) (CDR (MEMB (CDR PAIR) ALL-VARS))) collect PAIR)) (T NIL]) (MAIN-EVENT-OF [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (COND ((GETPROP NAME (QUOTE EVENT)) NAME) ((GETPROP NAME (QUOTE MAIN-EVENT))) (T (ERROR1 (PQUOTE (PROGN MAIN-EVENT-OF HAS BEEN CALLED ON AN OBJECT , NAMELY (!PPR NAME NIL) , THAT IS NEITHER AN EVENT NOR A SATELLITE OF ANOTHER EVENT !)) (BINDINGS (QUOTE NAME) NAME) (QUOTE HARD]) (CREATE-EVENT [LAMBDA (NAME EVENT) (* kbr: "19-Oct-85 16:31") (PUT1 NAME EVENT (QUOTE EVENT)) (PUT1 NAME (IDATE) (QUOTE IDATE)) (SETQ CHRONOLOGY (CONS NAME CHRONOLOGY)) (SETQ MAIN-EVENT-NAME NAME]) (MAKE-FLATTENED-MACHINE [LAMBDA (FNNAME TERM TESTS) (* kbr: "19-Oct-85 20:01") (* This function builds a list of TESTS-AND-CASE representing the function  FNNAME with body TERM. For each call of FNNAME in body, a TESTS-AND-CASE is  returned whose TESTS are all the tests that govern the call and whose CASE is  the arglist of the call. This code is a vast change from the previous version,  which did not consider terms with or within calls of FNNAME as governors.  *) (COND ((OR (VARIABLEP TERM) (FQUOTEP TERM)) NIL) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (NCONC (MAKE-FLATTENED-MACHINE FNNAME (FARGN TERM 1) TESTS) (MAKE-FLATTENED-MACHINE FNNAME (FARGN TERM 2) (APPEND TESTS (LIST (FARGN TERM 1)))) (MAKE-FLATTENED-MACHINE FNNAME (FARGN TERM 3) (APPEND TESTS (LIST (NEGATE-LIT (FARGN TERM 1))))))) ((EQ FNNAME (FFN-SYMB TERM)) (CONS (create TESTS-AND-CASE TESTS _ TESTS CASE _ (FARGS TERM)) (for ARG in (FARGS TERM) join (MAKE-FLATTENED-MACHINE FNNAME ARG TESTS)))) (T (for ARG in (FARGS TERM) join (MAKE-FLATTENED-MACHINE FNNAME ARG TESTS]) (MAKE-NEW-NAME [LAMBDA NIL (* kbr: "26-Oct-85 12:59") (LET (TEMP) (while (NULL (CHK-NEW-NAME (SETQ TEMP (GENSYM (QUOTE G))) T)) do NIL) TEMP]) (MAKE-REWRITE-RULES [LAMBDA (NAME HYPS CONCL) (* kbr: "19-Oct-85 16:31") (* This fn once entertained the idea of returning as many rewrite rules as  there were paths through the IF structure of HYPS.  That blew us out of the water on a thm whose hyp was  (AND (NOT (EQUAL X Y)) (NOT (LESSP X Y))) because it generated 75 paths! So the  fn now returns just one rewrite rule -- or none if CONCL is an explicit value.  The rule is LISTed so that the higher level functions still allow the  possibility of it someday returning more than one --  BUT they are all hung under the same fn symbol so this probably is not a useful  feature. *) (PROG (LHS RHS) (COND ((QUOTEP CONCL) (RETURN NIL)) ((BM-MATCH CONCL (EQUAL LHS RHS)) (SETQ CONCL (LIST (QUOTE EQUAL) LHS (NORMALIZE-IFS (EXPAND-BOOT-STRAP-NON-REC-FNS RHS) NIL NIL))))) (RETURN (LIST (CREATE-REWRITE-RULE NAME HYPS CONCL NIL]) (MAKE-TYPE-RESTRICTION [LAMBDA (TR DV RECOGNIZER TYPE-NO) (* kbr: "19-Oct-85 16:31") (LET (TYPE-SET) (SETQ TYPE-SET (for R in (CDR TR) bind (LOOP-ANS _ 0) do (SETQ LOOP-ANS (LOGOR LOOP-ANS (CDR (ASSOC R (CONS (CONS RECOGNIZER (LOGBIT TYPE-NO )) RECOGNIZER-ALIST)))) ) finally (RETURN LOOP-ANS))) (COND ((EQ (CAR TR) (QUOTE NONE-OF)) (SETQ TYPE-SET (LOGNOT TYPE-SET)))) (create TYPE-RESTRICTION TERM _ (COND ((EQ (CAR TR) (QUOTE ONE-OF)) (DISJOIN (for R in (CDR TR) collect (FCONS-TERM* R (QUOTE X))) NIL)) (T (CONJOIN (for R in (CDR TR) collect (DUMB-NEGATE-LIT (FCONS-TERM* R (QUOTE X)))) NIL))) TYPE-SET _ TYPE-SET DEFAULT _ (CONS-TERM DV NIL]) (MAX-FORM-COUNT [LAMBDA (X) (* kbr: " 4-Jul-86 18:32") (* The size of the most complicated  path in X regarded as a tree of IFs.  *) (COND ((VARIABLEP X) 0) ((FQUOTEP X) (* MAX-FORM-COUNT once used FORM-COUNT-EVG to compute the size of an evg.  But that function computed MAX-FORM-COUNT for 1000 that was bigger than for 999  and so the REWRITE package believed it was making progress and would open up  something like (LESSP X 1000)%. We have decided to try just measuring the LISP  size of the evg, as a better estimation of whether we are making progress.  *) (COUNT (CADR X))) ((EQ (FFN-SYMB X) (QUOTE IF)) (MAX (MAX-FORM-COUNT (FARGN X 2)) (MAX-FORM-COUNT (FARGN X 3)))) (T (ADD1 (for ARG in (FARGS X) sum (MAX-FORM-COUNT ARG]) (MAXIMAL-ELEMENTS [LAMBDA (LST MEASURE) (* kbr: "19-Oct-85 16:31") (LET (ANS MAX TEMP) (for X in LST do (SETQ TEMP (APPLY* MEASURE X)) (COND ((OR (NULL MAX) (GREATERP TEMP MAX)) (SETQ MAX TEMP) (SETQ ANS (LIST X))) ((EQUAL TEMP MAX) (SETQ ANS (NCONC1 ANS X))))) ANS]) (MEANING-SIMPLIFIER [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* When the theorem-prover assents to a theorem or accepts a definition, in  which theory is it working? Heretofore, the answer has been= in the theory  consisting of chapter 3 of ACL plus the user's definitions and axioms.  Because of the addition of metatheorems, the answer to that question is no  longer so simple. To answer the question, we first elaborate the notion of a  presented in the meta paper. Let us say that an event is a pair  (ev term) where ev is either DEFN, ADD-SHELL, ADD-AXIOM, PROVE-LEMMA, or DCL.  An member (ev term) if ev is DCL, then term is a function symbol and otherwise  term is a term. Given a list of events, we say that a function symbol is has  not been defined, has not been DCLed, and is not mentioned in the basic axioms.  A the concept being defined is new, and all the other function symbols are not  new for a shell invocation all the introduced symbols  (excepting possibly the default objects) are new for a DCL, the symbol is new  for a theorem or arbitrary axiom, none of the symbols used are new and the  theorems are provable from the preceding axioms  (including definitions and shell invocations)%.  We define a symbols on META-NAMES are DCLed or defined at the beginning of the  chronology as in BOOT-STRAP-INSTRS, immediately after each DCL and DEFINITION  the MEANING and ARITY axioms for the newly introduced function symbol are added  as arbitrary axioms, and there is otherwise no mention of any META-NAME except  in theorems. We vouch that our theorem-prover only calls proved in the user  chronology. We now make a like to work in a chronology with all those  metaaxioms To make the user happy, we show that corresponding to any user  chronology is a axioms and definitions only by the addition of more  definitions. Furthermore, we observe that in the real chronology, all the  theorems of the user chronology (the ones the theorem-prover proved) are  theorems in the real chronology after we replace each function symbol in  META-NAMES with another function symbol.  Thus, any theorem proved in the user chronology about concepts he has defined  or DCLed are literally theorems in the real chronology.  If he objects to having extra definitions around, then tough luck for him.  Given a initial BOOT-STRAP events that mention META-NAMES, replacing the  MEANING and ARITY axiom after each DCL or definition with the collection of  definitions called the metadefinitions in the meta paper for the i non-new  function symbols at that point in the chronology --  amended by indexing each META-NAME with i --  and altering each theorem by adding to each META-NAME the appropriate index.  Note we do not have to index user supplied axioms or definitions since they may  not contain META-NAMES. Note we are forbidding the user from using META-NAMES  in definitions even if he want to define concepts to help him prove metalemmas!  Why is a indexed theorems can be proved? The answer is that at any point i in  the user chronology (that is, after i definitions and declarations) and for  each axiom about a META-NAME in the user chronology, we can prove, in the real  chronology, at the corresponding point, the indexed version of the axiom.  The proof of this assertion is merely the observation that the metaaxioms  follow from the metadefinitions, so the indexed metaaxioms follow from the  indexed metadefinitions. The foregoing facts are independent of the use of  metalemmas. Now let us consider how metalemmas are used.  Suppose that a metalemma is proved at some constructive point i in a user  chronology and that at some point i+p we use the metalemma.  We claim that the inference can be proved at point i+p in the user chronology.  As a corollary to what has been said before, we also conclude that the  inference can be proved in the corresponding chronology is obvious since the  metatheorem at i was proved about the same symbol MEANING we will use at i+p to  lift and drop the formulas in question. *) (LET (X ALIST FN TL) (MATCH! TERM (MEANING X ALIST)) (COND ((VARIABLEP X) TERM) ((SHELLP X) (COND ((NEQ (FN-SYMB X) (QUOTE CONS)) (CONS-TERM (QUOTE LOOKUP) (FARGS TERM))) (T (SETQ FN (ARGN X 1)) (SETQ TL (ARGN X 2)) (COND ((AND (QUOTEP FN) (LITATOM (CADR FN))) (COND ((EQ (CADR FN) (QUOTE QUOTE)) (FCONS-TERM* (QUOTE CAR) TL)) ((AND (GETPROP (CADR FN) (QUOTE TYPE-PRESCRIPTION-LST)) (NOT (MEMB (CADR FN) META-NAMES))) (CONS-TERM (CADR FN) (for I from 1 to (ARITY (CADR FN)) collect (FCONS-TERM* (QUOTE MEANING) (FCONS-TERM* (QUOTE CAR) (CELL (SUB1 I) TL)) ALIST)))) (T TERM))) (T TERM))))) (T TERM]) (MEMB-NEGATIVE [LAMBDA (LIT CL) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP CL) NIL) ((COMPLEMENTARYP LIT (CAR CL)) T) (T (MEMB-NEGATIVE LIT (CDR CL]) (MENTIONSQ [LAMBDA (AT TREE) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP TREE) (EQ AT TREE)) (T (OR (MENTIONSQ AT (CAR TREE)) (MENTIONSQ AT (CDR TREE]) (MENTIONSQ-LST [LAMBDA (LST TREE) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP TREE) (MEMB TREE LST)) (T (OR (MENTIONSQ-LST LST (CAR TREE)) (MENTIONSQ-LST LST (CDR TREE]) (MERGE-CAND1-INTO-CAND2 [LAMBDA (CAND1 CAND2) (* kbr: "19-Oct-85 16:56") (* Note: The guts of this function is MERGE-TESTS-AND-ALISTS-LSTS.  The tests preceding it are heuristic only.  If MERGE-TESTS-AND-ALISTS-LSTS returns non-NIL then it returns a sound  induction indeed, it merely extends some of the substitutions in the second  candidate. *) (LET (SCORE1 CONTROLLERS1 CHANGED-VARS1 UNCHANGEABLES1 TESTS-AND-ALISTS-LST1 JUSTIFICATION1 TERM1 OTHER-TERMS1 SCORE2 CONTROLLERS2 CHANGED-VARS2 UNCHANGEABLES2 TESTS-AND-ALISTS-LST2 JUSTIFICATION2 TERM2 OTHER-TERMS2 ALISTS TESTS-AND-ALISTS-LST VARS) (SETQ SCORE1 (fetch (CANDIDATE SCORE) of CAND1)) (SETQ CONTROLLERS1 (fetch (CANDIDATE CONTROLLERS) of CAND1)) (SETQ CHANGED-VARS1 (fetch (CANDIDATE CHANGED-VARS) of CAND1)) (SETQ UNCHANGEABLES1 (fetch (CANDIDATE UNCHANGEABLE-VARS) of CAND1)) (SETQ TESTS-AND-ALISTS-LST1 (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of CAND1)) (SETQ JUSTIFICATION1 (fetch (CANDIDATE JUSTIFICATION) of CAND1)) (SETQ TERM1 (fetch (CANDIDATE INDUCTION-TERM) of CAND1)) (SETQ OTHER-TERMS1 (fetch (CANDIDATE OTHER-TERMS) of CAND1)) (SETQ SCORE2 (fetch (CANDIDATE SCORE) of CAND2)) (SETQ CONTROLLERS2 (fetch (CANDIDATE CONTROLLERS) of CAND2)) (SETQ CHANGED-VARS2 (fetch (CANDIDATE CHANGED-VARS) of CAND2)) (SETQ UNCHANGEABLES2 (fetch (CANDIDATE UNCHANGEABLE-VARS) of CAND2)) (SETQ TESTS-AND-ALISTS-LST2 (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of CAND2)) (SETQ JUSTIFICATION2 (fetch (CANDIDATE JUSTIFICATION) of CAND2)) (SETQ TERM2 (fetch (CANDIDATE INDUCTION-TERM) of CAND2)) (SETQ OTHER-TERMS2 (fetch (CANDIDATE OTHER-TERMS) of CAND2)) (* We once merged only if both cands agreed on the intersection of the  CHANGED-VARS. But the theorem that, under suitable conditions,  (EV FLG X VA FA N) IEQP (EV FLG X VA FA K) made us realize it was important  only to agree on the intersection of the controllers.  Note in fact that we mean the changing controllers --  there seems to be no need to merge two inductions if they only share unchanging  controllers. However the theorem that (GETPROP I  (SET J VAL MEM)) IEQP ... (GETPROP I MEM) ...  illustrates the situation in which the controllers, {I} and {J} do not even  overlap but the accumulators {MEM} do and we want a merge.  So we want agreement on the intersection of the changing controllers  (if that is nonempty) or on the accumulators.  For soundness it does not matter what list of vars we want to agree on because  no matter what, MERGE-TESTS-AND-ALISTS-LSTS returns either NIL or an extension  of the second candidates alists. *) (AND (SETQ VARS (OR (INTERSECTION CONTROLLERS1 (INTERSECTION CONTROLLERS2 (INTERSECTION CHANGED-VARS1 CHANGED-VARS2))) (INTERSECTION CHANGED-VARS1 CHANGED-VARS2))) (NOT (INTERSECTP UNCHANGEABLES1 CHANGED-VARS2)) (NOT (INTERSECTP UNCHANGEABLES2 CHANGED-VARS1)) (SETQ TESTS-AND-ALISTS-LST (MERGE-TESTS-AND-ALISTS-LSTS TESTS-AND-ALISTS-LST1 TESTS-AND-ALISTS-LST2 VARS)) (create CANDIDATE SCORE _ (PLUS SCORE1 SCORE2) CONTROLLERS _ (UNIONQ CONTROLLERS1 CONTROLLERS2) CHANGED-VARS _ (UNIONQ CHANGED-VARS1 CHANGED-VARS2) UNCHANGEABLE-VARS _ (UNIONQ UNCHANGEABLES1 UNCHANGEABLES2) TESTS-AND-ALISTS-LST _ TESTS-AND-ALISTS-LST JUSTIFICATION _ JUSTIFICATION2 INDUCTION-TERM _ TERM2 OTHER-TERMS _ (ADD-TO-SET TERM1 (UNION-EQUAL OTHER-TERMS1 OTHER-TERMS2]) (MERGE-CANDS [LAMBDA (CAND1 CAND2) (* kbr: "19-Oct-85 16:31") (OR (FLUSH-CAND1-DOWN-CAND2 CAND1 CAND2) (FLUSH-CAND1-DOWN-CAND2 CAND2 CAND1) (MERGE-CAND1-INTO-CAND2 CAND1 CAND2) (MERGE-CAND1-INTO-CAND2 CAND2 CAND1]) (MERGE-DESTRUCTOR-CANDIDATES [LAMBDA (LST) (* kbr: "19-Oct-85 16:31") (* The elements of LST are lists of  terms. Whenever the CARs of two  elements are EQUAL we UNIONQ together  the CDRs. *) (TRANSITIVE-CLOSURE LST (FUNCTION (LAMBDA (X Y) (COND ((EQUAL (CAR X) (CAR Y)) (CONS (CAR X) (UNION-EQUAL (CDR X) (CDR Y)))) (T NIL]) (MERGE-TESTS-AND-ALISTS [LAMBDA (TA1 TA2) (* kbr: "19-Oct-85 16:31") (AND (SETQ ALISTS (PIGEON-HOLE (fetch (TESTS-AND-ALISTS ALISTS) of TA1) (fetch (TESTS-AND-ALISTS ALISTS) of TA2) [FUNCTION (LAMBDA (ALIST1 ALIST2) (* Union the two alists if they have a non-trivial intersection, that is, they  intersect with a pair other than one like  (ITIMES), and they agree on their intersection.  *) (AND (for PAIR1 in ALIST1 thereis (AND (NEQ (CAR PAIR1) (CDR PAIR1)) (MEMBER PAIR1 ALIST2))) (for PAIR1 in ALIST1 bind PAIR2 when (SETQ PAIR2 (ASSOC (CAR PAIR1) ALIST2)) always (EQUAL PAIR2 PAIR1)) (UNION-EQUAL ALIST1 ALIST2] T NIL)) (create TESTS-AND-ALISTS TESTS _ (fetch (TESTS-AND-ALISTS TESTS) of TA2) ALISTS _ ALISTS]) (MERGE-TESTS-AND-ALISTS-LSTS [LAMBDA (TESTS-AND-ALISTS-LST1 TESTS-AND-ALISTS-LST2 VARS) (* kbr: "20-Oct-85 19:21") (* If every alist in TESTS-AND-ALISTS-LST1 fits into an alist in  TESTS-AND-ALISTS-LST2, then return the new TESTS-AND-ALISTS-LST obtained by  putting each alist in TESTS-AND-ALISTS-LST1 into every alist in  TESTS-AND-ALISTS-LST2 into which it fits.  Else return NIL. ALIST1 fits into ALIST2 iff the two agree on every var in  VARS. To merge one alist into another we extend the second alist by adding to  it every pair of the first, provided that pair does not clash with an existing  pair of the second. *) (LET (BUCKETS ALIST FLG) (SETQ BUCKETS (for TA in TESTS-AND-ALISTS-LST2 collect (for ALIST in (fetch (TESTS-AND-ALISTS ALISTS) of TA) collect (CONS ALIST NIL)))) (COND ((for TA1 in TESTS-AND-ALISTS-LST1 always (for ALIST1 in (fetch (TESTS-AND-ALISTS ALISTS) of TA1) always (PROGN (SETQ FLG NIL) (for BUCKET in BUCKETS do (for PAIR in BUCKET do (COND ((FITS ALIST1 (CAR PAIR) VARS) (RPLACD PAIR (ADD-TO-SET (EXTEND-ALIST ALIST1 (CAR PAIR)) (CDR PAIR))) (SETQ FLG T))))) FLG))) (for TA in TESTS-AND-ALISTS-LST2 as BUCKET in BUCKETS collect (create TESTS-AND-ALISTS TESTS _ (fetch (TESTS-AND-ALISTS TESTS) of TA) ALISTS _ (for X in BUCKET bind LOOP-ANS do (SETQ LOOP-ANS (UNION-EQUAL (OR (CDR X) X) LOOP-ANS)) finally (RETURN LOOP-ANS)) ))) (T NIL]) (META-LEMMAP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (NLISTP (fetch (REWRITE-RULE CONCL) of X]) (MULTIPLE-PIGEON-HOLE [LAMBDA (PIGEONS HOLES FN) (* kbr: "19-Oct-85 16:31") (LET (TEMP PAIRLST) (SETQ PAIRLST (for X in HOLES collect (CONS NIL X))) (COND ((for PIGEON in PIGEONS always (for PAIR in PAIRLST bind FLG do (SETQ TEMP (APPLY* FN PIGEON (CDR PAIR))) (COND (TEMP (RPLACD PAIR TEMP) (SETQ FLG T))) finally (RETURN FLG))) (for PAIR in PAIRLST collect (CDR PAIR))) (T (ERROR1 (PQUOTE (PROGN MULTIPLE-PIGEON-HOLE FAILED TO GETPROP EVERYTHING IN A POT.)) (BINDINGS) (QUOTE HARD]) ) (RPAQQ CODE-N-RCOMS ((* CODE-N-R *) (FNS BM-NEGATE NEGATE-LIT NEXT-AVAILABLE-TYPE-NO NO-CROWDINGP NO-DUPLICATESP NO-OP NON-RECURSIVE-DEFNP NORMALIZE-IFS NOT-EQUAL-0? NOT-IDENT NOT-LESSP? NOT-TO-BE-REWRITTENP NUMBERP? OBJ-TABLE OCCUR OCCUR-CNT OCCUR-LST ONE-WAY-UNIFY ONE-WAY-UNIFY-LIST ONE-WAY-UNIFY1 ONE-WAY-UNIFY11 ONEIFY ONEIFY-ASSUME-FALSE ONEIFY-ASSUME-TRUE ONEIFY-TEST OPTIMIZE-COMMON-SUBTERMS PARTITION PARTITION-CLAUSES PATH-ADD-TO-SET PATH-EQ PATH-POT-SUBSUMES PATH-UNION PEGATE-LIT PETITIO-PRINCIPII PICK-HIGH-SCORES PIGEON-HOLE PIGEON-HOLE-IN-ALL-POSSIBLE-WAYS PIGEON-HOLE1 PLUSJOIN POLY-MEMBER POP-CLAUSE-SET POP-LEMMA-FRAME POP-LINEARIZE-ASSUMPTIONS-FRAME POPU POSSIBLE-IND-PRINCIPLES POSSIBLY-NUMERIC POWER-EVAL POWER-REP PPC PPE PPE-LST BM-PPR PPRINDENT PPSD PPSD-LST PREPROCESS PREPROCESS-HYPS PRETTYIFY-CLAUSE PRETTYIFY-LISP PRIMITIVE-RECURSIVEP PRIMITIVEP PRINT-STACK PRINT-STATS PRINT-TO-DISPLAY PROCESS-EQUATIONAL-POLYS PROPERTYLESS-SYMBOLP PROVE PROVE-TERMINATION PROVEALL PUSH-CLAUSE-SET PUSH-LEMMA PUSH-LEMMA-FRAME PUSH-LINEARIZE-ASSUMPTION PUSH-LINEARIZE-ASSUMPTIONS-FRAME PUSHU PUT-CURSOR PUT-INDUCTION-INFO PUT-LEVEL-NO PUT-TYPE-PRESCRIPTION PUT0 PUT00 PUT1 PUT1-LST PUTD1 QUICK-BLOCK-INFO QUICK-BLOCK-INFO1 QUICK-WORSE-THAN R REDO! REDO-UNDONE-EVENTS BM-REDUCE REDUCE1 REFLECT0 RELIEVE-HYPS RELIEVE-HYPS-NOT-OK RELIEVE-HYPS1 REMOVE-*2*IFS REMOVE-NEGATIVE REMOVE-REDUNDANT-TESTS REMOVE1 REMOVE-TRIVIAL-EQUATIONS REMOVE-UNCHANGING-VARS REMPROP1 RESTART RESTART-BATCH REWRITE REWRITE-FNCALL REWRITE-FNCALLP REWRITE-IF REWRITE-IF1 REWRITE-LINEAR-CONCL REWRITE-SOLIDIFY REWRITE-TYPE-PRED REWRITE-WITH-LEMMAS REWRITE-WITH-LINEAR RPLACAI))) (* CODE-N-R *) (DEFINEQ (BM-NEGATE [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((FALSE-NONFALSEP TERM) (COND (DEFINITELY-FALSE TRUE) (T FALSE))) ((VARIABLEP TERM) (LIST (QUOTE NOT) TERM)) (T (SELECTQ (FFN-SYMB TERM) (NOT (COND ((BOOLEAN (FARGN TERM 1)) (FARGN TERM 1)) (T (FCONS-TERM* (QUOTE IF) (FARGN TERM 1) TRUE FALSE)))) (AND (DISJOIN2 (BM-NEGATE (FARGN TERM 1)) (BM-NEGATE (FARGN TERM 2)) NIL)) (OR (CONJOIN2 (BM-NEGATE (FARGN TERM 1)) (BM-NEGATE (FARGN TERM 2)) NIL)) (FCONS-TERM* (QUOTE NOT) TERM]) (NEGATE-LIT [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((FALSE-NONFALSEP TERM) (COND (DEFINITELY-FALSE TRUE) (T FALSE))) ((VARIABLEP TERM) (FCONS-TERM* (QUOTE NOT) TERM)) ((EQ (FFN-SYMB TERM) (QUOTE NOT)) (FARGN TERM 1)) (T (FCONS-TERM* (QUOTE NOT) TERM]) (NEXT-AVAILABLE-TYPE-NO [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (LET (TYPE-NO) (SETQ TYPE-NO (for I from 0 when (NOT (for PAIR in SHELL-ALIST thereis (EQUAL (CDR PAIR) I))) do (RETURN I))) (COND ((GREATERP TYPE-NO 30) (ERROR1 (PQUOTE (PROGN TOO MANY SHELLS ! BECAUSE OF OUR USE OF 32-BIT WORDS TO REPRESENT SETS OF SHELL TYPES , THE NEED TO RESERVE ONE BIT FOR INTERNAL USE , AND THE EXISTENCE OF 31 PREVIOUSLY DEFINED SHELLS , WE CANNOT ACCEPT FURTHER ADD-SHELL COMMANDS %.)) (BINDINGS) (QUOTE HARD)))) TYPE-NO]) (NO-CROWDINGP [LAMBDA (HOLES PRED PICKS) (* kbr: "19-Oct-85 16:31") (COND ((NULL HOLES) T) ((for X in (CAR HOLES) thereis (AND (for Y in PICKS never (APPLY* PRED X Y)) (NO-CROWDINGP (CDR HOLES) PRED (CONS X PICKS)))) T) (T NIL]) (NO-DUPLICATESP [LAMBDA (L) (* kbr: "19-Oct-85 16:31") (for TAIL on L never (MEMB (CAR TAIL) (CDR TAIL]) (NO-OP [LAMBDA NIL (* kbr: "19-Oct-85 16:31") NIL]) (NON-RECURSIVE-DEFNP [LAMBDA (FNNAME) (* kbr: "19-Oct-85 16:31") (* We use the fact that this AND  returns the SDEFN! *) (AND (NOT (DISABLEDP FNNAME)) (NOT (GETPROP FNNAME (QUOTE INDUCTION-MACHINE))) (GETPROP FNNAME (QUOTE SDEFN]) (NORMALIZE-IFS [LAMBDA (TERM TRUE-TERMS FALSE-TERMS) (* kbr: "19-Oct-85 16:31") (LET (T1 T2 T3 T11 T12 T13 BAD-ARG) (COND ((VARIABLEP TERM) (COND ((MEMB TERM FALSE-TERMS) FALSE) (T TERM))) ((FQUOTEP TERM) TERM) ((BM-MATCH TERM (IF T1 T2 T3)) (SETQ T1 (NORMALIZE-IFS T1 TRUE-TERMS FALSE-TERMS)) (COND ((OR (EQUAL T1 TRUE) (MEMBER T1 TRUE-TERMS)) (NORMALIZE-IFS T2 TRUE-TERMS FALSE-TERMS)) ((OR (EQUAL T1 FALSE) (MEMBER T1 FALSE-TERMS)) (NORMALIZE-IFS T3 TRUE-TERMS FALSE-TERMS)) ((BM-MATCH T1 (IF T11 T12 T13)) (NORMALIZE-IFS (FCONS-TERM* (QUOTE IF) T11 (FCONS-TERM* (QUOTE IF) T12 T2 T3) (FCONS-TERM* (QUOTE IF) T13 T2 T3)) TRUE-TERMS FALSE-TERMS)) (T (SETQ T2 (NORMALIZE-IFS T2 (CONS T1 TRUE-TERMS) FALSE-TERMS)) (SETQ T3 (NORMALIZE-IFS T3 TRUE-TERMS (CONS T1 FALSE-TERMS))) (COND ((EQUAL T2 T3) T2) ((AND (BOOLEAN T1) (EQUAL T2 TRUE) (AND (FALSE-NONFALSEP T3) DEFINITELY-FALSE)) T1) (T (FCONS-TERM* (QUOTE IF) T1 T2 T3)))))) (T (SETQ TERM (CONS-TERM (CAR TERM) (for ARG in (FARGS TERM) collect (NORMALIZE-IFS ARG TRUE-TERMS FALSE-TERMS)))) (COND ((BM-MATCH TERM (EQUAL T1 T2)) (COND ((EQUAL T1 T2) (SETQ TERM TRUE)) ((NOT-IDENT T1 T2) (SETQ TERM FALSE))))) (COND ((FQUOTEP TERM) TERM) ((SETQ BAD-ARG (for ARG in (FARGS TERM) when (BM-MATCH ARG (COND ((T1 T2 T3)))) do (RETURN ARG))) (FCONS-TERM* (QUOTE IF) T1 (NORMALIZE-IFS (SUBST-EXPR T2 BAD-ARG TERM) (CONS T1 TRUE-TERMS) FALSE-TERMS) (NORMALIZE-IFS (SUBST-EXPR T3 BAD-ARG TERM) TRUE-TERMS (CONS T1 FALSE-TERMS)))) ((MEMBER TERM FALSE-TERMS) FALSE) ((AND (MEMBER TERM TRUE-TERMS) (BOOLEAN TERM)) TRUE) (T TERM]) (NOT-EQUAL-0? [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (PROG (X Y TEMP EQUALITY) (COND ((BM-MATCH TERM (DIFFERENCE X Y)) (RETURN (BM-NEGATE (NOT-LESSP? Y X)))) ((OR (BM-MATCH TERM (ADD1 &)) (AND (QUOTEP TERM) (NOT (EQUAL (CADR TERM) 0)))) (RETURN TRUE))) (SETQ EQUALITY (FCONS-TERM* (QUOTE EQUAL) TERM ZERO)) (SETQ TEMP (TYPE-SET EQUALITY)) (COND ((IEQP TEMP TYPE-SET-TRUE) (RETURN FALSE)) ((IEQP TEMP TYPE-SET-FALSE) (RETURN TRUE)) (T (RETURN (FCONS-TERM* (QUOTE NOT) EQUALITY]) (NOT-IDENT [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (COND ((AND (VALUEP TERM1) (VALUEP TERM2) (NOT (EQUAL TERM1 TERM2))) T) ((OR (AND (BTM-OBJECTP TERM1) (SHELL-CONSTRUCTORP TERM2)) (AND (BTM-OBJECTP TERM2) (SHELL-CONSTRUCTORP TERM1))) (* Note, we do not even bother to check that they are of the same type, since  if they weren't they'd be unequal on type considerations alone.  *) T) ((IEQP 0 (LOGAND (TYPE-SET TERM1) (TYPE-SET TERM2))) T) ((SHELL-OCCUR TERM1 TERM2) T) ((SHELL-OCCUR TERM2 TERM1) T) (T NIL]) (NOT-LESSP? [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (PROG (TEMP TERM) (COND ((AND (EQUAL Y (QUOTE (QUOTE 1))) (IEQP (TYPE-SET X) TYPE-SET-NUMBERS)) (RETURN (NOT-EQUAL-0? X)))) (SETQ TEMP (TYPE-SET (SETQ TERM (FCONS-TERM* (QUOTE LESSP) X Y)))) (RETURN (COND ((IEQP TEMP TYPE-SET-FALSE) TRUE) ((IEQP TEMP TYPE-SET-TRUE) FALSE) (T (BM-NEGATE TERM]) (NOT-TO-BE-REWRITTENP [LAMBDA (TERM ALIST) (* kbr: "19-Oct-85 16:31") (* We assume TERM is a nonvariable nonQUOTEP and that  TERMS-TO-BE-IGNORED-BY-REWRITE contains no vars or QUOTEPs.  Let term' be (SUBLIS-VAR ALIST TERM)%. If term' is a member of  TERMS-TO-BE-IGNORED-BY-REWRITE we return term' else NIL.  We would like to do the membership test without doing the substitution, but the  maintenance of QUOTE-normal form by SUBLIS-VAR complicates matters.  We first ask whether the FFN-SYMB of TERM is the FFN-SYMB of any term to be  ignored. If not, we return NIL. Else we do the substitution and member check.  The correctness of this function is obvious in the case that we do the  substitution. So suppose we return NIL without doing the substitution.  Suppose, contrary to correctness that term' is a member of the to be ignored  list. Then term' is not a QUOTEP. But in that case the FFN-SYMB of term' is  that of TERM and must have passed our initial test.  *) (COND ((AND (for X in TERMS-TO-BE-IGNORED-BY-REWRITE thereis (EQ (FFN-SYMB TERM) (FFN-SYMB X))) (MEMBER (SETQ TEMP-TEMP (SUBLIS-VAR ALIST TERM)) TERMS-TO-BE-IGNORED-BY-REWRITE)) TEMP-TEMP) (T NIL]) (NUMBERP? [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (TEMP) (SETQ TEMP (TYPE-SET TERM)) (COND ((IEQP TEMP TYPE-SET-NUMBERS) TRUE) ((NOT (LOGSUBSETP TYPE-SET-NUMBERS TEMP)) FALSE) (T (FCONS-TERM* (QUOTE NUMBERP) TERM]) (OBJ-TABLE [LAMBDA (TYPE-SET OBJECTIVE ID-IFF) (* kbr: "19-Oct-85 16:31") (SELECTQ OBJECTIVE (TRUE (COND ((IEQP TYPE-SET TYPE-SET-TRUE) TRUE) ((EQ ID-IFF (QUOTE ID)) NIL) ((LOGSUBSETP TYPE-SET-FALSE TYPE-SET) NIL) (T TRUE))) (FALSE (COND ((IEQP TYPE-SET TYPE-SET-FALSE) FALSE) (T NIL))) (? (COND ((IEQP TYPE-SET TYPE-SET-FALSE) FALSE) ((IEQP TYPE-SET TYPE-SET-TRUE) TRUE) ((EQ ID-IFF (QUOTE ID)) NIL) ((LOGSUBSETP TYPE-SET-FALSE TYPE-SET) NIL) (T TRUE))) (ERROR1 (PQUOTE (PROGN UNRECOGNIZED REWRITE OBJECTIVE , (!PPR OBJECTIVE NIL) %.)) (BINDINGS (QUOTE OBJECTIVE) OBJECTIVE) (QUOTE HARD]) (OCCUR [LAMBDA (TERM1 TERM2) (* kbr: "20-Oct-85 14:23") (* Does TERM1 occur inside TERM2? *) (COND ((VARIABLEP TERM2) (EQ TERM1 TERM2)) ((FQUOTEP TERM2) (COND ((QUOTEP TERM1) (* Consider that TERM1 is built up out  of smaller constants, one of which  could be constant TERM2.  *) (COND ((FIXP (CADR TERM1)) (EVG-OCCUR-NUMBER (CADR TERM1) (CADR TERM2))) ((AND (LEGAL-CHAR-CODE-SEQ (CADR TERM1)) (EQUAL (CDR (LAST (CADR TERM1))) 0)) (EVG-OCCUR-LEGAL-CHAR-CODE-SEQ (CADR TERM1) (CADR TERM2))) (T (EVG-OCCUR-OTHER (CADR TERM1) (CADR TERM2))))) (T NIL))) ((EQUAL TERM1 TERM2) T) (T (for ARG in (FARGS TERM2) thereis (OCCUR TERM1 ARG]) (OCCUR-CNT [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (* Return a lower bound on the number  of times TERM1 occurs in TERM2.  We do not go inside of QUOTEs in  TERM2. *) (COND ((EQUAL TERM1 TERM2) 1) ((VARIABLEP TERM2) 0) ((FQUOTEP TERM2) 0) (T (for ARG in (FARGS TERM2) sum (OCCUR-CNT TERM1 ARG]) (OCCUR-LST [LAMBDA (X LST) (* kbr: "19-Oct-85 16:31") (for Y in LST thereis (OCCUR X Y]) (ONE-WAY-UNIFY [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2]) (ONE-WAY-UNIFY-LIST [LAMBDA (TERM1-LIST TERM2-LIST) (* kbr: "19-Oct-85 16:31") (* Like ONE-WAY-UNIFY except operates  on lists of terms. *) (SETQ UNIFY-SUBST NIL) (for TERM1 in TERM1-LIST as TERM2 in TERM2-LIST always (ONE-WAY-UNIFY1 TERM1 TERM2]) (ONE-WAY-UNIFY1 [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (LET (OLD-ALIST) (SETQ COMMUTED-EQUALITY-FLG NIL) (SETQ OLD-ALIST UNIFY-SUBST) (COND ((ONE-WAY-UNIFY11 TERM1 TERM2) T) (T (SETQ UNIFY-SUBST OLD-ALIST) NIL]) (ONE-WAY-UNIFY11 [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM1) (COND ((SETQ TEMP-TEMP (ASSOC TERM1 UNIFY-SUBST)) (EQUAL (CDR TEMP-TEMP) TERM2)) (T (SETQ UNIFY-SUBST (CONS (CONS TERM1 TERM2) UNIFY-SUBST))))) ((FQUOTEP TERM1) (* Since TERM1 is the only one whose variables we instantiate, and is constant,  and all terms are in the QUOTE-normal form discussed in CONS-TERM, these two  terms unify iff they are EQUAL. *) (EQUAL TERM1 TERM2)) ((VARIABLEP TERM2) NIL) ((EQ (FFN-SYMB TERM1) (FN-SYMB TERM2)) (COND ((EQ (FFN-SYMB TERM1) (QUOTE EQUAL)) (LET ((SAVED-UNIFY-SUBST UNIFY-SUBST)) (COND ((AND (ONE-WAY-UNIFY11 (FARGN TERM1 1) (FARGN TERM2 1)) (ONE-WAY-UNIFY11 (FARGN TERM1 2) (FARGN TERM2 2))) T) (T (SETQ UNIFY-SUBST SAVED-UNIFY-SUBST) (AND (ONE-WAY-UNIFY11 (FARGN TERM1 2) (FARGN TERM2 1)) (ONE-WAY-UNIFY11 (FARGN TERM1 1) (FARGN TERM2 2)) (SETQ COMMUTED-EQUALITY-FLG T)))))) (T (for ARG1 in (FARGS TERM1) as ARG2 in (SARGS TERM2) always (ONE-WAY-UNIFY11 ARG1 ARG2)) ))) (T NIL]) (ONEIFY [LAMBDA (TERM TESTS) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) TERM) ((FQUOTEP TERM) TERM) (T (SELECTQ (FFN-SYMB TERM) (IF (LIST (QUOTE *2*IF) (ONEIFY-TEST (FARGN TERM 1) TESTS) (ONEIFY (FARGN TERM 2) (ONEIFY-ASSUME-TRUE (FARGN TERM 1) TESTS)) (ONEIFY (FARGN TERM 3) (ONEIFY-ASSUME-FALSE (FARGN TERM 1) TESTS)))) (CONS (LIST (QUOTE CONS) (ONEIFY (FARGN TERM 1) TESTS) (ONEIFY (FARGN TERM 2) TESTS))) (CAR (COND ((IMPLIES? TESTS (FCONS-TERM* (QUOTE LISTP) (FARGN TERM 1))) (LIST (QUOTE CAR) (ONEIFY (FARGN TERM 1) TESTS))) (T (LIST (QUOTE *1*CAR) (ONEIFY (FARGN TERM 1) TESTS))))) (CDR (COND ((IMPLIES? TESTS (FCONS-TERM* (QUOTE LISTP) (FARGN TERM 1))) (LIST (QUOTE CDR) (ONEIFY (FARGN TERM 1) TESTS))) (T (LIST (QUOTE *1*CDR) (ONEIFY (FARGN TERM 1) TESTS))))) ((LISTP EQUAL) (LIST (QUOTE *2*IF) (ONEIFY-TEST TERM TESTS) (KWOTE *1*T) (KWOTE *1*F))) (CONS (PACK (LIST STRING-WEIRD (FFN-SYMB TERM))) (for ARG in (FARGS TERM) collect (ONEIFY ARG TESTS]) (ONEIFY-ASSUME-FALSE [LAMBDA (TEST TESTS) (* kbr: "19-Oct-85 16:31") (CONS (NEGATE-LIT TEST) TESTS]) (ONEIFY-ASSUME-TRUE [LAMBDA (TEST TESTS) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP TEST) (CONS TEST TESTS)) ((FQUOTEP TEST) (CONS TEST TESTS)) ((AND (EQ (FFN-SYMB TEST) (QUOTE IF)) (EQUAL (FARGN TEST 3) FALSE)) (ONEIFY-ASSUME-TRUE (FARGN TEST 1) (ONEIFY-ASSUME-TRUE (FARGN TEST 2) TESTS))) (T (CONS TEST TESTS]) (ONEIFY-TEST [LAMBDA (TERM TESTS) (* kbr: " 6-Jul-86 09:55") (COND ((VARIABLEP TERM) (LIST (QUOTE NEQ) TERM (QUOTE *1*F))) ((FQUOTEP TERM) (NOT (EQ (CADR TERM) *1*F))) (T (SELECTQ (FFN-SYMB TERM) (IF (LIST (QUOTE *2*IF) (ONEIFY-TEST (FARGN TERM 1) TESTS) (ONEIFY-TEST (FARGN TERM 2) (ONEIFY-ASSUME-TRUE (FARGN TERM 1) TESTS)) (ONEIFY-TEST (FARGN TERM 3) (ONEIFY-ASSUME-FALSE (FARGN TERM 1) TESTS)))) (LISTP (* We have to COPY the result of this SUB-PAIR so we do not have two EQ  occurrences of the arg in the X positions.  *) (COPY (SUB-PAIR (QUOTE (X *1*SHELL-QUOTE-MARK)) (LIST (ONEIFY (FARGN TERM 1) TESTS) (KWOTE *1*SHELL-QUOTE-MARK)) (QUOTE (*2*IF (LISTP X) (NEQ (CAR X) *1*SHELL-QUOTE-MARK) NIL))))) (EQUAL (COND ((AND (QUOTEP (FARGN TERM 1)) (LITATOM (CADR (FARGN TERM 1)))) (LIST (QUOTE EQ) (ONEIFY (FARGN TERM 2) TESTS) (FARGN TERM 1))) ((AND (QUOTEP (FARGN TERM 2)) (LITATOM (CADR (FARGN TERM 2)))) (LIST (QUOTE EQ) (ONEIFY (FARGN TERM 1) TESTS) (FARGN TERM 2))) (T (LIST (QUOTE EQUAL) (ONEIFY (FARGN TERM 1) TESTS) (ONEIFY (FARGN TERM 2) TESTS))))) (LIST (QUOTE NEQ) (ONEIFY TERM TESTS) (QUOTE *1*F]) (OPTIMIZE-COMMON-SUBTERMS [LAMBDA (FORM) (* kbr: "26-Oct-85 14:01") (PROG (SUBTERMS COMMONSUBTERMS PATHS DECISIONS OCC OCC1 OCC2 VAR-ALIST PARTI DOUBLE-TERMS NEW-FORM ISOLATED-CNT FIRST-CNT SECOND-CNT) (* We are interested in evaluating certain LISP FORMs that are constructed out  of variables (i.e., SYMBOLPS (none of which begin with 2)), objects of the form  (QUOTE ITIMES) and FORMs which are proper lists beginning with SYMBOLPs which  are either *2*IF or which have LAMBDA spread definitions.  *2*IF behaves as though it had the MACRO  ((X Y Z) (COND (X Y) (T Z)))%. We assume that no function associated with any  function symbol has any effect on the LISP state.  We assume that no variable is bound to the LITATOM *1*X.  We assume that there is no structure sharing among the non-QUOTE subexpressions  of FORM. Under these hypotheses, we generate and return a LISP form which when  evaluated returns the the same value as would be returned by evaluating FORM.  We intentionally ignore the fact that in LISP, if a variable is bound to  NOBIND, the evaluation of that variable causes an error.  This does not happened in compiled code.  *) (SETQ SUBTERMS (INTERESTING-SUBTERMS FORM)) (SETQ COMMONSUBTERMS (for TERM in SUBTERMS when (for TERM2 in SUBTERMS thereis (AND (NEQ TERM2 TERM) (EQUAL TERM2 TERM))) collect TERM)) (COND ((NULL COMMONSUBTERMS) (RETURN FORM))) (SETQ PARTI (PARTITION COMMONSUBTERMS)) (SETQ COMMONSUBTERMS (for PART in PARTI unless (for PART2 in PARTI thereis (PATH-POT-SUBSUMES PART2 PART)) join (APPEND PART NIL))) (SETQ PATHS (for P in (ALL-PATHS FORM) collect (REVERSE (CDR P)))) (* For each term that occurs more than once in FORM, we calculate just how that  occurrence occurs on the paths through the FORM.  Given a path, we say the term occurs ISOLATED if no other EQUAL term occurs on  the path. We say the term appears FIRST on the path if some EQUAL term follows  it but no EQUAL term precedes it. We say the term appears SECOND on the path if  it occurs on the path but the occurrence is not ISOLATED and is not FIRST,  i.e., there is some EQUAL term that has a preceding occurrence on the path.  *) (for TERM in COMMONSUBTERMS do (SETQ ISOLATED-CNT 0) (SETQ FIRST-CNT 0) (SETQ SECOND-CNT 0) (for PATH in PATHS when (SETQ OCC (MEMB TERM PATH)) do (SETQ OCC1 (MEMBER TERM PATH)) (SETQ OCC2 (MEMBER TERM (CDR OCC))) (COND ((AND (EQ OCC OCC1) (NULL OCC2)) (SETQ ISOLATED-CNT (ADD1 ISOLATED-CNT))) ((EQ OCC OCC1) (SETQ FIRST-CNT (ADD1 FIRST-CNT))) (T (SETQ SECOND-CNT (ADD1 SECOND-CNT))))) (* For each common subterm, we now decide what to replace the term with.  There are 5 alternatives. 1.0 (SET) Replace the term with  (SETQ (v term) term) where (v term) is a LITATOM beginning with 2 and such that  for all non-EQUAL common subterms s and t of FORM,  (v t) is not (v s)%. 2.0 (VAR) Replace term with  (v term)%. 3.0 (TEST) Replace term with (*2*IF  (EQ (v term) *1*X) term (v term))%. 4.0 (TEST-AND-SET) Replace term with  (*2*if (EQ (v term) *1*x) (SETQ (v term) term)  (v term))%. 5.0 Do nothing. *) (COND ((GREATERP FIRST-CNT 0) (COND ((GREATERP SECOND-CNT 0) (SETQ DECISIONS (CONS (CONS TERM (QUOTE TEST-AND-SET )) DECISIONS))) (T (SETQ DECISIONS (CONS (CONS TERM (QUOTE SET)) DECISIONS))))) ((GREATERP SECOND-CNT 0) (COND ((GREATERP ISOLATED-CNT 0) (SETQ DECISIONS (CONS (CONS TERM (QUOTE TEST)) DECISIONS))) (T (* This is the only decision that deserves serious consideration.  All of the other decisions obviously result in correct behavior.  Here, we know that the term always occurs second.  Thus we are guaranteed that on every path to term, an equal term will have  previously been evaluated. For each such path, some EQUAL term will have a  FIRST occurrence and every term that is ever first is always SET or  TEST-AND-SET. *) (SETQ DECISIONS (CONS (CONS TERM (QUOTE VAR)) DECISIONS))))) (T NIL))) (* We now construct a list of the common subterms, omitting EQUAL duplications.  We wish to associate a unique variable *2*TEMPi, for some i, with all EQUAL  common subterms. *) (SETQ DOUBLE-TERMS (for D in DECISIONS bind LOOP-ANS do (SETQ LOOP-ANS (ADD-TO-SET (CAR D) LOOP-ANS)) finally (RETURN LOOP-ANS))) (SETQ VAR-ALIST (for D in DOUBLE-TERMS as I from 1 collect (CONS D (PACK (CONS STRING-WEIRD2 (CONS (QUOTE TEMP) (UNPACK I))))))) (* Using DOUBLE-TERMS and VAR-ALIST,  COMMON-SWEEP now carries out the  DECISIONS. *) (SETQ NEW-FORM (COMMON-SWEEP FORM)) (RETURN (LIST (QUOTE LET) (for PAIR in VAR-ALIST collect (LIST (CDR PAIR) (QUOTE (QUOTE *1*X)))) NEW-FORM]) (PARTITION [LAMBDA (L) (* kbr: "19-Oct-85 16:31") (* Returns a list of lists. Each member of L is a MEMBer of exactly one the of  list of lists. Each MEMBer of each list is a MEMBer of L.  *) (LET (POT TEMP) (for L1 in L do (SETQ TEMP (SASSOC L1 POT)) (COND ((NULL TEMP) (SETQ POT (CONS (LIST L1) POT))) (T (NCONC1 TEMP L1)))) POT]) (PARTITION-CLAUSES [LAMBDA (LST) (* kbr: "20-Oct-85 19:37") (LET (ALIST FLG POCKETS N) (SETQ LST (for CL in LST collect (CONS NIL CL))) (for PAIR in LST do (for LIT in (CDR PAIR) do (SETQ FLG (BM-MATCH LIT (NOT LIT))) (SETQ TEMP-TEMP (SASSOC LIT ALIST)) (COND ((NULL TEMP-TEMP) (SETQ TEMP-TEMP (LIST LIT FLG PAIR)) (SETQ ALIST (CONS TEMP-TEMP ALIST))) ((EQUAL (CADR TEMP-TEMP) 0) NIL) ((NEQ FLG (CADR TEMP-TEMP)) (RPLACA (CDR TEMP-TEMP) 0)) (T (RPLACD (CDR TEMP-TEMP) (CONS PAIR (CDDR TEMP-TEMP))))))) (SETQ N (LENGTH LST)) (for PAIR in ALIST when (AND (NOT (EQUAL (CADR PAIR) 0)) (NOT (IEQP (LENGTH (CDDR PAIR)) N))) do (SETQ POCKETS (CONS (for PAIR in (CDDR PAIR) unless (CAR PAIR) collect (PROGN (RPLACA PAIR T) (CDR PAIR))) POCKETS))) (COND ((SETQ TEMP-TEMP (for PAIR in LST unless (CAR PAIR) collect (CDR PAIR))) (SETQ POCKETS (CONS TEMP-TEMP POCKETS)))) POCKETS]) (PATH-ADD-TO-SET [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (COND ((for Y1 in Y thereis (PATH-EQ X Y1)) Y) (T (CONS X Y]) (PATH-EQ [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (AND (IEQP (LENGTH X) (LENGTH Y)) (for X1 in X as Y1 in Y always (EQ X1 Y1]) (PATH-POT-SUBSUMES [LAMBDA (LARGER SMALLER) (* kbr: "19-Oct-85 16:31") (for I from 1 to (SUB1 (LENGTH (CAR LARGER))) thereis (for S in SMALLER always (for L in LARGER thereis (EQ S (FARGN L I]) (PATH-UNION [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (NCONC (for X1 in X unless (for Y1 in Y thereis (PATH-EQ X1 Y1)) collect X1) Y]) (PEGATE-LIT [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((FALSE-NONFALSEP TERM) (COND (DEFINITELY-FALSE FALSE) (T TRUE))) (T TERM]) (PETITIO-PRINCIPII [LAMBDA (EVENTS ALL-FLG FAILURE-ACTION DETACH-FLG DO-NOT-PRINT-FIRST-EVENT-FLG DO-NOT-PRINT-DATE-LINE-FLG) (* kbr: "19-Oct-85 16:31") (REDO-UNDONE-EVENTS (for X in EVENTS collect (COND ((EQ (CAR X) (QUOTE PROVE-LEMMA)) (LIST (QUOTE ADD-AXIOM) (CADR X) (CADDR X) (CADDDR X))) (T X))) ALL-FLG FAILURE-ACTION DETACH-FLG DO-NOT-PRINT-FIRST-EVENT-FLG DO-NOT-PRINT-DATE-LINE-FLG]) (PICK-HIGH-SCORES [LAMBDA (CANDLST) (* kbr: "19-Oct-85 16:31") (* Returns the list of elements of  CAND-LIST tied for the highest CAR.  *) (MAXIMAL-ELEMENTS CANDLST (FUNCTION (LAMBDA (CAND) (fetch (CANDIDATE SCORE) of CAND]) (PIGEON-HOLE [LAMBDA (PIGEONS HOLES FN DO-NOT-CROWD-FLG DO-NOT-SMASH-FLG) (* kbr: "19-Oct-85 16:31") (LET (PAIRLST) (SETQ PAIRLST (for X in HOLES collect (CONS NIL X))) (COND ((PIGEON-HOLE1 PIGEONS PAIRLST FN DO-NOT-CROWD-FLG DO-NOT-SMASH-FLG) (COND (DO-NOT-SMASH-FLG HOLES) (T (for PAIR in PAIRLST collect (CDR PAIR))))) (T NIL]) (PIGEON-HOLE-IN-ALL-POSSIBLE-WAYS [LAMBDA (PIGEONS HOLES FN DO-NOT-CROWD-FLG) (* kbr: "20-Oct-85 19:25") (LET (ANS POT X) (COND ((for PIGEON in PIGEONS always (PROGN (SETQ POT (for HOLE in HOLES when (SETQ X (APPLY* FN PIGEON HOLE)) collect (CONS HOLE X))) (COND (POT (SETQ ANS (NCONC1 ANS POT))) (T NIL)))) (COND ((AND DO-NOT-CROWD-FLG (NOT (NO-CROWDINGP ANS [FUNCTION (LAMBDA (X Y) (EQ (CAR X) (CAR Y] NIL))) NIL) (T (UNION-EQUAL (for X in ANS join (for Y in X collect (CDR Y))) (for HOLE in HOLES unless (for X in ANS thereis (ASSOC HOLE X)) collect HOLE))))) (T NIL]) (PIGEON-HOLE1 [LAMBDA (PIGEONS PAIRLST FN DO-NOT-CROWD-FLG DO-NOT-SMASH-FLG) (* kbr: "19-Oct-85 16:31") (LET (TEMP OLD-FLG OLD-HOLE) (COND ((NULL PIGEONS) T) ((for PAIR in PAIRLST unless (AND DO-NOT-CROWD-FLG (CAR PAIR)) thereis (COND ((SETQ TEMP (APPLY* FN (CAR PIGEONS) (CDR PAIR))) (SETQ OLD-FLG (CAR PAIR)) (SETQ OLD-HOLE (CDR PAIR)) (OR DO-NOT-SMASH-FLG (RPLACD PAIR TEMP)) (RPLACA PAIR T) (COND ((PIGEON-HOLE1 (CDR PIGEONS) PAIRLST FN DO-NOT-CROWD-FLG DO-NOT-SMASH-FLG) T) (T (RPLACD PAIR OLD-HOLE) (RPLACA PAIR OLD-FLG) NIL))) (T NIL))) T) (T NIL]) (PLUSJOIN [LAMBDA (LST) (* kbr: "19-Oct-85 16:31") (COND ((NULL LST) (QUOTE (ZERO))) ((NULL (CDR LST)) (CAR LST)) (T (FCONS-TERM* (QUOTE PLUS) (CAR LST) (PLUSJOIN (CDR LST]) (POLY-MEMBER [LAMBDA (POLY LST) (* kbr: "19-Oct-85 16:31") (for POLY2 in LST thereis (AND (EQUAL (fetch (POLY CONSTANT) of POLY) (fetch (POLY CONSTANT) of POLY2)) (EQUAL (fetch (POLY ALIST) of POLY) (fetch (POLY ALIST) of POLY2]) (POP-CLAUSE-SET [LAMBDA NIL (* kbr: "20-Apr-86 18:42") (PROG (CL-SET TEMP) TOP (COND ((NULL STACK) (WRAPUP T)) ((EQ (CAAR STACK) (QUOTE BEING-PROVED)) (SETQ TEMP (CADR (CAR STACK))) (SETQ STACK (CDR STACK)) (IO (QUOTE POP) TEMP NIL NIL (LIST (GET-STACK-NAME STACK))) (GO TOP)) (T (SETQ CL-SET (CADR (CAR STACK))) (SETQ STACK (CDR STACK)))) (COND ((for STACK-TAIL on STACK do (COND ((for CL2 in CL-SET always (for CL1 in (CADR (CAR STACK-TAIL)) thereis (SUBSUMES CL1 CL2))) (COND ((EQ (CAR (CAR STACK-TAIL)) (QUOTE BEING-PROVED)) (IO (QUOTE SUBSUMED-BY-PARENT) CL-SET NIL NIL (LIST (GET-STACK-NAME STACK) (GET-STACK-NAME (CDR STACK-TAIL)) (CADR (CAR STACK-TAIL)))) (WRAPUP NIL)) (T (IO (QUOTE SUBSUMED-BELOW) CL-SET NIL NIL (LIST (GET-STACK-NAME STACK) (GET-STACK-NAME (CDR STACK-TAIL)) (CADR (CAR STACK-TAIL))) ) (GO TOP)))))) (GO TOP))) (SETQ STACK (CONS (LIST (QUOTE BEING-PROVED) CL-SET) STACK)) (RETURN CL-SET]) (POP-LEMMA-FRAME [LAMBDA NIL (* kbr: "19-Oct-85 22:23") (PROG1 (CAR LEMMA-STACK) (COND ((NULL LEMMA-STACK) (ERROR1 (PQUOTE (PROGN LEMMA-STACK IS TOO POOPED TO POP !)) NIL (QUOTE HARD))) (T (SETQ LEMMA-STACK (CDR LEMMA-STACK]) (POP-LINEARIZE-ASSUMPTIONS-FRAME [LAMBDA NIL (* kbr: "19-Oct-85 22:02") (PROG1 (CAR LINEARIZE-ASSUMPTIONS-STACK) (COND ((NULL LINEARIZE-ASSUMPTIONS-STACK) (ERROR1 (PQUOTE (PROGN LINEARIZE-ASSUMPTIONS-STACK IS TOO POOPED TO POP !)) NIL (QUOTE HARD))) (T (SETQ LINEARIZE-ASSUMPTIONS-STACK (CDR LINEARIZE-ASSUMPTIONS-STACK]) (POPU [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (SETQ UNDONE-EVENTS (CAR UNDONE-EVENTS-STACK)) (SETQ UNDONE-EVENTS-STACK (CDR UNDONE-EVENTS-STACK)) UNDONE-EVENTS]) (POSSIBLE-IND-PRINCIPLES [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* TERM is a non-QUOTE fn call and this fn returns all the induction principles  suggested by it. See FLESH-OUT-IND-PRIN for the form of an induction prin.  *) (LET (MACHINE FORMALS QUICK-BLOCK-INFO MASK) (SETQ FORMALS (CADR (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN)))) (SETQ QUICK-BLOCK-INFO (GETPROP (FFN-SYMB TERM) (QUOTE QUICK-BLOCK-INFO))) (SETQ MACHINE (GETPROP (FFN-SYMB TERM) (QUOTE INDUCTION-MACHINE))) (COND ((DISABLEDP (FFN-SYMB TERM)) NIL) (T (for J in (GETPROP (FFN-SYMB TERM) (QUOTE JUSTIFICATIONS)) when (SETQ MASK (SOUND-IND-PRIN-MASK TERM J FORMALS QUICK-BLOCK-INFO)) collect (FLESH-OUT-IND-PRIN TERM FORMALS MACHINE J MASK QUICK-BLOCK-INFO]) (POSSIBLY-NUMERIC [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET ((TYPE-ALIST (OR HEURISTIC-TYPE-ALIST TYPE-ALIST))) (IEQP (TYPE-SET TERM) TYPE-SET-NUMBERS]) (POWER-EVAL [LAMBDA (L B) (* kbr: "25-Oct-85 18:13") (COND ((NLISTP L) 0) (T (PLUS (CAR L) (TIMES B (POWER-EVAL (CDR L) B]) (POWER-REP [LAMBDA (N B) (* kbr: "19-Oct-85 16:31") (COND ((LESSP N B) (LIST N)) (T (CONS (REMAINDER N B) (POWER-REP (QUOTIENT N B) B]) (PPC [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (BM-PPR (PRETTYIFY-CLAUSE CL) NIL) NIL]) (PPE [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (PPE-LST (LIST X]) (PPE-LST [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (for NAME in X do (ITERPRI NIL) (BM-PPR (OR (GETPROP NAME (QUOTE EVENT)) (AND (GETPROP NAME (QUOTE MAIN-EVENT)) (LIST (QUOTE *****) NAME (QUOTE IS) (QUOTE A) (QUOTE SATELLITE) (QUOTE OF) (GETPROP (GETPROP NAME (QUOTE MAIN-EVENT)) (QUOTE EVENT)))) (CONS (QUOTE *****) (CONS NAME (QUOTE (IS NEITHER AN EVENT NOR SATELLITE))))) NIL) (ITERPRI NIL]) (BM-PPR [LAMBDA (FMLA PPRFILE) (* kbr: "19-Oct-85 16:31") (LET (LEFTMARGINCHAR) (PPRIND FMLA 0 0 PPR-MACRO-LST PPRFILE) NIL]) (PPRINDENT [LAMBDA (TERM LEFTMARGIN RPARCNT FILE) (* kbr: "19-Oct-85 16:31") (COND ((IGREATERP (IPOSITION FILE NIL NIL) LEFTMARGIN) (ITERPRISPACES LEFTMARGIN FILE)) (T (TABULATE LEFTMARGIN FILE))) (PPRIND TERM LEFTMARGIN (OR RPARCNT 0) PPR-MACRO-LST FILE]) (PPSD [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (PPSD-LST (LIST X]) (PPSD-LST [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (for FNNAME in X do (BM-PPR (LIST FNNAME (OR (GETPROP FNNAME (QUOTE SDEFN)) (QUOTE UNDEFINED))) NIL) (ITERPRI NIL) (ITERPRI NIL]) (PREPROCESS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* Returns a set of clauses whose conjunction is equivalent to TERM and sets  ABBREVIATIONS-USED to the list of fn symbols and rewrite rules applied.  *) (LET (TYPE-ALIST) (SETQ ABBREVIATIONS-USED NIL) (CLAUSIFY-INPUT (EXPAND-ABBREVIATIONS TERM NIL]) (PREPROCESS-HYPS [LAMBDA (HYPS) (* kbr: "19-Oct-85 20:11") (* Expand NLISTP and NOT ZEROP hyps.  *) (for HYP in HYPS bind X join (COND ((BM-MATCH HYP (NOT (ZEROP X))) (LIST (FCONS-TERM* (QUOTE NUMBERP) X) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE EQUAL) X ZERO)))) ((BM-MATCH HYP (NLISTP X)) (LIST (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE LISTP) X)))) (T (LIST HYP]) (PRETTYIFY-CLAUSE [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (COND ((NULL CL) FALSE) ((NULL (CDR CL)) (CAR CL)) ((NULL (CDDR CL)) (LIST (QUOTE IMPLIES) (DUMB-NEGATE-LIT (CAR CL)) (CADR CL))) (T (LIST (QUOTE IMPLIES) (CONS (QUOTE AND) (for TAIL on CL unless (NULL (CDR TAIL)) collect (DUMB-NEGATE-LIT (CAR TAIL)))) (CAR (LAST CL]) (PRETTYIFY-LISP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (REMOVE-*2*IFS (INTRODUCE-ANDS (INTRODUCE-LISTS X]) (PRIMITIVE-RECURSIVEP [LAMBDA (FNNAME) (* kbr: "19-Oct-85 16:31") (LET (FORMALS) (SETQ FORMALS (CADR (GETPROP FNNAME (QUOTE SDEFN)))) (COND ((DISABLEDP FNNAME) T) (T (for X in (GETPROP FNNAME (QUOTE INDUCTION-MACHINE)) always (for CASE in (fetch (TESTS-AND-CASES CASES) of X) always (for VAR in FORMALS as TERM in CASE always (SHELL-DESTRUCTOR-NESTP VAR TERM]) (PRIMITIVEP [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (OR (VARIABLEP TERM) (FQUOTEP TERM) (AND (OR (NULL (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN))) (DISABLEDP (FFN-SYMB TERM)) (EQ (FFN-SYMB TERM) (QUOTE NOT))) (for ARG in (FARGS TERM) always (PRIMITIVEP ARG]) (PRINT-STACK [LAMBDA (Y) (* kbr: "19-Oct-85 16:31") (for X on Y by (QUOTE CADR) do (IPRINT (CAR X) T]) (PRINT-STATS [LAMBDA (ELAPSED IO FILE) (* kbr: "22-Oct-85 16:20") (ITERPRI FILE) (IPRINC "(" FILE) (ISPACES 1 FILE) (IPRINC ELAPSED FILE) (ISPACES 1 FILE) (IPRINC IO FILE) (ISPACES 1 FILE) (IPRINC ")" FILE]) (PRINT-TO-DISPLAY [LAMBDA (MSG1 MSG2 MSG3) (* kbr: "20-Oct-85 17:24") (COND ((NULL LEMMA-DISPLAY-FLG)) ((EQ LEMMA-DISPLAY-FLG (QUOTE MODEL33)) (for I from 1 to (SUB1 (STACK-DEPTH LEMMA-STACK)) do (* STACK-DEPTH starts at 1 and we want 0 leading chars at first.  In LEMMA-DISPLAY mode T we use STACK-DEPTH because lines on the screen are  numbered from 1.0 The CONSTANT below is just vertical bar, but if typed  explicitly it is brought up from emacs incorrectly.  *) (IPRINC "/" T)) (IPRINC "*" T) (IPRINC MSG1 T) (COND (MSG2 (ISPACES 1 T) (IPRINC MSG2 T))) (COND (MSG3 (IPRINC MSG3 T))) (ITERPRI T)) (T (PUT-CURSOR 1 (STACK-DEPTH LEMMA-STACK)) (ERASE-EOP) (IPRINC MSG1 T) (COND (MSG2 (ISPACES 1 T) (IPRINC MSG2 T))) (COND (MSG3 (IPRINC MSG3 T]) (PROCESS-EQUATIONAL-POLYS [LAMBDA (CL HIST POT-LST) (* kbr: "19-Oct-85 16:31") (* Deduce from POT-LST all the interesting equations in it and add them to CL  unless they have already been generated and recorded in HIST.  This function has no effect on the lemma and assumptions stacks but sets the  globals LEMMAS-USED-BY-LINEAR and LINEAR-ASSUMPTIONS if it changes CL.  When it adds an equation to CL it adds an entry to LEMMAS-USED-BY-LINEAR that  will ultimately be copied into the new hist for the clause.  The entry is of the form ((FIND-EQUATIONAL-POLYS lhs)) --  the apparently redundant level of parens is there to insure that the element  cannot be confused with a term. Thus, when it is thrown into the list  PROCESS-HIST with lemma names and literals used, we can filter out the  literals. SIMPLIFY-CLAUSE handles this filtering above us.  FIND-EQUATIONAL-POLY is the function that adds such entries to  LEMMAS-USED-BY-LINEAR and that looks for them in the HIST.  *) (SETQ LEMMAS-USED-BY-LINEAR NIL) (SETQ LINEAR-ASSUMPTIONS NIL) (for POT in POT-LST bind PAIR when (SETQ PAIR (FIND-EQUATIONAL-POLY HIST POT)) do (* When FIND-EQUATIONAL-POLY returns  nonNIL it side-effects the two global  collection sites above.  *) (SETQ CL (COND ((AND (VARIABLEP (CAR PAIR)) (NOT (OCCUR (CAR PAIR) (CDR PAIR)))) (SUBST-VAR-LST (CDR PAIR) (CAR PAIR) CL)) ((AND (VARIABLEP (CDR PAIR)) (NOT (OCCUR (CDR PAIR) (CAR PAIR)))) (SUBST-VAR-LST (CAR PAIR) (CDR PAIR) CL)) (T (CONS (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE EQUAL) (CAR PAIR) (CDR PAIR))) (SUBST-EXPR-LST (CDR PAIR) (CAR PAIR) CL)))))) CL]) (PROPERTYLESS-SYMBOLP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (OR (CAR-CDRP X) (MEMB X (QUOTE (NIL QUOTE LIST T F]) (PROVE [LAMBDA (FORM) (* kbr: " 6-Jul-86 09:44") (PROG (THM CLAUSES VARS) (SETQ THM (TRANSLATE FORM)) (SETQ CLAUSES (PREPROCESS THM)) (SETUP FORM CLAUSES ABBREVIATIONS-USED) (* Basic control loop of the Boyer  Moore theorem prover is to simplify  the clause set, induct, repeat again.  *) LOOP (SETQ VARS (for CL in CLAUSES bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (ALL-VARS-LST CL) LOOP-ANS)) finally (RETURN LOOP-ANS))) (SETQ ELIM-VARIABLE-NAMES1 (SET-DIFF ELIM-VARIABLE-NAMES VARS)) (SETQ GEN-VARIABLE-NAMES1 (SET-DIFF GEN-VARIABLE-NAMES VARS)) (* Simplification = Simplify, Settle  Down, Eliminate Destructors,  Fertilize, Generalize, Eliminate  Irrelevance *) (SIMPLIFY-LOOP CLAUSES) (* Induction *) (SETQ CLAUSES (INDUCT (POP-CLAUSE-SET))) (GO LOOP]) (PROVE-TERMINATION [LAMBDA (FORMALS RM MACHINE) (* kbr: "19-Oct-85 16:31") (SETQ PROVE-TERMINATION-LEMMAS-USED NIL) (for X in MACHINE always (COND ((AND (SIMPLIFY-CLAUSE-MAXIMALLY (NCONC1 (for H in (fetch (TESTS-AND-CASE TESTS) of X) collect (NEGATE-LIT H)) (CONS-TERM (CAR RM) (LIST (SUB-PAIR-VAR FORMALS (fetch ( TESTS-AND-CASE CASE) of X) (CADR RM)) (CADR RM))))) (NULL PROCESS-CLAUSES)) (SETQ PROVE-TERMINATION-LEMMAS-USED (UNION-EQUAL PROCESS-HIST PROVE-TERMINATION-LEMMAS-USED )) T) (T NIL]) (PROVEALL [LAMBDA (EVENT-LST DETACH-FLG FILENAME) (* kbr: "24-Oct-85 17:19") DETACH-FLG (SETQ FAILED-THMS NIL) (SETQ MASTER-ROOT-NAME (OR FILENAME (QUOTE PROVEALL))) (SETQ PROVE-FILE (AND NIL (OPENSTREAM (EXTEND-FILE-NAME MASTER-ROOT-NAME (QUOTE PROOFS)) (QUOTE OUTPUT)))) (SETQ TTY-FILE (AND NIL (OPENSTREAM (EXTEND-FILE-NAME MASTER-ROOT-NAME (QUOTE TTY)) (QUOTE OUTPUT)))) (REDO-UNDONE-EVENTS EVENT-LST T (QUOTE A) DETACH-FLG NIL NIL) (MAKE-LIB MASTER-ROOT-NAME]) (PUSH-CLAUSE-SET [LAMBDA (CL-SET) (* kbr: "19-Oct-85 16:31") (SETQ STACK (CONS (LIST (QUOTE TO-BE-PROVED) CL-SET) STACK]) (PUSH-LEMMA [LAMBDA (ELE) (* kbr: "19-Oct-85 16:31") (COND ((MEMB ELE (CAR LEMMA-STACK)) NIL) (T (RPLACA LEMMA-STACK (CONS ELE (CAR LEMMA-STACK))) NIL]) (PUSH-LEMMA-FRAME [LAMBDA NIL (* kbr: "19-Oct-85 22:23") (SETQ LEMMA-STACK (CONS NIL LEMMA-STACK)) NIL]) (PUSH-LINEARIZE-ASSUMPTION [LAMBDA (ELE) (* kbr: "19-Oct-85 16:31") (RPLACA LINEARIZE-ASSUMPTIONS-STACK (ADD-TO-SET ELE (CAR LINEARIZE-ASSUMPTIONS-STACK))) NIL]) (PUSH-LINEARIZE-ASSUMPTIONS-FRAME [LAMBDA NIL (* kbr: "19-Oct-85 22:00") (SETQ LINEARIZE-ASSUMPTIONS-STACK (CONS NIL LINEARIZE-ASSUMPTIONS-STACK)) NIL]) (PUSHU [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (SETQ UNDONE-EVENTS-STACK (CONS UNDONE-EVENTS UNDONE-EVENTS-STACK)) (SETQ UNDONE-EVENTS NIL]) (PUT-CURSOR [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (CURSORPOS Y X]) (PUT-INDUCTION-INFO [LAMBDA (FNNAME FORMALS BODY RELATION-MEASURE-LST TAK0) (* kbr: "19-Oct-85 16:31") (* If FNNAME is recursive we store JUSTIFICATIONS, INDUCTION-MACHINE, and  QUICK-BLOCK-INFO properties. If only one JUSTIFICATION is stored and in it the  RELATION is NIL then we did not establish termination.  ALL-LEMMAS-USED is side-effected to contain lemma names used to clean up the  INDUCTION-MACHINE. If TAK0 is nonNIL, then we are considering a reflexive  definition. (tak0) IEQP body is allegedly the justifying lemma for the  definition (fnname) IEQP body', where body' results from replacing all calls of  tak0 with fnname. *) (PROG (T-MACHINE I-MACHINE) (SETQ T-MACHINE (TERMINATION-MACHINE (OR TAK0 FNNAME) BODY NIL)) (COND ((NULL T-MACHINE) (SETQ ALL-LEMMAS-USED NIL) (RETURN NIL))) (OR RELATION-MEASURE-LST (SETQ RELATION-MEASURE-LST (GUESS-RELATION-MEASURE-LST FORMALS T-MACHINE))) (ADD-FACT FNNAME (QUOTE JUSTIFICATIONS) (OR (for RM in RELATION-MEASURE-LST when (PROVE-TERMINATION FORMALS RM T-MACHINE) collect (create JUSTIFICATION SUBSET _ (ALL-VARS (CADR RM)) MEASURE-TERM _ (CADR RM) RELATION _ (CAR RM) LEMMAS _ PROVE-TERMINATION-LEMMAS-USED)) (LIST (create JUSTIFICATION SUBSET _ FORMALS)))) (SETQ ALL-LEMMAS-USED NIL) (* We set ALL-LEMMAS-USED to NIL to forget the lemmas put there by PROVE so we  can now accumulate the lemmas used by REMOVE-REDUNDANT-TESTS in  INDUCTION-MACHINE. *) (SETQ I-MACHINE (INDUCTION-MACHINE FNNAME (COND (TAK0 (SUBST-FN FNNAME TAK0 BODY)) (T BODY)) NIL)) (ADD-FACT FNNAME (QUOTE INDUCTION-MACHINE) I-MACHINE) (ADD-FACT FNNAME (QUOTE QUICK-BLOCK-INFO) (QUICK-BLOCK-INFO FORMALS I-MACHINE)) (RETURN NIL]) (PUT-LEVEL-NO [LAMBDA (FNNAME) (* kbr: "24-Oct-85 15:48") (LET (BODY MAX) (SETQ BODY (CADDR (GETPROP FNNAME (QUOTE SDEFN)))) (SETQ MAX 0) (for FN in (ALL-FNNAMES BODY) when (NEQ FN FNNAME) do (SETQ MAX (IMAX (GET-LEVEL-NO FN) MAX))) (ADD-FACT FNNAME (QUOTE LEVEL-NO) (COND ((FNNAMEP FNNAME BODY) (ADD1 MAX)) (T MAX]) (PUT-TYPE-PRESCRIPTION [LAMBDA (NAME) (* kbr: "20-Apr-86 18:34") (* THIS FUNCTION WILL BE COMPLETELY UNSOUND IF TYPE-SET IS EVER REACHABLE FROM  WITHIN IT. IN PARTICULAR, BOTH THE TYPE-ALIST AND THE TYPE-PRESCRIPTION FOR THE  FN BEING PROCESSED ARE SET TO ONLY PARTIALLY ACCURATE VALUES AS THIS FN  COMPUTES THE REAL TYPE-SET. *) (PROG (OLD-TYPE-PRESCRIPTION NEW-TYPE-PRESCRIPTION BODY FORMALS TYPE-ALIST ANS TEMP) (SETQ BODY (GETPROP NAME (QUOTE SDEFN))) (SETQ FORMALS (CADR BODY)) (SETQ BODY (CADDR BODY)) (SETQ TYPE-ALIST (for ARG in FORMALS collect (CONS ARG (CONS 0 (LIST ARG))))) (SETQ OLD-TYPE-PRESCRIPTION (CONS 0 (for ARG in FORMALS collect NIL))) (ADD-FACT NAME (QUOTE TYPE-PRESCRIPTION-LST) (CONS NAME OLD-TYPE-PRESCRIPTION)) LOOP (RPLACD (CAR (SETQ TEMP (GETPROP NAME (QUOTE TYPE-PRESCRIPTION-LST)))) OLD-TYPE-PRESCRIPTION) (* It is very unusual to be mucking about with RPLACDs on data that is part of  the event level abstraction. But by virtue of the fact that we know what the  abstraction is and how it works -- i.e., by violating the abstraction! --  we know what we're doing here. The TYPE-PRESCRIPTION-LST at this moment is a  singleton list containing just the CONS added above.  The CAR of that CONS is the name of the event that gave rise to the type  prescription and the CDR is the type prescription.  The RPLACD above smashes the type prescription in the CDR to a new that  includes all the information contained in the current guess.  The fundamental difficulty with destructively changing event level data arises  because the ADD-SUB-FACT mechanism stores certain undo information about each  added fact, and if you change the data without being aware of that, you might  make the data inconsistent with the undoing information about it.  But we know that all ADD-SUB-FACT stores in this case is the name of the lemma,  that is, the CAR of the TYPE-PRESCRIPTION-NAME-AND-PAIR, and so by smashing the  CDR we're consistently fooling it. *) (PUTPROP NAME (QUOTE TYPE-PRESCRIPTION-LST) TEMP) (* Why do we both RPLACD the structure on the property list AND do the PUTPROP?  The answer is that we are afraid that someday perhaps we will permit a SWAPOUT  to occur anytime. Note that if that happened after we did the GETPROP but  before the RPLACD happened we would lose.  *) (SETQ ANS (DEFN-TYPE-SET BODY)) (SETQ NEW-TYPE-PRESCRIPTION (CONS (CAR ANS) (for ARG in FORMALS collect (COND ((MEMB ARG (CDR ANS)) T) (T NIL))))) (COND ((EQUAL OLD-TYPE-PRESCRIPTION NEW-TYPE-PRESCRIPTION) (RETURN NIL)) ((AND (LOGSUBSETP (CAR NEW-TYPE-PRESCRIPTION) (CAR OLD-TYPE-PRESCRIPTION)) (for FLG1 in (CDR NEW-TYPE-PRESCRIPTION) as FLG2 in (CDR OLD-TYPE-PRESCRIPTION) always (OR (NOT FLG1) FLG2))) (ERROR1 (PQUOTE (PROGN AN UNEXPECTED SITUATION HAS ARISEN ! THE DEFN-TYPE-SET ITERATION STOPPED BECAUSE OF A PROPER SUBSET CHECK RATHER THAN THE EQUALITY OF THE OLD AND NEW TYPE SETS %.)) NIL (QUOTE WARNING)) (RETURN NIL))) (SETQ OLD-TYPE-PRESCRIPTION (CONS (LOGOR (CAR OLD-TYPE-PRESCRIPTION) (CAR NEW-TYPE-PRESCRIPTION)) (for FLG1 in (CDR OLD-TYPE-PRESCRIPTION) as FLG2 in (CDR NEW-TYPE-PRESCRIPTION) collect (OR FLG1 FLG2)))) (GO LOOP]) (PUT0 [LAMBDA (ATM PROP VAL HIGHER-PROPS) (* kbr: "19-Oct-85 16:31") (* This function is conceptually hidden from the user of the lib file package.  It may be called internally provided ATM is known to be in the PROP-HASH-ARRAY  already. HIGHER-PROPS is the list of properties with higher priority than this  one. If it is NIL this function assumes that it hasn't been computed by the  caller and computes it. If the computation returns NIL, then PROP is not a  member of LIB-PROPS and an error is caused.  The reason this function does not just have three args and always compute  HIGHER-PROPS -- rather than allowing the caller to do it but not believing the  caller when he says NIL -- is that the main use of PUT0 is from PUT1, who must  decide whether PROP is a member of LIB-PROPS before updating the hash array for  ATM. So this implementation allows PUT1 to pass its answer down rather than  require PUT0 to do the work again. At the moment, the only other calls of PUT0  do not bother to compute HIGHER-PROPS and just let PUT0 do it.  But even if they did, and computed NIL, and did not check it but forced PUT0 to  compute the NIL again, the time wasted is not important since we're going to  then cause an error anyway. *) (OR HIGHER-PROPS (SETQ HIGHER-PROPS (MEMB PROP LIB-PROPS)) (ERROR1 (PQUOTE (PROGN ATTEMPT TO PUT1 THE NON-LIB-PROPS PROPERTY (!PPR PROP NIL) %.)) (BINDINGS (QUOTE PROP) PROP) (QUOTE HARD))) (SETPROPLIST ATM (PUT00 (GETPROPLIST ATM) PROP VAL)) VAL]) (PUT00 [LAMBDA (TAIL PROP VAL) (* kbr: "19-Oct-85 16:31") (COND ((NULL TAIL) (LIST PROP VAL)) ((EQ PROP (CAR TAIL)) (RPLACA (CDR TAIL) VAL) TAIL) ((MEMB (CAR TAIL) HIGHER-PROPS) (COND ((CDDR TAIL) (RPLACD (CDR TAIL) (PUT00 (CDDR TAIL) PROP VAL)) TAIL) (T (NCONC TAIL (LIST PROP VAL))))) (T (CONS PROP (CONS VAL TAIL]) (PUT1 [LAMBDA (ATM VAL PROP) (* kbr: "19-Oct-85 16:31") (* Like PUTPROP except keeps the properties in the order specified by  LIB-PROPS, causing an error if PROP is not on LIB-PROPS, and insures that ATM  is a memb of LIB-ATOMS-WITH-PROPS *) (LET (HIGHER-PROPS) (COND ((NOT (BOUNDP (QUOTE LIB-PROPS))) (ERROR1 (PQUOTE (PROGN THEOREM PROVER NOT INITIALIZED %.)) NIL (QUOTE HARD))) ((NULL (SETQ HIGHER-PROPS (MEMB PROP LIB-PROPS))) (ERROR1 (PQUOTE (PROGN ATTEMPT TO USE PUT1 TO STORE THE NON-LIB-PROPS PROPERTY (!PPR PROP NIL) %.)) (BINDINGS (QUOTE PROP) PROP) (QUOTE HARD))) ((NOT (MEMB ATM LIB-ATOMS-WITH-PROPS)) (SETQ LIB-ATOMS-WITH-PROPS (CONS ATM LIB-ATOMS-WITH-PROPS)))) (PUT0 ATM PROP VAL HIGHER-PROPS]) (PUT1-LST [LAMBDA (ATM PROPS) (* kbr: "19-Oct-85 16:31") (* PROPS is a list of the form (prop1 val1 prop2 val2 ...)%.  This function is equivalent to doing (PUT1 ATM vali propi) for each i, but is  faster. *) (SETPROPLIST ATM (APPEND PROPS (GETPROPLIST ATM]) (PUTD1 [LAMBDA (ATM EXPR) (* kbr: "26-Oct-85 13:52") (* If EXPR is NIL, remove ATM from LIB-ATOMS-WITH-DEFS and erase its function  definition and EXPR property. If EXPR is non-NIL, add ATM to  LIB-ATOMS-WITH-DEFS, make the compiled version of EXPR be the definition of  ATM, and store EXPR under the EXPR prop.  *) (COND ((NULL EXPR) (SETQ LIB-ATOMS-WITH-DEFS (DREMOVE ATM LIB-ATOMS-WITH-DEFS)) (KILL-DEFINITION ATM)) (T (SETQ LIB-ATOMS-WITH-DEFS (CONS ATM LIB-ATOMS-WITH-DEFS)) (STORE-DEFINITION ATM EXPR]) (QUICK-BLOCK-INFO [LAMBDA (FORMALS TESTS-AND-CASES-LST) (* kbr: "19-Oct-85 16:31") (* Return a list of SELF-REFLEXIVE, or QUESTIONABLE, indicating how the  corresponding arg position is changed in the calls enumerated.  This is used to help quickly decide if a blocked formal can be tolerated in  induction. *) (LET (BLOCK-TYPES) (SETQ BLOCK-TYPES (for VAR in FORMALS collect (QUOTE UN-INITIALIZED))) (for TESTS-AND-CASES in TESTS-AND-CASES-LST do (for CASE in (fetch (TESTS-AND-CASES CASES) of TESTS-AND-CASES) do (for VAR in FORMALS as ARG in CASE as TAIL on BLOCK-TYPES do (SELECTQ (CAR TAIL) (QUESTIONABLE NIL) (UN-INITIALIZED (RPLACA TAIL (QUICK-BLOCK-INFO1 VAR ARG))) (OR (EQ (CAR TAIL) (QUICK-BLOCK-INFO1 VAR ARG)) (RPLACA TAIL (QUOTE QUESTIONABLE))))))) BLOCK-TYPES]) (QUICK-BLOCK-INFO1 [LAMBDA (VAR TERM) (* kbr: "19-Oct-85 16:31") (COND ((EQ VAR TERM) (QUOTE UNCHANGING)) ((OCCUR VAR TERM) (QUOTE SELF-REFLEXIVE)) (T (QUOTE QUESTIONABLE]) (QUICK-WORSE-THAN [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM2) (COND ((EQ TERM1 TERM2) NIL) (T (OCCUR TERM2 TERM1)))) ((FQUOTEP TERM2) (COND ((VARIABLEP TERM1) T) ((FQUOTEP TERM1) (GREATERP (FORM-COUNT-EVG (CADR TERM1)) (FORM-COUNT-EVG (CADR TERM2)))) (T T))) ((VARIABLEP TERM1) NIL) ((FQUOTEP TERM1) NIL) ((EQ (FFN-SYMB TERM1) (FFN-SYMB TERM2)) (COND ((EQUAL TERM1 TERM2) NIL) ((for ARG1 in (FARGS TERM1) as ARG2 in (FARGS TERM2) thereis (OR (AND (OR (VARIABLEP ARG1) (VALUEP ARG1)) (NOT (OR (VARIABLEP ARG2) (VALUEP ARG2)))) (WORSE-THAN ARG2 ARG1))) NIL) (T (for ARG1 in (FARGS TERM1) as ARG2 in (FARGS TERM2) thereis (WORSE-THAN ARG1 ARG2))))) (T NIL]) (R [LAMBDA (FORM) (* kbr: "19-Oct-85 16:31") (COND ((NOT (ERRSET (SETQ FORM (TRANSLATE FORM)))) NIL) ((EQ (SETQ TEMP-TEMP (BM-REDUCE FORM R-ALIST)) (QUOTE *1*FAILED)) (QUOTE (NOT REDUCIBLE))) (T (EXPAND-PPR-MACROS TEMP-TEMP]) (REDO! [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (REDO-UNDONE-EVENTS (UNDO-NAME NAME) T (QUOTE C) NIL T T]) (REDO-UNDONE-EVENTS [LAMBDA (EVENTS ALL-FLG FAILURE-ACTION DETACH-FLG DO-NOT-PRINT-FIRST-EVENT-FLG DO-NOT-PRINT-DATE-LINE-FLG) (* kbr: " 6-Jul-86 09:48") (COND (IN-REDO-UNDONE-EVENTS-FLG (ERROR1 (PQUOTE (PROGN IT IS ILLEGAL TO ENTER A THEOREM PROVER FUNCTION WHILE YOU ARE RECURSIVELY UNDER ANOTHER THEOREM PROVER FUNCTION %.)) NIL (QUOTE HARD)))) (LET (ANS ANSLST FORM (IN-REDO-UNDONE-EVENTS-FLG T)) (PROG NIL (OR FAILURE-ACTION (SETQ FAILURE-ACTION (QUOTE Q))) (COND ((NOT (OPENP TTY-FILE)) (SETQ TTY-FILE NIL))) (COND ((NOT (OPENP PROVE-FILE)) (SETQ PROVE-FILE NIL))) (PREPARE-FOR-THE-NIGHT) (COND (DETACH-FLG (SETQ ALL-FLG T) (DETACH))) (SETQ UNDONE-EVENTS EVENTS) (COND ((NOT DO-NOT-PRINT-DATE-LINE-FLG) (PRINT-DATE-LINE))) LOOP (COND ((NULL UNDONE-EVENTS) (GO EXIT))) (SETQ FORM (CAR UNDONE-EVENTS)) (COND ((OR (NOT DO-NOT-PRINT-FIRST-EVENT-FLG) (NEQ FORM (CAR EVENTS)) (NEQ PROVE-FILE NIL)) (ITERPRIN 1 PROVE-FILE) (IPRINC EVENT-SEPARATOR-STRING PROVE-FILE) (ITERPRIN 2 PROVE-FILE) (COND (BOOK-SYNTAX-FLG (DUMP (LIST FORM) PROVE-FILE 5 (LINEL PROVE-FILE) NIL T)) (T (PPRIND FORM 0 0 PPR-MACRO-LST PROVE-FILE))) (ITERPRI PROVE-FILE) (COND ((AND (NEQ PROVE-FILE NIL) (NOT (DETACHEDP))) (IPRINC (CADR FORM) T))))) (COND ((OR (MEMB (CAR FORM) (QUOTE (DEFN REFLECT))) ALL-FLG (EQ FORM (CAR EVENTS)) (IPRINC "DO YOU WANT TO REDO THIS EVENT?" NIL)) (START-STATS) (SETQ ANS (LET (UNDONE-EVENTS) (APPLY (CAR FORM) (CDR FORM)))) (STOP-STATS) (COND ((EQ ANS (QUOTE *****ERROR*****)) (ERROR (QUOTE REDO-UNDONE-EVENTS)) (GO LOOP)) ((OR (NOT DO-NOT-PRINT-FIRST-EVENT-FLG) (NEQ FORM (CAR EVENTS)) (NEQ PROVE-FILE NIL)) (IPRINT ANS PROVE-FILE) (COND ((AND (NOT (DETACHEDP)) (NEQ PROVE-FILE NIL)) (COND ((EQ ANS NIL) (ITERPRI T) (IPRINC FAILURE-MSG T) (ITERPRI T)) (T (IPRINC "," T))))))) (SETQ ANSLST (NCONC1 ANSLST ANS)) (COND ((EQ ANS NIL) (COND ((AND (EQ FAILURE-ACTION (QUOTE A)) (EQ (CAR FORM) (QUOTE PROVE-LEMMA))) (ITERPRIN 2 PROVE-FILE) (BM-PPR (LIST (QUOTE COMMENT) (LIST (QUOTE ADD-AXIOM) (BM-NTH 1 FORM) (BM-NTH 2 FORM) (BM-NTH 3 FORM))) PROVE-FILE) (ITERPRI PROVE-FILE) (IPRINT (APPLY (QUOTE ADD-AXIOM) (LIST (BM-NTH 1 FORM) (BM-NTH 2 FORM) (BM-NTH 3 FORM))) PROVE-FILE)) ((OR (EQ FAILURE-ACTION (QUOTE Q)) (MEMB (CAR FORM) (QUOTE (ADD-AXIOM ADD-SHELL DCL)))) (GO EXIT))))))) (SETQ UNDONE-EVENTS (CDR UNDONE-EVENTS)) (SETQ EVENTS NIL) (GO LOOP) EXIT (COND ((NOT (EQUAL PROVE-FILE NIL)) (ITERPRIN 1 PROVE-FILE) (IPRINC EVENT-SEPARATOR-STRING PROVE-FILE) (PRINT-SYSTEM PROVE-FILE) (IPRINC "REDO-UNDONE-EVENTS COMPLETED. HERE IS FAILED-THMS:" PROVE-FILE) (ITERPRI PROVE-FILE) (BM-PPR FAILED-THMS PROVE-FILE) (ITERPRI PROVE-FILE) (CLOSEF PROVE-FILE) (SETQ PROVE-FILE NIL))) (COND ((NOT (EQUAL TTY-FILE NIL)) (CLOSEF TTY-FILE) (SETQ TTY-FILE NIL))) (RETURN ANSLST]) (BM-REDUCE [LAMBDA (TERM ALIST) (* kbr: "19-Oct-85 16:31") (* TERM is a term. ALIST is an alist dotting variable names to EVGs.  Reduce TERM under the assumptions that each var is equal to the corresponding  constant. Return the resulting term or *1*FAILED if TERM is not reducible.  BM-REDUCE is just serving as a name from which REDUCE1 sometimes RETFROMs.  *) (LIST (QUOTE QUOTE) (REDUCE1 TERM ALIST]) (REDUCE1 [LAMBDA (TERM ALIST) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (COND ((SETQ TEMP-TEMP (ASSOC TERM ALIST)) (CDR TEMP-TEMP)) (T (RETFROM (QUOTE BM-REDUCE) (QUOTE *1*FAILED))))) ((FQUOTEP TERM) (CADR TERM)) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (COND ((EQ (REDUCE1 (FARGN TERM 1) ALIST) *1*F) (REDUCE1 (FARGN TERM 3) ALIST)) (T (REDUCE1 (FARGN TERM 2) ALIST)))) ((SETQ TEMP-TEMP (GETPROP (FFN-SYMB TERM) (QUOTE LISP-CODE))) (* We special case the fns of arity 0,  1, 2, and 3 to avoid consing up the  arg list. *) (SELECTQ (LENGTH TERM) (1 (APPLY* TEMP-TEMP)) (2 (APPLY* TEMP-TEMP (REDUCE1 (FARGN TERM 1) ALIST))) (3 (APPLY* TEMP-TEMP (REDUCE1 (FARGN TERM 1) ALIST) (REDUCE1 (FARGN TERM 2) ALIST))) (4 (APPLY* TEMP-TEMP (REDUCE1 (FARGN TERM 1) ALIST) (REDUCE1 (FARGN TERM 2) ALIST) (REDUCE1 (FARGN TERM 3) ALIST))) (APPLY TEMP-TEMP (for ARG in (FARGS TERM) collect (REDUCE1 ARG ALIST))))) (T (RETFROM (QUOTE BM-REDUCE) (QUOTE *1*FAILED]) (REFLECT0 [LAMBDA (NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST FLG) (* kbr: "20-Oct-85 19:37") (LET (TRANSLATED-BODY CONTROL-VARS FN ARGS BODY (META-NAMES (CONS NAME META-NAMES))) (BM-MATCH (FORMULA-OF SATISFACTION-LEMMA-NAME) (EQUAL (CONS FN ARGS) BODY)) (SETQ TRANSLATED-BODY (TRANSLATE BODY)) (SETQ RELATION-MEASURE-LST (for TEMP in RELATION-MEASURE-LST collect (LIST (CAR TEMP) (TRANSLATE (CADR TEMP))))) (PUT-INDUCTION-INFO NAME ARGS TRANSLATED-BODY RELATION-MEASURE-LST FN) (ADD-FACT NAME (QUOTE SDEFN) (LIST (QUOTE LAMBDA) ARGS (SUBST-FN NAME FN TRANSLATED-BODY))) (ADD-FACT NAME (QUOTE TYPE-PRESCRIPTION-LST) (CAR (GETPROP FN (QUOTE TYPE-PRESCRIPTION-LST)))) (PUT-LEVEL-NO NAME) (AND (GETPROP NAME (QUOTE JUSTIFICATIONS)) (ADD-FACT NAME (QUOTE CONTROLLER-POCKETS) (SCRUNCH (for TEMP in (GETPROP NAME (QUOTE JUSTIFICATIONS)) collect (PROGN (SETQ CONTROL-VARS (fetch (JUSTIFICATION SUBSET) of TEMP)) (for FORMAL in ARGS as I from 0 bind (LOOP-ANS _ 0) when (MEMB FORMAL CONTROL-VARS ) do (SETQ LOOP-ANS (LOGOR LOOP-ANS (LSH 1 I))) finally (RETURN LOOP-ANS))))))) (COND (FLG (ADD-FACT NAME (QUOTE LISP-CODE) (PACK (LIST STRING-WEIRD NAME)))) ((for FN in (ALL-FNNAMES TRANSLATED-BODY) always (OR (EQ FN NAME) (GETPROP FN (QUOTE LISP-CODE)))) (ADD-DCELL NAME (PACK (LIST STRING-WEIRD NAME)) (LIST (QUOTE LAMBDA) (SETQ TEMP-TEMP (for ARG in ARGS collect (PACK (LIST STRING-WEIRD3 ARG)))) (TRANSLATE-TO-LISP (SUB-PAIR-VAR ARGS TEMP-TEMP (SUBST-FN NAME FN TRANSLATED-BODY))))) )) (COND ((NOT (TOTAL-FUNCTIONP NAME)) (ERROR1 (PQUOTE (PROGN THE RECURSION IN (!PPR NAME NIL) IS UNJUSTIFIED %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE WARNING)))) NIL]) (RELIEVE-HYPS [LAMBDA (HYPS LEMMA-NAME) (* kbr: "19-Oct-85 16:31") (PUSH-LEMMA-FRAME) (PUSH-LINEARIZE-ASSUMPTIONS-FRAME) (COND ((RELIEVE-HYPS1 HYPS LEMMA-NAME) (for X in (POP-LEMMA-FRAME) do (PUSH-LEMMA X)) (for X in (POP-LINEARIZE-ASSUMPTIONS-FRAME) do (PUSH-LINEARIZE-ASSUMPTION X)) T) (T (POP-LEMMA-FRAME) (POP-LINEARIZE-ASSUMPTIONS-FRAME) NIL]) (RELIEVE-HYPS-NOT-OK [LAMBDA (LIT) (* kbr: "20-Oct-85 19:32") (LET (LIT-ATOM ANS-ATOM) (SETQ LIT-ATOM LIT) (BM-MATCH LIT (NOT LIT-ATOM)) (for ANS in ANCESTORS thereis (PROGN (SETQ ANS-ATOM ANS) (BM-MATCH ANS (NOT ANS-ATOM)) (COND ((EQUAL LIT ANS) (SETQ RELIEVE-HYPS-NOT-OK-ANS T) T) ((AND (GREATEREQP (FORM-COUNT LIT-ATOM) (FORM-COUNT ANS-ATOM)) (WORSE-THAN-OR-EQUAL LIT-ATOM ANS-ATOM)) (SETQ RELIEVE-HYPS-NOT-OK-ANS NIL) T) (T NIL]) (RELIEVE-HYPS1 [LAMBDA (HYPS LEMMA-NAME) (* kbr: "20-Oct-85 19:12") (COND ((for HYP in HYPS as I from 1 bind (SPLIT-FLG CHECK-FLG LHS RHS) always (PROGN (PRINT-TO-DISPLAY LEMMA-NAME I (QUOTE ?)) (OR (SETQ SPLIT-FLG (BM-MATCH HYP (SPLIT HYP))) (SETQ CHECK-FLG (BM-MATCH HYP (CHECK HYP)))) (COND ((LOOKUP-HYP HYP) T) ((FREE-VARSP HYP UNIFY-SUBST) (COND ((AND (BM-MATCH HYP (EQUAL LHS RHS)) (VARIABLEP LHS) (NOT (ASSOC LHS UNIFY-SUBST)) (NOT (FREE-VARSP RHS UNIFY-SUBST))) (SETQ UNIFY-SUBST (CONS (CONS LHS (REWRITE RHS UNIFY-SUBST TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL)) UNIFY-SUBST))) ((SEARCH-GROUND-UNITS HYP) T) (T (SETQ LAST-EXIT (QUOTE FREE-VARSP)) NIL))) ((RELIEVE-HYPS-NOT-OK (SETQ INST-HYP (SUBLIS-VAR UNIFY-SUBST HYP))) (SETQ LAST-EXIT (QUOTE RELIEVE-HYPS-NOT-OK)) RELIEVE-HYPS-NOT-OK-ANS) ((FALSE-NONFALSEP INST-HYP) (SETQ LAST-EXIT (QUOTE FALSE-NONFALSEP)) (NOT DEFINITELY-FALSE)) ((MEMBER INST-HYP LITS-THAT-MAY-BE-ASSUMED-FALSE) (SETQ LAST-EXIT (QUOTE LITS-THAT-MAY-BE-ASSUMED-FALSE)) NIL) (SPLIT-FLG (PUSH-LINEARIZE-ASSUMPTION INST-HYP) T) (CHECK-FLG (SETQ LAST-EXIT (QUOTE CHECK-FLG)) NIL) ((BM-MATCH HYP (NOT HYP)) (LET ((ANCESTORS (CONS (DUMB-NEGATE-LIT INST-HYP) ANCESTORS))) (SETQ LAST-EXIT (REWRITE HYP UNIFY-SUBST TYPE-ALIST (QUOTE FALSE) (QUOTE IFF) NIL)) (EQUAL LAST-EXIT FALSE))) (T (LET ((ANCESTORS (CONS (DUMB-NEGATE-LIT INST-HYP) ANCESTORS))) (SETQ LAST-EXIT (REWRITE HYP UNIFY-SUBST TYPE-ALIST (QUOTE TRUE) (QUOTE IFF) NIL)) (* Could be NOT-IDENT FALSE but  LAST-EXIT was just rewritten with IFF.  *) (EQUAL LAST-EXIT TRUE))))) finally (SETQ LAST-HYP HYP)) (PRINT-TO-DISPLAY LEMMA-NAME NIL (QUOTE !)) T) (T NIL]) (REMOVE-*2*IFS [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (REST) (COND ((NLISTP X) X) ((EQ (CAR X) (QUOTE QUOTE)) X) ((EQ (CAR X) (QUOTE *2*IF)) (SETQ REST (REMOVE-*2*IFS (CADDDR X))) (CONS (QUOTE COND) (CONS (LIST (REMOVE-*2*IFS (CADR X)) (REMOVE-*2*IFS (CADDR X))) (COND ((AND (LISTP REST) (EQ (CAR REST) (QUOTE COND))) (CDR REST)) (T (LIST (LIST T REST))))))) (T (CONS (CAR X) (for ARG in (CDR X) collect (REMOVE-*2*IFS ARG]) (REMOVE-NEGATIVE [LAMBDA (LIT CL) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP CL) NIL) ((COMPLEMENTARYP LIT (CAR CL)) (CDR CL)) (T (CONS (CAR CL) (REMOVE-NEGATIVE LIT (CDR CL]) (REMOVE-REDUNDANT-TESTS [LAMBDA (TO-DO DONE) (* kbr: "19-Oct-85 16:31") (* When this function was conceived, we used to run the following code.  However, we have trivialized the effect because we found that it sometimes  hurt. In particular, if the tests were (LISTP X) and  (EQUAL (CAAR X) (QUOTE FOO)), the LISTP could get removed.  But then the LISTP has to be rederived when it comes up during a proof.  It is speculated that the original motivation for this function was messy base  cases, which was altered if not fixed by carrying around the base cases in the  INDUCTION-MACHINE. The following code is left in case a real removal of tests  is deemed necessary. (COND ((NULL TO-DO) DONE)  ((AND (SIMPLIFY-CLAUSE-MAXIMALLY (CONS (CAR TO-DO)  (APPEND (FOR X IN (CDR TO-DO) COLLECT (NEGATE-LIT X))  (FOR X IN DONE COLLECT (NEGATE-LIT X)))))  (NULL PROCESS-CLAUSES)) The lemmas on PROCESS-HIST will have been added to  ALL-LEMMAS-USED by SIMPLIFY-CLAUSE under SIMPLIFY-CLAUSE-MAXIMALLY and  ALL-LEMMAS-USED is correctly initialized and processed by DEFN-SETUP and the  post processing in DEFN. (REMOVE-REDUNDANT-TESTS  (CDR TO-DO) DONE)) (T (REMOVE-REDUNDANT-TESTS  (CDR TO-DO) (CONS (CAR TO-DO) DONE)))) . *) (APPEND TO-DO DONE]) (REMOVE1 [LAMBDA (X LST) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP LST) NIL) ((EQ X (CAR LST)) (CDR LST)) (T (CONS (CAR LST) (REMOVE1 X (CDR LST]) (REMOVE-TRIVIAL-EQUATIONS [LAMBDA (CL) (* kbr: "20-Oct-85 13:36") (* First cut down on variables by  eliminating any inequality involving a  variable LHS with a RHS that doesn't  contain LHS. *) (bind (LHS RHS) while (for LIT in CL thereis (AND (OR (AND (BM-MATCH LIT (NOT (EQUAL LHS RHS))) (OR (AND (VARIABLEP LHS) (NOT (OCCUR LHS RHS))) (AND (PROG2 (swap LHS RHS) T) (VARIABLEP LHS) (NOT (OCCUR LHS RHS))))) (AND (VARIABLEP LIT) (PROGN (SETQ LHS LIT) (SETQ RHS FALSE) T))) (PROGN (SETQ CL (for LIT2 in CL unless (EQ LIT LIT2) collect (SUBST-VAR RHS LHS LIT2))) T)))) (* Next any inequality between a LHS and a constant RHS is used to replace  occurences of LHS. (But we cannot get rid of the original inequality.) *) (bind (LHS RHS) while (for LIT in CL thereis (AND (BM-MATCH LIT (NOT (EQUAL LHS RHS))) (OR (AND (NOT (QUOTEP LHS)) (QUOTEP RHS)) (AND (PROG2 (swap LHS RHS) T) (NOT (QUOTEP LHS)) (QUOTEP RHS))) (for LIT2 in CL when (NEQ LIT LIT2) thereis (OCCUR LHS LIT2)) (SETQ CL (for LIT2 in CL collect (COND ((OR (EQ LIT LIT2) (NOT (OCCUR LHS LIT2))) LIT2) (T (SUBST-EXPR RHS LHS LIT2)))))))) CL]) (REMOVE-UNCHANGING-VARS [LAMBDA (CAND-LST CL-SET) (* kbr: "19-Oct-85 16:31") (LET (NOT-CHANGING-VARS) (SETQ NOT-CHANGING-VARS (for CL in CL-SET bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (for LIT in CL bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (UNCHANGING-VARS LIT) LOOP-ANS)) finally (RETURN LOOP-ANS)) LOOP-ANS)) finally (RETURN LOOP-ANS))) (OR (for CAND in CAND-LST unless (INTERSECTP (fetch (CANDIDATE CHANGED-VARS) of CAND) NOT-CHANGING-VARS) collect CAND) CAND-LST]) (REMPROP1 [LAMBDA (AT PROP) (* kbr: "19-Oct-85 16:31") AT PROP (ERROR1 (PQUOTE (PROGN IT IS NOT PERMITTED TO USE REMPROP1 ON PROPERTIES MAINTAINED BY PUT1 AND GETPROP !)) (BINDINGS) (QUOTE HARD]) (RESTART [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (REDO-UNDONE-EVENTS (OR X UNDONE-EVENTS) T (QUOTE Q) NIL NIL NIL]) (RESTART-BATCH [LAMBDA (LST) (* kbr: "19-Oct-85 16:31") (PROG NIL (SETQ UNDONE-BATCH-COMMANDS LST) TOP (COND ((NULL UNDONE-BATCH-COMMANDS) (RETURN NIL))) (EVAL (CAR UNDONE-BATCH-COMMANDS)) (SETQ UNDONE-BATCH-COMMANDS (CDR UNDONE-BATCH-COMMANDS)) (GO TOP]) (REWRITE [LAMBDA (TERM ALIST TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG) (* kbr: " 4-Jul-86 16:41") (* Returns a term that is equal (modulo ID-IFF) to the result of substituting  ALIST into TERM under the hypotheses of (a) TYPE-ALIST,  (b) the conjunction of the top frame of LINEARIZE-ASSUMPTIONS-STACK,  (c) and (d) some subset S of SIMPLIFY-CLAUSE-POT-LST such that if ITIMES IEQP  (LIST (QUOTE MARK)) is MEMB the LEMMAS field of some poly in S, then ITIMES is  a member of the top frame of the LEMMA-STACK.  *) (* DEFN-FLG = T if TERM is the body of  a definition that is being opened.  *) (COND ((VARIABLEP TERM) (REWRITE-SOLIDIFY (COND ((SETQ TEMP-TEMP (ASSOC TERM ALIST)) (CDR TEMP-TEMP)) (T TERM)))) ((FQUOTEP TERM) TERM) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (REWRITE-IF (REWRITE (FARGN TERM 1) ALIST TYPE-ALIST (QUOTE ?) (QUOTE IFF) NIL) (FARGN TERM 2) (FARGN TERM 3) TYPE-ALIST)) ((SETQ TEMP-TEMP (NOT-TO-BE-REWRITTENP TERM ALIST)) (REWRITE-SOLIDIFY TEMP-TEMP)) (T (LET (ARGS FN TEMP) (* If we are inside of a defn, rewrite the args and then simplify the resulting  term with lemmas etc. If we are not in a definition, we wish to avoid  introducing too many IFs all at once and swamping CLAUSIFY.  So rewrite the args until one of them gets an IF in it.  After the first such IF, rewrite the args but if an IF shows up do not use the  expansion -- use the result of just substituting alist into the arg.  *) (SETQ ARGS (for ARG in (FARGS TERM) collect (REWRITE ARG ALIST TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL))) (COND ((AND (for ARG in ARGS always (QUOTEP ARG)) (SETQ FN (GETPROP (FFN-SYMB TERM) (QUOTE LISP-CODE))) (NEQ (QUOTE *1*FAILED) (SETQ TEMP (APPLY FN (for ARG in ARGS collect (CADR ARG)))))) (PUSH-LEMMA (FFN-SYMB TERM)) (LIST (QUOTE QUOTE) TEMP)) (T (* The use of FCONS-TERM below is  justified by the immediately preceding  computation. *) (SETQ TEMP (REWRITE-TYPE-PRED (FCONS-TERM (FFN-SYMB TERM) ARGS))) (REWRITE-WITH-LEMMAS TEMP]) (REWRITE-FNCALL [LAMBDA (*FNNAME* *ARGLIST*) (* kbr: " 4-Jul-86 16:41") (LET (VALUE SDEFN (FNSTACK FNSTACK) *CONTROLLER-COMPLEXITIES* (LEMMA-STACK LEMMA-STACK) (LINEARIZE-ASSUMPTIONS-STACK LINEARIZE-ASSUMPTIONS-STACK) (*TYPE-ALIST* TYPE-ALIST) ANSWER) (SETQ SDEFN (GETPROP *FNNAME* (QUOTE SDEFN))) (SETQ ANSWER (COND ((NULL SDEFN) (REWRITE-SOLIDIFY (CONS-TERM *FNNAME* *ARGLIST*))) ((OR (MEMB *FNNAME* FNSTACK) (DISABLEDP *FNNAME*)) (REWRITE-SOLIDIFY (CONS-TERM *FNNAME* *ARGLIST*))) (T (SETQ *CONTROLLER-COMPLEXITIES* (for MASK in (GETPROP *FNNAME* (QUOTE CONTROLLER-POCKETS)) collect (for ARG in *ARGLIST* when (PROG1 (NOT (IEQP (LOGAND MASK 1) 0)) (SETQ MASK (LSH MASK -1))) sum (OR (QUOTEP ARG) (SETQ VALUE NIL)) (MAX-FORM-COUNT ARG)))) (SETQ FNSTACK (CONS *FNNAME* FNSTACK)) (* Add the name of the current fn to the FNSTACK so that when we see recursive  calls in the body we won't be tempted to go into them.  There is an odd aspect to the use of FNSTACK by this function.  Suppose that in the rewriting of the body of fn we apply a lemma and backwards  chain to some hyp. Suppose the hyp contains a call of fn.  Then when we try to rewrite fn in the hyp we will think it is a recursive call  and quit due to the (MEMB *FNNAME* FNSTACK) above.  Once upon a time, when we did not preprocess the hyps of lemmas at all and did  not EXPAND-BOOT-STRAP-NON-REC-FNS in defns this problem burned us on  (ZEROP expr) because inside the defn of ZEROP we saw  (EQUAL expr 0) and we backward chained to something with a ZEROP hyp and shied  away from it. This occurred while trying to use LITTLE-STEP under PRIME-KEY  under QUOTIENT-DIVIDES in the proof of PRIME-LIST-TIMES-LIST --  the ZEROP we were expanding was that in the DIVIDES hyp of PRIME-KEY and the  ZEROP we shied away from was that in PRIME in LITTLE-STEP.  We implemented makeshift fix to that by not putting nonrec fns onto FNSTACK  here. But that does not prevent us from shying away from calls to recursive fns  encountered in lemmas while somehow under the body of the fn.  Worse, it turns out to be very expensive.  Suppose we eliminate ZEROP by expanding it in preprocessing.  Then PRIME-LIST-TIMES-LIST is proved whether we put nonrec fns onto the stack  or not. But if we do not, it takes 248K conses while if we do it takes 140K.  So we have gone back to putting everything on the stack and await the day that  shying away from a spurious gets us. *) (PUSH-LEMMA-FRAME) (PRINT-TO-DISPLAY *FNNAME* (QUOTE ?) NIL) (PUSH-LINEARIZE-ASSUMPTIONS-FRAME) (* Rewrite the body of the definition  *) (SETQ VALUE (REWRITE (CADDR SDEFN) (for VAR in (CADR SDEFN) as VAL in *ARGLIST* collect (CONS VAR VAL)) TYPE-ALIST OBJECTIVE ID-IFF T)) (COND ((NULL (GETPROP *FNNAME* (QUOTE INDUCTION-MACHINE))) (* We are dealing with a nonrec fn. If we are at the top level of the clause  but the expanded body has too many IFs in it compared to the number of IFs in  the args, we do not use the expanded body.  Because we know the IFs in the args will be classified out soon and we do not  want to swamp CLAUSIFY by giving it too many at once.  Otherwise we use the expanded body. *) (COND ((AND (for X in (CDR FNSTACK) never (GETPROP X (QUOTE INDUCTION-MACHINE ))) (TOO-MANY-IFS *ARGLIST* VALUE)) (POP-LEMMA-FRAME) (POP-LINEARIZE-ASSUMPTIONS-FRAME) (REWRITE-SOLIDIFY (FCONS-TERM *FNNAME* *ARGLIST*))) (T (for X in (POP-LINEARIZE-ASSUMPTIONS-FRAME) do (PUSH-LINEARIZE-ASSUMPTION X)) (PRINT-TO-DISPLAY *FNNAME* (QUOTE !) NIL) (for X in (POP-LEMMA-FRAME) do (PUSH-LEMMA X)) (PUSH-LEMMA *FNNAME*) VALUE))) ((REWRITE-FNCALLP *FNNAME* VALUE) (for X in (POP-LINEARIZE-ASSUMPTIONS-FRAME) do (  PUSH-LINEARIZE-ASSUMPTION X)) (PRINT-TO-DISPLAY *FNNAME* (QUOTE !) NIL) (for X in (POP-LEMMA-FRAME) do (PUSH-LEMMA X)) (PUSH-LEMMA *FNNAME*) VALUE) (T (POP-LEMMA-FRAME) (POP-LINEARIZE-ASSUMPTIONS-FRAME) (REWRITE-SOLIDIFY (CONS-TERM *FNNAME* *ARGLIST*))))))) (COND (NIL (NOT (EQUAL ANSWER (CONS *FNNAME* *ARGLIST*))) (SHOWPRINT (CONS *FNNAME* *ARGLIST*)) (SHOWPRINT ANSWER) (\GETKEY))) ANSWER]) (REWRITE-FNCALLP [LAMBDA (FNNAME VALUE) (* kbr: " 4-Jul-86 18:38") (* A FNNAME call can be opened to give VALUE where FNNAME may be recursively  defined. Are all the FNNAME calls in VALUE better than the original FNNAME  call? *) (COND ((VARIABLEP VALUE) T) ((FQUOTEP VALUE) T) ((EQ (FFN-SYMB VALUE) FNNAME) (* The recursive call is OK if (1) each arg of the call already occurs in some  literal of CURRENT-CL or (2) the call itself occurs in CURRENT-SIMPLIFY-CL or  (3) the actuals of the recursive call corresponding to the SUBSET of some  JUSTIFICATION for the termination of FNNAME are overall less complex than those  of the original call or (4) the actuals of the recursive call corresponding to  the SUBSET of some JUSTIFICATION for the termination of FNNAME are constant and  some actual not corresponding to a formal in the SUBSET is symbolically simpler  now than before *) (AND (OR (for ARG in (FARGS VALUE) always (for LIT in CURRENT-CL thereis (DUMB-OCCUR ARG LIT))) (for LIT in CURRENT-SIMPLIFY-CL thereis (DUMB-OCCUR VALUE LIT)) (for N in *CONTROLLER-COMPLEXITIES* as MASK in (GETPROP FNNAME (QUOTE CONTROLLER-POCKETS )) thereis (LESSP (for ARG in (FARGS VALUE) when (PROG1 (NOT (IEQP (LOGAND MASK 1) 0)) (SETQ MASK (LSH MASK -1))) sum (MAX-FORM-COUNT ARG)) N)) (for MASK in (GETPROP FNNAME (QUOTE CONTROLLER-POCKETS)) bind TEMP thereis (PROGN (SETQ TEMP MASK) (* Is there a controller pocket such  that all the controllers are constant  and some non controller is  symbolically simpler now than before?  *) (AND (for ARG in (FARGS VALUE) when (PROG1 (NOT (IEQP (LOGAND TEMP 1) 0)) (SETQ TEMP (LSH TEMP -1))) always (QUOTEP ARG)) (for ARG1 in *ARGLIST* as ARG2 in (FARGS VALUE) thereis (AND (PROG1 (IEQP (LOGAND MASK 1) 0) (SETQ MASK (LSH MASK -1))) (LESSP (MAX-FORM-COUNT ARG2) (MAX-FORM-COUNT ARG1)))))))) (for ARG in (FARGS VALUE) always (REWRITE-FNCALLP FNNAME ARG)))) (T (for ARG in (FARGS VALUE) always (REWRITE-FNCALLP FNNAME ARG]) (REWRITE-IF [LAMBDA (TEST LEFT RIGHT TYPE-ALIST) (* kbr: "29-Jun-86 18:02") (* Rewrites the term  (IF TEST LEFT RIGHT) *) (COND ((AND (NVARIABLEP TEST) (NOT (FQUOTEP TEST)) (EQ (FFN-SYMB TEST) (QUOTE IF)) (EQUAL (FARGN TEST 2) FALSE) (FALSE-NONFALSEP (FARGN TEST 3)) (NOT DEFINITELY-FALSE)) (* Note: FALSE-NONFALSEP sets  DEFINITELY-FALSE *) (* Change (IF (IF P FALSE TRUE) LEFT  RIGHT) to (IF P RIGHT LEFT) *) (swap LEFT RIGHT) (SETQ TEST (FARGN TEST 1)))) (ASSUME-TRUE-FALSE TEST) (COND (MUST-BE-TRUE (JUMPOUTP LEFT (REWRITE LEFT ALIST TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG))) (MUST-BE-FALSE (JUMPOUTP RIGHT (REWRITE RIGHT ALIST TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG))) (T (REWRITE-IF1 TEST (JUMPOUTP LEFT (LET (FALSE-TYPE-ALIST) (REWRITE LEFT ALIST TRUE-TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG))) (JUMPOUTP RIGHT (REWRITE RIGHT ALIST FALSE-TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG]) (REWRITE-IF1 [LAMBDA (TEST LEFT RIGHT) (* kbr: "29-Jun-86 18:02") (* Called by REWRITE-IF to rewrite  (IF TEST LEFT RIGHT) *) (COND ((EQUAL LEFT RIGHT) (* Change (IF TEST P P) to P *) LEFT) ((AND (EQUAL TEST LEFT) (FALSE-NONFALSEP RIGHT) DEFINITELY-FALSE) (* Change (IF P P FALSE) to P *) TEST) ((AND (EQUAL TRUE LEFT) (FALSE-NONFALSEP RIGHT) DEFINITELY-FALSE (BOOLEAN TEST)) (* Change (IF TEST TRUE FALSE) to TEST  if TEST is a boolean *) TEST) (T (FCONS-TERM* (QUOTE IF) TEST LEFT RIGHT]) (REWRITE-LINEAR-CONCL [LAMBDA (CONCL) (* kbr: "19-Oct-85 16:31") (* We desire to rewrite the instantiated conclusion of linear lemmas before  adding them to the linear pot. However, because all of the literals of the  clause being proved are on the TYPE-ALIST as false, it is possible --  say when proving an instance of an already proved linear lemma --  to rewrite the conclusion to F! We could avoid this by either not putting the  linear-like literals on the type alist in the first place, or by not rewriting  the entire conclusion, just the args. We took the latter approach because it  was simplest. It does suffer from the possibility that the whole  (LESSP lhs rhs) of the conclusion might rewrite to something else, possibly a  better LESSP. *) (LET (LHS RHS) (COND ((BM-MATCH CONCL (LESSP LHS RHS)) (FCONS-TERM* (QUOTE LESSP) (REWRITE LHS UNIFY-SUBST TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL) (REWRITE RHS UNIFY-SUBST TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL))) ((BM-MATCH CONCL (NOT (LESSP LHS RHS))) (FCONS-TERM* (QUOTE NOT) (FCONS-TERM* (QUOTE LESSP) (REWRITE LHS UNIFY-SUBST TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL) (REWRITE RHS UNIFY-SUBST TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL)))) (T (ERROR1 (PQUOTE (PROGN REWRITE-LINEAR-CONCL THOUGHT THAT ALL LINEAR LEMMAS HAD CONCLUSIONS WITH NLISTP LESSP !)) NIL (QUOTE HARD]) (REWRITE-SOLIDIFY [LAMBDA (TERM) (* kbr: "29-Jun-86 17:43") (* Rewrites TERM with the context  supplied by TYPE-ALIST *) (LET (LIT TEMP LHS RHS) (COND ((QUOTEP TERM) TERM) ((AND (NVARIABLEP TERM) (EQ (FFN-SYMB TERM) (QUOTE IF))) (* See the proof in JUMPOUTP.  *) TERM) ((for PAIR in TYPE-ALIST thereis (AND (IEQP (CDR PAIR) TYPE-SET-TRUE) (BM-MATCH (CAR PAIR) (EQUAL LHS RHS)) (EQUAL LHS TERM))) (* If TERM is equal to the LHS of a  true equality then TERM rewrites to  the RHS of the equality.  *) RHS) ((AND (SETQ TEMP-TEMP (SASSOC TERM TYPE-ALIST)) (SETQ TEMP (OBJ-TABLE (CDR TEMP-TEMP) OBJECTIVE ID-IFF))) (* If the TERM is in the TYPE-ALIST as  true or false then return true or  false. *) TEMP) ((SETQ LIT (for LIT in LITS-THAT-MAY-BE-ASSUMED-FALSE when (COND ((EQUAL LIT TERM) (SETQ TEMP FALSE)) ((COMPLEMENTARYP LIT TERM) (SETQ TEMP TRUE)) (T NIL)) do (RETURN LIT))) (COND ((OR (EQ ID-IFF (QUOTE IFF)) (EQ TEMP FALSE) (BOOLEAN TERM)) (PUSH-LEMMA LIT) TEMP) (T TERM))) (T TERM]) (REWRITE-TYPE-PRED [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (LHS RHS PAIR TYPE-SET) (COND ((OR (VARIABLEP TERM) (FQUOTEP TERM)) TERM) ((BM-MATCH TERM (EQUAL LHS RHS)) (COND ((EQUAL LHS RHS) TRUE) ((NOT-IDENT LHS RHS) FALSE) ((AND (BOOLEAN LHS) (EQUAL TRUE RHS)) LHS) ((AND (BOOLEAN RHS) (EQUAL TRUE LHS)) RHS) ((BM-MATCH RHS (EQUAL & &)) (FCONS-TERM* (QUOTE IF) RHS (FCONS-TERM* (QUOTE EQUAL) LHS TRUE) (FCONS-TERM* (QUOTE IF) LHS FALSE TRUE))) ((EQUAL LHS FALSE) (FCONS-TERM* (QUOTE IF) RHS FALSE TRUE)) ((EQUAL RHS FALSE) (FCONS-TERM* (QUOTE IF) LHS FALSE TRUE)) ((BM-MATCH LHS (EQUAL & &)) (FCONS-TERM* (QUOTE IF) LHS (FCONS-TERM* (QUOTE EQUAL) RHS TRUE) (FCONS-TERM* (QUOTE IF) RHS FALSE TRUE))) ((AND (SETQ TYPE-SET (TYPE-SET LHS)) (for X in RECOGNIZER-ALIST thereis (IEQP TYPE-SET (CDR X))) (IEQP TYPE-SET (TYPE-SET RHS)) (NOT (BTM-OBJECT-OF-TYPE-SET TYPE-SET))) (* This piece of code was hacked together to test the idea that if you have an  (EQUAL lhs rhs) in which lhs and rhs have the same type --  and that type does not contain a btm object --  that you should rewrite it to T or F provided you can appropriately decide the  equalities of the components. Before attempting to add complete equality we did  not do anything like this and relied solely on elim to do it for us.  In the first attempt to add it to rewrite we just rewrote all such  (EQUAL lhs rhs) to the conjunction of the equalities of the components.  That was unsatisfactory because it caused such equalities as  (EQUAL (ADDTOLIST X L) B) to be torn up all the time.  That caused us to fail to prove thms like SORT-OF-ORDERED-NUMBER-LIST because  weak subgoals are pushed -- subgoals about  (CAR (ADDTOLIST X L)) and (CDR (ADDTOLIST X L)) instead about  (ADDTOLIST X L) itself. If this piece of code survives it should be cleaned up.  Two problems. We repeatedly cons up the constant  (EQUAL (CAR LHS) (CAR RHS)) and we (RETURN TERM) which works only because we  know this clause is the second to last one in the parent COND.  *) (for DEST in (CDR (ASSOC (CAR (for X in SHELL-ALIST when (IEQP TYPE-SET (LOGBIT (CDR X))) do (RETURN X))) SHELL-POCKETS)) do (SETQ TEMP-TEMP (REWRITE (FCONS-TERM* (QUOTE EQUAL) (FCONS-TERM* DEST (QUOTE LHS)) (FCONS-TERM* DEST (QUOTE RHS))) (LIST (CONS (QUOTE LHS) LHS) (CONS (QUOTE RHS) RHS)) TYPE-ALIST (QUOTE ?) (QUOTE ID) NIL)) (COND ((EQUAL TEMP-TEMP FALSE) (RETURN FALSE)) ((NOT (EQUAL TEMP-TEMP TRUE)) (RETURN TERM))) finally (RETURN TRUE))) (T TERM))) ((SETQ PAIR (ASSOC (FFN-SYMB TERM) RECOGNIZER-ALIST)) (SETQ TYPE-SET (TYPE-SET (FARGN TERM 1))) (COND ((LOGSUBSETP TYPE-SET (CDR PAIR)) TRUE) ((IEQP 0 (LOGAND TYPE-SET (CDR PAIR))) FALSE) (T TERM))) (T TERM]) (REWRITE-WITH-LEMMAS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (REWRITTEN-TERM UNIFY-SUBST TEMP INST-HYP) (COND ((VARIABLEP TERM) (REWRITE-SOLIDIFY TERM)) ((FQUOTEP TERM) TERM) ((MEMB (FFN-SYMB TERM) FNS-TO-BE-IGNORED-BY-REWRITE) TERM) ((AND (OR (NEQ (FFN-SYMB TERM) (QUOTE LESSP)) (NOT (MEMB (QUOTE LESSP) FNSTACK))) (REWRITE-WITH-LINEAR TERM))) ((for LEMMA in (GETPROP (FFN-SYMB TERM) (QUOTE LEMMAS)) unless (DISABLEDP (fetch (REWRITE-RULE NAME) of LEMMA)) thereis (COND ((META-LEMMAP LEMMA) (* The conclusion is the name of a LISP fn to apply to the term being  rewritten. To add such lemma it must be the case that the LISP function return  a TERMP such that in the current history  (EQUAL TERM val) can be proved. *) (SETQ REWRITTEN-TERM (APPLY* (fetch (REWRITE-RULE CONCL) of LEMMA) TERM)) (COND ((EQUAL REWRITTEN-TERM TERM) NIL) (T (* Because of the FORMP part of the correctness proof for user defined  metafunctions we know REWRITTEN-TERM is a TERMP.  However, we want all terms inside the theorem prover to be in quote normal form  -- all explicit values be represented with QUOTE.  We normalize REWRITTEN-TERM by applying the empty substitution to it.  When we wrote the metapaper we were uncertain whether it was essential to the  soundness of the theorem-prover that terms be in quote normal form --  however the theorem-prover could certainly be implemented so that it was not  crucial so we left this issue out of the paper.  We attempted to verify that the soundness of the current implementation did not  depend upon terms being in quote normal form, but we got very weary,  particularly because one of us could never remember what it was that we were  trying to prove. We did learn that some parts of the theorem prover that used  functions such as OCCUR would be heuristically inaccurate if terms were not in  normal form. We never discovered any situation in which terms not being in  normal form would cause unsoundness but we did not get past the C's in an  alphabetical scan. Instead, we gave up the search and decided to require that  terms be in normal form throughout the theorem-prover.  We still have not yet completed a pass through the theorem-prover checking that  normalcy is preserved, but we believe that we were thorough in the initial  *1*-reformulation of the theorem-prover --  never constructing a term except through CONS-TERM  (unless we really knew what we were doing, such as consing up an IF term in  rewrite)%. Our confidence that we were thorough during the *1*-reformulation is  based upon the existence of a comment in CONS-TERM claiming that every term had  to be in normal form. *) (PUSH-LEMMA (fetch (REWRITE-RULE NAME) of LEMMA)) (SETQ REWRITTEN-TERM (REWRITE (SUBLIS-VAR NIL REWRITTEN-TERM) NIL TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG)) T))) ((EQ (FFN-SYMB (fetch (REWRITE-RULE CONCL) of LEMMA)) (QUOTE NOT)) (COND ((AND (OR (NULL (fetch (REWRITE-RULE HYPS) of LEMMA)) (NEQ OBJECTIVE (QUOTE TRUE))) (ONE-WAY-UNIFY (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 1) TERM) (RELIEVE-HYPS (fetch (REWRITE-RULE HYPS) of LEMMA) (fetch (REWRITE-RULE NAME) of LEMMA))) (PUSH-LEMMA (fetch (REWRITE-RULE NAME) of LEMMA)) (SETQ REWRITTEN-TERM FALSE) T) (T NIL))) ((EQ (FFN-SYMB (fetch (REWRITE-RULE CONCL) of LEMMA)) (QUOTE EQUAL)) (COND ((AND (OR (NULL (fetch (REWRITE-RULE HYPS) of LEMMA)) (NEQ OBJECTIVE (QUOTE TRUE)) (NOT (EQUAL (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 2) FALSE))) (OR (NOT (MEMB (FFN-SYMB TERM) FNSTACK)) (NOT (FNNAMEP (FFN-SYMB TERM) (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 2)))) (ONE-WAY-UNIFY (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 1) TERM) (PROGN (SETQ TEMP COMMUTED-EQUALITY-FLG) T) (for PAIR in (fetch (REWRITE-RULE LOOP-STOPPER) of LEMMA) never (TERM-ORDER (CDR (ASSOC (CAR PAIR) UNIFY-SUBST)) (CDR (ASSOC (CDR PAIR) UNIFY-SUBST)))) (RELIEVE-HYPS (fetch (REWRITE-RULE HYPS) of LEMMA) (fetch (REWRITE-RULE NAME) of LEMMA))) (SETQ REWRITTEN-TERM (REWRITE (COND (TEMP (COMMUTE-EQUALITIES (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 2))) (T (FARGN (fetch (REWRITE-RULE CONCL) of LEMMA) 2))) UNIFY-SUBST TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG)) (PUSH-LEMMA (fetch (REWRITE-RULE NAME) of LEMMA)) T) ((AND (OR (NULL (fetch (REWRITE-RULE HYPS) of LEMMA)) (NEQ OBJECTIVE (QUOTE FALSE))) (EQ (FFN-SYMB TERM) (QUOTE EQUAL)) (ONE-WAY-UNIFY (fetch (REWRITE-RULE CONCL) of LEMMA) TERM) (RELIEVE-HYPS (fetch (REWRITE-RULE HYPS) of LEMMA) (fetch (REWRITE-RULE NAME) of LEMMA))) (PUSH-LEMMA (fetch (REWRITE-RULE NAME) of LEMMA)) (SETQ REWRITTEN-TERM TRUE) T) (T NIL))) ((AND (OR (NULL (fetch (REWRITE-RULE HYPS) of LEMMA)) (NEQ OBJECTIVE (QUOTE FALSE))) (OR (EQ ID-IFF (QUOTE IFF)) (BOOLEAN TERM)) (ONE-WAY-UNIFY (fetch (REWRITE-RULE CONCL) of LEMMA) TERM)) (COND ((RELIEVE-HYPS (fetch (REWRITE-RULE HYPS) of LEMMA) (fetch (REWRITE-RULE NAME) of LEMMA)) (PUSH-LEMMA (fetch (REWRITE-RULE NAME) of LEMMA)) (SETQ REWRITTEN-TERM TRUE) T) (T NIL))) (T NIL))) REWRITTEN-TERM) ((MEMBER TERM EXPAND-LST) (* If we have been told to expand this term, do it.  We used to do this inside of REWRITE-FNCALL, but there to avoid jumping out  when we hit unapproved recursive calls we just substituted the actuals into the  body and returned that. This seems neater.  *) (SETQ TEMP (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN))) (PUSH-LEMMA (FFN-SYMB TERM)) (REWRITE (CADDR TEMP) (for V in (CADR TEMP) as X in (FARGS TERM) collect (CONS V X)) TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG)) (T (SETQ TEMP (REWRITE-FNCALL (FFN-SYMB TERM) (FARGS TERM))) (COND ((EQUAL TEMP TERM) TERM) ((CONTAINS-REWRITEABLE-CALLP (FFN-SYMB TERM) TEMP) (REWRITE TEMP NIL TYPE-ALIST OBJECTIVE ID-IFF DEFN-FLG)) (T TEMP]) (REWRITE-WITH-LINEAR [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (PROG (ANS TEMP) (SETQ TEMP TERM) (BM-MATCH TEMP (NOT TEMP)) (* TEMP is the atom of TERM.  *) (COND ((AND (NOT (BM-MATCH TEMP (LESSP & &))) (NOT (BM-MATCH TEMP (EQUAL & &)))) NIL) ((EQ OBJECTIVE (QUOTE ?)) (* We tried rewriting with linear under the objective ?, and it cost us 4  million conses over a proveall, so we stopped rewriting with linear under the  objective ?. We found that too restrictive, and experimented with the idea of  only rewriting with linear under ? when ANCESTORS is nonNIL, i.e., when we are  working on a term that may appear as part of the simplification of the theorem  as opposed to a term that appears while rewriting the hypothesis of a rewrite  rule. That cost us 5 times more conses on the theorem it was designed to prove!  So we have abandoned linear under ? altogether, again.  Here, however is the most recent experimental code:  (COND ((AND (NULL ANCESTORS) (EQ (ADD-TERM-TO-POT-LST TERM  SIMPLIFY-CLAUSE-POT-LST NIL NIL) (QUOTE CONTRADICTION)))  (SETQ ANS TRUE) (GO WIN))) (COND ((AND (NULL ANCESTORS)  (EQ (ADD-TERM-TO-POT-LST TERM SIMPLIFY-CLAUSE-POT-LST T NIL)  (QUOTE CONTRADICTION))) (SETQ ANS FALSE)  (GO WIN))) *) NIL) ((EQ OBJECTIVE (QUOTE TRUE)) (COND ((EQ (ADD-TERM-TO-POT-LST TERM SIMPLIFY-CLAUSE-POT-LST NIL NIL) (QUOTE CONTRADICTION)) (SETQ ANS TRUE) (GO WIN)))) (T (COND ((EQ (ADD-TERM-TO-POT-LST TERM SIMPLIFY-CLAUSE-POT-LST T NIL) (QUOTE CONTRADICTION)) (SETQ ANS FALSE) (GO WIN))))) (RETURN NIL) WIN (for X in LEMMAS-USED-BY-LINEAR do (PUSH-LEMMA X)) (PUSH-LEMMA (QUOTE ZERO)) (for X in LINEAR-ASSUMPTIONS do (PUSH-LINEARIZE-ASSUMPTION X)) (RETURN ANS]) (RPLACAI [LAMBDA (LIST I X) (* kbr: "19-Oct-85 16:31") (COND ((IEQP I 1) (RPLACA (OR LIST (CONS NIL NIL)) X)) (T (RPLACD (OR LIST (CONS NIL NIL)) (RPLACAI (CDR LIST) (SUB1 I) X]) ) (RPAQQ CODE-S-ZCOMS ((* CODE-S-Z *) (FNS S SARGS SCONS-TERM SCRUNCH SCRUNCH-CLAUSE SCRUNCH-CLAUSE-SET SEARCH-GROUND-UNITS SEQUENTIAL-DIFFERENCE SET-DIFF SET-DIFF-N SET-EQUAL SET-SIMPLIFY-CLAUSE-POT-LST SETTLED-DOWN-CLAUSE SETTLED-DOWN-SENT SETUP SETUP-META-NAMES SHELL-CONSTRUCTORP SHELL-DESTRUCTOR-NESTP SHELL-OCCUR SHELL-OCCUR1 SHELLP SIMPLIFY-CLAUSE SIMPLIFY-CLAUSE-MAXIMALLY SIMPLIFY-CLAUSE-MAXIMALLY1 SIMPLIFY-CLAUSE0 SIMPLIFY-CLAUSE1 SIMPLIFY-LOOP SIMPLIFY-SENT SINGLETON-CONSTRUCTOR-TO-RECOGNIZER SKO-DEST-NESTP SOME-SUBTERM-WORSE-THAN-OR-EQUAL SORT-DESTRUCTOR-CANDIDATES SOUND-IND-PRIN-MASK STACK-DEPTH START-STATS STOP-STATS STORE-SENT STRIP-BRANCHES STRIP-BRANCHES1 SUB-SEQUENCEP SUBBAGP SUBLIS-EXPR SUBLIS-EXPR1 SUBLIS-VAR SUBLIS-VAR-LST SUB-PAIR-EXPR SUB-PAIR-EXPR-LST SUB-PAIR-EXPR1 SUB-PAIR-VAR SUB-PAIR-VAR-LST SUBST-EXPR SUBST-EXPR-ERROR1 SUBST-EXPR-LST SUBST-EXPR1 SUBST-FN SUBST-VAR SUBST-VAR-LST BM-SUBST SUBSUMES SUBSUMES-REWRITE-RULE SUBSUMES1 SUBSUMES11 SUM-STATS-ALIST TABULATE TERM-ORDER TERMINATION-MACHINE TP-EXPLODEN1 TP-GETCHARN1 TP-IMPLODE1 TO-BE-IGNOREDP TOO-MANY-IFS TOP-FNNAME TOTAL-FUNCTIONP TRANSITIVE-CLOSURE TRANSLATE TRANSLATE-TO-LISP TREE-DEPENDENTS TRIVIAL-POLYP TRIVIAL-POLYP1 TRUE-POLYP TYPE-ALIST-CLAUSE TYPE-PRESCRIPTION-LEMMAP TYPE-SET TYPE-SET2 UBT UNBREAK-LEMMA UNCHANGING-VARS UNCHANGING-VARS1 UNDO-BACK-THROUGH UNDO-NAME UNION-EQUAL UNPRETTYIFY VARIANTP WORSE-THAN WORSE-THAN-OR-EQUAL WRAPUP XXXJOIN ZERO-POLY))) (* CODE-S-Z *) (DEFINEQ (S [LAMBDA (VAR VAL) (* kbr: "19-Oct-85 16:31") (COND ((NOT (ERRSET (SETQ TEMP-TEMP (TRANSLATE VAR)))) NIL) ((OR (NEQ VAR TEMP-TEMP) (NOT (VARIABLEP VAR))) (QUOTE (NOT VARIABLEP))) ((NOT (ERRSET (SETQ VAL (TRANSLATE VAL)))) NIL) ((NOT (QUOTEP VAL)) (QUOTE (NOT QUOTEP))) (T (SETQ TEMP-TEMP (OR (ASSOC VAR R-ALIST) (CAR (SETQ R-ALIST (CONS (CONS VAR VAL) R-ALIST))))) (RPLACD TEMP-TEMP (CADR VAL)) VAR]) (SARGS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((NEQ (CAR TERM) (QUOTE QUOTE)) (CDR TERM)) ((LITATOM (CADR TERM)) (COND ((EQ (CADR TERM) *1*T) NIL) ((EQ (CADR TERM) *1*F) NIL) (T (LIST (LIST (QUOTE QUOTE) (DTACK-0-ON-END (CHCON (CADR TERM)))))))) ((FIXP (CADR TERM)) (COND ((LESSP (CADR TERM) 0) (LIST (LIST (QUOTE QUOTE) (MINUS (CADR TERM))))) ((EQUAL (CADR TERM) 0) NIL) (T (LIST (LIST (QUOTE QUOTE) (SUB1 (CADR TERM))))))) ((EQ (CAR (CADR TERM)) *1*SHELL-QUOTE-MARK) (for X in (CDDR (CADR TERM)) collect (LIST (QUOTE QUOTE) X))) (T (LIST (LIST (QUOTE QUOTE) (CAR (CADR TERM))) (LIST (QUOTE QUOTE) (CDR (CADR TERM]) (SCONS-TERM [LAMBDA (FN ARGS) (* kbr: "19-Oct-85 16:31") (COND ((EQ FN (QUOTE EQUAL)) (COND ((EQUAL (CAR ARGS) (CADR ARGS)) TRUE) ((AND (QUOTEP (CAR ARGS)) (QUOTEP (CADR ARGS))) FALSE) (T (CONS (QUOTE EQUAL) ARGS)))) (T (CONS-TERM FN ARGS]) (SCRUNCH [LAMBDA (L) (* kbr: " 4-Jul-86 18:10") (* Setifies list L *) (for TAIL on L unless (MEMBER (CAR TAIL) (CDR TAIL)) collect (CAR TAIL]) (SCRUNCH-CLAUSE [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (for TAIL on CL unless (OR (AND (FALSE-NONFALSEP (CAR TAIL)) DEFINITELY-FALSE) (MEMBER (CAR TAIL) (CDR TAIL))) collect (CAR TAIL]) (SCRUNCH-CLAUSE-SET [LAMBDA (CLAUSES) (* kbr: "19-Oct-85 16:31") (TRANSITIVE-CLOSURE (for CL in CLAUSES collect (SCRUNCH-CLAUSE CL)) (FUNCTION (LAMBDA (CL1 CL2) (COND ((SUBSETP CL1 CL2) CL1) ((SUBSETP CL2 CL1) CL2) (T NIL]) (SEARCH-GROUND-UNITS [LAMBDA (HYP) (* kbr: "19-Oct-85 16:31") (* Like LOOKUP-HYP except looks  through ground unit REWRITE lemmas.  *) (PROG (TERM FN REWRITE-RULE) (COND ((BM-MATCH HYP (NOT TERM)) (COND ((VARIABLEP TERM) (RETURN NIL)) ((FQUOTEP TERM) (RETURN (EQUAL TERM FALSE))) (T (SETQ FN (FFN-SYMB TERM))))) ((VARIABLEP HYP) (RETURN NIL)) ((FQUOTEP HYP) (RETURN (NOT (EQUAL HYP FALSE)))) (T (SETQ FN (FFN-SYMB HYP)))) (COND ((SETQ REWRITE-RULE (for REWRITE-RULE in (GET1 FN (QUOTE LEMMAS)) when (AND (NOT (DISABLEDP (fetch (REWRITE-RULE NAME) of REWRITE-RULE ))) (NOT (META-LEMMAP REWRITE-RULE)) (NOT (fetch (REWRITE-RULE HYPS) of REWRITE-RULE)) (NOT (FREE-VARSP (fetch (REWRITE-RULE CONCL) of REWRITE-RULE) NIL)) (ONE-WAY-UNIFY1 HYP (fetch (REWRITE-RULE CONCL) of REWRITE-RULE))) do (RETURN REWRITE-RULE))) (PUSH-LEMMA (fetch (REWRITE-RULE NAME) of REWRITE-RULE)) (RETURN T)) (T (RETURN NIL]) (SEQUENTIAL-DIFFERENCE [LAMBDA (SMALLER LARGER) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP SMALLER) LARGER) ((NLISTP LARGER) (QUOTE NOT-RELATED)) ((EQUAL (CAR SMALLER) (CAR LARGER)) (SEQUENTIAL-DIFFERENCE (CDR SMALLER) (CDR LARGER))) (T (SETQ TEMP-TEMP (SEQUENTIAL-DIFFERENCE SMALLER (CDR LARGER))) (COND ((EQ TEMP-TEMP (QUOTE NOT-RELATED)) (QUOTE NOT-RELATED)) (T (CONS (CAR LARGER) TEMP-TEMP]) (SET-DIFF [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (for ELE in X unless (MEMBER ELE Y) collect ELE]) (SET-DIFF-N [LAMBDA (BIG LITTLE N) (* kbr: "19-Oct-85 16:31") (COND ((ZEROP N) NIL) ((NLISTP BIG) (ERROR1 (PQUOTE (PROGN SET-DIFF-N CALLED WITH INAPPROPRIATE ARGUMENTS %.)) (BINDINGS) (QUOTE HARD))) ((MEMB (CAR BIG) LITTLE) (SET-DIFF-N (CDR BIG) LITTLE N)) (T (CONS (CAR BIG) (SET-DIFF-N (CDR BIG) LITTLE (SUB1 N]) (SET-EQUAL [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (AND (SUBSETP X Y) (SUBSETP Y X]) (SET-SIMPLIFY-CLAUSE-POT-LST [LAMBDA (CL HEURISTIC-TYPE-ALIST) (* kbr: "19-Oct-85 16:31") (* We use the same basic pot list for all the calls REWRITE for a given clause.  However, to keep from biting our tail, we must know which literals each poly  descends from and avoid the polys descending from the negation of our current  lit. In order to keep track of which literals are being used we set TYPE-ALIST  to NIL before setting up the pot list, and use the special hacks  LITS-THAT-MAY-BE-ASSUMED-FALSE and HEURISTIC-TYPE-ALIST.  The pot list we thus construct is immediately tested against CONTRADICTION to  see if CL is a consequence of linear. However, the failure to use everything we  know has burned us here. In particular, the type alist might contain an  equality that could be used as a rewrite rule to help us establish the  hypothesis of some needed lemma. Imagine for example that the clause contains  b=a and p (a) as hyps and we need to prove p  (b) to get some lemma. We try to handle this as follows.  After setting up SIMPLIFY-CLAUSE-POT-LST --  the pot list we will use subsequently and which has all the dependencies  carefully tracked -- we go at the pot list again with the ALL-NEW-FLG of  ADD-TERMS-TO-POT-LST set to T. This causes us to treat every addend in the pot  list as new and reconsider the adding of all the lemmas.  If this produces CONTRADICTION, we win. If not, we pretend we did not do it --  since the resulting pot list has hidden dependencies in it.  *) (LET ((LITS-THAT-MAY-BE-ASSUMED-FALSE CL) (TYPE-ALIST NIL)) (SETQ SIMPLIFY-CLAUSE-POT-LST (ADD-TERMS-TO-POT-LST CL NIL NIL NIL)) (COND ((NEQ SIMPLIFY-CLAUSE-POT-LST (QUOTE CONTRADICTION)) (SETQ TYPE-ALIST HEURISTIC-TYPE-ALIST) (COND ((EQ (ADD-TERMS-TO-POT-LST NIL SIMPLIFY-CLAUSE-POT-LST NIL T) (QUOTE CONTRADICTION)) (SETQ SIMPLIFY-CLAUSE-POT-LST (QUOTE CONTRADICTION)))))) NIL]) (SETTLED-DOWN-CLAUSE [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (COND ((ASSOC (QUOTE SETTLED-DOWN-CLAUSE) HIST) NIL) (T (SETQ PROCESS-HIST NIL) (SETQ PROCESS-CLAUSES (LIST CL)) T]) (SETTLED-DOWN-SENT [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (EXECUTE (QUOTE SETTLED-DOWN-CLAUSE) CL HIST (QUOTE SIMPLIFY-SENT) (QUOTE ELIMINATE-DESTRUCTORS-SENT]) (SETUP [LAMBDA (FORM CLAUSES LEMMAS) (* kbr: "19-Oct-85 16:31") (SETQ ORIGTHM FORM) (COND ((NOT (MEMBER ORIGTHM FAILED-THMS)) (SETQ FAILED-THMS (CONS ORIGTHM FAILED-THMS)))) (SETQ EXPAND-LST HINTED-EXPANSIONS) (SETQ TERMS-TO-BE-IGNORED-BY-REWRITE NIL) (SETQ INDUCTION-HYP-TERMS NIL) (SETQ INDUCTION-CONCL-TERMS NIL) (SETQ ALL-LEMMAS-USED LEMMAS) (SETQ STACK NIL) (SETQ FNSTACK NIL) (SETQ LAST-PRINT-CLAUSES NIL) (SETQ TYPE-ALIST NIL) (SETQ LITS-THAT-MAY-BE-ASSUMED-FALSE NIL) (SETQ CURRENT-LIT 0) (SETQ CURRENT-ATM 0) (SETQ ANCESTORS NIL) (INIT-LEMMA-STACK) (INIT-LINEARIZE-ASSUMPTIONS-STACK) (SETQ LAST-PRINEVAL-CHAR NIL) (RANDOM-INITIALIZATION ORIGTHM) (IO (QUOTE SETUP) (LIST ORIGTHM) NIL CLAUSES LEMMAS]) (SETUP-META-NAMES [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (ADD-FACT (QUOTE MEANING) (QUOTE LEMMAS) (create REWRITE-RULE NAME _ (QUOTE MEANING) CONCL _ (QUOTE MEANING-SIMPLIFIER))) (ADD-FACT (QUOTE FORMP) (QUOTE LEMMAS) (create REWRITE-RULE NAME _ (QUOTE FORMP) CONCL _ (QUOTE FORMP-SIMPLIFIER]) (SHELL-CONSTRUCTORP [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) (T (ASSOC (FN-SYMB TERM) SHELL-ALIST]) (SHELL-DESTRUCTOR-NESTP [LAMBDA (VAR TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (EQ VAR TERM)) ((FQUOTEP TERM) NIL) (T (AND (for POCKET in SHELL-POCKETS thereis (MEMB (FFN-SYMB TERM) (CDR POCKET))) (SHELL-DESTRUCTOR-NESTP VAR (FARGN TERM 1]) (SHELL-OCCUR [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (* Returns T if TERM1 properly occurs in a nest of shells TERM2.  That is whether TERM1 occurs as an arg at some depth in the shell TERM2, and  that the chain of shells from the occurrence to TERM1 all the way up to the top  of TERM2 is properly typed. See the comment in SHELL-OCCUR1.  Does not bother to do anything if TERM1 is a SHELLP, because  (assuming the terms are coming from EQUAL expressions) the two shells would be  either different and we wouldn't be here, or the same, in which case they would  be rewritten. At the moment the only fn to call SHELL-OCCUR is NOT-IDENT and we  only use NOT-IDENT to decide EQUALs or else one of the two terms is FALSE.  *) (LET (TYPE-SET-TERM1) (COND ((SHELLP TERM1) NIL) ((VARIABLEP TERM2) NIL) ((FQUOTEP TERM2) NIL) ((ASSOC (FFN-SYMB TERM2) SHELL-ALIST) (SETQ TYPE-SET-TERM1 (TYPE-SET TERM1)) (for ARG in (FARGS TERM2) as TR in (GET1 (FFN-SYMB TERM2) (QUOTE TYPE-RESTRICTIONS)) thereis (AND (SETQ TEMP-TEMP (SHELL-OCCUR1 TERM1 ARG)) (LOGSUBSETP TEMP-TEMP (fetch (TYPE-RESTRICTION TYPE-SET) of TR))))) (T NIL]) (SHELL-OCCUR1 [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (* This function wants to see whether TERM1 occurs as an arg to a shell in  TERM2. However, because of type restrictions, one must not be fooled into  thinking that, for example, (ADD1 0) occurs inside of  (ADD1 (CONS (ADD1 0) NIL)) despite the fact that it occurs as an arg to a  shell. The basic idea is that TERM1 must either be TERM2 or else must  shell-occur inside the shell TERM2 -- in a spot of the right type.  Thus, one way to compute it would be to see if TERM1 shell-occurred in an arg  position of shell TERM2 and if so to then determine if the typeset of the arg  was suitable. However, that would involve either a general purpose call on  typeset or else looking ahead to see whether the arg in which TERM1 occurred  was itself a shell -- in which case its typeset is just on its  type-prescription -- or was a TERM1 occurrence itself --  in which case a full blown typeset is necessary.  Rather than do it that way we have fixed SHELL-OCCUR1 so that it returns the  typeset of TERM2 if an occurrence was found, and otherwise NIL.  *) (COND ((EQUAL TERM1 TERM2) TYPE-SET-TERM1) ((VARIABLEP TERM2) NIL) ((FQUOTEP TERM2) NIL) ((AND (ASSOC (FFN-SYMB TERM2) SHELL-ALIST) (for ARG in (FARGS TERM2) as TR in (GET1 (FFN-SYMB TERM2) (QUOTE TYPE-RESTRICTIONS)) thereis (AND (SETQ TEMP-TEMP (SHELL-OCCUR1 TERM1 ARG)) (LOGSUBSETP TEMP-TEMP (fetch (TYPE-RESTRICTION TYPE-SET) of TR))))) (CAR (TYPE-PRESCRIPTION (FFN-SYMB TERM2)))) (T NIL]) (SHELLP [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) T) (T (OR (MEMB (FFN-SYMB TERM) *1*BTM-OBJECTS) (ASSOC (FFN-SYMB TERM) SHELL-ALIST]) (SIMPLIFY-CLAUSE [LAMBDA (CURRENT-SIMPLIFY-CL HIST) (* kbr: "19-Oct-85 22:43") (* If T is returned, then the conjunction of PROCESS-CLAUSES implies  CURRENT-SIMPLIFY-CL. Equivalently, if T is returned, then under the assumption  that CURRENT-SIMPLIFY-CL is F, CURRENT-SIMPLIFY-CL is equivalent to the  conjunction of PROCESS-CLAUSES. Note that PROCESS-CLAUSES may be the facetious  answer F, i.e., false generalization may and does happen.  We know such tail biting can occur through use of linear arithmetic.  We are uncertain whether it can occur without use of linear arithmetic.  To make it happen with linear we just need two slightly different versions of  the same inequality literal. The poly arising from the second is used to  rewrite the first to false and the poly arising from the first --  which is still in the pot list -- is used to rewrite the second to false.  LITS-TO-BE-IGNORED-BY-LINEAR actually prevents this direct example from working  -- the poly arising from the first is ignored after its literal has been  rewritten to false. To overcome this minor obstacle, it is necessary to cause  the first literal to be rewritten to something that will prove to be false  eventually but isn't syntactically F. *) (LET (ANS (TERMS-TO-BE-IGNORED-BY-REWRITE TERMS-TO-BE-IGNORED-BY-REWRITE) (EXPAND-LST EXPAND-LST)) (PROG NIL (COND ((SETQ TEMP-TEMP (ASSOC (QUOTE SETTLED-DOWN-CLAUSE) HIST)) (* The clause has settled down under rewriting with the INDUCTION-HYP-TERMS  ignored and the INDUCTION-CONCL-TERMS forcibly expanded.  In general then we now want to stop treating these terms specially and continue  simplifying. However, there is a special case that will save a little time.  Suppose that the clause just settled down --  that is, the most recent HIST entry is the settled mark.  And suppose that none of the specially treated terms occurs in the clause we're  to simplify. Then we needn't simplify it again.  The first supposition is important. Imagine that the clause settled down long  ago and we have done much since then. *) (COND ((AND (EQ TEMP-TEMP (CAR HIST)) (for TERM in INDUCTION-HYP-TERMS never (DUMB-OCCUR-LST TERM CURRENT-SIMPLIFY-CL))) (* Since we know the INDUCTION-CONCL-TERMS couldn't occur in the clause --  they would have been expanded -- it suffices to check for just the hyp terms.  This test should speed up base cases and the preinduction simplification at  least. *) (RETURN NIL)))) (T (* The clause has not yet settled  down, so arrange to ignore  INDUCTION-HYP-TERMS during rewriting  and to expand without question  INDUCTION-CONCL-TERMS.  *) (SETQ TERMS-TO-BE-IGNORED-BY-REWRITE (APPEND INDUCTION-HYP-TERMS TERMS-TO-BE-IGNORED-BY-REWRITE)) (SETQ EXPAND-LST (APPEND INDUCTION-CONCL-TERMS EXPAND-LST)))) (INIT-LEMMA-STACK) (PUSH-LEMMA-FRAME) (SETQ PROCESS-CLAUSES (SIMPLIFY-CLAUSE0 CURRENT-SIMPLIFY-CL HIST)) (SETQ PROCESS-HIST (for X in (POP-LEMMA-FRAME) unless (AND (LISTP X) (NLISTP (CAR X))) collect X)) (* The lemmas ignored are really literals from LITS-THAT-MAY-BE-ASSUMED-FALSE  that get put in by REWRITE-SOLIDIFY. The identifying test for these literals is  not a simple LISTP because PROCESS-EQUATIONAL-POLYS puts in some LISTP elements  to encode its additions to the clause and we must preserve them.  *) (for X in PROCESS-HIST unless (OR (LISTP X) (MEMB X ALL-LEMMAS-USED)) do (SETQ ALL-LEMMAS-USED (CONS X ALL-LEMMAS-USED))) (RETURN (NOT (AND (IEQP (LENGTH PROCESS-CLAUSES) 1) (EQUAL (CAR PROCESS-CLAUSES) CURRENT-SIMPLIFY-CL]) (SIMPLIFY-CLAUSE-MAXIMALLY [LAMBDA (CURRENT-CL) (* kbr: "19-Oct-85 16:31") (LET (SIMPLIFY-CLAUSE-MAXIMALLY-CLAUSES SIMPLIFY-CLAUSE-MAXIMALLY-HIST) (SIMPLIFY-CLAUSE-MAXIMALLY1 CURRENT-CL) (SETQ PROCESS-HIST SIMPLIFY-CLAUSE-MAXIMALLY-HIST) (SETQ PROCESS-CLAUSES SIMPLIFY-CLAUSE-MAXIMALLY-CLAUSES) (NOT (EQUAL PROCESS-CLAUSES (LIST CURRENT-CL]) (SIMPLIFY-CLAUSE-MAXIMALLY1 [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (COND ((SIMPLIFY-CLAUSE CL NIL) (for X in PROCESS-HIST unless (OR (LISTP X) (MEMB X SIMPLIFY-CLAUSE-MAXIMALLY-HIST)) do (SETQ SIMPLIFY-CLAUSE-MAXIMALLY-HIST (CONS X SIMPLIFY-CLAUSE-MAXIMALLY-HIST))) (for CL in PROCESS-CLAUSES do (SIMPLIFY-CLAUSE-MAXIMALLY1 CL))) (T (SETQ SIMPLIFY-CLAUSE-MAXIMALLY-CLAUSES (CONS CL SIMPLIFY-CLAUSE-MAXIMALLY-CLAUSES]) (SIMPLIFY-CLAUSE0 [LAMBDA (CL HIST) (* kbr: " 6-Jul-86 09:45") (* Called by SIMPLIFY-CLAUSE.  *) (PROG (TYPE-ALIST SIMPLIFY-CLAUSE-POT-LST CLS NEG-HYPS) (SETQ CL (REMOVE-TRIVIAL-EQUATIONS CL)) (SETQ TYPE-ALIST (TYPE-ALIST-CLAUSE CL)) (COND ((EQ (QUOTE CONTRADICTION) TYPE-ALIST) (RETURN NIL))) (SET-SIMPLIFY-CLAUSE-POT-LST CL TYPE-ALIST) (COND ((EQ SIMPLIFY-CLAUSE-POT-LST (QUOTE CONTRADICTION)) (SETQ CLS NIL)) (T (SETQ CLS (LIST (PROCESS-EQUATIONAL-POLYS CL HIST SIMPLIFY-CLAUSE-POT-LST))))) (COND ((NOT (AND (IEQP (LENGTH CLS) 1) (EQUAL (CAR CLS) CL))) (PUSH-LEMMA (QUOTE ZERO)) (for X in LEMMAS-USED-BY-LINEAR do (PUSH-LEMMA X)) (SETQ LINEAR-ASSUMPTIONS (for HYP in LINEAR-ASSUMPTIONS unless (for LIT in CL thereis (COMPLEMENTARYP HYP LIT)) collect HYP)) (SETQ NEG-HYPS (for HYP in LINEAR-ASSUMPTIONS collect (DUMB-NEGATE-LIT HYP))) (SETQ CLS (for CL in CLS collect (DISJOIN-CLAUSES NEG-HYPS CL))) (for TERM in LINEAR-ASSUMPTIONS do (SETQ CLS (CONS (CONS TERM CL) CLS))) (RETURN CLS)) (T (RETURN (SIMPLIFY-CLAUSE1 CL NIL NIL 1]) (SIMPLIFY-CLAUSE1 [LAMBDA (TAIL NEW-CLAUSE LITS-TO-BE-IGNORED-BY-LINEAR I) (* kbr: " 6-Jul-86 09:46") (* Called by SIMPLIFY-CLAUSE0. Returns a list of clauses whose conjunction is  equivalent to the clause CL formed by appending TAIL to NEW-CLAUSE under the  hypothesis of the polys in SIMPLIFY-CLAUSE-POT-LST and under the hypothesis  that CL is false. *) (PROG (VAL SEGS TYPE-ALIST NEG-HYPS CURRENT-LIT CURRENT-ATM BRANCHES) (COND ((NULL TAIL) (RETURN (LIST NEW-CLAUSE))) (T (PRINT-TO-DISPLAY (QUOTE SIMPLIFY-CLAUSE) I NIL) (SETQ CURRENT-LIT (SETQ CURRENT-ATM (CAR TAIL))) (BM-MATCH CURRENT-ATM (NOT CURRENT-ATM)) (SETQ LITS-TO-BE-IGNORED-BY-LINEAR (CONS CURRENT-LIT LITS-TO-BE-IGNORED-BY-LINEAR)) (SETQ FNSTACK NIL) (SETQ TYPE-ALIST (TYPE-ALIST-CLAUSE NEW-CLAUSE)) (COND ((EQ TYPE-ALIST (QUOTE CONTRADICTION)) (RETURN NIL))) (SETQ TYPE-ALIST (TYPE-ALIST-CLAUSE (CDR TAIL))) (COND ((EQ TYPE-ALIST (QUOTE CONTRADICTION)) (RETURN NIL))) (INIT-LINEARIZE-ASSUMPTIONS-STACK) (PUSH-LINEARIZE-ASSUMPTIONS-FRAME) (SETQ VAL (REWRITE CURRENT-ATM NIL TYPE-ALIST (QUOTE ?) (QUOTE IFF) NIL)) (COND ((NEQ CURRENT-LIT CURRENT-ATM) (SETQ VAL (NEGATE-LIT VAL)))) (SETQ LINEAR-ASSUMPTIONS (POP-LINEARIZE-ASSUMPTIONS-FRAME)) (SETQ NEG-HYPS (for HYP in LINEAR-ASSUMPTIONS collect (NEGATE-LIT HYP))) (SETQ BRANCHES (CLAUSIFY VAL)) (SETQ SEGS (CONJOIN-CLAUSE-SETS (for SEG in BRANCHES collect (DISJOIN-CLAUSES NEG-HYPS SEG)) (for HYP in LINEAR-ASSUMPTIONS bind (CL _ (ADD-LITERAL (PEGATE-LIT CURRENT-LIT) NIL NIL)) collect (ADD-LITERAL HYP CL NIL)))) (RETURN (for SEG in SEGS join (SIMPLIFY-CLAUSE1 (CDR TAIL) (APPEND NEW-CLAUSE SEG) (COND ((EQUAL BRANCHES (QUOTE (NIL))) LITS-TO-BE-IGNORED-BY-LINEAR) (T (CDR LITS-TO-BE-IGNORED-BY-LINEAR))) (ADD1 I]) (SIMPLIFY-LOOP [LAMBDA (CLAUSES) (* kbr: "20-Oct-85 15:36") (* This function just serves as a target for the RETFROM in STORE-SENT in the  event that we are working on the original input and find that we have split it  into more than one goal and want to back up and use induction on the input  term. *) (for CURRENT-CL in CLAUSES do (SIMPLIFY-SENT CURRENT-CL NIL]) (SIMPLIFY-SENT [LAMBDA (CL HIST) (* kbr: "19-Oct-85 16:31") (EXECUTE (QUOTE SIMPLIFY-CLAUSE) CL HIST (QUOTE SIMPLIFY-SENT) (QUOTE SETTLED-DOWN-SENT]) (SINGLETON-CONSTRUCTOR-TO-RECOGNIZER [LAMBDA (FNNAME) (* kbr: "19-Oct-85 16:31") (COND ((SETQ TEMP-TEMP (ASSOC FNNAME SHELL-ALIST)) (SETQ TEMP-TEMP (LSH 1 (CDR TEMP-TEMP))) (COND ((MEMBER TEMP-TEMP SINGLETON-TYPE-SETS) (CAR (for PAIR in RECOGNIZER-ALIST when (EQUAL TEMP-TEMP (CDR PAIR)) do (RETURN PAIR)))) (T NIL))) (T NIL]) (SKO-DEST-NESTP [LAMBDA (TERM DEEPFLG) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) T) ((FQUOTEP TERM) NIL) ((AND (SETQ TEMP-TEMP (GET1 (FFN-SYMB TERM) (QUOTE ELIMINATE-DESTRUCTORS-SEQ))) (NOT (DISABLEDP (fetch (REWRITE-RULE NAME) of TEMP-TEMP)))) (COND (DEEPFLG (for X in (FARGS TERM) always (SKO-DEST-NESTP X DEEPFLG))) (T (for X in (FARGS TERM) always (VARIABLEP X))))) (T NIL]) (SOME-SUBTERM-WORSE-THAN-OR-EQUAL [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (* Returns T if some subterm of TERM1  is WORSE-THAN or EQUAL to TERM2  itself. *) (COND ((VARIABLEP TERM1) (EQ TERM1 TERM2)) ((OR (EQUAL TERM1 TERM2) (QUICK-WORSE-THAN TERM1 TERM2)) T) ((FQUOTEP TERM1) NIL) (T (for ARG in (FARGS TERM1) thereis (SOME-SUBTERM-WORSE-THAN-OR-EQUAL ARG TERM2]) (SORT-DESTRUCTOR-CANDIDATES [LAMBDA (LST) (* kbr: "22-Oct-85 15:37") (* Each element of LST is a list of NVARIABLEP nonQUOTEP terms.  We sort them into descending order according to the sum of the level numbers of  the fn symbols of the terms in the CDR of each element.  INTERLISP's SORT is apparently nonstable and frequently  (perhaps always) reverses elements of equal weight.  Zetalisp sort is stable. We found three occasions in the rsa and wilson proofs  when this difference bit us and caused a different elimination to be chosen  first. The first two times we fixed it by letting it do the new elim and just  seeing that the appropriate lemmas were available to handle the new goals.  But on the third time we decided simply to REVERSE the input list to mimic  INTERLISP's sort, just so we could get on with reproducing the old proofs on  the new machine. *) (SORT (REVERSE LST) (FUNCTION (LAMBDA (X Y) (GREATERP (for TERM in (CDR X) sum (GET-LEVEL-NO (FFN-SYMB TERM))) (for TERM in (CDR Y) sum (GET-LEVEL-NO (FFN-SYMB TERM]) (SOUND-IND-PRIN-MASK [LAMBDA (TERM JUSTIFICATION FORMALS QUICK-BLOCK-INFO) (* kbr: "19-Oct-85 16:31") (* TERM is a term we are considering doing induction for.  JUSTIFICATION is one of the justifications associated with the function symbol  of TERM. FORMALS is the formals list of the fn and QUICK-BLOCK-INFO is the  obvious. JUSTIFICATION and the machine for fn describe an induction.  We wish to determine, in the terminology of ACL, whether the induction applies  to TERM. If so we return a mask indicating how to build the substitutions for  the induction from TERM and the machine for fn.  Otherwise we return NIL. Let the changeables be those actuals of TERM that are  in the measured subset of JUSTIFICATION and that sometimes change in the  recursion. Let the unchangeables be all of the variables occurring in measured  actuals that never change in recursion. The induction applies if changeables is  a sequence of distinct variable names and has an empty intersection with  unchangeables. If the induction is applicable then the substitutions should  substitute for the changeables just as the recursion would, and hold each  unchangeable fixed -- i.e., substitute each for itself.  With such substitutions it is possible to prove the measure lemmas analogous to  those proved in JUSTIFICATION, except that the measure is obtained by  instantiating the measure term used in the justification by the measured  actuals in unchanging slots. Actual variables that are neither among the  changeables or unchangeables may be substituted for arbitrarily.  If the induction is applicable we return a mask with as many elements as there  are actuals. For each actual the mask contains either CHANGEABLE, UNCHANGEABLE,  or NIL. CHANGEABLE means the actual should be instantiated as specified in the  recursion. UNCHANGEABLE means each var in the actual should be held fixed.  NIL means that the corresponding substitution pairs in the machine for the  function should be ignored. Abstractly, this function builds the mask by first  putting either CHANGEABLE or UNCHANGEABLE in each measured slot.  It then fills in the remaining slots from the left so as to permit the actual  to be instantiated or held fixed as desired by the recursion, provided that in  so doing it does not permit substitutions for previously allocated actuals.  *) (PROG (UNCHANGEABLES SUBSET CHANGEABLES) (SETQ SUBSET (fetch (JUSTIFICATION SUBSET) of JUSTIFICATION)) (SETQ UNCHANGEABLES (for ACTUAL in (FARGS TERM) as VAR in FORMALS as Q in QUICK-BLOCK-INFO bind LOOP-ANS when (AND (MEMB VAR SUBSET) (EQ Q (QUOTE UNCHANGING))) do (SETQ LOOP-ANS (UNIONQ (ALL-VARS ACTUAL) LOOP-ANS)) finally (RETURN LOOP-ANS))) (SETQ CHANGEABLES (for ACTUAL in (FARGS TERM) as VAR in FORMALS as Q in QUICK-BLOCK-INFO when (AND (MEMB VAR SUBSET) (NEQ Q (QUOTE UNCHANGING))) collect ACTUAL)) (COND ((OR (NOT (NO-DUPLICATESP CHANGEABLES)) (for X in CHANGEABLES thereis (NVARIABLEP X)) (INTERSECTP CHANGEABLES UNCHANGEABLES)) (RETURN NIL))) (RETURN (for ACTUAL in (FARGS TERM) as Q in QUICK-BLOCK-INFO as VAR in FORMALS collect (COND ((MEMB VAR SUBSET) (COND ((EQ Q (QUOTE UNCHANGING)) (QUOTE UNCHANGEABLE)) (T (QUOTE CHANGEABLE)))) ((AND (VARIABLEP ACTUAL) (EQ Q (QUOTE UNCHANGING))) (COND ((MEMB ACTUAL CHANGEABLES) NIL) (T (SETQ UNCHANGEABLES (ADD-TO-SET ACTUAL UNCHANGEABLES)) (QUOTE UNCHANGEABLE)))) ((AND (VARIABLEP ACTUAL) (NOT (MEMB ACTUAL CHANGEABLES)) (NOT (MEMB ACTUAL UNCHANGEABLES))) (SETQ CHANGEABLES (CONS ACTUAL CHANGEABLES)) (QUOTE CHANGEABLE)) (T NIL]) (STACK-DEPTH [LAMBDA (STK) (* kbr: "19-Oct-85 21:59") (ADD1 (LENGTH STK]) (START-STATS [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (SETQ ELAPSEDTHMTIME (TIME-IN-60THS)) (SETQ IOTHMTIME 0]) (STOP-STATS [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (PRINT-STATS (QUOTIENT (FLOAT (DIFFERENCE (DIFFERENCE (TIME-IN-60THS) ELAPSEDTHMTIME) IOTHMTIME)) 60.0) (QUOTIENT (FLOAT IOTHMTIME) 60.0) PROVE-FILE]) (STORE-SENT [LAMBDA (CL HIST) (* kbr: "20-Oct-85 15:36") (LET (CL-SET) (COND ((NULL CL) (IO (QUOTE STORE-SENT) CL HIST NIL (LIST (GET-STACK-NAME STACK))) (WRAPUP NIL)) (DO-NOT-USE-INDUCTION-FLG (IO (QUOTE STORE-SENT) CL HIST NIL (LIST (GET-STACK-NAME STACK) (QUOTE QUIT))) (WRAPUP NIL)) ((AND (NOT (AND IN-PROVE-LEMMA-FLG (ASSOC (QUOTE INDUCT) HINTS))) (OR (AND (NULL STACK) (for X in HIST thereis (NOT (MEMB (CAR X) (QUOTE (SETTLED-DOWN-CLAUSE SIMPLIFY-CLAUSE SETUP))))) ) (AND STACK (NOT (ASSOC (QUOTE BEING-PROVED) STACK))))) (* Abort and push the input clause to work on if  (a) this is the first time we've ever pushed anything and we've done anything  to the input other than simplify it, or (b) we have not yet gone into the first  induction for the original conjecture but have already pushed one simplified  subgoal. *) (SETQ STACK NIL) (SETQ CL-SET (CNF-DNF THM (QUOTE C))) (* Once upon a time we backed up to the output of PREPROCESS in PROVE.  However, PREPROCESS -- and CLAUSIFY-INPUT --  applies unconditional rewrite rules and we want the ability as users to type in  exactly what the system inducts on. The theorem that PREPROCESS screwed us on  was HACK1 when it distributed TIMES and GCD.  *) (IO (QUOTE STORE-SENT) CL NIL NIL (LIST (GET-STACK-NAME STACK) CL-SET)) (PUSH-CLAUSE-SET CL-SET) (RETFROM (QUOTE SIMPLIFY-LOOP) NIL)) (T (SETQ CL-SET (LIST CL)) (IO (QUOTE STORE-SENT) CL HIST NIL (LIST (GET-STACK-NAME STACK))) (PUSH-CLAUSE-SET CL-SET]) (STRIP-BRANCHES [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (CL) (for PAIR in (COND ((BM-MATCH TERM (NOT TERM)) (STRIP-BRANCHES1 TERM T T)) (T (STRIP-BRANCHES1 TERM T NIL))) unless (EQUAL (SETQ CL (ADD-LITERAL (PEGATE-LIT (CAR PAIR)) (CDR PAIR) T)) TRUE-CLAUSE) collect CL]) (STRIP-BRANCHES1 [LAMBDA (TERM TOPFLG NEGATE-FLG) (* kbr: "19-Oct-85 16:31") (LET (ANS1 ANS2 ANS3 ANS LST NEW-CL) (COND ((VARIABLEP TERM) (LIST (CONS (COND (NEGATE-FLG (NEGATE-LIT TERM)) (T TERM)) NIL))) ((FQUOTEP TERM) (COND (TOPFLG (COND ((EQUAL TERM FALSE) (COND (NEGATE-FLG NIL) (T (LIST (CONS FALSE NIL))))) (NEGATE-FLG (LIST (CONS FALSE NIL))) (T NIL))) (NEGATE-FLG (LIST (CONS (COND ((EQUAL TERM FALSE) TRUE) (T FALSE)) NIL))) (T (LIST (CONS TERM NIL))))) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (COND ((AND TOPFLG (OR (AND (NOT NEGATE-FLG) (EQUAL (FARGN TERM 3) FALSE)) (AND NEGATE-FLG (EQUAL (FARGN TERM 3) TRUE)))) (APPEND (for PAIR in (STRIP-BRANCHES1 (FARGN TERM 1) TOPFLG NIL) unless (EQUAL (SETQ NEW-CL (ADD-LITERAL (PEGATE-LIT (CAR PAIR)) (CDR PAIR) T)) TRUE-CLAUSE) collect (CONS FALSE NEW-CL)) (STRIP-BRANCHES1 (FARGN TERM 2) TOPFLG NEGATE-FLG))) ((AND TOPFLG (OR (AND (NOT NEGATE-FLG) (EQUAL (FARGN TERM 2) FALSE)) (AND NEGATE-FLG (EQUAL (FARGN TERM 2) TRUE)))) (APPEND (for PAIR in (STRIP-BRANCHES1 (FARGN TERM 1) TOPFLG T) unless (EQUAL (SETQ NEW-CL (ADD-LITERAL (PEGATE-LIT (CAR PAIR)) (CDR PAIR) T)) TRUE-CLAUSE) collect (CONS FALSE NEW-CL)) (STRIP-BRANCHES1 (FARGN TERM 3) TOPFLG NEGATE-FLG))) (T (SETQ ANS1 (STRIP-BRANCHES1 (FARGN TERM 1) NIL NIL)) (SETQ ANS2 (STRIP-BRANCHES1 (FARGN TERM 2) TOPFLG NEGATE-FLG)) (SETQ ANS3 (STRIP-BRANCHES1 (FARGN TERM 3) TOPFLG NEGATE-FLG)) (for PAIR in ANS1 do (for PAIR2 in ANS2 unless (EQUAL (CDR (SETQ ANS (CONS (CAR PAIR2) (DISJOIN-CLAUSES (CDR PAIR) (ADD-LITERAL (NEGATE-LIT (CAR PAIR)) (CDR PAIR2) NIL))))) TRUE-CLAUSE) do (SETQ LST (CONS ANS LST))) (for PAIR3 in ANS3 unless (EQUAL (CDR (SETQ ANS (CONS (CAR PAIR3) (DISJOIN-CLAUSES (CDR PAIR) (ADD-LITERAL (PEGATE-LIT (CAR PAIR)) (CDR PAIR3) NIL))))) TRUE-CLAUSE) do (SETQ LST (CONS ANS LST)))) LST))) (T (for PICK in (ALL-PICKS (for ARG in (FARGS TERM) collect (STRIP-BRANCHES1 ARG NIL NIL))) collect (CONS (COND (NEGATE-FLG (DUMB-NEGATE-LIT (SCONS-TERM (FFN-SYMB TERM) (for PAIR in PICK collect (CAR PAIR))))) (T (SCONS-TERM (FFN-SYMB TERM) (for PAIR in PICK collect (CAR PAIR))))) (for PAIR in PICK bind ANS until (EQUAL ANS TRUE-CLAUSE) do (SETQ ANS (DISJOIN-CLAUSES (CDR PAIR) ANS)) finally (RETURN ANS]) (SUB-SEQUENCEP [LAMBDA (SMALLER LARGER) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP SMALLER) T) ((NLISTP LARGER) NIL) ((EQUAL (CAR SMALLER) (CAR LARGER)) (SUB-SEQUENCEP (CDR SMALLER) (CDR LARGER))) (T (SUB-SEQUENCEP SMALLER (CDR LARGER]) (SUBBAGP [LAMBDA (BAG1 BAG2) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP BAG1) T) ((NLISTP BAG2) NIL) ((MEMBER (CAR BAG1) BAG2) (SUBBAGP (CDR BAG1) (DELETE1 (CAR BAG1) BAG2))) (T NIL]) (SUBLIS-EXPR [LAMBDA (ALIST FORM) (* kbr: "19-Oct-85 16:31") (for PAIR in ALIST do (COND ((QUOTEP (CAR PAIR)) (SUBST-EXPR-ERROR1 (CAR PAIR))))) (SUBLIS-EXPR1 ALIST FORM]) (SUBLIS-EXPR1 [LAMBDA (ALIST FORM) (* kbr: "19-Oct-85 16:31") (COND ((SETQ TEMP-TEMP (SASSOC FORM ALIST)) (CDR TEMP-TEMP)) ((VARIABLEP FORM) FORM) ((FQUOTEP FORM) FORM) (T (CONS-TERM (FFN-SYMB FORM) (for ARG in (FARGS FORM) collect (SUBLIS-EXPR1 ALIST ARG]) (SUBLIS-VAR [LAMBDA (ALIST FORM) (* kbr: "19-Oct-85 16:31") (* In REWRITE-WITH-LEMMAS we use this function with the NIL alist to put FORM  into quote normal form. Do not optimize this function for the NIL alist.  *) (COND ((VARIABLEP FORM) (COND ((SETQ TEMP-TEMP (ASSOC FORM ALIST)) (CDR TEMP-TEMP)) (T FORM))) ((FQUOTEP FORM) FORM) (T (CONS-TERM (FFN-SYMB FORM) (for ARG in (FARGS FORM) collect (SUBLIS-VAR ALIST ARG]) (SUBLIS-VAR-LST [LAMBDA (ALIST TERMLST) (* kbr: "19-Oct-85 16:31") (for TERM in TERMLST collect (SUBLIS-VAR ALIST TERM]) (SUB-PAIR-EXPR [LAMBDA (OLDLST NEWLST TERM) (* kbr: "19-Oct-85 16:31") (for X in OLDLST do (COND ((QUOTEP X) (SUBST-EXPR-ERROR1 X)))) (SUB-PAIR-EXPR1 OLDLST NEWLST TERM]) (SUB-PAIR-EXPR-LST [LAMBDA (OLDLST NEWLST LST) (* kbr: "19-Oct-85 16:31") (for X in LST collect (SUB-PAIR-EXPR OLDLST NEWLST X]) (SUB-PAIR-EXPR1 [LAMBDA (OLDLST NEWLST TERM) (* kbr: "19-Oct-85 16:31") (COND ((for OLD1 in OLDLST as NEW1 in NEWLST thereis (COND ((EQUAL OLD1 TERM) (SETQ TEMP-TEMP NEW1) T) (T NIL))) TEMP-TEMP) ((VARIABLEP TERM) TERM) ((FQUOTEP TERM) TERM) (T (CONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (SUB-PAIR-EXPR1 OLDLST NEWLST ARG]) (SUB-PAIR-VAR [LAMBDA (OLDLST NEWLST TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) (COND ((for OLD1 in OLDLST as NEW1 in NEWLST thereis (COND ((EQ OLD1 TERM) (SETQ TEMP-TEMP NEW1) T) (T NIL))) TEMP-TEMP) (T TERM))) ((FQUOTEP TERM) TERM) (T (CONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (SUB-PAIR-VAR OLDLST NEWLST ARG]) (SUB-PAIR-VAR-LST [LAMBDA (OLDLST NEWLST LST) (* kbr: "19-Oct-85 16:31") (for X in LST collect (SUB-PAIR-VAR OLDLST NEWLST X]) (SUBST-EXPR [LAMBDA (NEW OLD FORM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP OLD) (SUBST-VAR NEW OLD FORM)) ((FQUOTEP OLD) (SUBST-EXPR-ERROR1 OLD)) (T (SUBST-EXPR1 NEW OLD FORM]) (SUBST-EXPR-ERROR1 [LAMBDA (OLD) (* kbr: "19-Oct-85 16:31") (ERROR1 (PQUOTE (PROGN ATTEMPT TO BM-SUBST FOR THE EXPLICIT CONSTANT (!PPR OLD NIL) %. THE SUBSTITUTION FUNCTIONS WERE OPTIMIZED TO DISALLOW THIS %.)) (BINDINGS (QUOTE OLD) OLD) (QUOTE HARD]) (SUBST-EXPR-LST [LAMBDA (NEW OLD LST) (* kbr: "19-Oct-85 16:31") (for X in LST collect (SUBST-EXPR NEW OLD X]) (SUBST-EXPR1 [LAMBDA (NEW OLD FORM) (* kbr: "19-Oct-85 16:31") (COND ((EQUAL OLD FORM) NEW) ((VARIABLEP FORM) FORM) ((FQUOTEP FORM) FORM) (T (CONS-TERM (FFN-SYMB FORM) (for ARG in (FARGS FORM) collect (SUBST-EXPR1 NEW OLD ARG]) (SUBST-FN [LAMBDA (NEW OLD TERM) (* kbr: "19-Oct-85 16:31") (* Replaces calls of OLD with calls of  NEW. Assumes both have same arity and  that neither is a shell constructor or  bottom object. *) (COND ((VARIABLEP TERM) TERM) ((FQUOTEP TERM) TERM) ((EQ OLD (FFN-SYMB TERM)) (FCONS-TERM NEW (for ARG in (FARGS TERM) collect (SUBST-FN NEW OLD ARG)))) (T (FCONS-TERM (FFN-SYMB TERM) (for ARG in (FARGS TERM) collect (SUBST-FN NEW OLD ARG]) (SUBST-VAR [LAMBDA (NEW OLD FORM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP FORM) (COND ((EQ FORM OLD) NEW) (T FORM))) ((FQUOTEP FORM) FORM) (T (CONS-TERM (FFN-SYMB FORM) (for ARG in (FARGS FORM) collect (SUBST-VAR NEW OLD ARG]) (SUBST-VAR-LST [LAMBDA (NEW OLD TERMLST) (* kbr: "19-Oct-85 16:31") (for TERM in TERMLST collect (SUBST-VAR NEW OLD TERM]) (BM-SUBST [LAMBDA (NEW OLD FORM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP OLD) (SUBST-VAR NEW OLD FORM)) (T (SUBST-EXPR NEW OLD FORM]) (SUBSUMES [LAMBDA (CL1 CL2) (* kbr: "19-Oct-85 16:31") (LET (UNIFY-SUBST) (SUBSUMES1 CL1]) (SUBSUMES-REWRITE-RULE [LAMBDA (REWRITE-RULE1 REWRITE-RULE2) (* kbr: "19-Oct-85 16:31") (LET (UNIFY-SUBST (CL2 (fetch (REWRITE-RULE HYPS) of REWRITE-RULE2))) (AND (ONE-WAY-UNIFY1 (fetch (REWRITE-RULE CONCL) of REWRITE-RULE1) (fetch (REWRITE-RULE CONCL) of REWRITE-RULE2)) (SUBSUMES1 (fetch (REWRITE-RULE HYPS) of REWRITE-RULE1]) (SUBSUMES1 [LAMBDA (CL1) (* kbr: "19-Oct-85 16:31") (* Also called by SUBSUMES-SEQ.  *) (COND ((NULL CL1) T) (T (for LIT in CL2 thereis (SUBSUMES11 LIT CL1 UNIFY-SUBST]) (SUBSUMES11 [LAMBDA (LIT CL1 UNIFY-SUBST) (* kbr: "19-Oct-85 16:31") (AND (ONE-WAY-UNIFY1 (CAR CL1) LIT) (SUBSUMES1 (CDR CL1]) (SUM-STATS-ALIST [LAMBDA (ALIST) (* kbr: "25-Oct-85 16:21") (PROG (CPU IO) (SETQ CPU 0) (SETQ IO 0) (for X in ALIST do (SETQ CPU (IPLUS (CADR X) CPU)) (SETQ IO (IPLUS (CADDR X) IO))) (RETURN (LIST CPU IO]) (TABULATE [LAMBDA (N FILE) (* kbr: "19-Oct-85 16:31") (ISPACES (IDIFFERENCE N (IPOSITION FILE NIL NIL)) FILE]) (TERM-ORDER [LAMBDA (TERM1 TERM2) (* kbr: "26-Oct-85 17:20") (* A simple -- or complete or total -- ordering is a relation satisfying: XrX.  TERM-ORDER is a simple ordering on terms.  (TERM-ORDER TERM1 TERM2) if and only if (a) the number of occurrences of  variables in TERM1 is strictly less than the number in TERM2, or  (b) the numbers of variable occurrences are equal and the FORM-COUNT of TERM1  is strictly less than that of TERM2, or (c) the numbers of variable occurrences  are equal, the FORM-COUNTS are equal, and  (LEXORDER TERM1 TERM2)%. Let (STRICT-TERM-ORDER X Y) be the LISP function  defined as (AND (TERM-ORDER X Y) (NOT (EQUAL X Y)))%.  For a fixed, finite set of function symbols and variable symbols  STRICT-TERM-ORDER is well founded, as can be proved with the following lemma.  Lemma. Suppose that M is a function whose range is well ordered by r and such  that the inverse image of any member of the range is finite.  Suppose that L is a total order. Define (LESSP ITIMES y) IEQP  (OR (r (M ITIMES) (M y)) (AND (EQUAL (M ITIMES)  (M y)) (L ITIMES y) (NOT (EQUAL ITIMES y))))%.  ILESSP is a well-ordering. Proof. Suppose ...  ILESSP t3 ILESSP t2 ILESSP t1 is an infinite descending sequence.  ..., (M t3), (M t2), (M t1) is weakly descending but not infinitely descending  and so has a least element. WLOG assume ...  IEQP (M t3) IEQP (M t2) IEQP (M t1)%. By the finiteness of the inverse image of  (M t1), { ..., t3, t2, t1} is a finite set, which has a least element under L,  WLOG t27. But t28 L t27 and t28 /= t27 by t28 ILESSP t27, contradicting the  minimality of t27. QED If (TERM-ORDER ITIMES y) and t2 results from replacing  one occurrence of y with ITIMES in t1, then  (TERM-ORDER t2 t1)%. Cases on why ITIMES is less than y.  1.0 If the number of occurrences of variables in ITIMES is strictly smaller  than in y, then the number in t2 is strictly smaller than in t1.  2.0 If the number of occurrences of variables in ITIMES is equal to the number  in y but (FORM-COUNT ITIMES) is smaller than  (FORM-COUNT y), then the number of occurrences in t1 is equal to the number in  t2 but (FORM-COUNT t1) is less than (FORM-COUNT t2)%.  3.0 If the number of variable occurrences and parenthesis occurrences in ITIMES  and y are the same, then (LEXORDER ITIMES y)%.  (TERM-ORDER t2 t1) reduces to (LEXORDER t2 t1) because the number of variable  and parenthesis occurrences in t2 and t1 are the same.  The lexicographic scan of t1 and t2 will be all equals until ITIMES and y are  hit. *) (LET (FORM-COUNT1 FORM-COUNT2 NUMBER-OF-VARIABLES1 NUMBER-OF-VARIABLES2) (* Side effect of FORM-COUNT is to set  NUMBER-OF-VARIABLES.  *) (SETQ FORM-COUNT1 (FORM-COUNT TERM1)) (SETQ NUMBER-OF-VARIABLES1 NUMBER-OF-VARIABLES) (SETQ FORM-COUNT2 (FORM-COUNT TERM2)) (SETQ NUMBER-OF-VARIABLES2 NUMBER-OF-VARIABLES) (COND ((LESSP NUMBER-OF-VARIABLES1 NUMBER-OF-VARIABLES2) T) ((LESSP NUMBER-OF-VARIABLES2 NUMBER-OF-VARIABLES1) NIL) ((LESSP FORM-COUNT1 FORM-COUNT2) T) ((LESSP FORM-COUNT2 FORM-COUNT1) NIL) (T (LEXORDER TERM1 TERM2]) (TERMINATION-MACHINE [LAMBDA (FNNAME TERM TESTS) (* kbr: "19-Oct-85 16:31") (* This function builds a list of TESTS-AND-CASE representing the function  FNNAME with body TERM. For each call of FNNAME in body, a TESTS-AND-CASE is  returned whose TESTS are all the tests that CASE is the arglist of the call.  If a rules b, then a governs b but not vice versa.  For example, in (if (g (if a b c)) d e), a governs b but does not rule b.  The reason for taking this weaker notion of governance is that we can show  easily that the TESTS-AND-CASEs are together sufficient to imply the  TESTS-AND-CASES generated by INDUCTION-MACHINE.  *) (COND ((OR (VARIABLEP TERM) (FQUOTEP TERM)) NIL) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (NCONC (for ARGLIST in (ALL-ARGLISTS FNNAME (FARGN TERM 1)) collect (create TESTS-AND-CASE TESTS _ TESTS CASE _ ARGLIST)) (TERMINATION-MACHINE FNNAME (FARGN TERM 2) (APPEND TESTS (LIST (FARGN TERM 1)))) (TERMINATION-MACHINE FNNAME (FARGN TERM 3) (APPEND TESTS (LIST (NEGATE-LIT (FARGN TERM 1))))))) (T (for ARGLIST in (ALL-ARGLISTS FNNAME TERM) collect (create TESTS-AND-CASE TESTS _ TESTS CASE _ ARGLIST]) (TP-EXPLODEN1 [LAMBDA (SYM) (* kbr: "19-Oct-85 16:31") (for N in (OUR-EXPLODEN SYM) collect (COND ((OR (IEQP N #/-) (AND (ILEQ #/0 N) (ILEQ N #/9))) N) ((AND (ILEQ #/A N) (ILEQ N #/Z)) (IDIFFERENCE N 32.0)) (T (ERROR1 (PQUOTE (PROGN QUOTED LITERAL ATOMS MUST BE IN LOWER CASE AND (!PPR X NIL) IS NOT %.)) (BINDINGS (QUOTE X) SYM) (QUOTE SOFT]) (TP-GETCHARN1 [LAMBDA (SYM N) (* kbr: "19-Oct-85 16:31") (LET ((A (OUR-GETCHARN SYM N))) (COND ((OR (IEQP A #/-) (AND (ILEQ #/0 A) (ILEQ A #/9))) A) ((AND (ILEQ #/A A) (ILEQ A #/Z)) (IDIFFERENCE A 32.0)) (T (ERROR1 (PQUOTE (PROGN QUOTED LITERAL ATOMS MUST BE IN LOWER CASE AND (!PPR X NIL) IS NOT %.)) (BINDINGS (QUOTE X) SYM) (QUOTE HARD]) (TP-IMPLODE1 [LAMBDA (L) (* kbr: "19-Oct-85 16:31") (OUR-IMPLODE (for N in L collect (COND ((OR (IEQP (OUR-GETCHARN N 1) #/-) (AND (ILEQ #/0 (OUR-GETCHARN N 1)) (ILEQ (OUR-GETCHARN N 1) #/9))) (OUR-GETCHARN N 1)) ((AND (ILEQ #/A (OUR-GETCHARN N 1)) (ILEQ (OUR-GETCHARN N 1) #/Z)) (IPLUS (OUR-GETCHARN N 1) 32.0)) (T (ERROR1 (PQUOTE (PROGN QUOTED LITERAL ATOMS MUST BE IN LOWER CASE AND (!PPR X NIL) IS NOT %.)) (BINDINGS (QUOTE X) (OUR-IMPLODE L)) (QUOTE HARD]) (TO-BE-IGNOREDP [LAMBDA (POLY) (* kbr: "19-Oct-85 16:31") (LET (LEMMAS LITS) (SETQ LEMMAS (fetch (POLY LEMMAS) of POLY)) (SETQ LITS (fetch (POLY LITERALS) of POLY)) (for LIT in LITS-TO-BE-IGNORED-BY-LINEAR thereis (OR (MEMB LIT LEMMAS) (MEMB LIT LITS]) (TOO-MANY-IFS [LAMBDA (ARGS VAL) (* kbr: "20-Oct-85 19:31") (* Let ARGS be the list of actuals to a nonrec fn.  Let VAL be the rewritten body. We wish to determine whether the expansion of  the fn call introduces too many IFs all at once.  Our motivation comes from an example like  (M2 (ZTAK & & &) (ZTAK & & &) (ZTAK & & &)) where the careless opening up of  everybody produces a formula with several hundred IFs in it because of M2's  duplication of the IFs coming from the simplification of the ZTAKs.  My first thought was to never expand a nonrec fn --  at the top level of the clause -- if it had some IFs in its args and to wait  till CLAUSIFY has cleaned things up. That slowed a proveall down by a factor of  2 -- and by a factor of 13 in PRIME-LIST-TIMES-LIST --  because of the ridiculously slow expansion of such basic nonrec fns as AND, OR,  NOT, and NLISTP. I have been thinking about the problem and have thought of the  following ideas. None except the final one have been implemented or tested.  I thought of permitting the expansion if VAL had fewer IFs than ARGS but that  is obviously bad because it does not permit the fn to introduce any IFs of its  own, e.g., as in AND. So I have decided to just prohibit the duplication of  IF-containing-args in VAL. That is, I do not want to expand the fn if the  expansion causes the duplication of some arg containing an IF.  Of course, it could be that an IF-containing-arg does not occur in VAL only  because it has been rewritten by some rewrite rule to some other term, possibly  containing even more IFs, but I have decided to ignore that and blame that  problem on the process that permitted the introduction of those IFs.  So when I say an arg is duplicated in VAL I really mean the arg literally  OCCURs twice. Then it occurred to me that if arg1 and arg2 both contained IFs  and arg1 was duplicated in VAL but arg2 did not occur at all, then perhaps one  should permit the expansion if the number of IFs in the arg1 occurrences are  less than the number in the arg1 plus arg2.  So that is what I have implemented. This function computes  (GREATERP (FOR ARG IN ARGS SUM (* (COUNT-IFS ARG) *))  (FOR ARG IN ARGS SUM (COUNT-IFS ARG))) but does it slightly more efficiently by  observing that if no IFs occur in any arg then there is no point in doing the  OCCUR-CNTs and that once the left hand side has been pushed beyond the right  there is no point in continuing. *) (LET (RHS LHS) (SETQ RHS (for ARG in ARGS sum (COUNT-IFS ARG))) (SETQ LHS 0) (COND ((ZEROP RHS) NIL) (T (for ARG in ARGS when (NOT (ZEROP (SETQ TEMP-TEMP (COUNT-IFS ARG)))) thereis (PROGN (* The WHEN clause above just takes advantage of the fact that if X is 0 then  X*Y is 0 and Y need not be computed. *) (GREATERP (SETQ LHS (PLUS (TIMES TEMP-TEMP (OCCUR-CNT ARG VAL)) LHS)) RHS]) (TOP-FNNAME [LAMBDA (CONCL) (* kbr: "19-Oct-85 16:31") (OR (BM-MATCH CONCL (NOT CONCL)) (BM-MATCH CONCL (EQUAL CONCL &))) (COND ((VARIABLEP CONCL) NIL) (T (FN-SYMB CONCL]) (TOTAL-FUNCTIONP [LAMBDA (FNNAME) (* kbr: "19-Oct-85 16:31") (LET (TEMP) (SETQ TEMP (GET1 FNNAME (QUOTE JUSTIFICATIONS))) (NOT (AND (IEQP (LENGTH TEMP) 1) (NULL (fetch (JUSTIFICATION RELATION) of (CAR TEMP))) (NOT (DISABLEDP FNNAME]) (TRANSITIVE-CLOSURE [LAMBDA (SET PRED) (* kbr: "26-Oct-85 14:02") (* Compares all pairs x,y of distinct occurrences of from the bag SET with  (PRED ITIMES y) and if PRED returns non-NIL, ITIMES and y are removed from SET  and the result of PRED is inserted. This operation is repeated until no changes  occur. CAUTION: It must be the case that  (PRED ITIMES y) IEQP (PRED y ITIMES) . *) (LET (ALIVE NEW RESULT) (SETQ ALIVE (for X in SET collect (CONS X T))) (SETQ NEW (COPYLIST ALIVE)) (while NEW unless (AND (CDR (CAR NEW)) (for TAIL on ALIVE when (PROG NIL LOOP (COND ((NULL (CDR (CAR TAIL))) (COND ((NULL (CDR TAIL)) (RETURN NIL)) (T (RPLACA TAIL (CADR TAIL)) (RPLACD TAIL (CDDR TAIL)) (GO LOOP))))) (RETURN (COND ((EQ (CAR TAIL) (CAR NEW)) NIL) ((SETQ RESULT (APPLY* PRED (CAR (CAR TAIL)) (CAR (CAR NEW)))) (SETQ RESULT (CONS RESULT T)) (RPLACD (CAR TAIL) NIL) (RPLACA TAIL RESULT) (RPLACD (CAR NEW) NIL) (RPLACA NEW RESULT) T) (T NIL)))) do (RETURN TAIL))) do (SETQ NEW (CDR NEW))) (for PAIR in ALIVE when (CDR PAIR) collect (CAR PAIR]) (TRANSLATE [LAMBDA (X) (* kbr: "26-Oct-85 17:19") (COND ((NLISTP X) (COND ((FIXP X) (LIST (QUOTE QUOTE) X)) ((LITATOM X) (COND ((EQ X T) TRUE) ((EQ X (QUOTE F)) FALSE) ((EQ X NIL) (QUOTE (QUOTE NIL))) ((ILLEGAL-NAME X) (ERROR1 (PQUOTE (PROGN (!PPR X NIL) IS AN ILLEGAL VARIABLE NAME %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) (T X))) (T (ERROR1 (PQUOTE (PROGN UNRECOGNIZED SYNTAX: (!PPR X NIL))) (BINDINGS (QUOTE X) X) (QUOTE SOFT))))) ((NOT (LISTP X)) (ERROR1 (PQUOTE (PROGN NO HUNKS PLEASE: (!PPR X NIL))) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) ((CDR (LAST X)) (ERROR1 (PQUOTE (PROGN CONTRARY TO THE RULES OF WELL-FORMEDNESS , THE LAST CDR OF (!PPR X NIL) IS NON-NIL)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) ((NOT (LITATOM (CAR X))) (ERROR1 (PQUOTE (PROGN FUNCTION SYMBOLS MUST BE LISP LITERAL ATOMS AND (!PPR (CAR X) NIL) IS NOT !)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) ((NOT (LITATOM (CAR X))) (ERROR1 (PQUOTE (PROGN (!PPR (CAR X) NIL) IS NOT INTERNED IN THE RIGHT PLACES !)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) ((PROPERTYLESS-SYMBOLP (CAR X)) (COND ((EQ (CAR X) (QUOTE QUOTE)) (COND ((NOT (IEQP 1 (LENGTH (CDR X)))) (ERROR1 (PQUOTE (PROGN QUOTE MUST BE GIVEN EXACTLY ONE ARGUMENT %. IN (!PPR X NIL) IT IS GIVEN THE WRONG NUMBER OF ARGUMENTS %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) ((NOT (EVG (CADR X))) (ERROR1 (PQUOTE (PROGN THE OBJECT QUOTED IN THE EXPRESSION (!PPR X NIL) DOES NOT REPRESENT AN EXPLICIT VALUE TERM)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) (T X))) ((MEMB (CAR X) (QUOTE (NIL T F))) (ERROR1 (PQUOTE (PROGN (!PPR (CAR X) NIL) IS AN ILLEGAL FUNCTION SYMBOL %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))) ((EQ (CAR X) (QUOTE LIST)) (COND ((NULL (CDR X)) (TRANSLATE NIL)) (T (XXXJOIN (QUOTE CONS) (NCONC1 (for ARG in (CDR X) collect (TRANSLATE ARG)) (TRANSLATE NIL)))))) ((CAR-CDRP (CAR X)) (COND ((IEQP (LENGTH (CDR X)) 1) (FIXCAR-CDR (LIST (CAR X) (TRANSLATE (CADR X))))) (T (ERROR1 (PQUOTE (PROGN (!PPR (CAR X) NIL) IS A RESERVED ABBREVIATION FOR A CAR-CDR NEST AND MUST BE GIVEN EXACTLY ONE ARGUMENT %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))))) (T (ERROR1 (PQUOTE (PROGN PROPERTYLESS-SYMBOLP AND TRANSLATE DO NOT AGREE ON (!PPR (CAR X) NIL) %.)) (BINDINGS (QUOTE X) X) (QUOTE HARD))))) ((NULL (ARITY (CAR X))) (COND (IN-BOOT-STRAP-FLG (ERROR1 (PQUOTE (PROGN (!PPR (CAR X) NIL) HAS BEEN ENCOUNTERED AS AN UNDEFINED FUNCTION BY TRANSLATE %. YOU SHOULD ADD IT TO THE BINDING OF ARITY-ALIST IN BOOT-STRAP IF YOU WISH TO SUPPRESS THIS MESSAGE !)) (BINDINGS (QUOTE X) X) (QUOTE WARNING))) (T (ERROR1 (PQUOTE (PROGN THE FUNCTION (!PPR (CAR X) NIL) IS UNKNOWN %. PLEASE DELETE ALL REFERENCES TO IT , DEFINE IT OR DECLARE IT AS AN UNDEFINED FUNCTION %.)) (BINDINGS (QUOTE X) X) (QUOTE SOFT))))) ((AND (MEMB (CAR X) (QUOTE (AND OR PLUS TIMES))) (IGREATERP (LENGTH (CDR X)) 2)) (XXXJOIN (CAR X) (for ARG in (CDR X) collect (TRANSLATE ARG)))) ((NOT (IEQP (LENGTH (CDR X)) (ARITY (CAR X)))) (ERROR1 (PQUOTE (PROGN THE FUNCTION SYMBOL (!PPR (CAR X) NIL) TAKES EXACTLY (@ N) ARGUMENTS %. IN (!PPR X NIL) IT IS GIVEN THE WRONG NUMBER OF ARGUMENTS %.)) (BINDINGS (QUOTE X) X (QUOTE N) (ARITY (CAR X))) (QUOTE SOFT))) ((MEMB (CAR X) BOOT-STRAP-MACRO-FNS) (SUB-PAIR-VAR (CADR (GET1 (CAR X) (QUOTE SDEFN))) (for ARG in (CDR X) collect (TRANSLATE ARG)) (CADDR (GET1 (CAR X) (QUOTE SDEFN))))) (T (CONS-TERM (CAR X) (for ARG in (CDR X) collect (TRANSLATE ARG]) (TRANSLATE-TO-LISP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (LET (ANS TIME) (SETQ TIME (TIME-IN-60THS)) (SETQ ALL-LEMMAS-USED NIL) (SETQ ANS (PRETTYIFY-LISP (OPTIMIZE-COMMON-SUBTERMS (ONEIFY X NIL)))) (SETQ TRANSLATE-TO-LISP-TIME (PLUS (DIFFERENCE (TIME-IN-60THS) TIME) TRANSLATE-TO-LISP-TIME)) ANS]) (TREE-DEPENDENTS [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (CONS NAME (for X in (GET1 NAME (QUOTE IMMEDIATE-DEPENDENTS0)) bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (TREE-DEPENDENTS X) LOOP-ANS)) finally (RETURN LOOP-ANS]) (TRIVIAL-POLYP [LAMBDA (POLY) (* kbr: "19-Oct-85 16:31") (OR (TRIVIAL-POLYP1 POLY (QUOTE POSITIVE)) (TRIVIAL-POLYP1 POLY (QUOTE NEGATIVE]) (TRIVIAL-POLYP1 [LAMBDA (POLY PARITY) (* kbr: "19-Oct-85 16:31") (PROG (WINNING-PAIR COEF) (COND ((EQ PARITY (QUOTE POSITIVE)) (COND ((AND (LESSP (fetch (POLY CONSTANT) of POLY) 1) (IEQP 1 (for PAIR in (fetch (POLY ALIST) of POLY) count (GREATERP (CDR PAIR) 0)))) (SETQ WINNING-PAIR (for PAIR in (fetch (POLY ALIST) of POLY) when (GREATERP (CDR PAIR) 0) do (RETURN PAIR))) (SETQ COEF (CDR WINNING-PAIR))) (T (RETURN NIL)))) ((AND (GREATERP (fetch (POLY CONSTANT) of POLY) -1) (IEQP 1 (for PAIR in (fetch (POLY ALIST) of POLY) count (LESSP (CDR PAIR) 0)))) (SETQ WINNING-PAIR (for PAIR in (fetch (POLY ALIST) of POLY) when (LESSP (CDR PAIR) 0) do (RETURN PAIR))) (SETQ COEF (MINUS (CDR WINNING-PAIR)))) (T (RETURN NIL))) (COND ((AND (NOT (BM-MATCH (fetch (POLY LITERALS) of POLY) (LIST (NOT (EQUAL & &))))) (EQUAL 0 (REMAINDER (fetch (POLY CONSTANT) of POLY) COEF)) (for PAIR in (fetch (POLY ALIST) of POLY) always (EQUAL 0 (REMAINDER (CDR PAIR) COEF)))) (* We know that the polys in this pot list were formed from the current CL with  the ADD-TERMS-TO-POT-LST FLG=NIL. That is, the literals of the clause were  stored by LINEARIZE with their original parities, even though the poly was  generated from their negations. *) (RETURN (CONS (CONS (CAR WINNING-PAIR) (COND ((EQ PARITY (QUOTE POSITIVE)) 1) (T -1))) (create POLY CONSTANT _ (QUOTIENT (fetch (POLY CONSTANT) of POLY) COEF) ALIST _ (for PAIR in (fetch (POLY ALIST) of POLY) collect (CONS (CAR PAIR) (QUOTIENT (CDR PAIR) COEF))) ASSUMPTIONS _ (fetch (POLY ASSUMPTIONS) of POLY) LITERALS _ (fetch (POLY LITERALS) of POLY) LEMMAS _ (fetch (POLY LEMMAS) of POLY))))) (T (RETURN NIL]) (TRUE-POLYP [LAMBDA (POLY) (* kbr: "19-Oct-85 16:31") (AND (LESSEQP (fetch (POLY CONSTANT) of POLY) 0) (for PAIR in (fetch (POLY ALIST) of POLY) always (LESSEQP (CDR PAIR) 0]) (TYPE-ALIST-CLAUSE [LAMBDA (CL) (* kbr: "19-Oct-85 16:31") (LET ((TYPE-ALIST TYPE-ALIST)) (for LIT in CL while (NEQ TYPE-ALIST (QUOTE CONTRADICTION)) do (ASSUME-TRUE-FALSE LIT) (COND (MUST-BE-TRUE (SETQ TYPE-ALIST (QUOTE CONTRADICTION))) (MUST-BE-FALSE NIL) (T (SETQ TYPE-ALIST FALSE-TYPE-ALIST)))) TYPE-ALIST]) (TYPE-PRESCRIPTION-LEMMAP [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (LET (ATM) (COND ((for TUPLE in (GET1 NAME (QUOTE LOCAL-UNDO-TUPLES)) thereis (BM-MATCH TUPLE (CONS (QUOTE TYPE-PRESCRIPTION-LST) (CONS ATM &)))) ATM) (T NIL]) (TYPE-SET [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (PAIR TYPE-ARG1 TYPE-ARG2 ARG1 ARG2) (COND ((SETQ TEMP-TEMP (SASSOC TERM TYPE-ALIST)) (CDR TEMP-TEMP)) ((VARIABLEP TERM) TYPE-SET-UNKNOWN) ((FQUOTEP TERM) (CAR (TYPE-PRESCRIPTION (FN-SYMB0 (CADR TERM))))) ((SETQ PAIR (ASSOC (FFN-SYMB TERM) RECOGNIZER-ALIST)) (SETQ TYPE-ARG1 (TYPE-SET (FARGN TERM 1))) (COND ((IEQP 0 (LOGAND TYPE-ARG1 (CDR PAIR))) TYPE-SET-FALSE) ((LOGSUBSETP TYPE-ARG1 (CDR PAIR)) TYPE-SET-TRUE) (T TYPE-SET-BOOLEAN))) ((BM-MATCH TERM (EQUAL ARG1 ARG2)) (SETQ TYPE-ARG1 (TYPE-SET ARG1)) (SETQ TYPE-ARG2 (TYPE-SET ARG2)) (COND ((IEQP 0 (LOGAND TYPE-ARG1 TYPE-ARG2)) TYPE-SET-FALSE) ((AND (IEQP TYPE-ARG1 TYPE-ARG2) (MEMBER TYPE-ARG1 SINGLETON-TYPE-SETS)) TYPE-SET-TRUE) (T TYPE-SET-BOOLEAN))) ((BM-MATCH TERM (NOT ARG1)) (SETQ TYPE-ARG1 (TYPE-SET ARG1)) (COND ((IEQP TYPE-ARG1 TYPE-SET-FALSE) TYPE-SET-TRUE) ((NOT (LOGSUBSETP TYPE-SET-FALSE TYPE-ARG1)) TYPE-SET-FALSE) (T TYPE-SET-BOOLEAN))) ((EQ (FFN-SYMB TERM) (QUOTE IF)) (ASSUME-TRUE-FALSE (FARGN TERM 1)) (COND (MUST-BE-TRUE (TYPE-SET (FARGN TERM 2))) (MUST-BE-FALSE (TYPE-SET (FARGN TERM 3))) (T (LOGOR (TYPE-SET2 (FARGN TERM 2) TRUE-TYPE-ALIST) (TYPE-SET2 (FARGN TERM 3) FALSE-TYPE-ALIST))))) ((SETQ TEMP-TEMP (TYPE-PRESCRIPTION (FFN-SYMB TERM))) (LOGOR (CAR TEMP-TEMP) (for ARG in (FARGS TERM) as FLG in (CDR TEMP-TEMP) bind (LOOP-ANS _ 0) when FLG do (SETQ LOOP-ANS (LOGOR LOOP-ANS (TYPE-SET ARG))) finally (RETURN LOOP-ANS)))) (T TYPE-SET-UNKNOWN]) (TYPE-SET2 [LAMBDA (TERM TYPE-ALIST) (* kbr: "19-Oct-85 16:31") (* This is like TYPE-SET, only it lets  you specify the local TYPE-ALIST and  protects the FALSE-TYPE-ALIST for you.  *) (LET (FALSE-TYPE-ALIST) (TYPE-SET TERM]) (UBT [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (UNDO-BACK-THROUGH NAME) NAME]) (UNBREAK-LEMMA [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (COND ((NULL NAME) (SETQ BROKEN-LEMMAS NIL)) (T (SETQ BROKEN-LEMMAS (REMOVE (ASSOC NAME BROKEN-LEMMAS) BROKEN-LEMMAS]) (UNCHANGING-VARS [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (LET (ANS) (UNCHANGING-VARS1 (EXPAND-NON-REC-FNS TERM)) ANS]) (UNCHANGING-VARS1 [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (COND ((VARIABLEP TERM) NIL) ((FQUOTEP TERM) NIL) (T (for ARG in (FARGS TERM) do (UNCHANGING-VARS1 ARG)) (COND ((OR (MEMB (FFN-SYMB TERM) *1*BTM-OBJECTS) (ASSOC (FFN-SYMB TERM) RECOGNIZER-ALIST) (for X in SHELL-POCKETS thereis (MEMB (FFN-SYMB TERM) X)) (MEMB (FFN-SYMB TERM) (QUOTE (IF EQUAL)))) NIL) ((AND (GET1 (FFN-SYMB TERM) (QUOTE SDEFN)) (NOT (DISABLEDP (FFN-SYMB TERM)))) NIL) (T (for ARG in (FARGS TERM) when (VARIABLEP ARG) do (SETQ ANS (ADD-TO-SET ARG ANS]) (UNDO-BACK-THROUGH [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (COND ((NOT (GET1 NAME (QUOTE EVENT))) (ERROR1 (PQUOTE (PROGN ATTEMPT TO UNDO A NONEVENT , (!PPR NAME NIL) %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))) (T (DREVERSE (while (AND (BOUNDP (QUOTE CHRONOLOGY)) (MEMB NAME CHRONOLOGY)) do (APPEND (UNDO-NAME (CAR CHRONOLOGY]) (UNDO-NAME [LAMBDA (NAME) (* kbr: "19-Oct-85 16:31") (LET (EVENTS) (COND ((NOT (GET1 NAME (QUOTE EVENT))) (ERROR1 (PQUOTE (PROGN ATTEMPT TO UNDO A NONEVENT , (!PPR NAME NIL) %.)) (BINDINGS (QUOTE NAME) NAME) (QUOTE SOFT))) ((EQ NAME (QUOTE GROUND-ZERO)) (SETQ EVENTS (DREVERSE (for X in CHRONOLOGY collect (GET1 X (QUOTE EVENT))))) (KILL-LIB) EVENTS) (T (SETQ EVENTS (REVERSE (DEPENDENTS-OF NAME))) (DREVERSE (for X in EVENTS collect (PROG1 (GET1 X (QUOTE EVENT)) (KILL-EVENT X]) (UNION-EQUAL [LAMBDA (X Y) (* kbr: "19-Oct-85 16:31") (* When we moved to the 3600 we replaced calls of INTERLISP's UNIONQ --  which uses EQUAL -- with our own UNION-EQUAL because Zetalisp's UNIONQ uses EQ.  Some calls of INTERLISP's UNIONQ were allowed to remain UNIONs because we could  convince ourselves that only atoms were involved.  However, on questionable cases we went ahead and used UNION-EQUAL.  Thus, some calls of UNION-EQUAL could be replaced by UNION.  The main place is when dealing with lemmas used, where inside the simpblock we  permit listp names. Seeing a call of UNION-EQUAL in such a situation is not to  be taken as a claim that listp names are present we just didn't trace it out.  *) (NCONC (for Z in X unless (MEMBER Z Y) collect Z) Y]) (UNPRETTYIFY [LAMBDA (TERM) (* kbr: "19-Oct-85 16:31") (* This function returns a list of pairs  (hyps) such that the conjunction of all (IMPLIES hyps concl) is equivalent to  TERM. hyps is a list of hypotheses, implicitly conjoined.  concl does not begin with an AND or IMPLIES.  *) (LET (C1 C2 HYP CONCL) (COND ((BM-MATCH TERM (AND C1 C2)) (APPEND (UNPRETTYIFY C1) (UNPRETTYIFY C2))) ((BM-MATCH TERM (IMPLIES HYP CONCL)) (SETQ HYP (FLATTEN-ANDS-IN-LIT HYP)) (for PAIR in (UNPRETTYIFY CONCL) collect (CONS (APPEND HYP (CAR PAIR)) (CDR PAIR)))) (T (LIST (CONS NIL TERM]) (VARIANTP [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (AND (ONE-WAY-UNIFY TERM1 TERM2) (for PAIR in UNIFY-SUBST always (VARIABLEP (CDR PAIR))) (NO-DUPLICATESP (for PAIR in UNIFY-SUBST collect (CDR PAIR]) (WORSE-THAN [LAMBDA (TERM1 TERM2) (* kbr: "22-Oct-85 15:47") (* Is TERM1 syntactically worse than  TERM2? *) (COND ((QUICK-WORSE-THAN TERM1 TERM2) T) ((VARIABLEP TERM1) NIL) ((FQUOTEP TERM1) NIL) (T (for ARG in (FARGS TERM1) thereis (SOME-SUBTERM-WORSE-THAN-OR-EQUAL ARG TERM2]) (WORSE-THAN-OR-EQUAL [LAMBDA (TERM1 TERM2) (* kbr: "19-Oct-85 16:31") (OR (EQUAL TERM1 TERM2) (WORSE-THAN TERM1 TERM2]) (WRAPUP [LAMBDA (WON-FLG) (* kbr: "19-Oct-85 20:15") (COND ((NEQ LEMMA-STACK ORIG-LEMMA-STACK) (ITERPRI T) (ERROR1 (PQUOTE (PROGN WRAPUP FOUND A NON-TRIVIAL LEMMA-STACK !)) (BINDINGS) (QUOTE HARD)))) (COND ((NEQ LINEARIZE-ASSUMPTIONS-STACK ORIG-LINEARIZE-ASSUMPTIONS-STACK) (ITERPRI T) (ERROR1 (PQUOTE (PROGN WRAPUP FOUND A NON-TRIVIAL LINEARIZE-ASSUMPTIONS-STACK !)) (BINDINGS) (QUOTE HARD)))) (COND (WON-FLG (SETQ FAILED-THMS (REMOVE ORIGTHM FAILED-THMS)) (SETQ PROVED-THMS (CONS ORIGTHM PROVED-THMS)))) (IO (QUOTE FINISHED) NIL NIL NIL (LIST WON-FLG)) (RETFROM (QUOTE PROVE) (COND (WON-FLG (QUOTE PROVED)) (T NIL]) (XXXJOIN [LAMBDA (FN X) (* kbr: "19-Oct-85 16:31") (COND ((OR (NLISTP X) (NLISTP (CDR X))) (ERROR1 (PQUOTE (PROGN XXXJOIN MUST NOT BE CALLED ON A LIST WITH LESS THAN 2 ELEMENTS %.)) NIL (QUOTE HARD))) ((NLISTP (CDDR X)) (CONS-TERM FN X)) (T (CONS-TERM FN (LIST (CAR X) (XXXJOIN FN (CDR X]) (ZERO-POLY [LAMBDA (LIT) (* kbr: "19-Oct-85 16:31") (create POLY CONSTANT _ 0 LITERALS _ (LIST LIT]) ) (RPAQQ EVENTSCOMS ((* EVENTS *) (FNS BOOT-STRAP ADD-AXIOM ADD-SHELL DCL DEFN DEFN& DISABLE ENABLE PROVE-LEMMA PROVE-LEMMA& REFLECT TOGGLE) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA TOGGLE REFLECT PROVE-LEMMA ENABLE DISABLE DEFN DCL ADD-SHELL ADD-AXIOM) (NLAML) (LAMA))))) (* EVENTS *) (DEFINEQ (BOOT-STRAP [LAMBDA NIL (* kbr: "19-Oct-85 18:14") (LET ((IN-BOOT-STRAP-FLG T)) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE BOOT-STRAP))) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME (ARITY-ALIST (QUOTE ((NOT . 1) (AND . 2) (OR . 2) (IMPLIES . 2) (LESSP . 2) (PLUS . 2))))) (BOOT-STRAP0) (CREATE-EVENT (QUOTE GROUND-ZERO) (LIST (QUOTE BOOT-STRAP))) (ADD-FACT (QUOTE IF) (QUOTE LISP-CODE) (QUOTE *1*IF)) (ADD-FACT (QUOTE EQUAL) (QUOTE LISP-CODE) (QUOTE *1*EQUAL)) (ADD-FACT (QUOTE IF) (QUOTE TYPE-PRESCRIPTION-LST) (CONS (QUOTE GROUND-ZERO) (QUOTE (0 NIL T T)))) (ADD-FACT (QUOTE EQUAL) (QUOTE TYPE-PRESCRIPTION-LST) (CONS (QUOTE GROUND-ZERO) (CONS TYPE-SET-BOOLEAN (QUOTE (NIL NIL))))) (ADD-FACT (QUOTE COUNT) (QUOTE LISP-CODE) (QUOTE *1*COUNT)) (ADD-FACT (QUOTE COUNT) (QUOTE TYPE-PRESCRIPTION-LST) (CONS (QUOTE GROUND-ZERO) (CONS TYPE-SET-NUMBERS (QUOTE (NIL))))) (for INSTR in BOOT-STRAP-INSTRS do (APPLY (CAR INSTR) (CDR INSTR))) (SETQ FAILED-THMS NIL) (QUOTE GROUND-ZERO]) (ADD-AXIOM [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (NAME TYPES TERM) (LET ((IN-ADD-AXIOM-FLG T)) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE ADD-AXIOM) NAME TYPES TERM)) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME) (CHK-ACCEPTABLE-LEMMA NAME TYPES TERM) (CREATE-EVENT NAME (LIST (QUOTE ADD-AXIOM) NAME TYPES TERM)) (ADD-FACT NIL (QUOTE NONCONSTRUCTIVE-AXIOM-NAMES) NAME) (ADD-LEMMA0 NAME TYPES TERM) (DEPEND NAME (ALL-FNNAMES (TRANSLATE TERM))) NAME] (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$]) (ADD-SHELL [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE ADD-SHELL) SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES)) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME) (CHK-ACCEPTABLE-SHELL SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (CREATE-EVENT SHELL-NAME (LIST (QUOTE ADD-SHELL) SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) ) (ADD-SHELL0 SHELL-NAME BTM-FN-SYMB RECOGNIZER DESTRUCTOR-TUPLES) (DEPEND SHELL-NAME (SET-DIFF (UNIONQ (for X in DESTRUCTOR-TUPLES bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (CDR (CADR X)) LOOP-ANS)) finally (RETURN LOOP-ANS)) (for X in DESTRUCTOR-TUPLES bind LOOP-ANS do (SETQ LOOP-ANS (ADD-TO-SET (CADDR X) LOOP-ANS)) finally (RETURN LOOP-ANS))) (COND (BTM-FN-SYMB (LIST BTM-FN-SYMB RECOGNIZER)) (T (LIST RECOGNIZER))))) (* Make the shell depend on every fn  used in the type restrictions and  defaults except the BTM-FN-SYMB and  RECOGNIZER of this type.  *) SHELL-NAME] (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$]) (DCL [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (NAME ARGS) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE DCL) NAME ARGS)) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME) (CHK-ACCEPTABLE-DCL NAME ARGS) (CREATE-EVENT NAME (LIST (QUOTE DCL) NAME ARGS)) (DCL0 NAME ARGS) NAME] (pop $FEXPR$) (pop $FEXPR$]) (DEFN [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (NAME ARGS BODY RELATION-MEASURE-LST) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE DEFN) NAME ARGS BODY RELATION-MEASURE-LST)) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME) (CHK-ACCEPTABLE-DEFN NAME ARGS BODY RELATION-MEASURE-LST) (CREATE-EVENT NAME (COND (RELATION-MEASURE-LST (LIST (QUOTE DEFN) NAME ARGS BODY RELATION-MEASURE-LST)) (T (LIST (QUOTE DEFN) NAME ARGS BODY)))) (DEFN0 NAME ARGS BODY RELATION-MEASURE-LST NIL) (DEPEND NAME (REMOVE NAME (UNIONQ (ALL-FNNAMES (TRANSLATE BODY)) (UNIONQ ALL-LEMMAS-USED (for TEMP in (GETPROP NAME (QUOTE JUSTIFICATIONS)) bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (COND ((NULL (fetch (JUSTIFICATION RELATION) of TEMP)) NIL) (T (UNIONQ (ALL-FNNAMES (fetch (JUSTIFICATION MEASURE-TERM) of TEMP)) (ADD-TO-SET (fetch (JUSTIFICATION RELATION) of TEMP) (fetch (JUSTIFICATION LEMMAS) of TEMP))))) LOOP-ANS)) finally (RETURN LOOP-ANS)))))) (PRINT-DEFN-MSG NAME ARGS) (DEFN-WRAPUP (TOTAL-FUNCTIONP NAME)) (COND ((TOTAL-FUNCTIONP NAME) NAME) (T NIL] (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$]) (DEFN& [LAMBDA (NAME) (* kbr: "29-Jun-86 16:14") (PROG (FORM) (for PROP in LIB-PROPS do (REMPROP NAME PROP)) (PUTD (PACK* (QUOTE *1*) NAME) NIL) (SETQ FORM (CONS (QUOTE DEFN) (CONS NAME (GETPROP NAME (QUOTE DEFN))))) (SHOWPRINT FORM) (EVAL FORM]) (DISABLE [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (OLDNAME) (APPLY (FUNCTION TOGGLE) (LIST (MAKE-NEW-NAME) OLDNAME T] (pop $FEXPR$]) (ENABLE [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (OLDNAME) (APPLY (FUNCTION TOGGLE) (LIST (MAKE-NEW-NAME) OLDNAME NIL] (pop $FEXPR$]) (PROVE-LEMMA [NLAMBDA $FEXPR$ (* kbr: "19-Apr-86 18:10") ([LAMBDA (NAME TYPES TERM HINTS) (LET ((IN-PROVE-LEMMA-FLG T)) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE PROVE-LEMMA) NAME TYPES TERM HINTS)) T (QUOTE C) NIL T T))) (T (LET (PROVE-ANS MAIN-EVENT-NAME) (CHK-ACCEPTABLE-LEMMA NAME TYPES TERM) (CHK-ACCEPTABLE-HINTS HINTS) (NLSETQ (PROGN (* Before calling PROVE we call APPLY-HINTS.  APPLY-HINTS sets some global variables that affect the theorem-prover.  We enter an UNWIND-PROTECT here so that we can set those variables to their  standard default values no matter how we exit PROVE.  *) (SETQ PROVE-ANS (PROVE (APPLY-HINTS HINTS TERM))) (COND (PROVE-ANS (CREATE-EVENT NAME (COND (HINTS (LIST (QUOTE PROVE-LEMMA) NAME TYPES TERM HINTS)) (T (LIST (QUOTE PROVE-LEMMA) NAME TYPES TERM)))) (ADD-LEMMA0 NAME TYPES TERM) (DEPEND NAME (UNIONQ ALL-LEMMAS-USED (UNIONQ (  EXTRACT-DEPENDENCIES-FROM-HINTS HINTS) (ALL-FNNAMES (TRANSLATE TERM))))))) (COND (PROVE-ANS NAME) (T NIL))) (for X in HINT-VARIABLE-ALIST do (SET (CADR X) (CADDDR X] (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$]) (PROVE-LEMMA& [LAMBDA (NAME) (* kbr: "29-Jun-86 16:16") (PROG (FORM) (SETQ FORM (CONS (QUOTE PROVE-LEMMA) (CONS NAME (GETPROP NAME (QUOTE PROVE-LEMMA))))) (SHOWPRINT FORM T) (EVAL FORM]) (REFLECT [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE REFLECT) NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST)) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME) (DEFN-SETUP (LIST (QUOTE REFLECT) NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST)) (CHK-ACCEPTABLE-REFLECT NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST) (CREATE-EVENT NAME (COND (RELATION-MEASURE-LST (LIST (QUOTE REFLECT) NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST)) (T (LIST (QUOTE REFLECT) NAME SATISFACTION-LEMMA-NAME)))) (REFLECT0 NAME SATISFACTION-LEMMA-NAME RELATION-MEASURE-LST NIL) (DEPEND NAME (REMOVE NAME (ADD-TO-SET SATISFACTION-LEMMA-NAME (UNION-EQUAL ALL-LEMMAS-USED (for TEMP in (GETPROP NAME (QUOTE JUSTIFICATIONS)) bind LOOP-ANS do (SETQ LOOP-ANS (UNIONQ (COND ((NULL (fetch (JUSTIFICATION RELATION) of TEMP)) NIL) (T (UNIONQ (ALL-FNNAMES (fetch (JUSTIFICATION MEASURE-TERM) of TEMP)) (ADD-TO-SET (fetch ( JUSTIFICATION RELATION) of TEMP) (fetch (JUSTIFICATION LEMMAS) of TEMP))))) LOOP-ANS)) finally (RETURN LOOP-ANS)))))) (PRINT-DEFN-MSG NAME (CADR (GETPROP NAME (QUOTE SDEFN)))) (DEFN-WRAPUP (TOTAL-FUNCTIONP NAME)) (COND ((TOTAL-FUNCTIONP NAME) NAME) (T NIL] (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$]) (TOGGLE [NLAMBDA $FEXPR$ (* kbr: "19-Oct-85 16:31") ([LAMBDA (NAME OLDNAME FLG) (COND ((NOT IN-REDO-UNDONE-EVENTS-FLG) (CAR (REDO-UNDONE-EVENTS (LIST (LIST (QUOTE TOGGLE) NAME OLDNAME FLG)) T (QUOTE C) NIL T T))) (T (LET (MAIN-EVENT-NAME) (CHK-ACCEPTABLE-TOGGLE NAME OLDNAME FLG) (CREATE-EVENT NAME (LIST (QUOTE TOGGLE) NAME OLDNAME FLG)) (ADD-FACT NIL (QUOTE DISABLED-LEMMAS) (CONS OLDNAME (CONS NAME FLG))) (DEPEND NAME (LIST (MAIN-EVENT-OF OLDNAME))) NAME] (pop $FEXPR$) (pop $FEXPR$) (pop $FEXPR$]) ) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA TOGGLE REFLECT PROVE-LEMMA ENABLE DISABLE DEFN DCL ADD-SHELL ADD-AXIOM) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (RPAQQ GENFACTCOMS ((* GENFACT *) (FNS GENERATE-ADD-FACT-PART GENERATE-ADD-SUB-FACT1 GENERATE-SUB-FACT-PART GENERATE-UNDO-TUPLE-PART))) (* GENFACT *) (DEFINEQ (GENERATE-ADD-FACT-PART [LAMBDA (ALIST) (* kbr: "29-Oct-85 13:51") (LET (!SINGLE-PROPS! !ADDITIVE-PROPS! !ADDITIVE-VARS! !SINGLE-VARS!) (SETQ !SINGLE-PROPS! (for X in ALIST when (AND (EQ (CADR X) (QUOTE SINGLE)) (EQ (CADDR X) (QUOTE PROPERTY))) collect (CAR X))) (SETQ !ADDITIVE-PROPS! (for X in ALIST when (AND (EQ (CADR X) (QUOTE ADDITIVE)) (EQ (CADDR X) (QUOTE PROPERTY))) collect (CAR X))) (SETQ !ADDITIVE-VARS! (for X in ALIST when (AND (EQ (CADR X) (QUOTE ADDITIVE)) (EQ (CADDR X) (QUOTE VARIABLE))) collect (CAR X))) (SETQ !SINGLE-VARS! (for X in ALIST when (AND (EQ (CADR X) (QUOTE SINGLE)) (EQ (CADDR X) (QUOTE VARIABLE))) collect (CAR X))) (BQUOTE (PROGN (COND ((NULL VAL) (ERROR1 (PQUOTE (PROGN ATTEMPT TO DO AN ADD-FACT WITH VALUE (!PPR NIL NIL) ON (!PPR PROP NIL) AND (!PPR ATM NIL) %.)) (BINDINGS (QUOTE PROP) PROP (QUOTE ATM) ATM) (QUOTE HARD)))) (SELECTQ PROP ((\, !SINGLE-PROPS!) (COND ((GETPROP ATM PROP) (ERROR1 (PQUOTE (PROGN ATTEMPT TO SMASH EXISTING SINGLE PROPERTY FACT HUNG UNDER (!PPR PROP NIL) OF (!PPR ATM NIL) %.)) (BINDINGS (QUOTE PROP) PROP (QUOTE ATM) ATM) (QUOTE HARD)))) (PUT1 ATM VAL PROP)) ((\, !ADDITIVE-PROPS!) (PUT1 ATM (CONS VAL (GETPROP ATM PROP)) PROP)) (DCELL (COND ((GETD ATM) (ERROR1 (PQUOTE (PROGN ATTEMPT TO SMASH EXISTING LISP DEFINITION CELL OF THE FUNCTION (!PPR ATM NIL) %.)) (BINDINGS (QUOTE ATM) ATM) (QUOTE HARD))) (T (PUTD1 ATM VAL)))) ((\, !ADDITIVE-VARS!) (OR (NULL ATM) (ERROR1 (PQUOTE (PROGN ADD-SUB-FACT MUST NOT BE CALLED WITH PROP SET TO A VARIABLE NAME WHILE ATM IS NON-NIL BECAUSE IT CONFUSES THE UNDO INFORMATION %.)) NIL (QUOTE HARD))) (SET PROP (CONS VAL (EVALV PROP)))) ((\, !SINGLE-VARS!) (OR (NULL ATM) (ERROR1 (PQUOTE (PROGN ADD-SUB-FACT MUST NOT BE CALLED WITH PROP SET TO A VARIABLE NAME WHILE ATM IS NON-NIL BECAUSE IT CONFUSES THE UNDO INFORMATION %.)) NIL (QUOTE HARD))) (COND ((BOUNDP PROP) (ERROR1 (PQUOTE (PROGN ATTEMPT TO SMASH EXISTING SINGLE VARIABLE (\, (!PPR PROP NIL)) %.)) (BINDINGS (QUOTE PROP) PROP) (QUOTE HARD)))) (SET PROP VAL)) (ERROR1 (PQUOTE (PROGN ADD-SUB-FACT HAS BEEN CALLED ON A PROPERTY OR VARIABLE NAME NAMELY (\, (!PPR PROP NIL)) THAT WAS NOT DECLARED !)) (BINDINGS (QUOTE PROP) PROP) (QUOTE HARD]) (GENERATE-ADD-SUB-FACT1 [LAMBDA (ALIST) (* kbr: "24-Oct-85 16:35") (COND ((AND (for X in (QUOTE (IDATE SATELLITES MAIN-EVENT EVENT LOCAL-UNDO-TUPLES)) always (AND (SETQ TEMP-TEMP (ASSOC X ALIST)) (BM-MATCH (CDR TEMP-TEMP) (LIST (QUOTE HIDDEN) (QUOTE PROPERTY))))) (BM-MATCH (ASSOC (QUOTE CHRONOLOGY) ALIST) (LIST (QUOTE CHRONOLOGY) (QUOTE HIDDEN) (QUOTE VARIABLE))) (for X in ALIST never (AND (EQ (CADR X) (QUOTE HIDDEN)) (NOT (MEMB (CAR X) (QUOTE (IDATE SATELLITES MAIN-EVENT EVENT LOCAL-UNDO-TUPLES CHRONOLOGY))))))) (SUB-PAIR (QUOTE (!LIB-PROPS! !LIBVARS! !SUBTRACT-FACT! !UNDO-TUPLE! !ADD-FACT!)) (LIST (DREVERSE (for X in ALIST when (EQ (CADDR X) (QUOTE PROPERTY)) collect (CAR X))) (for X in ALIST when (EQ (CADDR X) (QUOTE VARIABLE)) collect (CAR X)) (GENERATE-SUB-FACT-PART ALIST) (GENERATE-UNDO-TUPLE-PART ALIST) (GENERATE-ADD-FACT-PART ALIST)) (QUOTE (COND (INIT (INIT-LIB (QUOTE !LIB-PROPS!) (QUOTE !LIBVARS!))) (TUPLE !SUBTRACT-FACT!) (T (COND ((OR (EQ MAIN-EVENT-NAME (QUOTE GROUND-ZERO)) (AND (OR (EQ MAIN-EVENT-NAME ATM) (AND ATM (EQ MAIN-EVENT-NAME (GETPROP ATM (QUOTE MAIN-EVENT ))))) (NEQ PROP (QUOTE DCELL)))) NIL) (T (PUT1 MAIN-EVENT-NAME (CONS !UNDO-TUPLE! (GETPROP MAIN-EVENT-NAME (QUOTE LOCAL-UNDO-TUPLES ))) (QUOTE LOCAL-UNDO-TUPLES)))) !ADD-FACT!))))) (T (ERROR (QUOTE (THE USER MUST DECLARE ALL THE BUILT-IN EVENT LEVEL PROPERTIES AND VARIABLES AS HIDDEN AND MUST NOT DECLARE ANY OTHER HIDDEN DATA.]) (GENERATE-SUB-FACT-PART [LAMBDA (ALIST) (* kbr: "20-Apr-86 18:39") (SUBST (CONS (QUOTE SELECTQ) (CONS (QUOTE PROP) (NCONC1 (for X in ALIST when (EQ (CADR X) (QUOTE ADDITIVE)) collect (LIST (CAR X) (CADDDR X))) NIL))) (QUOTE !VAL-NAME!) (QUOTE (LET (ATM PROP VAL-NAME VAL TEMP) (COND ((NLISTP TUPLE) (SETQ PROP TUPLE) (SET PROP NIL)) ((NLISTP (CDR TUPLE)) (SETQ PROP (CAR TUPLE)) (SETQ ATM (CDR TUPLE)) (COND ((EQ PROP (QUOTE DCELL)) (PUTD1 ATM NIL)) (T (PUTPROP ATM PROP NIL)))) (T (SETQ PROP (CAR TUPLE)) (SETQ ATM (CADR TUPLE)) (SETQ VAL-NAME (CDDR TUPLE)) (* In the following (and in the LET above) TEMP was introduced to skirt a bug in the Release 5.0 compiler. *) (SETQ TEMP (FOR VAL IN (COND ((NULL ATM) (EVALV PROP)) (T (GETPROP ATM PROP))) WHEN (EQUAL !VAL-NAME! VAL-NAME) DO (RETURN VAL))) (COND ((NULL TEMP) (ERROR1 (PQUOTE (PROGN IN UNDOING AN ADDITIVE ADD-FACT ON (!PPR ATM NIL) AND (!PPR PROP NIL) THE VALUE TO BE REMOVED WAS NOT FOUND %.)) (BINDINGS (QUOTE PROP) PROP (QUOTE ATM) ATM) (QUOTE WARNING)))) (COND ((NULL ATM) (SET PROP (REMOVE1 TEMP (EVALV PROP)))) (T (PUTPROP ATM PROP (REMOVE1 TEMP (GETPROP ATM PROP))))))) NIL]) (GENERATE-UNDO-TUPLE-PART [LAMBDA (ALIST) (* kbr: "19-Oct-85 16:31") (LET (!ADDITIVE! !---ADDITIVE-LST---! !SINGLE-VARS!) (SETQ !ADDITIVE! (QUOTE (!ADDITIVE-TYPE! (CONS PROP (CONS ATM !VAL-NAME!))))) (SETQ !---ADDITIVE-LST---! (for X in ALIST when (EQ (CADR X) (QUOTE ADDITIVE)) collect (SUB-PAIR (QUOTE (!ADDITIVE-TYPE! !VAL-NAME!)) (LIST (CAR X) (CADDDR X)) !ADDITIVE!))) (SETQ !SINGLE-VARS! (for X in ALIST when (AND (EQ (CADR X) (QUOTE SINGLE)) (EQ (CADDR X) (QUOTE VARIABLE))) collect (CAR X))) (BQUOTE (SELECTQ PROP (\,@ !---ADDITIVE-LST---!) ((\, !SINGLE-VARS!) PROP) (DCELL (CONS (QUOTE DCELL) ATM)) (CONS PROP ATM]) ) (RPAQQ IOCOMS ((* IO *) (FNS !CLAUSE-SET !CLAUSE EQUALITY-HYP-NO GET-SCHEMA-MEASURE-RELATION IO IO1 JUSTIFICATION-SENTENCE !LIST MAPRINEVAL NOTICE-CLAUSE PEVAL PEVAL-APPLY PEVALV PLURALP !PPR-LIST !PPR PRIN5* PRINEVAL PRINEVAL1 PRINT-DEFN-MSG TH-IFY UN-NOTICE-CLAUSE))) (* IO *) (DEFINEQ (!CLAUSE-SET [LAMBDA (CL-SET INDENT) (* kbr: "19-Oct-85 16:31") (LET ((*INDENT* (OR INDENT *INDENT*))) (SETQ LAST-CLAUSE CL-SET) (PPRINDENT (COND ((NULL CL-SET) TRUE) ((NULL (CDR CL-SET)) (PRETTYIFY-CLAUSE (CAR CL-SET))) (T (CONS (QUOTE AND) (for CL in CL-SET collect (PRETTYIFY-CLAUSE CL))))) (COND ((IEQP 0 *INDENT*) 0) (T (ADD1 *INDENT*))) 1 *FILE*) (SETQ LAST-PRINEVAL-CHAR NIL) NIL]) (!CLAUSE [LAMBDA (CL INDENT) (* kbr: "19-Oct-85 16:31") (LET ((*INDENT* (OR INDENT *INDENT*))) (SETQ LAST-CLAUSE CL) (PPRINDENT (PRETTYIFY-CLAUSE CL) (COND ((IEQP 0 *INDENT*) 0) (T (ADD1 *INDENT*))) 1 *FILE*) (SETQ LAST-PRINEVAL-CHAR NIL) NIL]) (EQUALITY-HYP-NO [LAMBDA (TERM CL) (* kbr: "19-Oct-85 16:31") (LET (HYPS) (SETQ HYPS (for LIT in CL count (BM-MATCH LIT (NOT (EQUAL & &))))) (COND ((IEQP HYPS 1) NIL) (T (ADD1 (for LIT in CL until (EQUAL LIT TERM) count (BM-MATCH LIT (NOT (EQUAL & &]) (GET-SCHEMA-MEASURE-RELATION [LAMBDA (CANDIDATE CL-SET) (* kbr: "19-Oct-85 16:31") (* Returns a list of three things. A schematic formula, using p applied to all  the vars in CL-SET, showing the induction in CANDIDATE a measure term,  indicating what decreases and the well-founded relation.  *) (LET (TERM MEASURE-ARGS FORMALS SCHEMA MEASURE RELATION) (SETQ TERM (fetch (CANDIDATE INDUCTION-TERM) of CANDIDATE)) (SETQ FORMALS (CADR (GETPROP (FFN-SYMB TERM) (QUOTE SDEFN)))) (SETQ MEASURE (fetch (JUSTIFICATION MEASURE-TERM) of (fetch (CANDIDATE JUSTIFICATION) of CANDIDATE))) (* We must instantiate the measure  term with the actuals.  *) (SETQ MEASURE-ARGS (ALL-VARS MEASURE)) (SETQ MEASURE (COND (MEASURE (SUB-PAIR-VAR-LST MEASURE-ARGS (FILTER-ARGS MEASURE-ARGS FORMALS (FARGS TERM)) MEASURE)) (T NIL))) (SETQ RELATION (fetch (JUSTIFICATION RELATION) of (fetch (CANDIDATE JUSTIFICATION) of CANDIDATE) )) (SETQ SCHEMA (CONS (QUOTE AND) (for CL in (IND-FORMULA (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of CANDIDATE) NIL (LIST (LIST (CONS (QUOTE P) (REVERSE (ALL-VARS-LST (REVERSE (APPLY (FUNCTION APPEND) CL-SET)))))))) collect (PRETTYIFY-CLAUSE CL)))) (LIST SCHEMA MEASURE RELATION]) (IO [LAMBDA (PROCESS PARENT PARENT-HIST DESCENDANTS HIST-ENTRY)(* kbr: "19-Oct-85 16:31") (LET (TIME) (SETQ TIME (TIME-IN-60THS)) (APPLY IO-FN NIL) (SETQ IOTHMTIME (PLUS IOTHMTIME (DIFFERENCE (TIME-IN-60THS) TIME))) NIL]) (IO1 [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (PROG (SO-NEXT-CONSIDER ACCUMS CROSS DEFNS DIR ELIM-LEMMAS GEN-LEMMAS HIGH-CNT INDENT KEEP LEMMAS LST MASS MERGED-CAND-CNT N NAME NAMES OBVIOUS RAW-CAND-CNT SKOS TERM1 TERM2 TERMS WINNING-CAND WON-FLG VETO-CNT BROTHER-NO MAX MEASURE RELATION SCHEMA FAVORED-CNT HYP-NO FLG *NOPOINT) (SETQ *NOPOINT T) (SETQ SO-NEXT-CONSIDER (PQUOTE (PROGN (COND ((EQ LAST-PROCESS (QUOTE POP)) %.)) // // // /# (COND ((NOT (EQ LAST-PROCESS (QUOTE STORE-SENT))) (? (SO NEXT CONSIDER) (SO LET US TURN OUR ATTENTION TO) (SO WE NOW RETURN TO)) : // // (!CLAUSE-SET CL-SET INDENT) (? (, // // NAMED) (, // // WHICH WE NAMED) (, // // WHICH IS FORMULA)) (!PPR (CAR HIST-ENTRY) NIL) ABOVE %.) ((AND (IEQP (LENGTH CL-SET) 1) (EQ LAST-CLAUSE (CAR CL-SET)))) (T SO NOW LET US (? (CONSIDER) (RETURN TO)) : // // (!CLAUSE-SET CL-SET NIL) (? (, // // NAMED) (, // // WHICH WE NAMED) (%. // // WE NAMED THIS) (%. // // WE GAVE THIS THE NAME)) (!PPR (CAR HIST-ENTRY) NIL) (? (ABOVE) NIL) %.))))) (COND ((EQ PROCESS (QUOTE SETUP)) (COND ((NOT (OPENP PROVE-FILE)) (SETQ PROVE-FILE NIL))) (SETQ CLAUSE-ALIST NIL) (SETQ LAST-PROCESS (QUOTE SETUP)) (SETQ LAST-PRINEVAL-CHAR (QUOTE %.)) (NOTICE-CLAUSE PARENT 0 (LIST NIL))) ((EQ PROCESS (QUOTE SETTLED-DOWN-CLAUSE)) (RETURN NIL)) ((EQ PROCESS (QUOTE INDUCT)) (COND ((AND (NOT LEFTMARGINCHAR) (EQ PARENT LAST-CLAUSE)) (SETQ TEMP-TEMP (UN-NOTICE-CLAUSE LAST-CLAUSE)) (SETQ CLAUSE-ALIST NIL) (COND ((AND (FIXP (CADR TEMP-TEMP)) (LESSP (CADR TEMP-TEMP) 16)) (NOTICE-CLAUSE LAST-CLAUSE (CADR TEMP-TEMP) (LIST NIL))) (T (NOTICE-CLAUSE (CAR TEMP-TEMP) 0 (LIST NIL))))) (T (SETQ CLAUSE-ALIST NIL) (NOTICE-CLAUSE PARENT 0 (LIST NIL)))))) (SETQ TEMP-TEMP (COND ((AND PARENT (NOT (MEMB PROCESS (QUOTE (POP SUBSUMED-ABOVE SUBSUMED-BY-PARENT SUBSUMED-BELOW))))) (UN-NOTICE-CLAUSE PARENT)) (T (QUOTE (NIL 0 (NIL)))))) (* The BROTHER-NO of a clause is the case number for it.  It is a list of numbers, to be printed in reverse order, separated by dots.  If the CAR of the BROTHER-NO is NIL it means do not print it.  *) (SETQ BROTHER-NO (OR (CADDR TEMP-TEMP) (LIST NIL))) (SETQ INDENT (CADR TEMP-TEMP)) (SETQ MAX (LENGTH DESCENDANTS)) (for CL in DESCENDANTS as I from MAX by -1 do (NOTICE-CLAUSE CL (COND ((IEQP MAX 1) INDENT) (T (IPLUS TREE-INDENT INDENT))) (COND ((IEQP MAX 1) (COND ((CAR BROTHER-NO) (CONS NIL BROTHER-NO)) (T BROTHER-NO))) ((CAR BROTHER-NO) (CONS I BROTHER-NO)) (T (CONS I (CDR BROTHER-NO)))))) (COND ((MEMB PROCESS EXECUTE-PROCESSES) (COND ((EQ LAST-PROCESS (QUOTE SETUP)) (SETQ LAST-CLAUSE PARENT)) (T (ITERPRIN TREE-LINES PROVE-FILE) (ISPACES (IDIFFERENCE INDENT TREE-INDENT) PROVE-FILE) (COND ((AND (NOT (EQUAL INDENT 0)) (CAR BROTHER-NO)) (IPRINC "CASE" PROVE-FILE) (for I in (REVERSE BROTHER-NO) do (IPRINC I PROVE-FILE) (IPRINC "." PROVE-FILE)))) (PRINEVAL (PQUOTE (!CLAUSE PARENT NIL)) (BINDINGS (QUOTE PARENT) PARENT) (IPLUS 5 INDENT) PROVE-FILE))))) (SELECTQ PROCESS (SIMPLIFY-CLAUSE (SETQ FLG NIL) (SETQ LEMMAS NIL) (SETQ DEFNS NIL) (for X in HIST-ENTRY do (COND ((LISTP X) (* A LISTP entry here means that PROCESS-EQUATIONAL-POLYS added an equality to  this clause. The form of X in this case is  ((FIND-EQUATIONAL-POLY lhs)), where lhs and rhs are the sides of the equation  added. In this case, ZERO is also a member of HIST-ENTRY and at the moment we  will just ignore this opportunity to make the IO fancier.  *) NIL) ((EQ X (QUOTE ZERO)) (SETQ FLG T)) ((GETPROP X (QUOTE TYPE-PRESCRIPTION-LST)) (SETQ DEFNS (CONS X DEFNS))) (T (SETQ LEMMAS (CONS X LEMMAS))))) (COND ((AND (EQ LAST-PROCESS (QUOTE SETUP)) (IEQP (LENGTH DESCENDANTS) 1) (NOT LEMMAS) (for X in DEFNS always (MEMB X (QUOTE (AND OR NOT IMPLIES)))) (NOT FLG)) (* pretend nothing happened in this  case. *) (RPLACA (CDR (ASSOC (CAR DESCENDANTS) CLAUSE-ALIST)) 0) (RETURN NIL)) (T (PRINEVAL (PQUOTE (PROGN (COND ((EQ LAST-PROCESS (QUOTE SETUP)) THIS (? (FORMULA) (CONJECTURE) NIL) SIMPLIFIES) (T (? (, // // WHICH (? (WE (@ FURTHER?) SIMPLIFY) ((@ FURTHER?) SIMPLIFIES))) (%. // // (COND ((EQ HIST-ENTRY NIL) (? NIL (OF COURSE ,))) (PARENT-HIST (? (BUT) NIL (HOWEVER)))) THIS (? (SIMPLIFIES (@ FURTHER?)) ((@ FURTHER?) SIMPLIFIES)))))) (COND (FLG , USING LINEAR ARITHMETIC (COND ((AND (NOT LEMMAS) (NOT DEFNS)) ,)))) (COND (LEMMAS (COND ((AND FLG (NOT DEFNS)) AND) (T ,)) (? ((? (APPEALING TO) (APPLYING) (REWRITING WITH)) THE (PLURAL? LEMMAS LEMMAS LEMMA)) (APPLYING) (REWRITING WITH)) (!LIST LEMMAS) ,)) (COND (DEFNS (COND ((OR FLG LEMMAS) AND) (T ,)) (? (OPENING UP) (EXPANDING) (UNFOLDING)) (? (THE (PLURAL? DEFNS FUNCTIONS FUNCTION )) (THE (PLURAL? DEFNS DEFINITIONS DEFINITION) OF) NIL) (!LIST DEFNS) ,)) (COND ((AND (NOT FLG) (EQ LEMMAS NIL) (EQ DEFNS NIL)) , (? (TRIVIALLY) (CLEARLY) (OBVIOUSLY)) ,)) TO)) (BINDINGS (QUOTE DEFNS) DEFNS (QUOTE LEMMAS) LEMMAS (QUOTE PARENT-HIST) PARENT-HIST (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE FURTHER?) (COND ((AND (NOT DESCENDANTS) (IGREATERP (LENGTH PARENT-HIST) 5)) (PQUOTE FINALLY)) ((EQ (CAAR PARENT-HIST) (QUOTE SIMPLIFY-CLAUSE)) (PQUOTE AGAIN)) ((ASSOC (QUOTE SIMPLIFY-CLAUSE) PARENT-HIST) (PQUOTE FURTHER)) (T NIL)) (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE FLG) FLG) INDENT PROVE-FILE)))) (FERTILIZE-CLAUSE (BM-MATCH HIST-ENTRY (LIST MASS CROSS DIR TERM1 TERM2 KEEP)) (SETQ HYP-NO (EQUALITY-HYP-NO (LIST (QUOTE NOT) (LIST (QUOTE EQUAL) TERM1 TERM2)) PARENT)) (OR (EQ DIR (QUOTE LEFT-FOR-RIGHT)) (swap TERM1 TERM2)) (PRINEVAL (PQUOTE (PROGN %. // // WE (? NIL NIL (NOW)) USE THE (COND (HYP-NO (@ N)) (T ABOVE)) EQUALITY HYPOTHESIS (COND ((OR MASS (NOT CROSS)) BY SUBSTITUTING) (T BY CROSS-FERTILIZING)) (!PPR TERM1 NIL) FOR (!PPR TERM2 NIL) (COND (KEEP AND KEEPING THE EQUALITY HYPOTHESIS) (T AND THROWING AWAY THE EQUALITY)) %.)) (BINDINGS (QUOTE KEEP) KEEP (QUOTE TERM2) TERM2 (QUOTE TERM1) TERM1 (QUOTE CROSS) CROSS (QUOTE MASS) MASS (QUOTE N) (TH-IFY HYP-NO) (QUOTE HYP-NO) HYP-NO) INDENT PROVE-FILE)) (ELIMINATE-DESTRUCTORS-CLAUSE (SETQ ELIM-LEMMAS NIL) (SETQ GEN-LEMMAS NIL) (for X in HIST-ENTRY do (SETQ ELIM-LEMMAS (ADD-TO-SET (CAR X) ELIM-LEMMAS)) (SETQ LST (CONS (LIST (QUOTE PROGN) (LIST (QUOTE !PPR) (KWOTE (CAR (CDDDDR X))) NIL) (PQUOTE BY) (LIST (QUOTE !PPR) (KWOTE (CADR (CDDDDR X))) NIL) (PQUOTE (PROGN TO ELIMINATE)) (LIST (QUOTE !LIST) (KWOTE (for D in (CADR X) collect (LIST (QUOTE !PPR) (KWOTE D) NIL))))) LST)) (COND ((CADDR X) (SETQ GEN-LEMMAS (UNION-EQUAL (for TERM in (CADDR X) bind LOOP-ANS do (SETQ LOOP-ANS (ADD-TO-SET (LIST (QUOTE PROGN) (PQUOTE (PROGN THE TYPE RESTRICTION LEMMA NOTED WHEN)) (FN-SYMB (ARGN TERM 1)) (PQUOTE (PROGN WAS INTRODUCED))) LOOP-ANS)) finally (RETURN LOOP-ANS)) GEN-LEMMAS)))) (SETQ GEN-LEMMAS (UNION-EQUAL (CADDDR X) GEN-LEMMAS))) (PRINEVAL (PQUOTE (PROGN %. // // (? (APPLYING) (APPEALING TO)) THE (PLURAL? ELIM-LEMMAS LEMMAS LEMMA) (!LIST ELIM-LEMMAS) , (? (WE NOW) NIL) REPLACE (!LIST LST) %. (COND (GEN-LEMMAS WE (? (USE) (RELY UPON) (EMPLOY)) (!LIST GEN-LEMMAS) TO (? (CONSTRAIN) (RESTRICT)) THE NEW (COND ((OR (CDR ELIM-LEMMAS) (CDR (CAR (CDR (CAR HIST-ENTRY))))) VARIABLES) (T VARIABLE)) %.)))) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE ELIM-LEMMAS) ELIM-LEMMAS (QUOTE GEN-LEMMAS) GEN-LEMMAS (QUOTE LST) LST) INDENT PROVE-FILE)) (GENERALIZE-CLAUSE (BM-MATCH HIST-ENTRY (LIST SKOS TERMS OBVIOUS LEMMAS)) (SETQ LST (for TERM in TERMS as VAR in SKOS collect (LIST (QUOTE PROGN) (LIST (QUOTE !PPR) (KWOTE TERM) NIL) (PQUOTE BY) (LIST (QUOTE !PPR) (KWOTE VAR) NIL)))) (COND (OBVIOUS (SETQ LEMMAS (UNION-EQUAL (for TERM in OBVIOUS bind LOOP-ANS do (SETQ LOOP-ANS (ADD-TO-SET (LIST (QUOTE PROGN) (PQUOTE (PROGN THE TYPE RESTRICTION LEMMA NOTED WHEN )) (FN-SYMB (ARGN TERM 1)) (PQUOTE (PROGN WAS INTRODUCED)) ) LOOP-ANS)) finally (RETURN LOOP-ANS)) LEMMAS)))) (PRINEVAL (PQUOTE (PROGN (? (, // // WHICH WE GENERALIZE BY) (%. // // WE WILL TRY TO PROVE THE ABOVE (? (FORMULA) ( CONJECTURE )) BY GENERALIZING IT ,)) REPLACING (!LIST LST) %. (COND (LEMMAS WE RESTRICT THE NEW (PLURAL? SKOS VARIABLES VARIABLE) BY (? (APPEALING TO) (RECALLING)) (!LIST LEMMAS) %.)))) (BINDINGS (QUOTE LEMMAS) LEMMAS (QUOTE SKOS) SKOS (QUOTE LST) LST) INDENT PROVE-FILE)) (ELIMINATE-IRRELEVANCE-CLAUSE (PRINEVAL (PQUOTE (? (, // // WHICH HAS (PLURAL? N (@ N) AN) IRRELEVANT (PLURAL? N TERMS TERM) IN IT %. BY ELIMINATING (PLURAL? N (PROGN THESE TERMS) (PROGN THE TERM)) WE GETPROP) (%. // // ELIMINATE (PLURAL? N NIL THE) IRRELEVANT (PLURAL? N TERMS TERM) %.))) (BINDINGS (QUOTE N) (IDIFFERENCE (LENGTH PARENT) (LENGTH (CAR DESCENDANTS)))) INDENT PROVE-FILE)) (STORE-SENT (NOTICE-CLAUSE PARENT INDENT BROTHER-NO) (COND ((AND PARENT (EQ LAST-PROCESS (QUOTE SETUP)) (CADR HIST-ENTRY)) (SETQ LAST-CLAUSE (CADR HIST-ENTRY)) (NOTICE-CLAUSE LAST-CLAUSE 0 (LIST NIL)))) (PRINEVAL (PQUOTE (COND ((EQ PARENT NIL) (? (, // // WHICH MEANS THE PROOF ATTEMPT HAS) (%. // // WHY SAY MORE ?) (%. // // NEED WE GO ON ?))) ((EQ LAST-PROCESS (QUOTE SETUP)) // /# (? (GIVE THE CONJECTURE THE NAME) (NAME THE CONJECTURE) (CALL THE CONJECTURE)) (!PPR (CAR HIST-ENTRY) NIL) %.) ((EQ (CAR (CDR HIST-ENTRY)) (QUOTE QUIT)) , // // WHICH WE WOULD NORMALLY TRY TO PROVE BY INDUCTION %. BUT SINCE THE DO-NOT-USE-INDUCTION-FLG HAS BEEN SET BY THE USER , THE PROOF ATTEMPT HAS) ((CAR (CDR HIST-ENTRY)) , // // WHICH WE WOULD (? (NORMALLY) (USUALLY)) PUSH AND WORK ON LATER BY INDUCTION %. BUT IF WE MUST USE INDUCTION TO PROVE THE INPUT CONJECTURE , WE PREFER TO INDUCT ON THE ORIGINAL FORMULATION OF THE PROBLEM %. THUS WE WILL DISREGARD ALL THAT WE HAVE PREVIOUSLY DONE , GIVE THE NAME (!PPR (CAR HIST-ENTRY ) NIL) TO THE ORIGINAL INPUT , AND WORK ON IT %.) (T (? (, // // WHICH WE WILL (@ FINALLY?) NAME (!PPR (CAR HIST-ENTRY) NIL) %.) (%. // // (@ FINALLY?) (? (GIVE THE ABOVE FORMULA THE NAME) (NAME THE ABOVE SUBGOAL) (CALL THE ABOVE CONJECTURE)) (!PPR (CAR HIST-ENTRY) NIL) %.))))) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE PARENT) PARENT (QUOTE FINALLY?) (COND ((IGREATERP (LENGTH PARENT-HIST) 5) (PQUOTE FINALLY)) (T NIL))) INDENT PROVE-FILE)) (POP (PRINEVAL (PQUOTE (PROGN (COND ((EQ LAST-PROCESS (QUOTE POP)) , WHICH (? (, IN TURN ,) (, CONSEQUENTLY ,) NIL) (? (ALSO) NIL)) (T // // // /# THAT)) FINISHES THE PROOF OF (!PPR (CAR HIST-ENTRY) NIL))) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE LAST-PROCESS) LAST-PROCESS) 0 PROVE-FILE)) (SUBSUMED-ABOVE (PRINEVAL (PQUOTE (PROGN (@ SO-NEXT-CONSIDER) (? (HA !) (HOW NICE !) NIL NIL NIL) THIS (? (CONJECTURE) (FORMULA) (GOAL) NIL) IS SUBSUMED BY THE (? ((? (LEMMA) (THEOREM) (GOAL)) WE NAMED (!PPR (CAR (CDR HIST-ENTRY)) NIL) AND PROVED ABOVE) (PREVIOUSLY PROVED (!PPR (CAR (CDR HIST-ENTRY)) NIL)) ((!PPR (CAR (CDR HIST-ENTRY)) NIL) , WHICH WAS PROVED ABOVE)) !)) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE SO-NEXT-CONSIDER) SO-NEXT-CONSIDER (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE CL-SET) PARENT (QUOTE LAST-CLAUSE) LAST-CLAUSE (QUOTE INDENT) 5) 0 PROVE-FILE)) (SUBSUMED-BY-PARENT (PRINEVAL (PQUOTE (PROGN (@ SO-NEXT-CONSIDER) (? (OH NO !) (OOPS !) NIL) THIS FORMULA IS SUBSUMED BY ITS PARENT , (!PPR (CAR (CDR HIST-ENTRY)) NIL) ! (? (THAT MEANS WE WOULD LOOP IF WE TRIED TO PROVE IT BY INDUCTION %.) NIL NIL))) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE SO-NEXT-CONSIDER) SO-NEXT-CONSIDER (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE CL-SET) PARENT (QUOTE LAST-CLAUSE) LAST-CLAUSE (QUOTE INDENT) 5) 0 PROVE-FILE)) (SUBSUMED-BELOW (PRINEVAL (PQUOTE (PROGN (@ SO-NEXT-CONSIDER) (? (AH HA !) (WHAT LUCK !) (YOU PROBABLY DID NOT NOTICE , BUT) (BUT) NIL) THIS CONJECTURE IS SUBSUMED BY (? (ANOTHER SUBGOAL AWAITING OUR ATTENTION , NAMELY) (THE SUBGOAL WE NAMED) (FORMULA)) (!PPR (CAR (CDR HIST-ENTRY)) NIL) ABOVE %.)) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE SO-NEXT-CONSIDER) SO-NEXT-CONSIDER (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE CL-SET) PARENT (QUOTE LAST-CLAUSE) LAST-CLAUSE (QUOTE INDENT) 5) 0 PROVE-FILE)) (INDUCT (BM-MATCH HIST-ENTRY (LIST NAME WINNING-CAND RAW-CAND-CNT MERGED-CAND-CNT VETO-CNT HIGH-CNT FAVORED-CNT)) (COND (WINNING-CAND (SETQ FLG NIL) (SETQ LEMMAS NIL) (SETQ DEFNS NIL) (for X in (fetch (JUSTIFICATION LEMMAS) of (fetch (CANDIDATE JUSTIFICATION) of WINNING-CAND)) do (COND ((EQ X (QUOTE ZERO)) (SETQ FLG T)) ((GETPROP X (QUOTE TYPE-PRESCRIPTION-LST)) (SETQ DEFNS (CONS X DEFNS))) (T (SETQ LEMMAS (CONS X LEMMAS))))) (BM-MATCH (GET-SCHEMA-MEASURE-RELATION WINNING-CAND PARENT) (LIST SCHEMA MEASURE RELATION)) (SETQ ACCUMS (SET-DIFF (fetch (CANDIDATE CHANGED-VARS) of WINNING-CAND) (ALL-VARS MEASURE))) (PRINEVAL (PQUOTE (PROGN (@ SO-NEXT-CONSIDER) (? (WE WILL TRY TO PROVE IT BY INDUCTION %.) (PERHAPS WE CAN PROVE IT BY INDUCTION %.) (LET US APPEAL TO THE INDUCTION PRINCIPLE %.) (WE WILL APPEAL TO INDUCTION %.)) (COND ((NOT (IEQP RAW-CAND-CNT 1)) (? (THERE ARE (@ RAW-CAND-CNT) PLAUSIBLE INDUCTIONS) ((@ RAW-CAND-CNT) INDUCTIONS ARE SUGGESTED BY TERMS IN THE CONJECTURE ) (THE RECURSIVE TERMS IN THE CONJECTURE SUGGEST (@ RAW-CAND-CNT) INDUCTIONS)) (COND ((IEQP RAW-CAND-CNT MERGED-CAND-CNT)) ((IEQP MERGED-CAND-CNT 1) %. HOWEVER , THEY MERGE INTO ONE LIKELY CANDIDATE INDUCTION %.) (T %. THEY MERGE INTO (@ MERGED-CAND-CNT) LIKELY CANDIDATE INDUCTIONS)) (COND ((NOT (IEQP MERGED-CAND-CNT 1)) (COND ((IEQP VETO-CNT 0) , (COND ((IEQP MERGED-CAND-CNT 2) BOTH) (T ALL)) OF WHICH ARE FLAWED %.) ((IEQP VETO-CNT MERGED-CAND-CNT) , (COND ((IEQP VETO-CNT 2) BOTH) (T ALL)) OF WHICH ARE UNFLAWED %.) ((IEQP VETO-CNT 1) %. HOWEVER , ONLY ONE IS UNFLAWED %.) (T , (@ VETO-CNT) OF WHICH ARE UNFLAWED %.)) (COND ((NOT (IEQP VETO-CNT 1)) (COND ((IEQP FAVORED-CNT 1) SO WE WILL CHOOSE THE ONE SUGGESTED BY THE LARGEST NUMBER OF NONPRIMITIVE RECURSIVE FUNCTIONS %.) (T (COND ((NOT (IEQP FAVORED-CNT VETO-CNT)) WE LIMIT OUR CONSIDERATION TO THE (@ FAVORED-CNT) SUGGESTED BY THE LARGEST NUMBER OF NONPRIMITIVE RECURSIVE FUNCTIONS IN THE CONJECTURE %.)) (COND ((IEQP HIGH-CNT 1) HOWEVER , ONE OF THESE IS MORE LIKELY THAN THE (COND ((IEQP FAVORED-CNT 2) OTHER) (T OTHERS)) %.) (T SINCE (COND ((IEQP HIGH-CNT FAVORED-CNT) (COND ((IEQP HIGH-CNT 2) BOTH) (T ALL))) (T (@ HIGH-CNT))) OF THESE ARE EQUALLY LIKELY , WE WILL CHOOSE ARBITRARILY %.))))))))) (T THERE IS ONLY ONE (? (PLAUSIBLE) (SUGGESTED)) INDUCTION %.)) WE WILL INDUCT ACCORDING TO THE FOLLOWING SCHEME (!PPR SCHEMA (PQUOTE %.)) (COND (MEASURE (@ JUSTIFICATION-SENTENCE) (PLURAL? TESTS-AND-ALISTS-LST EACH THE) INDUCTION STEP OF THE SCHEME %. (COND (ACCUMS NOTE , HOWEVER , THE INDUCTIVE (COND (INSTANCES? INSTANCES) (T INSTANCE)) CHOSEN FOR (!PPR-LIST ACCUMS) %.)) THE ABOVE INDUCTION SCHEME (? (PRODUCES) (GENERATES) (LEADS TO))) (T THIS SCHEME IS JUSTIFIED BY THE ASSUMPTION THAT (!PPR (FN-SYMB TERM) NIL) IS TOTAL %.)))) (BINDINGS (QUOTE ACCUMS) ACCUMS (QUOTE JUSTIFICATION-SENTENCE) (JUSTIFICATION-SENTENCE) (QUOTE RELATION) RELATION (QUOTE MEASURE) MEASURE (QUOTE LEMMAS) LEMMAS (QUOTE DEFNS) DEFNS (QUOTE FLG) FLG (QUOTE NUMBER) (LENGTH (fetch (JUSTIFICATION LEMMAS) of (fetch (CANDIDATE JUSTIFICATION ) of WINNING-CAND))) (QUOTE SCHEMA) SCHEMA (QUOTE FAVORED-CNT) FAVORED-CNT (QUOTE HIGH-CNT) HIGH-CNT (QUOTE MERGED-CAND-CNT) MERGED-CAND-CNT (QUOTE VETO-CNT) VETO-CNT (QUOTE RAW-CAND-CNT) RAW-CAND-CNT (QUOTE SO-NEXT-CONSIDER) SO-NEXT-CONSIDER (QUOTE TESTS-AND-ALISTS-LST) (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of WINNING-CAND) (QUOTE INSTANCES?) (OR (CDR ACCUMS) (NOT (IEQP 1 (for TA in (fetch (CANDIDATE TESTS-AND-ALISTS-LST) of WINNING-CAND) sum (LENGTH (fetch (TESTS-AND-ALISTS ALISTS) of TA)))))) (QUOTE TERM) (fetch (CANDIDATE INDUCTION-TERM) of WINNING-CAND) (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE CL-SET) PARENT (QUOTE LAST-CLAUSE) LAST-CLAUSE (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE INDENT) (IPLUS 5 INDENT)) INDENT PROVE-FILE)) (T (PRINEVAL (PQUOTE (PROGN (@ SO-NEXT-CONSIDER) SINCE THERE IS NOTHING TO INDUCT UPON , THE PROOF HAS)) (BINDINGS (QUOTE SO-NEXT-CONSIDER) SO-NEXT-CONSIDER (QUOTE LAST-PROCESS) LAST-PROCESS (QUOTE CL-SET) PARENT (QUOTE LAST-CLAUSE) LAST-CLAUSE (QUOTE HIST-ENTRY) HIST-ENTRY (QUOTE INDENT) 5) 0 PROVE-FILE)))) (SETUP (COND ((AND (IEQP (LENGTH DESCENDANTS) 1) (for X in HIST-ENTRY always (MEMB X (QUOTE (AND OR NOT IMPLIES))))) NIL) (T (PRINEVAL (PQUOTE (PROGN THIS (? (FORMULA) (CONJECTURE)) CAN BE (COND (HIST-ENTRY SIMPLIFIED , USING THE (PLURAL? HIST-ENTRY ABBREVIATIONS ABBREVIATION) (!LIST HIST-ENTRY) ,) (T PROPOSITIONALLY SIMPLIFIED)) TO)) (BINDINGS (QUOTE HIST-ENTRY) HIST-ENTRY) INDENT PROVE-FILE)))) (FINISHED (BM-MATCH HIST-ENTRY (LIST WON-FLG)) (PRINEVAL (PQUOTE (PROGN (COND ((EQ LAST-PROCESS (QUOTE POP)) %. (COND (WON-FLG Q.E.D.) (T // // (@ FAILURE-MSG)))) (T // // (COND ((EQ WON-FLG (QUOTE DEFN-OK))) (WON-FLG Q.E.D.) (T (@ FAILURE-MSG))))) // //)) (BINDINGS (QUOTE FAILURE-MSG) FAILURE-MSG (QUOTE WON-FLG) WON-FLG (QUOTE LAST-PROCESS) LAST-PROCESS) 0 PROVE-FILE)) (ERROR1 (PQUOTE (PROGN IO1 HAS BEEN GIVEN AN UNRECOGNIZED PROCESS NAMED (!PPR PROCESS NIL) %.)) (BINDINGS (QUOTE PROCESS) PROCESS) (QUOTE HARD))) (COND ((NOT (OR (MEMB PROCESS UN-PRODUCTIVE-PROCESSES) (AND (EQ PROCESS (QUOTE INDUCT)) (NOT (CADR HIST-ENTRY))) (AND (EQ PROCESS (QUOTE SETUP)) (IEQP (LENGTH DESCENDANTS) 1) (for X in HIST-ENTRY always (MEMB X (QUOTE (AND OR NOT IMPLIES))))))) (SETQ N (LENGTH DESCENDANTS)) (COND ((EQ LAST-PRINEVAL-CHAR (QUOTE %.)) (PRINEVAL (PQUOTE (? (WE THUS OBTAIN) (THE RESULT IS) (THIS PRODUCES) (THIS GENERATES) (WE WOULD THUS LIKE TO PROVE) (WE MUST THUS PROVE))) (BINDINGS) INDENT PROVE-FILE))) (COND ((NEQ LAST-PRINEVAL-CHAR (QUOTE :)) (PRINEVAL (PQUOTE (PROGN (COND ((EQUAL N 0) NIL) ((EQUAL N 1) (? (THE (? (NEW) NIL) (? (GOAL) (CONJECTURE) (FORMULA))) NIL NIL)) (T (? ((@ N) NEW (? (GOALS) (CONJECTURES) (FORMULAS))) (THE FOLLOWING (@ N) NEW (? (GOALS) (CONJECTURES) (FORMULAS)))))) :)) (BINDINGS (QUOTE N) N) INDENT PROVE-FILE))))) (COND ((AND (NOT (MEMB PROCESS UN-PRODUCTIVE-PROCESSES)) (NOT DESCENDANTS)) (ITERPRIN TREE-LINES PROVE-FILE) (PRINEVAL (PQUOTE (PROGN T %.)) (BINDINGS) (IPLUS 6 INDENT) PROVE-FILE))) (SETQ LAST-PROCESS (COND ((AND (EQ PROCESS (QUOTE SETUP)) (OR (NOT (IEQP (LENGTH DESCENDANTS) 1)) (NOT (for X in HIST-ENTRY always (MEMB X (QUOTE (AND OR NOT IMPLIES))))))) (QUOTE SETUP-AND-CLAUSIFY-INPUT)) (T PROCESS))) (RETURN NIL]) (JUSTIFICATION-SENTENCE [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (* This fn returns a sentence to be fed to PRINEVAL.  The BINDINGS must include FLG, LEMMAS, DEFNS, NUMBER, MEASURE, and RELATION.  FLG is T or NIL indicating that linear arithmetic was used.  LEMMAS and DEFNS are the list of lemmas and definitions used.  NUMBER is the length of LEMMAS plus that of DEFNS plus 1 or 0 according to FLG.  MEASURE is a term and RELATION is a fn name.  *) (PQUOTE (PROGN (COND (FLG LINEAR ARITHMETIC (COND ((AND LEMMAS DEFNS) ,) ((OR LEMMAS DEFNS) AND)))) (COND (LEMMAS THE (PLURAL? LEMMAS LEMMAS LEMMA) (!LIST LEMMAS) (COND ((AND FLG DEFNS) , AND) (DEFNS AND)))) (COND (DEFNS THE (PLURAL? DEFNS DEFINITIONS DEFINITION) OF (!LIST DEFNS))) (COND ((OR FLG LEMMAS DEFNS) (PLURAL? NUMBER (? (INFORM US) (ESTABLISH) (CAN BE USED TO (? (PROVE) (SHOW) (ESTABLISH)))) (? (ESTABLISHES) (INFORMS US) (CAN BE USED TO (? (PROVE) (SHOW) (ESTABLISH))))) THAT) (T (? (IT IS OBVIOUS THAT) (OBVIOUSLY) (CLEARLY)))) THE MEASURE (!PPR MEASURE NIL) DECREASES ACCORDING TO THE WELL-FOUNDED RELATION (!PPR RELATION NIL) IN]) (!LIST [LAMBDA (*LST*) (* kbr: "19-Oct-85 16:31") (MAPRINEVAL *LST* *INDENT* *FILE* NIL NIL (PQUOTE ,) (COND ((CDDR *LST*) (PQUOTE (PROGN , AND))) (T (PQUOTE AND]) (MAPRINEVAL [LAMBDA (*LST* *INDENT* *FILE* *LEFT* *RIGHT* *SEPR* *FINALSEPR*) (* kbr: "19-Oct-85 16:31") (AND *LEFT* (PRINEVAL1 *LEFT*)) (COND ((LISTP *LST*) (COND ((CDR *LST*) (for TAIL on *LST* do (PRINEVAL1 (CAR TAIL)) (COND ((NULL (CDR TAIL)) NIL) ((NULL (CDDR TAIL)) (AND *FINALSEPR* (PRINEVAL1 *FINALSEPR*))) (T (AND *FINALSEPR* (PRINEVAL1 *SEPR*)))))) (T (PRINEVAL1 (CAR *LST*)))))) (AND *RIGHT* (PRINEVAL1 *RIGHT*]) (NOTICE-CLAUSE [LAMBDA (CL COL BROTHER-NO) (* kbr: "19-Oct-85 16:31") (CAR (SETQ CLAUSE-ALIST (CONS (LIST CL (OR COL 0) BROTHER-NO) CLAUSE-ALIST]) (PEVAL [LAMBDA (FORM) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP FORM) (COND ((LITATOM FORM) (COND ((OR (EQ FORM NIL) (EQ FORM T)) FORM) (T (PEVALV FORM)))) ((NUMBERP FORM) FORM) (T (ERROR1 (PQUOTE (PROGN ILLEGAL PEVAL FORM , (!PPR TERM NIL) %.)) (BINDINGS (QUOTE TERM) FORM) (QUOTE HARD))))) ((OR (EQ (CAR FORM) (QUOTE PQUOTE)) (EQ (CAR FORM) (QUOTE QUOTE))) (CADR FORM)) ((MEMB (CAR FORM) PRINEVAL-FNS) (PEVAL-APPLY (CAR FORM) (for X in (CDR FORM) collect (PEVAL X)))) (T (ERROR1 (PQUOTE (PROGN ILLEGAL PEVAL FORM , (!PPR TERM NIL) %.)) (BINDINGS (QUOTE TERM) FORM) (QUOTE HARD]) (PEVAL-APPLY [LAMBDA (FN ARGS) (* kbr: "19-Oct-85 16:31") (SELECTQ FN (AND (COND ((NULL ARGS) T) ((MEMB NIL ARGS) NIL) (T (CAR (LAST ARGS))))) (OR (for X in ARGS thereis X)) (FN-SYMB (FN-SYMB (CAR ARGS))) (FFN-SYMB (FFN-SYMB (CAR ARGS))) (ARGN (ARGN (CAR ARGS) (CADR ARGS))) (FARGN (FARGN (CAR ARGS) (CADR ARGS))) (SARGS (SARGS (CAR ARGS))) (FARGS (FARGS (CAR ARGS))) (QUOTEP (QUOTEP (CAR ARGS))) (FQUOTEP (FQUOTEP (CAR ARGS))) (APPLY FN ARGS]) (PEVALV [LAMBDA (X) (* kbr: "19-Oct-85 18:25") (LET (TEMP) (COND ((SETQ TEMP (ASSOC X *ALIST*)) (CDR TEMP)) (T (ERROR1 (PQUOTE (PROGN (!PPR X NIL) IS AN UNBOUND NLISTP IN PRINEVAL !)) (LIST (CONS (QUOTE X) X)) (QUOTE HARD]) (PLURALP [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (NOT (OR (EQUAL X 1) (AND (LISTP X) (NLISTP (CDR X]) (!PPR-LIST [LAMBDA (*LST*) (* kbr: "19-Oct-85 16:31") (MAPRINEVAL (for X in *LST* collect (LIST (QUOTE !PPR) (KWOTE X) NIL)) *INDENT* *FILE* NIL NIL (PQUOTE ,) (COND ((CDDR *LST*) (PQUOTE (PROGN , AND))) (T (PQUOTE AND]) (!PPR [LAMBDA (X PUNCT) (* kbr: "19-Oct-85 16:31") (LET (NCHARS) (SETQ X (EXPAND-PPR-MACROS X)) (SETQ NCHARS (NCHARS X)) (COND ((IGREATERP (IPLUS 2 (MAX (IPOSITION *FILE* NIL NIL) *INDENT*) NCHARS) (LINEL *FILE*)) (COND ((AND (ILEQ (IPLUS *INDENT* NCHARS) (LINEL *FILE*)) (ILESSP NCHARS 25)) (ITERPRI *FILE*) (ISPACES *INDENT* *FILE*) (IPRINC X *FILE*) (AND PUNCT (PRINEVAL1 PUNCT))) (T (PRINEVAL1 (PQUOTE (PROGN : //))) (PPRINDENT X (IPLUS *INDENT* 6) (COND (PUNCT (NCHARS PUNCT)) (T 0)) *FILE*) (AND PUNCT (PRINEVAL1 PUNCT)) (ITERPRI *FILE*)))) (T (ISPACES (IDIFFERENCE *INDENT* (IPOSITION *FILE* NIL NIL)) *FILE*) (OR (IEQP (IPOSITION *FILE* NIL NIL) *INDENT*) (ISPACES 1 *FILE*)) (IPRINC X *FILE*) (AND PUNCT (PRINEVAL1 PUNCT)))) (OR PUNCT (SETQ LAST-PRINEVAL-CHAR (COND ((LISTP X) (QUOTE ")")) (T (QUOTE X)))))) NIL]) (PRIN5* [LAMBDA (X) (* kbr: "19-Oct-85 17:23") (LET (SPACES (*NOPOINT T)) (SETQ SPACES (COND ((IEQP 0 (IPOSITION *FILE* NIL NIL)) 0) ((EQ LAST-PRINEVAL-CHAR (QUOTE %.)) 2) ((EQ LAST-PRINEVAL-CHAR (QUOTE :)) 2) (T 1))) (COND ((MEMB X (QUOTE (// /# %. ! ? , :))) (COND ((EQ X (QUOTE //)) (ITERPRI *FILE*)) ((EQ X (QUOTE /#)) (ISPACES (IDIFFERENCE *INDENT* (IPOSITION *FILE* NIL NIL)) *FILE*) (ISPACES (IDIFFERENCE PARAGRAPH-INDENT 2) *FILE*) (SETQ LAST-PRINEVAL-CHAR (QUOTE %.))) ((OR (EQ X (QUOTE ,)) (EQ X (QUOTE :))) (COND ((AND (NOT (MEMB LAST-PRINEVAL-CHAR (QUOTE (%. , :)))) (NOT (IEQP 0 (IPOSITION *FILE* NIL NIL)))) (ISPACES (IDIFFERENCE *INDENT* (IPOSITION *FILE* NIL NIL)) *FILE*) (IPRINC X *FILE*) (SETQ LAST-PRINEVAL-CHAR X)))) ((OR (EQ X (QUOTE %.)) (EQ X (QUOTE !)) (EQ X (QUOTE ?))) (ISPACES (IDIFFERENCE *INDENT* (IPOSITION *FILE* NIL NIL)) *FILE*) (IPRINC X *FILE*) (SETQ LAST-PRINEVAL-CHAR (QUOTE %.))) (T (ERROR1 (PQUOTE (PROGN THE CODE FOR PRIN5* IS INCONSISTENT : THE MEMB SAYS ONE THING AND THE COND SAYS ANOTHER %.)) (BINDINGS) (QUOTE HARD))))) ((EQ X NIL) NIL) (T (ISPACES (IDIFFERENCE *INDENT* (IPOSITION *FILE* NIL NIL)) *FILE*) (COND ((IGREATERP (IPLUS (IPOSITION *FILE* NIL NIL) SPACES (NCHARS X) 1) (LINEL *FILE*)) (ITERPRI *FILE*) (ISPACES *INDENT* *FILE*)) (T (ISPACES SPACES *FILE*))) (COND ((NUMBERP X) (IPRINC X *FILE*)) (T (COND ((EQ LAST-PRINEVAL-CHAR (QUOTE %.)) (IPRINC (CHARACTER (U-CASECODE (NTHCHARCODE X 1))) *FILE*) (for I from 2 to (NCHARS X) do (IPRINC (NTHCHAR X I) *FILE*))) (T (IPRINC X *FILE*))))) (SETQ LAST-PRINEVAL-CHAR NIL))) NIL]) (PRINEVAL [LAMBDA (FORM *ALIST* *INDENT* *FILE*) (PRINEVAL1 FORM]) (PRINEVAL1 [LAMBDA (SUBFORM) (* kbr: "19-Oct-85 18:31") (COND ((NLISTP SUBFORM) (PRIN5* (COND ((FIXP SUBFORM) (SPELL-NUMBER SUBFORM)) (T SUBFORM)))) (T (SELECTQ (CAR SUBFORM) (@ (PRINEVAL1 (PEVAL (CADR SUBFORM)))) (? (for SUBFORM1 in (BM-NTH (ADD1 (RANDOM-NUMBER (LENGTH (CDR SUBFORM)))) SUBFORM) do (PRINEVAL1 SUBFORM1))) (COND (for SUBFORM1 in (CDR SUBFORM) thereis (COND ((PEVAL (CAR SUBFORM1)) (for SUBFORM2 in (CDR SUBFORM1) do (PRINEVAL1 SUBFORM2)) T)))) (PLURAL? (COND ((PLURALP (PEVAL (CADR SUBFORM))) (PRINEVAL1 (CADDR SUBFORM))) (T (PRINEVAL1 (CADDDR SUBFORM))))) (PROGN (for SUBFORM1 in (CDR SUBFORM) do (PRINEVAL1 SUBFORM1))) (PEVAL SUBFORM]) (PRINT-DEFN-MSG [LAMBDA (NAME ARGS) (* kbr: "19-Oct-85 16:31") (PROG (TEMPS MEASURE RELATION LEMMAS FLG CONCL TIME N DEFNS) (SETQ LAST-PRIN5-WORD (QUOTE %.)) (SETQ TIME (TIME-IN-60THS)) (COND (IN-BOOT-STRAP-FLG (SETQ IOTHMTIME (DIFFERENCE (TIME-IN-60THS) TIME)) (RETURN NIL))) (SETQ TEMPS (GETPROP NAME (QUOTE JUSTIFICATIONS))) (COND ((NOT (TOTAL-FUNCTIONP NAME)) (ERROR1 (PQUOTE (PROGN THE ADMISSIBILITY OF (!PPR NAME NIL) HAS NOT BEEN ESTABLISHED %. WE WILL ASSUME THAT THERE EXISTS A FUNCTION SATISFYING THIS DEFINITION %. AN INDUCTION PRINCIPLE FOR THIS FUNCTION HAS ALSO BEEN ASSUMED , CORRESPONDING TO THE OBVIOUS SUBGOAL INDUCTION FOR THE FUNCTION %. THESE ASSUMPTIONS MAY RENDER THE THEORY INCONSISTENT %. // //)) (BINDINGS (QUOTE NAME) NAME) (QUOTE WARNING))) (T (SETQ N (SUB1 (LENGTH TEMPS))) (PRINEVAL (PQUOTE (PROGN /#)) (BINDINGS) 0 PROVE-FILE) (for TEMP in TEMPS as I from 1 do (SETQ MEASURE (fetch (JUSTIFICATION MEASURE-TERM) of TEMP)) (SETQ RELATION (fetch (JUSTIFICATION RELATION) of TEMP)) (SETQ FLG NIL) (SETQ LEMMAS NIL) (SETQ DEFNS NIL) (for X in (fetch (JUSTIFICATION LEMMAS) of TEMP) do (COND ((EQ X (QUOTE ZERO)) (SETQ FLG T)) ((GETPROP X (QUOTE TYPE-PRESCRIPTION-LST)) (SETQ DEFNS (CONS X DEFNS))) (T (SETQ LEMMAS (CONS X LEMMAS))))) (PRINEVAL (PQUOTE (PROGN (COND (FINALLY? (COND ((EQUAL N 2) IN ADDITION) (T FINALLY)) ,)) (@ JUSTIFICATION-SENTENCE) EACH RECURSIVE CALL %. (COND ((EQUAL I 1) HENCE , (!PPR NAME NIL) IS ACCEPTED UNDER THE (? (PRINCIPLE OF DEFINITION) (DEFINITIONAL PRINCIPLE)) %. (COND ((EQUAL N 1) THE DEFINITION OF (!PPR NAME NIL) CAN BE JUSTIFIED IN ANOTHER WAY %.) (OTHERS THERE ARE (@ N) OTHER (? (EXPLANATIONS OF) (MEASURES AND WELL-FOUNDED FUNCTIONS EXPLAINING)) THE RECURSION ABOVE %.)))))) (BINDINGS (QUOTE N) N (QUOTE NAME) NAME (QUOTE I) I (QUOTE JUSTIFICATION-SENTENCE) (JUSTIFICATION-SENTENCE) (QUOTE RELATION) RELATION (QUOTE MEASURE) MEASURE (QUOTE DEFNS) DEFNS (QUOTE LEMMAS) LEMMAS (QUOTE FLG) FLG (QUOTE NUMBER) (LENGTH (fetch (JUSTIFICATION LEMMAS) of TEMP)) (QUOTE FINALLY?) (AND (NOT (EQUAL I 1)) (NOT (EQUAL N 1)) (EQUAL I (ADD1 N))) (QUOTE OTHERS) (GREATERP N 1)) 0 PROVE-FILE)))) (COND ((NOT (IEQP TYPE-SET-UNKNOWN (CAR (TYPE-PRESCRIPTION NAME)))) (SETQ TEMP-TEMP (CONS (DUMB-CONVERT-TYPE-SET-TO-TYPE-RESTRICTION-TERM (CAR (TYPE-PRESCRIPTION NAME)) (CONS NAME ARGS)) (for FLG in (CDR (TYPE-PRESCRIPTION NAME)) as I from 0 when FLG collect (LIST (QUOTE EQUAL) (CONS NAME ARGS) (BM-NTH I ARGS))))) (SETQ CONCL (COND ((NULL (CDR TEMP-TEMP)) (CAR TEMP-TEMP)) (T (CONS (QUOTE OR) TEMP-TEMP)))) (PRINEVAL (PQUOTE (PROGN (? (NOTE THAT) (OBSERVE THAT) (FROM THE DEFINITION WE CAN CONCLUDE THAT)) (!PPR CONCL NIL) IS A THEOREM %.)) (BINDINGS (QUOTE CONCL) CONCL) 0 PROVE-FILE))) (SETQ IOTHMTIME (DIFFERENCE (TIME-IN-60THS) TIME)) (RETURN NIL]) (TH-IFY [LAMBDA (N) (* kbr: "26-Oct-85 14:00") (SELECTQ N (1 (QUOTE FIRST)) (2 (QUOTE SECOND)) (3 (QUOTE THIRD)) (4 (QUOTE FOURTH)) (5 (QUOTE FIFTH)) (6 (QUOTE SIXTH)) (7 (QUOTE SEVENTH)) (8 (QUOTE EIGHTH)) (9 (QUOTE NINTH)) (10 (QUOTE TENTH)) (11 (QUOTE 11TH)) (12 (QUOTE 12TH)) (13 (QUOTE 13TH)) (COND ((FIXP N) (PACK (NCONC (UNPACK N) (SELECTQ (REMAINDER N 10) (1 (QUOTE ST)) (2 (QUOTE ND)) (3 (QUOTE RD)) (QUOTE TH))))) (T N]) (UN-NOTICE-CLAUSE [LAMBDA (CL) (* kbr: "26-Oct-85 13:52") (SETQ TEMP-TEMP (ASSOC CL CLAUSE-ALIST)) (COND ((NULL TEMP-TEMP) (ERROR1 (PQUOTE (PROGN UN-NOTICE-CLAUSE WAS CALLED ON A CLAUSE NOT IN CLAUSE-ALIST !)) NIL (QUOTE HARD)))) (SETQ CLAUSE-ALIST (DREMOVE TEMP-TEMP CLAUSE-ALIST)) TEMP-TEMP]) ) (RPAQQ PPRCOMS ((* BM-PPR *) (FNS PPRIND PPRPACK PPR1 PPR2 PPR22 TERPRISPACES))) (* BM-PPR *) (DEFINEQ (PPRIND [LAMBDA (FMLA LEFTMARGIN RPARCNT PPR-MACRO-LST PPRFILE) (* kbr: "20-Oct-85 16:00") (PROG (MARG2 PPR-MACRO-MEMO STARTLIST) (SETQ MARG2 (LINEL PPRFILE)) (COND ((NLISTP FMLA) (IPRIN1 FMLA PPRFILE) (RETURN NIL))) (SETQ POS (COND ((SETQ TEMP-TEMP (ASSOC PPRFILE IPOSITION-ALIST)) (CDR TEMP-TEMP)) (T 0))) (SETQ SPACELEFT (IDIFFERENCE MARG2 LEFTMARGIN)) (PPR1 FMLA (ADD1 RPARCNT)) (SETQ NEXTNODE (CDAR STARTLIST)) (SETQ NEXTIND (CAAR STARTLIST)) (SETQ PPR-MACRO-MEMO (DREVERSE PPR-MACRO-MEMO)) (SETQ NEXT-MEMO-KEY (CAR (CAR PPR-MACRO-MEMO))) (SETQ NEXT-MEMO-VAL (CDR (CAR PPR-MACRO-MEMO))) (PPR2 FMLA LEFTMARGIN RPARCNT) (IPOSITION PPRFILE POS NIL) (RETURN NIL]) (PPRPACK [LAMBDA NIL (* kbr: "19-Oct-85 16:31") (CONS (COND ((ILESSP MINREM DLHDFMLA) (SETQ REMAINDER 0) (MINUS (ADD1 MINREM))) (T (SETQ REMAINDER (IDIFFERENCE MINREM DLHDFMLA)) (ADD1 DLHDFMLA))) FMLA]) (PPR1 [LAMBDA (FMLA RPARCNT) (* kbr: "22-Oct-85 16:08") (LET (DLHDFMLA RUNFLAT MINREM L RUNSTART RUNEND (PPR-MACRO-LST PPR-MACRO-LST)) (PROG NIL (COND ((NOT (LISTP FMLA)) (SETQ NCHARS (IPLUS RPARCNT (NCHARS FMLA))) (SETQ REMAINDER (IDIFFERENCE SPACELEFT NCHARS)) (RETURN NIL))) (COND ((NLISTP (CAR FMLA)) (COND ((SETQ TEMP1 (ASSOC (CAR FMLA) PPR-MACRO-LST)) (SETQ TEMP1 (APPLY* (CDR TEMP1) FMLA)) (SETQ PPR-MACRO-MEMO (CONS (CONS FMLA TEMP1) PPR-MACRO-MEMO)) (COND ((NLISTP TEMP1) (SETQ NCHARS (IPLUS RPARCNT (NCHARS TEMP1))) (SETQ REMAINDER (IDIFFERENCE SPACELEFT NCHARS)) (RETURN NIL)) (T (SETQ FMLA TEMP1))))) (COND ((AND (EQ (QUOTE QUOTE) (CAR FMLA)) (NOT (NLISTP (CDR FMLA))) (NULL (CDDR FMLA))) (PPR1 (CADR FMLA) RPARCNT) (AND NCHARS (SETQ NCHARS (ADD1 NCHARS))) (SETQ REMAINDER (SUB1 REMAINDER)) (RETURN NIL))) (SETQ DLHDFMLA (ADD1 (NCHARS (CAR FMLA)))) (SETQ L FMLA)) (T (SETQ DLHDFMLA 0) (SETQ L (RPLACD NILCONS FMLA)) (GO OVER))) (COND ((NULL (CDR FMLA)) (SETQ NCHARS (IPLUS RPARCNT DLHDFMLA)) (SETQ REMAINDER (IDIFFERENCE SPACELEFT NCHARS)) (RETURN NIL))) OVER (SETQ RUNFLAT DLHDFMLA) (SETQ MINREM 1000) (SETQ SPACELEFT (SUB1 SPACELEFT)) LOOPFLAT (SETQ L (CDR L)) (COND ((NULL L) (SETQ SPACELEFT (ADD1 SPACELEFT)) (COND ((AND (NOT (IGREATERP RUNFLAT SPACELEFT)) (NOT (IGREATERP RUNFLAT FORCEIN))) (SETQ NCHARS RUNFLAT) (SETQ REMAINDER (IDIFFERENCE SPACELEFT RUNFLAT))) (T (SETQ STARTLIST (CONS (PPRPACK) NIL)) (SETQ ENDLIST STARTLIST) (SETQ NCHARS NIL))) (RETURN NIL))) (COND ((NLISTP L) (RPLACA (CDR DOTCONS) L) (SETQ L DOTCONS))) (COND ((NLISTP (CAR L)) (SETQ TEMP1 (NCHARS (CAR L))) (SETQ RUNFLAT (IPLUS TEMP1 (ADD1 RUNFLAT))) (SETQ TEMP1 (IDIFFERENCE SPACELEFT TEMP1)) (COND ((NULL (CDR L)) (SETQ RUNFLAT (IPLUS RPARCNT RUNFLAT)) (SETQ TEMP1 (IDIFFERENCE TEMP1 RPARCNT)))) (COND ((ILESSP TEMP1 MINREM) (SETQ MINREM TEMP1))) (GO LOOPFLAT)) (T (PPR1 (CAR L) (COND ((NULL (CDR L)) (ADD1 RPARCNT)) (T 1))) (COND ((ILESSP REMAINDER MINREM) (SETQ MINREM REMAINDER))) (COND (NCHARS (SETQ RUNFLAT (IPLUS NCHARS (ADD1 RUNFLAT))) (GO LOOPFLAT))))) (SETQ RUNSTART STARTLIST) (SETQ RUNEND ENDLIST) LOOPIND (SETQ L (CDR L)) (COND ((NULL L) (SETQ STARTLIST (CONS (PPRPACK) RUNSTART)) (SETQ ENDLIST RUNEND) (SETQ NCHARS NIL) (SETQ SPACELEFT (ADD1 SPACELEFT)) (RETURN NIL))) (COND ((NLISTP L) (RPLACA (CDR DOTCONS) L) (SETQ L DOTCONS))) (COND ((NLISTP (CAR L)) (SETQ TEMP1 (IDIFFERENCE SPACELEFT (NCHARS (CAR L)))) (COND ((NULL (CDR L)) (SETQ TEMP1 (IDIFFERENCE TEMP1 RPARCNT)))) (COND ((ILESSP TEMP1 MINREM) (SETQ MINREM TEMP1))) (GO LOOPIND))) (PPR1 (CAR L) (COND ((NULL (CDR L)) (ADD1 RPARCNT)) (T 1))) (COND ((ILESSP REMAINDER MINREM) (SETQ MINREM REMAINDER))) (COND (NCHARS) (T (RPLACD RUNEND STARTLIST) (SETQ RUNEND ENDLIST))) (GO LOOPIND]) (PPR2 [LAMBDA (FMLA MARG1 RPARCNT) (* kbr: "20-Oct-85 16:02") (PROG (NONLFLAG TEMP) (COND ((NLISTP FMLA) (PRIND FMLA PPRFILE) (RETURN NIL))) (COND ((EQ FMLA NEXT-MEMO-KEY) (SETQ FMLA NEXT-MEMO-VAL) (SETQ PPR-MACRO-MEMO (CDR PPR-MACRO-MEMO)) (SETQ NEXT-MEMO-KEY (CAR (CAR PPR-MACRO-MEMO))) (SETQ NEXT-MEMO-VAL (CDR (CAR PPR-MACRO-MEMO))) (COND ((NLISTP FMLA) (PRIND FMLA PPRFILE) (RETURN NIL))))) (COND ((AND (EQ (CAR FMLA) (QUOTE QUOTE)) (NOT (NLISTP (CDR FMLA))) (NULL (CDDR FMLA))) (PRIN1 "'" PPRFILE) (PPR2 (CADR FMLA) (ADD1 MARG1) RPARCNT) (RETURN NIL))) (COND ((EQ FMLA NEXTNODE) (SETQ MARG1 (IPLUS MARG1 (ABS NEXTIND))) (SETQ NONLFLAG (IGREATERP NEXTIND 0)) (SETQ STARTLIST (CDR STARTLIST)) (COND ((NULL STARTLIST)) (T (SETQ NEXTNODE (CDR (CAR STARTLIST))) (SETQ NEXTIND (CAR (CAR STARTLIST)))))) (T (PPR22 FMLA) (RETURN NIL))) (PRIN1 "(" PPRFILE) (COND ((NLISTP (CAR FMLA)) (PRIND (CAR FMLA) PPRFILE) (COND ((NULL (CDR FMLA)) (PRIN1 ")" PPRFILE) (RETURN NIL))) (COND ((AND (LISTP (CDR FMLA)) (OR (NLISTP (SETQ TEMP (CADR FMLA))) (AND (NOT (EQ (CADR FMLA) NEXTNODE)) (PROGN (COND ((EQ FMLA NEXT-MEMO-KEY) (SETQ TEMP NEXT-MEMO-VAL))) (OR (NLISTP TEMP) (AND (EQ (CAR TEMP) (QUOTE QUOTE)) (NOT (NLISTP (CDR TEMP))) (NLISTP (CADR TEMP)) (NULL (CDDR TEMP))))))) (ILESSP (IPLUS POS (NCHARS TEMP) RPARCNT) MARG2)) (PRIN1 " " PPRFILE) (PPR2 (CADR FMLA) MARG1 RPARCNT) (SETQ FMLA (CDR FMLA)) (GO LOOP1)) (NONLFLAG (PRIN1 " " PPRFILE)) (T (TERPRISPACES MARG1 PPRFILE))) (SETQ FMLA (CDR FMLA)))) LOOP (COND ((NLISTP FMLA) (PRIN1 "." PPRFILE) (PRIN1 " " PPRFILE) (PRIND FMLA PPRFILE) (PRIN1 ")" PPRFILE) (RETURN NIL))) (PPR2 (CAR FMLA) MARG1 (COND ((NULL (CDR FMLA)) (ADD1 RPARCNT)) (T 1))) LOOP1 (COND ((NULL (CDR FMLA)) (PRIN1 ")" PPRFILE) (RETURN NIL))) (COND ((AND (NLISTP (CAR FMLA)) (LISTP (CDR FMLA)) (OR (NLISTP (SETQ TEMP (CADR FMLA))) (AND (NOT (EQ TEMP NEXTNODE)) (PROGN (COND ((EQ FMLA NEXT-MEMO-KEY) (SETQ TEMP NEXT-MEMO-VAL))) (OR (NLISTP TEMP) (AND (EQ (CAR TEMP) (QUOTE QUOTE)) (NOT (NLISTP (CDR TEMP))) (NLISTP (CADR TEMP)) (NULL (CDDR TEMP))))))) (ILESSP (IPLUS POS (NCHARS TEMP) RPARCNT) MARG2)) (PRIN1 " " PPRFILE) (PPR2 (CADR FMLA) MARG2 RPARCNT) (SETQ FMLA (CDR FMLA)) (GO LOOP1))) (TERPRISPACES MARG1 PPRFILE) (SETQ FMLA (CDR FMLA)) (GO LOOP]) (PPR22 [LAMBDA (X) (* kbr: "19-Oct-85 16:31") (COND ((NLISTP X) (PRIND X PPRFILE)) (T (PRIN1 "(" PPRFILE) (PROG NIL LOOP (COND ((NLISTP X) (COND ((NULL X) (PRIN1 ")" PPRFILE)) (T (PRIN1 "." PPRFILE) (PRIN1 " " PPRFILE) (PRIND X PPRFILE) (PRIN1 ")" PPRFILE))) (RETURN NIL)) (T (PPR2 (CAR X) MARG2 0) (SETQ X (CDR X)) (COND ((NULL X)) (T (PRIN1 " " PPRFILE))) (GO LOOP]) (TERPRISPACES [LAMBDA (N FILE) (* kbr: "22-Oct-85 15:53") (TERPRI FILE) (for I from 1 to N do (PRIN1 " " FILE)) (SETQ POS N]) ) (FILESLOAD COMPILEBANG) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA TOGGLE REFLECT PROVE-LEMMA ENABLE DISABLE DEFN DCL ADD-SHELL ADD-AXIOM) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS BOYERMOORE COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1882 4524 (UNDEFN 1892 . 3169) (UNPROVE-LEMMA 3171 . 4522)) (38488 63236 (BM-UPCASE 38498 . 38731) (COMPILE-IF-APPROPRIATE-AND-POSSIBLE 38733 . 39901) (COPYLIST 39903 . 40148) ( EXTEND-FILE-NAME 40150 . 40408) (FIND-CHAR-IN-FILE 40410 . 41128) (FIND-STRING-IN-FILE 41130 . 42096) (GET-TOTAL-STATS 42098 . 43165) (GET-FROM-FILE 43167 . 43421) (GET-PLIST-FROM-FILE 43423 . 43796) ( GET-STATS-FILE 43798 . 44878) (BM-PRIN1 44880 . 45012) (PRINT-SYSTEM 45014 . 45416) (PRINT-DATE-LINE 45418 . 45577) (RANDOM-INITIALIZATION 45579 . 46159) (RANDOM-NUMBER 46161 . 46297) (READ-FILE 46299 . 46598) (REMQ 46600 . 46765) (STORE-DEFINITION 46767 . 46924) (SWAP-OUT 46926 . 47098) (R-LOOP 47100 . 47440) (TIME-IT 47442 . 47751) (TIME-IN-60THS 47753 . 47922) (XSEARCH 47924 . 48959) (*1*CAR 48961 . 49191) (*1*CDR 49193 . 49423) (ADD-TO-SET 49425 . 49600) (ARGN-MACRO 49602 . 50210) (BINDINGS-MACRO 50212 . 50527) (CELL 50529 . 50771) (CREATE-LEMMA-STACK 50773 . 50953) ( CREATE-LINEARIZE-ASSUMPTIONS-STACK 50955 . 51183) (CREATE-STACK1 51185 . 51603) (FARGN-MACRO 51605 . 52105) (FN-SYMB-MACRO 52107 . 52467) (HLOAD 52469 . 52883) (IPOSITION 52885 . 53445) (ITERPRI 53447 . 53605) (ITERPRIN 53607 . 53778) (ITERPRISPACES 53780 . 53944) (IPRIN1 53946 . 54122) (IPRINC 54124 . 54300) (IPRINT 54302 . 54480) (ISPACES 54482 . 54733) (KILL-DEFINITION 54735 . 54870) (LINEL 54872 . 55003) (MAKE-LIB 55005 . 57417) (MATCH-MACRO 57419 . 57806) (MATCH!-MACRO 57808 . 58022) (MATCH1-MACRO 58024 . 58547) (MATCH2-MACRO 58549 . 61263) (NOTE-LIB 61265 . 61708) (BM-NTH 61710 . 61840) ( PREPARE-FOR-THE-NIGHT 61842 . 61974) (SPELL-NUMBER 61976 . 62391) (SUB-PAIR 62393 . 62938) (UNIONQ 62940 . 63234)) (64942 186343 (*1*ADD1 64952 . 65156) (*1*AND 65158 . 65316) (*1*CONS 65318 . 65442) ( *1*COUNT 65444 . 66139) (*1*DIFFERENCE 66141 . 66387) (*1*EQUAL 66389 . 66559) (*1*FALSE 66561 . 66681 ) (*1*FALSEP 66683 . 66854) (*1*FIX 66856 . 67052) (*1*IMPLIES 67054 . 67216) (*1*LESSP 67218 . 67429) (*1*LISTP 67431 . 67670) (*1*LITATOM 67672 . 68079) (*1*MINUS 68081 . 68341) (*1*NEGATIVE-GUTS 68343 . 68551) (*1*NEGATIVEP 68553 . 68933) (*1*NLISTP 68935 . 69175) (*1*NOT 69177 . 69309) (*1*NUMBERP 69311 . 69517) (*1*OR 69519 . 69664) (*1*PACK 69666 . 70038) (*1*PLUS 70040 . 70199) (*1*QUOTIENT 70201 . 70432) (*1*REMAINDER 70434 . 70680) (*1*SUB1 70682 . 70880) (*1*TIMES 70882 . 71044) (*1*TRUE 71046 . 71165) (*1*TRUEP 71167 . 71337) (*1*UNPACK 71339 . 71805) (*1*ZERO 71807 . 71923) (*1*ZEROP 71925 . 72156) (ABBREVIATIONP 72158 . 72762) (ABBREVIATIONP1 72764 . 73224) ( ACCEPTABLE-TYPE-PRESCRIPTION-LEMMAP 73226 . 84063) (ACCESS-ERROR 84065 . 84353) (ADD-AXIOM1 84355 . 85251) (ADD-DCELL 85253 . 85482) (ADD-ELIM-LEMMA 85484 . 86309) (ADD-EQUATION 86311 . 93778) ( ADD-EQUATIONS 93780 . 95868) (ADD-EQUATIONS-TO-POT-LST 95870 . 101209) (ADD-FACT 101211 . 101421) ( ADD-GENERALIZE-LEMMA 101423 . 101703) (ADD-LEMMA 101705 . 101917) (ADD-LEMMA0 101919 . 102561) ( ADD-LESSP-ASSUMPTION-TO-POLY 102563 . 104400) (ADD-LINEAR-TERM 104402 . 107926) (ADD-LINEAR-VARIABLE 107928 . 108912) (ADD-LINEAR-VARIABLE1 108914 . 109920) (ADD-LITERAL 109922 . 110716) (ADD-META-LEMMA 110718 . 111308) (ADD-NOT-EQUAL-0-ASSUMPTION-TO-POLY 111310 . 113758) ( ADD-NOT-LESSP-ASSUMPTION-TO-POLY 113760 . 116508) (ADD-NUMBERP-ASSUMPTION-TO-POLY 116510 . 119719) ( ADD-PROCESS-HIST 119721 . 119975) (ADD-REWRITE-LEMMA 119977 . 122791) (ADD-SHELL-ROUTINES 122793 . 129115) (ADD-SHELL0 129117 . 141300) (ADD-SUB-FACT 141302 . 146290) (ADD-TERM-TO-POT-LST 146292 . 146890) (ADD-TERMS-TO-POT-LST 146892 . 153626) (ADD-TO-SET-EQ 153628 . 153810) (ADD-TYPE-SET-LEMMAS 153812 . 156061) (ALL-ARGLISTS 156063 . 157687) (ALL-FNNAMES 157689 . 157864) (ALL-FNNAMES-LST 157866 . 158072) (ALL-FNNAMES1 158074 . 158647) (ALL-FNNAMES1-EVG 158649 . 159850) (ALL-INSERTIONS 159852 . 160605) (ALL-PATHS 160607 . 167073) (ALL-PERMUTATIONS 167075 . 167661) (ALL-PICKS 167663 . 168426) ( ALL-SUBSEQUENCES 168428 . 169290) (ALL-VARS 169292 . 169929) (ALL-VARS-BAG 169931 . 170108) ( ALL-VARS-BAG1 170110 . 170406) (ALL-VARS-LST 170408 . 170904) (ALL-VARS1 170906 . 171563) ( ALMOST-SUBSUMES 171565 . 172122) (ALMOST-SUBSUMES-LOOP 172124 . 173866) (ALMOST-VALUEP 173868 . 174045 ) (ALMOST-VALUEP1 174047 . 174363) (APPLY-HINTS 174365 . 175191) (APPLY-INDUCT-HINT 175193 . 176918) ( APPLY-USE-HINT 176920 . 178814) (ARG1-IN-ARG2-UNIFY-SUBST 178816 . 179166) (ARGN0 179168 . 180054) ( ARITY 180056 . 180351) (ASSOC-OF-APPEND 180353 . 181128) (ASSUME-TRUE-FALSE 181130 . 186051) ( ATTEMPT-TO-REWRITE-RECOGNIZER 186053 . 186341)) (188185 332662 (BATCH-PROVEALL 188195 . 188720) ( BOOLEAN 188722 . 188900) (BOOT-STRAP0 188902 . 189130) (BREAK-LEMMA 189132 . 190243) (BTM-OBJECT 190245 . 190872) (BTM-OBJECT-OF-TYPE-SET 190874 . 191646) (BTM-OBJECTP 191648 . 192129) (BUILD-SUM 192131 . 192799) (CANCEL 192801 . 194837) (CANCEL-POSITIVE 194839 . 196016) (CANCEL1 196018 . 197638) (CAR-CDRP 197640 . 198154) (CDR-ALL 198156 . 198311) (CHK-ACCEPTABLE-DEFN 198313 . 200405) ( CHK-ACCEPTABLE-DCL 200407 . 201059) (CHK-ACCEPTABLE-ELIM-LEMMA 201061 . 205252) ( CHK-ACCEPTABLE-GENERALIZE-LEMMA 205254 . 205409) (CHK-ACCEPTABLE-HINTS 205411 . 212213) ( CHK-ACCEPTABLE-LEMMA 212215 . 213465) (CHK-ACCEPTABLE-META-LEMMA 213467 . 216705) ( CHK-ACCEPTABLE-REFLECT 216707 . 219132) (CHK-ACCEPTABLE-REWRITE-LEMMA 219134 . 230327) ( CHK-ACCEPTABLE-SHELL 230329 . 238499) (CHK-ACCEPTABLE-TOGGLE 238501 . 238967) (CHK-ARGLIST 238969 . 239835) (CHK-MEANING 239837 . 240460) (CHK-NEW-*1*NAME 240462 . 241433) (CHK-NEW-NAME 241435 . 243067) (CLAUSIFY 243069 . 243392) (CLAUSIFY-INPUT 243394 . 244087) (CLAUSIFY-INPUT1 244089 . 245892) ( CLEAN-UP-BRANCHES 245894 . 246322) (CNF-DNF 246324 . 248232) (COMMON-SWEEP 248234 . 249599) ( COMMUTE-EQUALITIES 249601 . 250094) (COMPARE-STATS 250096 . 258214) (COMPLEMENTARY-MULTIPLEP 258216 . 259983) (COMPLEMENTARYP 259985 . 260652) (COMPLEXITY 260654 . 261348) (COMPRESS-POLY 261350 . 261791) (COMPRESS-POLY1 261793 . 262293) (COMPUTE-VETOES 262295 . 266567) (COMSUBT1 266569 . 269576) ( COMSUBTERMS 269578 . 270156) (CONJOIN 270158 . 270441) (CONJOIN-CLAUSE-SETS 270443 . 270927) (CONJOIN2 270929 . 271927) (CONS-PLUS 271929 . 272176) (CONS-TERM 272178 . 274141) (CONSJOIN 274143 . 274427) ( CONTAINS-REWRITEABLE-CALLP 274429 . 275335) (CONVERT-CAR-CDR 275337 . 276103) (CONVERT-CONS 276105 . 276342) (CONVERT-NOT 276344 . 276609) (CONVERT-QUOTE 276611 . 277291) ( CONVERT-TYPE-NO-TO-RECOGNIZER-TERM 277293 . 277971) (BM-COUNT 277973 . 278196) (COUNT-IFS 278198 . 278590) (CREATE-REWRITE-RULE 278592 . 278907) (DCL0 278909 . 279210) (DECODE-IDATE 279212 . 279354) ( DEFN-ASSUME-TRUE-FALSE 279356 . 285727) (DEFN-LOGIOR 285729 . 285948) (DEFN-SETUP 285950 . 286746) ( DEFN-TYPE-SET 286748 . 288435) (DEFN-TYPE-SET2 288437 . 288615) (DEFN-WRAPUP 288617 . 289524) (DEFN0 289526 . 304479) (DELETE1 304481 . 304738) (DELETE-TAUTOLOGIES 304740 . 305268) (DELETE-TOGGLES 305270 . 305926) (DEPEND 305928 . 307268) (DEPENDENT-EVENTS 307270 . 307473) (DEPENDENTS-OF 307475 . 308111) (DEPENDENTS-OF1 308113 . 308773) (DESTRUCTORS 308775 . 309180) (DESTRUCTORS1 309182 . 309682) (DETACH 309684 . 309894) (DETACHED-ERROR 309896 . 310145) (DETACHEDP 310147 . 310267) (DISJOIN 310269 . 310553) (DISJOIN-CLAUSES 310555 . 311131) (DISJOIN2 311133 . 312407) (DTACK-0-ON-END 312409 . 312567) (DUMB-CONVERT-TYPE-SET-TO-TYPE-RESTRICTION-TERM 312569 . 314112) (DUMB-IMPLICATE-LITS 314114 . 314883) (DUMB-NEGATE-LIT 314885 . 315564) (DUMB-OCCUR 315566 . 315966) (DUMB-OCCUR-LST 315968 . 316149) (DUMP 316151 . 319470) (DUMP-ADD-AXIOM 319472 . 320153) (DUMP-ADD-SHELL 320155 . 322647) (DUMP-BEGIN-GROUP 322649 . 322998) (DUMP-DCL 323000 . 323544) (DUMP-DEFN 323546 . 324902) (DUMP-END-GROUP 324904 . 325280) (DUMP-HINTS 325282 . 330021) (DUMP-LEMMA-TYPES 330023 . 330847) (DUMP-OTHER 330849 . 331343) ( DUMP-PROVE-LEMMA 331345 . 332087) (DUMP-TOGGLE 332089 . 332660)) (335083 475823 (ELIMINABLE-VAR-CANDS 335093 . 335297) (ELIMINABLEP 335299 . 336045) (ELIMINATE-DESTRUCTORS-CANDIDATEP 336047 . 338796) ( ELIMINATE-DESTRUCTORS-CANDIDATES 338798 . 339363) (ELIMINATE-DESTRUCTORS-CANDIDATES1 339365 . 340162) (ELIMINATE-DESTRUCTORS-CLAUSE 340164 . 347723) (ELIMINATE-DESTRUCTORS-CLAUSE1 347725 . 348505) ( ELIMINATE-DESTRUCTORS-SENT 348507 . 348764) (ELIMINATE-IRRELEVANCE-CLAUSE 348766 . 350376) ( ELIMINATE-IRRELEVANCE-SENT 350378 . 350628) (EQUATIONAL-PAIR-FOR 350630 . 350981) (ERASE-EOL 350983 . 351119) (ERASE-EOP 351121 . 351257) (ERROR1 351259 . 353098) (EVENT-FORM 353100 . 353418) ( EVENT1-OCCURRED-BEFORE-EVENT2 353420 . 353639) (EVENTS-SINCE 353641 . 353954) (EVG 353956 . 356001) ( EVG-OCCUR-LEGAL-CHAR-CODE-SEQ 356003 . 357011) (EVG-OCCUR-NUMBER 357013 . 357903) (EVG-OCCUR-OTHER 357905 . 358611) (EXECUTE 358613 . 359031) (EXPAND-ABBREVIATIONS 359033 . 362301) (EXPAND-AND-ORS 362303 . 365041) (EXPAND-BOOT-STRAP-NON-REC-FNS 365043 . 365884) (EXPAND-NON-REC-FNS 365886 . 366609) (EXPAND-PPR-MACROS 366611 . 368185) (EXTEND-ALIST 368187 . 368822) (EXTERNAL-LINEARIZE 368824 . 369041 ) (EXTRACT-DEPENDENCIES-FROM-HINTS 369043 . 369588) (FALSE-NONFALSEP 369590 . 370372) ( FAVOR-COMPLICATED-CANDIDATES 370374 . 371022) (FERTILIZE-CLAUSE 371024 . 375319) (FERTILIZE-FEASIBLE 375321 . 376099) (FERTILIZE-SENT 376101 . 376335) (FERTILIZE1 376337 . 376902) (FILTER-ARGS 376904 . 377195) (FIND-EQUATIONAL-POLY 377197 . 380804) (FIRST-COEFFICIENT 380806 . 380980) (FIRST-VAR 380982 . 381144) (FITS 381146 . 381959) (FIXCAR-CDR 381961 . 382545) (FLATTEN-ANDS-IN-LIT 382547 . 383329) ( FLESH-OUT-IND-PRIN 383331 . 386613) (FLUSH-CAND1-DOWN-CAND2 386615 . 390867) (FN-SYMB0 390869 . 391587 ) (FNNAMEP 391589 . 392046) (FNNAMEP-IF 392048 . 392379) (FORM-COUNT 392381 . 393100) (FORM-COUNT-EVG 393102 . 394254) (FORM-COUNT1 394256 . 394619) (FORM-INDUCTION-CLAUSE 394621 . 395464) ( FORMP-SIMPLIFIER 395466 . 397366) (FORMULA-OF 397368 . 397666) (FREE-VAR-CHK 397668 . 399050) ( FREE-VARSP 399052 . 399351) (GEN-VARS 399353 . 400113) (GENERALIZE-CLAUSE 400115 . 401375) ( GENERALIZE-SENT 401377 . 401624) (GENERALIZE1 401626 . 402187) (GENERALIZE2 402189 . 402626) (GENRLT1 402628 . 403128) (GENRLTERMS 403130 . 403311) (GET-CANDS 403313 . 404177) (GET-LISP-SEXPR 404179 . 405102) (GET-LEVEL-NO 405104 . 405271) (GET-STACK-NAME 405273 . 405613) (GET-STACK-NAME1 405615 . 406042) (GET-TYPES 406044 . 408254) (GREATEREQP 408256 . 408389) (GUARANTEE-CITIZENSHIP 408391 . 408809) (GUESS-RELATION-MEASURE-LST 408811 . 409622) (HAS-LIB-PROPS 409624 . 409993) (ILLEGAL-CALL 409995 . 410238) (ILLEGAL-NAME 410240 . 410464) (IMMEDIATE-DEPENDENTS-OF 410466 . 414308) (IMPLIES? 414310 . 414444) (IMPOSSIBLE-POLYP 414446 . 414815) (IND-FORMULA 414817 . 418269) (INDUCT 418271 . 421684) (INDUCT-VARS 421686 . 422840) (INDUCTION-MACHINE 422842 . 424272) (INFORM-SIMPLIFY 424274 . 427137) (INIT-LEMMA-STACK 427139 . 427306) (INIT-LIB 427308 . 427913) ( INIT-LINEARIZE-ASSUMPTIONS-STACK 427915 . 428130) (INTERESTING-SUBTERMS 428132 . 428921) (INTERSECTP 428923 . 429084) (INTRODUCE-ANDS 429086 . 430297) (INTRODUCE-LISTS 430299 . 431324) (JUMPOUTP 431326 . 435046) (KILL-EVENT 435048 . 435584) (KILL-LIB 435586 . 436346) (KILLPROPLIST1 436348 . 436824) ( LEGAL-CHAR-CODE-SEQ 436826 . 438159) (LENGTH-TO-ATOM 438161 . 438341) (LESSEQP 438343 . 438473) ( LEXORDER 438475 . 439705) (LINEARIZE 439707 . 446713) (LISTABLE 446715 . 447267) (LOGSUBSETP 447269 . 447417) (LOOKUP-HYP 447419 . 449853) (LOOP-STOPPER 449855 . 450406) (MAIN-EVENT-OF 450408 . 450937) ( CREATE-EVENT 450939 . 451222) (MAKE-FLATTENED-MACHINE 451224 . 452685) (MAKE-NEW-NAME 452687 . 452953) (MAKE-REWRITE-RULES 452955 . 454209) (MAKE-TYPE-RESTRICTION 454211 . 455845) (MAX-FORM-COUNT 455847 . 457037) (MAXIMAL-ELEMENTS 457039 . 457599) (MEANING-SIMPLIFIER 457601 . 464013) (MEMB-NEGATIVE 464015 . 464268) (MENTIONSQ 464270 . 464522) (MENTIONSQ-LST 464524 . 464793) (MERGE-CAND1-INTO-CAND2 464795 . 469267) (MERGE-CANDS 469269 . 469578) (MERGE-DESTRUCTOR-CANDIDATES 469580 . 470564) ( MERGE-TESTS-AND-ALISTS 470566 . 472084) (MERGE-TESTS-AND-ALISTS-LSTS 472086 . 474752) (META-LEMMAP 474754 . 474921) (MULTIPLE-PIGEON-HOLE 474923 . 475821)) (477795 619591 (BM-NEGATE 477805 . 478768) ( NEGATE-LIT 478770 . 479214) (NEXT-AVAILABLE-TYPE-NO 479216 . 480143) (NO-CROWDINGP 480145 . 480631) ( NO-DUPLICATESP 480633 . 480845) (NO-OP 480847 . 480963) (NON-RECURSIVE-DEFNP 480965 . 481403) ( NORMALIZE-IFS 481405 . 484744) (NOT-EQUAL-0? 484746 . 485604) (NOT-IDENT 485606 . 486441) (NOT-LESSP? 486443 . 487129) (NOT-TO-BE-REWRITTENP 487131 . 488692) (NUMBERP? 488694 . 489087) (OBJ-TABLE 489089 . 490161) (OCCUR 490163 . 491459) (OCCUR-CNT 491461 . 492146) (OCCUR-LST 492148 . 492313) ( ONE-WAY-UNIFY 492315 . 492494) (ONE-WAY-UNIFY-LIST 492496 . 492946) (ONE-WAY-UNIFY1 492948 . 493307) ( ONE-WAY-UNIFY11 493309 . 495031) (ONEIFY 495033 . 497216) (ONEIFY-ASSUME-FALSE 497218 . 497388) ( ONEIFY-ASSUME-TRUE 497390 . 497904) (ONEIFY-TEST 497906 . 500468) (OPTIMIZE-COMMON-SUBTERMS 500470 . 508399) (PARTITION 508401 . 509036) (PARTITION-CLAUSES 509038 . 511186) (PATH-ADD-TO-SET 511188 . 511408) (PATH-EQ 511410 . 511643) (PATH-POT-SUBSUMES 511645 . 511937) (PATH-UNION 511939 . 512178) ( PEGATE-LIT 512180 . 512425) (PETITIO-PRINCIPII 512427 . 513290) (PICK-HIGH-SCORES 513292 . 513823) ( PIGEON-HOLE 513825 . 514349) (PIGEON-HOLE-IN-ALL-POSSIBLE-WAYS 514351 . 515678) (PIGEON-HOLE1 515680 . 516862) (PLUSJOIN 516864 . 517175) (POLY-MEMBER 517177 . 517627) (POP-CLAUSE-SET 517629 . 520102) ( POP-LEMMA-FRAME 520104 . 520496) (POP-LINEARIZE-ASSUMPTIONS-FRAME 520498 . 520986) (POPU 520988 . 521221) (POSSIBLE-IND-PRINCIPLES 521223 . 522473) (POSSIBLY-NUMERIC 522475 . 522722) (POWER-EVAL 522724 . 522984) (POWER-REP 522986 . 523249) (PPC 523251 . 523423) (PPE 523425 . 523556) (PPE-LST 523558 . 524581) (BM-PPR 524583 . 524784) (PPRINDENT 524786 . 525148) (PPSD 525150 . 525283) (PPSD-LST 525285 . 525680) (PREPROCESS 525682 . 526127) (PREPROCESS-HYPS 526129 . 527202) (PRETTYIFY-CLAUSE 527204 . 527752) (PRETTYIFY-LISP 527754 . 527937) (PRIMITIVE-RECURSIVEP 527939 . 528595) (PRIMITIVEP 528597 . 529046) (PRINT-STACK 529048 . 529277) (PRINT-STATS 529279 . 529597) (PRINT-TO-DISPLAY 529599 . 530807) (PROCESS-EQUATIONAL-POLYS 530809 . 533586) (PROPERTYLESS-SYMBOLP 533588 . 533779) (PROVE 533781 . 535357) (PROVE-TERMINATION 535359 . 536858) (PROVEALL 536860 . 537485) (PUSH-CLAUSE-SET 537487 . 537718) (PUSH-LEMMA 537720 . 537967) (PUSH-LEMMA-FRAME 537969 . 538142) ( PUSH-LINEARIZE-ASSUMPTION 538144 . 538376) (PUSH-LINEARIZE-ASSUMPTIONS-FRAME 538378 . 538599) (PUSHU 538601 . 538809) (PUT-CURSOR 538811 . 538943) (PUT-INDUCTION-INFO 538945 . 541528) (PUT-LEVEL-NO 541530 . 542127) (PUT-TYPE-PRESCRIPTION 542129 . 546737) (PUT0 546739 . 548634) (PUT00 548636 . 549190 ) (PUT1 549192 . 550297) (PUT1-LST 550299 . 550667) (PUTD1 550669 . 551364) (QUICK-BLOCK-INFO 551366 . 552612) (QUICK-BLOCK-INFO1 552614 . 552885) (QUICK-WORSE-THAN 552887 . 554098) (R 554100 . 554448) (REDO! 554450 . 554660) (REDO-UNDONE-EVENTS 554662 . 560468) (BM-REDUCE 560470 . 561023) (REDUCE1 561025 . 562852) (REFLECT0 562854 . 565896) (RELIEVE-HYPS 565898 . 566423) (RELIEVE-HYPS-NOT-OK 566425 . 567532) (RELIEVE-HYPS1 567534 . 571276) (REMOVE-*2*IFS 571278 . 572196) (REMOVE-NEGATIVE 572198 . 572493) (REMOVE-REDUNDANT-TESTS 572495 . 574037) (REMOVE1 574039 . 574303) (REMOVE-TRIVIAL-EQUATIONS 574305 . 577408) (REMOVE-UNCHANGING-VARS 577410 . 578460) (REMPROP1 578462 . 578774) (RESTART 578776 . 578992) (RESTART-BATCH 578994 . 579385) (REWRITE 579387 . 582861) (REWRITE-FNCALL 582863 . 589951) (REWRITE-FNCALLP 589953 . 593776) (REWRITE-IF 593778 . 595369) (REWRITE-IF1 595371 . 596360) ( REWRITE-LINEAR-CONCL 596362 . 598431) (REWRITE-SOLIDIFY 598433 . 601105) (REWRITE-TYPE-PRED 601107 . 605970) (REWRITE-WITH-LEMMAS 605972 . 616809) (REWRITE-WITH-LINEAR 616811 . 619245) (RPLACAI 619247 . 619589)) (621335 715338 (S 621345 . 621998) (SARGS 622000 . 623166) (SCONS-TERM 623168 . 623614) ( SCRUNCH 623616 . 623937) (SCRUNCH-CLAUSE 623939 . 624314) (SCRUNCH-CLAUSE-SET 624316 . 624784) ( SEARCH-GROUND-UNITS 624786 . 626875) (SEQUENTIAL-DIFFERENCE 626877 . 627485) (SET-DIFF 627487 . 627666 ) (SET-DIFF-N 627668 . 628221) (SET-EQUAL 628223 . 628380) (SET-SIMPLIFY-CLAUSE-POT-LST 628382 . 630735) (SETTLED-DOWN-CLAUSE 630737 . 631035) (SETTLED-DOWN-SENT 631037 . 631288) (SETUP 631290 . 632168) (SETUP-META-NAMES 632170 . 632664) (SHELL-CONSTRUCTORP 632666 . 632896) ( SHELL-DESTRUCTOR-NESTP 632898 . 633337) (SHELL-OCCUR 633339 . 634959) (SHELL-OCCUR1 634961 . 636987) ( SHELLP 636989 . 637322) (SIMPLIFY-CLAUSE 637324 . 642585) (SIMPLIFY-CLAUSE-MAXIMALLY 642587 . 643024) (SIMPLIFY-CLAUSE-MAXIMALLY1 643026 . 643627) (SIMPLIFY-CLAUSE0 643629 . 645468) (SIMPLIFY-CLAUSE1 645470 . 648472) (SIMPLIFY-LOOP 648474 . 648982) (SIMPLIFY-SENT 648984 . 649218) ( SINGLETON-CONSTRUCTOR-TO-RECOGNIZER 649220 . 649706) (SKO-DEST-NESTP 649708 . 650307) ( SOME-SUBTERM-WORSE-THAN-OR-EQUAL 650309 . 651016) (SORT-DESTRUCTOR-CANDIDATES 651018 . 652383) ( SOUND-IND-PRIN-MASK 652385 . 657525) (STACK-DEPTH 657527 . 657663) (START-STATS 657665 . 657847) ( STOP-STATS 657849 . 658281) (STORE-SENT 658283 . 660779) (STRIP-BRANCHES 660781 . 661359) ( STRIP-BRANCHES1 661361 . 666989) (SUB-SEQUENCEP 666991 . 667368) (SUBBAGP 667370 . 667721) ( SUBLIS-EXPR 667723 . 668032) (SUBLIS-EXPR1 668034 . 668436) (SUBLIS-VAR 668438 . 669074) ( SUBLIS-VAR-LST 669076 . 669265) (SUB-PAIR-EXPR 669267 . 669564) (SUB-PAIR-EXPR-LST 669566 . 669759) ( SUB-PAIR-EXPR1 669761 . 670488) (SUB-PAIR-VAR 670490 . 671256) (SUB-PAIR-VAR-LST 671258 . 671449) ( SUBST-EXPR 671451 . 671735) (SUBST-EXPR-ERROR1 671737 . 672130) (SUBST-EXPR-LST 672132 . 672313) ( SUBST-EXPR1 672315 . 672685) (SUBST-FN 672687 . 673539) (SUBST-VAR 673541 . 673934) (SUBST-VAR-LST 673936 . 674125) (BM-SUBST 674127 . 674349) (SUBSUMES 674351 . 674513) (SUBSUMES-REWRITE-RULE 674515 . 674966) (SUBSUMES1 674968 . 675367) (SUBSUMES11 675369 . 675575) (SUM-STATS-ALIST 675577 . 676015) (TABULATE 676017 . 676206) (TERM-ORDER 676208 . 680196) (TERMINATION-MACHINE 680198 . 681841) ( TP-EXPLODEN1 681843 . 682622) (TP-GETCHARN1 682624 . 683272) (TP-IMPLODE1 683274 . 684527) ( TO-BE-IGNOREDP 684529 . 684960) (TOO-MANY-IFS 684962 . 688612) (TOP-FNNAME 688614 . 688880) ( TOTAL-FUNCTIONP 688882 . 689264) (TRANSITIVE-CLOSURE 689266 . 692050) (TRANSLATE 692052 . 699038) ( TRANSLATE-TO-LISP 699040 . 699563) (TREE-DEPENDENTS 699565 . 699935) (TRIVIAL-POLYP 699937 . 700153) ( TRIVIAL-POLYP1 700155 . 703521) (TRUE-POLYP 703523 . 703886) (TYPE-ALIST-CLAUSE 703888 . 704382) ( TYPE-PRESCRIPTION-LEMMAP 704384 . 704793) (TYPE-SET 704795 . 707231) (TYPE-SET2 707233 . 707781) (UBT 707783 . 707931) (UNBREAK-LEMMA 707933 . 708229) (UNCHANGING-VARS 708231 . 708439) (UNCHANGING-VARS1 708441 . 709419) (UNDO-BACK-THROUGH 709421 . 709973) (UNDO-NAME 709975 . 710832) (UNION-EQUAL 710834 . 711834) (UNPRETTYIFY 711836 . 712739) (VARIANTP 712741 . 713054) (WORSE-THAN 713056 . 713591) ( WORSE-THAN-OR-EQUAL 713593 . 713779) (WRAPUP 713781 . 714667) (XXXJOIN 714669 . 715145) (ZERO-POLY 715147 . 715336)) (715870 733731 (BOOT-STRAP 715880 . 718163) (ADD-AXIOM 718165 . 719251) (ADD-SHELL 719253 . 721823) (DCL 721825 . 722539) (DEFN 722541 . 725351) (DEFN& 725353 . 725789) (DISABLE 725791 . 726049) (ENABLE 726051 . 726310) (PROVE-LEMMA 726312 . 729096) (PROVE-LEMMA& 729098 . 729403) ( REFLECT 729405 . 732801) (TOGGLE 732803 . 733729)) (734143 748312 (GENERATE-ADD-FACT-PART 734153 . 740658) (GENERATE-ADD-SUB-FACT1 740660 . 743936) (GENERATE-SUB-FACT-PART 743938 . 746933) ( GENERATE-UNDO-TUPLE-PART 746935 . 748310)) (748649 829912 (!CLAUSE-SET 748659 . 749399) (!CLAUSE 749401 . 749836) (EQUALITY-HYP-NO 749838 . 750255) (GET-SCHEMA-MEASURE-RELATION 750257 . 752347) (IO 752349 . 752680) (IO1 752682 . 808683) (JUSTIFICATION-SENTENCE 808685 . 811112) (!LIST 811114 . 811396 ) (MAPRINEVAL 811398 . 812214) (NOTICE-CLAUSE 812216 . 812485) (PEVAL 812487 . 813615) (PEVAL-APPLY 813617 . 814348) (PEVALV 814350 . 814808) (PLURALP 814810 . 815006) (!PPR-LIST 815008 . 815462) (!PPR 815464 . 817157) (PRIN5* 817159 . 820310) (PRINEVAL 820312 . 820392) (PRINEVAL1 820394 . 821819) ( PRINT-DEFN-MSG 821821 . 828705) (TH-IFY 828707 . 829489) (UN-NOTICE-CLAUSE 829491 . 829910)) (830036 842620 (PPRIND 830046 . 830992) (PPRPACK 830994 . 831341) (PPR1 831343 . 836904) (PPR2 836906 . 841538 ) (PPR22 841540 . 842407) (TERPRISPACES 842409 . 842618))))) STOP \ No newline at end of file diff --git a/lispusers/BRKDWNREPORT b/lispusers/BRKDWNREPORT new file mode 100644 index 00000000..d805fcf5 --- /dev/null +++ b/lispusers/BRKDWNREPORT @@ -0,0 +1 @@ +(FILECREATED "12-Feb-87 23:13:02" {FIREFS:CS:UNIV% ROCHESTER}LISP>BRKDWNREPORT.;1 8063 changes to: (VARS BRKDWNREPORTCOMS) (FNS BRKDWNFORM BDR-TYPE BRKDWN BRKDWNREPORT) previous date: "12-Feb-87 23:07:23" {FIREFS:CS:UNIV% ROCHESTER}LISP>BRKDWNREPORT.;1) (* Copyright (c) 1987 by Johannes A. G. M. Koomen. All rights reserved.) (PRETTYCOMPRINT BRKDWNREPORTCOMS) (RPAQQ BRKDWNREPORTCOMS ((FNS BRKDWNREPORT BRKDWNFORM BDR-TYPE BDR-TYPE-SORTED BDR-COL BDR-RPT))) (DEFINEQ (BRKDWNREPORT [LAMBDA (TITLE BRKDWNSTREAM) (* Koomen "18-Dec-86 16:11") (DECLARE (GLOBALVARS BRKDWNLABELS)) (if (NOT (OPENP BRKDWNSTREAM (QUOTE OUTPUT))) then (RESETLST (SETQ BRKDWNSTREAM (OPENSTREAM BRKDWNSTREAM (QUOTE OUTPUT))) [RESETSAVE NIL (BQUOTE (CLOSEF? (\, BRKDWNSTREAM] (BRKDWNREPORT TITLE BRKDWNSTREAM)) else (PROG [ENTRYCNT (FIRSTCOL 0) (TYPE-ENTRIES (for BDTYPE inside BRKDWNLABELS collect (* * Each entry is a list of three elements: total frequency of calls, total quantity measured, and list of  individual contributors, each of which is a 3-element list containing name, frequency and quantity measured.) (LIST 0 0 NIL] [for RESULT in (BRKDWNRESULTS T) as old ENTRYCNT from 0 bind NAME FREQUENCY unless (ZEROP (SETQ FREQUENCY (CADR RESULT))) do (SETQ NAME (CAR RESULT)) (for QUANTITY in (CDDR RESULT) as TYPE-ENTRY in TYPE-ENTRIES unless (ZEROP QUANTITY) do (add (CAR TYPE-ENTRY) FREQUENCY) (add (CADR TYPE-ENTRY) QUANTITY) (push (CADDR TYPE-ENTRY) (LIST NAME FREQUENCY QUANTITY))) (SETQ FIRSTCOL (MAX FIRSTCOL (NCHARS NAME] (SETQ FIRSTCOL (IPLUS FIRSTCOL 2)) (printout BRKDWNSTREAM "Breakdown Report:" 24 (OR TITLE "")) (printout BRKDWNSTREAM T T "Breakdown Date:" 24 (DATE)) (printout BRKDWNSTREAM T T "Functions measured:" 24 ENTRYCNT) (printout BRKDWNSTREAM T T "Non-zero entries:" T) (for BDTYPE inside BRKDWNLABELS as TYPE-ENTRY in TYPE-ENTRIES bind N do (SETQ N (LENGTH (CADDR TYPE-ENTRY))) (printout BRKDWNSTREAM 6 BDTYPE 24 .I6 N (if (EQP N 1) then " function" else " functions"))) (printout BRKDWNSTREAM T T T) (for BDTYPE inside BRKDWNLABELS as TYPE-ENTRY in TYPE-ENTRIES do (BDR-TYPE BRKDWNSTREAM FIRSTCOL (L-CASE BDTYPE) (CAR TYPE-ENTRY) (CADR TYPE-ENTRY) (CADDR TYPE-ENTRY))) (TERPRI BRKDWNSTREAM]) (BRKDWNFORM [LAMBDA (BRKDWNFORM BRKDWNFNS BRKDWNSTREAM NEWBRKDWNTYPE) (* Koomen "12-Feb-87 22:58") (DECLARE (GLOBALVARS BRKDWNTYPE BRKDWNTYPES) (LOCALVARS BRKDWNFORM BRKDWNFNS BRKDWNSTREAM NEWBRKDWNTYPE)) (RESETLST (APPLY (FUNCTION UNBREAK) BRKDWNFNS) (if NEWBRKDWNTYPE then (RESETSAVE BRKDWNTYPE (if (EQ NEWBRKDWNTYPE T) then (for BDT in BRKDWNTYPES collect (CAR BDT)) else NEWBRKDWNTYPE))) (BREAKDOWN) [RESETSAVE (APPLY (FUNCTION BREAKDOWN) BRKDWNFNS) (BQUOTE (UNBREAK (\,@ BRKDWNFNS] (EVAL BRKDWNFORM) (BRKDWNREPORT BRKDWNFORM BRKDWNSTREAM]) (BDR-TYPE [LAMBDA (OUTSTREAM FIRSTCOL BDTYPE TOTAL-FREQUENCY TOTAL-QUANTITY ENTRIES) (* Koomen "12-Feb-87 23:06") (if ENTRIES then [SORT ENTRIES (FUNCTION (LAMBDA (x y) (GEQ (CADDR x) (CADDR y] (printout OUTSTREAM T (U-CASE BDTYPE) " -- sorted by cummulative " BDTYPE ":" T) (BDR-TYPE-SORTED OUTSTREAM FIRSTCOL BDTYPE TOTAL-FREQUENCY TOTAL-QUANTITY ENTRIES) (if (CDR ENTRIES) then (SORT ENTRIES T) (printout OUTSTREAM T (U-CASE BDTYPE) " -- alphabetic sort:" T) (BDR-TYPE-SORTED OUTSTREAM FIRSTCOL BDTYPE TOTAL-FREQUENCY TOTAL-QUANTITY ENTRIES]) (BDR-TYPE-SORTED [LAMBDA (OUTSTREAM FIRSTCOL BDTYPE TOTAL-FREQUENCY TOTAL-QUANTITY ENTRIES) (* Koomen "17-Dec-86 15:10") (PROG (COL1-START COL1-WIDTH COL1-FORMAT COL2-START COL2-WIDTH COL2-FORMAT COL3-START COL3-WIDTH COL3-FORMAT COL4-START COL4-WIDTH COL4-FORMAT LINE-END) (SETQ COL1-START FIRSTCOL) (SETQ COL1-WIDTH 11) [SETQ COL1-FORMAT (BQUOTE (FIX (\, COL1-WIDTH] (SETQ COL2-START (PLUS COL1-START COL1-WIDTH 4)) (SETQ COL2-WIDTH 7) [SETQ COL2-FORMAT (BQUOTE (FIX (\, COL2-WIDTH] (SETQ COL3-START (PLUS COL2-START COL2-WIDTH 4)) (SETQ COL3-WIDTH 9) (SETQ COL3-FORMAT (BQUOTE (FLOAT (\, COL3-WIDTH) 3))) (SETQ COL4-START (PLUS COL3-START COL3-WIDTH 4)) (SETQ COL4-WIDTH 3) [SETQ COL4-FORMAT (BQUOTE (FIX (\, COL4-WIDTH] (SETQ LINE-END (PLUS COL4-START COL4-WIDTH)) (BDR-RPT "=" LINE-END OUTSTREAM) (TERPRI OUTSTREAM) (PRIN1 "Function:" OUTSTREAM) (BDR-COL OUTSTREAM COL1-START COL1-WIDTH BDTYPE) (BDR-COL OUTSTREAM COL2-START COL2-WIDTH "#calls") (BDR-COL OUTSTREAM COL3-START COL3-WIDTH "per call") (BDR-COL OUTSTREAM COL4-START COL4-WIDTH "%%") (TERPRI OUTSTREAM) (BDR-RPT "-" LINE-END OUTSTREAM) (TERPRI OUTSTREAM) (for ENTRY in ENTRIES as NLINES from 1 bind NAME FREQUENCY QUANTITY (LASTLINE _ (IDIFFERENCE (LENGTH ENTRIES) 4)) do (SETQ NAME (CAR ENTRY)) (SETQ FREQUENCY (CADR ENTRY)) (SETQ QUANTITY (CADDR ENTRY)) (PRIN1 NAME OUTSTREAM) (BDR-COL OUTSTREAM COL1-START COL1-WIDTH QUANTITY COL1-FORMAT) (BDR-COL OUTSTREAM COL2-START COL2-WIDTH FREQUENCY COL2-FORMAT) (BDR-COL OUTSTREAM COL3-START COL3-WIDTH (FQUOTIENT QUANTITY FREQUENCY) COL3-FORMAT) (BDR-COL OUTSTREAM COL4-START COL4-WIDTH (FQUOTIENT (FTIMES 100.0 QUANTITY) TOTAL-QUANTITY) COL4-FORMAT) (TERPRI OUTSTREAM) (if (AND (ZEROP (IREMAINDER NLINES 10)) (ILESSP NLINES LASTLINE)) then (BDR-RPT "-" LINE-END OUTSTREAM) (TERPRI OUTSTREAM))) (BDR-RPT "-" LINE-END OUTSTREAM) (TERPRI OUTSTREAM) (PRIN1 "Total:" OUTSTREAM) (BDR-COL OUTSTREAM COL1-START COL1-WIDTH TOTAL-QUANTITY COL1-FORMAT) (BDR-COL OUTSTREAM COL2-START COL2-WIDTH TOTAL-FREQUENCY COL2-FORMAT) (BDR-COL OUTSTREAM COL3-START COL3-WIDTH (FQUOTIENT TOTAL-QUANTITY TOTAL-FREQUENCY) COL3-FORMAT) (TERPRI OUTSTREAM) (BDR-RPT "=" LINE-END OUTSTREAM) (TERPRI OUTSTREAM) (TERPRI OUTSTREAM]) (BDR-COL [LAMBDA (OUTSTREAM START WIDTH VALUE FORMAT) (* Koomen "16-Dec-86 17:24") (if FORMAT then (TAB START 1 OUTSTREAM) (PRINTNUM FORMAT VALUE OUTSTREAM) else (SETQ START (IDIFFERENCE (IPLUS START WIDTH) (NCHARS VALUE))) (TAB START 1 OUTSTREAM) (PRIN1 VALUE OUTSTREAM]) (BDR-RPT [LAMBDA (STR N OUTSTREAM) (* Koomen "17-Dec-86 14:50") (for I from 1 to N do (PRIN1 STR OUTSTREAM]) ) (PUTPROPS BRKDWNREPORT COPYRIGHT ("Johannes A. G. M. Koomen" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (512 7973 (BRKDWNREPORT 522 . 2895) (BRKDWNFORM 2897 . 3703) (BDR-TYPE 3705 . 4464) ( BDR-TYPE-SORTED 4466 . 7414) (BDR-COL 7416 . 7794) (BDR-RPT 7796 . 7971))))) STOP \ No newline at end of file diff --git a/lispusers/BUTTONS b/lispusers/BUTTONS new file mode 100644 index 00000000..bc77c89b --- /dev/null +++ b/lispusers/BUTTONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "26-Oct-89 14:30:27" {ICE}LISPUSERS>MEDLEY>BUTTONS.;2 28959 changes to%: (VARS BUTTONSCOMS) (FNS MOVE-BUTTON \BUTTONS-DRAW-BOX \BUTTONS-TRACK-MOUSE EDIT-BUTTON-CONTENTS) previous date%: " 2-Dec-88 17:17:47" {ICE}LISPUSERS>KOTO>BUTTONS.;1) (* " Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BUTTONSCOMS) (RPAQQ BUTTONSCOMS ((* ;;; "BUTTONS provides a mechanism for mapping mouse clicks to actions via mouse-sensitive pictures of buttons. Each button has a label and an action, which is an arbitrary Lisp form. If the left mouse button is clicked on a button, its associated action is executed. If the action is a string it is stuffed into the system buffer and read by the current tty process; otherwise it is evaluated under the mouse process.") (* ;;; "USER INTERFACE") (RECORDS BUTTON) (FNS ALIGN-BUTTONS BUTTONP BUTTONSPROP BUTTON-ACTION BUTTON-LABEL CLOSE-BUTTON CLOSE-BUTTONS COPY-BUTTON CREATE-BUTTON DELETE-BUTTON DELETE-BUTTONS EDIT-BUTTON EDIT-BUTTON-CONTENTS EXECUTE-BUTTON EXPOSE-BUTTONS LOAD-SOME-BUTTONS MOVE-BUTTON REDISPLAY-BUTTON RESTORE-BUTTONS SAVE-BUTTONS SAVE-SOME-BUTTONS) (PROP ARGNAMES BUTTONSPROP BUTTON-ACTION BUTTON-LABEL) (* ;;; "IMPLEMENTATION") (PROP MAKEFILE-ENVIRONMENT BUTTONS) (VARS *BUTTONS-DATAVERSION* *DEFAULT-BUTTONPROPS*) (INITVARS (*BUTTONPROPS* (COPYALL *DEFAULT-BUTTONPROPS*)) (*ALL-BUTTONS* NIL) (*BUTTONS-DEFAULT-ACTION* NIL) (*BUTTONS-DEFAULT-LABEL* NIL) (*BUTTONS-EDIT-MENU* NIL) (*BUTTONS-EDIT-SHADE* NIL) (*BUTTONS-EXEC-SHADE* NIL) (*BUTTONS-GRID-ORIGIN* NIL) (*BUTTONS-LABEL-FONT* NIL) (*BUTTONS-MENU-FONT* NIL) (*BUTTONS-SAVE-DIRECTORY* NIL)) (FNS \BUTTONS-BUTTONEVENTFN \BUTTONS-DATAFILE-NAME \BUTTONS-CHANGE-LABEL \BUTTONS-CREATE-ICON \BUTTONS-DRAW-BOX \BUTTONS-EDITE \BUTTONS-EDIT-MENU \BUTTONS-INIT \BUTTONS-IO-EXIT \BUTTONS-OPEN-STREAM \BUTTONS-PROMPT-FOR-DATAFILE-NAME \BUTTONS-READ \BUTTONS-SETPROP \BUTTONS-SHOW \BUTTONS-SHOW-EXEC \BUTTONS-TRACK-MOUSE \BUTTONS-WAIT-MOUSE) (COMS (* The button icon) (FILES (SYSLOAD FROM LISPUSERS) ICONW) (FNS DROPSHADOW ICONMASK CLEAR-MASK-OUTLINE) (BITMAPS *BUTTON-BITMAP*) (INITVARS (*BUTTON-INVERT-REGION* (QUOTE (6 10 85 25))) (*BUTTON-CLIPPING-REGION* (QUOTE (7 11 83 23))) (*BUTTON-ICON* (DROPSHADOW *BUTTON-BITMAP*)) (*BUTTON-ICON-MASK* (ICONMASK *BUTTON-ICON*)))) (ADDVARS (BackgroundMenuCommands ("Button Control" (QUOTE (EDIT-BUTTON)) "Manipulate action buttons"))) (VARS (BackgroundMenu)) (P (\BUTTONS-INIT)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA BUTTON-LABEL BUTTON-ACTION BUTTONSPROP))))) (* ;;; "BUTTONS provides a mechanism for mapping mouse clicks to actions via mouse-sensitive pictures of buttons. Each button has a label and an action, which is an arbitrary Lisp form. If the left mouse button is clicked on a button, its associated action is executed. If the action is a string it is stuffed into the system buffer and read by the current tty process; otherwise it is evaluated under the mouse process." ) (* ;;; "USER INTERFACE") (DECLARE%: EVAL@COMPILE (ACCESSFNS BUTTON ((LABEL (WINDOWPROP DATUM (QUOTE BUTTON-LABEL)) (WINDOWPROP DATUM (QUOTE BUTTON-LABEL) NEWVALUE)) (ACTION (WINDOWPROP DATUM (QUOTE BUTTON-ACTION)) (WINDOWPROP DATUM (QUOTE BUTTON-ACTION) NEWVALUE)) (EXECUTING? (WINDOWPROP DATUM (QUOTE BUTTON-EXECUTING?)) (WINDOWPROP DATUM (QUOTE BUTTON-EXECUTING?) NEWVALUE))) ) ) (DEFINEQ (ALIGN-BUTTONS (LAMBDA (BUTTON) (* Koomen "30-Dec-86 16:04") (DECLARE (GLOBALVARS *ALL-BUTTONS*)) (bind BUTTONREGION BUTTON2 BUTTON2REGION (EDGE _ (MENU (create MENU TITLE _ "Which axis? " ITEMS _ (QUOTE (Vertical Horizontal)) CENTERFLG _ T))) first (if (NULL EDGE) then (RETURN)) (SETQ BUTTONREGION (WINDOWREGION BUTTON)) while (PROGN (PROMPTPRINT "Indicate another button to align: ") (AND (SETQ BUTTON2 (WHICHW (GETPOSITION))) (NEQ BUTTON2 BUTTON) (FMEMB BUTTON2 *ALL-BUTTONS*))) do (SETQ BUTTON2REGION (WINDOWREGION BUTTON2)) (MOVEW BUTTON2 (fetch (REGION LEFT) of (if (EQ EDGE (QUOTE Horizontal)) then BUTTON2REGION else BUTTONREGION)) (fetch (REGION BOTTOM) of (if (EQ EDGE (QUOTE Vertical)) then BUTTON2REGION else BUTTONREGION))) finally (PROMPTPRINT "Done."))) ) (BUTTONP (LAMBDA (BUTTON ERROR?) (* Koomen "18-Mar-87 14:03") (DECLARE (GLOBALVARS *ALL-BUTTONS*)) (if (FMEMB BUTTON *ALL-BUTTONS*) then BUTTON elseif ERROR? then (ERROR "Arg not a BUTTON:" BUTTON))) ) (BUTTONSPROP (LAMBDA N (* Koomen " 8-Jun-88 11:42") (DECLARE (GLOBALVARS *BUTTONPROPS*)) (PROG (PROPNAME OLDVALUE NEWVALUE) (SETQ PROPNAME (if (IGREATERP N 0) then (ARG N 1))) (if (NOT PROPNAME) then (RETURN)) (if (NEQ (QUOTE *BUTTONPROPS*) (CAR (LISTP *BUTTONPROPS*))) then (RETURN)) (SETQ OLDVALUE (CADR (ASSOC PROPNAME *BUTTONPROPS*))) (if (IGREATERP N 1) then (SETQ NEWVALUE (ARG N 2)) (if (NOT (EQUAL NEWVALUE OLDVALUE)) then (PUTASSOC PROPNAME (LIST NEWVALUE) *BUTTONPROPS*) (\BUTTONS-SETPROP PROPNAME NEWVALUE))) (RETURN OLDVALUE))) ) (BUTTON-ACTION (LAMBDA N (* Koomen "18-Mar-87 14:22") (PROG (BUTTON OLDACTION NEWACTION) (SETQ BUTTON (if (IGREATERP N 0) then (ARG N 1))) (if (NOT (BUTTONP BUTTON T)) then (RETURN)) (SETQ OLDACTION (fetch (BUTTON ACTION) of BUTTON)) (if (IGREATERP N 1) then (SETQ NEWACTION (ARG N 2)) (replace (BUTTON ACTION) of BUTTON with NEWACTION)) (RETURN OLDACTION))) ) (BUTTON-LABEL (LAMBDA N (* edited%: "18-Mar-87 22:33") (PROG (BUTTON OLDLABEL NEWLABEL) (SETQ BUTTON (if (IGREATERP N 0) then (ARG N 1))) (if (NOT (BUTTONP BUTTON T)) then (RETURN)) (SETQ OLDLABEL (fetch (BUTTON LABEL) of BUTTON)) (if (IGREATERP N 1) then (SETQ NEWLABEL (MKSTRING (OR (ARG N 2) ""))) (if (NOT (EQUAL NEWLABEL OLDLABEL)) then (\BUTTONS-CHANGE-LABEL BUTTON NEWLABEL))) (RETURN OLDLABEL))) ) (CLOSE-BUTTON (LAMBDA (BUTTON) (* Koomen "18-Mar-87 13:14") (if (BUTTONP BUTTON T) then (CLOSEW BUTTON)))) (CLOSE-BUTTONS (LAMBDA (BUTTONS) (* Koomen "18-Mar-87 13:09") (DECLARE (GLOBALVARS *ALL-BUTTONS*)) (for BUTTON in (OR (LISTP BUTTONS) *ALL-BUTTONS*) do (CLOSE-BUTTON BUTTON))) ) (COPY-BUTTON (LAMBDA (BUTTON NEWLOCATION) (* Koomen "18-Mar-87 14:58") (if (BUTTONP BUTTON T) then (CREATE-BUTTON (COPYALL (fetch (BUTTON ACTION) of BUTTON)) (COPYALL (fetch (BUTTON LABEL) of BUTTON)) NEWLOCATION))) ) (CREATE-BUTTON (LAMBDA (ACTION LABEL LOCATION NOOPENFLG) (* Koomen " 8-Jun-88 14:26") (* edited%: "18-Mar-87 22:48") (DECLARE (GLOBALVARS *ALL-BUTTONS* *BUTTON-ICON-MASK* *BUTTONS-DEFAULT-ACTION* *BUTTONS-DEFAULT-LABEL* LASTMOUSEX LASTMOUSEY)) (if (BUTTONP ACTION) then (* ; "Interactive") (SETQ LABEL NIL) (SETQ ACTION NIL)) (if (AND (NULL ACTION) (NULL LABEL)) then (SETQ ACTION *BUTTONS-DEFAULT-ACTION*) (SETQ LABEL *BUTTONS-DEFAULT-LABEL*) elseif (NULL ACTION) then (SETQ ACTION (BQUOTE (PROMPTPRINT (\, (KWOTE LABEL))))) elseif (NULL LABEL) then (SETQ LABEL ACTION)) (SETQ LABEL (COPYALL (MKSTRING LABEL))) (SETQ ACTION (COPYALL ACTION)) (SETQ LOCATION (if (REGIONP LOCATION) then (CREATEPOSITION (fetch (REGION LEFT) of LOCATION) (fetch (REGION BOTTOM) of LOCATION)) else (POSITIONP LOCATION))) (PROG ((BUTTON (ICONW (\BUTTONS-CREATE-ICON LABEL) *BUTTON-ICON-MASK* (OR LOCATION (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)) (OR NOOPENFLG (NULL LOCATION))))) (push *ALL-BUTTONS* BUTTON) (WINDOWPROP BUTTON (QUOTE REPAINTFN) (FUNCTION REDISPLAY-BUTTON)) (WINDOWPROP BUTTON (QUOTE BUTTONEVENTFN) (FUNCTION \BUTTONS-BUTTONEVENTFN)) (WINDOWPROP BUTTON (QUOTE RIGHTBUTTONFN) (FUNCTION \BUTTONS-BUTTONEVENTFN)) (replace (BUTTON LABEL) of BUTTON with LABEL) (replace (BUTTON ACTION) of BUTTON with ACTION) (if (AND (NOT NOOPENFLG) (NULL LOCATION)) then (MOVE-BUTTON BUTTON)) (RETURN BUTTON))) ) (DELETE-BUTTON (LAMBDA (BUTTON) (* Koomen "18-Mar-87 13:14") (DECLARE (GLOBALVARS *ALL-BUTTONS*)) (if (BUTTONP BUTTON T) then (CLOSEW BUTTON) (SETQ *ALL-BUTTONS* (DREMOVE BUTTON *ALL-BUTTONS*)))) ) (DELETE-BUTTONS (LAMBDA (BUTTONS) (* edited%: "18-Mar-87 23:10") (DECLARE (GLOBALVARS *ALL-BUTTONS*)) (for BUTTON in (APPEND (OR (LISTP BUTTONS) *ALL-BUTTONS*)) do (DELETE-BUTTON BUTTON))) ) (EDIT-BUTTON (LAMBDA (BUTTON CONTENTS?) (* Koomen " 8-Jun-88 08:45") (DECLARE (GLOBALVARS *ALL-BUTTONS* *BUTTONS-EDIT-SHADE*)) (RESETFORM (\BUTTONS-SHOW BUTTON *BUTTONS-EDIT-SHADE*) (PROG ((CMD (if CONTENTS? then (QUOTE EDIT-BUTTON-CONTENTS) else (MENU (\BUTTONS-EDIT-MENU))))) (if (AND (NULL BUTTON) (FMEMB CMD (QUOTE (CLOSE-BUTTON DELETE-BUTTON REDISPLAY-BUTTON MOVE-BUTTON EDIT-BUTTON-CONTENTS COPY-BUTTON ALIGN-BUTTONS)))) then (PROMPTPRINT "Indicate button to manipulate: ") (SETQ BUTTON (WHICHW (GETPOSITION))) (CLRPROMPT) (if (OR (NULL BUTTON) (NOT (FMEMB BUTTON *ALL-BUTTONS*))) then (RETURN))) (if CMD then (if (DEFINEDP CMD) then (APPLY* CMD BUTTON) else (PROMPTPRINT "Button command " CMD " not yet implemented!")))))) ) (EDIT-BUTTON-CONTENTS (LAMBDA (BUTTON) (* ; "Edited 25-Oct-89 10:47 by Koomen") (if (BUTTONP BUTTON T) then (PROG (OLDLABEL OLDACTION RESULT NEWLABEL NEWACTION) (SETQ OLDLABEL (fetch (BUTTON LABEL) of BUTTON)) (SETQ OLDACTION (fetch (BUTTON ACTION) of BUTTON)) (SETQ RESULT (\BUTTONS-EDITE (BQUOTE ((:LABEL (\, (COPYALL OLDLABEL))) (:ACTION (\, (COPYALL OLDACTION))))))) (if (NULL RESULT) then (RETURN)) (if (SETQ NEWLABEL (FASSOC :LABEL RESULT)) then (BUTTON-LABEL BUTTON (CAR (LISTP (CDR NEWLABEL))))) (if (SETQ NEWACTION (FASSOC :ACTION RESULT)) then (BUTTON-ACTION BUTTON (CAR (LISTP (CDR NEWACTION))))) (RETURN BUTTON)))) ) (EXECUTE-BUTTON (LAMBDA (BUTTON NOMOUSE) (* Koomen " 8-Jun-88 12:58") (* edited%: "18-Mar-87 22:53") (if (AND (BUTTONP BUTTON T) (NOT (fetch (BUTTON EXECUTING?) of BUTTON))) then (RESETFORM (\BUTTONS-SHOW-EXEC BUTTON T) (if (OR NOMOUSE (\BUTTONS-WAIT-MOUSE BUTTON)) then (ALLOW.BUTTON.EVENTS) (PROG ((ACTION (fetch (BUTTON ACTION) of BUTTON))) (if (LISTP ACTION) then (EVAL ACTION) else (BKSYSBUF ACTION))))))) ) (EXPOSE-BUTTONS (LAMBDA (BUTTONS) (* Koomen "18-Mar-87 16:31") (DECLARE (GLOBALVARS *ALL-BUTTONS*)) (for BUTTON in (OR (LISTP BUTTONS) *ALL-BUTTONS*) do (REDISPLAY-BUTTON BUTTON))) ) (LOAD-SOME-BUTTONS (LAMBDA (FILENAME) (* Koomen " 2-Dec-88 15:02") (if (BUTTONP FILENAME) then (* ;; "Invoked from button menu") (SETQ FILENAME NIL)) (if (NULL FILENAME) then (SETQ FILENAME (\BUTTONS-PROMPT-FOR-DATAFILE-NAME "File to load buttons from (NIL to abort):"))) (if FILENAME then (RESTORE-BUTTONS FILENAME (QUOTE ASK)))) ) (MOVE-BUTTON (LAMBDA (BUTTON X/POS Y) (* Koomen "26-Oct-89 08:12") (DECLARE (GLOBALVARS BOXCURSOR)) (AND NIL (MOVE-BUTTON (WHICHW (GETPOSITION)))) (if (BUTTONP BUTTON T) then (PROG (BOX BL BB BW BH BR BT OK?) (DECLARE (SPECVARS BL BB BW BH BR BT)) (if (POSITIONP X/POS) then (SETQ BL (fetch (POSITION XCOORD) of X/POS)) (SETQ BB (fetch (POSITION YCOORD) of X/POS)) (SETQ OK? T) elseif (AND (SMALLP X/POS) (SMALLP Y)) then (SETQ BL X/POS) (SETQ BB Y) (SETQ OK? T) elseif (AND (NULL X/POS) (NULL Y)) then (SETQ BOX (WINDOWREGION BUTTON)) (SETQ BL (fetch (REGION LEFT) of BOX)) (SETQ BB (fetch (REGION BOTTOM) of BOX)) (SETQ BW (fetch (REGION WIDTH) of BOX)) (SETQ BH (fetch (REGION HEIGHT) of BOX)) (SETQ BR (fetch (REGION RIGHT) of BOX)) (SETQ BT (fetch (REGION TOP) of BOX)) (\SETCURSORPOSITION BL BB) (RESETLST (RESETSAVE (CURSOR BOXCURSOR)) (RESETSAVE (\BUTTONS-DRAW-BOX)) (SETQ OK? (NLSETQ (\BUTTONS-TRACK-MOUSE))))) (if OK? then (MOVEW BUTTON BL BB))))) ) (REDISPLAY-BUTTON (LAMBDA (BUTTON) (* Koomen " 8-Jun-88 09:10") (DECLARE (GLOBALVARS *BUTTONS-EXEC-SHADE*)) (if (BUTTONP BUTTON T) then (\BUTTONS-SHOW BUTTON T) (if (fetch (BUTTON EXECUTING?) of BUTTON) then (\BUTTONS-SHOW BUTTON *BUTTONS-EXEC-SHADE*)))) ) (RESTORE-BUTTONS (LAMBDA (FILENAME KEEP-CURRENT-BUTTONS?) (* Koomen " 2-Dec-88 15:02") (DECLARE (GLOBALVARS *BUTTONPROPS*)) (if (BUTTONP FILENAME) then (* ;; "invoked interactively") (SETQ FILENAME) (SETQ KEEP-CURRENT-BUTTONS? NIL)) (bind (BUTTONSPECS _ (\BUTTONS-READ FILENAME)) first (if (NLISTP BUTTONSPECS) then (RETURN)) (if (EQ KEEP-CURRENT-BUTTONS? (QUOTE ASK)) then (SETQ KEEP-CURRENT-BUTTONS? (MOUSECONFIRM "Keep current buttons? "))) (if (NOT KEEP-CURRENT-BUTTONS?) then (DELETE-BUTTONS)) (* ;; "First element is full file name") (SETQ FILENAME (pop BUTTONSPECS)) (* ;; "Second element is the new buttonprops") (SETQ *BUTTONPROPS* (pop BUTTONSPECS)) (\BUTTONS-SETPROP) (* ;; "remaining elements are button specs") while BUTTONSPECS do (APPLY (FUNCTION CREATE-BUTTON) (pop BUTTONSPECS)) finally (RETURN FILENAME))) ) (SAVE-BUTTONS (LAMBDA (FILENAME BUTTONS) (* Koomen " 8-Jun-88 14:05") (DECLARE (SPECVARS FILERDTBL) (GLOBALVARS *ALL-BUTTONS* *BUTTONPROPS* *BUTTONS-DATAVERSION*)) (if (BUTTONP FILENAME) then (* ;; "invoked interactively") (SETQ FILENAME)) (RESETLST (PROG ((STREAM (\BUTTONS-OPEN-STREAM FILENAME T))) (if (NULL STREAM) then (PROMPTPRINT "*** Buttons data file failed to open! ***") (RETURN)) (RESETSAVE NIL (LIST (FUNCTION \BUTTONS-IO-EXIT) STREAM T)) (PRINT (LIST* *BUTTONS-DATAVERSION* *BUTTONPROPS* (for BUTTON in (OR (LISTP BUTTONS) *ALL-BUTTONS*) when (BUTTONP BUTTON T) collect (LIST (fetch (BUTTON ACTION) of BUTTON) (fetch (BUTTON LABEL) of BUTTON) (WINDOWPROP BUTTON (QUOTE REGION))))) STREAM FILERDTBL) (RETURN (CLOSEF STREAM))))) ) (SAVE-SOME-BUTTONS (LAMBDA (FILENAME BUTTONS) (* Koomen " 2-Dec-88 17:16") (DECLARE (GLOBALVARS *BUTTONS-EDIT-SHADE*)) (RESETLST (LET (BUTTON SAVEBUTTONS MARKEDBUTTONS) (if (LISTP BUTTONS) then (SETQ SAVEBUTTONS BUTTONS) else (* ;; "Either got here through button menu (so FILENAME is a button) or through background menu (so FILENAME is NIL)") (if (SETQ BUTTON FILENAME) then (SETQ SAVEBUTTONS (LIST BUTTON)) (SETQ MARKEDBUTTONS (LIST BUTTON))) (SETQ FILENAME NIL) (* EXPOSE-BUTTONS) (PROMPTPRINT "Click on the buttons you wish to save;" (CHARACTER (CHARCODE CR)) " click again to undo;" (CHARACTER (CHARCODE CR)) " click on non-button to stop.") (do (SETQ BUTTON (WHICHW (GETPOSITION))) (if (NOT (BUTTONP BUTTON)) then (RETURN) elseif (FMEMB BUTTON SAVEBUTTONS) then (* ; "remove it") (SETQ SAVEBUTTONS (DREMOVE BUTTON SAVEBUTTONS)) (\BUTTONS-SHOW BUTTON) else (* ; "add it") (push SAVEBUTTONS BUTTON) (if (FMEMB BUTTON MARKEDBUTTONS) then (\BUTTONS-SHOW BUTTON *BUTTONS-EDIT-SHADE*) else (push MARKEDBUTTONS BUTTON) (RESETSAVE (\BUTTONS-SHOW BUTTON *BUTTONS-EDIT-SHADE*)))))) (if (NULL FILENAME) then (SETQ FILENAME (\BUTTONS-PROMPT-FOR-DATAFILE-NAME "File to save buttons in (NIL to abort):"))) (if FILENAME then (SAVE-BUTTONS FILENAME SAVEBUTTONS))))) ) ) (PUTPROPS BUTTONSPROP ARGNAMES (PROPNAME {NEWVALUE})) (PUTPROPS BUTTON-ACTION ARGNAMES (BUTTON {NEWACTION})) (PUTPROPS BUTTON-LABEL ARGNAMES (BUTTON {NEWLABEL})) (* ;;; "IMPLEMENTATION") (PUTPROPS BUTTONS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (RPAQQ *BUTTONS-DATAVERSION* 3) (RPAQQ *DEFAULT-BUTTONPROPS* (*BUTTONPROPS* (GRID-ORIGIN (15 . 15)) (DEFAULT-LABEL "Create Button") (DEFAULT-ACTION (CREATE-BUTTON)) (MENU-FONT (MODERN 12 BOLD)) (LABEL-FONT (MODERN 10 BOLD)) (SAVE-DIRECTORY NIL) (EDIT-SHADE 4104) (EXEC-SHADE 65535))) (RPAQ? *BUTTONPROPS* (COPYALL *DEFAULT-BUTTONPROPS*)) (RPAQ? *ALL-BUTTONS* NIL) (RPAQ? *BUTTONS-DEFAULT-ACTION* NIL) (RPAQ? *BUTTONS-DEFAULT-LABEL* NIL) (RPAQ? *BUTTONS-EDIT-MENU* NIL) (RPAQ? *BUTTONS-EDIT-SHADE* NIL) (RPAQ? *BUTTONS-EXEC-SHADE* NIL) (RPAQ? *BUTTONS-GRID-ORIGIN* NIL) (RPAQ? *BUTTONS-LABEL-FONT* NIL) (RPAQ? *BUTTONS-MENU-FONT* NIL) (RPAQ? *BUTTONS-SAVE-DIRECTORY* NIL) (DEFINEQ (\BUTTONS-BUTTONEVENTFN (LAMBDA (BUTTON) (* Koomen " 8-Jun-88 09:19") (DECLARE (GLOBALVARS *BUTTONS-EDIT-SHADE* LASTMOUSEBUTTONS)) (if (LASTMOUSESTATE (ONLY LEFT)) then (EXECUTE-BUTTON BUTTON) elseif (LASTMOUSESTATE (ONLY MIDDLE)) then (RESETFORM (\BUTTONS-SHOW BUTTON *BUTTONS-EDIT-SHADE*) (MOVE-BUTTON BUTTON)) elseif (LASTMOUSESTATE (ONLY RIGHT)) then (EDIT-BUTTON BUTTON))) ) (\BUTTONS-DATAFILE-NAME (LAMBDA (FILENAME DATAVERSION) (* Koomen " 2-Dec-88 15:07") (DECLARE (GLOBALVARS *BUTTONS-SAVE-DIRECTORY*)) (LET ((FILE (UNPACKFILENAME FILENAME)) (DFLT (UNPACKFILENAME (if (EQP DATAVERSION 1) then (PACKFILENAME (QUOTE NAME) (QUOTE SAVED-BUTTONS) (QUOTE EXTENSION) NIL (QUOTE VERSION) NIL (QUOTE BODY) (DIRECTORYNAME)) else (PACKFILENAME (QUOTE NAME) (QUOTE SAVED-BUTTONS) (QUOTE EXTENSION) (QUOTE DATA) (QUOTE VERSION) NIL (QUOTE BODY) *BUTTONS-SAVE-DIRECTORY*))))) (if (LISTGET FILE (QUOTE HOST)) then (* ;; "Make sure we don't insert a directory where none's wanted (like on a Dorado DSK)") (LISTPUT DFLT (QUOTE DIRECTORY) NIL)) (PACKFILENAME (NCONC FILE DFLT)))) ) (\BUTTONS-CHANGE-LABEL (LAMBDA (BUTTON NEWLABEL) (* edited%: "18-Mar-87 22:25") (replace (BUTTON LABEL) of BUTTON with NEWLABEL) (WINDOWPROP BUTTON (QUOTE ICONIMAGE) (\BUTTONS-CREATE-ICON NEWLABEL)) (if (OPENWP BUTTON) then (REDISPLAY-BUTTON BUTTON))) ) (\BUTTONS-CREATE-ICON (LAMBDA (LABEL) (* edited%: "18-Mar-87 22:11") (DECLARE (GLOBALVARS *BUTTON-CLIPPING-REGION* *BUTTON-ICON* *BUTTONS-LABEL-FONT*)) (PROG (BM DSP LW LH X Y W H) (SETQ BM (BITMAPCOPY *BUTTON-ICON*)) (SETQ DSP (DSPCREATE BM)) (DSPFONT *BUTTONS-LABEL-FONT* DSP) (DSPCLIPPINGREGION *BUTTON-CLIPPING-REGION* DSP) (SETQ X (fetch (REGION LEFT) of *BUTTON-CLIPPING-REGION*)) (SETQ Y (fetch (REGION BOTTOM) of *BUTTON-CLIPPING-REGION*)) (SETQ W (fetch (REGION WIDTH) of *BUTTON-CLIPPING-REGION*)) (SETQ H (fetch (REGION HEIGHT) of *BUTTON-CLIPPING-REGION*)) (SETQ LW (STRINGWIDTH LABEL *BUTTONS-LABEL-FONT*)) (SETQ LH (FONTHEIGHT *BUTTONS-LABEL-FONT*)) (add Y (FONTDESCENT *BUTTONS-LABEL-FONT*)) (if (IGREATERP W LW) then (add X (LRSH (IDIFFERENCE W LW) 1))) (if (IGREATERP H LH) then (add Y (LRSH (IDIFFERENCE H LH) 1))) (MOVETO X Y DSP) (PRIN1 LABEL DSP) (RETURN BM))) ) (\BUTTONS-DRAW-BOX (LAMBDA NIL (* Koomen "26-Oct-89 08:12") (DECLARE (SPECVARS BB BL BR BT) (GLOBALVARS ScreenBitMap)) (DRAWGRAYBOX BL BB BR BT ScreenBitMap GRAYSHADE)) ) (\BUTTONS-EDITE (LAMBDA (FORM) (* edited%: "18-Mar-87 22:39") (ALLOW.BUTTON.EVENTS) (EVAL.IN.TTY.PROCESS (BQUOTE (CAR (NLSETQ (EDITE (\, (KWOTE FORM)))))) T)) ) (\BUTTONS-EDIT-MENU (LAMBDA NIL (* Koomen " 2-Dec-88 14:50") (DECLARE (GLOBALVARS *BUTTONS-EDIT-MENU* *BUTTONS-MENU-FONT*)) (* * If adding/changing menu entries, do (SETQ *BUTTONS-EDIT-MENU*)) (OR *BUTTONS-EDIT-MENU* (SETQ *BUTTONS-EDIT-MENU* (create MENU TITLE _ "Button Control" ITEMS _ (QUOTE (("Redisplay" (QUOTE REDISPLAY-BUTTON) "Redisplay the button") ("Move" (QUOTE MOVE-BUTTON) "Move the button") ("Copy" (QUOTE COPY-BUTTON) "Create a copy of the button") ("Edit" (QUOTE EDIT-BUTTON-CONTENTS) "Edit the label and the action of the button") ("" NIL "Does nothing") ("Close" (QUOTE CLOSE-BUTTON) "Close the button" (SUBITEMS ("Close All Buttons" (QUOTE CLOSE-BUTTONS)))) ("Delete" (QUOTE DELETE-BUTTON) "Delete this button" (SUBITEMS ("Delete All Buttons" (QUOTE DELETE-BUTTONS)))) ("" NIL "Does nothing") ("Create Button" (QUOTE CREATE-BUTTON) "Create a new button") ("" NIL "Does nothing") ("Expose Buttons" (QUOTE EXPOSE-BUTTONS) "Bring all buttons to the top") ("Align Buttons" (QUOTE ALIGN-BUTTONS) "Align one or more buttons with this button") ("" NIL "Does nothing") ("Save Buttons" (QUOTE SAVE-BUTTONS) "Save all current buttons in default datafile" (SUBITEMS ("Save Some Buttons" (QUOTE SAVE-SOME-BUTTONS) "Save some buttons in some datafile"))) ("Restore Buttons" (QUOTE RESTORE-BUTTONS) "Throw away current buttons, then restore saved buttons from default datafile" (SUBITEMS ("Load Some Buttons" (QUOTE LOAD-SOME-BUTTONS) "Load some buttons from some datafile"))))) MENUFONT _ *BUTTONS-MENU-FONT* MENUOUTLINESIZE _ 1 CENTERFLG _ T CHANGEOFFSETFLG _ (QUOTE Y) MENUOFFSET _ (QUOTE (-1 . 0)))))) ) (\BUTTONS-INIT (LAMBDA NIL (* Koomen " 8-Jun-88 14:13") (* edited%: "18-Mar-87 22:02") (DECLARE (GLOBALVARS *ALL-BUTTONS* *BUTTONS-GRID-ORIGIN*)) (\BUTTONS-SETPROP) (if (NULL *ALL-BUTTONS*) then (CREATE-BUTTON NIL NIL *BUTTONS-GRID-ORIGIN*))) ) (\BUTTONS-IO-EXIT (LAMBDA (STREAM SAVING?) (* Koomen "18-Mar-87 16:19") (if (OPENP STREAM) then (* * Error occurred, so close and discard if saving.) (if SAVING? then (DELFILE (CLOSEF STREAM)) else (CLOSEF STREAM))) NIL) ) (\BUTTONS-OPEN-STREAM (LAMBDA (FILENAME NEW? DATAVERSION) (* Koomen " 2-Dec-88 13:40") (PROG ((FILE (\BUTTONS-DATAFILE-NAME FILENAME DATAVERSION)) (ACCESS (if NEW? then (QUOTE OUTPUT) else (QUOTE INPUT))) (RECOG (if NEW? then (QUOTE NEW) else (QUOTE OLD))) (PARAMETERS (QUOTE (SEQUENTIAL)))) (RETURN (if FILENAME then (OPENSTREAM FILE ACCESS RECOG PARAMETERS) else (CAR (NLSETQ (OPENSTREAM FILE ACCESS RECOG PARAMETERS))))))) ) (\BUTTONS-PROMPT-FOR-DATAFILE-NAME (LAMBDA (PROMPTSTR) (* Koomen " 2-Dec-88 14:46") (DECLARE (GLOBALVARS PROMPTWINDOW)) (PROMPTPRINT PROMPTSTR) (MKATOM (U-CASE (PROMPTFORWORD " " (LET ((FILENAME (\BUTTONS-DATAFILE-NAME (DIRECTORYNAME T)))) (if (NEQ FILENAME (\BUTTONS-DATAFILE-NAME)) then FILENAME)) NIL PROMPTWINDOW NIL NIL (CHARCODE (CR)))))) ) (\BUTTONS-READ (LAMBDA (FILENAME) (* Koomen " 8-Jun-88 11:54") (DECLARE (SPECVARS FILERDTBL) (GLOBALVARS *DEFAULT-BUTTONPROPS*)) (RESETLST (PROG (STREAM PROPS BUTTONSPECS DATAVERSION) (if (AND (NOT (LITATOM FILENAME)) (NOT (STRINGP FILENAME))) then (SETQ FILENAME)) (SETQ STREAM (OR (\BUTTONS-OPEN-STREAM FILENAME NIL (SETQ DATAVERSION 2)) (\BUTTONS-OPEN-STREAM FILENAME NIL (SETQ DATAVERSION 1)))) (if (NULL STREAM) then (PROMPTPRINT "*** Buttons data file not found! ***") (RETURN)) (RESETSAVE NIL (LIST (FUNCTION \BUTTONS-IO-EXIT) STREAM)) (SETQ BUTTONSPECS (LISTP (READ STREAM FILERDTBL))) (if (NUMBERP (CAR BUTTONSPECS)) then (SETQ DATAVERSION (pop BUTTONSPECS))) RETRY (SELECTQ DATAVERSION (1 (SETQ PROPS (COPYALL *DEFAULT-BUTTONPROPS*)) (SETQ BUTTONSPECS (for SPEC in BUTTONSPECS collect (LIST (CADDR SPEC) (CAR SPEC) (CADR SPEC))))) (2 (if (EQ (CAR BUTTONSPECS) (QUOTE *BUTTONPROPS*)) then (SETQ PROPS (CONS (QUOTE *BUTTONPROPS*) (for P on (CDDR BUTTONSPECS) by (CDDR P) collect (LIST (CAR P) (CADR P))))) (SETQ BUTTONSPECS (bind SPEC while (NEQ (QUOTE STOP) (SETQ SPEC (READ STREAM FILERDTBL))) collect SPEC)) else (SETQ DATAVERSION 1) (GO RETRY))) (3 (SETQ PROPS (pop BUTTONSPECS))) (PROGN (PROMPTPRINT "*** Out-of-sync buttons data file version: " DATAVERSION "! ***") (RETURN))) (RETURN (LIST* (CLOSEF STREAM) PROPS BUTTONSPECS))))) ) (\BUTTONS-SETPROP (LAMBDA (PROPNAME PROPVALUE) (* Koomen " 8-Jun-88 11:47") (DECLARE (GLOBALVARS *BUTTONPROPS* *BUTTONS-DEFAULT-ACTION* *BUTTONS-DEFAULT-LABEL* *BUTTONS-EDIT-SHADE* *BUTTONS-EXEC-SHADE* *BUTTONS-GRID-ORIGIN* *BUTTONS-LABEL-FONT* *BUTTONS-MENU-FONT* *BUTTONS-SAVE-DIRECTORY*)) (SELECTQ PROPNAME (NIL (for PROP in (CDR *BUTTONPROPS*) do (\BUTTONS-SETPROP (CAR PROP) (CADR PROP)))) (GRID-ORIGIN (SETQ *BUTTONS-GRID-ORIGIN* (POSITIONP PROPVALUE))) (SAVE-DIRECTORY (SETQ *BUTTONS-SAVE-DIRECTORY* (MKSTRING (DIRECTORYNAME PROPVALUE)))) (EDIT-SHADE (SETQ *BUTTONS-EDIT-SHADE* (SMALLP PROPVALUE))) (EXEC-SHADE (SETQ *BUTTONS-EXEC-SHADE* (SMALLP PROPVALUE))) (LABEL-FONT (SETQ *BUTTONS-LABEL-FONT* (FONTCREATE PROPVALUE))) (MENU-FONT (SETQ *BUTTONS-MENU-FONT* (FONTCREATE PROPVALUE))) (DEFAULT-ACTION (SETQ *BUTTONS-DEFAULT-ACTION* PROPVALUE)) (DEFAULT-LABEL (SETQ *BUTTONS-DEFAULT-LABEL* (MKSTRING PROPVALUE))) NIL)) ) (\BUTTONS-SHOW (LAMBDA (BUTTON SHADE) (* Koomen " 8-Jun-88 09:10") (* ;;; "Resets or inverts the inner area of the button with the given shade.") (DECLARE (GLOBALVARS *BUTTON-INVERT-REGION*)) (if BUTTON then (if (FIXP SHADE) then (DSPFILL *BUTTON-INVERT-REGION* SHADE (QUOTE INVERT) BUTTON) elseif (OR (EQ SHADE T) (OPENWP BUTTON)) then (\ICONW.REPAINTFN BUTTON)) BUTTON)) ) (\BUTTONS-SHOW-EXEC (LAMBDA (BUTTON EXECUTING?) (* Koomen " 8-Jun-88 08:56") (* ;;; "Resets or inverts the inner area of the button. Returns the button so it can be used inside a RESET.") (DECLARE (GLOBALVARS *BUTTONS-EXEC-SHADE*)) (replace (BUTTON EXECUTING?) of BUTTON with EXECUTING?) (\BUTTONS-SHOW BUTTON (if EXECUTING? then *BUTTONS-EXEC-SHADE*)) BUTTON) ) (\BUTTONS-TRACK-MOUSE (LAMBDA NIL (* Koomen "26-Oct-89 08:12") (DECLARE (GLOBALVARS *BUTTONS-GRID-ORIGIN* LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY SCREENHEIGHT SCREENWIDTH) (SPECVARS BB BH BL BR BT BW)) (if (NOT (POSITIONP *BUTTONS-GRID-ORIGIN*)) then (SETQ *BUTTONS-GRID-ORIGIN* (CREATEPOSITION 0 0))) (bind MOUSEUP? MOUSEDOWN? NEWBL NEWBB (GRIDXORIGIN _ (fetch (POSITION XCOORD) of *BUTTONS-GRID-ORIGIN*)) (GRIDYORIGIN _ (fetch (POSITION YCOORD) of *BUTTONS-GRID-ORIGIN*)) (GRIDWIDTH _ (PLUS 16 BW)) (GRIDHEIGHT _ (PLUS 8 BH)) (MAXBL _ (IDIFFERENCE SCREENWIDTH BW)) (MAXBB _ (IDIFFERENCE SCREENHEIGHT BH)) until (PROGN (SETQ MOUSEUP? (MOUSESTATE UP)) (if (NOT MOUSEUP?) then (SETQ MOUSEDOWN? T)) (AND MOUSEUP? MOUSEDOWN?)) do (SETQ NEWBL LASTMOUSEX) (SETQ NEWBB LASTMOUSEY) (if (NOT (KEYDOWNP (QUOTE LSHIFT))) then (SETQ NEWBL (IPLUS GRIDXORIGIN (ITIMES GRIDWIDTH (IQUOTIENT NEWBL GRIDWIDTH)))) (SETQ NEWBB (IPLUS GRIDYORIGIN (ITIMES GRIDHEIGHT (IQUOTIENT NEWBB GRIDHEIGHT))))) (SETQ NEWBL (MAX 0 (MIN NEWBL MAXBL))) (SETQ NEWBB (MAX 0 (MIN NEWBB MAXBB))) (if (OR (NEQ NEWBL BL) (NEQ NEWBB BB)) then (UNINTERRUPTABLY (\BUTTONS-DRAW-BOX) (* ; "wipe old") (SETQ BR (IPLUS BW (SETQ BL NEWBL))) (SETQ BT (IPLUS BH (SETQ BB NEWBB))) (\BUTTONS-DRAW-BOX) (* ; "draw new"))))) ) (\BUTTONS-WAIT-MOUSE (LAMBDA (BUTTON) (* Koomen " 8-Jun-88 08:53") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY)) (PROG ((REGION (WINDOWPROP BUTTON (QUOTE REGION)))) LP (GETMOUSESTATE) (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) then (RETURN) elseif (NOT (LASTMOUSESTATE UP)) then (BLOCK) (GO LP) else (RETURN T)))) ) ) (* The button icon) (FILESLOAD (SYSLOAD FROM LISPUSERS) ICONW) (DEFINEQ (DROPSHADOW (LAMBDA (BM SHADOWOFFSET SHADOWSHADE) (* Koomen "31-Dec-86 12:47") (PROG (IMAGE (OFFSET (OR SHADOWOFFSET 4)) (SHADE (OR SHADOWSHADE 42405)) (MASK (BITMAPCOPY BM)) (SHADOW (BITMAPCOPY BM))) (SETQ IMAGE (BITMAPCREATE (PLUS OFFSET (BITMAPWIDTH BM)) (PLUS OFFSET (BITMAPHEIGHT BM)) (BITSPERPIXEL BM))) (* * Compute mask * *) (BLTSHADE BLACKSHADE MASK) (CLEAR-MASK-OUTLINE MASK BM) (* * Fill shadow * *) (BLTSHADE SHADE SHADOW) (* * Remove outline from shadow * *) (BITBLT MASK NIL NIL SHADOW NIL NIL NIL NIL (QUOTE INVERT) (QUOTE ERASE)) (* * Put shadow in bottom-right corner of image * *) (BITBLT SHADOW NIL NIL IMAGE OFFSET NIL NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (* * Put original in top-left corner of image * *) (BITBLT MASK NIL NIL IMAGE NIL OFFSET NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (BITBLT BM NIL NIL IMAGE NIL OFFSET NIL NIL (QUOTE INPUT) (QUOTE PAINT)) (RETURN IMAGE))) ) (ICONMASK (LAMBDA (ICON) (* Koomen "31-Dec-86 12:40") (PROG ((MASK (BITMAPCOPY ICON))) (BITBLT ICON NIL NIL MASK NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) (CLEAR-MASK-OUTLINE MASK ICON) (RETURN MASK))) ) (CLEAR-MASK-OUTLINE (LAMBDA (MASK BM) (* Koomen "31-Dec-86 12:35") (* * Make outline of MASK same as BM * *) (for I from 0 to (SUB1 (BITMAPWIDTH BM)) bind (BMH _ (SUB1 (BITMAPHEIGHT BM))) do (for J from 0 to BMH by 1 while (ZEROP (BITMAPBIT BM I J)) do (BITMAPBIT MASK I J 0)) (for J from BMH to 0 by -1 while (ZEROP (BITMAPBIT BM I J)) do (BITMAPBIT MASK I J 0)))) ) ) (RPAQQ *BUTTON-BITMAP* #*(97 37)@OOOOOOOOOOOOOOOOOOOOOOH@@@@COOOOOOOOOOOOOOOOOOOOOON@@@@G@@@@@@@@@@@@@@@@@@@@@@G@@@@F@@@@@@@@@@@@@@@@@@@@@@C@@@@LGOOOOOOOOOOOOOOOOOOOOOAH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LH@@@@@@@@@@@@@@@@@@@@@IH@@@LGOOOOOOOOOOOOOOOOOOOOOAH@@@F@@@@@@@@@@@@@@@@@@@@@@C@@@@G@@@@@@@@@@@@@@@@@@@@@@G@@@@COOOOOOOOOOOOOOOOOOOOOON@@@@@OOOOOOOOOOOOOOOOOOOOOOH@@@@) (RPAQ? *BUTTON-INVERT-REGION* (QUOTE (6 10 85 25))) (RPAQ? *BUTTON-CLIPPING-REGION* (QUOTE (7 11 83 23))) (RPAQ? *BUTTON-ICON* (DROPSHADOW *BUTTON-BITMAP*)) (RPAQ? *BUTTON-ICON-MASK* (ICONMASK *BUTTON-ICON*)) (ADDTOVAR BackgroundMenuCommands ("Button Control" (QUOTE (EDIT-BUTTON)) "Manipulate action buttons")) (RPAQQ BackgroundMenu NIL) (\BUTTONS-INIT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA BUTTON-LABEL BUTTON-ACTION BUTTONSPROP) ) (PUTPROPS BUTTONS COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3565 14600 (ALIGN-BUTTONS 3575 . 4350) (BUTTONP 4352 . 4557) (BUTTONSPROP 4559 . 5104) (BUTTON-ACTION 5106 . 5470) (BUTTON-LABEL 5472 . 5881) (CLOSE-BUTTON 5883 . 5993) (CLOSE-BUTTONS 5995 . 6176) (COPY-BUTTON 6178 . 6399) (CREATE-BUTTON 6401 . 7810) (DELETE-BUTTON 7812 . 8013) ( DELETE-BUTTONS 8015 . 8209) (EDIT-BUTTON 8211 . 8946) (EDIT-BUTTON-CONTENTS 8948 . 9580) ( EXECUTE-BUTTON 9582 . 9998) (EXPOSE-BUTTONS 10000 . 10186) (LOAD-SOME-BUTTONS 10188 . 10524) ( MOVE-BUTTON 10526 . 11489) (REDISPLAY-BUTTON 11491 . 11751) (RESTORE-BUTTONS 11753 . 12582) ( SAVE-BUTTONS 12584 . 13332) (SAVE-SOME-BUTTONS 13334 . 14598)) (15579 25703 (\BUTTONS-BUTTONEVENTFN 15589 . 15972) (\BUTTONS-DATAFILE-NAME 15974 . 16670) (\BUTTONS-CHANGE-LABEL 16672 . 16929) ( \BUTTONS-CREATE-ICON 16931 . 17818) (\BUTTONS-DRAW-BOX 17820 . 17994) (\BUTTONS-EDITE 17996 . 18160) ( \BUTTONS-EDIT-MENU 18162 . 19779) (\BUTTONS-INIT 19781 . 20029) (\BUTTONS-IO-EXIT 20031 . 20257) ( \BUTTONS-OPEN-STREAM 20259 . 20690) (\BUTTONS-PROMPT-FOR-DATAFILE-NAME 20692 . 21045) (\BUTTONS-READ 21047 . 22401) (\BUTTONS-SETPROP 22403 . 23333) (\BUTTONS-SHOW 23335 . 23713) (\BUTTONS-SHOW-EXEC 23715 . 24082) (\BUTTONS-TRACK-MOUSE 24084 . 25358) (\BUTTONS-WAIT-MOUSE 25360 . 25701)) (25776 27275 (DROPSHADOW 25786 . 26685) (ICONMASK 26687 . 26900) (CLEAR-MASK-OUTLINE 26902 . 27273))))) STOP \ No newline at end of file diff --git a/lispusers/BUTTONS.TEDIT b/lispusers/BUTTONS.TEDIT new file mode 100644 index 00000000..322fb93e Binary files /dev/null and b/lispusers/BUTTONS.TEDIT differ diff --git a/lispusers/BackgroundImages.TEDIT b/lispusers/BackgroundImages.TEDIT new file mode 100644 index 00000000..2ca9f26d Binary files /dev/null and b/lispusers/BackgroundImages.TEDIT differ diff --git a/lispusers/BackgroundMenu.TEDIT b/lispusers/BackgroundMenu.TEDIT new file mode 100644 index 00000000..251f6d74 Binary files /dev/null and b/lispusers/BackgroundMenu.TEDIT differ diff --git a/lispusers/C150STREAM b/lispusers/C150STREAM new file mode 100644 index 00000000..b69db73a --- /dev/null +++ b/lispusers/C150STREAM @@ -0,0 +1 @@ +(FILECREATED " 3-Apr-86 18:16:05" {ERIS}LIBRARY>C150STREAM.;15 139806 changes to: (FNS CREATEC150BUFFER) (VARS C150COLORMAP C150FONTDIRECTORIES) previous date: " 3-Apr-86 16:05:11" {ERIS}LIBRARY>C150STREAM.;14) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT C150STREAMCOMS) (RPAQQ C150STREAMCOMS ((CONSTANTS \C150PointsPerInch \C150RealBPP) (FNS C150.SEPARATOR C150.SETMARGINS \C150.ALLWHITESPACE \C150.BUFFER.DOT \C150.MICROLINEFEED \C150.SENDLINE \C150.SENDLINEINFO \C150INIT \CREATECHARSET.C150) (FNS CREATEC150BUFFER NEWLINE.C150 NEWPAGE.C150 OPENC150STREAM C150.RESET SEND.TO.C150 STARTPAGE.C150 \BITBLT.C150 \BLTCHAR.C150 \BLTSHADE.C150 \C150.CRLF \CHANGECHARSET.C150 \CHARWIDTH.C150 \CLOSEFN.C150 \CREATEC150FONT \READC150FONTFILE \DRAWCIRCLE.C150 \DRAWCURVE.C150 \DRAWELLIPSE.C150 \DRAWLINE.C150 \DSPBACKCOLOR.C150 \DSPCLIPPINGREGION.C150 \DSPCOLOR.C150 \C150.ASSURE.COLOR \C150.LOOKUPRGB \DSPFONT.C150 \DSPLEFTMARGIN.C150 \DSPLINEFEED.C150 \DSPOPERATION.C150 \DSPPRINTCHAR.C150 \DSPPRINTCR/LF.C150 \DSPRESET.C150 \DSPRIGHTMARGIN.C150 \DSPXPOSITION.C150 \DSPYPOSITION.C150 \DUMPPAGEBUFFER.C150 \FILLCIRCLE.C150 \OUTCHARFN.C150 \SEARCHC150FONTFILES \STRINGWIDTH.C150) (VARS MISSINGC150FONTCOERCIONS (\C150COLORTABLE) (\C150.FRAMEBUFFER) (\C150STREAM) C150COLORMAP C150FONTCOERCIONS C150FONTDIRECTORIES C150FONTEXTENSIONS) (INITVARS (C150.CLIPBUFFER T) (\C150DEFAULTDEVICE (QUOTE CENTRONICS))) (FNS COLORMAP.TO.C150TABLE) (FILES COLOR XXGEOM XXFILL) [P (IF (NOT (GETD (QUOTE POLYSHADE.BLT))) THEN (* A fix for KOTO, which is not necessary in n>) (MOVD (QUOTE POLYSHADE.DISPLAY) (QUOTE POLYSHADE.BLT] (DECLARE: DONTEVAL@LOAD DOCOPY (P (\C150INIT)) (FILES CENTRONICS)) (DECLARE: EVAL@LOAD DONTCOPY (FILES (LOADFROM) ADISPLAY LLDISPLAY)) (MACROS \C150BackingStream))) (DECLARE: EVAL@COMPILE (RPAQQ \C150PointsPerInch 120) (RPAQQ \C150RealBPP 4) (CONSTANTS \C150PointsPerInch \C150RealBPP) ) (DEFINEQ (C150.SEPARATOR [LAMBDA (BACKINGSTREAM) (* hdj " 5-Sep-85 12:12") (LET ((SEPR.LENGTH 30)) (for C instring (CONCAT "g0" SEPR.LENGTH " ") do (BOUT BACKINGSTREAM C)) (for DASH from 1 to SEPR.LENGTH do (BOUT BACKINGSTREAM 255]) (C150.SETMARGINS [LAMBDA (BACKINGSTREAM C150LEFT C150RIGHT) (* hdj " 5-Sep-85 12:21") (* * Set the left and right margins for the C150 printer) (LET [[LEFTCODE (CONCAT (FIX (TIMES 10 (if (OR (EQ C150LEFT NIL) (LESSP C150LEFT .5) (GEQ C150LEFT 9.0) (GEQ C150LEFT C150RIGHT)) then .5 else C150LEFT] (RIGHTCODE (CONCAT (FIX (TIMES 10 (if (OR (EQ C150RIGHT NIL) (GREATERP C150RIGHT 9) (LEQ C150RIGHT .5) (LEQ C150RIGHT C150LEFT)) then 9 else C150RIGHT] (* send the left margin) (BOUT BACKINGSTREAM (CHARCODE ESC)) (BOUT BACKINGSTREAM (CHARCODE l)) (for CHAR instring LEFTCODE do (BOUT BACKINGSTREAM CHAR)) (BOUT BACKINGSTREAM (CHARCODE CR)) (* send the right margin) (BOUT BACKINGSTREAM (CHARCODE ESC)) (BOUT BACKINGSTREAM (CHARCODE r)) (for CHAR instring RIGHTCODE do (BOUT BACKINGSTREAM CHAR)) (BOUT BACKINGSTREAM (CHARCODE CR]) (\C150.ALLWHITESPACE [LAMBDA (BITMAP TABLES STARTINGSCAN) (* hdj " 6-Aug-85 15:50") (* is there anything to print on the next 4 scanlines?) (LET*((MaxX (SUB1 (BITMAPWIDTH BITMAP))) [MaxColor (SUB1 (EXPT 2 (BITSPERPIXEL BITMAP] (COLORUSED? (ARRAY (ADD1 MaxColor) (QUOTE POINTER) NIL 0)) (BlackTable (ELT TABLES 0)) (MagentaTable (ELT TABLES 1)) (YellowTable (ELT TABLES 2)) (CyanTable (ELT TABLES 3))) (for Scanline from STARTINGSCAN to (IDIFFERENCE STARTINGSCAN 3) by -1 do (for X from 0 to MaxX do (SETA COLORUSED? (BITMAPBIT BITMAP X Scanline) T))) (for Value from 0 to MaxColor never (AND (ELT COLORUSED? Value) (OR (EQ (ELT BlackTable Value) 1) (EQ (ELT MagentaTable Value) 1) (EQ (ELT YellowTable Value) 1) (EQ (ELT CyanTable Value) 1]) (\C150.BUFFER.DOT [LAMBDA (DOT X BUFFER) (* hdj " 3-Aug-85 20:55") (SETA BUFFER X DOT]) (\C150.MICROLINEFEED [LAMBDA (BACKINGSTREAM) (* hdj " 5-Sep-85 12:12") (for CHAR instring "k1" do (BOUT BACKINGSTREAM CHAR]) (\C150.SENDLINE [LAMBDA (BACKINGSTREAM LINE# COLOR BUFFER) (* hdj " 5-Sep-85 12:13") (for CHAR instring (CONCAT "g" (CHARACTER (IPLUS (ITIMES 4 COLOR) (IREMAINDER LINE# 4) (CHARCODE 0))) (FOLDHI (ARRAYSIZE BUFFER) 8) " ") do (BOUT BACKINGSTREAM CHAR)) (bind (BYTE.TO.SEND _ 0) for BYTE from 0 to (SUB1 (ARRAYSIZE BUFFER)) by 8 do [for BIT from 7 to 0 by -1 do (SETQ BYTE.TO.SEND (LOGOR BYTE.TO.SEND (LLSH (ELT BUFFER (IPLUS BYTE BIT)) BIT] (BOUT BACKINGSTREAM BYTE.TO.SEND]) (\C150.SENDLINEINFO [LAMBDA (BACKINGSTREAM COLOR LENGTHINBYTES LINE#) (* hdj " 5-Sep-85 12:13") (for CHAR instring (CONCAT "g" (CHARACTER (IPLUS (UNFOLD COLOR 4) LINE# (CHARCODE 0))) LENGTHINBYTES " ") do (BOUT BACKINGSTREAM CHAR]) (\C150INIT [LAMBDA NIL (* gbn " 5-Nov-85 19:34") (* Initializes global variables for the C150) (DECLARE (GLOBALVARS \C150IMAGEOPS)) (SETQ \C150IMAGEOPS (create IMAGEOPS IMAGETYPE _(QUOTE C150) IMFONT _(FUNCTION \DSPFONT.C150) IMLEFTMARGIN _(FUNCTION \DSPLEFTMARGIN.C150) IMRIGHTMARGIN _(FUNCTION \DSPRIGHTMARGIN.C150) IMLINEFEED _(FUNCTION \DSPLINEFEED.C150) IMXPOSITION _(FUNCTION \DSPXPOSITION.C150) IMYPOSITION _(FUNCTION \DSPYPOSITION.C150) IMCLOSEFN _(FUNCTION \CLOSEFN.C150) IMDRAWCURVE _(FUNCTION \DRAWCURVE.C150) IMFILLCIRCLE _(QUOTE \FILLCIRCLE.C150) IMDRAWLINE _(FUNCTION \DRAWLINE.C150) IMDRAWELLIPSE _(FUNCTION \DRAWELLIPSE.C150) IMDRAWCIRCLE _(FUNCTION \DRAWCIRCLE.C150) IMBITBLT _(FUNCTION \BITBLT.C150) IMBLTSHADE _(FUNCTION \BLTSHADE.C150) IMNEWPAGE _(FUNCTION NEWPAGE.C150) IMSCALE _[FUNCTION (LAMBDA NIL (FQUOTIENT 120 72] IMSPACEFACTOR _(FUNCTION NILL) IMFONTCREATE _(QUOTE C150) IMCOLOR _(FUNCTION \DSPCOLOR.C150) IMBACKCOLOR _(FUNCTION \DSPBACKCOLOR.C150) IMOPERATION _(FUNCTION \DSPOPERATION.C150) IMSTRINGWIDTH _(FUNCTION \STRINGWIDTH.C150) IMCHARWIDTH _(FUNCTION \CHARWIDTH.C150) IMCLIPPINGREGION _(FUNCTION \DSPCLIPPINGREGION.C150) IMRESET _(FUNCTION \DSPRESET.C150) IMFILLPOLYGON _(FUNCTION POLYSHADE.BLT))) [push IMAGESTREAMTYPES (LIST (QUOTE C150) (LIST (QUOTE OPENSTREAM) (FUNCTION OPENC150STREAM)) (LIST (QUOTE FONTCREATE) (FUNCTION \CREATEC150FONT)) (LIST (QUOTE FONTSAVAILABLE) (FUNCTION \SEARCHC150FONTFILES)) (LIST (QUOTE CREATECHARSET) (FUNCTION \CREATECHARSET.C150] (push PRINTERTYPES (LIST (LIST (QUOTE C150)) (LIST (QUOTE CANPRINT) (LIST (QUOTE C150))) (LIST (QUOTE STATUS) (FUNCTION TRUE)) (LIST (QUOTE PROPERTIES) (FUNCTION NILL)) (LIST (QUOTE SEND) (FUNCTION SEND.TO.C150)) (LIST (QUOTE BITMAPSCALE) NIL) (LIST (QUOTE BITMAPFILE) NIL))) (ADDTOVAR DEFAULTPRINTINGHOST (C150 C150)) (PUTPROP (QUOTE C150) (QUOTE PRINTERTYPE) (QUOTE C150)) [push PRINTFILETYPES (LIST (QUOTE C150) (LIST (QUOTE TEST) (FUNCTION NILL)) (LIST (QUOTE EXTENSION) (LIST (QUOTE C150] (DEFAULTFONT (QUOTE C150) (QUOTE (CLASSIC 10 MRR)) (QUOTE NEW)) T]) (\CREATECHARSET.C150 [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* gbn " 9-Jan-86 13:00") (* * tries to build the csinfo required for CHARSET. Does the necessary coercions. Returns NIL when unsuccessful (\CREATECHARSET will do the same)) (* * NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL) (DECLARE (GLOBALVARS C150FONTCOERCIONS MISSINGC150FONTCOERCIONS)) (* C150FONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...)%. Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.) (COND ((PROG1 (for TRANSL in C150FONTCOERCIONS bind NEWCSINFO USERFONT REALFONT when (AND (SETQ USERFONT (CAR TRANSL)) (EQ FAMILY (CAR USERFONT)) (OR (NOT (CADR USERFONT)) (EQ SIZE (CADR USERFONT))) (OR (NOT (CADDR USERFONT)) (EQ CHARSET (CADDR USERFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\CREATECHARSET.C150 (OR (CAR REALFONT) FAMILY) (OR (CADR REALFONT) SIZE) FACE ROTATION DEVICE (OR (CADDR REALFONT) CHARSET) FONTDESC NOSLUG?))) do (RETURN NEWCSINFO)) (* Just recursively call ourselves to handle entries in C150FONTCOERCIONS) )) ((AND (EQ ROTATION 0) (* If it is available, this will force the appropriate file to be read to fill in the charset entry) (\READC150FONTFILE FAMILY SIZE FACE ROTATION (QUOTE C150) CHARSET))) (T (* * if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised "by hand") (PROG (NEWFONT XFONT XLATEDFAM) (RETURN (COND [(NEQ ROTATION 0) (* to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.) (OR (MEMB ROTATION (QUOTE (90 270))) (ERROR "only implemented rotations are 0, 90 and 270." ROTATION)) (COND ((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 (QUOTE C150) T CHARSET)) (* actually call FONTCREATE here, rather than \CREATEC150FONT or \CREATECHARSET.C150 so that the vanilla font that is built in this process will be cached and not repeated.) (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) then (\SFROTATECSINFO CSINFO ROTATION) else NIL] ((AND (EQ (fetch WEIGHT of FACE) (QUOTE BOLD)) (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE using FACE WEIGHT _(QUOTE MEDIUM)) 0 (QUOTE C150) T CHARSET))) (* if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo) (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) then (\SFMAKEBOLD CSINFO) else NIL)) ((AND (EQ (fetch SLOPE of FACE) (QUOTE ITALIC)) (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE using FACE SLOPE _(QUOTE REGULAR)) 0 (QUOTE C150) T CHARSET))) (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) then (\SFMAKEITALIC CSINFO) else NIL)) ((for TRANSL in MISSINGC150FONTCOERCIONS bind NEWCSINFO USERFONT REALFONT when (AND (SETQ USERFONT (CAR TRANSL)) (EQ FAMILY (CAR USERFONT)) (OR (NOT (CADR USERFONT)) (EQ SIZE (CADR USERFONT))) (OR (NOT (CADDR USERFONT)) (EQ CHARSET (CADDR USERFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\CREATECHARSET.C150 (OR (CAR REALFONT) FAMILY) (OR (CADR REALFONT) SIZE) FACE ROTATION DEVICE (OR (CADDR REALFONT) CHARSET) FONTDESC NOSLUG?))) do (RETURN NEWCSINFO))) ((NOT NOSLUG?) (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC) (FONTPROP FONTDESC (QUOTE ASCENT)) (FONTPROP FONTDESC (QUOTE DESCENT)) (FONTPROP FONTDESC (QUOTE DEVICE]) ) (DEFINEQ (CREATEC150BUFFER [LAMBDA (WIDTH HEIGHT) (* FS " 3-Apr-86 18:14") (LET*((BITWIDTH (ITIMES WIDTH \C150RealBPP)) (RASTERWIDTH (FOLDHI BITWIDTH BITSPERWORD)) (PAGES (FOLDHI (ITIMES RASTERWIDTH HEIGHT) WORDSPERPAGE))) (* * (create BITMAP BITMAPBITSPERPIXEL _ \C150RealBPP BITMAPRASTERWIDTH _ RASTERWIDTH BITMAPWIDTH _ BITWIDTH BITMAPHEIGHT _ HEIGHT BITMAPBASE _ (OR (\ALLOCPAGEBLOCK PAGES) (HELP "Can't allocate C150 buffer - pages needed = " PAGES)))) (* * Don't think code above is correct, commented out and added below, changing BITMAPWIDTH, and ignoring \MaxBitMapWords (safe?????) * *) (create BITMAP BITMAPBITSPERPIXEL _ \C150RealBPP BITMAPRASTERWIDTH _ RASTERWIDTH BITMAPWIDTH _ WIDTH BITMAPHEIGHT _ HEIGHT BITMAPBASE _(OR (\ALLOCPAGEBLOCK PAGES) (HELP "Can't allocate C150 buffer - pages needed = " PAGES]) (NEWLINE.C150 [LAMBDA (C150STREAM) (* hdj " 6-Jun-85 14:01") (* Go to next line (or next page if on last line)) (LET*[(C150DATA (fetch IMAGEDATA of C150STREAM)) (NEWYPOS (IPLUS (ffetch DDYPOSITION of C150DATA) (ffetch DDLINEFEED of C150DATA] (COND ((ILESSP NEWYPOS (ffetch DDClippingBottom of C150DATA)) (NEWPAGE.C150 C150STREAM)) (T (\DSPXPOSITION.C150 C150STREAM (ffetch DDLeftMargin of C150DATA)) (\DSPYPOSITION.C150 C150STREAM NEWYPOS]) (NEWPAGE.C150 [LAMBDA (C150STREAM) (* hdj " 7-Aug-85 16:48") (LET ((DD (fetch (STREAM IMAGEDATA) of C150STREAM))) [\DUMPPAGEBUFFER.C150 (fetch DDDestination of DD) C150STREAM (OR \C150COLORTABLE (SETQ \C150COLORTABLE (COLORMAP.TO.C150TABLE C150COLORMAP] (STARTPAGE.C150 C150STREAM]) (OPENC150STREAM [LAMBDA (C150FILE OPTIONS) (* gbn " 6-Nov-85 19:08") (* Opens a C150 stream) (* open a C150 stream. keep a permanent pointer to the frame buffer, because it can never be gc'ed any way, and we want to recycle it -- only allow one of them to be open at a time, due to global frame buffer) (DECLARE (GLOBALVARS \C150IMAGEOPS C150BAUDRATE \C150STREAM)) (if (AND (STREAMP \C150STREAM) (OPENP \C150STREAM)) then (ERROR "Sorry - you can only have one C150 stream open at one time" \C150STREAM) else (if (EQ (FILENAMEFIELD C150FILE (QUOTE HOST)) (QUOTE LPT)) then (* if the hardcopy interface is opening to the LPT pseudodevice, change it to be the device that the printer is actually connected to.) (SETQ C150FILE (PACKFILENAME (QUOTE HOST) \C150DEFAULTDEVICE (QUOTE BODY) C150FILE))) (LET*[(WIDTH (FIX (TIMES 8.5 \C150PointsPerInch))) (HEIGHT (FIX (TIMES 11 \C150PointsPerInch))) (BACKINGSTREAM (OPENSTREAM C150FILE (QUOTE OUTPUT))) (C150STREAM (SETQ \C150STREAM (DSPCREATE (OR \C150.FRAMEBUFFER (SETQ \C150.FRAMEBUFFER (CREATEC150BUFFER WIDTH HEIGHT] (replace (STREAM F1) of C150STREAM with BACKINGSTREAM) (replace (STREAM OUTCHARFN) of C150STREAM with (FUNCTION \OUTCHARFN.C150)) (replace (STREAM STRMBOUTFN) of C150STREAM with (FUNCTION \DSPPRINTCHAR.C150)) (replace (STREAM USERCLOSEABLE) of C150STREAM with T) (replace (STREAM IMAGEOPS) of C150STREAM with \C150IMAGEOPS) (replace (\DISPLAYDATA DDClippingRegion) of (\GETDISPLAYDATA C150STREAM) with (CREATEREGION 0 0 WIDTH HEIGHT)) (STREAMPROP C150STREAM (QUOTE COLORMAPCACHE) (LIST NIL)) (DSPLEFTMARGIN 0 C150STREAM) (DSPRIGHTMARGIN WIDTH C150STREAM) (DSPCOLOR 0 C150STREAM) (DSPBACKCOLOR 7 C150STREAM) (STARTPAGE.C150 C150STREAM) C150STREAM]) (C150.RESET [LAMBDA NIL (* gbn " 7-Nov-85 22:42") (* * just does things that the user prob doesn't know about.) (SETQ \C150STREAM) (CLOSEF? (QUOTE {CENTRONICS})) (CENTRONICS.RESET]) (SEND.TO.C150 [LAMBDA (HOST FILE PRINTOPTIONS) (* hdj " 6-Jun-85 15:37") (COPYFILE FILE (PACKFILENAME (QUOTE HOST) (QUOTE LPT) (QUOTE NAME) HOST (QUOTE EXTENSION) (QUOTE C150]) (STARTPAGE.C150 [LAMBDA (C150STREAM) (* hdj " 6-Aug-85 11:20") (LET*((DD (\GETDISPLAYDATA C150STREAM)) (CREG (fetch DDClippingRegion of DD)) (FONTASCENT (FONTASCENT (fetch DDFONT of DD))) (PAGEBUFFER (fetch DDDestination of DD))) (BLTSHADE (DSPBACKCOLOR NIL C150STREAM) PAGEBUFFER) (\DSPXPOSITION.C150 C150STREAM (fetch DDLeftMargin of DD)) (\DSPYPOSITION.C150 C150STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG) FONTASCENT]) (\BITBLT.C150 [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* hdj " 6-Jun-85 16:17") (DECLARE (LOCALVARS . T)) (PROG (stodx stody left top bottom right DESTBITMAP DESTINATIONNBITS (SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL ) of SOURCEBITMAP)) (DESTDD (fetch IMAGEDATA of DESTSTRM))) (SETQ DESTBITMAP (fetch DDDestination of DESTDD)) [PROGN (* compute limits based on clipping regions.) (SETQ left (fetch DDClippingLeft of DESTDD)) (SETQ bottom (fetch DDClippingBottom of DESTDD)) (SETQ right (fetch DDClippingRight of DESTDD)) (SETQ top (fetch DDClippingTop of DESTDD)) (COND (CLIPPINGREGION (* hard case, two destination clipping regions: do calculations to merge them.) (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (fetch LEFT of CLIPPINGREGION] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (fetch BOTTOM of CLIPPINGREGION ] [SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH of CLIPPINGREGION ] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT of CLIPPINGREGION] (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) (* left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.) [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* WIDTH is optional) (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* HEIGHT is optional) (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* Clip and translate coordinates.) (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) (* compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.) [PROGN (* compute left margin) (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx) 0)) (* compute bottom margin) (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody) 0)) (* compute right margin) (SETQ right (IMIN (\PIXELOFBITADDRESS SOURCENBITS (ffetch BITMAPWIDTH of SOURCEBITMAP )) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* compute top margin) (SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((AND (IGREATERP right left) (IGREATERP top bottom))) (T (* there is nothing to move.) (RETURN))) (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) (* We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic. But we might get interrupted before we go interruptable, so we do it there too.) (COND [(EQ SOURCENBITS DESTINATIONNBITS) (* going from one to another of the same size.) (* use LLSH with constant value rather than multiple because it compiles into opcodes.) [COND ((EQ DESTINATIONNBITS 4) (SETQ left (LLSH left 2)) (SETQ right (LLSH right 2)) (SETQ stodx (LLSH stodx 2))) (T (SETQ left (LLSH left 3)) (SETQ right (LLSH right 3)) (SETQ stodx (LLSH stodx 3] (* set texture if it will ever get looked at.) (AND (EQ SOURCETYPE (QUOTE MERGE)) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS))) (* easy case of color to color) (PROG ([PILOTBBT (COND ((type? PILOTBBT \SYSPILOTBBT) \SYSPILOTBBT) (T (SETQ \SYSPILOTBBT (create PILOTBBT] (HEIGHT (IDIFFERENCE top bottom)) (WIDTH (IDIFFERENCE right left)) (DTY (\SFInvert DESTBITMAP (IPLUS top stody))) (DLX (IPLUS left stodx)) (STY (\SFInvert SOURCEBITMAP top)) (SLX left)) (replace PBTWIDTH of PILOTBBT with WIDTH) (replace PBTHEIGHT of PILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE (QUOTE MERGE)) (\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)) (T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT SOURCETYPE OPERATION TEXTURE] [(EQ SOURCENBITS 1) (* going from a black and white bitmap to a color map) (AND SOURCETYPE (NEQ SOURCETYPE (QUOTE INPUT)) (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) (PROG ((HEIGHT (IDIFFERENCE top bottom)) (WIDTH (IDIFFERENCE right left)) (DBOT (IPLUS bottom stody)) (DLFT (IPLUS left stodx))) (SELECTQ OPERATION ((NIL REPLACE) (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH HEIGHT (COLORNUMBERP (fetch (\DISPLAYDATA DDBACKGROUNDCOLOR) of DESTDD)) (COLORNUMBERP (fetch (\DISPLAYDATA DDFOREGROUNDCOLOR) of DESTDD)) DESTINATIONNBITS)) (PAINT) (INVERT) (ERASE) (SHOULDNT] (T (* going from color map into black and white map.) (ERROR "not implemented to blt between bitmaps of different pixel size."))) (RETURN T]) (\BLTCHAR.C150 [LAMBDA (CHARCODE C150STREAM C150DATA) (* hdj "19-Jul-85 13:32") (* * puts a character on a C150STREAM. Since a C150STREAM is based on a color bitmap stream, we can use \SLOWBLTCHAR) [COND ((NEQ (ffetch DDCHARSET of C150DATA) (\CHARSET CHARCODE)) (* The charset has changed.) (\CHANGECHARSET.C150 C150DATA (\CHARSET CHARCODE] (LET [(CHAR8CODE (\CHAR8CODE CHARCODE)) (ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch DDFONT of C150DATA] (COND [(EQ 0 ROTATION) (PROG (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of C150DATA))) [COND ((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE C150DATA))) (ffetch DDRightMargin of C150DATA)) (* past RIGHT margin, force eol) (\DSPPRINTCR/LF.C150 (CHARCODE EOL) C150STREAM) (SETQ CURX (ffetch DDXPOSITION of C150DATA)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE C150DATA] (* update the x position.) (freplace DDXPOSITION of C150DATA with NEWX) (SETQ LEFT (IMAX (ffetch DDClippingLeft of C150DATA) CURX)) (SETQ RIGHT (IMIN (ffetch DDClippingRight of C150DATA) NEWX)) (COND ((AND (ILESSP LEFT RIGHT) (NEQ (ffetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT of C150DATA))) 0)) (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA DDDestination) of C150DATA)) (1 (freplace PBTDESTBIT of NEWX with LEFT) (freplace PBTWIDTH of NEWX with (IDIFFERENCE RIGHT LEFT)) (freplace PBTSOURCEBIT of NEWX with (IDIFFERENCE (IPLUS ( \DSPGETCHAROFFSET CHAR8CODE C150DATA) LEFT) CURX)) (\PILOTBITBLT NEWX 0)) (4 (freplace PBTDESTBIT of NEWX with (SETQ LEFT (LLSH LEFT 2))) (freplace PBTWIDTH of NEWX with (IDIFFERENCE (LLSH RIGHT 2) LEFT)) (freplace PBTSOURCEBIT of NEWX with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET CHAR8CODE C150DATA ) 2) LEFT) (LLSH CURX 2))) (\PILOTBITBLT NEWX 0)) (8 (freplace PBTDESTBIT of NEWX with (SETQ LEFT (LLSH LEFT 3))) (freplace PBTWIDTH of NEWX with (IDIFFERENCE (LLSH RIGHT 3) LEFT)) (freplace PBTSOURCEBIT of NEWX with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET CHAR8CODE C150DATA ) 3) LEFT) (LLSH CURX 3))) (\PILOTBITBLT NEWX 0)) (SHOULDNT)) T] (T (* handle rotated fonts) (LET [(YPOS (ffetch DDYPOSITION of C150DATA)) (HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE C150DATA)) (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) (ffetch DDFONT of C150DATA] (COND ((EQ ROTATION 90) (* don't force CR for rotated fonts.) (\DSPYPOSITION.C150 C150STREAM (IPLUS YPOS HEIGHTMOVED)) (* update the display stream x position.) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE C150DATA) C150STREAM (ADD1 (IDIFFERENCE (ffetch DDXPOSITION of C150DATA) (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO))) YPOS (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) ((EQ ROTATION 270) (\DSPYPOSITION.C150 C150STREAM (IDIFFERENCE YPOS HEIGHTMOVED)) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE C150DATA) C150STREAM (IDIFFERENCE (ffetch DDXPOSITION of C150DATA) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (ffetch DDYPOSITION of C150STREAM) (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) (T (ERROR "Not implemented to rotate by other than 0, 90 or 270"]) (\BLTSHADE.C150 [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* gbn " 5-Nov-85 18:42") (* BLTSHADE to C150 color printer) (DECLARE (LOCALVARS . T)) (PROG (left top bottom right DESTINATIONNBITS DESTINATIONBITMAP (DESTDD (fetch IMAGEDATA of STREAM))) (SETQ DESTINATIONLEFT DESTINATIONLEFT) (SETQ DESTINATIONBOTTOM DESTINATIONBOTTOM) [PROGN (* compute limits based on clipping regions.) (SETQ left (fetch DDClippingLeft of DESTDD)) (SETQ bottom (fetch DDClippingBottom of DESTDD)) (SETQ right (fetch DDClippingRight of DESTDD)) (SETQ top (fetch DDClippingTop of DESTDD)) (COND (CLIPPINGREGION (* hard case, two destination clipping regions: do calculations to merge them.) (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (fetch LEFT of CLIPPINGREGION] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (fetch BOTTOM of CLIPPINGREGION ] [SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH of CLIPPINGREGION ] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT of CLIPPINGREGION] [SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of (SETQ DESTINATIONBITMAP (fetch DDDestination of DESTDD] (* SETQ right (\PIXELOFBITADDRESS DESTINATIONNBITS right)) (* left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.) [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* WIDTH is optional) (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* HEIGHT is optional) (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* there is nothing to move.) (RETURN))) [SETQ TEXTURE (COND ((NULL TEXTURE) (DSPBACKCOLOR NIL STREAM)) [(FIXP TEXTURE) (* if fixp use the low order bits as a color number. This picks up the case of BLACKSHADE being used to INVERT.) (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (LOGAND TEXTURE (COND ((EQ DESTINATIONNBITS 4) 15) (T 255] (T (\C150.ASSURE.COLOR TEXTURE STREAM] (* filling an area with a texture.) (SETQ left (ITIMES DESTINATIONNBITS left)) (SETQ right (ITIMES DESTINATIONNBITS right)) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)) (* easy case of black and white bitmap into black and white or color to color or texture filling.) (* We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic. But we might get interrupted before we go interruptable, so we do it there too.) (PROG ([PILOTBBT (COND ((type? PILOTBBT \SYSPILOTBBT) \SYSPILOTBBT) (T (SETQ \SYSPILOTBBT (create PILOTBBT] (HEIGHT (IDIFFERENCE top bottom))) (replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left)) (replace PBTHEIGHT of PILOTBBT with HEIGHT) (\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP top) HEIGHT (QUOTE TEXTURE) (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)) TEXTURE)) (RETURN T]) (\C150.CRLF [LAMBDA (STREAM) (* hdj "25-Jan-85 17:11") (* Send a CRLF to the printer) (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF]) (\CHANGECHARSET.C150 [LAMBDA (DISPLAYDATA CHARSET) (* hdj "19-Jul-85 13:48") (* Called when the character set information cached in a display stream doesn't correspond to CHARSET) (PROG [BM (PBT (ffetch DDPILOTBBT of DISPLAYDATA)) (CSINFO (COND ((IEQP 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA DDDestination) of DISPLAYDATA))) (\GETCHARSETINFO CHARSET (ffetch DDFONT of DISPLAYDATA))) (T (\GETCOLORCSINFO (fetch (\DISPLAYDATA DDFONT) of DISPLAYDATA) (fetch DDFOREGROUNDCOLOR of DISPLAYDATA) (fetch DDBACKGROUNDCOLOR of DISPLAYDATA) (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA DDDestination) of DISPLAYDATA)) CHARSET] (UNINTERRUPTABLY (freplace DDWIDTHSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO WIDTHS) of CSINFO)) (freplace DDOFFSETSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO OFFSETS) of CSINFO)) (freplace DDCHARIMAGEWIDTHS of DISPLAYDATA with (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (freplace DDCHARSET of DISPLAYDATA with CHARSET) (SETQ BM (ffetch CHARSETBITMAP of CSINFO)) (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH of BM) BITSPERWORD)) [if (OR (NEQ (ffetch DDCHARSETASCENT of DISPLAYDATA) (ffetch CHARSETASCENT of CSINFO)) (NEQ (ffetch DDCHARSETDESCENT of DISPLAYDATA) (ffetch CHARSETDESCENT of CSINFO))) then (\SFFixY DISPLAYDATA CSINFO) else (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of BM) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (ffetch DDCHARHEIGHTDELTA of DISPLAYDATA])]) (\CHARWIDTH.C150 [LAMBDA (C150STREAM CHARCODE) (* hdj " 5-Jun-85 12:56") (* gets the width of a character code in a display stream. Need to fix up for spacefactor.) (\FGETWIDTH (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (ffetch IMAGEDATA of C150STREAM)) CHARCODE]) (\CLOSEFN.C150 [LAMBDA (C150STREAM) (* hdj " 4-Oct-85 12:31") (* * do cleanup prefatory to closing. dump last buffer and close the backing stream) (LET ((DD (fetch (STREAM IMAGEDATA) of C150STREAM))) [\DUMPPAGEBUFFER.C150 (fetch DDDestination of DD) C150STREAM (OR \C150COLORTABLE (SETQ \C150COLORTABLE (COLORMAP.TO.C150TABLE C150COLORMAP] (CLOSEF (\C150BackingStream C150STREAM]) (\CREATEC150FONT [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn " 8-Jan-86 17:09") (* * create a font for the C150, synthesizing it if we must) (PROG [(FONTDESC (create FONTDESCRIPTOR FONTDEVICE _(QUOTE C150) FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE \SFAscent _ 0 \SFDescent _ 0 \SFHeight _ 0 ROTATION _ ROTATION FONTDEVICESPEC _(LIST FAMILY SIZE FACE ROTATION (QUOTE C150] (if (\GETCHARSETINFO CHARSET FONTDESC T) then (RETURN FONTDESC) else (RETURN NIL]) (\READC150FONTFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj "26-Sep-85 21:49") (DECLARE (GLOBALVARS C150FONTEXTENSIONS C150FONTDIRECTORIES)) (bind FONTFILE CSINFO STRM for EXT inside C150FONTEXTENSIONS when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET) T C150FONTDIRECTORIES)) do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT))) (RESETLST (SETQ CSINFO (\READACFONTFILE STRM FAMILY SIZE FACE))) (* If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.) (RETURN CSINFO]) (\DRAWCIRCLE.C150 [LAMBDA (C150STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* gbn " 9-Jan-86 13:36") (* \DRAWCIRCLE.C150 extended for color. Color is specified by either BRUSH or the DSPCOLOR of DS.) (* * how is a litatom passed in as brush?) (DECLARE (LOCALVARS . T)) (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) ((EQ RADIUS 0) (* don't draw anything.) NIL) (T (GLOBALRESOURCE \BRUSHBBT (PROG ((BRUSH (create BRUSH using BRUSH BRUSHCOLOR _(\C150.ASSURE.COLOR (fetch BRUSHCOLOR of BRUSH) C150STREAM))) (X 0) (Y RADIUS) (D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 CX CY (BBT \BRUSHBBT) COLOR COLORBRUSHBASE NBITS (DISPLAYDATA (fetch IMAGEDATA of C150STREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.) (COND (USERFN (* if calling user fn, don't bother with set up and leave points in stream coordinates.) (SETQ CX CENTERX) (SETQ CY CENTERY)) (T (.SETUP.FOR.\BBTCURVEPT.) (SELECTQ NBITS (1 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2)))) (4 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2) 2)))) (8 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3) 2)))) (SHOULDNT)) (* take into account the brush thickness.) (SETQ CY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2))) (* Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points) )) [COND ((EQ RADIUS 1) (* put a single brush down.) (* draw the top and bottom most points.) (COND (USERFN (APPLY* USERFN CX CY C150STREAM)) (T (\CURVEPT CX CY))) (RETURN)) (T (* draw the top and bottom most points.) (COND (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) C150STREAM) (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) C150STREAM)) (T (\CURVEPT CX (IPLUS CY RADIUS)) (\CURVEPT CX (IDIFFERENCE CY RADIUS] LP (* (UNFOLD x 2) is used instead of (ITIMES x 2)) [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (IPLUS D Y) 2) 1) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS D (UNFOLD X 2) 1] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) 3)) (SETQ Y (SUB1 Y] (COND [(EQ Y 0) (* left most and right most points are drawn specially so that they are not duplicated which leaves a hole in XOR mode.) (COND (USERFN (APPLY* USERFN (IPLUS CX X) CY C150STREAM) (APPLY* USERFN (IDIFFERENCE CX X) CY C150STREAM)) (T (\CURVEPT (IPLUS CX X) CY) (\CURVEPT (IDIFFERENCE CX X) CY] (T (COND (USERFN (APPLY* USERFN (IPLUS CX X) (IPLUS CY Y) C150STREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IPLUS CY Y) C150STREAM) (APPLY* USERFN (IPLUS CX X) (IDIFFERENCE CY Y) C150STREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IDIFFERENCE CY Y) C150STREAM)) (T (\CIRCLEPTS CX CY X Y))) (GO LP))) (MOVETO CENTERX CENTERY C150STREAM) (RETURN NIL]) (\DRAWCURVE.C150 [LAMBDA (C150STREAM KNOTS CLOSED BRUSH DASHING) (* gbn "12-Jan-86 15:03") (* draws a spline curve with a given brush.) (GLOBALRESOURCE \BRUSHBBT (PROG ([DASHLST (AND DASHING (OR (AND (LISTP DASHING) (EVERY DASHING (FUNCTION FIXP)) DASHING) (\ILLEGAL.ARG DASHING] (BBT \BRUSHBBT) (CBRUSH (CREATE BRUSH USING BRUSH BRUSHCOLOR _( \C150.ASSURE.COLOR (FETCH BRUSHCOLOR OF BRUSH) C150STREAM))) LKNOT) (SELECTQ (LENGTH KNOTS) (0 (* No knots => empty curve rather than error?) NIL) (1 (* only one knot, put down a brush shape) (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (DRAWPOINT (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) BRUSH C150STREAM)) (2 (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (OR (type? POSITION (CADR KNOTS)) (ERROR "bad knot" (CADR KNOTS))) (\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) (fetch XCOORD of (CADR KNOTS)) (fetch YCOORD of (CADR KNOTS)) BRUSH DASHLST C150STREAM BBT)) (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED) CBRUSH DASHLST BBT C150STREAM)) (RETURN C150STREAM]) (\DRAWELLIPSE.C150 [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* hdj " 6-Jun-85 16:17") (DECLARE (LOCALVARS . T)) (* Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical. Orientation is positive in the counterclockwise direction. The current location in the stream is left at the center of the ellipse.) (PROG ((CENTERX (FIXR CENTERX)) (CENTERY (FIXR CENTERY)) (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS)) (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS))) (COND ((OR (EQ 0 SEMIMINORRADIUS) (EQ 0 SEMIMAJORRADIUS)) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN))) (COND ((ILESSP SEMIMINORRADIUS 1) (\ILLEGAL.ARG SEMIMINORRADIUS)) ((ILESSP SEMIMAJORRADIUS 1) (\ILLEGAL.ARG SEMIMAJORRADIUS)) ((OR (NULL ORIENTATION) (EQ SEMIMINORRADIUS SEMIMAJORRADIUS)) (SETQ ORIENTATION 0)) ((NULL (NUMBERP ORIENTATION)) (\ILLEGAL.ARG ORIENTATION))) (* This function is the implementation of the algorithm given in "Algorithm for drawing ellipses or hyperbolae with a digital plotter" by Pitteway appearing in Computer Journal 10: (3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse. This ellipse passes through the mesh point (0,0), the initial point of the algorithm. The power of 2 factors reflect an implementation convenience.) (GLOBALRESOURCE \BRUSHBBT (PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1 (BBT \BRUSHBBT) (cosOrientation (COS ORIENTATION)) (sinOrientation (SIN ORIENTATION)) (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS)) (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS)) (x 0) (y 0) (x2 1) x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset CYMinusOffset NBITSRIGHTPLUS1 COLORBRUSHBASE COLOR NBITS (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.) (COND (USERFN (* if calling user fn, don't bother with set up and leave points in window coordinates.) (SETQ CX CENTERX) (SETQ CY CENTERY)) (T (.SETUP.FOR.\BBTCURVEPT.) (* take into account the brush thickness.) (SELECTQ NBITS (1 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2)))) (4 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2) 2)))) (8 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3) 2)))) (SHOULDNT)) (SETQ CY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2))) (* Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points) )) (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation cosOrientation) (FTIMES SEMIMINORRADIUSSQUARED sinOrientation sinOrientation))) (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED cosOrientation cosOrientation) (FTIMES SEMIMAJORRADIUSSQUARED sinOrientation sinOrientation))) 3)) (SETQ G (FTIMES cosOrientation sinOrientation (LSH (IDIFFERENCE SEMIMINORRADIUSSQUARED SEMIMAJORRADIUSSQUARED ) 1))) [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS) (SQRT A] (SETQ CYPlusOffset (IPLUS CY yOffset)) (SETQ CYMinusOffset (IDIFFERENCE CY yOffset)) (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1))) 2)) (SETQ V (LSH (FIXR (FTIMES G yOffset)) 2)) (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED SEMIMAJORRADIUSSQUARED) (FTIMES A (ITIMES yOffset yOffset] 2)) (SETQ A (LSH (FIXR A) 3)) (SETQ G (LSH (FIXR G) 2)) (* The algorithm is incremental and iterates through the octants of a cartesian plane. The octants are labeled from 1 through 8 beginning above the positive X axis and proceeding counterclockwise. Decisions in making the incremental steps are determined according to the error term d which is updated according to the curvature terms a and b. k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries. The initial values of these terms depends on the octant in which drawing begins. The initial move steps (x1,y1) and (x2,y2) also depend on the starting octant.) [COND [(ILESSP (ABS U) (ABS V)) (SETQ x1 0) (COND [(MINUSP V) (* start in octant 2) (SETQ y1 1) (SETQ y2 1) (SETQ k1 (IMINUS A)) (SETQ k2 (IDIFFERENCE k1 G)) (SETQ k3 (IDIFFERENCE k2 (IPLUS B G))) (SETQ b (IPLUS U (RSH (IPLUS A G) 1))) (SETQ a (IMINUS (IPLUS b V))) (SETQ d (IPLUS b (RSH B 3) (RSH V 1) (IMINUS K] (T (* start in octant 7) (SETQ y1 -1) (SETQ y2 -1) (SETQ k1 A) (SETQ k2 (IDIFFERENCE k1 G)) (SETQ k3 (IPLUS k2 B (IMINUS G))) (SETQ b (IPLUS U (RSH (IDIFFERENCE G A) 1))) (SETQ a (IDIFFERENCE V b)) (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1) (RSH B 3] (T (SETQ x1 1) (SETQ y1 0) (COND [(MINUSP V) (* start in octant 1) (SETQ y2 1) (SETQ k1 B) (SETQ k2 (IPLUS k1 G)) (SETQ k3 (IPLUS k2 A G)) [SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G) 1] (SETQ a (IDIFFERENCE U b)) (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3) (RSH U 1] (T (* start in octant 8) (SETQ y2 -1) (SETQ k1 (IMINUS B)) (SETQ k2 (IPLUS k1 G)) (SETQ k3 (IPLUS k2 G (IMINUS A))) (SETQ b (IPLUS V (RSH (IDIFFERENCE B G) 1))) (SETQ a (IDIFFERENCE U b)) (SETQ d (IPLUS b (RSH A 3) (IMINUS (IPLUS K (RSH U 1] (* The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that it will pass through (0,0)%. Thus, the intended starting point is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse. Drawing is accomplished with point relative steps. In each octant, the error term d is used to choose between move 1 (an axis move) and move 2 (a diagonal move)%.) MOVE [COND ((MINUSP d) (* move 1) (SETQ x (IPLUS x x1)) (SETQ y (IPLUS y y1)) (SETQ b (IDIFFERENCE b k1)) (SETQ a (IPLUS a k2)) (SETQ d (IPLUS b d))) (T (* move 2) (SETQ x (IPLUS x x2)) (SETQ y (IPLUS y y2)) (SETQ b (IDIFFERENCE b k2)) (SETQ a (IPLUS a k3)) (SETQ d (IDIFFERENCE d a] (COND ((MINUSP x) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN NIL))) [COND (USERFN (APPLY* USERFN (IPLUS CX x) (IPLUS CYPlusOffset y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX x) (IDIFFERENCE CYMinusOffset y) DISPLAYSTREAM)) (T (\CURVEPT (IPLUS CX x) (IPLUS CYPlusOffset y)) (\CURVEPT (IDIFFERENCE CX x) (IDIFFERENCE CYMinusOffset y] (AND (MINUSP b) (GO SQUARE)) DIAGONAL (OR (MINUSP a) (GO MOVE)) (* diagonal octant change) (SETQ x1 (IDIFFERENCE x2 x1)) (SETQ y1 (IDIFFERENCE y2 y1)) (SETQ w (IDIFFERENCE (LSH k2 1) k3)) (SETQ k1 (IDIFFERENCE w k1)) (SETQ k2 (IDIFFERENCE k2 k3)) (SETQ k3 (IMINUS k3)) [SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2) 1] [SETQ d (IPLUS b (RSH (IPLUS k3 4) 3) (IMINUS d) (IMINUS (RSH (ADD1 a) 1] (SETQ a (IDIFFERENCE (RSH (ADD1 w) 1) a)) (OR (MINUSP b) (GO MOVE)) SQUARE (* square octant change) [COND ((EQ 0 x1) (SETQ x2 (IMINUS x2))) (T (SETQ y2 (IMINUS y2] (SETQ w (IDIFFERENCE k2 k1)) (SETQ k1 (IMINUS k1)) (SETQ k2 (IPLUS w k1)) (SETQ k3 (IDIFFERENCE (LSH w 2) k3)) (SETQ b (IDIFFERENCE (IMINUS b) w)) (SETQ d (IDIFFERENCE (IDIFFERENCE b a) d)) (SETQ a (IDIFFERENCE (IDIFFERENCE a w) (LSH b 1))) (GO DIAGONAL]) (\DRAWLINE.C150 [LAMBDA (C150STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) (* gbn " 5-Nov-85 13:39") (* C150STREAM is guaranteed to be a C150STREAM Draws a line from x1,y1 to x2,y2 leaving the position at x2,y2) (PROG ((DD (fetch IMAGEDATA of C150STREAM))) (\CLIPANDDRAWLINE (OR (FIXP X1) (FIXR X1)) (OR (FIXP Y1) (FIXR Y1)) (OR (FIXP X2) (FIXR X2)) (OR (FIXP Y2) (FIXR Y2)) [COND ((NULL WIDTH) 1) ((OR (FIXP WIDTH) (FIXR WIDTH] (SELECTQ OPERATION (NIL (ffetch DDOPERATION of DD)) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION)) (ffetch DDDestination of DD) (ffetch DDClippingLeft of DD) (SUB1 (ffetch DDClippingRight of DD)) (ffetch DDClippingBottom of DD) (SUB1 (ffetch DDClippingTop of DD)) C150STREAM (\C150.ASSURE.COLOR COLOR C150STREAM))) (* the generic case of MOVETO is used so that the hardcopy streams get handled as well.) (MOVETO X2 Y2 C150STREAM]) (\DSPBACKCOLOR.C150 [LAMBDA (STREAM COLOR) (* rmk: "12-Sep-84 09:54") (* sets and returns a display stream's background color.) (PROG (COLORCELL (DD (\GETDISPLAYDATA STREAM))) (SETQ COLORCELL (fetch DDCOLOR of DD)) (RETURN (COND (COLOR (OR (\POSSIBLECOLOR COLOR) (\ILLEGAL.ARG COLOR)) (PROG1 (COND (COLORCELL (PROG1 (CDR COLORCELL) (RPLACD COLORCELL COLOR))) (T (* no color cell yet, make one.) (replace DDCOLOR of DD with (CONS WHITECOLOR COLOR)) BLACKCOLOR)) (\SFFixFont STREAM DD))) (T (OR (CDR COLORCELL) BLACKCOLOR]) (\DSPCLIPPINGREGION.C150 [LAMBDA (C150STREAM REGION) (* hdj " 5-Jun-85 12:56") (* sets the clipping region of a display stream.) (PROG ((DD (\GETDISPLAYDATA C150STREAM))) (RETURN (PROG1 (ffetch DDClippingRegion of DD) (COND (REGION (OR (type? REGION REGION) (ERROR REGION " is not a REGION.")) (UNINTERRUPTABLY (freplace DDClippingRegion of DD with REGION) (\SFFixClippingRegion DD) (\SFFixY DD))]) (\DSPCOLOR.C150 [LAMBDA (STREAM COLOR) (* gbn "13-Jan-86 12:08") (* sets and returns a display stream's foreground color.) (LET (CURRENTCOLOR NEWCOLOR (DD (\GETDISPLAYDATA STREAM))) (SETQ CURRENTCOLOR (fetch DDCOLOR of DD)) (COND (COLOR (SETQ NEWCOLOR (\C150.ASSURE.COLOR COLOR STREAM)) (PROG1 (COND (CURRENTCOLOR (PROG1 (CAR CURRENTCOLOR) (RPLACA CURRENTCOLOR NEWCOLOR))) (T (* no color cell yet, make one.) (replace DDCOLOR of DD with (CONS NEWCOLOR BLACKCOLOR)) WHITECOLOR)) (\SFFixFont STREAM DD))) (T (OR (CAR CURRENTCOLOR) WHITECOLOR]) (\C150.ASSURE.COLOR [LAMBDA (COLOR# C150STREAM) (* gbn " 7-Jan-86 17:44") (PROG (LEVELS) (AND (COND ((NULL COLOR) (RETURN (DSPCOLOR NIL C150STREAM))) [(FIXP COLOR#) (RETURN (COND ((AND (IGEQ COLOR# 0) (ILESSP COLOR# 8) COLOR#)) (T (\ILLEGAL.ARG COLOR#] [(LITATOM COLOR#) (RETURN (COND ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#)) (* recursively look up color number) (\C150.ASSURE.COLOR (CDR LEVELS) C150STREAM)) (T (ERROR "Unknown color name" COLOR#] ((EQ (LENGTH COLOR#) 2) (* temporarily, handle the case of being given a texture and a color, by using the color) (RETURN (\C150.ASSURE.COLOR (CADR COLOR#) C150STREAM))) ((HLSP COLOR#) (* HLS form convert to RGB) (SETQ LEVELS (HLSTORGB COLOR#))) ((RGBP COLOR#) (* check for RGB or HLS) (SETQ LEVELS COLOR#)) ((TYPENAMEP COLOR# (QUOTE BITMAP)) (* just a hack to not blow up) (RETURN (IMOD (for I from 1 to (BITMAPWIDTH COLOR#) sum (BITMAPBIT COLOR# I 1)) 8))) (T (\ILLEGAL.ARG COLOR#))) (RETURN (COND ((\C150.LOOKUPRGB LEVELS C150STREAM)) (T (ERROR COLOR# "not available in color map"]) (\C150.LOOKUPRGB [LAMBDA (RGB C150STREAM) (* gbn " 5-Nov-85 15:47") (* * returns the colormap index whose value is RGB. Looks first in the cache, then runs through the colormap. Returns NIL if RGB NOT found) (DECLARE (GLOBALVARS C150COLORMAP)) (PROG [INDEX (CACHE (STREAMPROP C150STREAM (QUOTE COLORMAPCACHE] (RETURN (if (SETQ INDEX (SASSOC RGB CACHE)) then (CDR INDEX) else [SETQ INDEX (bind (CM _ C150COLORMAP) for I from 0 to (SUB1 (EXPT 2 3)) thereis (AND (EQ (\GENERIC.COLORLEVEL CM I (QUOTE RED)) (fetch (RGB RED) of LEVELS)) (EQ (\GENERIC.COLORLEVEL CM I (QUOTE GREEN)) (fetch (RGB GREEN) of LEVELS)) (EQ (\GENERIC.COLORLEVEL CM I (QUOTE BLUE)) (fetch (RGB BLUE) of LEVELS] (if INDEX then (PUTASSOC RGB INDEX CACHE)) INDEX]) (\DSPFONT.C150 [LAMBDA (C150STREAM FONT) (* hdj " 4-Oct-85 11:55") (* sets the font that a display stream uses to print characters. C150STREAM is guaranteed to be a stream of type C150) (PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of C150STREAM))) (* save old value to return, smash new value and update the bitchar portion of the record.) (RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD)) (COND (FONT (SETQ XFONT (OR (\GETFONTDESC FONT (QUOTE C150) T) (FONTCOPY (ffetch DDFONT of DD) FONT))) (* color case, create a font with the current foreground and background colors.) (* (SETQ XFONT (\GETCOLORFONT XFONT (DSPCOLOR NIL C150STREAM) (DSPBACKCOLOR NIL C150STREAM) (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA DDDestination) of DD))))) (* updating font information is fairly expensive operation. Don't bother unless font has changed.) (OR (EQ XFONT OLDFONT) (UNINTERRUPTABLY (freplace DDFONT of DD with XFONT) (freplace DDLINEFEED of DD with (IMINUS (fetch \SFHeight of XFONT))) (\SFFixFont C150STREAM DD))]) (\DSPLEFTMARGIN.C150 [LAMBDA (C150STREAM XPOSITION) (* hdj " 5-Jun-85 12:56") (* sets the xposition that a carriage return returns to.) (PROG ((DD (fetch IMAGEDATA of C150STREAM))) (RETURN (PROG1 (ffetch DDLeftMargin of DD) (AND XPOSITION (COND ((AND (SMALLP XPOSITION) (IGREATERP XPOSITION -1)) (UNINTERRUPTABLY (freplace DDLeftMargin of DD with XPOSITION) (\SFFIXLINELENGTH C150STREAM))) (T (\ILLEGAL.ARG XPOSITION]) (\DSPLINEFEED.C150 [LAMBDA (C150STREAM DELTAY) (* hdj " 5-Jun-85 12:56") (* sets the amount that a line feed increases the y coordinate by.) (PROG ((DD (fetch IMAGEDATA of C150STREAM))) (RETURN (PROG1 (ffetch DDLINEFEED of DD) (AND DELTAY (COND ((NUMBERP DELTAY) (freplace DDLINEFEED of DD with DELTAY)) (T (\ILLEGAL.ARG DELTAY]) (\DSPOPERATION.C150 [LAMBDA (C150STREAM OPERATION) (* hdj " 5-Jun-85 12:56") (* sets the operation field of a display stream) (PROG ((DD (\GETDISPLAYDATA C150STREAM))) (RETURN (PROG1 (fetch DDOPERATION of DD) (COND (OPERATION (OR (FMEMB OPERATION (QUOTE (PAINT REPLACE INVERT ERASE))) (LISPERROR "ILLEGAL ARG" OPERATION)) (UNINTERRUPTABLY (freplace DDOPERATION of DD with OPERATION) (* update other fields that depend on operation.) (\SETPBTFUNCTION (fetch DDPILOTBBT of DD) (fetch DDSOURCETYPE of DD) OPERATION))]) (\DSPPRINTCHAR.C150 [LAMBDA (STREAM CHARCODE) (* hdj " 5-Jun-85 12:56") (* Displays the character and increments the Xposition. STREAM is guaranteed to be of type display.) (PROG ((DD (fetch IMAGEDATA of STREAM))) (SELCHARQ CHARCODE ((EOL CR LF) (\DSPPRINTCR/LF.C150 CHARCODE STREAM) (replace CHARPOSITION of STREAM with 0)) (LF (\DSPPRINTCR/LF.C150 CHARCODE STREAM)) (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM))) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) (if (IGREATERP (\DISPLAYSTREAMINCRXPOSITION (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (MOD (IDIFFERENCE (fetch DDXPOSITION of DD) (ffetch DDLeftMargin of DD)) TABWIDTH))) DD) (ffetch DDRightMargin of DD)) then (* tab was past rightmargin, force cr.) (\DSPPRINTCR/LF.C150 (CHARCODE EOL) STREAM)) (* return the number of spaces taken.) (add (fetch CHARPOSITION of STREAM) (IQUOTIENT TABWIDTH SPACEWIDTH)))) (add (fetch CHARPOSITION of STREAM) (IPLUS (if (ILESSP CHARCODE 32) then (* CONTROL character) (\BLTCHAR.C150 CHARCODE STREAM DD) 0 else (\BLTCHAR.C150 CHARCODE STREAM DD) 1]) (\DSPPRINTCR/LF.C150 [LAMBDA (CHARCODE DS) (* hdj " 6-Jun-85 14:08") (* CHARCODE is EOL, CR, or LF Assumes that DS has been checked by \DSPPRINTCHAR) (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch IMAGEDATA of DS))) (COND ((AND (fetch DDSlowPrintingCase of DD) (NEQ (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD))) 0)) (PROG ((CLIPREG (ffetch DDClippingRegion of DD)) X) [COND ((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in X) (COND ((SETQ Y (fetch DDEOLFN of DD)) (* call the eol function for ds.) (APPLY* Y DS))) (\DSPYPOSITION.C150 DS (SELECTQ ROTATION (90 (fetch (REGION BOTTOM) of CLIPREG)) (270 (fetch (REGION TOP) of CLIPREG)) (ERROR "Only rotations supported are 0, 90 and 270" ] [SETQ X (IPLUS (fetch DDXPOSITION of DD) (SELECTQ ROTATION (90 (IMINUS (ffetch DDLINEFEED of DD))) (270 (ffetch DDLINEFEED of DD)) (ERROR "Only rotations supported are 0, 90 and 270"] (DSPXPOSITION X DS))) (T (COND ((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in X) (COND ((SETQ Y (fetch DDEOLFN of DD)) (* call the eol function for ds.) (APPLY* Y DS))) (DSPXPOSITION (ffetch DDLeftMargin of DD) DS))) (SETQ Y (IPLUS (ffetch DDYPOSITION of DD) (ffetch DDLINEFEED of DD))) (DSPYPOSITION Y DS]) (\DSPRESET.C150 [LAMBDA (C150STREAM) (* hdj " 5-Aug-85 18:57") (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* resets a display stream) (PROG (CREG FONT FONTASCENT (DD (\GETDISPLAYDATA C150STREAM))) (SETQ CREG (ffetch DDClippingRegion of DD)) (SETQ FONT (fetch DDFONT of DD)) (SETQ FONTASCENT (FONTASCENT FONT)) (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT) (0 (\DSPXPOSITION.C150 C150STREAM (ffetch DDLeftMargin of DD)) (\DSPYPOSITION.C150 C150STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG) FONTASCENT)))) (90 (\DSPXPOSITION.C150 C150STREAM (IPLUS (fetch LEFT of CREG) FONTASCENT)) (\DSPYPOSITION.C150 C150STREAM (fetch BOTTOM of CREG))) (270 (\DSPXPOSITION.C150 C150STREAM (IDIFFERENCE (fetch RIGHT of CREG) FONTASCENT)) (\DSPYPOSITION.C150 C150STREAM (fetch TOP of CREG))) (ERROR "only supported rotations are 0, 90 and 270")) (\CLEARBM (ffetch (\DISPLAYDATA DDDestination) of DD) (DSPBACKCOLOR NIL C150STREAM) CREG]) (\DSPRIGHTMARGIN.C150 [LAMBDA (C150STREAM XPOSITION) (* hdj " 5-Jun-85 12:56") (* Sets the right margin that determines when a cr is inserted by print.) (PROG (OLDRM (DD (fetch IMAGEDATA of C150STREAM))) (SETQ OLDRM (ffetch DDRightMargin of DD)) (COND ((NULL XPOSITION)) [(AND (SMALLP XPOSITION) (IGREATERP XPOSITION -1)) (* Avoid fixing linelength if right margin hasn't changed.) (OR (EQ XPOSITION OLDRM) (UNINTERRUPTABLY (freplace DDRightMargin of DD with XPOSITION) (\SFFIXLINELENGTH C150STREAM))] (T (\ILLEGAL.ARG XPOSITION))) (RETURN OLDRM]) (\DSPXPOSITION.C150 [LAMBDA (C150STREAM XPOSITION) (* hdj " 5-Jun-85 12:56") (* coordinate position is stored in 15 bits in the range -2^15 to +2^15.) (PROG ((DD (fetch IMAGEDATA of C150STREAM))) (RETURN (PROG1 (fetch DDXPOSITION of DD) (COND ((NULL XPOSITION)) ((NUMBERP XPOSITION) (freplace DDXPOSITION of DD with XPOSITION) (* reset the charposition field so that PRINT etc. won't put out eols.) (freplace (STREAM CHARPOSITION) of C150STREAM with 0)) (T (\ILLEGAL.ARG XPOSITION]) (\DSPYPOSITION.C150 [LAMBDA (DISPLAYSTREAM YPOSITION) (* hdj " 3-Oct-85 17:57") (LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) (PROG1 (ffetch DDYPOSITION of DD) (COND ((NULL YPOSITION)) ((NUMBERP YPOSITION) (UNINTERRUPTABLY (freplace DDYPOSITION of DD with YPOSITION) (\INVALIDATEDISPLAYCACHE DD))) (T (\ILLEGAL.ARG YPOSITION]) (\DUMPPAGEBUFFER.C150 [LAMBDA (BITMAP C150STREAM COLOR.TABLES) (* gbn "13-Jan-86 21:37") (CENTRONICS.RESET C150STREAM) (LET*[(BACKINGSTREAM (\C150BackingStream C150STREAM)) (MAXX (SUB1 (BITMAPWIDTH BITMAP))) (MAXY (SUB1 (BITMAPHEIGHT BITMAP))) (LINEBYTES (FOLDHI (BITMAPWIDTH BITMAP) BITSPERBYTE)) (PrintingTimeInSeconds 1) (PrintingTimer (SETUPTIMER PrintingTimeInSeconds NIL (QUOTE SECONDS] (C150.SETMARGINS BACKINGSTREAM) (C150.SEPARATOR BACKINGSTREAM) (bind (BLANKLINES _ 0) (FIRSTLINE _ T) for SCANLINE from MAXY to 0 by -4 do (if (\C150.ALLWHITESPACE BITMAP COLOR.TABLES SCANLINE) then (add BLANKLINES 1) (BLOCK) else (* * First dump the buffered microlinefeeds) (if (AND FIRSTLINE C150.CLIPBUFFER) then (* don't bother printing these microlinefeeds, since they are just the blanks at the top of the buffer) (SETQ FIRSTLINE NIL) else (for I to BLANKLINES do (\C150.MICROLINEFEED BACKINGSTREAM))) (SETQ BLANKLINES 0) [for SUBSCAN from 0 to 3 do (if (TIMEREXPIRED? PrintingTimer (QUOTE SECONDS)) then (BLOCK) (SETUPTIMER PrintingTimeInSeconds PrintingTimer (QUOTE SECONDS))) (for COLOR from 0 to 3 do (* loop over (black magenta yellow cyan)) (LET [(COLOR.ARRAY.BASE (fetch (ARRAYP BASE) of (ELT COLOR.TABLES COLOR] (\C150.SENDLINEINFO BACKINGSTREAM COLOR LINEBYTES SUBSCAN) (for XPOSITION from 0 to MAXX by 8 do (BOUT BACKINGSTREAM (for BIT from 0 to 7 sum (LLSH (\GETBASE COLOR.ARRAY.BASE (BITMAPBIT BITMAP (IPLUS XPOSITION BIT) (IDIFFERENCE SCANLINE SUBSCAN))) (IDIFFERENCE 7 BIT] (\C150.MICROLINEFEED BACKINGSTREAM)) finally (if (NOT C150.CLIPBUFFER) then (* print out the remaining microlinefeeds) (for I from 1 to BLANKLINES do (\C150.MICROLINEFEED BACKINGSTREAM]) (\FILLCIRCLE.C150 [LAMBDA (C150STREAM CENTERX CENTERY RADIUS TEXTURE) (* hdj " 6-Jun-85 16:17") (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) (T (GLOBALRESOURCE \BRUSHBBT (PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap (DISPLAYDATA (fetch IMAGEDATA of C150STREAM)) (X 0) (Y RADIUS) (D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE NBITS (FCBBT \BRUSHBBT)) (SETQ TOP (SUB1 (fetch DDClippingTop of DISPLAYDATA))) (SETQ BOTTOM (fetch DDClippingBottom of DISPLAYDATA)) (SETQ LEFT (fetch DDClippingLeft of DISPLAYDATA)) (SETQ RIGHT (SUB1 (fetch DDClippingRight of DISPLAYDATA))) (SETQ OPERATION (ffetch DDOPERATION of DISPLAYDATA)) (SETQ DestinationBitMap (fetch DDDestination of DISPLAYDATA)) (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) [SETQ TEXTUREBM (COND ((BITMAPP TEXTURE)) [(AND (NEQ NBITS 1) (BITMAPP (COLORTEXTUREFROMCOLOR# (COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL C150STREAM ] [(AND (NULL TEXTURE) (BITMAPP (ffetch DDTexture of DISPLAYDATA] ([OR (FIXP TEXTURE) (AND (NULL TEXTURE) (SETQ TEXTURE (ffetch DDTexture of DISPLAYDATA] (* create bitmap for the texture. Could reuse a bitmap but for now this is good enough.) (SETQ TEXTUREBM (BITMAPCREATE 16 4)) (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 12) 15))) (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8 ) 15))) (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4 ) 15))) (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15))) TEXTUREBM) (T (\ILLEGAL.ARG TEXTURE] (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) (SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap)) (SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap)) (* update as many fields in the brush bitblt table as possible from DS.) (replace PBTFLAGS of FCBBT with 0) (replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD)) (* clear gray information. PBTSOURCEBPL is used for gray information too.) (replace PBTSOURCEBPL of FCBBT with 0) (replace PBTUSEGRAY of FCBBT with T) [replace PBTGRAYWIDTHLESSONE of FCBBT with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) of TEXTUREBM) 16] [replace PBTGRAYHEIGHTLESSONE of FCBBT with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) of TEXTUREBM ) 16] (replace PBTDISJOINT of FCBBT with T) (\SETPBTFUNCTION FCBBT (QUOTE TEXTURE) OPERATION) (replace PBTHEIGHT of FCBBT with 1) (* take into account the brush thickness.) (SETQ CX CENTERX) (SETQ CY CENTERY) (* change Y TOP and BOTTOM to be in bitmap coordinates) (SETQ CY (\SFInvert DestinationBitMap CY)) [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOP)) (SETQ TOP (SUB1 (\SFInvert DestinationBitMap BOTTOM] (COND ((EQ RADIUS 0) (* put a single point down. Use \LINEBLT to get proper texture. NIL) (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS) (RETURN))) LP (* (UNFOLD x 2) is used instead of (ITIMES x 2)) [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (IPLUS D Y) 2) 1) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4))) (T (SETQ D (IPLUS D (UNFOLD X 2) 1)) (* don't draw unless Y changes.) (GO LP] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4))) (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) 3] (COND ((EQ Y 0) (* draw the middle line differently to avoid duplication.) (\LINEBLT FCBBT (IDIFFERENCE CX X) CY (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)) (T (\FILLCIRCLEBLT CX CY X Y) (SETQ Y (SUB1 Y)) (GO LP))) (MOVETO CENTERX CENTERY C150STREAM) (RETURN NIL]) (\OUTCHARFN.C150 [LAMBDA (C150STREAM CHARCODE) (* hdj "10-Jun-85 15:14") (SELCHARQ CHARCODE (EOL (* New Line) (NEWLINE.C150 C150STREAM) (replace (STREAM CHARPOSITION) of C150STREAM with 0)) (LF (* Line feed--move down, but not over) (\DSPXPOSITION.C150 C150STREAM (PROG1 (\DSPXPOSITION.C150 C150STREAM) (NEWLINE.C150 C150STREAM)))) (^L (* Form Feed) (replace (STREAM CHARPOSITION) of C150STREAM with 0) (NEWPAGE.C150 C150STREAM)) (\BOUT C150STREAM CHARCODE]) (\SEARCHC150FONTFILES [LAMBDA (FAMILY SIZE FACE ROTATION) (* hdj " 5-Jun-85 14:19") (* * returns a list of the fonts that can be read in for the C150 device. Rotation is ignored because it is assumed that all devices support 0 90 and 270) (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES)) (SELECTQ (SYSTEMTYPE) (D (for E FILENAMEPATTERN FONTSFOUND THISFONT inside DISPLAYFONTEXTENSIONS do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E)) [for DIR inside DISPLAYFONTDIRECTORIES do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY) DIR (QUOTE BODY) FILENAMEPATTERN)) do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE (QUOTE DISPLAY ))) FONTSFOUND) (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] finally (RETURN FONTSFOUND))) (SHOULDNT]) (\STRINGWIDTH.C150 [LAMBDA (C150STREAM STR RDTBL) (* hdj " 5-Jun-85 12:56") (* Returns the width of for the current font/spacefactor in STREAM.) (PROG (WIDTHSBASE) (RETURN (\STRINGWIDTH.GENERIC STR (SETQ WIDTHSBASE (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (ffetch IMAGEDATA of C150STREAM))) RDTBL (\FGETWIDTH WIDTHSBASE (CHARCODE SPACE]) ) (RPAQQ MISSINGC150FONTCOERCIONS (((GACHA) (MODERN)) ((TIMESROMAN) (MODERN)) ((HELVETICA) (MODERN)))) (RPAQQ \C150COLORTABLE NIL) (RPAQQ \C150.FRAMEBUFFER NIL) (RPAQQ \C150STREAM NIL) (RPAQ C150COLORMAP (READARRAY 16 (QUOTE POINTER) 0)) ((0 0 0) (0 0 255) (0 255 0) (255 0 0) (255 255 0) (255 0 255) (0 255 255) (255 255 255) (0 0 0) (0 0 255) (0 255 0) (255 0 0) (255 255 0) (255 0 255) (0 255 255) (255 255 255) NIL ) (RPAQQ C150FONTCOERCIONS (((CLASSIC 8) (CLASSIC 10)) ((MODERN 8) (MODERN 10)) ((MODERN 24) (MODERN 18)) ((MODERN 18) (CLASSIC 18)) ((CLASSIC 24) (CLASSIC 18)) ((CLASSIC 12) (CLASSIC 14)))) (RPAQQ C150FONTDIRECTORIES ({ERIS}LIBRARY>)) (RPAQQ C150FONTEXTENSIONS (C150FONT)) (RPAQ? C150.CLIPBUFFER T) (RPAQ? \C150DEFAULTDEVICE (QUOTE CENTRONICS)) (DEFINEQ (COLORMAP.TO.C150TABLE [LAMBDA (COLORMAP) (* hdj " 3-Aug-85 21:36") (LET*((SIZE (ARRAYSIZE COLORMAP)) (TABLETABLE (ARRAY 4 (QUOTE POINTER) NIL 0)) (BLACKTABLE (ARRAY SIZE (QUOTE SMALLP) 0 0)) (CYANTABLE (ARRAY SIZE (QUOTE SMALLP) 0 0)) (MAGENTATABLE (ARRAY SIZE (QUOTE SMALLP) 0 0)) (YELLOWTABLE (ARRAY SIZE (QUOTE SMALLP) 0 0))) (bind CYAN MAGENTA YELLOW for PIXELVAL from 0 to (SUB1 SIZE) do [SETQ CYAN (SETA CYANTABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB RED) of (COLORMAPENTRY COLORMAP PIXELVAL)) 128] [SETQ MAGENTA (SETA MAGENTATABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB GREEN) of (COLORMAPENTRY COLORMAP PIXELVAL)) 128] [SETQ YELLOW (SETA YELLOWTABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB BLUE) of (COLORMAPENTRY COLORMAP PIXELVAL )) 128] (if (AND (EQ CYAN 1) (EQ MAGENTA 1) (EQ YELLOW 1)) then (SETA CYANTABLE PIXELVAL 0) (SETA MAGENTATABLE PIXELVAL 0) (SETA YELLOWTABLE PIXELVAL 0) (SETA BLACKTABLE PIXELVAL 1))) (SETA TABLETABLE 0 BLACKTABLE) (SETA TABLETABLE 1 MAGENTATABLE) (SETA TABLETABLE 2 YELLOWTABLE) (SETA TABLETABLE 3 CYANTABLE) TABLETABLE]) ) (FILESLOAD COLOR XXGEOM XXFILL) (IF (NOT (GETD (QUOTE POLYSHADE.BLT))) THEN (* A fix for KOTO, which is not necessary in n>) (MOVD (QUOTE POLYSHADE.DISPLAY) (QUOTE POLYSHADE.BLT))) (DECLARE: DONTEVAL@LOAD DOCOPY (\C150INIT) (FILESLOAD CENTRONICS) ) (DECLARE: EVAL@LOAD DONTCOPY (FILESLOAD (LOADFROM) ADISPLAY LLDISPLAY) ) (DECLARE: EVAL@COMPILE (DEFMACRO \C150BackingStream (C150STREAM) (BQUOTE (fetch (STREAM F1) of , C150STREAM))) ) (PUTPROPS C150STREAM COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (2416 20778 (C150.SEPARATOR 2426 . 2839) (C150.SETMARGINS 2841 . 4574) ( \C150.ALLWHITESPACE 4576 . 6320) (\C150.BUFFER.DOT 6322 . 6553) (\C150.MICROLINEFEED 6555 . 6835) ( \C150.SENDLINE 6837 . 7856) (\C150.SENDLINEINFO 7858 . 8357) (\C150INIT 8359 . 12525) ( \CREATECHARSET.C150 12527 . 20776)) (20779 135286 (CREATEC150BUFFER 20789 . 21931) (NEWLINE.C150 21933 . 22878) (NEWPAGE.C150 22880 . 23386) (OPENC150STREAM 23388 . 26698) (C150.RESET 26700 . 27074) ( SEND.TO.C150 27076 . 27516) (STARTPAGE.C150 27518 . 28241) (\BITBLT.C150 28243 . 39228) (\BLTCHAR.C150 39230 . 46739) (\BLTSHADE.C150 46741 . 54213) (\C150.CRLF 54215 . 54665) (\CHANGECHARSET.C150 54667 . 58079) (\CHARWIDTH.C150 58081 . 58888) (\CLOSEFN.C150 58890 . 59533) (\CREATEC150FONT 59535 . 60463 ) (\READC150FONTFILE 60465 . 61352) (\DRAWCIRCLE.C150 61354 . 70823) (\DRAWCURVE.C150 70825 . 74177) ( \DRAWELLIPSE.C150 74179 . 90084) (\DRAWLINE.C150 90086 . 92331) (\DSPBACKCOLOR.C150 92333 . 93755) ( \DSPCLIPPINGREGION.C150 93757 . 94804) (\DSPCOLOR.C150 94806 . 96147) (\C150.ASSURE.COLOR 96149 . 98725) (\C150.LOOKUPRGB 98727 . 100214) (\DSPFONT.C150 100216 . 103285) (\DSPLEFTMARGIN.C150 103287 . 104410) (\DSPLINEFEED.C150 104412 . 105295) (\DSPOPERATION.C150 105297 . 106757) (\DSPPRINTCHAR.C150 106759 . 109848) (\DSPPRINTCR/LF.C150 109850 . 112967) (\DSPRESET.C150 112969 . 114625) ( \DSPRIGHTMARGIN.C150 114627 . 115995) (\DSPXPOSITION.C150 115997 . 117372) (\DSPYPOSITION.C150 117374 . 118012) (\DUMPPAGEBUFFER.C150 118014 . 121744) (\FILLCIRCLE.C150 121746 . 131735) (\OUTCHARFN.C150 131737 . 132803) (\SEARCHC150FONTFILES 132805 . 134363) (\STRINGWIDTH.C150 134365 . 135284)) (136566 139219 (COLORMAP.TO.C150TABLE 136576 . 139217))))) STOP \ No newline at end of file diff --git a/lispusers/CALENDAR b/lispusers/CALENDAR new file mode 100644 index 00000000..98a5725d --- /dev/null +++ b/lispusers/CALENDAR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Aug-90 09:16:22" {DSK}/lisp/ice/lyric/CALENDAR.;4 175016 changes to%: (FNS DOREMINDER CIRCLETODAY DAYSIN PRINTMONTH SHOWMOON MDMENUITEMREGION SHOWREMSINMONTH WEEKOF CALLOADFILE) (VARS CALENDARCOMS) previous date%: "21-Feb-90 15:20:05" {DSK}/lisp/ice/lyric/CALENDAR.;2) (* " Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CALENDARCOMS) (RPAQQ CALENDARCOMS ((VARS (CALCIRCLEDAY) (CALCIRCLEMONTH) (CALENDARVERSION "Calendar Version 2.1") CALOPTIONSDESC CALOPTIONSDESCLYRIC (LAFITE.AFTER.GETMAIL.FN 'CALPEEKNEWMAIL)) (INITVARS (CALALERTFLG T) (CALCURBROWSER '(NIL)) (CALCURDAY) (CALDAYBROWSERS) (CALDAYDEFAULTREGION '(32 200 362 100)) (CALDAYSTART 900) (CALDEFAULTALERTDELTA 0) (CALDEFAULTHOST&DIR) (CALDIRTYREMLST NIL) (CALFILELST) (CALFLASHTIMES 0) (CALFLASHTYPE 'None) (CALFONT) (CALHARDCOPYPOMFLG T) (CALHASH (HARRAY 200)) (CALHILITETODAY 'CIRCLE) (CALKEEPEXPIREDREMSFLG) (CALMAINMENU) (CALMONLOCK) (CALMONTHDEFAULTREGION '(32 32 500 400)) (CALMONTHICON) (CALMONTHLST) (CALNEEDSUPDATE) (CALREMCREATEREGION '(400 400 400 300)) (CALREMDISPLAYREGION '(200 400 400 300)) (CALREMINDERS) (CALREMSLOADED) (CALTEDITWINDOW) [CALTUNE '((750 . 20000) (650 . 20000] (CALUPDATEONSHRINKFLG 'Never) (CALWATCHMAILFLG 'TEXT) (CALYEARICON) (PBIGFONT) (PCALFONT) (PLITTLEFONT)) (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) TABLEBROWSER)) (FNS CALADDEVENT CALCREATEREM CALDELETEREM CALDISPEVENT CALDOOPTIONS CALENDAR CALENDARWATCHER CALEXTENDSEL CALLOADFILE CALMAKEKEY CALMONTHBEF CALMONTHICONFN CALMONTHRBF CALOPTIONMENU CALPEEKNEWMAIL CALPRINTREM CALREMDEF CALTBCLOSEFN CALTBCOPYFN CALTBNULLFN CALTBSELECTEDFN CALTEDITEXIT CALTEDITSTRING CALUPDATEFILE CALUPDATEINIT CALYEARICONFN CALYEARINRANGE CIRCLETODAY CLEARDAY CLOSEMONTH DAYABBR DAYNAME DAYOF DAYPLUS DAYSIN DERIVENEWDATE DOREMINDER FMNWAYITEM GETREMDEF INVERTGROUP LISPDATEDAY LISPDATEMONTH LISPDATEYEAR MDMENUITEMREGION MENUITEM MENUREGIONITEM MONTHABBR MONTHNAME MONTHNUM MONTHOFDAYPLUS MONTHPLUS MONTHYEARPLUS NEWPARSETIME NEXTMDISPLAYREGION PACKDATE PARSETIME PICKFONTSIZE POM POMDAYS PRINTMONTH REMINDERSOF REMINDERTIME REMINDERTIMELT REMSINMONTH REPAINTMONTH REPAINTYEAR SAMEDAYAS SAMEMONTHAS SCALEBITMAP SHOWDAY SHOWMONTH SHOWMONTHSMALL SHOWMOON SHOWREMSINDAY SHOWREMSINMONTH SHOWYEAR SHRINKMONTH SHRINKYEAR TIMEDREMP TPLUS WEEKOF YNCONVERT) (BITMAPS CALDAYICON CALMONTHICONMAP CALYEARICONMAP FQMAP FMMAP LQMAP NMMAP) (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) FREEMENU TABLEBROWSER))) (RPAQQ CALCIRCLEDAY NIL) (RPAQQ CALCIRCLEMONTH NIL) (RPAQ CALENDARVERSION "Calendar Version 2.1") (RPAQQ CALOPTIONSDESC (((TYPE TITLE LABEL Alert%: FONT (HELVETICA 10 BOLD)) (TYPE NWAY ID CALALERTFLG LABEL Yes MESSAGE "Reminders will alert you when they fire.") (TYPE NWAY ID CALALERTFLG LABEL No MESSAGE "Reminders will not alert you when they fire.")) ((TYPE TITLE LABEL "Keep expired rems.:" FONT (HELVETICA 10 BOLD)) (TYPE NWAY ID CALKEEPEXPIREDREMSFLG LABEL Yes MESSAGE "Expired reminders will not be deleted.") (TYPE NWAY ID CALKEEPEXPIREDREMSFLG LABEL No MESSAGE "Reminders are deleted automatically when they fire.")) ((TYPE TITLE LABEL "Auto. file update:" FONT (HELVETICA 10 BOLD)) (TYPE NWAY ID CALUPDATEONSHRINKFLG LABEL Always MESSAGE "Update after each reminder is created.") (TYPE NWAY ID CALUPDATEONSHRINKFLG LABEL Shrink MESSAGE "Update only when you shrink a month window.") (TYPE NWAY ID CALUPDATEONSHRINKFLG LABEL Never MESSAGE "No automatic updates - use Update in day browser menu.")) ((TYPE EDITSTART LABEL "Alert delta:" ITEMS (CALDEFAULTALERTDELTA) FONT (HELVETICA 10 BOLD) MESSAGE "Default alert time offset in minutes: - for before, + for after.") (TYPE EDIT ID CALDEFAULTALERTDELTA LABEL 0)) ((TYPE EDITSTART LABEL "Host & dir.:" ITEMS (CALDEFAULTHOST&DIR) FONT (HELVETICA 10 BOLD)) (TYPE EDIT ID CALDEFAULTHOST&DIR LABEL "")) ((TYPE MOMENTARY LABEL Apply! FONT (HELVETICA 10 BOLD) SELECTEDFN CALDOOPTIONS MESSAGE "Puts the selected options into effect and closes this window.")) (WINDOWPROPS TITLE "Calendar Options"))) (RPAQQ CALOPTIONSDESCLYRIC ([(GROUP (PROPS ID ALERTGROUP) ((TYPE DISPLAY LABEL "Alert:" FONT (HELVETICA 10 BOLD)) (TYPE NWAY COLLECTION CALALERTFLG LABEL Yes MESSAGE "Reminders will alert you when they fire.") (TYPE NWAY COLLECTION CALALERTFLG LABEL No MESSAGE "Reminders will not alert you when they fire."] [(GROUP (PROPS ID XGROUP) ((TYPE DISPLAY LABEL "Keep expired rems.:" FONT (HELVETICA 10 BOLD)) (TYPE NWAY COLLECTION CALKEEPEXPIREDREMSFLG LABEL Yes MESSAGE "Expired reminders will not be deleted.") (TYPE NWAY COLLECTION CALKEEPEXPIREDREMSFLG LABEL No MESSAGE "Reminders are deleted automatically when they fire."] [(GROUP (PROPS ID UPGROUP) ((TYPE DISPLAY LABEL "Auto. file update:" FONT (HELVETICA 10 BOLD)) (TYPE NWAY COLLECTION CALUPDATEONSHRINKFLG LABEL Always MESSAGE "Update after each reminder is created.") (TYPE NWAY COLLECTION CALUPDATEONSHRINKFLG LABEL Shrink MESSAGE "Update only when you shrink a month window.") (TYPE NWAY COLLECTION CALUPDATEONSHRINKFLG LABEL Never MESSAGE "No automatic updates - use Update in day browser menu." ] ((TYPE EDITSTART LABEL "Alert delta:" ITEMS (CALDEFAULTALERTDELTA) FONT (HELVETICA 10 BOLD) MESSAGE "Default alert time offset in minutes: - for before, + for after." ) (TYPE EDIT ID CALDEFAULTALERTDELTA LABEL 0)) ((TYPE EDITSTART LABEL "Host & dir.:" ITEMS (CALDEFAULTHOST&DIR) FONT (HELVETICA 10 BOLD)) (TYPE EDIT ID CALDEFAULTHOST&DIR LABEL "")) ((TYPE MOMENTARY LABEL Apply! FONT (HELVETICA 10 BOLD) SELECTEDFN CALDOOPTIONS MESSAGE "Puts the selected options into effect and closes this window." )))) (RPAQQ LAFITE.AFTER.GETMAIL.FN CALPEEKNEWMAIL) (RPAQ? CALALERTFLG T) (RPAQ? CALCURBROWSER '(NIL)) (RPAQ? CALCURDAY ) (RPAQ? CALDAYBROWSERS ) (RPAQ? CALDAYDEFAULTREGION '(32 200 362 100)) (RPAQ? CALDAYSTART 900) (RPAQ? CALDEFAULTALERTDELTA 0) (RPAQ? CALDEFAULTHOST&DIR ) (RPAQ? CALDIRTYREMLST NIL) (RPAQ? CALFILELST ) (RPAQ? CALFLASHTIMES 0) (RPAQ? CALFLASHTYPE 'None) (RPAQ? CALFONT ) (RPAQ? CALHARDCOPYPOMFLG T) (RPAQ? CALHASH (HARRAY 200)) (RPAQ? CALHILITETODAY 'CIRCLE) (RPAQ? CALKEEPEXPIREDREMSFLG ) (RPAQ? CALMAINMENU ) (RPAQ? CALMONLOCK ) (RPAQ? CALMONTHDEFAULTREGION '(32 32 500 400)) (RPAQ? CALMONTHICON ) (RPAQ? CALMONTHLST ) (RPAQ? CALNEEDSUPDATE ) (RPAQ? CALREMCREATEREGION '(400 400 400 300)) (RPAQ? CALREMDISPLAYREGION '(200 400 400 300)) (RPAQ? CALREMINDERS ) (RPAQ? CALREMSLOADED ) (RPAQ? CALTEDITWINDOW ) (RPAQ? CALTUNE '((750 . 20000) (650 . 20000))) (RPAQ? CALUPDATEONSHRINKFLG 'Never) (RPAQ? CALWATCHMAILFLG 'TEXT) (RPAQ? CALYEARICON ) (RPAQ? PBIGFONT ) (RPAQ? PCALFONT ) (RPAQ? PLITTLEFONT ) (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) TABLEBROWSER) ) (DEFINEQ (CALADDEVENT [LAMBDA (M D YR W BROWSER INITMSG MSGSTREAM) (* ; "Edited 14-Oct-88 13:25 by MJD") (* MJD " 2-Jul-86 14:10") (PROG (ANS MSGTITLE DATELST REMDATE REMTIME ALERTFLG ALERTTIME PARSEDALERTTIME PARSEDREMTIME AMBIGUOUSTIMEFLG HOUR PMFLG ASTARTPOS TSTARTPOS) (OBTAIN.MONITORLOCK CALMONLOCK) [OR MSGSTREAM (WITH.MONITOR CALMONLOCK (SETQ MSGSTREAM (CALTEDITSTRING INITMSG M D YR)))] (if (NOT MSGSTREAM) then (printout PROMPTWINDOW T "Reminder aborted") (RELEASE.MONITORLOCK CALMONLOCK) (RETURN NIL)) (SETQ ANS (COERCETEXTOBJ MSGSTREAM 'STRINGP)) (if (NOT D) then (* ;; "This is a rem. coming in via mail, so find its date from the rem. text:") [SETQ DATELST (\UNPACKDATE (IDATE (CONCAT (SUBSTRING ANS 7 15) " 12:00:00"] (SETQ D (CADDR DATELST)) (SETQ M (ADD1 (CADR DATELST))) (SETQ YR (CAR DATELST))) (if (NOT (STRPOS (CONCAT (CHARACTER 13) "Event time: ") ANS)) then (printout PROMPTWINDOW T "Error parsing event time: reminder aborted") (RELEASE.MONITORLOCK CALMONLOCK) (RETURN NIL)) (SETQ TSTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 13) "Event time: ") ANS) 13)) [SETQ REMTIME (SUBSTRING ANS TSTARTPOS (SUB1 (STRPOS (CHARACTER 13) ANS TSTARTPOS] (if (STRING-EQUAL REMTIME ">>Time<<") then (SETQ REMTIME NIL)) (SETQ REMDATE (PACKDATE (SETQ PARSEDREMTIME (NEWPARSETIME REMTIME)) M D YR)) (if (NOT (STRPOS (CONCAT (CHARACTER 13) "Alert time: ") ANS)) then (printout PROMPTWINDOW T "Error parsing alert time: reminder aborted") (RELEASE.MONITORLOCK CALMONLOCK) (RETURN NIL)) (SETQ ASTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 13) "Alert time: ") ANS) 13)) [SETQ ALERTTIME (SUBSTRING ANS ASTARTPOS (SUB1 (STRPOS (CHARACTER 9) ANS ASTARTPOS] (* ;  "Alert time field ends with a TAB") (if (STRING-EQUAL ALERTTIME ">>Time<<") then (SETQ ALERTTIME NIL)) (SETQ PARSEDALERTTIME (NEWPARSETIME ALERTTIME)) (if (NULL PARSEDREMTIME) then (printout PROMPTWINDOW T "Sorry - I couldn't parse that time.") (CALADDEVENT M D YR W BROWSER ANS) (RETURN T) elseif (IGREATERP PARSEDREMTIME 2359) then (SHOULDNT "Illegal time: must be <= 23:59") elseif (AND REMTIME (ILEQ (IDATE REMDATE) (IDATE))) then (printout PROMPTWINDOW T "Warning: you have added a reminder with a time in the past.")) (* ;  "If user gave an alert time w/o an event time, assume event time = alert time.") (if (AND (EQ PARSEDREMTIME 0) (NEQ PARSEDALERTTIME 0)) then (SETQ PARSEDREMTIME PARSEDALERTTIME)) (* ;; "If user didn't give an alert time, but has a default delta, then derive an alert time from that plus the event time.") (if (AND (NEQ CALDEFAULTALERTDELTA 0) (EQ PARSEDALERTTIME 0)) then (SETQ PARSEDALERTTIME (TPLUS PARSEDREMTIME CALDEFAULTALERTDELTA))) (if (NOT (STRPOS (CONCAT (CHARACTER 9) "Alert: ") ANS)) then (printout PROMPTWINDOW T "Error parsing alert option: reminder aborted") (RELEASE.MONITORLOCK CALMONLOCK) (RETURN NIL)) (SETQ ASTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 9) "Alert: ") ANS) 8)) [SETQ ALERTFLG (SUBSTRING ANS ASTARTPOS (SUB1 (STRPOS (CHARACTER 13) ANS ASTARTPOS] (SETQ ALERTFLG (COND ((STRING-EQUAL ALERTFLG "Yes") T) ((STRING-EQUAL ALERTFLG "No") NIL) (T CALALERTFLG))) (if (AND (IGREATERP (HARRAYPROP CALHASH 'NUMKEYS) 0) (NOT CALNEEDSUPDATE)) then (SETQ CALREMSLOADED T)) (if AMBIGUOUSTIMEFLG then (SETQ HOUR (QUOTIENT PARSEDREMTIME 100)) [if (IGEQ HOUR 12) then (SETQ PMFLG T) (if (IGEQ HOUR 12) then (SETQ HOUR (IDIFFERENCE HOUR 12] (printout PROMPTWINDOW "Assuming " HOUR ":" |.I2.10.0| (IMOD PARSEDREMTIME 100) (if PMFLG then " p.m." else " a.m.") T)) (* ; " tell user translated time") (RELEASE.MONITORLOCK CALMONLOCK) [SETQ MSGTITLE (SUBSTRING ANS 24 (SUB1 (STRPOS (CONCAT (CHARACTER 13) "Event time") ANS] (* ; "This needs fixing for groups") (if (EQ (WINDOWPROP W 'GROUPEND) '% ) then (WINDOWPROP W 'GROUPEND NIL)) (for RDAY from D to (OR (WINDOWPROP W 'GROUPEND) D) do (CALCREATEREM (LIST MSGTITLE MSGSTREAM) PARSEDREMTIME PARSEDALERTTIME ALERTFLG M RDAY YR BROWSER) (AND W (SHOWREMSINDAY W M RDAY YR))) (SETQ CALNEEDSUPDATE T) (if (NOT CALUPDATEONSHRINKFLG) then (CALUPDATEINIT]) (CALCREATEREM [LAMBDA (MSG REMTIME ALERTTIME ALERTFLG M D YR BROWSER) (* MJD "23-Feb-88 15:53") (* ;;  "MSG is a list of the form (title-string TEdit-stream), REMTIME is a number representing the time") (* ;; "ALERTTIME is either a time if > 0, a Timer if < 0, or not used if = 0 (note that this disallows times of 0000, ie. midnight, and should eventually be fixed). ALERTFLG if NIL means do not fire this reminder.") (* ;; "Timed reminders are stored on the list CALREMINDERS as (timer-object date-string TB-pointer) The message itself is stored in the data field of the browser item.") (* ;; "BROWSER is always supplied, unless the user clicked Middle in the month window to go startight to CALADDEVENT w/o calling Add from a browser menu.") (PROG (R REMDATE ITEM) (SETQ REMDATE (PACKDATE REMTIME M D YR)) (SETQ ITEM (create TABLEITEM)) (SETQ R (LIST (COND ((LESSP ALERTTIME 0) ALERTTIME) ((GREATERP ALERTTIME 0) (SETUPTIMER.DATE (PACKDATE ALERTTIME M D YR))) ((NEQ REMTIME 0) (SETUPTIMER.DATE REMDATE)) (T NIL)) REMDATE ITEM)) (replace TIDATA of ITEM with (APPEND R MSG)) (if BROWSER then (TB.INSERT.ITEM BROWSER ITEM) (if (ILESSP (TB.NUMBER.OF.ITEMS BROWSER 'SELECTED) 1) then (TB.SELECT.ITEM BROWSER ITEM))) [if (AND (NEQ REMTIME 0) ALERTFLG (IGREATERP (IDATE REMDATE) (IDATE))) then (* ;; "It's a timed reminder. If he wants an alert AND this rem. is not in the past (we now allow this for historical purposes), then put it on CALREMINDERS.") (if CALREMINDERS then (MERGE (LIST R) CALREMINDERS T) else (SETQ CALREMINDERS (LIST R] (pushnew CALDIRTYREMLST ITEM) (PUTHASH (CALMAKEKEY M D YR) (SORT (NCONC1 (GETHASH (CALMAKEKEY M D YR) CALHASH) ITEM) 'REMINDERTIMELT) CALHASH]) (CALDELETEREM [LAMBDA (BROWSER ITEM) (* MJD "10-Dec-87 15:44") (* ;; "ITEM can be either a timed list-form reminder (timer-obj date-str TI-pointer) from CALREMINDERS if this is being called by DOREMINDER, or a TABLEITEM if this is being called by the user via the browser menu.") (PROG (M D YR R RTIMESTR DAYBROWSER ITEMKEY) (if BROWSER then (TB.DELETE.ITEM BROWSER ITEM)) (SETQ CALDIRTYREMLST (REMOVE ITEM CALDIRTYREMLST)) (SETQ R (if (EQ (TYPENAME ITEM) 'TABLEITEM) then (if (EQ (TYPENAME (fetch TIDATA of ITEM)) 'TABLEITEM) then (fetch TIDATA of (fetch TIDATA of ITEM)) else (fetch TIDATA of ITEM)) else ITEM)) (SETQ RTIMESTR (CADR R)) (SETQ M (LISPDATEMONTH RTIMESTR)) (SETQ D (LISPDATEDAY RTIMESTR)) (SETQ YR (LISPDATEYEAR RTIMESTR)) (* ;; "See if this rem. has a browser open so it can be marked as deleted. However, if it has an alert time earlier than its event time, leave it be (looks bad to have a rem. crossed out before the event time.)") [if (AND (NOT BROWSER) (LESSP (IDATE RTIMESTR) (IDATE))) then (SETQ DAYBROWSER (for B in CALDAYBROWSERS thereis (AND (EQ D (CADR (TB.USERDATA B))) (EQ M (CAR (TB.USERDATA B))) (EQ YR (CADDR (TB.USERDATA B] [if DAYBROWSER then (TB.DELETE.ITEM DAYBROWSER (CAR (LAST ITEM] (* ;; "If this is a timed rem and it hasn't expired yet, remove it form CALREMINDERS.") (if (AND (TIMEDREMP R) (IGREATERP (IDATE RTIMESTR) (IDATE))) then (SETQ CALREMINDERS (REMOVE [for REM in CALREMINDERS thereis (EQ ITEM (CAR (NTH REM 3] CALREMINDERS))) (* ;; "If this reminder is periodic, its hash key is stored in its 6th slot. If nothing is found there, compute the key the usual way.") (SETQ ITEMKEY (OR (CAR (NTH R 6)) (CALMAKEKEY M D YR))) (* ;  "Now that we have the key, we can remove it from the list of rems. in that day.") (PUTHASH ITEMKEY (REMOVE (CADDR R) (GETHASH ITEMKEY CALHASH)) CALHASH]) (CALDISPEVENT [LAMBDA (ITEM MNAME BUTTON) (* ; "Edited 24-Oct-88 15:58 by MJD") (* ;  "Handles browser menu item selections --- Add, Display, Delete, Update, SendMail, Period.") (PROG (M D YR DLIST W BROWSER CHOICE ITEMKEY RECIPIENTS) (SETQ BROWSER (GETMENUPROP MNAME 'BROWSER)) (SETQ DLIST (TB.USERDATA BROWSER)) (SETQ W (CADDDR DLIST)) (* ; "Browser's wndow.") (SETQ M (CAR DLIST)) (SETQ D (CADR DLIST)) (SETQ YR (CADDR DLIST)) [COND [(EQ (CADR ITEM) 'CALADD) (* ; "Add:") (CALADDEVENT M D YR W (GETMENUPROP MNAME 'BROWSER] ((EQ (CADR ITEM) 'CALDISPLAY) (* ; "Display:") (TB.MAP.SELECTED.ITEMS BROWSER [FUNCTION (LAMBDA (B I) (TEDIT (CAR (NTH (GETREMDEF I) 5)) (CREATEW CALREMDISPLAYREGION "Reminder Display Window") NIL '(QUITFN T LEAVETTY T] 'CALTBNULLFN)) ((EQ (CADR ITEM) 'CALUPDATE) (* ; "Update:") (CALUPDATEINIT) (TB.MAP.DELETED.ITEMS BROWSER [FUNCTION (LAMBDA (B I) (TB.REMOVE.ITEM B I] 'NILL)) ((EQ (CADR ITEM) 'CALMAIL) (* ; "Mail:") (if (EQ (TB.NUMBER.OF.ITEMS BROWSER) 0) then (CALTBNULLFN BROWSER) else (SETQ RECIPIENTS (PROMPTFORWORD (PROGN (TERPRI PROMPTWINDOW) "Send message to: ") NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL))) (TB.MAP.SELECTED.ITEMS BROWSER [FUNCTION (LAMBDA (B I) (change (CAR (NTH (GETREMDEF I) 5)) (LIST 'LAFITE.SENDMESSAGE (CONCAT "Subject: A CALENDAR Message" (CHARACTER 13) "To: " RECIPIENTS (CHARACTER 13) (CHARACTER 13) (COERCETEXTOBJ (CAR (NTH (GETREMDEF I) 5)) 'STRINGP] 'CALTBNULLFN) (PRINTOUT PROMPTWINDOW T "The message will be mailed when its time arrives."))) ((EQ (CADR ITEM) 'CALDELETE) (* ; "Delete:") (if (EQ (TB.NUMBER.OF.ITEMS BROWSER) 0) then (CALTBNULLFN BROWSER) else (SETCURSOR WAITINGCURSOR) (TB.MAP.SELECTED.ITEMS BROWSER 'CALDELETEREM 'CALTBNULLFN) (SHOWREMSINDAY W M D YR) (SETQ CALNEEDSUPDATE T) (CURSOR T))) ((EQ (CADR ITEM) 'CALPERIOD) (* ; "Periodic:") (* ;; "When adding new period types here, you must change REMINDERSOF also.") (if (EQ (TB.NUMBER.OF.ITEMS BROWSER) 0) then (CALTBNULLFN BROWSER) else (SETQ CHOICE (MENU (create MENU ITEMS _ '(Daily Weekly Monthly Yearly) TITLE _ "Period:"))) (if (NOT CHOICE) then (PRINTOUT (GETPROMPTWINDOW (TB.WINDOW BROWSER) 1) T "No period set.") (RETURN NIL)) (TB.MAP.SELECTED.ITEMS BROWSER [FUNCTION (LAMBDA (B I) (PROG (DSTR D M YR) (SETQ DSTR (CADR (GETREMDEF I))) (SETQ D (LISPDATEDAY DSTR)) (SETQ M (LISPDATEMONTH DSTR)) (SETQ YR (LISPDATEYEAR DSTR)) (* ;  "First, remove the item from its original slot...") (PUTHASH (CALMAKEKEY M D YR) (REMOVE I (GETHASH (CALMAKEKEY M D YR) CALHASH)) CALHASH) (* ;; "Hash key period codes: 0 = daily; 1-31 = monthly; 32-38 = weekly (32 + day no.); yearly is set by using 1900 for YR (because of the way calmakekey works.") [SETQ ITEMKEY (COND ((EQ CHOICE 'Daily) 0) ((EQ CHOICE 'Weekly) (IPLUS (DAYOF M D YR) 32)) ((EQ CHOICE 'Monthly) D) ((EQ CHOICE 'Yearly) (CALMAKEKEY M D 1900] (* ;  "...and move it to the appropriate periodic slot:") (replace TIDATA of I with (NCONC1 (GETREMDEF I) ITEMKEY)) (* ;; "Note that we save the access key to this item in the rem. itself so that 1. we'll be able to find it if we need to delete it, and 2. when it fires we can tell it's periodic, figure out its next firing time and put it back on CALREMINDERS.") (PUTHASH ITEMKEY (SORT (NCONC1 (GETHASH ITEMKEY CALHASH) I) 'REMINDERTIMELT) CALHASH] 'CALTBNULLFN) (PRINTOUT (GETPROMPTWINDOW (TB.WINDOW BROWSER) 1) T "OK"] (TOTOPW (TB.WINDOW BROWSER]) (CALDOOPTIONS [LAMBDA (ITEM WINDOW BUTTON) (* MJD " 9-Dec-87 10:24") (* ;; " The conversion to Lyric has turned this routine into a disgusting mess, in particular that whole TYPEP clause.") (PROG [VALLIST (OPTLIST (if (EQ MAKESYSNAME 'KOTO) then (FM.READSTATE WINDOW) else (FM.GETSTATE WINDOW] (SETQ VALLIST (CDR OPTLIST)) [for ITEM in OPTLIST by (CDDR OPTLIST) as VAL in VALLIST by (CDDR VALLIST) when (NEQ VAL T) do (SET ITEM (COND ((EQ VAL 'Yes) T) ((EQ VAL 'No) NIL) [(AND (NEQ MAKESYSNAME 'KOTO) (TYPEP VAL 'FREEMENUITEM)) (if (AND (EQ (FM.ITEMPROP VAL 'TYPE) 'NWAY) (NEQ (FM.ITEMPROP VAL 'LABEL) 'Yes) (NEQ (FM.ITEMPROP VAL 'LABEL) 'No)) then (FM.ITEMPROP VAL 'LABEL) else (FM.ITEMPROP VAL 'STATE] (T (MKATOM VAL] (CLOSEW WINDOW) (PRINTOUT PROMPTWINDOW T "OK"]) (CALENDAR [LAMBDA (M D YR) (* MJD " 9-Dec-87 10:21") (* ;  "Top-level entry to the program, and public programming interface.") (* ;;; "If you use any part of Calendar code in your own programs, I would appreciate it if you would include credit to the original author. Thanks.") (pushnew BACKGROUNDFNS 'CALENDARWATCHER) [OR (EQ (TYPENAME CALMONLOCK) 'MONITORLOCK) (SETQ CALMONLOCK (CREATE.MONITORLOCK 'CALLOCKNAME] [if (NOT CALDEFAULTHOST&DIR) then (SETQ CALDEFAULTHOST&DIR (PROMPTFORWORD "Please enter a default host & directory for reminder files:" NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL] (COND ((type? MENU CALMAINMENU) (DELETEMENU CALMAINMENU))) (SETQ CALMAINMENU (create MENU ITEMS _ [APPEND (for YR from (IDIFFERENCE (LISPDATEYEAR (DATE)) 1) to (IPLUS (LISPDATEYEAR (DATE)) 3) collect (LIST YR YR "Will make a calendar for this year.")) (LIST '(Other 'OTHER "Lets you choose another year"] TITLE _ "Year" CENTERFLG _ T CHANGEOFFSETFLG _ T WHENSELECTEDFN _ 'SHOWYEAR)) (COND ((NOT CALFONT) (if (AND (NOT M) (NOT D) (NOT YR)) then (printout PROMPTWINDOW T "Looking for font TimesRoman 36 - one moment please ...") (SETCURSOR WAITINGCURSOR)) (SETQ CALFONT (FONTCREATE 'TIMESROMAN 36)) (CURSOR T))) (COND ((AND (NOT M) (NOT D) (NOT YR)) (printout T CALENDARVERSION T) (printout T "See the Prompt Window for Calendar messages." T) (printout PROMPTWINDOW T "Select a year for calendar.") (MENU CALMAINMENU)) [(EQ M 'TODAY) (SHOWDAY (LIST (LISPDATEDAY (DATE)) (LISPDATEMONTH (DATE)) (LISPDATEYEAR (DATE] [(EQ M 'THISMONTH) (SHOWMONTH (LIST NIL (LISPDATEMONTH (DATE)) (LISPDATEYEAR (DATE] [(EQ M 'THISYEAR) (SHOWYEAR (LIST (LISPDATEYEAR (DATE] ((AND (NUMBERP M) (NUMBERP D) (NUMBERP YR)) (SHOWDAY (LIST D M YR))) ((AND (NOT M) (NUMBERP YR)) (SHOWYEAR (LIST YR))) [(NUMBERP M) (SHOWMONTH (LIST NIL M (OR YR (LISPDATEYEAR (DATE] (T NIL]) (CALENDARWATCHER [LAMBDA NIL (* MJD "23-Jun-87 15:53") (if (AND CALREMINDERS (TIMEREXPIRED? (CAAR CALREMINDERS) 'SECONDS)) then (DOREMINDER (CAR CALREMINDERS]) (CALEXTENDSEL [LAMBDA (CALMONTHWINDOW) (* MJD "29-Jan-88 11:06") (* ;  "Changes the length of a day group selection.") (PROG [DEND NEWEND [CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU] (CALCURMONTH (WINDOWPROP CALMONTHWINDOW 'MONTH#)) (CALCURYEAR (WINDOWPROP CALMONTHWINDOW 'YEAR#] (while (MOUSESTATE (ONLY RIGHT)) do (SETQ DEND (CAR (MENUREGIONITEM CALMONTHWINDOW CALMONTHMENU))) (if (EQ DEND '% ) then (* ; " He clicked Right in a blank box.") (RETURN (TOTOPW CALMONTHWINDOW))) (OR CALCURDAY (RETURN (TOTOPW CALMONTHWINDOW))) (* ;  "Happens if he clicked right before selecting any day - (SHOWDAY sets CALCURDAY)") (OR DEND (SETQ DEND CALCURDAY)) (INVERTGROUP CALCURMONTH CALCURDAY CALCURYEAR CALCURMONTH DEND CALCURYEAR BLACKSHADE CALMONTHMENU) (SETQ NEWEND (CAR (MENUREGIONITEM CALMONTHWINDOW CALMONTHMENU))) (* ;; " At this point we have to check NEWEND for two possibilities: user wandered into a blank box (which makes it a blank), or out of the menu entirely (which makes it NIL). Either way, skip it.") (if (AND NEWEND (NEQ NEWEND '% ) (ILESSP NEWEND DEND)) then (INVERTGROUP CALCURMONTH NEWEND CALCURYEAR CALCURMONTH DEND CALCURYEAR WHITESHADE CALMONTHMENU) (SETQ DEND NEWEND))) (WINDOWPROP CALMONTHWINDOW 'GROUPEND DEND]) (CALLOADFILE [LAMBDA (F) (* ; "Edited 20-Feb-90 16:13 by MJD") (* ;; "Each reminder on the file has the format:") (* ;; " (timer-value date-string hash-key title-string) [TEdit-text] *start*. Note that the text may be omitted. The file ends in STOP.") (PROG ((*readtable* (FIND-READTABLE "OLD-INTERLISP-T")) (*package* (CL:FIND-PACKAGE "INTERLISP")) (R# 0) (R#SKIP 0) FILE FNAME FILESTREAM TEMPSTREAM RSTREAM R REMLIST ITEM TIMER REMDATE REMSTARTPTR REMENDPTR SAMETITLES TITLE ITEMKEY) (SETCURSOR WAITINGCURSOR) [SETQ FILE (OR F (U-CASE (PROMPTFORWORD "File to load:" NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL] (* ;; " First see if he typed in a full file name. If not, make it one, using the value of CALDEFAULTHOST&DIR:") (if (NOT (MEMBER 'HOST (UNPACKFILENAME FILE))) then (SETQ FILE (PACKFILENAME 'NAME FILE 'DIRECTORY CALDEFAULTHOST&DIR))) (* ;; "Now that we have a complete name, see if it's really out there:") (if (NOT (INFILEP FILE)) then (PRINTOUT PROMPTWINDOW T FILE " not found. No reminders loaded.") (CURSOR T) (RETURN NIL)) (if (AND (INFILEP FILE) (GETPROP (CAR (MEMBER FILE CALFILELST)) 'CONTENTS)) then (if (NOT (MOUSECONFIRM (CONCAT FILE " is already loaded. " "Are you sure you want to do this?"))) then (PRINTOUT PROMPTWINDOW T "OK. No reminders loaded.") (CURSOR T) (RETURN NIL))) (SETQ FILESTREAM (OPENSTREAM FILE 'INPUT 'OLD)) (* ;; "Open a stream on it and verify that it's a valid file:") (if (NEQ (CAR (READ FILESTREAM *readtable*)) '$$CALREMINDERS) then (PRINTOUT PROMPTWINDOW T FILE " is not a valid reminders file. No reminders loaded.") (CLOSEF FILESTREAM) (CURSOR T) (RETURN NIL)) (* ;; "Looks OK - let's read it:") (PRINTOUT PROMPTWINDOW T "Loading " FILE "...") (until (EQ (SETQ R (READ FILESTREAM *readtable*)) 'STOP) do (SETQ TIMER (CAR R)) (* ; " eg. -1558614616") (SETQ REMDATE (CADR R)) (* ; " eg. %"12-Oct-87%"") (SETQ ITEMKEY (CADDR R)) (* ; "eg. 29271") (SETQ TITLE (CADDDR R)) (* ; "eg. %"FOO%"") (* SETQ RSTREAM (OPENTEXTSTREAM)) (* ;; "9/28/88: Attempt to fix formatted rem. read-in bug (it's not clear this is all really needed - the old way also seems to work. The only problem may have been just in selecting the right start and end points to copy out of the file):") (SETQ TEMPSTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) (SETQ REMSTARTPTR (GETFILEPTR FILESTREAM)) (SETQ REMENDPTR (FILEPOS (CONCAT (CHARACTER 13) "*start*") FILESTREAM)) (* ;; "Check for Unix-style converted files with LF's instead o CR's:") (OR REMENDPTR (SETQ REMENDPTR (FILEPOS (CONCAT (CHARACTER 10) "*start*") FILESTREAM))) (SETFILEPTR FILESTREAM REMSTARTPTR) (COPYCHARS FILESTREAM TEMPSTREAM (ADD1 REMSTARTPTR) REMENDPTR) (SETFILEPTR TEMPSTREAM 0) (SETQ RSTREAM (OPENTEXTSTREAM TEMPSTREAM)) (* ; " the reminder text stream.") (* TEDIT.INCLUDE (TEXTOBJ RSTREAM)  FILESTREAM (ADD1 REMSTARTPTR)  REMENDPTR) (* ;; "Move past the separator: always skip 8 for the string %"*start*%". If the just-read rem. had no text, it ended with and reading stopped with the first , so we have to skip one more char - that is what the IF tests for.") (SETFILEPTR FILESTREAM (IPLUS (GETFILEPTR FILESTREAM) 8 (if (GREATERP REMENDPTR (ADD1 REMSTARTPTR)) then 0 else 1))) (* ; " Move past the separator.") (* ;; "Only load this rem. if it hasn't been loaded before. Tests are ordered from easy to hard to minimize performance hit. First see if there are already any rems already in this day. If not, this one must be new. Then compare titles. If any matches there, compare message lengths. Note that this still doesn't *guarantee* the rems. are different.") (if (OR (NOT (GETHASH ITEMKEY CALHASH)) (NOT (SETQ SAMETITLES (for ENTRY in (GETHASH ITEMKEY CALHASH) when (STRING-EQUAL TITLE (CAR (NTH (fetch TIDATA of ENTRY) 4))) collect ENTRY))) (NOT (for ENTRY in SAMETITLES when [EQ (NCHARS RSTREAM) (NCHARS (CAR (NTH (fetch TIDATA of ENTRY) 5] collect ENTRY))) then (SETQ ITEM (create TABLEITEM)) (if (AND (ILEQ ITEMKEY 38) (TIMEREXPIRED? TIMER 'SECONDS)) then (* ;; " It's a periodic rem. with an expired timer, so we need to find the next future time it will come up so we can add it to CALREMINDERS.") (SETQ REMDATE (DERIVENEWDATE REMDATE ITEMKEY)) (SETQ TIMER (SETUPTIMER.DATE REMDATE))) (replace TIDATA of ITEM with (LIST TIMER REMDATE ITEM TITLE RSTREAM ITEMKEY)) [if [AND TIMER (NOT (TIMEREXPIRED? TIMER 'SECONDS] then (* ;; "It's a timed reminder. Note that we don't put already expired timers on the list, as might happen when an old file containing timed-keep's is reloaded.") (if CALREMINDERS then (MERGE (LIST (LIST TIMER REMDATE ITEM ITEMKEY)) CALREMINDERS T) else (SETQ CALREMINDERS (LIST (LIST TIMER REMDATE ITEM ITEMKEY] (* ;; " Stuff it into the hash array:") (PUTHASH ITEMKEY (SORT (NCONC1 (GETHASH ITEMKEY CALHASH) ITEM) 'REMINDERTIMELT) CALHASH) (* ;;  " Keep track of the rems. we're making so we can save it at the end:") (SETQ REMLIST (NCONC1 REMLIST ITEM)) (add R# 1) (if (EQ (REMAINDER R# 5) 0) then (PRINTOUT PROMPTWINDOW R# ",")) else (add R#SKIP 1))) (* ;; "Wrap up: First, close the file:") (CLOSEF FILESTREAM) (* ;; "Add the file to the list of known files:") (pushnew CALFILELST (SETQ FNAME (MKATOM FILE))) (* ;; "Save the list of rems. in this file as a prop on the name. You have to do the MEMBER in the case that the user is reloading an already loaded file, where the name isn't at the CAR of the list.") (PUTPROP (CAR (MEMBER FNAME CALFILELST)) 'CONTENTS REMLIST) (SETQ CALREMSLOADED T) (OR (EQ (REMAINDER R# 5) 0) (printout PROMPTWINDOW R# ",")) (PRINTOUT PROMPTWINDOW " done.") (if (GREATERP R#SKIP 0) then (PRINTOUT PROMPTWINDOW " " R#SKIP " duplicate" (if (GREATERP R#SKIP 1) then "s" else "") " skipped.")) (CURSOR T) (RETURN T]) (CALMAKEKEY [LAMBDA (M D YR) (* MJD "20-Nov-86 15:48") (BLOCK) (LOGOR (LLSH M 12) (LLSH D 7) (IDIFFERENCE YR 1900]) (CALMONTHBEF [LAMBDA (CALMONTHWINDOW) (* MJD " 2-Dec-87 12:27") (PROG (CALMONTHSTREAM FILE) (SETQ CALMONTHSTREAM (WINDOWPROP CALMONTHWINDOW 'DSP)) (if [AND (MOUSESTATE MIDDLE) (NOT (INSIDEP (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH) (WINDOWPROP CALMONTHWINDOW 'HEIGHT)) (LASTMOUSEX CALMONTHSTREAM) (LASTMOUSEY CALMONTHSTREAM] then (SETQ FILE (MENU (create MENU ITEMS _ (APPEND CALFILELST (LIST 'Other)) TITLE _ "Load file:"))) (if (EQ FILE 'Other) then (SETQ FILE (PROMPTFORWORD "File name:" NIL NIL PROMPTWINDOW))) (if FILE then (CALLOADFILE FILE) else (PRINTOUT PROMPTWINDOW T "No file given.")) else (MENUBUTTONFN CALMONTHWINDOW]) (CALMONTHICONFN [LAMBDA (W ICON) (* MJD "17-Jun-87 15:47") (if ICON then [ICONW.TITLE ICON (MONTHNAME (WINDOWPROP W 'MONTH#] ICON else [SETQ CALMONTHICON (create TITLEDICON ICON _ CALMONTHICONMAP TITLEREG _ '(3 51 56 9] (TITLEDICONW CALMONTHICON (MONTHNAME (WINDOWPROP W 'MONTH#)) LITTLEFONT]) (CALMONTHRBF [LAMBDA (CALMONTHWINDOW) (* MJD "17-Nov-87 16:53") (* ;; "User clicked in a month window. If inside menu area with left, pass on to menu. If inside menu area with right, extend a selection. If outside menu area, do standard window menu.") (PROG [(CALMONTHSTREAM (WINDOWPROP CALMONTHWINDOW 'DSP] (if (INSIDEP [MENUREGION (CAR (WINDOWPROP CALMONTHWINDOW 'MENU] (LASTMOUSEX CALMONTHSTREAM) (LASTMOUSEY CALMONTHSTREAM)) then (if (MOUSESTATE LEFT) then (MENUBUTTONFN CALMONTHWINDOW) else (CALEXTENDSEL CALMONTHWINDOW)) else (DOWINDOWCOM CALMONTHWINDOW]) (CALOPTIONMENU [LAMBDA NIL (* ; "Edited 5-Nov-87 16:58 by MJD") (if (EQ MAKESYSNAME 'KOTO) then (SETQ CALOPTIONWINDOW (FM.FORMATMENU CALOPTIONSDESC)) (FM.CHANGELABEL (FM.ITEMFROMID CALOPTIONWINDOW 'CALDEFAULTHOST&DIR) CALOPTIONWINDOW CALDEFAULTHOST&DIR) (FM.CHANGELABEL (FM.ITEMFROMID CALOPTIONWINDOW 'CALDEFAULTALERTDELTA) CALOPTIONWINDOW CALDEFAULTALERTDELTA) (FM.CHANGESTATE (FMNWAYITEM CALOPTIONWINDOW 'CALALERTFLG (YNCONVERT CALALERTFLG)) CALOPTIONWINDOW) (FM.CHANGESTATE (FMNWAYITEM CALOPTIONWINDOW 'CALKEEPEXPIREDREMSFLG (YNCONVERT CALKEEPEXPIREDREMSFLG )) CALOPTIONWINDOW) (FM.CHANGESTATE (FM.ITEMFROMID CALOPTIONWINDOW CALUPDATEONSHRINKFLG) CALOPTIONWINDOW) (MOVEW CALOPTIONWINDOW LASTMOUSEX LASTMOUSEY) (OPENW CALOPTIONWINDOW) else (SETQ CALOPTIONWINDOW (FREEMENU CALOPTIONSDESCLYRIC "Calendar Options")) (FM.CHANGELABEL (FM.GETITEM 'CALDEFAULTHOST&DIR NIL CALOPTIONWINDOW) CALDEFAULTHOST&DIR CALOPTIONWINDOW) (FM.CHANGELABEL (FM.GETITEM 'CALDEFAULTALERTDELTA NIL CALOPTIONWINDOW) CALDEFAULTALERTDELTA CALOPTIONWINDOW) (FM.CHANGESTATE 'CALALERTFLG (FM.GETITEM (YNCONVERT CALALERTFLG) 'ALERTGROUP CALOPTIONWINDOW) CALOPTIONWINDOW) (FM.CHANGESTATE 'CALKEEPEXPIREDREMSFLG (FM.GETITEM (YNCONVERT CALKEEPEXPIREDREMSFLG) 'XGROUP CALOPTIONWINDOW) CALOPTIONWINDOW) (FM.CHANGESTATE 'CALUPDATEONSHRINKFLG (FM.GETITEM CALUPDATEONSHRINKFLG 'UPGROUP CALOPTIONWINDOW) CALOPTIONWINDOW) (MOVEW CALOPTIONWINDOW LASTMOUSEX LASTMOUSEY) (OPENW CALOPTIONWINDOW]) (CALPEEKNEWMAIL [LAMBDA (FOLDER MSGLST) (* ; "Edited 29-Feb-88 16:21 by DENBER") (* ; "This is a LAFITE.AFTER.GETMAIL.FN. It checks your mail for msgs. that start with %"$CALENDAR%" in the subject. These get added to your calendar automatically.") (* ;; "The decls for this is on {Erinyes}Lyric>Internal>Library>LAFITEDECLS.") (PROG (FSTREAM RSTREAM OLDPTR MSTRING MSTARTPOS MSGTEXT (TOT# 0)) (if CALWATCHMAILFLG then (SETQ FSTREAM (fetch FOLDERSTREAM of FOLDER)) (for MSG in MSGLST when (STRING.EQUAL (SUBSTRING (fetch SUBJECT of MSG) 1 9) "$CALENDAR") do (SETQ OLDPTR (GETFILEPTR FSTREAM)) (TEDIT.INCLUDE (TEXTOBJ (SETQ RSTREAM (OPENTEXTSTREAM))) FSTREAM (PROGN (SETFILEPTR FSTREAM (fetch START of MSG)) (IPLUS (FILEPOS (CONCAT (CHARACTER 13) (CHARACTER 13)) FSTREAM) 2)) (fetch END of MSG)) (* ;; "All this stuff is to see if the msg. is a list. If so, see if posting it is allowed before adding it (guards against possible Trojan horses):") (SETQ MSTRING (COERCETEXTOBJ RSTREAM 'STRINGP)) (SETQ MSTARTPOS (IPLUS (OR (STRPOS (CONCAT (CHARACTER 13) "Message: ") MSTRING) -9) 9)) (SETFILEPTR RSTREAM MSTARTPOS) (if (IGREATERP (IDIFFERENCE (NCHARS MSTRING) MSTARTPOS) 1) then (SETQ MSGTEXT (READ RSTREAM))) (if [OR (NOT (LISTP MSGTEXT)) (AND (LISTP MSGTEXT) (EQ CALWATCHMAILFLG 'ANY] then (CALADDEVENT NIL NIL NIL NIL NIL NIL RSTREAM) (add TOT# 1)) (SETFILEPTR FSTREAM OLDPTR)) (if (IGREATERP TOT# 0) then (PLAYTUNE CALTUNE) (PRINTOUT PROMPTWINDOW T TOT# " reminder" (if (EQ TOT# 1) then "" else "s") " posted to Calendar from new mail."]) (CALPRINTREM [LAMBDA (B ITEM STREAM) (* MJD " 7-Oct-87 13:52") (* ;  "Prints reminder in day box of month window. Caller must set x,y position in STREAM first.") (PROG (REMINDER (XOFFSET 0)) (SETQ REMINDER (fetch TIDATA of ITEM)) (if (EQ (TYPENAME REMINDER) 'TABLEITEM) then (SETQ REMINDER (fetch TIDATA of REMINDER))) (if (TIMEDREMP REMINDER) then (PRIN1 (REMINDERTIME REMINDER) STREAM) (SPACES 1 STREAM) (if (NEQ (IMAGESTREAMTYPE STREAM) 'DISPLAY) then (SETQ XOFFSET -10))) (* ;; "This kludge is required because IP streams currently do not support clipping regions (SHOWREMSINMONTH sets the clipping region that limits the line length automatically):") (PRIN1 (if (EQ (IMAGESTREAMTYPE STREAM) 'DISPLAY) then (CALREMDEF REMINDER) else (OR (SUBSTRING (CALREMDEF REMINDER) 1 (IPLUS 26 XOFFSET)) (CALREMDEF REMINDER))) STREAM) (* ;  " The OR above hinges on the fact that SUBSTRING returns NIL if its arg is too big.") (TERPRI STREAM]) (CALREMDEF [LAMBDA (REMINDER) (* MJD " 5-Jun-87 12:48") (* Return reminder message title text.) (CAR (NTH REMINDER 4]) (CALTBCLOSEFN [LAMBDA (BROWSER W TYPE) (* MJD "16-Nov-87 12:50") (* ;  "Before closing a day browser, remove it from the list of active browsers.") (if (EQ TYPE 'CLOSE) then (SETQ CALDAYBROWSERS (REMOVE BROWSER CALDAYBROWSERS))) NIL]) (CALTBCOPYFN [LAMBDA (BROWSER ITEM) (* MJD "23-Feb-88 17:00") (* ;  "Copy a rem. from BROWSER into previously selected browser.") (PROG (DDATE DBROWSER M D YR R REMTIME MSG ALERTTIME ALERTFLG DATELST) (* ;; " CALCURBROWSER is a dotted pair containing (source-browser . dest.-browser). It is set by CALTBSELECTEDFN every time you click in a day browser.") (if (NOT (CDR CALCURBROWSER)) then (PRINTOUT PROMPTWINDOW T "Please select a destination for copy first.") (RETURN NIL) else (SETQ DBROWSER (CDR CALCURBROWSER)) (SETQ DDATE (TB.USERDATA DBROWSER)) (SETQ M (CAR DDATE)) (SETQ D (CADR DDATE)) (SETQ YR (CADDR DDATE)) (SETQ R (fetch TIDATA of ITEM)) (SETQ REMTIME (OR (REMINDERTIME R) 0)) [SETQ MSG (LIST (CALREMDEF R) (CAR (NTH (GETREMDEF (CAR (NTH R 3))) 5] (* ;; "Extract the actual remind-time from the old Timer, so CALCREATEREM will know the time for the new date. \UNPACKDATE returns a list in the form (YR M D HR MIN SEC x x). The PROGN turns the hr and min ints. into a single 24-hr. time integer.") (SETQ ALERTTIME (if (TIMEDREMP R) then [PROGN [SETQ DATELST (\UNPACKDATE (IPLUS (IDATE) (TIME.UNTIL (TIMEDREMP R) 'SECONDS] (IPLUS (ITIMES (CAR (NTH DATELST 4)) 100) (CAR (NTH DATELST 5] else 0)) (SETQ ALERTFLG (TIMEDREMP R)) (CALCREATEREM MSG REMTIME ALERTTIME ALERTFLG M D YR DBROWSER]) (CALTBNULLFN [LAMBDA (BROWSER) (* MJD "22-Jun-87 14:49") (PRINTOUT (GETPROMPTWINDOW (TB.WINDOW BROWSER) 1) T "No reminders selected."]) (CALTBSELECTEDFN [LAMBDA (W) (* MJD "23-Feb-88 13:07") (* ;  "Makes this browser be the source for rem. copies.") (RPLACD CALCURBROWSER (CAR CALCURBROWSER)) (RPLACA CALCURBROWSER (WINDOWPROP W 'TABLEBROWSER]) (CALTEDITEXIT [LAMBDA (ITEM MNAME BUTTON) (* MJD "17-Jun-87 12:38") (COND ((EQ ITEM 'Save) (TEDIT.QUIT (TEXTSTREAM CALTEDITWINDOW))) ((EQ ITEM 'Abort) (TEDIT.QUIT (TEXTSTREAM CALTEDITWINDOW) 'Abort]) (CALTEDITSTRING [LAMBDA (STRING M D YR) (* ; "Edited 14-Oct-88 12:48 by MJD") (* T.Bigham "12-Nov-84 11:03") (* ;; "this may not be needed in Carol. In harmony, this makes tedit put the value into the item editor without the confirmation that always pops up when changes have been made without saving the file.") (PROG ((*readtable* (FIND-READTABLE "INTERLISP")) (*package* (CL:FIND-PACKAGE "INTERLISP")) STREAM) (if (NOT (WINDOWP CALTEDITWINDOW)) then (SETQ CALTEDITWINDOW (CREATEW CALREMCREATEREGION "" NIL T)) (ATTACHMENU (create MENU ITEMS _ '(Save Abort) ITEMWIDTH _ 199 CENTERFLG _ T MENUROWS _ 1 MENUFONT _ (FONTCREATE 'HELVETICA 12 'BOLD) MENUBORDERSIZE _ 1 WHENSELECTEDFN _ 'CALTEDITEXIT) CALTEDITWINDOW 'TOP 'LEFT)) (WINDOWPROP CALTEDITWINDOW 'TITLE (CONCAT "Calendar message editor for " (MKSTRING (MONTHNAME M)) " " D ", " (MKSTRING YR))) (RETURN (EVAL.IN.TTY.PROCESS `(PROGN [SETQ STREAM (OPENTEXTSTREAM (OR %, STRING (CONCAT "Date: " (GDATE (\PACKDATE ,YR (SUB1 ,M) ,D 0 0 0) (DATEFORMAT NO.TIME)) (CHARACTER 13) "Title: >>One line<<" (CHARACTER 13) "Event time: >>Time<<" (CHARACTER 13) "Alert time: >>Time<<" (CHARACTER 9) "Alert: >>Yes No<<" (CHARACTER 13) "Duration: >>hh:mm<<" (CHARACTER 13) "Message: >>Any text<<")) NIL NIL NIL '(QUITFN T] (TEDIT.SETSEL STREAM 24 12 NIL T) (SPAWN.MOUSE) [SETQ RESULT (TEDIT STREAM CALTEDITWINDOW T '(QUITFN T] (IF (EQ RESULT 'Abort) THEN NIL ELSE STREAM)) T]) (CALUPDATEFILE [LAMBDA (FILE) (* ; "Edited 24-Oct-88 16:09 by MJD") (* ;; "Each reminder on the file has the form:") (* ;; " (timer-value date-string hash-key title-string) TEdit-stream *start*.") (* ;; " File updates work like this: The file to be updated will contain all still-valid reminders that were on it when it was loaded (this info. was cached in the hash array under the file name when it was loaded or initally created), plus any new reminders that have not yet been saved (this comes from CALDIRTYREMLST).") (* ;; "9/23/88: A long-standing bug involving a break when reading in TEdit-formatted rems. is hopefully fixed. See the fns. NC.PutTextSubstance and NC.GetTextSubstance in {QV}1.3L>NCTEXTCARD for the model. A change was made to CALLOADFILE for this also. I'm still not sure *what* the problem was. At the moment, the old way seems to be working here - the only change was in CALLOADFILE where we start reading one byte later.") (PROG ((*readtable* (FIND-READTABLE "OLD-INTERLISP-T")) (*package* (CL:FIND-PACKAGE "INTERLISP")) FSTREAM REMSTREAM RDATA REMLIST WRITTENREMS (R# 0)) (OBTAIN.MONITORLOCK CALMONLOCK) (WITH.MONITOR CALMONLOCK [OUTPUT (SETQ FSTREAM (OPENSTREAM FILE 'BOTH 'OLD/NEW] (printout PROMPTWINDOW T "Updating reminder file " FILE "...") (pushnew CALFILELST FILE) (* ;; " A list of all the reminders that were in this file when it was loaded (or NIL if this is a new file to be written):") (SETQ REMLIST (GETPROP (CAR (MEMBER FILE CALFILELST)) 'CONTENTS)) (PRINT (LIST '$$CALREMINDERS CALENDARVERSION) FSTREAM) (* ;; "The hash array contains both lists of items and items in files.") [MAPHASH CALHASH (FUNCTION (LAMBDA (VLIST KEY) (* ;; " This is ugly, but we need the key of each item being written - it's the only way to tell if it's periodic. We sweep through the entire hash array looking for items that are on REMLIST. This test isn't done when creating a new file from scratch. In this case, there are no previously loaded rems., and so REMLIST is NIL.") (SETQ WRITTENREMS (APPEND WRITTENREMS (for VAL in VLIST when (OR (MEMBER VAL REMLIST) (MEMBER VAL CALDIRTYREMLST)) collect (PROGN (SETQ RDATA (fetch TIDATA of VAL)) (* ;; " Now put out the timer (CAR), the date-string (CADR), the hash key (KEY), and the title (CADDDR):") (PRINT (LIST (CAR RDATA) (CADR RDATA) KEY (CADDDR RDATA)) FSTREAM) (* ;; "Finally, write the reminder text:") (if [STREAMP (SETQ REMSTREAM (CAR (LAST (fetch TIDATA of VAL] then (* ;; "Proposed fix for fmt. bug:") (* SETQ STARTPTR (GETFILEPTR FSTREAM)) (* SETQ TEXTLEN (fetch  (TEXTOBJ TEXTLEN) of  (TEXTOBJ REMSTREAM))) (* TEDIT.PUT.PCTB (TEXTOBJ REMSTREAM)  FSTREAM)(* SETFILEPTR FSTREAM  (IDIFFERENCE (SETQ EOFPTR  (GETEOFPTR FSTREAM)) 8)) (* SETQ STARTFORMATPTR  (\DWIN FSTREAM)) (* SETFILEPTR FSTREAM  (IDIFFERENCE EOFPTR 8)) (* \DWOUT FSTREAM (DIFFERENCE  STARTFORMATPTR STARTPTR)) (* ; "Set file ptr to eof:") (* SETFILEPTR FSTREAM -1) (* ;; "Old way:") (COPYCHARS (OPENSTREAM (COERCETEXTOBJ (CAR (LAST (fetch TIDATA of VAL))) 'FILE) 'INPUT) FSTREAM)) (* ;; "and the separator:") (TERPRI FSTREAM) (PRINT '*start* FSTREAM) (add R# 1) (* ;; "User feedback - print N every 5:") (if (EQ (REMAINDER R# 5) 0) then (PRINTOUT PROMPTWINDOW R# ",")) VAL] (* ;; "Wrap-up:") (PRINT 'STOP FSTREAM) (CLOSEF FSTREAM) (SETQ CALDIRTYREMLST NIL) (* ;; "Make sure the entry for this file knows what rems. are on it so that the next Update of it will work right.:") (PUTPROP (CAR (MEMBER FILE CALFILELST)) 'CONTENTS WRITTENREMS) (SETQ CALREMSLOADED T) (OR (EQ (REMAINDER R# 5) 0) (printout PROMPTWINDOW R# ",")) (printout PROMPTWINDOW " done.")) (RELEASE.MONITORLOCK CALMONLOCK]) (CALUPDATEINIT [LAMBDA NIL (* ; "Edited 24-Oct-88 11:31 by MJD") (* ; "Handles file update preliminaries - getting and checking name, adding to known file list, then calls CALUPDATEFILE.") (PROG (FILE) (SETQ FILE (MENU (create MENU ITEMS _ (APPEND CALFILELST (LIST 'Other 'Abort)) TITLE _ "File to update:"))) (if (OR (NOT FILE) (EQ FILE 'Abort)) then (PRINTOUT PROMPTWINDOW T "Update aborted.") (RETURN NIL)) [if (EQ FILE 'Other) then (SETQ FILE (U-CASE (PROMPTFORWORD "File name:" NIL NIL PROMPTWINDOW))) (if (NOT FILE) then (PRINTOUT PROMPTWINDOW T "No file given - update aborted.") (RETURN NIL)) (* ;; " Now see if he typed in a full file name. If not, make it one, using the value of CALDEFAULTHOST&DIR:") (if (NOT (MEMBER 'HOST (UNPACKFILENAME FILE))) then (SETQ FILE (PACKFILENAME 'NAME FILE 'DIRECTORY (OR CALDEFAULTHOST&DIR (SETQ CALDEFAULTHOST&DIR (U-CASE (PROMPTFORWORD "Please enter a host & directory for the reminders file:" NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL] (* ;; "Apparently, we were passing a string filename to calupdatefile sometimes. This was causing the putprop there to croak. This should fix that:") (SETQ FILE (MKATOM FILE)) (if (AND (NOT (GETPROP (CAR (MEMBER FILE CALFILELST)) 'CONTENTS)) (INFILEP FILE)) then (* ;; "If there's already a file out there with this name but we can't find it in the hash array, it hasn't been loaded - this could be trouble (typo in name, forgot to load, etc.) so warn user:") (if (MOUSECONFIRM (CONCAT FILE " already exists but hasn't been loaded into this Calendar yet." " Should I overwrite it?")) then (CALUPDATEFILE FILE) else (PRINTOUT PROMPTWINDOW T "File not updated.") (RETURN NIL)) else (* ;; "If the file's not on disk, make sure he really wants to create it:") (if (NOT (INFILEP FILE)) then (if (MOUSECONFIRM (CONCAT "Should I create " FILE "?")) then (CALUPDATEFILE FILE) else (PRINTOUT PROMPTWINDOW T "File not updated.") (RETURN NIL)) else (CALUPDATEFILE FILE) (* ; "_ The normal case.")]) (CALYEARICONFN [LAMBDA (W ICON) (* MJD "22-Jun-87 14:40") (if ICON then [ICONW.TITLE ICON (MONTHNAME (WINDOWPROP W 'YEAR#] ICON else [SETQ CALYEARICON (create TITLEDICON ICON _ CALYEARICONMAP TITLEREG _ '(6 26 50 9] (TITLEDICONW CALYEARICON (WINDOWPROP W 'YEAR#) LITTLEFONT]) (CALYEARINRANGE [LAMBDA (YR) (* MJD " 7-Jan-86 12:33"  "Actual range is 3/1/1700 - 2/28/2100") (AND YR (ILESSP YR 2100) (IGREATERP YR 1700]) (CIRCLETODAY [LAMBDA (CALMONTHWINDOW) (* ; "Edited 16-May-90 15:51 by MJD") (* ;; "Put a circle around today. Only do this if: 1: the current month is this month, 2: the current year is this year (don't want circle around 3/12/87 if it's 3/12/86), and 3: today is different from the day already circled.") (PROG ([CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU] (CENTERFACTOR 0.62) RADIUS DAYREGION) (OR CALHILITETODAY (RETURN NIL)) (* ; " Don't if not wanted.") (COND ([AND (NEQ CALCIRCLEDAY (LISPDATEDAY (DATE))) (EQ (WINDOWPROP CALMONTHWINDOW 'MONTH#) (LISPDATEMONTH (DATE))) (EQ (WINDOWPROP CALMONTHWINDOW 'YEAR#) (LISPDATEYEAR (DATE] (TOTOPW CALMONTHWINDOW T) (SETQ DAYREGION (MDMENUITEMREGION CALCIRCLEDAY CALMONTHMENU)) (* ;; "Bug! The following doesn't work for circles on SPARC's:") (DSPOPERATION 'INVERT CALMONTHWINDOW) (* ;; "Can the topfn to avoid loops (drawcircle calls totopw):") (WINDOWPROP CALMONTHWINDOW 'TOTOPFN NIL) (* ; "Erase the old circle, if any") [AND CALCIRCLEDAY (EQ CALCIRCLEMONTH (LISPDATEMONTH (DATE))) (SETQ RADIUS (TIMES (MAXMENUITEMWIDTH CALMONTHMENU) CENTERFACTOR)) (COND ((EQ CALHILITETODAY 'CIRCLE) (DRAWCIRCLE (IPLUS (CAR DAYREGION) RADIUS) (IPLUS (CADR DAYREGION) RADIUS) RADIUS 1 NIL CALMONTHWINDOW)) ((EQ CALHILITETODAY 'BOX) (BITBLT NIL 0 0 CALMONTHWINDOW (CAR DAYREGION) (CADR DAYREGION) (MAXMENUITEMWIDTH CALMONTHMENU) (MAXMENUITEMHEIGHT CALMONTHMENU) 'TEXTURE NIL 32800] (* ;; "Then reset the circle to today, and draw a new circle:") (SETQ CALCIRCLEDAY (LISPDATEDAY (DATE))) (SETQ RADIUS (TIMES (MAXMENUITEMWIDTH CALMONTHMENU) CENTERFACTOR)) (* ; " Figure out the new location:") (SETQ DAYREGION (MDMENUITEMREGION CALCIRCLEDAY CALMONTHMENU)) (COND ((EQ CALHILITETODAY 'CIRCLE) (DRAWCIRCLE (IPLUS (CAR DAYREGION) RADIUS) (IPLUS (CADR DAYREGION) RADIUS) RADIUS 1 NIL CALMONTHWINDOW)) ((EQ CALHILITETODAY 'BOX) (BITBLT NIL 0 0 CALMONTHWINDOW (CAR DAYREGION) (CADR DAYREGION) (PLUS (MAXMENUITEMWIDTH CALMONTHMENU) 4) (PLUS (MAXMENUITEMHEIGHT CALMONTHMENU) 4) 'TEXTURE NIL 32800))) (DSPOPERATION 'REPLACE CALMONTHWINDOW) (WINDOWPROP CALMONTHWINDOW 'TOTOPFN 'CIRCLETODAY) (SETQ CALCIRCLEMONTH (LISPDATEMONTH (DATE]) (CLEARDAY [LAMBDA (D CALMONTHWINDOW CALMONTHMENU) (* MJD "29-Jan-88 12:04") (* ;  "Erase the contents of this day box so it can be rewritten.") (PROG ((DAYREGION (MDMENUITEMREGION D CALMONTHMENU))) (* ;; "Fool CIRCLETODAY into erasing the circle before clearing the box. Then we'll be OK when we redraw the circle. We have to do this since the circle overlaps into the text area and its top part would get lopped off otherwise.") (if (EQ D CALCIRCLEDAY) then (SETQ CALCIRCLEDAY NIL) (CIRCLETODAY CALMONTHWINDOW)) (* ; " Second const. was .08714") (if (IGREATERP (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 100) then (BITBLT NIL NIL NIL CALMONTHWINDOW (CAR DAYREGION) (IPLUS (CADR DAYREGION) (TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 0.053)) (CADDR DAYREGION) (SUB1 (TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 0.0868)) 'TEXTURE 'ERASE BLACKSHADE)) (if (EQ D CALCIRCLEDAY) then (SETQ CALCIRCLEDAY NIL) (CIRCLETODAY CALMONTHWINDOW]) (CLOSEMONTH [LAMBDA (W) (* MJD " 1-Dec-87 17:29") (PROG [(M (WINDOWPROP W 'MONTH#)) (YR (WINDOWPROP W 'YEAR#] [AND (NEQ CALUPDATEONSHRINKFLG 'Never) CALNEEDSUPDATE (ADD.PROCESS '(CALUPDATEINIT] (SETQ CALMONTHLST (REMOVE W CALMONTHLST)) (for B in CALDAYBROWSERS when [AND (EQ M (CAR (TB.USERDATA B))) (EQ YR (CADDR (TB.USERDATA B] do (CLOSEW (TB.WINDOW B]) (DAYABBR [LAMBDA (D SCALE) (* MJD " 7-Aug-87 14:15") (if (GEQ SCALE 0.2) then (CAR (NTH '(Sun Mon Tue Wed Thu Fri Sat % ) (ADD1 D))) else (CAR (NTH '(S M T W T F S % ) (ADD1 D]) (DAYNAME [LAMBDA (D) (* MD " 2-Feb-84 17:15") (CAR (NTH '(Sunday Monday Tuesday Wednesday Thursday Friday Saturday % ) (ADD1 D]) (DAYOF [LAMBDA (M D Y) (* MD " 2-Feb-84 15:39") (PROG (N) (SETQ N (FQUOTIENT (IDIFFERENCE (IPLUS [FIX (FTIMES 365.25 (COND ((IGREATERP M 2) Y) (T (SUB1 Y] [FIX (FTIMES 30.6 (COND ((IGREATERP M 2) (ADD1 M)) (T (IPLUS M 13] D) 621049) 7)) (RETURN (FIX (FPLUS (FTIMES (FDIFFERENCE N (FIX N)) 7) 0.5]) (DAYPLUS [LAMBDA (M D YR N) (* MJD " 4-Jan-88 12:02") (if (ILEQ (IPLUS D N) (DAYSIN M YR)) then (IPLUS D N) else (IDIFFERENCE N (IDIFFERENCE (DAYSIN M YR) D]) (DAYSIN [LAMBDA (M Y) (* ; "Edited 2-Jul-90 09:23 by MJD") (* ;  "Returns number of days in month M of year Y.") (COND ((EQ M 2) (* ;; "K&R put it this way: %"...a year is a leap year if it is divisible by 4 but not by 100, except that years divisible by 400 ARE leap years.%"") (COND ((OR (AND (EQ (IREMAINDER Y 4) 0) (NOT (EQ (IREMAINDER Y 100) 0))) (EQ (IREMAINDER Y 400) 0)) 29) (T 28))) (T (CAR (NTH '(31 NIL 31 30 31 30 31 31 30 31 30 31) M]) (DERIVENEWDATE [LAMBDA (DSTRING ITEMKEY) (* MJD " 6-Jan-88 13:35") (* ; "Previous edit by Sybalsky") (* ;; " Takea a date string for some expired periodic reminder and returns a new date representing the next scheduled firing time for the reminder. ITEMKEY is the rem's. hash key. This is used to tell what kind of periodic rem. it is.") (PROG (M D YR DNEW NEWM NEWDATESTR) (SETQ M (LISPDATEMONTH DSTRING)) (SETQ D (LISPDATEDAY DSTRING)) (SETQ YR (LISPDATEYEAR DSTRING)) (* ;; "Start incrementing the day, month, or year, as appropriate until we create some date in the future from now:") (repeatwhile (LESSP (IDATE NEWDATESTR) (IDATE (DATE))) do (COND ((EQ ITEMKEY 0) (* ; "Daily Item") (SETQ DNEW (DAYPLUS M D YR 1)) (SETQ NEWM (MONTHOFDAYPLUS M D YR 1)) (COND ((ILESSP NEWM M) (* ;  "Ran into a new year when we bumped the month: Up the year.") (ADD YR 1))) (SETQ D DNEW) (SETQ M NEWM)) ((ILESSP ITEMKEY 32) (* ; "Monthly Item") (SETQ NEWM (MONTHPLUS M 1)) (COND ((ILESSP NEWM M) (* ;  "Ran into a new year when we bumped the month: Up the year.") (ADD YR 1))) (SETQ M NEWM)) ((GEQ ITEMKEY 32) (* ; "Weekly Item") (SETQ DNEW (DAYPLUS M D YR 7)) (SETQ NEWM (MONTHOFDAYPLUS M D YR 7)) (SETQ D DNEW) (COND ((ILESSP NEWM M) (* ;  "Ran into a new year when we bumped the month: Up the year.") (ADD YR 1))) (SETQ M NEWM))) (SETQ NEWDATESTR (PACKDATE (GDATE (IDATE DSTRING) (DATEFORMAT NO.DATE)) M D YR))) (RETURN NEWDATESTR]) (DOREMINDER [LAMBDA (REM) (* ; "Edited 14-May-90 14:21 by MJD") (PROG ((*readtable* (FIND-READTABLE "OLD-INTERLISP-T")) (*package* (CL:FIND-PACKAGE "INTERLISP")) RSTREAM RDATESTR MSG MSTARTPOS MSGTEXT ITEM ITEMKEY DNEW R NEWTIMER REMDATE) (* ;; "Sometimes a machine boots with no time set, which makes the time be '31-Dec-00' causing all pending reminders to fire at once. This prevents that - until the year 2000, I guess.") (if (LESSP (IDATE) (IDATE "31-Dec-86 00:00")) then (RETURN NIL)) (pop CALREMINDERS) (* ;  "Get rid of it before CALENDARWATCHER sees it again") (* ;; "REM is an instance of what goes on CALREMINDERS, ie. (timer-integer date-string tableitem-obj). The tableitem-obj has the form (timer-integer date-string tableitem-obj title-string text-stream hashkey). Hashkey is present only if this is a periodic reminder (we need it to figure out when the next firing time will be).") (SETQ RSTREAM (CAR (NTH (GETREMDEF (CAR (NTH REM 3))) 5))) (SETQ RDATESTR (CADR REM)) [if (LISTP RSTREAM) then (EVAL RSTREAM) else (SETQ MSG (COERCETEXTOBJ RSTREAM 'STRINGP)) (SETQ MSTARTPOS (IPLUS (OR (STRPOS (CONCAT (CHARACTER 13) "Message: ") MSG) -9) 9)) (SETFILEPTR RSTREAM MSTARTPOS) (* ;;  " This check is to catch rems. whose message is a lone CR (the READ causes a break otherwise):") (if (IGREATERP (IDIFFERENCE (NCHARS MSG) MSTARTPOS) 1) then (SETQ MSGTEXT (READ RSTREAM *readtable*))) (if (LISTP MSGTEXT) then (EVAL MSGTEXT) else (if (STRING-EQUAL (CL:MACHINE-TYPE) "sparc") then (CLOSEF (CREATE-PROCESS-STREAM (CONCAT "cat " CALTUNE "> /dev/audio"))) else (PLAYTUNE CALTUNE)) (if (EQ CALFLASHTYPE 'SCREEN) then (FLASHWINDOW NIL CALFLASHTIMES)) (TEDIT.SETSEL RSTREAM 1 0) (TEDIT.SHOWSEL RSTREAM NIL) (TEDIT RSTREAM (PROG1 (CREATEW CALREMDISPLAYREGION "Reminder Display Window") (if (EQ CALFLASHTYPE 'WINDOW) then (FLASHWINDOW RSTREAM CALFLASHTIMES))) NIL '(QUITFN T LEAVETTY T SEL DON'T] (* ;  "Let's see if this one is periodic:") (SETQ ITEM (CAR (NTH REM 3))) (SETQ ITEMKEY (CAR (NTH (GETREMDEF (CAR (NTH REM 3))) 6))) [if (AND ITEMKEY (ILEQ ITEMKEY 38)) then (* ;  "Yup, so figure out its next scheduled firing time and put it back on CALREMINDERS") (SETQ REMDATE (DERIVENEWDATE RDATESTR ITEMKEY)) (SETQ NEWTIMER (SETUPTIMER.DATE REMDATE)) (SETQ R (LIST NEWTIMER REMDATE ITEM)) (if CALREMINDERS then (MERGE (LIST R) CALREMINDERS T) else (SETQ CALREMINDERS (LIST R] (if (NOT CALKEEPEXPIREDREMSFLG) then (CALDELETEREM NIL REM]) (FMNWAYITEM [LAMBDA (W ID LABEL) (* MJD "22-Jul-87 12:01") (for I in (WINDOWPROP W 'FM.ITEMS) thereis (AND (EQ (FM.ITEMPROP I 'ID) ID) (EQ (FM.ITEMPROP I 'LABEL) LABEL]) (GETREMDEF [LAMBDA (ITEM) (* MJD "21-May-87 16:49") (if (EQ (TYPENAME (fetch TIDATA of ITEM)) 'TABLEITEM) then (fetch TIDATA of (fetch TIDATA of ITEM)) else (fetch TIDATA of ITEM]) (INVERTGROUP [LAMBDA (M1 D1 YR1 M2 D2 YR2 SHADE CALMONTHMENU) (* MJD " 9-Dec-87 10:54") (AND D2 (for D from D1 to D2 do (SHADEITEM (MENUITEM D CALMONTHMENU) CALMONTHMENU SHADE]) (LISPDATEDAY [LAMBDA (LD) (* MJD "10-Jul-86 12:54") (SUBATOM LD (COND ((STREQUAL (SUBSTRING LD 1 1) " ") 2) (T 1)) 2]) (LISPDATEMONTH [LAMBDA (LD) (* MD "14-Feb-84 15:56") (MONTHNUM (SUBATOM LD 4 6]) (LISPDATEYEAR [LAMBDA (LD) (* MJD "24-Jun-87 10:55") (* Returns the year of a date in Lisp date format.  eg.%: "26-Nov-86 15:30:00") (if (EQ (SUBATOM LD 10 10) '% ) then (IPLUS 1900 (SUBATOM LD 8 9)) else (SUBATOM LD 8 11]) (MDMENUITEMREGION [LAMBDA (ITEM MNAME SCALE) (* MJD "12-Feb-86 16:00") (for I in (fetch ITEMS of MNAME) until (EQ ITEM (CAR I)) do NIL finally (RETURN (if SCALE then (for J in (MENUITEMREGION I MNAME) collect (TIMES J SCALE)) else (MENUITEMREGION I MNAME]) (MENUITEM [LAMBDA (ITEM MNAME) (* MJD "25-Jun-86 12:03") (for I in (fetch ITEMS of MNAME) thereis (EQ ITEM (CAR I]) (MENUREGIONITEM [LAMBDA (W MNAME) (* MJD "22-May-87 13:44") (GETMOUSESTATE) (for I in (fetch ITEMS of MNAME) thereis (INSIDEP (MENUITEMREGION I MNAME) (LASTMOUSEX W) (LASTMOUSEY W]) (MONTHABBR [LAMBDA (M) (* MD "15-Feb-84 12:19") (CAR (NTH '(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) M]) (MONTHNAME [LAMBDA (M) (* MJD "28-Jan-88 16:23") (CAR (NTH '(January February March April May June July August September October November December ) M]) (MONTHNUM [LAMBDA (MNAME) (* MD "14-Feb-84 16:01") (LISTGET '(Jan 1 Feb 2 Mar 3 Apr 4 May 5 Jun 6 Jul 7 Aug 8 Sep 9 Oct 10 Nov 11 Dec 12) MNAME]) (MONTHOFDAYPLUS [LAMBDA (M D YR N) (* MJD "23-Jun-87 16:27") (if (ILEQ (DAYPLUS M D YR N) D) then (MONTHPLUS M 1) else M]) (MONTHPLUS [LAMBDA (M N) (* MD "19-Oct-84 13:57") (COND ((ILEQ (IPLUS M N) 0) (IPLUS M N 12)) ((AND (EQ M 12) (IGREATERP N 0)) 1) (T (IREMAINDER (IPLUS M N) 13]) (MONTHYEARPLUS [LAMBDA (M YR N) (* MD " 5-Nov-84 14:48") (IPLUS YR (IQUOTIENT (IPLUS M N) 13) (if (ILEQ (IPLUS M N) 0) then -1 else 0]) (NEWPARSETIME [LAMBDA (TSTRING) (* MJD " 9-Dec-87 11:07") (* ;;; " This function converts the string TSTRING into an atom doing all the error checking to insure the time is valid. An a.m. or p.m. specifier is allowed as well as time in the 12 or 24 hour format. If the 12 hour format is allowed then the routine tries to deduce what the user meant. The global variable CALDAYSTART is an atom which represents the time that the user's day starts. Typically CALDAYSTART might be set to 900. The user's day when goes from 9:00 am to 8:59 pm. If TSTRING is 1:00 then this means 1:00 p.m. or 13:00. If TSTRING is 9:00 this translates to 9;00 am. If TSTRING is 8:00 this translates to 8:00 pm or 20:00") (LET* ([TempCleanedString (PACK (LDIFFERENCE (UNPACK TSTRING) '(%. %: - % A P M a p m] (CleanedString (if (AND (NOT (STRPOS "." TSTRING 1)) (NOT (STRPOS ":" TSTRING 1)) (NOT (STRPOS "-" TSTRING 1)) (NUMBERP TempCleanedString) (IGEQ TempCleanedString 0) (ILEQ TempCleanedString 23)) then (* ;; "handle the cases where the user says n meaning n:00") (TIMES TempCleanedString 100) else TempCleanedString)) (TwelveHours 1200) (TwentyFourHours (TIMES 2 TwelveHours)) Start End Time NewTime AMBIGUOUSTIMEFLG) (if (NULL TSTRING) then 0 elseif (NOT (NUMBERP CleanedString)) then NIL else (if (OR (STRPOS "A" TSTRING 1) (STRPOS "a" TSTRING 1)) then (* ;; "am specified") (if (AND (IGEQ CleanedString 0) (ILEQ CleanedString 1200)) then CleanedString else (printout PROMPTWINDOW " - time greater than 12:00 plus am doesn't make sense") NIL) elseif (OR (STRPOS "P" TSTRING 1) (STRPOS "p" TSTRING 1)) then (* ;; "pm specified") (if (AND (IGEQ CleanedString 0) (ILEQ CleanedString 1200)) then (IPLUS CleanedString 1200) elseif (AND (IGREATERP CleanedString 1200) (ILEQ CleanedString 2400)) then CleanedString else (printout PROMPTWINDOW " - time greater than 23:59 doesn't make sense") NIL) elseif (AND (IGREATERP CleanedString 1259) (ILEQ CleanedString 2359)) then (* ;; "In 24 hour mode between 12:59 and 23:59") CleanedString elseif (IGEQ CleanedString 2400) then (* ;; " time greater than 23:59") (printout PROMPTWINDOW " - time greater than 23:59 doesn't make sense") NIL else (* ambiguous time) (SETQ AMBIGUOUSTIMEFLG T) (if (OR (NOT (SMALLP CALDAYSTART)) (ILESSP CALDAYSTART 0) (IGREATERP CALDAYSTART 2359)) then (printout PROMPTWINDOW "- invalid variable CALDAYSTART " CALDAYSTART T) NIL else (SETQ Time CleanedString) (SETQ Start CALDAYSTART) (if (EQ Start TwelveHours) then (* Special case when we are starting  at 12%:00) (SETQ End TwentyFourHours) else (SETQ End (IMOD (IPLUS Start TwelveHours) TwentyFourHours))) (SETQ NewTime (IMOD (IPLUS Time TwelveHours) TwentyFourHours)) (if (GREATERP Start TwelveHours) then (if (OR (IGEQ NewTime Start) (ILESSP NewTime End)) then (* the time is the new time) else (SETQ NewTime Time)) else (if (AND (IGEQ NewTime Start) (ILESSP NewTime End)) then (* the time is the new time) else (SETQ NewTime Time))) NewTime]) (NEXTMDISPLAYREGION [LAMBDA (W H) (* MJD " 2-Dec-87 10:34") (* ; " Handles tiling of month windows given the locaiton of the previous one (in CALMONTHLST) if any. Otherwise use defaults.") (PROG (REG WWIDTH WHEIGHT WXLOC WYLOC) (SETQ REG (if CALMONTHLST then (WINDOWPROP (CAR CALMONTHLST) 'REGION) else CALMONTHDEFAULTREGION)) (* ;; " If the month we're keying off is shrunken, find the position of the window itself, not the icon. If this isn't the case, we've got the xloc in REG:") (SETQ WXLOC (if (AND CALMONTHLST (WINDOWPROP (CAR CALMONTHLST) 'ICONFOR)) then (CAR (WINDOWPROP (WINDOWPROP (CAR CALMONTHLST) 'ICONFOR) 'REGION)) else (CAR REG))) (SETQ WYLOC (if (AND CALMONTHLST (WINDOWPROP (CAR CALMONTHLST) 'ICONFOR)) then (CADR (WINDOWPROP (WINDOWPROP (CAR CALMONTHLST) 'ICONFOR) 'REGION)) else (CADR REG))) (SETQ WWIDTH (CADDR REG)) (SETQ WHEIGHT (CADDDR REG)) (RETURN (LIST (if (AND CALMONTHLST (IGREATERP (IPLUS WXLOC WWIDTH W) SCREENWIDTH)) then (CAR CALMONTHDEFAULTREGION) else (if (AND CALMONTHLST (ILEQ (IPLUS WXLOC WWIDTH W) SCREENWIDTH)) then (IPLUS WXLOC WWIDTH 1) else (CAR CALMONTHDEFAULTREGION))) (if (IGREATERP (IPLUS WXLOC WWIDTH W) SCREENWIDTH) then (if (IGREATERP (IPLUS WYLOC WHEIGHT H) SCREENHEIGHT) then (CADR CALMONTHDEFAULTREGION) else (IPLUS WYLOC WHEIGHT 1)) else WYLOC) W H]) (PACKDATE [LAMBDA (MTIME M D YR) (* MJD "15-May-87 09:38") (* Takes a time, M, D, and YR, and packs them into a formatted date which is  returned.) (* If MTIME = 0, then this is an untimed rem., so store NIL in the time field.) (CONCAT (if (IGEQ D 10) then D else (CONCAT " " D)) "-" (MONTHABBR M) "-" (if (IGREATERP YR 1999) then YR else (IDIFFERENCE YR 1900)) " " (if (EQ MTIME 0) then NIL else MTIME]) (PARSETIME [LAMBDA (TSTRING) (* MJD "22-Oct-85 12:06") (COND ([AND TSTRING (NOT (NUMBERP (PACK (LDIFFERENCE (UNPACK TSTRING) '(%. %: - % A P M a p m] NIL) [TSTRING (IPLUS (ITIMES [PACK (LDIFFERENCE (UNPACK TSTRING) '(%. %: - % A P M a p m] (COND ([OR (AND (NUMBERP (MKATOM TSTRING)) (ILEQ (MKATOM TSTRING) 24)) (AND (NOT (NUMBERP (MKATOM TSTRING))) (NOT (MEMBER '%: (UNPACK TSTRING] 100) (T 1))) (COND ((STRPOS "P" TSTRING 1) 1200) ((STRPOS "p" TSTRING 1) 1200) (T 0] (T 0]) (PICKFONTSIZE [LAMBDA (W H) (* MJD " 4-Jan-88 13:45") (PROG ((KEYSIZE (MIN W H))) (RETURN (COND ((LEQ KEYSIZE 40) 8) ((LEQ KEYSIZE 50) 10) ((LEQ KEYSIZE 60) 12) ((LEQ KEYSIZE 70) 14) ((LEQ KEYSIZE 80) 18) ((LEQ KEYSIZE 90) 24) ((LESSP KEYSIZE 100) 30) (T 36]) (POM [LAMBDA (M D YR) (* MD " 4-Apr-84 13:38") (PROG [GOLDEN CENTURY GREGCORRECTION CLAVCORRECTION EXTRADAYS EPACT SECSFROMNEWTHISYEAR SECSTHISMOON DAYINYEAR (SECSPERMIN 60) SECSPERHR SECSPERDAY SECSPERMOON (MONTHTABLE '(0 31 60 91 121 152 182 213 244 274 305 335 366] (SETQ SECSPERHR (ITIMES SECSPERMIN 60)) (SETQ SECSPERDAY (ITIMES SECSPERHR 24)) (SETQ SECSPERMOON (IPLUS (ITIMES SECSPERDAY 29) (ITIMES SECSPERHR 12) (ITIMES SECSPERMIN 44) 3)) (SETQ GOLDEN (ADD1 (IREMAINDER YR 19))) (SETQ CENTURY (ADD1 (IQUOTIENT YR 100))) (SETQ GREGCORRECTION (IDIFFERENCE (IQUOTIENT (ITIMES 3 CENTURY) 4) 12)) (SETQ CLAVCORRECTION (IQUOTIENT (IDIFFERENCE (IDIFFERENCE CENTURY 16) (IQUOTIENT (IDIFFERENCE CENTURY 18) 25)) 3)) (SETQ EXTRADAYS (IDIFFERENCE (IDIFFERENCE (IQUOTIENT (ITIMES 5 YR) 4) GREGCORRECTION) 10)) (SETQ EPACT (ADD1 (IREMAINDER (IPLUS (ITIMES 11 GOLDEN) 19 CLAVCORRECTION (IMINUS GREGCORRECTION)) 30))) (COND ((OR (AND (EQ EPACT 25) (IGREATERP GOLDEN 11)) (EQ EPACT 24)) (add EPACT 1))) (SETQ DAYINYEAR (IPLUS (CAR (NTH MONTHTABLE M)) D)) [COND ((IGREATERP M 2) (COND ((EQ (IREMAINDER YR 4) 0) (COND [(NEQ (IREMAINDER YR 100) 0) (COND ((EQ (IREMAINDER YR 400) 0) (add DAYINYEAR 1] (T (add DAYINYEAR 1] (SETQ SECSFROMNEWTHISYEAR (IPLUS (ITIMES DAYINYEAR SECSPERDAY) (ITIMES EPACT SECSPERDAY))) (SETQ SECSTHISMOON (IREMAINDER SECSFROMNEWTHISYEAR SECSPERMOON)) (RETURN (IQUOTIENT SECSTHISMOON (IQUOTIENT SECSPERMOON 8]) (POMDAYS [LAMBDA (M YR) (* MJD "13-Mar-86 15:47") (* PLIST is list of phase of each day. Then return list of first days of phases  NM, FQ, Full, LQ in that order.) (* The COND is complicated because the first phase may be split between the  beginning and end of the month. Since we want the first day of the phase  (which might not be the first time it appears on the list) we have to check for  this.) (PROG (PLIST) (SETQ PLIST (for D from 1 to (DAYSIN M YR) collect (POM M D YR))) (RETURN (for D in '(0 2 4 6) collect (COND ((EQ D (CAR PLIST)) (if (EQ D (CAR (LAST PLIST))) then [ADD1 (IDIFFERENCE (DAYSIN M YR) (COUNT (MEMBER (CAR PLIST) (NLEFT PLIST 15] else 1)) (T (ADD1 (IDIFFERENCE (DAYSIN M YR) (COUNT (MEMBER D PLIST]) (PRINTMONTH [LAMBDA (W STREAM) (* ; "Edited 21-Aug-90 09:16 by MJD") (* ;; "Prints a month calendar on paper. Fully cut over for IP printers.") (PROG [CALPRINTSTREAM (M (WINDOWPROP W 'MONTH#)) (YR (WINDOWPROP W 'YEAR#] (SETCURSOR WAITINGCURSOR) (PRINTOUT PROMPTWINDOW T "Formatting for print...") (* ;; "First, bag the stupid portrait stream we got sent (thanks, BVM):") (LET ((RESETSTATE 'ERROR)) (DECLARE (SPECVARS RESETSTATE)) (DELFILE (CLOSEF STREAM))) (* ;; "Now open our own landscape stream:") (* ;; "NIL used to be (PACKFILENAME 'VERSION NIL 'BODY (FULLNAME STREAM)):") [SETQ CALPRINTSTREAM (OPENIMAGESTREAM NIL 'INTERPRESS '(LANDSCAPE T] [OR PBIGFONT (SETQ PBIGFONT (FONTCREATE 'HELVETICA 14 NIL 0 'INTERPRESS] [OR PCALFONT (SETQ PCALFONT (FONTCREATE 'TIMESROMAN 24 NIL 0 'INTERPRESS] [OR PLITTLEFONT (SETQ PLITTLEFONT (FONTCREATE 'HELVETICA 8 NIL 0 'INTERPRESS] (DSPFONT PCALFONT CALPRINTSTREAM) [PROG (X Y CT) (SETQ CT 0) (DSPRESET CALPRINTSTREAM) (MOVETO 9500 20400 CALPRINTSTREAM) (PRIN1 (MONTHNAME M) CALPRINTSTREAM) (PRIN1 " " CALPRINTSTREAM) (* ;  "Leaves room for 3-ring binder hole") (PRIN1 YR CALPRINTSTREAM) (SETQ X 550) (SETQ Y 16700) (for I in (APPEND (for N from 1 to (DAYOF M 1 YR) collect '% ) (for N from 1 to (DAYSIN M YR) collect N)) do (MOVETO X Y CALPRINTSTREAM) (PRIN1 I CALPRINTSTREAM) (* ; "Print day numbers") (add X 3750) (add CT 1) (COND ((EQ (IREMAINDER CT 7) 0) (SETQ X 600) (add Y -3166] (for X from 300 to 26800 by 3750 do (DRAWLINE X 600 X 19600 40 'PAINT CALPRINTSTREAM)) (* ; "Print vertical lines") (DSPFONT PBIGFONT CALPRINTSTREAM) (for X from 800 to 25600 by 3750 as D from 0 to 6 do (MOVETO X 19800 CALPRINTSTREAM) (PRIN1 (DAYNAME D) CALPRINTSTREAM)) (* ; "Print day names") (for Y from 600 to 19600 by 3166 do (DRAWLINE 300 Y 26550 Y 40 'PAINT CALPRINTSTREAM)) (* ; "Print horizontal lines") (if CALHARDCOPYPOMFLG then (SHOWMOON M YR 32.0 (CAR (WINDOWPROP W 'MENU)) CALPRINTSTREAM)) (DSPFONT PLITTLEFONT CALPRINTSTREAM) (SHOWMONTHSMALL (MONTHPLUS M -1) (MONTHYEARPLUS M YR -1) 19300 950 28.0 CALPRINTSTREAM) (SHOWMONTHSMALL (MONTHPLUS M 1) (MONTHYEARPLUS M YR 1) 23100 950 28.0 CALPRINTSTREAM) (SHOWREMSINMONTH M YR 1 W (CAR (WINDOWPROP W 'MENU)) CALPRINTSTREAM) (CLOSEF CALPRINTSTREAM) (PRINTOUT PROMPTWINDOW "done." T) (CURSOR T]) (REMINDERSOF [LAMBDA (M D YR) (* ; "Edited 12-Dec-88 16:37 by MJD") (* ; "Returns all rems. for this day.") (* ;; "This day's reminders are the union of one shot rems. explicitly stored on this day; yearlies, keyed by M and D with YR = 1900; weeklies (in the 32-38 range); monthlies, keyed by D; and dailies, keyed by 0 (always applies).") (* ;; "See CALDISPEVENT for period setup.") (SORT (APPEND (GETHASH (CALMAKEKEY M D YR) CALHASH) (GETHASH (CALMAKEKEY M D 1900) CALHASH) (GETHASH (IPLUS (DAYOF M D YR) 32) CALHASH) (GETHASH D CALHASH) (GETHASH 0 CALHASH)) 'REMINDERTIMELT]) (REMINDERTIME [LAMBDA (R) (* MJD "15-May-87 11:16") (if (CAR R) then (MKATOM (GDATE (IDATE (CADR R)) (DATEFORMAT NO.DATE NO.SECONDS]) (REMINDERTIMELT [LAMBDA (R1 R2) (* ; "Edited 19-Jan-89 15:15 by MJD") (* ;; "Returns T if R1's time is earlier than R2 (the AND clause), or if R2 is untimed (the NOT clause). (That has the effect of putting all the untimed's at the end of the list). R1 and R2 are TABLEITEM's. Their TIDATA is a list of the form (timer# date-string tableitem-obj stream-obj).") (OR (NOT (CAR (fetch TIDATA of R2))) (AND (CAR (fetch TIDATA of R1)) (CAR (fetch TIDATA of R2)) (ILESSP (IDATE (CADR (fetch TIDATA of R1))) (IDATE (CADR (fetch TIDATA of R2]) (REMSINMONTH [LAMBDA (M YR) (* MJD "16-May-86 11:57") (for D to (DAYSIN M YR) collect (REMINDERSOF M D YR]) (REPAINTMONTH [LAMBDA (W REG) (* MJD "28-Jan-88 17:27") (DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP W 'WIDTH) (IPLUS (WINDOWPROP W 'HEIGHT) 3)) (WINDOWPROP W 'DSP)) (SHOWMONTH (LIST W (WINDOWPROP W 'MONTH#) (WINDOWPROP W 'YEAR#]) (REPAINTYEAR [LAMBDA (W REG) (* MJD "22-May-87 13:24") (DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP W 'WIDTH) (WINDOWPROP W 'HEIGHT)) (WINDOWPROP W 'DSP)) (SHOWYEAR (LIST (WINDOWPROP W 'YEAR#)) NIL NIL W]) (SAMEDAYAS [LAMBDA (LD M D YR) (* MD "12-Oct-84 14:23") (COND ((AND (EQ (LISPDATEDAY LD) D) (EQ (LISPDATEMONTH LD) M) (OR (EQ (LISPDATEYEAR LD) YR) (EQ (LISPDATEYEAR LD) 2034))) T) (T NIL]) (SAMEMONTHAS [LAMBDA (LD M YR) (* MD "10-May-85 10:50") (AND (EQ (LISPDATEMONTH LD) M) (OR (EQ (LISPDATEYEAR LD) YR) (EQ (LISPDATEYEAR LD) 2034]) (SCALEBITMAP [LAMBDA (BITMAP FACTOR) (* PmT "18-Mar-85 14:34") (* SCALES BITMAPS BY AN ARBITRARY AMOUNT OF 2 DECIMAL PLACES.  FACTOR CAN BE OF THE FOLLOWING FORMS%: I  (AN INTEGER REPRESENTING A PERCENTAGE AMOUNT;  E.G. I=67 MEANS REDUCE THE X AND Y AXIS TO 67% OF THEIR ORIGINAL);  R (A REAL; E.G. R=1.3 MEANS INCREASE THE X AND Y AXIS BY A FACTOR OF 1.3);  (IX . IY) (A DOTTED PAIR OF INTEGERS; E.G.  (75 . 125) MEANS REDUCE THE X AXIS TO 75% OF ORIGINAL;  INCREASE Y TO 125% OF ORIGINAL); (RX . RY)  (A DOTTED PAIR OF REALS; E.G. (2.3 . 0.81) MEANS 2.3 TIMES ORIGINAL X AXIS,  0.81 TIMES ORIGINAL Y)) (PROG (XFACTOR YFACTOR DELTAX DELTAY XROUND YROUND BITMAPWIDTH BITMAPHEIGHT HEIGHT-1 RASTERWIDTH BITMAPBASE NEWBITMAP NEWHEIGHT-1 NEWBITMAPBASE NEWRASTERWIDTH ORIGBASE NEWBASE ORIGWORD NEWWORD XSTART YSTART ENDX ENDY ONLINE) (OR (type? BITMAP BITMAP) (\ILLEGAL.ARG BITMAP)) (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (COND ((NUMBERP FACTOR) (SETQ XFACTOR FACTOR) (SETQ YFACTOR FACTOR)) ((POSITIONP FACTOR) (SETQ XFACTOR (CAR FACTOR)) (SETQ YFACTOR (CDR FACTOR))) (T (\ILLEGAL.ARG FACTOR))) [AND (FLOATP XFACTOR) (SETQ XFACTOR (FIX (FTIMES XFACTOR 100] [AND (FLOATP YFACTOR) (SETQ YFACTOR (FIX (FTIMES YFACTOR 100] (SETQ XFACTOR (IMIN SCREENWIDTH XFACTOR)) (SETQ YFACTOR (IMIN SCREENHEIGHT YFACTOR)) (COND ((ILESSP XFACTOR 101) (SETQ DELTAX 100) (SETQ XROUND (IQUOTIENT XFACTOR 2))) (T (SETQ DELTAX XFACTOR) (SETQ XROUND 50))) (COND ((ILESSP YFACTOR 101) (SETQ DELTAY 100) (SETQ YROUND (IQUOTIENT YFACTOR 2))) (T (SETQ DELTAY YFACTOR) (SETQ YROUND 50))) (SETQ NEWBITMAP (BITMAPCREATE (IQUOTIENT (IPLUS XROUND DELTAX (ITIMES (SUB1 BITMAPWIDTH) XFACTOR)) 100) (IQUOTIENT (IPLUS YROUND DELTAY (ITIMES (SUB1 BITMAPHEIGHT) YFACTOR)) 100) 1)) (* MAKE ALL VALUES QUICKLY AVAILABLE) (SETQ HEIGHT-1 (SUB1 BITMAPHEIGHT)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (* AND THE NEW BITMAP VALUES) (SETQ NEWHEIGHT-1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of NEWBITMAP))) (SETQ NEWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of NEWBITMAP)) (SETQ NEWBITMAPBASE (fetch (BITMAP BITMAPBASE) of NEWBITMAP)) (* OK, CRANK IT OUT) (* ORIGWORD AND NEWWORD ARE SORTA  CACHED FOR SPEED PURPOSES) [for Y from 0 to HEIGHT-1 do [SETQ ORIGBASE (\ADDBASE BITMAPBASE (ITIMES RASTERWIDTH (IDIFFERENCE HEIGHT-1 Y] (SETQ ONLINE NIL) [for X from 0 to (SUB1 BITMAPWIDTH) do [AND (ZEROP (IMOD X 16)) (SETQ ORIGWORD (\GETBASE ORIGBASE (LRSH X 4] (* LOOK FOR STRINGS OF "ON" BITS; THEN TREAT AS A LINE FOR TRANSLATIONAL  PURPOSES) (COND [(BITTEST ORIGWORD (\WORDELT BITMASKARRAY (IMOD X 16))) (OR ONLINE (AND (SETQ ONLINE T) (SETQ XSTART X) (SETQ YSTART Y] ((NULL ONLINE) (* JUST SKIP OVER BLANKS) ) (T (* SPELL THIS ALL OUT SO I CAN SEE WHAT'S GOIN' ON HERE) (SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR)) 100)) (SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR) YROUND DELTAY) 100)) (SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR)) 100)) (SETQ ENDX (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 X) XFACTOR)) 100)) (for NY from YSTART to (SUB1 ENDY) do (SETQ NEWWORD (\GETBASE [SETQ NEWBASE (\ADDBASE NEWBITMAPBASE (ITIMES NEWRASTERWIDTH (IDIFFERENCE NEWHEIGHT-1 NY] (LRSH XSTART 4))) (for NX from XSTART to ENDX do [AND (ZEROP (IMOD NX 16)) (SETQ NEWWORD (\GETBASE NEWBASE (LRSH NX 4] [SETQ NEWWORD (LOGOR NEWWORD (\WORDELT BITMASKARRAY (IMOD NX 16] (AND (ZEROP (IMOD (ADD1 NX) 16)) (\PUTBASE NEWBASE (LRSH NX 4) NEWWORD))) (\PUTBASE NEWBASE (LRSH ENDX 4) NEWWORD)) (SETQ ONLINE NIL] (COND (ONLINE (* GOTTA CLEANUP AFTER THE LAST CASE) (* THIS IN CASE WORKING ON A LINE THAT GOES TO END OF BITMAP) (* GAWD! WHAT A WASTE O SPACE THIS IS. FIX LATER) (SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR)) 100)) (SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR) YROUND DELTAY) 100)) (SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR)) 100)) (SETQ ENDX (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 BITMAPWIDTH) XFACTOR)) 100)) (for NY from YSTART to (SUB1 ENDY) do (SETQ NEWWORD (\GETBASE [SETQ NEWBASE (\ADDBASE NEWBITMAPBASE (ITIMES NEWRASTERWIDTH (IDIFFERENCE NEWHEIGHT-1 NY] (LRSH XSTART 4))) (for NX from XSTART to ENDX do [AND (ZEROP (IMOD NX 16)) (SETQ NEWWORD (\GETBASE NEWBASE (LRSH NX 4] [SETQ NEWWORD (LOGOR NEWWORD (\WORDELT BITMASKARRAY (IMOD NX 16] (AND (ZEROP (IMOD (ADD1 NX) 16)) (\PUTBASE NEWBASE (LRSH NX 4) NEWWORD))) (\PUTBASE NEWBASE (LRSH ENDX 4) NEWWORD] (RETURN NEWBITMAP]) (SHOWDAY [LAMBDA (ITEM MENUNAME BUTTON) (* ; "Edited 19-Jan-89 14:35 by MJD") (* ;; "Handles action for for day-box clicked: bring up browser, show last/next month, show option menu, or do nothing. ITEM format is (day month help-string year '{OPTIONS|NEXT|PREV})") (PROG ((D (CAR ITEM)) (M (CADR ITEM)) (YR (CADDDR ITEM)) [CALMONTHWINDOW (OR (WINDOWP (CAR (LAST ITEM))) (WFROMMENU (OR MENUNAME (CAAR (LAST ITEM] (DFHEIGHT (FONTPROP DEFAULTFONT 'HEIGHT)) DAYBROWSER CALTBITEMS CALDISPMENU CALMONTHMENU CALMONTHSTREAM CALCURMONTH (CALDAYDEFAULTXLOC (CAR CALDAYDEFAULTREGION)) (CALDAYDEFAULTYLOC (CADR CALDAYDEFAULTREGION))) [SETQ CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU] [SETQ CALMONTHSTREAM (CAR (WINDOWPROP CALMONTHWINDOW 'STREAM] [SETQ CALCURMONTH (CAR (WINDOWPROP CALMONTHWINDOW 'MONTH#] (COND ((NOT M) (printout PROMPTWINDOW T "Selecting a day in this month with Left will give you a Day Window.") (RETURN NIL)) ((NOT (CALYEARINRANGE YR)) (RETURN NIL)) ((AND (EQ BUTTON 'MIDDLE) (NEQ D '% )) (* ;  "Middle gets you Add, but only if on a numbered day.") (CALADDEVENT M D YR CALMONTHWINDOW)) ((EQ BUTTON 'RIGHT) (GETMOUSESTATE) (if (INSIDEP (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH) (WINDOWPROP CALMONTHWINDOW 'HEIGHT)) (LASTMOUSEX CALMONTHSTREAM) (LASTMOUSEY CALMONTHSTREAM)) then (CALEXTENDSEL CALMONTHWINDOW) else (DOWINDOWCOM CALMONTHWINDOW)) (RETURN NIL)) ((EQ (CAR (LAST ITEM)) 'OPTIONS) (CALOPTIONMENU) (RETURN NIL)) ((EQ (CAR (LAST ITEM)) 'OUCH) (PRINTOUT PROMPTWINDOW T "Ouch! Stop that!") (RETURN NIL)) ((EQ (CAR (LAST ITEM)) 'PREV) (SHOWMONTH (LIST (if (EQ BUTTON 'LEFT) then CALMONTHWINDOW) (MONTHPLUS M -1) (MONTHYEARPLUS M YR -1))) (RETURN NIL)) ((EQ (CAR (LAST ITEM)) 'NEXT) (SHOWMONTH (LIST (if (EQ BUTTON 'LEFT) then CALMONTHWINDOW) (MONTHPLUS M 1) (MONTHYEARPLUS M YR 1))) (RETURN NIL))) (if [AND BUTTON (NUMBERP (WINDOWPROP CALMONTHWINDOW 'GROUPEND] then (INVERTGROUP M CALCURDAY YR M (WINDOWPROP CALMONTHWINDOW 'GROUPEND) YR WHITESHADE CALMONTHMENU) (WINDOWPROP CALMONTHWINDOW 'GROUPEND NIL)) (if [AND CALMONTHWINDOW (EQ M (WINDOWPROP CALMONTHWINDOW 'MONTH#] then (SHOWREMSINDAY CALMONTHWINDOW M D YR)) (* ;  "Only write in month window if it exists, and is month of this day") (* ;  "You need default locs in case SHOWDAY is called programmatically w/o there being a Month window") [SETQ DAYBROWSER (for B in CALDAYBROWSERS thereis (AND (EQ D (CADR (TB.USERDATA B))) (EQ M (CAR (TB.USERDATA B))) (EQ YR (CADDR (TB.USERDATA B] (if (NOT DAYBROWSER) then [SETQ DAYBROWSER (TB.MAKE.BROWSER NIL (LIST (if CALMONTHMENU then (IDIFFERENCE (CAR (MDMENUITEMREGION D CALMONTHMENU)) (ITIMES (DAYOF M D YR) DFHEIGHT)) else CALDAYDEFAULTXLOC) (IPLUS (if CALMONTHMENU then (CADR (MDMENUITEMREGION D CALMONTHMENU)) else CALDAYDEFAULTYLOC) 180) (CADDR CALDAYDEFAULTREGION) (CADDDR CALDAYDEFAULTREGION)) (LIST 'PRINTFN (FUNCTION CALPRINTREM) 'CLOSEFN (FUNCTION CALTBCLOSEFN) 'COPYFN (FUNCTION CALTBCOPYFN) 'USERDATA (LIST M D YR CALMONTHWINDOW) 'TITLE (CONCAT "Day browser for " (MKSTRING (MONTHNAME M)) " " D ", " (MKSTRING YR] (push CALDAYBROWSERS DAYBROWSER) (SETQ CALTBITEMS (REMINDERSOF M D YR)) (for ITEM in CALTBITEMS do (TB.INSERT.ITEM DAYBROWSER ITEM)) (WINDOWPROP (TB.WINDOW DAYBROWSER) 'TOTOPFN 'CALTBSELECTEDFN) (SETQ CALDISPMENU (create MENU ITEMS _ '((Add CALADD "Add a new message in this day.") (Display CALDISPLAY "Displays the contents of the selected reminder." ) (Delete CALDELETE "The selected messages will be deleted immediately." ) (Update CALUPDATE "Write out all reminder changes to disk file." ) (SendMail CALMAIL "The selected messages will be mailed to the recipients of your choice." ) (Period CALPERIOD "Makes the selected messages periodic." )) MENUROWS _ 1 CENTERFLG _ T WHENSELECTEDFN _ 'CALDISPEVENT)) (PUTMENUPROP CALDISPMENU 'BROWSER DAYBROWSER) (ATTACHMENU CALDISPMENU (TB.WINDOW DAYBROWSER) 'TOP 'LEFT)) (OR (TB.WINDOW DAYBROWSER) (SHOULDNT "Browser window is NIL: please inform author")) (TB.REDISPLAY.ITEMS DAYBROWSER) (AND CALTBITEMS (TB.SELECT.ITEM DAYBROWSER (CAR CALTBITEMS))) (TOTOPW (TB.WINDOW DAYBROWSER)) (RETURN (SETQ CALCURDAY D]) (SHOWMONTH [LAMBDA (ITEM) (* ; "Edited 19-Jan-89 14:36 by MJD") (* ;  "Both displays new and redisplays existing month windows.") (PROG ((CALLTYPE (CAR ITEM)) (M (CADR ITEM)) (YR (CAR (LAST ITEM))) MLOC CALMONTHWINDOW CALMONTHSTREAM CALMONTHMENU TOFFSETX TOFFSETY NMOFFSETX LMOFFSETX LMOFFSETY OOFFSETX OOFFSETY DHEIGHT DOFFSET MOFFSET MWIDTH MHEIGHT FONTUSED TEMP (WWIDTH (CADDR CALMONTHDEFAULTREGION)) (WHEIGHT (CADDDR CALMONTHDEFAULTREGION))) (LET* ((TITLETEXT (CONCAT (MKSTRING (MONTHNAME M)) " " (MKSTRING YR))) (TITLETEXTWITHVERSION (CONCAT TITLETEXT " " CALENDARVERSION))) (if (NOT (CALYEARINRANGE YR)) then (RETURN NIL)) (* ; "Can it be done?") (SETCURSOR WAITINGCURSOR) (SETQ CALMONTHWINDOW (WINDOWP CALLTYPE)) [if (NOT CALMONTHWINDOW) then (* ;; " Magic numbers:") (SETQ MWIDTH (FIX (FQUOTIENT WWIDTH 7.15))) (* ; " Menu item width") (SETQ MHEIGHT (IQUOTIENT WHEIGHT 7)) (* ; " Menu item height") (SETQ MOFFSET (IQUOTIENT WHEIGHT 60)) (* ; " Menu offset w/in window") (SETQ DHEIGHT (FIX (FQUOTIENT WHEIGHT 1.096))) (* ; " Height of day names") (SETQ DOFFSET (FIX (FQUOTIENT WWIDTH 36.1667))) (* ; " Offset in x of day names") (SETQ OOFFSETX (FIX (FQUOTIENT WWIDTH 1.66))) (* ; "Option item offset in x") (SETQ OOFFSETY (FIX (FQUOTIENT WHEIGHT 12.1))) (* ; " Was 12.069") (* ; "Option item offset in y") (SETQ LMOFFSETX (FIX (FQUOTIENT WWIDTH 1.39))) (* ; " Little last mo. x offset") (SETQ LMOFFSETY (FIX (FQUOTIENT WHEIGHT 23.0))) (* ; " Little last mo. y offset") (SETQ NMOFFSETX (FIX (FQUOTIENT WWIDTH 1.165))) (* ; " Little next mo. x offset") (SETQ TOFFSETX (FIX (FQUOTIENT WWIDTH 3.472))) (SETQ TOFFSETY (FIX (FQUOTIENT WHEIGHT 1.045] (* ;; "Do we want to redo an existing month window?") (if CALMONTHWINDOW then (* ;; "Yes, so save the menu and delete it from the window (has the effect of clearing the window. Then the ADDMENU below will redraw the menu items for us.)") [SETQ CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU] (* ;;  "CALMONTHMENU could be NIL (eg. if the window being passed in is newly created):") (AND CALMONTHMENU (DELETEMENU CALMONTHMENU NIL CALMONTHWINDOW)) (* ;;  " If this call is due to a window reshape, we'll have to remake the menu anyway.") (if (OR (NEQ (WINDOWPROP CALMONTHWINDOW 'WIDTH) 868) (NEQ (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 700)) then (SETQ CALMONTHMENU NIL)) (* ;; "If this call is from a Next or Prev, the window passed in ITEM is there only to tell us to reuse this window --- it's month# and menu must be changed.") (if (NEQ (WINDOWPROP CALMONTHWINDOW 'MONTH#) M) then (WINDOWPROP CALMONTHWINDOW 'MONTH# M) (WINDOWPROP CALMONTHWINDOW 'YEAR# YR) (SETQ CALMONTHMENU NIL)) (SETQ WWIDTH (WINDOWPROP CALMONTHWINDOW 'WIDTH)) (SETQ WHEIGHT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)) (SETQ MWIDTH (FIX (FQUOTIENT WWIDTH 7.15))) (SETQ MHEIGHT (IQUOTIENT WHEIGHT 7)) (SETQ MOFFSET (SUB1 (IQUOTIENT WHEIGHT 61))) (* ; " Was 60") (SETQ DHEIGHT (FIX (FQUOTIENT WHEIGHT 1.096))) (SETQ DOFFSET (FIX (FQUOTIENT WWIDTH 36.1667))) (SETQ OOFFSETX (FIX (FQUOTIENT WWIDTH 1.66))) [SETQ OOFFSETY (SUB1 (FIX (FQUOTIENT WHEIGHT 15.0] (* ; " WAS 12.069") (SETQ LMOFFSETX (FIX (FQUOTIENT WWIDTH 1.39))) (SETQ LMOFFSETY (FIX (FQUOTIENT WHEIGHT 23.0))) (SETQ NMOFFSETX (FIX (FQUOTIENT WWIDTH 1.165))) (SETQ TOFFSETX (IQUOTIENT [IMAX 1 (DIFFERENCE (WINDOWPROP CALMONTHWINDOW 'WIDTH) (STRINGWIDTH TITLETEXT (WINDOWPROP CALMONTHWINDOW 'DSP] 2)) (* ;; "(setq toffsetx (iquotient (imax 1 (difference (windowprop calmonthwindow 'width) (stringwidth titletext (windowprop calmonthwindow 'dsp)))) 2))") (* SETQ TOFFSETX (FIX  (FQUOTIENT (WINDOWPROP  CALMONTHWINDOW (QUOTE WIDTH)) 3.472))) (SETQ TOFFSETY (FIX (FQUOTIENT WHEIGHT 1.045))) else (SETQ CALMONTHWINDOW (CREATEW (NEXTMDISPLAYREGION (WIDTHIFWINDOW WWIDTH) (HEIGHTIFWINDOW WHEIGHT T)) TITLETEXTWITHVERSION NIL T)) (WINDOWPROP CALMONTHWINDOW 'HARDCOPYFN 'PRINTMONTH) (WINDOWPROP CALMONTHWINDOW 'CLOSEFN 'CLOSEMONTH) (WINDOWPROP CALMONTHWINDOW 'SHRINKFN 'SHRINKMONTH) (WINDOWPROP CALMONTHWINDOW 'ICONFN 'CALMONTHICONFN) (WINDOWPROP CALMONTHWINDOW 'TOTOPFN 'CIRCLETODAY) (WINDOWPROP CALMONTHWINDOW 'RIGHTBUTTONFN 'CALMONTHRBF) (WINDOWPROP CALMONTHWINDOW 'PROCESS (FIND.PROCESS 'BACKGROUND)) (WINDOWPROP CALMONTHWINDOW 'MINSIZE '(77 . 77)) (WINDOWPROP CALMONTHWINDOW 'BORDER 2) (WINDOWPROP CALMONTHWINDOW 'MONTH# M) (WINDOWPROP CALMONTHWINDOW 'YEAR# YR)) (if (ILEQ WWIDTH 100) then (SETQ TEMPFONT (WINDOWTITLEFONT)) (WINDOWTITLEFONT LITTLEFONT)) (SETQ CALMONTHSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM CALMONTHWINDOW NIL TITLETEXTWITHVERSION)) (WINDOWPROP CALMONTHWINDOW 'TITLE (if (ILESSP (STRINGWIDTH TITLETEXTWITHVERSION DEFAULTFONT) WWIDTH) then TITLETEXTWITHVERSION else TITLETEXT)) (* ; " Month name in title bar.") (CLEARW CALMONTHWINDOW) (WINDOWPROP CALMONTHWINDOW 'GROUPEND NIL) [OR CALMONTHMENU (SETQ CALMONTHMENU (create MENU ITEMS _ [APPEND (for I from 1 to (DAYOF M 1 YR) collect (LIST '% '% "Does nothing.")) (for I from 1 to (DAYSIN M YR) collect (LIST I M "Left opens a day browser; middle adds a reminder" YR)) (for I from 1 to (IDIFFERENCE 38 (IPLUS (DAYOF M 1 YR) (DAYSIN M YR))) collect (LIST '% '% "Does nothing.")) (LIST (LIST '% M " " YR 'OUCH)) (LIST (LIST '% M "Opens a menu for setting options." YR 'OPTIONS)) (LIST (LIST '% M "Left shows last month in this window; middle creates a new window." YR 'PREV)) (LIST (LIST '% M "Left shows next month in this window; middle creates a new window." YR 'NEXT] MENUCOLUMNS _ 7 MENUFONT _ (FONTCREATE 'TIMESROMAN (PICKFONTSIZE MWIDTH MHEIGHT)) ITEMHEIGHT _ (MAX MHEIGHT 10) ITEMWIDTH _ (MAX MWIDTH 10) MENUBORDERSIZE _ (if (GEQ WWIDTH 100) then 1 else 0) MENUOUTLINESIZE _ (if (GEQ WWIDTH 100) then 1 else 0) WHENSELECTEDFN _ 'SHOWDAY] (ADDMENU CALMONTHMENU CALMONTHWINDOW (CONS MOFFSET MOFFSET)) (WINDOWPROP CALMONTHWINDOW 'RESHAPEFN 'REPAINTMONTH) (WINDOWPROP CALMONTHWINDOW 'REPAINTFN 'REPAINTMONTH) (WINDOWPROP CALMONTHWINDOW 'SCROLLFN NIL) (WINDOWPROP CALMONTHWINDOW 'BUTTONEVENTFN 'CALMONTHBEF) (* ;  "WINDOWPROP CALMONTHWINDOW (QUOTE BUTTONEVENTFN) (QUOTE CALMONTHBEF)") (* ;; " Trailing blanks help erase previous name if this mo. is a display in an existing window (but this causes wrap-around problems with small month window sizes):") (* ;; "FIX: Just simply clear the window, as done above. andyiii") (DSPFONT (SETQ FONTUSED (FONTCREATE 'TIMESROMAN (PICKFONTSIZE MWIDTH MHEIGHT))) CALMONTHSTREAM) (SETQ TOFFSETX (IQUOTIENT (IMAX 1 (DIFFERENCE (WINDOWPROP CALMONTHWINDOW 'WIDTH) (STRINGWIDTH TITLETEXT FONTUSED))) 2)) (if (GEQ (IPLUS TOFFSETY 6) (IPLUS DHEIGHT (FONTHEIGHT FONTUSED))) then (* ; " Big month name at top") (MOVETO TOFFSETX TOFFSETY CALMONTHSTREAM) (PRIN3 TITLETEXT CALMONTHSTREAM) (* ;;  "Can't use this 'cause we have to use PRIN3 to fix the %"split text%" bug:") (* CENTERPRINTINREGION TITLETEXT  (CREATEREGION 0 TOFFSETY WWIDTH  (FONTHEIGHT FONTUSED))  CALMONTHSTREAM) ) (* ;; "Pick font for day names across the top:") (DSPFONT (SETQ FONTUSED (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH) 700) 0.6) then BIGFONT else (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH) 700) 0.4) then DEFAULTFONT else LITTLEFONT))) CALMONTHWINDOW) (* ;; "(|if| (geq toffsety (iplus dheight (fontheight fontused))) |then| (moveto toffsetx toffsety calmonthstream) (printout calmonthstream titletext))") (if (GEQ WHEIGHT 100) then (for X from MOFFSET to WWIDTH by MWIDTH as D from 0 to 6 do (* ; " Day names across the top:") (MOVETO (IPLUS X DOFFSET) DHEIGHT CALMONTHSTREAM) (PRIN1 (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH) 868) 0.7) then (DAYNAME D) else (DAYABBR D (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH) 868))) CALMONTHSTREAM))) (if (GEQ (WINDOWPROP CALMONTHWINDOW 'WIDTH) 175) then (SHOWMOON M YR 1 CALMONTHMENU CALMONTHWINDOW)) (* ; "Phases of moon") (DSPFONT (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 700) 0.6) then DEFAULTFONT else LITTLEFONT) CALMONTHWINDOW) (MOVETO OOFFSETX OOFFSETY CALMONTHSTREAM) (PRINTOUT CALMONTHSTREAM (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH) 868) 0.6) then "Options" else (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH) 868) 0.2) then "Opt" else "O"))) (DSPFONT LITTLEFONT CALMONTHWINDOW) (if (GEQ WHEIGHT 150) then (SHOWREMSINMONTH M YR 1 CALMONTHWINDOW CALMONTHMENU CALMONTHSTREAM)) [for DELTA in '(-1 1) as MOFFSETX in (LIST LMOFFSETX NMOFFSETX) do (* ; "Little last month") (if (GEQ (FQUOTIENT WHEIGHT 700) 0.9) then (SHOWMONTHSMALL (MONTHPLUS M DELTA) (MONTHYEARPLUS M YR DELTA) MOFFSETX LMOFFSETY 1 CALMONTHWINDOW) else (MOVETO MOFFSETX OOFFSETY CALMONTHSTREAM) (PRINTOUT CALMONTHSTREAM (SUBSTRING (MONTHNAME (MONTHPLUS M DELTA)) [SETQ TEMP (STRPOSL '(J F M A S O N D) (MONTHNAME (MONTHPLUS M DELTA] (if (GEQ (FQUOTIENT WWIDTH 868) 0.6) then NIL else (if (GEQ (FQUOTIENT WWIDTH 868) 0.2) then (IPLUS TEMP 2) else (IPLUS TEMP 0] (* ; "Little next month") (DSPFONT (FONTCREATE 'TIMESROMAN (PICKFONTSIZE MWIDTH MHEIGHT)) CALMONTHWINDOW) (SETQ CALCIRCLEDAY NIL) (CIRCLETODAY CALMONTHWINDOW) (pushnew CALMONTHLST CALMONTHWINDOW) (if (ILEQ WWIDTH 100) then (WINDOWTITLEFONT TEMPFONT)) (CURSOR T) (RETURN M]) (SHOWMONTHSMALL [LAMBDA (M YR XLOC YLOC SCALE WINDOW) (* MJD " 2-Feb-88 13:09") (PROG [(CT 0) (X XLOC) (Y (IPLUS YLOC (TIMES 48 SCALE] (MOVETO (IPLUS X (TIMES SCALE 24)) (IPLUS Y (TIMES SCALE 12)) WINDOW) (PRIN1 (if (OR (NEQ (IMAGESTREAMTYPE WINDOW) 'DISPLAY) (GEQ (WINDOWPROP WINDOW 'WIDTH) 280)) then (MONTHNAME M) else (MONTHABBR M)) WINDOW) (for I in (APPEND (for N from 1 to (DAYOF M 1 YR) collect '% ) (for N from 1 to (DAYSIN M YR) collect N)) do (MOVETO X Y WINDOW) (PRIN1 I WINDOW) (add X (TIMES SCALE 16)) (add CT 1) (COND ((EQ (IREMAINDER CT 7) 0) (SETQ X XLOC) (add Y (TIMES SCALE -10]) (SHOWMOON [LAMBDA (M YR SCALE CALMONTHMENU STREAM) (* ; "Edited 20-Aug-90 15:39 by MJD") (* ; " SCALE here is 1 for screen res. Other than that, it's obsolete - should be removed. Currently only supports IP for hardcopy.") (* ;; "The month window is 23550 x 18996 in 300 spi. landscape printer coordinates. Each day is 3750 x 3166. The origin is a 600,300. (The printer clause contains magic numbers that should be parameterized - sometime.)") (* ;; "Show each moon making sure they have the proper sense (depends on backgorund color).") (for P in (POMDAYS M YR) as PMAP in (if (AND (EQ (IMAGESTREAMTYPE STREAM) 'DISPLAY) (VIDEOCOLOR)) then '(NMMAP FQMAP FMMAP LQMAP) else '(FMMAP LQMAP NMMAP FQMAP)) do (if (EQ (IMAGESTREAMTYPE STREAM) 'INTERPRESS) then (* ;; "Print on paper: the first factor in the PLUS corrects for window offset on the page; the second factor adjusts position within the day box.") (\MOVETO.IP STREAM (PLUS (TIMES (DAYOF M P YR) 3750) 600 1500) (PLUS (TIMES (IDIFFERENCE 5 (WEEKOF M P YR)) 3166) 300 500)) (SHOWBITMAP.IP STREAM (EVAL PMAP) NIL 0.5) (* ; "Thanks, Dinh!") else (* ;; "Write to display:") (BITBLT (if (GEQ (MIN (WINDOWPROP STREAM 'WIDTH) (WINDOWPROP STREAM 'HEIGHT)) 600) then (EVAL PMAP) else (SCALEBITMAP (EVAL PMAP) (FQUOTIENT (MIN (WINDOWPROP STREAM 'WIDTH) (WINDOWPROP STREAM 'HEIGHT)) 900))) NIL NIL STREAM (IPLUS (CAR (MDMENUITEMREGION P CALMONTHMENU SCALE)) (FQUOTIENT (WINDOWPROP STREAM 'WIDTH) 16.6)) (IPLUS (CADR (MDMENUITEMREGION P CALMONTHMENU SCALE)) (FQUOTIENT (WINDOWPROP STREAM 'HEIGHT) 350.0)) 34 34 'INPUT 'INVERT]) (SHOWREMSINDAY [LAMBDA (CALMONTHWINDOW M D YR) (* MJD "10-Aug-87 13:35") (* ;; "This code is similar to SHOWREMSINMONTH except that it is optimized for picking out the reminders for only one particular day, rather than all reminders in a month. Changes here may need to be done to SHOWREMSINMONTH also.") (PROG [(CALMONTHSTREAM (WINDOWPROP CALMONTHWINDOW 'DSP)) [CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU] (NREMS (FIX (TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 0.01] (CLEARDAY D CALMONTHWINDOW CALMONTHMENU) (DSPFONT LITTLEFONT CALMONTHWINDOW) (MOVETOUPPERLEFT CALMONTHSTREAM (MDMENUITEMREGION D CALMONTHMENU)) (DSPYPOSITION (IDIFFERENCE (DSPYPOSITION NIL CALMONTHSTREAM) 2) CALMONTHSTREAM) (SETQ DAYREGION (MDMENUITEMREGION D CALMONTHMENU)) (DSPCLIPPINGREGION DAYREGION CALMONTHSTREAM) (for REMINDER in (REMINDERSOF M D YR) as I to NREMS do (DSPXPOSITION (CAR (MDMENUITEMREGION D CALMONTHMENU)) CALMONTHSTREAM) (CALPRINTREM NIL REMINDER CALMONTHSTREAM)) (DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH) (WINDOWPROP CALMONTHWINDOW 'HEIGHT)) CALMONTHSTREAM]) (SHOWREMSINMONTH [LAMBDA (M YR SCALE CALMONTHWINDOW CALMONTHMENU STREAM)(* ; "Edited 20-Aug-90 16:05 by MJD") (* ;; "Handles printing of all reminders in a month both for screen and on paper. Changes here may need to be done to SHOWREMSINDAY also.") (* ;; "SCALE is now obsolete (8/20/90).") (PROG [D REMLIST DAYREGION NREMS (TOSCREEN (EQ (IMAGESTREAMTYPE STREAM) 'DISPLAY] (SETQ REMLIST (REMSINMONTH M YR)) (* ;; "Set the max. number of rems. to show in each day:") (SETQ NREMS (if TOSCREEN then (FIX (TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT) 0.01)) else 8)) (for REMINDER in REMLIST as D to (DAYSIN M YR) when REMINDER do (SETQ DAYREGION (if TOSCREEN then (MDMENUITEMREGION D CALMONTHMENU SCALE) else (LIST (PLUS (TIMES (DAYOF M D YR) 3750) 600) (PLUS (TIMES (IDIFFERENCE 5 (WEEKOF M D YR)) 3166) 300) 3750 3166))) (MOVETOUPPERLEFT STREAM DAYREGION) (* ;; "Provide a little clearance off the top edge:") (DSPYPOSITION (IDIFFERENCE (DSPYPOSITION NIL STREAM) 2) STREAM) (DSPCLIPPINGREGION DAYREGION STREAM) (for R in REMINDER as I to NREMS do (DSPXPOSITION (CAR DAYREGION) STREAM) (CALPRINTREM NIL R STREAM))) (if TOSCREEN then (DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH) (WINDOWPROP CALMONTHWINDOW 'HEIGHT)) STREAM]) (SHOWYEAR [LAMBDA (ITEM MNAME BUTTON CALYEARWINDOW) (* MJD "22-Jan-88 16:52") (PROG ((YR (CAR ITEM)) (CALLTYPE (LENGTH ITEM)) (MHEIGHT 70) MLOC CALYEARSTREAM CALYEARMENU) [if (EQ YR 'Other) then (TERPRI PROMPTWINDOW) (SETQ YR (MKATOM (PROMPTFORWORD "Year: " NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL] (COND [(CALYEARINRANGE YR) (if CALYEARWINDOW then (CLEARW CALYEARWINDOW) else [SETQ CALYEARWINDOW (CREATEW (if (NEQ CALLTYPE 1) then (PROGN (SETQ MLOC (GETBOXPOSITION 364 324 NIL NIL NIL "Please position the Year Window.")) (create REGION LEFT _ (CAR MLOC) BOTTOM _ (CDR MLOC) WIDTH _ 364 HEIGHT _ 324)) else '(32 400 364 324)) (CONCAT CALENDARVERSION " " (MKSTRING YR] [SETQ CALYEARSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM CALYEARWINDOW NIL (CONCAT CALENDARVERSION " " (MKSTRING YR] (WINDOWPROP CALYEARWINDOW 'ICON CALYEARICON) (WINDOWPROP CALYEARWINDOW 'ICONFN 'CALYEARICONFN) (WINDOWPROP CALYEARWINDOW 'YEAR# YR) (ATTACHMENU CALMAINMENU CALYEARWINDOW 'RIGHT 'TOP)) (SETQ CALYEARMENU (create MENU ITEMS _ (for I from 1 to 12 collect (LIST '% I YR)) MENUCOLUMNS _ 3 ITEMHEIGHT _ (IPLUS MHEIGHT 2) ITEMWIDTH _ 118 WHENSELECTEDFN _ 'SHOWMONTH)) (ADDMENU CALYEARMENU CALYEARWINDOW '(0 . 0)) (WINDOWPROP CALYEARWINDOW 'RESHAPEFN 'DON'T) (WINDOWPROP CALYEARWINDOW 'REPAINTFN 'REPAINTYEAR) (WINDOWPROP CALYEARWINDOW 'SCROLLFN NIL) (DSPFONT DEFAULTFONT CALYEARWINDOW) (MOVETO 157 294 CALYEARSTREAM) (PRIN1 YR CALYEARSTREAM) (DSPFONT LITTLEFONT CALYEARWINDOW) (for Y from 0 to 3 do (for X from 0 to 2 do (SHOWMONTHSMALL (IPLUS (ADD1 X) (ITIMES Y 3)) YR (IPLUS (ITIMES X 120) 4) (IPLUS (ITIMES (IDIFFERENCE 3 Y) MHEIGHT) 8) 1 CALYEARWINDOW] (T (printout PROMPTWINDOW T "Sorry - I can only handle years between 1700 and 2100."]) (SHRINKMONTH [LAMBDA (X) (* MJD "20-Jul-87 14:10") [AND (EQ CALUPDATEONSHRINKFLG 'Shrink) CALNEEDSUPDATE (ADD.PROCESS '(CALUPDATEINIT] (OR CALMONTHICON (SETQ CALMONTHICON (create TITLEDICON ICON _ CALMONTHICONMAP TITLEREG _ '(3 51 56 9]) (SHRINKYEAR [LAMBDA (X) (* MJD "19-Jun-87 12:09") [OR (WINDOWPROP CALYEARWINDOW 'ICONPOSITION) (WINDOWPROP CALYEARWINDOW 'ICONPOSITION (GETBOXPOSITION (BITMAPWIDTH CALYEARICON) (BITMAPHEIGHT CALYEARICON] (OR CALYEARICON (SETQ CALYEARICON (create TITLEDICON ICON _ CALYEARICONMAP TITLEREG _ '(6 26 50 9]) (TIMEDREMP [LAMBDA (REM) (* MJD "30-Jun-87 16:15") (CAR REM]) (TPLUS [LAMBDA (TIME MINS) (* ; "Edited 16-Dec-88 11:36 by MJD") (* ;; "Adds a time number and minute number, returning a time number. E.g. 1300 + -10 = 1250. The %"1987%" is just to make PACKDATE happy - the date itself is ignored.") (PACK (LDIFFERENCE (UNPACK (GDATE (PLUS (IDATE (PACKDATE TIME 7 1 1987)) (TIMES MINS 60)) (DATEFORMAT NO.DATE NO.SECONDS))) '(%:]) (WEEKOF [LAMBDA (M D YR) (* ; "Edited 20-Aug-90 14:49 by MJD") (* ;; "First week of month is number 0.") (IQUOTIENT (IPLUS (SUB1 D) (DAYOF M 1 YR)) 7]) (YNCONVERT [LAMBDA (X) (* MJD "22-Jul-87 12:07") (if X then 'Yes else 'No]) ) (RPAQQ CALDAYICON #*(64 64)OOOOOOOOOOOOOOOOOANOGLCGFAOGHOOONOMGGMOCGFNKKGOONOKKGLGCGFMMKGOONOHCGMOEGFLAHOOONOKKGMOEGFMMJGOOOAKK@LCFFAMMKGOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AHOOOOOOOOOOO@@@AHOOOOOOOOOOOH@@AHOOOOOOOOOOOL@@AHOOOOOOOOOOON@@AHMOOOOOOOOOOO@@AHMOOOOOOOOOOOH@AHMGOOOOOOOOOOL@AHMD@@@@@@@@@@L@AHMD@AL@@@CH@@D@AHMD@CN@@@GL@@D@AHMD@CN@@@GL@@D@AHMD@CN@@@GL@@D@AHMD@AL@@@CH@@D@AHMD@@@@@@@@@@D@AHMD@@@@@@@@@@D@AHMD@@@@@@@@@@D@AHMD@@@@B@AH@CD@AHMEOL@@G@AL@CD@AHMEON@@MH@L@FD@AHMDFG@AHL@F@FD@AHMDFCHC@F@F@LD@AHMDFAHB@F@CAHD@AHMDFAHF@C@CAHD@AHMDFAHL@CHAK@D@AHMDFAHL@AH@O@D@AHMDFAHL@AH@N@D@AHMDFAHL@AH@F@D@AHMDFAHL@AH@F@D@AHMDFAHOOOH@F@D@AHMDFAHOOOH@F@D@AHMDFAHOOOH@F@D@AHMDFAHL@AH@F@D@AHMDFAHL@AH@F@D@AHMDFAHL@AH@F@D@AHMDFCHL@AH@F@D@AHMEOO@L@AH@F@D@AHMEOL@L@AH@F@D@AHMD@@@@@@@@@@D@AHMD@@@@@@@@@@F@AHMD@@@@@@@@@@B@AHMD@@@@@@@@@@C@AHMD@@@@@@@@@@AHAHMD@@@@@@@@@@@LAHMB@@@@@@@@@@@FAHMA@@@@@@@@@@@LAHMA@@@@@@@@@@AHAHM@H@@@@@@@@@C@AHM@L@@@@@@@@ON@AHE@GOOOOOOOO@D@AHG@@@@@@@@@@@D@AHC@@@@@@@@@@@D@AHAOOOOOOOOOOOL@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOO ) (RPAQQ CALMONTHICONMAP #*(64 64)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AHG@HHOHDDCN@O@NAHD@MHB@ED@H@H@HAHG@JHB@ED@H@N@NAHA@JHB@CH@H@H@BAHG@HHB@BH@H@H@NAH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AH@D@B@AB@KHELBJAH@D@B@AB@HHDDBJAH@D@B@AB@IHELBOAH@D@B@AB@J@DDBBAH@D@B@AB@KHELBBAH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AKHELBNAG@KHEGBJAJ@E@BBAE@JHEEBJAKHELBBAG@KHEEBJAHHEDBBAE@HHEEBJAKHELBBAG@HHEGBJAH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AJNEGBJIELJNEGBKIJBEABJIE@JHEABJIJNEGBKMELJNEABKIJHEABHIDDJJEABJIJNEGBHIELJNEABKIH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AJNEKJNIFLKGEJJMMJJDJJBIBDIADJJEAJNEJJNIFLKGEKJMMJBEBJHIDHJAE@JHEJBEKJNIFLKGEHJMMH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AKGEKJMMFNKGD@B@AIDDHJEMBNIED@B@AJGE@JIEDBIED@B@AKGEHJMMFBKGD@B@AH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOO ) (RPAQQ CALYEARICONMAP #*(64 64)OOOOOOOOOOOOOOOOOANOGLCGFAOGHOHANOMGGMOCGFNKKGMENOKKGLGCGFMMKGMENOHCGMOEGFLAHOOMNOKKGMOEGFMMJGLAOAKK@LCFFAMMKGMMOOOOOOOOOOOOOOLAH@@@@H@@@@D@@@GOHCOOHHGOO@D@GN@AH@@@@H@@@@D@@@@AHEEEDH@BJHD@@EDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHED@@HJJ@@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOOH@@@@H@@@@D@@@@AH@OL@H@GH@D@CN@AH@@@@H@@@@D@@@@AHEEEDH@JJHD@@ADAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHE@@@HJJH@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOOH@@@@H@@@@D@@@@AH@GL@HAON@DCOOHAH@@@@H@@@@D@@@@AHEEEDH@BJHD@@@DAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHED@@HJJJ@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOOH@@@@H@@@@D@@@@AHCOO@HGOO@DCOOHAH@@@@H@@@@D@@@@AHAEEDH@@JHD@@@DAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAJ@@@@H@@@@D@@@@AKEEEDHJJJHDEEEDAJ@@@@H@@@@D@@@@AHEE@@HJJJ@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOO ) (RPAQQ FQMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OLGOL@@@@@@AN@GON@@@@@@GH@GOOH@@@@@O@@GOOL@@@@@L@@GOOL@@@@AL@@GOON@@@@CH@@GOOO@@@@C@@@GOOO@@@@G@@@GOOOH@@@F@@@GOOOH@@@F@@@GOOOH@@@N@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@N@@@GOOOL@@@F@@@GOOOH@@@F@@@GOOOH@@@G@@@GOOOH@@@C@@@GOOO@@@@CH@@GOOO@@@@AL@@GOON@@@@@L@@GOOL@@@@@O@@GOOL@@@@@GH@GOOH@@@@@AN@GON@@@@@@@OLGOL@@@@@@@COOO@@@@@@@@@GOH@@@@@@ ) (RPAQQ FMMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OOOOL@@@@@@AOOOON@@@@@@GOOOOOH@@@@@OOOOOOL@@@@@OOOOOOL@@@@AOOOOOON@@@@COOOOOOO@@@@COOOOOOO@@@@GOOOOOOOH@@@GOOOOOOOH@@@GOOOOOOOH@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@GOOOOOOOH@@@GOOOOOOOH@@@GOOOOOOOH@@@GOOOOOOO@@@@COOOOOOO@@@@AOOOOOON@@@@@OOOOOOL@@@@@OOOOOOL@@@@@GOOOOOH@@@@@AOOOON@@@@@@@OOOOL@@@@@@@COOO@@@@@@@@@GOH@@@@@@ ) (RPAQQ LQMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OOHOL@@@@@@AOOHAN@@@@@@GOOH@GH@@@@@OOOH@CL@@@@@OOOH@@L@@@@AOOOH@@N@@@@COOOH@@G@@@@COOOH@@C@@@@GOOOH@@CH@@@GOOOH@@AH@@@GOOOH@@AH@@@OOOOH@@AL@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@AL@@@GOOOH@@AH@@@GOOOH@@AH@@@GOOOH@@CH@@@COOOH@@C@@@@COOOH@@G@@@@AOOOH@@N@@@@@OOOH@@L@@@@@OOOH@CL@@@@@GOOH@GH@@@@@AOOHAN@@@@@@@OOHOL@@@@@@@COOO@@@@@@@@@GOH@@@@@@ ) (RPAQQ NMMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OL@OL@@@@@@AN@@AN@@@@@@GH@@@GH@@@@@O@@@@CL@@@@@L@@@@@L@@@@AL@@@@@N@@@@CH@@@@@G@@@@C@@@@@@C@@@@G@@@@@@CH@@@F@@@@@@AH@@@F@@@@@@AH@@@N@@@@@@AL@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@N@@@@@@AL@@@F@@@@@@AH@@@F@@@@@@AH@@@G@@@@@@CH@@@C@@@@@@C@@@@CH@@@@@G@@@@AL@@@@@N@@@@@L@@@@@L@@@@@O@@@@CL@@@@@GH@@@GH@@@@@AN@@AN@@@@@@@OL@OL@@@@@@@COOO@@@@@@@@@GOH@@@@@@ ) (FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) FREEMENU TABLEBROWSER) (PUTPROPS CALENDAR COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10435 169896 (CALADDEVENT 10445 . 17549) (CALCREATEREM 17551 . 20144) (CALDELETEREM 20146 . 23056) (CALDISPEVENT 23058 . 31241) (CALDOOPTIONS 31243 . 33026) (CALENDAR 33028 . 36102) ( CALENDARWATCHER 36104 . 36381) (CALEXTENDSEL 36383 . 38331) (CALLOADFILE 38333 . 48175) (CALMAKEKEY 48177 . 48378) (CALMONTHBEF 48380 . 49473) (CALMONTHICONFN 49475 . 49982) (CALMONTHRBF 49984 . 50776) (CALOPTIONMENU 50778 . 53033) (CALPEEKNEWMAIL 53035 . 56226) (CALPRINTREM 56228 . 57846) (CALREMDEF 57848 . 58089) (CALTBCLOSEFN 58091 . 58493) (CALTBCOPYFN 58495 . 60863) (CALTBNULLFN 60865 . 61091) ( CALTBSELECTEDFN 61093 . 61490) (CALTEDITEXIT 61492 . 61785) (CALTEDITSTRING 61787 . 65215) ( CALUPDATEFILE 65217 . 72172) (CALUPDATEINIT 72174 . 75543) (CALYEARICONFN 75545 . 76028) ( CALYEARINRANGE 76030 . 76304) (CIRCLETODAY 76306 . 79783) (CLEARDAY 79785 . 81308) (CLOSEMONTH 81310 . 81879) (DAYABBR 81881 . 82143) (DAYNAME 82145 . 82338) (DAYOF 82340 . 83372) (DAYPLUS 83374 . 83671 ) (DAYSIN 83673 . 84505) (DERIVENEWDATE 84507 . 88246) (DOREMINDER 88248 . 92582) (FMNWAYITEM 92584 . 92985) (GETREMDEF 92987 . 93299) (INVERTGROUP 93301 . 93569) (LISPDATEDAY 93571 . 93849) ( LISPDATEMONTH 93851 . 93999) (LISPDATEYEAR 94001 . 94365) (MDMENUITEMREGION 94367 . 94831) (MENUITEM 94833 . 95024) (MENUREGIONITEM 95026 . 95394) (MONTHABBR 95396 . 95573) (MONTHNAME 95575 . 95814) ( MONTHNUM 95816 . 96022) (MONTHOFDAYPLUS 96024 . 96252) (MONTHPLUS 96254 . 96559) (MONTHYEARPLUS 96561 . 96849) (NEWPARSETIME 96851 . 102502) (NEXTMDISPLAYREGION 102504 . 105075) (PACKDATE 105077 . 105792 ) (PARSETIME 105794 . 106921) (PICKFONTSIZE 106923 . 107577) (POM 107579 . 110233) (POMDAYS 110235 . 111576) (PRINTMONTH 111578 . 115444) (REMINDERSOF 115446 . 116364) (REMINDERTIME 116366 . 116608) ( REMINDERTIMELT 116610 . 117309) (REMSINMONTH 117311 . 117500) (REPAINTMONTH 117502 . 117904) ( REPAINTYEAR 117906 . 118236) (SAMEDAYAS 118238 . 118641) (SAMEMONTHAS 118643 . 118928) (SCALEBITMAP 118930 . 127982) (SHOWDAY 127984 . 136230) (SHOWMONTH 136232 . 156310) (SHOWMONTHSMALL 156312 . 157448 ) (SHOWMOON 157450 . 160389) (SHOWREMSINDAY 160391 . 161881) (SHOWREMSINMONTH 161883 . 164333) ( SHOWYEAR 164335 . 167849) (SHRINKMONTH 167851 . 168277) (SHRINKYEAR 168279 . 168808) (TIMEDREMP 168810 . 168934) (TPLUS 168936 . 169470) (WEEKOF 169472 . 169726) (YNCONVERT 169728 . 169894))))) STOP \ No newline at end of file diff --git a/lispusers/CALENDAR.TEDIT b/lispusers/CALENDAR.TEDIT new file mode 100644 index 00000000..3aca2d98 --- /dev/null +++ b/lispusers/CALENDAR.TEDIT @@ -0,0 +1,19 @@ +enˇvĹos CALENDAR 2 4 1 CALENDAR 1 4 By: Michel Denber (Denber.WBST @ Xerox.COM) Uses: TABLEBROWSER, TEDIT INTRODUCTION CALENDAR is a program which can be used to display a calendar on your screen, and keep track and remind you of events and appointments. Calendar 2.04 (the current distributed version) runs in the Koto or Lyric releases of Lisp. The version number appears in the title bar of each Calendar window. Calendar needs the Lisp Library package TABLEBROWSER, which it loads automatically. It also uses TEdit. Various font sizes (from 8 to 36) in the families TimesRoman and Helvetica may be needed, depending on the size chosen for month windows. Reminder files created by earlier versions of Calendar are incompatible with this version. I. STARTING CALENDAR Load CALENDAR.LCOM from your favorite LispUsers directory, eg. LOAD ({ERIS}CALENDAR.LCOM] and then type (CALENDAR). You will get a menu of years (the menu always shows five years starting with last year). If you select a year with Left, it will create a Year window containing a calendar for that year. Each month in the Year window is also a menu item. If you now select a particular month with Left, CALENDAR will create a Month window showing a calendar for that month. You can now select a particular day within the month to bring up a Day browser (described in the next section). The Month window also shows small calendars of last month and next month. You can bring up those months in the current month window by selecting them with Left. If you select them with Middle, the program will create a new window for that month. The Year menu has an entry labelled ``Other". If you select this, it will prompt you to type in a year, if you want one that isn't on the menu. You can have as many year and month windows open at the same time as you like. Month and day windows can also be reshaped to occupy less room on the screen. You can Shrink any of the CALENDAR windows to an appropriate icon, or close them when they are not needed. The reminder facility remains active. If you close your last year window, call (CALENDAR) again to get a new one. CALENDAR uses the Lisp Prompt Window to display informative messages. Please send your comments, suggestions, and bug reports to me - Denber.WBST (ARPA: Denber.WBST@Xerox.COM). Thanks. II. REMINDERS The Day Browser Clicking Left in any day in a month window will open a browser on that day. The browser displays each reminder for the day, along with its event time if it is a timed reminder. You may have more than one browser open at the same time. When you close a month window, it will automatically close all day browsers for that month. There is a menu across the top of the browser with the following items: Add: Lets you create a new reminder in this day. If you select Add, the program will bring up a TEdit window containing a template for the new reminder. The template contains several fields you can select and fill in. These are described in Creating Reminders, below. Display: Brings up the full contents of the reminder in a TEdit window. Delete: Useful for deleting reminders that you no longer need. By default, timed reminders are deleted automatically after they "fire"; untimed reminders do not fire and are never deleted automatically. Calendar will immediately remove reminders which you delete from the month window (and the reminder's line in the day browser is crossed out), however it will leave reminders that have fired visible in the month window until you redisplay it (eg. September is visible, you select Redisplay from the right-button menu in the title bar or select September again in the Year window, and all fired September reminders will be purged from the month window when it redraws). Update: Saves your reminders to disk (see the section on Saving reminders below). Send Mail: Prompts you for a name to send to. The selected reminder will be mailed to that person when it activates, rather than displaying on your screen. Note that no validity checking is done when you enter a name, so your message could conceivably not be delivered if you typed the name wrong, for example. The message is mailed when the time arrives. Of course, this assumes that your system is running at that time, that you have Lafite active, and that Lafite is running in the mode (GV or NS) corresponding to your intended recipients. Period: Brings up a menu with the choices Daily, Weekly, Monthly. The selected reminder will be made periodic and will appear at the selected intervals. Creating Reminders You can create a new reminder either by clicking Add in a day browser, or by clicking the middle button in a day box in the month window. This opens a new reminder form with the following fields: Title: The reminder title should not exceed one line in length. This field will be displayed in the Day browser and the month window. This field may not be omitted; all others are optional. Event time: The scheduled time for the event. By default, this is also the time at which the reminder will be activated. If this field is omitted, the reminder is "untimed". Untimed reminders do not alert you. When a timed reminder activates, it beeps and brings up a TEdit window containing the full reminder text. Alert time: The time at which you would like the reminder to activate. You might want to be reminded of a meeting 10 minutes early, for example. The alert time can be set to any time, before or after the event time, as long as it is in the same day. If this field is omitted, it defaults to the value of the event time. Alert: Edit this field to contain just the word Yes or No. If you choose No, the reminder will not alert you, even if it is a timed reminder. If this field is omitted, it defaults to the value set in the Options menu (see Programming below). Duration: The expected length of the event. Version 2.04 makes no use of this field. Message: The actual message you want to save. This may be any TEdit text or omitted entirely. The new reminder form includes a menu with the choices Save and Abort. After filling in the fields you want, clicking Save will add the reminder to the system and close the form. Clicking Abort at any point cancels the reminder being created. The time can be entered in almost any reasonable format, eg. 9:00 AM, 9 AM, 9 a.m., 2:30 PM, 2:30 P.M., 1430, or can be left out by skipping over the field. Times are "AM" by default, so if you only type 8:30, it will assume 8:30 AM. A heuristic is included to ask "Are you sure?" if you type a time earlier than 9 without an AM/PM qualifier (this value is controlled by CALDAYSTART, see Programming, below). Times of noon and midnight are special cases. There is no generally accepted meaning for the expressions "12:00 AM" and "12:00 PM". If you want a reminder at noon, enter the time as "12:00" or just "1200". Because reminders are added to a particular day, midnight is ambiguous; there is no provision for entering a time of midnight. If you add a reminder for a time that is already in the past (for example, to keep a historical record of an event after the fact), the program will save the reminder but will warn you that the reminder time has already passed. Expired timed reminders are automatically deleted upon expiration by default. Setting the variable CALKEEPEXPIREDREMS (see Programming, below) will cause timed reminders to be retained after firing. Reminders which are scheduled for a time when your machine is not running will not be activated the next time you login. This avoids having a possibly long sequence of "dead" reminders popping up at login time. Saving and loading reminders You can save your reminders in a file at any point. The first time tou start Calendar , it will ask you to provide a default host and directory for reminder files. You should enter this in the usual format, for example {DSK} or {ERIS}LISP>. This will become the new value of CALDEFAULTHOST&DIR (it is initially NIL). To save your reminders, select Update from any day browser. This will open a pop-up menu of currently loaded files, plus an "other" item for giving a new file name. If you enter a new name, all currently unsaved reminders will be stored under that name. If you select an existing file, the contents of that file will be updated and any new reminders created since the last update will be added to it. If you abandon your sysout or if your machine crashes, you can have Calendar automatically reload your reminders file when you restart (see CALDEFAULTHOST&DIR and CALLOADFILE in Programming, below). You can also load a reminder file at any time by holding the middle button down in the title bar of a month window. This will open a pop-up menu of files that have already been loaded, plus an "other" item to specify a new file. In this version of Calendar there is never any need to load a reminder file more than once. The menu is useful, however, to show which files have already been loaded. An "almanac" reminder file is distributed along with Calendar. It contains a variety of holidays and notable dates for the year. The file is called CALMANACnn, where nn is the last two digits of the year. For example, the file for 1986 is called CALMANAC86. You can load this file by selecting Other from the middle button menu and typing CALMANAC86. By default, the program will only save your reminders when you select Update. You may control file updating by changing the Auto File Update option available under the Options menu item in the month window. See Programming, below. III. PROGRAMMING A programmatic interface is provided to let you create day, month, or year windows from your own programs. If your reminder text is a Lisp list (anything inside parentheses), when the reminder fires the program will evaluate the list rather than displaying the reminder in a window and beeping. Functions (CALENDAR m d yr) [Function] m, d, and yr are integers specifying a month, day, and year, respectively. Arguments are specified as follows: If only yr (must be 4 digits) is supplied, brings up a year window for that year and returns yr. If m and yr are supplied, brings up a month window for that month and returns m. If m, d, and yr are supplied, brings up a day window for that day and returns d. For invalid combinations (missing yr, d and yr only), returns NIL. Also returns NIL if yr is out of range (the calendar algorithm is only valid for years between 1700 and 2100). Examples: (CALENDAR NIL NIL 1984) shows a calendar for 1984 and returns 1984. (CALENDAR 10 NIL 1984) shows a calendar for October 1984 and returns 10. (CALENDAR 10 NIL 84) returns NIL (out of range). (CALENDAR 10 21 1984) shows October 21st, 1984 and returns 21. You can also call Calendar with the keywords TODAY, THISMONTH, and THISYEAR. Examples: (CALENDAR 'THISYEAR) shows a Year window for 1986, if this year is 1986. This might be used in an init file, to always start a Calendar of "this year". (CALENDAR 'TODAY) opens a Day browser for today, containing all of today's active reminders. (CALLOADFILE file-name) [Function] Loads the file file-name into the reminder system and returns T. Returns NIL if the file is not found or is not a valid reminder file. Example: (CALLOADFILE '{DSK}CALREMINDERS) Variables CALALERTFLG [Variable] Initially T. This controls whether or not reminders whose Alert field is not specified should alert you when they fire. T means they will. NIL means they won't. CALDAYDEFAULTREGION [Variable] Initially (32 200 350 100). This specifies the default size for day browsers. The location is only used for day browsers opened programatically. CALDAYSTART [Variable] Initially 900. This represents the time (in 24 hour format) at which your regular day starts. The system will use it to confirm times you enter without a "PM" indicator if they are less than this value. For example, it is more likely that 4 means 4 PM than 4 AM. CALDEFAULTALERTDELTA [Variable] Initially 0. This represents the time (in minutes) before or efater the event time you want reminders to be activated, if no explicit alert time was given for them. To be reminded before the event, make this value negative. The resulting time must still be in the same day as the event. CALDEFAULTHOST&DIR [Variable] Initially NIL. This is the host and directory on which your reminder files will be saved if you type the file name without a directory specification. The system will prompt you to enter a value for this the first time you start it. CALFLASHTIMES [Variable] Initially 0. Specifies the number of times to flash the destination given by CALFLASHTYPE when a reminder is activated. CALFLASHTYPE [Variable] Initially 'None. Specifies which window should be flashed when a reminder is activated. Can be set to 'WINDOW, to flash the reminder display window, or 'SCREEN to flash the entire screen. CALFLASHTIMES (above) should be set to the desired number of flashes. CALFONT [Variable] Initially 'TimesRoman36. This variable controls the font used to display the Month Window. You can change it for example, by saying (SETQ CALFONT (FONTCREATE 'HELVETICA 18)). The change takes effect the next time you display a month. If you reshape a month window, the program will try to find a smaller font to fit the new window size, but the value of CALFONT will not be changed. CALHARDCOPYPOMFLG [Variable] Initially T. This variable controls the printing of the phase-of-the-moon icons when you hardcopy a month window. Setting it to NIL suppresses this printing. Month windows are hardcopied at printer resolution in Koto, screen resolution in Lyric. CALHILITETODAY [Variable] Initially 'CIRCLE. This variable determines how today's date will be highlighted in a month window. The default is to draw a circle cround it. If you set this to 'BOX, a light gray grid will be placed over the date. Setting this to NIL suppresses all date highlighting. CALKEEPEXPIREDREMSFLG [Variable] Initially NIL. If you set this to T, Calendar will not automatically delete reminders when they fire (they can still be deleted using the Delete menu command, above). The default action is to delete reminders when they fire, although they will remain visible until the window is redisplayed. CALMONTHDEFAULTREGION [Variable] Initially (32 32 868 700). This specifies the default position and size for month windows. If you set the size to a value small enough to allow several month windows side by side, the windows will tile left to right, bottom to top. CALREMDISPLAYREGION [Variable] Initially (200 400 300 400). This specifies the default position and size for reminder display windows. CALTUNE [Variable] When a reminder is activated, it will play the tune stored here (in PLAYTUNE format).This is initially a two-note "ding-dong". Set this to NIL if you want no audible warning. 1100's and 1132's have no hardware for sound. CALUPDATEONSHRINKFLG [Variable] Initially 'Never. This means that Calendar will save your reminders on a file only when you explicitly click Update from a Day Browser. If set to 'Shrink, it will cause Calendar to save your reminder file automatically only when you shrink the Month window. This is useful when you are entering many reminders at the same time, but it means you must remember to explicitly shrink the month window or your reminders will be lost if your machine dies. If set to 'Always, causes Calendar to immediately save each reminder as soon as it is created. You can also set these variables interactively by clicking on the box marked "Options" in any Month window. This brings up a freemenu similar to the TEdit expanded menu. l˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţüń˙˙÷˙˙ř˙˙÷˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţűżý˙˙÷˙˙÷ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţű¸ý㧗?÷iĂǎž?˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţű˙}ݛgěß÷fď÷vmß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţűř}Áťw ˙÷nď÷vî˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţűˇ}ßťví˙÷nď÷vďż˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţűˇ}Ýťfí˙÷fí÷víß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţüx}㻗 ˙řéó÷Žî?˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţŔŔŔŔ˙˙řÁ ť˙řˆÌť˙řČÌóď˜×ČŕĆ͛f×včŠĆÍűď8ŠÇ̓ďؙĚm›ďvč™Ěló˜ďˆŕŔ˙˙řŔ˙˙řŔ˙˙řŔŔŔŔ˙˙đĚŔ€w˙đ̀€w˙đĎ>ćo›çóĎxđ0Ż0‘ŔÎ Ůł3ĚŰlفśl͐0ŽíĐR ĎßłńŒŰف‡ěÍŔŢpR ͌3ŒŰ † ĚpŢ˙°2 ĚĚŮł3ĚŰ Ů†lÍ30ŢíĐ2 Ěg>ćo›ƒĚÍă0ß0ŔŔ0 ˙˙đŔ0 ˙˙đŔ0 ˙˙đŔŔŔŔ€˙˙˙˙ćÁ°pˆ€ť˙˙˙ćÀ 00(H€›˙˙˙ćÌß<}łŔfřůÇĎ(ÄGKX›Žî:fĆĚĚf1ś`f͘c˜($H€ ™d ŤvíŮŚĆĚĚf1ˇŕf͙ă€DQäFˆDŔŤ\ćÇĚĚf1śf͛c|R"HD ł]űćĚlĚf`1ś`f͛c˜D˘"ˆ€HDłw˝ŰćĚgÇ<`1łŔ>řůńĎDĄáˆDˆťž;ćŔŔ˙˙˙˙ćŔŔ˙˙˙˙ćŔŔ˙˙˙˙ćŔŔŔŔÁ Ì`€Ìóď€ůćůĂ €Ć͛f›6`c +€ĆÍű›öaŕ +€Ç̓›c` €Ěm››6cc€Ěló€ůć9óŔŔŔŔŔŔŔ`Ŕ`Ě`€`"Ï@řâĚ`0@‘$!„H@Ěg|@o€‘(A„H@€ĎěŮ0€3m€Œ8ƒž@đŔ@ĚlÜ0°3l‚$ €@€ @ĚlÇ0ŕ3l‘$A„H@€ĚlÓ0`3l€‘"!„H@Ěgž°l€"ńÈ|řâŔŔŔ`ŔŔŔŔŔÁ0À0ϟ63ĆĚŮś3ĆĚŮłcÇĚŮą@ĚlŮąĂĚoŸ0ƒŔ €Ŕ Ŕ ŔŔ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ Alert: Specifies the default for the Alert field in the new reminder form. Sets the value of CALALERTFLG (described above). Keep expired rems.: If set to No, the system will automatically delete reminders when they fire (although they remain listed in the month window until the next time you redisplay it). Sets the value of CALKEEPEXPIREDREMSFLG. Auto. file update: Always means that the system will update the reminder file every time you create a new reminder. Shrink means update only when a month window is shrunken. Never means updates will be done only when you explicitly select Update from a Day browser. Sets the value of CALDUPDATEONSHRINKFLG. Alert delta: Sets the value of CALDEFAULTALERTDELTA. Host & dir.: Sets the value of CALDEFAULTHOST&DIR . After you have made the selections you want, click Apply! This sets the selections and closes the menu. If you don't want to make any changes, just close the menu (like closing any window). This preserves the previous settings even if you changed them in the menu. Any changes you make to these variables are not saved automatically in reminder files. IV. LIMITATIONS Day groups must begin and end in the same month. The calendar algorithm is valid only for years between 1700 and 2100. V. KNOWN BUGS Today-circling function occasionally fails to erase the old day. VI. FUTURE PLANS Automatic scheduling. Automatic communication with other Calendars. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 27) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) ,3ČČT-ČT,Č3ČČT2ČČ,ŠŠ8,Č ,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD CLASSICCLASSICCLASSICMODERN +MODERN +MODERN MODERN +MODERN HELVETICA +    HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN + + HRULE.GETFNMODERN + HRULE.GETFNMODERN + -  } ?&Čt“@›K +“Ĺş 6 8đ MWőíäČÔDcęlź +  paQQł +EJ4@M +›^   p .   ¤ “   + # ę y   „ ů  ' ę i  ß (Ťd BMOBJ.GETFN3MODERN +wĎ$ * (d1FA.QÎ/zş \ No newline at end of file diff --git a/lispusers/CANVASCONVERTER.TEDIT b/lispusers/CANVASCONVERTER.TEDIT new file mode 100644 index 00000000..0531f003 Binary files /dev/null and b/lispusers/CANVASCONVERTER.TEDIT differ diff --git a/lispusers/CD b/lispusers/CD new file mode 100644 index 00000000..5f914245 --- /dev/null +++ b/lispusers/CD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 6-Jul-88 11:51:18" {IVY}LISP>UTIL>CD.;8 18509 changes to%: (VARS CDCOMS) (FNS CDFun) previous date%: "14-Dec-87 15:41:38" {ERINYES}LYRIC>LISPUSERS>CD.;2) (* " Copyright (c) 1984, 1985, 1986, 1987, 1988 by Henry Thompson, Dept. of Artificial Intelligence, Univ. of Edinburgh. All rights reserved. ") (PRETTYCOMPRINT CDCOMS) (RPAQQ CDCOMS ((FNS CDFun CDSepr CDName ChangeDir ReshowConn ShowCDMenu COPYBUTTONDOWN?) (INITVARS [LocalDiskVolume (COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (FILENAMEFIELD (DIRECTORYNAME '{DSK}) 'DIRECTORY] (CD.DEFAULT.HOST 'DSK) (CD.DEFAULT.PREFIX LocalDiskVolume) [CD.DEFAULT.USER (LET [(pos (STRPOS "." (USERNAME] (COND [pos (PACK* (SUBSTRING (USERNAME) 1 (DIFFERENCE pos 1] (T (USERNAME] (CD.DEFAULT.LEFT) (CD.DEFAULT.BOTTOM) (CDMenuItems) (LOGINHOST/DIR (CDName)) (CONNWINDOW) (CDMenu) (CDCommandMenu)) (ADDVARS (LISPXCOMS CD) [AFTERSYSOUTFORMS (SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume (COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (FILENAMEFIELD (DIRECTORYNAME '{DSK}) 'DIRECTORY] (POSTGREETFORMS [SETQ CD.DEFAULT.USER (LET [(pos (STRPOS "." (USERNAME] (COND [pos (PACK* (SUBSTRING (USERNAME) 1 (DIFFERENCE pos 1] (T (USERNAME] [SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume (COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (FILENAMEFIELD (DIRECTORYNAME '{DSK}) 'DIRECTORY] (SETQ LOGINHOST/DIR (CDName))) (CD.OS.SEPRS (DSK . >) (UNIX . /) (VMS . /) (NS . >) (IFS . >)) (CDCommandMenuItems (Connect (CDFun $dir$) "Connect to the directory") (Browse (APPLY* (FUNCTION FB) $dir$) "Bring up a file browser on the directory") (Delete (PROGN (SETQ CDMenu NIL) (SETQ CDMenuItems (DREMOVE $dir$ CDMenuItems))) "Remove the directory from the CD menu"))) (ADVISE CNDIR DIRECTORYNAME) (LISPXMACROS CD) (COMMANDS "CD") [P ([LAMBDA (new) (COND ((FMEMB new CDMenuItems) CDMenuItems) (T (SETQ CDMenuItems (CONS new CDMenuItems] (PACK* (DIRECTORYNAME '{DSK}] (PROP MAKEFILE-ENVIRONMENT CD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.DEFAULT.HOST CD.DEFAULT.PREFIX CD.OS.SEPRS LocalDiskVolume CD.DEFAULT.USER CD.DEFAULT.LEFT CD.DEFAULT.BOTTOM CONNWINDOW CDMenu CDMenuItems CDCommandMenuItems CDCommandMenu)))) (DEFINEQ (CDFun [LAMBDA (d) (* ; "Edited 6-Jul-88 11:49 by ht:") (if d then [LET* ((target (DIRECTORYNAME T)) (host (FILENAMEFIELD target 'HOST)) (dir (FILENAMEFIELD target 'DIRECTORY)) (sep (CDSepr host))) (SELECTQ (NTHCHAR d 1) ({ (ChangeDir d)) (< [if (AND (EQ (NCHARS d) 2) (EQ (NTHCHAR d 1) '<)) then (* ;; "this hack here for common lisp readtables which reject ..") [bind (prev _ 0) this while (SETQ this (STRPOS sep dir (PLUS prev 1))) do (SETQ prev this) finally (ChangeDir (PACKFILENAME 'HOST host 'DIRECTORY (SUBSTRING dir 1 (IMAX (IDIFFERENCE prev 1) 0) dir] else (ChangeDir (CDName (SUBSTRING d 2) (FILENAMEFIELD (DIRECTORYNAME T) 'HOST]) (bind dp first (SETQ dp (MKSTRING d)) while (IGREATERP (NCHARS dp) 0) do (if (EQ (NTHCHAR dp 1) '%.) then (GNC dp) [if (EQ (NTHCHAR dp 1) '%.) then (GNC dp) (bind (prev _ 0) this while (SETQ this (STRPOS sep dir (PLUS prev 1))) do (SETQ prev this) finally (SETQ dir (SUBSTRING dir 1 (IMAX (IDIFFERENCE prev 1) 0) dir] else (SETQ dir (PACK* dir sep dp)) (GO $$OUT)) (if (OR (EQ (NTHCHAR dp 1) sep) (EQ (NTHCHAR dp 1) '>)) then (GNC dp)) finally (RETURN (ChangeDir (PACKFILENAME 'HOST host 'DIRECTORY dir] else (ChangeDir (CDName]) (CDSepr [LAMBDA (host) (* ht%: "19-Mar-86 09:34") (OR (CDR (ASSOC host CD.OS.SEPRS)) (CDR (ASSOC (GETOSTYPE host) CD.OS.SEPRS)) '>]) (CDName [LAMBDA (dir host) (* drc%: " 1-Jun-86 16:17") (if (NOT host) then (SETQ host CD.DEFAULT.HOST)) (if [AND (NOT dir) (FMEMB (MACHINETYPE) '(DANDELION DOVE] then (SETQ dir CD.DEFAULT.USER)) (PACKFILENAME 'HOST host 'DIRECTORY (if [AND CD.DEFAULT.PREFIX (NOT (AND (FMEMB (MACHINETYPE) '(DANDELION DOVE)) (EQ CD.DEFAULT.PREFIX LocalDiskVolume) (NEQ host 'DSK] then (PACK* CD.DEFAULT.PREFIX (CDSepr host) dir) else dir]) (ChangeDir [LAMBDA (dir) (* ht%: " 8-SEP-82 20:05") (CONS (DIRECTORYNAME T) (/CNDIR dir]) (ReshowConn [LAMBDA NIL (* ht%: "30-Apr-85 17:33") (PROG ((DN (DIRECTORYNAME T)) (TTYREG (WINDOWPROP \TopLevelTtyWindow 'REGION)) REG FONT) (if (NOT (WINDOWP CONNWINDOW)) then (SETQ CONNWINDOW (CREATEW (SETQ REG (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 10 HEIGHT _ 10)) NIL NIL T)) (WINDOWPROP CONNWINDOW 'BUTTONEVENTFN (FUNCTION ShowCDMenu)) (if (SETQ FONT (FONTCREATE 'HELVETICA 8 NIL NIL 'DISPLAY T)) then (DSPFONT FONT CONNWINDOW)) (replace HEIGHT of REG with (HEIGHTIFWINDOW (- (DSPLINEFEED NIL CONNWINDOW)) NIL NIL)) (SHAPEW CONNWINDOW REG)) (if (ACTIVEWP CONNWINDOW) then (CLOSEW CONNWINDOW)) [SETQ REG (APPEND (WINDOWPROP CONNWINDOW 'REGION] (replace LEFT of REG with (OR CD.DEFAULT.LEFT (fetch LEFT of TTYREG))) (replace BOTTOM of REG with (OR CD.DEFAULT.BOTTOM (fetch TOP of TTYREG))) (replace WIDTH of REG with (WIDTHIFWINDOW (STRINGWIDTH DN CONNWINDOW) NIL)) (SHAPEW CONNWINDOW REG) (DSPRESET CONNWINDOW) (OPENW CONNWINDOW) (PRIN3 DN CONNWINDOW]) (ShowCDMenu [LAMBDA (cw) (* ht%: " 3-Apr-86 12:07") (LET [(copyFlg (COPYBUTTONDOWN?)) (mv (MENU (OR CDMenu (create MENU ITEMS _ CDMenuItems MENUFONT _ (FONTCREATE 'HELVETICA 8 NIL NIL 'DISPLAY T) WHENSELECTEDFN _ (FUNCTION (LAMBDA (item menu key vals) (CONS key item] (if mv then (if copyFlg then [if (COPYBUTTONDOWN?) then (if (NLSETQ (while (COPYBUTTONDOWN?) do (BLOCK))) then (BKSYSBUF (CDR mv] else (SELECTQ (CAR mv) (LEFT (CDFun (CDR mv))) ((MIDDLE RIGHT) (PROMPTPRINT "Choose action for directory " (CDR mv)) [LET (($dir$ (CDR mv))) (DECLARE (SPECVARS $dir$)) (MENU (OR CDCommandMenu (create MENU ITEMS _ CDCommandMenuItems]) (SHOULDNT]) (COPYBUTTONDOWN? [LAMBDA NIL (* ht%: "19-Mar-86 09:37") (SHIFTDOWNP 'SHIFT]) ) (RPAQ? LocalDiskVolume [COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (FILENAMEFIELD (DIRECTORYNAME '{DSK}) 'DIRECTORY]) (RPAQ? CD.DEFAULT.HOST 'DSK) (RPAQ? CD.DEFAULT.PREFIX LocalDiskVolume) (RPAQ? CD.DEFAULT.USER [LET [(pos (STRPOS "." (USERNAME] (COND [pos (PACK* (SUBSTRING (USERNAME) 1 (DIFFERENCE pos 1] (T (USERNAME]) (RPAQ? CD.DEFAULT.LEFT ) (RPAQ? CD.DEFAULT.BOTTOM ) (RPAQ? CDMenuItems ) (RPAQ? LOGINHOST/DIR (CDName)) (RPAQ? CONNWINDOW ) (RPAQ? CDMenu ) (RPAQ? CDCommandMenu ) (ADDTOVAR LISPXCOMS CD) (ADDTOVAR AFTERSYSOUTFORMS [SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume (COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (FILENAMEFIELD (DIRECTORYNAME '{DSK}) 'DIRECTORY]) (ADDTOVAR POSTGREETFORMS [SETQ CD.DEFAULT.USER (LET [(pos (STRPOS "." (USERNAME] (COND [pos (PACK* (SUBSTRING (USERNAME) 1 (DIFFERENCE pos 1] (T (USERNAME] [SETQ CD.DEFAULT.PREFIX (SETQ LocalDiskVolume (COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (FILENAMEFIELD (DIRECTORYNAME '{DSK}) 'DIRECTORY] (SETQ LOGINHOST/DIR (CDName))) (ADDTOVAR CD.OS.SEPRS (DSK . >) (UNIX . /) (VMS . /) (NS . >) (IFS . >)) (ADDTOVAR CDCommandMenuItems (Connect (CDFun $dir$) "Connect to the directory") (Browse (APPLY* (FUNCTION FB) $dir$) "Bring up a file browser on the directory") (Delete (PROGN (SETQ CDMenu NIL) (SETQ CDMenuItems (DREMOVE $dir$ CDMenuItems))) "Remove the directory from the CD menu")) [XCL:REINSTALL-ADVICE 'CNDIR :AROUND '((:LAST (PROG ((val (NLSETQ *))) (ReshowConn) (RETURN (if val then (if (NOT (FMEMB (CAR val) CDMenuItems)) then (push CDMenuItems (CAR val)) (SETQ CDMenu NIL)) (CAR val) else (ERROR!] [XCL:REINSTALL-ADVICE 'DIRECTORYNAME :AFTER '((:LAST (COND ([AND (EQ 'DSK (FILENAMEFIELD !VALUE 'HOST)) (NOT (FMEMB (NTHCHAR !VALUE -1) '(> }] (SETQ !VALUE (PACK* !VALUE ">"] (READVISE CNDIR DIRECTORYNAME) (ADDTOVAR LISPXMACROS (CD (CDFun (CAR LISPXLINE)))) (ADDTOVAR LISPXCOMS CD) (DEFCOMMAND ("CD" :EVAL) (&OPTIONAL XCL-USER::DIR-SPEC) "un*x style directory changing, e.g. cd foo (use << for ..)" (LET ((XCL-USER::DS XCL-USER::DIR-SPEC)) (CDFun (CL:IF (EQ XCL-USER::DS 'XCL-USER::<<) 'XCL-USER::|..| XCL-USER::DS)))) [[LAMBDA (new) (COND ((FMEMB new CDMenuItems) CDMenuItems) (T (SETQ CDMenuItems (CONS new CDMenuItems] (PACK* (DIRECTORYNAME '{DSK}] (PUTPROPS CD MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.DEFAULT.HOST CD.DEFAULT.PREFIX CD.OS.SEPRS LocalDiskVolume CD.DEFAULT.USER CD.DEFAULT.LEFT CD.DEFAULT.BOTTOM CONNWINDOW CDMenu CDMenuItems CDCommandMenuItems CDCommandMenu) ) ) (PUTPROPS CD COPYRIGHT ("Henry Thompson, Dept. of Artificial Intelligence, Univ. of Edinburgh" 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5118 13308 (CDFun 5128 . 8719) (CDSepr 8721 . 8951) (CDName 8953 . 9897) (ChangeDir 9899 . 10061) (ReshowConn 10063 . 11752) (ShowCDMenu 11754 . 13163) (COPYBUTTONDOWN? 13165 . 13306)))) ) STOP \ No newline at end of file diff --git a/lispusers/CD.TEDIT b/lispusers/CD.TEDIT new file mode 100644 index 00000000..529546f6 Binary files /dev/null and b/lispusers/CD.TEDIT differ diff --git a/lispusers/CHATEMACS b/lispusers/CHATEMACS new file mode 100644 index 00000000..3bd3d1f3 --- /dev/null +++ b/lispusers/CHATEMACS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-Mar-89 17:08:22" {ERINYES}MEDLEY>CHATEMACS.;2 19237 changes to%: (FILES CHATDECLS) (FNS CHAT.BUTTONFN CHAT.TYPEIN CHAT.TYPEOUT CHAT.SCREENPARAMS) (VARS CHATEMACSCOMS) previous date%: "18-Jan-89 16:46:52" |{IE:PARC:XEROX}MEDLEY>CHATEMACS.;1|) (* " Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATEMACSCOMS) (RPAQQ CHATEMACSCOMS ((DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (SOURCE FROM LOADUP) CHATDECLS)) (DECLARE%: (GLOBALVARS CHATEMACS.SWITCH.ENABLED CHAT.META.ESC)) (INITVARS (CHATEMACS.SWITCH.ENABLED T) (CHAT.META.ESC T)) (FNS CHAT.BUTTONFN CHAT.TYPEIN CHAT.TYPEOUT CHAT.SCREENPARAMS) (ADVISE CHAT.INIT CHAT.CLOSE))) (DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE FROM LOADUP) CHATDECLS) ) (DECLARE%: (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHATEMACS.SWITCH.ENABLED CHAT.META.ESC) ) ) (RPAQ? CHATEMACS.SWITCH.ENABLED T) (RPAQ? CHAT.META.ESC T) (DEFINEQ (CHAT.BUTTONFN [LAMBDA (WINDOW) (* ; "Edited 4-Mar-89 21:55 by Randy.Gobbel") (GETMOUSESTATE) (if (type? CHAT.STATE (WINDOWPROP WINDOW 'CHATSTATE)) then [with CHAT.STATE (WINDOWPROP WINDOW 'CHATSTATE) (LET ((CY (LASTMOUSEY WINDOW)) (CX (LASTMOUSEX WINDOW)) (BUTTONS LASTMOUSEBUTTONS) (TTYLINES (IQUOTIENT TTYHEIGHT FONTHEIGHT)) CSTRING (SHIFTSTATE 0)) (* ;; "The characters are FONTHEIGHT high by FONTWIDTH wide") (COND [(IGREATERP CY TOPMARGIN) (COND ((MOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((MOUSESTATE (ONLY MIDDLE)) (CHAT.MENU WINDOW] ((EQ BUTTONS 0) NIL) (CHATINEMACS (for SS in '(SHIFT CTRL META) as I from 1 by I when (SHIFTDOWNP SS) do (SETQ SHIFTSTATE (IPLUS SHIFTSTATE I))) (SETQ CY (MAX (SUB1 (IDIFFERENCE TTYLINES (IQUOTIENT CY FONTHEIGHT))) 0)) (SETQ CX (IQUOTIENT (IPLUS (IQUOTIENT FONTWIDTH 2) CX) FONTWIDTH)) (SETQ CSTRING (CONCAT (CHARACTER (CHARCODE ^\)) "m" CX ";" CY ";" BUTTONS ";" SHIFTSTATE ";")) (UNINTERRUPTABLY (BKSYSBUF CSTRING))) (T (CHAT.HOLD WINDOW] else (DOWINDOWCOM WINDOW]) (CHAT.TYPEIN [LAMBDA (HOST WINDOW LOGOPTION INITSTREAM) (* ; "Edited 4-Mar-89 21:55 by Randy.Gobbel") (DECLARE (SPECVARS STREAM)) (* ; "so that menu can change it") (PROG ((THISPROC (THIS.PROCESS)) (DEFAULTSTREAM T) (STATE (WINDOWPROP WINDOW 'CHATSTATE)) CHATSTREAM INSTREAM WINDOWSTREAM STREAM CH DISPLAYTYPE DISPLAYNAME CHATPROMPTWINDOW CSTRING) (SETQ CHATSTREAM (fetch (CHAT.STATE OUTSTREAM) of STATE)) (SETQ INSTREAM (fetch (CHAT.STATE INSTREAM) of STATE)) (PROCESSPROP THISPROC 'TTYEXITFN (FUNCTION CHAT.TTYEXITFN)) (PROCESSPROP THISPROC 'TTYENTRYFN (FUNCTION CHAT.TTYENTRYFN)) (COND ((TTY.PROCESSP) (* ;; "Already have tty (probably from menu), so explicitly turn off interrupts, since our TTYENTRYFN hadn't been set yet (so that ^E could interrupt GETCHATWINDOW)") (CHAT.TTYENTRYFN THISPROC)) (T (* ; "want to do this early so users can start typing ahead") (TTY.PROCESS THISPROC))) (PROCESSPROP THISPROC 'WINDOW WINDOW) (SETQ WINDOWSTREAM (WINDOWPROP WINDOW 'DSP)) (DSPFONT (OR CHAT.FONT (DEFAULTFONT 'DISPLAY)) WINDOWSTREAM) (DSPRESET WINDOWSTREAM) (WINDOWPROP WINDOW 'PROCESS (THIS.PROCESS)) (WINDOWPROP WINDOW 'CHATHOST (CONS HOST LOGOPTION)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (WINDOW STATE) (AND RESETSTATE (fetch (CHAT.STATE RUNNING?) of STATE) (CHAT.CLOSE WINDOW T] WINDOW STATE)) (* ; "If an error occurs, process is killed, or HARDRESET happens, this will flush the connection etc") [COND ((SETQ DISPLAYTYPE (STREAMPROP INSTREAM 'DISPLAYTYPE)) (SETQ DISPLAYNAME (fetch (CHATDISPLAYTYPE DPYNAME) of DISPLAYTYPE] (replace (CHAT.STATE TYPEOUTPROC) of STATE with (ADD.PROCESS `(CHAT.TYPEOUT ,WINDOW ',DISPLAYNAME ',STATE) '%,NAME 'CHAT.TYPEOUT)) [COND (DISPLAYTYPE (CHAT.SETDISPLAYTYPE INSTREAM (fetch (CHATDISPLAYTYPE DPYCODE) of DISPLAYTYPE] (CHAT.SCREENPARAMS STATE INSTREAM WINDOW) (AND (NEQ LOGOPTION 'NONE) (CHAT.LOGIN HOST LOGOPTION WINDOW STATE)) [COND (INITSTREAM (NLSETQ (SETQ STREAM (COND ((STRINGP INITSTREAM) (OPENSTRINGSTREAM INITSTREAM)) (T (OPENSTREAM INITSTREAM 'INPUT] (TTYDISPLAYSTREAM WINDOWSTREAM) (* ; "So that \TTYBACKGROUND flashes the caret where we expect") (while (EQ (fetch (CHAT.STATE RUNNING?) of STATE) T) do (COND ((NULL STREAM) (SETQ STREAM DEFAULTSTREAM))) [COND [(EQ STREAM T) (* ;; "Handle terminal differently. Mainly because we may be inside a blocked process's \fillbuffer, making READP think there is input. Ugh!!!") [COND ((STREAMPROP CHATSTREAM 'SEND.SCREEN.SIZE) (STREAMPROP CHATSTREAM 'SEND.SCREEN.SIZE NIL) (SETQ CSTRING (CONCAT (CHARACTER (CHARCODE ^\)) "s" (IQUOTIENT (fetch (CHAT.STATE TTYWIDTH) of STATE) (fetch (CHAT.STATE FONTWIDTH) of STATE)) ";" (IQUOTIENT (fetch (CHAT.STATE TTYHEIGHT) of STATE) (fetch (CHAT.STATE FONTHEIGHT) of STATE)) ";")) (UNINTERRUPTABLY (BKSYSBUF CSTRING))] (OR (TTY.PROCESSP) (\WAIT.FOR.TTY)) (COND ((\SYSBUFP) (do (SETQ CH (\GETKEY)) (BOUT CHATSTREAM (COND ((AND CHAT.META.ESC (NEQ (LOGAND CH 256) 0)) (BOUT CHATSTREAM 27) (LOGAND CH 127)) ((EQ CH CHAT.CONTROLCHAR) (* ; "Controlify it") (LOGAND (CHAT.BIN CHATSTREAM STATE) 31)) ((EQ CH CHAT.METACHAR) (* ; "Prefix meta, turn on 200q bit") (LOGOR (CHAT.BIN CHATSTREAM STATE) 128)) (T CH))) repeatwhile (\SYSBUFP)) (FORCEOUTPUT CHATSTREAM] (T [until (EOFP STREAM) do (BOUT CHATSTREAM (COND ((AND CHAT.META.ESC (NEQ (LOGAND (SETQ CH (\BIN STREAM)) 256) 0)) (BOUT CHATSTREAM 27) (LOGAND CH 127)) (T CH] (FORCEOUTPUT CHATSTREAM) (CLOSEF STREAM) (SETQ STREAM) (COND ((SETQ CHATPROMPTWINDOW (GETPROMPTWINDOW WINDOW NIL NIL T)) (* ; "Indicate completion of Input if came from menu command") (CLEARW CHATPROMPTWINDOW] (\TTYBACKGROUND)) (* ;; "Get here if we close connection.") [SELECTQ (fetch (CHAT.STATE RUNNING?) of STATE) (CLOSE (CHAT.CLOSE WINDOW)) (ABORT (CHAT.CLOSE WINDOW T)) (NIL (* ; "Already dead.")) (SHOULDNT (CONCAT "Unknown state in CHAT: " (fetch (CHAT.STATE RUNNING?) of STATE] (BLOCK]) (CHAT.TYPEOUT [LAMBDA (WINDOW DPYNAME CHAT.STATE) (* ; "Edited 4-Mar-89 21:44 by Randy.Gobbel") (bind (CNT _ 1) HANDLECHARFN MSG CH INSTREAM DSPSTREAM TYPESCRIPTSTREAM CRPENDING ESCPENDING TERM.STATE CHAT.OUTSTREAM first (SETQ INSTREAM (fetch (CHAT.STATE INSTREAM) of CHAT.STATE )) (SETQ CHAT.OUTSTREAM (fetch (CHAT.STATE OUTSTREAM) of CHAT.STATE )) (SETQ HANDLECHARFN (CADR (FASSOC DPYNAME CHAT.DRIVERTYPES))) (replace (CHAT.STATE TERM.STATE) of CHAT.STATE with (SETQ TERM.STATE (APPLY* (CADDR (FASSOC DPYNAME CHAT.DRIVERTYPES)) CHAT.STATE))) [COND [(EQ DPYNAME 'TEDIT) (SETQ DSPSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM] (T (SETQ DSPSTREAM (WINDOWPROP WINDOW 'DSP] (* ; "TERM.HOME CHAT.STATE") while (IGEQ (SETQ CH (BIN INSTREAM)) 0) do (while (fetch (CHAT.STATE HELD) of CHAT.STATE) do (BLOCK)) (\CHECKCARET DSPSTREAM) (COND ((SETQ MSG (STREAMPROP INSTREAM 'MESSAGE)) (PRIN1 MSG DSPSTREAM) (STREAMPROP INSTREAM 'MESSAGE NIL))) (* ; "Print any protocol related msgs that might have come along while we where asleep") (SETQ CH (LOGAND CH (MASK.1'S 0 7))) (if ESCPENDING then (SETQ ESCPENDING NIL) (SELCHARQ CH (1 (if (NOT (fetch (CHAT.STATE CHATINEMACS) of CHAT.STATE)) then (CHAT.SWITCH.EMACS CHAT.STATE WINDOW) (STREAMPROP CHAT.OUTSTREAM 'SEND.SCREEN.SIZE T))) (0 (if (fetch (CHAT.STATE CHATINEMACS) of CHAT.STATE) then (CHAT.SWITCH.EMACS CHAT.STATE WINDOW))) (PROGN (SPREADAPPLY* HANDLECHARFN (CHARCODE ESC) CHAT.STATE TERM.STATE) (SPREADAPPLY* HANDLECHARFN CH CHAT.STATE TERM.STATE))) else (if (EQ CH (CHARCODE ESC)) then (SETQ ESCPENDING T) else (SPREADAPPLY* HANDLECHARFN CH CHAT.STATE TERM.STATE))) [COND ((SETQ TYPESCRIPTSTREAM (fetch (CHAT.STATE TYPESCRIPTSTREAM) of CHAT.STATE)) (COND ((SELCHARQ CH (CR (PROG1 CRPENDING (SETQ CRPENDING T))) (LF (COND (CRPENDING (\OUTCHAR TYPESCRIPTSTREAM (CHARCODE EOL)) (* ; "Have the typescript put turn crlf into whatever it likes for eol") (SETQ CRPENDING NIL)) (T T))) (PROGN (COND (CRPENDING (\BOUT TYPESCRIPTSTREAM (CHARCODE CR)) (SETQ CRPENDING NIL))) T)) (\BOUT TYPESCRIPTSTREAM CH] [COND (CHATDEBUGFLG (COND ((OR (EQ CHATDEBUGFLG T) (IGREATERP (add CNT 1) CHATDEBUGFLG)) (BLOCK) (SETQ CNT 1] finally (SELECTQ CH (-1 (CHAT.TYPEOUT.CLOSE WINDOW DSPSTREAM CHAT.STATE 'CLOSE "closed")) (-2 (CHAT.TYPEOUT.CLOSE WINDOW DSPSTREAM CHAT.STATE 'ABORT "aborted")) (CHAT.TYPEOUT.CLOSE WINDOW DSPSTREAM CHAT.STATE 'CLOSE "closed somehow")) (COND ((NOT (OPENWP WINDOW)) (DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS]) (CHAT.SCREENPARAMS [LAMBDA (CHAT.STATE INSTREAM WINDOW) (* ; "Edited 4-Mar-89 22:09 by Randy.Gobbel") (* ;; "Sends screen width, height to partner and updates title. If INSTREAM is NIL then only update title.") (PROG ((HEIGHT (IMIN [IQUOTIENT (WINDOWPROP WINDOW 'HEIGHT) (IABS (DSPLINEFEED NIL (WINDOWPROP WINDOW 'DSP] 127)) (WIDTH (IMIN (LINELENGTH NIL WINDOW) 127)) (TITLE (WINDOWPROP WINDOW 'TITLE)) EMACSMODE TITLEMIDDLE) (COND (INSTREAM (CHAT.SENDSCREENPARAMS INSTREAM HEIGHT WIDTH))) [WINDOWPROP WINDOW 'TITLE (CONCAT (SUBSTRING TITLE 1 (SUB1 (OR (SETQ TITLEMIDDLE (STRPOS ", height" TITLE)) 0))) ", height = " HEIGHT ", width = " WIDTH (COND [[OR (SETQ EMACSMODE (fetch (CHAT.STATE CHATINEMACS ) of CHAT.STATE )) (AND TITLEMIDDLE (NOT (FIXP (NTHCHAR TITLE -1] (CONCAT ", Emacs " (COND (EMACSMODE "ON") (T "OFF"] (T ""] (COND (EMACSMODE (STREAMPROP (fetch (CHAT.STATE OUTSTREAM) of CHAT.STATE) 'SEND.SCREEN.SIZE T]) ) [XCL:REINSTALL-ADVICE 'CHAT.INIT :AFTER '((:LAST (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION CHAT.BUTTONFN] [XCL:REINSTALL-ADVICE 'CHAT.CLOSE :AFTER '((:LAST (WINDOWPROP WINDOW 'RIGHTBUTTONFN NIL] (READVISE CHAT.INIT CHAT.CLOSE) (PUTPROPS CHATEMACS COPYRIGHT ("Xerox Corporation" 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1254 18858 (CHAT.BUTTONFN 1264 . 3610) (CHAT.TYPEIN 3612 . 11510) (CHAT.TYPEOUT 11512 . 16871) (CHAT.SCREENPARAMS 16873 . 18856))))) STOP \ No newline at end of file diff --git a/lispusers/CHATEMACS.TEDIT b/lispusers/CHATEMACS.TEDIT new file mode 100644 index 00000000..f63627c6 Binary files /dev/null and b/lispusers/CHATEMACS.TEDIT differ diff --git a/lispusers/CHATSERVER b/lispusers/CHATSERVER new file mode 100644 index 00000000..e647abc8 --- /dev/null +++ b/lispusers/CHATSERVER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 7-Sep-88 17:08:57" {ERINYES}MEDLEY>CHATSERVER.;11 47957 changes to%: (FNS CHATSERVEROPENFN) previous date%: "19-May-88 00:37:49" {ERINYES}MEDLEY>CHATSERVER.;10) (* " Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATSERVERCOMS) (RPAQQ CHATSERVERCOMS [(FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN SERVER-EXEC SWEEP.OFD \CLEARSYSBUF PROMPTFORWORD \CREATELINEBUFFER \PROMPTFORWORDBIN \REMOTE.BIN \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DISPLAYTERMFLG 'DM)) (INITVARS (CHATSERVER.PROFILE) (\SIMPLEIMAGEOPS)) (P (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG)) (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL) (ECHOCHAR I 'IGNORE ASKUSERTTBL)) (ECHOCHAR (CHARCODE CR) 'SIMULATE CHATSERVERTTBL) (ECHOCHAR (CHARCODE CR) 'SIMULATE ASKUSERTTBL) (ECHOCHAR 0 'SIMULATE ASKUSERTTBL) (ECHOCHAR 0 'SIMULATE CHATSERVERTTBL))) (ADDVARS (\SWEPT.OFDS)) (DECLARE%: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD) T))) [COMS (FNS SIMPLECHATSERVER) (INITVARS (CHATSERVERWINDOW) (CHATSERVERWINDOWREGION '(11 228 392 190] (MACROS \SYNCODE) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES CL-TTYEDIT SIMPLECHAT) (ADVISE MENU CHAT RINGBELLS)) (COMMANDS "QUIT" "SAY") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \REMOTE.BIN CHATSERVEROPENFN]) (DEFINEQ (CHATSERVER [LAMBDA NIL (* ; "Edited 18-May-88 23:56 by amd") (PROMPTPRINT "Remote CHAT connection attempted") (PRINTOUT T "Remote " HERALDSTRING T T) (CL:UNWIND-PROTECT [COND ((AND (LISTGET CHATSERVER.PROFILE 'IDLE.ONLY) (NOT \IDLING)) (PRINTOUT T " Machine not in idle mode, login not allowed " T) (DISMISS 10000)) (T (COND ((LET ((PROFILE (APPEND CHATSERVER.PROFILE IDLE.PROFILE))) (OR (REQUIRED.LOGIN PROFILE) (REQUIRED.LOGIN PROFILE) (REQUIRED.LOGIN PROFILE))) (* ; "try three times") (PROMPTPRINT "Remote CHAT exec in use") (PRINTOUT T (IF \IDLING THEN "[Idling, " ELSE "[Not in Idle, ") "last user action " (GDATE (ALTO.TO.LISP.DATE \LASTUSERACTION)) "]" T) (LET ((*PACKAGE* (CL:FIND-PACKAGE "XCL-USER")) (*READTABLE* (FIND-READTABLE "XCL"))) (SERVER-EXEC))) (T (PRINTOUT T T "Sorry... bye" T] (PROMPTPRINT "Remote CHAT disconnect"]) (CHATSERVERWHENCLOSEDFN [LAMBDA (STREAM) (* ; "Edited 6-Oct-87 11:43 by Masinter") (* ;; "when a connection gets closed, signal the server process to abort") (LET [(PROC (STREAMPROP STREAM 'SERVER.PROCESS] (AND PROC (FIND.PROCESS PROC) (DEL.PROCESS PROC]) (CHATSERVEROPENFN [CL:LAMBDA (*KEYBOARD-STREAM* OUTSTREAM) (* ; "Edited 2-Sep-88 23:36 by masinter") (* ;; "code common to all chat servers") (CL:UNWIND-PROTECT [PROGN (LINELENGTH 80 OUTSTREAM) (PAGEHEIGHT 24 OUTSTREAM) (STREAMPROP *KEYBOARD-STREAM* 'SERVER.PROCESS (THIS.PROCESS)) (STREAMPROP *KEYBOARD-STREAM* 'AFTERCLOSE 'CHATSERVERWHENCLOSEDFN) (STREAMPROP OUTSTREAM 'SERVER.PROCESS (THIS.PROCESS)) (STREAMPROP OUTSTREAM 'AFTERCLOSE 'CHATSERVERWHENCLOSEDFN) [COND ((fetch (FDEV BUFFERED) of (fetch (STREAM DEVICE) of OUTSTREAM )) (* ;; "output is a buffered device: spawn/restart process to send it out") (pushnew \SWEPT.OFDS OUTSTREAM) (DEL.PROCESS 'SWEEP.OFD) (ADD.PROCESS '(SWEEP.OFD] [OR \SIMPLEIMAGEOPS (SETQ \SIMPLEIMAGEOPS (create IMAGEOPS using \NOIMAGEOPS IMFONT _ 'CHATSERVER.FONT] (AND (EQ (fetch IMAGEOPS of OUTSTREAM) \NOIMAGEOPS) (replace IMAGEOPS of OUTSTREAM with \SIMPLEIMAGEOPS)) (replace (STREAM OUTCHARFN) of OUTSTREAM with (FUNCTION \REMOTE.EXEC.OUTCHARFN )) (replace (STREAM EOLCONVENTION) of OUTSTREAM with CRLF.EOLC) (if (EQ (fetch (STREAM STRMBINFN) of *KEYBOARD-STREAM*) (fetch (FDEV BIN) (fetch (STREAM DEVICE) *KEYBOARD-STREAM*))) then (replace (STREAM STRMBINFN) of *KEYBOARD-STREAM* with '\REMOTE.BIN) elseif (NOT (EQ (fetch (STREAM STRMBINFN) of *KEYBOARD-STREAM*) '\REMOTE.BIN)) then (PRINTOUT OUTSTREAM "[Interrupts not enabled]" T)) (LET* ((BUFFERED (\CREATELINEBUFFER *KEYBOARD-STREAM*)) (\TERM.OFD OUTSTREAM) (*STANDARD-OUTPUT* \TERM.OFD) (\LINEBUF.OFD BUFFERED) (*STANDARD-INPUT* \LINEBUF.OFD) (*TRACE-OUTPUT* *STANDARD-OUTPUT*)) (DECLARE (CL:SPECIAL PROMPTWINDOW \TERM.OFD *STANDARD-OUTPUT* \LINEBUF.OFD *STANDARD-INPUT*)) (HANDLER-BIND [(XCL:STREAM-NOT-OPEN (FUNCTION (LAMBDA (COND) (IF (FMEMB (XCL:STREAM-NOT-OPEN-STREAM COND) (LIST OUTSTREAM INSTREAM (FULLNAME OUTSTREAM) (FULLNAME INSTREAM))) THEN (RESET) (* ; " abort") ELSE NIL (* ; "ignore")] (CHATSERVER] (SETQ \SWEPT.OFDS (REMOVE OUTSTREAM \SWEPT.OFDS)))]) (DOBE [LAMBDA NIL (FLUSHOUTPUT T T]) (REQUIRED.LOGIN [LAMBDA (PROFILE) (* ; "Edited 30-Oct-87 16:13 by masinter") (PROG ((GROUP (LISTGET PROFILE 'ALLOWED.LOGINS)) (AUTHTYPE (LISTGET PROFILE 'AUTHENTICATE)) (NAME (USERNAME NIL NIL T)) PWD) (COND ((NLISTP GROUP) (* ; "no login check at all") (COND ((LISTGET PROFILE 'FORGET) (SETPASSWORD NIL NAME ""))) (RETURN T))) (COND ((EQ 0 (NCHARS NAME)) (* ;  "Not logged in, so don't complain about anything") (RETURN T))) CLEAR (CLEARBUF T T) (SETQ NAME (USERNAME NIL NIL T)) (SETQ PWD NIL) RETRY (COND [(AND (EQUAL GROUP '(T)) NAME) (* ;  "Only previous user allowed to login") (SETQ PWD (PROMPTFORWORD (CONCAT NAME " password:") NIL NIL NIL '*] (T [SETQ NAME (PROMPTFORWORD "Login ( to terminate): " NAME NIL T NIL T (CHARCODE (CR LF] (if (MEMBER NAME '("Logon" "ogon")) then (GO CLEAR)) (SETQ PWD (PROMPTFORWORD " (password) " NIL NIL T '*)) (TERPRI T))) (if (EQUAL PWD "Logon") then (GO CLEAR)) (RETURN (COND ((NULL PWD) NIL) ([AND (OR (MEMB T GROUP) (MEMB '* GROUP)) (\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP '(T] (* ;; "Previous user is allowed to login. Also, if only allowed login is old user, but old password is unknown, allow it") T) ((\IDLE.ISMEMBER GROUP NAME PWD) (PROG1 (COND ((COND [AUTHTYPE (\IDLE.AUTHENTICATE NAME PWD AUTHTYPE (NOT (MEMB T GROUP] (T T)) (AND (LISTGET PROFILE 'FORGET) (SETPASSWORD NIL NAME PWD)) (SETQ \IDLE.PASSWORD.SET T) T)) (TERPRI T))) (T (PRINTOUT T "login incorrect" T) NIL]) (SERVER-EXEC [LAMBDA NIL (* ; "Edited 6-Oct-87 16:37 by Masinter") (\CALLME 'T) (do (EXEC :TOP-LEVEL-P T]) (SWEEP.OFD [LAMBDA NIL (* lmm "15-Mar-86 14:40") (while \SWEPT.OFDS do (for X in \SWEPT.OFDS do (if (if (NLISTP X) then [OR (NOT (OPENP X 'OUTPUT)) (NOT (NLSETQ (FORCEOUTPUT X] else T) then (SETQ \SWEPT.OFDS (REMOVE X \SWEPT.OFDS))) (BLOCK]) (\CLEARSYSBUF [LAMBDA (ALLFLG) (* ; "Edited 30-Oct-87 11:07 by Masinter") (LET ((KEY (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) (while (READP KEY) do (BIN KEY]) (PROMPTFORWORD [LAMBDA (PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG URGENCY.OPTION TERMINCHARS.LST KEYBD.CHANNEL) (* lmm "16-Jan-86 18:07") (DECLARE (SPECVARS TERMINCHARS.LST ECHO.CHANNEL DONTECHOTYPEIN.FLG)) [COND ((NOT (TERMTABLEP \PROMPTFORWORDTTBL)) (* ;  "Initializes the special readtable on the first time through.") (SETQ \PROMPTFORWORDTTBL (bind (TTBL _ (COPYTERMTABLE 'ORIG)) for CHAR from 0 to 31 do (SELCHARQ CHAR ((EOL ESCAPE SPACE LF TAB)) (ECHOCHAR CHAR 'INDICATE TTBL)) finally (PROGN (ECHOMODE NIL TTBL) (CONTROL T TTBL) (RETURN TTBL] (RESETLST (RESETSAVE (SETTERMTABLE \PROMPTFORWORDTTBL)) (PROG ([CHARBUFFER (COND (CANDIDATE.STR (DREVERSE (CHCON CANDIDATE.STR] TTYD X0Y0 TIMELIMITEXPIRED? BELLBEENHEARD? CANDIDATATE.LENGTH CHAR BEGUNTYPING? RUBBING? ?HELPMSGTRIEDP ?HELPMSGLIST TIMER) (DECLARE (SPECVARS TTYD X0Y0 TIMELIMITEXPIRED? BELLBEENHEARD? CHARBUFFER RUBBING?)) [COND [(EQMEMB 'TTY URGENCY.OPTION) (* ;  "If we're going to switch the TTY process, better do it before looking for TTYDISPLAYSTREAM etc.") [OR (TTY.PROCESSP) (RESETSAVE (TTY.PROCESS (THIS.PROCESS] (AND \PROMPTFORWORD.CURSOR (RESETSAVE (CURSOR \PROMPTFORWORD.CURSOR] (T (OR (FIXP URGENCY.OPTION) (SELECTQ URGENCY.OPTION ((NIL T) T) NIL) (\ILLEGAL.ARG URGENCY.OPTION] (SETQ ECHO.CHANNEL (GETSTREAM (OR ECHO.CHANNEL T) 'OUTPUT)) (* ; "Normalize the echo channel.") (CL:WHEN (SETQ TTYD (DISPLAYSTREAMP ECHO.CHANNEL)) (RESETSAVE (TTYDISPLAYSTREAM ECHO.CHANNEL))) [COND ((AND DONTECHOTYPEIN.FLG (NEQ DONTECHOTYPEIN.FLG T)) (SETQ DONTECHOTYPEIN.FLG (COND ((EQ (NCHARS DONTECHOTYPEIN.FLG) 1) (NTHCHARCODE DONTECHOTYPEIN.FLG 1)) (T T] (COND [(NULL TERMINCHARS.LST) (SETQ TERMINCHARS.LST (CHARCODE (EOL ESCAPE SPACE LF TAB] ((CHARCODEP TERMINCHARS.LST) (SETQ TERMINCHARS.LST (LIST TERMINCHARS.LST))) ([OR (NLISTP TERMINCHARS.LST) (for C in TERMINCHARS.LST bind CONVERTIBLEP unless (CHARCODEP C) do (COND ((AND (OR (LITATOM C) (STRINGP C)) (EQ 1 (NCHARS C))) (SETQ CONVERTIBLEP T)) (T (RETURN T))) finally (COND (CONVERTIBLEP (* ;  "List not all charcodes, but all are at least charcode like") (SETQ TERMINCHARS.LST (MAPCAR TERMINCHARS.LST (FUNCTION (LAMBDA (C) (OR (FIXP C) (CHCON1 C] (\ILLEGAL.ARG TERMINCHARS.LST))) [COND (KEYBD.CHANNEL (SETQ KEYBD.CHANNEL (\INSTREAMARG KEYBD.CHANNEL] [COND (URGENCY.OPTION (SETQ TIMER (SETUPTIMER (OR (FIXP URGENCY.OPTION) 0) NIL 'SECONDS] (* ;;; "Now ready to begin. Print the prompt, gather input") PROMPTAGAIN (COND (PROMPT.STR (PRIN3 PROMPT.STR ECHO.CHANNEL) (PRIN3 " " ECHO.CHANNEL))) [COND (TTYD (SETQ X0Y0 (create POSITION XCOORD _ (DSPXPOSITION NIL TTYD) YCOORD _ (DSPYPOSITION NIL TTYD] (COND (CHARBUFFER (* ;; "If there is input, e.g. the candidate string, echo it. This is the one place calling \PROMPTFORWORDRETYPE that doesn't want the line erased first.") (\PROMPTFORWORDRETYPE))) [until (OR (NULL (SETQ CHAR (\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD URGENCY.OPTION TIMER))) (FMEMB CHAR TERMINCHARS.LST)) do (COND ((SELECTQ (GETSYNTAX CHAR \PROMPTFORWORDTTBL) (CHARDELETE (COND (CHARBUFFER (SETQ BEGUNTYPING? T) (\PROMPTFORWORDBS)) (T (SETQ RUBBING?))) NIL) (LINEDELETE (COND (CHARBUFFER (COND ((NEQ DONTECHOTYPEIN.FLG T) (\PROMPTFORWORDERASE))) (SETQ BEGUNTYPING? T) (SETQ CHARBUFFER)) (T (SETQ RUBBING?))) NIL) (RETYPE (COND (CHARBUFFER (COND ((NEQ DONTECHOTYPEIN.FLG T) (\PROMPTFORWORDERASE))) (\PROMPTFORWORDRETYPE)) (T (SETQ RUBBING?))) NIL) (WORDDELETE (COND [CHARBUFFER (SETQ BEGUNTYPING? T) (bind (SPACEP _ (SYNTAXP (CAR CHARBUFFER) 'WORDSEPR \PROMPTFORWORDTTBL)) do (\PROMPTFORWORDBS) (COND ((NULL CHARBUFFER) (RETURN))) (SETQ CHAR (CAR CHARBUFFER)) (COND [(NOT SPACEP) (COND ((SYNTAXP CHAR 'WORDSEPR \PROMPTFORWORDTTBL) (RETURN] ((NOT (SYNTAXP CHAR 'WORDSEPR \PROMPTFORWORDTTBL)) (SETQ SPACEP NIL] (T (SETQ RUBBING?))) NIL) (CNTRLV (COND ((NOT DONTECHOTYPEIN.FLG) (* ;; "Well, so echo the ^V SO THAT THE LOSER CAN SEE THAT HE'S IN THE STATE OF WAITING FOR THE NEXT CHARACTER AFTER A ^V") (COND ((AND RUBBING? (NOT TTYD)) (BOUT ECHO.CHANNEL (CHARCODE \)) (SETQ RUBBING?))) (PRIN3 (CHARACTER CHAR) ECHO.CHANNEL))) (COND ((NULL (SETQ CHAR (\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD URGENCY.OPTION TIMER T))) (RETURN T))) (COND ((AND TTYD (NOT DONTECHOTYPEIN.FLG) (NULL (DSPRUBOUTCHAR TTYD CHAR))) (* ;; "Well, we tried to erase the ^V so that the typed-in charcter could be echoed, but apparently the ^V was split between lines.") (\PROMPTFORWORDERASE) (\PROMPTFORWORDRETYPE))) T) (COND ((EQ CHAR (CHARCODE ?)) (FRESHLINE ECHO.CHANNEL) [COND ((AND GENERATE?LIST.FN (NOT ?HELPMSGTRIEDP)) (SETQ ?HELPMSGLIST (OR (STRINGP GENERATE?LIST.FN) (APPLY* GENERATE?LIST.FN PROMPT.STR CANDIDATE.STR))) (SETQ ?HELPMSGTRIEDP T)) ((NOT ?HELPMSGTRIEDP) (SETQ ?HELPMSGLIST '??] (COND ((LISTP ?HELPMSGLIST) (PRIN3 '{ ECHO.CHANNEL) (PRIN3 (CONSTANT (CHARACTER (CHARCODE SPACE))) ECHO.CHANNEL) [MAPC ?HELPMSGLIST (FUNCTION (LAMBDA (X) (PRIN1 X ECHO.CHANNEL) (PRIN3 (CONSTANT (CHARACTER (CHARCODE SPACE))) ECHO.CHANNEL] (PRIN3 '} ECHO.CHANNEL)) (T (PRIN1 ?HELPMSGLIST ECHO.CHANNEL) (* ;  "FOO we'd really like this FRESHLINE to be just a MOVETO some initial position.") )) (FRESHLINE ECHO.CHANNEL) (GO PROMPTAGAIN)) (T T))) (* ;  "If the SELCHARQ does't select out any of its 'special' characters, then just fall through here") (COND ((AND (NOT BEGUNTYPING?) CHARBUFFER) (* ;; "This is the case of the CANDIDATE.STR having been proffered, but the user starts typing something else.") (COND ((EQ CHAR (CHARCODE SPACE)) (* ;; "Special kludge for benefit of those with old space-terminating habits: If there is a candidate string, and the first thing you do is type a space, then the space terminates even if it isn't a member of TERMINCHARS.LST") (RETURN))) (COND ((NOT DONTECHOTYPEIN.FLG) (* ;  "Don't need to do anything if type-in isn't being echoed") (\PROMPTFORWORDERASE))) (SETQ CHARBUFFER))) (push CHARBUFFER CHAR) (SETQ BEGUNTYPING? T) (COND ((NEQ DONTECHOTYPEIN.FLG T) (* ;  "Well, so echo the typed-in character already!") (COND ((AND RUBBING? (NOT TTYD)) (PRIN3 '\ ECHO.CHANNEL) (SETQ RUBBING?))) (BOUT ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG CHAR] [SETQ CHARBUFFER (COND [TIMELIMITEXPIRED? (* ;  "Ha, we overflowed the time limit.") (COND (CANDIDATE.STR (CONCAT CANDIDATE.STR] (CHARBUFFER (CONCATCODES (DREVERSE CHARBUFFER] (\CARET.DOWN ECHO.CHANNEL) (RETURN CHARBUFFER]) (\CREATELINEBUFFER [LAMBDA (TERMINAL.STREAM) (* ; "Edited 13-Apr-87 22:57 by bvm:") (* ;;  "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") (LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T] (DEV (fetch (STREAM DEVICE) of STREAM)) EOFMETHOD) (replace LINEBUFSTATE of STREAM with READING.LBS) (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM)) (replace USERCLOSEABLE of STREAM with NIL) (replace USERVISIBLE of STREAM with NIL) (* ;  "Other linebuffer fields default properly") [replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) (CL:FUNCALL \RefillBufferFn] (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of (fetch (STREAM DEVICE) TERMINAL.STREAM))) 'NILL)) then (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.") (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE 'FDEV DEV))) (* ;  "Copy the basic linebuffer device") (replace (FDEV EOFP) of DEV with EOFMETHOD)) STREAM]) (\PROMPTFORWORDBIN [LAMBDA (INSTREAM DISPLAYECHOSTREAM URGENCY.OPTION TIMER) (* ; "Edited 7-Oct-87 11:25 by Masinter") (* ;  "Takes in one character from the KEYBD.CHANNEL") (DECLARE (USEDFREE TERMINCHARS.LST TIMELIMITEXPIRED? BELLBEENHEARD?)) (PROG ((WAITINTERVAL.secs 15) (TTYWAITLIMIT (if URGENCY.OPTION then (if BELLBEENHEARD? then 30000 else 0))) [BROADURGENCY? (AND URGENCY.OPTION (NOT (FIXP URGENCY.OPTION] CHAR READABLE (KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) NEXTROUND [if BROADURGENCY? then (SETQ TIMER (SETUPTIMER WAITINTERVAL.secs TIMER 'SECONDS] LP (if (SETQ READABLE (OR INSTREAM (NEQ KEYSTREAM \KEYBOARD.STREAM) (WAIT.FOR.TTY TTYWAITLIMIT))) then (* ; "Ready to read") (if (SETQ CHAR (if (NULL INSTREAM) then (if (READP KEYSTREAM T) then (BIN KEYSTREAM)) elseif (READP INSTREAM T) then (BIN INSTREAM) elseif (EOFP INSTREAM) then (CAR TERMINCHARS.LST))) then (RETURN CHAR)) (if DISPLAYECHOSTREAM then (* ;  "\TTYBACKGROUND so that a caret will flash") (\TTYBACKGROUND) else (BLOCK))) (if (AND TIMER (TIMEREXPIRED? TIMER 'SECONDS)) then (if (AND URGENCY.OPTION (NOT BROADURGENCY?)) then (SETQ TIMELIMITEXPIRED? T) (RETURN)) else (SETQ TTYWAITLIMIT 30000) (AND READABLE (GO LP))) (if (NULL BELLBEENHEARD?) then (SETQ BELLBEENHEARD? T) (RINGBELLS)) [if (AND BROADURGENCY? (TTY.PROCESSP)) then (* ;; "Double the wait interval time (the time between 'flashings') up to about 2 minutes, so that it doesn't become obnoxious") (SETQ WAITINTERVAL.secs (IMIN (LLSH WAITINTERVAL.secs 1) (TIMES 2 60] (GO NEXTROUND]) (\REMOTE.BIN [CL:LAMBDA (STREAM) (* ; "Edited 30-Oct-87 10:47 by Masinter") (CL:MACROLET [(REALBIN NIL '(CL:FUNCALL (FETCH (FDEV BIN) (fetch (STREAM DEVICE) STREAM)) STREAM)) (CLR NIL '(while (READP STREAM) do (REALBIN] (PROG (CH) RETRY (SELCHARQ (SETQ CH (REALBIN)) (^E (CLR) (ERROR!)) (^D (CLR) (RESET)) (^B (CLR) (\DOHELPINTERRUPT1) (GO RETRY)) (^T (CL:CATCH 'DONE (PROG ((CNT 0)) (FRESHLINE T) [BACKTRACE -2 T NIL T (FUNCTION (LAMBDA (X) (PRIN1 (if (EQ CNT 0) then "Running in " else " in ") T) (CL:PRIN1 X *TERMINAL-IO*) (if (IGEQ (add CNT 1) 5) then (CL:THROW 'DONE NIL] (FRESHLINE T))) (GO RETRY)) NIL) (RETURN CH]) (\REMOTE.EXEC.OUTCHARFN [LAMBDA (STREAM CHARCODE) (* ; "Edited 11-Oct-87 23:17 by Masinter") (* ; "OUTCHARFN for standard files") [SELECTC (ffetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE)) (INDICATE.CCE (* ;  "Make sure that all the chars in the indicate-string fit on the line or wrap-around together.") (CL:MAP NIL #'[LAMBDA (CH) (CL:WRITE-CHAR CH STREAM) (CL:INCF (ffetch CHARPOSITION of STREAM] ( \INDICATESTRING CHARCODE))) (IGNORE.CCE) (PROGN (if (EQ CHARCODE ERASECHARCODE) then (BOUT STREAM (CHARCODE ^H)) (BOUT STREAM (CHARCODE SPACE)) (BOUT STREAM (CHARCODE ^H)) (add (fetch CHARPOSITION of STREAM) -1) else (SELCHARQ CHARCODE ((EOL CR LF) (BLOCK) [COND ([OR (EQ \CURRENTDISPLAYLINE -1) (AND (SMALLP \CURRENTDISPLAYLINE) (EQ \#DISPLAYLINES (SETQ \CURRENTDISPLAYLINE (ADD1 \CURRENTDISPLAYLINE] (SETQ \CURRENTDISPLAYLINE 0) (LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) (COND ((READP KEYSTREAM)) (T (PRIN1 \STOPSCROLLMESSAGE STREAM) (SELCHARQ (BIN KEYSTREAM) (^B (INTERRUPT)) (^E (ERROR!)) NIL) (* ; "Now erase the message") (FRPTQ (NCHARS \STOPSCROLLMESSAGE) (\REMOTE.EXEC.OUTCHARFN STREAM ERASECHARCODE)) (BLOCK] (BOUT STREAM (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE CR)) (LF.EOLC (CHARCODE LF)) (CRLF.EOLC (* ;; "The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes") (BOUT STREAM (CHARCODE CR)) (CHARCODE LF)) (SHOULDNT))) (freplace CHARPOSITION of STREAM with 0)) (ESCAPE (BOUT STREAM (CHARCODE $)) (add (ffetch CHARPOSITION of STREAM) 1)) (TAB (SPACES (DIFFERENCE 8 (IMOD (POSITION) 8)) STREAM)) (PROGN (BOUT STREAM CHARCODE) (add (ffetch CHARPOSITION of STREAM) 1] CHARCODE]) (CHATSERVER.FONT [LAMBDA (STREAM FONT) (* lmm "20-Nov-86 00:01") (SELECTQ DISPLAYTERMFLG (DM [COND ((OR (EQ BOLDFONT FONT) (EQ FONT LAMBDAFONT)) (BOUT STREAM (CHARCODE ^N))) (T (BOUT STREAM (CHARCODE ^X)) (BOUT STREAM (CHARCODE "^]"]) NIL]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ DISPLAYTERMFLG DM) (RPAQ? CHATSERVER.PROFILE ) (RPAQ? \SIMPLEIMAGEOPS ) (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG)) (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL) (ECHOCHAR I 'IGNORE ASKUSERTTBL)) (ECHOCHAR (CHARCODE CR) 'SIMULATE CHATSERVERTTBL) (ECHOCHAR (CHARCODE CR) 'SIMULATE ASKUSERTTBL) (ECHOCHAR 0 'SIMULATE ASKUSERTTBL) (ECHOCHAR 0 'SIMULATE CHATSERVERTTBL) ) (ADDTOVAR \SWEPT.OFDS ) (DECLARE%: EVAL@COMPILE DONTCOPY (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD) T) ) (DEFINEQ (SIMPLECHATSERVER [LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 6-Oct-87 14:37 by Masinter") (if NIL then (PRINTOUT OUTSTREAM "Simple chat echo service") (do (\OUTCHAR OUTSTREAM (BIN INSTREAM))) else (PROG ([WINDOW (OR CHATSERVERWINDOW (SETQ CHATSERVERWINDOW (CREATEW CHATSERVERWINDOWREGION "Chat Listener"] (KEYSTREAM \KEYBOARD.STREAM) MYSTREAM) (printout OUTSTREAM "Xerox Lisp Chat echo service" T) (CLEARW WINDOW) (SETQ MYSTREAM (GETSTREAM WINDOW 'OUTPUT)) [WINDOWPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (SETQ SIMPLECHATSERVERDONE T) (AND (OPENWP W) (WINDOWPROP W 'TITLE "Connection closed"] (WINDOWPROP WINDOW 'PROCESS (THIS.PROCESS)) (bind CH do (while (READP INSTREAM) do (\OUTCHAR OUTSTREAM (SETQ CH (BIN INSTREAM))) (\OUTCHAR MYSTREAM CH)) (BLOCK) (while (READP KEYSTREAM) do (\OUTCHAR OUTSTREAM (SETQ CH (BIN KEYSTREAM))) (\OUTCHAR MYSTREAM CH)) (if (EQ (TTY.PROCESS) (THIS.PROCESS)) then (\TTYBACKGROUND) else (BLOCK))) (printout MYSTREAM T T "Connection closed" T) (WINDOWPROP WINDOW 'TITLE "Connection closed") (WINDOWPROP WINDOW 'CLOSEFN NIL))) (* ;;; "The following isn't executed") ]) ) (RPAQ? CHATSERVERWINDOW ) (RPAQ? CHATSERVERWINDOWREGION '(11 228 392 190)) (DECLARE%: EVAL@COMPILE [PROGN (PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR) (CHECK (type? CHARTABLE TABLE)) (* ;  "0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \MAXTHINCHAR) (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE))) 0)) (T (\GETBASEBYTE TABLE CHAR]) (PUTPROPS \SYNCODE MACRO [OPENLAMBDA (TABLE CHAR) (CHECK (type? CHARTABLE TABLE)) (COND ((IGREATERP CHAR \MAXTHINCHAR) (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE))) 0)) (T (\GETBASEBYTE TABLE CHAR])] ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD CL-TTYEDIT SIMPLECHAT) [XCL:REINSTALL-ADVICE 'MENU :BEFORE '((:LAST (OR (DISPLAYSTREAMP \TERM.OFD) (RETURN (ASKUSER NIL NIL (OR (FETCH (MENU TITLE) MENU) "Menu choice:") (MAPCAR (FETCH (MENU ITEMS) MENU) (FUNCTION (LAMBDA (X) (COND ((LISTP X) (LIST (CAR X) "" 'RETURN (CADR X))) (T X] [XCL:REINSTALL-ADVICE 'CHAT :BEFORE '((:LAST (AND (NOT WINDOW) (NOT FROMMENU) (NOT (DISPLAYSTREAMP (TTYDISPLAYSTREAM))) (RETURN (TTYCHAT HOST LOGOPTION] [XCL:REINSTALL-ADVICE 'RINGBELLS :BEFORE '((:LAST (OR (WFROMDS \TERM.OFD) (RETURN (RPTQ (OR (FIXP N) 1) (BOUT \TERM.OFD 7] (READVISE MENU CHAT RINGBELLS) ) (DEFCOMMAND "QUIT" () (RETFROM 'CHATSERVEROPENFN)) (DEFCOMMAND "SAY" (&REST LINE) [MAPC \PROCESSES (FUNCTION (LAMBDA (PROC) (CL:WHEN (STRPOS "CHAT.SERVER" (PROCESS.NAME PROC)) (MAPRINT LINE (IF (EQ PROC (THIS.PROCESS)) THEN *STANDARD-OUTPUT* ELSE (EVALV '*STANDARD-OUTPUT* PROC)) " " " "))] (MAPRINT LINE PROMPTWINDOW " " " ") (CL:VALUES)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \REMOTE.BIN CHATSERVEROPENFN) ) (PRETTYCOMPRINT CHATSERVERCOMS) (RPAQQ CHATSERVERCOMS [(FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN SERVER-EXEC SWEEP.OFD \CLEARSYSBUF PROMPTFORWORD \CREATELINEBUFFER \PROMPTFORWORDBIN \REMOTE.BIN \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DISPLAYTERMFLG 'DM)) (INITVARS (CHATSERVER.PROFILE) (\SIMPLEIMAGEOPS)) (P (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG)) (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL) (ECHOCHAR I 'IGNORE ASKUSERTTBL)) (ECHOCHAR (CHARCODE CR) 'SIMULATE CHATSERVERTTBL) (ECHOCHAR (CHARCODE CR) 'SIMULATE ASKUSERTTBL) (ECHOCHAR 0 'SIMULATE ASKUSERTTBL) (ECHOCHAR 0 'SIMULATE CHATSERVERTTBL))) (ADDVARS (\SWEPT.OFDS)) (DECLARE%: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD) T))) [COMS (FNS SIMPLECHATSERVER) (INITVARS (CHATSERVERWINDOW) (CHATSERVERWINDOWREGION '(11 228 392 190] (MACROS \SYNCODE) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES CL-TTYEDIT SIMPLECHAT) (ADVISE MENU CHAT RINGBELLS)) (COMMANDS "QUIT" "SAY") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CHATSERVEROPENFN]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CHATSERVEROPENFN) ) (PUTPROPS CHATSERVER COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2216 38509 (CHATSERVER 2226 . 3955) (CHATSERVERWHENCLOSEDFN 3957 . 4304) ( CHATSERVEROPENFN 4306 . 8433) (DOBE 8435 . 8481) (REQUIRED.LOGIN 8483 . 11220) (SERVER-EXEC 11222 . 11395) (SWEEP.OFD 11397 . 11933) (\CLEARSYSBUF 11935 . 12184) (PROMPTFORWORD 12186 . 26531) ( \CREATELINEBUFFER 26533 . 28708) (\PROMPTFORWORDBIN 28710 . 31646) (\REMOTE.BIN 31648 . 33890) ( \REMOTE.EXEC.OUTCHARFN 33892 . 38114) (CHATSERVER.FONT 38116 . 38507)) (39151 41493 (SIMPLECHATSERVER 39161 . 41491))))) STOP \ No newline at end of file diff --git a/lispusers/CHATSERVER-NS b/lispusers/CHATSERVER-NS new file mode 100644 index 00000000..b35d99ee --- /dev/null +++ b/lispusers/CHATSERVER-NS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 7-Sep-88 17:17:04" {ERINYES}MEDLEY>CHATSERVER-NS.;2 7560 changes to%: (FNS MAKE.NS.CHAT.CONNECTION) previous date%: "16-Mar-88 22:34:39" {ERINYES}MEDLEY>CHATSERVER-NS.;1) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATSERVER-NSCOMS) (RPAQQ CHATSERVER-NSCOMS [(FNS MAKE.NS.CHAT.CONNECTION NS.CHAT.SERVE NSCHAT.SERVER.ATTENTION NSCHAT.SERVER.OUTPUTABORTED NSCHAT.SERVER.WHENCLOSED SPP.EOMP \NSCHAT.BIN \REMOTE.EOFP \REMOTE.PEEKBIN \REMOTE.READP GAP-SERVER-INIT) (FILES COURIERSERVE CHATSERVER) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (GAP-SERVER-INIT) (COURIER.START.SERVER))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) MODARITH) (FILES (LOADCOMP) LLNS SPP)) (FUNCTIONS CHECK) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MAKE.NS.CHAT.CONNECTION ]) (DEFINEQ (MAKE.NS.CHAT.CONNECTION (CL:LAMBDA (CSTREAM CPROG CPROC PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER) (* ; "Edited 2-Sep-88 23:43 by masinter") (LET ((OUTPUTSTREAM (SPPOUTPUTSTREAM CSTREAM))) (with SPPCON (fetch SPP.CONNECTION of CSTREAM) (SETQ SPPEOMONFORCEOUT T) (SETQ SPPATTENTIONFN (FUNCTION NSCHAT.SERVER.ATTENTION)) (SETQ SPPOUTPUTABORTEDFN (FUNCTION NSCHAT.SERVER.OUTPUTABORTED)) (SETQ SPPWHENCLOSEDFN (FUNCTION CHATSERVERWHENCLOSEDFN))) (with STREAM CSTREAM (SETQ DEVICE (create FDEV DEVICENAME _ 'NSCHATDEVICE (* ; "") PEEKBIN _ #'\REMOTE.PEEKBIN (* ; "") READP _ #'\REMOTE.READP (* ; "") EOFP _ #'\REMOTE.EOFP (* ; "") GETEOFPTR _ (FUNCTION NILL) (* ; "") BIN _ '\NSCHAT.BIN using DEVICE)) (SETQ STRMBINFN '\NSCHAT.BIN)) (* ;; "return the value, and then ") [COURIER.RETURN CSTREAM CPROG CPROC '((0 0] (SPP.FORCEOUTPUT OUTPUTSTREAM) (SPP.SENDATTENTION CSTREAM 209) (PROCESS.NAME (THIS.PROCESS) 'CHAT.SERVER) (SPP.DSTYPE OUTPUTSTREAM 192) (CHATSERVEROPENFN CSTREAM OUTPUTSTREAM)))) (NS.CHAT.SERVE (LAMBDA (INPUTSTREAM OUTPUTSTREAM OPENFN WHENCLOSEDFN) (* lmm " 7-Jan-86 13:21") (PROG (PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER) (repeatuntil (SPP.READP INPUTSTREAM) do (BLOCK)) (for I to 4 do (* Echo Courier version number) (BOUT OUTPUTSTREAM (BIN INPUTSTREAM))) (SPP.SENDEOM OUTPUTSTREAM) (SPP.CLEAREOM INPUTSTREAM) (repeatuntil (SPP.READP INPUTSTREAM) do (BLOCK)) (for I to 12 do (* Courier protocol bytes |...|) (BIN INPUTSTREAM)) (SETQ PARAMETERS (COURIER.READ INPUTSTREAM (QUOTE GAP) (QUOTE SessionParameterObject))) (SETQ TRANSPORT (COURIER.READ INPUTSTREAM (QUOTE GAP) (QUOTE Sequence.TransportObject))) (SETQ WAITTIME (COURIER.READ INPUTSTREAM (QUOTE GAP) (QUOTE WaitTime))) (SETQ CREDENTIALS (COURIER.READ INPUTSTREAM (QUOTE GAP) (QUOTE credentials))) (SETQ VERIFIER (COURIER.READ INPUTSTREAM (QUOTE GAP) (QUOTE verifier))) (* Courier RETURN command) (BOUT OUTPUTSTREAM 0) (BOUT OUTPUTSTREAM 2) (BOUT OUTPUTSTREAM 0) (BOUT OUTPUTSTREAM 0) (COURIER.WRITE OUTPUTSTREAM (QUOTE (0 0)) (QUOTE GAP) (QUOTE SessionHandle)) (SPP.SENDEOM OUTPUTSTREAM) (SPP.FLUSH.TO.EOF INPUTSTREAM) (with STREAM OUTPUTSTREAM (SETQ EOLCONVENTION 2)) (with STREAM INPUTSTREAM (SETQ IMAGEDATA OUTPUTSTREAM) (SETQ DEVICE (create FDEV DEVICENAME _ (QUOTE NSCHAT) BIN _ (FUNCTION \REMOTE.BIN) PEEKBIN _ (FUNCTION \REMOTE.PEEKBIN) READP _ (FUNCTION \REMOTE.READP) EOFP _ (FUNCTION \REMOTE.EOFP) GETEOFPTR _ (FUNCTION NILL) using DEVICE)) (SETQ STRMBINFN (FUNCTION \REMOTE.BIN))) (SPP.CLEAREOM INPUTSTREAM T) (SPP.CLEARATTENTION INPUTSTREAM T) (CHATSERVEROPENFN INPUTSTREAM OUTPUTSTREAM) (SPP.CLOSE INPUTSTREAM T))) ) (NSCHAT.SERVER.ATTENTION (LAMBDA (X) (* ; "Edited 6-Oct-87 13:25 by Masinter") (SPP.CLEARATTENTION X T) (LET (BYTE) (SELECTQ (SETQ BYTE (BIN X)) (209 (* ; "attention 209, whatever that is") NIL) (PRINTOUT PROMPTWINDOW T "attention byte " BYTE " recieved.")))) ) (NSCHAT.SERVER.OUTPUTABORTED (LAMBDA (STREAM X Y Z) (* lmm "10-Jan-86 00:32") NIL)) (NSCHAT.SERVER.WHENCLOSED (LAMBDA (STREAM X Y Z) (* lmm " 9-Jan-86 18:06") (CLOSEF? (SPPOUTPUTSTREAM STREAM)))) (SPP.EOMP (LAMBDA (STREAM) (* ; "Edited 6-Oct-87 13:04 by Masinter") (EQ (fetch SPPEOFBITS of STREAM) \SPPFLAG.EOM)) ) (\NSCHAT.BIN (LAMBDA (STREAM) (* ; "Edited 30-Oct-87 10:35 by Masinter") (until (\REMOTE.READP STREAM) do (BLOCK)) (\BUFFERED.BIN STREAM)) ) (\REMOTE.EOFP (LAMBDA (STREAM) (* ; "Edited 6-Oct-87 11:37 by Masinter") (* ;; "terminal EOF: never") NIL)) (\REMOTE.PEEKBIN (LAMBDA (STREAM NOERRORFLG) (* ; "Edited 6-Oct-87 11:35 by Masinter") (* ;; "SPP peek: ignore EOM") (until (SPP.READP STREAM) do (if (SPP.EOMP STREAM) then (SPP.CLEAREOM STREAM T)) (BLOCK)) (PROG ((BYTE (\BUFFERED.PEEKBIN STREAM NOERRORFLG))) (if (SPP.EOMP STREAM) then (SPP.CLEAREOM STREAM T)) (RETURN BYTE))) ) (\REMOTE.READP (LAMBDA (STREAM) (* ; "Edited 6-Oct-87 14:06 by Masinter") (* ;; " termal READP: ignore EOM") (PROG NIL RETRY (COND ((SPP.READP STREAM) (RETURN T)) ((SPP.EOMP STREAM) (SPP.CLEAREOM STREAM) (GO RETRY)) (T (RETURN NIL))))) ) (GAP-SERVER-INIT (LAMBDA NIL (LET* ((DEF (GETDEF (QUOTE GAP) (QUOTE COURIERPROGRAMS))) (LST (CDDDR (ASSOC (QUOTE Create) (CL:GETF (CDR DEF) (QUOTE PROCEDURES)))))) (CL:UNLESS (EQ (CL:GETF LST (QUOTE IMPLEMENTEDBY)) (QUOTE MAKE.NS.CHAT.CONNECTION)) (CL:SETF (CL:GETF LST (QUOTE IMPLEMENTEDBY)) (QUOTE MAKE.NS.CHAT.CONNECTION)) (PUTDEF (QUOTE GAP) (QUOTE COURIERPROGRAMS) DEF))) (COURIER.START.SERVER)) ) ) (FILESLOAD COURIERSERVE CHATSERVER) (DECLARE%: DONTEVAL@LOAD DOCOPY (GAP-SERVER-INIT) (COURIER.START.SERVER) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) MODARITH) (FILESLOAD (LOADCOMP) LLNS SPP) ) (DEFMACRO CHECK (X) `(CL:ASSERT ,X)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MAKE.NS.CHAT.CONNECTION) ) (PUTPROPS CHATSERVER-NS COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1506 7035 (MAKE.NS.CHAT.CONNECTION 1516 . 3560) (NS.CHAT.SERVE 3562 . 5186) ( NSCHAT.SERVER.ATTENTION 5188 . 5454) (NSCHAT.SERVER.OUTPUTABORTED 5456 . 5543) ( NSCHAT.SERVER.WHENCLOSED 5545 . 5660) (SPP.EOMP 5662 . 5785) (\NSCHAT.BIN 5787 . 5931) (\REMOTE.EOFP 5933 . 6045) (\REMOTE.PEEKBIN 6047 . 6381) (\REMOTE.READP 6383 . 6625) (GAP-SERVER-INIT 6627 . 7033))) )) STOP \ No newline at end of file diff --git a/lispusers/CHATSERVER-RS232 b/lispusers/CHATSERVER-RS232 new file mode 100644 index 00000000..9d2ef901 --- /dev/null +++ b/lispusers/CHATSERVER-RS232 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Sep-88 17:33:28" {ERINYES}MEDLEY>CHATSERVER-RS232.;1 2044 changes to%: (FNS DO.RS232.CHAT.SERVER DO.TTY.CHAT.SERVER) previous date%: "29-Oct-87 15:36:45" {PHYLUM}LYRIC>LISPUSERS>CHATSERVER-RS232.;1) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATSERVER-RS232COMS) (RPAQQ CHATSERVER-RS232COMS ((FNS DO.RS232.CHAT.SERVER TTYCHATSERVER DO.TTY.CHAT.SERVER RS232CHATSERVER) (FILES DLRS232C CHATSERVER))) (DEFINEQ (DO.RS232.CHAT.SERVER [LAMBDA NIL (* ; "Edited 7-Sep-88 17:32 by masinter") (PROG [(INS (OPENSTREAM '{RS232} 'INPUT)) (OUTS (OPENSTREAM '{RS232} 'OUTPUT] LP (READC INS) (CHATSERVEROPENFN INS OUTS) (GO LP]) (TTYCHATSERVER (LAMBDA (BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL) (* lmm "20-Mar-86 17:34") (TTY.INIT BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL) (DEL.PROCESS (QUOTE DO.TTY.CHAT.SERVER)) (ADD.PROCESS (QUOTE (DO.TTY.CHAT.SERVER)) (QUOTE RESTARTABLE) T)) ) (DO.TTY.CHAT.SERVER [LAMBDA NIL (* ; "Edited 7-Sep-88 17:33 by masinter") (PROG [(INS (OPENSTREAM '{TTY} 'INPUT)) (OUTS (OPENSTREAM '{TTY} 'OUTPUT] LP (READC INS) (CHATSERVEROPENFN INS OUTS) (GO LP]) (RS232CHATSERVER [LAMBDA (BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL) (* ; "Edited 29-Oct-87 15:34 by masinter") (DEL.PROCESS 'RS232) (RS232C.SHUTDOWN) (RS232C.INIT BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL) (ADD.PROCESS '(DO.RS232.CHAT.SERVER) 'RESTARTABLE T 'NAME 'RS232]) ) (FILESLOAD DLRS232C CHATSERVER) (PUTPROPS CHATSERVER-RS232 COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (650 1918 (DO.RS232.CHAT.SERVER 660 . 962) (TTYCHATSERVER 964 . 1236) ( DO.TTY.CHAT.SERVER 1238 . 1534) (RS232CHATSERVER 1536 . 1916))))) STOP \ No newline at end of file diff --git a/lispusers/CHATSERVER-TCP b/lispusers/CHATSERVER-TCP new file mode 100644 index 00000000..f170f55d --- /dev/null +++ b/lispusers/CHATSERVER-TCP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Sep-88 17:13:08" {ERINYES}MEDLEY>CHATSERVER-TCP.;2 1699 changes to%: (VARS CHATSERVER-TCPCOMS) (FNS TCP.CHAT.LISTENER)) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATSERVER-TCPCOMS) (RPAQQ CHATSERVER-TCPCOMS ((FNS TCP.CHAT.LISTENER TCPCHATSERVER) (FILES TCP CHATSERVER))) (DEFINEQ (TCP.CHAT.LISTENER [LAMBDA (PORT) (* ; "Edited 2-Sep-88 23:09 by masinter") (LET* [(INSTREAM (TCP.OPEN NIL NIL (OR PORT \TCP.TELNET.PORT) 'PASSIVE 'INPUT T)) (OUTSTREAM (AND INSTREAM (TCP.OTHER.STREAM INSTREAM] (* ;; "ok, I'm the server") (PROCESS.NAME (THIS.PROCESS) 'CHATSERVER) (PROCESSPROP (THIS.PROCESS) 'RESTARTABLE NIL) (* ;; "spawn another listener") (ADD.PROCESS (LIST (FUNCTION TCP.CHAT.LISTENER) (KWOTE PORT)) 'RESTARTABLE 'HARDRESET) (PROCESSPROP (THIS.PROCESS) 'RESTARTABLE NIL) (CHATSERVEROPENFN INSTREAM OUTSTREAM]) (TCPCHATSERVER [LAMBDA NIL (* ejs%: "26-Mar-86 16:47") (DEL.PROCESS 'TCP.CHAT.LISTENER) (ADD.PROCESS '(TCP.CHAT.LISTENER) 'RESTARTABLE 'HARDRESET]) ) (FILESLOAD TCP CHATSERVER) (PUTPROPS CHATSERVER-TCP COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (484 1585 (TCP.CHAT.LISTENER 494 . 1343) (TCPCHATSERVER 1345 . 1583))))) STOP \ No newline at end of file diff --git a/lispusers/CHATSERVER.TEDIT b/lispusers/CHATSERVER.TEDIT new file mode 100644 index 00000000..c959be44 Binary files /dev/null and b/lispusers/CHATSERVER.TEDIT differ diff --git a/lispusers/CHECKSET b/lispusers/CHECKSET new file mode 100644 index 00000000..c9728c12 --- /dev/null +++ b/lispusers/CHECKSET @@ -0,0 +1 @@ +(FILECREATED " 8-JAN-83 15:26:29" CHECKSET.;3 3992 changes to: (FNS CHECKSET1) previous date: " 6-JAN-83 22:58:57" CHECKSET.;2) (* Copyright (c) 1983 by Xerox Corporation) (PRETTYCOMPRINT CHECKSETCOMS) (RPAQQ CHECKSETCOMS ((* making sure files are up to date) (FNS CHECKSET CHECKSET1 CSETASK COMPFILES) (LOCALVARS . T) (GLOBALVARS COMPILE.EXT FILERDTBL DWIMWAIT))) (* making sure files are up to date) (DEFINEQ (CHECKSET [LAMBDA (SET COMPFLG) (* lmm " 6-JAN-83 22:57") (OR COMPFLG (SETQQ COMPFLG Y)) (COND [SET (SETQ SET (CHECKSET1 (OR (LISTP SET) [LISTP (GETATOMVAL (PACK* SET (QUOTE LISPSET] (LIST SET)) COMPFLG)) (COND ((EQ COMPFLG (QUOTE N)) SET) (T (COMPFILES SET] (T (for X in FILESETS join (CHECKSET (EVAL X) COMPFLG]) (CHECKSET1 [LAMBDA (FILES COMPFLG) (* lmm " 8-JAN-83 14:31") (PROG (@COM.SOURCES .COM @LISP LISP @PREV @SOURCE NEEDCOMPILE TEM TODO SFD) (for GROUP in FILES do (SETQ NEEDCOMPILE) (SETQ @COM.SOURCES (COND [(SETQ .COM (FINDFILE [PACKFILENAME (QUOTE EXTENSION) COMPILE.EXT (QUOTE BODY) (CAR (OR (LISTP GROUP) (SETQ GROUP (LIST GROUP] T)) (INPUT (INFILE .COM)) (SKREAD .COM) (for SOURCE in GROUP collect (IDATE (CADR (READ .COM] (T (SETQQ NEEDCOMPILE COMPILE) NIL))) [for SOURCE in GROUP as @COM.SOURCE in (OR @COM.SOURCES GROUP) do (COND ((NOT (SETQ TEM (FINDFILE SOURCE T))) (PRINT (LIST SOURCE (QUOTE (not found))) T T) (SETQ NEEDCOMPILE) (RETURN))) (SETQ TEM (INPUT (INFILE TEM))) (SETFILEPTR TEM 0) (SETQ SFD (READ TEM FILERDTBL)) (CLOSEF TEM) (SETQ @PREV (AND [STRINGP (SETQ @PREV (CAR (NLEFT SFD 2] (IDATE @PREV))) (SETQ @SOURCE (IDATE (CADR SFD))) (SETQ SFD (CONS (CADR SFD) TEM)) (COND ((NEQ NEEDCOMPILE (QUOTE COMPILE)) (COND (@COM.SOURCE (COND ((NOT (IEQP @COM.SOURCE @SOURCE)) (SETQ NEEDCOMPILE (COND ((AND @PREV (IEQP @PREV @COM.SOURCE)) (QUOTE RECOMPILE)) (T (QUOTE COMPILE] [COND ((AND NEEDCOMPILE (PROGN (SETQ NEEDCOMPILE (CONS NEEDCOMPILE GROUP)) (CSETASK NEEDCOMPILE COMPFLG))) (SETQ TODO (NCONC1 TODO NEEDCOMPILE] (AND .COM (CLOSEF .COM))) (RETURN TODO]) (CSETASK [LAMBDA (Q DEFAULT) (* bvm: "30-DEC-81 12:58") (SELECTQ DEFAULT ((Y N) (MAPRINT Q T NIL " ") T) (EQ (QUOTE Y) (ASKUSER DWIMWAIT DEFAULT Q NIL T]) (COMPFILES [LAMBDA (FILES FLG) (* bvm: "30-DEC-81 13:28") (PROG [LISPXHIST (LISTING (OR (SELECTQ (COND ((LISTP FLG) (OR (CADR FLG) (CAR FLG))) (T FLG)) (F (QUOTE F)) (ST (QUOTE ST)) NIL) (QUOTE F] (DECLARE (SPECVARS LISPXHIST)) (SELECTQ (OR (CAR (LISTP FLG)) FLG) (C (SETQQ FLG COMPILE)) (RC (SETQQ FLG RECOMPILE)) NIL) (RETURN (for FL in FILES collect (SELECTQ [CAR (OR (LISTP FL) (SETQ FL (LIST FLG FL] (RECOMPILE (PRINT (CONS (QUOTE recompiling) (CDR FL)) T) (LISPXUNREAD (LIST LISTING)) (BRECOMPILE (CDR FL) NIL (QUOTE CHANGES))) (COMPILE (PRINT (CONS (QUOTE compiling) (CDR FL)) T) (LISPXUNREAD (LIST LISTING)) (BCOMPL (CDR FL))) (HELP FL]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (ADDTOVAR GLOBALVARS COMPILE.EXT FILERDTBL DWIMWAIT) ) (PUTPROPS CHECKSET COPYRIGHT ("Xerox Corporation" 1983)) (DECLARE: DONTCOPY (FILEMAP (NIL (485 3770 (CHECKSET 495 . 926) (CHECKSET1 928 . 2571) (CSETASK 2573 . 2785) (COMPFILES 2787 . 3768))))) STOP \ No newline at end of file diff --git a/lispusers/CHECKSET.TEDIT b/lispusers/CHECKSET.TEDIT new file mode 100644 index 00000000..fc858d4e Binary files /dev/null and b/lispusers/CHECKSET.TEDIT differ diff --git a/lispusers/CIRCLPRINT b/lispusers/CIRCLPRINT new file mode 100644 index 00000000..dbaf641b --- /dev/null +++ b/lispusers/CIRCLPRINT @@ -0,0 +1 @@ +(FILECREATED "30-MAY-79 00:25:14" CIRCLPRINT.;3 19722 changes to: CIRCLPRINTCOMS previous date: " 5-JUL-78 19:49:27" CIRCLPRINT.;2) (PRETTYCOMPRINT CIRCLPRINTCOMS) (RPAQQ CIRCLPRINTCOMS [(FNS CIRCLMAKER CIRCLMAKER1 CIRCLPRINT CIRCLMARK RLPRIN1 RLRESTORE CSEARCH PLACEPRINT C2PRINT ROOMLEFT RLPRIN2 CPRINT CLPRINT CIRCLNC) (VARS CIRCLMARKER) (BLOCKS (CIRCLBLOCK CIRCLMAKER CIRCLMAKER1 CIRCLPRINT CIRCLMARK RLPRIN1 RLRESTORE CSEARCH PLACEPRINT C2PRINT ROOMLEFT RLPRIN2 CPRINT CLPRINT CIRCLNC (ENTRIES CIRCLPRINT CIRCLMARK RLPRIN1 RLPRIN2 RLRESTORE CIRCLMAKER CIRCLMAKER1) (SPECVARS RLKNT LABELIST REFLIST) (LOCALFREEVARS PLACELIST LL) (NOLINKFNS . T) (GLOBALVARS #UNDOSAVES RESETVARSLST]) (DEFINEQ (CIRCLMAKER [LAMBDA (L) (* lmm: 19 MAY 75 232) (PROG (LABELIST REFLIST) (CIRCLMAKER1 L) (* An error is generated if REFLIST is non-NIL, because this means that some nodes are referenced in L without being labeled (i.e. defined) and indicates that the user may have omitted some code. See the comments in CIRCLMAKER1 for additional information.) (COND (REFLIST (ERROR (QUOTE "LABEL NOT FOUND FOR REFERENCE"))) (T (RETURN L]) (CIRCLMAKER1 [LAMBDA (L) (* This function makes use of two free variables,  REFLIST and LABELIST, which are alist-like  structures that provide information about nodes that have been defined (labeled) and where they have been referenced. LABELIST is a list of lists. Each list in labelist is of the form  (n . L), where n is the number that is being used to label the node L. REFLIST is also a list of lists. Each list in REFLIST is of the form  (n (L1 L2 ...) (L1' L2' ...)), where n is the number of the node that is being referred to, and L1,  L2,... are those nodes for which car is a reference  to {n}, and L1', L2',... are those nodes for which  cdr is a reference to {n}.) (PROG (CARL CDRL CARLN CDRLN NODECODE) [COND ((LISTP L) (SETQ CARL (CAR L)) (SETQ CDRL (CDR L] (COND [(AND CARL (ATOM CARL)) (COND [[AND (NEQ CARL (QUOTE {})) (EQ (NTHCHAR CARL 1) (QUOTE {)) (EQ (NTHCHAR CARL -1) (QUOTE })) (FIXP (SETQ CARLN (MKATOM (SUBSTRING CARL 2 -2] (* This part of the conditional checks to see  whether CARL is a reference to a node, i.e. an atom  of the form {n}, where n is a number. If so, then we check to see whether the node has yet been labeled (this is the assoc on labelist),  whether it has been previously referred to, but not  labelled (this is the assoc on reflist), or else  assume that it has neither been referred to nor  labelled previously. In the first case, we replace  (/rplaca) CARL with a pointer to the node that is  labelled n (as explained above, this would be cdr of nodecode). In the second case, we add a pointer to L to (cadr nodecode) which is that part of REFLIST  which contains pointers to those nodes for which car is the atom {n}. In the final case, we add a new  sublist to REFLIST, to record that a reference has  been made to a node numbered n. It should be noted that, throughout this program,  all such manipulations are undoable, so that the  user can (for example) control-D and undo circlmaker to regain his original expression.) (COND ((SETQ NODECODE (ASSOC CARLN LABELIST)) (/RPLACA L (CDR NODECODE))) ((SETQ NODECODE (ASSOC CARLN REFLIST)) (/NCONC1 (CADR NODECODE) L)) (T (SETQ REFLIST (/NCONC1 REFLIST (LIST CARLN (LIST L) NIL] ([AND (NEQ CARL (QUOTE *)) (NEQ CARL (QUOTE **)) (EQ (NTHCHAR CARL 1) (QUOTE *)) (EQ (NTHCHAR CARL -1) (QUOTE *)) (FIXP (SETQ CARLN (MKATOM (SUBSTRING CARL 2 -2] (* This part of the conditional checks to see  whether CARL is a label for a node, i.e. an atom of  the form *n*, where n is a number. If so, then we check to see whether a node has  already been labelled by the same number, in which  case an error is generated  (*n* is ambiguous, multiply used label). Otherwise,  we check to see that cdr of l is a list, in which  case we physically (but undoably) remove the label  from L , add a new sublist to LABELIST, and check to see whether there is a sublist on REFLIST that  indicates that references to L have already been  made. If so, then we make the appropriate changes to car and cdr of the nodes wwich referenced L, and  undoably remove the sublist  (NODECODE) from REFLIST, because the only purpose of this sublist was to preserve a record of those nodes which referenced L, before the label for L was found and the actual pointers from those nodes to L could  be established-- now that the pointers have been  established, we can decrement REFLIST-- if all nodes that are referenced are in fact labeled somewhere in the structure, then REFLIST should eventually in  this way be decremented to NIL-- otherwise the  monitoring function CIRCLMAKER will generate an  error, if it was the top level function that called  CIRCLMAKER1. Finally, we call circlmaker1  recursively on L, and return the resultant value of  L. If the original cdr of l were not a list, then we would generate the CARL "IS MISPLACED LABEL" error-- this is intended to handle expressions like  (*1* . {1}), which are anomalous because the label  does not really point to a node, and there is a  likelihood that the user has inadvertently omitted  some code.) (COND ((ASSOC CARLN LABELIST) (ERROR CARL (QUOTE "IS AMBIGUOUS, MULTIPLY USED LABEL"))) ((LISTP (CDR L)) (/RPLACA L (CADR L)) (/RPLACD L (CDDR L)) (SETQ LABELIST (/NCONC1 LABELIST (CONS CARLN L))) [COND ((SETQ NODECODE (ASSOC CARLN REFLIST)) (SETQ REFLIST (/DREMOVE NODECODE REFLIST)) [MAPC (CADR NODECODE) (FUNCTION (LAMBDA (X) (/RPLACA X L] (MAPC (CADDR NODECODE) (FUNCTION (LAMBDA (X) (/RPLACD X L] (CIRCLMAKER1 L) (RETURN L)) (T (ERROR CARL (QUOTE "IS MISPLACED LABEL"] ((LISTP CARL) (CIRCLMAKER1 CARL))) (COND [(AND CDRL (ATOM CDRL)) (COND [[AND (NEQ CDRL (QUOTE {})) (EQ (NTHCHAR CDRL 1) (QUOTE {)) (EQ (NTHCHAR CDRL -1) (QUOTE })) (FIXP (SETQ CDRLN (MKATOM (SUBSTRING CDRL 2 -2] (* This branch of the conditional checks to see  whether CDRL is a reference to a node, i.e. an atom  of the form {n} where n is a number. If so, then the steps followed are analogous to  those described above for the case in which CARL is  a reference to a node. A similar check is made below to see whether CDRL is a label for a node. An error is generated in this case, because such a  label has no meaning (the label does not point to a  node), and there is a likelihood that the user has  inadvertently omitted some code. The error message reads "*n* IS MISPLACED LABEL".) (COND ((SETQ NODECODE (ASSOC CDRLN LABELIST)) (/RPLACD L (CDR NODECODE))) ((SETQ NODECODE (ASSOC CDRLN REFLIST)) (/NCONC1 (CADDR NODECODE) L)) (T (SETQ REFLIST (/NCONC1 REFLIST (LIST CDRLN NIL (LIST L] ([AND (EQ (NTHCHAR CDRL 1) (QUOTE *)) (NEQ CDRL (QUOTE *)) (NEQ CDRL (QUOTE **)) (EQ (NTHCHAR CDRL -1) (QUOTE *)) (FIXP (MKATOM (SUBSTRING CDRL 2 -2] (ERROR CDRL (QUOTE "IS MISPLACED LABEL"] ((LISTP CDRL) (CIRCLMAKER1 CDRL))) (RETURN L]) (CIRCLPRINT [LAMBDA (L PRINTFLG RLKNT) (* lmm: 24-JAN-76 1 22) [RESETLST (RESETSAVE (RADIX 10)) (RESETVARS (#UNDOSAVES) (PROG NIL (CIRCLMARK L RLKNT) (COND (PRINTFLG (RLPRIN1 L)) (T (RLPRIN2 L))) (RLRESTORE L] L]) (CIRCLMARK [LAMBDA (L RLKNT) (* lmm: 19 MAY 75 233) (PROG NIL (COND ((NULL RLKNT) (SETQ RLKNT 0))) (RETURN (CSEARCH L]) (RLPRIN1 [LAMBDA (L) (PROG (PLACELIST LL) (SETQ PLACELIST NIL) (SETQ LL (LINELENGTH)) (CLPRINT L (QUOTE CAR)) (TERPRI]) (RLRESTORE [LAMBDA (L) (* lmm: 19 MAY 75 234) (PROG NIL (COND ((AND (LISTP L) (EQ (CAAR L) CIRCLMARKER)) (RPLACA L (CADAR L)) (RLRESTORE (CAR L)) (RLRESTORE (CDR L]) (CSEARCH [LAMBDA (L) (* lmm: 19 MAY 75 234) (PROG (NXPOINT) (COND ((LISTP L) (SETQ NXPOINT (CAR L)) [COND [(LISTP NXPOINT) (COND ((EQ (CAR NXPOINT) CIRCLMARKER) [COND ((NULL (CDDR NXPOINT)) (NCONC1 NXPOINT (SETQ RLKNT (ADD1 RLKNT] (RETURN NIL)) (T (/RPLACA L (LIST CIRCLMARKER NXPOINT)) (CSEARCH NXPOINT] (T (/RPLACA L (LIST CIRCLMARKER NXPOINT] (RETURN (CSEARCH (CDR L]) (PLACEPRINT [LAMBDA (P) (COND (P (COND ((IGREATERP (CDAR P) -1) (SPACES (IDIFFERENCE (CDAR P) (POSITION))) (PRIN1 (CAAR P)) (RPLACD (CAR P) -1))) (PLACEPRINT (CDR P]) (C2PRINT [LAMBDA (L CAMEFROM) (* lmm: 19 MAY 75 234) (PROG NIL (TERPRI) (PLACEPRINT PLACELIST) (TERPRI) (TERPRI) (RETURN (CPRINT L CAMEFROM]) (ROOMLEFT [LAMBDA NIL (IDIFFERENCE LL (POSITION]) (RLPRIN2 [LAMBDA (L) (RESETLST (PROG (PLACELIST LL) (* Rather than checking NCHARS of every atom before  printing it just to make sure that lines don't go  over the boundary (causing LISP to put in TERPRI's  where we don't want them) LINELENGTH is just changed to be something huge and we are conservative about  how much we think will fit on a line... If a structure has atoms with more than 8  characters, and appears on the end of a line, it  might overflow, though) (SETQ LL (IDIFFERENCE (LINELENGTH) 8)) (RESETSAVE (LINELENGTH (IPLUS LL 80))) (CPRINT L (QUOTE CAR)) (TERPRI) (PLACEPRINT PLACELIST) (TERPRI]) (CPRINT [LAMBDA (L CAMEFROM) (* This function does most of the work involved in  circlprinting in the double line format. IN this format, a node is labeled by the appearance  of its number on the line below where the node  begins. If the node is car of the node we came from  (i.e. if CAMEFRON = 'CAR) then the node begins with  a left parens, and the node's number should begin  immediately below that left parens. If the node is cdr of the node we came from  (i.e. if CAMEFROM = 'CDR) then the node is a tail of a list, and the number identifying it should appear  on the line below the beginning of that tail. Thus, when labeeling a node we have to save the  position where the node begins. Also, we have to alternate printing nodes and  printing their labels below them. The function that prints labels below nodes is  PLACEPRINT. CPRINT saves the information necessary  to print labels in the correct position by adding  sublists to an alist called PLACELIST. When CPRINT adds a sublist to PLACELIST, this  sublist is of the form (N . P), where N is the  number of the ndoe being labeled, and P is the  position where printing of the label should begin. When PLACEPRINT prints a line of labels, it merely  cdr's thru PLACELIST checking to see if there are  any sublists of the form (N . P), where P is greater than -1.0 For each such sublist, N is printed and  then the sublist is physically altered to be of the  form (N . -1). Thus PLACELIST can also be used as a  list of all labels that have been printed  (or will be printed, when PLACEPRINT is called next),  and CPRINT can merely do an assoc on placelist to  see if a given node has been previously labeled.) (PROG (LN N CARL CARLN CDRL CDRLN LABELEDCDRL? LABELEDCARL? EXSPACES ROOM) (COND ((ILESSP (SETQ ROOM (ROOMLEFT)) 3) (C2PRINT L CAMEFROM)) ((OR (NLISTP L) (NLISTP (CAR L)) (NEQ (CAAR L) CIRCLMARKER)) (ERROR (QUOTE "UNCIRCLMARKED LIST STRUCTURE"))) ((AND (SETQ LN (CDDAR L)) (SETQ N (CAR LN)) (FASSOC N PLACELIST)) (* L has already been printed; print a back reference) [COND ((ILESSP ROOM (IPLUS 2 (CIRCLNC N))) (RETURN (C2PRINT L CAMEFROM] (PRIN1 (QUOTE {)) (PRIN1 N) (PRIN1 (QUOTE }))) ([AND LN (ILESSP ROOM (IPLUS 3 (SETQ EXSPACES (CIRCLNC N] (C2PRINT L CAMEFROM)) (T [COND (LN (SETQ PLACELIST (NCONC1 PLACELIST (CONS (CAR LN) (POSITION] (* If LN is not NIL, the  structure needs to be labeled) [COND ((EQ CAMEFROM (QUOTE CAR)) (PRIN1 (QUOTE %(] [COND (LN (COND ((OR (NEQ EXSPACES 1) (NEQ CAMEFROM (QUOTE CAR))) (* Make sure there is enough  space to clearly label L) (SPACES EXSPACES] [COND ((NLISTP (SETQ CARL (CADAR L))) (PRIN2 CARL)) ((EQ L CARL) (COND ((ILESSP (ROOMLEFT) (IPLUS 2 EXSPACES)) (TERPRI) (PLACEPRINT PLACELIST) (TERPRI) (TERPRI))) (PRIN1 (QUOTE {)) (PRIN1 (CAR LN)) (PRIN1 (QUOTE }))) (T (CPRINT CARL (QUOTE CAR] (COND ((NULL (CDR L)) (PRIN1 (QUOTE %)))) ((NLISTP (CDR L)) (PRIN1 (QUOTE " .")) (SPACES 1) (PRIN2 (CDR L)) (PRIN1 (QUOTE %)))) ((AND (SETQ CDRLN (CDDADR L)) (FASSOC (CAR CDRLN) PLACELIST)) (* If (CDR L) has been labeled,  then print a reference.) (COND ([ILESSP (ROOMLEFT) (IPLUS 6 (CIRCLNC (CAR CDRLN] (TERPRI) (PLACEPRINT PLACELIST) (TERPRI) (TERPRI))) (PRIN1 (QUOTE " .")) (SPACES 1) (PRIN1 (QUOTE {)) (PRIN1 (CAR CDRLN)) (PRIN1 (QUOTE })) (PRIN1 (QUOTE %)))) (T (SPACES 1) (CPRINT (CDR L) (QUOTE CDR]) (CLPRINT [LAMBDA (L CAMEFROM) (* This function does most of the work involved in  cirlcprinting in the single line format. The problems encountered with the double line format (see CPRINT) do not occur here. In particular the alist PLACELIST is used by CLPRINT only to store the numbers of the reentrant nodes  that have already been labeled, not the positions  where they were labeled. CLPRINT prints a  description of each node (i.e. a label, a reference, or car and cdr) as it encounters it.) (PROG (LN N LABELIT CARL CDRL CDRLN LISTPCDRL? LABELEDCDRL? EXSPACES) (COND ((ILESSP (ROOMLEFT) 2) (TERPRI))) (COND ((LISTP L) (COND ((NOT (EQ (CAAR L) CIRCLMARKER)) (ERROR (QUOTE "UNCIRCLMARKED LIST STRUCTURE"))) ((AND (SETQ LN (CDDAR L)) (SETQ N (CAR LN)) (SETQ EXSPACES (CIRCLNC N)) (FMEMB N PLACELIST)) (* If L is a reentrant node and has already been  labeled then we simply print a reference to L. CIRCLNC computes the number of digits in N which is  2 less than the number of characters needed to label or reference L, and makes it the value of EXSPACES. If N is greater than or equal to 10000, then an  error is generated. Otherwise, the FMEMB on  placelist checks to see if L has already been  labeled, in which case we print a reference to L, in the code below this comment.) (COND ((ILESSP (ROOMLEFT) (IPLUS 2 EXSPACES)) (TERPRI))) (PRIN1 (QUOTE {)) (PRIN1 N) (PRIN1 (QUOTE }))) (T (COND (LN (* Checks to see if L has to be  labeled.) (COND ((ILESSP (ROOMLEFT) (IPLUS 3 EXSPACES)) (TERPRI))) (SETQ LABELIT T))) [COND (LABELIT (* If L is to be labeled, then  add N to placelist.) (SETQ PLACELIST (NCONC PLACELIST LN] [COND ((EQ CAMEFROM (QUOTE CAR)) (PRIN1 (QUOTE %(] (COND (LABELIT (* If L is to be labeled, then  print a label.) (PRIN1 (QUOTE *)) (PRIN1 (CAR LN)) (PRIN1 (QUOTE *)) (SPACES 1))) (COND [(LISTP (SETQ CARL (CADAR L))) (* If CARL is a list then if L = CARL then print a  reference to CARL automatically, else CPRINT CARL.) (COND ((EQ L CARL) (COND ((ILESSP (ROOMLEFT) (IPLUS 2 EXSPACES)) (TERPRI))) (PRIN1 (QUOTE {)) (PRIN1 (CAR LN)) (PRIN1 (QUOTE }))) (T (CLPRINT CARL (QUOTE CAR] (T (PRIN2 CARL))) (COND ((LISTP (SETQ CDRL (CDR L))) (* Check whether CDRL needs to  be labeled.) (COND ((AND (SETQ CDRLN (CDDADR L)) (FMEMB (CAR CDRLN) PLACELIST)) (SETQ LABELEDCDRL? T)) (T (SETQ LABELEDCDRL? NIL))) (SETQ LISTPCDRL? T)) (T (SETQ LISTPCDRL? NIL))) (COND (CDRL (* make sure there will be a  space between carl and cdrl.) (SPACES 1))) (COND [LISTPCDRL? (* If CDRL has been labeled and is reentrant, then  print a reference. Else if CDRL is a list the  CLPRINT CDRL, else just prin1 it.) (COND (LABELEDCDRL? (SETQ N (CAR CDRLN)) (COND ((ILESSP (ROOMLEFT) (IPLUS 5 (CIRCLNC N))) (TERPRI))) (PRIN1 (QUOTE %.)) (SPACES 1) (PRIN1 (QUOTE {)) (PRIN1 (CAR CDRLN)) (PRIN1 (QUOTE })) (PRIN1 (QUOTE %)))) (T (CLPRINT CDRL (QUOTE CDR] ((NULL CDRL) (PRIN1 (QUOTE %)))) (T (PRIN1 (QUOTE %.)) (SPACES 1) (PRIN2 CDRL) (PRIN1 (QUOTE %)]) (CIRCLNC [LAMBDA (N) (COND ((ILESSP N 10) 1) ((ILESSP N 100) 2) ((ILESSP N 1000) 3) ((ILESSP N 10000) 4) (T (ERROR (QUOTE "REENTRANT NODE HAS BEEN NUMBERD OVER 10000"]) ) (RPAQQ CIRCLMARKER "BEENHERE") [DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK: CIRCLBLOCK CIRCLMAKER CIRCLMAKER1 CIRCLPRINT CIRCLMARK RLPRIN1 RLRESTORE CSEARCH PLACEPRINT C2PRINT ROOMLEFT RLPRIN2 CPRINT CLPRINT CIRCLNC (ENTRIES CIRCLPRINT CIRCLMARK RLPRIN1 RLPRIN2 RLRESTORE CIRCLMAKER CIRCLMAKER1) (SPECVARS RLKNT LABELIST REFLIST) (LOCALFREEVARS PLACELIST LL) (NOLINKFNS . T) (GLOBALVARS #UNDOSAVES RESETVARSLST)) ] (DECLARE: DONTCOPY (FILEMAP (NIL (798 19253 (CIRCLMAKER 808 . 1331) (CIRCLMAKER1 1335 . 8241) (CIRCLPRINT 8245 . 8552) ( CIRCLMARK 8554 . 8739) (RLPRIN1 8743 . 8914) (RLRESTORE 8916 . 9169) (CSEARCH 9171 . 9675) (PLACEPRINT 9679 . 9909) (C2PRINT 9911 . 10133) (ROOMLEFT 10137 . 10194) (RLPRIN2 10198 . 10942) (CPRINT 10946 . 15100) (CLPRINT 15104 . 19037) (CIRCLNC 19041 . 19251))))) STOP P \ No newline at end of file diff --git a/lispusers/CIRCLPRINT.SKETCH b/lispusers/CIRCLPRINT.SKETCH new file mode 100644 index 00000000..a5e93a28 Binary files /dev/null and b/lispusers/CIRCLPRINT.SKETCH differ diff --git a/lispusers/CL-TTYEDIT b/lispusers/CL-TTYEDIT new file mode 100644 index 00000000..6d13f353 --- /dev/null +++ b/lispusers/CL-TTYEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "19-Apr-88 12:01:09" {erinyes}medley>cl-ttyedit.\;2 4515 |changes| |to:| (vars cl-ttyeditcoms) (usermacros ||) |previous| |date:| "29-Oct-87 11:59:24" {erinyes}medley>cl-ttyedit.\;1) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint cl-ttyeditcoms) (rpaqq cl-ttyeditcoms ((vars (**comment**flg ";..") (editrdtbl nil) (dummy nil)) (p (setq postgreetforms (remove (find x in postgreetforms suchthat (and (eq (car x) 'and) (eq (cadr x) 'editcharacters))) postgreetforms))) (variables edit-atoms) (functions subpat) (p (unadvise editfpat \\editblock/editcoma \\editblock/editcoml editl) (* "This is because EDITCOMA attempts to rebind RDTBL to EDITRDTBL on PP -- a useless thing, but PP will error if *READTABLE* is NIL" ) (changename '\\editblock/editcoma '*readtable* 'dummy)) (advise editl editfpat \\editblock/editcoma \\editblock/editcoml) (usermacros ||))) (rpaq **comment**flg ";..") (rpaqq editrdtbl nil) (rpaqq dummy nil) (setq postgreetforms (remove (find x in postgreetforms suchthat (and (eq (car x) 'and) (eq (cadr x) 'editcharacters))) postgreetforms)) (cl:defparameter edit-atoms '(("--" . --) ("&" . &) ("*ANY*" . *any*) ("---" . |..|) ("==" . ==)) ) (cl:defun subpat (x) (|if| (litatom x) |then| (|for| p |in| edit-atoms |when| (strequal (car p) x) |do| (return (cdr p)) |finally| (return x)) |else| x)) (unadvise editfpat \\editblock/editcoma \\editblock/editcoml editl) (* "This is because EDITCOMA attempts to rebind RDTBL to EDITRDTBL on PP -- a useless thing, but PP will error if *READTABLE* is NIL" ) (changename '\\editblock/editcoma '*readtable* 'dummy) (xcl:reinstall-advice 'editl :around '((:last (let ((*readtable* *readtable*) (name (readtableprop *readtable* 'name))) (if (or (null name) (strpos "EDIT-" name)) then (setq editrdtbl *readtable*) else (or (find-readtable (setq name (concat "EDIT-" name))) (progn (setq editrdtbl (copyreadtable *readtable*)) (readtableprop editrdtbl 'name name) (apply 'settermchars editcharacters))) (setq *readtable* editrdtbl)) *)))) (xcl:reinstall-advice 'editfpat :before '((:last (setq pat (subpat pat))))) (xcl:reinstall-advice '\\editblock/editcoma :before '((:last (setq c (mkatom (u-case (mkstring c))))) )) (xcl:reinstall-advice '\\editblock/editcoml :before '((:last (and (litatom (car c)) (rplaca c (mkatom (u-case (mkstring (car c))))))))) (readvise editl editfpat \\editblock/editcoma \\editblock/editcoml) (addtovar usermacros (|| (a . b) up (1 a . b))) (addtovar editcomsl ||) (putprops cl-ttyedit copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil))) stop \ No newline at end of file diff --git a/lispusers/CL-TTYEDIT.TEDIT b/lispusers/CL-TTYEDIT.TEDIT new file mode 100644 index 00000000..78858b13 Binary files /dev/null and b/lispusers/CL-TTYEDIT.TEDIT differ diff --git a/lispusers/COLOR b/lispusers/COLOR new file mode 100644 index 00000000..13695db2 --- /dev/null +++ b/lispusers/COLOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED "27-Jan-87 15:56:46" {ERIS}NEXT>COLOR.;2 65054 changes to%: (VARS COLORCOMS EditColorMapHeight EditColorMapWidth DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM DICOLOR.hueConstants DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange DICOLOR.saturationConstants DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid DICOLOR.lightnessConstants DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white) (FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVELS HLSLEVEL HLSTORGB HLSVALUEFN HLSVALUEFROMLEVEL LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS OVERPAINT BITMAPFROMSTRING SHADEBITMAP EDITCOLORMAP GETCOLOR#FROMUSER GETCOLOR#FROMSCREEN DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT OUTLINEAREA OUTLINEREGION ADJUSTCOLORMAP SHOWCOLORBLOCKS MAPOFACOLOR CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS RGBTOCNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN DICOLOR.saturationNvalue DICOLOR.saturationNname) (RECORDS hueRecord lightnessRecord saturationRecord) previous date%: "16-Jan-87 18:20:53" {ERIS}NEXT>COLOR.;1) (* " Copyright (c) 1982, 1983, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COLORCOMS) (RPAQQ COLORCOMS [(FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVELS HLSLEVEL HLSTORGB HLSVALUEFN HLSVALUEFROMLEVEL LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS) (FNS OVERPAINT BITMAPFROMSTRING SHADEBITMAP) (INITVARS (EDITCOLORMAP.WINDOW NIL)) (FNS EDITCOLORMAP EDITCOLORMAP.BUTTONEVENTFN EDITCOLORMAP.REDISPLAYFN EDITCOLORMAP.VALUELEVEL EDITCOLORMAP.WINDOWLEVEL CHANGECOLORLEVELS GETCOLOR#FROMUSER GETCOLOR#FROMSCREEN DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT OUTLINEAREA OUTLINEREGION) (FNS ADJUSTCOLORMAP SHOWCOLORBLOCKS MAPOFACOLOR COLORHEXPATTERN) (VARS EditColorMapHeight EditColorMapWidth (COLOR#MENUSAVE) (CONTROLMENUSAVE) (EDIT8BITCOLORMAPMENU) (EDIT8BITCOLORMAPNUMBERREADER)) (GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER EditColorMapHeight EditColorMapWidth) (COMS (* ;;; "support for global naming and querying of colors.") (FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS RGBTOCNS) (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM) (INITVARS (COLORNAMEMENU)) (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN DICOLOR.saturationNvalue DICOLOR.saturationNname) (DECLARE%: EVAL@LOAD DONTCOPY (*) (RECORDS hueRecord lightnessRecord saturationRecord) (CONSTANTS * DICOLOR.hueConstants) (CONSTANTS * DICOLOR.saturationConstants) (CONSTANTS * DICOLOR.lightnessConstants)) (P (CNSMENUINIT))) (FILES LLCOLOR READNUMBER) (P (SETQ EDITBMMENU NIL) (MOVD 'ARRAYP 'COLORMAPP]) (DEFINEQ (DISPLAYCOLORLEVELS [LAMBDA (WINDOW RGB) (* kbr%: " 3-Jun-86 19:45") (PROG (HLS) (DISPLAYCOLORLEVEL WINDOW 'RED (fetch (RGB RED) of RGB) (fetch (RGB RED) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'GREEN (fetch (RGB GREEN) of RGB) (fetch (RGB GREEN) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'BLUE (fetch (RGB BLUE) of RGB) (fetch (RGB BLUE) of RGB)) (SETQ HLS (RGBTOHLS RGB)) (DISPLAYCOLORLEVEL WINDOW 'HUE (fetch (HLS HUE) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'HUE (fetch (HLS HUE) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'SATURATION (fetch (HLS SATURATION) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'SATURATION (fetch (HLS SATURATION) of HLS]) (DISPLAYHLSLEVELS [LAMBDA (HLS WIN) (* rrb "25-OCT-82 14:08") (* displays a hue lightness saturation triple in the edit window.) (DISPLAYHLSLEVEL HLS 'HUE NIL WIN) (DISPLAYHLSLEVEL HLS 'LIGHTNESS NIL WIN) (DISPLAYHLSLEVEL HLS 'SATURATION NIL WIN]) (HLSLEVEL [LAMBDA (HLS FIELD NEWLEVEL) (* rrb "25-OCT-82 13:29") (* returns the value of the named field from a hue lightness saturation record.) (SELECTQ FIELD (HUE (PROG1 (fetch (HLS HUE) of HLS) (AND NEWLEVEL (replace (HLS HUE) of HLS with NEWLEVEL)))) (LIGHTNESS (PROG1 (fetch (HLS LIGHTNESS) of HLS) (AND NEWLEVEL (replace (HLS LIGHTNESS) of HLS with NEWLEVEL)))) (SATURATION (PROG1 (fetch (HLS SATURATION) of HLS) (AND NEWLEVEL (replace (HLS SATURATION) of HLS with NEWLEVEL)))) (SHOULDNT]) (HLSTORGB [LAMBDA (HLS LIGHTNESS SATURATION) (* kbr%: " 3-Jun-86 21:16") (* Converts from a hue saturation lightness triple into red green blue triple.  HUE is in range 0 to 360, lightness and saturation are in the range 0 to 1.0 *) (* This algorithm was taken from siggraph vol 13 number 3 August 1979%: Status  report on graphics standards planning committee.  *) (PROG (HUE M1 M2 RGB) (COND ((LISTP HLS) (SETQ HUE (fetch (HLS HUE) of HLS)) (SETQ LIGHTNESS (fetch (HLS LIGHTNESS) of HLS)) (SETQ SATURATION (fetch (HLS SATURATION) of HLS))) (T (SETQ HUE HLS))) [SETQ M1 (COND ((FGREATERP 0.5 LIGHTNESS) (FTIMES LIGHTNESS (FPLUS 1.0 SATURATION))) (T (FDIFFERENCE (FPLUS LIGHTNESS SATURATION) (FTIMES LIGHTNESS SATURATION] (SETQ M2 (FDIFFERENCE (FTIMES 2.0 LIGHTNESS) M1)) [SETQ RGB (create RGB RED _ (HLSVALUEFN M1 M2 HUE) GREEN _ (HLSVALUEFN M1 M2 (IDIFFERENCE HUE 120)) BLUE _ (HLSVALUEFN M1 M2 (IDIFFERENCE HUE 240] (RETURN RGB]) (HLSVALUEFN [LAMBDA (M1 M2 HUE) (* kbr%: " 3-Jun-86 20:45") (* Internal value function for converting from HLS to RGB.  *) (SETQ HUE (IMOD HUE 360)) (FIX (FTIMES (COND ((ILESSP HUE 60) M1) [(ILESSP HUE 120) (FPLUS M1 (FTIMES (FQUOTIENT (FDIFFERENCE HUE 60) 60) (FDIFFERENCE M2 M1] ((ILESSP HUE 240) M2) [(ILESSP HUE 300) (FPLUS M2 (FTIMES (FQUOTIENT (FDIFFERENCE HUE 240) 60) (FDIFFERENCE M1 M2] (T M1)) 255]) (HLSVALUEFROMLEVEL [LAMBDA (HLS LEVEL) (* rrb "25-OCT-82 13:26") (* returns the scaled value of the hls marker on a scale from 0 to 255) (SELECTQ HLS (HUE (IQUOTIENT (ITIMES LEVEL 360) 255)) (FQUOTIENT LEVEL 255]) (LEVELFROMHLSVALUE [LAMBDA (HLS LEVEL) (* rrb "25-OCT-82 14:06") (* returns the level on a scale from 0 to 255 that this value would have.) (SELECTQ HLS (HUE (IQUOTIENT (ITIMES LEVEL 255) 360)) (FIX (FTIMES LEVEL 255]) (RAINBOWMAP [LAMBDA (NBITS) (* rrb "21-OCT-82 18:14") [OR NBITS (NULL (COLORDISPLAYP)) (SETQ NBITS (COLORMAPBITS (SCREENCOLORMAP] (COLORMAPCREATE (COND [(EQ NBITS 8) (PROG (MAXINTENSITY MINVISIBLERED MINVISIBLEBLUE MINVISIBLEGREEN NSTEPS REDSTEPSIZE GREENSTEPSIZE BLUESTEPSIZE) (SETQ MAXINTENSITY 255) (SETQ MINVISIBLERED 69) (SETQ MINVISIBLEBLUE 38) (SETQ MINVISIBLEGREEN 38) (SETQ NSTEPS (IQUOTIENT (EXPT 2 NBITS) 8)) (* determine how many steps are available for each transition from one color to  the next. There are 8 such transitions. red up, green up, red down, blue up,  green down, red up, green up, all down) (* minimum visible intensity values were emperically determined but will differ  depending upon the brightness setting of the individual display.  They are also diddled to make the numer of steps come out right.) (RETURN (NCONC (for I from MINVISIBLERED to MAXINTENSITY by (SETQ REDSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY MINVISIBLERED ) NSTEPS -2) NSTEPS)) collect (* red up) (LIST I 0 0)) (for I from MINVISIBLEGREEN to MAXINTENSITY by (SETQ GREENSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY MINVISIBLEGREEN ) -1 NSTEPS) NSTEPS)) collect (* GREEN UP) (LIST 255 I 0)) (for I from REDSTEPSIZE to (IDIFFERENCE MAXINTENSITY MINVISIBLERED) by REDSTEPSIZE collect (* red down) (LIST (IDIFFERENCE MAXINTENSITY I) 255 0)) (CONS '(0 255 0)) (for I from MINVISIBLEBLUE to MAXINTENSITY by (SETQ BLUESTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY MINVISIBLEBLUE ) -1 NSTEPS) NSTEPS)) collect (* BLUE UP) (LIST 0 255 I)) (for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY MINVISIBLEGREEN) by GREENSTEPSIZE collect (* GREEN down) (LIST 0 (IDIFFERENCE MAXINTENSITY I) 255)) (CONS '(0 0 255)) (for I from MINVISIBLERED to MAXINTENSITY by REDSTEPSIZE collect (* red up) (LIST I 0 255)) (for I from MINVISIBLEGREEN to MAXINTENSITY by GREENSTEPSIZE collect (* GREEN UP) (LIST 255 I 255)) (for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY MINVISIBLEGREEN) by GREENSTEPSIZE collect (* all down) (LIST (IDIFFERENCE MAXINTENSITY I) (IDIFFERENCE MAXINTENSITY I) (IDIFFERENCE MAXINTENSITY I))) (CONS '(0 0 0] (T RAINBOWINTENSITIES)) NBITS]) (RGBTOHLS [LAMBDA (RGB GREEN BLUE) (* kbr%: " 3-Jun-86 20:13") (* Converts from a red green blue triple of color information into a hue  lightness saturation triple. *) (* This algorithm was taken from Procedural Elements for Computer Graphics 1985  page 405 by David F. Rogers *) (PROG (RED CR CG CB M1 M2 LIGHTNESS HLS) (COND ((LISTP RGB) (SETQ RED (fetch (RGB RED) of RGB)) (SETQ GREEN (fetch (RGB GREEN) of RGB)) (SETQ BLUE (fetch (RGB BLUE) of RGB))) (T (SETQ RED RGB))) (SETQ M1 (MAX RED GREEN BLUE)) (SETQ M2 (MIN RED GREEN BLUE)) (SETQ LIGHTNESS (FQUOTIENT (FPLUS (FQUOTIENT M1 255) (FQUOTIENT M2 255)) 2)) [SETQ HLS (COND ((EQ M1 M2) (create HLS HUE _ 0 LIGHTNESS _ LIGHTNESS SATURATION _ 0.0)) (T (SETQ CR (FQUOTIENT (IDIFFERENCE M1 RED) (IDIFFERENCE M1 M2))) (SETQ CG (FQUOTIENT (IDIFFERENCE M1 GREEN) (IDIFFERENCE M1 M2))) (SETQ CB (FQUOTIENT (IDIFFERENCE M1 BLUE) (IDIFFERENCE M1 M2))) (create HLS HUE _ (IMOD (FIX (FTIMES [COND ((EQ M1 RED) (FDIFFERENCE CB CG)) ((EQ M1 GREEN) (FPLUS 2.0 (FDIFFERENCE CR CB))) (T (FPLUS 4.0 (FDIFFERENCE CG CR] 60.0)) 360) LIGHTNESS _ LIGHTNESS SATURATION _ (COND ((FGREATERP 0.5 LIGHTNESS) (FQUOTIENT (IDIFFERENCE M1 M2) (IPLUS M1 M2))) (T (FQUOTIENT (IDIFFERENCE M1 M2) (IDIFFERENCE (ITIMES 2 255) (IPLUS M1 M2] (RETURN HLS]) ) (DEFINEQ (OVERPAINT [LAMBDA (BM1 BM2 X Y TXT SCR) (* kbr%: " 2-Sep-85 20:30") (* Uses BM1 as a mask thru which it paints the INVERSE of texture onto BM2 at  position X Y) (PROG (BMW BMH) (SETQ BMW (BITMAPWIDTH BM1)) (SETQ BMH (BITMAPHEIGHT BM1)) (OR SCR (SETQ SCR (BITMAPCOPY BM1))) (* We need a scratch BM.  Most demos cache one) (BITBLT BM1 0 0 SCR 0 0 BMW BMH 'INPUT 'REPLACE) (BITBLT NIL NIL NIL SCR 0 0 BMW BMH 'TEXTURE 'ERASE TXT) (BITBLT BM1 0 0 BM2 X Y BMW BMH 'INPUT 'ERASE) (BITBLT SCR 0 0 BM2 X Y BMW BMH 'INPUT 'PAINT]) (BITMAPFROMSTRING [LAMBDA (STRING FONT BITSPERPIXEL) (* kbr%: "11-Aug-85 16:14") (PROG (BITMAP DS) (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH STRING FONT) (FONTPROP FONT 'HEIGHT) BITSPERPIXEL)) (SETQ DS (DSPCREATE BITMAP)) (DSPFONT FONT DS) (MOVETO 0 (FONTPROP FONT 'DESCENT) DS) (PRIN3 STRING DS) (RETURN BITMAP]) (SHADEBITMAP [LAMBDA (BM T0 T1) (* bas%: "25-APR-82 15:02") (* Shades bitmap BM with T0 into 0 areas and T1 into 1 areas) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'INVERT (LOGAND T0 (LOGXOR T0 T1))) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'PAINT (LOGAND T0 T1)) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'ERASE (LOGXOR (LOGOR T0 T1) 65535]) ) (RPAQ? EDITCOLORMAP.WINDOW NIL) (DEFINEQ (EDITCOLORMAP [LAMBDA NIL (* kbr%: " 5-Jun-86 22:49") (* Colormap Editor. Let's user  interactively adjust colormap.  *) (PROG (XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM) (COND ((NULL EDITCOLORMAP.WINDOW) (SETQ EDITCOLORMAP.WINDOW (CREATEW (GETBOXREGION EditColorMapWidth EditColorMapHeight NIL NIL NIL "Select location of Colormap Editor window.") "Colormap Editor")) (CLRPROMPT) (WINDOWPROP EDITCOLORMAP.WINDOW 'BUTTONEVENTFN 'EDITCOLORMAP.BUTTONEVENTFN) (WINDOWPROP EDITCOLORMAP.WINDOW 'REPAINTFN 'EDITCOLORMAP.REDISPLAYFN) (WINDOWPROP EDITCOLORMAP.WINDOW 'COLOR 0)) (T (CLEARW EDITCOLORMAP.WINDOW))) (REDISPLAYW EDITCOLORMAP.WINDOW]) (EDITCOLORMAP.BUTTONEVENTFN [LAMBDA (WINDOW) (* kbr%: " 4-Jun-86 21:21") (* Colormap editor. Displays a colormap in a window and allows the user to  change it. *) (PROG (REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM COLOR COLORMAP LEVEL LASTX LASTY HLS OLDLEVEL COMPONENT) (PROGN (SETQ REDREGION (WINDOWPROP WINDOW 'REDREGION)) (SETQ GREENREGION (WINDOWPROP WINDOW 'GREENREGION)) (SETQ BLUEREGION (WINDOWPROP WINDOW 'BLUEREGION)) (SETQ HUEREGION (WINDOWPROP WINDOW 'HUEREGION)) (SETQ LIGHTNESSREGION (WINDOWPROP WINDOW 'LIGHTNESSREGION)) (SETQ SATURATIONREGION (WINDOWPROP WINDOW 'SATURATIONREGION)) (SETQ BOTTOM (fetch (REGION BOTTOM) of REDREGION))) (SETQ COLOR (WINDOWPROP WINDOW 'COLOR)) (SETQ COLORMAP (SCREENCOLORMAP)) (COND [(LASTMOUSESTATE MIDDLE) (COND ((NUMBERP (SETQ LEVEL (GETCOLOR#FROMUSER))) (WINDOWPROP WINDOW 'COLOR LEVEL) (REDISPLAYW WINDOW] ((LASTMOUSESTATE LEFT) (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)) (COND ([SETQ COMPONENT (COND ((INSIDEP REDREGION LASTX LASTY) 'RED) ((INSIDEP GREENREGION LASTX LASTY) 'GREEN) ((INSIDEP BLUEREGION LASTX LASTY) 'BLUE) ((INSIDEP HUEREGION LASTX LASTY) 'HUE) ((INSIDEP LIGHTNESSREGION LASTX LASTY) 'LIGHTNESS) ((INSIDEP SATURATIONREGION LASTX LASTY) 'SATURATION] (SETQ OLDLEVEL (WINDOWPROP WINDOW COMPONENT)) (until (MOUSESTATE (NOT LEFT)) do (* As long as LEFT is down, adjust the color.  *) [SETQ LEVEL (IMIN 255 (IMAX 0 (IDIFFERENCE (LASTMOUSEY WINDOW ) BOTTOM] (COND ((NOT (EQ LEVEL OLDLEVEL)) (CHANGECOLORLEVELS WINDOW COMPONENT LEVEL) [SCREENCOLORMAPENTRY COLOR (create RGB RED _ (WINDOWPROP WINDOW 'RED) GREEN _ (WINDOWPROP WINDOW 'GREEN) BLUE _ (WINDOWPROP WINDOW 'BLUE] (SETQ OLDLEVEL LEVEL]) (EDITCOLORMAP.REDISPLAYFN [LAMBDA (WINDOW) (* kbr%: " 4-Jun-86 20:46") (* Colormap Editor. Let's user  interactively adjust colormap.  *) (PROG (XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM COLORMAP COLOR) (CLEARW WINDOW) (PROGN (MOVETO 35 4 WINDOW) (PRIN1 "RED" WINDOW) (SETQ REDREGION '(40 16 10 256)) (OUTLINEREGION REDREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'REDREGION REDREGION)) (PROGN (MOVETO 70 4 WINDOW) (PRIN1 "GREEN" WINDOW) (SETQ GREENREGION '(82 16 10 256)) (OUTLINEREGION GREENREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'GREENREGION GREENREGION)) (PROGN (MOVETO 119 4 WINDOW) (PRIN1 "BLUE" WINDOW) (SETQ BLUEREGION '(128 16 10 256)) (OUTLINEREGION BLUEREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'BLUEREGION BLUEREGION)) (PROGN (MOVETO 181 4 WINDOW) (PRIN1 "HUE" WINDOW) (SETQ HUEREGION '(186 16 10 256)) (OUTLINEREGION HUEREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'HUEREGION HUEREGION)) (PROGN (MOVETO 216 4 WINDOW) (PRIN1 "LIGHTNESS" WINDOW) (SETQ LIGHTNESSREGION '(242 16 10 256)) (OUTLINEREGION LIGHTNESSREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'LIGHTNESSREGION LIGHTNESSREGION)) (PROGN (MOVETO 300 4 WINDOW) (PRIN1 "SAT" WINDOW) (SETQ SATURATIONREGION '(305 16 10 256)) (OUTLINEREGION SATURATIONREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'SATURATIONREGION SATURATIONREGION)) (PROGN (SETQ COLORMAP (SCREENCOLORMAP)) (SETQ COLOR (WINDOWPROP WINDOW 'COLOR)) (MOVETO 8 250 WINDOW) (printout WINDOW |.I3| COLOR) (DISPLAYCOLORLEVELS WINDOW (ELT COLORMAP COLOR]) (EDITCOLORMAP.VALUELEVEL [LAMBDA (COMPONENT WINDOWLEVEL) (* kbr%: " 3-Jun-86 19:55") (* * Value that would be stored in an RGB or HLS corresponding to WINDOWLEVEL.  *) (SELECTQ COMPONENT (HUE (IQUOTIENT (ITIMES WINDOWLEVEL 360) 255)) ((LIGHTNESS SATURATION) (FQUOTIENT WINDOWLEVEL 255)) ((RED GREEN BLUE) WINDOWLEVEL) (SHOULDNT]) (EDITCOLORMAP.WINDOWLEVEL [LAMBDA (COMPONENT VALUELEVEL) (* kbr%: " 3-Jun-86 19:55") (* * Given VALUELEVEL of an RGB or HLS, what WINDOWLEVEL should be used to  display it? *) (SELECTQ COMPONENT (HUE (IQUOTIENT (ITIMES VALUELEVEL 255) 360)) ((LIGHTNESS SATURATION) (FIX (FTIMES VALUELEVEL 255))) ((RED GREEN BLUE) VALUELEVEL) (SHOULDNT]) (CHANGECOLORLEVELS [LAMBDA (WINDOW COMPONENT WINDOWLEVEL) (* kbr%: " 3-Jun-86 19:55") (PROG (RGB HLS) (DISPLAYCOLORLEVEL WINDOW COMPONENT (EDITCOLORMAP.VALUELEVEL COMPONENT WINDOWLEVEL) WINDOWLEVEL) (SELECTQ COMPONENT ((RED GREEN BLUE) [SETQ HLS (RGBTOHLS (WINDOWPROP WINDOW 'RED) (WINDOWPROP WINDOW 'GREEN) (WINDOWPROP WINDOW 'BLUE] (DISPLAYCOLORLEVEL WINDOW 'HUE (fetch (HLS HUE) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'HUE (fetch (HLS HUE) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'SATURATION (fetch (HLS SATURATION) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'SATURATION (fetch (HLS SATURATION) of HLS)))) ((HUE LIGHTNESS SATURATION) [SETQ RGB (HLSTORGB (EDITCOLORMAP.VALUELEVEL 'HUE (WINDOWPROP WINDOW 'HUE)) (EDITCOLORMAP.VALUELEVEL 'LIGHTNESS (WINDOWPROP WINDOW 'LIGHTNESS)) (EDITCOLORMAP.VALUELEVEL 'SATURATION (WINDOWPROP WINDOW 'SATURATION] (DISPLAYCOLORLEVEL WINDOW 'RED (fetch (RGB RED) of RGB) (fetch (RGB RED) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'GREEN (fetch (RGB GREEN) of RGB) (fetch (RGB GREEN) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'BLUE (fetch (RGB BLUE) of RGB) (fetch (RGB BLUE) of RGB))) (SHOULDNT]) (GETCOLOR#FROMUSER [LAMBDA NIL (* edited%: " 8-SEP-82 21:44") (* reads a color number from the user.) (PROG (RESPONSE) (MOVEW [COND ((TYPENAMEP EDIT8BITCOLORMAPNUMBERREADER 'WINDOW) EDIT8BITCOLORMAPNUMBERREADER) (T (SETQ EDIT8BITCOLORMAPNUMBERREADER (CREATE.NUMBERPAD.READER '(Enter color number to edit%:) (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY] (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)) LP (COND ([NULL (ERSETQ (SETQ RESPONSE (NUMBERPAD.READ EDIT8BITCOLORMAPNUMBERREADER] (* currently there is no way NIL can be returned from NUMBERPAD.READ but there  should be a way to quit.) (RETURN NIL)) ((OR (ILESSP RESPONSE 0) (IGREATERP RESPONSE 255)) (PROMPTPRINT "Color numbers must be between 0 and 255.") (GO LP)) (T (RETURN RESPONSE]) (GETCOLOR#FROMSCREEN [LAMBDA NIL (* rrb " 3-NOV-82 13:57") (* returns the color number of a point selected by the user.) (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (PROG (POS) (SETQ POS (GETPOSITION)) (RETURN (AND POS (BITMAPBIT (COLORSCREENBITMAP) (fetch (POSITION XCOORD) of POS) (fetch (POSITION YCOORD) of POS]) (DISPLAYCOLORLEVEL [LAMBDA (WINDOW COMPONENT NEWLEVEL WINDOWLEVEL) (* kbr%: " 4-Jun-86 20:23") (PROG (REGION) (WINDOWPROP WINDOW COMPONENT WINDOWLEVEL) (SETQ REGION (SELECTQ COMPONENT (RED (WINDOWPROP WINDOW 'REDREGION)) (BLUE (WINDOWPROP WINDOW 'BLUEREGION)) (GREEN (WINDOWPROP WINDOW 'GREENREGION)) (HUE (WINDOWPROP WINDOW 'HUEREGION)) (LIGHTNESS (WINDOWPROP WINDOW 'LIGHTNESSREGION)) (SATURATION (WINDOWPROP WINDOW 'SATURATIONREGION)) (SHOULDNT))) [PROGN (* Print out new level of COMPONENT.  *) (MOVETO (IDIFFERENCE (fetch (REGION LEFT) of REGION) 12) (IPLUS 8 (fetch (REGION TOP) of REGION)) WINDOW) (* Overstrike extra digits in case the old value was larger.  *) (COND ((FIXP NEWLEVEL) (printout WINDOW " " |.I3| NEWLEVEL)) (T (printout WINDOW |.F5.3| NEWLEVEL] (FILLINREGION REGION WINDOWLEVEL GRAYSHADE WINDOW]) (FILLINREGION [LAMBDA (REGION HEIGHT GRAY WINDOW) (* rrb "23-FEB-82 12:26") (* fills part of a region with gray.) (DSPFILL REGION WHITESHADE 'REPLACE WINDOW) (AREAFILL (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) HEIGHT GRAY 'REPLACE WINDOW]) (AREAFILL [LAMBDA (LFT BTM WDTH HGTH SHADE OPERATION WINDOW) (* fills an area of a window with  shade.) (BITBLT NIL NIL NIL WINDOW LFT BTM WDTH HGTH 'TEXTURE OPERATION SHADE]) (CENTEREDLEFT [LAMBDA (WIDTH LEFT RIGHT) (* rrb "16-FEB-82 14:58") (* returns the left point that would leave WIDTH centered between LEFT and  RIGHT) (IQUOTIENT (IDIFFERENCE (IPLUS LEFT RIGHT) WIDTH) 2]) (OUTLINEAREA [LAMBDA (LFT BTM WDTH HGHT LINEWIDTH OPERATION WIN) (* rrb "17-FEB-82 10:59") (* outlines an area of a window.) (PROG (LEFTPLUSWIDTH RIGHTLINELEFT VERTLINETOP TOPY LINEWIDTH) (SETQ LINEWIDTH (OR (NUMBERP LINEWIDTH) 1)) (SETQ LFT (IDIFFERENCE LFT LINEWIDTH)) (SETQ BTM (IDIFFERENCE BTM LINEWIDTH)) (SETQ WDTH (IPLUS WDTH (ITIMES LINEWIDTH 2))) (SETQ HGHT (IPLUS HGHT (ITIMES LINEWIDTH 2))) (DRAWLINE LFT BTM LFT (SETQ VERTLINETOP (SUB1 (IPLUS BTM HGHT))) LINEWIDTH OPERATION WIN) (DRAWLINE (SETQ RIGHTLINELEFT (IDIFFERENCE (IPLUS LFT WDTH) LINEWIDTH)) BTM RIGHTLINELEFT VERTLINETOP LINEWIDTH OPERATION WIN) (DRAWLINE (SETQ LEFTPLUSWIDTH (IPLUS LFT LINEWIDTH)) BTM (SETQ RIGHTLINELEFT (SUB1 RIGHTLINELEFT)) BTM LINEWIDTH OPERATION WIN) (DRAWLINE LEFTPLUSWIDTH (SETQ TOPY (ADD1 (IDIFFERENCE VERTLINETOP LINEWIDTH))) RIGHTLINELEFT TOPY LINEWIDTH OPERATION WIN]) (OUTLINEREGION [LAMBDA (REGION OUTLINEWIDTH OPERATION WIN) (* rrb "17-FEB-82 10:58") (* outlines the region REGION with a  width wide line) (OUTLINEAREA (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) OUTLINEWIDTH OPERATION WIN]) ) (DEFINEQ (ADJUSTCOLORMAP [LAMBDA (PRIMARY DELTA) (* kbr%: " 5-Jun-86 19:41") (* Adds DELTA points of intensity to all values of PRIMARY color in  SCREENCOLORMAP *) (PROG NIL (for COLOR from 0 to (MAXIMUMCOLOR (BITSPERPIXEL (SCREENCOLORMAP))) do (COLORLEVEL COLOR PRIMARY (IMIN 255 (IMAX 0 (IPLUS (COLORLEVEL COLOR PRIMARY) DELTA]) (SHOWCOLORBLOCKS [LAMBDA (DESTINATION) (* kbr%: "17-Aug-85 21:44") (* Puts shade blocks onto DESTINATION.  *) (PROG (BITSPERPIXEL MAXSHADE N WIDTH HEIGHT SHADE) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (SETQ MAXSHADE (MAXIMUMSHADE BITSPERPIXEL)) [SETQ N (FIXR (SQRT (ADD1 MAXSHADE] (SETQ WIDTH (IQUOTIENT (IPLUS (BITMAPWIDTH DESTINATION) N -1) N)) (SETQ HEIGHT (IQUOTIENT (IPLUS (BITMAPHEIGHT DESTINATION) N -1) N)) (SETQ SHADE 0) (for Y from (SUB1 N) to 0 by -1 do (for X from 0 to (SUB1 N) do (BLTSHADE SHADE DESTINATION (ITIMES X WIDTH) (ITIMES Y HEIGHT) WIDTH HEIGHT 'REPLACE) (SETQ SHADE (ADD1 SHADE)) (COND ((IGREATERP SHADE MAXSHADE) (SETQ SHADE 0]) (MAPOFACOLOR [LAMBDA (RGB BITSPERPIXEL) (* kbr%: "11-Jul-85 20:04") (* creates a gray color map *) (PROG (MAXCOLOR RED GREEN BLUE OPRED OPGREEN OPBLUE COLORMAP) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ RED (fetch (RGB RED) of RGB)) (SETQ GREEN (fetch (RGB GREEN) of RGB)) (SETQ BLUE (fetch (RGB BLUE) of RGB)) (SETQ OPRED (IDIFFERENCE MAXCOLOR RED)) (SETQ OPGREEN (IDIFFERENCE MAXCOLOR GREEN)) (SETQ OPBLUE (IDIFFERENCE MAXCOLOR BLUE)) (SETQ COLORMAP (COLORMAPCREATE (for I from 0 to MAXCOLOR as OPI from MAXCOLOR to 0 by -1 collect (create RGB RED _ (IQUOTIENT (IPLUS (ITIMES OPI OPRED) (ITIMES I RED)) MAXCOLOR) GREEN _ (IQUOTIENT (IPLUS (ITIMES OPI OPGREEN) (ITIMES I GREEN)) MAXCOLOR) BLUE _ (IQUOTIENT (IPLUS (ITIMES OPI OPBLUE) (ITIMES I BLUE)) MAXCOLOR))) BITSPERPIXEL)) (RETURN COLORMAP]) (COLORHEXPATTERN [LAMBDA (LIGHTNESS) (* kbr%: " 3-Jun-86 22:36") (* Put a color hex pattern on the color display.  *) (PROG (DESTINATION WIDTH HEIGHT BITSPERPIXEL N HEXWIDTH HEXHEIGHT LEFT BOTTOM COLOR MAXI JDIST IDIST) (COND ((NULL LIGHTNESS) (SETQ LIGHTNESS 0.5))) (SETQ DESTINATION (COLORSCREENBITMAP)) (SETQ WIDTH (BITMAPWIDTH DESTINATION)) (SETQ HEIGHT (BITMAPHEIGHT DESTINATION)) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (SETQ N (SELECTQ BITSPERPIXEL (4 1) (8 8) (RETURN))) (SETQ HEXWIDTH (IQUOTIENT WIDTH (IPLUS (ITIMES 2 N) 1))) (SETQ HEXHEIGHT (IQUOTIENT HEIGHT (IPLUS (ITIMES 2 N) 1))) (BLTSHADE MINIMUMSHADE DESTINATION) (SETQ COLOR 0) [for J from N to 0 by -1 do (SETQ BOTTOM (ITIMES (IPLUS J N) HEXHEIGHT)) (SETQ MAXI (IDIFFERENCE (IPLUS (ITIMES 2 N) 1) J)) (for I from 0 to MAXI do (SETQ LEFT (IQUOTIENT (ITIMES (IPLUS (ITIMES 2 I) J) HEXWIDTH) 2)) (SETQ COLOR (ADD1 COLOR)) (BLTSHADE COLOR DESTINATION LEFT BOTTOM HEXWIDTH HEXHEIGHT) (SETQ JDIST (FQUOTIENT J N)) (SETQ IDIST (FDIFFERENCE (FTIMES 2.0 (FQUOTIENT I MAXI)) 1.0)) (SCREENCOLORMAPENTRY COLOR (HLSTORGB (ATAN JDIST IDIST) LIGHTNESS (SQRT (FQUOTIENT (FPLUS (FTIMES IDIST IDIST) (FTIMES JDIST JDIST)) 2.0] (for J from -1 to (IMINUS N) by -1 do (SETQ BOTTOM (ITIMES (IPLUS J N) HEXHEIGHT)) (SETQ MAXI (IPLUS (IPLUS (ITIMES 2 N) 1) J)) (for I from 0 to MAXI do (SETQ LEFT (IQUOTIENT (ITIMES (IPLUS (ITIMES 2 I) (IMINUS J)) HEXWIDTH) 2)) (SETQ COLOR (ADD1 COLOR)) (BLTSHADE COLOR DESTINATION LEFT BOTTOM HEXWIDTH HEXHEIGHT) (SETQ JDIST (FQUOTIENT J N)) (SETQ IDIST (FDIFFERENCE (FTIMES 2.0 (FQUOTIENT I MAXI)) 1.0)) (SCREENCOLORMAPENTRY COLOR (HLSTORGB (ATAN JDIST IDIST) LIGHTNESS (SQRT (FQUOTIENT (FPLUS (FTIMES IDIST IDIST) (FTIMES JDIST JDIST)) 2.0]) ) (RPAQQ EditColorMapHeight 315) (RPAQQ EditColorMapWidth 380) (RPAQQ COLOR#MENUSAVE NIL) (RPAQQ CONTROLMENUSAVE NIL) (RPAQQ EDIT8BITCOLORMAPMENU NIL) (RPAQQ EDIT8BITCOLORMAPNUMBERREADER NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER EditColorMapHeight EditColorMapWidth) ) (* ;;; "support for global naming and querying of colors.") (DEFINEQ (CNSMENUINIT [LAMBDA NIL (* gbn " 9-Aug-85 03:11") [SETQ CNSHUEMENU (create MENU ITEMS _ (for I in DICOLOR.hueMapping collect (CAR I] [SETQ CNSSATURATIONMENU (create MENU ITEMS _ (for I in DICOLOR.saturationMapping collect (CAR I] (SETQ CNSLIGHTNESSMENU (create MENU ITEMS _ (for I in DICOLOR.lightnessMapping collect (CAR I]) (CNSTOCSL [LAMBDA (hue saturation lightness) (* hdj "12-Apr-85 19:01") (PROG ((hueAtom (MKATOM hue)) (saturationAtom (MKATOM saturation)) (lightnessAtom (MKATOM lightness)) c s l) (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom DICOLOR.hueMapping] then (SETQ c DICOLOR.achromatic)) (if (EQ c DICOLOR.achromatic) then (SETQ s DICOLOR.noSaturation) else (if [NOT (SETQ s (fetch (saturationRecord ordering) of (ASSOC saturationAtom DICOLOR.saturationMapping ] then (SETQ s DICOLOR.vivid))) (SELECTQ hueAtom (Black (SETQ l DICOLOR.black)) (White (SETQ l DICOLOR.white)) (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom DICOLOR.lightnessMapping] then (SETQ l DICOLOR.medium))) (RETURN (LIST c s l]) (CNSTORGB [LAMBDA (saturation lightness hue) (* hdj "15-Jul-85 12:33") (LET ((CSL (CNSTOCSL hue saturation lightness))) (HLSTORGB (APPLY (FUNCTION CSLTOHLS) CSL]) (CSLTOCNS [LAMBDA (c s l) (* hdj "15-Jul-85 12:37") (PROG (hue saturation lightness) [if (EQ c DICOLOR.achromatic) then (SETQ saturation "") [SELECTC l (DICOLOR.black (SETQ hue "Black") (SETQ lightness "")) (DICOLOR.white (SETQ hue "White") (SETQ lightness "")) (PROGN (SETQ hue "Gray") (SETQ lightness (MKSTRING (fetch (lightnessRecord name) of (DICOLOR.lightnessN l] else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c))) (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN s))) (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN l] (RETURN (LIST saturation lightness hue]) (DICOLOR.FROM.USER [LAMBDA NIL (* gbn "30-Oct-85 11:28") (* * Returns a color, either by its name  (which can then be looked up on colornames) or as an RGB triple if it is not  named. Prompts the user first with the global color name menu.  She can then choose NEWCOLOR which can be specified as RGB or CNS) (PROG (NAME RGB) (* first try to get a color name) [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU (create MENU ITEMS _ (CONS NEWCOLORITEM (for ENTRY in COLORNAMES collect (CAR ENTRY] (if (NOT NAME) then (* the user clicked outside the menu) (RETURN)) (SETQ RGB (SELECTQ NAME (RGB (READCOLOR1 "specify new color")) (CNS (APPLY (FUNCTION CNSTORGB) (GETCNS))) (RETURN NAME))) (if (NOT (SETQ NAME (TTYIN "New color name? "))) then (* user decided that she didn't want to name the color) (RETURN RGB)) (push COLORNAMES (CONS (SETQ NAME (CAR NAME)) RGB)) (SETQ COLORNAMEMENU NIL) (* invalidate the menu) (RETURN NAME]) (GETCNS [LAMBDA NIL (* gbn " 9-Aug-85 03:13") (LIST (MENU CNSLIGHTNESSMENU) (MENU CNSSATURATIONMENU) (MENU CNSHUEMENU]) (HLSTOCSL [LAMBDA (hue lightness saturation) (* hdj "15-Jul-85 12:14") (LET ((ISLHue (FQUOTIENT (MOD (PLUS hue 240) 360) 360))) (PROG (c s l) (for old s from DICOLOR.noSaturation to DICOLOR.vivid do (if (EQ s DICOLOR.vivid) then (RETURN)) (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s) (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue (ADD1 s)) (DICOLOR.saturationNvalue s)) 2))) then (RETURN))) [if (EQ s DICOLOR.noSaturation) then (SETQ c DICOLOR.achromatic) (for old l from DICOLOR.black to DICOLOR.white do (if (EQ l DICOLOR.white) then (RETURN)) (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue (ADD1 l)) (DICOLOR.lightnessNvalue l)) 2))) then (RETURN))) else (for old c from DICOLOR.red to DICOLOR.purplishRed do (* (HELP c)) (if (EQ c DICOLOR.purplishRed) then (if (GREATERP ISLHue (PLUS (DICOLOR.hueNvalue c) (QUOTIENT (DIFFERENCE 1 (  DICOLOR.hueNvalue c)) 2))) then (SETQ c DICOLOR.red)) (RETURN)) (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c) (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue (ADD1 c)) (DICOLOR.hueNvalue c)) 2))) then (RETURN))) (for old l from DICOLOR.veryDark to DICOLOR.veryLight do (if (EQ l DICOLOR.veryLight) then (RETURN)) (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue (ADD1 l)) (DICOLOR.lightnessNvalue l)) 2))) then (RETURN] (RETURN (LIST c s l]) (CSLTOHLS [LAMBDA (c s l) (* hdj "15-Jul-85 12:23") (PROG (hue saturation lightness) (if (EQ c DICOLOR.achromatic) then (SETQ hue 0.0) (SETQ saturation 0.0) (SETQ lightness (DICOLOR.lightnessNvalue l)) else (SETQ hue (DICOLOR.hueNvalue c)) (SETQ saturation (DICOLOR.saturationNvalue s)) (SETQ lightness (DICOLOR.lightnessNvalue l))) (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360)) 360) lightness saturation]) (RGBTOCNS [LAMBDA (Red Green Blue) (* hdj "15-Jul-85 12:36") (APPLY (FUNCTION CSLTOCNS) (APPLY (FUNCTION HLSTOCSL) (RGBTOHLS Red Green Blue]) ) (RPAQQ DICOLOR.hueMapping ((Achromatic 0.0 -1) (Red 0.0 0) (OrangishRed 0.01 1) (RedOrange 0.02 2) (ReddishOrange 0.03 3) (Orange 0.04 4) (YellowishOrange 0.070 5) (OrangeYellow 0.1 6) (OrangishYellow 0.13 7) (Yellow 0.1673 8) (GreenishYellow 0.2073 9) (YellowGreen 0.2473 10) (YellowishGreen 0.2873 11) (Green 0.3333 12) (BluishGreen 0.4133 13) (GreenBlue 0.4933 14) (GreenishBlue 0.5733 15) (Blue 0.6666 16) (PurplishBlue 0.6816 17) (BluePurple 0.6966 18) (BluishPurple 0.7116 19) (Purple 0.73 20) (ReddishPurple 0.8 21) (PurpleRed 0.87 22) (PurplishRed 0.94 23) (BrownishRed 0.01 24) (RedBrown 0.02 25) (ReddishBrown 0.03 26) (Brown 0.04 27) (YellowishBrown 0.070 28) (BrownYellow 0.1 29) (BrownishYellow 0.13 30))) (RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0) (VeryDark 0.1666 1) (Dark 0.3333 2) (Medium 0.5 3) (Light 0.6666 4) (VeryLight 0.8333 5) (White 1.0 6))) (RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0) (Grayish 0.25 1) (Moderate 0.5 2) (Strong 0.75 3) (Vivid 1.0 4))) (RPAQQ NEWCOLORITEM (New% Color 'CNS "Allows specification of a new color" (SUBITEMS (RGB 'RGB "Specify a new color using Red, Green, Blue sliders" ) (CNS 'CNS "Specify a new color using English" )))) (RPAQ? COLORNAMEMENU ) (DEFINEQ (DICOLOR.hueN [LAMBDA (N) (* hdj "17-Apr-85 13:38") (DECLARE (GLOBALVARS DICOLOR.hueMapping)) (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering) of ELT) N]) (DICOLOR.hueNvalue [LAMBDA (N) (* hdj "18-Apr-85 09:58") (fetch (hueRecord value) of (DICOLOR.hueN N]) (DICOLOR.hueNname [LAMBDA (N) (* hdj "18-Apr-85 10:07") (fetch (hueRecord name) of (DICOLOR.hueN N]) (DICOLOR.lightnessN [LAMBDA (N) (* hdj "17-Apr-85 13:40") (DECLARE (GLOBALVARS DICOLOR.lightnessMapping)) (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord ordering) of ELT) N]) (DICOLOR.lightnessNvalue [LAMBDA (N) (* hdj "17-Apr-85 13:36") (fetch (lightnessRecord value) of (DICOLOR.lightnessN N]) (DICOLOR.lightnessNname [LAMBDA (N) (* hdj "17-Apr-85 14:02") (fetch (lightnessRecord name) of (DICOLOR.lightnessN N]) (DICOLOR.saturationN [LAMBDA (N) (* hdj "17-Apr-85 13:39") (DECLARE (GLOBALVARS DICOLOR.saturationMapping)) (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord ordering) of ELT) N]) (DICOLOR.saturationNvalue [LAMBDA (N) (* hdj "17-Apr-85 13:36") (fetch (saturationRecord value) of (DICOLOR.saturationN N]) (DICOLOR.saturationNname [LAMBDA (N) (* hdj "17-Apr-85 14:02") (fetch (saturationRecord name) of (DICOLOR.saturationN N]) ) (DECLARE%: EVAL@LOAD DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD hueRecord (name value ordering)) (RECORD lightnessRecord (name value ordering)) (RECORD saturationRecord (name value ordering)) ) (RPAQQ DICOLOR.hueConstants (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange)) (DECLARE%: EVAL@COMPILE (RPAQQ DICOLOR.achromatic -1) (RPAQQ DICOLOR.blue 16) (RPAQQ DICOLOR.bluePurple 18) (RPAQQ DICOLOR.bluishGreen 13) (RPAQQ DICOLOR.bluishPurple 19) (RPAQQ DICOLOR.brown 27) (RPAQQ DICOLOR.brownYellow 29) (RPAQQ DICOLOR.brownishRed 24) (RPAQQ DICOLOR.brownishYellow 30) (RPAQQ DICOLOR.green 12) (RPAQQ DICOLOR.greenBlue 14) (RPAQQ DICOLOR.greenishBlue 15) (RPAQQ DICOLOR.greenishYellow 9) (RPAQQ DICOLOR.orange 4) (RPAQQ DICOLOR.orangeYellow 6) (RPAQQ DICOLOR.orangishRed 1) (RPAQQ DICOLOR.orangishYellow 7) (RPAQQ DICOLOR.purple 20) (RPAQQ DICOLOR.purpleRed 22) (RPAQQ DICOLOR.purplishBlue 17) (RPAQQ DICOLOR.purplishRed 23) (RPAQQ DICOLOR.red 0) (RPAQQ DICOLOR.redBrown 25) (RPAQQ DICOLOR.redOrange 2) (RPAQQ DICOLOR.reddishBrown 26) (RPAQQ DICOLOR.reddishOrange 3) (RPAQQ DICOLOR.reddishPurple 21) (RPAQQ DICOLOR.yellow 8) (RPAQQ DICOLOR.yellowGreen 10) (RPAQQ DICOLOR.yellowishBrown 28) (RPAQQ DICOLOR.yellowishGreen 11) (RPAQQ DICOLOR.yellowishOrange 5) (CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange) ) (RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid)) (DECLARE%: EVAL@COMPILE (RPAQQ DICOLOR.noSaturation 0) (RPAQQ DICOLOR.grayish 1) (RPAQQ DICOLOR.moderate 2) (RPAQQ DICOLOR.strong 3) (RPAQQ DICOLOR.vivid 4) (CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid) ) (RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white)) (DECLARE%: EVAL@COMPILE (RPAQQ DICOLOR.black 0) (RPAQQ DICOLOR.veryDark 1) (RPAQQ DICOLOR.dark 2) (RPAQQ DICOLOR.medium 3) (RPAQQ DICOLOR.light 4) (RPAQQ DICOLOR.veryLight 5) (RPAQQ DICOLOR.white 6) (CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white) ) ) (CNSMENUINIT) (FILESLOAD LLCOLOR READNUMBER) (SETQ EDITBMMENU NIL) (MOVD 'ARRAYP 'COLORMAPP) (PUTPROPS COLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5033 20085 (DISPLAYCOLORLEVELS 5043 . 6161) (DISPLAYHLSLEVELS 6163 . 6503) (HLSLEVEL 6505 . 7240) (HLSTORGB 7242 . 8671) (HLSVALUEFN 8673 . 9550) (HLSVALUEFROMLEVEL 9552 . 9884) ( LEVELFROMHLSVALUE 9886 . 10223) (RAINBOWMAP 10225 . 17234) (RGBTOHLS 17236 . 20083)) (20086 21872 ( OVERPAINT 20096 . 20857) (BITMAPFROMSTRING 20859 . 21349) (SHADEBITMAP 21351 . 21870)) (21910 38520 ( EDITCOLORMAP 21920 . 23139) (EDITCOLORMAP.BUTTONEVENTFN 23141 . 26871) (EDITCOLORMAP.REDISPLAYFN 26873 . 29232) (EDITCOLORMAP.VALUELEVEL 29234 . 29727) (EDITCOLORMAP.WINDOWLEVEL 29729 . 30232) ( CHANGECOLORLEVELS 30234 . 32361) (GETCOLOR#FROMUSER 32363 . 33681) (GETCOLOR#FROMSCREEN 33683 . 34241) (DISPLAYCOLORLEVEL 34243 . 35667) (FILLINREGION 35669 . 36136) (AREAFILL 36138 . 36400) (CENTEREDLEFT 36402 . 36728) (OUTLINEAREA 36730 . 37959) (OUTLINEREGION 37961 . 38518)) (38521 45894 ( ADJUSTCOLORMAP 38531 . 39051) (SHOWCOLORBLOCKS 39053 . 40520) (MAPOFACOLOR 40522 . 42173) ( COLORHEXPATTERN 42175 . 45892)) (46360 55962 (CNSMENUINIT 46370 . 47005) (CNSTOCSL 47007 . 48269) ( CNSTORGB 48271 . 48518) (CSLTOCNS 48520 . 49593) (DICOLOR.FROM.USER 49595 . 51354) (GETCNS 51356 . 51560) (HLSTOCSL 51562 . 55062) (CSLTOHLS 55064 . 55732) (RGBTOCNS 55734 . 55960)) (58806 61057 ( DICOLOR.hueN 58816 . 59134) (DICOLOR.hueNvalue 59136 . 59315) (DICOLOR.hueNname 59317 . 59494) ( DICOLOR.lightnessN 59496 . 59844) (DICOLOR.lightnessNvalue 59846 . 60043) (DICOLOR.lightnessNname 60045 . 60240) (DICOLOR.saturationN 60242 . 60653) (DICOLOR.saturationNvalue 60655 . 60855) ( DICOLOR.saturationNname 60857 . 61055))))) STOP \ No newline at end of file diff --git a/lispusers/COLORDEMO b/lispusers/COLORDEMO new file mode 100644 index 00000000..f73eb01b --- /dev/null +++ b/lispusers/COLORDEMO @@ -0,0 +1 @@ +(FILECREATED " 3-Sep-86 21:36:32" {ERIS}LIBRARY>COLORDEMO.;17 59524 changes to: (FNS COLORDEMO CD.RANDCOLORMAP TILEDEMO CD.INIT.COLORMAPS KINETICDEMO CD.QUITP WELLDEMO TUNNELDEMO CD.KINETIC VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO BUBBLEDEMO OVERPAINTDEMO CD.INIT CD.INIT.WINDOWS WALKDEMO CD.WALKBM CD.DEMOKINETIC COLORBACKGROUND COLORMAPOF CD.CIRKIN CD.INRANGE CD.PUTDROPS CD.DOCOLORDROP CD.RAININGCOLORMAP CD.STARBURST CD.STARSHINE CD.BUBBLE CD.INIT.MENU CD.NEXTELEMENT CD.RANDELEMENT CD.CHOOSEDEMO CD.MINESHAFT CD.POINTTEST CD.SQUARETUNNEL CD.CIRCULARTUNNEL CD.ROTATEIT) (VARS COLORDEMOCOMS) previous date: " 3-Sep-86 16:25:44" {ERIS}CML>COLORDEMO.;3) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT COLORDEMOCOMS) (RPAQQ COLORDEMOCOMS ((* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *) (COMS (* Color Demo. Stuff needed to run through different demos, but not the individual demos themselves. *) (VARS (CD.DEMOS (QUOTE (KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO BUBBLEDEMO OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO)))) (INITVARS (CD.NEWDEMO NIL) (CD.STOPDATE 0) (CD.TIMECELL NIL) (CD.WINDOW1 NIL) (CD.WINDOW2 NIL) (CD.WINDOW3 NIL) (CD.WINDOW4 NIL) (CD.MENU NIL) (CD.COLORMAPS NIL)) (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE) (FNS COLORDEMO CD.INIT CD.INIT.COLORMAPS CD.INIT.WINDOWS CD.INIT.MENU CD.NEXTELEMENT CD.RANDELEMENT CD.CHOOSEDEMO CD.QUITP)) (COMS (* Tunnel demo. *) (FNS CD.MINESHAFT CD.POINTTEST) (FNS WELLDEMO TUNNELDEMO CD.SQUARETUNNEL CD.CIRCULARTUNNEL)) (COMS (* Junk fns. *) (FNS CD.ROTATEIT) (FNS COLORMAPOF COLORMAPCOPY COLORFILL COLORBACKGROUND COLORFILLAREA)) (COMS (* Walk demos) (FNS WALKDEMO CD.WALKBM CD.RANDCOLORMAP) (INITVARS CD.MAXWALK CD.MINWALK CD.RANDCOLORPROB (CD.RANDOM.COLORMAP NIL) (CD.RAINBOW.COLORMAP NIL) (CD.8BITBMEXP (LIST (HARRAY 60))) (CD.4BITBMEXP (LIST (HARRAY 60)))) (GLOBALVARS CD.8BITBMEXP CD.4BITBMEXP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP)) (COMS (* Kinetic demos *) (FNS KINETICDEMO CD.DEMOKINETIC CD.CIRKIN) (VARS (CD.KINETICWAITTIME 150)) (GLOBALVARS CD.KINETICWAITTIME)) (COMS (* Vine demo *) (FNS VINEDEMO CD.INRANGE)) (COMS (* Raining demo *) (FNS RAINING CD.PUTDROPS CD.DOCOLORDROP CD.RAININGCOLORMAP)) (COMS (* Modart demo *) (FNS MODARTDEMO)) (COMS (* Starburst demo *) (FNS STARBURSTDEMO CD.STARBURST CD.STARSHINE)) (COMS (* Peano demo *) (FILES (FROM LISPUSERS) PEANO) (FNS COLORPEANODEMO)) (COMS (* Bubble demo *) (FNS BUBBLEDEMO CD.BUBBLE)) (COMS (* Overpaint demo *) (FNS OVERPAINTDEMO) (VARS (CD.OVERPAINTBITMAPS))) (COMS (* Tile demo *) (INITVARS (CD.TILEBITMAPS NIL)) (FNS TILEDEMO)) (COMS (* Polygons demo *) (FILES (FROM LISPUSERS) COLORPOLYGONS) (FNS POLYGONSDEMO)) (FILES COLOR) (COMS (* Color font profile *) (VARS COLORFONTPROFILE) (P (FONTPROFILE COLORFONTPROFILE) (* Create color fonts now instead of later. COLOR should already be LOADed. *) (for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT) do (FONTCREATE FONTCLASS NIL NIL NIL (QUOTE 8DISPLAY))) (FONTCREATE (QUOTE TIMESROMAND) 36 NIL NIL NIL (QUOTE 8DISPLAY)))))) (* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *) (* Color Demo. Stuff needed to run through different demos, but not the individual demos themselves. *) (RPAQQ CD.DEMOS (KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO BUBBLEDEMO OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO)) (RPAQ? CD.NEWDEMO NIL) (RPAQ? CD.STOPDATE 0) (RPAQ? CD.TIMECELL NIL) (RPAQ? CD.WINDOW1 NIL) (RPAQ? CD.WINDOW2 NIL) (RPAQ? CD.WINDOW3 NIL) (RPAQ? CD.WINDOW4 NIL) (RPAQ? CD.MENU NIL) (RPAQ? CD.COLORMAPS NIL) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE) ) (DEFINEQ (COLORDEMO (LAMBDA NIL (* kbr: " 3-Sep-86 21:19") (DECLARE (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE CD.COLORMAPS)) (PROG (WINDOWS WINDOW DEMO BITSPERPIXEL BITMAP) (COND ((NULL CD.MENU) (CD.INIT))) (COND ((NULL (WFROMMENU CD.MENU)) (ADDMENU CD.MENU NIL (GETBOXPOSITION (fetch (MENU IMAGEWIDTH) of CD.MENU) (fetch (MENU IMAGEHEIGHT) of CD.MENU)))) ((NOT (OPENWP (WFROMMENU CD.MENU))) (OPENW (WFROMMENU CD.MENU)))) (SETQ WINDOWS (LIST CD.WINDOW1 CD.WINDOW2 CD.WINDOW3 CD.WINDOW4)) (do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS)) (SETQ DEMO (OR CD.NEWDEMO (CD.NEXTELEMENT DEMO CD.DEMOS))) (SETQ CD.NEWDEMO NIL) (COND ((EQ DEMO (QUOTE STOP)) (RETURN))) (SETQ CD.STOPDATE (IPLUS (IDATE) 60)) (* Each DEMO takes a WAIT argument telling how long to run and an optional  WINDOW argument telling which window to use.  WAIT can be defaulted to NIL. *) (SCREENCOLORMAP (CD.RANDELEMENT CD.COLORMAPS)) (APPLY* DEMO NIL WINDOW) (COND ((ILESSP (LENGTH CD.TILEBITMAPS) 10) (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL)) (BITBLT WINDOW NIL NIL BITMAP) (push CD.TILEBITMAPS BITMAP)))) (CLOSEW (WFROMMENU CD.MENU))))) (CD.INIT (LAMBDA NIL (* kbr: " 3-Sep-86 19:06") (PROG NIL (CD.INIT.COLORMAPS) (CD.INIT.WINDOWS) (CD.INIT.MENU)))) (CD.INIT.COLORMAPS (LAMBDA NIL (* kbr: " 3-Sep-86 20:39") (PROG (BITSPERPIXEL MAXCOLOR) (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ CD.CMYCOLORMAP (SELECTQ BITSPERPIXEL (4 (CMYCOLORMAP 2 1 1 4)) (8 (CMYCOLORMAP 3 2 2 8)) NIL)) (SETQ CD.RGBCOLORMAP (SELECTQ BITSPERPIXEL (4 (CMYCOLORMAP 2 1 1 4)) (8 (RGBCOLORMAP 3 2 2 8)) NIL)) (SETQ CD.RANDOM.COLORMAP (COLORMAPCREATE (for COLOR from 0 to MAXCOLOR collect (create RGB RED _ (RAND 0 255) GREEN _ (RAND 0 255) BLUE _ (RAND 0 255))) BITSPERPIXEL)) (PROGN (SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP BITSPERPIXEL)) (for COLOR from (RAND 0 15) to MAXCOLOR by 16 do (SETA CD.RAINBOW.COLORMAP COLOR (create RGB RED _ (RAND 0 255) GREEN _ (RAND 0 255) BLUE _ (RAND 0 255))))) (SETQ CD.COLORMAPS (LIST CD.CMYCOLORMAP CD.RGBCOLORMAP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP)) (RETURN CD.COLORMAPS)))) (CD.INIT.WINDOWS (LAMBDA NIL (* kbr: " 3-Sep-86 18:34") (PROG (CSWIDTH CSHEIGHT TAB NORTHWEST NORTHEAST SOUTHWEST SOUTHEAST NORTH EAST SOUTH WEST WIDTH HEIGHT) (SETQ CSWIDTH (BITMAPWIDTH (COLORSCREENBITMAP))) (SETQ CSHEIGHT (BITMAPHEIGHT (COLORSCREENBITMAP))) (SETQ TAB 20) (SETQ WIDTH (IQUOTIENT (IDIFFERENCE CSWIDTH (ITIMES 3 TAB)) 2)) (SETQ HEIGHT (IQUOTIENT (IDIFFERENCE CSHEIGHT (ITIMES 3 TAB)) 2)) (SETQ NORTHWEST (create POSITION XCOORD _ TAB YCOORD _ (IPLUS TAB HEIGHT TAB))) (SETQ NORTHEAST (create POSITION XCOORD _ (IPLUS TAB WIDTH TAB) YCOORD _ (IPLUS TAB HEIGHT TAB))) (SETQ SOUTHWEST (create POSITION XCOORD _ TAB YCOORD _ TAB)) (SETQ SOUTHEAST (create POSITION XCOORD _ (IPLUS TAB WIDTH TAB) YCOORD _ TAB)) (SETQ NORTH (create POSITION XCOORD _ (IQUOTIENT (IDIFFERENCE CSWIDTH WIDTH) 2) YCOORD _ (IDIFFERENCE CSHEIGHT (IPLUS TAB HEIGHT)))) (SETQ EAST (create POSITION XCOORD _ (IDIFFERENCE CSWIDTH (IPLUS WIDTH TAB)) YCOORD _ (IQUOTIENT (IDIFFERENCE CSHEIGHT HEIGHT) 2))) (SETQ SOUTH (create POSITION XCOORD _ (IQUOTIENT (IDIFFERENCE CSWIDTH WIDTH) 2) YCOORD _ TAB)) (SETQ WEST (create POSITION XCOORD _ TAB YCOORD _ (IQUOTIENT (IDIFFERENCE CSHEIGHT HEIGHT) 2))) (SETQ CD.WINDOW1 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of NORTHWEST) BOTTOM _ (fetch (POSITION YCOORD) of NORTHWEST) WIDTH _ WIDTH HEIGHT _ HEIGHT) (QUOTE WINDOW1))) (SETQ CD.WINDOW2 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of NORTHEAST) BOTTOM _ (fetch (POSITION YCOORD) of NORTHEAST) WIDTH _ WIDTH HEIGHT _ HEIGHT) (QUOTE WINDOW2))) (SETQ CD.WINDOW3 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of SOUTHWEST) BOTTOM _ (fetch (POSITION YCOORD) of SOUTHWEST) WIDTH _ WIDTH HEIGHT _ HEIGHT) (QUOTE WINDOW3))) (SETQ CD.WINDOW4 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of SOUTHEAST) BOTTOM _ (fetch (POSITION YCOORD) of SOUTHEAST) WIDTH _ WIDTH HEIGHT _ HEIGHT) (QUOTE WINDOW4)))))) (CD.INIT.MENU (LAMBDA NIL (* kbr: "11-Aug-85 15:05") (SETQ CD.MENU (create MENU TITLE _ "Color Demos" ITEMS _ (APPEND CD.DEMOS (QUOTE (STOP))) WHENSELECTEDFN _ (QUOTE CD.CHOOSEDEMO))))) (CD.NEXTELEMENT (LAMBDA (ELEMENT LIST) (* kbr: "10-Jul-85 18:12") (* Pick element after ELEMENT in  rotating LIST. *) (PROG (TAIL ANSWER) (SETQ TAIL (FMEMB ELEMENT LIST)) (SETQ ANSWER (COND ((CDR TAIL) (CADR TAIL)) (T (CAR LIST)))) (RETURN ANSWER)))) (CD.RANDELEMENT (LAMBDA (LIST) (* kbr: "31-Jan-86 16:24") (CAR (NTH LIST (RAND 1 (LENGTH LIST)))))) (CD.CHOOSEDEMO (LAMBDA (NEW) (DECLARE (GLOBALVARS CD.NEWDEMO)) (* bas: " 5-JUN-82 13:07") (SETQ CD.NEWDEMO NEW))) (CD.QUITP (LAMBDA (N) (* kbr: " 3-Sep-86 20:05") (DECLARE (GLOBALVARS CD.NEWDEMO CD.STOPDATE)) (BLOCK) (OR CD.TIMECELL (SETQ CD.TIMECELL (CREATECELL \FIXP))) (OR CD.NEWDEMO (COND ((FIXP N) (SETQ CD.STOPDATE (IPLUS (ITIMES N 1000) (CLOCK 0 CD.TIMECELL))) NIL) (T (AND CD.STOPDATE (ILESSP CD.STOPDATE (CLOCK 0 CD.TIMECELL)))))))) ) (* Tunnel demo. *) (DEFINEQ (CD.MINESHAFT (LAMBDA (WINDOW N OUTFLG) (* kbr: "20-Jun-91 11:02") (* Draws a mineshaft on WINDOW.) (PROG (COLOR WIDTH HEIGHT MAXCOLOR) (WINDOWPROP WINDOW (QUOTE TITLE) (QUOTE CD.MINESHAFT)) (COND ((NULL N) (SETQ N 1))) (SETQ COLOR 0) (SETQ WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH))) (SETQ HEIGHT (WINDOWPROP WINDOW (QUOTE HEIGHT))) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (for LEFT from 0 by (ITIMES N 4) as BOTTOM from 0 by (ITIMES N 3) to (IQUOTIENT HEIGHT 2) do (BLTSHADE COLOR WINDOW LEFT BOTTOM (IDIFFERENCE WIDTH (ITIMES LEFT 2)) (IDIFFERENCE HEIGHT (ITIMES BOTTOM 2))) (COND (OUTFLG (SETQ COLOR (SUB1 COLOR)) (COND ((ILESSP COLOR 0) (SETQ COLOR MAXCOLOR)))) (T (SETQ COLOR (ADD1 COLOR)) (COND ((IGREATERP COLOR MAXCOLOR) (SETQ COLOR 0))))))))) (CD.POINTTEST (LAMBDA (WINDOW) (* kbr: " 8-Jul-85 09:44") (* randomly puts points in a region) (PROG (MAXX MAXY MAXCOLOR) (SETQ MAXX (SUB1 (WINDOWPROP WINDOW (QUOTE WIDTH)))) (SETQ MAXY (SUB1 (WINDOWPROP WINDOW (QUOTE HEIGHT)))) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (for I from 1 to 100 do (BITMAPBIT WINDOW (RAND 0 MAXX) (RAND 0 MAXY) (RAND 0 MAXCOLOR)))))) ) (DEFINEQ (WELLDEMO (LAMBDA (WAIT) (* kbr: " 3-Sep-86 20:08") (PROG (STARTCOLOR THRUCOLOR) (SETQ STARTCOLOR 1) (SETQ THRUCOLOR 14) (CD.SQUARETUNNEL CD.WINDOW1 4 STARTCOLOR THRUCOLOR) (CD.SQUARETUNNEL CD.WINDOW2 4 THRUCOLOR STARTCOLOR) (CD.CIRCULARTUNNEL CD.WINDOW3 4 THRUCOLOR STARTCOLOR) (CD.CIRCULARTUNNEL CD.WINDOW4 4 STARTCOLOR THRUCOLOR) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR))))) (TUNNELDEMO (LAMBDA (WAIT) (* kbr: " 3-Sep-86 20:08") (PROG (STARTCOLOR THRUCOLOR) (SETQ STARTCOLOR 1) (SETQ THRUCOLOR 14) (CD.SQUARETUNNEL CD.WINDOW1 STARTCOLOR THRUCOLOR) (CD.SQUARETUNNEL CD.WINDOW2 THRUCOLOR STARTCOLOR) (CD.CIRCULARTUNNEL CD.WINDOW3 THRUCOLOR STARTCOLOR) (CD.CIRCULARTUNNEL CD.WINDOW4 STARTCOLOR THRUCOLOR) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR))))) (CD.SQUARETUNNEL (LAMBDA (WINDOW STARTCOLOR THRUCOLOR) (* kbr: "24-Feb-86 12:16") (* Draws a CD.SQUARETUNNEL on the  WINDOW.) (PROG (LEFT BOTTOM MAXBOTTOM FACTOR LEFTFACTOR BOTTOMFACTOR INCR DELTA COLOR) (SETQ LEFT 0.0) (SETQ BOTTOM 0.0) (SETQ MAXBOTTOM (FQUOTIENT (BITMAPHEIGHT WINDOW) 2.0)) (SETQ FACTOR .2) (SETQ LEFTFACTOR (FTIMES 4.0 FACTOR)) (SETQ BOTTOMFACTOR (FTIMES 3.0 FACTOR)) (COND ((IGEQ THRUCOLOR STARTCOLOR) (SETQ DELTA 1)) (T (SETQ DELTA -1))) (SETQ COLOR STARTCOLOR) (do (BLTSHADE COLOR WINDOW (FIX LEFT) (FIX BOTTOM) (IDIFFERENCE (BITMAPWIDTH WINDOW) (FTIMES LEFT 2)) (IDIFFERENCE (BITMAPHEIGHT WINDOW) (FTIMES BOTTOM 2))) (SETQ INCR (FPLUS 1.0 (FTIMES .1 (FDIFFERENCE MAXBOTTOM BOTTOM)))) (SETQ LEFT (FPLUS LEFT (FTIMES INCR LEFTFACTOR))) (SETQ BOTTOM (FPLUS BOTTOM (FTIMES INCR BOTTOMFACTOR))) (COND ((FGREATERP BOTTOM MAXBOTTOM) (RETURN))) (COND ((EQ COLOR THRUCOLOR) (SETQ COLOR STARTCOLOR)) (T (SETQ COLOR (IPLUS COLOR DELTA)))))))) (CD.CIRCULARTUNNEL (LAMBDA (WINDOW STARTCOLOR THRUCOLOR) (* kbr: "24-Feb-86 12:23") (PROG (N WIDTH HEIGHT SIZE DELTA COLOR) (SETQ N 4) (SETQ WIDTH (BITMAPWIDTH WINDOW)) (SETQ HEIGHT (BITMAPHEIGHT WINDOW)) (SETQ SIZE (IQUOTIENT (SQRT (IPLUS (ITIMES WIDTH WIDTH) (ITIMES HEIGHT HEIGHT))) 2)) (COND ((IGEQ THRUCOLOR STARTCOLOR) (SETQ DELTA 1)) (T (SETQ DELTA -1))) (SETQ COLOR STARTCOLOR) (for I from 1 to SIZE by N do (* Have to make the brush a little bit thicker than the amount by which we are  incrementing the radius to avoid cracks appearing between circles.  *) (DRAWCIRCLE (IQUOTIENT WIDTH 2) (IQUOTIENT HEIGHT 2) I (LIST (QUOTE ROUND) (IPLUS N 2) COLOR) NIL WINDOW) (COND ((EQ COLOR THRUCOLOR) (SETQ COLOR STARTCOLOR)) (T (SETQ COLOR (IPLUS COLOR DELTA)))))))) ) (* Junk fns. *) (DEFINEQ (CD.ROTATEIT (LAMBDA (BEGINCOLOR ENDCOLOR WAIT) (* kbr: "23-Feb-86 17:30") (PROG NIL (do (ROTATECOLORMAP BEGINCOLOR ENDCOLOR) (COND ((NULL WAIT)) ((SMALLP WAIT) (DISMISS WAIT)) (T (GETMOUSESTATE) (DISMISS (LRSH LASTMOUSEX 3)))))))) ) (DEFINEQ (COLORMAPOF (LAMBDA (NEWCM BITSPERPIXEL) (* kbr: " 3-Sep-86 16:24") (COND ((COLORMAPP NEWCM) (COND ((EQ BITSPERPIXEL (COLORMAPBITS NEWCM)) NEWCM) (T (COLORMAPCOPY NEWCM BITSPERPIXEL)))) ((EQ NEWCM T) (COLORMAPCREATE NIL BITSPERPIXEL)) (T (COLORMAPCREATE NEWCM BITSPERPIXEL))))) (COLORMAPCOPY (LAMBDA (COLORMAP BITSPERPIXEL) (* rrb "21-OCT-82 18:32") (* makes a copy of a color map If COLORMAP is not a color map, it returns a new  color map with default values. If the colormaps are different sizes, the first  16 entries will be the same and the rest will be black) (COLORMAPCREATE (AND (COLORMAPP COLORMAP BITSPERPIXEL) (INTENSITIESFROMCOLORMAP COLORMAP)) BITSPERPIXEL))) (COLORFILL (LAMBDA (REGION COLOR# COLORBM OPERATION) (* rrb "21-DEC-82 20:54") (* fills a region in a color bitmap  with a color. Calls the standard  BITBLT with a texture.) (PROG (COLORBM) (SETQ COLORBM (COND ((TYPENAMEP COLORBM (QUOTE BITMAP)) COLORBM) ((NULL COLORBM) (COLORSCREENBITMAP)) (T (\ILLEGAL.ARG COLORBM)))) (COND ((NULL REGION) (COLORFILLAREA 0 0 NIL NIL COLOR# COLORBM OPERATION)) (T (COLORFILLAREA (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) COLOR# COLORBM OPERATION)))))) (COLORBACKGROUND (LAMBDA (TEXTURE) (* kbr: " 3-Sep-86 16:30") (CHANGEBACKGROUND TEXTURE (COLORSCREEN)))) (COLORFILLAREA (LAMBDA (LEFT BOTTOM WIDTH HEIGHT COLOR# COLORBM OPERATION)(* kbr: " 8-Jul-85 08:53") (* fills an area of a color bitmap  with color.) (COND ((NULL COLORBM) (SETQ COLORBM (COLORSCREENBITMAP)))) (BITBLT NIL NIL NIL COLORBM LEFT BOTTOM WIDTH HEIGHT (QUOTE TEXTURE) OPERATION COLOR#))) ) (* Walk demos) (DEFINEQ (WALKDEMO (LAMBDA (WINDOW WAIT SPEED WORD1 WORDS) (* kbr: " 3-Sep-86 18:50") (DECLARE (GLOBALVARS CD.STOPDATE)) (PROG NIL (CLEARW WINDOW) (for I in (COND (CD.OVERPAINTBITMAPS) (T (SETQ CD.OVERPAINTBITMAPS (LIST (BITMAPFROMSTRING "Interlisp-D"))))) until (CD.QUITP (OR WAIT 10)) do (CD.WALKBM WINDOW I NIL SPEED) (OR (CD.QUITP 10) (CD.WALKBM WINDOW NIL NIL SPEED)))))) (CD.WALKBM (LAMBDA (WINDOW BM FONT SPEED) (* kbr: " 3-Sep-86 18:52") (PROG (BITSPERPIXEL EBM SCR MAXX MAXY MAXCOLOR) (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (OR SPEED (SETQ SPEED 5)) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ EBM (CACHEBITMAP BM FONT BITSPERPIXEL)) (SETQ SCR (BITMAPCOPY EBM)) (SETQ MAXX (IDIFFERENCE (WINDOWPROP WINDOW (QUOTE WIDTH)) (BITMAPWIDTH EBM))) (SETQ MAXY (IDIFFERENCE (WINDOWPROP WINDOW (QUOTE HEIGHT)) (BITMAPHEIGHT EBM))) (SCREENCOLORMAP (CD.RANDCOLORMAP)) (bind (X _ -1) (Y _ -1) (DX _ 0) (DY _ 0) (I _ 1) (J _ 0) (COLORCOUNTER _ 0) until (CD.QUITP) do (COND ((EQ I MAXCOLOR) (SETQ I 1)) (T (SETQ I (ADD1 I)))) (add X DX) (add Y DY) (COND ((OR (ILEQ J 0) (ILESSP X 0) (IGEQ X MAXX) (ILESSP Y 0) (IGEQ Y MAXY)) (SETQ X (RAND 0 MAXX)) (SETQ Y (RAND 0 MAXY)) (SETQ DX (RAND (IMINUS SPEED) SPEED)) (SETQ DY (RAND (IMINUS SPEED) SPEED)) (SETQ J (RAND CD.MINWALK CD.MAXWALK))) (T (SETQ J (SUB1 J)))) (OVERPAINT EBM (COLORSCREENBITMAP) X Y (COLORTEXTUREFROMCOLOR# I) SCR) (COND ((IGREATERP (SETQ COLORCOUNTER (ADD1 COLORCOUNTER )) 300) (SETQ COLORCOUNTER 0) (SCREENCOLORMAP (CD.RANDCOLORMAP))) (T (ROTATECOLORMAP 1 MAXCOLOR))) (DISMISS 15))))) (CD.RANDCOLORMAP (LAMBDA NIL (* kbr: " 3-Sep-86 21:16") (PROG (MAXCOLOR) (SETQ MAXCOLOR (BITSPERPIXEL (SCREENCOLORMAP))) (SELECTQ (RAND 1 2) (1 (COND ((NULL CD.RANDOM.COLORMAP) (SETQ CD.RANDOM.COLORMAP (COLORMAPCREATE)) (for COLOR from 0 to MAXCOLOR do (SETA (ELT CD.RANDOM.COLORMAP COLOR) (create RGB RED _ (RAND 0 255) GREEN _ (RAND 0 255) BLUE _ (RAND 0 255)))))) (RETURN CD.RANDOM.COLORMAP)) (2 (COND ((NULL CD.RAINBOW.COLORMAP) (SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP (COLORMAPBITS (SCREENCOLORMAP)))) (* make every 16th color random) (for COLOR from (RAND 0 15) to MAXCOLOR by 16 do (SETA (ELT CD.RAINBOW.COLORMAP COLOR) (create RGB RED _ (RAND 0 255) GREEN _ (RAND 0 255) BLUE _ (RAND 0 255)))) (RETURN CD.RAINBOW.COLORMAP))) CD.RAINBOW.COLORMAP) NIL)))) ) (RPAQ? CD.MAXWALK NIL) (RPAQ? CD.MINWALK NIL) (RPAQ? CD.RANDCOLORPROB NIL) (RPAQ? CD.RANDOM.COLORMAP NIL) (RPAQ? CD.RAINBOW.COLORMAP NIL) (RPAQ? CD.8BITBMEXP (LIST (HARRAY 60))) (RPAQ? CD.4BITBMEXP (LIST (HARRAY 60))) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.8BITBMEXP CD.4BITBMEXP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP) ) (* Kinetic demos *) (DEFINEQ (KINETICDEMO (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") (* test example (KINETICDEMO)) (PROG (MAXCOLOR MAXX MAXY X Y) (WINDOWPROP WINDOW (QUOTE TITLE) "KINETIC") (CLEARW WINDOW) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (SETQ X (RAND 0 MAXX)) (SETQ Y (RAND 0 MAXY)) (BLTSHADE (RAND 0 MAXCOLOR) WINDOW X Y (RAND 2 (IDIFFERENCE MAXX X)) (RAND 2 (IDIFFERENCE MAXY Y)) (SELECTQ (RAND 0 5) (0 (QUOTE PAINT)) (1 (QUOTE ERASE)) (2 (QUOTE INVERT)) (QUOTE REPLACE))))))) (CD.DEMOKINETIC (LAMBDA (WINDOW FIRSTCOLOR LASTCOLOR) (* kbr: " 3-Sep-86 18:40") (* test example (CD.DEMOKINETIC)) (PROG (BITSPERPIXEL LEFT RIGHT BOTTOM TOP X Y COLOR# ROTATETIME KINROTATETIME HALFWIDTH HALFHEIGHT) (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (OR (COLORNUMBERP FIRSTCOLOR) (SETQ FIRSTCOLOR 0)) (OR (COLORNUMBERP LASTCOLOR) (SETQ LASTCOLOR (MAXIMUMCOLOR BITSPERPIXEL))) (COND ((IGREATERP FIRSTCOLOR LASTCOLOR) (swap FIRSTCOLOR LASTCOLOR))) (SETQ LEFT 0) (SETQ RIGHT (WINDOWPROP WINDOW (QUOTE WIDTH))) (SETQ BOTTOM 0) (SETQ TOP (WINDOWPROP WINDOW (QUOTE HEIGHT))) (SETQ COLOR# FIRSTCOLOR) (SETQ ROTATETIME (CLOCK 0)) (SETQ KINROTATETIME (CLOCK 0)) (SETQ HALFWIDTH (IQUOTIENT RIGHT 2)) (SETQ HALFHEIGHT (IQUOTIENT TOP 2)) (BLTSHADE FIRSTCOLOR WINDOW) BLTLP (COND ((IGREATERP (CLOCKDIFFERENCE ROTATETIME) CD.LOGOWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP 1 (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ ROTATETIME (CLOCK0 ROTATETIME)))) (COND ((IGREATERP (CLOCKDIFFERENCE KINROTATETIME) CD.KINWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR) (SETQ KINROTATETIME (CLOCK0 KINROTATETIME)))) (SETQ X (RAND LEFT RIGHT)) (SETQ Y (RAND BOTTOM TOP)) (BLTSHADE (COND ((EQ COLOR# LASTCOLOR) (SETQ COLOR# FIRSTCOLOR)) (T (SETQ COLOR# (ADD1 COLOR#)))) WINDOW X Y (RAND 2 (IMIN (IDIFFERENCE RIGHT X) HALFWIDTH)) (RAND 2 (IMIN (IDIFFERENCE TOP Y) HALFHEIGHT)) (QUOTE REPLACE)) MOUSELP (COND ((MOUSESTATE MIDDLE) (SELECTQ (CAR (ERSETQ (MENU (PROGN (COND ((NOT (TYPENAMEP CD.KINETICMENU (QUOTE MENU))) (INIT/COLORDEMO/MENUS))) CD.KINETICMENU)))) (EditColorMap (EDITCOLORMAP)) (IncreaseLogoSpeed (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME .8)))) (DecreaseLogoSpeed (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME 1.3)))) (IncreaseColorFlip (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME .8)))) (DecreaseColorFlip (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME 1.3)))) (STOP (RETURN)) NIL)) ((MOUSESTATE LEFT) (* on left rotate colormap) (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR) (COND ((IGREATERP (CLOCKDIFFERENCE ROTATETIME) CD.LOGOWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP 1 (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ ROTATETIME (CLOCK0 ROTATETIME)))) (COND ((IGREATERP (CLOCKDIFFERENCE KINROTATETIME) CD.KINWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR) (SETQ KINROTATETIME (CLOCK0 KINROTATETIME)))) (DISMISS (IMIN CD.KINETICWAITTIME CD.LOGOWAITTIME)) (GO MOUSELP))) (GO BLTLP)))) (CD.CIRKIN (LAMBDA (WINDOW) (* kbr: " 8-Jul-85 15:18") (PROG (MAXX MAXY MAXRAD MAXCOLOR) (WINDOWPROP WINDOW (QUOTE TITLE) (QUOTE CD.CIRKIN)) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ MAXX (SUB1 (WINDOWPROP WINDOW (QUOTE WIDTH)))) (SETQ MAXY (SUB1 (WINDOWPROP WINDOW (QUOTE HEIGHT)))) (SETQ MAXRAD (IQUOTIENT (IMIN MAXX MAXY) 3)) LP (for I from 1 to 4 do (FILLCIRCLE (RAND 0 MAXX) (RAND 0 MAXY) (RAND 0 MAXRAD) (RAND 0 MAXCOLOR) WINDOW)) (DSPOPERATION (SELECTQ (RAND 0 3) (0 (QUOTE REPLACE)) (1 (QUOTE PAINT)) (2 (QUOTE INVERT)) (QUOTE ERASE)) WINDOW) (GO LP)))) ) (RPAQQ CD.KINETICWAITTIME 150) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.KINETICWAITTIME) ) (* Vine demo *) (DEFINEQ (VINEDEMO (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") (PROG (MAXX MAXY X1 Y1 DX DY X2 Y2 COLOR MAXCOLOR WIDTH MAXWIDTH) (WINDOWPROP WINDOW (QUOTE TITLE) "VINE") (CLEARW WINDOW) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) (SETQ X1 (IQUOTIENT MAXX 2)) (SETQ Y1 (IQUOTIENT MAXY 2)) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ COLOR (IQUOTIENT MAXCOLOR 2)) (SETQ MAXWIDTH (IQUOTIENT (IMIN MAXX MAXY) 4)) (SETQ WIDTH 10) (SETQ DX 0) (SETQ DY 0) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) do (* Update velocity. *) (SETQ DX (CD.INRANGE (IQUOTIENT (IMINUS X1) 2) (IQUOTIENT (IDIFFERENCE MAXX X1) 2) (IPLUS DX (RAND (IQUOTIENT (IMINUS X1) 24) (IQUOTIENT (IDIFFERENCE MAXX X1) 24))))) (SETQ DY (CD.INRANGE (IQUOTIENT (IMINUS Y1) 2) (IQUOTIENT (IDIFFERENCE MAXY Y1) 2) (IPLUS DY (RAND (IQUOTIENT (IMINUS Y1) 24) (IQUOTIENT (IDIFFERENCE MAXY Y1) 24))))) (* Knowing current (X1 Y1) and last WIDTH and COLOR, compute the point we draw  to (X2 Y2) and new WIDTH and COLOR. *) (SETQ X2 (CD.INRANGE 0 MAXX (IPLUS X1 DX))) (COND ((OR (EQ X2 0) (EQ X2 MAXX)) (SETQ DX (IMINUS DX)))) (SETQ Y2 (CD.INRANGE 0 MAXY (IPLUS Y1 DY))) (COND ((OR (EQ Y2 0) (EQ Y2 MAXY)) (SETQ DY (IMINUS DY)))) (SETQ WIDTH (CD.INRANGE 1 MAXWIDTH (IPLUS WIDTH (ITIMES (CAR (NTH (QUOTE (-1 0 0 0 0 0 0 1)) (RAND 1 8))) (ADD1 (IQUOTIENT WIDTH 3)))))) (SETQ COLOR (IMOD (IPLUS COLOR (CAR (NTH (QUOTE (-1 0 0 0 0 0 0 1)) (RAND 1 8)))) MAXCOLOR)) (* Drawline and update position  (X1 Y1) *) (DRAWLINE X1 Y1 X2 Y2 WIDTH (QUOTE REPLACE) WINDOW COLOR) (SETQ X1 X2) (SETQ Y1 Y2))))) (CD.INRANGE (LAMBDA (MIN MAX VALUE) (* kbr: " 4-Mar-85 14:12") (IMAX MIN (IMIN MAX VALUE)))) ) (* Raining demo *) (DEFINEQ (RAINING (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") (PROG (N MAXCOLOR WIDTH HEIGHT COLOR#) (WINDOWPROP WINDOW (QUOTE TITLE) "RAINING") (CLEARW WINDOW) (SETQ N 3) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ WIDTH (BITMAPWIDTH WINDOW)) (SETQ HEIGHT (BITMAPHEIGHT WINDOW)) (SETQ COLOR# (RAND 0 MAXCOLOR)) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) do (SETQ COLOR# (CD.DOCOLORDROP (RAND 10 (IDIFFERENCE WIDTH 10)) (RAND 10 (IDIFFERENCE HEIGHT 10)) N (ITIMES N 3) 8 COLOR# MAXCOLOR WINDOW)))))) (CD.PUTDROPS (LAMBDA (WINDOW N) (* kbr: " 8-Jul-85 10:53") (PROG (POS MAXCOLOR) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) LP (SETQ POS (GETPOSITION WINDOW)) (COND ((LASTMOUSESTATE RIGHT) (RETURN))) (CD.DOCOLORDROP (fetch (POSITION XCOORD) of POS) (fetch (POSITION YCOORD) of POS) (OR N 3) (COND ((LASTMOUSESTATE LEFT) (RAND 8 15)) (T (RAND 10 20))) 6 0 MAXCOLOR WINDOW) (GO LP)))) (CD.DOCOLORDROP (LAMBDA (X Y WIDTH RADIUSINCR NCIRCLES COLOR# MAXCOLOR WINDOW) (* kbr: " 8-Jul-85 10:32") (* draws a series of concentric  circles.) (for I from 1 to NCIRCLES do (DRAWCIRCLE X Y (ITIMES I RADIUSINCR) (LIST (QUOTE ROUND) WIDTH (COND ((ILESSP (SETQ COLOR# (ADD1 COLOR#)) MAXCOLOR) COLOR#) (T (SETQ COLOR# 0)))) NIL WINDOW)) COLOR#)) (CD.RAININGCOLORMAP (LAMBDA (BITSPERPIXEL) (* kbr: " 8-Jul-85 11:13") (COLORMAPCREATE (SELECTQ BITSPERPIXEL (4 (NCONC (LIST (QUOTE (0 0 0))) (for I from 100 to 255 by 50 collect (LIST 0 0 I)) (for I from 0 to 11 collect (QUOTE (0 0 0))))) (8 (NCONC (LIST (QUOTE (0 0 0))) (for I from 100 to 255 by 50 collect (LIST 0 0 I)) (for I from 0 to 11 collect (QUOTE (0 0 0))))) (\ILLEGAL.ARG BITSPERPIXEL)) BITSPERPIXEL))) ) (* Modart demo *) (DEFINEQ (MODARTDEMO (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") (PROG (WIDTH HEIGHT MAXCOLOR W H L B) (WINDOWPROP WINDOW (QUOTE TITLE) "MODART") (CLEARW WINDOW) (SETQ WIDTH (BITMAPWIDTH WINDOW)) (SETQ HEIGHT (BITMAPHEIGHT WINDOW)) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (SETQ W (RAND 0 WIDTH)) (SETQ H (RAND 0 HEIGHT)) (SETQ L (RAND 0 (IDIFFERENCE WIDTH W))) (SETQ B (RAND 0 (IDIFFERENCE HEIGHT H))) (BITBLT WINDOW 0 0 WINDOW L B W H (SELECTQ (RAND 0 2) (0 (QUOTE INPUT)) (1 (QUOTE INVERT)) (QUOTE TEXTURE)) (SELECTQ (RAND 0 3) (0 (QUOTE REPLACE)) (1 (QUOTE PAINT)) (2 (QUOTE INVERT)) (QUOTE ERASE)) (RAND 0 MAXCOLOR)))))) ) (* Starburst demo *) (DEFINEQ (STARBURSTDEMO (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:11") (PROG (MAXX MAXY MAXCOLOR MAXWIDTH MINWIDTH) (WINDOWPROP WINDOW (QUOTE TITLE) "STARBURST") (CLEARW WINDOW) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ MAXWIDTH (IQUOTIENT (IMIN MAXX MAXY) 2)) (SETQ MINWIDTH (IQUOTIENT MAXWIDTH 6)) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (CD.STARBURST MAXX MAXY MINWIDTH MAXWIDTH WINDOW))))) (CD.STARBURST (LAMBDA (MAXX MAXY MINWIDTH MAXWIDTH WINDOW) (* kbr: "23-Feb-86 17:15") (PROG (BITSPERPIXEL NCOLORS RADIUS C S CX1 CY1 COLOR1 DELTA1 CX2 CY2 COLOR2 DELTA2 CX3 CY3 COLOR3 DELTA3) (* Do several starbursts at once to  help minimize calls to COS and SIN  which are slow. *) (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (SETQ NCOLORS (ADD1 (MAXIMUMCOLOR BITSPERPIXEL))) (SETQ RADIUS (RAND MINWIDTH MAXWIDTH)) (PROGN (SETQ CX1 (RAND 0 MAXX)) (SETQ CY1 (RAND 0 MAXY)) (SETQ COLOR1 (RAND 0 (SUB1 NCOLORS))) (SETQ DELTA1 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL))))) (PROGN (SETQ CX2 (RAND 0 MAXX)) (SETQ CY2 (RAND 0 MAXY)) (SETQ COLOR2 (RAND 0 (SUB1 NCOLORS))) (SETQ DELTA2 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL))))) (PROGN (SETQ CX3 (RAND 0 MAXX)) (SETQ CY3 (RAND 0 MAXY)) (SETQ COLOR3 (RAND 0 (SUB1 NCOLORS))) (SETQ DELTA3 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL))))) (for THETA from 0 to 44 by 5 do (SETQ C (FTIMES RADIUS (COS THETA))) (SETQ S (FTIMES RADIUS (SIN THETA))) (PROGN (CD.STARSHINE CX1 CY1 C S WINDOW COLOR1) (SETQ COLOR1 (IMOD (IPLUS COLOR1 DELTA1) NCOLORS))) (PROGN (CD.STARSHINE CX2 CY2 C S WINDOW COLOR2) (SETQ COLOR2 (IMOD (IPLUS COLOR2 DELTA2) NCOLORS))) (PROGN (CD.STARSHINE CX3 CY3 C S WINDOW COLOR3) (SETQ COLOR3 (IMOD (IPLUS COLOR3 DELTA3) NCOLORS))))))) (CD.STARSHINE (LAMBDA (CX1 CY1 C S WINDOW COLOR) (* kbr: "23-Feb-86 16:57") (PROG NIL (DRAWLINE (IDIFFERENCE CX1 C) (IDIFFERENCE CY1 S) (IPLUS CX1 C) (IPLUS CY1 S) 1 (QUOTE REPLACE) WINDOW COLOR) (DRAWLINE (IDIFFERENCE CX1 C) (IPLUS CY1 S) (IPLUS CX1 C) (IDIFFERENCE CY1 S) 1 (QUOTE REPLACE) WINDOW COLOR) (DRAWLINE (IDIFFERENCE CX1 S) (IPLUS CY1 C) (IPLUS CX1 S) (IDIFFERENCE CY1 C) 1 (QUOTE REPLACE) WINDOW COLOR) (DRAWLINE (IPLUS CX1 S) (IPLUS CY1 C) (IDIFFERENCE CX1 S) (IDIFFERENCE CY1 C) 1 (QUOTE REPLACE) WINDOW COLOR)))) ) (* Peano demo *) (FILESLOAD (FROM LISPUSERS) PEANO) (DEFINEQ (COLORPEANODEMO (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:13") (PROG (BITSPERPIXEL MAXCOLOR MAXSHADE LEVEL SCALE) (WINDOWPROP WINDOW (QUOTE TITLE) "PEANO") (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ MAXSHADE (MAXIMUMSHADE BITSPERPIXEL)) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (DSPCOLOR (RAND 0 MAXCOLOR) WINDOW) (DSPTEXTURE (RAND 0 MAXSHADE) WINDOW) (DSPBACKCOLOR (RAND 0 MAXCOLOR) WINDOW) (SETQ LEVEL (RAND 4 6)) (SETQ SCALE (IQUOTIENT (IMAX (BITMAPWIDTH WINDOW) (BITMAPHEIGHT WINDOW)) (EXPT 2 LEVEL))) (SETQ PEANOWINDOW WINDOW) (PEANODEMO LEVEL SCALE))))) ) (* Bubble demo *) (DEFINEQ (BUBBLEDEMO (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:13") (PROG (MAXX MAXY MAXCOLOR MAXWIDTH MINWIDTH HOLLOW) (WINDOWPROP WINDOW (QUOTE TITLE) "BUBBLE") (CLEARW WINDOW) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ MAXWIDTH (IQUOTIENT (IMIN MAXX MAXY) 8)) (SETQ MINWIDTH (IQUOTIENT MAXWIDTH 6)) (COND ((EQ (RAND 0 1) 1) (SETQ HOLLOW T))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) do (CD.BUBBLE (RAND 0 MAXX) (RAND 0 MAXY) (RAND MINWIDTH MAXWIDTH) HOLLOW WINDOW))))) (CD.BUBBLE (LAMBDA (CENTERX CENTERY RADIUS HOLLOW WINDOW) (* kbr: "29-Jul-85 18:09") (PROG (MAXCOLOR) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (FILLCIRCLE CENTERX CENTERY RADIUS (RAND 0 MAXCOLOR) WINDOW) (COND (HOLLOW (FILLCIRCLE CENTERX CENTERY (SUB1 RADIUS) 0 WINDOW)))))) ) (* Overpaint demo *) (DEFINEQ (OVERPAINTDEMO (LAMBDA (WAIT) (* kbr: " 3-Sep-86 20:14") (PROG (BITMAP BITSPERPIXEL MAXCOLOR WIDTH HEIGHT X Y) (WINDOWPROP CD.WINDOW1 (QUOTE TITLE) "MASK") (WINDOWPROP CD.WINDOW2 (QUOTE TITLE) "BACKGROUND") (WINDOWPROP CD.WINDOW3 (QUOTE TITLE) "INPUT") (WINDOWPROP CD.WINDOW4 (QUOTE TITLE) "OUTPUT") (SETQ BITSPERPIXEL (BITSPERPIXEL CD.WINDOW1)) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ WIDTH (BITMAPWIDTH CD.WINDOW1)) (SETQ HEIGHT (BITMAPHEIGHT CD.WINDOW1)) (COND ((NULL CD.OVERPAINTBITMAPS) (SETQ CD.OVERPAINTBITMAPS (for STRING in (QUOTE ("Interlisp-D" "Xerox" "Color")) collect (BITMAPFROMSTRING STRING (FONTCREATE (QUOTE TIMESROMAND ) 36) BITSPERPIXEL))))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (BITBLT CD.WINDOW2 NIL NIL CD.WINDOW4) (for I from 1 to (RAND 6 20) do (SETQ BITMAP (CD.NEXTELEMENT BITMAP CD.OVERPAINTBITMAPS)) (SETQ X (RAND 0 (IDIFFERENCE WIDTH (BITMAPWIDTH BITMAP)))) (SETQ Y (RAND 0 (IDIFFERENCE HEIGHT (BITMAPHEIGHT BITMAP)))) (CLEARW CD.WINDOW1) (BITBLT BITMAP NIL NIL CD.WINDOW1 X Y) (BLTSHADE (RAND 0 MAXCOLOR) CD.WINDOW3) (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW3 NIL NIL NIL NIL (QUOTE INVERT) (QUOTE ERASE)) (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW4 NIL NIL NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (BITBLT CD.WINDOW3 NIL NIL CD.WINDOW4 NIL NIL NIL NIL (QUOTE INPUT) (QUOTE PAINT))))))) ) (RPAQQ CD.OVERPAINTBITMAPS NIL) (* Tile demo *) (RPAQ? CD.TILEBITMAPS NIL) (DEFINEQ (TILEDEMO (LAMBDA (WAIT) (* kbr: " 3-Sep-86 21:19") (PROG (WINDOWS WINDOW BITSPERPIXEL BITMAP) (SETQ WINDOWS (LIST CD.WINDOW1 CD.WINDOW2 CD.WINDOW3 CD.WINDOW4)) (COND ((ILESSP (LENGTH CD.TILEBITMAPS) 4) (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) (for WINDOW in WINDOWS do (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL)) (BITBLT WINDOW NIL NIL BITMAP) (push CD.TILEBITMAPS BITMAP)))) (CHANGEBACKGROUND (CD.RANDELEMENT CD.TILEBITMAPS) (COLORSCREEN)) (WINDOWPROP CD.WINDOW1 (QUOTE TITLE) "WINDOW1") (WINDOWPROP CD.WINDOW2 (QUOTE TITLE) "WINDOW2") (WINDOWPROP CD.WINDOW3 (QUOTE TITLE) "WINDOW3") (WINDOWPROP CD.WINDOW4 (QUOTE TITLE) "WINDOW4") (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS)) (SETQ BITMAP (CD.RANDELEMENT CD.TILEBITMAPS)) (TILE BITMAP WINDOW))))) ) (* Polygons demo *) (FILESLOAD (FROM LISPUSERS) COLORPOLYGONS) (DEFINEQ (POLYGONSDEMO (LAMBDA (WAIT) (* kbr: " 6-Jun-86 00:27") (PROG NIL (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) do (COLORPOLYGON CD.WINDOW1) (COLORPOLYGON CD.WINDOW2) (COLORPOLYGON CD.WINDOW3) (COLORPOLYGON CD.WINDOW4) (COLORPOLYGONS.ROTATECOLORMAP))))) ) (FILESLOAD COLOR) (* Color font profile *) (RPAQQ COLORFONTPROFILE ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED)) (24DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (24DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (24DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (24DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) (CHANGEFONT) (PRETTYCOMFONT BOLDFONT) (FONT1 DEFAULTFONT) (FONT2 BOLDFONT) (FONT3 LITTLEFONT) (FONT4 BIGFONT) (FONT5 5 (HELVETICA 10 BIR) (HELVETICA 8 BIR) (MODERN 8 BIR)) (FONT6 6 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (FONT7 7 (GACHA 12) (GACHA 12) (TERMINAL 12)))) (FONTPROFILE COLORFONTPROFILE) (* Create color fonts now instead of later. COLOR should already be LOADed. *) (for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT) do (FONTCREATE FONTCLASS NIL NIL NIL (QUOTE 8DISPLAY))) (FONTCREATE (QUOTE TIMESROMAND) 36 NIL NIL NIL (QUOTE 8DISPLAY)) (PUTPROPS COLORDEMO COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (5128 14880 (COLORDEMO 5138 . 6924) (CD.INIT 6926 . 7146) (CD.INIT.COLORMAPS 7148 . 9003 ) (CD.INIT.WINDOWS 9005 . 13127) (CD.INIT.MENU 13129 . 13458) (CD.NEXTELEMENT 13460 . 14003) ( CD.RANDELEMENT 14005 . 14166) (CD.CHOOSEDEMO 14168 . 14330) (CD.QUITP 14332 . 14878)) (14908 17153 ( CD.MINESHAFT 14918 . 16512) (CD.POINTTEST 16514 . 17151)) (17154 21488 (WELLDEMO 17164 . 17758) ( TUNNELDEMO 17760 . 18348) (CD.SQUARETUNNEL 18350 . 19917) (CD.CIRCULARTUNNEL 19919 . 21486)) (21513 21915 (CD.ROTATEIT 21523 . 21913)) (21916 24640 (COLORMAPOF 21926 . 22326) (COLORMAPCOPY 22328 . 22858 ) (COLORFILL 22860 . 23996) (COLORBACKGROUND 23998 . 24161) (COLORFILLAREA 24163 . 24638)) (24664 30332 (WALKDEMO 24674 . 25293) (CD.WALKBM 25295 . 28716) (CD.RANDCOLORMAP 28718 . 30330)) (30729 36945 (KINETICDEMO 30739 . 31911) (CD.DEMOKINETIC 31913 . 35878) (CD.CIRKIN 35880 . 36943)) (37075 40482 ( VINEDEMO 37085 . 40333) (CD.INRANGE 40335 . 40480)) (40510 43827 (RAINING 40520 . 41436) (CD.PUTDROPS 41438 . 42110) (CD.DOCOLORDROP 42112 . 43064) (CD.RAININGCOLORMAP 43066 . 43825)) (43854 45278 ( MODARTDEMO 43864 . 45276)) (45308 49308 (STARBURSTDEMO 45318 . 46022) (CD.STARBURST 46024 . 48286) ( CD.STARSHINE 48288 . 49306)) (49376 50561 (COLORPEANODEMO 49386 . 50559)) (50588 51968 (BUBBLEDEMO 50598 . 51560) (CD.BUBBLE 51562 . 51966)) (51998 54683 (OVERPAINTDEMO 52008 . 54681)) (54777 56090 ( TILEDEMO 54787 . 56088)) (56169 56673 (POLYGONSDEMO 56179 . 56671))))) STOP \ No newline at end of file diff --git a/lispusers/COLORNNCC b/lispusers/COLORNNCC new file mode 100644 index 00000000..8cdff283 --- /dev/null +++ b/lispusers/COLORNNCC @@ -0,0 +1 @@ +(FILECREATED "16-Feb-86 00:08:50" {ERIS}LIBRARY>COLORNNCC.;9 31542 changes to: (FNS \COLORNNCC.CMD \COLORNNCC.PAR2 \COLORNNCC.INIT \COLORNNCC.STARTBOARD \COLORNNCC.SENDCOLORMAPENTRY \COLORNNCC.SENDPAGE \COLORNNCC.PILOTBITBLT \COLORNNCC24.STARTBOARD \COLORNNCC24.STARTCOLOR \COLORNNCC24.SENDPAGE \COLORNNCC.DEMO \COLORNNCC.DRAWLINE1 \COLORNNCC.TEST3 MYTEST TEST24 TESTMODE TESTCM) (VARS COLORNNCCCOMS) previous date: "15-Feb-86 21:44:39" {ERIS}LIBRARY>COLORNNCC.;7) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT COLORNNCCCOMS) (RPAQQ COLORNNCCCOMS ((* COLORNNCC -- Drivers for Number Nine Computer Corporation color cards. -- By Kelly Roach. *) (DECLARE: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY (CONSTANTS (DISPLAYADRH 10) (PARAMADRH 12) (REDTABLEADRL 256) (GREENTABLEADRL 512) (BLUETABLEADRL 768) (BANK0ADRL 1797) (BANK1ADRL 1798))) (COMS (* Specific to REV512X8 board. *) (INITVARS (\COLORNNCC.BANK1 0) (\COLORNNCC.BANK0 0) (\DEBUG.CURSORRAN NIL) (\DEBUG.SENDPAGERAN NIL) (\DEBUG.CURSORINTERRUPTED NIL) (\DEBUG.SENDPAGEINTERRUPTED NIL)) (MACROS \COLORNNCCBANK1 \COLORNNCCBANK0)) (COMS (* Specific to REV512X32 board. *) (INITVARS (\COLORNNCC24.REDBASE NIL) (\COLORNNCC24.GREENBASE NIL) (\COLORNNCC24.BLUEBASE NIL))) (FNS \COLORNNCC.CMD \COLORNNCC.PAR2) (FNS \COLORNNCC.INIT) (FNS \COLORNNCC.STARTBOARD \COLORNNCC.SENDCOLORMAPENTRY \COLORNNCC.SENDPAGE \COLORNNCC.PILOTBITBLT) (FNS \COLORNNCC24.STARTBOARD \COLORNNCC24.STARTCOLOR \COLORNNCC24.SENDPAGE) (FNS \COLORNNCC.DEMO \COLORNNCC.DRAWLINE1 \COLORNNCC.TEST3 MYTEST TEST24 TESTMODE TESTCM) (FILES BUSCOLOR) (* \DEBUG vars are temporary till I figure out bank switching. *) (VARS \COLORNNCC.LOCKEDFNS \COLORNNCC.LOCKEDVARS) (DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (\COLORNNCC.INIT))))) (* COLORNNCC -- Drivers for Number Nine Computer Corporation color cards. -- By Kelly Roach. *) (DECLARE: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE: EVAL@COMPILE (RPAQQ DISPLAYADRH 10) (RPAQQ PARAMADRH 12) (RPAQQ REDTABLEADRL 256) (RPAQQ GREENTABLEADRL 512) (RPAQQ BLUETABLEADRL 768) (RPAQQ BANK0ADRL 1797) (RPAQQ BANK1ADRL 1798) (CONSTANTS (DISPLAYADRH 10) (PARAMADRH 12) (REDTABLEADRL 256) (GREENTABLEADRL 512) (BLUETABLEADRL 768) (BANK0ADRL 1797) (BANK1ADRL 1798)) ) ) (* Specific to REV512X8 board. *) (RPAQ? \COLORNNCC.BANK1 0) (RPAQ? \COLORNNCC.BANK0 0) (RPAQ? \DEBUG.CURSORRAN NIL) (RPAQ? \DEBUG.SENDPAGERAN NIL) (RPAQ? \DEBUG.CURSORINTERRUPTED NIL) (RPAQ? \DEBUG.SENDPAGEINTERRUPTED NIL) (DECLARE: EVAL@COMPILE (PUTPROPS \COLORNNCCBANK1 MACRO ((BANK1) (SETQ \COLORNNCC.BANK1 BANK1) (PCBUS.WRITEHL PARAMADRH BANK1ADRL \COLORNNCC.BANK1))) (PUTPROPS \COLORNNCCBANK0 MACRO ((BANK0) (SETQ \COLORNNCC.BANK0 BANK0) (PCBUS.WRITEHL PARAMADRH BANK0ADRL \COLORNNCC.BANK0))) ) (* Specific to REV512X32 board. *) (RPAQ? \COLORNNCC24.REDBASE NIL) (RPAQ? \COLORNNCC24.GREENBASE NIL) (RPAQ? \COLORNNCC24.BLUEBASE NIL) (DEFINEQ (\COLORNNCC.CMD (LAMBDA (ARG RESETFLG) (* kbr: " 4-Jan-86 16:31") (OR RESETFLG (until (EQ 0 (LOGAND 2 (PCBUS.READHL PARAMADRH 0))))) (PCBUS.WRITEHL PARAMADRH 1 (CAR ARG)) (for X in (CDR ARG) do (until (EQ 0 (LOGAND 2 (PCBUS.READHL PARAMADRH 0)))) (PCBUS.WRITEHL PARAMADRH 0 X)))) (\COLORNNCC.PAR2 (LAMBDA (ARG) (* kbr: " 4-Jan-86 16:31") (until (EQ 0 (LOGAND 2 (PCBUS.READHL 12 0)))) (PCBUS.WRITEHL 12 0 (LOGAND ARG 255)) (until (EQ 0 (LOGAND 2 (PCBUS.READHL 12 0)))) (PCBUS.WRITEHL 12 0 (LOGAND (LRSH ARG 8) 255)))) ) (DEFINEQ (\COLORNNCC.INIT (LAMBDA NIL (* kbr: "15-Feb-86 18:14") (DECLARE (GLOBALVARS \COLORNNCCWSOPS \COLORNNCC24WSOPS \COLORNNCCINFO \COLORNNCCINFO24)) (for FN in \COLORNNCC.LOCKEDFNS do (\LOCKFN FN)) (for VAR in \COLORNNCC.LOCKEDVARS do (\LOCKVAR VAR)) (SETQ \COLORNNCCWSOPS (create WSOPS STARTBOARD _(FUNCTION \COLORNNCC.STARTBOARD) STARTCOLOR _(FUNCTION \BUSCOLOR.STARTCOLOR) STOPCOLOR _(FUNCTION \BUSCOLOR.STOPCOLOR) EVENTFN _(FUNCTION \BUSCOLOR.EVENTFN) SENDCOLORMAPENTRY _(FUNCTION \COLORNNCC.SENDCOLORMAPENTRY) SENDPAGE _(FUNCTION \COLORNNCC.SENDPAGE) PILOTBITBLT _(FUNCTION \COLORNNCC.PILOTBITBLT))) (SETQ \COLORNNCCINFO (create DISPLAYINFO DITYPE _(QUOTE REV512X8) DIWIDTH _ 512 DIHEIGHT _ 480 DIBITSPERPIXEL _ 8 DIWSOPS _ \COLORNNCCWSOPS)) (\DEFINEDISPLAYINFO \COLORNNCCINFO) (SETQ \COLORNNCC24WSOPS (create WSOPS STARTBOARD _(FUNCTION \COLORNNCC24.STARTBOARD) STARTCOLOR _(FUNCTION \COLORNNCC24.STARTCOLOR) STOPCOLOR _(FUNCTION \BUSCOLOR.STOPCOLOR) EVENTFN _(FUNCTION \BUSCOLOR.EVENTFN) SENDCOLORMAPENTRY _(FUNCTION NILL) SENDPAGE _(FUNCTION \COLORNNCC24.SENDPAGE) PILOTBITBLT _(FUNCTION NILL))) (SETQ \COLORNNCCINFO24 (create DISPLAYINFO DITYPE _(QUOTE REV512X32) DIWIDTH _ 512 DIHEIGHT _ 480 DIBITSPERPIXEL _ 24 DIWSOPS _ \COLORNNCC24WSOPS)) (\DEFINEDISPLAYINFO \COLORNNCCINFO24))) ) (DEFINEQ (\COLORNNCC.STARTBOARD (LAMBDA NIL (* kbr: "13-Feb-86 23:21") (* IBM Bus Access Mode. *) (PCBUS.WRITEHL PARAMADRH 1796 255) (PCBUS.WRITEHL PARAMADRH 1797 0) (* Overlay Select. *) (PCBUS.WRITEHL PARAMADRH 1798 0) (* Board Enable. *) (PCBUS.WRITEHL PARAMADRH 1799 255) (\COLORNNCC.CMD (QUOTE (0 31 62 100 8 5 3 240 64)) T) (\COLORNNCC.CMD (QUOTE (71 64))) (\COLORNNCC.CMD (QUOTE (111))) (\COLORNNCC.CMD (QUOTE (70 0))) (* Zoom Factor. *) (PCBUS.WRITEHL PARAMADRH 1792 255) (PCBUS.WRITEHL PARAMADRH 1793 255) (PCBUS.WRITEHL PARAMADRH 1794 255) (PCBUS.WRITEHL PARAMADRH 1795 255) (\COLORNNCC.CMD (QUOTE (75 0 192 0))) (\COLORNNCC.CMD (QUOTE (112 0 0 0 127))) (\COLORNNCC.CMD (QUOTE (120 255 255 255 255 255 255 255 255))) (\COLORNNCC.CMD (QUOTE (74 255 255))) (\COLORNNCC.CMD (QUOTE (107))) (\COLORNNCC.CMD (QUOTE (13))))) (\COLORNNCC.SENDCOLORMAPENTRY (LAMBDA (FDEV COLOR# RGB) (* kbr: "15-Feb-86 21:04") (PROG NIL (PCBUS.WRITEHL PARAMADRH (IPLUS 256 COLOR#) (fetch (RGB RED) of RGB)) (PCBUS.WRITEHL PARAMADRH (IPLUS 512 COLOR#) (fetch (RGB GREEN) of RGB)) (PCBUS.WRITEHL PARAMADRH (IPLUS 768 COLOR#) (fetch (RGB BLUE) of RGB))))) (\COLORNNCC.SENDPAGE (LAMBDA (PAGE PAGE#) (* kbr: "16-Feb-86 00:03") (PROG (BANK1 BANK0 ADRL DISPINTERRUPT) (* Keyboard interrupts have to be turned off to gaurantee proper COLORNNCC bank selection. *) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (* \PUTBASE \EM.DISPINTERRUPT 0 0) (SETQ BANK1 (COND ((EQ (LOGAND PAGE# 256) 0) 0) (T 255))) (SETQ BANK0 (COND ((EQ (LOGAND PAGE# 128) 0) 0) (T 255))) (\COLORNNCCBANK1 BANK1) (\COLORNNCCBANK0 BANK0) (SETQ ADRL (UNFOLD (LOGAND PAGE# 127) BYTESPERPAGE)) (\BUSBLTOUTBYTES PAGE DISPLAYADRH ADRL WORDSPERPAGE) (* \PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT) ))) (\COLORNNCC.PILOTBITBLT (LAMBDA (PILOTBBT N) (* kbr: "30-Jun-85 16:01") (PROG (DEST DESTBIT WIDTH HEIGHT VMADDR BUSADDRHI BUSADDRLO NWORDS ABSCURRPAGE CURRPAGEINBITMAP PAGE DISPINTERRUPT) (* The busmaster UPDATEDAEMON is a narrow communication bottleneck from the color screen bitmap to the color frame buffer. We work around this bottleneck by communicating small important changes to the color screen bitmap quickly and big less important changes slower. *) (* We try to make small changes that cross lots of pages appear visible in the frame buffer quickly by writing to both color screen bitmap and frame buffer. Big changes, which could be overwritten by other big changes before the UPDATEDAEMON notices them (and so save us time this way) are best left to the UPDATEDAEMON to handle. *) (* First, output to the color screen bitmap. *) (\PILOTBITBLT PILOTBBT N) (* If the PILOTBBT is disjoint or is fairly wide, then just return now. *) (COND ((OR (NOT (fetch (PILOTBBT PBTDISJOINT) of PILOTBBT)) (IGREATERP (fetch (PILOTBBT PBTWIDTH) of PILOTBBT) 1000)) (RETURN))) (* Probably a case worth optimizing: cursors, carets, characters, vertical drawlines, and vertical scroll bars. \BUSBLTOUTBYTES works in words, not pixels (bytes)%. We handle this problem by getting the values for our pixels from the DEST we just did our \PILOTBITBLT to, slopping over to a few unchanged pixels when necessary. *) (SETQ DEST (fetch (PILOTBBT PBTDEST) of PILOTBBT)) (SETQ DESTBIT (fetch (PILOTBBT PBTDESTBIT) of PILOTBBT)) (SETQ WIDTH (fetch (PILOTBBT PBTWIDTH) of PILOTBBT)) (SETQ HEIGHT (fetch (PILOTBBT PBTHEIGHT) of PILOTBBT)) (SETQ ABSCURRPAGE (fetch (POINTER PAGE#) of DEST)) (SETQ CURRPAGEINBITMAP (IDIFFERENCE ABSCURRPAGE ColorScreenBitMapBasePage)) (SETQ PAGE (LOGAND CURRPAGEINBITMAP 127)) (SETQ BUSADDRLO (UNFOLD (IPLUS (UNFOLD PAGE WORDSPERPAGE) (fetch (POINTER WORDINPAGE) of DEST) (FOLDLO DESTBIT BITSPERWORD)) BYTESPERWORD)) (SETQ NWORDS (IDIFFERENCE (FOLDHI (IPLUS DESTBIT WIDTH -1) BITSPERWORD) (FOLDLO DESTBIT BITSPERWORD))) (* Keyboard interrupts have to be turned off to gaurantee proper COLORNNCC bank selection. *) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (SETQ \COLORNNCC.SENDPAGERAN NIL) (SETQ \COLORNNCC.CURSORRAN T) (\COLORNNCCBANK1 (COND ((EQ (LOGAND CURRPAGEINBITMAP 256) 0) 0) (T 255))) (\COLORNNCCBANK0 (COND ((EQ (LOGAND CURRPAGEINBITMAP 128) 0) 0) (T 255))) (SETQ DEST (\ADDBASE DEST (FOLDLO DESTBIT BITSPERWORD))) (for I from 1 to HEIGHT do (\BUSBLTOUTBYTES DEST DISPLAYADRH BUSADDRLO NWORDS) (COND ((EQ I HEIGHT) (RETURN))) (SETQ DEST (\ADDBASE DEST WORDSPERPAGE)) (SETQ PAGE (ADD1 PAGE)) (COND ((ILESSP PAGE 128) (SETQ BUSADDRLO (IPLUS BUSADDRLO BYTESPERPAGE ))) (T (* Crossing into different bank. *) (COND ((EQ \COLORNNCC.BANK0 0) (\COLORNNCCBANK0 255)) (T (\COLORNNCCBANK1 255) (\COLORNNCCBANK0 0))) (SETQ PAGE 0) (SETQ BUSADDRLO (IDIFFERENCE BUSADDRLO (IDIFFERENCE 65536 BYTESPERPAGE) ))))) (COND (\COLORNNCC.SENDPAGERAN (SETQ \COLORNNCC.SENDPAGEINTERRUPTED T))) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT)))) ) (DEFINEQ (\COLORNNCC24.STARTBOARD (LAMBDA NIL (* kbr: "15-Feb-86 16:14") (* First part is just like setting up the REV512X8. *) (\COLORNNCC.STARTBOARD) (* Set up REV512X32 color lookup tables. *) (for I from 4096 to 16383 do (PCBUS.WRITEHL PARAMADRH I (LOGXOR (LOGAND I 255) 255))) (* I believe the following two commands will set REV512X32 to work in RGB-GUN MODE. I was never able to find and/or make PIXEL MODE work. *) (PCBUS.WRITEHL 12 1796 0) (PCBUS.WRITEHL 12 1797 0))) (\COLORNNCC24.STARTCOLOR (LAMBDA (FDEV) (* kbr: "15-Feb-86 18:24") (PROG NIL (COND ((NULL \COLORNNCC24.REDBASE) (SETQ \COLORNNCC24.REDBASE (NCREATE (QUOTE VMEMPAGEP))) (SETQ \COLORNNCC24.GREENBASE (NCREATE (QUOTE VMEMPAGEP))) (SETQ \COLORNNCC24.BLUEBASE (NCREATE (QUOTE VMEMPAGEP))) (\LOCKPAGES \COLORNNCC24.REDBASE 1) (\LOCKPAGES \COLORNNCC24.GREENBASE 1) (\LOCKPAGES \COLORNNCC24.BLUEBASE 1) (\LOCKVAR (QUOTE \COLORNNCC24.REDBASE)) (\LOCKVAR (QUOTE \COLORNNCC24.GREENBASE)) (\LOCKVAR (QUOTE \COLORNNCC24.BLUEBASE)))) (\BUSCOLOR.STARTCOLOR FDEV)))) (\COLORNNCC24.SENDPAGE (LAMBDA (PAGE PAGE#) (* kbr: "16-Feb-86 00:01") (PROG (POINTER ADRL DISPINTERRUPT X Y REDBANK GREENBANK BLUEBANK) (* Keyboard interrupts have to be turned off to gaurantee proper COLORNNGS bank selection. *) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (* \PUTBASE \EM.DISPINTERRUPT 0 0) (* The code below separates out the 8bit red, 8bit green, and 8bit blue components of a packed page of 24bit color. The first color boundary begins with one of first three bytes of the packed page, and we must case out. There will be 171, 171, and 170 bytes or a rotation thereof of red, green, and blue to be dealt with. Once the red, green, and blue components are separated out, they must be shipped to the BusMaster. We need to ship these components to the right banks of the REV512X32 board. We are only allowed to ship out a multiple of words, so we ship 172 bytes in all cases getting the extra 1, 1, and 2 bytes that we will need to ship from the right places. *) (PROGN (* Calculate red, green, blue components. *) (SETQ POINTER PAGE) (SETQ Y (IQUOTIENT PAGE# 3)) (SELECTQ (IREMAINDER PAGE# 3) (0 (SETQ X 0)) (1 (SETQ POINTER (\ADDBASE POINTER -1)) (SETQ X 170)) (PROGN (SETQ POINTER (\ADDBASE POINTER -2)) (SETQ X 340))) (for I from 0 to 171 as R from 0 by 3 as G from 1 by 3 as B from 2 by 3 do (\PUTBASEBYTE \COLORNNCC24.REDBASE I (\GETBASEBYTE POINTER R)) (\PUTBASEBYTE \COLORNNCC24.GREENBASE I (\GETBASEBYTE POINTER G)) (\PUTBASEBYTE \COLORNNCC24.BLUEBASE I (\GETBASEBYTE POINTER B))) (SETQ ADRL (IPLUS (LLSH (LOGAND Y 127) 9) X))) (PROGN (* Ship red component. *) (SETQ REDBANK (LRSH Y 7)) (PCBUS.WRITEHL 12 1024 REDBANK) (\BUSBLTOUTBYTES \COLORNNCC24.REDBASE DISPLAYADRH ADRL (FOLDLO 172 2))) (PROGN (* Ship green component. *) (SETQ GREENBANK (IPLUS 4 REDBANK)) (PCBUS.WRITEHL 12 1024 GREENBANK) (\BUSBLTOUTBYTES \COLORNNCC24.GREENBASE DISPLAYADRH ADRL (FOLDLO 172 2))) (PROGN (* Ship blue component. *) (SETQ BLUEBANK (IPLUS 8 REDBANK)) (PCBUS.WRITEHL 12 1024 BLUEBANK) (\BUSBLTOUTBYTES \COLORNNCC24.BLUEBASE DISPLAYADRH ADRL (FOLDLO 172 2))) (* \PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT) ))) ) (DEFINEQ (\COLORNNCC.DEMO (LAMBDA NIL (* kbr: " 4-Jan-86 16:26") (for I from 0 to 511 do (for J from 0 to 127 do (PCBUS.WRITEHL 10 (PLUS (TIMES 512 J) I) I))) (for I from 0 to 255 do (PCBUS.WRITEHL 12 (PLUS 256 I) I) (PCBUS.WRITEHL 12 (PLUS 512 I) I) (PCBUS.WRITEHL 12 (PLUS 768 I) I)))) (\COLORNNCC.DRAWLINE1 (LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE) (* edited: " 2-Jun-85 17:53") (PROG NIL (* DIR PLANE EAD DC D D2 D1 DM DI DD) (SETQ DI (IMAX DX DY)) (SETQ DD (IMIN DX DY)) (SETQ DIR (COND ((ILESSP YINC 0) (COND ((IGREATERP DY DX) 0) (T 1))) (T (COND ((IGREATERP DY DX) 2) (T 3))))) (SETQ PLANE 0) (SETQ EAD (IPLUS (ITIMES (IDIFFERENCE 479 Y0) 64) (LRSH X0 4) (ITIMES PLANE 16384))) (* CURS) (\COLORNNCC.CMD (LIST 73 (LOGAND EAD 255) (LOGAND (LRSH EAD 8) 255) (IPLUS (LLSH (LOGAND X0 15) 4) (LRSH EAD 16)))) (* WDAT) (\COLORNNCC.CMD (LIST (IPLUS 32 (SELECTQ MODE (PAINT 3) (REPLACE 0) (INVERSE 1) (RETURN))))) (PROGN (* FIGS) (\COLORNNCC.CMD (LIST 76 (IPLUS 8 DIR))) (\COLORNNCC.PAR2 (SETQ DC (IMAX DX DY))) (\COLORNNCC.PAR2 (SETQ D (IPLUS DD DD (IMINUS DI)))) (\COLORNNCC.PAR2 (SETQ D2 (LLSH (IDIFFERENCE DD DI) 1))) (\COLORNNCC.PAR2 (SETQ D1 (IPLUS DD DD))) (\COLORNNCC.PAR2 (SETQ DM 65535))) (* FIGD) (\COLORNNCC.CMD (QUOTE (108)))))) (\COLORNNCC.TEST3 (LAMBDA NIL (* edited: " 2-Jun-85 18:12") (for X from 0 to 100 by 10 do (\COLORNNCC.DRAWLINE1 0 479 512 0 X 100 0 -1 (QUOTE INVERSE))) (for Y from 0 to 90 by 10 do (\COLORNNCC.DRAWLINE1 0 479 512 0 100 Y 0 -1 (QUOTE INVERSE))))) (MYTEST (LAMBDA (COLOR) (* kbr: "14-Feb-86 00:37") (for I from 0 to 511 do (for J from 0 to I do (TEST24 I J COLOR))))) (TEST24 (LAMBDA (X Y NEWVALUE) (* kbr: "14-Feb-86 00:58") (* Write NEWVALUE out to X Y of REV512X32 board. *) (PROG (LO) (SETQ LO (IPLUS (LLSH (LOGAND Y 127) 9) X)) (PCBUS.WRITEHL 12 1024 (LRSH Y 7)) (PCBUS.WRITEHL 10 LO (LOGAND (LRSH NEWVALUE 16) 255)) (PCBUS.WRITEHL 12 1024 (IPLUS 4 (LRSH Y 7))) (PCBUS.WRITEHL 10 LO (LOGAND (LRSH NEWVALUE 8) 255)) (PCBUS.WRITEHL 12 1024 (IPLUS 8 (LRSH Y 7))) (PCBUS.WRITEHL 10 LO (LOGAND NEWVALUE 255))))) (TESTMODE (LAMBDA (X Y) (* kbr: "13-Feb-86 23:28") (PCBUS.WRITEHL 12 1796 X) (PCBUS.WRITEHL 12 1797 Y))) (TESTCM (LAMBDA NIL (* kbr: "15-Feb-86 11:14") (* Set up color tables. *) (for I from 4096 to 16383 do (PCBUS.WRITEHL PARAMADRH I (LOGXOR (LOGAND I 255) 255))))) ) (FILESLOAD BUSCOLOR) (* \DEBUG vars are temporary till I figure out bank switching. *) (RPAQQ \COLORNNCC.LOCKEDFNS (\COLORNNCC.SENDPAGE \COLORNNCC.PILOTBITBLT)) (RPAQQ \COLORNNCC.LOCKEDVARS (\COLORNNCC.BANK1 \COLORNNCC.BANK0 \DEBUG.CURSORRAN \DEBUG.SENDPAGERAN \DEBUG.CURSORINTERRUPTED \DEBUG.SENDPAGEINTERRUPTED)) (DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (\COLORNNCC.INIT) ) (PUTPROPS COLORNNCC COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (4685 5616 (\COLORNNCC.CMD 4695 . 5178) (\COLORNNCC.PAR2 5180 . 5614)) (5617 7947 ( \COLORNNCC.INIT 5627 . 7945)) (7948 18345 (\COLORNNCC.STARTBOARD 7958 . 9539) ( \COLORNNCC.SENDCOLORMAPENTRY 9541 . 10089) (\COLORNNCC.SENDPAGE 10091 . 11747) (\COLORNNCC.PILOTBITBLT 11749 . 18343)) (18346 25083 (\COLORNNCC24.STARTBOARD 18356 . 19565) (\COLORNNCC24.STARTCOLOR 19567 . 20421) (\COLORNNCC24.SENDPAGE 20423 . 25081)) (25084 30973 (\COLORNNCC.DEMO 25094 . 25996) ( \COLORNNCC.DRAWLINE1 25998 . 28329) (\COLORNNCC.TEST3 28331 . 28786) (MYTEST 28788 . 29135) (TEST24 29137 . 30150) (TESTMODE 30152 . 30407) (TESTCM 30409 . 30971))))) STOP \ No newline at end of file diff --git a/lispusers/COLOROBJ b/lispusers/COLOROBJ new file mode 100644 index 00000000..ad5235f0 --- /dev/null +++ b/lispusers/COLOROBJ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 4-Feb-87 23:58:42" {ERIS}LYRIC>COLOROBJ.;2 7868 changes to%: (VARS COLOROBJCOMS COLOROBJFNS) previous date%: "26-Feb-86 14:47:40" {ERIS}LYRIC>COLOROBJ.;1) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COLOROBJCOMS) (RPAQQ COLOROBJCOMS [(FNS * COLOROBJFNS) (FILES COLOR) (INITVARS (COLOROBJ.DEFAULT.COLOR 'RED)) (VARS (COLOROBJFNS '(COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN)) (COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN) (FUNCTION COLOROBJ.IMAGEBOXFN) (FUNCTION COLOROBJ.PUTFN) (FUNCTION COLOROBJ.GETFN) (FUNCTION COLOROBJ.COPYFN) (FUNCTION COLOROBJ.BUTTONEVENTFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION COLOROBJ.WHENOPERATEDONFN) (FUNCTION NILL]) (RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN)) (DEFINEQ (COLOROBJ.CREATE [LAMBDA (COLOR) (* gbn "13-Jan-86 16:00") (* * create a color object. color is anything acceptable to dspcolor  (atoms on colornames, rgb triples, indices)) (LET ((COLOROBJ (IMAGEOBJCREATE NIL COLOROBJ.IMAGEFNS))) (IMAGEOBJPROP COLOROBJ 'COLOR (OR COLOR COLOROBJ.DEFAULT.COLOR)) COLOROBJ]) (COLOROBJ.DISPLAYFN [LAMBDA (COLOROBJ IMAGE.STREAM) (* gbn "13-Jan-86 17:51") (* On the display a color object shows up as the color name, otherwise it has  no image. On any stream it has the sideeffect of changing the foreground color) (LET* ((COLOR (IMAGEOBJPROP COLOROBJ 'COLOR)) (X (DSPXPOSITION NIL IMAGE.STREAM)) (Y (DSPYPOSITION NIL IMAGE.STREAM))) (DSPCOLOR COLOR IMAGE.STREAM) (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (DISPLAY (DSPFONT '(WEIGHT BOLD) IMAGE.STREAM) (LET* ((STRING (IMAGEOBJPROP COLOROBJ 'COLOR)) (STRINGREGION (STRINGREGION STRING IMAGE.STREAM)) (LEFT (ADD1 (fetch (REGION LEFT) of STRINGREGION))) (BOTTOM (fetch (REGION BOTTOM) of STRINGREGION)) (REGION (create REGION LEFT _ LEFT BOTTOM _ BOTTOM HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of STRINGREGION) 2) WIDTH _ (IPLUS (fetch (REGION WIDTH) of STRINGREGION) 6))) (TOP (fetch (REGION TOP) of REGION)) (RIGHT (fetch (REGION RIGHT) of REGION))) (IMAGEOBJPROP COLOROBJ 'REGION REGION) (CENTERPRINTINREGION STRING REGION IMAGE.STREAM) (DRAWLINE LEFT BOTTOM LEFT (SUB1 TOP) 1 'INVERT IMAGE.STREAM) (DRAWLINE LEFT TOP (SUB1 RIGHT) TOP 1 'INVERT IMAGE.STREAM) (DRAWLINE RIGHT TOP RIGHT (ADD1 BOTTOM) 1 'INVERT IMAGE.STREAM) (DRAWLINE RIGHT BOTTOM (ADD1 LEFT) BOTTOM 1 'INVERT IMAGE.STREAM))) (NILL]) (COLOROBJ.GETFN [LAMBDA (INPUT.STREAM TEXTSTREAM) (* gbn "13-Jan-86 15:42") (* reads the COLOR and creates an  COLOROBJ) (COLOROBJ.CREATE (READ INPUT.STREAM]) (COLOROBJ.IMAGEBOXFN [LAMBDA (COLOROBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* gbn "13-Jan-86 16:01") (* * Returns a null imagebox, except to the display, where it returns the size  of the box) (LET NIL (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (DISPLAY (create IMAGEBOX XSIZE _ (IPLUS (STRINGWIDTH (IMAGEOBJPROP COLOROBJ 'COLOR) (DSPFONT NIL IMAGE.STREAM)) 8) YSIZE _ (IPLUS (FONTHEIGHT (DSPFONT NIL IMAGE.STREAM)) 4) YDESC _ 4 XKERN _ 0)) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (COLOROBJ.PUTFN [LAMBDA (COLOROBJ OUTPUT.STREAM) (* gbn "13-Jan-86 15:57") (* prints only the color to the file) (PRINT (IMAGEOBJPROP COLOROBJ 'COLOR) OUTPUT.STREAM]) (COLOROBJ.COPYFN [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* gbn "13-Jan-86 15:58") (COLOROBJ.CREATE (IMAGEOBJPROP IMAGEOBJ 'COLOR) TOSTREAM]) (COLOROBJ.WHENOPERATEDONFN [LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23") (* DUMMY) ]) ) (FILESLOAD COLOR) (RPAQ? COLOROBJ.DEFAULT.COLOR 'RED) (RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN)) (RPAQ COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN) (FUNCTION COLOROBJ.IMAGEBOXFN) (FUNCTION COLOROBJ.PUTFN) (FUNCTION COLOROBJ.GETFN) (FUNCTION COLOROBJ.COPYFN) (FUNCTION COLOROBJ.BUTTONEVENTFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION COLOROBJ.WHENOPERATEDONFN) (FUNCTION NILL))) (PUTPROPS COLOROBJ COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1994 6812 (COLOROBJ.CREATE 2004 . 2428) (COLOROBJ.DISPLAYFN 2430 . 4799) ( COLOROBJ.GETFN 4801 . 5136) (COLOROBJ.IMAGEBOXFN 5138 . 6118) (COLOROBJ.PUTFN 6120 . 6406) ( COLOROBJ.COPYFN 6408 . 6601) (COLOROBJ.WHENOPERATEDONFN 6603 . 6810))))) STOP \ No newline at end of file diff --git a/lispusers/COLORPOLYGONS b/lispusers/COLORPOLYGONS new file mode 100644 index 00000000..7d3c9085 --- /dev/null +++ b/lispusers/COLORPOLYGONS @@ -0,0 +1 @@ +(FILECREATED " 3-Sep-86 22:07:11" {ERIS}LIBRARY>COLORPOLYGONS.;4 27440 changes to: (FNS MOTIONIT COLORPOLYGONS.ROTATECOLORMAP) previous date: " 6-Jun-86 00:35:47" {ERIS}LIBRARY>COLORPOLYGONS.;2) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT COLORPOLYGONSCOMS) (RPAQQ COLORPOLYGONSCOMS ((FNS COLORPOLYGONS COLORPOLYGON COLORPOLYGONS.ROTATECOLORMAP) (FNS BLACKHOLE BLACKHOLE1 COLORCONNECTPOLYS COLORDRAWPOLY1 DRAWCOLORPOLYSTEPS LENSE LINETEST MAPIT MAPIT2 MOTIONIT ONECOLORPOLY RANDOMPT) (INITVARS (MOTIONMAP) (ONEMAP) (PRETTYMAP)) (VARS MOTIONMAPCOLORS ONEMAPCOLORS PRETTYCOLORS))) (DEFINEQ (COLORPOLYGONS (LAMBDA (DS) (* kbr: " 6-Jun-86 00:16") (PROG (BITSPERPIXEL NPTS) (COND ((NULL DS) (SETQ DS (DSPCREATE (COLORSCREENBITMAP))) (DSPCLIPPINGREGION (LIST 0 0 (BITMAPWIDTH (COLORSCREENBITMAP)) (BITMAPHEIGHT (COLORSCREENBITMAP))) DS))) LP (COLORPOLYGON DS) (COLORPOLYGONS.ROTATECOLORMAP) (GO LP)))) (COLORPOLYGON (LAMBDA (DS) (* kbr: " 6-Jun-86 00:10") (PROG (NPTS) (COLORCONNECTPOLYS (for I from 1 to (SETQ NPTS (RAND 3 8)) collect (RANDOMPT DS)) (for I from 1 to NPTS collect (RANDOMPT DS)) (ITIMES 15 (RAND 3 4)) T 1 1 15 8 DS)))) (COLORPOLYGONS.ROTATECOLORMAP (LAMBDA NIL (* kbr: " 3-Sep-86 21:31") (PROG (BITSPERPIXEL) (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) (COND ((EQ BITSPERPIXEL 4) (OR MOTIONMAP (SETQ MOTIONMAP (COLORMAPCREATE MOTIONMAPCOLORS BITSPERPIXEL))) (OR PRETTYMAP (SETQ PRETTYMAP (COLORMAPCREATE PRETTYCOLORS BITSPERPIXEL))) (SETQ WAITTIME 70)) (T (OR MOTIONMAP (SETQ MOTIONMAP (COLORMAPCREATE (for I from 1 to 8 join (NCONC (for J from 0 to 255 by 8 collect (LIST 0 0 J)) (for J from 1 to 8 collect (QUOTE (128 128 128))))) BITSPERPIXEL))) (OR PRETTYMAP (SETQ PRETTYMAP (RAINBOWMAP 8))) (SETQ WAITTIME 20))) (SCREENCOLORMAP MOTIONMAP) (CD.QUITP 40) (until (CD.QUITP) do (ROTATECOLORMAP 1)) (SCREENCOLORMAP PRETTYMAP) (CD.QUITP 40) (until (CD.QUITP) do (ROTATECOLORMAP 1) (DISMISS WAITTIME))))) ) (DEFINEQ (BLACKHOLE (LAMBDA (PTLST DS DENSITY PERCENT) (* kbr: " 5-Jun-86 23:45") (* maps a list of points onto itself  repeatedly until closure) (PROG NIL (DSPFILL NIL NIL 0 DS) (BLACKHOLE1 PTLST DS (OR DENSITY 3) (OR PERCENT 30))))) (BLACKHOLE1 (LAMBDA (PTLST DS DENSITY PERCENT) (* kbr: " 5-Jun-86 23:46") (* maps a list of points onto itself  repeatedly until closure) (PROG (CENTERX CENTERY X Y OTHERPTS) (SETQ CENTERX (IQUOTIENT (for PT in PTLST sum (fetch (POSITION XCOORD) of PT)) (LENGTH PTLST))) (SETQ CENTERY (IQUOTIENT (for PT in PTLST sum (fetch (POSITION YCOORD) of PT)) (LENGTH PTLST))) (* make another polygon that is 80%%  of the way to the edge.) (SETQ OTHERPTS (for PT in PTLST collect (create POSITION XCOORD _ (COND ((IGREATERP (SETQ X (fetch (POSITION XCOORD) of PT)) CENTERX) (IPLUS CENTERX (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE X CENTERX)) 100))) (T (IDIFFERENCE CENTERX (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE CENTERX X)) 100)))) YCOORD _ (COND ((IGREATERP (SETQ Y (fetch (POSITION YCOORD) of PT)) CENTERY) (IPLUS CENTERY (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE Y CENTERY)) 100))) (T (IDIFFERENCE CENTERY (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE CENTERY Y)) 100))))))) (* make sure the number of steps is  integral to number of colors.) (* draw from the outer one into the  inner one, shifted by one) (DRAWCOLORPOLYSTEPS PTLST (SETQ OTHERPTS (APPEND (CDR OTHERPTS) (LIST (CAR OTHERPTS)))) (ITIMES (OR DENSITY 3) 15) T 1 (MAXIMUMCOLOR) DS) (COND ((AND (for PT in OTHERPTS thereis (IGREATERP (ABS (IDIFFERENCE CENTERX (fetch (POSITION XCOORD) of PT))) 20)) (for PT in OTHERPTS thereis (IGREATERP (ABS (IDIFFERENCE CENTERY (fetch (POSITION YCOORD) of PT))) 20))) (BLACKHOLE1 OTHERPTS DS (ADD1 DENSITY) PERCENT)))))) (COLORCONNECTPOLYS (LAMBDA (FROMS TOS NSTEPS CONNECTEDFLG INCOLOR? FROMCOLOR TOCOLOR TWEENCOLOR DS) (* kbr: " 6-Jun-86 00:03") (* draws the source and destination  polygons and shows the track taken by  the sides; then leaves the trace of  the polygon in tranformation) (SETQ LASTPOLYGONFROMS FROMS) (SETQ LASTPOLYGONTOS TOS) (ERSETQ (PROG NIL (DSPFILL NIL NIL NIL DS) (COLORDRAWPOLY1 FROMS 1 CONNECTEDFLG (OR FROMCOLOR INCOLOR?) DS) (COLORDRAWPOLY1 TOS 1 CONNECTEDFLG (OR TOCOLOR INCOLOR?) DS) (SETQ DIFFS (for FPT in FROMS as TPT in TOS do (DRAWBETWEEN FPT TPT 1 NIL DS (OR TWEENCOLOR 15)))) (DISMISS 1500) (DSPFILL NIL NIL NIL DS) (DRAWCOLORPOLYSTEPS FROMS TOS NSTEPS CONNECTEDFLG INCOLOR? TOCOLOR DS))))) (COLORDRAWPOLY1 (LAMBDA (PTLIST WIDTH CONNECT? COLOR DS) (* rrb "11-OCT-82 11:43") (* draws a closed polygon of the  points given) (COND (PTLIST (for PTA in PTLIST as PTB in (CDR PTLIST) do (DRAWBETWEEN PTA PTB WIDTH (DSPOPERATION NIL DS) DS (COND ((LISTP COLOR) (* COLOR can be a list of colors for  each side.) (PROG1 (CAR COLOR) (SETQ COLOR (COND ((CDR COLOR)) (T (CAR COLOR)))))) (T COLOR))) finally (AND CONNECT? (DRAWBETWEEN (CAR (LAST PTLIST)) (CAR PTLIST) WIDTH (DSPOPERATION NIL DS) DS (COND ((LISTP COLOR) (PROG1 (CAR COLOR) (SETQ COLOR (COND ((CDR COLOR)) (T (CAR COLOR)))))) (T COLOR))) DS)))) (BLOCK))) (DRAWCOLORPOLYSTEPS (LAMBDA (FROMS TOS NSTEPS CONNECTEDFLG FROMCOLOR MAXCOLOR DS) (* rrb "15-OCT-82 14:47") (PROG (DIFFS XFROMS) (SETQ XFROMS (COPY FROMS)) (SETQ DIFFS (for FPT in XFROMS as TPT in TOS collect (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of TPT) (fetch (POSITION XCOORD) of FPT)) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of TPT) (fetch (POSITION YCOORD) of FPT))))) (for I from 1 to NSTEPS do (COLORDRAWPOLY1 XFROMS 1 CONNECTEDFLG (COND ((FIXP FROMCOLOR) (COND ((IGREATERP FROMCOLOR MAXCOLOR) (SETQ FROMCOLOR 1))) (PROG1 FROMCOLOR (SETQ FROMCOLOR (ADD1 FROMCOLOR)))) (T FROMCOLOR)) DS) (for PT in XFROMS as DIF in DIFFS as FROMPT in FROMS do (replace (POSITION XCOORD) of PT with (IPLUS (fetch (POSITION XCOORD) of FROMPT) (IQUOTIENT (ITIMES (fetch (POSITION XCOORD) of DIF) I) NSTEPS))) (replace (POSITION YCOORD) of PT with (IPLUS (fetch (POSITION YCOORD) of FROMPT) (IQUOTIENT (ITIMES (fetch (POSITION YCOORD) of DIF) I) NSTEPS)))) finally (COLORDRAWPOLY1 XFROMS 1 CONNECTEDFLG (COND ((FIXP FROMCOLOR) (COND ((IGREATERP FROMCOLOR MAXCOLOR ) (SETQ FROMCOLOR 1))) (PROG1 FROMCOLOR (SETQ FROMCOLOR (ADD1 FROMCOLOR )))) (T FROMCOLOR)) DS)) (RETURN FROMCOLOR)))) (LENSE (LAMBDA (PTLST DS DENSITY PERCENT OUTTOOFLG) (* kbr: " 5-Jun-86 23:52") (* maps a list of points onto itself  repeatedly until closure) (PROG (CENTERX CENTERY X Y OTHERPTS MAXCOLOR ENDCOLOR) (SETQ CENTERX (IQUOTIENT (for PT in PTLST sum (fetch (POSITION XCOORD) of PT)) (LENGTH PTLST))) (SETQ CENTERY (IQUOTIENT (for PT in PTLST sum (fetch (POSITION YCOORD) of PT)) (LENGTH PTLST))) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL (COLORSCREENBITMAP)))) (DSPFILL NIL NIL NIL DS) (* make another polygon that is 80%%  of the way to the edge.) (SETQ OTHERPTS (for PT in PTLST collect (create POSITION XCOORD _ (COND ((IGREATERP (SETQ X (fetch (POSITION XCOORD) of PT)) CENTERX) (IPLUS CENTERX (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE X CENTERX)) 100))) (T (IDIFFERENCE CENTERX (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE CENTERX X)) 100)))) YCOORD _ (COND ((IGREATERP (SETQ Y (fetch (POSITION YCOORD) of PT)) CENTERY) (IPLUS CENTERY (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE Y CENTERY)) 100))) (T (IDIFFERENCE CENTERY (IQUOTIENT (ITIMES PERCENT (IDIFFERENCE CENTERY Y)) 100))))))) (* make sure the number of steps is  integral to number of colors.) (* draw from the outer one into the  inner one, shifted by one) (SETQ ENDCOLOR (DRAWCOLORPOLYSTEPS PTLST (CONS (CAR (LAST OTHERPTS)) (BUTLAST OTHERPTS)) (ITIMES (OR DENSITY 3) 15) T 1 MAXCOLOR DS)) (* draw from the inner polygon to the  outer one shifted by two sides) (AND OUTTOOFLG (DRAWCOLORPOLYSTEPS (APPEND (CDR OTHERPTS) (LIST (CAR OTHERPTS))) PTLST (ITIMES (OR DENSITY 3) 15) T ENDCOLOR MAXCOLOR DS))))) (LINETEST (LAMBDA (DS) (for Y from 100 to 400 by 300 do (for I from 100 to 400 by 20 do (DRAWLINE 250 250 I Y 1 NIL DS (RAND 1 15)))) (for X from 100 to 400 by 300 do (for I from 100 to 400 by 20 do (DRAWLINE 250 250 X I 1 NIL DS (RAND 1 15)))))) (MAPIT (LAMBDA (PTLST DS DENSITY) (* kbr: " 5-Jun-86 23:52") (* maps a list of points onto itself) (DSPFILL NIL NIL NIL DS) (DRAWCOLORPOLYSTEPS PTLST (SETQ PTLST (APPEND (CDR PTLST) (CONS (CAR PTLST)))) (ITIMES (OR DENSITY 3) 15) T 1 (MAXIMUMCOLOR (BITSPERPIXEL (COLORSCREENBITMAP))) DS))) (MAPIT2 (LAMBDA (N DS DENSITY) (* kbr: " 5-Jun-86 23:53") (* create a random list of N points  and maps it onto N others.) (PROG (ORGPOINTS NOWCOLOR MAXCOLOR) (SETQ ORGPOINTS (for I from 1 to N collect (RANDOMPT DS))) (SETQ NOWCOLOR 1) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL (COLORSCREENBITMAP)))) (DSPFILL NIL NIL NIL DS) (SETQ STARTPTS ORGPOINTS) (* make sure the number of steps is  integral to number of colors.) (for COUNTER from 1 to N do (* make the first pt of the new set  the same as the last pt of the  previous one.) (SETQ NEWPTS (COND ((EQ COUNTER N) (* for the past group, return to the  starting points.) ORGPOINTS) (T (CONS (CAR (LAST STARTPTS)) (COND ((EQ COUNTER (SUB1 N)) (* for next to last group make the  last point the same as the start.) (NCONC1 (for I from 1 to (IDIFFERENCE N 2) collect (RANDOMPT DS)) (CAR ORGPOINTS))) (T (for I from 1 to (SUB1 N) collect (RANDOMPT DS)))))))) (SETQ NOWCOLOR (DRAWCOLORPOLYSTEPS STARTPTS NEWPTS (ITIMES (OR DENSITY 3) 15) NIL NOWCOLOR MAXCOLOR DS)) (SETQ STARTPTS NEWPTS))))) (MOTIONIT (LAMBDA (WINDOW) (* kbr: " 3-Sep-86 22:06") (PROG NIL LP (SCREENCOLORMAP ONEMAP) (ONECOLORPOLY (RAND 3 4) 45 T 1 1 15 8 WINDOW) (DISMISS 2000) (SCREENCOLORMAP MOTIONMAP) (CD.QUITP 10) (until (CD.QUITP) do (ROTATECOLORMAP 1) (DISMISS 75)) (SCREENCOLORMAP PRETTYMAP) (CD.QUITP 20) (until (CD.QUITP) do (ROTATECOLORMAP 1) (DISMISS 75)) (SCREENCOLORMAP ONEMAP) (DISMISS 2000) (GO LP)))) (ONECOLORPOLY (LAMBDA (NPOINTS NSTEPS CONNECTED? INCOLOR? FROMCOLOR TOCOLOR TWEENCOLOR DS) (* rrb "11-OCT-82 11:41") (* draws a polygon figure on the display stream DS.  INCOLOR? can be NIL for black and white case, a color number for the increment  each polygons case, or a list of color numbers to be used for each edge of the  polygons.) (COLORCONNECTPOLYS (for I from 1 to NPOINTS collect (RANDOMPT DS)) (for I from 1 to NPOINTS collect (RANDOMPT DS)) (OR NSTEPS POLYGONSTEPS) CONNECTED? INCOLOR? TOCOLOR FROMCOLOR TWEENCOLOR DS))) (RANDOMPT (LAMBDA (DS) (* kbr: " 6-Jun-86 00:01") (PROG (REG) (SETQ REG (DSPCLIPPINGREGION NIL DS)) (RETURN (create POSITION XCOORD _ (RAND (fetch (REGION LEFT) of REG) (fetch (REGION RIGHT) of REG)) YCOORD _ (RAND (fetch (REGION BOTTOM) of REG) (fetch (REGION TOP) of REG))))))) ) (RPAQ? MOTIONMAP ) (RPAQ? ONEMAP ) (RPAQ? PRETTYMAP ) (RPAQQ MOTIONMAPCOLORS ((0 0 0) (0 0 0) (0 0 0) (0 0 0) (0 0 0) (0 0 0) (0 0 0) (0 0 79) (0 0 126) (0 0 168) (0 0 199) (0 0 255) (0 0 0) (0 0 0) (0 0 0) (0 0 0))) (RPAQQ ONEMAPCOLORS ((100 100 100) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0) (255 0 0))) (RPAQQ PRETTYCOLORS ((0 0 0) (255 0 0) (255 206 0) (255 255 0) (128 255 0) (0 255 0) (0 255 128) (0 255 255) (0 128 255) (0 0 255) (128 0 255) (255 0 255) (255 128 255) (217 210 195) (160 172 180) (203 161 75))) (PUTPROPS COLORPOLYGONS COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (876 3221 (COLORPOLYGONS 886 . 1403) (COLORPOLYGON 1405 . 1808) ( COLORPOLYGONS.ROTATECOLORMAP 1810 . 3219)) (3222 25720 (BLACKHOLE 3232 . 3670) (BLACKHOLE1 3672 . 8507 ) (COLORCONNECTPOLYS 8509 . 9805) (COLORDRAWPOLY1 9807 . 11661) (DRAWCOLORPOLYSTEPS 11663 . 15717) ( LENSE 15719 . 20419) (LINETEST 20421 . 20841) (MAPIT 20843 . 21355) (MAPIT2 21357 . 23757) (MOTIONIT 23759 . 24427) (ONECOLORPOLY 24429 . 25187) (RANDOMPT 25189 . 25718))))) STOP \ No newline at end of file diff --git a/lispusers/COMMENTHACKS b/lispusers/COMMENTHACKS new file mode 100644 index 00000000..8a3c1b25 --- /dev/null +++ b/lispusers/COMMENTHACKS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Dec-87 13:33:22" {DSK}COMMENTHACKS.;7 14426 changes to%: (FNS MYSUPERPRINT/COMMENT2 MYSUPERPRINT/COMMENT EDITDEF.FUNCTIONS FIXDEFUNEDITDATE COMMENT2 MYEDITDATE? EDITDATE?) (VARS COMMENTHACKSCOMS) (FUNCTIONS FOOFUNCTIONS) (PROPS (COMMENTHACKS MAKEFILE-ENVIRONMENT)) previous date%: "10-Dec-87 10:58:48" {DSK}COMMENTHACKS.;1) (* " Copyright (c) 1987 by Unisys Corp.. All rights reserved. ") (PRETTYCOMPRINT COMMENTHACKSCOMS) (RPAQQ COMMENTHACKSCOMS ((FNS EDITDEF.FUNCTIONS FIXDEFUNEDITDATE MYEDITDATE? MYSUPERPRINT/COMMENT MYSUPERPRINT/COMMENT2) (P (MOVD 'MYEDITDATE? 'EDITDATE?) (MOVD 'MYSUPERPRINT/COMMENT 'SUPERPRINT/COMMENT)) (PROP EDITDEF FUNCTIONS) (PROP (MAKEFILE-ENVIRONMENT FILETYPE) COMMENTHACKS) (EDITHIST COMMENTHACKS))) (DEFINEQ (EDITDEF.FUNCTIONS [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS) (* ; "Edited 10-Dec-87 10:37 by DJVB") (LET [(DEF (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY] (SETQ RETRY NIL) (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG) (MARKASCHANGED NAME TYPE 'CHANGED) (FIXDEFUNEDITDATE DEF) (PUTDEF NAME TYPE DEF] OPTIONS) (* ; "AND SAY WE EDITED IT") T]) (FIXDEFUNEDITDATE [LAMBDA (EXPR) (* ; "Edited 10-Dec-87 10:42 by DJVB") (* ;; "Inserts or replaces previous edit date in a (DEFUN f (args) (DECLARE --)... %"doc string%" EDITDATE body") (AND INITIALS (LISTP EXPR) (FMEMB (CAR EXPR) '(CL:DEFUN DEFMACRO ) ) (LISTP (CDDR EXPR)) (PROG ((E (CDDDR EXPR))) RETRY (COND ((NLISTP E) (RETURN)) ((LISTP (CAR E)) (SELECTQ (CAAR E) ((DECLARE) (SETQ E (CDR E)) (GO RETRY)) (BREAK1 (COND ((EQ (CAR (CADAR E)) 'PROGN) (SETQ E (CDR (CADAR E))) (GO RETRY)))) (ADV-PROG (* No easy way to mark cleanly the date of an advised function) (RETURN)) NIL)) ((STRINGP (CAR E)) (* ; "DOC STRING") (SETQ E (CDR E)) (GO RETRY))) (COND ((AND (LISTP (CDR E)) (EDITDATE? (CAR E))) (/RPLACA E (EDITDATE (CAR E) INITIALS))) (T (/ATTACH (EDITDATE NIL INITIALS) E))) (RETURN EXPR]) (MYEDITDATE? [LAMBDA (COMMENT) (* ; "Edited 10-Dec-87 13:50 by DJVB") (AND *REPLACE-OLD-EDIT-DATES* (LISTP COMMENT) (SUPERPRINTEQ (CAR COMMENT) COMMENTFLG) (LISTP (CDR COMMENT)) (LISTP (CDDR COMMENT)) (NULL (CDDDR COMMENT)) (STRINGP (CADDR COMMENT)) (LET ((C2 (CADR COMMENT))) (AND (NOT (SUPERPRINTEQ C2 COMMENTFLG)) (OR (EQ C2 INITIALS) (COND [(LITATOM C2) (COND [(EQ C2 ';) (AND (STRPOS "Edited " (CADDR COMMENT) 1 NIL T) (GREATERP (CL:LENGTH (CADDR COMMENT)) (CONSTANT (CL:LENGTH "Edited 01-jan-86 00:00 by X"] (T (NOT (for PC from 1 to (NCHARS C2) always (EQ (NTHCHARCODE C2 PC) (CHARCODE ;] (T (AND (STRINGP C2) (IGREATERP 12 (NCHARS C2]) (MYSUPERPRINT/COMMENT [LAMBDA (L FILE) (* ; "Edited 11-Dec-87 13:32 by DJVB") (COND ((AND **COMMENT**FLG (NOT FILEFLG) (NOT MAKEMAP)) (AND (GREATERP (PLUS (DSPXPOSITION NIL FILE) (STRINGWIDTH **COMMENT**FLG FILE)) (DSPRIGHTMARGIN NIL FILE)) (PRINENDLINE 0 FILE)) (PRIN1S **COMMENT**FLG NIL FILE)) (T (LET (COMMENT-LMARGIN COMMENT-RMARGIN RIGHTFLG FLUSH-LEFTP SEMIP BODY) (DECLARE (SPECVARS RIGHTFLG)) [SETQ RIGHTFLG (NOT (if (SUPERPRINTEQ (CADR L) COMMENTFLG) elseif (SETQ SEMIP (SEMI-COLON-COMMENT-P L)) then (NEQ SEMIP 1) else (GREATERP (LENGTH L) 10] [COND (RIGHTFLG (SETQ COMMENT-LMARGIN (OR COMMENTCOL (SUPERPRINT/COMMENT1 L RMARGIN FILE) )) (SETQ COMMENT-RMARGIN RMARGIN)) ((AND (EQ SEMIP 3) (NOT MAKEMAP)) (SETQ COMMENT-LMARGIN 0) (SETQ COMMENT-RMARGIN RMARGIN)) (T (SETQ COMMENT-LMARGIN (FIXR (TIMES RMARGIN 0.1))) (SETQ COMMENT-RMARGIN (DIFFERENCE RMARGIN COMMENT-LMARGIN)) (CL:IF (EQ COMMENT-LMARGIN (DSPXPOSITION NIL FILE)) (SETQ RIGHTFLG T] (CL:IF (GREATERP (DSPXPOSITION NIL FILE) COMMENT-LMARGIN) (PRINENDLINE COMMENT-LMARGIN FILE) (DSPXPOSITION COMMENT-LMARGIN FILE)) (OR RIGHTFLG (PRINENDLINE COMMENT-LMARGIN FILE)) (SETFONT (PROG1 (SETFONT COMMENTFONT FILE) (CL:IF (AND SEMIP (NOT MAKEMAP) [STRINGP (SETQ BODY (CAR (LISTP (CDR (LISTP (CDR L] (NULL (CDDDR L)) (OR (IMAGESTREAMP FILE) *PRINT-SEMICOLON-COMMENTS*)) (PRIN2-LONG-STRING BODY FILE NIL NIL COMMENT-LMARGIN COMMENT-RMARGIN T SEMIP) (MYSUPERPRINT/COMMENT2 L COMMENT-LMARGIN (IQUOTIENT (PLUS COMMENT-LMARGIN COMMENT-RMARGIN) 2) COMMENT-RMARGIN FILE))) FILE) (CL:IF (OR (AND SEMIP (NOT MAKEMAP)) (NOT RIGHTFLG)) (PRINENDLINE 0 FILE)) L]) (MYSUPERPRINT/COMMENT2 [LAMBDA (CMT COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE SEMIN) (* ; "Edited 11-Dec-87 13:31 by DJVB") (* ;  "SEMIN USED IN RECURSIVE CALLS TO PASS DOWN SEMI LEVEL") (if (EQ *PRINT-SEMICOLON-COMMENTS* 'ALL) then (* ;; "Print comment between given margins. Use 2 semis if (* * --) or (* --) over 10 long, otherwise use one semi.") (LET* ((SEMI (OR SEMIN (if (OR (AND (SUPERPRINTEQ (CADR CMT) COMMENTFLG) (SETQ CMT (CDR CMT))) (GREATERP (LENGTH CMT) 10)) then 2 else 1))) (SEMIS (if (EQ SEMI 2) then ";;" else ";"))) (OR SEMIN (SETQ CMT (CDR CMT))) (* ; "IF TOP LEVEL, SKIP *") (SETQ FILE (\GETSTREAM FILE 'OUTPUT)) (AND (EQ (DSPXPOSITION NIL FILE) COMMENT-LMARGIN) (PRINOPEN TAIL SEMIS FILE)) (* ;  "does PRIN3, but only do if still at left") (for TAIL on CMT bind LASTITEM THISITEM finally (if TAIL then (PRINDOTP TAIL FILE)) do (SETQ THISITEM (CAR TAIL)) [if (OR (EQ LASTITEM '-) (AND (GEQ (DSPXPOSITION NIL FILE) COMMENT-MIDPOINT) (NOT (LISTP THISITEM)) (LITATOM LASTITEM) (SELCHARQ (NTHCHARCODE LASTITEM -1) ((; %. -) T) NIL))) then (PRINENDLINE COMMENT-LMARGIN FILE) (PRINOPEN TAIL SEMIS FILE) else (if [AND (NEQ CMT TAIL) (OR (LISTP LASTITEM) (NOT (MEMB THISITEM '(%. %, ; %:] then (SUPERPRINT/SPACE FILE)) (OR (LISTP THISITEM) (STRINGP THISITEM) (if (GEQ (PLUS (DSPXPOSITION NIL FILE) (STRINGWIDTH THISITEM (OR FILE *STANDARD-OUTPUT*) T) (STRINGWIDTH (if (CDR TAIL) then " " else ")") (OR FILE *STANDARD-OUTPUT*))) COMMENT-RMARGIN) then (PRINENDLINE COMMENT-LMARGIN FILE) (PRINOPEN TAIL SEMIS FILE] (SETQ LASTITEM THISITEM) (if (LISTP LASTITEM) then (MYSUPERPRINT/COMMENT2 LASTITEM COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE SEMI) elseif (STRINGP LASTITEM) then (PRIN2-LONG-STRING LASTITEM FILE NIL TAIL COMMENT-LMARGIN COMMENT-RMARGIN T SEMI) else (PRIN2S LASTITEM TAIL FILE))) (PRINSHUT TAIL NIL FILE) (* ; "IN CASE MAKING MAP") (* ;  "AND FORCE NEWLINE IN MYSUPERPRINT/COMMENT") (SETQ RIGHTFLG NIL)) else (* ; "Do it the old way as (* --)") (SUPERPRINT/COMMENT2 CMT COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE]) ) (MOVD 'MYEDITDATE? 'EDITDATE?) (MOVD 'MYSUPERPRINT/COMMENT 'SUPERPRINT/COMMENT) (PUTPROPS FUNCTIONS EDITDEF EDITDEF.FUNCTIONS) (PUTPROPS COMMENTHACKS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS COMMENTHACKS FILETYPE :TCOMPL) (DECLARE%: DONTCOPY (ADDTOVAR EDITHISTALIST (COMMENTHACKS ("10-Dec-87 10:59:27" DJVB {DSK}COMMENTHACKS.;1 (COMMENT2 EDITDATE? MYEDITDATE? MYSUPERPRINT/COMMENT EDITDEF.FUNCTIONS FIXDEFUNEDITDATE)) ("10-Dec-87 17:09:35" DJVB {DSK}COMMENTHACKS.;3 (MYSUPERPRINT/COMMENT COMMENT2 MYSUPERPRINT/COMMENT2 MYEDITDATE?) (STUFF TO GET EDITDATE INTO FUNCTIONS AND PRINT SEMICOLON COMMENTS FOR EVERYTHING)) ("11-Dec-87 12:49:30" DJVB {DSK}COMMENTHACKS.;4 ( MYSUPERPRINT/COMMENT2 )) ("11-Dec-87 12:52:55" DJVB {DSK}COMMENTHACKS.;6 ( EDITDEF.FUNCTIONS FIXDEFUNEDITDATE ) (FIXED DETAILS)) ("11-Dec-87 13:33:43" DJVB {DSK}COMMENTHACKS.;7 ( MYSUPERPRINT/COMMENT2 MYSUPERPRINT/COMMENT ) (FIXING DETAILS)))) ) (PUTPROPS COMMENTHACKS COPYRIGHT ("Unisys Corp." 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1135 12019 (EDITDEF.FUNCTIONS 1145 . 1784) (FIXDEFUNEDITDATE 1786 . 3426) (MYEDITDATE? 3428 . 4692) (MYSUPERPRINT/COMMENT 4694 . 7753) (MYSUPERPRINT/COMMENT2 7755 . 12017))))) STOP ˙ \ No newline at end of file diff --git a/lispusers/COMMON-MAKE b/lispusers/COMMON-MAKE new file mode 100644 index 00000000..6d64ebb6 --- /dev/null +++ b/lispusers/COMMON-MAKE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Dec-87 14:48:16" {DSK}COMMON-MAKE.;5 15290 changes to%: (VARS COMMON-MAKECOMS) (FNS COMMON-FILE-COMMAND COMMON-MAKEFILE) (PROPS (COMMON-MAKE MAKEFILE-ENVIRONMENT)) previous date%: "11-Dec-87 12:53:46" {DSK}COMMON-MAKE.;1) (* " Copyright (c) 1987 by Unisys Corp.. All rights reserved. ") (PRETTYCOMPRINT COMMON-MAKECOMS) (RPAQQ COMMON-MAKECOMS ((* FUNCTIONS TO HANDLE WRITING STANDARD COMMONLISP SOURCE FILES) (FNS COMMON-FILE-COMMAND COMMON-MAKEFILE) (PROP MAKEFILE-ENVIRONMENT COMMON-MAKE) (EDITHIST COMMON-MAKE))) (* FUNCTIONS TO HANDLE WRITING STANDARD COMMONLISP SOURCE FILES) (DEFINEQ (COMMON-FILE-COMMAND [LAMBDA (COMMAND) (* ; "Edited 11-Dec-87 14:46 by DJVB") (* THE NEW COMMONLISP COMMANDS ARE MOSTLY MACROS TO THINGS THIS HANDLES) (SELECTQ (SETQ TYPE (GETFILEPKGTYPE (CAR COMMAND) 'COMMAND)) (FNS [for FN in (PRETTYCOM1 COMMAND T T) bind DEF do (SETQ DEF (GETDEF FN 'FNS)) (CL:PPRINT (SELECTQ (CAR DEF) (CL:LAMBDA `(CL:DEFUN (\, FN) ,@(CDR DEF) ) ) (LAMBDA `(CL:DEFUN (\, FN) (&OPTIONAL ,@(CADR DEF)) ,@(CDDR DEF)) ) (HELP "UNSUPPORTED LAMBDA" (CAR DEF]) (DECLARE%: [FOR DEC IN (PRETTYCOM1 COMMAND T T) BIND (CND _ '(CL:LOAD CL:EVAL)) DO (SELECTQ DEC ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (HELP)) ((FIRST NOTFIRST)) (COMPILERVARS (RETURN)) ((COPY DOCOPY) (SETQ CND (CL:ADJOIN 'CL:LOAD CND))) ((DOEVAL@COMPILE EVAL@COMPILE) (SETQ CND (CL:ADJOIN 'CL:COMPILE CND))) ((DOEVAL@LOAD EVAL@LOAD) (SETQ CND (CL:ADJOIN 'CL:LOAD CND))) (DONTCOPY (SETQ CND (CL:REMOVE 'CL:LOAD CND))) (DONTEVAL@COMPILE (SETQ CND (CL:REMOVE 'CL:COMPILE CND))) (DONTEVAL@LOAD (SETQ CND (CL:REMOVE 'CL:EVAL CND))) (PROGN (CL:FORMAT T "~&(EVAL-WHEN ~S " CND) (COMMON-FILE-COMMAND DEC) (CL:FORMAT T ")"]) (SPECVARS [CL:PPRINT `(PROCLAIM (SPECIAL ,@(PRETTYCOM1 COMMAND T T]) (GLOBALVARS [CL:PPRINT `(PROCLAIM (USER::GLOBAL ,@(PRETTYCOM1 COMMAND T T]) (LOCALVARS [CL:PPRINT `(PROCLAIM (USER::LEXICAL ,@(PRETTYCOM1 COMMAND T T]) ((PROP IFPROP) [LET ((IFFLG (EQ (CAR COMMAND) PROP)) (PROP (CADR COMMAND)) (ATMS (PRETTYCOM1 (CDR COMMAND) T T))) (IF (LISTP PROP) THEN [FOR PRP IN PROP DO (for ATM in ATMS when (OR IFFLG (GET ATM PRP)) do (CL:PPRINT `(CL:SETF (GET ',ATM ',PRP) ',(GET ATM PRP] ELSEIF (EQ PROP 'ALL) THEN (* ALL PROPERTIES) [FOR ATM IN ATMS DO (FOR PAIR ON (GETPROPLIST ATM) BY (CDDR PAIR) UNLESS (MEMB (CAR PAIR) SYSPROPS) DO (CL:PPRINT `(CL:SETF [GET ',ATM ',(CAR PAIR] ',(CADR PAIR] ELSE (for ATM in ATMS when (OR (NOT IFFLG) (GET ATM PROP)) do (CL:PPRINT `(CL:SETF (GET ',ATM ',PROP) ',(GET ATM PROP]) (PROPS [FOR AP in (PRETTYCOM1 (CDR COMMAND) T T) do (CL:PPRINT `(CL:SETF [GET ',(CAR AP) ',(CADR AP] ',(GET (CAR AP) (CADR AP]) (P (for PTHIS in (PRETTYCOM1 COMMAND T) do (CL:PPRINT PTHIS))) (MACROS (HELP "I THOUGHT YOU TRANSORED ALL THOSE MACROS" COMMAND)) ((VARS ARRAY) [for VAR in (PRETTYCOM1 COMMAND T T) do (CL:PPRINT (if (LITATOM VAR) then `(CL:DEFPARAMETER (\, VAR) ',(GETTOPVAL VAR) ) else `(CL:DEFPARAMETER (\, (CAR VAR)) ',(CADR VAR) ) ]) (INITVARS [FOR VAR IN (PRETTYCOM1 COMMAND T T) DO (CL:PPRINT (IF (LITATOM VAR) THEN `(CL:DEFVAR (\, VAR) NIL) ELSE (IF (SUPERPRINTEQ (CAR VAR) COMMENTFLG) THEN VAR ELSE `(CL:DEFVAR (\,@ VAR) ) ]) (CONSTANTS [VARS (FOR VAR IN (PRETTYCOM1 COMMAND T T) DO (CL:PPRINT (IF (LITATOM VAR) THEN `(CL:DEFCONSTANT (\, VAR) ',(GETTOPVAL VAR) ) ELSE `(CL:DEFCONSTANT (\, (CAR VAR)) ',(CADR VAR) ) ]) ((UGLYVARS HORRIBLEVARS) [LET ((*PRINT-CIRCLE* T)) (DECLARE (SPECVARS *PRINT-CIRCLE*)) (FOR VAR IN (PRETTYCOM1 COMMAND T T) DO (CL:PPRINT `(DEFPARAMETER ,VAR ',(GETTOPVAL VAR]) (ADDVARS [for AV in (PRETTYCOM1 COMMAND T T) do (CL:PPRINT (if (CDDR AV) then `[SETQ ,(CAR AV) (UNION ',(CDR AV) ,(CAR AV] else `(CL:PUSHNEW ',(CADR AV) ,(CAR AV]) (APPENDVARS [FOR AV IN (PRETTYCOM1 COMMAND T T) DO (CL:PPRINT `(SETQ ,(CAR AV) (CL:APPEND ,(CAR AV) ',(CDR AV]) (E (HELP "I HOPE THIS %"E%"KNOWS WHAT ITS DOING" COMMAND) (FOR EXP IN (PRETTYCOM1 COMMAND T) DO (EVAL EXP))) ((FILEPKGCOMS I.S.OPRS TEMPLATES BLOCKS EXPORT EDITHIST) (* JUST IGNORE THESE) NIL) ((RECORDS INITRECORDS SYSRECORDS) (HELP "I THOUGHT YOU TRANSORED ALL THOSE RECORDS" COMMAND)) (COMS (FOR COM IN (PRETTYCOM1 COMMAND T) DO (COMMON-FILE-COMMAND COM))) (ORIGINAL (* COMS, BUT WITHOUT ANY USER DEFINED  COMMANDS) (LET* ((PRTTYTEM (PRETTYCOM1 COMMAND T)) (ORIGFLG T)) (DECLARE (SPECVARS ORIGFLG)) (for COM in PRTTYTEM do (COMMON-FILE-COMMAND COM)))) (FILES (* INSIDE LISTP%: FROM dir SOURCE COMPILED LOAD LOADCOMP LOADFROM SYSLOAD PROP  ALLPROP) (* REQUIRE IS NOT IDENTICAL, BUTS IS AS CLOSE AS CL GETS) [for F in (PRETTYCOM1 COMMAND T T) bind DIR PLACE do (if (LISTP F) then (if (SETQ PLACE (MEMB 'FROM F)) then (SETQ DIR (LIST (CADR PLACE))) else (HELP "FILES OPTION?" F)) else (CL:PPRINT `(CL:REQUIRE ,F ,@DIR]) (* (IF (EQ (CADR COMMAND) '*) THEN (BOUT *STANDARD-OUTPUT* (CHARCODE FORM)) ELSE (TERPRI) (TERPRI) (TERPRI)) (PRINTDEF COMMAND NIL T) (TERPRI) (TERPRI)) (LET (MACRO) (if (SETQ MACRO (CDR (ASSOC (CAR COMMAND) PRETTYDEFMACROS))) then (for COM in (SUBPAIR (CAR MACRO) (PRETTYCOM1 COMMAND T T) (CDR MACRO)) do (COMMON-FILE-COMMAND COM)) else (HELP "CAN'T HANDLE" (CAR COMMAND]) (COMMON-MAKEFILE [LAMBDA (FILE DEBUG) (* ; "Edited 11-Dec-87 13:25 by DJVB") (PROG ((*PRINT-SEMICOLON-COMMENTS* 'ALL) (*PRINT-ARRAY* T) (*PRINT-STRUCTURE* T) **COMMENTFLG** FONTCHANGEFLG *PRINT-LENGTH* *PRINT-LEVEL* %#RPARS) (DECLARE (SPECVARS *PRINT-SEMICOLON-COMMENTS* *PRINT-ARRAY* *PRINT-STRUCTURE* **COMMENTFLG** FONTCHANGEFLG *PRINT-LENGTH* *PRINT-LEVEL* %#RPARS)) (RETURN (PROG [(*STANDARD-OUTPUT* (OPENSTREAM (PACKFILENAME 'EXTENSION 'LISP 'BODY FILE) 'OUTPUT] (DECLARE (SPECVARS *STANDARD-OUTPUT*)) (RETURN (CL:UNWIND-PROTECT (PROG (DATES FILEILNAME PKGNAME BASE (*PACKAGE* *PACKAGE*) (*PRINT-BASE* *PRINT-BASE*) (*READTABLE* (FIND-READTABLE "LISP")) ) (DECLARE (SPECVARS *PACKAGE* *PRINT-BASE* *READTABLE*)) (SETQ DATES (GETPROP (SETQ FILEILNAME (CL:INTERN (STRING FILE) "IL")) 'FILEDATES)) (SETQ PKGNAME (OR (LISTGET (GETPROP FILEILNAME 'MAKEFILE-ENVIRONMENT) :PACKAGE) "USER")) (SETQ BASE (OR (LISTGET (GETPROP FILEILNAME ' MAKEFILE-ENVIRONMENT ) :BASE) 10)) (CL:FORMAT T ";;; -*- Mode: LISP; Syntax: Common-lisp; Package: ~A; Base: ~A -*-" PKGNAME BASE) (SETQ *PACKAGE* (CL:FIND-PACKAGE PKGNAME)) (SETQ *PRINT-BASE* BASE) (CL:FORMAT T "~%%;;; File converted ~A from source ~A" (DATE) FILE) (AND DATES (CL:FORMAT T "~&;;; Original source ~A created ~A" (CDAR DATES) (CAAR DATES))) (for P in (LISTP (GETTOPVAL (FILECOMS FILE))) do (COMMON-FILE-COMMAND P)) (RETURN (FULLNAME *STANDARD-OUTPUT*))) (CLOSEF *STANDARD-OUTPUT*]) ) (PUTPROPS COMMON-MAKE MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (DECLARE%: DONTCOPY (ADDTOVAR EDITHISTALIST (COMMON-MAKE ("11-Dec-87 12:54:22" DJVB {DSK}COMMON-MAKE.;1 (COMMON-FILE-COMMAND COMMON-MAKEFILE)) ("11-Dec-87 13:35:35" DJVB {DSK}COMMON-MAKE.;2 ( COMMON-FILE-COMMAND COMMON-MAKEFILE ) (GETTING DETAILS RIGHT)) ("11-Dec-87 13:40:48" DJVB {DSK}COMMON-MAKE.;3 ( COMMON-FILE-COMMAND )) ("11-Dec-87 14:09:04" DJVB {DSK}COMMON-MAKE.;4 ( COMMON-FILE-COMMAND )) ("11-Dec-87 14:48:44" DJVB {DSK}COMMON-MAKE.;5 ( COMMON-FILE-COMMAND ) (FIXED FILE COMMENTS AND CL:DEFVAR ET AL)))) ) (PUTPROPS COMMON-MAKE COPYRIGHT ("Unisys Corp." 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (829 13460 (COMMON-FILE-COMMAND 839 . 9055) (COMMON-MAKEFILE 9057 . 13458))))) STOP ˙ \ No newline at end of file diff --git a/lispusers/COMMWINDOW b/lispusers/COMMWINDOW new file mode 100644 index 00000000..c17b191c --- /dev/null +++ b/lispusers/COMMWINDOW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED " 2-Apr-87 17:06:05" {ERIS}LYRIC>COMMWINDOW.;3 49786 changes to%: (VARS REMOTE-CURSOR COMMWINDOWCOMS) (COURIERPROGRAMS COMMWINDOW) (FNS CLOSE-FRAME START-GET-BITS SEND-BITS FRAME-EVENT MAKE-FRAME) (FUNCTIONS \PILOTBITBLT) previous date%: " 2-Apr-87 16:54:24" {ERIS}LYRIC>COMMWINDOW.;2) (* " Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMMWINDOWCOMS) (RPAQQ COMMWINDOWCOMS ( (* ;;; "Viewer end") (FNS CLOSE-FRAME GET-BITS START-GET-BITS) (FILES COURIERSERVE) (* ;;; "Sender end") (FNS SEND-BITS SEND-TILE LISTEN-TO-VIEWER MAPTILES SHUT-DOWN-VIEWER CHANGE-SENDER-UPDATE-MODE) (FUNCTIONS INCR \PILOTBITBLT) (* ;; "Controling update schemes") (INITVARS (COMM.DEFAULT.TRANSMIT.TYPE 'SQUARE) (COMM.SEND.UNCHANGED.TILES T) (COMM.UPDATE.MOUSE.POSITION 'Sender)) (GLOBALVARS COMM.DEFAULT.TRANSMIT.TYPE COMM.UPDATE.MOUSE.POSITION COMM.SEND.UNCHANGED.TILES) (* ;;; "Pruning out unchanged screen tiles") (FNS PACKET-EQUAL GET-CACHED-PACKET PUT-CACHED-PACKET) (* ;;; "Low level packet exchange code") (CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE COMM.CURSOR.CLOSE.PACKET.TYPE COMM.SHUT.DOWN.PACKET.TYPE) (VARIABLES MAX-PACKET-BITS) (RECORDS COMM.XFER.PACKET) (* ;;; "Packing and unpacking bitmaps into etherpackets") (FNS BMTOPACKET PACKETTOBM) (* ;;; "Displaying the viewing machine's cursor") (VARS REMOTE-CURSOR) (INITVARS (CURSORICON NIL)) (* ;;; "Manipulating the frame that outlines the region being viewed") (INITVARS (*FRAME-SHADE* GRAYSHADE)) (FNS FRAME-EVENT MAKE-FRAME MOVE-FRAME SHAPE-FRAME SET-FRAME-TITLE) (* ;;; "Changing the system parameters") (FNS MAKE-MENUS-WINDOW MODE-MENU) (VARS COMM-MODES) (* ;;; "Initialization") (P (COURIER.START.SERVER)) (* ;;; "Unused stuff, as far as I can tell") (FNS FASTBITBLT) (* ;;; "System file dependencies") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (LOADCOMP) LLDISPLAY LLETHER LLNS)) (COURIERPROGRAMS COMMWINDOW))) (* ;;; "Viewer end") (DEFINEQ (CLOSE-FRAME [LAMBDA (FRAME) (* ; "Edited 2-Apr-87 16:50 by Masinter") (MAPC FRAME 'CLOSEW]) (GET-BITS (LAMBDA (RECEIVE-SOCKET WINDOW) (* ; "Edited 24-Nov-86 13:16 by smL") (RESETLST (RESETSAVE NIL (LIST 'CLOSENSOCKET RECEIVE-SOCKET)) (LET ((BBT (create PILOTBBT)) (STREAM (GETSTREAM WINDOW 'OUTPUT)) (SCRATCHX 0) (SCRATCHY 0) SPREAD SCRATCH SEENX SEENY CURSORUP CURLFT CURBTM CURX CURY X Y DATA WORDLEFT WINDOWBOTTOMLINE (CURSORCOVEREDIMAGE (BITMAPCREATE 16 16)) (TRACKING-CURSOR? NIL)) (* ;  "CURLFT and CURBTM are the left and bottom of the cursor bitmap positions, adjusted for hot spot.") (bind CP PACKET THISWIDTH THISHEIGHT while T do (COND ((SETQ PACKET (GETXIP RECEIVE-SOCKET 3000)) (SELECTC (fetch (COMM.XFER.PACKET PACKET-TYPE) of PACKET) (COMM.CURSOR.PACKET.TYPE (* ; "ignore data, just move cursor ") ) (COMM.BAND.PACKET.TYPE (SETQ SPREAD (fetch (COMM.XFER.PACKET SPREAD) of PACKET)) (SETQ X (fetch (COMM.XFER.PACKET DATAX) of PACKET)) (SETQ Y (fetch (COMM.XFER.PACKET DATAY) of PACKET)) (SETQ THISWIDTH (fetch (COMM.XFER.PACKET THISWIDTH) of PACKET)) (SETQ THISHEIGHT (fetch (COMM.XFER.PACKET THISHEIGHT) of PACKET)) (COND ((AND CURSORUP (<= (- X 16) CURLFT (+ X THISWIDTH 16)) (<= (- Y 16) CURBTM (+ Y THISHEIGHT 16))) (BITBLT CURSORCOVEREDIMAGE 0 0 STREAM CURLFT CURBTM) (SETQ CURSORUP NIL))) (COND ((OR (> THISWIDTH SCRATCHX) (> THISHEIGHT SCRATCHY)) (* ;;  "make sure scratch bitmap is big enough") (SETQ SCRATCH (BITMAPCREATE (SETQ SCRATCHX (MAX SCRATCHX THISWIDTH)) (SETQ SCRATCHY (MAX SCRATCHY THISHEIGHT)) )))) (PACKETTOBM BBT (fetch (COMM.XFER.PACKET BITS) of PACKET) THISWIDTH THISHEIGHT SCRATCH 0 0 SPREAD) (BITBLT SCRATCH 0 0 WINDOW X Y THISWIDTH THISHEIGHT)) (COMM.SHUT.DOWN.PACKET.TYPE (* ;; "Shut down the listener") (CLOSEW WINDOW) (RETURN)) (PRINTOUT PROMPTWINDOW "Odd packet" (fetch (COMM.XFER.PACKET PACKET-TYPE) of PACKET))) (SETQ SEENX (fetch (COMM.XFER.PACKET CURSORX) of PACKET)) (SETQ SEENY (fetch (COMM.XFER.PACKET CURSORY) of PACKET)) (RELEASE.XIP PACKET) (COND ((AND (KEYDOWNP 'LSHIFT) (<= 0 (SETQ X (LASTMOUSEX WINDOW)) (WINDOWPROP WINDOW 'WIDTH)) (<= 0 (SETQ Y (LASTMOUSEY WINDOW)) (WINDOWPROP WINDOW 'HEIGHT))) (* ;;  "Tell the sender to track our cursor.") (SETQ CP (\FILLINXIP \XIPT.EXCHANGE RECEIVE-SOCKET (fetch XIPSOURCEHOST of PACKET) (fetch XIPSOURCESOCKET of PACKET) (fetch XIPSOURCENET of PACKET) NIL)) (* ;  "send more than we need just to see if it fixes the problem") (XIPAPPEND.WORD CP 0) (XIPAPPEND.WORD CP COMM.CURSOR.PACKET.TYPE) (* ; "turn into a cursor ack") (XIPAPPEND.WORD CP X) (XIPAPPEND.WORD CP Y) (CL:ASSERT (AND (= (fetch (COMM.XFER.PACKET PACKET-TYPE) of CP) COMM.CURSOR.PACKET.TYPE) (= (fetch (COMM.XFER.PACKET CURSORX) CP) X) (= (fetch (COMM.XFER.PACKET CURSORY) CP) Y))) (replace (ETHERPACKET EPREQUEUE) of CP with 'FREE) (SENDXIP RECEIVE-SOCKET CP) (SETQ TRACKING-CURSOR? T) (BLOCK)) (TRACKING-CURSOR? (* ;;  "Last pass we were tracking the cursor, but we aren't now. Tell the sender to stop.") (SETQ CP (\FILLINXIP \XIPT.EXCHANGE RECEIVE-SOCKET (fetch XIPSOURCEHOST of PACKET) (fetch XIPSOURCESOCKET of PACKET) (fetch XIPSOURCENET of PACKET) NIL)) (XIPAPPEND.WORD CP 0) (XIPAPPEND.WORD CP COMM.CURSOR.CLOSE.PACKET.TYPE) (replace (ETHERPACKET EPREQUEUE) of CP with 'FREE) (SENDXIP RECEIVE-SOCKET CP) (SETQ TRACKING-CURSOR? NIL))) (SETQ X (DIFFERENCE SEENX (fetch CUHOTSPOTX DEFAULTCURSOR))) (SETQ Y (DIFFERENCE SEENY (fetch CUHOTSPOTY DEFAULTCURSOR))) (COND ((AND CURSORUP (OR (NEQ X CURLFT) (NEQ Y CURBTM))) (BITBLT CURSORCOVEREDIMAGE 0 0 STREAM CURLFT CURBTM) (SETQ CURSORUP NIL))) (COND ((AND (NULL CURSORUP) (<= 0 SEENX (WINDOWPROP WINDOW 'WIDTH)) (<= 0 SEENY (WINDOWPROP WINDOW 'HEIGHT))) (* ; "put cursor up") (SETQ CURLFT X) (SETQ CURBTM Y) (BITBLT STREAM CURLFT CURBTM CURSORCOVEREDIMAGE 0 0 16 16) (BITBLT (fetch CUIMAGE DEFAULTCURSOR) 0 0 STREAM CURLFT CURBTM NIL NIL 'INPUT 'PAINT) (SETQ CURSORUP T)))))))))) (START-GET-BITS [LAMBDA (DUMMY-STREAM DUMMY-PROGRAM DUMMY-PROGRAM REGION REMOTE-USER) (* ; "Edited 2-Apr-87 16:32 by Masinter") (LET ((NS (OPENNSOCKET)) (BORDERSIZE 8)) [ADD.PROCESS (LIST 'GET-BITS NS (LIST 'QUOTE (CREATEW (with REGION REGION (CREATEREGION (DIFFERENCE LEFT BORDERSIZE) (DIFFERENCE BOTTOM BORDERSIZE) (WIDTHIFWINDOW WIDTH BORDERSIZE) (HEIGHTIFWINDOW HEIGHT T BORDERSIZE))) (CONCAT "Viewing region of " REMOTE-USER "'s display") BORDERSIZE] (LIST 'RETURN (LIST (NSOCKETNUMBER NS) (USERNAME]) ) (FILESLOAD COURIERSERVE) (* ;;; "Sender end") (DEFINEQ (SEND-BITS [LAMBDA (PARTNER FRAME) (* ; "Edited 2-Apr-87 16:51 by Masinter") (* ;  "process that monitors the bits that are in the FRAME region and send them to RECADDR.") (OR CURSORICON (SETQ CURSORICON (ICONW REMOTE-CURSOR REMOTE-CURSOR '(0 . 0) T))) (RESETLST [CL:UNLESS FRAME (SETQ FRAME (MAKE-FRAME (GETREGION))) (RESETSAVE NIL `(CLOSE-FRAME ,FRAME] (LET* ((SENDSOCKET (OPENNSOCKET)) [PARTNERADDRESS (COND ((TYPENAMEP PARTNER 'NSADDRESS) PARTNER) (T (LOOKUP.NS.SERVER PARTNER] (PARTNERHOST (fetch NSHOSTNUMBER PARTNERADDRESS)) (PARTNERNET (fetch NSNET PARTNERADDRESS)) (PARTNERCALL (COURIER.OPEN PARTNERADDRESS)) (PACKET NIL) (VIEWER-RETURNED-VALUE (COURIER.CALL PARTNERCALL 'COMMWINDOW 'START-GET-BITS (WINDOWPROP (CAR FRAME) 'FRAME-REGION) (USERNAME))) (PARTNERSOCKET (CAR VIEWER-RETURNED-VALUE)) (PARTNERUSERNAME (CADR VIEWER-RETURNED-VALUE)) (BBT (create PILOTBBT))) (RESETSAVE NIL (LIST 'CLOSENSOCKET SENDSOCKET)) (CLOSEF PARTNERCALL) (* ;  "close SPP connection, needs no more RPC") (DISCARDXIPS SENDSOCKET) (RESETSAVE NIL (LIST 'SHUT-DOWN-VIEWER SENDSOCKET PARTNERHOST PARTNERNET PARTNERSOCKET)) (SET-FRAME-TITLE FRAME (CONCAT "Displaying region on " PARTNERUSERNAME "'s display") ) (while T do (DESTRUCTURING-BIND (L B W H) (WINDOWPROP (CAR FRAME) 'FRAME-REGION) (MAPC FRAME (FUNCTION TOTOPW)) (MAPTILES MAX-PACKET-BITS W H L B (FUNCTION (LAMBDA (X Y THIS-WIDTH THIS-HEIGHT SPREAD) (LISTEN-TO-VIEWER SENDSOCKET L B) (SEND-TILE X Y L B THIS-WIDTH THIS-HEIGHT SPREAD SENDSOCKET PARTNERHOST PARTNERNET PARTNERSOCKET PACKET]) (SEND-TILE (LAMBDA (X Y FRAME-LEFT FRAME-BOTTOM THIS-WIDTH THIS-HEIGHT SPREAD SENDSOCKET PARTNERHOST PARTNERNET PARTNERSOCKET PACKET) (* ; "Edited 24-Nov-86 14:45 by smL") (* ;;; "Send a tile to the receiver") (SETQ PACKET (\FILLINXIP \XIPT.EXCHANGE SENDSOCKET PARTNERHOST PARTNERSOCKET PARTNERNET)) (replace EPREQUEUE of PACKET with 'FREE) (XIPAPPEND.WORD PACKET (OR SPREAD (SETQ SPREAD 0))) (XIPAPPEND.WORD PACKET COMM.BAND.PACKET.TYPE) (* ;;  "Reserve space for the cursor pos, to be filled in later on") (XIPAPPEND.WORD PACKET 0) (XIPAPPEND.WORD PACKET 0) (XIPAPPEND.WORD PACKET X) (XIPAPPEND.WORD PACKET Y) (XIPAPPEND.WORD PACKET THIS-WIDTH) (XIPAPPEND.WORD PACKET THIS-HEIGHT) (BMTOPACKET NIL (SCREENBITMAP) (+ FRAME-LEFT X) (+ FRAME-BOTTOM Y) THIS-WIDTH THIS-HEIGHT (fetch (COMM.XFER.PACKET BITS) of PACKET) SPREAD) (add (fetch XIPLENGTH PACKET) (IQUOTIENT (+ 7 (TIMES THIS-WIDTH THIS-HEIGHT)) 8)) (CL:ASSERT (with COMM.XFER.PACKET PACKET (AND (EQ DATAX X) (EQ DATAY Y) (EQ THISWIDTH THIS-WIDTH) (EQ THISHEIGHT THIS-HEIGHT)))) (if (OR COMM.SEND.UNCHANGED.TILES (NOT (PACKET-EQUAL PACKET (GET-CACHED-PACKET X Y PARTNERHOST PARTNERNET PARTNERSOCKET)))) then (PUT-CACHED-PACKET PACKET X Y PARTNERHOST PARTNERNET PARTNERSOCKET) else (* ;;  "There has been no change in the bits, so don't bother to send them") (replace (XIP XIPLENGTH) of PACKET with (CONSTANT (PLUS \XIPOVLEN (TIMES 2 (INDEXF (FETCH ( COMM.XFER.PACKET DATALOC) OF T))))))) (* ;;  "Set in the cursor pos and send the packet") (replace (COMM.XFER.PACKET CURSORX) of PACKET with (LOGAND (- LASTMOUSEX FRAME-LEFT) 65535)) (replace (COMM.XFER.PACKET CURSORY) of PACKET with (LOGAND (- LASTMOUSEY FRAME-BOTTOM) 65535)) (SENDXIP SENDSOCKET PACKET) (BLOCK))) (LISTEN-TO-VIEWER (LAMBDA (SENDSOCKET FRAME-LEFT FRAME-BOTTOM) (* ; "Edited 24-Nov-86 13:13 by smL") (* ;;  "Update the display of the viewers cursor") (bind CURSORPACKET while (SETQ CURSORPACKET (GETXIP SENDSOCKET 0)) do (* ; "got an ack") (SELECTC (fetch (COMM.XFER.PACKET PACKET-TYPE) CURSORPACKET) (COMM.CURSOR.PACKET.TYPE (MOVEW CURSORICON (+ (fetch (COMM.XFER.PACKET CURSORX) CURSORPACKET) FRAME-LEFT) (+ (fetch (COMM.XFER.PACKET CURSORY) CURSORPACKET) FRAME-BOTTOM)) (OPENW CURSORICON)) (COMM.CURSOR.CLOSE.PACKET.TYPE (* ;;  "Stop shadowing the viewers cursor") (if (OPENWP CURSORICON) then (CLOSEW CURSORICON))) NIL)))) (MAPTILES (LAMBDA (MAXBITS W H L B FN) (* ; "Edited 24-Nov-86 17:42 by smL") (LET* ((SQRT-BITS (CL:ISQRT MAXBITS)) (PACKETHEIGHT NIL) (PACKETWIDTH NIL) (XMARGIN (IQUOTIENT SQRT-BITS 2)) (YMARGIN (IQUOTIENT SQRT-BITS 2)) (XD 1) (YD 1) (SPREAD NIL) (MX LASTMOUSEX) (MY LASTMOUSEY) (VIEWER-X -100) (VIEWER-Y -100)) (CL:ECASE COMM.DEFAULT.TRANSMIT.TYPE (SQUARE (SETQ PACKETHEIGHT SQRT-BITS)) (RECTANGLE (SETQ PACKETWIDTH (CL:* 2 SQRT-BITS))) (HORIZONTAL (SETQ PACKETWIDTH (MIN W MAXBITS))) (VERTICAL (SETQ PACKETHEIGHT (MIN H MAXBITS))) (H3 (SETQ PACKETWIDTH (MIN W MAXBITS)) (SETQ YD 8))) (OR PACKETWIDTH (SETQ PACKETWIDTH (IQUOTIENT MAXBITS PACKETHEIGHT))) (OR PACKETHEIGHT (SETQ PACKETHEIGHT (IQUOTIENT MAXBITS PACKETWIDTH))) (INCR Y (- H PACKETHEIGHT) (- PACKETHEIGHT) YD (< Y (- PACKETHEIGHT)) (INCR X 0 PACKETWIDTH XD (>= X W) (SELECTQ COMM.UPDATE.MOUSE.POSITION (NIL (* ;; "Don't do anything special") NIL) (Sender (* ;;  "Update around the sender's cursor (this machine is the sender) if the mouse has moved") (if (OR (NEQ LASTMOUSEX MX) (NEQ LASTMOUSEY MY)) then (SETQ MX LASTMOUSEX) (SETQ MY LASTMOUSEY) (LET ((X (- MX XMARGIN L)) (Y (- MY YMARGIN B))) (* ;;  "X and Y are now in block coordinates ") (CL:IF (AND (<= 0 X (- W 1)) (<= 0 Y (- H 1))) (CL:FUNCALL FN X Y (MIN (+ XMARGIN XMARGIN) (- W X)) (MIN (+ YMARGIN YMARGIN) (- H Y))))))) (Viewer (* ;; "Update around the viewer's cursor (the other machine is the viewer) if the cursor is in the frame (and hence open frame)") (LET ((VIEWERS-REGION (WINDOWPROP CURSORICON 'REGION))) (if (AND (OPENWP CURSORICON) (OR (NEQ (fetch LEFT of VIEWERS-REGION) VIEWER-X) (NEQ (fetch BOTTOM of VIEWERS-REGION) VIEWER-Y))) then (SETQ VIEWER-X (fetch LEFT of VIEWERS-REGION)) (SETQ VIEWER-Y (fetch BOTTOM of VIEWERS-REGION)) (LET ((X (- VIEWER-X XMARGIN L)) (Y (- VIEWER-Y YMARGIN B))) (* ;;  "X and Y are now in block coordinates ") (CL:IF (AND (<= 0 X (- W 1)) (<= 0 Y (- H 1))) (CL:FUNCALL FN X Y (MIN (+ XMARGIN XMARGIN) (- W X)) (MIN (+ YMARGIN YMARGIN) (- H Y)))))))) NIL) (CL:FUNCALL FN (MAX X 0) (MAX Y 0) (MIN PACKETWIDTH (- W X)) (MIN PACKETHEIGHT (- H Y)))))))) (SHUT-DOWN-VIEWER (LAMBDA (SENDSOCKET PARTNERHOST PARTNERNET PARTNERSOCKET) (* ; "Edited 24-Nov-86 11:40 by smL") (* ;;;  "Send a shut-down packet to the receiver") (* ;;  "Beware, this may fail on a noisey line, so we do it twice, just to be safer.") (to 2 do (LET ((PACKET (\FILLINXIP \XIPT.EXCHANGE SENDSOCKET PARTNERHOST PARTNERSOCKET PARTNERNET ))) (replace EPREQUEUE of PACKET with 'FREE) (XIPAPPEND.WORD PACKET 0) (XIPAPPEND.WORD PACKET COMM.SHUT.DOWN.PACKET.TYPE) (SENDXIP SENDSOCKET PACKET))))) (CHANGE-SENDER-UPDATE-MODE (LAMBDA (NEW-MODE) (* ; "Edited 24-Nov-86 12:49 by smL") (SETQ COMM.DEFAULT.TRANSMIT.TYPE NEW-MODE))) ) (DEFMACRO INCR (VAR START HEIGHT REPEATS UNTIL &REST FORMS) `(CL:DO ((REPEAT-COUNT 0 (+ REPEAT-COUNT 1))) ((>= REPEAT-COUNT ,REPEATS)) (CL:DO [(,VAR (+ ,START (CL:* REPEAT-COUNT ,HEIGHT)) (+ ,VAR (CL:* ,REPEATS ,HEIGHT] (,UNTIL) ,@FORMS))) (DEFMACRO \PILOTBITBLT (XCL-USER::TABLE &OPTIONAL (XCL-USER::N 0)) (CL:ASSERT (EQL XCL-USER::N 0)) `((OPCODES PILOTBITBLT) ,XCL-USER::TABLE 0)) (* ;; "Controling update schemes") (RPAQ? COMM.DEFAULT.TRANSMIT.TYPE 'SQUARE) (RPAQ? COMM.SEND.UNCHANGED.TILES T) (RPAQ? COMM.UPDATE.MOUSE.POSITION 'Sender) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMM.DEFAULT.TRANSMIT.TYPE COMM.UPDATE.MOUSE.POSITION COMM.SEND.UNCHANGED.TILES) ) (* ;;; "Pruning out unchanged screen tiles") (DEFINEQ (PACKET-EQUAL (LAMBDA (PACKET1 PACKET2) (* ; "Edited 24-Nov-86 14:36 by smL") (* ;;  "Are the data parts of two packets equal?") (AND (type? ETHERPACKET PACKET1) (type? ETHERPACKET PACKET2) (EQ (fetch (XIP XIPLENGTH) of PACKET1) (fetch (XIP XIPLENGTH) of PACKET2)) (LET ((DATA-BYTES (DIFFERENCE (fetch (XIP XIPLENGTH) of PACKET1) \XIPOVLEN))) (AND (for I from 0 to (LRSH DATA-BYTES 1) bind (DATA1 _ (fetch (COMM.XFER.PACKET BITS) of PACKET1)) (DATA2 _ (fetch (COMM.XFER.PACKET BITS) of PACKET2)) always (EQ (\GETBASE DATA1 I) (\GETBASE DATA2 I))) (OR (ZEROP (LOGAND 1 DATA-BYTES)) (EQ (\GETBASEBYTE PACKET1 (SUB1 (fetch (XIP XIPLENGTH) of PACKET1))) (\GETBASEBYTE PACKET2 (SUB1 (fetch (XIP XIPLENGTH) of PACKET1)))))))))) (GET-CACHED-PACKET (LAMBDA (X Y PARTNERHOST PARTNERNET PARTNERSOCKET) (* ; "Edited 24-Nov-86 14:41 by smL") (* ;; "Make sure the cursor pos in the packet is smashed to zero, and that the packet has actually been sent") NIL)) (PUT-CACHED-PACKET (LAMBDA (PACKET X Y PARTNERHOST PARTNERNET PARTNERSOCKET) (* ; "Edited 24-Nov-86 13:28 by smL") T)) ) (* ;;; "Low level packet exchange code") (DECLARE%: EVAL@COMPILE (RPAQQ COMM.BAND.PACKET.TYPE 1321) (RPAQQ COMM.CURSOR.PACKET.TYPE 2925) (RPAQQ COMM.CURSOR.CLOSE.PACKET.TYPE 2926) (RPAQQ COMM.SHUT.DOWN.PACKET.TYPE 4246) (CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE COMM.CURSOR.CLOSE.PACKET.TYPE COMM.SHUT.DOWN.PACKET.TYPE) ) (CL:DEFCONSTANT MAX-PACKET-BITS (CL:* 400 8) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS COMM.XFER.PACKET ((COMMPACKET (fetch (XIP XIPCONTENTS) of DATUM))) (BLOCKRECORD COMMPACKET ((SPREAD WORD) (PACKET-TYPE WORD) (CURSORX WORD) (CURSORY WORD) (DATAX WORD) (DATAY WORD) (THISWIDTH WORD) (THISHEIGHT WORD) (DATALOC 64 WORD))) [ACCESSFNS COMM.XFER.PACKET ((BITS (LOCF (FETCH (COMM.XFER.PACKET DATALOC ) OF DATUM]) ) (* ;;; "Packing and unpacking bitmaps into etherpackets") (DEFINEQ (BMTOPACKET (LAMBDA (BBT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT PACKETLOC SPREAD) (* ; "Edited 24-Nov-86 10:48 by smL") (* ;; "copy bitmap to packet") (CL:ASSERT (AND (BITMAPP SOURCEBITMAP) (<= 0 SOURCELEFT (- (BITMAPWIDTH SOURCEBITMAP) WIDTH 1)) (<= 0 SOURCEBOTTOM (- (BITMAPHEIGHT SOURCEBITMAP) HEIGHT 1)) (< 0 WIDTH) (< 0 HEIGHT))) (\PILOTBITBLT (create PILOTBBT smashing (OR BBT (create PILOTBBT)) PBTWIDTH _ WIDTH PBTHEIGHT _ HEIGHT PBTFLAGS _ 0 PBTDESTBPL _ WIDTH PBTDESTBIT _ 0 PBTUSEGRAY _ NIL PBTSOURCEBPL _ (CL:* (fetch (BITMAP BITMAPRASTERWIDTH ) of SOURCEBITMAP) 16 (+ SPREAD 1)) PBTSOURCEBIT _ SOURCELEFT PBTDISJOINT _ T PBTSOURCE _ (\ADDBASE (fetch (BITMAP BITMAPBASE) of SOURCEBITMAP) (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBITMAP) (- (fetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) HEIGHT SOURCEBOTTOM))) PBTDEST _ PACKETLOC PBTOPERATION _ 0 PBTSOURCETYPE _ 0) 0))) (PACKETTOBM (LAMBDA (BBT PACKETLOC WIDTH HEIGHT DESTBITMAP DESTLEFT DESTBOTTOM SPREAD) (* ; "Edited 24-Nov-86 10:48 by smL") (* ;;  "Do a bitblt from a packet into a bitmap. Inverts BMTOPACKET.") (CL:ASSERT (AND (BITMAPP DESTBITMAP) (<= 0 DESTLEFT (- (BITMAPWIDTH DESTBITMAP) WIDTH -1)) (<= 0 DESTBOTTOM (- (BITMAPHEIGHT DESTBITMAP) (CL:* HEIGHT (CL:1+ SPREAD)) -1)) (< 0 WIDTH) (< 0 HEIGHT))) (\PILOTBITBLT (create PILOTBBT smashing (OR BBT (create PILOTBBT)) PBTWIDTH _ WIDTH PBTHEIGHT _ HEIGHT PBTFLAGS _ 0 PBTDESTBPL _ (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of DESTBITMAP) 16 (CL:1+ SPREAD)) PBTDESTBIT _ DESTLEFT PBTUSEGRAY _ NIL PBTSOURCEBPL _ WIDTH PBTSOURCEBIT _ 0 PBTDISJOINT _ T PBTSOURCE _ PACKETLOC PBTDEST _ (\ADDBASE (fetch (BITMAP BITMAPBASE) of DESTBITMAP) (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of DESTBITMAP) (- (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP) HEIGHT DESTBOTTOM))) PBTOPERATION _ 0 PBTSOURCETYPE _ 0) 0))) ) (* ;;; "Displaying the viewing machine's cursor") (RPAQQ REMOTE-CURSOR #*(16 16)@C@@@C@@@F@@@F@@@LGN@LDAIHDAMHDAO@DAONGNOLDDOHDDO@DBN@DBL@DAH@DA) (RPAQ? CURSORICON NIL) (* ;;; "Manipulating the frame that outlines the region being viewed") (RPAQ? *FRAME-SHADE* GRAYSHADE) (DEFINEQ (FRAME-EVENT [LAMBDA (WINDOW) (* ; "Edited 2-Apr-87 16:53 by Masinter") (if (KEYDOWNP 'RIGHT) then (CLOSE-FRAME (WINDOWPROP WINDOW 'FRAME)) else (LET [(FRAME (WINDOWPROP WINDOW 'FRAME] (if (SHIFTDOWNP 'SHIFT) then [SHAPE-FRAME FRAME (LET [(REGION (WINDOWPROP WINDOW 'FRAME-REGION] (with REGION REGION (\SETCURSORPOSITION LEFT BOTTOM) (GETREGION 32 32 REGION NIL NIL] else (MOVE-FRAME WINDOW]) (MAKE-FRAME [LAMBDA (REGION VIEWER-NAME) (* ; "Edited 2-Apr-87 16:46 by Masinter") (LET (FRAME) [with REGION REGION (SETQ FRAME (LIST (CREATEW (LIST (- LEFT 8) (- BOTTOM 8) 8 (+ HEIGHT 8 8)) NIL 0) (CREATEW (LIST LEFT (- BOTTOM 8) (+ WIDTH 8) 8) NIL 0) (CREATEW (LIST (+ LEFT WIDTH) BOTTOM 8 (+ HEIGHT 8)) NIL 0) (CREATEW (LIST LEFT (+ BOTTOM HEIGHT) WIDTH (HEIGHTIFWINDOW 8 T 0)) "Viewed region" 0] (for X in FRAME do (DSPTEXTURE *FRAME-SHADE* X) (DSPRESET X) (WINDOWPROP X 'FRAME-REGION REGION) (WINDOWPROP X 'MINSIZE '(8 . 8)) (WINDOWPROP X 'FRAME FRAME) (WINDOWPROP X 'RIGHTBUTTONFN (FUNCTION FRAME-EVENT)) (WINDOWPROP X 'BUTTONEVENTFN (FUNCTION FRAME-EVENT))) FRAME]) (MOVE-FRAME (LAMBDA (W) (* lmm "17-Nov-86 02:11") (with REGION (WINDOWPROP W 'FRAME-REGION) (SHAPE-FRAME (WINDOWPROP W 'FRAME) (GETBOXREGION WIDTH HEIGHT LEFT BOTTOM))))) (SHAPE-FRAME (LAMBDA (FRAME REGION) (* ; "Edited 24-Nov-86 13:23 by smL") (with REGION REGION (PROGN (SHAPEW (CAR FRAME) (LIST (- LEFT 8) (- BOTTOM 8) 8 (+ HEIGHT 8 8))) (SHAPEW (CADR FRAME) (LIST LEFT (- BOTTOM 8) (+ WIDTH 8) 8)) (SHAPEW (CADDR FRAME) (LIST (+ LEFT WIDTH) BOTTOM 8 (+ HEIGHT 8))) (SHAPEW (CADDDR FRAME) (LIST LEFT (+ BOTTOM HEIGHT) WIDTH (HEIGHTIFWINDOW 8 (WINDOWPROP (CADDDR FRAME) 'TITLE) (WINDOWPROP (CADDDR FRAME) 'BORDER)))))) (for X in FRAME do (CLEARW X) (WINDOWPROP X 'FRAME-REGION REGION)))) (SET-FRAME-TITLE (LAMBDA (FRAME TITLE) (* ; "Edited 24-Nov-86 13:07 by smL") (WINDOWPROP (CAR (LAST FRAME)) 'TITLE TITLE))) ) (* ;;; "Changing the system parameters") (DEFINEQ (MAKE-MENUS-WINDOW (LAMBDA (MENUS TITLE POSITION) (* ; "Edited 24-Nov-86 10:40 by smL") (* ;;  "Make sure all the menu fields are filled in and up to date") (for MENU in MENUS do (UPDATE/MENU/IMAGE MENU)) (* ;;  "Create a window big enough to hold all the menus, and put the menus in it") (LET* ((MENU-GAP 5) (INSIDE-WINDOW-WIDTH (PLUS MENU-GAP (for MENU in MENUS sum (PLUS MENU-GAP (fetch (MENU IMAGEWIDTH) of MENU))))) (INSIDE-WINDOW-HEIGHT (PLUS MENU-GAP MENU-GAP (for MENU in MENUS largest (fetch (MENU IMAGEHEIGHT) of MENU) finally (RETURN $$EXTREME)))) (CONTROL-WINDOW (CREATEW (if POSITION then (CREATEPOSITION (fetch XCOORD of POSITION) (fetch YCOORD of POSITION)) else (GETBOXREGION (WIDTHIFWINDOW INSIDE-WINDOW-WIDTH) (HEIGHTIFWINDOW INSIDE-WINDOW-HEIGHT TITLE) NIL NIL NIL "Position the Mode Menu")) TITLE))) (for MENU in MENUS bind (LEFT _ MENU-GAP) do (ADDMENU MENU CONTROL-WINDOW (CREATEPOSITION LEFT (QUOTIENT (DIFFERENCE INSIDE-WINDOW-HEIGHT (fetch (MENU IMAGEHEIGHT) of MENU)) 2))) (add LEFT (fetch (MENU IMAGEWIDTH) of MENU) MENU-GAP)) CONTROL-WINDOW))) (MODE-MENU (LAMBDA NIL (* ; "Edited 24-Nov-86 16:52 by smL") (LET ((UPDATE-MENU (create MENU CENTERFLG _ T MENUTITLEFONT _ BOLDFONT WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU BUTTON) (MENUDESELECT COMM.DEFAULT.TRANSMIT.TYPE MENU) (MENUSELECT ITEM MENU) (CHANGE-SENDER-UPDATE-MODE ITEM))) TITLE _ "Update method" ITEMS _ COMM-MODES)) (MOUSE-POS-UPDATE-MENU (create MENU CENTERFLG _ T MENUTITLEFONT _ BOLDFONT WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU BUTTON) (MENUDESELECT COMM.UPDATE.MOUSE.POSITION MENU) (MENUSELECT ITEM MENU) (SETQ COMM.UPDATE.MOUSE.POSITION ITEM))) TITLE _ "Update near cursor?" ITEMS _ '(Sender Viewer NIL))) (SEND-UNCHANGED-TILES-MENU (create MENU CENTERFLG _ T MENUTITLEFONT _ BOLDFONT WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU BUTTON) (MENUDESELECT COMM.SEND.UNCHANGED.TILES MENU) (MENUSELECT ITEM MENU) (SETQ COMM.SEND.UNCHANGED.TILES ITEM))) TITLE _ "Send unchanged tiles?" ITEMS _ '(T NIL))) (LIGHTNING-MENU (create MENU CENTERFLG _ T MENUTITLEFONT _ BOLDFONT WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU BUTTON) (MENUDESELECT \ETHERLIGHTNING MENU) (MENUSELECT ITEM MENU) (SETQ \ETHERLIGHTNING ITEM))) TITLE _ "Ether Lightning" ITEMS _ '(NIL 3 6 1 4 7 2 5 8) MENUROWS _ 3))) (* ;; "") (* ;;  "Bring up a window with all the menus, at a location the user specifies") (* ;; "") (MAKE-MENUS-WINDOW (LIST UPDATE-MENU MOUSE-POS-UPDATE-MENU SEND-UNCHANGED-TILES-MENU LIGHTNING-MENU) "Send-Bits mode menu") (* ;; "") (* ;;  "Highlight the current values, so the user can see what the current values are.") (* ;; "") (MENUSELECT COMM.DEFAULT.TRANSMIT.TYPE UPDATE-MENU) (MENUSELECT COMM.UPDATE.MOUSE.POSITION MOUSE-POS-UPDATE-MENU) (MENUSELECT COMM.SEND.UNCHANGED.TILES SEND-UNCHANGED-TILES-MENU) (MENUSELECT \ETHERLIGHTNING LIGHTNING-MENU)))) ) (RPAQQ COMM-MODES (SQUARE RECTANGLE HORIZONTAL VERTICAL H3)) (* ;;; "Initialization") (COURIER.START.SERVER) (* ;;; "Unused stuff, as far as I can tell") (DEFINEQ (FASTBITBLT (LAMBDA (BBT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM WIDTH HEIGHT DESTBITMAP DESTLEFT DESTBOTTOM) (* lmm "17-Nov-86 03:55") (* ;; "copy bitmap to bitmap") (CL:ASSERT (AND (BITMAPP SOURCEBITMAP) (BITMAPP DESTBITMAP) (<= 0 SOURCELEFT (- (BITMAPWIDTH SOURCEBITMAP) WIDTH 1)) (<= 0 SOURCEBOTTOM (- (BITMAPHEIGHT SOURCEBITMAP) HEIGHT 1)) (<= 0 DESTLEFT (- (BITMAPWIDTH DESTBITMAP) WIDTH 1)) (<= 0 DESTBOTTOM (- (BITMAPHEIGHT DESTBITMAP) HEIGHT 1)) (< 0 WIDTH) (< 0 HEIGHT))) (\PILOTBITBLT (create PILOTBBT smashing (OR BBT (create PILOTBBT)) PBTWIDTH _ WIDTH PBTHEIGHT _ HEIGHT PBTFLAGS _ 0 PBTDESTBPL _ (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of DESTBITMAP) 16) PBTDESTBIT _ DESTLEFT PBTUSEGRAY _ NIL PBTSOURCEBPL _ (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBITMAP) 16) PBTSOURCEBIT _ SOURCELEFT PBTDISJOINT _ T PBTSOURCE _ (\ADDBASE (fetch (BITMAP BITMAPBASE) of SOURCEBITMAP) (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBITMAP ) (- (fetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP ) HEIGHT SOURCEBOTTOM))) PBTDEST _ (\ADDBASE (fetch (BITMAP BITMAPBASE) of DESTBITMAP ) (CL:* (fetch (BITMAP BITMAPRASTERWIDTH) of DESTBITMAP) (- (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP) HEIGHT DESTBOTTOM))) PBTOPERATION _ 0 PBTSOURCETYPE _ 0) 0))) ) (* ;;; "System file dependencies") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILESLOAD (LOADCOMP) LLDISPLAY LLETHER LLNS) ) (COURIERPROGRAM COMMWINDOW (1337 1) TYPES [(REGION (RECORD (LEFT INTEGER) (BOTTOM INTEGER) (WIDTH INTEGER) (HEIGHT INTEGER))) (USERNAME STRING) (RESPONSE (RECORD (SOCKET LONGINTEGER) (CORRESPONDENT USERNAME] PROCEDURES ((START-GET-BITS 1 (REGION USERNAME) RETURNS (RESPONSE) REPORTS (REMOTEERROR) IMPLEMENTEDBY START-GET-BITS)) ERRORS ((ERROR 1 (STRING)) (USE.COURIER 2 NIL))) (PUTPROPS COMMWINDOW COPYRIGHT ("Xerox Corporation" 1986 1900 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3203 13134 (CLOSE-FRAME 3213 . 3364) (GET-BITS 3366 . 11655) (START-GET-BITS 11657 . 13132)) (13189 26236 (SEND-BITS 13199 . 16020) (SEND-TILE 16022 . 19145) (LISTEN-TO-VIEWER 19147 . 20450) (MAPTILES 20452 . 25175) (SHUT-DOWN-VIEWER 25177 . 26046) (CHANGE-SENDER-UPDATE-MODE 26048 . 26234)) (27219 29090 (PACKET-EQUAL 27229 . 28632) (GET-CACHED-PACKET 28634 . 28949) (PUT-CACHED-PACKET 28951 . 29088)) (30529 34252 (BMTOPACKET 30539 . 32500) (PACKETTOBM 32502 . 34250)) (34556 38865 ( FRAME-EVENT 34566 . 35224) (MAKE-FRAME 35226 . 37008) (MOVE-FRAME 37010 . 37280) (SHAPE-FRAME 37282 . 38672) (SET-FRAME-TITLE 38674 . 38863)) (38915 45792 (MAKE-MENUS-WINDOW 38925 . 41284) (MODE-MENU 41286 . 45790)) (45968 48955 (FASTBITBLT 45978 . 48953))))) STOP \ No newline at end of file diff --git a/lispusers/COMMWINDOW.TEDIT b/lispusers/COMMWINDOW.TEDIT new file mode 100644 index 00000000..d8de3997 Binary files /dev/null and b/lispusers/COMMWINDOW.TEDIT differ diff --git a/lispusers/COMPARE-PATHS b/lispusers/COMPARE-PATHS new file mode 100644 index 00000000..8a39d698 --- /dev/null +++ b/lispusers/COMPARE-PATHS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "22-Sep-87 15:19:06" {ERINYES}LYRIC>COMPARE-PATHS.\;3 4836 |changes| |to:| (FUNCTIONS XCL-USER::COMPARE-PATHS XCL-USER::COMPARE-FLOPPY) (VARS COMPARE-PATHSCOMS) |previous| |date:| "22-Sep-87 12:03:37" {ERINYES}LYRIC>COMPARE-PATHS.\;1) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT COMPARE-PATHSCOMS) (RPAQQ COMPARE-PATHSCOMS ((FUNCTIONS XCL-USER::COMPARE-FLOPPY XCL-USER::COMPARE-PATHS))) (CL:DEFUN XCL-USER::COMPARE-FLOPPY (XCL-USER::FLOPPYPATH XCL-USER::FSPATH) (* |;;;| "This resoundingly dumb function walks IL:COMPARESOURCES down the files of two directories.") (LET* ((XCL-USER::FLOPPYFILES (DIRECTORY XCL-USER::FLOPPYPATH)) (XCL-USER::FSFILES (DIRECTORY XCL-USER::FSPATH))) (WHILE (AND XCL-USER::FLOPPYFILES XCL-USER::FSFILES) BIND XCL-USER::FLOPPYNAME XCL-USER::FSNAME DO (CL:SETQ XCL-USER::FLOPPYNAME (CL:PATHNAME-NAME (PATHNAME (CAR XCL-USER::FLOPPYFILES)))) (CL:SETQ XCL-USER::FSNAME (CL:PATHNAME-NAME (PATHNAME (CAR XCL-USER::FSFILES)))) (COND ((CL:STRING= XCL-USER::FLOPPYNAME XCL-USER::FSNAME) (LET ((XCL-USER::FLOPPYDATE (GETFILEINFO (CAR XCL-USER::FLOPPYFILES) 'CREATIONDATE)) (XCL-USER::FSDATE (GETFILEINFO (CAR XCL-USER::FSFILES) 'CREATIONDATE))) (IF (NOT (CL:STRING= XCL-USER::FLOPPYDATE XCL-USER::FSDATE)) THEN (CL:FORMAT T "Creation dates for ~s don't match:~%~S: ~S ~S: ~S ~2%" XCL-USER::FLOPPYNAME (CAR XCL-USER::FLOPPYFILES) XCL-USER::FLOPPYDATE (CAR XCL-USER::FSFILES) XCL-USER::FSDATE) ELSE (COMPARESOURCES (CAR XCL-USER::FLOPPYFILES) (CAR XCL-USER::FSFILES)) (CL:FORMAT T "~%"))) (CL:POP XCL-USER::FLOPPYFILES) (CL:POP XCL-USER::FSFILES)) ((CL:STRING< XCL-USER::FLOPPYNAME XCL-USER::FSNAME) (CL:FORMAT T "File ~S not found on ~S~%" (CAR XCL-USER::FLOPPYFILES) XCL-USER::FSPATH) (CL:POP XCL-USER::FLOPPYFILES)) (T (CL:POP XCL-USER::FSFILES)))) (WHILE XCL-USER::FLOPPYFILES DO (CL:FORMAT T "File ~S not found on ~S~%" (CAR XCL-USER::FLOPPYFILES ) XCL-USER::FSPATH) (CL:POP XCL-USER::FLOPPYFILES)))) (CL:DEFUN XCL-USER::COMPARE-PATHS (XCL-USER::PATH1 XCL-USER::PATH2) (* |;;;| "This resoundingly dumb function walks IL:COMPARESOURCES down the files of two directories.") (LET* ((XCL-USER::PL1 (DIRECTORY XCL-USER::PATH1)) (XCL-USER::PL2 (DIRECTORY XCL-USER::PATH2))) (WHILE (AND XCL-USER::PL1 XCL-USER::PL2) BIND XCL-USER::PN1 XCL-USER::PN2 DO (CL:SETQ XCL-USER::PN1 (CL:PATHNAME-NAME (PATHNAME (CAR XCL-USER::PL1)))) (CL:SETQ XCL-USER::PN2 (CL:PATHNAME-NAME (PATHNAME (CAR XCL-USER::PL2)))) (COND ((CL:STRING= XCL-USER::PN1 XCL-USER::PN2) (COMPARESOURCES (CAR XCL-USER::PL1) (CAR XCL-USER::PL2)) (CL:FORMAT T "~%") (CL:POP XCL-USER::PL1) (CL:POP XCL-USER::PL2)) ((CL:STRING< XCL-USER::PN1 XCL-USER::PN2) (CL:FORMAT T "File ~S not found on ~S~%" (CAR XCL-USER::PL1) XCL-USER::PATH2) (CL:POP XCL-USER::PL1)) (T (CL:FORMAT T "File ~S not found on ~S~%" (CAR XCL-USER::PL2) XCL-USER::PATH1) (CL:POP XCL-USER::PL2)))) (WHILE XCL-USER::PL1 DO (CL:FORMAT T "File ~S not found on ~S~%" (CAR XCL-USER::PL1) XCL-USER::PATH2) (CL:POP XCL-USER::PL1)) (WHILE XCL-USER::PL2 DO (CL:FORMAT T "File ~S not found on ~S~%" (CAR XCL-USER::PL2) XCL-USER::PATH1) (CL:POP XCL-USER::PL2)))) (PUTPROPS COMPARE-PATHS COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES b/lispusers/COMPAREDIRECTORIES new file mode 100644 index 00000000..fcfeb89c --- /dev/null +++ b/lispusers/COMPAREDIRECTORIES @@ -0,0 +1,145 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-May-2018 16:32:02"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;43 26134 changes to%: (FNS FIND-UNCOMPILED-FILES COMPAREDIRECTORIES) previous date%: " 9-May-2018 16:25:36" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;42) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents to two directories.") (FNS COMPAREDIRECTORIES COMPAREDIRS.FORMATLINE COMPAREDIRECTORIES.NEWPAGEFN COMPARE-DIRECTORIES) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES))) (* ;; "Compare the contents to two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (FROMDIR TODIR SHOW FILEPATTERN EXTENSIONSTOAVOID USEDIRECTORYDATE LISTINGFILE ALLVERSIONS) (* ; "Edited 9-May-2018 16:25 by rmk:") (* ; "Edited 9-May-2018 16:24 by rmk:") (* ; "Edited 4-May-2018 23:28 by rmk:") (* ; "Edited 4-May-2018 23:26 by rmk:") (* ; "Edited 4-May-2018 16:20 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW is or contains SAME, BEFORE, AFTER, then files where the FROM is the same as, earlier than, or later than the TO are shown. SHOW NIL is the same as (BEFORE AFTER), T is the same as (BEFORE AFTER SAME).") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is respect to the the LISP filedate if evailable.") (* ;; "") (* ;; "If LISTINGFILE is NIL, output goes to the display. If a filename ending in TXT or TEXT, then output goes to a text file. Otherwise, output goes to an image stream.") (* ;; "Looks only at latest version unless ALLVERSIONS") (CL:UNLESS FILEPATTERN (SETQ FILEPATTERN '*.*;)) (SETQ EXTENSIONSTOAVOID (MKLIST EXTENSIONSTOAVOID)) (CL:UNLESS ALLVERSIONS (SETQ FILEPATTERN (PACKFILENAME.STRING 'VERSION "" 'BODY FILEPATTERN))) (SETQ FROMDIR (DIRECTORYNAME FROMDIR)) (* ; "Resolve relative directories, so we can suppress subdirectory matches. Don't know why DIRECTORY produces them ") (SETQ TODIR (DIRECTORYNAME TODIR)) (PROG (TEXT LISTINGSTREAM (TONAMEPOS (ADD1 (NCHARS TODIR))) (FROMNAMEPOS (ADD1 (NCHARS FROMDIR))) (FROMPATTERN (PACKFILENAME.STRING 'DIRECTORY FROMDIR 'BODY FILEPATTERN)) (TOPATTERN (PACKFILENAME.STRING 'DIRECTORY TODIR 'BODY FILEPATTERN)) FROM-FILES TO-FILES) [SETQ LISTINGSTREAM (AND LISTINGFILE (IF (EQMEMB (U-CASE (FILENAMEFIELD LISTINGFILE 'EXTENSION)) '(TXT TEXT)) THEN (SETQ TEXT T) (OPENSTREAM LISTINGFILE 'OUTPUT) ELSE (OPENIMAGESTREAM LISTINGFILE NIL '(LANDSCAPE T] (* ;; "Pack may have put on a < or / incorrectly for relative directories") (* ;; "(CL:UNLESS (MEMB (NTHCHAR FROMDIR 1) '(/ \ <)) (SETQ FROMPATTERN (SUBSTRING FROMPATTERN 2 -1)))(CL:UNLESS (MEMB (NTHCHAR TODIR 1) '(/ \ <)) (SETQ TOPATTERN (SUBSTRING TOPATTERN 2 -1)))") (* ;; "Filter extensions") (CL:WHEN (MEMB '* EXTENSIONSTOAVOID) (SETQ FROMPATTERN (PACKFILENAME.STRING 'EXTENSION "" 'BODY FROMPATTERN)) (SETQ TOPATTERN (PACKFILENAME.STRING 'EXTENSION "" 'BODY TOPATTERN))) (* ;; "> test to skip subdirectories") (SETQ FROM-FILES (for FROMFILE in (DIRECTORY FROMPATTERN) UNLESS (IF (STRPOS ">" FROMFILE FROMNAMEPOS) ELSEIF (MEMB '* EXTENSIONSTOAVOID) THEN (* ;;  "For some unknown reason, DIRECTORY let's some through") (FILENAMEFIELD FROMFILE 'EXTENSION) ELSE (CL:MEMBER (UNPACKFILENAME.STRING FROMFILE 'EXTENSION) EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) collect FROMFILE)) (SETQ TO-FILES (for TOFILE in (DIRECTORY TOPATTERN) UNLESS (IF (STRPOS ">" TOFILE TONAMEPOS) ELSEIF (MEMB '* EXTENSIONSTOAVOID) THEN (FILENAMEFIELD TOFILE 'EXTENSION) ELSE (CL:MEMBER (UNPACKFILENAME.STRING TOFILE 'EXTENSION) EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) collect TOFILE)) (CL:UNLESS (AND TO-FILES FROM-FILES) (CL:UNLESS FROM-FILES (PRINTOUT T "FROMDIR " FROMDIR " is empty" T)) (CL:UNLESS TO-FILES (PRINTOUT T "TODIR " TODIR " is empty" T)) (RETURN)) (PRINTOUT T "Comparing " FROMDIR 6 "vs. " TODIR T "as of " (DATE) T) [COND (LISTINGSTREAM (IF TEXT THEN (LINELENGTH 1000 LISTINGSTREAM) (* ; "Don't wrap") (PRINTOUT LISTINGSTREAM "Comparing " FROMDIR 6 "vs. " TODIR T "as of " (DATE) T T) ELSE (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR) (CONCAT "as of " (DATE] (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM] (FOR FROMNAME IN FROM-FILES BIND TONAME DT1 DT2 FROMMATCH SHORT-FROM SHORT-TO EACHTIME (SETQ SHORT-FROM (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FROMNAME)) (SETQ FROMMATCH (PACKFILENAME.STRING 'VERSION NIL 'BODY SHORT-FROM)) [SETQ DT1 (IF USEDIRECTORYDATE THEN [IDATE (OR (FILEDATE FROMNAME) (GETFILEINFO FROMNAME 'CREATIONDATE] ELSE (GETFILEINFO FROMNAME 'ICREATIONDATE] DO (FOR TONAME IN TO-FILES WHEN (STREQUAL FROMMATCH (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL 'BODY TONAME)) DO (SETQ TO-FILES (CL:DELETE TONAME TO-FILES)) [SETQ DT2 (IF USEDIRECTORYDATE THEN (GETFILEINFO TONAME 'ICREATIONDATE) ELSE (IDATE (OR (FILEDATE TONAME) (GETFILEINFO TONAME 'CREATIONDATE] (SETQ SHORT-TO (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY TONAME)) (COND [(IEQP DT1 DT2) (* ; "same") (COND ((EQMEMB SHOW '(T SAME)) (EQ SHOW FILESTOO) (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM "" (GDATE DT1) " =" (GDATE DT2) SHORT-TO "" TEXT] ([OR [AND (ILESSP DT1 DT2) (EQMEMB SHOW '(NIL BEFORE] (AND (IGREATERP DT1 DT2) (EQMEMB SHOW '(NIL AFTER] (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO FROMNAME 'AUTHOR) (GDATE DT1) (COND ((LESSP DT1 DT2) "< ") (T " >")) (GDATE DT2) SHORT-TO (GETFILEINFO TONAME 'AUTHOR) TEXT))) (RETURN) FINALLY (* ;; "No match for a FROMFILE") (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO FROMNAME 'AUTHOR) (GDATE DT1) "**" NIL NIL NIL TEXT))) (* ;; "The TO-FILES that didn't match a FROM-FILE. GDATE to expand 19xx to 4 digits (Y2K)") (FOR TONAME SHORT-TO IN TO-FILES DO (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL 'BODY TONAME)) (COMPAREDIRS.FORMATLINE LISTINGSTREAM NIL NIL NIL "**" [GDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO TONAME 'ICREATIONDATE) ELSE (IDATE (OR (FILEDATE TONAME) (GETFILEINFO TONAME 'CREATIONDATE] SHORT-TO (GETFILEINFO TONAME 'AUTHOR) TEXT)) (RETURN (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) (COMPAREDIRS.FORMATLINE [LAMBDA (STREAM FROM FROMAUTHOR FDATE COMP TDATE TO TOAUTHOR TEXT) (* ; "Edited 2-May-2018 16:49 by rmk:") (* ;; "Format one line of the directory comparison listing. If FROMAUTHOR or TOAUTHOR are non-NIL, list the author in parens; otherwise omit it.") (COND ((AND STREAM (NOT TEXT)) (* ;  "It's an image stream, where TAB doesn't work right.") (LET* [(COMPFONT (FONTCREATE 'MODERN 8 'BOLD NIL STREAM)) (MAINFONT (FONTCREATE 'MODERN 8 NIL NIL STREAM)) (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM)) (LEFTMARGIN (DSPLEFTMARGIN NIL STREAM)) (RIGHTMARGIN (DSPRIGHTMARGIN NIL STREAM)) (CENTER (IQUOTIENT (+ LEFTMARGIN RIGHTMARGIN) 2)) (COMPWIDTH (IQUOTIENT (IMAX (STRINGWIDTH " >" COMPFONT) (STRINGWIDTH "< " COMPFONT) (STRINGWIDTH "==" COMPFONT) (STRINGWIDTH "**" COMPFONT)) 2)) (LEFTSIDE (- CENTER 353 COMPWIDTH)) (RIGHTSIDE (+ CENTER COMPWIDTH 353)) (FROM-STRING (COND (FROM (CL:FORMAT NIL "~A (~A; ~A)" FROM FROMAUTHOR FDATE)) (T ""))) (TO-STRING (COND (TO (CL:FORMAT NIL "~A (~A; ~A)" TO TOAUTHOR TDATE)) (T ""] (DSPFONT COMPFONT STREAM) (DSPXPOSITION (- CENTER (IQUOTIENT (STRINGWIDTH COMP COMPFONT) 2)) STREAM) (PRIN1 COMP STREAM) (DSPFONT MAINFONT STREAM) (DSPXPOSITION (- LEFTSIDE (STRINGWIDTH FROM-STRING MAINFONT)) STREAM) (PRIN1 FROM-STRING STREAM) (DSPXPOSITION RIGHTSIDE STREAM) (PRINTOUT STREAM TO-STRING T))) (T (* ;  "the display, where TAB does work.") (PRINTOUT STREAM (OR FROM "") (COND (FROMAUTHOR (CONCAT " (" FROMAUTHOR ")")) (T " ")) 45 (IF FDATE THEN (CONCAT "[" FDATE "]") ELSEIF TDATE THEN (SPACES (IPLUS 2 (NCHARS TDATE)) STREAM) "") -2 COMP -2 (IF TDATE THEN (CONCAT "[" TDATE "]") ELSE "") -1 (OR TO "") (COND (TOAUTHOR (CONCAT " (" TOAUTHOR ")")) (T "")) T]) (COMPAREDIRECTORIES.NEWPAGEFN [LAMBDA (LISTINGSTREAM) (* ; "Edited 15-Nov-88 19:20 by jds") (* ;; "Print the new-page headings on a COMPARE-DIRECTORIES page.") (LET* ((LEFT (DSPLEFTMARGIN NIL LISTINGSTREAM)) (RIGHT (DSPRIGHTMARGIN NIL LISTINGSTREAM)) (TITLEFONT (FONTCREATE 'MODERN 10 'BOLD NIL LISTINGSTREAM)) (TITLE (STREAMPROP LISTINGSTREAM 'TITLE)) (HEAD-WIDTH (IQUOTIENT (STRINGWIDTH (CAR TITLE) TITLEFONT) 2)) (CENTER (IQUOTIENT (+ LEFT RIGHT) 2))) (DSPFONT TITLEFONT LISTINGSTREAM) (MOVETO (- CENTER HEAD-WIDTH) (DSPTOPMARGIN NIL LISTINGSTREAM) LISTINGSTREAM) (PRIN1 (CAR TITLE) LISTINGSTREAM) (MOVETO (- RIGHT (STRINGWIDTH (CDR TITLE) TITLEFONT)) 1270 LISTINGSTREAM) (PRIN1 (CDR TITLE) LISTINGSTREAM) (MOVETO LEFT [IDIFFERENCE (DSPTOPMARGIN NIL LISTINGSTREAM) (FIXR (FTIMES 1.5 (FONTPROP TITLEFONT 'HEIGHT] LISTINGSTREAM]) (COMPARE-DIRECTORIES + [LAMBDA (FROMDIR TODIR SHOW=FILESTOO FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID) + (* ; "Edited 3-Nov-94 15:06 by jds") + + (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.") + + (LET ((LISTINGSTREAM (COND + [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'INTERPRESS '(LANDSCAPE T] + (T NIL))) + FROM-GENERATOR TO-GENERATOR) + (COND + (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) + [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR) + (CONCAT "as of " (DATE] + (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) + [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY + (OR FILEPATTERN '*.*;)) + NIL + '(SORT] + [SETQ TO-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY TODIR 'BODY + (OR FILEPATTERN '*.*;)) + NIL + '(SORT] + [bind FROM-FILE TO-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)) + (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) + repeatwhile (OR FROM-FILE TO-FILE) bind DT1 DT2 TON SHORT-FROM SHORT-TO + do (COND + ((AND FROM-FILE (CL:MEMBER (UNPACKFILENAME.STRING FROM-FILE 'EXTENSION) + EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) + + (* ;; "FROM file is on the prohibited-extension list. Skip it.") + + (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) + ((AND TO-FILE (CL:MEMBER (UNPACKFILENAME.STRING TO-FILE 'EXTENSION) + EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) + + (* ;; "TO file is on the prohibited-extension list. Skip it.") + + (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) + (T (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL + 'BODY FROM-FILE)) + (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL + 'BODY TO-FILE)) + (HELP) + (COND + ((NOT FROM-FILE) + + (* ;; " Ran out of FROM files first; print the missing-FROM marker") + + (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" + (GETFILEINFO TO-FILE 'CREATIONDATE) + SHORT-TO + (GETFILEINFO TO-FILE 'AUTHOR)) + (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) + ((NOT TO-FILE) + + (* ;; " Ran out of TO files first; print the missing-TO marker") + + (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO + FROM-FILE + 'AUTHOR) + (GETFILEINFO FROM-FILE 'CREATIONDATE) + "**" "" "" "") + (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) + ((CL:STRING-LESSP SHORT-FROM SHORT-TO) + + (* ;; + "This FROM file has no TO equivalent. Print the missing-FROM marker") + + (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO + FROM-FILE + 'AUTHOR) + (GETFILEINFO FROM-FILE 'CREATIONDATE) + "**" "" "" "") + (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) + ((CL:STRING-LESSP SHORT-TO SHORT-FROM) + + (* ;; + "This TO file has no FROM equivalent. Print the missing-TO marker") + + (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" + (GETFILEINFO TO-FILE 'CREATIONDATE) + SHORT-TO + (GETFILEINFO TO-FILE 'AUTHOR)) + (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) + ([= (SETQ DT1 (GETFILEINFO FROM-FILE 'ICREATIONDATE)) + (SETQ DT2 (GETFILEINFO TO-FILE 'ICREATIONDATE] + (AND SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM + "" (GDATE DT1) + "==" + (GDATE DT2) + SHORT-TO "")) + (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) + (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) + (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM + (GETFILEINFO FROM-FILE 'AUTHOR) + (GDATE DT1) + (COND + ((LESSP DT1 DT2) + "<<") + (T ">>")) + (GDATE DT2) + SHORT-TO + (GETFILEINFO TO-FILE 'AUTHOR)) + (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) + (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR] + (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES + [LAMBDA (FROMDIR TODIR LISTINGFILE) (* ; "Edited 3-Nov-94 15:17 by jds") + + (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.") + + (LET ((LISTINGSTREAM (COND + [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'POSTSCRIPT '(LANDSCAPE T] + (T NIL))) + FROM-GENERATOR TO-GENERATOR) + (COND + (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) + [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT "Compiled-file search of " FROMDIR + " vs " TODIR) + (CONCAT "as of " (DATE] + (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) + [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY "*.;") + NIL + '(SORT] + (bind FROM-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)) + repeatwhile FROM-FILE bind DT1 DT2 TON SHORT-FROM SHORT-TO + do (COND + [[SETQ TO-FILE (OR (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL + 'EXTENSION + 'DFASL + 'BODY FROM-FILE)) + (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL + 'EXTENSION + 'LCOM + 'BODY FROM-FILE] + (COND + ((< (GETFILEINFO TO-FILE 'ICREATIONDATE) + (GETFILEINFO FROM-FILE 'ICREATIONDATE)) + (PRINTOUT LISTINGSTREAM FROM-FILE " (" (GETFILEINFO FROM-FILE + 'CREATIONDATE) + ") vs " TO-FILE " (" (GETFILEINFO TO-FILE 'CREATIONDATE) + ")" T] + (T (PRINTOUT LISTINGSTREAM FROM-FILE " has no compiled equivalent." T))) + (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) + (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) ) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1114 23091 (COMPAREDIRECTORIES 1124 . 11760) (COMPAREDIRS.FORMATLINE 11762 . 14932) ( COMPAREDIRECTORIES.NEWPAGEFN 14934 . 16201) (COMPARE-DIRECTORIES 16203 . 23089)) (23156 26000 ( FIND-UNCOMPILED-FILES 23166 . 25998))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.TEDIT b/lispusers/COMPAREDIRECTORIES.TEDIT new file mode 100644 index 00000000..ca45d6e2 Binary files /dev/null and b/lispusers/COMPAREDIRECTORIES.TEDIT differ diff --git a/lispusers/COMPARESOURCES b/lispusers/COMPARESOURCES new file mode 100644 index 00000000..6fa1b2f2 --- /dev/null +++ b/lispusers/COMPARESOURCES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Apr-2018 10:50:03"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;2 15689 changes to%: (FNS COMPARESOURCES) previous date%: "15-Apr-88 14:42:45" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 2018 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPARESOURCESCOMS) (RPAQQ COMPARESOURCESCOMS ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE) (FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS) (VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE) (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)))) (DEFINEQ (COMPARESOURCES [LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 19-Apr-2018 10:49 by rmk:") (* ;;; "Compare two lisp source files, reporting differences.") (DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES)) (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY) [SETQ FILEX (OR (FINDFILE FILEX T) (RETURN (printout LISTSTREAM FILEX " not found" T] [SETQ FILEY (OR (FINDFILE FILEY T) (RETURN (printout LISTSTREAM FILEY " not found" T] (* ;; "Read the two files, throwing out extraneous forms & such:") (CL:MULTIPLE-VALUE-SETQ (BODYX ENVX) (READFILE FILEX)) (SETQ BODYX (\CS.FILTER.GARBAGE BODYX)) (CL:MULTIPLE-VALUE-SETQ (BODYY ENVY) (READFILE FILEY)) (SETQ BODYY (\CS.FILTER.GARBAGE BODYY)) (printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE) " and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE) ":" T T) [SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) 'DECLARE%:] (SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX)) [SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) 'DECLARE%:] (SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY)) (WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT)) (\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM) (* ;; "Done with the non-DECLARE: expressions. Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare") (SETQ BODYX (\CS.SORT.DECLARES DECLAREX)) (SETQ BODYY (\CS.SORT.DECLARES DECLAREY)) [SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y)) unless (SASSOC (CAR Y) BODYX] (* ;  "Add placeholders for any declaration types in Y not in X to simplify what follows") [for X in BODYX bind Y TYPE do (SETQ Y (SASSOC (CAR X) BODYY)) (SETQ TYPE (CAR X)) [SETQ X (LDIFFERENCE (CDR X) (PROG1 (CDR Y) (SETQ Y (LDIFFERENCE (CDR Y) X)))] (COND ((OR X Y) (printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND ( CL:SET-DIFFERENCE TYPE DEFAULT.DECLARE.TAGS ) '(--] " forms------" T) (* ;  "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order") (\CS.COMPARE.MASTERS (REVERSE X) (REVERSE Y) DW? LISTSTREAM] (TERPRI LISTSTREAM)) (RETURN (OR (REVERSE DIFFERENCES) 'SAME]) (\CS.COMPARE.MASTERS (LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 15-Apr-88 14:41 by bvm") (LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS) (DECLARE (USEDFREE DIFFERENCES)) (SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX)) (SETQ FNSX (for BOD in FNSX join (CDR BOD))) (SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY)) (SETQ FNSY (for BOD in FNSY join (CDR BOD))) (COND ((OR FNSX FNSY) (printout LISTSTREAM "---Functions: " T) (COND (DW? (LET ((NOSPELLFLG T)) (DECLARE (SPECVARS NOSPELLFLG)) (for X in FNSX when (SETQ Y (ASSOC (CAR X) FNSY)) do (* ; "Only bother dwimifying the ones that look different") (DWIMIFY (CADR X) T) (DWIMIFY (CADR Y) T))))) (COND ((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL (FUNCTION (LAMBDA (X Y STREAM) (COMPARELISTS (CADR X) (CADR Y) STREAM))) (FUNCTION CAR) LISTSTREAM)) (push DIFFERENCES (CONS (QUOTE FNS) DIFS)))))) (for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE) (SETQ DEFFERS (GET TYPE :DEFINED-BY))) do (* ;; "handle definer based things") (for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X when (EQ (CAR X) DEFFER))) (SETQ YTHING (for X in BODYY collect X when (EQ (CAR X) DEFFER))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (CONCAT (OR (CL:DOCUMENTATION TYPE (QUOTE DEFINE-TYPES)) TYPE) " defined by " DEFFER) NIL (GET DEFFER :DEFINITION-NAME) LISTSTREAM)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS)))))))) (for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE)) (SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X))) (SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (OR (fetch (CSTYPE TITLE) of TYPE) (L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE) of TYPE)) T)) (fetch (CSTYPE COMPAREFN) of TYPE) (OR (fetch (CSTYPE IDFN) of TYPE) (FUNCTION CADR)) LISTSTREAM)) (SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS))))))) (SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX (SETQ BODYX (LDIFFERENCE BODYX BODYY))))) (COND ((OR BODYX BODYY) (printout LISTSTREAM T "---Expressions:" T) (LET ((COMMENTX 0) (COMMENTY 0) EXTRAS) (* ; "Remove comments") (SETQ BODYX (for X in BODYX collect X unless (COND ((EQ (CAR X) COMMENTFLG) (add COMMENTX 1) T)))) (SETQ BODYY (for Y in BODYY collect Y unless (COND ((EQ (CAR Y) COMMENTFLG) (add COMMENTY 1) T)))) (COND ((OR (NEQ COMMENTX 0) (NEQ COMMENTY 0)) (printout LISTSTREAM |.I1| COMMENTX " comments -> " |.I1| COMMENTY " comments." T T))) (COND ((SETQ EXTRAS (COND (BODYX (COND (BODYY (COMPARELISTS BODYX BODYY LISTSTREAM) NIL) (T (printout LISTSTREAM "These are not on " FILEY) BODYX))) (BODYY (printout LISTSTREAM "These are not on " FILEX) BODYY))) (printout LISTSTREAM ":" T) (for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3)))) (COND ((AND (OR BODYX BODYY) (OR (EQ EXAMINE T) (EQMEMB (QUOTE MISC) EXAMINE))) (EDITE (LIST BODYX BODYY)))) (OR (ASSOC (QUOTE Other) DIFFERENCES) (push DIFFERENCES (LIST (QUOTE Other) (QUOTE --))))))))) ) (\CS.COMPARE.TYPES (LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN. Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT)))) ) (\CS.SORT.DECLARES (LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT)) ) (\CS.SORT.DECLARE1 (LAMBDA (DEC TAGLST) (* bvm%: "15-Nov-85 19:09") (DECLARE (USEDFREE RESULT)) (* ;;; "Process one DECLARE: expression, partitioning it into subdeclarations put on RESULT assuming that the default tags in effect by the time you get here are in TAGLST") (for TAIL on (CDR DEC) bind CURRENT TAG COMPLEMENT do (COND ((NLISTP (SETQ TAG (CAR TAIL))) (* ; "Canonicalize tag") (SELECTQ TAG (DOEVAL@LOAD (SETQQ TAG EVAL@LOAD)) (DOEVAL@COMPILE (SETQQ TAG EVAL@COMPILE)) (DOCOPY (SETQQ TAG COPY)) NIL) (COND ((NOT (MEMB TAG TAGLST)) (SETQ TAGLST (COND ((STRPOS (QUOTE WHEN) TAG) (* ; "These take an extra expression") (APPEND TAGLST (LIST TAG (CAR (SETQ TAIL (CDR TAIL)))))) ((FMEMB (SETQ COMPLEMENT (SELECTQ TAG (COPY (QUOTE DONTCOPY)) (DONTCOPY (QUOTE COPY)) (EVAL@COMPILE (QUOTE DONTEVAL@COMPILE)) (DONTEVAL@COMPILE (QUOTE EVAL@COMPILE)) (EVAL@LOAD (QUOTE DONTEVAL@LOAD)) (DONTEVAL@LOAD (QUOTE EVAL@LOAD)) (FIRST (QUOTE NOTFIRST)) (NOTFIRST (QUOTE FIRST)) NIL)) TAGLST) (SUBST TAG COMPLEMENT TAGLST)) (T (APPEND TAGLST (LIST TAG))))) (SETQ CURRENT NIL)))) ((EQ (CAR TAG) (QUOTE DECLARE%:)) (* ; "Process embedded declaration") (\CS.SORT.DECLARE1 TAG TAGLST)) (T (* ; "Stick this expression on the entry for the tags that tell when to eval it") (COND ((AND (NOT CURRENT) (NOT (SETQ CURRENT (SASSOC TAGLST RESULT)))) (SETQ RESULT (NCONC1 RESULT (SETQ CURRENT (LIST TAGLST)))))) (push (CDR CURRENT) TAG))))) ) (\CS.FILTER.GARBAGE (LAMBDA (FILECONTENTS) (* ; "Edited 29-Dec-86 10:44 by jds") (* ;;; "Remove %"Uninteresting%" items from files to be compared. Removes FILECREATED form, filemap, copyright notice, and DECLARE: DONTCOPY items.") (for X in FILECONTENTS collect X unless (OR (EQ (CAR X) (QUOTE FILECREATED)) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (EQ (CADR X) (QUOTE DONTCOPY)) (LISTP (CADDR X)) (OR (FMEMB (QUOTE COPYRIGHT) (CADDR X)) (FMEMB (QUOTE FILEMAP) (CADDR X))))))) ) ) (DEFINEQ (\CS.ISVARFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL))) (\CS.COMPARE.VARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compares two variable setting forms") (COND ((EQ (CAR X) (CAR Y)) (* ; "Same type of setting fn") (COMPARELISTS (CADDR X) (CADDR Y) STREAM)) (T (LET ((XVAL (COND ((EQ (CAR X) (QUOTE RPAQQ)) (KWOTE (CADDR X))) (T (CADDR X)))) (YVAL (COND ((EQ (CAR Y) (QUOTE RPAQQ)) (KWOTE (CADDR Y))) (T (CADDR Y))))) (COND ((EQUAL XVAL YVAL) (* ; "Same value, different setter") (printout STREAM (COND ((EQ (CAR X) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) " -> " (COND ((EQ (CAR Y) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) T)) (T (COMPARELISTS XVAL YVAL STREAM))))))) ) (\CS.ISMACROFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:19") (SELECTQ (CAR X) (DEFMACRO T) (PUTPROPS (FMEMB (CADDR X) MACROPROPS)) NIL)) ) (\CS.ISRECFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:20") (FMEMB (CAR X) CLISPRECORDTYPES))) (\CS.ISCOURIERFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:21") (EQ (CAR X) (QUOTE COURIERPROGRAM)))) (\CS.ISTEMPLATEFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:20") (EQ (CAR X) (QUOTE SETTEMPLATE)))) (\CS.COMPARE.TEMPLATES (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Templates usually look like (SETTEMPLATE (QUOTE FN) (QUOTE TEMPLATE))") (COND ((AND (EQUAL (CADR X) (CADR Y)) (EQ (CAR (CADDR X)) (QUOTE QUOTE)) (EQ (CAR (CADDR Y)) (QUOTE QUOTE))) (COMPARELISTS (CADR (CADDR X)) (CADR (CADDR Y)) STREAM)) (T (COMPARELISTS X Y STREAM)))) ) (\CS.ISPROPFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:34") (* ;;; "(PUTPROPS SYMBOL PROP VALUE)") (AND (EQ (CAR X) (QUOTE PUTPROPS)) (NULL (CDDDDR X)))) ) (\CS.PROP.NAME (LAMBDA (X) (* bvm%: "13-Mar-86 16:29") (* ;;; "The 'Name' of a property is its atom/value pair") (LIST (CADR X) (CADDR X))) ) (\CS.COMPARE.PROPS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compare the values") (COMPARELISTS (CADDDR X) (CADDDR Y) STREAM)) ) (\CS.ISADDVARFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:40") (EQ (CAR X) (QUOTE ADDTOVAR)))) (\CS.COMPARE.ADDVARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "(ADDTOVAR ListName . values)") (COMPARELISTS (CDDR X) (CDDR Y) STREAM)) ) (\CS.ISFPKGCOMFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:50") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (AND (EQ (CAR X) (QUOTE PUTDEF)) (EQUAL (CADDR X) (QUOTE (QUOTE FILEPKGCOMS))))) ) (\CS.COMPARE.FPKGCOMS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM)) ) ) (RPAQQ COMPARESOURCETYPES ((VARS \CS.ISVARFORM \CS.COMPARE.VARS) (MACROS \CS.ISMACROFORM) (RECORDS \CS.ISRECFORM) (PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties") (ADDVARS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS CADR "Additions to lists") (TEMPLATES \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES CADADR) (COURIERPROGRAMS \CS.ISCOURIERFORM) (FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR))) (RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD CSTYPE (FPKGTYPE PREDFN COMPAREFN IDFN TITLE)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS) ) ) (PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1153 12054 (COMPARESOURCES 1163 . 5121) (\CS.COMPARE.MASTERS 5123 . 8554) ( \CS.COMPARE.TYPES 8556 . 9805) (\CS.SORT.DECLARES 9807 . 10150) (\CS.SORT.DECLARE1 10152 . 11572) ( \CS.FILTER.GARBAGE 11574 . 12052)) (12055 14783 (\CS.ISVARFORM 12065 . 12170) (\CS.COMPARE.VARS 12172 . 12834) (\CS.ISMACROFORM 12836 . 12974) (\CS.ISRECFORM 12976 . 13069) (\CS.ISCOURIERFORM 13071 . 13171) (\CS.ISTEMPLATEFORM 13173 . 13271) (\CS.COMPARE.TEMPLATES 13273 . 13638) (\CS.ISPROPFORM 13640 . 13795) (\CS.PROP.NAME 13797 . 13942) (\CS.COMPARE.PROPS 13944 . 14101) (\CS.ISADDVARFORM 14103 . 14196) (\CS.COMPARE.ADDVARS 14198 . 14363) (\CS.ISFPKGCOMFORM 14365 . 14572) (\CS.COMPARE.FPKGCOMS 14574 . 14781))))) STOP \ No newline at end of file diff --git a/lispusers/COMPARESOURCES.TEDIT b/lispusers/COMPARESOURCES.TEDIT new file mode 100644 index 00000000..421b05b5 Binary files /dev/null and b/lispusers/COMPARESOURCES.TEDIT differ diff --git a/lispusers/COMPARETEXT b/lispusers/COMPARETEXT new file mode 100644 index 00000000..954a5466 --- /dev/null +++ b/lispusers/COMPARETEXT @@ -0,0 +1,654 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "18-Nov-93 14:43:00" {DSK}export>lispcore>lispusers>comparetext.;2 39517 + + changes to%: (VARS COMPARETEXTCOMS) + + previous date%: "11-Jul-85 09:12:06" {DSK}export>lispcore>lispusers>comparetext.;1) + + +(* ; " +Copyright (c) 1984, 1985, 1993 by Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT COMPARETEXTCOMS) + +(RPAQQ COMPARETEXTCOMS + ((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP) + GRAPHER)) + (FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS + IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH + IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS + IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST + IMCOMPARE.UPDATE.SYMBOL.TABLE) + (P (MOVD 'COMPARETEXT 'IMCOMPARE)) + (VARS (IMCOMPARE.LAST.NODE NIL) + (IMCOMPARE.LAST.GRAPH.WINDOW NIL) + (IMCOMPARE.HASH.TYPE.MENU NIL)) + (RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB) + (FILES GRAPHER))) +(DECLARE%: EVAL@COMPILE + +(FILESLOAD (LOADCOMP) + GRAPHER) +) +(DEFINEQ + +(COMPARETEXT + [LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION) + (* mjs " 8-Jan-84 21:06") + + (* Compares the two files, and produces a graph showing their corresponding + chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may + be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. + The file difference graph is displayed at GRAPHREGION. + If GRAPH.REGION = NIL, the user is asked to specify a region. + If GRAPH.REGION = T, a standard region is used.) + + (PROG ((NEWFILE (FINDFILE NEWFILENAME T)) + (OLDFILE (FINDFILE OLDFILENAME T))) + (if (AND OLDFILE NEWFILE) + then (* compare the two "chunks" + consisting of the entire text of the + two files) + (IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK + FILENAME _ NEWFILE + FILEPTR _ 0 + CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH)) + (create IMCOMPARE.CHUNK + FILENAME _ OLDFILE + FILEPTR _ 0 + CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH)) + HASH.TYPE + (if (EQ GRAPH.REGION T) + then (create REGION + LEFT _ 25 + BOTTOM _ 25 + WIDTH _ 500 + HEIGHT _ 150) + elseif GRAPH.REGION + else (CLRPROMPT) + (printout PROMPTWINDOW + "Please specify a window for the file difference graph" T) + (GETREGION))) + else (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME + " --- IMCOMPARE aborted" T]) + +(IMCOMPARE.BOXNODE + [LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40") + (if IMCOMPARE.LAST.NODE + then (RESET/NODE/BORDER IMCOMPARE.LAST.NODE 'INVERT IMCOMPARE.LAST.GRAPH.WINDOW) + (SETQ IMCOMPARE.LAST.NODE NIL) + (SETQ IMCOMPARE.LAST.GRAPH.WINDOW NIL)) + (if NODE + then (RESET/NODE/BORDER NODE 'INVERT WINDOW) + (SETQ IMCOMPARE.LAST.NODE NODE) + (SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW]) + +(IMCOMPARE.CHUNKS + [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION) + (* rmk%: " 8-Sep-84 00:06") + + (* this is the main text-comparison function. + It compares the text in the two chunks and produces a graph showing how the sub-chunks of the two main + chunks are related. The two main chunks may be in the same file, and the file + may actually be an open Tedit textstream. + The main chunks are broken down according to HASH.TYPE, which may be PARA + , LINE, or WORD. HASH.TYPE = NIL defaults to PARA. + The file difference graph is displayed at GRAPH.REGION.) + + (* this text comparison algorithm is originally from the article + "A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM, + V21, %#4, April 1978 --- major difference is that I use lists instead of arrays) + + (PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500)) + NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST) + + (* * collect lists of chunks from each of the main chunks, dividing them + according to HASH.TYPE) + + (SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE)) + (SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE)) + + (* * update the chunk symbol table. For each hash value, this table records the + number of "new" chunks with that hash value, the number of "old" chunks with + that value, and a pointer to the place in OLD.CHUNK.LIST .) + + (IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL) + (IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T) + + (* * For every new chunk whose hash value matches EXACTLY ONE old chunk's + value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK + field to point to the appropriate place in the old chunk list . Also, make sure that OTHERCHUNK of the matching old chunk is + non-NIL, so that unconnected old chunks will be merged correctly.) + + (for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB + do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK) + CHUNK.SYMBOL.TABLE)) + (if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB)) + (EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB))) + then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK + with (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB)) + (replace (IMCOMPARE.CHUNK OTHERCHUNK) + of (CAR (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB)) + with T))) + + (* * merge connected chunks forward) + + (IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL) + + (* * merge connected chunks backwards) + + (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST)) + (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST)) + (IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T) + (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST)) + (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST)) + + (* * merge unconnected chunks) + + (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST) + (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST) + + (* * now, the file comparison is complete. + Format and display the file difference graph) + + (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK + HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST]) + +(IMCOMPARE.COLLECT.HASH.CHUNKS + [LAMBDA (CHUNK HASH.TYPE) (* mjs " 8-Jan-84 20:57") + + (* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE) + + (PROG ((FILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK)) + STREAM END.OF.CHUNK.PTR CHUNK.LIST) + [SETQ STREAM (GETSTREAM (OPENFILE FILENAME 'INPUT 'OLD] + (SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)) + (SETQ END.OF.CHUNK.PTR (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK) + (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK))) + (SETQ CHUNK.LIST (until (IGEQ (GETFILEPTR STREAM) + END.OF.CHUNK.PTR) collect (IMCOMPARE.HASH STREAM + END.OF.CHUNK.PTR + HASH.TYPE))) + (CLOSEF STREAM) + (RETURN CHUNK.LIST]) + +(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH + [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST + OLDFILE.CHUNK.LIST) (* mjs "11-Jul-85 09:10") + + (* * format and display the graph) + + (PROG ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK)) + (OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK)) + (OLD.CHUNK.NODE.FROM.NODES NIL) + (BORDERSIZE 1) + GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD + YCOORD.INCREMENT DIFF.GRAPH) + + (* * set up GRAPH.WINDOW. This is done first so you can get the width and + height of strings to be printed in the window.) + + [SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by " + (SELECTQ HASH.TYPE + ((PARA NIL) + "Paragraph") + (LINE "Line") + (WORD "Word") + (SHOULDNT] + (WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE) + [WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) + (if (EQ WINDOW + IMCOMPARE.LAST.GRAPH.WINDOW) + then (SETQ + IMCOMPARE.LAST.GRAPH.WINDOW + NIL) + (SETQ IMCOMPARE.LAST.NODE NIL] + (SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW) + 2)) + [SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD + (IQUOTIENT (STRINGWIDTH + OLDFILENAME + GRAPH.WINDOW) + 2) + 20] + [SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE) + (fetch (REGION HEIGHT) of (STRINGREGION + NEWFILENAME + GRAPH.WINDOW] + + (* * collect new-chunk graph nodes, while accumulating + OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks) + + (SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from + YCOORD.INCREMENT + by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK + collect (SETQ CORRESPONDING.OLD.CHUNK + (CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) + of NEW.CHUNK))) + (if CORRESPONDING.OLD.CHUNK + then (SETQ OLD.CHUNK.NODE.FROM.NODES + (CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK) + OLD.CHUNK.NODE.FROM.NODES))) + (* Start out with 2 point white + border, so we can invert it) + (NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM + (PACK* (fetch (IMCOMPARE.CHUNK + FILEPTR) + of NEW.CHUNK) + ":" + (fetch (IMCOMPARE.CHUNK + CHUNKLENGTH) + of NEW.CHUNK)) + 12) + (create POSITION + XCOORD _ NEW.CHUNK.XCOORD + YCOORD _ Y) + (if CORRESPONDING.OLD.CHUNK + then (LIST CORRESPONDING.OLD.CHUNK) + else NIL) + NIL DEFAULTFONT -2))) + (SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from + YCOORD.INCREMENT + by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK + collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK + OLD.CHUNK.NODE.FROM.NODES + ))) + (NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM + (PACK* (fetch (IMCOMPARE.CHUNK + FILEPTR) + of OLD.CHUNK) + ":" + (fetch (IMCOMPARE.CHUNK + CHUNKLENGTH) + of OLD.CHUNK)) + 12 "-") + (create POSITION + XCOORD _ OLD.CHUNK.XCOORD + YCOORD _ Y) + NIL + (if CORRESPONDING.NEW.CHUNK + then (LIST CORRESPONDING.NEW.CHUNK) + else NIL) + DEFAULTFONT -2))) + (SETQ DIFF.GRAPH (create GRAPH + DIRECTEDFLG _ T + SIDESFLG _ T + GRAPHNODES _ + (NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME + (create POSITION + XCOORD _ NEW.CHUNK.XCOORD + YCOORD _ 0) + NIL NIL DEFAULTFONT -2)) + NEW.CHUNK.NODES + (LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME + (create POSITION + XCOORD _ OLD.CHUNK.XCOORD + YCOORD _ 0) + NIL NIL DEFAULTFONT -2)) + OLD.CHUNK.NODES))) + (SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN) + (FUNCTION IMCOMPARE.MIDDLEBUTTONFN) + T NIL]) + +(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT + [LAMBDA (FILE) (* mjs " 2-Jan-84 16:19") + + (* returns the Tedit text object of the first Tedit window which is currently + looking at FILE, if there is one. Returns NIL if none is found.) + + (PROG ((TEDIT.TEXT.OBJECT NIL)) + (for X in (OPENWINDOWS) bind POSS.TOBJ POSS.FILENAME + when (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil TEDIT.TEXT.OBJECT + do (SETQ POSS.FILENAME (FULLNAME (fetch (TEXTOBJ TXTFILE) of POSS.TOBJ))) + (if (EQ FILE POSS.FILENAME) + then (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ))) + (RETURN TEDIT.TEXT.OBJECT]) + +(IMCOMPARE.HASH + [LAMBDA (STREAM EOF.PTR HASH.TYPE) (* rmk%: " 8-Sep-84 00:37") + + (* reads caracters from STREAM and creates a hash value for the "next" "chunk" + A chunk is a paragraph ending in two consecutive CRs , + a line ending in a CR , or a word ending in any white space + character space . In computing the hash value, white space is + ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR + Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the + beginning of the chunk, the length of the chunk, and the fullname of the stream) + + (* Note%: Most of the time in COMPARETEXT is spent reading in and hashing + chunks, so this function was optimizes for speed, at the expense of length) + + (PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM)) + (EOLC (GETFILEINFO STREAM 'EOL)) + (HASHNUM 0) + FILE.PTR C) + (SETQ FILE.PTR BEGIN.FILE.PTR) + (SELECTQ HASH.TYPE + ((NIL PARA) + + (* Paragraph chunks end with two consecutive EOL's. + In order to detect this without slowing down the gobbling of normal chars, + LAST.EOL.POS is set to the filepos of the last EOL detected. + This is only checked when another EOL comes along.) + + (PROG ((LAST.EOL.POS -5)) + loop + (if (IGEQ FILE.PTR EOF.PTR) + then (GO return)) + (SETQ FILE.PTR (ADD1 FILE.PTR)) + (SELCHARQ (SETQ C (BIN STREAM)) + (CR + + (* If this is the second consecutive CR, this is the end of the chunk. + Otherwise, reset LAST.EOL.POS) + + (SELECTQ EOLC + (CR (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM))) + then (GO endchunk) + else (SETQ LAST.EOL.POS (GETFILEPTR STREAM)))) + (CRLF (if (IGEQ FILE.PTR EOF.PTR) + then (GO return)) + (SELCHARQ (\PEEKBIN STREAM T) + (LF (SETQ FILE.PTR (ADD1 FILE.PTR)) + (BIN STREAM) + (if (IEQP LAST.EOL.POS (IDIFFERENCE + (GETFILEPTR STREAM) + 2)) + then (GO endchunk) + else (SETQ LAST.EOL.POS (GETFILEPTR STREAM + )))) + NIL)) + NIL)) + (LF [COND + ((EQ EOLC 'LF) + (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM))) + then (GO endchunk) + else (SETQ LAST.EOL.POS (GETFILEPTR STREAM]) + ((SPACE TAB)) + (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) + 1 16) + 1 16) + 1 16))) + (GO loop))) + (LINE (* Line chunks end on a single CR.) + (PROG NIL + loop + (if (IGEQ FILE.PTR EOF.PTR) + then (GO return)) + (SETQ FILE.PTR (ADD1 FILE.PTR)) + (SELCHARQ (SETQ C (BIN STREAM)) + (CR (SELECTQ EOLC + (CR (GO endchunk)) + (LF) + (CRLF (if (IGEQ FILE.PTR EOF.PTR) + then (GO return)) + (SELCHARQ (\PEEKBIN STREAM T) + (LF (SETQ FILE.PTR (ADD1 FILE.PTR)) + (BIN STREAM) + (GO endchunk)) + NIL)) + (SHOULDNT))) + (LF (AND (EQ EOLC 'LF) + (GO endchunk))) + ((SPACE TAB)) + (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) + 1 16) + 1 16) + 1 16))) + (GO loop))) + (WORD (* word chunks end on any white + space) + (PROG NIL + loop + (if (IGEQ FILE.PTR EOF.PTR) + then (GO return)) + (SETQ FILE.PTR (ADD1 FILE.PTR)) + (SELCHARQ (SETQ C (BIN STREAM)) + ((CR SPACE TAB LF) + (GO endchunk)) + (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) + 1 16) + 1 16) + 1 16))) + (GO loop))) + (SHOULDNT)) + endchunk + (* flush all white space before next + chunk) + (if (IGEQ FILE.PTR EOF.PTR) + then (GO return)) + (SETQ FILE.PTR (ADD1 FILE.PTR)) + (SELCHARQ (BIN STREAM) + ((CR SPACE TAB LF) + (GO endchunk)) + (PROGN (SETQ FILE.PTR (SUB1 FILE.PTR)) + (SETFILEPTR STREAM FILE.PTR))) + return + (RETURN (create IMCOMPARE.CHUNK + HASHVALUE _ HASHNUM + FILEPTR _ BEGIN.FILE.PTR + CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR) + FILENAME _ (FULLNAME STREAM]) + +(IMCOMPARE.LEFTBUTTONFN + [LAMBDA (GNODE WINDOW) (* mjs " 2-Apr-85 14:21") + (if GNODE + then (IMCOMPARE.BOXNODE GNODE WINDOW) + (PROG ((NODEID (fetch (GRAPHNODE NODEID) of GNODE)) + (FILEPTR 1) + (CHUNKLENGTH 0) + (TEDIT.TEXT.OBJECT NIL) + FILE) + (SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID)) + (SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID)) + (SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID)) + (SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE)) + (if TEDIT.TEXT.OBJECT + then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25)) + 0 + 'LEFT) + (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT) + (TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT) + (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT) + (TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of + + TEDIT.TEXT.OBJECT + )) + 'PROCESS)) + else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH]) + +(IMCOMPARE.LENGTHEN.ATOM + [LAMBDA (X MIN.LENGTH EXTENDER) (* mjs "30-Dec-83 15:11") + + (* makes sure that the atom X is at least MIN.LENGTH characters long, by + concatinating the first character of EXTENDER + (or space, if not given) to the front) + + (PROG ((C (CHCON X))) + (SETQ EXTENDER (if EXTENDER + then (CHCON1 EXTENDER) + else (CHARCODE SPACE))) + (while (ILESSP (LENGTH C) + MIN.LENGTH) do (SETQ C (CONS EXTENDER C))) + (RETURN (PACKC C]) + +(IMCOMPARE.MERGE.CONNECTED.CHUNKS + [LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35") + (while NEW.CHUNK.LIST bind NEW.CHUNK OLD.CHUNK.PTR + do (SETQ NEW.CHUNK (CAR NEW.CHUNK.LIST)) + (SETQ OLD.CHUNK.PTR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK)) + (if [OR (NULL (CDR NEW.CHUNK.LIST)) + (NULL OLD.CHUNK.PTR) + (NULL (CDR OLD.CHUNK.PTR)) + (NOT (EQP (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR NEW.CHUNK.LIST + )) + (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR OLD.CHUNK.PTR] + then (SETQ NEW.CHUNK.LIST (CDR NEW.CHUNK.LIST)) + else + + (* next chunks have same hash, so "murge" them into current chunks by adding + their chunk lengths to the current chunks, and splicing out the next chunks) + + [replace (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK + with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK) + (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR + NEW.CHUNK.LIST + ] + [replace (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR OLD.CHUNK.PTR) + with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR + OLD.CHUNK.PTR + )) + (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR + OLD.CHUNK.PTR + ] + [if BACKWARDS.FLG + then (* if the list is backwards, copy + next fileptr) + (replace (IMCOMPARE.CHUNK FILEPTR) of NEW.CHUNK + with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR + NEW.CHUNK.LIST + ))) + (replace (IMCOMPARE.CHUNK FILEPTR) of (CAR OLD.CHUNK.PTR) + with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR + OLD.CHUNK.PTR + ] + (* splice chunks out of new and old + list) + (RPLACD NEW.CHUNK.LIST (CDDR NEW.CHUNK.LIST)) + (RPLACD OLD.CHUNK.PTR (CDDR OLD.CHUNK.PTR]) + +(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS + [LAMBDA (CHUNK.LST) (* mjs " 5-JAN-84 13:58") + (while CHUNK.LST bind CHUNK do (SETQ CHUNK (CAR CHUNK.LST)) + (if (OR (NULL (CDR CHUNK.LST)) + (fetch (IMCOMPARE.CHUNK OTHERCHUNK) + of CHUNK) + (fetch (IMCOMPARE.CHUNK OTHERCHUNK) + of (CADR CHUNK.LST))) + then (SETQ CHUNK.LST (CDR CHUNK.LST)) + else (* both current chunk and next chunk + have no OTHERCHUNK, so merge them) + [replace (IMCOMPARE.CHUNK CHUNKLENGTH) + of CHUNK + with (IPLUS (fetch (IMCOMPARE.CHUNK + CHUNKLENGTH) + of CHUNK) + (fetch (IMCOMPARE.CHUNK + CHUNKLENGTH) + of (CADR CHUNK.LST] + (* splice chunks out of new and old + list) + (RPLACD CHUNK.LST (CDDR CHUNK.LST]) + +(IMCOMPARE.MIDDLEBUTTONFN + [LAMBDA (GNODE WINDOW) (* mjs " 6-Jan-84 11:37") + + (* This function is called if the MIDDLE mouse button is pressed over a graph + node. The selected node is IMCOMPARE-ed with the last node selected . The type of hashing used is selected from a + pop-up menu. If none of the hashing types is selected, the current node is + boxed. The pop-up menu is always located a little above the current cursor + position, so a quick double-MIDDLE-click is an easy way to change the current + boxed node.) + + (if GNODE + then (PROG (INNER.HASH.TYPE) + (CLRPROMPT) + (printout PROMPTWINDOW "Please select the type of hashing you wish." T) + [SETQ INNER.HASH.TYPE + (MENU (if (type? MENU IMCOMPARE.HASH.TYPE.MENU) + then IMCOMPARE.HASH.TYPE.MENU + else (SETQ IMCOMPARE.HASH.TYPE.MENU + (create MENU + ITEMS _ '(PARA LINE WORD) + MENUOFFSET _ + (create POSITION + XCOORD _ 20 + YCOORD _ -20] + (if (NULL INNER.HASH.TYPE) + then (* if no hash type is selected, just + box the current node and return) + (IMCOMPARE.BOXNODE GNODE WINDOW) + (RETURN)) + (if (NULL IMCOMPARE.LAST.NODE) + then (CLRPROMPT) + (PRIN1 "You must select another graph node first." PROMPTWINDOW) + (RETURN)) + (printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T) + (IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE + ) + (fetch (GRAPHNODE NODEID) of GNODE) + INNER.HASH.TYPE + (WINDOWPROP WINDOW 'REGION]) + +(IMCOMPARE.SHOW.DIST + [LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13") + (PROG ((WINDOW (CREATEW)) + MAX.Y X MAX.X) + (SETQ MAX.X (WINDOWPROP WINDOW 'WIDTH)) + (SETQ MAX.Y (WINDOWPROP WINDOW 'HEIGHT)) + (for SAMPLE in LST do (SETQ X (FTIMES MAX.X (FQUOTIENT SAMPLE MAX))) + (DRAWLINE X 0 X MAX.Y 1 'PAINT WINDOW]) + +(IMCOMPARE.UPDATE.SYMBOL.TABLE + [LAMBDA (CHUNK.LIST CHUNK.SYMBOL.TABLE OLD.CHUNK.FLG) (* mjs " 8-Jan-84 21:01") + + (* * update the chunk symbol table. For each hash value, this table records the + number of "new" chunks with that hash value, the number of "old" chunks with + that value, and a pointer to the place in OLD.CHUNK.LIST .) + + (for CHUNK.PTR on CHUNK.LIST bind CHUNK SYMB + do (SETQ CHUNK (CAR CHUNK.PTR)) + (SETQ SYMB (if (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK) + CHUNK.SYMBOL.TABLE) + else (PUTHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK) + (create IMCOMPARE.SYMB + NEWCOUNT _ 0 + OLDCOUNT _ 0 + OLDPTR _ NIL) + CHUNK.SYMBOL.TABLE))) + (if OLD.CHUNK.FLG + then (* increment old-chunk count) + (replace (IMCOMPARE.SYMB OLDCOUNT) of SYMB + with (ADD1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB))) + + (* smash old-chunk pointer. Note that it must point to the LIST of old-chunks, + rather than to the individual one) + + (replace (IMCOMPARE.SYMB OLDPTR) of SYMB with CHUNK.PTR) + else (* increment new-chunk count) + (replace (IMCOMPARE.SYMB NEWCOUNT) of SYMB + with (ADD1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB]) +) + +(MOVD 'COMPARETEXT 'IMCOMPARE) + +(RPAQQ IMCOMPARE.LAST.NODE NIL) + +(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW NIL) + +(RPAQQ IMCOMPARE.HASH.TYPE.MENU NIL) +(DECLARE%: EVAL@COMPILE + +(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK) + FILEPTR _ 1 CHUNKLENGTH _ 0) + +(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR)) +) + +(FILESLOAD GRAPHER) +(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1295 39023 (COMPARETEXT 1305 . 3700) (IMCOMPARE.BOXNODE 3702 . 4218) (IMCOMPARE.CHUNKS +4220 . 8406) (IMCOMPARE.COLLECT.HASH.CHUNKS 8408 . 9491) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9493 + . 18359) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18361 . 19124) (IMCOMPARE.HASH 19126 . 26281) ( +IMCOMPARE.LEFTBUTTONFN 26283 . 28019) (IMCOMPARE.LENGTHEN.ATOM 28021 . 28659) ( +IMCOMPARE.MERGE.CONNECTED.CHUNKS 28661 . 32157) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32159 . 34114) ( +IMCOMPARE.MIDDLEBUTTONFN 34116 . 36688) (IMCOMPARE.SHOW.DIST 36690 . 37136) ( +IMCOMPARE.UPDATE.SYMBOL.TABLE 37138 . 39021))))) +STOP diff --git a/lispusers/COMPARETEXT.TEDIT b/lispusers/COMPARETEXT.TEDIT new file mode 100644 index 00000000..e5a30119 Binary files /dev/null and b/lispusers/COMPARETEXT.TEDIT differ diff --git a/lispusers/COMPILEBANG b/lispusers/COMPILEBANG new file mode 100644 index 00000000..c9a52f47 --- /dev/null +++ b/lispusers/COMPILEBANG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED "22-Dec-86 18:42:34" {ERIS}LISPCORE>COMPILEBANG.;3 3465 changes to%: (FNS COMPILE!) previous date%: "18-Nov-86 22:23:43" {ERIS}LISPCORE>COMPILEBANG.;2) (* " Copyright (c) 1982, 1983, 1984, 1986 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPILEBANGCOMS) (RPAQQ COMPILEBANGCOMS ((FNS COMPILE!) (LISPXMACROS C) (USERMACROS C) (COMMANDS C) (PROP FILETYPE COMPILEBANG))) (DEFINEQ (COMPILE! [LAMBDA (X NOSAVE NOREDEFINE PRINTLAP) (* bvm%: "10-MAR-83 12:48") (DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS NLAMA NLAML LAMS LAMA NOFIXFNSLST NOFIXVARSLST)) (* ;; "In-core compiling for functions and forms, without the interview. If X is a list, we assume that we are being called merely to display the lap and machine code. THe form is compiled as the definition of FOO but the compiled code is thrown away. --- If X is a litatom, then saving, redefining, and printing is controlled by the flags.") (RESETLST (* ; "RESETLST to provide reset context for macros under COMPILE1 as generated e.g. by DECL.") (LET ((LCFIL) [LAPFLG (AND PRINTLAP (COND (BYTECOMPFLG T) (T 2] (STRF (NOT NOREDEFINE)) (SVFLG (NOT NOSAVE)) (LSTFIL T) (SPECVARS T) (LOCALVARS (COND ((NEQ LOCALVARS T) (UNION SYSLOCALVARS LOCALVARS)) (T SYSLOCALVARS))) (NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) (LAMA LAMA) (NOFIXFNSLST NOFIXFNSLST) (NOFIXVARSLST NOFIXVARSLST)) (COMPILE1 (COND ((LITATOM X) X) (T '*DUMMY-COMPILED-FUNCTION*)) (COND ((NLISTP X) (VIRGINFN X T)) ((ARGTYPE X) X) (T (LIST 'LAMBDA NIL X))) T]) ) (ADDTOVAR LISPXMACROS (C (COND (LISPXLINE (COMPILE! (CAR LISPXLINE) NIL NIL T)) (T C)))) (ADDTOVAR USERMACROS [C NIL (ORR (UP 1) NIL) (ORR ((E (COMPILE! (OR (LISTP (%##)) (%## !0)) T T T))) ((E 'C?]) (ADDTOVAR EDITCOMSA C) (DEFCOMMAND (C :EVAL) (&REST LISPXLINE) (COND (LISPXLINE (COMPILE! (CAR LISPXLINE) NIL NIL T)) (T C))) (PUTPROPS COMPILEBANG FILETYPE CL:COMPILE-FILE) (PUTPROPS COMPILEBANG COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1986)) (DECLARE%: DONTCOPY (FILEMAP (NIL (622 2567 (COMPILE! 632 . 2565))))) STOP \ No newline at end of file diff --git a/lispusers/COMPILEBANG.TEDIT b/lispusers/COMPILEBANG.TEDIT new file mode 100644 index 00000000..bfa0d841 Binary files /dev/null and b/lispusers/COMPILEBANG.TEDIT differ diff --git a/lispusers/COURIERDEFS b/lispusers/COURIERDEFS new file mode 100644 index 00000000..0cf5ba74 --- /dev/null +++ b/lispusers/COURIERDEFS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jul-88 11:16:07" |{MCS:MCS:STANFORD}COURIERDEFS.;4| 7141 changes to%: (VARS COURIERDEFSCOMS) previous date%: "15-Sep-87 11:22:40" |{MCS:MCS:STANFORD}COURIERDEFS.;3|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University. All rights reserved. ") (PRETTYCOMPRINT COURIERDEFSCOMS) (RPAQQ COURIERDEFSCOMS ((FNS READCOURIERATOM READCOURIERBRUSH READCOURIERFONT WRITECOURIERFONT WRITECOURIERBRUSH READCOURIERNUMBER WRITECOURIERNUMBER READCOURIERPOSITION WRITECOURIERPOSITION READCOURIERTEXTURE WRITECOURIERTEXTURE) (PROP COURIERDEF ATOM BRUSH FONT NUMBER POSITION TEXTURE) (COURIERPROGRAMS INTERLISP))) (DEFINEQ (READCOURIERATOM [LAMBDA (STREAM PROGRAM TYPE) (* cdl "10-Nov-85 17:16") (MKATOM (COURIER.READ.STRING STREAM]) (READCOURIERBRUSH [LAMBDA (STREAM PROGRAM TYPE) (* cdl "21-Nov-85 19:10") (* DECLARATIONS%: (RECORD ITEM  (TYPENAME VALUE))) (with ITEM (COURIER.READ STREAM 'INTERLISP 'LISPBRUSH) (SELECTQ TYPENAME (NIL NIL) ((NUMBERP BRUSH) VALUE) (SHOULDNT]) (READCOURIERFONT [LAMBDA (STREAM PROGRAM TYPE) (* cdl " 5-Dec-85 19:01") (FONTCREATE (COURIER.READ STREAM 'INTERLISP 'FONTRECORD]) (WRITECOURIERFONT [LAMBDA (STREAM FONT PROGRAM TYPE) (* cdl " 6-Feb-86 19:01") (COURIER.WRITE STREAM (COURIER.CREATE (INTERLISP . FONTRECORD) FAMILY _ (FONTPROP FONT 'FAMILY) SIZE _ (FONTPROP FONT 'SIZE) FACE _ (FONTPROP FONT 'FACE) ROTATION _ (FONTPROP FONT 'ROTATION) DEVICE _ (FONTPROP FONT 'DEVICE)) 'INTERLISP 'FONTRECORD]) (WRITECOURIERBRUSH [LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 3-Sep-87 09:54 by cdl") (COURIER.WRITE STREAM (if (NULL ITEM) then '(NIL 0) elseif (NUMBERP ITEM) then (LIST 'NUMBERP ITEM) elseif (LISTP ITEM) then [until [GEQ (LENGTH ITEM) (CONSTANT (LENGTH (RECORDFIELDNAMES 'BRUSH] do (SETQ ITEM (APPEND ITEM '(NIL] (LIST 'BRUSH ITEM) else (SHOULDNT)) 'INTERLISP 'LISPBRUSH]) (READCOURIERNUMBER [LAMBDA (STREAM PROGRAM TYPE) (* cdl "13-Oct-85 12:50") (* DECLARATIONS%: (RECORD ITEM  (TYPENAME VALUE))) (with ITEM (COURIER.READ STREAM 'INTERLISP 'LISPNUMBER) (SELECTQ TYPENAME (NIL NIL) (NUMBERP VALUE) (SHOULDNT]) (WRITECOURIERNUMBER [LAMBDA (STREAM ITEM PROGRAM TYPE) (* cdl "13-Oct-85 13:31") (COURIER.WRITE STREAM (if (NULL ITEM) then '(NIL 0) elseif (NUMBERP ITEM) then (LIST 'NUMBERP ITEM) else (SHOULDNT)) 'INTERLISP 'LISPNUMBER]) (READCOURIERPOSITION [LAMBDA (STREAM PROGRAM TYPE) (* cdl "21-Nov-85 18:47") (create POSITION XCOORD _ (COURIER.READ STREAM PROGRAM 'NUMBER) YCOORD _ (COURIER.READ STREAM PROGRAM 'NUMBER]) (WRITECOURIERPOSITION [LAMBDA (STREAM ITEM PROGRAM TYPE) (* cdl "21-Nov-85 18:46") (with POSITION ITEM (COURIER.WRITE STREAM XCOORD PROGRAM 'NUMBER) (COURIER.WRITE STREAM YCOORD PROGRAM 'NUMBER]) (READCOURIERTEXTURE [LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 15-Sep-87 11:18 by cdl") (LOGOR (LLSH (BIN STREAM) BITSPERBYTE) (BIN STREAM]) (WRITECOURIERTEXTURE [LAMBDA (STREAM SHADE PROGRAM TYPE) (* ; "Edited 15-Sep-87 11:22 by cdl") (SETQ SHADE (SELECTQ SHADE (T BLACKSHADE) (NIL WHITESHADE) (if (NUMBERP SHADE) then SHADE else BLACKSHADE))) (BOUT STREAM (LRSH SHADE BITSPERBYTE)) (BOUT STREAM (LOGAND SHADE (MASK.1'S 0 BITSPERBYTE]) ) (PUTPROPS ATOM COURIERDEF (READCOURIERATOM COURIER.WRITE.STRING)) (PUTPROPS BRUSH COURIERDEF (READCOURIERBRUSH WRITECOURIERBRUSH)) (PUTPROPS FONT COURIERDEF (READCOURIERFONT WRITECOURIERFONT)) (PUTPROPS NUMBER COURIERDEF (READCOURIERNUMBER WRITECOURIERNUMBER)) (PUTPROPS POSITION COURIERDEF (READCOURIERPOSITION WRITECOURIERPOSITION)) (PUTPROPS TEXTURE COURIERDEF (READCOURIERTEXTURE WRITECOURIERTEXTURE)) (COURIERPROGRAM INTERLISP (1100 0) TYPES [(REGION (SEQUENCE INTEGER)) (FONTRECORD (RECORD (FAMILY ATOM) (SIZE CARDINAL) (FACE FONTFACE) (ROTATION NUMBER) (DEVICE ATOM))) [FONTFACE (RECORD (WEIGHT (ENUMERATION (LIGHT 0) (MEDIUM 1) (BOLD 2))) (SLOPE (ENUMERATION (REGULAR 0) (ITALIC 1))) (EXPANSION (ENUMERATION (REGULAR 0) (COMPRESSED 1) (EXPANDED 2] (OPERATION (ENUMERATION (NIL 0) (REPLACE 1) (PAINT 2) (INVERT 3) (ERASE 4))) (LISPNUMBER (CHOICE (NIL 0 UNSPECIFIED) (NUMBERP 1 INTEGER))) (LISPBRUSH (CHOICE (NIL 0 UNSPECIFIED) (NUMBERP 1 CARDINAL) (BRUSH 2 (RECORD (BRUSHSHAPE ATOM) (BRUSHSIZE NUMBER) (BRUSHCOLOR NUMBER] PROCEDURES NIL ERRORS NIL) (PUTPROPS COURIERDEFS COPYRIGHT ("Xerox Corporation & Stanford University" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (920 5241 (READCOURIERATOM 930 . 1083) (READCOURIERBRUSH 1085 . 1579) (READCOURIERFONT 1581 . 1754) (WRITECOURIERFONT 1756 . 2309) (WRITECOURIERBRUSH 2311 . 3168) (READCOURIERNUMBER 3170 . 3637) (WRITECOURIERNUMBER 3639 . 4057) (READCOURIERPOSITION 4059 . 4316) (WRITECOURIERPOSITION 4318 . 4566) (READCOURIERTEXTURE 4568 . 4779) (WRITECOURIERTEXTURE 4781 . 5239))))) STOP \ No newline at end of file diff --git a/lispusers/COURIERDEFS.TEDIT b/lispusers/COURIERDEFS.TEDIT new file mode 100644 index 00000000..2e564fe4 Binary files /dev/null and b/lispusers/COURIERDEFS.TEDIT differ diff --git a/lispusers/COURIEREVALSERVE b/lispusers/COURIEREVALSERVE new file mode 100644 index 00000000..d271ebf6 --- /dev/null +++ b/lispusers/COURIEREVALSERVE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Jul-88 11:44:33" |{MCS:MCS:STANFORD}COURIEREVALSERVE.;6| 9135 changes to%: (VARS COURIEREVALSERVECOMS) previous date%: "17-Sep-87 13:47:38" |{MCS:MCS:STANFORD}COURIEREVALSERVE.;5|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University. All rights reserved. ") (PRETTYCOMPRINT COURIEREVALSERVECOMS) (RPAQQ COURIEREVALSERVECOMS ((* Client Routines) (FNS REMOTEEVAL REMOTEAPPLY) (* Server Routines) (FNS CES.REMOTEEVAL CES.REMOTEAPPLY CES.ERRORN) (COURIERPROGRAMS EVAL) (FILES COURIERSERVE) (P (COURIER.START.SERVER)))) (* Client Routines) (DEFINEQ (REMOTEEVAL [LAMBDA (FORM COURIERSTREAM NOERRORFLG) (* ; "Edited 17-Sep-87 13:12 by cdl") (* DECLARATIONS%: (RECORD RESULT  (REJECTTYPE ERRORTYPE ERRORSTRING))) (LET (STRING STREAM RESULT) (DECLARE (SPECVARS STREAM STRING)) (if [LISTP (SETQ STRING (COURIER.CALL COURIERSTREAM 'EVAL 'EVAL (MKSTRING FORM T) 'RETURNERRORS] then [with RESULT STRING (if ERRORSTRING then [if (ZEROP (COURIER.FETCH (EVAL . ERRORN) NUMBER OF ERRORSTRING)) then (OR NOERRORFLG (ERROR "Remote evaluation error!" FORM)) else (OR NOERRORFLG (ERROR (ERRORMESS ERRORSTRING] else (OR NOERRORFLG (ERROR REJECTTYPE ERRORTYPE] elseif [SETQ RESULT (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTRINGSTREAM STRING 'INPUT] (NLSETQ (READ STREAM)))] then (CAR RESULT) else (OR NOERRORFLG (ERROR "Unreadable remote evaluation result!" STRING]) (REMOTEAPPLY [LAMBDA (FN ARGS COURIERSTREAM NOERRORFLG) (* ; "Edited 17-Sep-87 13:14 by cdl") (* DECLARATIONS%: (RECORD RESULT  (REJECTTYPE ERRORTYPE ERRORSTRING))) (LET (STRING STREAM RESULT) (DECLARE (SPECVARS STRING STREAM)) (if [LISTP (SETQ STRING (COURIER.CALL COURIERSTREAM 'EVAL 'APPLY (MKSTRING FN T) (for ARG in ARGS collect (MKSTRING ARG T)) 'RETURNERRORS] then [with RESULT STRING (if ERRORSTRING then [if (ZEROP (COURIER.FETCH (EVAL . ERRORN) NUMBER OF ERRORSTRING)) then (OR NOERRORFLG (ERROR "Remote apply error!" (CONS FN ARGS))) else (OR NOERRORFLG (ERROR (ERRORMESS ERRORSTRING] else (OR NOERRORFLG (ERROR REJECTTYPE ERRORTYPE] else (if [SETQ RESULT (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTRINGSTREAM STRING 'INPUT] (NLSETQ (READ STREAM)))] then (CAR RESULT) else (OR NOERRORFLG (ERROR "Unreadable remote apply result!" STRING]) ) (* Server Routines) (DEFINEQ (CES.REMOTEEVAL [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE STRING) (* ; "Edited 17-Sep-87 10:14 by cdl") (LET (STREAM SEXPR) (DECLARE (SPECVARS STREAM SEXPR)) (if [SETQ SEXPR (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTRINGSTREAM STRING 'INPUT] (NLSETQ (READ STREAM)))] then (SETQ SEXPR (CAR SEXPR)) [if (SETQ SEXPR (ERRORSET SEXPR)) then `(RETURN ,(MKSTRING (CAR SEXPR) T)) else `(ABORT REMOTE.EVAL.ERROR ,(CES.ERRORN] else `(ABORT REMOTE.READ.ERROR ,(CES.ERRORN]) (CES.REMOTEAPPLY [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE FN ARGS) (* ; "Edited 17-Sep-87 11:12 by cdl") (DECLARE (SPECVARS FN ARGS)) (LET (ERROR SEXPR STREAM) (DECLARE (SPECVARS STREAM)) [SETQ ARGS (for ARG in ARGS declare%: (SPECVARS ARG) collect [SETQ SEXPR (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTRINGSTREAM ARG 'INPUT] (NLSETQ (READ STREAM)))] (if SEXPR then (CAR SEXPR) else (SETQ ERROR 'REMOTE.READ.ERROR) (RETURN] (if ERROR then `(ABORT ,ERROR ,(CES.ERRORN)) else (if [SETQ FN (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTRINGSTREAM FN 'INPUT] (NLSETQ (READ STREAM)))] then (SETQ FN (CAR FN)) [if (SETQ SEXPR (NLSETQ (APPLY FN ARGS))) then `(RETURN ,(MKSTRING (CAR SEXPR) T)) else `(ABORT REMOTE.APPLY.ERROR ,(CES.ERRORN] else `(ABORT REMOTE.READ.ERROR ,(CES.ERRORN]) (CES.ERRORN [LAMBDA NIL (* ; "Edited 17-Sep-87 13:41 by cdl") (* Minimal functionality, just for  backward compatibility) (COURIER.CREATE (EVAL . ERRORN) NUMBER _ (CONSTANT (ZERO)) EXPR _ (CONSTANT null]) ) (COURIERPROGRAM EVAL (1105 0) TYPES [(SEXPR STRING) (FN STRING) (ARGS (SEQUENCE SEXPR)) (ERRORN (RECORD (NUMBER CARDINAL) (EXPR SEXPR] PROCEDURES ((EVAL 0 (SEXPR) RETURNS (SEXPR) REPORTS (REMOTE.EVAL.ERROR REMOTE.READ.ERROR) IMPLEMENTEDBY CES.REMOTEEVAL) (APPLY 1 (FN ARGS) RETURNS (SEXPR) REPORTS (REMOTE.APPLY.ERROR REMOTE.READ.ERROR) IMPLEMENTEDBY CES.REMOTEAPPLY)) ERRORS ((REMOTE.EVAL.ERROR 0 (ERRORN)) (REMOTE.APPLY.ERROR 1 (ERRORN)) (REMOTE.READ.ERROR 2 (ERRORN)))) (FILESLOAD COURIERSERVE) (COURIER.START.SERVER) (PUTPROPS COURIEREVALSERVE COPYRIGHT ("Xerox Corporation & Stanford University" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (899 5041 (REMOTEEVAL 909 . 3155) (REMOTEAPPLY 3157 . 5039)) (5070 8241 (CES.REMOTEEVAL 5080 . 5981) (CES.REMOTEAPPLY 5983 . 7822) (CES.ERRORN 7824 . 8239))))) STOP \ No newline at end of file diff --git a/lispusers/COURIEREVALSERVE.TEDIT b/lispusers/COURIEREVALSERVE.TEDIT new file mode 100644 index 00000000..45037576 Binary files /dev/null and b/lispusers/COURIEREVALSERVE.TEDIT differ diff --git a/lispusers/COURIERIMAGESTREAM b/lispusers/COURIERIMAGESTREAM new file mode 100644 index 00000000..b3ab16e0 --- /dev/null +++ b/lispusers/COURIERIMAGESTREAM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jul-88 10:15:36" |{MCS:MCS:STANFORD}COURIERIMAGESTREAM.;7| 49756 changes to%: (VARS COURIERIMAGESTREAMCOMS) (FNS \BITBLT.COURIER \SCALEDBITBLT.COURIER \COURIER.OPENIMAGESTREAM) previous date%: "16-Sep-87 17:41:23" |{MCS:MCS:STANFORD}COURIERIMAGESTREAM.;5|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University. All rights reserved. ") (PRETTYCOMPRINT COURIERIMAGESTREAMCOMS) (RPAQQ COURIERIMAGESTREAMCOMS ((* * ImageOp Functions) (FNS \BACKCOLOR.COURIER \BITBLT.COURIER \BLTSHADE.COURIER \BOTTOMMARGIN.COURIER \CHARSET.COURIER \CHARWIDTH.COURIER \CHARWIDTHY.COURIER \CLIPPINGREGION.COURIER \CLOSEFN.COURIER \COLOR.COURIER \COURIERIMAGESTREAM.BOUT \DEFAULTSTATE.COURIER \DRAWARC.COURIER \DRAWCIRCLE.COURIER \DRAWCURVE.COURIER \DRAWELLIPSE.COURIER \DRAWLINE.COURIER \DRAWPOINT.COURIER \DRAWPOLYGON.COURIER \FILLCIRCLE.COURIER \FILLPOLYGON.COURIER \FONT.COURIER \LEFTMARGIN.COURIER \LINEFEED.COURIER \MOVETO.COURIER \NEWPAGE.COURIER \OPENIMAGESTREAM.COURIER \OPERATION.COURIER \POPSTATE.COURIER \PUSHSTATE.COURIER \RESET.COURIER \RIGHTMARGIN.COURIER \ROTATE.COURIER \SCALE.COURIER \SCALEDBITBLT.COURIER \SCALE2.COURIER \SPACEFACTOR.COURIER \STRINGWIDTH.COURIER \TERPRI.COURIER \TOPMARGIN.COURIER \TRANSLATE.COURIER \XPOSITION.COURIER \YPOSITION.COURIER \OUTCHAR.COURIER) (* * Courier Server Functions) (FNS \COURIER.BACKCOLOR \COURIER.BITBLT \COURIER.BLTSHADE \COURIER.BOTTOMMARGIN \COURIER.CHARSET \COURIER.CHARWIDTH \COURIER.CHARWIDTHY \COURIER.CLIPPINGREGION \COURIER.CLOSEIMAGESTREAM \COURIER.COLOR \COURIER.DEFAULTSTATE \COURIER.DRAWARC \COURIER.DRAWCIRCLE \COURIER.DRAWCURVE \COURIER.DRAWELLIPSE \COURIER.DRAWLINE \COURIER.DRAWPOINT \COURIER.DRAWPOLYGON \COURIER.FILLCIRCLE \COURIER.FILLPOLYGON \COURIER.FONT \COURIER.FONTTYPE \COURIER.LEFTMARGIN \COURIER.LINEFEED \COURIER.MOVETO \COURIER.NEWPAGE \COURIER.OPERATION \COURIER.OPENIMAGESTREAM \COURIER.OUTCHAR \COURIER.POPSTATE \COURIER.PUSHSTATE \COURIER.RESET \COURIER.RIGHTMARGIN \COURIER.ROTATE \COURIER.SCALE \COURIER.SCALEDBITBLT \COURIER.SCALE2 \COURIER.SPACEFACTOR \COURIER.STRINGWIDTH \COURIER.TERPRI \COURIER.TOPMARGIN \COURIER.TRANSLATE \COURIER.XPOSITION \COURIER.YPOSITION) (* * etc.) (FNS \INITCOURIERIMAGESTREAM READSTREAMHANDLE WRITESTREAMHANDLE) (INITVARS \COURIERIMAGEOPS \NULLFDEV IMAGESTREAMALST) (PROP COURIERDEF STREAMHANDLE) (GLOBALVARS \COURIERIMAGEOPS \NULLFDEV IMAGESTREAMALST) (DECLARE%: DONTCOPY (RECORDS COURIERIMAGEDATA)) [ADDVARS (IMAGESTREAMTYPES (COURIER (OPENSTREAM \OPENIMAGESTREAM.COURIER] (FILES BITMAPFNS COURIERDEFS COURIERSERVE) (COURIERPROGRAMS IMAGESTREAM OLDIMAGESTREAM) (P (\INITCOURIERIMAGESTREAM) (COURIER.START.SERVER)))) (* * ImageOp Functions) (DEFINEQ (\BACKCOLOR.COURIER [LAMBDA (STREAM COLOR) (* cdl "10-Oct-85 20:56") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'BACKCOLOR CIS.IMAGESTREAM COLOR]) (\BITBLT.COURIER [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* ; "Edited 20-Jul-88 09:09 by cdl") (PROG (BULK.DATA.STREAM (BITMAP (BITMAPCREATE WIDTH HEIGHT))) (DECLARE (SPECVARS BULK.DATA.STREAM)) (BITBLT SOURCE SOURCELEFT SOURCEBOTTOM BITMAP) (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (SETQ BULK.DATA.STREAM (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'BITBLT CIS.IMAGESTREAM NIL DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)) (RESETLST [RESETSAVE NIL `(CLOSEF? ,BULK.DATA.STREAM] (WRITEBINARYBITMAP BITMAP BULK.DATA.STREAM))]) (\BLTSHADE.COURIER [LAMBDA (TEXTURE STREAM LEFT BOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* cdl "30-Oct-85 20:59") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'BLTSHADE (SELECTQ TEXTURE (NIL WHITESHADE) (T BLACKSHADE) TEXTURE) CIS.IMAGESTREAM LEFT BOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION]) (\BOTTOMMARGIN.COURIER [LAMBDA (STREAM YPOSITION) (* cdl "10-Oct-85 20:33") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'BOTTOMMARGIN CIS.IMAGESTREAM YPOSITION]) (\CHARSET.COURIER [LAMBDA (STREAM CHARACTERSET) (* cdl " 7-Nov-85 20:01") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'CHARSET CIS.IMAGESTREAM CHARACTERSET]) (\CHARWIDTH.COURIER [LAMBDA (STREAM CHARCODE) (* cdl "26-Nov-85 17:33") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (if CIS.LOCALFONTS? then (CHARWIDTH CHARCODE CIS.FONT) else (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'CHARWIDTH CIS.IMAGESTREAM CHARCODE]) (\CHARWIDTHY.COURIER [LAMBDA (STREAM CHARCODE) (* cdl "26-Nov-85 17:55") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (if CIS.LOCALFONTS? then (CHARWIDTHY CHARCODE CIS.FONT) else (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'CHARWIDTHY CIS.IMAGESTREAM CHARCODE]) (\CLIPPINGREGION.COURIER [LAMBDA (STREAM REGION) (* cdl "10-Oct-85 20:50") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'CLIPPINGREGION CIS.IMAGESTREAM REGION]) (\CLOSEFN.COURIER [LAMBDA (STREAM) (* cdl "10-Oct-85 19:01") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'CLOSE CIS.IMAGESTREAM]) (\COLOR.COURIER [LAMBDA (STREAM COLOR) (* cdl "10-Oct-85 19:08") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'COLOR CIS.IMAGESTREAM COLOR]) (\COURIERIMAGESTREAM.BOUT [LAMBDA (STREAM BYTE) (* cdl "26-Nov-85 16:50") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'OUTCHAR CIS.IMAGESTREAM BYTE]) (\DEFAULTSTATE.COURIER [LAMBDA (STREAM) (* ; "Edited 3-Sep-87 09:01 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DEFAULTSTATE CIS.IMAGESTREAM]) (\DRAWARC.COURIER [LAMBDA (STREAM CENTERX CENTERY RADIUS ANGLE DEGREES BRUSH DASHING) (* ; "Edited 3-Sep-87 08:47 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWARC CIS.IMAGESTREAM CENTERX CENTERY RADIUS ANGLE DEGREES BRUSH DASHING]) (\DRAWCIRCLE.COURIER [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* cdl "10-Oct-85 18:28") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWCIRCLE CIS.IMAGESTREAM CENTERX CENTERY RADIUS BRUSH DASHING]) (\DRAWCURVE.COURIER [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* cdl "21-Nov-85 18:51") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWCURVE CIS.IMAGESTREAM KNOTS CLOSED BRUSH DASHING]) (\DRAWELLIPSE.COURIER [LAMBDA (STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* cdl "10-Oct-85 20:23") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWELLIPSE CIS.IMAGESTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING]) (\DRAWLINE.COURIER [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* cdl "10-Nov-85 17:56") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWLINE CIS.IMAGESTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING]) (\DRAWPOINT.COURIER [LAMBDA (STREAM X Y BRUSH OPERATION) (* ; "Edited 3-Sep-87 09:20 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWPOINT CIS.IMAGESTREAM X Y BRUSH OPERATION]) (\DRAWPOLYGON.COURIER [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* cdl "21-Nov-85 18:52") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'DRAWPOLYGON CIS.IMAGESTREAM POINTS CLOSED BRUSH DASHING]) (\FILLCIRCLE.COURIER [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* cdl "10-Oct-85 19:11") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'FILLCIRCLE CIS.IMAGESTREAM CENTERX CENTERY RADIUS TEXTURE]) (\FILLPOLYGON.COURIER [LAMBDA (STREAM POINTS TEXTURE) (* cdl "26-Nov-85 16:25") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'FILLPOLYGON CIS.IMAGESTREAM POINTS TEXTURE]) (\FONT.COURIER [LAMBDA (STREAM FONT) (* cdl " 5-Dec-85 19:15") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (PROG1 CIS.FONT (if (AND FONT (NEQ FONT CIS.FONT)) then (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'FONT CIS.IMAGESTREAM FONT) (SETQ CIS.FONT FONT)))]) (\LEFTMARGIN.COURIER [LAMBDA (STREAM XPOSITION) (* cdl "10-Oct-85 19:42") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'LEFTMARGIN CIS.IMAGESTREAM XPOSITION]) (\LINEFEED.COURIER [LAMBDA (STREAM DELTAY) (* cdl "10-Oct-85 19:54") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'LINEFEED CIS.IMAGESTREAM DELTAY]) (\MOVETO.COURIER [LAMBDA (STREAM X Y) (* cdl "10-Oct-85 19:14") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'MOVETO CIS.IMAGESTREAM X Y]) (\NEWPAGE.COURIER [LAMBDA (STREAM) (* cdl "10-Oct-85 20:29") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'NEWPAGE CIS.IMAGESTREAM]) (\OPENIMAGESTREAM.COURIER [LAMBDA (COURIERSTREAM OPTIONS) (* ; "Edited 3-Sep-87 09:29 by cdl") (* DECLARATIONS%: (RECORD PAIR  (KEY VALUE))) (LET (FILE TYPE IMAGESTREAM IMAGEOPS STREAM) (DECLARE (GLOBALVARS DEFAULTFONT)) [if (NULL \NULLFDEV) then (SETQ \NULLFDEV (create FDEV CLOSEFILE _ (FUNCTION NILL] [SETQ OPTIONS (for PAIR on OPTIONS by (CDDR PAIR) when (with PAIR PAIR (SELECTQ KEY (FILE (SETQ FILE VALUE) NIL) (TYPE (SETQ TYPE VALUE) NIL) T)) join (with PAIR PAIR (LIST KEY VALUE] (if (NULL TYPE) then (SETQ TYPE 'DISPLAY)) (SETQ IMAGESTREAM (COURIER.CALL COURIERSTREAM 'IMAGESTREAM 'OPEN FILE TYPE (MKSTRING OPTIONS T))) (SETQ IMAGEOPS (create IMAGEOPS IMFONTCREATE _ (COURIER.CALL COURIERSTREAM 'IMAGESTREAM 'FONTTYPE IMAGESTREAM) reusing \COURIERIMAGEOPS)) (SETQ STREAM (create STREAM IMAGEDATA _ (create COURIERIMAGEDATA CIS.COURIERSTREAM _ COURIERSTREAM CIS.IMAGESTREAM _ IMAGESTREAM CIS.FONT _ (FONTCLASSCOMPONENT DEFAULTFONT (with IMAGEOPS IMAGEOPS IMFONTCREATE))) IMAGEOPS _ IMAGEOPS OUTCHARFN _ (FUNCTION \OUTCHAR.COURIER) ACCESS _ 'OUTPUT DEVICE _ \NULLFDEV)) (with STREAM STREAM (SETQ STRMBOUTFN (FUNCTION \COURIERIMAGESTREAM.BOUT))) STREAM]) (\OPERATION.COURIER [LAMBDA (STREAM OPERATION) (* cdl "10-Oct-85 20:41") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'OPERATION CIS.IMAGESTREAM OPERATION]) (\POPSTATE.COURIER [LAMBDA (STREAM) (* ; "Edited 3-Sep-87 08:59 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'POPSTATE CIS.IMAGESTREAM]) (\PUSHSTATE.COURIER [LAMBDA (STREAM) (* ; "Edited 3-Sep-87 08:58 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'PUSHSTATE CIS.IMAGESTREAM]) (\RESET.COURIER [LAMBDA (STREAM) (* cdl "26-Nov-85 16:42") (with STREAM STREAM (SETQ CHARPOSITION 0) (with COURIERIMAGEDATA IMAGEDATA (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'RESET CIS.IMAGESTREAM]) (\RIGHTMARGIN.COURIER [LAMBDA (STREAM XPOSITION) (* cdl "10-Oct-85 19:42") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'RIGHTMARGIN CIS.IMAGESTREAM XPOSITION]) (\ROTATE.COURIER [LAMBDA (STREAM ROTATION) (* ; "Edited 3-Sep-87 08:40 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'ROTATE CIS.IMAGESTREAM ROTATION]) (\SCALE.COURIER [LAMBDA (STREAM SCALE) (* cdl "10-Oct-85 18:47") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'SCALE CIS.IMAGESTREAM SCALE]) (\SCALEDBITBLT.COURIER [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE) (* ; "Edited 20-Jul-88 09:22 by cdl") (PROG (BULK.DATA.STREAM BITMAP) (DECLARE (SPECVARS BULK.DATA.STREAM)) (if (NULL WIDTH) then (SETQ WIDTH (BITMAPWIDTH SOURCE))) (if (NULL HEIGHT) then (SETQ HEIGHT (BITMAPHEIGHT SOURCE))) (BITBLT SOURCE SOURCELEFT SOURCEBOTTOM (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT))) (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (SETQ BULK.DATA.STREAM (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'SCALEDBITBLT CIS.IMAGESTREAM NIL DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SCALE)) (RESETLST [RESETSAVE NIL `(CLOSEF? ,BULK.DATA.STREAM] (WRITEBINARYBITMAP BITMAP BULK.DATA.STREAM))]) (\SCALE2.COURIER [LAMBDA (STREAM X Y) (* ; "Edited 3-Sep-87 08:54 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'SCALE2 CIS.IMAGESTREAM X Y]) (\SPACEFACTOR.COURIER [LAMBDA (STREAM FACTOR) (* cdl "10-Oct-85 20:43") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'SPACEFACTOR CIS.IMAGESTREAM FACTOR]) (\STRINGWIDTH.COURIER [LAMBDA (STREAM STRING RDTBL) (* cdl "26-Nov-85 17:32") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (if CIS.LOCALFONTS? then (STRINGWIDTH STRING CIS.FONT) else (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'STRINGWIDTH CIS.IMAGESTREAM STRING]) (\TERPRI.COURIER [LAMBDA (STREAM) (* cdl "26-Nov-85 16:35") (with STREAM STREAM (SETQ CHARPOSITION 0) (with COURIERIMAGEDATA IMAGEDATA (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'TERPRI CIS.IMAGESTREAM]) (\TOPMARGIN.COURIER [LAMBDA (STREAM YPOSITION) (* cdl "10-Oct-85 20:32") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'TOPMARGIN CIS.IMAGESTREAM YPOSITION]) (\TRANSLATE.COURIER [LAMBDA (STREAM X Y) (* ; "Edited 3-Sep-87 08:52 by cdl") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'TRANSLATE CIS.IMAGESTREAM X Y]) (\XPOSITION.COURIER [LAMBDA (STREAM XPOSITION) (* cdl "10-Oct-85 18:43") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'XPOSITION CIS.IMAGESTREAM XPOSITION]) (\YPOSITION.COURIER [LAMBDA (STREAM YPOSITION) (* cdl "10-Oct-85 18:45") (with COURIERIMAGEDATA (with STREAM STREAM IMAGEDATA) (COURIER.CALL CIS.COURIERSTREAM 'IMAGESTREAM 'YPOSITION CIS.IMAGESTREAM YPOSITION]) (\OUTCHAR.COURIER [LAMBDA (STREAM CHARCODE) (* cdl " 3-Dec-85 17:47") [if (EQ CHARCODE (CHARCODE EOL)) then (with STREAM STREAM (SETQ CHARPOSITION 0)) else (freplace CHARPOSITION of STREAM with (PROGN (* Ugh. Don't overflow) (\LOLOC (\ADDBASE (ffetch CHARPOSITION of STREAM) 1] (BOUT STREAM CHARCODE]) ) (* * Courier Server Functions) (DEFINEQ (\COURIER.BACKCOLOR [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM COLOR) (* ; "Edited 24-Mar-87 20:52 by cdl") `(RETURN ,(IMAGEOP 'IMBACKCOLOR IMAGESTREAM IMAGESTREAM COLOR]) (\COURIER.BITBLT [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM BULK.DATA.STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* ; "Edited 24-Mar-87 20:52 by cdl") (BITBLT (READBINARYBITMAP WIDTH HEIGHT BULK.DATA.STREAM) NIL NIL IMAGESTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) '(RETURN]) (\COURIER.BLTSHADE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE TEXTURE IMAGESTREAM LEFT BOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* cdl "10-Nov-85 16:36") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMBLTSHADE IMAGESTREAM TEXTURE IMAGESTREAM LEFT BOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) NIL]) (\COURIER.BOTTOMMARGIN [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM YPOSITION) (* ; "Edited 24-Mar-87 20:54 by cdl") `(RETURN ,(IMAGEOP 'IMBOTTOMMARGIN IMAGESTREAM IMAGESTREAM YPOSITION]) (\COURIER.CHARSET [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CHARACTERSET) (* ; "Edited 24-Mar-87 20:54 by cdl") `(RETURN ,(IMAGEOP 'IMCHARSET IMAGESTREAM IMAGESTREAM CHARACTERSET]) (\COURIER.CHARWIDTH [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CHARCODE) (* ; "Edited 24-Mar-87 20:55 by cdl") `(RETURN ,(IMAGEOP 'IMCHARWIDTH IMAGESTREAM IMAGESTREAM CHARCODE]) (\COURIER.CHARWIDTHY [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CHARCODE) (* ; "Edited 24-Mar-87 20:55 by cdl") `(RETURN ,(IMAGEOP 'IMCHARWIDTHY IMAGESTREAM IMAGESTREAM CHARCODE]) (\COURIER.CLIPPINGREGION [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM REGION) (* ; "Edited 24-Mar-87 20:56 by cdl") `(RETURN ,(IMAGEOP 'IMCLIPPINGREGION IMAGESTREAM IMAGESTREAM REGION]) (\COURIER.CLOSEIMAGESTREAM [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE HANDLE) (* ; "Edited 24-Mar-87 20:56 by cdl") (* DECLARATIONS%: (RECORD PAIR  (KEY . VALUE))) [LET ((PAIR (ASSOC HANDLE IMAGESTREAMALST))) (SETQ IMAGESTREAMALST (DREMOVE PAIR IMAGESTREAMALST)) (with PAIR PAIR (if (IMAGESTREAMTYPEP VALUE 'DISPLAY) then (CLOSEW VALUE) else (CLOSEF? VALUE] '(RETURN]) (\COURIER.COLOR [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM COLOR) (* ; "Edited 24-Mar-87 20:50 by cdl") `(RETURN ,(IMAGEOP 'IMCOLOR IMAGESTREAM IMAGESTREAM COLOR]) (\COURIER.DEFAULTSTATE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* ; "Edited 3-Sep-87 09:00 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDEFAULTSTATE IMAGESTREAM IMAGESTREAM) NIL]) (\COURIER.DRAWARC [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y RADIUS ANGLE DEGREES BRUSH DASHING) (* ; "Edited 3-Sep-87 08:46 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWARC IMAGESTREAM IMAGESTREAM X Y RADIUS ANGLE DEGREES BRUSH DASHING) NIL]) (\COURIER.DRAWCIRCLE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y RADIUS BRUSH DASHING) (* cdl "10-Nov-85 16:40") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWCIRCLE IMAGESTREAM IMAGESTREAM X Y RADIUS BRUSH DASHING) NIL]) (\COURIER.DRAWCURVE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM KNOTS CLOSED BRUSH DASHING) (* cdl "21-Nov-85 19:14") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWCURVE IMAGESTREAM IMAGESTREAM KNOTS CLOSED BRUSH DASHING) NIL]) (\COURIER.DRAWELLIPSE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* cdl "10-Nov-85 16:42") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWELLIPSE IMAGESTREAM IMAGESTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) NIL]) (\COURIER.DRAWLINE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y X2 Y2 WIDTH OPERATION COLOR DASHING) (* cdl "10-Nov-85 17:58") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWLINE IMAGESTREAM IMAGESTREAM X Y X2 Y2 WIDTH OPERATION COLOR DASHING) NIL]) (\COURIER.DRAWPOINT [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y BRUSH OPERATION) (* ; "Edited 3-Sep-87 09:04 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWPOINT IMAGESTREAM IMAGESTREAM X Y BRUSH OPERATION) NIL]) (\COURIER.DRAWPOLYGON [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM POINTS CLOSED BRUSH DASHING) (* cdl "21-Nov-85 20:20") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMDRAWPOLYGON IMAGESTREAM IMAGESTREAM POINTS CLOSED BRUSH DASHING) NIL]) (\COURIER.FILLCIRCLE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y RADIUS TEXTURE) (* cdl "10-Nov-85 16:43") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMFILLCIRCLE IMAGESTREAM IMAGESTREAM X Y RADIUS TEXTURE) NIL]) (\COURIER.FILLPOLYGON [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM POINTS TEXTURE) (* cdl "26-Nov-85 16:25") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMFILLPOLYGON IMAGESTREAM IMAGESTREAM POINTS TEXTURE) NIL]) (\COURIER.FONT [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM FONT) (* ; "Edited 24-Mar-87 20:58 by cdl") `(RETURN ,(IMAGEOP 'IMFONT IMAGESTREAM IMAGESTREAM FONT]) (\COURIER.FONTTYPE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* ; "Edited 24-Mar-87 20:58 by cdl") `(RETURN ,(with IMAGEOPS (with STREAM IMAGESTREAM IMAGEOPS) IMFONTCREATE]) (\COURIER.LEFTMARGIN [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM XPOSITION) (* ; "Edited 24-Mar-87 20:59 by cdl") `(RETURN ,(IMAGEOP 'IMLEFTMARGIN IMAGESTREAM IMAGESTREAM XPOSITION]) (\COURIER.LINEFEED [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM DELTAY) (* ; "Edited 24-Mar-87 20:59 by cdl") `(RETURN ,(IMAGEOP 'IMLINEFEED IMAGESTREAM IMAGESTREAM DELTAY]) (\COURIER.MOVETO [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y) (* cdl "10-Nov-85 16:46") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMMOVETO IMAGESTREAM IMAGESTREAM X Y) NIL]) (\COURIER.NEWPAGE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* cdl "10-Nov-85 16:47") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMNEWPAGE IMAGESTREAM IMAGESTREAM) NIL]) (\COURIER.OPERATION [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM OPERATION) (* ; "Edited 24-Mar-87 20:59 by cdl") `(RETURN ,(IMAGEOP 'IMOPERATION IMAGESTREAM IMAGESTREAM OPERATION]) (\COURIER.OPENIMAGESTREAM [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE FILE IMAGETYPE OPTIONS) (* ; "Edited 20-Jul-88 09:00 by cdl") (DECLARE (SPECVARS OPTIONS)) (LET (STREAM HANDLE) (DECLARE (SPECVARS STREAM)) [SETQ OPTIONS (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTRINGSTREAM OPTIONS 'INPUT] (CAR (NLSETQ (READ STREAM))))] (SETQ HANDLE (if IMAGESTREAMALST then (ADD1 (in IMAGESTREAMALST maximize CAR)) else (ZERO))) (push IMAGESTREAMALST (CONS HANDLE (OPENIMAGESTREAM FILE IMAGETYPE OPTIONS))) `(RETURN ,HANDLE]) (\COURIER.OUTCHAR [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CHARCODE) (* cdl " 7-Nov-85 18:49") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (\OUTCHAR IMAGESTREAM CHARCODE) NIL]) (\COURIER.POPSTATE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* ; "Edited 3-Sep-87 08:58 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMPOPSTATE IMAGESTREAM IMAGESTREAM) NIL]) (\COURIER.PUSHSTATE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* ; "Edited 3-Sep-87 08:57 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMPUSHSTATE IMAGESTREAM IMAGESTREAM) NIL]) (\COURIER.RESET [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* cdl "10-Nov-85 16:48") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMRESET IMAGESTREAM IMAGESTREAM) NIL]) (\COURIER.RIGHTMARGIN [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM XPOSITION) (* ; "Edited 24-Mar-87 21:00 by cdl") `(RETURN ,(IMAGEOP 'IMRIGHTMARGIN IMAGESTREAM IMAGESTREAM XPOSITION]) (\COURIER.ROTATE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM COLOR ROTATION) (* ; "Edited 3-Sep-87 08:38 by cdl") `(RETURN ,(IMAGEOP 'IMROTATE IMAGESTREAM IMAGESTREAM ROTATION]) (\COURIER.SCALE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM SCALE) (* ; "Edited 24-Mar-87 21:00 by cdl") `(RETURN ,(IMAGEOP 'IMSCALE IMAGESTREAM IMAGESTREAM SCALE]) (\COURIER.SCALEDBITBLT [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM BULK.DATA.STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SCALE) (* cdl "13-Nov-85 19:46") (SCALEDBITBLT (READBINARYBITMAP WIDTH HEIGHT BULK.DATA.STREAM) NIL NIL IMAGESTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SCALE) '(RETURN]) (\COURIER.SCALE2 [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y) (* ; "Edited 3-Sep-87 08:53 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMSCALE2 IMAGESTREAM IMAGESTREAM X Y) NIL]) (\COURIER.SPACEFACTOR [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM FACTOR) (* ; "Edited 24-Mar-87 21:01 by cdl") `(RETURN ,(IMAGEOP 'IMSPACEFACTOR IMAGESTREAM IMAGESTREAM FACTOR]) (\COURIER.STRINGWIDTH [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM STRING) (* ; "Edited 24-Mar-87 21:01 by cdl") `(RETURN ,(IMAGEOP 'IMSTRINGWIDTH IMAGESTREAM IMAGESTREAM STRING]) (\COURIER.TERPRI [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM) (* cdl "10-Nov-85 16:52") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMTERPRI IMAGESTREAM IMAGESTREAM) NIL]) (\COURIER.TOPMARGIN [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM YPOSITION) (* ; "Edited 24-Mar-87 21:02 by cdl") `(RETURN ,(IMAGEOP 'IMTOPMARGIN IMAGESTREAM IMAGESTREAM YPOSITION]) (\COURIER.TRANSLATE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM X Y) (* ; "Edited 3-Sep-87 08:51 by cdl") (COURIER.RETURN COURIERSTREAM PROGRAM PROCEDURE) (IMAGEOP 'IMTRANSLATE IMAGESTREAM IMAGESTREAM X Y) NIL]) (\COURIER.XPOSITION [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM XPOSITION) (* ; "Edited 24-Mar-87 21:02 by cdl") `(RETURN ,(IMAGEOP 'IMXPOSITION IMAGESTREAM IMAGESTREAM XPOSITION]) (\COURIER.YPOSITION [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM YPOSITION) (* ; "Edited 24-Mar-87 21:02 by cdl") `(RETURN ,(IMAGEOP 'IMYPOSITION IMAGESTREAM IMAGESTREAM YPOSITION]) ) (* * etc.) (DEFINEQ (\INITCOURIERIMAGESTREAM [LAMBDA NIL (* ; "Edited 3-Sep-87 09:59 by cdl") (SETQ \COURIERIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'COURIER IMCLOSEFN _ (FUNCTION \CLOSEFN.COURIER) IMXPOSITION _ (FUNCTION \XPOSITION.COURIER) IMYPOSITION _ (FUNCTION \YPOSITION.COURIER) IMFONT _ (FUNCTION \FONT.COURIER) IMLEFTMARGIN _ (FUNCTION \LEFTMARGIN.COURIER) IMRIGHTMARGIN _ (FUNCTION \RIGHTMARGIN.COURIER) IMLINEFEED _ (FUNCTION \LINEFEED.COURIER) IMDRAWLINE _ (FUNCTION \DRAWLINE.COURIER) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.COURIER) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.COURIER) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.COURIER) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.COURIER) IMBITBLT _ (FUNCTION \BITBLT.COURIER) IMBLTSHADE _ (FUNCTION \BLTSHADE.COURIER) IMMOVETO _ (FUNCTION \MOVETO.COURIER) IMSCALE _ (FUNCTION \SCALE.COURIER) IMTERPRI _ (FUNCTION \TERPRI.COURIER) IMFONTCREATE _ 'DISPLAY IMCOLOR _ (FUNCTION \COLOR.COURIER) IMBACKCOLOR _ (FUNCTION \BACKCOLOR.COURIER) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.COURIER) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.COURIER) IMCHARWIDTHY _ (FUNCTION \CHARWIDTHY.COURIER) IMRESET _ (FUNCTION \RESET.COURIER) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.COURIER) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.COURIER) IMTOPMARGIN _ (FUNCTION \TOPMARGIN.COURIER) IMBOTTOMMARGIN _ (FUNCTION \BOTTOMMARGIN.COURIER) IMNEWPAGE _ (FUNCTION \NEWPAGE.COURIER) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.COURIER) IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.COURIER) IMOPERATION _ (FUNCTION \OPERATION.COURIER) IMSPACEFACTOR _ (FUNCTION \SPACEFACTOR.COURIER) IMCHARSET _ (FUNCTION \CHARSET.COURIER) IMROTATE _ (FUNCTION \ROTATE.COURIER) IMDRAWARC _ (FUNCTION \DRAWARC.COURIER) IMTRANSLATE _ (FUNCTION \TRANSLATE.COURIER) IMSCALE2 _ (FUNCTION \SCALE2.COURIER) IMPUSHSTATE _ (FUNCTION \PUSHSTATE.COURIER) IMPOPSTATE _ (FUNCTION \POPSTATE.COURIER) IMDEFAULTSTATE _ (FUNCTION \DEFAULTSTATE.COURIER) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.COURIER]) (READSTREAMHANDLE [LAMBDA (STREAM PROGRAM TYPE) (* cdl "10-Nov-85 17:13") (* DECLARATIONS%: (RECORD ITEM  (TYPENAME VALUE))) (CDR (ASSOC (COURIER.READ STREAM PROGRAM 'UNSPECIFIED) IMAGESTREAMALST]) (WRITESTREAMHANDLE [LAMBDA (STREAM ITEM PROGRAM TYPE) (* cdl "10-Nov-85 17:13") (COURIER.WRITE STREAM ITEM PROGRAM 'UNSPECIFIED]) ) (RPAQ? \COURIERIMAGEOPS NIL) (RPAQ? \NULLFDEV NIL) (RPAQ? IMAGESTREAMALST NIL) (PUTPROPS STREAMHANDLE COURIERDEF (READSTREAMHANDLE WRITESTREAMHANDLE)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \COURIERIMAGEOPS \NULLFDEV IMAGESTREAMALST) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD COURIERIMAGEDATA (CIS.COURIERSTREAM CIS.IMAGESTREAM CIS.FONT CIS.LOCALFONTS?) CIS.LOCALFONTS? _ T) ) ) (ADDTOVAR IMAGESTREAMTYPES (COURIER (OPENSTREAM \OPENIMAGESTREAM.COURIER))) (FILESLOAD BITMAPFNS COURIERDEFS COURIERSERVE) (COURIERPROGRAM IMAGESTREAM (1111 1) TYPES [(X1 INTEGER) (Y1 INTEGER) (X2 INTEGER) (Y2 INTEGER) (ANGLE INTEGER) (RADIUS INTEGER) (SEMIMINORRADIUS INTEGER) (SEMIMAJORRADIUS INTEGER) (X NUMBER) (Y NUMBER) (LEFT NUMBER) (BOTTOM NUMBER) (WIDTH NUMBER) (HEIGHT NUMBER) (SCALE NUMBER) (COLOR NUMBER) (ROTATION NUMBER) (ORIENTATION NUMBER) (CHARACTERSET NUMBER) (CHARACTER CARDINAL) (CLOSED BOOLEAN) (FILE ATOM) (IMAGETYPE ATOM) (OPTIONS STRING) (DASHING (SEQUENCE CARDINAL)) (KNOTS (SEQUENCE POSITION)) (SOURCETYPE (ENUMERATION (NIL 0) (INPUT 1) (INVERT 2) (TEXTURE 3] INHERITS (INTERLISP) PROCEDURES ((OPEN 0 (FILE IMAGETYPE OPTIONS) RETURNS (CARDINAL) REPORTS NIL IMPLEMENTEDBY \COURIER.OPENIMAGESTREAM) (CLOSE 1 (CARDINAL) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.CLOSEIMAGESTREAM) (DRAWLINE 2 (STREAMHANDLE X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWLINE) (DRAWCIRCLE 3 (STREAMHANDLE X1 Y1 RADIUS BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWCIRCLE) (OUTCHAR 4 (STREAMHANDLE CHARACTER) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.OUTCHAR) (DRAWCURVE 5 (STREAMHANDLE KNOTS CLOSED BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWCURVE) (DRAWPOLYGON 6 (STREAMHANDLE KNOTS CLOSED BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWPOLYGON) (SCALE 7 (STREAMHANDLE SCALE) RETURNS (SCALE) REPORTS NIL IMPLEMENTEDBY \COURIER.SCALE) (XPOSITION 8 (STREAMHANDLE X) RETURNS (X) REPORTS NIL IMPLEMENTEDBY \COURIER.XPOSITION) (YPOSITION 9 (STREAMHANDLE Y) RETURNS (Y) REPORTS NIL IMPLEMENTEDBY \COURIER.YPOSITION) (COLOR 10 (STREAMHANDLE COLOR) RETURNS (COLOR) REPORTS NIL IMPLEMENTEDBY \COURIER.COLOR) (FILLCIRCLE 11 (STREAMHANDLE X1 Y1 RADIUS TEXTURE) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.FILLCIRCLE) (MOVETO 12 (STREAMHANDLE X1 Y1) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.MOVETO) (RESET 13 (STREAMHANDLE) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.RESET) (BLTSHADE 14 (TEXTURE STREAMHANDLE LEFT BOTTOM WIDTH HEIGHT OPERATION REGION) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.BLTSHADE) (RIGHTMARGIN 15 (STREAMHANDLE X) RETURNS (X) REPORTS NIL IMPLEMENTEDBY \COURIER.RIGHTMARGIN) (LEFTMARGIN 16 (STREAMHANDLE X) RETURNS (X) REPORTS NIL IMPLEMENTEDBY \COURIER.LEFTMARGIN) (TERPRI 17 (STREAMHANDLE) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.TERPRI) (STRINGWIDTH 18 (STREAMHANDLE STRING) RETURNS (WIDTH) REPORTS NIL IMPLEMENTEDBY \COURIER.STRINGWIDTH) (LINEFEED 19 (STREAMHANDLE Y) RETURNS (Y) REPORTS NIL IMPLEMENTEDBY \COURIER.LINEFEED) (FONT 20 (STREAMHANDLE FONT) RETURNS (FONT) REPORTS NIL IMPLEMENTEDBY \COURIER.FONT) (DRAWELLIPSE 21 (STREAMHANDLE X1 Y1 SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWELLIPSE) (NEWPAGE 22 (STREAMHANDLE) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.NEWPAGE) (TOPMARGIN 23 (STREAMHANDLE Y) RETURNS (Y) REPORTS NIL IMPLEMENTEDBY \COURIER.TOPMARGIN) (BOTTOMMARGIN 24 (STREAMHANDLE Y) RETURNS (Y) REPORTS NIL IMPLEMENTEDBY \COURIER.BOTTOMMARGIN) (SPACEFACTOR 25 (STREAMHANDLE X) RETURNS (WIDTH) REPORTS NIL IMPLEMENTEDBY \COURIER.SPACEFACTOR) (OPERATION 26 (STREAMHANDLE OPERATION) RETURNS (OPERATION) REPORTS NIL IMPLEMENTEDBY \COURIER.OPERATION) (CHARWIDTH 27 (STREAMHANDLE CHARACTER) RETURNS (WIDTH) REPORTS NIL IMPLEMENTEDBY \COURIER.CHARWIDTH) (CHARWIDTHY 28 (STREAMHANDLE CHARACTER) RETURNS (WIDTH) REPORTS NIL IMPLEMENTEDBY \COURIER.CHARWIDTHY) (CLIPPINGREGION 29 (STREAMHANDLE REGION) RETURNS (REGION) REPORTS NIL IMPLEMENTEDBY \COURIER.CLIPPINGREGION) (BACKCOLOR 30 (STREAMHANDLE COLOR) RETURNS (COLOR) REPORTS NIL IMPLEMENTEDBY \COURIER.BACKCOLOR) (FILLPOLYGON 31 (STREAMHANDLE KNOTS TEXTURE) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.FILLPOLYGON) (BITBLT 32 (STREAMHANDLE BULK.DATA.SOURCE LEFT BOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE REGION) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.BITBLT) (SCALEDBITBLT 33 (STREAMHANDLE BULK.DATA.SOURCE LEFT BOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE REGION NUMBER) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.SCALEDBITBLT) (CHARSET 34 (STREAMHANDLE CHARACTERSET) RETURNS (CHARACTERSET) REPORTS NIL IMPLEMENTEDBY \COURIER.CHARSET) (FONTTYPE 35 (STREAMHANDLE) RETURNS (ATOM) REPORTS NIL IMPLEMENTEDBY \COURIER.FONTTYPE) (ROTATE 36 (STREAMHANDLE ROTATION) RETURNS (ROTATION) REPORTS NIL IMPLEMETEDBY \COURIER.ROTATE) (DRAWARC 37 (STREAMHANDLE X1 Y1 RADIUS ANGLE ROTATION BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWARC) (TRANSLATE 38 (STREAMHANDLE X Y) RETURNS NIL REPORTS NIL IMPLEMETEDBY \COURIER.TRANSLATE) (SCALE2 39 (STREAMHANDLE X Y) RETURNS NIL REPORTS NIL IMPLEMETEDBY \COURIER.SCALE2) (PUSHSTATE 40 (STREAMHANDLE) RETURNS NIL REPORTS NIL IMPLEMETEDBY \COURIER.PUSHSTATE) (POPSTATE 41 (STREAMHANDLE) RETURNS NIL REPORTS NIL IMPLEMETEDBY \COURIER.POPSTATE) (DEFAULTSTATE 42 (STREAMHANDLE) RETURNS NIL REPORTS NIL IMPLEMETEDBY \COURIER.DEFAULTSTATE) (DRAWPOINT 43 (STREAMHANDLE X1 Y1 BRUSH OPERATION) RETURNS NIL REPORTS NIL IMPLEMETEDBY \COURIER.DRAWPOINT)) ERRORS NIL) (COURIERPROGRAM OLDIMAGESTREAM (1111 0) TYPES ((X NUMBER) (Y NUMBER) (X1 INTEGER) (Y1 INTEGER) (X2 INTEGER) (Y2 INTEGER) (COLOR NUMBER) (RADIUS CARDINAL) (DASHING (SEQUENCE CARDINAL)) (SCALE NUMBER) (LEFT NUMBER) (BOTTOM NUMBER) (WIDTH NUMBER) (HEIGHT NUMBER) (SEMIMINORRADIUS NUMBER) (SEMIMAJORRADIUS NUMBER) (ORIENTATION NUMBER)) INHERITS (INTERLISP IMAGESTREAM) PROCEDURES ((DRAWLINE 2 (STREAMHANDLE X1 Y1 X2 Y2 CARDINAL OPERATION COLOR DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWLINE) (DRAWCIRCLE 3 (STREAMHANDLE X Y RADIUS BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWCIRCLE) (SCALE 7 (STREAMHANDLE SCALE) RETURNS (CARDINAL) REPORTS NIL IMPLEMENTEDBY \COURIER.SCALE) (XPOSITION 8 (STREAMHANDLE NUMBER) RETURNS (CARDINAL) REPORTS NIL IMPLEMENTEDBY \COURIER.XPOSITION) (YPOSITION 9 (STREAMHANDLE NUMBER) RETURNS (CARDINAL) REPORTS NIL IMPLEMENTEDBY \COURIER.YPOSITION) (COLOR 10 (STREAMHANDLE COLOR) RETURNS (CARDINAL) REPORTS NIL IMPLEMENTEDBY \COURIER.COLOR) (FILLCIRCLE 11 (STREAMHANDLE X Y RADIUS TEXTURE) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.FILLCIRCLE) (MOVETO 12 (STREAMHANDLE CARDINAL CARDINAL) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.MOVETO) (DRAWELLIPSE 21 (STREAMHANDLE X Y SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.DRAWELLIPSE) (BITBLT 32 (STREAMHANDLE BULK.DATA.SOURCE LEFT BOTTOM WIDTH HEIGHT ATOM OPERATION TEXTURE REGION) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.BITBLT) (SCALEDBITBLT 33 (STREAMHANDLE BULK.DATA.SOURCE LEFT BOTTOM WIDTH HEIGHT ATOM OPERATION TEXTURE REGION NUMBER) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \COURIER.SCALEDBITBLT) (CHARSET 34 (STREAMHANDLE NUMBER) RETURNS (CARDINAL) REPORTS NIL IMPLEMENTEDBY \COURIER.CHARSET)) ERRORS NIL) (\INITCOURIERIMAGESTREAM) (COURIER.START.SERVER) (PUTPROPS COURIERIMAGESTREAM COPYRIGHT ("Xerox Corporation & Stanford University" 1985 1986 1987 1988) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3228 21422 (\BACKCOLOR.COURIER 3238 . 3509) (\BITBLT.COURIER 3511 . 4553) ( \BLTSHADE.COURIER 4555 . 5235) (\BOTTOMMARGIN.COURIER 5237 . 5518) (\CHARSET.COURIER 5520 . 5794) ( \CHARWIDTH.COURIER 5796 . 6200) (\CHARWIDTHY.COURIER 6202 . 6609) (\CLIPPINGREGION.COURIER 6611 . 6893 ) (\CLOSEFN.COURIER 6895 . 7154) (\COLOR.COURIER 7156 . 7419) (\COURIERIMAGESTREAM.BOUT 7421 . 7695) ( \DEFAULTSTATE.COURIER 7697 . 7980) (\DRAWARC.COURIER 7982 . 8399) (\DRAWCIRCLE.COURIER 8401 . 8724) ( \DRAWCURVE.COURIER 8726 . 9036) (\DRAWELLIPSE.COURIER 9038 . 9496) (\DRAWLINE.COURIER 9498 . 9887) ( \DRAWPOINT.COURIER 9889 . 10205) (\DRAWPOLYGON.COURIER 10207 . 10523) (\FILLCIRCLE.COURIER 10525 . 10842) (\FILLPOLYGON.COURIER 10844 . 11128) (\FONT.COURIER 11130 . 11537) (\LEFTMARGIN.COURIER 11539 . 11816) (\LINEFEED.COURIER 11818 . 12088) (\MOVETO.COURIER 12090 . 12353) (\NEWPAGE.COURIER 12355 . 12616) (\OPENIMAGESTREAM.COURIER 12618 . 15192) (\OPERATION.COURIER 15194 . 15469) (\POPSTATE.COURIER 15471 . 15746) (\PUSHSTATE.COURIER 15748 . 16025) (\RESET.COURIER 16027 . 16360) (\RIGHTMARGIN.COURIER 16362 . 16641) (\ROTATE.COURIER 16643 . 16923) (\SCALE.COURIER 16925 . 17188) (\SCALEDBITBLT.COURIER 17190 . 18470) (\SCALE2.COURIER 18472 . 18747) (\SPACEFACTOR.COURIER 18749 . 19025) ( \STRINGWIDTH.COURIER 19027 . 19433) (\TERPRI.COURIER 19435 . 19770) (\TOPMARGIN.COURIER 19772 . 20047) (\TRANSLATE.COURIER 20049 . 20330) (\XPOSITION.COURIER 20332 . 20607) (\YPOSITION.COURIER 20609 . 20884) (\OUTCHAR.COURIER 20886 . 21420)) (21460 35552 (\COURIER.BACKCOLOR 21470 . 21730) ( \COURIER.BITBLT 21732 . 22252) (\COURIER.BLTSHADE 22254 . 22649) (\COURIER.BOTTOMMARGIN 22651 . 22925) (\COURIER.CHARSET 22927 . 23197) (\COURIER.CHARWIDTH 23199 . 23465) (\COURIER.CHARWIDTHY 23467 . 23735) (\COURIER.CLIPPINGREGION 23737 . 24009) (\COURIER.CLOSEIMAGESTREAM 24011 . 24630) ( \COURIER.COLOR 24632 . 24884) (\COURIER.DEFAULTSTATE 24886 . 25132) (\COURIER.DRAWARC 25134 . 25508) ( \COURIER.DRAWCIRCLE 25510 . 25850) (\COURIER.DRAWCURVE 25852 . 26194) (\COURIER.DRAWELLIPSE 26196 . 26666) (\COURIER.DRAWLINE 26668 . 27034) (\COURIER.DRAWPOINT 27036 . 27376) (\COURIER.DRAWPOLYGON 27378 . 27726) (\COURIER.FILLCIRCLE 27728 . 28056) (\COURIER.FILLPOLYGON 28058 . 28380) (\COURIER.FONT 28382 . 28630) (\COURIER.FONTTYPE 28632 . 28865) (\COURIER.LEFTMARGIN 28867 . 29137) ( \COURIER.LINEFEED 29139 . 29399) (\COURIER.MOVETO 29401 . 29691) (\COURIER.NEWPAGE 29693 . 29917) ( \COURIER.OPERATION 29919 . 30187) (\COURIER.OPENIMAGESTREAM 30189 . 31050) (\COURIER.OUTCHAR 31052 . 31332) (\COURIER.POPSTATE 31334 . 31572) (\COURIER.PUSHSTATE 31574 . 31814) (\COURIER.RESET 31816 . 32036) (\COURIER.RIGHTMARGIN 32038 . 32310) (\COURIER.ROTATE 32312 . 32578) (\COURIER.SCALE 32580 . 32832) (\COURIER.SCALEDBITBLT 32834 . 33366) (\COURIER.SCALE2 33368 . 33670) (\COURIER.SPACEFACTOR 33672 . 33938) (\COURIER.STRINGWIDTH 33940 . 34206) (\COURIER.TERPRI 34208 . 34430) ( \COURIER.TOPMARGIN 34432 . 34700) (\COURIER.TRANSLATE 34702 . 35010) (\COURIER.XPOSITION 35012 . 35280 ) (\COURIER.YPOSITION 35282 . 35550)) (35570 39599 (\INITCOURIERIMAGESTREAM 35580 . 39043) ( READSTREAMHANDLE 39045 . 39428) (WRITESTREAMHANDLE 39430 . 39597))))) STOP \ No newline at end of file diff --git a/lispusers/COURIERIMAGESTREAM.TEDIT b/lispusers/COURIERIMAGESTREAM.TEDIT new file mode 100644 index 00000000..79d28b51 Binary files /dev/null and b/lispusers/COURIERIMAGESTREAM.TEDIT differ diff --git a/lispusers/COURIERSERVE b/lispusers/COURIERSERVE new file mode 100644 index 00000000..bd4875c1 --- /dev/null +++ b/lispusers/COURIERSERVE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Dec-91 20:30:40" |{PELE:MV:ENVOS}MEDLEY>COURIERSERVE.;2| 29040 changes to%: (VARS COURIERSERVECOMS) previous date%: "21-Jul-88 15:19:08" |{PELE:MV:ENVOS}MEDLEY>COURIERSERVE.;1|) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation & Stanford University. All rights reserved. ") (PRETTYCOMPRINT COURIERSERVECOMS) (RPAQQ COURIERSERVECOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES UTILISOPRS ETHERRECORDS (LOADCOMP) COURIER)) (FNS COURIER.START.SERVER COURIER.RETURN COURIER.ABORT COURIER.REJECT CLOSE.BULK.DATA COURIER.RESET.SOCKET) (FNS \COURIERSERVER \COURIER.SERVE \COURIER.APPLY \COURIER.SETUP.REPLY \COURIER.FINISH.REPLY \FIND.COURIER.PROGRAM \FIND.COURIER.PROCEDURE) (FNS \EXPEDITEDCOURIERSERVER \EXPEDITEDCOURIER.SERVE \CREATE.EXPEDITED.STREAM) (PROP ARGNAMES COURIER.CALL COURIER.EXPEDITED.CALL) (CONSTANTS (\REJECT.NOSUCHPROGRAM 0) (\REJECT.NOSUCHVERSION 1) (\REJECT.NOSUCHPROCEDURE 2) (\REJECT.INVALIDARGUMENTS 3) (\REJECT.UNSPECIFIED 65535) (\SINK.NULL 0) (\SINK.IMMEDIATE 1) (\SINK.PASSIVE 2) (\SINK.ACTIVE 3)) (DECLARE%: DONTCOPY (RECORDS COURIERSERVERFN XIPSOCKETPAIR)))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD UTILISOPRS ETHERRECORDS (LOADCOMP) COURIER) ) (DEFINEQ (COURIER.START.SERVER [LAMBDA (RESTART) (* ; "Edited 21-Jul-88 14:44 by cdl") (LET (PROCESS) (while (AND (SETQ PROCESS (FIND.PROCESS 'COURIER.LISTENER)) RESTART) do (DEL.PROCESS PROCESS) (BLOCK)) (if (NULL PROCESS) then (COURIER.RESET.SOCKET) (SPP.OPEN NIL \NS.WKS.Courier NIL 'COURIER.LISTENER '(SERVER.FUNCTION \COURIERSERVER OTHERXIPHANDLER \EXPEDITEDCOURIERSERVER )) (if COURIERTRACEFLG then (printout COURIERTRACEFILE T "Courier Server started")) (until (SETQ PROCESS (FIND.PROCESS 'COURIER.LISTENER)) do (BLOCK))) PROCESS]) (COURIER.RETURN [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE RESULTLST) (* cdl "26-Nov-85 17:10") (LET (RESULTS STREAM) (SETQ RESULTS (with COURIERFN (\GET.COURIER.DEFINITION PROGRAM PROCEDURE 'PROCEDURES (\GET.COURIERPROGRAM PROGRAM)) RESULTS)) (if (EQLENGTH RESULTLST (LENGTH RESULTS)) then (SETQ STREAM (\COURIER.SETUP.REPLY COURIERSTREAM \COURIERMSG.RETURN)) (if (\COURIER.EXPEDITED.ARGS STREAM PROGRAM RESULTLST RESULTS) then (\COURIER.FINISH.REPLY COURIERSTREAM STREAM) else (COURIER.REJECT COURIERSTREAM)) else (COURIER.REJECT COURIERSTREAM \REJECT.INVALIDARGUMENTS]) (COURIER.ABORT [LAMBDA (COURIERSTREAM PROGRAM ERROR RESULTLST) (* cdl "26-Nov-85 17:20") (LET [(STREAM (\COURIER.SETUP.REPLY COURIERSTREAM \COURIERMSG.ABORT)) (ERRORFORM (CDR (ASSOC ERROR (fetch (COURIERPGM ERRORS) of (\GET.COURIERPROGRAM PROGRAM] (PUTWORD STREAM (CAR ERRORFORM)) (if (\COURIER.EXPEDITED.ARGS STREAM PROGRAM RESULTLST (CADR ERRORFORM)) then (\COURIER.FINISH.REPLY COURIERSTREAM STREAM) else (COURIER.REJECT \REJECT.INVALIDARGUMENTS]) (COURIER.REJECT [LAMBDA (COURIERSTREAM ERROR RESULTLST) (* cdl "26-Jun-87 10:13") (* DECLARATIONS%: (RECORD  VERSIONRANGE (LOWEST . HIGHEST))) (LET ((STREAM (\COURIER.SETUP.REPLY COURIERSTREAM \COURIERMSG.REJECT))) [if (NOT (NUMBERP ERROR)) then (SETQ ERROR (SELECTQ ERROR ((NIL UNSPECIFIED) \REJECT.UNSPECIFIED) (NO.SUCH.PROGRAM \REJECT.NOSUCHPROGRAM) (NO.SUCH.VERSION \REJECT.NOSUCHVERSION) (NO.SUCH.PROCEDURE \REJECT.NOSUCHPROCEDURE) (INVALID.ARGUMENTS \REJECT.INVALIDARGUMENTS) (SHOULDNT] (PUTWORD STREAM ERROR) (SELECTC ERROR (\REJECT.NOSUCHVERSION (with VERSIONRANGE RESULTLST (PUTWORD STREAM LOWEST) (PUTWORD STREAM HIGHEST))) NIL) (\COURIER.FINISH.REPLY COURIERSTREAM STREAM]) (CLOSE.BULK.DATA [LAMBDA (STREAM ABORTFLG) (* ; "Edited 21-Jul-88 15:18 by cdl") (* Close a Bulk Data stream after the transfer has taken place.  If a result function was specified in COURIER.CALL, call it on the stream and  the result or list of results.) (PROG ((CON (fetch (SPPSTREAM SPP.CONNECTION) of STREAM))) (with SPPCON CON (SETQ SPPATTENTIONFN NIL) (if (NULL SPPSUBSTREAM) then (* This stream has already been closed.  We don't want to try to read the Courier results twice) (RETURN))) (if (WRITEABLE STREAM) then (if ABORTFLG then (SPP.SENDATTENTION STREAM 1) else (SPP.SENDEOM STREAM)) elseif (NOT (\EOFP STREAM)) then (* Closing before all the data has  been read -- abort the transfer.) (if (NOT ABORTFLG) then (SETQ ABORTFLG T)) (\ABORT.BULK.DATA STREAM)) (SPP.DSTYPE STREAM \SPPDSTYPE.COURIER) (with SPPCON CON (SETQ SPPINPKT NIL) (SETQ SPPSUBSTREAM NIL)) (* This stream is closing; make sure there aren't any dangling pointers into  the middle of ether packets.) (with STREAM STREAM (SETQ CBUFPTR NIL) (SETQ CBUFSIZE 0)) (* The result of the Courier call may be an error which the user should see;  however, we still need to clean up the substream, so we wrap it in this  RESETLST.) (if ABORTFLG then (with STREAM (with SPPCON CON SPPINPUTSTREAM) (SETQ ENDOFSTREAMOP (FUNCTION \COURIER.EOF))) (with STREAM STREAM (SETQ ENDOFSTREAMOP (FUNCTION ERROR!]) (COURIER.RESET.SOCKET [LAMBDA NIL (* ; "Edited 5-Apr-88 14:08 by cdl") (CLOSENSOCKET (OPENNSOCKET \NS.WKS.Courier 'ACCEPT) T]) ) (DEFINEQ (\COURIERSERVER [LAMBDA (STREAM) (* ; "Edited 5-Apr-88 14:02 by cdl") (DECLARE (SPECVARS STREAM)) (RESETLST (RESETSAVE NIL `(CLOSEF? %, STREAM)) [PROG (LOW.VERSION HIGH.VERSION) (SPP.DSTYPE STREAM \SPPDSTYPE.COURIER) (with STREAM STREAM (SETQ ENDOFSTREAMOP (FUNCTION \COURIER.EOF))) (PROCESS.NAME (THIS.PROCESS) (PACK* 'COURIER (SPP.DESTADDRESS STREAM))) (if COURIERTRACEFLG then (printout COURIERTRACEFILE T "Server opened connection with" %, (SPP.DESTADDRESS STREAM))) (PUTWORD STREAM COURIER.VERSION#) (PUTWORD STREAM COURIER.VERSION#) (SPP.FORCEOUTPUT STREAM) (SETQ LOW.VERSION (GETWORD STREAM)) (SETQ HIGH.VERSION (GETWORD STREAM)) (if (AND (LEQ LOW.VERSION COURIER.VERSION#) (LEQ COURIER.VERSION# HIGH.VERSION)) then (SPP.CLEAREOM STREAM T) (\COURIER.SERVE STREAM) else (if COURIERTRACEFLG then (printout COURIERTRACEFILE T "Client requesting unknown version of Courier" %, (SPP.DESTADDRESS STREAM) %, LOW.VERSION %, HIGH.VERSION])]) (\COURIER.SERVE [LAMBDA (STREAM) (* cdl "30-Jun-87 08:57") (until (SPP.EOFP STREAM) do (SELECTC (GETWORD STREAM) (\COURIERMSG.CALL (PROG (PROGRAM PROGRAM# VERSION# PROCEDURE# PROCEDURE PGMDEF PROCDEF VERSIONS RESULTLST) (STREAMPROP STREAM 'TRANSACTIONID (GETWORD STREAM)) (* Save the Transaction ID.) (SETQ PROGRAM# (GETLONG STREAM)) (SETQ VERSION# (GETWORD STREAM)) (SETQ PROCEDURE# (GETWORD STREAM)) (if (SETQ VERSIONS (\FIND.COURIER.PROGRAM PROGRAM# VERSION#)) then [if (SETQ PROGRAM (CDR (FASSOC VERSION# VERSIONS))) then (if (SETQ PROCEDURE (\FIND.COURIER.PROCEDURE (SETQ PGMDEF ( \GET.COURIERPROGRAM PROGRAM)) PROCEDURE#)) then (SETQ PROCDEF (\GET.COURIER.DEFINITION PROGRAM PROCEDURE 'PROCEDURES PGMDEF)) (with COURIERSERVERFN PROCDEF (if SERVERFN then (if (NEQ (\COURIER.APPLY SERVERFN STREAM PROGRAM PROCEDURE PGMDEF PROCDEF) 'FLUSH) then (RETURN)) else (COURIER.REJECT STREAM \REJECT.NOSUCHPROCEDURE))) else (COURIER.REJECT STREAM \REJECT.NOSUCHPROCEDURE)) else (COURIER.REJECT STREAM \REJECT.NOSUCHVERSION (CONS (in VERSIONS minimize CAR) (in VERSIONS maximize CAR] else (COURIER.REJECT STREAM \REJECT.NOSUCHPROGRAM)) (* Flush arguments from rejected  call) (bind FLG until (SETQ FLG (SPP.EOFP STREAM)) do (BIN STREAM) finally (SELECTQ FLG (EOM (SPP.CLEAREOM STREAM)) NIL)))) (SHOULDNT]) (\COURIER.APPLY [LAMBDA (FN STREAM PROGRAM PROCEDURE PGMDEF PROCDEF) (* cdl "26-Jun-87 11:37") (DECLARE (SPECVARS FN STREAM PROGRAM PROCEDURE PGMDEF PROCDEF)) (RESETLST (PROG (XIPSOCKETPAIR ARGLST RESULTS DATASTREAM) (DECLARE (SPECVARS XIPSOCKETPAIR ARGLST)) [if (type? XIPSOCKETPAIR STREAM) then (with XIPSOCKETPAIR (SETQ XIPSOCKETPAIR STREAM) (SETQ STREAM (\CREATE.EXPEDITED.STREAM XIP 'INPUT NIL (INDEXF (fetch (EXPEDITEDXIP ARG0) of T] [SETQ ARGLST (for TYPE in (with COURIERFN PROCDEF ARGS) collect (SELECTQ TYPE ((BULK.DATA.SINK BULK.DATA.SOURCE) (SELECTC (GETWORD STREAM) (\SINK.IMMEDIATE NIL) ((LIST \SINK.NULL \SINK.PASSIVE \SINK.ACTIVE) (* Server only handles IMMEDIATE  transfer, error out as cleanly as we  can) (COURIER.REJECT STREAM) (RETURN 'FLUSH)) (SHOULDNT)) (SETQ DATASTREAM (\BULK.DATA.STREAM STREAM (SELECTQ TYPE (BULK.DATA.SOURCE 'INPUT) 'OUTPUT) PROGRAM PROCEDURE PGMDEF PROCDEF ))) (COURIER.READ STREAM PROGRAM TYPE] (if XIPSOCKETPAIR then (SETQ STREAM XIPSOCKETPAIR) else (SELECTQ (SPP.EOFP STREAM) (EOM (SPP.CLEAREOM STREAM)) NIL)) (if [SETQ RESULTS (NLSETQ (APPLY FN (LIST* STREAM PROGRAM PROCEDURE ARGLST] then (SETQ RESULTS (CAR RESULTS)) else (if COURIERTRACEFLG then (printout COURIERTRACEFILE T "Courier server function break:" %, FN)) (COURIER.REJECT STREAM \REJECT.UNSPECIFIED) (RETURN)) (if (AND DATASTREAM (OPENP DATASTREAM)) then (CLOSE.BULK.DATA DATASTREAM)) (SELECTQ (CAR RESULTS) (RETURN (COURIER.RETURN STREAM PROGRAM PROCEDURE (CDR RESULTS))) (ABORT (COURIER.ABORT STREAM PROGRAM (CADR RESULTS) (CDDR RESULTS))) (REJECT (COURIER.REJECT STREAM (CADR RESULTS) (CDDR RESULTS))) NIL) (RETURN)))]) (\COURIER.SETUP.REPLY [LAMBDA (STREAM TYPE) (* cdl "26-Jun-87 11:30") (LET (TRANSACTIONID) [if (type? XIPSOCKETPAIR STREAM) then (SETQ TRANSACTIONID (with EXPEDITEDXIP (with XIPSOCKETPAIR STREAM XIP) TRANSACTIONID)) [with XIPSOCKETPAIR STREAM (SETQ STREAM (\CREATE.EXPEDITED.STREAM XIP 'OUTPUT NIL (INDEXF (fetch (EXPEDITEDXIP MSGTYPE) of T] else (SETQ TRANSACTIONID (STREAMPROP STREAM 'TRANSACTIONID] (PUTWORD STREAM TYPE) (PUTWORD STREAM TRANSACTIONID) (* Transaction ID just echoed for  now.) STREAM]) (\COURIER.FINISH.REPLY [LAMBDA (COURIERSTREAM STREAM) (* cdl " 7-Nov-85 19:22") (if (type? XIPSOCKETPAIR COURIERSTREAM) then (with XIPSOCKETPAIR COURIERSTREAM (replace (XIP XIPLENGTH) of XIP with (with STREAM STREAM COFFSET)) (SWAPXIPADDRESSES XIP) (with ETHERPACKET XIP (SETQ EPREQUEUE 'FREE)) (SENDXIP SOCKET XIP)) else (SPP.SENDEOM COURIERSTREAM]) (\FIND.COURIER.PROGRAM [LAMBDA (PROGRAM VERSION) (* cdl "30-Jun-87 08:56") (DECLARE (SPECVARS PROGRAM VERSION)) (LET (VERSIONS) (DECLARE (SPECVARS VERSIONS)) [MAPHASH \COURIERPROGRAM (FUNCTION (LAMBDA (VALUE KEY) (DECLARE (USEDFREE PROGRAM VERSION VERSIONS)) (with COURIERPGM VALUE (if (EQP PROGRAM# PROGRAM) then (push VERSIONS (CONS VERSION# KEY)) (if (EQP VERSION# VERSION) then (* We found the requested version,  no reason to look for others) (RETFROM (FUNCTION MAPHASH] VERSIONS]) (\FIND.COURIER.PROCEDURE [LAMBDA (PGMDEF PROCEDURE#) (* cdl "26-Jun-87 08:33") (LET (PROCEDURE) (if [SETQ PROCEDURE (OR (for PROCEDURE in (with COURIERPGM PGMDEF PROCEDURES ) thereis (EQP (with COURIERFN (CDR PROCEDURE) FN#) PROCEDURE#)) (for OTHERPROGRAM in (with COURIERPGM PGMDEF INHERITS) when [SETQ $$VAL (with COURIERPGM (\GET.COURIERPROGRAM OTHERPROGRAM) (for PROCEDURE in PROCEDURES thereis (EQP (with COURIERFN (CDR PROCEDURE) FN#) PROCEDURE#] do (RETURN $$VAL] then (CAR PROCEDURE]) ) (DEFINEQ (\EXPEDITEDCOURIERSERVER [LAMBDA (XIP SOCKET) (* cdl "26-Jun-87 09:08") (if COURIERTRACEFLG then (printout COURIERTRACEFILE T "Expedited server connection with" %, (with XIP XIP XIPSOURCENSADDRESS))) (LET ((XIPSOCKETPAIR (create XIPSOCKETPAIR XIP _ XIP SOCKET _ SOCKET))) (with EXPEDITEDXIP XIP (if (NOT (AND (LEQ LOWVERSION COURIER.VERSION#) (LEQ COURIER.VERSION# HIGHVERSION))) then (if COURIERTRACEFLG then (printout COURIERTRACEFILE T "Client requesting unknown version of Courier" %, (with XIP XIP XIPSOURCENSADDRESS) %, LOWVERSION %, HIGHVERSION)) (COURIER.REJECT XIPSOCKETPAIR))) (ADD.PROCESS `(\EXPEDITEDCOURIER.SERVE %, (KWOTE XIPSOCKETPAIR]) (\EXPEDITEDCOURIER.SERVE [LAMBDA (XIPSOCKETPAIR) (* cdl "30-Jun-87 08:57") (with EXPEDITEDXIP (with XIPSOCKETPAIR XIPSOCKETPAIR XIP) (SELECTC MSGTYPE (\COURIERMSG.CALL (PROG (PROGRAM PROCEDURE PGMDEF PROCDEF VERSIONS RESULTLST) (if (SETQ VERSIONS (\FIND.COURIER.PROGRAM PROGRAM# VERSION#)) then [if (SETQ PROGRAM (CDR (FASSOC VERSION# VERSIONS))) then (if (SETQ PROCEDURE (\FIND.COURIER.PROCEDURE (SETQ PGMDEF ( \GET.COURIERPROGRAM PROGRAM)) PROCEDURE#)) then (SETQ PROCDEF (\GET.COURIER.DEFINITION PROGRAM PROCEDURE 'PROCEDURES PGMDEF)) (with COURIERSERVERFN PROCDEF (if SERVERFN then (\COURIER.APPLY SERVERFN XIPSOCKETPAIR PROGRAM PROCEDURE PGMDEF PROCDEF) else (COURIER.REJECT XIPSOCKETPAIR \REJECT.NOSUCHPROCEDURE ))) else (COURIER.REJECT XIPSOCKETPAIR \REJECT.NOSUCHPROCEDURE)) else (COURIER.REJECT XIPSOCKETPAIR \REJECT.NOSUCHVERSION (CONS (in VERSIONS minimize CAR) (in VERSIONS maximize CAR] else (COURIER.REJECT XIPSOCKETPAIR \REJECT.NOSUCHPROGRAM)))) (SHOULDNT]) (\CREATE.EXPEDITED.STREAM [LAMBDA (XIP ACCESS OSTREAM OFFSET) (* ; "Edited 21-Jul-88 15:08 by cdl") (* * Makes a STREAM to access the contents of XIP as an expedited courier  message body. We use the BASEBYTES device for simplicity.  All the operations we actually need are BIN, BOUT, BLOCKIN and BLOCKOUT) (LET ([STREAM (OR OSTREAM (NCREATE 'STREAM] END) (replace (STREAM DEVICE) of STREAM with \BASEBYTESDEVICE) (replace (STREAM ACCESS) of STREAM with ACCESS) (replace (STREAM CBUFPTR) of STREAM with (fetch (XIP XIPBASE) of XIP)) [replace (STREAM COFFSET) of STREAM with (IPLUS \XIPOVLEN (UNFOLD 3 BYTESPERWORD) (if (EQ ACCESS 'INPUT) then (* For COURIER.RESULTS) (SETQ END (fetch (XIP XIPLENGTH) of XIP)) (UNFOLD (OR OFFSET (INDEXF (fetch (EXPEDITEDXIP MSGTYPE) of T))) BYTESPERWORD) else (* For COURIER.EXPEDITED.ARGS) (SETQ END (IPLUS \MAX.XIPDATALENGTH \XIPOVLEN)) (UNFOLD (OR OFFSET (INDEXF (fetch (EXPEDITEDXIP ARG0) of T))) BYTESPERWORD] (replace (STREAM EOFFSET) of STREAM with (replace (STREAM CBUFSIZE) of STREAM with END)) [if (EQ ACCESS 'INPUT) then (* Will cause error if COURIER.RESULTS tries to read more than was sent --  should never happen) (with STREAM STREAM (SETQ ENDOFSTREAMOP (FUNCTION \COURIER.EOF))) else (* Invoked if COURIER.EXPEDITED.ARGS  tries to write more than will fit in  the packet) (with BASEBYTESTREAM STREAM (SETQ WRITEXTENSIONFN (FUNCTION \COURIER.EXPEDITED.OVERFLOW] STREAM]) ) (PUTPROPS COURIER.CALL ARGNAMES (NIL (STREAM PROGRAM PROCEDURE ARG1 ... ARGn NOERRORFLG) . U)) (PUTPROPS COURIER.EXPEDITED.CALL ARGNAMES (NIL (ADDRESS SOCKET PROGRAM PROCEDURE ARG1 ... ARGn NOERRORFLG) . U)) (DECLARE%: EVAL@COMPILE (RPAQQ \REJECT.NOSUCHPROGRAM 0) (RPAQQ \REJECT.NOSUCHVERSION 1) (RPAQQ \REJECT.NOSUCHPROCEDURE 2) (RPAQQ \REJECT.INVALIDARGUMENTS 3) (RPAQQ \REJECT.UNSPECIFIED 65535) (RPAQQ \SINK.NULL 0) (RPAQQ \SINK.IMMEDIATE 1) (RPAQQ \SINK.PASSIVE 2) (RPAQQ \SINK.ACTIVE 3) (CONSTANTS (\REJECT.NOSUCHPROGRAM 0) (\REJECT.NOSUCHVERSION 1) (\REJECT.NOSUCHPROCEDURE 2) (\REJECT.INVALIDARGUMENTS 3) (\REJECT.UNSPECIFIED 65535) (\SINK.NULL 0) (\SINK.IMMEDIATE 1) (\SINK.PASSIVE 2) (\SINK.ACTIVE 3)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD COURIERSERVERFN (FN# ARGS RETURNSNOISE RESULTS REPORTSNOISE ERRORS IMPLEMENTEDNOISE SERVERFN)) (TYPERECORD XIPSOCKETPAIR (XIP . SOCKET)) ) ) (PUTPROPS COURIERSERVE COPYRIGHT ("Xerox Corporation & Stanford University" 1985 1986 1987 1988 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1593 7933 (COURIER.START.SERVER 1603 . 2726) (COURIER.RETURN 2728 . 3548) ( COURIER.ABORT 3550 . 4187) (COURIER.REJECT 4189 . 5621) (CLOSE.BULK.DATA 5623 . 7730) ( COURIER.RESET.SOCKET 7732 . 7931)) (7934 21043 (\COURIERSERVER 7944 . 9463) (\COURIER.SERVE 9465 . 12794) (\COURIER.APPLY 12796 . 16571) (\COURIER.SETUP.REPLY 16573 . 17735) (\COURIER.FINISH.REPLY 17737 . 18313) (\FIND.COURIER.PROGRAM 18315 . 19499) (\FIND.COURIER.PROCEDURE 19501 . 21041)) (21044 27777 (\EXPEDITEDCOURIERSERVER 21054 . 22390) (\EXPEDITEDCOURIER.SERVE 22392 . 25156) ( \CREATE.EXPEDITED.STREAM 25158 . 27775))))) STOP \ No newline at end of file diff --git a/lispusers/COURIERSERVE.TEDIT b/lispusers/COURIERSERVE.TEDIT new file mode 100644 index 00000000..3842e4d5 Binary files /dev/null and b/lispusers/COURIERSERVE.TEDIT differ diff --git a/lispusers/COURIERSERVEPATCH b/lispusers/COURIERSERVEPATCH new file mode 100644 index 00000000..4d143692 --- /dev/null +++ b/lispusers/COURIERSERVEPATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Mar-88 14:59:38" {ERINYES}LYRIC>COURIERSERVEPATCH.;2 3329 changes to%: (FNS \SPP.ESTABLISH) previous date%: " 9-Mar-88 16:56:49" {ERINYES}LYRIC>COURIERSERVEPATCH.;1) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COURIERSERVEPATCHCOMS) (RPAQQ COURIERSERVEPATCHCOMS ((FNS \SPP.ESTABLISH \SPP.CREATE.CON) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) SPPDECLS))) ) (DEFINEQ (\SPP.ESTABLISH (LAMBDA (INITCON XIP) (* ; "Edited 10-Mar-88 14:58 by bvm") (* ;;; "The arrival of XIP causes this SPP connection to be established. Fix up state as appropriate") (PROG (CON INSTREAM NAME) (COND ((NOT (fetch SPPSERVERFLAG of INITCON)) (SETQ CON INITCON) (* ; "For user connection, need to update socket info, as server may have switched from a well-known socket to a private one.") (\BLT (LOCF (fetch SPPDESTNSADDRESS0 of CON)) (LOCF (fetch XIPSOURCENET of XIP)) \#WDS.NSADDRESS)) (T (* ;; "The connection was opened in server mode. Create a new spp connection, and establish it to the remote side, spawning a new process") (COND ((\SPP.DUPLICATE.REQUEST XIP) (* ; "We've already spawned a server for this source") (RETURN))) (SETQ CON (\SPP.CREATE.CON)) (\BLT (LOCF (fetch SPPDESTNSADDRESS0 of CON)) (LOCF (fetch XIPSOURCENET of XIP)) \#WDS.NSADDRESS) (* ; "Fill in address of port that contacted us") (SETQ NAME (CONCAT (PROCESSPROP (fetch SPPPROCESS of INITCON) (QUOTE NAME)) (QUOTE +) (OCTALSTRING (fetch SPPSOURCESKT# of CON)))) (replace SPPATTENTIONFN of CON with (fetch SPPATTENTIONFN of INITCON)) (* ; "Copy some methods from the listener con") (replace SPPWHENCLOSEDFN of CON with (fetch SPPWHENCLOSEDFN of INITCON)) (replace SPPERRORHANDLER of CON with (fetch SPPERRORHANDLER of INITCON)))) (replace SPPDESTID of CON with (fetch (SPPXIP SOURCECONID) of XIP)) (replace SPPSYSPKT of CON with NIL) (* ; "Flush any cached sys packet, now out of date") (replace SPPESTABLISHEDP of CON with T) (replace SPPSTATE of CON with \SPS.OPEN) (replace SPPDESTINATIONKNOWN of CON with T) (if NAME then (* ; "Finally, get server going") (SETQ INSTREAM (\SPP.CREATE.STREAMS CON)) (\SPP.CREATE.WATCHER CON NAME) (WITH.MONITOR (fetch SPPLOCK of CON) (* ; "Have to reply to the sender so he knows our id & socket") (\SPP.PROBE CON)) (ADD.PROCESS (LIST (fetch SPPSERVERFN of INITCON) INSTREAM (SPPOUTPUTSTREAM INSTREAM)) (QUOTE AFTEREXIT) (QUOTE DELETE))) (NOTIFY.EVENT (fetch SPPINPUTEVENT of CON)))) ) (\SPP.CREATE.CON (LAMBDA (SKT#) (* ; "Edited 9-Mar-88 16:00 by bvm") (* ;; "Creates an SPPCON object, initialized to be a connection from this machine, etc. If SKT# is specified, we open that exact socket, else a random user socket.") (LET* ((NSOC (OPENNSOCKET SKT#)) (CON (create SPPCON SPPXIPLENGTH _ (+ \XIPOVLEN \SPPHEAD.LENGTH) SPPXIPTYPE _ \XIPT.SPP SPPSOURCEID _ (LOGOR 32768 (LOGAND (DAYTIME) 32767)) SPPMYNSOCKET _ NSOC SPPSOURCESKT# _ (NSOCKETNUMBER NSOC) SPPACCEPTNO _ \SPP.INITIAL.ALLOCATION))) (\BLT (LOCF (fetch SPPSOURCENSADDRESS0 of CON)) \MY.NSADDRESS (SUB1 \#WDS.NSADDRESS)) CON)) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) SPPDECLS) ) (PUTPROPS COURIERSERVEPATCH COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (540 3174 (\SPP.ESTABLISH 550 . 2564) (\SPP.CREATE.CON 2566 . 3172))))) STOP \ No newline at end of file diff --git a/lispusers/CROCK b/lispusers/CROCK new file mode 100644 index 00000000..1a309cd4 --- /dev/null +++ b/lispusers/CROCK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 2-Apr-87 00:37:46" {ERIS}LYRIC>CROCK.;2 17791 previous date%: "11-Jan-86 19:46:27" {PHYLUM}LYRIC>CROCK.;1) (* " Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CROCKCOMS) (RPAQQ CROCKCOMS ((* CROCK -- By Kelly Roach *) (FNS CROCK CROCK.BUTTONEVENTFN CROCK.CHANGE.STYLE CROCK.CLOSEFN CROCK.PROCESS CROCK.RESHAPEFN CROCK.ALARM CROCK.RING.ALARM CROCK.INIT) (INITVARS (CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T)) (CROCK.STYLE.MENU) (CROCK.ALARMS) (CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) [CROCK.TUNE '((1000 . 1000) (800 . 1000) (600 . 1000) (500 . 1000) (400 . 1000) (NIL . 500) (440 . 1000) (484 . 1000) (540 . 1000) (600 . 1000) (2000 . 1000) (1600 . 1000) (1200 . 1000) (1000 . 1000) (800 . 1000) (NIL . 500) (880 . 1000) (968 . 1000) (1080 . 1000) (1188 . 1000] (CROCKWINDOW)))) (* CROCK -- By Kelly Roach *) (DEFINEQ (CROCK [LAMBDA (REGION) (DECLARE (GLOBALVARS CROCKWINDOW)) (* lmm "22-Feb-84 17:07") (PROG NIL (COND ((NOT (WINDOWP CROCKWINDOW)) [COND ((NULL REGION) (PROMPTPRINT "Please indicate a region for the clock") (SETQ REGION (GETREGION] (SETQ CROCKWINDOW (CREATEW REGION))) (REGION (SHAPEW CROCKWINDOW REGION))) (DEL.PROCESS 'CROCK.PROCESS) (ADD.PROCESS '(CROCK.PROCESS) 'RESTARTABLE T]) (CROCK.BUTTONEVENTFN [LAMBDA (WINDOW) (* edited%: "24-AUG-82 17:15") (COND ((LASTMOUSESTATE MIDDLE) (CROCK.CHANGE.STYLE WINDOW)) ((LASTMOUSESTATE (NOT UP)) (WAKE.PROCESS 'CROCK.PROCESS 'REPAINT]) (CROCK.CHANGE.STYLE [LAMBDA (WINDOW) (* bvm%: "22-APR-83 17:13") (PROG (MENU COMMAND STYLE NO.CHANGE) [SETQ MENU (OR CROCK.STYLE.MENU (SETQ CROCK.STYLE.MENU (create MENU ITEMS _ '(NUMBERS POINTS NO.NUMBERS RINGS NO.RINGS HANDS NO.HANDS TIMES NO.TIMES (" " NIL) SHOW.STYLE SET.TO.DEFAULT CHANGE.DEFAULT (" " NIL) SETTIME] (SETQ COMMAND (MENU MENU)) (SETQ STYLE (WINDOWPROP WINDOW 'STYLE)) (SELECTQ COMMAND (NIL (SETQ NO.CHANGE T)) (SETTIME (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (SETTIME))) (SET.TO.DEFAULT (SETQ STYLE (COPY CROCK.DEFAULT.STYLE))) (HANDS (LISTPUT STYLE 'HANDS T)) (NO.HANDS (LISTPUT STYLE 'HANDS NIL)) (TIMES (LISTPUT STYLE 'TIMES T)) (NO.TIMES (LISTPUT STYLE 'TIMES NIL)) (RINGS (LISTPUT STYLE 'RINGS T)) (NO.RINGS (LISTPUT STYLE 'RINGS NIL)) (NUMBERS (LISTPUT STYLE 'NUMBERS T)) (POINTS (LISTPUT STYLE 'NUMBERS 'POINTS)) (NO.NUMBERS (LISTPUT STYLE 'NUMBERS NIL)) (CHANGE.DEFAULT (SETQ CROCK.DEFAULT.STYLE (COPY STYLE)) (SETQ NO.CHANGE T)) (SHOW.STYLE (printout PROMPTWINDOW T "CROCK style: " T 3 "Numbers: " (COND ((LISTGET STYLE 'NUMBERS) "yes") (T "no")) "; Rings: " (COND ((LISTGET STYLE 'RINGS) "yes") (T "no")) "; Hands: " (COND ((LISTGET STYLE 'HANDS) "yes") (T "no")) "; Times: " (COND ((LISTGET STYLE 'TIMES) "yes") (T "no"))) (SETQ NO.CHANGE T)) (SHOULDNT)) (COND (NO.CHANGE) (T (WINDOWPROP WINDOW 'STYLE STYLE) (WAKE.PROCESS 'CROCK.PROCESS 'CHANGE.STYLE]) (CROCK.CLOSEFN [LAMBDA (WINDOW) (* edited%: "24-AUG-82 17:17") (WAKE.PROCESS 'CROCK.PROCESS 'CLOSING]) (CROCK.PROCESS [LAMBDA NIL (DECLARE (GLOBALVARS CROCKWINDOW)) (* ; "Edited 1-Apr-00 by Briggs & Dixon") (PROG (SIZE HALFSIZE XCENTER YCENTER RADIUS INSIDERADIUS MINUTEHANDSIZE HOURHANDSIZE DS STYLE CLIPPINGREGION OUTLINE OUTLINEDSP DONE IDATE UDATE DATE HOURS MINUTES SECONDS OLDMINUTES WIDTH HEIGHT HOURANGLE MINUTEANGLE NUM FONTHALFHEIGHT CHANGE.STYLE FONT STRPTR 1APR OLDHOURS) (CROCK.INIT CROCKWINDOW) (SETQ STRPTR (DATE CROCK.DATEFORMAT)) (SETQ DS (WINDOWPROP CROCKWINDOW 'DSP)) RESTART (SETQ CHANGE.STYLE T) (SETQ CLIPPINGREGION (DSPCLIPPINGREGION NIL DS)) (SETQ XCENTER (IQUOTIENT (SETQ WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION)) 2)) (SETQ YCENTER (IQUOTIENT (SETQ HEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of CLIPPINGREGION ) 10)) 2)) (* ;  "Allow 10 points at top for digital form") (SETQ SIZE (IMIN HEIGHT WIDTH)) (SETQ HALFSIZE (IQUOTIENT SIZE 2)) (SETQ RADIUS (FIXR (FTIMES 0.9 HALFSIZE))) (SETQ INSIDERADIUS (IDIFFERENCE RADIUS 10)) (SETQ HOURHANDSIZE (FTIMES 0.5 INSIDERADIUS)) (SETQ MINUTEHANDSIZE (FTIMES 0.8 INSIDERADIUS)) (SETQ OUTLINE (BITMAPCREATE WIDTH HEIGHT)) (SETQ OUTLINEDSP (DSPCREATE)) (DSPDESTINATION OUTLINE OUTLINEDSP) (DSPFONT [SETQ FONT (COND ((ILESSP RADIUS 50) (FONTCREATE 'GACHA 8)) (T (FONTCREATE 'HELVETICA 10 'BOLD] OUTLINEDSP) (DSPFONT FONT DS) (SETQ STYLE (WINDOWPROP CROCKWINDOW 'STYLE)) (SETQ 1APR 1) [until DONE do (COND (CHANGE.STYLE (SETQ CHANGE.STYLE (SETQ OLDMINUTES (SETQ OLDHOURS NIL))) (DSPFILL NIL WHITESHADE 'REPLACE OUTLINEDSP) (DRAWCIRCLE XCENTER YCENTER RADIUS 4 NIL OUTLINEDSP) (DRAWCIRCLE XCENTER YCENTER 2 4 NIL OUTLINEDSP) (COND ((LISTGET STYLE 'RINGS) (DRAWCIRCLE XCENTER YCENTER HOURHANDSIZE 2 NIL OUTLINEDSP) (DRAWCIRCLE XCENTER YCENTER MINUTEHANDSIZE 2 NIL OUTLINEDSP))) (SELECTQ (LISTGET STYLE 'NUMBERS) (T (SETQ FONTHALFHEIGHT (IDIFFERENCE (IQUOTIENT (FONTHEIGHT FONT) 2) (FONTDESCENT FONT))) (for I from 1 to 12 do (SETQ NUM (MKSTRING I)) (SETQ MINUTEANGLE (FTIMES 1APR 30 I)) (MOVETO (FDIFFERENCE (FPLUS XCENTER (FTIMES INSIDERADIUS (SIN MINUTEANGLE))) (IQUOTIENT (STRINGWIDTH NUM OUTLINEDSP) 2)) (FDIFFERENCE (FPLUS YCENTER (FTIMES INSIDERADIUS (COS MINUTEANGLE))) FONTHALFHEIGHT) OUTLINEDSP) (PRIN1 NUM OUTLINEDSP))) (POINTS (for I from 1 to 12 bind (RAD _ (FPLUS INSIDERADIUS 5)) do (SETQ MINUTEANGLE (FTIMES 30 I)) (DRAWCIRCLE (FPLUS XCENTER (FTIMES RAD (SIN MINUTEANGLE)) ) (FPLUS YCENTER (FTIMES RAD (COS MINUTEANGLE))) 1 2 NIL OUTLINEDSP))) NIL))) (SETQ IDATE (IDATE)) (SETQ UDATE (\UNPACKDATE IDATE)) (SETQ DATE (\OUTDATE UDATE CROCK.DATEFORMAT STRPTR)) (SETQ MINUTES (CAR (NTH UDATE 5))) (SETQ SECONDS (CAR (NTH UDATE 6))) [COND ((NEQ MINUTES OLDMINUTES) (SETQ HOURS (CAR (NTH UDATE 4))) (BITBLT OUTLINE 0 0 DS 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (SETQ HOURANGLE (FPLUS (FTIMES 1APR 30.0 HOURS) (FTIMES 1APR 0.5 MINUTES))) (SETQ MINUTEANGLE (FTIMES 1APR 6.0 MINUTES)) (COND ((LISTGET STYLE 'HANDS) (DRAWLINE XCENTER YCENTER [PLUS XCENTER (FIXR (FTIMES HOURHANDSIZE (SIN HOURANGLE] [PLUS YCENTER (FIXR (FTIMES HOURHANDSIZE (COS HOURANGLE] 5 'PAINT DS) (DRAWLINE XCENTER YCENTER [PLUS XCENTER (FIXR (FTIMES MINUTEHANDSIZE (SIN MINUTEANGLE] [PLUS YCENTER (FIXR (FTIMES MINUTEHANDSIZE (COS MINUTEANGLE] 3 'PAINT DS))) (COND ((LISTGET STYLE 'TIMES) (MOVETO (FPLUS XCENTER -5 (FTIMES HOURHANDSIZE (SIN HOURANGLE))) (FPLUS YCENTER -5 (FTIMES HOURHANDSIZE (COS HOURANGLE))) DS) (PRIN1 (COND ((IGREATERP HOURS 12) (IDIFFERENCE HOURS 12)) (T HOURS)) DS) (MOVETO (FPLUS XCENTER -5 (FTIMES MINUTEHANDSIZE (SIN MINUTEANGLE))) (FPLUS YCENTER -5 (FTIMES MINUTEHANDSIZE (COS MINUTEANGLE))) DS) (PRIN1 MINUTES DS))) (COND ((NEQ HOURS OLDHOURS) (COND ((NEQ 1APR (SETQ 1APR (if (AND (EQ (CADR UDATE) 3) (EQ (CADDR UDATE) 1) (ILESSP (CADDDR UDATE) 12)) then -1 else 1))) (SETQ CHANGE.STYLE T] (SETQ OLDHOURS HOURS) (SETQ OLDMINUTES MINUTES) (MOVETOUPPERLEFT CROCKWINDOW CLIPPINGREGION) (PRIN3 DATE CROCKWINDOW) (while [AND CROCK.ALARMS (GEQ IDATE (CAR (CAR CROCK.ALARMS] do (CROCK.RING.ALARM)) (SELECTQ (BLOCK (ITIMES 1000 (IDIFFERENCE 60 SECONDS))) (CHANGE.STYLE (SETQ CHANGE.STYLE T)) (SHAPE (GO RESTART)) (CLOSING (SETQ DONE T)) NIL) (COND ((AND (EQ MINUTES 0) (EQ (IREMAINDER HOURS 6) 0) (EQ (MACHINETYPE) 'DANDELION)) (* ;; "\NET.SETTIME every six hours if possible because Xerox computers can't keep time right. SETTIME would make non-network users enter time manually--we don't want this. *") (\NET.SETTIME] (PROCESS.RETURN]) (CROCK.RESHAPEFN [LAMBDA (WINDOW REGION) (* bvm%: "27-AUG-82 16:26") (WAKE.PROCESS 'CROCK.PROCESS 'SHAPE]) (CROCK.ALARM [LAMBDA (DATESTRING MESSAGE FORM) (* kbr%: "29-Mar-84 14:57") (* Add (IDATE . MESSAGE) to  CROCK.ALARMS *) (PROG (IDATE) (SETQ IDATE (IDATE DATESTRING)) (COND ((ILESSP IDATE (IDATE)) (printout T "CROCK: Can't set alarm to " DATESTRING " in the past!" T) (RINGBELLS)) (T (SETQ CROCK.ALARMS (NCONC (for BUCKET in CROCK.ALARMS when (ILEQ (CAR BUCKET) IDATE) collect BUCKET) (LIST (LIST IDATE (GDATE IDATE) MESSAGE FORM)) (for BUCKET in CROCK.ALARMS when (IGREATERP (CAR BUCKET) IDATE) collect BUCKET))) (printout T "CROCK: Alarm set at " (GDATE IDATE) "." T]) (CROCK.RING.ALARM [LAMBDA NIL (* kbr%: "29-Mar-84 14:59") (PROG (BUCKET IDATE MESSAGE FORM) (SETQ BUCKET (pop CROCK.ALARMS)) (SETQ IDATE (CAR BUCKET)) (SETQ MESSAGE (CADDR BUCKET)) (SETQ FORM (CADDDR BUCKET)) (SELECTQ (MACHINETYPE) (DANDELION (COND (CROCK.TUNE (PLAYTUNE CROCK.TUNE)) (T (RINGBELLS 3)))) (RINGBELLS 3)) (printout PROMPTWINDOW "CROCK: It is now " (GDATE IDATE) "." T) (COND (MESSAGE (printout PROMPTWINDOW MESSAGE T))) (EVAL FORM) (INVERTW CROCKWINDOW]) (CROCK.INIT [LAMBDA (WINDOW) (* kbr%: "21-JUN-83 09:44") (WINDOWPROP WINDOW 'BUTTONEVENTFN 'CROCK.BUTTONEVENTFN) (WINDOWPROP WINDOW 'RESHAPEFN 'CROCK.RESHAPEFN) (WINDOWPROP WINDOW 'CLOSEFN 'CROCK.CLOSEFN) (COND ((NULL (WINDOWPROP WINDOW 'STYLE)) (WINDOWPROP WINDOW 'STYLE (COPY CROCK.DEFAULT.STYLE]) ) (RPAQ? CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T)) (RPAQ? CROCK.STYLE.MENU ) (RPAQ? CROCK.ALARMS ) (RPAQ? CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) (RPAQ? CROCK.TUNE '((1000 . 1000) (800 . 1000) (600 . 1000) (500 . 1000) (400 . 1000) (NIL . 500) (440 . 1000) (484 . 1000) (540 . 1000) (600 . 1000) (2000 . 1000) (1600 . 1000) (1200 . 1000) (1000 . 1000) (800 . 1000) (NIL . 500) (880 . 1000) (968 . 1000) (1080 . 1000) (1188 . 1000))) (RPAQ? CROCKWINDOW ) (PUTPROPS CROCK COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1940 16814 (CROCK 1950 . 2520) (CROCK.BUTTONEVENTFN 2522 . 2811) (CROCK.CHANGE.STYLE 2813 . 5626) (CROCK.CLOSEFN 5628 . 5790) (CROCK.PROCESS 5792 . 14290) (CROCK.RESHAPEFN 14292 . 14451) (CROCK.ALARM 14453 . 15681) (CROCK.RING.ALARM 15683 . 16424) (CROCK.INIT 16426 . 16812))))) STOP \ No newline at end of file diff --git a/lispusers/CROCK.TEDIT b/lispusers/CROCK.TEDIT new file mode 100644 index 00000000..479ba1f8 Binary files /dev/null and b/lispusers/CROCK.TEDIT differ diff --git a/lispusers/CUT-HKB b/lispusers/CUT-HKB new file mode 100644 index 00000000..fe433e0f --- /dev/null +++ b/lispusers/CUT-HKB @@ -0,0 +1 @@ +(FILECREATED "10-Feb-87 17:00:26" {DSK}H.ALFA>CUT.HKB;1 545 ) (PRETTYCOMPRINT CUTCOMS) (RPAQQ CUTCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)) (RPAQQ *functions1* NIL) (RPAQQ *predicates1* (A-CUT C B A)) (RPAQQ *variables1* (:b :a :y :x)) (RPAQQ *temp-foo* NIL) (RPAQQ *temp-pred* [(((A-CUT :x :y) < (B :x) / (C :y))) (((C 3)) ((C 4))) (((B 1)) ((B 2))) (((A :x :y) < (B :x) (C :y]) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/DANDELIONUFO b/lispusers/DANDELIONUFO new file mode 100644 index 00000000..03f799d6 --- /dev/null +++ b/lispusers/DANDELIONUFO @@ -0,0 +1 @@ +(FILECREATED "16-Feb-86 00:14:45" {ERIS}LIBRARY>DANDELIONUFO.;24 11913 changes to: (VARS DANDELIONUFOCOMS \DANDELIONUFO.LOCKEDFNS) (FNS \DANDELIONUFO.WRITE \DANDELIONUFO.SENDPAGE) previous date: "15-Feb-86 12:35:33" {ERIS}LIBRARY>DANDELIONUFO.;23) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DANDELIONUFOCOMS) (RPAQQ DANDELIONUFOCOMS ((* DANDELIONUFO -- Driver for the UFO systems Dandelion BusMaster color board -- By Kelly Roach and Herb Jellinek. *) (CONSTANTS (NYBBLESPERWORD 4) (BITSPERNYBBLE 4) (\PCColorMapBase 917520) (\RochesterDisplayBase 917504) (\RochesterDisplayOffsetRegister 917552) (\RochesterDisplayOffsetRegisterLo 917553) (\RochesterBUSADDRHI 8) (\RochesterBUSADDRLO 0) (\RochesterPIXELSPERPAGE 1024) (\RochesterRASTERWIDTH 160)) (FNS \DANDELIONUFO.WRITE) (FNS \DANDELIONUFO.INIT \DANDELIONUFO.STARTBOARD \DANDELIONUFO.SENDCOLORMAPENTRY \DANDELIONUFO.SENDPAGE \DANDELIONUFO.PILOTBITBLT) (FILES BUSCOLOR) (VARS \DANDELIONUFO.LOCKEDFNS) (DECLARE: DONTEVAL@COMPILE DOCOPY (P (\DANDELIONUFO.INIT))))) (* DANDELIONUFO -- Driver for the UFO systems Dandelion BusMaster color board -- By Kelly Roach and Herb Jellinek. *) (DECLARE: EVAL@COMPILE (RPAQQ NYBBLESPERWORD 4) (RPAQQ BITSPERNYBBLE 4) (RPAQQ \PCColorMapBase 917520) (RPAQQ \RochesterDisplayBase 917504) (RPAQQ \RochesterDisplayOffsetRegister 917552) (RPAQQ \RochesterDisplayOffsetRegisterLo 917553) (RPAQQ \RochesterBUSADDRHI 8) (RPAQQ \RochesterBUSADDRLO 0) (RPAQQ \RochesterPIXELSPERPAGE 1024) (RPAQQ \RochesterRASTERWIDTH 160) (CONSTANTS (NYBBLESPERWORD 4) (BITSPERNYBBLE 4) (\PCColorMapBase 917520) (\RochesterDisplayBase 917504) (\RochesterDisplayOffsetRegister 917552) (\RochesterDisplayOffsetRegisterLo 917553) (\RochesterBUSADDRHI 8) (\RochesterBUSADDRLO 0) (\RochesterPIXELSPERPAGE 1024) (\RochesterRASTERWIDTH 160)) ) (DEFINEQ (\DANDELIONUFO.WRITE (LAMBDA (A D) (* kbr: " 4-Feb-86 17:24") (PCBUS.WRITE (IPLUS 917504 A) D))) ) (DEFINEQ (\DANDELIONUFO.INIT (LAMBDA NIL (* kbr: "15-Feb-86 12:32") (DECLARE (GLOBALVARS \DANDELIONUFOWSOPS \DANDELIONUFOINFO)) (for FN in \DANDELIONUFO.LOCKEDFNS do (\LOCKFN FN)) (SETQ \DANDELIONUFOWSOPS (create WSOPS STARTBOARD _(FUNCTION \DANDELIONUFO.STARTBOARD) STARTCOLOR _(FUNCTION \BUSCOLOR.STARTCOLOR) STOPCOLOR _(FUNCTION \BUSCOLOR.STOPCOLOR) EVENTFN _(FUNCTION \BUSCOLOR.EVENTFN) SENDCOLORMAPENTRY _(FUNCTION \DANDELIONUFO.SENDCOLORMAPENTRY) SENDPAGE _(FUNCTION \DANDELIONUFO.SENDPAGE) PILOTBITBLT _(FUNCTION \DANDELIONUFO.PILOTBITBLT))) (SETQ \DANDELIONUFOINFO (create DISPLAYINFO DITYPE _(QUOTE DANDELIONUFO) DIWIDTH _ 640 DIHEIGHT _ 400 DIBITSPERPIXEL _ 4 DIWSOPS _ \DANDELIONUFOWSOPS)) (\DEFINEDISPLAYINFO \DANDELIONUFOINFO))) (\DANDELIONUFO.STARTBOARD (LAMBDA NIL (* kbr: "25-Aug-85 16:23") (\DANDELIONUFO.WRITE 1 0) (\DANDELIONUFO.WRITE 1 0) (\DANDELIONUFO.WRITE 1 16) (\DANDELIONUFO.WRITE 0 24) (\DANDELIONUFO.WRITE 0 (SELECTQ COLORMONITORTYPE ((NIL CONRAC) 10) (HITACHI 11) (ERROR "ILLEGAL ARG" COLORMONITORTYPE))) (\DANDELIONUFO.WRITE 0 25) (\DANDELIONUFO.WRITE 0 43) (\DANDELIONUFO.WRITE 0 227) (\DANDELIONUFO.WRITE 0 39) (\DANDELIONUFO.WRITE 0 0) (\DANDELIONUFO.WRITE 0 0) (\DANDELIONUFO.WRITE 0 0) (\DANDELIONUFO.WRITE 0 0) (\DANDELIONUFO.WRITE 0 0) (\DANDELIONUFO.WRITE 1 63) (\DANDELIONUFO.WRITE 2 1) (\DANDELIONUFO.WRITE 3 0) (\DANDELIONUFO.WRITE 32 8) (\DANDELIONUFO.WRITE 48 0) (\DANDELIONUFO.WRITE 49 0))) (\DANDELIONUFO.SENDCOLORMAPENTRY (LAMBDA (FDEV COLOR# RGB) (* kbr: " 4-Feb-86 17:22") (* sends the Ith entry of the colormap COLORMAP to the extension bus.) (PROG (LUT) (SETQ LUT (LOGXOR 63 (LOGOR 128 (LLSH (LRSH (fetch (RGB BLUE) of RGB) 6) 4) (LLSH (LRSH (fetch (RGB GREEN) of RGB) 6) 2) (LRSH (fetch (RGB RED) of RGB) 6)))) (PCBUS.WRITE (IPLUS \PCColorMapBase COLOR#) LUT)))) (\DANDELIONUFO.SENDPAGE (LAMBDA (PAGE PAGE#) (* kbr: "16-Feb-86 00:14") (PROG (DISPINTERRUPT) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (PCBUS.WRITEHL 14 48 (LLSH (LOGAND PAGE# 3) 6)) (PCBUS.WRITEHL 14 49 (LRSH PAGE# 2)) (* ((1024 pixels / page) / (16 pixels / offset)) = 64 offsets / page) (\BUSBLTOUTNYBBLES PAGE \RochesterBUSADDRHI \RochesterBUSADDRLO WORDSPERPAGE) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT)))) (\DANDELIONUFO.PILOTBITBLT (LAMBDA (PILOTBBT N) (* kbr: " 4-Feb-86 17:23") (PROG (DEST DESTBIT WIDTH HEIGHT BUSADDRHI BUSADDRLO NWORDS ABSCURRPAGE CURRPAGEINBITMAP DISPINTERRUPT) (* The busmaster UPDATEDAEMON is a narrow communication bottleneck from the color screen bitmap to the color frame buffer. We work around this bottleneck by communicating small important changes to the color screen bitmap quickly and big less important changes slower. *) (* We try to make small changes that cross lots of pages appear visible in the frame buffer quickly by writing to both color screen bitmap and frame buffer. Big changes, which could be overwritten by other big changes before the UPDATEDAEMON notices them (and so save us time this way) are best left to the UPDATEDAEMON to handle. *) (* First, output to the color screen bitmap. *) (\PILOTBITBLT PILOTBBT N) (* Probably a case worth optimizing: cursors, carets, characters, vertical drawlines, and vertical scroll bars. \BUSBLTOUTNYBBLES works in words, not pixels (nybbles)%. We handle this problem by getting the values for our pixels from the DEST we just did our \PILOTBITBLT to, slopping over to a few unchanged pixels when necessary. *) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (SETQ DEST (fetch (PILOTBBT PBTDEST) of PILOTBBT)) (SETQ DESTBIT (fetch (PILOTBBT PBTDESTBIT) of PILOTBBT)) (SETQ WIDTH (fetch (PILOTBBT PBTWIDTH) of PILOTBBT)) (SETQ HEIGHT (fetch (PILOTBBT PBTHEIGHT) of PILOTBBT)) (SETQ ABSCURRPAGE (fetch (POINTER PAGE#) of DEST)) (SETQ CURRPAGEINBITMAP (IDIFFERENCE ABSCURRPAGE ColorScreenBitMapBasePage)) (SETQ NWORDS (IPLUS (FOLDHI (IPLUS DESTBIT WIDTH -1) BITSPERWORD) (IMINUS (FOLDLO DESTBIT BITSPERWORD)) 1)) (SETQ BUSADDRLO (UNFOLD (IPLUS (fetch (POINTER WORDINPAGE) of DEST) (FOLDLO DESTBIT BITSPERWORD)) NYBBLESPERWORD)) (SETQ DEST (\ADDBASE DEST (FOLDLO DESTBIT BITSPERWORD))) (PCBUS.WRITEHL 14 48 (LLSH (LOGAND CURRPAGEINBITMAP 3) 6)) (PCBUS.WRITEHL 14 49 (LRSH CURRPAGEINBITMAP 2)) (for I from 1 to HEIGHT do (\BUSBLTOUTNYBBLES DEST \RochesterBUSADDRHI BUSADDRLO NWORDS) (COND ((EQ I HEIGHT) (RETURN))) (SETQ DEST (\ADDBASE DEST \RochesterRASTERWIDTH)) (SETQ BUSADDRLO (IPLUS BUSADDRLO (UNFOLD \RochesterRASTERWIDTH NYBBLESPERWORD))) (COND ((IGEQ BUSADDRLO 32768) (* Can't let BUSADDRLO exceed MAX.SMALLP. *) (SETQ BUSADDRLO (IDIFFERENCE BUSADDRLO 32768)) (SETQ CURRPAGEINBITMAP (IPLUS CURRPAGEINBITMAP 32)) (PCBUS.WRITEHL 14 48 (LLSH (LOGAND CURRPAGEINBITMAP 3) 6)) (PCBUS.WRITEHL 14 49 (LRSH CURRPAGEINBITMAP 2))))) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT)))) ) (FILESLOAD BUSCOLOR) (RPAQQ \DANDELIONUFO.LOCKEDFNS (\DANDELIONUFO.PILOTBITBLT \DANDELIONUFO.SENDPAGE)) (DECLARE: DONTEVAL@COMPILE DOCOPY (\DANDELIONUFO.INIT) ) (PUTPROPS DANDELIONUFO COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (2638 2904 (\DANDELIONUFO.WRITE 2648 . 2902)) (2905 11658 (\DANDELIONUFO.INIT 2915 . 4263) (\DANDELIONUFO.STARTBOARD 4265 . 5304) (\DANDELIONUFO.SENDCOLORMAPENTRY 5306 . 6388) ( \DANDELIONUFO.SENDPAGE 6390 . 7342) (\DANDELIONUFO.PILOTBITBLT 7344 . 11656))))) STOP \ No newline at end of file diff --git a/lispusers/DANDELIONUFO4096 b/lispusers/DANDELIONUFO4096 new file mode 100644 index 00000000..195e1100 --- /dev/null +++ b/lispusers/DANDELIONUFO4096 @@ -0,0 +1 @@ +(FILECREATED " 5-Jun-86 23:23:29" {ERIS}LIBRARY>DANDELIONUFO4096.;19 14610 changes to: (FNS \DANDELIONUFO4096.SENDCOLORMAPENTRY \DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL ) (VARS DANDELIONUFO4096COMS) previous date: " 5-Jun-86 21:19:03" {ERIS}LIBRARY>DANDELIONUFO4096.;18) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DANDELIONUFO4096COMS) (RPAQQ DANDELIONUFO4096COMS ((* * DANDELIONUFO4096 -- Driver for the old version of UFO systems Dandelion BusMaster color board -- By Kelly Roach and Herb Jellinek. *) (CONSTANTS (NYBBLESPERWORD 4) (BITSPERNYBBLE 4) (\PCColorMapRedBase 917568) (\PCColorMapGreenBase 917584) (\PCColorMapBlueBase 917600) (\RochesterDisplayBase 917504) (\RochesterDisplayOffsetRegister.4096 917696) (\RochesterBUSADDRHI 8) (\RochesterBUSADDRLO 0) (\RochesterPIXELSPERPAGE 1024) (\RochesterRASTERWIDTH 160) (DDLPIXELSPERPAGE 1024) (DDLPIXELSPERWORD 4)) (FNS \DANDELIONUFO4096.WRITE) (FNS \DANDELIONUFO4096.INIT \DANDELIONUFO4096.STARTBOARD \DANDELIONUFO4096.SENDCOLORMAPENTRY \DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL \DANDELIONUFO4096.SENDPAGE \DANDELIONUFO4096.PILOTBITBLT) (FILES BUSCOLOR) (VARS \DANDELIONUFO4096.LOCKEDFNS) (DECLARE: DONTEVAL@COMPILE DOCOPY (P (\DANDELIONUFO4096.INIT))))) (* * DANDELIONUFO4096 -- Driver for the old version of UFO systems Dandelion BusMaster color board -- By Kelly Roach and Herb Jellinek. *) (DECLARE: EVAL@COMPILE (RPAQQ NYBBLESPERWORD 4) (RPAQQ BITSPERNYBBLE 4) (RPAQQ \PCColorMapRedBase 917568) (RPAQQ \PCColorMapGreenBase 917584) (RPAQQ \PCColorMapBlueBase 917600) (RPAQQ \RochesterDisplayBase 917504) (RPAQQ \RochesterDisplayOffsetRegister.4096 917696) (RPAQQ \RochesterBUSADDRHI 8) (RPAQQ \RochesterBUSADDRLO 0) (RPAQQ \RochesterPIXELSPERPAGE 1024) (RPAQQ \RochesterRASTERWIDTH 160) (RPAQQ DDLPIXELSPERPAGE 1024) (RPAQQ DDLPIXELSPERWORD 4) (CONSTANTS (NYBBLESPERWORD 4) (BITSPERNYBBLE 4) (\PCColorMapRedBase 917568) (\PCColorMapGreenBase 917584) (\PCColorMapBlueBase 917600) (\RochesterDisplayBase 917504) (\RochesterDisplayOffsetRegister.4096 917696) (\RochesterBUSADDRHI 8) (\RochesterBUSADDRLO 0) (\RochesterPIXELSPERPAGE 1024) (\RochesterRASTERWIDTH 160) (DDLPIXELSPERPAGE 1024) (DDLPIXELSPERWORD 4)) ) (DEFINEQ (\DANDELIONUFO4096.WRITE [LAMBDA (A D) (* N.H.Briggs "29-May-86 15:19") (PCBUS.WRITE (IPLUS \RochesterDisplayBase A) D]) ) (DEFINEQ (\DANDELIONUFO4096.INIT [LAMBDA NIL (* kbr: "15-Feb-86 12:42") (DECLARE (GLOBALVARS \DANDELIONUFO4096WSOPS \DANDELIONUFO4096INFO)) (for FN in \DANDELIONUFO4096.LOCKEDFNS do (\LOCKFN FN)) [SETQ \DANDELIONUFO4096WSOPS (create WSOPS (SETQ STARTBOARD (FUNCTION \DANDELIONUFO4096.STARTBOARD)) (SETQ STARTCOLOR (FUNCTION \BUSCOLOR.STARTCOLOR)) (SETQ STOPCOLOR (FUNCTION \BUSCOLOR.STOPCOLOR)) (SETQ EVENTFN (FUNCTION \BUSCOLOR.EVENTFN)) (SETQ SENDCOLORMAPENTRY (FUNCTION \DANDELIONUFO4096.SENDCOLORMAPENTRY)) (SETQ SENDPAGE (FUNCTION \DANDELIONUFO4096.SENDPAGE)) (SETQ PILOTBITBLT (FUNCTION \DANDELIONUFO4096.PILOTBITBLT] (SETQ \DANDELIONUFO4096INFO (create DISPLAYINFO DITYPE _ (QUOTE DANDELIONUFO4096) DIWIDTH _ 640 DIHEIGHT _ 400 DIBITSPERPIXEL _ 4 DIWSOPS _ \DANDELIONUFO4096WSOPS)) (\DEFINEDISPLAYINFO \DANDELIONUFO4096INFO]) (\DANDELIONUFO4096.STARTBOARD [LAMBDA (DISPLAY) (* N.H.Briggs "29-May-86 15:24") (* * the ufo4096 card uses a Signetics 2672 programmable video timing controller. See the Signetics databook for  details) (* * offsets (write): initialization = 0; command = 1; screen start lower = 2; screen start upper = 3; cursor address lower = 4; cursor address upper = 5; display pointer address lower = 6; display pointer address  upper = 7) (\DANDELIONUFO4096.WRITE 1 0) (* master reset) (\DANDELIONUFO4096.WRITE 1 0) (* master reset) (\DANDELIONUFO4096.WRITE 1 16) (* load IR ptr with 0 (ten values follow)) (\DANDELIONUFO4096.WRITE 0 24) (* non-interlaced 4 lines, vsync, buffer mode  independent) (\DANDELIONUFO4096.WRITE 0 (SELECTQ COLORMONITORTYPE ((NIL CONRAC) 10) (HITACHI 11) (ERROR "ILLEGAL ARG" COLORMONITORTYPE))) (* equalizing constant EC = .5  (Hact+Hfp+Hsync+Hbp) -2 (Hsync)) (\DANDELIONUFO4096.WRITE 0 25) (* Hsync width = 8, H back porch = 1) (\DANDELIONUFO4096.WRITE 0 43) (* V front porch = 8 scan lines, V back porch = 26  scan lines) (\DANDELIONUFO4096.WRITE 0 227) (* Char blink = 1/32 Vsync, 100 active rows per  screen) (\DANDELIONUFO4096.WRITE 0 39) (* 39 active "characters" per row) (\DANDELIONUFO4096.WRITE 0 0) (* cursor first line 0, last line 0  (don't care)) (\DANDELIONUFO4096.WRITE 0 0) (* lightpen line 0, no cursor blink, single height  chars, underline position scan line 0  (don't care)) (\DANDELIONUFO4096.WRITE 0 0) (* display buffer first address least significant bits = 0) (\DANDELIONUFO4096.WRITE 0 0) (* display buffer last address  (0) = 1023, display buffer first address most  significant bits = 0) (\DANDELIONUFO4096.WRITE 0 0) (* cursor blink rate = 1/32 Vsync, split screen  interrupt row 0 (don't care)) (\DANDELIONUFO4096.WRITE 1 63) (* enable light pen, display on next field, cursor on) (\DANDELIONUFO4096.WRITE 2 1) (* screen start address lower register = 1) (\DANDELIONUFO4096.WRITE 3 0) (* screen start address upper register = 0) (\DANDELIONUFO4096.WRITE 128 8) (* video control register = 8) (\DANDELIONUFO4096.WRITE 192 0) (* address offset register low = 0) (\DANDELIONUFO4096.WRITE 193 0) (* address offset register high = 0) ]) (\DANDELIONUFO4096.SENDCOLORMAPENTRY (LAMBDA (FDEV COLOR ACTUALRGB) (* kbr: " 5-Jun-86 23:16") (* sends the Ith entry of the colormap  COLORMAP to the extension bus.) (PROG (HLS RGB) (SETQ HLS (RGBTOHLS ACTUALRGB)) (replace (HLS LIGHTNESS) of HLS with (FMAX (fetch (HLS LIGHTNESS) of HLS) .6)) (SETQ RGB (HLSTORGB HLS)) (PCBUS.WRITE (IPLUS \PCColorMapRedBase COLOR) (\DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL (fetch (RGB RED) of RGB))) (PCBUS.WRITE (IPLUS \PCColorMapGreenBase COLOR) (\DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL (fetch (RGB GREEN) of RGB))) (PCBUS.WRITE (IPLUS \PCColorMapBlueBase COLOR) (\DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL (fetch (RGB BLUE) of RGB)))))) (\DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL (LAMBDA (COLOR) (* kbr: " 5-Jun-86 23:14") (PROG (ANSWER) (RETURN (FOLDLO COLOR 16)) (SETQ ANSWER (IMIN HIGHFUDGE (IMAX (FOLDLO COLOR 16) LOWFUDGE))) (RETURN ANSWER)))) (\DANDELIONUFO4096.SENDPAGE [LAMBDA (PAGE PAGE#) (* kbr: "16-Feb-86 00:17") (PROG (DISPINTERRUPT) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (PCBUS.WRITE \RochesterDisplayOffsetRegister.4096 (LLSH (LOGAND PAGE# 3) 6)) (PCBUS.WRITE (ADD1 \RochesterDisplayOffsetRegister.4096) (LRSH PAGE# 2)) (* ((1024 pixels / page) /  (16 pixels / offset)) = 64 offsets / page) (\BUSBLTOUTNYBBLES PAGE \RochesterBUSADDRHI \RochesterBUSADDRLO WORDSPERPAGE) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT]) (\DANDELIONUFO4096.PILOTBITBLT (LAMBDA (PILOTBBT N) (* kbr: " 5-Jun-86 21:17") (PROG (DEST DESTBIT WIDTH HEIGHT BUSADDRHI BUSADDRLO NWORDS ABSCURRPAGE CURRPAGEINBITMAP DISPINTERRUPT) (* The busmaster UPDATEDAEMON is a narrow communication bottleneck from the  color screen bitmap to the color frame buffer.  We work around this bottleneck by communicating small important changes to the  color screen bitmap quickly and big less important changes slower.  *) (* We try to make small changes that cross lots of pages appear visible in the  frame buffer quickly by writing to both color screen bitmap and frame buffer.  Big changes, which could be overwritten by other big changes before the  UPDATEDAEMON notices them (and so save us time this way) are best left to the  UPDATEDAEMON to handle. *) (* First, output to the color screen  bitmap. *) (\PILOTBITBLT PILOTBBT N) (* Probably a case worth optimizing: cursors, carets, characters, vertical  drawlines, and vertical scroll bars. \BUSBLTOUTNYBBLES works in words, not  pixels (nybbles)%. We handle this problem by getting the values for our pixels  from the DEST we just did our \PILOTBITBLT to, slopping over to a few unchanged  pixels when necessary. *) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))(* \PUTBASE \EM.DISPINTERRUPT 0 0) (SETQ DEST (fetch (PILOTBBT PBTDEST) of PILOTBBT)) (SETQ DESTBIT (fetch (PILOTBBT PBTDESTBIT) of PILOTBBT)) (SETQ WIDTH (fetch (PILOTBBT PBTWIDTH) of PILOTBBT)) (SETQ HEIGHT (fetch (PILOTBBT PBTHEIGHT) of PILOTBBT)) (SETQ ABSCURRPAGE (fetch (POINTER PAGE#) of DEST)) (SETQ CURRPAGEINBITMAP (IDIFFERENCE ABSCURRPAGE ColorScreenBitMapBasePage)) (SETQ NWORDS (IPLUS (FOLDHI (IPLUS DESTBIT WIDTH -1) BITSPERWORD) (IMINUS (FOLDLO DESTBIT BITSPERWORD)) 1)) (SETQ BUSADDRLO (UNFOLD (IPLUS (fetch (POINTER WORDINPAGE) of DEST) (FOLDLO DESTBIT BITSPERWORD)) NYBBLESPERWORD)) (SETQ DEST (\ADDBASE DEST (FOLDLO DESTBIT BITSPERWORD))) (PCBUS.WRITEHL 14 192 (LLSH (LOGAND CURRPAGEINBITMAP 3) 6)) (PCBUS.WRITEHL 14 193 (LRSH CURRPAGEINBITMAP 2)) (for I from 1 to HEIGHT do (\BUSBLTOUTNYBBLES DEST \RochesterBUSADDRHI BUSADDRLO NWORDS) (COND ((EQ I HEIGHT) (RETURN))) (SETQ DEST (\ADDBASE DEST \RochesterRASTERWIDTH)) (SETQ BUSADDRLO (IPLUS BUSADDRLO (UNFOLD \RochesterRASTERWIDTH NYBBLESPERWORD))) (COND ((IGEQ BUSADDRLO 32768) (* Can't let BUSADDRLO exceed  MAX.SMALLP. *) (SETQ BUSADDRLO (IDIFFERENCE BUSADDRLO 32768)) (SETQ CURRPAGEINBITMAP (IPLUS CURRPAGEINBITMAP 32)) (PCBUS.WRITEHL 14 192 (LLSH (LOGAND CURRPAGEINBITMAP 3) 6)) (PCBUS.WRITEHL 14 193 (LRSH CURRPAGEINBITMAP 2))))) (* \PUTBASE \EM.DISPINTERRUPT 0  DISPINTERRUPT) ))) ) (FILESLOAD BUSCOLOR) (RPAQQ \DANDELIONUFO4096.LOCKEDFNS (\DANDELIONUFO4096.PILOTBITBLT \DANDELIONUFO4096.SENDPAGE)) (DECLARE: DONTEVAL@COMPILE DOCOPY (\DANDELIONUFO4096.INIT) ) (PUTPROPS DANDELIONUFO4096 COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (3245 3443 (\DANDELIONUFO4096.WRITE 3255 . 3441)) (3444 14335 (\DANDELIONUFO4096.INIT 3454 . 4603) (\DANDELIONUFO4096.STARTBOARD 4605 . 7879) (\DANDELIONUFO4096.SENDCOLORMAPENTRY 7881 . 8953) (\DANDELIONUFO4096.SENDCOLORMAPENTRY.LEVEL 8955 . 9302) (\DANDELIONUFO4096.SENDPAGE 9304 . 10005 ) (\DANDELIONUFO4096.PILOTBITBLT 10007 . 14333))))) STOP \ No newline at end of file diff --git a/lispusers/DATATYPESPLUS b/lispusers/DATATYPESPLUS new file mode 100644 index 00000000..800c3d6e --- /dev/null +++ b/lispusers/DATATYPESPLUS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "18-Feb-88 11:36:24" {ERINYES}LYRIC>DATATYPESPLUS.\;1 32709 |previous| |date:| "29-Jan-88 18:11:10" {QV}LISP>MAPLE>DATATYPESPLUS.\;4) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT DATATYPESPLUSCOMS) (RPAQQ DATATYPESPLUSCOMS ( (* |;;| "System functions that (unfortunately) had to be redefined to add the record field types REVERSEDWORD and REVERSEDFIXP. These are a 16 bit (unsigned) word with LSB, MSB and a 32 bit integer with LSW, MSW in the same reversed word format.") (* |;;| "") (DECLARE\: DONTCOPY (FILES (LOADCOMP) LLDATATYPE)) (FNS FETCHFIELD REPLACEFIELD COMPILEDFETCHFIELD COMPILEDREPLACEFIELD TRANSLATE.DATATYPE \\PUTREVERSEDFIXP) (* |;;| "") (VARS DATATYPEFIELDTYPES))) (* |;;| "System functions that (unfortunately) had to be redefined to add the record field types REVERSEDWORD and REVERSEDFIXP. These are a 16 bit (unsigned) word with LSB, MSB and a 32 bit integer with LSW, MSW in the same reversed word format." ) (* |;;| "") (DECLARE\: DONTCOPY (FILESLOAD (LOADCOMP) LLDATATYPE) ) (DEFINEQ (FETCHFIELD (LAMBDA (DESCRIPTOR DATUM) (* \; "Edited 17-Dec-87 18:45 by Briggs") (* |;;| "retrieves a data field from a user data structure.") (PROG ((TN (|fetch| |fdTypeName| |of| DESCRIPTOR)) (OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR))) (AND TN (SETQ DATUM (\\DTEST DATUM TN))) (RETURN (SELECTQ (|fetch| |fdType| |of| DESCRIPTOR) ((POINTER XPOINTER FULLPOINTER FULLXPOINTER) (\\GETBASEPTR DATUM OFFSET)) (FLOATP (MAKEFLOATNUMBER (\\GETBASE DATUM OFFSET) (\\GETBASE (\\ADDBASE DATUM 1) OFFSET))) (FIXP (\\MAKENUMBER (\\GETBASE DATUM OFFSET) (\\GETBASE (\\ADDBASE DATUM 1) OFFSET))) (SWAPPEDFIXP (\\MAKENUMBER (\\GETBASE (\\ADDBASE DATUM 1) OFFSET) (\\GETBASE DATUM OFFSET))) (REVERSEDFIXP (PROG ((HI (\\GETBASE (\\ADDBASE DATUM 1) OFFSET)) (LO (\\GETBASE DATUM OFFSET))) (RETURN (\\MAKENUMBER (LOGOR (LRSH HI 8) (LLSH (LOGAND HI 255) 8)) (LOGOR (LRSH LO 8) (LLSH (LOGAND LO 255) 8)))))) (PROG ((FT (|fetch| |fdType| |of| DESCRIPTOR)) (OFF OFFSET)) (RETURN (SELECTQ (CAR FT) (BITS (LOGAND (LRSH (\\GETBASE DATUM OFF) (|BitFieldShift| (CDR FT))) (|BitFieldMask| (CDR FT)))) (SIGNEDBITS ((LAMBDA (N WIDTH) (COND ((IGREATERP N (SUB1 (LLSH 1 (SUB1 WIDTH)))) (SUB1 (IDIFFERENCE N (SUB1 (LLSH 1 WIDTH))))) (T N))) (LOGAND (LRSH (\\GETBASE DATUM OFF) (|BitFieldShift| (CDR FT))) (|BitFieldMask| (CDR FT))) (|BitFieldWidth| (CDR FT)))) (LONGBITS (\\MAKENUMBER (LOGAND (LRSH (\\GETBASE DATUM OFF) (|BitFieldShift| (CDR FT))) (|BitFieldMask| (CDR FT))) (\\GETBASE (\\ADDBASE DATUM 1) OFF))) (FLAGBITS (NEQ (LOGAND (\\GETBASE DATUM OFF) (|BitFieldShiftedMask| (CDR FT))) 0)) (REVERSEDWORD (LOGOR (LRSH (\\GETBASE DATUM OFF) 8) (LLSH (LOGAND (\\GETBASE DATUM OFF) 255) 8))) (LISPERROR "ILLEGAL ARG" DESCRIPTOR))))))))) (REPLACEFIELD (LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* \; "Edited 11-Dec-87 12:28 by N.H.Briggs") (* \;  "replace a field in a user data structure. return coerced value.") (PROG ((OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR)) (FT (|fetch| |fdType| |of| DESCRIPTOR)) (TN (|fetch| |fdTypeName| |of| DESCRIPTOR)) SHIFT MASK) (AND TN (SETQ DATUM (\\DTEST DATUM TN))) (RETURN (SELECTQ FT ((POINTER FULLPOINTER) (\\RPLPTR DATUM OFFSET NEWVALUE)) (XPOINTER (* \; "no ref count, hi bits used") (PUTBASEPTRX DATUM OFFSET NEWVALUE)) (FULLXPOINTER (\\PUTBASEPTR DATUM OFFSET NEWVALUE)) (FLOATP (\\PUTBASEFLOATP DATUM OFFSET NEWVALUE)) (FIXP (\\PUTFIXP (\\ADDBASE DATUM OFFSET) NEWVALUE) NEWVALUE) (SWAPPEDFIXP (\\PUTSWAPPEDFIXP (\\ADDBASE DATUM OFFSET) NEWVALUE) NEWVALUE) (REVERSEDFIXP (\\PUTREVERSEDFIXP (\\ADDBASE DATUM OFFSET) NEWVALUE) NEWVALUE) (SELECTQ (CAR FT) (BITS (LOGAND (LRSH (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND (\\GETBASE DATUM OFFSET) (LOGXOR 65535 (LLSH (SETQ MASK (|BitFieldMask| (CDR FT))) (SETQ SHIFT (|BitFieldShift| (CDR FT)))))) (LLSH (LOGAND NEWVALUE MASK) SHIFT))) SHIFT) MASK)) (SIGNEDBITS ((LAMBDA (X) (COND ((IGREATERP X (SUB1 (LLSH 1 (SUB1 (|BitFieldWidth| (CDR FT)))))) (SUB1 (IDIFFERENCE X (SUB1 (LLSH 1 (|BitFieldWidth| (CDR FT))))))) (T X))) (LOGAND (LRSH (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND (\\GETBASE DATUM OFFSET) (LOGXOR 65535 (LLSH (SETQ MASK (|BitFieldMask| (CDR FT))) (SETQ SHIFT (|BitFieldShift| (CDR FT)))))) (LLSH (LOGAND (LOGAND NEWVALUE (SUB1 (LLSH 1 (|BitFieldWidth| (CDR FT))))) MASK) SHIFT))) SHIFT) MASK))) (FLAGBITS (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND (\\GETBASE DATUM OFFSET) (LOGXOR 65535 (LLSH (SETQ MASK (|BitFieldMask| (CDR FT))) (SETQ SHIFT (|BitFieldShift| (CDR FT)))))) (LLSH (LOGAND (COND (NEWVALUE 65535) (T 0)) MASK) SHIFT))) (AND NEWVALUE T)) (LONGBITS (PROG (LO HI) (.UNBOX. NEWVALUE HI LO) (UNINTERRUPTABLY (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND (\\GETBASE DATUM OFFSET) (LOGXOR 65535 (LLSH (SETQ MASK (|BitFieldMask| (CDR FT))) (SETQ SHIFT (|BitFieldShift| (CDR FT)))))) (LLSH (LOGAND HI MASK) SHIFT))) (\\PUTBASE DATUM (ADD1 OFFSET) LO))) NEWVALUE) (REVERSEDWORD (\\PUTBASE DATUM OFFSET (LOGOR (LRSH NEWVALUE 8) (LLSH (LOGAND NEWVALUE 255) 8))) NEWVALUE) (LISPERROR "ILLEGAL ARG" DESCRIPTOR))))))) (COMPILEDFETCHFIELD (LAMBDA (X FASTFLG) (* \; "Edited 15-Dec-87 12:33 by N.H.Briggs") (COND ((EQ (CAR (LISTP (CAR X))) 'QUOTE) ((LAMBDA (DESCRIPTOR DATUM) (PROG (TYPENAME) (COND ((AND (NOT FASTFLG) (SETQ TYPENAME (|fetch| |fdTypeName| |of| DESCRIPTOR))) (SETQ DATUM (LIST (FUNCTION \\DTEST) DATUM (KWOTE TYPENAME))))) (RETURN (SELECTQ (|fetch| |fdType| |of| DESCRIPTOR) ((POINTER XPOINTER FULLPOINTER FULLXPOINTER) (LIST '\\GETBASEPTR DATUM (|fetch| |fdOffset| |of| DESCRIPTOR))) (SWAPPEDXPOINTER `((OPENLAMBDA (D) (\\VAG2 (\\GETBASE D ,(ADD1 (|fetch| |fdOffset| |of| DESCRIPTOR)) ) (\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR)))) ,DATUM)) (FLOATP `(\\GETBASEFLOATP ,DATUM ,(|fetch| |fdOffset| |of| DESCRIPTOR))) (FIXP `(\\GETBASEFIXP ,DATUM ,(|fetch| |fdOffset| |of| DESCRIPTOR))) (SWAPPEDFIXP `((OPENLAMBDA (D) (\\MAKENUMBER (\\GETBASE D ,(ADD1 (|fetch| |fdOffset| |of| DESCRIPTOR))) (\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR) ))) ,DATUM)) (REVERSEDFIXP `((OPENLAMBDA (D) (\\MAKENUMBER (LOGOR (LRSH (\\GETBASE D ,(ADD1 (|fetch| |fdOffset| |of| DESCRIPTOR))) 8) (LLSH (LOGAND (\\GETBASE D ,(ADD1 (|fetch| |fdOffset| |of| DESCRIPTOR))) 255) 8)) (LOGOR (LRSH (\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR )) 8) (LLSH (LOGAND (\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR )) 255) 8)))) ,DATUM)) (PROG ((FT (|fetch| |fdType| |of| DESCRIPTOR)) (OFF (|fetch| |fdOffset| |of| DESCRIPTOR))) (RETURN (SELECTQ (CAR FT) (BITS (LIST '\\GETBITS DATUM OFF (CDR FT))) (SIGNEDBITS `(SIGNED (\\GETBITS ,DATUM ,OFF ,(CDR FT)) ,(|BitFieldWidth| (CDR FT)))) (FLAGBITS (LIST '\\TESTBITS DATUM OFF (CDR FT))) (REVERSEDWORD `((OPENLAMBDA (D) (LOGOR (\\GETBITS D ,OFF 7) (LLSH (\\GETBITS D ,OFF 135) 8))) ,DATUM)) (LONGBITS `((OPENLAMBDA (D) (\\MAKENUMBER (\\GETBITS D ,OFF ,(CDR FT)) (\\GETBASE D ,(ADD1 OFF)))) ,DATUM)) (SHOULDNT)))))))) (CADAR X) (CADR X))) (T 'IGNOREMACRO)))) (COMPILEDREPLACEFIELD (LAMBDA (X FASTFLG RPLVALFLG) (* \; "Edited 29-Jan-88 17:50 by Briggs") (* |compile| |code| |for| |replacing| |field| |values.|  |Goes| |to| |great| |length| |to| |ensure| |that| |the| |coerced| |value| |is|  |returned|) (COND ((EQ (CAR (LISTP (CAR X))) 'QUOTE) ((LAMBDA (DESCRIPTOR DATUM NEWVALUE) (PROG ((TYPENAME (|fetch| |fdTypeName| |of| DESCRIPTOR)) (FT (|fetch| |fdType| |of| DESCRIPTOR)) (OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR))) (COND ((AND (NOT FASTFLG) TYPENAME) (SETQ DATUM (LIST (FUNCTION \\DTEST) DATUM (KWOTE TYPENAME))))) (RETURN (SELECTQ FT ((POINTER FULLPOINTER) (LIST (FUNCTION \\RPLPTR) DATUM OFFSET NEWVALUE)) (XPOINTER (LIST (FUNCTION PUTBASEPTRX) DATUM OFFSET NEWVALUE)) (FULLXPOINTER (LIST '\\PUTBASEPTR DATUM OFFSET NEWVALUE)) (SWAPPEDXPOINTER `((OPENLAMBDA (D R) (\\PUTBASE D ,OFFSET (\\LOLOC R)) (\\PUTBASE D ,(ADD1 OFFSET) (\\HILOC R)) R) ,DATUM ,NEWVALUE)) (FIXP `(\\PUTBASEFIXP ,DATUM ,OFFSET ,NEWVALUE)) (SWAPPEDFIXP `(\\PUTSWAPPEDFIXP (\\ADDBASE ,DATUM ,OFFSET) ,NEWVALUE)) (REVERSEDFIXP `(\\PUTREVERSEDFIXP (\\ADDBASE ,DATUM ,OFFSET) ,NEWVALUE)) (FLOATP `(\\PUTBASEFLOATP ,DATUM ,OFFSET ,NEWVALUE)) (SELECTQ (CAR FT) (BITS (LIST '\\PUTBITS DATUM OFFSET (CDR FT) NEWVALUE)) (REVERSEDWORD `((OPENLAMBDA (D V) (\\PUTBITS D ,OFFSET 7 (LOGAND V 255)) (\\PUTBITS D ,OFFSET 135 (LRSH V 8)) V) ,DATUM ,NEWVALUE)) (LONGBITS (LIST (SUBPAIR '(OFFSET FT) (LIST OFFSET (CDR FT)) '(OPENLAMBDA (D V) (\\PUTBITS D OFFSET FT (\\HINUM V)) (\\PUTBASE D (ADD1 OFFSET) (\\LONUM V)) V)) DATUM NEWVALUE)) (SIGNEDBITS `(SIGNED (\\PUTBITS ,DATUM ,OFFSET ,(CDR FT) (UNSIGNED ,NEWVALUE ,(|BitFieldWidth| (CDR FT)))) ,(|BitFieldWidth| (CDR FT)))) (FLAGBITS `(NEQ (\\PUTBITS ,DATUM ,OFFSET ,(CDR FT) (COND (,NEWVALUE ,(|BitFieldMask| (CDR FT))) (T 0))) 0)) (RETURN 'IGNOREMACRO)))))) (CADAR X) (CADR X) (CADDR X))) (T 'IGNOREMACRO)))) (TRANSLATE.DATATYPE (LAMBDA (TYPENAME FIELDSPECS) (* DECLARATIONS\: (RECORD SPEC  (N LEN . FD))) (DECLARE (SPECVARS TYPENAME UNUSED BIT OFFSET FD)) (* \;  "Edited 11-Dec-87 12:00 by N.H.Briggs") (COND ((NULL TYPENAME)) ((OR (NOT (LITATOM TYPENAME)) (EQ TYPENAME '**DEALLOC**)) (ERROR "Invalid type name" TYPENAME))) (PROG ((N 0) UNUSED (OFFSET 0) (BIT 0) DLIST REUSE LEN FD) (SETQ DLIST (|for| S |in| FIELDSPECS |collect| (|create| SPEC N _ (|add| N 1) LEN _ (SELECTQ S ((POINTER XPOINTER) 24) ((FIXP FLOATP SWAPPEDFIXP REVERSEDFIXP FULLPOINTER SWAPPEDXPOINTER FULLXPOINTER) BITSPERCELL) (FLAG (SETQQ S FLAGBITS) 1) (BYTE (SETQQ S BITS) BITSPERBYTE) (WORD (SETQQ S BITS) BITSPERWORD) (REVERSEDWORD BITSPERWORD) (SIGNEDWORD (SETQQ S SIGNEDBITS) BITSPERWORD) (SELECTQ (CAR (LISTP S)) ((BITS FLAGBITS SIGNEDBITS) (PROG1 (CADR S) (SETQ S (CAR S)))) (ERROR "invalid field spec: " S))) FD _ (|create| |FldDsc| |fdTypeName| _ TYPENAME |fdType| _ S |fdOffset| _ NIL)))) (|for| S |in| DLIST |do| (|replace| |fdOffset| |of| (SETQ FD (|fetch| FD |of| S)) |with| (SELECTQ (|fetch| |fdType| |of| FD) ((POINTER XPOINTER) (COND ((AND TYPENAME (|find| X |in| UNUSED |suchthat| (AND (EQ 0 (LOGAND (CAR X) 1)) (IGEQ (CADDR X) 8) (EQ (IPLUS (CADR X) (CADDR X)) BITSPERWORD) (|find| Y |in| UNUSED |suchthat| (AND (EQ (CAR Y) (ADD1 (CAR X))) (EQ (CADDR Y) BITSPERWORD)))))) (* |unused| 24 |bit| |quantity|) (* |this| |case| |not| |implemented|  |yet|) )) (COND ((IGREATERP BIT 8) (* |Less| |than| 8 |bits| |left| |in|  |this| |word|) (\\REUSETO BITSPERWORD))) (COND ((ODDP OFFSET WORDSPERCELL) (* |not| |on| |double| |word|  |boundary|) (\\REUSETO BITSPERWORD))) (COND ((NEQ BIT 8) (\\REUSETO 8 (EQ BIT 0)))) (SETQ BIT 0) (PROG1 OFFSET (|add| OFFSET WORDSPERCELL))) ((FIXP SWAPPEDFIXP REVERSEDFIXP FLOATP SWAPPEDXPOINTER) (* 32 |bit| |quantities|) (COND ((NEQ BIT 0) (\\REUSETO BITSPERWORD))) (PROG1 OFFSET (|add| OFFSET WORDSPERCELL))) ((FULLPOINTER FULLXPOINTER) (* 32 |bit| |doubleword-aligned|  |quantities|) (COND ((NEQ BIT 0) (\\REUSETO BITSPERWORD))) (COND ((ODDP OFFSET WORDSPERCELL) (\\REUSETO BITSPERWORD))) (PROG1 OFFSET (|add| OFFSET WORDSPERCELL))) ((BITS FLAGBITS SIGNEDBITS REVERSEDWORD) (SETQ LEN (|fetch| LEN |of| S)) (COND ((AND TYPENAME (SETQ REUSE (|find| X |in| UNUSED |suchthat| (ILEQ LEN (CADDR X))))) (RPLACA (CDDR REUSE) (IDIFFERENCE (CAR (CDDR REUSE)) LEN)) (|replace| |fdType| |of| FD |with| (CONS (|fetch| |fdType| |of| FD) (|MakeBitField| (CADR REUSE) LEN))) (|add| (CADR REUSE) LEN) (CAR REUSE)) ((IGREATERP LEN BITSPERWORD) (* |more| |than| 1 |word| -  |Must| |right| |justify| |first| |word|) (SETQ LEN (IDIFFERENCE LEN BITSPERWORD)) (COND ((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT)) (\\REUSETO BITSPERWORD))) (COND ((NEQ (IDIFFERENCE BITSPERWORD BIT) LEN) (\\REUSETO (IDIFFERENCE BITSPERWORD LEN)))) (|replace| |fdType| |of| FD |with| (CONS 'LONGBITS (|MakeBitField| BIT LEN))) (SETQ BIT 0) (PROG1 OFFSET (|add| OFFSET 2))) (T (COND ((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT)) (\\REUSETO BITSPERWORD))) (|replace| |fdType| |of| FD |with| (CONS (|fetch| |fdType| |of| FD) (|MakeBitField| BIT LEN))) (|add| BIT LEN) (PROG1 OFFSET (COND ((EQ BIT BITSPERWORD) (SETQ BIT 0) (|add| OFFSET 1))))))) (SHOULDNT)))) (COND (TYPENAME (COND ((NEQ BIT 0) (\\REUSETO BITSPERWORD))) (|while| (ODDP OFFSET WORDSPERCELL) |do| (|add| OFFSET 1)) (COND ((IGREATERP OFFSET |\\MDSIncrement|) (ERROR TYPENAME "DATATYPE TOO BIG"))))) (RETURN (CONS OFFSET (MAPCAR DLIST (FUNCTION (LAMBDA (X) (|fetch| FD |of| X))))))))) (\\PUTREVERSEDFIXP (LAMBDA (PTR NUM) (* \; "Edited 11-Dec-87 12:19 by N.H.Briggs") (* |;;| "Store in completely reversed byte order") (PROG (HI LO) (.UNBOX. NUM HI LO) (|replace| (FIXP LONUM) |of| PTR |with| (LOGOR (LRSH HI 8) (LLSH (LOGAND HI 255) 8))) (|replace| (FIXP HINUM) |of| PTR |with| (LOGOR (LRSH LO 8) (LLSH (LOGAND LO 255) 8))) (RETURN NUM)))) ) (* |;;| "") (RPAQQ DATATYPEFIELDTYPES ((FLOATP 0.0) (FIXP 0) (SWAPPEDFIXP 0) (REVERSEDFIXP 0) (POINTER NIL) (XPOINTER NIL) (FULLPOINTER NIL) (FULLXPOINTER NIL) (SWAPPEDXPOINTER NIL) (FLAG NIL) (BYTE 0) (WORD 0) (REVERSEDWORD 0) (SIGNEDWORD 0))) (PUTPROPS DATATYPESPLUS COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1487 32010 (FETCHFIELD 1497 . 5916) (REPLACEFIELD 5918 . 12320) (COMPILEDFETCHFIELD 12322 . 17667) (COMPILEDREPLACEFIELD 17669 . 22035) (TRANSLATE.DATATYPE 22037 . 31268) ( \\PUTREVERSEDFIXP 31270 . 32008))))) STOP \ No newline at end of file diff --git a/lispusers/DATE b/lispusers/DATE new file mode 100644 index 00000000..0ef8c74e --- /dev/null +++ b/lispusers/DATE @@ -0,0 +1 @@ +(FILECREATED "18-Feb-87 15:42:27" {SUMEX-AIM}PS:DATE.;4 19668 previous date: "17-Feb-87 14:29:37" {SUMEX-AIM}DATE.;7) (* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) (PRETTYCOMPRINT DATECOMS) (RPAQQ DATECOMS ((* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (FNS DATEOBJ DATEOBJP DATE.DISPLAYFN DATE.IMAGEBOXFN CURRENT.DISPLAY.FONT DATE.PUTFN DATE.GETFN DATE.BUTTONEVENTINFN DATES.TEMPLATE AMPM DATES.MENU.APPLY DATES.MENU.WHENSELECTEDFN DATES.SET FINDDAY FINDHOUR FINDMONTH FINDTIME FINDYEAR NUMP WHICHDATE) (RECORDS DATEOBJ STREAM FONTCLASS))) (* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (DEFINEQ (DATEOBJ (LAMBDA (TEMPLATE) (* fsg "23-Jul-86 09:53") (* Create an instance of a date imageobj. A dateobj is also defined as a record with a  datestring field. *) (LET* ((TEMPLATE.TYPE (OR TEMPLATE '(M D Y F))) (DATEANDTIME (MKSTRING (DATE))) (DISPLAYDATE (MKSTRING (DATES.TEMPLATE DATEANDTIME TEMPLATE.TYPE))) (NEWOBJ (IMAGEOBJCREATE (create DATEOBJ DATESTRING _ DATEANDTIME DISPLAY.DATE _ DISPLAYDATE TEMPLATE.DATE _ TEMPLATE.TYPE) (IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN) (FUNCTION DATE.IMAGEBOXFN) (FUNCTION DATE.PUTFN) (FUNCTION DATE.GETFN) (FUNCTION NILL) (FUNCTION DATE.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))))) (* By convention, every image object will have a type  property associated with it that will facilitate  imageobj mapping in a TEdit file.) (IMAGEOBJPROP NEWOBJ 'TYPE 'DATEOBJ) NEWOBJ))) (DATEOBJP (LAMBDA (IMOBJ) (* ss: "24-Jun-85 16:33") (* Tests an imageobj to see if it is a date imageobject. By convention, testing functions for an imageobject will  be named (CONCAT "P")) (AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE) 'DATEOBJ)))) (DATE.DISPLAYFN (LAMBDA (OBJ STREAM STREAMTYPE HOSTSTREAM) (* fsg "17-Feb-87 09:28") (* * Display function for date imageobjs.) (PRIN1 (fetch DISPLAY.DATE of (fetch OBJECTDATUM of OBJ)) STREAM))) (DATE.IMAGEBOXFN (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "15-Feb-87 14:05") (* * Return the ImageBox for the date string. The size is determined by the stream's current font.) (DSPFONT (CURRENT.DISPLAY.FONT STREAM) STREAM) (create IMAGEBOX XSIZE _(STRINGWIDTH (fetch DISPLAY.DATE of (fetch OBJECTDATUM of OBJ)) STREAM) YSIZE _(FONTPROP STREAM 'HEIGHT) YDESC _(FONTPROP STREAM 'DESCENT) XKERN _ 0))) (CURRENT.DISPLAY.FONT (LAMBDA (STREAM) (* fsg "17-Feb-87 10:19") (* * Return the current font. This function is here instead of TMAX because the DATE code is also used in the  LetterHead code.) (LET ((CURRENT.FONT (fetch CLFONT of (with TEXTSTREAM (TEXTSTREAM (CAR (fetch \WINDOW of TEXTOBJ))) CURRENTLOOKS)))) (COND ((TYPENAMEP CURRENT.FONT 'FONTDESCRIPTOR) CURRENT.FONT) ((TYPENAMEP CURRENT.FONT 'FONTCLASS) (fetch DISPLAYFD of CURRENT.FONT)) (T (SHOULDNT "Can't get current font")))))) (DATE.PUTFN (LAMBDA (DATEOBJ STREAM) (* fsg " 4-Feb-87 09:40") (PRIN2 (LIST 'Date (fetch (DATEOBJ TEMPLATE.DATE) of (fetch OBJECTDATUM of DATEOBJ))) STREAM))) (DATE.GETFN (LAMBDA (STREAM) (* fsg " 4-Feb-87 09:42") (OR (WINDOWPROP (PROCESSPROP (THIS.PROCESS) 'WINDOW) 'IMAGEOBJ.MENUW) (AND (FGETD 'TSP.FMMENU) (TSP.FMMENU (TEXTSTREAM (PROCESSPROP (THIS.PROCESS) 'WINDOW))))) (APPLY 'DATEOBJ (CDR (READ STREAM))))) (DATE.BUTTONEVENTINFN (LAMBDA (DATEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* fsg "26-Jan-87 10:06") (AND (MOUSESTATE MIDDLE) (LET ((DATE.MENU (create MENU TITLE _ "Date Menu" ITEMS _ '((Month% Day,% Year (DATES.TEMPLATE DATE '(M D Y F)) "Insert current date as %"March 8, 1952%"") (Month/Day/Year (DATES.TEMPLATE DATE '(M D Y A)) "Insert current date as %"3/8/52%"") (Day% Month,% Year (DATES.TEMPLATE DATE '(D M Y F)) "Insert current date as %"8 March, 1952%"") (Day/Month/Year (DATES.TEMPLATE DATE '(D M Y A)) "Insert current date as %"8/3/52%"") (Time (DATES.TEMPLATE DATE '(T F)) "Insert current time as %"four thirty p.m.%"") (Numbered% Time (DATES.TEMPLATE DATE '(T A)) "Insert current time as %"4:30 p.m.%"") (Military% Time (DATES.TEMPLATE DATE '(T E)) "Insert current time as %"16:30%"")) WHENSELECTEDFN _(FUNCTION DATES.MENU.WHENSELECTEDFN)))) (PUTMENUPROP DATE.MENU 'IMAGEOBJ DATEOBJ) (MENU DATE.MENU) 'CHANGED)))) (DATES.TEMPLATE (LAMBDA (DATE TEMPLATE) (* fsg "24-Jul-86 14:43") (* * comment) (COND (TEMPLATE (LET ((VERSION (if (EQUAL (LAST TEMPLATE) '(A)) then 'ABBREV else (if (EQUAL (LAST TEMPLATE) '(F)) then 'FULL else 'EURO))) (FUNCLST '((D FINDDAY) (M FINDMONTH) (Y FINDYEAR)))) (COND ((EQ (CAR TEMPLATE) T) (FINDTIME DATE VERSION)) (T (LET ((CH (if (EQ VERSION 'ABBREV) then "/" else " "))) (CONCAT (APPLY (CADR (ASSOC (CAR TEMPLATE) FUNCLST)) (LIST DATE VERSION)) CH (APPLY (CADR (ASSOC (CADR TEMPLATE) FUNCLST)) (LIST DATE VERSION)) (if (EQUAL CH " ") then ", " else CH) (APPLY (CADR (ASSOC (CADDR TEMPLATE) FUNCLST)) (LIST DATE VERSION)))))))) (DATE)))) (AMPM (LAMBDA (HOUR) (if (OR (LESSP (MKATOM HOUR) 12) (EQUAL (MKATOM HOUR) 24)) then "a.m." else "p.m."))) (DATES.MENU.APPLY (LAMBDA (ITEM MENU) (* fsg "31-Jul-86 10:18") (* This function serves the purpose of calculating the stream and the editing window from information stored on the window containing the menu. It then applies the appropiate function for each ITEM in the menu*) (SETQ ITEM (COND ((ATOM ITEM) ITEM) (T (CAR ITEM)))) (LET* ((DATE.RECORD (fetch OBJECTDATUM of (GETMENUPROP MENU 'IMAGEOBJ))) (DATE (fetch DATESTRING of DATE.RECORD))) (COND ((fetch ITEMS of MENU) (LET ((FUNCALL (CADR (ASSOC ITEM (fetch ITEMS of MENU))))) (replace DISPLAY.DATE of DATE.RECORD with (EVAL FUNCALL)) (replace TEMPLATE.DATE of DATE.RECORD with (CADAR (LAST FUNCALL))))))))) (DATES.MENU.WHENSELECTEDFN (LAMBDA (ITEM MENU MB) (* fsg "28-Jul-86 14:57") (COND ((OR (EQ MB 'LEFT) (EQ MB 'MIDDLE)) (DATES.MENU.APPLY ITEM MENU))))) (DATES.SET (LAMBDA (PROPERTY VALUE) (WINDOWPROP (CREATEW) PROPERTY VALUE) VALUE)) (FINDDAY (LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:28") (MKATOM (if (NUMP (SUBSTRING OLDDATE 1 2)) then (SUBSTRING OLDDATE 1 2) else (SUBSTRING OLDDATE 2 2))))) (FINDHOUR (LAMBDA (HOUR) (* ss: " 8-Feb-86 17:49") (COND ((LESSP (MKATOM HOUR) 13) (COND ((LESSP (MKATOM HOUR) 10) (MKSTRING (CADR (UNPACK HOUR)))) (T HOUR))) (T (MKSTRING (SELECTQ (MKATOM HOUR) (13 1) (14 2) (15 3) (16 4) (17 5) (18 6) (19 7) (20 8) (21 9) (22 10) (23 11) (24 12) NIL)))))) (FINDMONTH (LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:38") (PROG ((DATES '((Jan 1 January) (Feb 2 February) (Mar 3 March) (Apr 4 April) (May 5 May) (Jun 6 June) (Jul 7 July) (Aug 8 August) (Sep 9 September) (Oct 10 October) (Nov 11 November) (Dec 12 December))) (OUTPUT NIL)) (if (EQ VERSION 'ABBREV) then (SETQ OUTPUT (CAR (CDR (ASSOC (MKATOM (SUBSTRING OLDDATE 4 6)) DATES)))) else (SETQ OUTPUT (CAR (CDDR (ASSOC (MKATOM (SUBSTRING OLDDATE 4 6)) DATES))))) (RETURN OUTPUT)))) (FINDTIME (LAMBDA (OLDDATE VERSION) (* shw: "24-Jul-85 15:39") (LET ((HOUR (SUBSTRING OLDDATE 11 12)) (MINUTES (SUBSTRING OLDDATE 14 15))) (if (EQUAL VERSION 'ABBREV) then (CONCAT (FINDHOUR HOUR) ":" MINUTES " " (AMPM HOUR)) else (if (EQUAL VERSION 'EURO) then (SUBSTRING OLDDATE 11 15) else (CONCAT (SELECTQ (if (LESSP (MKATOM MINUTES) 46) then (MKATOM (FINDHOUR HOUR)) else (PLUS 1 (MKATOM (FINDHOUR HOUR)))) (1 "one") (2 "two") (3 "three") (4 "four") (5 "five") (6 "six") (7 "seven") (8 "eight") (9 "nine") (10 "ten") (11 "eleven") (12 "twelve") NIL) " " (if (AND (GREATERP (MKATOM MINUTES) 15) (LESSP (MKATOM MINUTES) 45)) then "thirty" else "o'clock") " " (if (AND (GREATERP (MKATOM MINUTES) 44) (EQUAL (FINDHOUR HOUR) "11")) then (if (EQUAL (AMPM HOUR) "a.m.") then "p.m." else "a.m.") else (AMPM HOUR)))))))) (FINDYEAR (LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:31") (if (EQ VERSION 'ABBREV) then (MKATOM (SUBSTRING OLDDATE 8 9)) else (MKATOM (CONCAT "19" (SUBSTRING OLDDATE 8 9)))))) (NUMP (LAMBDA (N) (* edited: " 4-Apr-86 17:55") (* changed) (NOT (NULL (NUMBERP (MKATOM N)))))) (WHICHDATE (LAMBDA (VAR1 VAR2 YEAR OLDDATE VERSION) (* edited " 1-Jan-00 00:00") (* * comment) (PROG (DIVIDER) (SETQ DIVIDER (if (EQ VERSION 'ABBREV) then "/" else " ")) (RETURN (MKATOM (CONCAT (APPLY VAR1 (LIST OLDDATE VERSION)) DIVIDER (APPLY VAR2 (LIST OLDDATE VERSION)) DIVIDER (APPLY YEAR (LIST OLDDATE VERSION)))))))) ) [DECLARE: EVAL@COMPILE (RECORD DATEOBJ (DATESTRING DISPLAY.DATE TEMPLATE.DATE)) (DATATYPE STREAM ( (* First 4 words are fixed for BIN, BOUT opcodes. Length of whole datatype is multiple of 4, so  quad-aligned) (COFFSET WORD) (* Offset in CPPTR of next bin or bout) (CBUFSIZE WORD) (* Offset past last byte in that buffer) (BINABLE FLAG) (* BIN punts unless this bit on) (BOUTABLE FLAG) (* BOUT punts unless this bit on) (EXTENDABLE FLAG) (* BOUT punts when COFFSET ge CBUFFSIZE unless this  bit set and COFFSET lt 512) (NIL BITS 5) (CBUFPTR POINTER) (* Pointer to current buffer) (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* True if stream likes to read and write more than  one buffer at a time) (USERCLOSEABLE FLAG) (* Can be closed by CLOSEF; NIL for terminal, dribble...) (USERVISIBLE FLAG) (* Listed by OPENP; NIL for terminal, dribble ...) (ACCESSBITS BITS 3) (* What kind of access file is open for  (read, write, append)) (FULLFILENAME POINTER) (* Name by which file is known to user) (DEVICE POINTER) (* FDEV of this guy) (VALIDATION POINTER) (* A number somehow identifying file, used to  determine if file has changed in our absence) (EPAGE WORD) (EOFFSET WORD) (* Page, byte offset of eof) (* Following are device-specific fields) (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (* Following only filled in for open streams) (BYTESIZE BYTE) (BUFFS POINTER) (CPAGE WORD) (FW8 WORD) (MAXBUFFERS WORD) (CHARPOSITION WORD) (* Used by POSITION etc.) (DIRTYBITS WORD) (LINELENGTH WORD) (EOLCONVENTION BITS 2) (* End-of-line convention) (CBUFDIRTY FLAG) (NIL BITS 5) (OUTCHARFN POINTER) (ENDOFSTREAMOP POINTER) (* For use of applications programs, not devices) (OTHERPROPS POINTER) (IMAGEOPS POINTER) (* Image operations vector) (IMAGEDATA POINTER) (* Image instance variables--format depends on  IMAGEOPS value) (EXTRASTREAMOP POINTER) (STRMBINFN POINTER) (* Either the BIN fn from the FDEV, or a trap) (STRMBOUTFN POINTER) (* Either the BIN fn from the FDEV, or a trap) (CBUFMAXSIZE WORD) (FW9 WORD) (F10 POINTER) (* the current character set for this stream. gbn 4-2-85) (CHARSET BYTE)) (BLOCKRECORD STREAM ((NIL 2 WORD) (UCODEFLAGS BYTE) (NIL POINTER))) (ACCESSFNS STREAM ((ACCESS \GETACCESS \SETACCESS) (FULLNAME (OR (fetch (STREAM FULLFILENAME) of DATUM) DATUM)) (NAMEDP (AND (fetch (STREAM FULLFILENAME) of DATUM) T)))) (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ NoBits BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _(PROGN (DECLARE (GLOBALVARS \STREAM.DEFAULT.MAXBUFFERS)) \STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _(PROGN (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) OUTCHARFN _(FUNCTION \FILEOUTCHARFN) ENDOFSTREAMOP _(FUNCTION \EOSERROR) IMAGEOPS _ \NOIMAGEOPS EOLCONVENTION _(SELECTQ (SYSTEMTYPE) (D CR.EOLC) (VAX LF.EOLC) (JERICHO CRLF.EOLC) CR.EOLC) STRMBINFN _(FUNCTION \STREAM.NOT.OPEN) STRMBOUTFN _(FUNCTION \STREAM.NOT.OPEN)) (DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)) ] (/DECLAREDATATYPE 'STREAM '(WORD WORD FLAG FLAG FLAG (BITS 5) POINTER FLAG FLAG FLAG FLAG FLAG (BITS 3) POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD WORD BYTE POINTER WORD WORD WORD WORD WORD WORD (BITS 2) FLAG (BITS 5) POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER BYTE) '((STREAM 0 (BITS . 15)) (STREAM 1 (BITS . 15)) (STREAM 2 (FLAGBITS . 0)) (STREAM 2 (FLAGBITS . 16)) (STREAM 2 (FLAGBITS . 32)) (STREAM 2 (BITS . 52)) (STREAM 2 POINTER) (STREAM 4 (FLAGBITS . 0)) (STREAM 4 (FLAGBITS . 16)) (STREAM 4 (FLAGBITS . 32)) (STREAM 4 (FLAGBITS . 48)) (STREAM 4 (FLAGBITS . 64)) (STREAM 4 (BITS . 82)) (STREAM 4 POINTER) (STREAM 6 POINTER) (STREAM 8 POINTER) (STREAM 10 (BITS . 15)) (STREAM 11 (BITS . 15)) (STREAM 12 POINTER) (STREAM 14 POINTER) (STREAM 16 POINTER) (STREAM 18 POINTER) (STREAM 20 POINTER) (STREAM 22 (BITS . 15)) (STREAM 23 (BITS . 15)) (STREAM 20 (BITS . 7)) (STREAM 24 POINTER) (STREAM 26 (BITS . 15)) (STREAM 27 (BITS . 15)) (STREAM 28 (BITS . 15)) (STREAM 29 (BITS . 15)) (STREAM 30 (BITS . 15)) (STREAM 31 (BITS . 15)) (STREAM 24 (BITS . 1)) (STREAM 24 (FLAGBITS . 32)) (STREAM 24 (BITS . 52)) (STREAM 32 POINTER) (STREAM 34 POINTER) (STREAM 36 POINTER) (STREAM 38 POINTER) (STREAM 40 POINTER) (STREAM 42 POINTER) (STREAM 44 POINTER) (STREAM 46 POINTER) (STREAM 48 (BITS . 15)) (STREAM 49 (BITS . 15)) (STREAM 50 POINTER) (STREAM 50 (BITS . 7))) '52) (/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) '((FONTCLASS 0 (BITS . 7)) (FONTCLASS 0 POINTER) (FONTCLASS 2 POINTER) (FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER)) '10) (PUTPROPS DATE COPYRIGHT ("Leland Stanford Junior University" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (850 12872 (DATEOBJ 862 . 2359) (DATEOBJP 2363 . 2736) (DATE.DISPLAYFN 2740 . 3015) ( DATE.IMAGEBOXFN 3019 . 3575) (CURRENT.DISPLAY.FONT 3579 . 4284) (DATE.PUTFN 4288 . 4541) (DATE.GETFN 4545 . 4956) (DATE.BUTTONEVENTINFN 4960 . 6275) (DATES.TEMPLATE 6279 . 7439) (AMPM 7443 . 7615) ( DATES.MENU.APPLY 7619 . 8538) (DATES.MENU.WHENSELECTEDFN 8542 . 8780) (DATES.SET 8784 . 8895) (FINDDAY 8899 . 9154) (FINDHOUR 9158 . 9662) (FINDMONTH 9666 . 10427) (FINDTIME 10431 . 11846) (FINDYEAR 11850 . 12124) (NUMP 12128 . 12368) (WHICHDATE 12372 . 12869))))) STOP \ No newline at end of file diff --git a/lispusers/DATEFNS b/lispusers/DATEFNS new file mode 100644 index 00000000..b0e6c54d --- /dev/null +++ b/lispusers/DATEFNS @@ -0,0 +1 @@ +(FILECREATED "10-Oct-86 13:07:26" {DSK}DATEFNS.;1 20771 changes to: (FNS MAKE.DATE) previous date: " 4-May-84 18:46:07" {DANTE}LISPUSERS>DATEFNS.;1) (* Copyright (c) 1984, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DATEFNSCOMS) (RPAQQ DATEFNSCOMS ((FNS BUILDCALENDAR CALRBUTTONFN CENTERBLTINREGION DATEMENU DAY DAYOFWEEK DAYSIN DRAWCALENDAR FOLLOWING.MONTH LEAPYEARP MAKE.DATE PREVIOUS.MONTH XYTODATE \CALBOXITEM \CALINVERTITEM) (VARS LISTOFDAYS MONTH.LIST) (VARS (CALBORDER 3) (CALGRIDBORDER 1)) [VARS (MONTHNAMEFONT (FONTCREATE (QUOTE GACHA) 12)) (OTHERMONTHFONT (FONTCREATE (QUOTE GACHA) 8)) (DAYNAMEFONT (FONTCREATE (QUOTE GACHA) 10)) (DAYNUMBERFONT (FONTCREATE (QUOTE GACHA) 12 (QUOTE BOLD] (DECLARE: DONTCOPY (RECORDS CALENDARINFO)))) (DEFINEQ (BUILDCALENDAR [LAMBDA (MON YEAR CALENDARW) (* rrb " 3-May-84 12:41") (PROG ([YEAR (OR YEAR (MKATOM (SUBSTRING (DATE) 8 9] (MON (OR MON (SUBSTRING (DATE) 4 6))) DAYSIN FIRSTDAY WEEKROWS CALWIDTH CALHEIGHT CALWWIDTH CALWHEIGHT DAYWIDTH DAYHEIGHT OTHERMONWIDTH OTHERMONHEIGHT) (SETQ MON (MKATOM (U-CASE MON))) MONLP (COND ((MEMB MON MONTH.LIST)) ((IGREATERP (NCHARS MON) 3) (SETQ MON (MKATOM (SUBSTRING MON 1 3))) (GO MONLP)) (T (ERROR MON "not recognized as a month. Should be 3 letter abbrev."))) (SETQ DAYSIN (DAYSIN MON YEAR)) [SETQ FIRSTDAY (DAYOFWEEK (IDATE (CONCAT "01-" MON "-" YEAR " 12:00:00"] (SETQ WEEKROWS (COND ((IGREATERP (IPLUS DAYSIN FIRSTDAY) 35) 6) ((IGREATERP (IPLUS DAYSIN FIRSTDAY) 28) 5) (T 4))) [SETQ CALWIDTH (IPLUS (IMAX (ITIMES (IPLUS (ITIMES 2 (IPLUS CALGRIDBORDER 1)) (IMAX (STRINGWIDTH "Su" DAYNAMEFONT) (STRINGWIDTH "28" DAYNUMBERFONT))) 7) (IPLUS [ITIMES 2 (SETQ OTHERMONWIDTH (IPLUS 4 (STRINGWIDTH "MAY" OTHERMONTHFONT] (STRINGWIDTH " MAR 84 " MONTHNAMEFONT] (SETQ CALWWIDTH (WIDTHIFWINDOW CALWIDTH CALBORDER)) (SETQ CALHEIGHT (IPLUS (IPLUS 2 (IMAX (SETQ OTHERMONHEIGHT (IPLUS 2 (FONTHEIGHT OTHERMONTHFONT))) (FONTHEIGHT MONTHNAMEFONT))) (IPLUS 2 (FONTHEIGHT DAYNAMEFONT)) (ITIMES (SETQ DAYHEIGHT (IPLUS CALGRIDBORDER 2 (FONTHEIGHT DAYNUMBERFONT))) WEEKROWS))) (SETQ CALWHEIGHT (HEIGHTIFWINDOW CALHEIGHT NIL CALBORDER)) [COND [(WINDOWP CALENDARW) (PROG [(CURRENTREG (WINDOWPROP CALENDARW (QUOTE REGION] (CLEARW CALENDARW) (WINDOWPROP CALENDARW (QUOTE RESHAPEFN) NIL) (COND ((NEQ (fetch (REGION HEIGHT) of CURRENTREG) CALWHEIGHT) (* do reshape so that upper part of window remains  fixed.) (WINDOWPROP CALENDARW (QUOTE REGION) (CREATEREGION (fetch (REGION LEFT) of CURRENTREG) (IDIFFERENCE (fetch (REGION BOTTOM) of CURRENTREG) (IDIFFERENCE CALWHEIGHT (fetch (REGION HEIGHT) of CURRENTREG))) CALWWIDTH CALWHEIGHT] (T (SETQ CALENDARW (CREATEW (MAKEWITHINREGION (CREATEREGION LASTMOUSEX LASTMOUSEY CALWWIDTH CALWHEIGHT)) NIL CALBORDER NIL] (WINDOWPROP CALENDARW (QUOTE BUTTONEVENTFN) (FUNCTION CALRBUTTONFN)) (WINDOWPROP CALENDARW (QUOTE CURSORINFN) (FUNCTION CALRBUTTONFN)) (WINDOWPROP CALENDARW (QUOTE CURSORMOVEDFN) (FUNCTION CALRBUTTONFN)) (WINDOWPROP CALENDARW (QUOTE RESHAPEFN) (QUOTE DON'T)) (WINDOWPROP CALENDARW (QUOTE CALENDARINFO) (create CALENDARINFO MONTH _ MON YEAR _ YEAR #DAYS _ DAYSIN DAYOFFIRST _ FIRSTDAY WEEKROWS _ WEEKROWS) DAYSIN) (WINDOWPROP CALENDARW (QUOTE CALGRIDSPEC) (create REGION LEFT _(IQUOTIENT [IDIFFERENCE CALWIDTH (ITIMES 7 (SETQ DAYWIDTH (IQUOTIENT CALWIDTH 7] 2) BOTTOM _ 0 WIDTH _ DAYWIDTH HEIGHT _ DAYHEIGHT)) (WINDOWPROP CALENDARW (QUOTE OTHERMONTHREGIONS) (LIST (create REGION LEFT _ 0 BOTTOM _(IDIFFERENCE CALHEIGHT OTHERMONHEIGHT) WIDTH _ OTHERMONWIDTH HEIGHT _ OTHERMONHEIGHT) (create REGION LEFT _(IDIFFERENCE CALWIDTH OTHERMONWIDTH) BOTTOM _(IDIFFERENCE CALHEIGHT OTHERMONHEIGHT) WIDTH _ OTHERMONWIDTH HEIGHT _ OTHERMONHEIGHT))) (DRAWCALENDAR CALENDARW) (RETURN CALENDARW]) (CALRBUTTONFN [LAMBDA (CALENDARW) (* rrb " 2-May-84 19:51") (* buttoneventfn for calendar menus) (PROG ((CALINFO (WINDOWPROP CALENDARW (QUOTE CALENDARINFO))) (OTHERMONTHREGIONS (WINDOWPROP CALENDARW (QUOTE OTHERMONTHREGIONS))) (MGRIDSPEC (WINDOWPROP CALENDARW (QUOTE CALGRIDSPEC))) (LASTBUTTONSTATE LASTMOUSEBUTTONS) (MAXXBOX 7) OLDBOXX OLDBOXY BOXX BOXY DSPX DSPY MAXYBOX MOUSEDOWN ITEM YEAR MONTH) (SETQ MONTH (fetch (CALENDARINFO MONTH) of CALINFO)) (SETQ YEAR (fetch (CALENDARINFO YEAR) of CALINFO)) (SETQ MAXYBOX (fetch (CALENDARINFO WEEKROWS) of CALINFO)) [RETURN (until (COND (MOUSEDOWN (* if mouse has been down, process it) (MOUSESTATE UP)) ((MOUSESTATE (NOT UP)) (* mouse hasn't been down but just went down.) [COND ((LASTMOUSESTATE RIGHT) (DOWINDOWCOM CALENDARW) (SETQ MOUSEDOWN NIL)) (T (SETQ MOUSEDOWN T) (COND (OLDBOXX (* switch between boxing to flipping items.) (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW) (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW] NIL)) do [COND [[OR (AND (STRICTLY/BETWEEN (SETQ BOXY (GRIDYCOORD (LASTMOUSEY CALENDARW) MGRIDSPEC)) -1 MAXYBOX) (STRICTLY/BETWEEN (SETQ BOXX (GRIDXCOORD (LASTMOUSEX CALENDARW) MGRIDSPEC)) -1 MAXXBOX)) (SETQ BOXX (for REG in OTHERMONTHREGIONS when (INSIDE? REG (LASTMOUSEX CALENDARW) (LASTMOUSEY CALENDARW)) do (RETURN REG] (* BOXX and BOXY hold the number of the box pointed at.) (COND ((OR (NEQ BOXX OLDBOXX) (NEQ BOXY OLDBOXY)) (* selected item has changed.) (* uninvert old item if there was one.) [COND (OLDBOXX (COND (MOUSEDOWN (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW] (* invert new item) (COND (MOUSEDOWN (\CALINVERTITEM BOXX BOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM BOXX BOXY MGRIDSPEC CALENDARW))) (SETQ OLDBOXX BOXX) (SETQ OLDBOXY BOXY] (T (* cursor moved outside of the menu.) (COND (OLDBOXX (COND (MOUSEDOWN (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW))) (* OLDBOXX denotes item inverted.) (SETQ OLDBOXX))) (COND ((INSIDEP (WINDOWPROP CALENDARW (QUOTE REGION)) LASTMOUSEX LASTMOUSEY) (* cursor is still inside the window, keep control.) NIL) (T (RETURN] finally (* turn off inverse image. and call whenunheldfn is  necessary.) (COND (OLDBOXX (COND (MOUSEDOWN (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW))) (* something was selected, take down the window.) (CLOSEW CALENDARW))) (* return selected date or bring up new calendar) (RETURN (COND ((REGIONP OLDBOXX) (* selected a month) [COND [(EQ OLDBOXX (CAR OTHERMONTHREGIONS)) (COND ((EQ (SETQ MONTH (PREVIOUS.MONTH MONTH)) (QUOTE DEC)) (SETQ YEAR (SUB1 YEAR] (T (COND ((EQ (SETQ MONTH (FOLLOWING.MONTH MONTH)) (QUOTE JAN)) (SETQ YEAR (ADD1 YEAR] (BUILDCALENDAR MONTH YEAR CALENDARW)) (OLDBOXX (WINDOWPROP CALENDARW (QUOTE VALUE) (MAKE.DATE (XYTODATE CALENDARW OLDBOXX OLDBOXY) MONTH YEAR] (* return selected date or bring up new calendar) ]) (CENTERBLTINREGION [LAMBDA (BITMAP REGION STRM) (* rrb " 1-May-84 14:18") (* puts a bitmap centered in a region of a stream) (BITBLT BITMAP 0 0 STRM (IPLUS (fetch (REGION LEFT) of REGION) (IQUOTIENT (IDIFFERENCE (fetch (REGION WIDTH) of REGION) (BITMAPWIDTH BITMAP)) 2)) (IPLUS (fetch (REGION BOTTOM) of REGION) (IQUOTIENT (IDIFFERENCE (fetch (REGION HEIGHT) of REGION) (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) 2)) NIL NIL (QUOTE INPUT) NIL NIL REGION]) (DATEMENU [LAMBDA (MON YEAR) (* rrb " 2-May-84 19:53") (* puts up a calendar menu and reads a date from the  user) (PROG ((CALMENUW (BUILDCALENDAR MON YEAR))) (until (WINDOWPROP CALMENUW (QUOTE VALUE)) do (TOTOPW CALMENUW) (DISMISS 500)) (RETURN (WINDOWPROP CALMENUW (QUOTE VALUE) NIL]) (DAY [LAMBDA (STRDATE) (* rrb " 1-May-84 14:30") (SELECTQ (DAYOFWEEK (IDATE STRDATE)) (1 "MONDAY") (2 "TUESDAY") (3 "WEDNESDAY") (4 "THURSDAY") (5 "FRIDAY") (6 "SATURDAY") (0 "SUNDAY") (SHOULDNT]) (DAYOFWEEK [LAMBDA (INTERNALDATE) (* gbn "11-MAY-83 10:47") (* Returns a number between 0  (Sunday) and 6 (Saturday) representing the day of the  week which the given IDATE was/is/willbe) (PROG ((UNITSSINCEBASE (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE INTERNALDATE) 1) 30))) (* UNITSSINCEBASE represents the number of minutes since Jan 1,1901 GMT) (* now, adjust for the time zone. Since this may make UNITSSINCEBASE go negative , add in  one week of hours) (SETQ UNITSSINCEBASE (IDIFFERENCE (IPLUS (IQUOTIENT UNITSSINCEBASE 60) (ITIMES 24 7)) \TimeZoneComp)) (* UNITSSINCEBASE now represents the number of hours  since Genesis) (RETURN (IREMAINDER (IPLUS 2 (IQUOTIENT UNITSSINCEBASE 24)) 7]) (DAYSIN [LAMBDA (MONTH YEAR) (* rrb " 2-May-84 19:38") (SELECTQ (MKATOM MONTH) (FEB (COND ((LEAPYEARP YEAR) 29) (T 28))) ((APR JUN SEP NOV) 30) 31]) (DRAWCALENDAR [LAMBDA (CALENDARW) (* rrb " 2-May-84 18:47") (* Adds the grid numbering and messages to calendar) (PROG ((CALENDARINFO (WINDOWPROP CALENDARW (QUOTE CALENDARINFO))) (CALGRIDSPEC (WINDOWPROP CALENDARW (QUOTE CALGRIDSPEC))) ROWS GRIDWIDTH GRIDHEIGHT BOTTOM MONTH) (CLEARW CALENDARW) (* prepares the grid for the calendar) (GRID CALGRIDSPEC 7 (SETQ ROWS (fetch (CALENDARINFO WEEKROWS) of CALENDARINFO)) CALGRIDBORDER CALENDARW) (SETQ GRIDWIDTH (fetch WIDTH of CALGRIDSPEC)) (SETQ GRIDHEIGHT (fetch HEIGHT of CALGRIDSPEC)) (DSPFONT DAYNUMBERFONT CALENDARW) (* print in the numbers for the days.) (for #DAYOFWEEK from (fetch (CALENDARINFO DAYOFFIRST) of CALENDARINFO) as DATE from 1 to (fetch (CALENDARINFO #DAYS) of CALENDARINFO) do (CENTERPRINTINREGION DATE (create REGION BOTTOM _(BOTTOMOFGRIDCOORD (SUB1 (IDIFFERENCE ROWS (IQUOTIENT #DAYOFWEEK 7))) CALGRIDSPEC) LEFT _(LEFTOFGRIDCOORD (IREMAINDER #DAYOFWEEK 7) CALGRIDSPEC) WIDTH _ GRIDWIDTH HEIGHT _ GRIDHEIGHT) CALENDARW)) (* Now print the day headings in the top row of the  calendar) (DSPFONT DAYNAMEFONT CALENDARW) (for CHAR in LISTOFDAYS as #DAYOFWEEK from 0 do (CENTERPRINTINREGION CHAR (create REGION BOTTOM _( BOTTOMOFGRIDCOORD ROWS CALGRIDSPEC) LEFT _( LEFTOFGRIDCOORD #DAYOFWEEK CALGRIDSPEC) WIDTH _ GRIDWIDTH HEIGHT _ GRIDHEIGHT) CALENDARW)) (* put up the scroll bars for moving to previous and  following months.) (DSPFONT OTHERMONTHFONT CALENDARW) (SETQ MONTH (fetch (CALENDARINFO MONTH) of CALENDARINFO)) (for REGION in (WINDOWPROP CALENDARW (QUOTE OTHERMONTHREGIONS)) as NEARMONTH in (LIST (PREVIOUS.MONTH MONTH) (FOLLOWING.MONTH MONTH)) do (DRAWAREABOX (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 1 NIL CALENDARW) (CENTERPRINTINREGION NEARMONTH REGION CALENDARW)) (* put up month and year.) (DSPFONT MONTHNAMEFONT CALENDARW) (CENTERPRINTINREGION (CONCAT MONTH " " (fetch (CALENDARINFO YEAR) of CALENDARINFO)) (create REGION LEFT _(LEFTOFGRIDCOORD 0 CALGRIDSPEC) BOTTOM _(SETQ BOTTOM (BOTTOMOFGRIDCOORD (ADD1 ROWS) CALGRIDSPEC)) WIDTH _(ITIMES 7 GRIDWIDTH) HEIGHT _(IDIFFERENCE (WINDOWPROP CALENDARW (QUOTE HEIGHT)) BOTTOM)) CALENDARW]) (FOLLOWING.MONTH [LAMBDA (MONTH) (* rrb " 2-May-84 17:55") (* returns the following months) (for TAIL on MONTH.LIST when (EQ MONTH (CAR TAIL)) do (RETURN (COND ((CADR TAIL)) (T (CAR MONTH.LIST]) (LEAPYEARP [LAMBDA (YEAR) (* rrb " 2-May-84 19:38") (* determines if YEAR is a leap year. Uses current year if YEAR is NIL) (* assumes year is two digit number.) (AND (ZEROP (REMAINDER [SETQ YEAR (COND ((NUMBERP YEAR)) ((NULL YEAR) (MKATOM (SUBSTRING (DATE) 8 9))) (T (\ILLEGAL.ARG YEAR] 4)) (NOT (ZEROP YEAR]) (MAKE.DATE [LAMBDA (DAY MONTH YEAR) (* Newman "10-Oct-86 12:58") (* returns a date string.) [COND [(ILESSP DAY 1) (* day from previous month) (SETQ MONTH (PREVIOUS.MONTH MONTH)) [COND ((EQ MONTH (QUOTE DEC)) (SETQ YEAR (SUB1 YEAR] (SETQ DAY (IPLUS (ADD1 DAY) (DAYSIN MONTH YEAR] ((IGREATERP DAY (DAYSIN MONTH YEAR)) (* day in next month) (SETQ DAY (IDIFFERENCE DAY (DAYSIN MONTH YEAR))) (SETQ MONTH (FOLLOWING.MONTH MONTH)) (COND ((EQ MONTH (QUOTE JAN)) (SETQ YEAR (ADD1 YEAR] (CONCAT (COND ((IGEQ DAY 10) DAY) (T (CONCAT "0" DAY))) "-" MONTH "-" YEAR " 00:00:00"]) (PREVIOUS.MONTH [LAMBDA (MONTH) (* rrb " 2-May-84 17:53") (* returns the previous months) (COND ((EQ MONTH (CAR MONTH.LIST)) (CAR (LAST MONTH.LIST))) (T (for TAIL on MONTH.LIST when (EQ MONTH (CADR TAIL)) do (RETURN (CAR TAIL]) (XYTODATE [LAMBDA (WINDOW X Y) (* rrb " 2-May-84 15:33") (* Takes an x y position in grid coordinates and returns the date which corresponds to it) (PROG [(CALINFO (WINDOWPROP WINDOW (QUOTE CALENDARINFO] (RETURN (IPLUS 1 X (MINUS (fetch (CALENDARINFO DAYOFFIRST) of CALINFO)) (ITIMES (IPLUS -1 (fetch (CALENDARINFO WEEKROWS) of CALINFO) (MINUS Y)) 7]) (\CALBOXITEM [LAMBDA (COLUMN ROW GRID DSP) (* rrb " 2-May-84 20:00") (* inverts an item in a calendar displayed in DSP.) (PROG (LFT BTM WID HGHT) [COND ((REGIONP COLUMN) (* either the previous or next months.) (SETQ LFT (fetch (REGION LEFT) of COLUMN)) (SETQ BTM (fetch (REGION BOTTOM) of COLUMN)) (SETQ WID (fetch (REGION WIDTH) of COLUMN)) (SETQ HGHT (fetch (REGION HEIGHT) of COLUMN))) (T (* must be part of calendar.) (SETQ LFT (LEFTOFGRIDCOORD COLUMN GRID)) (SETQ BTM (BOTTOMOFGRIDCOORD ROW GRID)) (SETQ WID (fetch (REGION WIDTH) of GRID)) (SETQ HGHT (fetch (REGION HEIGHT) of GRID] (BITBLT NIL NIL NIL DSP (ADD1 LFT) (ADD1 BTM) (IDIFFERENCE WID 2) (IDIFFERENCE HGHT 2) (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE) (BITBLT NIL NIL NIL DSP (IPLUS LFT 2) (IPLUS BTM 2) (IDIFFERENCE WID 4) (IDIFFERENCE HGHT 4) (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE]) (\CALINVERTITEM [LAMBDA (COLUMN ROW GRID DSP) (* rrb " 2-May-84 18:37") (* inverts an item in a calendar displayed in DSP.) (COND ((REGIONP COLUMN) (* either the previous or next months.) (DSPFILL COLUMN BLACKSHADE (QUOTE INVERT) DSP)) (T (* must be part of calendar.) (SHADEGRIDBOX COLUMN ROW BLACKSHADE (QUOTE INVERT) GRID CALGRIDBORDER DSP]) ) (RPAQQ LISTOFDAYS ("Su" "M" "Tu" "W" "Th" "F" "Sa")) (RPAQQ MONTH.LIST (JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC)) (RPAQQ CALBORDER 3) (RPAQQ CALGRIDBORDER 1) (RPAQ MONTHNAMEFONT (FONTCREATE (QUOTE GACHA) 12)) (RPAQ OTHERMONTHFONT (FONTCREATE (QUOTE GACHA) 8)) (RPAQ DAYNAMEFONT (FONTCREATE (QUOTE GACHA) 10)) (RPAQ DAYNUMBERFONT (FONTCREATE (QUOTE GACHA) 12 (QUOTE BOLD))) (DECLARE: DONTCOPY [DECLARE: EVAL@COMPILE (RECORD CALENDARINFO (MONTH YEAR #DAYS DAYOFFIRST WEEKROWS)) ] ) (PUTPROPS DATEFNS COPYRIGHT ("Xerox Corporation" 1984 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (896 20124 (BUILDCALENDAR 906 . 4810) (CALRBUTTONFN 4812 . 9418) (CENTERBLTINREGION 9420 . 10087) (DATEMENU 10089 . 10559) (DAY 10561 . 10864) (DAYOFWEEK 10866 . 11981) (DAYSIN 11983 . 12233 ) (DRAWCALENDAR 12235 . 15548) (FOLLOWING.MONTH 15550 . 15906) (LEAPYEARP 15908 . 16475) (MAKE.DATE 16477 . 17393) (PREVIOUS.MONTH 17395 . 17773) (XYTODATE 17775 . 18299) (\CALBOXITEM 18301 . 19544) ( \CALINVERTITEM 19546 . 20122))))) STOP \ No newline at end of file diff --git a/lispusers/DATEFORMAT-EDITOR b/lispusers/DATEFORMAT-EDITOR new file mode 100644 index 00000000..62330089 --- /dev/null +++ b/lispusers/DATEFORMAT-EDITOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "19-May-89 17:52:44" {ERINYES}MEDLEY>DATEFORMAT-EDITOR.;1 13443 changes to%: (VARS DATEFORMAT-EDITORCOMS) previous date%: "16-Sep-88 12:50:52" {PHYLUM}MEDLEY>LISPUSERS>DATEFORMAT-EDITOR.;1) (* " Copyright (c) 1987, 1988, 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT DATEFORMAT-EDITORCOMS) (RPAQQ DATEFORMAT-EDITORCOMS ((* ;;; "This system provides a facility for editing date formats as described in section 12.5 of the Interlisp-D manual, Koto version. User entry point is the function EDIT-DATEFORMAT. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input to EDIT-DATEFORMAT is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function.") (* ;;; "Interface") (FNS EDIT-DATEFORMAT GET-DATEFORMAT-EDITOR) (INITVARS (EDIT-DATEFORMAT-DEFAULT (DATEFORMAT))) (* ;;; "Support") (FILES (SYSLOAD) FREEMENU) (FNS DATEFORMAT-EDITOR-STATUS DATEFORMAT-EDITOR-GET-STATE DATEFORMAT-EDITOR-PUT-STATE DATEFORMAT-EDITOR-SHOW-STATE DATEFORMAT-EDITOR-ABORTFN DATEFORMAT-EDITOR-CLOSEFN DATEFORMAT-EDITOR-GETDFLTFN DATEFORMAT-EDITOR-PUTDFLTFN DATEFORMAT-EDITOR-QUITFN DATEFORMAT-EDITOR-SHOWFN) (VARS $$DATEFORMAT-EDITOR-ITEMS) (INITVARS (DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS ($$DATEFORMAT-EDITOR (GET-DATEFORMAT-EDITOR)) ($$DATEFORMAT-EDITOR-IDATE (IDATE " 1-Jan-88 23:56:41"))) (P (COND ((NOT (GETD (QUOTE \OUTDATE-STRING))) (* ; "Get DATE extensions") (FILESLOAD (SYSLOAD) DATEPATCH))))) (PROP MAKEFILE-ENVIRONMENT DATEFORMAT-EDITOR))) (* ;;; "This system provides a facility for editing date formats as described in section 12.5 of the Interlisp-D manual, Koto version. User entry point is the function EDIT-DATEFORMAT. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input to EDIT-DATEFORMAT is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function." ) (* ;;; "Interface") (DEFINEQ (EDIT-DATEFORMAT (LAMBDA (DATEFORMAT) (* ; "Edited 29-Mar-88 17:24 by Koomen") (* ;;; "This system provides a facility for editing date formats as described in section 12.14 of the Interlisp-D manual, Koto version. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function.") (PROG ((DFE (GET-DATEFORMAT-EDITOR))) (DATEFORMAT-EDITOR-PUT-STATE DFE (OR DATEFORMAT EDIT-DATEFORMAT-DEFAULT)) (OPENW DFE) (DATEFORMAT-EDITOR-SHOW-STATE DFE) (DATEFORMAT-EDITOR-STATUS DFE (QUOTE EDIT)) (NLSETQ (while (EQ (DATEFORMAT-EDITOR-STATUS DFE) (QUOTE EDIT)) do (BLOCK))) (CLOSEW DFE) (if (EQ (DATEFORMAT-EDITOR-STATUS DFE) (QUOTE QUIT)) then (RETURN (DATEFORMAT-EDITOR-GET-STATE DFE)) else (DATEFORMAT-EDITOR-STATUS DFE (QUOTE ABORT))))) ) (GET-DATEFORMAT-EDITOR (LAMBDA (RECOMPUTE?) (* ; "Edited 24-Sep-87 13:36 by Koomen") (DECLARE (GLOBALVARS $$DATEFORMAT-EDITOR DATEFORMAT-EDITOR-ITEMS LASTMOUSEX LASTMOUSEY SCREENWIDTH SCREENHEIGHT)) (PROG ((DFE $$DATEFORMAT-EDITOR)) (if (OR RECOMPUTE? (NOT (WINDOWP DFE)) (NOT (FMEMB (DATEFORMAT-EDITOR-STATUS DFE) (QUOTE (QUIT ABORT))))) then (SETQ DFE (FREEMENU DATEFORMAT-EDITOR-ITEMS "Date Format Editor")) (SETQ $$DATEFORMAT-EDITOR DFE) (WINDOWPROP DFE (QUOTE CLOSEFN) (FUNCTION DATEFORMAT-EDITOR-CLOSEFN)) (WINDOWPROP DFE (QUOTE SHRINKFN) (QUOTE DON'T)) (WINDOWPROP DFE (QUOTE RESHAPEFN) (QUOTE DON'T)) (DATEFORMAT-EDITOR-STATUS DFE (QUOTE QUIT))) (MOVEW DFE (IMAX 0 (IMIN LASTMOUSEX (IDIFFERENCE SCREENWIDTH (fetch (REGION WIDTH) of (WINDOWREGION DFE))))) (IMAX 0 (IMIN LASTMOUSEY (IDIFFERENCE SCREENHEIGHT (fetch (REGION HEIGHT) of (WINDOWREGION DFE)))))) (RETURN DFE))) ) ) (RPAQ? EDIT-DATEFORMAT-DEFAULT (DATEFORMAT)) (* ;;; "Support") (FILESLOAD (SYSLOAD) FREEMENU) (DEFINEQ (DATEFORMAT-EDITOR-STATUS (LAMBDA (DFE NEWSTATUS) (* Koomen "30-Jan-87 23:41") (if NEWSTATUS then (WINDOWPROP DFE (QUOTE DATEFORMAT-EDITOR-STATUS) NEWSTATUS) else (WINDOWPROP DFE (QUOTE DATEFORMAT-EDITOR-STATUS)))) ) (DATEFORMAT-EDITOR-GET-STATE (LAMBDA (DFE) (* ; "Edited 29-Mar-88 15:05 by Koomen") (PROG ((FMT NIL) (ITEM NIL) (STATE (FM.GETSTATE DFE))) (if (SETQ ITEM (LISTGET STATE (QUOTE TIME))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (TIME-SECS NIL) (TIME-NONE (push FMT (QUOTE NO.TIME))) (TIME-MINS (push FMT (QUOTE NO.SECONDS))) (SHOULDNT "Bad TIME"))) (if (NOT (LISTGET FMT (QUOTE NO.TIME))) then (if (SETQ ITEM (LISTGET STATE (QUOTE TIMEZONE))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (TIMEZONE-NO NIL) (TIMEZONE-YES (push FMT (QUOTE TIME.ZONE))) (SHOULDNT "Bad TIMEZONE")))) (if (SETQ ITEM (LISTGET STATE (QUOTE DATE))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (DATE-NONE (push FMT (QUOTE NO.DATE))) (DATE-NORMAL NIL) (DATE-SPACES (push FMT (QUOTE SPACES))) (DATE-SLASHES (push FMT (QUOTE SLASHES))) (DATE-LEADING (push FMT (QUOTE MONTH.LEADING))) (SHOULDNT "Bad DATE"))) (if (NOT (LISTGET FMT (QUOTE NO.DATE))) then (if (SETQ ITEM (LISTGET STATE (QUOTE DAY))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (DAY-NONE NIL) (DAY-LONG (push FMT (QUOTE DAY.OF.WEEK))) (DAY-SHORT (push FMT (QUOTE DAY.OF.WEEK)) (push FMT (QUOTE DAY.SHORT))) (SHOULDNT "Bad DAY"))) (if (SETQ ITEM (LISTGET STATE (QUOTE MONTH))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (MONTH-LONG (push FMT (QUOTE MONTH.LONG))) (MONTH-SHORT NIL) (MONTH-NUMERIC (push FMT (QUOTE NUMBER.OF.MONTH))) (SHOULDNT "Bad MONTH"))) (if (SETQ ITEM (LISTGET STATE (QUOTE YEAR))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (YEAR-LONG (push FMT (QUOTE YEAR.LONG))) (YEAR-SHORT NIL) (SHOULDNT "Bad YEAR"))) (if (SETQ ITEM (LISTGET STATE (QUOTE LEADER))) then (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) (LEADER-NO (push FMT (QUOTE NO.LEADING.SPACES))) (LEADER-YES NIL) (SHOULDNT "Bad LEADER")))) (RETURN (APPLY (FUNCTION DATEFORMAT) (DREVERSE FMT))))) ) (DATEFORMAT-EDITOR-PUT-STATE (LAMBDA (DFE DATEFORMAT) (* ; "Edited 29-Mar-88 14:17 by Koomen") (FM.RESETMENU DFE) (for FMT in (if (AND DATEFORMAT (EQ (CAR (LISTP DATEFORMAT)) (QUOTE DATEFORMAT))) then (CDR DATEFORMAT)) bind (DATE _ (QUOTE DATE-NORMAL)) (YEAR _ (QUOTE YEAR-SHORT)) (MONTH _ (QUOTE MONTH-SHORT)) (DAY _ (QUOTE DAY-NONE)) (LEADER _ (QUOTE LEADER-YES)) (TIME _ (QUOTE TIME-SECS)) (TIMEZONE _ (QUOTE TIMEZONE-NO)) do (SELECTQ FMT (NO.DATE (SETQ DATE (QUOTE DATE-NONE))) (NUMBER.OF.MONTH (SETQ MONTH (QUOTE MONTH-NUMERIC))) (MONTH.LEADING (SETQ DATE (QUOTE DATE-LEADING))) (MONTH.LONG (SETQ MONTH (QUOTE MONTH-LONG))) (YEAR.LONG (SETQ YEAR (QUOTE YEAR-LONG))) (SLASHES (SETQ DATE (QUOTE DATE-SLASHES))) (SPACES (SETQ DATE (QUOTE DATE-SPACES))) (NO.LEADING.SPACES (SETQ LEADER (QUOTE LEADER-NO))) (NO.TIME (SETQ TIME (QUOTE TIME-NONE))) (TIME.ZONE (SETQ TIMEZONE (QUOTE TIMEZONE-YES))) (NO.SECONDS (SETQ TIME (QUOTE TIME-MINS))) (DAY.OF.WEEK (OR (EQ DAY (QUOTE DAY-SHORT)) (SETQ DAY (QUOTE DAY-LONG)))) (DAY.SHORT (SETQ DAY (QUOTE DAY-SHORT))) (PROGN (* ; "???") NIL)) finally (if (AND DATE (SETQ DATE (FM.GETITEM DATE NIL DFE))) then (FM.CHANGESTATE (QUOTE DATE) DATE DFE)) (if (AND YEAR (SETQ YEAR (FM.GETITEM YEAR NIL DFE))) then (FM.CHANGESTATE (QUOTE YEAR) YEAR DFE)) (if (AND MONTH (SETQ MONTH (FM.GETITEM MONTH NIL DFE))) then (FM.CHANGESTATE (QUOTE MONTH) MONTH DFE)) (if (AND DAY (SETQ DAY (FM.GETITEM DAY NIL DFE))) then (FM.CHANGESTATE (QUOTE DAY) DAY DFE)) (if (AND LEADER (SETQ LEADER (FM.GETITEM LEADER NIL DFE))) then (FM.CHANGESTATE (QUOTE LEADER) LEADER DFE)) (if (AND TIME (SETQ TIME (FM.GETITEM TIME NIL DFE))) then (FM.CHANGESTATE (QUOTE TIME) TIME DFE)) (if (AND TIMEZONE (SETQ TIMEZONE (FM.GETITEM TIMEZONE NIL DFE))) then (FM.CHANGESTATE (QUOTE TIMEZONE) TIMEZONE DFE)))) ) (DATEFORMAT-EDITOR-SHOW-STATE (LAMBDA (DFE) (* ; "Edited 29-Mar-88 13:01 by Koomen") (LET ((PROMPTW (GETPROMPTWINDOW DFE)) (FORMAT (DATEFORMAT-EDITOR-GET-STATE DFE))) (CLEARW PROMPTW) (printout PROMPTW (GDATE $$DATEFORMAT-EDITOR-IDATE FORMAT)))) ) (DATEFORMAT-EDITOR-ABORTFN (LAMBDA (ITEM WINDOW BUTTONS) (* Koomen "30-Jan-87 23:43") (DATEFORMAT-EDITOR-STATUS WINDOW (QUOTE ABORT))) ) (DATEFORMAT-EDITOR-CLOSEFN (LAMBDA (WINDOW) (* Koomen "30-Jan-87 23:42") (if (EQ (DATEFORMAT-EDITOR-STATUS WINDOW) (QUOTE EDIT)) then (DATEFORMAT-EDITOR-STATUS WINDOW (QUOTE ABORT)))) ) (DATEFORMAT-EDITOR-GETDFLTFN (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Mar-88 13:08 by Koomen") (if (EQ (DATEFORMAT-EDITOR-STATUS WINDOW) (QUOTE EDIT)) then (DATEFORMAT-EDITOR-PUT-STATE WINDOW EDIT-DATEFORMAT-DEFAULT) (DATEFORMAT-EDITOR-SHOW-STATE WINDOW))) ) (DATEFORMAT-EDITOR-PUTDFLTFN (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Mar-88 13:16 by Koomen") (if (EQ (DATEFORMAT-EDITOR-STATUS WINDOW) (QUOTE EDIT)) then (SETQ EDIT-DATEFORMAT-DEFAULT (DATEFORMAT-EDITOR-GET-STATE WINDOW)))) ) (DATEFORMAT-EDITOR-QUITFN (LAMBDA (ITEM WINDOW BUTTONS) (* Koomen "30-Jan-87 23:44") (DATEFORMAT-EDITOR-STATUS WINDOW (QUOTE QUIT))) ) (DATEFORMAT-EDITOR-SHOWFN (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Mar-88 13:03 by Koomen") (if (EQ (DATEFORMAT-EDITOR-STATUS WINDOW) (QUOTE EDIT)) then (DATEFORMAT-EDITOR-SHOW-STATE WINDOW))) ) ) (RPAQQ $$DATEFORMAT-EDITOR-ITEMS (((TYPE MOMENTARY LABEL "Quit" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-QUITFN MESSAGE "Stop editing, return current settings") (TYPE DISPLAY LABEL "") (TYPE MOMENTARY LABEL "Abort" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-ABORTFN MESSAGE "Stop editing, ignore changes, return NIL") (TYPE DISPLAY LABEL " Default:") (TYPE MOMENTARY LABEL "Get" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-GETDFLTFN MESSAGE "Use default settings") (TYPE MOMENTARY LABEL "Put" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-PUTDFLTFN MESSAGE "Save settings as default") (TYPE DISPLAY LABEL "")) ((TYPE DISPLAY LABEL "")) ((TYPE DISPLAY LABEL "DATE: " FONT (GACHA 10 BOLD))) ((TYPE DISPLAY LABEL " Format: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION DATE ID DATE-NORMAL LABEL "dd-mon-yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DATE ID DATE-SLASHES LABEL "dd/mon/yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DATE ID DATE-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " ") (TYPE NWAY COLLECTION DATE ID DATE-SPACES LABEL "dd mon yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DATE ID DATE-LEADING LABEL "mon dd, yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Year: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION YEAR ID YEAR-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION YEAR ID YEAR-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Month: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION MONTH ID MONTH-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION MONTH ID MONTH-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION MONTH ID MONTH-NUMERIC LABEL "numeric" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Weekday:" FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION DAY ID DAY-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DAY ID DAY-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DAY ID DAY-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Spaces: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION LEADER ID LEADER-YES LABEL "yes" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION LEADER ID LEADER-NO LABEL "no" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL "")) ((TYPE DISPLAY LABEL "TIME:" FONT (GACHA 10 BOLD))) ((TYPE DISPLAY LABEL " Format: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION TIME ID TIME-SECS LABEL "hh:mm:ss" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION TIME ID TIME-MINS LABEL "hh:mm" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION TIME ID TIME-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Time Zone:" FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION TIMEZONE ID TIMEZONE-YES LABEL "yes" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION TIMEZONE ID TIMEZONE-NO LABEL "no" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)))) (RPAQ? DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ $$DATEFORMAT-EDITOR (GET-DATEFORMAT-EDITOR)) (RPAQ $$DATEFORMAT-EDITOR-IDATE (IDATE " 1-Jan-88 23:56:41")) (COND ((NOT (GETD (QUOTE \OUTDATE-STRING))) (* ; "Get DATE extensions") (FILESLOAD (SYSLOAD) DATEPATCH))) ) (PUTPROPS DATEFORMAT-EDITOR MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (PUTPROPS DATEFORMAT-EDITOR COPYRIGHT ("Johannes A. G. M. Koomen" 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2483 4408 (EDIT-DATEFORMAT 2493 . 3520) (GET-DATEFORMAT-EDITOR 3522 . 4406)) (4513 9803 (DATEFORMAT-EDITOR-STATUS 4523 . 4743) (DATEFORMAT-EDITOR-GET-STATE 4745 . 6551) ( DATEFORMAT-EDITOR-PUT-STATE 6553 . 8363) (DATEFORMAT-EDITOR-SHOW-STATE 8365 . 8616) ( DATEFORMAT-EDITOR-ABORTFN 8618 . 8758) (DATEFORMAT-EDITOR-CLOSEFN 8760 . 8949) ( DATEFORMAT-EDITOR-GETDFLTFN 8951 . 9218) (DATEFORMAT-EDITOR-PUTDFLTFN 9220 . 9456) ( DATEFORMAT-EDITOR-QUITFN 9458 . 9596) (DATEFORMAT-EDITOR-SHOWFN 9598 . 9801))))) STOP \ No newline at end of file diff --git a/lispusers/DATEFORMAT-EDITOR.TEDIT b/lispusers/DATEFORMAT-EDITOR.TEDIT new file mode 100644 index 00000000..d15f4baa Binary files /dev/null and b/lispusers/DATEFORMAT-EDITOR.TEDIT differ diff --git a/lispusers/DATESORT b/lispusers/DATESORT new file mode 100644 index 00000000..da7945f2 --- /dev/null +++ b/lispusers/DATESORT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Feb-88 18:29:26" |{NEWTON:EUROPARC:RX}LISP>DATESORT.;2| 9298 previous date%: "11-Jun-87 10:15:34" |{NEWTON:EUROPARC:RX}LISP>DATESORT.;1|) (* " Copyright (c) 1986, 1987, 1988 by XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT DATESORTCOMS) (RPAQQ DATESORTCOMS ((UGLYVARS RQIREADTABLE) (FNS DATESORTER COMPAREDATE COMPAREDATE2 FIXNAME GETRF GETFTS DATESORT GETDATE GETINFORMATION CORRECTDATE MAKEFINALFILE) (ADDVARS (BackgroundMenuCommands ("Date Sorter" '(DATESORTER) "Sort a Mail file by date"))) (VARS (BackgroundMenu) (DEFAULTDATESORT NIL)))) (READVAR-FROM-STRING 'RQIREADTABLE "{D(9 10 11 25 31 32 39 44 63 96 124)OTHER OTHER SEPRCHAR (MACRO FIRST (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL)))) OTHER OTHER (MACRO FIRST READ') (MACRO FIRST READBQUOTECOMMA) (INFIX FIRST NOESCQUOTE DO?) (MACRO FIRST READBQUOTE) (INFIX ALWAYS READVBAR) } ") (DEFINEQ (DATESORTER [LAMBDA NIL (* edited%: "28-Jan-86 11:24") (ADD.PROCESS '(DATESORT) 'NAME 'DATESORTER 'INFOHOOK '(PROMPTPRINT "This is the Mail Date Sorter process" "Killing this process may leave open files, so make sure to close them" " and erase the files in {CORE}"]) (COMPAREDATE [LAMBDA (A B) (* edited%: "21-Jan-86 15:57") (PROG NIL (RETURN (OR (NOT (IDATE (CAR B))) (AND (IDATE (CAR A)) (ILESSP (IDATE (CAR A)) (IDATE (CAR B]) (COMPAREDATE2 [LAMBDA (A B) (* edited%: "23-Jan-86 17:45") (PROG NIL (RETURN (OR (NOT (IDATE (CAR A))) (AND (IDATE (CAR B)) (ILESSP (IDATE (CAR A)) (IDATE (CAR B]) (FIXNAME [LAMBDA (NAMETOFIX RVFLG) (* edited%: "23-Jan-86 14:43") (PROG NIL (RETURN (PACKFILENAME (if (MEMB 'EXTENSION (UNPACKFILENAME NAMETOFIX)) then [if RVFLG then (UNPACKFILENAME NAMETOFIX) else (for X in (UNPACKFILENAME NAMETOFIX) collect X until (EQUAL X 'VERSION] else (if RVFLG then (APPEND (UNPACKFILENAME NAMETOFIX) '(EXTENSION MAIL)) else (for X in (APPEND (UNPACKFILENAME NAMETOFIX) '(EXTENSION MAIL)) collect X until (EQUAL X 'VERSION]) (GETRF [LAMBDA (RF FTS) (* edited%: "23-Jan-86 15:04") (PROG NIL (SETQ FTS (FULLNAME (FIXNAME FTS) 'NEW)) (if (NOT RF) then (SETQ RF (MKATOM (PROMPTFORWORD "Enter name of resulting file: " FTS))) (TERPRI T)) (if [AND RF (SETQ RF (FULLNAME (FIXNAME RF) 'NEW] then (RETURN RF) else (RETURN]) (GETFTS [LAMBDA (FTS) (* edited%: "23-Jan-86 15:05") (PROG NIL (if (NOT FTS) then (SETQ FTS (MKATOM (PROMPTFORWORD "Enter name of file to be sorted: "))) (TERPRI T)) (if [AND FTS (SETQ FTS (FULLNAME (FIXNAME FTS T] then (RETURN FTS) else (RETURN]) (DATESORT [LAMBDA (FILETOSORT SORTEDFILE) (* edited%: "23-Jan-86 17:48") (PROG (COREFILE FILEINFO RESULTS) (CLRPROMPT) (* Code to check the filenames and  error if problems!!) (if (SETQ FILETOSORT (GETFTS FILETOSORT)) then (if (NOT (SETQ SORTEDFILE (GETRF SORTEDFILE FILETOSORT))) then (PRINTOUT PROMPTWINDOW "Error, no file to sort to ...aborted!" T) (FLASHWINDOW) (RETURN (CLOSEW T))) else (PRINTOUT PROMPTWINDOW "Error, no file to sort or file not found " FILETOSORT " ...aborted!" T) (FLASHWINDOW) (RETURN (CLOSEW T))) (* Error on file being open -  FATAL) (if (OPENP FILETOSORT) then (PRINTOUT PROMPTWINDOW "File to be sorted is already open ...aborted" T) (FLASHWINDOW) (RETURN (CLOSEW T))) (PRINTOUT T "Working ..." T) (SETQ COREFILE (COPYFILE FILETOSORT '{CORE}DATESORT.SCRATCH)) (SETQ COREFILE (OPENSTREAM COREFILE 'INPUT 'OLD)) (SETQ FILEINFO (GETINFORMATION COREFILE)) (CLOSEF COREFILE) (DELFILE COREFILE) (if DEFAULTDATESORT then (SORT FILEINFO 'COMPAREDATE) else (SORT FILEINFO 'COMPAREDATE2)) (BLOCK) (SETQ RESULTS (MAKEFINALFILE FILETOSORT SORTEDFILE FILEINFO)) (if RESULTS then (PRINTOUT PROMPTWINDOW " Messages sorted" T) (FLASHWINDOW PROMPTWINDOW) (CLOSEW T) (RETURN SORTEDFILE) else (PRINTOUT PROMPTWINDOW "Errors...") (FLASHWINDOW) (CLOSEW T) (RETURN "Errors..."]) (GETDATE [LAMBDA (GDFIL GDBEG GDNEXT) (* edited%: "22-Jan-86 10:25") (PROG NIL (SETFILEPTR GDFIL (FFILEPOS "DATE: " GDFIL GDBEG GDNEXT NIL NIL UPPERCASEARRAY)) (RSTRING GDFIL) (RETURN (RSTRING GDFIL RQIREADTABLE]) (GETINFORMATION [LAMBDA (SFIL) (* edited%: "23-Jan-86 17:20") (* Will return a list consisting of the Message number and the information  about it.) (PROG ((CURRENTSTART (FFILEPOS "*start*" SFIL 0)) (NEXTSTART 0) (MSGCOUNT 0) INFO) (repeatwhile (SETQ CURRENTSTART NEXTSTART) do (SETQ NEXTSTART (FFILEPOS "*start*" SFIL (ADD1 CURRENTSTART))) [SETQ INFO (APPEND INFO (LIST (LIST (GETDATE SFIL CURRENTSTART NEXTSTART) CURRENTSTART NEXTSTART] (BLOCK)) [SETQ INFO (for X in INFO collect (APPEND (LIST (CORRECTDATE (CAR X))) (CDR X] (* fixes bug when a date is of the form Wed 16 Dec...) (RETURN INFO]) (CORRECTDATE [LAMBDA (DATETOFIX) (* edited%: "22-Jan-86 09:52") (PROG (TEMP) (if (IDATE DATETOFIX) then (RETURN DATETOFIX) else (SETQ TEMP (GNC DATETOFIX)) (until (NUMBERP TEMP) do (SETQ TEMP (GNC DATETOFIX))) (RETURN (CONCAT TEMP DATETOFIX]) (MAKEFINALFILE [LAMBDA (FROMFILE TOFILE DATESLIST) (* edited%: "23-Jan-86 17:27") (PROG (ENDOFMSG) (if (OR (OPENP FROMFILE) (OPENP TOFILE)) then (PRINTOUT PROMPTWINDOW "File open in conflicting way ... aborted" T) (FLASHWINDOW) (RETURN)) (SETQ FROMFILE (OPENSTREAM FROMFILE 'INPUT 'OLD)) (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT 'NEW)) (for X in DATESLIST do (if (SETQ ENDOFMSG (CADDR X)) then (COPYBYTES FROMFILE TOFILE (CADR X) ENDOFMSG) else (COPYBYTES FROMFILE TOFILE (CADR X) (GETEOFPTR FROMFILE))) (BLOCK)) (CLOSEF TOFILE) (CLOSEF FROMFILE) (RETURN TOFILE]) ) (ADDTOVAR BackgroundMenuCommands ("Date Sorter" '(DATESORTER) "Sort a Mail file by date")) (RPAQQ BackgroundMenu NIL) (RPAQQ DEFAULTDATESORT NIL) (PUTPROPS DATESORT COPYRIGHT ("XEROX Corporation" 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1178 9047 (DATESORTER 1188 . 1685) (COMPAREDATE 1687 . 2005) (COMPAREDATE2 2007 . 2326) (FIXNAME 2328 . 3366) (GETRF 3368 . 3899) (GETFTS 3901 . 4314) (DATESORT 4316 . 6418) (GETDATE 6420 . 6711) (GETINFORMATION 6713 . 7676) (CORRECTDATE 7678 . 8067) (MAKEFINALFILE 8069 . 9045))))) STOP \ No newline at end of file diff --git a/lispusers/DATESORT.TEDIT b/lispusers/DATESORT.TEDIT new file mode 100644 index 00000000..0bca4dd0 --- /dev/null +++ b/lispusers/DATESORT.TEDIT @@ -0,0 +1 @@ +DATESORT [Internal Lafite Utility] Datesort places an item on the background menu. When selected you will be prompted for the name of a Lafite Mail folder to be sorted, and the name of a new resulting sorted folder. The folder messages will then be sorted in ascending order on their "Date:" fields (this takes some time). \ No newline at end of file diff --git a/lispusers/DEBUGGER-CONTEXT b/lispusers/DEBUGGER-CONTEXT new file mode 100644 index 00000000..5e8a2265 --- /dev/null +++ b/lispusers/DEBUGGER-CONTEXT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "14-Aug-87 17:09:50" il:{qv}convert>debugger-context.\;2 il:|changes| il:|to:| (il:commands "unlex") (il:functions open-lex-env init-debugger-context lex-eval-input) (il:vars il:debugger-contextcoms) il:|previous| il:|date:| "10-Aug-87 13:19:47" il:{qv}tools>lex-tool.\;1) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:debugger-contextcoms) (il:rpaqq il:debugger-contextcoms ( (il:* il:|;;;| "Debugger-Context -- fix the Xerox Lisp debugger so that you can work with lexically-defined functions, variables, blocks, and tag-bodies sensibly.") (il:* il:|;;;| "Written out of frustration by Herb Jellinek, 13-Aug-87.") (il:functions init-debugger-context lex-do-event open-lex-env) (il:variables xcl::*environment*) (il:p (init-debugger-context)) (il:commands "lex" "unlex") (il:prop il:makefile-environment il:debugger-context))) (il:* il:|;;;| "Debugger-Context -- fix the Xerox Lisp debugger so that you can work with lexically-defined functions, variables, blocks, and tag-bodies sensibly." ) (il:* il:|;;;| "Written out of frustration by Herb Jellinek, 13-Aug-87.") (defun init-debugger-context nil "Set things up for the DEBUGGER-CONTEXT hack" (undoably (setf *per-exec-variables* (il:* il:\;  "cause *environment* to be bound to nil in each executive.") (acons 'xcl::*environment* nil *per-exec-variables*) ) (il:* il:\;  "\"advise\" do-event to look at *environment* for its env.") (unless (fboundp 'old-do-event) (setf (symbol-function 'old-do-event) (symbol-function 'il:do-event)) (setf (symbol-function 'il:do-event) (symbol-function 'lex-do-event))))) (defun lex-do-event (original-input env &optional (fn nil function-p)) "Replacement for the executive's old DO-EVENT function." (if function-p (old-do-event original-input (or env xcl::*environment*) fn) (old-do-event original-input (or env xcl::*environment*)))) (defun open-lex-env nil "Finds the 'current' lex env and makes this debugger instance use it" (let ((frame-vars (il:stkargs il:lastpos))) (declare (special il:lastpos)) (dolist (value frame-vars (format t ";; ? found no lexical environment") ) (if (il:environment-p value) (progn (setq xcl::*environment* value) (format t ";; set lexical environment") (return)))))) (defvar xcl::*environment* nil) (init-debugger-context) (defcommand ("lex" :debugger) nil "Sets the debugger's lexical environment to that of the selected frame" (open-lex-env) (il:* il:\; "") (values)) (defcommand ("unlex" :debugger) nil "Unsets the lexical environment in the debugger" (setq xcl::*environment* nil) (format t ";; unset lexical environment") (values)) (il:putprops il:debugger-context il:makefile-environment (:readtable "XCL" :package "XCL-USER")) (il:putprops il:debugger-context il:copyright ("Xerox Corporation" 1987)) il:stop \ No newline at end of file diff --git a/lispusers/DECL b/lispusers/DECL new file mode 100644 index 00000000..f906482a --- /dev/null +++ b/lispusers/DECL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Nov-87 13:42:29" {QV}PARSER>LYRIC>DECL.;2 159700 changes to%: (FNS *DECLMAC) previous date%: "23-Feb-87 13:22:27" {QV}PARSER>LYRIC>DECL.;1) (* " Copyright (c) 1983, 1984, 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DECLCOMS) (RPAQQ DECLCOMS [(* DECLTYPE machinery, declaration translator, and declaration enforcer) (LOCALVARS . T) (GLOBALVARS FILEPKGFLG CLISPCHANGE CLISPARRAY DWIMESSGAG NOSPELLFLG MSDATABASELST DECLTYPESARRAY COMMENTFLG CLISPCHARS DECLATOMS LCASEFLG DECLMESSAGES CLISPRETRANFLG) (E (RESETSAVE CLISPIFYPRETTYFLG NIL) (RESETSAVE PRETTYPRINTMACROS (APPEND '((DECL . QUOTE) (DPROGN . QUOTE) (DLAMBDA . QUOTE) (DPROG . QUOTE)) PRETTYPRINTMACROS))) (COMS (* Interface to file package) (FNS DECLTYPE DECLTYPES DUMPDECLTYPES GETDECLDEF) (FILEPKGCOMS DECLTYPES IGNOREDECL) (PROP ARGNAMES DECLTYPE)) (* User functions) (FNS COVERS GETDECLTYPEPROP SETDECLTYPEPROP SUBTYPES SUPERTYPES) (MACROS SELCOVERSQ SELTYPEQ) (ALISTS (PRETTYEQUIVLST SELCOVERSQ SELTYPEQ) (DWIMEQUIVLST SELCOVERSQ SELTYPEQ)) [P (SETSYNONYM '(THE TYPE) '(AS A TYPE] (* Internal machinery) (DECLARE%: DONTCOPY (RECORDS TYPEBLOCK TYPEDEF) (ALISTS (PRETTYPRINTYPEMACROS TYPEBLOCK))) (INITRECORDS TYPEBLOCK) (P (DEFPRINT 'TYPEBLOCK 'TBDEFPRINT)) (FNS CHECKTYPEXP COLLECTTYPES COVERSCTYPE COVERSTB COVERSTE CREATEFNPROP CREATEFNVAL DECLERROR DELETETB FINDDECLTYPE FINDPROP FINDTYPEXP GETCTYPE GETDECLTYPE GETDECLTYPE.NOERROR GETTBPROP INHERITPROP INITDECLTYPES LCCTYPE LCC2 MAKECTYPE MAKEDECLTYPE MAKEBINDFN MAKESETFN MAPTYPEUSERS NOTICETB PPDTYPE RECDTYPE DECLCHANGERECORD RECDEFTYPE REPROPTB SETTBPROP TBDEFPRINT TETYPE TYPEMSANAL TYPEMSANAL1 UNCOMPLETE UNSAVETYPE USERDECLTYPE USESTYPE) (BLOCKS (LCCTYPE LCCTYPE LCC2) (TYPEMSANAL TYPEMSANAL TYPEMSANAL1)) (* Test fn creation block) (FNS MAKETESTFN MAKETESTFNBLOCK COMBINE.TESTS FUNIFY MKNTHCAR MKNTHCDR OF.TESTFN TUPLE.TESTFN WHOSE.TESTFN) (BLOCKS (MAKETESTFNBLOCK MAKETESTFNBLOCK COMBINE.TESTS FUNIFY MKNTHCAR MKNTHCDR OF.TESTFN TUPLE.TESTFN WHOSE.TESTFN)) (* Machinery to compile recursive testfns) (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LABEL) (* Idioms. Expressed as macros for now) (DECLARE%: DONTCOPY EVAL@COMPILE (VARS DefaultBindFn DefaultSetFn) (ADDVARS (NLAMA MAKEDECLTYPEQ)) (MACROS ANYC DECLVARERROR DTYPENAME foreachTB GETCGETD KWOTEBOX LAMBIND LAMVAL MAKEDECLTYPEQ NONEC TESTFORM) (FNS TESTFORM) (ADDVARS (DONTCOMPILEFNS TESTFORM)) (TEMPLATES foreachTB MAKEDECLTYPEQ)) (* Runtime utility functions) (FNS EVERYCHAR LARGEP DECLRECURSING SMASHCAR) (DECLARE%: EVAL@COMPILE (MACROS LARGEP)) (DECLARE%: DONTCOPY EVAL@COMPILE (MACROS SMASHCAR)) (* translator of dprogs and dlambdas) (FNS ASSERT ASSERTFAULT ASSERTMAC \*DECL *DECLMAC \CHKINIT CHKINITMAC DECLCONSTANTP DD DECLCLISPTRAN DECLMSG DECLDWIMERROR DECLDWIMTESTFN DECLSET DECLSETQ DECLSETQQ DECLTRAN DECLVAR DLAMARGLIST DTYPE?TRAN EDITNEWSATLIST FORMUSESTB IGNOREDECL MAKETESTFORM PPDECL PPVARLIST SETQMAC THETRAN VALUEERROR \VARASRT VARASRT1 VARSETFN) (BLOCKS (DECLTRAN DECLTRAN DECLVAR) (PPDECL PPDECL PPVARLIST) (\VARASRT \VARASRT VARASRT1)) (* Declaration database fns) (FNS DECLOF DECLOF1 TBOF TYPEBLOCKOF VARDECL) (BLOCKS (DECLOFBLK DECLOF DECLOF1 TBOF TYPEBLOCKOF VARDECL (ENTRIES DECLOF TYPEBLOCKOF))) (* Enabling and disabling fns) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FNEQUIVS) (MACROS MOVEPROP PUTIFPROP)) (FNS STARTDECLS DODECLS) (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LAMBDATRAN) (DECLARE%: EVAL@COMPILE (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) SIMPLIFY)) [DECLARE%: EVAL@COMPILE DONTCOPY (* the old NOBOX code.) (FNS IBOX FBOX NBOX) (P (MOVD? 'LIST 'LBOX) (MOVD? 'CONS 'CBOX)) (RECORDS FBOX IBOX) (MACROS IBOX FBOX NBOX) (MACROS CBOX LBOX) (I.S.OPRS scratchcollect) (ADDVARS (SYSLOCALVARS $$SCCONS $$SCPTR) (INVISIBLEVARS $$SCCONS $$SCPTR)) (* Definition of WITH. From WITH.) (MACROS WITH) (TEMPLATES WITH) (P (REMPROP 'WITH 'CLISPWORD) (ADDTOVAR DWIMEQUIVLST (WITH . PROG)) (ADDTOVAR PRETTYEQUIVLST (WITH . PROG] [DECLARE%: DOCOPY (DECLARE%: EVAL@LOADWHEN (NEQ (SYSTEMTYPE) 'D) (P (OR (GETPROP 'LOADTIMECONSTANT 'FILEDATES) (PROG ((X (FINDFILE (PACKFILENAME 'NAME 'LOADTIMECONSTANT 'EXTENSION COMPILE.EXT) T LISPUSERSDIRECTORIES))) (COND (X (LOAD X 'SYSLOAD)) ((NOT (GETPROP 'LOADTIMECONSTANT 'MACRO)) (PUTPROP 'LOADTIMECONSTANT 'MACRO '((FORM) (CONSTANT FORM] (ADDVARS (OPENFNS \DECLPROGN \CHKVAL \CHKINIT ASSERT \*DECL \VARASRT)) (PROP CLISPWORD DPROG DPROGN THE the) (PROP INFO DLAMBDA DPROG DPROGN) (VARS (SATISFIESLIST) (CSATISFIESLIST) (NEWSATLIST T)) (INITVARS (DECLMESSAGES) (COMPILEIGNOREDECL)) [ADDVARS (DECLATOMS DLAMBDA DPROG DPROGN) (LAMBDASPLST DLAMBDA) (SYSLOCALVARS VALUE) [DESCRIBELST ("types: " (GETRELATION FN '(USE TYPE] (BAKTRACELST (\DECLPROGN (DPROGN APPLY *PROG*LAM \*DECL *ENV*) (NIL APPLY *PROG*LAM \*DECL)) (PROG (DPROG \DECLPROGN APPLY *PROG*LAM \*DECL)] (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SLISTENTRY VARDECL)) (ALISTS (LAMBDATRANFNS DLAMBDA)) [DECLARE%: DONTEVAL@LOAD (E (* Declare is so PRETTYPRINTMACROS don't get set up during LOADFROM, when PPDECL is not being defined. Don't use ALIST for print macros cause entries are removed while DECL is being dumped)) (ADDVARS (PRETTYPRINTMACROS (DPROGN . PPDECL) (DECL . PPDECL) (DLAMBDA . PPDECL) (DPROG . PPDECL] (PROP INFO ASSERT) (MACROS ASSERT .CBIND. \CHKINIT \CHKVAL \*DECL DECL DECLMSGMAC REALSETQ) (* MACROS REALSET) [P (AND (GETD 'STARTDECLS) (STARTDECLS)) (PROG [(COM (CDR (ASSOC 'DW EDITMACROS] (AND COM (RPLACD COM (CONS (APPEND '(RESETVAR NEWSATLIST (EDITNEWSATLIST)) (CDR COM] (* Builtin DECLOF properties) (PROP DECLOF APPEND CONS EQ LIST LISTP NCONC) [DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG NIL) (AND (GETD 'DODECLS) (RESETSAVE (DODECLS) '(DODECLS T] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DECLSETQ DECLMSG DD \CHKINIT \*DECL ASSERT DECLTYPES DECLTYPE) (NLAML DECLSETQQ TYPEMSANAL) (LAMA DECLDWIMERROR]) (* DECLTYPE machinery, declaration translator, and declaration enforcer) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FILEPKGFLG CLISPCHANGE CLISPARRAY DWIMESSGAG NOSPELLFLG MSDATABASELST DECLTYPESARRAY COMMENTFLG CLISPCHARS DECLATOMS LCASEFLG DECLMESSAGES CLISPRETRANFLG) ) (* Interface to file package) (DEFINEQ (DECLTYPE [NLAMBDA X (* bas%: " 7-NOV-79 16:22") (USERDECLTYPE (CAR X) (CADR X) (CDDR X]) (DECLTYPES [NLAMBDA DTS (* bas%: " 7-NOV-79 16:24") (* Defines a list of decltypes) (for D in DTS collect (USERDECLTYPE (CAR D) (CADR D) (CDDR D]) (DUMPDECLTYPES [LAMBDA (TL) (* rmk%: " 7-SEP-81 04:50") (WITH [[TWOFLG (OR (NLISTP TL) (LISTP (CDR TL] (FFLG (NEQ T (OUTPUT] (* Don't do the plural and extra parens if only one, and don't do the  EVAL@COMPILE stuff if going to T=SHOWDEF) (if FFLG then (printout NIL T "(DECLARE: EVAL@COMPILE" T T)) (printout NIL (if TWOFLG then "(DECLTYPES" else "(DECLTYPE ")) (for D in TL do (if TWOFLG then (printout NIL 11 "(")) [if (LISTP D) then (printout NIL |.P2| (CAR D) %, |.P2| (CAR D) %, |.P2| (CADR D) %, .PPV (GETDECLTYPEPROP (CAR D) (CADR D))) else [SETQ D (CDR (GETDECLDEF D NIL 'NOCOPY] (printout NIL |.P2| (CAR D) %,) (for TAIL (POS _ (POSITION)) on (CDDR D) by (CDDR TAIL) first (PRINTDEF (CADR D) POS) do (printout NIL .TAB POS |.P2| (CAR TAIL) %, .PPF (CADR TAIL] (if TWOFLG then (printout NIL ")"))) (printout NIL ")" T) (if FFLG then (printout NIL ")" T]) (GETDECLDEF [LAMBDA (NAME FPTYPE OPTIONS) (* bas%: " 9-OCT-79 23:04") (* This is the GETDEF function for DECLTYPE.  FPTYPE is the file-package-type argument, which we ignore.) (WITH ((TB (FINDDECLTYPE NAME)) (NOCOPYP (EQMEMB 'NOCOPY OPTIONS))) (if TB then [CONS 'DECLTYPE (CONS NAME (CONS (WITH ((TE (fetch TYPEXP of TB))) (if NOCOPYP then TE else (COPY TE))) (WITH ((TP (fetch PROPS of TB))) (if NOCOPYP then TP else (COPY TP] elseif (EQMEMB 'NOERROR OPTIONS) then NIL else (DECLERROR NAME "is not a DECLTYPE"]) ) (PUTDEF (QUOTE DECLTYPES) (QUOTE FILEPKGCOMS) '[[COM MACRO (X (E (DUMPDECLTYPES 'X] (TYPE DESCRIPTION "type declarations" GETDEF GETDECLDEF DELDEF (LAMBDA (NAME) (DELETETB (OR (FINDDECLTYPE NAME) (DECLERROR "Can't delete non-existent type:" NAME]) (PUTDEF (QUOTE IGNOREDECL) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: DOEVAL@COMPILE DONTEVAL@LOAD DONTCOPY (P (RESETSAVE COMPILEIGNOREDECL 'X]) (PUTPROPS DECLTYPE ARGNAMES (NIL (NAME TYPE PROP1 VAL1 |...|) . X)) (* User functions) (DEFINEQ (COVERS [LAMBDA (HI LO) (* bas%: "16-OCT-79 11:22") (AND (COVERSTB (GETDECLTYPE HI) (GETDECLTYPE LO)) T]) (GETDECLTYPEPROP [LAMBDA (TYPE PROP) (* bas%: " 9-OCT-79 22:56") (GETTBPROP (GETDECLTYPE TYPE) PROP]) (SETDECLTYPEPROP [LAMBDA (NAME PROP VAL) (* rmk%: " 2-AUG-81 08:41") (OR (LITATOM NAME) (DECLERROR "Can't set property of non-atomic type:" NAME)) (REPROPTB (OR (FINDDECLTYPE NAME) (DECLERROR "Can't set property of non-existent type:" NAME)) (LIST PROP VAL)) (MARKASCHANGED (LIST NAME PROP) 'DECLTYPES) VAL]) (SUBTYPES [LAMBDA (NAME) (* bas%: "16-OCT-79 18:59") (PROG (TYPES CT (BT (GETDECLTYPE NAME))) (DECLARE (SPECVARS TYPES CT)) (SETQ CT (GETCTYPE BT)) (if (NONEC CT) elseif (EQ (CAR (fetch TYPEXP of BT)) 'ONEOF) then [RETURN (APPEND (CDR (fetch TYPEXP of BT] else [foreachTB S (AND (LITATOM (fetch NAME of S)) (FMEMB CT (GETCTYPE S)) (push TYPES (fetch NAME of S] (RETURN (OR TYPES (LIST 'NONE]) (SUPERTYPES [LAMBDA (NAME) (* bas%: "16-OCT-79 18:20") (PROG (TYPES (CN (GETCGETD NAME))) (DECLARE (SPECVARS TYPES CN)) [if (ANYC CN) then NIL else (foreachTB TB (AND (LITATOM (fetch NAME of TB)) (if (NONEC CN) then (* Very expensive, but kinda wierd) (NULL (SUBTYPES (fetch NAME of TB))) else (* Any sups will be complete so we dont need to complete here) (FMEMB (fetch CTYPE of (fetch DEF of TB)) CN)) (push TYPES (fetch NAME of TB] (RETURN TYPES]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS SELCOVERSQ MACRO (F (LIST [LIST 'LAMBDA '($$TMP) (CONS 'COND (MAPLIST (CDR F) (FUNCTION (LAMBDA (I) (COND ((CDR I) (CONS (LIST 'COVERS (KWOTE (CAAR I)) '$$TMP) (CDAR I))) (T (LIST T (CAR I] (LIST 'DECLOF (CAR F] [PUTPROPS SELTYPEQ MACRO (F (APPLYFORM [LIST 'LAMBDA '($$TMP) (CONS 'COND (MAPLIST (CDR F) (FUNCTION (LAMBDA (I) (COND ((CDR I) (CONS (LIST 'TYPE? (CAAR I) '$$TMP) (CDAR I))) (T (LIST T (CAR I] (CAR F] ) (ADDTOVAR PRETTYEQUIVLST (SELCOVERSQ . SELECTQ) (SELTYPEQ . SELECTQ)) (ADDTOVAR DWIMEQUIVLST (SELCOVERSQ . SELECTQ) (SELTYPEQ . SELECTQ)) (SETSYNONYM '(THE TYPE) '(AS A TYPE)) (* Internal machinery) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE TYPEBLOCK (NAME DEF BF SF TF PROPS) [ACCESSFNS TYPEBLOCK ([TYPEXP (fetch TEXP of (fetch DEF of DATUM)) (replace DEF of DATUM with (create TYPEDEF TEXP _ (COPY NEWVALUE] (BINDFN (OR (fetch BF of DATUM) (MAKEBINDFN DATUM)) (replace BF of DATUM with NEWVALUE)) (SETFN (OR (fetch SF of DATUM) (MAKESETFN DATUM)) (replace SF of DATUM with NEWVALUE)) (TESTFN (OR (fetch TF of DATUM) (MAKETESTFN DATUM)) (replace TF of DATUM with NEWVALUE] [CCREATE (PROGN (OR (FASSOC 'NAME FIELDS.IN.CREATE) (HELP "No NAME field in TYPEBLOCK create")) (OR (FASSOC 'TYPEXP FIELDS.IN.CREATE) (FASSOC 'DEF FIELDS.IN.CREATE) (HELP "No type expression in TYPEBLOCK create")) (LIST 'NOTICETB 'DATUM (CADR (FASSOC 'NAME FIELDS.IN.CREATE] (SYSTEM)) (RECORD TYPEDEF (TEXP . CTYPE)) ) (/DECLAREDATATYPE 'TYPEBLOCK '(POINTER POINTER POINTER POINTER POINTER POINTER) '((TYPEBLOCK 0 POINTER) (TYPEBLOCK 2 POINTER) (TYPEBLOCK 4 POINTER) (TYPEBLOCK 6 POINTER) (TYPEBLOCK 8 POINTER) (TYPEBLOCK 10 POINTER)) '12) (ADDTOVAR PRETTYPRINTYPEMACROS (TYPEBLOCK . PPDTYPE)) ) (/DECLAREDATATYPE 'TYPEBLOCK '(POINTER POINTER POINTER POINTER POINTER POINTER) '((TYPEBLOCK 0 POINTER) (TYPEBLOCK 2 POINTER) (TYPEBLOCK 4 POINTER) (TYPEBLOCK 6 POINTER) (TYPEBLOCK 8 POINTER) (TYPEBLOCK 10 POINTER)) '12) (DEFPRINT 'TYPEBLOCK 'TBDEFPRINT) (DEFINEQ (CHECKTYPEXP [LAMBDA (TE) (* bas%: "18-OCT-79 16:58") (* Checks that a type expression is  structurally valid) (OR (TETYPE TE) (DECLERROR "Invalid type expression" TE]) (COLLECTTYPES [LAMBDA (TYPES MERGE) (* bas%: " 9-OCT-79 22:53") (* Converts a list of type names into a list of typeblocks merging together  those that lie on the same sup-sub chain to the highest or lowest member of  that chain as specified by MERGE) (for SCR I VAL in TYPES eachtime (SETQ I (GETDECLTYPE SCR)) unless [for J in VAL thereis (OR (EQ I J) (SELECTQ MERGE (UP (COVERSTB J I)) (DOWN (COVERSTB I J)) (SHOULDNT] do (SETQ VAL (CONS I VAL)) (* Add to VAL unless dominated by an already existing entry) finally (* Walk back down list throwing out anything that is dominated by a subsequent  addition) (SETQ SCR VAL) (SETQ VAL NIL) [while SCR do (SETQ SCR (PROG1 (CDR SCR) (if (for J in VAL never (SELECTQ MERGE (UP (COVERSTB J (CAR SCR))) (DOWN (COVERSTB (CAR SCR) J)) (SHOULDNT))) then (RPLACD SCR VAL) (SETQ VAL SCR] (RETURN VAL]) (COVERSCTYPE [LAMBDA (H L) (* bas%: "11-OCT-79 11:35") (* COVERS for CTYPEs) (PROG NIL (* We use a PROG so we can chase singleton supertypes which are the common case  by looping rather than recursion.) LP (if (EQ H L) then (RETURN T) elseif (NLISTP L) then (RETURN (NONEC L)) (* Either we had NONE to start or we have arrived at ANY) elseif (CDR L) then (RETURN (for I in L thereis (COVERSCTYPE H I))) else (SETQ L (CAR L)) (* Single supertype) (GO LP]) (COVERSTB [LAMBDA (H L) (* bas%: "19-OCT-79 17:40") (* COVERS for type blocks. COVERSTE gets some cases that are difficult from the  lattice.) (OR (EQ H L) (COVERSCTYPE (GETCTYPE H) (GETCTYPE L)) (COVERSTE (fetch TYPEXP of H) (fetch TYPEXP of L]) (COVERSTE [LAMBDA (H L) (* bas%: "31-OCT-79 14:34") (* COVERS for type expressions. We pick off MEMQ and ONEOFs here because they  cannot be efficiently linked into the type lattice.) (SELECTQ (TETYPE H) (ONEOF (SELECTQ (TETYPE L) (ONEOF (for I in (CDR L) always (for J in (CDR H) thereis (COVERS J I)))) (for I in (CDR H) thereis (COVERS I L)))) (MEMQ (SELECTQ (TETYPE L) (MEMQ (for I in (CDR L) always (MEMBER I (CDR H)))) NIL)) NIL]) (CREATEFNPROP [LAMBDA (PL PN) (* bas%: " 7-NOV-79 16:51") (* If a value for prop PN appears on PL, CREATEFNVAL it.  NIL will indicate that no specification has yet been made.) (WITH ((PE (FINDPROP PL PN))) (AND PE (CREATEFNVAL (CADR PE) PN]) (CREATEFNVAL [LAMBDA (FVAL FNAME) (* bas%: " 7-NOV-79 16:53") (* Gets given a purported FNVAL. If that value is NIL, use the default.  Dwimify a list value.) (DECLARE (USEDFREE DWIMFLG)) (if FVAL then (AND DWIMFLG (LISTP FVAL) (DWIMIFY FVAL T)) FVAL else (SELECTQ FNAME (BINDFN (CONSTANT DefaultBindFn)) (SETFN (CONSTANT DefaultSetFn)) NIL]) (DECLERROR [LAMBDA (MSG1 MSG2) (* bas%: "25-NOV-78 18:25") (if (BOUNDP 'DECLERROR) then (SETQ DECLERROR T) (ERROR!) else (ERROR MSG1 MSG2]) (DELETETB [LAMBDA (TB) (* rmk%: "19-AUG-81 00:15") (* Dissasociates TB from its name and undoes any dependencies on it) (WITH ((NAME (fetch NAME of TB))) (SELECTQ NAME ((ANY NONE) (DECLERROR "(Futile) attempt to delete" NAME)) NIL) (UNSAVETYPE TB) (* Unsave dependent code) (UNCOMPLETE TB) (* Undo the cached values and  dependent types) (NOTICETB NIL NAME) (* Snap name association) (replace NAME of TB with (PACK* 'Deleted NAME]) (FINDDECLTYPE [LAMBDA (TE) (* bas%: "10-OCT-79 01:46") (* Finds the existing typeblock for a type expression if any) (COND ((LISTP TE) (* TE must be in CLISPARRAY to detect edits of the type expression) (AND (GETHASH TE CLISPARRAY) (GETHASH TE DECLTYPESARRAY))) (T (OR (GETHASH TE DECLTYPESARRAY) (RECDTYPE TE]) (FINDPROP [LAMBDA (L P) (* rmk%: "12-Mar-85 08:56") (for TAIL on L by (CDR (LISTP (CDR TAIL))) thereis (EQ P (CAR TAIL]) (FINDTYPEXP [LAMBDA (TYPE) (* bas%: "16-OCT-79 14:17") (* Tries to find an equivalent TYPEBLOCK for the expression TYPE) (DECLARE (SPECVARS TYPE)) (foreachTB TB (if (AND (LISTP (fetch NAME of TB)) (EQUAL TYPE (fetch TYPEXP of TB))) then (OR (EQUAL TYPE (fetch NAME of TB)) (replace NAME of TB with TYPE)) (* NAME has been edited) (NOTICETB TB TYPE) (* Remember this path) (RETFROM 'FINDTYPEXP TB))) NIL]) (GETCTYPE [LAMBDA (TB) (* rmk%: "29-NOV-81 14:33") (OR (fetch CTYPE of (fetch DEF of TB)) (if (DECLRECURSING 'GETCTYPE TB) then (DECLERROR "Invalid recursive type definition" (fetch TYPEXP of TB))) (replace CTYPE of (fetch DEF of TB) with (MAKECTYPE (fetch TYPEXP of TB]) (GETDECLTYPE [LAMBDA (TE VARNAME) (* bas%: "18-OCT-79 15:38") (* Either finds a typeblock with TE as its type expression or creates one.  We smuggle the name thru in the PROPS field as anyone who specifies a VARNAME  is unnamed so neither has nor can acquire any properties.) (OR (FINDDECLTYPE TE) (AND (LISTP TE) (OR (FINDTYPEXP TE) (MAKEDECLTYPE TE TE VARNAME))) (DECLERROR TE "is not a DECLTYPE"]) (GETDECLTYPE.NOERROR [LAMBDA (TE VAR) (* bas%: "19-OCT-79 16:05") (* Makes and completes a typeblock for TE suppressing any DECLERRORs) (WITH ((DECLERROR)) (DECLARE (SPECVARS DECLERROR)) (OR (CAR (ERSETQ (WITH ((TB (GETDECLTYPE TE VAR))) (* Force completion so any errors will happen now under the ERSETQ) (GETCTYPE TB) (fetch TESTFN of TB) TB))) (COND (DECLERROR NIL) (T (ERROR!]) (GETTBPROP [LAMBDA (TB P) (* bas%: "15-AUG-79 23:49") (SELECTQ P (BINDFN (fetch BINDFN of TB)) (SETFN (fetch SETFN of TB)) (TESTFN (fetch TESTFN of TB)) (WITH ((PL (FINDPROP (fetch PROPS of TB) P))) (if PL then (CADR PL) else (INHERITPROP TB P]) (INHERITPROP [LAMBDA (TB PROP) (* bas%: "19-OCT-79 16:45") (* Determines how types inherit their properties on the basis of the way they  were formed from other types) (WITH ((TE (fetch TYPEXP of TB))) (AND (LISTP TE) (GETDECLTYPEPROP (SELECTQ (TETYPE TE) ((ALLOF ONEOF) (WITH ((V (GETDECLTYPEPROP (CADR TE) PROP)) (ANYVAL (GETDECLTYPEPROP 'ANY PROP))) (RETFROM 'INHERITPROP (if [OR (EQ V ANYVAL) (for I in (CDDR TE) always (EQ V (GETDECLTYPEPROP I PROP] then V else ANYVAL)))) ((OF SATISFIES WHOSE) (CAR TE)) (MEMQ (CONS 'ONEOF (for I in (CDR TE) collect (DTYPENAME I)))) (SHARED (if (EQ PROP 'BINDFN) then (RETFROM 'INHERITPROP (CONSTANT DefaultBindFn)) else (CADR TE))) ((SUBTYPE SYNONYM) (CADR TE)) (TUPLE 'LISTP) 'ANY) PROP]) (INITDECLTYPES [LAMBDA NIL (* rmk%: "14-SEP-82 22:17") (* Initializes DECLTYPES hash array) [COND ((BOUNDP 'DECLTYPESARRAY) (CLRHASH DECLTYPESARRAY)) (T (SETQ DECLTYPESARRAY (CONS (HARRAY 128) 128] (FILEPKGCHANGES 'DECLTYPES NIL) (* Make FILEPKG forget about any types it may have noticed.) (RESETVARS (FILEPKGFLG) [for I in '(ANY NONE) do (create TYPEBLOCK NAME _ I DEF _ (create TYPEDEF TEXP _ I CTYPE _ I) BINDFN _ (CONSTANT DefaultBindFn) SETFN _ (CONSTANT DefaultSetFn) TESTFN _ (LAMVAL (EQ I 'ANY] (* ANY and NONE are created complete) (MAKEDECLTYPEQ ARRAYP (SUBTYPE ANY) (TESTFN ARRAYP)) (MAKEDECLTYPEQ HARRAYP (SUBTYPE ARRAYP) (TESTFN HARRAYP)) (MAKEDECLTYPEQ LISTP (SUBTYPE ANY) (TESTFN LISTP EVERYFN EVERY)) [MAKEDECLTYPEQ HASHARRAY (ONEOF HARRAYP (LISTP (WHOSE (CAR HARRAYP] (MAKEDECLTYPEQ READTABLEP (SUBTYPE ARRAYP) (TESTFN READTABLEP)) (MAKEDECLTYPEQ ATOM (SUBTYPE ANY) (TESTFN ATOM)) (MAKEDECLTYPEQ LITATOM (SUBTYPE ATOM) (TESTFN LITATOM)) (MAKEDECLTYPEQ BOOL (MEMQ NIL T)) (MAKEDECLTYPEQ NUMBERP (SUBTYPE ATOM) (TESTFN NUMBERP)) (MAKEDECLTYPEQ FIXP (SUBTYPE NUMBERP) (TESTFN FIXP)) [MAKEDECLTYPEQ CARDINAL (FIXP (SATISFIES (IGEQ VALUE 0] (MAKEDECLTYPEQ SMALLP (SUBTYPE FIXP) (TESTFN SMALLP)) (MAKEDECLTYPEQ LARGEP (SUBTYPE FIXP) (TESTFN LARGEP)) (MAKEDECLTYPEQ FLOATP (SUBTYPE NUMBERP) (TESTFN FLOATP)) (MAKEDECLTYPEQ FUNCTION (SUBTYPE ANY) (TESTFN FNTYP)) (MAKEDECLTYPEQ NIL (MEMQ NIL) (TESTFN NULL)) (MAKEDECLTYPEQ LST (ONEOF LISTP NIL) (EVERYFN EVERY)) (MAKEDECLTYPEQ ALIST (LST OF LISTP)) (MAKEDECLTYPEQ STACKP (SUBTYPE ANY) (TESTFN STACKP)) (MAKEDECLTYPEQ STRINGP (SUBTYPE ANY) (TESTFN STRINGP EVERYFN EVERYCHAR]) (LCCTYPE [LAMBDA (TL) (* bas%: "18-SEP-79 17:24") (* Returns the lowest common ctype for the type names in TL) (WITH [(C1 (GETCGETD (CAR TL] (if (CDR TL) then (LCC2 C1 (LCCTYPE (CDR TL))) else C1]) (LCC2 [LAMBDA (A B) (* bas%: "10-OCT-79 19:12") (* Returns the lcd of A and B) (if (COVERSCTYPE A B) then A elseif (COVERSCTYPE B A) then B else (for I C in A do (WITH ((D (LCC2 I B))) (if (OR (NULL C) (COVERSCTYPE C D)) then (SETQ C D))) finally (RETURN C]) (MAKECTYPE [LAMBDA (TE) (* bas%: "31-OCT-79 16:44") (* Computes the real sup types of TE) (SELECTQ (TETYPE TE) (ALLOF [WITH [(S (COLLECTTYPES (CDR TE) 'DOWN] (if (CDR S) then (SMASHCAR S (FUNCTION GETCTYPE)) else (* They are all on the same path) (GETCTYPE (CAR S]) (ONEOF [WITH [(S (COLLECTTYPES (CDR TE) 'UP] (* Rather than having the subtypes point to this new ctype, we pick that case  up in COVERS to avoid making the supertype structure bushy.) (if (CDR S) then (LIST (LCCTYPE (CDR TE))) else (* All on the same path) (GETCTYPE (CAR S]) ((SHARED SYNONYM) (GETCGETD (CADR TE))) (LIST (SELECTQ (TETYPE TE) (MEMQ (LCCTYPE (for I in (CDR TE) scratchcollect (DTYPENAME I)))) (GETCGETD (SELECTQ (TETYPE TE) ((OF SATISFIES WHOSE) (CAR TE)) (SUBTYPE (CADR TE)) (TUPLE (if (CDR TE) then 'LISTP else 'NIL)) (SHOULDNT]) (MAKEDECLTYPE [LAMBDA (NAME DECL PROPS) (* bas%: " 7-NOV-79 16:33") (* Defines the type specified by the  type expression DECL) (CHECKTYPEXP DECL) (* Provides an early check on well  formedness) (WITH [(TB (create TYPEBLOCK NAME _ NAME TYPEXP _ DECL PROPS _ (COPY PROPS] (if (LISTP PROPS) then (replace BINDFN of TB with (CREATEFNPROP PROPS 'BINDFN)) (replace SETFN of TB with (CREATEFNPROP PROPS 'SETFN)) (replace TESTFN of TB with (CREATEFNPROP PROPS 'TESTFN)) (CREATEFNPROP PROPS 'EVERYFN)) TB]) (MAKEBINDFN [LAMBDA (TB) (* bas%: "18-OCT-79 18:17") (* Finds a BINDFN for TB) (replace BINDFN of TB with (INHERITPROP TB 'BINDFN]) (MAKESETFN [LAMBDA (TB) (* bas%: "18-OCT-79 21:17") (* Finds a SETFN for TB) (replace SETFN of TB with (INHERITPROP TB 'SETFN]) (MAPTYPEUSERS [LAMBDA (NAME FN) (* bas%: "28-AUG-79 22:18") (DECLARE (SPECVARS . T)) (foreachTB TB (AND (USESTYPE NAME (fetch TYPEXP of TB)) (APPLY* FN TB]) (NOTICETB [LAMBDA (TBLOCK TEXP) (* rmk%: " 7-SEP-81 03:26") (* Enters hash links so TBLOCK can be found given type expression TEXP) (if (LISTP TEXP) then (PUTHASH TEXP TEXP CLISPARRAY) (* Access name is also in CLISPARRAY  to detect changes)) (PUTHASH TEXP TBLOCK DECLTYPESARRAY]) (PPDTYPE [LAMBDA (TYPE) (* bas%: "18-OCT-79 17:57") (* PPs typeblock, completing unless  NOCOMPFLG) (WITH [(LM (IPLUS 4 (POSITION))) (TB (if (type? TYPEBLOCK TYPE) then TYPE else (GETDECLTYPE TYPE] (printout NIL "DECLTYPE: " (fetch NAME of TB) " = " (OR (fetch TYPEXP of TB) "No type expression")) (printout NIL .TAB LM "Suptypes: ") (if (fetch CTYPE of (fetch DEF of TB)) then (for I in (GETCTYPE TB) declare (SPECVARS I) do (printout NIL .TAB0 (IPLUS LM 10)) (* Start each new suptype list on a  new line) (foreachTB S (AND (EQ I (fetch CTYPE of (fetch DEF of S))) (printout NIL (fetch NAME of S) %,))) (* Dont force a completion to get the  CTYPE)) else (printout NIL "... not completed...")) (if (fetch BF of TB) then (printout NIL .TAB LM "Bindfn: " .PPF (fetch BF of TB))) (if (fetch SF of TB) then (printout NIL .TAB LM "Setfn: " .PPF (fetch SF of TB))) (if (fetch TF of TB) then (printout NIL .TAB LM "Testfn: " .PPF (fetch TF of TB))) [if (fetch PROPS of TB) then (printout NIL .TAB LM "Property: ") (for P on (fetch PROPS of TB) by (CDDR P) do (printout NIL .TAB0 (IPLUS LM 10) (CAR P) " = " |.P2| (CADR P] (TERPRI) TB]) (RECDTYPE [LAMBDA (R) (* rmk%: " 6-SEP-81 04:29") (WITH [RDECL TB (TST (LIST 'type? R (CONS 'NILL] (* The CONS produces a unique, dwim-immune object to give RECORDTRAN to  dwimify. We can then substitute for it to build the testfn.) (COND ([RESETVARS (CLISPCHANGE (DWIMESSGAG T)) (* CLISPCHANGE bound cause RECORDTRAN  sets it) (* If the record package translation bombs, simply return NIL to GETDECLTYPE,  which might then print an error message.) (RETURN (NLSETQ (RECORDTRAN TST 'DTYPE?TRAN] (SETQ RDECL (RECLOOK R)) [SETQ TB (create TYPEBLOCK NAME _ R TYPEXP _ (LIST 'SUBTYPE (RECDEFTYPE RDECL] (* Use SETTBPROP to store TESTFN rather than doing it in the create, so that it  also shows up on the property list. Then the decltype will print with all its  info.) [SETTBPROP TB 'TESTFN (LAMVAL (LIST COMMENTFLG 'ASSERT%: (LIST 'RECORD R)) (SUBST 'VALUE (CADDR TST) (PROG1 (GETHASH TST CLISPARRAY) (PUTHASH TST NIL CLISPARRAY] (* The record package stores the DECL form in 9th car of the translation) (for X on (CDAR (FNTH (GETHASH RDECL CLISPARRAY) 9)) by (CDDR X) do (SETTBPROP TB (CAR X) (CADR X))) TB]) (DECLCHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* rmk%: " 7-SEP-81 04:17") (* CHANGERECORD is the default value of RECORDCHANGEFN, which is applied by  RECREDECLARE. This makes sure that a record change wipes out a dependent  decltype) (REALCHANGERECORD RNAME RFIELDS OLDFLG) (AND OLDFLG (WITH (TEMP (TB (GETHASH RNAME DECLTYPESARRAY))) (* This is a marginal guess at the dependency%: we would be wrong if the user  had, e.g., dumped a record-derived decltype and loaded it into a system without  the record.) (if (AND TB (SETQ TEMP (fetch TESTFN of TB)) [EQ COMMENTFLG (CAR (SETQ TEMP (CADDR TEMP] (EQ (CADR TEMP) 'ASSERT%:) (EQ (CAR (SETQ TEMP (CADDR TEMP))) 'RECORD) (EQ RNAME (CADR TEMP))) then (DELETETB TB]) (RECDEFTYPE [LAMBDA (RD) (* bas%: "21-SEP-79 14:53") (* Computes the DECLOF type corresponding to a record package type expression) (SELECTQ (CAR RD) (ACCESSFNS (WITH ((CRF (FASSOC 'CREATE RD))) (if CRF then (DECLOF (CADR CRF)) else 'ANY))) (ARRAYRECORD 'ARRAYP) (ASSOCRECORD 'ALIST) (ATOMRECORD 'LITATOM) (DATATYPE (if (LISTP (CADR RD)) then (CADADR RD) else 'ANY)) (HASHLINK 'HARRAYP) (PROPRECORD 'LST) (RECORD (WITH ((FLDS (CADDR RD))) (if (LISTP FLDS) then 'LST elseif [AND FLDS (EQ FLDS (CADR (FASSOC 'SUBRECORD RD] then (* The declaration has a top-level field equal to the subrecord name) FLDS else 'ANY))) (TYPERECORD 'LISTP) 'ANY]) (REPROPTB [LAMBDA (TB PROPS INHERITING) (* bas%: " 7-NOV-79 15:46") (* Propgates changes in properties) (PROG [(NEWP (for old PROPS by (CDDR PROPS) while PROPS unless [if INHERITING then (FINDPROP (fetch PROPS of TB) (CAR PROPS)) else (EQUAL (CADR PROPS) (LISTGET (fetch PROPS of TB) (CAR PROPS] join (SETTBPROP TB (CAR PROPS) (COPY (CADR PROPS)) INHERITING) (LIST (CAR PROPS) (CADR PROPS] (DECLARE (SPECVARS NEWP)) [if NEWP then (UNSAVETYPE TB) (* Probably not necessary, but we cant  tell) (MAPTYPEUSERS (fetch NAME of TB) (FUNCTION (LAMBDA (X) (REPROPTB X NEWP T] (* Any recursions bottom out b/c the change will have been made the first time  the type is reached) (RETURN NEWP) (* Indicate if any changes) ]) (SETTBPROP [LAMBDA (TB P V BLKONLY) (* bas%: " 7-NOV-79 16:55") (SELECTQ P (BINDFN (replace BINDFN of TB with (CREATEFNVAL V 'BINDFN))) (EVERYFN (CREATEFNVAL V 'EVERYFN)) (SETFN (replace SETFN of TB with (CREATEFNVAL V 'SETFN))) (TESTFN [SELECTQ (fetch NAME of TB) ((ANY NONE) (DECLERROR "(Futile) attempt to change TESTFN of" (fetch NAME of TB))) (replace TESTFN of TB with (CREATEFNVAL V 'TESTFN]) NIL) (* Unless BLKONLY, must also put on property list so it is known) (if BLKONLY elseif (fetch PROPS of TB) then (LISTPUT (fetch PROPS of TB) P V) else (replace PROPS of TB with (LIST P V]) (TBDEFPRINT [LAMBDA (TB) (* bas%: "22-NOV-78 14:32") (* DEFPRINTer for TYPEBLOCKs. Made a function to allow supression of constant  cons) (CBOX (CONCAT "{DECLTYPE: " (fetch NAME of TB) "}") (PACK]) (TETYPE [LAMBDA (TE) (* rmk%: "18-Feb-85 18:07") (* returns the type of a type  expression) (if (LITATOM TE) then 'PRIMITIVE elseif (LISTP TE) then (SELECTQ (CAR TE) ((ALLOF MEMQ ONEOF SHARED SUBTYPE SYNONYM TUPLE) (CAR TE)) (AND (LISTP (CDR TE)) (SELECTQ (CADR TE) (OF 'OF) (SELECTQ (CAR (LISTP (CADR TE))) ((SATISFIES WHOSE) (CAADR TE)) NIL]) (TYPEMSANAL [NLAMBDA (KIND) (* rmk%: " 9-NOV-83 09:24") (* Returns the information that the  various templates expect.) (DECLARE (USEDFREE EXPR FNNAME)) (SELECTQ KIND (COVERS (SCRATCHLIST (CBOX) (TYPEMSANAL1 EXPR))) ((type? the) [LBOX KIND (SCRATCHLIST (CBOX) (TYPEMSANAL1 (CADR EXPR))) (OR (GETHASH EXPR CLISPARRAY) (RESETVARS (FILEPKGFLG (NOSPELLFLG T) (DWIMESSGAG T)) (PROG (LISPXHIST) (DECLARE (SPECVARS LISPXHIST)) (DWIMIFY0? EXPR EXPR NIL NIL NIL FNNAME)) (RETURN (GETHASH EXPR CLISPARRAY]) (\*DECL (* We assume that the \*DECL came from a previous dwimification which also got  the testfn. The typeblock should already exist, but sometimes it isn't found  cause the clisparray gets cleared. The MAKEAPPLYFORM means that bogus VALUE's  are most likely eliminated) (LBOX [SCRATCHLIST (CBOX) (TYPEMSANAL1 (fetch DECL of (fetch VARDECL of EXPR] (APPLYFORM [fetch TESTFN of (GETDECLTYPE (fetch DECL of (fetch VARDECL of EXPR] (fetch VARNAME of EXPR)))) (SHOULDNT]) (TYPEMSANAL1 [LAMBDA (TYPEXP) (* bas%: "16-AUG-79 11:55") (* Collects from a type expression the names of all the named types that it  uses) (if (LITATOM TYPEXP) then (ADDTOSCRATCHLIST TYPEXP) elseif (LISTP TYPEXP) then [SELECTQ (CAR TYPEXP) ((ALLOF ONEOF SHARED SUBTYPE TUPLE) (for X in (CDR TYPEXP) do (TYPEMSANAL1 X))) (MEMQ NIL) (PROGN (* Infix operator so CAR is a type) (TYPEMSANAL1 (CAR TYPEXP)) (* CDR TYPEXP must also be a listp) (if (EQ (CADR TYPEXP) 'OF) then [TYPEMSANAL1 (CAR (LISTP (CDDR TYPEXP] else (SELECTQ (CAR (LISTP (CADR TYPEXP))) (SATISFIES NIL) (WHOSE (for I in (CDADR TYPEXP) do (TYPEMSANAL1 (CADR I)))) (SHOULDNT] else (SHOULDNT]) (UNCOMPLETE [LAMBDA (TB) (* bas%: " 7-NOV-79 16:08") (* Reinitializes the TYPEBLOCK for  NAME, recursing if necessary) (replace BINDFN of TB with (CREATEFNPROP (fetch PROPS of TB) 'BINDFN)) (replace SETFN of TB with (CREATEFNPROP (fetch PROPS of TB) 'SETFN)) (replace TESTFN of TB with (CREATEFNPROP (fetch PROPS of TB) 'TESTFN)) (if (fetch CTYPE of (fetch DEF of TB)) then (replace CTYPE of (fetch DEF of TB) with NIL) (MAPTYPEUSERS (fetch NAME of TB) (FUNCTION UNCOMPLETE]) (UNSAVETYPE [LAMBDA (TYPE) (* rmk%: " 7-SEP-81 03:44") (DECLARE (SPECVARS TYPE)) [MAPHASH CLISPARRAY (FUNCTION (LAMBDA (TRAN ORIG) (if (FORMUSESTB ORIG TRAN TYPE) then (PUTHASH ORIG NIL CLISPARRAY] (* Clear translations that depend on  this type) (AND MSDATABASELST (MSNEEDUNSAVE (GETRELATION (fetch NAME of TYPE) '(USE TYPE) T) "type declarations" T]) (USERDECLTYPE [LAMBDA (NAME DECL PROPS) (* rmk%: " 2-AUG-81 08:42") (* User entry to MAKEDECLTYPE) (if (LITATOM NAME) then (WITH ((TB (GETHASH NAME DECLTYPESARRAY))) (* We use GETHASH to avoid creating  record based types) (if [OR (EQ DECL NAME) (AND TB (EQUAL DECL (fetch TYPEXP of TB] then (AND (REPROPTB (GETDECLTYPE NAME) PROPS) (MARKASCHANGED NAME 'DECLTYPES)) (* Adding properties to existing type) else (SELECTQ NAME ((ANY NONE) (DECLERROR "(Futile) attempt to redefine" NAME)) NIL) [MARKASCHANGED NAME 'DECLTYPES (COND (TB 'CHANGED) (T 'DEFINED] (if TB then (DELETETB TB)) (* Forget it if it exists then remake  it) (MAKEDECLTYPE NAME (OR (LISTP DECL) (LIST 'SYNONYM DECL)) PROPS))) NAME else (DECLERROR "Non-atomic DECLTYPE name" NAME]) (USESTYPE [LAMBDA (NAME TE) (* rmk%: "18-Feb-85 18:14") (* Computes whether NAME appears in TE) (OR (EQ NAME TE) (SELECTQ (TETYPE TE) ((ALLOF ONEOF SHARED SUBTYPE SYNONYM) (for I in (CDR TE) thereis (USESTYPE NAME I))) (MEMQ (for I in (CDR TE) thereis (EQ I (DTYPENAME I)))) (OF [OR (USESTYPE NAME (CAR TE)) (AND [LISTP (CDR (LISTP (CDR TE] (USESTYPE NAME (CADDR TE]) (PRIMITIVE NIL) (SATISFIES (USESTYPE (CAR TE))) (TUPLE [OR (EQ NAME (if (CDR TE) then 'LISTP else NIL)) (USESTYPE NAME (CONS 'ALLOF (CDR TE]) (WHOSE [OR (USESTYPE NAME (CAR TE)) (for I in (CADR TE) when (LISTP (CDR (LISTP I))) thereis (USESTYPE NAME (CADR I]) (SHOULDNT]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: LCCTYPE LCCTYPE LCC2) (BLOCK%: TYPEMSANAL TYPEMSANAL TYPEMSANAL1) ) (* Test fn creation block) (DEFINEQ (MAKETESTFN [LAMBDA (TB) (* rmk%: "29-NOV-81 22:41") (* Computes the test fn for a type block.  Called from TESTFN fetch function. This is not a part of the MAKETESTFNBLOCK,  so that the name MAKETESTFN is a reliable indicator for checking recursion  (DECLRECURSING)) (MAKETESTFNBLOCK TB]) (MAKETESTFNBLOCK [LAMBDA (TB) (* rmk%: " 6-FEB-82 14:25") (* Computes the test fn for a type  block) (WITH [(TE (fetch TYPEXP of TB)) (BINDINGNAME (OR (AND (LITATOM (fetch PROPS of TB)) (fetch PROPS of TB)) 'VALUE] (DECLARE (SPECVARS BINDINGNAME)) (COND [(DECLRECURSING 'MAKETESTFNBLOCK TB) (* Name will be returned) (replace TESTFN of TB with (PACK* (fetch NAME of TB) '.TestFn] (T (WITH [(DEF (SELECTQ (TETYPE TE) (ALLOF (COMBINE.TESTS (SMASHCAR (COLLECTTYPES (CDR TE) 'DOWN) (FUNCTION TESTFORM)) 'AND)) (MEMQ [LAMBIND (COND [(COVERSTB (GETDECLTYPE '(ONEOF LITATOM SMALLP)) TB) (COND ((CDDR TE) (LIST 'SELECTQ BINDINGNAME (LIST (CDR TE) T) NIL)) (T (LIST 'EQ BINDINGNAME (KWOTE (CADR TE] (T (COND [(CDDR TE) (LIST 'MEMBER BINDINGNAME (KWOTE (CDR TE] (T (LIST 'EQUAL BINDINGNAME (KWOTE (CADR TE]) (OF [OF.TESTFN (GETDECLTYPE (CAR TE)) (GETDECLTYPE (COND ((CDDDR TE) (CDDR TE)) (T (CADDR TE]) (ONEOF (COMBINE.TESTS (SMASHCAR (COLLECTTYPES (CDR TE) 'UP) (FUNCTION TESTFORM)) 'OR)) (SATISFIES (COMBINE.TESTS [LIST (TESTFORM (GETDECLTYPE (CAR TE))) (COND ((CDDR (CADR TE)) (* There might be multiple forms or  disconnected CLISP) (CONS 'AND (CDADR TE))) (T (CADR (CADR TE] 'AND)) ((SHARED SUBTYPE SYNONYM) (fetch TESTFN of (GETDECLTYPE (CADR TE)))) (TUPLE (TUPLE.TESTFN (CDR TE))) (WHOSE (WHOSE.TESTFN TB (CAR TE) (CDADR TE))) (SHOULDNT] (WITH ((TF (fetch TF of TB))) (replace TESTFN of TB with (COND [TF (* Must be recursive with TF being the atom name.TestFn and DEF being a lambda  expression. Convert to a LABEL expression, then translate it using DOLABEL from  LABEL package.) (DOLABEL (CONS 'LABEL (CONS TF (CDR DEF] (T DEF]) (COMBINE.TESTS [LAMBDA (TESTS ANDOR) (* bas%: "28-AUG-79 13:29") (* Composes TESTS under either AND or  OR composition) (FUNIFY [for TST in TESTS join (COND ((EQ (CAR (LISTP TST)) ANDOR) (APPEND (CDR TST))) ((EQ TST (EQ ANDOR 'AND)) (* AND T or OR NIL) NIL) ((EQ TST (EQ ANDOR 'OR)) (* AND NIL or OR T) (RETURN (LIST TST))) (T (LIST TST] ANDOR]) (FUNIFY [LAMBDA (TEST ANDOR) (* bas%: "11-OCT-79 18:05") (* Provides LAMBDA abstraction for  COMBINE.TESTS) (LAMBIND (COND ((NLISTP TEST) (* No tests) (EQ ANDOR 'AND)) ((CDR TEST) (* More than one clause) (CONS ANDOR TEST)) (T (CAR TEST]) (MKNTHCAR [LAMBDA (L N) (* bas%: " 8-MAR-79 17:55") (* Constructs an expression for getting the Nth car of L) (PROG [(F (MKNTHCDR L (SUB1 N] (RETURN (SELECTQ (CAR F) (CDR (CONS 'CADR (CDR F))) (CDDR (CONS 'CADDR (CDR F))) (CDDDR (CONS 'CADDDR (CDR F))) (LIST 'CAR F]) (MKNTHCDR [LAMBDA (L N) (* bas%: " 9-MAR-79 14:50") (* Constructs an expresssion for getting the Nth cdr of L) (if (ZEROP N) then L elseif (ILESSP N 5) then (LIST (SELECTQ N (1 'CDR) (2 'CDDR) (3 'CDDDR) (4 'CDDDDR) (SHOULDNT)) L) elseif (ILESSP N 9) then (MKNTHCDR (LIST 'CDDDDR L) (IDIFFERENCE N 4)) else (LIST 'FNTH L (ADD1 N]) (OF.TESTFN [LAMBDA (AGG ELT) (* rmk%: "19-AUG-81 00:08") (COMBINE.TESTS [LIST (TESTFORM AGG) (LIST (OR (GETTBPROP AGG 'EVERYFN) (DECLERROR "OF construction used with non-aggregate type")) BINDINGNAME (LIST 'FUNCTION (fetch TESTFN of ELT] 'AND]) (TUPLE.TESTFN [LAMBDA (TYPES) (* rmk%: "19-AUG-81 00:16") (* Constructs the test function for  TUPLEs) (COND (TYPES (COMBINE.TESTS [CONS (LIST 'EQLENGTH BINDINGNAME (LENGTH TYPES)) (for I in TYPES as J from 1 collect (APPLYFORM (fetch TESTFN of (GETDECLTYPE I)) (MKNTHCAR BINDINGNAME J] 'AND)) (T 'NULL]) (WHOSE.TESTFN [LAMBDA (TB SNAM TAIL) (* bas%: " 6-NOV-79 16:56") (* Constructs TESTFN for WHOSE  expressions) (COMBINE.TESTS [CONS (TESTFORM (GETDECLTYPE SNAM)) (for I in TAIL collect (APPLYFORM [fetch TESTFN of (GETDECLTYPE (COND ((EQLENGTH I 2) (CADR I)) (T (CDR I] (COND [(EQ SNAM 'LISTP) (WITH ((V (CAR I))) (SELECTQ V ((CAR CDR CADR CDDR CAAR CDAR) (LIST V BINDINGNAME)) (COND ((AND (FIXP V) (NOT (MINUSP V))) (MKNTHCAR BINDINGNAME V] ((FMEMB (CAR I) (RECORDFIELDNAMES SNAM)) (LIST 'FETCH (LIST SNAM (CAR I)) 'OF BINDINGNAME)) (T (DECLERROR (CAR I) " is not a valid fieldname"] 'AND]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MAKETESTFNBLOCK MAKETESTFNBLOCK COMBINE.TESTS FUNIFY MKNTHCAR MKNTHCDR OF.TESTFN TUPLE.TESTFN WHOSE.TESTFN) ) (* Machinery to compile recursive testfns) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LABEL) (* Idioms. Expressed as macros for now) (DECLARE%: DONTCOPY EVAL@COMPILE (RPAQQ DefaultBindFn PROGN) (RPAQQ DefaultSetFn REALSETQ) (ADDTOVAR NLAMA MAKEDECLTYPEQ) (DECLARE%: EVAL@COMPILE [PUTPROPS ANYC MACRO ((C) (EQ C 'ANY] [PUTPROPS DECLVARERROR MACRO (ARGS (LSUBST ARGS 'ARGS '(DECLDWIMERROR ARGS T " inside " VARD] [PUTPROPS DTYPENAME MACRO ((X) (COND ((LARGEP X) 'LARGEP) (T (TYPENAME X] [PUTPROPS foreachTB MACRO (ARGS (LIST 'MAPHASH 'DECLTYPESARRAY (LIST 'FUNCTION (CONS 'LAMBDA (CONS (LIST (CAR ARGS)) (CDR ARGS] [PUTPROPS GETCGETD MACRO ((X) (GETCTYPE (GETDECLTYPE X] [PUTPROPS KWOTEBOX MACRO ((V) ([LAMBDA ($$8) (DECLARE (LOCALVARS $$8)) (FRPLACA (CDR $$8) V) $$8] ''Q] (PUTPROPS LAMBIND MACRO (ARGS (APPEND '(LIST 'LAMBDA (LIST BINDINGNAME)) ARGS))) (PUTPROPS LAMVAL MACRO (ARGS (APPEND '(LIST 'LAMBDA '(VALUE)) ARGS))) [PUTPROPS MAKEDECLTYPEQ MACRO ((NAME DEF PROPS) (MAKEDECLTYPE 'NAME 'DEF 'PROPS] [PUTPROPS NONEC MACRO ((C) (EQ C 'NONE] (PUTPROPS TESTFORM MACRO ((TB) (APPLYFORM (fetch TESTFN of TB) BINDINGNAME))) ) (DEFINEQ (TESTFORM [LAMBDA (TB) (* rmk%: "24-NOV-81 22:17") (* Doesn't get compiled, cause it is macroed out.  Symbolic definition exists because it get's APPLY*, not EVALed) (APPLYFORM (fetch TESTFN of TB) BINDINGNAME]) ) (ADDTOVAR DONTCOMPILEFNS TESTFORM) (SETTEMPLATE 'foreachTB '(CALL BIND |..| EFFECT)) (SETTEMPLATE 'MAKEDECLTYPEQ '(CALL NIL NIL NIL . PPE)) ) (* Runtime utility functions) (DEFINEQ (EVERYCHAR [LAMBDA (STRNG FN) (* bas%: " 6-MAR-79 17:58") (* The EVERY function for strings) (for I to (NCHARS STRNG) always (APPLY* FN (NTHCHAR STRNG I]) (LARGEP [LAMBDA (X) (* rmk%: "24-MAY-79 09:10") (* For LARGEP type-tests) (AND (FIXP X) (NOT (SMALLP X]) (DECLRECURSING [LAMBDA (NAME ARG) (* jtm%: "19-Feb-87 11:31") (* NAME is the name of a potentially looping function in our call chain.  ARG is the first arg in that lowest call to NAME.  Determines whether the function NAME exists higher on the stack with ARG as its  first argument. Used to check for recursive loops.) (bind (S _ (STKPOS NAME -1)) while (STKPOS NAME -2 S S) when (EQ ARG (STKARG 1 S)) do (* At each step we back off one from the last frame we checked b/c it would  otherwise be found by STKPOS, and search for the next one.  S is reused by both stack fns and released if the loop terminates with it  pointing to anything.) (RELSTK S) (RETURN T]) (SMASHCAR [LAMBDA (L FN) (* bas%: "31-OCT-79 17:11") (* Maps over L smashing the result of applying FN to each car into that car) [MAP L (FUNCTION (LAMBDA (X) (FRPLACA X (APPLY* FN (CAR X] L]) ) (DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE [PUTPROPS LARGEP MACRO ((X) (AND (FIXP X) (NOT (SMALLP X] ) ) (DECLARE%: DONTCOPY EVAL@COMPILE (DECLARE%: EVAL@COMPILE [PUTPROPS SMASHCAR MACRO (ARGS (SUBST [SELECTQ (CAADR ARGS) [(FUNCTION QUOTE) (APPLYFORM (CADADR ARGS) '(CAR I] (LIST 'APPLY* (CADR ARGS) '(CAR I] 'NEWVAL (LIST '[LAMBDA (L) (DECLARE (LOCALVARS L)) [MAP L (FUNCTION (LAMBDA (I) (DECLARE (LOCALVARS I)) (FRPLACA I NEWVAL] L] (CAR ARGS] ) ) (* translator of dprogs and dlambdas) (DEFINEQ (ASSERT [NLAMBDA ARGS (* rmk%: "11-NOV-83 08:00") (* ARGS is a mixed list of variable names and forms.  Forms must be true, and the test function for variables must be true too.) (DECLARE (LOCALVARS . T)) (for V in ARGS do (if (LITATOM V) then (\VARASRT V) elseif (LISTP V) then (OR (EVAL V 'INTERNAL) (ASSERTFAULT V NIL)) else (ERRORX (LIST 27 V]) (ASSERTFAULT [LAMBDA (DECL VARNAME) (* ; "Edited 23-Feb-87 08:35 by jtm:") (* Prints out the assertion error  messages.) (LET [(FN (STKNAME (REALSTKNTH -1 'ASSERTFAULT] [COND ((LISTP FN) (SETQ FN (STKNAME (REALSTKNTH -4 'ASSERTFAULT] (LISPXPRIN1 (if VARNAME then "DECLARATION" else "ASSERTION") T) (LISPXPRIN1 " NOT SATISFIED IN " T) (LISPXPRIN2 FN T) (LISPXPRIN1 (CONCAT ": " (if VARNAME then (LIST VARNAME DECL) else DECL)) T) (APPLY* (FUNCTION BREAK1) NIL T FN]) (ASSERTMAC [LAMBDA (ARGS) (* rmk%: " 2-AUG-79 23:21") (* Compiler for ASSERT forms.) (if (IGNOREDECL) then (CBOX COMMENTFLG (LBOX (CBOX 'ASSERT ARGS))) else (for V in ARGS collect (if (LISTP V) then (LIST 'OR V (LIST 'ASSERTFAULT (KWOTE V))) elseif (LITATOM V) then (MAKETESTFORM V (TYPEBLOCKOF V)) else (ERRORX (LIST 27 V))) finally (RETURN (if (CDR $$VAL) then (CONS 'PROGN $$VAL) else (CAR $$VAL]) (\*DECL [NLAMBDA ARGS (* DECLARATIONS%: (RECORD ARGRECORD  (SL . FORMS))) (* rmk%: "11-NOV-83 07:59") (* This maintains the proper bindings of SATISFIESLIST.  It is wrapped around function bodies by dprog's and dlambda's.  Compiles open, depending on COMPILEIGNOREDECL.) (PROG [(SATISFIESLIST (if [OR (NULL (fetch SL of ARGS)) (LISTP (CAAR (fetch SL of ARGS] then (* If NIL, then this is the top binding for a declarative without any bindings.  If LISTP, then this is the first binding in this lexical scope.) (fetch SL of ARGS) else (CONS (fetch SL of ARGS) SATISFIESLIST] (DECLARE (SPECVARS SATISFIESLIST)) (* Use \DECLPROGN instead of PROGN so BAKTRACELST can recognize us) (RETURN (APPLY (FUNCTION \DECLPROGN) (fetch FORMS of ARGS) 'INTERNAL]) (*DECLMAC [LAMBDA (ARGS) (* DECLARATIONS%: (RECORD ARGRECORD  (SL . FORMS))) (* rmk%: "15-Sep-87 10:16") (DECLARE (USEDFREE CSATISFIESLIST FREEVARS)) (PROG [FIRSTSL (FV FREEVARS) (SL (fetch SL of ARGS)) (FORM (if (CDR (fetch FORMS of ARGS)) then (CONS 'PROGN (fetch FORMS of ARGS)) else (CAR (fetch FORMS of ARGS] [SETQ FIRSTSL (OR (NULL SL) (LISTP (CAAR SL] (* The first declaration in this  function) (* Should maintain list of free variables for the benefit of clisp words  arising in macros, but FREEVARS in compiling context has different meaning from  FREEVARS in dwimify context. Interlisp-D byte compiler gets confused.) (for V in (if FIRSTSL then (CAR SL) else SL) when (EQ (fetch PROGNFLAG of (fetch VARDECL of V)) 'FREE) do (push FV (fetch VARNAME of V))) [SETQ SL (LIST 'CSATISFIESLIST (KWOTE (if FIRSTSL then SL else (CONS SL CSATISFIESLIST] (* Assumes that *DECLMAC is executed in the same compiletime context as CBIND.  If this is the first declaration, we bind COMPILEIGNOREDECL for the benefit of  compiler-generated sub-functions) (RETURN (LIST '.CBIND. [CONS SL (NCONC [PROG1 NIL (* (if (NEQ FV FREEVARS) then  (LIST (LIST (QUOTE FREEVARS)  (KWOTE FV)))))] (if FIRSTSL then (LIST (LIST 'COMPILEIGNOREDECL (IGNOREDECL] FORM]) (\CHKINIT [NLAMBDA ARGS (* bas%: " 9-OCT-79 23:15") (* ARGS is a list of variable names whose nearest assertions are to be checked.  Calls to \CHKINIT are generated by DLAMTRAN just for variables that have inital  values and test-forms in the nearest SATISFIESLIST entry.) (DECLARE (LOCALVARS . T)) (for V D in ARGS unless (APPLY* (fetch TESTFN of (GETDECLTYPE [SETQ D (fetch DECL of (fetch VARDECL of (ASSOC V (CAR SATISFIESLIST ] V)) (EVALV V)) do (ASSERTFAULT D V]) (CHKINITMAC [LAMBDA (ARGS) (* rmk%: " 9-NOV-83 09:20") (* Compiler for \CHKINIT forms.) (DECLARE (USEDFREE COMMENTFLG CSATISFIESLIST)) (if (IGNOREDECL) then (CBOX COMMENTFLG (CBOX '\CHKINIT ARGS)) else (* The \CHKINIT only includes variables whose testform is not T) (for V D TEMP in ARGS collect (LIST 'OR (APPLYFORM (fetch TESTFN of (GETDECLTYPE [SETQ D (fetch DECL of (fetch VARDECL of (ASSOC V (CAR CSATISFIESLIST ] V)) V) (LIST 'ASSERTFAULT (if (LISTP D) then (CONS 'DECLMSGMAC D) else (KWOTE D)) (KWOTE V))) finally (RETURN (if (CDR $$VAL) then (CONS 'PROGN $$VAL) else (CAR $$VAL]) (DECLCONSTANTP [LAMBDA (X) (* bas%: " 9-OCT-79 21:32") (OR (NULL X) (EQ X T) (NUMBERP X) (STRINGP X) (AND (LISTP X) (SELECTQ (CAR X) ('CONSTANT T) (WITH ((TEMP (if (GETP (CAR X) 'MACRO) then (EXPANDMACRO X T) else X))) (* If we did a DECLOF and got a MEMQ, we'd have a constant.  Thus, this code wouldn't have to duplicate what goes on in DECLOF, and we would  get the funny PROG and SELECTQ cases for free.) (if (AND (NEQ TEMP X) (NEQ TEMP 'IGNOREMACRO)) then (DECLCONSTANTP TEMP) elseif (SELECTQ (CAR X) ((SELECTQ CLOSER GO PROG COND) (* CLOSER has side-effects. The others have CTYPE properties but their  arguments can't be simply checked) NIL) (GETP (CAR X) 'CTYPE)) then (* The test we really want is that the function doesn't reference freevariables  or cause side-effects.) (EVERY (CDR X) (FUNCTION DECLCONSTANTP]) (DD [NLAMBDA X (* DECLARATIONS%: (RECORD ARGRECORD  (NAME . DEF) (RECORD DEF  (ARGS . BODY)))) (* rmk%: "24-JUL-78 08:13") (* For Defining DLambda functions. NAME is the function name and DEF the rest  of its definition.) (DEFINE [LIST (LIST (fetch NAME of X) (CONS 'DLAMBDA (fetch DEF of X] T]) (DECLCLISPTRAN [LAMBDA (X TRAN) (* rmk%: " 2-Nov-84 15:30") [PROG [DECL DFORM DPROGFLAG RETURNS (DECLARETAGS '(LOCALVARS SPECVARS ADDTOVAR DEFLIST PUTPROPS CONSTANTS SETQQ USEDFREE TYPE] (if [AND (LISTP TRAN) [EQ 'FORWORD (CAR (GETPROP (CAR (LISTP X)) 'CLISPWORD] [if (EQ 'PROG (CAR TRAN)) then (SETQ DPROGFLAG T) (SETQ DFORM TRAN) elseif (AND [EQ 'FUNCTION (CAR (SETQ DFORM (CAR (LISTP (CDR (LISTP (CDR TRAN] (EQ 'LAMBDA (CAR (SETQ DFORM (CAR (LISTP (CDR DFORM] (OR (NULL NEWSATLIST) (for D in (CDR (ASSOC 'DECLARE DFORM)) thereis (AND (LISTP D) (NOT (FMEMB (CAR D) DECLARETAGS] then (FRPLACA DFORM (if DPROGFLAG then 'DPROG else 'DLAMBDA)) [for F (PROGVARS _ (AND DPROGFLAG (CADR DFORM))) in (CDDR DFORM) when (EQ (CAR F) 'DECLARE) do (for D V DCLARE in (CDR F) do (if (OR (NLISTP D) (FMEMB (CAR D) DECLARETAGS)) then (push DCLARE D) elseif DPROGFLAG then (* Distribute declarations of local variables in the DPROG bindings.  This means that initial values will be taken into account) (for L on PROGVARS do (if (EQ (CAR D) (CAR L)) then [FRPLACA L (CONS (CAR L) (CONS NIL (CDR D] (RETURN) elseif (AND (LISTP (CAR L)) (EQ (CAR D) (CAAR L))) then [if (NLISTP (CDAR L)) then (FRPLACD (CAR L) (LIST (CDAR L] (* In case it's a list with no CADR) (NCONC (CAR L) (CDR D)) (RETURN)) finally (push DECL D)) elseif (EQ (CAR D) 'RETURNS) then (push RETURNS D) else (push DECL D)) finally (FRPLACD F (DREVERSE DCLARE] [if DECL then (push (CDDR DFORM) (CONS 'DECL (DREVERSE DECL] (RESETVARS (CLISPRETRANFLG) (* Resetting this flag avoids  redundancies in a !DW) (if RETURNS then (SETQ TRAN (LIST 'DPROGN (DREVERSE RETURNS) TRAN)) (DWIMIFY0? TRAN TRAN NIL NIL NIL FAULTFN) (* Only happens for a MAPC/AR etc that has a RETURNS) (SETQ TRAN (PROG1 (CAR (CDDDDR (GETHASH TRAN CLISPARRAY))) (PUTHASH TRAN NIL CLISPARRAY))) (* Skip down to the CHECKVALUE) else (DWIMIFY0? DFORM DFORM NIL NIL NIL FAULTFN))) (if (PROG1 (SETQ DECL (GETHASH DFORM CLISPARRAY)) (PUTHASH DFORM NIL CLISPARRAY)) then (* Don't clobber DFORM with an empty translation, which probably comes from a  lower-level error) (FRPLNODE2 DFORM DECL) else (SETQ TRAN NIL] (REALCLISPTRAN X TRAN]) (DECLMSG [NLAMBDA DECLMSG (* rmk%: "16-AUG-81 23:17") (* Purely for saving storage. For list declarations, the DECL argument of  ASSERTFAULT and VALUEERROR is compiled as a call to DECLMSGMAC which has a  macro that calls DECLMSG as a compiletime or loadtime constant.  We attempt to find an already existing copy of that list-structure, and if we  do, we return a pointer to that instead) (DECLARE (SPECVARS DECLMSG) (GLOBALVARS DECLTYPESARRAY DECLMESSAGES)) (if (GETHASH DECLMSG DECLTYPESARRAY) then (* This never works when we're loading from a file, but always works when we  are storing the compiled code directly into core.) DECLMSG else [foreachTB TB (if (EQUAL DECLMSG (fetch NAME of TB)) then (RETFROM 'DECLMSG (fetch NAME of TB] (* Fall through if didn't locate it. Look it up on our special message database  list.) (CAR (OR (MEMBER DECLMSG DECLMESSAGES) (push DECLMESSAGES DECLMSG]) (DECLDWIMERROR [LAMBDA ARGS (* bas%: "10-OCT-79 18:24") (DECLARE (USEDFREE FAULTFN)) (LISPXTERPRI T) (LISPXPRIN1 "{in " T) (LISPXPRIN1 FAULTFN T) (LISPXPRIN1 "} " T) (for I to ARGS do (if (EQ T (ARG ARGS I)) then (LISPXTERPRI T) else (LISPXPRIN1 (ARG ARGS I) T))) (LISPXTERPRI T) (ERROR!]) (DECLDWIMTESTFN [LAMBDA (TB) (* rmk%: " 6-FEB-82 14:26") (* Returns the dwimified TESTFN of TB) (DECLARE (USEDFREE FAULTFN)) (PROG ((FN (fetch TESTFN of TB))) (if [AND (LISTP FN) (OR CLISPRETRANFLG (NOT (GETHASH FN CLISPARRAY] then (DWIMIFY0? FN FN NIL NIL NIL FAULTFN) (* We hash the FN to itself to avoid repetitive dwimification unless  CLISPRETRANFLG is on. But we're careful to avoid circularity if FN begins with  a CLISPWORD.) (OR (GETHASH FN CLISPARRAY) (PUTHASH FN FN CLISPARRAY))) (RETURN FN]) (DECLSET [LAMBDA (VAR VAL) (* rmk%: "11-NOV-83 08:00") (* Version of SET that does ASSERT checks.  This is moved to SET when DECLTRAN is loaded.  The old definition of SET is available through the name REALSET.  Uses VARSETFN to find the run-time type-dependent SETFN, which will be that for  the lowest declaration on the satisfieslist for a DPROGN) (DECLARE (LOCALVARS . T)) (PROG1 (APPLY (VARSETFN VAR) (LBOX VAR (KWOTEBOX VAL))) (\VARASRT VAR]) (DECLSETQ [NLAMBDA U (* rmk%: "11-NOV-83 08:00") (* Version of SETQ that does ASSERT checks.  The old definition of SETQ is available through the name REALSETQ.  The contortions are so DWIM gets to see the value forms in the environment of  the running function.) (DECLARE (LOCALVARS . T)) (WITH [(V (APPLY (FUNCTION PROG1) (CDR U) 'INTERNAL] (* Bind the value so no recursion thru  the LBOX) (PROG1 (APPLY (VARSETFN (CAR U)) (LBOX (CAR U) (KWOTEBOX V)) 'INTERNAL) (\VARASRT (CAR U]) (DECLSETQQ [NLAMBDA (XSET YSET) (* bas%: " 1-NOV-79 17:54") (APPLY* (FUNCTION DECLSETQ) XSET (KWOTEBOX YSET]) (DECLTRAN [LAMBDA (FORM) (* DECLARATIONS%: FAST  (RECORD FORM (ATOM DCLS . FORMS))) (* rmk%: " 2-Nov-84 15:24") (* Translator for declarative  statements) (DECLARE (USEDFREE VARS CLISPCHANGE)) (* Used for DPROGN variable names) (SETQ CLISPCHANGE T) (PROG (TEMP CLISP%: DECLARE TOP BS PROGDCLS SPECVARS SAT INITVARS VARBINDFORMS RETURNS LOCALVARS (ATOM (fetch ATOM of FORM)) (FORMS (fetch FORMS of FORM)) (VARS VARS)) (DECLARE (SPECVARS VARS DECLARE PROGDCLS SPECVARS SAT INITVARS RETURNS LOCALVARS VARBINDFORMS)) (if (LISTP (SETQ TEMP (fetch DCLS of FORM))) then [for V in old TEMP do (if (AND (EQ ATOM 'DPROG) (EQ V 'THEN)) then [SETQ FORMS (LIST (LIST 'RETURN (CONS 'DPROG (CONS (CDR TEMP) FORMS] (RETURN)) (DECLVAR V (EQ ATOM 'DPROG) (NEQ ATOM 'DPROGN] (SETQ PROGDCLS (DREVERSE PROGDCLS)) else (if (AND TEMP (LITATOM TEMP) (EQ ATOM 'DLAMBDA)) then (DECLVAR (LIST TEMP 'CARDINAL) NIL T) (* Handles no-spread case;  not necessary to do \CHKINIT) (SETQ INITVARS NIL)) (SETQ PROGDCLS TEMP)) (if [AND (EQ ATOM 'DLAMBDA) (OR (EQ [CAR (SETQ TEMP (LISTP (CAR FORMS] 'CLISP%:) (AND (EQ (CAR TEMP) COMMENTFLG) (EQ (CADR TEMP) 'DECLARATIONS%:] then (SETQ CLISP%: TEMP) (SETQ FORMS (CDR FORMS))) [if (NEQ ATOM 'DPROGN) then (for F DECL in old FORMS do (if (NLISTP F) then (GO $$OUT) elseif (EQ (CAR F) COMMENTFLG) elseif (EQ (CAR F) 'DECLARE) then (* APPEND combines multiple declares) (SETQ DECLARE (APPEND DECLARE (CDR F))) elseif (EQ (CAR F) 'DECL) then (SETQ DECL (APPEND DECL (CDR F))) else (GO $$OUT)) finally [if (EQ ATOM 'DPROG) then (* This PROG represents the user's PROG, to which his RETURN and GO statements  are referred. The PROG introduced below is for the actual bindings, and allows  intervening checks for variables and RETURNS to be inserted.) (SETQ FORMS (LIST (CONS 'PROG (CONS NIL FORMS] (if DECL then (SETQ FORMS (LIST (CONS 'DPROGN (CONS DECL FORMS] (* The test-functions don't appear in the code, so they have to be dwimified  separately. This can't be done in MAKEDECLTYPE, because the variables in the  testfn aren't known until this whole binding set has been processed to add them  to VARS. -  We don't have to worry about set and bind functions, cause they are attached  only to named types and thus are dwimified when the type is defined.) [for V in SAT when (SETQ V (fetch VARDECL of V)) do (DECLDWIMTESTFN (OR (FINDDECLTYPE (fetch DECL of V)) (SHOULDNT] (if SPECVARS then (push DECLARE (CONS 'SPECVARS SPECVARS))) (if LOCALVARS then (push DECLARE (CONS 'LOCALVARS LOCALVARS))) [if RETURNS then (SETQ FORMS (LIST (CONS 'the (CONS RETURNS FORMS] (if DECLARE then (push DECLARE 'DECLARE)) (SETQ BS (CONS 'PROGN (NCONC [if INITVARS then (LIST (CONS '\CHKINIT (DREVERSE INITVARS] FORMS))) [if VARBINDFORMS then (FRPLACD BS (NCONC (DREVERSE VARBINDFORMS) (CDR BS] (* VARBINDFORMS is hook for  type-dependent initializations) (SELECTQ ATOM ((DLAMBDA) (* In parens to suppress PPDECL here) (SETQ FORMS (LIST BS)) (if DECLARE then (push FORMS DECLARE)) [push FORMS (CONS COMMENTFLG '(ASSERT%: (CLISP DLAMBDA] (if CLISP%: then (push FORMS CLISP%:)) (SETQ TOP (CONS 'LAMBDA (CONS PROGDCLS FORMS)))) ((DPROG) (SETQ TOP (LIST 'PROG PROGDCLS (LIST 'RETURN BS))) (if DECLARE then (push (CDDR TOP) DECLARE))) (SETQ TOP BS)) (* DPROGN falls through) (PROG (NEWSATLIST) (* Lower decl's are not new.) (DECLARE (SPECVARS NEWSATLIST)) (DWIMIFY0? TOP TOP NIL NIL NIL FAULTFN)) (if (OR SAT NEWSATLIST) then (FRPLACA BS '\*DECL) (* If no variables were declared, leave the PROGN that was to make sure that  the forms got dwimified correctly) (SETQ SAT (DREVERSE SAT)) (* So satlist is ordered like decls) (push (CDR BS) (if (AND NEWSATLIST SAT) then (LIST SAT) else SAT))) (* We can do the extra CONS statically when this is a newsatlist) (RETURN (if (EQ ATOM 'DLAMBDA) then TOP else (REALCLISPTRAN FORM TOP) FORM]) (DECLVAR [LAMBDA (VARD DPROGFLAG BINDFLAG) (* DECLARATIONS%: FAST) (* rmk%: " 2-Nov-84 15:33") (DECLARE (USEDFREE FAULTFN DECLARE RETURNS SAT INITVARS PROGDCLS LOCALVARS SPECVARS VARBINDFORMS VARS) (GLOBALVARS GLOBALVARS)) (PROG (TYPEBLOCK DECL TEMP TESTFORM NAME INITV TAIL SATFORM (PROGNFLAG (NOT BINDFLAG))) (if (LISTP VARD) then (SETQ NAME (CAR VARD)) (SELECTQ NAME ((RETURNS VALUE) (if RETURNS then (DECLVARERROR "Multiple RETURNS/VALUE declaration")) (SETQ DPROGFLAG (SETQ BINDFLAG NIL)) (SETQQ NAME VALUE)) NIL) (SETQ TAIL (CDR VARD)) (if DPROGFLAG then (RESETVARS ((NOSPELLFLG T) (DWIMESSGAG T)) (DWIMIFY0? TAIL VARD TAIL NIL NIL FAULTFN)) (* This will glue all the components of the initial value together.  It will also walk through the declarations, but no spelling corrections will be  done. Corrections in the SATISFIES will happen when the whole translation is  dwimified in DECLTRAN.) (SETQ INITV (pop TAIL))) else (SETQ NAME VARD)) (if (NOT (AND NAME (LITATOM NAME))) then (DECLVARERROR "Illegal variable name")) (for V in TAIL do (* RETRY is a label) RETRY (if (if BINDFLAG then [SELECTQ V (SPECIAL (if (FMEMB NAME LOCALVARS) then (DECLVARERROR "Variable can't be both LOCAL and SPECIAL: " NAME) else (push SPECVARS NAME))) (LOCAL (if (FMEMB NAME SPECVARS) then (DECLVARERROR "Variable can't be both LOCAL and SPECIAL: " NAME) else (push LOCALVARS NAME))) (if (EQ (CAR (LISTP V)) 'USEDIN) then (if (FMEMB NAME LOCALVARS) then (DECLVARERROR "Variable can't be both LOCAL and USEDIN: " NAME) else (push SPECVARS NAME] elseif (EQ V 'GLOBAL) then (pushnew GLOBALVARS NAME) elseif (OR (EQ V 'FREE) (EQ (CAR (LISTP V)) 'BOUNDIN)) then (SETQ PROGNFLAG 'FREE)) elseif (EQ (CAR (LISTP V)) 'SATISFIES) then (if SATFORM then (DECLVARERROR "Multiple SATISFIES")) (SETQ SATFORM V) elseif (EQ (CAR (LISTP V)) COMMENTFLG) elseif (SETQ TEMP (GETDECLTYPE.NOERROR V NAME)) then (if TYPEBLOCK then (DECLVARERROR "more than one type declaration: " V)) (SETQ TYPEBLOCK TEMP) (SETQ DECL V) elseif (AND (LISTP V) (FIXSPELL (CAR V) 80 '(SATISFIES BOUNDIN USEDIN) T V)) then (AND FAULTFN (NEQ FAULTFN 'TYPE-IN) (MARKASCHANGED FAULTFN 'FNS)) (GO RETRY) else (DECLVARERROR "invalid declaration: " V))) (if (NULL TYPEBLOCK) then (SETQQ DECL ANY)) (if SATFORM then (SETQ DECL (LIST DECL SATFORM)) (if (NULL (SETQ TYPEBLOCK (GETDECLTYPE.NOERROR DECL NAME))) then (DECLVARERROR "invalid declaration: " DECL))) (if (EQ NAME 'VALUE) then (SETQ RETURNS DECL) (* This gets reprocessed by THETRAN) (RETURN)) (if BINDFLAG then (for D in PROGDCLS when [OR (EQ NAME D) (EQ NAME (CAR (LISTP D] do (DECLVARERROR "more than one binding for " NAME))) (* TYPEBLOCK=NIL if default ANY with  no SATISFIES) [if TYPEBLOCK then (if (SETQ TEMP (GETTBPROP TYPEBLOCK 'DECLARESPEC)) then (push DECLARE (SUBST NAME 'VAR TEMP))) (if (EQ (SETQ TEMP (fetch BINDFN of TYPEBLOCK)) (CONSTANT DefaultBindFn)) elseif DPROGFLAG then [SETQ INITV (CONS TEMP (if INITV then (LIST INITV) else (* Indicate that the initialization is  not to be checked) (SETQ DPROGFLAG NIL] else (push VARBINDFORMS (LIST 'REALSETQ NAME (LIST TEMP NAME] (if (NEQ DECL 'ANY) then (* A missing VARDECL is interpreted as ANY, so don't bother to stick one in.) (push SAT (create SLISTENTRY VARNAME _ NAME VARDECL _ (create VARDECL DECL _ DECL PROGNFLAG _ PROGNFLAG))) (* PROGNFLAG means that inherited  declarations will be checked) (if (if INITV then DPROGFLAG elseif (NULL DPROGFLAG)) then (push INITVARS NAME)) elseif BINDFLAG then (* The empty VARDECL conceals type  information for higher declarations) (push SAT (create SLISTENTRY VARNAME _ NAME VARDECL _ NIL))) (if BINDFLAG then (push PROGDCLS (if INITV then (LIST NAME INITV) else NAME))) (push VARS NAME]) (DLAMARGLIST [LAMBDA (DEF) (* rmk%: " 6-APR-78 10:13") (if (LISTP (CADR DEF)) then (for A in (CADR DEF) unless (EQ (CAR (LISTP A)) 'RETURNS) collect (if (LISTP A) then (CAR A) else A)) else (CADR DEF]) (DTYPE?TRAN [LAMBDA (FORM) (* bas%: " 6-NOV-79 16:58") (SETQ CLISPCHANGE T) (if LCASEFLG then (/RPLACA FORM 'type?)) [PROG (TESTFORM (TYPEBLOCK (GETDECLTYPE.NOERROR (CADR FORM))) (FORMS (CDDR FORM))) (if (NULL TYPEBLOCK) then (DECLDWIMERROR "invalid type declaration: " (CADR FORM))) (DWIMIFY0? FORMS FORM NIL NIL NIL FAULTFN) (* The forms are dwimified first so that we can decide whether the testform  should be set-up for a bound VALUE.) (SETQ FORMS (if (CDR FORMS) then (CONS 'PROGN FORMS) else (CAR FORMS))) (SETQ TESTFORM (APPLYFORM (DECLDWIMTESTFN TYPEBLOCK) FORMS)) (REALCLISPTRAN FORM (if (NEQ TESTFORM T) then TESTFORM elseif (LISTP FORMS) then (LIST 'PROGN FORMS T) else (* Cause PPT prints a non-list  translation funny) '(PROGN T] FORM]) (EDITNEWSATLIST [LAMBDA NIL (* rmk%: " 7-SEP-81 03:31") (* Called from DW edit macro. True if there is no higher declarative on the  current edit chain.) (DECLARE (USEDFREE L)) (NOTANY (CDR L) (FUNCTION (LAMBDA (X) (AND (LISTP X) [OR (LITATOM (SETQ X (CAR X))) (LITATOM (SETQ X (CAR X] (OR (FMEMB X DECLATOMS) (EQ (CAR (GETPROP X 'CLISPWORD)) 'FORWORD]) (FORMUSESTB [LAMBDA (FORM TRANS TB) (* rmk%: " 9-NOV-83 09:24") (* Decides if FORM or its TRANSlation made use of the definition of the  typeblock TB (Currently, T for any decl expression regardless of typeblock)) (OR [AND (LISTP FORM) (FMEMB (CAR FORM) '(type? TYPE? the THE DLAMBDA DPROG DPROGN] (AND (LISTP TRAN) (OR (EQ (CAR TRAN) '\*DECL) (AND (EQ [CAR (LISTP (GETP (CAR (LISTP FORM)) 'CLISPWORD] 'FORWORD) (EQ [CAR (LISTP (SETQ TRAN (CAR (LAST TRAN] 'RETURN) (EQ [CAR (LISTP (CAR (LISTP (CDR TRAN] '\*DECL]) (IGNOREDECL [LAMBDA NIL (* rmk%: " 4-APR-79 00:04") (* Should be called only in macros; T if the function currently being compiled  should have debug information suppressed) (* FN is bound by COMPILE1 during ordinary compile, XXX during block compile.  The LISTP check inhibits the EVALV, and is necessary when called from  CHECKVALUEMAC inside masterscope.) (DECLARE (USEDFREE COMPILEIGNOREDECL)) (OR (EQ COMPILEIGNOREDECL T) (AND (LISTP COMPILEIGNOREDECL) (MEMB (EVALV 'FN 'COMPILE1) COMPILEIGNOREDECL) T]) (MAKETESTFORM [LAMBDA (VAR TYPE) (* rmk%: "16-AUG-81 23:12") (* Makes a form that tests VAR to be of type TYPE and reports errors if test  fails) (WITH ((TEST (APPLYFORM (fetch TESTFN of TYPE) VAR))) (if (EQ TEST T) then (CBOX COMMENTFLG (LBOX (LBOX 'ASSERT VAR))) else (LIST 'OR TEST (LIST 'ASSERTFAULT (WITH ((TN (fetch NAME of TYPE))) (if (LISTP TN) then (CONS 'DECLMSGMAC TN) else (KWOTE TN))) (KWOTE VAR]) (PPDECL [LAMBDA (FORM) (* rmk%: "28-JUN-82 12:44" posted%:  "17-MAY-77 22:06") (* Special prettyprinter for DLAMBDA's  and DPROG's. Called from  PRETTYPRINTMACROS) (DECLARE (GLOBALVARS %#RPARS CLISPARRAY PRETTYTRANFLG COMMENTFLG)) (COND ((OR (NLISTP (CDR FORM)) (AND PRETTYTRANFLG (GETHASH FORM CLISPARRAY))) FORM) (T (SELECTQ (CAR FORM) (DLAMBDA [PROG [(FORMPOS (IPLUS 2 (POSITION] (PRIN1 (COND (%#RPARS "[") (T "("))) (PRIN1 "DLAMBDA ") (PPVARLIST (CADR FORM)) (COND ((AND (LISTP (SETQ FORM (CDDR FORM))) (NEQ (CAR FORM) COMMENTFLG)) (printout NIL .TAB0 FORMPOS))) (PRINTDEF FORM FORMPOS T T FNSLST) (PRIN1 (COND (%#RPARS "]") (T ")"]) (DPROG (PROG [FORMPOS (LABELPOS (ADD1 (POSITION] (* For DPROG's. Highlights the THEN's in the argument list and formats initial  values) (SETQ FORMPOS (IPLUS LABELPOS 4)) (PRIN1 "(DPROG ") [COND ((LISTP (CADR FORM)) (PRIN1 "(") [for V VTAIL (LASTLIST _ T) (VARPOS _ (IPLUS LABELPOS 7)) in (CADR FORM) do (COND ((LISTP V) (printout NIL .TAB0 VARPOS "(" |.P2| (CAR V)) [COND ((SETQ VTAIL (CDR V)) (SPACES 1) (for X in old VTAIL do (PRINTDEF X (POSITION) T NIL FNSLST) repeatwhile (FMEMB (COND ((AND (LISTP X) (NLISTP (CADR VTAIL))) (NTHCHAR (CADR VTAIL) 1)) ((AND (NLISTP X) (LISTP (CADR VTAIL))) (NTHCHAR X -1))) CLISPCHARS) finally (SETQ VTAIL (CDR VTAIL))) (* Supress spaces in clisp initial  values) (for X in VTAIL do (SPACES 1) (PRINTDEF X (POSITION) T NIL FNSLST] (COND ((ILESSP (POSITION) VARPOS) (TAB VARPOS) (PRIN1 ")")) (T (PRIN3 ")"))) (SETQ LASTLIST T)) ((EQ V 'THEN) (printout NIL .TAB0 (IPLUS LABELPOS 2) 'THEN)) (T (COND (LASTLIST (TAB VARPOS 0)) (T (SPACES 1))) (SETQ LASTLIST NIL) (PRIN2 V] (PRIN3 ")")) (T (PRIN2 (CADR FORM] [for F in (CDDR FORM) do (COND ((LITATOM F) (printout NIL .TAB LABELPOS |.P2| F)) (T (COND ((NEQ (CAR (LISTP F)) COMMENTFLG) (printout NIL .TAB0 FORMPOS))) (PRINTDEF F (POSITION) T NIL FNSLST] (PRIN1 ")"))) (DECL (PRIN1 "(DECL ") (PPVARLIST (CDR FORM) T) (PRIN3 ")")) (DPROGN (PROG [(FORMPOS (IPLUS 3 (POSITION] (PRIN1 "(DPROGN ") (PPVARLIST (CADR FORM)) (COND ((AND (LISTP (SETQ FORM (CDDR FORM))) (NEQ (CAR FORM) COMMENTFLG)) (printout NIL .TAB0 FORMPOS))) (PRINTDEF FORM FORMPOS T T FNSLST) (PRIN1 ")"))) NIL) NIL]) (PPVARLIST [LAMBDA (VLIST TAILFLG) (* rmk%: "12-JUN-78 16:07") (* Pretty-prints the variable declarations for DLAMBDA, DPROGN, DECL.  The list begins at the current line position;  unless TAILFLG, enclosing parens are printed) (if (LISTP VLIST) then (OR TAILFLG (PRIN1 "(")) (for V (VARPOS _ (POSITION)) (LASTLIST _ T) in VLIST do (if (LISTP V) then (printout NIL .TAB0 VARPOS "(" |.P2| (CAR V)) (for X in (CDR V) do (SPACES 1) (PRINTDEF X (POSITION) T NIL FNSLST)) (if (ILESSP (POSITION) VARPOS) then (TAB VARPOS) (PRIN1 ")") else (PRIN3 ")")) (SETQ LASTLIST T) else (if LASTLIST then (TAB VARPOS 0) else (SPACES 1)) (SETQ LASTLIST NIL) (PRIN2 V)) finally (if $$LST1 then (PRIN1 " . ") (PRIN2 $$LST1))) (OR TAILFLG (PRIN3 ")")) else (PRIN2 VLIST]) (SETQMAC [LAMBDA (ARGS) (* bas%: "18-OCT-79 18:22") (* Compiler macro for SETQ.  Enforces declarations.) (PROG [SETFORM (TB (TYPEBLOCKOF (CAR ARGS] (SETQ SETFORM (CONS (fetch SETFN of TB) ARGS)) (* We can suppress the run time test if either IGNOREDECLS, type is ANY, the  value is a constant which passes the test fn now, or TB covers the possible set  of values. Can't do constant evaluation if there's a setfn, cause a setfn  clearly must have side-effects, and it may be doing coercions.) (RETURN (if [OR (IGNOREDECL) (EQ (fetch TYPEXP of TB) 'ANY) [AND (EQ (fetch SETFN of TB) (CONSTANT DefaultSetFn)) (DECLCONSTANTP (CADR ARGS)) (PROG (TEMP HELPFLAG (TST (fetch TESTFN of TB))) (DECLARE (SPECVARS HELPFLAG)) (RETURN (AND (OR (SUBRP TST) (NOT (FREEVARS TST))) [NLSETQ (OR [SETQ TEMP (APPLY* TST (EVAL (CADR ARGS] (COMPEM " Warning: Probable type fault in" (CONS 'SETQ ARGS] TEMP] (COVERSTB TB (TYPEBLOCKOF (if (EQ (fetch SETFN of TB) (CONSTANT DefaultSetFn)) then SETFORM else (CADR ARGS] then (* The variable's type includes the  value's, so we're OK.) SETFORM else (* PROG1 is used rather than embedding the SETFORM in the test to give  MAKEAPPLYFORM a better chance of simplifying) (LIST 'PROG1 SETFORM (MAKETESTFORM (CAR ARGS) TB]) (THETRAN [LAMBDA (FORM) (* rmk%: " 9-NOV-83 09:17") (DECLARE (USEDFREE LCASEFLG CLISPCHANGE)) (SETQ CLISPCHANGE T) (if LCASEFLG then (/RPLACA FORM 'the)) [WITH [(TYPEBLOCK (GETDECLTYPE.NOERROR (CADR FORM] (if (NULL TYPEBLOCK) then (DECLDWIMERROR "invalid type declaration: " (CADR FORM))) (DWIMIFY0? (CDDR FORM) FORM (CDDR FORM) NIL NIL FAULTFN) (WITH [(TESTFORM (APPLYFORM (DECLDWIMTESTFN TYPEBLOCK) 'VALUE)) (VALFORM (if (CDDDR FORM) then (CONS 'PROGN (CDDR FORM)) else (CADDR FORM] (REALCLISPTRAN FORM (if (EQ TESTFORM T) then VALFORM else (LIST '\CHKVAL (APPLYFORM [LAMVAL (LIST 'COND (LIST TESTFORM 'VALUE) (LIST T (LIST 'VALUEERROR 'VALUE (if (LISTP (CADR FORM)) then (CONS 'DECLMSGMAC (CADR FORM)) else (KWOTE (CADR FORM] VALFORM] FORM]) (VALUEERROR [LAMBDA (VALUE DECL) (* rmk%: "16-AUG-81 15:48") (DECLARE (SPECVARS VALUE)) (LISPXPRIN1 " VALUE ASSERTION NOT SATISFIED IN " T) (bind POS when [LITATOM (STKNAME (SETQ POS (REALSTKNTH -1 (OR POS 'VALUEERROR) NIL POS] do (LISPXPRIN2 (STKNAME POS) T) (RELSTK POS) (RETURN)) (* VALUE is the break expression so that an OK will simply return it.  Also, typing the command VALUE in the break will cause VALUE to be printed out,  given the EVAL command that sets it up. There are some paradoxes though%: If  the user sets VALUE, he will not see the change in the break unless he does  another EVAL. Instead, he must work with !VALUE.) (APPLY* (FUNCTION BREAK1) 'VALUE T (LIST 'VALUE DECL) '(EVAL]) (\VARASRT [LAMBDA (VARNAME) (* rmk%: " 2-DEC-78 14:47") (* Checks all the declaration predicates for VARNAME in the run-time context.) (DECLARE (LOCALVARS . T) (USEDFREE SATISFIESLIST)) (VARASRT1 VARNAME SATISFIESLIST]) (VARASRT1 [LAMBDA (VARNAME SLIST) (* bas%: " 9-OCT-79 23:24") (* Checks all run-time assertions for VARNAME.  Evaluates the highest predicate in the current scope first for DPROGN  variables.) (DECLARE (LOCALVARS . T)) (for S D in old SLIST when (SETQ D (ASSOC VARNAME S)) do (if (NULL (SETQ D (fetch VARDECL of D))) then (RETURN)) (if (fetch PROGNFLAG of D) then (VARASRT1 VARNAME (CDR SLIST))) (if (APPLY* (fetch TESTFN of (GETDECLTYPE (fetch DECL of D) VARNAME)) (EVALV VARNAME)) then (RETURN)) (ASSERTFAULT (fetch DECL of D) VARNAME]) (VARSETFN [LAMBDA (VARNAME) (* rmk%: " 2-Nov-84 15:05") (* Called by DECLSET and returns the setfn for VARNAME, or NIL if there isn't  one. The setfn is the lowest one found on a DPROGN chain.  Should be equivalent to (fetch SETFN of (VARDECL VARNAME T))%, but is opencoded  to avoid consing up the type each time.) (DECLARE (USEDFREE SATISFIESLIST)) (for S TEMP D in SATISFIESLIST when (SETQ D (ASSOC VARNAME S)) do (RETURN (fetch SETFN of (GETDECLTYPE (if (NULL (SETQ D (fetch VARDECL of D))) then 'ANY else (fetch DECL of D)) VARNAME))) finally (RETURN (CONSTANT DefaultSetFn]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: DECLTRAN DECLTRAN DECLVAR) (BLOCK%: PPDECL PPDECL PPVARLIST) (BLOCK%: \VARASRT \VARASRT VARASRT1) ) (* Declaration database fns) (DEFINEQ (DECLOF [LAMBDA (FORM DECLCONTEXT) (* bas%: "31-JUL-79 13:40") (* Returns a declaration for FORM in the context maintained by the code reading  system DECLCONTEXT) (DECLARE (USEDFREE CSATISFIESLIST SATISFIESLIST DECLVARSLST)) (fetch NAME of (TBOF FORM (SELECTQ DECLCONTEXT (COMPILER CSATISFIESLIST) (INTERPRETER SATISFIESLIST) (NIL (if (BOUNDP DECLVARSLST) then DECLVARSLST else CSATISFIESLIST)) (ERRORX (LIST 27 DECLCONTEXT]) (DECLOF1 [LAMBDA (FORM) (* rmk%: " 9-NOV-83 09:24") (* Computes a declaration form for FORM.  May be redundant as it will be checked in DECLOF.) (if (LITATOM FORM) then (SELECTQ FORM (NIL NIL) (T '(MEMQ T)) (VARDECL FORM)) elseif (LISTP FORM) then [PROG (TEMP) (RETURN (if (LITATOM (CAR FORM)) then [OR (if (AND (EQ [CAR (LISTP (SETQ TEMP (GETP (CAR FORM) 'DECLOF] 'FUNCTION) (NEQ (CAR (LISTP (CDR TEMP))) 'SATISFIES)) then (APPLY* (CADR TEMP) FORM) else TEMP) (SELECTQ (CAR FORM) ((SETQ SETQQ) [PROG [VSF (VD (VARDECL (CADR FORM] (SETQ VSF (fetch SETFN of (GETDECLTYPE VD))) (RETURN (if (EQ VSF (CONSTANT DefaultSetFn)) then [LIST 'ALLOF VD (if (EQ (CAR FORM) 'SETQQ) then (LIST 'MEMQ (CADDR FORM)) else (DECLOF1 (CADDR FORM] else (DECLOF1 (CONS VSF (CDR FORM]) (PROG (* Declaration is known only if the first and only executable statement in the  prog is a RETURN) [for TAIL TEMP on (CDDR FORM) suchthat (SELECTQ (SETQ TEMP (CAAR TAIL)) ((ASSERT DECLARE) NIL) (NEQ TEMP COMMENTFLG)) finally (RETURN (if (AND (EQ TEMP 'RETURN) (NULL (CDR TAIL))) then (DECLOF1 (CADAR TAIL)) else 'ANY]) (PROGN (DECLOF1 (CAR (LAST FORM)))) (COND [for CL D TFLAG in (CDR FORM) unless (if (EQ [SETQ D (DECLOF1 (CAR (LAST CL] 'ANY) then (RETURN 'ANY) else (if (EQ (CAR CL) T) then (SETQ TFLAG T)) (MEMBER D $$VAL)) collect D finally (if (NOT (OR TFLAG (FMEMB NIL $$VAL))) then (SETQ $$VAL (NCONC1 $$VAL NIL))) (RETURN (if (CDR $$VAL) then (CONS 'ONEOF $$VAL) else (CAR $$VAL]) (SELECTQ [for TAIL D on (CDDR FORM) unless (if (EQ [SETQ D (DECLOF1 (if (CDR TAIL) then (CAR (LAST (CDAR TAIL))) else (CAR TAIL] 'ANY) then (RETURN 'ANY) else (MEMBER D $$VAL)) collect D finally (RETURN (if (CDR $$VAL) then (CONS 'ONEOF $$VAL) else (CAR $$VAL]) ((REPLACEFIELD FREPLACEFIELD /REPLACEFIELD) (DECLOF1 (CADDDR FORM))) (REALSETQ (DECLOF1 (CADDR FORM))) ((FETCHFIELD FFETCHFIELD) (if (FIXP (CADR FORM)) then (SELECTQ (LRSH (LOGAND (CADR FORM) 12582912) 22) (1 'FIXP) (2 'FLOATP) (3 (* FLAG) '(MEMQ NIL T)) (PROGN (* 0=pointer) 'ANY)) else 'ANY)) (REPLACEFIELDVAL (DECLOF1 (CADDR FORM))) (PROG1 (DECLOF1 (CADR FORM))) (\*DECL [PROG [(DECLVARSLST (if [OR (NULL (CADR FORM)) (LISTP (CAR (CAADR FORM] then (CADR FORM) else (CONS (CADR FORM) DECLVARSLST] (* Maintain proper DECLVARSLST for  recursion) (DECLARE (SPECVARS DECLVARSLST)) (RETURN (DECLOF1 (CAR (LAST (CDDR FORM]) ((the THE) (CADR FORM)) ((create CREATE) (CADR FORM)) (QUOTE (* Could be done in the constant eval, but here for efficiency cause very  common) (LIST 'MEMQ (CADR FORM))) (if (AND (NEQ FORM (SETQ TEMP (EXPANDMACRO FORM T))) (NEQ TEMP 'IGNOREMACRO)) then (DECLOF1 TEMP) else (if [SETQ TEMP (OR (GETHASH FORM CLISPARRAY) (AND (GETP (CAR FORM) 'CLISPWORD) (RESETVARS (FILEPKGFLG (NOSPELLFLG T) (DWIMESSGAG T)) (DWIMIFY0? FORM FORM) (RETURN (GETHASH FORM CLISPARRAY] then (DECLOF1 TEMP) elseif (DECLCONSTANTP FORM) then (LIST 'MEMQ (EVAL FORM)) else 'ANY] elseif [AND (LISTP (CAR FORM)) (SETQ TEMP (SELECTQ (CAAR FORM) ([LAMBDA NLAMBDA] (CAR (LAST (CDDAR FORM)))) (PROGN (* Hope it's a translated LAMBDAWORD) (GETHASH (CAR FORM) CLISPARRAY] then (DECLOF1 TEMP) else 'ANY] else (LIST 'MEMQ FORM]) (TBOF [LAMBDA (FORM DECLVARSLST) (* bas%: " 9-OCT-79 23:27") (* Returns a type block for the value  of form) (DECLARE (SPECVARS DECLVARSLST)) (* DECLVARSLST is SPECIAL for an eventual call on VARDECL on an atom.) (GETDECLTYPE (DECLOF1 FORM]) (TYPEBLOCKOF [LAMBDA (FORM) (* bas%: "31-JUL-79 13:40") (* Gets type block for compiler  declaration of FORM) (DECLARE (USEDFREE CSATISFIESLIST)) (TBOF FORM CSATISFIESLIST]) (VARDECL [LAMBDA (VARNAME) (* bas%: "30-JUL-79 18:07") (* Returns the declaration for VARNAME. The declaration will include all  inherited attributes for DPROGN variables.) (DECLARE (USEDFREE DECLVARSLST)) (for S ONE DECLS D in DECLVARSLST when (SETQ D (fetch VARDECL of (ASSOC VARNAME S))) do (if ONE then (SETQ DECLS (LIST (fetch DECL of D) ONE)) (* ONE is to avoid the cons in the common single-test case) (SETQ ONE NIL) elseif DECLS then (push DECLS (fetch DECL of D)) else (SETQ ONE (fetch DECL of D))) (if (NOT (fetch PROGNFLAG of D)) then (GO $$OUT)) finally (RETURN (if DECLS then (CONS 'ALLOF (DREVERSE DECLS)) elseif ONE else 'ANY]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: DECLOFBLK DECLOF DECLOF1 TBOF TYPEBLOCKOF VARDECL (ENTRIES DECLOF TYPEBLOCKOF)) ) (* Enabling and disabling fns) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS FNEQUIVS ((DECLFN (PACK* 'DECL DATUM)) (REALFN (PACK* 'REAL DATUM)))) ) (DECLARE%: EVAL@COMPILE [PUTPROPS MOVEPROP MACRO ((PROP FROM TO) (PUTIFPROP TO PROP (GETPROP FROM PROP] [PUTPROPS PUTIFPROP MACRO ((ATM PROP VAL) (WITH ((V VAL)) (COND (V (PUTPROP ATM PROP V)) (T (REMPROP ATM PROP) NIL] ) ) (DEFINEQ (STARTDECLS [LAMBDA NIL (* rmk%: "12-Mar-85 09:15") (* Repository of various code that sets up dummy function defns and other  things that would require P commands in the file coms.  Distinct from DODECLS which actually activates DECLs.) (for I in '(DECL WHOSE) do (MOVD? 'QUOTE I)) (for I in '(\CHKVAL \DECLPROGN) do (MOVD? 'PROGN I)) [for I in '(CHANGERECORD CLISPTRAN SETQ SET SETQQ) do (AND (MOVD? I (fetch REALFN of I)) (BOUNDP 'SYSLINKEDFNS) (BOUNDP 'LINKEDFNS) (FMEMB I SYSLINKEDFNS) (push LINKEDFNS (fetch REALFN of I] (for P in MACROPROPS do (MOVEPROP P 'SETQ 'REALSETQ)) (for P in MACROPROPS do (MOVEPROP P 'SET 'REALSET)) (if (AND (BOUNDP 'DECLTYPESARRAY) (EQ (ASKUSER DWIMWAIT 'N "Reinitialize DECLTYPE lattice? ") 'N)) else (INITDECLTYPES)) (for I in '((COVERS CALL (IF (EQ (CAR EXPR) 'QUOTE) [NIL (@ (TYPEMSANAL COVERS) '((|..| TYPE] EVAL) (IF (EQ (CAR EXPR) 'QUOTE) [NIL (@ (TYPEMSANAL COVERS) '((|..| TYPE] EVAL) . PPE) (SELCOVERSQ . MACRO) (SELTYPEQ . MACRO) (\*DECL NIL [IF NULL NIL (IF (LISTP (CAAR EXPR)) [(|..| (@ (TYPEMSANAL \*DECL) '((|..| TYPE) TEST] (|..| (@ (TYPEMSANAL \*DECL) '((|..| TYPE) TEST] |..| EFFECT RETURN) (\CHKINIT NIL) (\CHKVAL NIL EVAL) (THE @ (TYPEMSANAL the) '(CLISP (|..| TYPE) RETURN)) (TYPE? @ (TYPEMSANAL type?) '(CLISP (|..| TYPE) RETURN)) (the @ (TYPEMSANAL the) '(CLISP (|..| TYPE) RETURN)) (type? @ (TYPEMSANAL type?) '(CLISP (|..| TYPE) RETURN)) (VALUEERROR NIL)) do (PUTHASH (CAR I) (CDR I) MSTEMPLATES)) (DODECLS T]) (DODECLS [LAMBDA (FLG) (* DECLARATIONS%: (RECORD DSF  (ATM FN . PRPLST))) (DECLARE (USEDFREE COMPILEIGNOREDECL)) (* rmk%: "12-Mar-85 09:07") (* Turns decls on if FLG; off if not. If turning on when they are currently  off, then the old values are saved in a private cons so they can be restored if  DECLS are turned off.) (SETQ COMPILEIGNOREDECL (NOT FLG)) (* Reset the compile switch) (WITH [[DECLSETFROM '((CHANGERECORD T) (CLISPTRAN T) (SET T) (SETQ T BYTEMACRO NIL MACRO (ARGS (SETQMAC ARGS))) (SETQQ T) (TYPE? NIL CLISPWORD (DTYPE?TRAN . type?)) (type? NIL CLISPWORD (DTYPE?TRAN . type?] (DECLUNSAVELST (CONSTANT (LIST NIL] [if (AND FLG (NOT (CAR DECLUNSAVELST))) then (* Collect the values to be restored) (RPLACA DECLUNSAVELST (for F in DECLSETFROM collect (create DSF ATM _ (fetch ATM of F) FN _ (GETD (fetch ATM of F)) PRPLST _ (for J on (fetch PRPLST of F) by (CDDR J) join (LIST (CAR J) (GETPROP (fetch ATM of F) (CAR J] [for F in (if FLG then DECLSETFROM else (CAR DECLUNSAVELST)) do [WITH ((DEF (fetch FN of F))) (AND DEF (PUTD (fetch ATM of F) (if (AND FLG (EQ DEF T)) then (GETD (fetch DECLFN of (fetch ATM of F))) else DEF] (for J on (fetch PRPLST of F) by (CDDR J) do (PUTIFPROP (fetch ATM of F) (CAR J) (CADR J] (if FLG else (RPLACA DECLUNSAVELST NIL) (* Nothing saved anymore))) FLG]) ) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LAMBDATRAN) (DECLARE%: EVAL@COMPILE (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) SIMPLIFY) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DEFINEQ (IBOX [LAMBDA (IVAL) (* edited%: "29-Jan-85 17:28") (* If needed, give field the initial value defined in the record) (create IBOX I _ (OR IVAL 0]) (FBOX [LAMBDA (FVAL) (* rmk%: "23-SEP-77 09:39") (create FBOX F _ (OR FVAL 0.0]) (NBOX [LAMBDA (NVAL) (* rmk%: "10-OCT-77 10:17") (* A boxing function for numbers of unknown type.  Since most functions that produce unknown-typed numbers compile closed and box  internally, this is really useful only to copy boxes produced by those  functions into new boxes at setq's. E.g.  (SETQ X (NBOX Y))%, where previously there was  (SETQ Y (DIFFERENCE A B))) (if (FLOATP NVAL) then (create FBOX F _ NVAL) else (create IBOX I _ NVAL]) ) (MOVD? 'LIST 'LBOX) (MOVD? 'CONS 'CBOX) (DECLARE%: EVAL@COMPILE (BLOCKRECORD FBOX ((F FLOATING)) [CREATE (SELECTQ (SYSTEMTYPE) ((TENEX TOPS-20) (FPLUS 0.0)) (D (\CREATECELL (CONSTANT \FLOATP))) (HELP "FBOX CREATE NOT DEFINED FOR SYSTEMTYPE " (SYSTEMTYPE]) (BLOCKRECORD IBOX ((I INTEGER)) [CREATE (SELECTQ (SYSTEMTYPE) ((TENEX TOPS-20) (IPLUS 100000)) (D (\CREATECELL (CONSTANT \FIXP))) (HELP "IBOX CREATE NOT DEFINED FOR SYSTEMTYPE " (SYSTEMTYPE]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS IBOX DMACRO (ARGS (COND (ARGS (APPEND '(create IBOX smashing (LOADTIMECONSTANT (\CREATECELL (CONSTANT \FIXP) )) I _) ARGS)) (T '(LOADTIMECONSTANT (\CREATECELL (CONSTANT \FIXP] [PUTPROPS FBOX DMACRO (ARGS (COND (ARGS (APPEND '(create FBOX smashing (LOADTIMECONSTANT (\CREATECELL (CONSTANT \FLOATP)) ) F _) ARGS)) (T '(LOADTIMECONSTANT (\CREATECELL (CONSTANT \FLOATP] [PUTPROPS NBOX DMACRO (OPENLAMBDA (NVAL) (COND ((FLOATP NVAL) (FBOX NVAL)) (T (IBOX NVAL] ) (DECLARE%: EVAL@COMPILE (PROGN (PUTPROPS CBOX MACRO ((X Y) (FRPLNODE (CONSTANT (CONS)) X Y))) (PUTPROPS CBOX DMACRO (= . CONS))) (PROGN [PUTPROPS LBOX MACRO (ARGLIST (PROG (NILIST (FORM '$X$)) [MAP ARGLIST (FUNCTION (LAMBDA (ARG) (SETQ NILIST (CONS NIL NILIST)) (SETQ FORM (LIST 'FRPLACA FORM (CAR ARG))) (AND (CDR ARG) (SETQ FORM (LIST 'CDR FORM] (RETURN (LIST (LIST 'LAMBDA '($X$) '(DECLARE (LOCALVARS $X$)) FORM '$X$) (KWOTE NILIST] (PUTPROPS LBOX DMACRO (= . LIST))) ) (DECLARE%: EVAL@COMPILE [I.S.OPR 'scratchcollect '(SETQ $$SCPTR (FRPLACA [OR (CDR $$SCPTR) (CDR (FRPLACD $$SCPTR (CAR (FRPLACA $$SCCONS (CONS] BODY)) '(BIND $$SCPTR $$SCCONS _ (CONSTANT (CONS)) FIRST (SETQ $$SCPTR $$SCCONS) FINALLY (SETQ $$VAL (AND (NEQ $$SCPTR $$SCCONS) (PROG1 (CDR $$SCCONS) (COND ((CDR $$SCPTR) (FRPLACD $$SCCONS (PROG1 (CDR $$SCPTR) (FRPLACD $$SCPTR NIL) (FRPLACD (PROG1 (CAR $$SCCONS) (FRPLACA $$SCCONS $$SCPTR) ) (CDR $$SCCONS] ) (ADDTOVAR SYSLOCALVARS $$SCCONS $$SCPTR) (ADDTOVAR INVISIBLEVARS $$SCCONS $$SCPTR) (DECLARE%: EVAL@COMPILE [PUTPROPS WITH MACRO (ARGS (CONS (CONS 'LAMBDA (CONS [for I in (CAR ARGS) collect (COND ((LITATOM I) I) ((LISTP I) (CAR I)) (T (ERROR "Invalid WITH form binding" I] (CDR ARGS))) (for I in (CAR ARGS) collect (CADR (LISTP I] ) (SETTEMPLATE 'WITH '((BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND EVAL |..| EFFECT) BIND))) |..| EFFECT RETURN)) (REMPROP 'WITH 'CLISPWORD) (ADDTOVAR DWIMEQUIVLST (WITH . PROG)) (ADDTOVAR PRETTYEQUIVLST (WITH . PROG)) ) (DECLARE%: DOCOPY (DECLARE%: EVAL@LOADWHEN (NEQ (SYSTEMTYPE) 'D) [OR (GETPROP 'LOADTIMECONSTANT 'FILEDATES) (PROG ((X (FINDFILE (PACKFILENAME 'NAME 'LOADTIMECONSTANT 'EXTENSION COMPILE.EXT) T LISPUSERSDIRECTORIES))) (COND (X (LOAD X 'SYSLOAD)) ((NOT (GETPROP 'LOADTIMECONSTANT 'MACRO)) (PUTPROP 'LOADTIMECONSTANT 'MACRO '((FORM) (CONSTANT FORM] ) ) (ADDTOVAR OPENFNS \DECLPROGN \CHKVAL \CHKINIT ASSERT \*DECL \VARASRT) (PUTPROPS DPROG CLISPWORD (DECLTRAN . DPROG)) (PUTPROPS DPROGN CLISPWORD (DECLTRAN . DPROGN)) (PUTPROPS THE CLISPWORD (THETRAN . the)) (PUTPROPS the CLISPWORD (THETRAN . the)) (PUTPROPS DLAMBDA INFO BINDS) (PUTPROPS DPROG INFO (BINDS LABELS)) (PUTPROPS DPROGN INFO EVAL) (RPAQQ SATISFIESLIST NIL) (RPAQQ CSATISFIESLIST NIL) (RPAQQ NEWSATLIST T) (RPAQ? DECLMESSAGES ) (RPAQ? COMPILEIGNOREDECL ) (ADDTOVAR DECLATOMS DLAMBDA DPROG DPROGN) (ADDTOVAR LAMBDASPLST DLAMBDA) (ADDTOVAR SYSLOCALVARS VALUE) (ADDTOVAR DESCRIBELST ["types: " (GETRELATION FN '(USE TYPE]) (ADDTOVAR BAKTRACELST (\DECLPROGN (DPROGN APPLY *PROG*LAM \*DECL *ENV*) (NIL APPLY *PROG*LAM \*DECL)) (PROG (DPROG \DECLPROGN APPLY *PROG*LAM \*DECL))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SLISTENTRY (VARNAME . VARDECL)) (RECORD VARDECL (DECL . PROGNFLAG)) ) ) (ADDTOVAR LAMBDATRANFNS (DLAMBDA DECLTRAN EXPR DLAMARGLIST)) (DECLARE%: DONTEVAL@LOAD (ADDTOVAR PRETTYPRINTMACROS (DPROGN . PPDECL) (DECL . PPDECL) (DLAMBDA . PPDECL) (DPROG . PPDECL)) ) (PUTPROPS ASSERT INFO EVAL) (DECLARE%: EVAL@COMPILE (PUTPROPS ASSERT MACRO (ARGS (ASSERTMAC ARGS))) [PROGN [PUTPROPS .CBIND. BYTEMACRO (APPLY (LAMBDA (PV BODY) (APPLY* 'PROG PV '(RETURN (COMP.EXP1 BODY] (PUTPROPS .CBIND. MACRO (X (HELP "Compiler dependent macro must be supplied for .CBIND."] (PUTPROPS \CHKINIT MACRO (ARGS (CHKINITMAC ARGS))) [PUTPROPS \CHKVAL MACRO (ARGS (COND [(IGNOREDECL) (COND ((EQ (CAAR ARGS) 'COND) (CADADR (CAR ARGS))) (T (CADAR ARGS] (T (CAR ARGS] (PUTPROPS \*DECL MACRO (ARGS (*DECLMAC ARGS))) [PUTPROPS DECL MACRO (X (COMPEM "DECL in illegal location" (CONS 'DECL X] [PROGN [PUTPROPS DECLMSGMAC DMACRO ((X . Y) (CONSTANT (DECLMSG X . Y] (PUTPROPS DECLMSGMAC MACRO ((X . Y) (LOADTIMECONSTANT (DECLMSG X . Y] (PROGN (DEFMACRO REALSETQ (X &REST CL:REST) (CONS 'CL:SETQ (CONS X CL:REST))) (PUTPROPS REALSETQ BYTEMACRO COMP.SETQ)) ) (* MACROS REALSET) (AND (GETD 'STARTDECLS) (STARTDECLS)) [PROG [(COM (CDR (ASSOC 'DW EDITMACROS] (AND COM (RPLACD COM (CONS (APPEND '(RESETVAR NEWSATLIST (EDITNEWSATLIST)) (CDR COM] (* Builtin DECLOF properties) (PUTPROPS APPEND DECLOF LST) (PUTPROPS CONS DECLOF LISTP) (PUTPROPS EQ DECLOF (MEMQ T NIL)) (PUTPROPS LIST DECLOF [FUNCTION (LAMBDA (FORM) (AND (CDR FORM) 'LISTP]) (PUTPROPS LISTP DECLOF LST) (PUTPROPS NCONC DECLOF LST) (DECLARE%: EVAL@COMPILE DONTCOPY (RESETSAVE DWIMIFYCOMPFLG NIL) [AND (GETD 'DODECLS) (RESETSAVE (DODECLS) '(DODECLS T] ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DECLSETQ DECLMSG DD \CHKINIT \*DECL ASSERT DECLTYPES DECLTYPE) (ADDTOVAR NLAML DECLSETQQ TYPEMSANAL) (ADDTOVAR LAMA DECLDWIMERROR) ) (PUTPROPS DECL COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9122 12665 (DECLTYPE 9132 . 9313) (DECLTYPES 9315 . 9672) (DUMPDECLTYPES 9674 . 11510) (GETDECLDEF 11512 . 12663)) (13894 16410 (COVERS 13904 . 14107) (GETDECLTYPEPROP 14109 . 14286) ( SETDECLTYPEPROP 14288 . 14725) (SUBTYPES 14727 . 15427) (SUPERTYPES 15429 . 16408)) (20952 57979 ( CHECKTYPEXP 20962 . 21340) (COLLECTTYPES 21342 . 23044) (COVERSCTYPE 23046 . 23872) (COVERSTB 23874 . 24301) (COVERSTE 24303 . 25008) (CREATEFNPROP 25010 . 25394) (CREATEFNVAL 25396 . 25942) (DECLERROR 25944 . 26179) (DELETETB 26181 . 27014) (FINDDECLTYPE 27016 . 27496) (FINDPROP 27498 . 27697) ( FINDTYPEXP 27699 . 28470) (GETCTYPE 28472 . 28907) (GETDECLTYPE 28909 . 29480) (GETDECLTYPE.NOERROR 29482 . 30166) (GETTBPROP 30168 . 30633) (INHERITPROP 30635 . 32197) (INITDECLTYPES 32199 . 35163) ( LCCTYPE 35165 . 35508) (LCC2 35510 . 36098) (MAKECTYPE 36100 . 37835) (MAKEDECLTYPE 37837 . 38848) ( MAKEBINDFN 38850 . 39126) (MAKESETFN 39128 . 39400) (MAPTYPEUSERS 39402 . 39660) (NOTICETB 39662 . 40129) (PPDTYPE 40131 . 42395) (RECDTYPE 42397 . 44262) (DECLCHANGERECORD 44264 . 45399) (RECDEFTYPE 45401 . 46562) (REPROPTB 46564 . 48281) (SETTBPROP 48283 . 49218) (TBDEFPRINT 49220 . 49556) (TETYPE 49558 . 50361) (TYPEMSANAL 50363 . 52158) (TYPEMSANAL1 52160 . 53383) (UNCOMPLETE 53385 . 54348) ( UNSAVETYPE 54350 . 55076) (USERDECLTYPE 55078 . 56819) (USESTYPE 56821 . 57977)) (58141 69148 ( MAKETESTFN 58151 . 58574) (MAKETESTFNBLOCK 58576 . 63318) (COMBINE.TESTS 63320 . 64319) (FUNIFY 64321 . 64898) (MKNTHCAR 64900 . 65358) (MKNTHCDR 65360 . 66007) (OF.TESTFN 66009 . 66469) (TUPLE.TESTFN 66471 . 67167) (WHOSE.TESTFN 67169 . 69146)) (71069 71414 (TESTFORM 71079 . 71412)) (71602 73334 ( EVERYCHAR 71612 . 71901) (LARGEP 71903 . 72146) (DECLRECURSING 72148 . 73023) (SMASHCAR 73025 . 73332) ) (74575 130437 (ASSERT 74585 . 75218) (ASSERTFAULT 75220 . 76142) (ASSERTMAC 76144 . 76985) (\*DECL 76987 . 78332) (*DECLMAC 78334 . 80689) (\CHKINIT 80691 . 81821) (CHKINITMAC 81823 . 83507) ( DECLCONSTANTP 83509 . 85131) (DD 85133 . 85774) (DECLCLISPTRAN 85776 . 90580) (DECLMSG 90582 . 91845) (DECLDWIMERROR 91847 . 92342) (DECLDWIMTESTFN 92344 . 93150) (DECLSET 93152 . 93783) (DECLSETQ 93785 . 94661) (DECLSETQQ 94663 . 94850) (DECLTRAN 94852 . 102250) (DECLVAR 102252 . 110275) (DLAMARGLIST 110277 . 110772) (DTYPE?TRAN 110774 . 112135) (EDITNEWSATLIST 112137 . 112793) (FORMUSESTB 112795 . 113667) (IGNOREDECL 113669 . 114395) (MAKETESTFORM 114397 . 115220) (PPDECL 115222 . 121443) ( PPVARLIST 121445 . 123040) (SETQMAC 123042 . 125572) (THETRAN 125574 . 127119) (VALUEERROR 127121 . 128269) (\VARASRT 128271 . 128598) (VARASRT1 128600 . 129511) (VARSETFN 129513 . 130435)) (130633 141888 (DECLOF 130643 . 131411) (DECLOF1 131413 . 139868) (TBOF 139870 . 140333) (TYPEBLOCKOF 140335 . 140712) (VARDECL 140714 . 141886)) (142628 148350 (STARTDECLS 142638 . 145503) (DODECLS 145505 . 148348)) (148558 149651 (IBOX 148568 . 148818) (FBOX 148820 . 148977) (NBOX 148979 . 149649))))) STOP \ No newline at end of file diff --git a/lispusers/DECL.TEDIT b/lispusers/DECL.TEDIT new file mode 100644 index 00000000..0063219f --- /dev/null +++ b/lispusers/DECL.TEDIT @@ -0,0 +1,110 @@ +XEROX DECL 2 4 1 DECL 1 4 UNSUPPORTED INTERNAL Uses: SIMPLIFY, LABEL and LAMBDATRAN NOTE TO LYRIC/MEDLEY USERS The DECL module is not supported in Lyric/Medley since it uses the DWIM facilities heavily, and DWIM is not supported in Lyric/Medley. It is being released as a LispUsers module only for backward compatibility. The DECL module only runs under the OLD-INTERLISP-T executive, and all the code that uses it will also have to run under this executive. Therefore, you may wish to convert code that uses DECL to something else. INTRODUCTION The Decl LispUsers package is contained on the file DECL.LCOM. The Decl package requires the LambdaTran package. LAMBDATRAN.LCOM will automatically be loaded with Decl if it is not already present. The Decl package extends Interlisp to allow the user to declare the types of variables and expressions appearing in functions. It provides a convenient way of constraining the behavior of programs when the generality and flexibility of ordinary Interlisp is either unnecessary, confusing, or inefficient. Decl provides a simple language for declarations, and augments the interpreter and the compiler to guarantee that these declarations are always satisfied. The declarations make programs more readable by indicating the type, and therefore something about the intended usage, of variables and expressions in the code. They facilitate debugging by localizing errors that manifest themselves as type incompatibilities. Finally, the declaration information is available for other purposes: compiler macros can consult the declarations to produce more efficient code; coercions for arguments at user interfaces can be automatically generated; and the declarations will be noticed by the Masterscope function analyzer. The declarations interpreted by the Decl package are in terms of a set of declaration types called decltypes, each of which specifies a set of acceptable values and also (optionally) other type-specific behavior. The Decl package provides a set of facilities for defining decltypes and their relations to each other, including type-valued expressions and a comprehensive treatment of union types. The following description of the Decl package is divided into three parts. First, the syntactic extensions that permit the concise attachment of declarations to program elements are discussed. Second, the mechanisms by which new decltypes can be defined and manipulated are covered. Finally, some additional capabilities based on the availability of declarations are outlined. USING DECLARATIONS IN PROGRAMS Declarations may be attached to the values of arbitrary expressions and to LAMBDA and PROG variables throughout (or for part of) their lexical scope. The declarations are attached using constructs that resemble the ordinary Interlisp LAMBDA, PROG, and PROGN, but which also permit the expression of declarations. The following examples illustrate the use of declarations in programs. Consider the following definition for the factorial function (FACT N ): [LAMBDA (N) (COND ((EQ N 0) 1) (T (ITIMES N (FACT (SUB1 N] Obviously, this function presupposes that N is a number, and the run-time checks in ITIMES and SUB1 will cause an error if this is not so. For instance, (FACT T) will cause an error and print the message NON-NUMERIC ARG T. By defining FACT as a DLAMBDA, the Decl package analog of LAMBDA, this presupposition can be stated directly in the code: [DLAMBDA ((N NUMBERP)) (COND ((EQ N 0) 1) (T (ITIMES N (FACT (SUB1 N] With this definition, (FACT T) will result in a NON-NUMERIC ARG T error when the body of the code is executed. Instead, the NUMBERP declaration will be checked when the function is first entered, and a declaration fault will occur. Thus, the message that the user will see will not dwell on the offending value T, but instead give a symbolic indication of what variable and declaration were violated, as follows: DECLARATION NOT SATISFIED ((N NUMBERP) BROKEN): The user is left in a break from which the values of variables, e.g., N, can be examined to determine what the problem is. The function FACT also makes other presuppositions concerning its argument, N. For example, FACT will go into an infinite recursive loop if N is a number less than zero. Although the user could program an explicit check for this unexpected situation, such coding is tedious and tends to obscure the underlying algorithm. Instead, the requirement that N not be negative can be succinctly stated by declaring it to be a subtype of NUMBERP that is restricted to non-negative numbers. This can be done by adding a SATISFIES clause to N's type specification: [DLAMBDA ([N NUMBERP (SATISFIES (NOT (MINUSP N]) (COND ((EQ N 0) 1) (T (ITIMES N (FACT (SUB1 N] The predicate in the SATISFIES clause will be evaluated after N is bound and found to satisfy NUMBERP, but before the function body is executed. In the event of a declaration fault, the SATISFIES condition will be included in the error message. For example, (FACT -1) would result in: DECLARATION NOT SATISFIED ((N NUMBERP (SATISFIES (NOT (MINUSP N))) BROKEN): The DLAMBDA construct also permits the type of the value that is returned by the function to be declared by means of the pseudo-variable RETURNS. For example, the following definition specifies that FACT is to return a positive integer: [DLAMBDA ([N NUMBERP (SATISFIES (NOT (MINUSP N] [RETURNS FIXP (SATISFIES (IGREATERP VALUE 0]) (COND ((EQ N 0) 1) (T (ITIMES N (FACT (SUB1 N] After the function body is evaluated, its value is bound to the variable VALUE and the RETURNS declaration is checked. A declaration fault will occur if the value is not satisfactory. This prevents a bad value from propagating to the caller of FACT, perhaps causing an error far away from the source of the difficulty. Declaring a variable causes its value to be checked not only when it is first bound, but also whenever that variable is reset by SETQ within the DLAMBDA. In other words, the type-checking machinery will not allow a declared variable to take on an improper value. An iterative version of the factorial function illustrates this feature in the context of a DPROG, the analog of PROG: (DLAMBDA ([N NUMBERP (SATISFIES (NOT (MINUSP N] [RETURNS FIXP (SATISFIES (IGREATERP VALUE 0]) [DPROG ([TEMP 1 FIXP (SATISFIES (IGREATERP TEMP 0] [RETURNS FIXP (SATISFIES (IGREATERP VALUE 0]) LP (COND ((EQ N 0) (RETURN TEMP))) (SETQ TEMP (ITIMES N TEMP)) (SETQ N (SUB1 N)) (GO LP] DPROG declarations are much like DLAMBDA declarations, except that they also allow an initial value for the variable to be specified. In the above example, TEMP is declared to be a positive integer throughout the computation and N is declared to be non-negative. Thus, a bug which caused an incorrect value to be assigned by one of the SETQ expressions would cause a declaration failure. Note that the RETURNS declaration for a DPROG is also useful in detecting the common bug of omitting an explicit RETURN. DLAMBDAs The Decl package version of a LAMBDA expression is an expression beginning with the atom DLAMBDA. Such an expression is a function object that may be used in any context where a LAMBDA expression may be used. It resembles a LAMBDA expression except that it permits declaration expressions in its argument list, as illustrated in the examples given earlier. Each element of the argument list of a DLAMBDA may be a literal atom (as in a conventional LAMBDA) or a list of the form (NAME TYPE .EXTRAS). Strictly, this would require a declaration with a SATISFIES clause to take the form (N (NUMBERP (SATISFIES --)) --). However, due to the frequency with which this construction is used, it may be written without the inner set of parentheses, e.g., (N NUMBERP (SATISFIES --) --). NAME fulfills the standard function of a parameter, i.e., providing a name to which the value of the corresponding argument will be bound. TYPE is either a Decl package type name or type expression. When the DLAMBDA is entered, its arguments will be evaluated and bound to the corresponding argument names, and then, after all the argument names have been bound, the declarations will be checked. The type checking is delayed so that SATISFIES predicates can include references to other variables bound by the same DLAMBDA. For example, one might wish to define a function whose two arguments are not only both required to be of some given type, but are also required to satisfy some relationship (e.g., that one is less than the other). EXTRAS allows some additional properties to be attached to a variable. One such property is the accessibility of NAME outside the current lexical scope. Accessibility specifications include the atoms LOCAL or SPECIAL, which indicate that this variable is to be compiled so that it is either a LOCALVAR or a SPECVAR, respectively. This is illustrated by the following example: [DLAMBDA ((A LISTP SPECIAL) (B FIXP LOCAL)) ...] A more informative equivalent to the SPECIAL key word is the USEDIN form, the tail of which can be a list of the other functions that are expected to have access to the variable.1 [DLAMBDA ((A LISTP (USEDIN FOO FIE)) (B FIXP LOCAL)) ...] EXTRAS may also include a comment in standard format, so that descriptive information may be given where a variable is bound: [DLAMBDA ((A LISTP (USEDIN FOO FIE) (* This is an important variable)) (B FIXP LOCAL)) ...] As mentioned earlier, the value returned by a DLAMBDA can also be declared, by means of the pseudo-variable RETURNS. The RETURNS declaration is just like other DLAMBDA declarations, except (1) in any SATISFIES predicate, the value of the function is referred to by the distinguished name VALUE; and (2) it makes no sense to declare the return value to be LOCAL or SPECIAL. DPROG Just as DLAMBDA resembles LAMBDA, DPROG is analogous to PROG. As for an ordinary PROG, a variable binding may be specified as an atom or a list including an initial value form. However, a DPROG binding also allows TYPE and EXTRAS information to appear following the initial value form. The format for these augmented variable bindings is (NAME INITIALVALUE TYPE .EXTRAS). The only difference between a DPROG binding and a DLAMBDA binding is that the second position is interpreted as the initial value for the variable. Note that if the user wishes to supply a type declaration for a variable, an initial value must be specified. The same rules apply for the interpretation of the type information for DPROGs as for DLAMBDAs, and the same set of optional EXTRAs can be used. DPROGs may also declare the type of the value they return, by specifying the pseudo-variable RETURNS. Just as for a DLAMBDA, type tests in a DPROG are not asserted until after all the variables have been bound, thus permitting predicates to refer to other variables being bound by this DPROG. If NIL appears as the initial value for a binding (i.e., the atom NIL actually appears in the code, not simply an expression that evaluates to NIL) the initial type test will be suppressed, but subsequent type tests, e.g., following a SETQ, will still be performed. A common construct in Lisp is to bind and initialize a PROG variable to the value of a complicated expression in order to avoid recomputing it, and then to use this value in initializing other PROG variables, e.g. [PROG ((A EXPRESSION)) (RETURN (PROG ((B... ( A...)) (C... ( A... ))) ...] The ugliness of such constructions in conventional Lisp often tempts the programmer to loosen the scoping relationships of the variables by binding them all at a single level and using SETQ's in the body of the PROG to establish the initial values for variables that depend on the initial values of other variables, e.g., [PROG ((A EXPRESSION) B C) (SETQ B (...A... )) (SETQ C ( ...A... )) ...] In the Decl package environment, this procedure undermines the protection offered by the type mechanism by encouraging the use of uninitialized variables. Therefore, the DPROG offers a syntactic form to encourage more virtuous initialization of its variables. A DPROG variable list may be segmented by occurrences of the special atom THEN, which causes the binding of its variables in stages, so that the bindings made in earlier stages can be used in later ones, e.g., [DPROG ((A (LENGTH FOO) FIXP LOCAL) THEN (B (SQRT A) FLOATP) THEN (C (CONS A B) LISTP)) ...] Each stage is carried out as a conventional set of DPROG bindings (i.e., simultaneously, followed by the appropriate type testing). This layering of the bindings permits one to gradually descend into a inner scope, binding the local names in a very structured and clean fashion, with initial values type-checked as soon as possible. DECLARATIONS IN ITERATIVE STATEMENTS The CLISP iterative statement provides a very useful facility for specifying a variety of PROGs that follow certain widely used formats. The Decl package allows declarations to be made for the scope of an iterative statement via the DECLARE CLISP (I.S. operator). DECLARE can appear as an operator anywhere in an iterative statement, followed by a list of declarations, for example: (for J from 1 to 10 declare (J FIXP) do. . . Note that DECLARE declarations do not create bindings, but merely provide declarations for existing bindings. For this reason, an initial value cannot be specified and the form of the declaration is the same as that of DLAMBDAs, namely create (NAME TYPE . EXTRAS). Note that variables bound outside of the scope of the iterative statement, i.e., a variable used freely in the I.S., can also be declared using this construction. Such a declaration will only be in effect for the scope of the iterative statement. DECLARING A VARIABLE FOR A RESTRICTED LEXICAL SCOPE The Decl package also permits declaring the type of a variable over some restricted portion of its existence. For example, suppose the variable X is either a fixed or floating number, and a program branches to treat the two cases separately. On one path X is known to be fixed, whereas on the other it is known to be floating. The Decl package DPROGN construct can be used in such cases to state the type of the variable along each path. DPROGN is exactly like PROGN, except that the second element of the form is interpreted as a list of DLAMBDA format declarations. These declarations are added to any existing declarations in the containing scope, and the composite declaration (created using the ALLOF type expression), is considered to hold throughout the lexical scope created by the DPROGN. Thus, our example becomes: (if (FIXP X) then (DPROGN ((X FIXP))...else (DPROGN ((X FLOATP)) ...)) Like DPROG and DLAMBDA, the value of a DPROGN may also be declared, using the pseudo-variable RETURNS. DPROGN may be used not only to restrict the declarations of local variables, but also to declare variables that are being used freely. For example, if the variable A is used freely inside a function but is known to be FIXP, this fact could be noted by enclosing the body of the function in (DPROGN ((A FIXP FREE)) BODY). Instead of FREE, the more specific construction (BOUNDIN FUNCTION1 FUNCTION 2. . .) can be used. This not only states that the variable is used freely but also gives the names of the functions that might have provided this binding.2 Since the DPROGN form introduces another level of parenthesization, which results in the enclosed forms being prettyprinted indented, the Decl package also permits such declarations to be attached to their enclosing DLAMBDA or DPROG scopes by placing a DEC expression, e.g., (DECL (A FIXP (BOUNDIN FUM)), before the first executable form in that scope. Like DPROGN's, DECL declarations use DLAMBDA format. DECLARING THE VALUES OF EXPRESSIONS The Decl package allows the value of an arbitrary form to be declared with the Decl construct THE. A THE expression is of the form (THE TYPE . FORMS), e.g., (THE FIXP (FOO X)). FORMS are evaluated in order, and the value of the last one is checked to see if it satisfies TYPE, a type name or type expression. If so, its value is returned, otherwise a declaration fault occurs. ASSERTIONS The Decl package also allows for checking that an arbitrary predicate holds at a particular point in a program's execution, e.g., a condition that must hold at function entry but not throughout its execution. Such predicates can be checked using an expression of the form (ASSERT FORM1 FORM2), in which each FORM1 is either a list (which will be evaluated) or a variable (whose declaration will be checked). Unless all elements of the ASSERT form are satisfied, a declaration fault will take place. ASSERTing a variable provides a convenient way of verifying that the value of the variable has not been improperly changed by a lower function. Although a similar effect could be achieved for predicates by explicit checks of the form (OR PREDICATE (SHOULDNT)), ASSERT also provides the ability both to check that a variable's declaration is currently satisfied and to remove its checks at compile time without source code modification (see COMPILEIGNOREDECL). USING TYPE EXPRESSIONS AS PREDICATES The Decl package extends the Record package TYPE? construct so that it accepts decltypes, as well as record names, e.g., (TYPE? (FIXP (SATISFIES (ILESSP VALUE 0))) EXPR). Thus, a TYPE? expression is exactly the same as a THE expression except that, rather than causing a declaration fault, TYPE? is a predicate that determines whether or not the value satisfies the given type. ENFORCEMENT The Decl package is a ŠŠsoft'' typing system˙˙ď%˙that is, the data objects themselves are not inherently typed. Consequently, declarations can only be enforced within the lexical scope in which the declaration takes place, and then only in certain contexts. In general, changes to a variable's value such as those resulting from side effects to embedded structure (e.g., RPLACA, SETN, etc.) or free variable references from outside the scope of the declaration cannot be, and therefore are not, enforced. Declarations are enforced, i.e., checked, in three different situations: when a declared variable is bound to some value or rebound with SETQ or SETQQ, when a declared expression is evaluated, and when an ASSERT expression is evaluated. In a binding context, the type check takes place after the binding, including any user-defined behavior specified by the type's binding function. Any failure of the declarations causes a break to occur and an informative message to be printed. In that break, the name to which the declaration is attached (or VALUE if no name is available) will be bound to the offending value. Thus, in the FACT T example above, N would be bound to T. The problem can be repaired either by returning an acceptable value from the break via the RETURN command, or by assigning an acceptable value to the offending name and returning from the break via an OK or GO command. The unsatisfied declaration will be reasserted when the computation is continued, so an unacceptable value will be detected.3 The automatic enforcement of type declarations is a very flexible and powerful aid to program development. It does, however, exact a considerable run-time cost because of all the checking involved. Factors of two to ten in running speed are not uncommon, especially where low-level, frequently used functions employ type declarations. As a result, it is usually desirable to remove the declaration enforcement code when the system is believed to be bug-free and performance becomes more central. This can be done with the variable COMPILEIGNOREDECL. COMPILEIGNOREDECL [Variable] Setting the value of the variable COMPILEIGNOREDECL to T (initially NIL) instructs the compiler not to insert declaration enforcement tests in the compiled code. More selective removal can be achieved by setting COMPILEIGNOREDECL to a list of function names. Any function whose name is found on this list is compiled without declaration enforcement. IGNOREDECL. VAL [File Com] Declaration enforcement may be suppressed selectively by a file using the IGNOREDECL file package command. If this appears in a file's file commands, it redefines the value of COMPILEIGNOREDECL to VAL for the compilation of this file only. Note: The period in the IGNOREDECL file package command is significant. To set COMPILEIGNOREDECL to T, use (IGNOREDECL . T), not (IGNOREDECL T). DECLTYPES A Decl package type, or decltype, specifies a subset of data values to which values of this type are restricted. For example, a ŠŠpositive number'' type might be defined to include only those values that are numbers and greater than zero. A type may also specify how certain operations, such as assignment or binding (see BINDFN), are to be performed on variables declared to be of this type. The inclusion relations among the sets of values that satisfy the different types define a natural partial ordering on types, bound by the universal type ANY (which all values satisfy) and the empty type NONE (which no value satisfies). Each type has one or more supertypes (each type has at least ANY as a supertype) and one or more subtypes (each type has at least NONE as a subtype). This structure is important to the user of Decl as it provides the framework in which new types are defined. Typically, much of the definition of a new type is defaulted, rather than specified explicitly. The definition will be completed by inheriting attributes which are shared by all its immediate supertypes. An initial set of decltypes that defines the Interlisp built-in data types and a few other commonly used types is provided. Thereafter, new decltypes are created in terms of existing ones using the type expressions described below. For conciseness, such new types can be associated with literal atoms using the function DECLTYPE. PREDEFINED TYPES Some commonly used types, such as the Interlisp built-in data types, are already defined when the Decl package is loaded. These types, indented to show subtype-supertype relations, are:4 ANY ATOM LST ARRAYP STRINGP FUNCTION STACKP LITATOM ALIST HARRAYP NIL LISTP READTABLEP NUMBERP FIXP LARGEP SMALLP FLOATP NONE Note that the definition of LST causes NIL to have multiple supertypes, i.e., LITATOM and LST, reflecting the duality of NIL as an atom and a (degenerate) list. In addition, declarations made using the Record package also define types that are attached as subtypes to an appropriate existing type (e.g., a TYPERECORD declaration defines a subtype of LISTP, a DATATYPE declaration a subtype of ANY, etc.) and may be used directly in declaration contexts. TYPE EXPRESSIONS Type expressions provide convenient ways for defining new types in terms of modifications to, or compositions of one or more existing types. (MEMQ VALUE1. . .VALUE N) [Type Expression] Specifies a type whose values can be any one of the fixed set of elements VALUE 1. . .VALUE N. For example, the status of a device might be represented by a datum restricted to the values BUSY and FREE. Such a ŠŠdevice status'' type could be defined via (MEMQ BUSY FREE). The new type will be a subtype of the narrowest type that all of the alternatives satisfy (e.g., the "device status" type would be a subtype of LITATOM). The membership test uses EQ if this supertype is a LITATOM; EQUAL otherwise. Thus, lists, floating point numbers, etc., can be included in the set of alternatives. (ONEOF TYPE 1. . .TYPE N) [Type Expression] Specifies a type that is the union of two or more other types. For example, the notion of a possibly degenerate list is something that is either LISTP or NIL. Such a type can be (and the built-in type LST in fact is) defined simply as (ONEOF NIL LISTP). A union data type becomes a supertype of all of the alternative types specified in the ONEOF expression, and a subtype of their lowest common supertype. The type properties of a union type are taken from its alternative types if they all agree, otherwise from the supertype. (ALLOF TYPE 1. . .TYPE N) [Type Expression] Specifies a type that is the intersection of two or more other types. For example, a variable may be required to satisfy both FIXP and also some type that is defined as (NUMBERP (SATISFIES PREDICATE)). The latter type will admit numbers that are not FIXP, i.e., floating point numbers; the former does not include PREDICATE. Both restrictions can be obtained by using the type (ALLOF (NUMBERP (SATISFIES PREDICATE)) FIXP).5 (OF AGGREGATE OF ELEMENT) [Type Expression] Specifies DECLaggregate, a type that is an aggregate of values of some other type (e.g., list of numbers, array of strings, etc.). AGGREGATE must be a type that provides an EVERYFN property. The EVERYFN is used to apply an arbitrary function to each of the elements of a datum of the aggregate type, and check whether the result is non-NIL for each element. ELEMENT may be any type expression. For example, the type ŠŠlist of either strings or atoms'' can be defined as (LISTP OF (ONEOF STRINGP ATOM)). The type test for the new type will consist of applying the type test for ELEMENT to each element of the aggregate type using the EVERYFN property. The new type will be a subtype of its aggregate type.6 (SATISFIES TYPE (SATISFIES FORM 1. . .FORM N)) [Type Expression] Specifies a type whose values are a subset of the values of an existing type. The type test for the new type will first check that the base type is satisfied, i.e., that the object is a member of TYPE, and then evaluate FORM 1. . .FORM N. If each form returns a non-NIL value, the type is satisfied. The value that is being tested may be referred to in FORM 1. . . FORM N by either (a) the variable name if the type expression appears in a binding context such as DLAMBDA or DPROG, (b) the distinguished atom ELT for a SATISFIES clause on the elements of an aggregate type, or (c) the distinguished atom VALUE, when the type expression is used in a context where no name is available (e.g., a RETURNS declaration). For example, one might declare the program variable A to be a negative integer via (FIXP (SATISFIES (MINUSP A))) or declare the value of a DLAMBDA to be of type ((ONEOF FIXP FLOATP) (SATISFIES (GREATERP VALUE 25))). Note that more than one SATISFIES clause may appear in a single type expression attached to different alternatives in a ONEOF type expression, or attached to both the elements and the overall structure of an aggregate. For example, [LISTP OF [FIXP (SATISFIES (ILEQ ELT (CAR VALUE] (SATISFIES (ILESSP (LENGTH VALUE) 7] specifies a list of less than seven integers each of which is no greater than the first element of the list. (SHARED TYPE) [Type Expression] Specifies DECLshared, a subtype of TYPE, with default binding behavior, i.e., the binding function (see BINDFN), if any, will be suppressed.7 For example, if the type FLOATP were redefined so that DLAMBDA and DPROG bindings of variables that were declared to be FLOATP copied their initial values (e.g., to allow SETNs to be free of side effects), then variables declared (SHARED FLOATP) would be initialized in the normal fashion, without copying their initial values. NAMED TYPES Although type expressions can be used in any declaration context, it is often desirable to save the definition of a new type if it is to be used frequently, or if a more complex specification of its behavior is to be given than is convenient in an expression. The ability to define a named type is provided by the function DECLTYPE. (DECLTYPE TYPENAME TYPE PROP1 VAL1 PROPN VALN) [Function] NLambda, nospread function. TYPENAME is a literal atom, TYPE is either the name of an existing type or a type expression, and PROP 1, VAL 1...PROP N,VAL N is a specification (in property list format) of other attributes of the type. DECLTYPE derives a type from TYPE, associates it with TYPENAME, and then defines any properties specified with the values given. The following properties are interpreted by the Decl package.8 Each of these properties can have as its value either a function name or a LAMBDA expression. TESTFN [Property] will be used by the Decl package to test whether a given value satisfies this type. The type is considered satisfied if FN applied to the item is non-NIL. For example, one might define the type INTEGER with TESTFN FIXP.9 EVERYFN [Property] EVERYFN specifies a mapping function that can apply a functional argument to each ŠŠelement'' of an instance of this type, and which will return NIL unless the result of every such application was non-NIL. FN must be a function of two arguments: the aggregate and the function to be applied. For example, the EVERYFN for the built-in type LISTP is EVERY. The Decl package uses the EVERYFN property of the aggregate type to construct a type test for aggregate type expressions. In fact, it is the presence of an EVERYFN property that allows a type to be used as an aggregate type.10 BINDFN [Property] BINDFN is used to compute from the initial value supplied for a DLAMBDA or DPROG variable of this type, the value to which the variable will actually be initialized. FN must be a function of one argument that will be applied to the initial value, and which should produce another value which is to be used to make the binding.11 For example, a BINDFN could be used to bind variables of some type so that new bindings are copies of the initial value. Thus, if FLOATP were given the BINDFN FPLUS, any variable declared FLOATP would be initialized with a new floating box, rather than sharing with that of the original initial value.12 SETFN [Property] is used for performing a SETQ or SETQQ of variables of this type. FN is a function of two arguments, the name of the variable and its new value. A SETFN is typically used to avoid the allocation of storage for intermediate results. Note that the SETFN is not the mechanism for the enforcement of type compatibility, which is checked after the assignment has taken place. Also note that not all functions that can change values are affected: in particular, SET and SETN are not. MANIPULATING NAMED TYPES DECLTYPES is a file package type. Thus all of the operations relating to file package types, e.g., GETDEF, PUTDEF, EDITDEF, DELDEF, SHOWDEF, etc., can be performed on decltypes.13 The file package command, DECLTYPES , is provided to dump named decltypes symbolically. They will be written as a series of DECLTYPE forms that will specify only those fields that differ from the corresponding field of their supertype(s). If the type depends on any unnamed types, those types will be dumped (as a compound type expression), continuing up the supertype chain until a named type is found. Care should be exercised to ensure that enough of the named type context is dumped to allow the type definition to remain meaningful. The functions GETDECLTYPEPROP and SETDECLTYPEPROP, defined analogously to the property list functions for atoms, allow the manipulation of the properties of named types. Setting a property to NIL with SETDECLTYPEPROP removes it from the type. RELATIONS BETWEEN TYPES The notion of equivalence of two types is not well defined. However, type equivalence is rarely of interest. What is of interest is type inclusion, i.e., whether one type is a supertype or subtype of another. The predicate COVERS can be used to determine whether the values of one type include those of another. (COVERS HI LO) [Function] COVERS is T if HI can be found on some (possibly empty) supertype chain of LO; else NIL. Thus, (COVERS 'FIXP (DECLOF 4))= T, even though the DECLTYPE of four is SMALLP, not FIXP. The extremal cases are the obvious identities: (COVERS 'ANY ANYTYPE) = (COVERS ANYTYPE 'NONE) = (COVERS X ) for any type X = T. COVERS allows declaration-based transformations of a form that depend on elements of the form being of a certain type to express their applicability conditions in terms of the weakest type to which they apply, without explicit concern for other types that may be subtypes of it. For example, if a particular transformation is to be applied whenever an element is of type NUMBERP, the program that applies that transformation does not have to check whether the element is of type SMALLP, LARGEP, FIXP, FLOATP, etc., but can simply ask whether NUMBERP COVERS the type of that element. The elementary relations among the types, out of which arbitrary traversals of the type space can be constructed, are made available via: (SUBTYPE TYPE) [Function] Returns the list of types that are immediate subtypes of TYPE. (SUPERTYPES TYPE) [Function] Returns the list of types that are immediate supertypes of TYPE. THE DECLARATION DATA BASE One of the primary uses of type declarations is to provide information that other systems can use to interpret or optimize code. For example, one might choose to write all arithmetic operations in terms of general functions like PLUS and TIMES and then use variable declarations to substitute more efficient, special-purpose code at compile time based on the types of the operands. To this end, a data base of declarations is made available by the Decl package to support these operations. (DECLOF FORM) [Function] Returns the type of FORM in the current declaration context. If FORM is an atom, DECLOF will look up that atom directly in its data base of current declarations. Otherwise, DECLOF will look on the property list of (CAR FORM) for a DECLOF property, as described below. If there is no DECLOF property, DECLOF will check if (CAR FORM) is one of a large set of functions of known result type (e.g., the arithmetic functions). Failing that, if (CAR FORM) has a MACRO property, DECLOF will apply itself to the result of expanding (with EXPANDMACRO), the macro definition. Finally, if FORM is a Lisp program element that DECLOF ŠŠunderstands'' (e.g., a COND, PROG, SELECTQ, etc.), DECLOF applies itself recursively to the part(s) of the contained form which will be returned as value.14 DECLOF [Property] Allows the specification of the type of the values returned by a particular function. The value of the DECLOF property can be either a type, i.e., a type name or a type expression, or a list of the form (FUNCTION FN), where FN is a function object. FN will be applied (by DECLOF) to the form whose CAR has this DECLOF property on its property list. The value of this function application will then be considered to be the type of the form. As an example of how declarations can be used to automatically generate more efficient code, consider an arithmetic package. Declarations of numeric variables could be used to guide code generation to avoid the inefficiencies of Interlisp's handling of arithmetic values. Not only could the generic arithmetic functions be automatically specialized, as suggested above, but by redefining the BINDFN and the SETFN properties for the types FLOATP and LARGEP to reuse storage in the appropriate contexts (i.e., when the new value can be determined to be of the appropriate type), tremendous economies could be realized by not allocating storage to intermediate results that must later be reclaimed by the garbage collector. The Decl package has been used as the basis for several such code optimizing systems. DECLARATIONS AND MASTERSCOPE The Decl package notifies MASTERSCOPE about type declarations and defines a new MASTERSCOPE relation, TYPE, which depends on declarations. Thus, the user can ask questions such as ŠŠWHO USES MUMBLE AS A TYPE?,'' ŠŠ DOES FOO USE FIXP AS A TYPE?,'' and so on. END NOTES 1. USEDIN is mainly for documentation purposes, since there is no way for such a restriction to be enforced. 2. Like USEDIN declarations, FREE and BOUNDIN declarations cannot be checked, and are for documentation purposes only. 3. With this exception, assignments to variables from within the break are not considered to be in the scope of the declarations that were in effect when the break took place and so are not checked. 4. LST is defined as either LISTP or NIL. i.e., a list or NIL. The name LST is used because the name LIST is treated specially by CLISP. A LIST is defined as either NIL or a list of elements each of which is of type LISTP. 5. When a value is tested, the component type tests are applied from left to right. 6. The built-in aggregate types are ARRAP, LISTP, LST, and STRINGP (and their subtypes). 7. As no predefined type has a binding function, this is of no concern until the user defines or redefines a type to have a binding function. 8. Actually, any property can be attached to a type, and will be available for use by user functions via the function GETDECLTYPEPROP. 9. Typically, the TESTFN for a type is derived from its type expression, rather than specified explicitly. The ability to specify the TESTFN is provided for those cases where a predicate is available that is much more efficient than that which would be derived from the type expression. For example, the type SMALLP is defined to have the function SMALLP as its TESTFN, rather than (LAMBDA(DATUM) (AND(NUMBERP DATUM)(FIXP DATUM) (SMALLP DATUM))) as would be derived from the subtype structure. 10. Note that a type's EVERYFN is not used in type tests for that type, but only in type tests for types defined by OF expressions that used this type as the aggregate type. For example, EVERY is not used in defining whether some value satisfies the type LISTP. The Decl package never applies the EVERYFN of a type to a value without first verifying that the value satisfies that type. 11. For a PPROG binding, FN will be applied to no arguments if the initial value is lexically NIL. 12. The BINDFN, if any, associated with a type may be suppressed in a declaration context by creating a subtype with the type-expressing operator SHARED. 13. Deleting a named type could possibly invalidate other type definitions that have the named type as a subtype or supertype. Consequently, the deleted type is simply unnamed and left in the type space as long as it is needed. 14. ŠŠThe current declaration context'' is defined by the environment at the time that DECLOF is called. Code-reading systems, such as the compiler and the interpreter, keep track of the lexical scope within which they are currently operating, in particular, which declarations are in effect. Note that (currently) DECLOF does not have access to any global data base of declarations. For example, DECLOF does not have information available about the types of arguments of, or the value returned by, a particular function, unless it is currently ŠŠinside'' that function. However, the DECLOF property can be used to inform DECLOF of the type of the value returned by a particular function.(LIST ((PAGE NIL (PAPERSIZE LETTER FOLIOINFO (ARABIC "" "") STARTINGPAGE# 52) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE LETTER FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE LETTER FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL)))))2ČČ,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD MODERN +MODERNLOGOMODERN MODERNMODERNMODERN +˙ţTERMINAL˙ţTERMINAL +MODERN +MODERNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN  HRULE.GETFNMODERN   %   Ť  Č 2 Í c +" | ‚ D  +    # *  +0    # Ë  +Ĺ   D  +4 L  +@  +Ô  +ł  + 1   # >  +ß  2 î 0 1   # A  0 1 3 1 * &     +â  +  +‡  +V  +k  +    ˛  %  +   +w I   v Ů  +  +o  + đ  +  +v Ě Ö  $ &  C     Ř $ ! #   N %‚ - ő  +   +Ö 4>  : g <  +; + + + +š  ™  +$Œ +P  +&  +g    +  +  +ť ď +Ö %~  ,  Í   +  +  +Ő  *  a   + ó –  +‹  +° N ť    0 & +       * ¤ & Ž   + T   +    + ż +t + +R +   + +  +  +  +k +ß  +×  +y    +  + Ý  +B 4  +2 é 1 / m   + #  +d K  N  + = +   +  +B  +k  +  +C = c  y  +b   Ń  +x   Ś  +ž 1   F  +  + ˛   ö ‹ + +§   +   +9  +˜ R K Š   + # +  +   + " + +  + î   +   +)  +š  +i  +s  +‚  +Ä   ×  +  +  +ż *   +q x É ă V Z ‘ ‰ ň „ c › ĺ H  +h ™oˆzş \ No newline at end of file diff --git a/lispusers/DEDITHARDCOPY b/lispusers/DEDITHARDCOPY new file mode 100644 index 00000000..fca3d576 --- /dev/null +++ b/lispusers/DEDITHARDCOPY @@ -0,0 +1 @@ +(FILECREATED "28-May-86 09:36:42" {ERIS}KOTO>DEDITHARDCOPY.;2 1082 changes to: (FNS DEDIT-HARDCOPY) (VARS DEDITHARDCOPYCOMS) (ADVICE MAKEEDITW) previous date: "28-May-86 09:32:45" {ERIS}KOTO>DEDITHARDCOPY.;1) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DEDITHARDCOPYCOMS) (RPAQQ DEDITHARDCOPYCOMS ((ADVISE MAKEEDITW) (FNS DEDIT-HARDCOPY))) (PUTPROPS MAKEEDITW READVICE [NIL (AFTER NIL (WINDOWPROP !VALUE (QUOTE HARDCOPYFN) (QUOTE DEDIT-HARDCOPY]) (READVISE MAKEEDITW) (DEFINEQ (DEDIT-HARDCOPY [LAMBDA (WINDOW IMS) (* lmm "28-May-86 09:34") (PRINTOUT IMS .FONT BOLDFONT (WINDOWPROP WINDOW (QUOTE TITLE)) .FONT DEFAULTFONT T T) (PRINTDEF (CAR (WINDOWPROP WINDOW (QUOTE EDITEXPR))) NIL T NIL NIL IMS T]) ) (PUTPROPS DEDITHARDCOPY COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (681 998 (DEDIT-HARDCOPY 691 . 996))))) STOP \ No newline at end of file diff --git a/lispusers/DEFAULTICON b/lispusers/DEFAULTICON new file mode 100644 index 00000000..602fb86e --- /dev/null +++ b/lispusers/DEFAULTICON @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "13-Jan-87 01:23:25" {ERIS}LISPCORE>DEFAULTICON.;1 4586 changes to%: (FNS \MAKEICONWINDOW) previous date%: "19-Dec-85 01:24:06" {ERIS}KOTO>LISPUSERS>DEFAULTICON.;1) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DEFAULTICONCOMS) (RPAQQ DEFAULTICONCOMS ((FILES ICONW) (UGLYVARS \DEFAULTICON) (INITVARS (DEFAULTICON \DEFAULTICON)) (FNS \MAKEICONWINDOW))) (FILESLOAD ICONW) (READVARS \DEFAULTICON) (({(READBITMAP)(64 64 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@AOOOOOOOOOOH@@" "@@N@@@@@@@@@@G@@" "@C@@@@@@@@@@@@L@" "@D@@@@@@@@@@@@B@" "@H@@@@@@@@@@@@A@" "A@@@@@@@@@@@@@@H" "B@@@@@@@@@@@CO@D" "B@@@@@@@@@@@BDHD" "D@@@@@@@@@@@ABDB" "D@@@@@@@@@@@AODB" "D@@@@@@@@@@@ABLB" "D@@@@@@@@@@@ABDA" "H@@@@@@@@@@@ABDA" "H@@@@@@@@@@@AOHA" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "H@@@@@@@@@@@@@@A" "D@@@@@@@@@@@@@@B" "D@@@@@@@@@@@@@@B" "D@@@@@@@@@@@@@@B" "B@@@@@@@@@@@@@@D" "B@@@@@@@@@@@@@@D" "A@@@@@@@@@@@@@@H" "@H@@@@@@@@@@@@A@" "@D@@@@@@@@@@@@B@" "@C@@@@@@@@@@@@L@" "@@N@@@@@@@@@@G@@" "@@AOOOOOOOOOOH@@")} {(READBITMAP)(64 64 "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@" "@@AOOOOOOOOOOH@@" "@@OOOOOOOOOOOO@@" "@COOOOOOOOOOOOL@" "@GOOOOOOOOOOOON@" "@OOOOOOOOOOOOOO@" "AOOOOOOOOOOOOOOH" "COOOOOOOOOOOOOOL" "COOOOOOOOOOONDOL" "GOOOOOOOOOOOOBGN" "GOOOOOOOOOOOOOGN" "GOOOOOOOOOOOOBON" "GOOOOOOOOOOOOBGO" "OOOOOOOOOOOOOBGO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "GOOOOOOOOOOOOOON" "GOOOOOOOOOOOOOON" "GOOOOOOOOOOOOOON" "COOOOOOOOOOOOOOL" "COOOOOOOOOOOOOOL" "AOOOOOOOOOOOOOOH" "@OOOOOOOOOOOOOO@" "@GOOOOOOOOOOOON@" "@COOOOOOOOOOOOL@" "@@OOOOOOOOOOOO@@" "@@AOOOOOOOOOOH@@")} (5 6 52 46))) (RPAQ? DEFAULTICON \DEFAULTICON) (DEFINEQ (\MAKEICONWINDOW [LAMBDA (iconText) (* ; "Edited 13-Jan-87 01:22 by Masinter") (DECLARE (SPECVARS ICONPOSITION WINDOW) (GLOBALVARS DEFAULTICON \DEFAULTICON WindowTitleDisplayStream)) (* ;; "Note: This function has to be compiled for STKNTHNAME to work properly.") (LET ((icon (OR DEFAULTICON \DEFAULTICON))) (SETQ icon (SELECTQ (TYPENAME icon) (BITMAP (CREATEWFROMIMAGE (BITMAPCOPY icon))) (WINDOW (CREATEWFROMIMAGE (WINDOW.BITMAP icon))) (LISTP (TITLEDICONW icon (if (WINDOWP iconText) then (WINDOWPROP iconText 'TITLE) else iconText) WINDOWTITLEFONT (CONSTANT ORIGIN) T)) (ERROR icon "can't be used as an icon"))) [if [AND (NOT ICONPOSITION) (NOT (WINDOWPROP WINDOW 'ICONPOSITION] then (SETQ ICONPOSITION (GETBOXPOSITION (WINDOWPROP icon 'WIDTH) (WINDOWPROP icon 'HEIGHT] icon]) ) (PUTPROPS DEFAULTICON COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3170 4498 (\MAKEICONWINDOW 3180 . 4496))))) STOP \ No newline at end of file diff --git a/lispusers/DEFAULTSUBITEMFN b/lispusers/DEFAULTSUBITEMFN new file mode 100644 index 00000000..e3ad3653 --- /dev/null +++ b/lispusers/DEFAULTSUBITEMFN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 4-Mar-87 15:59:01" {PHYLUM}LYRIC>DEFAULTSUBITEMFN.;1 1299 previous date%: "31-Jan-86 17:45:55" {PHYLUM}KOTO>LISPUSERS>DEFAULTSUBITEMFN.;1) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DEFAULTSUBITEMFNCOMS) (RPAQQ DEFAULTSUBITEMFNCOMS ((* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the subitem menu field) (FNS DEFAULTSUBITEMFN)) ) (* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the subitem menu field) (DEFINEQ (DEFAULTSUBITEMFN (LAMBDA (MENU ITEM) (* edited%: "31-Dec-85 16:41") (* rrb "17-Aug-84 17:24") (* default subitemfn for menus. Checks the fourth element of the item for an expression of the form (SUBITEMS a b c) or if the fourth element is (EVAL form) will return the value of form. MENU and ITEM will be available during the evaluation) (PROG (TEMP) (RETURN (if (AND (LISTP ITEM) (LISTP (SETQ TEMP (CDR ITEM))) (LISTP (SETQ TEMP (CDR TEMP))) (LISTP (SETQ TEMP (CDR TEMP)))) then (SELECTQ (CAR (SETQ TEMP (LISTP (CAR TEMP)))) (SUBITEMS (CDR TEMP)) (EVAL (EVAL (CADR TEMP))) NIL))))) ) ) (PUTPROPS DEFAULTSUBITEMFN COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (606 1206 (DEFAULTSUBITEMFN 616 . 1204))))) STOP \ No newline at end of file diff --git a/lispusers/DEFAULTSUBITEMFN.TEDIT b/lispusers/DEFAULTSUBITEMFN.TEDIT new file mode 100644 index 00000000..5b604f52 Binary files /dev/null and b/lispusers/DEFAULTSUBITEMFN.TEDIT differ diff --git a/lispusers/DEFINERPRINT b/lispusers/DEFINERPRINT new file mode 100644 index 00000000..aee17057 --- /dev/null +++ b/lispusers/DEFINERPRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "13-Apr-88 15:12:02" {ERIS}LISP>DEFINERPRINT.;20 29234 changes to%: (FNS PRINDOTP SUPERPRINT/COMMENT PRINTDEF1) (VARS DEFINERPRINTCOMS) (PROPS (DEFINE-SPECIAL-FORM :DEFINITION-PRINT-TEMPLATE)) (FUNCTIONS XCL::PPRINT-DEFINER) previous date%: "13-Apr-88 13:04:04" {ERIS}LISP>DEFINERPRINT.;19) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DEFINERPRINTCOMS) (RPAQQ DEFINERPRINTCOMS ((FUNCTIONS XCL::PPRINT-DEFINER XCL::PPRINT-DEFINER-FITP XCL::PPRINT-DEFINER-RECURSE) (PROP :DEFINITION-PRINT-TEMPLATE DEFCOMMAND CL:DEFCONSTANT DEFDEFINER DEFGLOBALPARAMETER DEFGLOBALVAR DEFINE-CONDITION CL:DEFINE-MODIFY-MACRO CL:DEFINE-SETF-METHOD DEFINE-SPECIAL-FORM DEFINLINE DEFMACRO CL:DEFPARAMETER CL:DEFSETF CL:DEFSTRUCT CL:DEFTYPE CL:DEFUN CL:DEFVAR) (COMS (* ; "Macros for some things pp handles stupidly") (FNS CODEWRAPPER.PRETTYPRINT PROG1.PRETTYPRINT CASE.PRETTYPRINT PROGV.PRETTYPRINT INDENTATION.FROM.HERE SEQUENTIAL.PRETTYPRINT) (ALISTS (PRETTYPRINTMACROS UNINTERRUPTABLY CL:UNWIND-PROTECT RESETLST CL:BLOCK CL:IF PROG1 CL:WHEN CL:UNLESS WITH-READER-ENVIRONMENT CL:CATCH CASE CL:ECASE CL:ETYPECASE CL:TYPECASE CL:PROGV WITH.MONITOR) (PRETTYEQUIVLST PROG* CL:COMPILER-LET))) (COMS (* ; "Repairs to other prettyprinting functions") (FNS SUPERPRINT/COMMENT PRIN2-LONG-STRING SUPERPRINT/WRAPPER SUPERPRINT/SPACE PRINENDLINE PRINDOTP PRINTDEF1) (ADVISE MAKEFILE) (DECLARE%: EVAL@COMPILE DOCOPY (* ; "Doing this at compile suppresses dwim junk") (P (MOVD? (QUOTE \DSPRETTY/ENDLINE) (QUOTE SUBPRINT/ENDLINE) NIL T))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (CL:PROCLAIM (QUOTE (CL:SPECIAL **COMMENT**FLG *PRINT-SEMICOLON-COMMENTS* COMMENTFONT FNSLST RMARGIN SPACEWIDTH)))) (FILES (LOADCOMP) DSPRINTDEF)) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ; "Backward compatibility, needed in Lyric especially") (P (MOVD (QUOTE XCL::PPRINT-DEFINER) (QUOTE PPRINT-DEFINER) NIL T)))) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) DEFINERPRINT))) (CL:DEFUN XCL::PPRINT-DEFINER (XCL::DEFINE-EXPRESSION) (DECLARE (CL:SPECIAL FORMFLG SPACEWIDTH)) (* ; "Bound in prettyprinter") (COND ((OR (NULL FORMFLG) (CL:ATOM (CDR XCL::DEFINE-EXPRESSION))) (* ; "Degenerate cases or printing as a quoted form--punt to default prettyprinting") XCL::DEFINE-EXPRESSION) (T (LET ((TAIL XCL::DEFINE-EXPRESSION) (LEFT (DSPXPOSITION)) XCL::TEMPLATE XCL::TOP-LEVEL-P XCL::NEXT TYPE XCL::FORM XCL::NEWLINEP) (DECLARE (CL:SPECIAL TAIL LEFT)) (* ; "For comment printer") (CL:SETQ XCL::TOP-LEVEL-P (EQ LEFT (DSPLEFTMARGIN))) (* ; "Printing definition to file, etc.") (CL:SETQ LEFT (+ LEFT (CL:* 3 SPACEWIDTH))) (* ; "Place we will indent body") (PRIN1 "(") (PRIN2 (CAR TAIL)) (CL:SETQ XCL::TEMPLATE (OR (GET (CL:POP TAIL) :DEFINITION-PRINT-TEMPLATE) (QUOTE (:NAME)))) (* ;; "This code should, and doesn't, pay attention to the NAME function to determine where the name is to decide what should and shouldn't be bold. Right now, it always bolds the second thing. Fortunately, we currently don't have any definers that don't have either the second or CAR of the second as the definition name.") (* ;; "Also, this code should be careful about calling the NAME function on the form. Sometimes, the form is not really a call to the definer but instead a back-quoted expression in a macro. In most such cases, the name is not really there; some comma-quoted expression is there instead.") (WHILE (CL:CONSP TAIL) DO (COND ((AND (CL:LISTP (CL:SETQ XCL::NEXT (CAR TAIL))) (EQ (CAR XCL::NEXT) COMMENTFLG) (SEMI-COLON-COMMENT-P XCL::NEXT)) (* ; "Comments can appear anywhere, so print this one without consuming the template. ENDLINE has side effect of printing comments") (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*) (CL:SETQ XCL::NEWLINEP T)) ((OR (CL:ATOM XCL::TEMPLATE) (EQ (CL:SETQ TYPE (CL:POP XCL::TEMPLATE)) :BODY)) (* ; "Once we hit the body, there's nothing more special to do.") (RETURN)) (T (SPACES 1) (CASE TYPE (:NAME (* ; "Embolden the name of this thing") (CL:SETQ XCL::NEWLINEP NIL) (COND ((NOT XCL::TOP-LEVEL-P) (* ; "Nothing special here--could even be a backquoted thing") (XCL::PPRINT-DEFINER-RECURSE)) (T (CL:POP TAIL) (COND ((CL:CONSP XCL::NEXT) (* ; "Name is a list. Assume the real name is the car and the rest is an options list or something") (CL:UNLESS (EQ (DSPYPOSITION) (PROGN (PRIN1 "(") (PRINTOUT NIL .FONT LAMBDAFONT |.P2| (CAR XCL::NEXT) .FONT DEFAULTFONT) (SPACES 1) (PRINTDEF (CDR XCL::NEXT) T T T FNSLST) (PRIN1 ")") (DSPYPOSITION))) (* ; "This thing took more than one line to print, so go to new line") (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*) (CL:SETQ XCL::NEWLINEP T))) (T (* ; "Atomic name is bold") (PRINTOUT NIL .FONT LAMBDAFONT |.P2| XCL::NEXT .FONT DEFAULTFONT)))))) (:ARG-LIST (* ; "NEXT is some sort of argument list. ") (COND ((NULL XCL::NEXT) (* ; "If NIL, be sure to print as ()") (PRIN1 "()") (CL:POP TAIL)) (T (XCL::PPRINT-DEFINER-RECURSE))) (CL:SETQ XCL::NEWLINEP NIL)) (T (* ; "Just print it, perhaps starting a new line") (CL:UNLESS (OR XCL::NEWLINEP (XCL::PPRINT-DEFINER-FITP XCL::NEXT)) (* ; "Go to new line if getting crowded") (PRINENDLINE LEFT)) (XCL::PPRINT-DEFINER-RECURSE) (CL:SETQ XCL::NEWLINEP NIL)))))) (* ;; "We've now gotten to the end of stuff we know how to print. Just prettyprint the rest") (CL:UNLESS (NULL TAIL) (COND (XCL::NEWLINEP (* ; "Already on new line")) ((OR (EQ TYPE :BODY) (NOT (XCL::PPRINT-DEFINER-FITP (CAR TAIL)))) (* ; "Go to new line and indent a bit. Always do this for the part matching &BODY, whether or not the prettyprinter thought that the remainder would %"fit%"") (PRINENDLINE LEFT NIL T)) (T (SPACES 1))) (WHILE (AND (CL:CONSP TAIL) (CL:ATOM (CL:SETQ XCL::FORM (CAR TAIL)))) DO (* ;; "Print this doc string or whatever on its own line. This is because otherwise the prettyprinter gets confused and tries to put the next thing after the string") (XCL::PPRINT-DEFINER-RECURSE) (CL:WHEN (AND (CL:KEYWORDP XCL::FORM) (CL:CONSP TAIL)) (* ; "Some sort of keyword-value pair stuff--print it on same line") (SPACES 1) (XCL::PPRINT-DEFINER-RECURSE)) (CL:WHEN (NULL TAIL) (RETURN)) (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*)) (PRINTDEF TAIL T T T FNSLST)) (PRIN1 ")") NIL)))) (CL:DEFUN XCL::PPRINT-DEFINER-FITP (XCL::ITEM) (* ;; "True if it won't look silly to try to print ITEM at current position instead of starting new line") (CL:IF (CL:CONSP XCL::ITEM) (OR (EQ (CAR XCL::ITEM) COMMENTFLG) (AND (< (COUNT XCL::ITEM) 20) (FITP XCL::ITEM))) (< (+ (DSPXPOSITION) (STRINGWIDTH XCL::ITEM *STANDARD-OUTPUT*)) (DSPRIGHTMARGIN)))) (CL:DEFUN XCL::PPRINT-DEFINER-RECURSE NIL (* ;; "Print and pop the next element. Prettyprinter uses the variable IL:TAIL for lookahead") (DECLARE (CL:SPECIAL TAIL)) (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*) (CL:SETQ TAIL (CDR TAIL))) (PUTPROPS DEFCOMMAND :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS CL:DEFCONSTANT :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE)) (PUTPROPS DEFDEFINER :DEFINITION-PRINT-TEMPLATE (:NAME :TYPE :ARG-LIST :BODY)) (PUTPROPS DEFGLOBALPARAMETER :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE)) (PUTPROPS DEFGLOBALVAR :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE)) (PUTPROPS DEFINE-CONDITION :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE :BODY)) (PUTPROPS CL:DEFINE-MODIFY-MACRO :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST)) (PUTPROPS CL:DEFINE-SETF-METHOD :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS DEFINE-SPECIAL-FORM :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS DEFINLINE :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS DEFMACRO :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS CL:DEFPARAMETER :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE)) (PUTPROPS CL:DEFSETF :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :ARG-LIST :BODY)) (PUTPROPS CL:DEFSTRUCT :DEFINITION-PRINT-TEMPLATE (:NAME :BODY)) (PUTPROPS CL:DEFTYPE :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS CL:DEFUN :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY)) (PUTPROPS CL:DEFVAR :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE)) (* ; "Macros for some things pp handles stupidly") (DEFINEQ (CODEWRAPPER.PRETTYPRINT (LAMBDA (FORM) (* ; "Edited 30-Mar-88 11:44 by bvm") (* ;; "Prettyprints things that wrap code like PROGN. We usually want them to start the code on the next line, rather than put the first expression way to the right of all the rest.") (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE))) (PRIN2 (pop FORM)) (* ; "Print the %"function%" itself") (if (NLISTP FORM) then (* ; "Ignore degenerate cases") (PRINTDEF FORM T T T FNSLST) else (SEQUENTIAL.PRETTYPRINT FORM HERE)) (PRIN1 ")") NIL)) ) (PROG1.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 30-Mar-88 12:02 by bvm") (* ;; "Prettyprinter advice for PROG1, CL:IF, UNLESS, etc. Default way's main problem is that if the first expression is a non-list but some later expression is a list, it doesn't put ALL the subsequent expressions equally indented. Thus, you get something like (PROG1 A (expression) (expression) ...)") (if (OR (NLISTP (CDR (LISTP (CDR EXPR)))) (AND (NLISTP (CDDDR EXPR)) (for E in (LISTP (CADDR EXPR)) never (LISTP E)))) then (* ; "2 or fewer elements, or 3 elements, the last of which is very simple--let default prettyprinter do it") EXPR else (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE)) (LEFT (PROGN (PRIN2 (pop EXPR)) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION)))) (DECLARE (SPECVARS LEFT)) (if (OR (if (>= HERE LEFT) then (* ; "Default indentation wants to be greater than the function length, so change it to here") (SETQ HERE LEFT)) (NLISTP (CAR EXPR)) (FITP (CAR EXPR) NIL NIL NIL *STANDARD-OUTPUT*)) then (SUPERPRINT (CAR EXPR) EXPR NIL *STANDARD-OUTPUT*) (* ; "Print the first element right at this position") (pop EXPR)) (SEQUENTIAL.PRETTYPRINT EXPR HERE)) (PRIN1 ")") (* ; "Return NIL to say we handled it") NIL)) ) (CASE.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 30-Mar-88 16:54 by bvm") (if (NLISTP (CDR EXPR)) then (* ; "Degenerate case--punt") EXPR else (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE)) (LEFT (PROGN (PRIN2 (pop EXPR)) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION))) (TAIL EXPR) INNERLEFT CASE) (DECLARE (SPECVARS LEFT TAIL)) (if (OR (if (>= HERE LEFT) then (* ; "Default indentation wants to be greater than the function length, so change it to here") (SETQ HERE LEFT)) (NLISTP (CAR TAIL)) (FITP (CAR TAIL) NIL NIL NIL *STANDARD-OUTPUT*)) then (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*) (* ; "Print the first element right at this position") (pop TAIL)) (SETQ INNERLEFT (+ (SETQ LEFT HERE) (TIMES 3 (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)))) (do (if (NLISTP TAIL) then (if TAIL then (* ; "dotted tail?") (PRINENDLINE LEFT *STANDARD-OUTPUT*) (PRINTDEF TAIL T T T)) (PRIN1 ")") (RETURN NIL) elseif (SEMI-COLON-COMMENT-P (LISTP (CAR TAIL))) then (* ; "Print any comments stuck in between elements") (SUPERPRINT/COMMENT (CAR TAIL) *STANDARD-OUTPUT*) (pop TAIL) else (* ; "Start new line, after printing any comments") (PRINENDLINE LEFT *STANDARD-OUTPUT*) (if (NLISTP (SETQ CASE (CAR TAIL))) then (* ; "degenerate case?") (PRIN2 CASE) else (PRIN1 "(") (LET (FORMFLG) (DECLARE (SPECVARS FORMFLG)) (* ; "Print the key(s) as data") (SUPERPRINT (CAR CASE) CASE NIL *STANDARD-OUTPUT*) (SPACES 1)) (if (NLISTP (SETQ CASE (CDR CASE))) then (* ; "No tail, but handle degenerates") (PRINTDEF CASE T T T) else (SEQUENTIAL.PRETTYPRINT CASE (LET ((HERE (DSPXPOSITION))) (if (OR (<= HERE INNERLEFT) (AND (NULL (CDR CASE)) (if (LISTP (CDR CASE)) then (* ; "Multiple things to print") NIL elseif (NLISTP (CAR CASE)) then (* ; "Print simple consequent if space") (< (STRINGWIDTH (CAR CASE) *STANDARD-OUTPUT* T) (- (DSPRIGHTMARGIN) HERE)) else (FITP CASE T NIL NIL *STANDARD-OUTPUT*)))) then (* ; "Key didn't go too far over, so just prettyprint from here") HERE else INNERLEFT)))) (PRIN1 ")")) (pop TAIL)))))) ) (PROGV.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 31-Mar-88 11:30 by bvm") (* ;; "Prettyprinter advice for PROGV. Default way's main problem is that if the vars and values are non-lists the %"body%" of the form doesn't get uniformly indented. Thus, you get something like (PROGV vars values (expression) (expression) ...)") (if (OR (NLISTP (CDR EXPR)) (LISTP (CADR EXPR)) (NLISTP (CDR (LISTP (CDDR EXPR))))) then (* ; "3 or fewer elements, or the second is a list--default prettyprinter will do fine") EXPR else (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE)) (LEFT (PROGN (PRIN2 (pop EXPR)) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION)))) (DECLARE (SPECVARS LEFT)) (SUPERPRINT (CAR EXPR) EXPR NIL *STANDARD-OUTPUT*) (* ; "Print the first element (vars) at this position") (pop EXPR) (if (XCL::PPRINT-DEFINER-FITP (CAR EXPR)) then (SPACES 1) (* ; "Room for next element (values) here") (SUPERPRINT (CAR EXPR) EXPR NIL *STANDARD-OUTPUT*) (pop EXPR)) (* ; "Finally, print the body") (SEQUENTIAL.PRETTYPRINT EXPR HERE)) (PRIN1 ")") (* ; "Return NIL to say we handled it") NIL)) ) (INDENTATION.FROM.HERE (LAMBDA NIL (* ; "Edited 28-Mar-88 18:17 by bvm") (* ;; "Returns X-pos about 3 chars over, for use in indenting code") (+ (DSPXPOSITION) (TIMES 3 (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)))) ) (SEQUENTIAL.PRETTYPRINT (LAMBDA (TAIL LEFT) (* ; "Edited 1-Apr-88 14:12 by bvm") (DECLARE (SPECVARS TAIL LEFT)) (* ;; "Print each element of tail indented at position LEFT.") (PROG NIL (if (<= (DSPXPOSITION) LEFT) then (* ; "Don't start with newline if we aren't to the right of the left margin") (GO MIDDLE)) TOP (if (OR (NULL TAIL) (PROGN (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*) (NULL TAIL))) then (* ; "Done") (RETURN)) MIDDLE (if (NLISTP TAIL) then (* ; "Degenerate tail") (RETURN (PRINTDEF TAIL T T T))) (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*) (pop TAIL) (GO TOP))) ) ) (ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY . CODEWRAPPER.PRETTYPRINT) (CL:UNWIND-PROTECT . CODEWRAPPER.PRETTYPRINT) (RESETLST . CODEWRAPPER.PRETTYPRINT) (CL:BLOCK . PROG1.PRETTYPRINT) (CL:IF . PROG1.PRETTYPRINT) (PROG1 . PROG1.PRETTYPRINT) (CL:WHEN . PROG1.PRETTYPRINT) (CL:UNLESS . PROG1.PRETTYPRINT) (WITH-READER-ENVIRONMENT . PROG1.PRETTYPRINT) (CL:CATCH . PROG1.PRETTYPRINT) (CASE . CASE.PRETTYPRINT) (CL:ECASE . CASE.PRETTYPRINT) (CL:ETYPECASE . CASE.PRETTYPRINT) (CL:TYPECASE . CASE.PRETTYPRINT) (CL:PROGV . PROGV.PRETTYPRINT) (WITH.MONITOR . PROG1.PRETTYPRINT)) (ADDTOVAR PRETTYEQUIVLST (PROG* . PROG) (CL:COMPILER-LET . LET)) (* ; "Repairs to other prettyprinting functions") (DEFINEQ (SUPERPRINT/COMMENT (LAMBDA (L FILE) (* ; "Edited 13-Apr-88 12:55 by bvm") (DECLARE (USEDFREE LEFT TAIL RMARGIN FILEFLG MAKEMAP)) (COND ((AND **COMMENT**FLG (NOT FILEFLG) (NOT MAKEMAP)) (* ;; "If we're eliding comments, not printing to a file, and not in DEdit, then just print the elision string") (COND ((> (+ (DSPXPOSITION NIL FILE) (STRINGWIDTH **COMMENT**FLG FILE)) (DSPRIGHTMARGIN NIL FILE)) (* ; "Watch out for overflowing the current line.") (PRINENDLINE (DSPLEFTMARGIN NIL FILE) FILE))) (PRIN1S **COMMENT**FLG NIL FILE)) (T (PROG ((DSLMARG (DSPLEFTMARGIN NIL FILE)) (HERE (DSPXPOSITION NIL FILE)) (COMMENT-RMARGIN RMARGIN) (SEMIP (SEMI-COLON-COMMENT-P L)) COMMENT-LMARGIN RIGHTFLG BODY HALFLINE) (if SEMIP then (* ; "Extract the comment body") (COND ((OR (NOT (STRINGP (SETQ BODY (CAR (LISTP (CDR (LISTP (CDR L)))))))) (CDDDR L)) (* ; "Not a good semi-colon comment") (SETQ SEMIP NIL)))) (COND ((SETQ RIGHTFLG (if SEMIP then (* ; "Only 1-semi comments go in right margin") (EQ SEMIP 1) else (* ; "Short single * comments go at right") (AND (NOT (SUPERPRINTEQ (CADR L) COMMENTFLG)) (<= (LENGTH L) 15)))) (* ; "Print comment in the righthand margin") (SETQ COMMENT-LMARGIN (OR COMMENTCOL (SUPERPRINT/COMMENT1 L RMARGIN FILE)))) ((AND SEMIP (NOT MAKEMAP)) (* ; "Semi-colon comment > 1, unless under DEdit (lest we confuse it)") (AND SEMIP (> SEMIP 2) (NOT MAKEMAP)) (SETQ COMMENT-LMARGIN (if (EQ SEMIP 2) then (* ; "indent like code, but no more than a third of the way over if it would take more than 2 lines to print this.") (MIN LEFT (MAX (- RMARGIN (FIXR (TIMES (STRINGWIDTH BODY FILE) 0.52))) (+ DSLMARG (IQUOTIENT (- RMARGIN DSLMARG) 3)))) else (* ; "Comment should be printed flush left.") DSLMARG))) (T (LET ((INDENT (IQUOTIENT (- RMARGIN DSLMARG) 11))) (* ; "Print old-style comment centered and wide, indented about 10%% from margins") (SETQ COMMENT-LMARGIN (+ DSLMARG INDENT)) (SETQ COMMENT-RMARGIN (- RMARGIN INDENT)) (COND ((EQ HERE COMMENT-LMARGIN) (* ;; "HACK: Almost certainly called from REPP, so we must supress the normal leading and trailing blank lines as they have already been done") (SETQ RIGHTFLG T)))))) (COND ((AND (NULL RIGHTFLG) (OR (NOT SEMIP) (> SEMIP 1))) (* ; "Centered comment starts on new line") (if (> HERE COMMENT-LMARGIN) then (* ; "We have not yet moved down a line, so do that first") (TERPRI FILE)) (if (AND (EQ SEMIP 2) (IMAGESTREAMP FILE)) then (* ; "For 2-semi comments, only go down half line, accomplished by moving up half line now before this next endline") (RELMOVETO 0 (SETQ HALFLINE (IQUOTIENT (- (DSPLINEFEED NIL FILE)) 2)))) (PRINENDLINE COMMENT-LMARGIN FILE)) ((< COMMENT-LMARGIN (DSPXPOSITION NIL FILE)) (* ; "Past the starting point, so start new line") (PRINENDLINE COMMENT-LMARGIN FILE)) (T (DSPXPOSITION COMMENT-LMARGIN FILE))) (SETFONT (PROG1 (SETFONT COMMENTFONT FILE) (COND ((AND SEMIP (NOT MAKEMAP) (OR *PRINT-SEMICOLON-COMMENTS* (IMAGESTREAMP FILE))) (* ; "do nice semi-colon stuff") (PRIN2-LONG-STRING BODY FILE NIL NIL COMMENT-LMARGIN COMMENT-RMARGIN T SEMIP)) (T (* ; "Old comment or in DEdit (makemap true), so have to do it the old way") (SETQ SEMIP NIL) (SUPERPRINT/COMMENT2 L COMMENT-LMARGIN (IQUOTIENT (+ COMMENT-LMARGIN COMMENT-RMARGIN) 2) COMMENT-RMARGIN FILE)))) FILE) (if (OR (NULL SEMIP) (> SEMIP 2)) then (* ; "Old centered comments and big semi-colon comments get new line") (OR RIGHTFLG (PRINENDLINE DSLMARG FILE)) elseif (NULL (CDR TAIL)) then (* ; "Nothing more will be printed. So even though we were a short comment, we need to go to new line so that the closing paren is on a new line, rather than here after the comment (AR 8475)") (PRINENDLINE LEFT FILE) elseif (AND HALFLINE (NOT (AND (LISTP (CDR TAIL)) (SEMI-COLON-COMMENT-P (LISTP (CADR TAIL)))))) then (* ; "Set off double-semi-colon comment by half line. Don't do for consecutive comments, since the next comment will take care of it") (RELMOVETO 0 HALFLINE) (PRINENDLINE DSLMARG FILE)) (RETURN L))))) ) (PRIN2-LONG-STRING (LAMBDA (STRING STREAM P2FLG TAIL LMARG RMARG COMMENTP USE-SEMI-COLONS) (* ; "Edited 4-Apr-88 14:26 by bvm") (* ;; "Fancy string printer that divides long strings into multiple lines at convenient breaks. If P2FLG is true, this is a call from PRIN2 or friend, in which case the surrounding doublequotes are printed, as well as escapes in front of special chars. TAIL is the list car of which is STRING. LMARG and RMARG specify the desired margins of the text. If COMMENTP is true, this is a comment. In addition, if USE-SEMI-COLONS is non-NIL, this is a semi-colon comment with that many semis.") (PROG ((ESC (fetch (READTABLEP ESCAPECHAR) of *READTABLE*)) (SA (fetch (READTABLEP READSA) of *READTABLE*)) (HERE (DSPXPOSITION NIL STREAM)) (FONT (DSPFONT NIL STREAM)) (IMSTREAMP (IMAGESTREAMP STREAM)) ESCWIDTH SPACEWIDTH CLOSEWIDTH SEMIWIDTH LASTSPACE I C NEXTC POS J MAPX1 MAPY1 SINGLELEFT SEMISTRING ESCAPESEPRS SEMICLOSE) (COND ((NOT (type? FONTDESCRIPTOR FONT)) (* ; "Ugh, happens for files") (SETQ FONT STREAM))) (SETQ ESCWIDTH (CHARWIDTH ESC FONT)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) FONT)) (SETQ CLOSEWIDTH (COND (P2FLG (STRINGWIDTH "%")" FONT)) (T 0))) (if USE-SEMI-COLONS then (if (< USE-SEMI-COLONS 5) then (* ; "Semicolon comment") (SETQ SEMIWIDTH (+ SPACEWIDTH (TIMES USE-SEMI-COLONS (CHARWIDTH (CHARCODE ";") FONT)))) (SETQ SEMISTRING (CONCAT (ALLOCSTRING USE-SEMI-COLONS (CHARCODE ";")) " ")) else (* ; "Balanced (hash bar) comment") (SETQ SEMISTRING "#|") (SETQ SEMIWIDTH (STRINGWIDTH SEMISTRING FONT)) (SETQ SEMICLOSE "|#"))) (COND ((for C instring (PROGN (* ; "dwimify bug tries to turn naked STRING into (STRING C) here.") STRING) as I from 1 bind (POS _ (+ HERE (COND (P2FLG (CHARWIDTH (CHARCODE %") FONT)) ((NULL USE-SEMI-COLONS) 0) ((< USE-SEMI-COLONS 5) SEMIWIDTH) (T (* ; "Include the width of the closing |#") (TIMES 2 SEMIWIDTH))) CLOSEWIDTH)) do (COND ((EQ C (CHARCODE CR)) (* ; "Always want to print these strings specially") (SETQ LASTSPACE I) (RETURN NIL)) ((AND P2FLG (OR (EQ C (CHARCODE %")) (EQ C ESC))) (* ; "Need escape") (add POS ESCWIDTH))) (COND ((> (add POS (CHARWIDTH C FONT)) RMARG) (RETURN NIL))) (COND ((EQ C (CHARCODE SPACE)) (SETQ LASTSPACE I))) finally (RETURN T)) (* ; "It all fits on this line") (RETURN (COND (P2FLG (PRIN2S STRING TAIL STREAM)) (T (if SEMISTRING then (PRIN1 SEMISTRING STREAM)) (PRIN1S STRING TAIL STREAM) (if SEMICLOSE then (PRIN1 SEMICLOSE STREAM))))))) (COND ((OR (NULL LASTSPACE) (AND (NULL COMMENTP) (NEQ HERE LMARG))) (* ;; "Can't print anything on this line before the end. Comments are allowed to have different first and subsequent margin.") (PRINENDLINE (SETQ HERE LMARG) STREAM) (SETQ LASTSPACE 0))) (COND (MAKEMAP (* ; "Note start") (SETQ MAPX1 HERE) (SETQ MAPY1 (DSPYPOSITION NIL STREAM)) (SETQ SINGLELEFT (EQ HERE LMARG)))) (COND (P2FLG (COND ((NOT (IMAGESTREAMP STREAM)) (* ; "Need to be able to read it back") (SETQ ESCAPESEPRS T) (LET ((HASH (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))) (\OUTCHAR STREAM HASH) (add HERE (CHARWIDTH HASH FONT))))) (\OUTCHAR STREAM (CHARCODE %")) (add HERE (CHARWIDTH (CHARCODE %") FONT))) (USE-SEMI-COLONS (* ; "Print the first set of semi-colons or #|") (PRIN1 SEMISTRING STREAM) (add HERE SEMIWIDTH) (if (EQ USE-SEMI-COLONS 5) then (* ; "No more semis now") (SETQ SEMISTRING NIL)))) (* ;;; "Now loop, printing as much as we can while there's room") (SETQ I 0) LP (COND ((NULL (SETQ C (NTHCHARCODE STRING (add I 1)))) (* ; "Done") (GO DONE)) ((NOT (< I LASTSPACE)) (* ;; "Must find the next safe place to print up to. LASTSPACE is either a space or CR position, or is 0, which is our state when printing from the left margin until we encounter a space.") (SETQ POS HERE) (SETQ J I) (* ; "Ordinarily, J is pointing at a space or CR except when we have just printed an endline") (SELCHARQ C (SPACE (* ; "Would like all spaces before the eol, where they're invisible, not after") (SELCHARQ (NTHCHARCODE STRING (ADD1 J)) ((SPACE CR NIL) (SETQ LASTSPACE (ADD1 J)) (* ; "Go ahead and print this space, and note that it is now okay to break the line") (COND ((AND (>= (+ HERE SPACEWIDTH) RMARG) (NOT ESCAPESEPRS)) (* ; "Extra spaces have no effect, so don't print them at all, lest the dsprightmargin bite") (GO LP)) (T (GO PRINTIT)))) NIL) (add POS SPACEWIDTH)) (CR (* ; "If two cr's in a row, print them all; if only one, must escape it") (COND ((EQ (SETQ C (NTHCHARCODE STRING (add I 1))) (CHARCODE CR)) (PRINENDLINE LMARG STREAM) (while (EQ (SETQ C (NTHCHARCODE STRING (add I 1))) (CHARCODE CR)) do (PRINENDLINE LMARG STREAM))) (ESCAPESEPRS (\OUTCHAR STREAM ESC))) (SETQ LASTSPACE 0) (GO ENDLINE)) (PROGN (* ;; "Gets set this way at left edge. Must print something on this line, even if there are no spaces before the right edge") (GO CHECKESCAPE))) (SETQ LASTSPACE 0) (while (< POS RMARG) do (SELCHARQ (SETQ NEXTC (NTHCHARCODE STRING (add J 1))) ((CR SPACE) (* ; "Can safely go this far") (SETQ LASTSPACE J) (RETURN)) (NIL (* ; "End of string -- ok if there is space for closing quote and paren as well") (COND ((< (+ POS CLOSEWIDTH) RMARG) (SETQ LASTSPACE J) (RETURN)) (T (GO $$OUT)))) NIL) (COND ((OR (EQ NEXTC (CHARCODE %")) (EQ NEXTC ESC)) (add POS ESCWIDTH))) (add POS (CHARWIDTH NEXTC FONT)) finally (COND ((EQ LASTSPACE 0) (* ; "Need break") (COND ((EQ C (CHARCODE SPACE)) (* ; "Will turn this space into CR") (SETQ C (NTHCHARCODE STRING (add I 1)))) (T (SHOULDNT))) (GO ENDLINE)))))) CHECKESCAPE (COND ((AND P2FLG (OR (EQ C (CHARCODE %")) (EQ C ESC))) (\OUTCHAR STREAM ESC) (add HERE ESCWIDTH))) PRINTIT (\OUTCHAR STREAM C) (add HERE (CHARWIDTH C FONT)) (GO LP) ENDLINE (PRINENDLINE LMARG STREAM) (SETQ HERE LMARG) (COND ((NULL C) (* ; "Done") (GO DONE)) ((AND ESCAPESEPRS (EQ (\SYNCODE SA C) SEPRCHAR.RC)) (* ; "Have to quote sepr immediately following CR") (\OUTCHAR STREAM ESC) (add HERE ESCWIDTH) (GO PRINTIT)) (T (COND (SEMISTRING (PRIN1 SEMISTRING STREAM) (add HERE SEMIWIDTH))) (GO CHECKESCAPE))) DONE (COND (P2FLG (\OUTCHAR STREAM (CHARCODE %")))) (COND (MAKEMAP (LET ((ENTRY (MAKEMAPENTRY TAIL (AND (NEQ MAKEMAP T) MAKEMAP) MAPX1 MAPY1 (DSPXPOSITION NIL STREAM) (DSPYPOSITION NIL STREAM) (\DEDITFONT# STREAM)))) (replace LONGSTRINGP of ENTRY with T) (COND (SINGLELEFT (replace LONGSTRING1MARGINP of ENTRY with T))) (COND ((EQ (- (DSPRIGHTMARGIN NIL STREAM) LMARG) RMARG) (* ;; "Assume that RMARG not equal to stream's right margin only happens for centered comments. In reality, it happens as well inside REPP, where RESETCLIP hides the true right margin.") (replace LONGSTRINGSYMMETRICP of ENTRY with T))))) (SEMICLOSE (PRIN1 SEMICLOSE STREAM))) (RETURN))) ) (SUPERPRINT/WRAPPER (LAMBDA (MACRO E TAIL BRFLG FILE) (* ; "Edited 31-Mar-88 12:00 by bvm") (* ;;; "Print E as MACRO followed by (CADR E), for example, print (QUOTE foo) as 'foo") (PRINOPEN TAIL MACRO FILE) (* ; "Print the prefix") (COND (MAKEMAP (* ;; "Need to fool DEDIT into thinking that it is printing the whole list E when only (CADR E) appears in print. So do a fake entry for (CAR E) whose width is zero") (replace WRAPPER of MAKEMAP with MACRO) (* ; "MAKEMAP is the entry for E -- want everyone to know it wasn't printed as normal list") (LET ((X (DSPXPOSITION NIL FILE)) (Y (DSPYPOSITION NIL FILE))) (MAKEMAPENTRY E (AND (NEQ MAKEMAP T) MAKEMAP) X Y X Y (\DEDITFONT# FILE))))) (PROG1 (SUPERPRINT (CADR E) (CDR E) BRFLG FILE) (* ; "Make sure to return the result of SUPERPRINT, so that caller (eventually SUBPRINT) knows whether we printed something like a list or not") (PRINSHUT TAIL NIL FILE) (* ; "Finally, print a vacuous closing paren"))) ) (SUPERPRINT/SPACE (LAMBDA (FILE) (* ; "Edited 31-Mar-88 12:18 by bvm") (* ;; "Print a space, preparing for next item to be printed") (DECLARE (CL:SPECIAL RMARGIN SPACEWIDTH LEFT)) (* ; "bound by prettyprinter stuff") (if (< (- RMARGIN (DSPXPOSITION NIL FILE)) (TIMES 2 SPACEWIDTH)) then (* ; "printing a space will overflow the line, or if not then the next char would, so go to new line") (PRINENDLINE LEFT FILE) else (PRIN3 " " FILE))) ) (PRINENDLINE (LAMBDA (NEWXPOSITION FILE) (* ; "Edited 1-Apr-88 14:24 by bvm") (* ;; "Terminate line, setting x at NEWXPOSITION.") (OR FILE (SETQ FILE *STANDARD-OUTPUT*)) (COND (MAKEMAP (* ; "From DEdit") (MOVETO NEWXPOSITION (+ (DSPYPOSITION NIL FILE) (DSPLINEFEED NIL FILE)) FILE)) (T (TERPRI FILE) (COND ((OR (SELECTQ (IMAGESTREAMTYPE FILE) ((NIL TEXT) (* ; "These don't know how to set x position") T) (PROGN (* ; "Assume all other image streams are ok") NIL)) (if (EQ FILE (TTYDISPLAYSTREAM)) then (* ; "Even if FILE knows how to set xpos, the dribble file doesn't, so use spaces") (DRIBBLEFILE))) (SETFONT (PROG1 (SETFONT DEFAULTFONT FILE) (* ;; "Print introductory spaces in the default font because we don't quite have this right yet for pspool files") (LET ((NS (QUOTIENT (- NEWXPOSITION (DSPXPOSITION NIL FILE)) SPACEWIDTH))) (RPTQ (QUOTIENT NS 8) (PRIN3 " " FILE)) (RPTQ (REMAINDER NS 8) (PRIN3 " " FILE)))) FILE))) (DSPXPOSITION NEWXPOSITION FILE)))) ) (PRINDOTP (LAMBDA (E FILE) (* ; "Edited 13-Apr-88 15:08 by bvm") (* ;; "Print a dotted tail consisting of the non-list E, i.e., print %" . %"") (LET* ((DOT " . ") (MAXPOS (- RMARGIN (WIDTH E FILE T) (WIDTH DOT FILE) (WIDTH ")" FILE)))) (* ; "MAXPOS is the rightmost position at which this will fit") (if (AND (> (DSPXPOSITION NIL FILE) MAXPOS) (>= MAXPOS FIRSTPOS)) then (* ; "Print dotted tail on next line as far to right as possible") (PRINENDLINE MAXPOS FILE)) (PRIN3 DOT FILE) (PRIN2S E (COND (MAKEMAP (MAKEDOTPTAIL E MAKEMAP)) (T (CONS E E))) FILE))) ) (PRINTDEF1 (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 10:54 by bvm") (* ;; "Used by MAKEFILE to print P, etc expressions. These are at top level, so must be forms! But still print BLOCK: as a var to make it prettier") (TERPRI) (PRINTDEF EXPR NIL (NEQ (CAR EXPR) (QUOTE BLOCK%:)) NIL FNSLST) (TERPRI)) ) ) (XCL:REINSTALL-ADVICE (QUOTE MAKEFILE) :AROUND (QUOTE ((:LAST (LET ((PRETTYFLG (AND (NOT (MEMB (QUOTE FAST) OPTIONS)) PRETTYFLG))) (DECLARE (CL:SPECIAL PRETTYFLG)) *))))) (READVISE MAKEFILE) (DECLARE%: EVAL@COMPILE DOCOPY (MOVD? (QUOTE \DSPRETTY/ENDLINE) (QUOTE SUBPRINT/ENDLINE) NIL T) ) (DECLARE%: EVAL@COMPILE DONTCOPY (CL:PROCLAIM (QUOTE (CL:SPECIAL **COMMENT**FLG *PRINT-SEMICOLON-COMMENTS* COMMENTFONT FNSLST RMARGIN SPACEWIDTH))) (FILESLOAD (LOADCOMP) DSPRINTDEF) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD (QUOTE XCL::PPRINT-DEFINER) (QUOTE PPRINT-DEFINER) NIL T) ) (PUTPROPS DEFINERPRINT FILETYPE :COMPILE-FILE) (PUTPROPS DEFINERPRINT MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (PUTPROPS DEFINERPRINT COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8172 13865 (CODEWRAPPER.PRETTYPRINT 8182 . 8700) (PROG1.PRETTYPRINT 8702 . 9931) ( CASE.PRETTYPRINT 9933 . 11951) (PROGV.PRETTYPRINT 11953 . 13049) (INDENTATION.FROM.HERE 13051 . 13271) (SEQUENTIAL.PRETTYPRINT 13273 . 13863)) (14562 28429 (SUPERPRINT/COMMENT 14572 . 18530) ( PRIN2-LONG-STRING 18532 . 25171) (SUPERPRINT/WRAPPER 25173 . 26133) (SUPERPRINT/SPACE 26135 . 26578) ( PRINENDLINE 26580 . 27555) (PRINDOTP 27557 . 28122) (PRINTDEF1 28124 . 28427))))) STOP \ No newline at end of file diff --git a/lispusers/DIALPHONE b/lispusers/DIALPHONE new file mode 100644 index 00000000..c2d24f11 --- /dev/null +++ b/lispusers/DIALPHONE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED " 5-Oct-89 11:00:18" {ICE}LISP>LYRIC>DIALPHONE.\;6 10111 |changes| |to:| (FNS DIALPHONE) (VARS DIALPHONECOMS) |previous| |date:| "24-Jul-89 15:27:55" {ICE}LISP>LYRIC>DIALPHONE.\;5) (PRETTYCOMPRINT DIALPHONECOMS) (RPAQQ DIALPHONECOMS ((FNS DIALPHONE) (INITVARS (DIALHISTSIZE 10) (DIALITEMS) (DIALMENU) (DIALPREFIX "ATDT") (DIALSUFFIX (CHARACTER 13)) (LASTNUMBERDIALED) (PHONEBILLNUMBER)) (BITMAPS PHONEMAP))) (DEFINEQ (DIALPHONE (LAMBDA (NUMBER DMENU BUTTON) (* \; "Edited 5-Oct-89 10:52 by MJD") (* |;;| "Phone dialing program for Hayes-compatible modems on the RS-232 port. Creates a global var. DIALMENU (which it tries to attach to an AddressBook window), and uses global strings PHONEBILLNUMBER - your local extension, and LASTNUMBERDIALED. Prompts for a number from the user if NUMBER is not provided.") (NLSETQ (PROG ((ATOZ '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)) MODEMLST MODEMSTR RS232STREAM DIALWINDOW) (|if| (AND (NOT NUMBER) (NOT DIALMENU)) |then| (* |;;|  "1st-time-only initializations (also skip this if the first call is programmatic):") (* |;;| "Note - no error checking:") (OR PHONEBILLNUMBER (SETQ PHONEBILLNUMBER (PROMPTFORWORD "What is your extension number?" NIL NIL PROMPTWINDOW))) (OR PHONEBILLNUMBER (SETQ PHONEBILLNUMBER "")) (SETQ DIALMENU (|create| MENU ITEMS _ (LIST (LIST (EVAL PHONEMAP) NIL "Dials a phone number.")) MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCREATE 'HELVETICA 12 'BOLD) WHENSELECTEDFN _ 'DIALPHONE)) (SETQ DIALWINDOW (|for| W |in| (OPENWINDOWS) |when| (EQ (WINDOWPROP W 'TITLE) '|Address Book|) |do| (RETURN W))) (|if| (NOT DIALWINDOW) |then| (PRINTOUT T "I couldn't find an AddressBook window to attach the Dial menu. Click left in the window you want it attached to, or in the Background to make a free-standing menu." ) (UNTILMOUSESTATE LEFT) (SETQ DIALWINDOW (WHICHW))) (|if| DIALWINDOW |then| (ATTACHMENU DIALMENU DIALWINDOW 'TOP 'LEFT) |else| (ADDMENU DIALMENU)) (RETURN DIALWINDOW)) (* |;;| "The NLSETQ keeps this from breaking if the modem is already in use:") (SETQ RS232STREAM (OPENSTREAM '{RS232} 'OUTPUT)) (SETQ LASTNUMBERDIALED (|if| (NUMBERP (MKATOM NUMBER)) |then| (* |;;| "We were invoked programatically:") NUMBER |else| (* |;;| "Called from menu, so get a number to dial:") (|if| (EQ BUTTON 'LEFT) |then| (* |;;| "Wants to type it in:") (PROMPTFORWORD "Number please:" LASTNUMBERDIALED NIL PROMPTWINDOW) |else| (* |;;| "Wants to select from history list:") (MENU (|create| MENU ITEMS _ DIALITEMS TITLE _ "Number please:"))))) (|if| (NOT LASTNUMBERDIALED) |then| (* |;;| "Didn't give a number, so wrap it up right here:") (CLOSEF RS232STREAM) (SETQ LASTNUMBERDIALED "") (* \;  "So it won't print \"NIL\" next time.") (PRINTOUT PROMPTWINDOW "...aborted." T) (RETURN NIL)) (|push| DIALITEMS LASTNUMBERDIALED) (* \; "Add to history list.") (|if| (GREATERP (LENGTH DIALITEMS) DIALHISTSIZE) |then| (* \; "Dequeue as needed:") (CL:NBUTLAST DIALITEMS 1)) (SETQ MODEMSTR (CONCAT LASTNUMBERDIALED)) (* \;  "Make copy so it won't get smashed by RPLSTRING below.") (|if| (INTERSECTION (UNPACK MODEMSTR) (APPEND ATOZ (L-CASE ATOZ))) |then| (* |;;| "It's got letters! Turn them into numbers:") (SETQ MODEMLST (UNPACK MODEMSTR)) (|for| N |from| 2 |to| 9 |as| GROUP |in| '((A B C) (D E F) (G H I) (J K L) (M N O) (P R S) (T U V) (W X Y)) |do| (|for| LETTER |in| GROUP |do| (DSUBST N LETTER MODEMLST))) (SETQ MODEMSTR (CONCATLIST MODEMLST))) (SETQ MODEMSTR (|if| (ILEQ (NCHARS MODEMSTR) 5) |then| (* |;;| "Just another extension:") (CONCAT MODEMSTR ",") |else| (|if| (ILEQ (NCHARS MODEMSTR) 8) |then| (* |;;|  "It's a local call (7 digits +optional \"-\"), so dial 9 first:") (CONCAT "9" MODEMSTR) |else| (* |;;|  "Long distance, so dial 8 first and add local no. for billing:") (|if| (STRING-EQUAL (SUBSTRING MODEMSTR 1 2 ) "8*") |then| (* |;;| "It's an Intelnet number:") (CONCAT (RPLSTRING MODEMSTR 1 "8,") "," PHONEBILLNUMBER) |else| (* |;;| "It's outside:") (CONCAT "8," MODEMSTR "," PHONEBILLNUMBER))))) (* |;;| "Dial the number and hang up:") (PRIN1 (CONCAT DIALPREFIX MODEMSTR ";H0" DIALSUFFIX) RS232STREAM) (PRINTOUT PROMPTWINDOW "...dialing...") (FORCEOUTPUT RS232STREAM) (* \; "Ensure buffer is dumped.") (CLOSEF RS232STREAM) (* \; "Cleanup & exit.") (PRINTOUT PROMPTWINDOW "OK" T) (RETURN LASTNUMBERDIALED))))) ) (RPAQ? DIALHISTSIZE 10) (RPAQ? DIALITEMS ) (RPAQ? DIALMENU ) (RPAQ? DIALPREFIX "ATDT") (RPAQ? DIALSUFFIX (CHARACTER 13)) (RPAQ? LASTNUMBERDIALED ) (RPAQ? PHONEBILLNUMBER ) (RPAQQ PHONEMAP #*(64 32)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOL@@@@@@@@COOOOOOOOH@@@@@@OOL@@@@GON@@@@@CL@@@@@@@@GH@@@@G@@@@@@@@@AL@@@@NF@@@@@@@@HN@@@ALC@@F@@L@AHG@@@CHAH@IOOB@C@C@@@C@@LGIOOCLF@AH@@F@@BOIHCCND@AH@@F@@@HIHCBB@@AH@@F@C@GOOOOL@LAH@@F@NAOOOOOO@CAH@@FC@CL@@@@CK@OH@@GLCG@AIIHAMLAH@AN@NN@AIIH@NOCH@COCML@@@@@@GCO@@CCOCH@AIIH@CHN@@FALC@@AIIH@AH@@@G@@G@@@@@@@AL@@@F@@N@@AIIH@@N@@@EH@L@@AIIH@@F@@@CDAL@@@@@@@@G@@@BMAH@@AIIH@@C@@@AKAH@@AIIH@@C@@@@JOH@@@@@@@@C@@@@COH@@@@@@@@C@@@@BOOOOOOOOOOO@@@@@AOOOOOOOOOO@@@@@@GN@@@@@@OL@@@ ) (DECLARE\: DONTCOPY (FILEMAP (NIL (797 9336 (DIALPHONE 807 . 9334))))) STOP \ No newline at end of file diff --git a/lispusers/DIALPHONE.TEDIT b/lispusers/DIALPHONE.TEDIT new file mode 100644 index 00000000..e2777282 Binary files /dev/null and b/lispusers/DIALPHONE.TEDIT differ diff --git a/lispusers/DICOLOR b/lispusers/DICOLOR new file mode 100644 index 00000000..f9912ef3 --- /dev/null +++ b/lispusers/DICOLOR @@ -0,0 +1 @@ +(FILECREATED "15-Aug-85 19:44:58" {ERIS}LIBRARY>DICOLOR.;2 15766 changes to: (VARS DICOLORCOMS) previous date: " 9-Aug-85 05:58:26" {ERIS}LIBRARY>DICOLOR.;1) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DICOLORCOMS) (RPAQQ DICOLORCOMS ((FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS RGBTOCNS) (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM) (INITVARS (COLORNAMEMENU)) (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN DICOLOR.saturationNvalue DICOLOR.saturationNname) (DECLARE: DONTCOPY (*) (RECORDS hueRecord lightnessRecord saturationRecord) (CONSTANTS * DICOLOR.hueConstants) (CONSTANTS * DICOLOR.saturationConstants) (CONSTANTS * DICOLOR.lightnessConstants)))) (DEFINEQ (CNSMENUINIT [LAMBDA NIL (* gbn " 9-Aug-85 03:11") [SETQ CNSHUEMENU (create MENU ITEMS _(for I in DICOLOR.hueMapping collect (CAR I] [SETQ CNSSATURATIONMENU (create MENU ITEMS _(for I in DICOLOR.saturationMapping collect (CAR I] (SETQ CNSLIGHTNESSMENU (create MENU ITEMS _(for I in DICOLOR.lightnessMapping collect (CAR I]) (CNSTOCSL [LAMBDA (hue saturation lightness) (* hdj "12-Apr-85 19:01") (PROG ((hueAtom (MKATOM hue)) (saturationAtom (MKATOM saturation)) (lightnessAtom (MKATOM lightness)) c s l) (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom DICOLOR.hueMapping] then (SETQ c DICOLOR.achromatic)) (if (EQ c DICOLOR.achromatic) then (SETQ s DICOLOR.noSaturation) else (if [NOT (SETQ s (fetch (saturationRecord ordering) of (ASSOC saturationAtom DICOLOR.saturationMapping] then (SETQ s DICOLOR.vivid))) (SELECTQ hueAtom (Black (SETQ l DICOLOR.black)) (White (SETQ l DICOLOR.white)) (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom DICOLOR.lightnessMapping] then (SETQ l DICOLOR.medium))) (RETURN (LIST c s l]) (CNSTORGB [LAMBDA (saturation lightness hue) (* hdj "15-Jul-85 12:33") (LET ((CSL (CNSTOCSL hue saturation lightness))) (HLSTORGB (APPLY (FUNCTION CSLTOHLS) CSL]) (CSLTOCNS [LAMBDA (c s l) (* hdj "15-Jul-85 12:37") (PROG (hue saturation lightness) [if (EQ c DICOLOR.achromatic) then (SETQ saturation "") [SELECTC l (DICOLOR.black (SETQ hue "Black") (SETQ lightness "")) (DICOLOR.white (SETQ hue "White") (SETQ lightness "")) (PROGN (SETQ hue "Gray") (SETQ lightness (MKSTRING (fetch (lightnessRecord name) of (DICOLOR.lightnessN l] else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c))) (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN s))) (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN l] (RETURN (LIST saturation lightness hue]) (DICOLOR.FROM.USER [LAMBDA (NAMES?) (* gbn " 9-Aug-85 04:51") (* * returns an RGB triple. If NAMES? prompts the user first with the global color name menu. She can then choose NEWCOLOR which can be specified as RGB or CNS) (PROG (NAME RGB) (if NAMES? then (* first try to get a color name) [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU (CREATE MENU ITEMS _(CONS NEWCOLORITEM (FOR ENTRY IN COLORNAMES COLLECT (CAR ENTRY] (if (NOT NAME) then (* the user clicked outside the menu) (RETURN)) [SETQ RGB (SELECTQ NAME (RGB (READCOLOR1 "specify new color")) (CNS (APPLY (FUNCTION CNSTORGB) (GETCNS))) (RETURN (CDR (ASSOC NAME COLORNAMES] (if (NOT (SETQ NAME (TTYIN "New color name? "))) then (* user must have decided that she didn't want to keep  (name) the color) (RETURN)) (push COLORNAMES (CONS (CAR NAME) RGB)) (SETQ COLORNAMEMENU NIL) (* invalidate the menu) (RETURN RGB]) (GETCNS [LAMBDA NIL (* gbn " 9-Aug-85 03:13") (LIST (MENU CNSLIGHTNESSMENU) (MENU CNSSATURATIONMENU) (MENU CNSHUEMENU]) (HLSTOCSL [LAMBDA (hue lightness saturation) (* hdj "15-Jul-85 12:14") (LET ((ISLHue (FQUOTIENT (MOD (PLUS hue 240) 360) 360))) (PROG (c s l) (for old s from DICOLOR.noSaturation to DICOLOR.vivid do (if (EQ s DICOLOR.vivid) then (RETURN)) (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s) (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue (ADD1 s)) (DICOLOR.saturationNvalue s)) 2))) then (RETURN))) [if (EQ s DICOLOR.noSaturation) then (SETQ c DICOLOR.achromatic) (for old l from DICOLOR.black to DICOLOR.white do (if (EQ l DICOLOR.white) then (RETURN)) (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue (ADD1 l)) (DICOLOR.lightnessNvalue l)) 2))) then (RETURN))) else (for old c from DICOLOR.red to DICOLOR.purplishRed do (* (HELP c)) (if (EQ c DICOLOR.purplishRed) then (if (GREATERP ISLHue (PLUS (DICOLOR.hueNvalue c) (QUOTIENT (DIFFERENCE 1 ( DICOLOR.hueNvalue c)) 2))) then (SETQ c DICOLOR.red)) (RETURN)) (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c) (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue (ADD1 c)) (DICOLOR.hueNvalue c)) 2))) then (RETURN))) (for old l from DICOLOR.veryDark to DICOLOR.veryLight do (if (EQ l DICOLOR.veryLight) then (RETURN)) (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue (ADD1 l)) (DICOLOR.lightnessNvalue l)) 2))) then (RETURN] (RETURN (LIST c s l]) (CSLTOHLS [LAMBDA (c s l) (* hdj "15-Jul-85 12:23") (PROG (hue saturation lightness) (if (EQ c DICOLOR.achromatic) then (SETQ hue 0.0) (SETQ saturation 0.0) (SETQ lightness (DICOLOR.lightnessNvalue l)) else (SETQ hue (DICOLOR.hueNvalue c)) (SETQ saturation (DICOLOR.saturationNvalue s)) (SETQ lightness (DICOLOR.lightnessNvalue l))) (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360)) 360) lightness saturation]) (RGBTOCNS [LAMBDA (Red Green Blue) (* hdj "15-Jul-85 12:36") (APPLY (FUNCTION CSLTOCNS) (APPLY (FUNCTION HLSTOCSL) (RGBTOHLS Red Green Blue]) ) (RPAQQ DICOLOR.hueMapping ((Achromatic 0.0 -1) (Red 0.0 0) (OrangishRed .01 1) (RedOrange .02 2) (ReddishOrange .03 3) (Orange .04 4) (YellowishOrange .07 5) (OrangeYellow .1 6) (OrangishYellow .13 7) (Yellow .1673 8) (GreenishYellow .2073 9) (YellowGreen .2473 10) (YellowishGreen .2873 11) (Green .3333 12) (BluishGreen .4133 13) (GreenBlue .4933 14) (GreenishBlue .5733 15) (Blue .6666 16) (PurplishBlue .6816 17) (BluePurple .6966 18) (BluishPurple .7116 19) (Purple .73 20) (ReddishPurple .8 21) (PurpleRed .87 22) (PurplishRed .94 23) (BrownishRed .01 24) (RedBrown .02 25) (ReddishBrown .03 26) (Brown .04 27) (YellowishBrown .07 28) (BrownYellow .1 29) (BrownishYellow .13 30))) (RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0) (VeryDark .1666 1) (Dark .3333 2) (Medium .5 3) (Light .6666 4) (VeryLight .8333 5) (White 1.0 6))) (RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0) (Grayish .25 1) (Moderate .5 2) (Strong .75 3) (Vivid 1.0 4))) (RPAQQ NEWCOLORITEM (New% Color (QUOTE CNS) "Allows specification of a new color" (SUBITEMS (RGB (QUOTE RGB) "Specify a new color using Red, Green, Blue sliders") (CNS (QUOTE CNS) "Specify a new color using English")))) (RPAQ? COLORNAMEMENU ) (DEFINEQ (DICOLOR.hueN [LAMBDA (N) (* hdj "17-Apr-85 13:38") (DECLARE (GLOBALVARS DICOLOR.hueMapping)) (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering) of ELT) N]) (DICOLOR.hueNvalue [LAMBDA (N) (* hdj "18-Apr-85 09:58") (fetch (hueRecord value) of (DICOLOR.hueN N]) (DICOLOR.hueNname [LAMBDA (N) (* hdj "18-Apr-85 10:07") (fetch (hueRecord name) of (DICOLOR.hueN N]) (DICOLOR.lightnessN [LAMBDA (N) (* hdj "17-Apr-85 13:40") (DECLARE (GLOBALVARS DICOLOR.lightnessMapping)) (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord ordering) of ELT) N]) (DICOLOR.lightnessNvalue [LAMBDA (N) (* hdj "17-Apr-85 13:36") (fetch (lightnessRecord value) of (DICOLOR.lightnessN N]) (DICOLOR.lightnessNname [LAMBDA (N) (* hdj "17-Apr-85 14:02") (fetch (lightnessRecord name) of (DICOLOR.lightnessN N]) (DICOLOR.saturationN [LAMBDA (N) (* hdj "17-Apr-85 13:39") (DECLARE (GLOBALVARS DICOLOR.saturationMapping)) (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord ordering) of ELT) N]) (DICOLOR.saturationNvalue [LAMBDA (N) (* hdj "17-Apr-85 13:36") (fetch (saturationRecord value) of (DICOLOR.saturationN N]) (DICOLOR.saturationNname [LAMBDA (N) (* hdj "17-Apr-85 14:02") (fetch (saturationRecord name) of (DICOLOR.saturationN N]) ) (DECLARE: DONTCOPY [DECLARE: EVAL@COMPILE (RECORD hueRecord (name value ordering)) (RECORD lightnessRecord (name value ordering)) (RECORD saturationRecord (name value ordering)) ] (RPAQQ DICOLOR.hueConstants (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange)) (DECLARE: EVAL@COMPILE (RPAQQ DICOLOR.achromatic -1) (RPAQQ DICOLOR.blue 16) (RPAQQ DICOLOR.bluePurple 18) (RPAQQ DICOLOR.bluishGreen 13) (RPAQQ DICOLOR.bluishPurple 19) (RPAQQ DICOLOR.brown 27) (RPAQQ DICOLOR.brownYellow 29) (RPAQQ DICOLOR.brownishRed 24) (RPAQQ DICOLOR.brownishYellow 30) (RPAQQ DICOLOR.green 12) (RPAQQ DICOLOR.greenBlue 14) (RPAQQ DICOLOR.greenishBlue 15) (RPAQQ DICOLOR.greenishYellow 9) (RPAQQ DICOLOR.orange 4) (RPAQQ DICOLOR.orangeYellow 6) (RPAQQ DICOLOR.orangishRed 1) (RPAQQ DICOLOR.orangishYellow 7) (RPAQQ DICOLOR.purple 20) (RPAQQ DICOLOR.purpleRed 22) (RPAQQ DICOLOR.purplishBlue 17) (RPAQQ DICOLOR.purplishRed 23) (RPAQQ DICOLOR.red 0) (RPAQQ DICOLOR.redBrown 25) (RPAQQ DICOLOR.redOrange 2) (RPAQQ DICOLOR.reddishBrown 26) (RPAQQ DICOLOR.reddishOrange 3) (RPAQQ DICOLOR.reddishPurple 21) (RPAQQ DICOLOR.yellow 8) (RPAQQ DICOLOR.yellowGreen 10) (RPAQQ DICOLOR.yellowishBrown 28) (RPAQQ DICOLOR.yellowishGreen 11) (RPAQQ DICOLOR.yellowishOrange 5) (CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange) ) (RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid)) (DECLARE: EVAL@COMPILE (RPAQQ DICOLOR.noSaturation 0) (RPAQQ DICOLOR.grayish 1) (RPAQQ DICOLOR.moderate 2) (RPAQQ DICOLOR.strong 3) (RPAQQ DICOLOR.vivid 4) (CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid) ) (RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white)) (DECLARE: EVAL@COMPILE (RPAQQ DICOLOR.black 0) (RPAQQ DICOLOR.veryDark 1) (RPAQQ DICOLOR.dark 2) (RPAQQ DICOLOR.medium 3) (RPAQQ DICOLOR.light 4) (RPAQQ DICOLOR.veryLight 5) (RPAQQ DICOLOR.white 6) (CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white) ) ) (PUTPROPS DICOLOR COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (1005 8438 (CNSMENUINIT 1015 . 1502) (CNSTOCSL 1504 . 2550) (CNSTORGB 2552 . 2782) ( CSLTOCNS 2784 . 3683) (DICOLOR.FROM.USER 3685 . 5118) (GETCNS 5120 . 5322) (HLSTOCSL 5324 . 7615) ( CSLTOHLS 7617 . 8217) (RGBTOCNS 8219 . 8436)) (9938 12002 (DICOLOR.hueN 9948 . 10228) ( DICOLOR.hueNvalue 10230 . 10405) (DICOLOR.hueNname 10407 . 10580) (DICOLOR.lightnessN 10582 . 10892) ( DICOLOR.lightnessNvalue 10894 . 11087) (DICOLOR.lightnessNname 11089 . 11280) (DICOLOR.saturationN 11282 . 11606) (DICOLOR.saturationNvalue 11608 . 11804) (DICOLOR.saturationNname 11806 . 12000))))) STOP \ No newline at end of file diff --git a/lispusers/DICT-WINDOW-TYPES b/lispusers/DICT-WINDOW-TYPES new file mode 100644 index 00000000..669f63e1 --- /dev/null +++ b/lispusers/DICT-WINDOW-TYPES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (IL:FILECREATED " 6-Oct-88 12:43:10" IL:{ERINYES}MEDLEY>DICT-WINDOW-TYPES.\;3 4434 IL:|changes| IL:|to:| (IL:FUNCTIONS DICT-WINDOW-RECONSTITUTER SEARCH-MENU-RECONSTITUTER DICT-WINDOW-ABSTRACTER SEARCH-MENU-ABSTRACTER SEARCH-MENU-P DICT-WINDOW-P) (IL:WINDOW-TYPES :DICT-WINDOW :SEARCH-MENU) (IL:VARS IL:DICT-WINDOW-TYPESCOMS) (IL:FNS SEARCH-MENU-P) (FILE-ENVIRONMENTS IL:DICT-WINDOW-TYPES) IL:|previous| IL:|date:| " 6-Oct-88 12:18:11" IL:{ERINYES}MEDLEY>DICT-WINDOW-TYPES.\;2 ) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DICT-WINDOW-TYPESCOMS) (IL:RPAQQ IL:DICT-WINDOW-TYPESCOMS ((FILE-ENVIRONMENTS IL:DICT-WINDOW-TYPES) (IL:WINDOW-TYPES :DICT-WINDOW :SEARCH-MENU) (IL:FUNCTIONS DICT-WINDOW-P DICT-WINDOW-ABSTRACTER DICT-WINDOW-RECONSTITUTER) (IL:FUNCTIONS SEARCH-MENU-P SEARCH-MENU-ABSTRACTER SEARCH-MENU-RECONSTITUTER))) (DEFINE-FILE-ENVIRONMENT IL:DICT-WINDOW-TYPES :COMPILER :COMPILE-FILE :READTABLE "XCL" :PACKAGE "XCL-USER") (ROOMS:DEF-WINDOW-TYPE :DICT-WINDOW :DEPENDENCIES (:TEDIT :TEXTSTREAM) :RECOGNIZER DICT-WINDOW-P :ABSTRACTER DICT-WINDOW-ABSTRACTER :RECONSTITUTER DICT-WINDOW-RECONSTITUTER :TITLE "Definitions" :FILES (IL:DICTTOOL IL:DICT-WINDOW-TYPES)) (ROOMS:DEF-WINDOW-TYPE :SEARCH-MENU :RECOGNIZER SEARCH-MENU-P :ABSTRACTER SEARCH-MENU-ABSTRACTER :RECONSTITUTER SEARCH-MENU-RECONSTITUTER :TITLE "Search Menu" :FILES (IL:SEARCHMENU IL:DICT-WINDOW-TYPES)) (DEFUN DICT-WINDOW-P (WINDOW) (DECLARE (GLOBAL IL:|Dict.DefWindow|)) (EQ WINDOW IL:|Dict.DefWindow|)) (DEFUN DICT-WINDOW-ABSTRACTER (W) (LET (NERD DICT) (DECLARE (GLOBAL IL:|Dict.OutputStream|)) (SETQ NERD (OR (IL:STREAMPROP (IL:TEXTSTREAM W) 'IL:|nerd|) (IL:STREAMPROP (IL:|Dict.OutputStream|) 'IL:|nerd|))) (SETQ DICT (OR (IL:STREAMPROP (IL:TEXTSTREAM W) 'IL:|dict|) (IL:STREAMPROP (IL:|Dict.OutputStream|) 'IL:|dict|))) (LIST :DICT (AND DICT (IL:|Dict.Name| DICT)) :NERD (AND NERD (IL:|InvertedDict.Name| NERD))))) (DEFUN DICT-WINDOW-RECONSTITUTER (DATA) (DECLARE (GLOBAL IL:|Dict.DefWindow|)) (LET (DICTSTREAM DICTNAME DICT NERDNAME NERD) (SETQ DICTSTREAM (IL:|Dict.OutputStream| (IL:CREATEREGION 0 0 100 100))) (COND ((SETQ DICTNAME (GETF DATA :DICT)) (COND ((SETQ DICT (IL:|DictFromName| DICTNAME)) (IL:STREAMPROP DICTSTREAM 'IL:|dict| DICT))))) (COND ((SETQ NERDNAME (GETF DATA :NERD)) (COND ((SETQ NERD (IL:|InvertedDictFromName| NERDNAME)) (IL:STREAMPROP DICTSTREAM 'IL:|nerd| NERD))))) IL:|Dict.DefWindow|)) (DEFUN SEARCH-MENU-P (W) (EQUAL "Search Menu" (IL:WINDOWPROP W 'IL:TITLE))) (DEFUN SEARCH-MENU-ABSTRACTER (W) (LET (NERD) (DECLARE (GLOBAL IL:|SearchMenu.Stream|)) (SETQ NERD (AND (STREAMP IL:|SearchMenu.Stream|) (IL:STREAMPROP IL:|SearchMenu.Stream| 'IL:|nerd|))) (LIST :NERD (AND NERD (IL:|InvertedDict.Name| NERD))))) (DEFUN SEARCH-MENU-RECONSTITUTER (DATA) (LET (NERDNAME NERD) (DECLARE (GLOBAL IL:|SearchMenu| IL:|SearchMenu.Stream|)) (IL:|SearchMenu.Create|) (COND ((NULL IL:|SearchMenu.Stream|) (SETQ IL:|SearchMenu.Stream| (IL:OPENTEXTSTREAM)))) (COND ((SETQ NERDNAME (GETF DATA :NERD)) (COND ((SETQ NERD (IL:|InvertedDictFromName| NERDNAME)) (IL:STREAMPROP IL:|SearchMenu.Stream| 'IL:|nerd| NERD))))) IL:|SearchMenu|)) (IL:PUTPROPS IL:DICT-WINDOW-TYPES IL:COPYRIGHT ("Xerox Corporation" 1988)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/DICTTOOL b/lispusers/DICTTOOL new file mode 100644 index 00000000..6cfcc445 --- /dev/null +++ b/lispusers/DICTTOOL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "31-May-89 15:07:29" {ERINYES}MEDLEY>DICTTOOL.;14 91631 changes to%: (FNS Dict.AddCommands) (VARS DICTTOOLCOMS) previous date%: "28-Feb-89 10:54:26" {ERINYES}MEDLEY>DICTTOOL.;13) (* " Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DICTTOOLCOMS) (RPAQQ DICTTOOLCOMS ((COMS * DICTTOOLDEPENDENCIES) (FILES ANALYZER (FROM {PIGLET/N}DICTSERVER>LISP>) DICTCLIENT) (* ;; "1/6/89 jtm: fixed TEdit.PrintDefinition so that SimpleDicts would print their entries in the definition window.") (* ;; "1/6/89 jtm: changed TEdit.SetDictionary and DictForStream so that TEdit.DefaultDictionary reflects the default dictionary to use if no other is specified.") (* ;; "2/28/89 jtm: changed FILES so that DICTCLIENT is loaded from PIGLET.") (* ;;  "5/31/89 jtm: changed Dict.AddCommands to put Dictionary menu item on Lafite display windows.") (FNS TEDIT.INCLUDESTREAM TEdit.PrintDefinition DictTool.PrintDefinition Dict.PrintDefinition DictTool.GetEntry TEdit.SetDictionary DictForStream DictTool.Dictionaries PARSEBYCOLONS PrintPronunciationGuide ConvertPronunciation) (FNS TEdit.PrintSearch DictTool.PrintSearch DictTool.MergeSearch NerdForStream TEdit.SetNerd DictTool.PromptForCutoff DictTool.PromptForKeywordCutoff PARSESELECTION) (FNS TEdit.PrintPhraseSearch DictTool.PrintPhraseSearch) (FNS TEdit.PrintSynonyms REMOVEALL CONVERTFUNCTIONSTOFORMS TEdit.PrintNounSynonyms DictTool.PrintNounSynonyms DictTool.PrintVerbSynonyms DictTool.PrintAdjSynonyms TEdit.PrintVerbSynonyms TEdit.PrintAdjSynonyms DictTool.PrintSynonyms) (FNS DictTool.TEditWrapper Dict.OutputStream DictTool.PromptStream) (FNS DictTool.Init DictTool.Open DictTool.OpenDictionary DictTool.OpenAnalyzer DictTool.OpenNerd Dict.AddCommands DictTool.Close) (FNS DictTool.Analyze DictTool.Analyzers DictTool.Pronunciation DictTool.Corrections DictTool.CountWords) (COMS (* * FINDWORD & SUBSTITUTEWORD) (FNS DictTool.FindWord DictTool.SubstituteWord DictTool.CreateConjugationMap DictTool.FindWordInit) (FNS LingFns.FindWord LingFns.Capitalize LingFns.Capitalization) (P (DictTool.FindWordInit))) (INITVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary (DictTool.MinKeywords 2) (DictTool.MaxWords 100)) (GLOBALVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.MinKeywords DictTool.MaxWords DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary) (P (DictTool.Init)) (VARS PronunciationGuide PronunciationMap))) (RPAQQ DICTTOOLDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'DICTTOOL 'DEPENDENCIES (for FILE in (FILECOMSLST 'DICTTOOL 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES DICTTOOL) (P (for FILE FILEDATE in (GETPROP 'DICTTOOL 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (printout T "Flushing old version of " (CAR FILE) T) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS DICTTOOL DEPENDENCIES ((ANALYZER . " 9-Mar-89 15:24:58") (DICTCLIENT . " 8-Oct-87 15:15:08"))) [for FILE FILEDATE in (GETPROP 'DICTTOOL 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force  FILESLOAD to reload the file.) (printout T "Flushing old version of " (CAR FILE) T) (PUTPROP (CAR FILE) 'FILEDATES NIL] (FILESLOAD ANALYZER (FROM {PIGLET/N}DICTSERVER>LISP>) DICTCLIENT) (* ;; "1/6/89 jtm: fixed TEdit.PrintDefinition so that SimpleDicts would print their entries in the definition window." ) (* ;; "1/6/89 jtm: changed TEdit.SetDictionary and DictForStream so that TEdit.DefaultDictionary reflects the default dictionary to use if no other is specified." ) (* ;; "2/28/89 jtm: changed FILES so that DICTCLIENT is loaded from PIGLET.") (* ;; "5/31/89 jtm: changed Dict.AddCommands to put Dictionary menu item on Lafite display windows." ) (DEFINEQ (TEDIT.INCLUDESTREAM [LAMBDA (TEXTSTREAM INCLUDEDSTREAM) (* jtm%: "28-Oct-87 14:41") (LET (STARTPOS) (SETQ STARTPOS (ADD1 (GETEOFPTR TEXTSTREAM))) (TEDIT.COPY (TEDIT.SETSEL INCLUDEDSTREAM 1 (GETEOFPTR INCLUDEDSTREAM) 'LEFT) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'LEFT)) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'LEFT) (TEDIT.NORMALIZECARET TEXTSTREAM) (TEDIT.STREAMCHANGEDP TEXTSTREAM T]) (TEdit.PrintDefinition [LAMBDA (stream dict words) (* ; "Edited 6-Jan-89 11:46 by jtm:") (* * prints out the definition of the currently selected text.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (OR dict (DictForStream stream)) [FUNCTION (LAMBDA (dict selection stream) (LET (printFn entry) (for word exists in (PARSEBYCOLONS selection) do [COND ((AND (SETQ printFn (fetch (Dict printEntryFn) of dict)) (NEQ printFn 'NILL)) (SETQ exists (OR (APPLY* printFn dict word stream) exists))) ((SETQ printFn (fetch (Dict getEntryFn) of dict)) (SETQ entry (APPLY* printFn dict word NIL)) [for def (left _ (LENGTH entry)) inside entry first (TEDIT.INSERT stream (CONCAT word ": ")) do [COND ((STREAMP def) (SETQ def (STREAM.FETCHSTRING def 0 (GETEOFPTR def] (TEDIT.INSERT stream def) (add left -1) (COND ((IGEQ left 1) (TEDIT.INSERT stream ", ")) (T (TEDIT.INSERT stream " "] (SETQ exists (OR entry exists] finally (RETURN exists] stream words "word to look up:" "Getting definition for"]) (DictTool.PrintDefinition [LAMBDA (dict words stream) (* jtm%: "17-Nov-87 11:02") (PROG (def looks found pos (offset 0)) [for word inside (PARSEBYCOLONS words) do (SETQ def (Dict.GetEntry dict word)) (SETQ looks (Dict.Prop dict 'Looks)) (COND ((AND (NULL looks) (Dict.Prop dict 'RemoteDict)) [SETQ looks (DICTCLIENT.GETLOOKS (Dict.Prop dict 'RemoteDict] (Dict.Prop dict 'Looks looks))) (COND [(STRINGP def) (SETQ found T) (TEDIT.INSERT stream def) (for I from 1 to 2 when (NEQ 13 (NTHCHARCODE def (IMINUS I))) do (TEDIT.INSERT stream (CHARACTER 13] ([AND (STRINGP (CAR def)) (NOT (STREQUAL "" (CAR def] (SETQ found T) (TEDIT.INSERT stream (CAR def) NIL (CDAR looks)) (for I from 1 to 2 when (NEQ 13 (NTHCHARCODE def (IMINUS I))) do (TEDIT.INSERT stream (CHARACTER 13))) (* assumes that the first look given  is the default for the dictionary.) (SETQ pos (TEDIT.GETPOINT stream)) (* setting looks moves the selection) (for i in (CDR def) do (TEDIT.LOOKS stream (CDR (FASSOC (CADDR i) looks)) (IPLUS (CAR i) offset) (CADR i))) (SETQ offset (SUB1 pos)) (TEDIT.SETSEL stream pos 0 'LEFT)) (NIL (TEDIT.INSERT stream (CONCAT word ": not found.")) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) 1 (ADD1 (NCHARS word))) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) (IPLUS 2 (NCHARS word)) 11] (RETURN found]) (Dict.PrintDefinition [LAMBDA (dict word stream) (* jtm%: "13-Oct-87 10:27") (PROG (scratch start) [COND ((NULL stream) (SETQ stream (Dict.OutputStream] [SETQ scratch (OPENTEXTSTREAM NIL NIL NIL NIL '(LEAVETTY] (COND ((Dict.PrintEntry dict word scratch) (TEDIT.INSERT scratch (CONCAT (CHARACTER 13) (CHARACTER 13)) (ADD1 (GETEOFPTR scratch))) (SETQ start (ADD1 (GETEOFPTR stream))) (TEDIT.COPY (TEDIT.SETSEL scratch 1 (GETEOFPTR scratch) 'LEFT) (TEDIT.SETSEL stream start 0 'LEFT)) (CLOSEF scratch) (TEDIT.SETSEL stream start 0 'RIGHT) (TEDIT.NORMALIZECARET stream) (TEDIT.STREAMCHANGEDP stream T) (RETURN T]) (DictTool.GetEntry [LAMBDA (dict uniqueID prop) (* jtm%: " 7-Apr-87 08:39") (COND [(NUMBERP uniqueID) (DICTCLIENT.ENUMERATE uniqueID (Dict.Prop dict 'RemoteDict] (T (DICTCLIENT.GETDEFINITION uniqueID (Dict.Prop dict 'RemoteDict]) (TEdit.SetDictionary [LAMBDA (stream dict) (* ; "Edited 6-Jan-89 12:24 by jtm:") (* * sets the dictionary property for the window) (PROG (menuItems) (OR stream (SETQ stream (Dict.OutputStream))) [COND ((NULL dict) [SETQ menuItems (for i in Dict.DictionaryList collect (LIST (Dict.Name i) (LIST 'QUOTE i) (if (Dict.Prop i 'RemoteDict) then "Calls the remote dictionary server"] [COND ((NULL menuItems) (TEDIT.PROMPTPRINT stream "Sorry, no dictionaries loaded." T)) ((EQ 1 (LENGTH menuItems)) (SETQ dict (CAR Dict.DictionaryList))) (T (SETQ dict (MENU (create MENU ITEMS _ menuItems TITLE _ "dictionaries" CENTERFLG _ T] (COND ((NULL dict) (SETQ dict (STREAMPROP stream 'dict)) (TEDIT.PROMPTPRINT stream (CONCAT "Dictionary is " (AND dict (Dict.Name dict)) ".") T) (RETURN] (TEDIT.PROMPTPRINT stream (CONCAT "Setting dictionary to " (AND dict (Dict.Name dict)) "...") T) (Dict.Open dict) (STREAMPROP stream 'dict dict) (* ;; "1/6/89 jtm: set TEdit.DefaultDictionary if this is the dictionary window or if it hasn't already been set.") (if [OR (NULL TEdit.DefaultDictionary) (AND (WINDOWP Dict.DefWindow) (EQ stream (WINDOWPROP Dict.DefWindow 'TEXTSTREAM] then (SETQ TEdit.DefaultDictionary dict)) (TEDIT.PROMPTPRINT stream "done.")) dict]) (DictForStream [LAMBDA (stream) (* ; "Edited 6-Jan-89 12:26 by jtm:") (* ;; "1/6/89 jtm: Try TEdit.DefaultDictionary if the stream doesn't have it's own dictionary.") (COND ((STREAMPROP stream 'dict)) (TEdit.DefaultDictionary) (T (TEdit.SetDictionary (Dict.OutputStream]) (DictTool.Dictionaries [LAMBDA (dict errorStream) (* jtm%: "13-Nov-86 10:57") (DICTCLIENT.DICTIONARIES]) (PARSEBYCOLONS [LAMBDA (STRING COLONSORSPACES) (* ; "Edited 11-Jan-89 13:55 by jtm:") (* * Actually, parse by SEMI-colons.) (LET (WORDS SEPARATOR (OLDPOS 1) (POS 0)) (COND ((STRINGP STRING) (SETQ SEPARATOR (COND ([AND COLONSORSPACES (NULL (STRPOS ";" STRING (ADD1 POS] " ") (T ";"))) [while (SETQ POS (STRPOS SEPARATOR STRING (ADD1 POS))) do (push WORDS (SUBSTRING STRING OLDPOS (SUB1 POS))) (SETQ OLDPOS (for I from (ADD1 POS) thereis (NEQ 32 (NTHCHARCODE STRING I] [COND ((AND (NEQ OLDPOS 0) (ILEQ OLDPOS (NCHARS STRING))) (push WORDS (SUBSTRING STRING OLDPOS (NCHARS STRING] (OR (DREVERSE WORDS) STRING)) (T STRING]) (PrintPronunciationGuide [LAMBDA (stream) (* jtm%: " 9-Feb-87 08:40") (LET (startPos) (SETQ startPos (GETFILEPTR stream)) [for i pronCode on PronunciationGuide do (SETQ pronCode (CAR i)) (TEDIT.INSERT stream (CONCAT (ConvertPronunciation (CAR pronCode)) ": " (CADR pronCode) " " (ConvertPronunciation (CADDR pronCode)) (COND ((CDR i) "; ") (T ""] (TEDIT.LOOKS stream '(FAMILY CLASSIC SIZE 10 FACE STANDARD) (ADD1 startPos) (IDIFFERENCE (GETFILEPTR stream) startPos]) (ConvertPronunciation [LAMBDA (string) (* jtm%: " 6-Feb-87 17:38") (CONCATLIST (for i char nschars from 1 to (NCHARS string) join (SETQ char (NTHCHAR string i)) (SETQ nschars (CDR (FASSOC char PronunciationMap))) (COND ((NULL nschars) (LIST char)) ((LISTP nschars) (COPY nschars)) (T (LIST nschars]) ) (DEFINEQ (TEdit.PrintSearch [LAMBDA (stream dict words) (* jtm%: "13-Oct-87 10:11") (* * prints out the definition of the currently selected text.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (OR dict (NerdForStream stream)) 'DictTool.PrintSearch stream words "Type keywords to search on:" "Searching for words using" 'SEARCHKEYS]) (DictTool.PrintSearch [LAMBDA (dict selection stream) (* jtm%: " 7-Apr-87 09:52") (LET (looks venn) (SETQ venn (DictTool.MergeSearch dict selection)) [for i pos in venn do (* printout header) (SETQ pos (TEDIT.GETPOINT stream)) [for header on (CAR i) do (TEDIT.INSERT stream (CONCAT (CAR header) (COND ((CDR header) " ") (T ": "] (push looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) pos))) [for word on (CADR i) do (TEDIT.INSERT stream (CONCAT (CAR word) (COND ((CDR word) "; ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (TEDIT.INSERT stream (CHARACTER (CHARCODE CR] (* do the looks last to avoid messing  up the text placement.) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) 1 (TEDIT.GETPOINT stream)) (for look in looks do (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) (CAR look) (CDR look))) venn]) (DictTool.MergeSearch [LAMBDA (dict synonymclasses minKeywords minWord maxWord) (* jtm%: " 2-Aug-88 13:15") (LET (minWord maxWord VennSearchFn) [for i on synonymclasses do (COND ((NLISTP (CAR i)) (RPLACA i (LIST (CAR i] [COND ((AND (NULL minWord) (NULL maxWord)) (COND ((AND (EQUAL synonymclasses DictTool.LastSearch) (NEQ 0 DictTool.MaxWords)) (COND ((NULL DictTool.LastWord) (SETQ DictTool.LastWord 0))) (SETQ minWord (ADD1 DictTool.LastWord)) [SETQ maxWord (COND ((EQ 0 DictTool.MaxWords) 0) (T (IPLUS DictTool.MaxWords DictTool.LastWord] (SETQ DictTool.LastWord maxWord)) (T (SETQ minWord 0) (SETQ maxWord DictTool.MaxWords) (SETQ DictTool.LastSearch synonymclasses) (SETQ DictTool.LastWord maxWord] (COND [(InvertedDict.Prop dict 'RemoteDict) (DICTCLIENT.SEARCHFORWORD synonymclasses DictTool.MinKeywords (OR minWord 0) (OR maxWord DictTool.MaxWords) (InvertedDict.Prop dict 'RemoteDict] ((SETQ VennSearchFn (InvertedDict.Prop dict 'VENNSEARCHFN)) (APPLY* VennSearchFn dict synonymclasses DictTool.MinKeywords (OR minWord 0) (OR maxWord DictTool.MaxWords))) (T (InvertedDict.MergeSearch dict synonymclasses DictTool.MinKeywords (OR minWord 0) (OR maxWord DictTool.MaxWords]) (NerdForStream [LAMBDA (stream) (* jtm%: "17-Nov-87 11:14") (* * comment) (COND ((STREAMPROP stream 'nerd)) ((STREAMPROP (Dict.OutputStream) 'nerd)) (T (TEdit.SetNerd (Dict.OutputStream]) (TEdit.SetNerd [LAMBDA (stream nerd) (* jtm%: "14-Oct-87 12:50") (* * sets the dictionary property for the window) (PROG (menuItems) (OR stream (SETQ stream (Dict.OutputStream))) [COND ((NULL nerd) [SETQ menuItems (for i in InvertedDict.List collect (LIST (InvertedDict.Name i) (LIST 'QUOTE i) (if (InvertedDict.Prop i 'RemoteDict) then "Calls the remote dictionary server"] [COND ((NULL menuItems)) ((EQ 1 (LENGTH menuItems)) (SETQ nerd (CAR InvertedDict.List))) (T (SETQ nerd (MENU (create MENU ITEMS _ menuItems TITLE _ "databases" CENTERFLG _ T] (COND ((NULL nerd) (SETQ nerd (STREAMPROP stream 'nerd)) (TEDIT.PROMPTPRINT stream (CONCAT "Database is " (AND nerd (InvertedDict.Name nerd)) ".") T) (RETURN] (TEDIT.PROMPTPRINT stream (CONCAT "Setting database to " (AND nerd (InvertedDict.Name nerd)) "...") T) (InvertedDict.Open nerd) (STREAMPROP stream 'nerd nerd) (TEDIT.PROMPTPRINT stream "done.") (SETQ DictTool.LastSearch NIL) (* so that you can do the same search  on a different data base.) ) nerd]) (DictTool.PromptForCutoff [LAMBDA (STREAM) (* jtm%: " 2-Feb-87 11:33") (OR STREAM (SETQ STREAM (Dict.OutputStream))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Current maximum = " DictTool.MaxWords ".") T) (SETQ DictTool.MaxWords (RNUMBER "Enter the maximum number of words that each combination of keywords may return. (0 = no limit)" )) (TEDIT.PROMPTPRINT STREAM (CONCAT "New maximum = " DictTool.MaxWords ".") T]) (DictTool.PromptForKeywordCutoff [LAMBDA (STREAM) (* jtm%: " 2-Feb-87 11:33") (OR STREAM (SETQ STREAM (Dict.OutputStream))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Current minimum = " DictTool.MinKeywords ".") T) (SETQ DictTool.MinKeywords (RNUMBER "Enter the minimum number of keywords that a word must have to be accepted. e.g. 2 = at least two keywords, 0 = all of the keywords given, -2 = all but two of the keywords given, etc." )) (TEDIT.PROMPTPRINT STREAM (CONCAT "New minimum = " DictTool.MinKeywords ".") T]) (PARSESELECTION [LAMBDA (selection) (* jtm%: "20-Mar-87 14:39") (LET (words temp) [for i charcode startPos alpha priorAlpha word from 1 to (ADD1 (NCHARS selection)) do (SETQ charcode (NTHCHARCODE selection i)) (SETQ priorAlpha alpha) [SETQ alpha (AND charcode (OR (ALPHACHARP charcode) (EQ charcode (CHARCODE -] [COND ((AND alpha (NULL priorAlpha)) (SETQ startPos i)) ((AND priorAlpha (NULL alpha)) (SETQ word (SUBSTRING selection startPos (SUB1 i))) (COND ((NULL temp) (push temp word)) (T (NCONC1 temp word] (COND ((EQ charcode (CHARCODE %()) (SETQ words (APPEND words temp)) (SETQ temp NIL)) ((EQ charcode (CHARCODE %))) (SETQ words (APPEND words (LIST temp))) (SETQ temp NIL] (SETQ words (APPEND words temp)) words]) ) (DEFINEQ (TEdit.PrintPhraseSearch [LAMBDA (stream dict words) (* jtm%: "26-May-87 09:26") (* * prints out the definitions that have a particular phrase in them.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (NerdForStream stream) 'DictTool.PrintPhraseSearch stream words "Type phrase to search for:" "Searching for phrase using" 'SEARCHPHRASE]) (DictTool.PrintPhraseSearch [LAMBDA (dict selection stream) (* jtm%: "26-May-87 09:29") (LET (looks words fn pos) [SETQ words (COND [(InvertedDict.Prop dict 'RemoteDict) (DICTCLIENT.SEARCHFORPHRASE selection (InvertedDict.Prop dict 'RemoteDict] ((SETQ fn (InvertedDict.Prop dict 'SEARCHFORPHRASEFN)) (APPLY* fn dict selection] (SETQ pos (TEDIT.GETPOINT stream)) (TEDIT.INSERT stream (CONCAT "%"" selection "%": ")) (SETQ looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) pos))) [for word on words do (TEDIT.INSERT stream (CONCAT (CAR word) (COND ((CDR word) "; ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (* do the looks last to avoid messing  up the text placement.) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) 1 (TEDIT.GETPOINT stream)) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) (CAR looks) (CDR looks)) words]) ) (DEFINEQ (TEdit.PrintSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T 'DictTool.PrintSynonyms stream words "synonym to look up:" "Getting synonyms for" 'USERSYNONYM]) (REMOVEALL [LAMBDA (X L) (* jtm%: "14-Oct-87 12:39") (for TAIL on X unless (EQUAL L (CAR TAIL)) collect (COND ((LISTP (CAR TAIL)) (REMOVEALL (CAR TAIL) L)) (T (COPY (CAR TAIL]) (CONVERTFUNCTIONSTOFORMS [LAMBDA (LIST) (* jtm%: "14-Oct-87 12:57") (for ELT in LIST collect (COND [(EQ (CAR ELT) 'FUNCTION) (LIST 'QUOTE (LIST (CADR ELT] ((LISTP ELT) (CONVERTFUNCTIONSTOFORMS ELT)) (T (COPY ELT]) (TEdit.PrintNounSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:43") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T (FUNCTION DictTool.PrintNounSynonyms) stream words "synonym to look up:" "Getting noun synonyms for" 'USERSYNONYM]) (DictTool.PrintNounSynonyms [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:32") (DictTool.PrintSynonyms dict words stream "n"]) (DictTool.PrintVerbSynonyms [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:34") (DictTool.PrintSynonyms dict words stream "v"]) (DictTool.PrintAdjSynonyms [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:35") (DictTool.PrintSynonyms dict words stream "adj"]) (TEdit.PrintVerbSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T 'DictTool.PrintVerbSynonyms stream words "synonym to look up:" "Getting verb synonyms for" 'USERSYNONYM]) (TEdit.PrintAdjSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T 'DictTool.PrintAdjSynonyms stream words "synonym to look up:" "Getting adjective synonyms for" 'USERSYNONYM]) (DictTool.PrintSynonyms [LAMBDA (dict words stream form) (* jtm%: "14-Oct-87 12:31") (PROG (synonyms found startPos headerPos endPos) (for word inside words do (SETQ synonyms (DICTCLIENT.SYNONYMS word)) (AND synonyms (SETQ found T)) (SETQ startPos (TEDIT.GETPOINT stream)) (TEDIT.INSERT stream (CONCAT word ": ")) (SETQ headerPos (TEDIT.GETPOINT stream)) [for class in synonyms when (OR (NULL form) (EQUAL form (CAR class))) do (TEDIT.INSERT stream (CONCAT (CAR class) ": ")) [for word on (CDR class) do (TEDIT.INSERT stream (CONCAT (CAR word) (COND ((CDR word) ", ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (SETQ endPos (TEDIT.GETPOINT stream)) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) startPos (IDIFFERENCE (SUB1 headerPos) startPos)) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) headerPos (IDIFFERENCE endPos headerPos)) (TEDIT.SETSEL stream endPos 0 'LEFT)) (RETURN found]) ) (DEFINEQ (DictTool.TEditWrapper [LAMBDA (dict proc stream selection promptString waitString cachePropName) (* jtm%: "29-Jun-88 09:56") (* * handles the TEdit user interface) (PROG (scratchStream textStream startPos startTime textObj) (* * set things up) [COND ((NULL stream) (SETQ stream (Dict.OutputStream] [COND ((NULL dict) (TEDIT.PROMPTPRINT stream "Please select a dictionary." T) (RETURN)) ((NULL selection) (SETQ selection (TEDIT.SEL.AS.STRING stream)) (COND ((ILEQ (NCHARS selection) 1) (SETQ selection NIL))) (* * "rht 4/27/88: No longer passes value of PROMPTWINDOW textprop to MOUSECONFIRM since it could be DON'T. Now looks for promptwindow on the WINDOWPROP of the stream's main window.") (COND [(AND selection (MOUSECONFIRM (CONCAT "CONFIRM INPUT: " selection) "" (CAR (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ stream))) 'PROMPTWINDOW] ([NULL (SETQ selection (TEDIT.GETINPUT stream (OR promptString "input: ") (AND cachePropName (STREAMPROP stream cachePropName] (TEDIT.PROMPTPRINT stream " Aborted." T) (RETURN] (* * print the results.) (SETQ startTime (CLOCK 0)) (AND cachePropName (STREAMPROP stream cachePropName selection)) (TEDIT.PROMPTPRINT stream (CONCAT (OR waitString "processing") " '" selection "' . . . ") T) [RESETSAVE (OUTPUT (CAR (WINDOWPROP Dict.DefWindow 'PROMPTWINDOW] (* redirects errors to the  promptwindow) [SETQ scratchStream (OPENTEXTSTREAM NIL NIL NIL NIL '(LEAVETTY] (COND [(APPLY* proc dict selection scratchStream) (TEDIT.INCLUDESTREAM (Dict.OutputStream) scratchStream) (COND (DictTool.TimeOperation (TEDIT.PROMPTPRINT stream (CONCAT "Elapsed Time: " (QUOTIENT (DIFFERENCE (CLOCK 0) startTime) 1000.0) " seconds."))) (T (TEDIT.PROMPTPRINT stream "Done."] (T (TEDIT.PROMPTPRINT stream "not found.") (TEDIT.PROMPTFLASH stream))) (CLOSEF scratchStream]) (Dict.OutputStream [LAMBDA (REGION) (* ; "Edited 12-Oct-88 09:20 by rmk:") (* ; "Edited 7-Oct-88 12:01 by jtm:") (LET (TEXTSTREAM HIDDENFN UNHIDEFN) [COND ((AND Dict.DefWindow (NOT (OPENWP Dict.DefWindow)) (WINDOWPROP Dict.DefWindow 'TEXTSTREAM)) (* window is shrunk.) (OPENW Dict.DefWindow)) ((AND Dict.DefWindow (CL:FIND-PACKAGE "ROOMS") (SETQ HIDDENFN (CL:FIND-SYMBOL "WINDOW-HIDDEN?" "ROOMS")) (GETD HIDDENFN) (CL:FUNCALL HIDDENFN Dict.DefWindow)) (* the FIND-SYMBOL calls are used to avoid a break that happens when you access  the ROOMS package when it hasn't been loaded.) (SETQ UNHIDEFN (CL:FIND-SYMBOL "UN-HIDE-WINDOW" "ROOMS")) (CL:FUNCALL UNHIDEFN Dict.DefWindow)) ((OR (NULL Dict.DefWindow) (NOT (OPENWP Dict.DefWindow))) (SETQ Dict.DefWindow (CREATEW [OR REGION (AND Dict.DefWindow (WINDOWPROP Dict.DefWindow 'REGION] "Definitions")) (SETQ TEXTSTREAM (OPENTEXTSTREAM NIL Dict.DefWindow)) (replace TXTFILE of (TEXTOBJ TEXTSTREAM) with "Definitions") (* do the replace before you spawn a TEDIT process in order to avoid a race  condition where sometimes the label on the icon was "T") (PROCESSPROP (TEDIT TEXTSTREAM Dict.DefWindow NIL '(LEAVETTY)) 'NAME 'DICTIONARY] (TEXTSTREAM Dict.DefWindow]) (DictTool.PromptStream [LAMBDA (stream) (* jtm%: "29-Sep-86 11:11") (COND [(STREAMPROP stream) (for window inside (STREAMPROP stream 'WINDOW) do (COND ((WINDOWPROP window 'PROMPTWINDOW) (RETURN (WINDOWPROP window ' PROMPTWINDOW] (T PROMPTWINDOW]) ) (DEFINEQ (DictTool.Init [LAMBDA (serverName) (* jtm%: "13-Oct-87 11:37") (PROG (analyzer dict wordNerd) (* * start up the interface) (Dict.AddCommands) (* * create the analyzer) [Analyzer.Establish (SETQ analyzer (create Morphalyzer analyzerName _ 'DictServer openFn _ (FUNCTION DictTool.OpenAnalyzer) closeFn _ (FUNCTION DictTool.Close) analyzeFn _ (FUNCTION DictTool.Analyze) correctionsFn _ (FUNCTION DictTool.Corrections] (Analyzer.Prop analyzer 'CountWords (FUNCTION DictTool.CountWords)) (* * create the dictionary) [Dict.Establish (SETQ dict (create Dict dictName _ 'DictServer openFn _ (FUNCTION DictTool.OpenDictionary) closeFn _ (FUNCTION DictTool.Close) getEntryFn _ (FUNCTION DictTool.GetEntry) printEntryFn _ (FUNCTION DictTool.PrintDefinition] (* * create the remote inverted dict.) [InvertedDict.Establish (SETQ wordNerd (create INVERTEDDICT INVERTEDDICTNAME _ 'DictServer] (InvertedDict.Prop wordNerd 'OPENFN (FUNCTION DictTool.OpenNerd)) (InvertedDict.Prop wordNerd 'DICTIONARY dict]) (DictTool.Open [LAMBDA (analyzer errors) (* jtm%: "13-Oct-87 10:43") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (analyzers dictionaries menuItems) (COND [(type? Morphalyzer analyzer) (COND ((NULL (Analyzer.Prop analyzer 'RemoteDict)) (SETQ analyzers (DictTool.Analyzers analyzer errors)) [SETQ menuItems (for i in analyzers collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Analyzer.Prop analyzer 'RemoteDict (CAR analyzers))) (T (Analyzer.Prop analyzer 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) " analyzers") CENTERFLG _ T)) (CAR analyzers))) (for i analyzerName in analyzers do (SETQ analyzerName (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) ": " i))) (COND ([NOT (for j in Analyzer.List thereis (EQ analyzerName ( Analyzer.Name j] (push Analyzer.List (create Morphalyzer copying analyzer)) (Analyzer.Prop (CAR Analyzer.List) 'RemoteDict i] ((type? Dict analyzer) (COND ((NULL (Dict.Prop analyzer 'RemoteDict)) (SETQ dictionaries (DictTool.Dictionaries analyzer errors)) [SETQ menuItems (for i in dictionaries collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Dict.Prop analyzer 'RemoteDict (CAR dictionaries))) (T (Dict.Prop analyzer 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Dict dictName) of analyzer) " dictionaries") CENTERFLG _ T)) (CAR dictionaries))) (for i dictName in dictionaries do (SETQ dictName (MKATOM (CONCAT (fetch (Dict dictName) of analyzer) ": " i))) (COND ([NOT (for j in Dict.DictionaryList thereis (EQ dictName (Dict.Name j] (push Dict.DictionaryList (create Dict copying analyzer)) (Dict.Prop (CAR Dict.DictionaryList) 'RemoteDict i]) (DictTool.OpenDictionary [LAMBDA (dict errors) (* jtm%: "13-Oct-87 10:38") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (dictionaries menuItems) (COND ((type? Dict dict) (COND ((NULL (Dict.Prop dict 'RemoteDict)) (SETQ dictionaries (DICTCLIENT.DICTIONARIES)) [SETQ menuItems (for i in dictionaries collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Dict.Prop dict 'RemoteDict (CAR dictionaries))) (T (Dict.Prop dict 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Dict dictName) of dict) " dictionaries") CENTERFLG _ T)) (CAR dictionaries))) (for i dictName in dictionaries do (SETQ dictName (MKATOM (CONCAT (fetch (Dict dictName) of dict) ": " i))) (COND ([NOT (for j in Dict.DictionaryList thereis (EQ dictName (Dict.Name j] (push Dict.DictionaryList (create Dict copying dict)) (Dict.Prop (CAR Dict.DictionaryList) 'RemoteDict i]) (DictTool.OpenAnalyzer [LAMBDA (analyzer errors) (* jtm%: "13-Oct-87 10:43") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (analyzers menuItems) (COND ((type? Morphalyzer analyzer) (COND ((NULL (Analyzer.Prop analyzer 'RemoteDict)) (SETQ analyzers (DICTCLIENT.LANGUAGES)) [SETQ menuItems (for i in analyzers collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Analyzer.Prop analyzer 'RemoteDict (CAR analyzers))) (T (Analyzer.Prop analyzer 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) " analyzers") CENTERFLG _ T)) (CAR analyzers))) (for i analyzerName in analyzers do (SETQ analyzerName (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) ": " i))) (COND ([NOT (for j in Analyzer.List thereis (EQ analyzerName ( Analyzer.Name j] (push Analyzer.List (create Morphalyzer copying analyzer)) (Analyzer.Prop (CAR Analyzer.List) 'RemoteDict i]) (DictTool.OpenNerd [LAMBDA (nerd errors) (* jtm%: "13-Oct-87 14:35") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (nerds menuItems dict remote) (COND ((type? INVERTEDDICT nerd) (COND ((NULL (InvertedDict.Prop nerd 'RemoteDict)) (SETQ nerds (DICTCLIENT.RESOURCES 'INDICES)) [SETQ menuItems (for i in nerds collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (InvertedDict.Prop nerd 'RemoteDict (CAR nerds))) (T [InvertedDict.Prop nerd 'RemoteDict (SETQ remote (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (INVERTEDDICT INVERTEDDICTNAME ) of nerd) " databases") CENTERFLG _ T)) (CAR nerds] (COND ((SETQ dict (InvertedDict.Prop nerd 'DICTIONARY)) (SETQ dict (COPYALL dict)) (Dict.Prop dict 'RemoteDict remote) (InvertedDict.Prop nerd 'DICTIONARY dict))) (for i in nerds do (COND ((NOT (InvertedDictFromName (fetch (INVERTEDDICT INVERTEDDICTNAME ) of nerd) i)) (push InvertedDict.List (create INVERTEDDICT copying nerd)) (InvertedDict.Prop (CAR InvertedDict.List) 'RemoteDict i) (COND ((SETQ dict (InvertedDict.Prop (CAR InvertedDict.List ) 'DICTIONARY)) (SETQ dict (COPYALL dict)) (Dict.Prop dict 'RemoteDict i) (InvertedDict.Prop (CAR InvertedDict.List) 'DICTIONARY dict]) (Dict.AddCommands [LAMBDA NIL (* ; "Edited 31-May-89 15:07 by jtm:") (* ; "Edited 31-May-89 15:06 by jtm:") (* ; "Edited 31-May-89 15:00 by jtm:") (* ; "Edited 31-May-89 13:36 by jtm:") (LET (menuItems) [SETQ menuItems '(Dictionary (FUNCTION TEdit.PrintDefinition) "Prints the definition of the selected word. Prompts the user for a word if there isn't a selection." (SUBITEMS (Set% Dictionary (FUNCTION TEdit.SetDictionary) "Gives the user a menu of dictionaries to select from." ) (Get% Definition (FUNCTION TEdit.PrintDefinition) "Prints the definition of the selected word. Prompts the user for a word if there isn't a selection." ) (Get% Synonyms (FUNCTION TEdit.PrintSynonyms) "Prints the synonyms of the selected word. Prompts the user for a word if there isn't a selection." (SUBITEMS (nouns (FUNCTION TEdit.PrintNounSynonyms) "Only prints the noun form synonyms." ) (verbs (FUNCTION TEdit.PrintVerbSynonyms) "Only prints the verb form synonyms.") (adjectives (FUNCTION TEdit.PrintAdjSynonyms) "Only prints the adjective form synonyms." ))) (|Search For Word| (FUNCTION TEdit.PrintSearch) "Prints the words in the dictionary containing at least two of the keywords in the selection. Prompts the user for keywords if there aren't any keywords selected." (SUBITEMS (Set% Database (FUNCTION TEdit.SetNerd) "Gives the user a menu of dictionaries to select from." ) (Max% Words (FUNCTION DictTool.PromptForCutoff) "Lets the user set the maximum number of words to be returned for a set of keywords." ) (Min% Keywords (FUNCTION DictTool.PromptForKeywordCutoff ) "Lets the user determine the minimum number of keywords needed by a word for it to accepted." ) (|Search For Phrase| (FUNCTION TEdit.PrintPhraseSearch) "Searches a dictionary for a particular phrase, using the Search For Word database to narrow the search. This can be an expensive operation, so please use it sparingly." ] (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU menuItems) (* ;; "add menu item to Lafite's display menu if Lafite has been loaded.") [COND ((BOUNDP '\LAFITE.ACTIVE) (pushnew LAFITE.EXTRA.DISPLAY.COMMANDS menuItems) (if \LAFITE.ACTIVE then (LAFITE.COMPUTE.CACHED.VARS] (PUTASSOC 'Dictionary (CONVERTFUNCTIONSTOFORMS (CDR menuItems)) BackgroundMenuCommands) (SETQ BackgroundMenu NIL]) (DictTool.Close [LAMBDA (analyzer) (* jtm%: "13-Nov-86 10:58") (CLOSEF DICTSERVERSTREAM]) ) (DEFINEQ (DictTool.Analyze [LAMBDA (analyzer stream fromLoc length analFn) (* jtm%: "14-Apr-87 14:16") (PROG (buffer bufferStream bufferLength char returnValue userWords (substring (ALLOCSTRING 0 32)) (maxBufferLength 5100) (offset fromLoc)) (SETQ userWords (Analyzer.Prop analyzer 'UserDict)) [COND ((NULL stream) NIL) [(STRINGP stream) (HELP "DictTool.Analyze not implemented for STRING") [SETQ returnValue (DICTCLIENT.PROOFREAD stream (Analyzer.Prop analyzer 'RemoteDict] (COND ((EQUAL 0 (CDR returnValue)) (RETURN (SETQ returnValue NIL] (T (* * break up the stream into strings of ~5000 characters.) (SETQ buffer (ALLOCSTRING (IMIN length maxBufferLength))) (SETQ bufferStream (OPENSTRINGSTREAM buffer 'OUTPUT)) (SETFILEPTR stream fromLoc) (while (IGREATERP length 0) do (SETFILEPTR bufferStream 0) (SETQ bufferLength 0) [do (SETQ char (BIN stream)) [COND ((OR (NOT (NUMBERP char)) (IGREATERP char 255)) (SETQ char (CHARCODE % ] (BOUT bufferStream char) (add length -1) (add bufferLength 1) (COND ((EQUAL length 0) (RETURN)) ((EQUAL bufferLength maxBufferLength) (RETURN)) ((IGREATERP bufferLength (IDIFFERENCE maxBufferLength 200)) (COND ([OR (EQ char (CHARCODE CR)) (AND (EQ char (CHARCODE SP)) (IGREATERP bufferLength (IDIFFERENCE maxBufferLength 50] (RETURN] [SETQ returnValue (DICTCLIENT.PROOFREAD (COND ((EQUAL bufferLength (NCHARS buffer) ) buffer) (T (SUBSTRING buffer 1 bufferLength substring))) (Analyzer.Prop analyzer 'RemoteDict] (COND ((EQUAL 0 (CDR returnValue)) (SETQ returnValue NIL) (add offset bufferLength)) ((AND userWords (Dict.GetEntry userWords (SUBSTRING buffer (ADD1 (CAR returnValue)) (IPLUS (CAR returnValue) (CDR returnValue)) substring))) [add length (IPLUS bufferLength (IMINUS (IPLUS (CAR returnValue) (CDR returnValue] (add offset (IPLUS (CAR returnValue) (CDR returnValue))) (SETFILEPTR stream offset) (SETQ returnValue NIL)) (returnValue (add (CAR returnValue) offset) (RETURN returnValue] (RETURN returnValue]) (DictTool.Analyzers [LAMBDA (analyzer errorStream) (* jtm%: "13-Nov-86 10:57") (* * wraps DictTool.RPCCall around a call to RemoteDict.Analyzers) (DICTCLIENT.LANGUAGES]) (DictTool.Pronunciation [LAMBDA (word dictName) (* jtm%: "13-Nov-86 10:58") [COND ((NOT (STRINGP word)) (SETQ word (MKSTRING word] [COND ((NULL dictName) (SETQ dictName 'AmericanHeritage] (DICTCLIENT.PRONUNCIATION word dictName]) (DictTool.Corrections [LAMBDA (analyzer stream loc len) (* jtm%: "13-Nov-86 10:58") (DICTCLIENT.CORRECTIONS (COND ((STRINGP stream) stream) (T (STREAM.FETCHSTRING stream loc len))) (Analyzer.Prop analyzer 'RemoteDict]) (DictTool.CountWords [LAMBDA (analyzer stream fromLoc length analFn) (* jtm%: "13-Nov-86 14:19") (PROG (buffer bufferStream bufferLength char (n 0) (substring (ALLOCSTRING 0 32)) (maxBufferLength 5100) (offset fromLoc)) [COND ((NULL stream) NIL) [(STRINGP stream) (HELP "DictTool.Analyze not implemented for STRING") [SETQ n (DICTCLIENT.PROOFREAD stream (Analyzer.Prop analyzer 'RemoteDict] (COND ((EQUAL 0 (CDR n)) (RETURN (SETQ n NIL] (T (* * break up the stream into strings of ~5000 characters.) (SETQ buffer (ALLOCSTRING (IMIN length maxBufferLength))) (SETQ bufferStream (OPENSTRINGSTREAM buffer 'OUTPUT)) (SETFILEPTR stream fromLoc) (while (IGREATERP length 0) do (SETFILEPTR bufferStream 0) (SETQ bufferLength 0) [do (SETQ char (BIN stream)) [COND ((OR (NOT (NUMBERP char)) (IGREATERP char 255)) (SETQ char (CHARCODE % ] (BOUT bufferStream char) (add length -1) (add bufferLength 1) (COND ((EQUAL length 0) (RETURN)) ((EQUAL bufferLength maxBufferLength) (RETURN)) ((IGREATERP bufferLength (IDIFFERENCE maxBufferLength 200)) (COND ([OR (EQ char (CHARCODE CR)) (AND (EQ char (CHARCODE SP)) (IGREATERP bufferLength (IDIFFERENCE maxBufferLength 50] (RETURN] [add n (DICTCLIENT.COUNTWORDS (COND ((EQUAL bufferLength (NCHARS buffer)) buffer) (T (SUBSTRING buffer 1 bufferLength substring) )) (Analyzer.Prop analyzer 'RemoteDict] (add offset bufferLength] (RETURN n]) ) (* * FINDWORD & SUBSTITUTEWORD) (DEFINEQ (DictTool.FindWord [LAMBDA (STREAM WORD CH) (* jtm%: "30-Apr-86 10:30") (* the TEDIT interface to FindWord) (PROG (SEL (TEXTOBJ (TEXTOBJ STREAM))) (* * prompt the user for a string if none is given.) [COND ((NULL WORD) (SETQ WORD (TEDIT.GETINPUT TEXTOBJ "Word to find: " (WINDOWPROP W ' TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC] (* * search for the word.) [COND (WORD (SETQ SEL (fetch SEL of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (LingFns.FindWord STREAM WORD CH)) (* * show the user what we found) (COND (CH (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (replace CH# of SEL with (CAR CH)) [replace DCH of SEL with (IPLUS (CAR CH) (IMINUS (CADR CH] (replace CHLIM of SEL with (ADD1 (CADR CH))) (replace POINT of SEL with 'RIGHT) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING WORD) (* And get it into the window) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found).") (\SHOWSEL SEL NIL T] (replace \INSERTNEXTCH of TEXTOBJ with -1]) (DictTool.SubstituteWord [LAMBDA (TEXTSTREAM PATTERN REPLACEMENT CONFIRM? DICTNAME) (* jtm%: "24-Mar-87 08:58") (* this procedure is a modification of  TEDIT.SUBSTITUTE.) (PROG (SEARCHSTRING REPLACESTRING ABORTFLG OUTOFRANGEFLG (TEXTOBJ (TEXTOBJ TEXTSTREAM)) ENDCHAR# STARTCHAR# RANGE (REPLACEDFLG 0) (YESLIST '("y" "Y" "yes" "Yes" "YES" "T")) CONFIRMFLG SEL PC# SELCH# SELCHLIM SELPOINT CRSEEN DICT) (COND ([NULL (SETQ SEARCHSTRING (OR PATTERN (TEDIT.GETINPUT TEXTOBJ "Search word:"] (* If the search pattern is empty,  bail out.) (TEDIT.PROMPTPRINT TEXTOBJ "[Aborted]") (RETURN))) (SETQ REPLACEMENT (OR REPLACEMENT (TEDIT.GETINPUT TEXTOBJ "Replace word:") "")) (* jtm%: use REPLACEMENT for the  original, REPLACESTRING for the  modified word.) (SETQ CRSEEN (STRPOS (CHARACTER (CHARCODE CR)) REPLACEMENT)) (* jtm%: use REPLACEMENT instead of  REPLACESTRING) (COND (PATTERN (* If a pattern is specd in the call,  use the caller's confirm flag.) (SETQ CONFIRMFLG CONFIRM?)) (T (* Otherwise, ask for one.) (SETQ CONFIRMFLG T) (* SETQ CONFIRMFLG (MEMBER  (TEDIT.GETINPUT TEXTOBJ  "Ask before each replace?" "Yes"  (CHARCODE (EOL SPACE ESCAPE LF TAB)))  YESLIST)) (* jtm%: change default to "Yes") )) (TEDIT.PROMPTPRINT TEXTOBJ "Substituting..." T) (SETQ DICT (DictTool.CreateConjugationMap DICTNAME SEARCHSTRING REPLACEMENT)) (SETQ SEL (fetch SEL of TEXTOBJ)) (* STARTCHAR# and ENDCHAR# are the  bound of the search) (\SHOWSEL SEL NIL NIL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* Turn off any blue pending delete) (SETQ STARTCHAR# (fetch CH# of SEL)) [SETQ ENDCHAR# (IPLUS STARTCHAR# (SUB1 (fetch DCH of SEL] (while (AND (SETQ RANGE (LingFns.FindWord TEXTSTREAM SEARCHSTRING STARTCHAR# DICT) (* jtm%: use FindWord for TEDIT.FIND) ) (NOT ABORTFLG)) do (SETQ REPLACESTRING (CADDR RANGE)) (* jtm%: add the suffix.) [PROG (PENDING.SEL CHOICE) (COND [CONFIRMFLG (SETQ PENDING.SEL (TEDIT.SETSEL TEXTSTREAM (CAR RANGE) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE))) 'RIGHT)) (TEDIT.SHOWSEL TEXTSTREAM T PENDING.SEL) (TEDIT.NORMALIZECARET TEXTOBJ SEL) [SETQ CHOICE (COND [(LISTP REPLACESTRING) (SETQ REPLACESTRING (MENU (create MENU ITEMS _ (CONS "*QUIT*" REPLACESTRING) CENTERFLG _ T CHANGEOFFSETFLG _ T TITLE _ "substitutions"] (T (TEDIT.GETINPUT TEXTOBJ (CONCAT "Substitute '" REPLACESTRING "'? ['q' quits]") "Yes" (CHARCODE (EOL SPACE ESCAPE LF TAB] (COND ((MEMBER CHOICE '("*QUIT*" "Q" "q")) (SETQ ABORTFLG T) (GO L1)) ((MEMBER CHOICE '(NIL "n" "N" "no" "NO")) (* turn off selection) (TEDIT.SHOWSEL TEXTSTREAM NIL PENDING.SEL) (RPLACA RANGE (IDIFFERENCE (CADR RANGE) (NCHARS REPLACESTRING))) (GO L1)) (T (* OK to replace) (TEDIT.DELETE TEXTSTREAM PENDING.SEL) (* make the replacement) (COND ((NOT (EQUAL REPLACESTRING "")) (* If the replacestring is nothing,  why bother to add nothing) (TEDIT.INSERT TEXTSTREAM REPLACESTRING (CAR RANGE)) [SETQ ENDCHAR# (IPLUS ENDCHAR# (IDIFFERENCE (NCHARS REPLACESTRING) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE] (add REPLACEDFLG 1] (T (* No confirmation required.  Do the substitutions without showing  intermediate work) (SETQ PC# (\DELETECH (CAR RANGE) (CADR RANGE) (ADD1 (IDIFFERENCE (CADR RANGE) (CAR RANGE))) TEXTOBJ)) (\FIXDLINES (fetch LINES of TEXTOBJ) SEL (CAR RANGE) (CADR RANGE) TEXTOBJ) [COND ((NOT (EQUAL REPLACESTRING "")) (* If the replacestring is nothing,  why bother to add nothing) (COND [CRSEEN (for ACHAR instring REPLACESTRING as NCH# from (CAR RANGE) by 1 do (SELCHARQ ACHAR (CR (\INSERTCR ACHAR NCH# TEXTOBJ)) (\INSERTCH ACHAR NCH# TEXTOBJ] (T (\INSERTCH REPLACESTRING (CAR RANGE) TEXTOBJ PC#))) (SETQ ENDCHAR# (IPLUS ENDCHAR# (IDIFFERENCE (NCHARS REPLACESTRING) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE] (add REPLACEDFLG 1))) L1 (SETQ STARTCHAR# (IPLUS (CAR RANGE) (NCHARS REPLACESTRING] (* start looking where you left off)) (COND ((ZEROP REPLACEDFLG) (TEDIT.PROMPTPRINT TEXTOBJ "No replacements made." T)) ((EQUAL REPLACEDFLG 1) (TEDIT.PROMPTPRINT TEXTOBJ "1 Replacement made." T)) (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (MKSTRING REPLACEDFLG) " Replacements made.") T))) (COND ((AND (NOT CONFIRMFLG) (NOT (ZEROP REPLACEDFLG))) (* There WERE replacements, and they  were not confirmed.) (replace CHLIM of SEL with ENDCHAR#) [replace DCH of SEL with (ADD1 (IDIFFERENCE (fetch CHLIM of SEL) (fetch CH# of SEL] (\TEDIT.MARK.LINES.DIRTY TEXTOBJ (fetch CH# of SEL) (fetch CHLIM of SEL)) (TEDIT.UPDATE.SCREEN TEXTOBJ) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (RETURN REPLACEDFLG]) (DictTool.CreateConjugationMap [LAMBDA (language word1 word2) (* jtm%: "24-Mar-87 09:06") (* * creates a conjugation dictionary that maps word1 into word2.) (PROG [fullconj1 fullconj2 pp1 pp2 prior (dict (SimpleDict.New 'map] [COND [word2 (SETQ fullconj1 (DICTCLIENT.CONJUGATE word1 NIL NIL language)) (SETQ fullconj2 (DICTCLIENT.CONJUGATE word2 NIL NIL language)) (SETQ pp1 (FASSOC 'pp fullconj1)) (SETQ pp2 (FASSOC 'pp fullconj2)) [COND [(AND pp1 (NULL pp2) (FASSOC 'v fullconj2)) (push fullconj2 (CONS 'pp (CDR (FASSOC 'pst fullconj2] ((AND pp2 (NULL pp1) (FASSOC 'v fullconj1)) (push fullconj1 (CONS 'pp (CDR (FASSOC 'pst fullconj1] (for conj1 conj2 entry in fullconj1 do (SETQ conj2 (FASSOC (CAR conj1) fullconj2)) (AND conj2 (for caps oldValue newValue in '(NONE FIRST ALL) do (SETQ entry (LingFns.Capitalize (CADR conj1) caps)) (SETQ oldValue (Dict.GetEntry dict entry)) (SETQ newValue (LingFns.Capitalize (CADR conj2) caps)) (SETQ newValue (COND ((for i inside oldValue thereis (STREQUAL i newValue)) oldValue) ((LISTP oldValue) (CONS newValue oldValue)) (oldValue (LIST newValue oldValue)) (T newValue))) (Dict.PutEntry dict entry newValue] (T (for conjugation in (DICTCLIENT.CONJUGATE word1 NIL language) do (for caps in '(NONE FIRST ALL) do (Dict.PutEntry dict (LingFns.Capitalize (CADR conjugation) caps) T] (RETURN dict]) (DictTool.FindWordInit [LAMBDA NIL (* jtm%: "26-Feb-87 13:46") (* * add items to TEDIT's menu.) [for ITEM on (fetch (MENU ITEMS) of TEDIT.DEFAULT.MENU) do (COND [(EQ (CAR ITEM) 'Find) (RPLACA ITEM '(Find 'Find NIL (SUBITEMS (FindWord (FUNCTION DictTool.FindWord) "Looks for a word independent of its inflection or capitalization." ] ((EQ (CAR ITEM) 'Substitute) (RPLACA ITEM '(Substitute 'Substitute NIL (SUBITEMS (SubstituteWord (FUNCTION DictTool.SubstituteWord) "Substitutes one word for another, keeping the same capitalization and inflectional form." ] (* * force the menu to be recomputed.) (COND ((EQ (fetch MENUCOLUMNS of TEDIT.DEFAULT.MENU) 1) (* If there is only one column, force  a re-figuring of the number of rows) (replace MENUROWS of TEDIT.DEFAULT.MENU with NIL)) ((EQ (fetch MENUROWS of TEDIT.DEFAULT.MENU) 1) (* There's only one row, so recompute  %# of columns.) (replace MENUCOLUMNS of TEDIT.DEFAULT.MENU with NIL))) (replace ITEMWIDTH of TEDIT.DEFAULT.MENU with 10000) (replace ITEMHEIGHT of TEDIT.DEFAULT.MENU with 10000) (replace IMAGE of TEDIT.DEFAULT.MENU with NIL) (* Force it to create a new menu  image.) (UPDATE/MENU/IMAGE TEDIT.DEFAULT.MENU]) ) (DEFINEQ (LingFns.FindWord [LAMBDA (STREAM WORD CH DICT) (* jtm%: "24-Mar-87 09:28") (* * finds the next instance of WORD in the text stream, independent of how it is  conjugated or capitalized. returns the first character index, the last character  index, the suffix, and the capitalization.) (PROG (CHAR NODE END EXPO FIRSTCHAR LASTCHAR U-FIRSTCHAR EOFPTR dictCreated) (* * build the dictionary) [COND (WORD (SETQ WORD (MKSTRING WORD)) [COND ((NULL DICT) (SETQ DICT (STREAMPROP STREAM 'FINDWORDMAP)) (COND ((EQUAL WORD (CAR DICT)) (SETQ DICT (CDR DICT))) (T (SETQ DICT (DictTool.CreateConjugationMap NIL WORD)) (STREAMPROP STREAM 'FINDWORDMAP (CONS WORD DICT] (* * initialize.) [COND ((NULL CH) (SETQ CH (TEDIT.GETPOINT STREAM] (SETQ CH (SUB1 CH)) (SETQ EOFPTR (GETEOFPTR STREAM)) (COND ((GREATERP CH EOFPTR) (RETURN)) (T (SETFILEPTR STREAM CH))) [SETQ FIRSTCHAR (CHCON1 (L-CASE (NTHCHAR WORD 1] [SETQ U-FIRSTCHAR (CHCON1 (U-CASE (NTHCHAR WORD 1] (* * search for a word that begins with the first letter.) (while (NEQ EOFPTR (GETFILEPTR STREAM)) do (SETQ LASTCHAR CHAR) (SETQ CHAR (BIN STREAM)) (COND ([AND [OR (NULL LASTCHAR) (AND (NUMBERP LASTCHAR) (NOT (ALPHACHARP LASTCHAR] (NUMBERP CHAR) (SETQ NODE (FASSOC (CHARACTER CHAR) (fetch (SimpleDict.Node subnodes) of (fetch (Dict contents) of DICT] (SETQ CH (GETFILEPTR STREAM)) [while NODE do (COND ((EQP EOFPTR (GETFILEPTR STREAM)) (SETQ END EOFPTR) (RETURN)) ([AND (SETQ CHAR (BIN STREAM)) (NUMBERP CHAR) (ALPHACHARP CHAR) (SETQ NODE (FASSOC (CHARACTER CHAR) (fetch (SimpleDict.Node subnodes) of NODE] (* is this a legal character?) ) (T (RETURN] (COND ((SETQ EXPO (fetch (SimpleDict.Node value) of NODE)) (RETURN] (* * we are done.) (RETURN (COND ((AND EXPO CH) [COND ((NULL END) (SETQ END (SUB1 (GETFILEPTR STREAM] (LIST CH END EXPO]) (LingFns.Capitalize [LAMBDA (word caps) (* jtm%: " 6-Aug-84 12:53") (* * capitalizes word according to the parameter "caps") (COND ((LISTP word) (for w in word collect (LingFns.Capitalize w caps))) (T (PROG (stringP litAtom) (COND ((STRINGP word) (SETQ word (UNPACK word)) (SETQ stringP T)) ((LITATOM word) (SETQ word (UNPACK word)) (SETQ litAtom T))) [SELECTQ caps (FIRST [COND ((NOT (U-CASEP (CAR word))) (RPLACA word (U-CASE (CAR word] [for char on (CDR word) do (COND ((U-CASEP (CAR char)) (RPLACA char (L-CASE (CAR char]) (ALL [for char on word do (COND ((NOT (U-CASEP (CAR char))) (RPLACA char (U-CASE (CAR char]) (for char on word do (COND ((U-CASEP (CAR char)) (RPLACA char (L-CASE (CAR char] [COND [stringP (SETQ word (MKSTRING (PACK word] (litAtom (SETQ word (PACK word] (RETURN word]) (LingFns.Capitalization [LAMBDA (word) (* jtm%: "18-Jul-84 15:19") (* * returns NIL, ALL or FIRST) (COND ([OR (NULL word) (NOT (U-CASEP (CAR word] NIL) ([OR (NULL (CDR word)) (NOT (U-CASEP (CADR word] 'FIRST) (T 'ALL]) ) (DictTool.FindWordInit) (RPAQ? DictTool.TimeOperation NIL) (RPAQ? Dict.DefWindow NIL) (RPAQ? Dict.CommandsAdded NIL) (RPAQ? InvertedDict.List NIL) (RPAQ? DictTool.LastSearch NIL) (RPAQ? DictTool.LastWord NIL) (RPAQ? TEdit.DefaultDictionary NIL) (RPAQ? DictTool.MinKeywords 2) (RPAQ? DictTool.MaxWords 100) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.MinKeywords DictTool.MaxWords DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary) ) (DictTool.Init) (RPAQQ PronunciationGuide (("q" "cat" "(kqt)") ("A" "pay" "(pA)") ("Q" "care" "(kQr)") ("*" "father" "(f*%"T5r)") ("b" "bike" "(bIk)") ("ch" "church" "(ch/rch)") ("d" "deed" "(dEd)") ("4" "pet" "(p4t)") ("E" "seed" "(sEd)") ("I" "fife" "(fIf)") ("g" "gag" "(gqg)") ("h" "hat" "(hqt)") ("hw" "which" "(hw9ch)") ("9" "pit" "(p9t)") ("I" "lie" "(lI)") ("7" "pier" "(p7r)") ("j" "judge" "(j8j)") ("k" "kick" "(k9k)") ("l" "lid" "(l9d)") ("l" "needle" "(nEd%"l)") ("m" "mum" "(m8m)") ("n" "no, sudden" "(nO)") ("ng" "thing" "(th9ng)") ("0" "pot" "(p0t)") ("O" "toe" "(tO)") ("" "paw" "(p)") ("oi" "noise" "(noiz)") ("ou" "out" "(out)") ("1" "book" "(b1k)") ("|" "boot" "(b|t)") ("p" "people" "(pE%"p5l)") ("r" "roar" "(rr)") ("s" "sauce" "(ss)") ("sh" "ship" "(sh9p)") ("t" "tight" "(tIt)") ("th" "thin" "(th9n)") ("T" "this" "(T9s)") ("8" "cut" "(k8t)") ("/" "urge" "(/rj)") ("v" "valve" "(vqlv)") ("w" "with" "(w9T, w9th)") ("y" "yes" "(y4s)") ("z" "zebra" "(zE%"br5)") ("zh" "vision" "(v9zh%"5n)") ("5" "about" "(5-bout%")") ("KH" "loch" "(l0KH, l0k)") ("N" "bon" "(b0n; French bN)."))) (RPAQQ PronunciationMap ((%" %') (5 ˙&f˙) (/ Ď u) (8 Ć u) (T Î t h) (%| Ĺ o Ĺ o) (1 Ć o Ć o) (% ˙ńŃ˙) (O Ĺ o) (0 Ć o) (7 ˙ńŔ˙) (I ˙ńż˙) (9 ˙ńž˙) (E Ĺ e) (4 Ć e) (* ˙ń§˙) (Q ˙ńŁ˙) (A Ĺ a) (q Ć a))) (PUTPROPS DICTTOOL COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5787 18593 (TEDIT.INCLUDESTREAM 5797 . 6308) (TEdit.PrintDefinition 6310 . 8564) ( DictTool.PrintDefinition 8566 . 11103) (Dict.PrintDefinition 11105 . 12068) (DictTool.GetEntry 12070 . 12369) (TEdit.SetDictionary 12371 . 14530) (DictForStream 14532 . 14899) (DictTool.Dictionaries 14901 . 15055) (PARSEBYCOLONS 15057 . 16106) (PrintPronunciationGuide 16108 . 17579) ( ConvertPronunciation 17581 . 18591)) (18594 27955 (TEdit.PrintSearch 18604 . 19054) ( DictTool.PrintSearch 19056 . 21319) (DictTool.MergeSearch 21321 . 23149) (NerdForStream 23151 . 23461) (TEdit.SetNerd 23463 . 25535) (DictTool.PromptForCutoff 25537 . 26084) ( DictTool.PromptForKeywordCutoff 26086 . 26734) (PARSESELECTION 26736 . 27953)) (27956 30011 ( TEdit.PrintPhraseSearch 27966 . 28428) (DictTool.PrintPhraseSearch 28430 . 30009)) (30012 34807 ( TEdit.PrintSynonyms 30022 . 30351) (REMOVEALL 30353 . 30853) (CONVERTFUNCTIONSTOFORMS 30855 . 31345) ( TEdit.PrintNounSynonyms 31347 . 31698) (DictTool.PrintNounSynonyms 31700 . 31884) ( DictTool.PrintVerbSynonyms 31886 . 32070) (DictTool.PrintAdjSynonyms 32072 . 32257) ( TEdit.PrintVerbSynonyms 32259 . 32601) (TEdit.PrintAdjSynonyms 32603 . 32948) (DictTool.PrintSynonyms 32950 . 34805)) (34808 40396 (DictTool.TEditWrapper 34818 . 38056) (Dict.OutputStream 38058 . 39852) ( DictTool.PromptStream 39854 . 40394)) (40397 58304 (DictTool.Init 40407 . 42137) (DictTool.Open 42139 . 45990) (DictTool.OpenDictionary 45992 . 47887) (DictTool.OpenAnalyzer 47889 . 50072) ( DictTool.OpenNerd 50074 . 53438) (Dict.AddCommands 53440 . 58153) (DictTool.Close 58155 . 58302)) ( 58305 65911 (DictTool.Analyze 58315 . 62363) (DictTool.Analyzers 62365 . 62595) ( DictTool.Pronunciation 62597 . 62917) (DictTool.Corrections 62919 . 63285) (DictTool.CountWords 63287 . 65909)) (65950 83282 (DictTool.FindWord 65960 . 67971) (DictTool.SubstituteWord 67973 . 78188) ( DictTool.CreateConjugationMap 78190 . 81065) (DictTool.FindWordInit 81067 . 83280)) (83283 89085 ( LingFns.FindWord 83293 . 87111) (LingFns.Capitalize 87113 . 88725) (LingFns.Capitalization 88727 . 89083))))) STOP \ No newline at end of file diff --git a/lispusers/DICTTOOL.TEDIT b/lispusers/DICTTOOL.TEDIT new file mode 100644 index 00000000..17d488c8 --- /dev/null +++ b/lispusers/DICTTOOL.TEDIT @@ -0,0 +1,16 @@ +XEROX DICTTOOL 2 4 1 DICTTOOL 1 4 By: Maxwell (Maxwell.pa@Xerox.com) Uses DICTCLIENT, ANALYZER INTERNAL INTRODUCTION DICTTOOL is the user's interface to the Dictionary Server. The Dictionary Server is a prototype of a shared network resource for providing a suite of dictionary-based capabilities to programs running on client workstations. It has on it the American Heritage dictionary, the Word Finder synonym package by Microlytics, a Proofreader, and the WordNerd, a package for searching for words based on their meaning. (Note: The American Heritage dictionary has been licensed to us by Houghton-Miflin for research purposes only, and so we have not made the Dictionary Server generally available. The Dictionary Server should only be used by people within PARC.) HOW TO USE DICTTOOL When you load the DICTTOOL, it automatically adds a new menu item named "Dictionary" to the TEdit menu and the Background menu. The "Dictionary" menu item has three sub-items: "Get Definition", "Get Synonyms", and "Search For Word". Here is how each one works: Get Definition If you make a selection in a TEdit document, and then invoke the "Get Definition" command in that document, then DictTool will ask for a confirmation and then fetch the definition for that word from the Dictionary Server, printing it in a separate window. If there is more than one entry in the American Heritage Dictionary for that word, then it will print the definitions one after another. The Dictionary Server knows how to find the root forms of words, and so "breathing" "breathes" and "breathe" will all give you the same entry. If there is no selection in the TEdit document, or if you deny the confirmation, or if instead of using the TEdit menu you use the Background menu, then DictTool will first prompt you for a word to look up and then fetch its definition. (Since it is very hard to make a null selection with TEdit, DictTool treats a one character selection as meaning "no selection". If you really want to look up a single letter in the dictionary, you can type it in when prompted for a word.) If you want to look up several definitions at once, separate the entries with semi-colons followed by spaces. (i.e. "camera; photography; motion picture"). Semi-colons are used as delimiters because some of the entries in the American Heritage Dictionary have spaces and commas in them (as in "motion picture"). It also makes it easier to look up words in the output of the WordNerd (see "Search For Word" below). Get Synonyms The interface for getting synonyms is exactly the same as the interface for getting definitions. If you make a selection, then DictTool will first confirm the selection and then print out the synonyms in the same window that the definitions are printed in. If you don't make a selection, then DictTool will first prompt you for a word. The format of the information printed out is a series of synonym classes separated by carriage returns. Each synonym class begins with the part of speech that its elements belong to. The elements themselves are separated by commas. Search For Word The interface to the WordNerd is a little different from the other interfaces. Instead of typing just one word in, you want to type a list of keywords separated by spaces. For instance, if you were looking for the word for a mechanical model of the solar system, you might type: Type keywords to search on: mechanical model solar system The WordNerd then searches for words that have at least two of these keywords in their definitions. The results would be sorted according to the number of keywords found, with the words having the most keywords printed first: mechanical model solar system: orrery mechanical solar system: mechanism model solar system: planetarium mechanical system: automation; bar1; component; degree of freedom; energy level; hookup; ignition; instrument; key1; linkwork; load; machine; neutral; perpetual motion; quantize; resonance; schematic; servomechanism; shafting; stress; suspension; unit solar system: Copernican; cosmic; Earth; Ganymede3; Jupiter2; Mars2; mercury; Milky Way; nebular hypothesis; Neptune3; Pallas; planet; planetesimal hypothesis; Pluto2; Saturn2; solar battery; space; sun; Uranus2; Venus2; Vesta2 (The numbers after some of the words mean that this is the nth entry of this word in the American Heritage Dictionary.) If there is a word in the list that you want to see the definition for, you can merely select it and get its definition with "Get Definition". In this case you would probably want to know what "orrery" means: or|re|ry n., pl. -ries. A mechanical model of the solar system. [After Charles Boyle (16761731), fourth Earl of Orrery, for whom one was made.] There is also a mechanism for indicating that two words are synonyms of one another, and hence should not be counted as separate keywords for the purpose of deciding whether a word has the minimum two keywords. All you need to do is put parentheses around the words in question. For instance if you were looking for the word for the little plastic thing on the end of a shoe lace, you might try: Type keywords to search on: (shoe lace shoelace) (end tip) And get in return: shoe+ end+: aglet; fall; heel1; lift; point; quarter; spike1; toe (A plus at the end of a word indicates a synonym class.) If you only give the DictTool one word, then it will print out all of the words in the dictionary that have that word in its definition. Max Words There are two sub-items in the "Search For Word" sub-menu: "Max Words" and "Min Keywords". The first sub-item, "Max Words", allows the user to specify the maximum number of words that should be returned on each search. DictTool is set up to only return 100 words at a time. If WordNerd finds more than a hundred words, then it truncates the list and indicates how many words it eliminated. If you want to see the words that were eliminated, just make the same request with the same keywords in the same order and the WordNerd will return the next 100 words. (If there is no selection in the document, then DictTool will prompt you with the last set of keywords so that this is easier.) However, if 100 words is too many or too few, you can change it with this menu item or by setting the global variable DictTool.MaxWords. Min Keywords DictTool is set up to only return a word if it has at least two of the user's keywords in its definition. If the user wants, he can raise or lower the minimum as he sees fit. The minimum only comes into play whenever the user gives more keywords than the minimum, otherwise the WordNerd looks for words that have at least one of the keywords in their definition. A minimum of 1 means that only one word has to match. A negative minimum means that the WordNerd will set the minimum relative to the number of keywords given. For instance, a minimum of -1 says that all but one of the keywords have to match for the word to be returned. A minimum of zero means that all of the words have to match. Search For Phrase The Search For Phrase command returns all of the entries in the American Heritage Dictionary that have a particular phrase in them. It does this with the help of the Search For Word command, which is why it is a sub-command of that command. Whenever you search for a phrase, the dictionary server first uses the Search For Word command to get the list of words in the dictionary that have all of the words of the phrase in it. It then looks up the definition of each of these words, and returns the words that have the phrase in their definition. This can be a very time-consuming operation, so you should use this command sparingly. But if you are concerned about locality and word order, then this command can save you a lot of time. PROOFREADING The Dictionary Server also provides proofreading facilities similar to the PROOFREADER package. The interface is exactly the same: there is a "Proofread" menu item on the TEdit menu which produces a special fixed menu for proofreading. The only difference is that all of the proofreading is done remotely on the server. You should only use the Dictionary Server for proofreading small documents; if you are going to do a lot of proofreading, it is better to use the PROOFREADER. (For more documentation on how to proofread, see PROOFREADER.) (LIST ((PAGE NIL (FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))),$$Č,,Č,ŠŠ8,Č ,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD  HELVETICA +TIMESROMAN + +TIMESROMAN + HELVETICA +MODERN +MODERN +MODERN +MODERN +MODERN MODERNLOGO  +  HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN +  HRULE.GETFNMODERN   HRULE.GETFNMODERN  $  Ąőߥ ? ă + éÖLZŽ! 5;‰ += žç " đzş \ No newline at end of file diff --git a/lispusers/DIGEST b/lispusers/DIGEST new file mode 100644 index 00000000..0b108c09 --- /dev/null +++ b/lispusers/DIGEST @@ -0,0 +1 @@ +(FILECREATED " 3-Jan-86 17:10:20" {ERIS}LIBRARY>DIGEST.;3 14384 changes to: (FNS DIGEST.FILE \DIGEST.FILE.FOR.TRANSMISSION \DIGEST.INITIALIZE \DIGEST.SEND.FILE.BYTES \DIGEST.SEND.PARAMETERS \DIGEST.WRITE \DIGEST.PREAMBLE \DIGEST.SEND.STRING \DIGEST.SEND.HEADER \DIGEST.SEND.PACKET) (MACROS \DIGEST.INCREMENT.SEQNO \DIGEST.DEFAULT.CHECKSUM \DIGEST.CTL \DIGEST.CHAR) (VARS DIGESTCOMS DIGEST.PACKET.TYPES \DIGESTOVLEN \DIGEST.INIT.PARAMETER.OFFSETS) previous date: " 3-Jan-86 16:49:25" {ERIS}LIBRARY>DIGEST.;1) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DIGESTCOMS) (RPAQQ DIGESTCOMS ((MACROS \DIGEST.CHAR \DIGEST.CTL \DIGEST.DEFAULT.CHECKSUM \DIGEST.INCREMENT.SEQNO) (VARS DIGEST.PACKET.TYPES \DIGEST.INIT.PARAMETER.OFFSETS \DIGESTOVLEN) (FNS DIGEST.FILE \DIGEST.FILE.FOR.TRANSMISSION \DIGEST.INITIALIZE \DIGEST.PREAMBLE \DIGEST.SEND.FILE.BYTES \DIGEST.SEND.HEADER \DIGEST.SEND.PACKET \DIGEST.SEND.PARAMETERS \DIGEST.SEND.STRING \DIGEST.WRITE) (RECORDS KERMITSTATE))) (DECLARE: EVAL@COMPILE (DEFMACRO \DIGEST.CHAR (X) (BQUOTE (IPLUS (\, X) 32))) (DEFMACRO \DIGEST.CTL (X) (BQUOTE (LOGAND (MASK.1'S 0 8) (LOGXOR , X 64)))) (DEFMACRO \DIGEST.DEFAULT.CHECKSUM (S) (BQUOTE (\KERMIT.CHAR (LOGAND (IPLUS (\, S) (FOLDLO (LOGAND (\, S) 192) 64)) (MASK.1'S 0 6))))) (DEFMACRO \DIGEST.INCREMENT.SEQNO (KERMITSTATE) (BQUOTE (change (fetch (KERMITSTATE CURRENTSEQNO) of (\, KERMITSTATE)) (IMOD (ADD1 DATUM) 64)))) ) (RPAQQ DIGEST.PACKET.TYPES ((DIGEST.DATA.PACKET (CHARCODE D)) (DIGEST.ACK.PACKET (CHARCODE Y)) (DIGEST.NAK.PACKET (CHARCODE N)) (DIGEST.SENDINIT.PACKET (CHARCODE S)) (DIGEST.BREAK.PACKET (CHARCODE B)) (DIGEST.FILEHEADER.PACKET (CHARCODE F)) (DIGEST.EOF.PACKET (CHARCODE Z)) (DIGEST.ERROR.PACKET (CHARCODE E)) (DIGEST.ILLEGAL.PACKET (CHARCODE T)) (DIGEST.GENERIC.SERVER.COMMAND (CHARCODE G)))) (RPAQQ \DIGEST.INIT.PARAMETER.OFFSETS ((\KPARM.MAXL 1) (\KPARM.TIME 2) (\KPARM.NPAD 3) (\KPARM.PADC 4) (\KPARM.EOL 5) (\KPARM.QCTL 6) (\KPARM.QBIN 7))) (RPAQQ \DIGESTOVLEN 5) (DEFINEQ (DIGEST.FILE (LAMBDA (INPUTFILE OUTPUTFILE) (* ejs: " 3-Jan-86 17:01") (* * Send a file to a remote kermit) (COND ((AND (SETQ INPUTFILE (INFILEP INPUTFILE)) OUTPUTFILE) (LET* ((KERMITSTATE (create KERMITSTATE EOL _(CHARCODE EOL) EOLCONVENTION _ NIL))) (\DIGEST.FILE.FOR.TRANSMISSION INPUTFILE OUTPUTFILE KERMITSTATE))) (OUTPUTFILE (ERROR "Can't find input file"))))) (\DIGEST.FILE.FOR.TRANSMISSION (LAMBDA (LOCALFILE REMOTEFILE KERMITSTATE) (* ejs: " 3-Jan-86 17:04") (* * Send a file) (LET ((OUTPUTSTREAM (COND ((STREAMP REMOTEFILE) REMOTEFILE) (T (OPENSTREAM REMOTEFILE (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY) (SEQUENTIAL T))))))) INPUTSTREAM) (\DIGEST.INITIALIZE KERMITSTATE OUTPUTSTREAM (QUOTE STORE)) (COND ((\DIGEST.PREAMBLE KERMITSTATE) (SETQ INPUTSTREAM (OPENSTREAM LOCALFILE (QUOTE INPUT) (QUOTE OLD) (QUOTE ((TYPE BINARY) (SEQUENTIAL T))))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM) (CLOSEF? STREAM))) INPUTSTREAM)) (\DIGEST.SEND.HEADER LOCALFILE KERMITSTATE) (\DIGEST.SEND.FILE.BYTES INPUTSTREAM KERMITSTATE)) (replace (KERMITSTATE STATE) of KERMITSTATE with (QUOTE COMPLETE))))))) (\DIGEST.INITIALIZE (LAMBDA (KERMITSTATE OUTPUTSTREAM FORWHAT) (* ejs: " 3-Jan-86 17:09") (with KERMITSTATE KERMITSTATE (SETQ CURRENTSEQNO 0) (SETQ OUTSTREAM OUTPUTSTREAM) (SETQ QBIN (CHARCODE &)) (SELECTQ FORWHAT (RECEIVE (SETQ STATE (QUOTE REC.INIT))) (STORE (SETQ STATE (QUOTE SEND.INIT))) (ERROR "Illegal Kermit operation" FORWHAT)) KERMITSTATE))) (\DIGEST.PREAMBLE (LAMBDA (KERMITSTATE) (* ejs: " 3-Jan-86 16:54") (LET (PARAMETER.PACKET) (SELECTQ (fetch (KERMITSTATE STATE) of KERMITSTATE) (REC.INIT (SETQ PARAMETER.PACKET (\KERMIT.GET.PACKET KERMITSTATE)) (SELECTC (NTHCHARCODE PARAMETER.PACKET KERMIT.PACKET.TYPE) (KERMIT.SENDINIT.PACKET (\KERMIT.PARSE.REMOTE.PARAMETERS PARAMETER.PACKET KERMITSTATE)) (KERMIT.ERROR.PACKET (HELP (\KERMIT.DATASECTION PARAMETER.PACKET))) (ERROR "Unexpected packet type: " PARAMETER.PACKET)) (LET ((QBIN (fetch (KERMITSTATE QBIN) of KERMITSTATE))) (SELECTC QBIN ((CHARCODE N) (replace (KERMITSTATE QBIN) of KERMITSTATE with NIL)) ((CHARCODE Y) (replace (KERMITSTATE QBIN) of KERMITSTATE with (CHARCODE &))) (COND ((OR (AND (GEQ QBIN 33) (LEQ QBIN 62)) (AND (GEQ QBIN 96) (LEQ QBIN 126))) (replace (KERMITSTATE QBIN) of KERMITSTATE with QBIN))))) (\DIGEST.SEND.PARAMETERS KERMITSTATE) (replace (KERMITSTATE STATE) of KERMITSTATE with (QUOTE REC.FILE))) (SEND.INIT (\DIGEST.SEND.PARAMETERS KERMITSTATE) (replace (KERMITSTATE STATE) of KERMITSTATE with (QUOTE SEND.FILE))) (HELP "Illegal Kermit state" (fetch (KERMITSTATE STATE) of KERMITSTATE)))))) (\DIGEST.SEND.FILE.BYTES (LAMBDA (FILESTREAM KERMITSTATE) (* ejs: " 3-Jan-86 17:02") (* * Send all the bytes of file) (replace (STREAM ENDOFSTREAMOP) of FILESTREAM with (FUNCTION (LAMBDA NIL -1))) (bind (PACKET _(ALLOCSTRING (fetch (KERMITSTATE MAXL) of KERMITSTATE))) (QCTL _(fetch (KERMITSTATE QCTL) of KERMITSTATE)) (QBIN _(fetch (KERMITSTATE QBIN) of KERMITSTATE)) DONE CHAR MASKEDCHAR DATASECTION FILLEDATASECTION MAXCHARS CHARINDEX first (SETQ DATASECTION (\KERMIT.DATASECTION PACKET)) (SETQ MAXCHARS (NCHARS DATASECTION)) until DONE as I from 1 do (for old CHARINDEX from 1 to MAXCHARS do (SETQ CHAR (BIN FILESTREAM)) (COND ((EQ -1 CHAR) (SETQ DONE T) (RETURN))) (COND ((AND QBIN (IGREATERP CHAR (MASK.1'S 0 7))) (SETQ MASKEDCHAR (LOGAND CHAR (MASK.1'S 0 7))) (COND ((OR (EQ CHARINDEX MAXCHARS) (AND (EQ CHARINDEX (SUB1 MAXCHARS)) (OR (ILESSP MASKEDCHAR (CHARCODE SPACE)) (EQ MASKEDCHAR QBIN) (EQ MASKEDCHAR QCTL) (EQ MASKEDCHAR (CHARCODE DEL))))) (* No room for possible quoted and controlified  character) (SETQ WAITINGCHAR CHAR) (RETURN))) (RPLCHARCODE DATASECTION CHARINDEX QBIN) (SETQ CHAR (LOGAND CHAR (MASK.1'S 0 7))) (add CHARINDEX 1))) (COND ((OR (ILESSP CHAR (CHARCODE SPACE)) (EQ CHAR QBIN) (EQ CHAR QCTL) (EQ CHAR (CHARCODE DEL))) (COND ((EQ CHARINDEX MAXCHARS) (* No room for both prefix and controlified character) (SETQ WAITINGCHAR CHAR) (RETURN))) (RPLCHARCODE DATASECTION CHARINDEX QCTL) (COND ((OR (EQ CHAR QBIN) (EQ CHAR QCTL))) (T (SETQ CHAR (\KERMIT.CTL CHAR)))) (add CHARINDEX 1))) (RPLCHARCODE DATASECTION CHARINDEX CHAR)) (SETQ FILLEDATASECTION (SUBSTRING DATASECTION 1 (SUB1 CHARINDEX) FILLEDATASECTION)) (COND ((NEQ 0 (NCHARS FILLEDATASECTION)) (\DIGEST.SEND.PACKET FILLEDATASECTION KERMIT.DATA.PACKET KERMITSTATE)) ((NOT DONE) (ERROR "No characters to send, but not done either." KERMITSTATE)))))) (\DIGEST.SEND.HEADER (LAMBDA (FILENAME KERMITSTATE) (* ejs: " 3-Jan-86 16:41") (* * Receive the file header, open the file according to TYPE, and return) (\DIGEST.SEND.PACKET (PACKFILENAME.STRING (QUOTE NAME) (FILENAMEFIELD FILENAME (QUOTE NAME)) (QUOTE EXTENSION) (FILENAMEFIELD FILENAME (QUOTE EXTENSION))) DIGEST.FILEHEADER.PACKET KERMITSTATE) (replace (KERMITSTATE STATE) of KERMITSTATE with (QUOTE SEND.DATA)))) (\DIGEST.SEND.PACKET (LAMBDA (CONTENTS TYPE KERMITSTATE SEQNO) (* ejs: " 3-Jan-86 16:40") (* * Send a packet and wait for the response) (DECLARE (USEDFREE KERMITSTATUSWINDOW)) (LET ((OUTSTREAM (fetch (KERMITSTATE OUTSTREAM) of KERMITSTATE)) (CURRENTSEQNO (fetch (KERMITSTATE CURRENTSEQNO) of KERMITSTATE)) ANSWER.PACKET LENGTH SEQ ANSWER.TYPE CHAR (CHECKSUM 0)) (\DIGEST.SEND.STRING CONTENTS TYPE KERMITSTATE SEQNO) (\DIGEST.INCREMENT.SEQNO KERMITSTATE)))) (\DIGEST.SEND.PARAMETERS (LAMBDA (KERMITSTATE) (* ejs: " 3-Jan-86 16:51") (LET ((MYPARAMETERS (ALLOCSTRING (CONSTANT (LENGTH \DIGEST.INIT.PARAMETER.OFFSETS))))) (RPLCHARCODE MYPARAMETERS \KPARM.MAXL (\KERMIT.CHAR 72)) (RPLCHARCODE MYPARAMETERS \KPARM.TIME (\KERMIT.CHAR 10)) (RPLCHARCODE MYPARAMETERS \KPARM.NPAD (\KERMIT.CHAR 0)) (RPLCHARCODE MYPARAMETERS \KPARM.PADC (\KERMIT.CHAR 0)) (RPLCHARCODE MYPARAMETERS \KPARM.EOL (\KERMIT.CHAR 0)) (RPLCHARCODE MYPARAMETERS \KPARM.QCTL (CHARCODE #)) (RPLCHARCODE MYPARAMETERS \KPARM.QBIN (CHARCODE &)) (SELECTQ (fetch (KERMITSTATE STATE) of KERMITSTATE) (REC.INIT (\DIGEST.SEND.PACKET MYPARAMETERS KERMIT.ACK.PACKET KERMITSTATE)) (SEND.INIT (\DIGEST.SEND.PACKET MYPARAMETERS DIGEST.SENDINIT.PACKET KERMITSTATE) ) (ERROR "Illegal Kermit state"))))) (\DIGEST.SEND.STRING (LAMBDA (STRING TYPE KERMITSTATE SEQNO) (* ejs: " 3-Jan-86 16:44") (* * Send a string of data to the remote kermit. The string MUST have been prefixified already) (LET* ((STREAM (fetch (KERMITSTATE OUTSTREAM) of KERMITSTATE)) (LENGTH (NCHARS STRING)) (PACKET (ALLOCSTRING (IPLUS LENGTH \DIGESTOVLEN))) (CHECKSUM 0) TEMP) (RPLCHARCODE PACKET KERMIT.PACKET.MARK (fetch (KERMITSTATE MARKCHAR) of KERMITSTATE)) (RPLCHARCODE PACKET KERMIT.PACKET.LEN (SETQ CHECKSUM (\DIGEST.CHAR (IPLUS LENGTH (CONSTANT (IDIFFERENCE \DIGESTOVLEN KERMIT.PACKET.LEN))))) ) (SETQ TEMP (\DIGEST.CHAR (OR SEQNO (fetch (KERMITSTATE CURRENTSEQNO) of KERMITSTATE) ))) (add CHECKSUM TEMP) (RPLCHARCODE PACKET KERMIT.PACKET.SEQ TEMP) (add CHECKSUM TYPE) (RPLCHARCODE PACKET KERMIT.PACKET.TYPE TYPE) (COND ((NEQ 0 LENGTH) (bind CHAR for I from \DIGESTOVLEN to (IPLUS LENGTH (CONSTANT (SUB1 \DIGESTOVLEN))) as J from 1 to LENGTH do (SETQ CHAR (NTHCHARCODE STRING J)) (COND ((ILESSP CHAR (CHARCODE SPACE)) (ERROR "Call to \KERMIT.SEND.STRING with unprefixed characters: " STRING)) ) (add CHECKSUM CHAR) (RPLCHARCODE PACKET I CHAR)))) (RPLCHARCODE PACKET (NCHARS PACKET) (\DIGEST.DEFAULT.CHECKSUM CHECKSUM)) (\DIGEST.WRITE PACKET KERMITSTATE) (replace (KERMITSTATE LASTPACKETOUT) of KERMITSTATE with PACKET) PACKET))) (\DIGEST.WRITE (LAMBDA (STRING KERMITSTATE) (* ejs: " 3-Jan-86 17:07") (* * Sends STRING out on STREAM with FORCEOUTPUT) (LET ((STREAM (fetch (KERMITSTATE OUTSTREAM) of KERMITSTATE)) PADC) (PRIN3 STRING STREAM) (TERPRI STREAM)))) ) [DECLARE: EVAL@COMPILE (DATATYPE KERMITSTATE ((LASTPACKETIN POINTER) (LASTPACKETOUT POINTER) (STATE POINTER) (INSTREAM POINTER) (OUTSTREAM POINTER) (EOLCONVENTION POINTER) (EOL POINTER) (QBIN POINTER) (TIME FIXP) (CURRENTSEQNO BYTE) (MARKCHAR BYTE) (MAXL BYTE) (NPAD BYTE) (PADC BYTE) (QCTL BYTE) (CHKT BYTE) (REPT BYTE)) CURRENTSEQNO _ 0 MARKCHAR _ KERMIT.DEFAULT.MARK.CHARACTER MAXL _ KERMIT.DEFAULT.RECV.PACKET.SIZE TIME _ KERMIT.DEFAULT.TIMEOUT.TIME NPAD _ KERMIT.DEFAULT.PAD.CHARS PADC _ KERMIT.DEFAULT.PAD.CHARACTER QCTL _ KERMIT.DEFAULT.PREFIX.CHARACTER EOL _ KERMIT.DEFAULT.EOL.CHARACTER) ] (/DECLAREDATATYPE (QUOTE KERMITSTATE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FIXP BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE)) (QUOTE ((KERMITSTATE 0 POINTER) (KERMITSTATE 2 POINTER) (KERMITSTATE 4 POINTER) (KERMITSTATE 6 POINTER) (KERMITSTATE 8 POINTER) (KERMITSTATE 10 POINTER) (KERMITSTATE 12 POINTER) (KERMITSTATE 14 POINTER) (KERMITSTATE 16 FIXP) (KERMITSTATE 14 (BITS . 7)) (KERMITSTATE 12 (BITS . 7)) (KERMITSTATE 10 (BITS . 7)) (KERMITSTATE 8 (BITS . 7)) (KERMITSTATE 6 (BITS . 7)) (KERMITSTATE 4 (BITS . 7)) (KERMITSTATE 2 (BITS . 7)) (KERMITSTATE 0 (BITS . 7)))) (QUOTE 18)) (PUTPROPS DIGEST COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (2343 12905 (DIGEST.FILE 2353 . 2857) (\DIGEST.FILE.FOR.TRANSMISSION 2859 . 3909) ( \DIGEST.INITIALIZE 3911 . 4383) (\DIGEST.PREAMBLE 4385 . 6032) (\DIGEST.SEND.FILE.BYTES 6034 . 8644) ( \DIGEST.SEND.HEADER 8646 . 9203) (\DIGEST.SEND.PACKET 9205 . 9765) (\DIGEST.SEND.PARAMETERS 9767 . 10781) (\DIGEST.SEND.STRING 10783 . 12574) (\DIGEST.WRITE 12576 . 12903))))) STOP \ No newline at end of file diff --git a/lispusers/DIGI-CLOCK b/lispusers/DIGI-CLOCK new file mode 100644 index 00000000..b3b4e7e0 --- /dev/null +++ b/lispusers/DIGI-CLOCK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "15-Mar-89 16:24:43" {ERIS}DOC>HACKS>DIGI-CLOCK.\;5 50813 |changes| |to:| (VARS DIGI-CLOCKCOMS) (FNS DC-DELETE-ALARM-SETTING DIGI-CLOCK DC-KILL-PROCESS DC-PROMPT-FOR-ALARM-MESSAGE DC-START-PROCESS DC-ADD-AUXW DC-SHAPE-TO-FIT DC-SET-ALARM) |previous| |date:| "22-Feb-89 16:50:15" {ERIS}DOC>HACKS>DIGI-CLOCK.\;4) ; Copyright (c) 1988, 1989 by XEROX Corporation. All rights reserved. (PRETTYCOMPRINT DIGI-CLOCKCOMS) (RPAQQ DIGI-CLOCKCOMS ( (* |;;| "Top level functions") (FNS DIGI-CLOCK DC-START-PROCESS DC-KILL-PROCESS DC-BUTTONEVENTFN DC-AUXW-BUTTONEVENTFN DC-SET-TIME-BUTTONEVENTFN ST) (* |;;| "Dc-buttoneventfns") (FNS DC-PROCESS DC-UPDATE DC-GET-OPERATION) (* |;;| "Auxw functions") (FNS DC-AUXW-GET-OPERATION DC-ADD-AUXW DC-DELETE-AUXW DC-AUXW-UPDATE) (* |;;| "Set time functions") (FNS DC-WARNING-TIME-NOT-SET) (FNS DC-SET-TIME DC-UPDATE-TIME-ITEM DC-VALID-DATE-P DC-SET-LAST-DAY-FOR-MONTH) (FNS DC-INITIALIZE-SET-TIME-MENU DC-MAKE-NEW-SET-TIME-MENU DC-OPEN-SET-TIME-MENUW) (FNS DC-EXTRACT-STARTING-SET-TIME-DATE DC-SET-TIME-MAKE-DATE-STRING) (FNS DC-SET-TIME-ZONE-HEADING DC-SET-TIME-ZONE DC-GET-TIME-ZONE) (* |;;| "Alarm functions") (FNS DC-SET-ALARM DC-ADD-ALARM-SETTING DC-DELETE-ALARM-SETTING) (FNS DC-ALARM-DUE-TO-RING? DC-RING-ALARM DC-TURN-ALARM-OFF) (FNS DC-PROMPT-FOR-ALARM-MESSAGE DC-GET-MESSAGE-WINDOW DC-CLOSE-MESSAGE-WINDOW) (* |;;| "Display & Misc functions") (FNS DC-DISPLAY-TIME DC-MAKE-DISPLAY-TIME-STRING DC-PRINT-JUSTIFIED-STRING DC-CONVERT-DATE-FORMAT DC-SHAPE-TO-FIT DC-GET-DATE DC-MENU-POSITION) (* |;;| "Font functions") (FNS DC-SET-FONT DC-FONT-FAMILY-MENU DC-FONT-SIZE-MENU DC-FONT-FACE-MENU) (* |;;| "List of the world's time zones") (VARS *DC-TIME-ZONE-LIST*) (* |;;| "Call digi-clock ") )) (* |;;| "Top level functions") (DEFINEQ (DIGI-CLOCK (LAMBDA (RESTART-FROM-SCRATCH) (* \; "Edited 22-Feb-89 16:21 by Mountford") (|if| (FIND.PROCESS "DIGITAL CLOCK") |then| (DEL.PROCESS "DIGITAL CLOCK")) (|if| (NOT (MEMBER "DIGITAL CLOCK" IDLE.SUSPEND.PROCESS.NAMES)) |then| (|push| IDLE.SUSPEND.PROCESS.NAMES "DIGITAL CLOCK")) (BLOCK) (ADD.PROCESS (LIST 'DC-START-PROCESS RESTART-FROM-SCRATCH) 'NAME "DIGITAL CLOCK" 'RESTARTABLE T))) (DC-START-PROCESS (LAMBDA (RESTART-FROM-SCRATCH) (* \; "Edited 17-Feb-89 16:04 by Mountford") (|if| (GREATERP (IDATE) 0) |then| (SETQ *DC-OLD-DATE* (DATE)) |else| (SETQ *DC-OLD-DATE* " 1-Jan-88 08:00:00")) (|if| (BOUNDP '*DC-WINDOW*) |then| (WINDOWPROP *DC-WINDOW* 'CLOSEFN (REMOVE 'DC-KILL-PROCESS (WINDOWPROP *DC-WINDOW* 'CLOSEFN))) (CLOSEW *DC-WINDOW*) (WINDOWPROP *DC-WINDOW* 'CLOSEFN 'DC-KILL-PROCESS)) (|if| (OR RESTART-FROM-SCRATCH (NOT (BOUNDP '*DC-WINDOW*)) (NULL *DC-WINDOW*)) |then| (SETQ *DC-WINDOW* (CREATEW (CREATEREGION 1 (IDIFFERENCE SCREENHEIGHT 46) 430 46))) (WINDOWPROP *DC-WINDOW* 'RESHAPEFN 'DON\'T) (SETQ *DC-DATEFORMAT* (DATEFORMAT SPACES NO.SECONDS DAY.OF.WEEK DAY.SHORT)) (WINDOWPROP *DC-WINDOW* 'BUTTONEVENTFN 'DC-BUTTONEVENTFN) (WINDOWPROP *DC-WINDOW* 'CLOSEFN 'DC-KILL-PROCESS) (SETQ *DC-AUXW-FONT* (FONTCREATE 'HELVETICA 18)) (SETQ *DC-FONT* (FONTCREATE 'HELVETICA 36)) (WINDOWPROP *DC-WINDOW* 'ALARM-MODE 'LOUD) (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE T) (DSPFONT *DC-FONT* *DC-WINDOW*) (DC-ADD-AUXW)) (DC-PROCESS))) (DC-KILL-PROCESS (LAMBDA NIL (* \; "Edited 22-Feb-89 16:16 by Mountford") (|if| (FIND.PROCESS "DIGITAL CLOCK") |then| (DEL.PROCESS "DIGITAL CLOCK")))) (DC-BUTTONEVENTFN (LAMBDA (WINDOW) (* \; "Edited 15-Aug-88 07:01 by Mountford") (|if| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE) |then| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE NIL) (TOTOPW WINDOW) (|if| (MOUSESTATE MIDDLE) |then| (SELECTQ (DC-GET-OPERATION) (* \; "") (|Set Font| (|if| (DC-SET-FONT) |then| (DC-UPDATE (IDATE)))) (|Set Time| (DC-SET-TIME)) (|Set Alarm| (DC-SET-ALARM)) (|Turn Alarm Off| (DC-TURN-ALARM-OFF) (DC-UPDATE (IDATE))) (|Delete Alarm Setting| (DC-DELETE-ALARM-SETTING)) (|Quiet Alarm| (WINDOWPROP *DC-WINDOW* 'ALARM-MODE 'QUIET)) (|Loud Alarm| (WINDOWPROP *DC-WINDOW* 'ALARM-MODE 'LOUD)) (|12-Hour Clock| (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE T) (DC-UPDATE (IDATE))) (|24-Hour Clock| (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE NIL) (DC-UPDATE (IDATE))) (|Set Local Time Zone| (DC-PRINT-JUSTIFIED-STRING *DC-WINDOW* "Select Local Time Zone" 'CENTER 'CLEARW) (DC-SET-TIME-ZONE WINDOW) (DC-UPDATE (IDATE))) (|Add New Regional Time Zone| (DC-ADD-AUXW)) (|Shape to Fit| (DC-SHAPE-TO-FIT *DC-WINDOW* (DC-MAKE-DISPLAY-TIME-STRING (DATE *DC-DATEFORMAT*) (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE ))) (DC-UPDATE (IDATE))) NIL)) (|if| (MOUSESTATE LEFT) |then| (DC-UPDATE (IDATE))) (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE T)))) (DC-AUXW-BUTTONEVENTFN (LAMBDA (WINDOW) (* \; "Edited 2-Sep-88 15:45 by Mountford") (|if| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE) |then| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE NIL) (TOTOPW WINDOW) (|if| (MOUSESTATE MIDDLE) |then| (SELECTQ (DC-AUXW-GET-OPERATION) (* \; "") (|Set Font for Aux Clocks| (|if| (DC-SET-FONT WINDOW 'ALL-AUXW) |then| (DC-UPDATE (IDATE)))) (|Set Aux Clock Font In Just This Window| (|if| (DC-SET-FONT WINDOW) |then| (DC-UPDATE (IDATE)))) (|Delete This Window| (DC-DELETE-AUXW WINDOW)) (|Set Time-Zone Heading| (DC-SET-TIME-ZONE-HEADING WINDOW) (DC-UPDATE (IDATE))) (|Set Regional Time Zone| (DC-SET-TIME-ZONE WINDOW) (DC-UPDATE (IDATE))) NIL)) (|if| (MOUSESTATE LEFT) |then| (DC-UPDATE (IDATE))) (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE T)))) (DC-SET-TIME-BUTTONEVENTFN (LAMBDA (ITEM MENU BUTTON) (* \; "Edited 15-Aug-88 07:16 by Mountford") (LET (DISPLAY-TIME) (COND ((EQ ITEM '|Set|) (CLOSEW *DC-SET-TIME-MENUW*) (|if| (WINDOWPROP *DC-SET-TIME-WINDOW* 'SETTING-ALARM) |then| (DC-ADD-ALARM-SETTING (DC-SET-TIME-MAKE-DATE-STRING)) |else| (SETTIME (DC-SET-TIME-MAKE-DATE-STRING)) (SETQ *DC-OLD-DATE* (DATE)) (|until| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE) |do| (BLOCK 1000)) (DC-UPDATE (IDATE)))) ((EQ ITEM '|Esc|) (CLOSEW *DC-SET-TIME-MENUW*)) (T (DC-UPDATE-TIME-ITEM ITEM) (SETQ DISPLAY-TIME (DC-CONVERT-DATE-FORMAT (DC-SET-TIME-MAKE-DATE-STRING) '(DATEFORMAT NO.SECONDS))) (SETQ DISPLAY-TIME (DC-MAKE-DISPLAY-TIME-STRING DISPLAY-TIME (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE))) (DC-PRINT-JUSTIFIED-STRING *DC-SET-TIME-WINDOW* DISPLAY-TIME 'CENTERED 'CLEARW)))))) (ST (LAMBDA (HOUR MINUTE DATE MONTH YEAR) (* \; "Edited 25-Jul-88 11:45 by Mountford") (|if| (NOT (BOUNDP '*DC-OLD-DATE*)) |then| (SETQ *DC-OLD-DATE* " 1-Jan-88 08:00:00")) (|if| (NOT HOUR) |then| (SETTIME *DC-OLD-DATE*) |else| (|if| (NOT MINUTE) |then| (SETQ MINUTE 0)) (|if| (NOT DATE) |then| (SETQ DATE (SUBSTRING *DC-OLD-DATE* 1 2))) (|if| (NOT MONTH) |then| (SETQ MONTH (SUBSTRING *DC-OLD-DATE* 4 6))) (|if| (NOT YEAR) |then| (SETQ YEAR (SUBSTRING *DC-OLD-DATE* 8 9))) (SETTIME (CONCAT MONTH "-" DATE "-" YEAR " " HOUR ":" MINUTE))) (CLRPROMPT) (SETQ *DC-OLD-DATE* (DATE)))) ) (* |;;| "Dc-buttoneventfns") (DEFINEQ (DC-PROCESS (LAMBDA NIL (* \; "Edited 15-Aug-88 06:52 by Mountford") (PROG NIL TOP (|if| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE) |then| (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE NIL) (DC-UPDATE (IDATE)) (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE T)) (BLOCK 60000) (* \; "BLOCK FOR A MINUTE") (GO TOP)))) (DC-UPDATE (LAMBDA (ITIME) (* \; "Edited 15-Aug-88 08:13 by Mountford") (LET ((MERIDIAN (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE)) (AUX-CLOCKS (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS))) (|if| (IGREATERP ITIME 0) |then| (DC-DISPLAY-TIME ITIME MERIDIAN) (|if| (DC-ALARM-DUE-TO-RING? ITIME) |then| (DC-RING-ALARM) (SETQ AUX-CLOCKS (CDR AUX-CLOCKS))) (|for| WINDOW |in| AUX-CLOCKS |do| (DC-AUXW-UPDATE ITIME MERIDIAN WINDOW)) |else| (DC-WARNING-TIME-NOT-SET))))) (DC-GET-OPERATION (LAMBDA NIL (* \; "Edited 13-Aug-88 10:40 by Mountford") (LET ((MENU-LIST (LIST '|Set Font| '|Set Time| '|Set Alarm| (|if| (EQ (WINDOWPROP *DC-WINDOW* 'ALARM-MODE) 'QUIET) |then| '|Loud Alarm| |else| '|Quiet Alarm|) (COND ((WINDOWPROP *DC-WINDOW* 'ALARM-RINGING) '|Turn Alarm Off|) ((WINDOWPROP *DC-WINDOW* 'ALARM-LIST) '|Delete Alarm Setting|) (T '||)) '|Shape to Fit| (|if| (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE) |then| '|24-Hour Clock| |else| '|12-Hour Clock|) '|Set Local Time Zone| '|Add New Regional Time Zone|))) (MENU (|create| MENU ITEMS _ MENU-LIST CENTERFLG _ T))))) ) (* |;;| "Auxw functions") (DEFINEQ (DC-AUXW-GET-OPERATION (LAMBDA NIL (* \; "Edited 2-Sep-88 13:53 by Mountford") (MENU (|create| MENU ITEMS _ '(|Delete This Window| (|Set Font for Aux Clocks| '|Set Font for Aux Clocks| NIL (SUBITEMS |Set Aux Clock Font In Just This Window| )) |Set Time-Zone Heading| |Set Regional Time Zone|) CENTERFLG _ T)))) (DC-ADD-AUXW (LAMBDA NIL (* \; "Edited 17-Feb-89 16:08 by Mountford") (LET ((AUXW) (ITIME (IDATE)) (MERIDIAN (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE)) (WINDOW-HEIGHT (HEIGHTIFWINDOW (FONTPROP *DC-AUXW-FONT* 'HEIGHT)))) (SETQ AUXW (CREATEW (CREATEREGION 1 (IDIFFERENCE SCREENHEIGHT WINDOW-HEIGHT) 430 WINDOW-HEIGHT) NIL NIL T)) (ATTACHWINDOW AUXW *DC-WINDOW* 'BOTTOM 'JUSTIFY) (DSPFONT *DC-AUXW-FONT* AUXW) (DC-PRINT-JUSTIFIED-STRING AUXW "Select Time Zone for this Window" 'CENTER 'CLEARW) (|if| (DC-SET-TIME-ZONE AUXW) |then| (WINDOWPROP AUXW 'BUTTONEVENTFN 'DC-AUXW-BUTTONEVENTFN) (DC-SHAPE-TO-FIT *DC-WINDOW* (DC-MAKE-DISPLAY-TIME-STRING (GDATE ITIME *DC-DATEFORMAT* ) MERIDIAN)) (|if| (IGREATERP ITIME 0) |then| (DC-AUXW-UPDATE ITIME MERIDIAN AUXW) |else| (DC-AUXW-UPDATE (IDATE *DC-OLD-DATE*) MERIDIAN AUXW)) |else| (DETACHWINDOW AUXW) (CLOSEW AUXW))))) (DC-DELETE-AUXW (LAMBDA (WINDOW) (* \; "Edited 25-Jul-88 06:59 by Mountford") (DETACHWINDOW WINDOW) (CLOSEW WINDOW) (LET ((WINDOW-LIST (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS))) (|for| W |in| WINDOW-LIST |do| (DETACHWINDOW W)) (|for| W |in| WINDOW-LIST |do| (ATTACHWINDOW W *DC-WINDOW* 'BOTTOM 'JUSTIFY))))) (DC-AUXW-UPDATE (LAMBDA (ITIME MERIDIAN WINDOW) (* \; "Edited 13-Aug-88 11:20 by Mountford") (LET ((LOCATION (WINDOWPROP WINDOW 'LOCATION)) (TIME-OFFSET (WINDOWPROP WINDOW 'TIME-ZONE-OFFSET)) REGIONAL-TIME DISPLAY-TIME) (SETQ REGIONAL-TIME (DC-GET-DATE *DC-DATEFORMAT* ITIME TIME-OFFSET)) (SETQ DISPLAY-TIME (DC-MAKE-DISPLAY-TIME-STRING REGIONAL-TIME MERIDIAN)) (DC-PRINT-JUSTIFIED-STRING WINDOW LOCATION 'LEFT 'CLEARW) (DC-PRINT-JUSTIFIED-STRING WINDOW DISPLAY-TIME 'RIGHT) DISPLAY-TIME))) ) (* |;;| "Set time functions") (DEFINEQ (DC-WARNING-TIME-NOT-SET (LAMBDA NIL (* \; "Edited 15-Aug-88 06:42 by Mountford") (LET ((WINDOWS (CONS *DC-WINDOW* (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS)))) (DC-PRINT-JUSTIFIED-STRING *DC-WINDOW* "Time not set." 'CENTER 'CLEARW) (|for| I |to| 10 |do| (|for| W |in| WINDOWS |do| (BLOCK 100) (INVERTW W) (BLOCK 100) (INVERTW W)))))) ) (DEFINEQ (DC-SET-TIME (LAMBDA NIL (* \; "Edited 25-Jul-88 07:25 by Mountford") (DC-INITIALIZE-SET-TIME-MENU) (WINDOWPROP *DC-SET-TIME-WINDOW* 'SETTING-ALARM NIL))) (DC-UPDATE-TIME-ITEM (LAMBDA (ITEM) (* \; "Edited 1-Aug-88 06:23 by Mountford") (LET ((CHANGE (CAR ITEM)) (ITEM (CADR ITEM))) (|if| (EQ CHANGE '+) |then| (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM (ADD1 (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM ))) (|if| (NOT (DC-VALID-DATE-P (DC-SET-TIME-MAKE-DATE-STRING))) |then| (COND ((EQ ITEM 'DY) (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY 1)) ((EQ ITEM 'MO) (|if| (IGREATERP (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO) 12) |then| (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO 1) |else| (DC-SET-LAST-DAY-FOR-MONTH))) ((EQ ITEM 'YR) (WINDOWPROP *DC-SET-TIME-WINDOW* 'YR 1)) ((OR (EQ ITEM 'HR) (EQ ITEM 'MIN)) (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM 0)) (T (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM (SUB1 (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM)))))) |else| (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM (SUB1 (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM)) ) (|if| (NOT (DC-VALID-DATE-P (DC-SET-TIME-MAKE-DATE-STRING))) |then| (COND ((EQ ITEM 'DY) (DC-SET-LAST-DAY-FOR-MONTH)) ((EQ ITEM 'MO) (|if| (ILESSP (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO) 1) |then| (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO 12) |else| (DC-SET-LAST-DAY-FOR-MONTH))) ((EQ ITEM 'YR) (WINDOWPROP *DC-SET-TIME-WINDOW* 'YR 99)) ((EQ ITEM 'HR) (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM 23)) ((EQ ITEM 'MIN) (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM 59)) (T (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM (ADD1 (WINDOWPROP *DC-SET-TIME-WINDOW* ITEM)))))))))) (DC-VALID-DATE-P (LAMBDA (DATE-STRING) (* \; "Edited 23-Jul-88 10:56 by Mountford") (|if| (IDATE DATE-STRING) |then| DATE-STRING))) (DC-SET-LAST-DAY-FOR-MONTH (LAMBDA NIL (* \; "Edited 31-Jul-88 14:54 by Mountford") (SELECTQ (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO) (2 (|if| (ZEROP (IREMAINDER (WINDOWPROP *DC-SET-TIME-WINDOW* 'YR) 4)) |then| (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY 29) |else| (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY 28))) ((4 6 9 11) (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY 30)) ((1 3 5 7 8 10 12) (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY 31)) NIL))) ) (DEFINEQ (DC-INITIALIZE-SET-TIME-MENU (LAMBDA NIL (* \; "Edited 14-Aug-88 21:35 by Mountford") (|if| (OR (NOT (BOUNDP '*DC-SET-TIME-MENUW*)) (NULL *DC-SET-TIME-MENUW*)) |then| (DC-MAKE-NEW-SET-TIME-MENU)) (LET ((MERIDIAN (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE)) DATE-STRING DISPLAY-TIME) (|if| (IGREATERP (IDATE *DC-OLD-DATE*) (IDATE)) |then| (SETQ DATE-STRING (DC-CONVERT-DATE-FORMAT *DC-OLD-DATE* '(NUMBER.OF.MONTH NO.SECONDS))) (SETQ DISPLAY-TIME (DC-CONVERT-DATE-FORMAT *DC-OLD-DATE* '(NO.SECONDS))) |else| (SETQ DATE-STRING (DATE (DATEFORMAT NUMBER.OF.MONTH NO.SECONDS))) (SETQ DISPLAY-TIME (DATE (DATEFORMAT NO.SECONDS)))) (SETQ DISPLAY-TIME (DC-MAKE-DISPLAY-TIME-STRING DISPLAY-TIME MERIDIAN)) (DC-OPEN-SET-TIME-MENUW) (DC-PRINT-JUSTIFIED-STRING *DC-SET-TIME-WINDOW* DISPLAY-TIME 'CENTERED 'CLEARW) (DC-EXTRACT-STARTING-SET-TIME-DATE DATE-STRING)))) (DC-MAKE-NEW-SET-TIME-MENU (LAMBDA NIL (* \; "Edited 31-Dec-00 16:10 by Mountford") (LET ((TITLE-FONT (FONTCREATE 'HELVETICA 12)) (MENU-FONT (FONTCREATE 'HELVETICA 18))) (SETQ *DC-SET-TIME-MENUW* (ADDMENU (|create| MENU ITEMS _ '((+ DY) (\ - DY) (+ MO) (\ - MO) (+ YR) (\ - YR) (+ HR) (\ - HR) (+ MIN) (\ - MIN) |Set| |Esc|) MENUROWS _ 2 MENUFONT _ MENU-FONT MENUTITLEFONT _ TITLE-FONT TITLE _ "DY MO YR HR MIN SET " WHENSELECTEDFN _ 'DC-SET-TIME-BUTTONEVENTFN))) (SETQ *DC-SET-TIME-WINDOW* (CREATEW (CREATEREGION LASTMOUSEX LASTMOUSEY 120 27) NIL NIL T)) (ATTACHWINDOW *DC-SET-TIME-WINDOW* *DC-SET-TIME-MENUW* 'TOP 'JUSTIFY) (DSPFONT MENU-FONT *DC-SET-TIME-WINDOW*)))) (DC-OPEN-SET-TIME-MENUW (LAMBDA NIL (* \; "Edited 25-Jul-88 07:33 by Mountford") (LET ((CLOCK-REGION (WINDOWPROP *DC-WINDOW* 'REGION))) (|if| (IGREATERP (IPLUS (CAR CLOCK-REGION) (CADDR CLOCK-REGION) 215) SCREENWIDTH) |then| (ATTACHWINDOW *DC-SET-TIME-MENUW* *DC-WINDOW* 'LEFT 'TOP) |else| (ATTACHWINDOW *DC-SET-TIME-MENUW* *DC-WINDOW* 'RIGHT 'TOP)) (DETACHWINDOW *DC-SET-TIME-MENUW*) (OPENW *DC-SET-TIME-MENUW*)))) ) (DEFINEQ (DC-EXTRACT-STARTING-SET-TIME-DATE (LAMBDA (DATE-STRING) (* \; "Edited 4-Aug-88 06:16 by Mountford") (|if| (EQUAL " " (SUBSTRING DATE-STRING 1 1)) |then| (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY (MKATOM (SUBSTRING DATE-STRING 2 2))) |else| (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY (MKATOM (SUBSTRING DATE-STRING 1 2)))) (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO (MKATOM (SUBSTRING DATE-STRING 4 5))) (WINDOWPROP *DC-SET-TIME-WINDOW* 'YR (MKATOM (SUBSTRING DATE-STRING 7 8))) (WINDOWPROP *DC-SET-TIME-WINDOW* 'HR (MKATOM (SUBSTRING DATE-STRING 10 11))) (WINDOWPROP *DC-SET-TIME-WINDOW* 'MIN (MKATOM (SUBSTRING DATE-STRING 13 14))))) (DC-SET-TIME-MAKE-DATE-STRING (LAMBDA NIL (* \; "Edited 25-Jul-88 07:31 by Mountford") (CONCAT (WINDOWPROP *DC-SET-TIME-WINDOW* 'MO) "-" (WINDOWPROP *DC-SET-TIME-WINDOW* 'DY) "-" (WINDOWPROP *DC-SET-TIME-WINDOW* 'YR) " " (WINDOWPROP *DC-SET-TIME-WINDOW* 'HR) ":" (WINDOWPROP *DC-SET-TIME-WINDOW* 'MIN)))) ) (DEFINEQ (DC-SET-TIME-ZONE-HEADING (LAMBDA (WINDOW) (* \; "Edited 20-Jul-88 23:42 by Mountford") (LET ((LOCATION (WINDOWPROP WINDOW 'LOCATION))) (CLEARW WINDOW) (MOVETOUPPERLEFT WINDOW) (WINDOWPROP WINDOW 'LOCATION (PROMPTFORWORD "Location Name: " LOCATION NIL WINDOW NIL 'TTY (CHARCODE (EOL ESCAPE LF TAB))))))) (DC-SET-TIME-ZONE (LAMBDA (WINDOW) (* \; "Edited 25-Jul-88 06:54 by Mountford") (LET ((TIME-ZONE-INFO (DC-GET-TIME-ZONE))) (|if| TIME-ZONE-INFO |then| (|if| (EQ WINDOW *DC-WINDOW*) |then| (SETQ |\\TimeZoneComp| (CDR TIME-ZONE-INFO)) (|for| W |in| (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS) |do| (WINDOWPROP W 'TIME-ZONE-OFFSET (ITIMES 3600 (IDIFFERENCE (WINDOWPROP W 'TIME-ZONE) |\\TimeZoneComp|)))) |else| (WINDOWPROP WINDOW 'LOCATION (CAR TIME-ZONE-INFO)) (WINDOWPROP WINDOW 'TIME-ZONE (CDR TIME-ZONE-INFO)) (WINDOWPROP WINDOW 'TIME-ZONE-OFFSET (ITIMES 3600 (IDIFFERENCE (CDR TIME-ZONE-INFO) |\\TimeZoneComp|))))) TIME-ZONE-INFO))) (DC-GET-TIME-ZONE (LAMBDA NIL (* \; "Edited 20-Jul-88 23:23 by Mountford") (|if| (AND (BOUNDP 'TIME-ZONE-MENU) TIME-ZONE-MENU) |then| (MENU TIME-ZONE-MENU) |else| (MENU (SETQ TIME-ZONE-MENU (|create| MENU TITLE _ "ENTER TIME ZONE" ITEMS _ *DC-TIME-ZONE-LIST* CENTERFLG _ T)))))) ) (* |;;| "Alarm functions") (DEFINEQ (DC-SET-ALARM (LAMBDA NIL (* \; "Edited 17-Feb-89 15:28 by Mountford") (* |;;| "The time and alarm are actually set by DC-SET-TIME-BUTTONEVENTFN.") (DC-INITIALIZE-SET-TIME-MENU) (WINDOWPROP *DC-SET-TIME-WINDOW* 'SETTING-ALARM T))) (DC-ADD-ALARM-SETTING (LAMBDA (DATE-STRING) (* \; "Edited 15-Aug-88 07:29 by Mountford") (LET ((MESSAGE-WINDOW (DC-GET-MESSAGE-WINDOW)) (ALARM-LIST (WINDOWPROP *DC-WINDOW* 'ALARM-LIST)) (ITIME (IDATE DATE-STRING)) MESSAGE ALARM-DATE) (SETQ MESSAGE (DC-PROMPT-FOR-ALARM-MESSAGE MESSAGE-WINDOW)) (WINDOWPROP *DC-WINDOW* 'ALARM-LIST (|push| ALARM-LIST (CONS ITIME MESSAGE))) (SETQ DATE-STRING (DC-CONVERT-DATE-FORMAT DATE-STRING (DATEFORMAT SPACES NO.SECONDS))) (SETQ DATE-STRING (DC-MAKE-DISPLAY-TIME-STRING DATE-STRING (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE))) (SETQ ALARM-DATE (CONCAT "Alarm set for: " DATE-STRING)) (DC-PRINT-JUSTIFIED-STRING MESSAGE-WINDOW ALARM-DATE 'CENTERED 'CLEARW)))) (DC-DELETE-ALARM-SETTING (LAMBDA NIL (* \; "Edited 22-Feb-89 16:50 by Mountford") (LET ((MENU-LIST '("CLEAR ALL")) NEW-ALARM-LIST DELETE-ITEM) (|for| ITEM |in| (WINDOWPROP *DC-WINDOW* 'ALARM-LIST) |do| (|push| MENU-LIST (CONCAT (DC-GET-DATE *DC-DATEFORMAT* (CAR ITEM)) " - " (CDR ITEM)))) (SETQ DELETE-ITEM (MENU (|create| MENU ITEMS _ MENU-LIST))) (|if| (EQUAL DELETE-ITEM "CLEAR ALL") |then| (WINDOWPROP *DC-WINDOW* 'ALARM-LIST NIL) |else| (SETQ DELETE-ITEM (IDATE (SUBSTRING DELETE-ITEM 1 15))) (|for| ITEM |in| (WINDOWPROP *DC-WINDOW* 'ALARM-LIST) |do| (|if| (NOT (EQP (CAR ITEM) DELETE-ITEM)) |then| (|push| NEW-ALARM-LIST ITEM))) (WINDOWPROP *DC-WINDOW* 'ALARM-LIST NEW-ALARM-LIST))))) ) (DEFINEQ (DC-ALARM-DUE-TO-RING? (LAMBDA (ITIME) (* \; "Edited 25-Jul-88 06:56 by Mountford") (* |;;;| "Routine looks to see if the alarm is ringing. If it is, it rings bells and then prints out at associated message. If the alarm isn't ringing, and there is a list of alarm times, it iterates down the list looking to see if it is time for the alarm to ring. If it is time for the alarm to ring it simply substitutes NIL for the date in the alarm list. The list is rebuilt once when the alarm is turned off. The reason for doing it this way is so that the list isn't being rebuilt every time the clock looks to see if the alarm is set and so that the alarm times can be in any order. Ie. they don't have to be in chronological order. ") (PROG ((ALARM-RINGING (WINDOWPROP *DC-WINDOW* 'ALARM-RINGING)) (ALARM-LIST (WINDOWPROP *DC-WINDOW* 'ALARM-LIST))) (COND (ALARM-RINGING (RETURN T)) (ALARM-LIST (|for| ALARM |in| ALARM-LIST |do| (|if| (IGEQ ITIME (CAR ALARM)) |then| (WINDOWPROP *DC-WINDOW* 'ALARM-RINGING ALARM) (RPLACA ALARM NIL) (RETURN T)))))))) (DC-RING-ALARM (LAMBDA NIL (* \; "Edited 25-Jul-88 06:57 by Mountford") (LET ((ALARM-MESSAGE (CDR (WINDOWPROP *DC-WINDOW* 'ALARM-RINGING))) (MESSAGE-WINDOW (DC-GET-MESSAGE-WINDOW))) (DC-PRINT-JUSTIFIED-STRING MESSAGE-WINDOW ALARM-MESSAGE 'CENTERED 'CLEARW) (|if| (EQ (WINDOWPROP *DC-WINDOW* 'ALARM-MODE) 'LOUD) |then| (RINGBELLS) |else| (|for| I |to| 30 |do| (VIDEOCOLOR (NOT (VIDEOCOLOR))) (BLOCK 110)))))) (DC-TURN-ALARM-OFF (LAMBDA (ITEM MENU BUTTON) (* \; "Edited 25-Jul-88 06:53 by Mountford") (LET ((TEMP-ALARM-LIST)) (|for| ALARM |in| (WINDOWPROP *DC-WINDOW* 'ALARM-LIST) |do| (|if| (CAR ALARM) |then| (SETQ TEMP-ALARM-LIST (APPEND TEMP-ALARM-LIST (LIST ALARM))))) (WINDOWPROP *DC-WINDOW* 'ALARM-LIST TEMP-ALARM-LIST) (WINDOWPROP *DC-WINDOW* 'ALARM-RINGING NIL) (DC-CLOSE-MESSAGE-WINDOW)))) ) (DEFINEQ (DC-PROMPT-FOR-ALARM-MESSAGE (LAMBDA (MESSAGE-WINDOW) (* \; "Edited 22-Feb-89 16:19 by Mountford") (LET (MESSAGE) (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE NIL) (CLEARW MESSAGE-WINDOW) (MOVETOUPPERLEFT WINDOW) (SETQ MESSAGE (PROMPTFORWORD " Message: " "No Message" NIL MESSAGE-WINDOW NIL 'TTY (CHARCODE (EOL ESCAPE LF TAB)))) (WINDOWPROP *DC-WINDOW* 'CAN-UPDATE T) MESSAGE))) (DC-GET-MESSAGE-WINDOW (LAMBDA NIL (* \; "Edited 25-Jul-88 07:07 by Mountford") (OR (CAR (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS)) (LET ((MESSAGE-WINDOW (CREATEW (CREATEREGION 1 (IDIFFERENCE SCREENHEIGHT 25) 430 30)))) (ATTACHWINDOW MESSAGE-WINDOW *DC-WINDOW* 'BOTTOM 'JUSTIFY) (WINDOWPROP MESSAGE-WINDOW 'MESSAGE-WINDOW T) (DSPFONT *DC-AUXW-FONT* MESSAGE-WINDOW) MESSAGE-WINDOW)))) (DC-CLOSE-MESSAGE-WINDOW (LAMBDA NIL (* \; "Edited 25-Jul-88 06:58 by Mountford") (LET ((MESSAGE-WINDOW (CAR (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS)))) (|if| (WINDOWPROP MESSAGE-WINDOW 'MESSAGE-WINDOW) |then| (DETACHWINDOW MESSAGE-WINDOW) (CLOSEW MESSAGE-WINDOW))))) ) (* |;;| "Display & Misc functions") (DEFINEQ (DC-DISPLAY-TIME (LAMBDA (ITIME MERIDIAN) (* \; "Edited 1-Aug-88 08:00 by Mountford") (LET* ((LOCAL-TIME (DC-GET-DATE *DC-DATEFORMAT* ITIME)) (DISPLAY-TIME (DC-MAKE-DISPLAY-TIME-STRING LOCAL-TIME MERIDIAN))) (DC-PRINT-JUSTIFIED-STRING *DC-WINDOW* DISPLAY-TIME 'CENTERED 'CLEARW)))) (DC-MAKE-DISPLAY-TIME-STRING (LAMBDA (DATE-STRING MERIDIAN) (* \; "Edited 15-Aug-88 09:18 by Mountford") (LET ((DISPLAY-TIME DATE-STRING) (HOUR (MKATOM (SUBSTRING DATE-STRING 11 12)))) (* |;;|  "If *DC-DATEFORMAT* is changed to number.of.month, it causes the clock to break in 12-hour mode.") (|if| MERIDIAN |then| (LET ((DAY (SUBSTRING DATE-STRING 16))) (COND ((ZEROP HOUR) (SETQ DISPLAY-TIME (CONCAT (SUBSTRING DATE-STRING 1 10) "12" (SUBSTRING DATE-STRING 13 15) "am"))) ((ILESSP HOUR 10) (SETQ DISPLAY-TIME (CONCAT (SUBSTRING DATE-STRING 1 10) " " (SUBSTRING DATE-STRING 12 15) "am"))) ((ILESSP HOUR 12) (SETQ DISPLAY-TIME (CONCAT (SUBSTRING DATE-STRING 1 15) "am"))) ((EQP HOUR 12) (SETQ DISPLAY-TIME (CONCAT (SUBSTRING DATE-STRING 1 15) "pm"))) ((ILESSP HOUR 22) (SETQ DISPLAY-TIME (CONCAT (SUBSTRING DATE-STRING 1 10) " " (IDIFFERENCE HOUR 12) (SUBSTRING DATE-STRING 13 15) "pm"))) (T (SETQ DISPLAY-TIME (CONCAT (SUBSTRING DATE-STRING 1 10) (IDIFFERENCE HOUR 12) (SUBSTRING DATE-STRING 13 15) "pm")))) (|if| DAY |then| (SETQ DISPLAY-TIME (CONCAT DISPLAY-TIME DAY))))) (|if| (EQUAL " " (SUBSTRING DISPLAY-TIME 1 1)) |then| (SETQ DISPLAY-TIME (SUBSTRING DISPLAY-TIME 2))) DISPLAY-TIME))) (DC-PRINT-JUSTIFIED-STRING (LAMBDA (WINDOW STRING JUSTIFICATION CLEARW?) (* \; "Edited 15-Aug-88 06:41 by Mountford") (LET ((STRING-WIDTH (STRINGWIDTH STRING WINDOW)) (WINDOW-WIDTH (WINDOWPROP WINDOW 'WIDTH))) (|if| CLEARW? |then| (CLEARW WINDOW)) (MOVETOUPPERLEFT WINDOW) (COND ((IGREATERP STRING-WIDTH WINDOW-WIDTH) (DC-SHAPE-TO-FIT *DC-WINDOW* STRING) (SETQ WINDOW-WIDTH (WINDOWPROP WINDOW 'WIDTH)))) (COND ((EQ JUSTIFICATION 'LEFT) (SETQ STRING (CONCAT " " STRING))) ((EQ JUSTIFICATION 'RIGHT) (SETQ STRING (CONCAT STRING " ")) (SETQ STRING-WIDTH (IPLUS 3 (STRINGWIDTH STRING WINDOW))) (DSPXPOSITION (IDIFFERENCE WINDOW-WIDTH STRING-WIDTH) WINDOW)) ('CENTER (DSPXPOSITION (IQUOTIENT (IDIFFERENCE WINDOW-WIDTH STRING-WIDTH) 2) WINDOW))) (PRINTOUT WINDOW STRING)))) (DC-CONVERT-DATE-FORMAT (LAMBDA (DATE-STRING NEW-FORMAT-LIST) (* \; "Edited 25-Jul-88 11:50 by Mountford") (|if| (EQ (CAR NEW-FORMAT-LIST) 'DATEFORMAT) |then| (GDATE (IDATE DATE-STRING) NEW-FORMAT-LIST) |else| (GDATE (IDATE DATE-STRING) (CONS 'DATEFORMAT NEW-FORMAT-LIST))))) (DC-SHAPE-TO-FIT (LAMBDA (WINDOW STRING) (* \; "Edited 17-Feb-89 16:12 by Mountford") (LET ((WINDOW-LIST (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS)) (STRING-WIDTH (STRINGWIDTH (CONCAT " " STRING) WINDOW)) (HEIGHT (HEIGHTIFWINDOW (FONTPROP WINDOW 'HEIGHT))) (REGION (WINDOWPROP WINDOW 'REGION)) STRING-WIDTH AUXW-STRING-WIDTH AUXW-HEIGHT X Y) (WINDOWPROP WINDOW 'RESHAPEFN NIL) (|for| AUXW |in| WINDOW-LIST |do| (DETACHWINDOW AUXW) (SETQ AUXW-STRING-WIDTH (STRINGWIDTH (CONCAT (WINDOWPROP AUXW 'LOCATION) " " STRING) AUXW)) (|if| (IGREATERP AUXW-STRING-WIDTH STRING-WIDTH) |then| (SETQ STRING-WIDTH AUXW-STRING-WIDTH))) (SETQ X (CAR REGION)) (SETQ Y (CADR REGION)) (SETQ WIDTH (WIDTHIFWINDOW STRING-WIDTH)) (SHAPEW WINDOW (LIST X Y WIDTH HEIGHT)) (SETQ AUXW-HEIGHT (HEIGHTIFWINDOW (FONTPROP (CAR WINDOW-LIST) 'HEIGHT))) (|for| AUXW |in| WINDOW-LIST |do| (SHAPEW AUXW (LIST X Y WIDTH AUXW-HEIGHT)) (ATTACHWINDOW AUXW *DC-WINDOW* 'BOTTOM 'JUSTIFY)) (WINDOWPROP *DC-WINDOW* 'RESHAPEFN 'DON\'T)))) (DC-GET-DATE (LAMBDA (DATEFORMAT ITIME OFFSET) (* \; "Edited 1-Aug-88 07:55 by Mountford") (|if| ITIME |then| (|if| OFFSET |then| (GDATE (IDIFFERENCE ITIME OFFSET) DATEFORMAT) |else| (GDATE ITIME DATEFORMAT)) |else| (|if| OFFSET |then| (GDATE (IDIFFERENCE (IDATE) OFFSET) DATEFORMAT) |else| (GDATE (IDATE) DATEFORMAT))))) (DC-MENU-POSITION (LAMBDA (MENU) (* \; "Edited 11-Aug-88 06:14 by Mountford") (LET ((WINDOW-REGION (WINDOWPROP *DC-WINDOW* 'REGION)) (MENU-HEIGHT (CADDDR (MENUREGION MENU)))) (CONS (IPLUS (CAR WINDOW-REGION) (CADDR WINDOW-REGION)) (IDIFFERENCE (IPLUS (CADR WINDOW-REGION) (CADDDR WINDOW-REGION)) MENU-HEIGHT))))) ) (* |;;| "Font functions") (DEFINEQ (DC-SET-FONT (LAMBDA (WINDOW ALL-AUXW-P) (* \; "Edited 2-Sep-88 15:44 by Mountford") (LET ((FAMILY (DC-FONT-FAMILY-MENU)) (SIZE (DC-FONT-SIZE-MENU)) (FACE (DC-FONT-FACE-MENU)) OLD-FONT NEW-FONT) (|if| (NOT (AND FAMILY SIZE FACE)) |then| (|if| WINDOW |then| (SETQ OLD-FONT (DSPFONT NIL WINDOW)) |else| (SETQ OLD-FONT (DSPFONT NIL *DC-WINDOW*))) (|if| (NOT FAMILY) |then| (SETQ FAMILY (FONTPROP OLD-FONT 'FAMILY))) (|if| (NOT SIZE) |then| (SETQ SIZE (FONTPROP OLD-FONT 'SIZE))) (|if| (NOT FACE) |then| (SETQ FACE (FONTPROP OLD-FONT 'FACE)))) (DC-PRINT-JUSTIFIED-STRING *DC-WINDOW* "Fetching Font" 'CENTER 'CLEARW) (SETQ NEW-FONT (FONTCREATE FAMILY SIZE FACE NIL NIL 'NOERRORFLG)) (|if| NEW-FONT |then| (COND (ALL-AUXW-P (SETQ *DC-AUXW-FONT* NEW-FONT) (|for| AUXW |in| (WINDOWPROP *DC-WINDOW* 'ATTACHEDWINDOWS) |do| (DSPFONT *DC-AUXW-FONT* AUXW))) (WINDOW (DSPFONT NEW-FONT WINDOW)) (T (SETQ *DC-FONT* NEW-FONT) (DSPFONT *DC-FONT* *DC-WINDOW*))) (DC-SHAPE-TO-FIT *DC-WINDOW* (DC-MAKE-DISPLAY-TIME-STRING (GDATE (IDATE) *DC-DATEFORMAT*) (WINDOWPROP *DC-WINDOW* '12-HOUR-MODE))) |else| (DC-PRINT-JUSTIFIED-STRING *DC-WINDOW* "Font Not Found" 'CENTER 'CLEARW)) NEW-FONT))) (DC-FONT-FAMILY-MENU (LAMBDA NIL (* \; "Edited 13-Aug-88 11:01 by Mountford") (|if| (OR (NOT (BOUNDP '*DC-FONT-FAMILY-MENU*)) (NULL *DC-FONT-FAMILY-MENU*)) |then| (SETQ *DC-FONT-FAMILY-MENU* (|create| MENU ITEMS _ '((|Titan| 'TITAN) (|Hippo| 'HIPPO) (|Gacha| 'GACHA) (|Classic| 'CLASSIC) (|BoldPS| 'BOLDPS) (|Modern| 'MODERN) (|Terminal| 'TERMINAL) (|Helvetica| 'HELVETICA) (|Helveticad| 'HELVETICAD) ("Old English" 'OLDENGLISH) ("Letter Gothic" 'LETTERGOTHIC) ("Times Roman" 'TIMESROMAN) ("Times Romand" 'TIMESROMAND)) CENTERFLG _ T TITLE _ " Font "))) (MENU *DC-FONT-FAMILY-MENU* (DC-MENU-POSITION *DC-FONT-FAMILY-MENU*)))) (DC-FONT-SIZE-MENU (LAMBDA NIL (* \; "Edited 13-Aug-88 10:52 by Mountford") (|if| (OR (NOT (BOUNDP '*DC-FONT-SIZE-MENU*)) (NULL *DC-FONT-SIZE-MENU*)) |then| (SETQ *DC-FONT-SIZE-MENU* (|create| MENU ITEMS _ '(6 7 8 9 10 11 12 14 16 18 24 26 30 36 72) MENUCOLUMNS _ 3 TITLE _ " Size "))) (MENU *DC-FONT-SIZE-MENU* (DC-MENU-POSITION *DC-FONT-SIZE-MENU*)))) (DC-FONT-FACE-MENU (LAMBDA NIL (* \; "Edited 11-Aug-88 06:46 by Mountford") (|if| (OR (NOT (BOUNDP '*DC-FONT-FACE-MENU*)) (NULL *DC-FONT-FACE-MENU*)) |then| (SETQ *DC-FONT-FACE-MENU* (|create| MENU ITEMS _ '((|Bold| 'BRR) (|Italic| 'MIR) ("Bold Italic" 'BIR) (|Regular| 'MRR)) TITLE _ " Face " CENTERFLG _ T))) (MENU *DC-FONT-FACE-MENU* (DC-MENU-POSITION *DC-FONT-FACE-MENU*)))) ) (* |;;| "List of the world's time zones") (RPAQQ *DC-TIME-ZONE-LIST* (("Nome, Alaska" '("Nome, Alaska: " . 11) '(-180 . -165)) ("Honolulu, Hawaii" '("Honolulu, Hawaii: " . 10) '(-165 . -150)) ("Marquesas Islands" '("Marquesas Islands: " . 9) '(-150 . -135)) ("San Francisco, California" '("San Francisco, California: " . 8) '(-135 . -120)) ("Denver, Colorado" '("Denver, Colorado: " . 7) '(-120 . -105)) ("Houston, Texas" '("Houston, Texas: " . 6) '(-105 . -90)) ("Washington DC" '("Washington DC: " . 5) '(-90 . -75)) ("Buenos Aires, Argentina" '("Buenos Aires, Argentina: " . 4) '(-75 . -60)) ("Brasilia, Brasil" '("Brasilia, Brasil: " . 3) '(-60 . -45)) ("Rio de Janeiro, Brasil" '("Rio de Janeiro, Brasil: " . 2) '(-45 . -30)) ("Reykjavik, Iceland" '("Reykjavik, Iceland: " . 1) '(-30 . -15)) ("Greenwich, England" '("Greenwich, England: " . 0) '(-15 . 0)) ("Paris, France" '("Paris, France: " . -1) '(0 . 15)) ("Athens, Greece" '("Athens, Greece: " . -2) '(15 . 30)) ("Moscow, USSR" '("Moscow, USSR: " . -3) '(30 . 45)) ("Riyadh, Arabia" '("Riyadh, Arabia: " . -4) '(45 . 60)) ("Kabul, Afganistan" '("Kabul, Afganistan: " . -5) '(60 . 75)) ("Kathmandu, Nepal" '("Kathmandu, Nepal: " . -6) '(75 . 90)) ("Bangkok, Thailand" '("Bangkok, Thailand:" . -7) '(90 . 105)) ("Hong Kong" '("Hong Kong: " . -8) '(105 . 120)) ("Seoul, South Korea" '("Seoul, South Korea: " . -9) '(120 . 135)) ("Tokyo, Japan" '("Tokyo, Japan: " . -10) '(135 . 150)) ("Sydney Austrailia" '("Sydney Austrailia:" . -11) '(150 . 165)) ("Aukland, New Zealand" '("Aukland, New Zealand: " . -12) '(165 . 180)))) (* |;;| "Call digi-clock ") (PUTPROPS DIGI-CLOCK COPYRIGHT ("XEROX Corporation" 1988 1989)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3028 11522 (DIGI-CLOCK 3038 . 3527) (DC-START-PROCESS 3529 . 5030) (DC-KILL-PROCESS 5032 . 5254) (DC-BUTTONEVENTFN 5256 . 7915) (DC-AUXW-BUTTONEVENTFN 7917 . 9437) ( DC-SET-TIME-BUTTONEVENTFN 9439 . 10705) (ST 10707 . 11520)) (11560 13964 (DC-PROCESS 11570 . 12052) ( DC-UPDATE 12054 . 12752) (DC-GET-OPERATION 12754 . 13962)) (13999 17168 (DC-AUXW-GET-OPERATION 14009 . 14636) (DC-ADD-AUXW 14638 . 16136) (DC-DELETE-AUXW 16138 . 16552) (DC-AUXW-UPDATE 16554 . 17166)) ( 17207 17833 (DC-WARNING-TIME-NOT-SET 17217 . 17831)) (17834 21892 (DC-SET-TIME 17844 . 18067) ( DC-UPDATE-TIME-ITEM 18069 . 21076) (DC-VALID-DATE-P 21078 . 21276) (DC-SET-LAST-DAY-FOR-MONTH 21278 . 21890)) (21893 25094 (DC-INITIALIZE-SET-TIME-MENU 21903 . 23106) (DC-MAKE-NEW-SET-TIME-MENU 23108 . 24463) (DC-OPEN-SET-TIME-MENUW 24465 . 25092)) (25095 26274 (DC-EXTRACT-STARTING-SET-TIME-DATE 25105 . 25817) (DC-SET-TIME-MAKE-DATE-STRING 25819 . 26272)) (26275 28480 (DC-SET-TIME-ZONE-HEADING 26285 . 26761) (DC-SET-TIME-ZONE 26763 . 27951) (DC-GET-TIME-ZONE 27953 . 28478)) (28516 30916 ( DC-SET-ALARM 28526 . 28830) (DC-ADD-ALARM-SETTING 28832 . 29756) (DC-DELETE-ALARM-SETTING 29758 . 30914)) (30917 33527 (DC-ALARM-DUE-TO-RING? 30927 . 32382) (DC-RING-ALARM 32384 . 32995) ( DC-TURN-ALARM-OFF 32997 . 33525)) (33528 34968 (DC-PROMPT-FOR-ALARM-MESSAGE 33538 . 34034) ( DC-GET-MESSAGE-WINDOW 34036 . 34586) (DC-CLOSE-MESSAGE-WINDOW 34588 . 34966)) (35013 42503 ( DC-DISPLAY-TIME 35023 . 35386) (DC-MAKE-DISPLAY-TIME-STRING 35388 . 37966) (DC-PRINT-JUSTIFIED-STRING 37968 . 39058) (DC-CONVERT-DATE-FORMAT 39060 . 39452) (DC-SHAPE-TO-FIT 39454 . 41404) (DC-GET-DATE 41406 . 42016) (DC-MENU-POSITION 42018 . 42501)) (42538 47425 (DC-SET-FONT 42548 . 44456) ( DC-FONT-FAMILY-MENU 44458 . 46056) (DC-FONT-SIZE-MENU 46058 . 46622) (DC-FONT-FACE-MENU 46624 . 47423) )))) STOP \ No newline at end of file diff --git a/lispusers/DIGI-CLOCK.TEDIT b/lispusers/DIGI-CLOCK.TEDIT new file mode 100644 index 00000000..e228d2ef Binary files /dev/null and b/lispusers/DIGI-CLOCK.TEDIT differ diff --git a/lispusers/DINFO b/lispusers/DINFO new file mode 100644 index 00000000..056c76fe --- /dev/null +++ b/lispusers/DINFO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Oct-87 10:11:04" {ERINYES}LYRIC>DINFO.;4 63282 changes to%: (VARS DINFOCOMS) (FNS DINFO.UPDATE.GRAPH.DISPLAY DINFO.TOGGLE.GRAPH) (FUNCTIONS DINFOGRAPHPROP) previous date%: "14-Sep-87 12:00:05" {ERINYES}LYRIC>DINFO.;2) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DINFOCOMS) (RPAQQ DINFOCOMS ((FILES TEDIT GRAPHER) (RECORDS DINFOGRAPH DINFONODE) (FUNCTIONS DINFOGRAPHPROP) (FNS (* ; "Primary functions") DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP) (FNS (* ; "Koto compatability") DINFO.READ.KOTO.GRAPH) (FNS (* ; "Window functions") DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN) (FNS (* ; "FreeMenu functions") DINFO.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY DINFO.TOGGLE.TEXT) (FNS (* ; "Other menu functions") DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY DINFO.HISTORIC.UPDATE) (FNS (* ; "Interface to GRAPHER") DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH) (FNS (* ; "Interface to TEdit") DINFO.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL DINFO.GET.FILENAME) (ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH) "Open a DInfo window for browsing documentation." ))) (VARS (BackgroundMenu)) (INITVARS (DINFO.GRAPHS) (DINFOMODES '(TEXT GRAPH)) (DINFO.HISTORY.LENGTH 20) (\DINFO.MAX.MENU.LEN 10)) (GLOBALVARS DINFO.GRAPH.FILES DINFOMODES DINFO.HISTORY.LENGTH \DINFO.MAX.MENU.LEN) (PROP (FILETYPE) DINFO))) (FILESLOAD TEDIT GRAPHER) (DECLARE%: EVAL@COMPILE (DATATYPE DINFOGRAPH (NAME NODELST TOPNODEID CURRENTNODE USERDATA TEXTPROPS FREEMENUITEMS LOOKUPFN MENUFN DEFAULTHOST DEFAULTDEVICE DEFAULTDIR MONITORLOCK DINFO.MENU WINDOW MENUFONT FMENU.WINDOW GRAPH.WINDOW HISTORY.MENU.WINDOW SUBNODE.MENU.WINDOW LAST.TEXT LAST.INVERTED.NODE LAST.GRAPH.LOCATION HISTORY.ITEMS FIND.STRING LOOKUP.STRING) (SYSTEM)) (RECORD DINFONODE (ID LABEL FILE FROMBYTE TOBYTE PARENT CHILDREN NEXTNODE PREVIOUSNODE USERDATA) (SYSTEM)) ) (/DECLAREDATATYPE 'DINFOGRAPH '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((DINFOGRAPH 0 POINTER) (DINFOGRAPH 2 POINTER) (DINFOGRAPH 4 POINTER) (DINFOGRAPH 6 POINTER) (DINFOGRAPH 8 POINTER) (DINFOGRAPH 10 POINTER) (DINFOGRAPH 12 POINTER) (DINFOGRAPH 14 POINTER) (DINFOGRAPH 16 POINTER) (DINFOGRAPH 18 POINTER) (DINFOGRAPH 20 POINTER) (DINFOGRAPH 22 POINTER) (DINFOGRAPH 24 POINTER) (DINFOGRAPH 26 POINTER) (DINFOGRAPH 28 POINTER) (DINFOGRAPH 30 POINTER) (DINFOGRAPH 32 POINTER) (DINFOGRAPH 34 POINTER) (DINFOGRAPH 36 POINTER) (DINFOGRAPH 38 POINTER) (DINFOGRAPH 40 POINTER) (DINFOGRAPH 42 POINTER) (DINFOGRAPH 44 POINTER) (DINFOGRAPH 46 POINTER) (DINFOGRAPH 48 POINTER) (DINFOGRAPH 50 POINTER)) '52) (DEFMACRO DINFOGRAPHPROP (GRAPH PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED)) [LET [(REAL-FIELD (AND (LISTP PROP) (EQ (CAR PROP) 'QUOTE) (FMEMB (CADR PROP) (RECORDFIELDNAMES 'DINFOGRAPH T)) (CADR PROP] (IF NEW-VALUE-SUPPLIED THEN [IF REAL-FIELD THEN `(REPLACE (DINFOGRAPH ,REAL-FIELD) OF ,GRAPH WITH ,NEW-VALUE) ELSE `(LET* ((SI::$GRAPH$ ,GRAPH) (SI::$USERDATA$ (FETCH (DINFOGRAPH USERDATA) OF SI::$GRAPH$)) (SI::$PROP$ ,PROP) (SI::$NEW-VALUE$ ,NEW-VALUE)) (IF (LISTP SI::$USERDATA$) THEN (LISTPUT SI::$USERDATA$ SI::$PROP$ SI::$NEW-VALUE$) ELSE (REPLACE (DINFOGRAPH USERDATA) OF SI::$GRAPH$ WITH (LIST SI::$PROP$ SI::$NEW-VALUE$)) SI::$NEW-VALUE$] ELSE (IF REAL-FIELD THEN `(FETCH (DINFOGRAPH ,REAL-FIELD) OF ,GRAPH) ELSE `(LISTGET (FETCH (DINFOGRAPH USERDATA) OF ,GRAPH) ,PROP]) (DEFINEQ (DINFO [LAMBDA (GRAPH.OR.FILE WINDOW.OR.REGION SETUP.ONLY? NO.FREEMENU?) (* drc%: "25-Jan-86 18:23") (* Starts a DInfo browser.) (RESETLST (LET ((W (OR (WINDOWP WINDOW.OR.REGION) (AND (REGIONP WINDOW.OR.REGION) (CREATEW WINDOW.OR.REGION "DInfo" NIL T)) (AND (type? DINFOGRAPH GRAPH.OR.FILE) (WINDOWP (fetch (DINFOGRAPH WINDOW) of GRAPH.OR.FILE))) (CREATEW NIL "DInfo"))) GRAPH MONITORLOCK) (OPENW W) [SETQ GRAPH (if (type? DINFOGRAPH GRAPH.OR.FILE) then GRAPH.OR.FILE else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW W)) (DINFO.READ.GRAPH GRAPH.OR.FILE] [SETQ MONITORLOCK (OR (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) (replace (DINFOGRAPH MONITORLOCK) of GRAPH with (CREATE.MONITORLOCK "DInfo"] (RESETSAVE NIL (LIST 'RELEASE.MONITORLOCK MONITORLOCK)) (OBTAIN.MONITORLOCK MONITORLOCK) (DINFO.SETUP.WINDOW GRAPH W NO.FREEMENU?) (OR SETUP.ONLY? (DINFO.UPDATE GRAPH NIL NIL T)) GRAPH]) (DINFO.UPDATE [LAMBDA (GRAPH NEW.NODE SEL FORCE?) (* jow "20-May-86 15:14") (* * Called to visit a NEW.NODE in GRAPH, or to just make sure that the display  of GRAPH is current.) (LET ([NODE (OR NEW.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH) (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) (fetch (DINFOGRAPH NODELST) of GRAPH] (PREVIOUS.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (OPENW WINDOW) (WINDOWPROP WINDOW 'DINFOGRAPH GRAPH) (OR (FMEMB NODE (fetch (DINFOGRAPH NODELST) of GRAPH)) (ERROR NODE "NOT IN NODELST")) (LET ((FMENU.WINDOW (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH)) (MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH))) [RESETLST (RESETSAVE NIL (LIST 'RELEASE.MONITORLOCK MONITORLOCK)) (if (NOT (OBTAIN.MONITORLOCK MONITORLOCK T)) then (* somebody else is messing with this  graph.) (FLASHWINDOW WINDOW) (PROMPTPRINT "DInfo is busy") elseif (NULL FMENU.WINDOW) then (replace (DINFOGRAPH CURRENTNODE) of GRAPH with NODE) (* FreeMenu turned off, so just  display text) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NODE SEL) else (* We've got a FreeMenu, so update  away!) (DINFO.UPDATE.FMENU GRAPH NODE) (LET ((STATUS (FM.GETSTATE FMENU.WINDOW))) (replace (DINFOGRAPH CURRENTNODE) of GRAPH with NODE) (AND (LISTGET STATUS 'GRAPH) (DINFO.UPDATE.GRAPH.DISPLAY GRAPH NODE FORCE?)) (AND (LISTGET STATUS 'MENU) (DINFO.UPDATE.MENU.DISPLAY GRAPH NODE)) (AND (LISTGET STATUS 'TEXT) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NODE SEL)) (DINFO.UPDATE.HISTORY GRAPH NODE SEL (LISTGET STATUS 'HISTORY] (CLEARW (GETPROMPTWINDOW WINDOW]) (DINFOGRAPH [LAMBDA (X) (* drc%: " 8-Jan-86 11:12") (if (type? DINFOGRAPH X) then X elseif (AND (WINDOWP X) (WINDOWPROP X 'DINFOGRAPH)) elseif (AND (WINDOWP X) (WINDOWPROP X 'MAINWINDOW)) then (WINDOWPROP (WINDOWPROP X 'MAINWINDOW) 'DINFOGRAPH]) (DINFO.SPECIAL.UPDATE [LAMBDA (TYPE GRAPH) (* drc%: "25-Jan-86 18:26") (* * Do a TYPE update of Graph, where TYPE is one of Top, Parent, Previous or  Next.) (LET* [(DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (CURRENT.NODE (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (NEW.NODE (FASSOC (SELECTQ TYPE (Top (fetch (DINFOGRAPH TOPNODEID) of GRAPH)) (Parent (fetch (DINFONODE PARENT) of CURRENT.NODE)) (Next (fetch (DINFONODE NEXTNODE) of CURRENT.NODE)) (Previous (fetch (DINFONODE PREVIOUSNODE) of CURRENT.NODE)) NIL) (fetch (DINFOGRAPH NODELST) of GRAPH] (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then (if NEW.NODE then (PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "DInfo " TYPE)) (DINFO.UPDATE GRAPH NEW.NODE) else (* TYPE of Top! or Node! will sound silly here, but should never happen.) (printout (GETPROMPTWINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) T "This node has no " TYPE)) else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) (DINFO.READ.GRAPH [LAMBDA (FILE QUIETFLG) (* drc%: "25-Jan-86 18:17") (* Reads a file written by DINFO.WRITE.GRAPH.  Returns the DInfo graph stored on FILE.) (OR QUIETFLG (printout T T "Reading " (FILENAMEFIELD FILE 'NAME) " graph...")) (LET* ((FULLFILENAME (INFILEP FILE)) [DATA (CDR (READFILE (OR FULLFILENAME (ERROR "FILE NOT FOUND" FILE] (GRAPH (create DINFOGRAPH))) (* fields stored on file) (replace (DINFOGRAPH TOPNODEID) of GRAPH with (LISTGET DATA 'TOPNODEID)) (replace (DINFOGRAPH TEXTPROPS) of GRAPH with (LISTGET DATA 'TEXTPROPS)) (replace (DINFOGRAPH LOOKUPFN) of GRAPH with (LISTGET DATA 'LOOKUPFN)) (replace (DINFOGRAPH MENUFN) of GRAPH with (LISTGET DATA 'MENUFN)) (replace (DINFOGRAPH FREEMENUITEMS) of GRAPH with (LISTGET DATA 'FREEMENUITEMS)) (replace (DINFOGRAPH NODELST) of GRAPH with (LISTGET DATA 'NODELST)) (replace (DINFOGRAPH USERDATA) of GRAPH with (LISTGET DATA 'USERDATA)) (* fields filled in at read time) (replace (DINFOGRAPH NAME) of GRAPH with (FILENAMEFIELD FULLFILENAME 'NAME)) (replace (DINFOGRAPH DEFAULTHOST) of GRAPH with (FILENAMEFIELD FULLFILENAME 'HOST)) (replace (DINFOGRAPH DEFAULTDEVICE) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DEVICE)) (replace (DINFOGRAPH DEFAULTDIR) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DIRECTORY)) (OR QUIETFLG (printout T "OK.")) GRAPH]) (DINFO.WRITE.GRAPH [LAMBDA (GRAPH FILE) (* drc%: "25-Jan-86 18:16") (* Writes a DInfo graph to a file for reading by DINFO.READ.GRAPH.  Returns the full file name of the file.) (* dump it out as a props list) (WRITEFILE (LIST 'TOPNODEID (fetch (DINFOGRAPH TOPNODEID) of GRAPH) 'TEXTPROPS (fetch (DINFOGRAPH TEXTPROPS) of GRAPH) 'LOOKUPFN (fetch (DINFOGRAPH LOOKUPFN) of GRAPH) 'MENUFN (fetch (DINFOGRAPH MENUFN) of GRAPH) 'FREEMENUITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH) 'NODELST (fetch (DINFOGRAPH NODELST) of GRAPH) 'USERDATA (fetch (DINFOGRAPH USERDATA) of GRAPH)) FILE]) (DINFO.SELECT.GRAPH [LAMBDA NIL (* drc%: "24-Jan-86 13:25") (* * This is called when DInfo is selected from the Background Menu.) (DECLARE (GLOBALVARS DINFO.GRAPHS)) (ALLOW.BUTTON.EVENTS) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (LET [(GRAPH (if (NULL DINFO.GRAPHS) then (PROMPTPRINT "No Graphs installed -- load HelpSys or DInfoEdit") elseif (NULL (CDR DINFO.GRAPHS)) then (EVAL (CADAR DINFO.GRAPHS)) else (MENU (create MENU CENTERFLG _ T TITLE _ "Select Graph" ITEMS _ DINFO.GRAPHS] (AND GRAPH (DINFO GRAPH]) (DINFO.DEFAULT.MENU [LAMBDA (GRAPH) (* jow "15-Jul-86 17:36") (* * This is the default MENUFN for DInfo graphs.) (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (CLEARW (GETPROMPTWINDOW DINFOW)) (LET [(TYPE (MENU (OR (fetch (DINFOGRAPH DINFO.MENU) of GRAPH) (replace (DINFOGRAPH DINFO.MENU) of GRAPH with (create MENU ITEMS _ '(("Top" 'Top "Visit the top node in the graph" ) ("Parent" 'Parent "Visit the parent of the current node" ) ("Previous" 'Previous "Visit the node before this node") ("Next " 'Next "Visit the node following this node") ("Find" 'Find "Search the text of this node") ("Lookup" 'Lookup "Lookup a new term in this graph") ("Expanded Menu" 'FreeMenu "Add an expanded options menu.")) CENTERFLG _ T MENUFONT _ (FONTCREATE 'HELVETICA 10 'BOLD] (if TYPE then (PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "DInfo " TYPE)) (SELECTQ TYPE ((Top Parent Previous Next) (DINFO.SPECIAL.UPDATE TYPE GRAPH)) (Find (DINFO.FIND GRAPH)) (Lookup (DINFO.LOOKUP GRAPH '(LEFT))) (FreeMenu (DINFO.ADD.FMENU GRAPH) (DINFO.UPDATE GRAPH)) NIL]) (DINFO.FIND [LAMBDA (GRAPH BUTTONS) (* drc%: "25-Jan-86 18:23") (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (if (NOT (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T)) then (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy") else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (TERPRI T) (LET ([STRING (if (AND (FMEMB 'MIDDLE BUTTONS) (fetch (DINFOGRAPH FIND.STRING) of GRAPH)) else (PROMPTFORWORD "Find: " (fetch (DINFOGRAPH FIND.STRING) of GRAPH) NIL NIL NIL 'TTY (CONSTANT (CHARCODE (EOL ESCAPE LF] (TEXTSTREAM (WINDOWPROP DINFOW 'TEXTSTREAM)) PAIR) (replace (DINFOGRAPH FIND.STRING) of GRAPH with STRING) (if STRING then (PRINTOUT T " Searching...") (if (SETQ PAIR (TEDIT.FIND TEXTSTREAM STRING NIL NIL T)) then (printout T "OK.") (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SHOWSEL TEXTSTREAM T (TEDIT.SETSEL TEXTSTREAM (CAR PAIR) (NCHARS STRING) 'RIGHT T))) else (printout T "not found.") (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 0]) (DINFO.LOOKUP [LAMBDA (GRAPH BUTTONS) (* drc%: "25-Jan-86 18:22") (LET ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH))) (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then [RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (LET ((LOOKUPFN (fetch (DINFOGRAPH LOOKUPFN) of GRAPH))) (if LOOKUPFN then (CLEARW T) (LET* [(OLD.STRING (fetch (DINFOGRAPH LOOKUP.STRING) of GRAPH)) (STRING (if (AND OLD.STRING (FMEMB 'MIDDLE BUTTONS)) then OLD.STRING else (PROMPTFORWORD "Lookup: " OLD.STRING NIL NIL NIL 'TTY (CONSTANT (CHARCODE (EOL ESCAPE LF] (replace (DINFOGRAPH LOOKUP.STRING) of GRAPH with STRING) (AND STRING (APPLY* LOOKUPFN STRING GRAPH))) else (PRINTOUT T T "The " (fetch (DINFOGRAPH NAME) of GRAPH) " graph has no LOOKUPFN."] else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) ) (DEFINEQ (DINFO.READ.KOTO.GRAPH [LAMBDA (FILE QUIETFLG) (* drc%: " 4-Feb-86 11:27") (* Reads a file written by Koto DINFO.WRITE.GRAPH and returns a Lute  DINFOGRAPH. Thus, (DINFO.WRITE.GRAPH (DINFO.READ.KOTO.GRAPH ) )  will convert the Koto format graph in to a Lute format graph in  .) (OR QUIETFLG (printout T T "Reading " (FILENAMEFIELD FILE 'NAME) " graph...")) (LET* ((FULLFILENAME (INFILEP FILE)) [DATA (CDR (READFILE (OR FULLFILENAME (ERROR "FILE NOT FOUND" FILE] (GRAPH (create DINFOGRAPH))) (* in Koto we just wrote out the  DINFOGRAPH record) (for FIELD in DATA as N from 1 to 11 do (* fields stored on file) (SELECTQ N ((1 4 5 6 10 11)) (2 (replace (DINFOGRAPH NODELST) of GRAPH with FIELD)) (3 (replace (DINFOGRAPH TOPNODEID) of GRAPH with FIELD)) (7 (replace (DINFOGRAPH TEXTPROPS) of GRAPH with FIELD)) (8 (replace (DINFOGRAPH LOOKUPFN) of GRAPH with FIELD)) (9 (replace (DINFOGRAPH MENUFN) of GRAPH with FIELD)) (SHOULDNT))) (* fields filled in at read time) (replace (DINFOGRAPH NAME) of GRAPH with (FILENAMEFIELD FULLFILENAME 'NAME)) (replace (DINFOGRAPH DEFAULTHOST) of GRAPH with (FILENAMEFIELD FULLFILENAME 'HOST)) (replace (DINFOGRAPH DEFAULTDEVICE) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DEVICE)) (replace (DINFOGRAPH DEFAULTDIR) of GRAPH with (FILENAMEFIELD FULLFILENAME 'DIRECTORY)) (OR QUIETFLG (printout T "OK.")) GRAPH]) ) (DEFINEQ (DINFO.SETUP.WINDOW [LAMBDA (GRAPH WINDOW NO.FREEMENU?) (* jow "10-Jun-86 15:29") (replace (DINFOGRAPH WINDOW) of GRAPH with WINDOW) (WINDOWPROP WINDOW 'DINFOGRAPH GRAPH) (DETACHALLWINDOWS WINDOW) (if (NOT NO.FREEMENU?) then (DINFO.ADD.FMENU GRAPH)) (DINFO.UPDATE.TEXT.DISPLAY GRAPH NIL NIL T) (WINDOWPROP WINDOW 'TITLE (CONCAT (fetch (DINFOGRAPH NAME) of GRAPH) " DInfo")) (WINDOWADDPROP WINDOW 'CLOSEFN 'DINFO.CLOSEFN) (WINDOWADDPROP WINDOW 'SHRINKFN 'DINFO.SHRINKFN) (WINDOWADDPROP WINDOW 'EXPANDFN 'DINFO.EXPANDFN]) (DINFO.CLOSEFN [LAMBDA (W) (* drc%: "25-Jan-86 18:26") (LET [(GRAPH (WINDOWPROP W 'DINFOGRAPH] (if (type? DINFOGRAPH GRAPH) then (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH)) (* remove circularity...) (WINDOWPROP W 'DINFOGRAPH NIL]) (DINFO.SHRINKFN [LAMBDA (W) (* drc%: "25-Jan-86 18:26") (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of (DINFOGRAPH W]) (DINFO.EXPANDFN [LAMBDA (W) (* jow "15-Jul-86 17:00") (LET* ((GRAPH (DINFOGRAPH W)) (FMENU (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH))) (if (AND FMENU (LISTGET (FM.GETSTATE FMENU) 'GRAPH)) then (LET ((GRAPHW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) (OPENW GRAPHW) (TOTOPW W) (WINDOWPROP GRAPHW 'DINFOGRAPH GRAPH]) (DINFO.ICONFN [LAMBDA (W) (* drc%: "25-Jan-86 16:33") (OR (WINDOWPROP WINDOW 'ICON) (WINDOWPROP WINDOW 'ICON (TITLEDICONW TEDIT.TITLED.ICON.TEMPLATE (WINDOWPROP WINDOW 'TITLE) TEDIT.ICON.FONT NIL T)) (WINDOWPROP WINDOW 'ICON]) ) (DEFINEQ (DINFO.ADD.FMENU [LAMBDA (GRAPH) (* jow "20-May-86 15:41") (* * Add a DInfo FreeMenu to WINDOW. then update the FreeMenu's display.) (LET ((WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (FM.WINDOW (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH))) (if [AND (WINDOWP FM.WINDOW) (FMEMB FM.WINDOW (WINDOWPROP WINDOW 'ATTACHEDWINDOWS] then (OPENW FM.WINDOW) else (REMOVEPROMPTWINDOW WINDOW) (SETQ FM.WINDOW (OR (WINDOWP FM.WINDOW) (DINFO.CREATE.FMENU GRAPH))) (replace (DINFOGRAPH FMENU.WINDOW) of GRAPH with FM.WINDOW) (ATTACHWINDOW FM.WINDOW WINDOW) (WINDOWPROP FM.WINDOW 'FM.PROMPTWINDOW (GETPROMPTWINDOW WINDOW)) (WINDOWDELPROP FM.WINDOW 'PASSTOMAINCOMS 'CLOSEW) (WINDOWADDPROP FM.WINDOW 'CLOSEFN 'DINFO.FMW.CLOSEFN T) (DINFO.UPDATE.FMENU GRAPH]) (DINFO.CREATE.FMENU [LAMBDA (GRAPH) (* jow "15-Jul-86 17:39") (* * Makes a DInfo FreeMenu for GRAPH) (LET* [(ADD.ITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH)) (FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT)) (FM (FREEMENU `((PROPS FONT %, FONT) ((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10)) (ID NODE LABEL "" TYPE DISPLAY)) ((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the top node") (ID TOP LABEL "" TYPE DISPLAY)) ((LABEL Parent! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the parent of the current node") (ID PARENT LABEL "" TYPE DISPLAY)) ((LABEL Previous! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the node previous to the current node") (ID PREVIOUS LABEL "" TYPE DISPLAY)) ((LABEL Next! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Visit the node after the current node") (ID NEXT LABEL "" TYPE DISPLAY)) ((LABEL Display%: TYPE DISPLAY FONT (HELVETICA 10)) (LABEL Graph ID GRAPH INITSTATE %, (MEMB 'GRAPH DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.GRAPH FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the graph") (LABEL Menu ID MENU INITSTATE %, (MEMB 'MENU DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.MENU FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the subnode menu") (LABEL Text ID TEXT INITSTATE %, (MEMB 'TEXT DINFOMODES) TYPE TOGGLE SELECTEDFN DINFO.TOGGLE.TEXT FONT (HELVETICA 10 BOLD) MESSAGE "Toggle display of the text of the current node") (LABEL History ID HISTORY INITSTATE %, (MEMB 'HISTORY DINFOMODES) TYPE TOGGLE FONT (HELVETICA 10 BOLD) SELECTEDFN DINFO.TOGGLE.HISTORY MESSAGE "Toggle the display of the History Menu")) %, (APPEND '((LABEL Find! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Perform a string search in the selected text of the current node" ) (LABEL Lookup! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD) MESSAGE "Lookup a term in this graph. LEFT for new term, MIDDLE to repeat last." )) ADD.ITEMS] (WINDOWPROP FM 'FM.DONTRESHAPE T) FM]) (DINFO.FMW.CLOSEFN [LAMBDA (W) (* drc%: "25-Jan-86 18:19") (* * CLOSEFN for a DInfo FreeMenu window.) (LET* ((DINFOW (WINDOWPROP W 'MAINWINDOW)) (GRAPH (DINFOGRAPH DINFOW))) (if GRAPH then (DETACHWINDOW W) (replace (DINFOGRAPH FMENU.WINDOW) of GRAPH with NIL) (DETACHWINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) (CLOSEW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) (DETACHWINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH)) (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH)) (REMOVEPROMPTWINDOW DINFOW]) (DINFO.FMENU.HANDLER [LAMBDA (ITEM WINDOW BUTTONS) (* drc%: "16-Jan-86 11:42") (* * Handle a command from the FreeMenu.) (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH)) (TYPE (MKATOM (SUBSTRING (FM.ITEMPROP ITEM 'LABEL) 1 -2] (SELECTQ TYPE ((Top Parent Previous Next) (DINFO.SPECIAL.UPDATE TYPE GRAPH)) (Find (DINFO.FIND GRAPH BUTTONS)) (Lookup (DINFO.LOOKUP GRAPH BUTTONS)) (SHOULDNT]) (DINFO.UPDATE.FMENU [LAMBDA (GRAPH NEW.NODE) (* jow "20-May-86 15:13") (* * Update the display of GRAPH's FreeMenu.  If NEW.NODE is not specified, use Top node of GRAPH, and change Top node title.) (LET* [(W (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH)) (NODELST (fetch (DINFOGRAPH NODELST) of GRAPH)) (NODE (OR NEW.NODE (FASSOC (fetch (DINFONODE ID) of (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) NODELST) (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) NODELST] (OR NEW.NODE (FM.CHANGELABEL (FM.GETITEM 'TOP NIL W) (fetch (DINFONODE LABEL) of (FASSOC (fetch (DINFOGRAPH TOPNODEID) of GRAPH) (fetch (DINFOGRAPH NODELST) of GRAPH))) W)) (FM.CHANGELABEL (FM.GETITEM 'NODE NIL W) (fetch (DINFONODE LABEL) of NODE) W) (FM.CHANGELABEL (FM.GETITEM 'PARENT NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE PARENT) of NODE) NODELST)) W) (FM.CHANGELABEL (FM.GETITEM 'NEXT NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE NEXTNODE) of NODE) NODELST)) W) (FM.CHANGELABEL (FM.GETITEM 'PREVIOUS NIL W) (fetch (DINFONODE LABEL) of NODE (FASSOC (fetch (DINFONODE PREVIOUSNODE) of NODE) NODELST)) W]) (DINFO.TOGGLE.MENU [LAMBDA (ITEM WINDOW) (* jow "10-Jun-86 14:15") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.MENU.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) else (LET ((SUBNODE.MENU.WINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH))) (DETACHWINDOW SUBNODE.MENU.WINDOW) (CLOSEW SUBNODE.MENU.WINDOW]) (DINFO.TOGGLE.GRAPH [LAMBDA (ITEM WINDOW) (* ; "Edited 1-Oct-87 09:56 by drc:") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.GRAPH.DISPLAY GRAPH (fetch CURRENTNODE of GRAPH) T) else (CLOSEW (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) ITEM]) (DINFO.TOGGLE.HISTORY [LAMBDA (ITEM WINDOW) (* jow "10-Jun-86 14:22") (LET [(GRAPH (WINDOWPROP (WINDOWPROP WINDOW 'MAINWINDOW) 'DINFOGRAPH] (if (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.HISTORY GRAPH NIL NIL T) else (LET ((HISTORY.MENU.WINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH))) (DETACHWINDOW HISTORY.MENU.WINDOW) (CLOSEW HISTORY.MENU.WINDOW]) (DINFO.TOGGLE.TEXT [LAMBDA (ITEM WINDOW) (* drc%: "25-Jan-86 18:26") (LET* ((DINFOW (WINDOWPROP WINDOW 'MAINWINDOW)) (GRAPH (WINDOWPROP DINFOW 'DINFOGRAPH)) (MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH))) (if (NOT (OBTAIN.MONITORLOCK MONITORLOCK T)) then (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy") elseif (FM.ITEMPROP ITEM 'STATE) then (DINFO.UPDATE.TEXT.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH)) (RELEASE.MONITORLOCK MONITORLOCK) else (DINFO.UPDATE.TEXT.DISPLAY GRAPH (fetch (DINFOGRAPH CURRENTNODE) of GRAPH) NIL T) (RELEASE.MONITORLOCK MONITORLOCK]) ) (DEFINEQ (DINFO.UPDATE.MENU.DISPLAY [LAMBDA (GRAPH NODE) (* drc%: "25-Jan-86 18:20") (LET* [(DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (WINDOW (fetch (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH)) [CHILDREN (DREVERSE (for ID in (fetch (DINFONODE CHILDREN) of NODE) bind (NODELST _ (fetch (DINFOGRAPH NODELST) of GRAPH)) collect (FASSOC ID NODELST] (LENGTH (FLENGTH CHILDREN)) (SCROLLABLE (GREATERP LENGTH \DINFO.MAX.MENU.LEN)) (MENU (create MENU MENUFONT _ (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT) ITEMWIDTH _ (WINDOWPROP DINFOW 'WIDTH) CENTERFLG _ T MENUCOLUMNS _ 1 MENUOUTLINESIZE _ 0 ITEMS _ (for CHILD in CHILDREN collect (LIST (fetch (DINFONODE LABEL) of CHILD) CHILD "Will visit this node if selected." )) WHENSELECTEDFN _ (FUNCTION DINFO.UPDATE.FROM.MENU] (AND WINDOW (PROGN (DETACHWINDOW WINDOW) (CLOSEW WINDOW))) (if CHILDREN then (UPDATE/MENU/IMAGE MENU) (SETQ WINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (WINDOWPROP DINFOW 'WIDTH) HEIGHT _ (HEIGHTIFWINDOW (if SCROLLABLE then (TIMES \DINFO.MAX.MENU.LEN (fetch (MENU ITEMHEIGHT) of MENU)) else (fetch (MENU IMAGEHEIGHT) of MENU)) T)) "Subnodes" NIL T)) (ADDMENU MENU WINDOW (create POSITION XCOORD _ 0 YCOORD _ (if SCROLLABLE then (TIMES (DIFFERENCE \DINFO.MAX.MENU.LEN LENGTH) (fetch (MENU ITEMHEIGHT) of MENU)) else 0)) T) (ATTACHWINDOW WINDOW DINFOW 'BOTTOM) (REDISPLAYW WINDOW) (replace (DINFOGRAPH SUBNODE.MENU.WINDOW) of GRAPH with WINDOW) (LET [(BITS (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION] (* Slide DINFOW up if our new menu is off the screen) (AND (ILESSP BITS 0) (RELMOVEW DINFOW (create POSITION XCOORD _ 0 YCOORD _ (IDIFFERENCE 0 BITS]) (DINFO.UPDATE.FROM.MENU [LAMBDA (ITEM MENU BUTTONS) (* drc%: "12-Dec-85 14:49") (DINFO.UPDATE (WINDOWPROP (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW) 'DINFOGRAPH) (CADR ITEM]) (DINFO.UPDATE.HISTORY [LAMBDA (GRAPH NODE SEL DISPLAY?) (* drc%: "25-Jan-86 18:21") (LET* ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (OLDWINDOW (fetch (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH)) (OLDITEMS (fetch (DINFOGRAPH HISTORY.ITEMS) of GRAPH)) (NEWITEM (if SEL then (LIST (if (LISTP SEL) then (CAR SEL) else SEL) (LIST (fetch (DINFONODE ID) of NODE) SEL) "Will re-lookup this term") elseif NODE then (LIST (fetch (DINFONODE LABEL) of NODE) (LIST (fetch (DINFONODE ID) of NODE) SEL) "Will re-visit this node"))) (ITEMS (if [AND NEWITEM (NOT (EQUAL NEWITEM (CAR OLDITEMS] then (CONS NEWITEM (for ITEM in OLDITEMS as I from 2 to DINFO.HISTORY.LENGTH collect ITEM)) else OLDITEMS))) (replace (DINFOGRAPH HISTORY.ITEMS) of GRAPH with ITEMS) (AND OLDWINDOW (PROGN (DETACHWINDOW OLDWINDOW) (CLOSEW OLDWINDOW))) (AND DISPLAY? ITEMS (LET [(HISTORYW (ATTACHMENU (create MENU MENUFONT _ (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH)) MENUFONT) TITLE _ "History" CENTERFLG _ T MENUCOLUMNS _ 1 ITEMS _ ITEMS WHENSELECTEDFN _ (FUNCTION DINFO.HISTORIC.UPDATE)) DINFOW 'LEFT 'TOP] (replace (DINFOGRAPH HISTORY.MENU.WINDOW) of GRAPH with HISTORYW]) (DINFO.HISTORIC.UPDATE [LAMBDA (ITEM MENU BUTTONS) (* drc%: "25-Jan-86 18:24") (LET* [(ID (CAADR ITEM)) (SEL (CADADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (GRAPH (WINDOWPROP WINDOW 'DINFOGRAPH)) (NODE (FASSOC ID (fetch (DINFOGRAPH NODELST) of GRAPH] (if (NOT (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T)) then (FLASHWINDOW WINDOW) (PROMPTPRINT "DInfo is busy") elseif (NULL NODE) then (PRINTOUT (GETPROMPTWINDOW WINDOW) T "This node no longer exists") else (DINFO.UPDATE GRAPH NODE SEL]) ) (DEFINEQ (DINFO.UPDATE.GRAPH.DISPLAY [LAMBDA (DINFO.GRAPH NODE FORCE?) (* drc%: "27-Jan-86 16:19") (LET [(DINFOW (fetch (DINFOGRAPH WINDOW) of DINFO.GRAPH)) (LOCATION (CONS (fetch (DINFONODE PARENT) of NODE) (fetch (DINFONODE CHILDREN) of NODE] (if (AND (NOT FORCE?) (EQUAL LOCATION (fetch (DINFOGRAPH LAST.GRAPH.LOCATION) of DINFO.GRAPH))) then (* don't need to relayout grapher display --  just change which node is inverted.) (DINFO.INVERT.NODE (fetch (DINFOGRAPH GRAPH.WINDOW) of DINFO.GRAPH) NODE DINFO.GRAPH) else (DINFO.SHOWGRAPH (DINFO.LAYOUTGRAPH DINFO.GRAPH NODE) DINFO.GRAPH)) (replace (DINFOGRAPH LAST.GRAPH.LOCATION) of DINFO.GRAPH with LOCATION) (WINDOWPROP (fetch (DINFOGRAPH GRAPH.WINDOW) of DINFO.GRAPH) 'TITLE (CONCAT (fetch (DINFOGRAPH NAME) of DINFO.GRAPH) " - " (fetch (DINFONODE LABEL) of (fetch (DINFOGRAPH CURRENTNODE) of DINFO.GRAPH]) (DINFO.UPDATE.FROM.GRAPH [LAMBDA (GRAPHER.NODE GRAPH.WINDOW) (* drc%: "12-Dec-85 18:34") (AND GRAPHER.NODE (ADD.PROCESS `(DINFO.UPDATE (QUOTE %, (WINDOWPROP GRAPH.WINDOW 'DINFOGRAPH)) (QUOTE %, (fetch (GRAPHNODE NODEID) of GRAPHER.NODE))) 'NAME "DInfo From Graph"]) (DINFO.GET.GRAPH.WINDOW [LAMBDA (GRAPH REGION) (* drc%: "25-Jan-86 18:05") (LET ((W (fetch (DINFOGRAPH GRAPH.WINDOW) of GRAPH))) (COND ((WINDOWP W)) (T (SETQ W (DINFO.CREATE.GRAPH.WINDOW GRAPH REGION)) [WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (W) (WINDOWPROP W 'DINFOGRAPH NIL] (replace (DINFOGRAPH GRAPH.WINDOW) of GRAPH with W))) (WINDOWPROP W 'DINFOGRAPH GRAPH) W]) (DINFO.CREATE.GRAPH.WINDOW [LAMBDA (GRAPH REGION) (* drc%: "25-Jan-86 17:49") (LET* ((DINFOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (DINFOREGION (WINDOWPROP DINFOW 'REGION)) (LEFT (DIFFERENCE (DIFFERENCE (fetch (REGION LEFT) of DINFOREGION) (fetch (REGION WIDTH) of REGION)) 10)) (BOTTOM (DIFFERENCE (DIFFERENCE (fetch (REGION BOTTOM) of DINFOREGION) (fetch (REGION HEIGHT) of REGION)) 50))) (CREATEW (CREATEREGION (if (GEQ LEFT 0) then LEFT else (RAND 0 10)) (if (GEQ BOTTOM 0) then BOTTOM else (RAND 0 10)) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION)) NIL NIL T]) (DINFO.SHOWGRAPH [LAMBDA (GRAPHER.GRAPH DINFO.GRAPH) (* drc%: "27-Jan-86 16:15") (LET* [(GRAPH.REGION (GRAPHREGION GRAPHER.GRAPH)) (GRAPH.WINDOW (DINFO.GET.GRAPH.WINDOW DINFO.GRAPH GRAPH.REGION)) (WINDOW.REGION (WINDOWPROP GRAPH.WINDOW 'REGION] [SHAPEW GRAPH.WINDOW (LET [(LEFT (fetch (REGION LEFT) of WINDOW.REGION)) (BOTTOM (fetch (REGION BOTTOM) of WINDOW.REGION)) (HEIGHT (HEIGHTIFWINDOW (fetch (REGION HEIGHT) of GRAPH.REGION) T)) (WIDTH (WIDTHIFWINDOW (fetch (REGION WIDTH) of GRAPH.REGION] (create REGION LEFT _ LEFT BOTTOM _ BOTTOM HEIGHT _ (if (GEQ (IPLUS BOTTOM HEIGHT) SCREENHEIGHT) then (IDIFFERENCE SCREENHEIGHT BOTTOM) else HEIGHT) WIDTH _ (if (GEQ (IPLUS LEFT WIDTH) SCREENWIDTH) then (IDIFFERENCE SCREENWIDTH LEFT) else WIDTH] (SHOWGRAPH GRAPHER.GRAPH GRAPH.WINDOW (FUNCTION DINFO.UPDATE.FROM.GRAPH) (FUNCTION DINFO.UPDATE.FROM.GRAPH]) (DINFO.INVERT.NODE [LAMBDA (WINDOW DINFO.NODE DINFO.GRAPH) (* drc%: "25-Jan-86 18:24") (LET* ((NODE (for NODE in (fetch (GRAPH GRAPHNODES) of (WINDOWPROP WINDOW 'GRAPH)) thereis (EQ (fetch (GRAPHNODE NODEID) of NODE) DINFO.NODE))) (LAST.NODE (fetch (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH))) (replace (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH with NODE) (if (NEQ NODE LAST.NODE) then (replace (GRAPHNODE NODELABELSHADE) of NODE with BLACKSHADE) (* (PRINTDISPLAYNODE NODE  (create POSITION XCOORD _ 0 YCOORD _ 0)  WINDOW)) (replace (GRAPHNODE NODELABELSHADE) of LAST.NODE with WHITESHADE) (* (PRINTDISPLAYNODE LAST.NODE  (create POSITION XCOORD _ 0 YCOORD _ 0)  WINDOW)) (REDISPLAYW WINDOW) else (OPENW WINDOW]) (DINFO.LAYOUTGRAPH [LAMBDA (DINFO.GRAPH NODE) (* drc%: "25-Jan-86 18:20") (LET* [(WINDOW (fetch (DINFOGRAPH WINDOW) of DINFO.GRAPH)) (FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of DINFO.GRAPH)) MENUFONT)) (NODELST (fetch (DINFOGRAPH NODELST) of DINFO.GRAPH)) (CHILDREN (for ID in (fetch (DINFONODE CHILDREN) of NODE) collect (FASSOC ID NODELST))) [CHILD.GRAPHER.NODES (for CHILD in CHILDREN collect (create GRAPHNODE NODEID _ CHILD NODELABEL _ (fetch (DINFONODE LABEL) of CHILD] (GRAPHER.NODE (create GRAPHNODE NODELABELSHADE _ BLACKSHADE NODEID _ NODE TONODES _ CHILDREN NODELABEL _ (fetch (DINFONODE LABEL) of NODE] (replace (DINFOGRAPH LAST.INVERTED.NODE) of DINFO.GRAPH with GRAPHER.NODE) (* so DINFO.INVERT.NODE will work  right) (if (fetch (DINFONODE PARENT) of NODE) then (LET* ((PARENT (FASSOC (fetch (DINFONODE PARENT) of NODE) NODELST)) (SIBLINGS (for ID in (fetch (DINFONODE CHILDREN) of PARENT) collect (FASSOC ID NODELST))) [SIBLING.GRAPHER.NODES (for SIBLING in SIBLINGS collect (if (EQ (fetch (DINFONODE ID) of SIBLING) (fetch (DINFONODE ID) of NODE)) then GRAPHER.NODE else (create GRAPHNODE NODEID _ SIBLING NODELABEL _ (fetch (DINFONODE LABEL) of SIBLING] (PARENT.GRAPHER.NODE (create GRAPHNODE NODEID _ PARENT NODELABEL _ (fetch (DINFONODE LABEL) of PARENT) TONODES _ SIBLINGS))) (LAYOUTGRAPH (CONS PARENT.GRAPHER.NODE (NCONC SIBLING.GRAPHER.NODES CHILD.GRAPHER.NODES)) (LIST PARENT) NIL FONT)) else (LAYOUTGRAPH (CONS GRAPHER.NODE CHILD.GRAPHER.NODES) (LIST NODE) NIL FONT]) ) (DEFINEQ (DINFO.UPDATE.TEXT.DISPLAY [LAMBDA (GRAPH NODE SEL OFF?) (* drc%: "25-Jan-86 18:18") (LET ((WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (FILENAME (DINFO.GET.FILENAME GRAPH NODE)) (FROM (fetch (DINFONODE FROMBYTE) of NODE)) (TO (fetch (DINFONODE TOBYTE) of NODE)) (PROPS (APPEND (LIST 'READONLY T 'NOTITLE T 'TITLEMENUFN 'DINFO.TITLEMENUFN) (fetch (DINFOGRAPH TEXTPROPS) of GRAPH))) (OLD.TEXTSTREAM (WINDOWPROP (fetch (DINFOGRAPH WINDOW) of GRAPH) 'TEXTSTREAM)) TEXTSTREAM FULLFILENAME) (* Default directory and host.) (if (OR OFF? (NULL FILENAME)) then (OPENTEXTSTREAM (if OFF? then "" else "This node has no text") WINDOW NIL NIL PROPS) (replace (DINFOGRAPH LAST.TEXT) of GRAPH with NIL) elseif (SETQ FULLFILENAME (MKATOM (INFILEP FILENAME))) then (SETQ TEXTSTREAM (DINFO.OPENTEXTSTREAM FULLFILENAME WINDOW FROM TO PROPS)) (DINFO.SHOWSEL TEXTSTREAM SEL) else (OPENTEXTSTREAM (CONCAT "Sorry, can't find the text for this node." (MKSTRING (CHARACTER (CHARCODE CR))) "Missing file is: " FILENAME) WINDOW NIL NIL PROPS) (replace (DINFOGRAPH LAST.TEXT) of GRAPH with NIL)) (CLOSEF? OLD.TEXTSTREAM) (WINDOWPROP WINDOW 'ICONFN 'DINFO.ICONFN) (WINDOWPROP WINDOW 'TEDIT.TITLEMENUFN 'DINFO.TITLEMENUFN]) (DINFO.TITLEMENUFN [LAMBDA (DINFOW) (* drc%: "25-Jan-86 18:19") (* * This is the TEdit TITLEMENUFN for a DInfo Window.  Uses the MENUFN of graph, defaulting to DINFO.DEFAULT.MENU.) (LET [(GRAPH (WINDOWPROP DINFOW 'DINFOGRAPH] (if (OBTAIN.MONITORLOCK (fetch (DINFOGRAPH MONITORLOCK) of GRAPH) T) then [LET ((MENUFN (fetch (DINFOGRAPH MENUFN) of GRAPH))) (if (FGETD MENUFN) then (OR (fetch (DINFOGRAPH FMENU.WINDOW) of GRAPH) (DINFO.ADD.FMENU GRAPH)) (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (APPLY* MENUFN GRAPH)) else (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW DINFOW)) (DINFO.DEFAULT.MENU GRAPH] else (FLASHWINDOW DINFOW) (PROMPTPRINT "DInfo is busy"]) (DINFO.OPENTEXTSTREAM [LAMBDA (FILE WINDOW FROM TO PROPS) (* drc%: "25-Jan-86 18:24") (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW WINDOW)) (LET ((TEXTSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM)) (THIS.TEXT (LIST FILE FROM TO))) (if (AND (EQUAL THIS.TEXT (fetch (DINFOGRAPH LAST.TEXT) of (DINFOGRAPH WINDOW))) TEXTSTREAM) then (* Same text, and its still there, so  do nothing.) TEXTSTREAM else (AND TEXTSTREAM (TEDIT.KILL TEXTSTREAM)) (CLEARW T) (CLEARW WINDOW) [RESETSAVE NIL `(AND RESETSTATE (WINDOWPROP %, WINDOW 'LAST.TEXT NIL] (PRINTOUT T "Fetching text from " FILE "...") (PROG1 (OPENTEXTSTREAM FILE WINDOW FROM TO PROPS) (PRINTOUT T "OK.") (replace (DINFOGRAPH LAST.TEXT) of (DINFOGRAPH WINDOW) with THIS.TEXT]) (DINFO.SHOWSEL [LAMBDA (TEXTSTREAM SEL) (* drc%: "16-Jan-86 21:30") (if (LISTP SEL) then (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM (CADR SEL) 0)) elseif (STRINGP SEL) then [LET ((CHAR# (TEDIT.FIND TEXTSTREAM SEL))) (if CHAR# then (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM CHAR# (NCHARS SEL) NIL T] else (TEDIT.NORMALIZECARET TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 0]) (DINFO.GET.FILENAME [LAMBDA (GRAPH NODE) (* drc%: "10-Jan-86 14:47") (* * returns the filename of the documentation for NODE in GRAPH.  Defaults HOST and DIRECTORY to that of graph) (LET ((FILE (fetch (DINFONODE FILE) of NODE))) (AND FILE (PACKFILENAME 'HOST (OR (FILENAMEFIELD FILE 'HOST) (fetch (DINFOGRAPH DEFAULTHOST) of GRAPH)) 'DEVICE (OR (FILENAMEFIELD FILE 'DEVICE) (fetch (DINFOGRAPH DEFAULTDEVICE) of GRAPH)) 'DIRECTORY (OR (FILENAMEFIELD FILE 'DIRECTORY) (fetch (DINFOGRAPH DEFAULTDIR) of GRAPH)) 'BODY FILE]) ) (ADDTOVAR BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH) "Open a DInfo window for browsing documentation.")) (RPAQQ BackgroundMenu NIL) (RPAQ? DINFO.GRAPHS ) (RPAQ? DINFOMODES '(TEXT GRAPH)) (RPAQ? DINFO.HISTORY.LENGTH 20) (RPAQ? \DINFO.MAX.MENU.LEN 10) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DINFO.GRAPH.FILES DINFOMODES DINFO.HISTORY.LENGTH \DINFO.MAX.MENU.LEN) ) (PUTPROPS DINFO FILETYPE :COMPILE-FILE) (PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6293 23119 (DINFO 6303 . 7917) (DINFO.UPDATE 7919 . 10783) (DINFOGRAPH 10785 . 11203) ( DINFO.SPECIAL.UPDATE 11205 . 12903) (DINFO.READ.GRAPH 12905 . 14760) (DINFO.WRITE.GRAPH 14762 . 15852) (DINFO.SELECT.GRAPH 15854 . 16761) (DINFO.DEFAULT.MENU 16763 . 19287) (DINFO.FIND 19289 . 21673) ( DINFO.LOOKUP 21675 . 23117)) (23120 25814 (DINFO.READ.KOTO.GRAPH 23130 . 25812)) (25815 28129 ( DINFO.SETUP.WINDOW 25825 . 26506) (DINFO.CLOSEFN 26508 . 26941) (DINFO.SHRINKFN 26943 . 27139) ( DINFO.EXPANDFN 27141 . 27698) (DINFO.ICONFN 27700 . 28127)) (28130 38978 (DINFO.ADD.FMENU 28140 . 29235) (DINFO.CREATE.FMENU 29237 . 32774) (DINFO.FMW.CLOSEFN 32776 . 33621) (DINFO.FMENU.HANDLER 33623 . 34262) (DINFO.UPDATE.FMENU 34264 . 36469) (DINFO.TOGGLE.MENU 36471 . 37061) (DINFO.TOGGLE.GRAPH 37063 . 37562) (DINFO.TOGGLE.HISTORY 37564 . 38108) (DINFO.TOGGLE.TEXT 38110 . 38976)) (38979 46677 ( DINFO.UPDATE.MENU.DISPLAY 38989 . 43009) (DINFO.UPDATE.FROM.MENU 43011 . 43310) (DINFO.UPDATE.HISTORY 43312 . 45846) (DINFO.HISTORIC.UPDATE 45848 . 46675)) (46678 56844 (DINFO.UPDATE.GRAPH.DISPLAY 46688 . 48006) (DINFO.UPDATE.FROM.GRAPH 48008 . 48451) (DINFO.GET.GRAPH.WINDOW 48453 . 49038) ( DINFO.CREATE.GRAPH.WINDOW 49040 . 50157) (DINFO.SHOWGRAPH 50159 . 51884) (DINFO.INVERT.NODE 51886 . 53274) (DINFO.LAYOUTGRAPH 53276 . 56842)) (56845 62701 (DINFO.UPDATE.TEXT.DISPLAY 56855 . 58716) ( DINFO.TITLEMENUFN 58718 . 59843) (DINFO.OPENTEXTSTREAM 59845 . 61061) (DINFO.SHOWSEL 61063 . 61796) ( DINFO.GET.FILENAME 61798 . 62699))))) STOP \ No newline at end of file diff --git a/lispusers/DIR-TREE.TEDIT b/lispusers/DIR-TREE.TEDIT new file mode 100644 index 00000000..b347c79b Binary files /dev/null and b/lispusers/DIR-TREE.TEDIT differ diff --git a/lispusers/DIRGRAPHER b/lispusers/DIRGRAPHER new file mode 100644 index 00000000..c3a4ba33 --- /dev/null +++ b/lispusers/DIRGRAPHER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL") (filecreated "26-Jan-88 15:45:41" {erinyes}lyric>dirgrapher.\;2 102873 |changes| |to:| (vars dirgraphercoms) (fns dg.advise-generate-file) |previous| |date:| "20-Aug-87 19:28:44" {erinyes}lyric>dirgrapher.\;1) ; Copyright (c) 1985, 1986, 1900, 1987, 1988 by Shaul Markovitch. All rights reserved. (prettycomprint dirgraphercoms) (rpaqq dirgraphercoms ((files grapher filebrowser) (initvars (* |;;;| "VARIABLES TO BE SET BY THE USER") (dg.promptwindowfont (fontcreate '(gacha 8))) (dg.graph-label-font (fontcreate '(gacha 8))) (dg.vertical-horizontal-option 'vertical) (dg.copy-over nil) (dg.box-all t) (dg.default-dir '{dsk}) (dg.concurrent nil) (dg.concurrent-all t) (dg.max-width 900) (dg.max-height 700) (dg.min-width 200) (dg.min-height 100) (dg.menu-edge 'right) (dg.menu-font littlefont) (dg.file-info-attributes '(size creationdate writedate author)) (dg.default-backup-directory '{floppy}) (dg.stand-alone-hosts '(dsk floppy core)) (dg.background-directories nil)) (vars dg.cancel-button-bm dg.ok-button-bm dg.reset-button-bm (* |;;;| "PROGRAM VARIABLES") (dg.iconfont (fontcreate '(gacha 8))) (dg.directory-was-selected-event (create.event)) (dg.monitor-lock (create.monitorlock "DG.MONITOR")) (dg.last-directory-selected nil) (dg.window-of-last-directory nil)) (fns dg.add-item-to-background-menu dg.advise-generate-file dg.apply-dirgrapher-command dg.apply-fb-on-dir-and-subdirs-command dg.apply-filebrowser-command dg.ask-for-backup-type dg.attach-directory-files-menu dg.backup-command dg.file-exists dg.file-info-command dg.file-info-selection-fn dg.files-hardcopy-command dg.load-files-command dg.newer-file dg.backup-on-default-command dg.backup-on-selected-command dg.connect-dir-command dg.copy-directory-command dg.copy-file-command dg.copybuttoneventfn dg.create-backup-free-menu dg.create-backup-name dg.create-directory-chain dg.create-directory-spec dg.create-directory-tree dg.create-graph-from-tree dg.create-icon-title dg.create-menu dg.create-path-from-file-name dg.create-prefix-from-path dg.create-quit-menu dg.create-subdir-command dg.create-tree-from-lists dg.create-tree-nodes dg.createiconw dg.current-connected-directory dg.delete-directory-command dg.delete-from-tree dg.delete-old-versions-command dg.delete-selected-files-command dg.directory-minus-prefix dg.directory-selection-function dg.display-directory-tree dg.docommand dg.docommand-with-monitor dg.docommand-without-monitor dg.exclusive-directory dg.exclusive-new-versions dg.exclusive-old-versions dg.fbiconfn dg.file-selection-fn dg.filecopy dg.find-directory-subtree dg.find-menu-item dg.find-parent-dierctory dg.flashallwindows dg.get-fb-pattern dg.get-file-list dg.get-initial-region dg.kill-process dg.move-dir-command dg.move-file-command dg.movecopy-command dg.movecopy-dir-command dg.pack-name-ver-ext dg.promptwindow dg.redisplayfn dg.residual-path dg.restore-command dg.restore-from-default-command dg.restore-from-selected-command dg.setify dg.shade-current-directory dg.trim dg.unadvise dg.unadvise-generate-file dg.unpack-directory-name dg.update-command dg.update-directory-tree dg.update-directroy-tree dg.wait-for-dir-selection dirgrapher) (bitmaps dg.icon dg.mask dg.fill-window-texture dg.whitebm) (p (dg.advise-generate-file) (setq dg.background-directories (union dg.background-directories (union directories (cons '{floppy} (for d in (volumes) when (lispdirectoryp d) collect (pack* '{dsk}< d '>)))))) (dg.add-item-to-background-menu '|DirGrapher| '(dirgrapher) "Will initiate dirgrapher process on the current directory" (cons 'subitems (cons '("DG Windows to top" (|for| w |in| (openwindows) |when| (or (windowprop w 'dg.path-to-root) (and (windowprop w 'iconfor) (windowprop (windowprop w 'iconfor) 'dg.path-to-root))) |do| (totopw w))) (for d in dg.background-directories collect (list d (list 'dirgrapher (kwote d)) (concat "WILL APPLY DIRGRAPHER ON " d))))))) (* |;;;| "(declare\\: dontcopy (prop makefile-environment dirgrapher))") )) (filesload grapher filebrowser) (rpaq? dg.promptwindowfont (fontcreate '(gacha 8))) (rpaq? dg.graph-label-font (fontcreate '(gacha 8))) (rpaq? dg.vertical-horizontal-option 'vertical) (rpaq? dg.copy-over nil) (rpaq? dg.box-all t) (rpaq? dg.default-dir '{dsk}) (rpaq? dg.concurrent nil) (rpaq? dg.concurrent-all t) (rpaq? dg.max-width 900) (rpaq? dg.max-height 700) (rpaq? dg.min-width 200) (rpaq? dg.min-height 100) (rpaq? dg.menu-edge 'right) (rpaq? dg.menu-font littlefont) (rpaq? dg.file-info-attributes '(size creationdate writedate author)) (rpaq? dg.default-backup-directory '{floppy}) (rpaq? dg.stand-alone-hosts '(dsk floppy core)) (rpaq? dg.background-directories nil) (rpaqq dg.cancel-button-bm #*(50 20)AOOOOOOOOOON@@@@COOOOOOOOOOO@@@@G@@@@@@@@@@CH@@@N@@@@@@@@@@AL@@@L@@@@@@@@@@@L@@@L@@@@@@@@@@@L@@@LAO@@@@@@@C@L@@@LCAH@@@@@@C@L@@@LCAILGLGHOC@L@@@LC@@FFFLMIK@L@@@LC@ANFFLAOK@L@@@LCAKFFFLAHC@L@@@LCAKFFFLMIK@L@@@LAOAOFFGHOC@L@@@L@@@@@@@@@@@L@@@L@@@@@@@@@@@L@@@N@@@@@@@@@@AL@@@G@@@@@@@@@@CH@@@COOOOOOOOOOO@@@@AOOOOOOOOOON@@@@ ) (rpaqq dg.ok-button-bm #*(50 20)AOOOOOOOOOON@@@@COOOOOOOOOOO@@@@G@@@@@@@@@@CH@@@N@@@@@@@@@@AL@@@L@@@@@@@@@@@L@@@L@GL@@@@@@@@L@@@L@FF@@@@@F@@L@@@L@FFGHOCLOH@L@@@L@FFLMIFFF@@L@@@L@GLOMLGNF@@L@@@L@FFL@GF@F@@L@@@L@FFLMCFFF@@L@@@L@FFGINCLCH@L@@@L@@@@@@@@@@@L@@@L@@@@@@@@@@@L@@@L@@@@@@@@@@@L@@@N@@@@@@@@@@AL@@@G@@@@@@@@@@CH@@@COOOOOOOOOOO@@@@AOOOOOOOOOON@@@@ ) (rpaqq dg.reset-button-bm #*(50 20)AOOOOOOOOOON@@@@COOOOOOOOOOO@@@@G@@@@@@@@@@CH@@@N@@@@@@@@@@AL@@@L@@@@@@@@@@@L@@@L@GL@@@@@@@@L@@@L@FF@@@@@F@@L@@@L@FFGHOCLOH@L@@@L@FFLMIFFF@@L@@@L@GLOMLGNF@@L@@@L@FFL@GF@F@@L@@@L@FFLMCFFF@@L@@@L@FFGINCLCH@L@@@L@@@@@@@@@@@L@@@L@@@@@@@@@@@L@@@L@@@@@@@@@@@L@@@N@@@@@@@@@@AL@@@G@@@@@@@@@@CH@@@COOOOOOOOOOO@@@@AOOOOOOOOOON@@@@ ) (rpaq dg.iconfont (fontcreate '(gacha 8))) (rpaq dg.directory-was-selected-event (create.event)) (rpaq dg.monitor-lock (create.monitorlock "DG.MONITOR")) (rpaqq dg.last-directory-selected nil) (rpaqq dg.window-of-last-directory nil) (defineq (dg.add-item-to-background-menu (lambda (label command message subitemlist) (* |edited:| "13-May-86 14:03") (declare (globalvars |BackgroundMenuCommands| |BackgroundMenu|)) (setq |BackgroundMenuCommands| (remove (fassoc label |BackgroundMenuCommands|) |BackgroundMenuCommands|)) (nconc1 |BackgroundMenuCommands| (list label command message subitemlist)) (setq |BackgroundMenu| nil))) (dg.advise-generate-file (lambda nil (* \; "Edited 26-Jan-88 15:42 by smL") (movd '\\generatenextfile 'dg.generate-next-file t) (unadvise (\\generatenextfile in fb.updatebrowseritems)) (advise '(\\generatenextfile in fb.updatebrowseritems) 'around '(prog* ((window (tb.window (fb.tablebrowser browser))) (pattern (dg.get-fb-pattern window)) (fbdir (u-case (filenamefield pattern 'directory))) (fbhost (u-case (filenamefield pattern 'host))) next-file temp-host) (declare (global dg.stand-alone-hosts)) (setq fbhost (|if| (fmemb fbhost dg.stand-alone-hosts) |then| fbhost |else| (or (canonical.hostname fbhost) fbhost))) next (setq next-file (dg.generate-next-file genobj nameonly)) (|if| (null next-file) |then| (return nil)) (|if| (listp next-file) |then| (setq next-file (packc next-file))) (|if| (or (not (windowprop (mainwindow window) 'dg.directory-only)) (and (eq (u-case (filenamefield next-file 'directory)) fbdir) (eq (filenamefield next-file 'host) fbhost))) |then| (return next-file) |else| (go next)))))) (dg.apply-dirgrapher-command (lambda (window) (* |edited:| " 3-Apr-85 11:27") (prog (current-path dir-file-list fb-window temp-string) (setq current-path (car (dg.wait-for-dir-selection window "Select directory on which to apply DirGrapher."))) (cond (current-path (invertw window) (dirgrapher (dg.create-prefix-from-path current-path)) (invertw window)))))) (dg.apply-fb-on-dir-and-subdirs-command (lambda (window) (* |sm| "10-Jun-85 14:42") (dg.apply-filebrowser-command window t))) (dg.apply-filebrowser-command (lambda (window subdirs) (* |edited:| " 7-May-86 13:09") (prog (current-path dir-file-list fb-window temp-string) (setq current-path (car (dg.wait-for-dir-selection window "Select directory on which to apply FileBrowser."))) (cond (current-path (invertw window) (setq fb-window (filebrowser (dg.create-prefix-from-path current-path))) (|if| (not subdirs) |then| (windowprop fb-window 'dg.directory-only t)) (windowprop fb-window 'iconfn 'dg.fbiconfn) (invertw window)))))) (dg.ask-for-backup-type (lambda (current-directory) (* |sm| " 9-Jun-85 11:53") (prog (backup-type) (cond ((null (cdr current-directory)) (setq backup-type 'files-only)) (t (setq backup-type (menu (|create| menu items _ (list (list "Back up files in this directory (but not in subdirectories)" ''files-only) (list "Backup files of this directory and subdirectories" ''files-and-subs)) menufont _ bigfont) nil t)))) (return backup-type)))) (dg.attach-directory-files-menu (lambda (path window main-window file-selection-fn includefullnames) (* |edited:| "16-May-86 15:56") (declare (globalvars littlefont screenheight)) (prog (menu file-list number-of-columns number-of-rows length-file-list max-width menu-window) (setq file-selection-fn (or file-selection-fn 'dg.file-selection-fn)) (setq file-list (cons '\ stop (|for| f |in| (dg.exclusive-directory ( dg.create-prefix-from-path path)) |collect| (|if| includefullnames |then| (list (dg.pack-name-ver-ext f) f) |else| (dg.pack-name-ver-ext f))))) (|if| (cdr file-list) |then| (setq length-file-list (length file-list)) (setq max-width 6) (|for| f |in| file-list |bind| width |when| (greaterp (setq width (stringwidth (|if| includefullnames |then| (car f) |else| f) littlefont)) max-width) |do| (setq max-width width)) (setq number-of-columns (max 1 (iquotient (car (windowsize main-window)) max-width))) (setq number-of-rows (iplus (iquotient length-file-list number-of-columns) (|if| (eqp (iremainder length-file-list number-of-columns) 0) |then| 0 |else| 1))) (setq file-list (append file-list (|for| i |from| (add1 length-file-list) |to| (itimes number-of-columns number-of-rows) |collect| " "))) (setq file-list (|for| row |from| 1 |to| number-of-rows |join| (|for| i |in| (nth file-list row) |by| (nth i (add1 number-of-rows)) |collect| i))) (setq menu-window (attachmenu (|create| menu items _ file-list whenselectedfn _ file-selection-fn menucolumns _ number-of-columns menufont _ littlefont) main-window (|if| (greaterp (iplus (|fetch| bottom |of| (windowregion main-window)) (iquotient (cdr (windowsize main-window)) 2)) (iquotient screenheight 2)) |then| 'bottom |else| 'top) 'justify)) (return menu-window) |else| (return nil))))) (dg.backup-command (lambda (window backup-dir) (* |edited:| "13-May-86 14:02") (declare (globalvars dg.directory-subtree dg.files-backup-names copyrightflg dg.copy-over filelst )) (prog (backup-type source-path source-directory files-to-backup round-of-files files-backup-names backup-host oldcopyrightflg source-path-and-window source-window) (setq source-path-and-window (dg.wait-for-dir-selection window "Select the directory that you want to back up." t)) (setq source-path (car source-path-and-window)) (setq source-window (cadr source-path-and-window)) (setq source-directory (dg.find-directory-subtree source-path source-window)) (setq backup-type (dg.ask-for-backup-type source-directory)) (|if| (null (filenamefield backup-dir 'directory)) |then| (setq backup-dir (pack* backup-dir '<))) (setq backup-host (filenamefield backup-dir 'host)) (invertw window) (setq files-to-backup (|if| (eq backup-type 'files-and-subs) |then| (directory (dg.create-prefix-from-path source-path)) |else| (dg.exclusive-directory (dg.create-prefix-from-path source-path)))) (setq files-backup-names (|for| f |in| files-to-backup |collect| (dg.create-backup-name f source-path source-directory))) (setq dg.files-backup-names files-backup-names) (setq dg.directory-subtree source-directory) (set (filecoms 'backupinfo) '((vars dg.files-backup-names dg.directory-subtree))) (putprop 'backupinfo 'filetype 'don\'tlist) (cond ((eq backup-type 'files-and-subs) (setq dg.directory-subtree source-directory)) (t (setq dg.directory-subtree nil))) (|if| (eq backup-host 'floppy) |then| (invertw window) (|printout| (dg.promptwindow window) t "Insert floppy .") (floppy.wait.for.floppy) (invertw window)) (setq oldcopyrightflg copyrightflg) (setq copyrightflg nil) (makefile (pack* backup-dir (car source-directory) '> 'backupinfo) 'new) (setq copyrightflg oldcopyrightflg) (|while| files-to-backup |do| (|for| f1 |in| files-to-backup |as| f2 |in| files-backup-names |do| (|if| (and (not dg.copy-over) (dg.file-exists (pack* backup-dir f2)) (not (dg.newer-file f1 (pack* backup-dir f2)))) |then| (|printout| (dg.promptwindow window) t "File " f1 " exists on " backup-dir " and was not copied.") (setq files-to-backup (remove f1 files-to-backup)) (setq files-backup-names (remove f2 files-backup-names)) |else| (|if| (and dg.copy-over (dg.file-exists (pack* backup-dir f2))) |then| (delfile (pack* backup-dir f2))) (|if| (or (neq backup-host 'floppy) (greaterp (floppy.free.pages) (iplus (getfileinfo f1 'size) 400))) |then| (|if| (dg.filecopy f1 (pack* backup-dir f2) dg.copy-over) |then| (|printout| (dg.promptwindow window) t "File " f1 " is backed up.") |else| (|printout| (dg.promptwindow window) t "File " f1 " exists on " backup-dir " and was not copied.")) (setq files-to-backup (remove f1 files-to-backup)) (setq files-backup-names (remove f2 files-backup-names))) )) (|if| files-to-backup |then| (invertw window) (clearw (dg.promptwindow window)) (|printout| (dg.promptwindow window) t "No more space on this floppy. Insert a new one. ") (flashwindow (dg.promptwindow window) 3) (|for| i |from| 100 |to| 1000 |by| 200 |do| (playtune (list (cons i 5000)))) (floppy.wait.for.floppy t) (invertw window))) (setq filelst (remove 'backupinfo filelst)) (invertw window)))) (dg.file-exists (lambda (f) (* |edited:| " 6-Mar-86 14:43") (infilep f))) (dg.file-info-command (lambda (window) (* |edited:| "16-May-86 15:59") (declare (globalvars dg.promptwindowfont littlefont dg.file-info-attributes)) (prog (source-path selected-files source-prefix menu-window source-path-window wregion title-width title columns datewidth pwindow) (setq pwindow (dg.promptwindow window)) (setq source-path (car (dg.wait-for-dir-selection window "Select directory from which you want to files info."))) (cond (source-path (invertw window) (setq source-prefix (dg.create-prefix-from-path source-path)) (setq title " ") (|while| (greaterp (stringwidth "MMMMMMMMMMMMMMMMMMMM : " dg.promptwindowfont) (stringwidth title littlefont)) |do| (setq title (concat title " "))) (setq datewidth (stringwidth (date) dg.promptwindowfont)) (|for| i |in| dg.file-info-attributes |bind| i-with-blanks |do| (setq columns (nconc1 columns (stringwidth title littlefont))) (setq i-with-blanks i) (|if| (member i '(writedate readdate creationdate)) |then| (|while| (greaterp datewidth (stringwidth i-with-blanks littlefont)) |do| (setq i-with-blanks (concat i-with-blanks " ")))) (setq title (concat title i-with-blanks " "))) (windowprop window 'dg.info-columns columns) (setq title-width (stringwidth title littlefont)) (|if| (greaterp title-width (|fetch| width |of| (windowprop pwindow 'region))) |then| (setq wregion (windowregion window)) (|replace| width |of| wregion |with| (iplus (|fetch| width |of| wregion) (idifference title-width (|fetch| width |of| (windowprop pwindow 'region))))) (invertw window) (reshapeallwindows window wregion) (invertw window)) (windowprop pwindow 'title title) (setq menu-window (dg.attach-directory-files-menu source-path window window 'dg.file-info-selection-fn t)) (invertw window) (|if| menu-window |then| (windowprop menu-window 'dg.detach t) (clearw (dg.promptwindow window)) (await.event (windowprop window 'dg.file-selection-ended-event) 1000000) (detachwindow menu-window) (closew menu-window)) (windowprop pwindow 'title nil)))))) (dg.file-info-selection-fn (lambda (item menu key) (* |edited:| "13-May-86 14:17") (declare (globalvars dg.file-info-attributes)) (prog (window) (setq window (mainwindow (wfrommenu menu))) (cond ((eq item '\ stop) (notify.event (windowprop window 'dg.file-selection-ended-event))) ((equal item " ")) (item (printout (dg.promptwindow window) t (substring (car item) 1 (min (nchars (car item) 20))) " : ") (|for| att |in| dg.file-info-attributes |as| col |in| (windowprop window 'dg.info-columns) |do| (dspxposition col (dg.promptwindow window)) (printout (dg.promptwindow window) (getfileinfo (cadr item) att)))))))) (dg.files-hardcopy-command (lambda (window) (* |edited:| "13-May-86 14:06") (prog (source-path selected-files source-prefix menu-window source-path-window) (setq source-path (car (dg.wait-for-dir-selection window "Select directory from which you want to hardcopy selected files." ))) (cond (source-path (setq source-prefix (dg.create-prefix-from-path source-path)) (setq menu-window (dg.get-file-list " The selected files will be hardcopied. " window source-path window)) (setq selected-files (windowprop menu-window 'dg.selected-files)) (|if| selected-files |then| (invertw window) (|for| file |in| selected-files |do| (listfiles1 (pack* source-prefix file)) (shadeitem file (car (windowprop menu-window 'menu)) highlightshade menu-window) (block)) (invertw window)) (detachwindow menu-window) (closew menu-window)))))) (dg.load-files-command (lambda (window loadtype ldflg) (* |edited:| "13-May-86 16:31") (declare (globalvars highlightshade)) (prog (source-path selected-files source-prefix menu-window source-path-window) (setq loadtype (or loadtype 'load)) (setq source-path (car (dg.wait-for-dir-selection window (concat "Select directory from which you want to " loadtype " selected files." )))) (cond (source-path (setq source-prefix (dg.create-prefix-from-path source-path)) (setq menu-window (dg.get-file-list " The selected files will be LOADED. " window source-path window)) (setq selected-files (windowprop menu-window 'dg.selected-files)) (|if| selected-files |then| (invertw window) (|for| file |in| selected-files |do| (apply* loadtype (pack* source-prefix file) ldflg) (shadeitem file (car (windowprop menu-window 'menu)) highlightshade menu-window) (block)) (invertw window)) (detachwindow menu-window) (closew menu-window)))))) (dg.newer-file (lambda (f1 f2) (* |edited:| " 7-Mar-86 15:31") (greaterp (getfileinfo f1 'icreationdate) (getfileinfo f2 'icreationdate)))) (dg.backup-on-default-command (lambda (window) (* |edited:| "13-May-86 13:56") (declare (globalvars dg.default-backup-directory)) (|if| (null dg.default-backup-directory) |then| (dg.flashallwindows window) (|printout| (dg.promptwindow window) t "NULL default directory.Backup aborted") |else| (dg.backup-command window dg.default-backup-directory)))) (dg.backup-on-selected-command (lambda (window) (* |sm| " 8-Jun-85 12:49") (prog (backup-directory) (setq backup-directory (dg.create-prefix-from-path (car (dg.wait-for-dir-selection window "Select the directory that will contain the backup." t)))) (dg.backup-command window backup-directory)))) (dg.connect-dir-command (lambda (window) (* |edited:| "13-May-86 13:55") (declare (globalvars dg.box-all)) (prog (current-path current-prefix) (setq current-path (car (dg.wait-for-dir-selection window "Select the directory to which you want to be connected"))) (cond (current-path (cndir (setq current-prefix (dg.create-prefix-from-path current-path))) (|if| dg.box-all |then| (|for| w |in| (openwindows) |when| (windowprop w 'dg.tree) |do| (dg.shade-current-directory w)) |else| (dg.shade-current-directory window))))))) (dg.copy-directory-command (lambda (window) (* |edited:| " 2-Apr-85 18:02") (dg.movecopy-dir-command window))) (dg.copy-file-command (lambda (window) (* |edited:| " 2-Apr-85 18:05") (dg.movecopy-command window))) (dg.copybuttoneventfn (lambda (window) (* |sm| " 9-Jul-85 12:28") (prog (cursor-pos selected-node node-region released) (setq cursor-pos (cursorposition nil window)) (setq released (mousestate (and (not left) (not middle) (not right)))) (|if| (setq selected-node (|for| node |in| (|fetch| graphnodes |of| (windowprop window 'graph)) |thereis| (insidep (setq node-region (noderegion node)) cursor-pos))) |then| (flipnode selected-node window) |else| (graphercopybuttoneventfn window)) (|if| (and released selected-node) |then| (bksysbuf (dg.create-prefix-from-path (append (windowprop window ' dg.path-to-root) (cdr (|fetch| nodeid |of| selected-node ))))))))) (dg.create-backup-free-menu (lambda (left bottom) (* |edited:| "16-May-86 17:50") (fm.formatmenu (list '((type title label "Files to Backup : " font (modern 12 bold)) (type toggle label "Include SubDirectories" id subdirs) (type toggle label "No Old Versions" id subdirs)) (list `(type nway label ,dg.ok-button-bm id buttons) `(type nway label ,\,dg.reset-button-bm id buttons) `(type nway label ,\,dg.cancel-button-bm id buttons)))))) (dg.create-backup-name (lambda (f current-path current-directory) (* |edited:| " 5-Apr-85 10:34") (prog (second-half file-backup-name) (setq second-half (substring (filenamefield f 'directory) (iplus 2 (nchars (dg.create-directory-chain (cdr current-path)))) (nchars (filenamefield f 'directory)))) (setq file-backup-name (packfilename 'directory (cond (second-half (dg.create-directory-chain (list (car current-directory ) second-half))) (t (car current-directory))) 'name (filenamefield f 'name) 'extension (filenamefield f 'extension) 'version (filenamefield f 'version))) (return (pack (cdr (unpack file-backup-name))))))) (dg.create-directory-chain (lambda (path) (* |sm| " 9-Jun-85 11:49") (cond ((null path) '"") ((null (cdr path)) (car path)) (t (pack* (car path) '> (dg.create-directory-chain (cdr path))))))) (dg.create-directory-spec (lambda (path window) (* |edited:| "31-Dec-00 22:14") (prog (current-directory spec) (setq current-directory (dg.find-directory-subtree path window)) (setq spec (dg.create-prefix-from-path path)) (|for| sub |in| (cdr current-directory) |do| (setq spec (list spec '- (dg.create-prefix-from-path (append path (list (car sub))))))) (return spec)))) (dg.create-directory-tree (lambda (path) (* |edited:| "13-May-86 12:34") (prog (tree-paths root tree) (setq tree-paths (|for| f |in| (directory (dg.create-prefix-from-path path)) |collect| (nth (dg.create-path-from-file-name f) (length path)))) (setq tree-paths (dg.setify tree-paths)) (setq tree (car (dg.create-tree-from-lists tree-paths))) (|if| tree |then| (return tree) |else| (return (last path)))))) (dg.create-graph-from-tree (lambda (tree) (* |edited:| "13-May-86 14:09") (declare (globalvars dg.vertical-horizontal-option dg.graph-label-font)) (prog (node-list) (setq node-list (dg.create-tree-nodes tree nil)) (return (layoutgraph (cdr node-list) (list (car node-list)) (list dg.vertical-horizontal-option) dg.graph-label-font))))) (dg.create-icon-title (lambda (l) (* |edited:| " 5-Apr-85 11:16") (cond (l (cond ((greaterp (length l) 3) (setq l (cdr (lastn l 3))))) (apply 'concat (cons (dg.trim (car l) 11) (|for| w |in| (cdr l) |collect| (concat (character 13) (dg.trim w 11)))))) (t " ")))) (dg.create-menu (lambda (window) (* |edited:| "16-May-86 16:19") (declare (globalvars dg.menu-edge dg.menu-font)) (prog (menuitems temp) (setq menuitems '(("Create Dir" dg.create-subdir-command "Creates subdirectory. Will wait for parent directory selection, and prompt for subdirectory name" ) ("Delete Dir" dg.delete-directory-command "Will delete entire directory including all files in subdirectories. Will wait for directory selection and if the directory is nonempty it will ask for confirmation" ) ("Backup Dir" dg.backup-on-selected-command "Will ask you to select the directory on which the backup should be stored" (subitems ("On default" dg.backup-on-default-command "Will backup the selected directory on the default backup directory (the value of DG.DEFAULT-BACKUP-DIRECTORY ) " ) ("On selected" dg.backup-on-selected-command "Will ask you to select the directory on which the backup should be stored" ))) ("Restore Dir" dg.restore-from-selected-command "Will ask you to select the directory from where the backup should be restored" (subitems ("From default" dg.restore-from-default-command "Will restore the selected directory from the default backup directory (the value of DG.DEFAULT-BACKUP-DIRECTORY ) " ) ("From selected" dg.restore-from-selected-command "Will ask you to select the directory from where the backup should be restored" ))) ("Move Dir" dg.move-dir-command "Will move the selected directory (including subdirectories) to a new parent directory." ) ("Copy Dir" dg.copy-directory-command "Will copy the selected directory (including subdirectories) to a new parent directory." ) ("Connect Dir" dg.connect-dir-command "Changes the current directory") ("Apply DG" dg.apply-dirgrapher-command "Calls DirGrapher on the selected directory") ("Apply FB" dg.apply-filebrowser-command "Calls FileBrowser on files in the selected directory (but not files in the subdirectories)." (subitems ("on directory only" dg.apply-filebrowser-command "Calls FileBrowser on files in the selected directory (but not files in the subdirectories)." ) ("On directory and subdirectories" dg.apply-fb-on-dir-and-subdirs-command "Calls FileBrowser on files in the selected directory and subdirectories." ))) ("Files" null " The subitems of the item manipulate files within selected directories" (subitems ("Move Files" dg.move-file-command "Will ask you to select: (1) source directory, (2) files to be moved, and (3) target directory." ) ("Copy Files" dg.copy-file-command "Will ask you to select: (1) source directory, (2) files to be copied, and (3) target directory." ) ("Load Files" (dg.load-files-command load nil) "Will ask you to select a directory and files to be loaded" (subitems ("LOAD" (dg.load-files-command load nil) "Will ask you to select a directory and files to be loaded" (subitems ("LDFLG=NIL" ( dg.load-files-command load nil)) ("LDFLG=SYSLOAD" (dg.load-files-command load sysload)))) ("LOAD?" (dg.load-files-command load? nil) "Will ask you to select a directory and files to be loaded USING LOAD? function" (subitems ("LDFLG=NIL" ( dg.load-files-command load? nil)) ("LDFLG=SYSLOAD" ( dg.load-files-command load? sysload )))) ("LOADFROM" (dg.load-files-command loadfrom nil) "Will ask you to select a directory and files to be loaded USING LOADFROM function" (subitems ("LDFLG=NIL" ( dg.load-files-command loadfrom nil)) ("LDFLG=SYSLOAD" ( dg.load-files-command loadfrom sysload)))))) ("Delete Files" dg.delete-selected-files-command "Will ask you to select a directory and files to be deleted (EXPUNGED)." (subitems ("Selected Files" dg.delete-selected-files-command "Will ask you to select a directory and files to be deleted (EXPUNGED)." ) ("Old Versions" dg.delete-old-versions-command " Will ask you to select a directory, and will delete all old versions of files in the selected directory. Only DG.NUMBER-OF-VERSIONS (1 by default) last versions will remain" ))) ("Info" dg.file-info-command "Will ask you to select a directory, and will display info on selected files. " ) ("Hardcopy" dg.files-hardcopy-command "Will ask you to select a directory and files to be hardcopied." ))) ("Update" dg.update-command "Will update the tree structure according to the current file system state" ))) (|if| (fmemb dg.menu-edge '(top bottom)) |then| (setq menuitems (copy menuitems)) (setq temp (caddr menuitems)) (rplaca (cddr menuitems) (car (nth menuitems 8))) (rplaca (nth menuitems 8) temp)) (return (|create| menu items _ menuitems menucolumns _ (|if| (fmemb dg.menu-edge '(top bottom)) |then| 4 |else| 1) whenselectedfn _ 'dg.docommand menufont _ dg.menu-font))))) (dg.create-path-from-file-name (lambda (fname) (* |edited:| " 3-Apr-85 15:41") (prog (dir host) (setq dir (filenamefield fname 'directory)) (setq host (filenamefield fname 'host)) (return (|if| host |then| (cons (packfilename 'host (filenamefield fname 'host)) (|if| (null dir) |then| nil |else| (dg.unpack-directory-name (unpack dir)))) |else| (|if| (null dir) |then| nil |else| (dg.unpack-directory-name (unpack dir)))))))) (dg.create-prefix-from-path (lambda (path) (* |edited:| "17-Jul-84 14:58") (cond ((cdr path) (pack* (car path) '< (pack (|for| d |in| (cdr path) |join| (list d '>))))) (t (car path))))) (dg.create-quit-menu (lambda (window) (* |edited:| "12-May-86 13:06") (|create| menu items _ (subst window 'window '((" I n t e r r u p t / R e s e t " ( dg.kill-process window) "Will kill the current DirGrapher process if active, and will reset the DirGrapher display." ))) centerflg _ t))) (dg.create-subdir-command (lambda (window) (* |edited:| "30-Sep-85 14:45") (prog (current-path new-dir-name directory-subtree) (setq current-path (car (dg.wait-for-dir-selection window "Select parent directory."))) (cond (current-path (setq directory-subtree (dg.find-directory-subtree current-path window)) (terpri (dg.promptwindow window)) (setq new-dir-name (mkatom (promptforword (concat "Enter name for new subdirectory (of " (car directory-subtree) ") :") nil nil (dg.promptwindow window) nil 'tty))) (cond ((member new-dir-name (cdr directory-subtree))) (t (rplacd directory-subtree (cons (list new-dir-name) (cdr directory-subtree))) (dg.display-directory-tree (dg.create-graph-from-tree (windowprop window 'dg.tree)) window)))))))) (dg.create-tree-from-lists (lambda (lists) (* |edited:| "13-May-86 12:10") (prog (temp l2) (|for| x |in| lists |when| x |do| (cond ((not (setq temp (fassoc (car x) l2))) (setq l2 (cons (list (car x) (cdr x)) l2))) (t (rplacd temp (cons (cdr x) (cdr temp))))) (block)) (return (|for| x |in| l2 |collect| (cons (car x) (dg.create-tree-from-lists (cdr x)))))))) (dg.create-tree-nodes (lambda (tree former-path) (* |edited:| " 3-Apr-85 22:05") (prog (current-id to-nodes current-node) (cond (tree (return (cons (setq current-id (append former-path (list (car tree)))) (cons (setq current-node (|create| graphnode nodeid _ current-id nodelabel _ (car tree) fromnodes _ (list former-path) nodeborder _ -2)) (prog (son-list) (setq son-list (|for| son |in| (cdr tree) |join| (prog (n-list) (setq n-list (dg.create-tree-nodes son current-id)) (setq to-nodes (cons (car n-list) to-nodes)) (return (cdr n-list))))) (|replace| tonodes |of| current-node |with| to-nodes) (return son-list)))))))))) (dg.createiconw (lambda (window icon) (* |edited:| " 5-Apr-85 11:13") (cond ((null icon) (setq icon (titlediconw (|create| titledicon icon _ dg.icon mask _ dg.mask titlereg _ (createregion 5 5 65 60)) (windowprop window 'dg.icontitle) dg.iconfont)))) icon)) (dg.current-connected-directory (lambda nil (* |edited:| "22-May-85 13:55") (prog (current-dir) (setq current-dir (directoryname t t)) (|if| (not (fmemb (car (last (unpack current-dir))) '(} >))) |then| (return (pack* current-dir '>)) |else| (return current-dir))))) (dg.delete-directory-command (lambda (window) (* |edited:| "19-Apr-85 14:23") (prog (current-path current-directory father-directory files-to-be-deleted number-of-files) (setq current-path (car (dg.wait-for-dir-selection window "Select directory to be deleted") )) (cond (current-path (invertw window) (setq files-to-be-deleted (directory (dg.create-prefix-from-path current-path))) (invertw window) (setq number-of-files (length files-to-be-deleted)) (cond ((greaterp number-of-files 0) (|printout| (dg.promptwindow window) t "CAUTION !!! " number-of-files " files are going to be deleted !!" "Confirm with left button .") (flashwindow (dg.promptwindow window) 2) (cond ((mouseconfirm) (invertw window) (|for| f |in| files-to-be-deleted |do| (delfile f) (|printout| (dg.promptwindow window) t "File " f " was deleted." )) (invertw window)) (t (|printout| (dg.promptwindow window) t "Delete directory aborted.") (return nil))))) (cond ((equal current-path (windowprop window 'dg.path-to-root)) (closew window) (return nil))) (dg.delete-from-tree current-path window)))))) (dg.delete-from-tree (lambda (path window) (* |edited:| "13-May-86 13:58") (prog (parent-and-son father-directory) (setq parent-and-son (dg.find-parent-dierctory path window)) (setq father-directory (car parent-and-son)) (rplacd father-directory (remove (cadr parent-and-son) (cdr father-directory))) (dg.display-directory-tree (dg.create-graph-from-tree (windowprop window 'dg.tree)) window)))) (dg.delete-old-versions-command (lambda (window) (* |edited:| "13-May-86 12:07") (prog (source-path selected-files source-prefix menu-window source-path-window) (setq source-path (car (dg.wait-for-dir-selection window "Select directory from which you want to delete old versions of files." ))) (cond (source-path (setq source-prefix (dg.create-prefix-from-path source-path)) (setq selected-files (dg.exclusive-old-versions source-prefix)) (|if| selected-files |then| (printout (dg.promptwindow window) t " " (length selected-files) " files will be DELETED from " source-prefix " . Approve with left button. ") (|if| (mouseconfirm) |then| (invertw window) (|for| file |in| selected-files |do| (delfile file) (printout (dg.promptwindow window) t file " was deleted. ") (block)) (invertw window) |else| (printout (dg.promptwindow window) t " Delete files aborted."))) (detachwindow menu-window) (closew menu-window)))))) (dg.delete-selected-files-command (lambda (window) (* |edited:| "13-May-86 16:31") (declare (globalvars highlightshade)) (prog (source-path selected-files source-prefix menu-window source-path-window) (setq source-path (car (dg.wait-for-dir-selection window "Select directory from which you want to delete selected files." ))) (cond (source-path (setq source-prefix (dg.create-prefix-from-path source-path)) (setq menu-window (dg.get-file-list (concat " The selected files will be " " DELETED (EXPUNGED) " " from " source-prefix " .") window source-path window)) (setq selected-files (windowprop menu-window 'dg.selected-files)) (|if| selected-files |then| (printout (dg.promptwindow window) t " " (length selected-files) " files will be DELETED from " source-prefix " . Approve with left button. ") (|if| (mouseconfirm) |then| (invertw window) (|for| file |in| selected-files |do| (delfile (pack* source-prefix file)) (shadeitem file (car (windowprop menu-window 'menu)) highlightshade menu-window) (block)) (invertw window) |else| (printout (dg.promptwindow window) t " Delete files aborted."))) (detachwindow menu-window) (closew menu-window)))))) (dg.directory-minus-prefix (lambda (directory prefix) (* |edited:| "27-Mar-85 23:50") (cond (prefix (subatom directory (iplus 2 (nchars prefix)) (nchars directory))) (t directory)))) (dg.directory-selection-function (lambda (selected-obj g-window) (* |edited:| "13-May-86 14:26") (declare (globalvars dg.last-directory-selected dg.window-of-last-directory dg.directory-was-selected-event)) (prog (current-node) (cond (selected-obj (setq dg.last-directory-selected (append (windowprop g-window ' dg.path-to-root) (cdr (|fetch| nodeid |of| selected-obj )))) (setq dg.window-of-last-directory g-window))) (notify.event dg.directory-was-selected-event t)))) (dg.display-directory-tree (lambda (graph window) (* |sm| " 8-Jul-85 17:27") (showgraph graph window 'dg.directory-selection-function 'dg.directory-selection-function) (windowprop window 'repaintfn (cons 'dg.redisplayfn (mklist (windowprop window 'repaintfn)))) (windowprop window 'copybuttoneventfn 'dg.copybuttoneventfn) (dg.shade-current-directory window))) (dg.docommand (lambda (item menu key) (* |edited:| "13-May-86 14:27") (declare (globalvars dg.concurrent dg.concurrent-all dg.monitor-lock)) (prog (window) (setq window (mainwindow (wfrommenu menu))) (cond ((not dg.concurrent-all) (dg.docommand-with-monitor dg.monitor-lock window item menu)) ((not dg.concurrent) (dg.docommand-with-monitor (windowprop window 'dg.lock) window item menu)) (t (dg.docommand-without-monitor window item menu)))))) (dg.docommand-with-monitor (lambda (monitor-lock window item menu) (* |edited:| " 8-May-86 12:10") (prog (parent-item) (setq parent-item (dg.find-menu-item item (|fetch| items |of| menu))) (windowprop window 'dg.process (add.process (subpair '(monitor-lock window menu item parent-item) (list monitor-lock window menu item parent-item) '(progn (with.monitor monitor-lock (ttydisplaystream (dg.promptwindow window)) (shadeitem 'parent-item menu grayshade) (windowprop window 'dg.unshade-if-shaded '(shadeitem 'parent-item menu whiteshade)) (clearw (dg.promptwindow window)) (if (atom (cadr 'item)) then (apply* (cadr 'item) window) else (apply (caadr 'item) (cons window (cdadr 'item)))) (printout (dg.promptwindow window) t (car 'parent-item) " Completed. ") (windowprop window 'dg.unshade-if-shaded nil) (shadeitem 'parent-item menu whiteshade) (windowprop window 'dg.shaded-item nil) (windowprop window 'dg.process nil)))) 'window (dg.promptwindow window) 'name (car parent-item)))))) (dg.docommand-without-monitor (lambda (window item menu) (* |edited:| " 8-May-86 12:10") (windowprop window 'dg.process (add.process (subpair '(window menu item) (list window menu item) '(progn (ttydisplaystream (dg.promptwindow window)) (shadeitem 'item menu grayshade) (windowprop window 'dg.shaded-item 'item) (clearw (dg.promptwindow window)) (if (atom (cadr 'item)) then (apply* (cadr 'item) window) else (apply (caadr 'item) (cons window (cdadr 'item)))) (printout (dg.promptwindow window) t (car 'item) " Completed. ") (shadeitem 'item menu whiteshade) (windowprop window 'dg.shaded-item nil) (windowprop window 'dg.process nil))) 'window (dg.promptwindow window) 'name (car item))))) (dg.exclusive-directory (lambda (directory-pattern) (* |edited:| "22-May-85 12:23") (prog (current-directory) (setq current-directory (filenamefield directory-pattern 'directory)) (return (|for| f |in| (directory directory-pattern) |when| (eq (filenamefield f 'directory) current-directory) |collect| f))))) (dg.exclusive-new-versions (lambda (directory-pattern) (* |edited:| "16-May-86 16:24") (prog (current-directory) (setq current-directory (filenamefield directory-pattern 'directory)) (return (|for| file |in| (|for| f |in| (directory directory-pattern) |when| (eq (filenamefield f 'directory) current-directory) |collect| f) |when| (equal file (infilep (packfilename.string 'version nil 'body file))) |collect| file))))) (dg.exclusive-old-versions (lambda (directory-pattern) (* |edited:| " 7-May-86 17:59") (prog (current-directory) (setq current-directory (filenamefield directory-pattern 'directory)) (return (|for| file |in| (|for| f |in| (directory directory-pattern) |when| (eq (filenamefield f 'directory) current-directory) |collect| f) |when| (not (equal file (infilep (packfilename.string 'version nil 'body file))) ) |collect| file))))) (dg.fbiconfn (lambda (window icon) (* |edited:| "13-May-86 14:25") (declare (globalvars filedrawer filedrawerregion dg.iconfont)) (cond ((null icon) (setq icon (titlediconw (|create| titledicon icon _ filedrawer titlereg _ filedrawerregion) (dg.create-icon-title (dg.create-path-from-file-name (dg.get-fb-pattern window))) dg.iconfont))) ((iconw.title icon (dg.create-icon-title (dg.create-path-from-file-name (dg.get-fb-pattern window)))))) icon)) (dg.file-selection-fn (lambda (item menu key) (* |edited:| "13-May-86 14:08") (declare (globalvars whiteshade blackshade)) (prog (window) (setq window (wfrommenu menu)) (cond ((eq item '\ stop) (notify.event (windowprop (mainwindow window) 'dg.file-selection-ended-event))) ((equal item " ")) (item (cond ((fmemb item (windowprop window 'dg.selected-files)) (windowdelprop window 'dg.selected-files item) (shadeitem item menu whiteshade window)) (t (windowaddprop window 'dg.selected-files item) (shadeitem item menu blackshade window)))))))) (dg.filecopy (lambda (f1 f2 over-flag) (* |edited:| " 6-Mar-86 15:06") (cond ((dg.file-exists f2) (cond ((or over-flag (dg.newer-file f1 f2)) (delfile f2) (copyfile f1 f2)) (t nil))) (t (copyfile f1 f2) t)))) (dg.find-directory-subtree (lambda (path window) (* |edited:| "31-Dec-00 22:10") (prog (directory-subtree) (setq path (nth path (length (windowprop window 'dg.path-to-root)))) (setq directory-subtree (list (windowprop window 'dg.tree))) (|for| x |in| path |do| (setq directory-subtree (fassoc x directory-subtree))) (return directory-subtree)))) (dg.find-menu-item (lambda (item item-list) (* |edited:| "26-Sep-85 14:19") (cond ((null item-list) nil) ((atom item-list) nil) ((fmemb item item-list) item) ((and (cdddr (car item-list)) (eq (car (cadddr (car item-list))) 'subitems) (dg.find-menu-item item (cdr (cadddr (car item-list))))) (car item-list)) (t (dg.find-menu-item item (cdr item-list)))))) (dg.find-parent-dierctory (lambda (path window) (* |edited:| "30-Mar-85 16:29") (prog (father-directory current-directory) (setq father-directory (windowprop window 'dg.tree)) (setq path (cdr (dg.residual-path window path))) (|while| (and (setq current-directory (fassoc (car path) father-directory)) (cdr path)) |do| (setq father-directory current-directory) (setq path (cdr path))) (|if| (not (listp current-directory)) |then| (return (list nil father-directory)) |else| (return (list father-directory current-directory)))))) (dg.flashallwindows (lambda (window) (* |edited:| " 3-Apr-85 16:21") (|for| w |in| (cons window (attachedwindows window)) |do| (flashwindow w)))) (dg.get-fb-pattern (lambda (w) (* |edited:| " 7-May-86 12:50") (fetchfield '(filebrowser 14 pointer) (windowprop (mainwindow w) 'filebrowser)))) (dg.get-file-list (lambda (message window source-path source-window) (* |edited:| "16-May-86 16:16") (prog (menu-window) (invertw window) (setq menu-window (dg.attach-directory-files-menu source-path source-window window)) (invertw window) (|if| menu-window |then| (windowprop menu-window 'dg.detach t) (clearw (dg.promptwindow window)) (|printout| (dg.promptwindow window) "Select files from menu. When done select STOP." t message) (await.event (windowprop window 'dg.file-selection-ended-event) 1000000)) (return menu-window)))) (dg.get-initial-region (lambda (graph) (* \; "Edited 19-Aug-87 08:55 by smL") (declare (globalvars dg.max-width dg.max-height dg.min-width dg.min-height)) (* |;;| "Edited by smL to use WIDTHIFWINDOW and HEIGHTIFWINDOW") (let ((g-region (graphregion graph))) (getmousestate) (getregion (min dg.max-width (widthifwindow (max (|fetch| width |of| g-region) dg.min-width))) (min dg.max-height (heightifwindow (max (|fetch| height |of| g-region) dg.min-height) t)))))) (dg.kill-process (lambda (window) (* |edited:| "12-May-86 13:03") (cond ((windowprop window 'dg.process) (del.process (windowprop window 'dg.process)) (dg.flashallwindows window) (clearw (dg.promptwindow window)) (|printout| (dg.promptwindow window) "User interupt. Directory Grapher process aborted."))) (|for| w |in| (attachedwindows window) |when| (windowprop w 'dg.detach) |do| (detachwindow w) (closew w)) (windowprop (dg.promptwindow window) 'title nil) (redisplayw window) (eval (windowprop window 'dg.unshade-if-shaded)) (windowprop window 'dg.process nil))) (dg.move-dir-command (lambda (window) (* |edited:| " 2-Apr-85 18:02") (dg.movecopy-dir-command window t))) (dg.move-file-command (lambda (window) (* |edited:| " 2-Apr-85 18:05") (dg.movecopy-command window t))) (dg.movecopy-command (lambda (window move) (* |edited:| "20-May-86 23:22") (declare (globalvars dg.copy-over highlightshade)) (prog (target-path source-path selected-files target-prefix source-prefix menu-window source-window source-path-window) (setq source-path-window (dg.wait-for-dir-selection window "Select source directory " t)) (setq source-window (cadr source-path-window)) (setq source-path (car source-path-window)) (cond (source-path (setq source-prefix (dg.create-prefix-from-path source-path)) (setq target-path (car (dg.wait-for-dir-selection window "Select target directory " t))) (|if| target-path |then| (setq target-prefix (dg.create-prefix-from-path target-path)) (setq menu-window (dg.get-file-list (concat " The selected files will be " (|if| move |then| " MOVED " |else| " COPIED ") " from " source-prefix " to " target-prefix " .") window source-path source-window)) (setq selected-files (windowprop menu-window 'dg.selected-files)) (|if| selected-files |then| (invertw window) (|for| file |in| selected-files |do| (|if| (dg.filecopy (pack* source-prefix file) (pack* target-prefix file) dg.copy-over) |then| (|printout| (dg.promptwindow window) t file " : " source-prefix " --> " target-prefix) |else| (|printout| (dg.promptwindow window) t file " already exists and was not copied. " )) (|if| move |then| (delfile (pack* source-prefix file))) (shadeitem file (car (windowprop menu-window 'menu)) highlightshade menu-window) (block)) (invertw window)) (detachwindow menu-window) (closew menu-window))))))) (dg.movecopy-dir-command (lambda (window move) (* |edited:| "13-May-86 14:13") (declare (globalvars dg.copy-over)) (prog (target-path source-path selected-files target-prefix source-prefix source-window-path menu-window source-father-son target-father-son target-path-window source-window target-window file-name new-name new-prefix) (setq source-window-path (dg.wait-for-dir-selection window "Select the directory that you want to transfer." t)) (setq source-path (car source-window-path)) (setq source-window (cadr source-window-path)) (cond (source-path (invertw window) (setq source-prefix (dg.create-prefix-from-path source-path)) (setq selected-files (directory source-prefix)) (invertw window) (setq target-path-window (dg.wait-for-dir-selection window (concat "Select new parent for directory " (car (last source-path ))) t)) (setq target-path (car target-path-window)) (|if| (and move (greaterp (length target-path) (length source-path)) (|for| a1 |in| source-path |as| a2 |in| target-path |always| (equal a1 a2))) |then| (dg.flashallwindows window) (|printout| (dg.promptwindow window) t "Can not move a directory to its descendants") (return nil)) (setq target-window (cadr target-path-window)) (cond (target-path (invertw window) (setq target-prefix (dg.create-prefix-from-path target-path)) (|for| file |in| selected-files |do| (|if| (dg.filecopy file (setq new-name (pack* (setq new-prefix (dg.create-prefix-from-path (append target-path (nth ( dg.create-path-from-file-name file) (length source-path ))))) (setq file-name (dg.pack-name-ver-ext file)))) dg.copy-over) |then| (|printout| (dg.promptwindow window) t file-name " : " (packfilename 'host (filenamefield file 'host) 'directory (filenamefield file 'directory)) " --> " new-prefix) |else| (|printout| (dg.promptwindow window) t new-name " already exists and was not copied. ")) (|if| move |then| (delfile file)) (block)) (setq source-father-son (dg.find-parent-dierctory source-path source-window)) (setq target-father-son (dg.find-parent-dierctory target-path target-window)) (rplacd (cadr target-father-son) (cons (copy (cadr source-father-son)) (cdr (cadr target-father-son)))) (|if| move |then| (rplacd (car source-father-son) (remove (cadr source-father-son) (cdar source-father-son)))) (dg.display-directory-tree (dg.create-graph-from-tree (windowprop source-window 'dg.tree)) source-window) (|if| (neq target-window source-window) |then| (dg.display-directory-tree (dg.create-graph-from-tree (windowprop target-window 'dg.tree)) target-window))))))))) (dg.pack-name-ver-ext (lambda (f) (* |edited:| " 3-Apr-85 11:31") (packfilename 'name (filenamefield f 'name) 'version (filenamefield f 'version) 'extension (filenamefield f 'extension)))) (dg.promptwindow (lambda (window) (* |edited:| "29-Mar-85 16:07") (car (windowprop window 'promptwindow)))) (dg.redisplayfn (lambda (window) (* |edited:| "26-Sep-85 15:05") (dg.shade-current-directory window))) (dg.residual-path (lambda (window path) (* |edited:| "29-Mar-85 12:37") (nth path (length (windowprop window 'dg.path-to-root))))) (dg.restore-command (lambda (window backup-dir) (* |edited:| "12-May-86 14:57") (declare (globalvars dg.files-backup-names dg.directory-subtree dg.copy-over)) (prog (target-path target-directory files-to-backup n over-write-flag floppy-files dsk-files directory-info-file-name f-name new-name over-flag-asked unfound-files info-name backup-host files-backup-names target-path-and-window target-window) (setq target-path-and-window (dg.wait-for-dir-selection window "Select directory that you want to restore" t)) (setq target-path (car target-path-and-window)) (setq target-window (cadr target-path-and-window)) (setq target-directory (dg.find-directory-subtree target-path target-window)) (setq backup-host (filenamefield backup-dir 'host)) (|if| (eq backup-host 'floppy) |then| (|printout| (dg.promptwindow window) t "Insert Floppy") (floppy.wait.for.floppy)) (|if| (null (filenamefield backup-dir 'directory)) |then| (setq backup-dir (pack* backup-dir '<))) (invertw window) (setq info-name (pack* backup-dir (car target-directory) '>backupinfo)) (|if| (null (directory info-name)) |then| (clearw (dg.promptwindow window)) (invertw window) (dg.flashallwindows window) (|printout| (dg.promptwindow window) t "Couldn't find the file " info-name " . Resore aborted. ") |else| (prog nil (load info-name 'sysload) (rplacd target-directory (append (cdr target-directory) (|for| sub |in| (cdr dg.directory-subtree) |when| (not (fassoc (car sub) (cdr target-directory) )) |collect| sub))) (dg.display-directory-tree (dg.create-graph-from-tree (windowprop target-window 'dg.tree)) target-window) (|if| (neq target-window window) |then| (invertw window)) (setq files-backup-names dg.files-backup-names) newroundofcopy (invertw window) (|for| f |in| files-backup-names |bind| f-with-< |do| (cond ((dg.file-exists (setq f-name (pack* backup-dir f))) (setq new-name (pack* (dg.create-prefix-from-path (append target-path (cdr (dg.create-path-from-file-name (setq f-with-< (pack* '< f)))))) (dg.pack-name-ver-ext f-with-<))) (cond ((dg.filecopy f-name new-name dg.copy-over) (|printout| (dg.promptwindow window) t new-name " Restored.")) (t (|printout| (dg.promptwindow window) t new-name " exists and wasn't restored. ")))) (t (cond ((not (fmemb f unfound-files)) (setq unfound-files (cons f unfound-files))))))) (invertw window) (cond (unfound-files (ringbells) (dg.flashallwindows window) (clearw (dg.promptwindow window)) (|if| (eq backup-host 'floppy) |then| (|printout| (dg.promptwindow window) (length unfound-files) " Files were not found on this floppy !! please insert another one. " ) (setq files-backup-names unfound-files) (setq unfound-files nil) (floppy.wait.for.floppy t) (go newroundofcopy) |else| (|printout| (dg.promptwindow window) (length unfound-files) " Files wre not found on the backup directory and were not restored" ))))))))) (dg.restore-from-default-command (lambda (window) (* |edited:| "13-May-86 13:57") (declare (globalvars dg.default-backup-directory)) (|if| (null dg.default-backup-directory) |then| (dg.flashallwindows window) (|printout| (dg.promptwindow window) t "NULL default directory.Backup aborted") |else| (dg.restore-command window dg.default-backup-directory)))) (dg.restore-from-selected-command (lambda (window) (* |sm| " 8-Jun-85 13:05") (prog (backup-directory) (setq backup-directory (dg.create-prefix-from-path (car (dg.wait-for-dir-selection window "Select the directory that contains the backup." t)))) (dg.restore-command window backup-directory)))) (dg.setify (lambda (l) (* |edited:| "13-May-86 12:10") (prog (new-set) (|for| one-element |in| l |when| (not (member one-element new-set)) |do| (setq new-set (cons one-element new-set)) (block)) (return new-set)))) (dg.shade-current-directory (lambda (window) (* |edited:| "22-May-85 13:56") (prog (current-path) (setq current-path (nth (dg.create-path-from-file-name (dg.current-connected-directory)) (length (windowprop window 'dg.path-to-root)))) (|for| node |in| (|fetch| graphnodes |of| (windowprop window 'graph)) |do| (cond ((equal current-path (|fetch| nodeid |of| node)) (reset/node/border node 2 window)) (t (cond ((greaterp (|fetch| nodeborder |of| node) 0) (reset/node/border node -2 window))))))))) (dg.trim (lambda (w n) (* |edited:| " 5-Apr-85 11:08") (cond ((greaterp (nchars w) n) (subatom w 1 n)) (t w)))) (dg.unadvise (lambda nil (* |edited:| "31-Mar-85 23:26") (unadvise (\\generatenextfile in fb.updatebrowseritems)))) (dg.unadvise-generate-file (lambda nil (* |edited:| "31-Mar-85 23:26") (unadvise (\\generatenextfile in fb.updatebrowseritems)))) (dg.unpack-directory-name (lambda (name) (* |edited:| " 3-Apr-85 17:01") (cond ((null name) nil) (t (cons (pack (prog (packed-name) loop (cond ((or (null name) (eq (car name) '>)) (return packed-name)) (t (setq packed-name (nconc1 packed-name (car name))) (setq name (cdr name)) (go loop))))) (dg.unpack-directory-name (cdr name))))))) (dg.update-command (lambda (window) (* |edited:| " 3-Apr-85 13:38") (invertw window) (dg.update-directory-tree window))) (dg.update-directory-tree (lambda (window) (* |edited:| " 3-Apr-85 22:20") (prog (tree) (setq tree (dg.create-directory-tree (windowprop window 'dg.path-to-root))) (windowprop window 'dg.tree tree) (dg.display-directory-tree (dg.create-graph-from-tree tree) window)))) (dg.update-directroy-tree (lambda (window) (* |edited:| "30-Mar-85 15:21") (prog (tree) (setq tree (dg.create-directory-tree (windowprop window \'dg.path-to-root))) (dg.display-directory-tree tree window)))) (dg.wait-for-dir-selection (lambda (window message allow-other-windows) (* |edited:| "13-May-86 14:31") (declare (globalvars dg.last-directory-selected dg.directory-was-selected-event dg.window-of-last-directory)) (prog (waits) (setq dg.last-directory-selected nil) (setq waits 0) (|printout| (dg.promptwindow window) t message) wait-again (setq waits (add1 waits)) (await.event dg.directory-was-selected-event 1000) (cond ((or (null dg.last-directory-selected) (and (not allow-other-windows) (neq dg.window-of-last-directory window))) (cond ((greaterp waits 50) (return nil)) ((zerop (imod waits 10)) (flashwindow (dg.promptwindow window)) (playtune (list (cons (itimes 100 (iquotient waits 10)) 10000) (cons (itimes 100 (add1 (iquotient waits 10))) 10000) (cons (itimes 100 (iquotient waits 10)) 10000))))) (go wait-again))) (return (list dg.last-directory-selected dg.window-of-last-directory))))) (dirgrapher (lambda ({dev} window-region path?) (* |edited:| "13-May-86 14:24") (declare (globalvars dg.default-dir waitingcursor promptwindow dg.min-width dg.min-height dg.promptwindowfont dg.menu-edge)) (prog (tree dg.window path old-cursor graph) (cond ((null {dev}) (setq {dev} dg.default-dir))) (setq old-cursor (cursor waitingcursor)) (printout promptwindow t "DirGrapher : Computing directory structure ") (|if| (listp {dev}) |then| (setq tree {dev}) (setq path (or path? (list (car tree)))) |else| (setq path (dg.create-path-from-file-name {dev})) (setq tree (dg.create-directory-tree (copy path)))) (setq graph (dg.create-graph-from-tree tree)) (printout promptwindow t "DirGrapher : Done.") (cursor old-cursor) (|if| window-region |then| (setq dg.window (createw window-region {dev})) |else| (setq dg.window (createw (dg.get-initial-region graph) {dev})) (windowprop dg.window 'minsize (cons dg.min-width dg.min-height))) (windowprop dg.window 'dg.path-to-root path) (dg.display-directory-tree graph dg.window) (windowprop dg.window 'dg.tree tree) (windowaddprop dg.window 'repaintfn 'dg.redisplayfn) (windowprop dg.window 'iconfn 'dg.createiconw) (windowprop dg.window 'expandfn '(dg.shade-current-directory redisplaygraph)) (windowprop dg.window 'dg.icontitle (dg.create-icon-title path)) (windowprop dg.window 'dg.process nil) (windowprop dg.window 'dg.file-selection-ended-event (create.event "DGEVENT")) (windowprop dg.window 'dg.lock (create.monitorlock "DG.LOCK")) (getpromptwindow dg.window 3 dg.promptwindowfont) (attachmenu (dg.create-menu dg.window) dg.window dg.menu-edge 'justify) (attachmenu (dg.create-quit-menu dg.window) dg.window 'bottom 'justify) (return dg.window)))) ) (rpaqq dg.icon #*(75 75)OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@N@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@@@@@@@N@NGOOOOOOOOOOOOOOOLN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@D@@@@@@@DN@ND@@@@@@@D@@@@@@@DN@ND@@@@@@@D@@@@@@@DN@ND@@@COOOOOOOH@@@DN@ND@@@B@@@@@@@H@@@DN@ND@@@B@@@@@@@H@@@DN@ND@@@B@@@@@@@H@@@DN@ND@GOOOO@@AOOOOH@DN@ND@D@@@A@@A@@@@H@DN@ND@D@@@A@@A@@@@H@DN@NDGOL@AOOAOO@@OOHDN@NDD@D@A@AA@A@@H@HDN@NDD@D@A@AA@A@@H@HDN@NDD@D@A@AA@A@@H@HDN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@ND@@@@@@@@@@@@@@@DN@NGOOOOOOOOOOOOOOOLN@N@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@@@@@@@N@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@ ) (rpaqq dg.mask #*(75 75)OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@ ) (rpaqq dg.fill-window-texture #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) (rpaqq dg.whitebm #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) (dg.advise-generate-file) (setq dg.background-directories (union dg.background-directories (union directories (cons '{floppy} (for d in (volumes) when (lispdirectoryp d) collect (pack* '{dsk}< d '>)))))) (dg.add-item-to-background-menu '|DirGrapher| '(dirgrapher) "Will initiate dirgrapher process on the current directory" (cons 'subitems (cons '("DG Windows to top" (|for| w |in| (openwindows) |when| (or (windowprop w 'dg.path-to-root) (and (windowprop w 'iconfor) (windowprop (windowprop w 'iconfor) 'dg.path-to-root))) |do| (totopw w))) (for d in dg.background-directories collect (list d (list 'dirgrapher (kwote d)) (concat "WILL APPLY DIRGRAPHER ON " d)))))) (* |;;;| "(declare\\: dontcopy (prop makefile-environment dirgrapher))") (putprops dirgrapher copyright ("Shaul Markovitch" 1985 1986 1900 1987 1988)) (declare\: dontcopy (filemap (nil (8084 97635 (dg.add-item-to-background-menu 8094 . 8552) (dg.advise-generate-file 8554 . 10241) (dg.apply-dirgrapher-command 10243 . 10764) (dg.apply-fb-on-dir-and-subdirs-command 10766 . 10939) (dg.apply-filebrowser-command 10941 . 11662) (dg.ask-for-backup-type 11664 . 12619) ( dg.attach-directory-files-menu 12621 . 16321) (dg.backup-command 16323 . 21827) (dg.file-exists 21829 . 21955) (dg.file-info-command 21957 . 25478) (dg.file-info-selection-fn 25480 . 26625) ( dg.files-hardcopy-command 26627 . 27988) (dg.load-files-command 27990 . 29633) (dg.newer-file 29635 . 29834) (dg.backup-on-default-command 29836 . 30287) (dg.backup-on-selected-command 30289 . 30776) ( dg.connect-dir-command 30778 . 31526) (dg.copy-directory-command 31528 . 31686) (dg.copy-file-command 31688 . 31837) (dg.copybuttoneventfn 31839 . 33270) (dg.create-backup-free-menu 33272 . 33892) ( dg.create-backup-name 33894 . 35331) (dg.create-directory-chain 35333 . 35645) ( dg.create-directory-spec 35647 . 36192) (dg.create-directory-tree 36194 . 36791) ( dg.create-graph-from-tree 36793 . 37277) (dg.create-icon-title 37279 . 37805) (dg.create-menu 37807 . 47220) (dg.create-path-from-file-name 47222 . 47939) (dg.create-prefix-from-path 47941 . 48228) ( dg.create-quit-menu 48230 . 48882) (dg.create-subdir-command 48884 . 50454) (dg.create-tree-from-lists 50456 . 51392) (dg.create-tree-nodes 51394 . 53153) (dg.createiconw 53155 . 53643) ( dg.current-connected-directory 53645 . 54038) (dg.delete-directory-command 54040 . 56106) ( dg.delete-from-tree 56108 . 56645) (dg.delete-old-versions-command 56647 . 58354) ( dg.delete-selected-files-command 58356 . 60575) (dg.directory-minus-prefix 60577 . 60833) ( dg.directory-selection-function 60835 . 61727) (dg.display-directory-tree 61729 . 62143) (dg.docommand 62145 . 62742) (dg.docommand-with-monitor 62744 . 64873) (dg.docommand-without-monitor 64875 . 66360) (dg.exclusive-directory 66362 . 66900) (dg.exclusive-new-versions 66902 . 67507) ( dg.exclusive-old-versions 67509 . 68133) (dg.fbiconfn 68135 . 68946) (dg.file-selection-fn 68948 . 69758) (dg.filecopy 69760 . 70085) (dg.find-directory-subtree 70087 . 70515) (dg.find-menu-item 70517 . 71022) (dg.find-parent-dierctory 71024 . 71780) (dg.flashallwindows 71782 . 71975) ( dg.get-fb-pattern 71977 . 72223) (dg.get-file-list 72225 . 72948) (dg.get-initial-region 72950 . 73678 ) (dg.kill-process 73680 . 74460) (dg.move-dir-command 74462 . 74616) (dg.move-file-command 74618 . 74769) (dg.movecopy-command 74771 . 78216) (dg.movecopy-dir-command 78218 . 83535) ( dg.pack-name-ver-ext 83537 . 83822) (dg.promptwindow 83824 . 83979) (dg.redisplayfn 83981 . 84131) ( dg.residual-path 84133 . 84306) (dg.restore-command 84308 . 89859) (dg.restore-from-default-command 89861 . 90316) (dg.restore-from-selected-command 90318 . 90809) (dg.setify 90811 . 91129) ( dg.shade-current-directory 91131 . 91896) (dg.trim 91898 . 92097) (dg.unadvise 92099 . 92267) ( dg.unadvise-generate-file 92269 . 92451) (dg.unpack-directory-name 92453 . 93166) (dg.update-command 93168 . 93340) (dg.update-directory-tree 93342 . 93705) (dg.update-directroy-tree 93707 . 93982) ( dg.wait-for-dir-selection 93984 . 95380) (dirgrapher 95382 . 97633))))) stop \ No newline at end of file diff --git a/lispusers/DLIONFNKEYS b/lispusers/DLIONFNKEYS new file mode 100644 index 00000000..704e92cb --- /dev/null +++ b/lispusers/DLIONFNKEYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Oct-87 18:18:54" {ERINYES}LISPCORE>DLIONFNKEYS.;1 6304 changes to%: (FNS BUILDFNKEYS) previous date%: "19-Nov-85 12:20:57" {ERINYES}LYRIC>LISPUSERS>DLIONFNKEYS.;1) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DLIONFNKEYSCOMS) (RPAQQ DLIONFNKEYSCOMS [(FILES KEYOBJ) (GLOBALVARS DLION.FN.KEYS DLION.FN.KEYLABELS KEYOBJ.TEMPLATE) [VARS (DLION.FN.KEYS '(CENTER BOLD ITALICS UNDERLINE SUPERSCRIPT SUBSCRIPT SMALLER DEFAULTS)) (DLION.FN.KEYLABELS '(CENTER BOLD ITALICS (UNDER- LINE) (SUPER- SCRIPT) (SUB- SCRIPT) SMALLER DEFAULTS] (BITMAPS FNKEYICON) (FNS BUILDFNKEYS FNKEY.MENUFN) (INITVARS (FNKEY.MENU (create MENU ITEMS _ '((Close 'CLOSEW "Closes a window" ) (Bury 'BURYW "Puts a window on the bottom." ) (Move 'MOVEW "Moves a window by a corner." ) (Shrink 'SHRINKW "Replaces this window with its icon" ]) (FILESLOAD KEYOBJ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DLION.FN.KEYS DLION.FN.KEYLABELS KEYOBJ.TEMPLATE) ) (RPAQQ DLION.FN.KEYS (CENTER BOLD ITALICS UNDERLINE SUPERSCRIPT SUBSCRIPT SMALLER DEFAULTS)) (RPAQQ DLION.FN.KEYLABELS (CENTER BOLD ITALICS (UNDER- LINE) (SUPER- SCRIPT) (SUB- SCRIPT) SMALLER DEFAULTS)) (RPAQQ FNKEYICON #*(80 50)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@@AOOH@@@@@@@@@@@@@@@@AONL@@@@@@@@@@@@@@@@BGOFCOOOOOOOOOOOOOOLDGNKF@@@@@@@@@@@@@@FHGMEH@@@@@@@@@@@@@@A@CNK@@@@@@@@@@@@@@@@HCMG@@@@@@@@@@@@@@@@LCNJ@@@@@@@@@@@@@@@@DCMF@@@@@@@@@@@@@@@@DCNJ@@@@@@@@@@@@@@@@DCMF@@@@@@@@@@@@@@@@DCNJ@@@@@@@@@@D@@@@@DCMF@CO@@@@@@DD@@@@@DCNJ@B@@@@@@@D@@@@@@DCMF@B@BABNALODGHKH@DCNJ@CNBACABBDDHDLD@DCMF@B@BABAB@DDHDHD@DCNJ@B@BABAB@DDHDHD@DCMF@B@BCBABBDDHDHD@DCNJ@B@AMBAALCDGHHD@DCMF@@@@@@@@@@@@@@@@DCNJ@@@@@@@@@@@@@@@@DCMF@@@@@@@@@@@@@@@@DCNJ@@@@@@@@@@@@@@@@DCMF@@@@BA@@@@@@@@@@DCNJ@@@@BB@@@@@@@@@@DCMF@@@@BD@NBBCH@@@@DCNJ@@@@BHAABBDD@@@@DCMF@@@@CDAOADCH@@@@DCNJ@@@@BBA@AD@D@@@@DCMF@@@@BAAA@HDD@@@@DCNJ@@@@B@HN@HCH@@@@DCMF@@@@@@@@@H@@@@@@DCNJ@@@@@@@@C@@@@@@@DCMF@@@@@@@@@@@@@@@@DCNK@@@@@@@@@@@@@@@@LCME@@@@@@@@@@@@@@@@HCNKH@@@@@@@@@@@@@@A@COBN@@@@@@@@@@@@@@GHGNDKOOOOOOOOOOOOOONLGOIAEEEEEEEEEEEEEEEFGOBBJJJJJJJJJJJJJJJKOOLEEEEEEEEEEEEEEEEEOONBJJJJJJJJJJJJJJJOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO ) (DEFINEQ (BUILDFNKEYS [LAMBDA NIL (* ; "Edited 29-Oct-87 18:14 by jds") (PROG ((TXT (OPENTEXTSTREAM NIL NIL NIL NIL)) (WIDTH (FIX (TIMES (BITMAPWIDTH KEYOBJ.TEMPLATE) 8.3))) W) (TEDIT.INSERT TXT (CHARACTER (CHARCODE EOL)) 1) (for KEY in DLION.FN.KEYS as LABEL in DLION.FN.KEYLABELS do (TEDIT.INSERT.OBJECT (KEYOBJ.CREATE KEY LABEL T) TXT)) (* ;  "this will create abortable key objects (if you slide out of the region, no transitions are sent)") (TEDIT.SETSEL TXT 2 0 'LEFT) (TEDIT.PARALOOKS TXT '(QUAD CENTERED)) (* ;  "(TEDIT.NORMALIZECARET TXT (TEDIT.SETSEL TXT 0 0 (QUOTE LEFT)))") (SETQ W (CREATEW (CREATEREGION (IQUOTIENT (IDIFFERENCE (BITMAPWIDTH (SCREENBITMAP)) WIDTH) 2) 5 WIDTH (IPLUS (FONTPROP MENUFONT 'HEIGHT) (BITMAPHEIGHT KEYOBJ.TEMPLATE) 10)) "Dandelion function keys" 2)) (SCROLLW W 0 -5) (* ;  "used to have NOTITLE T in the props") (* ;  "TEDIT TXT W NIL (QUOTE (LEAVETTY T PROMPTWINDOW DON'T))") (OPENTEXTSTREAM TXT W NIL NIL '(READONLY T)) (WINDOWPROP W 'WINDOWENTRYFN 'NIL) (* ;  "(WINDOWPROP W (QUOTE TITLE) (QUOTE NIL))") (WINDOWPROP W 'ICON FNKEYICON) (WINDOWPROP W 'RIGHTBUTTONFN 'FNKEY.MENUFN) (SETQ DLIONFNKEYS W]) (FNKEY.MENUFN [LAMBDA (KEYWINDOW) (* gbn "28-Jan-85 01:17") (PROG ((ITEM (MENU FNKEY.MENU))) (COND (ITEM (APPLY* ITEM KEYWINDOW]) ) (RPAQ? FNKEY.MENU [create MENU ITEMS _ '((Close 'CLOSEW "Closes a window") (Bury 'BURYW "Puts a window on the bottom.") (Move 'MOVEW "Moves a window by a corner.") (Shrink 'SHRINKW "Replaces this window with its icon"]) (PUTPROPS DLIONFNKEYS COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3544 5868 (BUILDFNKEYS 3554 . 5655) (FNKEY.MENUFN 5657 . 5866))))) STOP \ No newline at end of file diff --git a/lispusers/DOC-OBJECTS b/lispusers/DOC-OBJECTS new file mode 100644 index 00000000..968f3a8d --- /dev/null +++ b/lispusers/DOC-OBJECTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED " 9-May-2018 11:09:43"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>DOC-OBJECTS.;7 50515 changes to%: (FNS DOCOBJ-INCLUDE-EDIT DOCOBJ-INCLUDE-BEFOREHARDCOPYFN) previous date%: " 9-May-2018 10:35:47" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>DOC-OBJECTS.;4) (* ; " Copyright (c) 1986, 1987, 1993, 2018 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT DOC-OBJECTSCOMS) (RPAQQ DOC-OBJECTSCOMS [ (* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc.") (FILES (SYSLOAD) TEDIT IMAGEOBJ) (VARS (DocObjectsMenu NIL) (DocObjectsConfirmEditMenu NIL)) [INITVARS (DocObjectsMenuCommands NIL) (DocObjectsMenuFont (FONTCREATE '(MODERN 12 BOLD] (COMS (* ;; "The hook into GET.OBJ.FROM.USER") (FNS DOCOBJ-ACQUIRE-OBJECT DOCOBJ-INIT DOCOBJ-TEDIT-MENU-ENTRY DOCOBJ-GET-LOOKS DOCOBJ-REGISTER-OBJECT DOCOBJ-STRING-IMAGEBOX DOCOBJ-WAIT-MOUSE DOCOBJ-INVOKE-IMAGEOBJFN DOCOBJ-BEFOREHARDCOPYFN DOCOBJ-AFTERHARDCOPYFN)) [COMS (* ;; "Eval'd Form") (FNS DOCOBJ-ACQUIRE-EVALED-OBJECT) (ADDVARS (DocObjectsMenuCommands ("Eval'd Form" (DOCOBJ-ACQUIRE-EVALED-OBJECT) "Insert the value of a form to be typed in"] [COMS (* ;; "Screen Snap") (FNS DOCOBJ-ACQUIRE-SNAPPED-OBJECT) (ADDVARS (DocObjectsMenuCommands ("Screen Snap" (DOCOBJ-ACQUIRE-SNAPPED-OBJECT) "Insert a snap from the screen"] [COMS (* ;; "Time Stamp") (DECLARE%: DONTCOPY (RECORDS DOCOBJ-TIMESTAMP)) (FILES (SYSLOAD) DATEFORMAT-EDITOR) (FNS DOCOBJ-EDIT-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS DOCOBJ-TIMESTAMP-BUTTONEVENTINFN DOCOBJ-TIMESTAMP-COPYFN DOCOBJ-TIMESTAMP-DISPLAYFN DOCOBJ-TIMESTAMP-GETFN DOCOBJ-TIMESTAMP-IMAGEBOXFN DOCOBJ-TIMESTAMP-PREPRINTFN DOCOBJ-TIMESTAMP-PUTFN DOCOBJ-TIMESTAMP-TO-STRING) (INITVARS (DocObjectsTimeStampFormat) (DOCOBJ-TIMESTAMP-IMAGEFNS (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("Time Stamp" (DOCOBJ-MAKE-TIMESTAMP) "Date & time this document is PUT"] [COMS (* ;; "File Stamp") (FNS DOCOBJ-MAKE-FILESTAMP DOCOBJ-MAKE-FILESTAMP-IMAGEFNS DOCOBJ-FILESTAMP-COPYFN DOCOBJ-FILESTAMP-DISPLAYFN DOCOBJ-FILESTAMP-GETFN DOCOBJ-FILESTAMP-IMAGEBOXFN DOCOBJ-FILESTAMP-GET-FULLNAME DOCOBJ-FILESTAMP-NEW-FULLNAME DOCOBJ-FILESTAMP-PREPRINTFN DOCOBJ-FILESTAMP-PUTFN) (INITVARS (DOCOBJ-FILESTAMP-IMAGEFNS (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("File Stamp" (DOCOBJ-MAKE-FILESTAMP) "Name of file to which this document was last PUT." ] (COMS (* ;; "Horizontal Rule") (FILES (SYSLOAD) HRULE READNUMBER) (FNS DOCOBJ-MAKE-HRULE DOCOBJ-EDIT-HRULE DOCOBJ-HRULE-INIT DOCOBJ-HRULE-GET-WIDTH DOCOBJ-HRULE-BUTTONEVENTINFN) (VARS (DOCOBJ-HRULE-RULE-PAD) (DOCOBJ-HRULE-BLANK-PAD)) (ADDVARS (DocObjectsMenuCommands ("Horizontal Rule" (DOCOBJ-MAKE-HRULE) "One or more horizontal rules"))) (P (DOCOBJ-HRULE-INIT))) [COMS (* ;; "INCLUDE") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS INCLOBJ)) (FNS DOCOBJ-MAKE-INCLUDE DOCOBJ-MAKE-INCLUDE-IMAGEFNS DOCOBJ-INCLUDE-CREATE-OBJ DOCOBJ-INCLUDE-EDIT DOCOBJ-INCLUDE-EDIT-WINDOWP DOCOBJ-INCLUDE-RESET-OBJ) (FNS DOCOBJ-INCLUDE-AFTERHARDCOPYFN DOCOBJ-INCLUDE-BEFOREHARDCOPYFN DOCOBJ-INCLUDE-CLEANUPFN DOCOBJ-INCLUDE-BUTTONEVENTINFN DOCOBJ-INCLUDE-COPYFN DOCOBJ-INCLUDE-DISPLAYFN DOCOBJ-INCLUDE-GETFN DOCOBJ-INCLUDE-IMAGEBOXFN DOCOBJ-INCLUDE-PREPRINTFN DOCOBJ-INCLUDE-PUTFN) (INITVARS (DOCOBJ-INCLUDE-EDITMENU) (DOCOBJ-INCLUDE-IMAGEFNS (DOCOBJ-MAKE-INCLUDE-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("Include" (DOCOBJ-MAKE-INCLUDE) "Include another document right here when hardcopying" ] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DOCOBJ-INIT))) (DECLARE%: EVAL@LOAD DONTCOPY (COMS (PROP FILETYPE DOC-OBJECTS) (PROP MAKEFILE-ENVIRONMENT DOC-OBJECTS]) (* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc." ) (FILESLOAD (SYSLOAD) TEDIT IMAGEOBJ) (RPAQQ DocObjectsMenu NIL) (RPAQQ DocObjectsConfirmEditMenu NIL) (RPAQ? DocObjectsMenuCommands NIL) (RPAQ? DocObjectsMenuFont (FONTCREATE '(MODERN 12 BOLD))) (* ;; "The hook into GET.OBJ.FROM.USER") (DEFINEQ (DOCOBJ-ACQUIRE-OBJECT [LAMBDA NIL (* ; "Edited 15-Oct-87 16:27 by Koomen") (* ;;; "This function is invoked by TEdit's GET.OBJ.FROM.USER (cf. the Library file IMAGEOBJ) after (CHANGENAME (QUOTE GET.OBJ.FROM.USER) (QUOTE PROMPTFOREVALED) (QUOTE DOCOBJ-ACQUIRE-OBJECT))") (* ;;; "When adding more items to the DocObjectsMenuCommands, do (SETQ DocObjectsMenu)") (DECLARE (GLOBALVARS DocObjectsMenu DocObjectsMenuCommands DocObjectsMenuFont)) (if (NOT (type? MENU DocObjectsMenu)) then (SETQ DocObjectsMenu (create MENU TITLE _ "Select object type: " CENTERFLG _ T ITEMS _ DocObjectsMenuCommands MENUFONT _ DocObjectsMenuFont))) (MENU DocObjectsMenu]) (DOCOBJ-INIT [LAMBDA NIL (* ;  "Edited 8-Oct-87 21:32 by Koomen") (* ;;; "This function changes the behavior of standard TEdit such that ^O will invoke the DocObjects system; an entry to invoke the DocObjects system is also added to TEdit's middle button menu.") (DECLARE (GLOBALVARS TEDIT.DEFAULT.MENU)) (CHANGENAME 'GET.OBJ.FROM.USER 'PROMPTFOREVALED ' DOCOBJ-ACQUIRE-OBJECT) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Object (FUNCTION DOCOBJ-TEDIT-MENU-ENTRY) "Insert a Document Object"]) (DOCOBJ-TEDIT-MENU-ENTRY [LAMBDA (TEXTSTREAM) (* ;  "Edited 8-Oct-87 21:31 by Koomen") (* ;;; "This is the entry point into the DocObjects system from TEdit's middle button menu. GET.OBJ.FROM.USER used to call PROMPTFOREVALED but DocObjects changes this into a call to DOCOBJ-ACQUIRE-OBJECT.") (GET.OBJ.FROM.USER TEXTSTREAM (TEXTOBJ TEXTSTREAM]) (DOCOBJ-GET-LOOKS [LAMBDA (TEXTOBJ CH#ORCHARLOOKS) (* Koomen " 4-Feb-87 23:37") (* * Adapted from {ERIS}TEDITLOOKS.;30 dated  "15-Oct-85 16:51:10" to return looks itself, rather  than a proplist.)  (* jds "10-Jul-85 16:02") (* Return a PLIST of  character looks) (PROG ((TEXTOBJ (TEXTOBJ TEXTOBJ)) LOOKS FONT NLOOKS) [COND ((type? CHARLOOKS CH#ORCHARLOOKS) (* He handed us a  CHARLOOKS. Unparse it for  him.) (SETQ LOOKS CH#ORCHARLOOKS)) ((ZEROP (fetch TEXTLEN of TEXTOBJ)) (* There's no text in the document.  Use the extant caret looks.) (SETQ LOOKS (fetch CARETLOOKS of TEXTOBJ))) [(FIXP CH#ORCHARLOOKS) (* He gave us a CH# to geth the looks of.  Grab it.) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) CH#ORCHARLOOKS) (fetch PCTB of TEXTOBJ] [(type? SELECTION CH#ORCHARLOOKS) (* Get the looks of the  selected text) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) (fetch (SELECTION CH#) of CH#ORCHARLOOKS)) (fetch PCTB of TEXTOBJ] ((NULL CH#ORCHARLOOKS) (* Get the looks of the  selected text) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) (fetch (SELECTION CH#) of (fetch SEL of TEXTOBJ))) (fetch PCTB of TEXTOBJ] (RETURN LOOKS) (* * Now break the looks apart into a PROPLIST) (SETQ NLOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST LOOKS)) (RETURN NLOOKS]) (DOCOBJ-REGISTER-OBJECT [LAMBDA (OBJECT) (* ; "Edited 23-Oct-87 14:48 by Koomen") (* ;; "The following ensures that all DocObjects get a chance to do whatever they want to before and after hardcopying. Each DocObject can associate a BEFOREHARDCOPYFN and/or an AFTERHARDCOPYFN with the ImageObj representing the DocObject") (DECLARE (SPECVARS TEXTOBJ)) (if OBJECT then (TEXTPROP TEXTOBJ 'BEFOREHARDCOPYFN (FUNCTION DOCOBJ-BEFOREHARDCOPYFN)) (TEXTPROP TEXTOBJ 'AFTERHARDCOPYFN (FUNCTION DOCOBJ-AFTERHARDCOPYFN)) OBJECT]) (DOCOBJ-STRING-IMAGEBOX [LAMBDA (STRING IMAGESTREAM) (* Koomen " 9-Feb-87 17:22") (DECLARE (SPECVARS CHNO TEXTOBJ)) (PROG (LOOKS CLOFFSET FONT DEVICE HEIGHT DESCENT) (SETQ LOOKS (DOCOBJ-GET-LOOKS TEXTOBJ CHNO)) (SETQ CLOFFSET (fetch (CHARLOOKS CLOFFSET) of LOOKS)) (SETQ FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) (if (NEQ (FONTPROP FONT 'DEVICE) (SETQ DEVICE (IMAGESTREAMTYPE IMAGESTREAM))) then (SETQ FONT (FONTCOPY FONT 'DEVICE DEVICE))) (SETQ HEIGHT (FONTHEIGHT FONT)) (SETQ DESCENT (FONTPROP FONT 'DESCENT)) (RETURN (create IMAGEBOX XSIZE _ (STRINGWIDTH STRING FONT) YSIZE _ (IPLUS HEIGHT (IABS CLOFFSET)) YDESC _ (IDIFFERENCE DESCENT CLOFFSET) XKERN _ 0]) (DOCOBJ-WAIT-MOUSE [LAMBDA (STREAM) (* ;  "Edited 8-Oct-87 23:46 by Koomen") (while (NOT (MOUSESTATE UP)) bind (REGION _ (DSPCLIPPINGREGION NIL STREAM)) do (if (NOT (INSIDEP REGION (LASTMOUSEX STREAM) (LASTMOUSEY STREAM))) then (RETURN NIL)) finally (RETURN T]) (DOCOBJ-INVOKE-IMAGEOBJFN [LAMBDA (CH# PIECE PC# IMAGEOBJFNNAME) (* ; "Edited 15-Oct-87 23:35 by Koomen") (* ;; "If PIECE is an IMAGEOBJ, invoke the function associated with the ImageObj property IMAGEOBJFNNAME on the IMAGEOBJ and the character position where the IMAGEOBJ is located. ") (PROG (IMAGEOBJ IMAGEOBJFN) (if (NOT (type? PIECE PIECE)) then (RETURN)) (SETQ IMAGEOBJ (fetch POBJ of PIECE)) (if (NOT (IMAGEOBJP IMAGEOBJ)) then (RETURN)) (SETQ IMAGEOBJFN (IMAGEOBJPROP IMAGEOBJ IMAGEOBJFNNAME)) (if (AND IMAGEOBJFN (DEFINEDP IMAGEOBJFN)) then (APPLY* IMAGEOBJFN IMAGEOBJ CH# PIECE PC#]) (DOCOBJ-BEFOREHARDCOPYFN [LAMBDA (TEXTSTREAM TEXTOBJ) (* ;  "Edited 25-May-93 13:07 by sybalsky:mv:envos") (* ;; "Bug in TEDIT.FORMAT.HARDCOPY!!! This function is called with the arguments TEXTSTREAM and TEXTOBJ, but TEXTSTREAM is undefined!") (* ;; "*DOCOBJ-FORMS* is used to enable insertion and deletion of pieces. DocObjects can postpone insertion or deletion by added appropriate forms to *DOCOBJ-FORMS*. Can't do it while under TEDIT.MAPPIECES as the pointers get screwed up. ") (DECLARE (SPECVARS *DOCOBJ-FORMS*)) (LET ((TEXTSTREAM (TEXTSTREAM TEXTOBJ)) (*DOCOBJ-FORMS*)) (TEXTPROP TEXTSTREAM 'DOCOBJ-VIRGINP (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ;; "After hardcopy, TEXTSTREAM is reset if this flag is T") (do (SETQ *DOCOBJ-FORMS*) (TEDIT.MAPPIECES TEXTOBJ (FUNCTION DOCOBJ-INVOKE-IMAGEOBJFN) 'BEFOREHARDCOPYFN) [WITHOUT-UPDATES TEXTOBJ (FETCH (TEXTOBJ SCRATCHSEL) OF TEXTOBJ) (for FRM in *DOCOBJ-FORMS* do (APPLY (CAR FRM) (CDR FRM] repeatwhile *DOCOBJ-FORMS*]) (DOCOBJ-AFTERHARDCOPYFN [LAMBDA (TEXTSTREAM TEXTOBJ) (* ;  "Edited 25-May-93 13:08 by sybalsky:mv:envos") (* ;; "Bug in TEDIT.FORMAT.HARDCOPY!!! This function is called with the arguments TEXTSTREAM and TEXTOBJ, but TEXTSTREAM is undefined, and TEXTOBJ is NIL!") (DECLARE (SPECVARS *DOCOBJ-FORMS*)) (LET ((*DOCOBJ-FORMS*)) (do (SETQ *DOCOBJ-FORMS*) (TEDIT.MAPPIECES TEXTOBJ (FUNCTION DOCOBJ-INVOKE-IMAGEOBJFN) 'AFTERHARDCOPYFN) [WITHOUT-UPDATES TEXTOBJ (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) (for FRM in *DOCOBJ-FORMS* do (APPLY (CAR FRM) (CDR FRM] repeatwhile *DOCOBJ-FORMS*) (COND ((TEXTPROP TEXTSTREAM 'DOCOBJ-VIRGINP) (TEDIT.STREAMCHANGEDP TEXTSTREAM T]) ) (* ;; "Eval'd Form") (DEFINEQ (DOCOBJ-ACQUIRE-EVALED-OBJECT [LAMBDA NIL (* Koomen "30-Sep-86 02:08") (* * This is the original function called under  GET.OBJ.FROM.USER * *) (PROMPTFOREVALED "Form to eval: "]) ) (ADDTOVAR DocObjectsMenuCommands ("Eval'd Form" (DOCOBJ-ACQUIRE-EVALED-OBJECT) "Insert the value of a form to be typed in")) (* ;; "Screen Snap") (DEFINEQ (DOCOBJ-ACQUIRE-SNAPPED-OBJECT [LAMBDA NIL (* Koomen "26-Sep-86 16:55") (GETREGION]) ) (ADDTOVAR DocObjectsMenuCommands ("Screen Snap" (DOCOBJ-ACQUIRE-SNAPPED-OBJECT) "Insert a snap from the screen")) (* ;; "Time Stamp") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD DOCOBJ-TIMESTAMP (IDATE DATESTR FORMAT)) ) ) (FILESLOAD (SYSLOAD) DATEFORMAT-EDITOR) (DEFINEQ (DOCOBJ-EDIT-TIMESTAMP [LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:08") (PROG [(FORMAT (EDIT-DATEFORMAT (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP] (if FORMAT then (replace (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP with FORMAT) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL) (RETURN TIMESTAMP]) (DOCOBJ-MAKE-TIMESTAMP [LAMBDA NIL (* Koomen " 4-Feb-87 13:54") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS DocObjectsTimeStampFormat)) (IMAGEOBJCREATE (create DOCOBJ-TIMESTAMP IDATE _ (IDATE) FORMAT _ DocObjectsTimeStampFormat) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:53 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-TIMESTAMP-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-TIMESTAMP-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-TIMESTAMP-PUTFN)) (GETFN (FUNCTION DOCOBJ-TIMESTAMP-GETFN)) (COPYFN (FUNCTION DOCOBJ-TIMESTAMP-COPYFN)) (BUTTONEVENTINFN (FUNCTION DOCOBJ-TIMESTAMP-BUTTONEVENTINFN)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-TIMESTAMP-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-TIMESTAMP-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ;  "Edited 8-Oct-87 23:43 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-EDIT-TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then 'CHANGED]) (DOCOBJ-TIMESTAMP-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 00:30") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-TIMESTAMP-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* Koomen " 4-Feb-87 14:11") (PRINTOUT IMAGESTREAM (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-TIMESTAMP-GETFN [LAMBDA (FILESTREAM) (* Koomen "31-Jan-87 00:19") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (READ FILESTREAM) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-TIMESTAMP-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* Koomen " 9-Feb-87 17:13") (LET* ((TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) (TIMESTRING (DOCOBJ-TIMESTAMP-TO-STRING TIMESTAMP))) (DOCOBJ-STRING-IMAGEBOX TIMESTRING IMAGESTREAM]) (DOCOBJ-TIMESTAMP-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ;  "Edited 8-Oct-87 22:29 by Koomen") (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-TIMESTAMP-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* Koomen " 4-Feb-87 14:08") (PROG [(TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (replace (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP with (IDATE)) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL) (PRINT TIMESTAMP FILESTREAM]) (DOCOBJ-TIMESTAMP-TO-STRING [LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:12") (OR (STRINGP (fetch (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP)) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with (GDATE (fetch (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP) (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP]) ) (RPAQ? DocObjectsTimeStampFormat ) (RPAQ? DOCOBJ-TIMESTAMP-IMAGEFNS (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("Time Stamp" (DOCOBJ-MAKE-TIMESTAMP) "Date & time this document is PUT")) (* ;; "File Stamp") (DEFINEQ (DOCOBJ-MAKE-FILESTAMP [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:55 by Koomen") (DECLARE (SPECVARS TEXTOBJ) (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (DOCOBJ-FILESTAMP-NEW-FULLNAME TEXTOBJ) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:54 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-FILESTAMP-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-FILESTAMP-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-FILESTAMP-PUTFN)) (GETFN (FUNCTION DOCOBJ-FILESTAMP-GETFN)) (COPYFN (FUNCTION DOCOBJ-FILESTAMP-COPYFN)) (BUTTONEVENTINFN (FUNCTION NILL)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-FILESTAMP-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-FILESTAMP-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 04:10") (DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-FILESTAMP-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ;  "Edited 8-Oct-87 22:56 by Koomen") (PRINTOUT IMAGESTREAM (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ]) (DOCOBJ-FILESTAMP-GETFN [LAMBDA (FILESTREAM) (* ;  "Edited 8-Oct-87 22:58 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (LET ((FULLNAME (READ FILESTREAM))) (IMAGEOBJCREATE (AND FULLNAME (MKSTRING FULLNAME)) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-FILESTAMP-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ;  "Edited 8-Oct-87 22:59 by Koomen") (LET ((FULLNAME (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ))) (DOCOBJ-STRING-IMAGEBOX FULLNAME IMAGESTREAM]) (DOCOBJ-FILESTAMP-GET-FULLNAME [LAMBDA (IMAGEOBJ NODEFAULTFLG) (* ;  "Edited 8-Oct-87 22:59 by Koomen") (PROG [(FULLNAME (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (RETURN (OR (if FULLNAME then (if (LITATOM FULLNAME) then (MKSTRING FULLNAME) elseif (STRINGP FULLNAME) then (COPYALL FULLNAME))) (if (NOT NODEFAULTFLG) then "-- not yet filed --"]) (DOCOBJ-FILESTAMP-NEW-FULLNAME [LAMBDA (TEXTOBJ) (* ;  "Edited 8-Oct-87 22:52 by Koomen") (PROG ((FULLNAME (FULLNAME TEXTOBJ))) (RETURN (if FULLNAME then (if (LITATOM FULLNAME) then (MKSTRING FULLNAME) elseif (STRINGP FULLNAME) then (COPYALL FULLNAME]) (DOCOBJ-FILESTAMP-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ;  "Edited 8-Oct-87 22:56 by Koomen") (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ T]) (DOCOBJ-FILESTAMP-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* ;  "Edited 8-Oct-87 22:39 by Koomen") (PROG [(FULLNAME (MKSTRING (FULLNAME FILESTREAM] (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM FULLNAME) (PRINT FULLNAME FILESTREAM]) ) (RPAQ? DOCOBJ-FILESTAMP-IMAGEFNS (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("File Stamp" (DOCOBJ-MAKE-FILESTAMP) "Name of file to which this document was last PUT.")) (* ;; "Horizontal Rule") (FILESLOAD (SYSLOAD) HRULE READNUMBER) (DEFINEQ (DOCOBJ-MAKE-HRULE [LAMBDA NIL (* Koomen " 4-Feb-87 16:12") (HRULE.CREATE (bind WIDTH for I from 1 while (AND (SETQ WIDTH (DOCOBJ-HRULE-GET-WIDTH (ODDP I) (EQ I 1))) (GREATERP WIDTH 0)) collect WIDTH]) (DOCOBJ-EDIT-HRULE [LAMBDA (IMAGEOBJ) (* Koomen " 4-Feb-87 15:45") (PROG [NEWWIDTH (OLDWIDTH (MKLIST (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH] (SETQ NEWWIDTH (COPYALL OLDWIDTH)) (if (AND (NLSETQ (EDITE NEWWIDTH)) (NOT (EQUAL NEWWIDTH OLDWIDTH))) then (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH NEWWIDTH) (RETURN IMAGEOBJ]) (DOCOBJ-HRULE-INIT [LAMBDA NIL (* Koomen " 4-Feb-87 16:13") (* * provide HRULE editing * *) (DECLARE (GLOBALVARS HRULE.IMAGEFNS)) (replace (IMAGEFNS BUTTONEVENTINFN) of HRULE.IMAGEFNS with (FUNCTION DOCOBJ-HRULE-BUTTONEVENTINFN)) NIL]) (DOCOBJ-HRULE-GET-WIDTH [LAMBDA (RULE? FIRST?) (* ;  "Edited 24-May-93 23:35 by sybalsky:mv:envos") (DECLARE (GLOBALVARS DOCOBJ-HRULE-BLANK-PAD DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY)) [COND ((NULL DOCOBJ-HRULE-RULE-PAD) (SETQ DOCOBJ-HRULE-RULE-PAD (CREATE.NUMBERPAD.READER "Rule width: " NIL NIL NIL T T)) (SETQ DOCOBJ-HRULE-BLANK-PAD (CREATE.NUMBERPAD.READER "Blank space: " NIL NIL NIL T T] (COND (FIRST? (MOVEW DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY) (MOVEW DOCOBJ-HRULE-BLANK-PAD LASTMOUSEX LASTMOUSEY))) (NUMBERPAD.READ (COND (RULE? DOCOBJ-HRULE-RULE-PAD) (T DOCOBJ-HRULE-BLANK-PAD)) T]) (DOCOBJ-HRULE-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ;  "Edited 8-Oct-87 23:43 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-EDIT-HRULE IMAGEOBJ) then 'CHANGED]) ) (RPAQQ DOCOBJ-HRULE-RULE-PAD NIL) (RPAQQ DOCOBJ-HRULE-BLANK-PAD NIL) (ADDTOVAR DocObjectsMenuCommands ("Horizontal Rule" (DOCOBJ-MAKE-HRULE) "One or more horizontal rules")) (DOCOBJ-HRULE-INIT) (* ;; "INCLUDE") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD INCLOBJ (FILENAME ENABLEDP)) ) ) (DEFINEQ (DOCOBJ-MAKE-INCLUDE [LAMBDA NIL (* ; "Edited 15-Oct-87 14:54 by Koomen") (DECLARE (SPECVARS TEXTOBJ)) (PROG ((SUBFILE (TEDIT.GETINPUT TEXTOBJ "Enter file name: "))) (if SUBFILE then (RETURN (DOCOBJ-INCLUDE-CREATE-OBJ SUBFILE)) else (TEDIT.PROMPTPRINT TEXTOBJ "... aborted."]) (DOCOBJ-MAKE-INCLUDE-IMAGEFNS [LAMBDA NIL (* ; "Edited 23-Oct-87 00:20 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-INCLUDE-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-INCLUDE-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-INCLUDE-PUTFN)) (GETFN (FUNCTION DOCOBJ-INCLUDE-GETFN)) (COPYFN (FUNCTION DOCOBJ-INCLUDE-COPYFN)) (BUTTONEVENTINFN (FUNCTION DOCOBJ-INCLUDE-BUTTONEVENTINFN)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-INCLUDE-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-INCLUDE-CREATE-OBJ [LAMBDA (INCLOBJ) (* ; "Edited 23-Oct-87 14:06 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-INCLUDE-IMAGEFNS)) (PROG (IMAGEOBJ) [if INCLOBJ then (if (NLISTP INCLOBJ) then (* ;; "Just a file name") (SETQ INCLOBJ (create INCLOBJ FILENAME _ (MKSTRING INCLOBJ) ENABLEDP _ T] (SETQ IMAGEOBJ (IMAGEOBJCREATE INCLOBJ DOCOBJ-INCLUDE-IMAGEFNS)) (DOCOBJ-INCLUDE-RESET-OBJ IMAGEOBJ) (DOCOBJ-REGISTER-OBJECT IMAGEOBJ) (RETURN IMAGEOBJ]) (DOCOBJ-INCLUDE-EDIT [LAMBDA (INCLOBJ) (* ; "Edited 9-May-2018 11:09 by rmk:") (* ; "Edited 9-May-2018 10:35 by rmk:") (* ;  "Edited 26-Oct-87 19:57 by Koomen") (DECLARE (SPECVARS TEXTOBJ)) (SELECTQ [MENU (OR DOCOBJ-INCLUDE-EDITMENU (SETQ DOCOBJ-INCLUDE-EDITMENU (create MENU TITLE _ "Edit Include" ITEMS _ '(("New File" 'NEW.FILE "Include a different file") ("Edit File" 'EDIT.FILE "Edit the included file") ("Enable" 'ENABLE "Include the file during hardcopy" ) ("Disable" 'DISABLE "Do not include the file during hardcopy" )) CENTERFLG _ T MENUOFFSET _ '(-1 . 30) CHANGEOFFSETFLG _ 'Y] (NEW.FILE (LET [(NEWNAME (TEDIT.GETINPUT TEXTOBJ "Enter new file name: " (fetch (INCLOBJ FILENAME) of INCLOBJ] (if [AND NEWNAME (SETQ NEWNAME (MKSTRING NEWNAME)) (NOT (EQUAL NEWNAME (fetch (INCLOBJ FILENAME) of INCLOBJ] then (replace (INCLOBJ FILENAME) of INCLOBJ with NEWNAME) T))) (EDIT.FILE (for W in (OPENWINDOWS) bind [FULLNAME _ (OR [FINDFILE (fetch (INCLOBJ FILENAME) of INCLOBJ ) T (CONS (PACKFILENAME.STRING 'HOST (FILENAMEFIELD (FETCH TXTFILE OF TEXTOBJ) 'HOST) 'DIRECTORY (FILENAMEFIELD (FETCH TXTFILE OF TEXTOBJ) 'DIRECTORY] (INFILEP (fetch (INCLOBJ FILENAME) of INCLOBJ] first (if (NULL FULLNAME) then (TEDIT.PROMPTPRINT TEXTOBJ "Can't find " T) (TEDIT.PROMPTPRINT TEXTOBJ (fetch (INCLOBJ FILENAME) of INCLOBJ)) (RETURN)) when (SETQ W (DOCOBJ-INCLUDE-EDIT-WINDOWP FULLNAME W)) do (TOTOPW W) (GIVE.TTY.PROCESS W) (RETURN) finally (TEDIT (MKATOM FULLNAME)))) (ENABLE (if (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ)) then (replace (INCLOBJ ENABLEDP) of INCLOBJ with T) T)) (DISABLE (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then (replace (INCLOBJ ENABLEDP) of INCLOBJ with NIL) T)) NIL]) (DOCOBJ-INCLUDE-EDIT-WINDOWP [LAMBDA (FILENAME WINDOW) (* ; "Edited 26-Oct-87 19:53 by Koomen") (if (WINDOWP WINDOW) then (OR (LET (TEXTOBJ TXTFILE) (if (AND (SETQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ)) (type? TEXTOBJ TEXTOBJ) (SETQ TXTFILE (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) (STREAMP TXTFILE) (SETQ TXTFILE (FULLNAME TXTFILE)) (OR (STRINGP TXTFILE) (LITATOM TXTFILE)) (STRING-EQUAL FILENAME TXTFILE)) then WINDOW)) (DOCOBJ-INCLUDE-EDIT-WINDOWP FILENAME (WINDOWPROP WINDOW 'ICONFOR]) (DOCOBJ-INCLUDE-RESET-OBJ [LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:09 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-INCLUDE-IMAGEFNS)) (PROG (INCLOBJ FNAME) (if (SETQ INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then (SETQ FNAME (fetch (INCLOBJ FILENAME) of INCLOBJ)) (IMAGEOBJPROP IMAGEOBJ 'INCLDISPLAYSTRING (CONCAT "@Include[" FNAME "]")) (IMAGEOBJPROP IMAGEOBJ 'DONTINCLDISPLAYSTRING (CONCAT "@DoNotInclude[" FNAME "]")) ) (IMAGEOBJPROP IMAGEOBJ 'BEFOREHARDCOPYFN (FUNCTION DOCOBJ-INCLUDE-BEFOREHARDCOPYFN)) (IMAGEOBJPROP IMAGEOBJ 'AFTERHARDCOPYFN (FUNCTION DOCOBJ-INCLUDE-AFTERHARDCOPYFN]) ) (DEFINEQ (DOCOBJ-INCLUDE-AFTERHARDCOPYFN [LAMBDA (IMAGEOBJ CH#) (* ;  "Edited 3-Jun-93 12:42 by sybalsky:mv:envos") (DECLARE (SPECVARS TEXTSTREAM)) (COND ((IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) (* ;; "Just record current position, let endmarker do the rest") (IMAGEOBJPROP IMAGEOBJ 'INCLSTARTPOS (ADD1 CH#))) (T (* ;; "Hit an end marker") (PROG (HEADOBJ STARTPOS) (SETQ HEADOBJ (IMAGEOBJPROP IMAGEOBJ 'INCLIMAGEOBJ)) (SETQ STARTPOS (IMAGEOBJPROP HEADOBJ 'INCLSTARTPOS)) (IMAGEOBJPROP HEADOBJ 'INCLUDEDP NIL) (push *DOCOBJ-FORMS* `(DOCOBJ-INCLUDE-CLEANUPFN ,TEXTSTREAM ,STARTPOS ,(ADD1 (IDIFFERENCE CH# STARTPOS]) (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN [LAMBDA (IMAGEOBJ CH#) (* ; "Edited 9-May-2018 11:08 by rmk:") (* ; "Edited 9-May-2018 09:50 by rmk:") (* ; "Edited 9-May-2018 09:20 by rmk:") (* ;  "Edited 1-Jun-93 10:56 by sybalsky:mv:envos") (DECLARE (SPECVARS *DOCOBJ-FORMS* TEXTOBJ)) (* ;; "RMK: Changed to default to file in same directory as the including file. ") (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (COND ([AND INCLOBJ (fetch (INCLOBJ ENABLEDP) of INCLOBJ) (NOT (IMAGEOBJPROP IMAGEOBJ 'INCLUDEDP] (* ;; "We're under MAP.PIECES -- dangerous to insert here, so postpone") (push *DOCOBJ-FORMS* (LIST [FUNCTION (LAMBDA (STARTPOS INCLFILE IMAGEOBJ ENDOBJ WINDOWS) (DECLARE (SPECVARS TEXTSTREAM)) (COND (WINDOWS (TEDIT.PROMPTPRINT TEXTSTREAM "Including " T) (TEDIT.PROMPTPRINT TEXTSTREAM INCLFILE) (TEDIT.PROMPTPRINT TEXTSTREAM "...")) (T (PROMPTPRINT "[TEdit hardcopy: including " INCLFILE "...]"))) (WITHOUT-UPDATES (TEXTOBJ TEXTSTREAM) (fetch (TEXTOBJ SCRATCHSEL) of (TEXTOBJ TEXTSTREAM)) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'RIGHT) (* ;; "Force paragraph boundary, so that the first paragraph of the included document doesn't inherit the paralooks of the paragraph containing the @Include.") (TEDIT.INSERT TEXTSTREAM " ") (TEDIT.PARALOOKS TEXTSTREAM '(NEWPAGEAFTER NIL NEWPAGEBEFORE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 0)) (* ;;  "For space efficiency, tell TEdit to assume that the file will exist as long as we need it.") (TEDIT.INCLUDE TEXTSTREAM (OR [FINDFILE INCLFILE T (CONS (PACKFILENAME.STRING 'HOST (FILENAMEFIELD (FETCH TXTFILE OF (TEXTOBJ TEXTSTREAM )) 'HOST) 'DIRECTORY (FILENAMEFIELD (FETCH TXTFILE OF (TEXTOBJ TEXTSTREAM )) 'DIRECTORY] INCLFILE) NIL NIL T) (TEDIT.INSERT.OBJECT ENDOBJ TEXTSTREAM) (IMAGEOBJPROP ENDOBJ 'INCLIMAGEOBJ IMAGEOBJ) (IMAGEOBJPROP IMAGEOBJ 'INCLUDEDP T)) (COND (WINDOWS (TEDIT.PROMPTPRINT TEXTSTREAM " done.")) (T (PROMPTPRINT "[TEdit hardcopy: including " INCLFILE "... done.]"] (ADD1 CH#) (fetch (INCLOBJ FILENAME) of INCLOBJ) IMAGEOBJ (DOCOBJ-INCLUDE-CREATE-OBJ) (fetch (TEXTOBJ \WINDOW) of TEXTOBJ]) (DOCOBJ-INCLUDE-CLEANUPFN [LAMBDA (TEXTSTREAM STARTPOS LEN) (* ;  "Edited 3-Jun-93 12:43 by sybalsky:mv:envos") (* ;; "Do the cleanup of removing an included file's pieces (and closing it) after hardcopying with inclusions.") (LET* ((SEL (TEDIT.SETSEL TEXTSTREAM STARTPOS LEN)) (PCS (TEDIT.SELECTED.PIECES (TEXTOBJ TEXTSTREAM) SEL))) (for PC in PCS when (AND (fetch (PIECE PFILE) of PC) (OPENP (fetch (PIECE PFILE) of PC))) do (CLOSEF (fetch (PIECE PFILE) of PC))) (TEDIT.DELETE TEXTSTREAM STARTPOS LEN) (BLOCK]) (DOCOBJ-INCLUDE-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ; "Edited 23-Oct-87 00:46 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-INCLUDE-EDIT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then (DOCOBJ-INCLUDE-RESET-OBJ IMAGEOBJ) 'CHANGED]) (DOCOBJ-INCLUDE-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* ; "Edited 23-Oct-87 00:13 by Koomen") (DOCOBJ-INCLUDE-CREATE-OBJ (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-INCLUDE-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ; "Edited 23-Oct-87 14:42 by Koomen") (PROG [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (if [AND INCLOBJ (OR (EQ IMAGESTREAMTYPE 'DISPLAY) (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ] then (printout IMAGESTREAM (IMAGEOBJPROP IMAGEOBJ (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then 'INCLDISPLAYSTRING else 'DONTINCLDISPLAYSTRING]) (DOCOBJ-INCLUDE-GETFN [LAMBDA (FILESTREAM) (* ; "Edited 26-Oct-87 22:00 by Koomen") (LET ((INCLOBJ (READ FILESTREAM))) (if (NLISTP INCLOBJ) then (* ;; "Version 1: Just filename as string") (* ;; "Version 2: List whose CAR is filename") (SETQ INCLOBJ (create INCLOBJ FILENAME _ INCLOBJ))) (if (NLISTP (CDR INCLOBJ)) then (* ;; "Version 3: List whose CADR is ENABLEDP flag") (NCONC1 INCLOBJ T)) (DOCOBJ-INCLUDE-CREATE-OBJ INCLOBJ]) (DOCOBJ-INCLUDE-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 23-Oct-87 14:41 by Koomen") (OR (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (if [AND INCLOBJ (OR (EQ (IMAGESTREAMTYPE IMAGESTREAM) 'DISPLAY) (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ] then (DOCOBJ-STRING-IMAGEBOX (IMAGEOBJPROP IMAGEOBJ (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then 'INCLDISPLAYSTRING else 'DONTINCLDISPLAYSTRING)) IMAGESTREAM))) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (DOCOBJ-INCLUDE-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:19 by Koomen") (fetch (INCLOBJ FILENAME) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-INCLUDE-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* ; "Edited 15-Oct-87 17:17 by Koomen") (PRINT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) FILESTREAM]) ) (RPAQ? DOCOBJ-INCLUDE-EDITMENU ) (RPAQ? DOCOBJ-INCLUDE-IMAGEFNS (DOCOBJ-MAKE-INCLUDE-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("Include" (DOCOBJ-MAKE-INCLUDE) "Include another document right here when hardcopying")) (DECLARE%: DONTEVAL@LOAD DOCOPY (DOCOBJ-INIT) ) (DECLARE%: EVAL@LOAD DONTCOPY (PUTPROPS DOC-OBJECTS FILETYPE :TCOMPL) (PUTPROPS DOC-OBJECTS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) ) (PUTPROPS DOC-OBJECTS COPYRIGHT ("Johannes A. G. M. Koomen" 1986 1987 1993 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7690 17683 (DOCOBJ-ACQUIRE-OBJECT 7700 . 8574) (DOCOBJ-INIT 8576 . 9204) ( DOCOBJ-TEDIT-MENU-ENTRY 9206 . 9628) (DOCOBJ-GET-LOOKS 9630 . 12365) (DOCOBJ-REGISTER-OBJECT 12367 . 13021) (DOCOBJ-STRING-IMAGEBOX 13023 . 13971) (DOCOBJ-WAIT-MOUSE 13973 . 14433) ( DOCOBJ-INVOKE-IMAGEOBJFN 14435 . 15219) (DOCOBJ-BEFOREHARDCOPYFN 15221 . 16614) ( DOCOBJ-AFTERHARDCOPYFN 16616 . 17681)) (17713 17980 (DOCOBJ-ACQUIRE-EVALED-OBJECT 17723 . 17978)) ( 18184 18326 (DOCOBJ-ACQUIRE-SNAPPED-OBJECT 18194 . 18324)) (18669 23465 (DOCOBJ-EDIT-TIMESTAMP 18679 . 19208) (DOCOBJ-MAKE-TIMESTAMP 19210 . 19621) (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS 19623 . 20693) ( DOCOBJ-TIMESTAMP-BUTTONEVENTINFN 20695 . 21226) (DOCOBJ-TIMESTAMP-COPYFN 21228 . 21553) ( DOCOBJ-TIMESTAMP-DISPLAYFN 21555 . 21848) (DOCOBJ-TIMESTAMP-GETFN 21850 . 22090) ( DOCOBJ-TIMESTAMP-IMAGEBOXFN 22092 . 22448) (DOCOBJ-TIMESTAMP-PREPRINTFN 22450 . 22681) ( DOCOBJ-TIMESTAMP-PUTFN 22683 . 23052) (DOCOBJ-TIMESTAMP-TO-STRING 23054 . 23463)) (23763 28070 ( DOCOBJ-MAKE-FILESTAMP 23773 . 24114) (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS 24116 . 25158) ( DOCOBJ-FILESTAMP-COPYFN 25160 . 25475) (DOCOBJ-FILESTAMP-DISPLAYFN 25477 . 25765) ( DOCOBJ-FILESTAMP-GETFN 25767 . 26120) (DOCOBJ-FILESTAMP-IMAGEBOXFN 26122 . 26460) ( DOCOBJ-FILESTAMP-GET-FULLNAME 26462 . 27080) (DOCOBJ-FILESTAMP-NEW-FULLNAME 27082 . 27555) ( DOCOBJ-FILESTAMP-PREPRINTFN 27557 . 27766) (DOCOBJ-FILESTAMP-PUTFN 27768 . 28068)) (28397 30894 ( DOCOBJ-MAKE-HRULE 28407 . 28821) (DOCOBJ-EDIT-HRULE 28823 . 29295) (DOCOBJ-HRULE-INIT 29297 . 29629) ( DOCOBJ-HRULE-GET-WIDTH 29631 . 30442) (DOCOBJ-HRULE-BUTTONEVENTINFN 30444 . 30892)) (31282 39731 ( DOCOBJ-MAKE-INCLUDE 31292 . 31693) (DOCOBJ-MAKE-INCLUDE-IMAGEFNS 31695 . 32700) ( DOCOBJ-INCLUDE-CREATE-OBJ 32702 . 33491) (DOCOBJ-INCLUDE-EDIT 33493 . 38092) ( DOCOBJ-INCLUDE-EDIT-WINDOWP 38094 . 38956) (DOCOBJ-INCLUDE-RESET-OBJ 38958 . 39729)) (39732 49830 ( DOCOBJ-INCLUDE-AFTERHARDCOPYFN 39742 . 40626) (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN 40628 . 45403) ( DOCOBJ-INCLUDE-CLEANUPFN 45405 . 46172) (DOCOBJ-INCLUDE-BUTTONEVENTINFN 46174 . 46708) ( DOCOBJ-INCLUDE-COPYFN 46710 . 46928) (DOCOBJ-INCLUDE-DISPLAYFN 46930 . 47662) (DOCOBJ-INCLUDE-GETFN 47664 . 48387) (DOCOBJ-INCLUDE-IMAGEBOXFN 48389 . 49398) (DOCOBJ-INCLUDE-PREPRINTFN 49400 . 49619) ( DOCOBJ-INCLUDE-PUTFN 49621 . 49828))))) STOP \ No newline at end of file diff --git a/lispusers/DOC-OBJECTS.TEDIT b/lispusers/DOC-OBJECTS.TEDIT new file mode 100644 index 00000000..ce0ad6ce Binary files /dev/null and b/lispusers/DOC-OBJECTS.TEDIT differ diff --git a/lispusers/DONZ b/lispusers/DONZ new file mode 100644 index 00000000..d22c54e3 --- /dev/null +++ b/lispusers/DONZ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Mar-88 13:10:37" {ERINYES}LYRIC>DONZ.;2 23060 previous date%: " 1-Jun-86 13:49:39" {ERINYES}LYRIC>DONZ.;1) (* " Copyright (c) 1985, 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DONZCOMS) (RPAQQ DONZCOMS ((VARS DONZ.BUBBLE.BITMAP DONZ.BUBBLE.BITMAP.SMALL DONZ.BUBBLE.SHADOW DONZ.BUBBLE.SHADOW.SMALL DONZ.TEST.MESSAGE.ALIST DONZ.DELAY) (FNS SCREENBLEEDER DONZ.COMPUTE.BUBBLE.REGION DONZ.GETMESSAGE DONZ.ISA.CALENDAR.ICON DONZ.ISA.CHAT.ICON DONZ.ISA.CLOCK.WINDOW DONZ.ISA.FCACHE.ICON DONZ.ISA.FILEBROWSER.ICON DONZ.ISA.INSPECTOR.ICON DONZ.ISA.MAIL.BROWSER DONZ.ISA.SKETCH.ICON DONZ.ISA.TEDIT.ICON DONZ.MESSAGE DONZ.RUN DONZ.TRY.WINDOW) (P (ADD.PROCESS '(DONZ.RUN))))) (RPAQQ DONZ.BUBBLE.BITMAP #*(175 75)@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@GOOOOON@@@@@@@@@@@@@@@@@@GOOOOL@@@@@@@@@@@@COH@@@@@@@@@@@@@@@@@@@@@@@@@@GOOH@@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GO@@@@@@@@@@ON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@@@@@@@@CO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AO@@@@@@@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AO@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHB@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHB@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOHC@@@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOONAH@@@GO@@@@@@@@@@@@@@OOO@@@@@@@@@@@@@AON@@AOIH@@@AON@@@@@@@@@@@AOOOOO@@@@@@@@@@@OON@@@@CNL@@@@AOOO@@@@@@@COOOL@COOO@@@@@@OOOOL@@@@@@GL@@@@@AOOOOOOOOOOON@@@@@OOOOOOOOOOO@@@@@@@@AL@@@@@@@@OOOOOOOL@@@@@@@@AOOOOOON@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B ) (RPAQQ DONZ.BUBBLE.BITMAP.SMALL #*(150 65)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ DONZ.BUBBLE.SHADOW #*(175 75)@@@@@@@@@@@@@@@COOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOH@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@COL@@@@@GOOOOOOOOOOOOOL@COOOOOOOOOOOOOL@@@@@@GL@@@@@@GOOOOOOOOOON@@@@@OOOOOOOOOOO@@@@@@@@AL@@@@@@@@COOOOOOL@@@@@@@@AOOOOOON@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B ) (RPAQQ DONZ.BUBBLE.SHADOW.SMALL #*(175 75)@@@@@@@@@@@@@@@COOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOH@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@COL@@@@@GOOOOOOOOOOOOOL@COOOOOOOOOOOOOL@@@@@@GL@@@@@@GOOOOOOOOOON@@@@@OOOOOOOOOOO@@@@@@@@AL@@@@@@@@COOOOOOL@@@@@@@@AOOOOOON@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B ) (RPAQQ DONZ.TEST.MESSAGE.ALIST ((DONZ.ISA.CLOCK.WINDOW (Here's the time,) (Don't loose track of the time,) (It's good to have the correct time,) (Synchronize with me,) (Time is important, isn't it,) (Time is of the essence,) (I've always got time for you,) (Of course, Digital readouts are good too,) (It's time for a change,)) (DONZ.ISA.MAIL.BROWSER (Some nice notes in here,) (Don't forget the ZIP code,) (Fan mail from some flounder,) (Notes to your random friends,) (Another "Dear Don" letter just arrived,) (Perfumed Electronic Message in here,) (We worship you,) (A package for you,) (Postage due,) (It could be your mother,) (This one's in a plain brown wrapper,)) (DONZ.ISA.CALENDAR.ICON (I'll bet you have a date tonight,) (I can tell you what month it is,) (Lots of weekends this month,) (Life passes quickly,) (I've misplaced your schedule,) (Maybe you should schedule more time with Mom,)) (DONZ.ISA.TEDIT.ICON (I'd better be saved,) (Better check my spelling) (The world needs another stupid paper,) (OOPS.. just lost the results section,) (My Weekly Reader would love this,) (I've had to change a few remarks,) (Submit this to JIR,) (A pencil might be faster,)) (DONZ.ISA.SKETCH.ICON (Look me over,) (I wish I had your shape,) (Twiddle my bits,) (Great models in here,) (Another Picasso in the works,) (Play with my texture,) (Have you found that Crayon yet,) (I'm pretty neat,)) (DONZ.ISA.INSPECTOR.ICON (Do some work,) (Set some values,) (Inspect me,)) (DONZ.ISA.FCACHE.ICON (Money in the data bank,) (I'm the father of our country,) (Isn't this a clever icon,) (Never tell a lie,)) (DONZ.ISA.FILEBROWSER.ICON (Some good files in here,) (Pull me out,) (Don't drop any on the floor,)) (DONZ.ISA.CHAT.ICON (Help, I'm trapped in an ethernet,) (Mr. Computer calling,) (There are users in here,)))) (RPAQQ DONZ.DELAY 15000) (DEFINEQ (SCREENBLEEDER (LAMBDA NIL (* Jeff.Shrager "20-Dec-85 15:02") (do (BITBLT (SCREENBITMAP) (SETQ L (RAND 0 1000)) (SETQ B (RAND 0 800)) (SCREENBITMAP) (IDIFFERENCE L (RAND 1 3)) (IDIFFERENCE B (RAND 1 3)) (RAND 25 50) (RAND 25 50) 'INPUT 'REPLACE) (DISMISS)))) (DONZ.COMPUTE.BUBBLE.REGION (LAMBDA (WR) (* walt%: "26-Feb-86 12:34") (* Jeff.Shrager "20-Dec-85 16:55") (CONS (IDIFFERENCE (CAR WR) (BITMAPWIDTH DONZ.BUBBLE.BITMAP)) (IPLUS (CADR WR) (CADDDR WR))))) (DONZ.GETMESSAGE (LAMBDA (W) (* walt%: " 7-Mar-86 16:46") (* walt%: "25-Feb-86 16:30") (OR (for S in DONZ.TEST.MESSAGE.ALIST bind (MSG _ NIL) until MSG do (COND ((APPLY* (CAR S) (WINDOWPROP W 'ICONFOR)) (SETQ MSG (CAR (NTH (CDR S) (RAND 1 (LENGTH (CDR S))))))) ((APPLY* (CAR S) W) (SETQ MSG (CAR (NTH (CDR S) (RAND 1 (LENGTH (CDR S)))))))) finally (RETURN MSG)) (CAR (NTH '((Open me first,) (I'm getting bored,) (Party in here. Check it out,) (Let me out of here,) (I'm suffocating in here,) (I think I'm still shrinking,) (I need a flashlight,) (Look at me expand,) (I get VERY big,) (I'm beginning to think you've forgotten me,)) (RAND 1 10)))))) (DONZ.ISA.CALENDAR.ICON (LAMBDA (W) (* walt%: " 7-Mar-86 16:48") (EQ 'CALMONTHRBF (WINDOWPROP W 'RIGHTBUTTONFN)))) (DONZ.ISA.CHAT.ICON (LAMBDA (W) (* Jeff.Shrager "31-May-86 02:22") (EQ 'CHAT.RESHAPEWINDOW (WINDOWPROP W 'RESHAPEFN)))) (DONZ.ISA.CLOCK.WINDOW (LAMBDA (W) (* walt%: " 6-Mar-86 11:19") (OR (EQ 'BICLOCKRSFN (WINDOWPROP W 'RESHAPEFN)) (EQ 'CROCK.RESHAPEFN (WINDOWPROP W 'RESHAPEFN))))) (DONZ.ISA.FCACHE.ICON (LAMBDA (W) (* Jeff.Shrager "31-May-86 02:12") (EQUAL "File cache" (SUBSTRING (WINDOWPROP W 'TITLE) 1 10)))) (DONZ.ISA.FILEBROWSER.ICON (LAMBDA (W) (* Jeff.Shrager "31-May-86 02:14") (EQ 'FB.SCROLLFN (WINDOWPROP W 'SCROLLFN)))) (DONZ.ISA.INSPECTOR.ICON (LAMBDA (W) (* Jeff.Shrager "20-Dec-85 17:01") (EQ 'INSPECTW.REPAINTFN (WINDOWPROP W 'REPAINTFN)))) (DONZ.ISA.MAIL.BROWSER (LAMBDA (W) (* Jeff.Shrager "20-Dec-85 16:16") (EQ 'LAB.BUTTONEVENTFN (WINDOWPROP W 'RIGHTBUTTONFN)))) (DONZ.ISA.SKETCH.ICON (LAMBDA (W) (* Jeff.Shrager "20-Dec-85 16:59") (EQ 'SKETCHW.REPAINTFN (WINDOWPROP W 'REPAINTFN)))) (DONZ.ISA.TEDIT.ICON (LAMBDA (W) (* walt%: " 7-Mar-86 16:27") (* Jeff.Shrager "20-Dec-85 16:25") (EQ '\TEDIT.BUTTONEVENTFN (WINDOWPROP W 'BUTTONEVENTFN)))) (DONZ.MESSAGE (LAMBDA (W MSG) (* Jeff.Shrager " 1-Jun-86 13:49") (LET ((BUBBLE (ICONW DONZ.BUBBLE.BITMAP DONZ.BUBBLE.SHADOW (DONZ.COMPUTE.BUBBLE.REGION (WINDOWPROP W 'REGION)))) (BUBBLEPRINT (ICONW DONZ.BUBBLE.BITMAP.SMALL DONZ.BUBBLE.SHADOW.SMALL (DONZ.COMPUTE.BUBBLE.REGION (APPEND (LIST (IPLUS (CAR (WINDOWPROP W 'REGION)) 5) (IPLUS 3 (CADR (WINDOWPROP W 'REGION)))) (CDDR (WINDOWPROP W 'REGION))))))) (MOVETO 13 56 BUBBLEPRINT) (PRINTOUT BUBBLEPRINT T 1 .PARA 1 0 (APPEND MSG (LIST (CONCAT FIRSTNAME ".")))) (DISMISS 3000) (CLOSEW BUBBLE) (CLOSEW BUBBLEPRINT)))) (DONZ.RUN (LAMBDA NIL (* Jeff.Shrager "21-Dec-85 21:31") (PROG NIL LOOP (DONZ.TRY.WINDOW (CAR (NTH (OPENWINDOWS) (RAND 1 (LENGTH (OPENWINDOWS)))))) (DISMISS DONZ.DELAY) (GO LOOP)))) (DONZ.TRY.WINDOW (LAMBDA (W) (* walt%: " 7-Mar-86 16:43") (* walt%: "25-Feb-86 16:31") (OR (AND (WINDOWPROP W 'ICONFOR) (DONZ.MESSAGE W (DONZ.GETMESSAGE W))) (AND (OR (EQ 'BICLOCKRSFN (WINDOWPROP W 'RESHAPEFN)) (EQ 'CROCK.RESHAPEFN (WINDOWPROP W 'RESHAPEFN))) (DONZ.MESSAGE W (DONZ.GETMESSAGE W)))))) ) (ADD.PROCESS '(DONZ.RUN)) (PUTPROPS DONZ COPYRIGHT ("Xerox Corporation" 1985 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (17495 22948 (SCREENBLEEDER 17505 . 17959) (DONZ.COMPUTE.BUBBLE.REGION 17961 . 18317) ( DONZ.GETMESSAGE 18319 . 19476) (DONZ.ISA.CALENDAR.ICON 19478 . 19645) (DONZ.ISA.CHAT.ICON 19647 . 19819) (DONZ.ISA.CLOCK.WINDOW 19821 . 20044) (DONZ.ISA.FCACHE.ICON 20046 . 20260) ( DONZ.ISA.FILEBROWSER.ICON 20262 . 20433) (DONZ.ISA.INSPECTOR.ICON 20435 . 20612) ( DONZ.ISA.MAIL.BROWSER 20614 . 20792) (DONZ.ISA.SKETCH.ICON 20794 . 20967) (DONZ.ISA.TEDIT.ICON 20969 . 21238) (DONZ.MESSAGE 21240 . 22170) (DONZ.RUN 22172 . 22479) (DONZ.TRY.WINDOW 22481 . 22946))))) STOP \ No newline at end of file diff --git a/lispusers/DONZ.TEDIT b/lispusers/DONZ.TEDIT new file mode 100644 index 00000000..4d44e768 Binary files /dev/null and b/lispusers/DONZ.TEDIT differ diff --git a/lispusers/DORADOCOLOR b/lispusers/DORADOCOLOR new file mode 100644 index 00000000..5da89c9a --- /dev/null +++ b/lispusers/DORADOCOLOR @@ -0,0 +1 @@ +(FILECREATED "24-Feb-86 12:32:26" {ERIS}LIBRARY>DORADOCOLOR.;27 15311 changes to: (VARS DORADOCOLORCOMS) previous date: "15-Feb-86 16:46:20" {ERIS}LIBRARY>DORADOCOLOR.;26) (* Copyright (c) 1985, 1900, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DORADOCOLORCOMS) (RPAQQ DORADOCOLORCOMS ((* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb Jellinek, and Kelly Roach.) (DECLARE: DONTCOPY (RECORDS MonitorCB ChannelCB ColorCB ColorEntry) (CONSTANTS (DORADO\COLORSCREENWIDTH 640) (DORADO\COLORSCREENHEIGHT 480) (DORADOCOLORPAGES 602) (pplOffset 255) (MCBPtr 268) (MCBSeal 65326) (MCBLow 160) (MCBSize 8) (AFlagsMask 4) (ChCBLow 168) (ChCBSize 8) (ColCBLow 176) (ColCBSize 16) (CMapPages 8))) (* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and 40 for most other monitors. *) (INITVARS (\DORADOCOLOR.LEFTMARGIN 80) (\DORADOCOLOR.ATABLEIMAGE NIL) (DORADOCOLOR.BITSPERPIXEL 8)) (GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL) (FNS \RGB.TO.DORADO.RGB \DORADOCOLOR.LOOKATA) (FNS \DORADOCOLOR.INIT \DORADOCOLOR.STARTCOLOR \DORADOCOLOR.STOPCOLOR \DORADOCOLOR.EVENTFN \DORADOCOLOR.SENDCOLORMAPENTRY) (FNS \DORADOCOLOR.COLORLEVEL \DORADOCOLOR.SETONECOLOR) (FILES COLOR) (DECLARE: DONTEVAL@LOAD DOCOPY (P (\DORADOCOLOR.INIT))))) (* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb Jellinek, and Kelly Roach.) (DECLARE: DONTCOPY [DECLARE: EVAL@COMPILE (BLOCKRECORD MonitorCB ((Seal WORD) (Flags WORD) (ACB WORD) (NIL WORD) (colorCB WORD))) (BLOCKRECORD ChannelCB ((NIL WORD) (wordsPerLine WORD) (bitmapLo WORD) (bitmapHi WORD) (linesPerField WORD) (pixelsPerLine WORD) (leftMargin WORD) (scan WORD))) (BLOCKRECORD ColorCB ((ATableLo WORD) (ATableHi WORD) (NIL 6 WORD) (VBtoVS BYTE) (VStoVS BYTE) (VStoVB WORD) (VisibleLines WORD) (X WORD) (W BYTE) (A BYTE) (BtoA WORD) (clockm BITS 12) (clockd BITS 4) (NIL WORD))) (BLOCKRECORD ColorEntry ((NIL BITS 4) (RedLo BITS 4) (Blue BYTE) (NIL BITS 4) (Green BITS 8) (RedHi BITS 4))) ] (DECLARE: EVAL@COMPILE (RPAQQ DORADO\COLORSCREENWIDTH 640) (RPAQQ DORADO\COLORSCREENHEIGHT 480) (RPAQQ DORADOCOLORPAGES 602) (RPAQQ pplOffset 255) (RPAQQ MCBPtr 268) (RPAQQ MCBSeal 65326) (RPAQQ MCBLow 160) (RPAQQ MCBSize 8) (RPAQQ AFlagsMask 4) (RPAQQ ChCBLow 168) (RPAQQ ChCBSize 8) (RPAQQ ColCBLow 176) (RPAQQ ColCBSize 16) (RPAQQ CMapPages 8) (CONSTANTS (DORADO\COLORSCREENWIDTH 640) (DORADO\COLORSCREENHEIGHT 480) (DORADOCOLORPAGES 602) (pplOffset 255) (MCBPtr 268) (MCBSeal 65326) (MCBLow 160) (MCBSize 8) (AFlagsMask 4) (ChCBLow 168) (ChCBSize 8) (ColCBLow 176) (ColCBSize 16) (CMapPages 8)) ) ) (* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and 40 for most other monitors. *) (RPAQ? \DORADOCOLOR.LEFTMARGIN 80) (RPAQ? \DORADOCOLOR.ATABLEIMAGE NIL) (RPAQ? DORADOCOLOR.BITSPERPIXEL 8) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL) ) (DEFINEQ (\RGB.TO.DORADO.RGB (LAMBDA (RGB ColorEntryBox) (* kbr: " 5-Jul-85 15:08") (PROG (ColorEntry) (SETQ ColorEntry (OR ColorEntryBox (\ALLOCBLOCK 1))) (replace (ColorEntry Blue) of ColorEntry with (fetch (RGB BLUE) of RGB)) (replace (ColorEntry Green) of ColorEntry with (fetch (RGB GREEN) of RGB)) (replace (ColorEntry RedLo) of ColorEntry with (LOGAND (fetch (RGB RED) of RGB) 15)) (replace (ColorEntry RedHi) of ColorEntry with (LRSH (fetch (RGB RED) of RGB) 4)) (RETURN ColorEntry)))) (\DORADOCOLOR.LOOKATA (LAMBDA (MCB) (* kbr: " 5-Jul-85 16:04") (replace (MonitorCB Flags) of MCB with (LOGOR AFlagsMask (fetch (MonitorCB Flags) of MCB))) (while (EQ AFlagsMask (LOGAND AFlagsMask (fetch (MonitorCB Flags) of MCB))) do (* wait for microcode to notice) (BLOCK)))) ) (DEFINEQ (\DORADOCOLOR.INIT (LAMBDA NIL (* kbr: "15-Feb-86 13:01") (DECLARE (GLOBALVARS \DORADOCOLORWSOPS \DORADOCOLORINFO)) (SETQ \DORADOCOLORWSOPS (create WSOPS STARTBOARD _(FUNCTION NILL) STARTCOLOR _(FUNCTION \DORADOCOLOR.STARTCOLOR) STOPCOLOR _(FUNCTION \DORADOCOLOR.STOPCOLOR) EVENTFN _(FUNCTION \DORADOCOLOR.EVENTFN) SENDCOLORMAPENTRY _(FUNCTION \DORADOCOLOR.SENDCOLORMAPENTRY) SENDPAGE _(FUNCTION NILL) PILOTBITBLT _(FUNCTION \DISPLAY.PILOTBITBLT))) (SETQ \DORADOCOLORINFO (create DISPLAYINFO DITYPE _(QUOTE DORADOCOLOR) DIWIDTH _ DORADO\COLORSCREENWIDTH DIHEIGHT _ DORADO\COLORSCREENHEIGHT DIBITSPERPIXEL _ 8 DIWSOPS _ \DORADOCOLORWSOPS)) (\DEFINEDISPLAYINFO \DORADOCOLORINFO))) (\DORADOCOLOR.STARTCOLOR (LAMBDA (FDEV) (* kbr: "21-Aug-85 15:55") (DECLARE (GLOBALVARS \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL)) (PROG (DISPLAYSTATE MCB AC CB) (COND ((EQ (MACHINETYPE) (QUOTE DORADO)) (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE STARTCOLOR)) (MOVD (QUOTE \DISPLAY.PILOTBITBLT) (QUOTE \SOFTCURSORPILOTBITBLT)) (\LOCKFN (QUOTE \SOFTCURSORPILOTBITBLT)) (SETQ MCB (EMADDRESS MCBLow)) (SETQ AC (EMADDRESS ChCBLow)) (SETQ CB (EMADDRESS ColCBLow)) (\ZEROWORDS MCB (\ADDBASE MCB MCBSize)) (\ZEROWORDS AC (\ADDBASE AC ChCBSize)) (\ZEROWORDS CB (\ADDBASE CB ColCBSize)) (* Set up color control block) (OR \DORADOCOLOR.ATABLEIMAGE (SETQ \DORADOCOLOR.ATABLEIMAGE (\ALLOCBLOCK (ITIMES CMapPages 128) NIL 128))) (\TEMPLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages) (replace (ColorCB ATableHi) of CB with (\HILOC \DORADOCOLOR.ATABLEIMAGE)) (* Reverse pointer) (replace (ColorCB ATableLo) of CB with (\LOLOC \DORADOCOLOR.ATABLEIMAGE)) (replace (ColorCB VBtoVS) of CB with 3) (replace (ColorCB VStoVS) of CB with 3) (replace (ColorCB VStoVB) of CB with 16) (replace (ColorCB VisibleLines) of CB with 240) (replace (ColorCB X) of CB with 379) (replace (ColorCB W) of CB with 6) (replace (ColorCB A) of CB with 35) (replace (ColorCB BtoA) of CB with 18) (replace (ColorCB clockm) of CB with 88) (replace (ColorCB clockd) of CB with 12) (* set up channel control block) (replace (ChannelCB wordsPerLine) of AC with (FOLDHI (ITIMES DORADO\COLORSCREENWIDTH DORADOCOLOR.BITSPERPIXEL) BITSPERWORD)) (SETQ ColorScreenBitMapBase (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap)) (\TEMPLOCKPAGES ColorScreenBitMapBase DORADOCOLORPAGES) (replace (ChannelCB bitmapHi) of AC with (\HILOC ColorScreenBitMapBase)) (replace (ChannelCB bitmapLo) of AC with (\LOLOC ColorScreenBitMapBase)) (replace (ChannelCB linesPerField) of AC with (IQUOTIENT DORADO\COLORSCREENHEIGHT 2)) (replace (ChannelCB pixelsPerLine) of AC with (IPLUS DORADO\COLORSCREENWIDTH pplOffset)) (replace (ChannelCB leftMargin) of AC with \DORADOCOLOR.LEFTMARGIN) (replace (ChannelCB scan) of AC with (SELECTQ DORADOCOLOR.BITSPERPIXEL (4 (* Magic constants = 164B) 116) (8 (* Magic constants = 170B) 120) (\ILLEGAL.ARG DORADOCOLOR.BITSPERPIXEL))) (replace (MonitorCB Seal) of MCB with MCBSeal) (replace (MonitorCB Flags) of MCB with 60) (replace (MonitorCB ACB) of MCB with ChCBLow) (* Wyatt used an empty A bitmap to establish scan mode. Why? We dont) (replace (MonitorCB colorCB) of MCB with ColCBLow) (EMPUTBASE MCBPtr MCBLow) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE ON))))))) (\DORADOCOLOR.STOPCOLOR (LAMBDA (FDEV) (* kbr: "21-Aug-85 15:56") (PROG (DISPLAYSTATE MCB) (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE STOPCOLOR)) (SETQ MCB (EMADDRESS MCBLow)) (replace (MonitorCB ACB) of MCB with 0) (\ZEROWORDS \DORADOCOLOR.ATABLEIMAGE (\ADDBASE \DORADOCOLOR.ATABLEIMAGE 32)) (* Black) (\DORADOCOLOR.LOOKATA MCB) (EMPUTBASE MCBPtr 0) (\TEMPUNLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages) (\TEMPUNLOCKPAGES (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap) DORADOCOLORPAGES) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE OFF))))) (\DORADOCOLOR.EVENTFN (LAMBDA (FDEV EVENT) (* kbr: "24-Aug-85 16:55") (COND ((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV)) (QUOTE ON)) (SELECTQ EVENT ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS) (* turn off display since we may awake on different  machine) (COLORDISPLAY (QUOTE OFF))) (AFTERSAVEVM (* Rekick the color microcode. *) (\DORADOCOLOR.STARTCOLOR \COLORDISPLAYFDEV) (SCREENCOLORMAP (SCREENCOLORMAP))) NIL))))) (\DORADOCOLOR.SENDCOLORMAPENTRY (LAMBDA (FDEV COLOR# RGB) (* kbr: " 5-Jul-85 15:06") (PROG (ScratchColorEntry J) (SETQ ScratchColorEntry (\RGB.TO.DORADO.RGB (LIST 0 0 0))) (OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT)) (SETQ J (ITIMES COLOR# 8)) (\RGB.TO.DORADO.RGB RGB ScratchColorEntry) (\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE ScratchColorEntry 0)) (\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J) (\GETBASE ScratchColorEntry 1)) (\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow))))) ) (DEFINEQ (\DORADOCOLOR.COLORLEVEL (LAMBDA (DISPLAY COLOR# PRIMARYCOLOR NEWLEVEL) (* kbr: " 5-Jul-85 15:23") (PROG (REALCOLOR# COLORMAP ColorEntry) (SETQ REALCOLOR# (COLORNUMBERP COLOR#)) (SETQ COLORMAP (SCREENCOLORMAP NIL DISPLAY)) (SETQ ColorEntry (COLORMAPENTRY COLORMAP REALCOLOR#)) (PROG1 (\GENERIC.COLORLEVEL COLORMAP REALCOLOR# PRIMARYCOLOR NEWLEVEL) (* destructively modifies ColorEntry entry of COLORMAP  to have correct level of PRIMARYCOLOR) (\DORADOCOLOR.SETONECOLOR ColorEntry REALCOLOR#))))) (\DORADOCOLOR.SETONECOLOR (LAMBDA (RGBTRIPLE COLOR#) (* kbr: " 5-Jul-85 15:24") (PROG (DORADOFORMATCOLORCELL J) (OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT)) (SETQ DORADOFORMATCOLORCELL (\RGB.TO.DORADO.RGB RGBTRIPLE)) (SETQ J (LLSH COLOR# (IDIFFERENCE 11 DORADOCOLOR.BITSPERPIXEL))) (\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE DORADOFORMATCOLORCELL 0)) (\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J) (\GETBASE DORADOFORMATCOLORCELL 1)) (\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow))))) ) (FILESLOAD COLOR) (DECLARE: DONTEVAL@LOAD DOCOPY (\DORADOCOLOR.INIT) ) (PUTPROPS DORADOCOLOR COPYRIGHT ("Xerox Corporation" 1985 1900 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (5142 6333 (\RGB.TO.DORADO.RGB 5152 . 5872) (\DORADOCOLOR.LOOKATA 5874 . 6331)) (6334 13812 (\DORADOCOLOR.INIT 6344 . 7610) (\DORADOCOLOR.STARTCOLOR 7612 . 11482) (\DORADOCOLOR.STOPCOLOR 11484 . 12431) (\DORADOCOLOR.EVENTFN 12433 . 13153) (\DORADOCOLOR.SENDCOLORMAPENTRY 13155 . 13810)) ( 13813 15147 (\DORADOCOLOR.COLORLEVEL 13823 . 14500) (\DORADOCOLOR.SETONECOLOR 14502 . 15145))))) STOP \ No newline at end of file diff --git a/lispusers/DPUPFTPPATCH b/lispusers/DPUPFTPPATCH new file mode 100644 index 00000000..1f02c588 --- /dev/null +++ b/lispusers/DPUPFTPPATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Sep-87 11:48:32" {DSK}MATT>DPUPFTPPATCH.;6 5640 changes to%: (FNS \FTP.NEGOTIATED.CONNECTION.SOCKET) previous date%: "24-Jul-87 12:29:41" {DSK}MATT>DPUPFTPPATCH.;5) (* " Copyright (c) 1987 by Matt Heffron & XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT DPUPFTPPATCHCOMS) (RPAQQ DPUPFTPPATCHCOMS ((DECLARE%: DOCOPY FIRST (FILES DPUPFTP)) (FNS \FTP.NEGOTIATED.CONNECTION.SOCKET \FTP.OPEN.CONNECTION) (INITVARS (*FTP.NEGOTIATED.CONNECTION.HOSTS* NIL)) (GLOBALVARS *FTP.NEGOTIATED.CONNECTION.HOSTS*) (CONSTANTS (\PT.NEGOTIATED.CONNECTION 128) (\PUPSOCKET.NEGOTIATED.CONNECTION 63)) (DECLARE%: DONTCOPY (FILES (LOADCOMP) DPUPFTP)) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) DPUPFTPPATCH))) (DECLARE%: DOCOPY FIRST (FILESLOAD DPUPFTP) ) (DEFINEQ (\FTP.NEGOTIATED.CONNECTION.SOCKET [LAMBDA (PORT) (DECLARE (GLOBALVARS *FTP.NEGOTIATED.CONNECTION.HOSTS*)) (* ; "Edited 8-Sep-87 11:46 by Matt Heffron") (if (ZEROP (CDR PORT)) then [CONS (CAR PORT) (COND ((EQ (CDR PORT) 0) \PUPSOCKET.FTP) (T (CDR PORT] (if (MEMB (CAR PORT) *FTP.NEGOTIATED.CONNECTION.HOSTS*) then (LET ((PUP (ALLOCATE.PUP)) RESULT.FTP.SOCKET NEGOTIATIONSOCKET) (CLEARPUP PUP) (SETQ NEGOTIATIONSOCKET (SETUPPUP PUP (CAR PORT) \PUPSOCKET.NEGOTIATED.CONNECTION \PT.NEGOTIATED.CONNECTION NIL NIL 'FREE)) (SENDPUP NEGOTIATIONSOCKET PUP) (SETQ PUP (GETPUP NEGOTIATIONSOCKET 10000)) (if PUP then (SETQ RESULT.FTP.SOCKET (fetch PUPSOURCESOCKET of PUP)) (RELEASE.PUP PUP) else (* ;; "Timed-out, just do it the old-fashoned way.") (SETQ RESULT.FTP.SOCKET \PUPSOCKET.FTP)) (CONS (CAR PORT) RESULT.FTP.SOCKET)) else (* ;; "This is not talking to a known FTP negotiated connection host. So use the standard \PUPSOCKET.FTP.") (CONS (CAR PORT) \PUPSOCKET.FTP)) else (* ;; "If they specified an explicit SOCKET in the PORT (i.e. in the HOST argument to \FTP.OPEN.CONNECTION), just return that PORT.") PORT]) (\FTP.OPEN.CONNECTION [LAMBDA (HOST ECHOSTREAM FAILURESTRING) (* ; "Edited 21-Jul-87 18:45 by Matt Heffron") (LET ((PORT (BESTPUPADDRESS HOST PROMPTWINDOW)) INSTREAM) (if [AND PORT (SETQ INSTREAM (OPENBSPSTREAM (\FTP.NEGOTIATED.CONNECTION.SOCKET PORT) NIL (FUNCTION \FTP.ERRORHANDLER) NIL NIL (FUNCTION \FTP.WHENCLOSED) (OR FAILURESTRING "Can't open FTP connection"] then (if (TYPENAMEP INSTREAM 'STREAM) then (SETQ INSTREAM (create FTPCONNECTION FTPIN _ INSTREAM FTPOUT _ (BSPOUTPUTSTREAM INSTREAM) FTPHOST _ [\CANONICAL.HOSTNAME (COND ((LITATOM HOST) HOST) (T (ETHERHOSTNAME PORT] FTPBUSY _ T)) (if (\FTP.SENDVERSION INSTREAM ECHOSTREAM) then (push \FTPCONNECTIONS INSTREAM) INSTREAM else (CLOSEBSPSTREAM (fetch FTPIN of INSTREAM))) else INSTREAM]) ) (RPAQ? *FTP.NEGOTIATED.CONNECTION.HOSTS* NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *FTP.NEGOTIATED.CONNECTION.HOSTS*) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PT.NEGOTIATED.CONNECTION 128) (RPAQQ \PUPSOCKET.NEGOTIATED.CONNECTION 63) (CONSTANTS (\PT.NEGOTIATED.CONNECTION 128) (\PUPSOCKET.NEGOTIATED.CONNECTION 63)) ) (DECLARE%: DONTCOPY (FILESLOAD (LOADCOMP) DPUPFTP) ) (PUTPROPS DPUPFTPPATCH FILETYPE :TCOMPL) (PUTPROPS DPUPFTPPATCH MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS DPUPFTPPATCH COPYRIGHT ("Matt Heffron & XEROX Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1140 4993 (\FTP.NEGOTIATED.CONNECTION.SOCKET 1150 . 3246) (\FTP.OPEN.CONNECTION 3248 . 4991))))) STOP \ No newline at end of file diff --git a/lispusers/DSPSCALE b/lispusers/DSPSCALE new file mode 100644 index 00000000..68ab32c6 --- /dev/null +++ b/lispusers/DSPSCALE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jul-88 13:36:39" |{MCS:MCS:STANFORD}DSPSCALE.;10| 55021 changes to%: (FNS \TRANSLATE.SCALED CHARWIDTH! CHARWIDTHY! FONTPROP! STRINGWIDTH! INITSCALEDIMAGESTREAM \FILLPOLYGON.SCALED DSPSCALE.DASHING OPENIMAGESTREAM.SCALED \BACKCOLOR.SCALED \BITBLT.SCALED \BLTSHADE.SCALED \BOTTOMMARGIN.SCALED \BOUT.SCALED \CHARSET.SCALED \CHARWIDTH.SCALED \CHARWIDTHY.SCALED \CLIPPINGREGION.SCALED \CLOSEFN.SCALED \COLOR.SCALED \DEFAULTSTATE.SCALED \DRAWARC.SCALED \DRAWCIRCLE.SCALED \DRAWCURVE.SCALED \DRAWELLIPSE.SCALED \DRAWLINE.SCALED \DRAWPOINT.SCALED \DRAWPOLYGON.SCALED \FILLCIRCLE.SCALED \FONT.SCALED \LEFTMARGIN.SCALED \LINEFEED.SCALED \MOVETO.SCALED \NEWPAGE.SCALED \OPERATION.SCALED \POPSTATE.SCALED \PUSHSTATE.SCALED \RESET.SCALED \RIGHTMARGIN.SCALED \ROTATE.SCALED \SCALE.SCALED \SCALEDBITBLT.SCALED \SPACEFACTOR.SCALED \STRINGWIDTH.SCALED \TERPRI.SCALED \TOPMARGIN.SCALED \XPOSITION.SCALED \YPOSITION.SCALED \OUTCHAR.SCALED CENTERPRINTINREGION! CURSORPOSITION! BITBLT! BITMAPBIT! BLTSHADE! DSPBACKUP! DSPBOTTOMMARGIN! DSPCLIPPINGREGION! DRAWBETWEEN! DRAWARC! DRAWCIRCLE! DRAWCURVE! DRAWELLIPSE! DRAWLINE! DRAWPOINT! DRAWPOLYGON! DRAWTO! FILLCIRCLE! FILLPOLYGON! DSPLEFTMARGIN! DSPLINEFEED! GETPOSITION! MOVETO! MOVETOUPPERLEFT! DSPRIGHTMARGIN! DSPSCALE! RELDRAWTO! RELMOVETO! SCALEDBITBLT! STRINGREGION! DSPSPACEFACTOR! DSPTRANSLATE! DSPTOPMARGIN! DSPUNITS! DSPXOFFSET! DSPXPOSITION! DSPYOFFSET! DSPYPOSITION! DSPSCALE.BRUSH DSPSCALE.POINTS DSPSCALE.REGION DSPSCALE.NUMBER DSPSCALE.POSITION DSPSCALE.XPOSITION DSPSCALE.YPOSITION DSPSCALE.WIDTH DSPUNSCALE.REGION DSPUNSCALE.POSITION DSPUNSCALE.NUMBER DSPUNSCALE.CHARACTER ) (VARS DSPSCALECOMS) previous date%: "19-Jul-88 10:00:47" |{MCS:MCS:STANFORD}DSPSCALE.;6|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT DSPSCALECOMS) (RPAQQ DSPSCALECOMS ((LOCALVARS . T) (* * SCALED ImageStream ImageOp Functions) (FNS INITSCALEDIMAGESTREAM OPENIMAGESTREAM.SCALED) (FNS \BACKCOLOR.SCALED \BITBLT.SCALED \BLTSHADE.SCALED \BOTTOMMARGIN.SCALED \BOUT.SCALED \CHARSET.SCALED \CHARWIDTH.SCALED \CHARWIDTHY.SCALED \CLIPPINGREGION.SCALED \CLOSEFN.SCALED \COLOR.SCALED \DEFAULTSTATE.SCALED \DRAWARC.SCALED \DRAWCIRCLE.SCALED \DRAWCURVE.SCALED \DRAWELLIPSE.SCALED \DRAWLINE.SCALED \DRAWPOINT.SCALED \DRAWPOLYGON.SCALED \FILLCIRCLE.SCALED \FILLPOLYGON.SCALED \FONT.SCALED \LEFTMARGIN.SCALED \LINEFEED.SCALED \MOVETO.SCALED \NEWPAGE.SCALED \OPERATION.SCALED \POPSTATE.SCALED \PUSHSTATE.SCALED \RESET.SCALED \RIGHTMARGIN.SCALED \ROTATE.SCALED \SCALE.SCALED \SCALEDBITBLT.SCALED \SPACEFACTOR.SCALED \STRINGWIDTH.SCALED \TERPRI.SCALED \TOPMARGIN.SCALED \TRANSLATE.SCALED \XPOSITION.SCALED \YPOSITION.SCALED \OUTCHAR.SCALED) (* * Self Scaling DSP* Functions) (FNS CENTERPRINTINREGION! CHARWIDTH! CHARWIDTHY! CURSORPOSITION! BITBLT! BITMAPBIT! BLTSHADE! DSPBACKUP! DSPBOTTOMMARGIN! DSPCLIPPINGREGION! DRAWBETWEEN! DRAWARC! DRAWCIRCLE! DRAWCURVE! DRAWELLIPSE! DRAWLINE! DRAWPOINT! DRAWPOLYGON! DRAWTO! FILLCIRCLE! FILLPOLYGON! FONTPROP! DSPLEFTMARGIN! DSPLINEFEED! GETPOSITION! MOVETO! MOVETOUPPERLEFT! DSPRIGHTMARGIN! DSPSCALE! RELDRAWTO! RELMOVETO! SCALEDBITBLT! STRINGREGION! STRINGWIDTH! DSPSPACEFACTOR! DSPTRANSLATE! DSPTOPMARGIN! DSPUNITS! DSPXOFFSET! DSPXPOSITION! DSPYOFFSET! DSPYPOSITION!) (* * Low Level Scaling Functions) (FNS DSPSCALE.BRUSH DSPSCALE.DASHING DSPSCALE.POINTS DSPSCALE.REGION DSPSCALE.NUMBER DSPSCALE.POSITION DSPSCALE.XPOSITION DSPSCALE.YPOSITION DSPSCALE.WIDTH DSPUNSCALE.REGION DSPUNSCALE.POSITION DSPUNSCALE.NUMBER DSPUNSCALE.CHARACTER) (MACROS DSPUNSCALE.XPOSITION DSPUNSCALE.YPOSITION) (* * etc.) (DECLARE%: DONTCOPY (RECORDS SCALEDIMAGEDATA CONVERT)) [ADDVARS (IMAGESTREAMTYPES (SCALED (OPENSTREAM OPENIMAGESTREAM.SCALED] (INITVARS \SCALEDIMAGEOPS \NULLFDEV) (GLOBALVARS \SCALEDIMAGEOPS \NULLFDEV) [INITVARS (DSPSCALE.SCRATCHBRUSH '(ROUND 1 NIL)) (DSPSCALE.SCRATCHREGION (create REGION)) (DSPSCALE.SCRATCHPOSITION (create POSITION)) (DSPSCALE.SCRATCHLIST (to 10 collect)) (DSPSCALE.SCRATCHDASHING (to 10 collect)) (DSPSCALE.SCRATCHPOINTS (to 10 collect (create POSITION] (GLOBALVARS DSPSCALE.SCRATCHBRUSH DSPSCALE.SCRATCHREGION DSPSCALE.SCRATCHPOSITION DSPSCALE.SCRATCHLIST DSPSCALE.SCRATCHDASHING DSPSCALE.SCRATCHPOINTS) (P (MOVD? 'DSPUNITS! 'DSPUNITS) (INITSCALEDIMAGESTREAM)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (* * SCALED ImageStream ImageOp Functions) (DEFINEQ (INITSCALEDIMAGESTREAM [LAMBDA NIL (* ; "Edited 19-Jul-88 10:59 by cdl") (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS)) [if (NULL \NULLFDEV) then (SETQ \NULLFDEV (create FDEV CLOSEFILE _ (FUNCTION NILL] (SETQ \SCALEDIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'SCALED IMCLOSEFN _ (FUNCTION \CLOSEFN.SCALED) IMXPOSITION _ (FUNCTION \XPOSITION.SCALED) IMYPOSITION _ (FUNCTION \YPOSITION.SCALED) IMFONT _ (FUNCTION \FONT.SCALED) IMLEFTMARGIN _ (FUNCTION \LEFTMARGIN.SCALED) IMRIGHTMARGIN _ (FUNCTION \RIGHTMARGIN.SCALED) IMLINEFEED _ (FUNCTION \LINEFEED.SCALED) IMDRAWLINE _ (FUNCTION \DRAWLINE.SCALED) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.SCALED) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.SCALED) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.SCALED) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.SCALED) IMBLTSHADE _ (FUNCTION \BLTSHADE.SCALED) IMBITBLT _ (FUNCTION \BITBLT.SCALED) IMNEWPAGE _ (FUNCTION \NEWPAGE.SCALED) IMMOVETO _ (FUNCTION \MOVETO.SCALED) IMSCALE _ (FUNCTION \SCALE.SCALED) IMTERPRI _ (FUNCTION \TERPRI.SCALED) IMTOPMARGIN _ (FUNCTION \TOPMARGIN.SCALED) IMBOTTOMMARGIN _ (FUNCTION \BOTTOMMARGIN.SCALED) IMSPACEFACTOR _ (FUNCTION \SPACEFACTOR.SCALED) IMFONTCREATE _ 'DISPLAY IMOPERATION _ (FUNCTION \OPERATION.SCALED) IMCOLOR _ (FUNCTION \COLOR.SCALED) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.SCALED) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.SCALED) IMCHARWIDTHY _ (FUNCTION \CHARWIDTHY.SCALED) IMBACKCOLOR _ (FUNCTION \BACKCOLOR.SCALED) IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.SCALED) IMRESET _ (FUNCTION \RESET.SCALED) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.SCALED) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.SCALED) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.SCALED) IMCHARSET _ (FUNCTION \CHARSET.SCALED) IMROTATE _ (FUNCTION \ROTATE.SCALED) IMDRAWARC _ (FUNCTION \DRAWARC.SCALED) IMTRANSLATE _ (FUNCTION \TRANSLATE.SCALED) IMPUSHSTATE _ (FUNCTION \PUSHSTATE.SCALED) IMPOPSTATE _ (FUNCTION \POPSTATE.SCALED) IMDEFAULTSTATE _ (FUNCTION \DEFAULTSTATE.SCALED) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.SCALED]) (OPENIMAGESTREAM.SCALED [LAMBDA (IMAGESTREAM OPTIONS) (* cdl "26-Jan-87 09:23") (* DECLARATIONS%: (RECORD PAIR  (KEY VALUE))) (LET (STREAM SCALE) [SETQ OPTIONS (for PAIR on OPTIONS by (CDDR PAIR) when (with PAIR PAIR (SELECTQ KEY (SCALE (SETQ SCALE VALUE) NIL) T)) join (with PAIR PAIR (LIST KEY VALUE] (with STREAM (SETQ STREAM (create STREAM IMAGEDATA _ (create SCALEDIMAGEDATA IMAGESTREAM _ IMAGESTREAM) IMAGEOPS _ (create IMAGEOPS IMFONTCREATE _ (with IMAGEOPS (fetch (STREAM IMAGEOPS) of IMAGESTREAM) IMFONTCREATE) reusing \SCALEDIMAGEOPS) OUTCHARFN _ (FUNCTION \OUTCHAR.SCALED) ACCESS _ 'OUTPUT DEVICE _ \NULLFDEV)) (SETQ STRMBOUTFN (FUNCTION \BOUT.SCALED))) (if SCALE then (DSPSCALE! SCALE IMAGESTREAM)) STREAM]) ) (DEFINEQ (\BACKCOLOR.SCALED [LAMBDA (STREAM COLOR) (* cdl "26-Jan-87 09:04") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMBACKCOLOR IMAGESTREAM IMAGESTREAM COLOR]) (\BITBLT.SCALED [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* cdl "26-Jan-87 10:37") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM IMAGESTREAM (DSPSCALE.XPOSITION DESTINATIONLEFT IMAGESTREAM) (DSPSCALE.YPOSITION DESTINATIONBOTTOM IMAGESTREAM) WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE (DSPSCALE.REGION CLIPPINGREGION IMAGESTREAM]) (\BLTSHADE.SCALED [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* cdl "26-Jan-87 10:05") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMBLTSHADE IMAGESTREAM TEXTURE IMAGESTREAM (DSPSCALE.XPOSITION DESTINATIONLEFT IMAGESTREAM) (DSPSCALE.YPOSITION DESTINATIONBOTTOM IMAGESTREAM) (DSPSCALE.NUMBER WIDTH IMAGESTREAM) (DSPSCALE.NUMBER HEIGHT IMAGESTREAM) OPERATION (DSPSCALE.REGION CLIPPINGREGION IMAGESTREAM]) (\BOTTOMMARGIN.SCALED [LAMBDA (STREAM YPOSITION) (* cdl "26-Jan-87 08:55") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.YPOSITION (IMAGEOP 'IMBOTTOMMARGIN IMAGESTREAM IMAGESTREAM (if YPOSITION then (DSPSCALE.YPOSITION YPOSITION IMAGESTREAM))) IMAGESTREAM]) (\BOUT.SCALED [LAMBDA (STREAM BYTE) (* cdl "26-Jan-87 08:49") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (BOUT IMAGESTREAM BYTE]) (\CHARSET.SCALED [LAMBDA (STREAM CHARACTERSET) (* cdl "26-Jan-87 08:49") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMCHARSET IMAGESTREAM IMAGESTREAM CHARACTERSET]) (\CHARWIDTH.SCALED [LAMBDA (STREAM CHARCODE) (* cdl "26-Jan-87 09:50") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.CHARACTER (IMAGEOP 'IMCHARWIDTH IMAGESTREAM IMAGESTREAM CHARCODE) (DSPFONT NIL IMAGESTREAM) IMAGESTREAM]) (\CHARWIDTHY.SCALED [LAMBDA (STREAM CHARCODE) (* cdl "26-Jan-87 10:17") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.CHARACTER (IMAGEOP 'IMCHARWIDTHY IMAGESTREAM IMAGESTREAM CHARCODE) (DSPFONT NIL IMAGESTREAM) IMAGESTREAM]) (\CLIPPINGREGION.SCALED [LAMBDA (STREAM REGION) (* cdl "26-Jan-87 09:48") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.REGION (IMAGEOP 'IMCLIPPINGREGION IMAGESTREAM IMAGESTREAM (if REGION then (DSPSCALE.REGION REGION IMAGESTREAM))) IMAGESTREAM]) (\CLOSEFN.SCALED [LAMBDA (STREAM) (* cdl "26-Jan-87 08:49") (with STREAM STREAM (PROG1 (CLOSEF (with SCALEDIMAGEDATA IMAGEDATA IMAGESTREAM)) (SETQ IMAGEDATA NIL]) (\COLOR.SCALED [LAMBDA (STREAM COLOR) (* cdl "26-Jan-87 08:57") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMCOLOR IMAGESTREAM IMAGESTREAM COLOR]) (\DEFAULTSTATE.SCALED [LAMBDA (STREAM) (* ; "Edited 19-Jul-88 08:34 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDEFAULTSTATE IMAGESTREAM IMAGESTREAM]) (\DRAWARC.SCALED [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* ; "Edited 14-Sep-87 14:30 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWARC IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION CENTERX IMAGESTREAM) (DSPSCALE.YPOSITION CENTERY IMAGESTREAM) (DSPSCALE.NUMBER RADIUS IMAGESTREAM) STARTANGLE NDEGREES (DSPSCALE.BRUSH BRUSH IMAGESTREAM) (DSPSCALE.DASHING DASHING IMAGESTREAM]) (\DRAWCIRCLE.SCALED [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* cdl "26-Jan-87 09:03") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWCIRCLE IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION CENTERX IMAGESTREAM ) (DSPSCALE.YPOSITION CENTERY IMAGESTREAM) (DSPSCALE.NUMBER RADIUS IMAGESTREAM) (DSPSCALE.BRUSH BRUSH IMAGESTREAM) (DSPSCALE.DASHING DASHING IMAGESTREAM]) (\DRAWCURVE.SCALED [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* cdl "26-Jan-87 09:36") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWCURVE IMAGESTREAM IMAGESTREAM (DSPSCALE.POINTS KNOTS IMAGESTREAM) CLOSED (DSPSCALE.BRUSH BRUSH IMAGESTREAM) (DSPSCALE.DASHING DASHING IMAGESTREAM]) (\DRAWELLIPSE.SCALED [LAMBDA (STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* cdl "26-Jan-87 09:26") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWELLIPSE IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION CENTERX IMAGESTREAM) (DSPSCALE.YPOSITION CENTERY IMAGESTREAM) (DSPSCALE.NUMBER SEMIMINORRADIUS IMAGESTREAM) (DSPSCALE.NUMBER SEMIMAJORRADIUS IMAGESTREAM) ORIENTATION (DSPSCALE.BRUSH BRUSH IMAGESTREAM) (DSPSCALE.DASHING DASHING IMAGESTREAM]) (\DRAWLINE.SCALED [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* cdl "26-Jan-87 09:41") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWLINE IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION X1 IMAGESTREAM) (DSPSCALE.YPOSITION Y1 IMAGESTREAM) (DSPSCALE.XPOSITION X2 IMAGESTREAM) (DSPSCALE.YPOSITION Y2 IMAGESTREAM) (DSPSCALE.WIDTH WIDTH IMAGESTREAM) OPERATION COLOR (DSPSCALE.DASHING DASHING IMAGESTREAM]) (\DRAWPOINT.SCALED [LAMBDA (STREAM X Y BRUSH OPERATION) (* ; "Edited 14-Sep-87 14:30 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWPOINT IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION X IMAGESTREAM) (DSPSCALE.YPOSITION Y IMAGESTREAM) (DSPSCALE.BRUSH BRUSH IMAGESTREAM) OPERATION]) (\DRAWPOLYGON.SCALED [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* cdl "26-Jan-87 09:37") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMDRAWPOLYGON IMAGESTREAM IMAGESTREAM (DSPSCALE.POINTS KNOTS IMAGESTREAM) CLOSED (DSPSCALE.BRUSH BRUSH IMAGESTREAM) (DSPSCALE.DASHING DASHING IMAGESTREAM]) (\FILLCIRCLE.SCALED [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* cdl "26-Jan-87 08:59") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMFILLCIRCLE IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION CENTERX IMAGESTREAM ) (DSPSCALE.YPOSITION CENTERY IMAGESTREAM) (DSPSCALE.NUMBER RADIUS IMAGESTREAM) TEXTURE]) (\FILLPOLYGON.SCALED [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER) (* ; "Edited 19-Jul-88 10:30 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMFILLPOLYGON IMAGESTREAM IMAGESTREAM (DSPSCALE.POINTS KNOTS IMAGESTREAM) TEXTURE OPERATION WINDNUMBER]) (\FONT.SCALED [LAMBDA (STREAM FONT) (* cdl "26-Jan-87 09:13") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMFONT IMAGESTREAM IMAGESTREAM FONT]) (\LEFTMARGIN.SCALED [LAMBDA (STREAM XPOSITION) (* cdl "26-Jan-87 08:50") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.XPOSITION (IMAGEOP 'IMLEFTMARGIN IMAGESTREAM IMAGESTREAM (if XPOSITION then (DSPSCALE.XPOSITION XPOSITION IMAGESTREAM))) IMAGESTREAM]) (\LINEFEED.SCALED [LAMBDA (STREAM DELTAY) (* cdl "26-Jan-87 09:28") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.NUMBER (IMAGEOP 'IMLINEFEED IMAGESTREAM IMAGESTREAM (if DELTAY then (DSPSCALE.NUMBER DELTAY IMAGESTREAM))) IMAGESTREAM]) (\MOVETO.SCALED [LAMBDA (STREAM X Y) (* cdl "26-Jan-87 09:30") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMMOVETO IMAGESTREAM IMAGESTREAM (DSPSCALE.XPOSITION X IMAGESTREAM) (DSPSCALE.YPOSITION Y IMAGESTREAM]) (\NEWPAGE.SCALED [LAMBDA (STREAM) (* cdl "26-Jan-87 09:10") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMNEWPAGE IMAGESTREAM IMAGESTREAM]) (\OPERATION.SCALED [LAMBDA (STREAM OPERATION) (* cdl "26-Jan-87 08:50") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMOPERATION IMAGESTREAM IMAGESTREAM OPERATION]) (\POPSTATE.SCALED [LAMBDA (STREAM) (* ; "Edited 19-Jul-88 08:32 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMPOPSTATE IMAGESTREAM IMAGESTREAM]) (\PUSHSTATE.SCALED [LAMBDA (STREAM) (* ; "Edited 19-Jul-88 08:31 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMPUSHSTATE IMAGESTREAM IMAGESTREAM]) (\RESET.SCALED [LAMBDA (STREAM) (* cdl "26-Jan-87 09:09") (with STREAM STREAM (SETQ CHARPOSITION 0) (with SCALEDIMAGEDATA IMAGEDATA (IMAGEOP 'IMRESET IMAGESTREAM IMAGESTREAM]) (\RIGHTMARGIN.SCALED [LAMBDA (STREAM XPOSITION) (* cdl "26-Jan-87 08:50") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.XPOSITION (IMAGEOP 'IMRIGHTMARGIN IMAGESTREAM IMAGESTREAM (if XPOSITION then (DSPSCALE.XPOSITION XPOSITION IMAGESTREAM))) IMAGESTREAM]) (\ROTATE.SCALED [LAMBDA (STREAM ROTATION) (* ; "Edited 14-Sep-87 14:22 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMROTATE IMAGESTREAM IMAGESTREAM ROTATION]) (\SCALE.SCALED [LAMBDA (STREAM SCALE) (* cdl "26-Jan-87 09:34") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (if SCALE then (DSPSCALE! SCALE IMAGESTREAM) else (IMAGEOP 'IMSCALE IMAGESTREAM IMAGESTREAM]) (\SCALEDBITBLT.SCALED [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SCALE) (* cdl "26-Jan-87 10:38") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (SCALEDBITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM IMAGESTREAM (DSPSCALE.XPOSITION DESTINATIONLEFT IMAGESTREAM) (DSPSCALE.YPOSITION DESTINATIONBOTTOM IMAGESTREAM) WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE (DSPSCALE.REGION CLIPPINGREGION IMAGESTREAM) SCALE]) (\SPACEFACTOR.SCALED [LAMBDA (STREAM FACTOR) (* cdl "26-Jan-87 09:46") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.NUMBER (IMAGEOP 'IMSPACEFACTOR IMAGESTREAM IMAGESTREAM (if FACTOR then (DSPSCALE.NUMBER FACTOR IMAGESTREAM))) IMAGESTREAM]) (\STRINGWIDTH.SCALED [LAMBDA (STREAM STRING RDTBL) (* cdl "26-Jan-87 09:45") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.CHARACTER (IMAGEOP 'IMSTRINGWIDTH IMAGESTREAM IMAGESTREAM STRING RDTBL) (DSPFONT NIL IMAGESTREAM) IMAGESTREAM]) (\TERPRI.SCALED [LAMBDA (STREAM) (* cdl "26-Jan-87 09:06") (with STREAM STREAM (SETQ CHARPOSITION 0) (with SCALEDIMAGEDATA IMAGEDATA (IMAGEOP 'IMTERPRI IMAGESTREAM IMAGESTREAM]) (\TOPMARGIN.SCALED [LAMBDA (STREAM YPOSITION) (* cdl "26-Jan-87 08:54") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.YPOSITION (IMAGEOP 'IMTOPMARGIN IMAGESTREAM IMAGESTREAM (if YPOSITION then (DSPSCALE.YPOSITION YPOSITION IMAGESTREAM))) IMAGESTREAM]) (\TRANSLATE.SCALED [LAMBDA (STREAM Tx Ty) (* ; "Edited 19-Jul-88 13:32 by cdl") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (STREAMPROP IMAGESTREAM 'TRANSLATE (CREATEPOSITION (DSPSCALE.NUMBER Tx STREAM) (DSPSCALE.NUMBER Ty STREAM]) (\XPOSITION.SCALED [LAMBDA (STREAM XPOSITION) (* cdl "26-Jan-87 08:51") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.XPOSITION (IMAGEOP 'IMXPOSITION IMAGESTREAM IMAGESTREAM (if XPOSITION then (DSPSCALE.XPOSITION XPOSITION IMAGESTREAM))) IMAGESTREAM]) (\YPOSITION.SCALED [LAMBDA (STREAM YPOSITION) (* cdl "26-Jan-87 08:51") (with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA) (DSPUNSCALE.YPOSITION (IMAGEOP 'IMYPOSITION IMAGESTREAM IMAGESTREAM (if YPOSITION then (DSPSCALE.YPOSITION YPOSITION IMAGESTREAM))) IMAGESTREAM]) (\OUTCHAR.SCALED [LAMBDA (STREAM CHARCODE) (* cdl "26-Jan-87 10:20") [if (EQ CHARCODE (CHARCODE EOL)) then (with STREAM STREAM (SETQ CHARPOSITION 0)) else (freplace CHARPOSITION of STREAM with (\LOLOC (\ADDBASE (ffetch CHARPOSITION of STREAM) 1] (BOUT STREAM CHARCODE]) ) (* * Self Scaling DSP* Functions) (DEFINEQ (CENTERPRINTINREGION! [LAMBDA (EXP REGION STREAM) (* cdl "29-Jul-85 12:09") (CENTERPRINTINREGION EXP (if REGION then (DSPSCALE.REGION REGION STREAM)) STREAM]) (CHARWIDTH! [LAMBDA (CHARCODE FONT STREAM) (* ; "Edited 19-Jul-88 13:16 by cdl") (DSPUNSCALE.CHARACTER (CHARWIDTH CHARCODE FONT) FONT (OR STREAM (IMAGESTREAMP FONT]) (CHARWIDTHY! [LAMBDA (CHARCODE FONT STREAM) (* ; "Edited 19-Jul-88 13:16 by cdl") (DSPUNSCALE.CHARACTER (CHARWIDTHY CHARCODE FONT) FONT (OR STREAM (IMAGESTREAMP FONT]) (CURSORPOSITION! [LAMBDA (NEWPOSITION STREAM OLDPOSITION) (* cdl "30-Oct-85 08:15") (DSPUNSCALE.POSITION (CURSORPOSITION (if NEWPOSITION then (DSPSCALE.POSITION NEWPOSITION STREAM OLDPOSITION)) STREAM OLDPOSITION) STREAM OLDPOSITION]) (BITBLT! [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* cdl "29-Jul-85 12:09") (BITBLT SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION (DSPSCALE.XPOSITION DESTINATIONLEFT DESTINATION) (DSPSCALE.YPOSITION DESTINATIONBOTTOM DESTINATION) WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE (DSPSCALE.REGION CLIPPINGREGION DESTINATION]) (BITMAPBIT! [LAMBDA (STREAM X Y NEWVALUE) (* cdl "29-Jul-85 12:01") (BITMAPBIT STREAM (DSPSCALE.XPOSITION X STREAM) (DSPSCALE.YPOSITION Y STREAM) NEWVALUE]) (BLTSHADE! [LAMBDA (TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* cdl "29-Jul-85 12:02") (BLTSHADE TEXTURE DESTINATION (DSPSCALE.XPOSITION DESTINATIONLEFT DESTINATION) (DSPSCALE.YPOSITION DESTINATIONBOTTOM DESTINATION) (DSPSCALE.NUMBER WIDTH DESTINATION) (DSPSCALE.NUMBER HEIGHT DESTINATION) OPERATION (DSPSCALE.REGION CLIPPINGREGION DESTINATION]) (DSPBACKUP! [LAMBDA (WIDTH DISPLAYSTREAM) (* cdl "29-Jul-85 12:02") (DSPBACKUP (if WIDTH then (DSPSCALE.XPOSITION WIDTH DISPLAYSTREAM)) DISPLAYSTREAM]) (DSPBOTTOMMARGIN! [LAMBDA (YPOSITION STREAM) (* cdl "29-Jul-85 12:02") (DSPUNSCALE.YPOSITION (DSPBOTTOMMARGIN (if YPOSITION then (DSPSCALE.YPOSITION YPOSITION STREAM)) STREAM) STREAM]) (DSPCLIPPINGREGION! [LAMBDA (REGION STREAM) (* cdl "29-Jul-85 08:41") (DSPUNSCALE.REGION (DSPCLIPPINGREGION (if REGION then (DSPSCALE.REGION REGION STREAM)) STREAM) STREAM]) (DRAWBETWEEN! [LAMBDA (PT1 PT2 WIDTH OPERATION STREAM COLOR DASHING) (* cdl "29-Oct-85 15:30") (DRAWBETWEEN (DSPSCALE.POSITION PT1 STREAM (CAR DSPSCALE.SCRATCHPOINTS)) (DSPSCALE.POSITION PT2 STREAM (CADR DSPSCALE.SCRATCHPOINTS)) (DSPSCALE.WIDTH WIDTH STREAM) OPERATION STREAM COLOR (DSPSCALE.DASHING DASHING STREAM]) (DRAWARC! [LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING STREAM) (* ; "Edited 14-Sep-87 14:34 by cdl") (DRAWARC (DSPSCALE.XPOSITION CENTERX STREAM) (DSPSCALE.YPOSITION CENTERY STREAM) (DSPSCALE.NUMBER RADIUS STREAM) STARTANGLE NDEGREES (DSPSCALE.BRUSH BRUSH STREAM) (DSPSCALE.DASHING DASHING STREAM) STREAM]) (DRAWCIRCLE! [LAMBDA (CENTERX CENTERY RADIUS BRUSH DASHING STREAM) (* cdl "29-Jul-85 12:03") (DRAWCIRCLE (DSPSCALE.XPOSITION CENTERX STREAM) (DSPSCALE.YPOSITION CENTERY STREAM) (DSPSCALE.NUMBER RADIUS STREAM) (DSPSCALE.BRUSH BRUSH STREAM) (DSPSCALE.DASHING DASHING STREAM) STREAM]) (DRAWCURVE! [LAMBDA (KNOTS CLOSED BRUSH DASHING STREAM) (* cdl "29-Jul-85 10:04") (DRAWCURVE (DSPSCALE.POINTS KNOTS STREAM) CLOSED (DSPSCALE.BRUSH BRUSH STREAM) (DSPSCALE.DASHING DASHING STREAM) STREAM]) (DRAWELLIPSE! [LAMBDA (CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING STREAM) (* cdl "29-Jul-85 12:03") (DRAWELLIPSE (DSPSCALE.XPOSITION CENTERX STREAM) (DSPSCALE.YPOSITION CENTERY STREAM) (DSPSCALE.NUMBER SEMIMINORRADIUS STREAM) (DSPSCALE.NUMBER SEMIMAJORRADIUS STREAM) ORIENTATION (DSPSCALE.BRUSH BRUSH STREAM) (DSPSCALE.DASHING DASHING STREAM) STREAM]) (DRAWLINE! [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING) (* cdl "29-Oct-85 15:28") (DRAWLINE (DSPSCALE.XPOSITION X1 STREAM) (DSPSCALE.YPOSITION Y1 STREAM) (DSPSCALE.XPOSITION X2 STREAM) (DSPSCALE.YPOSITION Y2 STREAM) (DSPSCALE.WIDTH WIDTH STREAM) OPERATION STREAM COLOR (DSPSCALE.DASHING DASHING STREAM]) (DRAWPOINT! [LAMBDA (X Y BRUSH STREAM OPERATION) (* ; "Edited 14-Sep-87 14:36 by cdl") (DRAWPOINT (DSPSCALE.XPOSITION X STREAM) (DSPSCALE.YPOSITION Y STREAM) (DSPSCALE.BRUSH BRUSH STREAM) STREAM OPERATION]) (DRAWPOLYGON! [LAMBDA (POINTS CLOSED BRUSH DASHING STREAM) (* cdl "29-Jul-85 10:05") (DRAWPOLYGON (DSPSCALE.POINTS POINTS STREAM) CLOSED (DSPSCALE.BRUSH BRUSH STREAM) (DSPSCALE.DASHING DASHING STREAM) STREAM]) (DRAWTO! [LAMBDA (X Y WIDTH OPERATION STREAM COLOR DASHING) (* cdl "29-Oct-85 15:31") (DRAWTO (DSPSCALE.XPOSITION X STREAM) (DSPSCALE.YPOSITION Y STREAM) (DSPSCALE.WIDTH WIDTH STREAM) OPERATION STREAM COLOR (DSPSCALE.DASHING DASHING STREAM]) (FILLCIRCLE! [LAMBDA (CENTERX CENTERY RADIUS TEXTURE STREAM) (* cdl " 7-Feb-86 15:02") (FILLCIRCLE (DSPSCALE.XPOSITION CENTERX STREAM) (DSPSCALE.YPOSITION CENTERY STREAM) (DSPSCALE.NUMBER RADIUS STREAM) TEXTURE STREAM]) (FILLPOLYGON! [LAMBDA (KNOTS TEXTURE STREAM) (* cdl "30-Oct-85 07:44") (FILLPOLYGON (DSPSCALE.POINTS KNOTS STREAM) TEXTURE STREAM]) (FONTPROP! [LAMBDA (FONT PROP STREAM) (* ; "Edited 19-Jul-88 13:18 by cdl") (SELECTQ PROP ((ASCENT DESCENT HEIGHT) (DSPUNSCALE.CHARACTER (FONTPROP FONT PROP) FONT (OR STREAM (IMAGESTREAMP FONT)))) (FONTPROP FONT PROP]) (DSPLEFTMARGIN! [LAMBDA (XPOSITION STREAM) (* cdl "29-Jul-85 12:05") (DSPUNSCALE.XPOSITION (DSPLEFTMARGIN (if XPOSITION then (DSPSCALE.XPOSITION XPOSITION STREAM)) STREAM) STREAM]) (DSPLINEFEED! [LAMBDA (DELTAY STREAM) (* cdl "29-Jul-85 11:11") (DSPUNSCALE.NUMBER (DSPLINEFEED (if DELTAY then (DSPSCALE.NUMBER DELTAY STREAM)) STREAM) STREAM]) (GETPOSITION! [LAMBDA (STREAM CURSOR) (* cdl "30-Oct-85 08:03") (DSPUNSCALE.POSITION (GETPOSITION STREAM CURSOR) STREAM]) (MOVETO! [LAMBDA (X Y STREAM) (* cdl "29-Jul-85 12:06") (MOVETO (DSPSCALE.XPOSITION X STREAM) (DSPSCALE.YPOSITION Y STREAM) STREAM]) (MOVETOUPPERLEFT! [LAMBDA (WINDOW REGION) (* cdl "29-Jul-85 12:10") (MOVETOUPPERLEFT WINDOW (if REGION then (DSPSCALE.REGION REGION WINDOW]) (DSPRIGHTMARGIN! [LAMBDA (XPOSITION STREAM) (* cdl "16-Oct-85 16:11") (DSPUNSCALE.XPOSITION (DSPRIGHTMARGIN (if XPOSITION then (DSPSCALE.XPOSITION XPOSITION STREAM)) STREAM) STREAM]) (DSPSCALE! [LAMBDA (SCALE STREAM) (* cdl "23-Apr-86 09:40") (if (NOT (type? STREAM STREAM)) then (SETQ STREAM (GETSTREAM STREAM))) (PROG1 (OR (STREAMPROP STREAM 'SCALE) (DSPSCALE NIL STREAM)) [if SCALE then (STREAMPROP STREAM 'SCALE SCALE) (STREAMPROP STREAM 'SCALED T) (LET [(RATIO (STREAMPROP STREAM 'RATIO] [if (NULL RATIO) then (STREAMPROP STREAM 'RATIO (SETQ RATIO (create CONVERT SOURCE _ 1] (with CONVERT RATIO (SETQ DESTINATION (TIMES SCALE (DSPSCALE NIL STREAM])]) (RELDRAWTO! [LAMBDA (DX DY WIDTH OPERATION STREAM COLOR DASHING) (* cdl "29-Oct-85 15:31") (RELDRAWTO (DSPSCALE.NUMBER DX STREAM) (DSPSCALE.NUMBER DY STREAM) (DSPSCALE.WIDTH WIDTH STREAM) OPERATION STREAM COLOR (DSPSCALE.DASHING DASHING STREAM]) (RELMOVETO! [LAMBDA (DX DY STREAM) (* cdl "30-Oct-85 07:43") (RELMOVETO (DSPSCALE.NUMBER DX STREAM) (DSPSCALE.NUMBER DY STREAM) STREAM]) (SCALEDBITBLT! [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SCALE) (* cdl "29-Jul-85 12:13") (SCALEDBITBLT SOURCELEFT SOURCEBOTTOM DESTINATION (DSPSCALE.XPOSITION DESTINATIONLEFT DESTINATION) (DSPSCALE.YPOSITION DESTINATIONBOTTOM DESTINATION) WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE (DSPSCALE.REGION CLIPPINGREGION DESTINATION) SCALE]) (STRINGREGION! [LAMBDA (STR STREAM PRIN2FLG RDTBL) (* cdl " 2-May-86 14:05") (LET ((REGION (STRINGREGION STR STREAM PRIN2FLG RDTBL))) (DSPUNSCALE.REGION REGION STREAM REGION]) (STRINGWIDTH! [LAMBDA (STR FONT FLG RDTBL STREAM) (* ; "Edited 19-Jul-88 13:18 by cdl") (DSPUNSCALE.CHARACTER (STRINGWIDTH STR FONT FLG RDTBL) FONT (OR STREAM (IMAGESTREAMP FONT]) (DSPSPACEFACTOR! [LAMBDA (FACTOR STREAM) (* cdl "29-Jul-85 11:12") (DSPUNSCALE.NUMBER (DSPSPACEFACTOR (if FACTOR then (DSPSCALE.NUMBER FACTOR STREAM)) STREAM) STREAM]) (DSPTRANSLATE! [LAMBDA (Tx.OR.POSITION Ty.OR.STREAM STREAM.OR.NIL) (* ; "Edited 19-Jul-88 09:03 by cdl") (if (POSITIONP Tx.OR.POSITION) then (* Koto Compatibility) (STREAMPROP (GETSTREAM Ty.OR.STREAM) 'TRANSLATE Tx.OR.POSITION) else (STREAMPROP (GETSTREAM STREAM.OR.NIL) 'TRANSLATE (CREATEPOSITION Tx.OR.POSITION Ty.OR.STREAM]) (DSPTOPMARGIN! [LAMBDA (YPOSITION STREAM) (* cdl "29-Jul-85 12:00") (DSPUNSCALE.YPOSITION (DSPTOPMARGIN (if YPOSITION then (DSPSCALE.YPOSITION YPOSITION STREAM)) STREAM) STREAM]) (DSPUNITS! [LAMBDA (UNITS STREAM) (* cdl "23-Apr-86 09:40") (if (NOT (type? STREAM STREAM)) then (SETQ STREAM (GETSTREAM STREAM))) (PROG1 (STREAMPROP STREAM 'UNITS) [if UNITS then (STREAMPROP STREAM 'UNITS UNITS) (STREAMPROP STREAM 'SCALED T) (LET [(RATIO (STREAMPROP STREAM 'RATIO] [if (NULL RATIO) then (STREAMPROP STREAM 'RATIO (SETQ RATIO (create CONVERT DESTINATION _ 1] (with CONVERT RATIO (SETQ SOURCE UNITS])]) (DSPXOFFSET! [LAMBDA (XOFFSET DISPLAYSTREAM) (* cdl "29-Jul-85 11:12") (DSPUNSCALE.NUMBER (DSPXOFFSET (if XOFFSET then (DSPSCALE.NUMBER XOFFSET DISPLAYSTREAM)) DISPLAYSTREAM) DISPLAYSTREAM]) (DSPXPOSITION! [LAMBDA (XPOSITION STREAM) (* cdl "29-Jul-85 12:00") (DSPUNSCALE.XPOSITION (DSPXPOSITION (if XPOSITION then (DSPSCALE.XPOSITION XPOSITION STREAM)) STREAM) STREAM]) (DSPYOFFSET! [LAMBDA (YOFFSET DISPLAYSTREAM) (* cdl "29-Jul-85 11:59") (DSPUNSCALE.NUMBER (DSPYOFFSET (if YOFFSET then (DSPSCALE.NUMBER YOFFSET DISPLAYSTREAM)) DISPLAYSTREAM) DISPLAYSTREAM]) (DSPYPOSITION! [LAMBDA (YPOSITION STREAM) (* cdl "29-Jul-85 11:59") (DSPUNSCALE.YPOSITION (DSPYPOSITION (if YPOSITION then (DSPSCALE.YPOSITION YPOSITION STREAM)) STREAM) STREAM]) ) (* * Low Level Scaling Functions) (DEFINEQ (DSPSCALE.BRUSH [LAMBDA (BRUSH STREAM) (* cdl "29-Oct-85 15:29") (if (NULL BRUSH) then (create BRUSH BRUSHSHAPE _ 'ROUND BRUSHSIZE _ (DSPSCALE.WIDTH 1 STREAM) smashing DSPSCALE.SCRATCHBRUSH) elseif (LISTP BRUSH) then (with BRUSH BRUSH (create BRUSH BRUSHCOLOR _ BRUSHCOLOR BRUSHSHAPE _ BRUSHSHAPE BRUSHSIZE _ (DSPSCALE.WIDTH BRUSHSIZE STREAM) smashing DSPSCALE.SCRATCHBRUSH)) elseif (NUMBERP BRUSH) then (DSPSCALE.WIDTH BRUSH STREAM) else BRUSH]) (DSPSCALE.DASHING [LAMBDA (DASHING STREAM) (* ; "Edited 19-Jul-88 10:21 by cdl") (if (LISTP DASHING) then [SCRATCHLIST DSPSCALE.SCRATCHDASHING (for WIDTH in DASHING do (ADDTOSCRATCHLIST (DSPSCALE.WIDTH WIDTH STREAM] elseif (NUMBERP DASHING) then (DSPSCALE.WIDTH DASHING STREAM) else DASHING]) (DSPSCALE.POINTS [LAMBDA (KNOTS STREAM) (* ; "Edited 19-Jul-88 09:52 by cdl") (SCRATCHLIST DSPSCALE.SCRATCHLIST (bind (KNOTSLST _ DSPSCALE.SCRATCHPOINTS) for KNOT in KNOTS do (ADDTOSCRATCHLIST (DSPSCALE.POSITION KNOT STREAM (if KNOTSLST then (pop KNOTSLST) else (push DSPSCALE.SCRATCHPOINTS (create POSITION) ) (CAR DSPSCALE.SCRATCHPOINTS]) (DSPSCALE.REGION [LAMBDA (REGION STREAM SMASH) (* cdl "28-Oct-85 09:00") (if (type? REGION REGION) then (with REGION REGION (create REGION LEFT _ (DSPSCALE.XPOSITION LEFT STREAM) BOTTOM _ (DSPSCALE.YPOSITION BOTTOM STREAM) WIDTH _ (DSPSCALE.NUMBER WIDTH STREAM) HEIGHT _ (DSPSCALE.NUMBER HEIGHT STREAM) smashing (OR SMASH DSPSCALE.SCRATCHREGION))) else REGION]) (DSPSCALE.NUMBER [LAMBDA (VALUE STREAM) (* cdl "23-Apr-86 09:10") (if (NUMBERP VALUE) then (if (NOT (type? STREAM STREAM)) then (SETQ STREAM (GETSTREAM STREAM))) (if [FLOATP (SETQ VALUE (if (GETSTREAMPROP STREAM 'SCALED) then (with CONVERT (GETSTREAMPROP STREAM 'RATIO) (QUOTIENT (TIMES VALUE DESTINATION) SOURCE)) else (TIMES (IMAGEOP 'IMSCALE STREAM STREAM) VALUE] then (FIXR VALUE) else VALUE) else VALUE]) (DSPSCALE.POSITION [LAMBDA (POSITION STREAM SMASH) (* cdl "29-Jul-85 11:57") (with POSITION POSITION (create POSITION XCOORD _ (DSPSCALE.XPOSITION XCOORD STREAM) YCOORD _ (DSPSCALE.YPOSITION YCOORD STREAM) smashing (OR SMASH DSPSCALE.SCRATCHPOSITION]) (DSPSCALE.XPOSITION [LAMBDA (VALUE STREAM) (* cdl " 1-Nov-85 08:47") (if (NUMBERP VALUE) then (if (NOT (type? STREAM STREAM)) then (SETQ STREAM (GETSTREAM STREAM))) [LET [(TRANSLATE (GETSTREAMPROP STREAM 'TRANSLATE] (if TRANSLATE then (with POSITION TRANSLATE (add VALUE XCOORD] (DSPSCALE.NUMBER VALUE STREAM) else VALUE]) (DSPSCALE.YPOSITION [LAMBDA (VALUE STREAM) (* cdl " 1-Nov-85 08:47") (if (NUMBERP VALUE) then (if (NOT (type? STREAM STREAM)) then (SETQ STREAM (GETSTREAM STREAM))) [LET [(TRANSLATE (GETSTREAMPROP STREAM 'TRANSLATE] (if TRANSLATE then (with POSITION TRANSLATE (add VALUE YCOORD] (DSPSCALE.NUMBER VALUE STREAM) else VALUE]) (DSPSCALE.WIDTH [LAMBDA (WIDTH STREAM) (* cdl "29-Oct-85 15:27") (if (ZEROP (SETQ WIDTH (DSPSCALE.NUMBER WIDTH STREAM))) then 1 else WIDTH]) (DSPUNSCALE.REGION [LAMBDA (REGION STREAM SMASH) (* cdl " 2-May-86 14:04") (if (type? REGION REGION) then (with REGION REGION (create REGION LEFT _ (DSPUNSCALE.XPOSITION LEFT STREAM) BOTTOM _ (DSPUNSCALE.YPOSITION BOTTOM STREAM) WIDTH _ (DSPUNSCALE.NUMBER WIDTH STREAM) HEIGHT _ (DSPUNSCALE.NUMBER HEIGHT STREAM) smashing (OR SMASH DSPSCALE.SCRATCHREGION))) else REGION]) (DSPUNSCALE.POSITION [LAMBDA (POSITION STREAM SMASH) (* cdl "17-Sep-85 14:21") (with POSITION POSITION (create POSITION XCOORD _ (DSPUNSCALE.XPOSITION XCOORD STREAM) YCOORD _ (DSPUNSCALE.YPOSITION YCOORD STREAM) smashing (OR SMASH DSPSCALE.SCRATCHPOSITION]) (DSPUNSCALE.NUMBER [LAMBDA (VALUE STREAM OFFSET) (* cdl "27-Jan-87 11:32") (if (NUMBERP VALUE) then (if (NOT (type? STREAM STREAM)) then (SETQ STREAM (GETSTREAM STREAM))) [SETQ VALUE (if (GETSTREAMPROP STREAM 'SCALED) then (with CONVERT (GETSTREAMPROP STREAM 'RATIO) (QUOTIENT (TIMES VALUE SOURCE) DESTINATION)) else (QUOTIENT VALUE (IMAGEOP 'IMSCALE STREAM STREAM] [if OFFSET then (LET [(TRANSLATE (GETSTREAMPROP STREAM 'TRANSLATE] (if TRANSLATE then (with POSITION TRANSLATE (SELECTQ OFFSET (X (SETQ VALUE (DIFFERENCE VALUE XCOORD))) (Y (SETQ VALUE (DIFFERENCE VALUE YCOORD))) NIL] (if (FLOATP VALUE) then (FIXR VALUE) else VALUE) else VALUE]) (DSPUNSCALE.CHARACTER [LAMBDA (WIDTH FONT STREAM) (* cdl "23-Apr-86 09:11") (LET (CONVERT VALUE) (if (NUMBERP WIDTH) then (if [FLOATP (SETQ VALUE (if (AND STREAM (OR (type? STREAM STREAM) (SETQ STREAM (GETSTREAM STREAM))) (GETSTREAMPROP STREAM 'SCALED)) then (with CONVERT (GETSTREAMPROP STREAM 'RATIO) (QUOTIENT (TIMES WIDTH SOURCE) DESTINATION)) else (QUOTIENT WIDTH (OR (with FONTDESCRIPTOR FONT FONTSCALE) (IMAGEOP 'IMSCALE STREAM STREAM] then (FIXR VALUE) else VALUE) else WIDTH]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS DSPUNSCALE.XPOSITION MACRO ((VALUE STREAM) (DSPUNSCALE.NUMBER VALUE STREAM 'X] [PUTPROPS DSPUNSCALE.YPOSITION MACRO ((VALUE STREAM) (DSPUNSCALE.NUMBER VALUE STREAM 'Y] ) (* * etc.) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SCALEDIMAGEDATA (IMAGESTREAM)) (RECORD CONVERT (SOURCE . DESTINATION)) ) ) (ADDTOVAR IMAGESTREAMTYPES (SCALED (OPENSTREAM OPENIMAGESTREAM.SCALED))) (RPAQ? \SCALEDIMAGEOPS NIL) (RPAQ? \NULLFDEV NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SCALEDIMAGEOPS \NULLFDEV) ) (RPAQ? DSPSCALE.SCRATCHBRUSH '(ROUND 1 NIL)) (RPAQ? DSPSCALE.SCRATCHREGION (create REGION)) (RPAQ? DSPSCALE.SCRATCHPOSITION (create POSITION)) (RPAQ? DSPSCALE.SCRATCHLIST (to 10 collect)) (RPAQ? DSPSCALE.SCRATCHDASHING (to 10 collect)) (RPAQ? DSPSCALE.SCRATCHPOINTS (to 10 collect (create POSITION))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DSPSCALE.SCRATCHBRUSH DSPSCALE.SCRATCHREGION DSPSCALE.SCRATCHPOSITION DSPSCALE.SCRATCHLIST DSPSCALE.SCRATCHDASHING DSPSCALE.SCRATCHPOINTS) ) (MOVD? 'DSPUNITS! 'DSPUNITS) (INITSCALEDIMAGESTREAM) (PUTPROPS DSPSCALE COPYRIGHT ("Stanford University" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5589 11142 (INITSCALEDIMAGESTREAM 5599 . 9099) (OPENIMAGESTREAM.SCALED 9101 . 11140)) ( 11143 28693 (\BACKCOLOR.SCALED 11153 . 11396) (\BITBLT.SCALED 11398 . 12265) (\BLTSHADE.SCALED 12267 . 13022) (\BOTTOMMARGIN.SCALED 13024 . 13479) (\BOUT.SCALED 13481 . 13690) (\CHARSET.SCALED 13692 . 13938) (\CHARWIDTH.SCALED 13940 . 14287) (\CHARWIDTHY.SCALED 14289 . 14638) (\CLIPPINGREGION.SCALED 14640 . 15093) (\CLOSEFN.SCALED 15095 . 15356) (\COLOR.SCALED 15358 . 15593) (\DEFAULTSTATE.SCALED 15595 . 15850) (\DRAWARC.SCALED 15852 . 16481) (\DRAWCIRCLE.SCALED 16483 . 17072) (\DRAWCURVE.SCALED 17074 . 17493) (\DRAWELLIPSE.SCALED 17495 . 18291) (\DRAWLINE.SCALED 18293 . 18940) (\DRAWPOINT.SCALED 18942 . 19372) (\DRAWPOLYGON.SCALED 19374 . 19797) (\FILLCIRCLE.SCALED 19799 . 20297) ( \FILLPOLYGON.SCALED 20299 . 20639) (\FONT.SCALED 20641 . 20873) (\LEFTMARGIN.SCALED 20875 . 21326) ( \LINEFEED.SCALED 21328 . 21769) (\MOVETO.SCALED 21771 . 22097) (\NEWPAGE.SCALED 22099 . 22332) ( \OPERATION.SCALED 22334 . 22581) (\POPSTATE.SCALED 22583 . 22830) (\PUSHSTATE.SCALED 22832 . 23081) ( \RESET.SCALED 23083 . 23333) (\RIGHTMARGIN.SCALED 23335 . 23788) (\ROTATE.SCALED 23790 . 24042) ( \SCALE.SCALED 24044 . 24367) (\SCALEDBITBLT.SCALED 24369 . 25278) (\SPACEFACTOR.SCALED 25280 . 25727) (\STRINGWIDTH.SCALED 25729 . 26084) (\TERPRI.SCALED 26086 . 26338) (\TOPMARGIN.SCALED 26340 . 26789) ( \TRANSLATE.SCALED 26791 . 27161) (\XPOSITION.SCALED 27163 . 27612) (\YPOSITION.SCALED 27614 . 28063) ( \OUTCHAR.SCALED 28065 . 28691)) (28734 43771 (CENTERPRINTINREGION! 28744 . 29003) (CHARWIDTH! 29005 . 29238) (CHARWIDTHY! 29240 . 29475) (CURSORPOSITION! 29477 . 29921) (BITBLT! 29923 . 30533) (BITMAPBIT! 30535 . 30764) (BLTSHADE! 30766 . 31298) (DSPBACKUP! 31300 . 31536) (DSPBOTTOMMARGIN! 31538 . 31871) (DSPCLIPPINGREGION! 31873 . 32206) (DRAWBETWEEN! 32208 . 32591) (DRAWARC! 32593 . 33074) (DRAWCIRCLE! 33076 . 33451) (DRAWCURVE! 33453 . 33741) (DRAWELLIPSE! 33743 . 34305) (DRAWLINE! 34307 . 34782) ( DRAWPOINT! 34784 . 35071) (DRAWPOLYGON! 35073 . 35366) (DRAWTO! 35368 . 35680) (FILLCIRCLE! 35682 . 35971) (FILLPOLYGON! 35973 . 36161) (FONTPROP! 36163 . 36501) (DSPLEFTMARGIN! 36503 . 36830) ( DSPLINEFEED! 36832 . 37147) (GETPOSITION! 37149 . 37334) (MOVETO! 37336 . 37550) (MOVETOUPPERLEFT! 37552 . 37785) (DSPRIGHTMARGIN! 37787 . 38117) (DSPSCALE! 38119 . 38915) (RELDRAWTO! 38917 . 39231) ( RELMOVETO! 39233 . 39449) (SCALEDBITBLT! 39451 . 40089) (STRINGREGION! 40091 . 40316) (STRINGWIDTH! 40318 . 40560) (DSPSPACEFACTOR! 40562 . 40886) (DSPTRANSLATE! 40888 . 41389) (DSPTOPMARGIN! 41391 . 41715) (DSPUNITS! 41717 . 42443) (DSPXOFFSET! 42445 . 42780) (DSPXPOSITION! 42782 . 43106) ( DSPYOFFSET! 43108 . 43443) (DSPYPOSITION! 43445 . 43769)) (43812 53676 (DSPSCALE.BRUSH 43822 . 44648) (DSPSCALE.DASHING 44650 . 45198) (DSPSCALE.POINTS 45200 . 46255) (DSPSCALE.REGION 46257 . 46955) ( DSPSCALE.NUMBER 46957 . 47912) (DSPSCALE.POSITION 47914 . 48339) (DSPSCALE.XPOSITION 48341 . 48862) ( DSPSCALE.YPOSITION 48864 . 49385) (DSPSCALE.WIDTH 49387 . 49607) (DSPUNSCALE.REGION 49609 . 50309) ( DSPUNSCALE.POSITION 50311 . 50734) (DSPUNSCALE.NUMBER 50736 . 52070) (DSPUNSCALE.CHARACTER 52072 . 53674))))) STOP \ No newline at end of file diff --git a/lispusers/DSPSCALE.TEDIT b/lispusers/DSPSCALE.TEDIT new file mode 100644 index 00000000..591b206c Binary files /dev/null and b/lispusers/DSPSCALE.TEDIT differ diff --git a/lispusers/DUMPER b/lispusers/DUMPER new file mode 100644 index 00000000..b8bb895a --- /dev/null +++ b/lispusers/DUMPER @@ -0,0 +1 @@ +(FILECREATED "25-Mar-86 13:22:34" {LOGOS:AFB:SIP}LISP>DUMPER.;10 8672 changes to: (FNS DUMP.DUMP DUMP.DIRECTORY DUMP DUMP.LOG.FILENAME DUMP.NEW.FILENAME DUMP.DIRECTORIES) (VARS DUMPERCOMS) previous date: "24-Mar-86 21:40:40" {LOGOS:AFB:SIP}LISP>DUMPER.;7) (* Copyright (c) 1986, 1901 by Speech Input Project, Univ. of Edinburgh. All rights reserved.) (PRETTYCOMPRINT DUMPERCOMS) (RPAQQ DUMPERCOMS ((FNS DUMP DUMP.DUMP DUMP.NEW.FILENAME DUMP.DIRECTORIES DUMP.DIRECTORY DUMP.GENERATE.NEWERTHAN DUMP.NVERSIONS) (INITVARS (DUMP.IGNORE.DIRS '(FONTS CLEARINGHOUSE SYSTEMFILES DESKTOPS)) (DUMP.IGNORE.SPECS '(*.DCOM;* *.SYSOUT;*)) (DUMP.DIRECTORY.SEPARATOR "\")))) (DEFINEQ (DUMP [LAMBDA (HOST TO.DIRECTORY LOG.FILE NEWERTHAN NVERSIONS) (* drc: "25-Mar-86 12:43") (* * Will dump all files on NS file server HOST which are newer than NEWERTHAN, a date string, with a maximum of  NVERSIONS of a particular file being dumped to TO.DIRECTORY. If NEWERTHAN is NIL than all versions written since  (GDATE 0) will be dumped. If NVERSIONS is NIL then all versions will be dumped. A log file will be written to a  file w/ name specified by DUMP.LOG.FILENAME. Returns the log file name.) (DECLARE (GLOBALVARS DUMP.IGNORE.SPECS)) (RESETLST (LET ((IDATE (if NEWERTHAN then (IDATE NEWERTHAN) else 0)) (FILTERS (MAPCAR DUMP.IGNORE.SPECS (FUNCTION DIRECTORY.MATCH.SETUP))) LOG FILES) (* do a little arg checking) (OR (FIXP IDATE) (ERROR NEWERTHAN "ARG NOT A DATE STRING")) (OR (STRPOS ":" (MKSTRING HOST)) (ERROR HOST "NOT AN NS HOST")) (SETQ LOG (OPENSTREAM LOG.FILE 'OUTPUT 'NEW)) (RESETSAVE NIL (LIST 'CLOSEF? LOG)) (printout LOG "Dump of server " HOST " on " (DATE) " to " TO.DIRECTORY "." T "Dumping " (OR NVERSIONS "all") " versions of each file written since " (GDATE IDATE) "." T) (printout LOG "Not dumping files on directories :") (for DIR in DUMP.IGNORE.DIRS do (PRINTOUT LOG " " DIR)) (printout LOG T "Not dumping files which match :") (for SPEC in DUMP.IGNORE.SPECS do (PRINTOUT LOG " " SPEC)) (printout LOG T T) (* actually do the dump.) (for DIR in (DUMP.DIRECTORIES HOST) bind FILES do (PRINTOUT T DIR) (SETQ FILES (DUMP.DIRECTORY HOST DIR IDATE NVERSIONS FILTERS LOG)) (printout T "(" (FLENGTH FILES) ")") (DUMP.DUMP FILES TO.DIRECTORY LOG) (PRINTOUT T "OK" T)) (printout LOG T (DATE) " Done with backups." T) (CLOSEF LOG]) (DUMP.DUMP [LAMBDA (FILES TO.DIR LOG) (* drc: "25-Mar-86 13:02") (* * Will copy all files in FILES to TO.DIR, renaming files as specified by DUMP.NEW.FILENAME. Each file copied is recorded in LOG, a stream opened for output.) (for FILE in FILES as N from 1 bind VALUE NEWNAME do (SETQ N9]AME (DUMP.NEW.FILENAME FILE TO.DIR)) (SETQ VALUE (NLSETQ (COPYFILE FILE NEWNAME))) (if (LISTP VALUE) then (* file dumped successfully) (PRINTOUT T (if (ZEROP (REMAINDER N 10)) then N else ".")) (printout LOG FILE T) else (* error occurred) (LET ((ERROR (ERRORN))) (PRINTOUT T (ERRORSTRING (CAR ERROR)) " " (CADR ERROR) T FILE " Not dumped." T) (PRINTOUT LOG (ERRORSTRING (CAR ERROR)) " " (CADR ERROR) T FILE " Not dumped." T]) (DUMP.NEW.FILENAME [LAMBDA (FILE TO.DIR) (* drc: "25-Mar-86 12:00") (* * Replaces >'s in the DIRECTORY field of file with DUMP.DIRECTORY.SEPARATOR.) (DECLARE (GLOBALVARS DUMP.DIRECTORY.SEPARATOR)) (LET ((FILEFIELDS (UNPACKFILENAME FILE))) (PACKFILENAME 'NAME (CONCAT [CONCATLIST (DSUBST DUMP.DIRECTORY.SEPARATOR '> (UNPACK (LISTGET FILEFIELDS 'DIRECTORY] DUMP.DIRECTORY.SEPARATOR (LISTGET FILEFIELDS 'NAME)) 'EXTENSION (LISTGET FILEFIELDS 'EXTENSION) 'VERSION NIL 'BODY TO.DIRECTORY]) (DUMP.DIRECTORIES [LAMBDA (HOST) (* drc: "25-Mar-86 12:05") (* * Returns a list of the names of all the top-level directories on NS host HOST except those on DUMP.IGNORE.DIRS) (DECLARE (GLOBALVARS DUMP.IGNORE.DIRS)) (LET [(DIRS (MAPCAR (DIRECTORY (PACKFILENAME 'HOST HOST 'DIRECTORY '*)) (FUNCTION (LAMBDA (SPEC) (* DIRECTORY of {host:}<*> returns a list of  {host:}<*>.;1) (MKATOM (U-CASE (FILENAMEFIELD SPEC 'DIRECTORY] (for DIR in DUMP.IGNORE.DIRS do (DREMOVE (MKATOM (U-CASE DIR)) DIRS)) DIRS]) (DUMP.DIRECTORY [LAMBDA (HOST DIR IDATE NVERSIONS FILTERS LOG) (* drc: "25-Mar-86 13:03") (* * Return all the files on DIR newer than IDATE, an IDATE, with no more than NVERSIONS of any particular file. NIL versions means all. Files which match a filter on FILTERS (generated from by mapping DIRECTORY.MATCH.SETUP over DUMP.IGNORE.SPECS) are removed.) (LET* ((SPEC (PACKFILENAME 'HOST HOST 'DIRECTORY DIR 'BODY '*.*;*)) (VALUE (NLSETQ (DUMP.GENERATE.NEWERTHAN SPEC IDATE))) (FILES (if (LISTP VALUE) then (CAR VALUE) else (LET ((ERROR (ERRORN))) (PRINTOUT T (ERRORSTRING (CAR ERROR)) " " (CADR ERROR) T SPEC " Not dumped." T) (PRINTOUT LOG (ERRORSTRING (CAR ERROR)) " " (CADR ERROR) T SPEC " Not dumped." T)) NIL))) (for FILE in (if NVERSIONS then (DUMP.NVERSIONS FILES NVERSIONS) else FILES) when (for FILTER in FILTERS never (DIRECTORY.MATCH FILTER FILE)) collect FILE]) (DUMP.GENERATE.NEWERTHAN [LAMBDA (SPEC IDATE) (* drc: "21-Mar-86 22:05") (RESETLST (* collect all the files in filespec SPEC newerthan  IDATE) (bind FILE [GEN _(\GENERATEFILES SPEC '(WRITEDATE) '(RESETLST SORT)] eachtime (SETQ FILE (\GENERATENEXTFILE GEN)) when (GEQ (IDATE (\GENERATEFILEINFO GEN 'WRITEDATE)) IDATE) collect FILE until (NOT FILE]) (DUMP.NVERSIONS [LAMBDA (FILES N) (* drc: " 1-Jan-01 00:36") (* assumes FILES is sorted, with low versions first) (DREVERSE (for TAIL on (DREVERSE FILES) bind FILE LASTFILE FILEFIELDS LASTFIELDS (M _ 1) eachtime (* Have to reverse list to get high versions first.) (SETQ LASTFILE FILE) (SETQ FILE (CAR TAIL)) (SETQ LASTFIELDS FILEFIELDS) (SETQ FILEFIELDS (UNPACKFILENAME FILE)) (* only collect the first N of a particular file) (if [AND (EQ (LISTGET FILEFIELDS 'NAME) (LISTGET LASTFIELDS 'NAME)) (EQ (LISTGET FILEFIELDS 'EXTENSION) (LISTGET LASTFIELDS 'EXTENSION)) (EQ (LISTGET FILEFIELDS 'DIRECTORY) (LISTGET LASTFIELDS 'DIRECTORY] then (SETQ M (ADD1 M)) else (SETQ M 1)) when (LEQ M N) collect FILE]) ) (RPAQ? DUMP.IGNORE.DIRS '(FONTS CLEARINGHOUSE SYSTEMFILES DESKTOPS)) (RPAQ? DUMP.IGNORE.SPECS '(*.DCOM;* *.SYSOUT;*)) (RPAQ? DUMP.DIRECTORY.SEPARATOR "\") (PUTPROPS DUMPER COPYRIGHT ("Speech Input Project, Univ. of Edinburgh" 1986 1901)) (DECLARE: DONTCOPY (FILEMAP (NIL (744 8397 (DUMP 754 . 2934) (DUMP.DUMP 2936 . 4062) (DUMP.NEW.FILENAME 4064 . 4735) ( DUMP.DIRECTORIES 4737 . 5478) (DUMP.DIRECTORY 5480 . 6683) (DUMP.GENERATE.NEWERTHAN 6685 . 7234) ( DUMP.NVERSIONS 7236 . 8395))))) STOP \ No newline at end of file diff --git a/lispusers/DUMPLOAD b/lispusers/DUMPLOAD new file mode 100644 index 00000000..95286b50 --- /dev/null +++ b/lispusers/DUMPLOAD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Jan-88 15:36:10" "{ERINYES}Lyric>DUMPLOAD.;4" 5124 changes to%: (FNS \DUMP.COPY \DUMP.PURGE DUMPREAD) (VARS DUMPLOADCOMS) (PROPS (DUMPREAD ARGNAMES)) previous date%: " 4-Dec-83 17:53:41" {ERINYES}KOTO>LISPUSERS>DUMPLOAD.;1) (* " Copyright (c) 1983, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DUMPLOADCOMS) (RPAQQ DUMPLOADCOMS ((FNS DUMPREAD \DUMP.PARSEDATE \DUMP.PARSENAME \DUMP.COPY \DUMP.PURGE) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS * DUMPTYPES)) (PROP ARGNAMES DUMPREAD) (PROP FILETYPE DUMPLOAD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DUMPREAD)))) ) (DEFINEQ (DUMPREAD (CL:LAMBDA (FILE &KEY ((:COPY-TO COPYFLG) T) ((:ASK ASKFLG)) ((:PRINT PRINTFLG) T) ((:DATES DATEFLG) T) (COLLECT NIL COLLECTP)) (* ; "Edited 7-Jan-88 14:28 by bvm:") (LET (STREAM OUTSTREAM) (CL:UNWIND-PROTECT (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT))) SEEFLG RESULT NAME CREATIONDATE KEYWORD TYPE) (IF (NULL COPYFLG) ELSEIF (EQ COPYFLG T) THEN (SETQ SEEFLG T) (SETQ ASKFLG T) (SETQ COPYFLG NIL) ELSEIF (NOT COLLECTP) THEN (SETQ COLLECT T)) (SETQ KEYWORD (COND (SEEFLG (SETQ OUTSTREAM (GETSTREAM T (QUOTE OUTPUT))) "See") (COPYFLG "Copy") (T (SETQ ASKFLG NIL)))) (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD) (QUOTE ((SEQUENTIAL T))))) LP (SETQ TYPE (BIN STREAM)) TYPELP (SELECTC TYPE (\DUMP.END (* ; "End of file, return accumulated names, if we've been collecting") (RETURN RESULT)) (\DUMP.NAME (SETQ NAME (\DUMP.PARSENAME STREAM))) (\DUMP.DATE (SETQ CREATIONDATE (\DUMP.PARSEDATE STREAM)) (* ; "Date is in alto format") (SETQ CREATIONDATE (AND (OR DATEFLG COPYFLG) (GDATE (ALTO.TO.LISP.DATE CREATIONDATE) (DATEFORMAT TIME.ZONE))))) (\DUMP.ERROR (ERROR "Error block encountered in dump file" (FULLNAME STREAM))) (\DUMP.DATA (COND ((COND ((NULL NAME) (printout T "[Skipping nameless data...]" T) NIL) (ASKFLG (CL:Y-OR-N-P "~A ~A~@[ [~A]~]? " KEYWORD NAME CREATIONDATE)) (T (COND (PRINTFLG (CL:FORMAT T "~A~@[ [~A]~]" NAME CREATIONDATE) (COND (SEEFLG (printout T (QUOTE %:) T)) (COPYFLG (printout T " -> ")) (T (TERPRI T))))) T)) (SETQ TYPE (COND (SEEFLG (PROG1 (\DUMP.COPY STREAM OUTSTREAM T) (COND (PRINTFLG (printout T .TAB0 0 T))))) (COPYFLG (SETQ OUTSTREAM (OPENSTREAM (PACKFILENAME.STRING (QUOTE DIRECTORY) COPYFLG (QUOTE BODY) NAME) (QUOTE OUTPUT) NIL NIL (BQUOTE ((SEQUENTIAL T) (CREATIONDATE (\, CREATIONDATE)))))) (PROG1 (\DUMP.COPY STREAM OUTSTREAM) (SETQ NAME (CLOSEF OUTSTREAM)) (SETQ OUTSTREAM NIL) (COND (PRINTFLG (printout T NAME T))))) (T (\DUMP.PURGE STREAM)))) (COND (COLLECT (push RESULT NAME)))) (T (SETQ TYPE (\DUMP.PURGE STREAM)))) (SETQ NAME (SETQ CREATIONDATE NIL)) (GO TYPELP)) (ERROR "Bad Block Type in dump file" (FULLNAME STREAM))) (GO LP)) (* ;; "Be sure to clean up this stream on the way out") (IF (AND OUTSTREAM (NEQ COPYFLG T)) THEN (* ; "Flush partially written copy") (DELFILE (CLOSEF OUTSTREAM))) (AND STREAM (CLOSEF STREAM))))) ) (\DUMP.PARSEDATE (LAMBDA (INSTREAM) (* bvm%: " 2-Dec-83 18:22") (PROG1 (\MAKENUMBER (\WIN INSTREAM) (\WIN INSTREAM)) (BIN INSTREAM) (* ; "Ignore two bytes") (BIN INSTREAM))) ) (\DUMP.PARSENAME (LAMBDA (INSTREAM) (* bvm%: " 2-Dec-83 18:26") (BIN INSTREAM) (* ; "Skip two bytes") (BIN INSTREAM) (PROG ((CHARS (bind CH until (EQ 0 (SETQ CH (BIN INSTREAM))) collect CH)) RESULT) (SETQ RESULT (ALLOCSTRING (LENGTH CHARS))) (for CH in CHARS as I from 1 do (RPLCHARCODE RESULT I CH)) (RETURN RESULT))) ) (\DUMP.COPY (LAMBDA (INSTREAM OUTSTREAM TTYP) (* ; "Edited 7-Jan-88 15:15 by bvm:") (* ;; "Copy data blocks byte-by-byte from INSTREAM to OUTSTREAM. Return the type of the next block. TTYP is true if OUTSTREAM is the terminal.") (bind TYPE do (COPYBYTES INSTREAM OUTSTREAM (PROG1 (\WIN INSTREAM) (* ; "Length in bytes. Now skip checksum") (BIN INSTREAM) (BIN INSTREAM))) repeatwhile (EQ (SETQ TYPE (BIN INSTREAM)) \DUMP.DATA) finally (RETURN TYPE))) ) (\DUMP.PURGE (LAMBDA (STREAM) (* ; "Edited 7-Jan-88 15:31 by bvm:") (do (SETFILEPTR STREAM (+ (PROG1 (\WIN STREAM) (* ; "Second word is checksum, which ignore") (BIN STREAM) (BIN STREAM)) (GETFILEPTR STREAM))) repeatwhile (EQ (SETQ $$VAL (BIN STREAM)) \DUMP.DATA))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ DUMPTYPES ((\DUMP.DATE 251) (\DUMP.END 252) (\DUMP.ERROR 253) (\DUMP.DATA 254) (\DUMP.NAME 255)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \DUMP.DATE 251) (RPAQQ \DUMP.END 252) (RPAQQ \DUMP.ERROR 253) (RPAQQ \DUMP.DATA 254) (RPAQQ \DUMP.NAME 255) (CONSTANTS (\DUMP.DATE 251) (\DUMP.END 252) (\DUMP.ERROR 253) (\DUMP.DATA 254) (\DUMP.NAME 255)) ) ) (PUTPROPS DUMPREAD ARGNAMES (FILE &KEY :ASK :COPY-TO :DATES :PRINT :COLLECT)) (PUTPROPS DUMPLOAD FILETYPE :COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DUMPREAD) ) (PUTPROPS DUMPLOAD COPYRIGHT ("Xerox Corporation" 1983 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (767 4355 (DUMPREAD 777 . 3111) (\DUMP.PARSEDATE 3113 . 3292) (\DUMP.PARSENAME 3294 . 3618) (\DUMP.COPY 3620 . 4079) (\DUMP.PURGE 4081 . 4353))))) STOP \ No newline at end of file diff --git a/lispusers/Debugger-Context.TEdit b/lispusers/Debugger-Context.TEdit new file mode 100644 index 00000000..4c5cf265 Binary files /dev/null and b/lispusers/Debugger-Context.TEdit differ diff --git a/lispusers/DocumentationTemplate.TEdit b/lispusers/DocumentationTemplate.TEdit new file mode 100644 index 00000000..18308426 Binary files /dev/null and b/lispusers/DocumentationTemplate.TEdit differ diff --git a/lispusers/EDITBG b/lispusers/EDITBG new file mode 100644 index 00000000..dcc42448 --- /dev/null +++ b/lispusers/EDITBG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jul-88 09:06:28" |{MCS:MCS:STANFORD}EDITBG.;6| 16468 changes to%: (FNS EDITBACKGROUND EDITBG.BUTTONFN) (VARS EDITBGCOMS) previous date%: " 9-Sep-87 09:18:10" |{MCS:MCS:STANFORD}EDITBG.;4|) (* " Copyright (c) 1984, 1985, 1986, 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT EDITBGCOMS) (RPAQQ EDITBGCOMS ((FNS EDITBACKGROUND EDITBG.BUTTONFN) (RECORDS EDITBG.RECORD EDITBG.DATA) (CONSTANTS (EDITBG.PIXELSIZE 16)) (ALISTS (BackgroundMenuCommands EditBG)) (VARS (BackgroundMenu)) [INITVARS [EDITBG.SHADEREC (create EDITBG.RECORD REGION _ (CREATEREGION 2 2 (LLSH EDITBG.PIXELSIZE 2) (LLSH EDITBG.PIXELSIZE 2)) GRIDSPEC _ (CREATEREGION 2 2 EDITBG.PIXELSIZE EDITBG.PIXELSIZE) BITWIDTH _ 4 BITHEIGHT _ 4 DSPREGION _ (CREATEREGION EDITBG.PIXELSIZE (TIMES EDITBG.PIXELSIZE 6) (TIMES EDITBG.PIXELSIZE 11) (LLSH EDITBG.PIXELSIZE 1)) NUMBEREGION _ (CREATEREGION WBorder (PLUS (LLSH EDITBG.PIXELSIZE 2) WBorder) (DIFFERENCE (LLSH EDITBG.PIXELSIZE 2) WBorder) (FONTPROP DEFAULTFONT 'HEIGHT] [EDITBG.BORDERREC (create EDITBG.RECORD REGION _ (CREATEREGION (PLUS (TIMES EDITBG.PIXELSIZE 5) 2) 2 (LLSH EDITBG.PIXELSIZE 3) (LLSH EDITBG.PIXELSIZE 2)) GRIDSPEC _ (CREATEREGION (PLUS (TIMES EDITBG.PIXELSIZE 5) 2) 2 EDITBG.PIXELSIZE (LLSH EDITBG.PIXELSIZE 1)) BITWIDTH _ 8 BITHEIGHT _ 2 DSPREGION _ (CREATEREGION 1 (ADD1 (TIMES EDITBG.PIXELSIZE 5)) (PLUS (TIMES EDITBG.PIXELSIZE 13) 2) (SUB1 (LLSH EDITBG.PIXELSIZE 2))) NUMBEREGION _ (CREATEREGION (PLUS (TIMES EDITBG.PIXELSIZE 5 ) WBorder) (PLUS (LLSH EDITBG.PIXELSIZE 2) WBorder) (DIFFERENCE (LLSH EDITBG.PIXELSIZE 3) WBorder) (FONTPROP DEFAULTFONT 'HEIGHT] (EDITBG.BUTTONREGION (CREATEREGION (PLUS 2 (LLSH EDITBG.PIXELSIZE 2)) (PLUS 2 (LLSH EDITBG.PIXELSIZE 2)) (SUB1 EDITBG.PIXELSIZE) (SUB1 EDITBG.PIXELSIZE] (GLOBALVARS EDITBG.BUTTONREGION EDITBG.BORDERREC EDITBG.SHADEREC EDITBG.PIXELSIZE))) (DEFINEQ (EDITBACKGROUND [LAMBDA NIL (* ; "Edited 12-Jul-88 09:05 by cdl") (DECLARE (GLOBALVARS WBorder)) (LET ((WINDOW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (CONSTANT (PLUS (TIMES EDITBG.PIXELSIZE 13) WBorder))) (HEIGHTIFWINDOW (CONSTANT (TIMES EDITBG.PIXELSIZE 9)) T)) "Background Texture Edit Tool"))) (for RECORD in (LIST EDITBG.SHADEREC EDITBG.BORDERREC) do (with EDITBG.RECORD RECORD (with REGION REGION (WBOX (CREATEREGION (DIFFERENCE LEFT (QUOTIENT WBorder 2)) (DIFFERENCE BOTTOM (QUOTIENT WBorder 2)) (PLUS WIDTH WBorder) (PLUS HEIGHT WBorder)) NIL NIL WINDOW)) (GRID GRIDSPEC BITWIDTH BITHEIGHT 'POINT WINDOW) (CENTERPRINTINREGION 0 NUMBEREGION WINDOW))) (WBOX EDITBG.BUTTONREGION NIL NIL WINDOW) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION EDITBG.BUTTONFN)) (WINDOWPROP WINDOW 'EDITBG.DATA (create EDITBG.DATA)) WINDOW]) (EDITBG.BUTTONFN [LAMBDA (WINDOW) (* ; "Edited 12-Jul-88 08:38 by cdl") (PROG ((DATA (WINDOWPROP WINDOW 'EDITBG.DATA)) POSITION SHADE LEFTFLG PIXEL BIT GRIDX GRIDY RECORD NEWSHADE) (until (MOUSESTATE UP) do (SETQ POSITION (CURSORPOSITION NIL WINDOW POSITION)) (if (INSIDEP EDITBG.BUTTONREGION POSITION) then (DSPFILL EDITBG.BUTTONREGION BLACKSHADE 'INVERT WINDOW) (with EDITBG.DATA DATA (CHANGEBACKGROUND INTERIOR) (CHANGEBACKGROUNDBORDER EXTERIOR)) (DSPFILL EDITBG.BUTTONREGION BLACKSHADE 'INVERT WINDOW) (RETURN)) (if (INSIDEP (fetch (EDITBG.RECORD REGION) of EDITBG.SHADEREC) POSITION) then (SETQ RECORD EDITBG.SHADEREC) (SETQ SHADE (with EDITBG.DATA DATA INTERIOR)) elseif (INSIDEP (fetch (EDITBG.RECORD REGION) of EDITBG.BORDERREC) POSITION) then (SETQ RECORD EDITBG.BORDERREC) (SETQ SHADE (with EDITBG.DATA DATA EXTERIOR)) else (SETQ RECORD NIL)) (if RECORD then (SETQ LEFTFLG (LASTMOUSESTATE LEFT)) [with EDITBG.RECORD RECORD (with POSITION POSITION (SETQ GRIDX (GRIDXCOORD XCOORD GRIDSPEC)) (SETQ GRIDY (GRIDYCOORD YCOORD GRIDSPEC))) (SHADEGRIDBOX GRIDX GRIDY (if LEFTFLG then GRAYSHADE else WHITESHADE) NIL GRIDSPEC 'POINT WINDOW) [SETQ PIXEL (LLSH 1 (PLUS (TIMES GRIDY BITWIDTH) (SUB1 BITWIDTH) (MINUS GRIDX] [SETQ NEWSHADE (if LEFTFLG then (LOGOR SHADE PIXEL) else (LOGAND SHADE (LOGNOT PIXEL] (if (NEQ SHADE NEWSHADE) then (SETQ SHADE NEWSHADE) (DSPFILL NUMBEREGION WHITESHADE 'REPLACE WINDOW) (CENTERPRINTINREGION SHADE NUMBEREGION WINDOW) (with EDITBG.DATA DATA (if (EQ RECORD EDITBG.BORDERREC) then (SETQ BIT (if LEFTFLG then 1 else 0)) (SETQ GRIDY (LLSH GRIDY 1)) (for X from GRIDX to (PLUS GRIDX 8) by 8 do (for Y from GRIDY to (ADD1 GRIDY) do (BITMAPBIT BITMAP X Y BIT))) (DSPFILL DSPREGION BITMAP NIL WINDOW) (SETQ EXTERIOR SHADE) else (SETQ INTERIOR SHADE] (DSPFILL (fetch (EDITBG.RECORD DSPREGION) of EDITBG.SHADEREC) (with EDITBG.DATA DATA INTERIOR) NIL WINDOW)) (BLOCK]) ) (DECLARE%: EVAL@COMPILE (RECORD EDITBG.RECORD (REGION GRIDSPEC BITWIDTH DSPREGION NUMBEREGION BITHEIGHT)) (RECORD EDITBG.DATA (BITMAP INTERIOR EXTERIOR) BITMAP _ (BITMAPCREATE 16 4) INTERIOR _ 0 EXTERIOR _ 0) ) (DECLARE%: EVAL@COMPILE (RPAQQ EDITBG.PIXELSIZE 16) (CONSTANTS (EDITBG.PIXELSIZE 16)) ) (ADDTOVAR BackgroundMenuCommands (EditBG '(EDITBACKGROUND) "Opens a Background Texture Edit Tool")) (RPAQQ BackgroundMenu NIL) (RPAQ? EDITBG.SHADEREC [create EDITBG.RECORD REGION _ (CREATEREGION 2 2 (LLSH EDITBG.PIXELSIZE 2) (LLSH EDITBG.PIXELSIZE 2)) GRIDSPEC _ (CREATEREGION 2 2 EDITBG.PIXELSIZE EDITBG.PIXELSIZE) BITWIDTH _ 4 BITHEIGHT _ 4 DSPREGION _ (CREATEREGION EDITBG.PIXELSIZE (TIMES EDITBG.PIXELSIZE 6) (TIMES EDITBG.PIXELSIZE 11) (LLSH EDITBG.PIXELSIZE 1)) NUMBEREGION _ (CREATEREGION WBorder (PLUS (LLSH EDITBG.PIXELSIZE 2) WBorder) (DIFFERENCE (LLSH EDITBG.PIXELSIZE 2) WBorder) (FONTPROP DEFAULTFONT 'HEIGHT]) (RPAQ? EDITBG.BORDERREC [create EDITBG.RECORD REGION _ (CREATEREGION (PLUS (TIMES EDITBG.PIXELSIZE 5) 2) 2 (LLSH EDITBG.PIXELSIZE 3) (LLSH EDITBG.PIXELSIZE 2)) GRIDSPEC _ (CREATEREGION (PLUS (TIMES EDITBG.PIXELSIZE 5) 2) 2 EDITBG.PIXELSIZE (LLSH EDITBG.PIXELSIZE 1)) BITWIDTH _ 8 BITHEIGHT _ 2 DSPREGION _ (CREATEREGION 1 (ADD1 (TIMES EDITBG.PIXELSIZE 5)) (PLUS (TIMES EDITBG.PIXELSIZE 13) 2) (SUB1 (LLSH EDITBG.PIXELSIZE 2))) NUMBEREGION _ (CREATEREGION (PLUS (TIMES EDITBG.PIXELSIZE 5) WBorder) (PLUS (LLSH EDITBG.PIXELSIZE 2) WBorder) (DIFFERENCE (LLSH EDITBG.PIXELSIZE 3) WBorder) (FONTPROP DEFAULTFONT 'HEIGHT]) (RPAQ? EDITBG.BUTTONREGION (CREATEREGION (PLUS 2 (LLSH EDITBG.PIXELSIZE 2)) (PLUS 2 (LLSH EDITBG.PIXELSIZE 2)) (SUB1 EDITBG.PIXELSIZE) (SUB1 EDITBG.PIXELSIZE))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EDITBG.BUTTONREGION EDITBG.BORDERREC EDITBG.SHADEREC EDITBG.PIXELSIZE) ) (PUTPROPS EDITBG COPYRIGHT ("Stanford University" 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5943 11841 (EDITBACKGROUND 5953 . 7731) (EDITBG.BUTTONFN 7733 . 11839))))) STOP \ No newline at end of file diff --git a/lispusers/EDITBG.TEDIT b/lispusers/EDITBG.TEDIT new file mode 100644 index 00000000..521283d1 Binary files /dev/null and b/lispusers/EDITBG.TEDIT differ diff --git a/lispusers/EDITFONT b/lispusers/EDITFONT new file mode 100644 index 00000000..6d8869d4 --- /dev/null +++ b/lispusers/EDITFONT @@ -0,0 +1 @@ +(FILECREATED "26-Aug-86 16:23:09" {ERIS}EDITFONT.;2 42108 changes to: (FNS COPYFONT) previous date: " 7-Feb-86 11:05:47" {ERIS}EDITFONT.;1) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT EDITFONTCOMS) (RPAQQ EDITFONTCOMS ((* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL and LOADFROM FONT in order to compile this file. *) (CONSTANTS (BITSPERWORD 16) (BYTESPERWORD 2) (MAXCODE 255) (DUMMYINDEX 256)) (INITVARS (EF.MENU NIL) (EF.TITLEMENU NIL)) (RECORDS CHARITEM) (FNS EF.INIT EF.EDIT EF.PROMPT EF.MESSAGE EF.CLOSEFN EF.CHARITEMS EF.BUTTONEVENTFN EF.WHENSELECTEDFN EF.EDITBM EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SAVE EF.BLANK COPYFONT READSTRIKEFONTFILE WRITESTRIKEFONTFILE) (FNS BLANKFONTCREATE EDITFONT) (P (EF.INIT)))) (* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL and LOADFROM FONT in order to compile this file. *) (DECLARE: EVAL@COMPILE (RPAQQ BITSPERWORD 16) (RPAQQ BYTESPERWORD 2) (RPAQQ MAXCODE 255) (RPAQQ DUMMYINDEX 256) (CONSTANTS (BITSPERWORD 16) (BYTESPERWORD 2) (MAXCODE 255) (DUMMYINDEX 256)) ) (RPAQ? EF.MENU NIL) (RPAQ? EF.TITLEMENU NIL) [DECLARE: EVAL@COMPILE (RECORD CHARITEM (BITMAP (CHARCODE DUMMYFLG))) ] (DEFINEQ (EF.INIT (LAMBDA NIL (* kbr: "21-Oct-85 15:50") (PROG NIL (SETQ EF.MENU (create MENU ITEMS _(QUOTE ((CHANGESIZE (QUOTE EF.CHANGESIZE) "Change size of character.") (DELETE (QUOTE (QUOTE EF.DELETE)) "Delete character.") (EDITBM (QUOTE (QUOTE EF.EDITBM)) "Edit character.") (REPLACE (QUOTE (QUOTE EF.REPLACE)) "Prompt for bitmap to replace character."))))) (SETQ EF.TITLEMENU (create MENU ITEMS _(QUOTE ((SAVE (QUOTE EF.SAVE) "Save EDITFONT's work back into font.")))))) )) (EF.EDIT (LAMBDA (FONT FROMCHAR8CODE TOCHAR8CODE CHARSET) (* kbr: "21-Oct-85 15:35") (* Edit FONT. *) (COND ((NULL FROMCHAR8CODE) (SETQ FROMCHAR8CODE 0))) (COND ((NULL TOCHAR8CODE) (SETQ TOCHAR8CODE 255))) (COND ((NULL CHARSET) (SETQ CHARSET 0))) (PROG (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW) (COND ((FONTP FONT) (SETQ CHARITEMS (EF.CHARITEMS FONT FROMCHAR8CODE TOCHAR8CODE CHARSET)) (SETQ MENU (create MENU MENUFONT _ FONT CENTERFLG _ T MENUCOLUMNS _ 16 ITEMS _ CHARITEMS WHENSELECTEDFN _(FUNCTION EF.WHENSELECTEDFN))) (SETQ TITLE (PACK* (FONTPROP FONT (QUOTE FAMILY)) (FONTPROP FONT (QUOTE SIZE)) (PACKC (for ATOM in (FONTPROP FONT (QUOTE FACE)) collect (CHCON1 ATOM))))) (SETQ HEIGHT (HEIGHTIFWINDOW (fetch (MENU IMAGEHEIGHT) of MENU) T)) (SETQ WIDTH (WIDTHIFWINDOW (fetch (MENU IMAGEWIDTH) of MENU))) (SETQ POS (GETBOXPOSITION WIDTH HEIGHT)) (SETQ REGION (create REGION LEFT _(fetch (POSITION XCOORD) of POS) BOTTOM _(fetch (POSITION YCOORD) of POS) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (SETQ WINDOW (CREATEW REGION TITLE)) (WINDOWPROP WINDOW (QUOTE CHARITEMS) CHARITEMS) (ADDMENU MENU WINDOW (create POSITION XCOORD _ 0 YCOORD _ 0)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (QUOTE EF.BUTTONEVENTFN))) (T (ERROR "Can't edit " FONT)))))) (EF.PROMPT (LAMBDA (STRING WINDOW) (* kbr: "16-Oct-85 22:48") (PROG (PROMPTW ANSWER) (SETQ PROMPTW (GETPROMPTWINDOW WINDOW)) (CLEARW PROMPTW) (PRIN1 STRING PROMPTW) (PRIN1 " " PROMPTW) (SETQ ANSWER (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PROMPTW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (TTYINREAD PROMPTW))) (TERPRI PROMPTW) (SETQ ANSWER (EVAL ANSWER)) (RETURN ANSWER)))) (EF.MESSAGE (LAMBDA (STRING WINDOW) (* kbr: "16-Oct-85 22:50") (PROG (PROMPTW) (SETQ PROMPTW (GETPROMPTWINDOW WINDOW)) (PRIN1 STRING PROMPTW)))) (EF.CLOSEFN (LAMBDA (WINDOW) (* kbr: "15-Dec-84 15:20") (* Close EF Window. *) (PROG NIL (COND ((EQ (ASKUSER "Close Editfont Window?") (QUOTE N)) (RETURN (QUOTE DON'T)))) (CLOSEW WINDOW) (* Break circularity. *) (WINDOWPROP WINDOW (QUOTE MENU) NIL)))) (EF.CHARITEMS (LAMBDA (FONT FROMCHAR8CODE TOCHAR8CODE CHARSET) (* kbr: "16-Oct-85 23:11") (* Get CHARITEMS for FONT. *) (PROG (FROMCHARCODE TOCHARCODE OFFSETS DUMMYOFFSET DUMMYBITMAP OFFSET BITMAP CHARITEM CHARITEMS) (* Get DUMMY CHARITEM *) (* Interlisp assuming 256 is dummy is dumb now because of NS chars. Maybe Kaplan and Nuyens will fix. *) (SETQ DUMMYBITMAP (GETCHARBITMAP 256 FONT)) (SETQ CHARITEM (create CHARITEM BITMAP _ DUMMYBITMAP CHARCODE _ DUMMYINDEX DUMMYFLG _ T)) (push CHARITEMS CHARITEM) (* Get ordinairy CHARITEMs. *) (SETQ FROMCHARCODE (IPLUS (ITIMES 256 CHARSET) FROMCHAR8CODE)) (SETQ TOCHARCODE (IPLUS (ITIMES 256 CHARSET) TOCHAR8CODE)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of (\GETCHARSETINFO CHARSET FONT))) (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX)) (for I from TOCHARCODE to FROMCHARCODE by -1 do (SETQ OFFSET (\FGETOFFSET OFFSETS I)) (COND ((EQ OFFSET DUMMYOFFSET) (SETQ CHARITEM (create CHARITEM BITMAP _ DUMMYBITMAP CHARCODE _ I DUMMYFLG _ T))) (T (SETQ BITMAP (GETCHARBITMAP I FONT)) (SETQ CHARITEM (create CHARITEM BITMAP _ BITMAP CHARCODE _ I DUMMYFLG _ NIL)))) (push CHARITEMS CHARITEM)) (* OKEY DOKEY *) (RETURN CHARITEMS)))) (EF.BUTTONEVENTFN (LAMBDA (WINDOW) (* kbr: "16-Oct-85 22:19") (PROG (COMMAND) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (MENUBUTTONFN WINDOW)) ((SETQ COMMAND (MENU EF.TITLEMENU)) (APPLY* COMMAND WINDOW)))))) (EF.WHENSELECTEDFN (LAMBDA (CHARITEM MENU KEY) (* kbr: "16-Oct-85 22:26") (PROG NIL (COND (CHARITEM (SELECTQ KEY (LEFT (EF.EDITBM CHARITEM MENU)) (MIDDLE (EF.MIDDLEBUTTONFN CHARITEM MENU)) (* Do nothing. *))))))) (EF.EDITBM (LAMBDA (CHARITEM MENU) (* kbr: "15-Dec-84 15:20") (PROG (BITMAP CHARCODE DUMMYFLG) (RESETLST (RESETSAVE (SHADEITEM CHARITEM MENU BLACKSHADE) (BQUOTE (SHADEITEM (\, CHARITEM) (\, MENU) (\, WHITESHADE)))) (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM)) (COND ((AND (NOT (IEQP (fetch (CHARITEM CHARCODE) of CHARITEM) DUMMYINDEX)) (fetch (CHARITEM DUMMYFLG) of CHARITEM)) (* Undummify this CHARITEM. *) (SETQ BITMAP (COPYALL BITMAP)) (UNINTERRUPTABLY (replace (CHARITEM BITMAP) of CHARITEM with BITMAP) (replace (CHARITEM DUMMYFLG) of CHARITEM with NIL)))) (EDITBM BITMAP)) (* Update MENU image. SHADEITEM's side effects above suffice if we only changed one menu item. (I.e. we edited an ordinairy CHARITEM.) *) (COND ((IEQP (fetch (CHARITEM CHARCODE) of CHARITEM) DUMMYINDEX) (UPDATE/MENU/IMAGE MENU) (REDISPLAYW (WFROMMENU MENU))))))) (EF.MIDDLEBUTTONFN (LAMBDA (CHARITEM MENU) (* kbr: "15-Dec-84 15:20") (PROG (COMMAND) (SETQ COMMAND (MENU EF.MENU)) (COND (COMMAND (APPLY* COMMAND CHARITEM MENU)))))) (EF.CHANGESIZE (LAMBDA (CHARITEM MENU) (* kbr: "16-Oct-85 23:03") (* Change height & width of CHARITEM's BITMAP *) (PROG (HEIGHT WIDTH NEWBITMAP WINDOW) (SETQ WINDOW (WFROMMENU MENU)) (SETQ HEIGHT (EF.PROMPT "New height?" WINDOW)) (COND ((NULL HEIGHT) (EF.MESSAGE "Aborted." WINDOW) (RETURN))) (SETQ HEIGHT (EVAL HEIGHT)) (SETQ WIDTH (EF.PROMPT "New width?" WINDOW)) (COND ((NULL WIDTH) (EF.MESSAGE "Aborted." WINDOW) (RETURN))) (SETQ WIDTH (EVAL WIDTH)) (SETQ NEWBITMAP (BITMAPCREATE WIDTH HEIGHT)) (BITBLT (fetch (CHARITEM BITMAP) of CHARITEM) NIL NIL NEWBITMAP) (UNINTERRUPTABLY (replace (CHARITEM BITMAP) of CHARITEM with NEWBITMAP) (replace (CHARITEM DUMMYFLG) of CHARITEM with NIL)) (UPDATE/MENU/IMAGE MENU) (REDISPLAYW (WFROMMENU MENU))))) (EF.DELETE (LAMBDA (CHARITEM MENU) (* kbr: "15-Dec-84 15:20") (* Turn CHARITEM into dummy charitem. *) (PROG (WINDOW CHARITEMS DUMMYBITMAP) (SETQ WINDOW (WFROMMENU MENU)) (SETQ CHARITEMS (WINDOWPROP WINDOW (QUOTE CHARITEMS))) (SETQ DUMMYBITMAP (fetch (CHARITEM BITMAP) of (CAR (LAST CHARITEMS)))) (UNINTERRUPTABLY (replace (CHARITEM BITMAP) of CHARITEM with DUMMYBITMAP) (replace (CHARITEM DUMMYFLG) of CHARITEM with T)) (UPDATE/MENU/IMAGE MENU) (REDISPLAYW (WFROMMENU MENU))))) (EF.ENTER (LAMBDA (CHARITEM MENU) (* kbr: "15-Dec-84 15:20") (* Enter BITMAP of CHARITEM. *) (PROG (NEWBITMAP) (SETQ NEWBITMAP (EF.PROMPT "Enter new bitmap (evaluated):")) (COND ((NULL NEWBITMAP) (printout T "Aborted." T)) ((type? BITMAP NEWBITMAP) (UNINTERRUPTABLY (replace (CHARITEM BITMAP) of CHARITEM with NEWBITMAP) (replace (CHARITEM DUMMYFLG) of CHARITEM with NIL)) (UPDATE/MENU/IMAGE MENU) (REDISPLAYW (WFROMMENU MENU))) (T (LISPERROR "ILLEGAL ARG" NEWBITMAP)))))) (EF.REPLACE (LAMBDA (CHARITEM MENU) (* kbr: "16-Oct-85 23:04") (* Replace BITMAP of CHARITEM. *) (PROG (BITMAP WINDOW) (SETQ WINDOW (WFROMMENU MENU)) (SETQ BITMAP (EF.PROMPT "New bitmap?" WINDOW)) (COND ((NULL BITMAP) (EF.MESSAGE "Aborted." WINDOW)) ((type? BITMAP BITMAP) (UNINTERRUPTABLY (replace (CHARITEM BITMAP) of CHARITEM with BITMAP) (replace (CHARITEM DUMMYFLG) of CHARITEM with NIL)) (UPDATE/MENU/IMAGE MENU) (REDISPLAYW (WFROMMENU MENU))) (T (LISPERROR "ILLEGAL ARG" BITMAP)))))) (EF.SAVE (LAMBDA (WINDOW) (* kbr: "21-Oct-85 15:39") (* Save EDITFONT changes to FONT. *) (PROG (CHARITEMS FONT CB CBWIDTH CBHEIGHT WIDTHS OFFSETS HEIGHT WIDTH DUMMYOFFSET OFFSET BITMAP FIRSTCHAR LASTCHAR CHARSET CSINFO) (SETQ CHARITEMS (WINDOWPROP WINDOW (QUOTE CHARITEMS))) (SETQ FONT (WINDOWPROP WINDOW (QUOTE FONT))) (* New allocations. *) (SETQ CBWIDTH 0) (SETQ CBHEIGHT 0) (for I from 0 to DUMMYINDEX as CHARITEM in CHARITEMS when (OR (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM)) (IEQP I DUMMYINDEX)) do (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM)) (SETQ CBWIDTH (IPLUS CBWIDTH (fetch (BITMAP BITMAPWIDTH ) of BITMAP))) (SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP BITMAPHEIGHT ) of BITMAP)))) (SETQ CSINFO (create CHARSETINFO CHARSETASCENT _(fetch (FONTDESCRIPTOR \SFAscent) of FONT) CHARSETDESCENT _(fetch (FONTDESCRIPTOR \SFDescent) of FONT))) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (* Store new info in allocations. *) (SETQ OFFSET 0) (SETQ DUMMYOFFSET (IDIFFERENCE CBWIDTH (fetch (BITMAP BITMAPWIDTH) of (fetch (CHARITEM BITMAP) of (CAR (LAST CHARITEMS)))))) (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT)) (for I from 0 to DUMMYINDEX as CHARITEM in CHARITEMS do (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM)) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (\FSETWIDTH WIDTHS I WIDTH) (COND ((AND (fetch (CHARITEM DUMMYFLG) of CHARITEM) (NOT (IEQP I DUMMYINDEX))) (\FSETOFFSET OFFSETS I DUMMYOFFSET)) (T (\FSETOFFSET OFFSETS I OFFSET) (BITBLT BITMAP 0 0 CB OFFSET 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (SETQ OFFSET (IPLUS OFFSET WIDTH))))) (* FIRSTCHAR & LASTCHAR. (I wonder what you're suppose to do if there aren't any chars?) *) (SETQ FIRSTCHAR (\CHAR8CODE (fetch (CHARITEM CHARCODE) of (for CHARITEM in CHARITEMS thereis (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM))) ))) (SETQ LASTCHAR (\CHAR8CODE (fetch (CHARITEM CHARCODE) of (for CHARITEM in (REVERSE CHARITEMS) thereis (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM)))) )) (SETQ CHARSET (\CHARSET (fetch (CHARITEM CHARCODE) of (CAR CHARITEMS)))) (* Store new info. *) (UNINTERRUPTABLY (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB) (replace (CHARSETINFO WIDTHS) of CSINFO with WIDTHS) (replace (CHARSETINFO OFFSETS) of CSINFO with OFFSETS) (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR) (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with WIDTHS)) (* OKEY DOKEY. *) ))) (EF.BLANK (LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH) (* kbr: "21-Oct-85 15:25") (PROG (FONT CSINFO WIDTHS DUMMYWIDTH OFFSETS DUMMYOFFSET CB CBWIDTH CBHEIGHT) (SETQ FAMILY (U-CASE FAMILY)) (COND ((NOT (FIXP SIZE)) (LISPERROR "ILLEGAL ARG" SIZE))) (SETQ FACE (\FONTFACE FACE)) (COND ((NOT (SMALLP FIRSTCHAR)) (LISPERROR "ILLEGAL ARG" FIRSTCHAR))) (COND ((NOT (SMALLP LASTCHAR)) (LISPERROR "ILLEGAL ARG" LASTCHAR))) (COND ((NOT (SMALLP ASCENT)) (LISPERROR "ILLEGAL ARG" ASCENT))) (COND ((NOT (SMALLP DESCENT)) (LISPERROR "ILLEGAL ARG" DESCENT))) (COND ((NOT (OR (FIXP WIDTH) (AND (LISTP WIDTH) (NOT (for W in WIDTH thereis (NOT (FIXP W)))) (IEQP (LENGTH WIDTH) (IPLUS LASTCHAR (IMINUS FIRSTCHAR) 1 1))))) (LISPERROR "ILLEGAL ARG" WIDTH))) (* WIDTHS. *) (SETQ CSINFO (create CHARSETINFO CHARSETASCENT _ ASCENT CHARSETDESCENT _ DESCENT)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (COND ((LISTP WIDTH) (SETQ DUMMYWIDTH (CAR (LAST WIDTH))) (for I from 0 to (SUB1 FIRSTCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH)) (for I from FIRSTCHAR to LASTCHAR as W in WIDTH do (\FSETWIDTH WIDTHS I W)) (for I from (ADD1 LASTCHAR) to DUMMYINDEX do (\FSETWIDTH WIDTHS I DUMMYWIDTH))) (T (for I from 0 to DUMMYINDEX do (\FSETWIDTH WIDTHS I WIDTH)))) (* OFFSETS. *) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (for I from FIRSTCHAR to (ADD1 LASTCHAR) do (\FSETOFFSET OFFSETS (ADD1 I) (IPLUS (\FGETOFFSET OFFSETS I) (\FGETWIDTH WIDTHS I)))) (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS (ADD1 LASTCHAR))) (for I from 0 to (SUB1 FIRSTCHAR) do (\FSETOFFSET OFFSETS I DUMMYOFFSET)) (for I from (ADD1 LASTCHAR) to DUMMYINDEX do (\FSETOFFSET OFFSETS I DUMMYOFFSET)) (* Characterbitmap CB. *) (SETQ CBHEIGHT (IPLUS ASCENT DESCENT)) (SETQ CBWIDTH (IPLUS (\FGETOFFSET OFFSETS DUMMYINDEX) (\FGETWIDTH WIDTHS DUMMYINDEX))) (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT)) (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB) (* FONT. *) (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR) (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ FONT (create FONTDESCRIPTOR FONTDEVICE _(QUOTE DISPLAY) FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE \SFAscent _ 0 \SFDescent _ 0 \SFHeight _ 0 ROTATION _ 0 FONTDEVICESPEC _(LIST FAMILY SIZE FACE 0 (QUOTE DISPLAY)))) (replace (FONTDESCRIPTOR \SFAscent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFAscent) of FONT) (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))) (replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent) of FONT) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) (replace (FONTDESCRIPTOR \SFHeight) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFHeight) of FONT) (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))) (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT) 0 CSINFO) (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT)) (RETURN FONT)))) (COPYFONT (LAMBDA (FONT) (* jds "26-Aug-86 16:01") (PROG (NEWFONT NEWCHARSETVECTOR OLDCHARSETVECTOR NEWCSINFO OLDCSINFO) (SETQ NEWFONT (create FONTDESCRIPTOR using FONT)) (SETQ NEWCHARSETVECTOR (\ALLOCBLOCK (ADD1 \MAXCHARSET) T)) (SETQ OLDCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)) (for CHARSET from 0 to \MAXCHARSET do (SETQ OLDCSINFO (\GETBASEPTR OLDCHARSETVECTOR (UNFOLD CHARSET 2))) (COND (OLDCSINFO (SETQ NEWCSINFO (create CHARSETINFO CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of OLDCSINFO) CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of OLDCSINFO) CHARSETBITMAP _ (COPYALL (fetch (CHARSETINFO CHARSETBITMAP) of OLDCSINFO)))) (\BLT (fetch (CHARSETINFO WIDTHS) of NEWCSINFO) (fetch (CHARSETINFO WIDTHS) of OLDCSINFO) (ADD1 DUMMYINDEX)) (\BLT (fetch (CHARSETINFO OFFSETS) of NEWCSINFO) (fetch (CHARSETINFO OFFSETS) of OLDCSINFO) (ADD1 DUMMYINDEX)) (replace (CHARSETINFO IMAGEWIDTHS) of NEWCSINFO with (fetch (CHARSETINFO WIDTHS) of NEWCSINFO)) (\RPLPTR NEWCHARSETVECTOR (UNFOLD CHARSET 2) NEWCSINFO)))) (RETURN NEWFONT)))) (READSTRIKEFONTFILE (LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET) (* kbr: "14-Oct-85 11:16") (* Very similar to \READSTRIKEFONTFILE of SOURCES>FONT. Returns fontdescriptor FONT. *) (PROG (STRM CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS) (* This part imitates \READSTRIKEFONTFILE *) (SETQ STRM (OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD))) (SETQ CSINFO (create CHARSETINFO)) (\WIN STRM) (SETQ FIRSTCHAR (\WIN STRM)) (* minimum ascii code) (SETQ LASTCHAR (\WIN STRM)) (* maximum ascii code) (\WIN STRM) (* MaxWidth which isn't used by anyone.) (\WIN STRM) (* number of words in this StrikeBody) (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))(* ascent in scan lines (=FBBdy+FBBoy)) (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM)) (* descent in scan-lines (=FBBoy)) (\WIN STRM) (* offset in bits (<0 for kerning, else 0, =FBBox)) (SETQ RW (\WIN STRM)) (* raster width of bitmap) (* height of bitmap) (SETQ HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD) HEIGHT)) (\BINS STRM (fetch (BITMAP BITMAPBASE) of BITMAP) 0 (UNFOLD (ITIMES RW HEIGHT) BYTESPERWORD)) (* read bits into bitmap) (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP) (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR) 3)) (* SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (* initialise the offsets to 0) (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0)) (* AIN OFFSETS FIRSTCHAR NUMBCODES STRM) (for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM))) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0)) (* replace WIDTHS of CSINFO with (ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0)) (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR) (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO)) (CLOSEF STRM) (* This part imitates \CREATEDISPLAYFONT *) (COND ((NULL CHARSET) (SETQ CHARSET 0))) (COND ((NULL FONT) (SETQ FONT (create FONTDESCRIPTOR FONTDEVICE _(QUOTE DISPLAY) FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE \SFAscent _ 0 \SFDescent _ 0 \SFHeight _ 0 ROTATION _ 0 FONTDEVICESPEC _(LIST FAMILY SIZE FACE 0 (QUOTE DISPLAY)))))) (* This part imitates \CREATECHARSET. *) (replace (FONTDESCRIPTOR \SFAscent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFAscent) of FONT) (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))) (replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent) of FONT) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) (replace (FONTDESCRIPTOR \SFHeight) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFHeight) of FONT) (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))) (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT) CHARSET CSINFO) (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT)) (RETURN FONT)))) (WRITESTRIKEFONTFILE (LAMBDA (FONT CHARSET FILE) (* kbr: "21-Oct-85 15:08") (* Write strike FILE using info in FONT. *) (PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTH MAXWIDTH LENGTH RASTERWIDTH DUMMYCHAR DUMMYOFFSET OFFSET PREVIOUSOFFSET WIDTH CODE) (COND ((NOT (FONTP FONT)) (LISPERROR "ILLEGAL ARG" FONT))) (COND ((NULL CHARSET) (SETQ CHARSET 0)) ((NOT (AND (IGEQ CHARSET 0) (ILESSP CHARSET \MAXCHARSET))) (LISPERROR "ILLEGAL ARG" CHARSET))) (SETQ CSINFO (\GETCHARSETINFO CHARSET FONT T)) (COND ((NULL CSINFO) (ERROR "Couldn't find charset " CHARSET))) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX)) (SETQ FIRSTCHAR (for I from 0 to MAXCODE thereis (NOT (EQ (\FGETOFFSET OFFSETS I) DUMMYOFFSET)))) (SETQ LASTCHAR (for I from MAXCODE to 0 by -1 thereis (NOT (EQ (\FGETOFFSET OFFSETS I) DUMMYOFFSET)))) (SETQ DUMMYCHAR (ADD1 LASTCHAR)) (SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) (* STRIKE HEADER. *) (\WOUT STREAM 32768) (\WOUT STREAM FIRSTCHAR) (\WOUT STREAM LASTCHAR) (SETQ MAXWIDTH 0) (for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I)))) (\WOUT STREAM MAXWIDTH) (* STRIKE BODY. *) (* Length. *) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR) (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT) RASTERWIDTH))) (\WOUT STREAM LENGTH) (* Ascent, Descent, Xoffset (no longer used) and Rasterwidth. *) (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (\WOUT STREAM 0) (\WOUT STREAM RASTERWIDTH) (* Bitmap. *) (\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) 0 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))) (* Offsets. *) (SETQ CODE 0) (\WOUT STREAM CODE) (for I from FIRSTCHAR to DUMMYCHAR do (SETQ OFFSET (\FGETOFFSET OFFSETS I)) (SETQ WIDTH (\FGETWIDTH WIDTHS I)) (COND ((AND (IEQP OFFSET DUMMYOFFSET) (NOT (IEQP I DUMMYCHAR))) (* CODE stays the same. *) ) (T (SETQ CODE (IPLUS CODE WIDTH)))) (\WOUT STREAM CODE)) (CLOSEF STREAM)))) ) (DEFINEQ (BLANKFONTCREATE (LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH) (* mjs "27-Mar-85 14:48") (EF.BLANK FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH))) (EDITFONT (LAMBDA (FONT FROMCHARCODE TOCHARCODE) (* mjs "27-Mar-85 14:48") (EF.EDIT FONT FROMCHARCODE TOCHARCODE))) ) (EF.INIT) (PUTPROPS EDITFONT COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1490 41501 (EF.INIT 1500 . 2609) (EF.EDIT 2611 . 4889) (EF.PROMPT 4891 . 5533) ( EF.MESSAGE 5535 . 5828) (EF.CLOSEFN 5830 . 6579) (EF.CHARITEMS 6581 . 9239) (EF.BUTTONEVENTFN 9241 . 9736) (EF.WHENSELECTEDFN 9738 . 10300) (EF.EDITBM 10302 . 12192) (EF.MIDDLEBUTTONFN 12194 . 12522) ( EF.CHANGESIZE 12524 . 13795) (EF.DELETE 13797 . 14715) (EF.ENTER 14717 . 15618) (EF.REPLACE 15620 . 16549) (EF.SAVE 16551 . 21425) (EF.BLANK 21427 . 26773) (COPYFONT 26775 . 29227) (READSTRIKEFONTFILE 29229 . 36752) (WRITESTRIKEFONTFILE 36754 . 41499)) (41502 42014 (BLANKFONTCREATE 41512 . 41779) ( EDITFONT 41781 . 42012))))) STOP \ No newline at end of file diff --git a/lispusers/EDITKEYS b/lispusers/EDITKEYS new file mode 100644 index 00000000..3044b468 --- /dev/null +++ b/lispusers/EDITKEYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 9-Feb-87 21:28:31" {ERIS}LYRIC>EDITKEYS.;2 5949 previous date%: " 5-Nov-85 15:37:40" {ERIS}LYRIC>EDITKEYS.;1) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EDITKEYSCOMS) (RPAQQ EDITKEYSCOMS ((VARS KEY.TEMPLATE) (FNS BUILDFNKEYS KEY.BITMAP) (P (* could have (STRIKEOUT)) (BUILDFNKEYS '((BOLD BOLD) (ITALICS ITALICS) (UNDERLINE (UNDER- LINE)) (SUPERSCRIPT (SUPER/ SUB)) (LARGER (LARGER SMALLER)) (DEFAULTS DEFAULTS) (CASE CASE) (CENTER JUSTIFY) (AGAIN REDO) (HELP HELP)) '(Function Keys) 1)))) (RPAQQ KEY.TEMPLATE #*(78 48)OOOOOOOOOOOOOOOOOOOLON@@@@@@@@@@@@@@@AOLO@@@@@@@@@@@@@@@@@CLO@@@@@@@@@@@@@@@@@CLMH@@@@@@@@@@@@@@@@DLNLGOOOOOOOOOOOOOOHHLMFL@@@@@@@@@@@@@@M@LJK@@@@@@@@@@@@@@@B@DMF@@@@@@@@@@@@@@@A@DJN@@@@@@@@@@@@@@@AHDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMF@@@@@@@@@@@@@@@AHDJJ@@@@@@@@@@@@@@@A@DMG@@@@@@@@@@@@@@@B@DNEL@@@@@@@@@@@@@@O@LLIGOOOOOOOOOOOOOOMHLOBBJJJJJJJJJJJJJJJLLNDEEEEEEEEEEEEEEEEGLOHJJJJJJJJJJJJJJJJKLOLEEEEEEEEEEEEEEEEOLOOOOOOOOOOOOOOOOOOOL ) (DEFINEQ (BUILDFNKEYS [LAMBDA (KEYS TITLE NROWS) (* lmm " 5-Nov-85 15:35") (SHRINKW (ADDMENU [create MENU ITEMS _ [for KEY in KEYS collect (LIST (KEY.BITMAP (CADR KEY)) (LET [(KEYN (OR (SMALLP (CAR KEY)) (\KEYNAMETONUMBER (CAR KEY] (for LST in (LIST \DOVEKEYACTIONS \DLIONKEYACTIONS \ORIGKEYACTIONS) do (AND [SETQ $$VAL (for KEY in LST when (EQ (OR (SMALLP (CAR KEY)) (\KEYNAMETONUMBER (CAR KEY))) KEYN) do (RETURN (CADR KEY] (RETURN (LIST (OR (SMALLP (CAR $$VAL)) (CHARCODE.DECODE (CAR $$VAL))) (OR (SMALLP (CADR $$VAL)) (CHARCODE.DECODE (CADR $$VAL] TITLE _ (SUBSTRING TITLE 2 -2) MENUROWS _ NROWS WHENSELECTEDFN _ (FUNCTION (LAMBDA (X) (BKSYSCHARCODE (if (SHIFTDOWNP 'SHIFT) then (CADR (CADR X)) else (CAR (CADR X] NIL (create POSITION XCOORD _ (PLUS (DIFFERENCE (QUOTIENT SCREENWIDTH 2) (QUOTIENT (TIMES (BITMAPWIDTH KEY.TEMPLATE) (LENGTH KEYS)) 2)) (TIMES 2 WBorder)) YCOORD _ 0)) (KEY.BITMAP TITLE) '(0 . 0]) (KEY.BITMAP [LAMBDA (X) (* lmm " 5-Nov-85 14:04") (PROG ((BITMAP (BITMAPCOPY KEY.TEMPLATE)) DS QUARTER REGION) (SETQ DS (DSPCREATE BITMAP)) (DSPFONT MENUFONT DS) (COND ((LISTP X) (* this is supposed to have two labels, one on top of the other) (SETQ QUARTER (IQUOTIENT (BITMAPHEIGHT BITMAP) 4)) (CENTERPRINTINREGION (CADR X) (SETQ REGION (create REGION LEFT _ 0 BOTTOM _ QUARTER WIDTH _ (BITMAPWIDTH BITMAP) HEIGHT _ QUARTER)) DS) (replace BOTTOM of REGION with (ITIMES 2 QUARTER)) (CENTERPRINTINREGION (CAR X) REGION DS)) (T (CENTERPRINTINREGION X (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (BITMAPWIDTH BITMAP) HEIGHT _ (BITMAPHEIGHT BITMAP)) DS))) (RETURN BITMAP]) ) (* could have (STRIKEOUT)) (BUILDFNKEYS '((BOLD BOLD) (ITALICS ITALICS) (UNDERLINE (UNDER- LINE)) (SUPERSCRIPT (SUPER/ SUB)) (LARGER (LARGER SMALLER)) (DEFAULTS DEFAULTS) (CASE CASE) (CENTER JUSTIFY) (AGAIN REDO) (HELP HELP)) '(Function Keys) 1) (PUTPROPS EDITKEYS COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2077 5483 (BUILDFNKEYS 2087 . 4099) (KEY.BITMAP 4101 . 5481))))) STOP \ No newline at end of file diff --git a/lispusers/EDITKEYS.TEDIT b/lispusers/EDITKEYS.TEDIT new file mode 100644 index 00000000..32ed4d68 Binary files /dev/null and b/lispusers/EDITKEYS.TEDIT differ diff --git a/lispusers/EMACS b/lispusers/EMACS new file mode 100644 index 00000000..4b9abe8a --- /dev/null +++ b/lispusers/EMACS @@ -0,0 +1 @@ +(FILECREATED "27-Jul-86 17:26:37" {ERIS}LISPCORE>EMACS.;7 102965 changes to: (FNS EMACS.OPERATE) previous date: "12-Jul-86 16:55:09" {ERIS}LISPCORE>EMACS.;6) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT EMACSCOMS) (RPAQQ EMACSCOMS ((* EMACS -- By Kelly Roach *) (COMS (* EMACS *) (INITVARS (BytesPerPage 512) (EMACS.COMMANDS NIL) (EMACS.MCOMMANDS NIL) (EMACS.XCOMMANDS NIL) (EMACS.LIST '((1 EMACS.GOTO.BOL) (2 EMACS.BACK.BYTE) (4 EMACS.FWD.DELETE.BYTE) (5 EMACS.GOTO.EOL) (6 EMACS.FWD.BYTE) (9 EMACS.TAB) (11 EMACS.KILL.LINE) (12 EMACS.REDISPLAY) (14 EMACS.NEXT.LINE) (16 EMACS.PREVIOUS.LINE) (17 EMACS.QUOTE.BYTE) (19 EMACS.SEARCH) (20 EMACS.TRANSPOSE.BYTES) (22 EMACS.NEXT.SCREENFULL) (24 EMACS.CX) (26 EMACS.CZ) (41 EMACS.RPAREN) (93 EMACS.RBRACKET) (125 EMACS.RBRACE) (127 EMACS.BACK.DELETE.BYTE))) (EMACS.MLIST '((1 EMACS.GOTO.BOD) (2 EMACS.SAFE.BACK.SEXPR) (5 EMACS.GOTO.EOD) (6 EMACS.FWD.SEXPR) (11 EMACS.KILL.SEXPR) (60 EMACS.GOTO.BOF) (62 EMACS.GOTO.EOF) (66 EMACS.BACK.WORD) (68 EMACS.FWD.DELETE.WORD) (69 EMACS.EDIT) (70 EMACS.FWD.WORD) (71 EMACS.GRIND) (52 EMACS.SNARF) (86 EMACS.PREVIOUS.SCREENFULL) (94 EMACS.JOIN.LINES) (127 EMACS.BACK.DELETE.WORD))) (EMACS.XLIST '((22 EMACS.CXCV) (23 EMACS.CXCW) (26 EMACS.CXCZ))) (\BQUOTE.LEVEL 0)) (RECORDS EMACSSTREAM) (FNS EMACS.INIT EMACS.INIT.BACKGROUND DEDITEmacs EMACS.INIT.COMMANDS EMACS.COMMAND EMACS.OPERATE EMACS.GETKEY EMACS EMACS.PROCESS EMACS.TEDIT1 EMACS.WINDOW EMACS.SETFILEPTR EMACS.GETCARETPTR EMACS.SETCARETPTR EMACS.SHOWCARET EMACS.BOL EMACS.EOL EMACS.DELETE.BYTES EMACS.BOFP EMACS.EOFP EMACS.CCHAR EMACS.PEEKBIN EMACS.FBYTE EMACS.FWORD EMACS.BYTEP EMACS.FSKIP EMACS.FSKIPTO EMACS.BBYTE EMACS.BCHAR EMACS.BPEEKCHAR EMACS.BWORD EMACS.BSKIP EMACS.BSKIPTO EMACS.SET.EOF EMACS.GOTO.BOL EMACS.BACK.BYTE EMACS.FWD.DELETE.BYTE EMACS.GOTO.EOL EMACS.FWD.BYTE EMACS.KILL.LINE EMACS.DELETE.CHARS EMACS.REDISPLAY EMACS.NEXT.LINE EMACS.PREVIOUS.LINE EMACS.QUOTE.BYTE EMACS.SEARCH EMACS.TRANSPOSE.BYTES EMACS.NEXT.SCREENFULL EMACS.CXCV EMACS.CXCW EMACS.CXCZ EMACS.FWD.SEXPR EMACS.BACK.DELETE.BYTE EMACS.GOTO.BOD EMACS.BOD EMACS.GOTO.EOD EMACS.EOD EMACS.KILL.SEXPR EMACS.GOTO.BOF EMACS.GOTO.EOF EMACS.BACK.WORD EMACS.FWD.DELETE.WORD EMACS.EDIT EMACS.FWD.WORD EMACS.GRIND EMACS.SNARF EMACS.MT EMACS.PREVIOUS.SCREENFULL EMACS.JOIN.LINES EMACS.BACK.DELETE.WORD NEW.TEDIT.SELECT.LINE.SCANNER) (FNS \TEDIT1 \TEDIT.COMMAND.LOOP)) (COMS (* BALANCE *) (PROPS (ACCESSFNS EMACS.TAB) (DATATYPE EMACS.TAB) (DEFEXPR EMACS.TAB) (DEFFEXPR EMACS.TAB) (DEFVAR EMACS.TAB) (DO EMACS.TAB) (FOR EMACS.TAB) (LAMBDA EMACS.TAB) (PROG EMACS.TAB) (RECORD EMACS.TAB) (SELECT EMACS.TAB) (SELECTQ EMACS.TAB) (UNTIL EMACS.TAB) (WHILE EMACS.TAB)) (INITVARS (EMACS.DELIMS NIL) (EMACS.SDELIMS NIL) (EMACS.LDELIMS NIL) (EMACS.RDELIMS NIL) (EMACS.SCACHE NIL) (EMACS.BCACHE NIL) (EMACS.SYNTAX NIL) (EMACS.CR 1) (EMACS.WS 2) (EMACS.SD 4) (EMACS.NONCR 8) (EMACS.NONWS 16) (EMACS.NONSD 32) (EMACS.BQ 64) (EMACS.ALPHA 128) (EMACS.BD 256) (EMACS.SPACE 512)) (FNS EMACS.DELIMS EMACS.CR EMACS.RPAREN EMACS.RBRACKET EMACS.RBRACE EMACS.RANGLE EMACS.SDELIM.COMMAND EMACS.LDELIM.COMMAND EMACS.RDELIM.COMMAND EMACS.SDELIM EMACS.LDELIM EMACS.RDELIM EMACS.OPEN.STRING EMACS.CLOSE.STRING EMACS.OPEN.BALANCE EMACS.CLOSE.BALANCE EMACS.FLUSH.CACHE EMACS.SCACHE EMACS.BCACHE EMACS.SAFE.BACK.SEXPRS EMACS.SAFE.BACK.SEXPR EMACS.BACK.SEXPR EMACS.BACK.WORD EMACS.BACK.SKIPSEPRS EMACS.BACK.ESCAPEDP EMACS.TAB EMACS.TAB.INDENT EMACS.INIT.SYNTAX)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (EMACS.INIT) (MOVD? 'TEDIT.SELECT.LINE.SCANNER ' OLD.TEDIT.SELECT.LINE.SCANNER) (MOVD 'NEW.TEDIT.SELECT.LINE.SCANNER ' TEDIT.SELECT.LINE.SCANNER) (MOVD 'EMACS 'TEDIT))))) (* EMACS -- By Kelly Roach *) (* EMACS *) (RPAQ? BytesPerPage 512) (RPAQ? EMACS.COMMANDS NIL) (RPAQ? EMACS.MCOMMANDS NIL) (RPAQ? EMACS.XCOMMANDS NIL) (RPAQ? EMACS.LIST '((1 EMACS.GOTO.BOL) (2 EMACS.BACK.BYTE) (4 EMACS.FWD.DELETE.BYTE) (5 EMACS.GOTO.EOL) (6 EMACS.FWD.BYTE) (9 EMACS.TAB) (11 EMACS.KILL.LINE) (12 EMACS.REDISPLAY) (14 EMACS.NEXT.LINE) (16 EMACS.PREVIOUS.LINE) (17 EMACS.QUOTE.BYTE) (19 EMACS.SEARCH) (20 EMACS.TRANSPOSE.BYTES) (22 EMACS.NEXT.SCREENFULL) (24 EMACS.CX) (26 EMACS.CZ) (41 EMACS.RPAREN) (93 EMACS.RBRACKET) (125 EMACS.RBRACE) (127 EMACS.BACK.DELETE.BYTE))) (RPAQ? EMACS.MLIST '((1 EMACS.GOTO.BOD) (2 EMACS.SAFE.BACK.SEXPR) (5 EMACS.GOTO.EOD) (6 EMACS.FWD.SEXPR) (11 EMACS.KILL.SEXPR) (60 EMACS.GOTO.BOF) (62 EMACS.GOTO.EOF) (66 EMACS.BACK.WORD) (68 EMACS.FWD.DELETE.WORD) (69 EMACS.EDIT) (70 EMACS.FWD.WORD) (71 EMACS.GRIND) (52 EMACS.SNARF) (86 EMACS.PREVIOUS.SCREENFULL) (94 EMACS.JOIN.LINES) (127 EMACS.BACK.DELETE.WORD))) (RPAQ? EMACS.XLIST '((22 EMACS.CXCV) (23 EMACS.CXCW) (26 EMACS.CXCZ))) (RPAQ? \BQUOTE.LEVEL 0) [DECLARE: EVAL@COMPILE (ACCESSFNS EMACSSTREAM ((TEXTOBJ (fetch (STREAM F3) of DATUM)) (WINDOW (fetch (TEXTOBJ SELWINDOW) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (SELECTION (fetch (TEXTOBJ SEL) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (CARETPTR (EMACS.GETCARETPTR DATUM)) (FILEPTR (GETFILEPTR DATUM)) (DIRTY (fetch (TEXTOBJ \DIRTY) of (fetch (EMACSSTREAM TEXTOBJ) of DATUM))) (BCACHE (EMACS.BCACHE DATUM)) (SCACHE (EMACS.SCACHE DATUM)))) ] (DEFINEQ (EMACS.INIT (LAMBDA NIL (* kbr: "12-Jul-86 16:54") (* Initializes EMACS.  *) (PROG NIL (SETQ TEDIT.INTERRUPTS (QUOTE ((7 HELP)))) (SETQ EMACS.READTABLE (COPYREADTABLE FILERDTBL)) (EMACS.INIT.COMMANDS) (EMACS.INIT.SYNTAX) (EMACS.INIT.BACKGROUND) (ADDTOVAR *DEDIT-MENU-COMMANDS* (Emacs DEDITEmacs)) (CHANGECCODE (QUOTE NILL) (QUOTE TTYDISPLAYSTREAM) (QUOTE \TEDIT.COMMAND.LOOP))))) (EMACS.INIT.BACKGROUND (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (* Fix up BackgroundMenu. *) (PROG NIL (SETQ BackgroundMenuCommands (FOR BUCKET IN BackgroundMenuCommands WHEN (NOT (EQ (CAR BUCKET) (QUOTE TEdit))) COLLECT BUCKET)) (ADDTOVAR BackgroundMenuCommands (EMACS (QUOTE (EMACS)) "Opens an Edit Window.")) (SETQ BackgroundMenu NIL) (* BackgroundMenu recreated by WINDOW package next time user buttons background. *) ))) (DEDITEmacs (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (* Fn to let DEDIT call EMACS on DEDIT top selection. *) (PROG (EXPR) (CURSOR T) (SETQ EXPR (CAR (TOPSELECTION))) (SETQ EXPR (READ (EMACS (MKSTRING EXPR) NIL T) EMACS.READTABLE)) (DEDITZAPCAR (TOPSELECTION) EXPR)))) (EMACS.INIT.COMMANDS (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (* Initialize TEDIT.READTABLE. *) (PROG NIL (SETQ EMACS.COMMANDS (ARRAY 128 (QUOTE POINTER) NIL 0)) (SETQ EMACS.MCOMMANDS (ARRAY 128 (QUOTE POINTER) NIL 0)) (SETQ EMACS.XCOMMANDS (ARRAY 128 (QUOTE POINTER) NIL 0)) (FOR BUCKET IN EMACS.LIST DO (SETA EMACS.COMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR BUCKET IN EMACS.MLIST DO (SETA EMACS.MCOMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR BUCKET IN EMACS.XLIST DO (SETA EMACS.XCOMMANDS (CAR BUCKET) (CADR BUCKET))) (FOR I FROM 0 TO 255 DO (TEDIT.SETFUNCTION I (EMACS.COMMAND I) TEDIT.READTABLE))))) (EMACS.COMMAND (LAMBDA (I) (* kbr: "24-Jul-85 16:36") (BQUOTE (LAMBDA (STREAM) (EMACS.OPERATE (\, I) STREAM))))) (EMACS.OPERATE (LAMBDA (STREAM) (* kbr: "27-Jul-86 17:26") (* Accept token from user *) (PROG (TEXTOBJ I N FN PTR CH) (TTYDISPLAYSTREAM (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ TEXTOBJ (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (while (\SYSBUFP) do (* Handle user type-in) (SETQ I (\GETKEY)) (SETFILEPTR STREAM (fetch (EMACSSTREAM CARETPTR) of STREAM)) (SETQ N 1) (while (EQ I (CHARCODE ^U)) do (SETQ N (ITIMES 4 N)) (SETQ I (\GETKEY))) (SELCHARQ I ((ESC ^Z) (SETQ FN (ELT EMACS.MCOMMANDS (\GETKEY)))) (^X (SETQ FN (ELT EMACS.XCOMMANDS (\GETKEY)))) (COND ((ILESSP I 128) (SETQ FN (ELT EMACS.COMMANDS I))) ((ILESSP I 256) (SETQ FN (ELT EMACS.MCOMMANDS (IDIFFERENCE I 128)))))) (COND ((NULL FN) (* Insert char I N times. *) (* Handle blue pending delete, if there is one.) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (SETQ PTR (GETFILEPTR STREAM)) (COND ((AND (NOT (ZEROP PTR)) (EQ (\BACKPEEKBIN STREAM) (CHARCODE CR)) (NOT (MEMB I (CHARCODE (SP TAB))))) (* Start of a def *) (EMACS.FLUSH.CACHE))) (COND ((IEQP N 1) (TEDIT.\INSERT I SEL TEXTOBJ)) (T (SETQ CH (MKSTRING (CHARACTER I))) (TEDIT.INSERT STREAM (ALLOCSTRING N CH)))) (SETFILEPTR STREAM (IPLUS PTR N))) (T (for J from 1 to N do (APPLY* FN STREAM)) (COND ((AND (ILESSP I 256) (NOT (BITTEST (ELT EMACS.SYNTAX I) (LOGOR EMACS.CR EMACS.SD EMACS.BD)))) (EMACS.FLUSH.CACHE)))))) (EMACS.SHOWCARET STREAM)))) (EMACS.GETKEY (LAMBDA NIL (* kbr: "24-Jul-85 16:36") (PROG (CODE) (CARET (QUOTE OFF)) (SETQ CODE (\GETKEY)) (CARET T) (RETURN CODE)))) (EMACS (LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* kbr: "24-Jul-85 16:36") (PROG (PROCESS) (* Get TEXT. *) (COND ((AND (NOT (NULL TEXT)) (LITATOM TEXT)) (SETQ TEXT (OPENFILE TEXT (QUOTE INPUT) (QUOTE OLD))))) (* Get WINDOW. *) (COND ((NULL WINDOW) (SETQ WINDOW (EMACS.WINDOW DONTSPAWN PROPS)))) (COND (DONTSPAWN (* Don't spawn a process. *) (RETURN (EMACS.TEDIT1 TEXT WINDOW T PROPS))) (T (* Spawn a process. *) (SETQ PROCESS (ADD.PROCESS (BQUOTE (EMACS.PROCESS (QUOTE (\, TEXT)) (QUOTE (\, WINDOW)) (QUOTE (\, PROPS)))) (QUOTE EMACS) (QUOTE NO))) (TTY.PROCESS PROCESS) (RETURN PROCESS)))))) (EMACS.PROCESS (LAMBDA (TEXT WINDOW PROPS) (* kbr: "24-Jul-85 16:36") (PROG NIL (WINDOWPROP WINDOW (QUOTE PROCESS) (THIS.PROCESS)) (RETURN (EMACS.TEDIT1 TEXT WINDOW NIL PROPS))))) (EMACS.TEDIT1 (LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* kbr: "24-Jul-85 16:36") (PROG (ANSWER) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (RESETSAVE NIL (LIST (QUOTE INPUT) (INFILE T))) (RESETSAVE NIL (LIST (QUOTE OUTPUT) (OUTFILE T))) (SETQ ANSWER (\TEDIT1 TEXT WINDOW UNSPAWNED PROPS))) (RETURN ANSWER)))) (EMACS.WINDOW (LAMBDA (DONTSPAWN PROPS) (* kbr: "24-Jul-85 16:36") (PROG (WINDOW) (COND ((AND DONTSPAWN TEDIT.DEFAULT.WINDOW) (SETQ WINDOW TEDIT.DEFAULT.WINDOW)) (T (SETQ WINDOW (TEDIT.CREATEW "Indicate region for EMACS")))) (WINDOWPROP WINDOW (QUOTE TEDIT.PROPS) PROPS) (RETURN WINDOW)))) (EMACS.SETFILEPTR (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* Patch around bug in TEDIT SETFILEPTR. *) (PROG NIL (COND ((IGREATERP (GETEOFPTR STREAM) 0) (SETFILEPTR STREAM PTR) (SETFILEPTR STREAM PTR)))))) (EMACS.GETCARETPTR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (PROG (SELECTION ANSWER) (SETQ SELECTION (fetch (EMACSSTREAM SELECTION) of STREAM)) (SETQ ANSWER (SELECTQ (fetch (SELECTION POINT) of SELECTION) (LEFT (SUB1 (fetch (SELECTION CH#) of SELECTION))) (RIGHT (fetch (SELECTION CHLIM) of SELECTION)) (SHOULDNT))) (RETURN ANSWER)))) (EMACS.SETCARETPTR (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* Move caret to new filepos. *) (PROG (EOF) (SETQ EOF (GETEOFPTR STREAM)) (SETQ PTR (IMIN (IMAX PTR 0) EOF)) (TEDIT.SETSEL STREAM (ADD1 PTR) 0 (QUOTE LEFT)) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.SHOWCARET (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.SETCARETPTR STREAM PTR) (TEDIT.NORMALIZECARET (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.BOL (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* Beginning of line wrt filepos PTR. *) (PROG (OLDPTR BOL) (SETQ OLDPTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.BSKIP STREAM EMACS.NONCR) (SETQ BOL (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM OLDPTR) (RETURN BOL)))) (EMACS.EOL (LAMBDA (STREAM PTR) (* kbr: "24-Jul-85 16:36") (* End of line wrt filepos PTR. *) (PROG (OLDPTR EOL) (SETQ OLDPTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.FSKIP STREAM EMACS.NONCR) (SETQ EOL (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM OLDPTR) (RETURN EOL)))) (EMACS.DELETE.BYTES (LAMBDA (STREAM PTR1 PTR2) (* kbr: "19-Feb-85 15:11") (* Delete between PTR1 & PTR2 inclusive. *) (PROG (PTR LENGTH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ PTR1 (IMAX 0 PTR1)) (SETQ PTR2 (IMIN (GETEOFPTR STREAM) PTR2)) (SETQ LENGTH (IPLUS PTR2 (IMINUS PTR1) 1)) (TEDIT.DELETE STREAM (ADD1 PTR1) LENGTH) (COND ((ILEQ PTR PTR1) (EMACS.SETFILEPTR STREAM PTR)) ((ILEQ PTR PTR2) (EMACS.SETFILEPTR STREAM PTR1)) (T (EMACS.SETFILEPTR STREAM (IDIFFERENCE PTR LENGTH))))))) (EMACS.BOFP (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (ZEROP (GETFILEPTR STREAM)))) (EMACS.EOFP (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (IEQP (GETFILEPTR STREAM) (GETEOFPTR STREAM)))) (EMACS.CCHAR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Caret char. Char being pointed at by caret. *) (PROG (ANSWER) (SETQ ANSWER (\BIN STREAM)) (\BACKBIN STREAM) (RETURN ANSWER)))) (EMACS.PEEKBIN (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (SETQ ANSWER (\BIN STREAM)) (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.FBYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:11") (* Forward a char. *) (COND ((NOT (EMACS.EOFP STREAM)) (\BIN STREAM))))) (EMACS.FWORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Forward a word. *) (PROG NIL (EMACS.FSKIP STREAM EMACS.WS) (EMACS.FSKIP STREAM EMACS.NONWS)))) (EMACS.BYTEP (LAMBDA (N) (* kbr: "24-Jul-85 16:38") (AND (SMALLP N) (ILESSP N 256) N))) (EMACS.FSKIP (LAMBDA (STREAM CLASS LIMIT) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (COND ((NULL LIMIT) (SETQ LIMIT (GETEOFPTR STREAM)))) (PROG NIL (while (AND (ILESSP (GETFILEPTR STREAM) LIMIT) (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (EMACS.PEEKBIN STREAM)) 256)) CLASS)) do (\BIN STREAM))))) (EMACS.FSKIPTO (LAMBDA (STREAM CLASS) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (PROG NIL (WHILE (AND (NOT (EMACS.EOFP STREAM)) (NOT (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BIN STREAM)) 256)) CLASS))) DO (* Continue reading. *))))) (EMACS.BBYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Backward a byte. *) (COND ((NOT (EMACS.BOFP STREAM)) (\BACKBIN STREAM))))) (EMACS.BCHAR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a char. *) (PROG NIL (COND ((NOT (EMACS.BOFP STREAM)) (\BACKBIN STREAM)))))) (EMACS.BPEEKCHAR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Backwards peek at char. *) (PROG (PTR BYTE) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BYTE (EMACS.BCHAR STREAM)) (SETFILEPTR STREAM PTR) (RETURN BYTE)))) (EMACS.BWORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a word. *) (PROG NIL (EMACS.BSKIP STREAM EMACS.WS) (EMACS.BSKIP STREAM EMACS.NONWS)))) (EMACS.BSKIP (LAMBDA (STREAM CLASS LIMIT) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (COND ((NULL LIMIT) (SETQ LIMIT 0))) (PROG NIL (while (AND (IGREATERP (GETFILEPTR STREAM) LIMIT) (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BACKPEEKBIN STREAM)) 256)) CLASS)) do (\BACKBIN STREAM))))) (EMACS.BSKIPTO (LAMBDA (STREAM CLASS) (* kbr: "24-Jul-85 16:36") (* Skip chars in CLASS. *) (PROG NIL (WHILE (AND (NOT (EMACS.BOFP STREAM)) (NOT (BITTEST (ELT EMACS.SYNTAX (OR (EMACS.BYTEP (\BACKBIN STREAM)) 256)) CLASS))) DO (* Continue reading. *))))) (EMACS.SET.EOF (LAMBDA (STREAM PTR) (* kbr: "19-Feb-85 15:12") (* Temporarily reset eof of STREAM. *) (PROG NIL (replace (STREAM EPAGE) of STREAM with (LRSH PTR 8)) (replace (STREAM EOFFSET) of STREAM with (LOGAND PTR 255)) (replace (TEXTOBJ TEXTLEN) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with PTR)))) (EMACS.GOTO.BOL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to beginning of line. *) (PROG NIL (EMACS.BSKIP STREAM EMACS.NONCR)))) (EMACS.BACK.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Go back a byte. *) (PROG NIL (EMACS.BBYTE STREAM)))) (EMACS.FWD.DELETE.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Delete byte. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.DELETE.BYTES STREAM PTR PTR)))) (EMACS.GOTO.EOL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to end of line. *) (PROG NIL (EMACS.FSKIP STREAM EMACS.NONCR)))) (EMACS.FWD.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Go forward a byte. *) (PROG NIL (EMACS.FBYTE STREAM)))) (EMACS.KILL.LINE (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete a line. *) (PROG (PTR EOL) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.FSKIP STREAM EMACS.NONCR) (SETQ EOL (GETFILEPTR STREAM)) (COND ((IGREATERP EOL PTR) (EMACS.DELETE.CHARS STREAM PTR (SUB1 EOL))) ((ILESSP EOL (GETEOFPTR STREAM)) (EMACS.DELETE.CHARS STREAM EOL EOL))) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.DELETE.CHARS (LAMBDA (STREAM PTR1 PTR2) (* kbr: "18-Jun-86 23:23") (* Delete between PTR1 & PTR2 inclusive. *) (PROG (PTR LENGTH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ PTR1 (IMAX 0 PTR1)) (SETQ PTR2 (IMIN (GETEOFPTR STREAM) PTR2)) (SETQ LENGTH (IPLUS PTR2 (IMINUS PTR1) 1)) (TEDIT.DELETE STREAM (ADD1 PTR1) LENGTH) (COND ((ILEQ PTR PTR1) (SETFILEPTR STREAM PTR)) ((ILEQ PTR PTR2) (SETFILEPTR STREAM PTR1)) (T (SETFILEPTR STREAM (IDIFFERENCE PTR LENGTH))))))) (EMACS.REDISPLAY (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Redisplay EMACS screen. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (REDISPLAYW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.NEXT.LINE (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go down a line. *) (PROG (PTR BOL EOL NBOL NEOL OFFSET) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* First char on line is at OFFSET = 0.0 *) (SETQ OFFSET (IPLUS PTR (IMINUS BOL))) (SETQ EOL (EMACS.EOL STREAM PTR)) (SETQ NBOL (ADD1 EOL)) (COND ((ILEQ (GETEOFPTR STREAM) NBOL) (EMACS.SETFILEPTR STREAM (GETEOFPTR STREAM))) (T (SETQ NEOL (EMACS.EOL STREAM NBOL)) (SETQ OFFSET (IMIN OFFSET (IDIFFERENCE NEOL NBOL))) (EMACS.SETFILEPTR STREAM (IPLUS NBOL OFFSET))))))) (EMACS.PREVIOUS.LINE (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go up a line. *) (PROG (PTR BOL PBOL PEOL OFFSET) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* First char on line is at OFFSET = 0.0 *) (SETQ OFFSET (IPLUS PTR (IMINUS BOL))) (SETQ PEOL (SUB1 BOL)) (COND ((IGEQ 0 PEOL) (EMACS.SETFILEPTR STREAM 0)) (T (SETQ PBOL (EMACS.BOL STREAM PEOL)) (SETQ OFFSET (IMIN OFFSET (IDIFFERENCE PEOL PBOL))) (EMACS.SETFILEPTR STREAM (IPLUS PBOL OFFSET))))))) (EMACS.QUOTE.BYTE (LAMBDA (STREAM) (* kbr: "18-Jun-86 22:59") (* Quote next byte. *) (PROG (PTR CH) (* TBW: Fix use TEDIT's use of terminal table. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ CH (\GETKEY)) (TEDIT.INSERT STREAM CH (ADD1 PTR)) (EMACS.SETFILEPTR STREAM (ADD1 PTR))))) (EMACS.SEARCH (LAMBDA (STREAM) (* kbr: "18-Jun-86 23:12") (* Case sensitive search, with "*" and "#" wildcards  *) (PROG (PTR TEXTOBJ W OFILE SEL CH) (SETQ PTR (GETFILEPTR STREAM)) (SETQ TEXTOBJ (fetch (EMACSSTREAM TEXTOBJ) of STREAM)) (SETQ W (fetch (EMACSSTREAM WINDOW) of STREAM)) (ERSETQ (RESETLST (RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) (QUOTE (AND (\TEDIT.MARKINACTIVE OLDVALUE)))) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with (QUOTE Find)) (SETQ OFILE (WINDOWPROP W (QUOTE TEDIT.LAST.FIND.STRING))) (SETQ OFILE (TEDIT.GETINPUT STREAM "Text to find: " OFILE (CHARCODE (EOL LF ESC ^S)))) (COND (OFILE (WINDOWPROP W (QUOTE TEDIT.LAST.FIND.STRING) OFILE) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING OFILE) NIL NIL T))) (COND (CH (* We found the target text.) (* Set up SELECTION to be the found text) (replace (SELECTION CH#) of SEL with (CAR CH)) (replace (SELECTION CHLIM) of SEL with (CADR CH)) (replace (SELECTION DCH) of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (replace (SELECTION POINT) of SEL with (QUOTE RIGHT)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (EMACS.SETFILEPTR STREAM (EMACS.GETCARETPTR STREAM)) (* And get it into the window *) ) (T (FRESHLINE PROMPTWINDOW) (printout PROMPTWINDOW "String '" OFILE "' not found." T) (\SHOWSEL SEL NIL T) (EMACS.SETFILEPTR STREAM PTR))))) (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with -1)))))) (EMACS.TRANSPOSE.BYTES (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Transpose bytes. *) (PROG (PTR CODE CH) (COND ((OR (EMACS.BOFP STREAM) (EMACS.EOFP STREAM)) (RETURN))) (SETQ PTR (GETFILEPTR STREAM)) (SETQ CODE (\BIN STREAM)) (COND ((NUMBERP CODE) (SETQ CH (MKSTRING (CHARACTER CODE)))) (T (* IMAGEOBJ *) (SETQ CH CODE))) (EMACS.DELETE.BYTES STREAM PTR PTR) (EMACS.SETFILEPTR STREAM (SUB1 PTR)) (TEDIT.INSERT STREAM CH PTR) (EMACS.SETFILEPTR STREAM (ADD1 PTR))))) (EMACS.NEXT.SCREENFULL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Forward one screenfull. *) (PROG (WINDOW DELTAX DELTAY) (SETQ WINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ DELTAX 0) (SETQ DELTAY (IDIFFERENCE (WINDOWPROP WINDOW (QUOTE HEIGHT)) (FONTPROP (DSPFONT NIL WINDOW) (QUOTE HEIGHT)))) (replace (TEXTOBJ EDITOPACTIVE) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with NIL) (\TEDIT.SCROLLFN WINDOW DELTAX DELTAY)))) (EMACS.CXCV (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Visit a file. *) (PROG (FILE) (SETQ FILE (TEDIT.GETINPUT (fetch (EMACSSTREAM TEXTOBJ) of STREAM) "File to GET:")) (COND ((NULL FILE) (RETURN))) (COND ((fetch (EMACSSTREAM DIRTY) of STREAM) (EMACS.CXCW STREAM))) (TEDIT.GET (fetch (EMACSSTREAM TEXTOBJ) of STREAM) FILE) (EMACS.SETFILEPTR STREAM 0)))) (EMACS.CXCW (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Write buffer out to file. *) (PROG NIL (TEDIT.PUT (fetch (EMACSSTREAM TEXTOBJ) of STREAM))))) (EMACS.CXCZ (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Eval FORM in front of caret in lisp EXEC process. *) (PROG (FORM) (SETQ FORM (READ STREAM EMACS.READTABLE)) (PROCESS.EVAL (QUOTE EXEC) FORM)))) (EMACS.FWD.SEXPR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go forward a sexpr. *) (PROG NIL (RESETLST (* Accept uncaught BQUOTE commas. *) (RESETSAVE \BQUOTELEVEL (IQUOTIENT MAX.FIXP 2)) (READ STREAM EMACS.READTABLE))))) (EMACS.BACK.DELETE.BYTE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Delete byte in backwards direction. *) (* TBW: Delete selection if there is a selection. *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.DELETE.BYTES STREAM (SUB1 PTR) (SUB1 PTR))))) (EMACS.GOTO.BOD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to top of definition. *) (PROG (CODE) (* Find non-WS immediately preceded by CR. *) (EMACS.BCHAR STREAM) (DO (COND ((EMACS.BOFP STREAM) (RETURN))) (EMACS.BSKIP STREAM EMACS.NONCR) (COND ((BITTEST (ELT EMACS.SYNTAX (EMACS.CCHAR STREAM)) EMACS.NONWS) (RETURN))) (EMACS.BCHAR STREAM))))) (EMACS.BOD (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Determine top of definition. *) (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* Find lparen preceded by CR. *) (EMACS.BSKIP STREAM EMACS.CR) (DO (COND ((EMACS.BOFP STREAM) (RETURN))) (EMACS.BSKIP STREAM EMACS.NONCR) (COND ((EMACS.BOFP STREAM) (RETURN))) (COND ((OR (EMACS.BOFP STREAM) (EQ (\PEEKBIN STREAM) (CHARCODE "("))) (RETURN))) (EMACS.BBYTE STREAM)) (SETQ ANSWER (GETFILEPTR STREAM)) (SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.GOTO.EOD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to top of next definition. *) (PROG (CODE) (* Find non-WS immediately preceded by CR. *) (EMACS.FCHAR STREAM) (DO (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FSKIP STREAM EMACS.NONCR) (EMACS.FCHAR STREAM) (COND ((BITTEST (ELT EMACS.SYNTAX (EMACS.CCHAR STREAM)) EMACS.NONWS) (RETURN))))))) (EMACS.EOD (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:12") (* Determine top of next definition. *) (PROG (PTR ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* Find two CRs. *) (EMACS.FSKIP STREAM EMACS.CR) (DO (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FSKIP STREAM EMACS.NONCR) (COND ((EMACS.EOFP STREAM) (RETURN))) (EMACS.FBYTE STREAM) (COND ((OR (EMACS.EOFP STREAM) (EQ (\PEEKBIN STREAM) (CHARCODE CR))) (\BACKBIN STREAM) (RETURN)))) (SETQ ANSWER (GETFILEPTR STREAM)) (SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.KILL.SEXPR (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete expression. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (READ STREAM EMACS.READTABLE) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (EMACS.SETFILEPTR STREAM PTR1)))) (EMACS.GOTO.BOF (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to beginning of file. *) (PROG NIL (EMACS.SETFILEPTR STREAM 0)))) (EMACS.GOTO.EOF (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Go to end of file. *) (PROG NIL (EMACS.SETFILEPTR STREAM (GETEOFPTR STREAM))))) (EMACS.BACK.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a word. *) (PROG NIL (EMACS.BWORD STREAM)))) (EMACS.FWD.DELETE.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete word. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (EMACS.FSKIP STREAM EMACS.WS) (EMACS.FSKIP STREAM EMACS.NONWS) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (EMACS.SETFILEPTR STREAM PTR1)))) (EMACS.EDIT (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* DEDIT expression. *) (PROG (EXPR PTR1 PTR2) (SKIPSEPRS STREAM) (SETQ PTR1 (GETFILEPTR STREAM)) (SETQ EXPR (READ STREAM EMACS.READTABLE)) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (SETQ EXPR (EDITE EXPR)) (PRINTDEF EXPR NIL NIL NIL NIL STREAM)))) (EMACS.FWD.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Forward a word. *) (PROG NIL (EMACS.FWORD STREAM)))) (EMACS.GRIND (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Grind expression. *) (PROG (EXPR PTR1 PTR2) (SKIPSEPRS STREAM) (SETQ PTR1 (GETFILEPTR STREAM)) (SETQ EXPR (READ STREAM EMACS.READTABLE)) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (PRINTDEF EXPR NIL NIL NIL NIL STREAM)))) (EMACS.SNARF (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Snarf expression from DEDIT window. *) (PROG (EXPR) (SETQ EXPR (CAR (TOPSELECTION))) (PRINTDEF EXPR NIL NIL NIL NIL STREAM)))) (EMACS.MT (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Transpose words. *) (PROG (PTR BPTR1 BPTR2 FPTR1 FPTR2) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.BSKIP STREAM EMACS.WS) (SETQ BPTR2 (GETFILEPTR STREAM)) (EMACS.BWORD) (SETQ BPTR1 (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM PTR) (EMACS.FSKIP STREAM EMACS.WS) (SETQ FPTR1 (GETFILEPTR STREAM)) (EMACS.FWORD STREAM) (SETQ FPTR2 (GETFILEPTR STREAM)) (* How do I move? *) ))) (EMACS.PREVIOUS.SCREENFULL (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backwards a screenfull. *) (PROG (WINDOW DELTAX DELTAY) (SETQ WINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (SETQ DELTAX 0) (SETQ DELTAY (IDIFFERENCE (FONTPROP (DSPFONT NIL WINDOW) (QUOTE HEIGHT)) (WINDOWPROP WINDOW (QUOTE HEIGHT)))) (replace (TEXTOBJ EDITOPACTIVE) of (fetch (EMACSSTREAM TEXTOBJ) of STREAM) with NIL) (\TEDIT.SCROLLFN WINDOW DELTAX DELTAY)))) (EMACS.JOIN.LINES (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Move current line up *) (PROG (PTR BOL EOL PBOL PEOL PTR1 PTR2) (SETQ PTR (GETFILEPTR STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (SETQ EOL (EMACS.EOL STREAM PTR)) (COND ((ZEROP BOL) (RETURN))) (SETQ PEOL (SUB1 BOL)) (SETQ PBOL (EMACS.BOL STREAM PEOL)) (EMACS.SETFILEPTR STREAM BOL) (EMACS.BSKIP STREAM EMACS.WS) (SETQ PTR1 (IMAX (GETFILEPTR STREAM) PBOL)) (EMACS.SETFILEPTR STREAM BOL) (EMACS.FSKIP STREAM EMACS.WS) (SETQ PTR2 (IMIN (GETFILEPTR STREAM) (ADD1 EOL))) (EMACS.SETFILEPTR STREAM PTR1) (EMACS.DELETE.CHARS STREAM PTR1 (SUB1 PTR2)) (\BOUT STREAM (CHARCODE SP)) (EMACS.SETFILEPTR STREAM (ADD1 PTR1))))) (EMACS.BACK.DELETE.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Delete backward a word. *) (PROG (PTR1 PTR2) (SETQ PTR1 (GETFILEPTR STREAM)) (EMACS.BWORD STREAM) (SETQ PTR2 (GETFILEPTR STREAM)) (EMACS.DELETE.CHARS STREAM PTR2 (SUB1 PTR1))))) (NEW.TEDIT.SELECT.LINE.SCANNER (LAMBDA (X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW) (* kbr: "24-Jul-85 16:49") (PROG (SELECTION PTR) (SETQ SELECTION (OLD.TEDIT.SELECT.LINE.SCANNER X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW)) (COND ((EQ (TYPENAME SELECTION) (QUOTE SELECTION)) (replace (SELECTION POINT) of SELECTION with (QUOTE LEFT)) (EMACS.SETFILEPTR (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (SUB1 (fetch (SELECTION CH#) of SELECTION))))) (EMACS.FLUSH.CACHE) (RETURN SELECTION)))) ) (DEFINEQ (\TEDIT1 (LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* kbr: "11-Jun-86 23:06") (* Does the actual editing work, and  re-coercion or process kill when done.  Called by TEDIT directly, or  ADD.PROCESSed by it.) (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS)) (* Open the text for editing) (\TEDIT.COMMAND.LOOP TEXT) (* Run the editing engine) (CLOSEW WINDOW) (replace \WINDOW of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) with NIL) (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) (QUOTE AFTERQUITFN)) (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) (QUOTE AFTERQUITFN)) WINDOW TEXT)) (* Apply any post-window-close  (and post-QUIT) function) (COND (UNSPAWNED (* We're not a distinct process: Send  back the edited text in some suitable  form) (COND ((NEQ (fetch EDITFINISHEDFLG of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) T) (PROG1 (fetch EDITFINISHEDFLG of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) (replace EDITFINISHEDFLG of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) with NIL))) ((STRINGP (fetch TXTFILE of (fetch (TEXTSTREAM TEXTOBJ) of TEXT))) (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT) (QUOTE STRINGP))) (T TEXT)))))) (\TEDIT.COMMAND.LOOP (LAMBDA (STREAM RTBL) (* kbr: " 9-Jul-86 18:03") (* Main command loop for the TEDIT  editor. Includes keyboard polling and  command dispatch) (PROG (TEXTOBJ ISCRSTRING SEL WINDOW LINES IPASSSTRING TTYWINDOW) (COND ((type? STREAM STREAM) (SETQ TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) ((type? TEXTOBJ STREAM) (SETQ TEXTOBJ STREAM) (SETQ STREAM (TEXTSTREAM TEXTOBJ))) (T (HELP))) (SETQ ISCRSTRING (ALLOCSTRING \SCRATCHLEN " ")) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (SETQ WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) (SETQ IPASSSTRING (SUBSTRING ISCRSTRING 1)) (* Used inside \INSERT\TTY\BUFFER) (SETQ RTBL (OR RTBL (fetch (TEXTOBJ TXTRTBL) of TEXTOBJ) TEDIT.READTABLE)) (* Used to derive command characters  from type-in) (for WW inside WINDOW do (WINDOWPROP WW (QUOTE PROCESS) (THIS.PROCESS))) (* And the window to this process) (while (NOT (TTY.PROCESSP)) do (* Wait until we really have the TTY  before proceeding.) (DISMISS 250)) (TTYDISPLAYSTREAM (fetch (EMACSSTREAM WINDOW) of STREAM)) (RESETLST (RESETSAVE (\TEDIT.COMMAND.RESET.SETUP (LIST TEXTOBJ WINDOW) T)) (PROG (CH FN TCH DIRTY BLANKSEEN INSCH# CRSEEN TLEN CHNO READSA TERMSA TEDITSA TEDITFNHASH LOOPFN CHARFN COMMANDFN) (SETQ DIRTY NIL) (SETQ BLANKSEEN NIL) (SETQ CRSEEN NIL) (SETQ READSA (fetch (READTABLEP READSA) of #CURRENTRDTBL#)) (SETQ TERMSA (OR (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ) \PRIMTERMSA)) (SETQ TEDITSA (fetch (READTABLEP READSA) of RTBL)) (SETQ TEDITFNHASH (fetch (READTABLEP READMACRODEFS) of RTBL)) (SETQ LOOPFN (TEXTPROP TEXTOBJ (QUOTE LOOPFN))) (SETQ CHARFN (TEXTPROP TEXTOBJ (QUOTE CHARFN))) (while (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) do (ERSETQ (PROGN (\WAITFORSYSBUFP 25) (* Await type-in or mouse action) (while (OR TEDIT.SELPENDING (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ)) do (* Don't do anything while he's  selecting or one of the lock-out ops  is active.) (COND ((EQ TEDIT.SELPENDING TEXTOBJ) (* (OR (EQ TEDIT.SELPENDING TEXTOBJ)  (fetch TCUP of (fetch CARET of TEXTOBJ)))) (* If this TEdit is the one being  selected in, or the caret is  explicitly visible, flash it) (TEDIT.FLASHCARET (fetch (TEXTOBJ CARET) of TEXTOBJ)) )) (BLOCK)) (COND ((fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) (T (COND ((fetch (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ) (* We got here somehow with the window  not in sync with the text.  Run an update.) (\SHOWSEL SEL NIL NIL) (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (TEDIT.FLASHCARET (fetch (TEXTOBJ CARET) of TEXTOBJ)) (* Flash the caret periodically  (BUT not while we're here only to  cleanup and quit.)) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) (* Before starting to work, note that  we're doing something.) (* Process any pending selections) (ERSETQ (COND (TEDIT.COPY.PENDING (* Have to copy the shifted SEL to  caret.) (SETQ TEDIT.COPY.PENDING NIL) (\COPYSEL TEDIT.SHIFTEDSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) (TEDIT.COPY (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ)) (replace (SELECTION SET) of TEDIT.SHIFTEDSELECTION with NIL) (replace (SELECTION L1) of TEDIT.SHIFTEDSELECTION with NIL) (replace (SELECTION LN) of TEDIT.SHIFTEDSELECTION with NIL) (\COPYSEL TEDIT.SHIFTEDSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (TEDIT.COPYLOOKS.PENDING (* Have to copy the shifted SEL to  caret.) (SETQ TEDIT.COPYLOOKS.PENDING NIL) (\COPYSEL TEDIT.COPYLOOKSSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) (COND ((EQ (QUOTE PARA) (fetch (SELECTION SELKIND) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (* copy the paragraph looks, since the  source selection type was paragraph) (TEDIT.COPY.PARALOOKS TEXTOBJ (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ))) (T (* copy the character looks) (TEDIT.COPY.LOOKS TEXTOBJ (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ)))) (\SHOWSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) NIL NIL) (replace (SELECTION SET) of TEDIT.COPYLOOKSSELECTION with NIL) (replace (SELECTION L1) of TEDIT.COPYLOOKSSELECTION with NIL) (replace (SELECTION LN) of TEDIT.COPYLOOKSSELECTION with NIL) (\COPYSEL TEDIT.COPYLOOKSSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (TEDIT.MOVE.PENDING (* Have to move the ctrl-shift SEL to  caret.) (SETQ TEDIT.MOVE.PENDING NIL) (\COPYSEL TEDIT.MOVESELECTION (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ ) (TEDIT.MOVE (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ)) (replace (SELECTION SET) of TEDIT.MOVESELECTION with NIL) (replace (SELECTION L1) of TEDIT.MOVESELECTION with NIL) (replace (SELECTION LN) of TEDIT.MOVESELECTION with NIL) (\COPYSEL TEDIT.MOVESELECTION (fetch (TEXTOBJ MOVESEL) of TEXTOBJ))) (TEDIT.DEL.PENDING (* Delete the current selection.) (SETQ TEDIT.DEL.PENDING NIL) (* Above all, reset the demand flag  first) (COND ((fetch (SELECTION SET) of TEDIT.DELETESELECTION ) (* Only try the deletion if he really  set the selection.) (\SHOWSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) NIL NIL) (* Turn off the selection highlights) (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) with NIL) (\COPYSEL TEDIT.DELETESELECTION (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\TEDIT.SET.SEL.LOOKS (fetch (TEXTOBJ SEL) of TEXTOBJ) (QUOTE NORMAL)) (* Grab the selection we're to use) (\TEDIT.DELETE (fetch (TEXTOBJ SEL) of TEXTOBJ) (fetch (SELECTION \TEXTOBJ) of (fetch (TEXTOBJ SEL) of TEXTOBJ)) NIL) (replace (SELECTION L1) of TEDIT.DELETESELECTION with NIL) (replace (SELECTION LN) of TEDIT.DELETESELECTION with NIL)))))) (UNINTERRUPTABLY (replace (STRINGP OFFST) of ISCRSTRING with 0) (replace (STRINGP LENGTH) of ISCRSTRING with \SCRATCHLEN )) (COND ((\SYSBUFP) (ERSETQ (EMACS.OPERATE STREAM)))))) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL))) (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL))))))) ) (* BALANCE *) (PUTPROPS ACCESSFNS EMACS.TAB 2) (PUTPROPS DATATYPE EMACS.TAB 2) (PUTPROPS DEFEXPR EMACS.TAB 2) (PUTPROPS DEFFEXPR EMACS.TAB 2) (PUTPROPS DEFVAR EMACS.TAB 2) (PUTPROPS DO EMACS.TAB 1) (PUTPROPS FOR EMACS.TAB 1) (PUTPROPS LAMBDA EMACS.TAB 2) (PUTPROPS PROG EMACS.TAB 2) (PUTPROPS RECORD EMACS.TAB 2) (PUTPROPS SELECT EMACS.TAB 2) (PUTPROPS SELECTQ EMACS.TAB 2) (PUTPROPS UNTIL EMACS.TAB 1) (PUTPROPS WHILE EMACS.TAB 1) (RPAQ? EMACS.DELIMS NIL) (RPAQ? EMACS.SDELIMS NIL) (RPAQ? EMACS.LDELIMS NIL) (RPAQ? EMACS.RDELIMS NIL) (RPAQ? EMACS.SCACHE NIL) (RPAQ? EMACS.BCACHE NIL) (RPAQ? EMACS.SYNTAX NIL) (RPAQ? EMACS.CR 1) (RPAQ? EMACS.WS 2) (RPAQ? EMACS.SD 4) (RPAQ? EMACS.NONCR 8) (RPAQ? EMACS.NONWS 16) (RPAQ? EMACS.NONSD 32) (RPAQ? EMACS.BQ 64) (RPAQ? EMACS.ALPHA 128) (RPAQ? EMACS.BD 256) (RPAQ? EMACS.SPACE 512) (DEFINEQ (EMACS.DELIMS (LAMBDA (LCHARCODE RCHARCODE) (* kbr: "19-Feb-85 15:13") (* Make LCHARCODE & RCHARCODE into delimiters. If LCHARCODE = RCHARCODE, then string style. Otherwise paren style. *) (PROG (BUCKET) (SETQ BUCKET (CONS LCHARCODE RCHARCODE)) (COND ((MEMBER BUCKET EMACS.DELIMS) (* Already there. *) (RETURN))) (PUSH EMACS.DELIMS BUCKET) (COND ((IEQP LCHARCODE RCHARCODE) (SETSYNTAX LCHARCODE (QUOTE STRINGDELIM) EMACS.READTABLE) (SETA EMACS.SYNTAX LCHARCODE (LOGOR EMACS.NONWS EMACS.NONCR EMACS.SD)) (SETA EMACS.COMMANDS LCHARCODE (EMACS.SDELIM.COMMAND (MKSTRING (CHARACTER LCHARCODE)))) (PUSH EMACS.SDELIMS LCHARCODE)) (T (SETSYNTAX LCHARCODE (QUOTE LEFTPAREN) EMACS.READTABLE) (SETSYNTAX RCHARCODE (QUOTE RIGHTPAREN) EMACS.READTABLE) (FOR I IN (LIST LCHARCODE RCHARCODE) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONCR EMACS.NONWS EMACS.NONSD EMACS.BD))) (SETA EMACS.COMMANDS LCHARCODE (EMACS.LDELIM.COMMAND (MKSTRING (CHARACTER LCHARCODE)))) (SETA EMACS.COMMANDS RCHARCODE (EMACS.RDELIM.COMMAND (MKSTRING (CHARACTER RCHARCODE)))) (PUSH EMACS.LDELIMS LCHARCODE) (PUSH EMACS.RDELIMS RCHARCODE)))))) (EMACS.CR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM (CHARACTER (CHARCODE CR))) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((NOT (EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE))) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETCARETPTR STREAM EMACS.SCACHE) (DISMISS 1000) (EMACS.SETCARETPTR STREAM (ADD1 PTR)) (SETQ EMACS.SCACHE (QUOTE OUTSIDE)) (SETQ EMACS.BCACHE NIL)))))) (EMACS.RPAREN (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM ")") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.RBRACKET (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM "]") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.RBRACE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM "}") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.RANGLE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM ">") (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.SDELIM.COMMAND (LAMBDA (SDELIM) (* kbr: "19-Feb-85 15:14") (* Return sdelim fn to be inserted in EMACS.COMMANDS. SDELIM = 1 letter string. *) (PROG (ANSWER) (SETQ ANSWER (\BQUOTE (LAMBDA (STREAM) (EMACS.SDELIM (\COMMA SDELIM) STREAM)))) (RETURN ANSWER)))) (EMACS.LDELIM.COMMAND (LAMBDA (LDELIM) (* kbr: "19-Feb-85 15:14") (* Return LDELIM fn to be inserted in EMACS.COMMANDS. LDELIM = 1 letter string. *) (PROG (ANSWER) (SETQ ANSWER (\BQUOTE (LAMBDA (STREAM) (EMACS.LDELIM (\COMMA LDELIM) STREAM)))) (RETURN ANSWER)))) (EMACS.RDELIM.COMMAND (LAMBDA (RDELIM) (* kbr: "19-Feb-85 15:14") (* Return RDELIM fn to be inserted in EMACS.COMMANDS. RDELIM = 1 letter string. *) (PROG (ANSWER) (SETQ ANSWER (\BQUOTE (LAMBDA (STREAM) (EMACS.RDELIM (\COMMA RDELIM) STREAM)))) (RETURN ANSWER)))) (EMACS.SDELIM (LAMBDA (SDELIM STREAM) (* kbr: "19-Feb-85 15:14") (* Insert string delimiter SDELIM & update caches. SDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM SDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.OPEN.STRING STREAM)) (T (EMACS.CLOSE.STRING STREAM)))))) (EMACS.LDELIM (LAMBDA (LDELIM STREAM) (* kbr: "19-Feb-85 15:14") (* Insert LDELIM & update caches. LDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM LDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.OPEN.BALANCE STREAM)))))) (EMACS.RDELIM (LAMBDA (RDELIM STREAM) (* kbr: "19-Feb-85 15:14") (* Insert RDELIM & update caches. RDELIM = 1 letter string *) (PROG (PTR) (SETQ PTR (GETFILEPTR STREAM)) (TEDIT.INSERT STREAM RDELIM) (EMACS.SETFILEPTR STREAM (ADD1 PTR)) (COND ((EMACS.BACK.ESCAPEDP STREAM) (RETURN))) (COND ((EQ (EMACS.SCACHE STREAM) (QUOTE OUTSIDE)) (EMACS.CLOSE.BALANCE STREAM)))))) (EMACS.OPEN.STRING (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (LPTR) (* We should be 1 char after left delim. *) (SETQ LPTR (SUB1 (GETFILEPTR STREAM))) (SETQ EMACS.SCACHE LPTR)))) (EMACS.CLOSE.STRING (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (LPTR RPTR LDELIM RDELIM MATCHED) (* We should be 1 char after right delim. *) (SETQ EMACS.SCACHE (QUOTE OUTSIDE)) (SETQ RPTR (SUB1 (GETFILEPTR STREAM))) (EMACS.SETFILEPTR STREAM RPTR) (SETQ RDELIM (\PEEKBIN STREAM)) (EMACS.BSKIP STREAM EMACS.NONSD) (EMACS.BBYTE STREAM) (SETQ LPTR (GETFILEPTR STREAM)) (SETQ LDELIM (\PEEKBIN STREAM)) (SETQ MATCHED (IEQP LDELIM RDELIM)) (COND (MATCHED (EMACS.SETCARETPTR STREAM LPTR) (DISMISS 200)) (T (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (EMACS.SETCARETPTR STREAM LPTR) (DISMISS 1000))) (EMACS.SETCARETPTR STREAM (ADD1 RPTR)) (EMACS.SETFILEPTR STREAM (ADD1 RPTR))))) (EMACS.OPEN.BALANCE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (LPTR) (* We should be 1 char after left delim. *) (SETQ LPTR (SUB1 (GETFILEPTR STREAM))) (COND ((NUMBERP EMACS.BCACHE) (* We were at top level. *) (SETQ EMACS.BCACHE (LIST LPTR))) (T (push EMACS.BCACHE LPTR)))))) (EMACS.CLOSE.BALANCE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (PTR LPTR RPTR LDELIM RDELIM BALANCED) (* LPTR & RPTR point at balancing delims *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ RPTR (SUB1 PTR)) (EMACS.SETFILEPTR STREAM RPTR) (SETQ RDELIM (\PEEKBIN STREAM)) (EMACS.BCACHE STREAM) (SETQ BALANCED (NOT (NUMBERP EMACS.BCACHE))) (COND (BALANCED (SETQ LPTR (CAR EMACS.BCACHE)) (EMACS.SETFILEPTR STREAM LPTR) (SETQ LDELIM (\PEEKBIN STREAM)) (EMACS.SETCARETPTR STREAM LPTR) (COND ((IEQP (CDR (ASSOC LDELIM EMACS.DELIMS)) RDELIM) (* Correct match *) (DISMISS 200)) (T (* Flash incorrect match. *) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (DISMISS 1000))) (pop EMACS.BCACHE)) (T (* Flash beginning of non-list def. *) (EMACS.SETCARETPTR STREAM EMACS.BCACHE) (FLASHWINDOW (fetch (EMACSSTREAM WINDOW) of STREAM)) (DISMISS 1000))) (EMACS.SETCARETPTR STREAM PTR) (EMACS.SETFILEPTR STREAM PTR)))) (EMACS.FLUSH.CACHE (LAMBDA NIL (* kbr: "19-Feb-85 15:14") (* Lose cached info about string & paren balancing. *) (PROG NIL (* Hopefully we can change things so that not all  commands flush all of cache. *) (SETQ EMACS.SCACHE NIL) (SETQ EMACS.BCACHE NIL)))) (EMACS.SCACHE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Return or OUTSIDE, computing if necessary. *) (PROG (PTR ANSWER) (COND (EMACS.SCACHE (RETURN EMACS.SCACHE))) (* Recompute. *) (SETQ PTR (GETFILEPTR STREAM)) (EMACS.SETFILEPTR STREAM (EMACS.BOL STREAM PTR)) (SETQ ANSWER (QUOTE OUTSIDE)) (while (ILESSP (GETFILEPTR STREAM) PTR) do (* Find opening. *) (EMACS.FSKIP STREAM EMACS.NONSD PTR) (EMACS.FBYTE STREAM) (COND ((IGEQ (GETFILEPTR STREAM) PTR) (RETURN))) (SETQ ANSWER (GETFILEPTR STREAM)) (* Find closing. *) (EMACS.FSKIP STREAM EMACS.NONSD PTR) (EMACS.FBYTE STREAM) (COND ((IGEQ (GETFILEPTR STREAM) PTR) (RETURN))) (SETQ ANSWER (QUOTE OUTSIDE))) (* Store ANSWER, restore fileptr, & return *) (SETQ EMACS.SCACHE ANSWER) (EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.BCACHE (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Return ( ... ) or OUTSIDE *) (PROG (PTR SCACHE ANSWER) (COND (EMACS.BCACHE (RETURN EMACS.BCACHE))) (* Recompute. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ SCACHE (EMACS.SCACHE STREAM)) (COND ((NOT (EQ SCACHE (QUOTE OUTSIDE))) (* Move off string. *) (EMACS.SETFILEPTR STREAM SCACHE) (COND ((OR (EMACS.BOFP STREAM) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* A string def! *) (SETQ ANSWER SCACHE) (GO EXIT))))) (COND ((NULL (EMACS.SAFE.BACK.SEXPRS STREAM)) (* Unsuccessful read = unbalanced parens. Treat as if top level. *) (SETQ ANSWER (GETFILEPTR STREAM))) ((OR (ZEROP (GETFILEPTR STREAM)) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* Top level. *) (SETQ ANSWER (GETFILEPTR STREAM))) (T (* Opening delim present. *) (SETQ ANSWER (LIST (SUB1 (GETFILEPTR STREAM)))))) EXIT(EMACS.SETFILEPTR STREAM PTR) (SETQ EMACS.BCACHE ANSWER) (RETURN ANSWER)))) (EMACS.SAFE.BACK.SEXPRS (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Backwards read sexprs up to but not including opening delim. Return T if successful backwards read. Otherwise NIL & leave fileptr near failure point. *) (PROG (ANSWER) (DO (EMACS.BACK.SKIPSEPRS STREAM) (COND ((OR (ZEROP (GETFILEPTR STREAM)) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR)) (AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM)))) (* Up against delimiter. *) (SETQ ANSWER T) (RETURN)) ((NULL (NLSETQ (EMACS.BACK.SEXPR STREAM))) (* Error reading backwards. *) (FLASHWINDOW STREAM) (RETURN)))) (RETURN ANSWER)))) (EMACS.SAFE.BACK.SEXPR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Return T if successful backwards read. Otherwise NIL & leave fileptr near failure point. *) (PROG NIL (COND ((NULL (NLSETQ (EMACS.BACK.SEXPR STREAM))) (* Error reading backwards. *) (FLASHWINDOW STREAM) (RETURN NIL))) (RETURN T)))) (EMACS.BACK.SEXPR (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (PROG (RDELIM LDELIM) (EMACS.BACK.SKIPSEPRS STREAM) (COND ((EMACS.BOFP STREAM) (ERROR!)) ((EMACS.BACK.ESCAPEDP STREAM) (* Atom *) (EMACS.BACK.WORD STREAM) (RETURN))) (SETQ RDELIM (\BACKPEEKBIN STREAM)) (SETQ LDELIM (for BUCKET in EMACS.DELIMS when (IEQP (CDR BUCKET) RDELIM) do (RETURN (CAR BUCKET)))) (COND ((NULL LDELIM) (* Atom *) (EMACS.BACK.WORD STREAM)) ((IEQP LDELIM RDELIM) (* String delimiters *) (\BACKBIN STREAM) (WHILE (AND (NOT (EMACS.BOFP STREAM)) (OR (NOT (IEQP (\BACKPEEKBIN STREAM) LDELIM)) (EMACS.BACK.ESCAPEDP STREAM))) DO (\BACKBIN STREAM)) (COND ((EMACS.BOFP STREAM) (ERROR!))) (\BACKBIN STREAM)) (T (* Left Right delimters *) (\BACKBIN STREAM) (do (EMACS.BACK.SKIPSEPRS STREAM) (COND ((EMACS.BOFP STREAM) (ERROR!)) ((AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM))) (RETURN))) (EMACS.BACK.SEXPR STREAM) (COND ((OR (EMACS.BOFP STREAM) (IEQP (\BACKPEEKBIN STREAM) (CHARCODE CR))) (* At top of definition in middle of read. *) (ERROR!)))) (\BACKBIN STREAM) (EMACS.BSKIP STREAM EMACS.BQ)))))) (EMACS.BACK.WORD (LAMBDA (STREAM) (* kbr: "24-Jul-85 16:36") (* Backward a word. *) (PROG NIL (EMACS.BWORD STREAM)))) (EMACS.BACK.SKIPSEPRS (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Backwards SKIPSEPRS. *) (PROG (SA CH SNX) (SETQ SA (fetch (READTABLEP READSA) of EMACS.READTABLE)) (COND ((EMACS.BOFP STREAM) (RETURN))) (SETQ CH (\BACKPEEKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((NOT (EQ SNX SEPRCHAR.RC)) (RETURN))) (\BACKBIN STREAM) (do (COND ((EMACS.BOFP STREAM) (RETURN))) (SETQ CH (\BACKPEEKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((EQ SNX SEPRCHAR.RC) (\BACKBIN STREAM)) ((EQ SNX ESCAPE.RC) (\BIN STREAM) (COND ((NOT (EMACS.BACK.ESCAPEDP STREAM)) (\BACKBIN STREAM))) (RETURN)) (T (RETURN))))))) (EMACS.BACK.ESCAPEDP (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Is the previous byte escaped? *) (PROG (PTR SA CH SNX ANSWER) (* T if previous byte preceded by odd number of %%'s. *) (SETQ PTR (GETFILEPTR STREAM)) (COND ((ILEQ PTR 1) (RETURN NIL))) (SETQ SA (fetch (READTABLEP READSA) of EMACS.READTABLE)) (\BACKBIN STREAM) (do (SETQ CH (\BACKBIN STREAM)) (SETQ SNX (\GETBASEBYTE SA CH)) (COND ((EQ SNX ESCAPE.RC) (SETQ ANSWER (NOT ANSWER))) (T (RETURN))) (COND ((EMACS.BOFP STREAM) (RETURN)))) (SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.TAB (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Lisp indent. *) (PROG (PTR BOL EOL CODE INDENT OFFSET TABFLG) (* INDENT = how much we want to indent. OFFSET = how many chars to nonws. TABFLG = any tabs present at beginning of line. *) (SETQ PTR (GETFILEPTR STREAM)) (SETQ INDENT (EMACS.TAB.INDENT STREAM)) (SETQ BOL (EMACS.BOL STREAM PTR)) (* Calc OFFSET. *) (SETQ EOL (EMACS.EOL STREAM PTR)) (EMACS.SETFILEPTR STREAM BOL) (SETQ OFFSET 0) (for I from BOL to (SUB1 EOL) do (SETQ CODE (\BIN STREAM)) (COND ((EQUAL CODE (CHARCODE TAB)) (SETQ TABFLG T))) (COND ((NOT (BITTEST (ELT EMACS.SYNTAX (OR (NUMBERP CODE) 256)) EMACS.WS)) (RETURN))) (SETQ OFFSET (ADD1 OFFSET))) (* Insert and/or delete whitespace. *) (COND (TABFLG (EMACS.DELETE.BYTES STREAM BOL (IPLUS BOL OFFSET -1)) (COND ((NOT (ZEROP INDENT)) (TEDIT.INSERT STREAM (ALLOCSTRING INDENT " ") (ADD1 BOL))))) ((IEQP OFFSET INDENT) (* Do nothing. *) ) ((IGREATERP OFFSET INDENT) (EMACS.DELETE.BYTES STREAM BOL (IPLUS BOL (IDIFFERENCE OFFSET INDENT) -1))) ((ILESSP OFFSET INDENT) (TEDIT.INSERT STREAM (ALLOCSTRING (IDIFFERENCE INDENT OFFSET) " ") (ADD1 BOL))) (T (SHOULDNT))) (* Reposition fileptr. *) (COND ((ILEQ PTR (IPLUS BOL OFFSET)) (EMACS.SETFILEPTR STREAM (IPLUS BOL INDENT))) (T (EMACS.SETFILEPTR STREAM (IPLUS PTR (IDIFFERENCE INDENT OFFSET)))))))) (EMACS.TAB.INDENT (LAMBDA (STREAM) (* kbr: "19-Feb-85 15:14") (* Amount to indent for Lisp indent. *) (PROG (PTR BOD SISTER1PTR SISTER2PTR LDELIMFLG SISTER1 SISTERPTR OFFSET BOL ANSWER) (SETQ PTR (GETFILEPTR STREAM)) (* SETQ BOD (EMACS.BOD STREAM PTR)) (SETQ BOD 0) (EMACS.SETFILEPTR STREAM (EMACS.BOL STREAM PTR)) (EMACS.BSKIP STREAM EMACS.WS BOD) (* Get SISTER1PTR, SISTER2PTR, & LDELIMFLG *) (do (EMACS.BSKIP STREAM EMACS.SPACE) (COND ((ILEQ (GETFILEPTR STREAM) BOD) (RETURN))) (COND ((AND (FMEMB (\BACKPEEKBIN STREAM) EMACS.LDELIMS) (NOT (EMACS.BACK.ESCAPEDP STREAM))) (SETQ LDELIMFLG T) (RETURN))) (EMACS.SAFE.BACK.SEXPR STREAM) (SETQ SISTER2PTR SISTER1PTR) (SETQ SISTER1PTR (GETFILEPTR STREAM))) (* Get SISTER1. *) (COND (SISTER1PTR (EMACS.SETFILEPTR STREAM SISTER1PTR) (SETQ SISTER1 (RATOM STREAM)))) (* Get SISTERPTR & OFFSET. *) (SETQ SISTERPTR (OR SISTER1PTR (GETFILEPTR STREAM))) (COND ((AND SISTER1 (LITATOM SISTER1)) (SETQ OFFSET (GETPROP SISTER1 (QUOTE EMACS.TAB))))) (COND (OFFSET (SETQ OFFSET (SUB1 OFFSET))) ((NULL SISTER1) (SETQ OFFSET 1)) ((NULL LDELIMFLG) (SETQ OFFSET 0)) ((NULL SISTER2PTR) (SETQ OFFSET 0)) (T (SETQ SISTERPTR SISTER2PTR) (SETQ OFFSET 0))) (* Get ANSWER. *) (SETQ BOL (EMACS.BOL STREAM SISTERPTR)) (EMACS.SETFILEPTR STREAM BOL) (SETQ ANSWER OFFSET) (for I from BOL to (SUB1 SISTERPTR) do (COND ((IEQP (\BIN STREAM) (CHARCODE TAB)) (SETQ ANSWER (IPLUS ANSWER 8))) (T (SETQ ANSWER (ADD1 ANSWER))))) EXIT(EMACS.SETFILEPTR STREAM PTR) (RETURN ANSWER)))) (EMACS.INIT.SYNTAX (LAMBDA NIL (* kbr: "19-Feb-85 15:14") (PROG NIL (* "Character" 256 is used to handle IMAGEOBJs. *) (SETQ EMACS.SYNTAX (ARRAY 257 (QUOTE WORD) 0 0)) (FOR I FROM 0 TO 256 DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONCR EMACS.NONWS EMACS.NONSD EMACS.ALPHA))) (FOR I IN (CHARCODE (TAB LF SP)) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.WS EMACS.NONCR EMACS.NONSD EMACS.SPACE))) (SETA EMACS.SYNTAX (CHARCODE CR) (LOGOR EMACS.WS EMACS.CR EMACS.NONSD)) (FOR I IN (QUOTE (39 44 64 96)) DO (SETA EMACS.SYNTAX I (LOGOR EMACS.NONWS EMACS.NONCR EMACS.NONSD EMACS.BQ EMACS.ALPHA))) (SETQ EMACS.DELIMS NIL) (SETQ EMACS.SDELIMS NIL) (SETQ EMACS.LDELIMS NIL) (SETQ EMACS.RDELIMS NIL) (EMACS.DELIMS (CHARCODE "(") (CHARCODE ")")) (EMACS.DELIMS (CHARCODE "[") (CHARCODE "]")) (EMACS.DELIMS (CHARCODE "{") (CHARCODE "}")) (EMACS.DELIMS 34 34)))) ) (DECLARE: DONTEVAL@LOAD DOCOPY (EMACS.INIT) (MOVD? 'TEDIT.SELECT.LINE.SCANNER 'OLD.TEDIT.SELECT.LINE.SCANNER) (MOVD 'NEW.TEDIT.SELECT.LINE.SCANNER 'TEDIT.SELECT.LINE.SCANNER) (MOVD 'EMACS 'TEDIT) ) (PUTPROPS EMACS COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (9473 52815 (EMACS.INIT 9483 . 10172) (EMACS.INIT.BACKGROUND 10174 . 10893) (DEDITEmacs 10895 . 11408) (EMACS.INIT.COMMANDS 11410 . 12431) (EMACS.COMMAND 12433 . 12629) (EMACS.OPERATE 12631 . 15717) (EMACS.GETKEY 15719 . 15982) (EMACS 15984 . 17010) (EMACS.PROCESS 17012 . 17288) ( EMACS.TEDIT1 17290 . 17746) (EMACS.WINDOW 17748 . 18175) (EMACS.SETFILEPTR 18177 . 18578) ( EMACS.GETCARETPTR 18580 . 19075) (EMACS.SETCARETPTR 19077 . 19692) (EMACS.SHOWCARET 19694 . 20060) ( EMACS.BOL 20062 . 20647) (EMACS.EOL 20649 . 21228) (EMACS.DELETE.BYTES 21230 . 22211) (EMACS.BOFP 22213 . 22362) (EMACS.EOFP 22364 . 22538) (EMACS.CCHAR 22540 . 22913) (EMACS.PEEKBIN 22915 . 23232) ( EMACS.FBYTE 23234 . 23507) (EMACS.FWORD 23509 . 23816) (EMACS.BYTEP 23818 . 23982) (EMACS.FSKIP 23984 . 24527) (EMACS.FSKIPTO 24529 . 25027) (EMACS.BBYTE 25029 . 25307) (EMACS.BCHAR 25309 . 25617) ( EMACS.BPEEKCHAR 25619 . 26020) (EMACS.BWORD 26022 . 26330) (EMACS.BSKIP 26332 . 26856) (EMACS.BSKIPTO 26858 . 27360) (EMACS.SET.EOF 27362 . 27891) (EMACS.GOTO.BOL 27893 . 28168) (EMACS.BACK.BYTE 28170 . 28425) (EMACS.FWD.DELETE.BYTE 28427 . 28751) (EMACS.GOTO.EOL 28753 . 29022) (EMACS.FWD.BYTE 29024 . 29281) (EMACS.KILL.LINE 29283 . 29939) (EMACS.DELETE.CHARS 29941 . 30904) (EMACS.REDISPLAY 30906 . 31309) (EMACS.NEXT.LINE 31311 . 32266) (EMACS.PREVIOUS.LINE 32268 . 33102) (EMACS.QUOTE.BYTE 33104 . 33694) (EMACS.SEARCH 33696 . 38017) (EMACS.TRANSPOSE.BYTES 38019 . 38951) (EMACS.NEXT.SCREENFULL 38953 . 39650) (EMACS.CXCV 39652 . 40382) (EMACS.CXCW 40384 . 40699) (EMACS.CXCZ 40701 . 41083) ( EMACS.FWD.SEXPR 41085 . 41534) (EMACS.BACK.DELETE.BYTE 41536 . 42065) (EMACS.GOTO.BOD 42067 . 42708) ( EMACS.BOD 42710 . 43596) (EMACS.GOTO.EOD 43598 . 44260) (EMACS.EOD 44262 . 45148) (EMACS.KILL.SEXPR 45150 . 45640) (EMACS.GOTO.BOF 45642 . 45979) (EMACS.GOTO.EOF 45981 . 46268) (EMACS.BACK.WORD 46270 . 46526) (EMACS.FWD.DELETE.WORD 46528 . 47066) (EMACS.EDIT 47068 . 47650) (EMACS.FWD.WORD 47652 . 47906) (EMACS.GRIND 47908 . 48448) (EMACS.SNARF 48450 . 48813) (EMACS.MT 48815 . 49569) ( EMACS.PREVIOUS.SCREENFULL 49571 . 50272) (EMACS.JOIN.LINES 50274 . 51483) (EMACS.BACK.DELETE.WORD 51485 . 51926) (NEW.TEDIT.SELECT.LINE.SCANNER 51928 . 52813)) (52816 73467 (\TEDIT1 52826 . 54975) ( \TEDIT.COMMAND.LOOP 54977 . 73465)) (74455 102685 (EMACS.DELIMS 74465 . 76054) (EMACS.CR 76056 . 76838 ) (EMACS.RPAREN 76840 . 77286) (EMACS.RBRACKET 77288 . 77736) (EMACS.RBRACE 77738 . 78184) ( EMACS.RANGLE 78186 . 78632) (EMACS.SDELIM.COMMAND 78634 . 79085) (EMACS.LDELIM.COMMAND 79087 . 79538) (EMACS.RDELIM.COMMAND 79540 . 79991) (EMACS.SDELIM 79993 . 80800) (EMACS.LDELIM 80802 . 81543) ( EMACS.RDELIM 81545 . 82287) (EMACS.OPEN.STRING 82289 . 82635) (EMACS.CLOSE.STRING 82637 . 83809) ( EMACS.OPEN.BALANCE 83811 . 84316) (EMACS.CLOSE.BALANCE 84318 . 86090) (EMACS.FLUSH.CACHE 86092 . 86605 ) (EMACS.SCACHE 86607 . 88255) (EMACS.BCACHE 88257 . 90050) (EMACS.SAFE.BACK.SEXPRS 90052 . 90992) ( EMACS.SAFE.BACK.SEXPR 90994 . 91529) (EMACS.BACK.SEXPR 91531 . 93407) (EMACS.BACK.WORD 93409 . 93665) (EMACS.BACK.SKIPSEPRS 93667 . 94698) (EMACS.BACK.ESCAPEDP 94700 . 95631) (EMACS.TAB 95633 . 98287) ( EMACS.TAB.INDENT 98289 . 101361) (EMACS.INIT.SYNTAX 101363 . 102683))))) STOP \ No newline at end of file diff --git a/lispusers/ENDNOTE b/lispusers/ENDNOTE new file mode 100644 index 00000000..b952fe4e --- /dev/null +++ b/lispusers/ENDNOTE @@ -0,0 +1 @@ +(FILECREATED "18-Feb-87 15:43:31" {SUMEX-AIM}PS:ENDNOTE.;4 15652 changes to: (FNS NOTE.BUTTONEVENTINFN) previous date: "18-Feb-87 10:11:49" {SUMEX-AIM}PS:ENDNOTE.;6) (* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) (PRETTYCOMPRINT ENDNOTECOMS) (RPAQQ ENDNOTECOMS ((* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (FNS ADD.ENDNOTE INSERT.ENDNOTES INSERT.ENDNOTES.TEXT DELETE.ENDNOTES NOTESREGIONP SET.ENDNOTE.STYLE MAP.ENDNOTE.LOOKS GET.ENDNOTE.FONTS) (FNS ENDNOTEP NOTE.PUTFN NOTE.GETFN NOTE.BUTTONEVENTINFN) (RECORDS ENDNOTEFONTS) (* * Allow user to edit Endnote text in another TEdit window.) (FNS AUX.TEDIT AUX.TEDIT.AFTERQUITFN AUX.TEDIT.TITLEMENUFN) (* * Delimit text between two markers known as REGION MARKERS.) (FNS REGMARKOBJ REGMARKOBJP REGMARK.DISPLAYFN REGMARK.IMAGEBOXFN REGMARK.PUTFN REGMARK.GETFN REGMARK.BUTTONEVENTINFN) (RECORDS REGMARKOBJ))) (* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (DEFINEQ (ADD.ENDNOTE (LAMBDA (STREAM WINDOW) (* fsg "17-Feb-87 10:47") (* * Insert an ENDNOTE ImageObject as a superscript. Displayed as a number when updated.) (LET ((NOBJ (NUMBEROBJ 'NOTE))) (TEDIT.INSERT.OBJECT NOBJ STREAM) (COND ((UPDATE? WINDOW) (UPDATE.NUMBEROBJS WINDOW 'ENDNOTEP)) (T NIL)) (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of NOBJ) with (TEDIT.GETINPUT STREAM "Endnote text:")) (TEDIT.PROMPTPRINT STREAM "" T)))) (INSERT.ENDNOTES (LAMBDA (STREAM WINDOW) (* fsg "18-Feb-87 09:38") (* * Inserts text of endnotes at the end of the TEdit document. The text is inserted between two Region marking  imageobjs.) (LET* ((TEXTOBJ (TEXTOBJ STREAM)) (LIST.OF.ENDNOTES (TSP.LIST.OF.OBJECTS TEXTOBJ 'ENDNOTEP)) (CARETPOSITION (fetch CH# of (TEDIT.GETSEL STREAM)))) (DELETE.ENDNOTES STREAM) (COND (LIST.OF.ENDNOTES (TEDIT.PROMPTPRINT STREAM "Inserting notes at the end of the document..." T) (TEDIT.INSERT.OBJECT (REGMARKOBJ 'ENDNOTES 'Endnotes-START) STREAM (ADD1 (fetch TEXTLEN of TEXTOBJ))) (TEDIT.LOOKS STREAM '(PROTECTED ON) (fetch TEXTLEN of TEXTOBJ) 1) (TEDIT.INSERT STREAM (CONCAT (CHARACTER (CHARCODE EOL)) "Notes" (CHARACTER (CHARCODE EOL))) (ADD1 (fetch TEXTLEN of TEXTOBJ)) (fetch (ENDNOTEFONTS TITLE.FONT) of (GET.ENDNOTE.FONTS WINDOW)) T) (INSERT.ENDNOTES.TEXT STREAM TEXTOBJ LIST.OF.ENDNOTES) (TEDIT.INSERT.OBJECT (REGMARKOBJ 'ENDNOTES 'Endnotes-END) STREAM (ADD1 (fetch TEXTLEN of TEXTOBJ))) (TEDIT.LOOKS STREAM '(PROTECTED ON) (fetch TEXTLEN of TEXTOBJ) 1) (TEDIT.PROMPTPRINT STREAM "done") (TEDIT.NORMALIZECARET TEXTOBJ (TEDIT.SETSEL STREAM CARETPOSITION 1)) ) (T NIL))))) (INSERT.ENDNOTES.TEXT (LAMBDA (STREAM TEXTOBJ LIST.OF.ENDNOTES) (* fsg " 7-Jan-87 14:31") (* * Here to print the text of each endnote.) (LET ((TEXTLOOKS (fetch (ENDNOTEFONTS TEXT.FONT) of (GET.ENDNOTE.FONTS WINDOW)))) (for ENDNOTEOBJ in LIST.OF.ENDNOTES do (LET ((NUMSTRING (MKSTRING (fetch (NUMBEROBJ NUMSTRING) of (fetch OBJECTDATUM of (CAR ENDNOTEOBJ))))) (TEXT (fetch (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of (CAR ENDNOTEOBJ))))) (TEDIT.INSERT STREAM NUMSTRING (ADD1 (fetch TEXTLEN of TEXTOBJ)) TEXTLOOKS T) (TEDIT.INSERT STREAM (CONCAT " " TEXT (CHARACTER (CHARCODE EOL))) (ADD1 (fetch TEXTLEN of TEXTOBJ)) TEXTLOOKS T)))))) (DELETE.ENDNOTES (LAMBDA (STREAM) (* fsg "18-Feb-87 09:11") (* * Delete the Endnotes, i.e. delete the start/end REGMARK ImageObjects and all the text between them.) (LET* ((TEXTOBJ (TEXTOBJ STREAM)) (NOTEMARKER.LIST (TSP.LIST.OF.OBJECTS TEXTOBJ 'NOTESREGIONP)) (NOTES.START (CADAR NOTEMARKER.LIST)) (NOTES.END (CADADR NOTEMARKER.LIST))) (AND NOTEMARKER.LIST (TEDIT.DELETE STREAM NOTES.START (IDIFFERENCE (ADD1 NOTES.END) NOTES.START)))))) (NOTESREGIONP (LAMBDA (IMOBJ) (* fsg "26-Jan-87 09:41") (AND (REGMARKOBJP IMOBJ) (EQ (fetch REGION.USE of (fetch OBJECTDATUM of IMOBJ)) 'ENDNOTES)))) (SET.ENDNOTE.STYLE (LAMBDA (STREAM WINDOW) (* fsg " 9-Jan-87 09:18") (* * Set the font of the ENDNOTE number, title, or text.) (LET ((NOTE.FONTS (GET.ENDNOTE.FONTS WINDOW)) (NOTE.TYPE (MENU (create MENU TITLE _ "ENDNOTE Fonts" CENTERFLG _ T ITEMS _ '(Number Title Text)))) OLD.FONT NEW.FONT) (AND NOTE.TYPE (PROGN (SETQ OLD.FONT (SELECTQ NOTE.TYPE (Number (fetch (ENDNOTEFONTS NUMBER.FONT) of NOTE.FONTS)) (Title (fetch (ENDNOTEFONTS TITLE.FONT) of NOTE.FONTS)) (Text (fetch (ENDNOTEFONTS TEXT.FONT) of NOTE.FONTS)) NIL)) (TEDIT.PROMPTPRINT STREAM (CONCAT "Change Endnote " NOTE.TYPE " font " (LIST (ABBREVIATE.FONT OLD.FONT)) " to...") T) (SETQ NEW.FONT (FONTCREATE (GET.TSP.FONT WINDOW OLD.FONT))) (COND ((NEQ OLD.FONT NEW.FONT) (SELECTQ NOTE.TYPE (Number (replace (ENDNOTEFONTS NUMBER.FONT) of NOTE.FONTS with NEW.FONT)) (Title (replace (ENDNOTEFONTS TITLE.FONT) of NOTE.FONTS with NEW.FONT)) (Text (replace (ENDNOTEFONTS TEXT.FONT) of NOTE.FONTS with NEW.FONT)) NIL) (AND (EQ NOTE.TYPE 'Number) (MAP.ENDNOTE.LOOKS STREAM NEW.FONT))) (T NIL)) (TEDIT.PROMPTPRINT STREAM "" T)))))) (MAP.ENDNOTE.LOOKS (LAMBDA (STREAM NUMBERFONT) (* fsg " 9-Jan-87 09:09") (* * Here to update the ENDNOTE looks. Only the ENDNOTE superscript numbers are updated.) (LET ((LIST.OF.NOTES (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) 'ENDNOTEP))) (AND LIST.OF.NOTES (PROGN (TEDIT.PROMPTPRINT STREAM "Updating ENDNOTE Number looks..." T) (for NOTE/CH# in LIST.OF.NOTES do (TEDIT.LOOKS STREAM NUMBERFONT (CADR NOTE/CH#) 1)) (TEDIT.PROMPTPRINT STREAM "done.")))))) (GET.ENDNOTE.FONTS (LAMBDA (WINDOW) (* fsg " 5-Jan-87 10:40") (* * Setup the default ENDNOTE fonts for number, title, and text.) (OR (WINDOWPROP WINDOW 'ENDNOTE.FONTS) (PROGN (WINDOWPROP WINDOW 'ENDNOTE.FONTS (create ENDNOTEFONTS NUMBER.FONT _ GP.DefaultFont TITLE.FONT _ GP.DefaultFont TEXT.FONT _ GP.DefaultFont)) (WINDOWPROP WINDOW 'ENDNOTE.FONTS))))) ) (DEFINEQ (ENDNOTEP (LAMBDA (IMOBJ) (* ss: " 2-Jul-85 16:51") (AND (NUMBEROBJP IMOBJ) (EQ (fetch USE of (fetch OBJECTDATUM of IMOBJ)) 'NOTE)))) (NOTE.PUTFN (LAMBDA (NUMBEROBJ STREAM WINDOW) (* fsg "28-Jan-87 13:48") (* * Used to put a numberobj that is functioning as an endnote.) (replace (NUMBEROBJ FONT) of (fetch OBJECTDATUM of NUMBEROBJ) with (for NOTEFONT in (GET.ENDNOTE.FONTS WINDOW) collect (LIST.FONT.PROPS NOTEFONT) )) (PRIN4 (LIST 'Endnote (IMAGEOBJPROP NUMBEROBJ 'TAG) (fetch OBJECTDATUM of NUMBEROBJ)) STREAM))) (NOTE.GETFN (LAMBDA (NEWOBJ USE/TEXT WINDOW) (* fsg " 8-Jan-87 10:19") (* * Used to get a numberobj that is functioning as an endnote.) (WINDOWPROP WINDOW 'ENDNOTE.FONTS (for NOTEFONT in (fetch (NUMBEROBJ FONT) of USE/TEXT) collect (FONTCREATE NOTEFONT))) (replace (NUMBEROBJ FONT) of USE/TEXT with NIL) (replace OBJECTDATUM of NEWOBJ with USE/TEXT) NEWOBJ)) (NOTE.BUTTONEVENTINFN (LAMBDA (NUMBEROBJ STREAM) (* fsg "18-Feb-87 11:16") (* * Bring up another TEdit window where user can edit the text of an Endnote.) (MENU (create MENU TITLE _ 'Endnotes% Menu CENTERFLG _ T ITEMS _ '((Edit% Endnote (AUX.TEDIT NUMBEROBJ (CONCAT "Endnote #" (fetch NUMSTRING of (fetch OBJECTDATUM of NUMBEROBJ))) STREAM)) (Tag% Endnote (XREF.TAG.OBJECT NUMBEROBJ STREAM))))))) ) [DECLARE: EVAL@COMPILE (RECORD ENDNOTEFONTS (NUMBER.FONT TITLE.FONT TEXT.FONT)) ] (* * Allow user to edit Endnote text in another TEdit window.) (DEFINEQ (AUX.TEDIT (LAMBDA (IMOBJ TITLE STREAM) (* fsg "20-Jan-87 15:46") (* * Open a TEdit window where the user can view/edit the text of the selected Endnote.) (LET* ((MAINWINDOW (\TEDIT.MAINW STREAM)) (AUXWINDOW (CREATEW (WINDOWPROP MAINWINDOW 'AUXW.REGION) TITLE))) (WINDOWPROP AUXWINDOW 'MAIN.WINDOW MAINWINDOW) (WINDOWPROP AUXWINDOW 'NOTE.IMAGEOBJ IMOBJ) (TEDIT (MKSTRING (fetch (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of IMOBJ))) AUXWINDOW NIL '(AFTERQUITFN AUX.TEDIT.AFTERQUITFN TITLEMENUFN AUX.TEDIT.TITLEMENUFN))))) (AUX.TEDIT.AFTERQUITFN (LAMBDA (AUXWINDOW) (* fsg "20-Jan-87 15:56") (* * Here AFTER user finished with Endnote TEdit process.) (LET ((MAINWINDOW (WINDOWPROP AUXWINDOW 'MAIN.WINDOW))) (WINDOWPROP MAINWINDOW 'AUXW.REGION (WINDOWPROP AUXWINDOW 'REGION)) (GIVE.TTY.PROCESS MAINWINDOW) (TEDIT.NORMALIZECARET (TEXTOBJ MAINWINDOW))))) (AUX.TEDIT.TITLEMENUFN (LAMBDA (AUXWINDOW) (* fsg "20-Jan-87 15:49") (* * Here when left or middle button hit in title bar.) (LET ((ITEM (MENU (create MENU CENTERFLG _ T ITEMS _ '(Save% Changes Abort% Changes))))) (AND ITEM (PROGN (SELECTQ ITEM (Save% Changes (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of (WINDOWPROP AUXWINDOW 'NOTE.IMAGEOBJ)) with (COERCETEXTOBJ (TEXTSTREAM AUXWINDOW) 'STRINGP))) NIL) (TEDIT.QUIT (TEXTSTREAM AUXWINDOW))))))) ) (* * Delimit text between two markers known as REGION MARKERS.) (DEFINEQ (REGMARKOBJ (LAMBDA (USE MARKING) (* ss: "15-Jul-85 11:54") (LET ((NEWOBJ (IMAGEOBJCREATE (create REGMARKOBJ REGION.USE _ USE MARKING _ MARKING) (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN) (FUNCTION REGMARK.IMAGEBOXFN) (FUNCTION REGMARK.PUTFN) (FUNCTION REGMARK.GETFN) (FUNCTION NILL) (FUNCTION REGMARK.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))))) (IMAGEOBJPROP NEWOBJ 'TYPE 'REGMARKOBJ) NEWOBJ))) (REGMARKOBJP (LAMBDA (IMOBJ) (* ss: "12-Jul-85 15:04") (AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE) 'REGMARKOBJ)))) (REGMARK.DISPLAYFN (LAMBDA (OBJ STREAM) (* fsg "18-Feb-87 09:18") (* * REGMARK is just a marker, it doesn't actually display anything.) NIL)) (REGMARK.IMAGEBOXFN (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "17-Feb-87 10:22") (* * REGMARK is just a marker, it doesn't actually display anything.) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0))) (REGMARK.PUTFN (LAMBDA (MARKOBJ STREAM) (* fsg "28-Jan-87 14:10") (PRIN2 (LIST 'Region (IMAGEOBJPROP MARKOBJ 'TAG) (LIST (fetch REGION.USE of (fetch OBJECTDATUM of MARKOBJ)) (fetch MARKING of (fetch OBJECTDATUM of MARKOBJ)))) STREAM))) (REGMARK.GETFN (LAMBDA (STREAM) (* fsg "28-Jan-87 16:06") (OR (WINDOWPROP (PROCESSPROP (THIS.PROCESS) 'WINDOW) 'IMAGEOBJ.MENUW) (TSP.FMMENU (TEXTSTREAM (PROCESSPROP (THIS.PROCESS) 'WINDOW)))) (LET* ((REGMARK.ARGS (CDR (READ STREAM))) (NEWOBJ (APPLY 'REGMARKOBJ (CADR REGMARK.ARGS)))) (IMAGEOBJPROP NEWOBJ 'TAG (CAR REGMARK.ARGS)) NEWOBJ))) (REGMARK.BUTTONEVENTINFN (LAMBDA (MARKOBJ STREAM) (* fsg "18-Feb-87 10:07") (* * This function is never called because the REGMARK ImageObjects are protected after they are inserted and  anything protected can't be selected.) (AND (MOUSESTATE MIDDLE) (LET ((MARKDATUM (fetch OBJECTDATUM of MARKOBJ))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Region used for " (fetch REGION.USE of MARKDATUM) (COND ((fetch MARKING of MARKDATUM) (CONCAT ", Marker is " (fetch MARKING of MARKDATUM))) (T ""))) T))))) ) [DECLARE: EVAL@COMPILE (RECORD REGMARKOBJ (REGION.USE MARKING)) ] (PUTPROPS ENDNOTE COPYRIGHT ("Leland Stanford Junior University" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (1240 8234 (ADD.ENDNOTE 1252 . 1873) (INSERT.ENDNOTES 1877 . 3628) (INSERT.ENDNOTES.TEXT 3632 . 4538) (DELETE.ENDNOTES 4542 . 5135) (NOTESREGIONP 5139 . 5384) (SET.ENDNOTE.STYLE 5388 . 7086) (MAP.ENDNOTE.LOOKS 7090 . 7727) (GET.ENDNOTE.FONTS 7731 . 8231)) (8236 10115 (ENDNOTEP 8248 . 8477) ( NOTE.PUTFN 8481 . 9034) (NOTE.GETFN 9038 . 9547) (NOTE.BUTTONEVENTINFN 9551 . 10112)) (10280 12228 ( AUX.TEDIT 10292 . 11019) (AUX.TEDIT.AFTERQUITFN 11023 . 11495) (AUX.TEDIT.TITLEMENUFN 11499 . 12225)) (12302 15479 (REGMARKOBJ 12314 . 13131) (REGMARKOBJP 13135 . 13328) (REGMARK.DISPLAYFN 13332 . 13548) (REGMARK.IMAGEBOXFN 13552 . 13859) (REGMARK.PUTFN 13863 . 14228) (REGMARK.GETFN 14232 . 14759) ( REGMARK.BUTTONEVENTINFN 14763 . 15476))))) STOP \ No newline at end of file diff --git a/lispusers/EQUATIONEXAMPLES.TEDIT b/lispusers/EQUATIONEXAMPLES.TEDIT new file mode 100644 index 00000000..b971a11e --- /dev/null +++ b/lispusers/EQUATIONEXAMPLES.TEDIT @@ -0,0 +1,10 @@ +enˇvĹos EQUATION EDITOR EXAMPLES 2 2 4 1 4 1 EQUATION EDITOR EXAMPLES 1 4 By: Tad Hogg(Hogg.pa@Xerox.com) DESCRIPTION These are some examples of text formatted using the Equation Editor (contained in the file EQUATIONS). Examples: fraction: a = fraction ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "2x+5")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "23"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) sum: s = sum ( ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "i=1")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "m")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "i"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) = fraction ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "m (m+1)")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "2"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) integral: integral ( ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "0")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "1")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x dx"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) = 0.5 sub/superscripts: sub/superscripts ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "H")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "m")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) " ")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) " "))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) = 24 = sub/superscripts ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "X")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "i")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "23")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "KL")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "j"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) root: root ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x + 34y + z")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) " "))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) maximum: max/min ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "max")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "x in S")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "f(x)"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) limit: max/min ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "lim")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "x") ( (MATH 8 (MEDIUM REGULAR REGULAR)) "_") ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "0")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "f(x)"))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) matrix: a = matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "11")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "12")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "13")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "21")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "22")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "23"))) (rows 2 columns 3 enclosureKind NIL enclosureSide NIL numPieces 6 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "1")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 3 columns 1 enclosureKind NIL enclosureSide NIL numPieces 3 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) = matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "12")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "22"))) (rows 2 columns 1 enclosureKind NIL enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) A = matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "23x+2")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "4")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "-6")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "8x+4")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "1")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x"))) (rows 3 columns 3 enclosureKind NIL enclosureSide NIL numPieces 9 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind parentheses enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#52,162130) + matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind parentheses enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu NIL) + ... + matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind parentheses enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu NIL) = sub/superscripts ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "2")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) " ")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) " ")) ( ( (TIMESROMAN 8 (MEDIUM REGULAR REGULAR)) " "))) (fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) group ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n"))) (enclosureKind bars enclosureSide NIL fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) group ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n"))) (enclosureKind braces enclosureSide NIL fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) group ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n"))) (enclosureKind brackets enclosureSide NIL fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) group ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n"))) (enclosureKind parentheses enclosureSide NIL fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) group ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n"))) (enclosureKind angles enclosureSide NIL fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind bars enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#47,157614) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind braces enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#47,157670) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind NIL enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind parentheses enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#62,53260) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "n")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "0"))) (rows 2 columns 1 enclosureKind angles enclosureSide NIL numPieces 2 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#52,142000) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "y")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "z"))) (rows 3 columns 1 enclosureKind bars enclosureSide NIL numPieces 3 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#52,142054) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "y")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "z"))) (rows 3 columns 1 enclosureKind braces enclosureSide NIL numPieces 3 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#74,115260) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "y")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "z"))) (rows 3 columns 1 enclosureKind NIL enclosureSide NIL numPieces 3 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR))) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "y")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "z"))) (rows 3 columns 1 enclosureKind parentheses enclosureSide NIL numPieces 3 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#62,53054) matrix ( ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "x")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "y")) ( ( (TIMESROMAN 10 (MEDIUM REGULAR REGULAR)) "z"))) (rows 3 columns 1 enclosureKind angles enclosureSide NIL numPieces 3 fontSpec (GACHA 10 (MEDIUM REGULAR REGULAR)) rowMenu {MENU}#62,53000) (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 85) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 42 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL)))))-ČT,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD,Č2ŠŠ8 42ŠŠ8Č@ČČ PAGEHEADINGBOO CLASSICCLASSICCLASSICMODERN MODERNMODERN +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) + HELVETICA + HELVETICA + HRULE.GETFNMODERN + HRULE.GETFN HELVETICA +  HRULE.GETFN HELVETICA + HRULE.GETFN  HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN  HRULE.GETFNMODERN    f    ŠEQIO.Get ÖEQIO.GetŤEQIO.Get ÜEQIO.Get KEQIO.GetMEQIO.Get ŞEQIO.Get ăEQIO.Get <EQIO.Get ÂEQIO.GetEQIO.GetćEQIO.GetfEQIO.GetEQIO.GetřEQIO.Get řEQIO.GetKEQIO.Get‘EQIO.Get“EQIO.Get•EQIO.Get˜EQIO.Get“EQIO.GetţEQIO.GetEQIO.GetäEQIO.GetEQIO.GetEQIO.Get4EQIO.Get6EQIO.GetEQIO.Get:EQIO.Get5EQIO.Get"hźzş \ No newline at end of file diff --git a/lispusers/EQUATIONFORMS b/lispusers/EQUATIONFORMS new file mode 100644 index 00000000..650c646c --- /dev/null +++ b/lispusers/EQUATIONFORMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "18-Apr-88 14:00:00" {ERINYES}LYRIC>EQUATIONFORMS.;2 102911 changes to%: (VARS EQUATIONFORMSCOMS) (FNS EQ.SumGroup EQ.IntegralGroup EQ.MakeNSItem) previous date%: "30-Apr-87 10:52:34" |{IE:PARC:XEROX}LYRIC>LISPUSERS>EQUATIONFORMS.;1|) (* " Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EQUATIONFORMSCOMS) (RPAQQ EQUATIONFORMSCOMS [ (* ;;; "ATTACHEDBOX module: Part 1 of 5") (* ;  "Utility functions to manipulate attached regions") (* ;; "These functions use two sets of coords: global coords in which positions are given w.r.t. the lower left corner of a box, and side coords in which positions are given w.r.t. a particular side of the box. For the side coords, the origin is at the point on the side closest to the l.l. corner of the box, the x-axis points along the side toward the other end, and the y-axis points away from the box region") (FNS AB.RealPosition AB.PointPos AB.SidePosition AB.PlaceRegion AB.AdjustToLL AB.OppositeSide AB.RegionToBox AB.BoxToRegion AB.RelativePos AB.BiggerRegion AB.Check AB.PositionRegion AB.Position2Regions) (* ;;; "EQGROUP module: Part 2 of 5") (* ; "group equation functions") (FNS EQ.Group EQ.GroupCreate EQ.Make.group) (* ; "set up data definitions") [P (EQIO.AddType 'group 'EQ.Group 1 '(objectProps (enclosureKind NIL enclosureSide NIL) pieceNames ("item") wholeEditFn EQ.EnclosureEdit initialPropFn EQ.GroupCreate] (* ;;; "specific enclosure data") (RECORDS EQ.EnclosureData) (FNS EQ.AddEnclosure EQ.GetEnclosureData) (* ; "set up data for enclosures") (P (EQ.AddEnclosure 'angles (FUNCTION EQ.angles) "< angle brackets >") (EQ.AddEnclosure 'bars (FUNCTION EQ.bars) "| bars |") (EQ.AddEnclosure 'braces (FUNCTION EQ.braces) "{ braces }") (EQ.AddEnclosure 'brackets (FUNCTION EQ.brackets) "[ brackets ]") (EQ.AddEnclosure 'parentheses (FUNCTION EQ.parentheses) "( parentheses )") (EQIO.TypeProp 'group 'defaultEnclosure 'brackets)) (* ;;; "general enclosure functions") (FNS EQ.enclosure EQ.EnclosureCreate EQ.EnclosureEdit EQ.EnclosureKind EQ.EnclosureSide) (* ;;; "enclosure form functions") (FNS EQ.angles EQ.bars EQ.braces EQ.brackets EQ.parentheses EQ.enclosureForm EQ.enclosureWidth) (* ;;; "enclosure drawing functions") (FNS EQ.DrawAngles EQ.DrawBars EQ.DrawBraces EQ.DrawBrackets EQ.DrawParentheses) (* ;;; "EQMATRIX module: Part 3 of 5") (* ; "matrix equation functions") (FNS EQ.Matrix EQ.Make.matrix EQ.layout EQ.MatrixAdd EQ.MatrixChanged EQ.MatrixCreate EQ.MatrixDelete EQ.MatrixEdit EQ.MatrixGetMenu EQ.MatrixSelect) (INITVARS (EQ.Matrix.MaxPieces 100)) (GLOBALVARS EQ.Matrix.MaxPieces) [P (EQIO.AddType 'matrix 'EQ.Matrix 1 '(objectProps (rows 1 columns 1 enclosureKind NIL enclosureSide NIL) variable? T wholeEditFn EQ.MatrixEdit specialSelectFn EQ.MatrixSelect initialPropFn EQ.MatrixCreate changeFn EQ.MatrixChanged] (* ;;; "EQNFORMS module: Part 4 of 5") (* ; "fraction") (FNS EQ.Fraction EQ.Make.fraction) (* ;;; "sum group") (FNS EQ.SumGroup EQ.Make.sum EQ.Make.product EQ.Make.union EQ.Make.intersection) (* ;;; "integral group") (FNS EQ.IntegralGroup EQ.Make.integral EQ.Make.lineIntegral) (* ;;; "super- and sub- scripts") (FNS EQ.Script EQ.Make.sub/superscripts) (* ;;; "max/min/limit etc") (FNS EQ.MaxMin EQ.Make.max/min) (* ;;; "utilities") (FNS EQ.StreamSize EQ.UseNS? EQ.MakeNSItem) (GLOBALVARS EQ.UseNSChars EQ.NSChars) (* ;  "EQ.UseNSChars = NIL to use press fonts for display") [INITVARS EQ.UseNSChars (EQ.NSChars '(SUM ((CLASSIC 24) 9814) PRODUCT ((CLASSIC 24) 9811) SUM ((MODERN 30) 61306) PRODUCT ((MODERN 30) 61307) INTERSECTION ((MODERN 30) 61270) UNION ((MODERN 30) 61271) INTEGRAL ((MODERN 30) 61301) LINEINTEGRAL ((MODERN 30) 61302] [P [EQIO.AddType 'fraction 'EQ.Fraction 2 '(pieceNames ("numerator" "denominator"] [EQIO.AddType 'sum 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "summand"] [EQIO.AddType 'product 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "factor"] [EQIO.AddType 'union 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "set"] [EQIO.AddType 'intersection 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "set"] [EQIO.AddType 'integral 'EQ.IntegralGroup 3 '(initialData (-2 -2 0) pieceNames ("lower limit" "upper limit" "integrand"] (EQIO.AddType 'lineIntegral 'EQ.IntegralGroup 3 '(initialData (-2 -2 0) pieceNames ("lower limit" "upper limit" "integrand") menuLabel "line integral")) [EQIO.AddType 'sub/superscripts 'EQ.Script 5 '(initialData (0 -1 -1 -1 -1) pieceNames ("main value" "right subscript" "right superscript" "left subscript" "left superscript"] (EQIO.AddType 'max/min 'EQ.MaxMin 3 '(initialData (0 -2 0) pieceNames ("function" "index" "value") menuLabel "max min limit"] (* ;;; "EQROOT module: Part 5 of 5") (FNS EQ.Root EQ.Make.root) (FNS EQ.DrawRadicalSign) (P (EQIO.AddType 'root 'EQ.Root 2 '(pieceNames ("radicand" "index") initialData (0 -1]) (* ;;; "ATTACHEDBOX module: Part 1 of 5") (* ; "Utility functions to manipulate attached regions") (* ;; "These functions use two sets of coords: global coords in which positions are given w.r.t. the lower left corner of a box, and side coords in which positions are given w.r.t. a particular side of the box. For the side coords, the origin is at the point on the side closest to the l.l. corner of the box, the x-axis points along the side toward the other end, and the y-axis points away from the box region" ) (DEFINEQ (AB.RealPosition [LAMBDA (pos box side) (* THH " 8-May-85 11:31") (* returns position of pt. relative to l.l.  corner of box given position relative to specified side of box) (SELECTQ side ((top bottom) [create POSITION XCOORD _ (fetch XCOORD of pos) YCOORD _ (COND ((EQ side 'top) (PLUS (fetch YSIZE of box) (fetch YCOORD of pos))) (T (MINUS (fetch YCOORD of pos]) ((left right) [create POSITION YCOORD _ (fetch XCOORD of pos) XCOORD _ (COND ((EQ side 'right) (PLUS (fetch XSIZE of box) (fetch YCOORD of pos))) (T (MINUS (fetch YCOORD of pos]) NIL]) (AB.PointPos [LAMBDA (box side pt) (* THH " 8-May-85 11:34") (* returns position of pt relative to side --  pt is an atom specifying relative position along the side) (PROG [(horizSide (OR (EQ side 'top) (EQ side 'bottom] (RETURN (create POSITION XCOORD _ (SELECTQ pt (low (* lower end of side) 0) (display (* display pt of side) (COND (horizSide 0) (T (fetch YDESC of box)))) (center (* center of side) (IQUOTIENT (COND (horizSide (fetch XSIZE of box)) (T (fetch YSIZE of box))) 2)) (high (* upper end of side) (COND (horizSide (fetch XSIZE of box)) (T (fetch YSIZE of box)))) NIL) YCOORD _ 0]) (AB.SidePosition [LAMBDA (pos box side) (* THH " 8-May-85 11:32") (* returns position of pt rel. to side given position rel.  to l.l. corner of box) (SELECTQ side ((top bottom) [create POSITION XCOORD _ (fetch XCOORD of pos) YCOORD _ (COND ((EQ side 'top) (DIFFERENCE (fetch YCOORD of pos) (fetch YSIZE of box))) (T (MINUS (fetch YCOORD of pos]) ((left right) [create POSITION XCOORD _ (fetch YCOORD of pos) YCOORD _ (COND ((EQ side 'right) (DIFFERENCE (fetch XCOORD of pos) (fetch XSIZE of box))) (T (MINUS (fetch XCOORD of pos]) NIL]) (AB.PlaceRegion [LAMBDA (mainBox side mainPt addBox addPt gap shift) (* THH "10-May-85 16:51") (* returns placed region relative to l.l.  corner of main box when addBox is placed as specified) (PROG ((posMainPt (AB.PointPos mainBox side mainPt)) (opposite (AB.OppositeSide side)) posAddPt posSide) (SETQ posAddPt (create POSITION XCOORD _ (PLUS (fetch XCOORD of posMainPt) shift) YCOORD _ (PLUS (fetch YCOORD of posMainPt) gap))) (SETQ posSide (AB.PointPos addBox opposite addPt)) (replace XCOORD of posSide with (DIFFERENCE (fetch XCOORD of posAddPt) (fetch XCOORD of posSide))) (replace YCOORD of posSide with (fetch YCOORD of posAddPt)) (SETQ posSide (AB.AdjustToLL (AB.RealPosition posSide mainBox side) addBox side)) (RETURN (create REGION LEFT _ (fetch XCOORD of posSide) BOTTOM _ (fetch YCOORD of posSide) WIDTH _ (fetch XSIZE of addBox) HEIGHT _ (fetch YSIZE of addBox]) (AB.AdjustToLL [LAMBDA (pos addBox side) (* THH "10-May-85 14:58") (* gets position of l.l. corner of addBox w.r.t.  l.l of main box given pos of side opposite side of main box) (SELECTQ side ((top right) NIL) (left (replace XCOORD of pos with (DIFFERENCE (fetch XCOORD of pos) (fetch XSIZE of addBox)))) (bottom (replace YCOORD of pos with (DIFFERENCE (fetch YCOORD of pos) (fetch YSIZE of addBox)))) NIL) pos]) (AB.OppositeSide [LAMBDA (side) (* THH " 8-May-85 14:11") (SELECTQ side (top 'bottom) (bottom 'top) (left 'right) (right 'left) NIL]) (AB.RegionToBox [LAMBDA (region displayYPos) (* thh%: "13-May-85 10:16") (* returns image box corresponding to region whose y display position, relative  to (0,0) is given by displayYPos) (COND ((NOT displayYPos) (SETQ displayYPos 0))) (create IMAGEBOX XSIZE _ (fetch WIDTH of region) YSIZE _ (fetch HEIGHT of region) YDESC _ (DIFFERENCE displayYPos (fetch BOTTOM of region)) XKERN _ 0]) (AB.BoxToRegion [LAMBDA (box cornerXPos cornerYPos) (* thh%: "13-May-85 09:54") (* returns region corresponding to image box whose l.l.  corner is positioned at cornerXPos, cornerYPos --  if cornerYPos is NIL then cornerXPos should be a position) [COND ((NOT cornerYPos) (SETQ cornerYPos (fetch YCOORD of cornerXPos)) (SETQ cornerXPos (fetch XCOORD of cornerXPos] (create REGION LEFT _ cornerXPos BOTTOM _ cornerYPos WIDTH _ (fetch XSIZE of box) HEIGHT _ (fetch YSIZE of box]) (AB.RelativePos [LAMBDA (region bigRegion yShift) (* thh%: "13-May-85 10:27") (* returns relative position of l.l. of region w.r.t.  l.l. of bigRegion) (create POSITION XCOORD _ (DIFFERENCE (fetch LEFT of region) (fetch LEFT of bigRegion)) YCOORD _ (PLUS (DIFFERENCE (fetch BOTTOM of region) (fetch BOTTOM of bigRegion)) yShift]) (AB.BiggerRegion [LAMBDA (region extra) (* THH "23-May-85 14:03") (* creates a region that has extra  space all around) (* extra should be nonnegative) (COND ((OR (NOT extra) (ZEROP extra)) region) (T (create REGION LEFT _ (DIFFERENCE (fetch LEFT of region) extra) BOTTOM _ (DIFFERENCE (fetch BOTTOM of region) extra) WIDTH _ (PLUS (fetch WIDTH of region) (TIMES 2 extra)) HEIGHT _ (PLUS (fetch HEIGHT of region) (TIMES 2 extra]) (AB.Check [LAMBDA (region regionList side clear) (* THH "23-May-85 14:02") (* moves region away from side if it overlaps any regions in regionList) (COND ((NOT clear) (SETQ clear 0))) [COND ((GREATERP clear 0) (SETQ regionList (for r in regionList collect (AB.BiggerRegion r clear] (* must go through list repeatedly since moving region could cause it to  overlap previous regions) [repeatwhile overlap bind overlap do (SETQ overlap NIL) (for r in regionList do (COND ((REGIONSINTERSECTP region r) (SETQ overlap T) (SELECTQ side (top (replace BOTTOM of region with (PLUS (fetch BOTTOM of r) (fetch HEIGHT of r)))) (bottom (replace BOTTOM of region with (DIFFERENCE (fetch BOTTOM of r) (fetch HEIGHT of region)))) (left (replace LEFT of region with (DIFFERENCE (fetch LEFT of r) (fetch WIDTH of region)))) (right (replace LEFT of region with (PLUS (fetch LEFT of r) (fetch WIDTH of r)))) (SHOULDNT] region]) (AB.PositionRegion [LAMBDA (mainBox addedRegions side mainPt addBox addPt gap shift clear) (* thh%: " 9-Jan-86 10:00") (* positions addBox next to side of mainBox so that addPt on the added box is  at the specified relative position to the mainPt on the main box, then moves  addBox away from mainBox if necessary to avoid being within distance clear of  added regions on other sides as specified in addedRegions.  Returns (region newAddedRegions) where region is region of added box w.r.t.  l.l. corner of mainBox and newAddedRegions includes this new box to prevent  future additions from overlapping it) (PROG ((place (AB.Check (AB.PlaceRegion mainBox side mainPt addBox addPt gap shift) addedRegions side clear))) (RETURN (CONS place addedRegions]) (AB.Position2Regions [LAMBDA (mainBox addedRegions side highBox highPt lowBox lowPt highGap lowGap highShift lowShift clear) (* thh%: " 9-Jan-86 10:00") (* positions highBox and lowBox next to side on mainBox --  moves the boxes apart if they are closer than clear apart, and moves them away  from mainBox if they overlap previous regions as specfied by addedRegions) (* returns (highRegion lowRegion newAddedRegions) where regions are w.r.t.  l.l. corner of mainBox and newAddedRegions includes the added regions) (PROG (placeHigh placeLow) (SETQ placeHigh (AB.PlaceRegion mainBox side 'high highBox highPt highGap highShift)) (SETQ placeLow (AB.PlaceRegion mainBox side 'low lowBox lowPt lowGap lowShift)) (COND ((NOT clear) (SETQ clear 0))) [COND ((REGIONSINTERSECTP placeHigh (AB.BiggerRegion placeLow clear)) (* move regions apart) (PROG (shift totalSize) (* if the two added regions overlap  then separate them) (SELECTQ side ((top bottom) (SETQ shift (DIFFERENCE (PLUS (fetch LEFT of placeLow) (fetch WIDTH of placeLow) clear) (fetch LEFT of placeHigh))) [COND ((GREATERP shift 0) (SETQ totalSize (PLUS (fetch WIDTH of placeLow) (fetch WIDTH of placeHigh))) [add (fetch LEFT of placeLow) (MINUS (FIX (PLUS 0.5 (FQUOTIENT (TIMES shift (fetch WIDTH of placeLow)) totalSize] (add (fetch LEFT of placeHigh) (FIX (PLUS 0.5 (FQUOTIENT (TIMES shift (fetch WIDTH of placeHigh)) totalSize]) ((left right) (SETQ shift (DIFFERENCE (PLUS (fetch BOTTOM of placeLow) (fetch HEIGHT of placeLow) clear) (fetch BOTTOM of placeHigh))) [COND ((GREATERP shift 0) (SETQ totalSize (PLUS (fetch HEIGHT of placeLow) (fetch HEIGHT of placeHigh))) [add (fetch BOTTOM of placeLow) (MINUS (FIX (PLUS 0.5 (FQUOTIENT (TIMES shift (fetch HEIGHT of placeLow)) totalSize] (add (fetch BOTTOM of placeHigh) (FIX (PLUS 0.5 (FQUOTIENT (TIMES shift (fetch HEIGHT of placeHigh)) totalSize]) (SHOULDNT] (SETQ placeLow (AB.Check placeLow addedRegions side clear)) (SETQ placeHigh (AB.Check placeHigh addedRegions side clear)) (RETURN (CONS placeHigh (CONS placeLow addedRegions]) ) (* ;;; "EQGROUP module: Part 2 of 5") (* ; "group equation functions") (DEFINEQ (EQ.Group [LAMBDA (eqnObj imageStream draw?) (* THH "12-Jul-85 08:24") (* form function for group --  one argument with enclosure) (LET ((innerBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) enclose pos) (SETQ enclose (EQ.enclosure innerBox eqnObj imageStream draw?)) (SETQ pos (CDR enclose)) (add (fetch YCOORD of pos) (fetch YDESC of innerBox)) (EQIO.MakeSpec (CAR enclose) (LIST (EQIO.MakeDataSpec pos]) (EQ.GroupCreate [LAMBDA NIL (* thh%: " 1-Jul-85 14:57") (EQ.EnclosureCreate T]) (EQ.Make.group [LAMBDA (data enclosureKind enclosureSide fontSpec) (* thh%: " 9-Jan-86 10:24") (EQN.Make 'group (LIST data) fontSpec (LIST 'enclosureKind enclosureKind 'enclosureSide enclosureSide]) ) (* ; "set up data definitions") (EQIO.AddType 'group 'EQ.Group 1 '(objectProps (enclosureKind NIL enclosureSide NIL) pieceNames ("item") wholeEditFn EQ.EnclosureEdit initialPropFn EQ.GroupCreate)) (* ;;; "specific enclosure data") (DECLARE%: EVAL@COMPILE (RECORD EQ.EnclosureData (formFn label)) ) (DEFINEQ (EQ.AddEnclosure [LAMBDA (kind formFn label) (* THH "12-Jul-85 08:18") (* adds data for new form of enclosure) (LET ((enclosures (EQIO.TypeProp 'group 'enclosures)) (newValue (create EQ.EnclosureData formFn _ formFn label _ label))) [COND (enclosures (LISTPUT enclosures kind newValue)) (T (SETQ enclosures (LIST kind newValue] (EQIO.TypeProp 'group 'enclosures enclosures) (EQIO.TypeProp 'group 'kindMenu NIL]) (EQ.GetEnclosureData [LAMBDA (kind) (* THH "12-Jul-85 08:19") (LISTGET (EQIO.TypeProp 'group 'enclosures) kind]) ) (* ; "set up data for enclosures") (EQ.AddEnclosure 'angles (FUNCTION EQ.angles) "< angle brackets >") (EQ.AddEnclosure 'bars (FUNCTION EQ.bars) "| bars |") (EQ.AddEnclosure 'braces (FUNCTION EQ.braces) "{ braces }") (EQ.AddEnclosure 'brackets (FUNCTION EQ.brackets) "[ brackets ]") (EQ.AddEnclosure 'parentheses (FUNCTION EQ.parentheses) "( parentheses )") (EQIO.TypeProp 'group 'defaultEnclosure 'brackets) (* ;;; "general enclosure functions") (DEFINEQ (EQ.enclosure [LAMBDA (innerBox eqnObj imageStream draw?) (* THH "12-Jul-85 08:32") (* returns (outerBox . pos) where outerBox is box with enclosures and pos is  position of l.l. corner of inner box wrt l.l.  corner of outer box) (* if draw? is non-NIL, draws the  enclosures) (LET [[kind (OR (EQIO.EqnProperty eqnObj 'enclosureKind) (EQIO.TypeProp 'group 'defaultEnclosure] (which (EQIO.EqnProperty eqnObj 'enclosureSide] (COND ([NOT (OR (EQ which 'left) (EQ which 'right] (SETQ which NIL))) (LET [(formFn (fetch (EQ.EnclosureData formFn) of (EQ.GetEnclosureData kind] (COND (formFn (* note%: use of kind arg allows same formFn to be used for different  enclosures) (APPLY* formFn innerBox imageStream draw? which kind)) (T (* no enclosure so outer box is same as inner box) (CONS innerBox (create POSITION XCOORD _ 0 YCOORD _ 0]) (EQ.EnclosureCreate [LAMBDA (getWhich?) (* thh%: " 1-Jul-85 14:46") (* returns prop list describing  desired enclosure) (* if getWhich? is non-NIL also asks for side specification for enclosure) (LET ((kind (EQ.EnclosureKind)) which) (COND (getWhich? (SETQ which (EQ.EnclosureSide)) (LIST 'enclosureKind kind 'enclosureSide which)) (T (LIST 'enclosureKind kind]) (EQ.EnclosureEdit [LAMBDA (eqnObj) (* thh%: " 1-Jul-85 14:55") (* allows type of enclosure to be  changed) (* returns non-NIL if object changed) (LET ((editMenu (EQIO.TypeProp 'group 'editMenu)) newValue) (COND ((NOT (type? MENU editMenu)) [SETQ editMenu (create MENU CENTERFLG _ T TITLE _ "change what?" ITEMS _ '(("symbol" 'kind) ("which side" 'side] (EQIO.TypeProp 'group 'editMenu editMenu))) (SELECTQ (MENU editMenu) (kind (COND ((SETQ newValue (EQ.EnclosureKind)) (EQIO.EqnProperty eqnObj 'enclosureKind newValue) T) (T NIL))) (side (COND ((SETQ newValue (EQ.EnclosureSide)) (EQIO.EqnProperty eqnObj 'enclosureSide newValue) T) (T NIL))) NIL]) (EQ.EnclosureKind [LAMBDA NIL (* THH "12-Jul-85 08:39") (* gets desired kind of enclosure) (LET [(kindMenu (EQIO.TypeProp 'group 'kindMenu] (COND ((NOT (type? MENU kindMenu)) (SETQ kindMenu (create MENU CENTERFLG _ T ITEMS _ [LET [(enclosures (EQIO.TypeProp 'group 'enclosures] (while enclosures bind kind data collect (SETQ kind (CAR enclosures)) (SETQ data (CADR enclosures)) (SETQ enclosures (CDDR enclosures)) (LIST (fetch (EQ.EnclosureData label) of data) (KWOTE kind] TITLE _ "enclosures")) (EQIO.TypeProp 'group 'kindMenu kindMenu))) (MENU kindMenu]) (EQ.EnclosureSide [LAMBDA NIL (* thh%: " 1-Jul-85 14:48") (* gets desired side for enclosure) (LET [(whichMenu (EQIO.TypeProp 'group 'whichMenu] (COND ((NOT (type? MENU whichMenu)) (SETQ whichMenu (create MENU ITEMS _ '(left right both) TITLE _ "Which side?")) (EQIO.TypeProp 'group 'whichMenu whichMenu))) (MENU whichMenu]) ) (* ;;; "enclosure form functions") (DEFINEQ (EQ.angles [LAMBDA (innerBox imageStream draw? which) (* ; "Edited 21-Apr-87 09:00 by thh:") (LET ((size (EQ.StreamSize imageStream)) Hgap Hex Vgap Vex width height descent spacing overlap) (SETQ Hex size) (SETQ Vgap size) (SETQ Vex Hex) (SETQ height (PLUS (fetch YSIZE of innerBox) (TIMES 2 Vgap))) (SETQ width (EQ.enclosureWidth size height)) (SETQ Hgap (MAX (TIMES 3 size) (IQUOTIENT height 5))) [SETQ spacing (PLUS (fetch XSIZE of innerBox) (TIMES 2 (PLUS Hgap width] (SETQ descent (PLUS (fetch YDESC of innerBox) Vgap)) (SETQ overlap (MAX (TIMES 2 size) (IQUOTIENT (PLUS Hgap width) 2))) (* * draw angle brackets if requested) (COND (draw? (EQ.DrawAngles height descent spacing Hex width overlap imageStream which))) (* * determine outer box and position of inner box) (EQ.enclosureForm spacing Hex height Vex descent width NIL Hgap Vgap]) (EQ.bars [LAMBDA (innerBox imageStream draw? which) (* ; "Edited 21-Apr-87 09:00 by thh:") (LET ((size (EQ.StreamSize imageStream)) Hgap Hex Vgap Vex width height descent spacing) (SETQ Hgap (TIMES 2 size)) (SETQ Hex size) (SETQ Vgap Hgap) (SETQ Vex Hex) (SETQ height (PLUS (fetch YSIZE of innerBox) (TIMES 2 Vgap))) (SETQ width (EQ.enclosureWidth size height)) [SETQ spacing (PLUS (fetch XSIZE of innerBox) (TIMES 2 (PLUS Hgap width] (SETQ descent (PLUS (fetch YDESC of innerBox) Vgap)) (* * draw bars if requested) (COND (draw? (EQ.DrawBars height descent spacing Hex width imageStream which))) (* * determine outer box and position of inner box) (EQ.enclosureForm spacing Hex height Vex descent width NIL Hgap Vgap]) (EQ.braces [LAMBDA (innerBox imageStream draw? which) (* ; "Edited 21-Apr-87 09:01 by thh:") (LET ((size (EQ.StreamSize imageStream)) Hgap Hex Vgap Vex width height descent spacing overlap point space extra) (SETQ Vgap (TIMES 3 size)) (SETQ Hex size) (SETQ Vex Hex) (SETQ height (PLUS (fetch YSIZE of innerBox) (TIMES 2 Vgap))) (SETQ width (EQ.enclosureWidth size height)) (add height (TIMES 2 width)) (SETQ descent (PLUS (fetch YDESC of innerBox) Vgap width)) (SETQ Hgap (MAX (TIMES 4 size) (IQUOTIENT height 5))) [SETQ spacing (PLUS (fetch XSIZE of innerBox) (TIMES 2 (PLUS Hgap width] (SETQ overlap (PLUS Hgap width)) (SETQ point (PLUS size (IQUOTIENT overlap 2))) (SETQ space (IQUOTIENT overlap 2)) (SETQ extra space) (* * draw braces if requested) (COND (draw? (EQ.DrawBraces height descent spacing Hex width overlap extra point space imageStream which))) (* * determine outer box and position of inner box) (EQ.enclosureForm spacing Hex height Vex descent width T Hgap Vgap]) (EQ.brackets [LAMBDA (innerBox imageStream draw? which) (* ; "Edited 21-Apr-87 09:02 by thh:") (LET ((size (EQ.StreamSize imageStream)) Hgap Hex Vgap Vex width height descent spacing overlap) (SETQ Hgap (TIMES 3 size)) (SETQ Hex size) (SETQ Vgap Hgap) (SETQ Vex Hex) (SETQ height (PLUS (fetch YSIZE of innerBox) (TIMES 2 Vgap))) (SETQ width (EQ.enclosureWidth size height)) (add height (TIMES 2 width)) [SETQ spacing (PLUS (fetch XSIZE of innerBox) (TIMES 2 (PLUS Hgap width] (SETQ descent (PLUS (fetch YDESC of innerBox) Vgap width)) (SETQ overlap (MAX (TIMES 3 size) (PLUS Hgap width))) (* * draw brackets if requested) (COND (draw? (EQ.DrawBrackets height descent spacing Hex width overlap imageStream which))) (* * determine outer box and position of inner box) (EQ.enclosureForm spacing Hex height Vex descent width T Hgap Vgap]) (EQ.parentheses [LAMBDA (innerBox imageStream draw? which) (* ; "Edited 21-Apr-87 09:03 by thh:") (LET ((size (EQ.StreamSize imageStream)) Hgap Hex Vgap Vex width height descent spacing overlap) (SETQ Vgap (TIMES 2 size)) (SETQ Hex size) (SETQ Vex Hex) (SETQ height (PLUS (fetch YSIZE of innerBox) (TIMES 2 Vgap))) (SETQ width (EQ.enclosureWidth size height)) (add height (TIMES 2 width)) (SETQ descent (PLUS (fetch YDESC of innerBox) Vgap width)) (SETQ Hgap (MAX (TIMES 2 size) (IQUOTIENT height 8))) [SETQ spacing (PLUS (fetch XSIZE of innerBox) (TIMES 2 (PLUS Hgap width] (SETQ overlap (MAX (TIMES 3 size) (IQUOTIENT (PLUS Hgap width) 2))) (* * draw braces if requested) (COND (draw? (EQ.DrawParentheses height descent spacing Hex width overlap imageStream which))) (* * determine outer box and position of inner box) (EQ.enclosureForm spacing Hex height Vex descent width T Hgap Vgap]) (EQ.enclosureForm [LAMBDA (spacing Hex height Vex descent width verticalWidth? Hgap Vgap) (* ; "Edited 21-Apr-87 08:59 by thh:") (* computes outer box and position of inner box from parameters --  verticalWidth? non-NIL means enclosure wraps under the box) (CONS (create IMAGEBOX XSIZE _ (PLUS spacing (TIMES 2 Hex)) YSIZE _ (PLUS height (TIMES 2 Vex)) YDESC _ (PLUS descent Vex) XKERN _ 0) (create POSITION XCOORD _ (PLUS Hgap width Hex) YCOORD _ (PLUS Vgap (COND (verticalWidth? width) (T 0)) Vex]) (EQ.enclosureWidth [LAMBDA (size height) (* THH "16-Jul-85 09:15") (MAX size (IQUOTIENT height 100]) ) (* ;;; "enclosure drawing functions") (DEFINEQ (EQ.DrawAngles [LAMBDA (height descent spacing xShift width overlap imageStream which) (* thh%: "19-Aug-85 09:49") (* draws specified angle brackets on  imageStream) (LET ((halfWidth (IQUOTIENT width 2)) (halfWidth1 (IQUOTIENT (SUB1 width) 2)) (lowerX (PLUS (DSPXPOSITION NIL imageStream) xShift)) (lowerY (DIFFERENCE (DSPYPOSITION NIL imageStream) descent)) top middle left right) (SETQ top (PLUS lowerY (SUB1 height))) (SETQ middle (PLUS lowerY (IQUOTIENT (SUB1 height) 2))) (* * left angle bracket) (COND ((NOT (EQ which 'right)) (SETQ left (PLUS lowerX overlap halfWidth)) (DRAWLINE left lowerY (PLUS lowerX halfWidth) middle width NIL imageStream) (DRAWLINE (PLUS lowerX halfWidth) middle left top width NIL imageStream))) (* * right angle bracket) (COND ((NOT (EQ which 'left)) [SETQ right (PLUS lowerX (SUB1 spacing) (MINUS (PLUS overlap halfWidth1] (DRAWLINE right lowerY (PLUS lowerX (SUB1 spacing) (MINUS halfWidth1)) middle width NIL imageStream) (DRAWLINE (PLUS lowerX (SUB1 spacing) (MINUS halfWidth1)) middle right top width NIL imageStream]) (EQ.DrawBars [LAMBDA (height descent spacing xShift width imageStream which) (* thh%: "19-Aug-85 09:53") (* draws specified vertical bar on  imageStream) (PROG ((halfWidth (IQUOTIENT width 2)) (halfWidth1 (IQUOTIENT (SUB1 width) 2)) (lowerX (PLUS (DSPXPOSITION NIL imageStream) xShift)) (lowerY (DIFFERENCE (DSPYPOSITION NIL imageStream) descent))) (* * left bar) (COND ((NOT (EQ which 'right)) (MOVETO (PLUS lowerX halfWidth1) lowerY imageStream) (RELDRAWTO 0 (SUB1 height) width NIL imageStream))) (* * right bar) (COND ((NOT (EQ which 'left)) (MOVETO (DIFFERENCE (PLUS lowerX spacing) halfWidth) lowerY imageStream) (RELDRAWTO 0 (SUB1 height) width NIL imageStream]) (EQ.DrawBraces [LAMBDA (height descent spacing xShift width overlap extra point space imageStream which) (* THH "16-Jul-85 09:20") (* draws specified brace on  imageStream) (LET ((halfWidth (IQUOTIENT width 2)) (halfWidth1 (IQUOTIENT (SUB1 width) 2)) (lowerX (PLUS (DSPXPOSITION NIL imageStream) xShift)) (lowerY (DIFFERENCE (DSPYPOSITION NIL imageStream) descent)) top middle left1 left2 right1 right2) (SETQ top (PLUS lowerY (SUB1 height))) (SETQ middle (PLUS lowerY (IQUOTIENT (SUB1 height) 2))) (* * left brace) (COND ((NOT (EQ which 'right)) (SETQ left1 (PLUS lowerX (SUB1 overlap))) (SETQ left2 (PLUS lowerX (SUB1 point))) (DRAWCURVE (LIST (create POSITION XCOORD _ left1 YCOORD _ lowerY) (create POSITION XCOORD _ left2 YCOORD _ (PLUS lowerY extra)) (create POSITION XCOORD _ left2 YCOORD _ (DIFFERENCE middle (SUB1 space))) (create POSITION XCOORD _ lowerX YCOORD _ middle)) NIL width NIL imageStream) (DRAWCURVE (LIST (create POSITION XCOORD _ lowerX YCOORD _ middle) (create POSITION XCOORD _ left2 YCOORD _ (PLUS middle (SUB1 space))) (create POSITION XCOORD _ left2 YCOORD _ (DIFFERENCE top extra)) (create POSITION XCOORD _ left1 YCOORD _ top)) NIL width NIL imageStream))) (* * right brace) (COND ((NOT (EQ which 'left)) [SETQ right1 (PLUS lowerX (SUB1 spacing) (MINUS (SUB1 overlap] [SETQ right2 (PLUS lowerX (SUB1 spacing) (MINUS (SUB1 point] (DRAWCURVE (LIST (create POSITION XCOORD _ right1 YCOORD _ lowerY) (create POSITION XCOORD _ right2 YCOORD _ (PLUS lowerY extra)) (create POSITION XCOORD _ right2 YCOORD _ (DIFFERENCE middle (SUB1 space))) (create POSITION XCOORD _ (PLUS lowerX (SUB1 spacing)) YCOORD _ middle)) NIL width NIL imageStream) (DRAWCURVE (LIST (create POSITION XCOORD _ (PLUS lowerX (SUB1 spacing)) YCOORD _ middle) (create POSITION XCOORD _ right2 YCOORD _ (PLUS middle (SUB1 space))) (create POSITION XCOORD _ right2 YCOORD _ (DIFFERENCE top extra)) (create POSITION XCOORD _ right1 YCOORD _ top)) NIL width NIL imageStream]) (EQ.DrawBrackets [LAMBDA (height descent spacing xShift width overlap imageStream which) (* THH "12-Jul-85 09:06") (* draws specified bracket on  imageStream) (PROG ((halfWidth (IQUOTIENT width 2)) (halfWidth1 (IQUOTIENT (SUB1 width) 2)) (lowerX (PLUS (DSPXPOSITION NIL imageStream) xShift)) (lowerY (DIFFERENCE (DSPYPOSITION NIL imageStream) descent))) (* * left bracket) (COND ((NOT (EQ which 'right)) (MOVETO (PLUS lowerX halfWidth1) lowerY imageStream) (RELDRAWTO 0 (SUB1 height) width NIL imageStream) (RELMOVETO 0 (MINUS halfWidth) imageStream) (RELDRAWTO overlap 0 width NIL imageStream) (MOVETO (PLUS lowerX (SUB1 width)) (PLUS lowerY halfWidth1) imageStream) (RELDRAWTO overlap 0 width NIL imageStream))) (* * right bracket) (COND ((NOT (EQ which 'left)) (MOVETO (DIFFERENCE (PLUS lowerX spacing) (PLUS overlap width)) (PLUS lowerY halfWidth1) imageStream) (RELDRAWTO overlap 0 width NIL imageStream) (RELMOVETO halfWidth1 (MINUS halfWidth1) imageStream) (RELDRAWTO 0 (SUB1 height) width NIL imageStream) (RELMOVETO 0 (MINUS halfWidth) imageStream) (RELDRAWTO (MINUS overlap) 0 width NIL imageStream]) (EQ.DrawParentheses [LAMBDA (height descent spacing xShift width overlap imageStream which) (* THH "12-Jul-85 09:06") (* draws specified parenthesis on  imageStream) (LET ((halfWidth (IQUOTIENT width 2)) (halfWidth1 (IQUOTIENT (SUB1 width) 2)) (lowerX (PLUS (DSPXPOSITION NIL imageStream) xShift)) (lowerY (DIFFERENCE (DSPYPOSITION NIL imageStream) descent)) top middle left right) (SETQ top (PLUS lowerY (SUB1 height))) (SETQ middle (PLUS lowerY (IQUOTIENT (SUB1 height) 2))) (* * left parenthesis) (COND ((NOT (EQ which 'right)) (SETQ left (PLUS lowerX overlap halfWidth)) (DRAWCURVE (LIST (create POSITION XCOORD _ left YCOORD _ lowerY) (create POSITION XCOORD _ (PLUS lowerX halfWidth) YCOORD _ middle) (create POSITION XCOORD _ left YCOORD _ top)) NIL width NIL imageStream))) (* * right parenthesis) (COND ((NOT (EQ which 'left)) [SETQ right (PLUS lowerX (SUB1 spacing) (MINUS (PLUS overlap halfWidth1] (DRAWCURVE (LIST (create POSITION XCOORD _ right YCOORD _ lowerY) (create POSITION XCOORD _ (PLUS lowerX (SUB1 spacing) (MINUS halfWidth1)) YCOORD _ middle) (create POSITION XCOORD _ right YCOORD _ top)) NIL width NIL imageStream]) ) (* ;;; "EQMATRIX module: Part 3 of 5") (* ; "matrix equation functions") (DEFINEQ (EQ.Matrix [LAMBDA (eqnObj imageStream draw?) (* THH "12-Jul-85 09:50") (* form function for matrix) (* this equation form allows a variable number of parts arranged and stored in  rows) (LET ((layout (EQ.layout eqnObj imageStream)) enclose specs) (SETQ enclose (EQ.enclosure (EQIO.GetBox layout) eqnObj imageStream draw?)) (* * enclose of form (outerBox . pos) --  must now shift positions of individual pieces in layout  (assumes no selection region in layout --  it would also need to be shifted)) (SETQ specs (EQIO.GetDataSpecList layout)) (for dataSpec in specs bind pos (xShift _ (fetch (POSITION XCOORD) of (CDR enclose))) (yShift _ (fetch (POSITION YCOORD) of (CDR enclose))) do (SETQ pos (EQIO.GetDataPosition dataSpec)) (add (fetch (POSITION XCOORD) of pos) xShift) (add (fetch (POSITION YCOORD) of pos) yShift)) (EQIO.MakeSpec (CAR enclose) specs]) (EQ.Make.matrix [LAMBDA (rows columns dataList enclosureKind enclosureSide fontSpec) (* thh%: " 9-Jan-86 10:23") (* * may want to call initial prop fn???) (LET ((numPieces (TIMES rows columns))) (EQN.Make 'matrix dataList fontSpec (LIST 'numPieces numPieces 'rows rows 'columns columns 'enclosureKind enclosureKind 'enclosureSide enclosureSide]) (EQ.layout [LAMBDA (eqnObj imageStream) (* THH "12-Jul-85 10:26") (* form function for table of parts) (* this equation form allows a variable number of parts arranged and stored in  rows) (* layout defined by rowGap -- distance between rows, colGap --  distance between columns, shift -- distance of center above baseline) (LET ((size (EQ.StreamSize imageStream)) (columns (EQIO.EqnProperty eqnObj 'columns)) (rows (EQIO.EqnProperty eqnObj 'rows)) (fontSpec (FONTCREATE (COND ((EQIO.EqnProperty eqnObj 'fontSpec)) (T DEFAULTFONT)) NIL NIL NIL imageStream)) layoutBox boxList colData rowData colGap rowGap shift) (* * set quantities that define layout) (SETQ shift (IQUOTIENT (FONTPROP fontSpec 'ASCENT) 2)) (SETQ colGap (STRINGWIDTH " " fontSpec)) (SETQ rowGap colGap) (* * determine overall box) [COND ((OR (ILEQ columns 0) (ILEQ rows 0)) (SETQ layoutBox (create IMAGEBOX XSIZE _ 0 YSIZE _ 0))) (T (SETQ boxList (for piece in (EQIO.EqnDataList eqnObj) collect (FS.Box piece imageStream))) (SETQ colData (ARRAY columns 'FIXP 0)) (SETQ rowData (ARRAY rows)) (for row from 1 to rows bind (boxes _ boxList) rAscent rDesc do (SETQ rAscent 0) (SETQ rDesc 0) [for col from 1 to columns bind b do (SETQ b (CAR boxes)) (SETQ boxes (CDR boxes)) [SETQ rAscent (MAX rAscent (DIFFERENCE (fetch YSIZE of b) (fetch YDESC of b] (SETQ rDesc (MAX rDesc (fetch YDESC of b))) (SETA colData col (MAX (ELT colData col) (fetch XSIZE of b] (SETA rowData row (CONS (PLUS rAscent rDesc) rDesc))) (SETQ layoutBox (create IMAGEBOX XSIZE _ (PLUS (for col from 1 to columns sum (ELT colData col)) (TIMES (SUB1 columns) colGap)) YSIZE _ (PLUS (for row from 1 to rows sum (CAR (ELT rowData row))) (TIMES (SUB1 rows) rowGap] (replace YDESC of layoutBox with (DIFFERENCE (IQUOTIENT (fetch YSIZE of layoutBox) 2) shift)) (replace XKERN of layoutBox with 0) (* * return overall box and individual positions of all the parts) (LET [(xLow 0) (yHigh (fetch YSIZE of layoutBox)) (colPos (ARRAY columns 'FIXP] (* (xLow,yHigh) is position of upper left corner of block of matrix parts) [COND ((IGREATERP columns 0) (* set colPos to horizontal position of left edge of each column) (SETA colPos 1 xLow) (for col from 2 to columns do (SETA colPos col (PLUS (ELT colPos (SUB1 col)) colGap (ELT colData (SUB1 col] (EQIO.MakeSpec layoutBox (COND [(AND (IGREATERP columns 0) (IGREATERP rows 0)) (for row from 1 to rows bind rowValue (boxes _ boxList) (rowPos _ (PLUS yHigh rowGap)) join [SETQ rowPos (DIFFERENCE rowPos (PLUS rowGap (CAR (SETQ rowValue (ELT rowData row] (* rowPos is vertical position of  bottom of row) (for col from 1 to columns bind b collect (SETQ b (CAR boxes)) (SETQ boxes (CDR boxes)) (EQIO.MakeDataSpec (create POSITION XCOORD _ (PLUS (ELT colPos col) (IQUOTIENT (DIFFERENCE (ELT colData col) (fetch XSIZE of b)) 2)) YCOORD _ (PLUS rowPos (CDR rowValue] (T (* no pieces in this layout) NIL]) (EQ.MatrixAdd [LAMBDA (eqnObj which place window) (* thh%: " 3-Jun-85 10:19") (* adds new row/column to matrix) (* currently copies lists when adding new data instead of modifying the  original lists) (PROG ((rows (EQIO.EqnProperty eqnObj 'rows)) (columns (EQIO.EqnProperty eqnObj 'columns)) (dataList (EQIO.EqnDataList eqnObj)) newData tempData firstPiece continueFlg) (SELECTQ which (row (SETQ newData (EQN.DefaultData (EQIO.EqnType eqnObj) (EQIO.EqnProperty eqnObj 'fontSpec) columns)) (* insert newData after the  place*columns piece) (SETQ tempData (for d in dataList as i from 1 to (TIMES place columns) collect (SETQ dataList (CDR dataList)) d)) (EQIO.SetDataList eqnObj (APPEND tempData newData dataList)) (add rows 1) (EQIO.EqnProperty eqnObj 'rows rows) (SETQ firstPiece (ADD1 (TIMES columns place))) [SETQ continueFlg (CONS 1 (TIMES columns (ADD1 place]) (column (SETQ newData (EQN.DefaultData (EQIO.EqnType eqnObj) (EQIO.EqnProperty eqnObj 'fontSpec) rows)) [EQIO.SetDataList eqnObj (for i from 1 to rows bind newD join (SETQ newD (CAR newData)) (SETQ newData (CDR newData)) (APPEND (for j from 1 to place bind d collect (SETQ d (CAR dataList)) (SETQ dataList (CDR dataList)) d) (LIST newD) (for j from (ADD1 place) to columns bind d collect (SETQ d (CAR dataList)) (SETQ dataList (CDR dataList)) d] (add columns 1) (EQIO.EqnProperty eqnObj 'columns columns) (SETQ firstPiece (ADD1 place)) (SETQ continueFlg (LIST columns))) (ERROR "EQ.MatrixAdd: invalid arg for which = " which)) (EQIO.NumPieces eqnObj (TIMES rows columns)) (EQN.StartEdit eqnObj window firstPiece continueFlg 'PENDINGDEL]) (EQ.MatrixChanged [LAMBDA (eqnObj) (* thh%: "31-May-85 14:21") (* called when number of pieces in  matrix changed) (EQIO.EqnProperty eqnObj 'rowMenu NIL) (EQIO.EqnProperty eqnObj 'colMenu NIL]) (EQ.MatrixCreate [LAMBDA NIL (* THH "12-Jul-85 10:04") (* allows user to specify initial number of rows and columns in a new matrix) (LET (rows columns numPieces retry) (repeatwhile (GREATERP numPieces EQ.Matrix.MaxPieces) do (COND (retry (CLRPROMPT) (PROMPTPRINT "Too many matrix elements: " numPieces " [max allowed is " EQ.Matrix.MaxPieces "]"))) (SETQ rows (MAX (RNUMBER "How many rows for matrix?") 0)) (SETQ columns (MAX (RNUMBER "How many columns for matrix?") 0)) (SETQ numPieces (TIMES rows columns)) (SETQ retry T)) (LIST 'numPieces numPieces 'rows rows 'columns columns]) (EQ.MatrixDelete [LAMBDA (eqnObj which place) (* thh%: " 3-Jun-85 11:56") (* deletes row/column from matrix) (COND ((IGREATERP place 0) (PROG ((rows (EQIO.EqnProperty eqnObj 'rows)) (columns (EQIO.EqnProperty eqnObj 'columns)) (dataList (EQIO.EqnDataList eqnObj))) (SELECTQ which (row [EQIO.SetDataList eqnObj (for d in dataList as i from 1 bind (start _ (TIMES (SUB1 place) columns)) (stop _ (TIMES place columns)) collect d unless (AND (IGREATERP i start) (ILEQ i stop] (add rows -1) (EQIO.EqnProperty eqnObj 'rows rows)) (column (EQIO.SetDataList eqnObj (for d in dataList bind (j _ 0) eachtime (COND ((IGEQ j columns) (SETQ j 0))) (add j 1) collect d unless (IEQP j place))) (add columns -1) (EQIO.EqnProperty eqnObj 'columns columns)) (ERROR "EQ.MatrixDelete: invalid arg for which = " which)) (EQIO.NumPieces eqnObj (TIMES rows columns]) (EQ.MatrixEdit [LAMBDA (eqnObj window button) (* THH "12-Jul-85 10:08") (* adds and removes rows and columns  from matrix) (* returns non-NIL if eqnObj modified) (COND [(EQ (EQIO.EqnType eqnObj) 'matrix) (LET ((editMenu (EQIO.TypeProp 'matrix 'editMenu)) action place) (COND ((NOT (type? MENU editMenu)) [SETQ editMenu (create MENU CENTERFLG _ T ITEMS _ '(("add before col" 'beforeCol) ("add before row" 'beforeRow) ("add after col" 'afterCol) ("add after row" 'afterRow) ("DELETE column" 'delCol) ("DELETE row" 'delRow) ("[change enclosure]" 'enclosure] (EQIO.TypeProp 'matrix 'editMenu editMenu))) (SETQ action (MENU editMenu)) (COND ((EQ action 'enclosure) (EQ.EnclosureEdit eqnObj)) (T (* edit layout) (SETQ place (SELECTQ action ((beforeCol afterCol delCol) (COND [(IGREATERP (EQIO.EqnProperty eqnObj 'columns) 0) (MENU (EQ.MatrixGetMenu eqnObj 'column] ((EQ action 'beforeCol) 1) (T 0))) ((beforeRow afterRow delRow) (COND [(IGREATERP (EQIO.EqnProperty eqnObj 'rows) 0) (MENU (EQ.MatrixGetMenu eqnObj 'row] ((EQ action 'beforeRow) 1) (T 0))) NIL)) (COND (place [COND ((EQ action 'beforeCol) (add place -1) (SETQ action 'afterCol)) ((EQ action 'beforeRow) (add place -1) (SETQ action 'afterRow] (SELECTQ action (afterCol (EQ.MatrixAdd eqnObj 'column place window) T) (afterRow (EQ.MatrixAdd eqnObj 'row place window) T) (delCol (EQ.MatrixDelete eqnObj 'column place) T) (delRow (EQ.MatrixDelete eqnObj 'row place) T) NIL] (T (* eqnObj not a matrix) NIL]) (EQ.MatrixGetMenu [LAMBDA (eqnObj which) (* thh%: " 3-Jun-85 09:35") (* gets menu for eqnObj, which is either row or column) (SELECTQ which (row (PROG [(rowMenu (EQIO.EqnProperty eqnObj 'rowMenu] (COND ((NOT (type? MENU rowMenu)) (SETQ rowMenu (create MENU TITLE _ "row #" ITEMS _ (for i from 1 to (EQIO.EqnProperty eqnObj 'rows) collect i))) (EQIO.EqnProperty eqnObj 'rowMenu rowMenu))) (RETURN rowMenu))) (column (PROG [(colMenu (EQIO.EqnProperty eqnObj 'colMenu] (COND ((NOT (type? MENU colMenu)) (SETQ colMenu (create MENU TITLE _ "col #" MENUROWS _ 1 ITEMS _ (for i from 1 to (EQIO.EqnProperty eqnObj 'columns) collect i))) (EQIO.EqnProperty eqnObj 'colMenu colMenu))) (RETURN colMenu))) NIL]) (EQ.MatrixSelect [LAMBDA (eqnObj) (* thh%: " 3-Jun-85 09:20") (* selects piece to edit by row and  column number) (COND [(EQ (EQIO.EqnType eqnObj) 'matrix) (PROG (row col) (COND ((IGREATERP (EQIO.NumPieces eqnObj) 0) [SETQ row (MENU (EQ.MatrixGetMenu eqnObj 'row] (COND (row [SETQ col (MENU (EQ.MatrixGetMenu eqnObj 'column] (COND (col (RETURN (PLUS (TIMES (EQIO.EqnProperty eqnObj 'columns) (SUB1 row)) col] (T (* eqnObj is not a matrix) NIL]) ) (RPAQ? EQ.Matrix.MaxPieces 100) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EQ.Matrix.MaxPieces) ) (EQIO.AddType 'matrix 'EQ.Matrix 1 '(objectProps (rows 1 columns 1 enclosureKind NIL enclosureSide NIL) variable? T wholeEditFn EQ.MatrixEdit specialSelectFn EQ.MatrixSelect initialPropFn EQ.MatrixCreate changeFn EQ.MatrixChanged)) (* ;;; "EQNFORMS module: Part 4 of 5") (* ; "fraction") (DEFINEQ (EQ.Fraction [LAMBDA (eqnObj imageStream draw?) (* THH "21-May-85 12:14") (* form function for fraction) (* fraction defined by shift -- distance of line above base, gap --  space above and below the line, width --  width of the line and extend -- extra length of line on either side) (* these parameters could be specified by props to allow user to change them) (PROG ((size (EQ.StreamSize imageStream)) shift gap width extend nBox dBox pos box pNumer pDenom) (SETQ shift (IQUOTIENT (FONTPROP (FONTCREATE (COND ((EQIO.EqnProperty eqnObj 'fontSpec)) (T DEFAULTFONT)) NIL NIL NIL imageStream) 'ASCENT) 2)) (SETQ gap size) (SETQ width size) (SETQ extend size) (SETQ nBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) (SETQ dBox (FS.Box (EQIO.EqnData eqnObj 2) imageStream)) (SETQ pos (PLUS (fetch YSIZE of dBox) (TIMES 2 gap) width)) (* pos is distance from bottom of box to bottom of numerator) (SETQ box (create IMAGEBOX XSIZE _ (PLUS (MAX (fetch XSIZE of nBox) (fetch XSIZE of dBox)) (TIMES 2 extend)) YSIZE _ (PLUS (fetch YSIZE of nBox) pos) YDESC _ (PLUS gap (fetch YSIZE of dBox) (MINUS shift)) XKERN _ 0)) [SETQ pNumer (create POSITION XCOORD _ (IQUOTIENT (DIFFERENCE (fetch XSIZE of box) (fetch XSIZE of nBox)) 2) YCOORD _ (PLUS pos (fetch YDESC of nBox] (SETQ pDenom (create POSITION XCOORD _ (IQUOTIENT (DIFFERENCE (fetch XSIZE of box) (fetch XSIZE of dBox)) 2) YCOORD _ (fetch YDESC of dBox))) (COND (draw? (* note that original x,y pos not  preserved) (RELMOVETO 0 shift imageStream) (RELDRAWTO (fetch XSIZE of box) 0 width NIL imageStream))) [RETURN (EQIO.MakeSpec box (LIST (EQIO.MakeDataSpec pNumer (create REGION LEFT _ 0 BOTTOM _ pos WIDTH _ (fetch XSIZE of box) HEIGHT _ (fetch YSIZE of nBox))) (EQIO.MakeDataSpec pDenom (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch XSIZE of box) HEIGHT _ (fetch YSIZE of dBox] (* selection region for numerator (denominator) is entire top  (bottom) half of fraction) ]) (EQ.Make.fraction [LAMBDA (numerator denominator fontSpec) (* thh%: " 9-Jan-86 10:14") (EQN.Make 'fraction (LIST numerator denominator) fontSpec]) ) (* ;;; "sum group") (DEFINEQ (EQ.SumGroup [LAMBDA (eqnObj imageStream draw?) (* ; "Edited 18-Apr-88 13:30 by thh:") (* ;  "form function for forms drawn like a summation") (* ;; "form defined by gap -- distance between symbol and index (below) and limits (above), and vGap -- distance between symbol and value") (PROG ((size (EQ.StreamSize imageStream)) [char (LIST (COND ((EQ.UseNS? imageStream) (EQ.MakeNSItem (EQIO.EqnType eqnObj))) (T (* ; "use press fonts") (FS.MakeItem '(Sigma 20) (SELECTQ (EQIO.EqnType eqnObj) (sum '"M") (product '"P") (union '"U") (intersection '"I") (SHOULDNT "eqn not a known sum group"] extraShift charBox indexBox limitBox valueBox indexRegion limitRegion valueRegion charRegion boxRegion box temp gap vGap) (SETQ gap size) (SETQ vGap (TIMES 2 size)) (* ;  "extraShift compensates for extra space around the NS chars") (SETQ extraShift (COND ((EQ.UseNS? imageStream) (TIMES 4 size)) (T 0))) (SETQ charBox (FS.Box char imageStream)) (SETQ indexBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) (SETQ limitBox (FS.Box (EQIO.EqnData eqnObj 2) imageStream)) (SETQ valueBox (FS.Box (EQIO.EqnData eqnObj 3) imageStream)) (SETQ temp (AB.PositionRegion charBox NIL 'bottom 'center indexBox 'center (DIFFERENCE gap extraShift) 0 size)) (SETQ indexRegion (CAR temp)) (SETQ temp (AB.PositionRegion charBox temp 'top 'center limitBox 'center (TIMES -2 gap) 0 size)) (* ;  "-2*gap used instead of gap since symbol doesn't fill its box") (SETQ limitRegion (CAR temp)) (SETQ temp (AB.PositionRegion charBox temp 'right 'display valueBox 'display vGap extraShift size)) (SETQ valueRegion (CAR temp)) (SETQ charRegion (AB.BoxToRegion charBox 0 0)) (SETQ boxRegion (UNIONREGIONS charRegion indexRegion limitRegion valueRegion)) (SETQ box (AB.RegionToBox boxRegion (PLUS (fetch YDESC of charBox) extraShift))) (COND (draw? (* ;  "note that original x, y position not preserved") (RELMOVETO (MINUS (fetch LEFT of boxRegion)) (MINUS extraShift) imageStream) (FS.Display char imageStream))) (RETURN (EQIO.MakeSpec box (LIST (EQIO.MakeDataSpec (AB.RelativePos indexRegion boxRegion (fetch YDESC of indexBox))) (EQIO.MakeDataSpec (AB.RelativePos limitRegion boxRegion (fetch YDESC of limitBox))) (EQIO.MakeDataSpec (AB.RelativePos valueRegion boxRegion (fetch YDESC of valueBox]) (EQ.Make.sum [LAMBDA (lowerIndex upperLimit summand fontSpec) (* thh%: " 9-Jan-86 10:16") (EQN.Make 'sum (LIST lowerIndex upperLimit summand) fontSpec]) (EQ.Make.product [LAMBDA (lowerIndex upperLimit factor fontSpec) (* thh%: " 9-Jan-86 10:17") (EQN.Make 'product (LIST lowerIndex upperLimit factor) fontSpec]) (EQ.Make.union [LAMBDA (lowerIndex upperLimit set fontSpec) (* thh%: " 9-Jan-86 10:18") (EQN.Make 'union (LIST lowerIndex upperLimit set) fontSpec]) (EQ.Make.intersection [LAMBDA (lowerIndex upperLimit set fontSpec) (* thh%: " 9-Jan-86 10:18") (EQN.Make 'intersection (LIST lowerIndex upperLimit set) fontSpec]) ) (* ;;; "integral group") (DEFINEQ (EQ.IntegralGroup [LAMBDA (eqnObj imageStream draw?) (* ; "Edited 18-Apr-88 13:32 by thh:") (* ;  "form function for forms drawn like an integral") (* ;; "form defined by gap -- distance between symbol and limits and vGap -- distance between symbol and value") (PROG ((size (EQ.StreamSize imageStream)) [char (LIST (COND ((EQ.UseNS? imageStream) (EQ.MakeNSItem (EQIO.EqnType eqnObj))) (T (* ; "use press fonts") (FS.MakeItem '(Sigma 20) (SELECTQ (EQIO.EqnType eqnObj) (integral '"S") (lineIntegral '"C") (SHOULDNT "eqn not a known integral group"] charBox lowerBox upperBox valueBox lowerRegion upperRegion valueRegion charRegion boxRegion box temp gap vGap) (SETQ gap size) (SETQ vGap (TIMES 5 size)) (SETQ charBox (FS.Box char imageStream)) (SETQ lowerBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) (SETQ upperBox (FS.Box (EQIO.EqnData eqnObj 2) imageStream)) (SETQ valueBox (FS.Box (EQIO.EqnData eqnObj 3) imageStream)) (SETQ temp (AB.Position2Regions charBox NIL 'right upperBox 'center lowerBox 'center (MINUS gap) (TIMES -6 gap) 0 0 size)) (* ;  "negative gaps since symbol doesn't fill its box") (SETQ upperRegion (CAR temp)) (SETQ lowerRegion (CADR temp)) (SETQ temp (AB.PositionRegion charBox temp 'right 'display valueBox 'display vGap 0 size)) (SETQ valueRegion (CAR temp)) (SETQ charRegion (AB.BoxToRegion charBox 0 0)) (SETQ boxRegion (UNIONREGIONS charRegion upperRegion lowerRegion valueRegion)) (SETQ box (AB.RegionToBox boxRegion (fetch YDESC of charBox))) (COND (draw? (* ;  "note that original x, y position not preserved") (RELMOVETO (MINUS (fetch LEFT of boxRegion)) 0 imageStream) (FS.Display char imageStream))) (RETURN (EQIO.MakeSpec box (LIST (EQIO.MakeDataSpec (AB.RelativePos lowerRegion boxRegion (fetch YDESC of lowerBox))) (EQIO.MakeDataSpec (AB.RelativePos upperRegion boxRegion (fetch YDESC of upperBox))) (EQIO.MakeDataSpec (AB.RelativePos valueRegion boxRegion (fetch YDESC of valueBox]) (EQ.Make.integral [LAMBDA (lowerLimit upperLimit integrand fontSpec) (* thh%: " 9-Jan-86 10:19") (EQN.Make 'integral (LIST lowerLimit upperLimit integrand) fontSpec]) (EQ.Make.lineIntegral [LAMBDA (lowerLimit upperLimit integrand fontSpec) (* thh%: " 9-Jan-86 10:20") (EQN.Make 'lineIntegral (LIST lowerLimit upperLimit integrand) fontSpec]) ) (* ;;; "super- and sub- scripts") (DEFINEQ (EQ.Script [LAMBDA (eqnObj imageStream draw?) (* THH "23-May-85 14:07") (* form function for forms with sub  and superscripts) (* form defined by gap -- horizontal distance between main symbol and  sub/superscripts, %, and shift -- vertical distance of centers of  sub/superscripts below/above corner of main symbol) (PROG ((size (EQ.StreamSize imageStream)) mainBox super1Box sub1Box super2Box sub2Box super1Region sub1Region super2Region sub2Region mainRegion boxRegion box temp gap shift) (SETQ gap size) (SETQ shift size) (SETQ mainBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) (SETQ sub1Box (FS.Box (EQIO.EqnData eqnObj 2) imageStream)) (SETQ super1Box (FS.Box (EQIO.EqnData eqnObj 3) imageStream)) (SETQ sub2Box (FS.Box (EQIO.EqnData eqnObj 4) imageStream)) (SETQ super2Box (FS.Box (EQIO.EqnData eqnObj 5) imageStream)) (SETQ temp (AB.Position2Regions mainBox NIL 'right super1Box 'center sub1Box 'center gap gap shift (MINUS shift) size)) (SETQ super1Region (CAR temp)) (SETQ sub1Region (CADR temp)) (SETQ temp (AB.Position2Regions mainBox (CADDR temp) 'left super2Box 'center sub2Box 'center gap gap shift (MINUS shift) size)) (SETQ super2Region (CAR temp)) (SETQ sub2Region (CADR temp)) (SETQ mainRegion (AB.BoxToRegion mainBox 0 0)) (SETQ boxRegion (UNIONREGIONS mainRegion super1Region sub1Region super2Region sub2Region)) (SETQ box (AB.RegionToBox boxRegion (fetch YDESC of mainBox))) (* * this form has nothing extra to draw) (RETURN (EQIO.MakeSpec box (LIST (EQIO.MakeDataSpec (AB.RelativePos mainRegion boxRegion (fetch YDESC of mainBox))) (EQIO.MakeDataSpec (AB.RelativePos sub1Region boxRegion (fetch YDESC of sub1Box))) (EQIO.MakeDataSpec (AB.RelativePos super1Region boxRegion (fetch YDESC of super1Box))) (EQIO.MakeDataSpec (AB.RelativePos sub2Region boxRegion (fetch YDESC of sub2Box))) (EQIO.MakeDataSpec (AB.RelativePos super2Region boxRegion (fetch YDESC of super2Box]) (EQ.Make.sub/superscripts [LAMBDA (mainValue lowerRight upperRight lowerLeft upperLeft fontSpec) (* thh%: " 9-Jan-86 10:21") (EQN.Make 'sub/superscripts (LIST mainValue lowerRight upperRight lowerLeft upperLeft) fontSpec]) ) (* ;;; "max/min/limit etc") (DEFINEQ (EQ.MaxMin [LAMBDA (eqnObj imageStream draw?) (* thh%: " 9-Jan-86 10:02") (* form function for max/min/limit etc) (PROG ((size (EQ.StreamSize imageStream)) functionBox indexBox valueBox box functionRegion indexRegion valueRegion boxRegion gap vGap temp) (SETQ gap (TIMES 2 size)) (SETQ vGap size) (SETQ functionBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) (SETQ indexBox (FS.Box (EQIO.EqnData eqnObj 2) imageStream)) (SETQ valueBox (FS.Box (EQIO.EqnData eqnObj 3) imageStream)) (SETQ temp (AB.PositionRegion functionBox NIL 'bottom 'center indexBox 'center vGap 0 size) ) (SETQ indexRegion (CAR temp)) (SETQ temp (AB.PositionRegion functionBox temp 'right 'display valueBox 'display gap 0 size )) (SETQ valueRegion (CAR temp)) (SETQ functionRegion (AB.BoxToRegion functionBox 0 0)) (SETQ boxRegion (UNIONREGIONS functionRegion indexRegion valueRegion)) (SETQ box (AB.RegionToBox boxRegion (fetch YDESC of functionBox))) (* * nothing extra to draw) (RETURN (EQIO.MakeSpec box (LIST (EQIO.MakeDataSpec (AB.RelativePos functionRegion boxRegion (fetch YDESC of functionBox))) (EQIO.MakeDataSpec (AB.RelativePos indexRegion boxRegion (fetch YDESC of indexBox))) (EQIO.MakeDataSpec (AB.RelativePos valueRegion boxRegion (fetch YDESC of valueBox]) (EQ.Make.max/min [LAMBDA (function index value fontSpec) (* thh%: " 9-Jan-86 10:21") (EQN.Make 'max/min (LIST function index value) fontSpec]) ) (* ;;; "utilities") (DEFINEQ (EQ.StreamSize [LAMBDA (imageStream) (* thh%: " 3-May-85 08:37") (* standard size factor for the stream) (MAX 1 (IQUOTIENT (STRINGWIDTH "A" (FONTCREATE DEFAULTFONT NIL NIL NIL imageStream)) 5]) (EQ.UseNS? [LAMBDA (imageStream) (* thh%: " 9-Jan-86 10:29") (* * returns non-NIL if NS characters should be used for special symbols on  imageStream) (SELECTQ (IMAGESTREAMTYPE imageStream) (DISPLAY EQ.UseNSChars) (PRESS NIL) (INTERPRESS T) EQ.UseNSChars]) (EQ.MakeNSItem [LAMBDA (type) (* ; "Edited 18-Apr-88 13:29 by thh:") (LET [(value (LISTGET EQ.NSChars (U-CASE type] (OR value (SHOULDNT "no display character for eqn")) (FS.MakeItem (CAR value) (MKSTRING (CHARACTER (CADR value]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EQ.UseNSChars EQ.NSChars) ) (* ; "EQ.UseNSChars = NIL to use press fonts for display") (RPAQ? EQ.UseNSChars NIL) (RPAQ? EQ.NSChars '(SUM ((CLASSIC 24) 9814) PRODUCT ((CLASSIC 24) 9811) SUM ((MODERN 30) 61306) PRODUCT ((MODERN 30) 61307) INTERSECTION ((MODERN 30) 61270) UNION ((MODERN 30) 61271) INTEGRAL ((MODERN 30) 61301) LINEINTEGRAL ((MODERN 30) 61302))) [EQIO.AddType 'fraction 'EQ.Fraction 2 '(pieceNames ("numerator" "denominator"] [EQIO.AddType 'sum 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "summand"] [EQIO.AddType 'product 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "factor"] [EQIO.AddType 'union 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "set"] [EQIO.AddType 'intersection 'EQ.SumGroup 3 '(initialData (-2 -2 0) pieceNames ("index" "limit" "set"] [EQIO.AddType 'integral 'EQ.IntegralGroup 3 '(initialData (-2 -2 0) pieceNames ("lower limit" "upper limit" "integrand"] (EQIO.AddType 'lineIntegral 'EQ.IntegralGroup 3 '(initialData (-2 -2 0) pieceNames ("lower limit" "upper limit" "integrand") menuLabel "line integral")) [EQIO.AddType 'sub/superscripts 'EQ.Script 5 '(initialData (0 -1 -1 -1 -1) pieceNames ("main value" "right subscript" "right superscript" "left subscript" "left superscript"] (EQIO.AddType 'max/min 'EQ.MaxMin 3 '(initialData (0 -2 0) pieceNames ("function" "index" "value") menuLabel "max min limit")) (* ;;; "EQROOT module: Part 5 of 5") (DEFINEQ (EQ.Root [LAMBDA (eqnObj imageStream draw?) (* thh%: "18-Mar-86 14:47") (* form function for roots) (* layout defined by vGap -- extra vertical space on either side of radicand,  gap -- extra horizontal space on either side of radicand, ivGap --  vertical space between index and radical sign, igap --  extra horizontal extent of sign around index) (PROG ((size (EQ.StreamSize imageStream)) rBox iBox gap vGap ivGap igap baseLen barLen height rise desc toBottomLen toTopLen width box) (SETQ gap (TIMES 2 size)) (SETQ vGap (TIMES 2 size)) (SETQ ivGap size) (SETQ igap 0) (SETQ width size) (SETQ rBox (FS.Box (EQIO.EqnData eqnObj 1) imageStream)) (SETQ iBox (FS.Box (EQIO.EqnData eqnObj 2) imageStream)) (* * determine size of parts of radical sign and draw it if requested) [SETQ baseLen (MAX (TIMES 4 size) (PLUS (TIMES 2 igap) (fetch XSIZE of iBox] (SETQ barLen (PLUS (TIMES 2 gap) (fetch XSIZE of rBox))) (SETQ height (PLUS (TIMES 2 vGap) (fetch YSIZE of rBox) (QUOTIENT width 2))) (SETQ rise (QUOTIENT height 2)) (SETQ desc (PLUS (fetch YDESC of rBox) vGap)) (SETQ toBottomLen (TIMES 2 size)) (SETQ toTopLen (TIMES 4 toBottomLen)) (COND (draw? (EQ.DrawRadicalSign height rise desc baseLen toBottomLen toTopLen barLen width imageStream))) (* * get size and position values) (SETQ box (create IMAGEBOX XSIZE _ (PLUS baseLen toBottomLen toTopLen barLen) YSIZE _ (MAX (PLUS height (DIFFERENCE width (QUOTIENT width 2))) (PLUS rise ivGap (fetch YSIZE of iBox))) YDESC _ desc XKERN _ 0)) (RETURN (EQIO.MakeSpec box (LIST (EQIO.MakeDataSpec (create POSITION XCOORD _ (PLUS baseLen toBottomLen toTopLen gap) YCOORD _ desc)) (EQIO.MakeDataSpec (create POSITION XCOORD _ (QUOTIENT (DIFFERENCE baseLen (fetch XSIZE of iBox)) 2) YCOORD _ (PLUS rise ivGap (fetch YDESC of iBox]) (EQ.Make.root [LAMBDA (radicand index fontSpec) (* thh%: " 9-Jan-86 10:22") (EQN.Make 'root (LIST radicand index) fontSpec]) ) (DEFINEQ (EQ.DrawRadicalSign [LAMBDA (height rise desc baseLen toBottomLen toTopLen barLen width imageStream) (* thh%: "28-Jun-85 13:04") (* draws specified radical sign on  imageStream) (RELMOVETO 0 (DIFFERENCE rise desc) imageStream) (RELDRAWTO baseLen 0 width NIL imageStream) (RELDRAWTO toBottomLen (MINUS rise) (TIMES 2 width) NIL imageStream) (RELDRAWTO toTopLen height width NIL imageStream) (RELDRAWTO barLen 0 width NIL imageStream]) ) [EQIO.AddType 'root 'EQ.Root 2 '(pieceNames ("radicand" "index") initialData (0 -1] (PUTPROPS EQUATIONFORMS COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9792 26310 (AB.RealPosition 9802 . 10921) (AB.PointPos 10923 . 12559) (AB.SidePosition 12561 . 13668) (AB.PlaceRegion 13670 . 15155) (AB.AdjustToLL 15157 . 15865) (AB.OppositeSide 15867 . 16102) (AB.RegionToBox 16104 . 16670) (AB.BoxToRegion 16672 . 17348) (AB.RelativePos 17350 . 17905) ( AB.BiggerRegion 17907 . 18850) (AB.Check 18852 . 20854) (AB.PositionRegion 20856 . 21838) ( AB.Position2Regions 21840 . 26308)) (26398 27513 (EQ.Group 26408 . 27114) (EQ.GroupCreate 27116 . 27264) (EQ.Make.group 27266 . 27511)) (27957 28800 (EQ.AddEnclosure 27967 . 28611) ( EQ.GetEnclosureData 28613 . 28798)) (29325 34611 (EQ.enclosure 29335 . 30736) (EQ.EnclosureCreate 30738 . 31383) (EQ.EnclosureEdit 31385 . 32740) (EQ.EnclosureKind 32742 . 34017) (EQ.EnclosureSide 34019 . 34609)) (34655 41929 (EQ.angles 34665 . 35930) (EQ.bars 35932 . 36975) (EQ.braces 36977 . 38383) (EQ.brackets 38385 . 39593) (EQ.parentheses 39595 . 40918) (EQ.enclosureForm 40920 . 41770) ( EQ.enclosureWidth 41772 . 41927)) (41976 53697 (EQ.DrawAngles 41986 . 43783) (EQ.DrawBars 43785 . 45044) (EQ.DrawBraces 45046 . 49348) (EQ.DrawBrackets 49350 . 51309) (EQ.DrawParentheses 51311 . 53695 )) (53787 74449 (EQ.Matrix 53797 . 55143) (EQ.Make.matrix 55145 . 55707) (EQ.layout 55709 . 61973) ( EQ.MatrixAdd 61975 . 65003) (EQ.MatrixChanged 65005 . 65392) (EQ.MatrixCreate 65394 . 66306) ( EQ.MatrixDelete 66308 . 68147) (EQ.MatrixEdit 68149 . 71903) (EQ.MatrixGetMenu 71905 . 73433) ( EQ.MatrixSelect 73435 . 74447)) (75051 79348 (EQ.Fraction 75061 . 79151) (EQ.Make.fraction 79153 . 79346)) (79377 84351 (EQ.SumGroup 79387 . 83556) (EQ.Make.sum 83558 . 83749) (EQ.Make.product 83751 . 83949) (EQ.Make.union 83951 . 84142) (EQ.Make.intersection 84144 . 84349)) (84385 88224 ( EQ.IntegralGroup 84395 . 87804) (EQ.Make.integral 87806 . 88009) (EQ.Make.lineIntegral 88011 . 88222)) (88267 91812 (EQ.Script 88277 . 91496) (EQ.Make.sub/superscripts 91498 . 91810)) (91849 94162 ( EQ.MaxMin 91859 . 93968) (EQ.Make.max/min 93970 . 94160)) (94191 95245 (EQ.StreamSize 94201 . 94532) ( EQ.UseNS? 94534 . 94917) (EQ.MakeNSItem 94919 . 95243)) (98076 101949 (EQ.Root 98086 . 101767) ( EQ.Make.root 101769 . 101947)) (101950 102653 (EQ.DrawRadicalSign 101960 . 102651))))) STOP \ No newline at end of file diff --git a/lispusers/EQUATIONS b/lispusers/EQUATIONS new file mode 100644 index 00000000..5d96aeeb --- /dev/null +++ b/lispusers/EQUATIONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Mar-88 13:51:10" {ERINYES}LYRIC>EQUATIONS.;1 86057 changes to%: (FNS EQIO.Put EQIO.Get) previous date%: "27-May-87 11:20:49" |{IE:PARC:XEROX}LYRIC>LISPUSERS>EQUATIONS.;1|) (* " Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EQUATIONSCOMS) (RPAQQ EQUATIONSCOMS ( (* ;;; "EQUATION module: Part 1 of 3") (* ; "functions for image object") (FNS EQIO.CreateFns EQIO.Create EQIO.Imagebox EQIO.Display EQIO.ButtonEventIn EQIO.Copy EQIO.CopyList EQIO.Get EQIO.Put EQIO.WhenDeleted EQIO.SelectRegion EQIO.Selection EQIO.DefaultSelectFn EQIO.MakeSelectionMenu) (* ;;; "functions to handle individual equation props and data") (FNS EQIO.EqnType EQIO.EqnDataList EQIO.SetDataList EQIO.EqnData EQIO.EqnProperty EQIO.AllProps EQIO.Specify EQIO.GetInitialProps EQIO.NumPieces EQIO.NewStructure) (* ;;; "functions to handle equation specification info") (FNS EQIO.AddType EQIO.GetInfo EQIO.SetInfo EQIO.TypeProp EQIO.ResetTypeProps EQIO.IsDefined EQIO.GetBox EQIO.GetDataSpec EQIO.GetDataSpecList EQIO.GetDataPosition EQIO.GetDataSelectRegion EQIO.MakeSpec EQIO.MakeDataSpec) (* ;;; "variable specification") (GLOBALVARS EquationInfo EquationTypeMenu EquationImageFns UnknownEquationData EquationDefaultSelectFn) (VARS (EquationImageFns NIL)) (INITVARS EquationInfo (EquationDefaultSelectFn 'EQIO.DefaultSelectFn)) [P (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Equation 'EQN.Equation] (P (* ;  "needed to force the getfn to be recognized before any new eqns defined") (SETQ EquationImageFns (EQIO.CreateFns))) (VARS UnknownEquationData) (PROP ARGNAMES EQIO.TypeProp EQIO.NumPieces EQIO.AllProps EQIO.EqnProperty) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA EQN.ObjEditWindow EQN.ContinueFlg EQN.PieceNumber EQN.ResultObj EQN.ResultWindow EQN.EditWindow EQIO.TypeProp EQIO.NumPieces EQIO.AllProps EQIO.EqnProperty))) (* ;;; "EQUATIONEDIT module: Part 2 of 3") (* ; "functions to edit data pieces") (FNS EQN.AbortEdit EQN.StopEdit EQN.ContinueEdit EQN.FinishEdit EQN.MakeEditWindow EQN.SetUpEdit EQN.StartEdit EQN.StartNextEdit EQN.UpdateEdit EQN.DefaultData EQN.TypeMenu) (* ;;; "hooks to control behavior of equation subeditor") (FNS EQN.Equation EQN.NextPiece EQN.FinishEqn EQN.NoUpdateAbort EQN.PreventUpdate EQN.CharFn EQN.TEditSpecialChar EQN.SnuggleWindows EQN.SnuggleMainWindow) (* ;;; "functions to handle equation fonts") (FNS EQN.EquationFontNumber EQN.EquationFont EQN.GetEqnFont EQN.MakeFS) (* ;;; "utilities") (FNS EQN.AdjustWindow EQN.CheckWindowSize) (FNS EQN.SubEditorP EQN.WindowFromText EQN.EditWindow EQN.ResultWindow EQN.ResultObj EQN.PieceNumber EQN.ContinueFlg EQN.ValidEditWindow EQN.ObjEditWindow) (FNS EQN.Make) (GLOBALVARS EquationFontSpecs) (VARS EquationFontSpecs) (PROP ARGNAMES EQN.ObjEditWindow EQN.ContinueFlg EQN.PieceNumber EQN.ResultObj EQN.ResultWindow EQN.EditWindow) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA EQN.ObjEditWindow EQN.ContinueFlg EQN.PieceNumber EQN.ResultObj EQN.ResultWindow EQN.EditWindow))) (* ;;; "FORMATSTRING module: Part 3 of 3") (FNS FS.Box FS.Copy FS.Display FS.Get FS.Put FS.ItemFont FS.ItemValue FS.ItemShift FS.MakeItem FS.Extract FS.ExtractFont FS.ExtractShift FS.Insert FS.AllowedChar FS.RealStringP) (* ;;; "Now load EQUATIONFORMS") (FILES EQUATIONFORMS))) (* ;;; "EQUATION module: Part 1 of 3") (* ; "functions for image object") (DEFINEQ (EQIO.CreateFns [LAMBDA NIL (* thh%: " 5-Dec-85 10:50") (IMAGEFNSCREATE (FUNCTION EQIO.Display) (FUNCTION EQIO.Imagebox) (FUNCTION EQIO.Put) (FUNCTION EQIO.Get) (FUNCTION EQIO.Copy) (FUNCTION EQIO.ButtonEventIn) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION EQIO.WhenDeleted) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) (EQIO.Create [LAMBDA (kind dataList fontSpec objectProps) (* thh%: " 5-Dec-85 10:50") (* makes an equation image object of specified kind and data) (* fontSpec, if non-NIL, is used as fontSpec prop of eqn) (* objectProps specifies properties for this object --  if NIL then default props for this kind will be used) (PROG [(obj (IMAGEOBJCREATE (CONS kind dataList) (COND ((AND (BOUNDP 'EquationImageFns) (IMAGEFNSP EquationImageFns)) EquationImageFns) (T (SETQ EquationImageFns (EQIO.CreateFns] [COND ((NOT objectProps) (SETQ objectProps (COPYALL (EQIO.GetInfo kind 'objProps] (EQIO.AllProps obj objectProps) [COND (fontSpec (EQIO.EqnProperty obj 'fontSpec (COND ((NUMBERP fontSpec) (EQN.GetEqnFont fontSpec)) (T fontSpec] (RETURN obj]) (EQIO.Imagebox [LAMBDA (eqnObj imageStream) (* THH "21-May-85 12:13") (* determines size of equation) (PROG ((spec (EQIO.Specify eqnObj imageStream))) (RETURN (COND (spec (EQIO.GetBox spec)) (T (FS.Box UnknownEquationData imageStream]) (EQIO.Display [LAMBDA (eqnObj imageStream) (* thh%: "31-May-85 09:30") (* displays equation) (PROG [(curX (DSPXPOSITION NIL imageStream)) (curY (DSPYPOSITION NIL imageStream)) (spec (EQIO.Specify eqnObj imageStream T)) (invertPiece (PROG ((editWindow (EQN.ObjEditWindow eqnObj))) (RETURN (COND (editWindow (EQN.PieceNumber editWindow)) (T NIL] (COND [spec (for i from 1 to (EQIO.NumPieces eqnObj) bind data pos (desc _ (fetch YDESC of (EQIO.GetBox spec))) do (SETQ data (EQIO.EqnData eqnObj i)) (SETQ pos (EQIO.GetDataPosition (EQIO.GetDataSpec spec i))) (COND ((AND pos data) (MOVETO (PLUS curX (fetch XCOORD of pos)) (PLUS curY (fetch YCOORD of pos) (MINUS desc)) imageStream) (FS.Display data imageStream (EQ invertPiece i] (T (FS.Display UnknownEquationData imageStream invertPiece]) (EQIO.ButtonEventIn [LAMBDA (eqnObj windowStream selection relX relY window textStream button) (* thh%: "19-Mar-86 09:23") (* handles button press in equation) (PROG ((editWindow (EQN.EditWindow window)) [CHOICEMENU (CONSTANT (create MENU CENTERFLG _ T ITEMS _ '((Select 'SELECT "Select the image object") (Edit 'EDIT "Edit selected piece of the equation"] underEdit) [SETQ underEdit (AND editWindow (EQ eqnObj (EQN.ResultObj editWindow] (* non-NIL if eqnObj is currently  being edited) (RETURN (COND ((OR (KEYDOWNP 'RSHIFT) (KEYDOWNP 'LSHIFT) (KEYDOWNP 'CTRL)) (* note%: using COPYBUTTONEVENTIN fn instead of this test doesnt work since it  is never called) (COND (underEdit (* abort sub edit when obj specially selected in main window) (EQN.AbortEdit window) 'CHANGED) (T NIL))) (T (SPAWN.MOUSE) (OR (COND [(EQ button 'LEFT) (* check for direct selection of piece  within the equation) (AND (EQ (MENU CHOICEMENU) 'EDIT) (LET ((piece# (EQIO.Selection eqnObj windowStream relX relY))) (COND (piece# (EQN.StartEdit eqnObj window piece#) 'CHANGED) (T NIL] [(EQ button 'MIDDLE) (* use menu to allow selection of  piece to edit) (LET ((selectFn (EQIO.GetInfo (EQIO.EqnType eqnObj) 'specialSelectFn)) piece#) (COND ((NOT selectFn) (SETQ selectFn EquationDefaultSelectFn))) (COND ((AND selectFn (SETQ piece# (APPLY* selectFn eqnObj))) (EQN.StartEdit eqnObj window piece#) 'CHANGED) (T NIL] (T NIL)) (LET [(wholeEditFn (EQIO.GetInfo (EQIO.EqnType eqnObj) 'wholeEditFn] (* treat as top level selection and check for edits of global properties) (COND (underEdit (EQN.AbortEdit window))) (COND ((AND wholeEditFn (APPLY* wholeEditFn eqnObj window button)) 'CHANGED) (underEdit 'CHANGED) (T NIL]) (EQIO.Copy [LAMBDA (eqnObj) (* THH "12-Jul-85 10:40") (LET ((dataList (EQIO.EqnDataList eqnObj))) (EQIO.Create (COPY (EQIO.EqnType eqnObj)) (for data in dataList collect (FS.Copy data)) NIL (EQIO.CopyList (EQIO.AllProps eqnObj]) (EQIO.CopyList [LAMBDA (list) (* THH "12-Jul-85 10:44") (* copies list down to atoms or strings but sets anything else to NIL) (* datatype values set to NIL -- allows caching such data only) (COND ((OR (ATOM list) (STRINGP list)) list) ((LISTP list) (for item in list collect (EQIO.CopyList item))) (T (* set value to NIL) NIL]) (EQIO.Get [LAMBDA (fileStream) (* ; "Edited 3-Mar-88 13:45 by thh:") (* ;; "specify readtable for input") (LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))) (PROG ((kind (READ fileStream)) (dataList (FS.Get fileStream))) (RETURN (EQIO.Create kind dataList NIL (READ fileStream]) (EQIO.Put [LAMBDA (eqnObj fileStream) (* ; "Edited 3-Mar-88 13:43 by thh:") (* ;; "specify readtable for output and eliminate all non-atom/string props which PRIN2 won't handle correctly") (LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))) (PRIN2 (EQIO.EqnType eqnObj) fileStream) (FS.Put (EQIO.EqnDataList eqnObj) fileStream) (PRIN2 (EQIO.CopyList (EQIO.AllProps eqnObj)) fileStream]) (EQIO.WhenDeleted [LAMBDA (eqnObj window) (* thh%: "15-May-85 11:27") (* called when eqnObj is about to be deleted from edit window) (* abort any sub edit of this object) (PROG ((editWindow (EQN.ValidEditWindow (EQN.EditWindow window) eqnObj))) (COND (editWindow (EQN.AbortEdit window]) (EQIO.SelectRegion [LAMBDA (spec data piece# imageStream) (* THH "21-May-85 12:13") (* determines selection region for  piece in eqnObj) (PROG ((dataSpec (EQIO.GetDataSpec spec piece#))) (RETURN (COND ((EQIO.GetDataSelectRegion dataSpec)) [data (PROG ((dataBox (FS.Box data imageStream)) (pos (EQIO.GetDataPosition dataSpec))) (RETURN (create REGION LEFT _ (fetch XCOORD of pos) BOTTOM _ (DIFFERENCE (fetch YCOORD of pos) (fetch YDESC of dataBox)) WIDTH _ (fetch XSIZE of dataBox) HEIGHT _ (fetch YSIZE of dataBox] (T NIL]) (EQIO.Selection [LAMBDA (eqnObj imageStream relX relY) (* thh%: "31-May-85 09:31") (* returns piece number of data within which selection was made, if any) (* note%: if slection region for a piece is zero size, then cannot select that  piece) (* new TEdit%: relY is measured from baseline of object so must adjust since  eqn forms measure regions w.r.t. l.l. corner of box) (PROG ((spec (EQIO.Specify eqnObj imageStream)) piece#) (RETURN (COND [spec (add relY (fetch YDESC of (EQIO.GetBox spec))) (SETQ piece# (for i from 1 to (EQIO.NumPieces eqnObj) bind region do (SETQ region (EQIO.SelectRegion spec (EQIO.EqnData eqnObj i) i imageStream)) (COND ((AND region (INSIDEP region relX relY)) (RETURN i] (T (* unknown equation --  not able to select) NIL]) (EQIO.DefaultSelectFn [LAMBDA (eqnObj) (* thh%: "31-May-85 08:34") (* provides a menu-based selection of a part of the equation --  returns the piece# of the part selected or NIL if no part was selected) (* this is useful for selecting parts whose select region on the screen is zero  size) (PROG ((type (EQIO.EqnType eqnObj)) menu) [COND [(EQIO.GetInfo type 'variable?) (SETQ menu (EQIO.EqnProperty eqnObj 'selectionMenu)) (COND ((NOT (type? MENU menu)) (SETQ menu (EQIO.MakeSelectionMenu type (EQIO.NumPieces eqnObj))) (EQIO.EqnProperty eqnObj 'selectionMenu menu] (T (SETQ menu (EQIO.TypeProp type 'selectionMenu)) (COND ((NOT (type? MENU menu)) (SETQ menu (EQIO.MakeSelectionMenu type (EQIO.NumPieces eqnObj))) (EQIO.TypeProp type 'selectionMenu menu] (RETURN (COND (menu (MENU menu)) (T NIL]) (EQIO.MakeSelectionMenu [LAMBDA (type numPieces) (* thh%: "19-Mar-86 09:30") (* creates a selection menu for the specified type of equation) (* numPieces may be NIL if this is an unknown type of equation) (COND [(AND (FIXP numPieces) (IGREATERP numPieces 0)) (PROG [(pieceNames (EQIO.GetInfo type 'pieceNames] (RETURN (create MENU CENTERFLG _ T TITLE _ "Eqn piece?" ITEMS _ (for i from 1 to numPieces bind name collect (SETQ name (CAR pieceNames)) (COND (name (SETQ pieceNames (CDR pieceNames)) (LIST name i)) (T i] (T NIL]) ) (* ;;; "functions to handle individual equation props and data") (DEFINEQ (EQIO.EqnType [LAMBDA (eqnObj) (* THH " 2-May-85 12:59") (* returns type of equation) (CAR (IMAGEOBJPROP eqnObj 'OBJECTDATUM]) (EQIO.EqnDataList [LAMBDA (eqnObj) (* THH " 2-May-85 12:59") (* returns list of data pieces in the  equation) (CDR (IMAGEOBJPROP eqnObj 'OBJECTDATUM]) (EQIO.SetDataList [LAMBDA (eqnObj newDataList) (* thh%: " 3-Jun-85 08:34") (* replaces entire data list of eqn -- caller must make sure any props, e.g.  numPieces, are suitably adjusted) (IMAGEOBJPROP eqnObj 'OBJECTDATUM (CONS (EQIO.EqnType eqnObj) newDataList]) (EQIO.EqnData [LAMBDA (eqnObj piece#) (* THH " 2-May-85 13:52") (CAR (NTH (EQIO.EqnDataList eqnObj) piece#]) (EQIO.EqnProperty [LAMBDA eqn (* THH " 8-May-85 08:48") (* gets and sets individual eqn props) (* eqn is of form (eqnObj prop  {newValue})) (COND ((IEQP eqn 2) (LISTGET (IMAGEOBJPROP (ARG eqn 1) 'props) (ARG eqn 2))) ((IEQP eqn 3) (PROG [(props (IMAGEOBJPROP (ARG eqn 1) 'props] [COND (props (LISTPUT props (ARG eqn 2) (ARG eqn 3))) (T (SETQ props (LIST (ARG eqn 2) (ARG eqn 3] (IMAGEOBJPROP (ARG eqn 1) 'props props]) (EQIO.AllProps [LAMBDA eqn (* THH " 8-May-85 08:48") (* gets and sets all props for eqnObj) (* eqn is of form (eqnObj {newProps})) (COND ((IEQP eqn 1) (IMAGEOBJPROP (ARG eqn 1) 'props)) ((IEQP eqn 2) (IMAGEOBJPROP (ARG eqn 1) 'props (ARG eqn 2]) (EQIO.Specify [LAMBDA (eqnObj imageStream draw?) (* THH " 2-May-85 13:45") (* returns specification for equation on imageStream, and if draw? is not NIL,  draws the non-data parts of the equation) (PROG [(formFn (EQIO.GetInfo (EQIO.EqnType eqnObj) 'formFn] (RETURN (COND (formFn (APPLY* formFn eqnObj imageStream draw?)) (T NIL]) (EQIO.GetInitialProps [LAMBDA (type) (* thh%: "31-May-85 09:02") (* gets initial prop list to use when new equation of specified type is created) (PROG ([props (COPY (EQIO.GetInfo type 'objectProps] (initialPropFn (EQIO.GetInfo type 'initialPropFn)) newProps) [COND ((AND initialPropFn (SETQ newProps (APPLY* initialPropFn type))) (COND [props (repeatwhile newProps do (LISTPUT props (CAR newProps) (CADR newProps)) (SETQ newProps (CDDR newProps] (T (SETQ props newProps] (COND ([AND props (LISTGET props 'numPieces) (NOT (EQIO.GetInfo type 'variable?] (* this equation does not allow a variable number of pieces) (ERROR "EQIO.GetInitialProps: can't specify numPieces for fixed size eqn type = " type) )) (RETURN props]) (EQIO.NumPieces [LAMBDA eqn (* thh%: "31-Jul-85 08:49") (* gets or sets current number of parts for eqn --  args are (eqnObj {newValue})) (COND ((IGREATERP eqn 0) (PROG ((eqnObj (ARG eqn 1)) type value) (SETQ type (EQIO.EqnType eqnObj)) (RETURN (COND [(IEQP eqn 1) (COND ([AND (EQIO.GetInfo type 'variable?) (FIXP (SETQ value (EQIO.EqnProperty eqnObj 'numPieces] value) (T (* not variable or different number of  parts not specified) (EQIO.GetInfo type 'numPieces] ((EQIO.GetInfo type 'variable?) (EQIO.EqnProperty eqnObj 'numPieces (ARG eqn 2)) (EQIO.NewStructure eqnObj)) (T (ERROR "EQIO.NumPieces: equation has fixed # of parts, type = " type]) (EQIO.NewStructure [LAMBDA (eqnObj) (* thh%: " 3-Jun-85 09:21") (* called when eqn structure is changed --  e.g. different number of parts -- to reset any saved menus, etc.) (EQIO.EqnProperty eqnObj 'selectionMenu NIL) (PROG [(changeFn (EQIO.GetInfo (EQIO.EqnType eqnObj) 'changeFn] (COND (changeFn (APPLY* changeFn eqnObj]) ) (* ;;; "functions to handle equation specification info") (DEFINEQ (EQIO.AddType [LAMBDA (type formFn numPieces PROPS) (* THH " 1-Jul-85 08:37") (* creates info for new equation type) [PROG ((newValue (APPEND (LIST 'formFn formFn 'numPieces numPieces) PROPS))) (PUTPROP type 'equationInfo newValue) (COND ((NOT (MEMB type EquationInfo)) (push EquationInfo type] (EQIO.ResetTypeProps type]) (EQIO.GetInfo [LAMBDA (type info) (* thh%: "28-Jun-85 15:17") (* returns specified info for equation  type) (LISTGET (GETPROP type 'equationInfo) info]) (EQIO.SetInfo [LAMBDA (type info newValue) (* thh%: "28-Jun-85 15:38") (* allows setting particular equation info items for previously defined  equation types) (COND ((EQIO.IsDefined type) (LET [(spec (GETPROP type 'equationInfo] (COND (spec (LISTPUT spec info newValue) (PUTPROP type 'equationInfo spec) (EQIO.ResetTypeProps type) newValue) (T (ERROR "EQIO.SetInfo: warning -- no specifications for eqn type = " type]) (EQIO.TypeProp [LAMBDA type (* thh%: "31-May-85 09:11") (* associates properties with equation types --  e.g. can be used to store selection menus for equations with fixed number of  parts) (* args are (type prop {newValue})) (COND ((IEQP type 2) (LISTGET (GETPROP (ARG type 1) 'equationProps) (ARG type 2))) ((IEQP type 3) (PROG [(list (GETPROP (ARG type 1) 'equationProps] [COND (list (LISTPUT list (ARG type 2) (ARG type 3))) (T (SETQ list (LIST (ARG type 2) (ARG type 3] (PUTPROP (ARG type 1) 'equationProps list]) (EQIO.ResetTypeProps [LAMBDA (type) (* THH " 1-Jul-85 08:36") (* removes all props associated with this equation type --  called when type info redefined) (SETQ EquationTypeMenu NIL) (PUTPROP type 'equationProps NIL]) (EQIO.IsDefined [LAMBDA (type) (* thh%: "28-Jun-85 15:27") (* returns type if it is a currently defined equation type, else NIL) (COND ((MEMB type EquationInfo) type) (T NIL]) (EQIO.GetBox [LAMBDA (specification) (* THH " 2-May-85 13:22") (* gets image box) (CAR specification]) (EQIO.GetDataSpec [LAMBDA (specification piece#) (* THH " 2-May-85 13:26") (* gets data spec for corresponding  piece) (CAR (NTH specification (ADD1 piece#]) (EQIO.GetDataSpecList [LAMBDA (specification) (* THH "12-Jul-85 10:22") (CDR specification]) (EQIO.GetDataPosition [LAMBDA (dataSpec) (* THH " 2-May-85 13:26") (CAR dataSpec]) (EQIO.GetDataSelectRegion [LAMBDA (dataSpec) (* THH " 2-May-85 13:26") (CDR dataSpec]) (EQIO.MakeSpec [LAMBDA (box dataSpecList) (* THH " 2-May-85 13:26") (* constructs specification) (CONS box dataSpecList]) (EQIO.MakeDataSpec [LAMBDA (position selectRegion) (* THH " 2-May-85 13:26") (CONS position selectRegion]) ) (* ;;; "variable specification") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EquationInfo EquationTypeMenu EquationImageFns UnknownEquationData EquationDefaultSelectFn) ) (RPAQQ EquationImageFns NIL) (RPAQ? EquationInfo NIL) (RPAQ? EquationDefaultSelectFn 'EQIO.DefaultSelectFn) [TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Equation 'EQN.Equation] (* ;  "needed to force the getfn to be recognized before any new eqns defined") (SETQ EquationImageFns (EQIO.CreateFns)) (RPAQQ UnknownEquationData (((Gacha 10) "[unknown equation]"))) (PUTPROPS EQIO.TypeProp ARGNAMES (NIL (type prop {newValue}) args)) (PUTPROPS EQIO.NumPieces ARGNAMES (NIL (eqnObj {newValue}) args)) (PUTPROPS EQIO.AllProps ARGNAMES (NIL (eqnObj {newValue}) args)) (PUTPROPS EQIO.EqnProperty ARGNAMES (NIL (eqnObj prop {newValue}) args)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA EQN.ObjEditWindow EQN.ContinueFlg EQN.PieceNumber EQN.ResultObj EQN.ResultWindow EQN.EditWindow EQIO.TypeProp EQIO.NumPieces EQIO.AllProps EQIO.EqnProperty) ) (* ;;; "EQUATIONEDIT module: Part 2 of 3") (* ; "functions to edit data pieces") (DEFINEQ (EQN.AbortEdit [LAMBDA (mainWindow) (* thh%: " 3-May-85 11:17") (* terminates any eqn edit without  allowing any continuation) (PROG ((editWindow (EQN.EditWindow mainWindow))) (COND ((WINDOWP editWindow) (EQN.ContinueFlg editWindow NIL) (EQN.StopEdit mainWindow]) (EQN.StopEdit [LAMBDA (mainWindow) (* thh%: " 3-May-85 10:31") (* terminates any eqn edit) (PROG ((editWindow (EQN.EditWindow mainWindow))) (COND ((WINDOWP editWindow) (EQN.FinishEdit editWindow) (TEDIT.QUIT (TEXTSTREAM editWindow)) (CLOSEW editWindow]) (EQN.ContinueEdit [LAMBDA (window) (* thh%: "28-Jun-85 14:14") (* called after sub edit quits to see if eqn edit should continue with next  piece) (* continueFlg is NIL to stop, T to continue incrementing by 1, FIXP to  increment by that amount once, (FIXP . end) to increment up/down to end  (end = NIL to contnue until no more)%, or a function to determine next piece  from current piece (NIL to end)) (* selection is pending delete for selections that continue beyond current  piece) [PROG [(process (WINDOWPROP (EQN.ResultWindow window) 'PROCESS] (* return TTY process to result window) (COND (process (TTY.PROCESS process] (PROG ((continueFlg (EQN.ContinueFlg window)) (newPiece# (EQN.PieceNumber window)) increment end) (COND ((COND ((EQ continueFlg T) (add newPiece# 1) T) ((NULL continueFlg) NIL) [(FIXP continueFlg) (* treat pieces as circular list) (LET [(oldPiece# newPiece#) (numPieces (EQIO.NumPieces (EQN.ResultObj window] (SETQ newPiece# (IMOD (PLUS oldPiece# continueFlg) numPieces)) (COND ((ZEROP newPiece#) (SETQ newPiece# numPieces))) (SETQ continueFlg NIL) (* this is a one-shot continuation so continueFlg for new edit to NIL) (NOT (IEQP newPiece# oldPiece#] ((LISTP continueFlg) (COND [(AND (FIXP (SETQ increment (CAR continueFlg))) (NOT (ZEROP increment)) (OR (FIXP (SETQ end (CDR continueFlg))) (NULL end))) (add newPiece# increment) (COND ((NULL end) (* always continue) T) ((MINUSP increment) (IGEQ newPiece# end)) (T (ILEQ newPiece# end] (T (* bad format list --  don't continue) NIL))) ((LITATOM continueFlg) (SETQ newPiece# (APPLY* continueFlg newPiece#)) (* continue if the function returned a  valid piece number) (FIXP newPiece#)) (T (ERROR "EQN.ContinueEdit: Invalid value for continueFlg = " continueFlg) NIL)) (* continue with edit of newPiece#) (* * continuation of edit requested -- start new edit) (EQN.StartNextEdit (EQN.ResultObj window) (EQN.ResultWindow window) newPiece# continueFlg (COND (continueFlg 'PENDINGDEL) (T NIL]) (EQN.FinishEdit [LAMBDA (window) (* thh%: " 5-Dec-85 11:06") (* returns edited data to calling  TEdit) (PROG ((mainWindow (EQN.ResultWindow window))) (EQN.ObjEditWindow (EQN.ResultObj window) NIL) (EQN.AbortEdit window) (* abort any sub edits) (EQN.UpdateEdit mainWindow (WINDOWPROP window 'NOUPDATE)) (EQN.EditWindow mainWindow NIL)) (* return T to allow TEdit to quit without user confirmation) T]) (EQN.MakeEditWindow [LAMBDA (mainWindow XSIZE YSIZE) (* thh%: " 6-Dec-85 11:34") (* creates window for subeditor) (LET ((editWindow (CREATEW (CREATEREGION 0 0 (fetch (REGION WIDTH) of (WINDOWPROP mainWindow 'REGION)) (PLUS 10 (HEIGHTIFWINDOW (TIMES 2 YSIZE) T))) "Eqn edit" NIL T))) (ATTACHWINDOW editWindow mainWindow 'BOTTOM 'LEFT 'LOCALCLOSE) (* note%: edit window is justified -- later may automatically reshape it as new  text is entered) (WINDOWADDPROP editWindow 'CLOSEFN 'DETACHWINDOW) (* edit window will be detached when  closed) (* * allow main and edit windows to be independently reshaped) (WINDOWDELPROP editWindow 'PASSTOMAINCOMS 'SHAPEW) (WINDOWADDPROP editWindow 'REJECTMAINCOMS 'SHAPEW) (* * make windows snuggle after reshape) (WINDOWADDPROP editWindow 'RESHAPEFN 'EQN.SnuggleWindows) (WINDOWADDPROP mainWindow 'RESHAPEFN 'EQN.SnuggleWindows) editWindow]) (EQN.SetUpEdit [LAMBDA (editWindow mainWindow eqnObj continueFlg piece#) (* thh%: " 5-Dec-85 10:59") (* sets up props for sub edit) (EQN.ResultWindow editWindow mainWindow) (EQN.ResultObj editWindow eqnObj) (EQN.ContinueFlg editWindow continueFlg) (EQN.PieceNumber editWindow piece#) [WINDOWPROP editWindow 'TEDIT.MENU.COMMANDS '(Find Looks Substitute Character% Looks (Equation 'EQN.Equation) (Exit 'Quit "exit from equation editor" (SUBITEMS (Next% Piece 'EQN.NextPiece) (Finish% Eqn 'EQN.FinishEqn) (Abort 'EQN.NoUpdateAbort "Terminates eqn editor without changing eqn." ] (EQN.ObjEditWindow eqnObj editWindow]) (EQN.StartEdit [LAMBDA (eqnObj mainWindow piece# continueFlg initialSEL) (* thh%: " 6-Dec-85 11:21") (* Starts edit of specified piece of eqnObj which is currently in TEdit  mainWindow. Starts new edit only if piece exists.) (* continueFlg determines action on  normal exit) (* initialSEL is initial selection or  char number) (EQN.AbortEdit mainWindow) (* abort any previous eqn edit) (COND ((AND (IGREATERP piece# 0) (ILEQ piece# (EQIO.NumPieces eqnObj))) (PROG ((data (EQIO.EqnData eqnObj piece#)) editWindow editStream box len) (SETQ box (FS.Box data (DECODE/WINDOW/OR/DISPLAYSTREAM mainWindow))) (SETQ editWindow (EQN.MakeEditWindow mainWindow (fetch XSIZE of box) (fetch YSIZE of box))) [TEDIT NIL editWindow NIL (APPEND '(QUITFN EQN.FinishEdit AFTERQUITFN EQN.ContinueEdit CHARFN EQN.CharFn) (LIST 'PROMPTWINDOW (OR (TEXTPROP (TEXTSTREAM mainWindow) 'PROMPTWINDOW) (GETPROMPTWINDOW mainWindow] (* sub edit uses same prompt window as  main editor) (EQN.SetUpEdit editWindow mainWindow eqnObj continueFlg piece#) (SETQ editStream (TEXTSTREAM editWindow)) (SETQ len (FS.Insert data editStream)) (COND ((EQ initialSEL 'PENDINGDEL) (TEDIT.SETSEL editStream 1 len 'RIGHT T)) ((FIXP initialSEL) (TEDIT.SETSEL editStream initialSEL 0 'RIGHT)) ((type? SELECTION initialSEL) (TEDIT.SETSEL editStream initialSEL))) (EQN.EditWindow mainWindow editWindow) [COND ((NOT (EQN.SubEditorP mainWindow)) (* this is a main edit window -- make sure sub edits are aborted when main edit  is done (don't call EQN.FinishEdit since want QUITFN to return NIL to allow  user to confirm quit at top level)) (TEXTPROP (TEXTSTREAM mainWindow) 'QUITFN 'EQN.AbortEdit] (* old TEdit version%:  (WINDOWPROP mainWindow  (QUOTE TEDIT.QUITFN)  (QUOTE EQN.FinishEdit))) ]) (EQN.StartNextEdit [LAMBDA (eqnObj mainWindow newPiece# continueFlg initialSEL) (* thh%: "29-May-85 10:10") (* if another piece of eqnObj exists, starts an edit of it) (EQN.StartEdit eqnObj mainWindow newPiece# continueFlg initialSEL) (* mark obj as changed to allow display indication of new piece being edited) (TEDIT.OBJECT.CHANGED (TEXTSTREAM mainWindow) eqnObj]) (EQN.UpdateEdit [LAMBDA (mainWindow noChangeFLG) (* thh%: " 6-Dec-85 09:52") (* updates sub edit in mainWindow) (* noChangeFLG non-NIL means main eqn not changed, but still must notify TEdit  obj is changed to update display, e.g. uninvert edited piece) (PROG ((editWindow (EQN.EditWindow mainWindow)) value datum eqnObj piece# ptr) (COND ((WINDOWP editWindow) (SETQ eqnObj (EQN.ResultObj editWindow)) [COND ((NOT noChangeFLG) (EQN.UpdateEdit editWindow) (* get updates of any sub edits) (SETQ piece# (EQN.PieceNumber editWindow)) (SETQ value (FS.Extract (TEXTSTREAM editWindow))) (SETQ datum (EQIO.EqnDataList eqnObj)) (SETQ ptr (NTH datum piece#)) (COND (ptr (RPLACA ptr value)) (T (* put value on end of datum) (EQIO.SetDataList eqnObj (NCONC1 datum value] (EQN.CheckWindowSize mainWindow eqnObj) (TEDIT.OBJECT.CHANGED (TEXTSTREAM mainWindow) eqnObj]) (EQN.DefaultData [LAMBDA (type fontSpec numPieces dataList) (* thh%: " 6-Dec-85 09:44") (* gets list of default data items to use for equation specified type) (* currently just a single item --  blank) (* if dataList is specified its values are used as the default data --  either directly if the item is a format string or with default font for the  piece if it is a string) [COND ((NOT numPieces) (SETQ numPieces (EQIO.GetInfo type 'numPieces] (PROG [(initialData (EQIO.GetInfo type 'initialData] (RETURN (COND ((AND initialData (LITATOM initialData)) (APPLY* initialData fontSpec type numPieces dataList)) (T (COND ((NLISTP initialData) (SETQ initialData NIL))) (PROG ((fontNumber (EQN.EquationFontNumber fontSpec))) (RETURN (COND [numPieces (for i from 1 to numPieces bind initial item collect (SETQ initial (pop initialData)) (SETQ item (pop dataList)) (* each piece of the equation consists of a single-item format string  (unless specified otherwise by value in dataList)) (COND ((AND item (LISTP item)) item) ((IMAGEOBJP item) (LIST item)) (T (LIST (FS.MakeItem [EQN.EquationFont (PLUS fontNumber (COND ((FIXP initial ) initial) (T 0] (COND (item (MKSTRING item)) (T " "] (T NIL]) (EQN.TypeMenu [LAMBDA NIL (* THH " 1-Jul-85 08:42") (* returns menu of equation types) (COND ((AND (BOUNDP 'EquationTypeMenu) (type? MENU EquationTypeMenu)) EquationTypeMenu) (T (* compute menu from EquationInfo) (SETQ EquationTypeMenu (create MENU ITEMS _ (SORT (for item in EquationInfo bind label collect (SETQ label (EQIO.GetInfo item 'menuLabel)) (COND (label (LIST label (KWOTE item))) (T item))) T) TITLE _ "Equation Types"]) ) (* ;;; "hooks to control behavior of equation subeditor") (DEFINEQ (EQN.Equation [LAMBDA (textStream) (* thh%: "31-May-85 08:58") (* allows insertion of an equation at current selection in textStream) (PROG ((type (MENU (EQN.TypeMenu))) currentFont window eqnObj props) (COND (type (SETQ currentFont (FS.ExtractFont textStream)) (SETQ window (EQN.WindowFromText textStream)) (SETQ props (EQIO.GetInitialProps type)) (SETQ eqnObj (EQIO.Create type (EQN.DefaultData type currentFont (LISTGET props 'numPieces)) currentFont props)) (EQN.CheckWindowSize window eqnObj) (TEDIT.INSERT.OBJECT eqnObj textStream) (EQN.StartEdit eqnObj window 1 T 'PENDINGDEL) (* must mark obj changed to allow display to indicate obj is being edited) (* TEDIT.OBJECT.CHANGED can not be called directly from EQN.StartEdit because  that fcn is called by the button fcn) (TEDIT.OBJECT.CHANGED textStream eqnObj]) (EQN.NextPiece [LAMBDA (textStream) (* thh%: "29-May-85 10:11") (* aborts edit and continues with next  piece of eqn) (PROG ((editWindow (EQN.WindowFromText textStream)) mainWindow) (SETQ mainWindow (EQN.ResultWindow editWindow)) (COND ((WINDOWP mainWindow) (EQN.ContinueFlg editWindow (COND ((EQN.ContinueFlg editWindow)) (T 1))) (EQN.StopEdit mainWindow]) (EQN.FinishEqn [LAMBDA (textStream) (* thh%: " 3-May-85 11:53") (* aborts edit without any  continuation) (PROG ((editWindow (EQN.WindowFromText textStream)) mainWindow) (SETQ mainWindow (EQN.ResultWindow editWindow)) (COND ((WINDOWP mainWindow) (EQN.AbortEdit mainWindow]) (EQN.NoUpdateAbort [LAMBDA (textStream) (* thh%: " 5-Dec-85 11:21") (* aborts equation editor without  updating eqn in main window) (EQN.PreventUpdate (EQN.WindowFromText textStream)) (EQN.FinishEqn textStream]) (EQN.PreventUpdate [LAMBDA (window) (* thh%: " 5-Dec-85 11:21") (* prevents any update of this or any  subeditors) (COND ((WINDOWP window) (WINDOWPROP window 'NOUPDATE T) (EQN.PreventUpdate (EQN.EditWindow window]) (EQN.CharFn [LAMBDA (textObj charcode) (* thh%: "19-Aug-85 08:31") (* prevents control chars from being  inserted into the document) (* allows any char that can be used in a format string and a few special  editing chars%: backspace & delete) (* allows NEXT syntax char to exit  from editor) (LET ((syntax (EQN.TEditSpecialChar textObj charcode))) (COND ((EQ syntax 'NEXT) (* next syntax key pressed -- see if this should quit eqn editor) (COND ((TEDIT.FIND (TEXTSTREAM textObj) ">>*<<" NIL NIL T) (* special char -- let TEdit advance  to next slot) T) (T (* force exit) (EQN.FinishEdit (EQN.WindowFromText textObj)) (* TEDIT.QUIT does not automatically  call the QUITFN) (TEDIT.QUIT (TEXTSTREAM textObj)) NIL))) (syntax (* special character) T) ((FS.AllowedChar charcode) (* this character can be in format  strings) T) (T (* don't allow this char to be  inserted) (FLASHWINDOW (EQN.WindowFromText textObj)) NIL]) (EQN.TEditSpecialChar [LAMBDA (textObj charcode) (* thh%: "16-Aug-85 09:35") (* if charcode is a control character for edit specified by textObj returns its  syntax class, else NIL) (* this may not correspond exactly to the procedure TEdit uses to determine  syntax of a character -- need to also check terminal table??) (LET ((table (OR (READTABLEP (TEXTPROP textObj 'READTABLE)) TEDIT.READTABLE)) syntax) (SETQ syntax (TEDIT.GETSYNTAX charcode table)) (COND ((EQ syntax 'NONE) (SETQ syntax NIL))) syntax]) (EQN.SnuggleWindows [LAMBDA (window) (* thh%: " 6-Dec-85 12:07") (* reshape fn for independently  reshapeable attached windows) (* * move attached windows) (REPOSITIONATTACHEDWINDOWS window) (* Does not work correctly when window itself has attached windows ??) (* * move main window) (EQN.SnuggleMainWindow window]) (EQN.SnuggleMainWindow [LAMBDA (window) (* thh%: " 6-Dec-85 11:44") (* moves all windows in main window  chain) (LET ((mainW (MAINWINDOW window)) region) (COND ((AND (WINDOWP mainW) (NOT (EQ mainW window))) (SETQ region (WINDOWREGION window)) (* position main window above window) (* note that MOVEW must be rejected by window so that moving main window wont  also move attached window) [RESETLST (RESETSAVE (WINDOWADDPROP window 'REJECTMAINCOMS 'MOVEW) `(WINDOWDELPROP %, window REJECTMAINCOMS MOVEW)) (MOVEW mainW (fetch (REGION LEFT) of region) (PLUS (fetch (REGION BOTTOM) of region) (fetch (REGION HEIGHT) of region] (EQN.SnuggleMainWindow mainW]) ) (* ;;; "functions to handle equation fonts") (DEFINEQ (EQN.EquationFontNumber [LAMBDA (fontSpec) (* thh%: "31-Jul-85 08:48") (* returns number of the font to use for normal size parts of the equation) (* fontSpec can be a number which then corresponds to the size of the font) (COND ((NOT fontSpec) (SETQ fontSpec DEFAULTFONT))) (PROG [(size (OR (NUMBERP fontSpec) (FONTPROP fontSpec 'SIZE] (RETURN (for i from 1 to (ARRAYSIZE EquationFontSpecs) smallest (ABS (DIFFERENCE (FONTPROP (ELT EquationFontSpecs i) 'SIZE) size]) (EQN.EquationFont [LAMBDA (n) (* thh%: " 5-Dec-85 11:26") (* returns equation font number n) (COPY (ELT EquationFontSpecs (MAX 1 (MIN (ARRAYSIZE EquationFontSpecs) n]) (EQN.GetEqnFont [LAMBDA (fontSpec) (* thh%: "31-Jul-85 08:52") (EQN.EquationFont (EQN.EquationFontNumber fontSpec]) (EQN.MakeFS [LAMBDA (item fontSpec) (* thh%: "31-Jul-85 08:58") (* constructs a single element format  string) (COND ((IMAGEOBJP item) (LIST item)) ((LISTP item) item) (T (LIST (FS.MakeItem fontSpec (MKSTRING item]) ) (* ;;; "utilities") (DEFINEQ (EQN.AdjustWindow [LAMBDA (editWindow dWidth dHeight) (* thh%: " 6-Dec-85 12:09") (* reshapes subeditor window to have  extra width and height) (PROG ((region (WINDOWPROP editWindow 'REGION)) (attachedWindows (ATTACHEDWINDOWS editWindow)) newHeight howAttached) (SETQ newHeight (MAX (HEIGHTIFWINDOW 10 T) (PLUS (fetch HEIGHT of region) dHeight))) (* want to shape this window only, not any attached windows --  depends on correctly setting props when edit windows created) (* SETQ howAttached (for window in  attachedWindows collect  (DETACHWINDOW window))) (SHAPEW editWindow (create REGION LEFT _ (fetch LEFT of region) BOTTOM _ (DIFFERENCE (fetch BOTTOM of region) (DIFFERENCE newHeight (fetch HEIGHT of region))) WIDTH _ (MAX (WIDTHIFWINDOW 10) (PLUS (fetch WIDTH of region) dWidth)) HEIGHT _ newHeight)) (* reattach the windows -- note that LOCALCLOSE is assumed for all windows) (* for window in attachedWindows as how in howAttached do  (ATTACHWINDOW window editWindow (CAR how)  (CDR how) (QUOTE LOCALCLOSE))) ]) (EQN.CheckWindowSize [LAMBDA (window eqnObj) (* thh%: "29-May-85 08:52") (* makes sure window can contain new obj --  currently only checks based on height of new obj, assuming YDESC not too large) (COND ((EQN.SubEditorP window) (* only adjust for subeditors  (They contain a single line of text)) (PROG ((box (APPLY* (IMAGEOBJPROP eqnObj 'IMAGEBOXFN) eqnObj (DECODE/WINDOW/OR/DISPLAYSTREAM window))) (height (WINDOWPROP window 'HEIGHT)) extraHeight) (SETQ extraHeight (DIFFERENCE (MIN 400 (TIMES 2 (fetch YSIZE of box))) height)) (* for now require window to be twice as high as object so don't have to check  YDESC -- should work for most cases) (COND ((IGREATERP extraHeight 0) (EQN.AdjustWindow window 0 extraHeight]) ) (DEFINEQ (EQN.SubEditorP [LAMBDA (window) (* thh%: "28-May-85 09:27") (* non-NIL if window has a eqn subeditor running in it) (EQN.ResultWindow window]) (EQN.WindowFromText [LAMBDA (textObjORStream) (* thh%: "28-Jun-85 14:32") (* gets window corresponding to a text  object or stream) (* note%: \WINDOW field actually is a list whose only element is the window) (LET [(w (fetch \WINDOW of (TEXTOBJ textObjORStream] (OR (WINDOWP w) (WINDOWP (CAR w)) (ERROR "EQN.WindowFromText: unable to find window for textobj/stream = " textObjORStream ]) (EQN.EditWindow [LAMBDA window (* thh%: " 3-May-85 08:55") (* returns or sets window of any sub  edit) (COND [(IEQP window 1) (PROG [(w (WINDOWPROP (ARG window 1) 'EditWindow] (* test for valid window) (RETURN (COND ((WINDOWP w) (COND ((AND (OPENWP w) (EQ (EQN.ResultWindow w) (ARG window 1))) w) (T (WINDOWPROP (ARG window 1) 'EditWindow NIL) NIL))) (T NIL] ((IEQP window 2) (WINDOWPROP (ARG window 1) 'EditWindow (ARG window 2))) (T NIL]) (EQN.ResultWindow [LAMBDA editWindow (* THH " 2-May-85 16:20") (* returns or sets main window for a  sub edit) (COND ((IEQP editWindow 1) (WINDOWPROP (ARG editWindow 1) 'ResultWindow)) ((IEQP editWindow 2) (WINDOWPROP (ARG editWindow 1) 'ResultWindow (ARG editWindow 2))) (T NIL]) (EQN.ResultObj [LAMBDA editWindow (* THH " 2-May-85 16:25") (* returns or sets object being edited) (COND ((IEQP editWindow 1) (WINDOWPROP (ARG editWindow 1) 'ResultObj)) ((IEQP editWindow 2) (WINDOWPROP (ARG editWindow 1) 'ResultObj (ARG editWindow 2))) (T NIL]) (EQN.PieceNumber [LAMBDA editWindow (* THH " 2-May-85 16:37") (* returns or sets number of piece  being edited) (COND ((IEQP editWindow 1) (WINDOWPROP (ARG editWindow 1) 'PieceNumber)) ((IEQP editWindow 2) (WINDOWPROP (ARG editWindow 1) 'PieceNumber (ARG editWindow 2))) (T NIL]) (EQN.ContinueFlg [LAMBDA editWindow (* THH " 2-May-85 16:25") (* returns or sets continuation flag) (* THH " 2-May-85 13:35") (COND ((IEQP editWindow 1) (WINDOWPROP (ARG editWindow 1) 'ContinueFlg)) ((IEQP editWindow 2) (WINDOWPROP (ARG editWindow 1) 'ContinueFlg (ARG editWindow 2))) (T NIL]) (EQN.ValidEditWindow [LAMBDA (editWindow eqnObj) (* THH " 8-May-85 09:44") (* returns editWindow if it is a window currently being used to edit eqnObj,  else NIL) (COND ((AND (WINDOWP editWindow) (OPENWP editWindow) (EQ (EQN.ResultObj editWindow) eqnObj)) editWindow) (T NIL]) (EQN.ObjEditWindow [LAMBDA eqn (* THH " 8-May-85 10:01") (* gets or sets edit window for eqnObj) (* eqn is of the form  (eqnObj {newEditWindow})) (PROG (editWindow eqnObj) (COND ((AND (IGREATERP eqn 0) (SETQ eqnObj (ARG eqn 1)) (IMAGEOBJP eqnObj)) (RETURN (COND ((IEQP eqn 1) (SETQ editWindow (IMAGEOBJPROP eqnObj 'editWindow)) (COND ((EQN.ValidEditWindow editWindow eqnObj)) (editWindow (* remove invalid edit window prop) (IMAGEOBJPROP eqnObj 'editWindow NIL) NIL) (T NIL))) ((IEQP eqn 2) (SETQ editWindow (EQN.ValidEditWindow (ARG eqn 2) eqnObj)) (IMAGEOBJPROP eqnObj 'editWindow editWindow]) ) (DEFINEQ (EQN.Make [LAMBDA (type dataList fontSpec PROPS) (* thh%: " 9-Jan-86 10:12") (* creates equation of specified type with given dataList --  for variable piece eqns PROPS should include numPieces) (COND ((EQIO.IsDefined type) (LET [(numPieces (LISTGET PROPS 'numPieces] (EQIO.Create type (EQN.DefaultData type fontSpec (COND ((EQIO.GetInfo type 'variable?) numPieces) (numPieces (ERROR "Can't specify numPieces for type = " type)) (T NIL)) dataList) fontSpec PROPS))) (T (ERROR "Unknown equation type = " type]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EquationFontSpecs) ) (RPAQ EquationFontSpecs (READARRAY-FROM-LIST 3 (QUOTE POINTER) 1 (QUOTE ((TimesRoman 8) (TimesRoman 10 ) (TimesRoman 12) NIL)))) (PUTPROPS EQN.ObjEditWindow ARGNAMES (NIL (eqnObj {newEditWindow}) args)) (PUTPROPS EQN.ContinueFlg ARGNAMES (NIL (editWindow {continueFlg}) args)) (PUTPROPS EQN.PieceNumber ARGNAMES (NIL (editWindow {pieceNumber}) args)) (PUTPROPS EQN.ResultObj ARGNAMES (NIL (editWindow {resultObj}) args)) (PUTPROPS EQN.ResultWindow ARGNAMES (NIL (editWindow {resultWindow}) args)) (PUTPROPS EQN.EditWindow ARGNAMES (NIL (window {editWindow}) args)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA EQN.ObjEditWindow EQN.ContinueFlg EQN.PieceNumber EQN.ResultObj EQN.ResultWindow EQN.EditWindow) ) (* ;;; "FORMATSTRING module: Part 3 of 3") (DEFINEQ (FS.Box [LAMBDA (data imageStream) (* thh%: "27-May-87 10:02") (* determines box within which data will be displayed on imageStream --  data is a list whose elements are either image objs or lists of the form  (FontSpec String Shift)) (* added adjustment for shift -- assumes data still spans baseline) (for item in data bind (width _ 0) (ascent _ 0) (descent _ 0) (scale _ (DSPSCALE NIL imageStream)) do (PROG ((itemWidth 0) (itemAscent 0) (itemDescent 0) fullFont imageBox shift) [COND ((IMAGEOBJP item) (SETQ imageBox (APPLY* (IMAGEOBJPROP item 'IMAGEBOXFN) item imageStream)) (SETQ itemWidth (fetch XSIZE of imageBox)) (SETQ itemAscent (DIFFERENCE (fetch YSIZE of imageBox) (fetch YDESC of imageBox))) (SETQ itemDescent (fetch YDESC of imageBox))) ((FS.RealStringP item) (SETQ fullFont (FONTCREATE (FS.ItemFont item) NIL NIL NIL imageStream)) (SETQ shift (TIMES scale (FS.ItemShift item))) (SETQ itemWidth (STRINGWIDTH (FS.ItemValue item) fullFont)) [SETQ itemAscent (PLUS shift (FONTPROP fullFont 'ASCENT] (SETQ itemDescent (DIFFERENCE (FONTPROP fullFont 'DESCENT) shift] (add width itemWidth) (SETQ ascent (MAX ascent itemAscent)) (SETQ descent (MAX descent itemDescent))) finally (RETURN (create IMAGEBOX XSIZE _ width YSIZE _ (PLUS ascent descent) YDESC _ descent XKERN _ 0]) (FS.Copy [LAMBDA (data) (* THH "21-May-85 12:38") (* constructs a copy of data -- data is a list whose elements are either image  objs or lists of the form (FontSpec String)) (for item in data collect (COND ((IMAGEOBJP item) (* note%: COPYALL doesn't call imageobj copyfn so it can't be used here) (APPLY* (IMAGEOBJPROP item 'COPYFN) item)) (T (COPYALL item]) (FS.Display [LAMBDA (data imageStream invert?) (* thh%: "27-May-87 10:02") (* displays data on imageStream -- data is a list whose elements are either  image objs or lists of the form (FontSpec String Shift)) (* added shift) (PROG ((scale (DSPSCALE NIL imageStream)) xStart yStart) [COND (invert? (SETQ xStart (DSPXPOSITION NIL imageStream)) (SETQ yStart (DSPYPOSITION NIL imageStream] [for item in data do (COND ((IMAGEOBJP item) (PROG ((xPos (DSPXPOSITION NIL imageStream)) (yPos (DSPYPOSITION NIL imageStream))) (APPLY* (IMAGEOBJPROP item 'DISPLAYFN) item imageStream) (MOVETO (PLUS xPos (fetch XSIZE of (APPLY* (IMAGEOBJPROP item 'IMAGEBOXFN) item imageStream))) yPos imageStream))) ((FS.RealStringP item) (PROG [(oldFont (DSPFONT NIL imageStream)) (shift (TIMES scale (FS.ItemShift item] (DSPFONT (FS.ItemFont item) imageStream) (COND ((NOT (ZEROP shift)) (RELMOVETO 0 shift imageStream))) (PRIN1 (FS.ItemValue item) imageStream) (DSPFONT oldFont imageStream) (COND ((NOT (ZEROP shift)) (RELMOVETO 0 (MINUS shift) imageStream] (COND (invert? (PROG ((box (FS.Box data imageStream))) (DSPFILL (create REGION LEFT _ xStart BOTTOM _ (DIFFERENCE yStart (fetch YDESC of box)) WIDTH _ (fetch XSIZE of box) HEIGHT _ (fetch YSIZE of box)) BLACKSHADE 'INVERT imageStream]) (FS.Get [LAMBDA (fileStream) (* thh%: "13-Jun-85 09:17") (* reads data from fileStream -- data is a list whose elements are either image  objs or lists of the form (FontSpec String)) (* also reads a list of such data  items) (HREAD fileStream]) (FS.Put [LAMBDA (data fileStream) (* THH " 2-May-85 14:31") (* puts data on fileStream -- data is a list whose elements are either image  objs or lists of the form (FontSpec String)) (* also writes a list of such data  items) (HPRINT data fileStream]) (FS.ItemFont [LAMBDA (dataItem) (* thh%: "15-May-85 11:29") (* returns font spec of single data  item) (COND ((LISTP dataItem) (CAR dataItem)) (T NIL]) (FS.ItemValue [LAMBDA (dataItem) (* THH "21-May-85 12:28") (* returns string of single data item  or image object) (COND ((LISTP dataItem) (CADR dataItem)) ((IMAGEOBJP dataItem) dataItem]) (FS.ItemShift [LAMBDA (dataItem) (* thh%: "27-May-87 09:57") (* shift is number of points to move  up) (COND ((LISTP dataItem) (OR (CADDR dataItem) 0)) (T 0]) (FS.MakeItem [LAMBDA (fontSpec string shift) (* thh%: "27-May-87 09:48") (* makes data item from fontSpec and  string with shift) (COND ((AND shift (NOT (ZEROP shift))) (LIST fontSpec string shift)) (T (LIST fontSpec string]) (FS.Extract [LAMBDA (stream) (* thh%: "27-May-87 10:23") (* extracts data from TEdit stream) (SETFILEPTR stream 0) (* BIN gets imageObj or individual  characters) (PROG ((EOFptr (GETEOFPTR stream)) (CHcount 0) data result) [SETQ data (while (ILESSP CHcount EOFptr) collect (add CHcount 1) (CONS CHcount (BIN stream] (* data has (ch# . item)) (* now combine characters into strings  and get font information) [SETQ data (for item in data collect item unless (AND (NUMBERP (CDR item)) (NOT (FS.AllowedChar (CDR item] (* remove control characters, e.g.  CR, LF, tab...) [SETQ result (while data bind item fontSpec shift collect (SETQ item (CAR data)) (SETQ data (CDR data)) (* note that imageobjs are not copied so changes to returned obj will also  change original) (COND ((IMAGEOBJP (CDR item))) (T (SETQ fontSpec (FS.ExtractFont stream (CAR item))) (SETQ shift (FS.ExtractShift stream (CAR item))) (PROG ([string (MKSTRING (CHARACTER (CDR item] (nextItem (CAR data))) (while [AND nextItem (NOT (IMAGEOBJP (CDR nextItem))) (EQUAL fontSpec (FS.ExtractFont stream (CAR nextItem))) (EQUAL shift (FS.ExtractShift stream (CAR nextItem] do [SETQ string (CONCAT string (CHARACTER (CDR nextItem ] (SETQ data (CDR data)) (SETQ nextItem (CAR data))) (RETURN (FS.MakeItem fontSpec string shift] (RETURN (COND ((AND result (FS.RealStringP (CAR result))) (* first item is a string) result) (T (* preserve initial font by including a null string item at beginning of list) (* this item has zero shift) (CONS (FS.MakeItem (FS.ExtractFont stream (COND ((ZEROP EOFptr) NIL) (T 1))) "") result]) (FS.ExtractFont [LAMBDA (stream selOrCh#) (* thh%: "20-Feb-86 14:05") (* gets font spec for specified  selection) (PROG ((looks (TEDIT.GET.LOOKS stream selOrCh#))) (RETURN (LIST (LISTGET looks 'FAMILY) (LISTGET looks 'SIZE) (LIST (LISTGET looks 'WEIGHT) (LISTGET looks 'SLOPE) (LISTGET looks 'EXPANSION]) (FS.ExtractShift [LAMBDA (stream selOrCh#) (* thh%: "27-May-87 10:26") (* gets upward shift in points for  specified selection) (LET ((looks (TEDIT.GET.LOOKS stream selOrCh#)) shift) (COND ((SETQ shift (LISTGET looks 'SUPERSCRIPT)) shift) ((SETQ shift (LISTGET looks 'SUBSCRIPT)) (MINUS shift)) (T 0]) (FS.Insert [LAMBDA (data stream) (* thh%: "27-May-87 10:43") (* inserts data list into TEdit stream) (for item in data bind (length _ 0) shift do [COND ((IMAGEOBJP item) (add length 1) (TEDIT.INSERT.OBJECT item stream)) [(FS.RealStringP item) (add length (NCHARS (FS.ItemValue item))) (SETQ shift (FS.ItemShift item)) (COND [(ZEROP shift) (TEDIT.INSERT stream (FS.ItemValue item) NIL (FONTCREATE (FS.ItemFont item] [(MINUSP shift) (TEDIT.INSERT stream (FS.ItemValue item) NIL `(FONT ,(FS.ItemFont item) SUBSCRIPT ,(MINUS shift] (T (TEDIT.INSERT stream (FS.ItemValue item) NIL `(FONT ,(FS.ItemFont item) SUPERSCRIPT ,shift] (T (* null string -- preserve font info) (TEDIT.CARETLOOKS stream (FONTCREATE (FS.ItemFont item] finally (RETURN length]) (FS.AllowedChar [LAMBDA (charcode) (* thh%: "19-Aug-85 08:29") (* returns T if charcode can be included in format strings) (IGEQ charcode (CHARCODE " "]) (FS.RealStringP [LAMBDA (item nullOk) (* thh%: "31-Jul-85 08:11") (AND (LISTP item) (OR nullOk (NOT (EQUAL "" (FS.ItemValue item]) ) (* ;;; "Now load EQUATIONFORMS") (FILESLOAD EQUATIONFORMS) (PUTPROPS EQUATIONS COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4524 19553 (EQIO.CreateFns 4534 . 5067) (EQIO.Create 5069 . 6335) (EQIO.Imagebox 6337 . 6749) (EQIO.Display 6751 . 8362) (EQIO.ButtonEventIn 8364 . 12205) (EQIO.Copy 12207 . 12588) ( EQIO.CopyList 12590 . 13161) (EQIO.Get 13163 . 13571) (EQIO.Put 13573 . 14128) (EQIO.WhenDeleted 14130 . 14624) (EQIO.SelectRegion 14626 . 15773) (EQIO.Selection 15775 . 17279) (EQIO.DefaultSelectFn 17281 . 18519) (EQIO.MakeSelectionMenu 18521 . 19551)) (19627 25629 (EQIO.EqnType 19637 . 19888) ( EQIO.EqnDataList 19890 . 20230) (EQIO.SetDataList 20232 . 20629) (EQIO.EqnData 20631 . 20810) ( EQIO.EqnProperty 20812 . 21740) (EQIO.AllProps 21742 . 22257) (EQIO.Specify 22259 . 22756) ( EQIO.GetInitialProps 22758 . 23890) (EQIO.NumPieces 23892 . 25135) (EQIO.NewStructure 25137 . 25627)) (25696 30158 (EQIO.AddType 25706 . 26219) (EQIO.GetInfo 26221 . 26571) (EQIO.SetInfo 26573 . 27214) ( EQIO.TypeProp 27216 . 28162) (EQIO.ResetTypeProps 28164 . 28486) (EQIO.IsDefined 28488 . 28773) ( EQIO.GetBox 28775 . 28995) (EQIO.GetDataSpec 28997 . 29330) (EQIO.GetDataSpecList 29332 . 29477) ( EQIO.GetDataPosition 29479 . 29619) (EQIO.GetDataSelectRegion 29621 . 29765) (EQIO.MakeSpec 29767 . 30003) (EQIO.MakeDataSpec 30005 . 30156)) (31711 48815 (EQN.AbortEdit 31721 . 32233) (EQN.StopEdit 32235 . 32682) (EQN.ContinueEdit 32684 . 36336) (EQN.FinishEdit 36338 . 37071) (EQN.MakeEditWindow 37073 . 38492) (EQN.SetUpEdit 38494 . 39671) (EQN.StartEdit 39673 . 42974) (EQN.StartNextEdit 42976 . 43493) (EQN.UpdateEdit 43495 . 44892) (EQN.DefaultData 44894 . 47579) (EQN.TypeMenu 47581 . 48813)) ( 48882 56790 (EQN.Equation 48892 . 50151) (EQN.NextPiece 50153 . 50878) (EQN.FinishEqn 50880 . 51409) ( EQN.NoUpdateAbort 51411 . 51824) (EQN.PreventUpdate 51826 . 52261) (EQN.CharFn 52263 . 54348) ( EQN.TEditSpecialChar 54350 . 55069) (EQN.SnuggleWindows 55071 . 55662) (EQN.SnuggleMainWindow 55664 . 56788)) (56844 58583 (EQN.EquationFontNumber 56854 . 57613) (EQN.EquationFont 57615 . 57957) ( EQN.GetEqnFont 57959 . 58140) (EQN.MakeFS 58142 . 58581)) (58612 61753 (EQN.AdjustWindow 58622 . 60582 ) (EQN.CheckWindowSize 60584 . 61751)) (61754 67638 (EQN.SubEditorP 61764 . 61997) (EQN.WindowFromText 61999 . 62656) (EQN.EditWindow 62658 . 63736) (EQN.ResultWindow 63738 . 64288) (EQN.ResultObj 64290 . 64758) (EQN.PieceNumber 64760 . 65309) (EQN.ContinueFlg 65311 . 65874) (EQN.ValidEditWindow 65876 . 66310) (EQN.ObjEditWindow 66312 . 67636)) (67639 68756 (EQN.Make 67649 . 68754)) (69964 85899 ( FS.Box 69974 . 72220) (FS.Copy 72222 . 72862) (FS.Display 72864 . 75850) (FS.Get 75852 . 76321) ( FS.Put 76323 . 76794) (FS.ItemFont 76796 . 77157) (FS.ItemValue 77159 . 77565) (FS.ItemShift 77567 . 77947) (FS.MakeItem 77949 . 78371) (FS.Extract 78373 . 82297) (FS.ExtractFont 82299 . 82902) ( FS.ExtractShift 82904 . 83467) (FS.Insert 83469 . 85458) (FS.AllowedChar 85460 . 85697) ( FS.RealStringP 85699 . 85897))))) STOP \ No newline at end of file diff --git a/lispusers/EQUATIONS.TEDIT b/lispusers/EQUATIONS.TEDIT new file mode 100644 index 00000000..34813c02 Binary files /dev/null and b/lispusers/EQUATIONS.TEDIT differ diff --git a/lispusers/ETHERBOOT b/lispusers/ETHERBOOT new file mode 100644 index 00000000..75565e1b --- /dev/null +++ b/lispusers/ETHERBOOT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Sep-91 13:23:32" |{PELE:MV:ENVOS}MEDLEY>ETHERBOOT.;2| 15353 changes to%: (VARS ETHERBOOTCOMS) previous date%: "13-Jul-88 17:04:37" |{PELE:MV:ENVOS}MEDLEY>ETHERBOOT.;1|) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1991 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT ETHERBOOTCOMS) (RPAQQ ETHERBOOTCOMS ( (* ;; "Lisp-based Ethernet Boot server, requires ETHERRECORDS and EXPORTS.ALL to compile") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) ETHERRECORDS SPPDECLS)) (FNS ETHERBOOT SENDSIMPLEDATA SENDSPPDATA CACHE.BOOT.FILES) (VARS ETHERBOOTFILES BOOTREQUESTTYPES) (ADDVARS (BOOTFILEDIRECTORIES {CORE} {DSK}) (BOOTFILECACHETYPES DB GERM)) (INITVARS (BOOTFILECACHEDIRECTORY '{CORE})) (DECLARE%: DONTCOPY (RECORDS ETHERBOOTPACKET ETHERBOOTFILE BOOTREQUESTTYPE) (CONSTANTS (ETHERBOOTPACKETTYPE 9) (BOOTSERVERSOCKET 10) (SIMPLEREQUEST 1) (SIMPLEDATA 2) (SPPREQUEST 3))) (GLOBALVARS ETHERBOOTFILES BOOTREQUESTTYPES BOOTFILEDIRECTORIES BOOTFILECACHETYPES BOOTFILECACHEDIRECTORY))) (* ;; "Lisp-based Ethernet Boot server, requires ETHERRECORDS and EXPORTS.ALL to compile") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) ETHERRECORDS SPPDECLS) ) (DEFINEQ (ETHERBOOT [LAMBDA (LOGFILE) (* ; "Edited 13-Jul-88 17:03 by cdl") (DECLARE (SPECVARS . T)) (LET (XIP NSOCKET BOOTFILE BOOTSTREAM BOOTREQUESTTYPE FILENUMBER ETHERBOOTFILE) (DECLARE (SPECVARS . T)) (RESETLST [RESETSAVE NIL `(CLOSENSOCKET ,(SETQ NSOCKET (OPENNSOCKET BOOTSERVERSOCKET 'ACCEPT] [do (DISCARDXIPS NSOCKET) (if LOGFILE then (printout LOGFILE "Listening ..." T)) (RESETLST [RESETSAVE NIL `(RELEASE.XIP ,(SETQ XIP (GETXIP NSOCKET T] (if (SETQ BOOTREQUESTTYPE (FASSOC (with ETHERBOOTPACKET XIP ETHERBOOTREQUESTTYPE) BOOTREQUESTTYPES)) then (SETQ FILENUMBER (with ETHERBOOTPACKET XIP ETHERBOOTFILENUMBER)) (if [SETQ ETHERBOOTFILE (for BOOTFILE in ETHERBOOTFILES thereis (with ETHERBOOTFILE BOOTFILE (EQP BOOTFILENUMBER FILENUMBER] then (with ETHERBOOTFILE ETHERBOOTFILE (if LOGFILE then (printout LOGFILE (DATE) %, (with BOOTREQUESTTYPE BOOTREQUESTTYPE REQUESTDESCRIPTION) %, "Request for" %, BOOTFILEDESCRIPTION %, "from" %, (with XIP XIP XIPSOURCENSADDRESS) T)) (if (SETQ BOOTFILE (FINDFILE BOOTFILENAME NIL BOOTFILEDIRECTORIES)) then (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ BOOTSTREAM (OPENSTREAM BOOTFILE 'INPUT] (if LOGFILE then (printout LOGFILE "Opened" %, (FULLNAME BOOTSTREAM) T)) [NLSETQ (with XIP XIP (with BOOTREQUESTTYPE BOOTREQUESTTYPE (APPLY* REQUESTFN BOOTSTREAM XIP LOGFILE]) (if LOGFILE then (printout LOGFILE T "Closed" %, (FULLNAME BOOTSTREAM ) T)) elseif LOGFILE then (printout LOGFILE "Error, File Not Found:" %, BOOTFILENAME T))) elseif LOGFILE then (printout LOGFILE "Error, Unknown File Number:" %, FILENUMBER T)) elseif LOGFILE then (printout LOGFILE "Error, Unknown Request Type:" %, (with ETHERBOOTPACKET XIP ETHERBOOTREQUESTTYPE ) T)))])]) (SENDSIMPLEDATA [LAMBDA (BOOTSTREAM PACKET LOGFILE) (* ; "Edited 13-Jul-88 15:45 by cdl") (LET (SOCKET) (DECLARE (SPECVARS SOCKET)) (if LOGFILE then (printout LOGFILE "Packets")) (RESETLST [RESETSAVE NIL `(CLOSENSOCKET ,(SETQ SOCKET (OPENNSOCKET] (bind XIP (BYTECOUNT _ (GETFILEINFO BOOTSTREAM 'LENGTH)) for PACKETNUMBER to (ADD1 (GETFILEINFO BOOTSTREAM 'SIZE)) do (if LOGFILE then (printout LOGFILE %, PACKETNUMBER)) (SETQ XIP (with NSADDRESS (with XIP PACKET XIPSOURCENSADDRESS) (\FILLINXIP ETHERBOOTPACKETTYPE SOCKET NSHOSTNUMBER NSSOCKET NSNET))) (XIPAPPEND.WORD XIP SIMPLEDATA) (with ETHERBOOTPACKET PACKET (XIPAPPEND.WORD XIP ETHERBOOTBFNHI) (XIPAPPEND.WORD XIP ETHERBOOTBFNMID) (XIPAPPEND.WORD XIP ETHERBOOTBFNLOW)) (XIPAPPEND.WORD XIP PACKETNUMBER) (to BYTESPERPAGE as old BYTECOUNT by -1 until (ZEROP BYTECOUNT) do (XIPAPPEND.BYTE XIP (BIN BOOTSTREAM))) (SENDXIP SOCKET XIP) (BLOCK)))]) (SENDSPPDATA [LAMBDA (BOOTSTREAM PACKET LOGFILE) (* ; "Edited 13-Jul-88 16:56 by cdl") (DECLARE (SPECVARS . T)) (LET (INPUTSTREAM OUTPUTSTREAM) (DECLARE (SPECVARS . T)) (RESETLST [RESETSAVE NIL `(SPP.CLOSE ,(SETQ INPUTSTREAM (with NSADDRESS (with XIP PACKET XIPSOURCENSADDRESS ) (SPP.OPEN NSHOSTNUMBER NSSOCKET NIL NIL '(EOM.ON.FORCEOUTPUT T] (with SPPSTREAM (SETQ OUTPUTSTREAM (SPPOUTPUTSTREAM INPUTSTREAM)) (with SPPCON SPP.CONNECTION (* Switch to negotiated connection  id) (SETQ SPPDESTID (with ETHERBOOTPACKET PACKET ETHERBOOTSPPDESTID))) (* Send SYS packet to establish  (Dove fix)) (\SPP.SENDPKT SPP.CONNECTION (\SPP.SYSPKT SPP.CONNECTION 0))) (if LOGFILE then (printout LOGFILE "Packets")) (for PAGES to (SUB1 (GETFILEINFO BOOTSTREAM 'SIZE)) as COUNTER from 1 do (COPYBYTES BOOTSTREAM OUTPUTSTREAM BYTESPERPAGE) (FORCEOUTPUT OUTPUTSTREAM) (if LOGFILE then (if (GEQ COUNTER 10) then (SETQ COUNTER 0) (printout LOGFILE %, PAGES))) finally (COPYBYTES BOOTSTREAM OUTPUTSTREAM))) (if LOGFILE then (printout LOGFILE T "SPP Stream closed"]) (CACHE.BOOT.FILES [LAMBDA (TYPES) (* cdl "24-Sep-86 15:31") (bind FILE TOFILE for ETHERBOOTFILE in ETHERBOOTFILES do (with ETHERBOOTFILE ETHERBOOTFILE (if (AND (EQMEMB (U-CASE (FILENAMEFIELD BOOTFILENAME 'EXTENSION)) (OR TYPES BOOTFILECACHETYPES)) [NOT (INFILEP (SETQ TOFILE (PACKFILENAME 'NAME BOOTFILENAME 'DIRECTORY BOOTFILECACHEDIRECTORY ] (SETQ FILE (FINDFILE BOOTFILENAME NIL BOOTFILEDIRECTORIES))) then (COPYFILE FILE TOFILE) (PRINTOUT T FILE T]) ) (RPAQQ ETHERBOOTFILES (("Standard DLion Ethernet Initial Microcode" EtherInitial.db 2852126720) ("Standard DLion Diagnostic Microcode" MoonBoot.db 2852126728) ("Standard DLion Mesa Microcode" Mesa.db 2852126736) ("Standard DLion Germ" DLion.germ 2852126744) ("Standard DLion Boot File" SimpleNetExecDLion.boot 2852126752) ("Standard DLion Diagnostics Boot File" EIDiskDLion.boot 2852127232) ("Standard DLion Installer Boot File" InstallerNSDLion.boot 2852127234) ("Alternate DLion Ethernet Initial Microcode" EtherInitialAlt.db 2852126721) ("Alternate DLion Mesa Microcode" Mesa.db 2852126738) ("Alternate DLion Germ" DLion.germ 2852126746) ("Alternate DLion Boot File" InstallerNSDLion.boot 2852126754) ("Standard TriDLion Diagnostic Microcode" Moonboot.db 2852126729) ("Standard TriDLion Mesa Microcode" TridentRavenMesa.db 2852126737) ("Standard TriDLion Germ" TriDlion.germ 2852126745) ("Standard TriDLion Boot File" SimpleNetExecTriDlion.boot 2852126753) ("Alternate TriDLion Mesa Microcode" TridentRavenMesa.db 2852126739) ("Alternate TriDLion Germ" TriDlion.germ 2852126747) ("Alternate TriDLion Boot File" InstallerNSTriDlion.boot 2852126753) ("Standard Dove Ethernet Initial Microcode" EtherInitialDove.db 2852128768) ("Standard Dove Diagnostic Microcode" MoonRise.db 2852128776) ("Standard Dove Mesa Microcode" MesaDove.db 2852128784) ("Standard Dove Germ" Dove.germ 2852128792) ("Standard Dove Boot File" SimpleNetExecDove.boot 2852128800) ("Alternate Dove Ethernet Initial Microcode" EtherInitialDove.db 2852128769) ("Alternate Dove Diagnostic Microcode" MoonRise.db 2852128777) ("Alternate Dove Mesa Microcode" MesaDove.db 2852128785) ("Alternate Dove Germ" Dove.germ 2852128793) ("Alternate Dove Boot File" InstallerNSDove.boot 2852128801) ("Dove Simple Net Exec" SimpleNetExecDove.boot 2852128824) ("Dove Configuration Utility" SysConfigOfflineDove.boot 2852128825) ("Dove Installer" InstallerNSDove.boot 2852128826) ("Dove Diagnostics Utility" DiagDiskUtilDove.boot 2852128828) ("Dove Rigid Disk Diagnostics Utility" DiagRDDove.boot 2852128829) ("Dove Ethernet Diagnostics Utility" DiagEtherDove.boot 2852128830) ("Dove Keyboard & Display Diagnostics Utility" KDMDove.boot 2852128831))) (RPAQQ BOOTREQUESTTYPES ((1 Simple SENDSIMPLEDATA) (3 SPP SENDSPPDATA))) (ADDTOVAR BOOTFILEDIRECTORIES {CORE} {DSK}) (ADDTOVAR BOOTFILECACHETYPES DB GERM) (RPAQ? BOOTFILECACHEDIRECTORY '{CORE}) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS ETHERBOOTPACKET [(ETHERBOOTBASE (with XIP DATUM XIPCONTENTS)) (ETHERBOOTFILENUMBER (with ETHERBOOTPACKET DATUM (PLUS (LSH ETHERBOOTBFNHI 32) (LSH ETHERBOOTBFNMID 16) ETHERBOOTBFNLOW] (BLOCKRECORD ETHERBOOTBASE ((ETHERBOOTREQUESTTYPE WORD) (ETHERBOOTBFNHI WORD) (ETHERBOOTBFNMID WORD) (ETHERBOOTBFNLOW WORD) (ETHERBOOTSPPDESTID WORD)))) (RECORD ETHERBOOTFILE (BOOTFILEDESCRIPTION BOOTFILENAME BOOTFILENUMBER)) (RECORD BOOTREQUESTTYPE (REQUESTTYPE REQUESTDESCRIPTION REQUESTFN)) ) (DECLARE%: EVAL@COMPILE (RPAQQ ETHERBOOTPACKETTYPE 9) (RPAQQ BOOTSERVERSOCKET 10) (RPAQQ SIMPLEREQUEST 1) (RPAQQ SIMPLEDATA 2) (RPAQQ SPPREQUEST 3) (CONSTANTS (ETHERBOOTPACKETTYPE 9) (BOOTSERVERSOCKET 10) (SIMPLEREQUEST 1) (SIMPLEDATA 2) (SPPREQUEST 3)) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ETHERBOOTFILES BOOTREQUESTTYPES BOOTFILEDIRECTORIES BOOTFILECACHETYPES BOOTFILECACHEDIRECTORY) ) (PUTPROPS ETHERBOOT COPYRIGHT ("Stanford University" 1985 1986 1987 1988 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1585 11003 (ETHERBOOT 1595 . 6049) (SENDSIMPLEDATA 6051 . 7503) (SENDSPPDATA 7505 . 9712) (CACHE.BOOT.FILES 9714 . 11001))))) STOP \ No newline at end of file diff --git a/lispusers/ETHERBOOT.TEDIT b/lispusers/ETHERBOOT.TEDIT new file mode 100644 index 00000000..12da0b75 Binary files /dev/null and b/lispusers/ETHERBOOT.TEDIT differ diff --git a/lispusers/EVAL-WHEN-PATCH b/lispusers/EVAL-WHEN-PATCH new file mode 100644 index 00000000..44523995 --- /dev/null +++ b/lispusers/EVAL-WHEN-PATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated " 2-Jun-87 14:51:46" {dsk}work>eval-when-patch.\;1 30488 |changes| |to:| (vars eval-when-patchcoms) (fns addtocom delfromcom getdefcurrent importeval infilecom)) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint eval-when-patchcoms) (rpaqq eval-when-patchcoms ((fns addtocom delfromcom getdefcurrent importeval infilecom))) (defineq (addtocom (lambda (com name type near listname) (* \; "Edited 2-May-87 19:04 by Pavel") (* \;  "tries to insert NAME into the prettycom COM; returns NIL if unsuccessful") (prog (tem) (cond ((and near (not (infilecoms? near type (list com)))) (return))) (cond ((setq tem (|fetch| add |of| (car com))) (return (cond ((or (null listname) (infilecoms? listname 'filevars (list com))) (and (setq tem (apply* tem com name type near)) (markaschanged comsname 'vars)) tem))))) (return (selectq (car com) (fns (and (eq type 'fns) (addtocom1 com name near listname))) ((vars initvars) (cond ((or (eq (car com) 'vars) near listname) (* \;  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.") (selectq type (expressions (cond ((eq (car name) 'setq) (addtocom1 com (cdr name) near listname)))) (vars (addtocom1 com name near listname)) nil)))) (coms (addtocoms (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (caddr com)) (t (return)))) (t (cdr com))) name type near listname)) (declare\: (and (or listname near) (addtocoms (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (caddr com)) (t (return)))) (t (cdr com))) name type near listname))) (cl:eval-when (and (or listname near) (addtocoms (cond ((eq (cl:third com) '*) (cond ((litatom (cl:fourth com)) (cl:fourth com)) (t (return)))) (t (cddr com))) name type near listname))) ((prop ifprop) (selectq type (props (cond ((eq (cadr com) (cadr name)) (addtocom1 (cdr com) (car name) near listname)) ((and (eq (car name) (caddr com)) (null (cdddr com))) (/rplaca (cdr com) (union (mklist (cdr name)) (mklist (cadr com)))) (markaschanged comsname 'vars) t))) (macros (cond ((and (|for| prop |inside| (cadr com) |always| (eqmemb prop macroprops)) (|for| prop |in| macroprops |always| (or (eqmemb prop (cadr com)) (not (getprop name prop))))) (* |;;| "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed") (addtocom1 (cdr com) name near listname)))) nil)) ((props alists) (and (eq type (car com)) (addtocom1 com (/nconc1 (or (assoc (car name) (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (and (or (null listname) (eq (caddr com) listname)) (gettopval (caddr com)))) (t (return)))) (t (cdr com)))) (list (car name))) (cadr name)) near listname))) (p (cond ((and (eq type 'expressions) (neq (car name) 'setq)) (addtocom1 com name near listname)))) (and (eq (car com) type) (addtocom1 com name near listname))))))) (delfromcom (lambda (com name type) (* \; "Edited 2-May-87 19:02 by Pavel") (* \; "Tries to delete NAME from COM") (prog (tem var new) (cond ((setq tem (|fetch| delete |of| (car com))) (and (setq tem (apply* tem com name type)) (markaschanged comsname 'vars)) (return tem))) (return (selectq (car com) ((declare\: coms) (delfromcoms (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (caddr com)) (t (return)))) (t (cdr com))) name type)) ((cl:eval-when) (delfromcoms (cond ((eq (cl:third com) '*) (cond ((litatom (cl:fourth com)) (cl:fourth com)) (t (return)))) (t (cddr com))) name type)) ((alists props) (and (eq type (car com)) (cond ((eq (cadr com) '*) (cond ((and (litatom (setq var (caddr com))) (setq tem (assoc (car name) (gettopval var))) (neq (cdr tem) (setq tem (removeitem (cadr name) (cdr tem))))) (saveset var tem t 'noprint) t))) ((and (cdr (setq tem (assoc (car name) (cdr com)))) (neq (cdr tem) (setq new (removeitem (cadr name) (cdr tem))))) (/rplacd tem new) (markaschanged comsname 'vars) t)))) (blocks (* |;;| "Remove function name from blocks declarations. This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.") (and (eq type 'fns) (|for| block |in| (infilecomtail com t) |do| (and (memb name block) (/dremove name block)) (|for| x |in| block |when| (and (listp x) (memb name (cdr x))) |do| (/rplacd x (remove name (cdr x))))))) ((prop ifprop) (selectq type (props (return (cond ((eq (cadr com) (cadr name)) (delfromcom1 (cdr com) (car name))) ((and (eqmemb (cadr name) (cadr com)) (null (cdr (setq tem (prettycom1 (cdr com))))) (eq (car tem) (car name))) (/rplaca (cdr com) (remove (cadr name) (mklist (cadr com)))) (markaschanged comsname 'vars) t)))) (cond ((|for| prop |inside| (cadr com) |always| (eq type (getprop prop 'proptype))) (delfromcom1 (cdr com) name))))) ((records initrecords sysrecords) (and (eq type 'records) (delfromcom1 com name))) (p (and (eq type 'expressions) (delfromcom1 com name))) ((vars initvars) (and (eq type 'vars) (delfromcom1 com name t))) (and (eq type (car com)) (delfromcom1 com name))))))) (getdefcurrent (lambda (name type options) (* \; "Edited 2-May-87 19:00 by Pavel") (* \;  "Gets the current definition--source=0") (let (def) (cond ((and (setq def (|fetch| getdef |of| type)) (neq def t)) (* |;;| "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.") (or (neq (setq def (apply* def name type options)) (|fetch| nulldef |of| type)) (getdeferr name type options)) def) (t (or (neq (setq def (selectq type (fns (and (litatom name) (exprp (setq def (virginfn name))) def)) (vars (|if| (litatom name) |then| (gettopval name) |else| 'nobind)) ((fields records) (|if| (litatom name) |then| (setq def (selectq type (records (reclook name)) (mkprogn (fieldlook name)))) (|if| (eqmemb 'edit options) |then| (copy def) |else| def))) (files (* \;  "what is the `definition' of a file? -- I guess the COMS which say what it contains") (|if| (litatom name) |then| (|if| (setq def (getfiledef name)) |then| (updatefiles) (list (listp (gettopval (filecoms def))) (|fetch| tobedumped |of| (|fetch| fileprop |of| def)) (listp (|fetch| filedates |of| def)))))) (templates (|if| (and (litatom name) (setq def (gettemplate name))) |then| (list 'settemplate (kwote name) (kwote def)))) (macros (|if| (and (litatom name) (setq def (|for| x |on| (getproplist name) |by| (cddr x) |when| (fmemb (car x) macroprops) |join| (list (car x) (cadr x))))) |then| `(putprops ,name ,@def))) (expressions (listp name)) (props (and (listp name) (and (setq def (some (getproplist (car name)) (function (lambda (x) (eq x (cadr name)))) (function cddr))) (list 'putprops (car name) (cadr name) (cadr def))))) (filepkgcoms (and (litatom name) (prog ((com (filepkgcom name)) (typ (filepkgtype name))) (return (cond ((and com typ) (list (cons 'com com) (cons 'type typ))) (com (list (cons 'com com))) (typ (list (cons 'type typ)))))))) (filevars (cond ((and (litatom name) (listp (setq def (gettopval name))) (whereis name 'filevars)) def) (t 'nobind))) (let ((coms (list (makenewcom name type))) file) (cond ((not (setq def (getdefcom coms))) (with-reader-environment *old-interlisp-read-environment* (resetlst (resetsave prettyflg) (resetsave fontchangeflg) (resetsave (output (setq file (openstream '{nodircore} 'both)))) (prettydefcoms coms) (setfileptr file 0) (setq def (|for| x |in| (readfile file) |join| (selectq (car x) ((*) nil) (declare\: (|for| y |on| (cdr x) |unless| (selectq (car y) ((copywhen eval@loadwhen eval@compilewhen) (return (list y))) (fmemb (car y) declaretagslst)) |collect| (car y))) (cl:eval-when (cddr x)) (progn (cdr x)) (list x)))) (setq nocopy t))))) (mkprogn def)))) (|fetch| nulldef |of| type)) (getdeferr name type options)) def))))) (importeval (lambda (form returnflg) (* \; "Edited 2-May-87 18:57 by Pavel") (* |;;| "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms") (and (listp form) (selectq (car form) (declare\: (for z in (cdr form) join (importeval z returnflg))) (cl:eval-when (for z in (cddr form) join (importeval z returnflg))) (/declaredatatype (* \;  "Ignore datatype initializations -- we only need the record declaration itself") nil) (progn (* \; "default: eval and/or return it") (and (neq returnflg t) (eval form)) (and returnflg (list form))))))) (infilecom (lambda (com) (* \; "Edited 2-May-87 19:03 by Pavel") (cond ((nlistp com) (cond ((eq type 'vars) (infilecomsval com)))) ((eq (car com) commentflg) (* |;;|  "must be special case'd first so that (* * values) doesn't make it look like `values' is a variable") (* \;  "don't know why I should bother, but someone might want to know all of the comments on a file???") (cond ((eq type commentflg) (infilecomsval com t))) nil) (t (prog ((comname (car com)) (tail (cdr com)) cfn tem) (cond ((cond ((setq cfn (|fetch| (filepkgcom contents) |of| comname)) (setq tem (apply* cfn com (cond ((and (null onfiletype) (listp name)) (* \;  "call from WHEREIS of a name which is a list") (list name)) (t name)) type onfiletype))) ((setq cfn (|fetch| (filepkgcom prettytype) |of| comname)) (* \; "for compatability") (setq tem (apply* cfn com type name)))) (cond ((nlistp tem) (cond ((eq tem t) (cond ((or (eq name t) (null onfiletype)) (retfrom 'infilecoms? t)))))) (t (infilecomsvals tem)))) ((listp tail) (* |;;| "this SELECTQ handles the `exceptional cases' for the built in types. There is an explicit RETURN in the SELECTQ clause if the default is handled") (selectq comname ((prop ifprop) (setq tail (cdr tail))) nil) (cond ((eq (car tail) '*) (cond ((litatom (cadr tail)) (selectq type ((vars filevars) (infilecomsval (cadr tail))) nil)) ((and (listp (cadr tail)) (eq onfiletype 'update) (eq type 'vars) (eq (caadr tail) 'progn) (fmemb (car (last (cadr tail))) name)) (setq val (cons (cadr tail) val)))))) (selectq comname ((coms export) (infilecoms (infilecomtail com))) (cl:eval-when (infilecoms (infilecomtail (cdr com)))) (declare\: (* \; "skip over DECLARE: tags") (return (and (not (fmemb 'compilervars com)) (ifcdeclare (infilecomtail com) (eq type 'declare\:))))) (original (* \; "dont expand macros") (prog ((origflg t)) (infilecoms (infilecomtail com)))) ((prop ifprop) (* \;  "this currently does not handle `pseudo-types' of PROPNAMES") (selectq type (props (ifcpropscan (infilecomtail (cdr com)) (cadr com))) (macros (infilecomsmacro (infilecomtail (cdr com)) (cadr com))) nil)) (props (return (ifcprops com))) (macros (return (selectq type (props (ifcpropscan (infilecomtail com) macroprops)) (macros (infilecomsvals (infilecomtail com))) nil))) (alists (* \;  "sigh. This should probably also `coerce' when asking for LISPXMACROS, etc.") (return (selectq type (alists (infilepairs (infilecomtail com))) nil))) (p (return (selectq type ((expressions p) (infilecomsvals (infilecomtail com t) t)) (cond ((null onfiletype) (* \; "for WHEREIS and FILECOMSLST") (selectq type (i.s.oprs (ifcexprtype com 'i.s.opr)) (templates (ifcexprtype com 'settemplate)) nil)))))) ((addvars appendvars) (selectq type (vars (return (and (null onfiletype) (|for| x |in| (infilecomtail com t) |do| (infilecomsval (car x) t))))) (alists (return (|for| x |in| (infilecomtail com) |when| (eqmemb 'alist (getprop (car x) 'vartype)) |do| (|for| z |in| (cdr x) |do| (infilecomsval (list (car x) (car z)) t))))) (or (eq type comname) (return)))) ((vars initvars filevars uglyvars horriblevars constants array) (return (cond ((eq type 'expressions) (|for| x |in| (infilecomtail com) |when| (listp x) |do| (infilecomsval (cons 'setq x) t))) ((or (eq type 'vars) (eq type comname))(* \;  "either want all VARS, or else want all FILEVARS and this is a FILEVARS command") (|for| x |in| (infilecomtail com) |do| (cond ((listp x) (and (car x) (infilecomsval (car x) t))) (x (infilecomsval x (eq comname 'initvars))))))))) (defs (return (|for| x |in| (infilecomtail com) |when| (eq type (car x)) |do| (infilecomsvals (cdr x))))) (files (return)) nil) (* |;;| "Exceptional cases now handled. If TYPE matches (CAR COM) then scan the tail as usual. Else expand the com's MACRO, if it has one, unless there was a CONTENTS function") (cond ((eq comname type) (infilecomsvals (infilecomtail com))) ((and (or (null cfn) (and (eq cfn t) (null onfiletype))) (null origflg) (setq tem (|fetch| (filepkgcom macro) |of| comname))) (infilecoms (subpair (car tem) (infilecomtail com) (cdr tem)))))))))))) ) (putprops eval-when-patch copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (475 30395 (addtocom 485 . 7020) (delfromcom 7022 . 12896) (getdefcurrent 12898 . 19529) (importeval 19531 . 20542) (infilecom 20544 . 30393))))) stop \ No newline at end of file diff --git a/lispusers/EVALOBJ b/lispusers/EVALOBJ new file mode 100644 index 00000000..a15a5c09 --- /dev/null +++ b/lispusers/EVALOBJ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-May-2018 08:22:13"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>EVALOBJ.;2 15206 changes to%: (VARS EVALOBJCOMS) previous date%: " 6-May-2000 09:24:45" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>EVALOBJ.;1) (* ; " Copyright (c) 1997, 1998, 1999, 2000, 2018 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EVALOBJCOMS) (RPAQQ EVALOBJCOMS [(FILES IMOBJAPPLICATION) (DECLARE%: DOEVAL@LOAD DONTCOPY (FILES EXPORTS.ALL)) (FNS EVALOBJ.BUTTONEVENTINFN EVALOBJ.DISPLAYFN EVALOBJ.IMAGEBOXFN EVALOBJ.COPYFN EVALOBJ.CREATE EVALOBJ.GETFN EVALOBJ.PUTFN) (FNS PARAMS TEXTSTREAMPARAM) [COMS (FNS EVALOBJ.DISMANTLEFN EVALOBJ.SELTOOBJ) (P (AND (GETD 'ADDTOIMOBJAPPLICATIONMENU) (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ "Converts current selection to an evaluation object" (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'CREATE/LOAD] (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'HARDCOPY] [INITVARS (EVALOBJ.IMAGEFNS (IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN 'EVALOBJ.COPYFN 'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ) ""] (GLOBALVARS EVALOBJ.IMAGEFNS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PARAMS) (NLAML) (LAMA]) (FILESLOAD IMOBJAPPLICATION) (DECLARE%: DOEVAL@LOAD DONTCOPY (FILESLOAD EXPORTS.ALL) ) (DEFINEQ (EVALOBJ.BUTTONEVENTINFN [LAMBDA (OBJ STREAM) (* ; "Edited 19-Aug-97 14:03 by rmk:") (* jtm%: " 5-Aug-88 15:40") (* ;  "the user has pressed a button inside the eval OBJ") (CL:WHEN [MENU (CREATE MENU ITEMS _ '((|Edit evaulation form| T " Opens a window to edit the evaluation form"] (* ;;; "SEDIT always forks a process. We hang in that process until it closes (CLOSE-ON-COMPLETION)") (ALLOW.BUTTON.EVENTS) [IMAGEOBJPROP OBJ 'OBJECTDATUM (LET ((*READTABLE* FILERDTBL)) (DECLARE (SPECVARS *READTABLE*)) (EDITE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM)) NIL 'Evaluation% Form NIL NIL '(:CLOSE-ON-COMPLETION] (IMAGEOBJPROP OBJ 'EVALUATED NIL) 'CHANGED)]) (EVALOBJ.DISPLAYFN [LAMBDA (OBJ IMAGESTREAM) (* ; "Edited 19-Aug-97 13:46 by rmk:") (* fsg "17-Sep-87 11:14") (* ;; "Display an Eval imageobject. If the stream-type is display, then shows the form. Otherwise the stream-type is hardcopy and the form is executed.") (DECLARE (SPECVARS OBJ IMAGESTREAM) (USEDFREE TEXTSTREAM)) (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (LET ((FONT (DSPFONT '(TERMINAL 10) IMAGESTREAM))) (PRIN3 "{Eval: " IMAGESTREAM) (PRIN4 (IMAGEOBJPROP OBJ 'OBJECTDATUM) IMAGESTREAM) (PRIN3 "}" IMAGESTREAM) (DSPFONT FONT IMAGESTREAM))) (CL:WHEN (EQMEMB (IMAGEOBJPROP OBJ 'WHEN) '(NIL HARDCOPY)) (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM] (IF (LITATOM FORM/FN) THEN (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ) ELSE (EVAL FORM/FN))))]) (EVALOBJ.IMAGEBOXFN [LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 19-Aug-97 13:43 by rmk:") (* ss%: "27-Jun-87 15:50") (* ;; "Return the ImageBox for an EVALOBJ. Evaluates a CREATE/LOAD form that hasn't yet been evaluated (presumably came from the COPYFN).") (DECLARE (SPECVARS OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (USEDFREE TEXTSTREAM)) (CL:WHEN [AND (EQ (IMAGEOBJPROP OBJ 'WHEN) 'CREATE/LOAD) (NOT (IMAGEOBJPROP OBJ 'EVALUATED] (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM] (IF (LITATOM FORM/FN) THEN (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ) ELSE (EVAL FORM/FN)) (IMAGEOBJPROP OBJ 'EVALUATED T))) (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (LET [(FONT (FONTCREATE '(TERMINAL 10] (CREATE IMAGEBOX XSIZE _ (PLUS (STRINGWIDTH "{Eval: }" FONT) (STRINGWIDTH (IMAGEOBJPROP OBJ 'OBJECTDATUM) FONT T (FIND-READTABLE "INTERLISP"))) YSIZE _ (FONTPROP FONT 'HEIGHT) YDESC _ (FONTPROP FONT 'DESCENT) XKERN _ 0))) (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (EVALOBJ.COPYFN [LAMBDA (OBJ) (* ; "Edited 19-Aug-97 13:30 by rmk:") (EVALOBJ.CREATE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM)) (IMAGEOBJPROP OBJ 'WHEN]) (EVALOBJ.CREATE [LAMBDA (FORM WHEN TEXTSTREAM) (* ; "Edited 6-May-2000 09:24 by rmk:") (DECLARE (SPECVARS TEXTSTREAM)) (* ;; "For EVAL at CREATE/LOAD. TEXTSTREAM is NIL on call from COPYFN, since the destination stream isn't known. The object is not marked as evaluated, so that the imagebox fn will do it the first time it is displayed/printed. Hopefully it won't be copied to place where it isn't initially displayed--that's the best we can do. ") (IF (AND FORM (OR (LISTP FORM) (LITATOM FORM))) THEN (LET ((OBJ (IMAGEOBJCREATE FORM EVALOBJ.IMAGEFNS))) (IMAGEOBJPROP OBJ 'DISMANTLEFN (FUNCTION EVALOBJ.DISMANTLEFN)) (IMAGEOBJPROP OBJ 'TEDIT-TO-TEX-FN (FUNCTION TRUE)) (IMAGEOBJPROP OBJ 'WHEN WHEN) (CL:WHEN (AND TEXTSTREAM (EQ WHEN 'CREATE/LOAD)) (IF (LITATOM FORM) THEN (* ;;  "NIL is image stream. It should be an error if a CREATE/LOAD form accesses an image stream!") (APPLY* FORM NIL TEXTSTREAM OBJ) ELSE (EVAL FORM)) (IMAGEOBJPROP OBJ 'EVALUATED T)) OBJ) ELSE (ERROR!]) (EVALOBJ.GETFN [LAMBDA (FILESTREAM TEXTSTREAM) (* ; "Edited 19-Aug-97 13:25 by rmk:") (LET ((DATA (HREAD FILESTREAM)) FORM WHEN) (IF (LITATOM (CAR (LISTP DATA))) THEN (SETQ FORM DATA) ELSE (SETQ FORM (CAR DATA)) (SETQ WHEN (CADR DATA))) (EVALOBJ.CREATE FORM WHEN TEXTSTREAM]) (EVALOBJ.PUTFN [LAMBDA (OBJ STREAM) (* ; "Edited 19-Aug-97 13:28 by rmk:") (* ;; "Put a description of an eval object into the file.") (HPRINT (LIST (IMAGEOBJPROP OBJ 'OBJECTDATUM) (IMAGEOBJPROP OBJ 'WHEN)) STREAM]) ) (DEFINEQ (PARAMS [NLAMBDA PARAMS (* ; "Edited 7-Nov-97 08:41 by rmk:") (DECLARE (USEDFREE TEXTSTREAM)) (* ;; "Each P is either") (* ;; " a list of the form (name value), in which case value becomes the (new) value of parameter name;") (* ;;  " a list of the form (name v1 v2 ...) in which case it is treated as (name (v1 v2 ...))") (* ;; " a list of the form (name), in which case the value for name (even NIL) is removed)") (* ;; " a litatom, in which case it is treated as a list (atom T).") (* ;; "The form (name) is different from (name NIL)--the disinction allows the client to distinguish between no value (hence use a default) and a value of NIL.") (FOR P PCELL [PROP _ (APPEND (STREAMPROP TEXTSTREAM 'PARAMETERS] IN PARAMS DO (IF (LISTP P) THEN [IF (CDDR P) THEN (SETQ P (LIST (CAR P) (CDR P] ELSEIF (LITATOM P) THEN (SETQ P (LIST P T)) ELSE (PROMPTPRINT P " is not a valid text parameter")) (SETQ PCELL (ASSOC (CAR P) PROP)) (IF (CDR P) THEN [IF PCELL THEN (RPLACA (CDR PCELL) (CADR P)) ELSE (PUSH PROP (LIST (CAR P) (CADR P] ELSEIF PCELL THEN (SETQ PROP (DREMOVE PCELL PROP))) FINALLY (STREAMPROP TEXTSTREAM 'PARAMETERS PROP) (RETURN PROP]) (TEXTSTREAMPARAM [LAMBDA (PARAMNAME DEFAULTVALUE) (DECLARE (USEDFREE TEXTSTREAM)) (* ; "Edited 3-Aug-98 13:48 by rmk:") (* ;; "Returns the value of the parameter PARAMNAME on a higher-bound TEXTSTREAM, or DEFAULTVALUE if the parameter is not set.") (IF (AND (BOUNDP 'TEXTSTREAM) (STREAMP TEXTSTREAM)) THEN (LET [(PCELL (ASSOC PARAMNAME (STREAMPROP TEXTSTREAM 'PARAMETERS] (IF PCELL THEN (CADR PCELL) ELSE DEFAULTVALUE)) ELSE DEFAULTVALUE]) ) (DEFINEQ (EVALOBJ.DISMANTLEFN [LAMBDA (TEXTSTREAM OBJ CHAR#) (* ; "Edited 27-Jan-97 18:03 by rmk:") (SETFILEPTR TEXTSTREAM (SUB1 CHAR#)) (RESETLST (RESETSAVE %#RPARS) (PRINTOUT TEXTSTREAM 2 .PPV (IMAGEOBJPROP OBJ 'OBJECTDATUM)))]) (EVALOBJ.SELTOOBJ [LAMBDA (TEXTSTREAM SELECTION WHEN) (* ; "Edited 19-Aug-97 13:23 by rmk:") (IF (COLLECTIMOBJSINSEL TEXTSTREAM SELECTION) THEN (TEDIT.PROMPTPRINT TEXTSTREAM "Evaluation form can't contain image object" T) ELSE (* ; "Pack on ]]] to avoid eof errors") (LET ((OBJ (EVALOBJ.CREATE (READ (OPENSTRINGSTREAM (CONCAT (TEDIT.SEL.AS.STRING TEXTSTREAM SELECTION) "]]]]]")) (FIND-READTABLE "INTERLISP")) WHEN TEXTSTREAM))) (REPLACESELWITHOBJ OBJ TEXTSTREAM SELECTION]) ) [AND (GETD 'ADDTOIMOBJAPPLICATIONMENU) (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ "Converts current selection to an evaluation object" (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA ( TEXTSTREAM SELECTION ) (  EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'CREATE/LOAD] (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'HARDCOPY] (RPAQ? EVALOBJ.IMAGEFNS [IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN 'EVALOBJ.COPYFN 'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ) ""]) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EVALOBJ.IMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PARAMS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS EVALOBJ COPYRIGHT ("Xerox Corporation" 1997 1998 1999 2000 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3038 9319 (EVALOBJ.BUTTONEVENTINFN 3048 . 4241) (EVALOBJ.DISPLAYFN 4243 . 5418) ( EVALOBJ.IMAGEBOXFN 5420 . 6963) (EVALOBJ.COPYFN 6965 . 7188) (EVALOBJ.CREATE 7190 . 8606) ( EVALOBJ.GETFN 8608 . 9009) (EVALOBJ.PUTFN 9011 . 9317)) (9320 11885 (PARAMS 9330 . 11261) ( TEXTSTREAMPARAM 11263 . 11883)) (11886 13031 (EVALOBJ.DISMANTLEFN 11896 . 12179) (EVALOBJ.SELTOOBJ 12181 . 13029))))) STOP \ No newline at end of file diff --git a/lispusers/EXAMPLES.LGC b/lispusers/EXAMPLES.LGC new file mode 100644 index 00000000..8219d452 --- /dev/null +++ b/lispusers/EXAMPLES.LGC @@ -0,0 +1 @@ +EXAMPLES 3 NOTMEMBER (SA LAMBDA (X Y) (NOT (MEMBER X Y))) SA-MEMBER (SA LAMBDA (X Y) (MEMBER X Y)) PRINT-INFO (SA LAMBDA (FROM TO) (PROGN (FORMAT T "Current room is ~A, enter now room ~A~%%" FROM TO) T)) 9 SEARCH (((SEARCH ?FROM ?TO) :- (LOGIC-ASSERT GOAL (((GOAL ?TO))) EXAMPLES) (EXPLORE ?FROM ?TO (?FROM)) (GOAL ?TO))) GOAL (((GOAL G))) PHONE (((PHONE G))) NOT (((NOT ?X) :- (WFF ?X) ! (FAIL)) ((NOT ?X))) LOGIC-MEMBER (((LOGIC-MEMBER ?A (?A . ?B)) :- !) ((LOGIC-MEMBER ?A (?B . ?C)) :- (LOGIC-MEMBER ?A ?C))) DOOR (((DOOR A B)) ((DOOR A N)) ((DOOR B M)) ((DOOR B C)) ((DOOR M I)) ((DOOR C D)) ((DOOR D E)) ((DOOR E F)) ((DOOR F H)) ((DOOR H L)) ((DOOR L G))) APPEND (((APPEND NIL ?Q ?Q)) ((APPEND (?A . ?B) ?C (?A . ?D)) :- (APPEND ?B ?C ?D))) IS-THERE-DOOR (((IS-THERE-DOOR ?A ?B) :- (DOOR ?A ?B)) ((IS-THERE-DOOR ?A ?B) :- (DOOR ?B ?A))) EXPLORE (((EXPLORE ?X ?X ?START-LIST)) ((EXPLORE ?X ?Y ?START-LIST) :- (IS-THERE-DOOR ?X ?Z) (NOTMEMBER ?Z ?START-LIST) (PRINT-INFO ?X ?Z) (EXPLORE ?Z ?Y (?Z . ?START-LIST)))) \ No newline at end of file diff --git a/lispusers/EYECON b/lispusers/EYECON new file mode 100644 index 00000000..2c144bc2 --- /dev/null +++ b/lispusers/EYECON @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "24-Oct-88 21:40:18" {ERIS}LISP>EYECON.\;18 21796 |changes| |to:| (VARS EYECONCOMS EYECON.CONTROL.POINTS) (FNS EYECON.TRACK EYECON.FIND.POINT) |previous| |date:| "24-Oct-88 21:32:12" {ERIS}LISP>EYECON.\;17) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT EYECONCOMS) (RPAQQ EYECONCOMS ((CONSTANTS EYECON.PUPIL.SIZE EYECON.LEFT.CENTER EYECON.RIGHT.CENTER EYECON.HEIGHT.OFFSET EYECON.RIGHT.WINK EYECON.WINK.WIDTH) (VARS EYECON.PUPIL EYECON.MASK EYECON.OPEN EYECON.CLOSED EYECON.ICON EYECON.ICON.MASK EYECON.LEFT EYECON.BOTTOM) (FNS EYECON EYECON.DIE EYECON.DRAW.PUPIL EYECON.FIND.POINT EYECON.ICON EYECON.OPEN EYECON.TRACK EYECON.WINK) (* |;;| "Check screen size and compute appropriate scale factor") (* |;;| "All computations are scaled to keep them in smallp range") (VARS EYECON.SCALE.FACTOR EYECON.CONTROL.POINTS) (P (BIND (MINSF _ 256) (RANGE _ (MAX SCREENHEIGHT SCREENWIDTH)) FIRST (SETQ EYECON.SCALE.FACTOR 0) WHILE (ILESSP MINSF RANGE) DO (ADD EYECON.SCALE.FACTOR 1) (SETQ MINSF (LLSH MINSF 1))) (SETQ EYECON.SLOPE.LIST (FOR P IN (CDR EYECON.CONTROL.POINTS) COLLECT (IQUOTIENT (LSH (CDR P) 8) (CAR P)))) (PUSH EYECON.SLOPE.LIST (IPLUS (CAR EYECON.SLOPE.LIST) 1))))) (DECLARE\: EVAL@COMPILE (RPAQQ EYECON.PUPIL.SIZE 10) (RPAQQ EYECON.LEFT.CENTER 37) (RPAQQ EYECON.RIGHT.CENTER 97) (RPAQQ EYECON.HEIGHT.OFFSET 12) (RPAQQ EYECON.RIGHT.WINK 82) (RPAQQ EYECON.WINK.WIDTH 50) (CONSTANTS EYECON.PUPIL.SIZE EYECON.LEFT.CENTER EYECON.RIGHT.CENTER EYECON.HEIGHT.OFFSET EYECON.RIGHT.WINK EYECON.WINK.WIDTH) ) (RPAQQ EYECON.PUPIL #*(10 10)AN@@CO@@GOH@OOL@OCL@OCL@OOL@GOH@CO@@AN@@) (RPAQQ EYECON.MASK #*(133 45)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOON@@AOOOOOOOOOOON@@AOOOOOOOH@@OOOOOOO@@@@OOOOOOOOOOOL@@@COOOOOOH@@OOOOOON@@@@GOOOOOOOOOOH@@@AOOOOOOH@@OOOOOOH@@@@COOOOOOOOOO@@@@@GOOOOOH@@OOOOOOH@@@@COOOOOOOOOO@@@@@GOOOOOH@@OOOOOO@@@@@AOOOOOOOOON@@@@@COOOOOH@@OOOOOO@@@@@@OOOOOOOOOL@@@@@COOOOOH@@OOOOON@@@@@@OOOOOOOOOL@@@@@AOOOOOH@@OOOOOO@@@@@@OOOOOOOOOL@@@@@COOOOOH@@OOOOOOH@@@@@OOOOOOOOOL@@@@@GOOOOOH@@OOOOOOL@@@@@OOOOOOOOOL@@@@@OOOOOOH@@OOOOOON@@@@AOOOOOOOOON@@@@AOOOOOOH@@OOOOOOO@@@@COOOOOOOOOO@@@@COOOOOOH@@OOOOOOOH@@@OOOOOOOOOOOL@@@GOOOOOOH@@OOOOOOOO@@OOOOOOOOOOOOOL@COOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@ ) (RPAQQ EYECON.OPEN #*(133 45)E@@@@EOONJI@@@BC@CA@@@BEEOONH@@@BH@@HD@@AAGOOD@@EAD@C@@JBH@@KOOJB@@@H@@@B@HAEGFOOOMA@@@JAAD@@BBOOOMKJJ@DA@@@D@@@DJOGMONDAADE@BHJB@IONOKMDH@@@H@@I@AEGNIDKKOBJ@MJ@AFLAECOGDJEOJJ@B@@@HA@JMJJKEGODA@@DKDH@B@KOJKEEFMDB@@@@JLEOOM@DEKGOLJA@@@BADOOKFHHBOONHM@@@EBAGOHJAEEOOM@@DEHH@BOONJJADGOJABH@@JIGOH@@@@BEGOME@HDBJOOJI@@@@@GOJE@@@DJEOKD@@@AEKON@@DH@AOOFJ@@@@KGNIDH@@KJOH@@D@B@@DOFJJBAEEKLH@A@@H@@GMG@@@NKGJH@@@HABBON@KDKDAOMAB@D@@@EGKEH@@KGOD@@@@B@@ACML@C@@NOB@@A@@@@@KOK@@@NMFJD@@@@DA@KNIEJFJEODB@H@@@@IEJMH@@KGI@@@@@@ADBEEHB@A@FJI@J@@@@@@BGK@@@NOJD@@@BBB@HBOJI@BEGM@DAAA@@@@IGMH@@MJJH@@@DMKOEM@E@A@BHBNKOFLH@@@EEFH@@NOJB@@DICGDJEEAJHEFBJIDKKBDH@AAGMH@@IFDHBBAGOMOGMB@H@@DABOKNOOJAA@DIJ@@@KFJHH@BKOOFMDDEFAAJHHJMKOOE@@DEEK@@@EE@@@BOJJDHIJIII@BFFEFDDIEGM@@@BJH@@DJFJ@DJNMMECFJDEJFHIEKBJNMMDHAEIDH@@JJH@BAGAOOD@@EJ@@@AFH@@KONCJA@@EE@@@EDJJ@EJMGOBJJJDDLLHIEEECOJMFHAEDJH@@BA@DJIOOOOOI@A@B@A@B@BGOOOONEDHBA@@@EDJIABKOOOOBBKJBAAAGEACOOOOEBBEDJH@@H@EGGONN@@EOHD@@HD@@HGNH@AMOOKJH@@@@JDAMEOO@@@BMDABD@@IB@JM@@@CONJN@I@@@I@EGOON@@@@CAB@JDIDABC@@@@AOOOJHB@@@BDAMOOH@@@@CJ@HDC@HDAG@@@@@GONN@I@@@D@EGOOH@@@@BMDA@DHB@JM@@@@@GOOJH@H@@B@AOOO@@@@@AMDBDJDI@JN@@@@@COON@A@@@HHBBEO@@@@@@GA@DHDHBCH@@@@@CNIA@D@@@H@DJON@@@@@@ODE@C@BHKL@@@@@AOMDH@@@@B@@@@C@@@@@@@H@@@@@@D@@@@@@C@@@@A@@@H@ABEOH@@@@@J@DIABDHAD@@@@@GNIB@@@@@BD@@@@H@@@@@@D@C@C@@H@@@@@@D@@@@I@@@H@@AAFJ@@@@ABAF@@@AJAB@@@@AEJB@@@@@@B@D@@BI@@@@B@@IADJBD@A@@@@BE@@@HA@@@HH@@H@D@@@DHHHB@@@A@DDDH@@@H@D@@D@@@H@H@@E@E@@@@@A@JAADB@@@@@BHBH@@D@@@@E@@@@@B@EAAB@@EA@BBH@ABBBHA@@@@@BH@@HD@@@DH@@@@@H@@DDHH@@D@@@@@DH@@@H@@@B@@@@@@J@DD@@@H@@@@D@@@HHAD@@@@@A@@@D@@@@@@@D@@DAABBDIABB@H@@H@@@@@@@H@@ ) (RPAQQ EYECON.CLOSED #*(133 45)E@@@@EOONJI@@@@@@@@@@@BEEOONH@@@BH@@HD@@AAGOOD@@EA@@@@@DFH@@KOOJB@@@H@@@B@HAEGFOOOMA@@@@@@@@@BBOOOMKJJ@DA@@@D@@@DJOGMONDAA@@@@@DF@IONOKMDH@@@H@@I@AEGNIDKKOBJ@@@@@@@AECOGDJEOJJ@B@@@HA@JMJJKEGODA@@@@@@@F@KOJKEEFMDB@@@@JLDOOM@DEKGOLJ@@@@@BHOOKFHHBOOLHM@@@EBAOOHJAEEOOM@@@@@@@FOONJJADGONABH@@JIGOH@@@@BEGOM@@@@@EOOJI@@@@@GOJE@@@DJEOKD@@@AEKON@@@@@COOFJ@@@@KGNIDH@@KJOH@@D@B@@DOF@@@@@CGLH@A@@H@@GMG@@@NKGJH@@@HABBON@@@@@COMAB@D@@@EGKEH@@KGOD@@@@B@@ACM@@@@@EOB@@A@@@@@KOK@@@NMFJD@@@@DA@KN@@@@@CODB@H@@@@IEJMH@@KGI@@@@@@ADBEE@@@@@EFI@J@@@@@@BGK@@@NOJD@@@BBB@HBO@@@@@GI@DAAA@@@@IGMH@@MJJH@@@DMKOEM@@@@@@@FNKOFLH@@@EEFH@@NOJB@@DICGDJEE@@@@@EFIDKKBDH@AAGMH@@IFDHBBAGOMOGMB@@@@@BFOKNOOJAA@DIJ@@@KFJHH@BOOOFMDD@@@@@A@JMKOOM@@DEEK@@@EE@@@BGNJDHIJI@@@@@DIFDDIEOI@@@BJH@@DJFJ@DNNNBCCFJ@@@@@BIKCAAMMLHAEIDH@@JJH@BAOI@@@@@E@@@@@E@@@@@BGNA@@EE@@@EDJJ@IF@HJHHJJ@@@@@BIDDEDDAJDAEDJH@@BA@@JKHJ@CBA@A@@@@@D@BAC@ADGED@BA@@@EDHBAEBAG@DJBK@@@@@FIADHCJABJA@DJH@@H@E@FLIDH@@DHD@@@@@A@DH@@DJDMHBH@@@@JD@ICD@IBBM@DA@@@@@D@HBMABD@KBD@I@@@I@EBMAE@@H@BIB@@@@@BFE@@D@BJBMBHB@@@BDJMDJ@JBBB@B@@@@@@@A@AAAADADJMDI@@@D@BJO@H@@@@BHD@@@@@A@E@@@@@DCME@@H@@B@AGNL@HHHHHAD@@@@@AF@DDDDD@MOJ@A@@@HH@JOK@@@@@B@A@@@@@D@A@@@@@CGMD@D@@@H@EEONBBBBB@MD@@@@@AFLAAAAAAONJH@@@@BDDFBOL@D@HB@D@@@@@A@A@D@H@OMAHHI@@@H@@@MGJHIDA@JJ@@@@@BIDB@JDEGJL@@@@@@BD@@@GOBBBDACD@@@@@AGB@IAACOH@@@I@@@H@@DAENIEEABNM@@@@@EIMBBJJENJ@H@@@@@B@D@DCONLJDDOD@@@@@AGLHIDMOO@H@HA@@@HH@@@AONMKCKHH@@@@@@HGGCFMON@@@@D@@@H@H@A@GOGGONN@@@@@@@AMOOKKOHB@@D@@@@E@@@@ECOMMMMI@@@@@@@FFNNNOOBH@@@BH@@HD@@@B@OOMOFB@@@@@@@AAKNOOLA@@@@H@@@B@@@@H@BKKNJH@@@@@@@@EEOGE@@D@@@A@@@D@@@@@HCDKEDAA@@@@@DF@JKDK@D@@@@@H@@ ) (RPAQQ EYECON.ICON #*(30 18)@@COO@@@@COOOO@@@ON@AOL@AN@GHAN@CHAON@G@G@COO@CHN@COO@ALL@GLOH@LL@GHGH@LL@GHGH@LL@GLOH@LN@COO@ALG@COO@CHCHAON@G@AN@GHAN@@ON@AOL@@COOOO@@@@COO@@@ ) (RPAQQ EYECON.ICON.MASK #*(30 18)@@COO@@@@COOOO@@@OOOOOL@AOOOOON@COOOOOO@GOOOOOOHOOOOOOOLOOOOOOOLOOOOOOOLOOOOOOOLOOOOOOOLOOOOOOOLGOOOOOOHCOOOOOO@AOOOOON@@OOOOOL@@COOOO@@@@COO@@@ ) (RPAQQ EYECON.LEFT 200) (RPAQQ EYECON.BOTTOM 200) (DEFINEQ (EYECON (LAMBDA (EW) (* \; "Edited 8-Oct-88 23:02 by jrb:") (BITBLT EYECON.OPEN NIL NIL EW) (EYECON.DRAW.PUPIL EYECON.PUPIL EW EYECON.LEFT.CENTER EYECON.HEIGHT.OFFSET) (EYECON.DRAW.PUPIL EYECON.PUPIL EW EYECON.RIGHT.CENTER EYECON.HEIGHT.OFFSET) (WINDOWPROP EW 'PROCESS (ADD.PROCESS `(EYECON.TRACK ',EW))))) (EYECON.DIE (LAMBDA (EW) (* \; "Edited 2-Oct-88 20:00 by jrb:") (DEL.PROCESS (WINDOWPROP EW 'PROCESS)))) (EYECON.DRAW.PUPIL (LAMBDA (PM WINDOW DX DY MASK?) (* \; "Edited 9-Oct-88 16:22 by jrb:") (* |;;| "Draw the pupil") (LET* ((EYECON.PUPIL.OFFSET (IQUOTIENT EYECON.PUPIL.SIZE 2)) (BDX (IDIFFERENCE DX EYECON.PUPIL.OFFSET)) (BDY (IDIFFERENCE DY EYECON.PUPIL.OFFSET))) (|if| MASK? |then| (BITBLT EYECON.PUPIL NIL NIL PM) (BITBLT EYECON.MASK BDX BDY PM 0 0 EYECON.PUPIL.SIZE EYECON.PUPIL.SIZE 'INPUT 'ERASE) (BITBLT PM NIL NIL WINDOW BDX BDY NIL NIL 'INPUT 'PAINT) |else| (BITBLT PM NIL NIL WINDOW BDX BDY NIL NIL 'INPUT 'INVERT))))) (EYECON.FIND.POINT (LAMBDA (DX DY) (* \; "Edited 24-Oct-88 21:13 by jrb:") (SETQ DX (IABS DX)) (SETQ DY (IABS DY)) (* \; "Edited 24-Oct-88 20:34 by jrb:") (LET ((SLOPE (IF (EQ DX 0) THEN (CAR EYECON.SLOPE.LIST) ELSE (IQUOTIENT (LSH DY 8) DX)))) (FOR S IN EYECON.SLOPE.LIST AS P IN EYECON.CONTROL.POINTS WHEN (ILEQ S SLOPE) DO (RETURN P))))) (EYECON.ICON (LAMBDA (EW OLDICON) (* \; "Edited 8-Oct-88 21:37 by jrb:") (LET ((EP (WINDOWPROP EW 'PROCESS))) (IF EP THEN (DEL.PROCESS EP) (WINDOWPROP EW 'PROCESS NIL)) (OR OLDICON (ICONW EYECON.ICON EYECON.ICON.MASK))))) (EYECON.OPEN (LAMBDA (LEFT BOTTOM) (* \; "Edited 8-Oct-88 23:01 by jrb:") (LET ((EW (CREATEW (|create| REGION WIDTH _ (BITMAPWIDTH EYECON.OPEN) HEIGHT _ (BITMAPHEIGHT EYECON.OPEN) LEFT _ (OR LEFT EYECON.LEFT) BOTTOM _ (OR BOTTOM EYECON.BOTTOM)) NIL 4))) (OPENW EW) (WINDOWPROP EW 'CLOSEFN 'EYECON.DIE) (WINDOWPROP EW 'RESHAPEFN 'DON\'T) (WINDOWPROP EW 'ICONFN 'EYECON.ICON) (WINDOWPROP EW 'EXPANDFN 'EYECON) (EYECON EW)))) (EYECON.TRACK (LAMBDA (EW) (* \; "Edited 24-Oct-88 21:02 by jrb:") (* |;;| "Bind lots of variables") (LET (EWR (ELX 0) (ERX 0) (EY 0) OLDLX OLDLY OLDLB (LEFTLID T) (RIGHTLID T) (ELPX 0) (ERPX 0) (ELPY 0) (ERPY 0) (ELPMASK (BITMAPCOPY EYECON.PUPIL)) (ERPMASK (BITMAPCOPY EYECON.PUPIL)) (OLPX 0) (ORPX 0) (OLPY 0) (ORPY 0) ELDX ERDX EDY CP) (WHILE T DO (BLOCK) (* |;;| "Refresh our knowledge of where the window is if it's been moved (relying on the hack that the region windowprop gets changed when windows get moved)") (IF (NOT (EQ EWR (WINDOWPROP EW 'REGION))) THEN (SETQ EWR (WINDOWPROP EW 'REGION)) (SETQ ERX (SETQ ELX (FETCH (REGION LEFT) OF EWR))) (SETQ EY (IPLUS (FETCH (REGION BOTTOM) OF EWR) EYECON.HEIGHT.OFFSET)) (ADD ELX EYECON.LEFT.CENTER) (ADD ERX EYECON.RIGHT.CENTER) (* |;;|  "Clobber OLDLX so we'll fix the pupils for sure after moving the window") (SETQ OLDLX NIL)) (* |;;| "See if mouse has changed and mung eyes") (IF (OR (NOT (EQ OLDLX LASTMOUSEX)) (NOT (EQ OLDLY LASTMOUSEY)) (NOT (EQ OLDLB LASTMOUSEBUTTONS))) THEN (SETQ OLDLX LASTMOUSEX) (SETQ OLDLY LASTMOUSEY) (SETQ OLDLB LASTMOUSEBUTTONS) (* |;;|  "first check the button state, as we can skip some stuff if eyes are closed") (|if| (NOT (EQ 0 (LOGAND 1 OLDLB))) |then| (* \; "Both are closed") (|if| LEFTLID |then| (* \; "Closing left now") (EYECON.WINK EYECON.CLOSED 0 EW) (SETQ LEFTLID NIL)) (|if| RIGHTLID |then| (* \; "Closing right now") (EYECON.WINK EYECON.CLOSED EYECON.RIGHT.WINK EW) (SETQ RIGHTLID NIL)) |else| (|if| (EQ 0 (LOGAND 4 OLDLB)) |then| (* \; "Left is open") (|if| (NOT LEFTLID) |then| (* \; "Opening it now") (EYECON.WINK EYECON.OPEN 0 EW) (SETQ LEFTLID 'NOW)) |else| (|if| LEFTLID |then| (* \; "Closing left now") (EYECON.WINK EYECON.CLOSED 0 EW) (SETQ LEFTLID NIL))) (|if| (EQ 0 (LOGAND 2 OLDLB)) |then| (* \; "Right is open") (|if| (NOT RIGHTLID) |then| (* \; "Opening it now") (EYECON.WINK EYECON.OPEN EYECON.RIGHT.WINK EW) (SETQ RIGHTLID 'NOW)) |else| (|if| RIGHTLID |then| (* \; "Closing right now") (EYECON.WINK EYECON.CLOSED EYECON.RIGHT.WINK EW) (SETQ RIGHTLID NIL)))) (SETQ ELDX (IDIFFERENCE OLDLX ELX)) (SETQ ERDX (IDIFFERENCE OLDLX ERX)) (SETQ EDY (IDIFFERENCE OLDLY EY)) (* |;;| "See if we need to scale and do so") (IF (OR (IGREATERP (IABS OLDLX) 255) (IGREATERP (IABS OLDLY) 255)) THEN (SETQ ELDX (RSH ELDX EYECON.SCALE.FACTOR)) (SETQ ERDX (RSH ERDX EYECON.SCALE.FACTOR)) (SETQ EDY (RSH EDY EYECON.SCALE.FACTOR))) (* |;;| "find out where on the magic circle the pupils need to land") (|if| LEFTLID |then| (SETQ CP (EYECON.FIND.POINT ELDX EDY)) (IF (ILESSP ELDX 0) THEN (SETQ ELPX (IMINUS (CAR CP))) ELSE (SETQ ELPX (CAR CP))) (IF (ILESSP EDY 0) THEN (SETQ ELPY (IMINUS (CDR CP))) ELSE (SETQ ELPY (CDR CP))) (IF (OR (EQ LEFTLID 'NOW) (NOT (EQ ELPX OLPX)) (NOT (EQ ELPY OLPY))) THEN (|if| (EQ LEFTLID 'NOW) |then| (SETQ LEFTLID T) |else| (EYECON.DRAW.PUPIL ELPMASK EW (IPLUS EYECON.LEFT.CENTER OLPX ) (IPLUS EYECON.HEIGHT.OFFSET OLPY))) (SETQ OLPX ELPX) (SETQ OLPY ELPY) (EYECON.DRAW.PUPIL ELPMASK EW (IPLUS EYECON.LEFT.CENTER ELPX) (IPLUS EYECON.HEIGHT.OFFSET ELPY) T))) (|if| RIGHTLID |then| (SETQ CP (EYECON.FIND.POINT ERDX EDY)) (IF (ILESSP ERDX 0) THEN (SETQ ERPX (IMINUS (CAR CP))) ELSE (SETQ ERPX (CAR CP))) (IF (ILESSP EDY 0) THEN (SETQ ERPY (IMINUS (CDR CP))) ELSE (SETQ ERPY (CDR CP))) (IF (OR (EQ RIGHTLID 'NOW) (NOT (EQ ORPX ERPX)) (NOT (EQ ORPY ERPY))) THEN (|if| (EQ RIGHTLID 'NOW) |then| (SETQ RIGHTLID T) |else| (EYECON.DRAW.PUPIL ERPMASK EW (IPLUS EYECON.RIGHT.CENTER ORPX) (IPLUS EYECON.HEIGHT.OFFSET ORPY))) (SETQ ORPX ERPX) (SETQ ORPY ERPY) (EYECON.DRAW.PUPIL ERPMASK EW (IPLUS EYECON.RIGHT.CENTER ERPX) (IPLUS EYECON.HEIGHT.OFFSET ERPY) T)))))))) (EYECON.WINK (LAMBDA (SOURCE LEFT WINDOW) (* \; "Edited 8-Oct-88 23:23 by jrb:") (BITBLT SOURCE LEFT 0 WINDOW LEFT 0 EYECON.WINK.WIDTH (BITMAPHEIGHT EYECON.OPEN)))) ) (* |;;| "Check screen size and compute appropriate scale factor") (* |;;| "All computations are scaled to keep them in smallp range") (RPAQQ EYECON.SCALE.FACTOR 3) (RPAQQ EYECON.CONTROL.POINTS ((0 . 4) (1 . 4) (2 . 4) (3 . 4) (4 . 3) (5 . 3) (6 . 2) (7 . 1) (7 . 0))) (BIND (MINSF _ 256) (RANGE _ (MAX SCREENHEIGHT SCREENWIDTH)) FIRST (SETQ EYECON.SCALE.FACTOR 0) WHILE (ILESSP MINSF RANGE) DO (ADD EYECON.SCALE.FACTOR 1) (SETQ MINSF (LLSH MINSF 1))) (SETQ EYECON.SLOPE.LIST (FOR P IN (CDR EYECON.CONTROL.POINTS) COLLECT (IQUOTIENT (LSH (CDR P) 8) (CAR P)))) (PUSH EYECON.SLOPE.LIST (IPLUS (CAR EYECON.SLOPE.LIST) 1)) (PUTPROPS EYECON COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (7709 20550 (EYECON 7719 . 8110) (EYECON.DIE 8112 . 8277) (EYECON.DRAW.PUPIL 8279 . 9022 ) (EYECON.FIND.POINT 9024 . 9602) (EYECON.ICON 9604 . 9936) (EYECON.OPEN 9938 . 10615) (EYECON.TRACK 10617 . 20337) (EYECON.WINK 20339 . 20548))))) STOP \ No newline at end of file diff --git a/lispusers/EquationEditorPrgmersGuide.TEDIT b/lispusers/EquationEditorPrgmersGuide.TEDIT new file mode 100644 index 00000000..837abf11 Binary files /dev/null and b/lispusers/EquationEditorPrgmersGuide.TEDIT differ diff --git a/lispusers/ExtendedVmem-Lisp.run b/lispusers/ExtendedVmem-Lisp.run new file mode 100644 index 00000000..62029f18 Binary files /dev/null and b/lispusers/ExtendedVmem-Lisp.run differ diff --git a/lispusers/ExtendedVmem-Lisp.syms b/lispusers/ExtendedVmem-Lisp.syms new file mode 100644 index 00000000..d5a18229 Binary files /dev/null and b/lispusers/ExtendedVmem-Lisp.syms differ diff --git a/lispusers/FASTEDITBM b/lispusers/FASTEDITBM new file mode 100644 index 00000000..3724e793 --- /dev/null +++ b/lispusers/FASTEDITBM @@ -0,0 +1 @@ +(FILECREATED "16-Nov-87 17:15:41" {ERINYES}KOTO>FASTEDITBM.;3 68144 changes to: (FNS EXPANDBITMAP) (VARS FASTEDITBMCOMS) previous date: " 4-Sep-87 15:58:23" {ERINYES}KOTO>FASTEDITBM.;2) (* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT FASTEDITBMCOMS) (RPAQQ FASTEDITBMCOMS ((DECLARE: DONTCOPY (MACROS UPDATE/BM/DISPLAY)) (P (SETQ EDITBMMENU NIL)) (FNS GRID) (FNS EDITBM EDITBMCLOSEFN TILEAREA EDITBMBUTTONFN EDITBMSCROLLFN \EDITBM/PUTUP/DISPLAY EDITBMRESHAPEFN EDITBMREPAINTFN.NEW EDITBMREPAINTFN RESETGRID.NEW) (FNS SCALEBM BLTPATTERN BLTPATTERN.REPLACEDISPLAY) (FNS EXPANDBITMAP EXPANDBM))) (DECLARE: DONTCOPY (DECLARE: EVAL@COMPILE [PUTPROPS UPDATE/BM/DISPLAY MACRO ((BM W) (BITBLT BM (WINDOWPROP W (QUOTE DXOFFSET)) (WINDOWPROP W (QUOTE DYOFFSET)) W 0 (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM)) (WINDOWPROP W (QUOTE BMDISPLAYWIDTH)) 1000 NIL (QUOTE REPLACE] ) ) (SETQ EDITBMMENU NIL) (DEFINEQ (GRID [LAMBDA (GRIDSPEC WIDTH HEIGHT BORDER DS GRIDSHADE) (* N.H.Briggs " 4-Sep-87 15:39") (* ; "draws a grid") (PROG ((X0 (fetch (REGION LEFT) of GRIDSPEC)) (Y0 (fetch (REGION BOTTOM) of GRIDSPEC)) (SQWIDTH (fetch (REGION WIDTH) of GRIDSPEC)) (SQHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC)) (GRIDSHADE (COND ((TEXTUREP GRIDSHADE)) (T BLACKSHADE))) LINELENGTH TWICEBORDER MAXIMUMCOLOR TOTALHEIGHT GRIDBM TEMPBM) (SETQ TOTALHEIGHT (ITIMES HEIGHT SQHEIGHT)) (COND ((OR (ZEROP BORDER) (NULL BORDER)) (* ; "don't draw anything.") (RETURN)) [(NUMBERP BORDER) (SETQ TWICEBORDER (ITIMES BORDER 2)) (PROGN (* ;;   "draw vertical lines use BITBLT so that we don't have to correct for the width of the line since line drawing will put the coordinate in the middle." ) (BLTSHADE GRIDSHADE DS X0 Y0 BORDER TOTALHEIGHT (QUOTE REPLACE)) (for X from (IDIFFERENCE (IPLUS X0 SQWIDTH) BORDER) to (IDIFFERENCE (IPLUS X0 (ITIMES (SUB1 WIDTH) SQWIDTH)) BORDER) by SQWIDTH do (BLTSHADE GRIDSHADE DS X Y0 TWICEBORDER TOTALHEIGHT (QUOTE REPLACE))) (BLTSHADE GRIDSHADE DS (IDIFFERENCE (IPLUS X0 (ITIMES WIDTH SQWIDTH)) BORDER) Y0 BORDER TOTALHEIGHT (QUOTE REPLACE))) (PROGN (* ; "draw horizontal lines") (BLTSHADE GRIDSHADE DS X0 Y0 (SETQ LINELENGTH (ITIMES WIDTH SQWIDTH)) BORDER (QUOTE REPLACE)) (for Y from (IDIFFERENCE (IPLUS Y0 SQHEIGHT) BORDER) to (IDIFFERENCE (IPLUS Y0 (ITIMES (SUB1 HEIGHT) SQHEIGHT)) BORDER) by SQHEIGHT do (BLTSHADE GRIDSHADE DS X0 Y LINELENGTH TWICEBORDER (QUOTE REPLACE))) (BLTSHADE GRIDSHADE DS X0 (IDIFFERENCE (IPLUS Y0 TOTALHEIGHT) BORDER) LINELENGTH BORDER (QUOTE REPLACE] [(EQ BORDER (QUOTE POINT)) (* ; "put a point in the lower left corner of each box") (if (WINDOWP DS) then (SETQ TEMPBM (WINDOWPROP DS (QUOTE TEMPBM))) (SETQ GRIDBM (WINDOWPROP DS (QUOTE GRIDBM))) (if (NOT GRIDBM) then (SETQ GRIDBM (BITMAPCREATE SQWIDTH SQHEIGHT)) (WINDOWPROP DS (QUOTE GRIDBM) GRIDBM)) (BLTSHADE WHITESHADE GRIDBM 0 0) (* ; "Clear temporary bitmap.") (BLTSHADE BLACKSHADE GRIDBM 0 0 1 1 (QUOTE REPLACE)) (* ; "Put spot down.") (* ; "Fill up temporary bitmap.") (BLTPATTERN GRIDBM 0 0 SQWIDTH SQHEIGHT DS X0 Y0 (ITIMES WIDTH SQWIDTH) (ITIMES HEIGHT SQHEIGHT) (QUOTE PAINT) TEMPBM) else [SETQ MAXIMUMCOLOR (SUB1 (EXPT 2 (BITSPERPIXEL (DSPDESTINATION NIL DS] (* ;; "Crufty slow original code.") (for X from X0 to (IPLUS X0 (ITIMES WIDTH SQWIDTH)) by SQWIDTH do (for Y from Y0 to (IPLUS Y0 TOTALHEIGHT) by SQHEIGHT do (BITMAPBIT DS X Y MAXIMUMCOLOR] (T (\ILLEGAL.ARG BORDER]) ) (DEFINEQ (EDITBM [LAMBDA (BMSPEC) (* N.H.Briggs " 4-Sep-87 15:39") (* ;;; "A simple bitmap editor.") (* ;;   "The edit part of the display is from 0 to MAXGRIDWIDTH in width and from 0 to MAXGRIDHEIGHT in height. The commands and display area for the bitmap being edited are above the edit region." ) (DECLARE (GLOBALVARS SCREENWIDTH SCREENHEIGHT)) (PROG (BMW BMWINTERIOR BMWWIDTH BMWHEIGHT WIDTH HEIGHT BM CR ORIGBM GRIDSQUARE BPP ORIGBPP ORIGWIDTH) (* ;   "set ORIGBM to the input bitmap if any and BM to a copy of it for editting.") [COND ((OR (EQ BMSPEC CursorBitMap) (AND (EQ BMSPEC (QUOTE CursorBitMap)) (SETQ BMSPEC CursorBitMap))) (* ;   "editing cursor, save old value and make changes to the original.") (SETQ ORIGBM (BITMAPCOPY CursorBitMap)) (SETQ BM CursorBitMap)) [(BITMAPP BMSPEC) (SETQ BM (BITMAPCOPY (SETQ ORIGBM BMSPEC] [(LITATOM BMSPEC) (COND ([BITMAPP (SETQ ORIGBM (EVALV BMSPEC (QUOTE EDITBM] (* ; "use value.") (SETQ BM (BITMAPCOPY ORIGBM))) (T (SETQ ORIGBM NIL) (SETQ BM (\READBMDIMENSIONS] ((REGIONP BMSPEC) (* ;   "if BMSPEC is a region, treat it as a region of the screen.") [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC) (fetch (REGION HEIGHT) of BMSPEC) (BITSPERPIXEL (SCREENBITMAP] (* ; "note that bm has initial bits in it.") (SETQ ORIGBM BMSPEC) (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of BMSPEC) (fetch (REGION BOTTOM) of BMSPEC) BM 0 0 NIL NIL (QUOTE INPUT) (QUOTE REPLACE))) ((WINDOWP BMSPEC) (SETQ ORIGBM BMSPEC) (* ;;   "FS: Seems too big below, why not ClipRegion's Width & Height? That's all that's used...") (SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC (QUOTE WIDTH)) (WINDOWPROP BMSPEC (QUOTE HEIGHT)) (BITSPERPIXEL BMSPEC))) (* ; "open the window and bring it to the top.") (TOTOPW BMSPEC) (SETQ CR (DSPCLIPPINGREGION NIL BMSPEC)) (BITBLT BMSPEC (fetch (REGION LEFT) of CR) (fetch (REGION BOTTOM) of CR) BM 0 0 (fetch (REGION WIDTH) of CR) (fetch (REGION HEIGHT) of CR))) (T (* ; "otherwise create a bitmap") (SETQ BM (\READBMDIMENSIONS] (if (OR (EQ (BITMAPHEIGHT BM) 0) (EQ (BITMAPWIDTH BM) 0)) then (ERROR "Can't edit a bitmap with no bits in it." BMSPEC)) (SETQ BPP (BITSPERPIXEL (SCREENBITMAP))) (SETQ ORIGBPP (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)) [COND ((NOT (EQ BPP ORIGBPP)) (* ;;   "save the actual number of bits per pixel and set it to BPP in the bitmap being edited so that it can be BITBLT ed on the screen." ) (SETQ ORIGWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) (replace (BITMAP BITMAPBITSPERPIXEL) of BM with BPP) (SETQ WIDTH (IQUOTIENT (ITIMES ORIGBPP ORIGWIDTH) BPP)) (replace (BITMAP BITMAPWIDTH) of BM with WIDTH)) (T (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BM] (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) (* ;;   "Calculate a default window size. Start by calculating the grid size from the bitmap size.") (SETQ GRIDSQUARE (IMAX (IMIN (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES SCREENWIDTH 2) 3) GRIDTHICKNESS) WIDTH) (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES SCREENHEIGHT 2) 3) (ITIMES GRIDTHICKNESS 2)) (ADD1 HEIGHT)) NORMALGRIDSQUARE) MINGRIDSQUARE)) (SETQ BMWWIDTH (IMIN (IPLUS (ITIMES GRIDSQUARE WIDTH) GRIDTHICKNESS) (IQUOTIENT (ITIMES SCREENWIDTH 2) 3))) (SETQ BMWHEIGHT (IMIN (IPLUS (ITIMES HEIGHT (ADD1 GRIDSQUARE)) (ITIMES GRIDTHICKNESS 2) 1) (IQUOTIENT (ITIMES SCREENHEIGHT 2) 3))) (SETQ BMW (CREATEW (GETBOXREGION (WIDTHIFWINDOW BMWWIDTH) (HEIGHTIFWINDOW BMWHEIGHT T) NIL NIL NIL "Indicate the position for the Bitmap Edit window.") "Bitmap Editor")) (WINDOWPROP BMW (QUOTE BM) BM) (WINDOWPROP BMW (QUOTE SCROLLFN) (FUNCTION EDITBMSCROLLFN)) (WINDOWPROP BMW (QUOTE RESHAPEFN) (FUNCTION EDITBMRESHAPEFN)) (WINDOWPROP BMW (QUOTE REPAINTFN) (FUNCTION EDITBMREPAINTFN)) (WINDOWPROP BMW (QUOTE BUTTONEVENTFN) (FUNCTION EDITBMBUTTONFN)) (WINDOWPROP BMW (QUOTE CLOSEFN) (FUNCTION EDITBMCLOSEFN)) (WINDOWPROP BMW (QUOTE XOFFSET) 0) (WINDOWPROP BMW (QUOTE YOFFSET) 0) (WINDOWPROP BMW (QUOTE DXOFFSET) 0) (WINDOWPROP BMW (QUOTE DYOFFSET) 0) (WINDOWPROP BMW (QUOTE ORIGINALBITMAP) ORIGBM) (WINDOWPROP BMW (QUOTE FINISHEDFLG) NIL) (WINDOWPROP BMW (QUOTE COLOR) (SUB1 (EXPT 2 BPP))) (WINDOWPROP BMW (QUOTE GRIDON) T) (* ;  "call reshapefn to initialize the display and values") (EDITBMRESHAPEFN BMW NIL NIL NIL (NOT ORIGBM)) (* ;   "start a mouse process in case this process is the mouse process.") (SPAWN.MOUSE) (while (NOT (WINDOWPROP BMW (QUOTE FINISHEDFLG))) do (DISMISS 500)) (* ; "remove the closefn before closing the window.") (WINDOWPROP BMW (QUOTE CLOSEFN) NIL) (CLOSEW BMW) (COND ((NOT (EQ ORIGBPP BPP)) (replace (BITMAP BITMAPBITSPERPIXEL) of BM with ORIGBPP) (replace (BITMAP BITMAPWIDTH) of BM with ORIGWIDTH))) (RETURN (COND ((EQ T (WINDOWPROP BMW (QUOTE FINISHEDFLG))) (* ;   "editor exited via ok, stuff contents into original bitmap.") (COND ((EQ BMSPEC CursorBitMap) (* ; "editting happened in original, leave it alone.") CursorBitMap) ((REGIONP ORIGBM) (* ; "put it back into the screen.") (BITBLT BM 0 0 (SCREENBITMAP) (fetch (REGION LEFT) of ORIGBM) (fetch (REGION BOTTOM) of ORIGBM) (fetch (REGION WIDTH) of ORIGBM) (fetch (REGION HEIGHT) of ORIGBM) (QUOTE INPUT) (QUOTE REPLACE)) BM) ((WINDOWP ORIGBM) (* ; "put it back into the window") (BITBLT BM 0 0 ORIGBM (fetch (REGION LEFT) of CR) (fetch (REGION BOTTOM) of CR) (fetch (REGION WIDTH) of CR) (fetch (REGION HEIGHT) of CR) (QUOTE INPUT) (QUOTE REPLACE)) BM) (ORIGBM (BITBLT BM 0 0 ORIGBM 0 0 WIDTH HEIGHT) [COND ((AND BMSPEC (LITATOM BMSPEC)) (* ;   "if spec was an atom without a bm value, set it. in the environment above EDITBM.") (MARKASCHANGED BMSPEC (QUOTE VARS)) (STKEVAL (QUOTE EDITBM) (LIST (QUOTE SETQQ) BMSPEC BM] ORIGBM) (T BM))) (T (* ;  "error exit, if cursor return it to original value.") (COND ((EQ BMSPEC CursorBitMap) (BITBLT ORIGBM NIL NIL CursorBitMap))) (ERROR!]) (EDITBMCLOSEFN [LAMBDA (BMW) (* ; "Edited 27-Aug-87 21:26 by FS") (* ;;   "the close function for a bitmap edit window. For now do what a STOP would have done.") (* ;;   "FS: Assuming this window won't be reused, flush the temporary bm.") (WINDOWPROP BMW (QUOTE TEMPBM) NIL) (WINDOWPROP BMW (QUOTE GRIDBM) NIL) (WINDOWPROP BMW (QUOTE FINISHEDFLG) (QUOTE KILL]) (TILEAREA [LAMBDA (LFT BTM WDTH HGHT SRCBM WIN) (* ; "Edited 27-Aug-87 21:20 by FS") (* ;;   "lays tiles out in an area of a window. This function only provided for backwards compatibility.") (BLTPATTERN.REPLACEDISPLAY SRCBM 0 0 (BITMAPWIDTH SRCBM) (BITMAPHEIGHT SRCBM) WIN LFT BTM WDTH HGHT]) (EDITBMBUTTONFN [LAMBDA (W) (* N.H.Briggs " 4-Sep-87 15:30") (* ;; "inner function of bitmap editor.") (DECLARE (GLOBALVARS \CURRENTCURSOR)) (PROG (GRIDX0 GRIDY0 BITMAPWIDTH BITMAPHEIGHT NEWGRIDSIZE PAINTW ORIGBM GRIDSPEC GRIDINTERIOR BM BITSWIDE BITSHIGH WREGION XOFFSET YOFFSET DXOFFSET DYOFFSET DISPLAYREGION EXTENT BITSPERPIXEL CURSORBM) (SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC))) (SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR))) (SETQ BM (WINDOWPROP W (QUOTE BM))) (SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE))) (SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH))) (SETQ WREGION (WINDOWPROP W (QUOTE REGION))) (SETQ XOFFSET (WINDOWPROP W (QUOTE XOFFSET))) (SETQ YOFFSET (WINDOWPROP W (QUOTE YOFFSET))) (SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET))) (SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET))) (SETQ DISPLAYREGION (WINDOWPROP W (QUOTE DISPLAYREGION))) (SETQ EXTENT (WINDOWPROP W (QUOTE EXTENT))) (SETQ GRIDX0 (fetch (REGION LEFT) of GRIDSPEC)) (SETQ GRIDY0 (fetch (REGION BOTTOM) of GRIDSPEC)) (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)) (SETQ COLOR (WINDOWPROP W (QUOTE COLOR))) (* ;;  "mark the region of the bitmap that is being editted." ) (COND ((INSIDE? GRIDINTERIOR (LASTMOUSEX W) (LASTMOUSEY W)) (* ;; "if cursor is inside, shade it.") (\SHADEBITS BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH COLOR)) ((INSIDE? DISPLAYREGION (LASTMOUSEX W) (LASTMOUSEY W)) (* ;;  "Run the menu foe re-windowing into the whole bitmap") (SELECTQ [MENU (COND ((type? MENU EDITBMWINDOWMENU) EDITBMWINDOWMENU) ((SETQ EDITBMWINDOWMENU (create MENU ITEMS _ (QUOTE ((Move (QUOTE Move) "Selects a different part of the bitmap to edit."))) CENTERFLG _ T] (Move (* ;  "move the editing window's location on the bitmap.") (PROG (POS) [SETQ POS (GETBOXPOSITION BITSWIDE BITSHIGH [IPLUS 4 (fetch (REGION LEFT) of WREGION) (DIFFERENCE XOFFSET (WINDOWPROP W (QUOTE DXOFFSET] (IPLUS (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM)) (DIFFERENCE YOFFSET (WINDOWPROP W (QUOTE DYOFFSET)) ) 4 (fetch (REGION BOTTOM) of WREGION] [WINDOWPROP W (QUOTE XOFFSET) (SETQ XOFFSET (IMIN (IDIFFERENCE BITMAPWIDTH BITSWIDE) (IMAX [IPLUS (WINDOWPROP W (QUOTE DXOFFSET)) (DIFFERENCE (fetch (POSITION XCOORD) of POS) (IPLUS 4 (fetch (REGION LEFT) of WREGION] 0] [WINDOWPROP W (QUOTE YOFFSET) (SETQ YOFFSET (IMAX 0 (IMIN (DIFFERENCE BITMAPHEIGHT BITSHIGH) (DIFFERENCE (IPLUS (WINDOWPROP W (QUOTE DYOFFSET)) (DIFFERENCE (fetch (POSITION YCOORD) of POS) (IPLUS (fetch (REGION BOTTOM) of WREGION) 4))) (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM] (replace (REGION LEFT) of EXTENT with (IMINUS (QUOTIENT (TIMES XOFFSET (fetch (REGION WIDTH) of EXTENT)) BITMAPWIDTH))) (replace (REGION BOTTOM) of EXTENT with (IMINUS (QUOTIENT (TIMES YOFFSET (fetch (REGION HEIGHT) of EXTENT)) BITMAPHEIGHT))) [COND ([OR (ILESSP XOFFSET DXOFFSET) (ILESSP YOFFSET DYOFFSET) [IGREATERP (IPLUS XOFFSET BITSWIDE) (IPLUS DXOFFSET (WINDOWPROP W (QUOTE BMDISPLAYWIDTH] (IGREATERP (IPLUS YOFFSET BITSHIGH) (IPLUS DYOFFSET (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT] (* ;;   "Adjust the display region left lower corner so the selected region is near the center.") [WINDOWPROP W (QUOTE DXOFFSET) (SETQ DXOFFSET (IMAX 0 (IMIN (DIFFERENCE (fetch (BITMAP BITMAPWIDTH) of BM) (WINDOWPROP W (QUOTE BMDISPLAYWIDTH))) (DIFFERENCE (IPLUS XOFFSET (LRSH BITSWIDE 1)) (LRSH (WINDOWPROP W (QUOTE BMDISPLAYWIDTH) ) 1] (WINDOWPROP W (QUOTE DYOFFSET) (SETQ DYOFFSET (IMAX 0 (IMIN (DIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of BM) (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT))) (DIFFERENCE (IPLUS YOFFSET (LRSH BITSHIGH 1)) (LRSH (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT)) 1] (* DSPFILL GRIDINTERIOR WHITESHADE  (QUOTE REPLACE) W) (UPDATE/BM/DISPLAY BM W) (* ;;   "FS: More useless code: (COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))") (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T))) NIL)) ((LASTMOUSESTATE LEFT) (UPDATE/BM/DISPLAY/SELECTED/REGION W) (SETQ CURSORBM (BITMAPCREATE 16 16 (BITSPERPIXEL BM))) (BITBLT BM NIL NIL CURSORBM) [RESETFORM [CURSOR (CURSORCREATE CURSORBM (fetch (CURSOR CURSORHOTSPOTX) of (CURSOR)) (fetch (CURSOR CURSORHOTSPOTY) of (CURSOR] (until (MOUSESTATE (NOT LEFT] (UPDATE/BM/DISPLAY/SELECTED/REGION W)) (T (* ;;   "the region being editted is inverted while the menu is active. Each command must make sure that it is recomplemented." ) (UPDATE/BM/DISPLAY/SELECTED/REGION W) (SELECTQ [MENU (COND ((type? MENU EDITBMMENU) EDITBMMENU) (T (SETQ EDITBMMENU (create MENU ITEMS _ [APPEND (COND [(COLORDISPLAYP) (QUOTE ((Color (QUOTE Color) "Choose color to set bits with"] (T NIL)) (QUOTE ((Paint (QUOTE Paint) "Calls the window PAINT command on the bitmap.") (ShowAsTile (QUOTE ShowAsTile) "tiles the upper part of the edit window with the bitmap.") (Grid% On/Off (QUOTE GridOnOff) "Grid On/Off Switch") (GridSize_ (QUOTE GridSize_) "Allows setting of the size of a bit in the edit area.") (Reset (QUOTE Reset) "Sets the bitmap back to the state at the start of this edit session.") (Clear (QUOTE Clear) "Sets the entire bitmap to 0") (Cursor_ (QUOTE Cursor_) "Puts the bitmap into the cursor and exits the editor.") (OK (QUOTE OK) "Leaves the edit session.") (Abort (QUOTE Abort) "Restores the bitmap to its original values and leaves the editor."] CENTERFLG _ T] (OK (WINDOWPROP W (QUOTE FINISHEDFLG) T)) (Abort (WINDOWPROP W (QUOTE FINISHEDFLG) (QUOTE KILL))) [Reset (* ;;   "allow the user to choose between everything or just visible part. This also give the user a chance to change their mind." ) (COND ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH "RESET how much?") (VISIBLE [COND [(SETQ ORIGBM (WINDOWPROP W (QUOTE ORIGINALBITMAP))) (COND ((REGIONP ORIGBM) (BITBLT (SCREENBITMAP) (IPLUS XOFFSET (fetch (REGION LEFT) of ORIGBM)) (IPLUS YOFFSET (fetch (REGION BOTTOM) of ORIGBM)) BM XOFFSET YOFFSET BITSWIDE BITSHIGH (QUOTE INPUT) (QUOTE REPLACE))) (T (BITBLT ORIGBM XOFFSET YOFFSET BM XOFFSET YOFFSET BITSWIDE BITSHIGH] (T (BLTSHADE WHITESHADE BM XOFFSET YOFFSET BITSWIDE BITSHIGH (QUOTE REPLACE] T) (WHOLE [COND [(SETQ ORIGBM (WINDOWPROP W (QUOTE ORIGINALBITMAP))) (COND ((REGIONP ORIGBM) (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of ORIGBM) (fetch (REGION BOTTOM) of ORIGBM) BM)) (T (BITBLT ORIGBM NIL NIL BM] (T (BLTSHADE WHITESHADE BM NIL NIL NIL NIL (QUOTE REPLACE] T) (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W) NIL)) (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH] [Clear (* ;;   "allow the user to choose between everything or just visible part. This also give the user a chance to change their mind." ) (COND ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH "CLEAR how much?") (VISIBLE (BLTSHADE WHITESHADE BM XOFFSET YOFFSET BITSWIDE BITSHIGH (QUOTE REPLACE)) T) (WHOLE (\CLEARBM BM) T) (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W) NIL)) (DSPFILL GRIDINTERIOR WHITESHADE (QUOTE REPLACE) W) (COND ((WINDOWPROP W (QUOTE GRIDON)) (GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT) W))) (UPDATE/BM/DISPLAY BM W] (GridOnOff (COND ((NOT (WINDOWPROP W (QUOTE GRIDON))) (* ; "Turn Grid On") (WINDOWPROP W (QUOTE GRIDON) T) (GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT) W) (* ;;   "FS: The update here was unnecessary. (UPDATE/BM/DISPLAY BM W)") NIL) (T (* ; "Turn off grid") (WINDOWPROP W (QUOTE GRIDON) NIL) (* DSPFILL (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (ADD1 (fetch (REGION WIDTH) of GRIDINTERIOR)) HEIGHT _  (ADD1 (fetch (REGION HEIGHT) of GRIDINTERIOR))) WHITESHADE (QUOTE REPLACE) W) (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T) (* ;;   "FS: The update here was unnecessary. (UPDATE/BM/DISPLAY BM W)") NIL))) [GridSize_ (* ;  "sets the grid square size and calls the reshapefn.") (COND ([SETQ NEWGRIDSIZE (NUMBERP (MENU (COND ((TYPENAMEP GRIDSIZEMENU (QUOTE MENU)) GRIDSIZEMENU) (T (SETQ GRIDSIZEMENU (create MENU ITEMS _ (QUOTE (3 4 5 6 7 8 12 16 20 24 28 32) ) MENUROWS _ 4] (WINDOWPROP W (QUOTE GRIDSQUARE) NEWGRIDSIZE) (EDITBMRESHAPEFN W] (ShowAsTile (* ;   "tiles the upper part of the window with the bitmap so the user can see what it would be as a shade.") (UPDATE/SHADE/DISPLAY BM W)) [Paint (* ;   "call the window paint command on the contents of the bitmap.") [SETQ PAINTW (CREATEW (create REGION LEFT _ (IQUOTIENT (DIFFERENCE SCREENWIDTH BITMAPWIDTH) 2) BOTTOM _ (IQUOTIENT (DIFFERENCE SCREENHEIGHT BITMAPHEIGHT) 2) WIDTH _ (WIDTHIFWINDOW BITMAPWIDTH) HEIGHT _ (HEIGHTIFWINDOW BITMAPHEIGHT NIL] (OPENW PAINTW) (BITBLT BM 0 0 PAINTW) (PAINTW PAINTW) (COND ((MENU (create MENU ITEMS _ (QUOTE ((YES T "Will put the newly painted bits back in the bitmap being editted.") (NO NIL "Will discard the painted bits, not changing the bitmap being editted."))) TITLE _ "Put change into bitmap?" CENTERFLG _ T)) (BITBLT PAINTW 0 0 BM) (CLOSEW PAINTW) (* ; "set PAINTW so that space can be reclaimed") (SETQ PAINTW) (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH] (Cursor_ (* ;   "Stuffs lower left part of image into the cursor and sets the hotspot.") (READHOTSPOT BM GRIDSPEC GRIDINTERIOR W) (WINDOWPROP W (QUOTE FINISHEDFLG) T)) (Color (WINDOWPROP W (QUOTE COLOR) (OR (MENU (COLORMENU BITSPERPIXEL)) COLOR))) (UPDATE/BM/DISPLAY/SELECTED/REGION W]) (EDITBMSCROLLFN [LAMBDA (W DX DY) (* ; "Edited 31-Aug-87 13:29 by FS") (* ; "Do scrolling for the bitmap editor.") (PROG (GRIDSPEC REG WHEIGHT WWIDTH (DXGRID 0) (DYGRID 0) EXTENT EXTENTWIDTH EXTENTHEIGHT GILEFT GIBOTTOM GIHEIGHT GWIDTH GHEIGHT GRIDINTERIOR EBMXLIMIT EBMYLIMIT EBMXOFFSET EBMYOFFSET BM BITMAPWIDTH BITMAPHEIGHT BITSWIDE BITSHIGH DXOFFSET DYOFFSET) (SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC))) (SETQ REG (WINDOWPROP W (QUOTE REGION))) (SETQ WHEIGHT (WINDOWPROP W (QUOTE HEIGHT))) (SETQ WWIDTH (WINDOWPROP W (QUOTE WIDTH))) (SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR))) (SETQ EBMXOFFSET (WINDOWPROP W (QUOTE XOFFSET))) (SETQ EBMYOFFSET (WINDOWPROP W (QUOTE YOFFSET))) (SETQ BM (WINDOWPROP W (QUOTE BM))) (SETQ BITMAPWIDTH (fetch BITMAPWIDTH of BM)) (SETQ BITMAPHEIGHT (fetch BITMAPHEIGHT of BM)) (SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE))) (SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH))) (SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET))) (SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET))) (SETQ EBMXLIMIT (IPLUS EBMXOFFSET BITSWIDE)) (SETQ EBMYLIMIT (IPLUS EBMYOFFSET BITSHIGH)) (COND (GRIDSPEC (SETQ GILEFT (fetch (REGION LEFT) of GRIDINTERIOR)) (SETQ GIBOTTOM (fetch (REGION BOTTOM) of GRIDINTERIOR)) (SETQ GIHEIGHT (fetch (REGION HEIGHT) of GRIDINTERIOR)) (SETQ GWIDTH (fetch (REGION WIDTH) of GRIDSPEC)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC)) (SETQ EXTENT (WINDOWPROP W (QUOTE EXTENT))) (SETQ EXTENTWIDTH (fetch (REGION WIDTH) of EXTENT)) (SETQ EXTENTHEIGHT (fetch (REGION HEIGHT) of EXTENT)) (* ; "Make a horizontal adjustment") (COND ((FLOATP DX) (* ; "Horizontal thumbing") [WINDOWPROP W (QUOTE XOFFSET) (SETQ EBMXOFFSET (FIX (TIMES (IDIFFERENCE BITMAPWIDTH BITSWIDE) DX] (replace (REGION LEFT) of EXTENT with (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) BITMAPWIDTH))) (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM SCREENWIDTH  SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR) (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)) ((ILESSP DX 0) (* ; "moving to the left.") (* ; "determine how many grid points to move.") (SETQ DXGRID (IMIN (GRIDXCOORD (IMINUS DX) GRIDSPEC) (IDIFFERENCE BITMAPWIDTH EBMXLIMIT))) (COND ((NOT (IGREATERP DXGRID 0)) (* ; "right edge is at the right margin") (RETURN))) (WINDOWPROP W (QUOTE XOFFSET) (SETQ EBMXOFFSET (IPLUS EBMXOFFSET DXGRID))) (* ; "update EXTENT bar") (replace (REGION LEFT) of EXTENT with (IMAX (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) BITMAPWIDTH)) (IMINUS EXTENTWIDTH))) (* ; "move image to the left.") (BITBLT W (IPLUS GILEFT (TIMES DXGRID GWIDTH)) GIBOTTOM W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL GRIDINTERIOR) (* ; "clear the newly exposed area.") (BLTSHADE WHITESHADE W (IPLUS GILEFT (TIMES (IDIFFERENCE BITSWIDE DXGRID) GWIDTH)) GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR) (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH (IDIFFERENCE BITSWIDE DXGRID) 0 W)) ((ILESSP 0 DX) (* ;  "determine how many grid point to the left to move.") (SETQ DXGRID (IMIN EBMXOFFSET (GRIDXCOORD DX GRIDSPEC))) (COND ((NOT (IGREATERP DXGRID 0)) (* ; "left edge is at the left margin") (RETURN))) (WINDOWPROP W (QUOTE XOFFSET) (SETQ EBMXOFFSET (IDIFFERENCE EBMXOFFSET DXGRID))) (* ; "update REGION bar") (replace (REGION LEFT) of EXTENT with (IMIN (IMINUS (IQUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) BITMAPWIDTH)) 0)) (* ; "move image to the right.") (BITBLT W GILEFT GIBOTTOM W (IPLUS GILEFT (TIMES DXGRID GWIDTH)) GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL GRIDINTERIOR) (* ; "clear the newly exposed area.") (BLTSHADE WHITESHADE W GILEFT GIBOTTOM (TIMES DXGRID GWIDTH) GIHEIGHT (QUOTE REPLACE)) (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH 0 0 W))) (* ; "Make a vertical adjustment") (COND ((FLOATP DY) (* ; "Vertical Thumbing") [WINDOWPROP W (QUOTE YOFFSET) (SETQ EBMYOFFSET (FIX (TIMES (IDIFFERENCE BITMAPHEIGHT BITSHIGH) (FDIFFERENCE 1.0 DY] (* ; "set EXTENT bar") (replace (REGION BOTTOM) of EXTENT with (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) BITMAPHEIGHT))) (* ; "Clear Window") (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM SCREENWIDTH  SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR) (* ; "Repaint the image using grid function") (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)) ((ILESSP DY 0) (* ; "determine how many squares to move down.") (SETQ DYGRID (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of BM) EBMYLIMIT) (GRIDYCOORD (IMIN GIHEIGHT (IMINUS DY)) GRIDSPEC))) (COND ((NOT (IGREATERP DYGRID 0)) (* ; "top edge is at the top margin") (RETURN))) (WINDOWPROP W (QUOTE YOFFSET) (SETQ EBMYOFFSET (IPLUS EBMYOFFSET DYGRID))) (replace (REGION BOTTOM) of EXTENT with (IMAX (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) BITMAPHEIGHT)) (IMINUS EXTENTHEIGHT))) (BITBLT W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT)) W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL GRIDINTERIOR) (* BLTSHADE WHITESHADE W GILEFT  (IPLUS GIBOTTOM (ITIMES (IDIFFERENCE BITSHIGH DYGRID)  GHEIGHT)) SCREENWIDTH SCREENHEIGHT  (QUOTE REPLACE) GRIDINTERIOR) (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 (IDIFFERENCE BITSHIGH DYGRID) W T)) ((ILESSP 0 DY) (* ;  "moving up; determine how may grid squares to move.") (SETQ DYGRID (IMIN EBMYOFFSET (GRIDYCOORD (IMIN GIHEIGHT DY) GRIDSPEC))) (COND ((NOT (IGREATERP DYGRID 0)) (* ; "bottom edge is at the bottom margin") (RETURN))) (WINDOWPROP W (QUOTE YOFFSET) (SETQ EBMYOFFSET (IDIFFERENCE EBMYOFFSET DYGRID))) (replace (REGION BOTTOM) of EXTENT with (IMIN (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) BITMAPHEIGHT)) 0)) (BITBLT W GILEFT GIBOTTOM W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT)) SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL GRIDINTERIOR) (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM  (fetch (REGION WIDTH) of GRIDINTERIOR)  (ITIMES DYGRID GHEIGHT) (QUOTE REPLACE)) (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 0 W T))) (* ;;   "This call to GRID is unnecessary as the grid dots get filled in earlier.") (* ;;   "(COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))") [COND ([OR (ILESSP EBMXOFFSET DXOFFSET) (ILESSP EBMYOFFSET DYOFFSET) [IGREATERP (IPLUS EBMXOFFSET BITSWIDE) (IPLUS DXOFFSET (WINDOWPROP W (QUOTE BMDISPLAYWIDTH] (IGREATERP (IPLUS EBMYOFFSET BITSHIGH) (IPLUS DYOFFSET (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT] (* ;   "Adjust the display region left lower corner so the selected region is near the center.") [WINDOWPROP W (QUOTE DXOFFSET) (SETQ DXOFFSET (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPWIDTH) of BM) (WINDOWPROP W (QUOTE BMDISPLAYWIDTH))) (IDIFFERENCE (IPLUS EBMXOFFSET (LRSH BITSWIDE 1)) (LRSH (WINDOWPROP W (QUOTE BMDISPLAYWIDTH)) 1] (WINDOWPROP W (QUOTE DYOFFSET) (SETQ DYOFFSET (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of BM) (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT))) (IDIFFERENCE (IPLUS EBMYOFFSET (LRSH BITSHIGH 1)) (LRSH (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT)) 1] (UPDATE/BM/DISPLAY BM W]) (\EDITBM/PUTUP/DISPLAY [LAMBDA (WINDOW BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH) (* ; "Edited 31-Aug-87 13:05 by FS") (* initializes the display for the bitmap editor.) (* DSPFILL GRIDINTERIOR WHITESHADE  (QUOTE REPLACE) WINDOW) (* COND ((WINDOWPROP WINDOW  (QUOTE GRIDON)) (GRID GRIDSPEC BITSWIDE BITSHIGH  (QUOTE POINT) WINDOW))) (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 WINDOW T) (UPDATE/BM/DISPLAY BM WINDOW]) (EDITBMRESHAPEFN [LAMBDA (BMEDITWINDOW OLDIMAGE OLDREGION OLDSCREENREGION ZEROBMFLG) (* ; "Edited 31-Aug-87 12:41 by FS") (* ;;   "allows the bitmap edit window to be reshaped to enlarge the editting area. This is also called to set up the image during initialization." ) (PROG (BMWINTERIORWIDTH BMWINTERIORHEIGHT EDITAREABITWIDTH EDITAREABITHEIGHT GRIDSQUARE GRIDINTERIOR BITMAPWIDTH BMDISPLAYWIDTH BMDISPLAYBOTTOM BMDISPLAYHEIGHT BITMAPHEIGHT (BM (WINDOWPROP BMEDITWINDOW (QUOTE BM))) MINCOMMANDAREAWIDTH EXTENTWIDTH EXTENTHEIGHT) (SETQ MINCOMMANDAREAWIDTH 30) (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) (SETQ BMWINTERIORWIDTH (WINDOWPROP BMEDITWINDOW (QUOTE WIDTH))) (* ;;   "leave room at the top for the full size display area. But not more than half of the window.") (SETQ BMWINTERIORHEIGHT (IMAX (IDIFFERENCE (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT)) (IPLUS BITMAPHEIGHT GRIDTHICKNESS)) (IQUOTIENT (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT) ) 2))) (* ;;   "if the user hasn't set it, determine the grid size as the largest size which fits the interior but not larger than NORMALGRIDSQUARE nor smaller than MINGRIDSQUARE. If GRIDSQUARE was specified, reset it to NIL so that if reshaped it will be recalculated." ) (SETQ GRIDSQUARE (OR (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSQUARE) NIL) (IMAX (IMIN (IQUOTIENT BMWINTERIORWIDTH BITMAPWIDTH) (IQUOTIENT BMWINTERIORHEIGHT BITMAPHEIGHT) NORMALGRIDSQUARE) MINGRIDSQUARE))) (* ;  "calculate how many bits will be displayed at once.") (SETQ EDITAREABITWIDTH (IMIN (IQUOTIENT BMWINTERIORWIDTH GRIDSQUARE) BITMAPWIDTH)) (WINDOWPROP BMEDITWINDOW (QUOTE BITSWIDE) EDITAREABITWIDTH) (SETQ EDITAREABITHEIGHT (IMIN (IQUOTIENT BMWINTERIORHEIGHT GRIDSQUARE) BITMAPHEIGHT)) (* ;   "calculate offset of display and command regions at the top of the window.") (WINDOWPROP BMEDITWINDOW (QUOTE BITSHIGH) EDITAREABITHEIGHT) (SETQ BMDISPLAYBOTTOM (IPLUS (ITIMES GRIDSQUARE EDITAREABITHEIGHT) GRIDTHICKNESS)) (SETQ BMDISPLAYWIDTH (IMIN BITMAPWIDTH (IDIFFERENCE BMWINTERIORWIDTH MINCOMMANDAREAWIDTH))) (* ;;   "put the offset --- the lower left coordinate --- in the same place unless the new shape allows more to be shown past the upper right corner." ) (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET) (IMIN (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET)) (IDIFFERENCE BITMAPWIDTH EDITAREABITWIDTH))) (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET) (IMIN (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET)) (IDIFFERENCE BITMAPHEIGHT EDITAREABITHEIGHT))) (* ; "Center edit square") (SETQ GRIDINTERIOR (create REGION LEFT _ (IQUOTIENT (IDIFFERENCE BMWINTERIORWIDTH (ITIMES EDITAREABITWIDTH GRIDSQUARE)) 2) BOTTOM _ (IQUOTIENT (IDIFFERENCE BMDISPLAYBOTTOM (ITIMES EDITAREABITHEIGHT GRIDSQUARE)) 2) WIDTH _ (ITIMES EDITAREABITWIDTH GRIDSQUARE) HEIGHT _ (ITIMES EDITAREABITHEIGHT GRIDSQUARE))) (WINDOWPROP BMEDITWINDOW (QUOTE GRIDINTERIOR) GRIDINTERIOR) (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYBOTTOM) BMDISPLAYBOTTOM) (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYWIDTH) BMDISPLAYWIDTH) (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYHEIGHT) (SETQ BMDISPLAYHEIGHT (IDIFFERENCE (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT)) BMDISPLAYBOTTOM))) (WINDOWPROP BMEDITWINDOW (QUOTE DISPLAYREGION) (create REGION LEFT _ 0 BOTTOM _ BMDISPLAYBOTTOM WIDTH _ BMDISPLAYWIDTH HEIGHT _ BMDISPLAYHEIGHT)) (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSPEC) (create REGION LEFT _ (fetch (REGION LEFT) of GRIDINTERIOR) BOTTOM _ (fetch (REGION BOTTOM) of GRIDINTERIOR) WIDTH _ GRIDSQUARE HEIGHT _ GRIDSQUARE)) (SETQ EXTENTHEIGHT (QUOTIENT (TIMES BITMAPHEIGHT (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT))) EDITAREABITHEIGHT)) [SETQ EXTENTWIDTH (IDIFFERENCE (QUOTIENT (TIMES BITMAPWIDTH BMWINTERIORWIDTH) EDITAREABITWIDTH) (WINDOWPROP BMEDITWINDOW (QUOTE BORDER] (WINDOWPROP BMEDITWINDOW (QUOTE EXTENT) (CREATEREGION (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET)) EXTENTWIDTH) BITMAPWIDTH)) (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET)) EXTENTHEIGHT) BITMAPHEIGHT)) EXTENTWIDTH EXTENTHEIGHT)) (EDITBMREPAINTFN BMEDITWINDOW NIL ZEROBMFLG]) (EDITBMREPAINTFN.NEW [LAMBDA (WIN REGION ZEROBM) (* ; "Edited 27-Aug-87 22:02 by FS") (* ;;   "Stub in case I missed a call to this guy. Take out later.") (EDITBMREPAINTFN WIN REGION ZEROBM]) (EDITBMREPAINTFN [LAMBDA (WIN REGION ZEROBM) (* N.H.Briggs " 4-Sep-87 15:07") (* ;;   "redisplays a bitmap editting window If ZEROBM is non-NIL, it doesn't bother to display the bits.") (PROG [(GRIDSPEC (WINDOWPROP WIN (QUOTE GRIDSPEC))) (EDITAREABITWIDTH (WINDOWPROP WIN (QUOTE BITSWIDE))) (EDITAREABITHEIGHT (WINDOWPROP WIN (QUOTE BITSHIGH))) (BM (WINDOWPROP WIN (QUOTE BM] (CLEARW WIN) (* ;   "gray the area above the edit grid that is not bitmap display area.") (BLTSHADE NOTINUSEGRAY WIN (PLUS (WINDOWPROP WIN (QUOTE BMDISPLAYWIDTH)) GRIDTHICKNESS) (WINDOWPROP WIN (QUOTE BMDISPLAYBOTTOM))) (* ;; "put in the display of the full sized bitmap.") (UPDATE/BM/DISPLAY BM WIN) (* ;;   "FS: Now that RESETGRID displays the grid, don't need the call to GRID.") (* ;;   "(COND ((WINDOWPROP WIN 'GRIDON) (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 'POINT WIN)))") (if ZEROBM then (if (WINDOWPROP WIN (QUOTE GRIDON)) then (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT (QUOTE POINT) WIN)) else (RESETGRID.NEW BM GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 0 0 WIN]) (RESETGRID.NEW [LAMBDA (BM GRIDSPEC WIDTH HEIGHT ORIGX ORIGY WINDOW DOCLEARFLG) (* N.H.Briggs " 4-Sep-87 15:08") (* ;;   "Copies the contents of a bitmap into the edit display grid of window. ORIGX & Y are used to offest into both bitmap and destination window." ) (LET (XOFFSET YOFFSET MAXX MAXY SHADE XSCALE YSCALE TEMPBM) (SETQ XSCALE (fetch (REGION WIDTH) of GRIDSPEC)) (SETQ YSCALE (fetch (REGION HEIGHT) of GRIDSPEC)) (if (NULL ORIGX) then (SETQ ORIGX 0)) (if (NULL ORIGY) then (SETQ ORIGY 0)) (SETQ XOFFSET (WINDOWPROP WINDOW (QUOTE XOFFSET))) (SETQ YOFFSET (WINDOWPROP WINDOW (QUOTE YOFFSET))) (SETQ MAXX (IPLUS ORIGX WIDTH -1)) (SETQ MAXY (IPLUS ORIGY HEIGHT -1)) (* ;; "Build & cache a temporary bitmap.") (SETQ TEMPBM (WINDOWPROP WINDOW (QUOTE TEMPBM))) (if (NOT TEMPBM) then (SETQ TEMPBM (BITMAPCREATE (BITMAPWIDTH WINDOW) (BITMAPHEIGHT BM))) (WINDOWPROP WINDOW (QUOTE TEMPBM) TEMPBM)) (* ;;   "Use SCALEBM. Bitmap destination must be empty (white).") (if DOCLEARFLG then (BLTSHADE WHITESHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) (TIMES WIDTH XSCALE) (TIMES HEIGHT YSCALE) (QUOTE REPLACE))) (SCALEBM BM (PLUS ORIGX XOFFSET) (PLUS ORIGY YOFFSET) WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) WIDTH HEIGHT XSCALE YSCALE TEMPBM) (* ;; "Shade the pixels correctly.") (BLTSHADE DARKBITSHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) (TIMES WIDTH XSCALE) (TIMES HEIGHT YSCALE) (QUOTE ERASE)) (* ;; "Add grid") (if (WINDOWPROP WINDOW (QUOTE GRIDON)) then (if (OR (NEQ ORIGX (CAR GRIDSPEC)) (NEQ ORIGY (CADR GRIDSPEC))) then (SETQ GRIDSPEC (COPYALL GRIDSPEC)) (replace (REGION LEFT) of GRIDSPEC with (LEFTOFGRIDCOORD ORIGX GRIDSPEC)) (replace (REGION BOTTOM) of GRIDSPEC with (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC))) (GRID GRIDSPEC WIDTH HEIGHT (QUOTE POINT) WINDOW]) ) (DEFINEQ (SCALEBM [LAMBDA (SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEWIDTH SRCEHEIGHT XSCALE YSCALE TEMPBM) (* N.H.Briggs " 4-Sep-87 15:48") (* ;;   "Magnify a bitmap as per EDITBM. Use smearing algorithm.") (LET ((DESTWIDTH (BITMAPWIDTH DESTBM)) (DESTHEIGHT (if (WINDOWP DESTBM) then (WINDOWPROP DESTBM (QUOTE HEIGHT)) else (BITMAPHEIGHT DESTBM))) XSTEPS YSTEPS POWER) (* ;; "Check parameters, apply defaults") (if (NUMBERP SRCEWIDTH) else (SETQ SRCEWIDTH (BITMAPWIDTH SRCEBM))) (if (NUMBERP SRCEHEIGHT) else (SETQ SRCEHEIGHT (BITMAPHEIGHT SRCEBM))) (* ;;  "Save effort by considering min of srce and dest.") (SETQ DESTWIDTH (MIN DESTWIDTH (TIMES SRCEWIDTH XSCALE))) (SETQ DESTHEIGHT (MIN DESTHEIGHT (TIMES SRCEHEIGHT YSCALE))) (SETQ SRCEWIDTH (MIN SRCEWIDTH (IQUOTIENT DESTWIDTH XSCALE))) (SETQ SRCEHEIGHT (MIN SRCEHEIGHT (IQUOTIENT DESTHEIGHT YSCALE))) (if TEMPBM then (BLTSHADE WHITESHADE TEMPBM) else (SETQ TEMPBM (BITMAPCREATE DESTWIDTH SRCEHEIGHT))) (* ;;   "CALL EXPANDBM twice, once for each direction, because we have a spare bitmap which makes it run faster than a single call to EXPANDBM would (I think)." ) (* ;; "") (* ;; "Do X Direction Smearing.") (* ;; "============") (EXPANDBM SRCEBM SRCEX SRCEY SRCEWIDTH SRCEHEIGHT TEMPBM 0 0 DESTWIDTH SRCEHEIGHT XSCALE 1 XSCALE 1) (* ;; "") (* ;; "Do Y Direction Smearing.") (* ;; "============") (EXPANDBM TEMPBM 0 0 DESTWIDTH SRCEHEIGHT DESTBM DESTX DESTY DESTWIDTH DESTHEIGHT 1 YSCALE 1 YSCALE) (* ;; "") (* ;;  "Return the temporary bitmap for recycling purposes.") TEMPBM]) (BLTPATTERN [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH OPER TEMPBM) (* N.H.Briggs " 4-Sep-87 15:10") (* ;;   "Fills region of Destination with tiles of Source region, using operation. If Temporary bitmap is provided, use it for optimal performance." ) (PROG (W H RX RW) (if (NULL SW) then (SETQ SW (BITMAPWIDTH SRCE))) (if (NULL SH) then (SETQ SH (BITMAPHEIGHT SRCE))) (* ;; "") (* ;; "Fill columns ") (* ;; "") [if TEMPBM then (* ;;   "Temporary bitmap is only useful if larger than source.") (if [AND (GREATERP (BITMAPWIDTH TEMPBM) (MIN SW (BITMAPWIDTH SRCE))) (GREATERP (BITMAPHEIGHT TEMPBM) (MIN SH (BITMAPHEIGHT SRCE] then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH TEMPBM 0 0 (BITMAPWIDTH TEMPBM) (BITMAPHEIGHT TEMPBM)) (* ;;   "Allow code to fall through using TEMPBM as source area.") (SETQ SRCE TEMPBM) (SETQ SX 0) (SETQ SY 0) (SETQ SW (ITIMES SW (IQUOTIENT (BITMAPWIDTH TEMPBM) SW))) (SETQ SH (ITIMES SH (IQUOTIENT (BITMAPHEIGHT TEMPBM) SH] (if (AND (EQ OPER (QUOTE REPLACE)) (OR (BITMAPP DEST) (WINDOWP DEST))) then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH DEST DX DY DW DH) (RETURN)) (* ;;   "Even if operation is REPLACE, don't know if destination is inexpensively readable (e.g. Interpress stream. SO, this is the general case here." ) (while (GREATERP DH 0) do (SETQ H (MIN SH DH)) (* ;; "") (SETQ RW DW) (SETQ RX DX) (* ;; "") (* ;; "Fill rows") (* ;; "") (while (GREATERP RW 0) do (SETQ W (MIN SW RW)) (BITBLT SRCE SX SY DEST RX DY W H NIL OPER) (SETQ RW (DIFFERENCE RW W)) (SETQ RX (PLUS RX W))) (* ;; "") (SETQ DH (DIFFERENCE DH H)) (SETQ DY (PLUS DY H]) (BLTPATTERN.REPLACEDISPLAY [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH) (* N.H.Briggs " 4-Sep-87 15:11") (* ;;   "This routine only replaces the destination with the source, and assumes the destination itself can be easily read from and blt'ed to." ) (* ;;   "Put initial bitmap into destination. Source should not be within destination area, otherwise it will be overwritten." ) (LET (RX RY RW RH W H) (* ; "R's are remaining area.") (SETQ W (MIN SW DW)) (SETQ H (MIN SH DH)) (BLTSHADE WHITESHADE DEST DX DY W H (QUOTE REPLACE)) (BITBLT SRCE SX SY DEST DX DY W H NIL (QUOTE REPLACE)) (SETQ RX (PLUS DX W)) (SETQ RW (DIFFERENCE DW W)) (* ;; "Now power up until width is full.") (while (GREATERP RW 0) do (SETQ W (MIN SW RW)) (BITBLT DEST DX DY DEST RX DY W H NIL (QUOTE REPLACE)) (SETQ RW (DIFFERENCE RW W)) (* ; "Reduce remaining width") (SETQ RX (PLUS RX W)) (* ; "Set next starting position") (SETQ SW (PLUS SW SW)) (* ; "Can now use 2x area.")) (* ;; "") (SETQ RY (PLUS DY H)) (SETQ RH (DIFFERENCE DH H)) (SETQ SH H) (SETQ W DW) (* ;; "Now power up until height is full.") (while (GREATERP RH 0) do (SETQ H (MIN SH RH)) (BITBLT DEST DX DY DEST DX RY W H NIL (QUOTE REPLACE)) (SETQ RH (DIFFERENCE RH H)) (* ; "Reduce remaining width") (SETQ RY (PLUS RY H)) (* ; "Set next starting position") (SETQ SH (PLUS SH SH)) (* ; "Can now use 2x area.")]) ) (DEFINEQ (EXPANDBITMAP [LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR) (* N.H.Briggs "16-Nov-87 17:10") (* ;;   "Returns a new bitmap which is WidthFactor and HeightFactor bigger.") (* ;;   "FS: This slow piece of code has been replaced with a much faster, general one, EXPAND.l ") (LET (WIDTH HEIGHT BITSPERPIXEL NEWWIDTH NEWHEIGHT NEWX NEWY NEWBITMAP) (OR WIDTHFACTOR (SETQ WIDTHFACTOR 1)) (OR HEIGHTFACTOR (SETQ HEIGHTFACTOR 1)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) (SETQ NEWWIDTH (ITIMES WIDTHFACTOR WIDTH)) (SETQ NEWHEIGHT (ITIMES HEIGHTFACTOR HEIGHT)) (SETQ NEWBITMAP (BITMAPCREATE NEWWIDTH NEWHEIGHT BITSPERPIXEL)) (* ;; "OLD code commented out here.") (* LET NIL (* Expand in x-direction. *) (SETQ NEWX 0) (for X from 0 to (SUB1 WIDTH) do (for I from 1 to WIDTHFACTOR do (BITBLT BITMAP X 0 NEWBITMAP NEWX 0 1 HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (add NEWX 1)))  (* Expand in y-direction. *) (SETQ NEWY (SUB1 NEWHEIGHT)) (for Y from (SUB1 HEIGHT) to 0 by -1 do  (for I from 1 to HEIGHTFACTOR do (BITBLT NEWBITMAP 0 Y NEWBITMAP 0 NEWY NEWWIDTH 1 (QUOTE INPUT)  (QUOTE REPLACE)) (add NEWY -1)))) (EXPANDBM BITMAP 0 0 WIDTH HEIGHT NEWBITMAP 0 0 NEWWIDTH NEWHEIGHT WIDTHFACTOR HEIGHTFACTOR WIDTHFACTOR HEIGHTFACTOR) NEWBITMAP]) (EXPANDBM [LAMBDA (SRCEBM SRCEX SRCEY SRCEW SRCEH DESTBM DESTX DESTY DESTW DESTH XSCALE YSCALE XSPACE YSPACE) (* N.H.Briggs " 4-Sep-87 15:18") (* ;;   "Expands a region of SrceBM by X&Y scale into a region of DestBM, spaced Xspace by YSpace apart (space must be larger than scale). SrceBM cannot be the same bitmap as DestBM. The entire region inside DestBM is cleared." ) (PROG (XSTEPS YSTEPS POWER) (* ;; "Check parameters, apply defaults") (if (NUMBERP SRCEX) else (SETQ SRCEX 0)) (if (NUMBERP SRCEY) else (SETQ SRCEY 0)) (if (NUMBERP SRCEW) else (SETQ SRCEW (BITMAPWIDTH SRCEBM))) (if (NUMBERP SRCEH) else (SETQ SRCEH (BITMAPHEIGHT SRCEBM))) (if (NUMBERP DESTX) else (SETQ SRCEX 0)) (if (NUMBERP DESTY) else (SETQ SRCEY 0)) (* ;;  "Save effort by considering min of srce and dest.") [SETQ DESTW (IMIN DESTW (TIMES SRCEW (IMAX XSCALE XSPACE] [SETQ DESTH (IMIN DESTH (TIMES SRCEH (IMAX YSCALE YSPACE] [SETQ SRCEW (IMIN SRCEW (PLUS 1 (IQUOTIENT DESTW (IMAX XSCALE XSPACE] [SETQ SRCEH (IMIN SRCEH (PLUS 1 (IQUOTIENT DESTH (IMAX YSCALE YSPACE] (BLTSHADE WHITESHADE DESTBM DESTX DESTY DESTW DESTH) (if (AND (EQP XSPACE 1) (EQP YSPACE 1)) then (BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH) (RETURN DESTBM)) (* ;; "") (* ;; "Do X Direction Smearing.") (* ;; "============") (* ;;   "Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") (if (EQP XSPACE 1) then (* ;;   "Don't fill destination, instead use srce in YSmear loop.") (* ;;   "(BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH)") else (* ;;   "Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") (for I from (SUB1 SRCEW) to 0 by -1 do (BITBLT SRCEBM (PLUS SRCEX I) SRCEY DESTBM (PLUS DESTX (TIMES I XSPACE)) DESTY 1 SRCEH))) (* ;;   "Now smear by scalefactor. Each step smears out a power of two. LSH is in ucode.") [if (EQP XSCALE 1) else (SETQ POWER 1) (while (ILEQ POWER (LSH XSCALE -1)) do (* ;;   "In the X direction, only need to blt SRCEH bits high, and must shorten W to remain within DESTW") (BITBLT DESTBM DESTX DESTY DESTBM (PLUS DESTX POWER) DESTY (DIFFERENCE DESTW POWER) SRCEH NIL (QUOTE PAINT)) (SETQ POWER (PLUS POWER POWER))) (* ;; "Clean up for non power of two.") (if (ZEROP (DIFFERENCE XSCALE POWER)) else (BITBLT DESTBM DESTX DESTY DESTBM (PLUS DESTX (DIFFERENCE XSCALE POWER)) DESTY (DIFFERENCE DESTW (DIFFERENCE XSCALE POWER)) SRCEH NIL (QUOTE PAINT] (* ;; "") (* ;; "Do Y Direction Smearing.") (* ;; "============") (* ;;   "Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") [if (EQP YSPACE 1) else (if (EQP XSPACE 1) then (* ;;   "Didn't need to paint in destination, so can avoid second loop by blting from SRCBM instead of DESTBM.") (for J from (SUB1 SRCEH) to 0 by -1 do (BITBLT SRCEBM SRCEX (PLUS SRCEY J) DESTBM DESTX (PLUS DESTY (TIMES J YSPACE)) DESTW 1)) else (for J from (SUB1 SRCEH) to 0 by -1 do (BITBLT DESTBM DESTX (PLUS DESTY J) DESTBM DESTX (PLUS DESTY (TIMES J YSPACE)) DESTW 1)) (* ;;   "Since we reused DESTBM, parts of the dest have bits in them but shouldn't. So, clear them.") (for J from 0 to SRCEH by YSPACE do (BLTSHADE WHITESHADE DESTBM DESTX (PLUS DESTY J 1) DESTW (SUB1 YSPACE] (* ;;   "Now smear correctly. Each step smears out a power of two. LSH is in ucode.") [if (EQP YSCALE 1) else (SETQ POWER 1) (while (ILEQ POWER (LSH YSCALE -1)) do (BITBLT DESTBM DESTX DESTY DESTBM DESTX (PLUS DESTY POWER) DESTW (DIFFERENCE DESTH POWER) NIL (QUOTE PAINT)) (SETQ POWER (PLUS POWER POWER))) (* ;; "Clean up for non power of two.") (if (ZEROP (DIFFERENCE YSCALE POWER)) else (BITBLT DESTBM DESTX DESTY DESTBM DESTX (PLUS DESTY (DIFFERENCE YSCALE POWER)) DESTW DESTH NIL (QUOTE PAINT] (* ;; "") (* ;;  "Return the temporary bitmap for recycling purposes.") DESTBM]) ) (PUTPROPS FASTEDITBM COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (1041 4849 (GRID 1051 . 4847)) (4850 52348 (EDITBM 4860 . 13712) (EDITBMCLOSEFN 13714 . 14345) (TILEAREA 14347 . 14779) (EDITBMBUTTONFN 14781 . 29731) (EDITBMSCROLLFN 29733 . 40923) ( \EDITBM/PUTUP/DISPLAY 40925 . 41674) (EDITBMRESHAPEFN 41676 . 47657) (EDITBMREPAINTFN.NEW 47659 . 47983) (EDITBMREPAINTFN 47985 . 49598) (RESETGRID.NEW 49600 . 52346)) (52349 59854 (SCALEBM 52359 . 54995) (BLTPATTERN 54997 . 57709) (BLTPATTERN.REPLACEDISPLAY 57711 . 59852)) (59855 68063 ( EXPANDBITMAP 59865 . 61694) (EXPANDBM 61696 . 68061))))) STOP \ No newline at end of file diff --git a/lispusers/FILECACHE-FIX b/lispusers/FILECACHE-FIX new file mode 100644 index 00000000..18ccf223 --- /dev/null +++ b/lispusers/FILECACHE-FIX @@ -0,0 +1 @@ +(FILECREATED " 4-Aug-86 12:54:12" {PHYLUM}FILECACHE>FILECACHE-FIX.;1 692 changes to: (VARS FILECACHE-FIXCOMS) (FNS \New-FLUSHRIGHT) (ADVICE TAB-IN-FLUSHRIGHT)) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT FILECACHE-FIXCOMS) (RPAQQ FILECACHE-FIXCOMS ((* * A patch for the FILECACHE, v 5.2) (ADVISE TAB-IN-FLUSHRIGHT))) (* * A patch for the FILECACHE, v 5.2) (PUTPROPS TAB-IN-FLUSHRIGHT READVICE [(FLUSHRIGHT . TAB) (BEFORE NIL (COND ((GEQ POS 1000000) (SETQ POS 0]) (READVISE TAB-IN-FLUSHRIGHT) (PUTPROPS FILECACHE-FIX COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/FILENAMES b/lispusers/FILENAMES new file mode 100644 index 00000000..79b31804 --- /dev/null +++ b/lispusers/FILENAMES @@ -0,0 +1 @@ +(FILECREATED "12-Mar-85 14:02:50" {ERIS}LIBRARY>FILENAMES.;1 18342 changes to: (VARS FILENAMESCOMS)) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT FILENAMESCOMS) (RPAQQ FILENAMESCOMS ((FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.LISPM REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX))) (DEFINEQ (REPACKFILENAME.STRING [LAMBDA (NAME FOROSTYPE) (* edited: "12-Mar-85 13:51") (LET ((NAMELST (UNPACKFILENAME.STRING NAME))) (SELECTQ FOROSTYPE (UNIX (REPACKFILENAME.STRING.UNIX NAMELST)) ((TOPS20 TOPS-20) (REPACKFILENAME.STRING.TOPS20 NAMELST)) ((LISPM 3600 SYMBOLICS) (REPACKFILENAME.STRING.LISPM NAMELST)) ((D IFS) (REPACKFILENAME.STRING.D NAMELST)) NAME]) (REPACKFILENAME.STRING.D [LAMBDA N (* ejs: " 9-Mar-85 16:02") (* * Convert file names to native format) (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.D) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error checking of fields) (REPACKFILENAME.STRING.D VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) [HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP] [DIRECTORY (* DIRECTORY really is treated as  {Host}device:) (for X on (UNPACKFILENAME.STRING VAL NIL T) by (CDDR X) do (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] [(DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP] (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (: (LIST DEVICE)) (LIST DEVICE (QUOTE :] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE %.] (RPLCHARCODE DIRECTORY C (CHARCODE >] (LIST "<" DIRECTORY ">"))) (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) BLIP) (T (QUOTE %.))) (OR EXTENSION BLIP))) (AND VERSION (NEQ VERSION BLIP) (COND ((FIXP VERSION) (LIST (QUOTE ;) VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST (QUOTE ;) (SUBSTRING VERSION 2 -1))) (LIST (QUOTE ;) VERSION]) (REPACKFILENAME.STRING.LISPM [LAMBDA N (* ejs: "23-Feb-85 17:19") (* * Can you believe this???) (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.LISPM) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error checking of fields) (REPACKFILENAME.STRING.LISPM VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) [HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP] [DIRECTORY (* DIRECTORY really is treated as  {Host}device:) (for X on (UNPACKFILENAME.STRING VAL NIL T) by (CDDR X) do (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] [(DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP] (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (: (LIST DEVICE)) (LIST DEVICE (QUOTE :] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE %.] (RPLCHARCODE DIRECTORY C (CHARCODE >] (LIST ">" DIRECTORY ">"))) (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) BLIP) (T (QUOTE %.))) (OR EXTENSION BLIP))) (AND VERSION (NEQ VERSION BLIP) (COND ((FIXP VERSION) (LIST (QUOTE %.) VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST (QUOTE %.) (SUBSTRING VERSION 2 -1))) (LIST (QUOTE %.) VERSION]) (REPACKFILENAME.STRING.TOPS20 [LAMBDA N (* ejs: "23-Feb-85 17:20") (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.TOPS20) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error checking of fields) (REPACKFILENAME.STRING.TOPS20 VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) [HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP] [DIRECTORY (* DIRECTORY really is treated as  {Host}device:) (for X on (UNPACKFILENAME.STRING VAL NIL T) by (CDDR X) do (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] [(DEVICE HOST NAME EXTENSION VERSION TEMPORARY) (OR (EVALV VAR) (SET VAR (OR VAL BLIP] (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (SELECTQ TEMPORARY [(T S ;S) (* hack for Interlisp-D!) (OR HOST DEVICE (PROGN (SETQ HOST (QUOTE CORE)) (SETQ TEMPORARY] NIL) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (: (LIST DEVICE)) (LIST DEVICE (QUOTE :] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE DIRECTORY C (CHARCODE %.] (LIST "<" DIRECTORY ">"))) (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) BLIP) (T (QUOTE %.))) (OR EXTENSION BLIP))) [AND VERSION (NEQ VERSION BLIP) (COND ((FIXP VERSION) (LIST (QUOTE %.) VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST (QUOTE %.) (SUBSTRING VERSION 2 -1))) (LIST (QUOTE %.) VERSION] (AND TEMPORARY (NEQ TEMPORARY BLIP) (LIST (QUOTE ;) (SELECTQ TEMPORARY ((S ;S) (QUOTE S)) T]) (REPACKFILENAME.STRING.UNIX [LAMBDA N (* ejs: "23-Feb-85 17:20") (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.UNIX) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error checking of fields) (REPACKFILENAME.STRING.UNIX VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) [HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP] [DIRECTORY (* DIRECTORY really is treated as  {Host}device:) (for X on (UNPACKFILENAME.STRING VAL NIL T) by (CDDR X) do (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] [(DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP] (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) (AND DEVICE (NEQ DEVICE BLIP) (LIST "/" DEVICE)) (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE %.] (RPLCHARCODE DIRECTORY C (CHARCODE /] (LIST "/" DIRECTORY "/")) (LIST "/" DIRECTORY "/")) (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) (OR (NULL EXTENSION) (EQ EXTENSION BLIP) (STREQUAL EXTENSION ""))) BLIP) (T (QUOTE %.))) (OR EXTENSION BLIP))) (AND VERSION (NEQ VERSION BLIP) (COND ((FIXP VERSION) (LIST (QUOTE ;) VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST (QUOTE ;) (SUBSTRING VERSION 2 -1))) (LIST (QUOTE ;) VERSION]) ) (PRETTYCOMPRINT FILENAMESCOMS) (RPAQQ FILENAMESCOMS [(FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.LISPM REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.LISPM REPACKFILENAME.STRING.D]) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.LISPM REPACKFILENAME.STRING.D) ) (PUTPROPS FILENAMES COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (399 17562 (REPACKFILENAME.STRING 409 . 894) (REPACKFILENAME.STRING.D 896 . 4912) ( REPACKFILENAME.STRING.LISPM 4914 . 8979) (REPACKFILENAME.STRING.TOPS20 8981 . 13473) ( REPACKFILENAME.STRING.UNIX 13475 . 17560))))) STOP \ No newline at end of file diff --git a/lispusers/FILEWATCH b/lispusers/FILEWATCH new file mode 100644 index 00000000..339ed340 --- /dev/null +++ b/lispusers/FILEWATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "20-Oct-89 17:00:03" {ICE}LISPUSERS>MEDLEY>FILEWATCH.;2 63422 changes to%: (VARS FILEWATCHCOMS) (FNS FILEWATCH FW-CLOSE-CMD FW-INIT-MENUS) previous date%: "19-Oct-87 12:36:56" {ICE}LISPUSERS>MEDLEY>FILEWATCH.;1) (* " Copyright (c) 1986, 1987, 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT FILEWATCHCOMS) (RPAQQ FILEWATCHCOMS [(PROP MAKEFILE-ENVIRONMENT FILEWATCH) (* ;;; "FILEWATCH is a facility for keeping an eye on the status of open files. It maintains a display containing the names of open files and their file pointer positions including a percentage bar.") (* ;;; "Interface") (FNS FILEWATCH FILEWATCHPROP) (* ;;; "Implementation") (COMS (DECLARE%: DONTCOPY (RECORDS FW-OFD)) (INITRECORDS FW-OFD)) (FNS FW-ADJUST-PLACEMENT FW-ADJUST-REGION FW-AFTERMOVEFN FW-BUTTONEVENTFN FW-CHANGE-ANCHOR FW-CHANGE-JUSTIFICATION FW-CHANGE-POSITION FW-CLOSE-CMD FW-CLOSE-OLD-OFD-WINDOWS FW-CLOSEFN FW-CREATE-OFD FW-CREATE-OFD-LIST FW-CREATE-OFD-WINDOWS FW-CREATEW FW-FILTERED-FILE? FW-FORGET-CMD FW-INIT FW-INIT-MENUS FW-INIT-PROPS FW-INTERACT FW-LOOP FW-MOVE-OFD-WINDOWS FW-MOVEW FW-OFD-EXISTS? FW-OPENP FW-PERCENTAGE FW-RE-INIT FW-RECALL-CMD FW-REPAINTFN FW-RESET FW-RESIZE-OFD FW-SHAPEW FW-SORT-FN FW-UPDATE-OFD-WINDOW FW-UPDATE-OFD-WINDOWS FW-WIPE) [DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (* FILES (SOURCE FROM LISPUSERS) SYSEDIT) (P [OR (HASDEF 'FDEV 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'FDEV] (OR (HASDEF 'STREAM 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'STREAM] [INITVARS (FW-OFDList NIL) (FW-OpenP-ScratchList (CONS)) [FW-Commands (COPY '(FORGET FORGET-MANY RECALL RECALL-MANY CLOSE CLOSE-MANY MOVE SET-ANCHOR SET-POSITION SET-JUSTIFICATION QUIT] (FW-Properties (COPY `(FONT (GACHA 8) ALL-FILES? T POSITION ,(CREATEPOSITION SCREENWIDTH 0) ANCHOR BOTTOM-RIGHT SHADE ,GRAYSHADE INTERVAL 1000] (P (FW-INIT-MENUS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FILEWATCHPROP]) (PUTPROPS FILEWATCH MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (* ;;; "FILEWATCH is a facility for keeping an eye on the status of open files. It maintains a display containing the names of open files and their file pointer positions including a percentage bar." ) (* ;;; "Interface") (DEFINEQ (FILEWATCH [LAMBDA (COMMAND) (* ; "Edited 20-Oct-89 16:43 by koomen") (DECLARE (GLOBALVARS FW-Running?)) (PROG [(FW-PROC (FIND.PROCESS 'FileWatcher] (if (OR (NOT (PROCESSP FW-PROC)) (PROCESS.FINISHEDP FW-PROC)) then (SETQ FW-PROC NIL)) (SELECTQ (SELECTQ [if (OR (LITATOM COMMAND) (STRINGP COMMAND)) then (SETQ COMMAND (MKATOM (U-CASE COMMAND] (ON (if (NULL FW-PROC) then 'ON)) ((OFF QUIT) (if FW-PROC then (SETQ COMMAND 'OFF))) (MENU (SETQ COMMAND NIL) 'MENU) (if (OR COMMAND FW-PROC) then 'MENU else 'ON)) (ON (SETQ FW-PROC (ADD.PROCESS (LIST (FUNCTION FW-LOOP)) 'NAME 'FileWatcher 'RESTARTABLE 'HARDRESET))) (OFF (SETQ FW-PROC (SETQ FW-Running? NIL))) (MENU (if (NULL FW-PROC) then (FILEWATCH 'ON) (BLOCK)) (FW-INTERACT NIL COMMAND)) NIL) (RETURN FW-PROC]) (FILEWATCHPROP [LAMBDA FILEWATCH#ARGS (* Koomen "12-Jan-87 21:31") (DECLARE (GLOBALVARS FW-Properties FW-ReInit?)) (if (EQ FILEWATCH#ARGS 1) then (LET ((PROPNAME (ARG FILEWATCH#ARGS 1))) (LISTGET FW-Properties PROPNAME)) elseif (EQ FILEWATCH#ARGS 2) then (LET* ((PROPNAME (ARG FILEWATCH#ARGS 1)) (PROPVALUE (ARG FILEWATCH#ARGS 2)) (OLDPROPVALUE (LISTGET FW-Properties PROPNAME))) (if (NOT (EQUAL PROPVALUE OLDPROPVALUE)) then (LISTPUT FW-Properties PROPNAME PROPVALUE) (SETQ FW-ReInit? T)) OLDPROPVALUE) else (ERROR "FILEWATCH: Expecting 1 or 2 args -- " FILEWATCH#ARGS]) ) (* ;;; "Implementation") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE FW-OFD (FILESTREAM FULLNAME NAMEWIDTH LEFT BOTTOM WIDTH HEIGHT OFDLEFT OFDBOTTOM OFDWIDTH OFDHEIGHT OFDWINDOW OFDSTREAM OFDSTATUS CURPOS EOFPOS PCTPOS CURPOSXOFFSET EOFPOSXOFFSET PCTPOSXOFFSET ACCESSXOFFSET PCTREGION READING? WRITING? RANDOM?)) ) (/DECLAREDATATYPE 'FW-OFD '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FW-OFD 0 POINTER) (FW-OFD 2 POINTER) (FW-OFD 4 POINTER) (FW-OFD 6 POINTER) (FW-OFD 8 POINTER) (FW-OFD 10 POINTER) (FW-OFD 12 POINTER) (FW-OFD 14 POINTER) (FW-OFD 16 POINTER) (FW-OFD 18 POINTER) (FW-OFD 20 POINTER) (FW-OFD 22 POINTER) (FW-OFD 24 POINTER) (FW-OFD 26 POINTER) (FW-OFD 28 POINTER) (FW-OFD 30 POINTER) (FW-OFD 32 POINTER) (FW-OFD 34 POINTER) (FW-OFD 36 POINTER) (FW-OFD 38 POINTER) (FW-OFD 40 POINTER) (FW-OFD 42 POINTER) (FW-OFD 44 POINTER) (FW-OFD 46 POINTER) (FW-OFD 48 POINTER)) '50) ) (/DECLAREDATATYPE 'FW-OFD '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FW-OFD 0 POINTER) (FW-OFD 2 POINTER) (FW-OFD 4 POINTER) (FW-OFD 6 POINTER) (FW-OFD 8 POINTER) (FW-OFD 10 POINTER) (FW-OFD 12 POINTER) (FW-OFD 14 POINTER) (FW-OFD 16 POINTER) (FW-OFD 18 POINTER) (FW-OFD 20 POINTER) (FW-OFD 22 POINTER) (FW-OFD 24 POINTER) (FW-OFD 26 POINTER) (FW-OFD 28 POINTER) (FW-OFD 30 POINTER) (FW-OFD 32 POINTER) (FW-OFD 34 POINTER) (FW-OFD 36 POINTER) (FW-OFD 38 POINTER) (FW-OFD 40 POINTER) (FW-OFD 42 POINTER) (FW-OFD 44 POINTER) (FW-OFD 46 POINTER) (FW-OFD 48 POINTER)) '50) (DEFINEQ (FW-ADJUST-PLACEMENT [LAMBDA (OFDLIST) (* Koomen "12-Jan-87 21:19") (* * Recursively (post-order) position each window, so that the first element  ends up on top of the display. Note that, for downward-growing lists, the  sorter actually forces reverse sort.) (DECLARE (GLOBALVARS FW-WindowBottom FW-WindowBottomDelta)) (if OFDLIST then (FW-ADJUST-PLACEMENT (CDR OFDLIST)) (PROG ((OFD (CAR OFDLIST))) (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) ((NEW CURRENT) (replace (FW-OFD BOTTOM) of OFD with FW-WindowBottom) (if (OR (NEQ (fetch (FW-OFD OFDWIDTH) of OFD) (fetch (FW-OFD WIDTH) of OFD)) (NEQ (fetch (FW-OFD OFDHEIGHT) of OFD) (fetch (FW-OFD HEIGHT) of OFD))) then (FW-SHAPEW OFD) (replace (FW-OFD OFDSTATUS) of OFD with 'NEW) elseif (OR (NEQ (fetch (FW-OFD LEFT) of OFD) (fetch (FW-OFD OFDLEFT) of OFD)) (NEQ (fetch (FW-OFD BOTTOM) of OFD) (fetch (FW-OFD OFDBOTTOM) of OFD))) then (FW-MOVEW OFD)) (SETQ FW-WindowBottom (IPLUS FW-WindowBottom FW-WindowBottomDelta))) (FORGOTTEN) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-ADJUST-REGION [LAMBDA NIL (* Koomen "12-Jan-87 21:29") (DECLARE (GLOBALVARS FW-Anchor FW-Justified? FW-OFDList FW-Position FW-WindowBottom FW-WindowBottomDelta FW-WindowHeight WBorder)) [if FW-Justified? then (* Recompute maximum name field  width) (PROG (NAMEWIDTH (MAXNAMEWIDTH 0)) [for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) ((NEW CURRENT) (SETQ NAMEWIDTH (fetch (FW-OFD NAMEWIDTH) of OFD)) (if (IGREATERP NAMEWIDTH MAXNAMEWIDTH) then (SETQ MAXNAMEWIDTH NAMEWIDTH))) (FORGOTTEN) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS ) of OFD] (for OFD in FW-OFDList do (FW-RESIZE-OFD OFD MAXNAMEWIDTH] (SETQ FW-WindowBottom (fetch (POSITION YCOORD) of FW-Position)) (SETQ FW-WindowBottomDelta (IDIFFERENCE FW-WindowHeight (IQUOTIENT WBorder 2))) (SELECTQ FW-Anchor ((TOP-LEFT TOP-RIGHT) (SETQ FW-WindowBottom (IDIFFERENCE FW-WindowBottom FW-WindowHeight)) (SETQ FW-WindowBottomDelta (IMINUS FW-WindowBottomDelta))) ((BOTTOM-LEFT BOTTOM-RIGHT)) (ERROR "Unsupported anchor spec: " FW-Anchor]) (FW-AFTERMOVEFN [LAMBDA (W) (* ; "Edited 30-Sep-87 11:53 by Koomen") (* ;; "[30-Sep-87] Added FW-Dormant? flag: If moving a FileWatch window causes the FileWatch anchor position to move off the screen, then go to sleep. This is to accomodate the Rooms package.") (DECLARE (GLOBALVARS FW-Dormant? FW-OFDList SCREENHEIGHT SCREENWIDTH)) (SETQ FW-Dormant? NIL) (if (NEQ 'FileWatcher (PROCESS.NAME (THIS.PROCESS))) then (for OFD in FW-OFDList when (EQ W (fetch (FW-OFD OFDWINDOW) of OFD)) bind REGION DELTAX DELTAY OLDPOS NEWX NEWY do (SETQ OLDPOS (FILEWATCHPROP 'POSITION)) (SETQ REGION (WINDOWREGION W)) (SETQ DELTAX (IDIFFERENCE (fetch (REGION LEFT) of REGION) (fetch (FW-OFD OFDLEFT) of OFD))) (SETQ NEWX (IPLUS DELTAX (fetch (POSITION XCOORD) of OLDPOS))) (SETQ DELTAY (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) (fetch (FW-OFD OFDBOTTOM) of OFD))) (SETQ NEWY (IPLUS DELTAY (fetch (POSITION YCOORD) of OLDPOS))) (if (OR (ILESSP NEWX 0) (IGREATERP NEWX SCREENWIDTH) (ILESSP NEWY 0) (IGREATERP NEWY SCREENHEIGHT)) then (SETQ FW-Dormant? T) else (FILEWATCHPROP 'POSITION (create POSITION XCOORD _ NEWX YCOORD _ NEWY))) (RETURN]) (FW-BUTTONEVENTFN [LAMBDA (W) (* Koomen "16-Apr-87 15:28") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS)) (if (MOUSESTATE (ONLY RIGHT)) then (FW-INTERACT W) elseif (MOUSESTATE (ONLY MIDDLE)) then (FW-MOVE-OFD-WINDOWS 'POSITION) elseif (MOUSESTATE (ONLY LEFT)) then (FW-REPAINTFN W)) NIL]) (FW-CHANGE-ANCHOR [LAMBDA NIL (* Koomen "16-Apr-87 15:55") (DECLARE (GLOBALVARS PROMPTWINDOW)) (PROG [NEWANCHOR (OLDANCHOR (FILEWATCHPROP 'ANCHOR] (CLRPROMPT) (printout PROMPTWINDOW "Current anchor is " OLDANCHOR T T) (printout PROMPTWINDOW "Indicate new anchor: ") [SETQ NEWANCHOR (MENU (create MENU CENTERFLG _ T TITLE _ "Anchor: " ITEMS _ '(("Top Left" 'TOP-LEFT) ("Top Right" 'TOP-RIGHT) ("Bottom Left" 'BOTTOM-LEFT) ("Bottom Right" 'BOTTOM-RIGHT] (if (AND NEWANCHOR (NEQ NEWANCHOR OLDANCHOR)) then (FILEWATCHPROP 'ANCHOR NEWANCHOR]) (FW-CHANGE-JUSTIFICATION [LAMBDA NIL (* Koomen "16-Apr-87 15:55") (DECLARE (GLOBALVARS PROMPTWINDOW)) (PROG [NEWJUST? (OLDJUST? (FILEWATCHPROP 'JUSTIFIED?] (CLRPROMPT) (printout PROMPTWINDOW "Window justification is " OLDJUST? T T) (SETQ NEWJUST? (MOUSECONFIRM "Turn justification on?")) (if (NEQ NEWJUST? OLDJUST?) then (FILEWATCHPROP 'JUSTIFIED? NEWJUST?]) (FW-CHANGE-POSITION [LAMBDA NIL (* Koomen "16-Apr-87 15:48") (DECLARE (GLOBALVARS FW-OFDList PROMPTWINDOW)) (PROG ((OLDPOS (FILEWATCHPROP 'POSITION)) NEWPOS BOX R) (for OFD in FW-OFDList when (EQ (fetch (FW-OFD OFDSTATUS) of OFD) 'CURRENT) do (SETQ R (WINDOWREGION (fetch (FW-OFD OFDWINDOW) of OFD))) (SETQ BOX (if BOX then (UNIONREGIONS BOX R) else R))) (if BOX then (SETQ NEWPOS (GETBOXPOSITION (fetch (REGION WIDTH) of BOX) (fetch (REGION HEIGHT) of BOX) (fetch (REGION LEFT) of BOX) (fetch (REGION BOTTOM) of BOX))) (* ;; "Now translate since anchor may not have been bottom-left") [SETQ NEWPOS (create POSITION XCOORD _ (IPLUS (fetch (POSITION XCOORD) of OLDPOS) (IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (REGION LEFT) of BOX))) YCOORD _ (IPLUS (fetch (POSITION YCOORD) of OLDPOS) (IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (REGION BOTTOM) of BOX] else (CLRPROMPT) (printout PROMPTWINDOW "Current position is " OLDPOS T T) (printout PROMPTWINDOW "Indicate new position: ") (SETQ NEWPOS (GETPOSITION))) (if (NOT (EQUAL NEWPOS OLDPOS)) then (FILEWATCHPROP 'POSITION NEWPOS]) (FW-CLOSE-CMD [LAMBDA (W MANY?) (* ; "Edited 20-Oct-89 16:38 by koomen") (DECLARE (GLOBALVARS FW-OFDList)) (if (AND W (NOT MANY?)) then (for OFD in FW-OFDList bind STREAM when (EQ (fetch (FW-OFD OFDWINDOW) of OFD) W) do (SETQ STREAM (fetch (FW-OFD FILESTREAM) of OFD)) (if (NOT (OPENP STREAM)) then (* ;;  "The process owning the stream beat us to it!") elseif (NOT (fetch (STREAM USERCLOSEABLE) of STREAM)) then (PROMPTPRINT "FileWatch: stream not user closable.") elseif (MOUSECONFIRM (CONCAT "Closing " STREAM)) then (CLOSEF? STREAM)) (RETURN)) else (bind OPEN-STREAMS STREAM-TO-CLOSE do (SETQ OPEN-STREAMS (FW-OPENP)) (if (NULL OPEN-STREAMS) then (if (NULL STREAM-TO-CLOSE) then (* ;; "First time around, and no appropriate files") (PROMPTPRINT "FileWatch: no open files.")) (RETURN)) (SETQ OPEN-STREAMS (for STREAM in OPEN-STREAMS when (fetch (STREAM USERCLOSEABLE) of STREAM) collect STREAM)) (if (NULL OPEN-STREAMS) then (if (NULL STREAM-TO-CLOSE) then (* ;; "First time around, and no appropriate files") (PROMPTPRINT "FileWatch: no user closable files.")) (RETURN)) (SETQ STREAM-TO-CLOSE (MENU (create MENU TITLE _ "Select stream to close: " ITEMS _ OPEN-STREAMS))) (if (NULL STREAM-TO-CLOSE) then (RETURN)) (CLOSEF? STREAM-TO-CLOSE) (BLOCK) (* ; "Give FileWatch a chance") (if (NOT MANY?) then (RETURN]) (FW-CLOSE-OLD-OFD-WINDOWS [LAMBDA NIL (* Koomen " 1-Oct-86 23:48") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (OLD (CLOSEW (fetch (FW-OFD OFDWINDOW) of OFD))) ((NEW CURRENT FORGOTTEN)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-CLOSEFN [LAMBDA (W) (* Koomen " 2-Oct-86 00:17") (DECLARE (GLOBALVARS FW-OFDList FW-OpenFiles FW-Reset?)) (if (NEQ (PROCESS.NAME (THIS.PROCESS)) 'FileWatcher) then (for OFD in FW-OFDList when (EQ W (fetch (FW-OFD OFDWINDOW) of OFD)) do (replace (FW-OFD OFDSTATUS) of OFD with 'FORGOTTEN) (RETURN)) (* Force recomputing OFDList) (push FW-OpenFiles T) (SETQ FW-Reset? T]) (FW-CREATE-OFD [LAMBDA (FULLNAME FILESTREAM) (* ; "Edited 22-Sep-87 13:04 by Koomen") (DECLARE (GLOBALVARS FW-Font)) (FW-RESIZE-OFD (create FW-OFD FILESTREAM _ FILESTREAM FULLNAME _ FULLNAME NAMEWIDTH _ (STRINGWIDTH FULLNAME FW-Font) EOFPOS _ (if (RANDACCESSP FILESTREAM) then (GETEOFPTR FILESTREAM) else (GETFILEINFO FILESTREAM 'LENGTH)) READING? _ (if (OPENP FILESTREAM 'INPUT) then T) WRITING? _ (if (OPENP FILESTREAM 'OUTPUT) then T) RANDOM? _ (if (RANDACCESSP FILESTREAM) then T) OFDSTATUS _ 'NEW]) (FW-CREATE-OFD-LIST [LAMBDA NIL (* ; "Edited 22-Sep-87 13:34 by Koomen") (DECLARE (GLOBALVARS FW-OFDList FW-OpenFiles FW-SortFn)) (for FILESTREAM in FW-OpenFiles bind FULLNAME eachtime (SETQ FULLNAME (FULLNAME FILESTREAM)) unless (OR (FW-FILTERED-FILE? FULLNAME) (FW-OFD-EXISTS? FULLNAME FILESTREAM)) do (push FW-OFDList (FW-CREATE-OFD FULLNAME FILESTREAM))) [SETQ FW-OFDList (for OFD in FW-OFDList join (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) ((NEW CURRENT FORGOTTEN) (LIST OFD)) (OLD (CLOSEW (fetch (FW-OFD OFDWINDOW) of OFD)) NIL) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD] (if (AND FW-OFDList FW-SortFn) then (SETQ FW-OFDList (SORT FW-OFDList (FUNCTION FW-SORT-FN]) (FW-CREATE-OFD-WINDOWS [LAMBDA NIL (* Koomen "16-Apr-87 15:29") (DECLARE (GLOBALVARS FW-Font FW-OFDList)) (FW-ADJUST-REGION) (for OFD in FW-OFDList bind OFDWINDOW OFDSTREAM unless (fetch (FW-OFD OFDWINDOW ) of OFD) do (SETQ OFDWINDOW (FW-CREATEW OFD)) (SETQ OFDSTREAM (WINDOWPROP OFDWINDOW 'DSP)) (replace (FW-OFD OFDSTREAM) of OFD with OFDSTREAM) (DSPFONT FW-Font OFDSTREAM) (WINDOWPROP OFDWINDOW 'RIGHTBUTTONFN (FUNCTION FW-BUTTONEVENTFN)) (WINDOWPROP OFDWINDOW 'BUTTONEVENTFN (FUNCTION FW-BUTTONEVENTFN)) (WINDOWPROP OFDWINDOW 'REPAINTFN (FUNCTION FW-REPAINTFN)) (WINDOWPROP OFDWINDOW 'RESHAPEFN (FUNCTION NILL)) (WINDOWPROP OFDWINDOW 'CLOSEFN (FUNCTION FW-CLOSEFN)) (WINDOWPROP OFDWINDOW 'AFTERMOVEFN (FUNCTION FW-AFTERMOVEFN))) (FW-ADJUST-PLACEMENT FW-OFDList]) (FW-CREATEW [LAMBDA (OFD) (* Koomen "29-Sep-86 23:16") (replace (FW-OFD OFDWINDOW) of OFD with (CREATEW (create REGION LEFT _ (replace (FW-OFD OFDLEFT ) of OFD with (fetch (FW-OFD LEFT) of OFD)) BOTTOM _ (replace (FW-OFD OFDBOTTOM) of OFD with (fetch (FW-OFD BOTTOM) of OFD)) WIDTH _ (replace (FW-OFD OFDWIDTH ) of OFD with (fetch (FW-OFD WIDTH) of OFD)) HEIGHT _ (replace (FW-OFD OFDHEIGHT) of OFD with (fetch (FW-OFD HEIGHT) of OFD))) NIL NIL T]) (FW-FILTERED-FILE? [LAMBDA (FULLNAME) (* ; "Edited 22-Sep-87 13:31 by Koomen") (DECLARE (GLOBALVARS FW-Filters)) (* ;; "filters are precompiled for matching. Note that the system function DIRECTORY.MATCH.SETUP has stripped off the host, so we have to match it seperatedly.") (for FILTER in FW-Filters thereis (AND (DIRECTORY.MATCH (CDR FILTER) FULLNAME) (DIRECTORY.MATCH (CAR FILTER) (FILENAMEFIELD FULLNAME 'HOST]) (FW-FORGET-CMD [LAMBDA (W MANY?) (* Koomen "27-May-87 15:27") (DECLARE (GLOBALVARS FW-OFDList)) (if (AND W (NOT MANY?)) then (CLOSEW W) else (PROG (CURRENT-OFDS FORGET-OFD) (SETQ CURRENT-OFDS (for OFD in FW-OFDList when (EQ (fetch (FW-OFD OFDSTATUS) of OFD) 'CURRENT) collect OFD)) (if (NULL CURRENT-OFDS) then (PROMPTPRINT "FileWatch: no current files.") (RETURN)) FORGET-ANOTHER [SETQ FORGET-OFD (MENU (create MENU TITLE _ "Select file to forget: " ITEMS _ (for OFD in CURRENT-OFDS collect (LIST (fetch (FW-OFD FULLNAME) of OFD) (KWOTE OFD] (if (NULL FORGET-OFD) then (RETURN)) (CLOSEW (fetch (FW-OFD OFDWINDOW) of FORGET-OFD)) (if (AND MANY? (SETQ CURRENT-OFDS (REMOVE FORGET-OFD CURRENT-OFDS))) then (GO FORGET-ANOTHER]) (FW-INIT [LAMBDA NIL (* ; "Edited 30-Sep-87 11:53 by Koomen") (DECLARE (GLOBALVARS FW-Dormant? FW-Running?)) (* * Clean up possible left-overs from a previously killed FileWatch process,  then initialize the world) (FW-WIPE) (FW-RE-INIT) (FW-RESET) (SETQ FW-Dormant? NIL) (SETQ FW-Running? T]) (FW-INIT-MENUS [LAMBDA NIL (* ; "Edited 20-Oct-89 16:57 by koomen") (DECLARE (GLOBALVARS BackgroundMenu BackgroundMenuCommands FW-Commands FW-InteractMenu)) (* * When changing the list of control menu items, do  (SETQ FW-InteractMenu)) (PROG [(ITEMS '(("Forget File" 'FORGET "Stop watching this file" (SUBITEMS ("Forget Many Files" 'FORGET-MANY "Stop watching several files" ))) ("Recall File" 'RECALL "Start watching a forgotten file again" (SUBITEMS ("Recall Many Files" 'RECALL-MANY "Start watching several forgotten files again"))) ("" NIL "No-op") ("Close File" 'CLOSE "Close this file (user beware!)" (SUBITEMS ("Close Many Files" 'CLOSE-MANY "Close several files"))) ("" NIL "No-op") ("Move Display" 'MOVE "Change the display orientation specs" (SUBITEMS ("Set Anchor" 'SET-ANCHOR "Corner of the display to be anchored" ) ("Set Position" 'SET-POSITION "Position of display (relative to anchor)") ("Set Justification" 'SET-JUSTIFICATION "Windows to be shrunk or grown depending on maximum filename width" ))) ("Quit File Watcher" 'QUIT ""] [if (NOT (type? MENU FW-InteractMenu)) then (SETQ FW-InteractMenu (create MENU TITLE _ "FileWatch:" CENTERFLG _ T MENUOFFSET _ (CONS -1 58) CHANGEOFFSETFLG _ 'Y ITEMS _ (COPY ITEMS] (if (NULL (CDDDR (FASSOC 'FileWatch BackgroundMenuCommands))) then (* ;; "Not there, or no subitems (older version)") (for C in FW-Commands do (SETQ ITEMS (SUBST `'(FILEWATCH ',C) `',C ITEMS))) [push BackgroundMenuCommands (COPY `(FileWatch '(FILEWATCH 'ON) "Display and continuously update list of open files and and the location of their file pointers" (SUBITEMS ,@ITEMS] (SETQ BackgroundMenu]) (FW-INIT-PROPS [LAMBDA NIL (* ; "Edited 22-Sep-87 14:30 by Koomen") (DECLARE (GLOBALVARS FW-AllFiles? FW-Anchor FW-Filters FW-Font FW-Interval FW-Justified? FW-Position FW-Properties FW-Shade FW-SortFn)) [SETQ FW-AllFiles? (NOT (NULL (LISTGET FW-Properties 'ALL-FILES?] (SETQ FW-Anchor (OR [CAR (MEMB (LISTGET FW-Properties 'ANCHOR) '(TOP-LEFT TOP-RIGHT BOTTOM-LEFT BOTTOM-RIGHT] 'BOTTOM-LEFT)) (* ;; "precompile filters for matching. Note that the system function DIRECTORY.MATCH.SETUP strips off the host, so we have to match it seperatedly.") (SETQ FW-Filters (for FILTER inside (LISTGET FW-Properties 'FILTERS) join (if (OR (STRINGP FILTER) (LITATOM FILTER)) then (SETQ FILTER (DIRECTORY.FILL.PATTERN FILTER)) (LIST (CONS (DIRECTORY.MATCH.SETUP (OR (FILENAMEFIELD FILTER 'HOST) "*")) (DIRECTORY.MATCH.SETUP FILTER))) else (printout PROMPTWINDOW 0 "FileWatch: filter not a string or symbol: " T FILTER " ignored." T) NIL))) [SETQ FW-Font (FONTCREATE (LISTGET FW-Properties 'FONT] [SETQ FW-Interval (FIXP (LISTGET FW-Properties 'INTERVAL] [SETQ FW-Justified? (NOT (NULL (LISTGET FW-Properties 'JUSTIFIED?] (SETQ FW-Position (OR (POSITIONP (LISTGET FW-Properties 'POSITION)) (create POSITION XCOORD _ 0 YCOORD _ 0))) (LET ((X (fetch (POSITION XCOORD) of FW-Position)) (Y (fetch (POSITION YCOORD) of FW-Position)) (W SCREENWIDTH) (H SCREENHEIGHT) (XMIN 100) (XMAX (IDIFFERENCE SCREENWIDTH 100)) (YMIN 100) (YMAX (IDIFFERENCE SCREENHEIGHT 100))) (SELECTQ FW-Anchor (TOP-LEFT (if (IGEQ X XMAX) then (SETQ X XMAX)) (if (ILEQ Y YMIN) then (SETQ Y YMIN))) (TOP-RIGHT (if (ILEQ X XMIN) then (SETQ X XMIN)) (if (ILEQ Y YMIN) then (SETQ Y YMIN))) (BOTTOM-LEFT (if (IGEQ X XMAX) then (SETQ X XMAX)) (if (IGEQ Y YMAX) then (SETQ Y YMAX))) (BOTTOM-RIGHT (if (ILEQ X XMIN) then (SETQ X XMIN)) (if (IGEQ Y YMAX) then (SETQ Y YMAX))) (SHOULDNT)) (SETQ FW-Position (create POSITION XCOORD _ X YCOORD _ Y))) [SETQ FW-Shade (SMALLP (LISTGET FW-Properties 'SHADE] (SETQ FW-SortFn (LET [(FN (LISTGET FW-Properties 'SORTFN] (if (AND (LITATOM FN) (GETD FN)) then FN]) (FW-INTERACT [LAMBDA (W MENUCMD) (* Koomen "15-May-87 01:03") (DECLARE (GLOBALVARS FW-InteractMenu FW-Running?)) (SELECTQ (OR MENUCMD (SETQ MENUCMD (MENU FW-InteractMenu))) (NIL NIL) (FORGET (FW-FORGET-CMD W)) (FORGET-MANY (FW-FORGET-CMD W T)) (RECALL (FW-RECALL-CMD)) (RECALL-MANY (FW-RECALL-CMD T)) (CLOSE (FW-CLOSE-CMD W)) (CLOSE-MANY (FW-CLOSE-CMD W T)) (MOVE (FW-MOVE-OFD-WINDOWS)) (SET-ANCHOR (FW-MOVE-OFD-WINDOWS 'ANCHOR)) (SET-POSITION (FW-MOVE-OFD-WINDOWS 'POSITION)) (SET-JUSTIFICATION (FW-MOVE-OFD-WINDOWS 'JUSTIFIED?)) (QUIT (SETQ FW-Running? NIL)) (PROMPTPRINT "Unrecognized FileWatch Control Menu command: " MENUCMD]) (FW-LOOP [LAMBDA NIL (* ; "Edited 30-Sep-87 11:53 by Koomen") (DECLARE (GLOBALVARS FW-Dormant? FW-Interval FW-OpenFiles FW-ReInit? FW-Reset? FW-Running?)) (bind OPENFILES first (FW-INIT) while FW-Running? do (if (NOT FW-Dormant?) then (SETQ OPENFILES (FW-OPENP)) (if (OR FW-Reset? FW-ReInit? (NOT (EQUAL OPENFILES FW-OpenFiles))) then (if FW-ReInit? then (FW-RE-INIT)) (FW-RESET) (if (SETQ FW-OpenFiles (APPEND OPENFILES)) then (FW-CREATE-OFD-LIST) (FW-CREATE-OFD-WINDOWS) else (FW-CLOSE-OLD-OFD-WINDOWS)) (SETQ FW-ReInit?)) (FW-UPDATE-OFD-WINDOWS)) (BLOCK FW-Interval) finally (FW-WIPE]) (FW-MOVE-OFD-WINDOWS [LAMBDA (WHAT) (* Koomen "16-Apr-87 15:55") (if (OR (NULL WHAT) (EQ WHAT 'ANCHOR)) then (FW-CHANGE-ANCHOR)) (if (OR (NULL WHAT) (EQ WHAT 'POSITION)) then (FW-CHANGE-POSITION)) (if (OR (NULL WHAT) (EQ WHAT 'JUSTIFIED?)) then (FW-CHANGE-JUSTIFICATION]) (FW-MOVEW [LAMBDA (OFD) (* Koomen "29-Sep-86 23:10") (MOVEW (fetch (FW-OFD OFDWINDOW) of OFD) (replace (FW-OFD OFDLEFT) of OFD with (fetch (FW-OFD LEFT) of OFD)) (replace (FW-OFD OFDBOTTOM) of OFD with (fetch (FW-OFD BOTTOM) of OFD]) (FW-OFD-EXISTS? [LAMBDA (FULLNAME FILESTREAM) (* ; "Edited 22-Sep-87 13:27 by Koomen") (DECLARE (GLOBALVARS FW-OFDList FW-ReInit?)) (for OFD in FW-OFDList when (AND (EQ (fetch (FW-OFD FULLNAME) of OFD) FULLNAME) (EQ (fetch (FW-OFD FILESTREAM) of OFD) FILESTREAM) (EQ (fetch (FW-OFD READING?) of OFD) (if (OPENP FILESTREAM 'INPUT) then T)) (EQ (fetch (FW-OFD WRITING?) of OFD) (if (OPENP FILESTREAM 'OUTPUT) then T))) do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (OLD (replace (FW-OFD OFDSTATUS) of OFD with (if FW-ReInit? then 'NEW else 'CURRENT)) (RETURN T)) ((NEW CURRENT FORGOTTEN) (RETURN T)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-OPENP [LAMBDA NIL (* ; "Edited 22-Sep-87 11:32 by Koomen") (* ;; "Computes the list of currently open files (actually, streams). If the globalvar FW-AllFiles? is non-NIL, streams with flag USERVISIBLE=NIL are included as well.") (* ;;  "Note: Uses a scratchlist, so be sure to copy result if you need it across calls to FW-OPENP") (DECLARE (GLOBALVARS FW-AllFiles? FW-OpenP-ScratchList \FILEDEVICES)) (SCRATCHLIST FW-OpenP-ScratchList (for FD in \FILEDEVICES bind OPENPFN do (SETQ OPENPFN (fetch (FDEV OPENP) of FD)) (if (EQ OPENPFN '\GENERIC.OPENP) then (for S in (fetch (FDEV OPENFILELST) of FD) when (OR FW-AllFiles? (fetch (STREAM USERVISIBLE) of S)) do (ADDTOSCRATCHLIST S)) else (for FNAME in (APPLY* OPENPFN NIL NIL FD) do (ADDTOSCRATCHLIST (\GETSTREAM FNAME]) (FW-PERCENTAGE [LAMBDA (X Y) (* ; "Edited 30-Sep-87 01:00 by Koomen") (if (IGEQ X Y) then 100 elseif (IGREATERP X 0) then (IQUOTIENT (ITIMES X 100) Y) else 0]) (FW-RE-INIT [LAMBDA NIL (* ; "Edited 22-Sep-87 13:05 by Koomen") (* * Called from FW-INIT, or from FW-LOOP because a prop has changed.) (DECLARE (GLOBALVARS FW-AccessTab FW-AccessWidth FW-CurPosTab FW-EofPosTab FW-FieldWidth FW-Font FW-OFDList FW-PercentHeight FW-PercentTab FW-PercentWidth FW-SeprWidth FW-WindowBottom FW-WindowHeight FW-WindowNoNameWidth WBorder)) (FW-INIT-PROPS) (SETQ FW-SeprWidth (STRINGWIDTH "AA" FW-Font)) (SETQ FW-AccessWidth (IMAX (STRINGWIDTH "b " FW-Font) (STRINGWIDTH "r " FW-Font) (STRINGWIDTH "w " FW-Font))) (SETQ FW-FieldWidth (STRINGWIDTH "99999999" FW-Font)) (SETQ FW-PercentWidth (ITIMES 2 FW-FieldWidth)) [SETQ FW-PercentHeight (IDIFFERENCE (FONTHEIGHT FW-Font) (ITIMES 2 (ADD1 (FONTPROP FW-Font 'DESCENT] (SETQ FW-CurPosTab FW-SeprWidth) (SETQ FW-EofPosTab (IPLUS FW-CurPosTab FW-FieldWidth FW-SeprWidth)) (SETQ FW-PercentTab (IPLUS FW-EofPosTab FW-FieldWidth FW-SeprWidth)) (SETQ FW-AccessTab (IPLUS FW-PercentTab FW-FieldWidth FW-PercentWidth FW-SeprWidth)) (SETQ FW-WindowNoNameWidth (WIDTHIFWINDOW (IPLUS FW-AccessTab FW-AccessWidth) WBorder)) (SETQ FW-WindowBottom 0) (SETQ FW-WindowHeight (HEIGHTIFWINDOW (FONTHEIGHT FW-Font) NIL WBorder)) (for OFD in FW-OFDList do (DSPFONT FW-Font (fetch (FW-OFD OFDSTREAM) of OFD)) (replace (FW-OFD NAMEWIDTH) of OFD with (STRINGWIDTH (fetch (FW-OFD FULLNAME) of OFD) FW-Font)) (FW-RESIZE-OFD OFD]) (FW-RECALL-CMD [LAMBDA (MANY?) (* Koomen "14-May-87 23:46") (DECLARE (GLOBALVARS FW-OFDList FW-Reset?)) (PROG (FORGOTTEN-OFDS RECALL-OFD) (SETQ FORGOTTEN-OFDS (for OFD in FW-OFDList when (EQ (fetch (FW-OFD OFDSTATUS ) of OFD) 'FORGOTTEN) collect OFD)) (if (NULL FORGOTTEN-OFDS) then (PROMPTPRINT "FileWatch: no forgotten files.") (RETURN)) RECALL-ANOTHER [SETQ RECALL-OFD (MENU (create MENU TITLE _ "Select file to recall: " CENTERFLG _ T ITEMS _ (for OFD in FORGOTTEN-OFDS collect (LIST (fetch (FW-OFD FULLNAME) of OFD) (KWOTE OFD] (if (NULL RECALL-OFD) then (RETURN)) (replace (FW-OFD OFDSTATUS) of RECALL-OFD with (if (OPENP (fetch (FW-OFD FULLNAME) of RECALL-OFD)) then (FW-UPDATE-OFD-WINDOW RECALL-OFD T) 'CURRENT else (PROMPTPRINT "FileWatch: file has been closed.") 'OLD)) (SETQ FW-Reset? T) (if (AND MANY? (SETQ FORGOTTEN-OFDS (REMOVE RECALL-OFD FORGOTTEN-OFDS))) then (GO RECALL-ANOTHER]) (FW-REPAINTFN [LAMBDA (W) (* Koomen "25-Sep-86 00:44") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList when (EQ W (fetch (FW-OFD OFDWINDOW) of OFD)) do (if (OPENP (fetch (FW-OFD OFDSTREAM) of OFD)) then (FW-UPDATE-OFD-WINDOW OFD T)) (RETURN]) (FW-RESET [LAMBDA NIL (* Koomen "29-Sep-86 23:20") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (CURRENT (replace (FW-OFD OFDSTATUS) of OFD with 'OLD)) ((OLD FORGOTTEN)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-RESIZE-OFD [LAMBDA (OFD MAXNAMEWIDTH) (* ; "Edited 22-Sep-87 12:56 by Koomen") (* * If MAXNAMEWIDTH=NIL, uses OFD's own NAMEWIDTH) (DECLARE (GLOBALVARS FW-AccessTab FW-Anchor FW-CurPosTab FW-EofPosTab FW-PercentHeight FW-PercentTab FW-PercentWidth FW-Position FW-WindowBottom FW-WindowHeight FW-WindowNoNameWidth)) (PROG [(NAMEWIDTH (OR MAXNAMEWIDTH (fetch (FW-OFD NAMEWIDTH) of OFD] (replace (FW-OFD WIDTH) of OFD with (IPLUS FW-WindowNoNameWidth NAMEWIDTH)) (replace (FW-OFD HEIGHT) of OFD with FW-WindowHeight) (replace (FW-OFD LEFT) of OFD with (SELECTQ FW-Anchor ((TOP-LEFT BOTTOM-LEFT) (fetch (POSITION XCOORD) of FW-Position)) ((TOP-RIGHT BOTTOM-RIGHT) (IDIFFERENCE (fetch (POSITION XCOORD) of FW-Position) (fetch (FW-OFD WIDTH) of OFD))) (ERROR "Unsupported anchor spec: " FW-Anchor))) (replace (FW-OFD BOTTOM) of OFD with FW-WindowBottom) (replace (FW-OFD CURPOSXOFFSET) of OFD with (IPLUS FW-CurPosTab NAMEWIDTH)) (replace (FW-OFD EOFPOSXOFFSET) of OFD with (IPLUS FW-EofPosTab NAMEWIDTH)) (replace (FW-OFD PCTPOSXOFFSET) of OFD with (IPLUS FW-PercentTab NAMEWIDTH)) (replace (FW-OFD ACCESSXOFFSET) of OFD with (IPLUS FW-AccessTab NAMEWIDTH)) (replace (FW-OFD PCTREGION) of OFD with (create REGION LEFT _ NIL BOTTOM _ NIL WIDTH _ FW-PercentWidth HEIGHT _ FW-PercentHeight)) (RETURN OFD]) (FW-SHAPEW [LAMBDA (OFD) (* Koomen "29-Sep-86 23:09") (SHAPEW (fetch (FW-OFD OFDWINDOW) of OFD) (create REGION LEFT _ (replace (FW-OFD OFDLEFT) of OFD with (fetch (FW-OFD LEFT) of OFD)) BOTTOM _ (replace (FW-OFD OFDBOTTOM) of OFD with (fetch (FW-OFD BOTTOM) of OFD)) WIDTH _ (replace (FW-OFD OFDWIDTH) of OFD with (fetch (FW-OFD WIDTH) of OFD)) HEIGHT _ (replace (FW-OFD OFDHEIGHT) of OFD with (fetch (FW-OFD HEIGHT) of OFD]) (FW-SORT-FN [LAMBDA (OFD1 OFD2) (* Koomen "24-Sep-86 23:24") (DECLARE (GLOBALVARS FW-Anchor FW-SortFn)) (SELECTQ FW-Anchor ((TOP-LEFT TOP-RIGHT) (* growing downwards *) (APPLY* FW-SortFn (fetch (FW-OFD FULLNAME) of OFD2) (fetch (FW-OFD FULLNAME) of OFD1))) ((BOTTOM-LEFT BOTTOM-RIGHT) (* growing upwards *) (APPLY* FW-SortFn (fetch (FW-OFD FULLNAME) of OFD1) (fetch (FW-OFD FULLNAME) of OFD2))) (ERROR "Unsupported anchor spec: " FW-Anchor]) (FW-UPDATE-OFD-WINDOW [LAMBDA (OFD NEW?) (* ; "Edited 22-Sep-87 12:43 by Koomen") (DECLARE (GLOBALVARS FW-PercentHeight FW-PercentWidth FW-Shade)) (PROG ((OFDSTREAM (fetch (FW-OFD OFDSTREAM) of OFD)) (FILESTREAM (fetch (FW-OFD FILESTREAM) of OFD)) (OLDCURPOS (fetch (FW-OFD CURPOS) of OFD)) (OLDEOFPOS (fetch (FW-OFD EOFPOS) of OFD)) (OLDPCTPOS (fetch (FW-OFD PCTPOS) of OFD)) (PCTREGION (fetch (FW-OFD PCTREGION) of OFD)) (BOXBORDER 1) NEWCURPOS NEWEOFPOS NEWPCTPOS X Y) (if (NOT (OPENP FILESTREAM)) then (* * May just have created some windows, in which case there may have been a  BLOCK underneath during which this file was closed, so make sure file is still  open) (RETURN)) (SETQ NEWCURPOS (GETFILEPTR FILESTREAM)) (SETQ NEWEOFPOS (if (NOT (fetch (FW-OFD WRITING?) of OFD)) then OLDEOFPOS elseif (NOT (fetch (FW-OFD RANDOM?) of OFD)) then NEWCURPOS else (GETEOFPTR FILESTREAM))) (if (AND (FIXP NEWCURPOS) (FIXP NEWEOFPOS)) then (if (ILESSP NEWEOFPOS NEWCURPOS) then (SETQ NEWEOFPOS NEWCURPOS)) elseif (FIXP NEWCURPOS) then (SETQ NEWEOFPOS NEWCURPOS) elseif (FIXP NEWEOFPOS) then (SETQ NEWCURPOS NEWEOFPOS) else (SETQ NEWCURPOS (SETQ NEWEOFPOS 0))) (SETQ NEWPCTPOS (FW-PERCENTAGE NEWCURPOS NEWEOFPOS)) (if NEW? then (DSPRESET OFDSTREAM) (printout OFDSTREAM (fetch (FW-OFD FULLNAME) of OFD)) (DSPXPOSITION (fetch (FW-OFD ACCESSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM (LET ((R (fetch (FW-OFD READING?) of OFD)) (W (fetch (FW-OFD WRITING?) of OFD))) (if (AND R W) then "b" elseif R then "r" elseif W then "w" else "*"))) (replace (FW-OFD OFDSTATUS) of OFD with 'CURRENT)) (if (OR NEW? (NOT (EQUAL NEWCURPOS OLDCURPOS))) then (DSPXPOSITION (fetch (FW-OFD CURPOSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM |.I8| NEWCURPOS) (replace (FW-OFD CURPOS) of OFD with NEWCURPOS)) (if (OR NEW? (NOT (EQUAL NEWEOFPOS OLDEOFPOS))) then (DSPXPOSITION (fetch (FW-OFD EOFPOSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM |.I8| NEWEOFPOS) (replace (FW-OFD EOFPOS) of OFD with NEWEOFPOS)) (if (OR NEW? (NOT (EQUAL NEWPCTPOS OLDPCTPOS))) then (DSPXPOSITION (fetch (FW-OFD PCTPOSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM |.I5| NEWPCTPOS) (printout OFDSTREAM " %% ") [SETQ X (OR (fetch (REGION LEFT) of PCTREGION) (replace (REGION LEFT) of PCTREGION with (IPLUS BOXBORDER (DSPXPOSITION NIL OFDSTREAM] [SETQ Y (OR (fetch (REGION BOTTOM) of PCTREGION) (replace (REGION BOTTOM) of PCTREGION with (ADD1 (DSPYPOSITION NIL OFDSTREAM] (if (OR NEW? (ILESSP NEWPCTPOS (OR OLDPCTPOS 100))) then (GRAYBOXAREA X Y FW-PercentWidth FW-PercentHeight BOXBORDER BLACKSHADE OFDSTREAM)) (replace (REGION WIDTH) of PCTREGION with (IQUOTIENT (ITIMES NEWPCTPOS FW-PercentWidth ) 100)) (DSPFILL PCTREGION FW-Shade NIL OFDSTREAM) (replace (FW-OFD PCTPOS) of OFD with NEWPCTPOS]) (FW-UPDATE-OFD-WINDOWS [LAMBDA NIL (* Koomen " 9-Oct-86 17:18") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (NEW (FW-UPDATE-OFD-WINDOW OFD T)) (CURRENT (FW-UPDATE-OFD-WINDOW OFD)) ((OLD FORGOTTEN)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-WIPE [LAMBDA NIL (* Koomen "15-May-87 01:49") (DECLARE (GLOBALVARS FW-AllFiles? FW-Anchor FW-CurPosTab FW-EofPosTab FW-FieldWidth FW-Filters FW-Font FW-FullNameWidth FW-Interval FW-Justified? FW-OFDList FW-OpenFiles FW-PercentHeight FW-PercentTab FW-PercentWidth FW-Position FW-ReInit? FW-Reset? FW-Running? FW-SeprWidth FW-Shade FW-SortFn FW-WindowBottom FW-WindowBottomDelta FW-WindowHeight FW-WindowNoNameWidth)) (* * Clean up possible left-overs, then set all private vars to NIL) (for OFD in FW-OFDList do (CLOSEW (fetch (FW-OFD OFDWINDOW) of OFD))) (SETQ FW-AllFiles?) (SETQ FW-Anchor) (SETQ FW-CurPosTab) (SETQ FW-EofPosTab) (SETQ FW-FieldWidth) (SETQ FW-Filters) (SETQ FW-Font) (SETQ FW-FullNameWidth) (SETQ FW-Interval) (SETQ FW-Justified?) (SETQ FW-OFDList) (SETQ FW-OpenFiles) (SETQ FW-PercentHeight) (SETQ FW-PercentWidth) (SETQ FW-PercentTab) (SETQ FW-Position) (SETQ FW-ReInit?) (SETQ FW-Reset?) (SETQ FW-Running?) (SETQ FW-SeprWidth) (SETQ FW-Shade) (SETQ FW-SortFn) (SETQ FW-WindowBottom) (SETQ FW-WindowBottomDelta) (SETQ FW-WindowHeight) (SETQ FW-WindowNoNameWidth]) ) (DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE [OR (HASDEF 'FDEV 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'FDEV] [OR (HASDEF 'STREAM 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'STREAM] ) (RPAQ? FW-OFDList NIL) (RPAQ? FW-OpenP-ScratchList (CONS)) (RPAQ? FW-Commands (COPY '(FORGET FORGET-MANY RECALL RECALL-MANY CLOSE CLOSE-MANY MOVE SET-ANCHOR SET-POSITION SET-JUSTIFICATION QUIT))) (RPAQ? FW-Properties (COPY `(FONT (GACHA 8) ALL-FILES? T POSITION ,(CREATEPOSITION SCREENWIDTH 0) ANCHOR BOTTOM-RIGHT SHADE ,GRAYSHADE INTERVAL 1000))) (FW-INIT-MENUS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FILEWATCHPROP) ) (PUTPROPS FILEWATCH COPYRIGHT ("Johannes A. G. M. Koomen" 1986 1987 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3178 5622 (FILEWATCH 3188 . 4757) (FILEWATCHPROP 4759 . 5620)) (8016 62486 ( FW-ADJUST-PLACEMENT 8026 . 10093) (FW-ADJUST-REGION 10095 . 12049) (FW-AFTERMOVEFN 12051 . 14076) ( FW-BUTTONEVENTFN 14078 . 14504) (FW-CHANGE-ANCHOR 14506 . 15460) (FW-CHANGE-JUSTIFICATION 15462 . 15959) (FW-CHANGE-POSITION 15961 . 18279) (FW-CLOSE-CMD 18281 . 21446) (FW-CLOSE-OLD-OFD-WINDOWS 21448 . 22228) (FW-CLOSEFN 22230 . 22914) (FW-CREATE-OFD 22916 . 23971) (FW-CREATE-OFD-LIST 23973 . 25490) (FW-CREATE-OFD-WINDOWS 25492 . 26775) (FW-CREATEW 26777 . 29749) (FW-FILTERED-FILE? 29751 . 30429) ( FW-FORGET-CMD 30431 . 32080) (FW-INIT 32082 . 32497) (FW-INIT-MENUS 32499 . 35781) (FW-INIT-PROPS 35783 . 39386) (FW-INTERACT 39388 . 40238) (FW-LOOP 40240 . 41363) (FW-MOVE-OFD-WINDOWS 41365 . 41810) (FW-MOVEW 41812 . 42240) (FW-OFD-EXISTS? 42242 . 43870) (FW-OPENP 43872 . 45128) (FW-PERCENTAGE 45130 . 45419) (FW-RE-INIT 45421 . 47543) (FW-RECALL-CMD 47545 . 49616) (FW-REPAINTFN 49618 . 50020) ( FW-RESET 50022 . 50758) (FW-RESIZE-OFD 50760 . 53318) (FW-SHAPEW 53320 . 54550) (FW-SORT-FN 54552 . 55240) (FW-UPDATE-OFD-WINDOW 55242 . 60335) (FW-UPDATE-OFD-WINDOWS 60337 . 61086) (FW-WIPE 61088 . 62484))))) STOP \ No newline at end of file diff --git a/lispusers/FILEWATCH.TEDIT b/lispusers/FILEWATCH.TEDIT new file mode 100644 index 00000000..a4270c79 Binary files /dev/null and b/lispusers/FILEWATCH.TEDIT differ diff --git a/lispusers/FILLREGION b/lispusers/FILLREGION new file mode 100644 index 00000000..0a324ec6 --- /dev/null +++ b/lispusers/FILLREGION @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 9-Mar-87 18:02:40" {ERINYES}LISPUSERS>FILLREGION.;5 20221 changes to%: (FNS FILL.KERNEL FILL.REGION) (VARS FILLREGIONCOMS) (FUNCTIONS psetf) (MACROS POP.TASK) previous date%: "15-Mar-85 03:07:57" {ERINYES}LISPUSERS>FILLREGION.;1) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILLREGIONCOMS) (RPAQQ FILLREGIONCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES PSETF) (MACROS ADD.TASK CIRCLE.ABOUT DEC.X DEC.Y FINISH.ORIENTATION INC.X INC.Y NEXT.POINT.ON.CURVE POP.TASK RIGHT.BIT SEARCH SEARCH.AND.FILL SET.BIT TEST.BIT WANT.TO.EXTEND) (RECORDS TASK)) (FNS * \FILLREGION.FNS) (FUNCTIONS psetf) (BLOCKS * (LIST (APPEND '(FILLREGION) \FILLREGION.FNS '((ENTRIES AUTO.FILL FILL.REGION) (GLOBALVARS BITMASKARRAY) (LOCALVARS . T]) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD PSETF) (DECLARE%: EVAL@COMPILE [PUTPROPS ADD.TASK MACRO ((STARTW STARTM) (if FREELIST then (create TASK W _ STARTW M _ STARTM smashing (PROG1 (CAR FREELIST) (psetf FREELIST (CDR FREELIST) (CDR FREELIST) AGENDA AGENDA FREELIST))) else (push AGENDA (create TASK W _ STARTW M _ STARTM] [PUTPROPS CIRCLE.ABOUT MACRO ((START.W START.M) (first (SETQ CIRCLE.WORD START.W) (SETQ CIRCLE.MASK START.M) (NEXT.POINT.ON.CURVE CIRCLE.WORD CIRCLE.MASK 6 CIRCLE.THIS.DIR) (SETQ CIRCLE.EXTEND NIL) eachtime (SETQ CIRCLE.PREV.W CIRCLE.WORD) (SETQ CIRCLE.PREV.M CIRCLE.MASK) (NEXT.POINT.ON.CURVE CIRCLE.WORD CIRCLE.MASK CIRCLE.THIS.DIR CIRCLE.NEXT.DIR) (if (WANT.TO.EXTEND CIRCLE.THIS.DIR CIRCLE.NEXT.DIR) then (if (NOT CIRCLE.EXTEND) then (SETQ CIRCLE.EXTEND T) (ADD.TASK CIRCLE.PREV.W CIRCLE.PREV.M)) else (SETQ CIRCLE.EXTEND NIL)) (SET.BIT DEST.BASE CIRCLE.PREV.W CIRCLE.PREV.M) until (AND (EQ CIRCLE.PREV.W START.W) (EQ CIRCLE.PREV.M START.M) (FINISH.ORIENTATION CIRCLE.THIS.DIR CIRCLE.NEXT.DIR)) do (SETQ CIRCLE.THIS.DIR CIRCLE.NEXT.DIR] [PUTPROPS DEC.X MACRO ((WORD MASK) (SETQ MASK (if (EQ MASK (CONSTANT (MASK.1'S 15 1))) then (add WORD -1) 1 else (LLSH MASK 1] (PUTPROPS DEC.Y MACRO ((WORD MASK) (add WORD RASTERWIDTH))) [PUTPROPS FINISH.ORIENTATION MACRO ((THIS.DIR NEXT.DIR) (IGEQ THIS.DIR (LOGXOR NEXT.DIR 4] [PUTPROPS INC.X MACRO ((WORD MASK) (SETQ MASK (if (EQ MASK 1) then (add WORD 1) (CONSTANT (MASK.1'S 15 1)) else (LRSH MASK 1] [PUTPROPS INC.Y MACRO ((WORD MASK) (SETQ WORD (IDIFFERENCE WORD RASTERWIDTH] [PUTPROPS NEXT.POINT.ON.CURVE MACRO ((WORD MASK DIN DOUT) (PROG NIL [if (IGEQ DIN 5) then (if (EQ DIN 7) then (* DIN = 7) (INC.Y WORD MASK) (GO L6) else (* DIN = 5 or 6) (INC.X WORD MASK) (GO L4)) else (if (IGEQ DIN 3) then (* DIN = 3 or 4) (DEC.Y WORD MASK) (GO L2) else (if (NEQ DIN 0) then (* DIN = 1 or 2) (DEC.X WORD MASK) (GO L0) else (* DIN = 0) (INC.Y WORD MASK) (GO L6] L0 (DEC.Y WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 0) (RETURN)) (INC.X WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 1) (RETURN)) L2 (INC.X WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 2) (RETURN)) (INC.Y WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 3) (RETURN)) L4 (INC.Y WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 4) (RETURN)) (DEC.X WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 5) (RETURN)) L6 (DEC.X WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 6) (RETURN)) (DEC.Y WORD MASK) (if (NEQ 0 (TEST.BIT SRCE.BASE WORD MASK)) then (SETQ DOUT 7) (RETURN)) (GO L0] [PUTPROPS POP.TASK MACRO (NIL (PROG1 (CAR AGENDA) (CL:PSETF AGENDA (CDR AGENDA) (CDR AGENDA) FREELIST FREELIST AGENDA] [PUTPROPS RIGHT.BIT MACRO ((X) (LOGAND X (IMINUS X] [PUTPROPS SEARCH MACRO ((WORD MASK) (PROGN (SETQ SEARCH.BITS (\GETBASE SRCE.BASE WORD)) (for old WORD first (if (NEQ MASK 1) then (if (NEQ [SETQ SEARCH.BITS (LOGAND SEARCH.BITS (LOGNOT (SUB1 MASK] 0) then (SETQ MASK (RIGHT.BIT SEARCH.BITS)) (RETURN) else (add WORD -1))) when (NEQ (SETQ SEARCH.BITS (\GETBASE SRCE.BASE WORD)) 0) do (SETQ MASK (RIGHT.BIT SEARCH.BITS)) (RETURN) by (SUB1 WORD] [PUTPROPS SEARCH.AND.FILL MACRO ((WORD MASK) (PROGN (SETQ SEARCH.BITS (\GETBASE SRCE.BASE WORD)) (for old WORD first [if (NEQ MASK 1) then [SETQ SEARCH.MASKEDBITS (LOGAND SEARCH.BITS (SETQ SEARCH.EXTENDEDMASK (LOGXOR (SUB1 MASK) (CONSTANT (MASK.1'S 0 16] (if (NEQ SEARCH.MASKEDBITS 0) then [\PUTBASE DEST.BASE WORD (LOGOR (SETQ FILL.BITS (\GETBASE DEST.BASE WORD) ) (LOGAND SEARCH.EXTENDEDMASK (SUB1 (SETQ MASK (RIGHT.BIT SEARCH.MASKEDBITS ] (RETURN (LOGAND FILL.BITS MASK)) else (\PUTBASE DEST.BASE WORD (LOGOR (\GETBASE DEST.BASE WORD) SEARCH.EXTENDEDMASK)) (SETQ WORD (SUB1 WORD] when (NEQ (SETQ SEARCH.BITS (\GETBASE SRCE.BASE WORD)) 0) do [\PUTBASE DEST.BASE WORD (LOGOR (SETQ FILL.BITS (\GETBASE DEST.BASE WORD)) (SUB1 (SETQ MASK (RIGHT.BIT SEARCH.BITS] (RETURN (LOGAND FILL.BITS MASK)) by (PROGN (\PUTBASE DEST.BASE WORD (CONSTANT (MASK.1'S 0 16))) (SUB1 WORD] [PUTPROPS SET.BIT MACRO ((BASE WORD MASK) (change (fetch (BITMAPWORD BITS) of (\ADDBASE BASE WORD)) (LOGOR DATUM MASK] (PUTPROPS TEST.BIT MACRO ((BASE WORD MASK) (LOGAND (\GETBASE BASE WORD) MASK))) (PUTPROPS WANT.TO.EXTEND MACRO ((THIS.DIR NEXT.DIR) (IGREATERP (LOGAND (IDIFFERENCE THIS.DIR 3) 7) NEXT.DIR))) ) (DECLARE%: EVAL@COMPILE (RECORD TASK (W . M)) ) ) (RPAQQ \FILLREGION.FNS (AUTO.FILL FILL.KERNEL FILL.REGION REMOVE.SINGLE.POINTS)) (DEFINEQ (AUTO.FILL [LAMBDA (SHADE) (* JWogulis "28-Feb-85 09:03") (PROG ((W (WHICHW))) (GETMOUSESTATE) (RETURN (FILL.REGION W (CONS (LASTMOUSEX W) (LASTMOUSEY W)) SHADE]) (FILL.KERNEL [LAMBDA (SRCE.BASE DEST.BASE WORDNUM BITMASK RASTERWIDTH) (* mgb%: "15-Mar-85 01:54") (* * Appalling PROG structure instead of CLISP is to permit only one expansion  of CIRCLE.ABOUT macro) (PROG (TASK.W TASK.M AGENDA FREELIST TASK CIRCLE.PREV.W CIRCLE.PREV.M CIRCLE.WORD CIRCLE.MASK CIRCLE.THIS.DIR CIRCLE.NEXT.DIR CIRCLE.EXTEND SEARCH.BITS SEARCH.EXTENDEDMASK SEARCH.MASKEDBITS FILL.BITS KERNEL.WORD KERNEL.MASK KERNEL.THIS.DIR KERNEL.NEXT.DIR INITIALIZED) (SETQ KERNEL.WORD WORDNUM) (SETQ KERNEL.MASK BITMASK) (INC.X KERNEL.WORD KERNEL.MASK) (SEARCH KERNEL.WORD KERNEL.MASK) (GO DO.CIRCLE) TASK.LOOP (if (NULL AGENDA) then (RETURN)) (SETQ TASK (POP.TASK)) (SETQ TASK.W (fetch (TASK W) of TASK)) (SETQ TASK.M (fetch (TASK M) of TASK)) (SETQ KERNEL.NEXT.DIR 2) SEED.LOOP (SETQ KERNEL.THIS.DIR KERNEL.NEXT.DIR) (SETQ KERNEL.WORD TASK.W) (SETQ KERNEL.MASK TASK.M) (NEXT.POINT.ON.CURVE TASK.W TASK.M KERNEL.THIS.DIR KERNEL.NEXT.DIR) (if [NOT (AND (WANT.TO.EXTEND KERNEL.THIS.DIR KERNEL.NEXT.DIR) (PROGN (DEC.X KERNEL.WORD KERNEL.MASK) (EQ 0 (TEST.BIT DEST.BASE KERNEL.WORD KERNEL.MASK] then (GO TASK.LOOP)) (if (NEQ 0 (SEARCH.AND.FILL KERNEL.WORD KERNEL.MASK)) then (GO SEED.LOOP)) DO.CIRCLE (CIRCLE.ABOUT KERNEL.WORD KERNEL.MASK) (if INITIALIZED then (GO SEED.LOOP) else (SETQ INITIALIZED T) (GO TASK.LOOP]) (FILL.REGION [LAMBDA (WINDOW.OR.BM INTERIOR.POS SHADE) (* mgb%: "15-Mar-85 01:51") (* * This function has been "optimised" for performance.  Any resemblance to structured programming is purely coincidental.) [PROG ((X (CAR INTERIOR.POS)) (Y (CDR INTERIOR.POS)) WIDTH HEIGHT SRCE.BM SRCE.BASE DEST.BM DEST.BASE INVERTFLG? RASTERWIDTH TEMP.SHADE) (if (WINDOWP WINDOW.OR.BM) then (SETQ WIDTH (WINDOWPROP WINDOW.OR.BM 'WIDTH)) (SETQ HEIGHT (WINDOWPROP WINDOW.OR.BM 'HEIGHT)) elseif (BITMAPP WINDOW.OR.BM) then (SETQ WIDTH (BITMAPWIDTH WINDOW.OR.BM)) (SETQ HEIGHT (BITMAPHEIGHT WINDOW.OR.BM)) else (RETURN (ERROR "Must be either window or bitmap:" WINDOW.OR.BM))) (if (OR (LESSP X 0) (LESSP Y 0) (IGEQ X WIDTH) (IGEQ Y HEIGHT)) then (RETURN (ERROR "Outside of the window or bitmap:" INTERIOR.POS))) (add WIDTH 2) (add HEIGHT 2) (SETQ SRCE.BM (BITMAPCREATE WIDTH HEIGHT)) (SETQ DEST.BM (BITMAPCREATE WIDTH HEIGHT)) (SETQ INVERTFLG? (NEQ 0 (BITMAPBIT WINDOW.OR.BM X Y))) (* Above%: INVERTFLG? is T if we start on a black pixel instead of a white one.  XPOS will be the x position of the bitmap that is the first point on the edge  of the figure to be filled.) (SETQ SRCE.BASE (ffetch BITMAPBASE of SRCE.BM)) (SETQ RASTERWIDTH (ffetch BITMAPRASTERWIDTH of SRCE.BM)) (SETQ DEST.BASE (ffetch BITMAPBASE of DEST.BM)) (BITBLT WINDOW.OR.BM 0 0 SRCE.BM 1 1 NIL NIL (if INVERTFLG? then 'INVERT)) (* This will remove all the points in the window that have no one adjacent.  This is a special case and be dealt with more easily at thislevel than in the  program.) (REMOVE.SINGLE.POINTS SRCE.BM DEST.BM) (BITBLT DEST.BM 0 0 SRCE.BM 0 0 NIL NIL 'INPUT 'ERASE) (* NOW DO SOMETHING REALLY UGLY. Here we put a 1 bit border around the whole  window (which has been enlarged to hold it) so that we never run off the edge  and the window gets filled up. This also makes the fast versions of BITMAPBIT  fast, i.e. no checking for within the boundaries.) (BITBLT NIL NIL NIL SRCE.BM 0 0 1 NIL 'TEXTURE NIL 65535) (BITBLT NIL NIL NIL SRCE.BM 0 0 NIL 1 'TEXTURE NIL 65535) (BITBLT NIL NIL NIL SRCE.BM 0 (SUB1 HEIGHT) NIL 1 'TEXTURE NIL 65535) (BITBLT NIL NIL NIL SRCE.BM (SUB1 WIDTH) 0 1 NIL 'TEXTURE NIL 65535) (FILL.KERNEL SRCE.BASE DEST.BASE (IPLUS (LRSH X 4) (ITIMES (SUB1 (IDIFFERENCE HEIGHT (ADD1 Y))) RASTERWIDTH)) (ELT BITMASKARRAY (LOGAND X 15)) RASTERWIDTH) (BITBLT DEST.BM 1 1 WINDOW.OR.BM 0 0 NIL NIL 'MERGE (if INVERTFLG? then 'ERASE else 'PAINT) (if (NOT INVERTFLG?) then SHADE elseif (BITMAPP SHADE) then (SETQ TEMP.SHADE (BITMAPCREATE (BITMAPWIDTH SHADE) (BITMAPHEIGHT SHADE))) (BITBLT SHADE NIL NIL TEMP.SHADE NIL NIL NIL NIL 'INVERT) TEMP.SHADE else (LOGNOT SHADE] WINDOW.OR.BM]) (REMOVE.SINGLE.POINTS [LAMBDA (BITMAP RESULT.BM) (* edited%: " 8-Mar-85 01:22") (BITBLT BITMAP 0 0 RESULT.BM) (for X from -1 to 1 do (for Y from -1 to 1 do (if (NOT (AND (EQ 0 X) (EQ 0 Y))) then (BITBLT BITMAP X Y RESULT.BM 0 0 NIL NIL 'INPUT 'ERASE]) ) (DEFMACRO psetf (&BODY XCL-USER::BODY) (CL:APPEND (LIST 'CL:PSETF) XCL-USER::BODY)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: FILLREGION AUTO.FILL FILL.KERNEL FILL.REGION REMOVE.SINGLE.POINTS (ENTRIES AUTO.FILL FILL.REGION) (GLOBALVARS BITMASKARRAY) (LOCALVARS . T)) ) (PUTPROPS FILLREGION COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (13174 19700 (AUTO.FILL 13184 . 13495) (FILL.KERNEL 13497 . 15318) (FILL.REGION 15320 . 19281) (REMOVE.SINGLE.POINTS 19283 . 19698))))) STOP \ No newline at end of file diff --git a/lispusers/FILLREGION.TEDIT b/lispusers/FILLREGION.TEDIT new file mode 100644 index 00000000..d7c4b670 Binary files /dev/null and b/lispusers/FILLREGION.TEDIT differ diff --git a/lispusers/FIND-CITATION b/lispusers/FIND-CITATION new file mode 100644 index 00000000..ea4c7022 --- /dev/null +++ b/lispusers/FIND-CITATION @@ -0,0 +1 @@ +(FILECREATED "25-Nov-86 13:31:13" {PHYLUM}LISP>FIND-CITATION.;8 7942 changes to: (VARS FIND-CITATIONCOMS) previous date: "20-Nov-86 13:22:36" {PHYLUM}LISP>FIND-CITATION.;6) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT FIND-CITATIONCOMS) (RPAQQ FIND-CITATIONCOMS ((INITVARS (*citation-files* (QUOTE ({PHYLUM}DOC>BIBLIOGRAPHY.TEDIT))) (*citation-icon-pos* (CREATEPOSITION 920 600)) (*citation-region* (CREATEREGION 269 239 523 185))) (VARS *citation-mask* *citationbm*) (FNS CitationLookup) (FILES LOOKUPINFILES) (P (CitationLookup)))) (RPAQ? *citation-files* (QUOTE ({PHYLUM}DOC>BIBLIOGRAPHY.TEDIT))) (RPAQ? *citation-icon-pos* (CREATEPOSITION 920 600)) (RPAQ? *citation-region* (CREATEREGION 269 239 523 185)) (RPAQ *citation-mask* (READBITMAP)) (100 106 "H@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@OOOOOOOOOOOOOOOO@@@@@@@@@@" "@@OOOOOOOOOOOOOOOOH@@@@@@@@@" "@@OOOOOOOOOOOOOOOON@@@@@@@@@" "@@OOOOOOOOOOOOOOOOOH@@@@@@@@" "@@OOOOOOOOOOOOOOOOON@@@@@@@@" "@@OOOOOOOOOOOOOOOOOO@@@@@@@@" "@@OOOOOOOOOOOOOOOOOOL@@@@@@@" "@@OOOOOOOOOOOOOOOOOOO@@@@@@@" "@@OOOOOOOOOOOOOOOOOOOL@@@@@@" "@@OOOOOOOOOOOOOOOOOOOOH@@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@OOOOOOOOOOOOOOOOOOOOON@@@@" "@@GOOOOOOOOOOOOOOOOOOOON@@@@" "@@GOOOOOOOOOOOOOOOOOOOON@@@@" "@@COOOOOOOOOOOOOOOOOOOON@@@@" "@@AOOOOOOOOOOOOOOOOOOOON@@@@" "@@@OOOOOOOOOOOOOOOOOOOON@@@@" "@@@GOOOOOOOOOOOOOOOOOOON@@@@" "@@@COOOOOOOOOOOOOOOOOOON@@@@" "@@@AOOOOOOOOOOOOOOOOOOON@@@@" "@@@@OOOOOOOOOOOOOOOOOOON@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@" "@@@@@@@@@@@@@@@@@@@@@@@@@@@@") (RPAQ *citationbm* (READBITMAP)) (100 106 "OOOOOOOOOOOOOOOOOOOOOOOOO@@@" "OOOOOOOOOOOOOOOOOOOOOOOOO@@@" "L@@@@@@@@@@@@@@@@@@@@@@@C@@@" "L@@@@@@@@@@@@@@@@@@@@@@@C@@@" "LMKFFMKFFMKFFMKFFMKFFMKFC@@@" "LFOOOOOOOOOOOOOOOOOOKFNMC@@@" "LKOOOOOOOOOOOOOOOOONMKGFC@@@" "LFOOOOOOOOOOOOOOOOOOKFMKC@@@" "LMO@AA@@CH@@@H@H@@@GFMJMC@@@" "LKOOOOOOOOOOOOOOOOOOMKGFC@@@" "LFOH@MJH@@F@@@@@@@B@OFMKC@@@" "LMOOOOOOOOOOOHGOOOOOOMJMC@@@" "LKMO@@@@@F@@@OL@@C@@@OOFC@@@" "LKLOOOOOOOOOOOOOOOOOOOOOC@@@" "LMLGOOOOOOOOOOOOOOOOOOONC@@@" "LFLAOOOOOOOOOOOOOOOOOOOOC@@@" "LKL@CN@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@OCGNA@OMINGCCH@OC@@@" "LKL@@N@AIKAHCHCAKCGCFD@OC@@@" "LML@@N@AHCAHCHCAKCGKG@@NC@@@" "LFL@@N@AHCAHFLCAKCGKCH@OC@@@" "LKL@@N@AHCAHFLCAKCFOAL@OC@@@" "LML@@N@AIKAHONCAKCFODL@NC@@@" "LFL@@N@@OCAHLFCAINFGCH@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LJL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LEL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKL@@N@@@@@@@@@@@@@@@@@NC@@@" "LFL@@N@@@@@@@@@@@@@@@@@OC@@@" "LML@@N@@@@@@@@@@@@@@@@@OC@@@" "LKN@@N@@@@@@@@@@@@@@@@@NC@@@" "LKG@@N@@@@@@@@@@@@@@@@@OC@@@" "LMOH@N@@@@@@@@@@@@@@@@@NC@@@" "LFON@N@@@@@@@@@@@@@@@@@OC@@@" "LKEOHN@@@@@@@@@@@@@@@@@OC@@@" "LMKGOOOOOOOOOOOOOOOOOOONC@@@" "LFNMOOOOOOOOOOOOOOOOOOOOC@@@" "LKEKOOOOOOOOOOOOOOOOOOOOC@@@" "LMKFFMKFFMKFFMKFFMKFFMKFC@@@" "LFNMKFNMKFNMKFNMKFNMKFNMC@@@" "L@@@@@@@@@@@@@@@@@@@@@@@C@@@" "L@@@@@@@@@@@@@@@@@@@@@@@C@@@" "OOOOOOOOOOOOOOOOOOOOOOOOO@@@" "OOOOOOOOOOOOOOOOOOOOOOOOO@@@") (DEFINEQ (CitationLookup [LAMBDA NIL (* dgb:  "19-Nov-86 18:27") (MakeLookupWindow *citation-files* (QUOTE Citation% Lookup) *citation-region* *citationbm* *citation-mask* *citation-icon-pos*]) ) (FILESLOAD LOOKUPINFILES) (CitationLookup) (PUTPROPS FIND-CITATION COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (7531 7815 (CitationLookup 7541 . 7813))))) STOP \ No newline at end of file diff --git a/lispusers/FINGER b/lispusers/FINGER new file mode 100644 index 00000000..e5fd18bf --- /dev/null +++ b/lispusers/FINGER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Sep-88 10:44:56" |{EG:PARC:XEROX}LISP>USERS>FINGER.;5| 30905 changes to%: (FNS FINGER SEND.FINGER.REQUEST REFINGER FINGER.CONTAINS? FINGER.SETUP.WINDOW FINGER.MENU.SELECTED FINGER.SETUP.MENU \FINGER.PRINTFN STRING.NOT.NUMERIC FINGER.SERVER WAIT.FOR.FINGER.PACKET END.FINGER BACKGROUND.FINGER.SERVER TRACE.FINGER) (VARS FINGERCOMS) (FUNCTIONS NETS.WITHIN) previous date%: "14-Sep-88 18:05:53" |{EG:PARC:XEROX}LISP>USERS>FINGER.;4|) (* " Copyright (c) 1985, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FINGERCOMS) (RPAQQ FINGERCOMS ( (* ;; "Modified 6-April-87 by smL to interface to TALK; 14-Sep-88 to work in Medley") (P (IF (BOUNDP 'FINGER.WINDOW) THEN (END.FINGER))) (FNS FINGER REFINGER FINGER.CONTAINS? SEND.FINGER.REQUEST STRING.NOT.NUMERIC) (FUNCTIONS NETS.WITHIN) (INITVARS (FINGER.TIMEOUT 1000) (FINGER.NET.HOPS 2) (FINGER.BASE.DATE (IDATE "14-Mar-84 00:00:00")) (FINGER.CROWD NIL) (FINGER.INFINITY.MINUTES 90) (FINGER.CAPABILITIES '(TALK (AND (GETD 'TALK) (NOT TALK.GAG) (FIND.PROCESS 'COURIER.LISTENER) T) IDLING \IDLING SYSTEM 'Lisp))) (* ;; "Tablebrowser and window stuff") (FNS FINGER.SETUP.WINDOW FINGER.MENU.SELECTED FINGER.SETUP.MENU \FINGER.PRINTFN) (FILES ICONW TABLEBROWSER) (BITMAPS FINGER.ICON.BITMAP FINGER.ICON.MASK FINGER.INFINITY.BITMAP) (VARS (FINGER.MENU)) (INITVARS (FINGER.ICON.POSITION (CREATE POSITION XCOORD _ 900 YCOORD _ 500)) (FINGER.ICON (ICONW FINGER.ICON.BITMAP FINGER.ICON.MASK FINGER.ICON.POSITION T)) (FINGER.DISPLAY.WIDTH 290) (FINGER.DISPLAY.HEIGHT 140) (FINGER.DISPLAY.POSITION (CREATE POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH FINGER.DISPLAY.WIDTH) YCOORD _ 0))) (* ;; "Responding to finger requests on the net") (FNS FINGER.SERVER WAIT.FOR.FINGER.PACKET END.FINGER BACKGROUND.FINGER.SERVER) (* ;; "Ether info") (CONSTANTS (FINGER.SERVER.SOCKET# 199) (\XIPT.FINGERRESPONSE 20) (\XIPT.FINGERREQUEST 21)) (ALISTS (XIPTYPES \XIPT.FINGERRESPONSE \XIPT.FINGERREQUEST)) (FNS TRACE.FINGER) (* ;; "Start up Finger") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (FINGER.SERVER) (FINGER))) (* ;; "Compiler stuff") (DECLARE%: EVAL@LOAD DONTCOPY (P (LOADCOMP 'LLNS)) (FILES TABLEBROWSERDECLS) (RECORDS FINGER.HOST) (GLOBALVARS FINGER.TIMEOUT FINGER.NET.HOPS FINGER.BASE.DATE FINGER.INFINITY.MINUTES FINGER.ICON.POSITION FINGER.ICON FINGER.ICON.BITMAP FINGER.ICON.MASK FINGER.INFINITY.BITMAP FINGER.DISPLAY.WIDTH FINGER.DISPLAY.HEIGHT FINGER.DISPLAY.POSITION)) (* ;; "hints to the file manager") (PROP MAKEFILE-ENVIRONMENT FINGER))) (* ;; "Modified 6-April-87 by smL to interface to TALK; 14-Sep-88 to work in Medley") (IF (BOUNDP 'FINGER.WINDOW) THEN (END.FINGER)) (DEFINEQ (FINGER (LAMBDA (WHO HOST HOPS ICON?) (* ; "Edited 15-Sep-88 10:43 by smL") (LET ((USERS (CL:SORT (SEND.FINGER.REQUEST (OR HOPS FINGER.NET.HOPS)) #'(CL:LAMBDA (USER1 USER2) (CL:STRING< (FETCH (FINGER.HOST USERNAME) OF USER1) (FETCH (FINGER.HOST USERNAME) OF USER2))))) (WHOM (OR WHO FINGER.CROWD))) (if (OR (NOT (BOUNDP 'FINGER.BROWSER)) (NOT (BOUNDP 'FINGER.WINDOW))) then (FINGER.SETUP.WINDOW ICON?)) (if ICON? then (* ;; "if the icon? is true then just set up the window without opening it or sending a request") (if (NOT (OPENWP FINGER.ICON)) then (TOTOPW FINGER.ICON)) else (WINDOWPROP FINGER.WINDOW 'TITLE (CONCAT "Finger Display at " (SUBSTRING (DATE) 11 15))) (TB.REPLACE.ITEMS FINGER.BROWSER) (for P in USERS when (COND ((AND WHOM HOST) (OR (FINGER.CONTAINS? (CADR P) WHOM) (FINGER.CONTAINS? (CAR P) HOST))) (WHOM (FINGER.CONTAINS? (CADR P) WHOM)) (HOST (FINGER.CONTAINS? (CAR P) HOST)) (T T)) do (TB.INSERT.ITEM FINGER.BROWSER (create TABLEITEM TIDATA _ P TIUNDELETABLE _ T TIUNSELECTABLE _ (NOT (LISTGET (fetch CAPABILITIES of P) 'TALK))))) (TB.REDISPLAY.ITEMS FINGER.BROWSER))))) (REFINGER (LAMBDA (W) (* ; "Edited 14-Sep-88 18:03 by smL") (* ;; "dummy fun to call finger w/ no args, so can use as redisplayfn, etc.") (FINGER))) (FINGER.CONTAINS? (LAMBDA (ELEMENT L) (* ; "Edited 14-Sep-88 18:03 by smL") (* ;; "returns non-nil if element is list or is contained in list. case-insensitive compare used") (COND ((TYPENAMEP L 'LISTP) (MEMB (U-CASE ELEMENT) (for X in L collect (U-CASE X)))) (T (EQ (U-CASE ELEMENT) (U-CASE L)))))) (SEND.FINGER.REQUEST (LAMBDA (NET.HOPS) (* ; "Edited 15-Sep-88 10:44 by smL") (LET (FINGER.PACKET FINGER.USER.SOCKET NETS RESPONSES UNIQUERESULTS) (RESETLST (RESETSAVE NIL (LIST 'CLOSENSOCKET (SETQ FINGER.USER.SOCKET (OPENNSOCKET)))) (* ;; "Allocate a socket to send on") (SETQ NETS (NETS.WITHIN NET.HOPS)) (* ;; "send this to every one on the net in question TWICE") (for NET in (APPEND NETS NETS) do (* ;; "Get the xip") (SETQ FINGER.PACKET (ALLOCATE.XIP)) (\FILLINXIP \XIPT.FINGERREQUEST FINGER.USER.SOCKET BROADCASTNSHOSTNUMBER FINGER.SERVER.SOCKET# NET \XIPOVLEN FINGER.PACKET) (SENDXIP FINGER.USER.SOCKET FINGER.PACKET) (RELEASE.XIP FINGER.PACKET) (BLOCK)) (SETQ RESPONSES (for P in (bind PACKET while (SETQ PACKET (GETXIP FINGER.USER.SOCKET FINGER.TIMEOUT)) collect PACKET) bind PACKET.STREAM DATA collect (SETQ PACKET.STREAM (OPENSTRINGSTREAM (\GETBASESTRING (fetch XIPCONTENTS of P) 0 (IDIFFERENCE (fetch XIPLENGTH of P) \XIPOVLEN)))) (SETQ DATA (CAR (NLSETQ (READ PACKET.STREAM)))) (CLOSEF? PACKET.STREAM) (* ;; "don't die on old finger packets when the user was not logged in") (if (NUMBERP (CADR DATA)) then (SETQ DATA (CONS (CAR DATA) (CONS "[none]" (CDR DATA))))) DATA)) (* ;; "The responses are not necessarily eq for the same machine") (for DATALIST in RESPONSES when (AND DATALIST (NOT (SASSOC (CAR DATALIST) UNIQUERESULTS))) do (SETQ UNIQUERESULTS (CONS DATALIST UNIQUERESULTS))) UNIQUERESULTS)))) (STRING.NOT.NUMERIC (LAMBDA (S) (* edited%: " 3-Aug-84 10:21") (AND (STRPOSL (CONSTANT (MAKEBITTABLE (CHCON "0123456789") T)) S) S))) ) (CL:DEFUN NETS.WITHIN (HOPS) (DECLARE (GLOBAL \NS.ROUTING.TABLE)) (LET ((NETS NIL)) (\MAP.ROUTING.TABLE \NS.ROUTING.TABLE #'(CL:LAMBDA (ENTRY) (CL:WHEN (<= (fetch (ROUTING RTHOPCOUNT) of ENTRY) HOPS) (CL:SETQ NETS (CONS (fetch (ROUTING RTNET# ) of ENTRY) NETS))))) NETS)) (RPAQ? FINGER.TIMEOUT 1000) (RPAQ? FINGER.NET.HOPS 2) (RPAQ? FINGER.BASE.DATE (IDATE "14-Mar-84 00:00:00")) (RPAQ? FINGER.CROWD NIL) (RPAQ? FINGER.INFINITY.MINUTES 90) (RPAQ? FINGER.CAPABILITIES '(TALK (AND (GETD 'TALK) (NOT TALK.GAG) (FIND.PROCESS 'COURIER.LISTENER) T) IDLING \IDLING SYSTEM 'Lisp)) (* ;; "Tablebrowser and window stuff") (DEFINEQ (FINGER.SETUP.WINDOW (LAMBDA (ICON?) (* ; "Edited 14-Sep-88 18:04 by smL") (SETQ FINGER.WINDOW (CREATEW (CREATEREGION (fetch XCOORD of FINGER.DISPLAY.POSITION) (fetch YCOORD of FINGER.DISPLAY.POSITION) FINGER.DISPLAY.WIDTH (HEIGHTIFWINDOW FINGER.DISPLAY.HEIGHT T)) "Finger Display Window" NIL NIL)) (SETQ FINGER.BROWSER (TB.MAKE.BROWSER NIL FINGER.WINDOW '(PRINTFN \FINGER.PRINTFN))) (WINDOWPROP FINGER.WINDOW 'ICON FINGER.ICON) (WINDOWPROP FINGER.WINDOW 'SCROLLEXTENTUSE (CONS 'LIMIT 'LIMIT)) (WINDOWADDPROP FINGER.WINDOW 'EXPANDFN 'REFINGER) (WINDOWADDPROP FINGER.WINDOW 'CLOSEFN '(LAMBDA NIL (SETQ FINGER.WINDOW 'NOBIND))) (* ; "REFINGER is a dummy fn to call FINGER with no arguments.") (WINDOWADDPROP FINGER.WINDOW 'RESHAPEFN 'REFINGER) (FINGER.SETUP.MENU FINGER.WINDOW FINGER.BROWSER) (LET ((FINGER.PROMPT.WINDOW (GETPROMPTWINDOW FINGER.WINDOW 1 (FONTCREATE 'HELVETICA 10)))) (WINDOWPROP FINGER.PROMPT.WINDOW 'MINSIZE (CONS 0 (fetch (REGION HEIGHT) of (WINDOWPROP FINGER.PROMPT.WINDOW 'REGION)))) (WINDOWPROP FINGER.PROMPT.WINDOW 'MAXSIZE (CONS 64000 (fetch (REGION HEIGHT) of (WINDOWPROP FINGER.PROMPT.WINDOW 'REGION)))) (LINELENGTH MAX.SMALLP FINGER.PROMPT.WINDOW)) (if ICON? then (SHRINKW FINGER.WINDOW NIL FINGER.ICON.POSITION) else (* ; "shouldn't need to open this, but for the moment, one has to") (OPENW FINGER.ICON) (MOVEW FINGER.ICON FINGER.ICON.POSITION) (CLOSEW FINGER.ICON)))) (FINGER.MENU.SELECTED (LAMBDA (ITEM MENU MOUSE) (* ; "Edited 14-Sep-88 18:04 by smL") (if ITEM then (LET* ((browser (GETMENUPROP MENU 'TB)) (promptwindow (GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE%: (SPECVARS promptwindow)) (ALLOW.BUTTON.EVENTS) (SHADEITEM ITEM MENU MENUSELECTSHADE) (SELECTQ (CAR ITEM) (Update (FINGER)) (Talk (if (GETD 'TALK) then (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE%: (SPECVARS promptwindow)) (LET ((host (fetch TIDATA of item)) talkresult) (if (NOT (NULL (LISTGET (fetch CAPABILITIES of host) 'TALK))) then (printout promptwindow T "Trying to talk to " (fetch USERNAME of host) "...") (SETQ talkresult (TALK (fetch (FINGER.HOST NSHOSTNUMBER) of host))) (SELECTQ talkresult (T (printout promptwindow T "Talking to " (fetch USERNAME of host) ".")) (NIL (printout promptwindow T "Talk to " (fetch USERNAME of host) " aborted.")) (printout promptwindow T talkresult)) else (printout promptwindow T (fetch USERNAME of host) " on " (fetch HOSTNAME of host) " is not running TALK."))))) (FUNCTION (LAMBDA (browser) (DECLARE%: (SPECVARS promptwindow)) (printout promptwindow T "No hosts selected to TALK to.")))) else (printout promptwindow T "Can't -- TALK is not loaded"))) NIL) (SHADEITEM ITEM MENU WHITESHADE))))) (FINGER.SETUP.MENU (LAMBDA (WINDOW TABLE.BROWSER) (* ; "Edited 14-Sep-88 18:04 by smL") (SETQ FINGER.MENU (create MENU ITEMS _ '((Update NIL "Will update the finger display.") (Talk NIL "Open a TALK connection to the selected people")) WHENSELECTEDFN _ 'FINGER.MENU.SELECTED CENTERFLG _ T MENUOUTLINESIZE _ (IDIFFERENCE WBorder 3) MENUFONT _ (FONTCREATE '(HELVETICA 8 BOLD)))) (ATTACHMENU FINGER.MENU WINDOW) (PUTMENUPROP FINGER.MENU 'TB TABLE.BROWSER))) (\FINGER.PRINTFN (LAMBDA (browser item window) (* ; "Edited 14-Sep-88 18:04 by smL") (NLSETQ (LET* ((FINGER.HOST (fetch TIDATA of item)) (IDLE (fetch IDLE of FINGER.HOST)) (INFINITE.IDLE NIL)) (* ; "seconds of idle time") (if (IGEQ (IQUOTIENT IDLE 60) FINGER.INFINITY.MINUTES) then (SETQ INFINITE.IDLE T) else (SETQ IDLE (SUBSTRING (GDATE (IPLUS FINGER.BASE.DATE IDLE)) 11 15))) (printout window (if (LISTGET (fetch CAPABILITIES of FINGER.HOST) 'TALK) then "+" else " ") (fetch USERNAME of FINGER.HOST) 15 (L-CASE (fetch HOSTNAME of FINGER.HOST) T) 30) (if INFINITE.IDLE then (BITBLT FINGER.INFINITY.BITMAP NIL NIL window (DSPXPOSITION NIL window) (DSPYPOSITION NIL window)) (DSPXPOSITION (IPLUS (BITMAPWIDTH FINGER.INFINITY.BITMAP) (DSPXPOSITION NIL window)) window) else (PRIN1 IDLE window)))))) ) (FILESLOAD ICONW TABLEBROWSER) (RPAQQ FINGER.ICON.BITMAP #*(71 48)@@@@@@@O@@@@@@@@@@@@@@@@@@AOL@@@@@@@@@@@@@@@@@AHN@@@@@@@@@@@@@@@@@AHG@@@@@@@@@@@@@@@@@AHG@@@@@@@@@@@@@@@@@AHC@@@@@@@@@@@@@@@@@CHAH@@@@@@@@@@@@@@@@CHAH@@@@@@@@@@@@@@@@G@AH@@@@@@@@@@@@@@@@OBAH@@@@@@@@@@@@@@@ALCKH@@@@@@@@@@@@@@@CL@C@@@@@@@@@@@@@@@@GH@G@@@@@@AO@@@@@@@@O@@N@@@@@GOOL@@@@@@CN@AL@@@AOOO@N@@@@@@OH@AH@@OOON@@F@@@@@AN@@CKOOOO@@H@F@@@@@GL@@COOOH@@@L@F@@@@@OH@@CN@@@B@@DCN@@@@AN@@@@@@@@C@@GOL@@@@CL@@@@@@@@A@GON@@@@@CH@@B@@@@@COON@@@@@@O@@@B@@@@COON@@@@@OON@@@F@@@@CO@@@@@@@OOH@@@L@@@@GOH@@@@@@L@@@@AH@@@GLCH@@@@@@F@@@@B@@AOL@AH@@@@@@F@@@@D@AO@@@AH@@@@@@F@@@AHDB@@@@AH@@@@@@F@@@G@LDN@@@G@@@@@@@G@@CL@HIC@@GN@@@@@@@C@@F@@HIN@OLGH@@@@@@C@@@@@HL@O@@AH@@@@@@C@@@@@HGOH@@AH@@@@@@C@@@@A@@LD@@AH@@@@@@C@@@@A@AIJ@@G@@@@@@@C@@@@C@AJF@OO@@@@@@@C@@@@B@@IHGHCH@@@@@@C@@@@F@@LCL@AH@@@@@@C@@@@D@@GL@@AH@@@@@@C@@@@D@@@IN@AH@@@@@@C@@@@D@@ABB@GH@@@@@@C@CO@@@@AKLAN@@@@@@@CAOOL@@@@HAOL@@@@@@@CONAO@@@@OOOH@@@@@@@CO@@GO@AOOO@@@@@@@@@@@@@COOOOL@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@ ) (RPAQQ FINGER.ICON.MASK #*(71 48)@@@@@@@O@@@@@@@@@@@@@@@@@@AOL@@@@@@@@@@@@@@@@@AON@@@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@@@@@@COOH@@@@@@@@@@@@@@@@COOH@@@@@@@@@@@@@@@@GOOH@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@COOO@@@@@@@@@@@@@@@@GOOO@@@@@@AO@@@@@@@@OOON@@@@@GOOL@@@@@@COOOL@@@AOOOON@@@@@@OOOOH@@OOOOOON@@@@@AOOOOKOOOOOOOON@@@@@GOOOOOOOOOOOOON@@@@@OOOOOOOOOOOOOON@@@@AOOOOOOOOOOOOOOL@@@@COOOOOOOOOOOOON@@@@@COOOOOOOOOOOON@@@@@@OOOOOOOOOOOON@@@@@OOOOOOOOOOOOO@@@@@@@OOOOOOOOOOOOOH@@@@@@OOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOO@@@@@@@GOOOOOOOOOOON@@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOO@@@@@@@COOOOOOOOOOOO@@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOH@@@@@@COOOOOOOOOOON@@@@@@@COOOOOOOOOOOL@@@@@@@CONAOOOOOOOOH@@@@@@@CO@@GOOOOOO@@@@@@@@@@@@@COOOOL@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@ ) (RPAQQ FINGER.INFINITY.BITMAP #*(20 10)@@@@@@@@@@@@@@@@CL@O@@@@GNCOH@@@LCG@L@@@LAN@L@@@LAL@L@@@LCN@L@@@GOCAH@@@CLAO@@@@) (RPAQQ FINGER.MENU NIL) (RPAQ? FINGER.ICON.POSITION (CREATE POSITION XCOORD _ 900 YCOORD _ 500)) (RPAQ? FINGER.ICON (ICONW FINGER.ICON.BITMAP FINGER.ICON.MASK FINGER.ICON.POSITION T)) (RPAQ? FINGER.DISPLAY.WIDTH 290) (RPAQ? FINGER.DISPLAY.HEIGHT 140) (RPAQ? FINGER.DISPLAY.POSITION (CREATE POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH FINGER.DISPLAY.WIDTH) YCOORD _ 0)) (* ;; "Responding to finger requests on the net") (DEFINEQ (FINGER.SERVER (LAMBDA NIL (* ; "Edited 7-Apr-87 15:04 by Briggs") (* ;;; "spawn the process which will wait for finger requests, ensuring that there is only one finger server process.") (DEL.PROCESS (FIND.PROCESS 'Finger% Server)) (while (FIND.PROCESS 'Finger% Server) do (BLOCK)) (* ; "wait for the process to really die") (ADD.PROCESS '(WAIT.FOR.FINGER.PACKET) 'NAME 'Finger% Server 'RESTARTABLE 'HARDRESET) NIL)) (WAIT.FOR.FINGER.PACKET (LAMBDA NIL (* N.H.Briggs " 7-Apr-87 23:39") (* ;; "this function wakes up each time a finger request packet is received, it then sends back etherhostname (or address if no (pup) nameserver) ,the username, and the time since the last keyboard or mouse action.") (LET ((FINGER.SERVER.SOCKET)) (RESETLST (SETQ FINGER.SERVER.SOCKET (OPENNSOCKET FINGER.SERVER.SOCKET# 'ACCEPT)) (RESETSAVE NIL (LIST 'CLOSENSOCKET FINGER.SERVER.SOCKET T)) (DISCARDXIPS FINGER.SERVER.SOCKET) (while T do (AWAIT.EVENT (NSOCKETEVENT FINGER.SERVER.SOCKET)) (NLSETQ (PROG (RESPONSE.XIP DATA IDLETIME) (SETQ RESPONSE.XIP (GETXIP FINGER.SERVER.SOCKET)) (if (OR (NOT RESPONSE.XIP) (NEQ (fetch XIPTYPE of RESPONSE.XIP) \XIPT.FINGERREQUEST)) then (* ; "false alarm, go back to sleep") (RETURN)) (* ;; "format of response is a string containing a list of the data elements") (replace XIPLENGTH of RESPONSE.XIP with \XIPOVLEN) (SETQ IDLETIME (IDIFFERENCE (IDATE) (ALTO.TO.LISP.DATE \LASTUSERACTION))) (SETQ DATA (MKSTRING (create FINGER.HOST HOSTNAME _ (OR (STRING.NOT.NUMERIC (ETHERHOSTNAME NIL T)) (PORTSTRING (ETHERHOSTNUMBER))) USERNAME _ (if (STRING-EQUAL (USERNAME NIL NIL T) "") then "[none]" else (USERNAME NIL NIL T)) IDLE _ IDLETIME NSHOSTNUMBER _ \MY.NSADDRESS CAPABILITIES _ (for CAPABILITY on FINGER.CAPABILITIES by (CDDR CAPABILITY) join (LIST (CAR CAPABILITY) (EVAL (CADR CAPABILITY)))) ) T)) (XIPAPPEND.STRING RESPONSE.XIP DATA) (SWAPXIPADDRESSES RESPONSE.XIP) (* ;; "now have to set the correct source since original dest was nsbroadcastnumber") (replace XIPTYPE of RESPONSE.XIP with \XIPT.FINGERRESPONSE) (replace XIPSOURCEHOST of RESPONSE.XIP with \MY.NSHOSTNUMBER) (replace XIPSOURCENET of RESPONSE.XIP with 0) (replace XIPSOURCESOCKET of RESPONSE.XIP with FINGER.SERVER.SOCKET#) (SENDXIP FINGER.SERVER.SOCKET# RESPONSE.XIP)))))))) (END.FINGER (LAMBDA NIL (* ; "Edited 7-Apr-87 14:52 by Briggs") (DEL.PROCESS (FIND.PROCESS 'Finger% Server)) (if (BOUNDP 'FINGER.ICON) then (if (WINDOWP FINGER.ICON) then (CLOSEW FINGER.ICON))) (if (BOUNDP 'FINGER.WINDOW) then (if (WINDOWP FINGER.WINDOW) then (CLOSEW FINGER.WINDOW)) (SETQ FINGER.WINDOW 'NOBIND)) (if (BOUNDP 'FINGER.BROWSER) then (SETQ FINGER.BROWSER 'NOBIND)) NIL)) (BACKGROUND.FINGER.SERVER (LAMBDA NIL (* N.H.Briggs "15-Apr-87 18:44") (* ;; "this function wakes up each time a finger request packet is received, it then sends back etherhostname (or address if no (pup) nameserver) ,the username, and the time since the last keyboard or mouse action.") (SETQ FINGER.SERVER.SOCKET (OPENNSOCKET FINGER.SERVER.SOCKET# 'ACCEPT)) (AWAIT.EVENT (NSOCKETEVENT FINGER.SERVER.SOCKET) 20) (NLSETQ (PROG (RESPONSE.XIP DATA IDLETIME) (SETQ RESPONSE.XIP (GETXIP FINGER.SERVER.SOCKET)) (if (OR (NOT RESPONSE.XIP) (NEQ (fetch XIPTYPE of RESPONSE.XIP) \XIPT.FINGERREQUEST)) then (* ; "false alarm, go back to sleep") (RETURN)) (* ;; "format of response is a string containing a list of the data elements") (replace XIPLENGTH of RESPONSE.XIP with \XIPOVLEN) (SETQ IDLETIME (IDIFFERENCE (IDATE) (ALTO.TO.LISP.DATE \LASTUSERACTION))) (SETQ DATA (MKSTRING (create FINGER.HOST HOSTNAME _ (OR (STRING.NOT.NUMERIC (ETHERHOSTNAME NIL T)) (PORTSTRING (ETHERHOSTNUMBER))) USERNAME _ (if (STRING-EQUAL (USERNAME NIL NIL T) "") then "[none]" else (USERNAME NIL NIL T)) IDLE _ IDLETIME NSHOSTNUMBER _ \MY.NSADDRESS CAPABILITIES _ (for CAPABILITY on FINGER.CAPABILITIES by (CDDR CAPABILITY) join (LIST (CAR CAPABILITY) (EVAL (CADR CAPABILITY)))) ) T)) (XIPAPPEND.STRING RESPONSE.XIP DATA) (SWAPXIPADDRESSES RESPONSE.XIP) (* ;; "now have to set the correct source since original dest was nsbroadcastnumber") (replace XIPTYPE of RESPONSE.XIP with \XIPT.FINGERRESPONSE) (replace XIPSOURCEHOST of RESPONSE.XIP with \MY.NSHOSTNUMBER) (replace XIPSOURCENET of RESPONSE.XIP with 0) (replace XIPSOURCESOCKET of RESPONSE.XIP with FINGER.SERVER.SOCKET#) (SENDXIP FINGER.SERVER.SOCKET# RESPONSE.XIP))))) ) (* ;; "Ether info") (DECLARE%: EVAL@COMPILE (RPAQQ FINGER.SERVER.SOCKET# 199) (RPAQQ \XIPT.FINGERRESPONSE 20) (RPAQQ \XIPT.FINGERREQUEST 21) (CONSTANTS (FINGER.SERVER.SOCKET# 199) (\XIPT.FINGERRESPONSE 20) (\XIPT.FINGERREQUEST 21)) ) (ADDTOVAR XIPTYPES (\XIPT.FINGERRESPONSE 20) (\XIPT.FINGERREQUEST 21)) (DEFINEQ (TRACE.FINGER (LAMBDA NIL (* smL " 6-Apr-87 17:17") (SETQ XIPONLYTYPES (LIST \XIPT.FINGERREQUEST \XIPT.FINGERRESPONSE)) (XIPTRACE T))) ) (* ;; "Start up Finger") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (FINGER.SERVER) (FINGER) ) (* ;; "Compiler stuff") (DECLARE%: EVAL@LOAD DONTCOPY (LOADCOMP 'LLNS) (FILESLOAD TABLEBROWSERDECLS) (DECLARE%: EVAL@COMPILE (RECORD FINGER.HOST (HOSTNAME USERNAME IDLE NSHOSTNUMBER CAPABILITIES)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FINGER.TIMEOUT FINGER.NET.HOPS FINGER.BASE.DATE FINGER.INFINITY.MINUTES FINGER.ICON.POSITION FINGER.ICON FINGER.ICON.BITMAP FINGER.ICON.MASK FINGER.INFINITY.BITMAP FINGER.DISPLAY.WIDTH FINGER.DISPLAY.HEIGHT FINGER.DISPLAY.POSITION) ) ) (* ;; "hints to the file manager") (PUTPROPS FINGER MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS FINGER COPYRIGHT ("Xerox Corporation" 1985 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3811 9845 (FINGER 3821 . 6008) (REFINGER 6010 . 6217) (FINGER.CONTAINS? 6219 . 6625) ( SEND.FINGER.REQUEST 6627 . 9595) (STRING.NOT.NUMERIC 9597 . 9843)) (11149 18743 (FINGER.SETUP.WINDOW 11159 . 13381) (FINGER.MENU.SELECTED 13383 . 16560) (FINGER.SETUP.MENU 16562 . 17242) (\FINGER.PRINTFN 17244 . 18741)) (21438 29521 (FINGER.SERVER 21448 . 22044) (WAIT.FOR.FINGER.PACKET 22046 . 25945) ( END.FINGER 25947 . 26471) (BACKGROUND.FINGER.SERVER 26473 . 29519)) (29871 30074 (TRACE.FINGER 29881 . 30072))))) STOP \ No newline at end of file diff --git a/lispusers/FINGER.TEDIT b/lispusers/FINGER.TEDIT new file mode 100644 index 00000000..943c216d Binary files /dev/null and b/lispusers/FINGER.TEDIT differ diff --git a/lispusers/FM-CREATOR b/lispusers/FM-CREATOR new file mode 100644 index 00000000..5a3b423a --- /dev/null +++ b/lispusers/FM-CREATOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "18-Aug-88 14:32:54" {DSK}ANDRE>FM-CREATOR.;12 173736 changes to%: (VARS FM-CREATORCOMS) previous date%: "18-Aug-88 14:11:30" {DSK}ANDRE>FM-CREATOR.;11) (* " Copyright (c) 1988 by Rank Xerox France. Author Andre BLAVIER. All rights reserved. ") (PRETTYCOMPRINT FM-CREATORCOMS) (RPAQQ FM-CREATORCOMS ((PROP MAKEFILE-ENVIRONMENT FM-CREATOR) (* * FMC items record) (RECORDS FMC-ITEM) (* * FMC creation functions) (FNS FMC-CREATE FMC-INSTALL.IP.WINDOW FMC-INSTALL.GP.WINDOW FMC-CREATE.SHADE.MENU FMC-CREATE.SHADE.ITEM) (* * FMC windows functions) (FNS FMC-BUTTONEVENTFN FMC-CLOSEFN FMC-COPYBUTTONEVENTFN FMC-COPYINSERTFN FMC-CURSORMOVEDFN FMC-CURSOROUTFN FMC-EXPANDFN FMC-ICONFN FMC-SHRINKFN FMC-WINDOWENTRYFN) (* * FMC macros) (FUNCTIONS FM-GET.ITEM.LABEL FM-GET.ITEM.STATE FMC-CLEAR.REGION FMC-GET.ITEM FMC-GROUP? FMC-MARK.AS.CHANGED FMC-PUT.ITEM GET.REGION.BOTTOM GET.REGION.HEIGHT GET.REGION.LEFT GET.REGION.WIDTH NULLSTR PUT.REGION.BOTTOM PUT.REGION.HEIGHT PUT.REGION.LEFT PUT.REGION.WIDTH) (* * Right menu functions) (FNS FMC-FIXRIGHTMENU FMC-DORIGHTSELECTION) (* * Selection functions) (FNS FMC-SELECT.ITEM FMC-SELECT.LIST FMC-SELECT.LIST.ITEM FMC-SELECTALL FMC-GET.SELECTION FMC-DESELECT FMC-DESELECT.ITEM FMC-DESELECT.LIST FMC-DESELECT.LIST.ITEM) (* * Property windows functions) (FNS FMC-APPLY FMC-SHOW.ITEM FMC-SHOW.GROUP FMC-NEWITEM FMC-UPDATE.ITEM FMC-UPDATE.GROUP FMC-GET.LABEL FMC-CHOOSE.ITEM.BOXSHADE FMC-CHOOSE.ITEM.BG FMC-GET.MENUPROPS FMC-GET.INITSTATE FMC-EDIT.FN FMC-LINKS) (* * Property windows descriptions) (VARS FMC-IP-DESC FMC-GP-DESC) (* * Creating bitmaps) (FNS FMC-MAKEBITMAP FMC-COMPOUND.BITMAP FMC-SNAPBM) (* * Moving items) (FNS FMC-MOVE.SELECTION FMC-MOVE.BITMAP FMC-TRACK.NEW.ITEM FMC-UPDATE.BM.POSITION FMC-UPDATE.REGION) (* * Shaping items) (FNS FMC-COMPUTE.SHAPE.REGS FMC-SHAPE FMC-BOX.NEWREGIONFN FMC-NOBOX.NEWREGIONFN) (* * Redrawing items) (FNS FMC-REDRAW FMC-REDRAW.ITEM) (* * Deleting and undeleting items) (FNS FMC-DELETE FMC-UNDELETE) (* * GROUPing and UNGROUPing) (FNS FMC-GROUP FMC-UNGROUP) (* * Align and Center functions) (FNS FMC-ALIGN FMC-HCENTER FMC-VCENTER FMC-REL.MOVE) (* * File saving and loading) (FNS FMC-GET FMC-GET.ONE.OBJECT FMC-PUT FMC-PUT.OBJECT) (* * Creating a summary) (FNS FMC-EDIT.INFO FMC-EDIT.INFO.ITEM) (* * Hardcopy functions) (FNS FMC-HARDCOPY FMC-HARDCOPY.ITEM) (* * Creating the desription list) (FNS FMC-COMPUTE FMC-COMPUTE.OBJECT) (* * Miscellaneous) (FNS FMC-CREATE.ITEM.FROM.LIST FMC-DRAW.BOX FMC-CHOOSE.WINDOW.BG FMC-DISPLAY.GRID FMC-SET.GRIDSIZE FMC-FONT->LIST FMC-LIST->FONT FMC-SORT.ITEM.LIST FMC-IMPORT FMC-PROMPTPRINT) (* * Icon stuff) [COMS (BITMAPS FMC-ICON FMC-ICON.MASK) (INITVARS (FMC-ICON.TEMPLATE (create TITLEDICON ICON _ FMC-ICON MASK _ FMC-ICON.MASK TITLEREG _ (CREATEREGION 2 2 70 28] (* *) (COMS (P [OR (SASSOC 'FMCreator BackgroundMenuCommands) (NCONC1 BackgroundMenuCommands '(FMCreator '(FMC-CREATE) "Opens a Free Menu Creator window for use" ] (SETQ BackgroundMenu NIL))) (CURSORS MOVINGCURSOR))) (PUTPROPS FM-CREATOR MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (* * FMC items record) (DECLARE%: EVAL@COMPILE (RECORD FMC-ITEM (TYPE LABEL FONT ID COLLECTION DESELECT MESSAGE INITSTATE BOX BOXSHADE BACKGROUND LINKS OBJECTLIST MENU CHANGESTATE SELECTEDFN DOWNFN HELDFN MOVEDFN REGION BITMAP XBMOFFSET YBMOFFSET INFINITEWIDTH USERDATA) XBMOFFSET _ 0 YBMOFFSET _ 0) ) (* * FMC creation functions) (DEFINEQ (FMC-CREATE [LAMBDA NIL (* ; "Edited 18-Aug-88 12:21 by A.BLAVIER") (* ;; "Create a Free-Menu Creator window.") (LET ((Window (CREATEW (LIST LASTMOUSEX LASTMOUSEY 400 200) "Free Menu Creator" 4 T)) (RightMenu (create MENU ITEMS _ `((Redraw 'REDRAW "Redraw the FMC window") [Grid 'GRID "Grid" (SUBITEMS ("No Grid" 'NOGRID) (Size 'SIZE "Specify a grid size" (SUBITEMS 2 3 4 5 6 7 8 9 10)) ("Display Grid" 'DISPLAYGRID) ("Remove Grid Display" 'REMOVEGRIDDISPLAY] ("Delete" 'DELETE "Delete selected item(s)" (SUBITEMS ("Forget save list" 'FORGET.SAVE.LIST "Forget the list of deleted items" ))) ("Undelete" 'UNDELETE.LAST "Undelete last item" (SUBITEMS (Last 'UNDELETE.LAST "Undelete last item") (All 'UNDELETE.ALL "Undelete all deleted item(s)") (List 'UNDELETE.LIST "Undelete one item"))) (Group 'GROUP "Group the selected items") (Ungroup 'UNGROUP "Ungroup the selection") [Align 'ALIGN "Align selected items" (SUBITEMS ("Left sides" 'ALIGNLEFT) ("Right sides" 'ALIGNRIGHT) ("Tops" 'ALIGNTOP) ("Bottoms" 'ALIGNBOTTOM] [Center 'CENTER "Center items" (SUBITEMS (Horizontally 'HCENTER) (Vertically 'VCENTER] ("Select All" 'SELECTALL "Select all the items") ("Background" 'WBACKGROUND "Set the window's background") ("Summary" 'SUMMARY "Create a summary of the items") (Import 'IMPORT "Import items from a Free Menu") (Compute 'COMPUTE "Create the Free Menu description") (Get 'GET "Get items from a file") (Put 'PUT "Put items onto a file") ("Fixed Menu" 'FIXRIGHTMENU "Attach Right Menu")) CENTERFLG _ T)) FMC.PROMPTWINDOW) (PRINTOUT PROMPTWINDOW "FREE MENU CREATOR" T "Copyright (c) 1988 by Rank Xerox France. Author Andre BLAVIER") (SETCURSOR WAITINGCURSOR) (PUTMENUPROP RightMenu 'FMC.WINDOW Window) (* ;; "Initialize window properties") (WINDOWPROP Window 'WINDOWENTRYFN (FUNCTION FMC-WINDOWENTRYFN)) (WINDOWPROP Window 'BUTTONEVENTFN (FUNCTION FMC-BUTTONEVENTFN)) (WINDOWPROP Window 'RIGHTBUTTONFN (FUNCTION FMC-BUTTONEVENTFN)) (WINDOWPROP Window 'CURSORMOVEDFN (FUNCTION FMC-CURSORMOVEDFN)) (WINDOWPROP Window 'CURSOROUTFN (FUNCTION FMC-CURSOROUTFN)) (WINDOWPROP Window 'REPAINTFN (FUNCTION FMC-REDRAW)) (WINDOWPROP Window 'RESHAPEFN (LIST (FUNCTION REPOSITIONATTACHEDWINDOWS) (FUNCTION FMC-REDRAW))) (WINDOWPROP Window 'HARDCOPYFN (FUNCTION FMC-HARDCOPY)) (WINDOWPROP Window 'COPYBUTTONEVENTFN (FUNCTION FMC-COPYBUTTONEVENTFN)) (WINDOWPROP Window 'COPYINSERTFN (FUNCTION FMC-COPYINSERTFN)) (WINDOWPROP Window 'CLOSEFN (FUNCTION FMC-CLOSEFN)) (WINDOWPROP Window 'SHRINKFN (FUNCTION FMC-SHRINKFN)) (WINDOWPROP Window 'ICONFN (FUNCTION FMC-ICONFN)) (WINDOWPROP Window 'EXPANDFN (FUNCTION FMC-EXPANDFN)) (WINDOWPROP Window 'RIGHTMENU RightMenu) (WINDOWPROP Window 'FMC.CHANGED NIL) (* ;  "this flag will be set when any item changing occurs - it is checked before window closing") (* ;; "Create a prompt window") (SETQ FMC.PROMPTWINDOW (CREATEW [CREATEREGION 0 0 100 (HEIGHTIFWINDOW (FONTPROP (DEFAULTFONT 'DISPLAY) 'HEIGHT] NIL NIL T)) (WINDOWPROP FMC.PROMPTWINDOW 'PAGEFULLFN (FUNCTION NILL)) [WINDOWPROP FMC.PROMPTWINDOW 'MAXSIZE (CONS MAX.SMALLP (GET.REGION.HEIGHT (WINDOWPROP FMC.PROMPTWINDOW 'REGION] (DSPSCROLL 'ON FMC.PROMPTWINDOW) (ATTACHWINDOW FMC.PROMPTWINDOW Window 'TOP) (WINDOWPROP FMC.PROMPTWINDOW 'PASSTOMAINCOMS '(MOVEW SHAPEW SHRINKW BURYW)) (WINDOWPROP Window 'FMC.PROMPTWINDOW FMC.PROMPTWINDOW) (* ;; "") (MOVEW Window) (* ;; "Create and attach the Item and Group Properties windows") (SETCURSOR WAITINGCURSOR) (WINDOWPROP Window 'FMC.IP.WINDOW (FMC-INSTALL.IP.WINDOW Window)) (WINDOWPROP Window 'FMC.GP.WINDOW (FMC-INSTALL.GP.WINDOW Window)) (* ;; "Spawn a process") (ADD.PROCESS `(PROGN (TTYDISPLAYSTREAM ,Window) (UNTIL (WINDOWPROP ,Window 'CANCLOSE) DO (BLOCK))) 'NAME 'FMCreator 'WINDOW Window) (* ;; "") (SETCURSOR DEFAULTCURSOR]) (FMC-INSTALL.IP.WINDOW [LAMBDA (WINDOW) (* ; "Edited 16-Aug-88 14:17 by A.BLAVIER") (* ;; "Create and attach the Item Properties window") (PROG ((FMC.IP.Window (FREEMENU FMC-IP-DESC "ITEM PROPERTIES")) (DefaultFont (DEFAULTFONT 'DISPLAY)) FontList ShadeMenu BlackBitmap WhiteBitmap) (* ;; "Initialize Font to DEFAULTFONT") (SETQ FontList (FMC-FONT->LIST DefaultFont)) (FM.CHANGESTATE 'FAMILY (CAR FontList) FMC.IP.Window) (FM.CHANGESTATE 'SIZE (CADR FontList) FMC.IP.Window) (FM.CHANGESTATE 'FACE (CADDR FontList) FMC.IP.Window) (* ;; "the LABEL and MESSAGE edit fields are initially empty") (FM.CHANGELABEL 'LABELLINK "" FMC.IP.Window) (FM.CHANGELABEL 'MESSAGELINK "" FMC.IP.Window) (* ;; "Create the shade menu") (SETQ ShadeMenu (FMC-CREATE.SHADE.MENU)) (SETQ BlackBitmap (CAAR (fetch (MENU ITEMS) of ShadeMenu))) (* ;  "the blackshade bitmap is the first menu item") [SETQ WhiteBitmap (CAAR (NTH (fetch (MENU ITEMS) of ShadeMenu) (SUB1 (LENGTH (fetch (MENU ITEMS) of ShadeMenu] (* ;  "the whiteshade BM is the one before last ") (FM.CHANGESTATE 'BOXSHADE BlackBitmap FMC.IP.Window) (FM.CHANGESTATE 'BACKGROUND WhiteBitmap FMC.IP.Window) (* ;; "initialize window properties") (WINDOWPROP FMC.IP.Window 'SHADE.MENU ShadeMenu) (WINDOWPROP FMC.IP.Window 'FMC.ITEM.BOXSHADE BLACKSHADE) (WINDOWPROP FMC.IP.Window 'FMC.ITEM.BACKGROUND WHITESHADE) [for PROP in '(CHANGESTATE SELECTEDFN DOWNFN HELDFN MOVEDFN) do (WINDOWPROP FMC.IP.Window (PACK* 'FMC.ITEM. PROP) '(FUNCTION NILL] (WINDOWPROP FMC.IP.Window 'FMC.ITEM.MENUPROPS '(NIL)) (* ;; "attach the IP window") (ATTACHWINDOW FMC.IP.Window WINDOW 'TOP 'LEFT) (WINDOWPROP FMC.IP.Window 'MAIN.WINDOW WINDOW) (WINDOWPROP FMC.IP.Window 'RESHAPEFN 'DON'T) (RETURN FMC.IP.Window]) (FMC-INSTALL.GP.WINDOW [LAMBDA (WINDOW) (* ; "Edited 16-Aug-88 14:19 by A.BLAVIER") (* ;; "Create and attach the Group Properties window") (PROG ((FMC.GP.Window (FREEMENU FMC-GP-DESC "GROUP PROPERTIES")) (FMC.IP.Window (WINDOWPROP WINDOW 'FMC.IP.WINDOW)) ShadeMenu BlackBitmap WhiteBitmap) (* ;; "see comments of FMC-INSTALL.IP.WINDOW") (SETQ ShadeMenu (WINDOWPROP FMC.IP.Window 'SHADE.MENU)) (SETQ BlackBitmap (CAAR (fetch (MENU ITEMS) of ShadeMenu))) [SETQ WhiteBitmap (CAAR (NTH (fetch (MENU ITEMS) of ShadeMenu) (SUB1 (LENGTH (fetch (MENU ITEMS) of ShadeMenu] (FM.CHANGESTATE 'BOXSHADE BlackBitmap FMC.GP.Window) (FM.CHANGESTATE 'BACKGROUND WhiteBitmap FMC.GP.Window) (WINDOWPROP FMC.GP.Window 'FMC.ITEM.BOXSHADE BLACKSHADE) (WINDOWPROP FMC.GP.Window 'FMC.ITEM.BACKGROUND WHITESHADE) (WINDOWPROP FMC.GP.Window 'SHADE.MENU ShadeMenu) (ATTACHWINDOW FMC.GP.Window FMC.IP.Window 'RIGHT 'BOTTOM) (WINDOWPROP FMC.GP.Window 'MAIN.WINDOW WINDOW) (WINDOWPROP FMC.GP.Window 'RESHAPEFN 'DON'T) (RETURN FMC.GP.Window]) (FMC-CREATE.SHADE.MENU [LAMBDA NIL (* ; "Edited 16-Aug-88 14:21 by A.BLAVIER") (* ;; "Create a shade menu built out of the bitmaps corresponding to Shades.") (LET ((Shades '(65535 43605 38505 52224 61713 5160 32768 0)) ShadeItems) (SETQ ShadeItems (for s in Shades collect (FMC-CREATE.SHADE.ITEM s))) [NCONC1 ShadeItems '("OTHER" (CADADR (FMC-CREATE.SHADE.ITEM (EDITSHADE] (create MENU ITEMS _ ShadeItems ITEMWIDTH _ 60 CENTERFLG _ T TITLE _ "SHADE"]) (FMC-CREATE.SHADE.ITEM [LAMBDA (SHADE) (* ; "Edited 16-Aug-88 14:24 by A.BLAVIER") (* ;; "Compute a shade menu item of the form : (BITMAP (BITMAP . SHADE))") (PROG (Bitmap Stream bm) (SETQ Bitmap (BITMAPCREATE 60 12)) (SETQ Stream (DSPCREATE Bitmap)) (DSPFILL '(0 0 59 12) SHADE 'REPLACE Stream) (DRAWLINE 0 0 0 11 1 'REPLACE Stream) (DRAWLINE 0 11 59 11 1 'REPLACE Stream) (DRAWLINE 59 11 59 0 1 'REPLACE Stream) (DRAWLINE 59 0 0 0 1 'REPLACE Stream) (SETQ bm (BITMAPCOPY Bitmap)) (RETURN (LIST bm (KWOTE (CONS bm SHADE]) ) (* * FMC windows functions) (DEFINEQ (FMC-BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 16-Aug-88 14:33 by A.BLAVIER") (* ;; "This is the BUTTONEVENTFN attached to FMC windows.") (* ;; "In any case bring the window to top") (TOTOPW WINDOW) (LET ((SelectedItem (WINDOWPROP WINDOW 'SELECTED.ITEM)) (SelectionList (WINDOWPROP WINDOW 'SELECTION.LIST)) Item Timer Reg) (* ;; "") (* ;; "Deal with RIGHT button : pops up either FMC right menu or standard window menu") (if (LASTMOUSESTATE RIGHT) then (if [OR (WINDOWPROP WINDOW 'FIXEDRIGHTMENU) (IGREATERP (fetch (POSITION YCOORD) of (CURSORPOSITION NIL WINDOW)) (WINDOWPROP WINDOW 'HEIGHT] then (DOWINDOWCOM WINDOW) else (FMC-DORIGHTSELECTION (MENU (WINDOWPROP WINDOW 'RIGHTMENU)) WINDOW))) (* ;; "") (* ;; "Deal with LEFT Button") [if [AND (MOUSESTATE (AND LEFT (NOT MIDDLE))) (ILESSP (fetch (POSITION YCOORD) of (CURSORPOSITION NIL WINDOW)) (WINDOWPROP WINDOW 'HEIGHT] then (if [SETQ Item (for i in (WINDOWPROP WINDOW 'ITEMLIST) thereis (INSIDEP (FMC-GET.ITEM i REGION) (CURSORPOSITION NIL WINDOW] then (* ;; "user clicked inside an Item") [if (SHIFTDOWNP 'META) then (* ;; "user Meta-clicked") (if (NOT (FMEMB Item SelectionList)) then (* ;; "if Item is not yet part of a multiple selection add it to the selection") (WINDOWADDPROP WINDOW 'SELECTION.LIST Item) (FMC-SELECT.LIST.ITEM Item WINDOW) (if SelectedItem then (* ;; "Item was the unique selection : make it the only item of a multiple selection") (WINDOWADDPROP WINDOW 'SELECTION.LIST SelectedItem T) (FMC-DESELECT.ITEM WINDOW) (FMC-SELECT.LIST.ITEM SelectedItem WINDOW)) else (* ;; "remove Item from the multiple selection") (FMC-DESELECT.LIST.ITEM Item WINDOW)) else (COND ((EQUAL Item SelectedItem) (* ;  "Item is the unique selected item : move it") (FMC-MOVE.SELECTION WINDOW 'UNIQUE) (FMC-COMPUTE.SHAPE.REGS WINDOW)) ((FMEMB Item SelectionList) (* ;  "Item is a member of a multiple selection : move the selection") (FMC-MOVE.SELECTION WINDOW 'MULTIPLE)) (T (* ;  "Item is not yet selected : make it the unique selection") (FMC-DESELECT WINDOW) (SETQ Timer (SETUPTIMER 20000 NIL 'TICKS 'TICKS)) (WINDOWPROP WINDOW 'SELECTED.ITEM Item) (FMC-SELECT.ITEM WINDOW) [until (OR (MOUSESTATE (NOT LEFT)) (TIMEREXPIRED? Timer 'TICKS] (if (MOUSESTATE LEFT) then (FMC-MOVE.SELECTION WINDOW 'UNIQUE)) (FMC-COMPUTE.SHAPE.REGS WINDOW] else (* ;; "user clicked outside any item") (if (SHIFTDOWNP 'META) then (* ;; "if Meta : select items inside a ghost region") (FMC-GET.SELECTION WINDOW) else (* ;; "remove any selection") (FMC-DESELECT WINDOW] (* ;; "") (* ;; "Deal with MIDDLE Button") [if [AND (MOUSESTATE (AND MIDDLE (NOT LEFT))) (ILESSP (fetch (POSITION YCOORD) of (CURSORPOSITION NIL WINDOW)) (WINDOWPROP WINDOW 'HEIGHT] then (if [SETQ Item (for i in (WINDOWPROP WINDOW 'ITEMLIST) thereis (INSIDEP (FMC-GET.ITEM i REGION) (CURSORPOSITION NIL WINDOW] then (* ;; "user clicked inside an Item") (if (EQUAL Item SelectedItem) then (* ;; "shape the Item") (if [SETQ Reg (for reg in (WINDOWPROP WINDOW 'SHAPE.REGS) thereis (INSIDEP (CAR reg) (CURSORPOSITION NIL WINDOW] then (SETCURSOR (CADDDR Reg)) (APPLY (CADR Reg) (LIST (CADDR Reg) WINDOW))) else (SETCURSOR DEFAULTCURSOR] (* ;; "") (* ;; "The following statement handles the case where the user released the left button in a selected item : adjust the cursor appropriately") (if (MOUSESTATE (AND (NOT LEFT) (NOT MIDDLE) (NOT RIGHT))) then (FMC-CURSORMOVEDFN WINDOW]) (FMC-CLOSEFN [LAMBDA (W) (* ; "Edited 17-Aug-88 10:23 by A.BLAVIER") (* ;; "Attempt to close a FMC window.") (* ;; "Check the FMC.CHANGED property") (if [AND (WINDOWPROP W 'FMC.CHANGED) (NOT (MOUSECONFIRM "Warning ! Not saved yet. LEFT to quit anyway" "" (WINDOWPROP W 'FMC.PROMPTWINDOW] then 'DON'T else (* ;;  "if OK then set the CANCLOSE prop, which is continually checked by the process's main loop") (WINDOWPROP W 'CANCLOSE T]) (FMC-COPYBUTTONEVENTFN [LAMBDA (W) (* ; "Edited 16-Aug-88 14:39 by A.BLAVIER") (* ;; "Copy selected item(s) to another FMC window.") (* ;;  "Check that the destination window (the window that currently has the TTY) is a FMC window") (if (WINDOWPROP (PROCESSPROP (TTY.PROCESS) 'WINDOW) 'FMC.PROMPTWINDOW) then (* ;; "pass a list of the form : (FROM-FMC (selected items ...))") (COPYINSERT (LIST 'FROM-FMC (COND [(WINDOWPROP W 'SELECTED.ITEM) (LIST (COPYALL (WINDOWPROP W 'SELECTED.ITEM] ((WINDOWPROP W 'SELECTION.LIST) (COPYALL (WINDOWPROP W 'SELECTION.LIST]) (FMC-COPYINSERTFN [LAMBDA (OBJ WINDOW) (* ; "Edited 16-Aug-88 14:44 by A.BLAVIER") (* ;; "User is trying to insert some OBJect into the FMC window, using the COPY key.") (COND ((IMAGEOBJP OBJ) (* ;; "if OBJect is an IMAGEOBJ -> make LABEL be its bitmap") (LET (ImageBox Bitmap Stream) (SETQ ImageBox (APPLY (IMAGEOBJPROP OBJ 'IMAGEBOXFN) (LIST OBJ WINDOW))) (SETQ Bitmap (BITMAPCREATE (fetch (IMAGEBOX XSIZE) of ImageBox) (fetch (IMAGEBOX YSIZE) of ImageBox))) (SETQ Stream (DSPCREATE Bitmap)) (APPLY (IMAGEOBJPROP OBJ 'DISPLAYFN) (LIST OBJ Stream 'DISPLAY)) (FM.CHANGELABEL 'LABELLINK Bitmap (WINDOWPROP WINDOW 'FMC.IP.WINDOW) T))) ((EQ (CAR OBJ) 'FROM-FMC) (* ;; " if OBJect is a list of FMC item(s) (coming from another FMC window) -> add them to the window's ITEMLIST") (for item in (CADR OBJ) do (FMC-REDRAW.ITEM item WINDOW) (WINDOWADDPROP WINDOW 'ITEMLIST item)) (if (WINDOWPROP WINDOW 'SELECTED.ITEM) then (FMC-DESELECT.ITEM WINDOW)) (if (WINDOWPROP WINDOW 'SELECTION.LIST) then (FMC-DESELECT.LIST WINDOW)) (WINDOWPROP WINDOW 'SELECTION.LIST (CADR OBJ)) (FMC-SELECT.LIST WINDOW) (FMC-MARK.AS.CHANGED WINDOW]) (FMC-CURSORMOVEDFN [LAMBDA (WINDOW) (* ; "Edited 16-Aug-88 15:30 by A.BLAVIER") (* ;;  "If the cursor is inside a selected item make it the MOVINGCURSOR, else make it the DEFAULTCURSOR.") (LET (Item) (COND ((AND (SETQ Item (WINDOWPROP WINDOW 'SELECTED.ITEM)) (INSIDEP (FMC-GET.ITEM Item REGION) (CURSORPOSITION NIL WINDOW))) (SETCURSOR MOVINGCURSOR)) ((for i in (WINDOWPROP WINDOW 'SELECTION.LIST) thereis (INSIDEP (FMC-GET.ITEM i REGION) (CURSORPOSITION NIL WINDOW) )) (SETCURSOR MOVINGCURSOR)) (T (SETCURSOR DEFAULTCURSOR]) (FMC-CURSOROUTFN [LAMBDA (W) (* ; "Edited 16-Aug-88 14:06 by A.BLAVIER") (SETCURSOR DEFAULTCURSOR]) (FMC-EXPANDFN [LAMBDA (W) (* ; "Edited 16-Aug-88 15:44 by A.BLAVIER") (if (WINDOWPROP W 'PROCESS) then (* ;; "grab the TTY") (TTY.PROCESS (WINDOWPROP W 'PROCESS]) (FMC-ICONFN [LAMBDA (W) (* ; "Edited 16-Aug-88 15:42 by A.BLAVIER") (* ;; "Return a titled icon when shrinking a FMC window.") (* ;; "This function is extracted from the TEdit ICONFN.") (PROG [(Icon (WINDOWPROP W 'ICON)) (IconTitle (WINDOWPROP W 'FMC.ICON.TITLE)) (WindowTitle (WINDOWPROP W 'TITLE] [COND ((OR (AND IconTitle (EQUAL IconTitle WindowTitle)) (AND (NOT IconTitle) Icon)) NIL) (Icon (WINDOWPROP W 'FMC.ICON.TITLE (SETQ IconTitle WindowTitle)) (ICONTITLE IconTitle NIL NIL Icon)) (T (WINDOWPROP W 'FMC.ICON.TITLE (SETQ IconTitle WindowTitle)) (WINDOWPROP W 'ICON (TITLEDICONW FMC-ICON.TEMPLATE IconTitle '(HELVETICA 8 STANDARD) NIL T NIL 'FILE] (RETURN (WINDOWPROP W 'ICON]) (FMC-SHRINKFN [LAMBDA (W) (* ; "Edited 16-Aug-88 15:45 by A.BLAVIER") (if (AND (EQ (WINDOWPROP W 'PROCESS) (TTY.PROCESS))) then (* ;; "abandon the TTY") (TTY.PROCESS T]) (FMC-WINDOWENTRYFN [LAMBDA (W) (* ; "Edited 17-Aug-88 10:24 by A.BLAVIER") (* ;; "Grab the TTY when the mouse clicks in the window, and process the BUTTONEVENTFN.") (if [AND [NOT (OR (SHIFTDOWNP 'SHIFT) (SHIFTDOWNP 'META) (KEYDOWNP 'MOVE) (KEYDOWNP 'COPY] (PROCESSP (WINDOWPROP W 'PROCESS] then (TTY.PROCESS (WINDOWPROP W 'PROCESS)) (FMC-BUTTONEVENTFN W]) ) (* * FMC macros) (DEFMACRO FM-GET.ITEM.LABEL (ID.OR.LABEL WINDOW) (LIST 'FM.ITEMPROP (LIST 'FM.GETITEM ID.OR.LABEL NIL WINDOW) ''LABEL)) (DEFMACRO FM-GET.ITEM.STATE (ID.OR.LABEL WINDOW) (LIST 'FM.ITEMPROP (LIST 'FM.GETITEM ID.OR.LABEL NIL WINDOW) ''STATE)) (DEFMACRO FMC-CLEAR.REGION (REGION WINDOW) (LIST 'DSPFILL REGION 'WHITESHADE ''REPLACE WINDOW)) (DEFMACRO FMC-GET.ITEM (ITEM FIELD) (LIST 'fetch `(FMC-ITEM ,FIELD) 'of ITEM)) (DEFMACRO FMC-GROUP? (OBJECT) (LIST 'EQ `(FMC-GET.ITEM ,OBJECT TYPE) ''GROUP)) (DEFMACRO FMC-MARK.AS.CHANGED (W) (LIST 'WINDOWPROP W ''FMC.CHANGED T)) (DEFMACRO FMC-PUT.ITEM (ITEM FIELD VALUE) (LIST 'replace `(FMC-ITEM ,FIELD) 'of ITEM 'with VALUE)) (DEFMACRO GET.REGION.BOTTOM (REGION) (LIST 'fetch '(REGION BOTTOM) 'of REGION)) (DEFMACRO GET.REGION.HEIGHT (REGION) (LIST 'fetch '(REGION HEIGHT) 'of REGION)) (DEFMACRO GET.REGION.LEFT (REGION) (LIST 'fetch '(REGION LEFT) 'of REGION)) (DEFMACRO GET.REGION.WIDTH (REGION) (LIST 'fetch '(REGION WIDTH) 'of REGION)) (DEFMACRO NULLSTR (STR) (LIST 'STREQUAL STR "")) (DEFMACRO PUT.REGION.BOTTOM (REGION VALUE) (LIST 'replace '(REGION BOTTOM) 'of REGION 'with VALUE)) (DEFMACRO PUT.REGION.HEIGHT (REGION VALUE) (LIST 'replace '(REGION HEIGHT) 'of REGION 'with VALUE)) (DEFMACRO PUT.REGION.LEFT (REGION VALUE) (LIST 'replace '(REGION LEFT) 'of REGION 'with VALUE)) (DEFMACRO PUT.REGION.WIDTH (REGION VALUE) (LIST 'replace '(REGION WIDTH) 'of REGION 'with VALUE)) (* * Right menu functions) (DEFINEQ (FMC-FIXRIGHTMENU [LAMBDA (WINDOW) (* ; "Edited 25-Jul-88 11:16 by A.BLAVIER") (* ;; " Fix the right menu if not yet attached.") (COND ((NOT (WINDOWPROP WINDOW 'FIXEDRIGHTMENU)) (replace (MENU WHENSELECTEDFN) of (WINDOWPROP WINDOW 'RIGHTMENU) with (FUNCTION FMC-DORIGHTSELECTION)) (LET [(MenuWindow (ATTACHMENU (WINDOWPROP WINDOW 'RIGHTMENU) WINDOW 'RIGHT 'TOP] (WINDOWPROP MenuWindow 'ATTACHEDTO WINDOW) (* ;; "Don't pass CLOSEW to the main window !") (WINDOWPROP MenuWindow 'PASSTOMAINCOMS '(MOVEW SHAPEW SHRINKW BURYW)) [WINDOWPROP MenuWindow 'CLOSEFN (FUNCTION (LAMBDA (MW) (WINDOWPROP (WINDOWPROP MW 'ATTACHEDTO) 'FIXEDRIGHTMENU NIL) (replace (MENU WHENSELECTEDFN) of (WINDOWPROP (WINDOWPROP MW 'ATTACHEDTO) 'RIGHTMENU) with (FUNCTION DEFAULTWHENSELECTEDFN)) (DETACHWINDOW MW] (WINDOWPROP WINDOW 'FIXEDRIGHTMENU MenuWindow]) (FMC-DORIGHTSELECTION [LAMBDA (ITEM MENU.OR.WINDOW BUTTON) (* ; "Edited 17-Aug-88 10:38 by A.BLAVIER") (* ;; "Handles right menu selection either pop-up or fixed.") (LET ([WINDOW (if (WINDOWP MENU.OR.WINDOW) then MENU.OR.WINDOW else (GETMENUPROP MENU.OR.WINDOW 'FMC.WINDOW] (Selection (if (LISTP ITEM) then (EVAL (CADR ITEM)) else ITEM))) (SELECTQ Selection (FIXRIGHTMENU (FMC-FIXRIGHTMENU WINDOW)) (REDRAW (FMC-REDRAW WINDOW)) (GRID (if (WINDOWPROP WINDOW 'GRIDSIZE) then (FMC-PROMPTPRINT (CONCAT "Grid size is " (WINDOWPROP WINDOW 'GRIDSIZE)) WINDOW) else (FMC-PROMPTPRINT "No grid" WINDOW))) ((NOGRID 2 3 4 5 6 7 8 9 10) (FMC-SET.GRIDSIZE Selection WINDOW)) (DISPLAYGRID (FMC-DISPLAY.GRID WINDOW)) (REMOVEGRIDDISPLAY (if (WINDOWPROP WINDOW 'DISPLAYGRID) then (WINDOWPROP WINDOW 'DISPLAYGRID NIL) (FMC-REDRAW WINDOW))) (DELETE (FMC-DELETE WINDOW)) (FORGET.SAVE.LIST (WINDOWPROP WINDOW 'DELETED.ITEMS NIL)) (UNDELETE.LAST (FMC-UNDELETE 'LAST WINDOW)) (UNDELETE.ALL (FMC-UNDELETE 'ALL WINDOW)) (UNDELETE.LIST (FMC-UNDELETE 'LIST WINDOW)) (GROUP (FMC-GROUP WINDOW)) (UNGROUP (FMC-UNGROUP WINDOW)) ((ALIGNLEFT ALIGNRIGHT ALIGNTOP ALIGNBOTTOM) (FMC-ALIGN Selection WINDOW)) (HCENTER (FMC-HCENTER WINDOW)) (VCENTER (FMC-VCENTER WINDOW)) (SELECTALL (FMC-SELECTALL WINDOW)) (WBACKGROUND (FMC-CHOOSE.WINDOW.BG WINDOW)) (SUMMARY (FMC-EDIT.INFO WINDOW)) (IMPORT (FMC-IMPORT WINDOW)) (COMPUTE (FMC-COMPUTE WINDOW)) (GET (FMC-GET WINDOW)) (PUT (FMC-PUT WINDOW)) NIL]) ) (* * Selection functions) (DEFINEQ (FMC-SELECT.ITEM [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 10:50 by A.BLAVIER") (* ;; "Highlight the unique selected item of WINDOW.") (LET ((Item (WINDOWPROP WINDOW 'SELECTED.ITEM)) Reg RLeft RBottom RRight RTop) (SETQ Reg (FMC-GET.ITEM Item REGION)) (SETQ RLeft (IDIFFERENCE (GET.REGION.LEFT Reg) 2)) (SETQ RBottom (IDIFFERENCE (GET.REGION.BOTTOM Reg) 2)) (SETQ RRight (IPLUS (fetch (REGION RIGHT) of Reg) 2)) (SETQ RTop (IPLUS (fetch (REGION TOP) of Reg) 2)) (* ;; "") (DRAWLINE RLeft RBottom RRight RBottom 1 'REPLACE WINDOW NIL '(1 1)) (DRAWLINE RRight RBottom RRight RTop 1 'REPLACE WINDOW NIL '(1 1)) (DRAWLINE RRight RTop RLeft RTop 1 'REPLACE WINDOW NIL '(1 1)) (DRAWLINE RLeft RTop RLeft RBottom 1 'REPLACE WINDOW NIL '(1 1)) (FMC-COMPUTE.SHAPE.REGS WINDOW]) (FMC-SELECT.LIST [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 11:00 by A.BLAVIER") (* ;; "Highlight all the items of a multiple selection.") (for item in (WINDOWPROP WINDOW 'SELECTION.LIST) do (FMC-SELECT.LIST.ITEM item WINDOW]) (FMC-SELECT.LIST.ITEM [LAMBDA (ITEM WINDOW) (* ; "Edited 17-Aug-88 10:56 by A.BLAVIER") (* ;; "Highlight ITEM, member of the selection list, as a part of a multiple selection.") (LET* ((Reg (FMC-GET.ITEM ITEM REGION)) RLeft RBottom RRight RTop) (SETQ RLeft (IDIFFERENCE (GET.REGION.LEFT Reg) 2)) (SETQ RBottom (IDIFFERENCE (GET.REGION.BOTTOM Reg) 2)) (SETQ RRight (IPLUS (fetch (REGION RIGHT) of Reg) 2)) (SETQ RTop (IPLUS (fetch (REGION TOP) of Reg) 2)) (* ;; "") (DRAWLINE RLeft RBottom RRight RBottom 1 'REPLACE WINDOW NIL '(1 3)) (DRAWLINE RRight RBottom RRight RTop 1 'REPLACE WINDOW NIL '(1 3)) (DRAWLINE RRight RTop RLeft RTop 1 'REPLACE WINDOW NIL '(1 3)) (DRAWLINE RLeft RTop RLeft RBottom 1 'REPLACE WINDOW NIL '(1 3]) (FMC-SELECTALL [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 10:58 by A.BLAVIER") (* ;; "Select all the items of WINDOW.") (if (WINDOWPROP WINDOW 'SELECTED.ITEM) then (FMC-DESELECT.ITEM WINDOW)) (WINDOWPROP WINDOW 'SELECTION.LIST (WINDOWPROP WINDOW 'ITEMLIST)) (FMC-SELECT.LIST WINDOW]) (FMC-GET.SELECTION [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 11:23 by A.BLAVIER") (* ;; "META + LEFT Button outside any item --> let the user select a region and add the enclosed items to the selection list.") (LET ((SelectedItem (WINDOWPROP WINDOW 'SELECTED.ITEM)) (SelectionRegion (GETREGION)) (WLeft (IPLUS (GET.REGION.LEFT (WINDOWPROP WINDOW 'REGION)) 3)) (WBottom (IPLUS (GET.REGION.BOTTOM (WINDOWPROP WINDOW 'REGION)) 3))) (* ;; "convert SelectionRegion from Screen to Window coordinates") (PUT.REGION.LEFT SelectionRegion (IDIFFERENCE (GET.REGION.LEFT SelectionRegion) WLeft)) (PUT.REGION.BOTTOM SelectionRegion (IDIFFERENCE (GET.REGION.BOTTOM SelectionRegion) WBottom)) (for item in (WINDOWPROP WINDOW 'ITEMLIST) do (if (SUBREGIONP SelectionRegion (FMC-GET.ITEM item REGION)) then (WINDOWADDPROP WINDOW 'SELECTION.LIST item) (FMC-SELECT.LIST.ITEM item WINDOW) (if SelectedItem then (* ;; "if there was a unique selection then add it to the multiple selection") (WINDOWADDPROP WINDOW 'SELECTION.LIST SelectedItem T) (FMC-DESELECT.ITEM WINDOW) (FMC-SELECT.LIST.ITEM SelectedItem WINDOW) (SETQ SelectedItem NIL]) (FMC-DESELECT [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 11:24 by A.BLAVIER") (* ;; "Lowlight any selection.") (if (WINDOWPROP WINDOW 'SELECTED.ITEM) then (FMC-DESELECT.ITEM WINDOW)) (if (WINDOWPROP WINDOW 'SELECTION.LIST) then (FMC-DESELECT.LIST WINDOW]) (FMC-DESELECT.ITEM [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 11:25 by A.BLAVIER") (* ;; "Lowlight the unique selected item of WINDOW.") (LET ((Item (WINDOWPROP WINDOW 'SELECTED.ITEM)) Region Rleft Rbottom Rright Rtop) (SETQ Region (FMC-GET.ITEM Item REGION)) (SETQ Rleft (IDIFFERENCE (GET.REGION.LEFT Region) 2)) (SETQ Rbottom (IDIFFERENCE (GET.REGION.BOTTOM Region) 2)) (SETQ Rright (IPLUS (fetch (REGION RIGHT) of Region) 2)) (SETQ Rtop (IPLUS (fetch (REGION TOP) of Region) 2)) (* ;; "") (DRAWLINE Rleft Rbottom Rright Rbottom 1 'ERASE WINDOW) (DRAWLINE Rright Rbottom Rright Rtop 1 'ERASE WINDOW) (DRAWLINE Rright Rtop Rleft Rtop 1 'ERASE WINDOW) (DRAWLINE Rleft Rtop Rleft Rbottom 1 'ERASE WINDOW) (WINDOWPROP WINDOW 'SELECTED.ITEM NIL]) (FMC-DESELECT.LIST [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 11:25 by A.BLAVIER") (* ;; "Lowlight all the items of a multiple selection.") (for item in (WINDOWPROP WINDOW 'SELECTION.LIST) do (FMC-DESELECT.LIST.ITEM item WINDOW)) (WINDOWPROP WINDOW 'SELECTION.LIST NIL]) (FMC-DESELECT.LIST.ITEM [LAMBDA (ITEM WINDOW) (* ; "Edited 17-Aug-88 11:29 by A.BLAVIER") (* ;; "Lowlight one item, member of a multiple selection.") (LET ((Reg (fetch (FMC-ITEM REGION) of ITEM)) RLeft RBottom RRight RTop) (SETQ RLeft (IDIFFERENCE (GET.REGION.LEFT Reg) 2)) (SETQ RBottom (IDIFFERENCE (GET.REGION.BOTTOM Reg) 2)) (SETQ RRight (IPLUS (fetch (REGION RIGHT) of Reg) 2)) (SETQ RTop (IPLUS (fetch (REGION TOP) of Reg) 2)) (* ;; "") (DRAWLINE RLeft RBottom RRight RBottom 1 'ERASE WINDOW) (DRAWLINE RRight RBottom RRight RTop 1 'ERASE WINDOW) (DRAWLINE RRight RTop RLeft RTop 1 'ERASE WINDOW) (DRAWLINE RLeft RTop RLeft RBottom 1 'ERASE WINDOW) (WINDOWDELPROP WINDOW 'SELECTION.LIST ITEM]) ) (* * Property windows functions) (DEFINEQ (FMC-APPLY [LAMBDA (ITEM PROP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 11:51 by A.BLAVIER") (* ;; "User clicked in the APPLY item of the Item or Group Properties Free Menu : apply property(ies) to selected item(s).") (LET ((MainWindow (WINDOWPROP PROP.WINDOW 'MAIN.WINDOW)) (Prop T) Unique? ItemList) (* ;; "") (SETQ Unique? (WINDOWPROP MainWindow 'SELECTED.ITEM)) [if Unique? then (WINDOWPROP MainWindow 'SELECTION.LIST (LIST (WINDOWPROP MainWindow 'SELECTED.ITEM] (SETQ ItemList (WINDOWPROP MainWindow 'SELECTION.LIST)) (* ;; "") (if (STREQUAL (WINDOWPROP PROP.WINDOW 'TITLE) "ITEM PROPERTIES") then (* ;; "Request comes from the ITEM Properties window") (* ;; "Check that no GROUP is in the selection") [if (for i in ItemList thereis (FMC-GROUP? i)) then (FMC-PROMPTPRINT "Can't apply to GROUPs" MainWindow) else [if (IGREATERP (LENGTH ItemList) 1) then (* ;; "if there is more than one selected item then apply only ONE property to each item") (SETQ Prop (MENU (create MENU ITEMS _ '(TYPE LABEL BOX BOXSHADE BACKGROUND FONT CHANGESTATE SELECTEDFN DOWNFN HELDFN MOVEDFN) TITLE _ "Apply which Property ?"] (if Prop then (FMC-DESELECT.LIST MainWindow) (for item in ItemList do (DSPFILL (FMC-GET.ITEM item REGION) WHITESHADE 'REPLACE MainWindow) (if Unique? then (FMC-UPDATE.ITEM item 'ALL PROP.WINDOW) else (FMC-UPDATE.ITEM item Prop PROP.WINDOW)) (FMC-REDRAW.ITEM item MainWindow)) (if Unique? then (WINDOWPROP MainWindow 'SELECTED.ITEM (CAR ItemList)) (WINDOWPROP MainWindow 'SELECTION.LIST NIL) (FMC-SELECT.ITEM MainWindow) else (WINDOWPROP MainWindow 'SELECTION.LIST ItemList) (FMC-SELECT.LIST MainWindow] else (* ;; "Request comes from the GROUP Properties window") (* ;; "Check that the selection is unique and that it's a GROUP") (if (AND (EQP (LENGTH ItemList) 1) (FMC-GROUP? (CAR ItemList))) then (FMC-DESELECT.LIST MainWindow) (DSPFILL (FMC-GET.ITEM (CAR ItemList) REGION) WHITESHADE 'REPLACE MainWindow) (FMC-UPDATE.GROUP (CAR ItemList) PROP.WINDOW) (FMC-REDRAW.ITEM (CAR ItemList) MainWindow) (WINDOWPROP MainWindow 'SELECTED.ITEM (CAR ItemList)) (WINDOWPROP MainWindow 'SELECTION.LIST NIL) (FMC-SELECT.ITEM MainWindow) else (if [AND (IGREATERP (LENGTH ItemList) 0) (NOT (FMC-GROUP? (CAR ItemList] then (FMC-PROMPTPRINT "Can't apply to simple ITEMs" MainWindow]) (FMC-SHOW.ITEM [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 11:47 by A.BLAVIER") (* ;; "User clicked in the SHOW item of the Item Properties Free Menu : update the Free Menu according to the first selected item.") (LET ((MainWindow (WINDOWPROP IP.WINDOW 'MAIN.WINDOW)) Item ItemBox ItemFont) [SETQ Item (OR (WINDOWPROP MainWindow 'SELECTED.ITEM) (CAR (WINDOWPROP MainWindow 'SELECTION.LIST] (SETQ ItemBox (FMC-GET.ITEM Item BOX)) (SETQ ItemFont (FMC-GET.ITEM Item FONT)) (if Item then (if (FMC-GROUP? Item) then (FMC-PROMPTPRINT "Can't show GROUPs" MainWindow) else (FM.CHANGESTATE 'TYPE (FMC-GET.ITEM Item TYPE) IP.WINDOW) (FM.CHANGELABEL 'LABELLINK (FMC-GET.ITEM Item LABEL) IP.WINDOW) (FM.CHANGELABEL 'IDLINK (FMC-GET.ITEM Item ID) IP.WINDOW) (FM.CHANGESTATE 'BOX (if ItemBox then ItemBox else 0) IP.WINDOW) (FM.CHANGESTATE 'BOXSHADE [CAR (CADADR (FMC-CREATE.SHADE.ITEM (FMC-GET.ITEM Item BOXSHADE ] IP.WINDOW) (WINDOWPROP IP.WINDOW 'FMC.ITEM.BOXSHADE (FMC-GET.ITEM Item BOXSHADE)) (FM.CHANGESTATE 'BACKGROUND [CAR (CADADR (FMC-CREATE.SHADE.ITEM ( FMC-GET.ITEM Item BACKGROUND] IP.WINDOW) (WINDOWPROP IP.WINDOW 'FMC.ITEM.BACKGROUND (FMC-GET.ITEM Item BACKGROUND)) (FM.CHANGESTATE 'FAMILY (CAR ItemFont) IP.WINDOW) (FM.CHANGESTATE 'SIZE (CADR ItemFont) IP.WINDOW) (FM.CHANGESTATE 'FACE (CADDR ItemFont) IP.WINDOW) (FM.CHANGELABEL 'MESSAGELINK (FMC-GET.ITEM Item MESSAGE) IP.WINDOW) (for prop in '(CHANGESTATE SELECTEDFN DOWNFN HELDFN MOVEDFN) bind Def do (SETQ Def (SELECTQ prop ((CHANGESTATE) (FMC-GET.ITEM Item CHANGESTATE)) ((SELECTEDFN) (FMC-GET.ITEM Item SELECTEDFN)) ((DOWNFN) (FMC-GET.ITEM Item DOWNFN)) ((HELDFN) (FMC-GET.ITEM Item HELDFN)) ((MOVEDFN) (FMC-GET.ITEM Item MOVEDFN)) T)) (FM.CHANGESTATE prop (if (ATOM Def) then (MKATOM (LIST 'FUNCTION Def)) else (MKATOM Def)) IP.WINDOW) (WINDOWPROP IP.WINDOW (PACK* 'FMC.ITEM. prop) (if (ATOM Def) then (LIST 'FUNCTION Def) else Def))) (FM.CHANGESTATE 'INFINITEWIDTH (FMC-GET.ITEM Item INFINITEWIDTH) IP.WINDOW) (FM.CHANGESTATE 'MENU (MKATOM (FMC-GET.ITEM Item MENU)) IP.WINDOW) (WINDOWPROP IP.WINDOW 'FMC.ITEM.MENUPROPS (FMC-GET.ITEM Item MENU)) (FM.CHANGESTATE 'LINKS (MKATOM (FMC-GET.ITEM Item LINKS)) IP.WINDOW) (WINDOWPROP IP.WINDOW 'FMC.ITEM.LINKS (FMC-GET.ITEM Item LINKS)) (FM.CHANGESTATE 'INITSTATE (FMC-GET.ITEM Item INITSTATE) IP.WINDOW]) (FMC-SHOW.GROUP [LAMBDA (GPW.ITEM GP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 11:52 by A.BLAVIER") (* ;; "User clicked in the SHOW item of the Group Properties Free Menu : update the Free Menu according to the unique selected item.") (LET ((MainWindow (WINDOWPROP GP.WINDOW 'MAIN.WINDOW)) Item) (SETQ Item (WINDOWPROP MainWindow 'SELECTED.ITEM)) (if Item then (if (FMC-GROUP? Item) then (FM.CHANGELABEL 'IDLINK (FMC-GET.ITEM Item ID) GP.WINDOW) (FM.CHANGELABEL 'COLLECTIONLINK (if (FMC-GET.ITEM Item COLLECTION) then (FMC-GET.ITEM Item COLLECTION) else "") GP.WINDOW) (FM.CHANGESTATE 'DESELECT (FMC-GET.ITEM Item DESELECT) GP.WINDOW) (FM.CHANGESTATE 'BOX (FMC-GET.ITEM Item BOX) GP.WINDOW) (FM.CHANGESTATE 'BOXSHADE [CAR (CADADR (FMC-CREATE.SHADE.ITEM ( FMC-GET.ITEM Item BOXSHADE] GP.WINDOW) (WINDOWPROP GP.WINDOW 'FMC.ITEM.BOXSHADE (FMC-GET.ITEM Item BOXSHADE)) (FM.CHANGESTATE 'BACKGROUND [CAR (CADADR (FMC-CREATE.SHADE.ITEM (FMC-GET.ITEM Item BACKGROUND] GP.WINDOW) (WINDOWPROP GP.WINDOW 'FMC.ITEM.BACKGROUND (FMC-GET.ITEM Item BACKGROUND)) else (FMC-PROMPTPRINT "Can't show simple items" MainWindow]) (FMC-NEWITEM [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 12:00 by A.BLAVIER") (* ;; "User clicked in the NEW item of the Item Properties window : create a new FMC item.") (LET ((MainWindow (WINDOWPROP IP.WINDOW 'MAIN.WINDOW)) (NewItem (create FMC-ITEM))) (* ;; "set this new item's properties according to the IP window") (FMC-UPDATE.ITEM NewItem 'ALL IP.WINDOW) (* ;; "if the cursor is currently outside the main window, move it inside") (if (NOT (INSIDEP (DSPCLIPPINGREGION NIL MainWindow) (CURSORPOSITION NIL MainWindow))) then (CURSORPOSITION '(5 . 5) MainWindow)) (* ;; "remove any previous selection") (if (WINDOWPROP MainWindow 'SELECTED.ITEM) then (FMC-DESELECT.ITEM MainWindow)) (if (WINDOWPROP MainWindow 'SELECTION.LIST) then (FMC-DESELECT.LIST MainWindow)) (* ;; "let the user place the item where he wants") (FMC-TRACK.NEW.ITEM NewItem MainWindow) (WINDOWADDPROP MainWindow 'ITEMLIST NewItem) (* ;; "make the new item the unique selection") (WINDOWPROP MainWindow 'SELECTED.ITEM NewItem) (FMC-REDRAW.ITEM NewItem MainWindow) (FMC-SELECT.ITEM MainWindow) (FMC-COMPUTE.SHAPE.REGS MainWindow]) (FMC-UPDATE.ITEM [LAMBDA (ITEM PROP IP.WINDOW) (* ; "Edited 11-Aug-88 14:29 by A.BLAVIER") (* ;; "Update ITEM's fields according to the Item Properties Free Menu.") (* ;; "PROP is either ALL or one of LABEL, BOX, BOXSHADE, BACKGROUND, FONT, CHANGESTATE, SELECTEDFN, DOWNFN, HELDFN, MOVEDFN ") (LET (ItemLabel ItemBox ItemBitmap) (FMC-MARK.AS.CHANGED (WINDOWPROP IP.WINDOW 'MAIN.WINDOW)) (* ;; "update LABEL") (if (FMEMB PROP '(ALL LABEL)) then (SETQ ItemLabel (FM-GET.ITEM.LABEL 'LABELLINK IP.WINDOW)) (if (NULLSTR ItemLabel) then (SETQ ItemLabel "*NOLABEL*")) (FMC-PUT.ITEM ITEM LABEL ItemLabel) else (SETQ ItemLabel (FMC-GET.ITEM ITEM LABEL))) (* ;; "update BACKGROUND") [if (FMEMB PROP '(ALL BACKGROUND)) then (FMC-PUT.ITEM ITEM BACKGROUND (WINDOWPROP IP.WINDOW 'FMC.ITEM.BACKGROUND] (* ;; "update BOX if required. Anyway keep the value of BOX : we'll need it later") (if (FMEMB PROP '(ALL BOX)) then (SETQ ItemBox (FM-GET.ITEM.STATE 'BOX IP.WINDOW)) (if (EQP ItemBox 0) then (SETQ ItemBox NIL)) (FMC-PUT.ITEM ITEM BOX ItemBox) else (SETQ ItemBox (FMC-GET.ITEM ITEM BOX))) (* ;; "update BOXSHADE") (if (FMEMB PROP '(ALL BOXSHADE)) then (FMC-PUT.ITEM ITEM BOXSHADE (if ItemBox then (WINDOWPROP IP.WINDOW 'FMC.ITEM.BOXSHADE) else NIL))) (* ;; "update TYPE") (if (FMEMB PROP '(ALL TYPE)) then (FMC-PUT.ITEM ITEM TYPE (FM-GET.ITEM.STATE 'TYPE IP.WINDOW))) (* ;; "update FONT") [if (FMEMB PROP '(ALL FONT)) then (FMC-PUT.ITEM ITEM FONT (LIST (FM-GET.ITEM.STATE 'FAMILY IP.WINDOW) (FM-GET.ITEM.STATE 'SIZE IP.WINDOW) (FM-GET.ITEM.STATE 'FACE IP.WINDOW] (* ;; "update CHANGESTATE, SELECTEDFN, DOWNFN, HELDFN, MOVEDFN") (SELECTQ PROP ((ALL) (FMC-PUT.ITEM ITEM CHANGESTATE (WINDOWPROP IP.WINDOW 'FMC.ITEM.CHANGESTATE)) (FMC-PUT.ITEM ITEM SELECTEDFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.SELECTEDFN)) (FMC-PUT.ITEM ITEM DOWNFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.DOWNFN)) (FMC-PUT.ITEM ITEM HELDFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.HELDFN)) (FMC-PUT.ITEM ITEM MOVEDFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.MOVEDFN))) ((CHANGESTATE) (FMC-PUT.ITEM ITEM CHANGESTATE (WINDOWPROP IP.WINDOW 'FMC.ITEM.CHANGESTATE))) ((SELECTEDFN) (FMC-PUT.ITEM ITEM SELECTEDFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.SELECTEDFN))) ((DOWNFN) (FMC-PUT.ITEM ITEM DOWNFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.DOWNFN))) ((HELDFN) (FMC-PUT.ITEM ITEM HELDFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.HELDFN))) ((MOVEDFN) (FMC-PUT.ITEM ITEM MOVEDFN (WINDOWPROP IP.WINDOW 'FMC.ITEM.MOVEDFN))) T) (* ;; "update ID, MESSAGE, MENU, LINKS, INITSTATE, INFINITEWIDTH") (if (EQ PROP 'ALL) then [FMC-PUT.ITEM ITEM ID (if (NULLSTR (FM-GET.ITEM.LABEL 'IDLINK IP.WINDOW)) then NIL else (MKATOM (FM-GET.ITEM.LABEL 'IDLINK IP.WINDOW] (FMC-PUT.ITEM ITEM MESSAGE (FM-GET.ITEM.LABEL 'MESSAGELINK IP.WINDOW)) (FMC-PUT.ITEM ITEM MENU (WINDOWPROP IP.WINDOW 'FMC.ITEM.MENUPROPS)) (FMC-PUT.ITEM ITEM LINKS (WINDOWPROP IP.WINDOW 'FMC.ITEM.LINKS)) (FMC-PUT.ITEM ITEM INITSTATE (FM-GET.ITEM.STATE 'INITSTATE IP.WINDOW)) (FMC-PUT.ITEM ITEM INFINITEWIDTH (FM-GET.ITEM.STATE 'INFINITEWIDTH IP.WINDOW))) (* ;; "recompute the bitmap") [SETQ ItemBitmap (FMC-MAKEBITMAP ItemLabel (FMC-LIST->FONT (FMC-GET.ITEM ITEM FONT] (FMC-PUT.ITEM ITEM BITMAP ItemBitmap) (* ;; "if ITEM has no region yet, then it's a new item --> create the region") [if (NOT (FMC-GET.ITEM ITEM REGION)) then (FMC-PUT.ITEM ITEM REGION (CREATEREGION 5 5 (BITMAPWIDTH ItemBitmap) (BITMAPHEIGHT ItemBitmap] (* ;; "update XBMOFFSET and YBMOFFSET") (if (NOT ItemBox) then (FMC-PUT.ITEM ITEM XBMOFFSET 0) (FMC-PUT.ITEM ITEM YBMOFFSET 0)) (if (AND ItemBox (EQP (FMC-GET.ITEM ITEM YBMOFFSET) 0)) then (FMC-PUT.ITEM ITEM XBMOFFSET 2) (FMC-PUT.ITEM ITEM YBMOFFSET 2)) (* ;; "update REGION according to BITMAP and BOXSPACE") (FMC-PUT.ITEM ITEM REGION (CREATEREGION (GET.REGION.LEFT (FMC-GET.ITEM ITEM REGION)) (GET.REGION.BOTTOM (FMC-GET.ITEM ITEM REGION)) (IPLUS (BITMAPWIDTH ItemBitmap) (FMC-GET.ITEM ITEM XBMOFFSET) (FMC-GET.ITEM ITEM XBMOFFSET)) (IPLUS (BITMAPHEIGHT ItemBitmap) (FMC-GET.ITEM ITEM YBMOFFSET) (FMC-GET.ITEM ITEM YBMOFFSET]) (FMC-UPDATE.GROUP [LAMBDA (GROUP GP.WINDOW) (* ; "Edited 11-Aug-88 16:45 by A.BLAVIER") (* ;; "Update GROUP's fields according to the Group Properties Free Menu.") (FMC-MARK.AS.CHANGED (WINDOWPROP GP.WINDOW 'MAIN.WINDOW)) (* ;; "update ID") [FMC-PUT.ITEM GROUP ID (if (NULLSTR (FM-GET.ITEM.LABEL 'IDLINK GP.WINDOW)) then NIL else (MKATOM (FM-GET.ITEM.LABEL 'IDLINK GP.WINDOW] (* ;; "update COLLECTION. Check that all the subitems are NWAY.") [if (NULLSTR (FM-GET.ITEM.LABEL 'COLLECTIONLINK GP.WINDOW)) then (FMC-PUT.ITEM GROUP COLLECTION NIL) else (if (for i in (FMC-GET.ITEM GROUP OBJECTLIST) thereis (NEQ (FMC-GET.ITEM i TYPE) 'NWAY)) then (FMC-PROMPTPRINT "All items in GROUP should be NWAY" (WINDOWPROP GP.WINDOW 'MAIN.WINDOW)) else (FMC-PUT.ITEM GROUP COLLECTION (MKATOM (FM-GET.ITEM.LABEL 'COLLECTIONLINK GP.WINDOW ] (* ;; "update DESELECT") (FMC-PUT.ITEM GROUP DESELECT (FM-GET.ITEM.STATE 'DESELECT GP.WINDOW)) (* ;; "update BOX") (FMC-PUT.ITEM GROUP BOX (FM-GET.ITEM.STATE 'BOX GP.WINDOW)) (* ;; "update BOXSHADE") (FMC-PUT.ITEM GROUP BOXSHADE (WINDOWPROP GP.WINDOW 'FMC.ITEM.BOXSHADE)) (* ;; "update BACKGROUND") (FMC-PUT.ITEM GROUP BACKGROUND (WINDOWPROP GP.WINDOW 'FMC.ITEM.BACKGROUND]) (FMC-GET.LABEL [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 12:08 by A.BLAVIER") (* ;; "User clicked in the LABEL item of the IP window.") (COND ((EQUAL BUTTON '(LEFT)) (* ;; "he LEFT buttoned : edit the field") (FM.EDITITEM 'LABELLINK IP.WINDOW)) ((EQUAL BUTTON '(MIDDLE)) (* ;; "he MIDDLE buttoned : grab a bitmap from screen and set LABEL to it") (FM.CHANGELABEL 'LABELLINK (FMC-SNAPBM) IP.WINDOW T)) ((EQUAL BUTTON '(RIGHT)) (* ;; "he RIGHT buttoned : edit the field, clearing it first") (FM.EDITITEM 'LABELLINK IP.WINDOW T]) (FMC-CHOOSE.ITEM.BOXSHADE [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 12:10 by A.BLAVIER") (* ;; "User clicked in the BOXSHADE item of the Item or Group Prop window : let him choose a shade from a menu.") (LET ((ShadeMenu (WINDOWPROP IP.WINDOW 'SHADE.MENU)) Shade) (SETQ Shade (MENU ShadeMenu)) (if Shade then (FM.CHANGESTATE 'BOXSHADE (CAR Shade) IP.WINDOW) (WINDOWPROP IP.WINDOW 'FMC.ITEM.BOXSHADE (CDR Shade]) (FMC-CHOOSE.ITEM.BG [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 12:12 by A.BLAVIER") (* ;; "User clicked in the BACKGROUND item of the Item or Group Prop window : let him choose a background from a menu.") (LET ((ShadeMenu (WINDOWPROP IP.WINDOW 'SHADE.MENU)) Shade) (SETQ Shade (MENU ShadeMenu)) (if Shade then (FM.CHANGESTATE 'BACKGROUND (CAR Shade) IP.WINDOW) (WINDOWPROP IP.WINDOW 'FMC.ITEM.BACKGROUND (CDR Shade]) (FMC-GET.MENUPROPS [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 12:15 by A.BLAVIER") (* ;; "User clicked in the MENU button of the IP window : edit an EXPR where CAR is a list of menu items, CADR a font description list, CADDR a title for the menu.") (LET (Expr) [if (CAR (WINDOWPROP IP.WINDOW 'FMC.ITEM.MENUPROPS)) then [SETQ Expr (EDITE (COPYALL (WINDOWPROP IP.WINDOW 'FMC.ITEM.MENUPROPS] else (SETQ Expr (EDITE (COPYALL '(("ITEMS") "[FONT]" "[TITLE]"] (* ;; "a FM label can't be a list, so make it an atom") (FM.CHANGESTATE 'MENU (MKATOM Expr) IP.WINDOW) (* ;; "but keep the list in mind") (WINDOWPROP IP.WINDOW 'FMC.ITEM.MENUPROPS Expr]) (FMC-GET.INITSTATE [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 12:28 by A.BLAVIER") (* ;; "User clicked in the INITSTATE button of the IP window.") (LET ((MainWindow (WINDOWPROP IP.WINDOW 'MAIN.WINDOW)) (ItemType (FM-GET.ITEM.STATE 'TYPE IP.WINDOW)) (MenuProps (WINDOWPROP IP.WINDOW 'FMC.ITEM.MENUPROPS)) InitstateMenuItems Choice PromptWindow) (* ;; "The INITSTATE property is relevant only for TOGGLE, 3STATE and STATE items.") (if (FMEMB ItemType '(TOGGLE 3STATE STATE)) then (* ;;  "pop up a menu with the possible values for the INITSTATE, depending on the item type") (SETQ InitstateMenuItems (SELECTQ ItemType (TOGGLE '("NIL" T)) (3STATE '(OFF "NIL" T)) (STATE (if (CAR MenuProps) then (APPEND '("NIL" T) (CAR MenuProps) '(OTHER)) else '("NIL" T OTHER))) T)) (SETQ Choice (MENU (create MENU ITEMS _ InitstateMenuItems))) (* ;; "nothing is appropriate : let him specify a value") [if (EQ Choice 'OTHER) then (SETQ PromptWindow (WINDOWPROP MainWindow 'FMC.PROMPTWINDOW)) (DSPRESET PromptWindow) (TTY.PROCESS (THIS.PROCESS)) (SETQ Choice (PROMPTFORWORD "INITSTATE :" NIL "Type in an unevaluated expression" PromptWindow NIL NIL (CHARCODE (EOL ESCAPE LF TAB] else (SETQ Choice NIL) (FM.CHANGESTATE 'INITSTATE Choice IP.WINDOW)) (if Choice then (if (STREQUAL Choice "NIL") then (SETQ Choice NIL)) (FM.CHANGESTATE 'INITSTATE Choice IP.WINDOW]) (FMC-EDIT.FN [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 13:36 by A.BLAVIER") (* ;; "User wants to specify a function property : open a SEdit window.") (* ;; "Expr should be of the form (FUNCTION FNname) or a LAMDA expression") (LET ((Prop (FM.ITEMPROP IPW.ITEM 'ID)) Expr) [SETQ Expr (EDITE (COPYALL (WINDOWPROP IP.WINDOW (PACK* 'FMC.ITEM. Prop] (FM.CHANGESTATE Prop (MKATOM Expr) IP.WINDOW) (WINDOWPROP IP.WINDOW (PACK* 'FMC.ITEM. Prop) Expr]) (FMC-LINKS [LAMBDA (IPW.ITEM IP.WINDOW BUTTON) (* ; "Edited 17-Aug-88 13:44 by A.BLAVIER") (* ;; "User clicked in the LINKS button of the IP window : let him add or remove a link.") (LET ((MainWindow (WINDOWPROP IP.WINDOW 'MAIN.WINDOW)) [LinkMenu (create MENU ITEMS _ '(("Add Link" 'ADD) ("Remove Link" 'REMOVE] Item Id Link) (SELECTQ (MENU LinkMenu) (ADD (FMC-PROMPTPRINT "Click on the item you want to link to" MainWindow) (until (MOUSESTATE LEFT)) (if [SETQ Item (for i in (WINDOWPROP MainWindow 'ITEMLIST) thereis (INSIDEP (FMC-GET.ITEM i REGION) (CURSORPOSITION NIL MainWindow] then (SETQ Id (FMC-GET.ITEM Item ID)) (if Id then (SETQ Link (LIST (FMC-GET.ITEM Item TYPE) (MKATOM Id))) (WINDOWPROP IP.WINDOW 'FMC.ITEM.LINKS Link) (FM.CHANGESTATE 'LINKS (MKATOM Link) IP.WINDOW) else (FMC-PROMPTPRINT "This item has no ID - can't link" MainWindow))) (while (MOUSESTATE LEFT))) (REMOVE (WINDOWPROP IP.WINDOW 'FMC.ITEM.LINKS '(NIL)) (FM.CHANGESTATE 'LINKS "(NIL)" IP.WINDOW)) T]) ) (* * Property windows descriptions) (RPAQQ FMC-IP-DESC ((PROPS FORMAT EXPLICIT) (LABEL APPLY TYPE MOMENTARY LEFT 0 BOTTOM 195 BOX 1 BOXSHADE 65535 BOXSPACE 1 FONT (MODERN 14 BOLDITALIC) SELECTEDFN FMC-APPLY) (LABEL SHOW TYPE MOMENTARY LEFT 49 BOTTOM 195 BOX 1 BOXSHADE 65535 BOXSPACE 1 FONT (MODERN 14 BOLDITALIC) SELECTEDFN FMC-SHOW.ITEM) (LABEL NEW TYPE MOMENTARY LEFT 111 BOTTOM 195 BOX 1 BOXSHADE 65535 BOXSPACE 1 FONT (MODERN 14 BOLDITALIC) SELECTEDFN FMC-NEWITEM) (LABEL TYPE TYPE STATE LEFT -1 BOTTOM 178 FONT (MODERN 12 BOLD) MENUITEMS (MOMENTARY TOGGLE 3STATE STATE NWAY EDIT NUMBER EDITSTART DISPLAY) LINKS (DISPLAY TYPELINK) INITSTATE MOMENTARY) (LABEL MOMENTARY TYPE DISPLAY LEFT 31 BOTTOM 177 ID TYPELINK FONT (MODERN 12 STANDARD)) (LABEL LABEL TYPE MOMENTARY LEFT 113 BOTTOM 178 FONT (MODERN 12 BOLD) SELECTEDFN FMC-GET.LABEL LINKS (EDIT LABELLINK)) (LABEL "" TYPE EDIT LEFT 151 BOTTOM 177 ID LABELLINK FONT (MODERN 12 STANDARD) INITSTATE "IIIIMMMMMMMMMMMMMMM") (LABEL ID TYPE EDITSTART LEFT -1 BOTTOM 162 FONT (MODERN 12 BOLD) LINKS (EDIT IDLINK)) (LABEL "" TYPE EDIT LEFT 14 BOTTOM 161 ID IDLINK FONT (MODERN 12 STANDARD) INITSTATE "") (LABEL FONT TYPE DISPLAY LEFT -1 BOTTOM 146 FONT (MODERN 12 ITALIC)) (LABEL FAMILY TYPE STATE LEFT 32 BOTTOM 146 ID FAMILY FONT (MODERN 12 BOLD) MENUITEMS (CLASSIC MODERN TERMINAL TITAN GACHA HELVETICA TIMESROMAN) LINKS (DISPLAY FAMILYLINK) INITSTATE GACHA) (LABEL GACHA TYPE DISPLAY LEFT 77 BOTTOM 145 ID FAMILYLINK FONT (MODERN 12 STANDARD)) (LABEL SIZE TYPE STATE LEFT 161 BOTTOM 146 ID SIZE FONT (MODERN 12 BOLD) MENUITEMS (6 7 8 9 10 11 12 14 18 24 30 36) LINKS (DISPLAY SIZELINK) INITSTATE 12) (LABEL 10 TYPE DISPLAY LEFT 191 BOTTOM 145 ID SIZELINK FONT (MODERN 12 STANDARD)) (LABEL FACE TYPE STATE LEFT 210 BOTTOM 146 ID FACE FONT (MODERN 12 BOLD) MENUITEMS (REGULAR ITALIC BOLD BOLDITALIC) LINKS (DISPLAY FACELINK) INITSTATE BOLDITALIC) (LABEL REGULAR TYPE DISPLAY LEFT 241 BOTTOM 145 ID FACELINK FONT (MODERN 12 STANDARD) ) (LABEL BOX TYPE STATE LEFT -1 BOTTOM 130 FONT (MODERN 12 BOLD) MENUITEMS (0 1 2 3 4 5 6 7 8 9 10) LINKS (DISPLAY BOXLINK) INITSTATE 0) (LABEL 0 TYPE DISPLAY LEFT 26 BOTTOM 129 ID BOXLINK FONT (MODERN 12 STANDARD)) (LABEL BOXSHADE TYPE STATE LEFT 40 BOTTOM 130 FONT (MODERN 12 BOLD) SELECTEDFN FMC-CHOOSE.ITEM.BOXSHADE LINKS (DISPLAY BOXSHADELINK)) (LABEL "" TYPE DISPLAY LEFT 107 BOTTOM 130 ID BOXSHADELINK FONT (MODERN 12 STANDARD) MAXWIDTH 60) (LABEL BACKGROUND TYPE STATE LEFT 176 BOTTOM 130 ID BACKGROUND FONT (MODERN 12 BOLD) SELECTEDFN FMC-CHOOSE.ITEM.BG LINKS (DISPLAY BACKGROUNDLINK)) (LABEL "" TYPE DISPLAY LEFT 262 BOTTOM 130 ID BACKGROUNDLINK FONT (MODERN 12 STANDARD) MAXWIDTH 60) (LABEL MENU TYPE STATE LEFT -1 BOTTOM 114 FONT (MODERN 12 BOLD) SELECTEDFN FMC-GET.MENUPROPS LINKS (DISPLAY MENULINK) INITSTATE "(NIL)") (LABEL "(NIL)" TYPE DISPLAY LEFT 39 BOTTOM 113 ID MENULINK FONT (MODERN 12 STANDARD)) (LABEL INITSTATE TYPE STATE LEFT 195 BOTTOM 114 ID INITSTATE FONT (MODERN 12 BOLD) SELECTEDFN FMC-GET.INITSTATE LINKS (DISPLAY INITSTATELINK)) (LABEL "#NOLABEL#" TYPE DISPLAY LEFT 257 BOTTOM 113 ID INITSTATELINK FONT (MODERN 12 STANDARD)) (LABEL CHANGESTATE TYPE STATE LEFT -1 BOTTOM 98 ID CHANGESTATE FONT (MODERN 12 BOLD) SELECTEDFN FMC-EDIT.FN LINKS (DISPLAY CHANGESTATELINK) INITSTATE "(FUNCTION NILL)") (LABEL "(FUNCTION NILL)" TYPE DISPLAY LEFT 89 BOTTOM 97 ID CHANGESTATELINK FONT (MODERN 12 STANDARD)) (LABEL SELECTEDFN TYPE STATE LEFT -1 BOTTOM 81 ID SELECTEDFN FONT (MODERN 12 BOLD) SELECTEDFN FMC-EDIT.FN LINKS (DISPLAY SELECTEDFNLINK) INITSTATE "(FUNCTION NILL)") (LABEL "(FUNCTION NILL)" TYPE DISPLAY LEFT 75 BOTTOM 80 ID SELECTEDFNLINK FONT (MODERN 12 STANDARD)) (LABEL "DOWNFN" TYPE STATE LEFT -1 BOTTOM 65 ID DOWNFN FONT (MODERN 12 BOLD) SELECTEDFN FMC-EDIT.FN LINKS (DISPLAY DOWNFNLINK) INITSTATE "(FUNCTION NILL)") (LABEL "(FUNCTION NILL)" TYPE DISPLAY LEFT 57 BOTTOM 64 ID DOWNFNLINK FONT (MODERN 12 STANDARD)) (LABEL "HELDFN" TYPE STATE LEFT -1 BOTTOM 49 ID HELDFN FONT (MODERN 12 BOLD) SELECTEDFN FMC-EDIT.FN LINKS (DISPLAY HELDFNLINK) INITSTATE "(FUNCTION NILL)") (LABEL "(FUNCTION NILL)" TYPE DISPLAY LEFT 49 BOTTOM 48 ID HELDFNLINK FONT (MODERN 12 STANDARD)) (LABEL "MOVEDFN" TYPE STATE LEFT -1 BOTTOM 33 ID MOVEDFN FONT (MODERN 12 BOLD) SELECTEDFN FMC-EDIT.FN LINKS (DISPLAY MOVEDFNLINK) INITSTATE "(FUNCTION NILL)") (LABEL "(FUNCTION NILL)" TYPE DISPLAY LEFT 62 BOTTOM 32 ID MOVEDFNLINK FONT (MODERN 12 STANDARD)) (LABEL LINKS TYPE STATE LEFT -1 BOTTOM 16 FONT (MODERN 12 BOLD) SELECTEDFN FMC-LINKS LINKS (DISPLAY LINKSLINK) INITSTATE "(NIL)") (LABEL "(NIL)" TYPE DISPLAY LEFT 36 BOTTOM 15 ID LINKSLINK FONT (MODERN 12 STANDARD)) (LABEL "INFINITEWIDTH" TYPE TOGGLE LEFT 239 BOTTOM 16 ID INFINITEWIDTH FONT (MODERN 12 BOLD)) (LABEL MESSAGE TYPE EDITSTART LEFT -1 BOTTOM 0 FONT (MODERN 12 BOLD) LINKS (EDIT MESSAGELINK)) (LABEL "" TYPE EDIT LEFT 61 BOTTOM -1 ID MESSAGELINK FONT (MODERN 12 STANDARD) INITSTATE "MMMMMMMMMMMMMMMMMMMMMMMM"))) (RPAQQ FMC-GP-DESC ((PROPS FORMAT EXPLICIT) (LABEL APPLY TYPE MOMENTARY LEFT 0 BOTTOM 106 BOX 1 BOXSHADE 65535 BOXSPACE 1 FONT (MODERN 14 BOLDITALIC) SELECTEDFN FMC-APPLY) (LABEL SHOW TYPE MOMENTARY LEFT 49 BOTTOM 106 BOX 1 BOXSHADE 65535 BOXSPACE 1 FONT (MODERN 14 BOLDITALIC) SELECTEDFN FMC-SHOW.GROUP) (LABEL "ID" TYPE EDITSTART LEFT 0 BOTTOM 83 FONT (MODERN 12 BOLD) LINKS (EDIT IDLINK)) (LABEL "" TYPE EDIT LEFT 17 BOTTOM 82 ID IDLINK FONT (MODERN 12 STANDARD)) (LABEL "COLLECTION" TYPE EDITSTART LEFT 0 BOTTOM 67 FONT (MODERN 12 BOLD) LINKS (EDIT COLLECTIONLINK)) (LABEL "" TYPE EDIT LEFT 75 BOTTOM 66 ID COLLECTIONLINK FONT (MODERN 12 STANDARD) ) (LABEL "DESELECT" ID DESELECT TYPE TOGGLE LEFT 0 BOTTOM 50 FONT (MODERN 12 BOLD)) (LABEL BOX TYPE STATE LEFT 0 BOTTOM 33 FONT (MODERN 12 BOLD) MENUITEMS (1 2 3 4 5 6 7 8 9 10) LINKS (DISPLAY BOXLINK) INITSTATE 1) (LABEL 1 TYPE DISPLAY LEFT 27 BOTTOM 32 ID BOXLINK FONT (MODERN 12 STANDARD)) (LABEL BOXSHADE TYPE STATE LEFT 0 BOTTOM 16 FONT (MODERN 12 BOLD) SELECTEDFN FMC-CHOOSE.ITEM.BOXSHADE LINKS (DISPLAY BOXSHADELINK)) (LABEL "" TYPE DISPLAY LEFT 86 BOTTOM 16 ID BOXSHADELINK FONT (MODERN 12 STANDARD ) MAXWIDTH 60) (LABEL BACKGROUND TYPE STATE LEFT 0 BOTTOM 0 ID BACKGROUND FONT (MODERN 12 BOLD) SELECTEDFN FMC-CHOOSE.ITEM.BG LINKS (DISPLAY BACKGROUNDLINK)) (LABEL "" TYPE DISPLAY LEFT 86 BOTTOM 0 ID BACKGROUNDLINK FONT (MODERN 12 STANDARD) MAXWIDTH 60))) (* * Creating bitmaps) (DEFINEQ (FMC-MAKEBITMAP [LAMBDA (LABEL FONT) (* ; "Edited 17-Aug-88 13:50 by A.BLAVIER") (* ;; " Create the bitmap representing LABEL in font FONT.") (PROG (Bitmap Stream) (if (BITMAPP LABEL) then (RETURN LABEL) else [SETQ Bitmap (BITMAPCREATE (STRINGWIDTH LABEL FONT) (FONTPROP FONT 'HEIGHT] (SETQ Stream (DSPCREATE Bitmap)) (DSPFONT FONT Stream) (MOVETO 0 (FONTPROP FONT 'DESCENT) Stream) (PRIN1 LABEL Stream) (RETURN Bitmap]) (FMC-COMPOUND.BITMAP [LAMBDA (COMPOUND.REGION ITEM.LIST) (* ; "Edited 17-Aug-88 13:48 by A.BLAVIER") (* ;; "Create a bitmap composed of the bitmaps from ITEM.LIST") (PROG ((CompoundBitmap (BITMAPCREATE (GET.REGION.WIDTH COMPOUND.REGION) (GET.REGION.HEIGHT COMPOUND.REGION))) Stream) (SETQ Stream (DSPCREATE CompoundBitmap)) [for item in ITEM.LIST do (BITBLT (FMC-GET.ITEM item BITMAP) 0 0 Stream (IPLUS (FMC-GET.ITEM item XBMOFFSET) (IDIFFERENCE (GET.REGION.LEFT (FMC-GET.ITEM item REGION) ) (GET.REGION.LEFT COMPOUND.REGION) )) (IPLUS (FMC-GET.ITEM item YBMOFFSET) (IDIFFERENCE (GET.REGION.BOTTOM (FMC-GET.ITEM item REGION)) (GET.REGION.BOTTOM COMPOUND.REGION] (RETURN CompoundBitmap]) (FMC-SNAPBM [LAMBDA NIL (* ; "Edited 17-Aug-88 13:51 by A.BLAVIER") (* ;; "Extract a bitmap from the SCREENBITMAP") (PROG ((Region (GETREGION)) SnapBM) (SETQ SnapBM (BITMAPCREATE (GET.REGION.WIDTH Region) (GET.REGION.HEIGHT Region))) (BITBLT (SCREENBITMAP) (GET.REGION.LEFT Region) (GET.REGION.BOTTOM Region) SnapBM) (RETURN SnapBM]) ) (* * Moving items) (DEFINEQ (FMC-MOVE.SELECTION [LAMBDA (WINDOW UNIQUE.OR.MULTIPLE) (* ; "Edited 17-Aug-88 14:38 by A.BLAVIER") (* ;; "Move the selection, either unique item or selection list.") (LET (ItemList CompoundRegion CompoundBitmap Stream NewPos CorrX CorrY Left Bottom Width Height Right Top) (FMC-MARK.AS.CHANGED WINDOW) [if (EQ UNIQUE.OR.MULTIPLE 'UNIQUE) then (WINDOWPROP WINDOW 'SELECTION.LIST (LIST (WINDOWPROP WINDOW 'SELECTED.ITEM] (SETQ ItemList (WINDOWPROP WINDOW 'SELECTION.LIST)) (FMC-DESELECT.LIST WINDOW) (* ;; "compute the enclosing region") [SETQ CompoundRegion (APPLY 'UNIONREGIONS (for item in ItemList collect (FMC-GET.ITEM item REGION] (* ;; "compute the associated bitmap") (SETQ CompoundBitmap (FMC-COMPOUND.BITMAP CompoundRegion ItemList)) (SETQ Stream (DSPCREATE CompoundBitmap)) (* ;; "surround the moving region") (SETQ Left (GET.REGION.LEFT CompoundRegion)) (SETQ Bottom (GET.REGION.BOTTOM CompoundRegion)) (SETQ Width (IDIFFERENCE (GET.REGION.WIDTH CompoundRegion) 1)) (SETQ Height (IDIFFERENCE (GET.REGION.HEIGHT CompoundRegion) 1)) (SETQ Right (fetch (REGION RIGHT) of CompoundRegion)) (SETQ Top (fetch (REGION TOP) of CompoundRegion)) (DRAWLINE Left Bottom Right Bottom 1 'REPLACE WINDOW NIL '(2 2)) (DRAWLINE Right Bottom Right Top 1 'REPLACE WINDOW NIL '(2 2)) (DRAWLINE Right Top Left Top 1 'REPLACE WINDOW NIL '(2 2)) (DRAWLINE Left Top Left Bottom 1 'REPLACE WINDOW NIL '(2 2)) (DRAWLINE 0 0 Width 0 1 'REPLACE Stream NIL '(2 2)) (DRAWLINE Width 0 Width Height 1 'REPLACE Stream NIL '(2 2)) (DRAWLINE Width Height 0 Height 1 'REPLACE Stream NIL '(2 2)) (DRAWLINE 0 Height 0 0 1 'REPLACE Stream NIL '(2 2)) (* ;; "") (* ;; "let the user move the region") (SETQ NewPos (FMC-MOVE.BITMAP CompoundBitmap (GET.REGION.LEFT CompoundRegion) (GET.REGION.BOTTOM CompoundRegion) WINDOW)) (* ;; "") (SETQ CorrX (IDIFFERENCE (fetch (POSITION XCOORD) of NewPos) (GET.REGION.LEFT CompoundRegion))) (SETQ CorrY (IDIFFERENCE (fetch (POSITION YCOORD) of NewPos) (GET.REGION.BOTTOM CompoundRegion))) (SETQ Left (fetch (POSITION XCOORD) of NewPos)) (SETQ Bottom (fetch (POSITION YCOORD) of NewPos)) (add Right CorrX) (add Top CorrY) (* ;; "remove the surrounding rectangle") (DRAWLINE Left Bottom Right Bottom 1 'ERASE WINDOW) (DRAWLINE Right Bottom Right Top 1 'ERASE WINDOW) (DRAWLINE Right Top Left Top 1 'ERASE WINDOW) (DRAWLINE Left Top Left Bottom 1 'ERASE WINDOW) (* ;; "update items' regions") (for item in ItemList do (FMC-UPDATE.REGION item CorrX CorrY WINDOW) (if (FMC-GROUP? item) then (FMC-REDRAW.ITEM item WINDOW))) (if (EQ UNIQUE.OR.MULTIPLE 'UNIQUE) then (WINDOWPROP WINDOW 'SELECTED.ITEM (CAR ItemList)) (WINDOWPROP WINDOW 'SELECTION.LIST NIL) (FMC-SELECT.ITEM WINDOW) else (WINDOWPROP WINDOW 'SELECTION.LIST ItemList) (FMC-SELECT.LIST WINDOW]) (FMC-MOVE.BITMAP [LAMBDA (BITMAP BM.X BM.Y WINDOW) (* ; "Edited 17-Aug-88 14:06 by A.BLAVIER") (PROG ((CorrX (IQUOTIENT (BITMAPWIDTH BITMAP) 2)) (CorrY (IQUOTIENT (BITMAPHEIGHT BITMAP) 2)) (Grid (WINDOWPROP WINDOW 'GRIDSIZE)) GridOldX GridOldY (GridNewX BM.X) (GridNewY BM.Y) OldX OldY (NewX BM.X) (NewY BM.Y) NewPos) (* ;; "Performs bitmap moving under the cursor, starting at (BM.X BM.Y). Returns the new position of the bitmap.") (* ;; "") (* ;; "Set the cursor position in the center of the item's region") (CURSORPOSITION (create POSITION XCOORD _ (IPLUS BM.X CorrX) YCOORD _ (IPLUS BM.Y CorrY)) WINDOW) (* ;; "Redraw the item without the selection box") (BITBLT BITMAP 0 0 WINDOW BM.X BM.Y NIL NIL 'INPUT 'REPLACE) (* ;; "") (SETCURSOR MOVINGCURSOR) (SETQ OldX (IPLUS BM.X CorrX)) (SETQ OldY (IPLUS BM.Y CorrY)) (SETQ GridOldX BM.X) (SETQ GridOldY BM.Y) (* ;; "Track the mouse") [if Grid then (* ;; "constrain movement along the grid") (while (MOUSESTATE LEFT) do (SETQ NewX (LASTMOUSEX WINDOW)) (SETQ NewY (LASTMOUSEY WINDOW)) (if (OR (NOT (EQP OldX NewX)) (NOT (EQP OldY NewY))) then (SETQ GridNewX (ITIMES (IQUOTIENT (IDIFFERENCE NewX CorrX) Grid) Grid)) (SETQ GridNewY (ITIMES (IQUOTIENT (IDIFFERENCE NewY CorrY) Grid) Grid)) (BITBLT BITMAP 0 0 WINDOW GridOldX GridOldY NIL NIL 'INPUT 'INVERT) (BITBLT BITMAP 0 0 WINDOW GridNewX GridNewY NIL NIL 'INPUT 'INVERT) (SETQ GridOldX GridNewX) (SETQ GridOldY GridNewY) (SETQ OldX NewX) (SETQ OldY NewY))) (SETQ NewPos (create POSITION XCOORD _ GridNewX YCOORD _ GridNewY)) else (* ;; "move freely") (while (MOUSESTATE LEFT) do (SETQ NewX (LASTMOUSEX WINDOW)) (SETQ NewY (LASTMOUSEY WINDOW)) (if (OR (NOT (EQP OldX NewX)) (NOT (EQP OldY NewY))) then (BITBLT BITMAP 0 0 WINDOW (IDIFFERENCE OldX CorrX) (IDIFFERENCE OldY CorrY) NIL NIL 'INPUT 'INVERT) (BITBLT BITMAP 0 0 WINDOW (IDIFFERENCE NewX CorrX) (IDIFFERENCE NewY CorrY) NIL NIL 'INPUT 'INVERT)) (SETQ OldX NewX) (SETQ OldY NewY)) (SETQ NewPos (create POSITION XCOORD _ (IDIFFERENCE NewX CorrX) YCOORD _ (IDIFFERENCE NewY CorrY] (SETCURSOR DEFAULTCURSOR) (RETURN NewPos]) (FMC-TRACK.NEW.ITEM [LAMBDA (ITEM WINDOW) (* ; "Edited 17-Aug-88 14:45 by A.BLAVIER") (* ;; "Move a newly created item") (LET ((ItemBitmap (FMC-GET.ITEM ITEM BITMAP)) (ItemRegion (FMC-GET.ITEM ITEM REGION)) (OldX (LASTMOUSEX WINDOW)) (OldY (LASTMOUSEY WINDOW)) NewX NewY) (BITBLT ItemBitmap 0 0 WINDOW (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (until (MOUSESTATE LEFT) do (SETQ NewX (LASTMOUSEX WINDOW)) (SETQ NewY (LASTMOUSEY WINDOW)) (if (OR (NOT (EQP OldX NewX)) (NOT (EQP OldY NewY))) then (BITBLT ItemBitmap 0 0 WINDOW OldX OldY NIL NIL 'INPUT 'INVERT) (BITBLT ItemBitmap 0 0 WINDOW NewX NewY NIL NIL 'INPUT 'INVERT)) (SETQ OldX NewX) (SETQ OldY NewY)) (PUT.REGION.LEFT ItemRegion NewX) (PUT.REGION.BOTTOM ItemRegion NewY]) (FMC-UPDATE.BM.POSITION [LAMBDA (ITEM WINDOW) (* ; "Edited 9-Aug-88 17:17 by A.BLAVIER") (* ;; "Update X and Y offset of an item's bitmap within it's box region.") (LET ((Bitmap (FMC-GET.ITEM ITEM BITMAP)) (Region (FMC-GET.ITEM ITEM REGION)) X) (if (FMC-GET.ITEM ITEM BOX) then (SETQ X (IDIFFERENCE (IQUOTIENT (GET.REGION.WIDTH Region) 2) (IQUOTIENT (BITMAPWIDTH Bitmap) 2))) (FMC-PUT.ITEM ITEM XBMOFFSET X) (FMC-PUT.ITEM ITEM YBMOFFSET X]) (FMC-UPDATE.REGION [LAMBDA (OBJECT DELTAX DELTAY WINDOW) (* ; "Edited 17-Aug-88 14:50 by A.BLAVIER") (* ;; "This function is called by FMC-MOVE.SELECTION and by itself to update all items'regions moved by the user.") (LET ((Reg (FMC-GET.ITEM OBJECT REGION)) (Box (FMC-GET.ITEM OBJECT BOX)) (ObjectList (FMC-GET.ITEM OBJECT OBJECTLIST))) (PUT.REGION.LEFT Reg (IPLUS (GET.REGION.LEFT Reg) DELTAX)) (PUT.REGION.BOTTOM Reg (IPLUS (GET.REGION.BOTTOM Reg) DELTAY)) (DSPFILL Reg (FMC-GET.ITEM OBJECT BACKGROUND) 'PAINT WINDOW) (if Box then (FMC-DRAW.BOX OBJECT Box (FMC-GET.ITEM OBJECT BOXSHADE) WINDOW)) (if (FMC-GROUP? OBJECT) then (for obj in ObjectList do (FMC-UPDATE.REGION obj DELTAX DELTAY WINDOW]) ) (* * Shaping items) (DEFINEQ (FMC-COMPUTE.SHAPE.REGS [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:11 by A.BLAVIER") (* ;; "Compute the shaping regions of the selected item.") (LET ((Item (WINDOWPROP WINDOW 'SELECTED.ITEM)) Region Rleft Rbottom Rwidth Rheight HalfHeight HalfWidth Reg1 Reg2 Reg3 Reg4) (SETQ Region (FMC-GET.ITEM Item REGION)) (SETQ Rleft (GET.REGION.LEFT Region)) (SETQ Rbottom (GET.REGION.BOTTOM Region)) (SETQ Rwidth (GET.REGION.WIDTH Region)) (SETQ Rheight (GET.REGION.HEIGHT Region)) (SETQ HalfHeight (IQUOTIENT Rheight 2)) (SETQ HalfWidth (IQUOTIENT Rwidth 2)) (* ;; "") (if (FMC-GET.ITEM Item BOX) then (SETQ Reg1 (LIST (CREATEREGION Rleft (IPLUS Rbottom HalfHeight) HalfWidth HalfHeight) (FUNCTION FMC-SHAPE) 'TOPLEFT UpperLeftCursor)) (SETQ Reg2 (LIST (CREATEREGION (IPLUS Rleft HalfWidth) (IPLUS Rbottom HalfHeight) HalfWidth HalfHeight) (FUNCTION FMC-SHAPE) 'TOPRIGHT UpperRightCursor)) (SETQ Reg3 (LIST (CREATEREGION (IPLUS Rleft HalfWidth) Rbottom HalfWidth HalfHeight) (FUNCTION FMC-SHAPE) 'BOTTOMRIGHT LowerRightCursor)) (SETQ Reg4 (LIST (CREATEREGION Rleft Rbottom HalfWidth HalfHeight) (FUNCTION FMC-SHAPE) 'BOTTOMLEFT LowerLeftCursor)) (WINDOWPROP WINDOW 'SHAPE.REGS (LIST Reg1 Reg2 Reg3 Reg4)) else (SETQ Reg1 (LIST (CREATEREGION Rleft Rbottom Rwidth Rheight) (FUNCTION FMC-SHAPE) NIL LowerRightCursor)) (WINDOWPROP WINDOW 'SHAPE.REGS (LIST Reg1]) (FMC-SHAPE [LAMBDA (WHERE WINDOW) (* ; "Edited 17-Aug-88 16:40 by A.BLAVIER") (* ;; "Reshape an item (simple item or group, boxed or not).") (LET ((Item (WINDOWPROP WINDOW 'SELECTED.ITEM)) Box Region RLeft RBottom RRight RTop WLeft WBottom SC.Region SC.RLeft SC.RBottom SC.RRight SC.RTop NewRegion MinWidth MinHeight CorrX CorrY) (FMC-MARK.AS.CHANGED WINDOW) (SETQ Box (FMC-GET.ITEM Item BOX)) (SETQ Region (FMC-GET.ITEM Item REGION)) (SETQ RLeft (GET.REGION.LEFT Region)) (SETQ RBottom (GET.REGION.BOTTOM Region)) (SETQ RRight (fetch (REGION PRIGHT) of Region)) (SETQ RTop (fetch (REGION PTOP) of Region)) (SETQ WLeft (IPLUS (GET.REGION.LEFT (WINDOWPROP WINDOW 'REGION)) 3)) (SETQ WBottom (IPLUS (GET.REGION.BOTTOM (WINDOWPROP WINDOW 'REGION)) 3)) (* ;; "SC stands for Screen Coordinates") (SETQ SC.RLeft (IPLUS WLeft RLeft)) (SETQ SC.RBottom (IPLUS WBottom RBottom)) (SETQ SC.RRight (IPLUS WLeft RRight)) (SETQ SC.RTop (IPLUS WBottom RTop)) (SETQ SC.Region (CREATEREGION SC.RLeft SC.RBottom (GET.REGION.WIDTH Region) (GET.REGION.HEIGHT Region))) (* ;; "compute the minimum size the item should be") (SETQ MinWidth (IPLUS (BITMAPWIDTH (FMC-GET.ITEM Item BITMAP)) (if Box then (IPLUS Box 3) else 0))) (SETQ MinHeight (IPLUS (BITMAPHEIGHT (FMC-GET.ITEM Item BITMAP)) (if Box then (IPLUS Box 3) else 0))) (FMC-DESELECT.ITEM WINDOW) (* ;; "shape the item") (SETQ NewRegion (if (NOT Box) then (GETREGION MinWidth MinHeight SC.Region (FUNCTION FMC-NOBOX.NEWREGIONFN) SC.RBottom (LIST SC.RLeft SC.RTop SC.RRight SC.RBottom)) else (SELECTQ WHERE (TOPLEFT (GETREGION MinWidth MinHeight SC.Region (FUNCTION FMC-BOX.NEWREGIONFN) (LIST SC.RLeft SC.RTop WHERE) (LIST SC.RRight SC.RBottom SC.RLeft SC.RTop))) (TOPRIGHT (GETREGION MinWidth MinHeight SC.Region (FUNCTION FMC-BOX.NEWREGIONFN) (LIST SC.RRight SC.RTop WHERE) (LIST SC.RLeft SC.RBottom SC.RRight SC.RTop))) (BOTTOMRIGHT (GETREGION MinWidth MinHeight SC.Region (FUNCTION FMC-BOX.NEWREGIONFN) (LIST SC.RRight SC.RBottom WHERE) (LIST SC.RLeft SC.RTop SC.RRight SC.RBottom))) (BOTTOMLEFT (GETREGION MinWidth MinHeight SC.Region (FUNCTION FMC-BOX.NEWREGIONFN) (LIST SC.RLeft SC.RBottom WHERE) (LIST SC.RRight SC.RTop SC.RLeft SC.RBottom))) NIL))) (FMC-CLEAR.REGION Region WINDOW) (* ;; "update it's region and bitmap position") (FMC-PUT.ITEM Item REGION (CREATEREGION (IDIFFERENCE (GET.REGION.LEFT NewRegion) WLeft) (IDIFFERENCE (GET.REGION.BOTTOM NewRegion) WBottom) (GET.REGION.WIDTH NewRegion) (GET.REGION.HEIGHT NewRegion))) (FMC-UPDATE.BM.POSITION Item WINDOW) (* ;; "if item is a group we'll have to move its items according to the new shape") (if (FMC-GROUP? Item) then (* ;; "CorrX and CorrY are correction factors needed to move the items appropriately") (SELECTQ WHERE (TOPLEFT (SETQ CorrX (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (GET.REGION.LEFT NewRegion) WLeft) RLeft) 2)) (SETQ CorrY (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (fetch (REGION PTOP) of NewRegion) WBottom) RTop) 2))) (TOPRIGHT (SETQ CorrX (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (fetch (REGION PRIGHT) of NewRegion) WLeft) RRight) 2)) (SETQ CorrY (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (fetch (REGION PTOP) of NewRegion) WBottom) RTop) 2))) (BOTTOMRIGHT (SETQ CorrX (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (fetch (REGION PRIGHT) of NewRegion) WLeft) RRight) 2)) (SETQ CorrY (IQUOTIENT (IDIFFERENCE (IDIFFERENCE ( GET.REGION.BOTTOM NewRegion) WBottom) RBottom) 2))) (BOTTOMLEFT (SETQ CorrX (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (GET.REGION.LEFT NewRegion) WLeft) RLeft) 2)) (SETQ CorrY (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (GET.REGION.BOTTOM NewRegion) WBottom) RBottom) 2))) T) (for object in (FMC-GET.ITEM Item OBJECTLIST) do (FMC-UPDATE.REGION object CorrX CorrY WINDOW))) (* ;; "") (FMC-REDRAW.ITEM Item WINDOW) (WINDOWPROP WINDOW 'SELECTED.ITEM Item) (FMC-SELECT.ITEM WINDOW]) (FMC-BOX.NEWREGIONFN [LAMBDA (FIXEDPOINT MOVINGPOINT X.Y.WHERE) (* ; "Edited 17-Aug-88 16:44 by A.BLAVIER") (* ;; "Constrain box shaping so that BOXSPACE is the same horizontally and vertically.") (* ;; "This is applied to simple boxed items or to groups") (PROG ((AnchorX (CAR X.Y.WHERE)) (AnchorY (CADR X.Y.WHERE)) (WHERE (CADDR X.Y.WHERE)) (MovingX (fetch (POSITION XCOORD) of MOVINGPOINT)) (MovingY (fetch (POSITION YCOORD) of MOVINGPOINT)) DeltaX DeltaY) (if (NULL MOVINGPOINT) then (RETURN FIXEDPOINT) else (SELECTQ WHERE ((BOTTOMLEFT TOPRIGHT) (SETQ DeltaX (IDIFFERENCE MovingX AnchorX)) (SETQ DeltaY (IDIFFERENCE MovingY AnchorY)) [RETURN (CONS (IPLUS AnchorX (IMIN DeltaX DeltaY)) (IPLUS AnchorY (IMIN DeltaX DeltaY]) ((TOPLEFT BOTTOMRIGHT) (SETQ DeltaX (IDIFFERENCE MovingX AnchorX)) (SETQ DeltaY (IDIFFERENCE AnchorY MovingY)) [RETURN (CONS (IPLUS AnchorX (IMIN DeltaX DeltaY)) (IDIFFERENCE AnchorY (IMIN DeltaX DeltaY]) NIL]) (FMC-NOBOX.NEWREGIONFN [LAMBDA (FIXEDPOINT MOVINGPOINT Y) (* ; "Edited 9-Aug-88 17:15 by A.BLAVIER") (* ;; "Constrain item shaping so that only its width can get changed.") (* ;; "This is applied only to non-boxed items.") (if (NULL MOVINGPOINT) then FIXEDPOINT else (CONS (CAR MOVINGPOINT) Y]) ) (* * Redrawing items) (DEFINEQ (FMC-REDRAW [LAMBDA (WINDOW REGION) (* ; "Edited 22-Jul-88 17:41 by A.BLAVIER") (* ;; "Redraw the entire FMC window") (DSPFILL NIL (WINDOWPROP WINDOW 'FMC.BACKGROUND) 'REPLACE WINDOW) (for ITEM in (WINDOWPROP WINDOW 'ITEMLIST) do (FMC-REDRAW.ITEM ITEM WINDOW)) (if (WINDOWPROP WINDOW 'SELECTED.ITEM) then (FMC-SELECT.ITEM WINDOW)) (if (WINDOWPROP WINDOW 'SELECTION.LIST) then (FMC-SELECT.LIST WINDOW)) (if (WINDOWPROP WINDOW 'DISPLAYGRID) then (FMC-DISPLAY.GRID WINDOW]) (FMC-REDRAW.ITEM [LAMBDA (ITEM WINDOW) (* ; "Edited 17-Aug-88 16:46 by A.BLAVIER") (* ;; "Redraw one item (simple item or group).") (LET ((Bitmap (FMC-GET.ITEM ITEM BITMAP)) (Region (FMC-GET.ITEM ITEM REGION)) (ObjectList (FMC-GET.ITEM ITEM OBJECTLIST)) (Background (FMC-GET.ITEM ITEM BACKGROUND)) (Box (FMC-GET.ITEM ITEM BOX)) (BoxShade (FMC-GET.ITEM ITEM BOXSHADE)) RLeft RBottom) (DSPFILL Region Background 'REPLACE WINDOW) (if Box then (FMC-DRAW.BOX ITEM Box BoxShade WINDOW)) (* ;; "if ITEM is a group recursively call this function for each of its subitems") (if (FMC-GROUP? ITEM) then (for OBJECT in ObjectList do (FMC-REDRAW.ITEM OBJECT WINDOW)) else (SETQ RLeft (GET.REGION.LEFT Region)) (SETQ RBottom (GET.REGION.BOTTOM Region)) (BITBLT Bitmap 0 0 WINDOW (IPLUS RLeft (FMC-GET.ITEM ITEM XBMOFFSET)) (IPLUS RBottom (FMC-GET.ITEM ITEM YBMOFFSET)) NIL NIL 'INPUT 'PAINT]) ) (* * Deleting and undeleting items) (DEFINEQ (FMC-DELETE [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:47 by A.BLAVIER") (* ;; "Delete selected item(s). Save them in a list so they can get undeleted.") (LET ((Unique? (WINDOWPROP WINDOW 'SELECTED.ITEM)) ItemList) [if Unique? then (WINDOWPROP WINDOW 'SELECTION.LIST (LIST (WINDOWPROP WINDOW 'SELECTED.ITEM] (SETQ ItemList (WINDOWPROP WINDOW 'SELECTION.LIST)) (if ItemList then (FMC-DESELECT.LIST WINDOW) (for ITEM in ItemList do (DSPFILL (FMC-GET.ITEM ITEM REGION) WHITESHADE 'REPLACE WINDOW) (WINDOWDELPROP WINDOW 'ITEMLIST ITEM) (WINDOWADDPROP WINDOW 'DELETED.ITEMS ITEM T)) (FMC-PROMPTPRINT (CONCAT (LENGTH ItemList) " item(s) deleted") WINDOW) (WINDOWPROP WINDOW 'SELECTED.ITEM NIL) (WINDOWPROP WINDOW 'SELECTION.LIST NIL) (FMC-MARK.AS.CHANGED WINDOW) else (FMC-PROMPTPRINT "Nothing to Delete" WINDOW]) (FMC-UNDELETE [LAMBDA (WHAT WINDOW) (* ; "Edited 28-Jul-88 17:56 by A.BLAVIER") (* ;; "Undelete deleted items : the saved list works as a LIFO structure.") (LET ((DeletedItems (WINDOWPROP WINDOW 'DELETED.ITEMS)) UndeletedItems) (if DeletedItems then (SELECTQ WHAT (LAST (SETQ UndeletedItems (LIST (CAR DeletedItems)))) (ALL (SETQ UndeletedItems DeletedItems)) (LIST [SETQ UndeletedItems (LIST (MENU (create MENU ITEMS _ (for ITEM in DeletedItems collect (LIST (CONCAT (FMC-GET.ITEM ITEM TYPE) " - " (FMC-GET.ITEM ITEM LABEL)) (KWOTE ITEM]) NIL) (if (CAR UndeletedItems) then (for ITEM in UndeletedItems do (FMC-REDRAW.ITEM ITEM WINDOW) (WINDOWDELPROP WINDOW 'DELETED.ITEMS ITEM) (WINDOWADDPROP WINDOW 'ITEMLIST ITEM)) (FMC-PROMPTPRINT (CONCAT (LENGTH UndeletedItems) " items(s) undeleted") WINDOW) (FMC-MARK.AS.CHANGED WINDOW) else (FMC-PROMPTPRINT "Nothing Undeleted" WINDOW)) else (FMC-PROMPTPRINT "Nothing to Undelete" WINDOW]) ) (* * GROUPing and UNGROUPing) (DEFINEQ (FMC-GROUP [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:50 by A.BLAVIER") (* ;; "Group a multiple selection.") (LET ((ObjectList (WINDOWPROP WINDOW 'SELECTION.LIST)) Group GroupRegion GroupBitmap) (if (IGREATERP (LENGTH ObjectList) 1) then (FMC-MARK.AS.CHANGED WINDOW) (FMC-DESELECT WINDOW) (* ;; "remove items from the ITEMLIST") (for object in ObjectList do (WINDOWDELPROP WINDOW 'ITEMLIST object)) (* ;;  "a group is an FMC-ITEM whose TYPE is GROUP and whose OBJECTLIST is a list of items (or groups)") (SETQ Group (create FMC-ITEM)) (FMC-PUT.ITEM Group TYPE 'GROUP) (FMC-PUT.ITEM Group OBJECTLIST ObjectList) (* ;; "the group's region is the union region of its items") [SETQ GroupRegion (APPLY 'UNIONREGIONS (for OBJECT in ObjectList collect (FMC-GET.ITEM OBJECT REGION] (FMC-PUT.ITEM Group REGION (CREATEREGION (IDIFFERENCE (GET.REGION.LEFT GroupRegion) 2) (IDIFFERENCE (GET.REGION.BOTTOM GroupRegion) 2) (IPLUS (GET.REGION.WIDTH GroupRegion) 4) (IPLUS (GET.REGION.HEIGHT GroupRegion) 4))) (* ;; "the group's bitmap is the compound of its items' bitmaps") (SETQ GroupBitmap (FMC-COMPOUND.BITMAP GroupRegion ObjectList)) (FMC-PUT.ITEM Group BITMAP GroupBitmap) (FMC-PUT.ITEM Group LABEL GroupBitmap) (* ;; "default boxing is black 1 pixel thick") (FMC-PUT.ITEM Group BOX 1) (FMC-PUT.ITEM Group BOXSHADE 65535) (FMC-PUT.ITEM Group XBMOFFSET 2) (FMC-PUT.ITEM Group YBMOFFSET 2) (* ;; "") (FMC-REDRAW.ITEM Group WINDOW) (WINDOWADDPROP WINDOW 'ITEMLIST Group) (WINDOWPROP WINDOW 'SELECTED.ITEM Group) (FMC-SELECT.ITEM WINDOW]) (FMC-UNGROUP [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:50 by A.BLAVIER") (* ;; "Unpack a group.") (* ;; "For safety, this function works only on a unique selection") (LET ((Group (WINDOWPROP WINDOW 'SELECTED.ITEM)) ObjectList) (SETQ ObjectList (FMC-GET.ITEM Group OBJECTLIST)) (if (AND Group (FMC-GROUP? Group)) then (FMC-MARK.AS.CHANGED WINDOW) (WINDOWDELPROP WINDOW 'ITEMLIST Group) (FMC-DESELECT.ITEM WINDOW) (FMC-CLEAR.REGION (FMC-GET.ITEM Group REGION) WINDOW) (for OBJECT in ObjectList do (WINDOWADDPROP WINDOW 'ITEMLIST OBJECT) (WINDOWADDPROP WINDOW 'SELECTION.LIST OBJECT) (FMC-REDRAW.ITEM OBJECT WINDOW)) (FMC-SELECT.LIST WINDOW]) ) (* * Align and Center functions) (DEFINEQ (FMC-ALIGN [LAMBDA (ALIGN.TYPE WINDOW) (* ; "Edited 17-Aug-88 16:51 by A.BLAVIER") (* ;; "Align items of a multiple selection.") (* ;; "Reference is the first selected item, that is : the first item won't get moved.") (LET ((ItemList (WINDOWPROP WINDOW 'SELECTION.LIST)) RefEdge RegionOfRefItem) (FMC-MARK.AS.CHANGED WINDOW) (if (IGREATERP (LENGTH ItemList) 1) then (FMC-DESELECT.LIST WINDOW) (SETQ RegionOfRefItem (FMC-GET.ITEM (CAR ItemList) REGION)) (SETQ RefEdge (SELECTQ ALIGN.TYPE (ALIGNLEFT (GET.REGION.LEFT RegionOfRefItem)) (ALIGNBOTTOM (GET.REGION.BOTTOM RegionOfRefItem)) (ALIGNTOP (IPLUS (GET.REGION.BOTTOM RegionOfRefItem) (GET.REGION.HEIGHT RegionOfRefItem))) (ALIGNRIGHT (IPLUS (GET.REGION.LEFT RegionOfRefItem) (GET.REGION.WIDTH RegionOfRefItem))) T)) (for item in (CDR ItemList) bind region deltaX deltaY do (SETQ region (FMC-GET.ITEM item REGION)) (SETQ deltaX 0) (SETQ deltaY 0) (FMC-CLEAR.REGION region WINDOW) (SELECTQ ALIGN.TYPE (ALIGNLEFT (SETQ deltaX (IDIFFERENCE RefEdge (GET.REGION.LEFT region))) (PUT.REGION.LEFT region RefEdge)) (ALIGNBOTTOM (SETQ deltaY (IDIFFERENCE RefEdge (GET.REGION.BOTTOM region) )) (PUT.REGION.BOTTOM region RefEdge)) (ALIGNTOP (SETQ deltaY (IDIFFERENCE RefEdge (fetch (REGION PTOP) of region))) (PUT.REGION.BOTTOM region (IDIFFERENCE RefEdge ( GET.REGION.HEIGHT region)))) (ALIGNRIGHT (SETQ deltaX (IDIFFERENCE RefEdge (fetch (REGION PRIGHT) of region))) (PUT.REGION.LEFT region (IDIFFERENCE RefEdge ( GET.REGION.WIDTH region)))) T) (if (FMC-GROUP? item) then (* ;; "if item is a group its subitems have to moved proportionnally") (FMC-REL.MOVE item deltaX deltaY)) (FMC-REDRAW.ITEM item WINDOW)) (WINDOWPROP WINDOW 'SELECTION.LIST ItemList) (FMC-SELECT.LIST WINDOW]) (FMC-HCENTER [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:52 by A.BLAVIER") (* ;; "Center items of a multiple selection horizontally.") (* ;; " Reference is the first selected item.") (LET ((ItemList (WINDOWPROP WINDOW 'SELECTION.LIST)) HPos RegionOfRefItem) (FMC-MARK.AS.CHANGED WINDOW) (if (IGREATERP (LENGTH ItemList) 1) then (FMC-DESELECT.LIST WINDOW) (SETQ RegionOfRefItem (FMC-GET.ITEM (CAR ItemList) REGION)) (SETQ HPos (IPLUS (GET.REGION.LEFT RegionOfRefItem) (IQUOTIENT (GET.REGION.WIDTH RegionOfRefItem) 2))) (for item in (CDR ItemList) bind region deltaX do (SETQ region (FMC-GET.ITEM item REGION)) (FMC-CLEAR.REGION region WINDOW) (SETQ deltaX (GET.REGION.LEFT region)) (PUT.REGION.LEFT region (IDIFFERENCE (GET.REGION.LEFT region) (IDIFFERENCE (IPLUS (GET.REGION.LEFT region) (IQUOTIENT ( GET.REGION.WIDTH region) 2)) HPos))) (SETQ deltaX (IDIFFERENCE (GET.REGION.LEFT region) deltaX)) (if (FMC-GROUP? item) then (* ;; "if item is a group its subitems have to be moved proportionnally") (FMC-REL.MOVE item deltaX 0)) (FMC-REDRAW.ITEM item WINDOW)) (WINDOWPROP WINDOW 'SELECTION.LIST ItemList) (FMC-SELECT.LIST WINDOW]) (FMC-VCENTER [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:53 by A.BLAVIER") (* ;; "Center items vertically.") (* ;; "Reference is the first selected item.") (LET ((ItemList (WINDOWPROP WINDOW 'SELECTION.LIST)) VPos RegionOfRefItem) (FMC-MARK.AS.CHANGED WINDOW) (if (IGREATERP (LENGTH ItemList) 1) then (FMC-DESELECT.LIST WINDOW) (SETQ RegionOfRefItem (FMC-GET.ITEM (CAR ItemList) REGION)) (SETQ VPos (IPLUS (GET.REGION.BOTTOM RegionOfRefItem) (IQUOTIENT (GET.REGION.HEIGHT RegionOfRefItem) 2))) (for item in (CDR ItemList) bind region deltaY do (SETQ region (FMC-GET.ITEM item REGION)) (FMC-CLEAR.REGION region WINDOW) (SETQ deltaY (GET.REGION.BOTTOM region)) (PUT.REGION.BOTTOM region (IDIFFERENCE (GET.REGION.BOTTOM region) (IDIFFERENCE (IPLUS (GET.REGION.BOTTOM region) (IQUOTIENT ( GET.REGION.HEIGHT region) 2)) VPos))) (SETQ deltaY (IDIFFERENCE (GET.REGION.BOTTOM region) deltaY)) (if (FMC-GROUP? item) then (* ;; "if item is a group its subitems have to be moved proportionnally") (FMC-REL.MOVE item 0 deltaY)) (FMC-REDRAW.ITEM item WINDOW)) (WINDOWPROP WINDOW 'SELECTION.LIST ItemList) (FMC-SELECT.LIST WINDOW]) (FMC-REL.MOVE [LAMBDA (GROUP DELTAX DELTAY) (* ; "Edited 3-Aug-88 16:27 by A.BLAVIER") (* ;;  "Move the items of a group when the group itself has been moved by a Center or Align operation.") (LET ((ObjectList (FMC-GET.ITEM GROUP OBJECTLIST))) (for item in ObjectList bind Region do (SETQ Region (FMC-GET.ITEM item REGION)) (PUT.REGION.LEFT Region (IPLUS (GET.REGION.LEFT Region) DELTAX)) (PUT.REGION.BOTTOM Region (IPLUS (GET.REGION.BOTTOM Region) DELTAY)) (if (FMC-GROUP? item) then (FMC-REL.MOVE item DELTAX DELTAY]) ) (* * File saving and loading) (DEFINEQ (FMC-GET [LAMBDA (WINDOW) (* ; "Edited 18-Aug-88 11:48 by A.BLAVIER") (* ;; "Read item(s) from a FMC file and add them to the window.") (LET ((PromptWindow (WINDOWPROP WINDOW 'FMC.PROMPTWINDOW)) FileName Stream Expr Item) (FMC-PROMPTPRINT "" WINDOW) (* ;; "input the file name") [SETQ FileName (PROMPTFORWORD "File to GET :" FileName NIL PromptWindow NIL NIL (CHARCODE (EOL ESCAPE LF TAB] (if FileName then (* ;; "check that FileName exists") (if (FINDFILE FileName) then (RESETLST (SETQ Stream (OPENSTREAM FileName 'INPUT)) (RESETSAVE (CURSOR WAITINGCURSOR)) (RESETSAVE NIL (LIST 'CLOSEF Stream)) (* ;; "check that the file is actually a FMC file") (if (NEQ (READ Stream) 'FreeMenuCreator-ItemList) then (FMC-PROMPTPRINT "Not a Free Menu Creator file" WINDOW) else (FMC-DESELECT WINDOW) (FMC-PROMPTPRINT (CONCAT "GETting file " (FULLNAME Stream) "...") WINDOW) (* ;; "read the items in") (until (EQ (SETQ Item (FMC-GET.ONE.OBJECT Stream)) 'STOP) do (WINDOWADDPROP WINDOW 'ITEMLIST Item) (WINDOWADDPROP WINDOW 'SELECTION.LIST Item)) (FMC-REDRAW WINDOW) (FMC-PROMPTPRINT (CONCAT "GETting file " (FULLNAME Stream) "...done") WINDOW))) (* ;; "if the window was not (file)named yet, change it's title") (if (NOT (WINDOWPROP WINDOW 'FILENAME)) then (WINDOWPROP WINDOW 'FILENAME FileName) (WINDOWPROP WINDOW 'TITLE FileName)) (FMC-MARK.AS.CHANGED WINDOW) else (FMC-PROMPTPRINT (CONCAT "Couldn't find file " FileName) WINDOW)) else (FMC-PROMPTPRINT "GET aborted" WINDOW]) (FMC-GET.ONE.OBJECT [LAMBDA (STREAM) (* ; "Edited 12-Aug-88 11:33 by A.BLAVIER") (* ;; "Read in one item from STREAM") (PROG (Expr Item Bitmap CompoundRegion ObjectListSize) (SETQ Expr (READ STREAM)) (SETQ ObjectListSize (CAR (NTH Expr 13))) (if (NEQ Expr 'STOP) then (SETQ Item (FMC-CREATE.ITEM.FROM.LIST Expr)) (FMC-PUT.ITEM Item OBJECTLIST NIL) [COND ((NEQ (CAR Expr) 'GROUP) (* ;;  "if it's not a group read its bitmap if any. If none compute it from its label and font") [if (EQ (CADR Expr) '**BITMAP**) then (SETQ Bitmap (HREAD STREAM)) (FMC-PUT.ITEM Item LABEL Bitmap) else (SETQ Bitmap (FMC-MAKEBITMAP (CADR Expr) (CADDR Expr] (FMC-PUT.ITEM Item BITMAP Bitmap)) (T (* ;; "it's a group : read its items and build the OBJECTLIST") (FMC-PUT.ITEM Item OBJECTLIST (for i from 1 to ObjectListSize collect (FMC-GET.ONE.OBJECT STREAM))) (* ;; "compute its bitmap") [SETQ CompoundRegion (APPLY 'UNIONREGIONS (for i in (FMC-GET.ITEM Item OBJECTLIST) collect (FMC-GET.ITEM i REGION] (FMC-PUT.ITEM Item BITMAP (FMC-COMPOUND.BITMAP CompoundRegion (FMC-GET.ITEM Item OBJECTLIST))) (FMC-PUT.ITEM Item LABEL (FMC-GET.ITEM Item BITMAP] (RETURN Item) else (RETURN 'STOP]) (FMC-PUT [LAMBDA (WINDOW) (* ; "Edited 12-Aug-88 13:35 by A.BLAVIER") (* ;; "Save the contents of WINDOW onto a file.") (LET ((PromptWindow (WINDOWPROP WINDOW 'FMC.PROMPTWINDOW)) (ItemList (WINDOWPROP WINDOW 'ITEMLIST)) (FileName (WINDOWPROP WINDOW 'FILENAME)) Stream) (if ItemList then (FMC-PROMPTPRINT "" WINDOW) (* ;; "input the file name") [SETQ FileName (PROMPTFORWORD "File to PUT to :" FileName NIL PromptWindow NIL NIL (CHARCODE (EOL ESCAPE LF TAB] (if FileName then (RESETLST (SETQ Stream (OPENSTREAM FileName 'OUTPUT)) (RESETSAVE (CURSOR WAITINGCURSOR)) (RESETSAVE NIL (LIST 'CLOSEF Stream)) (FMC-PROMPTPRINT (CONCAT "PUTting file " (FULLNAME Stream) "...") WINDOW) (* ;; "write the FMC header") (PRINTOUT Stream 'FreeMenuCreator-ItemList T) (* ;; "write the items") (for item in ItemList do (FMC-PUT.OBJECT item Stream)) (PRINTOUT Stream 'STOP) (FMC-PROMPTPRINT (CONCAT "PUTting file " (FULLNAME Stream) "...done") WINDOW)) (* ;; "change the window title") (WINDOWPROP WINDOW 'FILENAME FileName) (WINDOWPROP WINDOW 'TITLE FileName) (WINDOWPROP WINDOW 'FMC.CHANGED NIL) else (FMC-PROMPTPRINT "PUT aborted" WINDOW]) (FMC-PUT.OBJECT [LAMBDA (ITEM STREAM) (* ; "Edited 12-Aug-88 10:33 by A.BLAVIER") (* ;; "write one item on STREAM") (LET ((ObjectList (FMC-GET.ITEM ITEM OBJECTLIST)) (Label (FMC-GET.ITEM ITEM LABEL)) (Message (FMC-GET.ITEM ITEM MESSAGE))) (PRINTOUT STREAM (LIST (FMC-GET.ITEM ITEM TYPE) (if (BITMAPP Label) then "**BITMAP**" else (CONCAT '%" Label '%")) (FMC-GET.ITEM ITEM FONT) (FMC-GET.ITEM ITEM ID) (FMC-GET.ITEM ITEM COLLECTION) (FMC-GET.ITEM ITEM DESELECT) (if Message then (CONCAT '%" Message '%") else (CONCAT '%" '%")) (FMC-GET.ITEM ITEM INITSTATE) (FMC-GET.ITEM ITEM BOX) (FMC-GET.ITEM ITEM BOXSHADE) (FMC-GET.ITEM ITEM BACKGROUND) (FMC-GET.ITEM ITEM LINKS) (LENGTH ObjectList) (FMC-GET.ITEM ITEM MENU) (FMC-GET.ITEM ITEM CHANGESTATE) (FMC-GET.ITEM ITEM SELECTEDFN) (FMC-GET.ITEM ITEM DOWNFN) (FMC-GET.ITEM ITEM HELDFN) (FMC-GET.ITEM ITEM MOVEDFN) (FMC-GET.ITEM ITEM REGION) NIL (FMC-GET.ITEM ITEM XBMOFFSET) (FMC-GET.ITEM ITEM YBMOFFSET) (FMC-GET.ITEM ITEM INFINITEWIDTH) (FMC-GET.ITEM ITEM USERDATA)) T) (if (AND (BITMAPP Label) (NOT (FMC-GROUP? ITEM))) then (HPRINT Label STREAM T T)) (if (FMC-GROUP? ITEM) then (* ;; "ITEM is a group : write its subitems") (for object in ObjectList do (FMC-PUT.OBJECT object STREAM]) ) (* * Creating a summary) (DEFINEQ (FMC-EDIT.INFO [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 16:57 by A.BLAVIER") (* ;; "Create a %"dead%" TEdit window, listing a summary of the items.") (LET ((ItemList (WINDOWPROP WINDOW 'ITEMLIST)) Stream TEdWindow) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ Stream (OPENTEXTSTREAM "")) (RESETSAVE NIL (LIST 'CLOSEF Stream)) (FMC-PROMPTPRINT "Creating summary ..." WINDOW) (SETCURSOR WAITINGCURSOR) (FMC-SORT.ITEM.LIST ItemList) (* ;; "") (PRINTOUT Stream .FONT '(MODERN 14 BOLD) "- Free Menu Creator Summary -" T T) (PRINTOUT Stream .FONT '(MODERN 10 REGULAR) (DATE) T T) (for item in ItemList do (FMC-EDIT.INFO.ITEM item Stream 0)) (TEDIT.PARALOOKS Stream '(QUAD CENTERED) 1 2) (SETCURSOR DEFAULTCURSOR) (FMC-PROMPTPRINT "Creating summary ... done" WINDOW) (SETQ TEdWindow (CREATEW NIL "FMC Items Summary")) (OPENTEXTSTREAM Stream TEdWindow]) (FMC-EDIT.INFO.ITEM [LAMBDA (ITEM STREAM SPACES) (* ; "Edited 8-Aug-88 17:00 by A.BLAVIER") (* ;; "This function is called by FMC-EDIT.INFO (and by itself). Writes on STREAM interesting item properties.") (LET ((ID (FMC-GET.ITEM ITEM ID)) (LABEL (FMC-GET.ITEM ITEM LABEL)) (TYPE (FMC-GET.ITEM ITEM TYPE)) (FONT (FMC-GET.ITEM ITEM FONT)) (CHANGESTATE (FMC-GET.ITEM ITEM CHANGESTATE)) (SELECTEDFN (FMC-GET.ITEM ITEM SELECTEDFN)) (DOWNFN (FMC-GET.ITEM ITEM DOWNFN)) (HELDFN (FMC-GET.ITEM ITEM HELDFN)) (MOVEDFN (FMC-GET.ITEM ITEM MOVEDFN)) (MENU (FMC-GET.ITEM ITEM MENU)) (INITSTATE (FMC-GET.ITEM ITEM INITSTATE)) (LINKS (FMC-GET.ITEM ITEM LINKS)) (INFINITEWIDTH (FMC-GET.ITEM ITEM INFINITEWIDTH)) (MESSAGE (FMC-GET.ITEM ITEM MESSAGE)) (OBJECTLIST (FMC-GET.ITEM ITEM OBJECTLIST))) (if (FMC-GROUP? ITEM) then (PRINTOUT STREAM .SP SPACES .FONT '(MODERN 12 BOLD) "GROUP - " .FONT '(MODERN 10 BOLDITALIC) " ID : " .FONT '(MODERN 10 REGULAR) ID T) (for OBJECT in (FMC-SORT.ITEM.LIST OBJECTLIST) do (FMC-EDIT.INFO.ITEM OBJECT STREAM (IPLUS SPACES 5))) else (PRINTOUT STREAM .SP SPACES .FONT '(MODERN 10 BOLD) "ITEM - " .FONT '(MODERN 10 BOLDITALIC) " ID : " .FONT '(MODERN 10 REGULAR) ID .FONT '(MODERN 10 BOLDITALIC) " - LABEL : " .FONT '(MODERN 10 REGULAR) LABEL T .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) "TYPE : " .FONT '(MODERN 10 REGULAR) TYPE T) (if [NOT (FMEMB TYPE '(DISPLAY EDIT NUMBER] then (if (EQ TYPE 'STATE) then (if [NOT (EQUAL MENU '(NIL] then (PRINTOUT STREAM .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) "MENU : " .FONT '(MODERN 10 REGULAR) MENU T)) (if [NOT (EQUAL CHANGESTATE '(FUNCTION NILL] then (PRINTOUT STREAM .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) "CHANGESTATE : " .FONT '(MODERN 10 REGULAR) CHANGESTATE T))) (for prop in '(SELECTEDFN DOWNFN HELDFN MOVEDFN) bind Def do (SETQ Def (EVAL prop)) (if [NOT (EQUAL Def '(FUNCTION NILL] then (PRINTOUT STREAM .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) (CONCAT prop " : ") .FONT '(MODERN 10 REGULAR) Def T))) (if INITSTATE then (PRINTOUT STREAM .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) "INITSTATE : " .FONT '(MODERN 10 REGULAR) INITSTATE T)) (if LINKS then (PRINTOUT STREAM .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) "LINKS : " .FONT '(MODERN 10 REGULAR) LINKS T))) (if (FMEMB TYPE '(EDIT NUMBER)) then (PRINTOUT STREAM .SP SPACES .SP 5 .FONT '(MODERN 10 BOLDITALIC) "INFINITEWIDTH : " .FONT '(MODERN 10 REGULAR) INFINITEWIDTH T]) ) (* * Hardcopy functions) (DEFINEQ (FMC-HARDCOPY [LAMBDA (WINDOW STREAM) (* ; "Edited 17-Aug-88 17:01 by A.BLAVIER") (* ;; "Make a centered hardcopy of the contents of the FMC window.") (LET ((ItemList (WINDOWPROP WINDOW 'ITEMLIST)) (PageScale (DSPSCALE NIL STREAM)) (Xmin 5000) (Xmax 0) (Ymin 5000) (Ymax 0) PageWidth PageHeight FMCWidth FMCHeight Xoffset Yoffset 2points 5points 10points) (FMC-PROMPTPRINT "Formatting for print ..." WINDOW) (* ; "compute X and Y offsets") (for item in ItemList bind (region left bottom right top) do (SETQ region (FMC-GET.ITEM item REGION)) (SETQ left (GET.REGION.LEFT region)) (SETQ bottom (GET.REGION.BOTTOM region)) (SETQ right (fetch (REGION RIGHT) of region)) (SETQ top (fetch (REGION TOP) of region)) (if (ILESSP left Xmin) then (SETQ Xmin left)) (if (ILESSP bottom Ymin) then (SETQ Ymin bottom)) (if (IGREATERP right Xmax) then (SETQ Xmax right)) (if (IGREATERP top Ymax) then (SETQ Ymax top))) (SETQ PageWidth (FIX (TIMES 8.27 72 PageScale))) (SETQ PageHeight (FIX (TIMES 11.69 72 PageScale))) (SETQ FMCWidth (ITIMES PageScale (IDIFFERENCE Xmax Xmin))) (SETQ FMCHeight (ITIMES PageScale (IDIFFERENCE Ymax Ymin))) (SETQ Xoffset (IQUOTIENT (IDIFFERENCE PageWidth FMCWidth) 2)) (if (ILESSP Xoffset 0) then (SETQ Xoffset 0)) (SETQ Yoffset (IQUOTIENT (IDIFFERENCE PageHeight FMCHeight) 2)) (SETQ 2points (ITIMES PageScale 2)) (SETQ 5points (ITIMES PageScale 5)) (SETQ 10points (ITIMES PageScale 10)) (if (ILESSP Yoffset 0) then (SETQ Yoffset 0)) (* ;; "draw a rectangle around the items") (DRAWLINE (IDIFFERENCE Xoffset 5points) (IDIFFERENCE Yoffset 5points) (IPLUS Xoffset FMCWidth 5points) (IDIFFERENCE Yoffset 5points) 2points 'REPLACE STREAM) (RELDRAWTO 0 (IPLUS FMCHeight 10points) 2points 'REPLACE STREAM) (RELDRAWTO (MINUS (IPLUS FMCWidth 10points)) 0 2points 'REPLACE STREAM) (RELDRAWTO 0 (MINUS (IPLUS FMCHeight 10points)) 2points 'REPLACE STREAM) (* ;; "adjust X and Y offsets so that the lower left item gets printed in the lower left corner of the area") (SETQ Xoffset (IDIFFERENCE Xoffset (ITIMES PageScale Xmin))) (SETQ Yoffset (IDIFFERENCE Yoffset (ITIMES PageScale Ymin))) (* ;; "draw the items") (for item in ItemList do (FMC-HARDCOPY.ITEM item STREAM Xoffset Yoffset)) (FMC-PROMPTPRINT (CONCAT "Formatting for print ... " " done") WINDOW]) (FMC-HARDCOPY.ITEM [LAMBDA (ITEM STREAM XOFFSET YOFFSET) (* ; "Edited 17-Aug-88 17:12 by A.BLAVIER") (* ;; "Recursive function initially called by FMC-HARDCOPY.") (LET ((Label (FMC-GET.ITEM ITEM LABEL)) (Font (FMC-GET.ITEM ITEM FONT)) (Bitmap (FMC-GET.ITEM ITEM BITMAP)) (Region (FMC-GET.ITEM ITEM REGION)) (Box (FMC-GET.ITEM ITEM BOX)) (BoxShade (FMC-GET.ITEM ITEM BOXSHADE)) (ObjectList (FMC-GET.ITEM ITEM OBJECTLIST)) (PageScale (DSPSCALE NIL STREAM)) RLeft RBottom RWidth RHeight RRight RTop) [SETQ RLeft (IPLUS XOFFSET (ITIMES PageScale (GET.REGION.LEFT Region] [SETQ RBottom (IPLUS YOFFSET (ITIMES PageScale (GET.REGION.BOTTOM Region] (SETQ RWidth (ITIMES PageScale (GET.REGION.WIDTH Region))) (SETQ RHeight (ITIMES PageScale (GET.REGION.HEIGHT Region))) (SETQ RRight (IPLUS RLeft RWidth)) (SETQ RTop (IPLUS RBottom RHeight)) (SETQ Region (CREATEREGION RLeft RBottom RWidth RHeight)) (DSPFILL Region (FMC-GET.ITEM ITEM BACKGROUND) 'REPLACE STREAM) (if Box then (SETQ Box (ITIMES PageScale Box)) (DSPFILL (CREATEREGION RLeft RBottom Box RHeight) BoxShade 'REPLACE STREAM) (DSPFILL (CREATEREGION RLeft (IDIFFERENCE RTop Box) RWidth Box) BoxShade 'REPLACE STREAM) (DSPFILL (CREATEREGION (IDIFFERENCE RRight Box) RBottom Box RHeight) BoxShade 'REPLACE STREAM) (DSPFILL (CREATEREGION RLeft RBottom RWidth Box) BoxShade 'REPLACE STREAM)) (if (FMC-GROUP? ITEM) then (for object in ObjectList do (FMC-HARDCOPY.ITEM object STREAM XOFFSET YOFFSET)) else (if (BITMAPP Label) then [BITBLT Bitmap 0 0 STREAM (IPLUS RLeft (ITIMES PageScale (FMC-GET.ITEM ITEM XBMOFFSET))) (IPLUS RBottom (ITIMES PageScale (FMC-GET.ITEM ITEM YBMOFFSET] else (MOVETO (IPLUS RLeft (ITIMES PageScale (FMC-GET.ITEM ITEM XBMOFFSET))) [IPLUS RBottom (ITIMES PageScale (FMC-GET.ITEM ITEM YBMOFFSET)) (ITIMES PageScale (FONTPROP Font 'DESCENT] STREAM) (PRINTOUT STREAM .FONT Font Label]) ) (* * Creating the desription list) (DEFINEQ (FMC-COMPUTE [LAMBDA (WINDOW) (* ; "Edited 12-Aug-88 13:49 by A.BLAVIER") (* ;; "Compute a description list suitable for the FREEMENU function.") (* ;; "Store the list in the global variable FM-DESCRIPTION.") (* ;; "Create and open a real Free Menu window built out of the description.") (LET ((Background (WINDOWPROP WINDOW 'FMC.BACKGROUND)) Description FM-WINDOW) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (FMC-PROMPTPRINT "COMPUTING ... " WINDOW) (* ;; "build the description list") (SETQ Description '(PROPS FORMAT EXPLICIT)) [if (AND Background (NOT (EQP Background 0))) then (SETQ Description (APPEND Description `(BACKGROUND ,Background] [SETQ Description (CONS Description (for object in (FMC-SORT.ITEM.LIST (WINDOWPROP WINDOW 'ITEMLIST)) collect (FMC-COMPUTE.OBJECT object] (SETQ FM-DESCRIPTION Description) (* ;; "create the Free Menu") (SETQ FM-WINDOW (FREEMENU Description)) (FMC-PROMPTPRINT "COMPUTING ... DONE" WINDOW)) (MOVEW FM-WINDOW (GETBOXPOSITION (WINDOWPROP FM-WINDOW 'WIDTH) (WINDOWPROP FM-WINDOW 'HEIGHT) (IDIFFERENCE (CAR (WINDOWPROP WINDOW 'REGION)) 0) (IDIFFERENCE (CADR (WINDOWPROP WINDOW 'REGION)) 0))) (OPENW FM-WINDOW) (TOTOPW FM-WINDOW]) (FMC-COMPUTE.OBJECT [LAMBDA (OBJECT COLLECTIONID DESELECT) (* ; "Edited 11-Aug-88 16:55 by A.BLAVIER") (* ;; "This recursive function computes the description sublist of OBJECT [Group or Item]") (PROG (Region Type Label Id Box Boxshade Font CHANGESTATE SELECTEDFN DOWNFN HELDFN MOVEDFN Menu Links Initstate Background InfiniteWidth ObjectList TmpLst) (SETQ Region (FMC-GET.ITEM OBJECT REGION)) (SETQ Type (FMC-GET.ITEM OBJECT TYPE)) (SETQ Label (if (STREQUAL (FMC-GET.ITEM OBJECT LABEL) "*NOLABEL*") then "" else (FMC-GET.ITEM OBJECT LABEL))) (SETQ Id (FMC-GET.ITEM OBJECT ID)) (if (FMC-GROUP? OBJECT) then (SETQ Collection (FMC-GET.ITEM OBJECT COLLECTION))) (SETQ Box (FMC-GET.ITEM OBJECT BOX)) (SETQ Boxshade (FMC-GET.ITEM OBJECT BOXSHADE)) (SETQ Font (FMC-GET.ITEM OBJECT FONT)) (SETQ CHANGESTATE (FMC-GET.ITEM OBJECT CHANGESTATE)) (SETQ SELECTEDFN (FMC-GET.ITEM OBJECT SELECTEDFN)) (SETQ DOWNFN (FMC-GET.ITEM OBJECT DOWNFN)) (SETQ HELDFN (FMC-GET.ITEM OBJECT HELDFN)) (SETQ MOVEDFN (FMC-GET.ITEM OBJECT MOVEDFN)) (SETQ Menu (FMC-GET.ITEM OBJECT MENU)) (SETQ Links (FMC-GET.ITEM OBJECT LINKS)) (SETQ Initstate (FMC-GET.ITEM OBJECT INITSTATE)) (SETQ Background (FMC-GET.ITEM OBJECT BACKGROUND)) (SETQ InfiniteWidth (FMC-GET.ITEM OBJECT INFINITEWIDTH)) (SETQ ObjectList (FMC-GET.ITEM OBJECT OBJECTLIST)) (if (FMC-GROUP? OBJECT) then (* ;; "it's a group : compute the header") [SETQ TmpLst `(PROPS ID ,Id LEFT ,(GET.REGION.LEFT Region) BOTTOM ,(GET.REGION.BOTTOM Region) BOX ,Box BOXSHADE ,Boxshade BOXSPACE ,(IDIFFERENCE (FMC-GET.ITEM OBJECT YBMOFFSET) Box] [if (AND Background (NOT (EQP Background 0))) then (SETQ TmpLst (APPEND TmpLst `(BACKGROUND ,Background] (SETQ TmpLst (CONS 'GROUP (LIST TmpLst))) (* ;; "and recursively build it's description") (FMC-SORT.ITEM.LIST ObjectList) (NCONC1 TmpLst (FMC-COMPUTE.OBJECT (CAR ObjectList) Collection (FMC-GET.ITEM OBJECT DESELECT))) (for item in (CDR ObjectList) do (NCONC1 TmpLst (FMC-COMPUTE.OBJECT item Collection))) else (* ;;  "it's a simple item : do the exhausting task of building a property list-format description") (SETQ TmpLst (LIST 'LABEL Label 'TYPE Type 'LEFT (GET.REGION.LEFT Region) 'BOTTOM (GET.REGION.BOTTOM Region))) (if Id then (LISTPUT TmpLst 'ID Id)) [if (EQ Type 'NWAY) then (LISTPUT TmpLst 'COLLECTION COLLECTIONID) (if DESELECT then (LISTPUT TmpLst 'NWAYPROPS '(DESELECT T] (if Box then (LISTPUT TmpLst 'BOX Box) (LISTPUT TmpLst 'BOXSHADE Boxshade) (LISTPUT TmpLst 'BOXSPACE (IDIFFERENCE (FMC-GET.ITEM OBJECT YBMOFFSET) Box))) (if Font then (LISTPUT TmpLst 'FONT Font)) [if (AND [NOT (EQUAL CHANGESTATE '(FUNCTION NILL] (LISTP CHANGESTATE)) then (LISTPUT TmpLst 'CHANGESTATE (if (EQUAL (CAR CHANGESTATE) 'LAMBDA) then CHANGESTATE else (CADR CHANGESTATE] [for prop in '(CHANGESTATE SELECTEDFN DOWNFN HELDFN MOVEDFN) bind Def do (SETQ Def (EVAL prop)) (if [NOT (EQUAL Def '(FUNCTION NILL] then (LISTPUT TmpLst prop (if (EQUAL (CAR Def) 'LAMBDA) then Def else (CADR Def] [if (CAR Menu) then (LISTPUT TmpLst 'MENUITEMS (CAR Menu)) (if (CADR Menu) then (LISTPUT TmpLst 'MENUFONT (CADR Menu))) (if (CADDR Menu) then (LISTPUT TmpLst 'MENUTITLE (CADDR Menu] (if (CAR Links) then (LISTPUT TmpLst 'LINKS Links)) (if Initstate then (LISTPUT TmpLst 'INITSTATE Initstate)) (if (OR [AND [NOT (FMEMB Type '(EDIT NUMBER] (NOT Box) (NOT (EQUAL (GET.REGION.WIDTH Region) (BITMAPWIDTH (FMC-GET.ITEM OBJECT BITMAP] (AND (FMEMB Type '(EDIT NUMBER)) (NOT InfiniteWidth))) then (LISTPUT TmpLst 'MAXWIDTH (GET.REGION.WIDTH Region))) (if (AND Background (NOT (EQP Background 0))) then (LISTPUT TmpLst 'BACKGROUND Background))) (RETURN TmpLst]) ) (* * Miscellaneous) (DEFINEQ (FMC-CREATE.ITEM.FROM.LIST [LAMBDA (L) (* ; "Edited 12-Aug-88 11:21 by A.BLAVIER") (* ;; "Given a list as those saved in a FMC file, create a new item.") (create FMC-ITEM TYPE _ (CAR (NTH L 1)) LABEL _ (CAR (NTH L 2)) FONT _ (CAR (NTH L 3)) ID _ (CAR (NTH L 4)) COLLECTION _ (CAR (NTH L 5)) DESELECT _ (CAR (NTH L 6)) MESSAGE _ (CAR (NTH L 7)) INITSTATE _ (CAR (NTH L 8)) BOX _ (CAR (NTH L 9)) BOXSHADE _ (CAR (NTH L 10)) BACKGROUND _ (CAR (NTH L 11)) LINKS _ (CAR (NTH L 12)) OBJECTLIST _ (CAR (NTH L 13)) MENU _ (CAR (NTH L 14)) CHANGESTATE _ (CAR (NTH L 15)) SELECTEDFN _ (CAR (NTH L 16)) DOWNFN _ (CAR (NTH L 17)) HELDFN _ (CAR (NTH L 18)) MOVEDFN _ (CAR (NTH L 19)) REGION _ (CAR (NTH L 20)) BITMAP _ (CAR (NTH L 21)) XBMOFFSET _ (CAR (NTH L 22)) YBMOFFSET _ (CAR (NTH L 23)) INFINITEWIDTH _ (CAR (NTH L 24)) USERDATA _ (CAR (NTH L 25]) (FMC-DRAW.BOX [LAMBDA (ITEM BOX BOXSHADE WINDOW) (* ; "Edited 17-Aug-88 17:38 by A.BLAVIER") (* ;; "Draw a BOX wide box around the item with BOXSHADE.") (LET ((Region (FMC-GET.ITEM ITEM REGION)) RLeft RBottom RWidth RHeight RRight RTop) (SETQ RLeft (GET.REGION.LEFT Region)) (SETQ RBottom (GET.REGION.BOTTOM Region)) (SETQ RWidth (GET.REGION.WIDTH Region)) (SETQ RHeight (GET.REGION.HEIGHT Region)) (SETQ RRight (fetch (REGION PRIGHT) of Region)) (SETQ RTop (fetch (REGION PTOP) of Region)) (if BOX then (DSPFILL (CREATEREGION RLeft RBottom BOX RHeight) BOXSHADE 'REPLACE WINDOW) (DSPFILL (CREATEREGION RLeft (IDIFFERENCE RTop BOX) RWidth BOX) BOXSHADE 'REPLACE WINDOW) (DSPFILL (CREATEREGION (IDIFFERENCE RRight BOX) RBottom BOX RHeight) BOXSHADE 'REPLACE WINDOW) (DSPFILL (CREATEREGION RLeft RBottom RWidth BOX) BOXSHADE 'REPLACE WINDOW]) (FMC-CHOOSE.WINDOW.BG [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 17:39 by A.BLAVIER") (* ;; "Choose a background shade for the FMC window.") (LET ((ShadeMenu (WINDOWPROP (WINDOWPROP WINDOW 'FMC.IP.WINDOW) 'SHADE.MENU)) Shade) (SETQ Shade (MENU ShadeMenu)) (if Shade then (WINDOWPROP WINDOW 'FMC.BACKGROUND (CDR Shade)) (FMC-REDRAW WINDOW]) (FMC-DISPLAY.GRID [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 17:40 by A.BLAVIER") (LET [(Size (WINDOWPROP WINDOW 'GRIDSIZE] [if (AND Size (IGREATERP Size 2)) then (for y from 0 to (WINDOWPROP WINDOW 'HEIGHT) by Size do (DRAWLINE 0 y (WINDOWPROP WINDOW 'WIDTH) y 1 'REPLACE WINDOW NIL (LIST 1 (SUB1 Size] (WINDOWPROP WINDOW 'DISPLAYGRID T]) (FMC-SET.GRIDSIZE [LAMBDA (SIZE WINDOW) (* ; "Edited 22-Jun-88 13:47 by A.BLAVIER") (if (EQ SIZE 'NOGRID) then (WINDOWPROP WINDOW 'GRIDSIZE NIL) (FMC-PROMPTPRINT "No grid" WINDOW) (if (WINDOWPROP WINDOW 'DISPLAYGRID) then (FMC-REDRAW WINDOW)) (WINDOWPROP WINDOW 'DISPLAYGRID NIL) else (FMC-PROMPTPRINT (CONCAT "Grid size is " SIZE) WINDOW) (if (NOT (EQP (WINDOWPROP WINDOW 'GRIDSIZE) SIZE)) then (WINDOWPROP WINDOW 'GRIDSIZE SIZE) (if (WINDOWPROP WINDOW 'DISPLAYGRID) then (FMC-REDRAW WINDOW]) (FMC-FONT->LIST [LAMBDA (FONT) (* ; "Edited 17-Aug-88 17:42 by A.BLAVIER") (* ;; "Compute a Font description list based on a Font Descriptor.") (LET [(Face (FONTPROP FONT 'FACE] (LIST (FONTPROP FONT 'FAMILY) (FONTPROP FONT 'SIZE) (COND ((EQUAL Face '(MEDIUM REGULAR REGULAR)) 'STANDARD) ((EQUAL Face '(MEDIUM ITALIC REGULAR)) 'ITALIC) ((EQUAL Face '(BOLD REGULAR REGULAR)) 'BOLD) ((EQUAL Face '(BOLD ITALIC REGULAR)) 'BOLDITALIC]) (FMC-LIST->FONT [LAMBDA (FONT.LIST) (* ; "Edited 17-Aug-88 17:42 by A.BLAVIER") (* ;; "Compute a Font Descriptor based on a Font description list.") (FONTCREATE (CAR FONT.LIST) (CADR FONT.LIST) (CADDR FONT.LIST) 0 'DISPLAY]) (FMC-SORT.ITEM.LIST [LAMBDA (LIST) (* ; "Edited 17-Aug-88 17:43 by A.BLAVIER") (* ;;  "Sort items by order of appearance in the window from top to bottom and from left to right.") (SORT LIST (FUNCTION (LAMBDA (ITEMA ITEMB) (LET [(LEFTA (GET.REGION.LEFT (FMC-GET.ITEM ITEMA REGION))) (LEFTB (GET.REGION.LEFT (FMC-GET.ITEM ITEMB REGION))) (TOPA (fetch (REGION TOP) of (FMC-GET.ITEM ITEMA REGION))) (TOPB (fetch (REGION TOP) of (FMC-GET.ITEM ITEMB REGION))) (BOTTOMA (GET.REGION.BOTTOM (FMC-GET.ITEM ITEMA REGION))) (BOTTOMB (GET.REGION.BOTTOM (FMC-GET.ITEM ITEMB REGION] (OR (> BOTTOMA TOPB) (AND (< LEFTA LEFTB) (< BOTTOMB TOPA]) (FMC-IMPORT [LAMBDA (WINDOW) (* ; "Edited 12-Aug-88 10:42 by A.BLAVIER") (* ;; "Import items from a Free Menu.") (LET (FM.WINDOW FM.ITEMS) (FMC-PROMPTPRINT "Click on the Free Menu you want to import from" WINDOW) (while (MOUSESTATE (NOT LEFT))) (SETQ FM.WINDOW (WHICHW)) (SETQ FM.ITEMS (WINDOWPROP FM.WINDOW 'FM.ITEMS)) (if (NOT FM.ITEMS) then (FMC-PROMPTPRINT "This is not a Free Menu" WINDOW) else (INVERTW FM.WINDOW) (FMC-PROMPTPRINT "Importing items ..." WINDOW) (FMC-DESELECT WINDOW) (for ITEM in FM.ITEMS bind NEW.ITEM label message links userData menuProps changeState selectedFn downFn heldFn movedFn do (SETQ label (fetch FM.LABEL of ITEM)) (SETQ message (fetch FM.MESSAGE of ITEM)) (SETQ links (fetch FM.LINKS of ITEM)) (SETQ userData (fetch FM.USERDATA of ITEM)) (SETQ changeState (LISTGET userData 'CHANGESTATE)) (SETQ selectedFn (fetch FM.SELECTEDFN of ITEM)) (SETQ downFn (fetch FM.DOWNFN of ITEM)) (SETQ heldFn (fetch FM.HELDFN of ITEM)) (SETQ movedFn (fetch FM.MOVEDFN of ITEM)) [SETQ NEW.ITEM (COPYALL (FMC-CREATE.ITEM.FROM.LIST (LIST (fetch FM.TYPE of ITEM) (if (OR (STREQUAL label "") (NULL label)) then "*NOLABEL*" else label) (FMC-FONT->LIST (fetch FM.FONT of ITEM)) (fetch FM.ID of ITEM) NIL NIL (if (OR (STREQUAL message "Will select this item when you release the button." ) (STREQUAL message "Will let you select a value from a pop up menu." ) (STREQUAL message "Will toggle this item when you release the button." )) then "" else message) (fetch FM.INITSTATE of ITEM) NIL 0 0 (if (CAR links) then (LIST (CAR links) (fetch FM.ID of (CADR links))) else '(NIL)) NIL (if (LISTGET userData 'MENUITEMS) then [SETQ menuProps (LIST (LISTGET userData 'MENUITEMS] [if (LISTGET userData 'MENUFONT) then (NCONC1 menuProps (LISTGET userData 'MENUFONT] [if (LISTGET userData 'MENUTITLE) then (if (NOT (CDR menuProps)) then (NCONC1 menuProps NIL)) (NCONC1 menuProps (LISTGET userData 'MENUTITLE] menuProps else '(NIL)) (if changeState then (if (ATOM changeState) then (LIST 'FUNCTION changeState) else changeState) else '(FUNCTION NILL)) (if (ATOM selectedFn) then (LIST 'FUNCTION selectedFn) else selectedFn) (if (ATOM downFn) then (LIST 'FUNCTION downFn) else downFn) (if (ATOM heldFn) then (LIST 'FUNCTION heldFn) else heldFn) (if (ATOM movedFn) then (LIST 'FUNCTION movedFn) else movedFn) (fetch FM.REGION of ITEM) (FMC-MAKEBITMAP (if (OR (STREQUAL label "") (NULL label)) then "*NOLABEL*" else label) (fetch FM.FONT of ITEM)) 0 0 (LISTGET userData 'INFINITEWIDTH) NIL] [if (OR (STREQUAL label "") (NULL label)) then (PUT.REGION.WIDTH (FMC-GET.ITEM NEW.ITEM REGION) (BITMAPWIDTH (FMC-GET.ITEM NEW.ITEM BITMAP))) (PUT.REGION.HEIGHT (FMC-GET.ITEM NEW.ITEM REGION) (BITMAPHEIGHT (FMC-GET.ITEM NEW.ITEM BITMAP] [if (LISTGET userData 'BOX) then (FMC-PUT.ITEM NEW.ITEM BOX (LISTGET userData 'BOX)) (FMC-PUT.ITEM NEW.ITEM BOXSHADE (LISTGET userData 'BOXSHADE)) (FMC-PUT.ITEM NEW.ITEM XBMOFFSET (LISTGET userData 'BOXOFFSET)) (FMC-PUT.ITEM NEW.ITEM YBMOFFSET (LISTGET userData 'BOXOFFSET] (WINDOWADDPROP WINDOW 'ITEMLIST NEW.ITEM) (WINDOWADDPROP WINDOW 'SELECTION.LIST NEW.ITEM) (FMC-REDRAW.ITEM NEW.ITEM WINDOW)) (INVERTW FM.WINDOW) (FMC-PROMPTPRINT "Importing items ... DONE" WINDOW) (FMC-SELECT.LIST WINDOW) (FMC-MARK.AS.CHANGED WINDOW]) (FMC-PROMPTPRINT [LAMBDA (STR WINDOW) (* ; "Edited 17-Aug-88 17:44 by A.BLAVIER") (* ;; "Print a message in the FMC prompt window.") (LET [(PromptWindow (WINDOWPROP WINDOW 'FMC.PROMPTWINDOW] (DSPRESET PromptWindow) (PRINTOUT PromptWindow T STR) (FLASHWINDOW PromptWindow 1]) ) (* * Icon stuff) (RPAQQ FMC-ICON #*(76 94)@@@@@@@@AO@@@@@@@@@@@@@@@@@@COH@@@@@@@@@@@@@@@@@GOL@@@@@@@@@@@@@@@@@OON@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@@OON@@@@@@@@@@@@@@@@@GOL@@@@@@@@@@@@@@@@@COH@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOON@@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@CO@FOKHOH@@@@@@@@@@@COGNGCGGH@@@@@@@@@@@GOGNJKGOL@@@@@@@@@@@GOGNMKGOL@@@@@@@@@@@OOANOKGON@@@@@@@@@@@OOGNOKGON@@@@@@@@@@AOOGNOKGOO@@@@@@@@@@AOOGNOKGGO@@@@@@@@@@COOGNOKHOOH@@@@@@@@@COOOOOOOOOH@@@@@@AOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOL@@@AH@AOL@@@@@AOL@AL@@@C@@@OL@@@@@GON@@L@@@CCONONGOH@AOON@@L@@@CB@@GO@@H@COOL@@L@@@CBOOGOCLH@OOO@@@N@@@FDH@COHDHCOOL@@@F@@@FDOOKOILHOOOH@@@F@@@FD@@AOL@HOON@@@@F@@@FD@@AOL@HGOH@@@@G@@@LIOOLONLHGN@@@@@C@@@LI@@BONDHCH@@@@@C@@@LJ@@BGODHB@@@@@@C@@@LKOONGO@H@@@@@@@CH@AI@@@@COHH@@@@@@@AH@AI@@@@AO@H@@@@@@@AH@AIOOOOMLOH@@@@@@@AH@C@@@@@@@@@@@@@@@@AH@C@@@@@@@@@@@@@@@@@L@C@@@@@@@@@@@@@@@@@L@CCOOOOOHGOOLCOOO@@L@FB@@@@@HD@@DB@@A@@L@FB@@@@@HD@@DB@@A@@F@FD@@@@A@D@@DB@@@H@F@FD@@@@A@D@@DB@@@H@F@LGOOOOO@GOOLCOOOH@F@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@C@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@ ) (RPAQQ FMC-ICON.MASK #*(76 94)@@@@@@@@AO@@@@@@@@@@@@@@@@@@COH@@@@@@@@@@@@@@@@@GOL@@@@@@@@@@@@@@@@@OON@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@@OON@@@@@@@@@@@@@@@@@GOL@@@@@@@@@@@@@@@@@COH@@@@@@@@@@@@@@@@@AO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOON@@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@OOOOOOOON@@@@@@@@@@@OOOOOOOON@@@@@@@@@@AOOOOOOOOO@@@@@@@@@@AOOOOOOOOO@@@@@@@@@@COOOOOOOOOH@@@@@@@@@COOOOOOOOOH@@@@@@AOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOH@AOOOOOOOOOOOOOOOOOH@AOOOOOOOOOOOOOOOOOH@AOOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOH@COOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOL@GOOOOOOOOOOOOOOOOOL@GOOOOOOOOOOOOOOOOON@GOOOOOOOOOOOOOOOOON@GOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOO@ ) (RPAQ? FMC-ICON.TEMPLATE (create TITLEDICON ICON _ FMC-ICON MASK _ FMC-ICON.MASK TITLEREG _ (CREATEREGION 2 2 70 28))) (* *) [OR (SASSOC 'FMCreator BackgroundMenuCommands) (NCONC1 BackgroundMenuCommands '(FMCreator '(FMC-CREATE) "Opens a Free Menu Creator window for use"] (SETQ BackgroundMenu NIL) (RPAQ MOVINGCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@A@@@CH@@ED@@A@@@A@@BA@HD@@DOLGND@@DBA@H@A@@@A@@@ED@@CH@@A@@ ) (QUOTE NIL) 7 7)) (PUTPROPS FM-CREATOR COPYRIGHT ("Rank Xerox France. Author Andre BLAVIER" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4362 15980 (FMC-CREATE 4372 . 10712) (FMC-INSTALL.IP.WINDOW 10714 . 13291) ( FMC-INSTALL.GP.WINDOW 13293 . 14616) (FMC-CREATE.SHADE.MENU 14618 . 15281) (FMC-CREATE.SHADE.ITEM 15283 . 15978)) (16015 29619 (FMC-BUTTONEVENTFN 16025 . 23020) (FMC-CLOSEFN 23022 . 23823) ( FMC-COPYBUTTONEVENTFN 23825 . 24785) (FMC-COPYINSERTFN 24787 . 26407) (FMC-CURSORMOVEDFN 26409 . 27296 ) (FMC-CURSOROUTFN 27298 . 27459) (FMC-EXPANDFN 27461 . 27741) (FMC-ICONFN 27743 . 28755) ( FMC-SHRINKFN 28757 . 29061) (FMC-WINDOWENTRYFN 29063 . 29617)) (31454 35400 (FMC-FIXRIGHTMENU 31464 . 33117) (FMC-DORIGHTSELECTION 33119 . 35398)) (35433 42932 (FMC-SELECT.ITEM 35443 . 36551) ( FMC-SELECT.LIST 36553 . 36874) (FMC-SELECT.LIST.ITEM 36876 . 37932) (FMC-SELECTALL 37934 . 38328) ( FMC-GET.SELECTION 38330 . 40066) (FMC-DESELECT 40068 . 40446) (FMC-DESELECT.ITEM 40448 . 41526) ( FMC-DESELECT.LIST 41528 . 41897) (FMC-DESELECT.LIST.ITEM 41899 . 42930)) (42972 71259 (FMC-APPLY 42982 . 47323) (FMC-SHOW.ITEM 47325 . 52244) (FMC-SHOW.GROUP 52246 . 54394) (FMC-NEWITEM 54396 . 55927) ( FMC-UPDATE.ITEM 55929 . 61952) (FMC-UPDATE.GROUP 61954 . 63772) (FMC-GET.LABEL 63774 . 64522) ( FMC-CHOOSE.ITEM.BOXSHADE 64524 . 65106) (FMC-CHOOSE.ITEM.BG 65108 . 65695) (FMC-GET.MENUPROPS 65697 . 66591) (FMC-GET.INITSTATE 66593 . 68971) (FMC-EDIT.FN 68973 . 69590) (FMC-LINKS 69592 . 71257)) (81842 84551 (FMC-MAKEBITMAP 81852 . 82544) (FMC-COMPOUND.BITMAP 82546 . 84005) (FMC-SNAPBM 84007 . 84549)) (84577 95636 (FMC-MOVE.SELECTION 84587 . 88458) (FMC-MOVE.BITMAP 88460 . 92852) (FMC-TRACK.NEW.ITEM 92854 . 93904) (FMC-UPDATE.BM.POSITION 93906 . 94629) (FMC-UPDATE.REGION 94631 . 95634)) (95663 108537 (FMC-COMPUTE.SHAPE.REGS 95673 . 97851) (FMC-SHAPE 97853 . 106662) (FMC-BOX.NEWREGIONFN 106664 . 108106) (FMC-NOBOX.NEWREGIONFN 108108 . 108535)) (108566 110451 (FMC-REDRAW 108576 . 109224) ( FMC-REDRAW.ITEM 109226 . 110449)) (110494 113925 (FMC-DELETE 110504 . 111854) (FMC-UNDELETE 111856 . 113923)) (113962 117670 (FMC-GROUP 113972 . 116637) (FMC-UNGROUP 116639 . 117668)) (117710 127034 ( FMC-ALIGN 117720 . 121191) (FMC-HCENTER 121193 . 123497) (FMC-VCENTER 123499 . 125877) (FMC-REL.MOVE 125879 . 127032)) (127071 136665 (FMC-GET 127081 . 129946) (FMC-GET.ONE.OBJECT 129948 . 132185) ( FMC-PUT 132187 . 134238) (FMC-PUT.OBJECT 134240 . 136663)) (136697 141636 (FMC-EDIT.INFO 136707 . 137943) (FMC-EDIT.INFO.ITEM 137945 . 141634)) (141668 147722 (FMC-HARDCOPY 141678 . 144920) ( FMC-HARDCOPY.ITEM 144922 . 147720)) (147764 155916 (FMC-COMPUTE 147774 . 149790) (FMC-COMPUTE.OBJECT 149792 . 155914)) (155943 169254 (FMC-CREATE.ITEM.FROM.LIST 155953 . 157160) (FMC-DRAW.BOX 157162 . 158498) (FMC-CHOOSE.WINDOW.BG 158500 . 159017) (FMC-DISPLAY.GRID 159019 . 159523) (FMC-SET.GRIDSIZE 159525 . 160305) (FMC-FONT->LIST 160307 . 161008) (FMC-LIST->FONT 161010 . 161357) (FMC-SORT.ITEM.LIST 161359 . 162401) (FMC-IMPORT 162403 . 168871) (FMC-PROMPTPRINT 168873 . 169252))))) STOP \ No newline at end of file diff --git a/lispusers/FM-CREATOR.TEDIT b/lispusers/FM-CREATOR.TEDIT new file mode 100644 index 00000000..118a68e0 Binary files /dev/null and b/lispusers/FM-CREATOR.TEDIT differ diff --git a/lispusers/FONTDECLS b/lispusers/FONTDECLS new file mode 100644 index 00000000..9a4ed448 --- /dev/null +++ b/lispusers/FONTDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "27-Sep-87 16:13:36" {DSK}FONTDECLS.;7 10151 changes to%: (VARS FONTDECLSCOMS) previous date%: "25-Sep-87 22:24:36" {DSK}FONTDECLS.;6) (PRETTYCOMPRINT FONTDECLSCOMS) (RPAQQ FONTDECLSCOMS ((PROP MAKEFILE-ENVIRONMENT FONTDECLS) (RECORDS FONTDESCRIPTOR CHARSETINFO) (CONSTANTS WORDSPERCELL \MAXCHARSET \MAXTHINCHAR) (MACROS FOLDHI UNFOLD \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR \FGETIMAGEWIDTH \FGETOFFSET \FGETWIDTH \FSETIMAGEWIDTH \FSETOFFSET \FSETWIDTH \GETCHARSETINFO \SETCHARSETINFO))) (PUTPROPS FONTDECLS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (DECLARE%: EVAL@COMPILE (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) (\SFObsolete1 POINTER) (* WAS CHARACTERBITMAP) (* Bitmap containing the character  images, indexed by \SFOffsets) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) (\SFObsolete2 POINTER) (* Was \SFWidths) (* The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations.) (\SFObsolete3 POINTER) (* WAS \SFOffsets) (* Offset of each character into the image bitmap;  X value of left edge) (\SFObsolete4 POINTER) (* Was \SFWidthsY) (\SFObsolete5 WORD) (* WAS FIRSTCHAR) (* Charcode of the first character that exists in the font) (\SFObsolete6 WORD) (* WAS LASTCHAR) (* Charcode of the last character that exists in the font) (\SFAscent WORD) (\SFDescent WORD) (\SFHeight WORD) (ROTATION WORD) (FBBOX SIGNEDWORD) (FBBOY SIGNEDWORD) (FBBDX SIGNEDWORD) (FBBDY SIGNEDWORD) (\SFFACECODE BITS 8) (\SFLKerns POINTER) (\SFRWidths POINTER) (FONTDEVICESPEC POINTER) (* Holds the spec by which the font is known to the printing device, if  coercion has been done) (OTHERDEVICEFONTPROPS POINTER) (* For individual devices to hang  special information) (FONTSCALE POINTER) (FONTAVGCHARWIDTH WORD) (* Set in FONTCREATE, used to fix up the linelength when DSPFONT is called) (FONTIMAGEWIDTHS POINTER) (* This is the image width, as opposed to the advanced width;  initial hack for accents, kerning. Fields is referenced by FONTCREATE.) (FONTCHARSETVECTOR POINTER) (* A 256-pointer block, with one pointer per "character set" --each group of  256 character codes. Each pointer is either NIL if there's no info for that  charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the  characters in that charset.) (FONTEXTRAFIELD2 POINTER)) FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR)) (DATATYPE CHARSETINFO (WIDTHS (* The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations.) OFFSETS (* Offset of each character into the image bitmap;  X value of left edge) IMAGEWIDTHS (* imagewidths is not automagically allocated since it is not always needed) CHARSETBITMAP (* Bitmap containing the character  images, indexed by OFFSETS) YWIDTHS (CHARSETASCENT WORD) (* Max ascent for all characters in  this CHARSET) (CHARSETDESCENT WORD) (* Max descent for all characters in  this CHARSET) ) WIDTHS _ (\CREATECSINFOELEMENT) OFFSETS _ (\CREATECSINFOELEMENT)) ) (/DECLAREDATATYPE 'FONTDESCRIPTOR '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8) POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER) '((FONTDESCRIPTOR 0 POINTER) (FONTDESCRIPTOR 2 POINTER) (FONTDESCRIPTOR 4 POINTER) (FONTDESCRIPTOR 6 POINTER) (FONTDESCRIPTOR 8 POINTER) (FONTDESCRIPTOR 10 POINTER) (FONTDESCRIPTOR 12 POINTER) (FONTDESCRIPTOR 14 POINTER) (FONTDESCRIPTOR 16 (BITS . 15)) (FONTDESCRIPTOR 17 (BITS . 15)) (FONTDESCRIPTOR 18 (BITS . 15)) (FONTDESCRIPTOR 19 (BITS . 15)) (FONTDESCRIPTOR 20 (BITS . 15)) (FONTDESCRIPTOR 21 (BITS . 15)) (FONTDESCRIPTOR 22 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 23 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 24 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 25 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 14 (BITS . 7)) (FONTDESCRIPTOR 26 POINTER) (FONTDESCRIPTOR 28 POINTER) (FONTDESCRIPTOR 30 POINTER) (FONTDESCRIPTOR 32 POINTER) (FONTDESCRIPTOR 34 POINTER) (FONTDESCRIPTOR 36 (BITS . 15)) (FONTDESCRIPTOR 38 POINTER) (FONTDESCRIPTOR 40 POINTER) (FONTDESCRIPTOR 42 POINTER)) '44) (/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD) '((CHARSETINFO 0 POINTER) (CHARSETINFO 2 POINTER) (CHARSETINFO 4 POINTER) (CHARSETINFO 6 POINTER) (CHARSETINFO 8 POINTER) (CHARSETINFO 10 (BITS . 15)) (CHARSETINFO 11 (BITS . 15))) '12) (DECLARE%: EVAL@COMPILE (RPAQQ WORDSPERCELL 2) (RPAQQ \MAXCHARSET 255) (RPAQQ \MAXTHINCHAR 255) (CONSTANTS WORDSPERCELL \MAXCHARSET \MAXTHINCHAR) ) (DECLARE%: EVAL@COMPILE [PUTPROPS FOLDHI MACRO (X (PROG [(FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X] (OR (AND DIVISOR (POWEROFTWOP DIVISOR)) (\ILLEGAL.ARG (CADR X))) (RETURN (LIST 'LRSH (LIST 'IPLUS FORM (SUB1 DIVISOR)) (SUB1 (INTEGERLENGTH DIVISOR] [PUTPROPS UNFOLD MACRO (X (PROG [(FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X] (OR (AND DIVISOR (POWEROFTWOP DIVISOR)) (\ILLEGAL.ARG (CADR X))) (RETURN (LIST 'LLSH FORM (SUB1 (INTEGERLENGTH DIVISOR] [PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3) WORDSPERCELL] (PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL (* Allocates a block for the character set records) (\ALLOCBLOCK (ADD1 \MAXCHARSET) T))) (PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))) (PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\GETBASE OFFSETSBLOCK CHAR8CODE))) (PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\GETBASE WIDTHSBLOCK CHAR8CODE))) (PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) (PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET))) (PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) [PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) (* * fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates the required charset.) (* * NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL) (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC) (UNFOLD CHARSET 2)) (\CREATECHARSET CHARSET FONTDESC NOSLUG?] (PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO) (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2) CSINFO))) ) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/FONTSAMPLER b/lispusers/FONTSAMPLER new file mode 100644 index 00000000..d23542e4 --- /dev/null +++ b/lispusers/FONTSAMPLER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Apr-87 22:43:49" {ERIS}LYRIC>FONTSAMPLER.;4 7992 changes to%: (FNS FontSample) previous date%: "29-Apr-87 22:41:24" {ERIS}KOTO>FONTSAMPLER.;6) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTSAMPLERCOMS) (RPAQQ FONTSAMPLERCOMS ((FNS FontSample FontSampleFaked FontTable) [VARS (*INTERESTING-CHARSETS* '(0 33 34 38 39 238 239 240 241] (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) FONT)))) (DEFINEQ (FontSample [LAMBDA (Fonts CharacterSets Printer StreamType) (* edited%: "29-Apr-87 22:03") (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer] (FontList (if (LISTP Fonts) else (CONS Fonts))) [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList] (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream))) (LastFont (CAR (LAST FontList))) [CharacterSets (if (LISTP CharacterSets) then CharacterSets else (LIST (OR CharacterSets 0] (LastCharacterSet (CAR (LAST CharacterSets] (DSPRIGHTMARGIN (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL Stream)) Stream) (for Font in FontList do (for CharacterSet in CharacterSets do (FontTable Font CharacterSet Stream (OR (NEQ Font LastFont) (NEQ CharacterSet LastCharacterSet )) TitleFont InchesToPrinterUnits)) finally (CLOSEF Stream]) (FontSampleFaked [LAMBDA (FontAsList Printer StreamType) (* N.H.Briggs "27-Apr-87 18:12") (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer] (Font) [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont] (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream] [SETQ Font (NCREATE 'FONTDESCRIPTOR (DEFAULTFONT (OR StreamType (PRINTERTYPE Printer] (replace FONTFAMILY of Font with (CAR FontAsList)) (replace FONTSIZE of Font with (CADR FontAsList)) (replace FONTFACE of Font with (\FONTFACE (CADDR FontAsList))) (FontTable Font '(0) Stream NIL TitleFont InchesToPrinterUnits) (CLOSEF Stream]) (FontTable [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits) (* edited%: "29-Apr-87 22:36") (LET* ((Family (FONTPROP Font 'FAMILY)) (Face (FONTPROP Font 'FACE)) (Size (FONTPROP Font 'SIZE)) (Title (CONCAT " " Size "pt " (L-CASE Family T) " " (L-CASE Face T) " Character set "))) (printout T Title |.I0.8| CharacterSet "Q") (RESETLST (RESETSAVE (RADIX 8)) (for XPosition from (TIMES 0.65 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits ) as Counter from 0 to 15 bind (YPosition _ (TIMES 9.5 InchesToPrinterUnits)) do (MOVETO XPosition YPosition Stream) (PRIN1 Counter Stream)) (for YPosition from (TIMES 9 InchesToPrinterUnits) by (TIMES -0.5 InchesToPrinterUnits) as Counter from 0 to 240 by 16 bind (XPosition _ (TIMES 0.25 InchesToPrinterUnits )) do (MOVETO XPosition YPosition Stream) (PRIN1 Counter Stream))) (DRAWLINE (TIMES 0.25 InchesToPrinterUnits) (TIMES 9.25 InchesToPrinterUnits) (TIMES 8.0 InchesToPrinterUnits) (TIMES 9.25 InchesToPrinterUnits) (DSPSCALE NIL Stream) 'PAINT Stream) (DRAWLINE (TIMES 0.6 InchesToPrinterUnits) (TIMES 9.7 InchesToPrinterUnits) (TIMES 0.6 InchesToPrinterUnits) (TIMES 1.25 InchesToPrinterUnits) (DSPSCALE NIL Stream) 'PAINT Stream) (DSPFONT Font Stream) (for YPosition from (TIMES 9 InchesToPrinterUnits) by (TIMES -0.5 InchesToPrinterUnits) as YCounter from 0 to 15 bind (CharacterCode _ 0) do (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits) as XCounter from 0 to 15 do (MOVETO XPosition YPosition Stream) (if (AND (NEQ CharacterCode (CHARCODE FF)) (if (MEMB (IMAGESTREAMTYPE Stream) '(DISPLAY INTERPRESS)) then (OR (AND (IGREATERP CharacterCode 31) (ILESSP CharacterCode 127)) (AND (IGREATERP CharacterCode 160) (ILESSP CharacterCode 255))) else T)) then (PRINTCCODE (IPLUS (ITIMES CharacterSet 256) CharacterCode) Stream)) (SETQ CharacterCode (ADD1 CharacterCode))) (printout T ".")) (MOVETO (FTIMES 0.75 InchesToPrinterUnits) (FTIMES 0.75 InchesToPrinterUnits) Stream) (DSPFONT TitleFont Stream) (printout Stream Title |.I0.8| CharacterSet) (DSPYPOSITION (PLUS (DSPYPOSITION NIL Stream) (TIMES -0.4 (FONTHEIGHT TitleFont))) Stream) (printout Stream "8") [if (EQ (FILENAMEFIELD (FULLNAME Stream) 'HOST) 'LPT) then (MOVETO (FTIMES 0.75 InchesToPrinterUnits) (FTIMES 0.5 InchesToPrinterUnits) Stream) (printout Stream " on " (L-CASE (OR (FILENAMEFIELD (FULLNAME Stream) 'DEVICE) (FILENAMEFIELD (FULLNAME Stream) 'NAME)) T) ", " (GDATE NIL (DATEFORMAT NO.TIME SPACES] (if FormFeed then (DSPNEWPAGE Stream)) (printout T " done." T]) ) (RPAQQ *INTERESTING-CHARSETS* (0 33 34 38 39 238 239 240 241)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) FONT) ) (PUTPROPS FONTSAMPLER COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (689 7765 (FontSample 699 . 2154) (FontSampleFaked 2156 . 2965) (FontTable 2967 . 7763)) ))) STOP \ No newline at end of file diff --git a/lispusers/FONTSAMPLER.TEDIT b/lispusers/FONTSAMPLER.TEDIT new file mode 100644 index 00000000..367db669 Binary files /dev/null and b/lispusers/FONTSAMPLER.TEDIT differ diff --git a/lispusers/FORMACRO b/lispusers/FORMACRO new file mode 100644 index 00000000..c78ada4e --- /dev/null +++ b/lispusers/FORMACRO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "USER" READTABLE "XCL") (IL:FILECREATED "22-Sep-87 13:17:50" IL:{DSK}FORMACRO.\;10 20832 IL:|changes| IL:|to:| (IL:FUNCTIONS SDC-FOR XCL-USER::SELECTC ISOPRP FROMTOTEST) (IL:VARS IL:FORMACROCOMS) (IL:PROPS (AS FORWORD) (THEREIS FORWORD) (BY FORWORD) (FROM FORWORD) (IN FORWORD) (ON FORWORD) (TO FORWORD) (JOIN FORWORD)) IL:|previous| IL:|date:| "21-Sep-87 17:07:45" IL:{DSK}FORMACRO.\;9) ; Copyright (c) 1987 by System Development Corp.. All rights reserved. (IL:PRETTYCOMPRINT IL:FORMACROCOMS) (IL:RPAQQ IL:FORMACROCOMS ((IL:P (EXPORT 'FOR)) (IL:FUNCTIONS EVLIST FOR FROMTOTEST ISOPRP SDC-FOR XCL-USER::SELECTC TESTFOR) (IL:PROP FORWORD ALWAYS AS BIND BY COLLECT COUNT DO EACHTIME FINALLY FIRST FROM IN INSIDE JOIN LARGEST MAX MIN NEVER ON REPEATWHILE REPEATUNTIL SMALLEST SUM TO THEREIS UNION UNLESS UNTIL WHEN WHILE) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:FORMACRO) (IL:EDITHIST IL:FORMACRO))) (EXPORT 'FOR) (DEFUN EVLIST (L) (NREVERSE (MAPCAR #'EVAL L))) (DEFMACRO FOR (&BODY X) (SDC-FOR X)) (DEFUN FROMTOTEST (IV FROM TO BY BYVAR TOVAR) (LET ((BYVAL (SYMBOL-VALUE BY))) (IF (CONSTANTP BYVAL) (IF (AND (NUMBERP FROM) (NUMBERP TO) (< TO FROM) (= BYVAL 1)) (PROGN (IL:* IL:\;  "BY was probably a default +1 so silently force to -1 before the incrementer gets expanded") (SET BY -1) `(IF (< ,IV ,TO) (GO $$OUT))) `(IF (,(IF (MINUSP BYVAL) '< '>) ,IV ,(IF (CONSTANTP TO) TO TOVAR)) (GO $$OUT))) `(IF (AND ,BYVAR (OR (= 0 ,BYVAR) (IF (MINUSP ,BYVAR) (< ,IV ,(IF (CONSTANTP TO) TO TOVAR)) (> ,IV ,(IF (CONSTANTP TO) TO TOVAR))))) (GO $$OUT))))) (DEFUN ISOPRP (X) (IF (SYMBOLP X) (GET (INTERN (STRING-UPCASE X) "USER") 'FORWORD))) (DEFUN SDC-FOR (X) (DECLARE (SPECIAL X)) (PROG (VARLIST IV IV1 IOV INITS EACHS PRETESTS BODYS POSTTESTS UPDATES FINALS OP (INCCNT 0) $$INC0 $$INC1 $$INC2 $$INC3 $$INC4 $$INC5 $$INC6 $$INCVAR0 $$INCVAR1 $$INCVAR2 $$INCVAR3 $$INCVAR4 $$INCVAR5 $$INCVAR6 $$INIT0 $$INIT1 $$INIT2 $$INIT3 $$INIT4 $$INIT5 $$INIT6 $$END0 $$END1 $$END2 $$END3 $$END4 $$END5 $$END6) (DECLARE (SPECIAL VARLIST IV IV1 IOV INITS EACHS PRETESTS BODYS POSTTESTS UPDATES FINALS INCCNT $$INC0 $$INC1 $$INC2 $$INC3 $$INC4 $$INC5 $$INC6 $$INCVAR0 $$INCVAR1 $$INCVAR2 $$INCVAR3 $$INCVAR4 $$INCVAR5 $$INCVAR6 $$INIT0 $$INIT1 $$INIT2 $$INIT3 $$INIT4 $$INIT5 $$INIT6 $$END0 $$END1 $$END2 $$END3 $$END4 $$END5 $$END6)) (PUSH '$$VAL VARLIST) (COND ((CONSP (CAR X)) (COND ((CONSP (CAAR X)) (IL:* IL:\;  "(FOR ((VAR \"...\") \"...\") \"...\")") (SETQ IOV (SETQ IV1 (SETQ IV (CAAAR X))))) (T (IL:* IL:\;  "(FOR (VAR \"...\") \"...\")") (SETQ IV1 (SETQ IV (CAAR X))))) (SETQ VARLIST (NCONC (REVERSE (CAR X)) VARLIST)) (SETQ X (CDR X))) ((AND (SYMBOLP (CAR X)) (NOT (ISOPRP (CAR X)))) (IL:* IL:\; "(FOR VAR \"...\")") (SETQ IOV (SETQ IV1 (SETQ IV (CAR X)))) (PUSH (LIST (CAR X) 1) VARLIST) (SETQ X (CDR X))) (T (IL:* IL:\; "E.G. (FOR DO \"...\")") (SETQ IOV (SETQ IV1 (SETQ IV '$$ITER))) (PUSH '($$ITER 1) VARLIST))) TOP (IF (NULL X) (RETURN `(PROG ,(NREVERSE VARLIST) ,@(EVLIST INITS) $$LP ,@(EVLIST EACHS) ,@(EVLIST PRETESTS) ,@(EVLIST BODYS) $$ITERATE ,@(EVLIST POSTTESTS) ,@(EVLIST UPDATES) (GO $$LP) $$OUT ,@(EVLIST FINALS) (RETURN $$VAL)))) (COND ((SETQ OP (ISOPRP (CAR X))) (EVAL OP) (COND ((AND (CDDR X) (NOT (ISOPRP (CADDR X))) (NOT (EQL 'DO (INTERN (STRING-UPCASE (CAR X)) "USER")))) (PRINT (LIST "Warning, no implicit PROGN in Unisys FOR macro:" X) T))) (SETQ X (CDDR X))) (T (PUSH (LIST 'QUOTE (CAR X)) BODYS) (SETQ X (CDR X)))) (GO TOP))) (DEFMACRO XCL-USER::SELECTC (XCL-USER::SELECTOR &REST XCL-USER::CASES) `(CASE ,XCL-USER::SELECTOR ,@(FOR CASE XCL-USER::ON XCL-USER::CASES XCL-USER::WHILE (CDR CASE) XCL-USER::COLLECT (CONS (EVAL (CAAR CASE)) (CDAR CASE))) (OTHERWISE ,(CAR (LAST XCL-USER::CASES))))) (DEFMACRO TESTFOR (L . BODY) (PROG (X) (SETQ X (SDC-FOR (CONS L BODY))) (TERPRI) (WRITE X :PRETTY T) (TERPRI) (RETURN X))) (IL:PUTPROPS ALWAYS FORWORD (PROGN (PUSH ''(SETQ $$VAL T) INITS) (PUSH (LIST 'QUOTE `(COND ((NULL ,(CADR X)) (SETQ $$VAL NIL) (GO $$OUT)))) BODYS))) (IL:PUTPROPS AS FORWORD (PROGN (INCF INCCNT) (SETQ IOV (SETQ IV (CADR X))) (OR IV1 (SETQ IV1 IV)) (PUSH (LIST IV 1) VARLIST))) (IL:PUTPROPS BIND FORWORD (IF (CONSP (CADR X)) (SETQ VARLIST (APPEND (REVERSE (CADR X)) VARLIST)) (PUSH (CADR X) VARLIST))) (IL:PUTPROPS BY FORWORD (LET ((INCAMT (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT)) "USER"))) (COND ((NUMBERP (CADR X)) (SET INCAMT (CADR X))) (T (SET INCAMT (SUBST IOV IV (CADR X))) (LET ((BYVAR (GENSYM))) (PUSH BYVAR VARLIST) (SET (INTERN (CONCATENATE 'STRING "$$INCVAR" ( PRINC-TO-STRING INCCNT)) "USER") BYVAR)))))) (IL:PUTPROPS COLLECT FORWORD (PROGN (PUSH (LIST 'QUOTE `(SETQ $$VAL (CONS ,(CADR X) $$VAL))) BODYS) (PUSH ''(SETQ $$VAL (NREVERSE $$VAL)) FINALS))) (IL:PUTPROPS COUNT FORWORD (PROGN (PUSH ''(SETQ $$VAL 0) INITS) (PUSH (LIST 'QUOTE `(IF ,(CADR X) (SETQ $$VAL (1+ $$VAL)))) BODYS))) (IL:PUTPROPS DO FORWORD (IF (NULL (ISOPRP (CADR X))) (PUSH (LIST 'QUOTE (CADR X)) BODYS) (SETQ X (CONS 'X X)))) (IL:PUTPROPS EACHTIME FORWORD (PUSH (LIST 'QUOTE (CADR X)) EACHS)) (IL:PUTPROPS FINALLY FORWORD (PUSH (LIST 'QUOTE (CADR X)) FINALS)) (IL:PUTPROPS FIRST FORWORD (PUSH (LIST 'QUOTE (CADR X)) INITS)) (IL:PUTPROPS FROM FORWORD (LET ((INCREM (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT)) "USER"))) (IF (EQL IV (CADR (CADAR INITS))) (RPLACA (CDDR (CADAR INITS)) (CADR X)) (PUSH `'(SETQ ,IV ,(CADR X)) INITS)) (SET (INTERN (CONCATENATE 'STRING "$$INIT" (PRINC-TO-STRING INCCNT)) "USER") (CADR X)) (OR (SYMBOL-VALUE INCREM) (SET INCREM 1)) (OR (EQL IV (CADR (CADDAR UPDATES))) (PUSH `(LIST 'INCF ',IV (IF (CONSTANTP ,INCREM) ,INCREM (LIST 'SETQ ,(INTERN (CONCATENATE 'STRING "$$INCVAR" ( PRINC-TO-STRING INCCNT)) "USER") ,INCREM))) UPDATES)))) (IL:PUTPROPS IN FORWORD (PROG (INCEXPR) (SETQ IOV (GENSYM)) (SETQ INCEXPR (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT)) "USER")) (SET INCEXPR (LIST 'CDR IOV)) (PUSH (LIST IOV (CADR X)) VARLIST) (PUSH (LIST 'QUOTE `(IF (NOT ,IOV) (GO $$OUT) (SETQ ,IV (CAR ,IOV)))) EACHS) (PUSH `(LIST 'SETQ ,(LIST 'QUOTE IOV) ,INCEXPR) UPDATES))) (IL:PUTPROPS INSIDE FORWORD (PROGN (SETQ IOV (GENSYM)) (PUSH (LIST IOV (CADR X)) VARLIST) (PUSH (LIST 'QUOTE `(COND ((NULL ,IOV) (GO $$OUT)) ((NOT (CONSP ,IOV)) (SETQ ,IV ,IOV) (SETQ ,IOV NIL)) (T (SETQ ,IV (CAR ,IOV)) (SETQ ,IOV (CDR ,IOV))))) EACHS))) (IL:PUTPROPS JOIN FORWORD (PROGN (PUSH (LIST 'QUOTE `(SETQ $$VAL (NCONC (NREVERSE ,(CADR X)) $$VAL))) BODYS) (PUSH ''(SETQ $$VAL (NREVERSE $$VAL)) FINALS))) (IL:PUTPROPS LARGEST FORWORD (PROGN (PUSH '$$EXTREME VARLIST) (PUSH (LIST 'QUOTE `(COND ((OR (NULL $$EXTREME) (> ,(CADR X) $$EXTREME)) (SETQ $$EXTREME ,(CADR X)) (SETQ $$VAL ,IV)))) BODYS))) (IL:PUTPROPS MAX FORWORD (PUSH (LIST 'QUOTE `(IF (NULL $$VAL) (SETQ $$VAL ,(CADR X)) (SETQ $$VAL (MAX $$VAL ,(CADR X))))) BODYS)) (IL:PUTPROPS MIN FORWORD (PUSH (LIST 'QUOTE `(IF (NULL $$VAL) (SETQ $$VAL ,(CADR X)) (SETQ $$VAL (MIN $$VAL ,(CADR X))))) BODYS)) (IL:PUTPROPS NEVER FORWORD (PROGN (PUSH ''(SETQ $$VAL T) INITS) (PUSH (LIST 'QUOTE `(COND (,(CADR X) (SETQ $$VAL NIL) (GO $$OUT)))) BODYS))) (IL:PUTPROPS ON FORWORD (PROG (INCEXPR) (SETQ INCEXPR (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING (INCF INCCNT))) "USER")) (SET INCEXPR (LIST 'CDR IOV)) (COND ((EQL IV (CAAR VARLIST)) (RPLACA (CDAR VARLIST) (CADR X))) (T (PUSH (LIST 'QUOTE `(SETQ ,IV ,(CADR X))) INITS))) (PUSH `(LIST 'SETQ ,(LIST 'QUOTE IV) ,INCEXPR) UPDATES) (PUSH (LIST 'QUOTE `(IF (NOT ,IV) (GO $$OUT))) PRETESTS))) (IL:PUTPROPS REPEATWHILE FORWORD (PUSH (LIST 'QUOTE `(IF (NOT ,(CADR X)) (GO $$OUT))) POSTTESTS)) (IL:PUTPROPS REPEATUNTIL FORWORD (IF (NUMBERP (CADR X)) (PUSH (LIST 'QUOTE `(IF (> ,IV ,(CADR X)) (GO $$OUT))) POSTTESTS) (PUSH (LIST 'QUOTE `(IF ,(CADR X) (GO $$OUT))) POSTTESTS))) (IL:PUTPROPS SMALLEST FORWORD (PROGN (PUSH '$$EXTREME VARLIST) (PUSH (LIST 'QUOTE `(COND ((OR (NULL $$EXTREME) (< ,(CADR X) $$EXTREME)) (SETQ $$EXTREME ,(CADR X)) (SETQ $$VAL ,IV)))) BODYS))) (IL:PUTPROPS SUM FORWORD (PROGN (PUSH ''(SETQ $$VAL 0) INITS) (PUSH (LIST 'QUOTE `(SETQ $$VAL (+ ,(CADR X) $$VAL))) BODYS))) (IL:PUTPROPS TO FORWORD (LET (LIMIT (INITAMT (INTERN (CONCATENATE 'STRING "$$INIT" (PRINC-TO-STRING INCCNT)) "USER")) (INCREM (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT)) "USER")) (BYVAR (INTERN (CONCATENATE 'STRING "$$INCVAR" (PRINC-TO-STRING INCCNT)) "USER")) (END (INTERN (CONCATENATE 'STRING "$$END" (PRINC-TO-STRING INCCNT )) "USER"))) (OR (EQL IV (CADR (CADAR INITS))) (PUSH `'(SETQ ,IV 1) INITS)) (OR (SYMBOL-VALUE INCREM) (SET INCREM 1)) (OR (CONSTANTP (CADR X)) (PUSH (LIST (SETQ LIMIT (GENSYM)) (CADR X)) VARLIST)) (OR (SYMBOL-VALUE INITAMT) (SET INITAMT 1)) (OR (EQL IV (CADR (CADDAR UPDATES))) (PUSH `(LIST 'INCF ',IV (IF (CONSTANTP ,INCREM) ,INCREM (LIST 'SETQ ,BYVAR ,INCREM))) UPDATES)) (SET END (CADR X)) (PUSH (LIST 'FROMTOTEST `',IV INITAMT END `',INCREM BYVAR `',LIMIT) PRETESTS))) (IL:PUTPROPS THEREIS FORWORD (PROGN (PUSH (LIST 'QUOTE `(COND (,(CADR X) (SETQ $$VAL (OR ,IV1 T)) (GO $$OUT)))) BODYS))) (IL:PUTPROPS UNION FORWORD (PUSH (LIST 'QUOTE `(SETQ $$VAL (UNION ,(CADR X) $$VAL))) BODYS)) (IL:PUTPROPS UNLESS FORWORD (PUSH (LIST 'QUOTE `(IF ,(CADR X) (GO $$ITERATE))) PRETESTS)) (IL:PUTPROPS UNTIL FORWORD (IF (NUMBERP (CADR X)) (PUSH (LIST 'QUOTE `(IF (> ,IV ,(CADR X)) (GO $$OUT))) PRETESTS) (PUSH (LIST 'QUOTE `(IF ,(CADR X) (GO $$OUT))) PRETESTS))) (IL:PUTPROPS WHEN FORWORD (PUSH (LIST 'QUOTE `(IF (NOT ,(CADR X)) (GO $$ITERATE))) PRETESTS)) (IL:PUTPROPS WHILE FORWORD (PUSH (LIST 'QUOTE `(IF (NOT ,(CADR X)) (GO $$OUT))) PRETESTS)) (IL:PUTPROPS IL:FORMACRO IL:MAKEFILE-ENVIRONMENT (:PACKAGE "USER" :READTABLE "XCL")) (IL:DECLARE\: IL:DONTCOPY (IL:ADDTOVAR IL:EDITHISTALIST ) ) (IL:PUTPROPS IL:FORMACRO IL:COPYRIGHT ("System Development Corp." 1987)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/FTPSERVER-MULTI-CONNECTIONS.TEDIT b/lispusers/FTPSERVER-MULTI-CONNECTIONS.TEDIT new file mode 100644 index 00000000..b7c3dfd8 Binary files /dev/null and b/lispusers/FTPSERVER-MULTI-CONNECTIONS.TEDIT differ diff --git a/lispusers/FTPSERVERPATCH b/lispusers/FTPSERVERPATCH new file mode 100644 index 00000000..9abf9875 --- /dev/null +++ b/lispusers/FTPSERVERPATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 9-Sep-88 19:06:08" {DSK}MEDLEY-SOURCES>FTPSERVERPATCH.;4 18581 changes to%: (FNS \SFTP.OPENFILE.FROM.PLIST) (MACROS .IFDESIRED.) previous date%: " 7-Sep-88 16:59:13" {DSK}MEDLEY-SOURCES>FTPSERVERPATCH.;2) (* " Copyright (c) 1987, 1988 by Matt Heffron & XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT FTPSERVERPATCHCOMS) (RPAQQ FTPSERVERPATCHCOMS ((DECLARE%: DOCOPY FIRST (FILES FTPSERVER)) (FNS FTPSERVER NEGOTIATED-FTPSERVER \FTPSERVER.TOP \NEGOTIATED-FTPSERVER.TOP \SFTP.COMMANDLOOP \SFTP.OPENFILE.FROM.PLIST \SFTP.PLIST.FROM.FILE \SFTP.WHENCLOSED) (CONSTANTS (\PUPSOCKET.NEGOTIATED.CONNECTION 63)) (DECLARE%: DONTCOPY (MACROS .IFDESIRED.) (FILES (LOADCOMP) DPUPFTP BSP)) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) FTPSERVERPATCH))) (DECLARE%: DOCOPY FIRST (FILESLOAD FTPSERVER) ) (DEFINEQ (FTPSERVER [LAMBDA (FTPDEBUG) (* ; "Edited 24-Jul-87 12:36 by Matt Heffron") (* ;; "Start the process that listens for the requests for Negotiated sockets") (ADD.PROCESS (LIST (FUNCTION \FTPSERVER.TOP) (KWOTE FTPDEBUG)) 'NAME 'FTPSERVER 'RESTARTABLE 'HARDRESET) (* ;; "Then start a FTP server on the STANDARD socket.") (NEGOTIATED-FTPSERVER \PUPSOCKET.FTP]) (NEGOTIATED-FTPSERVER [LAMBDA (SOCKET#) (* ; "Edited 22-Jul-87 11:56 by Matt Heffron") (if (NOT (FIXP SOCKET#)) then (SETQ SOCKET# \PUPSOCKET.FTP)) (ADD.PROCESS (LIST (FUNCTION \NEGOTIATED-FTPSERVER.TOP) SOCKET#) 'NAME 'NEGOTIATED-FTPSERVER 'RESTARTABLE 'HARDRESET]) (\FTPSERVER.TOP [LAMBDA (FTPDEBUG) (DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 22-Jul-87 11:55 by Matt Heffron") (LET (SOCKET PUP NEWFTPSOCKET) (COND (FTPDEBUG [COND ((OR (EQ FTPDEBUG T) (LISTP FTPDEBUG)) (SETQ FTPDEBUGLOG (GETSTREAM (CREATEW (LISTP FTPDEBUG) "FTP Server traffic") 'OUTPUT)) (WINDOWPROP FTPDEBUGLOG 'PAGEFULLFN (FUNCTION NILL)) (DSPSCROLL 'ON FTPDEBUGLOG) (DSPFONT '(GACHA 8) FTPDEBUGLOG)) (T (SETQ FTPDEBUGLOG (GETSTREAM FTPDEBUG 'OUTPUT] (printout FTPDEBUGLOG "FTP Server started at " (DATE) T T) (RESETSAVE FTPDEBUGFLG T))) (SETQ SOCKET (OPENPUPSOCKET \PUPSOCKET.NEGOTIATED.CONNECTION 'ACCEPT)) (do (SETQ PUP (GETPUP SOCKET T)) (SWAPPUPPORTS PUP) (SETQ NEWFTPSOCKET (PUPSOCKETNUMBER (OPENPUPSOCKET))) (NEGOTIATED-FTPSERVER NEWFTPSOCKET) (replace PUPSOURCESOCKET of PUP with NEWFTPSOCKET) (SENDPUP SOCKET PUP]) (\NEGOTIATED-FTPSERVER.TOP [LAMBDA (SOCKET#) (DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 22-Jul-87 13:19 by Matt Heffron") (LET (SOCKET INSTREAM EVENT SAVER) (if FTPDEBUGLOG then (printout FTPDEBUGLOG "Negotiated FTP Server started at " (DATE) " on Socket #" (OCTALSTRING SOCKET#) T T)) (RESETSAVE NIL (SETQ SAVER (LIST [FUNCTION (LAMBDA (SOC) (AND SOC (CLOSERTPSOCKET SOC 0] NIL))) (do (SETQ SOCKET (OPENRTPSOCKET NIL '(SERVER RETURN) (OPENPUPSOCKET SOCKET# T) NIL)) (RPLACA (CDR SAVER) SOCKET) (SETQ EVENT (fetch RTPEVENT of SOCKET)) (until (EQ (fetch RTPSTATE of SOCKET) \STATE.OPEN) do (AWAIT.EVENT EVENT)) [COND ((SETQ INSTREAM (CREATEBSPSTREAM SOCKET NIL (FUNCTION \SFTP.ERRORHANDLER) (IMIN \FTP.IDLE.TIMEOUT MAX.SMALLP) (FUNCTION \SFTP.TIMEOUTFN) (FUNCTION \SFTP.WHENCLOSED))) (if FTPDEBUGLOG then (PUTSTREAMPROP INSTREAM 'FTP.DEBUG.PREFIX (CONCAT "[" (OCTALSTRING SOCKET#) "] "))) (if (NEQ SOCKET# \PUPSOCKET.FTP) then (PUTSTREAMPROP INSTREAM 'FTP.SERVER.PROCESS (THIS.PROCESS))) (NLSETQ (RESETLST [RESETSAVE NIL (if (EQ SOCKET# \PUPSOCKET.FTP) then `(CLOSEBSPSTREAM ,INSTREAM 0) else `(PROGN (CLOSEBSPSTREAM ,INSTREAM 0) (DEL.PROCESS ,(THIS.PROCESS] (* ;; "(RPLACA (CDR SAVER) NIL)") (if FTPDEBUGLOG then (printout FTPDEBUGLOG T "[" (OCTALSTRING SOCKET#) "] Connection open with " (PORTSTRING (fetch FRNPORT of SOCKET) (\MAKENUMBER (fetch FRNSOCKETHI of SOCKET) (fetch FRNSOCKETLO of SOCKET))) T)) (\SFTP.COMMANDLOOP INSTREAM (BSPOUTPUTSTREAM INSTREAM] repeatwhile (EQ SOCKET# \PUPSOCKET.FTP]) (\SFTP.COMMANDLOOP [LAMBDA (INS OUTS) (DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 7-Sep-88 16:50 by Matt Heffron") (LET ((*UPPER-CASE-FILE-NAMES* NIL) MARK) (DECLARE (SPECVARS *UPPER-CASE-FILE-NAMES*)) (* ;  "We certainly don't need anything to be upper-case symbols.") (repeatwhile (SELECTC (SETQ MARK (FTPGETMARK INS)) ((MARK# VERSION) (\SFTP.VERSION INS OUTS)) ((MARK# RETRIEVE) (\SFTP.RETRIEVE INS OUTS)) ((MARK# NEW-STORE) (\SFTP.STORE INS OUTS)) ((MARK# STORE) (\SFTP.STORE INS OUTS T)) ((MARK# NEW-ENUMERATE) (\SFTP.ENUMERATE INS OUTS T)) ((MARK# ENUMERATE) (\SFTP.ENUMERATE INS OUTS)) ((MARK# DELETE) (\SFTP.DELETE INS OUTS)) ((MARK# EOC) T) ((MARK# COMMENT) (OR (\FTP.FLUSH.TO.EOC INS FTPDEBUGLOG) (\SFTP.PROTOCOL.ERROR INS OUTS))) ((LIST (MARK# YES) (MARK# NO) (MARK# HERE-IS-PLIST) (MARK# HERE-IS-FILE)) (\SFTP.PROTOCOL.ERROR INS OUTS)) (0 (* ; "timed out") NIL) (PROGN (FTPPUTMARK OUTS (MARK# NO)) (FTPPUTCODE OUTS \NO.UNIMPLEMENTED) (PRIN3 "Unimplemented command " OUTS) (PRIN3 (MKSTRING MARK) OUTS) (.EOC. OUTS) T]) (\SFTP.OPENFILE.FROM.PLIST [LAMBDA (PLIST ACCESS OUTS DESIREDPROPS RECOG) (* ; "Edited 9-Sep-88 19:04 by Matt Heffron") (* ;  "Opens file from user's PLIST, or answers NO and returns NIL") (LET (FILENAME PIECES MYPLIST VALUE HIGHESTVERSIONP) (for PAIR in PLIST do (SETQ VALUE (CADR PAIR)) (SELECTQ (CAR PAIR) (SERVER-FILENAME (SETQ PIECES (UNPACKFILENAME.STRING VALUE))) ((DEVICE DIRECTORY VERSION) (push PIECES (CAR PAIR) VALUE)) (NAME-BODY (push PIECES 'BODY VALUE)) (TYPE [push MYPLIST (LIST 'TYPE (MKATOM (U-CASE VALUE]) ((CREATION-DATE CREATIONDATE) (push MYPLIST (LIST 'CREATIONDATE VALUE))) ((END-OF-LINE-CONVENTION EOLCONVENTION EOC) [push MYPLIST (LIST 'EOLCONVENTION (MKATOM (U-CASE VALUE]) (SIZE (push MYPLIST (LIST 'LENGTH (MKATOM VALUE)))) NIL)) (for TAIL on PIECES by (CDDR TAIL) do (* ;  "Process some parts. Done here rather than above so that SERVER-FILENAME works easily.") (SELECTQ (CAR TAIL) (DEVICE (* ; "Fake host") (RPLACA TAIL 'HOST) [COND ((EQ (NTHCHARCODE (CADR TAIL) -1) (CHARCODE %:)) (* ;  "Device specified with trailing colon--strip it") (RPLACA (CDR TAIL) (SUBSTRING (CADR TAIL) 1 -2]) (VERSION [if (if (STRING.EQUAL (SETQ VALUE (CADR TAIL)) "H") then (SETQ RECOG 'OLD) (SETQ HIGHESTVERSIONP T) elseif (STRING.EQUAL VALUE "L") then (SETQ RECOG 'OLDEST)) then (* ; "Remove VERSION attribute.") (if (EQ TAIL PIECES) then (SETQ PIECES (CDDR TAIL)) else (RPLACD (NLEFT PIECES 1 TAIL) (CDDR TAIL]) NIL)) [SETQ FILENAME (PACKFILENAME.STRING `(,.PIECES HOST ,FTPSERVER.DEFAULT.HOST ,@(if (EQ ACCESS 'ENUMERATE) then (* ;  "Need to default extension to * before possibly packing on a version.") '(EXTENSION *] (CL:MULTIPLE-VALUE-BIND (RESULT C) [IGNORE-ERRORS (SELECTQ ACCESS (ENUMERATE (SETQ FILENAME (DIRECTORY.FILL.PATTERN FILENAME NIL (if HIGHESTVERSIONP then "" else "*"))) [CONS FILENAME (\GENERATEFILES FILENAME DESIREDPROPS '(RESETLST SORT)]) (DELETE (FULLNAME FILENAME RECOG)) (OPENSTREAM FILENAME ACCESS RECOG NIL (CONS '(SEQUENTIAL T) MYPLIST] (COND (RESULT) (T (* ; "On failure, write error value and return NIL. C could be NIL if FULLNAME didn't find the file, in which case the error will be FILE NOT FOUND.") (\SFTP.MARK.ERROR OUTS C) (.EOC. OUTS) NIL]) (\SFTP.PLIST.FROM.FILE [LAMBDA (FILE NEW DESIREDPROPS FILEOPENP GENERATOR) (* ; "Edited 7-Sep-88 16:40 by Matt Heffron") (* ;; "Generates a PLIST from FILE. NEW is true if file is being written anew DESIREDPROPS may restrict what we send") (PROG ([PIECES (UNPACKFILENAME.STRING (COND ((type? STREAM FILE) (FULLNAME FILE)) (T FILE] INFOFN INFOHANDLE HOST DIR NAME EXT VERSION AUTHOR TYPE PLIST) (COND (GENERATOR (SETQ INFOFN (FUNCTION \GENERATEFILEINFO)) (SETQ INFOHANDLE GENERATOR)) (T (SETQ INFOFN (FUNCTION GETFILEINFO)) (SETQ INFOHANDLE FILE))) (for TAIL on PIECES by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST [COND ((STRING-EQUAL (CADR TAIL) FTPSERVER.DEFAULT.HOST) (RPLACA (CDR TAIL))) (T (SETQ HOST (CADR TAIL]) (DIRECTORY (SETQ DIR (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXT (CADR TAIL))) (VERSION (SETQ VERSION (CADR TAIL))) NIL)) [SETQ PLIST (NCONC (.IFDESIRED. SERVER-FILENAME (PACKFILENAME.STRING PIECES)) (.IFDESIRED. NAME-BODY (COND (EXT (CONCAT NAME "." EXT)) (T NAME))) (.IFDESIRED. VERSION VERSION) (.IFDESIRED. END-OF-LINE-CONVENTION 'CR) (AND DIR (.IFDESIRED. DIRECTORY DIR)) (AND HOST (.IFDESIRED. DEVICE HOST] [COND ((NOT NEW) (SETQ PLIST (NCONC PLIST [.IFDESIRED. TYPE (SETQ TYPE (OR (CL:FUNCALL INFOFN INFOHANDLE 'TYPE) (\GETFILETYPE FILE FILEOPENP] (AND (EQ TYPE 'BINARY) (LIST (LIST 'BYTE-SIZE 8))) (.IFDESIRED. CREATION-DATE (CL:FUNCALL INFOFN INFOHANDLE 'CREATIONDATE)) (.IFDESIRED. WRITE-DATE (CL:FUNCALL INFOFN INFOHANDLE 'WRITEDATE)) (.IFDESIRED. READ-DATE (CL:FUNCALL INFOFN INFOHANDLE 'READDATE)) (.IFDESIRED. SIZE (CL:FUNCALL INFOFN INFOHANDLE 'LENGTH)) (.IFDESIRED. AUTHOR (CL:FUNCALL INFOFN INFOHANDLE 'AUTHOR] (RETURN PLIST]) (\SFTP.WHENCLOSED [LAMBDA (STREAM) (DECLARE (SPECVARS FTPDEBUGLOG)) (* ; "Edited 7-Sep-88 16:51 by Matt Heffron") (LET [(SERVERPROC (GETSTREAMPROP STREAM 'FTP.SERVER.PROCESS] (if FTPDEBUGLOG then (printout FTPDEBUGLOG T (GETSTREAMPROP STREAM 'FTP.DEBUG.PREFIX) "Connection closed" T)) (if SERVERPROC then (* ; "Was: (DEL.PROCESS SERVERPROC)") (PROCESS.EVAL SERVERPROC '(ERROR!]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPSOCKET.NEGOTIATED.CONNECTION 63) (CONSTANTS (\PUPSOCKET.NEGOTIATED.CONNECTION 63)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS .IFDESIRED. MACRO ((PROP . LISTFORM) (AND (OR (NULL DESIREDPROPS) (FMEMB 'PROP DESIREDPROPS)) (PROG ((PROPVAL . LISTFORM)) (RETURN (AND PROPVAL (LIST (LIST 'PROP PROPVAL] ) (FILESLOAD (LOADCOMP) DPUPFTP BSP) ) (PUTPROPS FTPSERVERPATCH FILETYPE :TCOMPL) (PUTPROPS FTPSERVERPATCH MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS FTPSERVERPATCH COPYRIGHT ("Matt Heffron & XEROX Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1262 17784 (FTPSERVER 1272 . 1807) (NEGOTIATED-FTPSERVER 1809 . 2215) (\FTPSERVER.TOP 2217 . 3577) (\NEGOTIATED-FTPSERVER.TOP 3579 . 6442) (\SFTP.COMMANDLOOP 6444 . 8761) ( \SFTP.OPENFILE.FROM.PLIST 8763 . 14134) (\SFTP.PLIST.FROM.FILE 14136 . 17215) (\SFTP.WHENCLOSED 17217 . 17782))))) STOP \ No newline at end of file diff --git a/lispusers/FileCacheMsgWindow b/lispusers/FileCacheMsgWindow new file mode 100644 index 00000000..a8f03f3d --- /dev/null +++ b/lispusers/FileCacheMsgWindow @@ -0,0 +1 @@ +(FILECREATED " 2-May-86 18:58:43" {PHYLUM}FILECACHE>FILECACHEMSGWINDOW.;5 5430 changes to: (VARS FILECACHEMSGWINDOWCOMS) previous date: " 5-Mar-86 12:54:06" {PHYLUM}FILECACHE>FILECACHEMSGWINDOW.;4) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT FILECACHEMSGWINDOWCOMS) (RPAQQ FILECACHEMSGWINDOWCOMS ((* * Give the FileCacher a seperate window and Icon) (FILES FILECACHE (FROM LISPUSERS) ICONW) (BITMAPS FileCacheMessageIcon FileCacheMessageIconMask) [INITVARS (FILE-CACHE-MESSAGE-STREAM-REGION (with REGION (WINDOWPROP PROMPTWINDOW (QUOTE REGION)) (CREATEREGION (PLUS LEFT WIDTH) BOTTOM WIDTH HEIGHT))) (FILE-CACHE-MESSAGE-STREAM-ICON-POSITION (with REGION FILE-CACHE-MESSAGE-STREAM-REGION (create POSITION XCOORD _ LEFT YCOORD _ (MIN BOTTOM (DIFFERENCE SCREENHEIGHT (BITMAPHEIGHT FileCacheMessageIcon] (VARS (*FILE-CACHE-MESSAGE-STREAM* (CREATEW FILE-CACHE-MESSAGE-STREAM-REGION "FileCache message window" 2))) (P (DSPTEXTURE BLACKSHADE *FILE-CACHE-MESSAGE-STREAM*) (DSPOPERATION (QUOTE INVERT) *FILE-CACHE-MESSAGE-STREAM*) (DSPSCROLL (QUOTE ON) *FILE-CACHE-MESSAGE-STREAM*) (DSPRESET *FILE-CACHE-MESSAGE-STREAM*) (WINDOWPROP *FILE-CACHE-MESSAGE-STREAM* (QUOTE ICON) (TITLEDICONW (create TITLEDICON ICON _ FileCacheMessageIcon MASK _ FileCacheMessageIconMask TITLEREG _ (QUOTE (12 15 40 40))) "File cache msgs" NIL FILE-CACHE-MESSAGE-STREAM-ICON-POSITION T)) (SHRINKW *FILE-CACHE-MESSAGE-STREAM*)))) (* * Give the FileCacher a seperate window and Icon) (FILESLOAD FILECACHE (FROM LISPUSERS) ICONW) (RPAQ FileCacheMessageIcon (READBITMAP)) (62 61 "AOOOOOOOOOOOOON@" "AH@@@@@@@@@@@FA@" "C@@@@@@@@@@@@D@H" "B@@@@@@@@@@@@L@H" "B@@@@@@@@@@@@H@D" "B@@@@@@@@@@@@H@D" "B@@@@@@@@@@@@H@D" "B@@@@@@@@@@@@D@H" "C@@@@@@@@@@@@DDH" "A@@@@@@@@@@@@CG@" "AH@@@@@@@@@@@@H@" "@H@@@@@@@@@@@@H@" "@H@@@@@@@@@@@@D@" "@L@@@@@@@@@@@@D@" "@L@@@@@@@@@@@@D@" "@D@@@@@@@@@@@@D@" "@F@@@@@@@@@@@@D@" "@B@@@@@@@@@@@@D@" "@B@@@@@@@@@@@@D@" "@C@@@@@@@@@@@@D@" "@C@@@@@@@@@@@@D@" "@A@@@@@@@@@@@@D@" "@A@@@@@@@@@@@@D@" "@A@@@@@@@@@@@@D@" "@AH@@@@@@@@@@@F@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@H@@@@@@@@@@@B@" "@@L@@@@@@@@@@@C@" "@@L@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@D@@@@@@@@@@@A@" "@@L@@@@@@@@@@@A@" "@@H@@@@@@@@@@@A@" "@@H@@@@@@@@@@@A@" "@@H@@@@@@@@@@@A@" "@OOOOOOOOOOOO@A@" "AH@@@@@@@@@@GLA@" "F@@@@@@@@@@@LFA@" "D@@@@@@@@@@AHBC@" "L@@@@@@@@@@A@FB@" "H@@@@@@@@@@A@LF@" "H@@@@@@@@@@AOHD@" "H@@@@@@@@@@AH@D@" "L@@@@@@@@@@@H@H@" "L@@@@@@@@@@@LA@@" "N@@@@@@@@@@@GF@@" "CH@@@@@@@@@@AL@@" "@OOOOOOOOOOOOH@@") (RPAQ FileCacheMessageIconMask (READBITMAP)) (62 61 "AOOOOOOOOOOOOON@" "AOOOOOOOOOOOOOO@" "COOOOOOOOOOOOOOH" "COOOOOOOOOOOOOOH" "COOOOOOOOOOOOOOL" "COOOOOOOOOOOOOOL" "COOOOOOOOOOOOOOL" "COOOOOOOOOOOOOOH" "COOOOOOOOOOOOOOH" "AOOOOOOOOOOOOOO@" "AOOOOOOOOOOOOOH@" "@OOOOOOOOOOOOOH@" "@OOOOOOOOOOOOOL@" "@OOOOOOOOOOOOOL@" "@OOOOOOOOOOOOOL@" "@GOOOOOOOOOOOOL@" "@GOOOOOOOOOOOOL@" "@COOOOOOOOOOOOL@" "@COOOOOOOOOOOOL@" "@COOOOOOOOOOOOL@" "@COOOOOOOOOOOOL@" "@AOOOOOOOOOOOOL@" "@AOOOOOOOOOOOOL@" "@AOOOOOOOOOOOOL@" "@AOOOOOOOOOOOON@" "@AOOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOON@" "@@OOOOOOOOOOOOO@" "@@OOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@GOOOOOOOOOOOO@" "@@OOOOOOOOOOOOO@" "@@OOOOOOOOOOOOO@" "@@OOOOOOOOOOOOO@" "@@OOOOOOOOOOOOO@" "@OOOOOOOOOOOOOO@" "AOOOOOOOOOOOOOO@" "GOOOOOOOOOOOOOO@" "GOOOOOOOOOOOOOO@" "OOOOOOOOOOOOOON@" "OOOOOOOOOOOOOON@" "OOOOOOOOOOOOOOL@" "OOOOOOOOOOOOOOL@" "OOOOOOOOOOOOOOH@" "OOOOOOOOOOOOOO@@" "OOOOOOOOOOOOON@@" "COOOOOOOOOOOOL@@" "@OOOOOOOOOOOOH@@") (RPAQ? FILE-CACHE-MESSAGE-STREAM-REGION (with REGION (WINDOWPROP PROMPTWINDOW (QUOTE REGION)) (CREATEREGION (PLUS LEFT WIDTH) BOTTOM WIDTH HEIGHT))) (RPAQ? FILE-CACHE-MESSAGE-STREAM-ICON-POSITION [with REGION FILE-CACHE-MESSAGE-STREAM-REGION (create POSITION XCOORD _ LEFT YCOORD _ (MIN BOTTOM (DIFFERENCE SCREENHEIGHT (BITMAPHEIGHT FileCacheMessageIcon]) (RPAQ *FILE-CACHE-MESSAGE-STREAM* (CREATEW FILE-CACHE-MESSAGE-STREAM-REGION "FileCache message window" 2)) (DSPTEXTURE BLACKSHADE *FILE-CACHE-MESSAGE-STREAM*) (DSPOPERATION (QUOTE INVERT) *FILE-CACHE-MESSAGE-STREAM*) (DSPSCROLL (QUOTE ON) *FILE-CACHE-MESSAGE-STREAM*) (DSPRESET *FILE-CACHE-MESSAGE-STREAM*) (WINDOWPROP *FILE-CACHE-MESSAGE-STREAM* (QUOTE ICON) (TITLEDICONW (create TITLEDICON ICON _ FileCacheMessageIcon MASK _ FileCacheMessageIconMask TITLEREG _ (QUOTE (12 15 40 40))) "File cache msgs" NIL FILE-CACHE-MESSAGE-STREAM-ICON-POSITION T)) (SHRINKW *FILE-CACHE-MESSAGE-STREAM*) (PUTPROPS FILECACHEMSGWINDOW COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.LC1-SF b/lispusers/GACHAE.LC1-SF new file mode 100644 index 00000000..79c03e55 --- /dev/null +++ b/lispusers/GACHAE.LC1-SF @@ -0,0 +1 @@ + ((FAMILY gacha) (CHARACTER 141Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:22:31) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((93 182) (93 182) (143 182)) NIL ((-12.5 0 0 0 75. 0 ) (25. 0 75. 0 -75. 0 )) NATURAL) (19 ((143 182) (147 197) (170 215) (225 221) (290 213) (309 194) (287 165) (191 156) (122 142) (100 128) (85 110) (75 78) (81 46) (96 25) (118 9) (153 -4) (199 -8) (247 -2) (313 14)) NIL ((0.804730058 13.568931 0 0 19.171619 8.5864067 ) (10.390539 17.862133 19.171619 8.5864067 18.1419029 -24.932033 ) (38.63311 13.9825229 37.313522 -16.3456268 -13.7392387 1.14173698 ) (69.07701 -1.79223466 23.574283 -15.2038898 -95.184936 8.36507798 ) (45.058822 -12.813585 -71.610656 -6.83881188 58.47901 -16.602043 ) (2.68767023 -27.953422 -13.131645 -23.440856 -108.73107 64.043106 ) (-64.809524 -19.372722 -121.8627 40.602249 178.4453 -59.570404 ) (-97.44955 -8.5556755 56.58264 -18.968154 0.949485779 24.238521 ) (-40.39218 -15.404567 57.532127 5.27036858 -62.243286 -7.38368893 ) (-13.981699 -13.826044 -4.7111616 -2.11332083 8.02367784 -18.703762 ) (-14.6810188 -25.291248 3.31251764 -20.817085 18.148567 22.19876 ) (-2.29421711 -35.008949 21.461086 1.38167786 -14.617956 13.908697 ) (11.857891 -26.672924 6.8431301 15.290376 -1.67673778 -11.8335666 ) (17.862651 -17.299331 5.16639233 3.45680857 9.3249073 -2.57442284 ) (27.691497 -15.1297359 14.4913 0.882385612 0.377099991 10.1312599 ) (42.371345 -9.1817188 14.8684 11.013647 -22.833305 -1.95062256 ) (45.823097 0.856617928 -7.9649067 9.0630245 36.956123 3.67121887 ) (56.336258 11.7552509 28.991222 12.734243 -28.991222 -12.734243 )) NATURAL) (5 ((313 14) (329 6) (358 -1) (378 0) (397 2)) NIL ((11.8928566 -7.7142849 0 0 24.642856 -1.71428537 ) (24.214283 -8.5714283 24.642856 -1.71428537 -45.214279 14.571426 ) (26.249996 -2.99999952 -20.571426 12.857141 24.214283 -14.571426 ) (17.785713 2.5714283 3.6428566 -1.71428561 -3.6428566 1.71428561 )) NATURAL) (2 ((397 2) (397 36)) NIL ((0 34. 0 0 0 0 )) NATURAL) (4 ((397 36) (378 36) (361 41) (355 51)) NIL ((-18.799999 -1. 0 0 -1.19999981 6. ) (-19.399997 2. -1.19999981 6. 17.999996 0 ) (-11.599998 8. 16.799999 6. -16.799999 -6. )) NATURAL) (2 ((355 51) (355 185)) NIL ((0 134. 0 0 0 0 )) NATURAL) (6 ((355 185) (348 212) (328 232) (304 245) (271 252) (229 256)) NIL ((-3.67464113 28.473682 0 0 -19.952152 -8.84210397 ) (-13.6507168 24.052627 -19.952152 -8.84210397 21.760761 2.21052551 ) (-22.722484 16.315788 1.80861187 -6.63157845 -13.090906 0 ) (-27.459327 9.6842098 -11.282295 -6.63157845 0.602870941 3.78947353 ) (-38.440185 4.94736767 -10.679424 -2.84210491 10.679424 2.84210491 )) NATURAL) (6 ((229 256) (177 253) (135 241) (115 228) (99 209) (93 182)) NIL ((-53.12918 -0.583732248 0 0 6.77511979 -14.497606 ) (-49.741623 -7.83253575 6.77511979 -14.497606 26.1244 18.488033 ) (-29.904304 -13.086122 32.89952 3.99043036 -39.27272 -11.454544 ) (-16.641147 -14.822965 -6.37320519 -7.46411515 22.966503 -2.66985512 ) (-11.531099 -23.622009 16.5932998 -10.13397 -16.5932998 10.13397 )) NATURAL)) ((11 ((308 127) (235 123) (180 115) (142 101) (127 74) (139 46) (174 32) (223 30) (290 45) (308 80) (308 127)) NIL ((-76.935379 -3.13017798 0 0 23.612281 -5.21893215 ) (-65.129226 -5.73964405 23.612281 -5.21893215 -10.061409 2.09466267 ) (-46.54766 -9.91124536 13.5508728 -3.12426949 10.63335 -15.159719 ) (-27.68011 -20.615371 24.184223 -18.2839889 3.5280075 16.544212 ) (-1.73188519 -30.627254 27.71223 -1.73977589 -0.745380402 20.982864 ) (25.607654 -21.875595 26.96685 19.243091 -24.546482 -10.4756908 ) (40.30126 -7.87034989 2.42036581 8.76740075 44.931312 8.9199009 ) (65.187286 5.35700226 47.351684 17.687301 -131.1788 4.79608155 ) (46.949569 25.442344 -83.827118 22.483383 77.783889 -10.1042308 ) (2.0144062 42.87361 -6.04321957 12.379152 6.04321957 -12.379152 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 142Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:29:14) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((73 337) (73 337) (73 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((73 0) (122 0)) NIL ((49. 0 0 0 0 0 )) NATURAL) (2 ((122 0) (122 19)) NIL ((0 19. 0 0 0 0 )) NATURAL) (19 ((122 19) (145 7) (186 -3) (223 -6) (274 -2) (306 10) (330 24) (346 42) (358 66) (367 124) (358 182) (346 206) (330 224) (306 238) (274 250) (223 254) (186 251) (145 241) (122 229)) NIL ((17.530986 -12.1277828 0 0 32.814079 0.766703606 ) (33.938026 -11.74443 32.814079 0.766703606 -56.070419 8.166481 ) (38.716896 -6.89448739 -23.25634 8.93318559 59.467628 -3.43263149 ) (45.194366 0.322382927 36.211288 5.50055409 -73.800094 5.56404019 ) (44.505607 8.60495759 -37.588813 11.064594 37.732772 -12.823528 ) (25.783184 13.2577877 0.143964797 -1.75893473 -11.131006 9.73007585 ) (20.361644 16.363891 -10.987041 7.97114278 6.79124547 -14.0967788 ) (12.770227 17.286644 -4.195796 -6.12563706 7.96602345 58.657035 ) (12.5574417 40.489532 3.77022743 52.531402 -32.655334 -52.531402 ) (-3.20374965E-7 66.755233 -28.885112 0 32.655334 -52.531402 ) (-12.5574417 40.489524 3.77022743 -52.531402 -7.96602345 58.657035 ) (-12.770227 17.286644 -4.195796 6.12563706 -6.79124547 -14.0967788 ) (-20.361644 16.363891 -10.987041 -7.97114278 11.131006 9.73007585 ) (-25.783184 13.2577858 0.143965035 1.75893426 -37.732772 -12.823528 ) (-44.505607 8.60495568 -37.588813 -11.064594 73.800094 5.56404019 ) (-45.194366 0.322382271 36.211288 -5.50055409 -59.467628 -3.43263149 ) (-38.716896 -6.89448739 -23.25634 -8.93318559 56.070419 8.166481 ) (-33.938026 -11.74443 32.814079 -0.766703487 -32.814079 0.766703487 )) NATURAL) (2 ((122 229) (122 337)) NIL ((0 108. 0 0 0 0 )) NATURAL) (2 ((122 337) (73 337)) NIL ((-49. 0 0 0 0 0 )) NATURAL)) ((11 ((315 124) (312 86) (300 53) (275 34) (240 28) (220 28) (200 28) (165 34) (140 53) (128 86) (125 124)) NIL ((-1.25837326 -38.552482 0 0 -10.44976 3.31491756 ) (-6.48325349 -36.895027 -10.44976 3.31491756 -1.75119591 13.425411 ) (-17.808612 -26.8674 -12.200956 16.740329 -6.54545403 -3.01657295 ) (-33.282295 -11.6353588 -18.74641 13.7237568 45.933013 -7.35911656 ) (-29.062198 -1.59116006 27.186603 6.36464024 -27.186603 -9.5469589 ) (-15.4688987 0 0 -3.18232012 -27.186603 9.5469589 ) (-29.062198 1.5911603 -27.186603 6.36464024 45.933013 7.35911656 ) (-33.282295 11.6353588 18.74641 13.7237568 -6.54545403 3.01657295 ) (-17.808609 26.8674 12.200956 16.740329 -1.75119781 -13.425413 ) (-6.48325253 36.895027 10.4497585 3.3149166 -10.4497585 -3.3149166 )) NATURAL) (11 ((125 124) (128 162) (140 195) (165 214) (200 220) (220 220) (240 220) (275 214) (300 195) (312 162) (315 124)) NIL ((1.25837326 38.552482 0 0 10.44976 -3.31491756 ) (6.48325349 36.895027 10.44976 -3.31491756 1.75119591 -13.425411 ) (17.808612 26.8674 12.200956 -16.740329 6.54545403 3.01657295 ) (33.282295 11.6353588 18.74641 -13.7237568 -45.933013 7.35911656 ) (29.062198 1.59116006 -27.186603 -6.36464024 27.186603 9.5469589 ) (15.4688987 0 0 3.18232012 27.186603 -9.5469589 ) (29.062198 -1.5911603 27.186603 -6.36464024 -45.933013 -7.35911656 ) (33.282295 -11.6353588 -18.74641 -13.7237568 6.54545403 -3.01657295 ) (17.808609 -26.8674 -12.200956 -16.740329 1.75119781 13.425413 ) (6.48325253 -36.895027 -10.4497585 -3.3149166 10.4497585 3.3149166 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 143Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:26:59) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((24 ((379 184) (360 219) (330 239) (291 250) (247 253) (199 250) (165 243) (128 229) (105 209) (87 184) (76 148) (73 124) (76 100) (86 64) (103 37) (124 19) (163 3) (199 -4) (247 -7) (291 -2) (330 9) (358 30) (370 49) (379 74)) NIL ((-16.644897 38.499534 0 0 -14.1306038 -20.997219 ) (-23.710201 28.000923 -14.1306038 -20.997219 4.65302277 14.9861088 ) (-35.514289 14.496757 -9.477581 -6.0111103 7.51851369 -2.94722366 ) (-41.232612 7.01203538 -1.95906663 -8.95833398 -10.727083 2.80278683 ) (-48.55522 -0.544904828 -12.686151 -6.15554715 41.389816 3.73607063 ) (-40.546463 -4.83241654 28.70367 -2.41947651 -46.832206 -5.74706936 ) (-35.258895 -10.125427 -18.128536 -8.16654588 43.939003 1.25220871 ) (-31.41793 -17.665866 25.810466 -6.91433716 -26.923797 6.73823167 ) (-19.069366 -21.21109 -1.11333346 -0.176105380 9.75619889 -22.205131 ) (-15.3045978 -32.48976 8.64286614 -22.381237 -0.101001739 46.08229 ) (-6.71223355 -31.829849 8.5418644 23.701057 -3.35219002 -24.124053 ) (0.153535515 -20.190822 5.18967438 -0.422999382 1.50976372 -21.586059 ) (6.09809209 -31.406852 6.6994381 -22.009059 3.31313324 38.468307 ) (14.4540958 -34.181755 10.012571 16.459247 -14.762298 -6.28718758 ) (17.0855179 -20.8661 -4.74972725 10.17206 37.73606 -13.319557 ) (31.203823 -17.35382 32.986335 -3.14749718 -52.181953 17.565422 ) (38.099174 -11.718605 -19.195617 14.4179268 44.99176 -14.942138 ) (41.399444 -4.7717495 25.796146 -0.524212718 -37.78511 12.203134 ) (48.30303 0.805606008 -11.9889679 11.6789226 10.148691 -9.8704033 ) (41.388412 7.5493269 -1.84027552 1.80851817 -8.8096504 15.278482 ) (35.14331 16.997085 -10.649927 17.087001 -10.910089 -27.243534 ) (19.038337 20.462322 -21.560016 -10.156534 22.450019 21.695667 ) (8.703331 21.153621 0.890004874 11.539133 -0.890004874 -11.539133 )) NATURAL) (2 ((379 74) (329 74)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (20 ((329 74) (329 64) (322 47) (298 35) (268 30) (243 29) (218 30) (176 36) (153 48) (135 71) (124 124) (135 177) (153 200) (176 212) (218 218) (243 219) (268 218) (298 213) (322 201) (329 184)) NIL ((0.788245917 -7.8808317 0 0 -4.72947598 -12.7150058 ) (-1.57649183 -14.238334 -4.72947598 -12.7150058 -18.352619 21.575031 ) (-15.4822788 -16.165821 -23.082096 8.8600273 18.139965 -1.58513355 ) (-29.494392 -8.09836198 -4.94212914 7.27489377 11.792747 -3.23450184 ) (-28.540145 -2.4407196 6.85061837 4.04039192 0.689037323 -3.47685623 ) (-21.345008 -0.138755947 7.53965569 0.563535691 -44.548889 5.14192868 ) (-36.079803 2.99574423 -37.009239 5.70546437 75.50656 0.909141541 ) (-35.335762 9.15577889 38.497322 6.6146059 -41.47737 -2.77849531 ) (-17.577129 14.3811378 -2.98005152 3.83611059 6.4029312 40.204834 ) (-17.3557129 38.319664 3.4228797 44.040947 27.865646 -44.040847 ) (-8.89971852E-6 60.340187 31.288528 9.19930607E-5 -27.865531 -44.041404 ) (17.355751 38.319572 3.42299652 -44.041313 -6.40351487 40.206466 ) (17.576992 14.381498 -2.98051882 -3.83484268 41.47959 -2.78447056 ) (35.336265 9.15442086 38.499076 -6.61931325 -75.514846 0.931411744 ) (36.077919 3.00081348 -37.015777 -5.6879015 44.57981 5.05882263 ) (21.352046 -0.157676696 7.56403638 -0.629078388 -0.804404259 -3.16670466 ) (28.513881 -2.37010717 6.7596321 -3.79578304 -11.3621997 -4.39200688 ) (29.592414 -8.3618946 -4.60256768 -8.1877899 -19.746788 2.73473835 ) (15.116451 -15.1823158 -24.349357 -5.45305157 24.349357 5.45305157 )) NATURAL) (2 ((329 184) (379 184)) NIL ((50. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 144Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:36:21) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((367 337) (367 337) (367 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((367 0) (319 0)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((319 0) (319 19)) NIL ((0 19. 0 0 0 0 )) NATURAL) (19 ((319 19) (288 7) (255 -1) (217 -6) (166 -2) (134 9) (111 24) (94 42) (82 66) (73 124) (82 182) (94 206) (111 224) (134 239) (166 250) (217 254) (255 249) (288 241) (319 229)) NIL ((-30.485801 -12.997631 0 0 -3.08518171 5.9857931 ) (-32.028389 -10.004734 -3.08518171 5.9857931 3.42590904 -5.92896652 ) (-33.400619 -6.98342515 0.340727687 0.0568262711 -28.618454 11.7300739 ) (-47.369117 -1.06156063 -28.277729 11.786901 63.04792 -4.99134064 ) (-44.122886 8.22966958 34.770195 6.79556084 -31.573257 -3.76470709 ) (-25.13932 13.142877 3.19693613 3.03085375 3.24512148 2.05016756 ) (-20.319824 17.198814 6.4420576 5.0810213 0.592772484 -10.4359607 ) (-13.5813789 17.061855 7.0348301 -5.3549404 -11.616209 57.69367 ) (-12.354654 40.553749 -4.58137989 52.338737 33.872062 -52.338737 ) (7.97212123E-7 66.723114 29.290687 -2.04428988E-6 -33.872062 -52.33872 ) (12.354654 40.553749 -4.58137989 -52.338729 11.616209 57.693664 ) (13.5813789 17.061855 7.03482915 5.3549385 -0.592770577 -10.4359588 ) (20.319824 17.198814 6.44205857 -5.08102036 -3.24512196 2.05016661 ) (25.13932 13.142877 3.1969366 -3.03085375 31.573257 -3.76470709 ) (44.122886 8.22966958 34.770195 -6.79556084 -63.04792 -4.99134064 ) (47.369117 -1.06156182 -28.277729 -11.786901 28.618454 11.7300739 ) (33.400619 -6.98342515 0.340728342 -0.0568258986 -3.42591 -5.92896652 ) (32.028389 -10.004734 -3.08518171 -5.9857931 3.08518171 5.9857931 )) NATURAL) (2 ((319 229) (319 337)) NIL ((0 108. 0 0 0 0 )) NATURAL) (2 ((319 337) (367 337)) NIL ((48. 0 0 0 0 0 )) NATURAL)) ((21 ((125 124) (128 86) (140 53) (166 34) (195 28) (220 25) (248 28) (275 34) (300 53) (312 86) (315 124) (312 162) (300 195) (275 214) (240 220) (220 221) (200 220) (166 214) (140 195) (128 162) (125 124)) NIL ((1.51067447 -38.577346 0 0 8.93595315 3.46408939 ) (5.97865105 -36.845298 8.93595315 3.46408939 9.32023049 12.679552 ) (19.574718 -27.041435 18.256183 16.143642 -16.216877 -0.182313919 ) (29.722465 -10.9889488 2.03930521 15.961328 -10.452711 -17.950286 ) (26.535415 -4.0027647 -8.41340638 -1.98896122 16.027721 11.9834747 ) (26.135868 1.15633010E-5 7.6143179 9.99451448 -11.658184 -11.983612 ) (27.921096 4.00271988 -4.04386616 -1.98909831 6.60501576 17.950973 ) (27.179737 10.989109 2.5611496 15.9618759 -20.761878 0.179710388 ) (19.359943 27.04084 -18.200729 16.141586 10.4425125 -12.669805 ) (6.38047219 36.847518 -7.75821686 3.47177982 2.99181557 -3.50048733 ) (0.118163108 38.569053 -4.76640129 -0.0287075825 -4.40977478 -3.32824135 ) (-6.85312558 36.876228 -9.17617608 -3.35694933 -3.35271454 -13.186544 ) (-17.705661 26.926006 -12.5288906 -16.543495 -6.17935753 2.07443428 ) (-33.324226 11.419729 -18.708248 -14.4690609 46.070129 10.8888015 ) (-28.997413 2.39507007 27.36188 -3.58025837 -28.10115 2.3703537 ) (-15.686109 -1.16033479E-5 -0.739272595 -1.20990467 -23.665515 -2.37021637 ) (-28.25814 -2.3950243 -24.404789 -3.58012104 38.763206 -10.889488 ) (-33.281318 -11.419889 14.358423 -14.46961 0.612663269 -2.07182503 ) (-18.616565 -26.92541 14.971086 -16.541435 -5.21385956 13.176794 ) (-6.25240899 -36.878448 9.75722695 -3.36464119 -9.75722695 3.36464119 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 145Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:44:36) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((10 ((114 106) (121 71) (140 47) (162 36) (198 28) (232 26) (262 30) (290 38) (310 55) (317 74)) NIL ((3.72561359 -37.048507 0 0 19.646316 12.291084 ) (13.5487728 -30.902969 19.646316 12.291084 -26.23159 4.54457855 ) (20.079292 -16.3395958 -6.5852747 16.8356628 31.280056 -18.469402 ) (29.134048 -8.738636 24.694782 -1.63374018 -32.88864 9.3330364 ) (37.384506 -5.70585728 -8.1938591 7.69929696 4.27451039 -0.862744332 ) (31.327903 1.56206679 -3.91934872 6.8365526 3.79060364 -5.88205815 ) (29.303859 5.4575901 -0.128744781 0.954493762 -7.43692494 12.390974 ) (25.456649 12.6075706 -7.56567 13.345468 -10.0429077 -13.681835 ) (12.8695259 19.112121 -17.608577 -0.336367309 17.608577 0.336367309 )) NATURAL) (2 ((317 74) (367 74)) NIL ((50. 0 0 0 0 0 )) NATURAL) (26 ((367 74) (358 49) (346 30) (318 9) (279 -2) (235 -7) (187 -4) (151 3) (120 17) (92 38) (74 63) (64 90) (61 124) (64 148) (75 184) (92 210) (116 229) (153 245) (188 252) (235 253) (276 248) (315 237) (345 217) (365 189) (375 153) (376 106)) NIL ((-9.14956666 -26.922843 0 0 0.897400857 11.5370788 ) (-8.7008648 -21.154304 0.897400857 11.5370788 -22.487003 -21.685394 ) (-19.046966 -20.459922 -21.589603 -10.148315 11.0506248 27.204502 ) (-35.111259 -17.005985 -10.5389785 17.056186 8.28450204 -15.132629 ) (-41.507988 -7.51611615 -2.25447607 1.92355561 -8.18863679 9.3260288 ) (-47.85678 -0.929544092 -10.443113 11.249586 30.470039 -10.1714935 ) (-43.064872 5.23429489 20.026927 1.07809257 -17.691524 7.3599491 ) (-31.883708 9.99236299 2.33540249 8.4380417 -1.70394110 -1.26830482 ) (-30.400276 17.796249 0.631461263 7.16973687 12.5072899 -2.28672886 ) (-23.51517 23.822624 13.138752 4.883008 -6.32522488 -7.5847759 ) (-13.53903 24.913242 6.8135271 -2.7017684 0.793606759 20.625831 ) (-6.3286991 32.52439 7.60713387 17.924064 -2.84920406 -44.918556 ) (-0.146167755 27.989177 4.7579298 -26.994491 4.60321713 57.048393 ) (6.91337014 29.518886 9.3611469 30.053905 -3.56366348 -51.275047 ) (14.492685 33.935264 5.79748345 -21.221145 -2.34856748 16.051834 ) (19.115882 20.740036 3.44891596 -5.16931153 18.957935 5.067708 ) (32.043769 18.1045799 22.406852 -0.101603269 -37.483184 -12.32267 ) (35.70903 11.84164 -15.0763359 -12.424274 40.974823 8.22297288 ) (41.1201 3.52885342 25.89849 -4.20130062 -42.416122 -2.56921959 ) (45.81053 -1.957057 -16.517631 -6.7705202 20.689662 2.05390358 ) (39.637733 -7.7006254 4.17203236 -4.71661663 -16.342529 -5.64639378 ) (35.638504 -15.24044 -12.1704979 -10.36301 2.68045235 2.53167534 ) (24.808235 -24.337612 -9.49004556 -7.83133507 -0.379274368 1.51969146 ) (15.128551 -31.409103 -9.8693199 -6.3116436 -1.16334915 -8.610445 ) (4.67755604 -42.02597 -11.032669 -14.922088 11.032669 14.922088 )) NATURAL) (2 ((376 106) (114 106)) NIL ((-262. 0 0 0 0 0 )) NATURAL)) ((13 ((111 148) (115 173) (128 195) (142 206) (164 215) (199 220) (219 221) (239 220) (273 215) (296 206) (309 195) (323 173) (327 148)) NIL ((1.59247875 25.037006 0 0 14.445127 -0.222058296 ) (8.8150425 24.925979 14.445127 -0.222058296 -18.225643 -16.889705 ) (14.147348 16.259063 -3.78051567 -17.111766 10.4574489 19.780899 ) (15.595558 9.03774835 6.67693425 2.66913366 18.395839 -8.23390008 ) (31.470413 7.58993245 25.072776 -5.56476689 -54.040817 1.15470123 ) (29.522777 2.60251617 -28.968044 -4.41006565 29.767448 3.61509848 ) (15.438461 -1.19209289E-7 0.799406291 -0.794966818 24.971008 -3.61509848 ) (28.723369 -2.60251665 25.770416 -4.41006565 -45.65148 -1.15470123 ) (31.668045 -7.58993245 -19.881069 -5.56476689 7.63492776 8.23390008 ) (15.60444 -9.03774835 -12.246141 2.66913366 21.111778 -19.780899 ) (13.914188 -16.259067 8.8656368 -17.111766 -26.082042 16.889705 ) (9.73880197 -24.925979 -17.216407 -0.222057551 17.216407 0.222057551 )) NATURAL) (2 ((327 148) (111 148)) NIL ((-216. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 146Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:51:03) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((156 0) (156 210)) NIL ((0 210. 0 0 0 0 )) NATURAL) (2 ((156 210) (60 210)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((60 210) (60 246)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((60 246) (156 246)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((156 246) (156 292)) NIL ((0 46. 0 0 0 0 )) NATURAL) (10 ((156 292) (165 316) (189 333) (215 341) (243 345) (278 346) (315 342) (348 331) (369 315) (378 292)) NIL ((5.11860848 25.295597 0 0 23.288345 -7.7735853 ) (16.762779 21.408802 23.288345 -7.7735853 -26.441726 -3.1320734 ) (26.83026 12.069181 -3.15338469 -10.9056587 4.47857857 8.3018837 ) (25.916164 5.31446457 1.32519412 -2.60377359 8.5274124 -0.0754714012 ) (31.505065 2.67295551 9.8526077 -2.67924499 -8.58823396 -1.99999904 ) (37.063552 -1.00628972 1.26437258 -4.67924404 -4.17447186 -3.92452908 ) (36.240692 -7.64779854 -2.9100995 -8.6037731 -10.713871 5.69811249 ) (27.973655 -13.402515 -13.6239719 -2.90566063 -0.970033646 -6.86792374 ) (13.8646679 -19.742137 -14.594005 -9.77358438 14.594005 9.77358438 )) NATURAL) (2 ((378 292) (378 272)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (2 ((378 272) (337 272)) NIL ((-41. 0 0 0 0 0 )) NATURAL) (8 ((337 272) (331 295) (319 305) (300 311) (273 313) (245 310) (219 299) (209 283)) NIL ((-4.74338722 26.25661 0 0 -7.53967667 -19.539676 ) (-8.51322557 16.48677 -7.53967667 -19.539676 1.69838524 19.698383 ) (-15.203708 6.79628945 -5.84129143 0.158708185 -5.25386429 -5.25386334 ) (-23.671932 4.32806492 -11.0951557 -5.0951557 13.3170719 1.31707239 ) (-28.10855 -0.108553722 2.22191667 -3.77808333 -6.01442719 -6.01442719 ) (-28.893848 -6.89385033 -3.7925105 -9.792511 28.74063 4.74063969 ) (-18.31604 -14.3160419 24.948123 -5.0518713 -24.948123 5.0518713 )) NATURAL) (2 ((209 283) (209 246)) NIL ((0 -37. 0 0 0 0 )) NATURAL) (2 ((209 246) (313 246)) NIL ((104. 0 0 0 0 0 )) NATURAL) (2 ((313 246) (313 210)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((313 210) (209 210)) NIL ((-104. 0 0 0 0 0 )) NATURAL) (2 ((209 210) (209 0)) NIL ((0 -210. 0 0 0 0 )) NATURAL) (2 ((209 0) (156 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 147Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:11:15) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((11 ((367 -36) (360 -58) (339 -81) (316 -96) (276 -109) (223 -113) (171 -109) (130 -96) (106 -81) (87 -58) (79 -36)) NIL ((-3.1312089 -21.157455 0 0 -23.212745 -5.05524826 ) (-14.737581 -23.685081 -23.212745 -5.05524826 32.063728 19.276241 ) (-21.91846 -19.102207 8.85098649 14.220993 -33.042182 -18.04972 ) (-29.588569 -13.906076 -24.1912 -3.82872963 10.105022 16.922653 ) (-48.727256 -9.27347947 -14.0861778 13.093923 16.622085 -7.6408863 ) (-54.502388 6.37024641E-7 2.53591108 5.45303726 7.4066181 7.6408844 ) (-48.263168 9.27347947 9.94252969 13.0939216 13.751432 -16.922649 ) (-31.444919 13.906076 23.693962 -3.82872915 -26.412349 18.04972 ) (-20.957134 19.102207 -2.71838999 14.220993 19.897983 -19.276241 ) (-13.726532 23.685081 17.1795959 -5.05524826 -17.1795959 5.05524826 )) NATURAL) (2 ((79 -36) (134 -36)) NIL ((55. 0 0 0 0 0 )) NATURAL) (8 ((134 -36) (157 -66) (188 -78) (215 -81) (238 -81) (278 -72) (310 -53) (319 -26)) NIL ((20.736858 -34.19924 0 0 13.578838 25.195465 ) (27.526279 -21.601509 13.578838 25.195465 -19.894191 -17.977325 ) (31.15802 -5.39470959 -6.3153553 7.21813775 -6.00206185 -7.28615475 ) (21.841632 -1.81964922 -12.317417 -0.0680177510 43.902435 11.121948 ) (31.475437 3.67330837 31.585022 11.053932 -43.607688 -1.20164871 ) (41.256607 14.126417 -12.0226726 9.85228349 -19.471656 -0.315355301 ) (19.498107 23.821022 -31.49433 9.53692819 31.49433 -9.53692819 )) NATURAL) (2 ((319 -26) (319 19)) NIL ((0 45. 0 0 0 0 )) NATURAL) (19 ((319 19) (294 10) (255 -1) (217 -6) (166 -2) (134 9) (111 24) (94 42) (78 78) (73 124) (77 160) (88 196) (111 224) (134 239) (166 250) (217 254) (263 249) (297 238) (319 229)) NIL ((-20.838954 -8.1762371 0 0 -24.966262 -4.94256687 ) (-33.322082 -10.6475219 -24.966262 -4.94256687 40.83132 12.712835 ) (-37.872688 -9.2336712 15.865064 7.77026845 -48.359054 2.09122372 ) (-46.187156 -0.417790532 -32.493995 9.86149217 68.604934 -3.07773304 ) (-44.378677 7.9048357 36.110939 6.7837591 -34.060707 -1.78029155 ) (-25.298099 13.798448 2.05022669 5.00346756 7.6379194 -7.8010969 ) (-19.428913 14.901367 9.6881466 -2.79762983 -14.490961 26.984676 ) (-16.986244 25.596077 -4.80281449 24.187049 20.325923 -10.1376247 ) (-11.6260967 44.714317 15.523111 14.049425 -6.81274796 -34.43418 ) (0.490640223 41.546646 8.7103634 -20.384758 -5.07493115 27.874359 ) (6.66353799 35.099075 3.63543177 7.489604 15.112472 -17.0632629 ) (17.855205 34.057045 18.747905 -9.5736599 -25.374961 -7.62130547 ) (23.91563 20.672733 -6.62705899 -17.194965 14.387386 17.548488 ) (24.482265 12.252012 7.7603283 0.353523433 21.825416 -8.572649 ) (43.155304 8.31921006 29.585746 -8.21912576 -41.68907 -1.25789261 ) (51.896514 -0.528861285 -12.1033249 -9.47701837 0.930879594 1.60422325 ) (40.258628 -9.20376779 -11.172445 -7.8727951 -4.0344429 12.8409939 ) (27.068962 -10.656065 -15.206888 4.96819878 15.206888 -4.96819878 )) NATURAL) (2 ((319 229) (319 246)) NIL ((0 17. 0 0 0 0 )) NATURAL) (2 ((319 246) (367 246)) NIL ((48. 0 0 0 0 0 )) NATURAL) (2 ((367 246) (367 -36)) NIL ((0 -282. 0 0 0 0 )) NATURAL)) ((11 ((315 124) (312 86) (300 53) (275 34) (240 28) (220 26) (200 28) (166 34) (140 53) (128 86) (125 124)) NIL ((-1.25777840 -38.569053 0 0 -10.453329 3.41436482 ) (-6.4844427 -36.861877 -10.453329 3.41436482 -1.73335266 12.9281749 ) (-17.804447 -26.983425 -12.1866817 16.34254 -6.61325646 -1.12707138 ) (-33.29776 -11.204418 -18.799938 15.215469 46.186386 -14.419889 ) (-29.004505 -3.1988945 27.386447 0.795579792 -28.1323 4.80662918 ) (-15.6842098 4.17232513E-7 -0.745856881 5.60220909 -23.657165 -4.80662918 ) (-28.258647 3.19889498 -24.403022 0.795579315 38.76097 14.419889 ) (-33.28118 11.20442 14.357952 15.215469 0.613256455 1.12706756 ) (-18.6166 26.983425 14.971208 16.3425369 -5.21401215 -12.928171 ) (-6.2523985 36.861877 9.7571964 3.41436482 -9.7571964 -3.41436482 )) NATURAL) (11 ((125 124) (128 162) (140 195) (166 214) (200 220) (220 222) (240 220) (275 214) (300 195) (312 162) (315 124)) NIL ((1.37380051 38.569053 0 0 9.7571964 -3.41436482 ) (6.2523985 36.861877 9.7571964 -3.41436482 5.21401596 -12.9281749 ) (18.616603 26.983425 14.971212 -16.34254 -0.613260269 1.12707138 ) (33.28118 11.204418 14.357952 -15.215469 -38.76097 14.419889 ) (28.258647 3.1988945 -24.403022 -0.795579792 23.657165 -4.80662918 ) (15.6842098 -4.17232513E-7 -0.745855928 -5.60220909 28.1323 4.80662918 ) (29.004505 -3.19889498 27.386447 -0.795579315 -46.186386 -14.419889 ) (33.29776 -11.20442 -18.799942 -15.215469 6.61326218 -1.12706756 ) (17.804447 -26.983425 -12.1866798 -16.3425369 1.73335075 12.928171 ) (6.4844427 -36.861877 -10.453329 -3.41436482 10.453329 3.41436482 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 150Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:17:17) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((81 0) (81 0) (81 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((81 337) (132 337)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((132 337) (132 221)) NIL ((0 -116. 0 0 0 0 )) NATURAL) (11 ((132 221) (159 239) (190 249) (215 254) (244 256) (273 253) (301 245) (321 236) (336 224) (348 208) (355 187)) NIL ((25.419338 19.823307 0 0 9.48395349 -10.939859 ) (30.161315 14.353378 9.48395349 -10.939859 -23.419769 6.69930363 ) (27.935386 6.76317025 -13.9358158 -4.24055577 24.195125 2.14264202 ) (26.097133 3.59393549 10.2593097 -2.09791374 -13.3607387 -3.26987267 ) (29.676075 -0.138914734 -3.10142994 -5.3677864 5.24783802 -1.06315231 ) (29.198562 -6.03827763 2.14640856 -6.4309387 -13.630613 7.5224819 ) (24.529663 -8.7079754 -11.484205 1.09154343 7.27461815 -5.02677727 ) (16.6827659 -10.1298198 -4.2095871 -3.93523455 2.53214359 0.584630490 ) (13.739254 -13.772739 -1.67744326 -3.35060406 -5.40319538 -3.31174469 ) (9.3602123 -18.779216 -7.08063889 -6.66234875 7.08063889 6.66234875 )) NATURAL) (2 ((355 187) (357 0)) NIL ((2. -187. 0 0 0 0 )) NATURAL) (2 ((357 0) (308 0)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (2 ((308 0) (308 166)) NIL ((0 166. 0 0 0 0 )) NATURAL) (9 ((308 166) (302 195) (283 213) (255 220) (232 221) (202 218) (168 211) (142 191) (132 166)) NIL ((-3.2881074 31.25368 0 0 -16.271354 -13.5220909 ) (-11.423784 24.492633 -16.271354 -13.5220909 3.35677528 1.61045646 ) (-26.01675 11.775772 -12.914579 -11.911634 26.844253 7.08026505 ) (-25.5092 3.40427065 13.929674 -4.8313694 -26.733795 0.0684823990 ) (-24.946426 -1.39285707 -12.8041229 -4.762887 8.09094239 4.64580345 ) (-33.705078 -3.83284283 -4.71318054 -0.117083445 12.370027 -18.651691 ) (-32.233245 -13.275772 7.65684796 -18.7687759 14.4289398 15.9609699 ) (-17.361927 -24.064064 22.085788 -2.80780554 -22.085788 2.80780554 )) NATURAL) (2 ((132 166) (132 0)) NIL ((0 -166. 0 0 0 0 )) NATURAL) (2 ((132 0) (81 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 151Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:21:40) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((254 210) (254 0)) NIL ((0 -210. 0 0 0 0 )) NATURAL) (2 ((254 0) (304 0)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((304 0) (304 246)) NIL ((0 246. 0 0 0 0 )) NATURAL) (2 ((304 246) (115 246)) NIL ((-189. 0 0 0 0 0 )) NATURAL) (2 ((115 246) (115 210)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((115 210) (254 210)) NIL ((139. 0 0 0 0 0 )) NATURAL)) ((13 ((236 313) (240 329) (251 339) (275 345) (299 339) (310 329) (314 313) (310 297) (299 287) (275 281) (251 287) (240 297) (236 313)) NIL ((2.99777937 17.538459 0 0 6.01332379 -9.2307682 ) (6.00444127 12.9230766 6.01332379 -9.2307682 11.93338 10.1538429 ) (17.984455 8.7692299 17.946704 0.923076273 -17.7468529 -19.384609 ) (27.057731 -6.96629285E-7 0.199850619 -18.461536 -18.945957 19.384613 ) (17.784599 -8.7692299 -18.746109 0.923076988 15.530712 -10.1538448 ) (6.80384827 -12.9230766 -3.21539688 -9.2307682 -7.17690278 9.2307682 ) (-7.15255737E-7 -17.538459 -10.3922996 0 7.17690278 9.2307682 ) (-6.80384827 -12.9230747 -3.2153964 9.2307682 -15.5307159 -10.1538448 ) (-17.784603 -8.7692299 -18.746112 -0.923076749 18.945961 19.384613 ) (-27.057731 6.96629285E-7 0.199851840 18.461536 17.7468529 -19.384613 ) (-17.984455 8.7692299 17.946704 -0.923076988 -11.93338 10.1538448 ) (-6.00444127 12.9230766 6.01332379 9.2307682 -6.01332379 -9.2307682 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 152Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:27:59) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((275 -33) (275 210)) NIL ((0 243. 0 0 0 0 )) NATURAL) (2 ((275 210) (136 210)) NIL ((-139. 0 0 0 0 0 )) NATURAL) (2 ((136 210) (136 246)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((136 246) (325 246)) NIL ((189. 0 0 0 0 0 )) NATURAL) (2 ((325 246) (325 -32)) NIL ((0 -278. 0 0 0 0 )) NATURAL) (13 ((325 -32) (321 -50) (312 -67) (298 -83) (279 -97) (250 -107) (193 -113) (136 -107) (108 -97) (88 -83) (75 -67) (66 -50) (61 -34)) NIL ((-2.93862963 -18.215393 0 0 -6.36822224 1.29237032 ) (-6.12274075 -17.569206 -6.36822224 1.29237032 1.84111404 -0.461851597 ) (-11.5704059 -16.5077629 -4.52710819 0.830518723 -0.996235848 0.555036068 ) (-16.59563 -15.3997268 -5.52334404 1.38555479 2.14382934 4.2417059 ) (-21.047061 -11.89332 -3.37951469 5.62726116 -37.579078 -5.52186203 ) (-43.216117 -9.02698899 -40.958595 0.105398297 40.172508 17.845745 ) (-64.088455 0.00128283351 -0.786086679 17.951145 44.889015 -17.861129 ) (-42.43003 9.021862 44.102935 0.0900126547 -45.728599 5.5987873 ) (-21.191398 11.911268 -1.62566781 5.6888008 12.0254 -4.5340147 ) (-16.804367 15.333061 10.3997326 1.15478539 -8.37299348 0.537271738 ) (-10.591131 16.756481 2.02673769 1.69205713 3.466578 -3.6150713 ) (-6.83110524 16.641002 5.4933157 -1.92301416 -5.4933157 1.92301416 )) NATURAL) (2 ((61 -34) (111 -33)) NIL ((50. 1. 0 0 0 0 )) NATURAL) (9 ((111 -33) (120 -56) (145 -71) (170 -75) (193 -77) (216 -75) (241 -71) (266 -56) (275 -33)) NIL ((4.75 -24.371131 0 0 25.5 8.2268028 ) (17.5 -20.257728 25.5 8.2268028 -31.5 6.86598015 ) (27.249996 -8.59793664 -6. 15.0927829 4.5 -17.690719 ) (23.499996 -2.35051536 -1.49999976 -2.59793806 1.49999952 9.8969059 ) (22.75 -1.58324837E-7 -6.38824957E-8 7.29896927 1.5 -9.8969059 ) (23.5 2.35051536 1.5 -2.59793758 4.49999905 17.690715 ) (27.249996 8.59793855 5.99999905 15.092781 -31.499992 -6.86597634 ) (17.499996 20.257728 -25.499996 8.22680474 25.499996 -8.22680474 )) NATURAL)) ((13 ((296 345) (272 339) (261 329) (257 313) (261 297) (272 287) (296 281) (320 287) (331 297) (335 313) (331 329) (320 339) (296 345)) NIL ((-27.115383 -5.32938576 0 0 18.692306 -4.02368546 ) (-17.7692299 -7.34122849 18.692306 -4.02368546 -15.461536 -3.88156986 ) (-6.80769158 -13.305698 3.23076916 -7.9052553 7.15384579 7.549963 ) (2.38418579E-7 -17.43597 10.3846149 -0.355292022 -7.15384579 9.681715 ) (6.80769253 -12.950405 3.23076868 9.32642365 15.461536 -10.2768306 ) (17.7692299 -8.76239778 18.692306 -0.950407744 -18.692306 19.425609 ) (27.115383 -2.57045030E-7 0 18.475204 -18.692306 -19.425609 ) (17.7692299 8.76239778 -18.692306 -0.950407386 15.461538 10.2768306 ) (6.80769158 12.950407 -3.2307682 9.32642365 -7.15384675 -9.681715 ) (-2.38418579E-7 17.43597 -10.3846149 -0.355291724 7.15384579 -7.549963 ) (-6.80769253 13.305698 -3.23076868 -7.9052553 -15.461536 3.88156986 ) (-17.7692299 7.34122849 -18.692306 -4.02368546 18.692306 4.02368546 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 153Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:32:02) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((73 0) (73 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((73 337) (120 337)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((120 337) (120 157)) NIL ((0 -180. 0 0 0 0 )) NATURAL) (2 ((120 157) (165 157)) NIL ((45. 0 0 0 0 0 )) NATURAL) (2 ((165 157) (293 246)) NIL ((128. 89. 0 0 0 0 )) NATURAL) (2 ((293 246) (360 246)) NIL ((67. 0 0 0 0 0 )) NATURAL) (2 ((360 246) (199 136)) NIL ((-161. -110. 0 0 0 0 )) NATURAL) (2 ((199 136) (405 0)) NIL ((206. -136. 0 0 0 0 )) NATURAL) (2 ((405 0) (333 0)) NIL ((-72. 0 0 0 0 0 )) NATURAL) (2 ((333 0) (165 110)) NIL ((-168. 110. 0 0 0 0 )) NATURAL) (2 ((165 110) (120 110)) NIL ((-45. 0 0 0 0 0 )) NATURAL) (2 ((120 110) (120 0)) NIL ((0 -110. 0 0 0 0 )) NATURAL) (2 ((120 0) (73 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 154Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:32:50) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((232 0) (232 301)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((232 301) (94 301)) NIL ((-138. 0 0 0 0 0 )) NATURAL) (2 ((94 301) (94 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((94 337) (283 337)) NIL ((189. 0 0 0 0 0 )) NATURAL) (2 ((283 337) (283 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((283 0) (232 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 155Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:39:05) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((31 0) (31 246)) NIL ((0 246. 0 0 0 0 )) NATURAL) (2 ((31 246) (78 246)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((78 246) (78 227)) NIL ((0 -19. 0 0 0 0 )) NATURAL) (9 ((78 227) (88 237) (100 244) (117 250) (153 254) (178 254) (205 250) (225 244) (241 232)) NIL ((9.3958931 10.755245 0 0 3.62463093 -4.53147984 ) (11.20821 8.48950578 3.62463093 -4.53147984 -6.1231556 4.65740013 ) (11.771263 6.286726 -2.49852466 0.125920355 38.867988 -2.09812164 ) (28.706737 5.36358547 36.369468 -1.97220134 -65.348846 -2.26491165 ) (32.401779 2.2589283 -28.979377 -4.237113 42.52742 -0.842230797 ) (24.686119 -2.39930057 13.548048 -5.0793438 -26.76086 5.63383484 ) (24.853736 -4.661726 -13.212812 0.554491878 10.516016 -9.6931133 ) (16.898929 -8.95379258 -2.69679642 -9.13862229 2.69679642 9.13862229 )) NATURAL) (10 ((241 232) (256 241) (274 248) (294 253) (322 255) (358 250) (381 242) (394 231) (403 220) (409 200)) NIL ((14.241657 9.41674615 0 0 4.5500555 -2.50048065 ) (16.516681 8.1665058 4.5500555 -2.50048065 -4.75027752 0.502404452 ) (18.6916 5.91722679 -0.200222254 -1.9980762 8.4510555 0.490862370 ) (22.716903 4.16458225 8.2508335 -1.50721383 6.94605637 -8.46585084 ) (34.440765 -1.57555818 15.1968898 -9.9730663 -36.235282 9.37254716 ) (31.520011 -6.86235047 -21.038398 -0.600517631 11.995113 -5.02434349 ) (16.4791679 -9.9750385 -9.04328538 -5.6248617 6.25482846 10.7248249 ) (10.563299 -10.2374878 -2.78845692 5.09996319 -1.01442861 -19.87495 ) (7.2676277 -15.075002 -3.80288553 -14.77499 3.80288553 14.77499 )) NATURAL) (2 ((409 200) (409 0)) NIL ((0 -200. 0 0 0 0 )) NATURAL) (2 ((409 0) (359 0)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((359 0) (359 190)) NIL ((0 190. 0 0 0 0 )) NATURAL) (9 ((359 190) (355 206) (341 215) (319 219) (294 219) (271 214) (258 205) (252 190) (250 174)) NIL ((-1.83845734 17.571243 0 0 -12.969255 -9.42746545 ) (-8.32308579 12.857509 -12.969255 -9.42746545 4.84628105 5.1373329 ) (-18.869197 5.99871063 -8.1229744 -4.29013253 5.58413029 0.878129960 ) (-24.200107 2.14764309 -2.53884363 -3.41200256 2.81719446 -2.64985275 ) (-25.330356 -2.58928585 0.278350830 -6.0618553 13.147089 3.72128105 ) (-18.478458 -6.79050065 13.4254398 -2.34057426 -7.40555764 -6.23527337 ) (-8.75579835 -12.2487106 6.0198822 -8.5758476 -1.52485275 9.21980859 ) (-3.49834299 -16.214653 4.49502945 0.643961907 -4.49502945 -0.643961907 )) NATURAL) (2 ((250 174) (250 0)) NIL ((0 -174. 0 0 0 0 )) NATURAL) (2 ((250 0) (201 0)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (2 ((201 0) (201 190)) NIL ((0 190. 0 0 0 0 )) NATURAL) (10 ((201 190) (197 206) (183 215) (161 219) (142 220) (122 218) (99 214) (86 205) (80 190) (78 174)) NIL ((-1.95049953 17.560386 0 0 -12.2970028 -9.3623371 ) (-8.09900094 12.879219 -12.2970028 -9.3623371 1.48501777 4.81169033 ) (-19.653495 5.92272759 -10.811985 -4.55064678 18.356933 2.11557484 ) (-21.287014 2.42986774 7.54494954 -2.43507194 -8.9127617 -1.27399206 ) (-18.198444 -0.642200113 -1.36781311 -3.709064 -6.70588303 2.98039245 ) (-22.9192 -2.86106777 -8.07369615 -0.728671313 23.736293 -4.64757633 ) (-19.124748 -5.91352749 15.662597 -5.37624836 -10.23929 -2.39008522 ) (-8.58179666 -12.484817 5.42330647 -7.76633359 -0.779133797 8.20791627 ) (-3.54805756 -16.1471939 4.64417267 0.441583455 -4.64417267 -0.441583455 )) NATURAL) (2 ((78 174) (78 0)) NIL ((0 -174. 0 0 0 0 )) NATURAL) (2 ((78 0) (31 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.LC2-SF b/lispusers/GACHAE.LC2-SF new file mode 100644 index 00000000..2b113cd5 --- /dev/null +++ b/lispusers/GACHAE.LC2-SF @@ -0,0 +1 @@ + ((FAMILY gacha) (CHARACTER 156Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:03:06) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((81 0) (81 0) (81 246)) NIL ((0 -61.5 0 0 0 369. ) (0 123. 0 369. 0 -369. )) NATURAL) (2 ((81 246) (132 246)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((132 246) (132 231)) NIL ((0 -15. 0 0 0 0 )) NATURAL) (12 ((132 231) (146 239) (165 247) (188 252) (219 255) (244 255) (273 253) (301 245) (321 236) (336 224) (348 208) (355 187)) NIL ((12.757387 7.8082018 0 0 7.45567608 1.15078807 ) (16.4852218 8.3835945 7.45567608 1.15078807 -7.2783804 -5.75393963 ) (20.301708 6.65741254 0.177295416 -4.60315228 15.657846 3.86497593 ) (28.30793 3.9867487 15.835142 -0.738176108 -31.353008 -3.705966 ) (28.466568 1.39558935 -15.517866 -4.44414234 25.754188 4.95888996 ) (25.825794 -0.569107771 10.236322 0.514747978 -11.6637478 -10.1295967 ) (30.230243 -5.11915779 -1.42742538 -9.6148491 -9.09919549 11.5594978 ) (24.253219 -8.95425797 -10.5266208 1.94464874 6.0605383 -6.10839368 ) (16.756866 -10.0638065 -4.46608258 -4.16374493 2.85703802 0.874077321 ) (13.719303 -13.790512 -1.60904455 -3.2896676 -5.48869324 -3.38791514 ) (9.36591149 -18.774135 -7.09773827 -6.67758275 7.09773827 6.67758275 )) NATURAL) (2 ((355 187) (357 0)) NIL ((2. -187. 0 0 0 0 )) NATURAL) (2 ((357 0) (308 0)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (2 ((308 0) (308 176)) NIL ((0 176. 0 0 0 0 )) NATURAL) (11 ((308 176) (307 191) (295 205) (275 215) (247 219) (223 220) (197 219) (168 215) (149 205) (137 191) (132 176)) NIL ((1.54838872 15.082872 0 0 -15.2903328 -0.497237682 ) (-6.09677697 14.834253 -15.2903328 -0.497237682 10.4516639 -3.51381159 ) (-16.161277 12.5801086 -4.83866883 -4.01104927 -8.5163231 -3.44751453 ) (-25.258106 6.84530354 -13.3549919 -7.4585638 23.613628 5.30386734 ) (-26.806285 2.03867388 10.258636 -2.15469599 -13.938192 0.232043981 ) (-23.516746 -7.96280801E-8 -3.67955732 -1.922652 -3.86084795 -0.232043504 ) (-29.126728 -2.03867388 -7.54040528 -2.15469551 23.381584 -5.3038683 ) (-24.976337 -6.84530354 15.8411789 -7.4585638 -11.665493 3.44751453 ) (-14.9679069 -12.58011 4.17568493 -4.01104927 5.28039456 3.51381159 ) (-8.1520252 -14.834253 9.45607949 -0.497237623 -9.45607949 0.497237623 )) NATURAL) (2 ((132 176) (132 0)) NIL ((0 -176. 0 0 0 0 )) NATURAL) (2 ((132 0) (81 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 157Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:07:04) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((29 ((220 253) (184 250) (150 243) (111 227) (90 209) (72 184) (61 148) (58 124) (61 100) (72 64) (90 39) (111 21) (148 3) (184 -4) (220 -7) (256 -4) (292 3) (330 21) (351 39) (369 64) (379 100) (382 124) (379 148) (369 184) (351 209) (330 227) (291 243) (256 250) (220 253)) NIL ((-37.23284 -2.5527296 0 0 7.3970537 -2.68362236 ) (-33.534309 -3.89454079 7.3970537 -2.68362236 -24.985267 -10.581888 ) (-38.629898 -11.869106 -17.5882149 -13.26551 50.544029 15.0111789 ) (-30.94609 -17.629028 32.955818 1.74566984 -39.190887 -7.4628372 ) (-17.58572 -19.614776 -6.23507023 -5.71716786 16.219528 -15.159822 ) (-15.711023 -32.911857 9.9844608 -20.876991 -1.68723678 44.102119 ) (-6.5701809 -31.737785 8.29722405 23.225132 -3.47058487 -23.24868 ) (-0.00824896433 -20.136993 4.82663918 -0.0235491991 3.56957626 -23.107383 ) (6.60317803 -31.714237 8.39621545 -23.130935 1.19228363 43.67823 ) (15.595535 -33.00605 9.58849908 20.547298 -14.338714 -13.6055526 ) (18.014675 -19.261531 -4.75021649 6.9417448 32.162574 -13.256025 ) (29.345752 -18.947799 27.412365 -6.31428147 -36.311607 24.629661 ) (38.60231 -12.94725 -8.8992462 18.31538 11.083864 -19.26263 ) (35.244995 -4.26318646 2.18461943 -0.947252036 -2.02385092 10.4208755 ) (36.417686 4.37721610E-7 0.160768091 9.47362519 -2.98846006 -10.420877 ) (35.084228 4.26318646 -2.82769203 -0.947252989 13.977691 19.262634 ) (39.245384 12.947252 11.1499996 18.3153839 -40.922302 -24.629665 ) (29.93423 18.947799 -29.772304 -6.31428147 35.711525 13.256027 ) (18.017688 19.261531 5.93922329 6.94174576 -17.923809 13.6055526 ) (14.995006 33.00605 -11.9845867 20.547298 5.98371315 -43.67823 ) (6.00227643 31.714233 -6.00087357 -23.130935 -0.0110425949 23.107383 ) (-0.00411796570 20.136993 -6.01191617 -0.0235481784 0.0604562759 23.24868 ) (-5.9858074 31.737785 -5.95145989 23.225132 -6.23077584 -44.102119 ) (-15.052654 32.91185 -12.1822357 -20.876987 18.86264 15.159818 ) (-17.803569 19.614776 6.68040753 -5.7171688 -39.219795 7.46283913 ) (-30.733062 17.629028 -32.53939 1.74567079 48.016555 -15.0111828 ) (-39.264167 11.869106 15.4771709 -13.265512 -20.846462 10.58189 ) (-34.210235 3.8945403 -5.36929226 -2.6836214 5.36929226 2.6836214 )) NATURAL)) ((21 ((244 28) (221 26) (196 28) (160 36) (138 47) (117 71) (106 124) (117 177) (138 201) (160 212) (196 220) (221 221) (244 220) (280 212) (303 201) (324 177) (334 124) (324 71) (303 47) (280 36) (244 28)) NIL ((-31.346866 -4.94781018 27.096454 7.89321995 -31.20816 -5.99279499 ) (-19.854492 -0.0509881154 -4.11170769 1.90042472 -18.537914 6.6046543 ) (-33.235153 5.1517639 -22.649623 8.50507928 51.359825 -8.4258213 ) (-30.204864 9.44393159 28.7102 0.0792564750 -36.90139 9.0986347 ) (-19.945362 14.0725078 -8.19119454 9.17789269 18.245773 32.031272 ) (-19.013671 39.266037 10.0545787 41.209167 17.918293 -41.223762 ) (5.46798110E-5 59.863327 27.972873 -0.0145962312 -17.918949 -41.136184 ) (19.01345 39.280632 10.0539245 -41.150787 -18.242496 31.768524 ) (19.946128 14.014112 -8.18857194 -9.38226129 36.88893 10.062099 ) (30.202026 9.6629028 28.700363 0.679839969 -51.313247 -12.016935 ) (33.245758 4.33427334 -22.612884 -11.337097 18.364067 14.005647 ) (19.81491 1.11246481E-6 -4.24881554 2.66855192 31.85696 -14.005661 ) (31.494579 -4.33427906 27.608146 -11.33711 -55.791923 12.0170059 ) (31.206764 -9.66288568 -28.183776 0.679895640 35.31073 -10.062366 ) (20.678356 -14.014175 7.1269579 -9.38247109 -19.451011 -31.767528 ) (18.079803 -39.28041 -12.3240547 -41.15 -11.506668 41.132476 ) (0.00241565704 -59.864166 -23.830722 -0.0175195671 11.477674 41.237594 ) (-18.0894699 -39.262886 -12.353048 41.220077 19.59597 -32.08287 ) (-20.644531 -14.084251 7.24292184 9.1372032 -35.861557 -8.9060955 ) (-31.332393 -9.4000969 -28.618637 0.231106251 57.850273 7.70726395 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 160Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:12:38) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((73 246) (73 -98)) NIL ((0 -344. 0 0 0 0 )) NATURAL) (2 ((73 -98) (122 -98)) NIL ((49. 0 0 0 0 0 )) NATURAL) (2 ((122 -98) (122 19)) NIL ((0 117. 0 0 0 0 )) NATURAL) (19 ((122 19) (152 6) (186 -2) (223 -6) (274 -2) (306 10) (330 24) (346 42) (358 66) (367 124) (358 182) (346 206) (330 224) (306 238) (274 250) (223 254) (186 250) (149 241) (122 229)) NIL ((28.78485 -14.1662578 0 0 7.29088879 6.99755765 ) (32.43029 -10.6674785 7.29088879 6.99755765 -12.4544449 -4.9877901 ) (33.493957 -6.1638174 -5.1635561 2.00976705 36.526893 6.95360566 ) (46.593849 -0.677247048 31.363338 8.96337319 -67.653137 1.17336273 ) (44.130615 8.87280656 -36.28981 10.1367359 36.0857 -11.6470565 ) (25.883659 13.186014 -0.204107195 -1.51032066 -10.689651 9.4148655 ) (20.334728 16.383125 -10.8937587 7.90454579 6.67289925 -14.012405 ) (12.777418 17.281471 -4.22085953 -6.10786057 7.9980583 58.63475 ) (12.5555877 40.490989 3.77719927 52.526893 -32.66513 -52.526634 ) (2.22682952E-4 66.75456 -28.887935 2.57580541E-4 32.662468 -52.528175 ) (-12.556476 40.49073 3.77453518 -52.527923 -7.98474026 58.639366 ) (-12.7743129 17.282493 -4.21020508 6.11144925 -6.72350693 -14.029323 ) (-20.346271 16.37928 -10.933712 -7.91787434 10.8787708 9.4779205 ) (-25.840599 13.2003688 -0.0549402982 1.56004619 -36.791572 -11.8823547 ) (-44.291328 8.81923677 -36.846519 -10.322309 70.28755 2.05150032 ) (-45.99407 -0.477321923 33.441032 -8.27080918 -46.358634 3.67635918 ) (-35.73236 -6.9099512 -12.917608 -4.59445 31.147007 1.24306249 ) (-33.076461 -10.8828697 18.2294 -3.3513875 -18.2294 3.3513875 )) NATURAL) (2 ((122 229) (122 246)) NIL ((0 17. 0 0 0 0 )) NATURAL) (2 ((122 246) (73 246)) NIL ((-49. 0 0 0 0 0 )) NATURAL)) ((11 ((121 124) (124 162) (136 195) (162 214) (196 220) (222 222) (244 220) (279 214) (304 195) (316 162) (319 124)) NIL ((1.40951395 38.569053 0 0 9.54291535 -3.41436482 ) (6.1809721 36.861877 9.54291535 -3.41436482 6.28541756 -12.9281749 ) (18.866596 26.983425 15.8283329 -16.34254 -4.68458176 1.12707138 ) (32.352638 11.204418 11.143751 -15.215469 -23.547092 14.419889 ) (31.722843 3.1988945 -12.403341 -0.795579792 2.87295532 -4.80662918 ) (20.755977 -4.17232513E-7 -9.53038598 -5.60220909 36.055267 4.80662918 ) (29.25323 -3.19889498 26.524887 -0.795579315 -45.094047 -14.419889 ) (33.231086 -11.20442 -18.569164 -15.215469 6.32094384 -1.12706756 ) (17.822395 -26.983425 -12.24822 -16.3425369 1.81027794 12.928171 ) (6.47931386 -36.861877 -10.437942 -3.41436482 10.437942 3.41436482 )) NATURAL) (11 ((319 124) (316 86) (304 53) (279 34) (244 28) (222 26) (196 28) (162 34) (136 53) (124 86) (121 124)) NIL ((-1.26034259 -38.569053 0 0 -10.437944 3.41436482 ) (-6.4793148 -36.861877 -10.437944 3.41436482 -1.81027794 12.9281749 ) (-17.822395 -26.983425 -12.248222 16.34254 -6.32094193 -1.12707138 ) (-33.231086 -11.204418 -18.569164 15.215469 45.094047 -14.419889 ) (-29.25323 -3.1988945 26.524887 0.795579792 -36.055267 4.80662918 ) (-20.755977 4.17232513E-7 -9.53038598 5.60220909 -2.87295532 -4.80662918 ) (-31.722843 3.19889498 -12.403341 0.795579315 23.547092 14.419889 ) (-32.352638 11.20442 11.143753 15.215469 4.68457794 1.12706756 ) (-18.866596 26.983425 15.828331 16.3425369 -6.28541566 -12.928171 ) (-6.18097115 36.861877 9.54291535 3.41436482 -9.54291535 -3.41436482 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 161Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:19:54) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((367 -98) (319 -98)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((319 -98) (319 19)) NIL ((0 117. 0 0 0 0 )) NATURAL) (19 ((319 19) (288 7) (255 -1) (217 -6) (166 -2) (134 9) (111 24) (94 42) (82 66) (73 124) (82 182) (94 206) (111 224) (134 239) (166 250) (217 254) (255 250) (292 241) (319 229)) NIL ((-30.485801 -12.997631 0 0 -3.08518171 5.9857931 ) (-32.028389 -10.004734 -3.08518171 5.9857931 3.42590904 -5.92896652 ) (-33.400619 -6.98342515 0.340727687 0.0568262711 -28.618454 11.7300739 ) (-47.369117 -1.06156039 -28.277729 11.786901 63.04792 -4.99134159 ) (-44.122886 8.22966958 34.770195 6.79555989 -31.57326 -3.76470089 ) (-25.13932 13.142879 3.19693089 3.03085899 3.24514675 2.05014229 ) (-20.319816 17.19881 6.44207764 5.08100128 0.592679024 -10.435867 ) (-13.5813999 17.061878 7.03475667 -5.35486698 -11.6158619 57.693328 ) (-12.354574 40.553672 -4.58110619 52.338462 33.870765 -52.337432 ) (-2.96272337E-4 66.723404 29.289665 0.00102418940 -33.867218 -52.34358 ) (12.3557586 40.552642 -4.5775528 -52.342559 11.5981006 57.711776 ) (13.577257 17.065979 7.0205488 5.36921883 -0.525197029 -10.503532 ) (20.335208 17.183429 6.4953518 -5.13431454 -3.49731016 2.30235624 ) (25.081905 13.200292 2.99804163 -2.83195829 32.514434 -4.7058897 ) (44.337165 8.0153904 35.51248 -7.53784848 -66.560455 -1.47879696 ) (46.56941 -0.261858106 -31.047985 -9.01664544 41.727447 4.62108517 ) (36.385154 -6.9679613 10.679462 -4.39556027 -28.349323 0.994450570 ) (32.889953 -10.8662967 -17.66986 -3.4011097 17.66986 3.4011097 )) NATURAL) (2 ((319 229) (319 246)) NIL ((0 17. 0 0 0 0 )) NATURAL) (2 ((319 246) (367 246)) NIL ((48. 0 0 0 0 0 )) NATURAL) (2 ((367 246) (367 -98)) NIL ((0 -344. 0 0 0 0 )) NATURAL)) ((11 ((319 124) (316 162) (304 195) (279 214) (244 220) (220 222) (196 220) (162 214) (136 195) (124 162) (121 124)) NIL ((-1.27691745 38.569053 0 0 -10.338495 -3.41436482 ) (-6.44616604 36.861877 -10.338495 -3.41436482 -2.307518 -12.9281749 ) (-17.938419 26.983425 -12.646013 -16.34254 -4.43143654 1.12707138 ) (-32.800148 11.204418 -17.077449 -15.215469 38.03327 14.419889 ) (-30.860965 3.1988945 20.955825 -0.795579792 -21.701679 -4.80662918 ) (-20.755977 -4.17232513E-7 -0.745855928 -5.60220909 -17.226543 4.80662918 ) (-30.115108 -3.19889498 -17.9724 -0.795579315 30.607864 -14.419889 ) (-32.783577 -11.20442 12.6354656 -15.215469 2.79507446 -1.12706756 ) (-18.750572 -26.983425 15.43054 -16.3425369 -5.78817559 12.928171 ) (-6.21412087 -36.861877 9.6423645 -3.41436482 -9.6423645 3.41436482 )) NATURAL) (11 ((121 124) (124 86) (136 53) (162 34) (196 28) (220 26) (244 28) (279 34) (304 53) (316 86) (319 124)) NIL ((1.39293909 -38.569053 0 0 9.6423645 3.41436482 ) (6.21412087 -36.861877 9.6423645 3.41436482 5.78817749 12.9281749 ) (18.750572 -26.983425 15.430542 16.34254 -2.79507828 -1.12707138 ) (32.783577 -11.204418 12.6354637 15.215469 -30.607864 -14.419889 ) (30.115108 -3.1988945 -17.9724 0.795579792 17.226543 4.80662918 ) (20.755977 4.17232513E-7 -0.745855928 5.60220909 21.701679 -4.80662918 ) (30.860965 3.19889498 20.955825 0.795579315 -38.03327 14.419889 ) (32.800148 11.20442 -17.077449 15.215469 4.43143654 1.12706756 ) (17.938419 26.983425 -12.646013 16.3425369 2.3075161 -12.928171 ) (6.44616509 36.861877 -10.338497 3.41436482 10.338497 -3.41436482 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 162Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:24:15) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((94 0) (94 0) (94 246)) NIL ((0 -61.5 0 0 0 369. ) (0 123. 0 369. 0 -369. )) NATURAL) (2 ((94 246) (146 246)) NIL ((52. 0 0 0 0 0 )) NATURAL) (2 ((146 246) (146 231)) NIL ((0 -15. 0 0 0 0 )) NATURAL) (11 ((146 231) (172 241) (200 250) (226 254) (258 256) (286 253) (315 245) (334 236) (349 224) (361 208) (369 187)) NIL ((25.179721 9.92842675 0 0 4.92166043 0.429432392 ) (27.640552 10.1431427 4.92166043 0.429432392 -12.608301 -8.14716149 ) (26.25806 6.49899483 -7.6866417 -7.71772957 21.51155 8.15921594 ) (29.327194 2.8608737 13.824909 0.441486776 -25.4379 -6.48970318 ) (30.43315 0.0575087815 -11.612993 -6.04821683 20.240062 -0.200402260 ) (28.940189 -6.090909 8.62707139 -6.24861909 -25.522361 7.29131127 ) (24.806079 -8.69387246 -16.89529 1.04269218 15.849386 -4.96484089 ) (15.835481 -10.1336 -1.04590392 -3.92214918 -1.87518859 0.568055630 ) (13.851984 -13.7717228 -2.9210925 -3.35409355 -2.34863329 -3.30738258 ) (9.7565746 -18.779506 -5.2697258 -6.66147614 5.2697258 6.66147614 )) NATURAL) (2 ((369 187) (370 169)) NIL ((1. -18. 0 0 0 0 )) NATURAL) (2 ((370 169) (321 169)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (10 ((321 169) (319 191) (307 205) (288 215) (259 220) (235 221) (209 219) (178 212) (155 193) (146 160)) NIL ((0.395535767 23.935108 0 0 -14.3732147 -11.6106548 ) (-6.79107094 18.129779 -14.3732147 -11.6106548 11.8660736 10.053274 ) (-15.2312488 11.545763 -2.50714111 -1.55738067 -15.091079 -4.60244179 ) (-25.283931 7.68716145 -17.59822 -6.15982247 30.498256 2.35649347 ) (-27.633022 2.70558596 12.9000358 -3.80332899 -16.901958 1.1764698 ) (-23.183967 -0.509507895 -4.00192356 -2.62685919 -4.89041806 -1.06237459 ) (-29.631099 -3.66755486 -8.8923416 -3.68923378 18.46363 -8.9269695 ) (-29.291626 -11.820274 9.57129098 -12.616203 9.03588296 -5.22974015 ) (-15.20239 -27.051349 18.6071739 -17.845943 -18.6071739 17.845943 )) NATURAL) (2 ((146 160) (146 0)) NIL ((0 -160. 0 0 0 0 )) NATURAL) (2 ((146 0) (94 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 163Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:34:01) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((25 ((351 186) (346 202) (336 220) (306 238) (265 250) (223 254) (183 252) (148 246) (120 234) (106 222) (94 204) (90 183) (96 165) (121 142) (175 120) (226 103) (277 85) (295 58) (281 32) (238 25) (210 26) (171 31) (138 42) (122 59) (117 73)) NIL ((-4.89096356 15.5457267 0 0 -0.654214859 2.72563505 ) (-5.21807099 16.908542 -0.654214859 2.72563505 -26.728923 -1.62817669 ) (-19.236747 18.820091 -27.38314 1.09745836 17.569915 -8.21292687 ) (-37.83493 15.811084 -9.8132229 -7.11546899 10.4492588 -1.52011108 ) (-42.423522 7.9355602 0.636036754 -8.63558007 0.633041024 2.29337406 ) (-41.470962 0.446667433 1.26907777 -6.342206 5.0185728 4.34661293 ) (-37.692596 -3.72223234 6.28765107 -1.99559283 -2.70733642 -7.67982579 ) (-32.758613 -9.55773736 3.58031464 -9.67541886 17.810775 14.372688 ) (-20.272914 -12.046812 21.39109 4.69726944 -26.535766 -13.81093 ) (-12.1497097 -14.2550087 -5.1446762 -9.1136608 16.3322868 4.87103844 ) (-9.1282406 -20.933151 11.187612 -4.24262238 -2.79339218 12.326774 ) (0.662676096 -19.012386 8.39422036 8.0841522 6.8412819 -18.178138 ) (12.477537 -20.017303 15.235502 -10.0939865 29.428268 12.385782 ) (42.427177 -23.918396 44.663772 2.2917962 -64.554397 4.63500405 ) (54.81375 -19.309097 -19.890628 6.92680073 36.789367 -6.92580319 ) (53.3178 -15.845199 16.8987388 9.97102587E-4 -64.603057 -12.9317836 ) (37.915008 -22.310096 -47.704322 -12.930788 23.622894 10.6529445 ) (2.02213144 -29.914409 -24.081428 -2.27784204 -23.888504 30.319995 ) (-34.003547 -17.032253 -47.969932 28.042156 89.931106 -23.932937 ) (-37.007927 -0.956568003 41.961174 4.10921669 -71.835937 -0.588241577 ) (-30.964725 2.85852814 -29.874763 3.52097511 41.412643 2.28590584 ) (-40.133163 7.52245618 11.5378837 5.80688095 8.1853447 3.44461632 ) (-24.502605 15.051645 19.723228 9.25149728 -8.15403558 -16.064369 ) (-8.8563976 16.2709579 11.5691928 -6.81287385 -11.5691928 6.81287385 )) NATURAL) (2 ((117 73) (72 73)) NIL ((-45. 0 0 0 0 0 )) NATURAL) (24 ((72 73) (85 42) (112 15) (144 1) (183 -7) (222 -8) (261 -7) (296 0) (325 13) (349 37) (355 66) (348 95) (330 114) (292 131) (238 148) (187 165) (151 184) (156 213) (188 221) (213 223) (241 221) (277 214) (297 202) (303 186)) NIL ((9.47211839 -31.218654 0 0 21.167285 1.31194877 ) (20.055763 -30.562683 21.167285 1.31194877 -21.836437 17.440254 ) (30.304828 -20.530601 -0.669154763 18.752204 12.1784839 -17.072986 ) (35.724914 -10.3148918 11.5093307 1.67921805 -14.877496 8.8516998 ) (39.795494 -4.20982266 -3.3681674 10.530918 5.33150673 -12.3338146 ) (39.093078 0.154187590 1.96334004 -1.80289674 -6.4485321 10.483564 ) (37.832153 3.59307385 -4.4851923 8.68066789 -3.53737736 -5.60044766 ) (31.578277 9.47351838 -8.02256967 3.08022022 8.59804345 11.918224 ) (27.854728 18.512851 0.575473786 14.998445 -24.854797 -12.0724487 ) (16.0028 27.47507 -24.279323 2.9259963 12.821157 0.371571064 ) (-1.86594367 30.586853 -11.458166 3.29756737 3.57016087 -19.413829 ) (-11.539028 24.177501 -7.88800526 -16.116264 -15.101804 17.28376 ) (-26.977935 16.703121 -22.98981 1.16749811 2.83706665 -1.72122335 ) (-48.549217 17.0100059 -20.152744 -0.553725243 27.753543 1.6011281 ) (-54.825187 17.256843 7.6008024 1.04740286 0.148731231 -4.68328858 ) (-47.150016 15.962604 7.74953366 -3.63588619 43.651519 29.132022 ) (-17.574722 26.89273 51.401054 25.496139 -18.754821 -63.84481 ) (24.448917 20.466461 32.646232 -38.34867 -52.632209 40.247222 ) (30.779045 2.24140549 -19.985977 1.89855599 25.283653 -7.1441021 ) (23.434894 0.567910671 5.297678 -5.24554634 11.497587 0.329174995 ) (34.48136 -4.51304817 16.795265 -4.91637135 -41.274002 -0.172595977 ) (30.639629 -9.51571656 -24.478736 -5.08896733 9.598423 0.361209869 ) (10.9601039 -14.4240799 -14.8803138 -4.72775746 14.8803138 4.72775746 )) NATURAL) (2 ((303 186) (351 186)) NIL ((48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 164Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:41:54) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((215 316) (169 316)) NIL ((-46. 0 0 0 0 0 )) NATURAL) (2 ((169 316) (169 246)) NIL ((0 -70. 0 0 0 0 )) NATURAL) (2 ((169 246) (73 246)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((73 246) (73 210)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((73 210) (169 210)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((169 210) (169 60)) NIL ((0 -150. 0 0 0 0 )) NATURAL) (11 ((169 60) (175 39) (189 20) (205 7) (229 -3) (268 -9) (316 -6) (346 3) (367 20) (381 38) (388 69)) NIL ((3.90507937 -21.153274 0 0 12.5695228 0.919651986 ) (10.18984 -20.693447 12.5695228 0.919651986 -14.847616 7.40174008 ) (15.335556 -16.072925 -2.27809334 8.32139207 10.8209438 -6.526618 ) (18.467933 -11.014843 8.5428505 1.79477358 7.56383896 0.704737187 ) (30.792705 -8.86770059 16.106689 2.49951076 0.923694611 9.7076702 ) (47.361244 -1.51435375 17.030384 12.2071819 -47.258613 -9.53542138 ) (40.762313 5.92511654 -30.228233 2.67175913 26.110794 10.434017 ) (23.589481 13.8138847 -4.1174364 13.1057777 -3.1845789 -20.200649 ) (17.879753 16.8193359 -7.3020153 -7.09487343 -1.37248039 28.368587 ) (9.89149858 23.90876 -8.6744957 21.273715 8.6744957 -21.273715 )) NATURAL) (2 ((388 69) (340 69)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (8 ((340 69) (337 47) (325 33) (303 27) (272 25) (245 29) (222 40) (215 60)) NIL ((-1.11267614 -23.621776 0 0 -11.323942 9.73067666 ) (-6.7746477 -18.756439 -11.323942 9.73067666 2.61971664 -0.653385163 ) (-16.78873 -9.35245515 -8.70422555 9.0772915 -5.1549282 -7.1171398 ) (-28.070419 -3.83373404 -13.8591537 1.96015119 23.999996 5.12195015 ) (-29.929576 0.687392831 10.140844 7.0821018 -12.8450699 -1.37066269 ) (-26.211265 7.08416367 -2.70422554 5.71143914 27.380279 6.3607006 ) (-15.225351 15.975952 24.676055 12.0721397 -24.676055 -12.0721397 )) NATURAL) (2 ((215 60) (215 210)) NIL ((0 150. 0 0 0 0 )) NATURAL) (2 ((215 210) (334 210)) NIL ((119. 0 0 0 0 0 )) NATURAL) (2 ((334 210) (334 246)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((334 246) (215 246)) NIL ((-119. 0 0 0 0 0 )) NATURAL) (2 ((215 246) (215 316)) NIL ((0 70. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 165Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:50:36) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((367 0) (367 0) (367 246)) NIL ((0 -61.5 0 0 0 369. ) (0 123. 0 369. 0 -369. )) NATURAL) (2 ((367 246) (316 246)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((316 246) (316 90)) NIL ((0 -156. 0 0 0 0 )) NATURAL) (9 ((316 90) (308 59) (278 39) (243 30) (222 29) (196 29) (161 33) (132 49) (123 90)) NIL ((-2.74641037 -33.309829 0 0 -31.521537 13.858984 ) (-18.507179 -26.380336 -31.521537 13.858984 25.607692 -3.29491997 ) (-37.224868 -14.1688137 -5.91384316 10.564064 31.090755 -0.679307938 ) (-27.593334 -3.94440317 25.176914 9.8847561 -35.970726 -11.987848 ) (-20.401783 -0.0535713807 -10.7938156 -2.10309267 -1.20783996 6.63070584 ) (-31.799518 1.1586895 -12.001655 4.52761364 16.802093 3.46502209 ) (-35.400123 7.41881467 4.80043888 7.9926357 23.99945 27.5092 ) (-18.599964 29.166053 28.799892 35.501838 -28.799892 -35.501838 )) NATURAL) (2 ((123 90) (123 246)) NIL ((0 156. 0 0 0 0 )) NATURAL) (2 ((123 246) (75 246)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((75 246) (76 59)) NIL ((1. -187. 0 0 0 0 )) NATURAL) (11 ((76 59) (82 35) (96 18) (114 5) (141 -4) (175 -8) (204 -9) (235 -6) (258 -1) (277 7) (316 23)) NIL ((4.01473713 -25.642467 0 0 11.911575 9.85482026 ) (9.9705238 -20.715057 11.911575 9.85482026 -11.5578765 -7.27410126 ) (16.1031608 -14.497289 0.353697181 2.58071852 10.3199367 1.24158621 ) (21.616828 -11.295776 10.673635 3.82230473 0.278120041 2.30775452 ) (32.429519 -6.31959534 10.951755 6.13005925 -23.432415 -4.47259999 ) (31.665069 -2.42583704 -12.480661 1.65745854 21.451553 3.5826478 ) (29.910186 1.02294540 8.97089387 5.24010659 -20.373809 -3.85799217 ) (28.694175 4.3340559 -11.4029178 1.38211417 0.0436954498 -0.150678157 ) (17.313106 5.640831 -11.359222 1.23143601 44.199028 10.4607029 ) (28.053398 12.102619 32.839805 11.6921405 -32.839805 -11.6921405 )) NATURAL) (2 ((316 23) (316 0)) NIL ((0 -23. 0 0 0 0 )) NATURAL) (2 ((316 0) (367 0)) NIL ((51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 166Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:55:45) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((55 246) (195 0)) NIL ((140. -246. 0 0 0 0 )) NATURAL) (2 ((195 0) (242 0)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((242 0) (382 246)) NIL ((140. 246. 0 0 0 0 )) NATURAL) (2 ((382 246) (328 246)) NIL ((-54. 0 0 0 0 0 )) NATURAL) (2 ((328 246) (219 41)) NIL ((-109. -205. 0 0 0 0 )) NATURAL) (2 ((219 41) (110 246)) NIL ((-109. 205. 0 0 0 0 )) NATURAL) (2 ((110 246) (55 246)) NIL ((-55. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 167Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:57:51) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((25 246) (124 0)) NIL ((99. -246. 0 0 0 0 )) NATURAL) (2 ((124 0) (175 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((175 0) (219 146)) NIL ((44. 146. 0 0 0 0 )) NATURAL) (2 ((219 146) (262 0)) NIL ((43. -146. 0 0 0 0 )) NATURAL) (2 ((262 0) (313 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((313 0) (412 246)) NIL ((99. 246. 0 0 0 0 )) NATURAL) (2 ((412 246) (361 246)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((361 246) (286 62)) NIL ((-75. -184. 0 0 0 0 )) NATURAL) (2 ((286 62) (237 246)) NIL ((-49. 184. 0 0 0 0 )) NATURAL) (2 ((237 246) (201 246)) NIL ((-36. 0 0 0 0 0 )) NATURAL) (2 ((201 246) (151 62)) NIL ((-50. -184. 0 0 0 0 )) NATURAL) (2 ((151 62) (77 246)) NIL ((-74. 184. 0 0 0 0 )) NATURAL) (2 ((77 246) (25 246)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 170Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 10:01:04) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((76 246) (190 139)) NIL ((114. -107. 0 0 0 0 )) NATURAL) (2 ((190 139) (43 0)) NIL ((-147. -139. 0 0 0 0 )) NATURAL) (2 ((43 0) (98 0)) NIL ((55. 0 0 0 0 0 )) NATURAL) (2 ((98 0) (219 109)) NIL ((121. 109. 0 0 0 0 )) NATURAL) (2 ((219 109) (340 0)) NIL ((121. -109. 0 0 0 0 )) NATURAL) (2 ((340 0) (394 0)) NIL ((54. 0 0 0 0 0 )) NATURAL) (2 ((394 0) (248 139)) NIL ((-146. 139. 0 0 0 0 )) NATURAL) (2 ((248 139) (361 246)) NIL ((113. 107. 0 0 0 0 )) NATURAL) (2 ((361 246) (305 246)) NIL ((-56. 0 0 0 0 0 )) NATURAL) (2 ((305 246) (219 164)) NIL ((-86. -82. 0 0 0 0 )) NATURAL) (2 ((219 164) (132 246)) NIL ((-87. 82. 0 0 0 0 )) NATURAL) (2 ((132 246) (76 246)) NIL ((-56. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 171Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 10:03:58) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((67 246) (207 3)) NIL ((140. -243. 0 0 0 0 )) NATURAL) (8 ((207 3) (204 -28) (182 -55) (154 -65) (130 -67) (105 -63) (78 -50) (65 -25)) NIL ((1.58570909 -30.982479 0 0 -27.514255 -0.105117797 ) (-12.171417 -31.035038 -27.514255 -0.105117797 23.571277 24.525589 ) (-27.900032 -18.877357 -3.94297457 24.420471 11.2291298 -19.997249 ) (-26.228443 -4.455513 7.2861557 4.42322159 -8.4878044 1.4634161 ) (-23.186187 0.699416161 -1.20164919 5.88663769 -7.27790929 2.14358997 ) (-28.026794 7.65785027 -8.47955895 8.03022767 31.599445 7.9622154 ) (-20.706626 19.669185 23.119888 15.992443 -23.119888 -15.992443 )) NATURAL) (2 ((65 -25) (18 -25)) NIL ((-47. 0 0 0 0 0 )) NATURAL) (9 ((18 -25) (33 -57) (60 -81) (88 -95) (138 -101) (195 -91) (232 -69) (253 -38) (274 3)) NIL ((11.490978 -33.511222 0 0 21.054122 9.0673771 ) (22.018039 -28.977539 21.054122 9.0673771 -33.270614 2.66310882 ) (26.436855 -18.578605 -12.2164936 11.7304859 46.028343 -7.71980954 ) (37.234535 -10.7080249 33.81185 4.01067639 -24.842777 16.216125 ) (58.625 1.41071462 8.96907235 20.226802 -36.65721 -9.1446972 ) (49.265457 17.065166 -27.688144 11.0821056 9.47165299 -3.63733387 ) (26.31314 26.328605 -18.216491 7.44477177 22.770614 5.69403363 ) (19.481956 36.620391 4.55412293 13.138805 -4.55412293 -13.138805 )) NATURAL) (2 ((274 3) (394 246)) NIL ((120. 243. 0 0 0 0 )) NATURAL) (2 ((394 246) (340 246)) NIL ((-54. 0 0 0 0 0 )) NATURAL) (2 ((340 246) (241 37)) NIL ((-99. -209. 0 0 0 0 )) NATURAL) (2 ((241 37) (122 246)) NIL ((-119. 209. 0 0 0 0 )) NATURAL) (2 ((122 246) (67 246)) NIL ((-55. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 172Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 10:05:23) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((81 246) (369 246)) NIL ((288. 0 0 0 0 0 )) NATURAL) (2 ((369 246) (369 212)) NIL ((0 -34. 0 0 0 0 )) NATURAL) (2 ((369 212) (140 36)) NIL ((-229. -176. 0 0 0 0 )) NATURAL) (2 ((140 36) (378 36)) NIL ((238. 0 0 0 0 0 )) NATURAL) (2 ((378 36) (378 0)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((378 0) (63 0)) NIL ((-315. 0 0 0 0 0 )) NATURAL) (2 ((63 0) (63 34)) NIL ((0 34. 0 0 0 0 )) NATURAL) (2 ((63 34) (292 210)) NIL ((229. 176. 0 0 0 0 )) NATURAL) (2 ((292 210) (81 210)) NIL ((-211. 0 0 0 0 0 )) NATURAL) (2 ((81 210) (81 246)) NIL ((0 36. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.NUM-SF b/lispusers/GACHAE.NUM-SF new file mode 100644 index 00000000..af6370f4 --- /dev/null +++ b/lispusers/GACHAE.NUM-SF @@ -0,0 +1 @@ + ((FAMILY gacha) (CHARACTER 60Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 11:56:36) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((29 ((220 -2) (177 2) (142 13) (115 28) (97 49) (87 72) (78 108) (72 169) (78 230) (87 266) (97 289) (115 310) (142 325) (177 336) (220 340) (264 336) (298 325) (325 308) (343 289) (354 266) (363 230) (369 169) (363 108) (354 72) (343 49) (325 28) (298 13) (264 2) (220 -2)) NIL ((-44.70249 2.2971487 0 0 10.2149925 10.2171058 ) (-39.595 7.4057026 10.2149925 10.2171058 -3.07496834 -9.08553506 ) (-30.917491 13.0800399 7.14002419 1.13156938 2.08488273 8.12504388 ) (-22.735023 18.274131 9.2249069 9.25661469 0.735431671 -11.4146518 ) (-13.1424007 21.823421 9.9603386 -2.15803718 -11.0266018 13.533569 ) (-8.695364 26.43217 -1.06626343 11.375532 1.37097907 23.280372 ) (-9.07613755 49.44789 0.304715693 34.655906 17.542682 -34.655075 ) (-7.94418156E-5 66.776245 17.8474 8.27937503E-4 -17.541725 -34.660041 ) (9.07645799 49.447059 0.305675328 -34.659217 -1.37578034 23.295288 ) (8.69424249 26.435485 -1.07010507 -11.3639278 11.044849 13.478868 ) (13.146564 21.810989 9.9747448 2.11494064 -0.803623200 -11.210775 ) (22.719497 18.320545 9.1711216 -9.09583474 -1.83035755 7.36423016 ) (30.97544 12.906824 7.34076405 -1.73160457 2.12505627 -6.24614144 ) (39.37873 8.0521488 9.4658203 -7.977746 -6.6698742 -0.379662514 ) (45.509613 -0.115427330 2.79594612 -8.3574085 -17.445552 1.76478958 ) (39.582786 -7.59044076 -14.649606 -6.59261895 10.452091 -0.679496765 ) (30.159225 -14.522808 -4.19751454 -7.2721157 -6.3628168 6.95319844 ) (22.7803 -18.318321 -10.560331 -0.318916559 2.99917793 -3.13330078 ) (13.7195587 -20.203891 -7.5611534 -3.45221758 6.3660984 -6.4199934 ) (9.34145547 -26.866107 -1.19505500 -9.87221147 1.53642988 -25.186718 ) (8.91461564 -49.331672 0.341374993 -35.058929 -18.5118179 35.166854 ) (7.89556652E-5 -66.807174 -18.170444 0.107930347 18.510856 34.519271 ) (-8.91493608 -49.439598 0.340415239 34.627204 -1.53162884 -23.243984 ) (-9.34033395 -26.434387 -1.19121360 11.3832206 -6.38434506 -13.5433178 ) (-13.723722 -21.822826 -7.57555867 -2.1600976 -2.93098736 11.4172649 ) (-22.764774 -18.274292 -10.506546 9.2571678 6.10829259 -8.12574578 ) (-30.217174 -13.079996 -4.39825344 1.13142156 -9.5021801 9.08572198 ) (-39.366516 -7.40571404 -13.900434 10.217144 13.900434 -10.217144 )) NATURAL)) ((15 ((117 169) (117 139) (120 107) (126 75) (143 52) (165 38) (195 29) (220 28) (245 29) (275 38) (298 52) (314 75) (320 107) (323 139) (323 169)) NIL ((-0.787026048 -29.594802 0 0 4.72215653 -2.43117809 ) (1.57405233 -30.81039 4.72215653 -2.43117809 -5.61078453 0.155890941 ) (3.49081659 -33.16362 -0.888628126 -2.27528715 17.720981 13.807613 ) (11.4626827 -28.535102 16.832355 11.5323276 -17.2731628 -1.38635635 ) (19.658454 -17.695949 -0.440809131 10.145971 15.371683 -8.2621956 ) (26.903488 -11.6810779 14.9308757 1.88377571 -26.213573 10.435146 ) (28.727577 -4.57973004 -11.2826976 12.318922 11.482616 -15.478382 ) (23.186187 1.59256160E-7 0.199920326 -3.15946055 10.283096 15.47838 ) (28.527656 4.57973004 10.4830169 12.31892 -22.615001 -10.435144 ) (27.70317 11.6810779 -12.1319866 1.88377547 8.17691995 8.2621975 ) (19.659645 17.695953 -3.95506573 10.145973 -10.0926818 1.38635444 ) (10.658237 28.535102 -14.047748 11.5323276 14.193815 -13.807615 ) (3.70739698 33.16362 0.146066695 -2.27528763 -4.68258286 -0.155889988 ) (1.51217198 30.81039 -4.53651619 -2.43117761 4.53651619 2.43117761 )) NATURAL) (15 ((323 169) (323 199) (320 231) (314 263) (298 286) (275 300) (245 309) (220 310) (195 309) (165 300) (143 286) (126 263) (120 231) (117 199) (117 169)) NIL ((0.756085992 29.594802 0 0 -4.53651619 2.43117809 ) (-1.51217222 30.81039 -4.53651619 2.43117809 4.6825819 -0.155890941 ) (-3.70739698 33.16362 0.146066278 2.27528715 -14.193813 -13.807613 ) (-10.658239 28.535102 -14.047748 -11.5323276 10.0926818 1.38635635 ) (-19.659645 17.695949 -3.95506573 -10.145971 -8.17691995 8.2621956 ) (-27.70317 11.6810779 -12.1319866 -1.88377571 22.615001 -10.435146 ) (-28.527656 4.57973004 10.4830169 -12.318922 -10.283094 15.478382 ) (-23.186187 -1.59256160E-7 0.199920833 3.15946055 -11.48262 -15.47838 ) (-28.727577 -4.57973004 -11.2826995 -12.31892 26.213577 10.435144 ) (-26.903488 -11.6810779 14.930877 -1.88377547 -15.3716869 -8.2621975 ) (-19.658454 -17.695953 -0.440809786 -10.145973 17.273166 -1.38635444 ) (-11.4626808 -28.535102 16.832359 -11.5323276 -17.720985 13.807615 ) (-3.49081612 -33.16362 -0.888629199 2.27528763 5.61078549 0.155889988 ) (-1.57405209 -30.81039 4.72215653 2.43117761 -4.72215653 -2.43117761 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 61Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 11:58:51) (MADE-FROM gachan.cu 0 140 10 925) (SPLINES ((3 ((124 0) (124 0) (367 0)) NIL ((-60.75 0 0 0 364.5 0 ) (121.5 0 364.5 0 -364.5 0 )) NATURAL) (2 ((367 0) (367 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((367 36) (273 36)) NIL ((-94. 0 0 0 0 0 )) NATURAL) (2 ((273 36) (273 337)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((273 337) (210 337)) NIL ((-63. 0 0 0 0 0 )) NATURAL) (2 ((210 337) (78 246)) NIL ((-132. -91. 0 0 0 0 )) NATURAL) (2 ((78 246) (134 246)) NIL ((56. 0 0 0 0 0 )) NATURAL) (2 ((134 246) (220 303)) NIL ((86. 57. 0 0 0 0 )) NATURAL) (2 ((220 303) (220 36)) NIL ((0 -267. 0 0 0 0 )) NATURAL) (2 ((220 36) (124 36)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((124 36) (124 0)) NIL ((0 -36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 62Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:24:12) (MADE-FROM gachan.cu 0 140 10 925) (SPLINES ((3 ((367 0) (367 0) (73 0)) NIL ((73.5 0 0 0 -441. 0 ) (-147. 0 -441. 0 441. 0 )) NATURAL) (2 ((73 0) (73 50)) NIL ((0 50. 0 0 0 0 )) NATURAL) (17 ((73 50) (78 70) (90 89) (123 114) (152 134) (189 159) (230 186) (269 212) (303 239) (306 270) (290 291) (260 301) (216 305) (179 301) (155 293) (137 280) (130 264)) NIL ((4.74380017 20.817619 0 0 1.53719520 -4.90571976 ) (5.51239777 18.364757 1.53719520 -4.90571976 34.314018 18.528598 ) (24.206604 22.723339 35.851219 13.622879 -54.793289 -27.208679 ) (32.66117 22.741878 -18.942073 -13.5858 34.85916 24.306118 ) (31.148681 21.309139 15.917087 10.7203178 -12.643362 -10.0157985 ) (40.744087 27.021556 3.27372408 0.704518795 -8.28570748 -2.24291372 ) (39.874954 26.604618 -5.01198483 -1.53839493 9.78619767 0.987456680 ) (39.756073 25.559951 4.77421379 -0.550938249 -48.859077 10.293085 ) (20.100742 30.155559 -44.084869 9.74214746 29.650135 -24.159797 ) (-9.1590557 27.817802 -14.434732 -14.417652 2.25853729 2.34612083 ) (-22.464519 14.573211 -12.176195 -12.071531 -8.6842861 8.77531434 ) (-38.982856 6.8893385 -20.860481 -3.29621697 32.478599 -7.44738007 ) (-43.604034 -0.130568802 11.61812 -10.743597 4.7698803 9.014204 ) (-29.600975 -6.36706353 16.388 -1.729393 -15.558134 -4.60943508 ) (-20.992042 -10.4011745 0.829866291 -6.33882809 15.462663 3.42353535 ) (-12.430843 -15.028234 16.29253 -2.91529274 -16.29253 2.91529274 )) NATURAL) (2 ((130 264) (130 239)) NIL ((0 -25. 0 0 0 0 )) NATURAL) (2 ((130 239) (82 239)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((82 239) (82 269)) NIL ((0 30. 0 0 0 0 )) NATURAL) (20 ((82 269) (90 291) (105 308) (129 322) (159 331) (216 338) (273 332) (307 320) (331 305) (348 282) (354 247) (341 216) (312 189) (282 167) (246 143) (211 120) (181 101) (149 81) (131 65) (125 43)) NIL ((6.78662205 23.226146 0 0 7.2802677 -7.356884 ) (10.4267559 19.547702 7.2802677 -7.356884 5.5986595 6.78442288 ) (20.506351 15.58303 12.878927 -0.572460413 -17.6749038 -7.78081227 ) (24.547828 11.1201629 -4.79597855 -8.3532734 47.100959 12.3388309 ) (43.30233 8.936306 42.304985 3.9855585 -44.728965 -23.574516 ) (63.242828 1.13460397 -2.42398405 -19.588958 -30.185062 15.959251 ) (45.72631 -10.4747276 -32.609046 -3.62970686 27.469234 1.73749709 ) (26.851886 -13.235687 -5.1398096 -1.89220977 -1.69189834 -4.90924263 ) (20.866127 -17.582519 -6.83170796 -6.80145264 -2.70164585 -12.100521 ) (12.6835956 -30.434234 -9.5333538 -18.901973 -11.501516 29.311332 ) (-2.60051441 -34.680542 -21.03487 10.4093589 0.707698822 -9.14481927 ) (-23.281532 -28.843593 -20.327171 1.26453852 26.670726 7.2679472 ) (-30.273342 -23.945079 6.3435564 8.53248597 -17.390609 -13.926967 ) (-32.62509 -22.376079 -11.047054 -5.39448166 12.891712 6.4399252 ) (-37.226287 -24.550598 1.84465909 1.04544425 7.82375527 6.1672592 ) (-31.469749 -20.421524 9.66841508 7.2127037 -20.186737 -13.108963 ) (-31.894702 -19.763301 -10.5183239 -5.8962593 30.923206 16.2685928 ) (-26.951423 -17.5252609 20.404884 10.372335 -7.50610734 -21.965419 ) (-10.299591 -18.135635 12.898777 -11.593084 -12.898777 11.593084 )) NATURAL) (2 ((125 43) (367 43)) NIL ((242. 0 0 0 0 0 )) NATURAL) (2 ((367 43) (367 0)) NIL ((0 -43. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 63Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:24:51) (MADE-FROM gachan.cu 0 140 10 925) (SPLINES ((2 ((61 99) (111 99)) NIL ((50. 0 0 0 0 0 )) NATURAL) (16 ((111 99) (111 75) (126 51) (153 39) (188 35) (213 34) (238 35) (272 39) (299 48) (319 70) (323 97) (317 126) (304 143) (281 155) (251 161) (226 161)) NIL ((-3.35919046 -23.278705 0 0 20.155143 -4.32776165 ) (6.71838284 -25.442585 20.155143 -4.32776165 -10.775732 21.638805 ) (21.48566 -18.950939 9.3794117 17.311046 4.94778824 -10.2274837 ) (33.338966 -6.7536373 14.3271999 7.0835619 -33.01541 -4.72886086 ) (31.158458 -2.03450584 -18.688217 2.35470104 19.11388 -0.857067586 ) (22.027183 -0.108338594 0.425663412 1.49763345 16.559894 2.15713119 ) (30.732795 2.4678607 16.985561 3.65476465 -31.353477 -1.77145815 ) (32.041618 5.2368965 -14.367916 1.8833065 12.854017 16.928699 ) (24.100711 15.584554 -1.51389813 18.812007 -20.062587 -17.943359 ) (12.555519 25.42488 -21.576488 0.868646980 13.396343 6.8447523 ) (-2.32279682 29.715908 -8.18014527 7.71339989 2.47721863 -27.435646 ) (-9.2643337 23.711479 -5.70292664 -19.722248 -5.30521584 18.89785 ) (-17.619869 13.438158 -11.008142 -0.824397088 0.743648529 -6.1557617 ) (-28.256187 9.53587915 -10.2644939 -6.9801588 20.330616 -0.274801254 ) (-28.355373 2.4183197 10.0661239 -7.25496007 -10.0661239 7.25496007 )) NATURAL) (2 ((226 161) (166 161)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (3 ((166 161) (166 197) (166 197)) NIL ((0 45. 0 0 0 -54. ) (0 18. 0 -54. 0 54. )) NATURAL) (2 ((166 197) (216 197)) NIL ((50. 0 0 0 0 0 )) NATURAL) (15 ((216 197) (241 197) (269 204) (289 217) (298 235) (301 260) (290 283) (268 297) (232 303) (210 303) (187 303) (149 297) (133 286) (125 272) (125 252)) NIL ((23.819458 -1.50491333 0 0 7.08323479 9.02947999 ) (27.361076 3.00982666 7.08323479 9.02947999 -17.416175 -3.14740086 ) (25.736225 10.4656067 -10.332941 5.88207913 -3.4185276 -2.43987894 ) (13.694019 15.127746 -13.751468 3.44220018 13.090288 6.9069147 ) (6.48769475 22.023403 -0.661179662 10.349115 -18.9426269 -13.187776 ) (-3.64480162 25.778629 -19.603809 -2.83866167 14.6802387 -8.1558056 ) (-15.908493 18.862064 -4.92357064 -10.9944687 -21.778327 3.8110094 ) (-31.721229 9.7731018 -26.7019 -7.18345929 54.43308 -1.08823299 ) (-31.206584 2.0455246 27.731185 -8.27169229 -27.954029 12.541927 ) (-17.452415 0.0447963029 -0.222843975 4.27023506 -32.616958 -13.079483 ) (-33.983741 -2.22471094 -32.839805 -8.80924798 74.42189 3.77601147 ) (-29.612598 -9.1459522 41.582084 -5.0332365 -43.07064 3.97543287 ) (-9.56583596 -12.191473 -1.48855781 -1.05780363 13.8606968 -7.6777439 ) (-4.12404633 -17.08815 12.3721389 -8.735548 -12.3721389 8.735548 )) NATURAL) (2 ((125 252) (82 252)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (2 ((82 252) (82 277)) NIL ((0 25. 0 0 0 0 )) NATURAL) (15 ((82 277) (91 294) (108 310) (132 323) (163 332) (213 337) (259 333) (295 323) (321 307) (339 284) (346 254) (342 230) (331 210) (312 190) (294 179)) NIL ((7.3249216 17.1195678 0 0 10.0504665 -0.717417956 ) (12.3501548 16.76086 10.0504665 -0.717417956 -2.25233459 -2.41290998 ) (21.274452 14.836986 7.79813195 -3.13032818 -7.04112816 -1.63093948 ) (25.55202 10.8911876 0.757003189 -4.76126766 30.41685 2.93666792 ) (41.517448 7.59825516 31.173854 -1.8245995 -42.626266 -10.115734 ) (51.378166 0.715788484 -11.452417 -11.940334 2.08823204 7.5262718 ) (40.969863 -7.4614105 -9.36418534 -4.4140625 -1.72665214 -1.98934936 ) (30.742355 -12.8701477 -11.090837 -6.40341187 4.81837368 0.431121826 ) (22.060703 -19.057998 -6.2724638 -5.97229004 -5.5468378 -5.73513413 ) (13.014822 -27.897853 -11.8193016 -11.707424 -0.631027222 22.50941 ) (0.880005479 -28.35057 -12.4503288 10.8019886 8.07095338 -6.3025217 ) (-7.53484727 -20.699844 -4.37937546 4.4994669 -7.65279008 -9.29932405 ) (-15.740617 -20.85004 -12.032165 -4.79985714 16.5402069 19.499816 ) (-19.502677 -15.899986 4.50804138 14.699962 -4.50804138 -14.699962 )) NATURAL) (15 ((294 179) (331 161) (354 138) (364 115) (367 90) (360 61) (339 32) (316 16) (279 3) (216 -2) (159 1) (117 12) (90 28) (72 50) (63 71)) NIL ((39.920318 -16.637714 0 0 -17.5219269 -8.17371179 ) (31.159355 -20.724571 -17.5219269 -8.17371179 3.60964584 10.8685646 ) (15.442251 -23.464 -13.912281 2.6948533 9.08333589 -5.30055332 ) (6.07163716 -23.419422 -4.82894516 -2.60570001 -3.94299126 -1.66635275 ) (-0.728803635 -26.858299 -8.7719364 -4.27205277 -11.3113689 -0.0340318680 ) (-15.156425 -31.147369 -20.083305 -4.30608464 25.188472 25.802475 ) (-22.645492 -22.552211 5.10516835 21.496391 -17.442531 -25.17588 ) (-26.261592 -13.643764 -12.337366 -3.679492 -27.41833 14.9010658 ) (-52.308128 -9.8727226 -39.755699 11.2215747 55.115875 -4.42838192 ) (-64.505874 -0.865339280 15.360178 6.79319287 -1.04520416 2.81245708 ) (-49.668304 7.3340826 14.3149738 9.60564996 3.0649395 -6.82144929 ) (-33.820861 13.5290088 17.379913 2.78420067 -11.2145576 6.4733448 ) (-22.048225 19.549881 6.16535569 9.25754548 5.79330445 -13.0719318 ) (-12.986219 22.271461 11.95866 -3.81438637 -11.95866 3.81438637 )) NATURAL) (2 ((63 71) (61 99)) NIL ((-2. 28. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 64Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:27:37) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((2 ((287 0) (334 0)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((334 0) (334 84)) NIL ((0 84. 0 0 0 0 )) NATURAL) (2 ((334 84) (388 84)) NIL ((54. 0 0 0 0 0 )) NATURAL) (2 ((388 84) (388 127)) NIL ((0 43. 0 0 0 0 )) NATURAL) (2 ((388 127) (334 127)) NIL ((-54. 0 0 0 0 0 )) NATURAL) (2 ((334 127) (334 337)) NIL ((0 210. 0 0 0 0 )) NATURAL) (2 ((334 337) (287 337)) NIL ((-47. 0 0 0 0 0 )) NATURAL) (2 ((287 337) (61 112)) NIL ((-226. -225. 0 0 0 0 )) NATURAL) (2 ((61 112) (61 84)) NIL ((0 -28. 0 0 0 0 )) NATURAL) (2 ((61 84) (287 84)) NIL ((226. 0 0 0 0 0 )) NATURAL) (2 ((287 84) (287 0)) NIL ((0 -84. 0 0 0 0 )) NATURAL)) ((2 ((287 127) (132 127)) NIL ((-155. 0 0 0 0 0 )) NATURAL) (2 ((132 127) (287 285)) NIL ((155. 158. 0 0 0 0 )) NATURAL) (2 ((287 285) (287 127)) NIL ((0 -158. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 65Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:33:57) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((2 ((63 99) (113 99)) NIL ((50. 0 0 0 0 0 )) NATURAL) (11 ((113 99) (117 71) (128 55) (149 41) (187 33) (212 31) (238 32) (276 39) (300 56) (317 84) (322 112)) NIL ((2.45260906 -31.158916 0 0 9.2843437 18.953514 ) (7.09478188 -21.682159 9.2843437 18.953514 -4.42172432 -22.76757 ) (14.168264 -14.112432 4.8626194 -3.81405783 26.402553 12.1167736 ) (32.232162 -11.868103 31.265174 8.3027172 -59.188507 -1.69952965 ) (33.903076 -4.41515064 -27.923336 6.60318757 30.351509 -5.31865692 ) (21.155502 -0.471291602 2.42817497 1.28452992 21.782455 4.97415924 ) (34.474899 3.30031872 24.210632 6.25868989 -51.48133 3.42201805 ) (32.944862 11.2700176 -27.270702 9.6807079 28.14289 5.33776856 ) (19.745609 23.619609 0.872188688 15.018476 -19.090236 -18.773094 ) (11.072681 29.251537 -18.218048 -3.7546196 18.218048 3.7546196 )) NATURAL) (12 ((322 112) (319 136) (310 159) (298 174) (278 186) (250 191) (229 192) (203 191) (167 185) (146 173) (134 159) (125 141)) NIL ((-1.50521779 23.720333 0 0 -8.96869279 1.67799902 ) (-5.9895649 24.55933 -8.96869279 1.67799902 8.8434677 -14.389993 ) (-10.5365219 19.042331 -0.125223279 -12.711996 -8.4051876 13.8819828 ) (-14.8643398 13.2713279 -8.53041268 1.16998744 -5.22271347 -11.137939 ) (-26.00611 8.87234689 -13.753126 -9.9679527 29.296043 6.669775 ) (-25.111213 2.23928118 15.542919 -3.29817772 -21.961471 2.45884323 ) (-20.54903 0.170525491 -6.4185524 -0.839334369 -13.450157 -4.50514984 ) (-33.692657 -2.92138386 -19.868709 -5.34448433 45.762107 -2.43824291 ) (-30.680313 -9.48498918 25.893402 -7.78272725 -19.598308 8.2581215 ) (-14.586067 -13.138656 6.29509164 0.475394309 -3.36886454 -6.59424306 ) (-9.97540856 -15.960382 2.92622709 -6.1188488 -2.92622709 6.1188488 )) NATURAL) (3 ((125 141) (73 141) (73 141)) NIL ((-65. 0 0 0 78. 0 ) (-26. 0 78. 0 -78. 0 )) NATURAL) (2 ((73 141) (108 337)) NIL ((35. 196. 0 0 0 0 )) NATURAL) (2 ((108 337) (334 337)) NIL ((226. 0 0 0 0 0 )) NATURAL) (2 ((334 337) (334 295)) NIL ((0 -42. 0 0 0 0 )) NATURAL) (2 ((334 295) (153 295)) NIL ((-181. 0 0 0 0 0 )) NATURAL) (2 ((153 295) (137 202)) NIL ((-16. -93. 0 0 0 0 )) NATURAL) (22 ((137 202) (170 217) (202 224) (237 227) (280 222) (312 211) (337 193) (352 175) (363 153) (367 122) (363 86) (351 57) (325 29) (295 12) (259 2) (208 -2) (160 4) (120 17) (94 34) (76 54) (67 73) (63 99)) NIL ((33.278953 16.989254 0 0 -1.6737628 -11.935539 ) (32.442077 11.021486 -1.6737628 -11.935539 2.36881447 11.677698 ) (31.95272 4.9247961 0.695052028 -0.257840454 16.198501 -10.775257 ) (40.747024 -0.720674277 16.893554 -11.033098 -37.162834 7.42333985 ) (39.059166 -8.0421009 -20.269279 -3.6097579 18.4528389 -6.9181099 ) (28.016304 -15.110916 -1.816437 -10.527868 -12.6485328 14.249101 ) (19.875598 -18.514232 -14.464971 3.72123432 14.141298 -8.07830239 ) (12.481279 -18.832149 -0.323671937 -4.35706902 -7.91666699 -5.9358902 ) (8.19927407 -26.157165 -8.24033929 -10.292959 -0.474626541 1.82187271 ) (-0.278379440 -35.539184 -8.7149658 -8.4710865 3.8151741 22.648395 ) (-7.0857582 -32.686073 -4.89979172 14.1773109 -14.786075 -20.415466 ) (-19.378585 -28.716499 -19.685867 -6.2381563 19.329124 23.013469 ) (-29.39989 -23.447917 -0.356739759 16.775314 -2.53043222 -11.6384296 ) (-31.021846 -12.491817 -2.88717222 5.13688374 -21.207397 -0.459736824 ) (-44.512718 -7.58480263 -24.09457 4.6771469 33.36003 7.47737885 ) (-51.927269 0.831033350 9.26546289 12.1545257 -4.23274899 -5.4497776 ) (-44.778183 10.2606697 5.03271389 6.70474816 13.570957 -3.67826986 ) (-32.959983 15.126283 18.603672 3.02647829 -14.051084 2.16285753 ) (-21.381855 19.234191 4.55258656 5.18933583 6.63338948 -10.9731578 ) (-13.512575 18.936946 11.185976 -5.783823 -6.4824705 17.729778 ) (-5.56783486 22.018013 4.7035055 11.945955 -4.7035055 -11.945955 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 66Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:40:25) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((11 ((314 260) (306 281) (287 297) (251 308) (210 307) (174 303) (144 291) (125 271) (117 255) (113 235) (110 192)) NIL ((-6.15634823 22.203887 0 0 -11.0619106 -7.2233467 ) (-11.687303 18.592216 -11.0619106 -7.2233467 -10.6904468 6.11673546 ) (-28.094436 14.427236 -21.752357 -1.10661101 17.823703 -17.243595 ) (-40.934944 4.6988287 -3.92865229 -18.350208 11.39562 20.857646 ) (-39.165779 -3.2225542 7.4669695 2.50744152 -3.40619659 -12.186998 ) (-33.401908 -6.80861188 4.0607729 -9.6795578 8.2291622 -2.10965156 ) (-25.226558 -17.542995 12.289936 -11.789209 0.489543915 20.625602 ) (-12.6918487 -19.019401 12.7794799 8.83639527 -10.1873417 -8.39276696 ) (-5.00603962 -14.3793907 2.59213829 0.443627298 -1.74017286 -35.054527 ) (-3.283988 -31.463031 0.851965309 -34.6109 -0.851965309 34.6109 )) NATURAL) (33 ((110 192) (143 210) (181 220) (232 225) (279 222) (310 213) (337 199) (357 180) (370 153) (376 124) (373 91) (363 60) (334 29) (289 8) (226 -1) (174 6) (135 20) (105 40) (87 60) (70 98) (64 164) (69 221) (76 252) (91 283) (111 306) (139 323) (177 335) (235 338) (279 333) (309 323) (331 309) (351 286) (357 260)) NIL ((32.591583 19.91341 0 0 2.45046902 -11.480478 ) (33.816818 14.173172 2.45046902 -11.480478 17.7476539 9.40239717 ) (45.141113 7.39389229 20.198123 -2.07808113 -25.441089 -8.12911416 ) (52.61869 1.25125384 -5.24296665 -10.207195 -17.983284 5.1140623 ) (38.384079 -6.39890957 -23.226253 -5.09313298 25.374244 -0.327138901 ) (27.844951 -11.6556129 2.14799404 -5.42027188 -11.5137119 2.19449425 ) (24.236091 -15.978637 -9.36571885 -3.22577763 2.68060589 -8.45083619 ) (16.210674 -23.429832 -6.68511296 -11.6766147 0.791287423 13.608858 ) (9.9212036 -28.30202 -5.89382553 1.93224478 -5.8457508 -9.9846058 ) (1.10450172 -31.362079 -11.739576 -8.05236245 10.5917167 14.3295707 ) (-5.33921623 -32.249656 -1.14785862 6.27720929 -24.521122 -11.333683 ) (-18.747634 -31.639289 -25.668983 -5.05647373 15.4927768 19.005157 ) (-36.670234 -27.19318 -10.1762066 13.948686 -19.449962 -4.68696213 ) (-56.571426 -15.587976 -29.62617 9.26172448 50.307067 11.742685 ) (-61.044059 -0.454907894 20.6809 21.004409 -7.77833939 -18.283779 ) (-44.252327 11.4076118 12.902561 2.72062778 -7.19371319 7.39244557 ) (-34.946617 17.824459 5.708848 10.113073 12.55319 -17.285995 ) (-22.961177 19.294536 18.262039 -7.17292214 -25.019046 25.751537 ) (-17.20866 24.997383 -6.7570076 18.578617 21.522995 22.279834 ) (-13.20417 54.71591 14.765987 40.85845 -1.07293892 -54.870864 ) (1.02534771 68.13893 13.693048 -14.0124149 -17.231231 -24.796375 ) (6.10277939 41.728324 -3.53818369 -38.808792 15.997869 52.056388 ) (10.5635299 28.94773 12.459686 13.2476 -10.760248 -27.429206 ) (17.643093 28.480728 1.69943738 -14.181606 9.04312516 9.6604328 ) (23.864093 19.129337 10.742563 -4.52117348 -7.412261 0.787478924 ) (30.900527 15.001905 3.33030224 -3.73369455 32.605918 -6.81034947 ) (50.53379 7.86303425 35.936225 -10.544044 -63.011444 2.45392418 ) (54.964294 -1.45404815 -27.075222 -8.0901203 15.439876 2.99464989 ) (35.609008 -8.04684258 -11.635345 -5.09547043 1.25195694 3.56747198 ) (24.599643 -11.3585777 -10.3833885 -1.52799845 15.5522918 -11.264534 ) (21.992401 -18.51884 5.16890335 -12.7925338 -27.461128 11.490667 ) (13.43074 -25.566043 -22.292224 -1.30186629 22.292224 1.30186629 )) NATURAL) (2 ((357 260) (314 260)) NIL ((-43. 0 0 0 0 0 )) NATURAL)) ((21 ((113 119) (121 149) (140 172) (164 185) (208 192) (228 194) (248 192) (291 185) (314 170) (327 147) (333 117) (330 86) (315 57) (290 40) (249 33) (229 31) (209 33) (163 42) (134 61) (119 84) (113 119)) NIL ((4.91333866 31.251632 0 0 18.519966 -7.5098009 ) (14.173322 27.49673 18.519966 -7.5098009 -26.599842 -4.45099545 ) (19.393367 17.761432 -8.07987596 -11.960796 51.879409 7.3137846 ) (37.253196 9.45752908 43.799537 -4.64701176 -90.917816 -0.804142953 ) (35.593818 4.4084463 -47.118286 -5.4511547 47.791908 1.90278578 ) (12.371492 -0.0913158953 0.673623085 -3.54836893 43.750167 -0.806997777 ) (34.920204 -4.04318428 44.423797 -4.3553667 -84.792617 -4.6747942 ) (36.947685 -10.7359466 -40.36882 -9.0301609 37.420303 1.50617122 ) (15.289024 -19.013023 -2.94851398 -7.52398968 -4.88860703 -1.34988689 ) (9.8962059 -27.211956 -7.837121 -8.87387658 0.134121895 9.8933773 ) (2.12614632 -31.139144 -7.7029991 1.01950121 -7.64788056 -2.22362852 ) (-9.40079309 -31.231456 -15.350879 -1.20412731 12.457403 17.0011329 ) (-18.522972 -23.935016 -2.893476 15.797006 -30.181732 -5.78090859 ) (-36.507316 -11.028463 -33.07521 10.016098 72.26953 -5.87750626 ) (-33.44776 -3.95111895 39.19432 4.13859177 -36.896385 -0.709060669 ) (-12.701635 -0.167057514 2.29793119 3.4295311 -50.683975 2.71375179 ) (-35.745689 4.61934948 -48.386047 6.1432829 83.632309 7.85405255 ) (-42.315582 14.689657 35.24626 13.997335 -25.845264 -16.129955 ) (-19.991954 20.622013 9.40099526 -2.13262224 1.7487545 20.665775 ) (-9.71658326 28.82228 11.1497497 18.533153 -11.1497497 -18.533153 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 67Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:42:36) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((3 ((82 337) (82 337) (82 295)) NIL ((0 10.5 0 0 0 -63. ) (0 -21. 0 -63. 0 63. )) NATURAL) (2 ((82 295) (317 295)) NIL ((235. 0 0 0 0 0 )) NATURAL) (2 ((317 295) (140 0)) NIL ((-177. -295. 0 0 0 0 )) NATURAL) (2 ((140 0) (207 0)) NIL ((67. 0 0 0 0 0 )) NATURAL) (2 ((207 0) (367 307)) NIL ((160. 307. 0 0 0 0 )) NATURAL) (2 ((367 307) (367 337)) NIL ((0 30. 0 0 0 0 )) NATURAL) (2 ((367 337) (82 337)) NIL ((-285. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 70Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:49:46) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((19 ((291 180) (315 191) (336 207) (351 232) (354 260) (345 290) (324 313) (298 326) (259 336) (219 340) (178 336) (139 326) (114 313) (93 290) (84 260) (87 232) (102 207) (123 191) (147 180)) NIL ((24.558052 10.265171 0 0 -3.34833002 4.4089651 ) (22.883888 12.469654 -3.34833002 4.4089651 -1.25834989 7.95517254 ) (18.906383 20.856205 -4.60667992 12.3641376 -9.61826898 -12.229656 ) (9.49056817 27.105514 -14.2249489 0.134480089 3.73142815 4.96345997 ) (-2.86866617 29.721725 -10.4935207 5.09794045 -5.3074398 -13.624183 ) (-16.015907 28.007572 -15.80096 -8.5262432 17.498333 -4.46672058 ) (-23.067699 17.247966 1.69737339 -12.9929638 -22.685901 13.4910698 ) (-32.713279 11.0005397 -20.988529 0.498106360 25.245277 -7.49756528 ) (-41.07917 7.74986458 4.25675106 -6.99945927 -6.2952261 -1.50080967 ) (-39.97003 -4.76837158E-7 -2.03847551 -8.50026895 -0.0643725395 1.50080967 ) (-42.040695 -7.74986458 -2.10284805 -6.99945927 24.552715 7.49756528 ) (-31.867183 -11.0005397 22.449867 0.498106659 -26.146499 -13.4910717 ) (-22.490562 -17.24797 -3.69663239 -12.9929657 20.03329 4.46672249 ) (-16.170547 -28.007572 16.336658 -8.5262432 -5.98667336 13.624183 ) (-2.82722759 -29.721725 10.349985 5.09794045 3.91341019 -4.96346092 ) (9.47946359 -27.105514 14.263395 0.134479522 -9.6669674 12.22966 ) (18.909374 -20.856205 4.59642697 12.364139 -1.24553394 -7.9551754 ) (22.883033 -12.469654 3.35089302 4.40896416 -3.35089302 -4.40896416 )) NATURAL) (21 ((147 180) (117 170) (87 154) (69 134) (60 100) (67 60) (88 34) (114 18) (139 9) (169 2) (219 -2) (268 2) (298 9) (324 18) (349 34) (370 60) (378 100) (369 134) (351 154) (321 170) (291 180)) NIL ((-29.24649 -8.45737458 0 0 -4.52104187 -9.25575067 ) (-31.50701 -13.0852489 -4.52104187 -9.25575067 22.605209 10.278753 ) (-24.725448 -17.201622 18.084167 1.02300405 -13.899799 -19.859268 ) (-13.5911808 -26.108253 4.18436814 -18.836265 14.993984 9.15831948 ) (-1.90981889 -40.365356 19.178352 -9.6779461 -4.07614327 31.225994 ) (15.230461 -34.430305 15.102209 21.548049 -10.6893997 -14.062305 ) (24.987968 -19.91341 4.41280842 7.4857435 -7.16625214 1.02323055 ) (25.817649 -11.9160499 -2.75344372 8.50897409 3.3544116 -8.03062058 ) (24.741413 -7.42238618 0.600968123 0.478352726 29.7486 1.09926128 ) (40.216682 -6.3944025 30.34957 1.57761407 -32.348823 9.63357545 ) (54.391838 7.15255737E-7 -1.99925756 11.211191 -26.353275 -9.63357736 ) (39.215942 6.3944025 -28.352535 1.57761335 29.761928 -1.09926057 ) (25.744373 7.42238618 1.40939593 0.478352666 -2.69444275 8.03062058 ) (25.806549 11.9160499 -1.28504705 8.50897409 -0.984160424 -1.02323150 ) (24.029418 19.91341 -2.26920748 7.48574258 -11.3689117 14.062307 ) (16.075756 34.430305 -13.63812 21.548049 -7.5401821 -31.225994 ) (-1.3324542 40.365356 -21.178302 -9.6779461 17.529632 -9.15831567 ) (-13.745939 26.108249 -3.64866877 -18.836261 -14.57835 19.859264 ) (-24.683784 17.201622 -18.22702 1.02300405 22.783775 -10.278753 ) (-31.518917 13.0852489 4.55675507 -9.25575067 -4.55675507 9.25575067 )) NATURAL)) ((9 ((131 253) (135 224) (156 204) (194 196) (221 194) (244 196) (281 204) (302 224) (307 253)) NIL ((0.832658768 -30.649482 0 0 19.004047 9.8969059 ) (10.334684 -25.701026 19.004047 9.8969059 6.97975159 4.51546479 ) (32.828605 -13.54639 25.983799 14.41237 -46.923042 -9.9587631 ) (35.350875 -4.1134014 -20.939247 4.45360756 12.712442 -0.680411816 ) (20.767856 1.59256160E-7 -8.22680474 3.77319574 38.073265 0.680411816 ) (31.577686 4.11340237 29.846466 4.45360756 -57.005523 9.9587612 ) (32.921386 13.546392 -27.159057 14.4123687 9.94882585 -4.51546097 ) (10.7367439 25.70103 -17.210231 9.8969078 17.210231 -9.8969078 )) NATURAL) (9 ((307 253) (298 283) (274 300) (244 307) (221 309) (194 307) (164 300) (140 283) (131 253)) NIL ((-5.5618553 32.845359 0 0 -20.628864 -17.072162 ) (-15.876289 24.309276 -20.628864 -17.072162 13.144329 7.36082268 ) (-29.932987 10.917524 -7.4845352 -9.71133996 22.051544 5.6288662 ) (-26.39175 4.02061749 14.5670089 -4.08247376 -23.350509 0.123711586 ) (-23.5 -3.18512320E-7 -8.78350259 -3.95876217 5.3505125 -0.123711586 ) (-29.608245 -4.02061844 -3.4329896 -4.08247376 7.94845296 -5.6288662 ) (-29.067009 -10.917526 4.51546383 -9.71133996 16.855667 -7.36082268 ) (-16.12371 -24.309276 21.371131 -17.072162 -21.371131 17.072162 )) NATURAL)) ((11 ((105 98) (113 128) (132 147) (155 158) (194 164) (220 165) (244 164) (283 158) (305 147) (325 128) (332 98)) NIL ((4.97496033 32.444747 0 0 18.150238 -14.668506 ) (14.050081 25.110496 18.150238 -14.668506 -24.751201 7.34253979 ) (19.824714 14.113258 -6.6009655 -7.32596684 38.854583 3.2983427 ) (32.651046 8.4364624 32.253624 -4.02762413 -58.667167 -2.53591156 ) (35.571083 3.14088345 -26.413543 -6.5635357 21.814094 6.84530354 ) (20.06459 -7.96280801E-8 -4.59944725 0.281768083 37.410774 -6.84530354 ) (34.170532 -3.14088392 32.811332 -6.5635357 -69.457214 2.53591251 ) (32.25325 -8.4364643 -36.645889 -4.02762318 48.41812 -3.2983427 ) (19.816429 -14.113258 11.7722377 -7.32596589 -34.215293 -7.34254265 ) (14.481018 -25.110496 -22.443058 -14.668508 22.443058 14.668508 )) NATURAL) (11 ((332 98) (326 69) (302 47) (275 36) (244 31) (220 29) (194 31) (162 36) (135 47) (111 69) (105 98)) NIL ((-1.27926373 -30.190605 0 0 -28.324417 7.14364625 ) (-15.441473 -26.618782 -28.324417 7.14364625 33.622093 6.2817669 ) (-26.954841 -16.334251 5.29768086 13.425413 -16.163986 -8.2707176 ) (-29.739154 -7.04419804 -10.866306 5.1546955 25.033847 -3.19889402 ) (-28.088535 -3.48895025 14.167543 1.95580148 -17.971408 3.06629705 ) (-22.906696 3.18512320E-7 -3.80386734 5.02209854 -7.1482048 -3.06629753 ) (-30.284668 3.48895025 -10.952072 1.95580101 22.564231 3.19889545 ) (-29.954624 7.044199 11.6121616 5.15469647 -17.1087379 8.2707157 ) (-26.896831 16.334251 -5.4965763 13.425413 33.870712 -6.2817669 ) (-15.4580459 26.618782 28.374141 7.14364625 -28.374141 -7.14364625 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 71Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:58:42) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((2 ((118 77) (75 77)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (32 ((75 77) (81 51) (100 28) (123 14) (153 4) (196 -1) (255 2) (294 13) (321 31) (340 54) (355 85) (363 116) (367 173) (364 239) (351 277) (333 297) (303 317) (264 331) (205 338) (142 329) (97 308) (67 277) (55 246) (54 213) (60 184) (75 157) (109 130) (153 115) (199 112) (260 118) (302 131) (322 145)) NIL ((2.70768738 -26.21757 0 0 19.753875 1.30543661 ) (12.584625 -25.564853 19.753875 1.30543661 -20.769386 11.472816 ) (21.953807 -18.523006 -1.01551056 12.778253 9.32367517 -11.1967029 ) (25.600135 -11.343107 8.3081646 1.58154917 1.47467994 3.31399965 ) (34.645637 -8.10455705 9.78284455 4.89554882 20.77761 3.94070339 ) (54.81729 -1.23865676 30.560455 8.8362522 -66.585128 -1.07681560 ) (52.085174 7.0591879 -36.024673 7.7594366 29.562927 0.366560936 ) (30.841968 15.001905 -6.46174336 8.12599755 -3.66660023 -6.3894329 ) (22.546924 19.933185 -10.1283435 1.73656463 9.1034622 13.191175 ) (16.970314 28.265338 -1.02488088 14.92774 -8.7472496 -28.375263 ) (11.5718078 29.005447 -9.77213098 -13.447525 7.88553906 52.309883 ) (5.7424469 41.712867 -1.88659143 38.862358 -4.79491043 -24.864299 ) (1.45840072 68.143066 -6.68150235 13.998058 -6.70589734 -54.852653 ) (-8.5760498 54.714805 -13.3873996 -40.854599 13.6184997 22.274959 ) (-15.154197 24.997684 0.231101900 -18.579639 -17.768104 25.752807 ) (-23.807151 19.294448 -17.537006 7.17316819 15.4539318 -17.286197 ) (-33.617187 17.824516 -2.08307314 -10.113031 -26.047618 7.3919878 ) (-48.724075 11.407478 -28.130695 -2.72104311 22.736557 -18.2817459 ) (-65.48648 -0.454440713 -5.39413643 -21.002792 31.101375 11.7350216 ) (-55.329933 -15.589721 25.70724 -9.26777078 -15.14208 -4.65834809 ) (-37.193733 -27.186668 10.5651607 -13.9261188 11.466947 18.898368 ) (-20.895099 -31.6636 22.032108 4.97225094 -12.725717 -10.9351349 ) (-5.2258501 -32.158912 9.30639077 -5.9628849 -2.5640707 12.842174 ) (2.7985053 -31.700714 6.74232007 6.87928963 -1.01799202 -4.43356228 ) (9.03182984 -27.038208 5.72432804 2.44572735 18.636032 -7.1079273 ) (24.074176 -28.146442 24.360363 -4.66219998 -13.526155 20.865268 ) (41.671463 -22.376003 10.8342075 16.203071 -18.53141 -4.35317803 ) (43.239959 -8.34952165 -7.69720364 11.849893 39.651802 -3.45254517 ) (55.368667 1.77409935 31.954605 8.3973484 -62.075828 0.163358688 ) (56.285354 10.253126 -30.121227 8.5607071 4.65153504 -9.20088388 ) (28.489894 14.213392 -25.469692 -0.640176893 25.469692 0.640176893 )) NATURAL) (12 ((322 145) (319 102) (314 82) (307 66) (287 46) (262 36) (226 33) (196 33) (162 36) (141 44) (126 58) (118 77)) NIL ((-2.36525059 -48.755897 0 0 -3.80849552 34.535408 ) (-4.26949787 -31.488193 -3.80849552 34.535408 7.0424776 -34.67704 ) (-4.55675507 -14.291311 3.23398209 -0.141639173 -24.361415 -9.8272133 ) (-13.5034828 -19.346557 -21.127433 -9.968853 24.403202 25.985908 ) (-22.429313 -16.322452 3.27577066 16.017055 -25.251411 -10.1164398 ) (-31.77925 -5.36361695 -21.975643 5.90061569 40.602447 -3.52014017 ) (-33.453666 -1.22307181 18.626808 2.38047552 -35.158393 0.197004795 ) (-32.406059 1.25590610 -16.531585 2.57748031 40.031112 2.73212242 ) (-28.922084 5.19944763 23.49953 5.30960274 -22.966072 0.874502183 ) (-16.90559 10.946302 0.533458472 6.1841049 9.83317567 -0.230131149 ) (-11.455543 17.0153389 10.366634 5.95397377 -10.366634 -5.95397377 )) NATURAL)) ((11 ((323 220) (316 188) (295 164) (268 150) (226 145) (202 143) (179 145) (138 152) (115 166) (99 190) (93 220)) NIL ((-3.30784607 -33.58744 0 0 -22.152923 9.52467538 ) (-14.3843078 -28.825103 -22.152923 9.52467538 26.764621 0.376617432 ) (-23.154918 -19.112121 4.61169815 9.9012928 -36.905563 0.968858719 ) (-36.996009 -8.72639848 -32.293869 10.870151 66.857666 -10.252054 ) (-35.861038 -2.98227548 34.563797 0.618097306 -32.525123 4.039361 ) (-17.559806 -0.344497323 2.03867292 4.6574583 -38.757156 0.0946092606 ) (-34.899719 4.36026573 -36.71849 4.75206757 73.553787 1.58220005 ) (-34.841308 9.90343286 36.835304 6.3342676 -39.458053 5.57659245 ) (-17.735031 19.025997 -2.62274933 11.91086 18.278434 -5.88857556 ) (-11.218561 27.992569 15.655687 6.0222845 -15.655687 -6.0222845 )) NATURAL) (11 ((93 220) (95 251) (111 280) (140 297) (180 307) (204 308) (227 306) (274 295) (302 276) (317 253) (323 220)) NIL ((-1.10016107 30.764175 0 0 18.600967 1.4149456 ) (8.2003212 31.471645 18.600967 1.4149456 -9.00483705 -19.074726 ) (22.29887 23.349227 9.59613038 -17.659782 11.4183807 14.883974 ) (37.604187 13.131431 21.014511 -2.7758069 -48.668686 -10.4611778 ) (34.284355 5.12503529 -27.654178 -13.236986 21.256389 14.9607429 ) (17.258373 -0.631578923 -6.39778805 1.72375726 53.64311 -13.3817978 ) (37.68215 -5.59872055 47.24533 -11.658041 -85.8289 2.5664463 ) (42.01303 -15.973539 -38.583572 -9.0915947 31.672523 9.1160202 ) (19.26572 -20.507122 -6.91104603 0.0244256891 -4.86119175 -15.0305309 ) (9.924078 -27.997962 -11.7722377 -15.006105 11.7722377 15.006105 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.S1-SF b/lispusers/GACHAE.S1-SF new file mode 100644 index 00000000..8a13afa8 --- /dev/null +++ b/lispusers/GACHAE.S1-SF @@ -0,0 +1 @@ + ((FAMILY gacha) (CHARACTER 40Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 13-SEP-77 15:50:28) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES)) ((FAMILY gacha) (CHARACTER 30Q) (FACE M R E) (WIDTH 0 0) (FIDUCIAL 480 480) (VERSION 0 13-SEP-77 15:52:00) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((3 ((0 -112) (0 -112) (441 -112)) NIL ((-110.25 0 0 0 661.5 0 ) (220.5 0 661.5 0 -661.5 0 )) NATURAL) (2 ((441 -112) (441 -76)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((441 -76) (0 -76)) NIL ((-441. 0 0 0 0 0 )) NATURAL) (2 ((0 -76) (0 -112)) NIL ((0 -36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 41Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 13:12:55) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((219 -4) (231 -3) (251 9) (261 29) (251 49) (231 61) (219 62) (207 61) (187 49) (177 29) (187 9) (207 -3) (219 -4)) NIL ((9.72938157 0.167401611 -0.927834511 -5.42605019 16.407211 21.273738 ) (17.005153 5.3782215 15.479379 15.84769 -28.469066 -7.81240464 ) (18.249996 17.319709 -12.9896869 8.03528596 -10.530931 -8.02412416 ) (-0.00515493005 21.342933 -23.520618 0.0111602712 10.5927848 -8.09108735 ) (-18.229381 17.3085479 -12.927833 -8.07992745 28.15979 -7.61152077 ) (-17.077316 5.42286206 15.231958 -15.691448 -15.231958 20.53717 ) (-9.46133996 0 -5.11072471E-7 4.8457241 -15.231954 -20.53717 ) (-17.07732 -5.42286206 -15.231956 -15.691448 28.15979 7.61152077 ) (-18.229377 -17.3085479 12.927833 -8.07992745 10.592781 8.09108735 ) (-0.00515333563 -21.342933 23.520614 0.0111602917 -10.5309238 8.02412416 ) (18.25 -17.319709 12.9896908 8.03528596 -28.46907 7.81240464 ) (17.005153 -5.3782215 -15.479381 15.84769 16.407215 -21.273738 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 42Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 13:18:48) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((8 ((137 197) (130 223) (122 248) (115 273) (112 296) (114 313) (126 331) (147 338)) NIL ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 ) (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 ) (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 ) (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 ) (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 ) (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 ) (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 )) NATURAL) (8 ((147 338) (168 331) (180 313) (182 296) (179 273) (172 248) (164 223) (157 197)) NIL ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 ) (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 ) (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 ) (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 ) (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 ) (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 ) (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 )) NATURAL) (2 ((157 197) (137 197)) NIL ((-20. 0 0 0 0 0 )) NATURAL)) ((2 ((302 197) (282 197)) NIL ((-20. 0 0 0 0 0 )) NATURAL) (8 ((282 197) (275 223) (267 248) (260 273) (257 296) (259 313) (271 331) (292 338)) NIL ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 ) (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 ) (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 ) (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 ) (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 ) (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 ) (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 )) NATURAL) (8 ((292 338) (313 331) (325 313) (327 296) (324 273) (317 248) (309 223) (302 197)) NIL ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 ) (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 ) (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 ) (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 ) (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 ) (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 ) (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 43Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 13:21:04) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((39 0) (90 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((90 0) (144 113)) NIL ((54. 113. 0 0 0 0 )) NATURAL) (2 ((144 113) (246 113)) NIL ((102. 0 0 0 0 0 )) NATURAL) (2 ((246 113) (192 0)) NIL ((-54. -113. 0 0 0 0 )) NATURAL) (2 ((192 0) (243 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((243 0) (297 113)) NIL ((54. 113. 0 0 0 0 )) NATURAL) (2 ((297 113) (393 113)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((393 113) (393 148)) NIL ((0 35. 0 0 0 0 )) NATURAL) (2 ((393 148) (313 148)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (2 ((313 148) (337 198)) NIL ((24. 50. 0 0 0 0 )) NATURAL) (2 ((337 198) (415 198)) NIL ((78. 0 0 0 0 0 )) NATURAL) (2 ((415 198) (417 232)) NIL ((2. 34. 0 0 0 0 )) NATURAL) (2 ((417 232) (354 232)) NIL ((-63. 0 0 0 0 0 )) NATURAL) (2 ((354 232) (405 337)) NIL ((51. 105. 0 0 0 0 )) NATURAL) (2 ((405 337) (354 337)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((354 337) (303 232)) NIL ((-51. -105. 0 0 0 0 )) NATURAL) (2 ((303 232) (201 232)) NIL ((-102. 0 0 0 0 0 )) NATURAL) (2 ((201 232) (252 337)) NIL ((51. 105. 0 0 0 0 )) NATURAL) (2 ((252 337) (201 337)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((201 337) (150 232)) NIL ((-51. -105. 0 0 0 0 )) NATURAL) (2 ((150 232) (54 232)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((54 232) (54 197)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((54 197) (133 197)) NIL ((79. 0 0 0 0 0 )) NATURAL) (2 ((133 197) (109 147)) NIL ((-24. -50. 0 0 0 0 )) NATURAL) (2 ((109 147) (31 147)) NIL ((-78. 0 0 0 0 0 )) NATURAL) (2 ((31 147) (30 113)) NIL ((-1. -34. 0 0 0 0 )) NATURAL) (2 ((30 113) (93 113)) NIL ((63. 0 0 0 0 0 )) NATURAL) (2 ((93 113) (39 0)) NIL ((-54. -113. 0 0 0 0 )) NATURAL)) ((2 ((184 197) (160 147)) NIL ((-24. -50. 0 0 0 0 )) NATURAL) (2 ((160 147) (262 147)) NIL ((102. 0 0 0 0 0 )) NATURAL) (2 ((262 147) (286 197)) NIL ((24. 50. 0 0 0 0 )) NATURAL) (2 ((286 197) (184 197)) NIL ((-102. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 46Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:35:37) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((4 ((107 270) (123 246) (161 212) (174 202)) NIL ((8.46666719 -19.733333 0 0 45.199996 -25.599998 ) (31.066665 -32.533332 45.199996 -25.599998 -93.999984 67.999984 ) (29.266662 -24.133331 -48.799995 42.399993 48.799995 -42.399993 )) NATURAL) (13 ((174 202) (197 214) (222 228) (247 246) (259 270) (253 289) (235 303) (205 308) (182 310) (158 308) (131 303) (113 289) (107 270)) NIL ((22.63285 11.613859 0 0 2.202878 2.31683636 ) (23.73429 12.7722778 2.202878 2.31683636 0.985608578 0.415817738 ) (26.429973 15.2970237 3.18848658 2.73265409 -18.145309 8.01989175 ) (20.545803 22.039623 -14.956825 10.752546 -6.4043541 -20.495391 ) (2.38680172 22.544475 -21.361179 -9.74284555 13.7627258 7.9616804 ) (-12.0930137 16.7824669 -7.5984535 -1.78116488 -12.646549 -11.3513279 ) (-26.014743 9.3256397 -20.245002 -13.1324939 36.82347 13.4436359 ) (-27.848007 2.91496467 16.578468 0.311142981 -20.647338 -6.42321969 ) (-21.593212 0.0144983027 -4.0688715 -6.11207677 -2.23410892 6.24923993 ) (-26.779136 -2.97295809 -6.30298043 0.137163698 17.583774 -12.57374 ) (-24.290229 -9.1226635 11.280794 -12.4365768 3.8990078 8.04572106 ) (-11.0599327 -17.53638 15.1798019 -4.39085484 -15.1798019 4.39085484 )) NATURAL)) ((15 ((129 183) (72 242) (61 280) (73 309) (97 326) (132 339) (183 344) (234 339) (268 326) (291 309) (302 280) (294 242) (270 214) (238 196) (200 177)) NIL ((-67.869125 64.199096 0 0 65.214828 -31.194587 ) (-35.261718 48.601799 65.214828 -31.194587 -50.074157 29.972938 ) (4.91602898 32.393684 15.1406707 -1.22164702 -2.91818809 -16.697174 ) (18.597606 22.823448 12.2224827 -17.918823 -4.25308895 18.815761 ) (28.693542 14.312507 7.96939374 0.896939040 13.930542 -10.56587 ) (43.628204 9.92650987 21.899936 -9.66893197 -21.469078 -0.552272797 ) (54.7936 -0.0185569115 0.430855572 -10.2212047 -24.054214 0.774955750 ) (43.197349 -9.85228349 -23.623359 -9.446249 15.6859588 9.4524574 ) (27.416969 -14.5723037 -7.93739987 0.00620953180 -2.68962955 -14.584795 ) (18.134754 -21.858493 -10.627029 -14.578586 -10.927448 0.886726380 ) (2.04400062 -35.993713 -21.554477 -13.69186 4.39942932 29.03789 ) (-17.31076 -35.166626 -17.155048 15.346033 11.329729 -3.0383091 ) (-28.800945 -21.339752 -5.82531929 12.307724 -1.71835041 -16.884651 ) (-35.485443 -17.474353 -7.5436697 -4.57693005 7.5436697 4.57693005 )) NATURAL) (2 ((200 177) (318 80)) NIL ((118. -97. 0 0 0 0 )) NATURAL) (6 ((318 80) (335 99) (346 114) (356 130) (368 156) (372 178)) NIL ((18.459327 19.933013 0 0 -8.75597955 -5.5980854 ) (14.0813389 17.133968 -8.75597955 -5.5980854 7.77990246 3.99043036 ) (9.21531106 13.531099 -0.976076246 -1.60765481 7.63636208 19.63636 ) (12.057415 21.741626 6.66028596 18.028705 -20.325355 -28.53588 ) (8.5550232 25.502391 -13.665069 -10.507175 13.665069 10.507175 )) NATURAL) (2 ((372 178) (421 178)) NIL ((49. 0 0 0 0 0 )) NATURAL) (6 ((421 178) (412 145) (396 115) (373 85) (361 74) (346 59)) NIL ((-7.85167409 -34.186599 0 0 -6.88995267 7.1196165 ) (-11.2966499 -30.626792 -6.88995267 7.1196165 -7.5502367 -17.598083 ) (-21.961719 -32.306213 -14.440189 -10.4784679 37.090904 45.27272 ) (-17.856456 -20.148323 22.650714 34.794258 -32.813392 -49.49282 ) (-11.61244 -10.100477 -10.1626777 -14.698564 10.1626777 14.698564 )) NATURAL) (2 ((346 59) (424 0)) NIL ((78. -59. 0 0 0 0 )) NATURAL) (2 ((424 0) (352 0)) NIL ((-72. 0 0 0 0 0 )) NATURAL) (2 ((352 0) (309 32)) NIL ((-43. 32. 0 0 0 0 )) NATURAL) (12 ((309 32) (270 11) (228 -2) (163 -8) (105 0) (63 18) (37 45) (28 84) (40 124) (64 150) (94 168) (129 183)) NIL ((-39.917266 -22.867206 0 0 5.50363159 11.2032489 ) (-37.16545 -17.265583 5.50363159 11.2032489 -45.518158 -8.0162468 ) (-54.420906 -10.070457 -40.014526 3.18700123 56.569015 14.861742 ) (-66.150909 0.547416330 16.554489 18.048744 -0.757925034 -9.4307308 ) (-49.975395 13.880794 15.796564 8.61801339 0.462682724 -1.13881588 ) (-33.947486 21.929401 16.2592468 7.4791975 -1.09281921 7.98599148 ) (-18.234645 33.401596 15.166427 15.4651889 9.90859605 -12.805143 ) (1.88607931 42.46421 25.075023 2.66004515 -14.5415477 -22.765411 ) (19.690326 33.741546 10.5334758 -20.105369 -5.74240303 13.866802 ) (27.3526 20.56958 4.79107285 -6.23856736 1.51115894 3.29820967 ) (32.899253 15.9801178 6.30223179 -2.94035768 -6.30223179 2.94035768 )) NATURAL)) ((10 ((277 52) (243 38) (192 25) (147 26) (111 37) (86 53) (72 82) (81 112) (105 133) (150 157)) NIL ((-29.138164 -13.446022 0 0 -29.170993 -3.32386208 ) (-43.723663 -15.107954 -29.170993 -3.32386208 43.854972 22.619308 ) (-50.96717 -7.12215996 14.683979 19.295448 -8.2489071 -9.15338517 ) (-40.407638 7.59659577 6.43507195 10.142063 7.14065743 -10.0057678 ) (-30.40224 12.735775 13.575729 0.136293560 -8.3137245 19.176464 ) (-20.983375 22.460304 5.26200485 19.312759 26.114242 -18.700103 ) (-2.66424894 32.423004 31.376247 0.612653733 -24.143245 -16.376026 ) (16.640373 24.847648 7.23299885 -15.763374 22.458747 24.204216 ) (35.102745 21.186382 29.691749 8.44084359 -29.691749 -8.44084359 )) NATURAL) (2 ((150 157) (277 52)) NIL ((127. -105. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 47Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:38:09) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((8 ((210 197) (203 223) (195 248) (188 273) (185 296) (187 313) (199 331) (220 338)) NIL ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 ) (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 ) (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 ) (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 ) (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 ) (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 ) (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 )) NATURAL) (8 ((220 338) (241 331) (253 313) (255 296) (252 273) (245 248) (237 223) (230 197)) NIL ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 ) (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 ) (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 ) (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 ) (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 ) (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 ) (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 )) NATURAL) (2 ((230 197) (210 197)) NIL ((-20. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 50Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:40:32) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((304 350) (256 350)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (11 ((256 350) (226 328) (190 291) (160 250) (140 202) (127 121) (139 40) (161 -8) (190 -49) (226 -86) (256 -108)) NIL ((-28.149116 -18.291866 0 0 -11.105289 -22.248802 ) (-33.701759 -29.416267 -11.105289 -22.248802 19.526447 21.244014 ) (-35.043823 -41.04306 8.42115785 -1.00478410 4.99949837 3.2727251 ) (-24.12292 -40.411483 13.420656 2.267941 -15.5244369 -52.334915 ) (-18.464481 -64.311004 -2.10378218 -50.066978 39.098243 50.066978 ) (-1.01913643 -89.34448 36.994468 0 -32.868583 50.066978 ) (19.541038 -64.310989 4.1258812 50.066978 2.37611484 -52.334915 ) (24.854976 -40.411476 6.50199605 -2.26794243 5.3641386 3.27272701 ) (34.039039 -41.04306 11.8661346 1.00478482 -23.832664 21.244014 ) (33.988838 -29.416267 -11.9665317 22.248802 11.9665317 -22.248802 )) NATURAL) (2 ((256 -108) (304 -108)) NIL ((48. 0 0 0 0 0 )) NATURAL) (11 ((304 -108) (274 -86) (238 -49) (210 -8) (187 40) (175 121) (189 202) (208 250) (238 291) (274 328) (304 350)) NIL ((-27.892368 18.291866 0 0 -12.6457729 22.248802 ) (-34.215255 29.416267 -12.6457729 22.248802 27.22887 -21.244014 ) (-33.246589 41.04306 14.583097 1.00478410 -12.269714 -3.2727251 ) (-24.798355 40.411483 2.3133831 -2.267941 3.84998512 52.334915 ) (-20.559978 64.311004 6.16336823 50.066978 32.869773 -50.066978 ) (2.03827906 89.34448 39.033142 0 -45.3291 -50.066978 ) (18.406868 64.310989 -6.29596043 -50.066978 22.446659 52.334915 ) (23.334239 40.411476 16.150699 2.26794243 -8.45755387 -3.27272701 ) (35.256164 41.04306 7.69314576 -1.00478482 -18.616432 -21.244014 ) (33.64109 29.416267 -10.923286 -22.248802 10.923286 22.248802 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 51Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:42:07) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((11 ((126 350) (156 328) (192 291) (222 250) (241 202) (255 121) (243 40) (220 -8) (192 -49) (156 -86) (126 -108)) NIL ((28.17945 -18.291866 0 0 10.923286 -22.248802 ) (33.64109 -29.416267 10.923286 -22.248802 -18.616432 21.244014 ) (35.256164 -41.04306 -7.69314576 -1.00478410 -8.45755769 3.2727251 ) (23.334239 -40.411483 -16.150703 2.267941 22.446666 -52.334915 ) (18.406868 -64.311004 6.29596425 -50.066978 -45.329109 50.066978 ) (2.03827715 -89.34448 -39.033149 0 32.86978 50.066978 ) (-20.559978 -64.310989 -6.16336537 50.066978 3.84998179 -52.334915 ) (-24.798355 -40.411476 -2.31338358 -2.26794243 -12.269712 3.27272701 ) (-33.246589 -41.04306 -14.583097 1.00478482 27.22887 21.244014 ) (-34.215255 -29.416267 12.6457748 22.248802 -12.6457748 -22.248802 )) NATURAL) (2 ((126 -108) (174 -108)) NIL ((48. 0 0 0 0 0 )) NATURAL) (11 ((174 -108) (204 -86) (240 -49) (269 -8) (291 40) (303 121) (290 202) (270 250) (240 291) (204 328) (174 350)) NIL ((28.005577 18.291866 0 0 11.9665336 22.248802 ) (33.988838 29.416267 11.9665336 22.248802 -23.832668 -21.244014 ) (34.039039 41.04306 -11.8661346 1.00478410 5.36413956 -3.2727251 ) (24.854976 40.411483 -6.50199509 -2.267941 2.37611198 52.334915 ) (19.541038 64.311004 -4.1258831 50.066978 -32.868583 -50.066978 ) (-1.01914072 89.34448 -36.994468 0 39.098243 -50.066978 ) (-18.464481 64.310989 2.10378218 -50.066978 -15.5244369 52.334915 ) (-24.12292 40.411476 -13.420656 2.26794243 4.99949837 -3.27272701 ) (-35.043823 41.04306 -8.42115785 -1.00478482 19.526447 -21.244014 ) (-33.701759 29.416267 11.105289 -22.248802 -11.105289 22.248802 )) NATURAL) (2 ((174 350) (126 350)) NIL ((-48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 52Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:50:44) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((49 ((225 98) (205 106) (196 133) (202 169) (218 201) (186 185) (159 162) (132 150) (105 157) (93 184) (111 202) (144 209) (203 218) (144 227) (111 234) (93 252) (105 279) (132 286) (159 274) (186 251) (218 235) (202 267) (196 303) (205 330) (225 338) (245 330) (254 303) (248 267) (232 235) (264 251) (291 274) (318 286) (345 279) (357 252) (339 234) (306 227) (247 218) (306 209) (339 202) (357 184) (345 157) (318 150) (291 162) (264 185) (232 201) (248 169) (254 133) (245 106) (225 98)) NIL ((-22.53239 0.0906766206 0.746076346 11.4537448 12.9561367 13.094705 ) (-15.308248 18.091774 13.702213 24.54845 -3.25714302 -20.196006 ) (-3.23460579 32.54222 10.44507 4.3524437 24.072422 7.68932534 ) (19.246673 40.739326 34.517494 12.041769 -123.0325 -88.561279 ) (-7.7521 8.50045587 -88.515045 -76.519516 120.0577 82.5558 ) (-36.238273 -26.741153 31.542694 6.03629685 -39.198417 4.33803749 ) (-24.294792 -18.535835 -7.65572835 10.374334 6.73594475 8.09202767 ) (-28.582546 -4.11548805 -0.919782878 18.466362 12.254642 11.293846 ) (-23.375007 19.997795 11.3348598 29.760208 34.245483 -47.267402 ) (5.08259297 26.124298 45.580345 -17.507198 -59.236595 3.77578545 ) (21.044639 10.504995 -13.65625 -13.7314129 112.70089 20.164264 ) (63.738838 6.85571576 99.044647 6.43285275 -325.5669 -6.43285275 ) (5.08129596E-6 10.0721416 -226.5223 0 325.5669 -6.43285275 ) (-63.738838 6.8557148 99.044647 -6.43285275 -112.70089 20.164264 ) (-21.044639 10.504995 -13.6562519 13.7314129 59.2366 3.77578545 ) (-5.0825901 26.124301 45.580352 17.507198 -34.245513 -47.26741 ) (23.375003 19.997791 11.3348369 -29.760215 -12.254545 11.293884 ) (28.582569 -4.11548043 -0.919708253 -18.466331 -6.7362957 8.0918808 ) (24.294712 -18.535869 -7.65600396 -10.3744506 39.199722 4.33859158 ) (36.23857 -26.741024 31.543724 -6.0358591 -120.0626 82.55374 ) (7.75098897 8.49999238 -88.51889 76.51788 123.0507 -88.5536 ) (-19.24253 40.741066 34.531845 -12.0357227 -24.140338 7.6607275 ) (3.21914434 32.535705 10.391504 -4.37499523 3.51062012 -20.08929 ) (15.365957 18.116069 13.902124 -24.464286 -13.902124 12.69643 ) (22.31702 0 -5.11072471E-7 -11.7678566 -13.90212 -12.69643 ) (15.365957 -18.116069 -13.902122 -24.464286 3.5106144 20.089286 ) (3.21914196 -32.535713 -10.391508 -4.37499714 -24.140327 -7.6607256 ) (-19.24253 -40.741066 -34.531837 -12.0357227 123.0507 88.5536 ) (7.75099564 -8.49998284 88.518875 76.51788 -120.06259 -82.55374 ) (36.23857 26.741027 -31.543724 -6.035861 39.199722 -4.33858967 ) (24.294712 18.535869 7.6560049 -10.3744506 -6.73629666 -8.0918808 ) (28.582569 4.11547947 0.919708014 -18.466331 -12.254543 -11.293884 ) (23.375003 -19.997791 -11.3348369 -29.760215 -34.245513 47.26741 ) (-5.08259106 -26.124298 -45.580352 17.507198 59.2366 -3.77578545 ) (-21.044643 -10.504995 13.6562538 13.7314129 -112.70089 -20.164264 ) (-63.738838 -6.85571576 -99.044647 -6.43285275 325.5669 6.43285275 ) (-5.08129596E-6 -10.0721416 226.5223 0 -325.5669 6.43285275 ) (63.738838 -6.8557148 -99.044647 6.43285275 112.70089 -20.164264 ) (21.044639 -10.504995 13.65625 -13.7314129 -59.236595 -3.77578545 ) (5.08259106 -26.124298 -45.580345 -17.507198 34.245483 47.267402 ) (-23.375011 -19.997795 -11.334856 29.760204 12.2546367 -11.293842 ) (-28.582546 4.11548996 0.919782162 18.466362 6.7359457 -8.09202767 ) (-24.294792 18.535839 7.65572835 10.374334 -39.198417 -4.33804226 ) (-36.238273 26.741149 -31.542694 6.03629208 120.0577 -82.555786 ) (-7.75209904 -8.50045968 88.515045 -76.5195 -123.0325 88.56126 ) (19.246673 -40.739326 -34.517494 12.041765 24.072422 -7.6893215 ) (-3.2346077 -32.54222 -10.44507 4.3524437 -3.25714302 20.196006 ) (-15.308248 -18.091774 -13.702213 24.54845 12.9561367 -13.094705 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 53Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:00:01) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((195 28) (245 28)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((245 28) (245 143)) NIL ((0 115. 0 0 0 0 )) NATURAL) (2 ((245 143) (360 143)) NIL ((115. 0 0 0 0 0 )) NATURAL) (2 ((360 143) (360 193)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((360 193) (245 193)) NIL ((-115. 0 0 0 0 0 )) NATURAL) (2 ((245 193) (245 308)) NIL ((0 115. 0 0 0 0 )) NATURAL) (2 ((245 308) (195 308)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((195 308) (195 193)) NIL ((0 -115. 0 0 0 0 )) NATURAL) (2 ((195 193) (80 193)) NIL ((-115. 0 0 0 0 0 )) NATURAL) (2 ((80 193) (80 143)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((80 143) (195 143)) NIL ((115. 0 0 0 0 0 )) NATURAL) (2 ((195 143) (195 28)) NIL ((0 -115. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 54Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:04:46) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((20 ((218 -3) (205 -3) (185 9) (175 29) (181 49) (195 61) (213 66) (241 61) (255 50) (263 29) (259 -9) (247 -32) (234 -44) (215 -53) (186 -57) (170 -49) (177 -36) (195 -31) (215 -21) (218 -3)) NIL ((-10.673479 -2.67581272 0 0 -13.959116 16.054878 ) (-17.653038 5.3516264 -13.959116 16.054878 27.795578 -8.27439309 ) (-17.714363 17.269306 13.8364639 7.7804842 4.77679062 -6.95730019 ) (-1.48950290 21.57114 18.613254 0.823183776 -10.902744 -11.896402 ) (11.672378 16.446121 7.7105093 -11.073219 -9.1658039 6.54291535 ) (14.7999859 8.6443615 -1.4552958 -4.53030396 23.565967 -8.275259 ) (25.127674 -0.0235718079 22.110672 -12.8055629 -49.09806 8.5581188 ) (22.689312 -8.55007554 -26.987392 -4.2474432 28.826297 -1.95721721 ) (10.115068 -13.7761268 1.83890605 -6.2046604 -18.207134 -24.729248 ) (2.8504076 -32.345413 -16.3682289 -30.93391 8.00223924 58.874214 ) (-9.51670075 -33.842216 -8.36598969 27.940307 10.198177 -18.767623 ) (-12.7836017 -15.2857189 1.83218932 9.1726837 -6.7949562 -7.80373 ) (-14.34889 -10.0149 -4.9627676 1.3689537 -13.0183487 1.98254585 ) (-25.820835 -7.65467358 -17.981117 3.35149956 34.868362 11.8735466 ) (-26.367767 1.63359928 16.887249 15.225046 11.544872 -7.47673417 ) (-3.70808268 13.120277 28.43212 7.748312 -21.047866 -23.966606 ) (14.2001037 8.8852844 7.3842535 -16.218296 0.646611214 25.343174 ) (21.907661 5.3385763 8.0308647 9.12487985 -35.538574 0.593898773 ) (12.169237 14.760406 -27.507713 9.7187786 27.507713 -9.7187786 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 55Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:07:38) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((320 193) (120 193)) NIL ((-200. 0 0 0 0 0 )) NATURAL) (2 ((120 193) (120 143)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((120 143) (320 143)) NIL ((200. 0 0 0 0 0 )) NATURAL) (2 ((320 143) (320 193)) NIL ((0 50. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 56Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:10:01) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((218 63) (231 61) (251 49) (261 29) (251 9) (231 -3) (218 -5) (205 -3) (185 9) (175 29) (185 49) (205 61) (218 63)) NIL ((10.989046 -0.181750595 -0.894697548 1.09114074 14.749813 -14.182918 ) (17.469253 -6.18206978 13.8551159 -13.0917778 -26.380886 4.36775208 ) (18.133926 -17.089969 -12.52577 -8.7240257 -11.226255 8.71190835 ) (-0.00497087091 -21.458042 -23.752025 -0.0121169965 11.285902 8.78460885 ) (-18.114044 -17.077854 -12.466123 8.77249337 26.082653 4.14965058 ) (-17.538841 -6.2305355 13.616529 12.9221439 -13.616529 -13.3832149 ) (-10.730577 9.96515154E-8 0 -0.461072266 -13.616529 13.3832149 ) (-17.538841 6.23053647 -13.616529 12.9221439 26.082653 -4.14965058 ) (-18.114044 17.077854 12.466123 8.77249337 11.285898 -8.78460885 ) (-0.00496927649 21.458042 23.752021 -0.0121165085 -11.2262497 -8.71190835 ) (18.133926 17.089969 12.525772 -8.7240257 -26.380889 -4.36775208 ) (17.469253 6.18206883 -13.8551178 -13.0917778 14.749815 14.182918 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 57Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:11:04) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((73 0) (321 337)) NIL ((248. 337. 0 0 0 0 )) NATURAL) (2 ((321 337) (369 337)) NIL ((48. 0 0 0 0 0 )) NATURAL) (2 ((369 337) (121 0)) NIL ((-248. -337. 0 0 0 0 )) NATURAL) (2 ((121 0) (73 0)) NIL ((-48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 73Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:15:21) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((219 232) (206 230) (186 218) (176 198) (186 178) (206 166) (219 164) (232 166) (252 178) (262 198) (252 218) (232 230) (219 232)) NIL ((-10.989046 -0.181750595 0.894697548 1.09114074 -14.749813 -14.182918 ) (-17.469253 -6.18206978 -13.8551159 -13.0917778 26.380886 4.36775208 ) (-18.133926 -17.089969 12.52577 -8.7240257 11.226255 8.71190835 ) (0.00497087091 -21.458042 23.752025 -0.0121169965 -11.285902 8.78460885 ) (18.114044 -17.077854 12.466123 8.77249337 -26.082653 4.14965058 ) (17.538841 -6.2305355 -13.616529 12.9221439 13.616529 -13.3832149 ) (10.730577 9.96515154E-8 0 -0.461072266 13.616529 13.3832149 ) (17.538841 6.23053647 13.616529 12.9221439 -26.082653 -4.14965058 ) (18.114044 17.077854 -12.466123 8.77249337 -11.285898 -8.78460885 ) (0.00496927649 21.458042 -23.752021 -0.0121165085 11.2262497 -8.71190835 ) (-18.133926 17.089969 -12.525772 -8.7240257 26.380889 -4.36775208 ) (-17.469253 6.18206883 13.8551178 -13.0917778 -14.749815 14.182918 )) PSEUDOCYCLIC)) ((20 ((218 -3) (215 -21) (195 -31) (177 -36) (170 -49) (186 -57) (215 -53) (234 -44) (247 -32) (259 -9) (263 29) (255 50) (241 61) (213 66) (195 61) (181 49) (175 29) (185 9) (205 -3) (218 -3)) NIL ((1.58461880 -19.619796 0 0 -27.507713 9.7187805 ) (-12.169239 -14.760406 -27.507713 9.7187805 35.538574 -0.593902588 ) (-21.907661 -5.3385763 8.0308647 9.1248779 -0.646611214 -25.343174 ) (-14.2001037 -8.88528634 7.3842535 -16.218296 21.047866 23.966606 ) (3.70808458 -13.120277 28.43212 7.748312 -11.544872 7.47673417 ) (26.367767 -1.63359856 16.887249 15.225046 -34.86837 -11.8735466 ) (25.820831 7.65467358 -17.981121 3.35149956 13.018354 -1.98254537 ) (14.34889 10.0149 -4.9627657 1.36895418 6.7949543 7.80372716 ) (12.7836017 15.2857208 1.8321886 9.1726818 -10.198175 18.767623 ) (9.51670075 33.842208 -8.36598779 27.940307 -8.00224114 -58.874214 ) (-2.85040808 32.345413 -16.3682289 -30.93391 18.207134 24.729248 ) (-10.115068 13.7761268 1.83890652 -6.20466138 -28.826297 1.95721817 ) (-22.689312 8.5500736 -26.987392 -4.2474432 49.09806 -8.5581188 ) (-25.127674 0.0235716477 22.110672 -12.8055629 -23.565967 8.275259 ) (-14.7999859 -8.6443615 -1.45529556 -4.53030396 9.1658039 -6.54291535 ) (-11.672378 -16.446121 7.7105093 -11.073219 10.902744 11.896402 ) (1.48950433 -21.57114 18.613254 0.823183776 -4.77679062 6.95730019 ) (17.714363 -17.269306 13.8364639 7.7804842 -27.795578 8.27439309 ) (17.653038 -5.35162544 -13.959116 16.054878 13.959116 -16.054878 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 72Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:16:21) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((7 ((219 164) (206 166) (186 178) (176 198) (186 218) (206 230) (219 232)) NIL ((-10.730768 -0.133333206 0 0 -13.615383 12.799999 ) (-17.538459 6.2666664 -13.615383 12.799999 26.076919 -4. ) (-18.115383 17.066665 12.461538 8.79999925 11.3076915 -8.79999925 ) (6.37024641E-7 21.466663 23.769229 0 -11.307693 -8.79999925 ) (18.115383 17.066665 12.461536 -8.79999925 -26.076919 -4. ) (17.538459 6.2666664 -13.615383 -12.799999 13.615383 12.799999 )) NATURAL) (7 ((219 232) (232 230) (252 218) (262 198) (252 178) (232 166) (219 164)) NIL ((10.730768 0.133333206 0 0 13.615383 -12.799999 ) (17.538459 -6.2666664 13.615383 -12.799999 -26.076919 4. ) (18.115383 -17.066665 -12.461538 -8.79999925 -11.3076915 8.79999925 ) (-6.37024641E-7 -21.466663 -23.769229 0 11.307693 8.79999925 ) (-18.115383 -17.066665 -12.461536 8.79999925 26.076919 4. ) (-17.538459 -6.2666664 13.615383 12.799999 -13.615383 -12.799999 )) NATURAL)) ((7 ((219 -3) (206 -1) (186 11) (176 31) (186 51) (206 63) (219 65)) NIL ((-10.730768 -0.133333206 0 0 -13.615383 12.799999 ) (-17.538459 6.2666664 -13.615383 12.799999 26.076919 -4. ) (-18.115383 17.066665 12.461538 8.79999925 11.3076915 -8.79999925 ) (6.37024641E-7 21.466663 23.769229 0 -11.307693 -8.79999925 ) (18.115383 17.066665 12.461536 -8.79999925 -26.076919 -4. ) (17.538459 6.2666664 -13.615383 -12.799999 13.615383 12.799999 )) NATURAL) (7 ((219 65) (232 63) (252 51) (262 31) (252 11) (232 -1) (219 -3)) NIL ((10.730768 0.133333206 0 0 13.615383 -12.799999 ) (17.538459 -6.2666664 13.615383 -12.799999 -26.076919 4. ) (18.115383 -17.066665 -12.461538 -8.79999925 -11.3076915 8.79999925 ) (-6.37024641E-7 -21.466663 -23.769229 0 11.307693 8.79999925 ) (-18.115383 -17.066665 -12.461536 8.79999925 26.076919 4. ) (-17.538459 -6.2666664 13.615383 12.799999 -13.615383 -12.799999 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 45Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 8:31:26) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((17 ((118 338) (159 333) (186 321) (201 303) (207 277) (201 251) (186 233) (159 221) (118 216) (78 221) (51 233) (36 251) (30 277) (36 303) (51 321) (78 333) (118 338)) NIL ((43.632125 -0.0974335671 1.31016326 -11.476913 -19.723274 5.01534176 ) (35.08065 -9.0666752 -18.413112 -6.4615717 6.75541115 1.78477382 ) (20.045242 -14.63586 -11.657701 -4.67679787 4.70163059 -6.1544361 ) (10.7383575 -22.389877 -6.9560709 -10.8312339 -7.56193638 10.832973 ) (0.00131877139 -27.804622 -14.518007 0.00173969077 7.5461092 10.8225345 ) (-10.743633 -22.391616 -6.97189809 10.8242759 -4.62250042 -6.1231203 ) (-20.026783 -14.6289 -11.594398 4.70115566 -7.05610657 1.66994285 ) (-35.14923 -9.09277345 -18.650505 6.3710985 20.846931 5.4433527 ) (-43.376274 0 2.19642639 11.814451 13.668373 -5.44335366 ) (-34.345657 9.09277345 15.864799 6.37109757 -3.52042198 -1.66994095 ) (-20.241073 14.6289 12.344377 4.70115662 -5.5866909 6.12311745 ) (-10.6900406 22.391616 6.7576866 10.824274 7.8671856 -10.8225326 ) (0.00123898312 27.804622 14.624872 0.00174020207 -7.8820505 -10.832975 ) (10.685085 22.389877 6.7428217 -10.8312358 5.6610155 6.154438 ) (20.258415 14.63586 12.403837 -4.67679787 3.23799324 -1.78477382 ) (34.281242 9.0666752 15.64183 -6.4615717 -12.6129837 -5.01534176 )) PSEUDOCYCLIC)) ((13 ((318 25) (342 29) (364 43) (370 61) (364 79) (342 93) (318 96) (294 93) (272 79) (266 61) (272 43) (294 29) (318 25)) NIL ((24.01675 0.0585110932 -1.65684819 5.3434658 4.87002945 7.618536 ) (24.794918 9.21124459 3.2131815 12.9620018 -26.409057 -10.1534767 ) (14.803571 17.096508 -23.195877 2.80852413 16.766201 -3.00462341 ) (-0.00920486450 18.402717 -6.42967606 -0.196099460 -16.655742 -1.82802653 ) (-14.766752 17.292606 -23.085418 -2.02412605 25.856773 -13.683267 ) (-24.923782 8.42684747 2.77135515 -15.707393 -2.77135515 14.56109 ) (-23.538105 -8.00937414E-8 -1.27768117E-7 -1.14630294 -2.7713542 -14.56109 ) (-24.923782 -8.42684747 -2.77135467 -15.707393 25.856773 13.6832657 ) (-14.766752 -17.292606 23.085418 -2.02412653 -16.655742 1.82802701 ) (-0.00920422748 -18.402717 6.42967606 -0.196099311 16.766197 3.00462294 ) (14.803571 -17.096508 23.195873 2.80852365 -26.409053 10.1534767 ) (24.794918 -9.21124459 -3.21318102 12.9620018 4.8700285 -7.61853696 )) PSEUDOCYCLIC)) ((2 ((324 337) (73 0)) NIL ((-251. -337. 0 0 0 0 )) NATURAL) (3 ((73 0) (73 0) (118 0)) NIL ((-11.25 0 0 0 67.5 0 ) (22.5 0 67.5 0 -67.5 0 )) NATURAL) (2 ((118 0) (369 337)) NIL ((251. 337. 0 0 0 0 )) NATURAL) (2 ((369 337) (324 337)) NIL ((-45. 0 0 0 0 0 )) NATURAL)) ((17 ((319 122) (360 117) (387 105) (402 87) (408 61) (402 35) (387 17) (360 5) (319 0) (279 5) (252 17) (237 35) (231 61) (237 87) (252 105) (279 117) (319 122)) NIL ((43.632125 -0.0974335671 1.31016326 -11.476913 -19.723274 5.01534176 ) (35.08065 -9.0666752 -18.413112 -6.4615717 6.75541115 1.78477382 ) (20.045242 -14.63586 -11.657701 -4.67679787 4.70163059 -6.1544361 ) (10.7383575 -22.389877 -6.9560709 -10.8312339 -7.56193638 10.832973 ) (0.00131877139 -27.804622 -14.518007 0.00173969077 7.5461092 10.8225345 ) (-10.743633 -22.391616 -6.97189809 10.8242759 -4.62250042 -6.1231203 ) (-20.026783 -14.6289 -11.594398 4.70115566 -7.05610657 1.66994285 ) (-35.14923 -9.09277345 -18.650505 6.3710985 20.846931 5.4433527 ) (-43.376274 0 2.19642639 11.814451 13.668373 -5.44335366 ) (-34.345657 9.09277345 15.864799 6.37109757 -3.52042198 -1.66994095 ) (-20.241073 14.6289 12.344377 4.70115662 -5.5866909 6.12311745 ) (-10.6900406 22.391616 6.7576866 10.824274 7.8671856 -10.8225326 ) (0.00123898312 27.804622 14.624872 0.00174020207 -7.8820505 -10.832975 ) (10.685085 22.389877 6.7428217 -10.8312358 5.6610155 6.154438 ) (20.258415 14.63586 12.403837 -4.67679787 3.23799324 -1.78477382 ) (34.281242 9.0666752 15.64183 -6.4615717 -12.6129837 -5.01534176 )) PSEUDOCYCLIC)) ((13 ((118 312) (142 309) (164 295) (170 277) (164 259) (142 245) (118 241) (94 245) (72 259) (66 277) (72 295) (94 309) (118 312)) NIL ((23.538459 -0.330866456 0 0 2.76922989 -16.014801 ) (24.923076 -8.33826829 2.76922989 -16.014801 -25.846149 14.074016 ) (14.769228 -17.316059 -23.076919 -1.94078445 16.615379 1.71872663 ) (-6.37024641E-7 -18.39748 -6.4615383 -0.222057670 -16.615379 3.0510726 ) (-14.7692318 -17.094001 -23.076919 2.82901525 25.846149 10.0769786 ) (-24.923076 -9.22649766 2.76923036 12.905994 -2.76922989 -7.35899258 ) (-23.538459 3.18512320E-7 2.55536235E-7 5.54700184 -2.76923132 7.35899258 ) (-24.923076 9.22649766 -2.76923132 12.905994 25.846153 -10.0769786 ) (-14.7692299 17.094001 23.076923 2.82901478 -16.6153869 -3.05107212 ) (6.37024641E-7 18.39748 6.4615364 -0.222057640 16.6153869 -1.71872687 ) (14.7692299 17.316059 23.076923 -1.94078469 -25.846153 -14.074014 ) (24.923076 8.33826638 -2.76923084 -16.014801 2.76923084 16.014801 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 44Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 9:30:26) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((236 364) (236 344)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (7 ((236 344) (277 339) (309 330) (331 320) (348 309) (363 291) (367 260)) NIL ((42.793586 -4. 0 0 -10.7615375 -6. ) (37.412818 -7. -10.7615375 -6. -0.192308426 6. ) (26.555126 -9.9999981 -10.9538459 6.81195899E-8 5.5307703 -3.23568030E-7 ) (18.366664 -10. -5.42307568 -2.55448469E-7 8.0692272 -5.9999981 ) (16.978202 -13. 2.6461525 -5.99999905 -19.807685 -12. ) (9.72051049 -25. -17.161533 -18. 17.161533 18. )) NATURAL) (2 ((367 260) (329 260)) NIL ((-38. 0 0 0 0 0 )) NATURAL) (6 ((329 260) (324 280) (312 294) (288 305) (261 312) (236 316)) NIL ((-3.91866016 21.454544 0 0 -6.488039 -8.72727204 ) (-7.16267968 17.090908 -6.488039 -8.72727204 -9.5598049 7.63636208 ) (-18.430622 12.181818 -16.0478439 -1.09090924 14.727268 -3.81818056 ) (-27.11483 9.1818161 -1.32057404 -4.90909004 4.65071678 1.63636303 ) (-26.110046 5.090909 3.33014345 -3.27272701 -3.33014345 3.27272701 )) NATURAL) (2 ((236 316) (236 197)) NIL ((0 -119. 0 0 0 0 )) NATURAL) (11 ((236 197) (280 187) (313 177) (342 161) (366 136) (376 92) (370 55) (346 27) (313 9) (274 -1) (236 -6)) NIL ((46.700439 -10.36273 0 0 -16.202648 2.17638588 ) (38.599113 -9.27453805 -16.202648 2.17638588 15.013242 -10.881929 ) (29.903087 -12.5391159 -1.18940448 -8.7055435 -1.85032797 5.3513317 ) (27.78852 -18.568992 -3.03973246 -3.35421133 -13.6119308 -28.523391 ) (17.942817 -36.184898 -16.651664 -31.877605 2.29807663 48.74224 ) (2.44018984 -43.691383 -14.353588 16.864639 -7.58037568 -10.4455948 ) (-15.703586 -32.049545 -21.933963 6.41904355 16.023418 5.0401411 ) (-29.625843 -23.110427 -5.9105444 11.4591846 -2.51330852 -3.71496868 ) (-36.793037 -13.508728 -8.4238529 7.74421597 12.0298156 -2.18027019 ) (-39.20198 -6.8546486 3.60596323 5.56394577 -3.60596323 -5.56394577 )) NATURAL) (2 ((236 -6) (236 -35)) NIL ((0 -29. 0 0 0 0 )) NATURAL) (2 ((236 -35) (192 -35)) NIL ((-44. 0 0 0 0 0 )) NATURAL) (2 ((192 -35) (192 -6)) NIL ((0 29. 0 0 0 0 )) NATURAL) (6 ((192 -6) (141 -4) (99 8) (75 23) (55 49) (46 85)) NIL ((-52.143539 -0.626794100 0 0 6.8612442 15.760765 ) (-48.712913 7.2535877 6.8612442 15.760765 19.693779 -18.803825 ) (-32.004783 13.61244 26.555023 -3.04306173 -31.63636 17.45454 ) (-21.26794 19.296649 -5.08133984 14.4114818 22.851673 -3.0143528 ) (-14.9234447 32.20095 17.770336 11.397129 -17.770336 -11.397129 )) NATURAL) (2 ((46 85) (90 85)) NIL ((44. 0 0 0 0 0 )) NATURAL) (6 ((90 85) (93 69) (103 49) (127 33) (162 25) (192 22)) NIL ((1.89473676 -14.770334 0 0 6.63157845 -7.37798978 ) (5.21052647 -18.459327 6.63157845 -7.37798978 8.84210588 12.8899498 ) (16.2631569 -19.392341 15.473684 5.51196099 -1.90734863E-6 3.81818199 ) (31.736839 -11.9712906 15.473682 9.33014298 -26.842102 -4.16267872 ) (33.789466 -4.72248745 -11.3684196 5.16746426 11.3684196 -5.16746426 )) NATURAL) (2 ((192 22) (192 159)) NIL ((0 137. 0 0 0 0 )) NATURAL) (11 ((192 159) (151 173) (118 185) (93 197) (70 219) (61 263) (73 296) (94 315) (124 331) (160 341) (192 344)) NIL ((-42.561904 14.467121 0 0 9.37145997 -2.80273056 ) (-37.876174 13.0657558 9.37145997 -2.80273056 1.14269447 2.01365328 ) (-27.933368 11.2698516 10.514154 -0.789076925 -13.9422378 6.74811555 ) (-24.390335 13.854833 -3.4280839 5.95903874 18.626262 30.993877 ) (-18.505283 35.310806 15.198179 36.952919 11.437181 -58.72363 ) (2.41148281 42.901908 26.63536 -21.770717 -22.374977 5.900671 ) (17.859352 24.081527 4.26038075 -15.870046 6.06273175 17.120952 ) (25.1511 16.771957 10.323112 1.25090599 -1.87594414 -8.38448144 ) (34.536239 13.830625 8.44716836 -7.13357545 -16.5589599 -1.5830307 ) (34.703926 5.90553475 -8.1117916 -8.71660615 8.1117916 8.71660615 )) NATURAL) (2 ((192 344) (192 364)) NIL ((0 20. 0 0 0 0 )) NATURAL) (2 ((192 364) (236 364)) NIL ((44. 0 0 0 0 0 )) NATURAL)) ((2 ((192 316) (192 212)) NIL ((0 -104. 0 0 0 0 )) NATURAL) (9 ((192 212) (160 221) (133 229) (109 243) (103 266) (115 290) (134 304) (161 312) (192 316)) NIL ((-33.384933 9.54270936 0 0 8.3096447 -3.25625897 ) (-29.230114 7.9145794 8.3096447 -3.25625897 -11.548229 10.2812957 ) (-26.694583 9.79896928 -3.238585 7.0250368 25.883277 4.13107395 ) (-16.991527 18.889541 22.644695 11.1561107 -1.98490143 -8.8055935 ) (4.66071415 25.642856 20.659793 2.35051584 -17.943664 -16.908687 ) (16.348674 19.539024 2.71612644 -14.558174 7.75957204 10.440353 ) (22.944587 10.2010288 10.475698 -4.11781979 -7.09462357 -0.852724076 ) (29.872974 5.65684796 3.3810749 -4.97054386 -3.3810749 4.97054386 )) NATURAL)) ((10 ((236 143) (268 135) (301 125) (326 111) (339 86) (333 61) (313 41) (286 31) (262 26) (236 23)) NIL ((31.306991 -7.5433216 0 0 4.15804672 -2.74006653 ) (33.386009 -8.91335488 4.15804672 -2.74006653 -14.790233 1.70033264 ) (30.148944 -10.803255 -10.6321869 -1.03973388 1.00288772 -16.061264 ) (20.018199 -19.873619 -9.62929917 -17.1009979 -13.221313 20.544723 ) (3.77824688 -26.702255 -22.850612 3.44372892 9.88235665 -0.117646694 ) (-14.131187 -23.317348 -12.968256 3.32608223 3.69189644 9.92585755 ) (-25.253494 -15.028337 -9.27635957 13.2519397 17.350055 -9.58579064 ) (-25.854827 -6.56929303 8.07369615 3.66614914 -13.092119 -1.58268642 ) (-24.32719 -3.69448757 -5.01842404 2.08346271 5.01842404 -2.08346271 )) NATURAL) (2 ((236 23) (236 143)) NIL ((0 120. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.S2-SF b/lispusers/GACHAE.S2-SF new file mode 100644 index 00000000..e293c5ed --- /dev/null +++ b/lispusers/GACHAE.S2-SF @@ -0,0 +1 @@ + ((FAMILY gacha) (CHARACTER 74Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:22:05) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((60 169) (312 0)) NIL ((252. -169. 0 0 0 0 )) NATURAL) (2 ((312 0) (372 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((372 0) (120 169)) NIL ((-252. 169. 0 0 0 0 )) NATURAL) (2 ((120 169) (370 337)) NIL ((250. 168. 0 0 0 0 )) NATURAL) (2 ((370 337) (310 337)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((310 337) (60 169)) NIL ((-250. -168. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 75Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:22:46) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((82 148) (82 148)) NIL ((0 0 0 0 0 0 )) NATURAL)) ((2 ((82 148) (357 148)) NIL ((275. 0 0 0 0 0 )) NATURAL) (2 ((357 148) (357 108)) NIL ((0 -40. 0 0 0 0 )) NATURAL) (2 ((357 108) (82 108)) NIL ((-275. 0 0 0 0 0 )) NATURAL) (2 ((82 108) (82 148)) NIL ((0 40. 0 0 0 0 )) NATURAL)) ((2 ((82 190) (357 190)) NIL ((275. 0 0 0 0 0 )) NATURAL) (2 ((357 190) (357 230)) NIL ((0 40. 0 0 0 0 )) NATURAL) (2 ((357 230) (82 230)) NIL ((-275. 0 0 0 0 0 )) NATURAL) (2 ((82 230) (82 190)) NIL ((0 -40. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 76Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:24:09) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((370 169) (118 0)) NIL ((-252. -169. 0 0 0 0 )) NATURAL) (2 ((118 0) (58 0)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((58 0) (310 169)) NIL ((252. 169. 0 0 0 0 )) NATURAL) (2 ((310 169) (60 337)) NIL ((-250. 168. 0 0 0 0 )) NATURAL) (2 ((60 337) (120 337)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((120 337) (370 169)) NIL ((250. -168. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 77Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:35:10) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((248 24) (243 6) (228 -9) (204 -14) (180 -9) (165 6) (160 24) (165 42) (180 57) (204 62) (228 57) (243 42) (248 24)) NIL ((-2.93116188 -18.230766 0 0 -12.4130268 1.38461542 ) (-9.13767625 -17.538459 -12.4130268 1.38461542 2.06513786 11.076921 ) (-20.518135 -10.615383 -10.3478889 12.461538 10.152477 -3.69230843 ) (-25.789783 3.18512320E-7 -0.195410430 8.7692299 11.3249416 3.69230843 ) (-20.322723 10.615383 11.1295318 12.461538 -1.45225525 -11.076921 ) (-9.91931916 17.538459 9.6772766 1.38461518 0.484085083 -1.38461518 ) (3.18512320E-7 18.230766 10.1613617 -1.91652190E-7 -0.484086990 -1.38461423 ) (9.91931916 17.538459 9.6772747 -1.38461446 1.45225715 -11.076923 ) (20.322723 10.615383 11.1295318 -12.461538 -11.3249416 3.69230843 ) (25.789783 -3.18512320E-7 -0.195410639 -8.7692299 -10.152477 -3.69230843 ) (20.518131 -10.615383 -10.3478889 -12.461538 -2.06513786 11.076921 ) (9.13767434 -17.538459 -12.4130268 -1.38461518 12.4130268 1.38461518 )) NATURAL)) ((18 ((76 258) (82 281) (100 310) (141 337) (184 345) (222 347) (265 344) (301 336) (330 322) (351 301) (358 272) (351 242) (325 219) (291 200) (256 185) (234 163) (230 120) (230 82)) NIL ((4.36275196 21.588817 0 0 9.8234863 8.46708489 ) (9.27449418 25.82236 9.8234863 8.46708489 22.882568 -6.33543015 ) (30.539264 31.12173 32.706054 2.13165474 -35.353759 -31.125358 ) (45.568435 17.690704 -2.64770508 -28.993705 -7.4675293 28.836875 ) (39.186965 3.11543942 -10.115234 -0.156827688 23.223876 -6.22215367 ) (40.68367 -0.152465343 13.108642 -6.3789816 -25.427978 2.05173683 ) (41.078323 -5.505579 -12.3193378 -4.32724476 6.48805333 -1.9847908 ) (32.003013 -10.825218 -5.83128453 -6.31203557 -0.524238587 -0.112575531 ) (25.909606 -17.193542 -6.3555231 -6.4246111 -10.391092 -3.56490803 ) (14.358539 -25.400604 -16.746616 -9.9895191 6.0886116 8.3722038 ) (0.656227112 -31.20402 -10.6580047 -1.61731481 -13.963348 12.0760917 ) (-16.983448 -26.78329 -24.621353 10.458778 19.764766 -8.6765785 ) (-31.722419 -20.662803 -4.85658455 1.78219914 0.904281617 4.63022518 ) (-36.12686 -16.56549 -3.95230293 6.41242505 18.618099 -9.8443241 ) (-30.770114 -15.075229 14.665796 -3.43189907 8.6233196 -31.252922 ) (-11.7926578 -34.13359 23.289115 -34.684822 -23.111393 50.856025 ) (-0.0592400506 -43.390396 0.177720159 16.171203 -0.177720159 -16.171203 )) NATURAL) (2 ((230 82) (178 82)) NIL ((-52. 0 0 0 0 0 )) NATURAL) (9 ((178 82) (176 130) (179 173) (191 195) (215 207) (241 217) (277 231) (300 247) (306 274)) NIL ((-2.93114853 48.008277 0 0 5.58689213 -0.0497055054 ) (-0.137702286 47.983429 5.58689213 -0.0497055054 2.06553745 -29.751472 ) (6.4819584 33.057983 7.65242959 -29.801178 10.150957 23.055595 ) (19.209865 14.7846088 17.803386 -6.74558068 -24.669364 3.52908611 ) (24.678569 9.8035698 -6.86597825 -3.21649456 28.526504 10.828054 ) (32.075843 12.001104 21.660526 7.6115608 -41.43666 -10.8413086 ) (33.018035 14.1920089 -19.776138 -3.2297492 -0.779823304 20.537181 ) (12.8519859 21.230854 -20.555961 17.307434 20.555961 -17.307434 )) NATURAL) (8 ((306 274) (300 293) (276 312) (234 318) (202 317) (155 308) (133 281) (128 258)) NIL ((-2.76743364 18.186187 0 0 -19.395397 4.88285733 ) (-12.4651317 20.627616 -19.395397 4.88285733 -11.023014 -24.414283 ) (-37.372032 13.303329 -30.41841 -19.531429 63.487457 14.774301 ) (-36.046714 1.15905142 33.069046 -4.7571268 -74.926818 1.31707191 ) (-40.441085 -2.9395399 -41.85778 -3.44005489 86.219848 -26.042594 ) (-39.188934 -19.40089 44.362075 -29.48265 -29.952594 42.853309 ) (-9.8031597 -27.456886 14.409479 13.3706627 -14.409479 -13.3706627 )) NATURAL) (2 ((128 258) (76 258)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 100Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:41:59) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((25 ((274 84) (315 89) (349 101) (378 127) (388 169) (382 261) (346 310) (312 329) (274 340) (222 346) (169 340) (132 329) (97 310) (61 261) (49 169) (61 77) (99 29) (132 9) (169 -2) (222 -8) (273 -1) (312 10) (339 25) (357 40) (372 65)) NIL ((42.841934 4.12846947 0 0 -11.051645 5.22917843 ) (37.316116 6.74305916 -11.051645 5.22917843 13.25823 15.8541069 ) (32.893585 19.899292 2.2065854 21.083286 -29.98128 -26.645618 ) (20.109527 27.659767 -27.774696 -5.562335 22.666904 102.72837 ) (3.66828489 73.461624 -5.10779095 97.166046 -42.686332 -180.2678 ) (-22.782672 80.49371 -47.794128 -83.101837 64.07843 60.343216 ) (-38.537582 27.563484 16.284305 -22.758621 -21.627391 16.8949508 ) (-33.066978 13.252338 -5.3430872 -5.8636694 -13.568861 4.07696724 ) (-45.194496 9.42715455 -18.911949 -1.78670144 15.902847 -15.202821 ) (-56.15502 0.0390407219 -3.00910091 -16.9895248 27.957454 14.734329 ) (-45.185394 -9.5833187 24.948356 -2.25519466 -25.732685 -1.7344985 ) (-33.103378 -12.7057628 -0.784330249 -3.98969317 -9.0267067 -25.796333 ) (-38.401062 -29.593627 -9.81103707 -29.786029 43.839515 -27.080135 ) (-26.292339 -72.91972 34.02848 -56.866165 -16.33139 56.116867 ) (-0.429553986 -101.7274 17.69709 -0.749291659 21.486053 60.612625 ) (28.010566 -72.170425 39.183143 59.863334 -57.61283 -34.567375 ) (38.38729 -29.590789 -18.429687 25.295959 22.96529 -18.343135 ) (31.440254 -13.466398 4.53560543 6.95282174 19.751655 -6.06007004 ) (45.851684 -9.5436115 24.287262 0.892751694 -29.971923 18.583416 ) (55.152984 0.640850663 -5.68466473 19.476169 -7.86394025 -20.273609 ) (45.536346 9.98021318 -13.5486049 -0.797443152 1.42769622 8.51104165 ) (32.70159 13.438291 -12.1209087 7.71360016 2.15315056 -13.770559 ) (21.65726 14.266613 -9.96775819 -6.0569601 7.9596977 22.571197 ) (15.669353 19.49525 -2.00806045 16.51424 2.00806045 -16.51424 )) NATURAL) (2 ((372 65) (326 65)) NIL ((-46. 0 0 0 0 0 )) NATURAL) (13 ((326 65) (310 43) (285 30) (260 22) (223 17) (194 19) (167 25) (140 37) (120 53) (103 82) (98 111) (96 143) (95 169)) NIL ((-13.31982 -24.077533 0 0 -16.0810699 12.4652157 ) (-21.360355 -17.8449249 -16.0810699 12.4652157 26.405349 -8.32608224 ) (-24.23875 -9.5427513 10.3242817 4.1391325 -35.540336 -3.16088247 ) (-31.684639 -6.98406029 -25.21606 0.978249670 43.756027 8.96961595 ) (-35.022682 -1.52100181 18.53997 9.94786645 -19.483806 -8.7175865 ) (-26.224617 4.0680704 -0.943838716 1.23027920 -1.82078004 7.90073395 ) (-28.078846 9.24871636 -2.76461887 9.13101388 14.766931 -10.885349 ) (-23.459995 12.937055 12.0023136 -1.75433612 -15.246952 23.640663 ) (-19.081157 23.003051 -3.24463844 21.886329 22.220874 -29.677307 ) (-11.2153568 30.050727 18.976238 -7.79098035 -19.636566 17.068573 ) (-2.05740309 30.794033 -0.660330892 9.2775936 2.32541323 -20.596992 ) (-1.55502748 29.773132 1.66508269 -11.3193988 -1.66508269 11.3193988 )) NATURAL) (9 ((95 169) (96 195) (98 227) (103 256) (120 285) (140 301) (167 313) (194 319) (223 321)) NIL ((0.722201824 24.113586 0 0 1.66678905 11.318481 ) (1.55559635 29.772827 1.66678905 11.318481 -2.33394575 -20.592411 ) (2.05541229 30.7951 -0.667156935 -9.2739315 19.668994 17.051174 ) (11.222753 30.046756 19.001838 7.7772455 -22.34204 -29.612293 ) (19.053569 23.017852 -3.34020567 -21.835048 15.699186 23.398006 ) (23.562957 12.881811 12.358982 1.56295967 -16.454708 -9.97974778 ) (27.694583 9.454895 -4.09572888 -8.4167881 8.11966134 4.52098465 ) (27.658687 3.29860067 4.02393246 -3.89580298 -4.02393246 3.89580298 )) NATURAL) (7 ((223 321) (252 319) (279 313) (306 301) (326 285) (343 256) (348 227)) NIL ((29.670509 -1.34871792 0 0 -4.02307606 -3.90769243 ) (27.658973 -3.30256414 -4.02307606 -3.90769243 8.11538316 -4.46153736 ) (27.693588 -9.44102479 4.09230709 -8.36923028 -16.438457 9.7538433 ) (23.566665 -12.933332 -12.346153 1.38461446 15.63846 -22.55384 ) (19.039741 -22.825641 3.29230738 -21.169227 -22.115379 26.461532 ) (11.2743568 -30.764099 -18.823074 5.2923069 18.823074 -5.2923069 )) NATURAL) (12 ((348 227) (324 241) (300 250) (262 253) (217 242) (192 227) (174 204) (166 168) (181 124) (204 103) (231 91) (274 84)) NIL ((-24.775428 15.165264 0 0 4.6525793 -6.99158669 ) (-22.449138 11.6694698 4.6525793 -6.99158669 -23.262893 4.95793438 ) (-29.428009 7.1568508 -18.610317 -2.0336523 4.3990097 -18.8401489 ) (-45.83882 -4.2968769 -14.211307 -20.873802 47.666854 22.402671 ) (-36.216697 -13.969343 33.45555 1.52886963 -33.066444 -10.770544 ) (-19.294372 -17.825744 0.389100015 -9.2416744 6.59894753 -3.32049179 ) (-15.605798 -28.727664 6.9880476 -12.562166 24.670658 -5.9474926 ) (3.71757555 -44.26358 31.658706 -18.509658 -27.281574 57.110458 ) (21.735492 -34.218002 4.37713242 38.600799 -5.54436779 -36.494346 ) (23.340442 -13.8643818 -1.16723537 2.10645246 25.459041 4.86693383 ) (34.902725 -9.32446099 24.291809 6.97338677 -24.291809 -6.97338677 )) NATURAL)) ((21 ((203 170) (205 183) (211 201) (225 217) (249 226) (270 229) (291 226) (315 217) (329 201) (335 183) (337 170) (335 157) (329 139) (315 123) (291 114) (270 111) (249 114) (225 123) (211 139) (205 157) (203 170)) NIL ((1.29664564 11.627071 0 0 4.2201252 8.2375679 ) (3.40670824 15.745855 4.2201252 8.2375679 2.89937305 -11.187843 ) (9.076519 18.389499 7.11949826 -2.95027637 8.18238069 -5.48618603 ) (20.287208 12.6961307 15.3018799 -8.4364624 -23.628898 3.13259506 ) (23.774639 5.82596588 -8.32702066 -5.30386734 8.33322335 -1.04419803 ) (19.614231 -3.18512320E-7 0.00620389823 -6.34806538 8.29599954 1.04419803 ) (23.768432 -5.82596684 8.30220414 -5.30386734 -23.517223 -3.13259506 ) (20.312023 -12.6961326 -15.215021 -8.4364624 7.772912 5.48618603 ) (8.98345948 -18.389499 -7.4421091 -2.9502759 4.42556858 11.187843 ) (3.75413466 -15.745855 -3.01654005 8.2375679 -1.47518968 -8.2375679 ) (-8.00937414E-8 -11.627071 -4.49172974 0 1.47518968 -8.2375679 ) (-3.75413513 -15.745855 -3.01654005 -8.2375679 -4.42556763 11.187843 ) (-8.98345948 -18.389499 -7.44210816 2.95027685 -7.77291489 5.48618508 ) (-20.312023 -12.6961307 -15.215023 8.4364624 23.517227 -3.13259506 ) (-23.768432 -5.82596588 8.30220414 5.30386734 -8.29599954 1.04419803 ) (-19.614231 1.59256160E-7 0.00620390940 6.34806538 -8.33322335 -1.04419708 ) (-23.774639 5.82596684 -8.32702066 5.3038683 23.628898 3.1325941 ) (-20.287208 12.6961326 15.3018779 8.4364624 -8.18237878 -5.48618603 ) (-9.076519 18.389499 7.11949826 2.9502759 -2.89937305 -11.187843 ) (-3.40670824 15.745855 4.2201252 -8.2375679 -4.2201252 8.2375679 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 133Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:43:08) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((346 351) (94 351)) NIL ((-252. 0 0 0 0 0 )) NATURAL) (2 ((94 351) (94 -112)) NIL ((0 -463. 0 0 0 0 )) NATURAL) (2 ((94 -112) (346 -112)) NIL ((252. 0 0 0 0 0 )) NATURAL) (2 ((346 -112) (346 -76)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((346 -76) (141 -76)) NIL ((-205. 0 0 0 0 0 )) NATURAL) (2 ((141 -76) (141 315)) NIL ((0 391. 0 0 0 0 )) NATURAL) (2 ((141 315) (346 315)) NIL ((205. 0 0 0 0 0 )) NATURAL) (2 ((346 315) (346 351)) NIL ((0 36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 134Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:44:28) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((117 337) (370 0)) NIL ((253. -337. 0 0 0 0 )) NATURAL) (2 ((370 0) (322 0)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((322 0) (69 337)) NIL ((-253. 337. 0 0 0 0 )) NATURAL) (2 ((69 337) (117 337)) NIL ((48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 135Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:45:24) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((346 351) (94 351)) NIL ((-252. 0 0 0 0 0 )) NATURAL) (2 ((94 351) (94 315)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((94 315) (299 315)) NIL ((205. 0 0 0 0 0 )) NATURAL) (2 ((299 315) (299 -76)) NIL ((0 -391. 0 0 0 0 )) NATURAL) (2 ((299 -76) (94 -76)) NIL ((-205. 0 0 0 0 0 )) NATURAL) (2 ((94 -76) (94 -112)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((94 -112) (346 -112)) NIL ((252. 0 0 0 0 0 )) NATURAL) (2 ((346 -112) (346 351)) NIL ((0 463. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 136Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:48:17) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((219 302) (71 183)) NIL ((-148. -119. 0 0 0 0 )) NATURAL) (2 ((71 183) (121 183)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((121 183) (198 239)) NIL ((77. 56. 0 0 0 0 )) NATURAL) (2 ((198 239) (198 42)) NIL ((0 -197. 0 0 0 0 )) NATURAL) (2 ((198 42) (240 42)) NIL ((42. 0 0 0 0 0 )) NATURAL) (2 ((240 42) (240 239)) NIL ((0 197. 0 0 0 0 )) NATURAL) (2 ((240 239) (316 183)) NIL ((76. -56. 0 0 0 0 )) NATURAL) (2 ((316 183) (366 183)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((366 183) (219 302)) NIL ((-147. 119. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 137Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:49:20) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((22 169) (198 285)) NIL ((176. 116. 0 0 0 0 )) NATURAL) (2 ((198 285) (198 233)) NIL ((0 -52. 0 0 0 0 )) NATURAL) (2 ((198 233) (130 191)) NIL ((-68. -42. 0 0 0 0 )) NATURAL) (2 ((130 191) (411 191)) NIL ((281. 0 0 0 0 0 )) NATURAL) (2 ((411 191) (411 147)) NIL ((0 -44. 0 0 0 0 )) NATURAL) (2 ((411 147) (130 147)) NIL ((-281. 0 0 0 0 0 )) NATURAL) (2 ((130 147) (198 105)) NIL ((68. -42. 0 0 0 0 )) NATURAL) (2 ((198 105) (198 53)) NIL ((0 -52. 0 0 0 0 )) NATURAL) (2 ((198 53) (22 169)) NIL ((-176. 116. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 173Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:53:08) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((7 ((313 351) (284 348) (250 338) (224 326) (205 311) (191 293) (182 259)) NIL ((-27.201278 -1.20512819 0 0 -10.7923069 -10.7692299 ) (-32.597435 -6.5897436 -10.7923069 -10.7692299 23.961536 11.846151 ) (-31.408973 -11.4358959 13.169229 1.07692265 -7.0538454 -6.61538315 ) (-21.766666 -13.666666 6.1153841 -5.53846073 -1.74615383 8.61538316 ) (-16.5243568 -14.897436 4.36923027 3.07692337 2.03846168 -27.846153 ) (-11.1358966 -25.743587 6.40769196 -24.769229 -6.40769196 24.769229 )) NATURAL) (2 ((182 259) (182 179)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (6 ((182 179) (176 162) (154 142) (130 133) (103 128) (79 126)) NIL ((-1.78468942 -15.4688987 0 0 -25.291862 -9.18660165 ) (-14.430622 -20.062198 -25.291862 -9.18660165 30.459323 27.93301 ) (-24.49282 -15.282295 5.1674633 18.74641 -12.545452 -18.545452 ) (-25.598083 -5.80861187 -7.37798978 0.200957238 13.722486 4.24880219 ) (-26.11483 -3.483253 6.34449769 4.44975949 -6.34449769 -4.44975949 )) NATURAL) (2 ((79 126) (79 106)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (6 ((79 106) (103 104) (130 99) (154 90) (176 70) (182 53)) NIL ((22.942581 -1.25837326 0 0 6.34449673 -4.44976044 ) (26.11483 -3.48325348 6.34449673 -4.44976044 -13.722486 4.24880314 ) (25.598083 -5.80861187 -7.37798978 -0.200957209 12.545454 -18.545452 ) (24.49282 -15.282297 5.16746426 -18.74641 -30.459327 27.933013 ) (14.430622 -20.062198 -25.291866 9.18660356 25.291866 -9.18660356 )) NATURAL) (2 ((182 53) (182 -27)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (7 ((182 -27) (191 -61) (205 -79) (224 -94) (250 -106) (284 -116) (313 -119)) NIL ((7.9320507 -38.128204 0 0 6.40769196 24.769229 ) (11.1358966 -25.743587 6.40769196 24.769229 -2.03846168 -27.846149 ) (16.5243568 -14.897434 4.36923027 -3.07692242 1.74615478 8.61538316 ) (21.766666 -13.666666 6.11538506 5.53846073 7.05384446 -6.61538315 ) (31.408973 -11.4358959 13.169229 -1.07692289 -23.961536 11.846151 ) (32.597435 -6.58974267 -10.7923069 10.7692299 10.7923069 -10.7692299 )) NATURAL) (2 ((313 -119) (332 -119)) NIL ((19. 0 0 0 0 0 )) NATURAL) (2 ((332 -119) (332 -83)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((332 -83) (307 -83)) NIL ((-25. 0 0 0 0 0 )) NATURAL) (5 ((307 -83) (276 -78) (255 -69) (237 -54) (229 -29)) NIL ((-33.642852 4.17857075 0 0 15.857141 4.92857075 ) (-25.714283 6.6428566 15.857141 4.92857075 -19.285709 -0.642856598 ) (-19.5 11.25 -3.42857075 4.28571415 19.285709 9.6428566 ) (-13.285713 20.357139 15.857141 13.9285717 -15.857141 -13.9285717 )) NATURAL) (2 ((229 -29) (229 41)) NIL ((0 70. 0 0 0 0 )) NATURAL) (6 ((229 41) (223 63) (210 84) (195 96) (180 106) (157 116)) NIL ((-4.30622006 21.660285 0 0 -10.1626777 2.03827715 ) (-9.3875599 22.679424 -10.1626777 2.03827715 8.81339456 -16.191383 ) (-15.143539 16.622005 -1.34928202 -14.153108 4.90909004 14.72727 ) (-14.038276 9.8325348 3.55980825 0.574162603 -16.449756 -0.717703223 ) (-18.703346 10.0478458 -12.8899517 -0.143540680 12.8899517 0.143540680 )) NATURAL) (6 ((157 116) (180 126) (195 136) (210 148) (223 169) (229 191)) NIL ((25.148323 9.9760761 0 0 -12.8899517 0.143540561 ) (18.703346 10.0478458 -12.8899517 0.143540561 16.449756 -0.717702747 ) (14.038276 9.8325348 3.55980825 -0.574162245 -4.90909004 14.72727 ) (15.143539 16.622009 -1.3492825 14.153108 -8.81339456 -16.191383 ) (9.38755799 22.679424 -10.1626777 -2.03827715 10.1626777 2.03827715 )) NATURAL) (2 ((229 191) (229 261)) NIL ((0 70. 0 0 0 0 )) NATURAL) (5 ((229 261) (237 286) (255 301) (276 310) (307 315)) NIL ((5.35714245 27.321426 0 0 15.857141 -13.9285698 ) (13.285713 20.357139 15.857141 -13.9285698 -19.285709 9.6428547 ) (19.5 11.249998 -3.42857075 -4.28571415 19.285709 -0.642856598 ) (25.714283 6.6428566 15.857141 -4.92857075 -15.857141 4.92857075 )) NATURAL) (2 ((307 315) (332 315)) NIL ((25. 0 0 0 0 0 )) NATURAL) (2 ((332 315) (332 351)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((332 351) (313 351)) NIL ((-19. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 174Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:54:25) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((195 351) (195 -112)) NIL ((0 -463. 0 0 0 0 )) NATURAL) (2 ((195 -112) (246 -112)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((246 -112) (246 351)) NIL ((0 463. 0 0 0 0 )) NATURAL) (2 ((246 351) (195 351)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 175Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:58:20) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((139 351) (158 351)) NIL ((19. 0 0 0 0 0 )) NATURAL) (7 ((158 351) (187 348) (221 338) (247 326) (266 311) (280 293) (289 259)) NIL ((27.201278 -1.20512819 0 0 10.7923069 -10.7692299 ) (32.597435 -6.5897436 10.7923069 -10.7692299 -23.961536 11.846151 ) (31.408973 -11.4358959 -13.169229 1.07692265 7.0538454 -6.61538315 ) (21.766666 -13.666666 -6.1153841 -5.53846073 1.74615383 8.61538316 ) (16.5243568 -14.897436 -4.36923027 3.07692337 -2.03846168 -27.846153 ) (11.1358966 -25.743587 -6.40769196 -24.769229 6.40769196 24.769229 )) NATURAL) (2 ((289 259) (289 179)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (6 ((289 179) (295 162) (317 142) (341 133) (368 128) (392 126)) NIL ((1.78468942 -15.4688987 0 0 25.291862 -9.18660165 ) (14.430622 -20.062198 25.291862 -9.18660165 -30.459323 27.93301 ) (24.49282 -15.282295 -5.1674633 18.74641 12.545452 -18.545452 ) (25.598083 -5.80861187 7.37798978 0.200957238 -13.722486 4.24880219 ) (26.11483 -3.483253 -6.34449769 4.44975949 6.34449769 -4.44975949 )) NATURAL) (2 ((392 126) (392 106)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (6 ((392 106) (368 104) (341 99) (317 90) (295 70) (289 53)) NIL ((-22.942581 -1.25837326 0 0 -6.34449673 -4.44976044 ) (-26.11483 -3.48325348 -6.34449673 -4.44976044 13.722486 4.24880314 ) (-25.598083 -5.80861187 7.37798978 -0.200957209 -12.545454 -18.545452 ) (-24.49282 -15.282297 -5.16746426 -18.74641 30.459327 27.933013 ) (-14.430622 -20.062198 25.291866 9.18660356 -25.291866 -9.18660356 )) NATURAL) (2 ((289 53) (289 -27)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (7 ((289 -27) (280 -61) (266 -79) (247 -94) (221 -106) (187 -116) (158 -119)) NIL ((-7.9320507 -38.128204 0 0 -6.40769196 24.769229 ) (-11.1358966 -25.743587 -6.40769196 24.769229 2.03846168 -27.846149 ) (-16.5243568 -14.897434 -4.36923027 -3.07692242 -1.74615478 8.61538316 ) (-21.766666 -13.666666 -6.11538506 5.53846073 -7.05384446 -6.61538315 ) (-31.408973 -11.4358959 -13.169229 -1.07692289 23.961536 11.846151 ) (-32.597435 -6.58974267 10.7923069 10.7692299 -10.7923069 -10.7692299 )) NATURAL) (2 ((158 -119) (139 -119)) NIL ((-19. 0 0 0 0 0 )) NATURAL) (2 ((139 -119) (139 -83)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((139 -83) (164 -83)) NIL ((25. 0 0 0 0 0 )) NATURAL) (5 ((164 -83) (195 -78) (216 -69) (234 -54) (242 -29)) NIL ((33.642852 4.17857075 0 0 -15.857141 4.92857075 ) (25.714283 6.6428566 -15.857141 4.92857075 19.285709 -0.642856598 ) (19.5 11.25 3.42857075 4.28571415 -19.285709 9.6428566 ) (13.285713 20.357139 -15.857141 13.9285717 15.857141 -13.9285717 )) NATURAL) (2 ((242 -29) (242 41)) NIL ((0 70. 0 0 0 0 )) NATURAL) (6 ((242 41) (248 63) (261 84) (276 96) (291 106) (314 116)) NIL ((4.30622006 21.660285 0 0 10.1626777 2.03827715 ) (9.3875599 22.679424 10.1626777 2.03827715 -8.81339456 -16.191383 ) (15.143539 16.622005 1.34928202 -14.153108 -4.90909004 14.72727 ) (14.038276 9.8325348 -3.55980825 0.574162603 16.449756 -0.717703223 ) (18.703346 10.0478458 12.8899517 -0.143540680 -12.8899517 0.143540680 )) NATURAL) (6 ((314 116) (291 126) (276 136) (261 148) (248 169) (242 191)) NIL ((-25.148323 9.9760761 0 0 12.8899517 0.143540561 ) (-18.703346 10.0478458 12.8899517 0.143540561 -16.449756 -0.717702747 ) (-14.038276 9.8325348 -3.55980825 -0.574162245 4.90909004 14.72727 ) (-15.143539 16.622009 1.3492825 14.153108 8.81339456 -16.191383 ) (-9.38755799 22.679424 10.1626777 -2.03827715 -10.1626777 2.03827715 )) NATURAL) (2 ((242 191) (242 261)) NIL ((0 70. 0 0 0 0 )) NATURAL) (5 ((242 261) (234 286) (216 301) (195 310) (164 315)) NIL ((-5.35714245 27.321426 0 0 -15.857141 -13.9285698 ) (-13.285713 20.357139 -15.857141 -13.9285698 19.285709 9.6428547 ) (-19.5 11.249998 3.42857075 -4.28571415 -19.285709 -0.642856598 ) (-25.714283 6.6428566 -15.857141 -4.92857075 15.857141 4.92857075 )) NATURAL) (2 ((164 315) (139 315)) NIL ((-25. 0 0 0 0 0 )) NATURAL) (2 ((139 315) (139 351)) NIL ((0 36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 176Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 8:03:50) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((70 84) (30 84)) NIL ((-40. 0 0 0 0 0 )) NATURAL) (13 ((30 84) (39 111) (55 131) (76 147) (106 158) (144 161) (184 156) (222 142) (249 131) (286 122) (327 124) (356 145) (366 161)) NIL ((7.34924794 28.65084 0 0 9.9045086 -9.9050579 ) (12.301502 23.69831 9.9045086 -9.9050579 -7.5225458 7.52529336 ) (18.444736 17.5559 2.3819623 -2.37976408 8.18567658 -2.19611978 ) (24.91954 14.078077 10.56764 -4.57588387 -1.22017288 -4.7408142 ) (34.87709 7.1317854 9.3474674 -9.31669808 -9.30498506 3.15938091 ) (39.572067 -0.605221987 0.0424815491 -6.15731717 2.44012308 -7.8967161 ) (40.83461 -10.710897 2.48260498 -14.054033 -24.455505 22.427482 ) (31.089466 -13.551187 -21.9729 8.37345124 41.381904 -9.8132267 ) (29.807518 -10.0843486 19.409004 -1.43977689 -15.07213 10.8254299 ) (41.680458 -6.1114111 4.33687306 9.38565446 -17.093372 20.511505 ) (37.470642 13.5299949 -12.7565 29.897159 -12.5543709 -44.871444 ) (18.436954 20.991428 -25.31087 -14.9742908 25.31087 14.9742908 )) NATURAL) (2 ((366 161) (406 161)) NIL ((40. 0 0 0 0 0 )) NATURAL) (7 ((406 161) (397 134) (381 114) (360 98) (330 87) (292 84) (252 89)) NIL ((-7.3487177 -28.653842 0 0 -9.90769197 9.9230766 ) (-12.3025627 -23.692306 -9.90769197 9.9230766 7.53846074 -7.6153841 ) (-18.441024 -17.576919 -2.36923075 2.30769205 -8.24615098 2.5384612 ) (-24.93333 -13.999998 -10.615383 4.84615326 1.44615364 3.46153832 ) (-34.825637 -7.42307664 -9.1692295 8.30769158 8.4615364 1.61538505 ) (-39.764099 1.69230771 -0.707692385 9.9230766 0.707692385 -9.9230766 )) NATURAL) (7 ((252 89) (214 103) (187 114) (150 123) (109 121) (80 100) (70 84)) NIL ((-41.551277 14.767948 0 0 21.307689 -4.60769177 ) (-30.897434 12.4641018 21.307689 -4.60769177 -40.538452 5.03846073 ) (-29.858974 10.3756408 -19.230766 0.430769324 14.846151 -9.546154 ) (-41.666664 6.03333283 -4.38461495 -9.11538507 17.1538429 -20.853843 ) (-37.474357 -13.508974 12.7692299 -29.96923 12.5384597 44.961532 ) (-18.435894 -20.997432 25.307689 14.992307 -25.307689 -14.992307 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.UC1-SF b/lispusers/GACHAE.UC1-SF new file mode 100644 index 00000000..9cc43ef0 --- /dev/null +++ b/lispusers/GACHAE.UC1-SF @@ -0,0 +1 @@ + ((FAMILY gacha) (CHARACTER 101Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 10:14:09) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((25 0) (157 337)) NIL ((132. 337. 0 0 0 0 )) NATURAL) (2 ((157 337) (280 337)) NIL ((123. 0 0 0 0 0 )) NATURAL) (2 ((280 337) (412 0)) NIL ((132. -337. 0 0 0 0 )) NATURAL) (2 ((412 0) (359 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL) (2 ((359 0) (321 98)) NIL ((-38. 98. 0 0 0 0 )) NATURAL) (2 ((321 98) (116 98)) NIL ((-205. 0 0 0 0 0 )) NATURAL) (2 ((116 98) (78 0)) NIL ((-38. -98. 0 0 0 0 )) NATURAL) (2 ((78 0) (25 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL)) ((2 ((305 141) (132 141)) NIL ((-173. 0 0 0 0 0 )) NATURAL) (2 ((132 141) (194 301)) NIL ((62. 160. 0 0 0 0 )) NATURAL) (2 ((194 301) (243 301)) NIL ((49. 0 0 0 0 0 )) NATURAL) (2 ((243 301) (305 141)) NIL ((62. -160. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 102Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 10:21:33) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((60 337) (60 337) (60 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((60 0) (225 0)) NIL ((165. 0 0 0 0 0 )) NATURAL) (11 ((225 0) (268 5) (307 15) (340 32) (364 59) (376 97) (370 132) (355 154) (339 167) (312 178) (283 185)) NIL ((43.77365 4.02735329 0 0 -4.64191437 5.83587933 ) (41.45269 6.94529343 -4.64191437 5.83587933 -0.790425301 0.820601464 ) (36.415565 13.191473 -5.43233967 6.6564808 -4.19638348 2.88171577 ) (28.885032 21.28881 -9.62872315 9.53819657 -0.424039841 5.65253067 ) (19.044288 33.653274 -10.052763 15.190727 -12.107458 -19.491832 ) (2.9377985 39.098083 -22.160221 -4.3011055 12.85387 -11.6851997 ) (-12.795486 28.954376 -9.3063507 -15.986305 14.691978 6.2326393 ) (-14.7558479 16.084388 5.3856287 -9.7536659 -23.621791 10.754642 ) (-21.181118 11.7080478 -18.236164 1.00097775 19.795204 -7.25122166 ) (-29.51968 9.08341409 1.5590415 -6.25024415 -1.5590415 6.25024415 )) NATURAL) (12 ((283 185) (318 199) (336 212) (349 227) (358 254) (352 287) (338 306) (319 319) (297 328) (279 332) (256 335) (225 337)) NIL ((39.205406 14.229002 0 0 -25.232437 -1.37401437 ) (26.589183 13.541994 -25.232437 -1.37401437 24.162193 0.870072127 ) (13.437845 12.6030159 -1.07024192 -0.503942251 0.583649278 15.893724 ) (12.6594276 20.045936 -0.486592591 15.3897838 -20.496791 -4.44498253 ) (1.924438 33.213226 -20.983387 10.944801 15.403532 -34.113792 ) (-11.357181 27.101131 -5.579854 -23.16899 0.882661820 20.900169 ) (-16.495704 14.3822269 -4.69719219 -2.26882028 -0.934181214 -1.48690176 ) (-21.659988 11.369955 -5.6313734 -3.75572205 14.854061 -2.9525671 ) (-19.86433 6.13794995 9.22268868 -6.70828915 -16.4820709 7.29716588 ) (-18.882679 3.07824373 -7.25938416 0.588877082 -2.9257679 -2.2360959 ) (-27.604946 2.54907274 -10.185152 -1.64721918 10.185152 1.64721918 )) NATURAL) (2 ((225 337) (60 337)) NIL ((-165. 0 0 0 0 0 )) NATURAL)) ((6 ((236 168) (269 163) (292 153) (304 143) (314 128) (319 101)) NIL ((34.904304 -3.62200928 0 0 -11.4258365 -8.26794244 ) (29.191387 -7.7559805 -11.4258365 -8.26794244 -2.87081337 11.339712 ) (16.330143 -10.3540668 -14.2966499 3.07177019 16.909088 -7.090909 ) (10.488037 -10.827751 2.6124401 -4.01913929 -10.7655506 -12.976072 ) (7.71770287 -21.334926 -8.1531105 -16.995212 8.1531105 16.995212 )) NATURAL) (6 ((319 101) (316 75) (304 57) (287 45) (268 39) (236 36)) NIL ((-0.971291781 -27.813396 0 0 -12.1722488 10.8803825 ) (-7.05741597 -22.373203 -12.1722488 10.8803825 6.8612442 -6.40191365 ) (-15.799041 -14.693779 -5.31100464 4.4784689 8.72727204 2.72727203 ) (-16.74641 -8.8516731 3.4162674 7.20574093 -23.770332 -4.5071764 ) (-25.215309 -3.89952135 -20.354064 2.69856453 20.354064 -2.69856453 )) NATURAL) (3 ((236 36) (211 36) (113 36)) NIL ((-6.75 0 0 0 -109.5 0 ) (-61.5 0 -109.5 0 109.5 0 )) NATURAL) (2 ((113 36) (113 168)) NIL ((0 132. 0 0 0 0 )) NATURAL) (2 ((113 168) (236 168)) NIL ((123. 0 0 0 0 0 )) NATURAL)) ((2 ((113 204) (113 302)) NIL ((0 98. 0 0 0 0 )) NATURAL) (2 ((113 302) (220 302)) NIL ((107. 0 0 0 0 0 )) NATURAL) (2 ((220 302) (245 302)) NIL ((25. 0 0 0 0 0 )) NATURAL) (5 ((245 302) (266 299) (291 291) (305 274) (308 253)) NIL ((19.339283 -2.23214292 0 0 9.9642849 -4.60714245 ) (24.321426 -4.53571415 9.9642849 -4.60714245 -25.821426 -6.96428586 ) (21.374996 -12.625 -15.857141 -11.571428 3.3214283 8.4642849 ) (7.17857075 -19.964283 -12.535713 -3.10714245 12.535713 3.10714245 )) NATURAL) (5 ((308 253) (303 231) (290 217) (266 208) (245 204)) NIL ((-3.6964283 -23.875 0 0 -7.82142926 11.25 ) (-7.60714245 -18.25 -7.82142926 11.25 -8.89285279 -8.25 ) (-19.875 -11.124998 -16.714283 3. 25.392852 3.74999905 ) (-23.892856 -6.24999905 8.6785698 6.74999905 -8.6785698 -6.74999905 )) NATURAL) (2 ((245 204) (220 204)) NIL ((-25. 0 0 0 0 0 )) NATURAL) (2 ((220 204) (113 204)) NIL ((-107. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 103Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 11:50:25) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((25 ((378 260) (370 287) (352 310) (318 332) (271 343) (229 345) (186 342) (141 330) (109 310) (85 285) (69 260) (60 236) (49 169) (60 102) (69 78) (85 53) (109 28) (141 8) (186 -4) (229 -7) (271 -5) (318 6) (352 28) (370 51) (378 78)) NIL ((-6.19386483 28.169479 0 0 -10.836809 -7.01689053 ) (-11.61227 24.661033 -10.836809 -7.01689053 -5.8159504 11.0844516 ) (-25.357055 23.18637 -16.652759 4.0675621 -1.89938736 -19.320919 ) (-42.95951 17.593471 -18.5521469 -15.2533588 31.413505 6.199234 ) (-45.8049 5.43973065 12.8613586 -9.05412484 -15.754644 6.5239849 ) (-40.82086 -0.352400899 -2.8932867 -2.53013944 -4.39492512 -8.29517556 ) (-45.911613 -7.03012753 -7.2882118 -10.825315 27.334346 2.65671539 ) (-39.532653 -16.527084 20.046134 -8.16860009 -14.942476 3.6683216 ) (-26.957756 -22.861526 5.10365868 -4.50027848 2.43556595 0.669996739 ) (-20.636314 -27.026805 7.5392246 -3.83028174 5.20021248 23.651683 ) (-10.4969825 -19.031242 12.739437 19.821403 -29.236415 -89.27673 ) (-12.375753 -43.848213 -16.496978 -69.455337 57.74546 69.45532 ) (3.18139791E-6 -78.57588 41.24848 -4.08857977E-6 -57.74546 69.45535 ) (12.375753 -43.848213 -16.496982 69.45535 29.236419 -89.27676 ) (10.4969825 -19.031242 12.739439 -19.821411 -5.20021439 23.651691 ) (20.636314 -27.026805 7.5392246 3.83028364 -2.43556785 0.669993878 ) (26.957756 -22.861522 5.10365677 4.50027752 14.942482 3.66832447 ) (39.532653 -16.527084 20.046138 8.168602 -27.33435 2.65670967 ) (45.911613 -7.03012658 -7.28821374 10.8253116 4.39492703 -8.29516984 ) (40.82086 -0.352400601 -2.89328623 2.5301404 15.754644 6.52398205 ) (45.8049 5.4397316 12.8613586 9.0541229 -31.413505 6.19923783 ) (42.959503 17.593471 -18.5521469 15.2533607 1.89938736 -19.320922 ) (25.357051 23.18637 -16.652759 -4.0675621 5.8159504 11.0844516 ) (11.612268 24.661033 -10.836809 7.01689053 10.836809 -7.01689053 )) NATURAL) (2 ((378 78) (326 78)) NIL ((-52. 0 0 0 0 0 )) NATURAL) (14 ((326 78) (320 55) (309 40) (286 28) (256 24) (230 23) (199 26) (177 32) (150 46) (132 64) (116 90) (106 120) (102 142) (101 169)) NIL ((-5.3555641 -25.071785 0 0 -3.86661339 12.4307289 ) (-7.2888708 -18.856422 -3.86661339 12.4307289 -10.666933 -14.153646 ) (-16.4889488 -13.5025177 -14.533546 -1.72291755 4.53435135 14.1838588 ) (-28.755321 -8.13350488 -9.9991951 12.460941 22.529521 -12.5817928 ) (-27.489753 -1.9634602 12.5303287 -0.120852127 -28.652446 6.14331818 ) (-29.285652 0.987347246 -16.1221199 6.02246667 38.080276 -5.99148369 ) (-26.36763 4.01407147 21.95816 0.0309827476 -39.668693 11.822618 ) (-24.243816 9.95636369 -17.710533 11.853601 36.594505 -11.298988 ) (-23.657093 16.160469 18.883976 0.554612279 -22.709346 9.37333489 ) (-16.127792 21.401752 -3.82537174 9.927948 12.2428798 -2.19436264 ) (-13.831724 30.232517 8.41750909 7.73358536 -2.26217842 -24.595874 ) (-6.5453043 25.668167 6.15533066 -16.862289 -3.1941638 28.577858 ) (-1.98705554 23.094806 2.96116686 11.71557 -2.96116686 -11.71557 )) NATURAL) (14 ((101 169) (102 196) (106 218) (116 248) (132 274) (150 292) (177 306) (199 312) (230 315) (256 314) (286 310) (309 298) (321 284) (326 260)) NIL ((0.506471396 28.95259 0 0 2.96117163 -11.7155666 ) (1.98705721 23.09481 2.96117163 -11.7155666 3.19414091 28.577835 ) (6.54529954 25.668159 6.15531254 16.86227 2.2622652 -24.595783 ) (13.831745 30.232536 8.41757775 -7.73351479 -12.243206 -2.1946907 ) (16.1277199 21.401676 -3.82562828 -9.9282055 22.710559 9.37454988 ) (23.657371 16.160743 18.884933 -0.553655625 -36.599037 -11.303514 ) (24.242786 9.9553318 -17.714103 -11.85717 39.685585 11.8395099 ) (26.371479 4.01791764 21.971485 -0.0176593437 -38.143325 -6.0545311 ) (29.271297 0.972992898 -16.171844 -6.07219124 28.887744 6.37861539 ) (27.543323 -1.90989017 12.7159 0.306424796 -23.407657 -13.45993 ) (28.555393 -8.33343125 -10.691759 -13.153507 -1.25710296 17.461109 ) (17.235084 -12.7563839 -11.948862 4.30760193 4.43607807 -20.384502 ) (7.504261 -18.641033 -7.512784 -16.0769 7.512784 16.0769 )) NATURAL) (2 ((326 260) (378 260)) NIL ((52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 105Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:00:54) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((82 337) (82 337) (82 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((82 0) (369 0)) NIL ((287. 0 0 0 0 0 )) NATURAL) (2 ((369 0) (369 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((369 36) (134 36)) NIL ((-235. 0 0 0 0 0 )) NATURAL) (2 ((134 36) (134 161)) NIL ((0 125. 0 0 0 0 )) NATURAL) (2 ((134 161) (315 161)) NIL ((181. 0 0 0 0 0 )) NATURAL) (2 ((315 161) (315 197)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((315 197) (134 197)) NIL ((-181. 0 0 0 0 0 )) NATURAL) (2 ((134 197) (134 301)) NIL ((0 104. 0 0 0 0 )) NATURAL) (2 ((134 301) (355 301)) NIL ((221. 0 0 0 0 0 )) NATURAL) (2 ((355 301) (355 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((355 337) (82 337)) NIL ((-273. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 106Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:01:55) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((328 197) (328 161)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((328 161) (147 161)) NIL ((-181. 0 0 0 0 0 )) NATURAL) (2 ((147 161) (147 0)) NIL ((0 -161. 0 0 0 0 )) NATURAL) (2 ((147 0) (96 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (3 ((96 0) (96 337) (96 337)) NIL ((0 421.25 0 0 0 -505.5 ) (0 168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((96 337) (369 337)) NIL ((273. 0 0 0 0 0 )) NATURAL) (2 ((369 337) (369 301)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((369 301) (147 301)) NIL ((-222. 0 0 0 0 0 )) NATURAL) (2 ((147 301) (147 197)) NIL ((0 -104. 0 0 0 0 )) NATURAL) (2 ((147 197) (328 197)) NIL ((181. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 107Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:14:10) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((354 0) (388 0)) NIL ((34. 0 0 0 0 0 )) NATURAL) (2 ((388 0) (388 169)) NIL ((0 169. 0 0 0 0 )) NATURAL) (2 ((388 169) (208 169)) NIL ((-180. 0 0 0 0 0 )) NATURAL) (2 ((208 169) (208 134)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((208 134) (336 134)) NIL ((128. 0 0 0 0 0 )) NATURAL) (8 ((336 134) (336 109) (330 76) (314 51) (285 33) (249 24) (224 22) (199 26)) NIL ((1.08862924 -22.377876 0 0 -6.53177548 -15.732736 ) (-2.17725849 -30.244243 -6.53177548 -15.732736 -3.34112072 30.663684 ) (-10.3795948 -30.645137 -9.8728962 14.93095 -4.1037426 -10.922018 ) (-22.304363 -21.175193 -13.9766388 4.00893116 1.75609588 7.0243902 ) (-35.402954 -13.6540699 -12.2205429 11.033321 33.079353 -5.17554093 ) (-31.083816 -5.20851898 20.85881 5.85778046 -26.073513 1.67777347 ) (-23.261764 1.48814869 -5.2147026 7.53555394 5.2147026 -7.53555394 )) NATURAL) (23 ((199 26) (177 32) (150 46) (131 63) (114 88) (104 118) (100 141) (99 169) (101 196) (104 218) (114 250) (129 277) (148 294) (173 306) (199 312) (230 315) (259 314) (289 309) (309 299) (320 286) (325 270) (325 270) (326 260)) NIL ((-20.09576 3.9550767 0 0 -11.425428 12.2695389 ) (-25.808475 10.0898456 -11.425428 12.2695389 27.127147 -13.347694 ) (-23.67033 15.685537 15.701719 -1.07815694 -19.083168 11.121244 ) (-17.5101928 20.168003 -3.38144875 10.0430889 13.205524 -1.13729667 ) (-14.288881 29.642444 9.8240757 8.90579225 -3.73893929 -24.572052 ) (-6.3342743 26.26221 6.0851364 -15.666261 -4.24976254 27.425514 ) (-2.37401914 24.308708 1.83537364 11.759254 2.73799419 -13.130014 ) (0.830351830 29.502952 4.57336807 -1.37075996 -6.7022152 -10.9054546 ) (2.0526123 22.679466 -2.12884712 -12.2762146 12.070867 32.75183 ) (5.959198 26.77917 9.9420204 20.475616 -5.58125305 -30.101875 ) (13.1105919 32.203842 4.36076737 -9.62625886 -1.74585771 -2.3443203 ) (16.59843 21.405426 2.61490965 -11.970579 6.564682 9.4791603 ) (22.495681 14.1744289 9.17959214 -2.49141884 -12.5128708 -5.57232285 ) (25.418838 8.89684678 -3.3332796 -8.06374169 13.4868049 6.81013394 ) (28.82896 4.23817349 10.153526 -1.25360703 -17.4343529 -3.668221 ) (30.265308 1.15045547 -7.2808275 -4.92182827 14.250612 1.86275148 ) (30.109787 -2.83999729 6.9697857 -3.05907679 -21.5681 -3.78278589 ) (26.295524 -7.7904663 -14.598314 -6.84186268 6.02178765 7.26839066 ) (14.708103 -10.9981346 -8.57652665 0.426528394 3.48095322 -13.290775 ) (7.8720541 -17.216991 -5.09557343 -12.864248 -1.94560623 45.894706 ) (1.80367732 -7.13388539 -7.04117966 33.030464 10.3014736 -56.288078 ) (-0.0867649615 -2.24746179 3.26029491 -23.257614 -3.26029491 23.257614 )) NATURAL) (2 ((326 260) (378 260)) NIL ((52. 0 0 0 0 0 )) NATURAL) (25 ((378 260) (370 287) (352 310) (318 332) (271 343) (229 345) (186 342) (144 331) (109 310) (85 285) (69 260) (60 236) (53 209) (49 169) (52 127) (64 83) (83 52) (108 28) (141 9) (183 -3) (229 -7) (271 -1) (300 9) (326 26) (344 49)) NIL ((-6.1920843 28.170055 0 0 -10.84749 -7.02033616 ) (-11.615829 24.659885 -10.84749 -7.02033616 -5.76254845 11.1016826 ) (-25.344593 23.190391 -16.610038 4.08134747 -2.10231399 -19.386398 ) (-43.00579 17.578537 -18.712352 -15.305053 32.171806 6.44392205 ) (-45.632232 5.4954462 13.459455 -8.86113168 -18.584922 5.6107149 ) (-41.46524 -0.560327769 -5.12547016 -3.25041676 6.16789437 -4.88678265 ) (-43.506767 -6.25413609 1.0424242 -8.1371994 5.9133482 -4.06358147 ) (-39.507667 -16.423126 6.9557724 -12.2007808 6.17871476 9.14110566 ) (-29.462539 -24.053352 13.134487 -3.05967522 -6.62821198 3.49915838 ) (-19.642158 -25.363449 6.50627518 0.439483404 2.33413124 0.862258196 ) (-11.9688167 -24.492836 8.8404064 1.3017416 -8.708313 -0.948191763 ) (-7.48256779 -23.665191 0.132091939 0.353549778 2.49913216 -21.069484 ) (-6.10090924 -33.846382 2.63122415 -20.715938 4.71178627 25.226146 ) (-1.11379099 -41.949249 7.3430109 4.51021099 2.65371418 -13.835115 ) (7.556077 -44.356597 9.99672509 -9.3249054 -3.32663918 30.114315 ) (15.889482 -38.624343 6.6700859 20.789409 -1.34715652 -16.622142 ) (21.88599 -26.146007 5.32292938 4.16726685 2.71526527 0.374253273 ) (28.56655 -21.791614 8.03819467 4.54152012 2.48609352 3.12512875 ) (37.847793 -15.687528 10.524288 7.66664887 -6.6596422 -0.874764443 ) (45.042259 -8.4582615 3.86464596 6.7918844 -5.84751797 6.3739252 ) (45.983146 1.52058458 -1.98287248 13.165809 -17.950279 -12.620937 ) (35.02513 8.37592507 -19.933155 0.544872284 23.648662 8.10982705 ) (26.916309 12.9757118 3.71550894 8.6546993 -16.644382 -1.81837463 ) (22.309623 20.721221 -12.9288768 6.8363247 12.9288768 -6.8363247 )) NATURAL) (2 ((344 49) (354 0)) NIL ((10. -49. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 110Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:14:57) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((61 0) (61 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((61 337) (113 337)) NIL ((52. 0 0 0 0 0 )) NATURAL) (2 ((113 337) (113 197)) NIL ((0 -140. 0 0 0 0 )) NATURAL) (2 ((113 197) (326 197)) NIL ((213. 0 0 0 0 0 )) NATURAL) (2 ((326 197) (326 337)) NIL ((0 140. 0 0 0 0 )) NATURAL) (2 ((326 337) (378 337)) NIL ((52. 0 0 0 0 0 )) NATURAL) (2 ((378 337) (378 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((378 0) (326 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL) (2 ((326 0) (326 161)) NIL ((0 161. 0 0 0 0 )) NATURAL) (2 ((326 161) (113 161)) NIL ((-213. 0 0 0 0 0 )) NATURAL) (2 ((113 161) (113 0)) NIL ((0 -161. 0 0 0 0 )) NATURAL) (2 ((113 0) (61 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 111Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:21:10) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((194 35) (94 35)) NIL ((-100. 0 0 0 0 0 )) NATURAL) (2 ((94 35) (94 0)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((94 0) (346 0)) NIL ((252. 0 0 0 0 0 )) NATURAL) (2 ((346 0) (346 35)) NIL ((0 35. 0 0 0 0 )) NATURAL) (2 ((346 35) (245 35)) NIL ((-101. 0 0 0 0 0 )) NATURAL) (2 ((245 35) (245 302)) NIL ((0 267. 0 0 0 0 )) NATURAL) (2 ((245 302) (346 302)) NIL ((101. 0 0 0 0 0 )) NATURAL) (2 ((346 302) (346 337)) NIL ((0 35. 0 0 0 0 )) NATURAL) (2 ((346 337) (94 337)) NIL ((-252. 0 0 0 0 0 )) NATURAL) (2 ((94 337) (94 302)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((94 302) (194 302)) NIL ((100. 0 0 0 0 0 )) NATURAL) (2 ((194 302) (194 35)) NIL ((0 -267. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 112Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:24:11) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((13 ((367 83) (358 56) (342 35) (318 18) (286 5) (249 -4) (213 -7) (177 -4) (139 5) (108 18) (84 35) (67 56) (58 83)) NIL ((-7.5716381 -28.383419 0 0 -8.57017137 8.30051805 ) (-11.8567238 -24.233158 -8.57017137 8.30051805 0.850863457 -5.50259018 ) (-20.001464 -18.683937 -7.7193079 2.79792738 -0.833287240 1.70984411 ) (-28.137416 -15.0310878 -8.55259515 4.50777149 2.48228836 -1.33678722 ) (-35.448867 -11.191709 -6.07030678 3.17098427 8.90413095 3.63730621 ) (-37.067108 -6.20207215 2.83382416 6.80829049 -2.09881306 -1.21243572 ) (-35.282692 0 0.735010863 5.59585476 -6.50887776 1.21243572 ) (-37.802116 6.20207215 -5.7738676 6.80829049 16.1343269 -3.63730621 ) (-35.508819 11.191709 10.360462 3.17098427 -4.02844429 1.33678722 ) (-27.162582 15.0310878 6.3320179 4.50777149 -0.0205554962 -1.70984459 ) (-20.840839 18.683937 6.3114624 2.7979269 4.11067009 5.50259114 ) (-12.4740429 24.233158 10.422132 8.30051805 -10.422132 -8.30051805 )) NATURAL) (2 ((58 83) (58 125)) NIL ((0 42. 0 0 0 0 )) NATURAL) (2 ((58 125) (108 125)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((108 125) (108 83)) NIL ((0 -42. 0 0 0 0 )) NATURAL) (11 ((108 83) (117 61) (134 46) (156 37) (185 31) (214 29) (241 31) (269 37) (291 46) (308 61) (317 83)) NIL ((7.0843725 -23.486187 0 0 11.493761 8.9171257 ) (12.831253 -19.027622 11.493761 8.9171257 -9.4688053 -2.58563423 ) (19.59061 -11.4033146 2.02495432 6.33149148 8.381464 -4.5745859 ) (25.806297 -7.3591156 10.4064197 1.75690555 -12.057056 2.88397884 ) (30.184188 -4.1602211 -1.65063834 4.6408844 -2.15322876 -0.961326600 ) (27.456935 1.59256160E-7 -3.80386734 3.6795578 8.66997529 0.961325646 ) (27.988056 4.1602211 4.86610794 4.64088345 -14.526672 -2.88397694 ) (25.590827 7.3591156 -9.6605644 1.75690627 7.43671513 4.574584 ) (19.64862 11.4033146 -2.22384882 6.3314905 -9.22018624 2.58563518 ) (12.814678 19.027622 -11.444036 8.9171257 11.444036 -8.9171257 )) NATURAL) (2 ((317 83) (317 301)) NIL ((0 218. 0 0 0 0 )) NATURAL) (2 ((317 301) (187 301)) NIL ((-130. 0 0 0 0 0 )) NATURAL) (2 ((187 301) (187 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((187 337) (367 337)) NIL ((180. 0 0 0 0 0 )) NATURAL) (2 ((367 337) (367 83)) NIL ((0 -254. 0 0 0 0 )) NATURAL)))) ((FAMILY GACHA) (CHARACTER 113Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:28:21) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((73 0) (73 0) (73 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((73 337) (120 337)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((120 337) (120 191)) NIL ((0 -146. 0 0 0 0 )) NATURAL) (2 ((120 191) (175 191)) NIL ((55. 0 0 0 0 0 )) NATURAL) (2 ((175 191) (320 338)) NIL ((145. 147. 0 0 0 0 )) NATURAL) (2 ((320 338) (373 338)) NIL ((53. 0 0 0 0 0 )) NATURAL) (2 ((373 338) (214 176)) NIL ((-159. -162. 0 0 0 0 )) NATURAL) (2 ((214 176) (418 0)) NIL ((204. -176. 0 0 0 0 )) NATURAL) (2 ((418 0) (347 0)) NIL ((-71. 0 0 0 0 0 )) NATURAL) (2 ((347 0) (170 155)) NIL ((-177. 155. 0 0 0 0 )) NATURAL) (2 ((170 155) (120 155)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((120 155) (120 0)) NIL ((0 -155. 0 0 0 0 )) NATURAL) (2 ((120 0) (73 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)))) ((FAMILY GACHA) (CHARACTER 114Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:29:42) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((82 337) (82 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((82 0) (390 0)) NIL ((308. 0 0 0 0 0 )) NATURAL) (2 ((390 0) (390 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((390 36) (134 36)) NIL ((-256. 0 0 0 0 0 )) NATURAL) (2 ((134 36) (134 337)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((134 337) (82 337)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY GACHA) (CHARACTER 115Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:34:46) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((40 0) (40 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((40 337) (102 337)) NIL ((62. 0 0 0 0 0 )) NATURAL) (2 ((102 337) (219 80)) NIL ((117. -257. 0 0 0 0 )) NATURAL) (2 ((219 80) (335 337)) NIL ((116. 257. 0 0 0 0 )) NATURAL) (2 ((335 337) (397 337)) NIL ((62. 0 0 0 0 0 )) NATURAL) (2 ((397 337) (397 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((397 0) (346 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((346 0) (346 260)) NIL ((0 260. 0 0 0 0 )) NATURAL) (2 ((346 260) (219 -8)) NIL ((-127. -268. 0 0 0 0 )) NATURAL) (2 ((219 -8) (92 260)) NIL ((-127. 268. 0 0 0 0 )) NATURAL) (2 ((92 260) (92 0)) NIL ((0 -260. 0 0 0 0 )) NATURAL) (2 ((92 0) (40 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 104Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 13:35:12) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((51 0) (51 0) (51 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((51 337) (231 337)) NIL ((180. 0 0 0 0 0 )) NATURAL) (13 ((231 337) (280 330) (322 313) (352 291) (373 264) (388 220) (393 169) (388 118) (373 74) (352 47) (322 25) (280 8) (231 0)) NIL ((50.16728 -4.66153813 0 0 -7.0037012 -14.030771 ) (46.665428 -11.6769237 -7.0037012 -14.030771 -6.98149396 10.153858 ) (36.170982 -20.630764 -13.985195 -3.87691164 4.92968178 3.4153304 ) (24.650627 -22.80001 -9.05551339 -0.461581111 5.26276684 -23.815181 ) (18.226497 -35.169181 -3.79274607 -24.276763 -7.9807539 19.845397 ) (10.4433746 -49.523246 -11.7735 -4.4313631 2.66025162 4.43358326 ) (-3.18512320E-7 -51.737815 -9.1132488 0.00222035451 -2.66025162 4.42026043 ) (-10.4433746 -49.525467 -11.7735 4.42248154 7.98075486 19.885368 ) (-18.226497 -35.1603 -3.79274559 24.307849 -5.26276779 -23.961738 ) (-24.650627 -22.83332 -9.05551339 0.346110821 -4.92968178 3.96159315 ) (-36.170982 -20.506412 -13.985195 4.30770397 6.9814949 8.1153679 ) (-46.665428 -12.1410236 -7.00370026 12.4230728 7.00370026 -12.4230728 )) NATURAL) (2 ((231 0) (51 0)) NIL ((-180. 0 0 0 0 0 )) NATURAL)) ((2 ((101 301) (225 301)) NIL ((124. 0 0 0 0 0 )) NATURAL) (15 ((225 301) (250 300) (278 295) (298 286) (314 273) (331 245) (340 208) (343 169) (340 130) (331 93) (314 65) (298 52) (278 43) (250 38) (225 37)) NIL ((23.713207 -0.204053551 0 0 7.72074509 -4.77567864 ) (27.573581 -2.59189272 7.72074509 -4.77567864 -20.603725 -0.121606826 ) (24.992462 -7.42837525 -12.882982 -4.89728546 8.6941681 5.2621088 ) (16.456562 -9.69460679 -4.18881417 0.364823341 9.82705308 -20.926826 ) (17.181274 -19.793197 5.6382389 -20.562004 -18.00238 12.4452057 ) (13.818325 -34.132598 -12.364141 -8.1167984 8.1824684 7.145998 ) (5.54541779 -38.676399 -4.18167305 -0.970800281 -2.72749042 0.970800281 ) (1.58324837E-7 -39.161796 -6.90916348 3.19420294E-8 2.72748947 0.970800043 ) (-5.54541779 -38.676399 -4.181674 0.970800162 -8.1824665 7.145998 ) (-13.818325 -34.132598 -12.364141 8.1167984 18.002376 12.4452057 ) (-17.181274 -19.793193 5.63823796 20.562004 -9.82705117 -20.926826 ) (-16.456562 -9.69460488 -4.1888132 -0.364823401 -8.6941681 5.2621088 ) (-24.992462 -7.4283743 -12.882982 4.89728546 20.603725 -0.121606826 ) (-27.573581 -2.59189272 7.72074509 4.77567864 -7.72074509 -4.77567864 )) NATURAL) (2 ((225 37) (101 36)) NIL ((-124. -1. 0 0 0 0 )) NATURAL) (2 ((101 36) (101 301)) NIL ((0 265. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GACHAE.UC2-SF b/lispusers/GACHAE.UC2-SF new file mode 100644 index 00000000..56a9f2bd --- /dev/null +++ b/lispusers/GACHAE.UC2-SF @@ -0,0 +1 @@ + ((FAMILY GACHA) (CHARACTER 116Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:42:48) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((61 0) (61 0) (111 0)) NIL ((-12.5 0 0 0 75. 0 ) (25. 0 75. 0 -75. 0 )) NATURAL) (2 ((111 0) (111 295)) NIL ((0 295. 0 0 0 0 )) NATURAL) (2 ((111 295) (312 0)) NIL ((201. -295. 0 0 0 0 )) NATURAL) (2 ((312 0) (376 0)) NIL ((64. 0 0 0 0 0 )) NATURAL) (2 ((376 0) (376 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((376 337) (326 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((326 337) (326 42)) NIL ((0 -295. 0 0 0 0 )) NATURAL) (2 ((326 42) (125 337)) NIL ((-201. 295. 0 0 0 0 )) NATURAL) (2 ((125 337) (61 337)) NIL ((-64. 0 0 0 0 0 )) NATURAL) (2 ((61 337) (61 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 117Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:52:08) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((29 ((222 22) (257 25) (286 34) (316 51) (334 75) (346 105) (351 140) (353 169) (351 198) (346 233) (334 263) (316 287) (286 304) (255 313) (222 316) (189 313) (158 304) (128 287) (110 263) (98 233) (93 198) (91 169) (93 140) (98 105) (110 75) (128 51) (158 34) (187 25) (222 22)) NIL ((36.888336 1.854002 0 0 -11.3300247 6.875988 ) (31.223323 5.291996 -11.3300247 6.875988 20.650123 1.62005996 ) (30.21836 12.978014 9.32010079 8.49604798 -29.270477 -1.35623073 ) (24.90322 20.795944 -19.950378 7.13981724 18.431793 -2.19513702 ) (14.168741 26.838195 -1.51858186 4.9446802 -8.456707 4.13677883 ) (8.42180444 33.851265 -9.9752903 9.08145906 9.3950348 -20.351982 ) (3.14403296 32.756729 -0.580255032 -11.270523 -5.1234331 11.271158 ) (0.00206090975 27.121788 -5.70368862 6.36285287E-4 5.09869957 11.2673397 ) (-3.15227747 32.756095 -0.604988218 11.2679767 -9.2713661 -20.340518 ) (-8.39294816 33.853813 -9.8763561 -9.0725422 7.98676587 4.09474373 ) (-14.2759208 26.82864 -1.88958955 -4.97779846 -16.675693 -2.03846168 ) (-24.50336 20.831611 -18.565284 -7.01626015 22.716026 -1.94089889 ) (-31.710632 12.844902 4.15074253 -8.95715905 -8.18842698 3.80206299 ) (-31.654102 5.78877354 -4.0376854 -5.15509606 4.0376854 -1.26735592 ) (-33.672943 1.58324837E-7 0 -6.42245198 4.0376854 1.26735496 ) (-31.654102 -5.78877449 4.0376854 -5.155097 -8.18842698 -3.80206204 ) (-31.710632 -12.844902 -4.15074253 -8.95715905 22.716026 1.94089889 ) (-24.503356 -20.831611 18.565284 -7.01626015 -16.675693 2.03846168 ) (-14.2759208 -26.82864 1.88958955 -4.97779846 7.98676396 -4.09474564 ) (-8.39294816 -33.853813 9.8763542 -9.0725441 -9.2713642 20.340518 ) (-3.15227747 -32.756095 0.604989052 11.2679767 5.09869957 -11.2673397 ) (0.00206130743 -27.121788 5.70368862 6.36285287E-4 -5.1234331 -11.271158 ) (3.14403296 -32.756729 0.580254913 -11.270523 9.3950348 20.351982 ) (8.42180444 -33.851265 9.9752903 9.08146096 -8.456707 -4.13678074 ) (14.168741 -26.838195 1.51858258 4.9446802 18.431793 2.19513607 ) (24.90322 -20.795944 19.950378 7.13981629 -29.270477 1.35623169 ) (30.21836 -12.978012 -9.32010079 8.49604798 20.650123 -1.62006092 ) (31.223323 -5.29199505 11.3300247 6.87598706 -11.3300247 -6.87598706 )) NATURAL)) ((29 ((42 169) (47 117) (61 78) (80 48) (102 28) (133 10) (180 -3) (222 -7) (264 -3) (311 10) (342 28) (364 48) (383 78) (397 117) (402 169) (397 221) (383 260) (364 290) (342 310) (311 328) (264 341) (222 345) (180 341) (133 328) (102 310) (80 290) (61 260) (47 221) (42 169)) NIL ((0.0957953036 -55.136116 9.7570095 0.390455067 0.154199600 17.645336 ) (9.92990495 -45.922988 9.9112091 18.035793 -5.3130598 -12.5694408 ) (17.184581 -34.171913 4.5981493 5.46635247 -2.90195894 8.63244058 ) (20.331752 -24.389339 1.69619012 14.098793 4.92089939 -15.960325 ) (24.488395 -18.27071 6.61709023 -1.86153316 19.218349 7.20887089 ) (40.71466 -16.527809 25.835441 5.34733773 -39.794303 5.12484169 ) (46.652946 -8.6180496 -13.958868 10.472179 13.9589 -3.70823574 ) (39.67353 1.14440918E-5 3.27086381E-5 6.76394368 13.958702 3.70810032 ) (46.652915 8.61800576 13.958736 10.472044 -39.793716 -5.12416935 ) (40.71479 16.527965 -25.834983 5.34787464 19.216178 -7.21142007 ) (24.487899 18.27013 -6.61880208 -1.86354613 4.92899609 15.969852 ) (20.333595 24.39151 -1.68980574 14.106308 -2.93216896 -8.66798974 ) (17.1777038 34.163818 -4.62197495 5.4383173 -5.20031739 12.7020969 ) (9.9555721 45.953193 -9.8222923 18.140415 -0.266559601 -18.140411 ) (-6.37024641E-7 55.023399 -10.0888519 1.02214494E-6 0.266559601 -18.140419 ) (-9.9555721 45.953186 -9.8222923 -18.140419 5.20031739 12.7021007 ) (-17.1777038 34.163818 -4.62197495 -5.4383173 2.93216944 -8.6679878 ) (-20.333595 24.39151 -1.68980551 -14.106306 -4.92899609 15.96985 ) (-24.487899 18.27013 -6.61880208 1.86354565 -19.216178 -7.21142007 ) (-40.71479 16.527965 -25.834983 -5.34787464 39.793716 -5.12416935 ) (-46.652915 8.61800386 13.958738 -10.472044 -13.958704 3.70809937 ) (-39.67353 1.11255794E-5 3.27086381E-5 -6.76394463 -13.9589 -3.70823288 ) (-46.652946 -8.6180496 -13.958868 -10.472177 39.794303 5.12483883 ) (-40.71466 -16.527809 25.835441 -5.34733868 -19.218349 7.20887185 ) (-24.488391 -18.27071 6.61709119 1.86153364 -4.9209013 -15.960327 ) (-20.331752 -24.389339 1.6961894 -14.0987949 2.90196085 8.63244248 ) (-17.184581 -34.171913 4.59815026 -5.4663515 5.31305886 -12.5694408 ) (-9.929903 -45.922988 9.9112091 -18.035793 -0.154199600 17.645336 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 120Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:02:12) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((81 0) (81 0) (81 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((81 337) (261 337)) NIL ((180. 0 0 0 0 0 )) NATURAL) (13 ((261 337) (287 336) (318 331) (346 318) (363 300) (375 272) (381 236) (375 200) (363 172) (346 154) (318 141) (287 136) (261 135)) NIL ((24.635082 -0.447435856 0 0 8.18948937 -3.31538487 ) (28.729827 -2.10512829 8.18948937 -3.31538487 -10.9474468 -7.42307568 ) (31.445594 -9.13205148 -2.75795746 -10.7384605 -12.399702 9.0076904 ) (22.487785 -15.3666668 -15.157659 -1.73076916 12.5462589 -10.6076908 ) (13.603256 -22.401279 -2.61139917 -12.3384609 -1.78534364 3.42307854 ) (10.099184 -33.028198 -4.39674282 -8.9153824 -11.404884 8.91538049 ) (-1.60187482E-7 -37.485893 -15.801628 -5.11072471E-7 11.404884 8.9153843 ) (-10.099184 -33.028198 -4.39674282 8.9153843 1.78534364 3.42307472 ) (-13.603256 -22.401279 -2.61139917 12.338459 -12.5462589 -10.6076889 ) (-22.487785 -15.3666649 -15.157659 1.73077011 12.399702 9.0076885 ) (-31.445594 -9.13204957 -2.7579565 10.7384586 10.947443 -7.42307377 ) (-28.729827 -2.10512829 8.18948747 3.31538487 -8.18948747 -3.31538487 )) NATURAL) (2 ((261 135) (134 135)) NIL ((-127. 0 0 0 0 0 )) NATURAL) (2 ((134 135) (134 0)) NIL ((0 -135. 0 0 0 0 )) NATURAL) (2 ((134 0) (81 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL)) ((9 ((261 301) (283 299) (306 293) (323 270) (329 238) (323 206) (306 183) (283 177) (261 175)) NIL ((21.463916 -1.98214268 0 0 3.21649456 -0.107143402 ) (23.072162 -2.03571415 3.21649456 -0.107143402 -10.0824737 -23.464283 ) (21.247421 -13.875 -6.8659792 -23.571426 -4.88659764 15.964283 ) (11.9381427 -29.464283 -11.7525768 -7.60714245 -0.371133804 7.60714245 ) (-3.18512320E-7 -33.267852 -12.1237106 2.55529982E-7 0.371133804 7.60714055 ) (-11.9381446 -29.464283 -11.7525768 7.6071415 4.88659859 15.9642849 ) (-21.247421 -13.874998 -6.86597825 23.571426 10.0824718 -23.464283 ) (-23.072162 -2.03571415 3.21649504 0.107142448 -3.21649504 -0.107142448 )) NATURAL) (2 ((261 175) (134 175)) NIL ((-127. 0 0 0 0 0 )) NATURAL) (2 ((134 175) (134 301)) NIL ((0 126. 0 0 0 0 )) NATURAL) (2 ((134 301) (261 301)) NIL ((127. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 121Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:08:33) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((29 ((222 22) (187 25) (158 34) (128 51) (110 75) (98 105) (93 140) (91 169) (93 198) (98 233) (110 263) (128 287) (158 304) (189 313) (222 316) (255 313) (286 304) (316 287) (334 263) (346 233) (351 198) (353 169) (351 140) (346 105) (334 75) (316 51) (286 34) (257 25) (222 22)) NIL ((-36.888336 1.854002 0 0 11.3300247 6.875988 ) (-31.223323 5.291996 11.3300247 6.875988 -20.650123 1.62005996 ) (-30.21836 12.978014 -9.32010079 8.49604798 29.270477 -1.35623073 ) (-24.90322 20.795944 19.950378 7.13981724 -18.431793 -2.19513702 ) (-14.168741 26.838195 1.51858186 4.9446802 8.456707 4.13677883 ) (-8.42180444 33.851265 9.9752903 9.08145906 -9.3950348 -20.351982 ) (-3.14403296 32.756729 0.580255032 -11.270523 5.1234331 11.271158 ) (-0.00206090975 27.121788 5.70368862 6.36285287E-4 -5.09869957 11.2673397 ) (3.15227747 32.756095 0.604988218 11.2679767 9.2713661 -20.340518 ) (8.39294816 33.853813 9.8763561 -9.0725422 -7.98676587 4.09474373 ) (14.2759208 26.82864 1.88958955 -4.97779846 16.675693 -2.03846168 ) (24.50336 20.831611 18.565284 -7.01626015 -22.716026 -1.94089889 ) (31.710632 12.844902 -4.15074253 -8.95715905 8.18842698 3.80206299 ) (31.654102 5.78877354 4.0376854 -5.15509606 -4.0376854 -1.26735592 ) (33.672943 1.58324837E-7 0 -6.42245198 -4.0376854 1.26735496 ) (31.654102 -5.78877449 -4.0376854 -5.155097 8.18842698 -3.80206204 ) (31.710632 -12.844902 4.15074253 -8.95715905 -22.716026 1.94089889 ) (24.503356 -20.831611 -18.565284 -7.01626015 16.675693 2.03846168 ) (14.2759208 -26.82864 -1.88958955 -4.97779846 -7.98676396 -4.09474564 ) (8.39294816 -33.853813 -9.8763542 -9.0725441 9.2713642 20.340518 ) (3.15227747 -32.756095 -0.604989052 11.2679767 -5.09869957 -11.2673397 ) (-0.00206130743 -27.121788 -5.70368862 6.36285287E-4 5.1234331 -11.271158 ) (-3.14403296 -32.756729 -0.580254913 -11.270523 -9.3950348 20.351982 ) (-8.42180444 -33.851265 -9.9752903 9.08146096 8.456707 -4.13678074 ) (-14.168741 -26.838195 -1.51858258 4.9446802 -18.431793 2.19513607 ) (-24.90322 -20.795944 -19.950378 7.13981629 29.270477 1.35623169 ) (-30.21836 -12.978012 9.32010079 8.49604798 -20.650123 -1.62006092 ) (-31.223323 -5.29199505 -11.3300247 6.87598706 11.3300247 -6.87598706 )) NATURAL)) ((2 ((264 -3) (256 -5)) NIL ((-8. -2. 0 0 0 0 )) NATURAL) (5 ((256 -5) (255 -17) (261 -29) (273 -34) (285 -34)) NIL ((-2.4464283 -11.5892849 0 0 8.6785698 -2.46428537 ) (1.89285755 -12.821428 8.6785698 -2.46428537 -1.39285564 12.321426 ) (9.875 -9.1249981 7.28571416 9.8571415 -9.1071415 -4.82142735 ) (12.607141 -1.67857122 -1.8214283 5.03571415 1.8214283 -5.03571415 )) NATURAL) (2 ((285 -34) (367 -34)) NIL ((82. 0 0 0 0 0 )) NATURAL) (2 ((367 -34) (367 -69)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((367 -69) (262 -69)) NIL ((-105. 0 0 0 0 0 )) NATURAL) (6 ((262 -69) (243 -66) (225 -58) (213 -44) (208 -22) (208 -4)) NIL ((-18.947364 1.91866016 0 0 -0.315789461 6.48803807 ) (-19.105262 5.16267872 -0.315789461 6.48803807 7.57894707 -2.44019127 ) (-15.631578 10.430622 7.26315785 4.0478468 -9.53674316E-7 9.27272416 ) (-8.36841966 19.11483 7.2631569 13.3205719 -1.57894706 -22.650714 ) (-1.89473653 21.110046 5.68420983 -9.33014298 -5.68420983 9.33014298 )) NATURAL) (2 ((208 -4) (180 -3)) NIL ((-28. 1. 0 0 0 0 )) NATURAL) (27 ((180 -3) (133 10) (102 28) (80 48) (61 78) (47 117) (42 169) (47 221) (61 260) (80 290) (102 310) (133 328) (180 341) (222 345) (264 341) (311 328) (342 310) (364 290) (383 260) (397 221) (402 169) (397 117) (383 78) (364 48) (342 28) (311 10) (264 -3)) NIL ((-50.682457 11.6410236 0 0 22.094749 8.15385057 ) (-39.635078 15.7179489 22.094749 8.15385057 -14.4737549 -10.7692546 ) (-24.777206 18.487171 7.62099457 -2.61540413 -6.19972516 16.923168 ) (-20.256076 24.333354 1.4212687 14.3077659 3.27266073 -8.92342759 ) (-17.1984749 34.179405 4.69392967 5.38433743 5.10908127 12.7705459 ) (-9.95000649 45.949012 9.80301095 18.154884 0.291007995 -18.15876 ) (-0.00149090960 55.02452 10.0940189 -0.00387597363 -0.273111343 -18.135498 ) (9.95597268 45.952888 9.8209076 -18.139377 -5.19856167 12.7007808 ) (17.177597 34.163902 4.62234593 -5.43859673 -2.93264007 -8.66763497 ) (20.333625 24.391487 1.68970585 -14.1062317 4.92912293 15.969757 ) (24.487892 18.2701339 6.61882878 1.86352634 19.216144 -7.2113981 ) (40.714798 16.527961 25.834976 -5.34787178 -39.793716 -5.12416458 ) (46.652908 8.61800767 -13.958744 -10.472036 13.958744 3.7080555 ) (39.673538 -6.37024641E-7 0 -6.76398087 13.958744 -3.70805359 ) (46.652908 -8.61800958 13.958744 -10.472034 -39.793716 5.12416172 ) (40.71479 -16.527961 -25.834976 -5.34787274 19.216144 7.21139908 ) (24.487892 -18.2701339 -6.61882878 1.86352634 4.92912197 -15.969757 ) (20.333625 -24.391487 -1.68970608 -14.1062317 -2.93264055 8.66763497 ) (17.177597 -34.163902 -4.62234688 -5.43859577 -5.1985607 -12.7007808 ) (9.95597077 -45.952888 -9.8209076 -18.139377 -0.273111343 18.135498 ) (-0.00149186514 -55.02452 -10.0940189 -0.00387699622 0.291007995 18.15876 ) (-9.95000649 -45.949012 -9.80301095 18.154884 5.10908127 -12.7705478 ) (-17.198478 -34.179405 -4.69392967 5.38433647 3.2726612 8.9234295 ) (-20.256076 -24.33335 -1.42126846 14.3077659 -6.19972706 -16.923168 ) (-24.777206 -18.487171 -7.6209955 -2.6154046 -14.4737529 10.7692546 ) (-39.635078 -15.7179489 -22.094749 8.15385057 22.094749 -8.15385057 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 122Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:19:31) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((73 0) (73 0) (73 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((73 337) (244 337)) NIL ((171. 0 0 0 0 0 )) NATURAL) (7 ((244 337) (280 335) (316 328) (345 311) (362 286) (367 255) (367 242)) NIL ((35.673072 -1.27820491 0 0 1.96153855 -4.33076954 ) (36.653839 -3.44358969 1.96153855 -4.33076954 -9.80769158 -8.34615136 ) (33.711532 -11.947435 -7.8461542 -12.6769218 -4.73076725 7.71538354 ) (23.499996 -20.766666 -12.576921 -4.9615383 -1.26923179 -10.5153846 ) (10.2884597 -30.985897 -13.846153 -15.476923 9.80769158 46.346145 ) (1.34615373 -23.289741 -4.03846169 30.869228 4.03846169 -30.869228 )) NATURAL) (6 ((367 242) (367 229) (362 198) (345 173) (316 156) (292 151)) NIL ((0.732057333 -7.84210587 0 0 -4.39234448 -30.947364 ) (-1.46411466 -23.315788 -4.39234448 -30.947364 -8.03827668 46.73683 ) (-9.875597 -30.894733 -12.430622 15.789472 -5.45454407 -11.999998 ) (-25.033493 -21.105262 -17.885166 3.78947306 29.856456 13.2631569 ) (-27.990428 -10.6842098 11.9712906 17.052631 -11.9712906 -17.052631 )) NATURAL) (2 ((292 151) (360 0)) NIL ((68. -151. 0 0 0 0 )) NATURAL) (2 ((360 0) (305 0)) NIL ((-55. 0 0 0 0 0 )) NATURAL) (2 ((305 0) (239 147)) NIL ((-66. 147. 0 0 0 0 )) NATURAL) (2 ((239 147) (120 147)) NIL ((-119. 0 0 0 0 0 )) NATURAL) (2 ((120 147) (120 0)) NIL ((0 -147. 0 0 0 0 )) NATURAL) (2 ((120 0) (73 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)) ((2 ((120 183) (120 301)) NIL ((0 118. 0 0 0 0 )) NATURAL) (2 ((120 301) (226 301)) NIL ((106. 0 0 0 0 0 )) NATURAL) (6 ((226 301) (272 299) (293 292) (307 280) (313 265) (315 242)) NIL ((52.330139 -1. 0 0 -37.980857 -6. ) (33.339706 -4. -37.980857 -6. 39.904296 0 ) (15.311004 -10. 1.92344451 -6. -13.63636 6. ) (10.416267 -13. -11.712917 0 8.6411457 -12. ) (3.0239234 -19. -3.07177019 -12. 3.07177019 12. )) NATURAL) (6 ((315 242) (313 219) (307 204) (293 192) (272 185) (226 183)) NIL ((-1.48803806 -24.999996 0 0 -3.07177067 11.999998 ) (-3.0239234 -18.999996 -3.07177067 11.999998 -8.6411457 -11.999996 ) (-10.416267 -12.999998 -11.712917 2.54313135E-7 13.636358 5.9999981 ) (-15.311004 -9.9999981 1.92344212 5.99999905 -39.904289 9.53674316E-7 ) (-33.339714 -4. -37.98085 6. 37.98085 -6. )) NATURAL) (2 ((226 183) (120 183)) NIL ((-106. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 123Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:39:15) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((370 259) (328 259)) NIL ((-42. 0 0 0 0 0 )) NATURAL) (19 ((328 259) (319 283) (296 300) (270 309) (220 313) (178 311) (154 307) (129 297) (113 280) (109 264) (115 239) (145 218) (182 212) (218 209) (273 203) (318 191) (350 172) (371 140) (378 88)) NIL ((-4.98698998 25.367855 0 0 -24.07806 -8.2071476 ) (-17.02602 21.264282 -24.07806 -8.2071476 36.390304 -0.964258195 ) (-22.908927 12.575006 12.312244 -9.1714058 -55.48316 6.06417847 ) (-38.338264 6.43568993 -43.17092 -3.10722733 59.54238 -5.29245758 ) (-51.737999 0.682233811 16.371463 -8.3996849 9.31360246 9.10564996 ) (-30.709728 -3.16462517 25.685066 0.705966711 -36.796806 -7.13014699 ) (-23.423069 -6.02373219 -11.1117458 -6.42418099 23.873664 -4.58506012 ) (-22.597984 -14.740444 12.761919 -11.009241 1.30215072 19.470386 ) (-9.1849899 -16.014488 14.0640697 8.4611473 -11.0822677 -25.296493 ) (-0.662053824 -20.201587 2.9818015 -16.835346 31.026916 21.71558 ) (17.833206 -26.179142 34.00872 4.88023567 -29.025417 16.434162 ) (37.329216 -13.081827 4.98330307 21.314399 -16.925239 -21.452232 ) (33.849899 -2.4935441 -11.941936 -0.137833327 48.72637 -2.62523365 ) (46.271156 -3.943995 36.784439 -2.76306724 -57.98026 -4.04682827 ) (54.06546 -8.73047639 -21.195827 -6.8098955 9.19470979 0.812546731 ) (37.466987 -15.134098 -12.0011177 -5.99734879 3.20141602 -5.20335579 ) (27.066577 -23.733127 -8.7997017 -11.2007045 -10.00037 -15.9991169 ) (13.266689 -42.933387 -18.800071 -27.199821 18.800071 27.199821 )) NATURAL) (11 ((378 88) (369 49) (349 23) (314 4) (273 -6) (214 -9) (151 -5) (106 7) (73 25) (46 52) (36 84)) NIL ((-7.0958252 -42.124916 0 0 -11.425045 18.749504 ) (-12.8083477 -32.75016 -11.425045 18.749504 -8.87477494 -15.74752 ) (-28.67078 -21.87442 -20.299819 3.00198221 22.924152 8.2405815 ) (-37.508522 -14.752147 2.62433576 11.242565 -28.821849 -5.2148094 ) (-49.295112 -6.11698628 -26.197517 6.02775574 20.363262 0.618652344 ) (-65.311004 0.220096260 -5.8342533 6.64640809 31.368785 2.74019813 ) (-55.46086 8.2366047 25.534534 9.3866062 -13.838428 -5.57944775 ) (-36.845535 14.833486 11.6961059 3.80715847 -12.015068 7.5775995 ) (-31.156967 22.429443 -0.318962395 11.384758 25.898704 -6.7309475 ) (-18.52658 30.448726 25.579742 4.6538105 -25.579742 -4.6538105 )) NATURAL) (2 ((36 84) (88 84)) NIL ((52. 0 0 0 0 0 )) NATURAL) (4 ((88 84) (103 56) (127 40) (166 28)) NIL ((13.599998 -30.93333 0 0 8.3999996 17.599998 ) (17.799999 -22.133331 8.3999996 17.599998 11.999998 -15.999998 ) (32.199997 -12.5333328 20.399997 1.5999999 -20.399997 -1.5999999 )) NATURAL) (25 ((166 28) (208 23) (248 25) (287 31) (320 57) (330 99) (322 135) (292 152) (248 159) (193 165) (140 174) (103 188) (75 209) (60 237) (57 264) (69 299) (91 320) (124 334) (165 343) (216 345) (261 343) (300 335) (336 316) (360 289) (370 259)) NIL ((42.478797 -6.88853169 0 0 -2.87278843 11.331192 ) (41.042396 -1.22293496 -2.87278843 11.331192 2.36394262 -14.6559658 ) (39.351585 2.78027391 -0.508845687 -3.32477379 -0.582982898 29.292675 ) (38.551246 14.1018409 -1.09182858 25.967903 -30.032005 -6.51475526 ) (22.443412 36.812362 -31.123836 19.453147 18.711029 -27.23365 ) (0.675090075 42.648689 -12.412805 -7.7805023 -14.812124 -16.550632 ) (-19.1437759 26.592868 -27.224929 -24.331134 16.53746 15.43618 ) (-38.099975 9.97982408 -10.6874675 -8.89495469 -3.3377304 8.805912 ) (-50.456306 5.48782635 -14.025198 -0.0890419930 14.813459 3.34016419 ) (-57.074775 7.06886674 0.788262964 3.25112248 22.083881 1.83342743 ) (-45.244567 11.2367038 22.872146 5.0845499 -19.14899 1.3261261 ) (-31.946922 16.984317 3.7231555 6.410676 12.512073 4.8620653 ) (-21.967727 25.826026 16.235229 11.272741 -6.89930726 -20.774387 ) (-9.1821537 26.711574 9.33592225 -9.50164796 9.0851593 30.235496 ) (4.69634819 32.327667 18.421081 20.733848 -11.4413375 -46.167587 ) (17.3967628 29.977726 6.97974396 -25.433738 6.68019105 22.434852 ) (27.716602 15.761413 13.659935 -2.9988861 -9.27941896 -1.57182884 ) (36.736824 11.976614 4.3805151 -4.57071495 12.4374847 -4.14753914 ) (47.336082 5.33212757 16.818 -8.7182541 -28.470516 6.1619911 ) (49.918823 -0.305130005 -11.652515 -2.55626249 5.4445772 -2.50043249 ) (40.988594 -4.1116085 -6.2079382 -5.05669499 6.69220734 -8.16025926 ) (38.126762 -13.248434 0.484269857 -13.216955 -14.213407 5.14147759 ) (31.504329 -23.894649 -13.729139 -8.0754776 -3.83857536 5.59434796 ) (15.855903 -29.172954 -17.567714 -2.48112965 17.567714 2.48112965 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 124Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:44:08) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((192 0) (192 301)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((192 301) (52 301)) NIL ((-140. 0 0 0 0 0 )) NATURAL) (2 ((52 301) (52 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((52 337) (388 337)) NIL ((336. 0 0 0 0 0 )) NATURAL) (2 ((388 337) (388 301)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((388 301) (254 301)) NIL ((-134. 0 0 0 0 0 )) NATURAL) (2 ((254 301) (254 0)) NIL ((0 -301. 0 0 0 0 )) NATURAL) (2 ((254 0) (192 0)) NIL ((-62. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 125Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:47:06) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((13 ((390 83) (381 56) (364 35) (340 18) (309 5) (271 -4) (220 -8) (169 -4) (132 5) (100 18) (76 35) (60 56) (51 83)) NIL ((-7.24374676 -28.381198 0 0 -10.5375175 8.2871933 ) (-12.512506 -24.237598 -10.5375175 8.2871933 4.6875944 -5.4359722 ) (-20.706226 -18.668392 -5.84992314 2.85122108 -2.21286487 1.45669841 ) (-27.662582 -15.088821 -8.062788 4.3079195 4.16386414 -0.390820980 ) (-33.643432 -10.9763126 -3.8989234 3.91709852 -14.4425907 0.106587886 ) (-44.763656 -7.00592137 -18.341514 4.0236864 17.606502 5.96446896 ) (-54.301918 6.37024641E-7 -0.735011101 9.98815537 22.016567 -5.9644699 ) (-44.02864 7.00592137 21.281559 4.02368546 -21.67279 -0.106587410 ) (-33.58348 10.9763126 -0.391231656 3.91709805 10.6745968 0.390821457 ) (-28.637413 15.088821 10.283365 4.3079195 -3.02559567 -1.45669794 ) (-19.866848 18.668392 7.25776959 2.85122156 1.42778682 5.43597126 ) (-11.895185 24.237602 8.6855564 8.2871933 -8.6855564 -8.2871933 )) NATURAL) (2 ((51 83) (51 337)) NIL ((0 254. 0 0 0 0 )) NATURAL) (2 ((51 337) (101 337)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((101 337) (101 83)) NIL ((0 -254. 0 0 0 0 )) NATURAL) (10 ((101 83) (110 61) (127 46) (149 37) (196 30) (245 30) (292 37) (314 46) (331 61) (340 83)) NIL ((6.73856164 -23.4566 0 0 13.568626 8.7396221 ) (13.5228748 -19.086792 13.568626 8.7396221 -19.843132 -1.69811344 ) (17.169933 -11.196226 -6.27450753 7.04150868 47.803909 -7.94716836 ) (34.797386 -8.1283016 41.529403 -0.905660153 -51.372535 9.4867897 ) (50.640518 -4.29056549 -9.8431358 8.58113099 19.686271 0 ) (50.640518 4.29056549 9.8431358 8.58113099 -51.372535 -9.4867897 ) (34.797378 8.1283016 -41.529403 -0.905660153 47.803909 7.94716836 ) (17.169933 11.196226 6.27450944 7.04150868 -19.843135 1.69811344 ) (13.5228748 19.086792 -13.568626 8.7396221 13.568626 -8.7396221 )) NATURAL) (2 ((340 83) (340 337)) NIL ((0 254. 0 0 0 0 )) NATURAL) (2 ((340 337) (390 337)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((390 337) (390 83)) NIL ((0 -254. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 126Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:51:38) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((21 337) (192 0)) NIL ((171. -337. 0 0 0 0 )) NATURAL) (2 ((192 0) (248 0)) NIL ((56. 0 0 0 0 0 )) NATURAL) (2 ((248 0) (420 337)) NIL ((172. 337. 0 0 0 0 )) NATURAL) (2 ((420 337) (370 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((370 337) (220 44)) NIL ((-150. -293. 0 0 0 0 )) NATURAL) (2 ((220 44) (71 337)) NIL ((-149. 293. 0 0 0 0 )) NATURAL) (2 ((71 337) (21 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 127Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:57:20) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((24 337) (90 0)) NIL ((66. -337. 0 0 0 0 )) NATURAL) (2 ((90 0) (143 0)) NIL ((53. 0 0 0 0 0 )) NATURAL) (2 ((143 0) (221 288)) NIL ((78. 288. 0 0 0 0 )) NATURAL) (2 ((221 288) (298 0)) NIL ((77. -288. 0 0 0 0 )) NATURAL) (2 ((298 0) (351 0)) NIL ((53. 0 0 0 0 0 )) NATURAL) (2 ((351 0) (417 337)) NIL ((66. 337. 0 0 0 0 )) NATURAL) (2 ((417 337) (367 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((367 337) (317 79)) NIL ((-50. -258. 0 0 0 0 )) NATURAL) (2 ((317 79) (247 337)) NIL ((-70. 258. 0 0 0 0 )) NATURAL) (2 ((247 337) (194 337)) NIL ((-53. 0 0 0 0 0 )) NATURAL) (2 ((194 337) (124 79)) NIL ((-70. -258. 0 0 0 0 )) NATURAL) (2 ((124 79) (74 337)) NIL ((-50. 258. 0 0 0 0 )) NATURAL) (2 ((74 337) (24 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 130Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:06:06) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((49 0) (107 0)) NIL ((58. 0 0 0 0 0 )) NATURAL) (2 ((107 0) (219 142)) NIL ((112. 142. 0 0 0 0 )) NATURAL) (2 ((219 142) (331 0)) NIL ((112. -142. 0 0 0 0 )) NATURAL) (2 ((331 0) (389 0)) NIL ((58. 0 0 0 0 0 )) NATURAL) (2 ((389 0) (248 179)) NIL ((-141. 179. 0 0 0 0 )) NATURAL) (2 ((248 179) (372 337)) NIL ((124. 158. 0 0 0 0 )) NATURAL) (2 ((372 337) (314 337)) NIL ((-58. 0 0 0 0 0 )) NATURAL) (2 ((314 337) (219 216)) NIL ((-95. -121. 0 0 0 0 )) NATURAL) (2 ((219 216) (125 337)) NIL ((-94. 121. 0 0 0 0 )) NATURAL) (2 ((125 337) (66 337)) NIL ((-59. 0 0 0 0 0 )) NATURAL) (2 ((66 337) (189 179)) NIL ((123. -158. 0 0 0 0 )) NATURAL) (2 ((189 179) (49 0)) NIL ((-140. -179. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 131Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:08:44) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((190 0) (190 154)) NIL ((0 154. 0 0 0 0 )) NATURAL) (2 ((190 154) (30 337)) NIL ((-160. 183. 0 0 0 0 )) NATURAL) (2 ((30 337) (91 337)) NIL ((61. 0 0 0 0 0 )) NATURAL) (2 ((91 337) (219 188)) NIL ((128. -149. 0 0 0 0 )) NATURAL) (2 ((219 188) (347 337)) NIL ((128. 149. 0 0 0 0 )) NATURAL) (2 ((347 337) (408 337)) NIL ((61. 0 0 0 0 0 )) NATURAL) (2 ((408 337) (247 154)) NIL ((-161. -183. 0 0 0 0 )) NATURAL) (2 ((247 154) (247 0)) NIL ((0 -154. 0 0 0 0 )) NATURAL) (2 ((247 0) (190 0)) NIL ((-57. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 132Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:10:13) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((72 337) (72 301)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((72 301) (293 301)) NIL ((221. 0 0 0 0 0 )) NATURAL) (2 ((293 301) (61 29)) NIL ((-232. -272. 0 0 0 0 )) NATURAL) (2 ((61 29) (61 0)) NIL ((0 -29. 0 0 0 0 )) NATURAL) (2 ((61 0) (378 0)) NIL ((317. 0 0 0 0 0 )) NATURAL) (2 ((378 0) (378 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((378 36) (124 36)) NIL ((-254. 0 0 0 0 0 )) NATURAL) (2 ((124 36) (355 308)) NIL ((231. 272. 0 0 0 0 )) NATURAL) (2 ((355 308) (355 337)) NIL ((0 29. 0 0 0 0 )) NATURAL) (2 ((355 337) (72 337)) NIL ((-283. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/GENERIC-INIT b/lispusers/GENERIC-INIT new file mode 100644 index 00000000..e72b98e2 --- /dev/null +++ b/lispusers/GENERIC-INIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL") (filecreated "21-Sep-88 11:02:16" |{EG:PARC:XEROX}LISP>USERS>GENERIC-INIT.;108| 102770 |changes| |to:| (advice files? cl:compile makefile getpromptwindow) (vars rooms-init-commands mail-init-commands unix-init-commands loops-init-commands tedit-init-commands pcl-init-commands generic-initcoms who-line-commands display-control-init-commands chat-init-commands) (commands "MORE" "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY") (functions xcl-user::log-generic-init-user eval-at-greet notice make oam de file |PickOneAtRandom| atom-neighbors load-nova-fonts) |previous| |date:| "19-Sep-88 09:26:30" |{EG:PARC:XEROX}LISP>USERS>GENERIC-INIT.;107| ) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint generic-initcoms) (rpaqq generic-initcoms ((* |;;| "Macro to avoid problems when trying to maintain file.") (coms (p (cl:proclaim (quote (global *generic-init-loaded*)))) (initvars (*generic-init-loaded* nil)) (functions eval-at-greet)) (* |;;| "Silent loads") (coms (p (cl:proclaim (quote (global *load-silent* prettyheader)))) (initvars (*load-silent* nil)) (vars (\\original-load-verbose *load-verbose*) (\\original-prettyheader prettyheader) (*load-verbose* (if *load-silent* then nil else *load-verbose*)) (prettyheader (if *load-silent* then nil else prettyheader)))) (* |;;| "Environment setup") (coms * compute-directories-init-commands) (coms * env-tailoring-init-commands) (coms * patch-init-commands) (coms (* |;;| "Wants to be (COMS * FILECACHE-INIT-COMMANDS), but the FileCrasher doesn't exist in Lyric, yet. Probably never will.") (vars filecache-init-commands)) (coms * font-setup-init-commands) (declare\: eval@loadwhen (not *generic-init-loaded*) donteval@compile docopy (files (sysload from lispusers) loadmenuitems)) (* |;;| "Machine status") (coms * who-line-commands) (coms * vstats-init-commands) (* |;;| "Display control") (coms * screen-setup-init-commands) (coms * rooms-init-commands) (coms * change-background-init-commands) (coms * display-control-init-commands) (coms * idle-init-commands) (coms * clock-init-commands) (* |;;| "Programming stuff") (coms * programming-init-commands) (coms * old-utils-commands) (coms * wizard-init-commands) (coms * dinfo-init-commands) (coms * pcl-init-commands) (coms * loops-init-commands) (* |;;| "Documentation") (coms * tedit-init-commands) (coms * sketch-init-commands) (coms * notecards-init-commands) (* |;;| "Communication & Info") (coms * mail-init-commands) (coms * chat-init-commands) (coms * talk-init-commands) (coms * calendar-init-commands) (coms * printer-init-commands) (coms * db-init-commands) (coms * nfs-init-commands) (* |;;| "Files") (coms * file-watch-init-commands) (coms * file-server-init-commands) (coms * dirgrapher-init-commands) (coms * fb-init-commands) (coms * compare-files-init-commands) (* |;;| "Random stuff") (coms * unix-init-commands) (coms * demos-init-commands) (coms * games-init-commands) (* |;;| "Cleanup") (coms * background-menu-cleanup-init-commands) (coms * do-load-utilities-init-commands) (coms (* |;;| "Send the Tool Work's a message telling it about this user.") (functions xcl-user::log-generic-init-user) (initvars (\\cc-generic-init-msg t)) (p (eval-at-greet (cl:unless *generic-init-loaded* (xcl-user::log-generic-init-user))))) (vars (*load-verbose* \\original-load-verbose) (prettyheader \\original-prettyheader) (*generic-init-loaded* t)) (* |;;| "Make the FileManager happy") (declare\: dontcopy (prop makefile-environment generic-init)))) (* |;;| "Macro to avoid problems when trying to maintain file.") (cl:proclaim (quote (global *generic-init-loaded*))) (rpaq? *generic-init-loaded* nil) (defmacro eval-at-greet (&body forms) "Evaluate the forms only when loading the compiled file, and then only when greeting" (bquote (cl:eval-when (cl:load) (cl:unless (or *generic-init-loaded* (memb dfnflg (quote (prop allprop)))) (\\\,@ forms))))) (* |;;| "Silent loads") (cl:proclaim (quote (global *load-silent* prettyheader))) (rpaq? *load-silent* nil) (rpaq \\original-load-verbose *load-verbose*) (rpaq \\original-prettyheader prettyheader) (rpaq *load-verbose* (if *load-silent* then nil else *load-verbose*)) (rpaq prettyheader (if *load-silent* then nil else prettyheader)) (* |;;| "Environment setup") (rpaqq compute-directories-init-commands ((* |;;| "Who am I?") (declare\: donteval@compile (vars (|\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name)))) (loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (concat "{PHYLUM}<" |\\BasicUserName| ">LISP>")) (t loginhost/dir))))) (initvars (|\\UserHomeDirectory| (u-case (packfilename.string (quote host) (filenamefield loginhost/dir (quote host)) (quote directory) |\\BasicUserName|))) (tempdir (concat |\\UserHomeDirectory| "TEMP>")) (home-machine-name "") (private-lispusersdirectories nil) (*cache-directories* nil)))) (* |;;| "Who am I?") (declare\: donteval@compile (rpaq |\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name)))) (rpaq loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (concat "{PHYLUM}<" |\\BasicUserName| ">LISP>")) (t loginhost/dir))) ) (rpaq? |\\UserHomeDirectory| (u-case (packfilename.string (quote host) (filenamefield loginhost/dir (quote host)) (quote directory) |\\BasicUserName|))) (rpaq? tempdir (concat |\\UserHomeDirectory| "TEMP>")) (rpaq? home-machine-name "") (rpaq? private-lispusersdirectories nil) (rpaq? *cache-directories* nil) (rpaqq env-tailoring-init-commands ((* |;;;| " Misc environmental tailoring") (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) pagehold) (vars (|MaxValueLeftMargin| 512) (scrollbarwidth 20) (fixspelldefault (quote \n)) (\\ethertimeout 3000) (empress#sides 2) (*print-case* :downcase)) (* |;;| "FileManager defaults") (vars (cleanupoptions (quote (rc st))) (copyrightflg (quote default)) (recompiledefault (quote exprs)) (*default-cleanup-compiler* (quote cl:compile-file)) (*default-makefile-environment* (quote (:package "XCL-USER" :readtable "XCL" :base 10)))) (* |;;| "None of us here are system hackers") (vars (*original-give-and-take-directories* *give-and-take-directories*) (*give-and-take-directories* (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*))) (* |;;| "I don't like being told that I haven't listed files...") (advise files?) (* |;;| "Load up the extended vmem stuff") (p (eval-at-greet (cl:when (and (eq makesysname (quote :lyric)) (eq (machinetype) (quote dorado))) (filesload (sysload from lispusers) extendedvmem) (install-extended-virtual-memory)) (cl:when (cl:fboundp (quote describe-virtual-memory)) (describe-virtual-memory)))) (* |;;| "Check greetdates whenever I log back in") (addvars (afterlogoutforms (|for| greet-date |in| greetdates |bind| (today _ (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t))))))) (* |;;;| " Misc environmental tailoring") (declare\: donteval@load donteval@compile (filesload (sysload noerror from lispusers) pagehold) (rpaqq |MaxValueLeftMargin| 512) (rpaqq scrollbarwidth 20) (rpaqq fixspelldefault \n) (rpaqq \\ethertimeout 3000) (rpaqq empress#sides 2) (rpaq *print-case* :downcase) (rpaqq cleanupoptions (rc st)) (rpaqq copyrightflg default) (rpaqq recompiledefault exprs) (rpaqq *default-cleanup-compiler* cl:compile-file) (rpaqq *default-makefile-environment* (:package "XCL-USER" :readtable "XCL" :base 10)) (rpaq *original-give-and-take-directories* *give-and-take-directories*) (rpaq *give-and-take-directories* (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*)) (xcl:reinstall-advice (quote files?) :before (quote ((:last (setq notlistedfiles nil))))) (readvise files?) (eval-at-greet (cl:when (and (eq makesysname (quote :lyric)) (eq (machinetype) (quote dorado))) (filesload (sysload from lispusers) extendedvmem) (install-extended-virtual-memory)) (cl:when (cl:fboundp (quote describe-virtual-memory)) (describe-virtual-memory))) (addtovar afterlogoutforms (|for| greet-date |in| greetdates |bind| (today _ (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t))) ) (rpaqq patch-init-commands ((* |;;;| " Patches") (fns purge-file-advice purge-advice) (declare\: donteval@load donteval@compile (* |;;| "") (* |;;| "Start the Lyric-only stuff") (e (printout nil "(" .ppftl (quote (cl:when (eq makesysname :lyric))) t)) (* |;;| "Add NS fileserver random-access support") (initvars (*nsfiling-random-access* t)) (* |;;| "Fix some compiler bogosity") (advise cl:compile) (* |;;| "Add a few missing optimizers") (files (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) base-optimizers) (* |;;| "The interpreted LET* function is busted") (p (/putd (quote let*) nil)) (* |;;| "The var \\BrushAList is broken in the loadup - it ends in (... . NOBIND) instead of (... . NIL)") (* \; "Some people have their system set up to be so paranoid that it is always checking vars to see if they are eq to NOBIND, and generating an error if they are. Since, in the last loop thru the list, the var is indeed bound to NOBIND, we got troubles. The following piece of code is structured in a convoluted way to get around this problem.") (vars (|\\BrushAList| (cl:do ((x |\\BrushAList| (cdr x)) (number-good-brushes 0 (cl:incf number-good-brushes)) (brushes nil) (number-brushes (length |\\BrushAList|))) ((= number-good-brushes number-brushes) (cl:nreverse brushes)) (cl:push (car x) brushes)))) (* |;;| "Advice saved in a file often gets duplicated. This tries to fix it.") (addvars (makefileforms (purge-file-advice file))) (advise makefile) (* |;;| "Fix the SEdit hang bug") (p (changename (quote |\\\\seditA0001|) (quote readp) (quote \\sysbufp))) (* |;;| "") (* |;;| "End the Lyric-only stuff") (e (printout nil " )" t))))) (* |;;;| " Patches") (defineq (purge-file-advice (lambda (file) (* \; "Edited 30-Oct-87 11:08 by smL") (|for| f |in| (filecomslst (rootfilename file) 'advice) |do| (purge-advice f)))) (purge-advice (lambda (fn) (* \; "Edited 30-Oct-87 11:07 by smL") (|if| (hasdef fn 'advice) |then| (putdef fn 'advice (let ((advice (getdef fn 'advice))) (intersection advice advice))) fn |else| nil))) ) (declare\: donteval@load donteval@compile (cl:when (eq makesysname :lyric) (rpaq? *nsfiling-random-access* t) (xcl:reinstall-advice (quote cl:compile) :around (quote ((:last (let (compiler::*input-stream*) (xcl:inner)))))) (readvise cl:compile) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) base-optimizers) (/putd (quote let*) nil) (rpaq |\\BrushAList| (cl:do ((x |\\BrushAList| (cdr x)) (number-good-brushes 0 (cl:incf number-good-brushes)) (brushes nil) (number-brushes (length |\\BrushAList|))) ((= number-good-brushes number-brushes) (cl:nreverse brushes)) (cl:push (car x) brushes))) (addtovar makefileforms (purge-file-advice file)) (xcl:reinstall-advice (quote makefile) :after (quote ((:last (purge-file-advice file)))) :around (quote ((:last (let ((prettyflg (and (not (memb (quote fast) options)) prettyflg))) (declare (cl:special prettyflg)) *)) (:last (let ((|ObjectAlwaysPPFlag| nil)) *))))) (readvise makefile) (changename (quote |\\\\seditA0001|) (quote readp) (quote \\sysbufp)) ) ) (* |;;| "Wants to be (COMS * FILECACHE-INIT-COMMANDS), but the FileCrasher doesn't exist in Lyric, yet. Probably never will." ) (rpaqq filecache-init-commands ((* |;;;| "File caching stuff") (files (from "{EG:}FileCache>") filecache) (declare\: donteval@load (p (|if| (boundp (quote fcache.version.number)) |then| (* |;;| "Set up some initial parameters") (|for| |propDescr| |in| (quote ((trust.cachelist t) (delay.delete t) (timetoverify 300) (io.block? t))) |do| (* \; "UNDOably, of course") (undosave (bquote (fcache.putprop (\\\, (car |propDescr|)) (\\\, (fcache.getprop (car |propDescr|)))))) (fcache.putprop (car |propDescr|) (cadr |propDescr|))) (* |;;| "Tell the fcache scavenger to ignore some files that I store on the cache partition") (/nconc (assoc (quote dorado) fcache.scavenge.ignore) (copy (quote (*.sysout updateloops.cm)))) (* |;;| "Treat any mail files as private files if I'm not on my normal machine") (|if| (not (string-equal home-machine-name (etherhostname))) |then| (|/push| private.files (quote *.mail)))))) (* |;;| "File cache msg window stuff") (initvars (file-cache-message-stream-region (|with| region (windowprop promptwindow (quote region)) (createregion left (difference bottom height) width height))) (file-cache-message-stream-icon-position (|with| region (windowprop promptwindow (quote region)) (|create| position xcoord _ (difference left 75) ycoord _ bottom)))) (declare\: donteval@load (p (|if| (boundp (quote fcache.version.number)) |then| (filesload (sysload noerror from lispusers) filecachemsgwindow) (* \; "UNDOably, of course") (undosave (bquote (dspfont (\\\, (dspfont (fontcreate (quote gacha) 8) *file-cache-message-stream*)) (\\\, *file-cache-message-stream*)))) (dspreset *file-cache-message-stream*) (shrinkw *file-cache-message-stream*)))))) (rpaqq font-setup-init-commands ((* |;;;| "Define printing/fonts the way people like. This includes setting prettyprinting fonts used by the editor and others, Lafite fonts, default flags controlling prettyprinting at the top level, ... This needs to be early, so other utils get the desired fonts.") (alists (fontdefs generic-init)) (initvars (\\font-profile-name (quote generic-init))) (declare\: donteval@load donteval@compile (p (eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow))))))) (advise getpromptwindow)))) (* |;;;| "Define printing/fonts the way people like. This includes setting prettyprinting fonts used by the editor and others, Lafite fonts, default flags controlling prettyprinting at the top level, ... This needs to be early, so other utils get the desired fonts." ) (addtovar fontdefs (generic-init (fontchangeflg . all) (filelinelength . 102) (commentlinelength 80 . 102) (lambdafontlinelength . 95) (firstcol . 60) (prettylcom . 25) (listfilestr . " ") (|ObjectDontPPFlag| . t) (sysprettyflg . t) (**comment**flg) (fontprofile (defaultfont 1 (gacha 10) (gacha 8) (terminal 8)) (boldfont 2 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (littlefont 3 (helvetica 8) (helvetica 6 mir) (modern 6 mir)) (bigfont 4 (helvetica 12 brr) (helvetica 10 brr) (modern 10 brr)) (userfont boldfont) (commentfont littlefont) (lambdafont bigfont) (systemfont) (clispfont boldfont) (changefont) (prettycomfont boldfont) (tinyfont littlefont) (font1 defaultfont) (font2 boldfont) (font3 littlefont) (font4 bigfont) (font5 5 (helvetica 10 bir) (helvetica 8 bir) (modern 8 bir)) (font6 6 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (font7 7 (gacha 12) (gacha 12) (terminal 12)) (font8 8 (cream 10) (cream 10) (modern 10 mir)) (font9 9 (cream 10 brr) (cream 10 brr) (modern 10 bir)) (font10 10 (cream 12) (cream 12) (modern 12 mir)) (font11 11 (timesroman 10) (timesroman 10) (classic 10)) (|\\WindowTitleFont| bigfont) (lafitetitlefont |\\WindowTitleFont|) (chat.font font7)))) (rpaq? \\font-profile-name (quote generic-init)) (declare\: donteval@load donteval@compile (eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow)))))) (xcl:reinstall-advice (quote getpromptwindow) :before (quote ((:last (cond ((and (null font) (boundp (quote promptfont))) (setq font promptfont))))))) (readvise getpromptwindow) ) (declare\: eval@loadwhen (not *generic-init-loaded*) donteval@compile docopy (filesload (sysload from lispusers) loadmenuitems) ) (* |;;| "Machine status") (rpaqq who-line-commands ((* |;;;| "Give us a Who-Line") (* |;;| "Load and start the who-line") (declare\: donteval@load donteval@compile (files (sysload from lispusers) who-line) (* |;;| "Define these now, instead of with an INITVARS, because (i) Who-Line might have been in the sysout, and (ii) you can't define the entries untill the Who-Line code is loaded.") (vars (*who-line-anchor* (quote (:justify :top))) (*who-line-display-names?* t) (*who-line-directories* (list |\\UserHomeDirectory|)) (*who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*))) (p (eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*)))))))))) (* |;;;| "Give us a Who-Line") (* |;;| "Load and start the who-line") (declare\: donteval@load donteval@compile (filesload (sysload from lispusers) who-line) (rpaqq *who-line-anchor* (:justify :top)) (rpaqq *who-line-display-names?* t) (rpaq *who-line-directories* (list |\\UserHomeDirectory|)) (rpaq *who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*)) (eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*)))))) ) (rpaqq vstats-init-commands ((* |;;;| "Storage stuff") (initvars (vstats.clock.interval 0) (vstats.mutil.interval nil) (vstats.position (createposition (difference screenwidth 147) 0))) (declare\: donteval@load donteval@compile (loadmenuitems "System-Aids" (((sysload from lispusers) "VStats") (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|)))) (((sysload from lispusers) |Storage|) (showstorage (quote item))))))) (* |;;;| "Storage stuff") (rpaq? vstats.clock.interval 0) (rpaq? vstats.mutil.interval nil) (rpaq? vstats.position (createposition (difference screenwidth 147) 0)) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) "VStats")) (quote (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|))))) (|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) |Storage|)) (quote (showstorage (quote item)))) ) (* |;;| "Display control") (rpaqq screen-setup-init-commands ((* |;;;| "Screen layout stuff") (declare\: donteval@load donteval@compile (vars (windowtitleshade grayshade)) (* |;;| "Some interesting background shades") (files (sysload from "{FS8:PARC:XEROX}Lisp>Users>") "BITMAP-GALLERY" "GRANITE") (* |;;| "Rearrange the screen") (initvars (\\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal))))) (p (eval-at-greet (cl:when \\rearrange-screen (* |;;| "Change the background shade") (|GraniteBG|) (* |;;| "Fix up the prompt window") (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (* |;;| "Rearrange the screen a bit") (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height))))))) (* |;;| "Make the standard icon functions be cute") (initvars (\\load-grid-icons t) (enforce.icon.grid t)) (p (eval-at-greet (cl:when \\load-grid-icons (filesload (from lispusers) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100))))))) (* |;;;| "Screen layout stuff") (declare\: donteval@load donteval@compile (rpaq windowtitleshade grayshade) (filesload (sysload from "{FS8:PARC:XEROX}Lisp>Users>") "BITMAP-GALLERY" "GRANITE") (rpaq? \\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal)))) (eval-at-greet (cl:when \\rearrange-screen (* |;;| "Change the background shade") (|GraniteBG|) (* |;;| "Fix up the prompt window") (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (* |;;| "Rearrange the screen a bit") (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height)))))) (rpaq? \\load-grid-icons t) (rpaq? enforce.icon.grid t) (eval-at-greet (cl:when \\load-grid-icons (filesload (from lispusers) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100))) ) (rpaqq rooms-init-commands ((declare\: donteval@load donteval@compile (initvars (user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>"))) (roomsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Lyric>" "{Pogo:AISNorth:XEROX}Lyric>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{Pogo:AISNorth:XEROX}Medley>Sources>"))))) (roomsusersdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Lyric>Users>" "{Pogo:AISNorth:XEROX}Lyric>Users>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Users>" "{NB:PARC:XEROX}Lyric>Users>" "{Pogo:AISNorth:XEROX}Medley>Users>" "{Pogo:AISNorth:XEROX}Lyric>Users>")))))) (* \; "Force CL:EVAL instead of the default IL:EVAL, since IL:EVAL doesn't understand some things.") (loadmenuitems "Screen-Maintanance" (((sysload from rooms) "ROOMS") (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" (\\\,@ (if (eq makesysname :lyric) then nil else (quote ("WallPaper"))))))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility))))))))))))) (declare\: donteval@load donteval@compile (rpaq? user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>"))) (rpaq? roomsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Lyric>" "{Pogo:AISNorth:XEROX}Lyric>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{Pogo:AISNorth:XEROX}Medley>Sources>"))))) (rpaq? roomsusersdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Lyric>Users>" "{Pogo:AISNorth:XEROX}Lyric>Users>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Users>" "{NB:PARC:XEROX}Lyric>Users>" "{Pogo:AISNorth:XEROX}Medley>Users>" "{Pogo:AISNorth:XEROX}Lyric>Users>"))))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from rooms) "ROOMS")) (quote (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" (\\\,@ (if (eq makesysname :lyric) then nil else (quote ("WallPaper"))))))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility)))))))))) ) (rpaqq change-background-init-commands ((* |;;;| "Make it easy to change your background") (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{PHYLUM}Faces>") "Dead") (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) (\\\,@ (|for| item |in| menu-items |collect| (car item))) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image))))))))))))))))))) (* |;;;| "Make it easy to change your background") (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{PHYLUM}Faces>") "Dead")) (quote (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) (\\\,@ (|for| item |in| menu-items |collect| (car item))) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image)))))))))))))))) ) (rpaqq display-control-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems "Screen-Maintanance" (((sysload from lispusers) "WDWHacks")) (((sysload from lispusers) "Turbo-Windows")) (((sysload from lispusers) "Solid-Movew")) (((sysload from lispusers) "NSDisplaySizes")) (((sysload from lispusers) "SNAPW-ICON")))))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "WDWHacks"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Turbo-Windows"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Solid-Movew"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "NSDisplaySizes"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "SNAPW-ICON"))) ) (rpaqq idle-init-commands ((* |;;;| "The Idle package") (declare\: donteval@load donteval@compile (loadmenuitems "IdlePatterns" (((sysload from lispusers) "IdleHax")) (((sysload from lispusers) "IdleDrain") (/listput idle.profile (quote displayfn) (quote idle-drain))) (((sysload from lispusers) "ReadBrush")) (((sysload from "{PHYLUM}Andes>Users>") "Bouncing-Face")) (((sysload from lispusers) "StarBG") (/listput idle.profile (quote displayfn) (quote |Cosmos|))) (((sysload from lispusers) "Pac-Man-Idle") (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|))) (((sysload from "{QV}Lisp>") "Idle-Cost")) (((sysload) "ScreenPaper") (/listput idle.profile (quote displayfn) (quote screenpaper))) (((sysload from private-lispusers) "Idle-Lyrics") (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics)))) (p (eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil)))))) (* |;;;| "The Idle package") (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleHax"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleDrain")) (quote (/listput idle.profile (quote displayfn) (quote idle-drain)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "ReadBrush"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{PHYLUM}Andes>Users>") "Bouncing-Face"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "StarBG")) (quote (/listput idle.profile (quote displayfn) (quote |Cosmos|)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "Pac-Man-Idle")) (quote (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{QV}Lisp>") "Idle-Cost"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload) "ScreenPaper")) (quote (/listput idle.profile (quote displayfn) (quote screenpaper)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from private-lispusers) "Idle-Lyrics")) (quote (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics)))) (eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil)) ) (rpaqq clock-init-commands ((* |;;;| "Telling the time") (* |;;| "Standard clock is the Biclock, in the lower-left corner") (initvars (biclockinitialprops (quote (horizontal left vertical bottom size 95)))) (* |;;| "Optional clock is CROCK, also in the lower-left corner") (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) biclock) (loadmenuitems nil (((sysload from lispusers) "Crock") (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow))))))) (* |;;;| "Telling the time") (* |;;| "Standard clock is the Biclock, in the lower-left corner") (rpaq? biclockinitialprops (quote (horizontal left vertical bottom size 95))) (* |;;| "Optional clock is CROCK, also in the lower-left corner") (declare\: donteval@load donteval@compile (filesload (sysload noerror from lispusers) biclock) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Crock")) (quote (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow)))) ) (* |;;| "Programming stuff") (rpaqq programming-init-commands ((* |;;;| "Editing code") (functions notice) (* |;;| "Saving files") (functions make) (* |;;| "For testing optimizers") (functions oam) (* |;;| "Handy exec commands") (commands "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY") (* |;;| "never really worked - (loadmenuitems \"ProgrammingAids\" (((sysload from lispusers) \"Step-Command-Menu\")))") (* |;;| "") (* |;;| "SEDIT stuff") (declare\: donteval@load donteval@compile (p (eval-at-greet (* |;;| "Give us a META key if running on a Dorado") (selectq (machinetype) (dorado (metashift t)) nil) (* |;;| "Reset SEdit so it gets the correct fonts") (case makesysname (:lyric (sedit.reset)) (cl:otherwise (cl:funcall (cl:intern "RESET" (cl:find-package "SEDIT"))))) (* |;;| "Hacking SEdit so it uses better package/readtable defaults") (case makesysname (:lyric (filesload (sysload noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "SEDIT-HACK")) (cl:otherwise (filesload (sysload from lispusers) "sedit-profile"))))) (* |;;| "Change the SEdit EXPAND behavior to expand definers in a reasonable way") (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers"))) (* |;;| "The Eval&Insert hook") (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval"))) (* |;;| "Exit/Compile hooks") (p (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "SEdit-Compile")))))) (* |;;| "TTY editor stuff") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "CL-TTYEdit")))) (declare\: donteval@load donteval@compile (* |;;| "Better WHEREIS facility") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "New-Where-Is"))) (* |;;| "Checking out lexical contexts in a break") (p (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "Debugger-Context")))))) (* |;;| "Save-Your-Ass") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Checkpoint"))) (* |;;| "Spy button") (initvars (\spy.button.pos nil)) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) spy) (spy.button \spy.button.pos))) (* |;;| "Graph calls") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "GraphCalls"))) (* |;;| "The Source Manager") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Manager"))) (* |;;| "Better file listing tools") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "PP-Code-File")) (((sysload from lispusers) "PrettyFileIndex"))) (* |;;| "TEdit executive") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "TExec"))) (* |;;| "Iteration packages") (loadmenuitems "ProgrammingAids" (((sysload from "{Phylum}rcw>") "OSS")))) (declare\: donteval@load donteval@compile (* |;;| "Moving between Xerox Lisp and the rest of the world") (p (|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge"))))))))) (* |;;;| "Editing code") (cl:defun notice (&rest files) "Notice a set of files, so things on them can be edited" (* |;;;| "Return 4 values: a list of all files that were noticed, a list of files that were already noticed, a list of files that weren't noticed because they weren't loaded, and a list of files that couldn't be found.") (cl:labels ((canonocal-filemanager-name (path) "Return the canonical FileManager name of a file" (cl:intern (cl:string-upcase (cl:pathname-name path)) (cl:find-package "IL"))) (find-source-file (file-name &optional (search-path-list directories)) "Return the full pathname of the source file" (or (* \; "In case we are given enough to find the file") (cl:probe-file file-name) (* \; "Check for the original source, in it's original location") (let ((original-source-file-name (cdr (cl:first (get (canonocal-filemanager-name (pathname file-name)) (quote filedates)))))) (cl:if original-source-file-name (cl:probe-file original-source-file-name) nil)) (* \; "As a last resort, check the list of directories") (cl:find-if (cl:function cl:probe-file) (cl:mapcar (cl:function (cl:lambda (dir) (cl:merge-pathnames file-name dir))) search-path-list)))) (file-noticed-p (path) "Has the file been noticed?" (cl:member (canonocal-filemanager-name path) filelst :test (quote eq))) (file-loaded-p (path) "Has the file been loaded?" (not (null (get (canonocal-filemanager-name path) (quote filedates))))) (notice-file (path) "Notice the file" (load path (quote prop)))) (let ((alread-noticed-files nil) (not-loaded-files nil) (noticed-files nil) (not-found-files nil)) (cl:mapc (cl:function (cl:lambda (file) (let ((pathname (find-source-file file))) (cond ((null pathname) (cl:push file not-found-files)) ((file-noticed-p pathname) (cl:push pathname alread-noticed-files)) ((file-loaded-p pathname) (loadfrom pathname nil (quote prop)) (cl:push pathname noticed-files)) (t (cl:push pathname not-loaded-files)))))) files) (cl:values noticed-files alread-noticed-files not-loaded-files not-found-files)))) (* |;;| "Saving files") (cl:defun make (files) (let ((files (or files (cl:remove-if-not (cl:function (cl:lambda (file-name) (cdr (get file-name (quote file))))) filelst))) (original-dir *default-pathname-defaults*) file-dir roopt-file) (cl:unwind-protect (cl:dolist (file files) (cl:setq roopt-file (cl:pathname-name file)) (cl:setq roopt-file (cl:typecase roopt-file (string (cl:intern (cl:string-upcase roopt-file) (cl:find-package "IL"))) (cl:symbol (cl:intern (cl:symbol-name roopt-file) (cl:find-package "IL"))))) (cndir (cl:if (get roopt-file (quote filedates)) (let ((file-dir (unpackfilename.string (cdr (cl:first (get roopt-file (quote filedates))))))) (packfilename.string (quote host) (cl:getf file-dir (quote host)) (quote device) (cl:getf file-dir (quote device)) (quote directory) (cl:getf file-dir (quote directory)))) original-dir)) (cl:when (cl:funcall (quote cleanup) roopt-file) (cl:load (packfilename.string (quote name) roopt-file (quote extension) "dfasl")))) (cndir original-dir)))) (* |;;| "For testing optimizers") (cl:defun oam (form) "Optimize and Macroexpand the form. For use as an SEdit mutator." (compiler:optimize-and-macroexpand-1 form (compiler:make-empty-env) (compiler:make-context))) (* |;;| "Handy exec commands") (defcommand "BREAK" (&rest fns) "Set a breakpoint on the named functions." (eval (bquote (break (\\\,@ fns))))) (defcommand "UNBREAK" (&rest fns) "Remove a breakpoint from the named functions." (eval (bquote (unbreak (\\\,@ fns))))) (defcommand "CALLS" (fn) "Print out information about what the function calls." (cond ((not (cl:fboundp fn)) (cl:format t "~%~S has no function definition" fn)) ((cl:macro-function fn) (cl:format t "~%~S is a macro" fn)) ((cl:special-form-p fn) (cl:format t "~%~S is a special-form" fn)) (t (destructuring-bind (calls binds uses-free uses-global) (calls fn) (cl:format t "~%--- ~S ---" fn) (let ((format-string "~%~A:~{ ~S~}")) (cl:when (not (null calls)) (cl:format t format-string "CALLS" calls)) (cl:when (not (null binds)) (cl:format t format-string "BINDS" binds)) (cl:when (not (null uses-free)) (cl:format t format-string "SPECIALS USED" uses-free)) (cl:when (not (null uses-global)) (cl:format t format-string "GLOBALS USED" uses-global)))))) (cl:values)) (defcommand "DESCRIBE" (&rest objects) "Describe the named objects." (cl:mapc (cl:function (cl:lambda (x) (cl:format t "~&-- ~A --" x) (cl:describe x))) objects) (cl:values)) (defcommand "EC" (form) "Evaluate a compiled version of the form" (cl:funcall (prog2 (cl:format t "~%Compiling...") (cl:compile nil (bquote (cl:lambda nil (\\\, form)))) (cl:format t "done.~%")))) (defcommand "EFF" (&rest patterns-commands) "Edit any uses of any of the patterns on any noticed file. Args are ..patterns - ..edit comands." (let* ((position (cl:position "-" patterns-commands :key (cl:function (lambda (pattern) (if (cl:symbolp pattern) then (cl:symbol-name pattern) else ""))) :test (cl:function string-equal))) (patterns (if (null position) then patterns-commands else (cl:butlast patterns-commands (- (length patterns-commands) position)))) (edit-commands (if position then (cl:subseq patterns-commands (1+ position)) else nil))) (case (cl:length patterns) (0 nil) (1 (editfromfile nil nil (cl:first patterns) edit-commands)) (cl:otherwise (editfromfile nil nil (bquote (*any* (\\\,@ patterns))) edit-commands)))) (cl:values)) (defcommand "FILES?" nil "Tell you about what source files need to be dumped." (files?) (cl:values)) (defcommand "IC" (fn) "Inspect the code for the function." (inspectcode (if (cl:symbolp fn) then (if (ccodep (getd fn)) then fn else (cl:compile nil (getd fn))) else (cl:compile nil (if (cl:member (car fn) (quote (cl:lambda lambda)) :test (cl:function eq)) then fn else (bquote (cl:lambda nil (\\\, fn))))))) (cl:values)) (defcommand "NOTICE" (&rest files) "Notice a set of files, so things on them can be edited" (cl:flet ((tell-user (files msg) (cl:when files (cl:format t "~%~A" msg) (cl:mapcar (cl:function (cl:lambda (path) (cl:format t "~%~5T~A" (cl:pathname-name path)))) files)))) (cl:multiple-value-bind (just-noticed previously-noticed not-loaded not-found) (cl:apply (cl:function notice) files) (tell-user just-noticed "Noticed files") (tell-user previously-noticed "Previously noticed files") (tell-user not-loaded "Not loaded, so not noticed files") (tell-user not-found "Could not find files")) (cl:values))) (defcommand "MAKE" (&rest files) "Save, recompile, and reload the files." (make files) (cl:values)) (defcommand "SPY" (form) (cl:unwind-protect (progn (spy.start) (prog1 (cl:eval form) (spy.end))) (spy.end) (spy.tree))) (* |;;| "never really worked - (loadmenuitems \"ProgrammingAids\" (((sysload from lispusers) \"Step-Command-Menu\")))" ) (* |;;| "") (* |;;| "SEDIT stuff") (declare\: donteval@load donteval@compile (eval-at-greet (* |;;| "Give us a META key if running on a Dorado") (selectq (machinetype) (dorado (metashift t)) nil) (* |;;| "Reset SEdit so it gets the correct fonts") (case makesysname (:lyric (sedit.reset)) (cl:otherwise (cl:funcall (cl:intern "RESET" (cl:find-package "SEDIT"))))) (* |;;| "Hacking SEdit so it uses better package/readtable defaults") (case makesysname (:lyric (filesload (sysload noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "SEDIT-HACK")) (cl:otherwise (filesload (sysload from lispusers) "sedit-profile")))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval"))) (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "SEdit-Compile"))))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "CL-TTYEdit"))) ) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "New-Where-Is"))) (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "Debugger-Context"))))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Checkpoint"))) (rpaq? \spy.button.pos nil) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) spy)) (quote (spy.button \spy.button.pos))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "GraphCalls"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Manager"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PP-Code-File"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PrettyFileIndex"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "TExec"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from "{Phylum}rcw>") "OSS"))) ) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge"))))) ) (rpaqq old-utils-commands ((* |;;| "Used to be in the seperate file UTILS.") (* |;;| "Making sure that breaks happen") (fns |DebugMode|) (* |;;| "Used to be in Loops") (fns selectw) (functions de file) (usermacros de ee fv) (* |;;| "Print out a doc file") (fns |PrintDocFile|) (* |;;| "Just what is says") (fns |\\Pick-One-At-Random|) (functions |PickOneAtRandom|) (* |;;| "Ways to quit a sysout") (fns |GoodNight| |NewLisp|) (* |;;| "Make the KEY3.CM file on the top partition put you back in you last used partition, and the KEY2.CM restart the vmem, assuming that KEY1.CM starts a fresh sysout") (fns |RememberLastPartition| |RememberLispState|) (declare\: donteval@load donteval@compile (addvars (beforelogoutforms (|RememberLispState|) (|RememberLastPartition|)))))) (* |;;| "Used to be in the seperate file UTILS.") (* |;;| "Making sure that breaks happen") (defineq (|DebugMode| (lambda (debug-on-p all-execs-p) (* \; "Edited 25-Jan-88 08:19 by smL") (|if| debug-on-p |then| (setq nlsetqgag nil) (setq helpflag break!) (|if| all-execs-p |then| (putassoc 'helpflag (list 'break!) *per-exec-variables*)) |else| (setq nlsetqgag t) (setq helpflag t) (|if| all-execs-p |then| (putassoc 'helpflag (list t) *per-exec-variables*))))) ) (* |;;| "Used to be in Loops") (defineq (selectw (lambda nil (* \; "Edited 15-Jan-88 09:17 by smL") (* |;;;| "Let the user select a window") (|first| (clrprompt) (|printout| promptwindow "Move mouse to desired window." t "Then press down the CTRL key or click mouse") |until| (or (keydownp 'ctrl) (not (mousestate up))) |do| nil |finally| (getmousestate) (clrprompt) (return (whichw))))) ) (defmacro de (|fn-name| |arg-list| &rest |body|) (* |;;;| "Shorthand for defineing functions") (bquote (defineq ((\\\, |fn-name|) (\\\, |arg-list|) (\\\,@ |body|))))) (defmacro file (|file-name| &rest |file-package-commands|) (* |;;;| "Allows one to create a file giving the commands explicitly e.g. - (FILE FOO (VARS * FUMVARS) (FNS * FNSLIST)) - will create FOOCOMS and make file FOO") (let ((|real-file-name| (u-case |file-name|))) (bquote (progn (\\\, (|if| (null |file-package-commands|) |then| nil |elseif| (and (litatom (car |file-package-commands|)) (null (cdr |file-package-commands|))) |then| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (getatomval (quote (\\\, (car |file-package-commands|)))))) |else| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (quote (\\\, |file-package-commands|)))))) (resetform (radix 10) (makefile (quote (\\\, |real-file-name|)))))))) (addtovar usermacros (fv nil (e (freevars (\## (orr (up 1) nil)) t))) (ee nil (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (ee (dummy) (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (de nil (comsq (bi 1 -1) (e (dedite (\## 1)) t) (bo 1)))) (addtovar editcomsa de ee) (addtovar editcomsl ee) (* |;;| "Print out a doc file") (defineq (|PrintDocFile| (lambda (utility-name print-server) (* \; "Edited 17-Mar-88 16:24 by smL") (* |;;;| "Print out the documentation file for the named package") (setq print-server (or print-server (car defaultprintinghost))) (cl:flet ((find-doc-source-file nil (or (findfile (packfilename 'name utility-name 'extension 'tedit) nil directories) (findfile (packfilename 'name utility-name 'extension 'ted) nil directories) (findfile (packfilename 'name utility-name 'extension 'txt) nil directories) (findfile (packfilename 'name utility-name 'extension 'doc) nil directories)))) (|if| (eq print-server t) |then| (let ((doc-file (find-doc-source-file))) (|if| doc-file |then| (tedit doc-file) |else| "No doc file found")) |elseif| print-server |then| (let ((doc-file (or (findfile (packfilename 'name utility-name 'extension (selectq (printertype print-server) ((press fullpress) 'press) (interpress 'ip) (help "Unknown printer type!"))) nil directories) (find-doc-source-file)))) (|if| doc-file |then| (add.process `(empress ',doc-file nil ',print-server)) (concat "Printing file " doc-file " on printer " print-server) |else| "No doc file found")) |else| "No printer specified")))) ) (* |;;| "Just what is says") (defineq (|\\Pick-One-At-Random| (lambda (|list|) (* \; "Edited 15-Jan-88 09:20 by smL") (* |;;;| "Return a random element of the list") (resetlst (resetsave (randset t) `(randset ,(randset))) (car (nth |list| (rand 1 (length |list|))))))) ) (defmacro |PickOneAtRandom| (&rest |elements|) (bquote (|\\Pick-One-At-Random| (quote (\\\, (mapcar |elements| (quote eval))))))) (* |;;| "Ways to quit a sysout") (defineq (|GoodNight| (lambda (|flag| |altoCommandString|) (* |smL| "20-Sep-85 14:43") (let ((|stream| (openstream '{dsk}rem.cm\;1 'output 'old/new))) (prin1 (or |altoCommandString| "Q") |stream|) (terpri |stream|) (closef |stream|)) (logout |flag|))) (|NewLisp| (lambda nil (* \; "Edited 15-Jan-88 09:20 by smL") (* |;;;| "Start up a new system, assuming that {DSK}KEY1.CM starts one up.") (|if| (mouseconfirm "Do you really want to start up a new system?") |then| (|GoodNight| t "@KEY1.CM")))) ) (* |;;| "Make the KEY3.CM file on the top partition put you back in you last used partition, and the KEY2.CM restart the vmem, assuming that KEY1.CM starts a fresh sysout" ) (defineq (|RememberLastPartition| (lambda nil (* \; "Edited 15-Jan-88 09:21 by smL") (* |;;;| "Sets up the KEY3 CM file in the last partition (19 or 5) to put you back in this partition.") (selectq (machinetype) (dorado (|for| |partitionNumber| |in| '(19 5) |bind| |stream| |key3File| |eachtime| (setq |key3File| (concat "{DSK" |partitionNumber| "}KEY3.CM;1")) (setq |stream| (car (nlsetq (getstream |key3File|)))) (and |stream| (closef? |stream|)) (setq |stream| (car (nlsetq (openstream |key3File| 'output 'old/new)))) |thereis| (streamp |stream|) |finally| (|if| (and (streamp |stream|) (openp |stream|)) |then| (|printout| |stream| "// " "This will set you back in your last used partition, " firstname t "// [last used " (date) "]" t "Par " (diskpartition) t) (closef |stream|)))) nil))) (|RememberLispState| (lambda nil (* \; "Edited 15-Jan-88 09:21 by smL") (* |;;;| "Make KEY2.CM restart this lisp if the logout was not FAST...") (nlsetq (|if| (and (stkpos 'logout) (eq (machinetype) 'dorado)) |then| (|if| (nlsetq (getstream '{dsk}key2.cm\;1)) |then| (closef? (getstream '{dsk}key2.cm\;1))) (resetlst (let ((logout-arg (stkarg 1 'logout)) (stream (openstream '{dsk}key2.cm\;1 'output 'old/new))) (resetsave nil (list (function closef?) stream)) (|printout| stream "// You did a (LOGOUT") (selectq logout-arg (nil nil) (|printout| stream " " logout-arg)) (|printout| stream ") last time [" (date) "], so this will ") (selectq logout-arg ((nil ?) (|printout| stream "restart your old")) (|printout| stream "start a new")) (|printout| stream " LISP, " firstname t) (selectq logout-arg ((nil ?) (|printout| stream "Lisp") (|if| (eqp (realmemorysize) 21845) |then| (|printout| stream " 52525/c"))) (|printout| stream "@KEY1.CM")) (|printout| stream t))))))) ) (declare\: donteval@load donteval@compile (addtovar beforelogoutforms (|RememberLispState|) (|RememberLastPartition|)) ) (rpaqq wizard-init-commands ((* |;;;| "Some tools for wizards, or people who occasionally think they are.") (* |;;| "Find out what other symbols were interned at about the same time as a given symbol. Useful to find out what file defined a symbol.") (functions atom-neighbors))) (* |;;;| "Some tools for wizards, or people who occasionally think they are.") (* |;;| "Find out what other symbols were interned at about the same time as a given symbol. Useful to find out what file defined a symbol." ) (cl:defun atom-neighbors (cl:symbol &optional (xcl-user::number-of-neighbors 8)) (cl:if (cl:symbolp cl:symbol) (let ((xcl-user::atom-number (\\loloc cl:symbol)) (xcl-user::neighbors (list cl:symbol))) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (+ xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) (cl:setf xcl-user::neighbors (cl:nreverse xcl-user::neighbors)) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (- xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) xcl-user::neighbors) "Not a symbol")) (rpaqq dinfo-init-commands ((* |;;| "Set up the on-line documentation") (declare\: donteval@load donteval@compile (vars (irm.host&dir (cond ((infilep "{DSK}HELPSYS>IRMTOP.TEDIT") "{DSK}HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}Lyric>LispUsers>IRM>"))) (dinfomodes (quote (graph)))) (initvars (irm.font (fontcreate (quote (helvetica 10)))) (irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2))))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "DInfo" "Helpsys") (dinfo (irm.get.dinfograph t) irmwindowregion)) (((sysload from lispusers) "LispNerd")))))) (* |;;| "Set up the on-line documentation") (declare\: donteval@load donteval@compile (rpaq irm.host&dir (cond ((infilep "{DSK}HELPSYS>IRMTOP.TEDIT") "{DSK}HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}Lyric>LispUsers>IRM>"))) (rpaqq dinfomodes (graph)) (rpaq? irm.font (fontcreate (quote (helvetica 10)))) (rpaq? irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2)))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "DInfo" "Helpsys")) (quote (dinfo (irm.get.dinfograph t) irmwindowregion))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "LispNerd"))) ) (rpaqq pcl-init-commands ((* |;;| "PCL fun and games") (initvars (pcldirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}LYRIC>" "{PHYLUM}LYRIC>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{pooh/n}pcl>medley>" "{NB:PARC:XEROX}MEDLEY>" "{PHYLUM}MEDLEY>")))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL")) (quote (cl:when (eq makesysname :lyric) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((from pcl) "Clos-Browser")))))))))))) (* |;;| "PCL fun and games") (rpaq? pcldirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}LYRIC>" "{PHYLUM}LYRIC>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{pooh/n}pcl>medley>" "{NB:PARC:XEROX}MEDLEY>" "{PHYLUM}MEDLEY>"))))) (declare\: donteval@load donteval@compile (eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL")) (quote (cl:when (eq makesysname :lyric) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((from pcl) "Clos-Browser")))))))) ) (rpaqq loops-init-commands ((* |;;;| "Loops initialization") (initvars (loopsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Lyric>Sources>" "{PHYLUM}Lyric>Sources>" "{POGO:AISNorth:XEROX}SYSTEM>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{PHYLUM}Medley>Sources>" "{POGO:AISNorth:XEROX}SYSTEM>"))))) (\\loops-init-form (quote (progn (filesload (from "{EG:PARC:XEROX}Loops>") initloops))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form)))))))) (* |;;;| "Loops initialization") (rpaq? loopsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Lyric>Sources>" "{PHYLUM}Lyric>Sources>" "{POGO:AISNorth:XEROX}SYSTEM>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{PHYLUM}Medley>Sources>" "{POGO:AISNorth:XEROX}SYSTEM>"))))) (rpaq? \\loops-init-form (quote (progn (filesload (from "{EG:PARC:XEROX}Loops>") initloops)))) (declare\: donteval@load donteval@compile (eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form)))) ) (* |;;| "Documentation") (rpaqq tedit-init-commands ((* |;;;| "TEDIT stuff") (functions load-nova-fonts) (declare\: donteval@load donteval@compile (vars (tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t)) (* \; "Set up default tabs to be 8 spaces, so we can edit code files.") (tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A"))))))))) (p (eval-at-greet (cl:when (getd (quote tedit)) (* |;;| "Make the ESC key REDO the previous TEdit operation") (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)) (* |;;| "Make TEdit close files when shrunk") (filesload (sysload from lispusers) tedit-close-on-shrink)))) (loadmenuitems "WritingAids" (((sysload from lispusers) "ProofReader")) (((sysload from lispusers) "TMAX")) (((sysload from lispusers) "DictTool")) (((sysload from lispusers) "TEditDoradoKeys")) (((sysload from lispusers) "EditKeys")) (((sysload from lispusers) "VirtualKeyboards") (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file)))) (((sysload from lispusers) "KeyboardEditor")) (((sysload from lispusers) "Equations" "Sketch")) (((sysload from lispusers) "NovaFont") (load-nova-fonts))) (coms (initvars (docobjectsmenufont menufont)) (alists (imageobjgetfns docobj-filestamp-getfn docobj-timestamp-getfn docobj-include-getfn)) (loadmenuitems "WritingAids" (((sysload from lispusers) "Doc-Objects"))))))) (* |;;;| "TEDIT stuff") (cl:defun load-nova-fonts nil (let ((nova-font-host "Starfile Public:Parc:Xerox") (nova-fonts-to-load (quote ("VP Optima XSG Fonts>OptimaItalic" "VP Optima XSG Fonts>OptimaMedium"))) (nova-fonts-to-notice (quote ("Xerox Logo Fonts>XeroxLogo" "Xerox VP Quartz Fonts!2>QuartzBIR" "Xerox VP Quartz Fonts!2>QuartzBRR" "Xerox VP Quartz Fonts!2>QuartzMIR" "Xerox VP Quartz Fonts!2>QuartzMRR")))) (cl:flet ((find-nova-font (font) "Find the Novafont file" (cl:probe-file (cl:make-pathname :host nova-font-host :type "NovaFont" :defaults font)))) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Loading Novafont ~A" (cl:pathname-name font-file)) (load-novafont-file font-file) (notice-novafont-file font-file))))) nova-fonts-to-load) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Noticing Novafont ~A" (cl:pathname-name font-file)) (notice-novafont-file font-file))))) nova-fonts-to-notice))) (cl:mapc (cl:function (cl:lambda (item) (cl:pushnew item tedit.known.fonts :test (quote cl:equal)))) (quote (("XeroxLogo" (quote xeroxlogo)) ("Quartz" (quote quartz)) ("Optima" (quote optima)))))) (declare\: donteval@load donteval@compile (rpaq tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t)) (rpaq tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A")))))))) (eval-at-greet (cl:when (getd (quote tedit)) (* |;;| "Make the ESC key REDO the previous TEdit operation") (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)) (* |;;| "Make TEdit close files when shrunk") (filesload (sysload from lispusers) tedit-close-on-shrink))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "ProofReader"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TMAX"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "DictTool"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TEditDoradoKeys"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "EditKeys"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "VirtualKeyboards")) (quote (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file))))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "KeyboardEditor"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Equations" "Sketch"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "NovaFont")) (quote (load-nova-fonts))) (rpaq? docobjectsmenufont menufont) (addtovar imageobjgetfns (docobj-filestamp-getfn file doc-objects) (docobj-timestamp-getfn file doc-objects) (docobj-include-getfn file doc-objects)) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Doc-Objects"))) ) (rpaqq sketch-init-commands ((* |;;;| "SKETCH Stuff") (alists (imageobjgetfns skio.getfn skio.getfn.2)) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from lispusers) "Sketch")))))) (* |;;;| "SKETCH Stuff") (addtovar imageobjgetfns (skio.getfn) (skio.getfn.2 file sketch)) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Sketch"))) ) (rpaqq notecards-init-commands ((* |;;;| "NOTECARDS stuff") (initvars (|NC.NoteCardsIconPosition| (createposition 891 2)) (ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil))) (notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}1.3L>" "{NB:PARC:XEROX}1.3L>")))) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from notecards) "NoteCards") (|NoteCards| |NC.NoteCardsIconPosition|)))))) (* |;;;| "NOTECARDS stuff") (rpaq? |NC.NoteCardsIconPosition| (createposition 891 2)) (rpaq? ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil))) (rpaq? notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}1.3L>" "{NB:PARC:XEROX}1.3L>"))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from notecards) "NoteCards")) (quote (|NoteCards| |NC.NoteCardsIconPosition|))) ) (* |;;| "Communication & Info") (rpaqq mail-init-commands ((* |;;;| "LAFITE stuff") (declare\: donteval@load donteval@compile (* |;;| "These have to be VARS instead of INITVARS since they come set to default values in the FULL sysout.") (vars (*new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder)))) (defaultmailfoldername (quote active.mail)) (lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>")) (lafitehardcopybatchflg t) (lafitemovetoconfirmflg (quote left)) (lafiteshowmodeflg (quote always)) (lafitebrowserregion (createregion 360 5 650 165)) (lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175)))) (lafitestatuswindowposition (createposition 100 45)) (lafitemodedefault (or lafitemodedefault (quote gv)))) (* |;;| "In latest Lafite. Of course, it doesn't hurt to set them even if they aren't used.") (vars (lafite.dont.display.headers (quote ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References"))) (lafite.dont.forward.headers lafite.dont.display.headers) (lafite.dont.hardcopy.headers lafite.dont.display.headers)) (* |;;| "There are lots of optional mail utilities") (loadmenuitems "MailTools" (((sysload from lispusers) "LafiteTimedDelete")) (((sysload from lispusers) "LafiteFind")) (((sysload from lispusers) "Maintain")) (((sysload from lispusers) "NSMaintain")) (((sysload from lispusers) "MailScavenge")) (((sysload from lispusers) "Undigestify")) (((from lispusers) "Lafite-Indent")) (((sysload from lispusers) "MailShare")) (((sysload from "{QV}Lisp>") "LafiteFolderIcon")) (((sysload from "{ERIS}Sources>") "AppendMail"))) (p (eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{PHYLUM}Lisp>") "Short-Lafite-Header"))))))) (* |;;| "") (* |;;| "Additional text at the start and end of a msg") (declare\: donteval@load donteval@compile (p (eval-at-greet (if *new-lafite-p* then (* |;;| "New Lafite running, set the appropriate vars.") (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (* |;;| "Use the hack I wrote") (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg"))))) (* |;;| "Private DL support") (initvars (lafitedldirectories nil)) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL"))))))) (* |;;| "Patches to Lafite to put the MOVE-TO folder first in the title.") (p (eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{Phylum}Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv))))) (coms (* |;;;| "COMMON-LENS stuff") (initvars (\\use-lens? nil) (user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail"))))))) (vars (user::lens-loader-dir "{NB:PARC:Xerox}Current>")) (p (eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (* \; "Common-Lens already loaded") (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (* \; "Want to use Common-Lens, so load it now") (cl:load (cl:make-pathname :name "LOAD-CLENS" :defaults user::lens-loader-dir))) (t (* \; "Give the user the option of using it later") (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "LOAD-CLENS")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on))))))))) (* |;;| "Turn on mailer (no, no, not Norman -- but he is easy to turn on. Or so I've heard.)") (initvars (\\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber)))) (p (eval-at-greet (cond ((not (getd (quote lafite))) (* \; "Don't turn on mail if it doesn't exist") nil) ((not \\turn-on-mailer) (* \; "Don't turn on if the user doesn't want to") nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (* \; "Use COMMON-LENS if it's here and the user wants it") (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (* \; "Use Lafite") (lafite (quote on)))))))) (* |;;;| "LAFITE stuff") (declare\: donteval@load donteval@compile (rpaq *new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder)))) (rpaqq defaultmailfoldername active.mail) (rpaq lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>")) (rpaqq lafitehardcopybatchflg t) (rpaqq lafitemovetoconfirmflg left) (rpaqq lafiteshowmodeflg always) (rpaq lafitebrowserregion (createregion 360 5 650 165)) (rpaq lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175)))) (rpaq lafitestatuswindowposition (createposition 100 45)) (rpaq lafitemodedefault (or lafitemodedefault (quote gv))) (rpaqq lafite.dont.display.headers ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References")) (rpaq lafite.dont.forward.headers lafite.dont.display.headers) (rpaq lafite.dont.hardcopy.headers lafite.dont.display.headers) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteTimedDelete"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteFind"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Maintain"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "NSMaintain"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailScavenge"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Undigestify"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((from lispusers) "Lafite-Indent"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailShare"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{QV}Lisp>") "LafiteFolderIcon"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{ERIS}Sources>") "AppendMail"))) (eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{PHYLUM}Lisp>") "Short-Lafite-Header"))))) ) (* |;;| "") (* |;;| "Additional text at the start and end of a msg") (declare\: donteval@load donteval@compile (eval-at-greet (if *new-lafite-p* then (* |;;| "New Lafite running, set the appropriate vars.") (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (* |;;| "Use the hack I wrote") (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg"))) ) (* |;;| "Private DL support") (rpaq? lafitedldirectories nil) (declare\: donteval@load donteval@compile (eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL"))))) ) (* |;;| "Patches to Lafite to put the MOVE-TO folder first in the title.") (eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{Phylum}Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv)))) (* |;;;| "COMMON-LENS stuff") (rpaq? \\use-lens? nil) (rpaq? user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail")))))) (rpaq user::lens-loader-dir "{NB:PARC:Xerox}Current>") (eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (* \; "Common-Lens already loaded") (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (* \; "Want to use Common-Lens, so load it now") (cl:load (cl:make-pathname :name "LOAD-CLENS" :defaults user::lens-loader-dir))) (t (* \; "Give the user the option of using it later") (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "LOAD-CLENS")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on))))))) (* |;;| "Turn on mailer (no, no, not Norman -- but he is easy to turn on. Or so I've heard.)") (rpaq? \\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber))) (eval-at-greet (cond ((not (getd (quote lafite))) (* \; "Don't turn on mail if it doesn't exist") nil) ((not \\turn-on-mailer) (* \; "Don't turn on if the user doesn't want to") nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (* \; "Use COMMON-LENS if it's here and the user wants it") (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (* \; "Use Lafite") (lafite (quote on))))) (rpaqq chat-init-commands ((* |;;;| "CHAT stuff") (declare\: donteval@load donteval@compile (alists (networkloginfo lily symbolics)) (vars (chat.allhosts (sort (bquote (|IBID:PARC:XEROX| |PARC CHS:PARC:XEROX| erinyes eris phylum qv (\\\,@ (|for| host |in| defaultprintinghost |when| (eq (printertype host) (quote interpress)) |collect| host)))))) (closechatwindowflg t) (chat.window.size (let ((n-chars-wide 80) (n-chars-high 24)) (cons (min (quotient (times screenwidth 2) 3) (widthifwindow (times n-chars-wide (stringwidth "A" chat.font)))) (min (quotient (times screenheight 2) 3) (heightifwindow (times n-chars-high (fontprop chat.font (quote height))) t))))) (defaultchathost (filenamefield loginhost/dir (quote host)))) (loadmenuitems nil (((sysload from lispusers) "TCPChat")))))) (* |;;;| "CHAT stuff") (declare\: donteval@load donteval@compile (addtovar networkloginfo (lily (login "l" username cr password cr)) (symbolics (login))) (rpaq chat.allhosts (sort (bquote (|IBID:PARC:XEROX| |PARC CHS:PARC:XEROX| erinyes eris phylum qv (\\\,@ (|for| host |in| defaultprintinghost |when| (eq (printertype host) (quote interpress)) |collect| host)))))) (rpaqq closechatwindowflg t) (rpaq chat.window.size (let ((n-chars-wide 80) (n-chars-high 24)) (cons (min (quotient (times screenwidth 2) 3) (widthifwindow (times n-chars-wide (stringwidth "A" chat.font)))) (min (quotient (times screenheight 2) 3) (heightifwindow (times n-chars-high (fontprop chat.font (quote height))) t))))) (rpaq defaultchathost (filenamefield loginhost/dir (quote host))) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "TCPChat"))) ) (rpaqq talk-init-commands ((* |;;| "Talk program initialization commands") (initvars (talk.default.region (createregion 575 0 500 500))) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "Talk")))) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload compiled noerror from "{PHYLUM}Lisp>") fing) (fingw)))))) (* |;;| "Talk program initialization commands") (rpaq? talk.default.region (createregion 575 0 500 500)) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Talk"))) ) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload compiled noerror from "{PHYLUM}Lisp>") fing)) (quote (fingw))) ) (rpaqq calendar-init-commands ((* |;;;| "Calendar") (initvars (caldaydefaultregion (createregion 32 200 375 100)) (caldefaultalertdelta -10) (caldefaulthost&dir (concat |\\UserHomeDirectory| "CALENDAR>")) (calfont (fontcreate (quote (helvetica 18)))) (calupdateonshrinkflg t) (calkeepexpiredrems t)) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "Calendar") (progn (calloadfile "CalReminders") (let ((file (findfile "Calmanac88" t lispusersdirectories))) (cl:when file (calloadfile file))) (calendar (quote thisyear)))))))) (* |;;;| "Calendar") (rpaq? caldaydefaultregion (createregion 32 200 375 100)) (rpaq? caldefaultalertdelta -10) (rpaq? caldefaulthost&dir (concat |\\UserHomeDirectory| "CALENDAR>")) (rpaq? calfont (fontcreate (quote (helvetica 18)))) (rpaq? calupdateonshrinkflg t) (rpaq? calkeepexpiredrems t) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Calendar")) (quote (progn (calloadfile "CalReminders") (let ((file (findfile "Calmanac88" t lispusersdirectories))) (cl:when file (calloadfile file))) (calendar (quote thisyear))))) ) (rpaqq printer-init-commands ((* |;;| "Printer menu") (initvars (printermenu.position (createposition (difference screenwidth 125) 5))) (loadmenuitems nil (((sysload from lispusers) "PrinterMenu") (printermenu))) (* |;;| "Hardcopying graphs") (loadmenuitems nil (((sysload from lispusers) "HGraph"))))) (* |;;| "Printer menu") (rpaq? printermenu.position (createposition (difference screenwidth 125) 5)) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "PrinterMenu")) (quote (printermenu))) (* |;;| "Hardcopying graphs") (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "HGraph"))) (rpaqq db-init-commands ((* |;;| "Information gathering database stuff") (initvars (|*Address-Book-Pos*| (createposition 19 181)) (|*Phone-Directory-Pos*| (createposition 19 181))) (addvars (phonelistfiles "{PHYLUM}ROLODEX.TEDIT")) (loadmenuitems nil (((from lispusers) "Phone-Directory")) (((from lispusers) "AddressBook"))) (* |;;| "Bibliographic lookup") (loadmenuitems "WritingAids" (((from lispusers) "Find-Citation"))))) (* |;;| "Information gathering database stuff") (rpaq? |*Address-Book-Pos*| (createposition 19 181)) (rpaq? |*Phone-Directory-Pos*| (createposition 19 181)) (addtovar phonelistfiles "{PHYLUM}ROLODEX.TEDIT") (|AddLoadMenuItem| (quote nil) (quote ((from lispusers) "Phone-Directory"))) (|AddLoadMenuItem| (quote nil) (quote ((from lispusers) "AddressBook"))) (* |;;| "Bibliographic lookup") (|AddLoadMenuItem| (quote "WritingAids") (quote ((from lispusers) "Find-Citation"))) (rpaqq nfs-init-commands ((* |;;| "Add NFS support") (loadmenuitems "FileAids" (((sysload from "{NB:PARC:XEROX}") "PARC-NFS"))))) (* |;;| "Add NFS support") (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from "{NB:PARC:XEROX}") "PARC-NFS"))) (* |;;| "Files") (rpaqq file-watch-init-commands ((* |;;;| "FileWatcher") (declare\: donteval@load donteval@compile (initvars (|FW-Properties| (bquote (font (gacha 8) all-files? nil position (\\\, (createposition screenwidth (cl:if (and (boundp (quote *who-line*)) (windowp *who-line*)) (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) screenheight))) anchor top-right shade (\\\, grayshade) interval 1000 filters ({dsk1}sysdir {core}<*>rolodex.* {core}<*>*phone*.txt))))) (loadmenuitems "FileAids" (((sysload from lispusers) "FileWatch") (filewatch)))))) (* |;;;| "FileWatcher") (declare\: donteval@load donteval@compile (rpaq? |FW-Properties| (bquote (font (gacha 8) all-files? nil position (\\\, (createposition screenwidth (cl:if (and (boundp (quote *who-line*)) (windowp *who-line*)) (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) screenheight))) anchor top-right shade (\\\, grayshade) interval 1000 filters ({dsk1}sysdir {core}<*>rolodex.* {core}<*>*phone*.txt)))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "FileWatch")) (quote (filewatch))) ) (rpaqq file-server-init-commands ((loadmenuitems "FileAids" (((sysload from lispusers) "NSProtection") (nsprotection))) (* |;;| "The ArchiveTool") (loadmenuitems "FileAids" (((sysload from lispusers) "ArchiveTool")) (((sysload from lispusers) "ArchiveBrowser")) (((sysload from lispusers) "NSAllocation"))))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "NSProtection")) (quote (nsprotection))) (* |;;| "The ArchiveTool") (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "ArchiveTool"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "ArchiveBrowser"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "NSAllocation"))) (rpaqq dirgrapher-init-commands ((* |;;| "DirGrapher") (initvars (dg.file-info-attributes fb.default.info) (dg.default-dir |\\UserHomeDirectory|) (dg.vertical-horizontal-option (quote horizontal)) (dg.background-directories (bquote ((\\\, dg.default-dir) "{NB:PARC:XEROX}" "{Phylum}" "{Pogo:AISNorth:XEROX}")))) (declare\: donteval@load donteval@compile (loadmenuitems "FileAids" (((sysload from lispusers) "DirGrapher")))))) (* |;;| "DirGrapher") (rpaq? dg.file-info-attributes fb.default.info) (rpaq? dg.default-dir |\\UserHomeDirectory|) (rpaq? dg.vertical-horizontal-option (quote horizontal)) (rpaq? dg.background-directories (bquote ((\\\, dg.default-dir) "{NB:PARC:XEROX}" "{Phylum}" "{Pogo:AISNorth:XEROX}"))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "DirGrapher"))) ) (rpaqq fb-init-commands ((* |;;| "FileBrowser tailoring") (declare\: donteval@load donteval@compile (vars (fb.default.info (quote (size creationdate)))) (loadmenuitems "FileAids" (((sysload from lispusers) "Resize-FileBrowser")))))) (* |;;| "FileBrowser tailoring") (declare\: donteval@load donteval@compile (rpaqq fb.default.info (size creationdate)) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "Resize-FileBrowser"))) ) (rpaqq compare-files-init-commands ((* |;;| "Comparing files and the like") (loadmenuitems "FileAids" (((sysload from lispusers) "CompareDirectories")) (((sysload from lispusers) "CompareText")) (((sysload from lispusers) "CompareSources"))))) (* |;;| "Comparing files and the like") (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareDirectories"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareText"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareSources"))) (* |;;| "Random stuff") (rpaqq unix-init-commands ((* |;;| "Some of UNIXish commands") (variables *unix-dir-stack*) (functions do-cd print-directory-stack) (commands "CD" "DIRS" "LS" "MORE" "POPD" "PUSHD" "PWD"))) (* |;;| "Some of UNIXish commands") (defglobalvar *unix-dir-stack* nil "The directory stack used in the exec commands PUSHD and friends.") (cl:defun do-cd (directory) (if (string-equal directory "..") then (let* ((current (directoryname t)) (parent (substring current 1 (strpos ">" current -2 nil nil nil nil t)))) (cndir parent)) else (cndir directory)) (directoryname t)) (cl:defun print-directory-stack nil (cl:format t "~%~A" (directoryname t)) (for dir in *unix-dir-stack* do (cl:format t " ~A" dir)) (cl:values)) (defcommand "CD" (&optional directory) "Connect to a directory" (do-cd directory) (setq *unix-dir-stack* nil) (cl:format t "~%~A" (directoryname t)) (cl:values)) (defcommand "DIRS" nil "Print out the directory stack used by PUSHD and friends." (print-directory-stack) (cl:values)) (defcommand "LS" (&optional (dirspec "*")) "List files matching the spec" (let ((filing.enumeration.depth 1)) (directory dirspec (quote (p)))) (cl:values)) (defcommand "MORE" (file) "Type the contents of a file" (cl:funcall (cl:function see) file) (cl:values)) (defcommand "POPD" (directory) "Connect to the previous directory" (if (null *unix-dir-stack*) then (cl:format t "~%popd: Directory stack empty.") else (do-cd (pop *unix-dir-stack*)) (print-directory-stack)) (cl:values)) (defcommand "PUSHD" (directory) "Connect to a directory, remember the current one on the directory stack." (cl:push (directoryname t) *unix-dir-stack*) (do-cd directory) (print-directory-stack) (cl:values)) (defcommand "PWD" nil "Print out the currently connected directory." (cl:format t "~%~A" (directoryname t)) (cl:values)) (rpaqq demos-init-commands ((* |;;;| "Giveing demos and the like") (initvars (|SlideFiles| (quote ("{PHYLUM}Talks>*.Tedit;")))) (declare\: donteval@load donteval@compile (loadmenuitems "Demos" (((sysload from lispusers) "SlideProjector")) (((sysload from lispusers) "Magnifier")) (((sysload from lispusers) "Big")) (((load from "{PHYLUM}") "Demo")))))) (* |;;;| "Giveing demos and the like") (rpaq? |SlideFiles| (quote ("{PHYLUM}Talks>*.Tedit;"))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "SlideProjector"))) (|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "Magnifier"))) (|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "Big"))) (|AddLoadMenuItem| (quote "Demos") (quote ((load from "{PHYLUM}") "Demo"))) ) (rpaqq games-init-commands ((* |;;;| "R and R") (declare\: donteval@load donteval@compile (loadmenuitems "Games" (((from "{PHYLUM}Lisp>") "BlackBox")) (((from "{FS8:PARC:XEROX}Lisp>") "Go")) (((sysload from lispusers) "Qix") (add.process (quote (qix.grow)))) (((sysload from lispusers) "FaceInvader")) (((sysload from lispusers) "Donz")) (((sysload from lispusers) "Doctor")) (((sysload from lispusers) "Hanoi")) (((sysload from lispusers) "Life")) (((sysload from lispusers) "Solitare")) (((sysload from "{FS8:PARC:XEROX}Lisp>") "RandomWord")))))) (* |;;;| "R and R") (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "Games") (quote ((from "{PHYLUM}Lisp>") "BlackBox"))) (|AddLoadMenuItem| (quote "Games") (quote ((from "{FS8:PARC:XEROX}Lisp>") "Go"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Qix")) (quote (add.process (quote (qix.grow))))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "FaceInvader"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Donz"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Doctor"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Hanoi"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Life"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Solitare"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from "{FS8:PARC:XEROX}Lisp>") "RandomWord"))) ) (* |;;| "Cleanup") (rpaqq background-menu-cleanup-init-commands ((* |;;;| "Clean up the background menu") (functions move-background-item-under) (declare\: donteval@load donteval@compile (p (eval-at-greet (* |;;| "Put the HARDCOPY item under the SNAP command") (move-background-item-under "Hardcopy" "Snap") (* |;;| "Put the ArchiveTool under the FileBrowser") (move-background-item-under "ArchiveTool" "FileBrowser") (* |;;| "Add a menu item for loging out") (/nconc1 |BackgroundMenuCommands| (quote ("LOGOUT & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT)?") (|GoodNight|))) "Logout of LISP" (subitems ("LOGOUT T & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT T)?") (|GoodNight| t))) "Logout without saving VMem"))))) (* |;;| "Hide some system-level commands under a single top-level command") (or (for item in |BackgroundMenuCommands| thereis (string-equal "System" (car item))) (/nconc1 |BackgroundMenuCommands| (list "System" nil nil (list (quote subitems))))) (for label in (quote ("SaveVM" "Idle" "AR Edit" "DumpCache" "Set Directories" "LOGOUT & Power-Off")) do (move-background-item-under label "System")))) (* |;;| "Clear the background menu cache") (vars (|BackgroundMenu| nil))))) (* |;;;| "Clean up the background menu") (cl:defun move-background-item-under (label-to-move parent-label) (let ((item-to-move (for item in |BackgroundMenuCommands| thereis (string-equal label-to-move (car item)))) (parent-item (for item in |BackgroundMenuCommands| thereis (string-equal parent-label (car item))))) (cond ((or (null parent-item) (null item-to-move)) nil) ((null (cdddr parent-item)) (* \; "No subitems yet") (/nconc1 parent-item (bquote (subitems (\\\, item-to-move)))) (/dremove item-to-move |BackgroundMenuCommands|)) (t (* \; "Already has subitems ") (/nconc1 (cadddr parent-item) item-to-move) (/dremove item-to-move |BackgroundMenuCommands|))))) (declare\: donteval@load donteval@compile (eval-at-greet (* |;;| "Put the HARDCOPY item under the SNAP command") (move-background-item-under "Hardcopy" "Snap") (* |;;| "Put the ArchiveTool under the FileBrowser") (move-background-item-under "ArchiveTool" "FileBrowser") (* |;;| "Add a menu item for loging out") (/nconc1 |BackgroundMenuCommands| (quote ("LOGOUT & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT)?") (|GoodNight|))) "Logout of LISP" (subitems ("LOGOUT T & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT T)?") (|GoodNight| t))) "Logout without saving VMem"))))) (* |;;| "Hide some system-level commands under a single top-level command") (or (for item in |BackgroundMenuCommands| thereis (string-equal "System" (car item))) (/nconc1 |BackgroundMenuCommands| (list "System" nil nil (list (quote subitems))))) (for label in (quote ("SaveVM" "Idle" "AR Edit" "DumpCache" "Set Directories" "LOGOUT & Power-Off")) do (move-background-item-under label "System"))) (rpaqq |BackgroundMenu| nil) ) (rpaqq do-load-utilities-init-commands ((* |;;| "Load the users specified utilities") (initvars *load-utility-options* nil) (p (eval-at-greet (cl:unless *generic-init-loaded* (cl:mapc (cl:function (cl:lambda (utility) (|PickLoadUtilityItem| utility nil t))) *load-utility-options*)))))) (* |;;| "Load the users specified utilities") (rpaq? *load-utility-options* nil) (rpaq? nil nil) (eval-at-greet (cl:unless *generic-init-loaded* (cl:mapc (cl:function (cl:lambda (utility) (|PickLoadUtilityItem| utility nil t))) *load-utility-options*))) (* |;;| "Send the Tool Work's a message telling it about this user.") (cl:defun xcl-user::log-generic-init-user nil "If another person uses Generic-Init, let me know." (ignore-errors (let ((xcl-user::me "Lanning") (xcl-user::user (cl:if \\cc-generic-init-msg (username) ""))) (cond ((string-equal xcl-user::user xcl-user::me) (* |;;| "Don't bother if the user is me.") nil) ((not (cl:fboundp (quote lafite.sendmessage))) (* |;;| "Can't send message if LAFITE isn't loaded.") nil) (t (lafite.sendmessage (cl:format nil "Subject: ~A~%To: ~A~%Cc: ~A~@{~%~%~A~}" "Generic-Init" xcl-user::me xcl-user::user "This is to let you know that I am using Generic-Init (again)." "Thanks for making it available.")) (if (eq makesysname :medely) then (lafite.sendmessage (cl:format nil "Subject: ~A~%To: ~A~%From: ~A~@{~%~%~A~}" "!!!Stop using Generic-Init!!!" (username) "Generic-Init (lanning.pa)" "Welcome to Medley." "Did you know that Generic-Init is no longer supported in Medley?" "I thought not." "Instead, please start using VANILLA-INIT (another failure in the quest for a good name)." "You should edit your personal INIT file to reflect this change." "" "Have a nice day." "--smL")))))))) (rpaq? \\cc-generic-init-msg t) (eval-at-greet (cl:unless *generic-init-loaded* (xcl-user::log-generic-init-user))) (rpaq *load-verbose* \\original-load-verbose) (rpaq prettyheader \\original-prettyheader) (rpaqq *generic-init-loaded* t) (* |;;| "Make the FileManager happy") (declare\: dontcopy (putprops generic-init makefile-environment (:package "IL" :readtable "XCL")) ) (putprops generic-init copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil (10532 11096 (purge-file-advice 10542 . 10771) (purge-advice 10773 . 11094)) (50783 51349 (|DebugMode| 50793 . 51347)) (51385 51969 (selectw 51395 . 51967)) (53377 55868 (|PrintDocFile| 53387 . 55866)) (55902 56226 (|\\Pick-One-At-Random| 55912 . 56224)) (56395 57032 (|GoodNight| 56405 . 56722) (|NewLisp| 56724 . 57030)) (57212 60582 (|RememberLastPartition| 57222 . 58511) ( |RememberLispState| 58513 . 60580))))) stop \ No newline at end of file diff --git a/lispusers/GRAPHCALLS b/lispusers/GRAPHCALLS new file mode 100644 index 00000000..0018ef37 --- /dev/null +++ b/lispusers/GRAPHCALLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "24-Aug-88 08:59:17" |{XDE:MCS:STANFORD}MEDLEY>GRAPHCALLS.;1| 59928 changes to%: (FNS GRAPHCALLS.BREAKIN GRAPHCALLS.WHEREIS) previous date%: "21-Jul-88 08:44:32" |{MCS:MCS:STANFORD}GRAPHCALLS.;36|) (* " Copyright (c) 1984, 1985, 1986, 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT GRAPHCALLSCOMS) (RPAQQ GRAPHCALLSCOMS [(* * GRAPHCALLS Dynamic Function Graphing) (LOCALVARS . T) (FNS GRAPHCALLS) (FNS GRAPHCALLS1 GRAPHCALLS.SEARCH GRAPHCALLS.ADVISE GRAPHCALLS.ADVISE1 GRAPHCALLS.BREAKIN GRAPHCALLS.LEFT GRAPHCALLS.MIDDLE GRAPHCALLS.COLLECT GRAPHCALLS.INSPECT.FRAME GRAPHCALLS.INSPECT GRAPHCALLS.INVERT.NODE GRAPHCALLS.FETCH GRAPHCALLS.STORE GRAPHCALLS.PRINT GRAPHCALLS.CLOSE GRAPHCALLS.GRAPH.CLOSEFN NO\ GRAPHCALLS.INSPECTCODE GRAPHCALLS.WHEREIS GRAPHCALLS.ARGLIST) [INITVARS GRAPHCALLS.INSPECTCODE.WINDOW (GRAPHCALLS.DEFAULT.OPTIONS '(:DELAY 500 :SUBFNDEFFLG T :SEARCHFN GRAPHCALLS.SEARCH :DEPTH 2 :LEFTBUTTONFN GRAPHCALLS.LEFT :MIDDLEBUTTONFN GRAPHCALLS.MIDDLE :INSPECTWIDTH 250 :INSPECTCODEWIDTH 400 :FONT (GACHA 8) :FORMAT (HORIZONTAL COMPACT REVERSE/DAUGHTERS] (PROP ARGNAMES GRAPHCALLS) (PROP MENU * GRAPHCALLS.MENUS) (INITVARS * GRAPHCALLS.MENUS) (GLOBALVARS * GRAPHCALLS.MENUS) (GLOBALVARS GRAPHCALLS.DEFAULT.OPTIONS GRAPHCALLS.INSPECTCODE.WINDOW) (RECORDS GRAPHCALLS.RECORD GRAPHCALLS.OPTIONS) (GLOBALVARS DEFAULT.GRAPH.NODEBORDER DEFAULT.GRAPH.NODEFONT DEFAULT.GRAPH.NODELABELSHADE) (BLOCKS (GRAPHCALLS (SPECVARS GRAPHCALLS.SEEN) (ENTRIES GRAPHCALLS) GRAPHCALLS GRAPHCALLS1 GRAPHCALLS.ADVISE GRAPHCALLS.ADVISE1) (GRAPHCALLS.INSPECT.FRAME (SPECVARS GRAPHCALLS.COLLECTED) (ENTRIES GRAPHCALLS.INSPECT.FRAME) GRAPHCALLS.INSPECT GRAPHCALLS.INSPECT.FRAME GRAPHCALLS.COLLECT)) (FILES (SYSLOAD FROM LISPUSERS) MSANALYZE GRAPHER) [P (for MENU in GRAPHCALLS.MENUS do (SET MENU (EVAL (GETPROP MENU 'MENU] (* * GRAPHCALLS Command Window) (FNS GRAPHCALLSW) (FNS GRAPHCALLSW.CLEAR GRAPHCALLSW.DOIT GRAPHCALLSW.FILTER GRAPHCALLSW.INCLUDE GRAPHCALLSW.PRINTFN) (INITVARS GRAPHCALLSW.WINDOW (GRAPHCALLSW.SCRATCHMENU (create MENU))) (VARS GRAPHCALLSW.MENUS) (PROP MENU * (PROGN GRAPHCALLSW.MENUS)) (GLOBALVARS GRAPHCALLSW.WINDOW GRAPHCALLSW.SCRATCHMENU GRAPHCALLSW.MENUS) (DECLARE%: DONTCOPY (RECORDS GRAPHCALLSW.MENUS.RECORD)) (ADDVARS (UNSAFE.TO.MODIFY.FNS ERROR ERRORX RAID RECLAIM \ALLOCBLOCK \MOVEBYTES \MP.ERROR \STOP.DRIBBLE?)) (ALISTS (BackgroundMenuCommands GraphCalls)) (VARS (BackgroundMenu)) (* * Multiple Selection Menus) (FNS MMENU MMENU.SELECTEDFN MMENU.MARKITEM MMENU.BOLDITEM) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA GRAPHCALLS]) (* * GRAPHCALLS Dynamic Function Graphing) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (GRAPHCALLS [CL:LAMBDA (FN &REST OPTIONS &KEY DEPTH &ALLOW-OTHER-KEYS) (* ; "Edited 21-Jul-88 08:39 by cdl") (PROG (GRAPHNODES GRAPH GRAPHCALLS.SEEN) (DECLARE (SPECVARS GRAPHCALLS.SEEN)) (if OPTIONS then (for OPTION on GRAPHCALLS.DEFAULT.OPTIONS by (CDDR OPTION) unless (LISTGET OPTIONS (CAR OPTION)) do (LISTPUT OPTIONS (CAR OPTION) (CADR OPTION))) else (SETQ OPTIONS (COPY GRAPHCALLS.DEFAULT.OPTIONS))) (with GRAPHCALLS.OPTIONS OPTIONS (if (NULL (APPLY* :SEARCHFN FN)) then (RETURN)) (if :STREAM then (SETQ :FONT (DSPFONT NIL :STREAM))) (SETQ GRAPHNODES (GRAPHCALLS1 FN :DEPTH (FONTCOPY :FONT 'WEIGHT 'BOLD) OPTIONS)) (SETQ GRAPH (LAYOUTGRAPH GRAPHNODES (LIST FN) :FORMAT :FONT)) (if (OR (NULL :STREAM) (WINDOWP :STREAM)) then [if (OR :ADVISE :SHAPE) then (LET (GRAPHWIDTH GRAPHHEIGHT) (with REGION (GRAPHREGION GRAPH) (SETQ GRAPHWIDTH (WIDTHIFWINDOW (if (EQMEMB 'COUNT :ADVISE) then (PLUS WIDTH (STRINGWIDTH "00000" :FONT)) else WIDTH))) (SETQ GRAPHHEIGHT (HEIGHTIFWINDOW HEIGHT :ALLOWEDITFLG))) (if (WINDOWP :STREAM) then (with REGION (WINDOWPROP :STREAM 'REGION) (SHAPEW :STREAM (CREATEREGION LEFT BOTTOM GRAPHWIDTH GRAPHHEIGHT))) else (SETQ :STREAM (CREATEW (GETBOXREGION GRAPHWIDTH GRAPHHEIGHT] (SETQ :STREAM (SHOWGRAPH GRAPH :STREAM :LEFTBUTTONFN :MIDDLEBUTTONFN :TOPJUSTIFYFLG :ALLOWEDITFLG :COPYBUTTONEVENTFN)) (WINDOWPROP :STREAM 'CLOSEFN (FUNCTION GRAPHCALLS.GRAPH.CLOSEFN)) (SETQ :STREAM (WINDOWPROP :STREAM 'DSP)) else (DISPLAYGRAPH GRAPH :STREAM)) [if :ADVISE then (STREAMPROP :STREAM 'ADVISEDFNS (RESETFORM (CURSOR WAITINGCURSOR) (GRAPHCALLS.ADVISE GRAPHNODES FN (MKLIST :ADVISE) :STREAM] (STREAMPROP :STREAM 'OPTIONS OPTIONS) (RETURN :STREAM]) ) (DEFINEQ (GRAPHCALLS1 [LAMBDA (FN DEPTH LEAFFONT OPTIONS) (* ; "Edited 28-Jul-87 08:09 by cdl") (DECLARE (USEDFREE GRAPHCALLS.SEEN)) (PROG (GRAPHNODES GRAPHNODE) (push GRAPHCALLS.SEEN FN) [with GRAPHNODE [with GRAPHCALLS.OPTIONS OPTIONS (SETQ GRAPHNODE (create GRAPHNODE NODEID _ FN NODELABEL _ (if :NAMEFN then (APPLY* :NAMEFN FN OPTIONS) elseif :PRIN2FLG then (MKSTRING FN T) else FN] [with GRAPHCALLS.OPTIONS OPTIONS (if (NULL (SETQ TONODES (for SUBFN in (CAR (APPLY* :SEARCHFN FN OPTIONS)) when (OR (NULL :FILTER) (APPLY* :FILTER SUBFN)) collect SUBFN))) then (SETQ NODEFONT LEAFFONT) (RETURN (CONS GRAPHNODE] (if (ZEROP DEPTH) then (SETQ TONODES NIL) else (SETQ GRAPHNODES (for SUBFN in TONODES unless (FMEMB SUBFN GRAPHCALLS.SEEN) join (GRAPHCALLS1 SUBFN (SUB1 DEPTH) LEAFFONT OPTIONS] (RETURN (CONS GRAPHNODE GRAPHNODES]) (GRAPHCALLS.SEARCH [LAMBDA (FN OPTIONS) (* ; "Edited 21-Jul-88 07:31 by cdl") (if (FGETD FN) then (RESETLST [if (with GRAPHCALLS.OPTIONS OPTIONS :SUBFNDEFFLG) then (RESETSAVE (MOVD 'NILL '\SUBFNDEF) `(PUTD \SUBFNDEF ,(GETD '\SUBFNDEF] (CALLS FN))]) (GRAPHCALLS.ADVISE [LAMBDA (GRAPHNODES ROOTID FLAGS STREAM) (* ; "Edited 21-Jul-88 08:28 by cdl") (DECLARE (GLOBALVARS UNSAFE.TO.MODIFY.FNS)) (LET (ADVISED) (if (NOT (FMEMB ROOTID UNSAFE.TO.MODIFY.FNS)) then (push ADVISED (GRAPHCALLS.ADVISE1 ROOTID (GETNODEFROMID ROOTID GRAPHNODES) FLAGS STREAM))) [bind PARENT for GRAPHNODE in GRAPHNODES do (SETQ PARENT (with GRAPHNODE GRAPHNODE (if (LISTP NODEID) then (CAR NODEID) else NODEID))) (bind FN for TONODE in (with GRAPHNODE GRAPHNODE TONODES) when (AND (SETQ FN (if (LISTP TONODE) then (CAR TONODE) else TONODE)) (FGETD FN)) unless (FMEMB FN UNSAFE.TO.MODIFY.FNS) do (push ADVISED (GRAPHCALLS.ADVISE1 (LIST FN :IN PARENT) (GETNODEFROMID TONODE GRAPHNODES) FLAGS STREAM] ADVISED]) (GRAPHCALLS.ADVISE1 [LAMBDA (FN NODE FLAGS STREAM) (* ; "Edited 21-Jul-88 07:44 by cdl") [ADVISE FN 'AROUND NIL `(PROG2 (GRAPHCALLS.INVERT.NODE ,(KWOTE NODE) ,STREAM ,(KWOTE FLAGS) 'BEFORE) * (GRAPHCALLS.INVERT.NODE ,(KWOTE NODE) ,STREAM ,(KWOTE FLAGS) 'AFTER] (UNMARKASCHANGED FN 'ADVICE) FN]) (GRAPHCALLS.BREAKIN [LAMBDA (NODE WINDOW FN) (* ; "Edited 24-Aug-88 08:53 by cdl") (PROG [PARENT NODELST GRAPHNODEID (GRAPHNODES (fetch GRAPHNODES of (WINDOWPROP WINDOW 'GRAPH] (with GRAPHNODE NODE (if (NULL FROMNODES) then (RETURN)) (SETQ NODELST (for FROMNODE in FROMNODES collect (GETNODEFROMID FROMNODE GRAPHNODES))) (if (CDR NODELST) then (for NODE in NODELST do (FLIPNODE NODE WINDOW)) (GRAPHCALLS.PRINT "In the context of which node?") (SETQ PARENT (READ/NODE NODELST WINDOW)) (for NODE in NODELST do (FLIPNODE NODE WINDOW)) else (SETQ PARENT (CAR NODELST))) (if PARENT then (if (LISTP (SETQ GRAPHNODEID (fetch (GRAPHNODE NODEID) of PARENT))) then (SETQ GRAPHNODEID (CAR GRAPHNODEID))) (GRAPHCALLS.PRINT (APPLY* FN `(,NODELABEL :IN ,GRAPHNODEID]) (GRAPHCALLS.LEFT [LAMBDA (GRAPHNODE WINDOW) (DECLARE (SPECVARS GRAPHNODE WINDOW)) (* cdl "15-Oct-85 10:06") (LET [FN (STREAM (WINDOWPROP WINDOW 'DSP] (DECLARE (SPECVARS FN STREAM)) (if GRAPHNODE then (if (LISTP (SETQ FN (fetch (GRAPHNODE NODEID) of GRAPHNODE))) then (SETQ FN (CAR FN))) (MENU GRAPHCALLS.MENU) else (MENU GRAPHCALLS.BACKGROUND.MENU]) (GRAPHCALLS.MIDDLE [LAMBDA (GRAPHNODE WINDOW) (DECLARE (SPECVARS GRAPHNODE)) (* cdl "15-Oct-85 10:07") (LET (FN) (DECLARE (SPECVARS FN)) (if (AND GRAPHNODE GRAPHCALLSW.WINDOW) then (if (LISTP (SETQ FN (fetch (GRAPHNODE NODEID) of GRAPHNODE))) then (SETQ FN (CAR FN))) (MENU GRAPHCALLS.MIDDLE.MENU]) (GRAPHCALLS.COLLECT [LAMBDA (FN GRAPHNODES BACKFLG) (* ; "Edited 31-Mar-87 10:25 by cdl") (DECLARE (USEDFREE GRAPHCALLS.COLLECTED)) (LET [EXPANDCALLS CALLS (VARS (if (FGETD FN) then (VARS FN] [with GRAPHNODE (GETNODEFROMID FN GRAPHNODES) (SETQ EXPANDCALLS (for ID in (if BACKFLG then FROMNODES else TONODES) unless (FMEMB ID GRAPHCALLS.COLLECTED) collect (PROGN (push GRAPHCALLS.COLLECTED ID) ID] [if EXPANDCALLS then (for ID in EXPANDCALLS when (FGETD ID) do (SETQ CALLS (GRAPHCALLS.COLLECT ID GRAPHNODES BACKFLG)) (with GRAPHCALLS.RECORD VARS (SETQ FREEVARS (UNION FREEVARS (fetch (GRAPHCALLS.RECORD FREEVARS) of CALLS))) (SETQ GLOBALVARS (UNION GLOBALVARS (fetch ( GRAPHCALLS.RECORD GLOBALVARS) of CALLS] (replace (GRAPHCALLS.RECORD LOCALVARS) of VARS with NIL) VARS]) (GRAPHCALLS.INSPECT.FRAME [LAMBDA (FN WINDOW TREEFLG BACKFLG) (* cdl "10-Oct-85 17:41") (PROG (RECORD GRAPHCALLS.COLLECTED VARS) (DECLARE (SPECVARS GRAPHCALLS.COLLECTED)) (if (AND TREEFLG (OR BACKFLG (FGETD FN)) (SETQ RECORD (GRAPHCALLS.COLLECT FN (fetch GRAPHNODES of (WINDOWPROP WINDOW 'GRAPH)) BACKFLG)) (in RECORD thereis LISTP)) then (GRAPHCALLS.INSPECT RECORD WINDOW (CONCAT FN "'s " (if BACKFLG then "scope" else "tree"))) elseif (AND (NOT TREEFLG) (FGETD FN) (in (SETQ VARS (VARS FN)) thereis LISTP)) then (GRAPHCALLS.INSPECT VARS WINDOW FN) else (GRAPHCALLS.PRINT NIL "Nothing to INSPECT!"]) (GRAPHCALLS.INSPECT [LAMBDA (RECORD WINDOW LABEL) (* ; "Edited 1-Apr-87 08:21 by cdl") (PROG [INSPECTW INSPECTWS REGION (LINEHEIGHT (FONTPROP DEFAULTFONT 'HEIGHT] (SETQ REGION (CREATEREGION NIL NIL (WIDTHIFWINDOW (with GRAPHCALLS.OPTIONS GRAPHCALLS.DEFAULT.OPTIONS :INSPECTWIDTH)) (HEIGHTIFWINDOW (TIMES (LENGTH (in RECORD thereis LISTP)) LINEHEIGHT) T))) (with REGION (with REGION REGION (GETBOXREGION WIDTH HEIGHT)) (replace (REGION LEFT) of REGION with LEFT) (replace (REGION BOTTOM) of REGION with BOTTOM)) [SETQ INSPECTWS (for FIELD in [CONSTANT (REVERSE (RECORDFIELDNAMES 'GRAPHCALLS.RECORD] as VALUE in RECORD when VALUE collect (PROG1 (SETQ INSPECTW (INSPECTW.CREATE VALUE VALUE (FUNCTION GRAPHCALLS.FETCH) (FUNCTION GRAPHCALLS.STORE) NIL NIL NIL (if LABEL then (CONCAT FIELD " in " LABEL)) NIL (create REGION HEIGHT _ (HEIGHTIFWINDOW (ITIMES (LENGTH VALUE) LINEHEIGHT) T) BOTTOM _ (if INSPECTW then (fetch (REGION TOP) of (WINDOWPROP INSPECTW 'REGION)) else (fetch BOTTOM of REGION)) using REGION))) (WINDOWPROP INSPECTW 'CLOSEFN (FUNCTION GRAPHCALLS.CLOSE)) (WINDOWPROP INSPECTW 'GRAPHW WINDOW))] (if INSPECTWS then (WINDOWADDPROP WINDOW 'INSPECTWS INSPECTWS]) (GRAPHCALLS.INVERT.NODE [LAMBDA (NODE STREAM FLAGS WHEN) (* ; "Edited 28-Jul-87 15:48 by cdl") (if (FMEMB 'INVERT FLAGS) then (FLIPNODE NODE STREAM)) (SELECTQ WHEN (BEFORE (BLOCK (with GRAPHCALLS.OPTIONS GRAPHCALLS.DEFAULT.OPTIONS :DELAY))) (AFTER [if (FMEMB 'COUNT FLAGS) then (with GRAPHNODE NODE (MOVETO (PLUS (fetch XCOORD of NODEPOSITION ) (QUOTIENT NODEWIDTH 2)) (DIFFERENCE (PLUS (fetch YCOORD of NODEPOSITION) (FONTPROP NODEFONT 'DESCENT) 1) (QUOTIENT NODEHEIGHT 2)) STREAM) (DSPFONT NODEFONT STREAM) (printout STREAM %, (if (FIXP NODEBORDER) then (add NODEBORDER 1) else (SETQ NODEBORDER 1]) (SHOULDNT]) (GRAPHCALLS.FETCH [LAMBDA (OBJECT PROPERTY) (* cdl "21-Feb-84 14:17") (EVALV PROPERTY]) (GRAPHCALLS.STORE [LAMBDA (OBJECT PROPERTY NEWVALUE) (* cdl "28-Feb-84 10:09") (SET PROPERTY NEWVALUE]) (GRAPHCALLS.PRINT [LAMBDA (EXP ERROR) (* ; "Edited 28-Jul-87 16:07 by cdl") (DECLARE (GLOBALVARS PROMPTWINDOW)) (CLRPROMPT) (if EXP then (CENTERPRINTINREGION EXP NIL PROMPTWINDOW) elseif ERROR then (RINGBELLS) (CENTERPRINTINREGION ERROR NIL PROMPTWINDOW]) (GRAPHCALLS.CLOSE [LAMBDA (WINDOW) (* ; "Edited 31-Mar-87 10:15 by cdl") (PROG (INSPECTWS (GRAPHW (WINDOWPROP WINDOW 'GRAPHW NIL))) (SETQ INSPECTWS (for WINDOWLST in (WINDOWPROP GRAPHW 'INSPECTWS) thereis (FMEMB WINDOW WINDOWLST))) (for INSPECTW in INSPECTWS when (AND (OPENWP INSPECTW) (NEQ INSPECTW WINDOW)) do (WINDOWPROP INSPECTW 'CLOSEFN NIL) (WINDOWPROP INSPECTW 'GRAPHW NIL) (CLOSEW INSPECTW)) (WINDOWDELPROP GRAPHW 'INSPECTWS INSPECTWS]) (GRAPHCALLS.GRAPH.CLOSEFN [LAMBDA (WINDOW) (* cdl "27-Jun-85 15:13") (for INSPECTWS in (WINDOWPROP WINDOW 'INSPECTWS NIL) do (for INSPECTW in INSPECTWS when (OPENWP INSPECTW) do (WINDOWPROP INSPECTW 'CLOSEFN NIL) (WINDOWPROP INSPECTW 'GRAPHW NIL) (CLOSEW INSPECTW))) (LET ((FNS (STREAMPROP (WINDOWPROP WINDOW 'DSP) 'ADVISEDFNS NIL))) (if FNS then (APPLY (FUNCTION UNADVISE) FNS]) (NO\ [LAMBDA (FN) (* cdl " 6-Mar-84 14:47") (NEQ (NTHCHARCODE FN 1) (CHARCODE \]) (GRAPHCALLS.INSPECTCODE [LAMBDA (FN) (* ; "Edited 17-Sep-87 08:52 by cdl") (DECLARE (GLOBALVARS SCREENHEIGHT SCROLLBARWIDTH)) (LET ((TITLE (CONCAT FN " Code Window"))) (if (NOT (WINDOWP GRAPHCALLS.INSPECTCODE.WINDOW)) then (SETQ GRAPHCALLS.INSPECTCODE.WINDOW (CREATEW (GETBOXREGION (with GRAPHCALLS.OPTIONS GRAPHCALLS.DEFAULT.OPTIONS :INSPECTCODEWIDTH ) (DIFFERENCE SCREENHEIGHT SCROLLBARWIDTH)) TITLE)) else (WINDOWPROP GRAPHCALLS.INSPECTCODE.WINDOW 'TITLE TITLE) (DSPRESET GRAPHCALLS.INSPECTCODE.WINDOW)) (OR (INSPECTCODE FN GRAPHCALLS.INSPECTCODE.WINDOW) FN]) (GRAPHCALLS.WHEREIS [LAMBDA (FN OPTIONS) (* ; "Edited 24-Aug-88 08:57 by cdl") (LET ((FILES (for TYPE in '(FNS FUNCTIONS) join (WHEREIS FN TYPE T))) (LABEL (if (with GRAPHCALLS.OPTIONS OPTIONS :PRIN2FLG) then (MKSTRING FN T) else FN))) (if FILES then (CONS LABEL FILES) else LABEL]) (GRAPHCALLS.ARGLIST [LAMBDA (FN OPTIONS) (* ; "Edited 1-Apr-87 08:58 by cdl") (LET ((LABEL (if (with GRAPHCALLS.OPTIONS OPTIONS :PRIN2FLG) then (MKSTRING FN T) else FN))) (if (FGETD FN) then (CONS LABEL (SMARTARGLIST FN)) else LABEL]) ) (RPAQ? GRAPHCALLS.INSPECTCODE.WINDOW NIL) (RPAQ? GRAPHCALLS.DEFAULT.OPTIONS '(:DELAY 500 :SUBFNDEFFLG T :SEARCHFN GRAPHCALLS.SEARCH :DEPTH 2 :LEFTBUTTONFN GRAPHCALLS.LEFT :MIDDLEBUTTONFN GRAPHCALLS.MIDDLE :INSPECTWIDTH 250 :INSPECTCODEWIDTH 400 :FONT (GACHA 8) :FORMAT (HORIZONTAL COMPACT REVERSE/DAUGHTERS))) (PUTPROPS GRAPHCALLS ARGNAMES (NIL (FN &KEY :ADVISE :ALLOWEDITFLG :COPYBUTTONEVENTFN :DELAY :DEPTH :FILTER :FONT :FORMAT :INSPECTCODEWIDTH :INSPECTWIDTH :LEFTBUTTONFN :MIDDLEBUTTONFN :NAMEFN :PRIN2FLG :SEARCHFN :SHAPE :STREAM :SUBFNDEFFLG :TOPJUSTIFYFLG))) (RPAQQ GRAPHCALLS.MENUS (GRAPHCALLS.BACKGROUND.MENU GRAPHCALLS.MENU GRAPHCALLS.MIDDLE.MENU GRAPHCALLS.SOURCE.MENU)) (PUTPROPS GRAPHCALLS.BACKGROUND.MENU MENU [create MENU ITEMS _ '(("UNBREAK" (UNBREAK) "UnBreak everything.") ("RESET" (for GRAPHNODE in (fetch (GRAPH GRAPHNODES) of (WINDOWPROP WINDOW 'GRAPH)) when (with GRAPHNODE GRAPHNODE (FIXP NODEBORDER)) do (with GRAPHNODE GRAPHNODE (SETQ NODEBORDER NIL)) finally (REDISPLAYW WINDOW]) (PUTPROPS GRAPHCALLS.MENU MENU (create MENU ITEMS _ '[("?=" (PROG (ARGS) (GRAPHCALLS.PRINT [COND ((SETQ ARGS (NLSETQ (SMARTARGLIST FN T))) `(,FN ,@(CAR ARGS] "Args not availiable!")) "The function's argument list") ("HELP" (GRAPHCALLS.PRINT (NLSETQ (PROGN (IRM.LOOKUP FN) FN)) "Help not available!") "HelpSys information") ("FNTYP" (GRAPHCALLS.PRINT (FNTYP FN) "Fn's type not found") "Get the FNTYP of the function") ("WHERE" (GRAPHCALLS.PRINT (WHEREIS FN NIL T) "File not found!") "Do a WHEREIS on function") ("EDIT" (GRAPHCALLS.PRINT (NLSETQ (PROG1 (EDITDEF FN 'FNS) (TOTOPW WINDOW))) "Nothing to EDIT!") "Edit the function") ("TYPEIN" (BKSYSBUF FN T) "BKSYSBUF the function name") ("BREAK" (GRAPHCALLS.PRINT (APPLY* (FUNCTION BREAK) FN)) "Break this function" (SUBITEMS ("BREAKIN" (GRAPHCALLS.BREAKIN GRAPHNODE WINDOW (FUNCTION BREAK)) "Break this fn in another fn") ("UNBREAKIN" (GRAPHCALLS.BREAKIN GRAPHNODE WINDOW (FUNCTION UNBREAK)) "UnBreak this fn in another fn") ("UNBREAK" (GRAPHCALLS.PRINT (APPLY* (FUNCTION UNBREAK) FN)) "UnBreak this function") ("TRACE" (GRAPHCALLS.PRINT (APPLY* (FUNCTION TRACE) FN)) "Trace this function") ("TRACEIN" (GRAPHCALLS.BREAKIN GRAPHNODE WINDOW (FUNCTION TRACE)) "Trace this fn in another fn"))) ("CCODE" (GRAPHCALLS.PRINT (COND ((CCODEP FN) (GRAPHCALLS.INSPECTCODE FN))) "Not compiled code!") "Inspect this function's ccode") ("GRAPH" (GRAPHCALLS.PRINT [APPLY (FUNCTION GRAPHCALLS) `(,FN :STREAM NIL :DEPTH ,(with GRAPHCALLS.OPTIONS GRAPHCALLS.DEFAULT.OPTIONS :DEPTH) ,@(APPEND (STREAMPROP STREAM 'OPTIONS] "Nothing to graph!") "Graph this function's calls") ("FRAME" (GRAPHCALLS.INSPECT.FRAME FN WINDOW) "Inspect this function's vars" (SUBITEMS (">FRAME" (GRAPHCALLS.INSPECT.FRAME FN WINDOW T) "Inspect this sub-graph's freevars") (" " T))) (CLOSEW WINDOW)) "Enter a new function to be graphed, prompts for input.") (Include (GRAPHCALLSW.INCLUDE T) "Specify which functions (by file or function) to include (overide EXCLUDE)." ) (Exclude (GRAPHCALLSW.INCLUDE NIL) "Specify which functions (by file or function) to exclude from the graph." ) (Clear (GRAPHCALLSW.CLEAR) "Clear the current settings on the command window to the defaults." ) (,(MMENU.BOLDITEM "Graph" MENUFONT) (GRAPHCALLSW.DOIT) "Graph the function with the selected settings.")) TITLE _ "Command" CENTERFLG _ T)) (PUTPROPS GRAPHCALLSW.FILTER.MENU MENU (create MENU ITEMS _ '((WhereIs WHEREIS "Only graph functions that WHEREIS can locate." ) (FGetD FGETD "Only graph functions that are defined." ) (ExprP EXPRP "Only graph functions that are not compiled." ) (CCodeP CCODEP "Only graph functions that are compiled." ) (No\ NO\ "Only graph functions that do not have an initial slash in their name." )) TITLE _ "Filters" CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION MMENU.SELECTEDFN))) (PUTPROPS GRAPHCALLSW.FLAGS.MENU MENU (create MENU ITEMS _ '((Invert (:ADVISE INVERT) "ADVISE the graphed functions to invert their node when called." ) (Count (:ADVISE COUNT) "ADVISE the graphed functions to keep a count of calls after their node." ) (Shape (:SHAPE T) "Shape the graph window to fit the graph." ) (Edit (:ALLOWEDITFLG T) "Make the graph editable by passing the ALLOWEDITFLG to SHOWGRAPH." ) (Prin2 (:PRIN2FLG T) "Display the package names.") ) TITLE _ "Flags" CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION MMENU.SELECTEDFN))) (PUTPROPS GRAPHCALLSW.FORMAT.MENU MENU (create MENU ITEMS _ '((Lattice LATTICE "Specify the LATTICE format in LAYOUTGRAPH." ) (Reverse REVERSE "Specify the REVERSE format in LAYOUTGRAPH." ) (Vertical VERTICAL "Specify the VERTICAL format in LAYOUTGRAPH." ) (ArgList (:NAMEFN GRAPHCALLS.ARGLIST) "Use the function and its arguments as the node label." ) (WhereIs (:NAMEFN GRAPHCALLS.WHEREIS) "Use the function and the file(s) where it is found as the node label." )) TITLE _ "Format" CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION MMENU.SELECTEDFN))) (PUTPROPS GRAPHCALLSW.DEPTH.MENU MENU (create MENU ITEMS _ '(0 1 2 3 4 5 6 7 8 9 10) TITLE _ "Depth" WHENSELECTEDFN _ (FUNCTION MMENU.MARKITEM) MENUUSERDATA _ `(VALUE ,(with GRAPHCALLS.OPTIONS GRAPHCALLS.DEFAULT.OPTIONS :DEPTH)) CENTERFLG _ T)) (PUTPROPS GRAPHCALLSW.DELAY.MENU MENU (create MENU ITEMS _ '(0 1 2 3 4 5 6 7 8 9 10) TITLE _ "Delay" WHENSELECTEDFN _ [FUNCTION (LAMBDA (ITEM MENU KEY) (MMENU.MARKITEM ITEM MENU KEY) (LISTPUT GRAPHCALLS.DEFAULT.OPTIONS :DELAY (TIMES 100 ITEM] MENUUSERDATA _ '(VALUE 5) CENTERFLG _ T)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GRAPHCALLSW.WINDOW GRAPHCALLSW.SCRATCHMENU GRAPHCALLSW.MENUS) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GRAPHCALLSW.MENUS.RECORD (COMMANDMENU FILTERMENU FLAGSMENU FORMATMENU DEPTHMENU DELAYMENU )) ) ) (ADDTOVAR UNSAFE.TO.MODIFY.FNS ERROR ERRORX RAID RECLAIM \ALLOCBLOCK \MOVEBYTES \MP.ERROR \STOP.DRIBBLE?) (ADDTOVAR BackgroundMenuCommands (GraphCalls '(GRAPHCALLSW) "Open the GraphCalls Command Window")) (RPAQQ BackgroundMenu NIL) (* * Multiple Selection Menus) (DEFINEQ (MMENU [LAMBDA (MENU PRESELECT) (* ; "Edited 31-Mar-87 14:38 by cdl") (LET [(EVENT (GETMENUPROP MENU 'EVENT] [if (NULL EVENT) then (PUTMENUPROP MENU 'EVENT (SETQ EVENT (CREATE.EVENT 'MULTIMENU] (with MENU MENU (SETQ WHENSELECTEDFN (FUNCTION MMENU.SELECTEDFN))) (ADDMENU MENU) (for ITEM in PRESELECT do (DOSELECTEDITEM MENU ITEM)) (AWAIT.EVENT EVENT) (PROG1 (GETMENUPROP MENU 'VALUE) (PUTMENUPROP MENU 'VALUE NIL))]) (MMENU.SELECTEDFN [LAMBDA (ITEM MENU KEY) (* ; "Edited 21-Jul-88 07:51 by cdl") (LET [(VALUE (GETMENUPROP MENU 'VALUE] (SELECTQ ITEM (DONE (CLRPROMPT) (SETQ VALUE (for ITEM in VALUE collect (DEFAULTWHENSELECTEDFN ITEM MENU))) (DELETEMENU MENU T) (NOTIFY.EVENT (GETMENUPROP MENU 'EVENT))) (CLEAR (for ITEM in VALUE do (SHADEITEM ITEM MENU (CONSTANT WHITESHADE))) (SETQ VALUE NIL)) (if (MEMB ITEM VALUE) then (SHADEITEM ITEM MENU (CONSTANT WHITESHADE)) (SETQ VALUE (DREMOVE ITEM VALUE)) else (SHADEITEM ITEM MENU (CONSTANT BLACKSHADE)) (push VALUE ITEM))) (PUTMENUPROP MENU 'VALUE VALUE]) (MMENU.MARKITEM [LAMBDA (ITEM MENU KEY) (* ; "Edited 21-Jul-88 07:52 by cdl") [LET [(VALUE (GETMENUPROP MENU 'VALUE] (if VALUE then (SHADEITEM VALUE MENU (CONSTANT WHITESHADE] (PUTMENUPROP MENU 'VALUE ITEM) (SHADEITEM ITEM MENU (CONSTANT BLACKSHADE]) (MMENU.BOLDITEM [LAMBDA (STRING FONT) (* cdl "16-Oct-85 08:56") (LET [BITMAP STREAM (BOLDERFONT (FONTCOPY FONT 'WEIGHT 'BOLD] [SETQ STREAM (DSPCREATE (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH STRING BOLDERFONT) (FONTPROP FONT 'HEIGHT] (DSPFONT BOLDERFONT STREAM) (DSPYPOSITION (FONTPROP FONT 'DESCENT) STREAM) (PRIN1 STRING STREAM) BITMAP]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA GRAPHCALLS) ) (PUTPROPS GRAPHCALLS COPYRIGHT ("Stanford University" 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3731 7765 (GRAPHCALLS 3741 . 7763)) (7766 27104 (GRAPHCALLS1 7776 . 9788) ( GRAPHCALLS.SEARCH 9790 . 10226) (GRAPHCALLS.ADVISE 10228 . 11695) (GRAPHCALLS.ADVISE1 11697 . 12375) ( GRAPHCALLS.BREAKIN 12377 . 13892) (GRAPHCALLS.LEFT 13894 . 14399) (GRAPHCALLS.MIDDLE 14401 . 14847) ( GRAPHCALLS.COLLECT 14849 . 16769) (GRAPHCALLS.INSPECT.FRAME 16771 . 18057) (GRAPHCALLS.INSPECT 18059 . 20987) (GRAPHCALLS.INVERT.NODE 20989 . 22678) (GRAPHCALLS.FETCH 22680 . 22814) (GRAPHCALLS.STORE 22816 . 22957) (GRAPHCALLS.PRINT 22959 . 23331) (GRAPHCALLS.CLOSE 23333 . 24031) ( GRAPHCALLS.GRAPH.CLOSEFN 24033 . 24651) (NO\ 24653 . 24803) (GRAPHCALLS.INSPECTCODE 24805 . 26253) ( GRAPHCALLS.WHEREIS 26255 . 26712) (GRAPHCALLS.ARGLIST 26714 . 27102)) (35375 39533 (GRAPHCALLSW 35385 . 39531)) (39534 48781 (GRAPHCALLSW.CLEAR 39544 . 40456) (GRAPHCALLSW.DOIT 40458 . 43379) ( GRAPHCALLSW.FILTER 43381 . 44769) (GRAPHCALLSW.INCLUDE 44771 . 47892) (GRAPHCALLSW.PRINTFN 47894 . 48779)) (57293 59681 (MMENU 57303 . 57870) (MMENU.SELECTEDFN 57872 . 58835) (MMENU.MARKITEM 58837 . 59174) (MMENU.BOLDITEM 59176 . 59679))))) STOP \ No newline at end of file diff --git a/lispusers/GRAPHCALLS.TEDIT b/lispusers/GRAPHCALLS.TEDIT new file mode 100644 index 00000000..cc672127 --- /dev/null +++ b/lispusers/GRAPHCALLS.TEDIT @@ -0,0 +1,26 @@ +enˇvĹos GRAPHCALLS 2 4 1 GRAPHCALLS 1 4 By: Christopher Lane (Lane@Sumex-Aim.Stanford.Edu) Uses: GRAPHER, MSANALYZE (WHERE-IS & HELPSYS optional) GRAPHCALLS is an extended graphical interface to the Envos Lisp CALLS function. It is to CALLS what BROWSER is to SHOW PATHS in MASTERSCOPE. It allows fast graphing of the calling hierarchy of both interpreted and compiled code, whether or not the source is available (see the CALLS function in the MASTERSCOPE section of the Lisp Library Modules manual), allowing examination of both user and system functions. The sources of the functions do not have to be analyzed by MASTERSCOPE first. Additionally, buttoning a function on the graph brings up a menu of operations that can be done with the function, such as editing, inspecting, further graphing etc. (GRAPHCALLS FUNCTION &REST OPTIONS) [Function] Graphs the calling hierarchy of FUNCTION. Terminal nodes on the graph (those which call no other functions or are undefined) are printed in a bold version of the graph's font indicating that they cannot be graphed further: (( FIELDS ( SIDESFLG T) IDS 14 DATE \UNPACKDATE DAYTIME IMOD \DTSCAN \ISDST? \OUTDATE \LISPERROR NTH SUBSTRING NCHARS ALLOCSTRING \RPLRIGHT RPLSTRING FONTS 2 (GACHA 8) (GACHA 8 BRR) NODES ( (1 DATE (11 . 76) 1 NIL NIL (2 7 ) NIL) (2 \UNPACKDATE (80 . 111) 1 NIL NIL (3 4 5 6 ) (1 )) (3 DAYTIME (157 . 129) 1 NIL NIL NIL (2 )) (4 IMOD (150 . 117) 2 NIL NIL NIL (2 )) (5 \DTSCAN (157 . 105) 2 NIL NIL NIL (2 )) (6 \ISDST? (157 . 93) 1 NIL NIL NIL (2 )) (7 \OUTDATE (73 . 41) 1 NIL NIL (8 9 10 11 12 13 14 ) (1 )) (8 \LISPERROR (150 . 77) 1 NIL NIL NIL (7 )) (9 NTH (132 . 65) 2 NIL NIL NIL (7 )) (10 SUBSTRING (147 . 53) 1 NIL NIL NIL (7 )) (11 NCHARS (140 . 41) 1 NIL NIL NIL (7 )) (12 ALLOCSTRING (152 . 29) 1 NIL NIL NIL (7 )) (13 \RPLRIGHT (147 . 17) 2 NIL NIL NIL (7 )) (14 RPLSTRING (147 . 5) 1 NIL NIL NIL (7 )) )) 0 0 NIL The remainder of the) The remainder of the arguments, in keyword format, make up OPTIONS eg. (GRAPHCALLS 'DATE :FONT '(GACHA 10) :DEPTH 4 :FILTER 'FGETD) Options include: :STREAM An image stream to display the graph on. The options list is saved on the stream. :FILTER A predicate to apply to the functions when building the graph to test their eligibility to appear on the graph. The filter can be any defined function; the default is not to filter. Interesting filters include: WHEREIS Limits the tree to only functions the user as has loaded and prunes out system functions and SYSLOADed files. Quite useful. FGETD Limits the tree to only functions that are actually defined. Thus if you are perusing the tree for BITBLT and do not have and are not interested in the color code, FGETD will remove all of the undefined color bitmap functions. EXPRP Limits the tree to interpreted functions. Useful for graphing functions in the development stage. CCODEP Limits the tree to compiled functions. NO\ Keeps low level functions starting with \ (i.e. \OUTDATE) off of the graph. Useful for getting an overview of system functions and when advising system functions (as \'ed functions should probably not be advised). :DEPTH The calling hierarchy is graphed to depth levels (defaults to 2). :FORMAT Passed to LAYOUTGRAPH and can be any format specification (LATTICE, VERTICAL, REVERSE etc.); defaults to (HORIZONTAL COMPACT REVERSE/DAUGHTERS). In the forest format multiple instances of a function appear on the graph after every calling function and a boxed node indicates the function appears elsewhere on the graph, possibly graphed further. In the lattice format each function gets placed on the graph only once (particularly useful for dynamic graphing, described below), and boxed nodes indicate recursive functions calls. :SEARCHFN A function to use to generate the children of a given node. It should return a list whose first item is a list of the children, the other items in the list are ignore. Using this feature, it is possible to graph things other than functions. To graph what files load other files, supply a search function of (LAMBDA (FILE) (LIST (FILECOMSLST FILE 'FILES))) and a file name for the function argument. :ADVISE Advises the functions after they are graphed (see Dynamic Graphing below); recognized values are one or both of the following: INVERT Visually tracks a running program . COUNT Counts function calls in a running program. :DELAY The delay to use in advised graphs; defaults to 500 milliseconds. :NAMEFN A function to use to generate the node labels on the graph. :FONT The font to use to display the graph; defaults to (GACHA 8). :SHAPE A boolean that indicates if the window should be shaped to fit the graph; defaults to NIL. :PRIN2FLG A boolean that indicates to use PRIN2 when printing node labels, defaults to NIL. :SUBFNDEFFLG A boolean that enables graphing of compiler generated functions; defaults to T. :TOPJUSTIFYFLG Passed to SHOWGRAPH; defaults to NIL. :ALLOWEDITFLG Passed to SHOWGRAPH; defaults to NIL. GRAPH MENUS The menu that pops up when you left button a function on the graph contains the following items: ?= Print the arguments to the function, if available. HELP Calls HELPSYS on the function. FNTYP Print the function's FNTYP. WHERE Do a WHEREIS (with FILES = T) on the function. EDIT Calls the editor on the function if available for editing. TYPEIN BKSYSBUFs the name of the function into the typein buffer. BREAK Applies BREAK to the function. Its subitems are: BREAKIN Breaks the function only in the context of a particular calling function. In lattice format, if the function has more than one function calling it on the graph, the user is prompted to indicate the caller in which to break the function. UNBREAKIN Undoes BREAKIN. UNBREAK Applies UNBREAK to the function. TRACE Applies TRACE to the function. TRACEIN Traces the function only when called from inside a particular function, like BREAKIN above. Use UNBREAKIN to remove the trace, or else UNBREAK on the window menu. CCODE Calls INSPECTCODE on the function if it is compiled code. GRAPH Calls GRAPHCALLS to make a new graph starting with function, inherits the original graph's options. FRAME Inspect the local, free and global variables of the function. These are the last three lists of the CALLS function placed into INSPECT windows. Its subitems are: >FRAME Like FRAME but for all of the functions on the sub-tree starting at the selected node and only for FREEVARS and GLOBALVARS. FRAME but for all of the functions above the function in the graph, i.e. the FREEVARS and GLOBALVARS in the function's scope. Buttoning the graph outside a node give you a menu with these options: UNBREAK Does an (UNBREAK), unbreaking all broken functions. RESET Resets the counters for the COUNT option and redisplays the graph. DYNAMIC GRAPHING When the ADVISE option is specified with the value(s) of INVERT and/or COUNT, GRAPHCALLS will advise all of the functions on the graph (in the context of their parent) to invert their corresponding node on the graph (as well as delay some to allow it to be seen) and/or follow each function name by a count of the number of times it has been executed. In invert mode, a node remains inverted as long as control is inside its corresponding function and it returns to normal when the function is exited. The lattice format is best when using the invert feature. Closing the graph window UNADVISEs the functions on the graph. An example of this is (GRAPHCALLS 'DATE :ADVISE 'INVERT) and then evaluate (DATE). GRAPHCALLS will not graph or advise any function in the system list UNSAFE.TO.MODIFY.FNS when the advise option is used. Functions which are unsafe to advise should be added to this list. CAVEAT PROGRAMMER! This feature must be used with caution. As a rule, one should not do this to system functions, but only one's own, use WHEREIS as a filter for this. Advising system code indiscriminately will probably crash the machine unrecoverablely. You can, at some risk, interactively break and edit functions on the graph while the code is executing. Also, creating subgraphs of advised graphs will show the generated advice functions not the original functions called, as will creating new graphs of functions in advised graphs. You can create advised graphs of functions already graphed normally on the screen. COMMAND WINDOW )Ś˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ţ˙˙ďří˙ř˙˙˙˙˙ý÷;˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ý÷˙˙ď÷żí˙÷ż˙˙˙˙˙ý÷;˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€űţ˜ččďříÇďřtΙăŁĹ÷;hńpîď˙˙˙˙˙˙˙˙˙˙˙˙˙€űţWggo÷mťď÷ł6fݝšú×gnonď˙˙˙˙˙˙˙˙˙˙˙˙˙€ű†üoooümÇď÷ˇvîń˝˝ú×ooou_˙˙˙˙˙˙˙˙˙˙˙˙˙€űöóoooóműď÷ˇvîÍ˝˝ú×ooou_˙˙˙˙˙˙˙˙˙˙˙˙˙€ýć÷gowˇmť÷ˇˇvîÝ˝šýďono{ż˙˙˙˙˙˙˙˙˙˙˙˙˙€ţř¨ďxx­Çřxwvîâ˝Ĺýďoqpűż˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€Ŕ€Ŕ€Ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ů€Ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ů€Ď˙˙˙˙˙˙˙˙˙ţ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ů€Ď‡˙˙˙˙˙˙ßţŰ˙˙˙˙Ŕß˙˙˙ţ˙˙˙ý˙˙˙wř?ű˙ů€Ď{˙˙˙˙˙˙ßţ˙Ű˙˙˙˙ßß˙˙˙ţ˙˙˙˙ý˙{˙˙wűßű˙ů€Î˙‡Léž:<_ţţĐÇL˙ßÜx¸˙ţ˙”Ď}ÇF{î;Žé€Î˙{3fmŮ۟ţŰť+ż˙Áۡ7ţöS6í˙}ť;sťíŰvé€Î˙{wnďŰßţţۃ|˙ßŢ7¸˙ţţö÷w˙}ƒ{wťěÇY€Î˙{wněŰŰßţţŰżż˙ß١żţţö÷vm˙}ż{wťíű7Y€Ď{{wníŰ۟ţţŰť{ż˙ßۡ7ţţö÷ví˙{ť;wťÝŰwš€Ď‡‡wnî+Ü_ţţÜÇ|˙ßÜX¸˙ţ˙÷wÇG—¸>;‹š€Ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙÷ż˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙š€Ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ř˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţy€Č  €Č   €Č?  @"Ŕ 8 €Č0€ @  D €Č0fřóěóŕ—,á KˆŽ/Âçú8p D €Č>f͙›0Ľ‘5" LH‘5"Dˆ D €Č0f́›0ĽŸ!ń HE!r"@ř D €Č0f́›0Ľ! HE!’"@€ D €Č0f͙›0B‘!" HB!"Dˆ D €Č0>Ěđěó0BŽ á HB Âřéš8pŔ 8 €Č  €Č  €Č  €Č  €Č€ áđ> x‚€@  €Č€ ! „‚@Ŕ  €Č—$#Ł€砀!x„šâGYÄŔ x €Č˜‘$$d@Ä €!„„Ä‚H‘"j$D@  €Č$$'Ŕyň €!„„„‚Š>AÇÄ@  €Č$$$  €!„„„‚H + @$@  €Č‘$dd@! „„Œ„‚H„"B$D@  €ČŽ#ŁŁ€čáž xxt„bGAÄ@  €Č  €Č  €Č ˙˙˙˙ŕ €Č ˙˙˙˙ŕ €Čđř!ń"˙ţ?˙ŕ8 €Č€"  ˙ýß˙ŕD €Č#‰čŕâЀ"pâáÂ!Ĺú8q˙˙ß˙ŕ €ČáDI đŁP€!á‰""&˘D‰˙˙ß˙ŕ €Č„ đB râCä"@9˙˙?˙ŕ €Č„ B ’B"@É˙ţ˙˙ŕ €ČDIŁ" "‚$"D‰˙ý˙˙ŕ@ €Čň#ˆččŕůâ!ńęáÄ8u˙ü˙ŕ| €Č ˙˙˙˙ŕ €Č ˙˙˙˙ŕ €Č  €Č  €Čń<| ř €Ŕ 8 €Č B!B  € D €Č8°€@B éxBΐĎ  €Č"DĐ€@!#"B ń CQ$Ŕ  €Č>€€@!!>|  "Ä  €Č d€€@!! @  â$  €Č "D€B!!#"@  $ D €Čń:€<@ ř韑ĂŔ 8 €Č € €Č  €Č  €Č  €Č  ># Ŕ  €Č1€  !"# Ŕ  €Č0>qóŕ +#Á !-.#áŜ#„@ ( €Č3ś›0 $! !51Ł&˘$D@ ( €Č1°y›0 $ € >!! ˘ä>#„@ H €Č1°Ů›0¤ @ !!˘ Dŕ | €Č3°Ů›0d !! B$"$D@  €Č°}ó0#Ŕ !!>BÄ#„@  €Č€  €Č€  €Ď˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü?˙˙˙ů€Ŕ?˙˙˙ů€Ŕŕ?˙Ă˙ů€Ŕ?˙ß˙ů€ŔŔ?˙‡˙ů€Ŕ ?˙ť˙ů€Ŕ ?˙ű˙ů€Ŕ ?˙ű˙ů€Ŕ ?˙ť˙ů€ŔŔ?˙Ç˙ů€Ŕ?˙˙˙ů€Ŕ?˙˙˙ů€Ŕ €Ŕ €ŔŔ 8 €Ŕ D €Ŕ @ €ŔŔ x €Ŕ D €Ŕ D €Ŕ D €ŔŔ 8 €Ŕ €Ŕ €Ŕ €Ŕ €Ŕŕ | €Ŕ  €Ŕ@  €Ŕ€  €Ŕ€  €Ŕ €Ŕ €Ŕ €Ŕ €Ŕ €Ŕ €Ŕ €ŔŔ 8 €Ŕ D €Ŕ D €ŔŔ 8 €Ŕ D €Ŕ D €Ŕ D €ŔŔ 8 €Ŕ €Ŕ €Ŕ €Ŕ €ŔŔ 8 €Ŕ D €Ŕ D €Ŕ D €Ŕŕ < €Ŕ  €Ŕ D €ŔŔ 8 €Ŕ €Ŕ €Ŕ €Ŕ €Ŕ8 C€ €Ŕ D Ä@ €Ŕ \ S Q( '  +` 5    0 < = 4đ " Ľ ; e Ś}…G 5 D  r " ˝ ď o° BMOBJ.GETFN3MODERN + + + + + Ů ­ 6 n p m EĆ{|€'v j yŤ ­ +4¸MU€GM-zş \ No newline at end of file diff --git a/lispusers/GRAPHGROUP.TEDIT b/lispusers/GRAPHGROUP.TEDIT new file mode 100644 index 00000000..6f39abc4 Binary files /dev/null and b/lispusers/GRAPHGROUP.TEDIT differ diff --git a/lispusers/GREP b/lispusers/GREP new file mode 100644 index 00000000..be516181 --- /dev/null +++ b/lispusers/GREP @@ -0,0 +1 @@ +(FILECREATED "14-May-86 08:04:43" {DSK}GREP.;1 2502 changes to: (FNS DOGREP) previous date: " 5-Mar-86 12:15:18" {DANTE}LISPUSERS>GREP.;1) (* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT GREPCOMS) (RPAQQ GREPCOMS ((FNS DOGREP GREP PHONE) (FILES BSEARCH) (INITVARS (PHONELISTFILES)))) (DEFINEQ (DOGREP [LAMBDA (STR FILES) (* Newman "14-May-86 08:04") (* * Originally coded by Larry Masinter.) (* * No longer permanently modifies the DSPFONT when DSPFONT is not the same as the DEFAULTFONT. -DVN "14-May-86 08:03:59") (if (LISTP FILES) then (for FILE in FILES do (DOGREP STRS FILE)) elseif (STRPOS "*" FILES) then (DOGREP STRS (DIRECTORY FILES NIL "*" "")) else (RESETLST (INFILE FILES) (RESETSAVE NIL (LIST (QUOTE CLOSEF?) (INPUT))) (RESETSAVE NIL (LIST (QUOTE DSPFONT) (DSPFONT))) (bind FOUND for STR inside STRS do (SETFILEPTR NIL 0) (bind POS while (SETQ POS (FFILEPOS STR NIL NIL NIL NIL NIL UPPERCASEARRAY)) do (OR FOUND (PROGN (PRINTOUT NIL T .FONT COMMENTFONT "(from " (INPUT) ")" .FONT DEFAULTFONT) (SETQ FOUND T))) (COPYCHARS NIL T (OR (BFILEPOS [CONSTANT (MKSTRING (CHARACTER (CHARCODE CR] (INPUT) 0 POS) 0) POS) (DSPFONT BOLDFONT) [COPYCHARS NIL T POS (SETQ POS (IPLUS POS (NCHARS STR] (DSPFONT DEFAULTFONT) (COPYCHARS NIL T POS (ADD1 (FILEPOS (CHARACTER (CHARCODE CR)) NIL POS]) (GREP (LAMBDA (STRS FILES) (* lmm " 1-Apr-85 15:27") (RESETLST (DOGREP STRS FILES)))) (PHONE [LAMBDA (NAME) (* lmm " 5-Mar-86 12:14") (GREP NAME (OR PHONELISTFILES (PROMPTFORWORD "Name of directory file: "]) ) (FILESLOAD BSEARCH) (RPAQ? PHONELISTFILES ) (PUTPROPS GREP COPYRIGHT ("Xerox Corporation" 1984 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (392 2368 (DOGREP 402 . 2000) (GREP 2002 . 2091) (PHONE 2093 . 2366))))) STOP \ No newline at end of file diff --git a/lispusers/GREP.TEDIT b/lispusers/GREP.TEDIT new file mode 100644 index 00000000..8312fdad Binary files /dev/null and b/lispusers/GREP.TEDIT differ diff --git a/lispusers/GRID-ICONS b/lispusers/GRID-ICONS new file mode 100644 index 00000000..41af1f53 --- /dev/null +++ b/lispusers/GRID-ICONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP") (FILECREATED "22-Nov-88 14:03:08" |{EG:PARC:XEROX}LISP>USERS>GRID-ICONS.;14| 27616 changes to%: (VARS GRID-ICONSCOMS) (FNS ICONW.MOVEFN LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN) previous date%: "29-Sep-88 13:43:56" |{EG:PARC:XEROX}LISP>USERS>GRID-ICONS.;13|) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT GRID-ICONSCOMS) (RPAQQ GRID-ICONSCOMS ((* ;;; "For laying out icons on a grid") (FNS ICONW.MOVEFN \ENSURE.ICON.GRID \TRIM-ICON-FILE-TITLE GRID-WINDOW) (INITVARS (ENFORCE.ICON.GRID NIL) (ENFORCE.ICON.REGIONS NIL) (ICON.SPACING (QUOTE (5 . 5))) (ICON.SIZE (QUOTE (85 . 85))) (GRID.OFFSET (QUOTE (0 . 0)))) (GLOBALVARS ENFORCE.ICON.GRID ICON.SPACING ICON.SIZE GRID.OFFSET) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADVISE ICONW TITLEDICONW)) (* ;;; "Defining some nice Viewpoint-ish icons") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (* ;; "Redefine the Lafite folder icon, making them a bit smaller") (VARS MSGFOLDERICON MSGFOLDERMASK (MSGFOLDERTEMPLATE (create TITLEDICON ICON _ MSGFOLDERICON MASK _ MSGFOLDERMASK TITLEREG _ (CREATEREGION 5 2 65 35)))) (* ;; "And, for the new improved Lafite:") (VARS (LAFITE.FOLDER.ICON MSGFOLDERTEMPLATE))) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (* ;; "Redefine the Tedit icon, making it cuter and smaller") (P (if (GETD (QUOTE TEDIT)) then (ADVISE (QUOTE (TEXTSTREAM.TITLE IN \TEDIT.SHRINK.ICONCREATE)) (QUOTE AFTER) (QUOTE (SETQ !VALUE (\TRIM-ICON-FILE-TITLE !VALUE)))))) (VARS TEDIT.ICON TEDIT.MASK (TEDIT.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ TEDIT.ICON MASK _ TEDIT.MASK TITLEREG _ (CREATEREGION 5 2 50 30))))) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (* ;; "Redefine the SEdit icon, making it smaller and cuter") (VARS SEDITICON SEDITICONMASK) (P (SET (if (CL:FIND-PACKAGE "SEDIT") then (CL:INTERN "TITLED-ICON" (CL:FIND-PACKAGE "SEDIT")) else (QUOTE \\titled.icon)) (create TITLEDICON ICON _ SEDITICON MASK _ SEDITICONMASK TITLEREG _ (CREATEREGION 5 5 50 65))))) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (* ;; "Redefine the Sketch icon, making it cuter and smaller") (P (if (GETD (QUOTE SKETCH)) then (ADVISE (QUOTE (SKETCH.TITLE IN SK.SHRINK.ICONCREATE)) (QUOTE AFTER) (QUOTE (SETQ !VALUE (\TRIM-ICON-FILE-TITLE !VALUE)))))) (VARS SKETCH.ICON SKETCH.MASK (SKETCH.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ SKETCH.ICON MASK _ SKETCH.MASK TITLEREG _ (CREATEREGION 5 2 50 30))))) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (* ;; "Make SPY icons appear on the grid") (P (if (GETD (QUOTE SPY.BUTTON)) then (ADVISE (QUOTE SPY.BUTTON) (QUOTE AFTER) (QUOTE (GRID-WINDOW (OR !VALUE SPY.BUTTON))))))) (COMS (* ;; "Define a nice icon for accessing the list of loaded files") (FNS LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (VARS LOADED-FILES-ICON LOADED-FILES-ICON-MASK (LOADED-FILES-ICON-WINDOW (LET ((W (TITLEDICONW (create TITLEDICON ICON _ LOADED-FILES-ICON MASK _ LOADED-FILES-ICON-MASK TITLEREG _ (CREATEREGION 7 9 55 10)) "Lisp files" NIL (CREATEPOSITION 0 0) T (QUOTE BOTTOM)))) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (QUOTE LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN)) W))))) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (* ;; "Define the standard icon, using the new Lyric feature") (VARS STANDARD-ICON STANDARD-ICON-MASK (DEFAULTTEXTICON (create TITLEDICON ICON _ STANDARD-ICON MASK _ STANDARD-ICON-MASK TITLEREG _ (CREATEREGION 5 5 50 60))) (DEFAULTICONFN (QUOTE TEXTICON)))) (* ;;; "") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT GRID-ICONS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN))))) (* ;;; "For laying out icons on a grid") (DEFINEQ (ICONW.MOVEFN (LAMBDA (ICON POS) (* ; "Edited 26-Jan-88 09:34 by smL") (* ;;; "Make sure the icon gets moved on a grid") (LET ((ICON.WIDTH (fetch (REGION WIDTH) of (WINDOWPROP ICON (QUOTE REGION)))) (ICON.HEIGHT (fetch (REGION HEIGHT) of (WINDOWPROP ICON (QUOTE REGION))))) (COND ((OR (NOT ENFORCE.ICON.GRID) (WINDOWPROP ICON (QUOTE IGNORE.ICON.GRID))) POS) ((OR (GREATERP (fetch (POSITION XCOORD) of POS) SCREENWIDTH) (LESSP (PLUS (fetch (POSITION XCOORD) of POS) ICON.WIDTH) 0) (GREATERP (fetch (POSITION YCOORD) of POS) SCREENHEIGHT) (LESSP (PLUS (fetch (POSITION YCOORD) of POS) ICON.HEIGHT) 0)) (* ; "Must be a deliberate attempt to move the icon off the screen, since the end result isn't visible. In that case, let them move it.") POS) (T (* ; "Compute the grid location for the icon, being careful not to push the icon (accidentally) off the screen") (LET* ((ICON.CENTER.X (PLUS (fetch (POSITION XCOORD) of POS) (QUOTIENT ICON.WIDTH 2))) (ICON.CENTER.Y (PLUS (fetch (POSITION YCOORD) of POS) (QUOTIENT ICON.HEIGHT 2))) (GRID.X.SIZE (PLUS (CAR ICON.SIZE) (CAR ICON.SPACING))) (GRID.Y.SIZE (PLUS (CDR ICON.SIZE) (CDR ICON.SPACING))) (GRID.X.OFFSET (CAR GRID.OFFSET)) (GRID.Y.OFFSET (CDR GRID.OFFSET)) (ICON.GRID.X (MAX 0 (QUOTIENT (MIN (DIFFERENCE ICON.CENTER.X GRID.X.OFFSET) SCREENWIDTH) GRID.X.SIZE))) (ICON.GRID.Y (MAX 0 (QUOTIENT (MIN (DIFFERENCE ICON.CENTER.Y GRID.Y.OFFSET) SCREENHEIGHT) GRID.Y.SIZE)))) (if (OR (NULL ENFORCE.ICON.REGIONS) (for REGION in ENFORCE.ICON.REGIONS thereis (INSIDE? REGION ICON.CENTER.X ICON.CENTER.Y))) then (create POSITION XCOORD _ (PLUS (TIMES GRID.X.SIZE ICON.GRID.X) (QUOTIENT (CAR ICON.SPACING) 2) (QUOTIENT (DIFFERENCE (CAR ICON.SIZE) ICON.WIDTH) 2) GRID.X.OFFSET) YCOORD _ (PLUS (TIMES GRID.Y.SIZE ICON.GRID.Y) (QUOTIENT (CDR ICON.SPACING) 2) (QUOTIENT (DIFFERENCE (CDR ICON.SIZE) ICON.HEIGHT) 2) GRID.Y.OFFSET)) else POS)))))) ) (\ENSURE.ICON.GRID (LAMBDA (W) (* smL "17-Apr-87 15:43") (LET ((OPENP (OPENWP W))) (MOVEW W (ICONW.MOVEFN W (create POSITION XCOORD _ (fetch LEFT of (WINDOWPROP W 'REGION)) YCOORD _ (fetch BOTTOM of (WINDOWPROP W 'REGION))))) (if (NOT OPENP) then (CLOSEW W))))) (\TRIM-ICON-FILE-TITLE (LAMBDA (TITLE) (* ; "Edited 12-Jan-88 11:41 by smL") (if (AND TITLE (OR (STRINGP TITLE) (LITATOM TITLE))) then (PACKFILENAME.STRING 'NAME (FILENAMEFIELD TITLE 'NAME) 'EXTENSION (FILENAMEFIELD TITLE 'EXTENSION)) else TITLE))) (GRID-WINDOW (LAMBDA (W) (* ; "Edited 14-Sep-87 10:14 by smL") (COND ((WINDOWP W) (WINDOWADDPROP W 'MOVEFN 'ICONW.MOVEFN) (\ENSURE.ICON.GRID W))))) ) (RPAQ? ENFORCE.ICON.GRID NIL) (RPAQ? ENFORCE.ICON.REGIONS NIL) (RPAQ? ICON.SPACING (QUOTE (5 . 5))) (RPAQ? ICON.SIZE (QUOTE (85 . 85))) (RPAQ? GRID.OFFSET (QUOTE (0 . 0))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ENFORCE.ICON.GRID ICON.SPACING ICON.SIZE GRID.OFFSET) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (XCL:REINSTALL-ADVICE (QUOTE ICONW) :AFTER (QUOTE ((:LAST (GRID-WINDOW !VALUE))))) (XCL:REINSTALL-ADVICE (QUOTE TITLEDICONW) :AFTER (QUOTE ((:LAST (GRID-WINDOW !VALUE))))) (READVISE ICONW TITLEDICONW) ) (* ;;; "Defining some nice Viewpoint-ish icons") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (RPAQQ MSGFOLDERICON #*(75 55)COOOON@@@@@@@@@@@@@@GOOOOO@@@@@@@@@@@@@@N@@@@CH@@@@@@@@@@@@@L@@@@AH@@@@@@@@@@@@@L@@@@AOOOOOOOOOOOOL@L@@@@AOOOOOOOOOOOOL@L@@@@@@@@@@@@@@@@@N@OOOOOOOOOOOOOOOOOON@L@@@@@@@@@@@@@@@@@F@LMJFG@@@@@@@@@@@ONF@LKNOJ@@@@@@@@@COHBF@L@@@@@@@@@@@@@@@HBF@LOFIJ@@@@@@@@@@@HBF@LCKGB@@@@@@@@@COHBF@L@@@@@@@@@@@@@@@HBF@LIMFJ@@@@@@@@@@@HBF@LMFMJ@@@@@@@@@COHBF@L@@@@@@@@@@@@@@@ONF@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@L@@@@@@@@@@@@@@@@@F@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@) (RPAQQ MSGFOLDERMASK #*(75 55)COOOON@@@@@@@@@@@@@@GOOOOO@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOL@OOOOOOOOOOOOOOOOOOL@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@) (RPAQ MSGFOLDERTEMPLATE (create TITLEDICON ICON _ MSGFOLDERICON MASK _ MSGFOLDERMASK TITLEREG _ (CREATEREGION 5 2 65 35))) (RPAQ LAFITE.FOLDER.ICON MSGFOLDERTEMPLATE) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (if (GETD (QUOTE TEDIT)) then (ADVISE (QUOTE (TEXTSTREAM.TITLE IN \TEDIT.SHRINK.ICONCREATE)) (QUOTE AFTER) (QUOTE (SETQ !VALUE (\TRIM-ICON-FILE-TITLE !VALUE))))) (RPAQQ TEDIT.ICON #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@CNGOCOONA@L@@L@@CNGOCOONA@F@@L@@@@@@@@@@A@C@@L@@@@@@@@@@A@AH@L@@@@@@@@@@A@@L@L@@@@@@@@@@A@@F@L@@@@@@@@@@AOOO@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@OOMNOOOMOGKHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LGKNOOOGOOGOOHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LFOONOOKOOMOOHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LGNOOOL@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@OMOOOGOMOOOHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LGOOMNOOONMOOHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LGKOOOKNOONOOHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LGNOOOMOOKONOHC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@LGOMOOOGOOH@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQQ TEDIT.MASK #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQ TEDIT.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ TEDIT.ICON MASK _ TEDIT.MASK TITLEREG _ (CREATEREGION 5 2 50 30))) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (RPAQQ SEDITICON #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@LB@@@@@@@@@AC@@@LD@@@@@@@@@AAH@@LD@@@@@@@@@A@L@@LH@@@@@@@@@A@F@@LH@@@@@@@@@A@C@@LH@@@@@@@@@A@AH@LH@@@@@@@@@A@@L@LH@@@@@@@@@A@@F@LDDI@@@@@@@AOOO@LD@@@@@@@@@@@@C@LB@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@DC@L@@@@@@@@@@@@BC@L@@@@@@@@@@@@BC@L@@@@@@@@@@@@AC@L@@@@@@@@@@@@AC@L@@@@@@@@@@@@AC@L@@@@@@@@@@@@AC@L@@@@@@@@@@@@AC@L@@@@@@@@@@IBBC@L@@@@@@@@@@@@BC@L@@@@@@@@@@@@DC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQQ SEDITICONMASK #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (SET (if (CL:FIND-PACKAGE "SEDIT") then (CL:INTERN "TITLED-ICON" (CL:FIND-PACKAGE "SEDIT")) else (QUOTE \\titled.icon)) (create TITLEDICON ICON _ SEDITICON MASK _ SEDITICONMASK TITLEREG _ (CREATEREGION 5 5 50 65))) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (if (GETD (QUOTE SKETCH)) then (ADVISE (QUOTE (SKETCH.TITLE IN SK.SHRINK.ICONCREATE)) (QUOTE AFTER) (QUOTE (SETQ !VALUE (\TRIM-ICON-FILE-TITLE !VALUE))))) (RPAQQ SKETCH.ICON #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@LAOOOOOOOH@AAH@@LA@@@@@@@H@A@L@@LA@@@H@@@H@A@F@@LA@L@H@@@H@A@C@@LA@B@NCBHH@A@AH@LA@N@IDI@H@A@@L@LAAB@IDI@H@A@@F@LA@N@NCBHH@AOOO@LA@@@@@@@H@@@@C@LAOOOOOOOH@@@@C@L@@@B@@@@@@@@@C@L@@@B@@@@@@@@@C@L@@@D@@@@@@@@@C@L@@@D@@@@@@@@@C@L@@@H@@@@@@@@@C@L@@@H@@@@@@@@@C@L@@@H@@@@@@@@@C@L@@@H@@@@@@@@@C@L@@@H@@@@@@@@@C@L@@@H@@@@@@@@@C@L@@@D@@@@@@@@@C@L@@@D@@@@@@@@@C@L@@@B@@@@AN@@@C@L@@@A@@@@FAH@@C@L@@@@H@@AH@F@@C@L@@@@F@DB@@A@@C@L@@@@ALBD@@@H@C@L@@@@@CMD@@@H@C@L@@@@@@CH@@@D@C@L@@@@@@FH@@@D@C@L@@@@@@I@@@@B@C@L@@@@@@A@@@@B@C@L@@@@@@A@@@@B@C@L@@@@@@A@@@@B@C@L@@@@@@@H@@@D@C@L@@@@@@@H@@@D@C@L@@@@@@@D@@@H@C@L@@@@@@@D@@@H@C@L@@@@@@@B@@A@@C@L@@@@@@@AH@F@@C@L@@@@@@@@FAH@@C@L@@@@@@@@AN@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQQ SKETCH.MASK #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQ SKETCH.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ SKETCH.ICON MASK _ SKETCH.MASK TITLEREG _ (CREATEREGION 5 2 50 30))) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (if (GETD (QUOTE SPY.BUTTON)) then (ADVISE (QUOTE SPY.BUTTON) (QUOTE AFTER) (QUOTE (GRID-WINDOW (OR !VALUE SPY.BUTTON))))) ) (* ;; "Define a nice icon for accessing the list of loaded files") (DEFINEQ (LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN (CL:LAMBDA (W) (* ; "Edited 22-Nov-88 13:57 by smL") (DECLARE (GLOBAL FILELST)) (LET ((NEW-FILE-ITEM "* New file *") (NOTICE-FILE-ITEM "* Sysloaded file *")) (CL:LABELS ((LOADED-FILES NIL "Return a sorted list of names of known loaded files" (SORT (COPY FILELST))) (HIDDEN-FILES NIL "Return a sorted list of names of hidden loaded files" (DECLARE (GLOBALVARS LOADEDFILELST)) (SORT (LDIFFERENCE (for FILE in LOADEDFILELST bind ROOT-NAME eachtime (SETQ ROOT-NAME (FILENAMEFIELD FILE (QUOTE NAME))) until (EQ ROOT-NAME (QUOTE INIT)) when (GET ROOT-NAME (QUOTE FILEDATES)) collect ROOT-NAME) FILELST))) (EDIT-FILECOMS (FILE-NAME) "Edit the filecoms of a file" (ED FILE-NAME (QUOTE (FILES :DONTWAIT :DISPLAY)))) (NOTICE-AND-EDIT-FILE (ITEM MENU BUTTON) "Notice a file and then edit its filecoms" (LET ((FILE (FILENAMEFIELD ITEM (QUOTE NAME)))) (COND ((NULL FILE) NIL) ((NULL (NLSETQ (LOAD FILE (QUOTE PROP)))) (PROMPTPRINT "Error attempting to Notice the file " FILE)) (T (EDIT-FILECOMS FILE))))) (PRINT-FILE-MENU-HELP (ITEM MENU BUTTON) (COND ((NULL ITEM) NIL) ((EQ ITEM NEW-FILE-ITEM) (PROMPTPRINT "Add a new file and edit its filecoms")) ((EQ ITEM NOTICE-FILE-ITEM) (PROMPTPRINT "Prompt for a sysloaded file, Notice its contents, and then edit its filecoms")) (T (PROMPTPRINT "Edit the filecoms of file " ITEM)))) (MENU-ITEM-SELECTED (ITEM MENU BUTTON) (COND ((NULL ITEM) NIL) ((EQ ITEM NEW-FILE-ITEM) (LET ((FILE-NAME (PROGN (CLEARW PROMPTWINDOW) (PROMPTFORWORD "Name of new file (CR to abort): " NIL NIL PROMPTWINDOW NIL T (LIST (CHARCODE EOL)))))) (if FILE-NAME then (SETQ FILE-NAME (U-CASE (MKATOM FILE-NAME))) (SET (FILECOMS FILE-NAME) (BQUOTE (((\, COMMENTFLG) ;;; (\, (CONCAT "New file"))) (DECLARE%: DONTCOPY (PROPS ((\, FILE-NAME) MAKEFILE-ENVIRONMENT) ((\, FILE-NAME) FILETYPE)))))) (PUTPROP FILE-NAME (QUOTE MAKEFILE-ENVIRONMENT) (CL:COPY-TREE *DEFAULT-MAKEFILE-ENVIRONMENT*)) (PUTPROP FILE-NAME (QUOTE FILETYPE) (SELECTQ *DEFAULT-CLEANUP-COMPILER* (TCOMPL :TCOMPL) (BCOMPL :BCOMPL) :COMPILE-FILE)) (ADDFILE FILE-NAME) (EDIT-FILECOMS FILE-NAME) else (PROMPTPRINT "No file added")))) ((EQ ITEM NOTICE-FILE-ITEM) (LET ((HIDDEN-FILES (HIDDEN-FILES))) (IF HIDDEN-FILES then (MENU (create MENU ITEMS _ HIDDEN-FILES TITLE _ "Notice which sysloaded file?" WHENHELDFN _ (CL:FUNCTION (LAMBDA (ITEM MENU BUTTON) (COND (ITEM (PROMPTPRINT "Load-PROP the file " ITEM " and then edit its COMS"))))) WHENSELECTEDFN _ (CL:FUNCTION NOTICE-AND-EDIT-FILE))) else (PROMPTPRINT "No hidden files")))) (T (EDIT-FILECOMS (FILENAMEFIELD ITEM (QUOTE NAME))))))) (COND ((MOUSESTATE LEFT) (MOVEW W)) ((MOUSESTATE MIDDLE) (MENU (create MENU ITEMS _ (BQUOTE ((\,. (LOADED-FILES)) (\, NEW-FILE-ITEM) (\, NOTICE-FILE-ITEM))) TITLE _ "Edit COMS of which file?" WHENHELDFN _ (CL:FUNCTION PRINT-FILE-MENU-HELP) WHENSELECTEDFN _ (CL:FUNCTION MENU-ITEM-SELECTED)))))))) ) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (RPAQQ LOADED-FILES-ICON #*(72 72)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@CL@@@@@@@@@@@@@AN@@@CHA@B@@@@@@@@@@@N@@@CHB@DCNDDG@@@@@@N@@@CHB@DB@FDHH@@@@@N@@@CHD@HB@FDHH@@@@@N@@@CHD@HCLEDF@@@@@@N@@@CHD@HB@EDA@@@@@@N@@@CHD@HB@DLHH@@@@@N@@@CHD@HB@DLHH@@@@@N@@@CHB@DB@DDG@D@HA@N@@@CHB@D@@@@@@@@@@@N@@@CHA@B@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CHAOOOOOOOO@@@@@N@@@CHAOOOOOOOO@@@@@N@@@CHAH@@@@@@C@@@@@N@@@CHAH@@@@@@C@@@@@N@@@CHAOOOOOOOO@@@@@N@@@CHAL@@@@@@G@@@@@N@@@CH@N@@@@@@N@@@@@N@@@CH@G@@@@@AL@@@@@N@@@CH@CH@@@@CH@@@@@N@@@CH@AL@@@@G@@@@@@N@@@CH@@N@@@@N@@@@@@N@@@CH@@G@@@AL@@@@@@N@@@CH@@CH@@CH@@@@@@N@@@CH@@AL@@G@@@@@@@N@@@CH@@@N@@N@@@@@@@N@@@CH@@@G@AL@@@@@@@N@@@CH@@@CHCH@@@@@@@N@@@CH@@@ALG@@@@@@@@N@@@CH@@@@LF@@@@@@@@N@@@CH@@@@LF@@@@@@@@N@@@CH@@@@LF@@@@@@@@N@@@CH@@@@LF@@@@@@@@N@@@CH@@@@LF@@@@@@@@N@@@CH@@@@LF@@@@@@@@N@@@CH@@@@ON@@@@@@@@N@@@CH@@@@GL@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CH@@@@@@@@@@@@@@N@@@CL@@@@@@@@@@@@@AN@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@OOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) (RPAQQ LOADED-FILES-ICON-MASK #*(72 72)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@OOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) (RPAQ LOADED-FILES-ICON-WINDOW (LET ((W (TITLEDICONW (create TITLEDICON ICON _ LOADED-FILES-ICON MASK _ LOADED-FILES-ICON-MASK TITLEREG _ (CREATEREGION 7 9 55 10)) "Lisp files" NIL (CREATEPOSITION 0 0) T (QUOTE BOTTOM)))) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (QUOTE LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN)) W)) ) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (RPAQQ STANDARD-ICON #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@@@@@@@@@A@L@@L@@@@@@@@@@A@F@@L@@@@@@@@@@A@C@@L@@@@@@@@@@A@AH@L@@@@@@@@@@A@@L@L@@@@@@@@@@A@@F@L@@@@@@@@@@AOOO@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQQ STANDARD-ICON-MASK #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@) (RPAQ DEFAULTTEXTICON (create TITLEDICON ICON _ STANDARD-ICON MASK _ STANDARD-ICON-MASK TITLEREG _ (CREATEREGION 5 5 50 60))) (RPAQQ DEFAULTICONFN TEXTICON) ) (* ;;; "") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PUTPROPS GRID-ICONS MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP")) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN) ) (PUTPROPS GRID-ICONS COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3792 6715 (ICONW.MOVEFN 3802 . 5681) (\ENSURE.ICON.GRID 5683 . 6110) ( \TRIM-ICON-FILE-TITLE 6112 . 6487) (GRID-WINDOW 6489 . 6713)) (18334 21229 ( LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN 18344 . 21227))))) STOP \ No newline at end of file diff --git a/lispusers/GRID-ICONS.TEDIT b/lispusers/GRID-ICONS.TEDIT new file mode 100644 index 00000000..a4218fce Binary files /dev/null and b/lispusers/GRID-ICONS.TEDIT differ diff --git a/lispusers/GraphGroup b/lispusers/GraphGroup new file mode 100644 index 00000000..bf2a43ad --- /dev/null +++ b/lispusers/GraphGroup @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Dec-88 19:28:09" {ERINYES}MEDLEY>GRAPHGROUP.;2 8791 changes to%: (FNS GraphGroup \GraphGroupGVisNSP \GraphGroupReadNSEntry \GraphGroupAux \GraphGroupReadFn \GraphGroupReadMapping) previous date%: " 8-Jul-88 11:10:20" {ERINYES}LYRIC>GRAPHGROUP.;2) (* " Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT GRAPHGROUPCOMS) (RPAQQ GRAPHGROUPCOMS ((VARS \GraphGroupGVtoNSRegistryMapping \NAMETYPE.NSGROUP \NAMETYPE.NSINDIVIDUAL) (FNS GraphGroup \GraphGroupGVisNSP \GraphGroupReadNSEntry) (FILES GRAPEVINE MAINTAIN) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAINTAIN) (MACROS \WIN)) (FNS \GraphGroupAux \GraphGroupReadFn \GraphGroupReadMapping))) (RPAQQ \GraphGroupGVtoNSRegistryMapping ((ALLAREAS . "ALL AREAS:XEROX") (AYLRX . "AYL:RX") (AYLTSDRX . "AYLTSD:RX") (BRIDGEHOUSERXUK . "BRIDGE HOUSE:RXUK") (BROOKRIVER . "BROOKRIVER:XEROX") (BUSRX . "BUS:RX") (CB19RXF . "CB19:RXF") (CINOPS . "CIN OPS:XEROX") (DLOSCE . "DLOSCE:XEROX") (DLOSCSS . "DLOSCSS:XEROX") (DLOSETRON . "DLOSETRON:XEROX") (DLOSL300 . "DLOSL300:XEROX") (DLOSLC . "DLOSLC:XEROX") (DLOSLV . "DLOSLV:XEROX") (DLOSLV-COMM . "DLOSLV-COMM:XEROX") (DLOSNSC . "DLOSNSC:XEROX") (DTSSIEMENS . "DTS:SIEMENS") (EDSERVICES . "EDSERVICES:LEESBURG") (EIS . "EIS:VERSATEC") (ELSEGUNDO . "EL SEGUNDO:XEROX") (ESAREA . "ES AREA:XEROX") (ESCP8 . "ES CP8:XEROX") (ESGSDWCO . "ES GSD/WCO:XEROX") (ESM4RED . "ES M4 RED:XEROX") (ESPOORXSF . "ESPOO:RXSF") (ESXC15 . "ES XC15:XEROX") (ESXC16 . "ES XC16:XEROX") (ESXCOST . "ES XC OST:XEROX") (HENR801G . "HENR801G:XEROX") (HKRXS . "HK:RXS") (IHAIL . "IH:AIL") (IWAFX . "IWA:FUJI XEROX") (NSC . "NSC:XEROX") (NSC-50 . "NSC-5.0:XEROX") (OSBUBAYSHORE . "OSBU BAYSHORE:XEROX") (OSBUNORTH . "OSBU NORTH:XEROX") (OSBURX . "OSBU:RX") (OSBUSOUTH . "OSBU SOUTH:XEROX") (OSDASSOCIATES . "OSD ASSOCIATES:XEROX") (OSSERVICE . "OS SERVICE:XEROX") (PAAREA . "PA AREA:XEROX") (PARC . "PARC:XEROX") (PARC-MES . "PARC-MES:XEROX") (PAVISITORS . "VISITORS PA:XEROX VISITORS") (PQANET1 . "PQANET1:XEROX") (PQANET2 . "PQANET2:XEROX") (PQANET3 . "PQANET3:XEROX") (RDES . "RDES:VERSATEC") (ROCH . "ROCH:XEROX") (ROCH805 . "ROCH805:XEROX") (ROCH888 . "ROCH888:XEROX") (RXH . "RXH:RX") (RXHRX . "RXH:RX") (SANDIEGOXCSS . "SAN DIEGO:XCSS") (SBDERX . "SBD-E:RX") (SBDRXN . "SBD:RXN") (SHINJUKUMIZUNOFX . "SHINJUKU MIZUNO:FUJI XEROX") (SOLNAMORXS . "SOLNA-MO:RXS") (STHQ . "STHQ:XEROX") (SUNNYVALE . "SUNNYVALE:XEROX") (TESTLABORPNIDSIEMENS . "TESTLABOR PN ID:SIEMENS") (TORHO . "TOR HO:XCI") (TSC . "TSC:XEROX") (VEN1RX . "VEN1:RX") (VISTA . "VISTA:XEROX") (WBST102A . "WBST102A:XEROX") (WBST105 . "WBST105:XEROX") (WBST105B . "WBST105B:XEROX") (WBST114 . "WBST114:XEROX") (WBST128 . "WBST128:XEROX") (WBST129 . "WBST129:XEROX") (WBST129UL . "WBST129UL:XEROX") (WBST139 . "WBST139:XEROX") (WBST147 . "WBST147:XEROX") (WBST207V . "WBST207V:XEROX") (WBST311 . "WBST311:XEROX") (WBSTAREA . "WBST AREA:XEROX") (WGCERX . "WGC-E:RX") (WNDC . "WNDC:XEROX") (XRCC-NS . "XRCC:XEROX") (XSIS . "XSIS:XEROX") (XSISHQ . "XSIS-HQ:XEROX") (ZTISOFSIEMENS . "ZTISOF:SIEMENS") (ZURICHRXCH . "ZURICH:RXCH"))) (RPAQQ \NAMETYPE.NSGROUP 3) (RPAQQ \NAMETYPE.NSINDIVIDUAL 2) (DEFINEQ (GraphGroup (LAMBDA (Group InfoStream LayoutOptions ExpandNSGroups IgnoreForwarding) (* ; "Edited 13-Dec-88 19:09 by Briggs") (LET ((Entry (GV.READENTRY Group NIL (FUNCTION \GraphGroupReadFn))) GroupStructure) (SETQ GroupStructure (\GraphGroupAux Entry InfoStream ExpandNSGroups IgnoreForwarding)) (SHOWGRAPH (LAYOUTSEXPR GroupStructure (LISTGET LayoutOptions (QUOTE FORMAT)) (LISTGET LayoutOptions (QUOTE BOXING)) (OR (LISTGET LayoutOptions (QUOTE FONT)) (FONTCREATE (QUOTE CLASSIC) 10)) (LISTGET LayoutOptions (QUOTE MOTHERD)) (LISTGET LayoutOptions (QUOTE PERSONALD)) (LISTGET LayoutOptions (QUOTE FAMILYD)))) (AND InfoStream (FRESHLINE InfoStream)) GroupStructure)) ) (\GraphGroupGVisNSP (LAMBDA (Address) (* N.H.Briggs "17-Aug-86 16:42") (* determine if a name returned by Grapevine is in fact an NS name) (LET ((GVAddress (\GV.PARSERECIPIENTS1 Address DEFAULTREGISTRY T))) (if (SETQ DomainAndOrganization (CDR (FASSOC (U-CASE (CDAR GVAddress)) \GraphGroupGVtoNSRegistryMapping))) then (CONCAT (CAAR GVAddress) ":" DomainAndOrganization)))) ) (\GraphGroupReadNSEntry (LAMBDA (Address) (* N.H.Briggs "17-Aug-86 16:33") (LET ((Properties (CAR (NLSETQ (CH.LIST.PROPERTIES Address))))) (if (MEMB 3 (CADR Properties)) then (* it's a group) (LIST \NAMETYPE.NSGROUP (CAR Properties)) elseif (MEMB 10003 (CADR Properties)) then (* it's an individual) (LIST \NAMETYPE.NSINDIVIDUAL (CAR Properties))))) ) ) (FILESLOAD GRAPEVINE MAINTAIN) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) MAINTAIN) (DECLARE%: EVAL@COMPILE (PUTPROPS \WIN MACRO ((Stream) (LOGOR (LSH (\BIN Stream) 8) (\BIN Stream)))) ) ) (DEFINEQ (\GraphGroupAux (LAMBDA (Entry InfoStream ExpandNSGroups IgnoreForwarding) (* ; "Edited 13-Dec-88 19:27 by Briggs") (SELECTC (CAR Entry) (\NAMETYPE.INDIVIDUAL (AND InfoStream (printout InfoStream ".")) (if (OR (NULL (CDDR Entry)) IgnoreForwarding) then (MKATOM (CADR Entry)) elseif (STRING-EQUAL (CADDR Entry) "NoMailboxes.ms") then (LIST (MKATOM (CADR Entry)) "-no mailbox-") else (* ; "there is forwarding") (LIST (MKATOM (CADR Entry)) (LET ((FwdEntry (GV.READENTRY (CADDR Entry) NIL (FUNCTION \GraphGroupReadFn)))) (if (EQ FwdEntry (QUOTE BadRName)) then (AND InfoStream (printout InfoStream "?")) (MKATOM (CADDR Entry)) else (\GraphGroupAux FwdEntry InfoStream NIL IgnoreForwarding)))))) (\NAMETYPE.NSINDIVIDUAL (AND InfoStream (printout InfoStream ".")) (* ; "isn't any forwarding in NS mail") (MKATOM (CADR Entry))) (\NAMETYPE.GROUP (LET ((Members (GV.READMEMBERS (CADR Entry)))) (AND InfoStream (printout InfoStream "[" (SUB1 (LENGTH Members)))) (PROG1 (CONS (CADR Entry) (for Member in Members when (NEQ (TYPENAME Member) (QUOTE TIMESTAMP)) collect (LET ((MemberEntry (GV.READENTRY Member NIL (FUNCTION \GraphGroupReadFn)))) (if (EQ MemberEntry (QUOTE BadRName)) then (if (AND ExpandNSGroups (SETQ MemberNSName (\GraphGroupGVisNSP Member)) (SETQ MemberNSEntry (\GraphGroupReadNSEntry MemberNSName))) then (\GraphGroupAux MemberNSEntry InfoStream ExpandNSGroups IgnoreForwarding) else (AND InfoStream (printout InfoStream "?")) (MKATOM Member)) else (\GraphGroupAux MemberEntry InfoStream ExpandNSGroups IgnoreForwarding))))) (AND InfoStream (printout InfoStream "]"))))) (\NAMETYPE.NSGROUP (LET ((Members (CH.RETRIEVE.MEMBERS (CADR Entry) (QUOTE MEMBERS)))) (AND InfoStream (printout InfoStream "[" (LENGTH Members))) (PROG1 (CONS (CADR Entry) (for Member in Members collect (LET ((MemberEntry (\GraphGroupReadNSEntry Member))) (if (NULL MemberEntry) then (AND InfoStream (printout InfoStream "?")) (MKATOM Member) else (\GraphGroupAux MemberEntry InfoStream ExpandNSGroups IgnoreForwarding))))) (AND InfoStream (printout InfoStream "]"))))) NIL)) ) (\GraphGroupReadFn (LAMBDA (Stream) (* N.H.Briggs "16-Jul-86 11:12") (LET (ComponentCount Result) (\RECEIVESTAMP Stream T) (* Skip stamp) (SETQ ComponentCount (\WIN Stream)) (* There is a database entry. First component is the "prefix" %, which contains, among other things, the name's type and its "official" name) (\WIN Stream) (* Length of this component) (\RECEIVESTAMP Stream T) (* Skip stamp) (SETQ Result (LIST (\WIN Stream) (\RECEIVERNAME Stream))) (* return the component type and "official" name) (if (EQ (CAR Result) \NAMETYPE.INDIVIDUAL) then (* should pick up forwarding info) (\SKIPCOMPONENT Stream) (* password) (\SKIPCOMPONENT Stream) (* connect site) (if (NOT (ZEROP (\WIN Stream))) then (NCONC1 Result (\RECEIVESTRING Stream (\WIN Stream))) (* forwarding)) (to (IDIFFERENCE ComponentCount 4) do (\SKIPCOMPONENT Stream)) (* throw away the leftovers) else (* throw away the leftovers) (to (SUB1 ComponentCount) do (\SKIPCOMPONENT Stream))) Result)) ) (\GraphGroupReadMapping (LAMBDA NIL (* N.H.Briggs "14-Aug-86 23:14") (LET ((Stream (OPENSTREAM "{INDIGO}GV>GV-NS-MAPPING.TXT" (QUOTE INPUT))) (NoSpaceReadTable (COPYREADTABLE (QUOTE ORIG))) End) (SETSEPR (LIST (CHARCODE CR)) NIL NoSpaceReadTable) (SETBRK (LIST (CHARCODE CR)) NIL NoSpaceReadTable) (SETQ End (FILEPOS "NS-to-GV Mappings:" Stream 1 NIL NIL NIL (UPPERCASEARRAY))) (FILEPOS "GV-to-NS Mappings:" Stream 1 NIL NIL NIL (UPPERCASEARRAY)) (FILEPOS "." Stream NIL NIL NIL T) (until (GREATERP (GETFILEPTR Stream) End) collect (SETQ Registry (READ Stream)) (READ Stream) (SKIPSEPRS Stream) (SETQ DomainOrg (RSTRING Stream NoSpaceReadTable)) (FILEPOS "." Stream NIL NIL NIL T) (CONS Registry DomainOrg)))) ) ) (PUTPROPS GRAPHGROUP COPYRIGHT ("Xerox Corporation" 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3298 4723 (GraphGroup 3308 . 3983) (\GraphGroupGVisNSP 3985 . 4364) ( \GraphGroupReadNSEntry 4366 . 4721)) (4931 8704 (\GraphGroupAux 4941 . 7002) (\GraphGroupReadFn 7004 . 7974) (\GraphGroupReadMapping 7976 . 8702))))) STOP \ No newline at end of file diff --git a/lispusers/H-BLOCKS.HKB b/lispusers/H-BLOCKS.HKB new file mode 100644 index 00000000..310ad05b --- /dev/null +++ b/lispusers/H-BLOCKS.HKB @@ -0,0 +1 @@ +(FILECREATED " 6-Feb-87 10:18:07" {DSK}H.ALFA>BLOCKS.HKB;2 4571 changes to: (VARS *functions1* *predicates1* *variables1* *temp-foo* *temp-pred*) previous date: " 3-Nov-86 11:06:40" {DSK}H>BLOCKS.HKB;9) (PRETTYCOMPRINT BLOCKSCOMS) (RPAQQ BLOCKSCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)) (RPAQQ *functions1* (HRPRINT LISTMEMB MEMBER fail true noteq)) (RPAQQ *predicates1* (color-of showworld SPLIT putdown pickup please ART PREP GoOnNp PARTIC OPTPARTIC VP VERB NP1 NP NOM BLOCK on clear puton)) (RPAQQ *variables1* (:d :c :color :bl :a4 :a3 :a2 :a1 :e :q :s :m :string :e4 :e3 :e2 :e1 :rest1 :block2 :q4 :q3 :q2 :q1 :block1 :rest :block :oper :vf :b :a :w2 :w1 :x1 :y1 :u :r :v :z :i :h :j :l :w :y :x :k :p)) (RPAQQ *temp-foo* [[LAMBDA (y) (PRINTOUT T y T] [LAMBDA (x y) (PROG ((temp x)) loop (COND ((NULL temp) (RETURN T)) (T (COND ([OR (MEMBER (CAR temp) y) (EQ (CAR temp (QUOTE one] (SETQ temp (CDR temp)) (GO loop)) (T (RETURN NIL] [LAMBDA (x y) (MEMBER x y] [LAMBDA NIL NIL] [LAMBDA NIL T] (LAMBDA (x y) (NOT (EQ x y]) (RPAQQ *temp-pred* [(((color-of :block :color) < (BLOCK :block :color :a :b :c :d))) (((showworld) < (on :x :y) (HRPRINT (on :x :y)) (fail))) (((SPLIT (:a . :b) :a :b))) (((putdown :x) < (puton :x table))) (((pickup :x) < (puton :x hand))) (((please :string) < (VP :string))) (((ART the)) ((ART a)) ((ART an))) (((PREP on on))) (((GoOnNp (:x . :y) :v :rest) < (PREP :x :x1) (NP :y :v :rest))) (((PARTIC down)) ((PARTIC up)) ((PARTIC to))) (((OPTPARTIC NIL :x)) ((OPTPARTIC (:x . :y) :z) < (PARTIC :x))) (((VP (:x :y . :z)) < (VERB :x :vf :oper) (PARTIC :y) (MEMBER :y :vf) (NP :z :block NIL) (:oper :block)) ((VP (:x . :y)) < (VERB :x :vf :oper) (MEMBER one :vf) (NP :y :block :rest) (OPTPARTIC :rest :vf) (:oper :block)) ((VP (:x . :y)) < (VERB :x :vf :oper) (MEMBER two :vf) (NP :y :block1 :rest) (BLOCK :block1 :q1 :q2 :q3 :q4 stackable) (GoOnNp :rest :block2 :rest1) (BLOCK :block2 :e1 :e2 :e3 supportive :e4) (:oper :block1 :block2))) (((VERB pickup (one) pickup)) ((VERB pick (up one) pickup)) ((VERB put (two) puton)) ((VERB stack (two) puton)) ((VERB put (down one) putdown))) (((NP1 (:x :y . :z) :w :u :r) < (PREP :y :y1) (NOM :x :x1) (NP :z :v :r) (:y1 :w :v) (BLOCK . :w1) (LISTMEMB (:x1 . :u) :w1) (SPLIT :w1 :w :w2)) ((NP1 (:x . :y) :v :u :r) < (NOM :x :x1) (NP1 :y :v (:x1 . :u) :r)) ((NP1 (:x . :y) :w :u :y) < (NOM :x :x1) (BLOCK . :w1) (LISTMEMB (:x1 . :u) :w1) (SPLIT :w1 :w :w2))) (((NP (:x . :y) :v :r) < (ART :x) (NP1 :y :v NIL :r)) ((NP :x :v :r) < (NP1 :x :v NIL :r))) (((NOM red red)) ((NOM block cube)) ((NOM cube cube)) ((NOM cube1 cube1)) ((NOM cube2 cube2)) ((NOM cube3 cube3)) ((NOM big large)) ((NOM small small)) ((NOM blue blue)) ((NOM white white)) ((NOM green green)) ((NOM pyramid1 pyramid)) ((NOM pyramid pyramid)) ((NOM sphere sphere))) (((BLOCK pyramid1 white pyramid 3 NIL stackable)) ((BLOCK cube2 blue cube 5 supportive stackable)) ((BLOCK cube3 green cube 1 supportive stackable)) ((BLOCK cube1 red cube 10 supportive stackable)) ((BLOCK sphere black sphere 3 NIL stackable)) ((BLOCK table NIL NIL NIL supportive NIL)) ((BLOCK hand NIL NIL NIL supportive NIL))) (((on cube3 hand)) ((on sphere table)) ((on cube1 table)) ((on cube2 table)) ((on pyramid1 table))) (((clear table)) ((clear :x) < (on :y :x) (puton :y table)) ((clear :x))) (((puton :x :y) < (noteq :x table) (clear :x) (noteq :y pyramid) (noteq :y sphere) (clear :y) (on :x :w) (delete (on :x :w)) (assert (on :x :y]) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/H-CUT.HKB b/lispusers/H-CUT.HKB new file mode 100644 index 00000000..fe433e0f --- /dev/null +++ b/lispusers/H-CUT.HKB @@ -0,0 +1 @@ +(FILECREATED "10-Feb-87 17:00:26" {DSK}H.ALFA>CUT.HKB;1 545 ) (PRETTYCOMPRINT CUTCOMS) (RPAQQ CUTCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)) (RPAQQ *functions1* NIL) (RPAQQ *predicates1* (A-CUT C B A)) (RPAQQ *variables1* (:b :a :y :x)) (RPAQQ *temp-foo* NIL) (RPAQQ *temp-pred* [(((A-CUT :x :y) < (B :x) / (C :y))) (((C 3)) ((C 4))) (((B 1)) ((B 2))) (((A :x :y) < (B :x) (C :y]) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/H-ENV b/lispusers/H-ENV new file mode 100644 index 00000000..6eea7d36 --- /dev/null +++ b/lispusers/H-ENV @@ -0,0 +1 @@ +(FILECREATED "17-Mar-87 16:39:13" {DSK}H.BETA>HENV.;7 23674 changes to: (FNS H.NullW H.PrintInfo H.BUTTONFN HMenuFunction) (VARS HENVCOMS HMIDDLEMENU HMENUITEMS) previous date: "25-Feb-87 15:27:15" {DSK}H.BETA>HENV.;5) (PRETTYCOMPRINT HENVCOMS) (RPAQQ HENVCOMS [(VARS *temp-vars* HMENUITEMS HMIDDLEMENU HMenuItems) (FNS H H.BUTTONFN H.NullW H.PrintInfo H.delete H.editAxiom H.editSA H.erase H.load H.save HMenuFunction HReadProvePrint LoadHKB SaveHKB \DummyFoo \SEE.AT) (ADDVARS (BackgroundMenuCommands (H [QUOTE (ADD.PROCESS (QUOTE (H] "Open window on logic programming environment") )) (VARS (BackgroundMenu NIL)) (ADVICE LOAD) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML \SEE.AT) (LAMA]) (RPAQQ *temp-vars* NIL) (RPAQQ HMENUITEMS ((Dribble (QUOTE Dribble) "Dribble on file"))) (RPAQQ HMIDDLEMENU NIL) (RPAQQ HMenuItems (("Show Profile" (QUOTE SHOWPROFILE) "Show the profile of environment") ("Show(Axiom)" (QUOTE SHOWAXIOM) "Pretty-print axioms" (SUBITEMS ("Show SA" (QUOTE SHOWSA) "Pretty-print semantic attachment") ("Show Axiom" (QUOTE SHOWAXIOM) "Pretty-print axiom"))) ("Delete(Axiom)" (QUOTE DELETEAXIOM) "Erases axiom from database" (SUBITEMS ("Delete SA" (QUOTE DELETESA) "Erases semantic attachments from database") ("DeleteAxiom" (QUOTE DELETEAXIOM) "Erases axiom from database"))) ("Edit(Axiom)" (QUOTE EDITAXIOM) "Edit axioms" (SUBITEMS ("Edit SA" (QUOTE EDITSA) "Edit semantic attachment") ("EditAxiom" (QUOTE EDITAXIOM) "Edit axioms"))) (SetLimit (QUOTE SETLIMIT) "Set limit of depth-search tree") (Mode (QUOTE MODE) "Set mode of demonstration" (SUBITEMS (All (QUOTE ALL) "Search for all goals") (First (QUOTE FIRST) "Stop at first goal reached") (Interactive (QUOTE INTERACTIVE) "Ask user to go on"))) [Shortform (QUOTE SHORTFORM) "Perform the control of occurrence" (SUBITEMS (Yes (QUOTE YES)) (No (QUOTE NO] [Trace (QUOTE TRACE) "Trace demonstration" (SUBITEMS (Trace (QUOTE TRACE)) (NoTrace (QUOTE NOTRACE] ["Trace PM" (QUOTE TRACEPM) "Trace pattern matching" (SUBITEMS (Trace (QUOTE TRACEPM)) (NoTrace (QUOTE NOTRACEPM] (LoadHKB (QUOTE LOAD) "Load H knowledge base") (SaveHKB (QUOTE SAVE) "Save H knowledge base") ("EraseEnv" (QUOTE ERASE) "Erase entire environment") (Exit (QUOTE Exit) "Exit from logic environment"))) (DEFINEQ (H [LAMBDA NIL (* edited: " 9-Feb-87 14:52") (LET* ((HWINDOW (CREATEW NIL (CONCAT "H " H.RELEASE.NUMBER " -- Horn Clauses Programming Environment ") 6 T)) (HMenu (MENUWINDOW (create MENU MENUCOLUMNS _ 1 TITLE _ "H control window" ITEMS _ HMenuItems WHENSELECTEDFN _ (FUNCTION HMenuFunction) CENTERFLG _ T))) (HKBMenu (MENUWINDOW (create MENU MENUCOLUMNS _ 1 TITLE _ "KB loaded:" ITEMS _ NIL CENTERFLG _ T))) (LISPXUSERFN T) (H.FROM.WINDOW T)) (ATTACHWINDOW HMenu HWINDOW (QUOTE RIGHT) (QUOTE TOP)) (ATTACHWINDOW HKBMenu HWINDOW (QUOTE LEFT) (QUOTE TOP)) (PUTWINDOWPROP HWINDOW (QUOTE *functions*) NIL) (PUTWINDOWPROP HWINDOW (QUOTE *int-mode*) (QUOTE first)) (PUTWINDOWPROP HWINDOW (QUOTE *l-trace*) NIL) (PUTWINDOWPROP HWINDOW (QUOTE *limit*) 200) (PUTWINDOWPROP HWINDOW (QUOTE *match-trace*) NIL) (PUTWINDOWPROP HWINDOW (QUOTE *predicates*) NIL) (PUTWINDOWPROP HWINDOW (QUOTE *shortform*) T) (PUTWINDOWPROP HWINDOW (QUOTE *variables*) NIL) (OPENW HWINDOW) (TTYDISPLAYSTREAM HWINDOW) (USEREXEC (QUOTE ?--) NIL (FUNCTION HReadProvePrint)) (CLOSEW HWINDOW]) (H.BUTTONFN [LAMBDA (W) (* edited: "17-Mar-87 16:28") (COND ((LASTMOUSESTATE LEFT) T) ((LASTMOUSESTATE MIDDLE) (SELECTQ [SETQ COM (MENU (OR HMIDDLEMENU (SETQ HMIDDLEMENU (create MENU ITEMS _ HMENUITEMS] [Dribble (LET ((PW (GETPROMPTWINDOW W)) (FILE NIL) (FILENAME NIL)) (CLEARW PW) (SETQ FILENAME (MKATOM (PROMPTFORWORD "Typescript to file (cr to close): " NIL NIL PW))) (FOO) (CLEARW PW) (COND ((NULL FILENAME) (CLOSEF (GETWINDOWPROP W (QUOTE TYPESCRIPTFILE)) ) (CLEARW PW) (PRINTOUT PW (CONCAT (FULLNAME (GETWINDOWPROP W (QUOTE TYPESCRIPTFILE))) " closed")) (PUTWINDOWPROP W (QUOTE TYPESCRIPTFILE) NIL)) (T (SETQ FILE (OPENSTREAM FILENAME (QUOTE OUTPUT) (QUOTE NEW))) (if (NULL FILE) then [PROGN NIL (CLEARW PW) (PRINTOUT PW (CONCAT "Could not open" (FULLNAME FILENAME] else (PROGN NIL (CLEARW PW) (PRINTOUT PW (CONCAT (FULLNAME FILENAME) " opened")) (PUTWINDOWPROP W (QUOTE TYPESCRIPTFILE) FILE] T]) (H.NullW [LAMBDA (type) (* edited: "17-Mar-87 16:33") (COND [(EQ type (QUOTE PM)) (if (NULL *PMWindow*) then (SETQ *PMWindow* (CREATEW NIL "Pattern matching window")) (DSPSCROLL (QUOTE ON) *PMWindow*) (PUTWINDOWPROP *PMWindow* (QUOTE BUTTONEVENTFN) (FUNCTION H.BUTTONFN] [(EQ type (QUOTE TR)) (if (NULL *TraceWindow*) then (SETQ *TraceWindow* (CREATEW NIL "Tracing window")) (DSPSCROLL (QUOTE ON) *TraceWindow*) (PUTWINDOWPROP *TraceWindow* (QUOTE BUTTONEVENTFN) (FUNCTION H.BUTTONFN] ((EQ type (QUOTE SH)) (if (NULL *ShowWindow*) then (PROGN NIL (SETQ *ShowWindow* (CREATEW NIL "Show window")) (DSPSCROLL (QUOTE ON) *ShowWindow*) (PUTWINDOWPROP *ShowWindow* (QUOTE BUTTONEVENTFN) (FUNCTION H.BUTTONFN]) (H.PrintInfo [LAMBDA (win-type args) (* edited: "17-Mar-87 16:32") (* Names for windows are: *PMWindow*, for tracing pattern  matching, *TraceWindow*, for tracing window, and  *ShowWindow*, for showing window) (H.NullW win-type) (LET [(W (COND ((EQ win-type (QUOTE PM)) *PMWindow*) ((EQ win-type (QUOTE TR)) *TraceWindow*) ((EQ win-type (QUOTE SH)) *ShowWindow*] (SHOWPRINT args W) (TERPRI W) (LET [(FILE (GETWINDOWPROP W (QUOTE TYPESCRIPTFILE] (if FILE then (SHOWPRINT args FILE]) (H.delete [LAMBDA (delendo ax-list) (* edited: "17-Oct-86 15:07") (COND ((NULL ax-list) NIL) ((EQUAL delendo (CAAR ax-list)) (CDR ax-list)) (T (CONS (CAR ax-list) (H.delete delendo (CDR ax-list]) (H.editAxiom [LAMBDA (W) (* edited: " 6-Feb-87 10:15") (CLEARW PROMPTWINDOW) (TTYDISPLAYSTREAM PROMPTWINDOW) (LET* [(preds (GETWINDOWPROP W (QUOTE *predicates*))) (name (MENU (create MENU MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (LENGTH preds) 10)) TITLE _ (QUOTE Predicates) ITEMS _ (CONS (QUOTE --New--) preds) MENUBORDERSIZE _ 1 CENTERFLG _ T))) (*dummy-axiom* (LIST (LIST (LIST (QUOTE predicate] [COND ((NULL name) NIL) [(MEMBER name preds) (SETQ *dummy-axiom* (GETPROP name (QUOTE axiom))) (DV *dummy-axiom*) (PUTPROP name (QUOTE axiom) *dummy-axiom*) (MkVars *dummy-axiom* W) (SETQ *dummy-axiom* (LIST (LIST (LIST (QUOTE predicate] (T (SETQ name (MKATOM (PROMPTFORWORD "Name of new axiom: "))) (DV *dummy-axiom*) (PUTPROP name (QUOTE axiom) *dummy-axiom*) (MkVars *dummy-axiom* W) (PUTWINDOWPROP W (QUOTE *predicates*) (CONS name preds] (SETQ *dummy-axiom* (LIST (LIST (LIST (QUOTE predicate]) (H.editSA [LAMBDA (W) (* edited: " 6-Feb-87 10:15") (CLEARW PROMPTWINDOW) (LET* [(SAs (GETWINDOWPROP W (QUOTE *functions*))) (name (MENU (create MENU MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (LENGTH SAs) 10)) TITLE _ (QUOTE Functions) ITEMS _ (CONS (QUOTE --New--) SAs) MENUBORDERSIZE _ 1 CENTERFLG _ T))) (*dummy-SA* (LIST (QUOTE LAMBDA) (LIST (QUOTE ARGS) (QUOTE ...)) (QUOTE BODY] (COND ((NULL name) NIL) [(MEMBER name SAs) (SETQ *dummy-SA* (GETPROP name (QUOTE funct))) (DV *dummy-SA*) (PUTPROP name (QUOTE funct) *dummy-SA*) (SETQ *dummy-SA* (LIST (QUOTE LAMBDA) (LIST (QUOTE ARGS) (QUOTE ...)) (QUOTE BODY] (T (SETQ name (MKATOM (PROMPTFORWORD "Name of new SA: "))) (DV *dummy-SA*) (PUTPROP name (QUOTE funct) *dummy-SA*) (PUTWINDOWPROP W (QUOTE *functions*) (CONS name SAs)) (SETQ *dummy-SA* (LIST (QUOTE LAMBDA) (LIST (QUOTE ARGS) (QUOTE ...)) (QUOTE BODY]) (H.erase [LAMBDA NIL (* edited: " 5-Feb-87 15:46") (PSETQ *functions1* NIL *functions* NIL *predicates1* NIL *predicates* NIL *variables1* NIL *variables* NIL]) (H.load [LAMBDA (kb) (* edited: " 5-Feb-87 16:10") (LET ((numFoo NIL) (numPred NIL)) [LOAD (PACK (APPEND (UNPACK kb) (QUOTE (%. H K B] (SETQ numPred (LENGTH *predicates1*)) (SETQ numFoo (LENGTH *functions1*)) (for I in *temp-foo* as Q in *functions1* as H from 1 to numFoo do (PUTPROP Q (QUOTE funct) I)) (for I in *temp-pred* as Q in *predicates1* as H from 1 to numPred do (PUTPROP Q (QUOTE axiom) I)) (for Q in *variables1* do (PUTPROP Q (QUOTE variable) T)) (SETQ *predicates* (APPEND *predicates* *predicates1*)) (SETQ *functions* (APPEND *functions* *functions1*)) (SETQ *variables* (APPEND *variables* *variables1*)) T]) (H.save [LAMBDA (kb) (* edited: " 5-Feb-87 15:43") (LET [[var (PACK (CONS (UNPACK kb) (QUOTE (C O M S] (file (PACK (APPEND (UNPACK kb) (QUOTE (%. H K B] [SETQ *temp-foo* (for I in *functions* collect (GETPROP I (QUOTE funct] [SETQ *temp-pred* (for I in *predicates* collect (GETPROP I (QUOTE axiom] (PSETQ *functions1* *functions* *predicates1* *predicates* *variables1* *variables*) [SETQ var (LIST (LIST (QUOTE *functions1*) (QUOTE *predicates1*) (QUOTE *variables1*) (QUOTE *temp-foo*) (QUOTE *temp-pred*] (PUTDEF file (QUOTE FILES) var) (MAKEFILE file]) (HMenuFunction [LAMBDA (item menu button) (* edited: "17-Mar-87 14:09") (LET* [(newitem (CADADR item)) (mainw (MAINWINDOW (WFROMMENU menu))) (KBMenu (CADR (ATTACHEDWINDOWS mainw] (COND ((EQ newitem (QUOTE Exit)) (PROG NIL (GIVE.TTY.PROCESS mainw) (BKSYSBUF (QUOTE (OK))) (CLOSEW mainw))) ((MEMBER newitem (QUOTE (ALL MODE))) (PUTWINDOWPROP mainw (QUOTE *int-mode*) (QUOTE all))) ((EQ newitem (QUOTE FIRST)) (PUTWINDOWPROP mainw (QUOTE *int-mode*) (QUOTE first))) [(EQ newitem (QUOTE SHOWAXIOM)) (PROG (ans (mm (create MENU MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (LENGTH (GETWINDOWPROP mainw (QUOTE *predicates*))) 10)) TITLE _ (QUOTE Predicates) ITEMS _ (GETWINDOWPROP mainw (QUOTE *predicates*)) MENUBORDERSIZE _ 1 CENTERFLG _ T))) (OR (GETWINDOWPROP mainw (QUOTE *predicates*)) (RETURN T)) flag(SETQ ans (MENU mm)) (if ans then (PROG NIL (H.PrintInfo (QUOTE SH) (GETPROP ans (QUOTE axiom))) (GO flag] [(EQ newitem (QUOTE SHOWSA)) (PROG (ans (mm (create MENU MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (LENGTH (GETWINDOWPROP mainw (QUOTE *functions*))) 10)) TITLE _ (QUOTE Functions) ITEMS _ (GETWINDOWPROP mainw (QUOTE *functions*)) MENUBORDERSIZE _ 1 CENTERFLG _ T))) (OR (GETWINDOWPROP mainw (QUOTE *functions*)) (RETURN T)) flag(SETQ ans (MENU mm)) (if ans then (PROG NIL (H.PrintInfo (QUOTE SH) (GETPROP ans (QUOTE funct))) (GO flag] [(EQ newitem (QUOTE DELETEAXIOM)) (PROG (ans) flag(SETQ ans (MENU (create MENU MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (LENGTH (GETWINDOWPROP mainw (QUOTE *predicates*))) 10)) TITLE _ (QUOTE Predicates) ITEMS _ (GETWINDOWPROP mainw (QUOTE *predicates*)) MENUBORDERSIZE _ 1 CENTERFLG _ T))) (if ans then (PROG NIL [PUTWINDOWPROP mainw (QUOTE *predicates*) (DREMOVE ans (GETWINDOWPROP mainw (QUOTE *predicates*] (PUTPROP ans (QUOTE axiom) NIL) (GO flag] [(EQ newitem (QUOTE DELETESA)) (PROG (ans) flag(SETQ ans (MENU (create MENU MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (LENGTH (GETWINDOWPROP mainw (QUOTE *functions*))) 10)) TITLE _ (QUOTE Functions) ITEMS _ (GETWINDOWPROP mainw (QUOTE *functions*)) MENUBORDERSIZE _ 1 CENTERFLG _ T))) (if ans then (PROG NIL [PUTWINDOWPROP mainw (QUOTE *functions*) (DREMOVE ans (GETWINDOWPROP mainw (QUOTE *functions*] (PUTPROP ans (QUOTE funct) NIL) (GO flag] ((EQ newitem (QUOTE INTERACTIVE)) (PUTWINDOWPROP mainw (QUOTE *int-mode*) T)) ((EQ newitem (QUOTE EDITAXIOM)) (H.editAxiom mainw)) ((EQ newitem (QUOTE EDITSA)) (H.editSA mainw)) ((MEMBER newitem (QUOTE (SHORTFORM YES))) (PUTWINDOWPROP mainw (QUOTE *shortform*) T)) ((EQ newitem (QUOTE NO)) (PUTWINDOWPROP mainw (QUOTE *shortform*) NIL)) ((EQ newitem (QUOTE TRACE)) (PUTWINDOWPROP mainw (QUOTE *l-trace*) T)) ((EQ newitem (QUOTE NOTRACE)) (PUTWINDOWPROP mainw (QUOTE *l-trace*) NIL)) ((EQ newitem (QUOTE SETLIMIT)) (PUTWINDOWPROP mainw (QUOTE *limit*) (RNUMBER "Set new limit:"))) ((EQ newitem (QUOTE ERASE)) (for I in (GETWINDOWPROP mainw (QUOTE *predicates*)) do (PUTPROP I (QUOTE axiom) NIL)) (for I in (GETWINDOWPROP mainw (QUOTE *functions*)) do (PUTPROP I (QUOTE funct) NIL)) (PUTWINDOWPROP mainw (QUOTE *functions*) NIL) (PUTWINDOWPROP mainw (QUOTE *predicates*) NIL) (PUTWINDOWPROP mainw (QUOTE *variables*) NIL) (PSETQ *temp-foo* NIL *temp-pred* NIL) (PSETQ *functions1* NIL *predicates1* NIL *variables1* NIL *PMTraceWindow* NIL *ShowWindow* NIL *TraceWindow* NIL) (DETACHWINDOW KBMenu) (CLOSEW KBMenu) (ATTACHMENU (create MENU MENUCOLUMNS _ 1 TITLE _ "KB loaded:" ITEMS _ NIL CENTERFLG _ T) mainw (QUOTE LEFT) (QUOTE TOP))) ((EQ newitem (QUOTE TRACEPM)) (PUTWINDOWPROP mainw (QUOTE *match-trace*) T)) ((EQ newitem (QUOTE NOTRACEPM)) (PUTWINDOWPROP mainw (QUOTE *match-trace*) NIL)) ((EQ newitem (QUOTE LOAD)) (LoadHKB mainw)) ((EQ newitem (QUOTE SAVE)) (SaveHKB mainw)) ((EQ newitem (QUOTE SHOWPROFILE)) (CLEARW PROMPTWINDOW) (PRINTOUT PROMPTWINDOW (QUOTE Mode:) .SP 1 (GETWINDOWPROP mainw (QUOTE *int-mode*)) .SP 3 (QUOTE Limit:) (GETWINDOWPROP mainw (QUOTE *limit*)) T (QUOTE Tracing:) .SP 1 (GETWINDOWPROP mainw (QUOTE *l-trace*)) .SP 3 (QUOTE PMTracing:) .SP 1 (GETWINDOWPROP mainw (QUOTE *match-trace*)) T]) (HReadProvePrint [LAMBDA (x line) (* edited: "20-Oct-86 14:11") (PROG ((SYSPRETTYFLG T)) (H.?! (LIST x)) (RETURN T]) (LoadHKB [LAMBDA (W) (* edited: " 4-Feb-87 10:14") (CLEARW PROMPTWINDOW) (TTYDISPLAYSTREAM PROMPTWINDOW) (LET [(ans (MKATOM (PROMPTFORWORD "Name of KB:"))) (numFoo NIL) (numPred NIL) (att-w (CADR (ATTACHEDWINDOWS W] [LOAD (PACK (APPEND (UNPACK ans) (QUOTE (%. H K B] (DETACHWINDOW att-w) (CLOSEW att-w) (ATTACHMENU (create MENU MENUCOLUMNS _ 1 TITLE _ "KB loaded:" ITEMS _ (replace ITEMS of (CAR (GETWINDOWPROP att-w (QUOTE MENU))) with (APPEND [fetch ITEMS of (CAR (GETWINDOWPROP att-w (QUOTE MENU] (LIST ans))) CENTERFLG _ T) W (QUOTE LEFT) (QUOTE TOP)) (SETQ numPred (LENGTH *predicates1*)) (SETQ numFoo (LENGTH *functions1*)) (for I in *temp-foo* as Q in *functions1* as H from 1 to numFoo do (PUTPROP Q (QUOTE funct) I)) (for I in *temp-pred* as Q in *predicates1* as H from 1 to numPred do (PUTPROP Q (QUOTE axiom) I)) (for Q in *variables1* do (PUTPROP Q (QUOTE variable) T)) (if (GETWINDOWPROP W (QUOTE *predicates*)) then (PUTWINDOWPROP W (QUOTE *predicates*) (APPEND (GETWINDOWPROP W (QUOTE *predicates*)) *predicates1*)) else (PUTWINDOWPROP W (QUOTE *predicates*) *predicates1*)) (if (GETWINDOWPROP W (QUOTE *functions*)) then (PUTWINDOWPROP W (QUOTE *functions*) (APPEND (GETWINDOWPROP W (QUOTE *functions*)) *functions1*)) else (PUTWINDOWPROP W (QUOTE *functions*) *functions1*)) (if (GETWINDOWPROP W (QUOTE *variables*)) then (PUTWINDOWPROP W (QUOTE *variables*) (APPEND (GETWINDOWPROP W (QUOTE *variables*)) *variables1*)) else (PUTWINDOWPROP W (QUOTE *variables*) *variables1*]) (SaveHKB [LAMBDA (W) (* edited: " 3-Feb-87 18:15") (CLEARW PROMPTWINDOW) (TTYDISPLAYSTREAM PROMPTWINDOW) (LET* [(ans (MKATOM (PROMPTFORWORD "Name of KB:"))) [var (PACK (CONS (UNPACK ans) (QUOTE (C O M S] (file (PACK (APPEND (UNPACK ans) (QUOTE (%. H K B] [SETQ *temp-foo* (for I in (GETWINDOWPROP W (QUOTE *functions*)) collect (GETPROP I (QUOTE funct] [SETQ *temp-pred* (for I in (GETWINDOWPROP W (QUOTE *predicates*)) collect (GETPROP I (QUOTE axiom] (PSETQ *functions1* (GETWINDOWPROP W (QUOTE *functions*)) *predicates1* (GETWINDOWPROP W (QUOTE *predicates*)) *variables1* (GETWINDOWPROP W (QUOTE *variables*))) [SETQ var (LIST (LIST (QUOTE *functions1*) (QUOTE *predicates1*) (QUOTE *variables1*) (QUOTE *temp-foo*) (QUOTE *temp-pred*] (PUTDEF file (QUOTE FILES) var) (MAKEFILE file]) (\DummyFoo [LAMBDA NIL (* edited: "25-Feb-87 11:30") (PROG NIL LOOP(BLOCK 600000) (GO LOOP]) (\SEE.AT [NLAMBDA (ARG) (* edited: " 3-Feb-87 17:42") (if H.FROM.WINDOW then (GETWINDOWPROP HWINDOW ARG) else (EVAL ARG]) ) (ADDTOVAR BackgroundMenuCommands (H [QUOTE (ADD.PROCESS (QUOTE (H] "Open window on logic programming environment")) (RPAQQ BackgroundMenu NIL) (PUTPROPS LOAD READVICE [NIL (AROUND NIL (PROG1 (PROG ((UpdateClassBrowsers? NIL)) (RETURN *)) (UpdateClassBrowsers]) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML \SEE.AT) (ADDTOVAR LAMA ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (2832 23212 (H 2842 . 4416) (H.BUTTONFN 4418 . 5945) (H.NullW 5947 . 6963) ( H.PrintInfo 6965 . 7717) (H.delete 7719 . 8013) (H.editAxiom 8015 . 9337) (H.editSA 9339 . 10690) (H.erase 10692 . 10911) (H.load 10913 . 11887) (H.save 11889 . 12788) (HMenuFunction 12790 . 19126) (HReadProvePrint 19128 . 19319) (LoadHKB 19321 . 21658) (SaveHKB 21660 . 22841) (\DummyFoo 22843 . 23007) (\SEE.AT 23009 . 23210))))) STOP \ No newline at end of file diff --git a/lispusers/H-LOAD b/lispusers/H-LOAD new file mode 100644 index 00000000..b25ef51e --- /dev/null +++ b/lispusers/H-LOAD @@ -0,0 +1 @@ +(FILECREATED "22-Apr-87 09:36:18" {DSK}H.BETA>LOADH.;2 505 changes to: (VARS LOADHCOMS) previous date: " 6-Feb-87 11:31:16" {DSK}H.BETA>LOADH.;1) (* Copyright (c) 1987 by Roberto Ghislanzoni. All rights reserved.) (PRETTYCOMPRINT LOADHCOMS) (RPAQQ LOADHCOMS ((P (FILESLOAD H-ENV H-SOURCE H-PATCHES CMLSPECIALFORMS)))) (FILESLOAD H-ENV H-SOURCE H-PATCHES CMLSPECIALFORMS) (PUTPROPS LOADH COPYRIGHT ("Roberto Ghislanzoni" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/H-LOOPS.HKB b/lispusers/H-LOOPS.HKB new file mode 100644 index 00000000..d21e8d3a --- /dev/null +++ b/lispusers/H-LOOPS.HKB @@ -0,0 +1 @@ +(FILECREATED "24-Mar-87 13:21:03" {DSK}H.BETA>HLOOPS.HKB;2 848 previous date: "24-Mar-87 12:27:15" {DSK}H.BETA>HLOOPS.HKB;1) (PRETTYCOMPRINT HLOOPSCOMS) (RPAQQ HLOOPSCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)) (RPAQQ *functions1* (H@ H_@ H_)) (RPAQQ *predicates1* NIL) (RPAQQ *variables1* (:c)) (RPAQQ *temp-foo* ([LAMBDA XX (LET [(l (for I from 1 to XX collect (ARG XX I] (EVAL (APPEND (LIST (QUOTE @)) l)) T] [LAMBDA XX (LET [(l (for I from 1 to XX collect (ARG XX I] (EVAL (APPEND (LIST (QUOTE _@)) l)) T] [LAMBDA XX (LET [(l (for I from 1 to XX collect (ARG XX I] (EVAL (APPEND (LIST (QUOTE _)) l)) T])) (RPAQQ *temp-pred* NIL) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/H-MAZE.HKB b/lispusers/H-MAZE.HKB new file mode 100644 index 00000000..a5407ce8 --- /dev/null +++ b/lispusers/H-MAZE.HKB @@ -0,0 +1 @@ +(FILECREATED " 9-Dec-86 16:51:42" {DSK}H>MAZE.HKB;4 1337 previous date: " 9-Dec-86 13:21:53" {DSK}H>MAZE.HKB;2) (PRETTYCOMPRINT MAZECOMS) (RPAQQ MAZECOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)) (RPAQQ *functions1* (PRINT notmember)) (RPAQQ *predicates1* (search explore phone door)) (RPAQQ *variables1* (:A :w :q :s :v :b :a :start-list :to :from :z :y :list :x)) (RPAQQ *temp-foo* [[LAMBDA (x) (PRINTOUT T (EVAL x) T) T] (LAMBDA (x y) (NOT (MEMBER x y]) (RPAQQ *temp-pred* [(((search :from :to :start-list) < (explore :from :to :start-list) (phone :to))) [((explore :x :x :list)) ((explore :x :y :list) < (door :x :z) (notmember :z :list) (PRINT (CONCAT "Entering room " (QUOTE :z))) (explore :z :y (:z . :list))) ((explore :x :y :list) < (door :z :x) (notmember :z :list) (PRINT (CONCAT "Entering room " (QUOTE :z))) (explore :z :y (:z . :list] (((phone g))) (((door a b)) ((door a n)) ((door b m)) ((door b c)) ((door m i)) ((door c d)) ((door d e)) ((door e f)) ((door f h)) ((door h l)) ((door l g]) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/H-PATCHES b/lispusers/H-PATCHES new file mode 100644 index 00000000..7891c088 --- /dev/null +++ b/lispusers/H-PATCHES @@ -0,0 +1 @@ +(FILECREATED " 2-Feb-87 16:53:11" {DSK}H.ALFA>HPATCHES.;2 489 changes to: (VARS HPATCHESCOMS H.RELEASE.NUMBER) previous date: " 4-Dec-86 16:20:37" {DSK}H.ALFA>HPATCHES.;1) (PRETTYCOMPRINT HPATCHESCOMS) (RPAQQ HPATCHESCOMS ((VARS *PMWindow* *ShowWindow* *TraceWindow* H.RELEASE.NUMBER))) (RPAQQ *PMWindow* NIL) (RPAQQ *ShowWindow* NIL) (RPAQQ *TraceWindow* NIL) (RPAQQ H.RELEASE.NUMBER "1.0") (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/H-SOURCE b/lispusers/H-SOURCE new file mode 100644 index 00000000..25627161 --- /dev/null +++ b/lispusers/H-SOURCE @@ -0,0 +1 @@ +(FILECREATED "23-Mar-87 13:37:16" {DSK}H.BETA>HSOURCE.;6 20748 previous date: "18-Mar-87 14:22:10" {DSK}H.BETA>HSOURCE.;5) (PRETTYCOMPRINT HSOURCECOMS) (RPAQQ HSOURCECOMS [(VARS *functions* *int-mode* *l-trace* *limit* *match-trace* *predicates* *primitiveSA* *shortform* *variables* H.FROM.WINDOW) (FNS BuildAssert FirstAntec H.? H.?! H.?v H.RmAxiom H.absent H.addaxiom H.all H.another? H.any H.attach H.axioms H.continue? H.del H.expand1 H.index H.isfunc? H.match H.prove H.show H.strip H.the IsCar? IsPrimitive? MacroAxiom MapNull MkVars NewAxiom NotCorrect PredicateOf RmAxiom SET.H.MODE Write fact? with?) (MACROS H.strip) (PROP axiom /) (PROP prim-funct assert delete set) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA Write H.show H.attach H.?) (NLAML) (LAMA]) (RPAQQ *functions* NIL) (RPAQQ *int-mode* first) (RPAQQ *l-trace* NIL) (RPAQQ *limit* 200) (RPAQQ *match-trace* NIL) (RPAQQ *predicates* NIL) (RPAQQ *primitiveSA* (set assert delete)) (RPAQQ *shortform* T) (RPAQQ *variables* NIL) (RPAQQ H.FROM.WINDOW NIL) (DEFINEQ (BuildAssert [LAMBDA (x) (* edited: " 2-Oct-86 12:08") (SETQ assert-numb (PLUS 1 assert-numb)) (MacroAxiom (MkVars x]) (FirstAntec [LAMBDA (p) (* edited: " 2-Oct-86 13:09") (CADDR p]) (H.? [NLAMBDA conj.to.prove (* edited: " 5-Feb-87 11:15") (LET ((*lisp-use* T) (lisp-channel NIL) (formulas conj.to.prove)) (MkVars conj.to.prove) (H.?v conj.to.prove) lisp-channel]) (H.?! [LAMBDA (conj.to.prove) (* edited: " 5-Feb-87 17:28") (MkVars conj.to.prove HWINDOW) (* Used by the H window) (LET ((lisp-channel NIL) (*lisp-use* NIL)) (H.?v conj.to.prove]) (H.?v [LAMBDA (formulas) (* edited: " 3-Feb-87 11:16") (CATCH (QUOTE first-level) (LET ((counter (PLUS 1 *limit*)) (globalslashflag NIL) (IsCar NIL)) (MkVars formulas) (H.prove (LIST (LIST formulas NIL)) 1]) (H.RmAxiom [LAMBDA (ax) (* edited: "10-Feb-87 15:16") (SETQ *predicates* (DREMOVE ax *predicates*)) (PUTPROP ax (QUOTE axiom) NIL]) (H.absent [LAMBDA (x xlst y ylst) (* edited: " 4-Feb-87 14:20") (PROG NIL a (COND [(ATOM y) (COND ([OR (NUMBERP y) (AND (MEMBER y (\SEE.AT *variables*)) (NOT (GETPROP y (QUOTE variable] (RETURN T)) ((SETQ temp (ASSOC y (CAR ylst))) (SETQ y (CADR temp)) (SETQ ylst (CDDR temp)) (GO a)) ((RETURN (NOT (AND (EQ x y) (EQ xlst ylst] ((H.absent x xlst (CAR y) ylst) (SETQ y (CDR y)) (GO a]) (H.addaxiom [LAMBDA (ax-list) (* edited: " 7-Oct-86 09:48") (CATCH (QUOTE first-level) (LET ((assert-numb 0)) (MapNull ax-list (QUOTE BuildAssert]) (H.all [LAMBDA (formulas cong) (* edited: " 5-Feb-87 11:17") (MkVars cong) (LET ((globalslashflag NIL) (*int-mode* (QUOTE all)) (*lisp-use* T) (counter (PLUS 1 *limit*)) (lisp-channel NIL)) (H.prove (BQUOTE (((\, cong) NIL))) 1) lisp-channel]) (H.another? [LAMBDA NIL (* edited: " 4-Feb-87 16:17") (COND ((EQ (\SEE.AT *int-mode*) (QUOTE all)) T) ((OR (EQ (\SEE.AT *int-mode*) (QUOTE first)) (ZEROP (\SEE.AT *int-mode*))) NIL) ((NUMBERP (\SEE.AT *int-mode*)) (if H.FROM.WINDOW then (PUTWINDOWPROP HWINDOW (QUOTE *int-mode*) (SUB1 (\SEE.AT *int-mode*))) else (SETQ *int-mode* (SUB1 *int-mode*))) T) (T (H.continue?]) (H.any [LAMBDA (quant formulas cong) (* edited: " 5-Feb-87 12:12") (MkVars cong) (CATCH (QUOTE first-level) (LET ((globalslashflag NIL) (*int-mode* quant) (*lisp-use* T) (IsCar T) (counter (PLUS 1 *limit*)) (lisp-channel NIL)) (H.prove (BQUOTE (((\, cong) NIL))) 1) lisp-channel]) (H.attach [NLAMBDA flist (* edited: " 3-Oct-86 11:56") [COND ((NOT (MEMBER (CAR flist) *functions*)) (SETQ *functions* (CONS (CAR flist) *functions*] (PUTPROP (CAR flist) (QUOTE funct) (CADR flist]) (H.axioms [LAMBDA (ax-list) (* edited: " 7-Oct-86 09:49") (CATCH (QUOTE first-level) (LET ((assert-numb 0) (IsCar NIL)) (MapNull ax-list (QUOTE RmAxiom)) (MapNull ax-list (QUOTE BuildAssert]) (H.continue? [LAMBDA NIL (* edited: " 7-Oct-86 14:11") (TERPRI) (MEMBER (CAR (TTYIN (QUOTE Another?))) (QUOTE (y yes ok Y YES S SI si s]) (H.del [LAMBDA (arg) (* edited: " 5-Feb-87 13:29") (PUTPROP (CAR arg) (QUOTE axiom) (H.delete arg (GETPROP (CAR arg) (QUOTE axiom]) (H.expand1 [LAMBDA (lst x) (* edited: " 4-Feb-87 14:21") (COND ((STRINGP x) x) [(NOT (ATOM x)) (CONS (H.expand1 lst (CAR x)) (H.expand1 lst (CDR x] ((NUMBERP x) x) ((AND (MEMBER x (\SEE.AT *variables*)) (GETPROP x (QUOTE variable))) (COND ((SETQ temp (ASSOC x (CAR lst))) (H.expand1 (CDDR temp) (CADR temp))) (T x))) (T x]) (H.index [LAMBDA (z zlst) (* edited: " 3-Oct-86 09:22") (PROG NIL a (COND ((NOT (ATOM z)) (SETQ z (CAR z)) (GO a)) ((SETQ temp (ASSOC z (CAR zlst))) (SETQ z (CADR temp)) (SETQ zlst (CDDR temp)) (GO a)) (z (RETURN z]) (H.isfunc? [LAMBDA (arg) (* edited: " 6-Feb-87 09:43") (COND ((ATOM arg) NIL) ((IsPrimitive? (CAR arg)) (QUOTE primitive)) (T (AND (MEMBER (CAR arg) (\SEE.AT *functions*)) (GETPROP (CAR arg) (QUOTE funct]) (H.match [LAMBDA (x xlst y ylst) (* edited: "17-Mar-87 14:10") (AND (\SEE.AT *match-trace*) (H.PrintInfo (QUOTE PM) (LIST (QUOTE X=) x (QUOTE Y=) y))) (PROG (temp) a [COND ((ATOM x) (COND [(NOT (NUMBERP x)) (COND [(AND (MEMBER x (\SEE.AT *variables*)) (GETPROP x (QUOTE variable))) (COND ((SETQ temp (ASSOC x (CAR xlst))) (SETQ x (CADR temp)) (SETQ xlst (CDDR temp)) (GO a)) (T [PROG NIL b (COND ([AND (ATOM y) (NOT (NUMBERP y)) (AND (MEMBER y (\SEE.AT *variables*)) (GETPROP y (QUOTE variable))) (SETQ temp (ASSOC y (CAR ylst] (SETQ y (CADR temp)) (SETQ ylst (CDDR temp)) (GO b] (COND ((AND (EQ x y) (EQ ylst xlst)) (RETURN T)) ((OR (\SEE.AT *shortform*) (H.absent x xlst y ylst)) (SETQ save (CONS xlst save)) (RPLACA xlst (CONS (CONS x (CONS y ylst)) (CAR xlst))) (RETURN T)) (T (RETURN NIL] (T (GO c] (T (GO c] b [COND ((ATOM y) (COND [(NOT (NUMBERP y)) (COND [(AND (MEMBER y (\SEE.AT *variables*)) (GETPROP y (QUOTE variable))) (COND ((SETQ temp (ASSOC y (CAR ylst))) (SETQ y (CADR temp)) (SETQ ylst (CDDR temp)) (GO b)) (T (COND ((OR (\SEE.AT *shortform*) (H.absent y ylst x xlst)) (SETQ save (CONS ylst save)) (RPLACA ylst (CONS (CONS y (CONS x xlst)) (CAR ylst))) (RETURN T)) (T (RETURN NIL] (T (RETURN (EQ x y] (T (RETURN (EQ x y] (COND ((H.match (CAR x) xlst (CAR y) ylst) (SETQ x (CDR x)) (SETQ y (CDR y)) (GO a)) (T (RETURN NIL))) c (COND ((ATOM y) (COND [(NOT (NUMBERP y)) (COND [(AND (MEMBER y (\SEE.AT *variables*)) (GETPROP y (QUOTE variable))) (COND ((SETQ temp (ASSOC y (CAR ylst))) (SETQ y (CADR temp)) (SETQ ylst (CDDR temp)) (GO c)) (T (COND ((OR (\SEE.AT *shortform*) (H.absent y ylst x xlst)) (SETQ save (CONS ylst save)) (RPLACA ylst (CONS (CONS y (CONS x xlst)) (CAR ylst))) (RETURN T)) (T (RETURN NIL] (T (RETURN (EQ x y] (T (RETURN (EQ x y]) (H.prove [LAMBDA (stack level) (* edited: "17-Mar-87 14:11") (PROG ((save (LIST)) val ASS w z f) (SETQ counter (SUB1 counter)) c [COND ((ZEROP counter) (LET [(answer (CAR (TTYIN (QUOTE continue?] (COND [(MEMBER answer (QUOTE (y yes ok s si))) (SETQ counter (PLUS 1 (\SEE.AT *limit*] ((MEMBER answer (QUOTE (n no stop))) (THROW (QUOTE first-level) NIL)) (T (SHOWPRINT (EVAL answer) (if LISPXUSERFN then HWINDOW else T)) (GO c] b [COND [(NULL (CAAR stack)) (SETQ level (SUB1 level)) (COND [(NULL (CDR stack)) (SETQ val (H.expand1 (CDAR stack) formulas)) [COND (*lisp-use* (SETQ lisp-channel (CONS (H.expand1 (CDAR stack) formulas) lisp-channel))) (T (SHOWPRINT val (if LISPXUSERFN then HWINDOW else T] (COND ((H.another?) (RETURN NIL)) (T (THROW (QUOTE first-level) val] ((SETQ stack (CDR stack)) (OR [AND (\SEE.AT *l-trace*) (H.PrintInfo (QUOTE TR) (LIST level (QUOTE <--) (H.expand1 (CDAR stack) (CAAAR stack] T) (SETQ stack (CONS (CONS (CDAAR stack) (CDAR stack)) (CDR stack))) (GO b] ([SETQ f (H.isfunc? (H.expand1 (CDAR stack) (CAAAR stack] [COND ((\SEE.AT *l-trace*) (H.PrintInfo (QUOTE TR) (LIST level (QUOTE fun--->) (H.expand1 (CDAR stack) (CAAAR stack] (COND ((APPLY (GETPROP (H.expand1 (CDAR stack) (CAAAAR stack)) (if (EQ f (QUOTE primitive)) then (QUOTE prim-funct) else (QUOTE funct))) (H.expand1 (CDAR stack) (CDAAAR stack))) (SETQ stack (CONS (CONS (CDAAR stack) (CDAR stack)) (CDR stack))) (GO b] (SETQ ASS (GETPROP (H.index (CAAAR stack) (CDAR stack)) (QUOTE axiom))) a (COND ((ZEROP counter) (RETURN)) ((NULL ASS) [COND ((EQ (CAAAR stack) (QUOTE /)) (OR globalslashflag (SETQ globalslashflag (CDAR stack] (RETURN)) ([AND (H.match (CAAR ASS) (SETQ z (LIST NIL)) (CAAAR stack) (CDAR stack)) (OR [AND (\SEE.AT *l-trace*) (H.PrintInfo (QUOTE TR) (LIST level (QUOTE -->) (CAAAR stack) (H.expand1 z (CAR ASS] T) (SETQ w (H.prove (CONS (CONS (H.strip (CDAR ASS)) z) stack) (PLUS 1 level] (RETURN w)) (T [MapNull save (FUNCTION (LAMBDA (p) (RPLACA p (CDAR p] (SETQ save NIL) [SETQ ASS (COND ((NULL globalslashflag) (CDR ASS)) ((EQ globalslashflag z) (SETQ globalslashflag NIL] (GO a]) (H.show [NLAMBDA args (* edited: " 4-Feb-87 14:48") (for I in args do (PRINTOUT T (AND (MEMBER I (\SEE.AT *predicates*)) (GETPROP I (QUOTE axiom))) T]) (H.strip [LAMBDA (x) (* edited: " 2-Oct-86 12:03") (COND ((NULL x) NIL) (T (CDR x]) (H.the [LAMBDA (formulas cong) (* edited: " 5-Feb-87 12:13") (MkVars cong) (CATCH (QUOTE first-level) (LET ((globalslashflag NIL) (*int-mode* (QUOTE first)) (*lisp-use* T) (IsCar T) (counter (PLUS 1 *limit*)) (lisp-channel NIL)) (H.prove (BQUOTE (((\, cong) NIL))) 1) lisp-channel]) (IsCar? [LAMBDA (arg) (* edited: " 5-Feb-87 11:24") (FOO) (if IsCar then (CAR arg) else arg]) (IsPrimitive? [LAMBDA (pred) (* edited: " 6-Feb-87 09:44") (MEMBER pred *primitiveSA*]) (MacroAxiom [LAMBDA (assert) (* edited: " 5-Feb-87 11:08") (COND ((fact? assert) (NewAxiom assert)) ((with? assert) (BuildWith assert)) ((NotCorrect assert) (PRINTOUT T " Incorrect definition in " assert-numb) (THROW (QUOTE first-level) NIL)) ((EQ (FirstAntec assert) (QUOTE if)) (BuildIf assert)) ((EQ (FirstAntec assert) (QUOTE or)) (BuildOr assert)) (T (NewAxiom assert]) (MapNull [LAMBDA (lst foo) (* edited: " 2-Oct-86 11:47") (COND ((NULL lst) NIL) (T (APPLY foo (LIST (CAR lst))) (MapNull (CDR lst) foo]) (MkVars [LAMBDA (assert win) (* edited: " 6-Feb-87 11:16") (COND ((NULL assert) NIL) ((STRINGP assert) assert) ((NOT (ATOM assert)) (CONS (MkVars (CAR assert) win) (MkVars (CDR assert) win))) ((EQ (CAR (UNPACK assert)) (QUOTE :)) [COND ((NOT (MEMBER assert (if win then (GETWINDOWPROP win (QUOTE *variables*)) else *variables*))) (PUTPROP assert (QUOTE variable) T) (if win then [PUTWINDOWPROP win (QUOTE *variables*) (CONS assert (GETWINDOWPROP win (QUOTE *variables*] else (SETQ *variables* (CONS assert *variables*] assert) (T assert]) (NewAxiom [LAMBDA (assert) (* edited: " 3-Feb-87 18:29") (COND ((OR (ATOM assert) (ATOM (CAR assert))) (PRINTOUT T "Error in atomic formula " assert-numb T) (THROW (QUOTE first-level) NIL)) (T (LET ((predicate-name (PredicateOf assert))) [COND ((NOT (MEMBER predicate-name (\SEE.AT *predicates*))) (if H.FROM.WINDOW then (PUTWINDOWPROP HWINDOW (QUOTE *predicates*) (CONS predicate-name (\SEE.AT *predicates*))) else (SETQ *predicates* (CONS predicate-name *predicates*] (PUTPROP predicate-name (QUOTE axiom) (APPEND (GETPROP predicate-name (QUOTE axiom)) (LIST assert]) (NotCorrect [LAMBDA (as) (* edited: " 2-Oct-86 13:10") (NOT (EQ (CADR as) (QUOTE <]) (PredicateOf [LAMBDA (assert) (* edited: " 5-Feb-87 10:55") (COND ((ATOM (CAR assert)) (CAR assert)) (T (CAAR assert]) (RmAxiom [LAMBDA (assert) (* edited: " 5-Feb-87 11:00") (AND (LISTP assert) (OR (SETQ *predicates* (DREMOVE (PredicateOf assert) *predicates*)) T) (PUTPROP (PredicateOf assert) (QUOTE axiom) NIL]) (SET.H.MODE [LAMBDA (MODE NUM) (* edited: "10-Feb-87 15:11") (COND ((NULL MODE) (* Set the mode of demonstration for H  read-prove-print cicle : MODE may be "all",  "interactive" or "first") (LIST (IF (EQ MODE interactive) THEN (QUOTE interactive) ELSE *int-mode*) *l-trace* *limit*)) ((NUMBERP NUM) (SETQ *limit* NUM)) ((MEMBER MODE (QUOTE (all interactive first))) (IF (EQ MODE interactive) THEN (SETQ *int-mode* T) ELSE (SETQ *int-mode* MODE))) (T (ERROR "Unknown mode in SET.H.MODE"]) (Write [NLAMBDA ARGS (* edited: " 3-Sep-86 11:42") (for i in ARGS do (PRINTOUT T (EVAL i) T]) (fact? [LAMBDA (fact) (* edited: " 2-Oct-86 13:06") (NULL (CDR fact]) (with? [LAMBDA (assert) (* edited: " 2-Oct-86 13:42") (EQ (CAR assert) (QUOTE with]) ) (DECLARE: EVAL@COMPILE (PUTPROPS H.strip MACRO NIL) ) (PUTPROPS / axiom ((/))) (PUTPROPS assert prim-funct [LAMBDA (ARGS) (if H.FROM.WINDOW then [if [NOT (MEMBER (CAR ARGS) (GETWINDOWPROP HWINDOW (QUOTE *predicates*] then (PUTWINDOWPROP HWINDOW (QUOTE *predicates*) (CONS (CAR ARGS) (GETWINDOWPROP HWINDOW (QUOTE *predicates*] else (SETQ *predicates* (CONS (CAAR ARGS) *predicates*))) [CAR (PUTPROP (CAR ARGS) (QUOTE axiom) (CONS (LIST ARGS) (GETPROP (CAR ARGS) (QUOTE axiom] T]) (PUTPROPS delete prim-funct [LAMBDA (axiom) (PUTPROP (CAR axiom) (QUOTE axiom) (H.delete axiom (GETPROP (CAR axiom) (QUOTE axiom]) (PUTPROPS set prim-funct [LAMBDA (x1 y1) (LET ((lispvalue (EVAL y1))) (COND ((OR (NOT (ATOM x1)) (NUMBERP x1)) (Write "ERROR IN SET") NIL) ((GETPROP x1 (QUOTE variable)) (SETQ save (CONS (CDAR stack) save)) (RPLACA (CDAR stack) (CONS [CONS x1 (CONS lispvalue (QUOTE (NIL] (CADAR stack))) T) (T NIL]) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA Write H.show H.attach H.?) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (1201 19276 (BuildAssert 1211 . 1410) (FirstAntec 1412 . 1541) (H.? 1543 . 1812) (H.?! 1814 . 2095) (H.?v 2097 . 2432) (H.RmAxiom 2434 . 2653) (H.absent 2655 . 3293) (H.addaxiom 3295 . 3530 ) (H.all 3532 . 3884) (H.another? 3886 . 4466) (H.any 4468 . 4882) (H.attach 4884 . 5222) (H.axioms 5224 . 5527) (H.continue? 5529 . 5762) (H.del 5764 . 6005) (H.expand1 6007 . 6533) (H.index 6535 . 6905) (H.isfunc? 6907 . 7252) (H.match 7254 . 10270) (H.prove 10272 . 13718) (H.show 13720 . 13984) ( H.strip 13986 . 14155) (H.the 14157 . 14583) (IsCar? 14585 . 14764) (IsPrimitive? 14766 . 14915) ( MacroAxiom 14917 . 15460) (MapNull 15462 . 15702) (MkVars 15704 . 16543) (NewAxiom 16545 . 17357) ( NotCorrect 17359 . 17524) (PredicateOf 17526 . 17733) (RmAxiom 17735 . 18057) (SET.H.MODE 18059 . 18800) (Write 18802 . 18980) (fact? 18982 . 19117) (with? 19119 . 19274))))) STOP \ No newline at end of file diff --git a/lispusers/H.TEDIT b/lispusers/H.TEDIT new file mode 100644 index 00000000..56803468 Binary files /dev/null and b/lispusers/H.TEDIT differ diff --git a/lispusers/HANOI b/lispusers/HANOI new file mode 100644 index 00000000..de590919 --- /dev/null +++ b/lispusers/HANOI @@ -0,0 +1 @@ +(FILECREATED "25-Feb-86 19:07:01" {ERIS}KOTO>HANOI.;7 19947 changes to: (VARS HANOICOMS) previous date: "17-Feb-86 14:59:01" {ERIS}KOTO>HANOI.;5) (* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT HANOICOMS) (RPAQQ HANOICOMS ((FNS DISPLAYPEGSANDRINGS DOHANOI FINDOTHER HANOI HANOIDEMO MOVEDIS MOVERING RINGSHADE SETUPRINGBITMAPS TRACK WHANOI XHANOI) (VARS (HANOIWINDOW)) (DECLARE: DONTCOPY (RECORDS PEG RING) (CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE) (CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30) (MAXHORIZSPEED 44)) (MACROS PEGN)) (VARS EVENRINGSHADE ODDRINGSHADE PEGSHADE) (ALISTS (IDLE.FUNCTIONS Hanoi HanoiUsername)))) (DEFINEQ (DISPLAYPEGSANDRINGS [LAMBDA (PEGS W) (* edited: " 1-Oct-84 12:41") (* displays the pegs and the rings on them.) (for PEG in PEGS do (\CLEARBM W PEGSHADE (fetch PEGREGION of PEG)) (for RING in (fetch RINGS of PEG) do (\CLEARBM W (RINGSHADE (fetch RINGNUMBER of RING)) (fetch RINGREGION of RING)) (COND ((fetch RINGLABEL of RING) (CENTERPRINTINREGION (fetch RINGLABEL of RING) (fetch RINGREGION of RING) W]) (DOHANOI [LAMBDA (N SRC DST W) (* lmm " 8-MAR-82 12:05") (COND ((EQ N 1) (MOVERING SRC DST W)) (T (DOHANOI (SUB1 N) SRC (FINDOTHER SRC DST) W) (MOVERING SRC DST W) (DOHANOI (SUB1 N) (FINDOTHER SRC DST) DST W]) (FINDOTHER [LAMBDA (S D) (* bas: "10-DEC-80 14:01") (for Z from 1 to 3 thereis (NOT (OR (EQ Z S) (EQ Z D]) (HANOI [LAMBDA (NRINGS WINDOW FONT ONCE) (* lmm " 9-MAR-82 09:52") (WHANOI NRINGS WINDOW FONT ONCE]) (HANOIDEMO [LAMBDA NIL (* lmm "17-Feb-86 14:58") (PROG (HANOI.MOUSE.SPEED) (WHANOI 7 [COND ((TYPENAMEP HANOIWINDOW (QUOTE WINDOW)) HANOIWINDOW) (T (SETQ HANOIWINDOW (CREATEW (create REGION LEFT _ 4 BOTTOM _ 340 WIDTH _ 500 HEIGHT _ 300] NIL T]) (MOVEDIS [LAMBDA (RING DY SX DX W) (* lmm "17-Feb-86 14:58") (* moves RING from its position on the source peg whose left is SX to the peg whose left is DX at a height of DY) (PROG ((RINGREGION (fetch RINGREGION of RING)) RINGWIDTH HORIZWIDTH MOVERIGHTFLG) [COND (HANOI.MOUSE.SPEED (GETMOUSESTATE) (* IPLUS 16 is because cursor can go negative.) (SETQ VERTSPEED (IMIN (IMAX (IDIFFERENCE 17 (IQUOTIENT LASTMOUSEY 50)) 1) MAXVERTSPEED)) (SETQ HORIZSPEED (IMIN (IMAX (ADD1 (IQUOTIENT LASTMOUSEX 50)) 1) MAXHORIZSPEED] (SETUPRINGBITMAPS RING (SETQ RINGWIDTH (fetch WIDTH of RINGREGION)) (SETQ MOVERIGHTFLG (IGREATERP DX SX)) W) (* PROG is because FOR loop bug.) (PROG ((I (fetch BOTTOM of RINGREGION)) (TOPLIMIT (IDIFFERENCE PEGTOP VERTSPEED))) LP (COND ((IGREATERP TOPLIMIT I) (BITBLT UPRINGBM 0 0 W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED) (QUOTE INPUT) (QUOTE REPLACE)) (SETQ I (IPLUS VERTSPEED I)) (GO LP))) (BITBLT UPRINGBM 0 (IDIFFERENCE I TOPLIMIT) W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED) (QUOTE INPUT) (QUOTE REPLACE))) (BITBLT TOPUPRINGBM 0 0 W SX PEGTOP RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED) (QUOTE INPUT) (QUOTE REPLACE)) (SETQ HORIZWIDTH (IPLUS RINGWIDTH HORIZSPEED)) (for I from (COND (MOVERIGHTFLG SX) (T (IDIFFERENCE SX HORIZSPEED))) to (COND (MOVERIGHTFLG (SUB1 (IDIFFERENCE DX HORIZSPEED))) (T (ADD1 DX))) by (ITIMES (COND ((IGREATERP DX SX) 1) (T -1)) HORIZSPEED) do (BITBLT HORIZRINGBM 0 0 W I (IPLUS PEGTOP VERTSPEED) HORIZWIDTH RINGHEIGHT (QUOTE INPUT) (QUOTE REPLACE))) (BITBLT HORIZRINGBM 0 0 W (COND (MOVERIGHTFLG (IDIFFERENCE DX HORIZSPEED)) (T DX)) (IPLUS PEGTOP VERTSPEED) HORIZWIDTH NIL (QUOTE INPUT) (QUOTE REPLACE)) (* Update the ring region's left) (replace LEFT of RINGREGION with (IPLUS (fetch LEFT of RINGREGION) (IDIFFERENCE DX SX))) (for I from PEGTOP to (SUB1 (IDIFFERENCE PEGTOP RINGHEIGHT)) by (IMINUS VERTSPEED) do (BITBLT TOPDOWNRINGBM NIL NIL W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED) (QUOTE INPUT) (QUOTE REPLACE))) (BITBLT TOPDOWNRINGBM NIL NIL W DX (IDIFFERENCE PEGTOP RINGHEIGHT) RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED) (QUOTE INPUT) (QUOTE REPLACE)) (PROG [(I (IDIFFERENCE PEGTOP (IPLUS VERTSPEED RINGHEIGHT] LP (COND ((IGREATERP DY I) (* blt last ring image) (BITBLT DOWNRINGBM 0 0 W DX DY RINGWIDTH (COND ((IGREATERP VERTSPEED RINGHEIGHT) (IDIFFERENCE (IPLUS RINGHEIGHT VERTSPEED) (IDIFFERENCE DY I))) (T (IPLUS RINGHEIGHT VERTSPEED))) (QUOTE INPUT) (QUOTE REPLACE)) (RETURN))) (BITBLT DOWNRINGBM 0 0 W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED) (QUOTE INPUT) (QUOTE REPLACE)) (SETQ I (IDIFFERENCE I VERTSPEED)) (GO LP)) (replace BOTTOM of RINGREGION with DY) (RETURN RING]) (MOVERING [LAMBDA (SRC DST W) (* rrb " 2-AUG-82 17:41") (PROG ([X (fetch RINGREGION of (CAR (fetch RINGS of (PEGN DST] RING) (push (fetch RINGS of (PEGN DST)) (MOVEDIS [SETQ RING (pop (fetch RINGS of (PEGN SRC] (IPLUS (fetch BOTTOM of X) (fetch HEIGHT of X)) (TRACK SRC (fetch RINGREGION of RING)) (TRACK DST (fetch RINGREGION of RING)) W)) (BLOCK]) (RINGSHADE [LAMBDA (RINGN) (* rrb " 9-JUN-81 15:11") (COND ((EQ RINGN (QUOTE BASE)) PEGSHADE) ((ZEROP (LOGAND RINGN 1)) EVENRINGSHADE) (T ODDRINGSHADE]) (SETUPRINGBITMAPS [LAMBDA (RING RINGWIDTH MOVERIGHTFLG W) (* edited: " 1-Oct-84 12:43") (* sets up the ring bitmaps. There are 5 ring bitmaps: up while on peg, up above peg, horizontal, down above peg and down while on peg.) (PROG ((PEGOFFSET (IQUOTIENT (IDIFFERENCE RINGWIDTH PEGWIDTH) 2)) (RINGREGION (fetch RINGREGION of RING)) (RINGN (fetch RINGNUMBER of RING))) (AND FONT (DSPFONT FONT RDEST)) (DSPOPERATION (QUOTE ERASE) RDEST) [PROGN (\CLEARBM UPRINGBM) (BITBLT NIL NIL NIL UPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT (QUOTE TEXTURE) (QUOTE REPLACE) (RINGSHADE RINGN)) (* put in peg) (BITBLT NIL NIL NIL UPRINGBM PEGOFFSET 0 PEGWIDTH VERTSPEED (QUOTE TEXTURE) (QUOTE REPLACE) PEGSHADE) (COND ((fetch RINGLABEL of RING) (* print in label if there is one.) (DSPDESTINATION UPRINGBM RDEST) (CENTERPRINTINAREA (fetch RINGLABEL of RING) 0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST] [PROGN (\CLEARBM TOPUPRINGBM) (BITBLT NIL NIL NIL TOPUPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT (QUOTE TEXTURE) (QUOTE REPLACE) (RINGSHADE RINGN)) (COND ((fetch RINGLABEL of RING) (* print in label if there is one.) (DSPDESTINATION TOPUPRINGBM RDEST) (CENTERPRINTINAREA (fetch RINGLABEL of RING) 0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST] (PROGN (\CLEARBM DOWNRINGBM) (BITBLT NIL NIL NIL DOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE) (QUOTE REPLACE) (RINGSHADE RINGN)) (COND ((fetch RINGLABEL of RING) (* print in label if there is one.) (DSPDESTINATION DOWNRINGBM RDEST) (CENTERPRINTINAREA (fetch RINGLABEL of RING) 0 0 RINGWIDTH RINGHEIGHT RDEST))) (* put in peg) (BITBLT NIL NIL NIL DOWNRINGBM PEGOFFSET RINGHEIGHT PEGWIDTH VERTSPEED (QUOTE TEXTURE) (QUOTE REPLACE) PEGSHADE)) [PROGN (\CLEARBM TOPDOWNRINGBM) (BITBLT NIL NIL NIL TOPDOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE) (QUOTE REPLACE) (RINGSHADE RINGN)) (COND ((fetch RINGLABEL of RING) (* print in label if there is one.) (DSPDESTINATION TOPDOWNRINGBM RDEST) (CENTERPRINTINAREA (fetch RINGLABEL of RING) 0 0 RINGWIDTH RINGHEIGHT RDEST] [PROGN (\CLEARBM HORIZRINGBM) (BITBLT NIL NIL NIL HORIZRINGBM (COND (MOVERIGHTFLG HORIZSPEED) (T 0)) 0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE) (QUOTE REPLACE) (RINGSHADE RINGN)) (COND ((fetch RINGLABEL of RING) (* print in label if there is one.) (DSPDESTINATION HORIZRINGBM RDEST) (CENTERPRINTINAREA (fetch RINGLABEL of RING) (COND (MOVERIGHTFLG HORIZSPEED) (T 0)) 0 RINGWIDTH RINGHEIGHT RDEST] (RETURN]) (TRACK [LAMBDA (PN REGION) (* lmm " 8-MAR-82 12:10") (* returns the track offset for ring movement on a  peg.) (IPLUS HANOIMARGIN (IPLUS (ITIMES RINGLARGEST (SUB1 PN)) (IQUOTIENT (IDIFFERENCE RINGLARGEST (fetch WIDTH of REGION)) 2]) (WHANOI [LAMBDA (RINGS W FONT ONCE) (* lmm " 3-Dec-85 12:51") (* runs hanoi in a region of a displaystream) (PROG ([REGION (DSPCLIPPINGREGION NIL (SETQ W (COND [(NULL W) (OR HANOIWINDOW (SETQ HANOIWINDOW (CREATEW] ((WINDOWP W)) (T (CREATEW W] [NRINGS (COND ((NUMBERP RINGS) RINGS) (T (LENGTH RINGS] (HORIZSPEED 21) (VERTSPEED 17) PEGS RINGBM TOPUPRINGBM RINGLARGEST TOPDOWNRINGBM PEGWIDTH BASEWIDTH RINGHEIGHT MOVEMENTHEIGHT BASEHEIGHT PEGTOP RINGDISPLAYSTREAM HANOIWINDOW RINGDELTA UPRINGBM HORIZRINGBM DOWNRINGBM (RDEST (DSPCREATE))) (DECLARE (SPECVARS . T)) (PROG (IMAGEHEIGHT) (SETQ BASEWIDTH (IDIFFERENCE (fetch WIDTH of REGION) (ITIMES HANOIMARGIN 2))) (SETQ RINGLARGEST (IQUOTIENT BASEWIDTH 3)) (* RINGDELTA is the difference in peg size on each  side.) (COND ([ZEROP (SETQ RINGDELTA (IQUOTIENT (IDIFFERENCE RINGLARGEST PEGMIN) (ADD1 (ITIMES NRINGS 2] (HELP "Not enough width for a display."))) (* leave one ring width for base, one for top of peg and two above peg for movement. Doesn't really use two heights at top, only one plus VERTSPEED) (SETQ RINGHEIGHT (IQUOTIENT (SETQ IMAGEHEIGHT (IDIFFERENCE (fetch HEIGHT of REGION) (ITIMES HANOIMARGIN 2))) (IPLUS NRINGS 4))) (COND ((ZEROP RINGHEIGHT) (HELP "Not enough height for display."))) (SETQ PEGWIDTH (IQUOTIENT (IDIFFERENCE RINGLARGEST (ITIMES RINGDELTA (SUB1 NRINGS) 2)) 3)) (* put extra in base if it comes out closer to  pegwidth.) (COND [(IGREATERP PEGWIDTH RINGHEIGHT) (SETQ BASEHEIGHT (IMIN PEGWIDTH (IPLUS RINGHEIGHT (IDIFFERENCE IMAGEHEIGHT (ITIMES (IPLUS NRINGS 4) RINGHEIGHT] (T (SETQ BASEHEIGHT RINGHEIGHT))) (SETQ MOVEMENTHEIGHT (IPLUS [SETQ PEGTOP (IPLUS HANOIMARGIN BASEHEIGHT (ITIMES RINGHEIGHT (ADD1 NRINGS] VERTSPEED)) (DSPFONT FONT RDEST) (DSPFONT FONT W) (DSPOPERATION (QUOTE ERASE) RDEST) (DSPOPERATION (QUOTE ERASE) W)) [PROG ((BASE (create REGION LEFT _ HANOIMARGIN BOTTOM _ HANOIMARGIN WIDTH _ BASEWIDTH HEIGHT _ BASEHEIGHT))) (SETQ PEGS (for PLEFT from (IPLUS HANOIMARGIN (IQUOTIENT (IDIFFERENCE RINGLARGEST PEGWIDTH) 2)) by RINGLARGEST as I from 1 to 3 collect (create PEG PEGREGION _(create REGION LEFT _ PLEFT BOTTOM _(IPLUS BASEHEIGHT HANOIMARGIN) WIDTH _ PEGWIDTH HEIGHT _(ITIMES RINGHEIGHT (ADD1 NRINGS))) RINGS _(LIST (create RING RINGREGION _ BASE RINGNUMBER _(QUOTE BASE] [PROG [(SOURCEPEG (PEGN 1)) (RINGLABELS (COND ((LISTP RINGS) (REVERSE RINGS)) (T (* collect n NILs as lables.) (for I from 1 to RINGS collect NIL] (for RINGBOTTOM from (IPLUS HANOIMARGIN BASEHEIGHT) by RINGHEIGHT as RINGLEFT from (IPLUS HANOIMARGIN (ITIMES RINGLARGEST (SUB1 1))) by RINGDELTA as I from 0 to (SUB1 NRINGS) as LABEL in RINGLABELS do (push (fetch RINGS of SOURCEPEG) (create RING RINGREGION _(create REGION LEFT _ RINGLEFT BOTTOM _ RINGBOTTOM WIDTH _(IDIFFERENCE RINGLARGEST (ITIMES I 2 RINGDELTA)) HEIGHT _ RINGHEIGHT) RINGNUMBER _(ADD1 (IDIFFERENCE NRINGS I)) RINGLABEL _ LABEL))) (* allocate bitmaps for ring movement) (SETQ HORIZRINGBM (BITMAPCREATE (IPLUS RINGLARGEST MAXHORIZSPEED) RINGHEIGHT)) (SETQ UPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED))) (SETQ DOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED))) (SETQ TOPUPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)) ) (SETQ TOPDOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED] (\CLEARBM W) (DISPLAYPEGSANDRINGS PEGS W) (bind (HERE _ 1) (THERE _ 3) do (DOHANOI NRINGS HERE THERE W) (COND (ONCE (RETURN))) (DISMISS 2000) (SETQ HERE (PROG1 THERE (SETQ THERE (FINDOTHER HERE THERE]) (XHANOI [LAMBDA NIL (* lmm " 8-MAR-82 15:59") (PROG ((EVENRINGSHADE XRINGSHADE) (ODDRINGSHADE ORINGSHADE) (PEGSHADE XPEGSHADE)) (WHANOI (QUOTE (X E R O X)) (QUOTE (0 0 400 280)) (FONTCREATE (QUOTE LOGO) 24]) ) (RPAQQ HANOIWINDOW NIL) (DECLARE: DONTCOPY [DECLARE: EVAL@COMPILE (RECORD PEG (PEGREGION RINGS)) (RECORD RING (RINGREGION RINGNUMBER RINGLABEL)) ] (DECLARE: EVAL@COMPILE (RPAQQ XRINGSHADE 42405) (RPAQQ ORINGSHADE 60375) (RPAQQ XPEGSHADE 65535) (CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE) ) (DECLARE: EVAL@COMPILE (RPAQQ PEGMIN 2) (RPAQQ HANOIMARGIN 5) (RPAQQ MAXVERTSPEED 30) (RPAQQ MAXHORIZSPEED 44) (CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30) (MAXHORIZSPEED 44)) ) (DECLARE: EVAL@COMPILE [PUTPROPS PEGN MACRO ((N) (CAR (SELECTQ N (1 PEGS) (2 (CDR PEGS)) (CDDR PEGS] ) ) (RPAQQ EVENRINGSHADE 42405) (RPAQQ ODDRINGSHADE 61375) (RPAQQ PEGSHADE 65535) (ADDTOVAR IDLE.FUNCTIONS [Hanoi (FUNCTION (LAMBDA (W) (HANOI (UNPACK (QUOTE "Xerox AI Systems")) W (QUOTE (TIMESROMAND 36] [HanoiUsername (FUNCTION (LAMBDA (W) (HANOI (UNPACK (USERNAME NIL T T)) W (QUOTE (TIMESROMAND 36]) (PUTPROPS HANOI COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (797 18810 (DISPLAYPEGSANDRINGS 807 . 1479) (DOHANOI 1481 . 1818) (FINDOTHER 1820 . 2022 ) (HANOI 2024 . 2167) (HANOIDEMO 2169 . 2861) (MOVEDIS 2863 . 8440) (MOVERING 8442 . 8994) (RINGSHADE 8996 . 9245) (SETUPRINGBITMAPS 9247 . 12568) (TRACK 12570 . 12983) (WHANOI 12985 . 18479) (XHANOI 18481 . 18808))))) STOP \ No newline at end of file diff --git a/lispusers/HANOI.TEDIT b/lispusers/HANOI.TEDIT new file mode 100644 index 00000000..3d1d4fd0 Binary files /dev/null and b/lispusers/HANOI.TEDIT differ diff --git a/lispusers/HARDCOPY-RETAIN b/lispusers/HARDCOPY-RETAIN new file mode 100644 index 00000000..e3dbd66a --- /dev/null +++ b/lispusers/HARDCOPY-RETAIN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "29-Sep-88 17:02:58" |{EG:PARC:XEROX}LISPUSERS>HARDCOPY-RETAIN.;3| 3423 |changes| |to:| (vars hardcopy-retaincoms) |previous| |date:| "29-Dec-87 14:01:40" |{EG:PARC:XEROX}LISPUSERS>HARDCOPY-RETAIN.;2| ) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint hardcopy-retaincoms) (rpaqq hardcopy-retaincoms ((functions hardcopyimagew.tofile&printer install-option) (declare\: donteval@load docopy (p (install-option))))) (cl:defun hardcopyimagew.tofile&printer (&optional xcl-user::window) "Send hardcopy of WINDOW to a printer and a file." (let ((xcl-user::result (|GetImageFile|))) (cl:when xcl-user::result (let ((xcl-user::printer-name (|GetPrinterName|))) (destructuring-bind (xcl-user::file . type) xcl-user::result (hardcopy.somehow xcl-user::window xcl-user::file type) (cl:when xcl-user::printer-name (let ((xcl-user::full-name (packfilename.string (quote host) (cl:pathname-host xcl-user::file) (quote device) (cl:pathname-device xcl-user::file) (quote directory) (cl:pathname-directory xcl-user::file) (quote name) (cl:pathname-name xcl-user::file) (quote extension) (or (cl:first (cl:second (cl:assoc (quote extension) (cl:rest (cl:assoc type printfiletypes))))) type) (quote body) (cl:namestring *default-pathname-defaults*)))) (send.file.to.printer xcl-user::full-name xcl-user::printer-name)))))))) (cl:defun install-option nil "Install the new Hardcopy option." (cl:labels ((xcl-user::get-subitems (xcl-user::item) (and (eq (cl:first (cl:fourth xcl-user::item)) (quote subitems)) (cl:rest (cl:fourth xcl-user::item)))) (xcl-user::find-place-wm (xcl-user::item) (let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item))) (cl:when xcl-user::subitems (cl:if (eq (car xcl-user::item) (quote |Hardcopy|)) (cl:unless (* \; "Install if not already there.") (cl:find (quote hardcopyimagew.tofile&printer) xcl-user::subitems :key (cl:function (cl:lambda (xcl-user::x) (cl:second (cl:second xcl-user::x)))) :test (cl:function eq)) (nconc xcl-user::subitems (list (list "To a file and a printer" (quote (quote hardcopyimagew.tofile&printer)) "Sends image to a printer of your choosing, retaining the printer version of the file.")))) (cl:mapc (cl:function xcl-user::find-place-wm) xcl-user::subitems))))) (xcl-user::find-place-bm (xcl-user::item) (let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item))) (cl:when xcl-user::subitems (cl:if (eq (car xcl-user::item) (quote |Hardcopy|)) (cl:unless (* \; "Install if not already there.") (cl:find (quote hardcopyimagew.tofile&printer) xcl-user::subitems :key (cl:function (cl:lambda (xcl-user::x) (cl:first (cl:second (cl:second xcl-user::x))))) :test (cl:function eq)) (nconc xcl-user::subitems (list (list "To a file and a printer" (quote (quote (hardcopyimagew.tofile&printer))) "Sends image to a printer of your choosing, retaining the printer version of the file.")))) (cl:mapc (cl:function xcl-user::find-place-bm) xcl-user::subitems)))))) (cl:mapc (cl:function xcl-user::find-place-wm) |WindowMenuCommands|) (cl:mapc (cl:function xcl-user::find-place-bm) |BackgroundMenuCommands|) (cl:setq |WindowMenu| nil) (cl:setq |BackgroundMenu| nil))) (declare\: donteval@load docopy (install-option) ) (putprops hardcopy-retain copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil))) stop \ No newline at end of file diff --git a/lispusers/HARDCOPY-RETAIN.TEDIT b/lispusers/HARDCOPY-RETAIN.TEDIT new file mode 100644 index 00000000..562a0998 Binary files /dev/null and b/lispusers/HARDCOPY-RETAIN.TEDIT differ diff --git a/lispusers/HASHBUFFER b/lispusers/HASHBUFFER new file mode 100644 index 00000000..cef9297c --- /dev/null +++ b/lispusers/HASHBUFFER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Sep-87 11:26:06" |{MCS:MCS:STANFORD}HASHBUFFER.;6| 6916 changes to%: (VARS HASHBUFFERCOMS) previous date%: " 3-Sep-87 17:06:23" |{MCS:MCS:STANFORD}HASHBUFFER.;5|) (* " Copyright (c) 1985, 1986, 1987 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT HASHBUFFERCOMS) (RPAQQ HASHBUFFERCOMS ((FNS CREATEHASHBUFFER OPENHASHBUFFER CLOSEHASHBUFFER GETHASHBUFFER PUTHASHBUFFER) (INITVARS (EMPTYHASHENTRYMARKER '**EMPTYHASHENTRY**)) (GLOBALVARS EMPTYHASHENTRYMARKER) (FNS HASHARRAY.TO.HASHFILE HASHFILE.TO.HASHARRAY) (DECLARE%: DONTCOPY (RECORDS HASHBUFFER)) (FILES HASH))) (DEFINEQ (CREATEHASHBUFFER [LAMBDA (FILE VALUETYPE ITEMLENGTH %#ENTRIES OVERFLOW HASHBITSFN EQUIVFN) (* cdl " 1-May-87 16:08") (DECLARE (GLOBALVARS HASHFILEDEFAULTSIZE)) (PROG [(HASHBUFFER (create HASHBUFFER HASHFILE _ (CREATEHASHFILE FILE VALUETYPE ITEMLENGTH %#ENTRIES) HASHARRAY _ (HASHARRAY (OR %#ENTRIES HASHFILEDEFAULTSIZE) OVERFLOW HASHBITSFN EQUIVFN] (replace (HASHBUFFER ACCESS) of HASHBUFFER with (GETFILEINFO (with HashFile (with HASHBUFFER HASHBUFFER HASHFILE) Stream) 'ACCESS)) (RETURN HASHBUFFER]) (OPENHASHBUFFER [LAMBDA (FILE ACCESS MINKEYS OVERFLOW HASHBITSFN EQUIVFN) (* cdl " 1-May-87 16:10") (PROG [(HASHBUFFER (create HASHBUFFER HASHFILE _ (OPENHASHFILE FILE ACCESS] (replace (HASHBUFFER HASHARRAY) of HASHBUFFER with (HASHARRAY (OR MINKEYS (with HashFile (with HASHBUFFER HASHBUFFER HASHFILE) %#Entries)) OVERFLOW HASHBITSFN EQUIVFN)) (replace (HASHBUFFER ACCESS) of HASHBUFFER with (GETFILEINFO (with HashFile (with HASHBUFFER HASHBUFFER HASHFILE) Stream) 'ACCESS)) (RETURN HASHBUFFER]) (CLOSEHASHBUFFER [LAMBDA (HASHBUFFER FILEONLY?) (* cdl " 1-May-87 16:21") (with HASHBUFFER HASHBUFFER (PROG1 (HASHFILEPROP HASHFILE 'NAME) (CLOSEHASHFILE HASHFILE) (if (NOT FILEONLY?) then (SETQ HASHARRAY NIL]) (GETHASHBUFFER [LAMBDA (KEY HASHBUFFER) (* cdl "24-Oct-85 08:37") (PROG (VALUE) (with HASHBUFFER HASHBUFFER (if (EQ EMPTYHASHENTRYMARKER (SETQ VALUE (GETHASH KEY HASHARRAY ))) then (RETURN) elseif VALUE then (RETURN VALUE) elseif (SETQ VALUE (GETHASHFILE KEY HASHFILE)) then (PUTHASH KEY VALUE HASHARRAY) (RETURN VALUE) else (PUTHASH KEY EMPTYHASHENTRYMARKER HASHARRAY]) (PUTHASHBUFFER [LAMBDA (KEY VALUE HASHBUFFER) (* cdl "24-Oct-85 08:26") (with HASHBUFFER HASHBUFFER (if (NEQ ACCESS 'INPUT) then (PUTHASHFILE KEY VALUE HASHFILE)) (PUTHASH KEY VALUE HASHARRAY]) ) (RPAQ? EMPTYHASHENTRYMARKER '**EMPTYHASHENTRY**) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EMPTYHASHENTRYMARKER) ) (DEFINEQ (HASHARRAY.TO.HASHFILE [LAMBDA (HASHARRAY HASHFILE TESTFN) (* ; "Edited 3-Sep-87 17:05 by cdl") (DECLARE (SPECVARS HASHARRAY HASHFILE TESTFN)) (LET (REOPEN) (DECLARE (SPECVARS REOPEN)) [if (HASHFILEP HASHFILE) then (SETQ REOPEN T) else (SETQ HASHFILE (CREATEHASHFILE HASHFILE NIL NIL (HARRAYPROP HASHARRAY 'NUMKEYS] [RESETLST [RESETSAVE NIL `(CLOSEHASHFILE ,HASHFILE ,REOPEN] (MAPHASH HASHARRAY (FUNCTION (LAMBDA (VALUE KEY) (if (OR (NULL TESTFN) (APPLY* TESTFN KEY VALUE HASHARRAY HASHFILE)) then (PUTHASHFILE KEY VALUE HASHFILE] (if REOPEN then HASHFILE else (with HashFile HASHFILE File]) (HASHFILE.TO.HASHARRAY [LAMBDA (HASHFILE HASHARRAY TESTFN) (* ; "Edited 3-Sep-87 17:05 by cdl") (DECLARE (SPECVARS HASHFILE HASHARRAY TESTFN)) (LET (REOPEN) (DECLARE (SPECVARS REOPEN)) [if (HASHFILEP HASHFILE) then (SETQ REOPEN T) else (SETQ HASHFILE (OPENHASHFILE HASHFILE 'INPUT] [if (NULL HASHARRAY) then (SETQ HASHARRAY (with HashFile HASHFILE (HASHARRAY %#Entries] [RESETLST [RESETSAVE NIL `(CLOSEHASHFILE ,HASHFILE ,REOPEN] (MAPHASHFILE HASHFILE (FUNCTION (LAMBDA (KEY VALUE) (if (OR (NULL TESTFN) (APPLY* TESTFN KEY VALUE HASHFILE HASHARRAY )) then (PUTHASH KEY VALUE HASHARRAY] HASHARRAY]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD HASHBUFFER (HASHARRAY HASHFILE ACCESS)) ) ) (FILESLOAD HASH) (PUTPROPS HASHBUFFER COPYRIGHT ("Stanford University" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (848 4618 (CREATEHASHBUFFER 858 . 1987) (OPENHASHBUFFER 1989 . 3081) (CLOSEHASHBUFFER 3083 . 3472) (GETHASHBUFFER 3474 . 4317) (PUTHASHBUFFER 4319 . 4616)) (4745 6703 ( HASHARRAY.TO.HASHFILE 4755 . 5690) (HASHFILE.TO.HASHARRAY 5692 . 6701))))) STOP \ No newline at end of file diff --git a/lispusers/HASHBUFFER.TEDIT b/lispusers/HASHBUFFER.TEDIT new file mode 100644 index 00000000..63249b5f Binary files /dev/null and b/lispusers/HASHBUFFER.TEDIT differ diff --git a/lispusers/HASHDATUM b/lispusers/HASHDATUM new file mode 100644 index 00000000..4a2dcbd9 --- /dev/null +++ b/lispusers/HASHDATUM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jul-88 14:35:59" |{MCS:MCS:STANFORD}HASHDATUM.;4| 3829 changes to%: (VARS HASHDATUMCOMS) (FNS GETHASHTEDIT) previous date%: "15-Sep-87 11:25:28" |{MCS:MCS:STANFORD}HASHDATUM.;3|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT HASHDATUMCOMS) (RPAQQ HASHDATUMCOMS ((FNS GETHASHDATUM PUTHASHDATUM) (MACROS GETHASHBITMAP PUTHASHBITMAP GETHASHBINARYBITMAP PUTHASHBINARYBITMAP GETHASHGRAPH PUTHASHGRAPH GETHASHUGLY PUTHASHUGLY PUTHASHTEDIT) (FNS GETHASHTEDIT \WRITEBM) (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (LOADCOMP) HASH)) (FILES HASH))) (DEFINEQ (GETHASHDATUM [LAMBDA (KEY HASHFILE READFN) (* cdl "28-Jun-85 10:07") (PROG ((HASHTEXTPTR (GETHASHFILE KEY HASHFILE))) (if (type? HashTextPtr HASHTEXTPTR) then (with HashFile HASHFILE (with HashTextPtr HASHTEXTPTR (SETFILEPTR Stream Start)) (RETURN (APPLY* READFN Stream]) (PUTHASHDATUM [LAMBDA (KEY DATA HASHFILE PRINTFN) (* cdl "28-Jun-85 10:17") (with HashFile (SETQ HASHFILE (GTHASHFILE HASHFILE T)) (SETFILEPTR Stream -1) (PROG [(HASHTEXTPTR (create HashTextPtr Start _ (GETEOFPTR Stream] (with HashTextPtr HASHTEXTPTR (APPLY* PRINTFN DATA Stream) (SETQ End (GETEOFPTR Stream))) (RETURN (PUTHASHFILE KEY HASHTEXTPTR HASHFILE]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS GETHASHBITMAP MACRO ((KEY HASHFILE) (GETHASHDATUM KEY HASHFILE (FUNCTION READBITMAP] [PUTPROPS PUTHASHBITMAP MACRO ((KEY BITMAP HASHFILE) (PUTHASHDATUM KEY BITMAP HASHFILE (FUNCTION PRINTBITMAP] [PUTPROPS GETHASHBINARYBITMAP MACRO ((KEY HASHFILE) (GETHASHDATUM KEY HASHFILE (FUNCTION READBM] [PUTPROPS PUTHASHBINARYBITMAP MACRO ((KEY BITMAP HASHFILE) (PUTHASHDATUM KEY BITMAP HASHFILE (FUNCTION \WRITEBM] [PUTPROPS GETHASHGRAPH MACRO ((KEY HASHFILE) (GETHASHDATUM KEY HASHFILE (FUNCTION READGRAPH] [PUTPROPS PUTHASHGRAPH MACRO ((KEY GRAPH HASHFILE) (PUTHASHDATUM KEY GRAPH HASHFILE (FUNCTION DUMPGRAPH] [PUTPROPS GETHASHUGLY MACRO ((KEY HASHFILE) (GETHASHDATUM KEY HASHFILE (FUNCTION HREAD] [PUTPROPS PUTHASHUGLY MACRO ((KEY UGLYVAR HASHFILE) (PUTHASHDATUM KEY UGLYVAR HASHFILE (FUNCTION HPRINT] [PUTPROPS PUTHASHTEDIT MACRO ((KEY TEXTOBJ HASHFILE) (PUTHASHDATUM KEY TEXTOBJ HASHFILE (FUNCTION TEDIT.PUT.PCTB] ) (DEFINEQ (GETHASHTEDIT [LAMBDA (KEY HASHFILE WINDOW PROPS) (* ; "Edited 12-Jul-88 14:33 by cdl") (with HashTextPtr (GETHASHFILE KEY HASHFILE) (OPENTEXTSTREAM (OPENSTREAM (with HashFile HASHFILE File) 'INPUT) WINDOW Start End PROPS]) (\WRITEBM [LAMBDA (BITMAP STREAM) (* cdl "24-Oct-85 10:51") (WRITEBM STREAM BITMAP]) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILESLOAD (LOADCOMP) HASH) ) (FILESLOAD HASH) (PUTPROPS HASHDATUM COPYRIGHT ("Stanford University" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (956 1880 (GETHASHDATUM 966 . 1354) (PUTHASHDATUM 1356 . 1878)) (3157 3639 (GETHASHTEDIT 3167 . 3498) (\WRITEBM 3500 . 3637))))) STOP \ No newline at end of file diff --git a/lispusers/HASHDATUM.TEDIT b/lispusers/HASHDATUM.TEDIT new file mode 100644 index 00000000..5c2b3d44 Binary files /dev/null and b/lispusers/HASHDATUM.TEDIT differ diff --git a/lispusers/HEADLINE b/lispusers/HEADLINE new file mode 100644 index 00000000..635d8e51 --- /dev/null +++ b/lispusers/HEADLINE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 2-May-88 13:47:17" {ERINYES}MEDLEY>HEADLINE.;2 8211 changes to%: (FNS CLOSE.HEADLINES BANNER.MAKE) previous date%: " 1-Apr-86 15:45:51" {ERINYES}KOTO>LISPUSERS>HEADLINE.;1) (* " Copyright (c) 1985, 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT HEADLINECOMS) (RPAQQ HEADLINECOMS ((FNS BANNER BANNER.ARRAY BANNER.MAKE BILLBOARD CLOSE.HEADLINES HEADLINE HEADLINE.ABSTRACTER HEADLINE.ARRAY HEADLINE.MAKE HEADLINE.RECOGNIZER HEADLINE.RECONSTITUTER)) ) (DEFINEQ (BANNER (LAMBDA (PHRASE FONT POSITION ALIGNMENT) (* DAHJr " 4-Mar-86 11:09") (PROG (TITLE FNT REFERENCE.POINT XALIGNMENT YALIGNMENT W) (SETQ TITLE (COND ((NULL PHRASE) "The British are coming") (T (MKSTRING PHRASE)))) (SETQ FNT (OR FONT (QUOTE (TIMESROMAND 36)))) (SETQ REFERENCE.POINT (OR POSITION (PROGN (GETMOUSESTATE) (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)))) (SETQ XALIGNMENT (COND (ALIGNMENT (COND ((LISTP ALIGNMENT) (CAR ALIGNMENT)) (T ALIGNMENT))) (T (QUOTE CENTER)))) (SETQ YALIGNMENT (COND (ALIGNMENT (COND ((LISTP ALIGNMENT) (CDR ALIGNMENT)) (T ALIGNMENT))) (T (QUOTE CENTER)))) (SETQ W (BANNER.MAKE TITLE FNT REFERENCE.POINT (CONS XALIGNMENT YALIGNMENT))) (COND ((NULL POSITION) (MOVEW W))))) ) (BANNER.ARRAY (LAMBDA (TITLES ALIGNMENT SEPARATION POSITION) (* DAHJr " 1-Apr-86 15:34") (* edited%: " 5-AUG-82 10:42") (PROG ((X (COND (POSITION (FETCH (POSITION XCOORD) OF POSITION)) (T 50))) (ALIGN (OR ALIGNMENT (QUOTE CENTER))) (SEP (OR SEPARATION 70))) (for TITLE in TITLES do (BANNER (CAR TITLE) (CADR TITLE) (create POSITION XCOORD _ X YCOORD _ (COND (POSITION (fetch (POSITION XCOORD) of POSITION)) (T (SELECTQ ALIGN (BOTTOM 30) (CENTER 400) (TOP 750) (SHOULDNT))))) (CONS (QUOTE LEFT) ALIGN)) (SETQ X (IPLUS X SEP))) NIL)) ) (BANNER.MAKE (LAMBDA (TITLE FONT REFERENCE.POINT ALIGNMENT) (* DAHJr " 4-Mar-86 11:04") (PROG (W FNTDESC FONT.HEIGHT REGION DSP BOUNDARY BORDER INFO MAX.WIDTH CHAR WIDTH HEIGHT XALIGNMENT YALIGNMENT LEFT BOTTOM OFF.SCREEN PLEFT PBOTTOM) (SETQ FNTDESC (FONTCREATE FONT)) (SETQ FONT.HEIGHT (FONTHEIGHT FNTDESC)) (SETQ BORDER 4) (SETQ BOUNDARY 4) (SETQ INFO (for I to (NCHARS TITLE) collect (CONS (SETQ CHAR (NTHCHAR TITLE I)) (STRINGWIDTH CHAR FNTDESC)))) (SETQ MAX.WIDTH (OR (CDR (for ELEM in INFO largest (CDR ELEM))) 0)) (SETQ WIDTH (IPLUS BORDER BORDER BOUNDARY BOUNDARY MAX.WIDTH)) (SETQ HEIGHT (IPLUS BORDER BORDER BOUNDARY BOUNDARY (ITIMES (LENGTH INFO) FONT.HEIGHT))) (SETQ XALIGNMENT (CAR ALIGNMENT)) (SETQ YALIGNMENT (CDR ALIGNMENT)) (SETQ LEFT (SELECTQ XALIGNMENT ((LEFT BOTTOM LOW) (fetch (POSITION XCOORD) of REFERENCE.POINT)) ((CENTER MIDDLE) (IDIFFERENCE (fetch (POSITION XCOORD) of REFERENCE.POINT) (IQUOTIENT WIDTH 2))) ((RIGHT TOP HIGH) (IDIFFERENCE (fetch (POSITION XCOORD) of REFERENCE.POINT) WIDTH)) (SHOULDNT))) (SETQ BOTTOM (SELECTQ YALIGNMENT ((LEFT BOTTOM LOW) (fetch (POSITION YCOORD) of REFERENCE.POINT)) ((CENTER MIDDLE) (IDIFFERENCE (fetch (POSITION YCOORD) of REFERENCE.POINT) (IQUOTIENT HEIGHT 2))) ((RIGHT TOP HIGH) (IDIFFERENCE (fetch (POSITION YCOORD) of REFERENCE.POINT) HEIGHT)) (SHOULDNT))) (SETQ PLEFT (MAX 0 (MIN LEFT (IDIFFERENCE SCREENWIDTH WIDTH)))) (SETQ PBOTTOM (MAX 0 (MIN BOTTOM (IDIFFERENCE SCREENHEIGHT HEIGHT)))) (SETQ REGION (create REGION LEFT _ PLEFT BOTTOM _ PBOTTOM WIDTH _ WIDTH HEIGHT _ HEIGHT)) (SETQ W (CREATEW REGION NIL BORDER)) (WINDOWPROP W (QUOTE HEADLINE.TYPE) (QUOTE BANNER)) (WINDOWPROP W (QUOTE HEADLINE.FONT) FONT) (WINDOWPROP W (QUOTE HEADLINE.TITLE) TITLE) (WINDOWPROP W (QUOTE HEADLINE.ALIGNMENT) ALIGNMENT) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION MOVEW)) (WINDOWPROP W (QUOTE RESHAPEFN) (QUOTE DON'T)) (SETQ DSP (WINDOWPROP W (QUOTE DSP))) (DSPFONT FNTDESC DSP) (for ELEM in INFO as I from (SUB1 (LENGTH INFO)) by -1 do (MOVETO (IPLUS BOUNDARY (IQUOTIENT (IDIFFERENCE MAX.WIDTH (CDR ELEM)) 2)) (IPLUS BOUNDARY (ITIMES I FONT.HEIGHT) (FONTDESCENT FNTDESC)) W) (PRIN3 (CAR ELEM) W)) (RETURN W))) ) (BILLBOARD (LAMBDA (TITLES ALIGNMENT SEPARATION POSITION) (* DAHJr " 1-Apr-86 15:45") (* edited%: " 5-AUG-82 10:42") (HEADLINE.ARRAY TITLES ALIGNMENT SEPARATION POSITION)) ) (CLOSE.HEADLINES (LAMBDA NIL (* ; "Edited 2-May-88 13:47 by Briggs") (* ;; "changed ACTIVEWINDOWS to OPENWINDOWS for Lyric & beyond") (for WINDOW in (OPENWINDOWS) do (COND ((WINDOWPROP WINDOW (QUOTE HEADLINE.TYPE)) (CLOSEW WINDOW))))) ) (HEADLINE (LAMBDA (PHRASE FONT POSITION ALIGNMENT) (* DAHJr " 4-Mar-86 11:10") (PROG (TITLE FNT FNTDESC REFERENCE.POINT XALIGNMENT YALIGNMENT W) (SETQ TITLE (COND ((NULL PHRASE) "The British are coming") (T (MKSTRING PHRASE)))) (SETQ FNT (OR FONT (QUOTE (TIMESROMAND 36)))) (SETQ REFERENCE.POINT (OR POSITION (PROGN (GETMOUSESTATE) (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)))) (SETQ XALIGNMENT (COND (ALIGNMENT (COND ((LISTP ALIGNMENT) (CAR ALIGNMENT)) (T ALIGNMENT))) (T (QUOTE CENTER)))) (SETQ YALIGNMENT (COND (ALIGNMENT (COND ((LISTP ALIGNMENT) (CDR ALIGNMENT)) (T ALIGNMENT))) (T (QUOTE CENTER)))) (SETQ W (HEADLINE.MAKE TITLE FNT REFERENCE.POINT (CONS XALIGNMENT YALIGNMENT))) (COND ((NULL POSITION) (MOVEW W))))) ) (HEADLINE.ABSTRACTER (LAMBDA (WINDOW) (* DAHJr " 4-Mar-86 11:15") (LIST (WINDOWPROP WINDOW (QUOTE HEADLINE.TYPE)) (WINDOWPROP WINDOW (QUOTE HEADLINE.TITLE)) (WINDOWPROP WINDOW (QUOTE HEADLINE.FONT)) (WINDOWPROP WINDOW (QUOTE HEADLINE.ALIGNMENT)))) ) (HEADLINE.ARRAY (LAMBDA (TITLES ALIGNMENT SEPARATION POSITION) (* edited%: " 5-AUG-82 10:42") (PROG ((Y (COND (POSITION (FETCH (POSITION YCOORD) OF POSITION)) (T 670))) (ALIGN (OR ALIGNMENT (QUOTE CENTER))) (SEP (OR SEPARATION 70))) (for TITLE in TITLES do (HEADLINE (CAR TITLE) (CADR TITLE) (create POSITION XCOORD _ (COND (POSITION (fetch (POSITION XCOORD) of POSITION)) (T (SELECTQ ALIGN (LEFT 30) (CENTER 500) (RIGHT 1000) (SHOULDNT)))) YCOORD _ Y) (CONS ALIGN (QUOTE BOTTOM))) (SETQ Y (IDIFFERENCE Y SEP))) NIL)) ) (HEADLINE.MAKE (LAMBDA (TITLE FONT REFERENCE.POINT ALIGNMENT) (* DAHJr " 4-Mar-86 11:04") (PROG (FNTDESC BOUNDARY BORDER XALIGNMENT YALIGNMENT WIDTH HEIGHT LEFT BOTTOM REGION W DSP) (SETQ FNTDESC (FONTCREATE FONT)) (SETQ BORDER 4) (SETQ BOUNDARY 4) (SETQ XALIGNMENT (CAR ALIGNMENT)) (SETQ YALIGNMENT (CDR ALIGNMENT)) (SETQ WIDTH (IPLUS BORDER BORDER BOUNDARY BOUNDARY (STRINGWIDTH TITLE FNTDESC))) (SETQ HEIGHT (IPLUS BORDER BORDER BOUNDARY BOUNDARY (FONTHEIGHT FNTDESC))) (SETQ LEFT (SELECTQ XALIGNMENT ((LEFT BOTTOM LOW) (fetch (POSITION XCOORD) of REFERENCE.POINT)) ((CENTER MIDDLE) (IDIFFERENCE (fetch (POSITION XCOORD) of REFERENCE.POINT) (IQUOTIENT WIDTH 2))) ((RIGHT TOP HIGH) (IDIFFERENCE (fetch (POSITION XCOORD) of REFERENCE.POINT) WIDTH)) (SHOULDNT))) (SETQ BOTTOM (SELECTQ YALIGNMENT ((LEFT BOTTOM LOW) (fetch (POSITION YCOORD) of REFERENCE.POINT)) ((CENTER MIDDLE) (IDIFFERENCE (fetch (POSITION YCOORD) of REFERENCE.POINT) (IQUOTIENT HEIGHT 2))) ((RIGHT TOP HIGH) (IDIFFERENCE (fetch (POSITION YCOORD) of REFERENCE.POINT) HEIGHT)) (SHOULDNT))) (SETQ REGION (create REGION LEFT _ (MAX 0 (MIN LEFT (IDIFFERENCE SCREENWIDTH WIDTH))) BOTTOM _ (MAX 0 (MIN BOTTOM (IDIFFERENCE SCREENHEIGHT HEIGHT))) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (SETQ W (CREATEW REGION NIL BORDER)) (WINDOWPROP W (QUOTE HEADLINE.TYPE) (QUOTE HEADLINE)) (WINDOWPROP W (QUOTE HEADLINE.FONT) FONT) (WINDOWPROP W (QUOTE HEADLINE.TITLE) TITLE) (WINDOWPROP W (QUOTE HEADLINE.ALIGNMENT) ALIGNMENT) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION MOVEW)) (WINDOWPROP W (QUOTE RESHAPEFN) (QUOTE DON'T)) (SETQ DSP (WINDOWPROP W (QUOTE DSP))) (DSPFONT FNTDESC DSP) (MOVETO BOUNDARY (IPLUS BOUNDARY (FONTDESCENT FNTDESC)) W) (PRIN3 TITLE W) (RETURN W))) ) (HEADLINE.RECOGNIZER (LAMBDA (WINDOW) (WINDOWPROP WINDOW (QUOTE HEADLINE.TYPE)))) (HEADLINE.RECONSTITUTER (LAMBDA (DESCRIPTION) (* DAHJr " 4-Mar-86 11:19") (SELECTQ (CAR DESCRIPTION) (HEADLINE (HEADLINE.MAKE (CADR DESCRIPTION) (CADDR DESCRIPTION) (CONS 0 0) (CADDDR DESCRIPTION))) (BANNER (BANNER.MAKE (CADR DESCRIPTION) (CADDR DESCRIPTION) (CONS 0 0) (CADDDR DESCRIPTION))) NIL)) ) ) (PUTPROPS HEADLINE COPYRIGHT ("Xerox Corporation" 1985 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (602 8121 (BANNER 612 . 1341) (BANNER.ARRAY 1343 . 1880) (BANNER.MAKE 1882 . 4057) ( BILLBOARD 4059 . 4236) (CLOSE.HEADLINES 4238 . 4479) (HEADLINE 4481 . 5222) (HEADLINE.ABSTRACTER 5224 . 5477) (HEADLINE.ARRAY 5479 . 6002) (HEADLINE.MAKE 6004 . 7726) (HEADLINE.RECOGNIZER 7728 . 7813) ( HEADLINE.RECONSTITUTER 7815 . 8119))))) STOP \ No newline at end of file diff --git a/lispusers/HEADLINE.TEDIT b/lispusers/HEADLINE.TEDIT new file mode 100644 index 00000000..ada6db15 Binary files /dev/null and b/lispusers/HEADLINE.TEDIT differ diff --git a/lispusers/HELPSYS b/lispusers/HELPSYS new file mode 100644 index 00000000..655f5961 --- /dev/null +++ b/lispusers/HELPSYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 1-Oct-87 13:40:16" {ERINYES}LYRIC>HELPSYS.;4 16138 changes to%: (FUNCTIONS IRM.LOAD-GRAPH) previous date%: "14-Aug-87 17:39:39" {ERINYES}LYRIC>HELPSYS.;3) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT HELPSYSCOMS) (RPAQQ HELPSYSCOMS ((FILES DINFO HASH) (RECORDS IRMREFERENCE) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) DINFO HASH)) (COMS (COMMANDS "man") (FNS HELPSYS IRM.LOOKUP IRM.SMART.LOOKUP IRM.RESET) (INITVARS (IRM.HOST&DIR) (IRM.HASHFILE.NAME)) (GLOBALVARS IRM.HOST&DIR IRM.HASHFILE.NAME) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE HELPSYS) (QUOTE XHELPSYS) NIL T)))) (COMS (* ;;; "Interface to DInfo") (FNS IRM.GET.DINFOGRAPH IRM.DISPLAY.REF) (FUNCTIONS IRM.LOAD-GRAPH) (ADDVARS (DINFO.GRAPHS ("Interlisp-D Reference Manual" (IRM.GET.DINFOGRAPH T)))) (INITVARS (IRM.DINFOGRAPH)) (GLOBALVARS IRM.DINFOGRAPH) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (COND (IRM.HOST&DIR (SETQ IRM.DINFOGRAPH (IRM.LOAD-GRAPH)))))) (* ;;; "Cross reference imageobj") (FNS IRM.DISPLAY.CREF IRM.CREF.BOX IRM.PUT.CREF IRM.GET.CREF IRM.CREF.BUTTONEVENTFN) (INITVARS (IRM.CREF.FONT (FONTCREATE (QUOTE MODERN) 8 (QUOTE MRR))) (\IRM.CREF.IMAGEFNS (IMAGEFNSCREATE (FUNCTION IRM.DISPLAY.CREF) (FUNCTION IRM.CREF.BOX) (FUNCTION IRM.PUT.CREF) (FUNCTION IRM.GET.CREF) (FUNCTION NILL) (FUNCTION IRM.CREF.BUTTONEVENTFN)))) (GLOBALVARS IRM.CREF.FONT \IRM.CREF.IMAGEFNS)) (COMS (* ;;; "Internal functions and variables") (FNS \IRM.GET.REF \IRM.SMART.REF \IRM.CHOOSE.REF \IRM.WILD.REF \IRM.WILDCARD \IRM.WILD.MATCH \IRM.GET.HASHFILE \IRM.GET.KEYWORDS) (INITVARS (\IRM.HASHFILE) (\IRM.KEYWORDS)) (GLOBALVARS \IRM.HASHFILE \IRM.KEYWORDS) (FUNCTIONS \IRM.AROUND-EXIT) (ADDVARS (AROUNDEXITFNS \IRM.AROUND-EXIT)))) ) (FILESLOAD DINFO HASH) (DECLARE%: EVAL@COMPILE (RECORD IRMREFERENCE (* ;; "A reference to something in the IRM. There is a list of these for each entry in the index of the IRM. Each element of the list corresponds to one of the page references. These lists are stored under the ITEM in a hash file. ") (TYPE (* ; "The type of index entry -- typically a capitalized symbol in IL, eg. il:|Functions|. Yes, it's ugly.") ITEM (* ; "The name indexed") PRIMARYFLG (* ; "True iff this is the primary reference for this name/type") NODE (* ; "The ID of the node in the IRM DInfo graph containing this reference") CH# (* ; "The character number of the beginning of the reference. If unspecified we search for the first existence of NAME in the text of the node.")) (SYSTEM)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) DINFO HASH) ) (DEFCOMMAND "man" (ENTRY) "Lookup ENTRY in the IRM." (IRM.SMART.LOOKUP ENTRY)) (DEFINEQ (HELPSYS (LAMBDA (FN PROPS) (* drc%: "20-Jan-86 18:05") (if (NOT IRM.HOST&DIR) then (PROMPTPRINT "HELPSYS is unavailable. Set IRM.HOST&DIR.") NIL else (SELECTQ PROPS (ARGS (* HELPSYS is called by SMARTARGLIST to get args, but this implementation does not support that.) NIL) (FromDEdit (* from ? under EditCom) (IRM.LOOKUP (if (LISTP FN) then (CAR FN) else FN)) NIL) (NIL (* called by TTYIN when FN...? is typed.) (if (FGETD FN) then (IRM.LOOKUP FN (QUOTE Function)) elseif (for MACRO.TYPE in MACROPROPS thereis (GETPROP FN MACRO.TYPE)) then (IRM.LOOKUP FN (QUOTE Macro) IRMWINDOW) elseif (SELECTQ (CAR (GETPROP FN (QUOTE CLISPWORD))) (NIL) (FORWORD (IRM.LOOKUP FN (QUOTE I.S.Operator))) (RECORDTRAN (IRM.LOOKUP FN (QUOTE RecordOperator))) (PROGN (IRM.LOOKUP FN NIL))) else (BEEP))) NIL))) ) (IRM.LOOKUP (LAMBDA (KEYWORD TYPE GRAPH SMARTFLG) (* drc%: "17-Jan-86 14:09") (* * Does a lookup in the IRM index for KEYWORD (optionally of TYPE) and visits the DInfo node in GRAPH containing the reference. If SMARTFLG is non-NIL, wildcards will be enabled. GRAPH defaults to IRM.DINFOGRAPH.) (LET* ((GRAPH (if (type? DINFOGRAPH GRAPH) then GRAPH else (IRM.GET.DINFOGRAPH))) (KEYWORD (MKATOM (U-CASE KEYWORD))) (TYPE (MKATOM TYPE)) (WINDOW (fetch (DINFOGRAPH WINDOW) of GRAPH)) (MONITORLOCK (DINFOGRAPHPROP GRAPH (QUOTE MONITORLOCK)))) (OPENW WINDOW) (if (OBTAIN.MONITORLOCK MONITORLOCK T) then (RESETLST (RESETSAVE (TTYDISPLAYSTREAM (GETPROMPTWINDOW WINDOW))) (RESETSAVE NIL (LIST (QUOTE RELEASE.MONITORLOCK) MONITORLOCK)) (LET ((REF (if SMARTFLG then (\IRM.SMART.REF KEYWORD WINDOW) else (\IRM.GET.REF KEYWORD TYPE WINDOW)))) (AND REF (IRM.DISPLAY.REF REF GRAPH)))) else (FLASHWINDOW WINDOW)))) ) (IRM.SMART.LOOKUP (LAMBDA (KEYWORD GRAPH) (* drc%: " 6-Jan-86 14:50") (IRM.LOOKUP KEYWORD NIL GRAPH T))) (IRM.RESET (LAMBDA NIL (* drc%: "27-Jan-86 11:19") (if (type? DINFOGRAPH IRM.DINFOGRAPH) then (LET ((W (fetch (DINFOGRAPH WINDOW) of IRM.DINFOGRAPH))) (OPENW W) (CLOSEW W))) (SETQ IRM.DINFOGRAPH) (CLOSEHASHFILE \IRM.HASHFILE) (SETQ \IRM.HASHFILE) (SETQ \IRM.KEYWORDS)) ) ) (RPAQ? IRM.HOST&DIR ) (RPAQ? IRM.HASHFILE.NAME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRM.HOST&DIR IRM.HASHFILE.NAME) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD (QUOTE HELPSYS) (QUOTE XHELPSYS) NIL T) ) (* ;;; "Interface to DInfo") (DEFINEQ (IRM.GET.DINFOGRAPH (LAMBDA (FROM.BACKGROUND?) (* ; "Edited 14-Aug-87 17:31 by drc:") (* ;; "returns the DInfo graph for the IRM, ensuring that it has been setup.") (CL:UNLESS (TYPEP IRM.DINFOGRAPH (QUOTE DINFOGRAPH)) (* ;; "graph has not been loaded -- load it") (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (SETQ IRM.DINFOGRAPH (IRM.LOAD-GRAPH)))) (CL:UNLESS (WINDOWP (fetch (DINFOGRAPH WINDOW) of IRM.DINFOGRAPH)) (* ;; "graph has not been set up -- set it up") (DINFO IRM.DINFOGRAPH (CREATEW (GETBOXREGION 540 400 NIL NIL NIL "Specify region for IRM DInfo window") "IRM DInfo Graph") T (NOT FROM.BACKGROUND?))) IRM.DINFOGRAPH) ) (IRM.DISPLAY.REF (LAMBDA (REF GRAPH) (* drc%: "18-Jan-86 17:17") (* * visit the DInfo node of GRAPH containing REF) (LET ((NODE (FASSOC (fetch (IRMREFERENCE NODE) of REF) (fetch (DINFOGRAPH NODELST) of GRAPH)))) (if NODE then (DINFO.UPDATE GRAPH NODE (LIST (fetch (IRMREFERENCE ITEM) of REF) (fetch (IRMREFERENCE CH#) of REF))) else (PRINTOUT (GETPROMPTWINDOW WINDOW) T "Node not found!")))) ) ) (CL:DEFUN IRM.LOAD-GRAPH NIL (LET ((FILE (INFILEP (PACKFILENAME (QUOTE NAME) (QUOTE IRM) (QUOTE EXTENSION) (QUOTE DINFOGRAPH) (QUOTE BODY) IRM.HOST&DIR)))) (CL:IF FILE (DINFO.READ.GRAPH FILE) (PROG1 NIL (CL:WARN "IRM.DINFOGRAPH not found on ~S~%%Perhaps IL:IRM.HOST&DIR is set incorrectly" IRM.HOST&DIR))))) (ADDTOVAR DINFO.GRAPHS ("Interlisp-D Reference Manual" (IRM.GET.DINFOGRAPH T))) (RPAQ? IRM.DINFOGRAPH ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRM.DINFOGRAPH) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (COND (IRM.HOST&DIR (SETQ IRM.DINFOGRAPH (IRM.LOAD-GRAPH)))) ) (* ;;; "Cross reference imageobj") (DEFINEQ (IRM.DISPLAY.CREF (LAMBDA (IMAGEOBJ STREAM) (* drc%: " 7-Jan-86 13:41") (if (EQ (IMAGESTREAMTYPE STREAM) (QUOTE DISPLAY)) then (DSPFONT IRM.CREF.FONT STREAM) (LET* ((STRING (IMAGEOBJPROP IMAGEOBJ (QUOTE ITEM))) (STRINGREGION (STRINGREGION STRING STREAM)) (LEFT (ADD1 (fetch (REGION LEFT) of STRINGREGION))) (BOTTOM (fetch (REGION BOTTOM) of STRINGREGION)) (REGION (create REGION LEFT _ LEFT BOTTOM _ BOTTOM HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of STRINGREGION) 2) WIDTH _ (IPLUS (fetch (REGION WIDTH) of STRINGREGION) 6))) (TOP (fetch (REGION TOP) of REGION)) (RIGHT (fetch (REGION RIGHT) of REGION))) (IMAGEOBJPROP IMAGEOBJ (QUOTE REGION) REGION) (CENTERPRINTINREGION STRING REGION STREAM) (DRAWLINE LEFT BOTTOM LEFT (SUB1 TOP) 1 (QUOTE INVERT) STREAM) (DRAWLINE LEFT TOP (SUB1 RIGHT) TOP 1 (QUOTE INVERT) STREAM) (DRAWLINE RIGHT TOP RIGHT (ADD1 BOTTOM) 1 (QUOTE INVERT) STREAM) (DRAWLINE RIGHT BOTTOM (ADD1 LEFT) BOTTOM 1 (QUOTE INVERT) STREAM)) else (PRIN1 "page X.XX" STREAM))) ) (IRM.CREF.BOX (LAMBDA (IMAGEOBJ STREAM CURRENTX RIGHTMARGIN) (* drc%: " 7-Jan-86 13:42") (LET ((TYPE (IMAGESTREAMTYPE STREAM))) (create IMAGEBOX XSIZE _ (SELECTQ TYPE (DISPLAY (IPLUS (STRINGWIDTH (IMAGEOBJPROP IMAGEOBJ (QUOTE ITEM)) IRM.CREF.FONT) 8)) (STRINGWIDTH "page X.XX" STREAM)) YSIZE _ (SELECTQ TYPE (DISPLAY (IPLUS (FONTHEIGHT IRM.CREF.FONT) 4)) (FONTHEIGHT STREAM)) YDESC _ (SELECTQ TYPE (DISPLAY 4) 0) XKERN _ 0))) ) (IRM.PUT.CREF (LAMBDA (IMAGEOBJ STREAM) (* drc%: " 7-Jan-86 22:09") (PRIN2 (CONS (IMAGEOBJPROP IMAGEOBJ (QUOTE ITEM)) (IMAGEOBJPROP IMAGEOBJ (QUOTE TYPE))) STREAM)) ) (IRM.GET.CREF (LAMBDA (FILE TEXTSTREAM) (* drc%: " 2-Jan-86 17:45") (DECLARE (GLOBALVARS \IRM.CREF.IMAGEFNS)) (LET ((DATA (READ FILE)) (IMAGEOBJ (IMAGEOBJCREATE NIL \IRM.CREF.IMAGEFNS))) (IMAGEOBJPROP IMAGEOBJ (QUOTE ITEM) (CAR DATA)) (IMAGEOBJPROP IMAGEOBJ (QUOTE TYPE) (CDR DATA)) IMAGEOBJ)) ) (IRM.CREF.BUTTONEVENTFN (LAMBDA (IMAGEOBJ WSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) (* drc%: " 8-Jan-86 15:34") (* (INSPECT IMAGEOBJ)) (LET* ((BOUNDBOX (IMAGEOBJPROP IMAGEOBJ (QUOTE BOUNDBOX))) (WIDTH (fetch (IMAGEBOX XSIZE) of BOUNDBOX)) (HEIGHT (fetch (IMAGEBOX YSIZE) of BOUNDBOX)) (REGION (create REGION HEIGHT _ HEIGHT WIDTH _ WIDTH LEFT _ 0 BOTTOM _ 0))) (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW WINDOW)) (BLTSHADE BLACKSHADE WSTREAM 0 0 WIDTH HEIGHT (QUOTE INVERT)) (bind (N _ 0) (ITEM _ (IMAGEOBJPROP IMAGEOBJ (QUOTE ITEM))) (TYPE _ (IMAGEOBJPROP IMAGEOBJ (QUOTE TYPE))) until (OR (NOT (MOUSESTATE (OR LEFT MIDDLE))) (NOT (INSIDEP REGION (CURSORPOSITION NIL WSTREAM)))) do (BLOCK 100) (if (EQ (SETQ N (ADD1 N)) 10) then (printout T T "Will lookup " (IMAGEOBJPROP IMAGEOBJ (QUOTE ITEM)) (if TYPE then (CONCAT " as a " TYPE ".") else "."))) (GETMOUSESTATE) finally (CLEARW T) (if (INSIDEP REGION (CURSORPOSITION NIL WSTREAM)) then (ADD.PROCESS (LIST (QUOTE IRM.LOOKUP) (KWOTE ITEM) (KWOTE TYPE) (WINDOWPROP WINDOW (QUOTE DINFOGRAPH))) (QUOTE NAME) "IRM Cross Reference")) (BLTSHADE BLACKSHADE WSTREAM 0 0 WIDTH HEIGHT (QUOTE INVERT)) NIL)))) ) ) (RPAQ? IRM.CREF.FONT (FONTCREATE (QUOTE MODERN) 8 (QUOTE MRR))) (RPAQ? \IRM.CREF.IMAGEFNS (IMAGEFNSCREATE (FUNCTION IRM.DISPLAY.CREF) (FUNCTION IRM.CREF.BOX) (FUNCTION IRM.PUT.CREF) (FUNCTION IRM.GET.CREF) (FUNCTION NILL) (FUNCTION IRM.CREF.BUTTONEVENTFN)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRM.CREF.FONT \IRM.CREF.IMAGEFNS) ) (* ;;; "Internal functions and variables") (DEFINEQ (\IRM.GET.REF (LAMBDA (KEYWORD TYPE WINDOW) (* drc%: "18-Jan-86 17:13") (* * Returns an IRMREFERENCE for KEYWORD of optionally specified TYPE.) (\IRM.GET.HASHFILE) (* keywords in hashfile are all uppercased -- make's lookup case insensitive) (SETQ KEYWORD (MKATOM (U-CASE KEYWORD))) (LET (SAMEFLG REFS) (SETQ REFS (if (EQ KEYWORD (WINDOWPROP WINDOW (QUOTE PREVIOUS.KEYWORD))) then (* same keyword as last time, so fetch cached refs) (SETQ SAMEFLG T) (WINDOWPROP WINDOW (QUOTE IRM.REFS)) else (CLEARW T) (PRINTOUT T "Fetching reference(s) for " KEYWORD "...") (* hashfile contains a list of IRMREFERENCES for each keyword) (GETHASHFILE KEYWORD \IRM.HASHFILE))) (WINDOWPROP WINDOW (QUOTE PREVIOUS.KEYWORD) KEYWORD) (WINDOWPROP WINDOW (QUOTE IRM.REFS) REFS) (COND ((NULL REFS) (PRINTOUT T "None found.") NIL) ((NULL TYPE) (PRINTOUT T "OK.") (\IRM.CHOOSE.REF REFS KEYWORD)) ((for REF in REFS thereis (if (AND (EQ (fetch (IRMREFERENCE TYPE) of REF) TYPE) (fetch (IRMREFERENCE PRIMARYFLG) of REF)) then (PRINTOUT T "OK.") REF))) ((SETQ REFS (for REF in REFS join (if (EQ (fetch (IRMREFERENCE TYPE) of REF) TYPE) then (LIST REF) else NIL))) (PRINTOUT T "OK.") (\IRM.CHOOSE.REF REFS KEYWORD)) (T (PRINTOUT T "none found of type " TYPE ".") NIL)))) ) (\IRM.SMART.REF (LAMBDA (KEYWORD WINDOW) (* drc%: "18-Jan-86 17:40") (* * Returns IRMREFERENCE for KEYWORD. Allows wildcards in KEYWORD, and will try spelling correction.) (if (while (SETQ POS (STRPOS "*" KEYWORD (AND POS (ADD1 POS)))) bind POS when (NEQ (NTHCHAR KEYWORD (SUB1 POS)) (QUOTE %')) do (RETURN T) finally (* if not doing wildcarding then remove quotes when preceding asterisks) (SETQ KEYWORD (PACK (for TAIL on (UNPACK KEYWORD) when (NOT (AND (EQ (CAR TAIL) (QUOTE %')) (EQ (CADR TAIL) (QUOTE *)))) collect (CAR TAIL)))) (RETURN NIL)) then (* there's an unquoted asterisk -- it's wildcardin' time!) (\IRM.WILD.REF KEYWORD WINDOW) elseif \IRM.KEYWORDS then (* we've got possible matches loaded, so try spelling correction) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (LET ((CORRECTED (MISSPELLED? KEYWORD 50 \IRM.KEYWORDS T))) (if CORRECTED then (\IRM.GET.REF CORRECTED NIL WINDOW) else (PRINTOUT T T KEYWORD " Not in IRM") NIL))) else (* default to normal lookup) (\IRM.GET.REF KEYWORD NIL WINDOW))) ) (\IRM.CHOOSE.REF (LAMBDA (REFS KEYWORD) (* drc%: " 8-Jan-86 15:23") (if (NULL (CDR REFS)) then (CAR REFS) else (MENU (create MENU CENTERFLG _ T TITLE _ (MKSTRING KEYWORD) ITEMS _ (for REF in REFS collect (LIST (LET ((TYPE (fetch (IRMREFERENCE TYPE) of REF))) (if (fetch (IRMREFERENCE PRIMARYFLG) of REF) then (PACK* "* " TYPE " *") else TYPE)) (KWOTE REF) (CONCAT "Lookup " KEYWORD " as " (fetch (IRMREFERENCE TYPE) of REF)))))))) ) (\IRM.WILD.REF (LAMBDA (KEYWORD WINDOW) (* drc%: "18-Jan-86 17:04") (* * Return IRMREFERENCE matching wildcarded KEYWORD.) (OPENW WINDOW) (LET* (SAMEFLG (MATCHES (if (EQ KEYWORD (WINDOWPROP WINDOW (QUOTE IRM.WILD.KEYWORD))) then (* same as last time we wildcarded -- used cached matches.) (SETQ SAMEFLG T) (WINDOWPROP WINDOW (QUOTE IRM.MATCHES)) else (PROG2 (PRINTOUT (GETPROMPTWINDOW WINDOW) "...Matching wildcard(s)...") (\IRM.WILDCARD KEYWORD (\IRM.GET.KEYWORDS WINDOW)) (PRINTOUT (GETPROMPTWINDOW WINDOW) "OK"))))) (WINDOWPROP WINDOW (QUOTE IRM.WILD.KEYWORD) KEYWORD) (WINDOWPROP WINDOW (QUOTE IRM.MATCHES) MATCHES) (if MATCHES then (if (NULL (CDR MATCHES)) then (\IRM.GET.REF (CAR MATCHES) NIL WINDOW) else (OR SAMEFLG (WINDOWPROP WINDOW (QUOTE WILD.MENU) (create MENU ITEMS _ (for MATCH in MATCHES collect (LIST MATCH (KWOTE MATCH) (CONCAT "Will lookup " MATCH " in IRM if selected."))) CENTERFLG _ T TITLE _ KEYWORD))) (LET ((CHOICE (MENU (WINDOWPROP WINDOW (QUOTE WILD.MENU))))) (AND CHOICE (\IRM.GET.REF CHOICE NIL WINDOW)))) else (PRINTOUT (GETPROMPTWINDOW WINDOW) T "No matches found for " KEYWORD) NIL))) ) (\IRM.WILDCARD (LAMBDA (WILDATOM LIST) (* drc%: "18-Jan-86 17:00") (* * Returns those atoms in LIST which match WILDATOM.) (LET ((SCRATCH (CONS)) (WILDLIST (UNPACK WILDATOM))) (for ATOM in LIST when (\IRM.WILD.MATCH WILDLIST (DUNPACK ATOM SCRATCH)) collect ATOM))) ) (\IRM.WILD.MATCH (LAMBDA (WILDLIST LIST) (* drc%: "18-Jan-86 16:59") (* * predicate for whether wildcard containing WILDLIST matches LIST.) (COND ((AND (NULL WILDLIST) (NULL LIST))) ((AND (EQ (CAR WILDLIST) (QUOTE %')) (EQ (CADR WILDLIST) (QUOTE *))) (* found a quoted asterisk) (if (EQ (QUOTE *) (CAR LIST)) then (* and it matches) (\IRM.WILD.MATCH (CDDR WILDLIST) (CDR LIST)))) ((EQ (CAR WILDLIST) (QUOTE *)) (* found a real wildcard) (OR (NULL (CDR WILDLIST)) (for TAIL on LIST thereis (\IRM.WILD.MATCH (CDR WILDLIST) TAIL)))) ((EQ (CAR WILDLIST) (CAR LIST)) (* first chars match -- keep checking) (\IRM.WILD.MATCH (CDR WILDLIST) (CDR LIST))) (T NIL))) ) (\IRM.GET.HASHFILE (LAMBDA NIL (* drc%: "16-Dec-85 12:09") (OR (ARRAYP \IRM.HASHFILE) (SETQ \IRM.HASHFILE (OPENHASHFILE (OR IRM.HASHFILE.NAME (PACKFILENAME (QUOTE NAME) (QUOTE IRM) (QUOTE EXTENSION) (QUOTE HASHFILE) (QUOTE BODY) IRM.HOST&DIR)) (QUOTE INPUT))))) ) (\IRM.GET.KEYWORDS (LAMBDA (WINDOW QUIETFLG) (* drc%: "18-Jan-86 17:14") (* * keyword list is hidden in hashfile as its key is in lower case) (OR \IRM.KEYWORDS (PROGN (PRINTOUT (GETPROMPTWINDOW WINDOW) "Loading keyword list...") (\IRM.GET.HASHFILE) (SETQ \IRM.KEYWORDS (GETHASHFILE (QUOTE irm.keywords) (\IRM.GET.HASHFILE)))))) ) ) (RPAQ? \IRM.HASHFILE ) (RPAQ? \IRM.KEYWORDS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IRM.HASHFILE \IRM.KEYWORDS) ) (CL:DEFUN \IRM.AROUND-EXIT (EVENT) (CASE EVENT ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT) (AND \IRM.HASHFILE (CLOSEHASHFILE \IRM.HASHFILE))))) (ADDTOVAR AROUNDEXITFNS \IRM.AROUND-EXIT) (PUTPROPS HELPSYS COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2803 4933 (HELPSYS 2813 . 3640) (IRM.LOOKUP 3642 . 4545) (IRM.SMART.LOOKUP 4547 . 4655) (IRM.RESET 4657 . 4931)) (5193 6238 (IRM.GET.DINFOGRAPH 5203 . 5837) (IRM.DISPLAY.REF 5839 . 6236)) ( 6866 9945 (IRM.DISPLAY.CREF 6876 . 7865) (IRM.CREF.BOX 7867 . 8298) (IRM.PUT.CREF 8300 . 8470) ( IRM.GET.CREF 8472 . 8771) (IRM.CREF.BUTTONEVENTFN 8773 . 9943)) (10350 15724 (\IRM.GET.REF 10360 . 11605) (\IRM.SMART.REF 11607 . 12621) (\IRM.CHOOSE.REF 12623 . 13059) (\IRM.WILD.REF 13061 . 14183) ( \IRM.WILDCARD 14185 . 14455) (\IRM.WILD.MATCH 14457 . 15118) (\IRM.GET.HASHFILE 15120 . 15387) ( \IRM.GET.KEYWORDS 15389 . 15722))))) STOP \ No newline at end of file diff --git a/lispusers/HELPSYS.TEDIT b/lispusers/HELPSYS.TEDIT new file mode 100644 index 00000000..1248ed81 Binary files /dev/null and b/lispusers/HELPSYS.TEDIT differ diff --git a/lispusers/HGRAPH b/lispusers/HGRAPH new file mode 100644 index 00000000..5f12c76c --- /dev/null +++ b/lispusers/HGRAPH @@ -0,0 +1 @@ +(FILECREATED "24-Apr-87 19:08:21" {ERIS}KOTO>HGRAPH.;2 12562 changes to: (FNS HARDCOPYWHOLEGRAPH) previous date: "27-Jan-87 14:35:21" {PHYLUM}KOTO>HGRAPH.;1) (* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT HGRAPHCOMS) (RPAQQ HGRAPHCOMS ((FNS CEILING HARDCOPYDISPLAYGRAPH HARDCOPYWHOLEGRAPH) (P (MOVD (QUOTE HARDCOPYGRAPH) (QUOTE OLDHARDCOPYGRAPH)) (MOVD (QUOTE HARDCOPYWHOLEGRAPH) (QUOTE HARDCOPYGRAPH))) (* This is in order to fix the problem with borders on Interpress printers. I\t seems that you cannot bitblt anything thinner than 36 pixel onto an Interpress stream, why? Anyway, this fixes the problem by setting the border width to 36))) (DEFINEQ (CEILING [LAMBDA (NUMBER) (COND ((EQP (FIX NUMBER) NUMBER) NUMBER) (T (ADD1 (FIX NUMBER]) (HARDCOPYDISPLAYGRAPH [LAMBDA (GRAPH STREAM CLIP/REG TRANS) (* bbb "27-Jan-87 11:52") (* Displays GRAPH with coordinates system translated to TRANS on STREAM. POS=NIL is interpreted as 0\,0. Draws links first then labels so that lattices don't have lines through the labels.) (* This function is to be used together with  HARDCOPYWHOLEGRAPH\, it assumes that the scaling of  the graph is done already, for efficiency.) (PROG (SCALE (LINEWIDTH 1)) [OR (type? POSITION TRANS) (SETQ TRANS (CONSTANT (create POSITION XCOORD _ 0 YCOORD _ 0] (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT))) (COND ((DISPLAYSTREAMP STREAM) (* This is because PRIN3 on displaystreams can sometimes cause CR's to be output. GRAPHER/CENTERPRINTINAREA doesn't have the rightmargin kludge that the CENTERPRINTINAREA in MENU has.) (DSPRIGHTMARGIN 65000 STREAM)) (T (SETQ SCALE (DSPSCALE NIL STREAM)) [SETQ TRANS (create POSITION XCOORD _ (FIXR (FTIMES SCALE (fetch XCOORD of TRANS))) YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD of TRANS] (SETQ LINEWIDTH SCALE))) (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH)) (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) do (PRINTDISPLAYNODE N TRANS STREAM CLIP/REG]) (HARDCOPYWHOLEGRAPH [LAMBDA (GraphOrWindow File ImageType Translation NoAlignmentDots DontCloseStream) (* N.H.Briggs "24-Apr-87 19:07") (* * Hardcopy \a whole graph from \a window using as many pages as necessary) (* fix: moved SCALE/GRAPH outside the for loops for  effiency.) (* fix: moved SCALE.REGION inline, in order to avoid  the LOADFNS in the COMS list.) (LET ((Stream (OR (AND File (OPENP File (QUOTE OUTPUT)) File) (OPENIMAGESTREAM File ImageType))) (Graph (COND ((WINDOWP GraphOrWindow) (WINDOWPROP GraphOrWindow (QUOTE GRAPH))) (T GraphOrWindow))) GraphUnitsPerPageUnit PageUnitsPerGraphUnit GraphRegionInGraphUnits GraphRegionInPageUnits PageRegion PageWidthInGraphUnits PageHeightInGraphUnits GraphWidthInGraphUnits GraphHeightInGraphUnits CornerXOffsetInGraphUnits CornerYOffsetInGraphUnits PageScale LeftCenteringOffsetInGraphUnits BottomCenteringOffsetInGraphUnits PageNumberFont NumberOfXPages NumberOfYPages XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits LeftXAlignmentInPageUnits RightXAlignmentInPageUnits LowerYAlignmentInPageUnits UpperYAlignmentInPageUnits PageUnitsPerInch) (SETQ PageScale (DSPSCALE NIL Stream)) (SETQ GraphUnitsPerPageUnit (FQUOTIENT 1.0 PageScale)) (SETQ PageUnitsPerGraphUnit PageScale) (* 72 screen points per inch.) (SETQ PageUnitsPerInch (TIMES PageScale 72)) (SETQ GraphRegionInGraphUnits (GRAPHREGION Graph)) (SETQ CornerXOffsetInGraphUnits (MINUS (fetch (REGION LEFT) of GraphRegionInGraphUnits))) (SETQ CornerYOffsetInGraphUnits (MINUS (fetch (REGION BOTTOM) of GraphRegionInGraphUnits))) (* fix: moved SCALE.REGION inline, in order to avoid  the LOADFNS in the COMS list.) [SETQ GraphRegionInPageUnits (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT) of GraphRegionInGraphUnits) GraphUnitsPerPageUnit)) (FIXR (QUOTIENT (fetch (REGION BOTTOM) of GraphRegionInGraphUnits) GraphUnitsPerPageUnit)) (FIXR (QUOTIENT (fetch (REGION WIDTH) of GraphRegionInGraphUnits) GraphUnitsPerPageUnit)) (FIXR (QUOTIENT (fetch (REGION HEIGHT) of GraphRegionInGraphUnits) GraphUnitsPerPageUnit] (SELECTQ (IMAGESTREAMTYPE Stream) [INTERPRESS (* * Make the clipping region be the whole page on Interpress streams) (DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch 8.5) ) (FIXR (TIMES PageUnitsPerInch 11.0))) Stream) (* * Get rid of 1 inch margins except .5 inch at right and top) (SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch 8.0) ) (FIXR (TIMES PageUnitsPerInch 10.5] [PRESS (* * Make the clipping region be the whole page on Press streams) (DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch 8.5)) (FIXR (TIMES PageUnitsPerInch 11.0))) Stream) (* * Get rid of 1 inch margins except 1 inch at right and top) (SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch 7.5)) (FIXR (TIMES PageUnitsPerInch 10.0] (SETQ PageRegion (DSPCLIPPINGREGION NIL Stream))) (SETQ PageWidthInGraphUnits (TIMES (fetch (REGION WIDTH) of PageRegion) GraphUnitsPerPageUnit)) (SETQ PageHeightInGraphUnits (TIMES (fetch (REGION HEIGHT) of PageRegion) GraphUnitsPerPageUnit)) (SETQ GraphWidthInGraphUnits (fetch (REGION WIDTH) of GraphRegionInGraphUnits)) (SETQ GraphHeightInGraphUnits (fetch (REGION HEIGHT) of GraphRegionInGraphUnits)) (SETQ BottomCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageHeightInGraphUnits (REMAINDER GraphHeightInGraphUnits PageHeightInGraphUnits)) 1.75)) (SETQ LeftCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageWidthInGraphUnits (REMAINDER GraphWidthInGraphUnits PageWidthInGraphUnits)) 1.75)) (SETQ NumberOfYPages (CEILING (QUOTIENT GraphHeightInGraphUnits PageHeightInGraphUnits) )) (SETQ NumberOfXPages (CEILING (QUOTIENT GraphWidthInGraphUnits PageWidthInGraphUnits))) (SETQ PageNumberFont (FONTCREATE (QUOTE MODERN) 6)) (* * The page numbers are \a quarter of in after the edge of the printing edge and are in the upper right hand  corner of the page. The pages are printed row-wise and no page numbers are printed on the last page. The page numbers are positioned .25 inch to the right of the right edge of the page region and .35 inch up from the top of the page region. The alignment dots are .25 inch to the right of the right edge of the page region and .25  inch up from the page region.) (SETQ XPageNumberPositionInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion) (TIMES PageUnitsPerInch .25))) (SETQ YPageNumberPositionInPageUnits (PLUS (fetch (REGION TOP) of PageRegion) (TIMES PageUnitsPerInch .35))) (SETQ LeftXAlignmentInPageUnits (TIMES PageUnitsPerInch .25)) (SETQ RightXAlignmentInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion) (TIMES PageUnitsPerInch .25))) (SETQ LowerYAlignmentInPageUnits (TIMES PageUnitsPerInch .25)) (SETQ UpperYAlignmentInPageUnits (PLUS (fetch (REGION TOP) of PageRegion) (TIMES PageUnitsPerInch .25))) (* Latest fix: moved SCALE/GRAPH outside the for loops for effiency.) (SETQ Graph (SCALE/GRAPH Graph Stream PageScale)) [for BottomOfPageInGraphUnits from 0 to GraphHeightInGraphUnits by PageHeightInGraphUnits as YPageNumber from 1 do (for LeftOfPageInGraphUnits from 0 to GraphWidthInGraphUnits by PageWidthInGraphUnits as XPageNumber from 1 do [HARDCOPYDISPLAYGRAPH Graph Stream (DSPCLIPPINGREGION NIL Stream) (create POSITION XCOORD _ (FIXR (PLUS CornerXOffsetInGraphUnits LeftCenteringOffsetInGraphUnits (MINUS LeftOfPageInGraphUnits))) YCOORD _ (FIXR (PLUS BottomCenteringOffsetInGraphUnits CornerYOffsetInGraphUnits (MINUS BottomOfPageInGraphUnits] (* * Print the alignment points) [COND ((NOT NoAlignmentDots) (* * The lower left page should not have \a dot in the lower left corner. Similarly for other corner pages.) (COND ((NOT (AND (EQ XPageNumber 1) (EQ YPageNumber 1))) (MOVETO LeftXAlignmentInPageUnits LowerYAlignmentInPageUnits Stream) (printout Stream "."))) (COND ((NOT (AND (EQ XPageNumber NumberOfXPages) (EQ YPageNumber 1))) (MOVETO RightXAlignmentInPageUnits LowerYAlignmentInPageUnits Stream) (printout Stream "."))) (COND ((NOT (AND (EQ YPageNumber NumberOfYPages) (EQ XPageNumber 1))) (MOVETO LeftXAlignmentInPageUnits UpperYAlignmentInPageUnits Stream) (printout Stream "."))) (COND ((NOT (AND (EQ XPageNumber NumberOfXPages) (EQ YPageNumber NumberOfYPages))) (MOVETO RightXAlignmentInPageUnits UpperYAlignmentInPageUnits Stream) (printout Stream "."] (COND ((NOT (AND (EQ XPageNumber NumberOfXPages) (EQ YPageNumber NumberOfYPages))) (* Not on the very last page) (DSPFONT PageNumberFont Stream) (MOVETO XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits Stream) (printout Stream XPageNumber "," YPageNumber) (* Print the page number) (DSPNEWPAGE Stream] (COND ((NOT DontCloseStream) (CLOSEF Stream]) ) (MOVD (QUOTE HARDCOPYGRAPH) (QUOTE OLDHARDCOPYGRAPH)) (MOVD (QUOTE HARDCOPYWHOLEGRAPH) (QUOTE HARDCOPYGRAPH)) (* This is in order to fix the problem with borders on Interpress printers. I\t seems that you cannot bitblt anything thinner than 36 pixel onto an Interpress stream, why? Anyway, this fixes the problem by setting the border width to 36) (PUTPROPS HGRAPH COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (779 12115 (CEILING 789 . 928) (HARDCOPYDISPLAYGRAPH 930 . 2653) (HARDCOPYWHOLEGRAPH 2655 . 12113))))) STOP \ No newline at end of file diff --git a/lispusers/HOSTUP b/lispusers/HOSTUP new file mode 100644 index 00000000..ce793e0d --- /dev/null +++ b/lispusers/HOSTUP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Oct-89 17:18:44" {ICE}LISPUSERS>MEDLEY>HOSTUP.;1 9510 changes to%: (VARS HOSTUPCOMS) previous date%: "19-Oct-89 16:52:50" {ICE}LISPUSERS>MEDLEY>HOSTUP.;1) (* " Copyright (c) 1988, 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT HOSTUPCOMS) (RPAQQ HOSTUPCOMS ((FNS HOSTUP?) (INITVARS (HOSTUP.TIMEOUT 15000) (HOSTUP.RETRYCNT 5)) (GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT) (DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE (FILES SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES until (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS 'BODY (SETQ $$VAL (PACKFILENAME 'HOST (FILENAMEFIELD D 'HOST) 'DIRECTORY (CONCAT "LISP>" MAKESYSNAME ">SOURCES"] LLNSDECLS (LOADCOMP) LLNS)))) (DEFINEQ (HOSTUP? [LAMBDA (name) (* ; "Edited 19-Oct-89 16:51 by koomen") (* ;; "Adapted from FILECACHE function \FCACHE.HOSTUP?") (* ;; "Uses the globalvar HOSTUP.TIMEOUT (default: 15,000 msecs) to limit total wait time, and the globalvar HOSTUP.RETRYCNT (default: 5 times) to limit the number of retries")  (* smL " 3-Sep-86 16:04") (* ;;; "Try to determine if the host if able to respond") (LET* [(DEV (\GETDEVICEFROMNAME name T NIL)) (retryCount (MAX 1 (FIX HOSTUP.RETRYCNT))) (initialInterval (FIX (QUOTIENT (MAX 1000 HOSTUP.TIMEOUT) (SUB1 (LSH 1 retryCount] (SELECTQ (if DEV then (* ;; "use real DEV to determine the DEV type") (SELECTQ (fetch OPENFILE of DEV) ((\LEAF.OPENFILE \FTP.OPENFILE) 'LEAF) (\NSFILING.OPENFILE 'NSFILING) (fetch DEVICENAME of DEV)) else (* ;;  "the FDEV doesn't exist, and we can't create one for it, so it must be down") 'NOFDEV) (LEAF (* ;; "We think its a LEAF server, so try PUP.ECHOUSER") (RESETLST (PROG ((i 1) (interval initialInterval) (PORT (BESTPUPADDRESS name PROMPTWINDOW)) (SOC (OPENPUPSOCKET)) echo OPUP IPUP ECHOPUPLENGTH) (RESETSAVE NIL (LIST 'CLOSEPUPSOCKET SOC)) (OR PORT (RETURN NIL)) TryAgain (if (IGREATERP i retryCount) then (RETURN NIL)) (SETQ OPUP (ALLOCATE.PUP)) (SETUPPUP OPUP PORT \PUPSOCKET.ECHO \PT.ECHOME NIL SOC T) (PUTPUPWORD OPUP 0 1) (add (fetch PUPLENGTH of OPUP) BYTESPERWORD) (SETQ ECHOPUPLENGTH (fetch PUPLENGTH of OPUP)) (SENDPUP SOC OPUP) [COND ((SETQ IPUP (GETPUP SOC interval)) (COND ((PROG1 (AND (EQ (fetch PUPTYPE of IPUP) \PT.IAMECHO) (EQ (fetch PUPIDHI of IPUP) (fetch PUPIDHI of OPUP)) (EQ (fetch PUPIDLO of IPUP) (fetch PUPIDLO of OPUP)) (EQ (fetch PUPLENGTH of IPUP) ECHOPUPLENGTH) (IEQP (GETPUPWORD IPUP 0) 1)) (RELEASE.PUP IPUP)) (RETURN T] (SETQ i (ADD1 i)) (SETQ interval (ITIMES interval 2)) (GO TryAgain)))) (NSFILING (* ;  "We think its an NSFILING server, so try NS.ECHOUSER") (RESETLST (PROG ((i 1) (interval initialInterval) (ECHOADDRESS (OR (COERCE-TO-NSADDRESS name \NS.WKS.Echo) (\ILLEGAL.ARG name))) NSOC OXIP ECHOXIPLENGTH IXIP) (OR ECHOADDRESS (RETURN NIL)) [RESETSAVE NIL (LIST 'CLOSENSOCKET (SETQ NSOC (OPENNSOCKET] (if (IGREATERP i retryCount) then (RETURN NIL)) (SETQ OXIP (\FILLINXIP \XIPT.ECHO NSOC ECHOADDRESS)) (XIPAPPEND.WORD OXIP \XECHO.OP.REQUEST) (XIPAPPEND.WORD OXIP 1) (SETQ ECHOXIPLENGTH (fetch XIPLENGTH of OXIP)) TryAgain (if (IGREATERP i retryCount) then (RETURN NIL)) (SENDXIP NSOC OXIP) [COND ((SETQ IXIP (GETXIP NSOC interval)) (COND ((PROG1 (AND (EQ (fetch XIPTYPE of IXIP) \XIPT.ECHO) (EQ (fetch XIPLENGTH of IXIP) ECHOXIPLENGTH) (EQ (\GETBASE (fetch XIPCONTENTS of IXIP) 0) \XECHO.OP.REPLY)) (RELEASE.XIP IXIP)) (RETURN T] (SETQ i (ADD1 i)) (SETQ interval (LLSH interval 1)) (GO TryAgain)))) (FLOPPY (* ;; "the FLOPPY disk") (* ;;  "Should be (FLOPPY.CAN.READP) but this triggers a bug in the Floppy handler") T) (TCP (* ;; "A TCP device. Punt on them") T) (NOFDEV (* ;; "we can't create an FDEV for the device, so it can't be up") NIL) T]) ) (RPAQ? HOSTUP.TIMEOUT 15000) (RPAQ? HOSTUP.RETRYCNT 5) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT) ) (DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE (FILESLOAD SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES until (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS 'BODY (SETQ $$VAL (PACKFILENAME 'HOST (FILENAMEFIELD D 'HOST) 'DIRECTORY (CONCAT "LISP>" MAKESYSNAME ">SOURCES"] LLNSDECLS (LOADCOMP) LLNS) ) (PUTPROPS HOSTUP COPYRIGHT ("Johannes A. G. M. Koomen" 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1512 8312 (HOSTUP? 1522 . 8310))))) STOP \ No newline at end of file diff --git a/lispusers/HOSTUP.TEDIT b/lispusers/HOSTUP.TEDIT new file mode 100644 index 00000000..5f8fb3db Binary files /dev/null and b/lispusers/HOSTUP.TEDIT differ diff --git a/lispusers/HPGL b/lispusers/HPGL new file mode 100644 index 00000000..52e9a5d6 --- /dev/null +++ b/lispusers/HPGL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Jul-88 17:47:02" |{MCS:MCS:STANFORD}HPGL.;24| 45342 changes to%: (FNS \DRAWLINE.HPGL \FONT.HPGL \INIT.HPGL HARDCOPYW.HPGL) previous date%: "20-Jul-88 17:34:42" |{MCS:MCS:STANFORD}HPGL.;23|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT HPGLCOMS) (RPAQQ HPGLCOMS ((* * User Functions) (FNS MAKEHPGL OPENHPGLSTREAM HARDCOPYW.HPGL) (* * ImageOp Functions) (FNS \BITBLT.HPGL \BLTSHADE.HPGL \CLOSEFN.HPGL \COLOR.HPGL \DRAWARC.HPGL \DRAWCIRCLE.HPGL \DRAWCURVE.HPGL \DRAWLINE.HPGL \DRAWPOLYGON.HPGL \FILLCIRCLE.HPGL \FONT.HPGL \LEFTMARGIN.HPGL \LINEFEED.HPGL \MOVETO.HPGL \RESET.HPGL \RIGHTMARGIN.HPGL \ROTATE.HPGL \SCALEDBITBLT.HPGL \STRINGWIDTH.HPGL \CLIPPINGREGION.HPGL \TERPRI.HPGL \XPOSITION.HPGL \YPOSITION.HPGL) (* * Internal Functions) (FNS \DUMPSTRING.HPGL \FONTCREATE.HPGL \INIT.HPGL \OUTCHAR.HPGL \SEARCH.HPGL.FONTS \FILL.HPGL \DASHING.HPGL) (* * etc.) (VARS HPGL.FONTS HPGL.OPTIONS HPGL.FONT.EXPANSIONS HPGL.DASHING (SKETCHINCOLORFLG T)) (INITVARS (HPGL.TERMINATOR (CHARACTER (CHARCODE ;))) (HPGL.SEPARATOR (CHARACTER (CHARCODE %,))) (HPGL.TEXT.TERMINATOR (CHARACTER (CHARCODE ^A))) HPGL.CHORD.ANGLE HPGL.PATTERN.LENGTH \HPGLIMAGEOPS \NULLFDEV SK.DASHING.PATTERNS) (GLOBALVARS HPGL.FONTS HPGL.OPTIONS HPGL.FONT.EXPANSIONS HPGL.DASHING HPGL.TERMINATOR HPGL.SEPARATOR HPGL.TEXT.TERMINATOR HPGL.CHORD.ANGLE HPGL.PATTERN.LENGTH \HPGLIMAGEOPS \NULLFDEV) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES UTILISOPRS) (ALISTS (PRINTOUTMACROS !, !; !!;)) (RECORDS PLOTTERDATA)) [ADDVARS (PRINTERTYPES ((PLOTTER HPGL) (CANPRINT (HPGL)) (STATUS TRUE) (BITMAPFILE (HARDCOPYW.HPGL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)) (PROPERTIES NILL))) [PRINTFILETYPES (HPGL (EXTENSION (HPGL PLOT)) (CONVERSION (TEXT MAKEHPGL TEDIT (LAMBDA (FILE PFILE) (SETQ FILE (OPENTEXTSTREAM FILE)) (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'HPGL) (CLOSEF? FILE) PFILE] (IMAGESTREAMTYPES (HPGL (OPENSTREAM OPENHPGLSTREAM) (FONTCREATE \FONTCREATE.HPGL) (FONTSAVAILABLE \SEARCH.HPGL.FONTS) (CREATECHARSET NILL] (P [if (FGETD (FUNCTION SK.DASHING.LABEL)) then (for ENTRY in HPGL.DASHING do (push SK.DASHING.PATTERNS (LIST (SK.DASHING.LABEL (CDR ENTRY)) (CDR ENTRY] (\INIT.HPGL)))) (* * User Functions) (DEFINEQ (MAKEHPGL [LAMBDA (FILE PFILE FONTS HEADING TABS) (* cdl "12-Jun-85 11:22") (TEXTTOIMAGEFILE FILE PFILE 'HPGL FONTS HEADING TABS]) (OPENHPGLSTREAM [LAMBDA (FILE OPTIONS) (* ; "Edited 8-Sep-87 08:50 by cdl") (* DECLARATIONS%: (RECORD PAIR  (KEY VALUE))) (LET (HPGLSTREAM POSITION (STREAM (OPENSTREAM FILE 'OUTPUT)) (SCALE (create POSITION XCOORD _ SCREENWIDTH YCOORD _ SCREENHEIGHT))) (if (AND (SETQ POSITION (LISTGET OPTIONS 'SCALE)) (POSITIONP POSITION)) then (SETQ SCALE POSITION)) (SETQ HPGLSTREAM (create STREAM IMAGEOPS _ \HPGLIMAGEOPS IMAGEDATA _ (create PLOTTERDATA PD.STREAM _ STREAM PD.SCALE _ SCALE PD.RIGHTMARGIN _ (with POSITION SCALE XCOORD) ) OUTCHARFN _ (FUNCTION \OUTCHAR.HPGL) CBUFPTR _ NIL CBUFSIZE _ 0 DEVICE _ \NULLFDEV using STREAM)) (with STREAM STREAM (SETQ LINELENGTH MAX.SMALLP)) (with POSITION SCALE (printout STREAM "DF" !; "SC" "0" !, XCOORD !, "0" !, YCOORD !; "DT" !!; !;)) [bind ENTRY for PAIR on OPTIONS by (CDDR PAIR) do (with PAIR PAIR (if (SETQ ENTRY (ASSOC KEY HPGL.OPTIONS)) then (printout STREAM (CDR ENTRY) VALUE !;] (DSPFONT DEFAULTFONT HPGLSTREAM) (DSPRESET HPGLSTREAM) HPGLSTREAM]) (HARDCOPYW.HPGL [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)(* ; "Edited 20-Jul-88 17:11 by cdl") (LET ((PFILE (OPENHPGLSTREAM FILE))) (with REGION REGION (BITBLT BITMAP LEFT BOTTOM PFILE NIL NIL WIDTH HEIGHT)) (CLOSEF PFILE]) ) (* * ImageOp Functions) (DEFINEQ (\BITBLT.HPGL [LAMBDA (BITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 8-Sep-87 08:41 by cdl") (\DUMPSTRING.HPGL STREAM) (bind (FILESTREAM _ (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) PD.STREAM)) for Y from SOURCEBOTTOM to (SUB1 (PLUS SOURCEBOTTOM HEIGHT)) as J from DESTINATIONBOTTOM do (bind PI (STATE _ 0) for X from SOURCELEFT to (SUB1 (PLUS SOURCELEFT WIDTH)) as I from DESTINATIONLEFT do (if (NEQ STATE (BITMAPBIT BITMAP X Y)) then (if (ZEROP (SETQ STATE (IDIFFERENCE 1 STATE))) then (printout FILESTREAM "PD") (if (NEQ PI (SUB1 I)) then (printout FILESTREAM (SUB1 I) !, J)) (printout FILESTREAM !;) else (printout FILESTREAM "PU" I !, J !;)) (SETQ PI I)) finally (if (NOT (ZEROP STATE)) then (printout FILESTREAM "PD") (if (NEQ PI (SUB1 I)) then (printout FILESTREAM (SUB1 I) !, J)) (printout FILESTREAM !;))) finally (printout FILESTREAM "PU" !;)) T]) (\BLTSHADE.HPGL [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 10-Nov-87 15:37 by cdl") (SUB1VAR WIDTH) (SUB1VAR HEIGHT) (if (AND (OR (ZEROP WIDTH) (ZEROP HEIGHT)) (EQ TEXTURE BLACKSHADE)) then (* Get around bug in plotter  hardware triggered by SKETCH boxes) (DRAWLINE DESTINATIONLEFT DESTINATIONBOTTOM (PLUS DESTINATIONLEFT WIDTH) (PLUS DESTINATIONBOTTOM HEIGHT) NIL OPERATION STREAM) else (IMAGEOP 'IMMOVETO STREAM STREAM DESTINATIONLEFT DESTINATIONBOTTOM) (\FILL.HPGL STREAM TEXTURE) (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (printout PD.STREAM "RA" (PLUS DESTINATIONLEFT WIDTH) !, (PLUS DESTINATIONBOTTOM HEIGHT) !;))) T]) (\CLOSEFN.HPGL [LAMBDA (STREAM) (* ; "Edited 8-Sep-87 08:34 by cdl") (\DUMPSTRING.HPGL STREAM) (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (printout PD.STREAM "PU" !;) (CLOSEF? PD.STREAM) (SETQ PD.STREAM NIL)) T]) (\COLOR.HPGL [LAMBDA (STREAM COLOR) (* ; "Edited 8-Dec-87 17:10 by cdl") (* DECLARATIONS%: (RECORD ENTRY  (NAME . VALUES))) (DECLARE (GLOBALVARS COLORNAMES)) (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (PROG1 PD.COLOR (if COLOR then [if (LITATOM COLOR) then (SETQ COLOR (for ENTRY in COLORNAMES as I from 1 thereis (with ENTRY ENTRY (EQ COLOR NAME)) yield (DIFFERENCE (LENGTH COLORNAMES) I))) elseif (RGBP COLOR) then (SETQ COLOR (for ENTRY in COLORNAMES as I from 1 thereis (with ENTRY ENTRY (EQUAL COLOR VALUES)) yield (DIFFERENCE (LENGTH COLORNAMES) I] (if (AND (FIXP COLOR) (NEQ COLOR PD.COLOR)) then (\DUMPSTRING.HPGL STREAM) (printout PD.STREAM "SP" (ADD1 (SETQ PD.COLOR COLOR)) !;))))]) (\DRAWARC.HPGL [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* ; "Edited 14-Sep-87 10:57 by cdl") (DECLARE (SPECVARS . T)) (\DUMPSTRING.HPGL STREAM) [if (LISTP BRUSH) then (with BRUSH BRUSH (if BRUSHCOLOR then (IMAGEOP 'IMCOLOR STREAM STREAM BRUSHCOLOR] (RESETLST [RESETSAVE NIL `(\DASHING.HPGL ,STREAM ,(\DASHING.HPGL STREAM DASHING] [RESETSAVE NIL `(DSPCOLOR ,(IMAGEOP 'IMCOLOR STREAM STREAM (if (LISTP BRUSH) then (with BRUSH BRUSH BRUSHCOLOR))) ,STREAM] (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (printout PD.STREAM "PU" (SETQ XCOORD CENTERX) !, (SETQ YCOORD CENTERY) !; "EW" RADIUS !, (PLUS STARTANGLE 90) !, NDEGREES) (if HPGL.CHORD.ANGLE then (printout PD.STREAM !, HPGL.CHORD.ANGLE)) (printout PD.STREAM !;)))) T]) (\DRAWCIRCLE.HPGL [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* ; "Edited 14-Sep-87 10:54 by cdl") (DECLARE (SPECVARS . T)) (\DUMPSTRING.HPGL STREAM) [if (LISTP BRUSH) then (with BRUSH BRUSH (if BRUSHCOLOR then (IMAGEOP 'IMCOLOR STREAM STREAM BRUSHCOLOR] (RESETLST [RESETSAVE NIL `(\DASHING.HPGL ,STREAM ,(\DASHING.HPGL STREAM DASHING] [RESETSAVE NIL `(DSPCOLOR ,(IMAGEOP 'IMCOLOR STREAM STREAM (if (LISTP BRUSH) then (with BRUSH BRUSH BRUSHCOLOR))) ,STREAM] (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (printout PD.STREAM "PU" (SETQ XCOORD CENTERX) !, (SETQ YCOORD CENTERY) !; "CI" RADIUS) (if HPGL.CHORD.ANGLE then (printout PD.STREAM !, HPGL.CHORD.ANGLE)) (printout PD.STREAM !;)))) T]) (\DRAWCURVE.HPGL [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 8-Sep-87 11:25 by cdl") (DECLARE (SPECVARS . T)) (\DUMPSTRING.HPGL STREAM) (if (FGETD 'DRAWCURVE.STREAM) then (RESETLST [RESETSAVE NIL `(DSPCOLOR ,(IMAGEOP 'IMCOLOR STREAM STREAM (if (LISTP BRUSH) then (with BRUSH BRUSH BRUSHCOLOR) )) ,STREAM] (DRAWCURVE.STREAM STREAM KNOTS CLOSED BRUSH DASHING)) else (IMAGEOP 'IMDRAWPOLYGON STREAM STREAM KNOTS CLOSED BRUSH DASHING]) (\DRAWLINE.HPGL [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 20-Jul-88 17:45 by cdl") (DECLARE (SPECVARS . T)) [if [AND DASHING (NOT (bind (DASHING _ (MKLIST DASHING)) for ENTRY in HPGL.DASHING thereis (EQUAL DASHING (CDR ENTRY] then (* Not a hardware dashing pattern) (DRAWDASHEDLINE X1 Y1 X2 Y2 (OR WIDTH 1) OPERATION STREAM COLOR DASHING) else (\DUMPSTRING.HPGL STREAM) (RESETLST [RESETSAVE NIL `(\DASHING.HPGL ,STREAM ,(\DASHING.HPGL STREAM DASHING] [RESETSAVE NIL `(DSPCOLOR ,(IMAGEOP 'IMCOLOR STREAM STREAM COLOR) ,STREAM] (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (if [NOT (AND (OR (EQ X1 T) (EQ X1 XCOORD)) (OR (EQ Y1 T) (EQ Y1 YCOORD] then (printout PD.STREAM "PU" (if (EQ X1 T) then XCOORD else X1) !, (if (EQ Y1 T) then YCOORD else Y1) !;)) (printout PD.STREAM "PD" (SETQ XCOORD X2) !, (SETQ YCOORD Y2) !;))))] T]) (\DRAWPOLYGON.HPGL [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 8-Sep-87 08:22 by cdl") (DECLARE (SPECVARS . T)) (\DUMPSTRING.HPGL STREAM) (RESETLST [RESETSAVE NIL `(\DASHING.HPGL ,STREAM ,(\DASHING.HPGL STREAM DASHING] [RESETSAVE NIL `(DSPCOLOR ,(IMAGEOP 'IMCOLOR STREAM STREAM (if (LISTP BRUSH) then (with BRUSH BRUSH BRUSHCOLOR))) ,STREAM] (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION (CAR POINTS) (printout PD.STREAM "PU" XCOORD !, YCOORD !; "PD")) (for POINT on (CDR POINTS) do (with POSITION (CAR POINT) (printout PD.STREAM XCOORD !, YCOORD) ) (if (CDR POINT) then (printout PD.STREAM !,))) (if CLOSED then (with POSITION (CAR POINTS) (printout PD.STREAM XCOORD !, YCOORD))) (PRINTOUT PD.STREAM !;) (with POSITION (CAR (LAST POINTS)) (create POSITION XCOORD _ XCOORD YCOORD _ YCOORD smashing PD.POSITION)))) T]) (\FILLCIRCLE.HPGL [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 14-Sep-87 11:25 by cdl") (\DUMPSTRING.HPGL STREAM) (\FILL.HPGL STREAM TEXTURE) (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (printout PD.STREAM "PU" (SETQ XCOORD CENTERX) !, (SETQ YCOORD CENTERY) !; "WG" RADIUS !, "0" !, "360") (if HPGL.CHORD.ANGLE then (printout PD.STREAM !, HPGL.CHORD.ANGLE)) (printout PD.STREAM !;))) T]) (\FONT.HPGL [LAMBDA (STREAM FONT) (* ; "Edited 20-Jul-88 17:34 by cdl") [if (type? FONTCLASS FONT) then (SETQ FONT (FONTCLASSCOMPONENT FONT (IMAGESTREAMTYPE STREAM] (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (if (AND FONT (NEQ FONT PD.FONT)) then (\DUMPSTRING.HPGL STREAM) [with FONTDESCRIPTOR FONT (if (NEQ FONTFAMILY (fetch FONTFAMILY of PD.FONT)) then (printout PD.STREAM "CS" (OR (CDR (FASSOC FONTFAMILY HPGL.FONTS)) (CONSTANT null)) !;)) (if (NEQ ROTATION (fetch ROTATION of PD.FONT)) then (printout PD.STREAM "DI") (if (AND ROTATION (NOT (ZEROP ROTATION))) then (printout PD.STREAM (COS ROTATION) !, (SIN ROTATION))) (printout PD.STREAM !;)) (with POSITION PD.SCALE (printout PD.STREAM "SR") (PRINTNUM '(FLOAT NIL 3) (QUOTIENT (QUOTIENT [TIMES FONTAVGCHARWIDTH (with FONTFACE FONTFACE (CDR (ASSOC EXPANSION HPGL.FONT.EXPANSIONS ] 3) XCOORD) PD.STREAM) (printout PD.STREAM !,) (PRINTNUM '(FLOAT NIL 3) (QUOTIENT (TIMES \SFHeight 100.0) YCOORD) PD.STREAM) (printout PD.STREAM !;)) (with FONTFACE FONTFACE (if (NEQ SLOPE (fetch (FONTFACE SLOPE) of (fetch (FONTDESCRIPTOR FONTFACE) of PD.FONT))) then (printout PD.STREAM "SL" (SELECTQ SLOPE (REGULAR (CONSTANT null)) (ITALIC 1) (SHOULDNT)) !;] (PROG1 PD.FONT (SETQ PD.FONT FONT)) else PD.FONT]) (\LEFTMARGIN.HPGL [LAMBDA (STREAM XPOSITION) (* cdl "25-Jun-85 15:33") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (PROG1 PD.LEFTMARGIN (if XPOSITION then (SETQ PD.LEFTMARGIN XPOSITION)))]) (\LINEFEED.HPGL [LAMBDA (STREAM DELTAY) (* cdl "24-Jul-85 08:01") (MINUS (TIMES 2 (FONTPROP (with STREAM STREAM (with PLOTTERDATA IMAGEDATA PD.FONT)) 'HEIGHT]) (\MOVETO.HPGL [LAMBDA (STREAM X Y) (* ; "Edited 8-Sep-87 10:39 by cdl") (\DUMPSTRING.HPGL STREAM) (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (printout PD.STREAM "PU" (SETQ XCOORD X) !, (SETQ YCOORD Y) !;))) T]) (\RESET.HPGL [LAMBDA (STREAM) (* cdl "19-Jul-85 16:30") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (IMAGEOP 'IMMOVETO STREAM STREAM PD.LEFTMARGIN (PLUS (with POSITION PD.SCALE YCOORD) (IMAGEOP 'IMLINEFEED STREAM STREAM]) (\RIGHTMARGIN.HPGL [LAMBDA (STREAM XPOSITION) (* cdl "25-Jun-85 15:34") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (PROG1 PD.RIGHTMARGIN (if XPOSITION then (SETQ PD.RIGHTMARGIN XPOSITION)))]) (\ROTATE.HPGL [LAMBDA (STREAM ROTATION) (* ; "Edited 8-Sep-87 08:37 by cdl") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (PROG1 PD.ROTATION (if PD.ROTATION then (\DUMPSTRING.HPGL STREAM) (printout PD.STREAM "RO" PD.ROTATION !;)))]) (\SCALEDBITBLT.HPGL [LAMBDA (BITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE) (* ; "Edited 8-Sep-87 08:43 by cdl") (\DUMPSTRING.HPGL STREAM) (bind (FILESTREAM _ (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) PD.STREAM)) (SOURCEWIDTH _ (SUB1 (PLUS SOURCELEFT WIDTH))) for Y from SOURCEBOTTOM to (SUB1 (PLUS SOURCEBOTTOM HEIGHT)) as J from DESTINATIONBOTTOM by SCALE do [for Z from J to (PLUS J (SUB1 SCALE)) do (bind PI LASTPOSITION (STATE _ 0) for X from SOURCELEFT to SOURCEWIDTH as I from DESTINATIONLEFT by SCALE do (if (NEQ STATE (BITMAPBIT BITMAP X Y)) then (if (ZEROP (SETQ STATE (DIFFERENCE 1 STATE))) then (printout FILESTREAM "PD") (if (NOT (IEQP PI (SUB1 I))) then (printout FILESTREAM (SUB1 I) !, Z)) (printout FILESTREAM !;) else (printout FILESTREAM "PU" I !, Z !;)) (SETQ PI I)) finally (if (NOT (ZEROP STATE)) then (printout FILESTREAM "PD") (if (NOT (IEQP PI (SUB1 I))) then (printout FILESTREAM (SUB1 I) !, Z)) (printout FILESTREAM !;] finally (printout FILESTREAM "PU" !;)) T]) (\STRINGWIDTH.HPGL [LAMBDA (STREAM STRING RDTBL) (* cdl "29-Apr-85 14:31") (STRINGWIDTH STRING (DSPFONT NIL STREAM) RDTBL RDTBL]) (\CLIPPINGREGION.HPGL [LAMBDA (STREAM REGION) (* cdl "16-Oct-85 10:57") (with STREAM STREAM (with PLOTTERDATA IMAGEDATA (with POSITION PD.SCALE (CREATEREGION 0 0 XCOORD YCOORD]) (\TERPRI.HPGL [LAMBDA (STREAM) (* cdl "24-Jul-85 09:26") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (IMAGEOP 'IMMOVETO STREAM STREAM PD.LEFTMARGIN (PLUS YCOORD (IMAGEOP 'IMLINEFEED STREAM STREAM]) (\XPOSITION.HPGL [LAMBDA (STREAM XPOSITION) (* ; "Edited 8-Sep-87 08:32 by cdl") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (PROG1 XCOORD (if XPOSITION then (\DUMPSTRING.HPGL STREAM) (printout PD.STREAM "PU" (SETQ XCOORD XPOSITION) !, YCOORD !;)))]) (\YPOSITION.HPGL [LAMBDA (STREAM YPOSITION) (* ; "Edited 8-Sep-87 08:31 by cdl") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with POSITION PD.POSITION (PROG1 YCOORD (if YPOSITION then (\DUMPSTRING.HPGL STREAM) (printout PD.STREAM "PU" XCOORD !, (SETQ YCOORD YPOSITION) !;)))]) ) (* * Internal Functions) (DEFINEQ (\DUMPSTRING.HPGL [LAMBDA (STREAM) (* ; "Edited 8-Sep-87 08:51 by cdl") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (if PD.TEXT then (printout PD.STREAM "LB") (for CHARCODE in (DREVERSE PD.TEXT) do (BOUT PD.STREAM CHARCODE)) (printout PD.STREAM !!;) (SETQ PD.TEXT NIL) T]) (\FONTCREATE.HPGL [LAMBDA (FAMILY SIZE FACE ROTATION) (* ; "Edited 4-Sep-87 15:13 by cdl") (if (ASSOC FAMILY HPGL.FONTS) then (LET ((WIDTHSBLOCK (\CREATECSINFOELEMENT)) (FONTDESCRIPTOR (create FONTDESCRIPTOR FONTDEVICE _ 'HPGL FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE ROTATION _ ROTATION \SFHeight _ SIZE \SFAscent _ SIZE \SFDescent _ 0))) (bind (WIDTH _ (FIX (QUOTIENT (TIMES 3 SIZE) 4))) for N from 0 to 254 do (\FSETWIDTH WIDTHSBLOCK N WIDTH)) (with FONTDESCRIPTOR FONTDESCRIPTOR (\SETCHARSETINFO FONTCHARSETVECTOR 0 (create CHARSETINFO WIDTHS _ WIDTHSBLOCK IMAGEWIDTHS _ WIDTHSBLOCK CHARSETASCENT _ SIZE CHARSETDESCENT _ 0))) FONTDESCRIPTOR) else (FONTCREATE (CAAR HPGL.FONTS) SIZE FACE ROTATION 'HPGL]) (\INIT.HPGL [LAMBDA NIL (* ; "Edited 20-Jul-88 17:04 by cdl") (* DECLARATIONS%: (RECORD CLASS  (FONTCLASSNAME PRETTYFONT# DISPLAYFD  PRESSFD INTERPRESSFD . OTHERFDS))) (DECLARE (GLOBALVARS FONTDEFS FONTNAME)) (SETQ \NULLFDEV (create FDEV CLOSEFILE _ (FUNCTION NILL))) (SETQ \HPGLIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'HPGL IMCLOSEFN _ (FUNCTION \CLOSEFN.HPGL) IMXPOSITION _ (FUNCTION \XPOSITION.HPGL) IMYPOSITION _ (FUNCTION \YPOSITION.HPGL) IMFONT _ (FUNCTION \FONT.HPGL) IMLEFTMARGIN _ (FUNCTION \LEFTMARGIN.HPGL) IMRIGHTMARGIN _ (FUNCTION \RIGHTMARGIN.HPGL) IMLINEFEED _ (FUNCTION \LINEFEED.HPGL) IMDRAWLINE _ (FUNCTION \DRAWLINE.HPGL) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.HPGL) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.HPGL) IMDRAWELLIPSE _ (FUNCTION DRAWELLIPSEWITHDRAWCURVE) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.HPGL) IMBITBLT _ (FUNCTION \BITBLT.HPGL) IMBLTSHADE _ (FUNCTION \BLTSHADE.HPGL) IMMOVETO _ (FUNCTION \MOVETO.HPGL) IMSCALE _ [FUNCTION (LAMBDA (STREAM SCALE) 1] IMTERPRI _ (FUNCTION \TERPRI.HPGL) IMFONTCREATE _ 'HPGL IMCOLOR _ (FUNCTION \COLOR.HPGL) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.HPGL) IMCHARWIDTH _ (FUNCTION \STRINGWIDTH.HPGL) IMRESET _ (FUNCTION \RESET.HPGL) IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.HPGL) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.HPGL) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.HPGL) IMDRAWARC _ (FUNCTION \DRAWARC.HPGL) IMROTATE _ (FUNCTION \ROTATE.HPGL))) (for FONTSET in FONTDEFS do [for CLASS in (CDR (ASSOC 'FONTPROFILE (CDR FONTSET))) unless (with CLASS CLASS (OR (NULL DISPLAYFD) (NULL INTERPRESSFD) (ASSOC 'HPGL OTHERFDS))) do (with CLASS CLASS (push OTHERFDS (LIST 'HPGL (CONS 'STANDARD (CDR (if (LISTP DISPLAYFD) then DISPLAYFD else (FONTUNPARSE DISPLAYFD] finally (FONTSET FONTNAME]) (\OUTCHAR.HPGL [LAMBDA (STREAM CHARCODE) (* cdl " 3-Oct-85 13:20") (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (SELCHARQ CHARCODE (EOL (\TERPRI.HPGL STREAM)) (if (AND (GEQ CHARCODE (CHARCODE SPACE)) (LEQ CHARCODE (CHARCODE ~))) then (with POSITION PD.POSITION (add XCOORD (CHARWIDTH CHARCODE PD.FONT))) (push PD.TEXT CHARCODE]) (\SEARCH.HPGL.FONTS [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* cdl " 1-May-85 09:34") (if (EQ DEVICE 'HPGL) then (if (FASSOC FAMILY HPGL.FONTS) then (LIST (LIST FAMILY SIZE FACE ROTATION DEVICE]) (\FILL.HPGL [LAMBDA (STREAM TEXTURE) (* ; "Edited 8-Dec-87 16:56 by cdl") (* DECLARATIONS%: (RECORD TEXTURE  (TYPE SPACING ANGLE))  (RECORD TEXTURECOLORPAIR  (TEXURE COLOR))) (\DUMPSTRING.HPGL STREAM) (if (LISTP TEXTURE) then (SETQ TEXTURE (with TEXTURECOLORPAIR TEXTURE (if (RGBP COLOR) then (IMAGEOP 'IMCOLOR STREAM STREAM COLOR)) TEXTURE))) [if (FIXP TEXTURE) then (SETQ TEXTURE (create TEXTURE TYPE _ (if (IEQP TEXTURE BLACKSHADE) then 1 elseif (IEQP TEXTURE WHITESHADE) then 3 else 4) SPACING _ 0 ANGLE _ (TIMES (LOGAND TEXTURE 3) 45] (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (with TEXTURE TEXTURE (printout PD.STREAM "FT" (if (AND (FIXP TYPE) (GEQ TYPE 1) (LEQ TYPE 4)) then TYPE else 1) !, (if (FIXP SPACING) then SPACING else 0) !, (if (AND (FIXP ANGLE) (ZEROP (IMOD ANGLE 45))) then ANGLE else 0) !;))) T]) (\DASHING.HPGL [LAMBDA (STREAM DASHING) (* ; "Edited 14-Sep-87 11:28 by cdl") (* DECLARATIONS%: (RECORD ENTRY  (INDEX . LENGTHS))) (with PLOTTERDATA (with STREAM STREAM IMAGEDATA) (PROG1 (if PD.DASHING then (CDR (ASSOC PD.DASHING HPGL.DASHING))) (if DASHING then (LET (INDEX) [if (SETQ DASHING (MKLIST DASHING)) then (SETQ INDEX (for ENTRY in HPGL.DASHING thereis (with ENTRY ENTRY (EQUAL DASHING LENGTHS)) yield (with ENTRY ENTRY INDEX] (if (AND (FIXP INDEX) (NEQ INDEX PD.DASHING)) then (\DUMPSTRING.HPGL STREAM) (printout PD.STREAM "LT" (SETQ PD.DASHING INDEX)) (if HPGL.PATTERN.LENGTH then (printout PD.STREAM !, HPGL.PATTERN.LENGTH)) (printout PD.STREAM !;))) elseif PD.DASHING then (\DUMPSTRING.HPGL STREAM) (printout PD.STREAM "LT" !;) (SETQ PD.DASHING NIL)))]) ) (* * etc.) (RPAQQ HPGL.FONTS ((STANDARD . 0) (9825 . 1) (FRENCH . 2) (SCANDINAVIAN . 3) (SPANISH . 4) (JISASCII . 6) (ROMAN . 7) (KATAKANA . 8) (IRV . 9) (SWEDISH . 30) (SWEDISH2 . 31) (NORWAY . 32) (GERMAN . 33) (FRENCH2 . 34) (BRITISH . 35) (ITALIAN . 36) (SPANISH2 . 37) (PORTUGUESE . 38) (NORWAY2 . 39))) (RPAQQ HPGL.OPTIONS ((ROTATE . "RO") (VELOCITY . "VS") (PAPER . "PS") (TERMINATOR . "DT"))) (RPAQQ HPGL.FONT.EXPANSIONS ((REGULAR . 200.0) (COMPRESSED . 100.0) (EXPANDED . 400.0))) (RPAQQ HPGL.DASHING ((1 1 49) (2 25) (3 35 15) (4 39 5 1 5) (5 35 5 5 5) (6 25 5 5 5 5 5))) (RPAQQ SKETCHINCOLORFLG T) (RPAQ? HPGL.TERMINATOR (CHARACTER (CHARCODE ;))) (RPAQ? HPGL.SEPARATOR (CHARACTER (CHARCODE %,))) (RPAQ? HPGL.TEXT.TERMINATOR (CHARACTER (CHARCODE ^A))) (RPAQ? HPGL.CHORD.ANGLE NIL) (RPAQ? HPGL.PATTERN.LENGTH NIL) (RPAQ? \HPGLIMAGEOPS NIL) (RPAQ? \NULLFDEV NIL) (RPAQ? SK.DASHING.PATTERNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HPGL.FONTS HPGL.OPTIONS HPGL.FONT.EXPANSIONS HPGL.DASHING HPGL.TERMINATOR HPGL.SEPARATOR HPGL.TEXT.TERMINATOR HPGL.CHORD.ANGLE HPGL.PATTERN.LENGTH \HPGLIMAGEOPS \NULLFDEV) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD UTILISOPRS) (ADDTOVAR PRINTOUTMACROS [!, (LAMBDA (COMS) (CONS '(PRIN1 HPGL.SEPARATOR NIL) (CDR COMS] [!; (LAMBDA (COMS) (CONS '(PRIN1 HPGL.TERMINATOR NIL) (CDR COMS] [!!; (LAMBDA (COMS) (CONS '(PRIN1 HPGL.TEXT.TERMINATOR NIL) (CDR COMS]) (DECLARE%: EVAL@COMPILE (RECORD PLOTTERDATA (PD.STREAM PD.POSITION PD.FONT PD.TEXT PD.COLOR PD.SCALE PD.LEFTMARGIN PD.RIGHTMARGIN PD.DASHING PD.ROTATION) PD.POSITION _ (create POSITION) PD.COLOR _ 0 PD.LEFTMARGIN _ 0 PD.ROTATION _ 0) ) ) (ADDTOVAR PRINTERTYPES ((PLOTTER HPGL) (CANPRINT (HPGL)) (STATUS TRUE) (BITMAPFILE (HARDCOPYW.HPGL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE )) (PROPERTIES NILL))) (ADDTOVAR PRINTFILETYPES [HPGL (EXTENSION (HPGL PLOT)) (CONVERSION (TEXT MAKEHPGL TEDIT (LAMBDA (FILE PFILE) (SETQ FILE (OPENTEXTSTREAM FILE)) (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'HPGL) (CLOSEF? FILE) PFILE]) (ADDTOVAR IMAGESTREAMTYPES (HPGL (OPENSTREAM OPENHPGLSTREAM) (FONTCREATE \FONTCREATE.HPGL) (FONTSAVAILABLE \SEARCH.HPGL.FONTS) (CREATECHARSET NILL))) [if (FGETD (FUNCTION SK.DASHING.LABEL)) then (for ENTRY in HPGL.DASHING do (push SK.DASHING.PATTERNS (LIST (SK.DASHING.LABEL (CDR ENTRY)) (CDR ENTRY] (\INIT.HPGL) (PUTPROPS HPGL COPYRIGHT ("Stanford University" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3583 6000 (MAKEHPGL 3593 . 3756) (OPENHPGLSTREAM 3758 . 5715) (HARDCOPYW.HPGL 5717 . 5998)) (6031 29802 (\BITBLT.HPGL 6041 . 8018) (\BLTSHADE.HPGL 8020 . 9173) (\CLOSEFN.HPGL 9175 . 9503) (\COLOR.HPGL 9505 . 11429) (\DRAWARC.HPGL 11431 . 12940) (\DRAWCIRCLE.HPGL 12942 . 14285) ( \DRAWCURVE.HPGL 14287 . 15076) (\DRAWLINE.HPGL 15078 . 17236) (\DRAWPOLYGON.HPGL 17238 . 18904) ( \FILLCIRCLE.HPGL 18906 . 19622) (\FONT.HPGL 19624 . 23275) (\LEFTMARGIN.HPGL 23277 . 23578) ( \LINEFEED.HPGL 23580 . 23823) (\MOVETO.HPGL 23825 . 24303) (\RESET.HPGL 24305 . 24674) ( \RIGHTMARGIN.HPGL 24676 . 24980) (\ROTATE.HPGL 24982 . 25356) (\SCALEDBITBLT.HPGL 25358 . 27641) ( \STRINGWIDTH.HPGL 27643 . 27826) (\CLIPPINGREGION.HPGL 27828 . 28133) (\TERPRI.HPGL 28135 . 28492) ( \XPOSITION.HPGL 28494 . 29156) (\YPOSITION.HPGL 29158 . 29800)) (29834 40881 (\DUMPSTRING.HPGL 29844 . 30316) (\FONTCREATE.HPGL 30318 . 31926) (\INIT.HPGL 31928 . 35493) (\OUTCHAR.HPGL 35495 . 36108) ( \SEARCH.HPGL.FONTS 36110 . 36383) (\FILL.HPGL 36385 . 39041) (\DASHING.HPGL 39043 . 40879))))) STOP \ No newline at end of file diff --git a/lispusers/HPGL.TEDIT b/lispusers/HPGL.TEDIT new file mode 100644 index 00000000..77f47313 Binary files /dev/null and b/lispusers/HPGL.TEDIT differ diff --git a/lispusers/HYPERDESK-INIT b/lispusers/HYPERDESK-INIT new file mode 100644 index 00000000..209435bc --- /dev/null +++ b/lispusers/HYPERDESK-INIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10) (il:filecreated " 1-Feb-89 14:45:32" il:|{EG:PARC:XEROX}LISP>MEDLEY>HYPERDESK-INIT.;4| 10934 il:|changes| il:|to:| (il:vars il:hyperdesk-initcoms) (il:functions il:log-hyperdesk-user il:make-hyperdesk-bug-report) il:|previous| il:|date:| "29-Nov-88 18:01:17" il:|{EG:PARC:XEROX}LISP>MEDLEY>HYPERDESK-INIT.;3|) ; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved. (il:prettycomprint il:hyperdesk-initcoms) (il:rpaqq il:hyperdesk-initcoms ((il:* il:|;;| "HYPERDESK INIT") (il:* il:|;;| "Stuff needed even when just source is loaded") (il:files (il:sysload il:from il:lispusers) il:hyperdesk-log) (il:functions remove-junk-rooms) (il:alists (il:fontdefs il:hyperdesk)) (il:* il:|;;| "Only Evalled at load of Compile") (il:declare\: il:donteval@load il:donteval@compile (il:* il:|;;;| "----- Init File Stuff") (il:coms (il:initvars (*hyperdesk-sysout-p* (il:strpos "HyperDesk" il:heraldstring)) (*superdesk-sysout-p* (il:strpos "SuperDesk" il:heraldstring))) (il:vars (*hyperdesk-init-p* t) (il:hyperusersdirectories (quote (il:{eg\:}lisp>medley> il:{eg\:}lisp>users> il:{eg\:}lisp>users>)))) (il:initvars (il:usersdirectories il:hyperusersdirectories) (il:* il:|;;| "So I know whether these have been loaded (or attempted) before.") (il:*generic-init-loaded* nil) (il:*hyperdesk-init-loaded* nil) (*hyperdesk-init-logged*) (il:\\cc-hyperdesk-msg t))) (il:* il:|;;;| "----- BASICS Goodies") (il:addvars (il:greetdates ("27-JAN" . "Happy Mozart's birthday") (" 1-APR" . "Hello fool") (" 5-MAY" . "Happy Cinco de Mayo") (" 6-AUG" . "Hiroshima day") (" 9-AUG" . "Nagasaki day") ("11-NOV" . "Remember the 11th hour of the 11th day of the 11th month"))) (il:* il:|;;;| "----- Set up PRE Generic Init variables that you want initialized before generic init gets loaded") (il:initvars (il:*hyperdesk-full-init-p* (il:memb (il:askuser 7 (quote il:y) "Do a full initialization? ") (quote (il:y t))))) (il:appendvars (il:|*AddressBookFiles*| il:{indigo}parcphonelist.txt)) (il:initvars (il:*hyperdesk-base-modules*) (il:*hyperdesk-modules* (quote ("Load-PCL" "Rooms" "Common-Lens" "Clens-Rooms" "Random-Window-Types" "Notecards-Window-Types" "Lafite-Window-Types"))) (il:*hyperdesk-extra-modules*)) (il:initvars (il:*load-utility-options* (if il:*hyperdesk-full-init-p* (append il:*hyperdesk-base-modules* il:*hyperdesk-modules* il:*hyperdesk-extra-modules*) (if *hyperdesk-sysout-p* (quote ("Rooms"))))) (il:\\use-lens? t) (il:\\turn-on-mailer nil) (il:*load-silent* t)) (il:initvars (il:\\font-profile-name (quote il:hyperdesk))) (il:* il:|;;;| "----- Now LOAD Generic Init") (il:p (il:filesload (il:sysload il:from il:hyperusers) "RRExec") (il:filesload (il:from il:lispusers) "Vanilla-Init")) (il:* il:|;;;| "----- Set up POST Generic Init Variables.") (il:vars (il:enforce.icon.regions (list (il:createregion 0 (* 1/6 il:screenheight) il:screenwidth (* 5/6 il:screenheight)))) (il:lafitehardcopybatchflg) (il:lafitebrowserregion (il:createregion (floor (* il:screenwidth 2/5)) (floor (* il:screenheight 2/11)) (floor (* il:screenwidth 3/5)) (floor (* il:screenheight 1/5)))) (il:lafitedisplayregion (il:createregion (floor (* il:screenwidth 2/5)) (floor (* il:screenheight 25/64)) (floor (* il:screenwidth 3/5)) (floor (* il:screenheight 7/12))))) (il:* il:|;;;| "----- SETUP HyperDesk Suite ------") (il:initvars (il:*hyperdesk-suites-p* t) (il:*hyperdesk-ax-original-p* t) (il:*hyperdesk-ax-pockets-p* t) (il:*hyperfloor-suite-p* t) (il:*hyperdesk-suite-p* t) (il:*hyperdesk-user-suites* nil)) (il:p (when (and il:*hyperdesk-full-init-p* il:*hyperdesk-suites-p*) (when il:*hyperfloor-suite-p* (il:filesload (il:from lispusers) "HyperFloor.Suite") (when il:*hyperdesk-suite-p* (il:filesload (il:from lispusers) "HyperDesk.Suite"))) (dolist (suite il:*hyperdesk-user-suites*) (load suite)) (remove-junk-rooms il:*hyperdesk-ax-original-p* il:*hyperdesk-ax-pockets-p*)) (when (not (and il:*hyperdesk-full-init-p* il:*hyperdesk-suites-p* il:*hyperfloor-suite-p*)) (il:|AddLoadMenuItem| "Rooms" (quote ((il:from il:users) "HyperFloor.Suite")))) (when (not (and il:*hyperdesk-full-init-p* il:*hyperdesk-suites-p* il:*hyperfloor-suite-p* il:*hyperdesk-suite-p*)) (il:|AddLoadMenuItem| "Rooms" (quote ((il:from il:users) "HyperDesk.Suite"))))) (il:* il:|;;;| "----- HYPERDESK LOADED -----") (il:p (il:log-hyperdesk-user)) (il:vars (il:*hyperdesk-init-loaded* t))) (il:* il:|;;| "") (il:declare\: il:dontcopy (il:props (il:hyperdesk-init il:makefile-environment) (il:hyperdesk-init il:filetype))))) (il:* il:|;;| "HYPERDESK INIT") (il:* il:|;;| "Stuff needed even when just source is loaded") (il:filesload (il:sysload il:from il:lispusers) il:hyperdesk-log) (defun remove-junk-rooms (ax-original-p ax-pockets-p) (macrolet ((rooms-funcall (fn . args) (il:bquote (funcall (intern (symbol-name (il:\\\, fn)) "ROOMS") (il:\\\,@ args)))) (rooms-intern (name) (il:bquote (eval (intern (il:\\\, name) "ROOMS"))))) (let ((original (gethash "Original" (rooms-intern "*ROOMS*"))) (pockets (gethash "Pockets" (rooms-intern "*ROOMS*")))) (when (and ax-original-p original) (when (equal (rooms-funcall (quote room-name) (rooms-intern "*CURRENT-ROOM*")) "Original") (rooms-funcall (quote add-placement) (rooms-funcall (quote make-placement) (il:wfromds t)) (rooms-intern "*OVERVIEW-ROOM*")) (rooms-funcall (quote go-to-overview))) (rooms-funcall (quote delete-room) original)) (when (and ax-pockets-p pockets) (rooms-funcall (quote delete-room) pockets))))) (il:addtovar il:fontdefs (il:hyperdesk (il:fontchangeflg . il:all) (il:filelinelength . 102) (il:commentlinelength 80 . 102) (il:lambdafontlinelength . 95) (il:firstcol . 60) (il:prettylcom . 25) (il:listfilestr . " ") (il:|ObjectDontPPFlag| . t) (il:sysprettyflg . t) (il:**comment**flg) (il:fontprofile (il:defaultfont 1 (il:gacha 10) (il:gacha 8) (il:terminal 8)) (il:boldfont 2 (il:helvetica 10 il:brr) (il:helvetica 8 il:brr) (il:modern 8 il:brr)) (il:littlefont 3 (il:helvetica 8) (il:helvetica 6 il:mir) (il:modern 6 il:mir)) (il:bigfont 4 (il:helvetica 12 il:brr) (il:helvetica 10 il:brr) (il:modern 10 il:brr)) (il:userfont il:boldfont) (il:commentfont il:littlefont) (il:lambdafont il:bigfont) (il:systemfont) (il:clispfont il:boldfont) (il:changefont) (il:prettycomfont il:boldfont) (il:tinyfont il:littlefont) (il:font1 il:defaultfont) (il:font2 il:boldfont) (il:font3 il:littlefont) (il:font4 il:bigfont) (il:font5 5 (il:helvetica 10 il:bir) (il:helvetica 8 il:bir) (il:modern 8 il:bir)) (il:font6 6 (il:helvetica 10 il:brr) (il:helvetica 8 il:brr) (il:modern 8 il:brr)) (il:font7 7 (il:gacha 12) (il:gacha 12) (il:terminal 12)) (il:font8 8 (il:cream 10) (il:cream 10) (il:modern 10 il:mir)) (il:font9 9 (il:cream 10 il:brr) (il:cream 10 il:brr) (il:modern 10 il:bir)) (il:font10 10 (il:cream 12) (il:cream 12) (il:modern 12 il:mir)) (il:font11 11 (il:timesroman 10) (il:timesroman 10) (il:classic 10)) (il:font12 12 (il:timesroman 12) (il:timesroman 12) (il:classic 12)) (il:|\\WindowTitleFont| il:bigfont) (il:lafitetitlefont il:|\\WindowTitleFont|) (il:chat.font il:font7) (il:lafitehardcopyfont il:font12)))) (il:* il:|;;| "Only Evalled at load of Compile") (il:declare\: il:donteval@load il:donteval@compile (il:rpaq? *hyperdesk-sysout-p* (il:strpos "HyperDesk" il:heraldstring)) (il:rpaq? *superdesk-sysout-p* (il:strpos "SuperDesk" il:heraldstring)) (il:rpaqq *hyperdesk-init-p* t) (il:rpaqq il:hyperusersdirectories (il:{eg\:}lisp>medley> il:{eg\:}lisp>users> il:{eg\:}lisp>users>)) (il:rpaq? il:usersdirectories il:hyperusersdirectories) (il:rpaq? il:*generic-init-loaded* nil) (il:rpaq? il:*hyperdesk-init-loaded* nil) (il:rpaq? *hyperdesk-init-logged*) (il:rpaq? il:\\cc-hyperdesk-msg t) (il:addtovar il:greetdates ("27-JAN" . "Happy Mozart's birthday") (" 1-APR" . "Hello fool") (" 5-MAY" . "Happy Cinco de Mayo") (" 6-AUG" . "Hiroshima day") (" 9-AUG" . "Nagasaki day") ("11-NOV" . "Remember the 11th hour of the 11th day of the 11th month")) (il:rpaq? il:*hyperdesk-full-init-p* (il:memb (il:askuser 7 (quote il:y) "Do a full initialization? ") (quote (il:y t)))) (il:appendtovar il:|*AddressBookFiles*| il:{indigo}parcphonelist.txt) (il:rpaq? il:*hyperdesk-base-modules*) (il:rpaq? il:*hyperdesk-modules* (quote ("Load-PCL" "Rooms" "Common-Lens" "Clens-Rooms" "Random-Window-Types" "Notecards-Window-Types" "Lafite-Window-Types"))) (il:rpaq? il:*hyperdesk-extra-modules*) (il:rpaq? il:*load-utility-options* (if il:*hyperdesk-full-init-p* (append il:*hyperdesk-base-modules* il:*hyperdesk-modules* il:*hyperdesk-extra-modules*) (if *hyperdesk-sysout-p* (quote ("Rooms"))))) (il:rpaq? il:\\use-lens? t) (il:rpaq? il:\\turn-on-mailer nil) (il:rpaq? il:*load-silent* t) (il:rpaq? il:\\font-profile-name (quote il:hyperdesk)) (il:filesload (il:sysload il:from il:hyperusers) "RRExec") (il:filesload (il:from il:lispusers) "Vanilla-Init") (il:rpaq il:enforce.icon.regions (list (il:createregion 0 (* 1/6 il:screenheight) il:screenwidth (* 5/6 il:screenheight)))) (il:rpaqq il:lafitehardcopybatchflg nil) (il:rpaq il:lafitebrowserregion (il:createregion (floor (* il:screenwidth 2/5)) (floor (* il:screenheight 2/11)) (floor (* il:screenwidth 3/5)) (floor (* il:screenheight 1/5)))) (il:rpaq il:lafitedisplayregion (il:createregion (floor (* il:screenwidth 2/5)) (floor (* il:screenheight 25/64)) (floor (* il:screenwidth 3/5)) (floor (* il:screenheight 7/12)))) (il:rpaq? il:*hyperdesk-suites-p* t) (il:rpaq? il:*hyperdesk-ax-original-p* t) (il:rpaq? il:*hyperdesk-ax-pockets-p* t) (il:rpaq? il:*hyperfloor-suite-p* t) (il:rpaq? il:*hyperdesk-suite-p* t) (il:rpaq? il:*hyperdesk-user-suites* nil) (when (and il:*hyperdesk-full-init-p* il:*hyperdesk-suites-p*) (when il:*hyperfloor-suite-p* (il:filesload (il:from lispusers) "HyperFloor.Suite") (when il:*hyperdesk-suite-p* (il:filesload (il:from lispusers) "HyperDesk.Suite"))) (dolist (suite il:*hyperdesk-user-suites*) (load suite)) (remove-junk-rooms il:*hyperdesk-ax-original-p* il:*hyperdesk-ax-pockets-p*)) (when (not (and il:*hyperdesk-full-init-p* il:*hyperdesk-suites-p* il:*hyperfloor-suite-p*)) (il:|AddLoadMenuItem| "Rooms" (quote ((il:from il:users) "HyperFloor.Suite")))) (when (not (and il:*hyperdesk-full-init-p* il:*hyperdesk-suites-p* il:*hyperfloor-suite-p* il:*hyperdesk-suite-p*)) (il:|AddLoadMenuItem| "Rooms" (quote ((il:from il:users) "HyperDesk.Suite")))) (il:log-hyperdesk-user) (il:rpaqq il:*hyperdesk-init-loaded* t) ) (il:* il:|;;| "") (il:declare\: il:dontcopy (il:putprops il:hyperdesk-init il:makefile-environment (:package "XCL-USER" :readtable "XCL" :base 10)) (il:putprops il:hyperdesk-init il:filetype :compile-file) ) (il:putprops il:hyperdesk-init il:copyright ("Xerox Corporation" 1988 1989)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/HYPERDESK-LOG b/lispusers/HYPERDESK-LOG new file mode 100644 index 00000000..7dd9da9e --- /dev/null +++ b/lispusers/HYPERDESK-LOG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10) (il:filecreated " 1-Feb-89 14:44:47" il:|{EG:PARC:XEROX}LISP>MEDLEY>HYPERDESK-LOG.;3| 2633 il:|changes| il:|to:| (il:vars il:hyperdesk-logcoms) (il:functions il:make-hyperdesk-bug-report il:log-hyperdesk-user) il:|previous| il:|date:| " 1-Feb-89 14:41:24" il:|{EG:PARC:XEROX}LISP>MEDLEY>HYPERDESK-LOG.;2|) ; Copyright (c) 1989 by Xerox Corporation. All rights reserved. (il:prettycomprint il:hyperdesk-logcoms) (il:rpaqq il:hyperdesk-logcoms ((il:initvars (*hyperdesk-sysout-p*) (*superdesk-sysout-p*) (*hyperdesk-init-p*) (il:\\cc-hyperdesk-msg t) (*hyperdesk-maintainers* "Burwell.pa, Rao.pa")) (il:functions il:log-hyperdesk-user il:make-hyperdesk-bug-report) (il:p (pushnew (quote ("HyperDesk Report" (quote il:make-hyperdesk-bug-report) "Report a bug in HyperDesk")) il:lafitespecialforms :test (quote equal) :key (quote car)) (setq il:lafiteformsmenu nil)) (il:declare\: il:dontcopy (il:props (il:hyperdesk-log il:makefile-environment) (il:hyperdesk-log il:filetype))))) (il:rpaq? *hyperdesk-sysout-p*) (il:rpaq? *superdesk-sysout-p*) (il:rpaq? *hyperdesk-init-p*) (il:rpaq? il:\\cc-hyperdesk-msg t) (il:rpaq? *hyperdesk-maintainers* "Burwell.pa, Rao.pa") (defun il:log-hyperdesk-user nil "If another person uses Generic-Init, let me know." (unless *hyperdesk-init-logged* (ignore-errors (let ((user (il:if il:\\cc-hyperdesk-msg il:then (il:username) il:else "")) (maintainer *hyperdesk-maintainers*)) (unless (string-equal (il:username) maintainer) (il:lafite.sendmessage (format nil "Subject: ~A~%To: ~A~%Cc: ~A~@{~%~%~A~}" (format nil "Using Sysout: ~a, Hyper Init File: ~a" (if *hyperdesk-sysout-p* "Hyper" (if *superdesk-sysout-p* "Super" "Guess")) *hyperdesk-init-p*) maintainer user "If you hate seeing this message, set IL:\\CC-HYPERDESK-MSG to NIL in your Init file or ask rr to." "Call x4716 or xBEC for instant help" "Thanks for making the HyperDesk available.")))) (setq *hyperdesk-init-logged* t)))) (defun il:make-hyperdesk-bug-report nil (il:makexxxsupportform "HyperDesk" *hyperdesk-maintainers* il:heraldstring)) (pushnew (quote ("HyperDesk Report" (quote il:make-hyperdesk-bug-report) "Report a bug in HyperDesk")) il:lafitespecialforms :test (quote equal) :key (quote car)) (setq il:lafiteformsmenu nil) (il:declare\: il:dontcopy (il:putprops il:hyperdesk-log il:makefile-environment (:package "XCL-USER" :readtable "XCL" :base 10)) (il:putprops il:hyperdesk-log il:filetype :compile-file) ) (il:putprops il:hyperdesk-log il:copyright ("Xerox Corporation" 1989)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/HYPERDESK.SUITE b/lispusers/HYPERDESK.SUITE new file mode 100644 index 00000000..6aecbc84 --- /dev/null +++ b/lispusers/HYPERDESK.SUITE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM)) ) (il:filecreated " 3-May-88 18:06:18" il:|{EG:PARC:XEROX}HYPERDESK>HYPERDESK.SUITE;17| 2245 il:|changes| il:|to:| (il:suites "HYPERDESK") il:|previous| il:|date:| "26-Apr-88 14:20:53" il:|{EG:PARC:XEROX}HYPERDESK>HYPERDESK.SUITE;15|) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:hyperdeskcoms) (il:rpaqq il:hyperdeskcoms ((il:files il:rooms) (file-environments il:hyperdesk.suite) (il:suites "HYPERDESK"))) (il:filesload il:rooms) (define-file-environment il:hyperdesk.suite :package (defpackage "ROOMS" (:use "LISP" "XCL") (:shadow cl:room)) :readtable "XCL" :compiler :compile-file) (defsuite "HYPERDESK" (:version 1) (:files) (:window 0 :type :lens-operation "Get Mail" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :inverted? nil :position (0 . 0)) (:window 1 :type :lens-folder-web) (:window 2 :type :lens-operation "Auto Mode" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :inverted? nil :position (0 . 0)) (:window 3 :type :lens-operation "Browse" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :inverted? nil :position (0 . 0)) (:room "Office" :placements nil :inclusions ("HyperPanel") :background ((:region (0.0 1/6 1.0 5/6) :shade (:eval il:square9.bm) :border 2) (:text "Office" :font (il:timesromand 24 (il:medium il:regular il:regular) 0 il:display) :position (0.99 . 0.155) :alignment :right-top)) :file-watch-on? nil) (:room "Mail" :placements ((0 :region (189/1024 107/808 17/256 3/101)) (1 :region (25/256 45/808 7/16 83/101) :shrunken? t :icon-position (271/1024 . 3/808)) (2 :region (271/1024 53/404 17/64 3/101)) (3 :region (271/1024 10/101 15/256 3/101))) :inclusions ("HyperPanel") :background ((:region (0.0 1/6 1.0 5/6) :shade (:eval il:wallpaper) :border 2) (:text "Mail" :font (il:timesromand 24 (il:medium il:regular il:regular) 0 il:display) :position (0.99 . 0.155) :alignment :right-top)) :file-watch-on? t)) (il:putprops il:hyperdesk.suite il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/HYPERDESK.TEDIT b/lispusers/HYPERDESK.TEDIT new file mode 100644 index 00000000..ed73e51d Binary files /dev/null and b/lispusers/HYPERDESK.TEDIT differ diff --git a/lispusers/HYPERFLOOR.SUITE b/lispusers/HYPERFLOOR.SUITE new file mode 100644 index 00000000..a8c09743 --- /dev/null +++ b/lispusers/HYPERFLOOR.SUITE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM)) ) (il:filecreated " 1-Jun-88 09:37:57" il:|{EG:PARC:XEROX}LISP>MEDLEY>HYPERFLOOR.SUITE;2| 7277 il:|changes| il:|to:| (il:suites "HYPERFLOOR") (file-environments il:hyperfloor.suite) il:|previous| il:|date:| " 3-May-88 18:03:24" il:|{EG:PARC:XEROX}HYPERDESK>HYPERFLOOR.SUITE;25|) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:hyperfloorcoms) (il:rpaqq il:hyperfloorcoms ((il:files il:rooms) (file-environments il:hyperfloor.suite) (il:suites "HYPERFLOOR"))) (il:filesload il:rooms) (define-file-environment il:hyperfloor.suite :package (defpackage "ROOMS" (:use "LISP" "XCL") (:shadow cl:room)) :readtable "XCL" :compiler :compile-file) (defsuite "HYPERFLOOR" (:version 1) (:files il:who-line il:random-window-types il:printermenu il:biclock) (:window 0 :type :button :text "Overview" :font (il:helvetica 10 (il:bold il:regular il:regular)) :shadows nil :type :ark :help "Enter the overview" :action (go-to-overview) :inverted? nil) (:window 1 :type :who-line) (:window 2 :type :biclock) (:window 3 :type :button :text-form (il:eval *back-door-room-name*) :font (il:helvetica 8 (il:bold il:regular il:regular)) :shadows nil :type :door :help "Go to the previous room" :action (interactive-go-to-room-named *back-door-room-name*) :inverted? nil) (:window 4 :type :button :text "Office" :font (il:helvetica 10 (il:bold il:regular il:regular)) :shadows nil :type :ark :help "Go to room named \"Office\"." :action (interactive-go-to-room-named (quote "Office")) :inverted? nil :region (85/1024 59/404 41/512 13/404)) (:window 5 :type :prompt-window) (:window 6 :type :button :text "Help Room" :font (il:helvetica 10 (il:bold il:regular il:regular)) :shadows nil :type :ark :help "Go to room named \"Help Room\"." :action (interactive-go-to-room-named (quote "Help Room")) :inverted? nil :region (85/1024 59/404 41/512 13/404)) (:window 7 :type :exec :region (0.0 299/404 399/1024 35/202) :package "XCL-USER" :readtable "XCL") (:window 8 :type :button :text "Mail Room" :font (il:helvetica 10 (il:bold il:regular il:regular)) :shadows nil :type :ark :help "Go to room named \"Mail\"." :action (interactive-go-to-room-named (quote "Mail")) :inverted? nil) (:window 9 :type :button :text "Boiler Room" :font (il:helvetica 10 (il:bold il:regular il:regular)) :shadows nil :type :ark :help "Go to room named \"Boiler Room\"." :action (interactive-go-to-room-named (quote "Boiler Room")) :inverted? nil) (:window 10 :type :button :text "Go to ???" :font (il:helvetica 10 (il:bold il:regular il:regular)) :shadows nil :type :ark :help "Go to an existing room" :action (interactive-go-to-room) :inverted? nil) (:window 11 :type :lens-operation "Send Mail" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :inverted? nil :position (0 . 0)) (:window 12 :type :lens-icon-window) (:window 13 :type :printer-menu-window) (:window 14 :type :button :text "Reload HyperFloor" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Reloads the rooms that Ramana is maintaining" :action (let nil (go-to-overview) (delete-suite "HYPERFLOOR" t) (load "{EG:}HYPERDESK>HYPERFLOOR.Suite") (go-to-room (room-named "Boiler Room"))) :inverted? nil) (:window 15 :type :button :text "Logout..." :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Logs out" :action (il:logout) :inverted? nil) (:window 16 :type :button :text "Print Common-Lens Doc" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Print Common-Lens documentation file" :action (il:add.process (quote (il:listfiles "{NB:PARC:XEROX}DOC>COMMON-LENS.TED"))) :inverted? nil :position (0 . 0)) (:window 17 :type :button :text "Edit Common-Lens Doc" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Edit Common-Lens documentation file" :action (il:tedit "{NB:PARC:XEROX}doc>common-lens.ted") :inverted? nil :position (0 . 0)) (:window 18 :type :button :text "Print Generic Init Doc" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Print Generic Init documentation file" :action (il:add.process (quote (il:listfiles "{EG:PARC:XEROX}LISP>USERS>GENERIC-INIT.TEDIT"))) :inverted? nil :position (0 . 0)) (:window 19 :type :button :text "Edit Generic Init Doc" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Edit Generic Init documentation file" :action (il:tedit "{EG:PARC:XEROX}lisp>users>generic-init.tedit") :inverted? nil :position (0 . 0)) (:window 20 :type :button :text "Edit HyperDesk Doc" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Edit HyperDesk documentation file" :action (il:tedit (quote xcl-user::hyperdesk.tedit)) :inverted? nil :position (0 . 0)) (:window 21 :type :button :text "Print HyperDesk Doc" :font (il:helvetica 12 (il:bold il:regular il:regular)) :shadows nil :type :shadowed :help "Print HyperDesk documentation file" :action (il:add.process (quote (il:listfiles "HYPERDESK.TEDIT"))) :inverted? nil :position (0 . 0)) (:room "HyperPanel" :placements ((0 :region (1/1024 105/808 41/512 13/404)) (1 :region (0.0 199/202 1.0 3/202)) (2 :region (233/256 1/202 43/512 43/404)) (3 :region (3/256 1/202 59/1024 99/808)) (4 :region (45/512 105/808 41/512 13/404)) (5 :region (0.0 371/404 399/1024 53/808) :font (il:helvetica 12 (il:bold il:regular il:regular)) :border 0 :shade 65535 :title nil :operation il:invert) (6 :region (45/512 53/808 41/512 13/404)) (7 :region (0.0 299/404 399/1024 35/202)) (8 :region (45/512 79/808 41/512 13/404)) (9 :region (45/512 27/808 41/512 13/404)) (10 :region (45/512 1/808 41/512 13/404)) (11 :region (93/512 75/808 19/256 3/101)) (12 :region (47/256 1/404 9/128 9/101))) :inclusions nil :background ((:whole-screen (:eval il:windowbackgroundshade)) (:region (0.0 0.0 1.0 1/6) :shade (:eval il:grayshade) :border 2)) :file-watch-on? t) (:room "Boiler Room" :placements ((13 :region (887/1024 30/101 71/512 43/404)) (14 :region (9/1024 32/101 67/512 3/101)) (15 :region (1/128 113/404 17/256 3/101))) :inclusions ("HyperPanel") :background ((:region (0.0 1/6 1.0 5/6) :shade (:eval il:woven2) :border 2) (:text "Boiler Room" :font (il:timesromand 24 (il:medium il:regular il:regular) 0 il:display) :position (0.99 . 155) :alignment :right-top)) :file-watch-on? nil) (:room "Help Room" :placements ((16 :region (5/256 309/808 11/64 3/101)) (17 :region (11/512 335/808 85/512 3/101)) (18 :region (21/1024 111/202 5/32 3/101)) (19 :region (21/1024 59/101 77/512 3/101)) (20 :region (21/1024 415/808 73/512 3/101)) (21 :region (5/256 48/101 19/128 3/101))) :inclusions ("HyperPanel") :background ((:region (0.0 1/6 1.0 5/6) :shade (:eval il:avantbackground5) :border 2) (:text "Help Room" :font (il:timesromand 24 (il:medium il:regular il:regular) 0 il:display) :position (0.99 . 0.155) :alignment :right-top)) :file-watch-on? t)) (il:putprops il:hyperfloor.suite il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/IDEASKETCH b/lispusers/IDEASKETCH new file mode 100644 index 00000000..a0850b98 --- /dev/null +++ b/lispusers/IDEASKETCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Oct-88 17:50:59" {ERINYES}MEDLEY>IDEASKETCH.;1 14200 previous date%: "18-Feb-87 17:04:55" {PHYLUM}IDEASKETCH.;9) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IDEASKETCHCOMS) (RPAQQ IDEASKETCHCOMS [(FILES SKETCH) (COMS (* stuff for creating a writing specialized sketch window.) (FNS WRITEW.CREATE SK.TOGGLE.DEFAULT.ARROWHEAD SK.WRITING.MENU SK.ADD.SUBITEM.TO.MENU SK.SEL.AND.MAKE)) (COMS (* stuff to add writingtool to background menu) (P (SK.ADD.SUBITEM.TO.MENU BackgroundMenuCommands 'Sketch '("IdeaSketch" '(WRITEW.CREATE NIL NIL (GETREGION) NIL NIL T T) "Opens an idea sketch window.") T)) (VARS (BackgroundMenu NIL]) (FILESLOAD SKETCH) (* stuff for creating a writing specialized sketch window.) (DEFINEQ (WRITEW.CREATE [LAMBDA (SKETCH SKETCHREGION SCREENREGION TITLE INITIALSCALE BRINGUPMENU INITIALGRID) (* rrb "20-Mar-86 17:50") (* creates a sketch window with a menu that is specialized for writing.) (PROG ((SKW (SKETCHW.CREATE SKETCH SKETCHREGION SCREENREGION TITLE INITIALSCALE (  SK.WRITING.MENU ) INITIALGRID))) (* change some default to more appropriate for writing.) (SK.SET.LINE.LENGTH.MODE SKW 'NO) (SK.SET.MOVE.MODE SKW 'POINTS) (SK.SET.LINE.ARROWHEAD SKW 'LAST) (* set the arrowhead type to line for speed.) (SK.SET.ARROWHEAD.TYPE SKW 'LINE) (SK.SET.TEXT.HORIZ.ALIGN SKW 'LEFT) (SK.SET.TEXT.VERT.ALIGN SKW 'TOP) (RETURN SKW]) (SK.TOGGLE.DEFAULT.ARROWHEAD [LAMBDA (W) (* rrb "12-Jan-85 11:03") (* sets whether or not the default line has an arrowhead.) (PROG [(SKETCHCONTEXT (WINDOWPROP W 'SKETCHCONTEXT] (RETURN (replace (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKETCHCONTEXT with (COND ((EQ (fetch (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKETCHCONTEXT ) 'LAST) (* if the last setting was LAST, make it NEITHER) 'NEITHER) (T 'LAST]) (SK.WRITING.MENU [LAMBDA (MENUTITLE) (* rrb "28-Aug-85 11:06") (* returns the control menu for a writing window.) (create MENU ITEMS _ [APPEND '(("Move points" SK.MOVE.POINTS "Moves a collection of control points.")) '((Change SK.CHANGE.ELT "Changes a property of a piece.")) (for ELEMENT in '(TEXTBOX) when [fetch (SKETCHTYPE LABEL) of (SETQ ELEMENT (GETPROP ELEMENT 'SKETCHTYPE] collect (* add the sketch elements that have a label.) (LIST (fetch (SKETCHTYPE LABEL) of ELEMENT) ELEMENT (fetch (SKETCHTYPE DOCSTR) of ELEMENT))) '(("font LARGE" (SK.SEL.AND.MAKE '(TEXT LARGER)) "Makes the font larger.") ("font small" (SK.SEL.AND.MAKE '(TEXT SMALLER)) "Makes the font of selected items smaller.") ("BOLD" (SK.SEL.AND.MAKE '(TEXT BOLD)) "makes selected text bold." (SUBITEMS ("Default BOLD" (SK.SET.DEFAULT.TEXT.FACE '(BOLD REGULAR REGULAR)) "makes the default text bold.") ("Default unbold" (SK.SET.DEFAULT.TEXT.FACE '(MEDIUM REGULAR REGULAR)) "makes the default text unbold."))) ("line size" (SK.SEL.AND.MAKE (LIST 'SIZE (READBRUSHSIZE))) "sets the line size of selected elements." (SUBITEMS ("Default line size" (SK.SET.DEFAULT.BRUSH.SIZE ( READBRUSHSIZE )) "sets the line size of any newly constructed lines." ))) ("More Menu" SK.SKETCH.MENU "pops up the normal sketch command menu.")) '[("Move view" SKETCH.ZOOM "makes a new region the part of the sketch visible." (SUBITEMS ("Move view" SKETCH.ZOOM "changes the scale of the display.") (AutoZoom SKETCH.AUTOZOOM "changes the scale around a selected point.") (Home SKETCH.HOME "returns to the origin at the original scale") ("Fit it" SK.FRAME.IT "moves so that the entire sketch just fits in the window" ) ("Restore view" SK.RESTORE.VIEW "Moves to a previously saved view." (SUBITEMS ("Restore view" SK.RESTORE.VIEW "Moves to a previously saved view." ) ("Save view" SK.NAME.CURRENT.VIEW "saves the current view (position and scale) of the sketch for easy return." ) ("Forget view" SK.FORGET.VIEW "Deletes a previously saved view."))) ("Coord window" ADD.GLOBAL.DISPLAY "creates a window that shows the cursor in global coordinates." (SUBITEMS ("Coord window" ADD.GLOBAL.DISPLAY "creates a window that shows the cursor position in global coordinates." ) ("Grid coord window" ADD.GLOBAL.GRIDDED.DISPLAY "creates a window that shows the grid position nearest the cursor in global coordinates." ))) (New% window SKETCH.NEW.VIEW "opens another viewer onto this sketch"] '[(HardCopy HARDCOPYIMAGEW "sends a copy of the current window contents on the default printer." (SUBITEMS ("To a file" HARDCOPYIMAGEW.TOFILE "Puts image on a file; prompts for filename and format" ) ("To a printer" HARDCOPYIMAGEW.TOPRINTER "Sends image to a printer of your choosing") ("Whole sketch" SK.LIST.IMAGE "Sends the image of the whole sketch at the current scale to the printer." (SUBITEMS ("To a file" HARDCOPYIMAGEW.TOFILE "Puts image on a file; prompts for filename and format" ) ("To a printer" HARDCOPYIMAGEW.TOPRINTER "Sends image to a printer of your choosing" ))) (Hardcopy% Display SK.SET.HARDCOPY.MODE "Makes the display correspond to the hardcopy image on the default printer." ) (Normal% Display SK.UNSET.HARDCOPY.MODE "Changes the display to use display fonts."] [AND ALLOWSKETCHPUTFLG '((Put SK.PUT.ON.FILE "saves this sketch on a file"] [AND ALLOWSKETCHPUTFLG '((Get SK.GET.FROM.FILE "gets a sketch from a file." ] '((Redisplay REDISPLAYW "repaints the sketch image."] CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION SKETCHW.SELECTIONFN) MENUFONT _ (FONTNAMELIST (FONTCREATE BOLDFONT)) TITLE _ MENUTITLE]) (SK.ADD.SUBITEM.TO.MENU [LAMBDA (ITEMLST ITEMLABEL NEWSUBITEM NOERRORFLG) (* rrb "20-Mar-86 17:52") (* adds a new subitem to an item.) (PROG ((ITEMS (COND ((type? MENU ITEMLST) (fetch (MENU ITEMS) of ITEMLST)) (T ITEMLST))) ITEM) (SETQ ITEM (SASSOC ITEMLABEL ITEMS)) [COND [(NULL ITEM) (COND [(SETQ ITEM (MEMBER ITEMLABEL ITEMS)) (* item is standalone.) (RPLACA ITEM (LIST (CAR ITEM) (KWOTE (CAR ITEM)) NIL (LIST 'SUBITEMS NEWSUBITEM] (NOERRORFLG (* couldn't find item.) (RETURN)) (T (ERROR "Couldn't find item in item lst."] [(NULL (CDR ITEM)) (* item is just a label?) (NCONC ITEM (LIST (KWOTE (CAR ITEM)) NIL (LIST 'SUBITEMS NEWSUBITEM] [(NULL (CDDR ITEM)) (* no help string) (NCONC ITEM (LIST NIL (LIST 'SUBITEMS NEWSUBITEM] ((NULL (CDDDR ITEM)) (* no help string) (NCONC1 ITEM (LIST 'SUBITEMS NEWSUBITEM))) ((EQ (CAR (CADDDR ITEM)) 'SUBITEMS) (OR (MEMBER NEWSUBITEM (CADDDR ITEM)) (NCONC1 (CADDDR ITEM) NEWSUBITEM))) (T (* item is of some foreign form splice it in.) (RPLACD (CDDDR ITEM) (CONS (LIST 'SUBITEMS NEWSUBITEM) (CDDDR ITEM] (COND ((type? MENU ITEMLST) (UPDATE/MENU/IMAGE ITEMLST]) (SK.SEL.AND.MAKE [LAMBDA (CHANGECOMMAND W) (* rrb "18-Feb-87 17:04") (* lets the user select elements and applies the given change command to them.) (SK.APPLY.CHANGE.COMMAND (FUNCTION SK.ELEMENTS.CHANGEFN) CHANGECOMMAND (SK.SELECT.MULTIPLE.ITEMS W T) W]) ) (* stuff to add writingtool to background menu) (SK.ADD.SUBITEM.TO.MENU BackgroundMenuCommands 'Sketch '("IdeaSketch" '(WRITEW.CREATE NIL NIL (GETREGION) NIL NIL T T) "Opens an idea sketch window.") T) (RPAQQ BackgroundMenu NIL) (PUTPROPS IDEASKETCH COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1108 13793 (WRITEW.CREATE 1118 . 2379) (SK.TOGGLE.DEFAULT.ARROWHEAD 2381 . 3363) ( SK.WRITING.MENU 3365 . 11174) (SK.ADD.SUBITEM.TO.MENU 11176 . 13274) (SK.SEL.AND.MAKE 13276 . 13791))) )) STOP \ No newline at end of file diff --git a/lispusers/IDEASKETCH.TEDIT b/lispusers/IDEASKETCH.TEDIT new file mode 100644 index 00000000..775a1766 Binary files /dev/null and b/lispusers/IDEASKETCH.TEDIT differ diff --git a/lispusers/IDLEDRAIN b/lispusers/IDLEDRAIN new file mode 100644 index 00000000..d4daf5fd --- /dev/null +++ b/lispusers/IDLEDRAIN @@ -0,0 +1 @@ +(FILECREATED "28-May-86 12:00:22" {ERIS}KOTO>IDLEDRAIN.;2 2598 changes to: (FNS IDLE-DRAIN) (VARS IDLEDRAINCOMS) previous date: "28-May-86 11:44:43" {ERIS}KOTO>IDLEDRAIN.;1) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT IDLEDRAINCOMS) (RPAQQ IDLEDRAINCOMS ([ADDVARS (IDLE.FUNCTIONS ("Drain" (QUOTE IDLE-DRAIN] (FNS IDLE-DRAIN))) (ADDTOVAR IDLE.FUNCTIONS ("Drain" (QUOTE IDLE-DRAIN))) (DEFINEQ (IDLE-DRAIN [LAMBDA (WINDOW) (* hdj "28-May-86 11:52") (do (BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)) NIL NIL WINDOW NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) (LET* ((WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH))) (HEIGHT (WINDOWPROP WINDOW (QUOTE HEIGHT))) (HALF-WIDTH (IQUOTIENT WIDTH 2)) (HALF-HEIGHT (IQUOTIENT HEIGHT 2))) (for EDGE from 0 to (MIN HALF-WIDTH HALF-HEIGHT) do (BLOCK) (BITBLT WINDOW EDGE 0 WINDOW (1+ EDGE) 0 (- HALF-WIDTH EDGE) HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE WINDOW EDGE 0 1 HEIGHT (QUOTE REPLACE)) (BITBLT WINDOW (1+ HALF-WIDTH) 0 WINDOW HALF-WIDTH 0 (- HALF-WIDTH EDGE) HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE WINDOW (- WIDTH EDGE) 0 1 HEIGHT (QUOTE REPLACE)) (BITBLT WINDOW 0 EDGE WINDOW 0 (1+ EDGE) WIDTH (- HALF-HEIGHT EDGE) (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE WINDOW 0 EDGE WIDTH 1 (QUOTE REPLACE)) (BITBLT WINDOW 0 (+ HALF-HEIGHT EDGE 1) WINDOW 0 (+ HALF-HEIGHT EDGE) WIDTH (- HALF-HEIGHT EDGE) (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE WINDOW 0 (- HEIGHT EDGE) WIDTH 1 (QUOTE REPLACE]) ) (PUTPROPS IDLEDRAIN COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (520 2518 (IDLE-DRAIN 530 . 2516))))) STOP \ No newline at end of file diff --git a/lispusers/IDLEHAX b/lispusers/IDLEHAX new file mode 100644 index 00000000..7f4ab4c9 --- /dev/null +++ b/lispusers/IDLEHAX @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Sep-91 14:35:23" |{PELE:MV:ENVOS}MEDLEY>IDLEHAX.;2| 22593 changes to%: (FNS CONNECTPOLYS RANDOMPT KAL.ORAND) (VARS IDLEHAXCOMS) (RECORDS KALFIXP) previous date%: "10-Jun-88 17:50:01" |{PELE:MV:ENVOS}MEDLEY>IDLEHAX.;1|) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IDLEHAXCOMS) (RPAQQ IDLEHAXCOMS ([COMS [ADDVARS (IDLE.FUNCTIONS (Lines 'LINES) (Warp-Out 'WARP) (Radar 'WALKINGSPOKE) [Triangles (FUNCTION (LAMBDA (W) (LINES W 3 1 40] [RandAngles (FUNCTION (LAMBDA (W) (LINES W (RAND 3 7) (RAND 1 16) (RAND 25 100] (Polygons 'POLYGONS) (Bubbles 'BUBBLES) (Kaleidoscope 'KALDEMO) (Windows 'IDLE-WINDOWS] (VARS (IDLE.DEFAULTFN 'LINES] (COMS (* ; "for drawing polygons") (FNS POLYGONSDEMO POLYGONS CONNECTPOLYS DRAWPOLY1 RANDOMPT) (INITVARS (POLYGONSWINDOW)) (VARS POLYGONWAIT2 POLYGONMINPTS POLYGONMAXPTS POLYGONSTEPS POLYGONWAIT) (RECORDS NPOINT)) (COMS (* ; "and dots") (DECLARE%: DONTCOPY (RECORDS KALSTATE KALFIXP) (CONSTANTS KAL.MASK)) (FNS KALDEMO KAL.ADVANCE KAL.SPOTS KAL.BMS KAL.ORAND)) (COMS (* ; "Fun with circles...") (FNS BUBBLES BUBBLE.CREATE) (VARS (BUBBLECNT 20)) (FNS IDLE-WINDOWS)) (COMS (* ; "line drawing demo") (FNS LINES LINES1 LINES2 LINES3) (VARS LINECNT)) (COMS (* ; "circles and lines") (FNS WALKINGSPOKE WARP)) [COMS (* ; "melting") (FNS IDLE-MELT IDLE-SLIDE) (VARS MELT-BLOCK-SIZE) (ADDVARS (IDLE.FUNCTIONS ("Melt screen" 'IDLE-MELT) ("Slide screen" 'IDLE-SLIDE] (COMS (* ; "utilities") (FNS DEMOWINDOW) (GLOBALVARS BLOCKTIMER) (MACROS PERIODIC.BLOCK)))) (ADDTOVAR IDLE.FUNCTIONS (Lines 'LINES) (Warp-Out 'WARP) (Radar 'WALKINGSPOKE) [Triangles (FUNCTION (LAMBDA (W) (LINES W 3 1 40] [RandAngles (FUNCTION (LAMBDA (W) (LINES W (RAND 3 7) (RAND 1 16) (RAND 25 100] (Polygons 'POLYGONS) (Bubbles 'BUBBLES) (Kaleidoscope 'KALDEMO) (Windows 'IDLE-WINDOWS)) (RPAQQ IDLE.DEFAULTFN LINES) (* ; "for drawing polygons") (DEFINEQ (POLYGONSDEMO (LAMBDA NIL (* hts%: "20-AUG-83 22:55") (POLYGONS (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW (QUOTE (200 150 600 500))))) T (SETUPTIMER 10000))) ) (POLYGONS (LAMBDA (W) (* lmm "30-Jul-85 20:31") (SETQ W (DEMOWINDOW W)) (LET ((OP (if (VIDEOCOLOR) then (QUOTE PAINT) else (QUOTE ERASE)))) (bind NPOINTS do (SETQ NPOINTS (RAND POLYGONMINPTS POLYGONMAXPTS)) (CONNECTPOLYS (for I from 1 to NPOINTS collect (RANDOMPT W)) (for I from 1 to NPOINTS collect (RANDOMPT W)) POLYGONSTEPS W OP) (DISMISS POLYGONWAIT)))) ) (CONNECTPOLYS [LAMBDA (FROMS TOS NSTEPS W OPERATION) (* lmm "30-Jul-85 17:19") (PROG (DIFFS) (CLEARW W) (LINES2 FROMS 3 W OPERATION) (SETQ DIFFS (for FPT in FROMS as TPT in TOS bind DX DY collect (SETQ DX (IQUOTIENT (IDIFFERENCE (fetch XC of TPT) (fetch XC of FPT)) POLYGONSTEPS)) (SETQ DY (IQUOTIENT (IDIFFERENCE (fetch YC of TPT) (fetch YC of FPT)) POLYGONSTEPS)) (replace XC of TPT with (IPLUS (fetch XC of FPT) (ITIMES POLYGONSTEPS DX))) (replace YC of TPT with (IPLUS (fetch YC of FPT) (ITIMES POLYGONSTEPS DY))) (CONS DX DY))) (LINES2 TOS 3 W OPERATION) (for FPT in FROMS as TPT in TOS do (DRAWLINE (fetch XC of FPT) (fetch YC of FPT) (fetch XC of TPT) (fetch YC of TPT) 1 OPERATION W)) (DISMISS POLYGONWAIT2) (CLEARW W) (for I from 1 to POLYGONSTEPS do (BLOCK) (LINES2 FROMS 1 W OPERATION) (for PT in FROMS as DIF in DIFFS do (add (fetch XC of PT) (CAR DIF)) (add (fetch YC of PT) (CDR DIF))) finally (LINES2 FROMS 1 W OPERATION]) (DRAWPOLY1 (LAMBDA (PTLIST WIDTH OPERATION W NOBLOCK) (* edited%: "19-AUG-83 04:14") (* draws a closed polygon of the points given If OPERATION is not given, use the one from the default DS.) (COND (PTLIST (OR OPERATION (SETQ OPERATION (DSPOPERATION NIL W))) (PROG ((PTS PTLIST)) (while (CDR PTS) do (DRAWLINE (fetch XC of (CAR PTS)) (fetch YC of (CAR PTS)) (fetch XC of (CADR PTS)) (fetch YC of (CADR PTS)) WIDTH OPERATION W) (pop PTS) finally (DRAWLINE (fetch XC of (CAR PTS)) (fetch YC of (CAR PTS)) (fetch XC of (CAR PTLIST)) (fetch YC of (CAR PTLIST)) WIDTH OPERATION W))))) (COND (NOBLOCK (ALLOW.BUTTON.EVENTS)) (T (BLOCK)))) ) (RANDOMPT [LAMBDA (DS) (* edited%: "18-AUG-83 16:22") (PROG ((REG (DSPCLIPPINGREGION NIL DS))) (RETURN (create NPOINT XC _ (RAND (fetch LEFT of REG) (fetch RIGHT of REG)) YC _ (RAND (fetch BOTTOM of REG) (fetch TOP of REG]) ) (RPAQ? POLYGONSWINDOW ) (RPAQQ POLYGONWAIT2 250) (RPAQQ POLYGONMINPTS 3) (RPAQQ POLYGONMAXPTS 9) (RPAQQ POLYGONSTEPS 35) (RPAQQ POLYGONWAIT 2000) (DECLARE%: EVAL@COMPILE (DATATYPE NPOINT ((XC XPOINTER) (YC XPOINTER))) ) (/DECLAREDATATYPE 'NPOINT '(XPOINTER XPOINTER) '((NPOINT 0 XPOINTER) (NPOINT 2 XPOINTER)) '4) (* ; "and dots") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD KALSTATE (A B C PERIODCOUNT PERIOD)) (BLOCKRECORD KALFIXP ((VALUE FIXP))) ) (DECLARE%: EVAL@COMPILE (RPAQQ KAL.MASK 65535) (CONSTANTS KAL.MASK) ) ) (DEFINEQ (KALDEMO (LAMBDA (W PERIOD PERSISTENCE) (* lmm " 5-Aug-85 22:16") (OR PERIOD (SETQ PERIOD (RAND 8 128))) (OR PERSISTENCE (SETQ PERSISTENCE (LSH 1 (RAND 4 13)))) (SETQ W (DEMOWINDOW W)) (LET ((XSTATEB (create KALSTATE A _ 1 B _ -1849 C _ (RAND 2 4) PERIOD _ PERIOD PERIODCOUNT _ 1)) (XSTATEE (create KALSTATE)) (YSTATEB (create KALSTATE A _ 1 B _ -1809 C _ (RAND 0 20) PERIOD _ PERIOD PERIODCOUNT _ 1)) (YSTATEE (create KALSTATE)) (WINDOWSIDE (MIN (WINDOWPROP W (QUOTE HEIGHT)) (WINDOWPROP W (QUOTE WIDTH)))) (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS))) (BLACK (NOT (VIDEOCOLOR))) XOFFSET) (SETQ XOFFSET (QUOTIENT (MAX (DIFFERENCE (WINDOWPROP W (QUOTE WIDTH)) WINDOWSIDE) 0) 2)) (SETQ XSTATEE (COPY XSTATEB)) (SETQ YSTATEE (COPY YSTATEB)) (from 1 to PERSISTENCE do (KAL.ADVANCE XSTATEB) (KAL.ADVANCE YSTATEB) (KAL.SPOTS (ffetch A of XSTATEB) (ffetch A of YSTATEB) WINDOWSIDE W BLACK XOFFSET) (PERIODIC.BLOCK TIMER)) (do (KAL.ADVANCE XSTATEE) (KAL.ADVANCE YSTATEE) (PROG ((X0 (LOGAND (LRSH (ffetch A of XSTATEE) 7) KAL.MASK)) (Y0 (LOGAND (LRSH (ffetch A of YSTATEE) 7) KAL.MASK)) X1 Y1) (COND ((ILESSP X0 Y0) (SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE) X0)) (SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE) Y0)) (KAL.BMS W X0 Y0 X1 Y1 (if BLACK then 1 else 0) XOFFSET)))) (KAL.ADVANCE XSTATEB) (KAL.ADVANCE YSTATEB) (KAL.SPOTS (ffetch A of XSTATEB) (ffetch A of YSTATEB) WINDOWSIDE W BLACK XOFFSET) (PERIODIC.BLOCK TIMER)))) ) (KAL.ADVANCE (LAMBDA (STATE) (* lmm "30-Jul-85 20:16") (freplace A of STATE with (KAL.ORAND (ffetch A of STATE) (ffetch B of STATE))) (freplace PERIODCOUNT of STATE with (SUB1 (ffetch PERIODCOUNT of STATE))) (COND ((EQ (ffetch PERIODCOUNT of STATE) 0) (freplace B of STATE with (KAL.ORAND (ffetch B of STATE) (ffetch C of STATE))) (freplace PERIODCOUNT of STATE with (ffetch PERIOD of STATE))))) ) (KAL.SPOTS (LAMBDA (X Y WINDOWSIDE W BLACK XOFFSET) (* lmm " 3-Aug-85 21:59") (PROG ((X0 (LRSH X 7)) (Y0 (LRSH Y 7)) X1 Y1 C) (COND ((ILESSP X0 Y0) (SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE) X0)) (SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE) Y0)) (SETQ C (LOGAND X 1)) (KAL.BMS W X0 Y0 X1 Y1 (if BLACK then (DIFFERENCE 1 C) else C) XOFFSET))))) ) (KAL.BMS (LAMBDA (W X0 Y0 X1 Y1 C XOFFSET) (* lmm "30-Jul-85 19:38") (UNINTERRUPTABLY (if (EQUAL (GETWINDOWPROP W (QUOTE REGION)) WHOLESCREEN) then (TOTOPW W) (SETQ W (SCREENBITMAP))) (BITMAPBIT W (PLUS XOFFSET X0) Y0 C) (BITMAPBIT W (PLUS XOFFSET Y0) X0 C) (BITMAPBIT W (PLUS XOFFSET X1) Y0 C) (BITMAPBIT W (PLUS XOFFSET Y0) X1 C) (BITMAPBIT W (PLUS XOFFSET X1) Y1 C) (BITMAPBIT W (PLUS XOFFSET Y1) X1 C) (BITMAPBIT W (PLUS XOFFSET X0) Y1 C) (BITMAPBIT W (PLUS XOFFSET Y1) X0 C))) ) (KAL.ORAND [LAMBDA (A B) (* ; "Edited 26-Sep-91 14:34 by jds") (LET [(BOX (CONSTANT (NCREATE 'FIXP] (replace (KALFIXP VALUE) of BOX with A) (\BOXIPLUS BOX B) (LOGXOR (LOGAND BOX KAL.MASK) (LOGAND B KAL.MASK]) ) (* ; "Fun with circles...") (DEFINEQ (BUBBLES (LAMBDA (W) (* lmm "30-Jul-85 20:35") (WINDOWPROP (SETQ W (DEMOWINDOW W)) (QUOTE RESHAPEFN) (FUNCTION (LAMBDA (W) (DSPFILL NIL (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) (QUOTE REPLACE) W)))) (DSPFILL NIL (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) (QUOTE REPLACE) W) (bind (ARRAY _ (ARRAY BUBBLECNT (QUOTE POINTER))) (I _ 1) CIRCLE eachtime (SETQ I (if (EQ I BUBBLECNT) then 1 else (ADD1 I))) do (* * first erase the circle at I in array) (SETQ CIRCLE (ELT ARRAY I)) (DSPOPERATION (if (VIDEOCOLOR) then (QUOTE ERASE) else (QUOTE PAINT)) W) (* there will be no circle at I the first time through) (AND CIRCLE (DRAWCIRCLE (CAR CIRCLE) (CADR CIRCLE) (CADDR CIRCLE) NIL NIL W)) (* * now put a new circle in array at I and draw it) (SETQ CIRCLE (SETA ARRAY I (BUBBLE.CREATE W))) (DSPOPERATION (QUOTE REPLACE) W) (* fill center w/ black so it ocludes ones under) (FILLCIRCLE (CAR CIRCLE) (CADR CIRCLE) (SUB1 (CADDR CIRCLE)) (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) W) (DSPOPERATION (QUOTE INVERT) W) (DRAWCIRCLE (CAR CIRCLE) (CADR CIRCLE) (CADDR CIRCLE) NIL NIL W) (BLOCK))) ) (BUBBLE.CREATE (LAMBDA (W) (* drc%: "29-Jul-85 13:51") (LET* ((REGION (WINDOWPROP W (QUOTE REGION))) (WIDTH (SUB1 (fetch WIDTH of REGION))) (HEIGHT (SUB1 (fetch HEIGHT of REGION))) (CENTERX (RAND 1 (SUB1 WIDTH))) (CENTERY (RAND 1 (SUB1 HEIGHT)))) (LIST CENTERX CENTERY (RAND 1 (IMIN (IDIFFERENCE WIDTH CENTERX) CENTERX (IDIFFERENCE HEIGHT CENTERY) CENTERY))))) ) ) (RPAQQ BUBBLECNT 20) (DEFINEQ (IDLE-WINDOWS (LAMBDA (W DELAY) (* lmm " 7-Jun-86 22:21") (SETQ W (DEMOWINDOW W)) (PROG ((D (WINDOWPROP W (QUOTE WIDTH))) (H (WINDOWPROP W (QUOTE HEIGHT))) (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS)))) (LET ((TITLE (WINDOWPROP (CREATEW (LIST 0 0 D (HEIGHTIFWINDOW 0 T)) "Yet another window" NIL T) (QUOTE IMAGECOVERED)))) (while T do (PROG ((X (RAND 0 (- D (+ 2 2 100)))) (Y (RAND 0 (- H 8 100)))) (PROG ((D0 (MAX 100 (RAND 100 (- D X)))) (H0 (MAX 100 (RAND 100 (- H Y))))) (BITBLT NIL NIL NIL W X Y D0 2 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL W X Y 2 H0 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL W (+ X (- D0 2)) Y 2 H0 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT TITLE NIL (+ WBorder (QUOTIENT WBorder 2)) W X (+ Y H0) D0 NIL NIL (QUOTE REPLACE)) (BITBLT NIL NIL NIL W (+ X 2) (+ Y 2) (- D0 (+ 2 2)) (- H0 2) (QUOTE TEXTURE) (QUOTE ERASE) BLACKSHADE))) (if DELAY then (BLOCK DELAY) else (PERIODIC.BLOCK TIMER)))))) ) ) (* ; "line drawing demo") (DEFINEQ (LINES (LAMBDA (W N LCNT STEPS ODDSTEP) (* lmm "27-Sep-85 00:50") (SETQ W (DEMOWINDOW W)) (OR STEPS (SETQ STEPS POLYGONSTEPS)) (OR N (SETQ N 2)) (RESETLST (PROG ((LINES (to (OR LCNT (if (NEQ N 2) then (ADD1 (QUOTIENT LINECNT N)) else LINECNT)) collect NIL)) (CNT 0) FROMPTS TOPTS DXS (ODDSTART)) (RESETSAVE NIL (LIST (FUNCTION RPLACD) LINES)) (NCONC LINES LINES) (SETQ FROMPTS (to N collect (RANDOMPT W))) (bind (TIMER _ (SETUPTIMER 0 NIL (QUOTE TICKS))) while T do (COND ((ILEQ CNT 0) (SETQ TOPTS (bind (ODDP _ (SETQ ODDSTART (NOT ODDSTART))) for X in FROMPTS collect (if (AND ODDSTEP (SETQ ODDP (NOT ODDP))) then X else (RANDOMPT W)))) (SETQ DXS (for TP in TOPTS as FP in FROMPTS collect (create NPOINT XC _ (QUOTIENT (DIFFERENCE (fetch XC TP) (fetch XC FP)) STEPS) YC _ (QUOTIENT (DIFFERENCE (fetch YC TP) (fetch YC FP)) STEPS)))) (SETQ CNT STEPS)) (T (SETQ CNT (SUB1 CNT)))) (LINES1 FROMPTS LINES W) (for X in FROMPTS as D in DXS do (add (fetch XC X) (fetch XC D)) (add (fetch YC X) (fetch YC D))) (SETQ LINES (CDR LINES)) (PERIODIC.BLOCK TIMER))))) ) (LINES1 (LAMBDA (ENDPOINTS LINES DSP) (* lmm "30-Jul-85 17:33") (PROG (PTS) (COND ((SETQ PTS (CAR LINES)) (* ERASE OLD) (LINES3 (CAR LINES) 1 DSP (QUOTE INVERT) ENDPOINTS)) (T (RPLACA LINES (SETQ PTS (in ENDPOINTS collect (create NPOINT)))) (LINES2 ENDPOINTS 1 DSP (QUOTE INVERT)))) (for PT in PTS as EP in ENDPOINTS do (replace XC of PT with (fetch XC of EP)) (replace YC of PT with (fetch YC of EP))))) ) (LINES2 (LAMBDA (ENDPOINTS WIDTH WINDOW OPERATION) (* lmm "30-Jul-85 17:14") (for (X _ ENDPOINTS) while (OR (CDR X) (if (CDDR ENDPOINTS) then X)) do (DRAWLINE (fetch XC (CAR X)) (fetch YC (CAR X)) (fetch XC (CAR (OR (SETQ X (CDR X)) ENDPOINTS))) (fetch YC (CAR (OR X ENDPOINTS))) WIDTH OPERATION WINDOW))) ) (LINES3 (LAMBDA (ENDPOINTS WIDTH WINDOW OPERATION EP2) (* lmm "30-Jul-85 17:33") (for (X _ ENDPOINTS) while (OR (CDR X) (if (CDDR ENDPOINTS) then X)) bind (Y _ EP2) do (DRAWLINE (fetch XC (CAR X)) (fetch YC (CAR X)) (fetch XC (CAR (OR (SETQ X (CDR X)) ENDPOINTS))) (fetch YC (CAR (OR X ENDPOINTS))) WIDTH OPERATION WINDOW) (DRAWLINE (fetch XC (CAR Y)) (fetch YC (CAR Y)) (fetch XC (CAR (OR (SETQ Y (CDR Y)) EP2))) (fetch YC (CAR (OR Y EP2))) WIDTH OPERATION WINDOW))) ) ) (RPAQQ LINECNT 100) (* ; "circles and lines") (DEFINEQ (WALKINGSPOKE (LAMBDA (W) (* lmm "19-Mar-86 17:49") (LET ((W (DEMOWINDOW W)) (SINARRAY (ARRAY 360 NIL NIL 0)) (MARGIN (QUOTIENT MAX.SMALLP SCREENWIDTH))) (for N from 0 to 359 do (SETA SINARRAY N (FIXR (TIMES MARGIN (SIN N))))) (CLEARW W) (do (PROG ((WIDTH (WINDOWPROP W (QUOTE WIDTH))) (HEIGHT (WINDOWPROP W (QUOTE HEIGHT)))) (* for YY from 0 to 298 do (DRAWLINE 0 YY 298 YY 1 (QUOTE INVERT) RADARWINDOW)) (LET ((R (QUOTIENT (RAND (MIN 100 WIDTH HEIGHT) (MIN WIDTH HEIGHT)) 2))) (LET ((X (RAND R (DIFFERENCE WIDTH R))) (Y (RAND R (DIFFERENCE HEIGHT R)))) (RPTQ 2 (for N from 0 to 359 do (DRAWLINE X Y (PLUS X (QUOTIENT (TIMES R (ELT SINARRAY (IMOD (PLUS N 90) 360))) MARGIN)) (PLUS Y (QUOTIENT (TIMES R (ELT SINARRAY N)) MARGIN)) 2 (QUOTE INVERT) W) (BLOCK)) (RECLAIM)))))))) ) (WARP (LAMBDA (W) (* hdj " 1-Apr-86 14:22") (do (CLEARW W) (LET ((OLDOP (DSPOPERATION (QUOTE INVERT) W))) (LET ((WIDTH (WINDOWPROP W (QUOTE WIDTH))) (HEIGHT (WINDOWPROP W (QUOTE HEIGHT)))) (LET ((CENTERX (RAND 0 WIDTH)) (CENTERY (RAND 0 HEIGHT))) (for RADIUS from (RAND 5 250) to 5 by -2 do (FILLCIRCLE (PLUS CENTERX (RAND 0 2)) (PLUS CENTERY (RAND 0 2)) RADIUS BLACKSHADE W) (BLOCK)))) (DSPOPERATION OLDOP W)))) ) ) (* ; "melting") (DEFINEQ (IDLE-MELT [LAMBDA (WINDOW SIZE INITIAL PATH) (* ; "Edited 10-Jun-88 17:15 by MASINTER") (OR SIZE (SETQ SIZE MELT-BLOCK-SIZE)) (SETQ WINDOW (DEMOWINDOW WINDOW)) (PROG ((W (WINDOWPROP WINDOW 'WIDTH)) (H (WINDOWPROP WINDOW 'HEIGHT)) BM (TAIL INITIAL) TIMER) REPAINT (CLEARW WINDOW) [SETQ BM (OR (CAR TAIL) (WINDOWPROP WINDOW 'IMAGECOVERED] (for BITMAP inside BM do (BITBLT (SETQ BITMAP (if (BITMAPP BITMAP) then BITMAP elseif (CL:SYMBOLP BITMAP) then (CAR (READBRUSHFILE BITMAP)) else (IDLE.BITMAP NIL BITMAP))) NIL NIL WINDOW (RAND 0 (- W (BITMAPWIDTH BITMAP ))) (RAND 0 (- H (BITMAPHEIGHT BITMAP))) NIL NIL (if (VIDEOCOLOR) then NIL else 'INVERT) 'REPLACE)) (if INITIAL then [SETQ TIMER (AND (CADR TAIL) (SETUPTIMER (CADR TAIL) TIMER 'SECONDS 'SECONDS] (SETQ TAIL (OR (CDDR TAIL) INITIAL))) [do (LET [(X (RAND 0 (- W SIZE))) (Y (RAND 0 (- H SIZE] (BITBLT WINDOW X Y WINDOW (+ X (RAND -1 1)) (+ Y (RAND -1 1)) SIZE SIZE NIL 'REPLACE)) (BLOCK) repeatuntil (AND TIMER (TIMEREXPIRED? TIMER 'SECONDS] (GO REPAINT]) (IDLE-SLIDE [LAMBDA (W SIZE SPEED COUNT SOURCE) (* ; "Edited 10-Jun-88 17:12 by MASINTER") (OR SIZE (SETQ SIZE 128)) (OR COUNT (SETQ COUNT 120)) (OR SPEED (SETQ SPEED 2)) (SETQ W (DEMOWINDOW W)) (BITBLT [OR SOURCE (SETQ SOURCE (WINDOWPROP W 'IMAGECOVERED] NIL NIL W NIL NIL NIL NIL (if (VIDEOCOLOR) then NIL else 'INVERT) 'REPLACE) (LET [(D (WINDOWPROP W 'WIDTH)) (H (WINDOWPROP W 'HEIGHT] (LET [(XMAX (- D SIZE)) (YMAX (- H SIZE)) X Y DX DY (CNT 1) DDX DDY (TIMER (SETUPTIMER 0 NIL 'TICKS] (do (COND ((OR (EQ (add CNT -1) 0) (< X 0) (> X XMAX) (< Y 0) (> Y YMAX)) (SETQ X (RAND 0 XMAX)) (SETQ Y (RAND 0 YMAX)) (SETQ DX (RAND (- SPEED) SPEED)) (SETQ DY (RAND (- SPEED) SPEED)) (BITBLT SOURCE X Y W X Y SIZE SIZE NIL 'REPLACE) (SETQ DDX DY) (SETQ DDY DX) (SETQ CNT COUNT))) (BITBLT W X Y W (+ X DDX) (+ Y DDY) SIZE SIZE NIL 'REPLACE) (add X DX) (add Y DY) (PERIODIC.BLOCK TIMER]) ) (RPAQQ MELT-BLOCK-SIZE 32) (ADDTOVAR IDLE.FUNCTIONS ("Melt screen" 'IDLE-MELT) ("Slide screen" 'IDLE-SLIDE)) (* ; "utilities") (DEFINEQ (DEMOWINDOW (LAMBDA (W) (* lmm "30-Jul-85 20:34") (OR W (SETQ W (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW))))) (DSPTEXTURE (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) W) (DSPOPERATION (QUOTE INVERT) W) (CLEARW W) W) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BLOCKTIMER) ) (DECLARE%: EVAL@COMPILE (PUTPROPS PERIODIC.BLOCK MACRO [(TIMER) (if (TIMEREXPIRED? TIMER 'TICKS) then (BLOCK) (SETQ TIMER (SETUPTIMER 100 TIMER 'TICKS 'MILLISECONDS]) ) (PUTPROPS IDLEHAX COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3587 7576 (POLYGONSDEMO 3597 . 3767) (POLYGONS 3769 . 4133) (CONNECTPOLYS 4135 . 6482) (DRAWPOLY1 6484 . 7121) (RANDOMPT 7123 . 7574)) (8217 11199 (KALDEMO 8227 . 9638) (KAL.ADVANCE 9640 . 10041) (KAL.SPOTS 10043 . 10384) (KAL.BMS 10386 . 10873) (KAL.ORAND 10875 . 11197)) (11236 12722 ( BUBBLES 11246 . 12352) (BUBBLE.CREATE 12354 . 12720)) (12749 13734 (IDLE-WINDOWS 12759 . 13732)) ( 13769 16040 (LINES 13779 . 14838) (LINES1 14840 . 15250) (LINES2 15252 . 15563) (LINES3 15565 . 16038) ) (16100 17313 (WALKINGSPOKE 16110 . 16891) (WARP 16893 . 17311)) (17338 21621 (IDLE-MELT 17348 . 19864) (IDLE-SLIDE 19866 . 21619)) (21796 22042 (DEMOWINDOW 21806 . 22040))))) STOP \ No newline at end of file diff --git a/lispusers/IDLEHAX.TEDIT b/lispusers/IDLEHAX.TEDIT new file mode 100644 index 00000000..fba6d6df Binary files /dev/null and b/lispusers/IDLEHAX.TEDIT differ diff --git a/lispusers/IDLESWAP b/lispusers/IDLESWAP new file mode 100644 index 00000000..56d389a2 --- /dev/null +++ b/lispusers/IDLESWAP @@ -0,0 +1 @@ +(FILECREATED "29-May-86 23:42:08" {ERIS}KOTO>IDLESWAP.;4 2353 changes to: (FNS IDLE-SWAP) (VARS IDLESWAPCOMS) previous date: "29-May-86 23:10:51" {ERIS}KOTO>IDLESWAP.;2) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT IDLESWAPCOMS) (RPAQQ IDLESWAPCOMS [(INITVARS (IDLE-SWAP-SIZE 64)) (FNS IDLE-SWAP) (ADDVARS (IDLE.FUNCTIONS ("Swap" (QUOTE IDLE-SWAP]) (RPAQ? IDLE-SWAP-SIZE 64) (DEFINEQ (IDLE-SWAP [LAMBDA (WINDOW) (* hdj "29-May-86 23:41") (DECLARE (GLOBALVARS IDLE-SWAP-SIZE)) (BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)) NIL NIL WINDOW NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) (LET [(WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH))) (HEIGHT (WINDOWPROP WINDOW (QUOTE HEIGHT] (do (BLOCK (RAND 0 5000)) (LET [[RAND-X-1 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT WIDTH IDLE-SWAP-SIZE] [RAND-Y-1 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT HEIGHT IDLE-SWAP-SIZE] [RAND-X-2 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT WIDTH IDLE-SWAP-SIZE] (RAND-Y-2 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT HEIGHT IDLE-SWAP-SIZE] (if (AND (NEQ RAND-X-1 RAND-X-2) (NEQ RAND-Y-1 RAND-Y-2)) then (* * swap the two regions of the window using BITBLT only) (BITBLT WINDOW RAND-X-1 RAND-Y-1 WINDOW RAND-X-2 RAND-Y-2 IDLE-SWAP-SIZE IDLE-SWAP-SIZE (QUOTE INPUT) (QUOTE INVERT)) (BITBLT WINDOW RAND-X-2 RAND-Y-2 WINDOW RAND-X-1 RAND-Y-1 IDLE-SWAP-SIZE IDLE-SWAP-SIZE (QUOTE INPUT) (QUOTE INVERT)) (BITBLT WINDOW RAND-X-1 RAND-Y-1 WINDOW RAND-X-2 RAND-Y-2 IDLE-SWAP-SIZE IDLE-SWAP-SIZE (QUOTE INPUT) (QUOTE INVERT]) ) (ADDTOVAR IDLE.FUNCTIONS ("Swap" (QUOTE IDLE-SWAP))) (PUTPROPS IDLESWAP COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (532 2216 (IDLE-SWAP 542 . 2214))))) STOP \ No newline at end of file diff --git a/lispusers/INDEX b/lispusers/INDEX new file mode 100644 index 00000000..fdee4847 --- /dev/null +++ b/lispusers/INDEX @@ -0,0 +1 @@ +(FILECREATED "18-Feb-87 15:44:37" {SUMEX-AIM}PS:INDEX.;4 23471 changes to: (FNS INSERT.KNOWN.INDEX) previous date: "17-Feb-87 14:27:45" {SUMEX-AIM}PS:INDEX.;5) (* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) (PRETTYCOMPRINT INDEXCOMS) (RPAQQ INDEXCOMS ((* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (FNS INDEXOBJ INDEXOBJP INDEX.DISPLAYFN INDEX.IMAGEBOXFN INDEX.PUTFN INDEX.GETFN INDEX.BUTTONEVENTINFN CHANGE.INDEX CHANGE.INDEXENTRY INDEX.WHENDELETEDFN) (FNS ADD.NEW.INDEX INDEX.STRING INSERT.INDEX INSERT.INDEXENTRY GET.INDEXENTRY.NUMBER INSERT.KNOWN.INDEX INDEX.LIST.REFS LIST.OF.INDEXENTRIES CREATE.INDEX.FILE VIEW.INDEX.FILE GET.INDEX.FILE WRITE.INDEX.FILE WRITE.INDEX.PAGENUMBERS) (RECORDS INDEX.ENTRY.RECORD))) (* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (DEFINEQ (INDEXOBJ (LAMBDA (KEY INDEXENTRY.PARMS) (* fsg "15-Jan-87 09:53") (* * Create an instance of an Index or IndexEntry imageobject. The difference between the two is the OBJECTDATUM. For a simple Index, OBJECTDATUM is NIL. For an IndexEntry, OBJECTDATUM is a record containing the Entry, Entry's  font, and Number option. In either case, the INDEX.KEY property is the hash key and is also the text to index for a simple Index.) (LET ((NEWOBJ (IMAGEOBJCREATE INDEXENTRY.PARMS (IMAGEFNSCREATE (FUNCTION INDEX.DISPLAYFN) (FUNCTION INDEX.IMAGEBOXFN) (FUNCTION INDEX.PUTFN) (FUNCTION INDEX.GETFN) (FUNCTION NILL) (FUNCTION INDEX.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION INDEX.WHENDELETEDFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))))) (IMAGEOBJPROP NEWOBJ 'INDEX.KEY KEY) (IMAGEOBJPROP NEWOBJ 'TYPE 'INDEXOBJ) NEWOBJ))) (INDEXOBJP (LAMBDA (OBJ) (* fsg "15-Jan-87 09:55") (* * Tests an imageobject to see if it an Index or IndexEntry imageobject. By convention, testing functions for an  imageobject are named .) (AND OBJ (EQ (IMAGEOBJPROP OBJ 'TYPE) 'INDEXOBJ)))) (INDEX.DISPLAYFN (LAMBDA (OBJ STREAM) (* fsg "17-Feb-87 10:18") (* * Display an Index or IndexEntry imageobject. If the output is to the display imagestream, then just type Index  or IndexEntry followed by their args. Otherwise the output is to a hardcopy imagestream. In this case type nothing  and replace the CAR of the hash array entry with a list of page numbers in which this index entry appears.  is the current TEdit page number iff doing a hardcopy.) (LET ((WINDOW (CAR (fetch \WINDOW of TEXTOBJ))) PGS/IMOBJS CURRENT.PAGE) (SELECTQ (IMAGESTREAMTYPE STREAM) (DISPLAY (PROGN (DSPFONT GP.DefaultFont STREAM) (PRIN3 (INDEX.STRING OBJ) STREAM))) (PROGN (SETQ PGS/IMOBJS (GETHASH (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY)) (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY))) (SETQ CURRENT.PAGE (CAR FORMATTINGSTATE)) (COND (PGS/IMOBJS (COND ((LISTP (CAR PGS/IMOBJS)) (OR (MEMBER CURRENT.PAGE (CAR PGS/IMOBJS)) (RPLACA PGS/IMOBJS (SORT (APPEND (CAR PGS/IMOBJS) (LIST CURRENT.PAGE) ) 'ILESSP)))) (T (RPLACA PGS/IMOBJS (LIST CURRENT.PAGE))))) (T (SHOULDNT "No array entry for this INDEX")))))))) (INDEX.IMAGEBOXFN (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "15-Feb-87 14:37") (* * Return the ImageBox for an Index or IndexEntry request.) (SELECTQ (IMAGESTREAMTYPE STREAM) (DISPLAY (create IMAGEBOX XSIZE _(STRINGWIDTH (INDEX.STRING OBJ) GP.DefaultFont) YSIZE _(FONTPROP GP.DefaultFont 'HEIGHT) YDESC _(FONTPROP GP.DefaultFont 'DESCENT) XKERN _ 0)) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0)))) (INDEX.PUTFN (LAMBDA (OBJ STREAM) (* fsg "11-Feb-87 11:07") (* * Puts the Index or IndexEntry imageobject in a file.) (LET ((DATUM (fetch OBJECTDATUM of OBJ))) (PRIN2 (COND (DATUM (LIST 'IndexEntry (IMAGEOBJPROP OBJ 'INDEX.KEY) DATUM)) (T (LIST 'Index (IMAGEOBJPROP OBJ 'INDEX.KEY)))) STREAM)))) (INDEX.GETFN (LAMBDA (STREAM) (* fsg "11-Feb-87 10:42") (* * Create the Index or IndexEntry imageobject when it is read from file.) (LET* ((INDEX.ARGS (CDR (READ STREAM))) (NEWOBJ (APPLY 'INDEXOBJ INDEX.ARGS)) (WINDOW (PROCESSPROP (THIS.PROCESS) 'WINDOW))) (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) (TSP.FMMENU (TEXTSTREAM WINDOW))) (ADD.NEW.INDEX WINDOW (CAR INDEX.ARGS) NEWOBJ) NEWOBJ))) (INDEX.BUTTONEVENTINFN (LAMBDA (OBJ STREAM SEL RELX RELY WINDOW HOSTSTREAM BUTTON) (* fsg "15-Jan-87 11:26") (* * Process the MIDDLE button pressed inside an Index or IndexEntry imageobject. This means the user wants to  Change this index.) (AND (MOUSESTATE MIDDLE) (MENU (create MENU ITEMS _ '((Change 'CHANGE "Change this Index or IndexEntry")) CENTERFLG _ T)) (LET* ((OBJDATUM (fetch OBJECTDATUM of OBJ)) (NEW.INDEX (COND (OBJDATUM (CHANGE.INDEXENTRY OBJ STREAM OBJDATUM)) (T (CHANGE.INDEX OBJ STREAM))))) (AND (CAR NEW.INDEX) (PROGN (INDEX.WHENDELETEDFN OBJ STREAM) (IMAGEOBJPROP OBJ 'INDEX.KEY (CAR NEW.INDEX)) (AND OBJDATUM (replace OBJECTDATUM of OBJ with (CADR NEW.INDEX))) (ADD.NEW.INDEX WINDOW (CAR NEW.INDEX) OBJ) 'CHANGED)))))) (CHANGE.INDEX (LAMBDA (OBJ STREAM) (* fsg "15-Jan-87 10:54") (* * Here when CHANGE buttoned inside an Index ImageObject.) (LIST (MKATOM (TEDIT.GETINPUT STREAM (CONCAT "Change Index name %"" (IMAGEOBJPROP OBJ 'INDEX.KEY) "%" to: ")))))) (CHANGE.INDEXENTRY (LAMBDA (OBJ STREAM OBJDATUM) (* fsg "15-Jan-87 11:17") (* * Here when CHANGE buttoned inside an IndexEntry ImageObject.) (LET ((WINDOW (\TEDIT.MAINW STREAM)) NEWINDEX.KEY NEWINDEX.ENTRY NEWINDEX.FONT NEWINDEX.NUMBER) (COND ((SETQ NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM (CONCAT "Change IndexEntry Key %"" (IMAGEOBJPROP OBJ 'INDEX.KEY) "%" to: ")))) (SETQ NEWINDEX.ENTRY (OR (MKATOM (TEDIT.GETINPUT STREAM (CONCAT "Change IndexEntry Entry %"" (fetch INDEX.ENTRY of OBJDATUM) "%" to: "))) (fetch INDEX.ENTRY of OBJDATUM))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Change IndexEntry Entry font %"" (ABBREVIATE.FONT (fetch INDEX.ENTRYFONT of OBJDATUM)) "%" to...") T) (until (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW (OR (fetch INDEX.ENTRYFONT of OBJDATUM) GP.DefaultFont))) do (TEDIT.PROMPTPRINT STREAM "Invalid font specification...try again." T)) (TEDIT.PROMPTPRINT STREAM (CONCAT "Change IndexEntry Number option %"" (fetch INDEX.NUMBER of OBJDATUM) "%" to...") T) (SETQ NEWINDEX.NUMBER (GET.INDEXENTRY.NUMBER WINDOW (fetch INDEX.NUMBER of OBJDATUM))) (TEDIT.PROMPTPRINT STREAM "" T) (LIST NEWINDEX.KEY (create INDEX.ENTRY.RECORD INDEX.ENTRY _ NEWINDEX.ENTRY INDEX.ENTRYFONT _ NEWINDEX.FONT INDEX.NUMBER _ NEWINDEX.NUMBER))) (T (LIST NEWINDEX.KEY)))))) (INDEX.WHENDELETEDFN (LAMBDA (OBJ WINDOW) (* fsg "15-Jan-87 11:30") (* * Delete the selected Index or IndexEntry imageobject.) (LET* ((INDEXKEY (IMAGEOBJPROP OBJ 'INDEX.KEY)) (INDEX.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) (HASH.VALUE (GETHASH INDEXKEY INDEX.ARRAY))) (COND ((DREMOVE OBJ (COND ((fetch OBJECTDATUM of OBJ) (CADDR HASH.VALUE)) (T (CADR HASH.VALUE)))) NIL) (T (DSUBST NIL (LIST OBJ) HASH.VALUE) (PUTHASH INDEXKEY (COND ((OR (CADR HASH.VALUE) (CADDR HASH.VALUE)) HASH.VALUE) (T NIL)) INDEX.ARRAY))) NIL))) ) (DEFINEQ (ADD.NEW.INDEX (LAMBDA (WINDOW INDEXKEY OBJ) (* fsg "28-Jan-87 11:37") (* * Add an Index or IndexEntry imageobject to our index array. If at least one already exists for this index key,  then just append this imageobject to the list. Otherwise create a new array entry for this imageobject. The list contains three elements; a string, a list of Index imageobjects, and a list of IndexEntry imageobjects.) (LET* ((CODE.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) (HASH.VALUE (GETHASH INDEXKEY CODE.ARRAY)) (INDEX.OBJS (CADR HASH.VALUE)) (ENTRY.OBJS (CADDR HASH.VALUE))) (COND ((fetch OBJECTDATUM of OBJ) (SETQ ENTRY.OBJS (APPEND ENTRY.OBJS (LIST OBJ)))) (T (SETQ INDEX.OBJS (APPEND INDEX.OBJS (LIST OBJ))))) (PUTHASH INDEXKEY (LIST '"[Pages (?)]" INDEX.OBJS ENTRY.OBJS) CODE.ARRAY)))) (INDEX.STRING (LAMBDA (OBJ) (* fsg "15-Feb-87 14:40") (* * Returns the display imagestream text for an Index or IndexEntry ImageObject.) (LET ((OBJDATUM (fetch OBJECTDATUM of OBJ)) INDEXNUMBER) (COND (OBJDATUM (CONCAT "[Index Key=" (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY)) ",Entry=" (fetch INDEX.ENTRY of OBJDATUM) (COND ((EQ (SETQ INDEXNUMBER (fetch INDEX.NUMBER of OBJDATUM)) 'YES) ",Number]") ((NUMBERP INDEXNUMBER) (CONCAT ",Number=" INDEXNUMBER "]")) (T "]")))) (T (CONCAT "[Index " (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY)) "]")))))) (INSERT.INDEX (LAMBDA (STREAM WINDOW) (* fsg "15-Jan-87 11:37") (* * Process the "Index" function in the ImageObjects menu.) (LET ((NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM "Index Key: ")))) (TEDIT.PROMPTPRINT STREAM "" T) (AND NEWINDEX.KEY (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY))) (ADD.NEW.INDEX WINDOW NEWINDEX.KEY NEW.INDEX.OBJ) (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM)))))) (INSERT.INDEXENTRY (LAMBDA (STREAM WINDOW) (* fsg "15-Jan-87 11:39") (* * Process the "IndexEntry" function in the ImageObjects menu.) (LET ((NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM "IndexEntry Key: "))) NEWINDEX.ENTRY NEWINDEX.FONT NEWINDEX.NUMBER) (COND (NEWINDEX.KEY (SETQ NEWINDEX.ENTRY (OR (MKATOM (TEDIT.GETINPUT STREAM "IndexEntry Entry: " (MKSTRING NEWINDEX.KEY))) NEWINDEX.KEY)) (TEDIT.PROMPTPRINT STREAM "IndexEntry Entry font..." T) (until (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW GP.DefaultFont)) do (TEDIT.PROMPTPRINT STREAM "Invalid font specification...try again." T)) (TEDIT.PROMPTPRINT STREAM "IndexEntry Number option..." T) (SETQ NEWINDEX.NUMBER (GET.INDEXENTRY.NUMBER WINDOW)) (TEDIT.PROMPTPRINT STREAM "" T) (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY (create INDEX.ENTRY.RECORD INDEX.ENTRY _ NEWINDEX.ENTRY INDEX.ENTRYFONT _ NEWINDEX.FONT INDEX.NUMBER _ NEWINDEX.NUMBER)))) (ADD.NEW.INDEX WINDOW NEWINDEX.KEY NEW.INDEX.OBJ) (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))) (T (TEDIT.PROMPTPRINT STREAM "" T)))))) (GET.INDEXENTRY.NUMBER (LAMBDA (WINDOW DEFAULTNUMBER) (* fsg "15-Jan-87 11:43") (* * Get the NUMBER argument for an IndexEntry ImageObject. The NUMBER can be "YES", "NO", or an integer.) (OR (MENU (create MENU TITLE _ "NUMBER?" CENTERFLG _ T ITEMS _ '(YES NO VALUE) WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM) (COND ((EQ ITEM 'VALUE) (NUMBERPAD.READ (CREATE.NUMBERPAD.READER "NUMBER value?" NIL NIL NIL T))) (T ITEM)))))) DEFAULTNUMBER 'YES))) (INSERT.KNOWN.INDEX (LAMBDA (STREAM WINDOW) (* fsg "18-Feb-87 14:48") (* * Process the "Known Indices" function in the ImageObjects menu. A menu of all the known Indices and  IndexEntries pops up and the user may button one of these to insert the corrsponding Index or IndexEntry. Any buttoning outside of this menu will make it disappear.) (LET* ((PREVINDICES (INDEX.LIST.REFS WINDOW)) (NEWINDEX.KEY (COND (PREVINDICES (LET ((NMENU (create MENU TITLE _ "Index Keys" ITEMS _ PREVINDICES)) MENU.SELECTION) (SETQ MENU.SELECTION (MENU NMENU)) (AND MENU.SELECTION (OR (LISTP MENU.SELECTION) (LIST MENU.SELECTION))))) (T (TEDIT.PROMPTPRINT STREAM "There are no Indicies/IndexEntries in this document." T) NIL)))) (AND NEWINDEX.KEY (LET ((NEWINDEX.OBJ (APPLY 'INDEXOBJ NEWINDEX.KEY))) (ADD.NEW.INDEX WINDOW (CAR NEWINDEX.KEY) NEWINDEX.OBJ) (TEDIT.INSERT.OBJECT NEWINDEX.OBJ STREAM) (TEDIT.PROMPTPRINT STREAM "" T)))))) (INDEX.LIST.REFS (LAMBDA (WINDOW) (* fsg "15-Jan-87 11:46") (* * Return a sorted list of the Index and IndexEntry keys. Simple Index keys are just added to the list. For an IndexEntry key, there are SUBITEMS for each IndexEntry for this key. This list can be used as the ITEMS  field in the Known Indices menu or for creating the index file.) (LET ((INDEX.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) (INDEX.KEYLIST NIL) (INDEX.ITEMS (CONS)) INDEX.VALUE) (MAPHASH INDEX.ARRAY (FUNCTION (LAMBDA (VAL KY) (SETQ INDEX.KEYLIST (CONS KY INDEX.KEYLIST))))) (for KEY in (SORT INDEX.KEYLIST 'UALPHORDER) do (SETQ INDEX.VALUE (GETHASH KEY INDEX.ARRAY)) (AND (CADR INDEX.VALUE) (NCONC INDEX.ITEMS (LIST KEY))) (AND (CADDR INDEX.VALUE) (NCONC INDEX.ITEMS (LIST (LIST KEY NIL "Select an IndexEntry subitem." (CONS 'SUBITEMS (LIST.OF.INDEXENTRIES KEY (CADDR INDEX.VALUE)))))))) (CDR INDEX.ITEMS)))) (LIST.OF.INDEXENTRIES (LAMBDA (KEY OBJLIST) (* fsg "15-Jan-87 11:48") (* * Returns a list of the IndexEntries sorted by Entry) (LET ((ENTRY.LIST (CONS)) OBJDATUM) (for OBJ in OBJLIST do (SETQ OBJDATUM (fetch OBJECTDATUM of OBJ)) (NCONC ENTRY.LIST (LIST (LIST (CONCAT (fetch INDEX.ENTRY of OBJDATUM) ", " (ABBREVIATE.FONT (fetch INDEX.ENTRYFONT of OBJDATUM)) ", " (fetch INDEX.NUMBER of OBJDATUM)) (KWOTE (LIST KEY OBJDATUM)))))) (SORT (INTERSECTION (CDR ENTRY.LIST) (CDR ENTRY.LIST)) (FUNCTION (LAMBDA (A B) (UALPHORDER (CAADR (CADADR A)) (CAADR (CADADR B))))))))) (CREATE.INDEX.FILE (LAMBDA (STREAM WINDOW) (* fsg "15-Dec-86 13:22") (* * Writes the indices and their corresponding page numbers or strings to the index file. The indices are sorted  alphabetically regardless of case.) (LET* ((INDEX.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) (INDEX.LIST (INDEX.LIST.REFS WINDOW)) (INDEX.FILE (GET.INDEX.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW))) (INDEX.STREAM (AND INDEX.FILE (OPENTEXTSTREAM)))) (COND ((AND INDEX.LIST INDEX.FILE) (TEDIT.PROMPTPRINT STREAM (CONCAT "Putting indices in: " INDEX.FILE "...") T) (WRITE.INDEX.FILE INDEX.STREAM INDEX.LIST INDEX.ARRAY) (TEDIT.PROMPTPRINT STREAM "done") (TEDIT.PUT INDEX.STREAM INDEX.FILE) INDEX.FILE) (INDEX.LIST (TEDIT.PROMPTPRINT STREAM "Specify a file name for the indices first." T) NIL) (T (TEDIT.PROMPTPRINT STREAM "There are no indices in this document." T) NIL))))) (VIEW.INDEX.FILE (LAMBDA (STREAM WINDOW) (* fsg "15-Dec-86 15:22") (* * Writes out the index file via CREATE.INDEX.FILE and then opens another TEdit window where this new file is  displayed.) (LET ((INDEX.FILE (CREATE.INDEX.FILE STREAM WINDOW)) (INDEX.FILEW (WINDOWPROP WINDOW 'INDEX.WINDOW))) (AND INDEX.FILE (COND ((WINDOWP INDEX.FILEW) (COND ((OPENWP INDEX.FILEW) (TEDIT.GET (TEXTOBJ INDEX.FILEW) INDEX.FILE)) ((OPENW INDEX.FILEW) (TEDIT INDEX.FILE INDEX.FILEW)))) (T (WINDOWPROP WINDOW 'INDEX.WINDOW (SETQ INDEX.FILEW (CREATEW NIL (CONCAT "Viewing index file: " INDEX.FILE)))) (TEDIT INDEX.FILE INDEX.FILEW))))))) (GET.INDEX.FILE (LAMBDA (MENUW) (* fsg "19-Aug-86 09:09") (* * Return the user specified index file name.) (LET* ((ITEM (FM.ITEMFROMID MENUW 'INDEX.FILE)) (FILENAME (FM.ITEMPROP ITEM 'LABEL))) (COND ((NOT (STREQUAL FILENAME "")) (MKATOM FILENAME)))))) (WRITE.INDEX.FILE (LAMBDA (INDEX.STREAM INDEX.LIST INDEX.ARRAY) (* fsg "28-Jan-87 13:31") (* * Do the output to the index file. For each Index, the Key is printed followed by the list of page numbers in  which this Index Key appears. Each IndexEntry is printed on a separate line and the page number depends on the  IndexEntry Number option. After all indices/indexentries are printed, the array page number list is converted back  to a string. This insures that the next DISPLAYFN call will reconvert the string back to a page number list.) (DSPFONT (FONTCREATE '(HELVETICA 14 BRR)) INDEX.STREAM) (PRINTOUT INDEX.STREAM "Index" T T) (for INDEX.ITEM in INDEX.LIST do (COND ((LISTP INDEX.ITEM) (LET ((PGS.AND.IMOBJS (GETHASH (CAR INDEX.ITEM) INDEX.ARRAY))) (for INDEX.SUBITEM in (CDR (CADDDR INDEX.ITEM)) do (for (INDEX.ENTRYARGS INDEX.FONT) in (CDR (CADADR INDEX.SUBITEM)) do (DSPFONT (SETQ INDEX.FONT (FONTCREATE (CADR INDEX.ENTRYARGS))) INDEX.STREAM) (PRINTOUT INDEX.STREAM (MKSTRING (CAR INDEX.ENTRYARGS))) (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS (CADDR INDEX.ENTRYARGS)) (DSPFONT INDEX.FONT INDEX.STREAM) (PRINTOUT INDEX.STREAM T))))) (T (DSPFONT GP.DefaultFont INDEX.STREAM) (LET ((PGS.AND.IMOBJS (GETHASH INDEX.ITEM INDEX.ARRAY))) (COND ((CAR PGS.AND.IMOBJS) (PRINTOUT INDEX.STREAM (MKSTRING INDEX.ITEM)) (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS NIL) (PRINTOUT INDEX.STREAM T)) (T NIL)))))) (for (INDEX.ITEM PAGES/IMOBJS) in INDEX.LIST do (SETQ PAGES/IMOBJS (GETHASH (COND ((LISTP INDEX.ITEM) (CAR INDEX.ITEM)) (T INDEX.ITEM)) INDEX.ARRAY)) (RPLACA PAGES/IMOBJS (COND ((STRINGP (CAR PAGES/IMOBJS)) (CAR PAGES/IMOBJS)) (T (CONCAT "[Pages " (MKSTRING (CAR PAGES/IMOBJS)) "]"))))))) (WRITE.INDEX.PAGENUMBERS (LAMBDA (STREAM PAGES.AND.IMOBJS NUMBER.OPTION) (* fsg "15-Jan-87 11:53") (* * Here to write the actual page or pages nubers that this Index or IndexEntry appears in. NUMBER.OPTION is the Number field of an IndexEntry.) (DSPFONT GP.DefaultFont STREAM) (LET ((PAGE.NBRS (COND (NUMBER.OPTION (SELECTQ NUMBER.OPTION (NO "") (YES (CAR PAGES.AND.IMOBJS)) (MKSTRING NUMBER.OPTION))) (T (CAR PAGES.AND.IMOBJS)))) (PAGE#.STRING " ")) (COND ((LISTP PAGE.NBRS) (for PAGE in PAGE.NBRS do (SETQ PAGE#.STRING (CONCAT PAGE#.STRING " " (MKSTRING PAGE))) finally (PRINTOUT STREAM PAGE#.STRING))) (T (PRINTOUT STREAM (CONCAT PAGE#.STRING PAGE.NBRS))))))) ) [DECLARE: EVAL@COMPILE (RECORD INDEX.ENTRY.RECORD (INDEX.ENTRY INDEX.ENTRYFONT INDEX.NUMBER)) ] (PUTPROPS INDEX COPYRIGHT ("Leland Stanford Junior University" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (1056 9971 (INDEXOBJ 1068 . 2331) (INDEXOBJP 2335 . 2718) (INDEX.DISPLAYFN 2722 . 4281) (INDEX.IMAGEBOXFN 4285 . 4863) (INDEX.PUTFN 4867 . 5325) (INDEX.GETFN 5329 . 5903) ( INDEX.BUTTONEVENTINFN 5907 . 6972) (CHANGE.INDEX 6976 . 7324) (CHANGE.INDEXENTRY 7328 . 9178) ( INDEX.WHENDELETEDFN 9182 . 9968)) (9973 23270 (ADD.NEW.INDEX 9985 . 10986) (INDEX.STRING 10990 . 11779 ) (INSERT.INDEX 11783 . 12319) (INSERT.INDEXENTRY 12323 . 13738) (GET.INDEXENTRY.NUMBER 13742 . 14360) (INSERT.KNOWN.INDEX 14364 . 15630) (INDEX.LIST.REFS 15634 . 16840) (LIST.OF.INDEXENTRIES 16844 . 17764) (CREATE.INDEX.FILE 17768 . 18867) (VIEW.INDEX.FILE 18871 . 19740) (GET.INDEX.FILE 19744 . 20129 ) (WRITE.INDEX.FILE 20133 . 22381) (WRITE.INDEX.PAGENUMBERS 22385 . 23267))))) STOP \ No newline at end of file diff --git a/lispusers/INSPECTCODE-TEDIT b/lispusers/INSPECTCODE-TEDIT new file mode 100644 index 00000000..46bb0093 --- /dev/null +++ b/lispusers/INSPECTCODE-TEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE (DEFPACKAGE "INSPECTCODE-TEDIT" (§USE "INTERLISP") ( §NICKNAMES "ICT") (§PREFIX-NAME "ICT"))) (FILECREATED " 4-May-87 11:52:50" {DSK}MATT>INSPECTCODE-TEDIT.;10 16087 changes to%: (ADVICE IL:OPENTEXTSTREAM-IN-\TEDIT.INSPECTCODE) (FILEVARS IL:INSPECTCODE-TEDITCOMS) (FNS TITLEMENU-FN OPENTEXTSTREAM-FOR-\TEDIT.INSPECTCODE) previous date%: " 7-Apr-87 16:03:12" IL:{DSK}MATT>INSPECTCODE-TEDIT.;9) (* " Copyright (c) 1985, 1986, 1987 by Beckman Instruments, Inc.. All rights reserved. ") (PRETTYCOMPRINT IL:INSPECTCODE-TEDITCOMS) (RPAQQ IL:INSPECTCODE-TEDITCOMS ((FNS BUILD.TITLEMENU ICON-FN INSP.ERROR KILL.TEDIT.PROCESS NOSELFN OPENTEXTSTREAM-FOR-\TEDIT.INSPECTCODE TITLEMENU-FN) (UGLYVARS ICON.TEMPLATE) (P (CHANGENAME '\TEDIT.INSPECTCODE 'TEXTICON 'ICON-FN) (CHANGENAME '\TEDIT.INSPECTCODE 'OPENTEXTSTREAM ' OPENTEXTSTREAM-FOR-\TEDIT.INSPECTCODE)) (COMMANDS IC) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) INSPECTCODE-TEDIT))) (DEFINEQ (BUILD.TITLEMENU [LAMBDA NIL (* ; "Edited 30-Mar-87 16:32 by Matt Heffron") (DECLARE (GLOBALVARS TITLEMENU)) (SETQ TITLEMENU (create MENU ITEMS _ '((GraphCalls 'GC "Invoke GRAPHCALLS on the current selection") (InspectCode 'IC "INSPECTCODE the current selection") (Inspect 'INSP "INSPECT the current selection" (SUBITEMS (Freely 'INSP "INSPECT the free-reference value of the selection" ) (Globally 'INSP.GLOB "INSPECT the Global (Top Level) value of the selection" ) ("In Process Context" 'INSP.PROC "INSPECT the value of the selection in a process' context" ))) ("Pretty Print Value" 'PPV "Pretty Print the value of the current selection" (SUBITEMS (Freely 'PPV "Pretty Print the free-reference value of the selection" ) (Globally 'PPV.GLOB "Pretty Print the Global (Top Level) value of the selection" ) ("In Process Context" 'PPV.PROC "Pretty Print the value of the selection in a process' context" ))) (Quit 'QUIT "Terminates this INSPECTCODE"]) (ICON-FN [LAMBDA (W) (* ; "Edited 30-Mar-87 15:59 by Matt Heffron") (DECLARE (GLOBALVARS ICON.TEMPLATE)) (LET ((ICON (TITLEDICONW ICON.TEMPLATE (WINDOWPROP W 'FNNAME) (FONTCREATE 'HELVETICA 8 'MRR NIL NIL T) NIL T))) (WINDOWPROP W 'ICON ICON) (WINDOWPROP W 'ICONWINDOW ICON) (WINDOWPROP W 'ICONFN NIL) ICON]) (INSP.ERROR [LAMBDA (MESS1 MESS2 MESS3) (* ; "Edited 30-Mar-87 16:00 by Matt Heffron") (CLRPROMPT) (if (NOT MESS2) then (PROMPTPRINT MESS1) elseif (NOT MESS3) then (PROMPTPRINT MESS1 MESS2) else (PROMPTPRINT MESS1 MESS2 MESS3)) (RINGBELLS]) (KILL.TEDIT.PROCESS [LAMBDA (W) (* ; "Edited 30-Mar-87 16:00 by Matt Heffron") (DEL.PROCESS (WINDOWPROP W 'PROCESS]) (NOSELFN [LAMBDA NIL (* ; "Edited 30-Mar-87 16:01 by Matt Heffron") (CLRPROMPT) (PROMPTPRINT "No current selection") (RINGBELLS]) (OPENTEXTSTREAM-FOR-\TEDIT.INSPECTCODE [LAMBDA (TEXT WINDOW START END PROPS) (* ; "Edited 4-May-87 11:47 by ") (PROG1 [OPENTEXTSTREAM TEXT WINDOW START END (APPEND PROPS '(QUITFN T TITLEMENUFN TITLEMENU-FN NOTITLE T] (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION KILL.TEDIT.PROCESS)) (WINDOWPROP WINDOW 'FNNAME FN) (WINDOWPROP WINDOW '*PACKAGE* *PACKAGE*) (WINDOWPROP WINDOW '*READTABLE* *READTABLE*]) (TITLEMENU-FN [LAMBDA (W) (* ; "Edited 4-May-87 11:32 by ") (* ; "Edited 4-May-87 11:25 by ") (* ; "Edited 4-May-87 11:19 by ") (DECLARE (GLOBALVARS TITLEMENU)) (if (OR (NOT (BOUNDP 'TITLEMENU)) (NOT (type? MENU TITLEMENU))) then (BUILD.TITLEMENU)) [LET* ((STREAM (TEXTSTREAM W)) (W*PACKAGE* (WINDOWPROP W '*PACKAGE*)) (W*READTABLE* (WINDOWPROP W '*READTABLE*)) (SELLEN (fetch (SELECTION DCH) of (TEDIT.GETSEL STREAM))) (MENUCHOICE (MENU TITLEMENU)) (SpecifyRegionString "Specify a region for the value pretty print window") INSPVAL SELSTR DISPLAYWINDOW) (if (NOT MENUCHOICE) then (* ;  "Nothing to do, clicked out of menu") elseif (EQ MENUCHOICE 'QUIT) then (TEDIT.QUIT STREAM) (if (OPENWP W) then (CLOSEW W)) else [if (EQ SELLEN 0) then (NOSELFN) elseif (GREATERP SELLEN 255) then (INSP.ERROR "Selection is too long (> 255 characters)") (TEDIT.SHOWSEL STREAM NIL NIL) (TEDIT.SETSEL STREAM 0 0 'LEFT) else (SETQ SELSTR (LET [(*PACKAGE* W*PACKAGE*) (*READTABLE* W*READTABLE*) (STRM (OPENSTRINGSTREAM (TEDIT.SEL.AS.STRING STREAM NIL) 'INPUT] (READ STRM] (SELECTQ MENUCHOICE (IC (LET ((*PACKAGE* W*PACKAGE*) (*READTABLE* W*READTABLE*)) (INSPECTCODE SELSTR))) (GC (if (FGETD 'GRAPHCALLSW) then (if (NOT (LET ((*PACKAGE* W*PACKAGE*) (*READTABLE* W*READTABLE*)) (GRAPHCALLS SELSTR))) then (INSP.ERROR "Nothing to graph!!")) else (INSP.ERROR "The GRAPHCALLS package is not loaded. Cannot graph " SELSTR) )) ((INSP PPV) (if (BOUNDP SELSTR) then (if (EQ MENUCHOICE 'PPV) then (PROMPTPRINT SpecifyRegionString) (SETQ DISPLAYWINDOW (CREATEW (GETREGION (WIDTHIFWINDOW 72) (HEIGHTIFWINDOW 72 T)) SELSTR)) (CLRPROMPT) (printout DISPLAYWINDOW .PPV (EVAL SELSTR)) else (INSPECT (EVALV SELSTR))) else (INSP.ERROR SELSTR " has no value to " (if (EQ MENUCHOICE 'PPV) then "print" else "inspect")))) ((INSP.GLOB PPV.GLOB) (if (NEQ (SETQ INSPVAL (GETTOPVAL SELSTR)) 'NOBIND) then (if (EQ MENUCHOICE 'PPV.GLOB) then (PROMPTPRINT SpecifyRegionString) (SETQ DISPLAYWINDOW (CREATEW (GETREGION (WIDTHIFWINDOW 72) (HEIGHTIFWINDOW 72 T)) SELSTR)) (CLRPROMPT) (printout DISPLAYWINDOW .PPV INSPVAL) else (INSPECT INSPVAL)) else (INSP.ERROR SELSTR " has no Global value to " (if (EQ MENUCHOICE 'PPV.GLOB) then "print" else "inspect")))) ((INSP.PROC PPV.PROC) (LET (PROCESSLIST PROC) (DECLARE (SPECVARS PROCESSLIST)) [MAP.PROCESSES (FUNCTION (LAMBDA (PHANDLE PNAME PFORM) (DECLARE (SPECVARS PROCESSLIST)) (push PROCESSLIST (LIST PNAME PHANDLE] (SETQ PROC (MENU (create MENU ITEMS _ PROCESSLIST CENTERFLG _ T))) (if PROC then [if (NEQ (SETQ INSPVAL (PROCESS.EVALV PROC SELSTR)) 'NOBIND) then (if (EQ MENUCHOICE 'PPV.PROC) then (PROMPTPRINT SpecifyRegionString) (SETQ DISPLAYWINDOW (CREATEW (GETREGION (WIDTHIFWINDOW 72) (HEIGHTIFWINDOW 72 T)) SELSTR)) (CLRPROMPT) (printout DISPLAYWINDOW .PPV INSPVAL) else (INSPECT INSPVAL)) else (INSP.ERROR SELSTR (if (EQ MENUCHOICE 'PPV.PROC) then " has no value to print in process " else " has no value to inspect in process " ) (PROCESSPROP PROC 'NAME] else (INSP.ERROR "No process selected. Will not " (if (EQ MENUCHOICE 'PPV.PROC) then "print " else "inspect ") SELSTR)))) (PROGN (* ; "Shouldn't happen, but ignore it.") ] NIL]) ) (READVAR-FROM-STRING 'ICON.TEMPLATE "({(READBITMAP)(87 91 %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@COO@@@@@F@@%" %"L@@@@@@@@@@@AOOON@@@@F@@%" %"L@@@@@@@@@@@GN@AOH@@@F@@%" %"L@@@@@@@@@@AO@@@CN@@@F@@%" %"L@@@@@@@@@@CL@@@@O@@@F@@%" %"L@@@@@@@@@@O@@@@@CL@@F@@%" %"L@@@@@@@@@AN@@@@@AN@@F@@%" %"L@@@@@@@@@CH@@@@@@G@@F@@%" %"L@@@@@@@@@C@@@@@@@C@@F@@%" %"L@@@@@@@@@G@@@@@@@CH@F@@%" %"L@@@@@@@@@N@@@@@@@AL@F@@%" %"L@@@@@@@@@L@@@@@@@@L@F@@%" %"L@@@@@@@@AL@@@@@@@@N@F@@%" %"L@@@@@@@@AH@@@@@@@@F@F@@%" %"L@@@@@@@@CH@@@@@@@@G@F@@%" %"L@@@@@@@@C@@@@@@@@@C@F@@%" %"L@@@@@@@@C@@@@@@@@@C@F@@%" %"L@@@@@@@@GGL@OHGO@OOHF@@%" %"L@@@@@@@@GLFCHNFALLAHF@@%" %"L@@@@@@@@GHCC@FF@LLAHF@@%" %"L@@@@@@@@G@@F@CF@FLAHF@@%" %"LBIGKMLNOO@@F@CF@FOOHF@@%" %"LBMDBEA@BG@@F@CF@FLAHF@@%" %"LBOGKMM@BG@@F@CF@FLAHF@@%" %"LBK@JAA@BGHCC@FF@LLAHF@@%" %"LBIGJALNBGLFCHNFALLAHF@@%" %"L@@@@@@@@GGL@OHGO@OOHF@@%" %"L@@@@@@@@C@@@@@@@@@C@F@@%" %"L@@@@@@@@C@@@@@@@@@C@F@@%" %"L@@@@@@@@CH@@@@@@@@G@F@@%" %"L@@@@@@@@AH@@@@@@@@F@F@@%" %"L@@@@@@@@AL@@@@@@@@N@F@@%" %"L@@@@@@@@@L@@@@@@@@L@F@@%" %"L@@@@@@@@@N@@@@@@@AL@F@@%" %"L@@@@@@@@@G@@@@@@@CH@F@@%" %"L@@@@@@@@@G@@@@@@@C@@F@@%" %"L@@@@@@@@@OL@@@@@@G@@F@@%" %"L@@@@@@@@@ON@@@@@AN@@F@@%" %"L@@@@@@@@AGO@@@@@CL@@F@@%" %"L@@@@@@@@CKCL@@@@O@@@F@@%" %"L@@@@@@@@GLAO@@@CN@@@F@@%" %"L@@@@@@@@OH@GN@AOH@@@F@@%" %"L@@@@@@@AO@@AOOON@@@@F@@%" %"L@@@@@@@FN@@@COO@@@@@F@@%" %"L@@@@@@@OD@@@@@@@@@@@F@@%" %"L@@@@@@AOH@@@@@@@@@@@F@@%" %"L@@@@@@COH@@@@@@@@@@@F@@%" %"L@@@@@@GO@@@@@@@@@@@@F@@%" %"L@@@@@@ON@@@@@@@@@@@@F@@%" %"L@@@@@AOL@@@@@@@@@@@@F@@%" %"L@@@@@COH@@@@@@@@@@@@F@@%" %"L@@@@@GO@@@@@@@@@@@@@F@@%" %"L@@@@@ON@@@@@@@@@@@@@F@@%" %"L@@@@AOL@@@@@@@@@@@@@F@@%" %"L@@@@COH@@@@@@@@@@@@@F@@%" %"L@@@@GO@@@@@@@@@@@@@@F@@%" %"L@@@@ON@@@@@@@@@@@@@@F@@%" %"L@@@AOL@@@@@@@@@@@@@@F@@%" %"L@@@COH@@@@@@@@@@@@@@F@@%" %"L@@@GO@@@@@@@@@@@@@@@F@@%" %"L@@@GN@@@@@@@@@@@@@@@F@@%" %"L@@@CL@@@@@@@@@@@@@@@F@@%" %"L@@@AH@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"L@@@@@@@@@@@@@@@@@@@@F@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%")} NIL (4 5 79 18)) ") (CHANGENAME '\TEDIT.INSPECTCODE 'TEXTICON 'ICON-FN) (CHANGENAME '\TEDIT.INSPECTCODE 'OPENTEXTSTREAM 'OPENTEXTSTREAM-FOR-\TEDIT.INSPECTCODE) (DEFCOMMAND IC (FN) (INSPECTCODE FN)) (PUTPROPS INSPECTCODE-TEDIT FILETYPE :TCOMPL) (PUTPROPS INSPECTCODE-TEDIT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (DEFPACKAGE "INSPECTCODE-TEDIT" (:USE "INTERLISP") (:NICKNAMES "ICT") (:PREFIX-NAME "ICT")))) (PUTPROPS INSPECTCODE-TEDIT COPYRIGHT ("Beckman Instruments, Inc." 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1353 12345 (BUILD.TITLEMENU 1363 . 3517) (ICON-FN 3519 . 3975) (INSP.ERROR 3977 . 4315) (KILL.TEDIT.PROCESS 4317 . 4491) (NOSELFN 4493 . 4688) (OPENTEXTSTREAM-FOR-\TEDIT.INSPECTCODE 4690 . 5238) (TITLEMENU-FN 5240 . 12343))))) STOP \ No newline at end of file diff --git a/lispusers/INSPECTCODE-TEDIT.TEDIT b/lispusers/INSPECTCODE-TEDIT.TEDIT new file mode 100644 index 00000000..3e4bac2b Binary files /dev/null and b/lispusers/INSPECTCODE-TEDIT.TEDIT differ diff --git a/lispusers/IPTALK b/lispusers/IPTALK new file mode 100644 index 00000000..4c7302cf --- /dev/null +++ b/lispusers/IPTALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Jul-88 14:16:28" |{MCS:MCS:STANFORD}IPTALK.;1| 12755 ) (PRETTYCOMPRINT IPTALKCOMS) (RPAQQ IPTALKCOMS ((* TALK (Interim) IP Interface) (LOCALVARS . T) (FNS TALK.IP.SERVER) (FNS TALK.IP.USERNAME TALK.IP.CONNECT TALK.IP.EVENT TALK.START.IP.SERVER) (INITVARS (TALK.UDP.PORT 517)) (GLOBALVARS TALK.UDP.PORT TALK.IP.CONSTANTS) (DECLARE%: DONTCOPY (RECORDS TALK.IP.PACKET) (CONSTANTS * TALK.IP.CONSTANTS)) (* etc) (FILES TALK TCP TCPUDP) (APPENDVARS (TALK.PROTOCOLTYPES (IP DODIP.HOSTP TALK.IP.USERNAME TALK.IP.CONNECT TALK.IP.EVENT TALK.START.IP.SERVER))) (DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILES ETHERRECORDS TCPEXPORTS) ) (P (TALK.START.IP.SERVER)))) (* TALK (Interim) IP Interface) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (TALK.IP.SERVER [LAMBDA NIL (* ; "Edited 17-Jun-88 13:45 by cdl") (DECLARE (GLOBALVARS \IP.READY)) (LET (SOCKET) (DECLARE (SPECVARS SOCKET)) (RESETLST [RESETSAVE NIL `(UDP.CLOSE.SOCKET ,(SETQ SOCKET (UDP.OPEN.SOCKET TALK.UDP.PORT] [bind PACKET RESPONSE SERVICE GAP.SERVICETYPE TALK.SERVICETYPE INPUTSTREAM OUTPUTSTREAM PORT USER while \IP.READY do (SETQ PACKET (UDP.GET SOCKET T)) (UDP.SETUP (SETQ RESPONSE (\ALLOCATE.ETHERPACKET)) (with IP PACKET IPSOURCEADDRESS) (with UDP PACKET UDPSOURCEPORT) 0 SOCKET 'FREE) (UDP.APPEND.BYTE RESPONSE (with TALK.IP.PACKET PACKET TALK.SERVICE.BYTE)) (if [OR [NULL (if (SETQ GAP.SERVICETYPE (ASSOC (with TALK.IP.PACKET PACKET TALK.SERVICE.BYTE ) GAP.SERVICETYPES)) then (SETQ SERVICE (with GAP.SERVICETYPE GAP.SERVICETYPE GAP.SERVICENAME] (NULL (SETQ TALK.SERVICETYPE (ASSOC SERVICE TALK.SERVICETYPES] then (UDP.APPEND.BYTE RESPONSE \IPTALK.NOSERVICE) (UDP.SEND SOCKET RESPONSE) elseif [OR TALK.GAG (NOT (TALK.ANSWER (SETQ USER (with TALK.IP.PACKET PACKET TALK.IP.USERNAME) ) SERVICE 'IP (with IP PACKET IPSOURCEADDRESS] then (UDP.APPEND.BYTE RESPONSE \IPTALK.NOANSWER) (UDP.SEND SOCKET RESPONSE) else (UDP.APPEND.BYTE RESPONSE \IPTALK.SUCCESS) (UDP.APPEND.WORD RESPONSE (SETQ PORT (\TCP.SELECT.PORT))) (UDP.SEND SOCKET RESPONSE) (if (SETQ INPUTSTREAM (TCP.OPEN (with IP PACKET IPSOURCEADDRESS ) NIL PORT 'PASSIVE 'INPUT)) then (TALK.PROCESS INPUTSTREAM (TCP.OTHER.STREAM INPUTSTREAM) TALK.SERVICETYPE 'IP 'SERVER USER T])]) ) (DEFINEQ (TALK.IP.USERNAME [LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE MODE USER) (* ; "Edited 8-Jun-88 15:45 by cdl") (SELECTQ (with TALK.SERVICETYPE SERVICETYPE TALK.SERVICENAME) ((TTY Sketch) (* For (backward) compatibility) USER) (LET ((NAME (USERNAME))) (PRINTOUT OUTPUTSTREAM (if (NOT (STREQUAL NAME (CONSTANT null))) then NAME) T) (FORCEOUTPUT OUTPUTSTREAM) (SETQ NAME (RATOM INPUTSTREAM TALK.READTABLE)) (* Eat EOL) (BIN INPUTSTREAM) (OR NAME USER]) (TALK.IP.CONNECT [LAMBDA (HOST SERVICETYPES) (* ; "Edited 13-Jun-88 17:54 by cdl") (DECLARE (SPECVARS HOST SERVICETYPES)) (LET (SOCKET) (DECLARE (SPECVARS SOCKET)) (RESETLST [RESETSAVE NIL `(UDP.CLOSE.SOCKET ,(SETQ SOCKET (UDP.OPEN.SOCKET] [PROG (NAME REQUEST RESPONSE INPUTSTREAM RESULT) (while (STREQUAL (SETQ NAME (USERNAME)) (CONSTANT null)) do (LOGIN)) (if [LITATOM (SETQ RESULT (for SERVICETYPE in SERVICETYPES thereis (PROGN (UDP.SETUP (SETQ REQUEST (\ALLOCATE.ETHERPACKET)) HOST TALK.UDP.PORT 0 SOCKET 'FREE) (UDP.APPEND.BYTE REQUEST (with GAP.SERVICETYPE [for GAP.SERVICETYPE in GAP.SERVICETYPES thereis (with GAP.SERVICETYPE GAP.SERVICETYPE (with TALK.SERVICETYPE SERVICETYPE (EQ GAP.SERVICENAME TALK.SERVICENAME] GAP.UNSPECIFIED)) (UDP.APPEND.BYTE REQUEST 0) (UDP.APPEND.WORD REQUEST 0) (UDP.APPEND.WORD REQUEST (NCHARS NAME)) (UDP.APPEND.STRING REQUEST NAME) (if [SETQ RESPONSE (UDP.EXCHANGE SOCKET REQUEST (TIMES TALK.ANSWER.WAIT (CONSTANT (PROGN (* Convert to milliseconds and  double in case they are idle) (TIMES 2 1000] then (SELECT (with TALK.IP.PACKET RESPONSE TALK.STATUS) (\IPTALK.SUCCESS T) (\IPTALK.NOSERVICE NIL) (\IPTALK.NOANSWER (RETURN 'ANSWER)) (RETURN 'CONNECT)) else (* Can't connect) (RETURN 'CONNECT] then (RETURN RESULT) else (if (STREAMP (SETQ INPUTSTREAM (TCP.OPEN HOST (with TALK.IP.PACKET RESPONSE TALK.TEDIT.PORT) NIL 'ACTIVE 'INPUT T))) then [RETURN (CONS RESULT (CONS INPUTSTREAM (TCP.OTHER.STREAM INPUTSTREAM] else (RETURN 'CONNECT])]) (TALK.IP.EVENT [LAMBDA (INPUTSTREAM OUTPUTSTREAM) (* cdl "18-May-87 16:29") (while (AND (OPENP INPUTSTREAM) (OPENP OUTPUTSTREAM) (NOT (READP INPUTSTREAM))) do (if (EOFP INPUTSTREAM) then (CLOSEF? INPUTSTREAM)) (BLOCK]) (TALK.START.IP.SERVER [LAMBDA (RESTART) (* ; "Edited 17-Jun-88 12:20 by cdl") [LET [(DEVICE (\GETDEVICEFROMNAME 'TCP 'NOERROR 'DONTCREATE] (if DEVICE then (* (Temporary) patch to make TCP  streams handle NS character codes) (with FDEV DEVICE (if (NULL READCHARCODE) then (SETQ READCHARCODE (FUNCTION \GENERIC.READCCODE ] (bind PROCESS while (AND (SETQ PROCESS (FIND.PROCESS 'TALK.IP.SERVER)) RESTART) do (DEL.PROCESS PROCESS) (BLOCK) yield (if PROCESS then PROCESS elseif \IP.READY then (ADD.PROCESS '(TALK.IP.SERVER) 'RESTARTABLE 'SYSTEM]) ) (RPAQ? TALK.UDP.PORT 517) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.UDP.PORT TALK.IP.CONSTANTS) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS TALK.IP.PACKET [(TALK.PACKET.BASE (with UDP DATUM UDPCONTENTS)) (TALK.IP.USERNAME (\GETBASESTRING (with UDP DATUM UDPCONTENTS) 6 (with TALK.IP.PACKET DATUM TALK.USERNAME.LENGTH] (BLOCKRECORD TALK.PACKET.BASE ((TALK.SERVICE.BYTE BYTE) (TALK.STATUS BYTE) (TALK.TEDIT.PORT WORD) (TALK.USERNAME.LENGTH WORD)))) ) (RPAQQ TALK.IP.CONSTANTS ((\IPTALK.SUCCESS 0) (\IPTALK.NOSERVICE 1) (\IPTALK.NOANSWER 2))) (DECLARE%: EVAL@COMPILE (RPAQQ \IPTALK.SUCCESS 0) (RPAQQ \IPTALK.NOSERVICE 1) (RPAQQ \IPTALK.NOANSWER 2) (CONSTANTS (\IPTALK.SUCCESS 0) (\IPTALK.NOSERVICE 1) (\IPTALK.NOANSWER 2)) ) ) (* etc) (FILESLOAD TALK TCP TCPUDP) (APPENDTOVAR TALK.PROTOCOLTYPES (IP DODIP.HOSTP TALK.IP.USERNAME TALK.IP.CONNECT TALK.IP.EVENT TALK.START.IP.SERVER)) (DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILESLOAD ETHERRECORDS TCPEXPORTS) ) (TALK.START.IP.SERVER) (DECLARE%: DONTCOPY (FILEMAP (NIL (1313 4720 (TALK.IP.SERVER 1323 . 4718)) (4721 11119 (TALK.IP.USERNAME 4731 . 5475) ( TALK.IP.CONNECT 5477 . 9538) (TALK.IP.EVENT 9540 . 9963) (TALK.START.IP.SERVER 9965 . 11117))))) STOP \ No newline at end of file diff --git a/lispusers/IRIS.TEdit b/lispusers/IRIS.TEdit new file mode 100644 index 00000000..69ac05ec Binary files /dev/null and b/lispusers/IRIS.TEdit differ diff --git a/lispusers/IRISCONSTANTS b/lispusers/IRISCONSTANTS new file mode 100644 index 00000000..fdead42d --- /dev/null +++ b/lispusers/IRISCONSTANTS @@ -0,0 +1 @@ +(FILECREATED "24-Oct-85 18:17:51" {ERIS}KOTO>IRISCONSTANTS.;2 48027 changes to: (VARS IRISCONSTANTSCOMS) previous date: " 5-Sep-85 23:28:08" {ERIS}KOTO>IRISCONSTANTS.;1) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT IRISCONSTANTSCOMS) (RPAQQ IRISCONSTANTSCOMS [(COMS (* * gl.h) (* Maximum X and Y screen coordinates) (CONSTANTS (IRIS.XMAXSCREEN 1023) (IRIS.YMAXSCREEN 767)) (* Various hardware/software limits) (CONSTANTS (IRIS.ATTRIBSTACKDEPTH 10) (IRIS.VPSTACKDEPTH 8) (IRIS.MATRIXSTACKDEPTH 32) (IRIS.STARTTAG -2) (IRIS.ENDTAG -3)) (* Name for colors in color map loaded by IRIS.GINIT) (CONSTANTS (IRIS.BACKGROUND 0) (IRIS.BLACK 0) (IRIS.RED 1) (IRIS.GREEN 2) (IRIS.YELLOW 3) (IRIS.BLUE 4) (IRIS.MAGENTA 5) (IRIS.CYAN 6) (IRIS.WHITE 7))) (COMS (* * device.h) (* Macros to test valuator and button numbers) (MACROS IRIS.ISBUTTON IRIS.ISSCRBUTTON IRIS.ISVALUATOR IRIS.ISTIMER IRIS.ISDIAL IRIS.ISLPEN IRIS.ISLPENBUT) (* Include file with device definitions) (CONSTANTS (IRIS.NULLDEV 0) (IRIS.BUTOFFSET 1) (IRIS.SBTOFFSET 200) (IRIS.VALOFFSET 256) (IRIS.KEYOFFSET 512) (IRIS.TIMOFFSET 515) (IRIS.BUTCOUNT 144) (IRIS.SBTCOUNT 16) (IRIS.VALCOUNT 14) (IRIS.TIMCOUNT 8)) (* Buttons) (CONSTANTS (IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET)) (IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET)) (IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET)) (IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET)) (IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET)) (IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET)) (IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET)) (IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET)) (IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET)) (IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET)) (IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET)) (IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET)) (IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET)) (IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET)) (IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET)) (IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET)) (IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET)) (IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET)) (IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET)) (IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET)) (IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET)) (IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET)) (IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET)) (IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET)) (IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET)) (IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET)) (IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET)) (IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET)) (IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET)) (IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET)) (IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET)) (IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET)) (IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET)) (IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET)) (IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET)) (IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET)) (IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET)) (IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET)) (IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET)) (IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET)) (IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET)) (IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET)) (IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET)) (IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET)) (IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET)) (IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET)) (IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET)) (IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET)) (IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET)) (IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET)) (IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET)) (IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET)) (IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET)) (IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET)) (IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET)) (IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET)) (IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET)) (IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET)) (IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET)) (IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET)) (IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET)) (IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET)) (IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET)) (IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET)) (IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET)) (IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET)) (IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET)) (IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET)) (IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET)) (IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET)) (IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET)) (IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET)) (IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET)) (IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET)) (IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET)) (IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET)) (IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET)) (IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET)) (IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET)) (IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET)) (IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET)) (IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET)) (IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET)) (IRIS.MAXKBDBUT IRIS.BUT82) (IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET)) (IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET)) (IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET)) (IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET)) (IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET)) (IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET)) (IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET)) (IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET)) (IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET)) (IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET)) (IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET)) (IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET)) (IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET)) (IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET)) (IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET)) (IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET)) (IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET)) (IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET)) (IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET)) (IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET)) (IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET)) (IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET)) (IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET)) (IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET)) (IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET)) (IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET)) (IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET)) (IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET)) (IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET)) (IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET)) (IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET)) (IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET)) (IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET)) (IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET)) (IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET)) (IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET)) (IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET)) (IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET)) (IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET)) (IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET)) (IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET)) (IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET)) (IRIS.MOUSEBUTTON1 IRIS.BUT100) (IRIS.MOUSEBUTTON2 IRIS.BUT101) (IRIS.MOUSEBUTTON3 IRIS.BUT102) (IRIS.MOUSE1 IRIS.BUT100) (IRIS.MOUSE2 IRIS.BUT101) (IRIS.MOUSE3 IRIS.BUT102) (IRIS.LEFTMOUSEBUTTON IRIS.BUT102) (IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101) (IRIS.RIGHTMOUSEBUTTON IRIS.BUT100) (IRIS.LEFTMOUSE IRIS.BUT102) (IRIS.MIDDLEMOUSE IRIS.BUT101) (IRIS.RIGHTMOUSE IRIS.BUT100) (IRIS.LPENBUT 104)) (* Switches) (CONSTANTS (IRIS.SWBASE IRIS.BUT110) (IRIS.SW0 (IPLUS IRIS.SWBASE 0)) (IRIS.SW1 (IPLUS IRIS.SWBASE 1)) (IRIS.SW2 (IPLUS IRIS.SWBASE 2)) (IRIS.SW3 (IPLUS IRIS.SWBASE 3)) (IRIS.SW4 (IPLUS IRIS.SWBASE 4)) (IRIS.SW5 (IPLUS IRIS.SWBASE 5)) (IRIS.SW6 (IPLUS IRIS.SWBASE 6)) (IRIS.SW7 (IPLUS IRIS.SWBASE 7)) (IRIS.SW8 (IPLUS IRIS.SWBASE 8)) (IRIS.SW9 (IPLUS IRIS.SWBASE 9)) (IRIS.SW10 (IPLUS IRIS.SWBASE 10)) (IRIS.SW11 (IPLUS IRIS.SWBASE 11)) (IRIS.SW12 (IPLUS IRIS.SWBASE 12)) (IRIS.SW13 (IPLUS IRIS.SWBASE 13)) (IRIS.SW14 (IPLUS IRIS.SWBASE 14)) (IRIS.SW15 (IPLUS IRIS.SWBASE 15)) (IRIS.SW16 (IPLUS IRIS.SWBASE 16)) (IRIS.SW17 (IPLUS IRIS.SWBASE 17)) (IRIS.SW18 (IPLUS IRIS.SWBASE 18)) (IRIS.SW19 (IPLUS IRIS.SWBASE 19)) (IRIS.SW20 (IPLUS IRIS.SWBASE 20)) (IRIS.SW21 (IPLUS IRIS.SWBASE 21)) (IRIS.SW22 (IPLUS IRIS.SWBASE 22)) (IRIS.SW23 (IPLUS IRIS.SWBASE 23)) (IRIS.SW24 (IPLUS IRIS.SWBASE 24)) (IRIS.SW25 (IPLUS IRIS.SWBASE 25)) (IRIS.SW26 (IPLUS IRIS.SWBASE 26)) (IRIS.SW27 (IPLUS IRIS.SWBASE 27)) (IRIS.SW28 (IPLUS IRIS.SWBASE 28)) (IRIS.SW29 (IPLUS IRIS.SWBASE 29)) (IRIS.SW30 (IPLUS IRIS.SWBASE 30)) (IRIS.SW31 (IPLUS IRIS.SWBASE 31))) (* Keys) (CONSTANTS (IRIS.AKEY IRIS.BUT10) (IRIS.BKEY IRIS.BUT35) (IRIS.CKEY IRIS.BUT27) (IRIS.DKEY IRIS.BUT17) (IRIS.EKEY IRIS.BUT16) (IRIS.FKEY IRIS.BUT18) (IRIS.GKEY IRIS.BUT25) (IRIS.HKEY IRIS.BUT26) (IRIS.IKEY IRIS.BUT39) (IRIS.JKEY IRIS.BUT33) (IRIS.KKEY IRIS.BUT34) (IRIS.LKEY IRIS.BUT41) (IRIS.MKEY IRIS.BUT43) (IRIS.NKEY IRIS.BUT36) (IRIS.OKEY IRIS.BUT40) (IRIS.PKEY IRIS.BUT47) (IRIS.QKEY IRIS.BUT9) (IRIS.RKEY IRIS.BUT23) (IRIS.SKEY IRIS.BUT11) (IRIS.TKEY IRIS.BUT24) (IRIS.UKEY IRIS.BUT32) (IRIS.VKEY IRIS.BUT28) (IRIS.WKEY IRIS.BUT15) (IRIS.XKEY IRIS.BUT20) (IRIS.YKEY IRIS.BUT32) (IRIS.ZKEY IRIS.BUT19) (IRIS.ZEROKEY IRIS.BUT45) (IRIS.ONEKEY IRIS.BUT7) (IRIS.TWOKEY IRIS.BUT13) (IRIS.THREEKEY IRIS.BUT14) (IRIS.FOURKEY IRIS.BUT21) (IRIS.FIVCEKEY IRIS.BUT22) (IRIS.SIXKEY IRIS.BUT29) (IRIS.SEVENKEY IRIS.BUT30) (IRIS.EIGHTKEY IRIS.BUT37) (IRIS.NINIKEY IRIS.BUT38) (IRIS.BREAKKEY IRIS.BUT0) (IRIS.SETUPKEY IRIS.BUT1) (IRIS.CNTRLKEY IRIS.BUT2) (IRIS.CAPSLOCKKEY IRIS.BUT3) (IRIS.RIGHTSHIFTKEY IRIS.BUT4) (IRIS.LEFTSHIFTKEY IRIS.BUT5) (IRIS.NOSCRLKEY IRIS.BUT12) (IRIS.ESCKEY IRIS.BUT6) (IRIS.TABKEY IRIS.BUT8) (IRIS.RETURNKEY IRIS.BUT50) (IRIS.SPACEKKEY IRIS.BUT82) (IRIS.LINEFEEDKEY IRIS.BUT59) (IRIS.BACKSPACEKEY IRIS.BUT60) (IRIS.DELETEKEY IRIS.BUT61) (IRIS.SEMICOLONKEY IRIS.BUT42) (IRIS.PERIODKEY IRIS.BUT51) (IRIS.COMMAKEY IRIS.BUT44) (IRIS.QUOTEKEY IRIS.BUT49) (IRIS.ACCENTGRAVEKEY IRIS.BUT54) (IRIS.MINUSKEY IRIS.BUT46) (IRIS.VIRGULEKEY IRIS.BUT52) (IRIS.BACKSLASHKEY IRIS.BUT56) (IRIS.EQUALKEY IRIS.BUT53) (IRIS.LEFTBRACKETKEY IRIS.BUT48) (IRIS.RIGHTBRACKETKEY IRIS.BUT55) (IRIS.LEFTARROWKEY IRIS.BUT72) (IRIS.DOWNARROWKEY IRIS.BUT73) (IRIS.UPARROWKEY IRIS.BUT80) (IRIS.PAD0 IRIS.BUT58) (IRIS.PAD1 IRIS.BUT57) (IRIS.PAD2 IRIS.BUT63) (IRIS.PAD3 IRIS.BUT64) (IRIS.PAD4 IRIS.BUT62) (IRIS.PAD5 IRIS.BUT68) (IRIS.PAD6 IRIS.BUT69) (IRIS.PAD8 IRIS.BUT67) (IRIS.PAD9 IRIS.BUT74) (IRIS.PADPF1 IRIS.BUT71) (IRIS.PADPF2 IRIS.BUT70) (IRIS.PADPF3 IRIS.BUT78) (IRIS.PADPF4 IRIS.BUT77) (IRIS.PADPERIOD IRIS.BUT65) (IRIS.PADMINUS IRIS.BUT75) (IRIS.PADCOMMA IRIS.BUT76) (IRIS.PADENTER IRIS.BUT81)) (* Screen buttons) (CONSTANTS (IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0)) (IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1)) (IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2)) (IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3)) (IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4)) (IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5)) (IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6)) (IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7)) (IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8)) (IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9)) (IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10)) (IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11)) (IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12)) (IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13)) (IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14)) (IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15)) (IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16))) (* Valuators) (CONSTANTS (IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET)) (IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET)) (IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET)) (IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET)) (IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET)) (IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET)) (IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET)) (IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET)) (IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET)) (IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET)) (IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET)) (IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET)) (IRIS.LPENX (PLUS 12 IRIS.VALOFFSET)) (IRIS.PLENY (PLUS 13 IRIS.VALOFFSET)) (IRIS.NULLX (PLUS 14 IRIS.VALOFFSET)) (IRIS.NULLY (PLUS 15 IRIS.VALOFFSET))) (* Timers) (CONSTANTS (IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0)) (IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1)) (IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2)) (IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3)) (IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4)) (IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5)) (IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6)) (IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7))) (* Misc devices) (CONSTANTS (IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET)) (IRIS.CURSORX 526) (* cursor x pseudo valuator) (IRIS.CURSORY 527) (* cursor y pseudo valuator) (IRIS.VALMARK 523) (* valuator mark) (IRIS.GERROR 524) (* errors device) (IRIS.REDRAW 528) (* used by port manager to signal redraws) (IRIS.WMSEND 529) (* data in proc's shmem) (IRIS.WMREPLY 530) (* reply from port manager) (IRIS.WMGFCLOSE 531) (* gf # is no longer being used) (IRIS.WMTXCLOSE 532) (* tx # is no longer being used) (IRIS.MODECHANGE 533) (* the display mode has changed) (IRIS.INPUTCHANGE 534) (* input connected or disconnected) (IRIS.QFULL 535) (* queue was filled)) (* * get.h) (* Values returned by IRIS.GETBUFFER) (CONSTANTS (IRIS.NEITHERBUFFER 0) (IRIS.BACKBUFFER 1) (IRIS.FRONTBUFFER 2) (IRIS.BOTHBUFFERS 3) (IRIS.NOBUFFER 0) (IRIS.BCKBUFFER 1) (IRIS.FRNTBUFFER 2)) (* Values returned by IRIS.GETCMMODE) (CONSTANTS (IRIS.MULTIMAP 0) (IRIS.ONEMAP 1) (IRIS.CMAPMULTI 0) (IRIS.CMAPONE 1)) (* Values returned by IRIS.GETDISPLAYMODE) (CONSTANTS (IRIS.RGBMODE 0) (IRIS.SINGLEBUFFER 1) (IRIS.DOUBLEBUFFER 2) (IRIS.DMRGB 0) (IRIS.DMSINGLE 1) (IRIS.DMDOUBLE 2)) (* Values returned by IRIS.GETDISPLAYMODE) (CONSTANTS (IRIS.HZ30 0) (IRIS.HZ60 1) (IRIS.NTSC 2) (IRIS.PAL 2) (IRIS.HZ50 3) (IRIS.MONA 5) (IRIS.MONB 6) (IRIS.MONC 7) (IRIS.MOND 8) (IRIS.MONSPECIAL 16)) (* Individual hit bits returned by IRIS.HITCODE) (CONSTANTS (IRIS.LEFTPLANE 1) (IRIS.RIGHTPLANE 2) (IRIS.BOTTOMPLANE 4) (IRIS.TOPPLANE 8) (IRIS.NEARPLANE 16) (IRIS.FARPLANE 32)) (* * constants for rotation) (CONSTANTS (IRIS.XAXIS (CHARCODE X)) (IRIS.YAXIS (CHARCODE Y)) (IRIS.ZAXIS (CHARCODE Z))) (* * Other stuff) (* Approximate interval between retraces in milliseconds) (CONSTANTS (IRIS.RETRACEINTERVAL 33.33333]) (* * gl.h) (* Maximum X and Y screen coordinates) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.XMAXSCREEN 1023) (RPAQQ IRIS.YMAXSCREEN 767) (CONSTANTS (IRIS.XMAXSCREEN 1023) (IRIS.YMAXSCREEN 767)) ) (* Various hardware/software limits) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.ATTRIBSTACKDEPTH 10) (RPAQQ IRIS.VPSTACKDEPTH 8) (RPAQQ IRIS.MATRIXSTACKDEPTH 32) (RPAQQ IRIS.STARTTAG -2) (RPAQQ IRIS.ENDTAG -3) (CONSTANTS (IRIS.ATTRIBSTACKDEPTH 10) (IRIS.VPSTACKDEPTH 8) (IRIS.MATRIXSTACKDEPTH 32) (IRIS.STARTTAG -2) (IRIS.ENDTAG -3)) ) (* Name for colors in color map loaded by IRIS.GINIT) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.BACKGROUND 0) (RPAQQ IRIS.BLACK 0) (RPAQQ IRIS.RED 1) (RPAQQ IRIS.GREEN 2) (RPAQQ IRIS.YELLOW 3) (RPAQQ IRIS.BLUE 4) (RPAQQ IRIS.MAGENTA 5) (RPAQQ IRIS.CYAN 6) (RPAQQ IRIS.WHITE 7) (CONSTANTS (IRIS.BACKGROUND 0) (IRIS.BLACK 0) (IRIS.RED 1) (IRIS.GREEN 2) (IRIS.YELLOW 3) (IRIS.BLUE 4) (IRIS.MAGENTA 5) (IRIS.CYAN 6) (IRIS.WHITE 7)) ) (* * device.h) (* Macros to test valuator and button numbers) (DECLARE: EVAL@COMPILE [PUTPROPS IRIS.ISBUTTON MACRO ((b) (AND (GEQ b IRIS.BUTOFFSET) (LESSP b (PLUS IRIS.BUTCOUNT IRIS.BUTOFFSET] [PUTPROPS IRIS.ISSCRBUTTON MACRO ((b) (AND (GEQ b IRIS.SBTOFFSET) (LESSP b (IPLUS IRIS.SBTCOUNT IRIS.SBTOFFSET] [PUTPROPS IRIS.ISVALUATOR MACRO ((v) (AND (GEQ v IRIS.VALOFFSET) (LESSP v (IPLUS IRIS.VALCOUNT IRIS.VALOFFSET] [PUTPROPS IRIS.ISTIMER MACRO ((t) (AND (GEQ t IRIS.TIMOFFSET) (LESSP t (IPLUS IRIS.TIMCOUNT IRIS.TIMOFFSET] [PUTPROPS IRIS.ISDIAL MACRO ((t) (AND (GEQ t IRIS.DIAL0) (LEQ t IRIS.DIAL8] [PUTPROPS IRIS.ISLPEN MACRO ((t) (OR (EQP t IRIS.LPENX) (EQP t IRIS.LPENY] (PUTPROPS IRIS.ISLPENBUT MACRO ((t) (EQP t IRIS.LPENBUT))) ) (* Include file with device definitions) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.NULLDEV 0) (RPAQQ IRIS.BUTOFFSET 1) (RPAQQ IRIS.SBTOFFSET 200) (RPAQQ IRIS.VALOFFSET 256) (RPAQQ IRIS.KEYOFFSET 512) (RPAQQ IRIS.TIMOFFSET 515) (RPAQQ IRIS.BUTCOUNT 144) (RPAQQ IRIS.SBTCOUNT 16) (RPAQQ IRIS.VALCOUNT 14) (RPAQQ IRIS.TIMCOUNT 8) (CONSTANTS (IRIS.NULLDEV 0) (IRIS.BUTOFFSET 1) (IRIS.SBTOFFSET 200) (IRIS.VALOFFSET 256) (IRIS.KEYOFFSET 512) (IRIS.TIMOFFSET 515) (IRIS.BUTCOUNT 144) (IRIS.SBTCOUNT 16) (IRIS.VALCOUNT 14) (IRIS.TIMCOUNT 8)) ) (* Buttons) (DECLARE: EVAL@COMPILE (RPAQ IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET)) (RPAQ IRIS.MAXKBDBUT IRIS.BUT82) (RPAQ IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET)) (RPAQ IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET)) (RPAQ IRIS.MOUSEBUTTON1 IRIS.BUT100) (RPAQ IRIS.MOUSEBUTTON2 IRIS.BUT101) (RPAQ IRIS.MOUSEBUTTON3 IRIS.BUT102) (RPAQ IRIS.MOUSE1 IRIS.BUT100) (RPAQ IRIS.MOUSE2 IRIS.BUT101) (RPAQ IRIS.MOUSE3 IRIS.BUT102) (RPAQ IRIS.LEFTMOUSEBUTTON IRIS.BUT102) (RPAQ IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101) (RPAQ IRIS.RIGHTMOUSEBUTTON IRIS.BUT100) (RPAQ IRIS.LEFTMOUSE IRIS.BUT102) (RPAQ IRIS.MIDDLEMOUSE IRIS.BUT101) (RPAQ IRIS.RIGHTMOUSE IRIS.BUT100) (RPAQQ IRIS.LPENBUT 104) (CONSTANTS (IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET)) (IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET)) (IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET)) (IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET)) (IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET)) (IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET)) (IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET)) (IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET)) (IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET)) (IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET)) (IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET)) (IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET)) (IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET)) (IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET)) (IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET)) (IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET)) (IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET)) (IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET)) (IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET)) (IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET)) (IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET)) (IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET)) (IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET)) (IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET)) (IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET)) (IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET)) (IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET)) (IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET)) (IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET)) (IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET)) (IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET)) (IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET)) (IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET)) (IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET)) (IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET)) (IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET)) (IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET)) (IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET)) (IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET)) (IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET)) (IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET)) (IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET)) (IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET)) (IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET)) (IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET)) (IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET)) (IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET)) (IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET)) (IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET)) (IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET)) (IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET)) (IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET)) (IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET)) (IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET)) (IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET)) (IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET)) (IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET)) (IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET)) (IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET)) (IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET)) (IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET)) (IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET)) (IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET)) (IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET)) (IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET)) (IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET)) (IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET)) (IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET)) (IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET)) (IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET)) (IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET)) (IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET)) (IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET)) (IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET)) (IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET)) (IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET)) (IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET)) (IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET)) (IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET)) (IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET)) (IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET)) (IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET)) (IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET)) (IRIS.MAXKBDBUT IRIS.BUT82) (IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET)) (IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET)) (IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET)) (IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET)) (IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET)) (IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET)) (IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET)) (IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET)) (IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET)) (IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET)) (IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET)) (IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET)) (IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET)) (IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET)) (IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET)) (IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET)) (IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET)) (IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET)) (IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET)) (IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET)) (IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET)) (IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET)) (IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET)) (IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET)) (IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET)) (IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET)) (IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET)) (IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET)) (IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET)) (IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET)) (IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET)) (IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET)) (IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET)) (IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET)) (IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET)) (IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET)) (IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET)) (IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET)) (IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET)) (IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET)) (IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET)) (IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET)) (IRIS.MOUSEBUTTON1 IRIS.BUT100) (IRIS.MOUSEBUTTON2 IRIS.BUT101) (IRIS.MOUSEBUTTON3 IRIS.BUT102) (IRIS.MOUSE1 IRIS.BUT100) (IRIS.MOUSE2 IRIS.BUT101) (IRIS.MOUSE3 IRIS.BUT102) (IRIS.LEFTMOUSEBUTTON IRIS.BUT102) (IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101) (IRIS.RIGHTMOUSEBUTTON IRIS.BUT100) (IRIS.LEFTMOUSE IRIS.BUT102) (IRIS.MIDDLEMOUSE IRIS.BUT101) (IRIS.RIGHTMOUSE IRIS.BUT100) (IRIS.LPENBUT 104)) ) (* Switches) (DECLARE: EVAL@COMPILE (RPAQ IRIS.SWBASE IRIS.BUT110) (RPAQ IRIS.SW0 (IPLUS IRIS.SWBASE 0)) (RPAQ IRIS.SW1 (IPLUS IRIS.SWBASE 1)) (RPAQ IRIS.SW2 (IPLUS IRIS.SWBASE 2)) (RPAQ IRIS.SW3 (IPLUS IRIS.SWBASE 3)) (RPAQ IRIS.SW4 (IPLUS IRIS.SWBASE 4)) (RPAQ IRIS.SW5 (IPLUS IRIS.SWBASE 5)) (RPAQ IRIS.SW6 (IPLUS IRIS.SWBASE 6)) (RPAQ IRIS.SW7 (IPLUS IRIS.SWBASE 7)) (RPAQ IRIS.SW8 (IPLUS IRIS.SWBASE 8)) (RPAQ IRIS.SW9 (IPLUS IRIS.SWBASE 9)) (RPAQ IRIS.SW10 (IPLUS IRIS.SWBASE 10)) (RPAQ IRIS.SW11 (IPLUS IRIS.SWBASE 11)) (RPAQ IRIS.SW12 (IPLUS IRIS.SWBASE 12)) (RPAQ IRIS.SW13 (IPLUS IRIS.SWBASE 13)) (RPAQ IRIS.SW14 (IPLUS IRIS.SWBASE 14)) (RPAQ IRIS.SW15 (IPLUS IRIS.SWBASE 15)) (RPAQ IRIS.SW16 (IPLUS IRIS.SWBASE 16)) (RPAQ IRIS.SW17 (IPLUS IRIS.SWBASE 17)) (RPAQ IRIS.SW18 (IPLUS IRIS.SWBASE 18)) (RPAQ IRIS.SW19 (IPLUS IRIS.SWBASE 19)) (RPAQ IRIS.SW20 (IPLUS IRIS.SWBASE 20)) (RPAQ IRIS.SW21 (IPLUS IRIS.SWBASE 21)) (RPAQ IRIS.SW22 (IPLUS IRIS.SWBASE 22)) (RPAQ IRIS.SW23 (IPLUS IRIS.SWBASE 23)) (RPAQ IRIS.SW24 (IPLUS IRIS.SWBASE 24)) (RPAQ IRIS.SW25 (IPLUS IRIS.SWBASE 25)) (RPAQ IRIS.SW26 (IPLUS IRIS.SWBASE 26)) (RPAQ IRIS.SW27 (IPLUS IRIS.SWBASE 27)) (RPAQ IRIS.SW28 (IPLUS IRIS.SWBASE 28)) (RPAQ IRIS.SW29 (IPLUS IRIS.SWBASE 29)) (RPAQ IRIS.SW30 (IPLUS IRIS.SWBASE 30)) (RPAQ IRIS.SW31 (IPLUS IRIS.SWBASE 31)) (CONSTANTS (IRIS.SWBASE IRIS.BUT110) (IRIS.SW0 (IPLUS IRIS.SWBASE 0)) (IRIS.SW1 (IPLUS IRIS.SWBASE 1)) (IRIS.SW2 (IPLUS IRIS.SWBASE 2)) (IRIS.SW3 (IPLUS IRIS.SWBASE 3)) (IRIS.SW4 (IPLUS IRIS.SWBASE 4)) (IRIS.SW5 (IPLUS IRIS.SWBASE 5)) (IRIS.SW6 (IPLUS IRIS.SWBASE 6)) (IRIS.SW7 (IPLUS IRIS.SWBASE 7)) (IRIS.SW8 (IPLUS IRIS.SWBASE 8)) (IRIS.SW9 (IPLUS IRIS.SWBASE 9)) (IRIS.SW10 (IPLUS IRIS.SWBASE 10)) (IRIS.SW11 (IPLUS IRIS.SWBASE 11)) (IRIS.SW12 (IPLUS IRIS.SWBASE 12)) (IRIS.SW13 (IPLUS IRIS.SWBASE 13)) (IRIS.SW14 (IPLUS IRIS.SWBASE 14)) (IRIS.SW15 (IPLUS IRIS.SWBASE 15)) (IRIS.SW16 (IPLUS IRIS.SWBASE 16)) (IRIS.SW17 (IPLUS IRIS.SWBASE 17)) (IRIS.SW18 (IPLUS IRIS.SWBASE 18)) (IRIS.SW19 (IPLUS IRIS.SWBASE 19)) (IRIS.SW20 (IPLUS IRIS.SWBASE 20)) (IRIS.SW21 (IPLUS IRIS.SWBASE 21)) (IRIS.SW22 (IPLUS IRIS.SWBASE 22)) (IRIS.SW23 (IPLUS IRIS.SWBASE 23)) (IRIS.SW24 (IPLUS IRIS.SWBASE 24)) (IRIS.SW25 (IPLUS IRIS.SWBASE 25)) (IRIS.SW26 (IPLUS IRIS.SWBASE 26)) (IRIS.SW27 (IPLUS IRIS.SWBASE 27)) (IRIS.SW28 (IPLUS IRIS.SWBASE 28)) (IRIS.SW29 (IPLUS IRIS.SWBASE 29)) (IRIS.SW30 (IPLUS IRIS.SWBASE 30)) (IRIS.SW31 (IPLUS IRIS.SWBASE 31))) ) (* Keys) (DECLARE: EVAL@COMPILE (RPAQ IRIS.AKEY IRIS.BUT10) (RPAQ IRIS.BKEY IRIS.BUT35) (RPAQ IRIS.CKEY IRIS.BUT27) (RPAQ IRIS.DKEY IRIS.BUT17) (RPAQ IRIS.EKEY IRIS.BUT16) (RPAQ IRIS.FKEY IRIS.BUT18) (RPAQ IRIS.GKEY IRIS.BUT25) (RPAQ IRIS.HKEY IRIS.BUT26) (RPAQ IRIS.IKEY IRIS.BUT39) (RPAQ IRIS.JKEY IRIS.BUT33) (RPAQ IRIS.KKEY IRIS.BUT34) (RPAQ IRIS.LKEY IRIS.BUT41) (RPAQ IRIS.MKEY IRIS.BUT43) (RPAQ IRIS.NKEY IRIS.BUT36) (RPAQ IRIS.OKEY IRIS.BUT40) (RPAQ IRIS.PKEY IRIS.BUT47) (RPAQ IRIS.QKEY IRIS.BUT9) (RPAQ IRIS.RKEY IRIS.BUT23) (RPAQ IRIS.SKEY IRIS.BUT11) (RPAQ IRIS.TKEY IRIS.BUT24) (RPAQ IRIS.UKEY IRIS.BUT32) (RPAQ IRIS.VKEY IRIS.BUT28) (RPAQ IRIS.WKEY IRIS.BUT15) (RPAQ IRIS.XKEY IRIS.BUT20) (RPAQ IRIS.YKEY IRIS.BUT32) (RPAQ IRIS.ZKEY IRIS.BUT19) (RPAQ IRIS.ZEROKEY IRIS.BUT45) (RPAQ IRIS.ONEKEY IRIS.BUT7) (RPAQ IRIS.TWOKEY IRIS.BUT13) (RPAQ IRIS.THREEKEY IRIS.BUT14) (RPAQ IRIS.FOURKEY IRIS.BUT21) (RPAQ IRIS.FIVCEKEY IRIS.BUT22) (RPAQ IRIS.SIXKEY IRIS.BUT29) (RPAQ IRIS.SEVENKEY IRIS.BUT30) (RPAQ IRIS.EIGHTKEY IRIS.BUT37) (RPAQ IRIS.NINIKEY IRIS.BUT38) (RPAQ IRIS.BREAKKEY IRIS.BUT0) (RPAQ IRIS.SETUPKEY IRIS.BUT1) (RPAQ IRIS.CNTRLKEY IRIS.BUT2) (RPAQ IRIS.CAPSLOCKKEY IRIS.BUT3) (RPAQ IRIS.RIGHTSHIFTKEY IRIS.BUT4) (RPAQ IRIS.LEFTSHIFTKEY IRIS.BUT5) (RPAQ IRIS.NOSCRLKEY IRIS.BUT12) (RPAQ IRIS.ESCKEY IRIS.BUT6) (RPAQ IRIS.TABKEY IRIS.BUT8) (RPAQ IRIS.RETURNKEY IRIS.BUT50) (RPAQ IRIS.SPACEKKEY IRIS.BUT82) (RPAQ IRIS.LINEFEEDKEY IRIS.BUT59) (RPAQ IRIS.BACKSPACEKEY IRIS.BUT60) (RPAQ IRIS.DELETEKEY IRIS.BUT61) (RPAQ IRIS.SEMICOLONKEY IRIS.BUT42) (RPAQ IRIS.PERIODKEY IRIS.BUT51) (RPAQ IRIS.COMMAKEY IRIS.BUT44) (RPAQ IRIS.QUOTEKEY IRIS.BUT49) (RPAQ IRIS.ACCENTGRAVEKEY IRIS.BUT54) (RPAQ IRIS.MINUSKEY IRIS.BUT46) (RPAQ IRIS.VIRGULEKEY IRIS.BUT52) (RPAQ IRIS.BACKSLASHKEY IRIS.BUT56) (RPAQ IRIS.EQUALKEY IRIS.BUT53) (RPAQ IRIS.LEFTBRACKETKEY IRIS.BUT48) (RPAQ IRIS.RIGHTBRACKETKEY IRIS.BUT55) (RPAQ IRIS.LEFTARROWKEY IRIS.BUT72) (RPAQ IRIS.DOWNARROWKEY IRIS.BUT73) (RPAQ IRIS.UPARROWKEY IRIS.BUT80) (RPAQ IRIS.PAD0 IRIS.BUT58) (RPAQ IRIS.PAD1 IRIS.BUT57) (RPAQ IRIS.PAD2 IRIS.BUT63) (RPAQ IRIS.PAD3 IRIS.BUT64) (RPAQ IRIS.PAD4 IRIS.BUT62) (RPAQ IRIS.PAD5 IRIS.BUT68) (RPAQ IRIS.PAD6 IRIS.BUT69) (RPAQ IRIS.PAD8 IRIS.BUT67) (RPAQ IRIS.PAD9 IRIS.BUT74) (RPAQ IRIS.PADPF1 IRIS.BUT71) (RPAQ IRIS.PADPF2 IRIS.BUT70) (RPAQ IRIS.PADPF3 IRIS.BUT78) (RPAQ IRIS.PADPF4 IRIS.BUT77) (RPAQ IRIS.PADPERIOD IRIS.BUT65) (RPAQ IRIS.PADMINUS IRIS.BUT75) (RPAQ IRIS.PADCOMMA IRIS.BUT76) (RPAQ IRIS.PADENTER IRIS.BUT81) (CONSTANTS (IRIS.AKEY IRIS.BUT10) (IRIS.BKEY IRIS.BUT35) (IRIS.CKEY IRIS.BUT27) (IRIS.DKEY IRIS.BUT17) (IRIS.EKEY IRIS.BUT16) (IRIS.FKEY IRIS.BUT18) (IRIS.GKEY IRIS.BUT25) (IRIS.HKEY IRIS.BUT26) (IRIS.IKEY IRIS.BUT39) (IRIS.JKEY IRIS.BUT33) (IRIS.KKEY IRIS.BUT34) (IRIS.LKEY IRIS.BUT41) (IRIS.MKEY IRIS.BUT43) (IRIS.NKEY IRIS.BUT36) (IRIS.OKEY IRIS.BUT40) (IRIS.PKEY IRIS.BUT47) (IRIS.QKEY IRIS.BUT9) (IRIS.RKEY IRIS.BUT23) (IRIS.SKEY IRIS.BUT11) (IRIS.TKEY IRIS.BUT24) (IRIS.UKEY IRIS.BUT32) (IRIS.VKEY IRIS.BUT28) (IRIS.WKEY IRIS.BUT15) (IRIS.XKEY IRIS.BUT20) (IRIS.YKEY IRIS.BUT32) (IRIS.ZKEY IRIS.BUT19) (IRIS.ZEROKEY IRIS.BUT45) (IRIS.ONEKEY IRIS.BUT7) (IRIS.TWOKEY IRIS.BUT13) (IRIS.THREEKEY IRIS.BUT14) (IRIS.FOURKEY IRIS.BUT21) (IRIS.FIVCEKEY IRIS.BUT22) (IRIS.SIXKEY IRIS.BUT29) (IRIS.SEVENKEY IRIS.BUT30) (IRIS.EIGHTKEY IRIS.BUT37) (IRIS.NINIKEY IRIS.BUT38) (IRIS.BREAKKEY IRIS.BUT0) (IRIS.SETUPKEY IRIS.BUT1) (IRIS.CNTRLKEY IRIS.BUT2) (IRIS.CAPSLOCKKEY IRIS.BUT3) (IRIS.RIGHTSHIFTKEY IRIS.BUT4) (IRIS.LEFTSHIFTKEY IRIS.BUT5) (IRIS.NOSCRLKEY IRIS.BUT12) (IRIS.ESCKEY IRIS.BUT6) (IRIS.TABKEY IRIS.BUT8) (IRIS.RETURNKEY IRIS.BUT50) (IRIS.SPACEKKEY IRIS.BUT82) (IRIS.LINEFEEDKEY IRIS.BUT59) (IRIS.BACKSPACEKEY IRIS.BUT60) (IRIS.DELETEKEY IRIS.BUT61) (IRIS.SEMICOLONKEY IRIS.BUT42) (IRIS.PERIODKEY IRIS.BUT51) (IRIS.COMMAKEY IRIS.BUT44) (IRIS.QUOTEKEY IRIS.BUT49) (IRIS.ACCENTGRAVEKEY IRIS.BUT54) (IRIS.MINUSKEY IRIS.BUT46) (IRIS.VIRGULEKEY IRIS.BUT52) (IRIS.BACKSLASHKEY IRIS.BUT56) (IRIS.EQUALKEY IRIS.BUT53) (IRIS.LEFTBRACKETKEY IRIS.BUT48) (IRIS.RIGHTBRACKETKEY IRIS.BUT55) (IRIS.LEFTARROWKEY IRIS.BUT72) (IRIS.DOWNARROWKEY IRIS.BUT73) (IRIS.UPARROWKEY IRIS.BUT80) (IRIS.PAD0 IRIS.BUT58) (IRIS.PAD1 IRIS.BUT57) (IRIS.PAD2 IRIS.BUT63) (IRIS.PAD3 IRIS.BUT64) (IRIS.PAD4 IRIS.BUT62) (IRIS.PAD5 IRIS.BUT68) (IRIS.PAD6 IRIS.BUT69) (IRIS.PAD8 IRIS.BUT67) (IRIS.PAD9 IRIS.BUT74) (IRIS.PADPF1 IRIS.BUT71) (IRIS.PADPF2 IRIS.BUT70) (IRIS.PADPF3 IRIS.BUT78) (IRIS.PADPF4 IRIS.BUT77) (IRIS.PADPERIOD IRIS.BUT65) (IRIS.PADMINUS IRIS.BUT75) (IRIS.PADCOMMA IRIS.BUT76) (IRIS.PADENTER IRIS.BUT81)) ) (* Screen buttons) (DECLARE: EVAL@COMPILE (RPAQ IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0)) (RPAQ IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1)) (RPAQ IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2)) (RPAQ IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3)) (RPAQ IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4)) (RPAQ IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5)) (RPAQ IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6)) (RPAQ IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7)) (RPAQ IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8)) (RPAQ IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9)) (RPAQ IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10)) (RPAQ IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11)) (RPAQ IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12)) (RPAQ IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13)) (RPAQ IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14)) (RPAQ IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15)) (RPAQ IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16)) (CONSTANTS (IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0)) (IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1)) (IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2)) (IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3)) (IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4)) (IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5)) (IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6)) (IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7)) (IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8)) (IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9)) (IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10)) (IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11)) (IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12)) (IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13)) (IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14)) (IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15)) (IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16))) ) (* Valuators) (DECLARE: EVAL@COMPILE (RPAQ IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET)) (RPAQ IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET)) (RPAQ IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET)) (RPAQ IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET)) (RPAQ IRIS.LPENX (PLUS 12 IRIS.VALOFFSET)) (RPAQ IRIS.PLENY (PLUS 13 IRIS.VALOFFSET)) (RPAQ IRIS.NULLX (PLUS 14 IRIS.VALOFFSET)) (RPAQ IRIS.NULLY (PLUS 15 IRIS.VALOFFSET)) (CONSTANTS (IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET)) (IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET)) (IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET)) (IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET)) (IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET)) (IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET)) (IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET)) (IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET)) (IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET)) (IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET)) (IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET)) (IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET)) (IRIS.LPENX (PLUS 12 IRIS.VALOFFSET)) (IRIS.PLENY (PLUS 13 IRIS.VALOFFSET)) (IRIS.NULLX (PLUS 14 IRIS.VALOFFSET)) (IRIS.NULLY (PLUS 15 IRIS.VALOFFSET))) ) (* Timers) (DECLARE: EVAL@COMPILE (RPAQ IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0)) (RPAQ IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1)) (RPAQ IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2)) (RPAQ IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3)) (RPAQ IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4)) (RPAQ IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5)) (RPAQ IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6)) (RPAQ IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7)) (CONSTANTS (IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0)) (IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1)) (IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2)) (IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3)) (IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4)) (IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5)) (IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6)) (IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7))) ) (* Misc devices) (DECLARE: EVAL@COMPILE (RPAQ IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET)) (RPAQQ IRIS.CURSORX 526) (RPAQQ IRIS.CURSORY 527) (RPAQQ IRIS.VALMARK 523) (RPAQQ IRIS.GERROR 524) (RPAQQ IRIS.REDRAW 528) (RPAQQ IRIS.WMSEND 529) (RPAQQ IRIS.WMREPLY 530) (RPAQQ IRIS.WMGFCLOSE 531) (RPAQQ IRIS.WMTXCLOSE 532) (RPAQQ IRIS.MODECHANGE 533) (RPAQQ IRIS.INPUTCHANGE 534) (RPAQQ IRIS.QFULL 535) (CONSTANTS (IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET)) (IRIS.CURSORX 526) (IRIS.CURSORY 527) (IRIS.VALMARK 523) (IRIS.GERROR 524) (IRIS.REDRAW 528) (IRIS.WMSEND 529) (IRIS.WMREPLY 530) (IRIS.WMGFCLOSE 531) (IRIS.WMTXCLOSE 532) (IRIS.MODECHANGE 533) (IRIS.INPUTCHANGE 534) (IRIS.QFULL 535)) ) (* * get.h) (* Values returned by IRIS.GETBUFFER) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.NEITHERBUFFER 0) (RPAQQ IRIS.BACKBUFFER 1) (RPAQQ IRIS.FRONTBUFFER 2) (RPAQQ IRIS.BOTHBUFFERS 3) (RPAQQ IRIS.NOBUFFER 0) (RPAQQ IRIS.BCKBUFFER 1) (RPAQQ IRIS.FRNTBUFFER 2) (CONSTANTS (IRIS.NEITHERBUFFER 0) (IRIS.BACKBUFFER 1) (IRIS.FRONTBUFFER 2) (IRIS.BOTHBUFFERS 3) (IRIS.NOBUFFER 0) (IRIS.BCKBUFFER 1) (IRIS.FRNTBUFFER 2)) ) (* Values returned by IRIS.GETCMMODE) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.MULTIMAP 0) (RPAQQ IRIS.ONEMAP 1) (RPAQQ IRIS.CMAPMULTI 0) (RPAQQ IRIS.CMAPONE 1) (CONSTANTS (IRIS.MULTIMAP 0) (IRIS.ONEMAP 1) (IRIS.CMAPMULTI 0) (IRIS.CMAPONE 1)) ) (* Values returned by IRIS.GETDISPLAYMODE) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.RGBMODE 0) (RPAQQ IRIS.SINGLEBUFFER 1) (RPAQQ IRIS.DOUBLEBUFFER 2) (RPAQQ IRIS.DMRGB 0) (RPAQQ IRIS.DMSINGLE 1) (RPAQQ IRIS.DMDOUBLE 2) (CONSTANTS (IRIS.RGBMODE 0) (IRIS.SINGLEBUFFER 1) (IRIS.DOUBLEBUFFER 2) (IRIS.DMRGB 0) (IRIS.DMSINGLE 1) (IRIS.DMDOUBLE 2)) ) (* Values returned by IRIS.GETDISPLAYMODE) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.HZ30 0) (RPAQQ IRIS.HZ60 1) (RPAQQ IRIS.NTSC 2) (RPAQQ IRIS.PAL 2) (RPAQQ IRIS.HZ50 3) (RPAQQ IRIS.MONA 5) (RPAQQ IRIS.MONB 6) (RPAQQ IRIS.MONC 7) (RPAQQ IRIS.MOND 8) (RPAQQ IRIS.MONSPECIAL 16) (CONSTANTS (IRIS.HZ30 0) (IRIS.HZ60 1) (IRIS.NTSC 2) (IRIS.PAL 2) (IRIS.HZ50 3) (IRIS.MONA 5) (IRIS.MONB 6) (IRIS.MONC 7) (IRIS.MOND 8) (IRIS.MONSPECIAL 16)) ) (* Individual hit bits returned by IRIS.HITCODE) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.LEFTPLANE 1) (RPAQQ IRIS.RIGHTPLANE 2) (RPAQQ IRIS.BOTTOMPLANE 4) (RPAQQ IRIS.TOPPLANE 8) (RPAQQ IRIS.NEARPLANE 16) (RPAQQ IRIS.FARPLANE 32) (CONSTANTS (IRIS.LEFTPLANE 1) (IRIS.RIGHTPLANE 2) (IRIS.BOTTOMPLANE 4) (IRIS.TOPPLANE 8) (IRIS.NEARPLANE 16) (IRIS.FARPLANE 32)) ) (* * constants for rotation) (DECLARE: EVAL@COMPILE (RPAQ IRIS.XAXIS (CHARCODE X)) (RPAQ IRIS.YAXIS (CHARCODE Y)) (RPAQ IRIS.ZAXIS (CHARCODE Z)) (CONSTANTS (IRIS.XAXIS (CHARCODE X)) (IRIS.YAXIS (CHARCODE Y)) (IRIS.ZAXIS (CHARCODE Z))) ) (* * Other stuff) (* Approximate interval between retraces in milliseconds) (DECLARE: EVAL@COMPILE (RPAQQ IRIS.RETRACEINTERVAL 33.33333) (CONSTANTS (IRIS.RETRACEINTERVAL 33.33333)) ) (PUTPROPS IRISCONSTANTS COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/IRISDEMOFNS b/lispusers/IRISDEMOFNS new file mode 100644 index 00000000..7b581619 --- /dev/null +++ b/lispusers/IRISDEMOFNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 2-Feb-87 21:13:01" {ERIS}NEXT>IRISDEMOFNS.;10 21478 changes to%: (VARS IRISDEMOFNSCOMS) (FNS TETRA TETRA.DRAW.FACE TETRA.OBJ) previous date%: " 4-Mar-86 10:57:38" {ERIS}NEXT>IRISDEMOFNS.;8) (PRETTYCOMPRINT IRISDEMOFNSCOMS) (RPAQQ IRISDEMOFNSCOMS [(FNS IRIS.DEGREES SNOW SPHERE TETRA TETRA.COLOR TETRA.DRAW.FACE TETRA.OBJ TETRA.TILT.AND.RECURSE) (VARS IRIS.TILT TETRA.COLOR TETRA.EDGE.COLOR TETRA.SHRINK TETRA.TILT IV.DEFAULT.STYLE) (* ;; "minimal 3-d support for the tetra demo") (RECORDS 3POINT) (FNS 3DOT 3DRAWTO 3MOVETO 3NORMALIZE 3PLUS 3POINT 3UNITCROSSPRODUCT 3DIFFERENCE 3CROSSPRODUCT 3LENGTH 3LINE 3TIMES DRAW.FACE? IRIS.XLATE) (VARS \IRIS.DUMMYBUFFER \IRIS.FEEDBACKBUFFER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TETRA]) (DEFINEQ (IRIS.DEGREES [LAMBDA (DEGREES) (* edited%: "13-Dec-85 18:32") (* Takes an angle in degrees and returns an angle as the iris likes it  (tenths)) (FIX (TIMES DEGREES 10]) (SNOW [LAMBDA (N) (* edited%: "11-Dec-85 23:12") (for I to (OR N (RAND 5 20)) do (IRIS.PUSHMATRIX) (IRIS.TRANSLATE (RAND 0 SCREENWIDTH) (RAND 0 SCREENHEIGHT) 0 \IRISSTREAM) (IRIS.ROTATE (RAND 0 1800) 88) (IRIS.ROTATE (RAND 0 1800) 89) (IRIS.ROTATE (RAND 0 1800) 90) (IRIS.SCALE (RAND 0.1 1) (RAND 0.1 1) (RAND 0.1 1)) (SPHERE " Noel" (RAND 5 90) (RAND 1 3)) (IRIS.POPMATRIX]) (SPHERE [LAMBDA (MSG THETA COUNT) (* edited%: "11-Dec-85 15:24") (IRIS.PUSHMATRIX) (OR THETA (SETQ THETA 30)) (OR COUNT (SETQ COUNT 3)) (DSPCOLOR 'RED \IRISSTREAM) (IRIS.PUSHMATRIX) (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM) (DSPCOLOR (IMOD I 7) \IRISSTREAM) (IRIS.ROTATE (ITIMES 10 THETA) IRIS.ZAXIS) (PRINTOUT \IRISSTREAM MSG)) (IRIS.POPMATRIX) (IRIS.PUSHMATRIX) (IRIS.ROTATE 900 IRIS.YAXIS) (DSPCOLOR 'BLACK \IRISSTREAM) (SELECTQ COUNT (1 NIL) (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM) (DSPCOLOR (IMOD I 7) \IRISSTREAM) (IRIS.ROTATE (ITIMES 10 THETA) IRIS.ZAXIS) (PRINTOUT \IRISSTREAM MSG))) (IRIS.POPMATRIX) (DSPCOLOR 'CYAN \IRISSTREAM) (IRIS.ROTATE 900 IRIS.XAXIS) (SELECTQ COUNT ((1 2) NIL) (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM) (DSPCOLOR (IMOD I 7) \IRISSTREAM) (IRIS.ROTATE (ITIMES 10 THETA) IRIS.ZAXIS) (PRINTOUT \IRISSTREAM MSG))) (IRIS.POPMATRIX]) (TETRA [CL:LAMBDA (&OPTIONAL (SIDE-LENGTH 200) (RECURSIVE-DEPTH 3) (SHRINK-FACTOR TETRA.SHRINK) (STYLE 'WIREFRAME) (DONTBASERECURSE NIL)) (* ; "Edited 31-Jan-87 17:29 by gbn") (* ;;; "Draws a recursive tetrahedron. shrinkfactor is the ratio of side length of parent and child. style is one of 'wireframe, polygon or normal.") (LET ((RECURSIVE-DEPTH (OR RECURSIVE-DEPTH 5)) (SHRINK-FACTOR (OR SHRINK-FACTOR TETRA.SHRINK)) (STYLE (OR STYLE IV.DEFAULT.STYLE))) (if (EQ 0 RECURSIVE-DEPTH) then (* ; "done") NIL else (TETRA.OBJ SIDE-LENGTH (TETRA.COLOR RECURSIVE-DEPTH) STYLE DONTBASERECURSE) (if (NOT DONTBASERECURSE) then (IRIS.PUSHMATRIX) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.YAXIS) (IRIS.ROTATE (IRIS.DEGREES (MINUS TETRA.TILT)) IRIS.XAXIS) (IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3)) 0) (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE ) (IRIS.POPMATRIX)) (IRIS.PUSHMATRIX) (IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3)) 0) (* ;  "move the origin to the middle of the base of the tetrahedron") (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) (IRIS.ROTATE (IRIS.DEGREES 120) IRIS.ZAXIS) (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) (IRIS.ROTATE (IRIS.DEGREES 120) IRIS.ZAXIS) (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) (* ;; "(IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3))) 0) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.XAXIS) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.ZAXIS) (TETRA.TILT.AND.RECURSE X RECDEPTH)") (IRIS.POPMATRIX]) (TETRA.COLOR [LAMBDA (COLOR) (* gbn "21-Feb-86 17:11") (IMOD COLOR 8]) (TETRA.DRAW.FACE [LAMBDA (STYLE COLOR LEFT RIGHT TOP) (* ; "Edited 31-Jan-87 18:44 by gbn") (* ;; "handles drawing a single face. Left right and top are just logical names for the points of the triangle. They need not correspond to Tetra's interpretation of those names.") (SELECTQ STYLE (WIREFRAME) ((POLYGON NORMALS BACKFACES) (if (NOT DONTBASERECURSE) then (IRIS.POLF 3 (LIST LEFT RIGHT FRONT))) (DSPCOLOR COLOR \IRISSTREAM) (IRIS.POLF 3 (LIST LEFT RIGHT TOP)) (* ;  "(IRIS.POLF 3 (LIST FRONT RIGHT TOP)) (IRIS.POLF 3 (LIST FRONT LEFT TOP))") (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM) (3MOVETO \IRISSTREAM LEFT) (3DRAWTO \IRISSTREAM RIGHT) (3DRAWTO \IRISSTREAM TOP) (3DRAWTO \IRISSTREAM LEFT) (SELECTQ STYLE (POLYGON) (NORMALS (* ;  "compute and draw a normal to the face") [LET* ((LEFTTOP (3DIFFERENCE TOP LEFT)) (LEFTRIGHT (3DIFFERENCE RIGHT LEFT)) (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT)) (NORMAL (3DIFFERENCE NORMALENDPT LEFT))) (3LINE LEFT (3PLUS LEFT (3TIMES (3NORMALIZE NORMAL) 50]) (BACKFACES (* ;  "compute and draw a normal to the face") (LET* ((LEFTTOP (3DIFFERENCE TOP LEFT)) (LEFTRIGHT (3DIFFERENCE RIGHT LEFT)) (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT)) (NORMAL (3DIFFERENCE NORMALENDPT LEFT)) (EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT) LEFT))) (if (LESSP (3DOT EYEVECTOR NORMAL) 0.0) then (* ; "this is not a backface so drawit") (DSPCOLOR COLOR \IRISSTREAM) (IRIS.POLF 3 (LIST LEFT RIGHT TOP)) (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM) (3MOVETO \IRISSTREAM LEFT) (3DRAWTO \IRISSTREAM RIGHT) (3DRAWTO \IRISSTREAM TOP) (3DRAWTO \IRISSTREAM LEFT)))) (ERROR "Unknown drawing style: " STYLE))) (ERROR "Unknown drawing style: " STYLE]) (TETRA.OBJ [LAMBDA (X COLOR STYLE DONTBASERECURSE) (* ; "Edited 31-Jan-87 17:35 by gbn") (* ;;; "The function that draws a single tetrahedron (and optionally, it's faces.)") (LET ([TOP (3POINT 0 (QUOTIENT X (SQRT 3)) (SQRT (TIMES (TIMES X X) (QUOTIENT 8 3.0] (LEFT (3POINT (MINUS X) 0 0)) (RIGHT (3POINT X 0 0)) (FRONT (3POINT 0 (TIMES (SQRT 3) X) 0))) (IRIS.PUSHATTRIBUTES) (SELECTQ STYLE (WIREFRAME (DSPCOLOR COLOR \IRISSTREAM) (3MOVETO \IRISSTREAM LEFT) (3DRAWTO \IRISSTREAM RIGHT) (3DRAWTO \IRISSTREAM FRONT) (3DRAWTO \IRISSTREAM LEFT) (3DRAWTO \IRISSTREAM TOP) (3DRAWTO \IRISSTREAM RIGHT) (3MOVETO \IRISSTREAM FRONT) (3DRAWTO \IRISSTREAM TOP)) ((POLYGON NORMALS BACKFACES) (DSPCOLOR COLOR \IRISSTREAM) (if (NOT DONTBASERECURSE) then (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT FRONT)) (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT TOP) (TETRA.DRAW.FACE STYLE COLOR RIGHT FRONT TOP) (TETRA.DRAW.FACE STYLE COLOR FRONT LEFT TOP)) (ERROR "Unknown drawing style: " STYLE)) (IRIS.POPATTRIBUTES]) (TETRA.TILT.AND.RECURSE [LAMBDA (X RECDEPTH SHRINKFACTOR STYLE) (* edited%: "16-Dec-85 17:41") (* * sets up the transformations to recurse, and calls tetra) (* * called with 0 0 0 already placed at the "bottom edge" on the face of the  larger tetra) (* BOTTOMY is the y component of the point BOTTOM, which is not explicitly  calculated) (LET [(BOTTOMY (QUOTIENT X (SQRT 3] (IRIS.PUSHMATRIX) (IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3))) 0) (IRIS.ROTATE (IRIS.DEGREES TETRA.TILT) IRIS.XAXIS) (IRIS.TRANSLATE 0 (DIFFERENCE BOTTOMY (TIMES BOTTOMY SHRINKFACTOR)) 0) (IRIS.SCALE SHRINKFACTOR SHRINKFACTOR SHRINKFACTOR) (TETRA (TIMES SHRINKFACTOR X) (SUB1 RECDEPTH) SHRINKFACTOR STYLE T) (* IRIS.TRANSLATE 0 (MINUS BOTTOMY) 0) (* put 0 0 0 back on the edge of the larger tetra) (IRIS.POPMATRIX]) ) (RPAQQ IRIS.TILT 70.52878) (RPAQQ TETRA.COLOR BLUE) (RPAQQ TETRA.EDGE.COLOR BLACK) (RPAQQ TETRA.SHRINK 0.7) (RPAQQ TETRA.TILT 70.52878) (RPAQQ IV.DEFAULT.STYLE WIREFRAME) (* ;; "minimal 3-d support for the tetra demo") (DECLARE%: EVAL@COMPILE (RECORD 3POINT (|3X| |3Y| |3Z|)) ) (DEFINEQ (3DOT [LAMBDA (A B) (* gbn " 3-Mar-86 17:54") (PLUS (TIMES (fetch |3X| of A) (fetch |3X| of B)) (TIMES (fetch |3Y| of A) (fetch |3Y| of B)) (TIMES (fetch |3Z| of A) (fetch |3Z| of B]) (3DRAWTO [LAMBDA (STREAM XOR3PT Y Z) (* edited%: "13-Dec-85 16:16") (if (NUMBERP XOR3PT) then (IRIS.DRAW XOR3PT Y Z STREAM) else (IRIS.DRAW (fetch |3X| of XOR3PT) (fetch |3Y| of XOR3PT) (fetch |3Z| of XOR3PT) STREAM]) (3MOVETO [LAMBDA (STREAM XOR3PT Y Z) (* edited%: "13-Dec-85 16:16") (if (NUMBERP XOR3PT) then (IRIS.MOVE XOR3PT Y Z STREAM) else (IRIS.MOVE (fetch |3X| of XOR3PT) (fetch |3Y| of XOR3PT) (fetch |3Z| of XOR3PT) STREAM]) (3NORMALIZE [LAMBDA (3VECTOR) (* gbn " 3-Mar-86 15:51") (* * Produces a vector with the same direction but unit magnitude as 3VECTOR) (LET ((LENGTH (3LENGTH 3VECTOR))) (3POINT (QUOTIENT (fetch |3X| of 3VECTOR) LENGTH) (QUOTIENT (fetch |3Y| of 3VECTOR) LENGTH) (QUOTIENT (fetch |3Z| of 3VECTOR) LENGTH]) (3PLUS [LAMBDA (A B) (* gbn " 3-Mar-86 14:46") (* vector sum of a and b) (3POINT (PLUS (fetch |3X| of A) (fetch |3X| of B)) (PLUS (fetch |3Y| of A) (fetch |3Y| of B)) (PLUS (fetch |3Z| of A) (fetch |3Z| of B]) (3POINT [LAMBDA (X Y Z) (* edited%: "13-Dec-85 16:02") (* creates a |3-d| point) (create 3POINT |3X| _ X |3Y| _ Y |3Z| _ Z]) (3UNITCROSSPRODUCT [LAMBDA (A B) (* gbn " 3-Mar-86 15:51") (LET* ((NORMAL (3CROSSPRODUCT A B)) (LENGTH (3LENGTH NORMAL))) (replace |3X| of NORMAL with (QUOTIENT (fetch |3X| of NORMAL) LENGTH)) (replace |3Y| of NORMAL with (QUOTIENT (fetch |3Y| of NORMAL) LENGTH)) (replace |3Z| of NORMAL with (QUOTIENT (fetch |3Z| of NORMAL) LENGTH)) NORMAL]) (3DIFFERENCE [LAMBDA (DEST SOURCE) (* gbn "28-Feb-86 17:13") (* vector difference from source to  dest) (3POINT (DIFFERENCE (fetch |3X| of DEST) (fetch |3X| of SOURCE)) (DIFFERENCE (fetch |3Y| of DEST) (fetch |3Z| of SOURCE)) (DIFFERENCE (fetch |3Z| of DEST) (fetch |3Z| of SOURCE]) (3CROSSPRODUCT [LAMBDA (A B) (* gbn "28-Feb-86 17:17") (3POINT (DIFFERENCE (TIMES (fetch |3Y| of A) (fetch |3Z| of B)) (TIMES (fetch |3Z| of A) (fetch |3Y| of B))) (DIFFERENCE (TIMES (fetch |3Z| of A) (fetch |3X| of B)) (TIMES (fetch |3X| of A) (fetch |3Z| of B))) (DIFFERENCE (TIMES (fetch |3X| of A) (fetch |3Y| of B)) (TIMES (fetch |3Y| of A) (fetch |3X| of B]) (3LENGTH [LAMBDA (A) (* gbn " 3-Mar-86 15:36") (* * returns the euclidean norm of the |3d| vector) (SQRT (PLUS (TIMES (fetch |3X| of A) (fetch |3X| of A)) (TIMES (fetch |3Y| of A) (fetch |3Y| of A)) (TIMES (fetch |3Z| of A) (fetch |3Z| of A]) (3LINE [LAMBDA (A B) (* gbn "28-Feb-86 17:22") (3MOVETO \IRISSTREAM A) (3DRAWTO \IRISSTREAM B]) (3TIMES [LAMBDA (VECTOR SCALAR) (* gbn " 3-Mar-86 14:47") (3POINT (TIMES (fetch |3X| of VECTOR) SCALAR) (TIMES (fetch |3Y| of VECTOR) SCALAR) (TIMES (fetch |3Z| of VECTOR) SCALAR]) (DRAW.FACE? [LAMBDA (LEFT RIGHT TOP COLOR) (* gbn " 3-Mar-86 18:45") (* handles drawing a single face. Left right and top are just logical names for  the points of the triangle. They need not correspond to Tetra's interpretation  of those names.) (LET* ((LEFTTOP (3DIFFERENCE TOP LEFT)) (LEFTRIGHT (3DIFFERENCE RIGHT LEFT)) (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT)) (NORMAL (3DIFFERENCE NORMALENDPT LEFT)) (EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT) LEFT))) (if (GREATERP (3DOT EYEVECTOR NORMAL) 0.0) then (* this is not a backface so drawit) (DSPCOLOR (OR COLOR 'CYAN) \IRISSTREAM) (IRIS.POLF 3 (LIST LEFT RIGHT TOP)) (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM) (3MOVETO \IRISSTREAM LEFT) (3DRAWTO \IRISSTREAM RIGHT) (3DRAWTO \IRISSTREAM TOP) (3DRAWTO \IRISSTREAM LEFT]) (IRIS.XLATE [LAMBDA (3VECTOR) (* gbn " 3-Mar-86 17:18") (IRIS.FEEDBACK \IRIS.DUMMYBUFFER 9) (IRIS.XFPT (fetch |3X| of 3VECTOR) (fetch |3Y| of 3VECTOR) (fetch |3Z| of 3VECTOR)) (if (NOT (EQUAL (IRIS.ENDFEEDBACK \IRIS.FEEDBACKBUFFER) 9)) then (HELP "NINE ITEMS NOT RETURNED")) (3POINT (create FLOATP HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 2) LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 3)) (create FLOATP HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 4) LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 5)) (create FLOATP HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 6) LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 7]) ) (RPAQ \IRIS.DUMMYBUFFER (READARRAY 9 (QUOTE FIXP) 1)) (1 1 1 1 1 1 1 1 1 NIL ) (RPAQ \IRIS.FEEDBACKBUFFER (READARRAY 9 (QUOTE FIXP) 1)) (56 17275 9800 17288 8544 17585 41814 17585 41814 NIL ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TETRA) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1291 13248 (IRIS.DEGREES 1301 . 1568) (SNOW 1570 . 2622) (SPHERE 2624 . 4537) (TETRA 4539 . 7134) (TETRA.COLOR 7136 . 7267) (TETRA.DRAW.FACE 7269 . 10466) (TETRA.OBJ 10468 . 12107) ( TETRA.TILT.AND.RECURSE 12109 . 13246)) (13570 21123 (3DOT 13580 . 13945) (3DRAWTO 13947 . 14317) ( 3MOVETO 14319 . 14689) (3NORMALIZE 14691 . 15221) (3PLUS 15223 . 15686) (3POINT 15688 . 15975) ( 3UNITCROSSPRODUCT 15977 . 16640) (3DIFFERENCE 16642 . 17238) (3CROSSPRODUCT 17240 . 18011) (3LENGTH 18013 . 18495) (3LINE 18497 . 18667) (3TIMES 18669 . 19007) (DRAW.FACE? 19009 . 20260) (IRIS.XLATE 20262 . 21121))))) STOP \ No newline at end of file diff --git a/lispusers/IRISIO b/lispusers/IRISIO new file mode 100644 index 00000000..5028eace --- /dev/null +++ b/lispusers/IRISIO @@ -0,0 +1 @@ +(FILECREATED "12-Nov-85 19:11:43" {ERIS}KOTO>IRISIO.;2 21026 changes to: (VARS IRISIOCOMS) (FNS IRIS.SENDFS) previous date: " 9-Sep-85 13:47:28" {ERIS}KOTO>IRISIO.;1) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT IRISIOCOMS) (RPAQQ IRISIOCOMS [(COMS (* User level primitives) (FNS IRIS.GEXIT IRIS.GFLUSH IRIS.GINIT IRIS.GRESET) (MACROS IRIS.GFLUSH)) (COMS (* Lower level primitives) (FNS IRIS.RECBS IRIS.RECFS IRIS.RECLS IRIS.RECSS IRIS.SENDBS IRIS.SENDFS IRIS.SENDLS IRIS.SENDQS IRIS.SENDSS IRIS.SETFASTCOM) (MACROS IRIS.DOSYNC IRIS.ECHOFF IRIS.ECHOON IRIS.FLUSHG IRIS.GCMD IRIS.GETGCHAR IRIS.GEXIT IRIS.GFINISH IRIS.PUTGCHAR IRIS.REC32 IRIS.REC6 IRIS.RECB IRIS.RECCR IRIS.RECF IRIS.RECL IRIS.RECO IRIS.RECOS IRIS.RECS IRIS.SEND6 IRIS.SEND8 IRIS.SENDB IRIS.SENDC IRIS.SENDF IRIS.SENDL IRIS.SENDO IRIS.SENDS SPPINPUTSTREAM SPPSTREAM?) (CONSTANTS (STDERR T) (IRIS\AESC 46) (IRIS\RESC 126) (IRIS\TESC 16))) [DECLARE: EVAL@LOAD DONTCOPY (P (LOADDEF (QUOTE FLOATP) (QUOTE RECORD) (QUOTE LLARITH] (INITVARS (IRISCONN) (IRISSPPON T)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* User level primitives) (DEFINEQ (IRIS.GEXIT (LAMBDA (stream) (if stream then (IRIS.FLUSHG stream) else (IRIS.FLUSHG IRISCONN)))) (IRIS.GFLUSH (LAMBDA (stream) (if stream then (IRIS.FLUSHG stream) else (IRIS.FLUSHG IRISCONN)))) (IRIS.GINIT (LAMBDA (STREAM) (* LeL, " 3-Sep-85 17:18") (if (NOT STREAM) then (SETQ STREAM IRISCONN)) (IRIS.SETFASTCOM STREAM) (* Assumes that we communicate on the net) (IRIS.XGINIT STREAM) (IRIS.FLUSHG STREAM))) (IRIS.GRESET (LAMBDA (STREAM) (* LeL, " 3-Sep-85 17:18") (IRIS.XGRESET STREAM) (IRIS.FLUSHG STREAM))) ) (DECLARE: EVAL@COMPILE [PUTPROPS IRIS.GFLUSH MACRO (arg? (* Just for speed...) (if arg? then (CONS (QUOTE IRIS.FLUSHG) arg?) else (QUOTE (IRIS.FLUSHG IRISCONN] ) (* Lower level primitives) (DEFINEQ (IRIS.RECBS (LAMBDA (values stream) (* LeL, " 6-Sep-85 14:15") (* Receive an array of bytes and fill VALUES) (PROG (nLongs nBytes) (SETQ nLongs (LRSH (IPLUS (SETQ nBytes (IRIS.RECL stream)) 3) 2)) (* Number of longs - FIXP - to recieve) (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) then (PRINT "IRIS.RECBS: error in array transport" STDERR) (while (SPP.READP stream) do (BIN stream)) (* Flush input) (RETURN)) (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 3 bind aLong (arrayMax _(IPLUS (ARRAYORIG values) nVals)) do (SETQ aLong (IRIS.REC32 stream)) (* Recieve 6 six-bits words to make a long) (if (IRIS.DOSYNC i) then (IRIS.GETGCHAR stream) (IRIS.PUTGCHAR IRIS\AESC stream) (IRIS.FLUSHG stream)) (for j from 0 to 2 when (LEQ (IPLUS ptr j) arrayMax) do (SETA values (IPLUS ptr j) (LOGAND 255 (LRSH aLong (LLSH j 3)))))) (IRIS.GETGCHAR stream)))) (IRIS.RECFS (LAMBDA (values stream) (* LeL, " 6-Sep-85 12:50") (* Common subroutine to IRIS.RECFS and IRIS.RECLS) (PROG (nLongs) (SETQ nLongs (IRIS.RECL stream)) (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) then (printout STDERR "IRIS.RECFLS: error in array transport" T) (while (SPP.READP stream) do (BIN stream)) (* Empty the stream buffer) (RETURN)) (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) bind aLong (aFloat _(NCREATE 'FLOATP)) do (SETQ aLong (IRIS.REC32 stream)) (if (IRIS.DOSYNC i) then (IRIS.GETGCHAR stream) (IRIS.PUTGCHAR IRIS\AESC stream) (IRIS.FLUSHG stream)) (replace (FLOATP HIWORD) of aFloat with (LRSH aLong 16)) (replace (FLOATP LOWORD) of aFloat with (LOGAND aLong 65535)) (SETA values ptr aFloat)) (IRIS.GETGCHAR stream)))) (IRIS.RECLS (LAMBDA (values STREAM) (* LeL, " 6-Sep-85 10:22") (* Recieve an array of longs) (PROG (nLongs) (SETQ nLongs (IRIS.RECL STREAM)) (if (NEQ IRIS\RESC (IRIS.GETGCHAR STREAM)) then (PRINT "IRIS.RECLS: error in array transport" STDERR) (while (SPP.READP stream) do (BIN stream)) (RETURN)) (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) bind aLong do (SETQ aLong (IRIS.REC32 STREAM)) (if (IRIS.DOSYNC i) then (IRIS.GETGCHAR STREAM) (IRIS.PUTGCHAR IRIS\AESC STREAM) (IRIS.FLUSHG STREAM)) (SETA values ptr aLong)) (IRIS.GETGCHAR STREAM)))) (IRIS.RECSS (LAMBDA (values stream) (* LeL, " 6-Sep-85 14:17") (* Recieve an array of SMALL INTEGERS) (PROG (nLongs nShorts) (SETQ nLongs (LRSH (ADD1 (SETQ nShorts (IRIS.RECL stream))) 1)) (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) then (PRINT "IRIS.RECSS: error in array transport" STDERR) (while (SPP.READP stream) do (BIN stream)) (RETURN)) (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong do (SETQ aLong (IRIS.REC32 stream)) (if (IRIS.DOSYNC i) then (IRIS.GETGCHAR stream) (IRIS.PUTGCHAR IRIS\AESC stream) (IRIS.FLUSHG stream)) (SETA values ptr (LRSH aLong 16)) (if (OR (LESSP i (SUB1 nLongs)) (EVENP nShorts)) then (SETA values (ADD1 ptr) (LOGAND 65535 aLong)))) (IRIS.GETGCHAR stream)))) (IRIS.SENDBS (LAMBDA (values nVals stream) (* LeL, " 9-Sep-85 05:29") (* Send an array of bytes) (PROG (nLongs) (SETQ nLongs (LRSH (IPLUS nVals 3) 2)) (COND ((ARRAYP values) (IRIS.SENDL nVals stream) (* Fill a 32 bits word starting from highest byte :) (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 4 bind aLong (arrayMax _(IPLUS (ARRAYORIG values) nVals)) do (SETQ aLong (for j from 0 to 4 when (LEQ (IPLUS ptr j) arrayMax) sum (LLSH (ELT values (IPLUS ptr j)) (LLSH j 3)))) (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL aLong stream))) ((LISTP values) (IRIS.SENDL nVals stream) (for i from 0 to (SUB1 nLongs) bind (ptr _ values) do (SETQ aLong (for j from 24 to 0 by -8 when ptr sum (LLSH (pop ptr) j))) (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL aLong stream))))))) (IRIS.SENDFS [LAMBDA (values nVals stream) (* gbn "11-Nov-85 19:48") (* * Sends an array or (possibly two-layered) list of numbers) (COND ([AND (ARRAYP values) (NUMBERP (ELT values (ARRAYORIG values] (* An array of numbers) (IRIS.SENDL (LLSH nVals 2) stream) (for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values) do (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDF (ELT values ptr) stream))) ((AND (LISTP values) (NUMBERP (CAR values))) (* A list of numbers) (IRIS.SENDL (LLSH nVals 2) stream) (for i in values as counter from 0 do (if (IRIS.DOSYNC counter) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDF i stream))) ((AND (LISTP values) (POSITIONP (CAR values)) (NUMBERP (CAAR values))) (* A list of positions) (IRIS.SENDL (LLSH nVals 2) stream) (for i in values bind (counter _ -1) do (if (IRIS.DOSYNC (add counter 1)) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDF (CAR i) stream) (if (IRIS.DOSYNC (add counter 1)) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDF (CDR i) stream))) [(AND (LISTP values) (LISTP (CAR values)) (NUMBERP (CAAR values))) (* A list of list of numbers) (IRIS.SENDL (LLSH nVals 2) stream) (for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1) do (if (IRIS.DOSYNC counter) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDF j stream] (T (ERROR values "-- is not an list [of list]/array of numbers"]) (IRIS.SENDLS (LAMBDA (values nVals stream) (* LeL, " 9-Sep-85 02:14") (* * Sends an array or (possibly two-layered) list of numbers) (COND ((AND (ARRAYP values) (NUMBERP (ELT values (ARRAYORIG values)))) (* An array of numbers) (IRIS.SENDL (LLSH nVals 2) stream) (for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values) do (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL (ELT values ptr) stream))) ((AND (LISTP values) (NUMBERP (CAR values))) (* A list of numbers) (IRIS.SENDL (LLSH nVals 2) stream) (for i in values as counter from 0 do (if (IRIS.DOSYNC counter) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL i stream))) ((AND (LISTP values) (LISTP (CAR values)) (NUMBERP (CAAR values))) (* A list of list of numbers) (IRIS.SENDL (LLSH nVals 2) stream) (for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1) do (if (IRIS.DOSYNC counter) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL j stream)))) (T (ERROR values "-- is not an list [of list]/array of numbers"))))) (IRIS.SENDQS (LAMBDA (values nVals stream) (* LeL, " 2-Sep-85 12:47") (IRIS.SENDL (LLSH nVals 3)) (COND ((ARRAYP values) (for i from 0 to (LLSH nVals 1) by 2 as ptr from 0 by 8 do (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL (LOGOR (LLSH (ELT values ptr) 16) (LLSH (ELT values (IPLUS ptr 1)) 24) (LLSH (ELT values (IPLUS ptr 2)) 8) (ELT values (IPLUS ptr 3))) stream) (if (IRIS.DOSYNC (IPLUS i 1)) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL (LOGOR (LLSH (ELT values (IPLUS ptr 4)) 24) (LLSH (ELT values (IPLUS ptr 5)) 16) (ELT values (IPLUS ptr 6)) (LLSH (ELT values (IPLUS ptr 7)) 8)) stream))) ((LISTP values) (for i from 0 to (LLSH nVals 1) by 2 as ptr from values by 8 do (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL (LOGOR (LLSH (CAR values) 16) (LLSH (CADR values) 24) (LLSH (CADDR values) 8) (CADDDR values)) stream) (SETQ values (NTH values 5)) (if (IRIS.DOSYNC (IPLUS i 1)) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL (LOGOR (LLSH (ELT values (CAR values)) 24) (LLSH (ELT values (CADR values)) 16) (CADDR values) (LLSH (CADDDR values) 8)) stream) (SETQ values (NTH values 5)))) (T (ERROR values "-- neither an array nor a list"))))) (IRIS.SENDSS (LAMBDA (values nVals stream) (* LeL, " 6-Sep-85 14:20") (* * Sends an array or list of numbers shorts (SMALLPs)) (LET ((nLongs (LRSH nVals 1)) (nBytes (LLSH nVals 1))) (COND ((AND (ARRAYP values) (NUMBERP (ELT values (ARRAYORIG values)))) (* An array of numbers) (IRIS.SENDL nBytes stream) (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong do (SETQ aLong (ELT values ptr)) (if (OR (LESSP i nLongs) (EVENP nVals)) then (add aLong (LLSH (ELT values (ADD1 ptr)) 16))) (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL aLong stream))) ((AND (LISTP values) (NUMBERP (CAR values))) (* A list of numbers) (IRIS.SENDL nBytes stream) (for i from 0 to (SUB1 nLongs) bind aLong (pnt _ values) do (SETQ aLong (pop pnt)) (if pnt then (add aLong (LLSH (pop pnt) 16))) (if (IRIS.DOSYNC i) then (IRIS.PUTGCHAR IRIS\AESC stream)) (IRIS.SENDL i stream))) (T (ERROR values "-- is not an list [of list]/array of numbers")))))) (IRIS.SETFASTCOM (LAMBDA (STREAM) (* gbn "19-Mar-85 21:02") (IRIS.GCMD 1 STREAM))) ) (DECLARE: EVAL@COMPILE [PUTPROPS IRIS.DOSYNC MACRO ((i) (COND ((EQ 0 (LOGAND i 7))) (T NIL] (PUTPROPS IRIS.ECHOFF MACRO ((STREAM) (STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG) NIL))) (PUTPROPS IRIS.ECHOON MACRO ((STREAM) (STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG) T))) (PUTPROPS IRIS.FLUSHG MACRO (= . SPP.FORCEOUTPUT)) (PUTPROPS IRIS.GCMD MACRO ((CMD STREAM) (* Sends a command) (BOUT STREAM IRIS\TESC) (* Escape character) (IRIS.SEND6 CMD STREAM) (* ...followed by the number in two six bits transmission) (IRIS.SEND6 (LRSH CMD 6) STREAM))) [PUTPROPS IRIS.GETGCHAR MACRO ((STREAM) (BIN (SPPINPUTSTREAM STREAM] [PUTPROPS IRIS.GEXIT MACRO ((stream) (if stream then (IRIS.FLUSHG stream) else (IRIS.FLUSHG IRISCONN] (PUTPROPS IRIS.GFINISH MACRO ((stream) (* null defn) (IRIS.FLUSHG stream))) (PUTPROPS IRIS.PUTGCHAR MACRO ((onechar SPPSTREAM) (BOUT SPPSTREAM onechar))) [PUTPROPS IRIS.REC32 MACRO ((stream) (for j from 0 to 30 by 6 sum (LLSH (IRIS.REC6 stream) j] (PUTPROPS IRIS.REC6 MACRO ((STREAM) (* Recieve a 6 bit word; we substract 32 because the other end add3s 32 to avoid sending control characters) (* NO LONGER ANDS 63) (IDIFFERENCE (IRIS.GETGCHAR STREAM) 32))) [PUTPROPS IRIS.RECB MACRO (LAMBDA (STREAM) (* Receive a byte) (* is passed the spp outputstream, so must grab the input stream from it) (SETQ STREAM (SPPINPUTSTREAM STREAM)) (while (NEQ IRIS\RESC (BIN STREAM))) (LOGOR (IRIS.REC6 STREAM) (LLSH (IRIS.REC6 STREAM) 6] [PUTPROPS IRIS.RECCR MACRO ((STREAM) (* recieve a CarriageReturn) (IRIS.GETGCHAR STREAM) (* OR (EQ (IRIS.GETGCHAR STREAM) (IPLUS 32 (CHARCODE CR))) (ERROR "IRIS.RECCR received a non-carriage return from the IRIS"] [PUTPROPS IRIS.RECF MACRO (LAMBDA (SPPSTREAM) (* gbn "17-Jun-85 17:31") (* receive a float. uses IRIS.RECL to receive a 32 bit word and convert it to float) (PROG (AFLOAT ALONG) (SETQ ALONG (IRIS.RECL SPPSTREAM)) (SETQ AFLOAT (NCREATE (QUOTE FLOATP))) (replace (FLOATP HIWORD) of AFLOAT with (LRSH ALONG 16)) (replace (FLOATP LOWORD) of AFLOAT with (LOGAND ALONG 65535)) (RETURN AFLOAT] (PUTPROPS IRIS.RECL MACRO ((stream) (while (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) do NIL) (IRIS.REC32 stream))) (PUTPROPS IRIS.RECO MACRO ((STREAM) (* Recieve a boolean) (IRIS.RECB STREAM))) (PUTPROPS IRIS.RECOS MACRO ((values STREAM) (* Recieve an array of boolean) (IRIS.RECBS values STREAM))) [PUTPROPS IRIS.RECS MACRO ((stream) (* Recieve a SMALL INTEGER) (while (NEQ (IRIS.GETGCHAR stream) IRIS\RESC) do NIL) (LET* ((1stbyte (IRIS.REC6 stream)) (2ndbyte (IRIS.REC6 stream))) (LOGOR 1stbyte (LLSH 2ndbyte 6) (LLSH (IRIS.REC6 stream) 12] [PUTPROPS IRIS.SEND6 MACRO ((n STREAM) (* Add 32 to avoid sending control characters) (BOUT STREAM (IPLUS 32 (LOGAND 63 n] (PUTPROPS IRIS.SEND8 MACRO ((n STREAM) (BOUT STREAM n))) (PUTPROPS IRIS.SENDB MACRO ((VALUE STREAM) (* Send a byte) (IRIS.SEND8 VALUE STREAM))) (PUTPROPS IRIS.SENDC MACRO ((string stream) (* Send a string of characters) (* should probably allocate a global resource) (IRIS.SENDBS (NCONC1 (CHCON string) 0) (ADD1 (NCHARS string)) stream))) [PUTPROPS IRIS.SENDF MACRO ((value stream) (* Send a float) (LET ((float (FLOAT value))) (IRIS.SEND8 (\GETBASEBYTE float 0) stream) (IRIS.SEND8 (\GETBASEBYTE float 1) stream) (IRIS.SEND8 (\GETBASEBYTE float 2) stream) (IRIS.SEND8 (\GETBASEBYTE float 3) stream] [PUTPROPS IRIS.SENDL MACRO (LAMBDA (VALUE STREAM) (* Sends a 32 bit integer) (SELECTQ (TYPENAME VALUE) (SMALLP (if (ILESSP VALUE 0) then (IRIS.SEND8 255 STREAM) (IRIS.SEND8 255 STREAM) else (IRIS.SEND8 0 STREAM) (IRIS.SEND8 0 STREAM)) (IRIS.SEND8 (LOGAND (LRSH VALUE 8) 255) STREAM) (IRIS.SEND8 (LOGAND VALUE 255) STREAM)) (FIXP (IRIS.SEND8 (\GETBASEBYTE VALUE 0) STREAM) (IRIS.SEND8 (\GETBASEBYTE VALUE 1) STREAM) (IRIS.SEND8 (\GETBASEBYTE VALUE 2) STREAM) (IRIS.SEND8 (\GETBASEBYTE VALUE 3) STREAM)) (ERROR VALUE "can't be sent thru IRIS.SENDL (neither an FIXP nor a SMALLP)"] (PUTPROPS IRIS.SENDO MACRO ((value STREAM) (* send a boolean) (IRIS.SENDB value STREAM))) (PUTPROPS IRIS.SENDS MACRO ((value STREAM) (* Send a SMALL INTEGER (16 bits)) (IRIS.SEND8 (LOGAND 255 (LRSH value 8)) STREAM) (IRIS.SEND8 (LOGAND 255 value) STREAM))) [PUTPROPS SPPINPUTSTREAM MACRO ((OUTPUTSTREAM) (* gbn "17-Jun-85 17:40") (fetch (SPPCON SPPINPUTSTREAM) of (fetch (STREAM F1) of OUTPUTSTREAM] [PUTPROPS SPPSTREAM? MACRO (LAMBDA (STREAM) (AND (TYPENAME STREAM (QUOTE STREAM)) (TYPENAMEP (fetch F1 of STREAM) (QUOTE SPPCON] ) (DECLARE: EVAL@COMPILE (RPAQQ STDERR T) (RPAQQ IRIS\AESC 46) (RPAQQ IRIS\RESC 126) (RPAQQ IRIS\TESC 16) (CONSTANTS (STDERR T) (IRIS\AESC 46) (IRIS\RESC 126) (IRIS\TESC 16)) ) (DECLARE: EVAL@LOAD DONTCOPY (LOADDEF (QUOTE FLOATP) (QUOTE RECORD) (QUOTE LLARITH)) ) (RPAQ? IRISCONN ) (RPAQ? IRISSPPON T) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS IRISIO COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (1379 2155 (IRIS.GEXIT 1389 . 1514) (IRIS.GFLUSH 1516 . 1642) (IRIS.GINIT 1644 . 1986) ( IRIS.GRESET 1988 . 2153)) (2392 15323 (IRIS.RECBS 2402 . 3820) (IRIS.RECFS 3822 . 4990) (IRIS.RECLS 4992 . 5841) (IRIS.RECSS 5843 . 6941) (IRIS.SENDBS 6943 . 8275) (IRIS.SENDFS 8277 . 10344) ( IRIS.SENDLS 10346 . 11826) (IRIS.SENDQS 11828 . 13707) (IRIS.SENDSS 13709 . 15181) (IRIS.SETFASTCOM 15183 . 15321))))) STOP \ No newline at end of file diff --git a/lispusers/IRISLIB b/lispusers/IRISLIB new file mode 100644 index 00000000..43e89d35 --- /dev/null +++ b/lispusers/IRISLIB @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 2-Feb-87 23:35:29" {ERIS}NEXT>IRISLIB.;7 150378 changes to%: (VARS IRISLIBCOMS) (FNS IRIS\ERROR) previous date%: " 9-Sep-85 05:32:30" {ERIS}NEXT>IRISLIB.;1) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IRISLIBCOMS) (RPAQQ IRISLIBCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES SPPDECLS (LOADCOMP) IRISIO IRISSTREAM)) (GLOBALVARS IRISCONN) (FNS IRIS.XSETSLOWCOM IRIS.XSETFASTCOM IRIS.GVERSION IRIS.GDOWNLOAD IRIS.PAGECOLOR IRIS.TEXTCOLOR IRIS.TEXTPORT IRIS.ARC IRIS.ARCF IRIS.ARCFI IRIS.ARCI IRIS.ATTACHCURSOR IRIS.BACKBUFFER IRIS.BBOX2 IRIS.BBOX2I IRIS.BLINK IRIS.CALLOBJ IRIS.CHARSTR IRIS.CIRC IRIS.CIRCF IRIS.CIRCFI IRIS.CIRCI IRIS.CLEAR IRIS.CLEARHITCODE IRIS.CLOSEOBJ IRIS.CMOV IRIS.CMOV2 IRIS.CMOV2I IRIS.CMOVI IRIS.COLOR IRIS.CURSOFF IRIS.CURSON IRIS.CURVEIT IRIS.DEFCURSOR IRIS.DEFLINESTYLE IRIS.DEFRASTERFONT IRIS.DELOBJ IRIS.DOUBLEBUFFER IRIS.DRAW IRIS.DRAW2 IRIS.DRAW2I IRIS.DRAWI IRIS.EDITOBJ IRIS.ENDPICK IRIS.ENDSELECT IRIS.FINISH IRIS.FONT IRIS.FRONTBUFFER IRIS.GCONFIG IRIS.GENOBJ IRIS.GENTAG IRIS.GETBUFFER IRIS.GETBUTTON IRIS.GETCMMODE IRIS.GETCOLOR IRIS.GETCURSOR IRIS.GETDEPTH IRIS.GETDISPLAYMODE IRIS.GETFONT IRIS.GETHEIGHT IRIS.GETHITCODE IRIS.GETLSBACKUP IRIS.GETLSTYLE IRIS.GETLWIDTH IRIS.GETMAP IRIS.GETMATRIX IRIS.GETPLANES IRIS.GETRESETLS IRIS.GETSCRMASK IRIS.GETVALUATOR IRIS.GETVIEWPORT IRIS.GETWRITEMASK IRIS.XGINIT IRIS.XGRESET IRIS.GRGBCOLOR IRIS.GRGBCURSOR IRIS.GRGBMASK IRIS.ISOBJ IRIS.ISTAG IRIS.LINEWIDTH IRIS.LOADMATRIX IRIS.LOOKAT IRIS.LSBACKUP IRIS.MAKEOBJ IRIS.MAKETAG IRIS.MAPCOLOR IRIS.MAPW IRIS.MAPW2 IRIS.MOVE IRIS.MOVE2 IRIS.MOVE2I IRIS.MOVEI IRIS.MULTIMAP IRIS.MULTMATRIX IRIS.NOISE IRIS.ONEMAP IRIS.ORTHO IRIS.ORTHO2 IRIS.PERSPECTIVE IRIS.PICK IRIS.PICKSIZE IRIS.PNT IRIS.PNT2 IRIS.PNT2I IRIS.PNTI IRIS.POLARVIEW IRIS.POLF IRIS.POLF2 IRIS.POLF2I IRIS.POLFI IRIS.POLY IRIS.POLY2 IRIS.POLY2I IRIS.POLYI IRIS.POPATTRIBUTES IRIS.POPMATRIX IRIS.POPVIEWPORT IRIS.PUSHATTRIBUTES IRIS.PUSHMATRIX IRIS.PUSHVIEWPORT IRIS.QENTER IRIS.QREAD IRIS.QRESET IRIS.QTEST IRIS.READPIXELS IRIS.READRGB IRIS.RECT IRIS.RECTF IRIS.RECTFI IRIS.RECTI IRIS.RESETLS IRIS.RGBCOLOR IRIS.RGBCURSOR IRIS.RGBMODE IRIS.RGBWRITEMASK IRIS.ROTATE IRIS.SCALE IRIS.SCRMASK IRIS.SELECT IRIS.SETBUTTON IRIS.SETCURSOR IRIS.SETDEPTH IRIS.SETLINESTYLE IRIS.SETMAP IRIS.SETVALUATOR IRIS.SINGLEBUFFER IRIS.STRWIDTH IRIS.SWAPBUFFERS IRIS.SWAPINTERVAL IRIS.GSYNC IRIS.TIE IRIS.TRANSLATE IRIS.VIEWPORT IRIS.WINDOW IRIS.WRITEMASK IRIS.WRITEPIXELS IRIS.WRITERGB IRIS.TPON IRIS.TPOFF IRIS.TEXTWRITEMASK IRIS.XGEXIT IRIS.CLKON IRIS.CLKOFF IRIS.LAMPON IRIS.LAMPOFF IRIS.SETBELL IRIS.RINGBELL IRIS.TADELAY IRIS.ARCFS IRIS.ARCS IRIS.BBOX2S IRIS.BLANKSCREEN IRIS.BLKQREAD IRIS.GETMCOLOR IRIS.CALLFUNC IRIS.CHUNKSIZE IRIS.CIRCFS IRIS.CIRCS IRIS.CMOV2S IRIS.CMOVS IRIS.COMPACTIFY IRIS.QDEVICE IRIS.UNQDEVICE IRIS.CURVEBASIS IRIS.CURVEPRECISION IRIS.CRV IRIS.GETTP IRIS.GBEGIN IRIS.TEXTINIT IRIS.CRVN IRIS.DEFBASIS IRIS.DELTAG IRIS.DEPTHCUE IRIS.DRAW2S IRIS.DRAWS IRIS.ENDFEEDBACK IRIS.FEEDBACK IRIS.GETCPOS IRIS.GETDCM IRIS.GETGPOS IRIS.GETLSREPEAT IRIS.GETMEM IRIS.GETMONITOR IRIS.GETOPENOBJ IRIS.GETZBUFFER IRIS.GEWRITE IRIS.INITNAMES IRIS.LOADNAME IRIS.LSREPEAT IRIS.MOVE2S IRIS.MOVES IRIS.NEWTAG IRIS.PASSTHROUGH IRIS.PATCHBASIS IRIS.PATCHPRECISION IRIS.PATCH IRIS.PCLOS IRIS.PDR IRIS.PDR2 IRIS.PDRI IRIS.PDR2I IRIS.PDRS IRIS.PDR2S IRIS.POLF2S IRIS.POLFS IRIS.POLY2S IRIS.POLYS IRIS.PMV IRIS.PMV2 IRIS.PMVI IRIS.PMV2I IRIS.PMVS IRIS.PMV2S IRIS.PNT2S IRIS.PNTS IRIS.POPNAME IRIS.PUSHNAME IRIS.RDR IRIS.RDR2 IRIS.RDRI IRIS.RDR2I IRIS.RDRS IRIS.RDR2S IRIS.RECTCOPY IRIS.RMV IRIS.RMV2 IRIS.RMVI IRIS.RMV2I IRIS.RMVS IRIS.RMV2S IRIS.RPDR IRIS.RPDR2 IRIS.RPDRI IRIS.RPDR2I IRIS.RPDRS IRIS.RPDR2S IRIS.RPMV IRIS.RPMV2 IRIS.RPMVI IRIS.RPMV2I IRIS.RPMVS IRIS.RPMV2S IRIS.SETDBLIGHTS IRIS.SETMONITOR IRIS.SETSHADE IRIS.SHADERANGE IRIS.SPCLOS IRIS.SPLF IRIS.SPLF2 IRIS.SPLFI IRIS.SPLF2I IRIS.SPLFS IRIS.SPLF2S IRIS.XFPT IRIS.XFPTI IRIS.XFPTS IRIS.XFPT2 IRIS.XFPT2I IRIS.XFPT2S IRIS.XFPT4 IRIS.XFPT4I IRIS.XFPT4S IRIS.ZBUFFER IRIS.CHARST IRIS.STRWID IRIS.DEFPATTERN IRIS.GETPATTERN IRIS.SETPATTERN IRIS.OBJINSERT IRIS.OBJDELETE IRIS.OBJREPLACE IRIS.ZCLEAR IRIS.CURORIGIN IRIS.PAGEWRITEMASK IRIS.PATCHCURVES IRIS.DBTEXT IRIS.LASTONE IRIS\ERROR))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD SPPDECLS (LOADCOMP) IRISIO IRISSTREAM) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRISCONN) ) (DEFINEQ (IRIS.XSETSLOWCOM [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 0 sppStream]) (IRIS.XSETFASTCOM [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 1 sppStream]) (IRIS.GVERSION [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 2 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GDOWNLOAD [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 3 sppStream]) (IRIS.PAGECOLOR [LAMBDA (color sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if color then (IRIS.GCMD 4 sppStream) (IRIS.SENDS color sppStream) else (IRIS\ERROR %'IRIS.PAGECOLOR %' (color]) (IRIS.TEXTCOLOR [LAMBDA (color sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if color then (IRIS.GCMD 5 sppStream) (IRIS.SENDS color sppStream) else (IRIS\ERROR %'IRIS.TEXTCOLOR %' (color]) (IRIS.TEXTPORT [LAMBDA (left right top bottom sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right top bottom) then (IRIS.GCMD 6 sppStream) (IRIS.SENDS left sppStream) (IRIS.SENDS right sppStream) (IRIS.SENDS top sppStream) (IRIS.SENDS bottom sppStream) else (IRIS\ERROR %'IRIS.TEXTPORT %' (left right top bottom]) (IRIS.ARC [LAMBDA (x y radius startang endang sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius startang endang) then (IRIS.GCMD 7 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF radius sppStream) (IRIS.SENDS startang sppStream) (IRIS.SENDS endang sppStream) else (IRIS\ERROR %'IRIS.ARC %' (x y radius startang endang]) (IRIS.ARCF [LAMBDA (x y radius startang endang sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius startang endang) then (IRIS.GCMD 8 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF radius sppStream) (IRIS.SENDS startang sppStream) (IRIS.SENDS endang sppStream) else (IRIS\ERROR %'IRIS.ARCF %' (x y radius startang endang]) (IRIS.ARCFI [LAMBDA (x y radius startang endang sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius startang endang) then (IRIS.GCMD 9 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL radius sppStream) (IRIS.SENDS startang sppStream) (IRIS.SENDS endang sppStream) else (IRIS\ERROR %'IRIS.ARCFI %' (x y radius startang endang]) (IRIS.ARCI [LAMBDA (x y radius startang endang sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius startang endang) then (IRIS.GCMD 10 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL radius sppStream) (IRIS.SENDS startang sppStream) (IRIS.SENDS endang sppStream) else (IRIS\ERROR %'IRIS.ARCI %' (x y radius startang endang]) (IRIS.ATTACHCURSOR [LAMBDA (vx vy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND vx vy) then (IRIS.GCMD 11 sppStream) (IRIS.SENDS vx sppStream) (IRIS.SENDS vy sppStream) else (IRIS\ERROR %'IRIS.ATTACHCURSOR %' (vx vy]) (IRIS.BACKBUFFER [LAMBDA (b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if b then (IRIS.GCMD 12 sppStream) (IRIS.SENDO b sppStream) else (IRIS\ERROR %'IRIS.BACKBUFFER %' (b]) (IRIS.BBOX2 [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND xmin ymin x1 y1 x2 y2) then (IRIS.GCMD 14 sppStream) (IRIS.SENDS xmin sppStream) (IRIS.SENDS ymin sppStream) (IRIS.SENDF x1 sppStream) (IRIS.SENDF y1 sppStream) (IRIS.SENDF x2 sppStream) (IRIS.SENDF y2 sppStream) else (IRIS\ERROR %'IRIS.BBOX2 %' (xmin ymin x1 y1 x2 y2]) (IRIS.BBOX2I [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND xmin ymin x1 y1 x2 y2) then (IRIS.GCMD 15 sppStream) (IRIS.SENDS xmin sppStream) (IRIS.SENDS ymin sppStream) (IRIS.SENDL x1 sppStream) (IRIS.SENDL y1 sppStream) (IRIS.SENDL x2 sppStream) (IRIS.SENDL y2 sppStream) else (IRIS\ERROR %'IRIS.BBOX2I %' (xmin ymin x1 y1 x2 y2]) (IRIS.BLINK [LAMBDA (rate color red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND rate color red green blue) then (IRIS.GCMD 17 sppStream) (IRIS.SENDS rate sppStream) (IRIS.SENDS color sppStream) (IRIS.SENDS red sppStream) (IRIS.SENDS green sppStream) (IRIS.SENDS blue sppStream) else (IRIS\ERROR %'IRIS.BLINK %' (rate color red green blue]) (IRIS.CALLOBJ [LAMBDA (obj sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if obj then (IRIS.GCMD 18 sppStream) (IRIS.SENDL obj sppStream) else (IRIS\ERROR %'IRIS.CALLOBJ %' (obj]) (IRIS.CHARSTR [LAMBDA (str sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if str then (IRIS.GCMD 19 sppStream) (IRIS.SENDC str sppStream) else (IRIS\ERROR %'IRIS.CHARSTR %' (str]) (IRIS.CIRC [LAMBDA (x y radius sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius) then (IRIS.GCMD 20 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF radius sppStream) else (IRIS\ERROR %'IRIS.CIRC %' (x y radius]) (IRIS.CIRCF [LAMBDA (x y radius sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius) then (IRIS.GCMD 21 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF radius sppStream) else (IRIS\ERROR %'IRIS.CIRCF %' (x y radius]) (IRIS.CIRCFI [LAMBDA (x y radius sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius) then (IRIS.GCMD 22 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL radius sppStream) else (IRIS\ERROR %'IRIS.CIRCFI %' (x y radius]) (IRIS.CIRCI [LAMBDA (x y radius sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius) then (IRIS.GCMD 23 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL radius sppStream) else (IRIS\ERROR %'IRIS.CIRCI %' (x y radius]) (IRIS.CLEAR [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 24 sppStream]) (IRIS.CLEARHITCODE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 25 sppStream]) (IRIS.CLOSEOBJ [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 29 sppStream]) (IRIS.CMOV [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 30 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.CMOV %' (x y z]) (IRIS.CMOV2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 31 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.CMOV2 %' (x y]) (IRIS.CMOV2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 32 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.CMOV2I %' (x y]) (IRIS.CMOVI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 33 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.CMOVI %' (x y z]) (IRIS.COLOR [LAMBDA (color sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if color then (IRIS.GCMD 34 sppStream) (IRIS.SENDS color sppStream) else (IRIS\ERROR %'IRIS.COLOR %' (color]) (IRIS.CURSOFF [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 35 sppStream]) (IRIS.CURSON [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 36 sppStream]) (IRIS.CURVEIT [LAMBDA (iterationcount sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if iterationcount then (IRIS.GCMD 38 sppStream) (IRIS.SENDS iterationcount sppStream) else (IRIS\ERROR %'IRIS.CURVEIT %' (iterationcount]) (IRIS.DEFCURSOR [LAMBDA (n curs sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n curs) then (IRIS.GCMD 39 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDSS curs 16 sppStream) else (IRIS\ERROR %'IRIS.DEFCURSOR %' (n curs]) (IRIS.DEFLINESTYLE [LAMBDA (n ls sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n ls) then (IRIS.GCMD 40 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDS ls sppStream) else (IRIS\ERROR %'IRIS.DEFLINESTYLE %' (n ls]) (IRIS.DEFRASTERFONT [LAMBDA (n ht nc chars nr raster sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n ht nc chars nr raster) then (IRIS.GCMD 42 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDS ht sppStream) (IRIS.SENDS nc sppStream) (IRIS.SENDQS chars nc sppStream) (IRIS.SENDS nr sppStream) (IRIS.SENDSS raster nr sppStream) else (IRIS\ERROR %'IRIS.DEFRASTERFONT %' (n ht nc chars nr raster]) (IRIS.DELOBJ [LAMBDA (obj sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if obj then (IRIS.GCMD 45 sppStream) (IRIS.SENDL obj sppStream) else (IRIS\ERROR %'IRIS.DELOBJ %' (obj]) (IRIS.DOUBLEBUFFER [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 46 sppStream]) (IRIS.DRAW [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 47 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.DRAW %' (x y z]) (IRIS.DRAW2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 48 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.DRAW2 %' (x y]) (IRIS.DRAW2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 49 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.DRAW2I %' (x y]) (IRIS.DRAWI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 50 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.DRAWI %' (x y z]) (IRIS.EDITOBJ [LAMBDA (obj sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if obj then (IRIS.GCMD 51 sppStream) (IRIS.SENDL obj sppStream) else (IRIS\ERROR %'IRIS.EDITOBJ %' (obj]) (IRIS.ENDPICK [LAMBDA (buffer sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if buffer then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 52 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECSS buffer sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.ENDPICK %' (buffer]) (IRIS.ENDSELECT [LAMBDA (buffer sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if buffer then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 53 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECSS buffer sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.ENDSELECT %' (buffer]) (IRIS.FINISH [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 54 sppStream]) (IRIS.FONT [LAMBDA (fntnum sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if fntnum then (IRIS.GCMD 55 sppStream) (IRIS.SENDS fntnum sppStream) else (IRIS\ERROR %'IRIS.FONT %' (fntnum]) (IRIS.FRONTBUFFER [LAMBDA (b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if b then (IRIS.GCMD 56 sppStream) (IRIS.SENDO b sppStream) else (IRIS\ERROR %'IRIS.FRONTBUFFER %' (b]) (IRIS.GCONFIG [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 57 sppStream]) (IRIS.GENOBJ [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 58 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GENTAG [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 59 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETBUFFER [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 60 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETBUTTON [LAMBDA (b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if b then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 61 sppStream) (IRIS.SENDS b sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.GETBUTTON %' (b]) (IRIS.GETCMMODE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 62 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETCOLOR [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 63 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETCURSOR [LAMBDA (index color wtm b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND index color wtm b) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 64 sppStream) (IRIS.FLUSHG sppStream) (SET index (IRIS.RECS sppStream)) (SET color (IRIS.RECS sppStream)) (SET wtm (IRIS.RECS sppStream)) (SET b (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETCURSOR %' (index color wtm b]) (IRIS.GETDEPTH [LAMBDA (near far sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND near far) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 65 sppStream) (IRIS.FLUSHG sppStream) (SET near (IRIS.RECS sppStream)) (SET far (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETDEPTH %' (near far]) (IRIS.GETDISPLAYMODE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 66 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETFONT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 67 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETHEIGHT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 68 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETHITCODE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 69 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETLSBACKUP [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 70 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETLSTYLE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 71 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETLWIDTH [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 72 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETMAP [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 73 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETMATRIX [LAMBDA (m sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if m then (IRIS.ECHOFF sppStream) (IRIS.GCMD 74 sppStream) (IRIS.FLUSHG sppStream) (IRIS.RECFS m sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETMATRIX %' (m]) (IRIS.GETPLANES [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 76 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETRESETLS [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 77 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETSCRMASK [LAMBDA (left right bottom top sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 78 sppStream) (IRIS.FLUSHG sppStream) (SET left (IRIS.RECS sppStream)) (SET right (IRIS.RECS sppStream)) (SET bottom (IRIS.RECS sppStream)) (SET top (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETSCRMASK %' (left right bottom top]) (IRIS.GETVALUATOR [LAMBDA (v sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if v then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 80 sppStream) (IRIS.SENDS v sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.GETVALUATOR %' (v]) (IRIS.GETVIEWPORT [LAMBDA (left right bottom top sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 81 sppStream) (IRIS.FLUSHG sppStream) (SET left (IRIS.RECS sppStream)) (SET right (IRIS.RECS sppStream)) (SET bottom (IRIS.RECS sppStream)) (SET top (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETVIEWPORT %' (left right bottom top]) (IRIS.GETWRITEMASK [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 82 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.XGINIT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 83 sppStream]) (IRIS.XGRESET [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 84 sppStream]) (IRIS.GRGBCOLOR [LAMBDA (red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND red green blue) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 85 sppStream) (IRIS.FLUSHG sppStream) (SET red (IRIS.RECS sppStream)) (SET green (IRIS.RECS sppStream)) (SET blue (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GRGBCOLOR %' (red green blue]) (IRIS.GRGBCURSOR [LAMBDA (index red green blue redm greenm blum b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND index red green blue redm greenm blum b) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 86 sppStream) (IRIS.FLUSHG sppStream) (SET index (IRIS.RECS sppStream)) (SET red (IRIS.RECS sppStream)) (SET green (IRIS.RECS sppStream)) (SET blue (IRIS.RECS sppStream)) (SET redm (IRIS.RECS sppStream)) (SET greenm (IRIS.RECS sppStream)) (SET blum (IRIS.RECS sppStream)) (SET b (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GRGBCURSOR %' (index red green blue redm greenm blum b]) (IRIS.GRGBMASK [LAMBDA (redm greenm blum sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND redm greenm blum) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 87 sppStream) (IRIS.FLUSHG sppStream) (SET redm (IRIS.RECS sppStream)) (SET greenm (IRIS.RECS sppStream)) (SET blum (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GRGBMASK %' (redm greenm blum]) (IRIS.ISOBJ [LAMBDA (obj sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if obj then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 89 sppStream) (IRIS.SENDL obj sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.ISOBJ %' (obj]) (IRIS.ISTAG [LAMBDA (t sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if t then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 90 sppStream) (IRIS.SENDL t sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.ISTAG %' (t]) (IRIS.LINEWIDTH [LAMBDA (n sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if n then (IRIS.GCMD 92 sppStream) (IRIS.SENDS n sppStream) else (IRIS\ERROR %'IRIS.LINEWIDTH %' (n]) (IRIS.LOADMATRIX [LAMBDA (m sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if m then (IRIS.GCMD 93 sppStream) (IRIS.SENDFS m 16 sppStream) else (IRIS\ERROR %'IRIS.LOADMATRIX %' (m]) (IRIS.LOOKAT [LAMBDA (vx vy vz px py pz twist sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND vx vy vz px py pz twist) then (IRIS.GCMD 94 sppStream) (IRIS.SENDF vx sppStream) (IRIS.SENDF vy sppStream) (IRIS.SENDF vz sppStream) (IRIS.SENDF px sppStream) (IRIS.SENDF py sppStream) (IRIS.SENDF pz sppStream) (IRIS.SENDS twist sppStream) else (IRIS\ERROR %'IRIS.LOOKAT %' (vx vy vz px py pz twist]) (IRIS.LSBACKUP [LAMBDA (b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if b then (IRIS.GCMD 95 sppStream) (IRIS.SENDO b sppStream) else (IRIS\ERROR %'IRIS.LSBACKUP %' (b]) (IRIS.MAKEOBJ [LAMBDA (obj sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if obj then (IRIS.GCMD 96 sppStream) (IRIS.SENDL obj sppStream) else (IRIS\ERROR %'IRIS.MAKEOBJ %' (obj]) (IRIS.MAKETAG [LAMBDA (t sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if t then (IRIS.GCMD 97 sppStream) (IRIS.SENDL t sppStream) else (IRIS\ERROR %'IRIS.MAKETAG %' (t]) (IRIS.MAPCOLOR [LAMBDA (color red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND color red green blue) then (IRIS.GCMD 98 sppStream) (IRIS.SENDS color sppStream) (IRIS.SENDS red sppStream) (IRIS.SENDS green sppStream) (IRIS.SENDS blue sppStream) else (IRIS\ERROR %'IRIS.MAPCOLOR %' (color red green blue]) (IRIS.MAPW [LAMBDA (vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 99 sppStream) (IRIS.SENDL vobj sppStream) (IRIS.SENDS sx sppStream) (IRIS.SENDS sy sppStream) (IRIS.FLUSHG sppStream) (SET wx1 (IRIS.RECF sppStream)) (SET wy1 (IRIS.RECF sppStream)) (SET wz1 (IRIS.RECF sppStream)) (SET wx2 (IRIS.RECF sppStream)) (SET wy2 (IRIS.RECF sppStream)) (SET wz2 (IRIS.RECF sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.MAPW %' (vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2]) (IRIS.MAPW2 [LAMBDA (vobj sx sy wx wy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND vobj sx sy wx wy) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 100 sppStream) (IRIS.SENDL vobj sppStream) (IRIS.SENDS sx sppStream) (IRIS.SENDS sy sppStream) (IRIS.FLUSHG sppStream) (SET wx (IRIS.RECF sppStream)) (SET wy (IRIS.RECF sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.MAPW2 %' (vobj sx sy wx wy]) (IRIS.MOVE [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 102 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.MOVE %' (x y z]) (IRIS.MOVE2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 103 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.MOVE2 %' (x y]) (IRIS.MOVE2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 104 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.MOVE2I %' (x y]) (IRIS.MOVEI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 105 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.MOVEI %' (x y z]) (IRIS.MULTIMAP [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 106 sppStream]) (IRIS.MULTMATRIX [LAMBDA (m sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if m then (IRIS.GCMD 107 sppStream) (IRIS.SENDFS m 16 sppStream) else (IRIS\ERROR %'IRIS.MULTMATRIX %' (m]) (IRIS.NOISE [LAMBDA (v delta sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND v delta) then (IRIS.GCMD 108 sppStream) (IRIS.SENDS v sppStream) (IRIS.SENDS delta sppStream) else (IRIS\ERROR %'IRIS.NOISE %' (v delta]) (IRIS.ONEMAP [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 111 sppStream]) (IRIS.ORTHO [LAMBDA (left right bottom top near far sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top near far) then (IRIS.GCMD 112 sppStream) (IRIS.SENDF left sppStream) (IRIS.SENDF right sppStream) (IRIS.SENDF bottom sppStream) (IRIS.SENDF top sppStream) (IRIS.SENDF near sppStream) (IRIS.SENDF far sppStream) else (IRIS\ERROR %'IRIS.ORTHO %' (left right bottom top near far]) (IRIS.ORTHO2 [LAMBDA (left right bottom top sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top) then (IRIS.GCMD 113 sppStream) (IRIS.SENDF left sppStream) (IRIS.SENDF right sppStream) (IRIS.SENDF bottom sppStream) (IRIS.SENDF top sppStream) else (IRIS\ERROR %'IRIS.ORTHO2 %' (left right bottom top]) (IRIS.PERSPECTIVE [LAMBDA (fovy aspect near far sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND fovy aspect near far) then (IRIS.GCMD 114 sppStream) (IRIS.SENDS fovy sppStream) (IRIS.SENDF aspect sppStream) (IRIS.SENDF near sppStream) (IRIS.SENDF far sppStream) else (IRIS\ERROR %'IRIS.PERSPECTIVE %' (fovy aspect near far]) (IRIS.PICK [LAMBDA (numNames buffer sppStream) (* LeL, " 9-Sep-85 04:19") (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND numNames buffer) then (IRIS.GCMD 115 sppStream) (IRIS.SENDSS buffer 0 sppStream) (IRIS.SENDL numNames sppStream) else (IRIS\ERROR %'IRIS.PICK %' (numNames buffer]) (IRIS.PICKSIZE [LAMBDA (deltax deltay sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND deltax deltay) then (IRIS.GCMD 116 sppStream) (IRIS.SENDS deltax sppStream) (IRIS.SENDS deltay sppStream) else (IRIS\ERROR %'IRIS.PICKSIZE %' (deltax deltay]) (IRIS.PNT [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 117 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.PNT %' (x y z]) (IRIS.PNT2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 118 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.PNT2 %' (x y]) (IRIS.PNT2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 119 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.PNT2I %' (x y]) (IRIS.PNTI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 120 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.PNTI %' (x y z]) (IRIS.POLARVIEW [LAMBDA (dist azim inc twist sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dist azim inc twist) then (IRIS.GCMD 121 sppStream) (IRIS.SENDF dist sppStream) (IRIS.SENDS azim sppStream) (IRIS.SENDS inc sppStream) (IRIS.SENDS twist sppStream) else (IRIS\ERROR %'IRIS.POLARVIEW %' (dist azim inc twist]) (IRIS.POLF [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 122 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS parray (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.POLF %' (n parray]) (IRIS.POLF2 [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 123 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS parray (TIMES 2 n) sppStream) else (IRIS\ERROR %'IRIS.POLF2 %' (n parray]) (IRIS.POLF2I [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 124 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDLS parray (TIMES 2 n) sppStream) else (IRIS\ERROR %'IRIS.POLF2I %' (n parray]) (IRIS.POLFI [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 125 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDLS parray (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.POLFI %' (n parray]) (IRIS.POLY [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 126 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS parray (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.POLY %' (n parray]) (IRIS.POLY2 [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 127 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS parray (TIMES 2 n) sppStream) else (IRIS\ERROR %'IRIS.POLY2 %' (n parray]) (IRIS.POLY2I [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 128 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDLS parray (TIMES 2 n) sppStream) else (IRIS\ERROR %'IRIS.POLY2I %' (n parray]) (IRIS.POLYI [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 129 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDLS parray (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.POLYI %' (n parray]) (IRIS.POPATTRIBUTES [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 130 sppStream]) (IRIS.POPMATRIX [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 131 sppStream]) (IRIS.POPVIEWPORT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 132 sppStream]) (IRIS.PUSHATTRIBUTES [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 133 sppStream]) (IRIS.PUSHMATRIX [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 134 sppStream]) (IRIS.PUSHVIEWPORT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 135 sppStream]) (IRIS.QENTER [LAMBDA (qtype val sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND qtype val) then (IRIS.GCMD 137 sppStream) (IRIS.SENDS qtype sppStream) (IRIS.SENDS val sppStream) else (IRIS\ERROR %'IRIS.QENTER %' (qtype val]) (IRIS.QREAD [LAMBDA (data sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if data then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 139 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (SET data (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.QREAD %' (data]) (IRIS.QRESET [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 140 sppStream]) (IRIS.QTEST [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 141 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.READPIXELS [LAMBDA (n colors sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n colors) then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 143 sppStream) (IRIS.SENDS n sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECSS colors sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.READPIXELS %' (n colors]) (IRIS.READRGB [LAMBDA (n red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n red green blue) then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 144 sppStream) (IRIS.SENDS n sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECBS red sppStream) (IRIS.RECBS green sppStream) (IRIS.RECBS blue sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.READRGB %' (n red green blue]) (IRIS.RECT [LAMBDA (x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x1 y1 x2 y2) then (IRIS.GCMD 145 sppStream) (IRIS.SENDF x1 sppStream) (IRIS.SENDF y1 sppStream) (IRIS.SENDF x2 sppStream) (IRIS.SENDF y2 sppStream) else (IRIS\ERROR %'IRIS.RECT %' (x1 y1 x2 y2]) (IRIS.RECTF [LAMBDA (x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x1 y1 x2 y2) then (IRIS.GCMD 146 sppStream) (IRIS.SENDF x1 sppStream) (IRIS.SENDF y1 sppStream) (IRIS.SENDF x2 sppStream) (IRIS.SENDF y2 sppStream) else (IRIS\ERROR %'IRIS.RECTF %' (x1 y1 x2 y2]) (IRIS.RECTFI [LAMBDA (x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x1 y1 x2 y2) then (IRIS.GCMD 147 sppStream) (IRIS.SENDL x1 sppStream) (IRIS.SENDL y1 sppStream) (IRIS.SENDL x2 sppStream) (IRIS.SENDL y2 sppStream) else (IRIS\ERROR %'IRIS.RECTFI %' (x1 y1 x2 y2]) (IRIS.RECTI [LAMBDA (x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x1 y1 x2 y2) then (IRIS.GCMD 148 sppStream) (IRIS.SENDL x1 sppStream) (IRIS.SENDL y1 sppStream) (IRIS.SENDL x2 sppStream) (IRIS.SENDL y2 sppStream) else (IRIS\ERROR %'IRIS.RECTI %' (x1 y1 x2 y2]) (IRIS.RESETLS [LAMBDA (b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if b then (IRIS.GCMD 150 sppStream) (IRIS.SENDO b sppStream) else (IRIS\ERROR %'IRIS.RESETLS %' (b]) (IRIS.RGBCOLOR [LAMBDA (red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND red green blue) then (IRIS.GCMD 151 sppStream) (IRIS.SENDS red sppStream) (IRIS.SENDS green sppStream) (IRIS.SENDS blue sppStream) else (IRIS\ERROR %'IRIS.RGBCOLOR %' (red green blue]) (IRIS.RGBCURSOR [LAMBDA (index red green blue redm greenm blum sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND index red green blue redm greenm blum) then (IRIS.GCMD 152 sppStream) (IRIS.SENDS index sppStream) (IRIS.SENDS red sppStream) (IRIS.SENDS green sppStream) (IRIS.SENDS blue sppStream) (IRIS.SENDS redm sppStream) (IRIS.SENDS greenm sppStream) (IRIS.SENDS blum sppStream) else (IRIS\ERROR %'IRIS.RGBCURSOR %' (index red green blue redm greenm blum]) (IRIS.RGBMODE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 153 sppStream]) (IRIS.RGBWRITEMASK [LAMBDA (red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND red green blue) then (IRIS.GCMD 154 sppStream) (IRIS.SENDS red sppStream) (IRIS.SENDS green sppStream) (IRIS.SENDS blue sppStream) else (IRIS\ERROR %'IRIS.RGBWRITEMASK %' (red green blue]) (IRIS.ROTATE [LAMBDA (a axis sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND a axis) then (IRIS.GCMD 155 sppStream) (IRIS.SENDS a sppStream) (IRIS.SENDB axis sppStream) else (IRIS\ERROR %'IRIS.ROTATE %' (a axis]) (IRIS.SCALE [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 156 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.SCALE %' (x y z]) (IRIS.SCRMASK [LAMBDA (left right bottom top sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top) then (IRIS.GCMD 158 sppStream) (IRIS.SENDS left sppStream) (IRIS.SENDS right sppStream) (IRIS.SENDS bottom sppStream) (IRIS.SENDS top sppStream) else (IRIS\ERROR %'IRIS.SCRMASK %' (left right bottom top]) (IRIS.SELECT [LAMBDA (numnames buffer sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND numnames buffer) then (IRIS.GCMD 159 sppStream) (IRIS.SENDSS numnames 0 sppStream) (IRIS.SENDL buffer sppStream) else (IRIS\ERROR %'IRIS.SELECT %' (numnames buffer]) (IRIS.SETBUTTON [LAMBDA (b value sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND b value) then (IRIS.GCMD 160 sppStream) (IRIS.SENDS b sppStream) (IRIS.SENDO value sppStream) else (IRIS\ERROR %'IRIS.SETBUTTON %' (b value]) (IRIS.SETCURSOR [LAMBDA (index color wtm sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND index color wtm) then (IRIS.GCMD 161 sppStream) (IRIS.SENDS index sppStream) (IRIS.SENDS color sppStream) (IRIS.SENDS wtm sppStream) else (IRIS\ERROR %'IRIS.SETCURSOR %' (index color wtm]) (IRIS.SETDEPTH [LAMBDA (near far sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND near far) then (IRIS.GCMD 162 sppStream) (IRIS.SENDS near sppStream) (IRIS.SENDS far sppStream) else (IRIS\ERROR %'IRIS.SETDEPTH %' (near far]) (IRIS.SETLINESTYLE [LAMBDA (index sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if index then (IRIS.GCMD 163 sppStream) (IRIS.SENDS index sppStream) else (IRIS\ERROR %'IRIS.SETLINESTYLE %' (index]) (IRIS.SETMAP [LAMBDA (mapnum sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if mapnum then (IRIS.GCMD 164 sppStream) (IRIS.SENDS mapnum sppStream) else (IRIS\ERROR %'IRIS.SETMAP %' (mapnum]) (IRIS.SETVALUATOR [LAMBDA (v init min max sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND v init min max) then (IRIS.GCMD 167 sppStream) (IRIS.SENDS v sppStream) (IRIS.SENDS init sppStream) (IRIS.SENDS min sppStream) (IRIS.SENDS max sppStream) else (IRIS\ERROR %'IRIS.SETVALUATOR %' (v init min max]) (IRIS.SINGLEBUFFER [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 168 sppStream]) (IRIS.STRWIDTH [LAMBDA (str sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if str then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 169 sppStream) (IRIS.SENDC str sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.STRWIDTH %' (str]) (IRIS.SWAPBUFFERS [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 170 sppStream]) (IRIS.SWAPINTERVAL [LAMBDA (i sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if i then (IRIS.GCMD 171 sppStream) (IRIS.SENDS i sppStream) else (IRIS\ERROR %'IRIS.SWAPINTERVAL %' (i]) (IRIS.GSYNC [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 172 sppStream]) (IRIS.TIE [LAMBDA (b v1 v2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND b v1 v2) then (IRIS.GCMD 173 sppStream) (IRIS.SENDS b sppStream) (IRIS.SENDS v1 sppStream) (IRIS.SENDS v2 sppStream) else (IRIS\ERROR %'IRIS.TIE %' (b v1 v2]) (IRIS.TRANSLATE [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 175 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.TRANSLATE %' (x y z]) (IRIS.VIEWPORT [LAMBDA (left right bottom top sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top) then (IRIS.GCMD 179 sppStream) (IRIS.SENDS left sppStream) (IRIS.SENDS right sppStream) (IRIS.SENDS bottom sppStream) (IRIS.SENDS top sppStream) else (IRIS\ERROR %'IRIS.VIEWPORT %' (left right bottom top]) (IRIS.WINDOW [LAMBDA (left right bottom top near far sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top near far) then (IRIS.GCMD 180 sppStream) (IRIS.SENDF left sppStream) (IRIS.SENDF right sppStream) (IRIS.SENDF bottom sppStream) (IRIS.SENDF top sppStream) (IRIS.SENDF near sppStream) (IRIS.SENDF far sppStream) else (IRIS\ERROR %'IRIS.WINDOW %' (left right bottom top near far]) (IRIS.WRITEMASK [LAMBDA (wtm sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if wtm then (IRIS.GCMD 181 sppStream) (IRIS.SENDS wtm sppStream) else (IRIS\ERROR %'IRIS.WRITEMASK %' (wtm]) (IRIS.WRITEPIXELS [LAMBDA (n colors sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n colors) then (IRIS.GCMD 182 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDSS colors n sppStream) else (IRIS\ERROR %'IRIS.WRITEPIXELS %' (n colors]) (IRIS.WRITERGB [LAMBDA (n red green blue sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n red green blue) then (IRIS.GCMD 183 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDBS red n sppStream) (IRIS.SENDBS green n sppStream) (IRIS.SENDBS blue n sppStream) else (IRIS\ERROR %'IRIS.WRITERGB %' (n red green blue]) (IRIS.TPON [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 184 sppStream]) (IRIS.TPOFF [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 185 sppStream]) (IRIS.TEXTWRITEMASK [LAMBDA (tmask sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if tmask then (IRIS.GCMD 187 sppStream) (IRIS.SENDS tmask sppStream) else (IRIS\ERROR %'IRIS.TEXTWRITEMASK %' (tmask]) (IRIS.XGEXIT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 188 sppStream]) (IRIS.CLKON [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 189 sppStream]) (IRIS.CLKOFF [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 190 sppStream]) (IRIS.LAMPON [LAMBDA (lamps sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if lamps then (IRIS.GCMD 191 sppStream) (IRIS.SENDB lamps sppStream) else (IRIS\ERROR %'IRIS.LAMPON %' (lamps]) (IRIS.LAMPOFF [LAMBDA (lamps sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if lamps then (IRIS.GCMD 192 sppStream) (IRIS.SENDB lamps sppStream) else (IRIS\ERROR %'IRIS.LAMPOFF %' (lamps]) (IRIS.SETBELL [LAMBDA (arg sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if arg then (IRIS.GCMD 193 sppStream) (IRIS.SENDB arg sppStream) else (IRIS\ERROR %'IRIS.SETBELL %' (arg]) (IRIS.RINGBELL [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 194 sppStream]) (IRIS.TADELAY [LAMBDA (arg1 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if arg1 then (IRIS.GCMD 195 sppStream) (IRIS.SENDS arg1 sppStream) else (IRIS\ERROR %'IRIS.TADELAY %' (arg1]) (IRIS.ARCFS [LAMBDA (x y radius startang endang sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius startang endang) then (IRIS.GCMD 196 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS radius sppStream) (IRIS.SENDS startang sppStream) (IRIS.SENDS endang sppStream) else (IRIS\ERROR %'IRIS.ARCFS %' (x y radius startang endang]) (IRIS.ARCS [LAMBDA (x y radius startang endang sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius startang endang) then (IRIS.GCMD 197 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS radius sppStream) (IRIS.SENDS startang sppStream) (IRIS.SENDS endang sppStream) else (IRIS\ERROR %'IRIS.ARCS %' (x y radius startang endang]) (IRIS.BBOX2S [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND xmin ymin x1 y1 x2 y2) then (IRIS.GCMD 199 sppStream) (IRIS.SENDS xmin sppStream) (IRIS.SENDS ymin sppStream) (IRIS.SENDS x1 sppStream) (IRIS.SENDS y1 sppStream) (IRIS.SENDS x2 sppStream) (IRIS.SENDS y2 sppStream) else (IRIS\ERROR %'IRIS.BBOX2S %' (xmin ymin x1 y1 x2 y2]) (IRIS.BLANKSCREEN [LAMBDA (bool sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if bool then (IRIS.GCMD 200 sppStream) (IRIS.SENDO bool sppStream) else (IRIS\ERROR %'IRIS.BLANKSCREEN %' (bool]) (IRIS.BLKQREAD [LAMBDA (data n sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND data n) then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 202 sppStream) (IRIS.SENDS n sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECSS data sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.BLKQREAD %' (data n]) (IRIS.GETMCOLOR [LAMBDA (color r g b sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND color r g b) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 203 sppStream) (IRIS.SENDS color sppStream) (IRIS.FLUSHG sppStream) (SET r (IRIS.RECS sppStream)) (SET g (IRIS.RECS sppStream)) (SET b (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETMCOLOR %' (color r g b]) (IRIS.CALLFUNC [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 204 sppStream]) (IRIS.CHUNKSIZE [LAMBDA (chunk sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if chunk then (IRIS.GCMD 205 sppStream) (IRIS.SENDL chunk sppStream) else (IRIS\ERROR %'IRIS.CHUNKSIZE %' (chunk]) (IRIS.CIRCFS [LAMBDA (x y radius sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius) then (IRIS.GCMD 206 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS radius sppStream) else (IRIS\ERROR %'IRIS.CIRCFS %' (x y radius]) (IRIS.CIRCS [LAMBDA (x y radius sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y radius) then (IRIS.GCMD 207 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS radius sppStream) else (IRIS\ERROR %'IRIS.CIRCS %' (x y radius]) (IRIS.CMOV2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 208 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.CMOV2S %' (x y]) (IRIS.CMOVS [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 209 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.CMOVS %' (x y z]) (IRIS.COMPACTIFY [LAMBDA (obj sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if obj then (IRIS.GCMD 210 sppStream) (IRIS.SENDL obj sppStream) else (IRIS\ERROR %'IRIS.COMPACTIFY %' (obj]) (IRIS.QDEVICE [LAMBDA (v sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if v then (IRIS.GCMD 211 sppStream) (IRIS.SENDS v sppStream) else (IRIS\ERROR %'IRIS.QDEVICE %' (v]) (IRIS.UNQDEVICE [LAMBDA (v sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if v then (IRIS.GCMD 212 sppStream) (IRIS.SENDS v sppStream) else (IRIS\ERROR %'IRIS.UNQDEVICE %' (v]) (IRIS.CURVEBASIS [LAMBDA (basisid sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if basisid then (IRIS.GCMD 213 sppStream) (IRIS.SENDS basisid sppStream) else (IRIS\ERROR %'IRIS.CURVEBASIS %' (basisid]) (IRIS.CURVEPRECISION [LAMBDA (nsegments sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if nsegments then (IRIS.GCMD 214 sppStream) (IRIS.SENDS nsegments sppStream) else (IRIS\ERROR %'IRIS.CURVEPRECISION %' (nsegments]) (IRIS.CRV [LAMBDA (geom sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if geom then (IRIS.GCMD 215 sppStream) (IRIS.SENDFS geom (TIMES 4 3) sppStream) else (IRIS\ERROR %'IRIS.CRV %' (geom]) (IRIS.GETTP [LAMBDA (left right bottom top sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 216 sppStream) (IRIS.FLUSHG sppStream) (SET left (IRIS.RECS sppStream)) (SET right (IRIS.RECS sppStream)) (SET bottom (IRIS.RECS sppStream)) (SET top (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETTP %' (left right bottom top]) (IRIS.GBEGIN [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 217 sppStream]) (IRIS.TEXTINIT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 218 sppStream]) (IRIS.CRVN [LAMBDA (n geom sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n geom) then (IRIS.GCMD 219 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS geom (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.CRVN %' (n geom]) (IRIS.DEFBASIS [LAMBDA (id matrix sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND id matrix) then (IRIS.GCMD 220 sppStream) (IRIS.SENDS id sppStream) (IRIS.SENDFS matrix 16 sppStream) else (IRIS\ERROR %'IRIS.DEFBASIS %' (id matrix]) (IRIS.DELTAG [LAMBDA (t sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if t then (IRIS.GCMD 221 sppStream) (IRIS.SENDL t sppStream) else (IRIS\ERROR %'IRIS.DELTAG %' (t]) (IRIS.DEPTHCUE [LAMBDA (mode sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if mode then (IRIS.GCMD 222 sppStream) (IRIS.SENDO mode sppStream) else (IRIS\ERROR %'IRIS.DEPTHCUE %' (mode]) (IRIS.DRAW2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 223 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.DRAW2S %' (x y]) (IRIS.DRAWS [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 224 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.DRAWS %' (x y z]) (IRIS.ENDFEEDBACK [LAMBDA (buffer sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if buffer then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 225 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECSS buffer sppStream) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.ENDFEEDBACK %' (buffer]) (IRIS.FEEDBACK [LAMBDA (buffer size sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND buffer size) then (IRIS.GCMD 226 sppStream) (IRIS.SENDSS buffer 0 sppStream) (IRIS.SENDL size sppStream) else (IRIS\ERROR %'IRIS.FEEDBACK %' (buffer size]) (IRIS.GETCPOS [LAMBDA (ix iy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND ix iy) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 227 sppStream) (IRIS.FLUSHG sppStream) (SET ix (IRIS.RECS sppStream)) (SET iy (IRIS.RECS sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETCPOS %' (ix iy]) (IRIS.GETDCM [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 228 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETGPOS [LAMBDA (x y z w sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z w) then (IRIS.ECHOFF sppStream) (IRIS.GCMD 229 sppStream) (IRIS.FLUSHG sppStream) (SET x (IRIS.RECF sppStream)) (SET y (IRIS.RECF sppStream)) (SET z (IRIS.RECF sppStream)) (SET w (IRIS.RECF sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) else (IRIS\ERROR %'IRIS.GETGPOS %' (x y z w]) (IRIS.GETLSREPEAT [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 230 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETMEM [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 231 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETMONITOR [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 232 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETOPENOBJ [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 233 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GETZBUFFER [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 234 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECO sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.GEWRITE [LAMBDA (arg1 arg2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND arg1 arg2) then (IRIS.GCMD 235 sppStream) (IRIS.SENDSS arg1 arg2 sppStream) (IRIS.SENDL arg2 sppStream) else (IRIS\ERROR %'IRIS.GEWRITE %' (arg1 arg2]) (IRIS.INITNAMES [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 236 sppStream]) (IRIS.LOADNAME [LAMBDA (name sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if name then (IRIS.GCMD 237 sppStream) (IRIS.SENDS name sppStream) else (IRIS\ERROR %'IRIS.LOADNAME %' (name]) (IRIS.LSREPEAT [LAMBDA (factor sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if factor then (IRIS.GCMD 238 sppStream) (IRIS.SENDL factor sppStream) else (IRIS\ERROR %'IRIS.LSREPEAT %' (factor]) (IRIS.MOVE2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 239 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.MOVE2S %' (x y]) (IRIS.MOVES [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 240 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.MOVES %' (x y z]) (IRIS.NEWTAG [LAMBDA (newtag oldtag offset sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND newtag oldtag offset) then (IRIS.GCMD 241 sppStream) (IRIS.SENDL newtag sppStream) (IRIS.SENDL oldtag sppStream) (IRIS.SENDL offset sppStream) else (IRIS\ERROR %'IRIS.NEWTAG %' (newtag oldtag offset]) (IRIS.PASSTHROUGH [LAMBDA (token sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if token then (IRIS.GCMD 242 sppStream) (IRIS.SENDS token sppStream) else (IRIS\ERROR %'IRIS.PASSTHROUGH %' (token]) (IRIS.PATCHBASIS [LAMBDA (uid vid sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND uid vid) then (IRIS.GCMD 243 sppStream) (IRIS.SENDL uid sppStream) (IRIS.SENDL vid sppStream) else (IRIS\ERROR %'IRIS.PATCHBASIS %' (uid vid]) (IRIS.PATCHPRECISION [LAMBDA (usegments vsegments sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND usegments vsegments) then (IRIS.GCMD 244 sppStream) (IRIS.SENDL usegments sppStream) (IRIS.SENDL vsegments sppStream) else (IRIS\ERROR %'IRIS.PATCHPRECISION %' (usegments vsegments]) (IRIS.PATCH [LAMBDA (geomx geomy geomz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND geomx geomy geomz) then (IRIS.GCMD 245 sppStream) (IRIS.SENDFS geomx 16 sppStream) (IRIS.SENDFS geomy 16 sppStream) (IRIS.SENDFS geomz 16 sppStream) else (IRIS\ERROR %'IRIS.PATCH %' (geomx geomy geomz]) (IRIS.PCLOS [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 246 sppStream]) (IRIS.PDR [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 247 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.PDR %' (x y z]) (IRIS.PDR2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 248 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.PDR2 %' (x y]) (IRIS.PDRI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 249 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.PDRI %' (x y z]) (IRIS.PDR2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 250 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.PDR2I %' (x y]) (IRIS.PDRS [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 251 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.PDRS %' (x y z]) (IRIS.PDR2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 252 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.PDR2S %' (x y]) (IRIS.POLF2S [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 253 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDSS parray (TIMES 2 n) sppStream) else (IRIS\ERROR %'IRIS.POLF2S %' (n parray]) (IRIS.POLFS [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 254 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDSS parray (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.POLFS %' (n parray]) (IRIS.POLY2S [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 255 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDSS parray (TIMES 2 n) sppStream) else (IRIS\ERROR %'IRIS.POLY2S %' (n parray]) (IRIS.POLYS [LAMBDA (n parray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray) then (IRIS.GCMD 256 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDSS parray (TIMES 3 n) sppStream) else (IRIS\ERROR %'IRIS.POLYS %' (n parray]) (IRIS.PMV [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 257 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.PMV %' (x y z]) (IRIS.PMV2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 258 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.PMV2 %' (x y]) (IRIS.PMVI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 259 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.PMVI %' (x y z]) (IRIS.PMV2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 260 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.PMV2I %' (x y]) (IRIS.PMVS [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 261 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.PMVS %' (x y z]) (IRIS.PMV2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 262 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.PMV2S %' (x y]) (IRIS.PNT2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 263 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.PNT2S %' (x y]) (IRIS.PNTS [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 264 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.PNTS %' (x y z]) (IRIS.POPNAME [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 265 sppStream]) (IRIS.PUSHNAME [LAMBDA (name sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if name then (IRIS.GCMD 266 sppStream) (IRIS.SENDS name sppStream) else (IRIS\ERROR %'IRIS.PUSHNAME %' (name]) (IRIS.RDR [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 267 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) (IRIS.SENDF dz sppStream) else (IRIS\ERROR %'IRIS.RDR %' (dx dy dz]) (IRIS.RDR2 [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 268 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) else (IRIS\ERROR %'IRIS.RDR2 %' (dx dy]) (IRIS.RDRI [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 269 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) (IRIS.SENDL dz sppStream) else (IRIS\ERROR %'IRIS.RDRI %' (dx dy dz]) (IRIS.RDR2I [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 270 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) else (IRIS\ERROR %'IRIS.RDR2I %' (dx dy]) (IRIS.RDRS [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 271 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) (IRIS.SENDS dz sppStream) else (IRIS\ERROR %'IRIS.RDRS %' (dx dy dz]) (IRIS.RDR2S [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 272 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) else (IRIS\ERROR %'IRIS.RDR2S %' (dx dy]) (IRIS.RECTCOPY [LAMBDA (left right bottom top newx newy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND left right bottom top newx newy) then (IRIS.GCMD 273 sppStream) (IRIS.SENDS left sppStream) (IRIS.SENDS right sppStream) (IRIS.SENDS bottom sppStream) (IRIS.SENDS top sppStream) (IRIS.SENDS newx sppStream) (IRIS.SENDS newy sppStream) else (IRIS\ERROR %'IRIS.RECTCOPY %' (left right bottom top newx newy]) (IRIS.RMV [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 274 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) (IRIS.SENDF dz sppStream) else (IRIS\ERROR %'IRIS.RMV %' (dx dy dz]) (IRIS.RMV2 [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 275 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) else (IRIS\ERROR %'IRIS.RMV2 %' (dx dy]) (IRIS.RMVI [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 276 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) (IRIS.SENDL dz sppStream) else (IRIS\ERROR %'IRIS.RMVI %' (dx dy dz]) (IRIS.RMV2I [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 277 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) else (IRIS\ERROR %'IRIS.RMV2I %' (dx dy]) (IRIS.RMVS [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 278 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) (IRIS.SENDS dz sppStream) else (IRIS\ERROR %'IRIS.RMVS %' (dx dy dz]) (IRIS.RMV2S [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 279 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) else (IRIS\ERROR %'IRIS.RMV2S %' (dx dy]) (IRIS.RPDR [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 280 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) (IRIS.SENDF dz sppStream) else (IRIS\ERROR %'IRIS.RPDR %' (dx dy dz]) (IRIS.RPDR2 [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 281 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) else (IRIS\ERROR %'IRIS.RPDR2 %' (dx dy]) (IRIS.RPDRI [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 282 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) (IRIS.SENDL dz sppStream) else (IRIS\ERROR %'IRIS.RPDRI %' (dx dy dz]) (IRIS.RPDR2I [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 283 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) else (IRIS\ERROR %'IRIS.RPDR2I %' (dx dy]) (IRIS.RPDRS [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 284 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) (IRIS.SENDS dz sppStream) else (IRIS\ERROR %'IRIS.RPDRS %' (dx dy dz]) (IRIS.RPDR2S [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 285 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) else (IRIS\ERROR %'IRIS.RPDR2S %' (dx dy]) (IRIS.RPMV [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 286 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) (IRIS.SENDF dz sppStream) else (IRIS\ERROR %'IRIS.RPMV %' (dx dy dz]) (IRIS.RPMV2 [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 287 sppStream) (IRIS.SENDF dx sppStream) (IRIS.SENDF dy sppStream) else (IRIS\ERROR %'IRIS.RPMV2 %' (dx dy]) (IRIS.RPMVI [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 288 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) (IRIS.SENDL dz sppStream) else (IRIS\ERROR %'IRIS.RPMVI %' (dx dy dz]) (IRIS.RPMV2I [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 289 sppStream) (IRIS.SENDL dx sppStream) (IRIS.SENDL dy sppStream) else (IRIS\ERROR %'IRIS.RPMV2I %' (dx dy]) (IRIS.RPMVS [LAMBDA (dx dy dz sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy dz) then (IRIS.GCMD 290 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) (IRIS.SENDS dz sppStream) else (IRIS\ERROR %'IRIS.RPMVS %' (dx dy dz]) (IRIS.RPMV2S [LAMBDA (dx dy sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND dx dy) then (IRIS.GCMD 291 sppStream) (IRIS.SENDS dx sppStream) (IRIS.SENDS dy sppStream) else (IRIS\ERROR %'IRIS.RPMV2S %' (dx dy]) (IRIS.SETDBLIGHTS [LAMBDA (mask sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if mask then (IRIS.GCMD 292 sppStream) (IRIS.SENDL mask sppStream) else (IRIS\ERROR %'IRIS.SETDBLIGHTS %' (mask]) (IRIS.SETMONITOR [LAMBDA (type sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if type then (IRIS.GCMD 293 sppStream) (IRIS.SENDS type sppStream) else (IRIS\ERROR %'IRIS.SETMONITOR %' (type]) (IRIS.SETSHADE [LAMBDA (shade sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if shade then (IRIS.GCMD 294 sppStream) (IRIS.SENDS shade sppStream) else (IRIS\ERROR %'IRIS.SETSHADE %' (shade]) (IRIS.SHADERANGE [LAMBDA (lowindex highindex sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND lowindex highindex) then (IRIS.GCMD 295 sppStream) (IRIS.SENDS lowindex sppStream) (IRIS.SENDS highindex sppStream) else (IRIS\ERROR %'IRIS.SHADERANGE %' (lowindex highindex]) (IRIS.SPCLOS [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 296 sppStream]) (IRIS.SPLF [LAMBDA (n parray iarray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray iarray) then (IRIS.GCMD 297 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS parray (TIMES 3 n) sppStream) (IRIS.SENDSS iarray n sppStream) else (IRIS\ERROR %'IRIS.SPLF %' (n parray iarray]) (IRIS.SPLF2 [LAMBDA (n parray iarray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray iarray) then (IRIS.GCMD 298 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDFS parray (TIMES 2 n) sppStream) (IRIS.SENDSS iarray n sppStream) else (IRIS\ERROR %'IRIS.SPLF2 %' (n parray iarray]) (IRIS.SPLFI [LAMBDA (n parray iarray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray iarray) then (IRIS.GCMD 299 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDLS parray (TIMES 3 n) sppStream) (IRIS.SENDSS iarray n sppStream) else (IRIS\ERROR %'IRIS.SPLFI %' (n parray iarray]) (IRIS.SPLF2I [LAMBDA (n parray iarray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray iarray) then (IRIS.GCMD 300 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDLS parray (TIMES 2 n) sppStream) (IRIS.SENDSS iarray n sppStream) else (IRIS\ERROR %'IRIS.SPLF2I %' (n parray iarray]) (IRIS.SPLFS [LAMBDA (n parray iarray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray iarray) then (IRIS.GCMD 301 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDSS parray (TIMES 3 n) sppStream) (IRIS.SENDSS iarray n sppStream) else (IRIS\ERROR %'IRIS.SPLFS %' (n parray iarray]) (IRIS.SPLF2S [LAMBDA (n parray iarray sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n parray iarray) then (IRIS.GCMD 302 sppStream) (IRIS.SENDL n sppStream) (IRIS.SENDSS parray (TIMES 2 n) sppStream) (IRIS.SENDSS iarray n sppStream) else (IRIS\ERROR %'IRIS.SPLF2S %' (n parray iarray]) (IRIS.XFPT [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 303 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) else (IRIS\ERROR %'IRIS.XFPT %' (x y z]) (IRIS.XFPTI [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 304 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) else (IRIS\ERROR %'IRIS.XFPTI %' (x y z]) (IRIS.XFPTS [LAMBDA (x y z sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z) then (IRIS.GCMD 305 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) else (IRIS\ERROR %'IRIS.XFPTS %' (x y z]) (IRIS.XFPT2 [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 306 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) else (IRIS\ERROR %'IRIS.XFPT2 %' (x y]) (IRIS.XFPT2I [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 307 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) else (IRIS\ERROR %'IRIS.XFPT2I %' (x y]) (IRIS.XFPT2S [LAMBDA (x y sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y) then (IRIS.GCMD 308 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) else (IRIS\ERROR %'IRIS.XFPT2S %' (x y]) (IRIS.XFPT4 [LAMBDA (x y z w sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z w) then (IRIS.GCMD 309 sppStream) (IRIS.SENDF x sppStream) (IRIS.SENDF y sppStream) (IRIS.SENDF z sppStream) (IRIS.SENDF w sppStream) else (IRIS\ERROR %'IRIS.XFPT4 %' (x y z w]) (IRIS.XFPT4I [LAMBDA (x y z w sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z w) then (IRIS.GCMD 310 sppStream) (IRIS.SENDL x sppStream) (IRIS.SENDL y sppStream) (IRIS.SENDL z sppStream) (IRIS.SENDL w sppStream) else (IRIS\ERROR %'IRIS.XFPT4I %' (x y z w]) (IRIS.XFPT4S [LAMBDA (x y z w sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND x y z w) then (IRIS.GCMD 311 sppStream) (IRIS.SENDS x sppStream) (IRIS.SENDS y sppStream) (IRIS.SENDS z sppStream) (IRIS.SENDS w sppStream) else (IRIS\ERROR %'IRIS.XFPT4S %' (x y z w]) (IRIS.ZBUFFER [LAMBDA (bool sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if bool then (IRIS.GCMD 312 sppStream) (IRIS.SENDO bool sppStream) else (IRIS\ERROR %'IRIS.ZBUFFER %' (bool]) (IRIS.CHARST [LAMBDA (arg1 arg2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND arg1 arg2) then (IRIS.GCMD 313 sppStream) (IRIS.SENDBS arg1 arg2 sppStream) (IRIS.SENDL arg2 sppStream) else (IRIS\ERROR %'IRIS.CHARST %' (arg1 arg2]) (IRIS.STRWID [LAMBDA (arg1 arg2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND arg1 arg2) then (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 314 sppStream) (IRIS.SENDBS arg1 arg2 sppStream) (IRIS.SENDL arg2 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval) else (IRIS\ERROR %'IRIS.STRWID %' (arg1 arg2]) (IRIS.DEFPATTERN [LAMBDA (n size mask sppStream) (* LeL, " 9-Sep-85 04:19") (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n size mask) then (IRIS.GCMD 315 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDS size sppStream) (IRIS.SENDSS mask (QUOTIENT (TIMES size size) 16) sppStream) else (IRIS\ERROR %'IRIS.DEFPATTERN %' (n size mask]) (IRIS.GETPATTERN [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (LET (retval) (IRIS.ECHOFF sppStream) (IRIS.GCMD 316 sppStream) (IRIS.FLUSHG sppStream) (SETQ retval (IRIS.RECL sppStream)) (IRIS.RECCR sppStream) (IRIS.ECHOON sppStream) retval]) (IRIS.SETPATTERN [LAMBDA (index sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if index then (IRIS.GCMD 317 sppStream) (IRIS.SENDS index sppStream) else (IRIS\ERROR %'IRIS.SETPATTERN %' (index]) (IRIS.OBJINSERT [LAMBDA (t sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if t then (IRIS.GCMD 318 sppStream) (IRIS.SENDL t sppStream) else (IRIS\ERROR %'IRIS.OBJINSERT %' (t]) (IRIS.OBJDELETE [LAMBDA (tag1 tag2 sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND tag1 tag2) then (IRIS.GCMD 319 sppStream) (IRIS.SENDL tag1 sppStream) (IRIS.SENDL tag2 sppStream) else (IRIS\ERROR %'IRIS.OBJDELETE %' (tag1 tag2]) (IRIS.OBJREPLACE [LAMBDA (t sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if t then (IRIS.GCMD 320 sppStream) (IRIS.SENDL t sppStream) else (IRIS\ERROR %'IRIS.OBJREPLACE %' (t]) (IRIS.ZCLEAR [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 321 sppStream]) (IRIS.CURORIGIN [LAMBDA (n xorigin yorigin sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND n xorigin yorigin) then (IRIS.GCMD 322 sppStream) (IRIS.SENDS n sppStream) (IRIS.SENDS xorigin sppStream) (IRIS.SENDS yorigin sppStream) else (IRIS\ERROR %'IRIS.CURORIGIN %' (n xorigin yorigin]) (IRIS.PAGEWRITEMASK [LAMBDA (arg sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if arg then (IRIS.GCMD 323 sppStream) (IRIS.SENDS arg sppStream) else (IRIS\ERROR %'IRIS.PAGEWRITEMASK %' (arg]) (IRIS.PATCHCURVES [LAMBDA (ucurves vcurves sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if (AND ucurves vcurves) then (IRIS.GCMD 324 sppStream) (IRIS.SENDL ucurves sppStream) (IRIS.SENDL vcurves sppStream) else (IRIS\ERROR %'IRIS.PATCHCURVES %' (ucurves vcurves]) (IRIS.DBTEXT [LAMBDA (str sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (if str then (IRIS.GCMD 325 sppStream) (IRIS.SENDBS str 8 sppStream) else (IRIS\ERROR %'IRIS.DBTEXT %' (str]) (IRIS.LASTONE [LAMBDA (sppStream) (if sppStream then [OR (SPPSTREAM? sppStream) (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] else (SETQ sppStream IRISCONN)) (IRIS.GCMD 326 sppStream]) (IRIS\ERROR [LAMBDA (FNNAME FNARGS) (* ; "Edited 28-Jan-87 18:57 by gbn") (* ;;; "This function breaks whenever an IRIS library function gets a null arg") (ERROR (CONCAT FNNAME ": some input arg is NIL" " ") (APPLY 'CONCAT (for ARG in FNARGS join (LIST " " ARG " = " (EVAL ARG) " "]) ) (PUTPROPS IRISLIB COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5294 150294 (IRIS.XSETSLOWCOM 5304 . 5586) (IRIS.XSETFASTCOM 5588 . 5870) ( IRIS.GVERSION 5872 . 6367) (IRIS.GDOWNLOAD 6369 . 6649) (IRIS.PAGECOLOR 6651 . 7069) (IRIS.TEXTCOLOR 7071 . 7489) (IRIS.TEXTPORT 7491 . 8085) (IRIS.ARC 8087 . 8727) (IRIS.ARCF 8729 . 9371) (IRIS.ARCFI 9373 . 10017) (IRIS.ARCI 10019 . 10662) (IRIS.ATTACHCURSOR 10664 . 11131) (IRIS.BACKBUFFER 11133 . 11538) (IRIS.BBOX2 11540 . 12201) (IRIS.BBOX2I 12203 . 12866) (IRIS.BLINK 12868 . 13509) (IRIS.CALLOBJ 13511 . 13918) (IRIS.CHARSTR 13920 . 14327) (IRIS.CIRC 14329 . 14836) (IRIS.CIRCF 14838 . 15347) ( IRIS.CIRCFI 15349 . 15860) (IRIS.CIRCI 15862 . 16371) (IRIS.CLEAR 16373 . 16650) (IRIS.CLEARHITCODE 16652 . 16936) (IRIS.CLOSEOBJ 16938 . 17218) (IRIS.CMOV 17220 . 17707) (IRIS.CMOV2 17709 . 18154) ( IRIS.CMOV2I 18156 . 18603) (IRIS.CMOVI 18605 . 19094) (IRIS.COLOR 19096 . 19507) (IRIS.CURSOFF 19509 . 19788) (IRIS.CURSON 19790 . 20068) (IRIS.CURVEIT 20070 . 20521) (IRIS.DEFCURSOR 20523 . 20992) ( IRIS.DEFLINESTYLE 20994 . 21457) (IRIS.DEFRASTERFONT 21459 . 22152) (IRIS.DELOBJ 22154 . 22559) ( IRIS.DOUBLEBUFFER 22561 . 22845) (IRIS.DRAW 22847 . 23334) (IRIS.DRAW2 23336 . 23781) (IRIS.DRAW2I 23783 . 24230) (IRIS.DRAWI 24232 . 24721) (IRIS.EDITOBJ 24723 . 25130) (IRIS.ENDPICK 25132 . 25835) ( IRIS.ENDSELECT 25837 . 26544) (IRIS.FINISH 26546 . 26824) (IRIS.FONT 26826 . 27239) (IRIS.FRONTBUFFER 27241 . 27648) (IRIS.GCONFIG 27650 . 27929) (IRIS.GENOBJ 27931 . 28425) (IRIS.GENTAG 28427 . 28921) ( IRIS.GETBUFFER 28923 . 29420) (IRIS.GETBUTTON 29422 . 30109) (IRIS.GETCMMODE 30111 . 30608) ( IRIS.GETCOLOR 30610 . 31106) (IRIS.GETCURSOR 31108 . 31856) (IRIS.GETDEPTH 31858 . 32486) ( IRIS.GETDISPLAYMODE 32488 . 32990) (IRIS.GETFONT 32992 . 33487) (IRIS.GETHEIGHT 33489 . 33986) ( IRIS.GETHITCODE 33988 . 34486) (IRIS.GETLSBACKUP 34488 . 34987) (IRIS.GETLSTYLE 34989 . 35486) ( IRIS.GETLWIDTH 35488 . 35985) (IRIS.GETMAP 35987 . 36481) (IRIS.GETMATRIX 36483 . 37033) ( IRIS.GETPLANES 37035 . 37532) (IRIS.GETRESETLS 37534 . 38032) (IRIS.GETSCRMASK 38034 . 38800) ( IRIS.GETVALUATOR 38802 . 39493) (IRIS.GETVIEWPORT 39495 . 40263) (IRIS.GETWRITEMASK 40265 . 40765) ( IRIS.XGINIT 40767 . 41045) (IRIS.XGRESET 41047 . 41326) (IRIS.GRGBCOLOR 41328 . 42023) ( IRIS.GRGBCURSOR 42025 . 43027) (IRIS.GRGBMASK 43029 . 43730) (IRIS.ISOBJ 43732 . 44419) (IRIS.ISTAG 44421 . 45100) (IRIS.LINEWIDTH 45102 . 45505) (IRIS.LOADMATRIX 45507 . 45916) (IRIS.LOOKAT 45918 . 46625) (IRIS.LSBACKUP 46627 . 47028) (IRIS.MAKEOBJ 47030 . 47437) (IRIS.MAKETAG 47439 . 47838) ( IRIS.MAPCOLOR 47840 . 48431) (IRIS.MAPW 48433 . 49429) (IRIS.MAPW2 49431 . 50194) (IRIS.MOVE 50196 . 50684) (IRIS.MOVE2 50686 . 51132) (IRIS.MOVE2I 51134 . 51582) (IRIS.MOVEI 51584 . 52074) ( IRIS.MULTIMAP 52076 . 52357) (IRIS.MULTMATRIX 52359 . 52769) (IRIS.NOISE 52771 . 53233) (IRIS.ONEMAP 53235 . 53514) (IRIS.ORTHO 53516 . 54214) (IRIS.ORTHO2 54216 . 54808) (IRIS.PERSPECTIVE 54810 . 55408) (IRIS.PICK 55410 . 55963) (IRIS.PICKSIZE 55965 . 56457) (IRIS.PNT 56459 . 56945) (IRIS.PNT2 56947 . 57391) (IRIS.PNT2I 57393 . 57839) (IRIS.PNTI 57841 . 58329) (IRIS.POLARVIEW 58331 . 58921) (IRIS.POLF 58923 . 59420) (IRIS.POLF2 59422 . 59921) (IRIS.POLF2I 59923 . 60424) (IRIS.POLFI 60426 . 60925) ( IRIS.POLY 60927 . 61424) (IRIS.POLY2 61426 . 61925) (IRIS.POLY2I 61927 . 62428) (IRIS.POLYI 62430 . 62929) (IRIS.POPATTRIBUTES 62931 . 63217) (IRIS.POPMATRIX 63219 . 63501) (IRIS.POPVIEWPORT 63503 . 63787) (IRIS.PUSHATTRIBUTES 63789 . 64076) (IRIS.PUSHMATRIX 64078 . 64361) (IRIS.PUSHVIEWPORT 64363 . 64648) (IRIS.QENTER 64650 . 65122) (IRIS.QREAD 65124 . 65821) (IRIS.QRESET 65823 . 66102) (IRIS.QTEST 66104 . 66598) (IRIS.READPIXELS 66600 . 67365) (IRIS.READRGB 67367 . 68240) (IRIS.RECT 68242 . 68790) (IRIS.RECTF 68792 . 69342) (IRIS.RECTFI 69344 . 69896) (IRIS.RECTI 69898 . 70448) (IRIS.RESETLS 70450 . 70850) (IRIS.RGBCOLOR 70852 . 71384) (IRIS.RGBCURSOR 71386 . 72156) (IRIS.RGBMODE 72158 . 72438) ( IRIS.RGBWRITEMASK 72440 . 72980) (IRIS.ROTATE 72982 . 73442) (IRIS.SCALE 73444 . 73934) (IRIS.SCRMASK 73936 . 74530) (IRIS.SELECT 74532 . 75031) (IRIS.SETBUTTON 75033 . 75503) (IRIS.SETCURSOR 75505 . 76043) (IRIS.SETDEPTH 76045 . 76517) (IRIS.SETLINESTYLE 76519 . 76945) (IRIS.SETMAP 76947 . 77365) ( IRIS.SETVALUATOR 77367 . 77941) (IRIS.SINGLEBUFFER 77943 . 78228) (IRIS.STRWIDTH 78230 . 78924) ( IRIS.SWAPBUFFERS 78926 . 79210) (IRIS.SWAPINTERVAL 79212 . 79622) (IRIS.GSYNC 79624 . 79902) (IRIS.TIE 79904 . 80398) (IRIS.TRANSLATE 80400 . 80898) (IRIS.VIEWPORT 80900 . 81496) (IRIS.WINDOW 81498 . 82198) (IRIS.WRITEMASK 82200 . 82612) (IRIS.WRITEPIXELS 82614 . 83095) (IRIS.WRITERGB 83097 . 83682) ( IRIS.TPON 83684 . 83961) (IRIS.TPOFF 83963 . 84241) (IRIS.TEXTWRITEMASK 84243 . 84671) (IRIS.XGEXIT 84673 . 84952) (IRIS.CLKON 84954 . 85232) (IRIS.CLKOFF 85234 . 85513) (IRIS.LAMPON 85515 . 85929) ( IRIS.LAMPOFF 85931 . 86347) (IRIS.SETBELL 86349 . 86757) (IRIS.RINGBELL 86759 . 87040) (IRIS.TADELAY 87042 . 87454) (IRIS.ARCFS 87456 . 88102) (IRIS.ARCS 88104 . 88748) (IRIS.BBOX2S 88750 . 89414) ( IRIS.BLANKSCREEN 89416 . 89836) (IRIS.BLKQREAD 89838 . 90591) (IRIS.GETMCOLOR 90593 . 91313) ( IRIS.CALLFUNC 91315 . 91596) (IRIS.CHUNKSIZE 91598 . 92018) (IRIS.CIRCFS 92020 . 92532) (IRIS.CIRCS 92534 . 93044) (IRIS.CMOV2S 93046 . 93494) (IRIS.CMOVS 93496 . 93986) (IRIS.COMPACTIFY 93988 . 94402) (IRIS.QDEVICE 94404 . 94804) (IRIS.UNQDEVICE 94806 . 95210) (IRIS.CURVEBASIS 95212 . 95642) ( IRIS.CURVEPRECISION 95644 . 96090) (IRIS.CRV 96092 . 96529) (IRIS.GETTP 96531 . 97288) (IRIS.GBEGIN 97290 . 97569) (IRIS.TEXTINIT 97571 . 97852) (IRIS.CRVN 97854 . 98343) (IRIS.DEFBASIS 98345 . 98825) ( IRIS.DELTAG 98827 . 99225) (IRIS.DEPTHCUE 99227 . 99641) (IRIS.DRAW2S 99643 . 100091) (IRIS.DRAWS 100093 . 100583) (IRIS.ENDFEEDBACK 100585 . 101297) (IRIS.FEEDBACK 101299 . 101786) (IRIS.GETCPOS 101788 . 102403) (IRIS.GETDCM 102405 . 102900) (IRIS.GETGPOS 102902 . 103607) (IRIS.GETLSREPEAT 103609 . 104109) (IRIS.GETMEM 104111 . 104606) (IRIS.GETMONITOR 104608 . 105107) (IRIS.GETOPENOBJ 105109 . 105608) (IRIS.GETZBUFFER 105610 . 106109) (IRIS.GEWRITE 106111 . 106591) (IRIS.INITNAMES 106593 . 106875) (IRIS.LOADNAME 106877 . 107291) (IRIS.LSREPEAT 107293 . 107715) (IRIS.MOVE2S 107717 . 108165) (IRIS.MOVES 108167 . 108657) (IRIS.NEWTAG 108659 . 109211) (IRIS.PASSTHROUGH 109213 . 109637) ( IRIS.PATCHBASIS 109639 . 110111) (IRIS.PATCHPRECISION 110113 . 110641) (IRIS.PATCH 110643 . 111193) ( IRIS.PCLOS 111195 . 111473) (IRIS.PDR 111475 . 111961) (IRIS.PDR2 111963 . 112407) (IRIS.PDRI 112409 . 112897) (IRIS.PDR2I 112899 . 113345) (IRIS.PDRS 113347 . 113835) (IRIS.PDR2S 113837 . 114283) ( IRIS.POLF2S 114285 . 114786) (IRIS.POLFS 114788 . 115287) (IRIS.POLY2S 115289 . 115790) (IRIS.POLYS 115792 . 116291) (IRIS.PMV 116293 . 116779) (IRIS.PMV2 116781 . 117225) (IRIS.PMVI 117227 . 117715) ( IRIS.PMV2I 117717 . 118163) (IRIS.PMVS 118165 . 118653) (IRIS.PMV2S 118655 . 119101) (IRIS.PNT2S 119103 . 119549) (IRIS.PNTS 119551 . 120039) (IRIS.POPNAME 120041 . 120321) (IRIS.PUSHNAME 120323 . 120737) (IRIS.RDR 120739 . 121237) (IRIS.RDR2 121239 . 121691) (IRIS.RDRI 121693 . 122193) (IRIS.RDR2I 122195 . 122649) (IRIS.RDRS 122651 . 123151) (IRIS.RDR2S 123153 . 123607) (IRIS.RECTCOPY 123609 . 124317) (IRIS.RMV 124319 . 124817) (IRIS.RMV2 124819 . 125271) (IRIS.RMVI 125273 . 125773) (IRIS.RMV2I 125775 . 126229) (IRIS.RMVS 126231 . 126731) (IRIS.RMV2S 126733 . 127187) (IRIS.RPDR 127189 . 127689) (IRIS.RPDR2 127691 . 128145) (IRIS.RPDRI 128147 . 128649) (IRIS.RPDR2I 128651 . 129107) (IRIS.RPDRS 129109 . 129611) (IRIS.RPDR2S 129613 . 130069) (IRIS.RPMV 130071 . 130571) (IRIS.RPMV2 130573 . 131027 ) (IRIS.RPMVI 131029 . 131531) (IRIS.RPMV2I 131533 . 131989) (IRIS.RPMVS 131991 . 132493) (IRIS.RPMV2S 132495 . 132951) (IRIS.SETDBLIGHTS 132953 . 133373) (IRIS.SETMONITOR 133375 . 133793) (IRIS.SETSHADE 133795 . 134213) (IRIS.SHADERANGE 134215 . 134731) (IRIS.SPCLOS 134733 . 135012) (IRIS.SPLF 135014 . 135578) (IRIS.SPLF2 135580 . 136146) (IRIS.SPLFI 136148 . 136714) (IRIS.SPLF2I 136716 . 137284) ( IRIS.SPLFS 137286 . 137852) (IRIS.SPLF2S 137854 . 138422) (IRIS.XFPT 138424 . 138912) (IRIS.XFPTI 138914 . 139404) (IRIS.XFPTS 139406 . 139896) (IRIS.XFPT2 139898 . 140344) (IRIS.XFPT2I 140346 . 140794) (IRIS.XFPT2S 140796 . 141244) (IRIS.XFPT4 141246 . 141780) (IRIS.XFPT4I 141782 . 142318) ( IRIS.XFPT4S 142320 . 142856) (IRIS.ZBUFFER 142858 . 143270) (IRIS.CHARST 143272 . 143750) (IRIS.STRWID 143752 . 144519) (IRIS.DEFPATTERN 144521 . 145198) (IRIS.GETPATTERN 145200 . 145699) (IRIS.SETPATTERN 145701 . 146123) (IRIS.OBJINSERT 146125 . 146529) (IRIS.OBJDELETE 146531 . 147009) (IRIS.OBJREPLACE 147011 . 147417) (IRIS.ZCLEAR 147419 . 147698) (IRIS.CURORIGIN 147700 . 148246) (IRIS.PAGEWRITEMASK 148248 . 148668) (IRIS.PATCHCURVES 148670 . 149176) (IRIS.DBTEXT 149178 . 149587) (IRIS.LASTONE 149589 . 149869) (IRIS\ERROR 149871 . 150292))))) STOP \ No newline at end of file diff --git a/lispusers/IRISNET b/lispusers/IRISNET new file mode 100644 index 00000000..a670d21f --- /dev/null +++ b/lispusers/IRISNET @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "10-May-88 00:46:44" {ERINYES}MEDLEY>IRISNET.;1 15482 previous date%: " 4-Feb-87 19:47:55" {ERINYES}LYRIC>IRISNET.;1) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IRISNETCOMS) (RPAQQ IRISNETCOMS ([DECLARE%: EVAL@LOAD DONTCOPY (P (LOADCOMP 'LLETHER) (LOADCOMP 'ETHERRECORDS] (FNS IRIS.RESET IRIS.TRACE IRISBOOTPROCESS SENDIRISPACKET IRISFILTER OPEN.IRISCONN IRISBOOTSERVER) (VARS \IRIS.VERBOSE (PRINTSPPDATAFLG T)) (VARS (IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock"))) (GLOBALVARS IRISNSHOSTNUMBER) [INITVARS (IRISNET 146) (IRISBOOTDIRECTORIES '({CORE} {ERIS}gl2>boot>] (CONSTANTS (IRISSOCKET 37) (IRIS.PACKETTYPE 32790) (IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|)) [DECLARE%: EVAL@LOAD DONTCOPY (FILES ETHERRECORDS) (P (LOADCOMP 'LLETHER] [P (ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET EPENCAPSULATION ) OF DATUM] [BLOCKRECORD IRISBASE ((IRISLENGTH WORD) (IRISDESTHOSTO 3 WORD) (IRISSOURCEHOSTO 3 WORD) (IRISTYPE WORD) (IRISEXCHID WORD) (INFOCHAR1 BYTE) (INFOCHAR2 BYTE)) [ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)) (IRISPACKETBASE (LOCF DATUM)) (IRISDESTHOSTBASE (LOCF DATUM] (ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM) ) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)) (IRISSOURCEHOSTBASE (LOCF DATUM] (TYPE? (type? ETHERPACKET DATUM] (MACROS BROADCASTP))) (DECLARE%: EVAL@LOAD DONTCOPY (LOADCOMP 'LLETHER) (LOADCOMP 'ETHERRECORDS) ) (DEFINEQ (IRIS.RESET [LAMBDA NIL (* gbn "24-Jun-85 01:31") (PROG (PROC) (CLOSEF? '{DSK}IRISBOOTFILE) (if (SETQ PROC (FIND.PROCESS IRIS.BOOT.STREAM.NAME)) then (DEL.PROCESS PROC)) (if (SETQ PROC (FIND.PROCESS '|Iris Terminal SPP|)) then (DEL.PROCESS PROC)) (if (SETQ PROC (FIND.PROCESS 'IRISBOOTPROCESS)) then (DEL.PROCESS PROC)) (PROCESS.STATUS.WINDOW (CREATEPOSITION 5 5]) (IRIS.TRACE [LAMBDA NIL (* gbn "25-Feb-86 12:24") (SETQ PRINTSPPDATAFLG NIL) (SETQ XIPIGNORETYPES '(1 TRANS)) (XIPTRACE T]) (IRISBOOTPROCESS [LAMBDA (IRISPACKET) (* gbn "12-Nov-85 23:16") (DECLARE (GLOBALVARS IRISBOOTDIRECTORIES IRISNSADDRESS IRIS.LOCK IRISNET IRISNSHOSTNUMBER)) (COND ((OBTAIN.MONITORLOCK IRIS.LOCK T T) [PROG (DH CHAR NET IRISBOOTFILE INBOOTSTREAM OUTBOOTSTREAM IRISBOOTFILENAME BOOTFILENAME TEMP ) (SETQ DH (fetch (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET)) (SETQ CHAR (fetch (IRISENCAPSULATION INFOCHAR1) of IRISPACKET)) (replace (IRISENCAPSULATION IRISDESTHOST) of IRISPACKET with (SETQ IRISNSHOSTNUMBER (fetch (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET))) (replace (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET with \MY.NSHOSTNUMBER ) [COND (\IRIS.VERBOSE (* inform the user that a boot attempt is being made) (FLASHWINDOW PROMPTWINDOW) (PROMPTPRINT (CONCAT "IRIS boot initiated to: " DH] (* "E" for "reply" to booting and "H" for "hostname" for spp connection) (SETQ NET (fetch (XIP XIPSOURCENET) of IRISPACKET)) (SETQ IRISNSADDRESS (create NSADDRESS NSNET _ IRISNET NSHOSTNUMBER _ IRISNSHOSTNUMBER)) (* this should be using the net from the iris, but it can't be trusted.  SGI doesn't handle turning around packets properly) (COND ((EQ CHAR (CHARCODE C)) (* replace EPSOCKET of IRISPACKET  with 41) (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE E)) (SENDIRISPACKET IRISPACKET) (* just sends back an "E" packet with our host socket  (41) filled in) (SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME)) (SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM)) (SPP.DSTYPE INBOOTSTREAM 108) (* returns a connection which is not  yet established) (BIN INBOOTSTREAM) [SETQ TEMP (CONCAT (PACKC (while (SPP.READP INBOOTSTREAM) collect (BIN INBOOTSTREAM] [SETQ BOOTFILENAME (L-CASE (SUBSTRING TEMP (STRPOS ":*:" TEMP 1 NIL NIL T) (SUB1 (STRPOS (CONCAT (CHARACTER 0)) TEMP] [COND ((STREQUAL BOOTFILENAME (CONSTANT "defaultboot")) (SETQ BOOTFILENAME (CONSTANT "iris"] (* This is a packet specifying the  boot file name,) [SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL IRISBOOTDIRECTORIES)) 'INPUT NIL '((TYPE BINARY] [COND (\IRIS.VERBOSE (* inform the user that a boot attempt is being made) (PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME] (COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL) (FORCEOUTPUT OUTBOOTSTREAM) (CLOSEF IRISBOOTFILE) (PROMPTPRINT "IRIS boot server complete, closing boot file") (CLOSEF INBOOTSTREAM)) ((EQ CHAR (CHARCODE A)) (* replace EPSOCKET of IRISPACKET  with 41) (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE E)) (SENDIRISPACKET IRISPACKET) (* just sends back an "E" packet with our host socket  (41) filled in) (SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME)) (SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM)) (SPP.DSTYPE INBOOTSTREAM 108) (* returns a connection which is not  yet established) (BIN INBOOTSTREAM) (while (SPP.READP INBOOTSTREAM) collect (BIN INBOOTSTREAM)) (SETQ BOOTFILENAME (CONSTANT "iris")) (* This is a packet specifying the  boot file name,) [SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL IRISBOOTDIRECTORIES)) 'INPUT NIL '((TYPE BINARY] [COND (\IRIS.VERBOSE (* inform the user that a boot attempt is being made) (PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME] (COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL) (FORCEOUTPUT OUTBOOTSTREAM) (CLOSEF IRISBOOTFILE) (PROMPTPRINT "IRIS boot server complete, closing boot file") (CLOSEF INBOOTSTREAM)) ((EQ CHAR (CHARCODE H)) (* serv-hostname in SGIspeak) (PRINT "workstation server connection") (* replace EPSOCKET of IRISPACKET  with 41) (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE H)) (SETQ INBOOTSTREAM (SPP.OPEN NIL 37)) (SENDIRISPACKET IRISPACKET)) (T (PRINT "Iris connection") (* replace EPSOCKET of IRISPACKET  with 41) (PRINTOUT PROMPTWINDOW CHAR "RECEIVED") (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE H)) (SETQ INBOOTSTREAM (SPP.OPEN NIL 37)) (SENDIRISPACKET IRISPACKET] (RELEASE.MONITORLOCK IRIS.LOCK]) (SENDIRISPACKET [LAMBDA (IRISPACKET) (* gbn "10-Jun-85 16:05") (* * Sends a raw seething IRIS packet) (COND ((fetch (ETHERPACKET EPTRANSMITTING) of IRISPACKET) 'AlreadyQueued) (T (* (\RCLK (LOCF (fetch  (ETHERPACKET EPTIMESTAMP) of  IRISPACKET)))) (TRANSMIT.ETHERPACKET (fetch (ETHERPACKET EPNETWORK) of IRISPACKET) IRISPACKET]) (IRISFILTER [LAMBDA (IRISPACKET) (* gbn " 3-Jun-85 22:49") (if (AND (EQ (fetch (ETHERPACKET EPTYPE) of IRISPACKET) IRIS.PACKETTYPE) (BROADCASTP IRISPACKET)) then (ADD.PROCESS `(IRISBOOTPROCESS %, IRISPACKET)) T else (* not an iris packet) NIL]) (OPEN.IRISCONN [LAMBDA (NSADDRESS) (* gbn " 7-Jul-85 14:42") (SETQ IRISCONN (SPP.OPEN (OR NSADDRESS IRISNSADDRESS) IRISSOCKET T '|Iris Terminal SPP|]) (IRISBOOTSERVER [LAMBDA (ON?) (* gbn " 7-Jul-85 14:54") (if ON? then (PROMPTPRINT "Enabling IRIS boot server") (\ADD.PACKET.FILTER (FUNCTION IRISFILTER)) else (PROMPTPRINT "Disabling IRIS boot server") (\DEL.PACKET.FILTER (FUNCTION IRISFILTER]) ) (RPAQQ \IRIS.VERBOSE T) (RPAQQ PRINTSPPDATAFLG T) (RPAQ IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRISNSHOSTNUMBER) ) (RPAQ? IRISNET 146) (RPAQ? IRISBOOTDIRECTORIES '({CORE} {ERIS}gl2>boot>)) (DECLARE%: EVAL@COMPILE (RPAQQ IRISSOCKET 37) (RPAQQ IRIS.PACKETTYPE 32790) (RPAQQ IRIS.BOOT.STREAM.NAME |IRIS boot SPP|) (CONSTANTS (IRISSOCKET 37) (IRIS.PACKETTYPE 32790) (IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|)) ) (DECLARE%: EVAL@LOAD DONTCOPY (FILESLOAD ETHERRECORDS) (LOADCOMP 'LLETHER) ) (ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET EPENCAPSULATION) OF DATUM] [BLOCKRECORD IRISBASE ((IRISLENGTH WORD) (IRISDESTHOSTO 3 WORD) (IRISSOURCEHOSTO 3 WORD) (IRISTYPE WORD) (IRISEXCHID WORD) (INFOCHAR1 BYTE) (INFOCHAR2 BYTE)) [ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)) (IRISPACKETBASE (LOCF DATUM)) (IRISDESTHOSTBASE (LOCF DATUM] (ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)) (IRISSOURCEHOSTBASE (LOCF DATUM] (TYPE? (type? ETHERPACKET DATUM))) (DECLARE%: EVAL@COMPILE [PUTPROPS BROADCASTP MACRO ((PACKET) ([LAMBDA (NDB) (AND NDB (APPLY* (fetch NDBBROADCASTP of NDB) PACKET NDB] (fetch EPNETWORK of PACKET] ) (PUTPROPS IRISNET COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3679 13267 (IRIS.RESET 3689 . 4230) (IRIS.TRACE 4232 . 4424) (IRISBOOTPROCESS 4426 . 11586) (SENDIRISPACKET 11588 . 12227) (IRISFILTER 12229 . 12677) (OPEN.IRISCONN 12679 . 12908) ( IRISBOOTSERVER 12910 . 13265))))) STOP \ No newline at end of file diff --git a/lispusers/IRISSTREAM b/lispusers/IRISSTREAM new file mode 100644 index 00000000..fe9bb897 --- /dev/null +++ b/lispusers/IRISSTREAM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 4-Feb-87 19:48:57" {ERIS}NEXT>IRISSTREAM.;10 68566 changes to%: (RECORDS IRISDATA) (FNS OPENIRISSTREAM CLEARIRIS DRAWBITMAP TRYGRAPHER \FONTCREATE.IRIS \OUTCHARFN.IRIS \IRISSTREAMINIT \IRIS.ASSURE.COLOR \LOOKUPRGB BOXSCREEN IRIS.CONS.OBJNO IRISBITMAP FILLPOLYGON INSTALL.OBJFONT \CLOSEF.IRIS R SPPINPUTSTREAM \BACKCOLOR.IRIS \BITBLT.IRIS \BLTSHADE.IRIS \FONTSAVAILABLE.IRIS \LEFTMARGIN.IRIS \RESET.IRIS \PSPLINE.TO.BEZIER.GEOMETRY \SCALE.IRIS \SCALE.SPLINE.BY.DERIVS \STRINGWIDTH.IRIS \TERPRI.IRIS \FONT.IRIS \CREATECHARSET.IRIS \IRISSETFONTBASE \IRISFONTBASE \CHANGECHARSET.IRIS \CHARWIDTH.IRIS \CLIPPINGREGION.IRIS \CLOSEFN.IRIS \COLOR.IRIS \DRAWCIRCLE.IRIS \DRAWCURVE.IRIS \DRAWLINE.IRIS \CONVERTLINESTYLE.IRIS \MOVETO.IRIS \XPOSITION.IRIS \YPOSITION.IRIS \FILLCIRCLE.IRIS \DRAWELLIPSE.IRIS \FILLPOLYGON.IRIS \IRIS.BITBLT \DRAWPOLYGON.IRIS ALIGN) (VARS IRISSTREAMCOMS \BEZIERBASIS.IRIS) previous date%: "16-Jan-87 18:14:11" {ERIS}NEXT>IRISSTREAM.;5) (PRETTYCOMPRINT IRISSTREAMCOMS) (RPAQQ IRISSTREAMCOMS ((FILES SFFONT COLOR IRISLIB IRISIO IRISNET) [ADDVARS (IMAGESTREAMTYPES (IRIS (OPENSTREAM OPENIRISSTREAM) (FONTCREATE \FONTCREATE.IRIS) (FONTSAVAILABLE \FONTSAVAILABLE.IRIS) (CREATECHARSET \CREATECHARSET.IRIS] (GLOBALVARS \IRIS.VERBOSE IRISNSHOSTNUMBER \IRIS.DEBUG \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE \IRIS.VERSION \IRISSTREAM IRISCONN \IV.HIGHOBJNO \IRIS.BITPLANES) (INITVARS (\IRIS.VERBOSE T) (\IRISSTREAMS NIL) (\IRIS.VERSION 'GL2) (IRISFONTDIRECTORIES '{ERIS}SF>) (\CHARSEGMENTS.IRIS 10) (\IRIS.BITPLANES 4) (IRISFONTFAMILIES '(GACHA TIMESROMAN)) (IRISFONTROTATIONS '(0)) (IRISFONTSIZES '(8 10 12 14 18 24)) (\IRIS.DEBUG NIL) (IRISNSHOSTNUMBER "0#4000.12000.41504#0") (\IV.HIGHOBJNO 100000)) (VARS \BEZIERBASIS.IRIS \IRIS.VERBOSE \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE \IRIS.VERSION) (CONSTANTS IRIS.YAXIS IRIS.ZAXIS) (FNS BOXSCREEN CLEARIRIS DRAWBITMAP IRIS.CONS.OBJNO IRISBITMAP INSTALL.OBJFONT OPENIRISSTREAM \CLOSEF.IRIS R SPPINPUTSTREAM TRYGRAPHER \BACKCOLOR.IRIS \BITBLT.IRIS \BLTSHADE.IRIS \FONTCREATE.IRIS \FONTSAVAILABLE.IRIS \LEFTMARGIN.IRIS \RESET.IRIS \LOOKUPRGB \PSPLINE.TO.BEZIER.GEOMETRY \SCALE.IRIS \SCALE.SPLINE.BY.DERIVS \TERPRI.IRIS \FONT.IRIS \CREATECHARSET.IRIS \IRISSETFONTBASE \IRISFONTBASE \CHANGECHARSET.IRIS \CHARWIDTH.IRIS \OUTCHARFN.IRIS \CLIPPINGREGION.IRIS \CLOSEFN.IRIS \COLOR.IRIS \IRIS.ASSURE.COLOR \DRAWCIRCLE.IRIS \DRAWCURVE.IRIS \DRAWLINE.IRIS \CONVERTLINESTYLE.IRIS \IRISSTREAMINIT \MOVETO.IRIS \XPOSITION.IRIS \YPOSITION.IRIS \FILLCIRCLE.IRIS \DRAWELLIPSE.IRIS \FILLPOLYGON.IRIS \IRIS.BITBLT \DRAWPOLYGON.IRIS ALIGN) (* ;;; "test functions") (RECORDS BEZIER IRISDATA IRISSTREAM SPLINE) (CONSTANTS (\ALTLINESTYLE.IRIS 1) (\IRIS.ITALICS.ROTATION -100) (\PRIMARYLINESTLE.IRIS 0) (\IRIS.BOLD.LINEWIDTH 2)) [P (\IRISSTREAMINIT) (SETFONTCLASSCOMPONENT DEFAULTFONT 'IRIS '(GACHA 12] [ADDVARS (DEFAULTPRINTINGHOST (IRIS Iris)) (PRINTERTYPES (IRIS (CANPRINT (IRIS)) (BITMAPFILE (IRISBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] (P (PUTPROP 'Iris 'PRINTERTYPE 'IRIS)) (PROP PRINTERTYPE Iris) (FUNCTIONS WITH.IRIS.ATTR))) (FILESLOAD SFFONT COLOR IRISLIB IRISIO IRISNET) (ADDTOVAR IMAGESTREAMTYPES (IRIS (OPENSTREAM OPENIRISSTREAM) (FONTCREATE \FONTCREATE.IRIS) (FONTSAVAILABLE \FONTSAVAILABLE.IRIS) (CREATECHARSET \CREATECHARSET.IRIS))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IRIS.VERBOSE IRISNSHOSTNUMBER \IRIS.DEBUG \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE \IRIS.VERSION \IRISSTREAM IRISCONN \IV.HIGHOBJNO \IRIS.BITPLANES) ) (RPAQ? \IRIS.VERBOSE T) (RPAQ? \IRISSTREAMS NIL) (RPAQ? \IRIS.VERSION 'GL2) (RPAQ? IRISFONTDIRECTORIES '{ERIS}SF>) (RPAQ? \CHARSEGMENTS.IRIS 10) (RPAQ? \IRIS.BITPLANES 4) (RPAQ? IRISFONTFAMILIES '(GACHA TIMESROMAN)) (RPAQ? IRISFONTROTATIONS '(0)) (RPAQ? IRISFONTSIZES '(8 10 12 14 18 24)) (RPAQ? \IRIS.DEBUG NIL) (RPAQ? IRISNSHOSTNUMBER "0#4000.12000.41504#0") (RPAQ? \IV.HIGHOBJNO 100000) (RPAQQ \BEZIERBASIS.IRIS ((-1.0 3.0 -3.0 1.0) (3.0 -6.0 3.0 0.0) (-3.0 3.0 0.0 0.0) (1.0 0.0 0.0 0.0))) (RPAQQ \IRIS.VERBOSE T) (RPAQQ \BEZIERBASIS.IRIS ((-1.0 3.0 -3.0 1.0) (3.0 -6.0 3.0 0.0) (-3.0 3.0 0.0 0.0) (1.0 0.0 0.0 0.0))) (RPAQQ \IRISCOLORMAPCACHE (((0 0 0) . 0) ((255 255 255) . 7) ((0 255 0) . 2) ((0 0 255) . 4) ((255 0 0) . 1) ((255 255 0) . 3) ((255 0 255) . 5) ((0 255 255) . 6))) (RPAQQ \IRIS.VERSION GL2) (DECLARE%: EVAL@COMPILE (RPAQQ IRIS.YAXIS 89) (RPAQQ IRIS.ZAXIS 90) (CONSTANTS IRIS.YAXIS IRIS.ZAXIS) ) (DEFINEQ (BOXSCREEN [LAMBDA NIL (* gbn " 8-Nov-85 16:56") (* * draw a box around the screen) (DRAWLINE 0 0 (SUB1 SCREENWIDTH) 0 NIL NIL \IRISSTREAM) (DRAWTO (SUB1 SCREENWIDTH) (SUB1 SCREENHEIGHT) NIL NIL \IRISSTREAM) (DRAWTO 0 (SUB1 SCREENHEIGHT) NIL NIL \IRISSTREAM) (DRAWTO 0 0 NIL NIL \IRISSTREAM) (FLUSHOUTPUT IRISCONN]) (CLEARIRIS [LAMBDA (IRIS-CONNECTION IRISSTREAM) (* ; "Edited 2-Feb-87 23:36 by gbn") (OR IRISSTREAM (SETQ IRISSTREAM \IRISSTREAM)) [OR IRIS-CONNECTION (SETQ IRIS-CONNECTION (fetch SPPOUTSTREAM of (fetch IRISDATA of \IRISSTREAM] (IRIS.SINGLEBUFFER IRIS-CONNECTION) (IRIS.GCONFIG IRIS-CONNECTION) (DSPCLIPPINGREGION WHOLESCREEN IRISSTREAM) (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -1000 1000 IRIS-CONNECTION) (DSPCOLOR 'WHITE IRISSTREAM) (IRIS.LINEWIDTH 1 IRIS-CONNECTION) (* ; "IRIS.RESETLS 0 IRISCONN") (* ;  "make the IRIS not reset the line style between curve segments") (IRIS.CURSOFF IRIS-CONNECTION) (IRIS.CLEAR IRIS-CONNECTION) (DSPCOLOR 'BLUE IRISSTREAM) (SELECTQ \IRIS.VERSION (GL2 (IRIS.CURVEPRECISION \CHARSEGMENTS.IRIS IRIS-CONNECTION) (IRIS.DEFBASIS 1 \BEZIERBASIS.IRIS IRIS-CONNECTION) (IRIS.CURVEBASIS 1 IRIS-CONNECTION)) (GL1) (ERROR "Unknown version of IRIS: " \IRIS.VERSION)) (DSPRESET IRISSTREAM) (SPP.FORCEOUTPUT IRIS-CONNECTION]) (DRAWBITMAP [LAMBDA (BITMAP SOURCELEFT SOURCEBOTTOM OUTPUTSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT ) (* ; "Edited 2-Feb-87 23:37 by gbn") (LET ((DESTBOTTOM (OR DESTINATIONBOTTOM (DSPYPOSITION NIL OUTPUTSTREAM))) (DESTLEFT (OR DESTINATIONLEFT (DSPXPOSITION NIL OUTPUTSTREAM))) (WIDTH (OR WIDTH (BITMAPWIDTH BITMAP))) (HEIGHT (OR HEIGHT (BITMAPHEIGHT BITMAP))) (SBOTTOM (OR SOURCEBOTTOM 0)) (SLEFT (OR SOURCELEFT 0)) ROW) [for Y from SOURCEBOTTOM to (IPLUS SOURCEBOTTOM HEIGHT) as YBASE from 0 do (SETQ ROW (IPLUS DESTBOTTOM YBASE)) (* if there is a pixel set on the row, it is better to set the row outside the  loop) (bind (STATE _ 'SKIP0S) START END for X from SLEFT to (IPLUS SLEFT WIDTH) as BASE from 0 do (SELECTQ STATE (SKIP0S (if (IEQP 0 (BITMAPBIT BITMAP X Y)) then (* skipping zeros, found a zero, so do  nothing) NIL else (* start a run.) (SETQ START BASE) (SETQ END BASE) (SETQ STATE 'COLLECT1S))) (COLLECT1S (if (ILESSP END (add END (BITMAPBIT BITMAP X Y))) then (* collecting 1's, found one. The test already incremented END, so do nothing) NIL else (DRAWLINE (IPLUS DESTLEFT START) ROW (IPLUS DESTLEFT END) ROW 1 NIL OUTPUTSTREAM) (SETQ STATE 'SKIP0S))) (SHOULDNT "Unknown state: " STATE)) finally (if (EQ STATE 'COLLECT1S) then (DRAWLINE (IPLUS DESTLEFT START) ROW (IPLUS DESTLEFT END) ROW 1 NIL OUTPUTSTREAM] (MOVETO DESTLEFT DESTBOTTOM OUTPUTSTREAM]) (IRIS.CONS.OBJNO [LAMBDA NIL (* gbn "15-Nov-85 15:41") (add \IV.HIGHOBJNO 1]) (IRISBITMAP [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE) (* gbn "24-Oct-85 16:51") (LET [(IRISSTREAM (OPENIMAGESTREAM '{LPT}Iris.IRIS 'IRIS] (BITBLT BITMAP (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) IRISSTREAM (DSPXPOSITION NIL IRISSTREAM) (DSPYPOSITION NIL IRISSTREAM) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION]) (INSTALL.OBJFONT [LAMBDA (FAMILY CHARSET LOWCHARCODE HIGHESTCHARCODE SCALE IRISSTREAM CSINFO) (* gbn "12-Nov-85 19:17") (* * takes a font in SF format that is already in core, ie, part of the value  of \SPLINEFONTSINCORE, and installs it on the iris connected to STREAM.  Characters in the font which are nil are not downloaded) (* * note that this fn is called by the fontcreate method for the iris, even  when the font has already been downloaded.  This fn looks up in the stream and just returns the old cached info from the  original downloading.) (if \IRIS.DEBUG then (SETQ LOWCHARCODE 97) (SETQ HIGHESTCHARCODE 101) else (SETQ LOWCHARCODE (OR LOWCHARCODE 1)) (SETQ HIGHESTCHARCODE (OR HIGHESTCHARCODE 255))) (PROG ((FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET)) (IRISDATA (fetch IRISDATA of IRISSTREAM)) (MAXHEIGHT 0) SPACEWIDTH OBJ# FONTBASE CHARDESC WIDTHARRAY STREAM) (SETQ STREAM (fetch SPPOUTSTREAM of IRISDATA)) (if (NOT FONTARRAY) then (ERROR "Charset for spline font not in core:" (LIST FAMILY CHARSET))) (if (SETQ FONTBASE (\IRISFONTBASE FAMILY CHARSET IRISDATA)) then (* the font has already been downloaded, just return the cached info) (if \IRIS.DEBUG then (SHOULDNT "font being redefined")) (RETURN FONTBASE) else (SETQ FONTBASE (add (fetch HIFONT# of IRISDATA) 256)) (SETQ WIDTHARRAY (\CREATECSINFOELEMENT))) (if \IRIS.VERBOSE then (PROMPTPRINT "Installing font on IRIS: " FAMILY)) (if (ZEROP (IRIS.ISOBJ 0 STREAM)) then (IRIS.MAKEOBJ 0 STREAM) (IRIS.CURSOFF STREAM) (IRIS.CLOSEOBJ STREAM)) (* character 0 of the font is always defined on the IRIS as the way of telling  if this charset has been downloaded.) (* NOT ANY MORE) [for I from LOWCHARCODE to HIGHESTCHARCODE do (SETQ CHARDESC (ELT FONTARRAY I)) (if CHARDESC then (IRIS.MAKEOBJ (SETQ OBJ# (IPLUS FONTBASE I)) STREAM) (SFDRAW CHARDESC NIL 0 0 SCALE IRISSTREAM) (* The scale is always one when called for the iris, because the printchar  method makes the IRIS scale the character anyway) (IRIS.CLOSEOBJ STREAM) (ALIGN) (* CONSISTENCY CHECK) (if (ZEROP (IRIS.ISOBJ OBJ# STREAM)) then (ERROR ' "(OBJECT FONT CHARACTER IS UNDEFINED DIRECTLY AFTER DEFINING INSIDE INSTALL.OBJFONT)" ) else (PRINTOUT PROMPTWINDOW (CHARACTER I] (IRIS.GFLUSH STREAM) (ALIGN) (\IRISSETFONTBASE FAMILY CHARSET IRISDATA FONTBASE) (SETQ OBJ# (IPLUS FONTBASE (CHARCODE SPACE))) (if (ZEROP (IRIS.ISOBJ OBJ# STREAM)) then (* install a fake space char if there  isn't one) (SETQ SPACEWIDTH (\FGETWIDTH WIDTHARRAY (OR HIGHESTCHARCODE 127))) (IRIS.MAKEOBJ OBJ# STREAM) (MOVETO SPACEWIDTH 0 IRISSTREAM) (IRIS.CLOSEOBJ STREAM) (\FSETWIDTH WIDTHARRAY (CHARCODE SPACE) SPACEWIDTH)) (RETURN (LIST FAMILY FONTBASE WIDTHARRAY MAXHEIGHT]) (OPENIRISSTREAM [LAMBDA (NSHOSTNUMBER OPTIONS) (* ; "Edited 4-Feb-87 19:05 by gbn") (* * opens a stream to an iris workstation) (DECLARE (GLOBALVARS \IRISIMAGEOPS)) (PROG ((IRISDATA (create IRISDATA)) (HOST (OR NSHOSTNUMBER IRISNSHOSTNUMBER)) (IRISSTREAM (OPENSTREAM '{NODIRCORE}IRIS.SCRATCH 'OUTPUT 'NEW 8 'BINARY)) TEMPCONN) (if (NOT HOST) then (ERROR "IRISNSHOSTNUMBER must be supplied")) (if [AND (NOT (EQMEMB 'RECONNECT OPTIONS)) (SPP.OPENP IRISCONN) (OR (NULL HOST) (SELECTQ (TYPENAME HOST) (NSADDRESS (EQUAL (fetch (NSADDRESS NSHOSTNUMBER) of HOST) (fetch (NSADDRESS NSHOSTNUMBER) of (SPP.DESTADDRESS IRISCONN)))) (LISTP (EQUAL HOST (fetch (NSADDRESS NSHOSTNUMBER) of (SPP.DESTADDRESS IRISCONN)))) (LITATOM (EQ 'LPT (LISTGET (UNPACKFILENAME HOST) 'HOST))) (NILL] then (* there is still a stream open to the iris.  Just use that, since one can have at most a single stream open to the iris) (RETURN \IRISSTREAM) else (if [AND (TYPENAMEP HOST 'LITATOM) (EQ 'LPT (LISTGET (UNPACKFILENAME HOST) 'HOST] then (* * This is just a request to hardcopy when there is no open stream) (SETQ HOST NIL)) (if (NOT (SETQ TEMPCONN (OPEN.IRISCONN HOST))) then (ERROR "Iris did not respond to connection attempt" HOST))) (* replace (STREAM USERCLOSEABLE) of  IRISSTREAM with NIL) (STREAMADDPROP IRISSTREAM 'BEFORECLOSE '\CLOSEF.IRIS) (replace (STREAM OUTCHARFN) of IRISSTREAM with (FUNCTION \OUTCHARFN.IRIS)) (replace (IRISSTREAM IMAGEOPS) of IRISSTREAM with \IRISIMAGEOPS) (replace (IRISSTREAM IRISDATA) of IRISSTREAM with IRISDATA) (replace (IRISDATA SPPINSTREAM) of IRISDATA with TEMPCONN) (replace (IRISDATA SPPOUTSTREAM) of IRISDATA with (SPPOUTPUTSTREAM TEMPCONN)) (replace (IRISDATA IRISCOLORMAPCACHE) of IRISDATA with \IRISCOLORMAPCACHE) (* replace (IRISDATA IRISCOLORMAP) of  IRISDATA with (COLORMAPCREATE NIL  \IRIS.BITPLANES)) (replace (IRISDATA IRISCHARSET) of IRISDATA with -1) (replace (IRISDATA IRISPAGE) of IRISDATA with (COPY WHOLESCREEN)) (SETQ IRISCONN (fetch SPPOUTSTREAM of IRISDATA)) (IRIS.GINIT IRISCONN) (CLEARIRIS IRISCONN IRISSTREAM) (RETURN (SETQ \IRISSTREAM IRISSTREAM]) (\CLOSEF.IRIS [LAMBDA (IRISSTREAM) (* gbn "25-Oct-85 17:18") (* * this fn is installed on the stream as a streamprop.  It flushs the output to the stream, but does not close it) (FORCEOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM))) (RETFROM 'CLOSEF NIL]) (R [LAMBDA NIL (* gbn "21-Jun-85 03:57") (OPENIRISSTREAM NIL '(DONTCONNECT]) (SPPINPUTSTREAM [LAMBDA (OUTPUTSTREAM) (* gbn "17-Jun-85 17:40") (PROG ((CON (fetch (STREAM F1) of OUTPUTSTREAM))) (if CON then (RETURN (fetch (SPPCON SPPINPUTSTREAM) of CON]) (TRYGRAPHER [LAMBDA (DONTSETUP?) (* ; "Edited 2-Feb-87 23:43 by gbn") (* ;;; "just a hack to try to draw a grapher graph") (* ;;; "comment") (PROG (G) [SETQ G (LAYOUTSEXPR '(stu (wxy xxx) (xyzzy)) NIL NIL (FONTCREATE 'GACHA 20 NIL NIL 'IRIS] (IF (NOT DONTSETUP?) THEN (IRIS.GRESET) (IRIS.SINGLEBUFFER) (* ; "(IRIS.DOUBLEBUFFER)") (IRIS.GCONFIG) (IRIS.PERSPECTIVE 120 1 -1000 1000) (IRIS.LOOKAT 0 0 30000 0 0 0 0) (IRIS.LINEWIDTH 2) (CLEAR 'BLUE) (IRIS.COLOR 'WHITE)) (DISPLAYGRAPH G \IRISSTREAM) (RETURN]) (\BACKCOLOR.IRIS [LAMBDA (STREAM COLOR) (* ; "Edited 16-Jan-87 13:58 by gbn") (IF COLOR THEN (REPLACE (IRISDATA BACKCOLOR) OF (FETCH IRISDATA OF STREAM) WITH COLOR) ELSE (FETCH (IRISDATA BACKCOLOR) OF (FETCH IRISDATA OF STREAM]) (\BITBLT.IRIS [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* gbn "12-Nov-85 14:35") (* * produces a |3-d| bitmap composed of lines) (if (NOT (EQ (IMAGESTREAMTYPE DESTINATION) 'IRIS)) then (ERROR "Destination not IRIS stream: " DESTINATION)) (DRAWBITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT) (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of \IRISSTREAM]) (\BLTSHADE.IRIS [LAMBDA (TEXTURE IRISSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION ) (* ; "Edited 16-Jan-87 15:00 by gbn") (* ;  "should not affect anything, so do a with attr") (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM)) (SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))) (WITH.IRIS.ATTR (IRIS.POLF2 4 (LIST (CREATEPOSITION DESTINATIONLEFT DESTINATIONBOTTOM) (CREATEPOSITION (IPLUS DESTINATIONLEFT WIDTH) DESTINATIONBOTTOM) (CREATEPOSITION (IPLUS DESTINATIONLEFT WIDTH) (IPLUS DESTINATIONBOTTOM HEIGHT)) (CREATEPOSITION DESTINATIONLEFT (IPLUS DESTINATIONBOTTOM HEIGHT))) SPPOUT) IRISSTREAM SPPOUT :COLOR TEXTURE) (FORCEOUTPUT SPPOUT]) (\FONTCREATE.IRIS [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 2-Feb-87 23:44 by gbn") (* ;;; "This function reads in the spline definition for a font, but does not install it on the iris. The installation is done on a demand basis on the IRIS, charset by charset.") (PROG (WIDTHS (SCALE 1) FONTDESC CSINFO) (* ;; "since a spline font can be any size, we must guarantee that relative sizes are guaranteed, i.e. a 10 point font is twice as big as a 5 point font") (SETQ SCALE 1) (* ;;; "the width arrays, the height, ascent, etc are all scaled") (SETQ FONTDESC (create FONTDESCRIPTOR FONTDEVICE _ 'IRIS FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE ROTATION _ ROTATION)) (* ; "CHECK WHAT FONTSCALE MEANS") (SETQ CSINFO (\GETCHARSETINFO 0 FONTDESC T)) (if (NOT CSINFO) then (RETURN NIL)) (* ;  "this will call the createcharset method for the IRIS") [SETQ SCALE (replace OTHERDEVICEFONTPROPS of FONTDESC with (QUOTIENT (FLOAT SIZE) (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) [for I from 0 to \MAXTHINCHAR DO (\FSETWIDTH WIDTHS I (FIX (TIMES (\FGETWIDTH WIDTHS I) SCALE] (replace \SFHeight of FONTDESC with SIZE) [replace \SFAscent of FONTDESC with (FIX (TIMES SCALE (fetch (CHARSETINFO CHARSETASCENT) of CSINFO] [replace \SFDescent of FONTDESC with (FIX (TIMES SCALE (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] (* ;  "OTHERDEVICEFONTPROPS is used to hide the scale of the font on the iris") (RETURN FONTDESC]) (\FONTSAVAILABLE.IRIS [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* gbn "13-Nov-85 12:06") (* * returns a list of the form (family size face rotation IRIS) for any font  matching the specs. * is used as wildcard.) (DECLARE (GLOBALVARS IRISFONTDIRECTORIES)) (* Normalize face) (LET [(FAMILIES (if (MEMB FAMILY IRISFONTFAMILIES) then FAMILY else NIL)) (SIZES (SELECTQ PSIZE (* IRISFONTSIZES) (PROG1 PSIZE))) [FACES (SELECTQ FACE (* '((MEDIUM REGULAR REGULAR) (MEDIUM ITALIC REGULAR) (BOLD REGULAR REGULAR) (BOLD ITALIC REGULAR))) (PROG1 (LIST (\FONTFACE FACE] (ROTATIONS (SELECTQ ROTATION (* IRISFONTROTATIONS) (PROG1 ROTATION] (for FFAMILY inside FAMILIES join (for SSIZE inside SIZES join (for FFACE in FACES join (for RROTATION inside ROTATIONS collect (LIST FFAMILY SSIZE FFACE RROTATION 'IRIS]) (\LEFTMARGIN.IRIS [LAMBDA (MARGIN STREAM) (* gbn " 8-Nov-85 17:33") (OR 0 (if MARGIN then (replace LEFT of (fetch IRISPAGE OF (fetch IRISDATA of STREAM)) with MARGIN) else (fetch LEFT of (fetch IRISPAGE OF (fetch IRISDATA of STREAM]) (\RESET.IRIS [LAMBDA (IRISSTREAM) (* gbn "13-Nov-85 00:46") (MOVETO (DSPLEFTMARGIN NIL IRISSTREAM) (IDIFFERENCE (fetch TOP of (DSPCLIPPINGREGION NIL IRISSTREAM)) (FONTPROP (DSPFONT NIL IRISSTREAM) 'HEIGHT)) IRISSTREAM]) (\LOOKUPRGB [LAMBDA (RGB IRISDATA) (* ; "Edited 2-Feb-87 20:37 by gbn") (* ;;; "returns the colormap index whose value is RGB. Returns the closest found and caches that value.") (* ;;; "Since the colormap code is so flakey, the iris now relies only on the cache in the stream. Not very efficient.") (LET* ((CACHE (FETCH IRISCOLORMAPCACHE OF IRISDATA)) (INDEX (SASSOC RGB CACHE))) (IF INDEX THEN (CDR INDEX) ELSE (* ;; "didn't find exactly the right index. Now look through the cache. For closeness in the color space, we use cartesian difference of the rgb's.") [SETQ INDEX (CDR (FOR PAIR IN CACHE SMALLEST (CL:FLET [(ABSDIF (X Y) (IABS (IDIFFERENCE X Y] (APPLY #'+ (CL:MAPCAR #'ABSDIF RGB (CAR PAIR] (REPLACE IRISCOLORMAPCACHE OF IRISDATA WITH (CL:ACONS RGB INDEX CACHE)) INDEX]) (\PSPLINE.TO.BEZIER.GEOMETRY [LAMBDA (SPLINE KNOT#) (* gbn " 7-Jul-85 20:49") (* * returns a bezier geometry matrix from the spline for knot KNOT#.  (compare with SF.DERIVS.TO.BEZIER which does the same thing for a SF spline  description)) (* * the derivatives must already be scaled by the Factorials) (* * should not create the BEZIER) (PROG [(BEZ (create BEZIER B0X _ (ELT (fetch SPLINEX of SPLINE) KNOT#) B0Y _ (ELT (fetch SPLINEY of SPLINE) KNOT#] (replace B1X of BEZ with (PLUS (ffetch B0X of BEZ) (QUOTIENT (ELT (ffetch SPLINEDX of SPLINE) KNOT#) 3))) (replace B1Y of BEZ with (PLUS (ffetch B0Y of BEZ) (QUOTIENT (ELT (ffetch SPLINEDY of SPLINE) KNOT#) 3))) (replace B2X of BEZ with (PLUS (ffetch B1X of BEZ) (QUOTIENT (PLUS (ELT (ffetch SPLINEDX of SPLINE) KNOT#) (ELT (ffetch SPLINEDDX of SPLINE) KNOT#)) 3))) (replace B2Y of BEZ with (PLUS (ffetch B1Y of BEZ) (QUOTIENT (PLUS (ELT (ffetch SPLINEDY of SPLINE) KNOT#) (ELT (ffetch SPLINEDDY of SPLINE) KNOT#)) 3))) (replace B3X of BEZ with (PLUS (ffetch B0X of BEZ) (ELT (ffetch SPLINEDX of SPLINE) KNOT#) (ELT (ffetch SPLINEDDX of SPLINE) KNOT#) (ELT (ffetch SPLINEDDDX of SPLINE) KNOT#))) (replace B3Y of BEZ with (PLUS (ffetch B0Y of BEZ) (ELT (fetch SPLINEDY of SPLINE) KNOT#) (ELT (ffetch SPLINEDDY of SPLINE) KNOT#) (ELT (ffetch SPLINEDDDY of SPLINE) KNOT#))) (RETURN BEZ]) (\SCALE.IRIS [LAMBDA (STREAM SCALE) (* gbn "24-Jun-85 18:50") (if (NOT SCALE) then 1 else (ERROR]) (\SCALE.SPLINE.BY.DERIVS [LAMBDA (SPLINE) (* gbn " 8-Jul-85 17:20") (* * For the form used by \PSPLINE.TO.BEZIER.GEOMETRY, the derivs can all be  premultiplied by the factorial coefficients, rather than repeatedly multiplying  them in) (bind (DDX _ (fetch SPLINEDDX of SPLINE)) (DDY _ (fetch SPLINEDDY of SPLINE)) (DDDX _ (fetch SPLINEDDDX of SPLINE)) (DDDY _ (fetch SPLINEDDDY of SPLINE)) for I from 1 to (fetch %#KNOTS of SPLINE) do (SETA DDX I (FQUOTIENT (ELT DDX I) 2.0)) (SETA DDY I (FQUOTIENT (ELT DDY I) 2.0)) (SETA DDDX I (FQUOTIENT (ELT DDDX I) 6.0)) (SETA DDDY I (FQUOTIENT (ELT DDDY I) 6.0]) (\TERPRI.IRIS [LAMBDA (STREAM) (* gbn "12-Nov-85 14:37") (MOVETO (DSPLEFTMARGIN NIL STREAM) (IDIFFERENCE (DSPYPOSITION NIL STREAM) (FONTPROP (DSPFONT NIL STREAM) 'HEIGHT)) STREAM) (if (ILESSP (DSPYPOSITION NIL STREAM) 0) then (DSPRESET STREAM)) (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM]) (\FONT.IRIS [LAMBDA (IRISSTREAM FONTDESC) (* gbn "29-Oct-85 15:25") (if FONTDESC then (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM))) [if [NOT (AND (type? FONTDESCRIPTOR FONTDESC) (EQ 'IRIS (fetch FONTDEVICE of FONTDESC] then (SETQ FONTDESC (\COERCEFONTDESC FONTDESC 'IRIS] (* user supplied a font so install it) (replace (IRISDATA CURRENTFONTDESC) of IRISDATA with FONTDESC) (\CHANGECHARSET.IRIS IRISSTREAM 0) (* this validates the caches for  fontbase, current charset, etc.) FONTDESC) else (fetch CURRENTFONTDESC of (fetch IRISDATA of IRISSTREAM]) (\CREATECHARSET.IRIS [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* ; "Edited 16-Jan-87 16:43 by gbn") (* ;;; "This function reads in the spline definition for a CHARSET but does not install it on the iris. The installation is done on a demand basis on the IRIS, charset by charset.") (PROG ((FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET)) (MAXHEIGHT 1) WIDTHS CSINFO FONTARRAY SCALE FILES) (if (NOT FONTARRAY) then (* ;  "we haven't even read this into core.") (SETQ FILES (DIRECTORY (PACK* IRISFONTDIRECTORIES FAMILY '*.*SF) 'COLLECT)) (* ;; "THIS METHOD OF FINDING THE FILES WILL NEED TO BE UPGRADED IF WE GET SPLINE DEFINITIONS FOR NS CHARACTERS") (if (NOT FILES) then (* ;; "if you can't find the file then just return NIL to createcharset who will either report the error or build a slug charset") (RETURN (if NOSLUG? then (* ;  "if you can't find the file then just return NIL to createcharset who will report the error") NIL else (* ;  "this will guarantee that all the chars in the charset have 0 width") (\BUILDSLUGCSINFO 0 0 0))) else (if \IRIS.VERBOSE then (PROMPTPRINT "Reading the following spline font files: " FILES)) (if \IRIS.DEBUG then (READ.SPLINE.FONT (CAR FILES) FAMILY CHARSET) else (READ.SPLINE.FONT FILES FAMILY CHARSET))) (* ; "now see if it really worked") (if (NOT (SETQ FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET))) then (* ;  "we just lost horribly, so die with an inconsistency") (SHOULDNT "Inside \FONTCREATE.IRIS, some SFFONTS were found, but reading them did not produce an entry in \SPLINEFONTSINCORE" ))) (* ;  "we have the FAMILY/CHARSET entries, now see if there is a font descriptor ready made for this size") (* ;; "since a spline font can be any size, we must guarantee that relative sizes are guaranteed, i.e. a 10 point font is twice as big as a 5 point font") (SETQ CSINFO (create CHARSETINFO)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (bind CHARDESC for I from 1 to \MAXTHINCHAR do (SETQ CHARDESC (ELT FONTARRAY I)) (* ;; "If there is no description for a character, set its width to zero, so that dspprintchar can recognize not to call this character.") (if CHARDESC then (\FSETWIDTH WIDTHS I (fetch XWIDTH of (fetch SF.WIDTH of CHARDESC))) [SETQ MAXHEIGHT (IMAX MAXHEIGHT (fetch YFIDUCIAL of (fetch FIDUCIAL of CHARDESC] else (\FSETWIDTH WIDTHS I 0))) (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (FIX (TIMES 0.7 MAXHEIGHT))) (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (FIX (TIMES 0.3 MAXHEIGHT))) (* ;; "It doesn't look like this scale junk is used anymore. gbn Jan 17/87") [if (SETQ SCALE (fetch OTHERDEVICEFONTPROPS of FONTDESC)) then (* ;; "this fontdescriptor has already build character sets, and has determined its scale. So scale the widths in this character set. For the first character set, this is done in \fontcreate.iris") (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I (FIX (TIMES (\FGETWIDTH WIDTHS I) SCALE] (RETURN CSINFO]) (\IRISSETFONTBASE [LAMBDA (FAMILY CHARSET IRISDATA FONTBASE) (* gbn "18-Oct-85 16:15") (PUTASSOC (CONS FAMILY CHARSET) FONTBASE (fetch FONTSINIRIS of IRISDATA]) (\IRISFONTBASE [LAMBDA (FAMILY CHARSET IRISDATA) (* gbn "18-Oct-85 16:15") (CDR (SASSOC (CONS FAMILY CHARSET) (fetch FONTSINIRIS of IRISDATA]) (\CHANGECHARSET.IRIS [LAMBDA (IRISSTREAM CHARSET) (* gbn "18-Oct-85 16:16") (* * called when a character is about to be printed which is in a different  charset than the current one.) (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM)) CSINFO BASE FONTDESC) (SETQ FONTDESC (fetch CURRENTFONTDESC of IRISDATA)) [replace (IRISDATA IRISWIDTHSCACHE) of IRISDATA with (fetch (CHARSETINFO WIDTHS) of (SETQ CSINFO (\GETCHARSETINFO CHARSET FONTDESC] (SETQ BASE (\IRISFONTBASE (fetch FONTFAMILY of FONTDESC) CHARSET IRISDATA)) (if (NOT BASE) then (* this stream has never seen this charset before so install it on the IRIS.) (INSTALL.OBJFONT (fetch FONTFAMILY of FONTDESC) CHARSET NIL NIL NIL IRISSTREAM CSINFO) (SETQ BASE (\IRISFONTBASE (fetch FONTFAMILY of FONTDESC) CHARSET IRISDATA))) (replace (IRISDATA CURRENTFONTBASE) of IRISDATA with BASE) (replace (IRISDATA IRISCHARSET) of IRISDATA with CHARSET]) (\CHARWIDTH.IRIS [LAMBDA (CHARCODE FONT) (* gbn "18-Oct-85 19:11") (FIX (TIMES (fetch OTHERDEVICEFONTPROPS of FONT) (\FGETCHARWIDTH FONT CHARCODE]) (\OUTCHARFN.IRIS [LAMBDA (IRISSTREAM CHARCODE) (* ; "Edited 2-Feb-87 23:46 by gbn") (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM)) (SPPOUT (fetch SPPOUTSTREAM of IRISDATA)) OBJNO (FONTDESC (fetch CURRENTFONTDESC of IRISDATA)) PUSHEDATTRIBUTES SCALE) (if (NOT FONTDESC) then (* ;  "this is so that the stream can be opened without the expensive font create operation") (SETQ FONTDESC (DSPFONT (FONTCREATE 'GACHA 12 NIL NIL 'IRIS) IRISSTREAM))) (if (NEQ (fetch (IRISDATA IRISCHARSET) of IRISDATA) (\CHARSET CHARCODE)) then (\CHANGECHARSET.IRIS IRISSTREAM (\CHARSET CHARCODE))) (SETQ OBJNO (IPLUS (fetch CURRENTFONTBASE of IRISDATA) CHARCODE)) (COND ((EQ CHARCODE (CHARCODE EOL)) (\TERPRI.IRIS IRISSTREAM)) ((NILL) (* ;  "ZEROP (IRIS.ISOBJ CURRENTFONTBASE SPPOUT)") (* ;; "this character set has not been installed on the IRIS. character zero is defined for every charset that is installed.") (SHOULDNT "\CHANGECHARSET.IRIS has not guaranteed that char 0 is defined. Obj = " OBJNO)) ((ZEROP (\FGETWIDTH (fetch (IRISDATA IRISWIDTHSCACHE) of IRISDATA) (\CHAR8CODE CHARCODE))) (* ;  "the character is not defined. don't call it") NIL) (T (IRIS.PUSHMATRIX SPPOUT) (IRIS.TRANSLATE (DSPXPOSITION NIL IRISSTREAM) (DSPYPOSITION NIL IRISSTREAM) 0 SPPOUT) (IRIS.SCALE (SETQ SCALE (fetch OTHERDEVICEFONTPROPS of FONTDESC)) SCALE SCALE SPPOUT) (if (EQ (CAR (fetch FONTFACE of FONTDESC)) 'BOLD) then (SETQ PUSHEDATTRIBUTES T) (IRIS.PUSHATTRIBUTES SPPOUT) (IRIS.LINEWIDTH \IRIS.BOLD.LINEWIDTH SPPOUT)) (if (EQ (CADR (fetch FONTFACE of FONTDESC)) 'ITALIC) then (* ; "fake italics with a rotation") (IRIS.ROTATE \IRIS.ITALICS.ROTATION IRIS.ZAXIS SPPOUT)) (if PUSHEDATTRIBUTES then (IRIS.POPATTRIBUTES SPPOUT)) (IRIS.CALLOBJ OBJNO SPPOUT) (IRIS.POPMATRIX SPPOUT) (RELMOVETO (FIX (\FGETWIDTH (fetch IRISWIDTHSCACHE of IRISDATA) CHARCODE)) 0 IRISSTREAM) (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM]) (\CLIPPINGREGION.IRIS [LAMBDA (STREAM REGION) (* gbn "30-Jun-85 21:21") (if REGION then (replace IRISCLIPPINGREGION of (fetch IRISDATA of STREAM) with REGION) else (fetch IRISCLIPPINGREGION of (fetch IRISDATA of STREAM]) (\CLOSEFN.IRIS [LAMBDA (STR) (* gbn "12-Nov-85 14:25") (* * (I DONT THINK THAT SGI IMPLEMENTS THE SPP CLOSE PROTOCOL, BUT WE SHOULD  TRY TO CONVINCE THEM)) (FORCEOUTPUT IRISCONN]) (\COLOR.IRIS [LAMBDA (STREAM COLOR) (* gbn " 8-Nov-85 19:25") (if COLOR then (IRIS.COLOR (\IRIS.ASSURE.COLOR COLOR STREAM) (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM))) else (IRIS.GETCOLOR (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM]) (\IRIS.ASSURE.COLOR [LAMBDA (COLOR# IRISSTREAM) (* ; "Edited 31-Jan-87 20:32 by gbn") (PROG (LEVELS) (AND (COND ((NULL COLOR#) NIL) ((FIXP COLOR#) (* ;; "since Sketch and others call fillpolygon with textures, just return a consistent color from a texture") (RETURN (IMOD COLOR# 7))) [(LITATOM COLOR#) (RETURN (COND ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#)) (* ; "recursively look up color number") (\IRIS.ASSURE.COLOR (CDR LEVELS) IRISSTREAM)) (T (ERROR "Unknown color name" COLOR#] ((HLSP COLOR#) (* ; "HLS form convert to RGB") (SETQ LEVELS (HLSTORGB COLOR#))) ((RGBP COLOR#) (* ; "check for RGB or HLS") (SETQ LEVELS COLOR#)) ((AND (LISTP COLOR#) (RGBP (CADR COLOR#))) (* ;  "temporarily, handle the case of being given a texture and a color, by using the color") (RETURN (\IRIS.ASSURE.COLOR (CADR COLOR#) IRISSTREAM))) ((TYPENAMEP COLOR# 'BITMAP) (* ; "just a hack to not blow up") (RETURN (IMOD (for I from 1 to (BITMAPWIDTH COLOR#) sum (BITMAPBIT COLOR# I 1)) 8))) (T (\ILLEGAL.ARG COLOR#))) (RETURN (COND ((\LOOKUPRGB LEVELS (fetch IRISDATA of IRISSTREAM))) (T (ERROR COLOR# "not available in color map"]) (\DRAWCIRCLE.IRIS [LAMBDA (IRISSTREAM X Y RADIUS BRUSH DASHING) (* ; "Edited 16-Jan-87 15:18 by gbn") (LET [(SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of (fetch IRISDATA of IRISSTREAM] (WITH.IRIS.ATTR (IRIS.CIRC X Y RADIUS SPPOUT) SPPOUT IRISSTREAM :COLOR (CADDR BRUSH) :WIDTH (if (NOT (EQP (CADR BRUSH) 1)) then (CADR BRUSH) else NIL) :DASHING DASHING]) (\DRAWCURVE.IRIS [LAMBDA (IRISSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 16-Jan-87 16:00 by gbn") (* ;;; "takes a list of knots. It must build a set of bezier control points for each knot pair.") (LET ((SPPOUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM))) GEOMETRY SPLINE) (WITH.IRIS.ATTR [PROGN [SETQ SPLINE (PARAMETRICSPLINE KNOTS CLOSED (fetch SCRATCHSPLINE of (fetch IRISDATA of IRISSTREAM] (* ;  "convert the list of knots to a parametric spline description.") (\SCALE.SPLINE.BY.DERIVS SPLINE) (* ;  "For each knot in the spline, use the knots and the derivatives to compute bezier control points") (for KNOT# from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) do (SETQ GEOMETRY (\PSPLINE.TO.BEZIER.GEOMETRY SPLINE KNOT#)) (SELECTQ \IRIS.VERSION (GL1 (IRIS.CURVE 10 \BEZIERBASIS.IRIS GEOMETRY SPPOUT)) (GL2 (IRIS.CRV GEOMETRY SPPOUT)) (ERROR "UNKNOWN IRIS VERSION" \IRIS.VERSION] SPPOUT IRISSTREAM :COLOR (CADDR BRUSH) :WIDTH (if (NOT (EQP (CADR BRUSH) 1)) then (CADR BRUSH) else NIL) :DASHING DASHING) (fetch %#KNOTS of SPLINE]) (\DRAWLINE.IRIS [LAMBDA (IRISSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 16-Jan-87 15:22 by gbn") (* ;;; "(check about color and operation) (sets irisx and irisy to x2 and y2 respectively)") (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM)) PUSHEDATTRIBUTES SPPOUT) (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)) (WITH.IRIS.ATTR (PROGN (IRIS.MOVE X1 Y1 (fetch IRISZ of IRISDATA) SPPOUT) (IRIS.DRAW (replace IRISX of IRISDATA with X2) (replace IRISY of IRISDATA with Y2) (fetch IRISZ of IRISDATA) SPPOUT)) IRISSTREAM SPPOUT :COLOR COLOR :WIDTH WIDTH :DASHING DASHING]) (\CONVERTLINESTYLE.IRIS [LAMBDA (DASHING) (* gbn "12-Nov-85 13:54") (* * takes an Interlisp style dashing description  (a list of on then off pixels) and turns it into a 16 bit dashing description,  like the IRIS likes.) (bind (RESULT _ 0) for PIX in DASHING as (FLAG _ 1) by (IDIFFERENCE 1 FLAG) do [SETQ RESULT (LOGOR (LLSH RESULT PIX) (ITIMES FLAG (SUB1 (EXPT 2 PIX] finally (RETURN (LOGAND (SUB1 (EXPT 2 16)) RESULT]) (\IRISSTREAMINIT [LAMBDA NIL (* ; "Edited 31-Jan-87 19:57 by gbn") (* ;;; "installs the definition of the Iris ImageOps") (DECLARE (GLOBALVARS \IRISIMAGEOPS \FACT.IRIS)) (SETQ \IRISIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'IRIS IMCLOSEFN _ (FUNCTION \CLOSEFN.IRIS) IMMOVETO _ (FUNCTION \MOVETO.IRIS) IMXPOSITION _ (FUNCTION \XPOSITION.IRIS) IMYPOSITION _ (FUNCTION \YPOSITION.IRIS) IMFONT _ (FUNCTION \FONT.IRIS) IMFONTCREATE _ (FUNCTION IRIS) IMDRAWLINE _ (FUNCTION \DRAWLINE.IRIS) IMLEFTMARGIN _ (FUNCTION \LEFTMARGIN.IRIS) IMRIGHTMARGIN _ (FUNCTION NILL) IMLINEFEED _ (FUNCTION HELP) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.IRIS) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.IRIS) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.IRIS) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.IRIS) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.IRIS) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.IRIS) IMBLTSHADE _ (FUNCTION \BLTSHADE.IRIS) IMBITBLT _ (FUNCTION \BITBLT.IRIS) IMNEWPAGE _ (FUNCTION NILL) IMSCALE _ (FUNCTION \SCALE.IRIS) IMTERPRI _ (FUNCTION \TERPRI.IRIS) IMTOPMARGIN _ (FUNCTION NILL) IMBOTTOMMARGIN _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION \BACKCOLOR.IRIS) IMCOLOR _ (FUNCTION \COLOR.IRIS) IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.IRIS) IMRESET _ (FUNCTION \RESET.IRIS) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.IRIS) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.IRIS))) (SETQ \FACT.IRIS (ARRAY 4 0 0.0 0)) (SETA \FACT.IRIS 0 1.0) (SETA \FACT.IRIS 1 1.0) (SETA \FACT.IRIS 2 2.0) (SETA \FACT.IRIS 3 6.0) \IRISIMAGEOPS]) (\MOVETO.IRIS [LAMBDA (IRISSTREAM XPOS YPOS) (* gbn "12-Nov-85 14:36") (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM))) (IRIS.MOVE (replace IRISX of IRISDATA with XPOS) (replace IRISY of IRISDATA with YPOS) (fetch IRISZ of IRISDATA) (fetch SPPOUTSTREAM of IRISDATA]) (\XPOSITION.IRIS [LAMBDA (IRISSTREAM XPOS) (* gbn "24-Jun-85 01:17") (* * adjust only the xpos) (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM))) (RETURN (if XPOS then (IRIS.MOVE (replace IRISX of IRISDATA with XPOS) (fetch IRISY of IRISDATA) (fetch IRISZ of IRISDATA) (fetch SPPOUTSTREAM of IRISDATA)) XPOS else (OR (fetch IRISX of IRISDATA) (replace IRISX of IRISDATA with (CAR (IRIS.GETGPOS NIL NIL NIL NIL \IRISSTREAM]) (\YPOSITION.IRIS [LAMBDA (IRISSTREAM YPOS) (* gbn "17-Jun-85 15:05") (* * adjust only the ypos) (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM))) (RETURN (if YPOS then (IRIS.MOVE (fetch IRISX of IRISDATA) (replace IRISY of IRISDATA with YPOS) (fetch IRISZ of IRISDATA) (fetch SPPOUTSTREAM of IRISDATA)) YPOS else (fetch IRISY of IRISDATA]) (\FILLCIRCLE.IRIS [LAMBDA (IRISSTREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 16-Jan-87 15:24 by gbn") (* IRISSTREAM is guaranteed to be an  IRIS stream) (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) (T (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM)) (SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))) (WITH.IRIS.ATTR (IRIS.CIRCF CENTERX CENTERY RADIUS SPPOUT) IRISSTREAM SPPOUT :COLOR TEXTURE]) (\DRAWELLIPSE.IRIS [LAMBDA (IRISSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* gbn "11-Nov-85 19:07") (PROG [(SINOR (COND (ORIENTATION (SIN ORIENTATION)) (T 0.0))) (COSOR (COND (ORIENTATION (COS ORIENTATION)) (T 1.0] (\DRAWCURVE.IRIS IRISSTREAM [LIST (CREATEPOSITION (PLUS CENTERX (FTIMES COSOR SEMIMAJORRADIUS)) (PLUS CENTERY (FTIMES SINOR SEMIMAJORRADIUS))) (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES SINOR SEMIMINORRADIUS )) (PLUS CENTERY (FTIMES COSOR SEMIMINORRADIUS))) (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES COSOR SEMIMAJORRADIUS )) (DIFFERENCE CENTERY (FTIMES SINOR SEMIMAJORRADIUS) )) (CREATEPOSITION (PLUS CENTERX (FTIMES SINOR SEMIMINORRADIUS)) (DIFFERENCE CENTERY (FTIMES COSOR SEMIMINORRADIUS] T BRUSH DASHING) (MOVETO CENTERX CENTERY IRISSTREAM]) (\FILLPOLYGON.IRIS [LAMBDA (IRISSTREAM POINTS TEXTURE CONVEX?) (* gbn "11-Nov-85 19:30") (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM)) COLOR PUSHEDATTRIBUTES SPPOUT) (SETQ COLOR (\IRIS.ASSURE.COLOR TEXTURE IRISSTREAM)) (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)) (if COLOR then (* save the current attributes since this fn is to have no side effects) (SETQ PUSHEDATTRIBUTES T) (IRIS.PUSHATTRIBUTES SPPOUT) (IRIS.COLOR COLOR SPPOUT)) (if (NOT CONVEX?) then (* break the polygon up into convex hunks, then fill each of those.) (for POLY in (TRAPLOOP POINTS) do (IRIS.POLF2 (LENGTH POLY) (for P in POLY collect (LIST (CAR P) (CDR P))) SPPOUT)) else (IRIS.POLF2 (LENGTH POINTS) (for P in POINTS collect (LIST (CAR P) (CDR P))) SPPOUT)) (if PUSHEDATTRIBUTES then (IRIS.POPATTRIBUTES SPPOUT]) (\IRIS.BITBLT [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)(* gbn " 7-Aug-85 23:36") (PROG ((COLOR (DSPCOLOR NIL DESTINATION)) (SPPOUT (fetch SPPOUTSTREAM of (fetch IRISDATA of DESTINATION))) NLONGS) (for Y from DESTINATIONBOTTOM to (IPLUS DESTINATIONBOTTOM HEIGHT) do (IRIS.CMOV2I DESTINATIONLEFT (PLUS DESTINATIONBOTTOM Y) SPPOUT) (* IRIS.WRITEPIXELS WIDTH  (for X from SOURCELEFT to  (IPLUS SOURCELEFT (SUB1 WIDTH))  collect (ITIMES (BITMAPBIT SOURCE X Y)  COLOR)) DESTINATION) (* the current character position determines where a write pixels op happens) (PROGN (* * now do an inline IRIS.WRITEPIXELS) (IRIS.GCMD 182 SPPOUT) (IRIS.SENDS WIDTH SPPOUT) (SETQ NLONGS (FOLDHI WIDTH 2)) (IRIS.SENDL (LLSH NLONGS 1) SPPOUT) (* Send the number of bytes to be sent) (bind ALONG for X from SOURCELEFT to (IPLUS SOURCELEFT (SUB1 WIDTH)) by 2 do (SETQ ALONG (LOGOR (LLSH (ITIMES (BITMAPBIT SOURCE X Y) COLOR) 16) (ITIMES (BITMAPBIT SOURCE (ADD1 X) Y) COLOR))) (COND ((IRIS.DOSYNC (IQUOTIENT X 2)) (IRIS.PUTGCHAR IRIS\AESC SPPOUT))) (IRIS.SENDL ALONG SPPOUT]) (\DRAWPOLYGON.IRIS [LAMBDA (IRISSTREAM POINTS TEXTURE) (* ; "Edited 16-Jan-87 15:33 by gbn") (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM)) COLOR SPPOUT) (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)) (WITH.IRIS.ATTR (IRIS.POLY2 (LENGTH POINTS) POINTS SPPOUT) IRISSTREAM SPPOUT :COLOR TEXTURE]) (ALIGN [LAMBDA (STREAM) (* gbn "17-Jun-85 15:06") (* * this is a dummy to insure that the IRIS has caught up on the output side.  When it returns a value, it has caught up) (IRIS.GETCOLOR (OR STREAM (fetch SPPINSTREAM of (fetch IRISDATA of \IRISSTREAM]) ) (* ;;; "test functions") (DECLARE%: EVAL@COMPILE (RECORD BEZIER ((B0X B0Y B0Z) (B1X B1Y B1Z) (B2X B2Y B2Z) (B3X B3Y B3Z)) B0Z _ 0 B1Z _ 0 B2Z _ 0 B3Z _ 0) (DATATYPE IRISDATA (IRISX IRISY IRISZ SPPOUTSTREAM SPPINSTREAM SCRATCHSPLINE FONTSINIRIS CURRENTFONTDESC HIFONT# CURRENTFONTBASE BACKCOLOR IRISCLIPPINGREGION OBSOLETE-FIELD IRISCOLORMAPCACHE IRISCHARSET IRISWIDTHSCACHE IRISPAGE) FONTSINIRIS _ (LIST NIL) IRISX _ 0 IRISY _ 0 IRISZ _ 0 SCRATCHSPLINE _ (create SPLINE) HIFONT# _ -255) (RECORD IRISSTREAM STREAM (SUBRECORD STREAM) [ACCESSFNS ((IRISDATA (FETCH (STREAM IMAGEDATA) OF DATUM) (REPLACE (STREAM IMAGEDATA) OF DATUM WITH NEWVALUE] (TYPE? (TYPE? IRISDATA OF (FETCH (STREAM IMAGEDATA) OF DATUM)))) (RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY)) ) (/DECLAREDATATYPE 'IRISDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((IRISDATA 0 POINTER) (IRISDATA 2 POINTER) (IRISDATA 4 POINTER) (IRISDATA 6 POINTER) (IRISDATA 8 POINTER) (IRISDATA 10 POINTER) (IRISDATA 12 POINTER) (IRISDATA 14 POINTER) (IRISDATA 16 POINTER) (IRISDATA 18 POINTER) (IRISDATA 20 POINTER) (IRISDATA 22 POINTER) (IRISDATA 24 POINTER) (IRISDATA 26 POINTER) (IRISDATA 28 POINTER) (IRISDATA 30 POINTER) (IRISDATA 32 POINTER)) '34) (DECLARE%: EVAL@COMPILE (RPAQQ \ALTLINESTYLE.IRIS 1) (RPAQQ \IRIS.ITALICS.ROTATION -100) (RPAQQ \PRIMARYLINESTLE.IRIS 0) (RPAQQ \IRIS.BOLD.LINEWIDTH 2) (CONSTANTS (\ALTLINESTYLE.IRIS 1) (\IRIS.ITALICS.ROTATION -100) (\PRIMARYLINESTLE.IRIS 0) (\IRIS.BOLD.LINEWIDTH 2)) ) (\IRISSTREAMINIT) (SETFONTCLASSCOMPONENT DEFAULTFONT 'IRIS '(GACHA 12)) (ADDTOVAR DEFAULTPRINTINGHOST (IRIS Iris)) (ADDTOVAR PRINTERTYPES (IRIS (CANPRINT (IRIS)) (BITMAPFILE (IRISBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (PUTPROP 'Iris 'PRINTERTYPE 'IRIS) (PUTPROPS Iris PRINTERTYPE IRIS) (DEFMACRO WITH.IRIS.ATTR (FORM SPPOUT IRISSTREAM &KEY (COLOR NIL COLORSET) (WIDTH NIL WIDTHSET) (DASHING NIL DASHINGSET)) `(LET [PUSHED ., [if COLORSET then `((ECOLOR %, COLOR] ., [if WIDTHSET then `((EWIDTH %, WIDTH] ., (if DASHINGSET then `((EDASHING %, DASHING] ., [if COLORSET then `((SETQ ECOLOR (AND ECOLOR (\IRIS.ASSURE.COLOR ECOLOR IRISSTREAM] ., [if DASHINGSET then `((SETQ EDASHING (AND EDASHING (\CONVERTLINESTYLE.IRIS EDASHING] [IF [OR ., (if COLORSET then '(ECOLOR)) ., (if WIDTHSET then '(EWIDTH)) ., (if DASHINGSET then '(EDASHING] THEN (SETQ PUSHED T) (IRIS.PUSHATTRIBUTES %, SPPOUT) ., [IF COLORSET THEN `((IF ECOLOR THEN (IRIS.COLOR ECOLOR %, SPPOUT] ., [IF WIDTHSET THEN `((IF EWIDTH THEN (SELECTQ \IRIS.VERSION (GL2 (IRIS.LINEWIDTH EWIDTH %, SPPOUT)) (GL1 (if (IGREATERP EWIDTH 2) then NIL else (IRIS.LINEWIDTH 2 %, SPPOUT))) (ERROR "UNKNOWN VERSION" \IRIS.VERSION] ., (IF DASHINGSET THEN `((IF EDASHING THEN (IRIS.DEFLINESTYLE \ALTLINESTYLE.IRIS EDASHING %, SPPOUT) (IRIS.SETLINESTYLE \ALTLINESTYLE.IRIS SPPOUT) (IRIS.RESETLS 0 SPPOUT] %, FORM (IF PUSHED THEN (IRIS.POPATTRIBUTES %, SPPOUT)))) (DECLARE%: DONTCOPY (FILEMAP (NIL (6112 63745 (BOXSCREEN 6122 . 6588) (CLEARIRIS 6590 . 7831) (DRAWBITMAP 7833 . 10506) ( IRIS.CONS.OBJNO 10508 . 10654) (IRISBITMAP 10656 . 11185) (INSTALL.OBJFONT 11187 . 15363) ( OPENIRISSTREAM 15365 . 18920) (\CLOSEF.IRIS 18922 . 19306) (R 19308 . 19453) (SPPINPUTSTREAM 19455 . 19732) (TRYGRAPHER 19734 . 20565) (\BACKCOLOR.IRIS 20567 . 20911) (\BITBLT.IRIS 20913 . 21651) ( \BLTSHADE.IRIS 21653 . 23041) (\FONTCREATE.IRIS 23043 . 25581) (\FONTSAVAILABLE.IRIS 25583 . 26989) ( \LEFTMARGIN.IRIS 26991 . 27367) (\RESET.IRIS 27369 . 27717) (\LOOKUPRGB 27719 . 28896) ( \PSPLINE.TO.BEZIER.GEOMETRY 28898 . 32164) (\SCALE.IRIS 32166 . 32344) (\SCALE.SPLINE.BY.DERIVS 32346 . 33307) (\TERPRI.IRIS 33309 . 33797) (\FONT.IRIS 33799 . 34751) (\CREATECHARSET.IRIS 34753 . 39537) (\IRISSETFONTBASE 39539 . 39763) (\IRISFONTBASE 39765 . 39974) (\CHANGECHARSET.IRIS 39976 . 41436) ( \CHARWIDTH.IRIS 41438 . 41662) (\OUTCHARFN.IRIS 41664 . 44891) (\CLIPPINGREGION.IRIS 44893 . 45228) ( \CLOSEFN.IRIS 45230 . 45512) (\COLOR.IRIS 45514 . 45895) (\IRIS.ASSURE.COLOR 45897 . 47915) ( \DRAWCIRCLE.IRIS 47917 . 48467) (\DRAWCURVE.IRIS 48469 . 50364) (\DRAWLINE.IRIS 50366 . 51344) ( \CONVERTLINESTYLE.IRIS 51346 . 51981) (\IRISSTREAMINIT 51983 . 54492) (\MOVETO.IRIS 54494 . 54911) ( \XPOSITION.IRIS 54913 . 55773) (\YPOSITION.IRIS 55775 . 56436) (\FILLCIRCLE.IRIS 56438 . 57173) ( \DRAWELLIPSE.IRIS 57175 . 59099) (\FILLPOLYGON.IRIS 59101 . 60607) (\IRIS.BITBLT 60609 . 62926) ( \DRAWPOLYGON.IRIS 62928 . 63373) (ALIGN 63375 . 63743))))) STOP \ No newline at end of file diff --git a/lispusers/IRISVIEW b/lispusers/IRISVIEW new file mode 100644 index 00000000..1c5ffd1f --- /dev/null +++ b/lispusers/IRISVIEW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED " 4-Feb-87 19:32:44" {ERIS}NEXT>IRISVIEW.;18 65298 changes to%: (VARS IRISVIEWCOMS) (FNS IV.SET.CURRENT.SCENE IV.SCENE.SETUP IV.INIT IV.VIEW.CHANGED IRIS.DEGREES IV.ENSURE.SCENE IV.REDEFINE.SCENE IV.DOUBLEBUFFER IV.AXES IV.NEWSTREAM IV.BACKGROUND IV.DSPCOLOR IV.RIGHT IV.UP IV.TOWARD IV.PHOME.AUX IV.PHOME IV.2D.HOME) (VARIABLES *IV-COMMANDS-MENUDESC* *IV-FILLINS-MENUDESC* *IV-POSITIONING-MENU-DESC* *IV-MENUDESC*) previous date%: "27-Jan-87 01:16:23" {ERIS}NEXT>IRISVIEW.;10) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IRISVIEWCOMS) (RPAQQ IRISVIEWCOMS [(FILES IRISCONSTANTS COLOROBJ) (GLOBALVARS IV.CURRENT.SCENE IV.SCENES IV.SCENES.MENU IV.VIEW.MENU IV.PROMPTWINDOW AXES.SCENE SKULL.SCENE \IV.DRAW.AXES iV.BACKGROUND IV.MODE IV.THETA IV.DXLATE) (INITVARS (IV.SCENES NIL) (IV.CURRENT.SCENE) (IV.SCENES.MENU) (IV.VIEW.MENU)) (BITMAPS IV.LEFT IV.POS IV.RIGHT IV.RIGHT.HIGHLIGHT IV.DOWN IV.UP IV.UP.HIGHLIGHT BACKGROUNDBITMAP IV.ROTX IV.ROTX.HIGHLIGHT IV.ROTY IV.ROTY.HIGHLIGHT IV.ROTZ IV.ROTZ.HIGHLIGHT IV.ROTATE IV.DELTA.LABEL IV.THETA.LABEL IV.TOWARD IV.TOWARD.HIGHLIGHT IV.AWAY) (* ; "fns for co-ordinating scenes") (FNS IV.PROOF.SCENE IV.ENSURE.SCENE IV.NEW.SCENE.FROM.USER IV.REDEFINE.SCENE IV.CHOOSE.SCENE IV.BUILD.SCENES.MENU IV.FORGET.SCENE IV.DRAW.SCENE IV.SET.CURRENT.SCENE IV.SCENE.SETUP) (FNS DRAW.AXES F IV.CLEARIRIS IV.DOWN IV.GETINPUT IV.READ IV.HOME IV.2D.HOME IV.PHOME IV.PHOME.AUX IV.VIEW IV.LEFT IV.RIGHT IV.ROTX IV.DOUBLEBUFFER IV.ROTY IV.ROTZ IV.SWAPBUFFERS IV.UP IV.THETA IV.AXES IV.BACKGROUND IV.TOWARD IV.AWAY IV.DSPCOLOR IV.DELTA IV.VIEW.CHANGED IV.NEWSTREAM IV.PROMPTPRINT IV.PROOF.SKETCH IV.INIT \CLEAR.IRIS IRIS.DEGREES) (FNS IV.ITEMMAPFN IV.DISPLAY.FMITEM) (RECORDS IRISSCENE IVPOS) (VARS HANDWIDTH IRIS.XAXIS IRIS.ZAXIS IV.DXLATE IV.MODE IV.OBJPT IV.THETA IV.TRACE.FNS IV.TWIST IV.VIEWPT LASTIV.OBJPT LASTIV.VIEWPT (\IV.DRAW.AXES) (\IV.BACKGROUND)) (P (IV.SCENE.SETUP) (IV.BUILD.SCENES.MENU)) (FNS SKULLO) (* ;; "The order of these variables is important.") (VARIABLES *IV-SCENES-MENUDESC* *IV-FILLINS-MENUDESC* *IV-COMMANDS-MENUDESC* *IV-POSITIONING-MENU-DESC* *IV-MENUDESC*) (PROP FILETYPE IRISVIEW) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA IV.PROMPTPRINT]) (FILESLOAD IRISCONSTANTS COLOROBJ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IV.CURRENT.SCENE IV.SCENES IV.SCENES.MENU IV.VIEW.MENU IV.PROMPTWINDOW AXES.SCENE SKULL.SCENE \IV.DRAW.AXES iV.BACKGROUND IV.MODE IV.THETA IV.DXLATE) ) (RPAQ? IV.SCENES NIL) (RPAQ? IV.CURRENT.SCENE ) (RPAQ? IV.SCENES.MENU ) (RPAQ? IV.VIEW.MENU ) (RPAQQ IV.LEFT #*(48 24)@@@L@@@@@@@@@@ACH@@@@@@@@@A@F@@@@@@@@@@HAH@@@@@@@@@F@F@@@@@@@@@ALAH@@@@@@@@@B@L@@@@@GOOOO@GH@@@@H@@@@@@F@@@@H@@@@@@ACO@@H@@@@@@@N@@@GOOO@@@@B@@@@@D@@@@@B@@@@@H@@@@@B@@@@@H@@@@@B@@@@@GOH@@@B@@@@@B@@@@@B@@@@@D@@@@@B@@@@@D@@@@@B@@@@@CON@@@B@@@@@A@@@@@B@@@@@B@@@@AN@@@@@B@@@@NAH@@@@AOOOO@@G@@ ) (RPAQQ IV.POS (275 . 200)) (RPAQQ IV.RIGHT #*(48 24)@@@@@@@@C@@@@@@@@@@ALH@@@@@@@@@F@H@@@@@@@@AHA@@@@@@@@@F@F@@@@@@@@AHCH@@@@@@@@C@D@@@@@@@@AN@OOOON@@@@F@@@@@@A@@OLH@@@@@@A@@@G@@@@@@@A@@@D@@@@OOON@@@D@@@@@B@@@@@D@@@@@A@@@@@D@@@@@A@@@@@D@@@AON@@@@@D@@@@@D@@@@@D@@@@@B@@@@@D@@@@@B@@@@@D@@@GOL@@@@@D@@@@@H@@@@@GH@@@@D@@@@AHG@@@@D@@@@N@@OOOOH@@ ) (RPAQQ IV.RIGHT.HIGHLIGHT #*(48 24)@@@@@@@@C@@@@@@@@@@AOH@@@@@@@@@GOH@@@@@@@@AOO@@@@@@@@@GON@@@@@@@@AOOH@@@@@@@@GOL@@@@@@@@AOOOOOON@@@@GOOOOOOO@@OLOOOOOOOO@@@GOOOOOOOO@@@GOOOOOOON@@@GOOOOON@@@@@GOOOOOO@@@@@GOOOOOO@@@@@GOOOOON@@@@@GOOOOOL@@@@@GOOOOON@@@@@GOOOOON@@@@@GOOOOOL@@@@@GOOOOOH@@@@@GOOOOOL@@@@AHGOOOOL@@@@N@@OOOOH@@ ) (RPAQQ IV.DOWN #*(24 48)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@A@@@@D@@A@@@@D@@A@@@@D@@B@@@@D@@B@@@@GOOL@@@@B@@D@@@@B@@D@@@@D@@D@@@@H@@B@@@@H@@B@@@A@@@B@@@A@@@A@@@A@@@A@@@C@@@A@@@F@@@A@@@D@@@A@@@H@@@A@@@H@@@A@@A@@@@A@@AA@@@A@@BC@@AA@@BE@@AA@@DE@AAA@@DEAAAA@@DIAAAA@@HIAAAA@@IAAAAA@@FAAAAI@@@AAAIF@@@AAIF@@@@AAF@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@@N@@@@@ ) (RPAQQ IV.UP #*(24 48)@@N@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AAF@@@@@AAIF@@@@AAAIF@@FAAAAI@@IAAAAA@@HIAAAA@@DIAAAA@@DEAAAA@@DE@AAA@@BE@@AA@@BC@@AA@@AA@@@A@@A@@@@A@@@H@@@A@@@H@@@A@@@D@@@A@@@F@@@A@@@C@@@A@@@A@@@A@@@A@@@A@@@A@@@B@@@@H@@B@@@@H@@B@@@@D@@D@@@@B@@D@@@@B@@D@@@@GOOL@@@@D@@B@@@@D@@B@@@@D@@A@@@@D@@A@@@@D@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.UP.HIGHLIGHT #*(24 48)@@N@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AOF@@@@@AOOF@@@@AOOOF@@FAOOOO@@OAOOOO@@OIOOOO@@GIOOOO@@GMOOOO@@GMOOOO@@CMOOOO@@COOOOO@@AOOOOO@@AOOOOO@@@OOOOO@@@OOOOO@@@GOOOO@@@GOOOO@@@COOOO@@@AOOOO@@@AOOOO@@@AOOON@@@@OOON@@@@OOON@@@@GOOL@@@@COOL@@@@COOL@@@@GOOL@@@@D@@B@@@@D@@B@@@@D@@A@@@@D@@A@@@@D@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ BACKGROUNDBITMAP #*(12 15)@@@@CKN@EOB@IFH@JFH@BF@@BD@@@D@@@D@@@B@@@CF@@CN@@ON@AON@@@@@) (RPAQQ IV.ROTX #*(28 47)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@AHL@@@@@B@B@@@@@D@A@@@@@D@A@@@@@H@@H@@@@H@@H@@@A@@@D@@@A@@@D@@@A@@@D@@@A@@@D@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@BB@@@B@@CBF@@B@@AJL@@B@@@OH@@A@@@F@@@A@@@D@@@A@@@D@@@A@@@D@@@@H@@H@@@@H@@H@@@@D@A@@@@@D@A@@@@@B@B@@@@@AHL@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.ROTX.HIGHLIGHT #*(28 47)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@AOL@@@@@CON@@@@@GOO@@@@@GOO@@@@@OOOH@@@@OOOH@@@AOOOL@@@AOOOL@@@AOOOL@@@AOOOL@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOONF@@COOONL@@COOOOH@@AOOON@@@AOOOL@@@AOOOL@@@AOOOL@@@@OOOH@@@@OOOH@@@@GOO@@@@@GOO@@@@@CON@@@@@AOL@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.ROTY #*(42 30)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@@@@@@@@O@@AN@@@@@@C@@@@AH@@@@@L@@@@@F@@@@A@@@@@@A@@@@B@@@@@@@H@@@B@@@@@@@H@@@D@@@@@@@D@@@D@@@@@@@D@@@D@@@@@@@D@@@B@@@@@@@H@@@B@@@@H@@H@@@A@@@AH@A@@@@@L@@C@@F@@@@@C@@F@AH@@@@@@O@LAN@@@@@@@@OON@@@@@@@@@@L@@@@@@@@@@@F@@@@@@@@@@@C@@@@@@@@@@@AH@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.ROTY.HIGHLIGHT #*(42 30)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@@@@@@@@OOOON@@@@@@COOOOOH@@@@@OOOOOON@@@@AOOOOOOO@@@@COOOOOOOH@@@COOOOOOOH@@@GOOOOOOOL@@@GOOOOOOOL@@@GOOOOOOOL@@@COOOOOOOH@@@COOOOOOOH@@@AOOOOOOO@@@@@OOOOOON@@@@@COOOOOH@@@@@@OOOON@@@@@@@@OON@@@@@@@@@@L@@@@@@@@@@@F@@@@@@@@@@@C@@@@@@@@@@@AH@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.ROTZ #*(45 38)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@AL@O@@@@@@@@F@@@N@@@@@@@H@@@AH@@@@@A@@@@@F@@@@@A@@@@@AOO@@@A@@@@@AL@@@@B@@@@@AB@@@@B@@@@@AA@@@@B@@@@@A@H@@@B@@@@@A@D@@@A@@@@@A@D@@@A@@@@@A@B@@@A@@@@@A@A@@@@H@@@@@@A@@@@D@@@@@@A@@@@D@@@@@@@H@@@B@@@@@@@H@@@A@@@@@@@H@@@@H@@@@@@H@@@@F@@@@@A@@@@@A@@@@@A@@@@@@L@@@@A@@@@@@C@@@@B@@@@@@@N@@@L@@@@@@@AN@G@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.ROTZ.HIGHLIGHT #*(45 38)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@AOOO@@@@@@@@GOOON@@@@@@@OOOOOH@@@@@AOOOOON@@@@@AOOOOOOOO@@@AOOOOOOL@@@@COOOOOON@@@@COOOOOOO@@@@COOOOOOOH@@@COOOOOOOL@@@AOOOOOOOL@@@AOOOOOOON@@@AOOOOOOOO@@@@OOOOOOOO@@@@GOOOOOOO@@@@GOOOOOOOH@@@COOOOOOOH@@@AOOOOOOOH@@@@OOOOOOOH@@@@GOOOOOO@@@@@AOOOOOO@@@@@@OOOOOO@@@@@@COOOON@@@@@@@OOOOL@@@@@@@AOOO@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.ROTATE #*(74 77)@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@@@@@BJ@@@@@@@@@@@@@@@@@@BJ@@@@@@@@@@@@@@@@@@DI@@@@@@@@@@@@@@@@@@DI@@@@@@@@@@@@@@@@@@HI@@@@@@@@@@@@@@@@@@HHH@@@@@@@@@@@@@@@@@HHH@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@IB@@@@@@@@@@@@@@@@@@HJ@@@@@@@@@@@@@@@@@@HF@@@@@@@@@@@@@@@@@@HB@@@@@@@@@@@@@@@@@@IB@@@@@@@@@@@@@@@@@@HL@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@HH@@@@@@@@@@@H@@@@@@E@@@@@@@@@@@@H@@@@@@B@N@@@@@@@@@@H@@@@@@E@AH@@@@@@@@@H@@@@@@HH@F@@@@@@@@@H@@@@@@@@@AL@@@@@@@@OOOOOOOOOOOO@@@@@@@A@@@@@@@@@@AL@@@@@@@A@@@@@@@@@@F@@@@@@@@B@@@@@@@@@AH@@@@@@@@D@@@@@@@@@N@@@@@@@@@D@@@@@@@@@@@@@@@AN@@H@@@@@@@@@@@@@@@@B@A@@@@@@@@@@@@@@@@@D@A@@@@@@@@@@@@@@@@@H@B@@@@@@@@@@@@@@@@AN@D@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@AA@@@@@@@@@@@@@@@@@@AA@@@@@@@@@@@@@@@@@@AB@@@@@@@@@@@@@@@@@@BD@@@@@@@@@@@@@@@@@@BDD@@@@@@@@@@@@@@@@@BHH@@@@@@@@@@@@@@@@@EA@@@@@@@@@@@@@@@@@@EF@@@@@@@@@@@@@@@@@@FH@@@@@@@@@@@@@@@@@@M@@@@@@@@@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.DELTA.LABEL #*(9 13)@@@@@H@@@H@@AD@@AD@@BB@@BB@@DA@@DA@@GO@@@@@@@@@@@@@@) (RPAQQ IV.THETA.LABEL #*(7 13)@@@@CH@@DD@@DD@@DD@@GL@@DD@@DD@@DD@@CH@@@@@@@@@@@@@@) (RPAQQ IV.TOWARD #*(35 38)@@@@@@H@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@G@@@L@@@@@@@DN@CD@@@@@@@FAONF@@@@@@@B@@@B@@@@@@@A@@@C@@@@@@@@L@@A@@@@@@@@CO@@H@@@@@@@@F@@D@@@@@@@@D@@B@@@@@@@@H@@A@@@@@@@A@@@@IB@@@@@B@@@@EN@@@@@D@@@@C@@@@@@HB@@@F@@@@@A@D@@@H@@@@@B@H@@@H@@@@@DA@D@A@@@@@@HB@H@B@@@@@A@DA@HD@@@@@B@JBA@H@@@@@DAALBA@@@@@@HB@DDB@@@@@@HD@GHD@@@@@@GH@@HH@@@@@@@@@@I@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.TOWARD.HIGHLIGHT #*(35 38)@@@@@@H@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@G@@@L@@@@@@@GN@CL@@@@@@@GOOON@@@@@@@COOON@@@@@@@AOOOO@@@@@@@@OOOO@@@@@@@@COOOH@@@@@@@@GOOL@@@@@@@@GOON@@@@@@@@OOOO@@@@@@@AOOOOHB@@@@@COOOOMN@@@@@GOOOOO@@@@@@OOOOON@@@@@AOOOOOH@@@@@COOOOOH@@@@@GOOOOO@@@@@@OOOOON@@@@@AOOOOOL@@@@@COKOOOH@@@@@GOAOOO@@@@@@ON@GON@@@@@@OL@GOL@@@@@@GH@@OH@@@@@@@@@@O@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IV.AWAY #*(36 34)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@C@@@@@@@@@@@G@@@@@@@@@@@K@@@@@@@@@@AE@@@@@@@@@@BE@@@@@@@@@@@E@@@@@@@@@@@I@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@@@@@@D@@@@@@@@@@@D@@@@@@@@@@@D@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (* ; "fns for co-ordinating scenes") (DEFINEQ (IV.PROOF.SCENE [LAMBDA (ITEM) (* gbn "21-Nov-85 01:14") (LET ((OBJNO (fetch (IRISSCENE OBJNO) of IV.CURRENT.SCENE))) (IV.ENSURE.SCENE IV.CURRENT.SCENE) (* makes sure the object is defined) (IRIS.CALLOBJ OBJNO \IRISSTREAM) (IRIS.SWAPBUFFERS \IRISSTREAM) (ALIGN \IRISSTREAM) (SPP.FORCEOUTPUT IRISCONN]) (IV.ENSURE.SCENE [LAMBDA (SCENE) (* ; "Edited 29-Jan-87 01:22 by gbn") (* ;  "makes sure that a scene's objno is defined.") (LET ((OBJNO (fetch (IRISSCENE OBJNO) of SCENE))) (if (ZEROP (IRIS.ISOBJ OBJNO \IRISSTREAM)) then (IV.PROMPTPRINT "Creating object for " (fetch (IRISSCENE NAME) of SCENE)) (RESETLST (RESETSAVE NIL (LIST 'IRIS.CLOSEOBJ \IRISSTREAM)) (IRIS.MAKEOBJ OBJNO \IRISSTREAM) (if (SETQ DRAWFN (fetch (IRISSCENE DRAWFN) of SCENE)) then (EVAL DRAWFN) else (IV.GETINPUT (CONCAT "Please remake " (fetch (IRISSCENE NAME) of SCENE) " then hit RETURN"))) (IRIS.CLOSEOBJ \IRISSTREAM)) (PRINTOUT IV.PROMPTWINDOW "...done" T]) (IV.NEW.SCENE.FROM.USER [LAMBDA NIL (* gbn "20-Nov-85 23:21") (* * Reads a new scene from the user. Returns NIL if the scene is not  completed. Sets the scene menu to nil to cause it to be rebuilt when a new  scene is successfully read) (PROG (NAME DRAWFN OBJNO SCENE) (SETQ NAME (IV.GETINPUT "Scene Name?")) (if (NOT NAME) then (RETURN)) (SETQ SCENE (create IRISSCENE NAME _ NAME OBJNO _ (IRIS.CONS.OBJNO))) (replace (IRISSCENE DRAWFN) of SCENE with (SETQ DRAWFN (IV.READ "Form to eval to create scene? " ))) (if (NOT DRAWFN) then (IRIS.MAKEOBJ (fetch (IRISSCENE OBJNO) of SCENE) \IRISSTREAM) (IV.GETINPUT "Make object, then type RETURN") (IRIS.CLOSEOBJ \IRISSTREAM)) (push IV.SCENES SCENE) (SETQ IV.SCENES.MENU NIL) (RETURN SCENE]) (IV.REDEFINE.SCENE [LAMBDA (ITEM BUTTONS WINDOW) (* ; "Edited 29-Jan-87 01:20 by gbn") (LET ((SCENE (IV.CHOOSE.SCENE))) (if (MOUSECONFIRM (CONCAT "Redefine " (fetch NAME of SCENE)) NIL IV.PROMPTWINDOW) then (IRIS.DELOBJ (fetch OBJNO of SCENE) \IRISSTREAM) (REPLACE OBJNO OF SCENE WITH (IRIS.CONS.OBJNO)) (IV.ENSURE.SCENE SCENE]) (IV.CHOOSE.SCENE [LAMBDA NIL (* edited%: "12-Dec-85 20:58") (MENU (OR IV.SCENES.MENU (IV.BUILD.SCENES.MENU]) (IV.BUILD.SCENES.MENU [LAMBDA NIL (* ; "Edited 23-Jan-87 20:23 by gbn") (* ;;; "builds the menu used to prompt the user for scenes that can be loaded on the iris.") (SETQ IV.SCENES.MENU (create MENU ITEMS _ (CONS '(New% Scene? (IV.NEW.SCENE.FROM.USER) "allows specification of a new scene") (for ENTRY in IV.SCENES collect (LIST (fetch (IRISSCENE NAME) of ENTRY) (KWOTE ENTRY]) (IV.FORGET.SCENE [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "12-Dec-85 20:58") (PROG ((NEWSCENE (IV.CHOOSE.SCENE)) OBJNO) (if NEWSCENE then (DREMOVE NEWSCENE IV.SCENES) (if (SETQ OBJNO (fetch (IRISSCENE OBJNO) of NEWSCENE)) then (IRIS.DELOBJ OBJNO \IRISSTREAM)) (SETQ IV.SCENES.MENU NIL]) (IV.DRAW.SCENE [LAMBDA NIL (* gbn "21-Nov-85 02:09") (OR IV.CURRENT.SCENE (ERROR "CAN'T DRAW NULL SCENE")) (SELECTQ IV.MODE (POLAR (IRIS.POLARVIEW IV.DIST IV.AZIM IV.INC IV.TWIST \IRISSTREAM)) (XLATE NIL) (LOOKAT (if (NOT (AND (EQUAL IV.OBJPT LASTIV.OBJPT) (EQUAL IV.VIEWPT LASTIV.VIEWPT))) then (* setup the viewing transformation,  since it has changed) (IRIS.LOOKAT (fetch IVX of IV.VIEWPT) (fetch IVX of IV.VIEWPT) (fetch IVY of IV.VIEWPT) (fetch IVZ of IV.OBJPT) (fetch IVY of IV.OBJPT) (fetch IVZ of IV.OBJPT) IV.TWIST \IRISSTREAM) (SETQ LASTIV.OBJPT IV.OBJPT) (SETQ LASTIV.VIEWPT IV.VIEWPT))) (ERROR "UNKNOWN IV.MODE")) (if \IV.BACKGROUND then (\CLEAR.IRIS \IV.BACKGROUND)) (IRIS.CALLOBJ (fetch (IRISSCENE OBJNO) of IV.CURRENT.SCENE) \IRISSTREAM) (if \IV.DRAW.AXES then (IRIS.CALLOBJ (fetch (IRISSCENE OBJNO) of AXES.SCENE) \IRISSTREAM)) (IRIS.SWAPBUFFERS \IRISSTREAM) (ALIGN \IRISSTREAM]) (IV.SET.CURRENT.SCENE [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 4-Feb-87 19:28 by gbn") (PROG ([NEWSCENE (MENU (OR IV.SCENES.MENU (IV.BUILD.SCENES.MENU] SCENEITEM) (if NEWSCENE then (SETQ IV.CURRENT.SCENE NEWSCENE) (SETQ SCENEITEM (FM.GETITEM 'CURRENTSCENE 'FILL-INS WINDOW)) (OR SCENEITEM (ERROR "SCENE ITEM NOT FOUND")) (FM.CHANGESTATE SCENEITEM (fetch (IRISSCENE NAME) of NEWSCENE) WINDOW) (* IV.DISPLAY.FMITEM SCENEITEM WINDOW) (IV.PROOF.SCENE SCENEITEM]) (IV.SCENE.SETUP [LAMBDA NIL (* ; "Edited 4-Feb-87 19:22 by gbn") [IF (NOT (BOUNDP 'AXES.SCENE)) THEN (SETQ AXES.SCENE (CREATE IRISSCENE NAME _ 'Axes OBJNO _ (IRIS.CONS.OBJNO) DRAWFN _ '(DRAW.AXES 2] [IF (NOT (BOUNDP 'SKULL.SCENE)) THEN (SETQ SKULL.SCENE (CREATE IRISSCENE NAME _ 'Skull OBJNO _ (IRIS.CONS.OBJNO) DRAWFN _ '(SKULLO \IRISSTREAM] (PUSHNEW IV.SCENES AXES.SCENE) (PUSHNEW IV.SCENES SKULL.SCENE) (SETQ IV.CURRENT.SCENE AXES.SCENE]) ) (DEFINEQ (DRAW.AXES [LAMBDA (WIDTH COLOR) (* edited%: "17-Dec-85 18:39") (* * draws tri-color axes with each axis being 200 in length in the positive  direction) (IRIS.PUSHATTRIBUTES \IRISSTREAM) (IRIS.LINEWIDTH (OR WIDTH 5) \IRISSTREAM) (IRIS.COLOR (OR COLOR 1) \IRISSTREAM) (IRIS.MOVE 0 0 0 \IRISSTREAM) (IRIS.DRAW 0 0 200 \IRISSTREAM) (IRIS.CMOV 0 0 210 \IRISSTREAM) (IRIS.CHARSTR "z" \IRISSTREAM) (IRIS.COLOR (OR COLOR 2) \IRISSTREAM) (IRIS.MOVE 0 0 0 \IRISSTREAM) (IRIS.DRAW 0 200 0 \IRISSTREAM) (IRIS.CMOV 0 210 0 \IRISSTREAM) (IRIS.CHARSTR "y" \IRISSTREAM) (IRIS.COLOR (OR COLOR 3) \IRISSTREAM) (IRIS.MOVE 0 0 0 \IRISSTREAM) (IRIS.DRAW 200 0 0 \IRISSTREAM) (IRIS.CMOV 210 0 0 \IRISSTREAM) (IRIS.CHARSTR "x" \IRISSTREAM) (IRIS.POPATTRIBUTES \IRISSTREAM) (F]) (F [LAMBDA NIL (* edited%: "13-Dec-85 18:35") (SPP.FORCEOUTPUT IRISCONN]) (IV.CLEARIRIS [LAMBDA NIL (* gbn "21-Nov-85 00:51") (DSPCOLOR (DICOLOR.FROM.USER T) \IRISSTREAM) (IRIS.CLEAR \IRISSTREAM) (IRIS.SWAPBUFFERS \IRISSTREAM) (F]) (IV.DOWN [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:01") (LET NIL (SELECTQ IV.MODE (POLAR (add IV.AZIM IV.THETA)) (XLATE (IRIS.TRANSLATE 0 (IMINUS IV.DXLATE) 0 \IRISSTREAM)) (PROGN (add (fetch IVX of IV.OBJPT) IV.DXLATE))) (IV.DRAW.SCENE]) (IV.GETINPUT [LAMBDA (MSG) (* edited%: "21-Aug-85 04:10") (CLEARW IV.PROMPTWINDOW) (PROG1 (PROMPTFORWORD MSG NIL NIL IV.PROMPTWINDOW NIL 'TTY NIL NIL) (WINDOWPROP IV.PROMPTWINDOW 'PROCESS NIL) (* some random process circularity fix) ]) (IV.READ [LAMBDA (PROMPT) (* gbn "20-Nov-85 23:19") (CLEARW IV.PROMPTWINDOW) (PRINTOUT IV.PROMPTWINDOW PROMPT) (RESETFORM (TTYDISPLAYSTREAM IV.PROMPTWINDOW) (LISPXREAD T T]) (IV.HOME [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 18:31") (PROG [(R (FM.ITEMPROP ITEM 'REGION] (\FM.HIGHLIGHTITEM ITEM WINDOW) (SELECTQ IV.MODE (XLATE (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -5000 5000 IRISCONN) (IV.VIEW)) (POLAR (IRIS.POLARVIEW 500 0 0 0 \IRISSTREAM)) (LOOKAT NIL) (ERROR "UNKNOWN MODE")) (IV.DRAW.SCENE) (F]) (IV.2D.HOME [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 18:43 by gbn") (PROG [(R (FM.ITEMPROP ITEM 'REGION] (\FM.HIGHLIGHTITEM ITEM WINDOW) (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -1000 1000 IRISCONN) (IV.DRAW.SCENE) (F]) (IV.PHOME [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 18:43 by gbn") (PROG [(R (FM.ITEMPROP ITEM 'REGION] (\FM.HIGHLIGHTITEM ITEM WINDOW) (IV.PHOME.AUX) (F]) (IV.PHOME.AUX [LAMBDA NIL (* ; "Edited 27-Jan-87 18:31 by gbn") (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -5000 5000 IRISCONN) (IRIS.VIEWPORT 0 IRIS.XMAXSCREEN 0 IRIS.YMAXSCREEN IRISCONN) (IRIS.PERSPECTIVE (IRIS.DEGREES 45) (IQUOTIENT IRIS.XMAXSCREEN IRIS.YMAXSCREEN) 0 10000 IRISCONN) (* ;  "The projection (world-space -> eye-space) transformation") (IRIS.POLARVIEW 500 (IRIS.DEGREES 45) (IRIS.DEGREES 45) 0 IRISCONN) (* ;  "the viewing (placing eye-space in world-space) transformation") (IV.DRAW.SCENE]) (IV.VIEW [LAMBDA (Z) (* edited%: "17-Dec-85 18:32") (IRIS.PERSPECTIVE (IRIS.DEGREES 45) (IQUOTIENT IRIS.XMAXSCREEN IRIS.YMAXSCREEN) 0 10000 IRISCONN) (IRIS.POLARVIEW (OR Z 1000) (IRIS.DEGREES 90) (IRIS.DEGREES 90) 0 IRISCONN]) (IV.LEFT [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 15:59") (LET NIL (SELECTQ IV.MODE (POLAR (add IV.AZIM IV.THETA)) (XLATE (IRIS.TRANSLATE (IMINUS IV.DXLATE) 0 0 \IRISSTREAM)) (PROGN (add (fetch IVX of IV.OBJPT) IV.DXLATE))) (IV.DRAW.SCENE]) (IV.RIGHT [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 17:55 by gbn") (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT) THEN (IMINUS IV.DXLATE) ELSE IV.DXLATE))) (IRIS.TRANSLATE MOVE 0 0 \IRISSTREAM) (IV.DRAW.SCENE]) (IV.ROTX [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:03") (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT) then (MINUS IV.THETA) else IV.THETA) IRIS.XAXIS \IRISSTREAM) (IV.DRAW.SCENE]) (IV.DOUBLEBUFFER [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Jan-87 00:03 by gbn") (PROG [(STATE (FM.ITEMPROP ITEM 'STATE] (if STATE then (IRIS.DOUBLEBUFFER \IRISSTREAM) (IRIS.FRONTBUFFER 0) (IRIS.BACKBUFFER 1) (IV.PROMPTPRINT "Double buffering.") else (IRIS.SINGLEBUFFER \IRISSTREAM) (IRIS.FRONTBUFFER 1) (IRIS.BACKBUFFER 0) (IV.PROMPTPRINT "Single buffering.")) (IRIS.GCONFIG IRISCONN]) (IV.ROTY [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:04") (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT) then (MINUS IV.THETA) else IV.THETA) IRIS.YAXIS \IRISSTREAM) (IV.DRAW.SCENE]) (IV.ROTZ [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:02") (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT) then (MINUS IV.THETA) else IV.THETA) IRIS.ZAXIS \IRISSTREAM) (IV.DRAW.SCENE]) (IV.SWAPBUFFERS [LAMBDA NIL (* gbn "14-Nov-85 18:27") (IRIS.SWAPBUFFERS \IRISSTREAM) (SPP.FORCEOUTPUT IRISCONN]) (IV.UP [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 17:55 by gbn") (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT) THEN (IMINUS IV.DXLATE) ELSE IV.DXLATE))) (IRIS.TRANSLATE 0 MOVE 0 \IRISSTREAM) (IV.DRAW.SCENE]) (IV.THETA [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 01:13 by gbn") (* controls whether or not the background is cleared before drawing a scene) (LET ((NEW (RNUMBER "Enter new rotation in degrees"))) (if NEW then (SETQ IV.THETA (ITIMES 10 NEW)) (FM.CHANGESTATE (FM.GETITEM 'THETA 'FILL-INS WINDOW) NEW WINDOW]) (IV.AXES [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Jan-87 00:17 by gbn") (* ;  "controls whether or not axes are drawn in the scene.") (if (FM.ITEMPROP ITEM 'STATE) then (SETQ \IV.DRAW.AXES T) (IV.ENSURE.SCENE AXES.SCENE) else (SETQ \IV.DRAW.AXES)) (IV.DRAW.SCENE]) (IV.BACKGROUND [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 28-Jan-87 17:01 by gbn") (* ;  "controls whether or not the background is cleared before drawing a scene") (LET ((NAME-OR-RGB (DICOLOR.FROM.USER T))) (SETQ \IV.BACKGROUND (if NAME-OR-RGB then (\IRIS.ASSURE.COLOR NAME-OR-RGB \IRISSTREAM) else NIL)) (FM.CHANGELABEL (FM.GETITEM 'BACKGROUND 'FILL-INS WINDOW) (if NAME-OR-RGB then (L-CASE (MKSTRING NAME-OR-RGB)) else "none") WINDOW) (IV.DRAW.SCENE]) (IV.TOWARD [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 17:55 by gbn") (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT) THEN (IMINUS IV.DXLATE) ELSE IV.DXLATE))) (IRIS.TRANSLATE 0 0 MOVE \IRISSTREAM) (IV.DRAW.SCENE]) (IV.AWAY [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 15:39") (LET NIL (SELECTQ IV.MODE (POLAR (add IV.AZIM IV.THETA)) (XLATE (IRIS.TRANSLATE 0 0 (MINUS IV.DXLATE) \IRISSTREAM)) (PROGN (add (fetch IVX of IV.OBJPT) IV.DXLATE))) (IV.DRAW.SCENE]) (IV.DSPCOLOR [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 28-Jan-87 17:02 by gbn") (* ;;; "sets the dspcolor for the stream (foreground color)") (LET ((RGB (DICOLOR.FROM.USER T))) (if RGB then (DSPCOLOR RGB \IRISSTREAM) (FM.CHANGESTATE (FM.GETITEM 'DSPCOLOR 'FILL-INS WINDOW) (if RGB then (L-CASE (MKSTRING RGB)) else "none") WINDOW) else NIL]) (IV.DELTA [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 01:13 by gbn") (LET ((NEW (RNUMBER "Enter new translation value"))) (if NEW then (FM.CHANGESTATE (FM.GETITEM 'DELTA 'FILL-INS WINDOW) (SETQ IV.DXLATE NEW) WINDOW]) (IV.VIEW.CHANGED [LAMBDA NIL (* ; "Edited 3-Feb-87 00:00 by gbn") 'JUNK]) (IV.NEWSTREAM [LAMBDA (ITEM BUTTONS WINDOW) (* ; "Edited 29-Jan-87 00:59 by gbn") (IF (MOUSECONFIRM "kill old stream? (lose fonts, etc.)" "left to confirm" IV.PROMPTWINDOW) THEN (SETQ IRISCONN NIL) (OPENIRISSTREAM IRISNSHOSTNUMBER]) (IV.PROMPTPRINT [LAMBDA ARGS (* edited%: "21-Aug-85 06:10") (CLEARW IV.PROMPTWINDOW) (for F from 1 to ARGS do (PRIN1 (ARG ARGS F) IV.PROMPTWINDOW]) (IV.PROOF.SKETCH [LAMBDA (ARGS |...|) (* edited%: "21-Aug-85 10:39") (IV.PROMPTPRINT "SKETCHing...") (IRIS.SKETCH (PROG1 NIL (GETPOSITION))) (ALIGN \IRISSTREAM) (IV.PROMPTPRINT "done"]) (IV.INIT [LAMBDA (MENU-POSITION) (* ; "Edited 4-Feb-87 19:23 by gbn") (* ;;; "uses freemenu to build the view controller menu ") (LET NIL (if (BOUNDP 'IV.DEMOW) then (CLOSEW IV.DEMOW)) (MOVEW (SETQ IV.DEMOW (FREEMENU *IV-MENUDESC*)) MENU-POSITION) (SETQ IV.PROMPTWINDOW (GETPROMPTWINDOW IV.DEMOW 2)) (IV.NEWSTREAM NIL NIL NIL) (* ; "INIT LOOKAT PARAMS") (SETQ LASTIV.OBJPT (create IVPOS IVX _ 0 IVY _ 0 IVZ _ 1)) (SETQ IV.OBJPT (create IVPOS IVX _ 0 IVY _ 0 IVZ _ 0)) (SETQ IV.VIEWPT (create IVPOS IVX _ 0 IVY _ 0 IVZ _ -1000)) (SETQ LASTIV.VIEWPT (create IVPOS IVX _ 0 IVY _ 0 IVZ _ -1001)) (* ;  "The amount that a translate should move") (SETQ IV.DXLATE 10) (* ; "INIT POLAR PARAMS") (SETQ IV.DIST 500) (SETQ IV.AZIM (SETQ IV.INC (SETQ IV.TWIST 0))) (SETQ IV.MODE 'XLATE) (IRIS.DOUBLEBUFFER \IRISSTREAM) (IV.SCENE.SETUP) (IV.ENSURE.SCENE AXES.SCENE) (IV.PHOME.AUX) (IV.DRAW.SCENE) (IV.DRAW.SCENE) (IRIS.GCONFIG \IRISSTREAM]) (\CLEAR.IRIS [LAMBDA (COLOR) (* gbn "21-Nov-85 02:10") (IRIS.PUSHATTRIBUTES \IRISSTREAM) (IRIS.COLOR (\IRIS.ASSURE.COLOR COLOR \IRISSTREAM)) (IRIS.CLEAR \IRISSTREAM) (IRIS.POPATTRIBUTES]) (IRIS.DEGREES [LAMBDA (DEGREES) (* edited%: "13-Dec-85 18:32") (* Takes an angle in degrees and returns an angle as the iris likes it  (tenths)) (FIX (TIMES DEGREES 10]) ) (DEFINEQ (IV.ITEMMAPFN [LAMBDA (ITEM) (* edited%: "21-Aug-85 02:05") (if (EQUAL (FM.ITEMPROP ITEM 'NAME%:) NAME) then (SETQ RESULT ITEM]) (IV.DISPLAY.FMITEM [LAMBDA (ITEM WINDOW) (* gbn "15-Nov-85 12:25") (HELP)(* PROG ((STREAM (fetch (FREEMENU STREAM) of  (WINDOWPROP WINDOW (QUOTE FREEMENU)))) (FONT  (FM.ITEMPROP ITEM (QUOTE FONT%:))) (REGION  (FM.ITEMPROP ITEM (QUOTE REGION))) (LABEL  (FM.ITEMPROP ITEM (QUOTE LABEL)))) (DSPDESTINATION  (FM.ITEMPROP ITEM (QUOTE BITMAP)) STREAM)  (DSPXPOSITION 0 STREAM) (DSPYPOSITION (FONTPROP FONT  (QUOTE DESCENT)) STREAM) (DSPFONT FONT STREAM)  (PRIN1 LABEL STREAM) (replace (REGION WIDTH) of REGION with  (STRINGWIDTH LABEL FONT)) (FM.DISPLAYITEM ITEM WINDOW)  (BLTSHADE WHITESHADE WINDOW (IPLUS (fetch  (REGION LEFT) of REGION) (fetch (REGION WIDTH) of REGION))  (fetch (REGION BOTTOM) of REGION) (IDIFFERENCE  (BITMAPWIDTH (FM.ITEMPROP ITEM (QUOTE BITMAP)))  (fetch (REGION WIDTH) of REGION)) (BITMAPHEIGHT  (FM.ITEMPROP ITEM (QUOTE BITMAP))))) ]) ) (DECLARE%: EVAL@COMPILE (RECORD IRISSCENE (NAME DRAWFN OBJNO) OBJNO _ (IRIS.CONS.OBJNO)) (RECORD IVPOS (IVX IVY IVZ)) ) (RPAQQ HANDWIDTH 48) (RPAQQ IRIS.XAXIS 88) (RPAQQ IRIS.ZAXIS 90) (RPAQQ IV.DXLATE 10) (RPAQQ IV.MODE XLATE) (RPAQQ IV.OBJPT (0 0 0)) (RPAQQ IV.THETA 50) (RPAQQ IV.TRACE.FNS (IRIS.POPMATRIX IRIS.ROTATE IRIS.TRANSLATE)) (RPAQQ IV.TWIST 0) (RPAQQ IV.VIEWPT (0 0 -1000)) (RPAQQ LASTIV.OBJPT (0 0 1)) (RPAQQ LASTIV.VIEWPT (0 0 -1001)) (RPAQQ \IV.DRAW.AXES NIL) (RPAQQ \IV.BACKGROUND NIL) (IV.SCENE.SETUP) (IV.BUILD.SCENES.MENU) (DEFINEQ (SKULLO [LAMBDA (*STREAM*) (FILLCIRCLE 529 377 192.0 '(NIL (255 0 0)) *STREAM*) (DRAWCIRCLE 529 377 192.0 '(ROUND 1 (0 255 255)) 'NIL *STREAM*) (FILLPOLYGON '((530 . 568) (476 . 562) (426 . 540) (380 . 500) (349 . 445) (337 . 386) (344 . 323) (383 . 250) (436 . 208) (484 . 190) (530 . 184)) '(NIL (0 0 255)) *STREAM*) (DRAWLINE 530 568 476 562 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 476 562 426 540 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 426 540 380 500 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 380 500 349 445 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 349 445 337 386 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 337 386 344 323 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 344 323 383 250 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 383 250 436 208 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 436 208 484 190 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 484 190 530 184 '1 'NIL *STREAM* '(0 255 255) 'NIL) (DRAWLINE 530 184 530 568 '1 'NIL *STREAM* '(0 255 255) 'NIL) (FILLCIRCLE 529 417 152.0526 '(NIL (255 255 255)) *STREAM*) (DRAWCIRCLE 529 417 152.0526 '(ROUND 1 (255 255 255)) 'NIL *STREAM*) (FILLPOLYGON '((639 . 312) (642 . 301) (642 . 291) (640 . 283) (635 . 276) (629 . 273) (620 . 272) (611 . 294)) '(NIL (255 255 255)) *STREAM*) (DRAWLINE 639 312 642 301 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 642 301 642 291 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 642 291 640 283 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 640 283 635 276 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 635 276 629 273 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 629 273 620 272 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 620 272 611 294 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 611 294 639 312 '1 'NIL *STREAM* '(255 255 255) 'NIL) (FILLPOLYGON '((446 . 300) (439 . 271) (439 . 254) (440 . 245) (446 . 236) (455 . 231) (465 . 227) (529 . 220) (602 . 227) (611 . 229) (618 . 236) (622 . 245) (622 . 256) (620 . 271) (615 . 302)) '(NIL (255 255 255)) *STREAM*) (DRAWLINE 446 300 439 271 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 439 271 439 254 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 439 254 440 245 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 440 245 446 236 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 446 236 455 231 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 455 231 465 227 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 465 227 529 220 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 529 220 602 227 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 602 227 611 229 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 611 229 618 236 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 618 236 622 245 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 622 245 622 256 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 622 256 620 271 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 620 271 615 302 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 615 302 446 300 '1 'NIL *STREAM* '(255 255 255) 'NIL) (FILLPOLYGON '((468 . 228) (466 . 222) (468 . 216) (474 . 218) (478 . 212) (481 . 213) (486 . 202) (493 . 205) (499 . 194) (505 . 198) (514 . 186) (522 . 191) (530 . 187) (538 . 192) (546 . 186) (554 . 192) (559 . 190) (566 . 196) (572 . 194) (578 . 202) (584 . 201) (589 . 210) (593 . 209) (598 . 214) (601 . 214) (604 . 219) (600 . 226)) '(NIL (255 255 255)) *STREAM*) (DRAWLINE 468 228 466 222 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 466 222 468 216 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 468 216 474 218 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 474 218 478 212 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 478 212 481 213 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 481 213 486 202 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 486 202 493 205 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 493 205 499 194 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 499 194 505 198 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 505 198 514 186 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 514 186 522 191 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 522 191 530 187 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 530 187 538 192 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 538 192 546 186 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 546 186 554 192 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 554 192 559 190 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 559 190 566 196 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 566 196 572 194 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 572 194 578 202 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 578 202 584 201 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 584 201 589 210 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 589 210 593 209 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 593 209 598 214 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 598 214 601 214 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 601 214 604 219 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 604 219 600 226 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 600 226 468 228 '1 'NIL *STREAM* '(255 255 255) 'NIL) (FILLPOLYGON '((422 . 310) (419 . 298) (419 . 283) (420 . 278) (424 . 274) (431 . 272) (439 . 271) (451 . 292)) '(NIL (255 255 255)) *STREAM*) (DRAWLINE 422 310 419 298 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 419 298 419 283 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 419 283 420 278 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 420 278 424 274 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 424 274 431 272 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 431 272 439 271 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 439 271 451 292 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 451 292 422 310 '1 'NIL *STREAM* '(255 255 255) 'NIL) (FILLCIRCLE 527 419 136.0 '(NIL (255 0 0)) *STREAM*) (DRAWCIRCLE 527 419 136.0 '(ROUND 2 (255 255 255)) 'NIL *STREAM*) (FILLPOLYGON '((564 . 550) (582 . 544) (609 . 527) (632 . 506) (650 . 478) (662 . 441) (664 . 404) (654 . 369) (638 . 340) (616 . 316) (591 . 299) (565 . 286) (532 . 280) (490 . 286)) '(NIL (0 0 255)) *STREAM*) (DRAWLINE 564 550 582 544 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 582 544 609 527 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 609 527 632 506 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 632 506 650 478 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 650 478 662 441 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 662 441 664 404 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 664 404 654 369 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 654 369 638 340 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 638 340 616 316 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 616 316 591 299 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 591 299 565 286 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 565 286 532 280 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 532 280 490 286 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 490 286 564 550 '1 'NIL *STREAM* '(255 255 255) 'NIL) (FILLPOLYGON '((564 . 550) (560 . 532) (568 . 530) (548 . 492) (574 . 492) (536 . 432) (572 . 433) (522 . 378) (559 . 378) (492 . 286) (510 . 362) (482 . 363) (518 . 418) (496 . 418) (542 . 480) (520 . 480) (554 . 525) (545 . 524)) '(NIL (255 255 255)) *STREAM*) (DRAWLINE 564 550 560 532 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 560 532 568 530 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 568 530 548 492 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 548 492 574 492 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 574 492 536 432 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 536 432 572 433 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 572 433 522 378 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 522 378 559 378 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 559 378 492 286 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 492 286 510 362 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 510 362 482 363 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 482 363 518 418 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 518 418 496 418 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 496 418 542 480 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 542 480 520 480 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 520 480 554 525 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 554 525 545 524 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWLINE 545 524 564 550 '1 'NIL *STREAM* '(255 255 255) 'NIL) (DRAWCIRCLE 529 417 136.0 '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((420 . 311) (390 . 354) (377 . 415) (387 . 470) (409 . 511) (444 . 542) (488 . 563) (528 . 569) (581 . 559) (630 . 531) (657 . 498) (677 . 453) (679 . 392) (662 . 342) (640 . 312)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((565 . 547)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 565 547 547 522 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((547 . 522)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 547 522 555 522 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((555 . 522)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 555 522 522 478 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((522 . 478)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 522 478 545 479 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((545 . 479)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 545 479 499 416 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((499 . 416)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 499 416 521 416 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((521 . 416)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 521 416 483 362 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((483 . 362)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 483 362 512 360 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((512 . 360)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 512 360 493 285 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((493 . 285)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((566 . 548)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 566 548 562 529 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((562 . 529)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 562 529 570 529 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((570 . 529)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 570 529 550 490 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((550 . 490)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 550 490 575 490 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((575 . 490)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 575 490 538 430 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((538 . 430)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 538 430 573 431 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((573 . 431)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 573 431 526 377 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((526 . 377)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 526 377 561 376 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((561 . 376)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWLINE 561 376 493 285 '2 'NIL *STREAM* '(0 0 0) 'NIL) (DRAWCURVE '((493 . 285)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCIRCLE 529 377 192.0 '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((478 . 260) (471 . 258) (462 . 256) (459 . 268) (462 . 283) (457 . 289)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((513 . 256) (520 . 260) (508 . 266) (490 . 267) (481 . 264) (478 . 260) (486 . 258) (499 . 253)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((589 . 261) (593 . 261) (605 . 265) (605 . 273) (605 . 285) (605 . 293)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((549 . 253) (545 . 257) (545 . 265) (561 . 267) (569 . 267) (577 . 265) (585 . 261) (589 . 261) (581 . 257) (573 . 257) (561 . 253) (553 . 253)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((638 . 312) (640 . 302) (641 . 291) (639 . 280) (629 . 273) (617 . 271)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((619 . 271) (621 . 256) (620 . 240) (611 . 230) (602 . 226)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((438 . 271) (438 . 253) (442 . 240) (453 . 231) (465 . 227)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((421 . 310) (418 . 294) (420 . 276) (431 . 271) (436 . 271)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((534 . 240) (533 . 234) (534 . 230) (539 . 226) (543 . 232) (540 . 235)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((527 . 242) (528 . 236) (527 . 229) (520 . 227) (521 . 234) (524 . 238)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((465 . 226) (466 . 219) (469 . 215) (472 . 218) (473 . 223) (470 . 228)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((474 . 222) (475 . 215) (478 . 211) (481 . 214) (482 . 219) (479 . 224)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((483 . 219) (486 . 222) (493 . 219) (493 . 213) (493 . 206) (486 . 203) (482 . 209)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((494 . 216) (496 . 219) (501 . 218) (505 . 213) (505 . 203) (505 . 199) (502 . 195) (497 . 195) (495 . 200) (494 . 205) (494 . 210)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((507 . 209) (510 . 213) (517 . 212) (520 . 206) (521 . 199) (521 . 193) (519 . 189) (513 . 186) (509 . 190) (506 . 196)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((523 . 208) (526 . 212) (533 . 211) (536 . 205) (537 . 198) (537 . 192) (535 . 188) (529 . 185) (525 . 189) (522 . 195)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((539 . 208) (542 . 212) (549 . 211) (552 . 205) (553 . 198) (553 . 192) (551 . 188) (545 . 185) (541 . 189) (538 . 195)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((553 . 212) (555 . 215) (560 . 214) (564 . 209) (564 . 199) (564 . 195) (561 . 191) (556 . 191) (554 . 196) (553 . 201) (553 . 206)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((565 . 215) (567 . 218) (572 . 217) (576 . 212) (576 . 202) (576 . 198) (573 . 194) (568 . 194) (566 . 199) (565 . 204) (565 . 209)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((578 . 217) (581 . 220) (588 . 217) (588 . 211) (588 . 204) (581 . 201) (577 . 207)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((588 . 220) (589 . 213) (592 . 209) (595 . 212) (596 . 217) (593 . 222)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) (DRAWCURVE '((596 . 224) (597 . 217) (600 . 213) (603 . 216) (604 . 221) (601 . 226)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*]) ) (* ;; "The order of these variables is important.") (CL:DEFPARAMETER *IV-SCENES-MENUDESC* `(NIL ((LABEL "Draw Scene" SELECTEDFN IV.PROOF.SCENE HJUSTIFY CENTER)) ((LABEL "Forget Scene" SELECTEDFN IV.FORGET.SCENE HJUSTIFY CENTER)) ((LABEL "Redefine Scene" SELECTEDFN IV.REDEFINE.SCENE HJUSTIFY CENTER))) ) (CL:DEFPARAMETER *IV-FILLINS-MENUDESC* `[(GROUP (PROPS FORMAT TABLE ID FILL-INS) ((LABEL "Change Scene" SELECTEDFN IV.SET.CURRENT.SCENE) (TYPE EDIT ID CURRENTSCENE LABEL "axes" MAXWIDTH 55) ) ((LABEL "" TYPE DISPLAY) (LABEL "" TYPE DISPLAY)) [(LABEL "Background:" SELECTEDFN IV.BACKGROUND) (TYPE EDIT ID BACKGROUND LABEL "black" SELECTEDFN IV.BACKGROUND MAXWIDTH ,(STRINGWIDTH ">background<"] [(LABEL "Foreground:" SELECTEDFN IV.DSPCOLOR) (TYPE EDIT ID DSPCOLOR LABEL "red" SELECTEDFN IV.DSPCOLOR MAXWIDTH ,(STRINGWIDTH ">background<"] [(LABEL ,IV.DELTA.LABEL SELECTEDFN IV.DELTA) (TYPE EDIT ID DELTA LABEL ,(MKSTRING IV.DXLATE] ((LABEL ,IV.THETA.LABEL SELECTEDFN IV.THETA) (TYPE EDIT ID THETA LABEL ,(MKSTRING IV.THETA] ) (CL:DEFPARAMETER *IV-COMMANDS-MENUDESC* `[(GROUP (PROPS FORMAT ROW) ((LABEL "New Stream" SELECTEDFN IV.NEWSTREAM HJUSTIFY CENTER)) ((TYPE TOGGLE LABEL "Axes" SELECTEDFN IV.AXES HJUSTIFY CENTER INITSTATE NIL)) ((TYPE TOGGLE LABEL "Double Buffer" SELECTEDFN IV.DOUBLEBUFFER HJUSTIFY CENTER INITSTATE T)) ((TYPE MOMENTARY LABEL "Swap buffers" SELECTEDFN IV.SWAPBUFFERS HJUSTIFY CENTER)) ((TYPE MOMENTARY LABEL "Clear IRIS" SELECTEDFN IV.CLEARIRIS HJUSTIFY CENTER)) ((TYPE DISPLAY LABEL "")) ,@*IV-SCENES-MENUDESC* (,@*IV-FILLINS-MENUDESC*] ) (CL:DEFPARAMETER *IV-POSITIONING-MENU-DESC* `((GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BOX 0) (LABEL ,IV.TOWARD HIGHLIGHT ,IV.TOWARD.HIGHLIGHT LEFT 0 BOTTOM 0 HELDFN IV.TOWARD) (LABEL ,IV.ROTZ HIGHLIGHT ,IV.ROTZ.HIGHLIGHT LEFT ,(IPLUS -10 (BITMAPWIDTH IV.TOWARD)) BOTTOM ,(BITMAPHEIGHT IV.TOWARD) HELDFN IV.ROTZ) [TYPE DISPLAY LABEL ,IV.ROTATE LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) (IQUOTIENT (BITMAPWIDTH IV.ROTZ) 2)) BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ) (BITMAPHEIGHT IV.TOWARD] (LABEL ,IV.RIGHT HIGHLIGHT ,IV.RIGHT.HIGHLIGHT LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) (IQUOTIENT (BITMAPWIDTH IV.ROTZ) 2) (BITMAPWIDTH IV.ROTATE) (BITMAPWIDTH IV.ROTX)) BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ) (BITMAPHEIGHT IV.TOWARD) 20) HELDFN IV.RIGHT) (LABEL ,IV.ROTX HIGHLIGHT ,IV.ROTX.HIGHLIGHT LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) (IQUOTIENT (BITMAPWIDTH IV.ROTZ) 2) (BITMAPWIDTH IV.ROTATE)) BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ) (BITMAPHEIGHT IV.TOWARD)) HELDFN IV.ROTX) (LABEL ,IV.UP HIGHLIGHT ,IV.UP.HIGHLIGHT LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) (IQUOTIENT (BITMAPWIDTH IV.ROTZ) 2) 10) BOTTOM ,(IPLUS (BITMAPHEIGHT IV.TOWARD) (BITMAPHEIGHT IV.ROTZ) (BITMAPHEIGHT IV.ROTATE) (BITMAPHEIGHT IV.ROTY) -5) HELDFN IV.UP) (LABEL "2D-Home" DOWNFN IV.2D.HOME LEFT ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) BOTTOM ,(BITMAPHEIGHT IV.TOWARD)) [LABEL "Home" DOWNFN IV.HOME LEFT ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) BOTTOM ,(IPLUS -15 (BITMAPHEIGHT IV.TOWARD] [LABEL "Acute-Home" DOWNFN IV.PHOME LEFT ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) BOTTOM ,(IPLUS -30 (BITMAPHEIGHT IV.TOWARD] (LABEL ,IV.ROTY HIGHLIGHT ,IV.ROTY.HIGHLIGHT LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) (IQUOTIENT (BITMAPWIDTH IV.ROTZ) 2) 5) BOTTOM ,(IPLUS (BITMAPHEIGHT IV.TOWARD) (BITMAPHEIGHT IV.ROTZ) (BITMAPHEIGHT IV.ROTATE)) HELDFN IV.ROTY))) ) (CL:DEFPARAMETER *IV-MENUDESC* `[(PROPS FORMAT ROW BOX 4) ((TYPE DISPLAY LABEL "IRIS View Controller" HJUSTIFY CENTER FONT (MODERN 10 BOLD))) (,@*IV-POSITIONING-MENU-DESC* (GROUP (PROPS FORMAT COLUMN) (,@*IV-COMMANDS-MENUDESC*] ) (PUTPROPS IRISVIEW FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA IV.PROMPTPRINT) ) (PUTPROPS IRISVIEW COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (11707 19606 (IV.PROOF.SCENE 11717 . 12158) (IV.ENSURE.SCENE 12160 . 13349) ( IV.NEW.SCENE.FROM.USER 13351 . 14631) (IV.REDEFINE.SCENE 14633 . 15155) (IV.CHOOSE.SCENE 15157 . 15334 ) (IV.BUILD.SCENES.MENU 15336 . 16056) (IV.FORGET.SCENE 16058 . 16516) (IV.DRAW.SCENE 16518 . 18096) ( IV.SET.CURRENT.SCENE 18098 . 18798) (IV.SCENE.SETUP 18800 . 19604)) (19607 33829 (DRAW.AXES 19617 . 20587) (F 20589 . 20727) (IV.CLEARIRIS 20729 . 20978) (IV.DOWN 20980 . 21419) (IV.GETINPUT 21421 . 21757) (IV.READ 21759 . 22011) (IV.HOME 22013 . 22529) (IV.2D.HOME 22531 . 22857) (IV.PHOME 22859 . 23110) (IV.PHOME.AUX 23112 . 23926) (IV.VIEW 23928 . 24278) (IV.LEFT 24280 . 24719) (IV.RIGHT 24721 . 25050) (IV.ROTX 25052 . 25354) (IV.DOUBLEBUFFER 25356 . 25967) (IV.ROTY 25969 . 26271) (IV.ROTZ 26273 . 26575) (IV.SWAPBUFFERS 26577 . 26758) (IV.UP 26760 . 27086) (IV.THETA 27088 . 27554) (IV.AXES 27556 . 28039) (IV.BACKGROUND 28041 . 28829) (IV.TOWARD 28831 . 29161) (IV.AWAY 29163 . 29601) (IV.DSPCOLOR 29603 . 30179) (IV.DELTA 30181 . 30534) (IV.VIEW.CHANGED 30536 . 30675) (IV.NEWSTREAM 30677 . 30986) (IV.PROMPTPRINT 30988 . 31255) (IV.PROOF.SKETCH 31257 . 31518) (IV.INIT 31520 . 33296) (\CLEAR.IRIS 33298 . 33558) (IRIS.DEGREES 33560 . 33827)) (33830 35177 (IV.ITEMMAPFN 33840 . 34061) ( IV.DISPLAY.FMITEM 34063 . 35175)) (35819 55207 (SKULLO 35829 . 55205))))) STOP \ No newline at end of file diff --git a/lispusers/KEYOBJ b/lispusers/KEYOBJ new file mode 100644 index 00000000..7603cd31 --- /dev/null +++ b/lispusers/KEYOBJ @@ -0,0 +1 @@ +(FILECREATED "19-Nov-85 12:22:23" {ERIS}GREGCO>KEYOBJ.;3 10904 changes to: (FNS KEYOBJ.BUTTONEVENTINFN KEYOBJ.CREATE) previous date: "28-Jan-85 01:34:31" {ERIS}KOTO>LISPUSERS>KEYOBJ.;1) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT KEYOBJCOMS) (RPAQQ KEYOBJCOMS ((FNS KEYOBJ.BUTTONEVENTINFN KEYOBJ.COPYFN KEYOBJ.CREATE KEYOBJ.DISPLAYFN KEYOBJ.GETFN KEYOBJ.IMAGEBOXFN KEYOBJ.IMAGESTREAMTYPE KEYOBJ.INSTALL.BITMAP KEYOBJ.PUTFN KEYOBJ.WHENOPERATEDONFN TYPEA) [VARS (KEYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION KEYOBJ.DISPLAYFN) (FUNCTION KEYOBJ.IMAGEBOXFN) (FUNCTION KEYOBJ.PUTFN) (FUNCTION KEYOBJ.GETFN) (FUNCTION KEYOBJ.COPYFN) (FUNCTION KEYOBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL] (INITVARS (KEYOBJ.FONT (FONTCREATE (QUOTE HELVETICA) 10))) (BITMAPS KEYOBJ.TEMPLATE))) (DEFINEQ (KEYOBJ.BUTTONEVENTINFN [LAMBDA (KEYOBJ WINDOWSTREAM SEL RELX RELY WINDOW TEXTSTREAM BUTTON) (* gbn "19-Nov-85 12:21") (* * gets called when the "key" goes down. sends the down transition, inverts the bitmap of the key, when the mouse comes up, uninverts the picture and sends the up transition) (* * NOTE: inside buttoneventinfn's the origin is the left bottom of the imageobj) (PROG ((KEYNUMBER (IMAGEOBJPROP KEYOBJ (QUOTE KEYNUMBER))) (ABORTABLE (IMAGEOBJPROP KEYOBJ (QUOTE ABORTABLE))) (IMAGEBOX (IMAGEOBJPROP KEYOBJ (QUOTE IMAGEBOX))) X Y) (IMAGEOBJPROP KEYOBJ (QUOTE STATE) (QUOTE DOWN)) (IMAGEOBJPROP KEYOBJ (QUOTE WINDOW) (fetch \WINDOW of (TEXTOBJ TEXTSTREAM))) (KEYOBJ.DISPLAYFN KEYOBJ WINDOWSTREAM NIL NIL T) (if ABORTABLE then (* since this is an abortable key don't send any  transitions until the key comes up) NIL else (* send the down transition) (\DECODETRANSITION KEYNUMBER T)) (while (MOUSESTATE (OR LEFT MIDDLE RIGHT)) do NIL) (IMAGEOBJPROP KEYOBJ (QUOTE STATE) (QUOTE UP)) (KEYOBJ.DISPLAYFN KEYOBJ WINDOWSTREAM NIL NIL T) (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) (if (AND (ILEQ X (fetch XSIZE of IMAGEBOX)) (IGEQ X 0) (ILEQ Y (fetch YSIZE of IMAGEBOX)) (IGEQ Y 0)) then (* only send the transition if the mouse is still in the region. This is not consistent with the key metaphor,  however, the menu functionality is useful) (if ABORTABLE then (* now send the saved down transition) (\DECODETRANSITION KEYNUMBER T)) (\DECODETRANSITION KEYNUMBER)) (RETURN (QUOTE DON'T]) (KEYOBJ.COPYFN [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* jds "10-Jan-85 01:03") (* * shouldn't be called) (* (SHOULDNT "why are you copying a keyobj?")) (KEYOBJ.CREATE (IMAGEOBJPROP IMAGEOBJ (QUOTE KEYNAME)) TOSTREAM]) (KEYOBJ.CREATE [LAMBDA (KEYNAME KEYLABEL ABORTABLE) (* gbn "19-Nov-85 12:05") (PROG ((KEYOBJ (IMAGEOBJCREATE NIL KEYOBJ.IMAGEFNS)) BITMAP (KEYLABEL (OR KEYLABEL KEYNAME)) DS) (IMAGEOBJPROP KEYOBJ (QUOTE STATE) (QUOTE UP)) (IMAGEOBJPROP KEYOBJ (QUOTE KEYNUMBER) (\KEYNAMETONUMBER KEYNAME)) (IMAGEOBJPROP KEYOBJ (QUOTE KEYNAME) KEYNAME) (IMAGEOBJPROP KEYOBJ (QUOTE KEYLABEL) KEYLABEL) (IMAGEOBJPROP KEYOBJ (QUOTE ABORTABLE) ABORTABLE) (KEYOBJ.INSTALL.BITMAP KEYOBJ) (SETQ BITMAP (IMAGEOBJPROP KEYOBJ (QUOTE BITMAP))) (IMAGEOBJPROP KEYOBJ (QUOTE IMAGEBOX) (create IMAGEBOX XSIZE _(BITMAPWIDTH BITMAP) YSIZE _(BITMAPHEIGHT BITMAP) YDESC _ 0 XKERN _ 0)) (RETURN KEYOBJ]) (KEYOBJ.DISPLAYFN [LAMBDA (KEYOBJ IMAGE.STREAM MODE TEXTSTREAM OFFSETS0?) (* jds "10-Jan-85 01:02") (* function which displays the bitmap of the hrule on  the display or calls an {inter}press function to draw  the rule on a file) (PROG [[SOURCETYPE (SELECTQ (IMAGEOBJPROP KEYOBJ (QUOTE STATE)) (UP (QUOTE INPUT)) (DOWN (QUOTE INVERT)) (ERROR "Illegal state in KEYOBJ" (IMAGEOBJPROP KEYOBJ (QUOTE STATE] (BITMAP (IMAGEOBJPROP KEYOBJ (QUOTE BITMAP] (* (IMAGE.STREAM (IMAGEOBJPROP KEYOBJ  (QUOTE WINDOW)))) (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) [DISPLAY (* (PROMPTPRINT (CONCAT (IMAGEOBJPROP KEYOBJ (QUOTE STATE)) "CLIP " (DSPCLIPPINGREGION NIL IMAGE.STREAM) " OFFSETS"  (DSPXOFFSET NIL IMAGE.STREAM) " " (DSPYOFFSET NIL IMAGE.STREAM) " X AND Y POS " (DSPXPOSITION NIL IMAGE.STREAM) " "  (DSPYPOSITION NIL IMAGE.STREAM))) (INVERTW IMAGE.STREAM)) (if OFFSETS0? then (BITBLT BITMAP NIL NIL IMAGE.STREAM 0 0 NIL NIL SOURCETYPE (QUOTE REPLACE)) else (BITBLT BITMAP NIL NIL IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM) (DSPYPOSITION NIL IMAGE.STREAM) NIL NIL SOURCETYPE (QUOTE REPLACE] (ERROR "NO OTHER STREAMS DEFINED FOR KEYOBJ.DISPLAYFN"]) (KEYOBJ.GETFN [LAMBDA (INPUT.STREAM TEXTSTREAM) (* gbn "27-Jan-85 23:36") (* * just reads the keyname and calls keyobj.create) (KEYOBJ.CREATE (READ INPUT.STREAM) (READ INPUT.STREAM]) (KEYOBJ.IMAGEBOXFN [LAMBDA (KEYOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* gbn " 9-Jan-85 21:35") (* * since all keyobjs have constant dimensions, they are cached as the imagebox prop) (IMAGEOBJPROP KEYOBJ (QUOTE IMAGEBOX]) (KEYOBJ.IMAGESTREAMTYPE [LAMBDA (STREAM) (* gbn "13-May-84 12:38") (* hack until imagestreamtype works) (if (STKPOS (QUOTE TEDIT.HARDCOPY)) then (QUOTE INTERPRESS) else (QUOTE DISPLAY]) (KEYOBJ.INSTALL.BITMAP (LAMBDA (KEYOBJ) (* edited: "18-Jan-85 18:52") (* * Takes an imageobj and installs the image according to the size and label on the props) (PROG ((BITMAP (BITMAPCOPY KEYOBJ.TEMPLATE)) (KEYLABEL (IMAGEOBJPROP KEYOBJ (QUOTE KEYLABEL))) DS QUARTER) (SETQ DS (DSPCREATE BITMAP)) (DSPFONT KEYOBJ.FONT DS) (if (LISTP KEYLABEL) then (* this is supposed to have two labels, one on top of  the other) (SETQ QUARTER (IQUOTIENT (BITMAPHEIGHT BITMAP) 4)) (CENTERPRINTINREGION (CADR KEYLABEL) (SETQ REGION (create REGION LEFT _ 0 BOTTOM _ QUARTER WIDTH _ (BITMAPWIDTH BITMAP) HEIGHT _ QUARTER)) DS) (replace BOTTOM of REGION with (ITIMES 2 QUARTER)) (CENTERPRINTINREGION (CAR KEYLABEL) REGION DS) else (CENTERPRINTINREGION KEYLABEL (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (BITMAPWIDTH BITMAP) HEIGHT _ (BITMAPHEIGHT BITMAP)) DS)) (CLOSEF DS) (IMAGEOBJPROP KEYOBJ (QUOTE BITMAP) BITMAP) (RETURN KEYOBJ)))) (KEYOBJ.PUTFN [LAMBDA (KEYOBJ OUTPUT.STREAM) (* gbn "27-Jan-85 23:35") (* prints only the rule.width to the file, the rest can be discovered) (PRINT (IMAGEOBJPROP KEYOBJ (QUOTE KEYNAME)) OUTPUT.STREAM) (PRINT (IMAGEOBJPROP KEYOBJ (QUOTE KEYLABEL)) OUTPUT.STREAM]) (KEYOBJ.WHENOPERATEDONFN [LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23") (* DUMMY) ]) (TYPEA [LAMBDA NIL (* gbn " 9-Jan-85 21:09") (* fakes typing an A) (\DT 46 T) (\DT 46 NIL]) ) (RPAQ KEYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION KEYOBJ.DISPLAYFN) (FUNCTION KEYOBJ.IMAGEBOXFN) (FUNCTION KEYOBJ.PUTFN) (FUNCTION KEYOBJ.GETFN) (FUNCTION KEYOBJ.COPYFN) (FUNCTION KEYOBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))) (RPAQ? KEYOBJ.FONT (FONTCREATE (QUOTE HELVETICA) 10)) (RPAQ KEYOBJ.TEMPLATE (READBITMAP)) (80 50 "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO" "OO@@@@@@@@@@@@@@@@OO" "OH@@@@@@@@@@@@@@@@AO" "OH@@@@@@@@@@@@@@@@AO" "NL@@@@@@@@@@@@@@@@BG" "OFCOOOOOOOOOOOOOOLDG" "NKF@@@@@@@@@@@@@@FHG" "MEH@@@@@@@@@@@@@@A@C" "NK@@@@@@@@@@@@@@@@HC" "MG@@@@@@@@@@@@@@@@LC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NJ@@@@@@@@@@@@@@@@DC" "MF@@@@@@@@@@@@@@@@DC" "NK@@@@@@@@@@@@@@@@LC" "ME@@@@@@@@@@@@@@@@HC" "NKH@@@@@@@@@@@@@@A@C" "OBN@@@@@@@@@@@@@@GHG" "NDKOOOOOOOOOOOOOONLG" "OIAEEEEEEEEEEEEEEEFG" "OBBJJJJJJJJJJJJJJJKO" "OLEEEEEEEEEEEEEEEEEO" "ONBJJJJJJJJJJJJJJJOO" "OOOOOOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOOOOOO") (PUTPROPS KEYOBJ COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (1109 9187 (KEYOBJ.BUTTONEVENTINFN 1119 . 3259) (KEYOBJ.COPYFN 3261 . 3611) ( KEYOBJ.CREATE 3613 . 4559) (KEYOBJ.DISPLAYFN 4561 . 6043) (KEYOBJ.GETFN 6045 . 6300) ( KEYOBJ.IMAGEBOXFN 6302 . 6570) (KEYOBJ.IMAGESTREAMTYPE 6572 . 6913) (KEYOBJ.INSTALL.BITMAP 6915 . 8327 ) (KEYOBJ.PUTFN 8329 . 8751) (KEYOBJ.WHENOPERATEDONFN 8753 . 8954) (TYPEA 8956 . 9185))))) STOP \ No newline at end of file diff --git a/lispusers/KEYOBJ.TEDIT b/lispusers/KEYOBJ.TEDIT new file mode 100644 index 00000000..a46b48fa Binary files /dev/null and b/lispusers/KEYOBJ.TEDIT differ diff --git a/lispusers/KINETIC b/lispusers/KINETIC new file mode 100644 index 00000000..df019d87 --- /dev/null +++ b/lispusers/KINETIC @@ -0,0 +1 @@ +(FILECREATED " 2-Apr-86 00:14:01" {ERIS}KOTO>KINETIC.;2 1626 changes to: (VARS KINETICCOMS) previous date: " 3-Dec-85 14:17:48" {ERIS}KOTO>KINETIC.;1) (* Copyright (c) 1982, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT KINETICCOMS) (RPAQQ KINETICCOMS ((FNS KINETIC) (VARS (CHECKSHADE 63903) (KINETICWINDOW)) (ALISTS (IDLE.FUNCTIONS Kinetic)))) (DEFINEQ (KINETIC [LAMBDA (WINDOW) (* lmm " 3-Dec-85 14:16") (* test example (KINETICDEMO)  (SETQ CHECKSHADE (EDITSHADE CHECKSHADE))) [OR (WINDOWP WINDOW) (SETQ WINDOW (OR KINETICWINDOW (SETQ KINETICWINDOW (CREATEW NIL "Kinetic Window"] (PROG ((WD (WINDOWPROP WINDOW (QUOTE WIDTH))) (HT (WINDOWPROP WINDOW (QUOTE HEIGHT))) X Y) (do (SETQ X (RAND 0 WD)) (SETQ Y (RAND 0 HT)) (BITBLT NIL NIL NIL WINDOW (RAND 0 (IDIFFERENCE WD X)) (RAND 0 (IDIFFERENCE HT Y)) X Y (QUOTE TEXTURE) (SELECTQ (RAND 0 5) (0 (QUOTE PAINT)) (QUOTE INVERT)) (SELECTQ (AND CHECKSHADE (RAND 0 12)) (0 CHECKSHADE) BLACKSHADE)) (BLOCK]) ) (RPAQQ CHECKSHADE 63903) (RPAQQ KINETICWINDOW NIL) (ADDTOVAR IDLE.FUNCTIONS (Kinetic (QUOTE KINETIC))) (PUTPROPS KINETIC COPYRIGHT ("Xerox Corporation" 1982 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (447 1420 (KINETIC 457 . 1418))))) STOP \ No newline at end of file diff --git a/lispusers/KINETIC.TEDIT b/lispusers/KINETIC.TEDIT new file mode 100644 index 00000000..fb293971 Binary files /dev/null and b/lispusers/KINETIC.TEDIT differ diff --git a/lispusers/KOTOLOGO b/lispusers/KOTOLOGO new file mode 100644 index 00000000..27e87d7d --- /dev/null +++ b/lispusers/KOTOLOGO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "17-Aug-88 03:42:15" {erinyes}medley>kotologo.\;1 3467 |changes| |to:| (vars kotologocoms) (fns kotologow)) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint kotologocoms) (rpaqq kotologocoms ((fns kotologow \\drawlogowindowimage))) (defineq (kotologow (lambda (string where title angledelta) (* |edited:| " 1-AUG-83 22:55") (* |creates| \a |logo| |window.|) (prog ((circlesize 60) (logoxcenter 70) (logoycenter 65) (logowindowheight 180) w logowindowwidth wimagewidth wimageheight (string (or string "Interlisp-D"))) (or angledelta (setq angledelta 23)) (setq wimagewidth (fix (ftimes circlesize 0.62))) (setq wimageheight (fix (ftimes circlesize 0.5))) (setq logowindowwidth (iplus logoxcenter 30 wimagewidth (stringwidth string '(timesromand 36)))) (setq w (cond ((typenamep where 'window) where) (t (createw (cond ((positionp where) (|create| region left _ (|fetch| (position xcoord) |of| where) bottom _ (|fetch| (position ycoord) |of| where) width _ logowindowwidth height _ logowindowheight)) (t (getboxregion logowindowwidth logowindowheight nil nil nil "Specify location for logo window."))) (or title (concat "Copyright (c) by Xerox Corporation" " " (or makesysdate (date)))))))) (|for| angle |from| 0 |to| 270 |by| angledelta |do| (\\drawlogowindowimage (iplus logoxcenter (ftimes circlesize (cos angle))) (iplus logoycenter (ftimes circlesize (sin angle))) wimagewidth wimageheight 2 w)) (moveto (iplus logoxcenter 10 wimagewidth) (iplus 2 (idifference logoycenter circlesize)) w) (dspfont '(timesromand 36) w) (prin3 string w) (return w)))) (\\drawlogowindowimage (lambda (xpos ypos width height border w) (* |rrb| "22-FEB-82 18:04") (* |makes| \a |window| |image.|  |This| |is| |part| |of| |the| |logo|  |drawing.|) (bitblt nil nil nil w xpos ypos width height 'texture 'replace blackshade) (bitblt nil nil nil w (iplus border xpos) (iplus border ypos) (idifference width (itimes border 2)) (idifference height (itimes border 3)) 'texture 'replace whiteshade))) ) (putprops kotologo copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil (393 3387 (kotologow 403 . 2682) (\\drawlogowindowimage 2684 . 3385))))) stop \ No newline at end of file diff --git a/lispusers/KOTOLOGO.TEDIT b/lispusers/KOTOLOGO.TEDIT new file mode 100644 index 00000000..ecb4ce39 Binary files /dev/null and b/lispusers/KOTOLOGO.TEDIT differ diff --git a/lispusers/LABEL b/lispusers/LABEL new file mode 100644 index 00000000..3fe04380 --- /dev/null +++ b/lispusers/LABEL @@ -0,0 +1 @@ +(FILECREATED "19-Feb-87 09:57:38" {QV}PARSER>NEXT>LABEL.;1 986 previous date: " 5-JAN-83 18:06:12" {ERIS}KOTO>LIBRARY>LABEL.;1) (* Copyright (c) 1983, 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT LABELCOMS) (RPAQQ LABELCOMS ((FNS DOLABEL) (ALISTS (LAMBDATRANFNS LABEL)) (ADDVARS (LAMBDASPLST LABEL)) (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LAMBDATRAN))) (DEFINEQ (DOLABEL [LAMBDA (X) (* lmm " 5-JAN-83 18:04") (PROG [(NAME (CAR (CDR X))) (ARGS (CADR (CDR X))) (FORMS (CDDR (CDR X] (RETURN (BQUOTE (LAMBDA , ARGS ([LAMBDA (, NAME) (APPLY* , NAME ,. ARGS] (FUNCTION (LAMBDA , ARGS ,. FORMS]) ) (ADDTOVAR LAMBDATRANFNS (LABEL DOLABEL)) (ADDTOVAR LAMBDASPLST LABEL) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LAMBDATRAN) (PUTPROPS LABEL COPYRIGHT ("Xerox Corporation" 1983 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (445 754 (DOLABEL 455 . 752))))) STOP \ No newline at end of file diff --git a/lispusers/LAFITE-INDENT b/lispusers/LAFITE-INDENT new file mode 100644 index 00000000..4c90b8dd --- /dev/null +++ b/lispusers/LAFITE-INDENT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "22-Jan-87 01:34:36" {ERIS}LISPCORE>LAFITE-INDENT.;1 25845 previous date%: "21-Jan-87 16:06:01" {ERIS}KOTO>LAFITE-INDENT.;5) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITE-INDENTCOMS) (RPAQQ LAFITE-INDENTCOMS [(* * LAFITE-INDENT defines a function that will indent the current selection.) (FNS TEDIT-INDENT-ADD-INDENTATION TEDIT-INDENT-BREAK-LINE TEDIT-INDENT-BREAK-LONG-LINES TEDIT-INDENT-FIND-BREAKPOINT TEDIT-INDENT-REPLACE-SELECTION TEDIT-INDENT-SELECTION TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS TEDIT-INDENT-SEPERATE-PARAGRAPHS TEDIT-INDENT-SET-INDENT TEDIT-INDENT-STRIP-INDENTATION TEDIT-MAKE-LINES-EXPLICIT TEDIT-OPEN-LINE TEDIT-REMOVE-INDENT \TEDIT-INDENT-COUNT-SPACES \TEDIT-INDENT-FIND-PARAGRAPH-END \TEDIT-INDENT-SEPERATE-LINES \TEDIT-INDENT-SEPERATE-PARAGRAPHS) (INITVARS (*TEDIT-INDENT-STRING* (ALLOCSTRING 4 " ")) (*TEDIT-INDENT-LINE-LENGTH* 72)) [CONSTANTS (*eol-string* (CHARACTER (CHARCODE EOL] (GLOBALVARS *TEDIT-INDENT-STRING* *TEDIT-INDENT-LINE-LENGTH*) (P (OR (GETD 'TEDIT) (FILESLOAD TEDIT)) (TEDIT.REMOVE.MENUITEM TEDIT.DEFAULT.MENU 'Indent) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Indent 'TEDIT-INDENT-SELECTION "Indent the current selection" (SUBITEMS (Indent 'TEDIT-INDENT-SELECTION "Indent the current selection" ) ("Indent & keep lines" ' TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS "Indent the current selection, keeping existing line breaks" ) ("Set indent" ' TEDIT-INDENT-SET-INDENT "Set the indent string to a new value" ) (Unindent 'TEDIT-REMOVE-INDENT "Remove one level of indentation from the current selection" ) ("Open line" 'TEDIT-OPEN-LINE "Open a blank line at the current position" ) ("Insert s" ' TEDIT-MAKE-LINES-EXPLICIT "Insert real s at the end of each line in the current selection" ) ("Break long lines" ' TEDIT-INDENT-BREAK-LONG-LINES "Break long lines by inserting explicit 's" ]) (* * LAFITE-INDENT defines a function that will indent the current selection.) (DEFINEQ (TEDIT-INDENT-ADD-INDENTATION [LAMBDA (paragraph indent-string right-margin hanging-indent) (* smL "15-Sep-86 16:47") (* * Return a string based on the given string but with the indentation changed  by the given amount. -  Break lines at or before the given right-margin.  -  If hanging-indent is given, then the first line is already indented by that  amount.) (if [for i from 1 to (NCHARS paragraph) always (MEMB (NTHCHARCODE paragraph i) (CONSTANT (LIST (CHARCODE SPACE) (CHARCODE EOL] then paragraph else (LET* [[old-indent (\TEDIT-INDENT-COUNT-SPACES paragraph (ADD1 (OR (STRPOS *eol-string* paragraph) (NCHARS paragraph] (new-indent (PLUS (NCHARS indent-string) old-indent)) (new-indent-string (CONCAT indent-string (ALLOCSTRING old-indent " "] (CONCATLIST (for string on (TEDIT-INDENT-BREAK-LINE (CONCAT (if (NUMBERP hanging-indent) then "" else indent-string) (TEDIT-INDENT-STRIP-INDENTATION paragraph)) (DIFFERENCE right-margin (PLUS new-indent (OR (NUMBERP hanging-indent ) 0))) (DIFFERENCE right-margin new-indent)) join (if (CDR string) then (LIST (CAR string) *eol-string* new-indent-string) else (LIST (CAR string]) (TEDIT-INDENT-BREAK-LINE [LAMBDA (string first-line-max-length max-length) (* smL "26-Sep-86 19:42") (* * Return a list of strings equivilent to the input string, but with no  single string containing more than max-length characters and the first line  having no more than first-line-max-length characters) (if (OR (NULL string) (STRING-EQUAL string "") (STRING-EQUAL string *eol-string*)) then NIL else (LET ((existing-eol (STRPOSL [DEFERREDCONSTANT (MAKEBITTABLE (LIST (CHARCODE EOL] string))) (if (OR (AND (NULL existing-eol) (LEQ (NCHARS string) first-line-max-length)) (AND (NUMBERP existing-eol) (EQ existing-eol (NCHARS string)) (LEQ existing-eol first-line-max-length))) then (* the string fits on a single line) (LIST string) else (LET [(break-point (if (AND (NUMBERP existing-eol) (LESSP existing-eol first-line-max-length)) then existing-eol else (TEDIT-INDENT-FIND-BREAKPOINT string first-line-max-length] (CONS (OR (SUBSTRING string 1 (SUB1 break-point)) "") (TEDIT-INDENT-BREAK-LINE (OR (SUBSTRING string (ADD1 break-point)) "") max-length max-length]) (TEDIT-INDENT-BREAK-LONG-LINES [LAMBDA (text-stream explicit-paragraph-breaks?) (* smL "21-Jan-87 16:03") (* * Break the current selection into explicit lines, each having no more than  *TEDIT-INDENT-LINE-LENGTH* characters. -  If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in  the current selection are removed. -  This is intended to be used in Lafite, where one wants to indent a piece of a  forwarded document, but can be used in any TEdit document) (LET ((selection (TEDIT.GETSEL text-stream))) (TEDIT-INDENT-REPLACE-SELECTION text-stream selection (CONCATLIST (for string on (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING text-stream selection) explicit-paragraph-breaks?) bind [hanging-indent _ (AND (NOT (EQP (fetch CHAR1 of (CAR (fetch L1 of selection))) (fetch CH# of selection))) (DIFFERENCE (fetch CH# of selection) (fetch CHAR1 of (CAR (fetch L1 of selection] join (PROG1 (LIST (TEDIT-INDENT-ADD-INDENTATION (CAR string) "" *TEDIT-INDENT-LINE-LENGTH* hanging-indent) *eol-string*) (SETQ hanging-indent NIL]) (TEDIT-INDENT-FIND-BREAKPOINT [LAMBDA (string max-length) (* smL " 8-Sep-86 14:23") (* * Return the position to break string so that it will contain no more than  max-length characters -  if there is no whitespace before max-length characters, break it at the first  whitespace after max-length) (LET [(white-space-chars (DEFERREDCONSTANT (MAKEBITTABLE (LIST (CHARCODE SPACE) (CHARCODE TAB) (CHARCODE EOL] (OR (STRPOSL white-space-chars string max-length NIL T) (STRPOSL white-space-chars string max-length NIL NIL) (ADD1 (NCHARS string]) (TEDIT-INDENT-REPLACE-SELECTION [LAMBDA (text-stream selection new-text) (* smL " 8-Sep-86 17:44") (* * Replace the given selection in the text stream with the new-text.  End up with the new-text selected.) (LET ((start (fetch CH# of selection))) (TEDIT.SETSEL text-stream start (fetch DCH of selection) 'LEFT T) (TEDIT.INSERT text-stream new-text) (TEDIT.SETSEL text-stream start (NCHARS new-text) 'RIGHT]) (TEDIT-INDENT-SELECTION [LAMBDA (text-stream explicit-paragraph-breaks?) (* smL "21-Jan-87 16:00") (* * Indent the current selection by prefacing each line with the value of  *TEDIT-INDENT-STRING*, and inserting line breaks after each  *TEDIT-INDENT-LINE-LENGTH* characters. -  If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in  the current selection are removed. -  This is intended to be used in Lafite, where one wants to indent a piece of a  forwarded document, but can be used in any TEdit document) (LET ((selection (TEDIT.GETSEL text-stream))) (TEDIT-INDENT-REPLACE-SELECTION text-stream selection (CONCATLIST (for string on (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING text-stream selection) explicit-paragraph-breaks?) bind [hanging-indent _ (AND (NOT (EQP (fetch CHAR1 of (CAR (fetch L1 of selection))) (fetch CH# of selection))) (DIFFERENCE (fetch CH# of selection) (fetch CHAR1 of (CAR (fetch L1 of selection] join (PROG1 (LIST (TEDIT-INDENT-ADD-INDENTATION (CAR string) *TEDIT-INDENT-STRING* *TEDIT-INDENT-LINE-LENGTH* hanging-indent) *eol-string*) (SETQ hanging-indent NIL]) (TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS [LAMBDA (text-stream) (* smL "12-Sep-86 16:58") (* * Indent the current selection, keeping current line breaks) (TEDIT-INDENT-SELECTION text-stream T]) (TEDIT-INDENT-SEPERATE-PARAGRAPHS [LAMBDA (string explicit-paragraph-breaks?) (* smL "12-Sep-86 09:54") (* * Return a list of strings, each comprising a seperate paragraph, that taken  together make up the given string. -  If explicit-paragraph-breaks? is true, paragraphs are delimited by 's,  otherwise paragraphs are delimited by a change in indentation after the second  line.) (if (NOT (STRINGP string)) then NIL elseif explicit-paragraph-breaks? then (\TEDIT-INDENT-SEPERATE-LINES string NIL) else (\TEDIT-INDENT-SEPERATE-PARAGRAPHS string NIL]) (TEDIT-INDENT-SET-INDENT [LAMBDA (text-stream) (* smL "12-Sep-86 17:09") (* * Prompt the user for a new indentation string) (LET* ((window (fetch \WINDOW of (TEXTOBJ text-stream))) (pwindow (if window then (GETPROMPTWINDOW (if (LISTP window) then (CAR window) else window)) else PROMPTWINDOW))) (CLEARW pwindow) (SETQ *TEDIT-INDENT-STRING* (PROMPTFORWORD "New indent string: " *TEDIT-INDENT-STRING* NIL pwindow NIL NIL (LIST (CHARCODE EOL]) (TEDIT-INDENT-STRIP-INDENTATION [LAMBDA (paragraph first-line-too?) (* smL "15-Sep-86 17:03") (* * Remove indentation from the given string) (bind (string _ paragraph) (eol-pos _ 1) while (SETQ eol-pos (STRPOS *eol-string* string)) do [SETQ string (if (EQP eol-pos (NCHARS string)) then (SUBSTRING string 1 (SUB1 eol-pos)) else (CONCAT (SUBSTRING string 1 (SUB1 eol-pos)) " " (OR [SUBSTRING string (PLUS 1 eol-pos (  \TEDIT-INDENT-COUNT-SPACES string (ADD1 eol-pos] ""] finally (RETURN (if first-line-too? then (OR (SUBSTRING string (ADD1 (\TEDIT-INDENT-COUNT-SPACES string 1))) "") else string]) (TEDIT-MAKE-LINES-EXPLICIT [LAMBDA (text-stream) (* smL " 8-Sep-86 18:20") (* * Take the current selection and replace all TEdit end-of-lines with  explicit line breaks. -  This is intended to be used in Lafite, where it is sometimes nice to know that  anyone receiving the msg will see the same line breaks that you see.  see, but can be used in any TEdit document) (LET ((selection (TEDIT.GETSEL text-stream))) [for i in (bind (this-line _ (CAR (fetch L1 of selection))) [last-line _ (CAR (LAST (fetch LN of selection] repeatuntil (PROGN (SETQ this-line (fetch NEXTLINE of this-line)) (EQ this-line last-line)) collect (fetch CHARLIM of this-line)) do (TEDIT.SETSEL text-stream i 1 'LEFT T) (TEDIT.INSERT text-stream (CONSTANT (CHARACTER (CHARCODE EOL] (TEDIT.SETSEL text-stream selection NIL 'RIGHT]) (TEDIT-OPEN-LINE [LAMBDA (text-stream) (* smL "17-Sep-86 11:13") (* * Open a new line at the current position.) (LET ((selection (TEDIT.GETSEL text-stream))) (TEDIT.INSERT text-stream (CONCAT *eol-string* (ALLOCSTRING [DIFFERENCE (fetch CH# of selection) (fetch CHAR1 of (CAR (fetch L1 of selection] " "))) (if (ZEROP (fetch DCH of selection)) then (TEDIT.SETSEL text-stream selection]) (TEDIT-REMOVE-INDENT [LAMBDA (text-stream) (* smL "15-Sep-86 17:03") (* * Remove the indentation from the current selection) (LET ((selection (TEDIT.GETSEL text-stream))) (TEDIT-INDENT-REPLACE-SELECTION text-stream selection (CONCATLIST (for paragraph in (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING text-stream selection)) join (LIST (TEDIT-INDENT-STRIP-INDENTATION paragraph T) *eol-string*]) (\TEDIT-INDENT-COUNT-SPACES [LAMBDA (string start-pos) (* smL "12-Sep-86 14:29") (* * Count the number of spaces following position start-pos in string) (if (NOT (STRINGP string)) then 0 else (DIFFERENCE [for i from start-pos bind (max-pos _ (NCHARS string)) thereis (OR (GREATERP i max-pos) (NOT (EQP (NTHCHARCODE string i) (CHARCODE SPACE] start-pos]) (\TEDIT-INDENT-FIND-PARAGRAPH-END [LAMBDA (string paragraph-indent after-pos) (* smL "15-Sep-86 15:53") (* * Find the end of paragraph that has the given indent and contains the given  position in the string) (LET [(eol-pos (STRPOS *eol-string* string (ADD1 after-pos] (if (NULL eol-pos) then (ADD1 (NCHARS string)) elseif (for i from (ADD1 after-pos) to (SUB1 eol-pos) always (EQP (CHARCODE SPACE) (NTHCHARCODE string i))) then after-pos elseif (EQP eol-pos (NCHARS string)) then eol-pos elseif (EQP paragraph-indent (\TEDIT-INDENT-COUNT-SPACES string (ADD1 eol-pos))) then (\TEDIT-INDENT-FIND-PARAGRAPH-END string paragraph-indent eol-pos) else eol-pos]) (\TEDIT-INDENT-SEPERATE-LINES [LAMBDA (remaining-string current-lines) (* smL "21-Jan-87 15:58") (* * Return a list of lines that make up the remaining-string, with the reverse  of current-lines appended to the front) (if (NOT (STRINGP remaining-string)) then (OR (DREVERSE current-lines) (LIST "")) else (LET [(eol-pos (OR (STRPOS *eol-string* remaining-string) (ADD1 (NCHARS remaining-string] (\TEDIT-INDENT-SEPERATE-LINES (SUBSTRING remaining-string (ADD1 eol-pos)) (CONS (OR (SUBSTRING remaining-string 1 (SUB1 eol-pos)) "") current-lines]) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS [LAMBDA (string current-paragraphs) (* smL "15-Sep-86 15:54") (* * Return a list of strings, each comprising a seperate paragraph, that taken  together make up the given string. Paragraphs are delimited by a change in  indentation after the second line, or a blank line.) (if (NOT (STRINGP string)) then (DREVERSE current-paragraphs) else (LET ((eol-pos (STRPOS *eol-string* string))) (if (NULL eol-pos) then (DREVERSE (CONS string current-paragraphs)) elseif (for i from 1 to (SUB1 eol-pos) always (EQP (CHARCODE SPACE) (NTHCHARCODE string i))) then (\TEDIT-INDENT-SEPERATE-PARAGRAPHS (SUBSTRING string (ADD1 eol-pos)) (CONS "" current-paragraphs)) elseif (EQP eol-pos (NCHARS string)) then (DREVERSE (CONS string current-paragraphs)) else (LET ((para-end-pos (\TEDIT-INDENT-FIND-PARAGRAPH-END string (\TEDIT-INDENT-COUNT-SPACES string (ADD1 eol-pos)) eol-pos))) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS (SUBSTRING string (ADD1 para-end-pos)) (CONS (OR (SUBSTRING string 1 (SUB1 para-end-pos)) "") current-paragraphs]) ) (RPAQ? *TEDIT-INDENT-STRING* (ALLOCSTRING 4 " ")) (RPAQ? *TEDIT-INDENT-LINE-LENGTH* 72) (DECLARE%: EVAL@COMPILE (RPAQ *eol-string* (CHARACTER (CHARCODE EOL))) [CONSTANTS (*eol-string* (CHARACTER (CHARCODE EOL] ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *TEDIT-INDENT-STRING* *TEDIT-INDENT-LINE-LENGTH*) ) (OR (GETD 'TEDIT) (FILESLOAD TEDIT)) (TEDIT.REMOVE.MENUITEM TEDIT.DEFAULT.MENU 'Indent) [TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Indent 'TEDIT-INDENT-SELECTION "Indent the current selection" (SUBITEMS (Indent 'TEDIT-INDENT-SELECTION "Indent the current selection") ("Indent & keep lines" ' TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS "Indent the current selection, keeping existing line breaks" ) ("Set indent" 'TEDIT-INDENT-SET-INDENT "Set the indent string to a new value") (Unindent 'TEDIT-REMOVE-INDENT "Remove one level of indentation from the current selection" ) ("Open line" 'TEDIT-OPEN-LINE "Open a blank line at the current position" ) ("Insert s" 'TEDIT-MAKE-LINES-EXPLICIT "Insert real s at the end of each line in the current selection" ) ("Break long lines" ' TEDIT-INDENT-BREAK-LONG-LINES "Break long lines by inserting explicit 's" ] (PUTPROPS LAFITE-INDENT COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3949 23354 (TEDIT-INDENT-ADD-INDENTATION 3959 . 6527) (TEDIT-INDENT-BREAK-LINE 6529 . 8462) (TEDIT-INDENT-BREAK-LONG-LINES 8464 . 10231) (TEDIT-INDENT-FIND-BREAKPOINT 10233 . 11056) ( TEDIT-INDENT-REPLACE-SELECTION 11058 . 11615) (TEDIT-INDENT-SELECTION 11617 . 13518) ( TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS 13520 . 13799) (TEDIT-INDENT-SEPERATE-PARAGRAPHS 13801 . 14530) (TEDIT-INDENT-SET-INDENT 14532 . 15306) (TEDIT-INDENT-STRIP-INDENTATION 15308 . 16528) ( TEDIT-MAKE-LINES-EXPLICIT 16530 . 17735) (TEDIT-OPEN-LINE 17737 . 18493) (TEDIT-REMOVE-INDENT 18495 . 19265) (\TEDIT-INDENT-COUNT-SPACES 19267 . 19868) (\TEDIT-INDENT-FIND-PARAGRAPH-END 19870 . 20841) ( \TEDIT-INDENT-SEPERATE-LINES 20843 . 21641) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS 21643 . 23352))))) STOP \ No newline at end of file diff --git a/lispusers/LAFITE-INDENT.TEDIT b/lispusers/LAFITE-INDENT.TEDIT new file mode 100644 index 00000000..018ecb1f Binary files /dev/null and b/lispusers/LAFITE-INDENT.TEDIT differ diff --git a/lispusers/LAFITEABBREV b/lispusers/LAFITEABBREV new file mode 100644 index 00000000..3295b147 --- /dev/null +++ b/lispusers/LAFITEABBREV @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Nov-88 19:37:06" |{NEWTON:EUROPARC:RX}LISP>MEDLEY>LAFITEABBREV.;1| 5987 changes to%: (VARS LAFITEABBREVCOMS) previous date%: "22-Sep-88 13:06:40" |{NEWTON:EUROPARC:RX}LISP>LYRIC>LAFITEABBREV.;7| ) (* " Copyright (c) 1988, 1901 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITEABBREVCOMS) (RPAQQ LAFITEABBREVCOMS ((APPENDVARS (LAFITE.ABBREVS ("*@*:*" "*@*:*" :OUT) ("*@*" "%"*%%*%":GV:Xerox" :IN) ("*@*" "*%%*:GV:Xerox") ("*@*.*" "*%%*:*:Xerox" :IN) ("*.pa" "*:PA:Xerox"))) (INITVARS (LAFITE.ABBREV.DIRECTIONS :BOTH) (LAFITE.ABBREV.MOVE.GAZE.RIGHT T) (LAFITE.ABBREV.TRACE)) (FUNCTIONS SAFEUPPERCHARCODE) (FNS LAFITE.ABBREV LAFITE.ABBREV.MATCH) (ADVISE (NSNAME.TO.STRING :IN \NSMAIL.PRINT.NAMES) (PARSE.NSNAME :IN \NSMAIL.PARSE1)) (GLOBALVARS LAFITE.ABBREVS LAFITE.ABBREV.DIRECTIONS LAFITE.ABBREV.MOVE.GAZE.RIGHT LAFITE.ABBREV.TRACE))) (APPENDTOVAR LAFITE.ABBREVS ("*@*:*" "*@*:*" :OUT) ("*@*" "%"*%%*%":GV:Xerox" :IN) ("*@*" "*%%*:GV:Xerox") ("*@*.*" "*%%*:*:Xerox" :IN) ("*.pa" "*:PA:Xerox")) (RPAQ? LAFITE.ABBREV.DIRECTIONS :BOTH) (RPAQ? LAFITE.ABBREV.MOVE.GAZE.RIGHT T) (RPAQ? LAFITE.ABBREV.TRACE) (DEFMACRO SAFEUPPERCHARCODE (CODE) (BQUOTE (if (AND (NUMBERP (\, CODE)) (LEQ (\, CODE) 255)) THEN (GETCASEARRAY UPPERCASEARRAY (\, CODE)) ELSE (\, CODE)))) (DEFINEQ (LAFITE.ABBREV (LAMBDA (ADDRESS DIRECTION) (* ; "Edited 2-Aug-88 16:48 by Lennart") (* ;;; "Translate Lafite abbreviations to addresses or vice versa. The DIRECTION should be either :IN, :OUT, or :BOTH, defaulting to :OUT if left unspecified. It has to agree with the overall setting of LAFITE.ABBREV.DIRECTIONS for anything to happen. LAFITE.ABBREVS, then, is a list of translations -- each of the form (abbrev address direction), where direction is optional and defaults to LAFITE.ABBREV.DIRECTIONS. For compatibility with TEDIT.ABBREVS, we also support the simpler form (abbrev . address), which is interpreted the same as (abbrev address NIL). Both abbrevations and addresses in LAFITE.ABBREVS may contain wildcards -- read more about this in the documentation.") (OR DIRECTION (SETQ DIRECTION :OUT)) (if (AND LAFITE.ABBREV.DIRECTIONS (OR (EQ LAFITE.ABBREV.DIRECTIONS :BOTH) (EQ LAFITE.ABBREV.DIRECTIONS DIRECTION))) then (for TRAN in LAFITE.ABBREVS bind NEWADDRESS when (AND (LISTP TRAN) (OR (NLISTP (CDR TRAN)) (NULL (CDDR TRAN)) (NOT (LITATOM (CADDR TRAN))) (EQ (CADDR TRAN) :BOTH) (EQ (CADDR TRAN) DIRECTION))) do (if (SETQ NEWADDRESS (LAFITE.ABBREV.MATCH (if (EQ DIRECTION :OUT) then (CAR TRAN) elseif (LISTP (CDR TRAN)) then (CADR TRAN) else (CDR TRAN)) ADDRESS (if (EQ DIRECTION :IN) then (CAR TRAN) elseif (LISTP (CDR TRAN)) then (CADR TRAN) else (CDR TRAN)))) then (* ;; "Success, now make sure there's no percent after the atsign unless user has turned off flag.") (AND LAFITE.ABBREV.MOVE.GAZE.RIGHT (bind (P _ (STRPOSL (CHARCODE (@)) NEWADDRESS)) Q while (AND P (SETQ Q (STRPOSL (CHARCODE (%%)) NEWADDRESS P))) do (RPLCHARCODE NEWADDRESS P (CHARCODE %%)) (RPLCHARCODE NEWADDRESS Q (CHARCODE @)) (SETQ P Q))) (AND LAFITE.ABBREV.TRACE (PRINTOUT LAFITE.ABBREV.TRACE T "[Translating " ADDRESS " to " NEWADDRESS "]")) (SETQ ADDRESS NEWADDRESS) (RETURN)))) ADDRESS) ) (LAFITE.ABBREV.MATCH (LAMBDA (PATTERN STRING TEMPLATE) (* ; "Edited 22-Sep-88 13:03 by Lennart") (DECLARE (LOCALVARS . T)) (* ;;; "Match a test string wrt to a pattern string where asterisks in the pattern act as wildcards, matching zero or more arbitrary characters in the test string. The returned value is NIL or T, or if a template is given, a string merge done by substituting asterisks in the template string for the matched substrings in the test string. Be aware that this functions utilizes the fact that NTHCHARCODE will return NIL for chars outside of the string.") (PROG ((patLen (NCHARS PATTERN)) (strLen (NCHARS STRING)) (temLen (NCHARS TEMPLATE)) (pp 1) (sp 1) (tp 1) pwp swp twp stack matches) LOOP (SETQ pwp pp) (SETQ swp sp) (bind tmp eachtime (SETQ tmp (NTHCHARCODE PATTERN pwp)) (if (EQ tmp (CHARCODE *)) then (RETURN)) while (EQ (SAFEUPPERCHARCODE tmp) (SAFEUPPERCHARCODE (NTHCHARCODE STRING swp))) do (if (IGREATERP pwp patLen) then (GO SUCCEED)) (SETQ pwp (ADD1 pwp)) (SETQ swp (ADD1 swp)) finally (GO BACKTRACK)) (SETQ pp (ADD1 pwp)) (SETQ sp swp) EXTEND (bind (tmp _ (SAFEUPPERCHARCODE (NTHCHARCODE PATTERN pp))) while (NEQ tmp (SAFEUPPERCHARCODE (NTHCHARCODE STRING sp))) do (if (IGREATERP sp strLen) then (GO BACKTRACK)) (SETQ sp (ADD1 sp))) (push stack pp swp sp) (GO LOOP) BACKTRACK (if (NULL stack) then (RETURN NIL)) (SETQ pp (pop stack)) (SETQ swp (pop stack)) (SETQ sp (ADD1 (pop stack))) (GO EXTEND) SUCCEED (if (NOT TEMPLATE) then (RETURN (OR STRING T))) (* ;; "Collect the matched substrings.") (while stack do (SETQ pp (pop stack)) (SETQ swp (pop stack)) (SETQ sp (pop stack)) (push matches (SUBSTRING STRING swp (SUB1 sp)))) (* ;; "Substitute wildcards in the template string.") (RETURN (CONCATLIST (while (LEQ tp temLen) bind result eachtime (SETQ twp (OR (STRPOS "*" TEMPLATE tp) (ADD1 temLen))) do (* ; "Note that (MKLIST NIL) is NIL") (SETQ result (NCONC result (MKLIST (SUBSTRING TEMPLATE tp (SUB1 twp))) (AND (ILEQ twp temLen) (MKLIST (pop matches))))) (SETQ tp (ADD1 twp)) finally (RETURN result)))) FAIL (RETURN NIL))) ) ) (XCL:REINSTALL-ADVICE (QUOTE (NSNAME.TO.STRING :IN \NSMAIL.PRINT.NAMES)) :AFTER (QUOTE ((:LAST (SETQ !VALUE (LAFITE.ABBREV !VALUE :IN)))))) (XCL:REINSTALL-ADVICE (QUOTE (PARSE.NSNAME :IN \NSMAIL.PARSE1)) :BEFORE (QUOTE ((:LAST (SETQ NAME (LAFITE.ABBREV NAME :OUT)))))) (READVISE (NSNAME.TO.STRING :IN \NSMAIL.PRINT.NAMES) (PARSE.NSNAME :IN \NSMAIL.PARSE1)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAFITE.ABBREVS LAFITE.ABBREV.DIRECTIONS LAFITE.ABBREV.MOVE.GAZE.RIGHT LAFITE.ABBREV.TRACE) ) (PUTPROPS LAFITEABBREV COPYRIGHT ("Xerox Corporation" 1988 1901)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1425 5397 (LAFITE.ABBREV 1435 . 3321) (LAFITE.ABBREV.MATCH 3323 . 5395))))) STOP \ No newline at end of file diff --git a/lispusers/LAFITEABBREV.TEDIT b/lispusers/LAFITEABBREV.TEDIT new file mode 100644 index 00000000..2ba6332a Binary files /dev/null and b/lispusers/LAFITEABBREV.TEDIT differ diff --git a/lispusers/LAFITEPRIVATEDL b/lispusers/LAFITEPRIVATEDL new file mode 100644 index 00000000..cd051e7f --- /dev/null +++ b/lispusers/LAFITEPRIVATEDL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "19-Jan-87 23:56:51" {ERIS}LISPCORE>LAFITEPRIVATEDL.;1 10080 previous date%: "19-Jan-87 23:47:54" {PHYLUM}KOTO>LAFITEPRIVATEDL.;2) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITEPRIVATEDLCOMS) (RPAQQ LAFITEPRIVATEDLCOMS ((* * LAFITEDL.EXT is the default extension for dl files when no extension is specified) (* * LAFITEDLDIRECTORIES is a list of directories to be searched after the connected directory and the LAFITEDEFAULTHOST&DIR in order to locate a dl file when no host or directory is specified) (INITVARS (LAFITEDL.EXT 'DL) (LAFITEDLDIRECTORIES NIL)) (* * no functions are user callable) (FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST) (* Lafite's readtable for parsing addresses needs to have CR as a SEPRCHAR so that lines from a text file can all be parsed at once. This has no effect on normal operation since before private dls no CR was ever passed to the parser) (P (SETSYNTAX (CHARCODE CR) 'SEPRCHAR ADDRESSPARSERRDTBL)))) (* * LAFITEDL.EXT is the default extension for dl files when no extension is specified) (* * LAFITEDLDIRECTORIES is a list of directories to be searched after the connected directory and the LAFITEDEFAULTHOST&DIR in order to locate a dl file when no host or directory is specified) (RPAQ? LAFITEDL.EXT 'DL) (RPAQ? LAFITEDLDIRECTORIES NIL) (* * no functions are user callable) (DEFINEQ (\GV.PARSERECIPIENTS1 [LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:44") (* ;;; "INTERNALFLG = T means produce addresses to give Grapevine; NIL means give human-readable addresses") (PROG (FIELDSTREAM ADDRESSES ADDR TOKEN) (COND ((NULL FIELD) (RETURN))) (SETQ FIELDSTREAM (if (STRINGP FIELD) then (OPENSTRINGSTREAM FIELD) else (* ;  "FIELD should already be an open stream") FIELD)) [SETFILEINFO FIELDSTREAM 'ENDOFSTREAMOP (FUNCTION (LAMBDA (STREAM) (* ; "Terminate anything in progress") (SELECTQ (STREAMPROP STREAM 'EOFCOUNT) (NIL (* ; "First try terminating with comma") (STREAMPROP STREAM 'EOFCOUNT 1) (CHARCODE %,)) (1 (* ;  "Must be something unbalanced. Try closing a paren") (STREAMPROP STREAM 'EOFCOUNT 2) (CHARCODE %))) (2 (* ;  "Still unbalanced, must have been a string") (STREAMPROP STREAM 'EOFCOUNT 3) (CHARCODE %")) (HELP] (OR REGISTRY (SETQ REGISTRY DEFAULTREGISTRY)) (* ;; "first just collect all the atoms using a special readtable ") (SETQ ADDRESSES (when (SETQ ADDR (until (OR (EOFP FIELDSTREAM) (EQ (SETQ TOKEN (READ FIELDSTREAM ADDRESSPARSERRDTBL)) '%,)) when (PROGN (* ; "Lists are comments") (NLISTP TOKEN)) collect TOKEN)) collect ADDR repeatuntil (EOFP FIELDSTREAM ))) [SELECTQ (STREAMPROP FIELDSTREAM 'EOFCOUNT) ((NIL 1) (* ; "Okay") ) (COND [EDITWINDOW (\SENDMESSAGEFAIL EDITWINDOW (if (STRINGP FIELD) then "Malformed address(es): " else (CONCAT "Malformed address(es) [in " (FULLNAME FIELDSTREAM) "]: ")) (COND ((EQ (STREAMPROP FIELDSTREAM 'EOFCOUNT) 2) "Unbalanced parentheses") (T "Unbalanced quotes"] (T (RETURN (CONS] (RETURN (for ADDRESS in ADDRESSES bind REALADDRESS VALIDRECIPIENT CLOSE OPEN join (if (AND (EQ (CADR ADDRESS) '%:) (NULL (CDDDR ADDRESS)) (EQ (CADDR ADDRESS) ';)) then (* ;; "it's a private dl --- foo:;") (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST ADDRESS REGISTRY INTERNALFLG EDITWINDOW) else (* ;; "ADDRESS will only get rebound if there is an address with <>'s in it ") (SETQ VALIDRECIPIENT (\GV.PARSE.SINGLE.ADDRESS (COND ([AND (SETQ OPEN (FMEMB '< ADDRESS)) (SETQ CLOSE (FMEMB '> (CDR OPEN] (SETQ REALADDRESS (LDIFF (CDR OPEN) CLOSE))) (T ADDRESS)) REGISTRY INTERNALFLG EDITWINDOW)) (LIST (COND ((OR T INTERNALFLG (NULL REALADDRESS)) VALIDRECIPIENT) (T (* ;; "Need to figure out how to make GETREGISTRY of this work, and remove duplicates in MAKEANSWERFORM before we can enable this") (\GV.REPACKADDRESS (APPEND (LDIFF ADDRESS OPEN) (LIST '< VALIDRECIPIENT '>) (CDR CLOSE]) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST [LAMBDA (DL REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:45") (LET* [(FILENAME (FINDFILE (PACKFILENAME.STRING 'BODY (CAR DL) 'EXTENSION LAFITEDL.EXT) T (CONS LAFITEDEFAULTHOST&DIR LAFITEDLDIRECTORIES))) (STREAM (AND FILENAME (CAR (NLSETQ (OPENTEXTSTREAM (OPENSTREAM FILENAME 'INPUT 'OLD] (if (NOT STREAM) then (if EDITWINDOW then (\SENDMESSAGEFAIL EDITWINDOW (CONCAT "Can't open dl file " (CAR DL))) else (PROMPTPRINT "Can't open dl file " (CAR DL))) (CONS) else (if INTERNALFLG then (PROG1 (\GV.PARSERECIPIENTS1 STREAM REGISTRY INTERNALFLG EDITWINDOW) (CLOSEF? STREAM)) else (CLOSEF STREAM) (LIST (\GV.REPACKADDRESS DL]) ) (* Lafite's readtable for parsing addresses needs to have CR as a SEPRCHAR so that lines from a text file can all be parsed at once. This has no effect on normal operation since before private dls no CR was ever passed to the parser) (SETSYNTAX (CHARCODE CR) 'SEPRCHAR ADDRESSPARSERRDTBL) (PUTPROPS LAFITEPRIVATEDL COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1965 9682 (\GV.PARSERECIPIENTS1 1975 . 8562) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST 8564 . 9680))))) STOP \ No newline at end of file diff --git a/lispusers/LAFITETIMEDDELETE b/lispusers/LAFITETIMEDDELETE new file mode 100644 index 00000000..5db814ae --- /dev/null +++ b/lispusers/LAFITETIMEDDELETE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Oct-88 11:05:53" {ERINYES}MEDLEY>LAFITETIMEDDELETE.;3 9944 changes to%: (VARS LAFITETIMEDDELETECOMS) previous date%: "21-Sep-88 16:47:01" {ERINYES}MEDLEY>LAFITETIMEDDELETE.;2) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITETIMEDDELETECOMS) (RPAQQ LAFITETIMEDDELETECOMS ((DECLARE%: DONTCOPY EVAL@COMPILE (FILES LAFITEDECLS)) (FILES LAFITEFIND) (FNS \LAFITE.TIMEDDELETE \LAFITE.SETEXPIRATIONS \LAFITE.DELETEEXPIRED) (FNS LTD.INIT MESSAGEAGE) (INITVARS EXPIRATIONMENU) (VARS EXPIRATIONMENUITEMS MARKDURATIONS) (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) (P (LTD.INIT)))) (DECLARE%: DONTCOPY EVAL@COMPILE (FILESLOAD LAFITEDECLS) ) (FILESLOAD LAFITEFIND) (DEFINEQ (\LAFITE.TIMEDDELETE [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* jtm%: "30-Sep-87 14:25") (COND ((EQ KEY 'MIDDLE) (\LAFITE.SETEXPIRATIONS WINDOW MAILFOLDER ITEM MENU)) (T (\LAFITE.DELETE WINDOW MAILFOLDER ITEM MENU]) (\LAFITE.SETEXPIRATIONS [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 21-Sep-88 16:36 by jtm:") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) [LET (EXPIRATION DURATION MSGDURATION MSGEXPIRATION TODAY YEAR ONEDAY MESSAGEAGE (N 0) (NODATE 0)) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND [[SETQ EXPIRATION (MENU (OR EXPIRATIONMENU (SETQ EXPIRATIONMENU (create MENU MENUFONT _ LAFITEMENUFONT TITLE _ "Expiration date" CENTERFLG _ T ITEMS _ EXPIRATIONMENUITEMS] (SETQ DURATION (CADR (FASSOC EXPIRATION MARKDURATIONS))) [AND DURATION (add DURATION (IMINUS (IQUOTIENT DURATION 10] (* this is so yesterday's messages won't be marked as 4 months when you ask for  2.0) [COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"))) (SETQ TODAY (IPLUS (IDATE (DATE)) (IQUOTIENT ONEDAY 2))) (* treat "now" as being after noon  for the purposes of counting days.) (SETQ YEAR (SUBSTRING (DATE) 8 9)) (for MSG selectedin MAILFOLDER when (OR (EQ EXPIRATION 0) (NOT (fetch (LAFITEMSG DELETED?) of MSG))) do (COND ((EQ EXPIRATION T) (DELETEMESSAGE MSG MAILFOLDER)) ((EQ EXPIRATION 0) (* equivalent to undelete.) (UNDELETEMESSAGE MSG MAILFOLDER) (MARKMESSAGE MSG MAILFOLDER 32)) ((SETQ MESSAGEAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) (SETQ MSGDURATION (IPLUS DURATION MESSAGEAGE)) (SETQ MSGEXPIRATION (OR [CAR (for ITEM in MARKDURATIONS thereis (ILEQ MSGDURATION (CADR ITEM] 9)) (MARKMESSAGE MSG MAILFOLDER (IPLUS 48 MSGEXPIRATION))) (T (* the message didn't have a date.  Flag the message with a ?) (add NODATE 1) (MARKMESSAGE MSG MAILFOLDER 63))) (add N 1] (COND ((EQ NODATE 0) (LAB.PROMPTPRINT MAILFOLDER T "Marked " N " " (COND ((EQ N 1) "message") (T "messages")) " to expire after " [CAR (for I in EXPIRATIONMENUITEMS thereis (EQ EXPIRATION (CADR I] ".")) (T (LAB.PROMPTPRINT MAILFOLDER T "Error: " NODATE " " (COND ((EQ NODATE 1) "message") (T "messages")) " had a bad date."] (T (LAB.PROMPTPRINT MAILFOLDER T "No expiration date selected."])]) (\LAFITE.DELETEEXPIRED [LAMBDA (MAILFOLDER) (* ; "Edited 21-Sep-88 16:39 by jtm:") (LET (MESSAGES LASTMSG# YEAR TODAY ONEDAY (N 0)) (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) (SETQ TODAY (IDATE (DATE))) (SETQ YEAR (SUBSTRING (DATE) 8 9)) (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"))) [for I MSG MARK MSGAGE DURATION from 1 to LASTMSG# do (SETQ MSG (NTHMESSAGE MESSAGES I)) (SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG)) (COND ((AND (IGREATERP MARK 48) (ILESSP MARK 58) (NOT (fetch (LAFITEMSG DELETED?) of MSG))) (SETQ MSGAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) (SETQ DURATION (CADR (FASSOC (IDIFFERENCE MARK 48) MARKDURATIONS))) (COND ((AND DURATION (IGEQ MSGAGE DURATION)) (DELETEMESSAGE MSG MAILFOLDER) (add N 1] (LAB.PROMPTPRINT MAILFOLDER T N " expired " (COND ((EQ N 1) "message") (T "messages")) " deleted."]) ) (DEFINEQ (LTD.INIT [LAMBDA NIL (* jtm%: "30-Sep-87 16:44") (LET (DELETEMENUITEM) (COND ((SETQ DELETEMENUITEM (SASSOC "Delete" LAFITEBROWSERMENUITEMS)) (RPLACA (CDR DELETEMENUITEM) ''\LAFITE.TIMEDDELETE) (COND ((NOT (SASSOC "Delete Expired Msgs" LAFITEEXTRAMENUITEMS)) (push LAFITEEXTRAMENUITEMS '("Delete Expired Msgs" (FUNCTION \LAFITE.DELETEEXPIRED) "Mark as deleted all of the messages that have passed their expiration dates." )) (SETQ LAFITEEXTRAMENU NIL) (SETQ LAFITEEXTRAMENUFLG T]) (MESSAGEAGE [LAMBDA (MSG TODAY YEAR ONEDAY) (* ; "Edited 21-Sep-88 16:25 by jtm:") (LET (MSGDATE MSGTIME) (SETQ MSGDATE (fetch (LAFITEMSG DATE) of MSG)) [OR TODAY (SETQ TODAY (IDATE (DATE] (OR YEAR (SETQ YEAR (SUBSTRING (DATE) 8 9))) [OR ONEDAY (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"] (COND ((SETQ MSGTIME (IDATE (CONCAT MSGDATE " " YEAR " 12:00"))) [COND ((IGREATERP (IDIFFERENCE MSGTIME TODAY) ONEDAY) (* a message from last year.) (SETQ MSGTIME (IDATE (CONCAT MSGDATE " " (SUB1 (MKATOM YEAR)) " 12:00"] (QUOTIENT (IDIFFERENCE TODAY MSGTIME) ONEDAY]) ) (RPAQ? EXPIRATIONMENU NIL) (RPAQQ EXPIRATIONMENUITEMS (("now" T) ("one day" 1) ("two days" 2) ("four days" 3) ("one week" 4) ("two weeks" 5) ("one month" 6) ("two months" 7) ("four months" 8) ("eight months" 9) ("forever" 0))) (RPAQQ MARKDURATIONS ((1 1) (2 2) (3 4) (4 7) (5 14) (6 30) (7 61) (8 122) (9 244))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) ) (LTD.INIT) (PUTPROPS LAFITETIMEDDELETE COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (920 7257 (\LAFITE.TIMEDDELETE 930 . 1204) (\LAFITE.SETEXPIRATIONS 1206 . 5586) ( \LAFITE.DELETEEXPIRED 5588 . 7255)) (7258 9112 (LTD.INIT 7268 . 8157) (MESSAGEAGE 8159 . 9110))))) STOP \ No newline at end of file diff --git a/lispusers/LAFITETIMEDDELETE.TEDIT b/lispusers/LAFITETIMEDDELETE.TEDIT new file mode 100644 index 00000000..11815699 Binary files /dev/null and b/lispusers/LAFITETIMEDDELETE.TEDIT differ diff --git a/lispusers/LAMBDATRAN b/lispusers/LAMBDATRAN new file mode 100644 index 00000000..585eaf4f --- /dev/null +++ b/lispusers/LAMBDATRAN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "19-Feb-87 10:40:43" {QV}PARSER>NEXT>LAMBDATRAN.;2 9556 changes to%: (FNS FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS) previous date%: "19-Feb-87 09:56:18" {QV}PARSER>NEXT>LAMBDATRAN.;1) (* " Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAMBDATRANCOMS) (RPAQQ LAMBDATRANCOMS [(* Translation machinery for new LAMBDA words) (LOCALVARS . T) [DECLARE%: FIRST (P (VIRGINFN 'ARGLIST T) (MOVD? 'ARGLIST 'OLDARGLIST) (VIRGINFN 'NARGS T) (MOVD? 'NARGS 'OLDNARGS) (VIRGINFN 'ARGTYPE T) (MOVD? 'ARGTYPE 'OLDARGTYPE) (MOVD? 'NILL 'LTDWIMUSERFN] (FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS) (ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN))) (PROP VARTYPE LAMBDATRANFNS) (ALISTS (LAMBDATRANFNS)) (PROP MACRO LTSTKNAME) (P (PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES)) (P (RELINK 'WORLD)) (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T)) (GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY )) (DECLARE%: DONTCOPY (RECORDS LAMBDAWORD)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML LTSTKNAME) (LAMA]) (* Translation machinery for new LAMBDA words) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: FIRST (VIRGINFN 'ARGLIST T) (MOVD? 'ARGLIST 'OLDARGLIST) (VIRGINFN 'NARGS T) (MOVD? 'NARGS 'OLDNARGS) (VIRGINFN 'ARGTYPE T) (MOVD? 'ARGTYPE 'OLDARGTYPE) (MOVD? 'NILL 'LTDWIMUSERFN) ) (DEFINEQ (ARGLIST [LAMBDA (FN) (* rmk%: " 6-AUG-79 22:41") (PROG (TEMP (DEF (CGETD FN))) (DECLARE (LOCALVARS . T)) (RETURN (if (OR (SUBRP DEF) (NLISTP DEF) (SELECTQ (CAR DEF) ([LAMBDA NLAMBDA FUNARG] T) NIL)) then (OLDARGLIST FN) elseif (AND CLISPARRAY (SETQ TEMP (GETHASH DEF CLISPARRAY))) then (ARGLIST TEMP) elseif [AND [SETQ TEMP (fetch ARGLIST of (CDR (ASSOC (CAR DEF) LAMBDATRANFNS] (NEQ T (SETQ TEMP (APPLY* TEMP DEF] then TEMP else (OLDARGLIST FN]) (ARGTYPE [LAMBDA (FN) (* rmk%: " 9-APR-78 12:55") (* Note%: We don't have to worry about SUBR's or CCODE here) (OR (OLDARGTYPE FN) (SELECTQ (FNTYP FN) (EXPR 0) (FEXPR 1) (EXPR* 2) (FEXPR* 3) NIL]) (FNTYP1 [LAMBDA (X) (* rmk%: " 6-AUG-79 22:43") (* Called by FNTYP when it can't interpret the CAR of a list definition.  Doesn't call dwimify, because it might not know what FAULTN really is.  Therefore, examines the FNTYP field of the LAMBDATRAN entry) (PROG (TEMP) (RETURN (if (AND CLISPARRAY (SETQ TEMP (GETHASH X CLISPARRAY))) then (FNTYP TEMP) elseif (SETQ TEMP (CDR (ASSOC (CAR X) LAMBDATRANFNS))) then (SELECTQ (SETQ TEMP (fetch FNTYP of TEMP)) ((EXPR EXPR* FEXPR FEXPR*) TEMP) (NIL 'EXPR) (APPLY* TEMP X]) (LTDWIMUSERFN [LAMBDA NIL (* rmk%: " 6-AUG-79 22:49") (* NOTE%: dwimuserfn HAS to be  compiled for proper action!!) (* LAMBDA-words can be added by making entries on LAMBDATRANFNS, e.g.  (FOOLAMBDA FOOTRAN EXPR FOOARGLIST)) (DECLARE (USEDFREE EXPR FAULTFN FAULTAPPLYFLG FAULTX FAULTARGS LAMBDASPLST LAMBDATRANFNS COMMENTFLG CLISPCHANGE)) (PROG (FORM TRAN TRANFN (EXPR EXPR) (FAULTFN FAULTFN)) (DECLARE (SPECVARS FAULTFN EXPR)) (* Rebind FAULTFN to guarantee  function name instead of TYPE-IN) [SETQ FORM (if (LISTP FAULTX) then (if (FMEMB (CAR FAULTX) LAMBDASPLST) then FAULTX elseif (LITATOM (CAR FAULTX)) then [SETQ EXPR (GETD (SETQ FAULTFN (CAR FAULTX] else (LISTP (CAR FAULTX))) elseif (AND FAULTAPPLYFLG (LITATOM FAULTX)) then (SETQ EXPR (GETD (SETQ FAULTFN FAULTX] (RETURN (if [SETQ TRANFN (fetch TRANFN of (CDR (ASSOC (CAR FORM) LAMBDATRANFNS] then (SETQ CLISPCHANGE T) (* Tell dwim not to try again if the translation doesn't make it) (if (LISTP (SETQ TRAN (APPLY* TRANFN FORM))) then (if [OR (EQ FORM (GETD FAULTFN)) (EQ FORM (GETP FAULTFN 'EXPR] then (* Insert the form that will establish the right function name on the stack) (for X TEMP on (CDR (LISTP (CDR TRAN))) unless (SELECTQ [SETQ TEMP (CAR (LISTP (CAR X] ((DECLARE CLISP%:) T) (EQ TEMP COMMENTFLG)) do (ATTACH (LIST 'LTSTKNAME FAULTFN) X) (RETURN))) (CLISPTRAN FORM TRAN) (if FAULTAPPLYFLG then (RETAPPLY 'FAULTAPPLY TRAN FAULTARGS) else (SELECTQ (CAR TRAN) ([LAMBDA NLAMBDA] (if (EQ FORM (CAR FAULTX)) then (DWIMIFY0? (CDR FAULTX) FAULTX NIL NIL NIL FAULTFN)) (* Dwimify the arguments of an open  LAMBDA) FAULTX) TRAN]) (LTSTKNAME [NLAMBDA (NAME) (* rmk%: " 6-JUN-79 10:54") (* Smashes the correct stack-name on the frame for the LAMBDA-translation.  The call goes away at compile. If BOUNDPDUMMY is bound to a stackframe, avoids  allocation on each call.) (DECLARE (USEDFREE BOUNDPDUMMY)) (PROG (POS) (SETSTKNAME (SETQ POS (REALSTKNTH -1 'LTSTKNAME T BOUNDPDUMMY)) NAME) (RELSTK POS]) (NARGS [LAMBDA (X) (* rmk%: "29-APR-78 14:10") (OR (OLDNARGS X) (AND (NLSETQ (SETQ X (ARGLIST X))) (if (NULL X) then 0 elseif (LISTP X) then (LENGTH X) else 1]) ) (ADDTOVAR DWIMUSERFORMS (LTDWIMUSERFN)) (PUTPROPS LAMBDATRANFNS VARTYPE ALIST) (ADDTOVAR LAMBDATRANFNS ) (PUTPROPS LTSTKNAME MACRO (X (CONS COMMENTFLG X))) (PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES) (RELINK 'WORLD) (DECLARE%: EVAL@COMPILE DONTCOPY (RESETSAVE DWIMIFYCOMPFLG T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LAMBDAWORD (TRANFN FNTYP ARGLIST)) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML LTSTKNAME) (ADDTOVAR LAMA ) ) (PUTPROPS LAMBDATRAN COPYRIGHT ("Xerox Corporation" 1984 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2224 8821 (ARGLIST 2234 . 3188) (ARGTYPE 3190 . 3544) (FNTYP1 3546 . 4455) ( LTDWIMUSERFN 4457 . 7957) (LTSTKNAME 7959 . 8483) (NARGS 8485 . 8819))))) STOP \ No newline at end of file diff --git a/lispusers/LAMBDATRAN.TEDIT b/lispusers/LAMBDATRAN.TEDIT new file mode 100644 index 00000000..5766b228 Binary files /dev/null and b/lispusers/LAMBDATRAN.TEDIT differ diff --git a/lispusers/LAYOUT-SEDIT b/lispusers/LAYOUT-SEDIT new file mode 100644 index 00000000..d4f24d97 --- /dev/null +++ b/lispusers/LAYOUT-SEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" (§NICKNAMES "L-S"))) (il:filecreated " 9-Jan-87 19:55:25" il:{eris}lispcore>layout-sedit.\;2 7190 il:|changes| il:|to:| (il:variables user::*l-s-region-zero* user::*l-s-region-delta* user::*l-s-reuse-earlier-regions*) (il:functions get-region save-region user::use-l-s-regions user::stop-using-l-s-regions) (il:vars il:layout-seditcoms) il:|previous| il:|date:| "26-Dec-86 19:42:46" il:{eris}lisp>layout-sedit.\;2) ; Copyright (c) 1986, 1987 by Pavel Curtis. All rights reserved. (il:prettycomprint il:layout-seditcoms) (il:rpaqq il:layout-seditcoms ((il:functions user::use-l-s-regions user::stop-using-l-s-regions) (il:variables *region-alist* user::*l-s-region-zero* user::*l-s-region-delta* user::*l-s-reuse-earlier-regions*) (il:functions region-plus) (il:functions get-region save-region) (il:declare\: il:donteval@load il:donteval@compile il:docopy (il:p (user::use-l-s-regions))) (il:* il:|;;| "Arrange to use the proper compiler and makefile environment ") (il:prop (il:filetype il:makefile-environment) il:layout-sedit))) (defun user::use-l-s-regions nil (assert (null il:|\\\\contexts|) nil "Close all open SEdit windows") (il:sedit.reset) (il:movd 'il:sedit.get.window.region 'old-get-region) (il:movd 'il:sedit.save.window.region 'old-save-region) (il:movd 'get-region 'il:sedit.get.window.region) (il:movd 'save-region 'il:sedit.save.window.region)) (defun user::stop-using-l-s-regions nil (assert (null il:|\\\\contexts|) nil "Close all open SEdit windows") (il:sedit.reset) (il:movd 'old-get-region 'il:sedit.get.window.region) (il:movd 'old-save-region 'il:sedit.save.window.region)) (defvar *region-alist* nil (il:* il:|;;;| "An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL.") ) (defvar user::*l-s-region-zero* (il:createregion 25 (- (truncate il:screenheight 2) 19) (truncate il:screenwidth 2) (truncate il:screenheight 2)) (il:* il:|;;;| "The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window.") ) (defvar user::*l-s-region-delta* (il:createregion 11 -44 0 0) ) (defvar user::*l-s-reuse-earlier-regions* nil (il:* il:|;;;| "If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created.") ) (defun region-plus (one two) (il:createregion (+ (il:fetch (il:region il:left) il:of one) (il:fetch (il:region il:left) il:of two)) (+ (il:fetch (il:region il:bottom) il:of one) (il:fetch (il:region il:bottom) il:of two)) (+ (il:fetch (il:region il:width) il:of one) (il:fetch (il:region il:width) il:of two)) (+ (il:fetch (il:region il:height) il:of one) (il:fetch (il:region il:height) il:of two)))) (defun get-region (context) (let ((pair (and user::*l-s-reuse-earlier-regions* (find nil *region-alist* :key 'cdr)))) (cond ((null pair) (cond ((null *region-alist*) (setq *region-alist* (list (cons user::*l-s-region-zero* context))) user::*l-s-region-zero*) (t (let ((new-region (region-plus (car (first *region-alist*) ) user::*l-s-region-delta*))) (push (cons new-region context) *region-alist*) new-region)))) (t (setf (cdr pair) context) (car pair))))) (defun save-region (context) (il:* il:|;;;| "The context is done with its region. Deallocate it.") (let ((pair (find context *region-alist* :key 'cdr))) (if (null pair) (warn "An SEdit context is trying to give up an unallocated region.") (setf (cdr pair) nil)) (setq *region-alist* (member-if-not 'null *region-alist* :key 'cdr)))) (il:declare\: il:donteval@load il:donteval@compile il:docopy (user::use-l-s-regions) ) (il:* il:|;;| "Arrange to use the proper compiler and makefile environment ") (il:putprops il:layout-sedit il:filetype compile-file) (il:putprops il:layout-sedit il:makefile-environment (:readtable "XCL" :package (xcl:defpackage "LAYOUT-SEDIT" (:nicknames "L-S")))) (il:putprops il:layout-sedit il:copyright ("Pavel Curtis" 1986 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/LICENSE b/lispusers/LICENSE new file mode 100644 index 00000000..6f72ec3e --- /dev/null +++ b/lispusers/LICENSE @@ -0,0 +1,21 @@ +MIT License if marked in file + +Copyright as marked + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/lispusers/LIFE b/lispusers/LIFE new file mode 100644 index 00000000..661f36de --- /dev/null +++ b/lispusers/LIFE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "20-Aug-88 12:18:43" {erinyes}medley>life.\;5 8231 |previous| |date:| " 6-Mar-87 19:11:20" {erinyes}medley>life.\;3) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint lifecoms) (rpaqq lifecoms ((functions |Life| |LifeIdle|) (fns expand.bitmap.vertically expand.bitmap.horizontally) (addvars (idle.functions ("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|) ("Double bits" '(lambda (\w) (|LifeIdle| \w 2))) ("Quadruple bits" '(lambda (\w) (|LifeIdle| \w 4))) ("Eight bits" '(lambda (\w) (|LifeIdle| \w 8))))))))) (cl:defun |Life| (win &optional (n 1)) (let* ((w (windowprop win 'width)) (w1 (idifference w n)) (h (iquotient (windowprop win 'height) n)) (h1 (sub1 h)) (a (bitmapcreate w h)) (b (bitmapcreate w h)) (c (bitmapcreate w h)) (d (bitmapcreate w h)) (e (bitmapcreate w h)) pbt temp) (|if| (neq n 1) |then| (setq temp (bitmapcreate (iquotient w n) h)) (setq pbt (|create| pilotbbt)) (bitblt win 0 0 temp 0 0) (expand.bitmap.horizontally temp n a pbt) (setq temp (bitmapcreate w (windowprop win 'height))) (bitblt a 0 0 temp 0 0 w h) |else| (bitblt win 0 0 a 0 0 w h)) (cl:loop (block) (cl:macrolet ((bitbltbitmap (source sourceleft sourcebottom destination destinationleft destinationbottom width height &optional sourcetype operation) `(\\bitblt.bitmap ,source ,sourceleft ,sourcebottom ,destination ,destinationleft ,destinationbottom ,width ,height ,sourcetype ,operation nil nil ,sourceleft ,sourcebottom)) (shuffle (inhi lo horiz?) `(progn ,@(|if| horiz? |then| `((bitbltbitmap ,inhi n 0 ,lo 0 0 w1 h) (bitbltbitmap ,inhi 0 0 ,lo w1 0 n h) (bitbltbitmap ,inhi 0 0 c n 0 w1 h) (bitbltbitmap ,inhi w1 0 c 0 0 n h)) |else| `((bitbltbitmap ,inhi 0 1 ,lo 0 0 w h1) (bitbltbitmap ,inhi 0 0 ,lo 0 h1 w 1) (bitbltbitmap ,inhi 0 0 c 0 1 w h1) (bitbltbitmap ,inhi 0 h1 c 0 0 w 1))) (bitbltbitmap c 0 0 ,lo 0 0 w h 'input 'invert) (bitbltbitmap ,lo 0 0 c 0 0 w h 'input 'erase) (bitbltbitmap ,inhi 0 0 ,lo 0 0 w h 'input 'invert) (bitbltbitmap ,lo 0 0 ,inhi 0 0 w h 'input 'erase) (bitbltbitmap c 0 0 ,inhi 0 0 w h 'input 'paint)))) (shuffle a b t) (shuffle b d nil) (shuffle a e nil) (bitbltbitmap d 0 0 c 0 0 w h) (bitbltbitmap b 0 0 c 0 0 w h 'input 'invert) (bitbltbitmap e 0 0 c 0 0 w h 'input 'invert) (|if| (eq n 1) |then| (bitblt win 0 0 d 0 0 w h 'input 'paint) |else| (bitbltbitmap temp 0 0 d 0 0 w h 'input 'paint)) (|if| (shiftdownp 'ctrl) |then| (bitbltbitmap d 0 0 a 0 0 w h) |else| (bitbltbitmap b 0 0 e 0 0 w h 'input 'paint) (bitbltbitmap e 0 0 a 0 0 w h 'input 'invert) (bitbltbitmap c 0 0 a 0 0 w h 'input 'erase) (bitbltbitmap d 0 0 a 0 0 w h 'invert 'erase)) (|if| (eq n 1) |then| (bitblt a 0 0 win 0 0 w h) |else| (expand.bitmap.vertically a n temp pbt) (bitblt temp 0 0 win 0 0) (bitbltbitmap a 0 0 temp 0 0 w h)))))) (cl:defun |LifeIdle| (\w &optional (\n 1)) (bitblt (windowprop \w 'imagecovered) 0 0 \w) (|Life| \w \n)) (defineq (expand.bitmap.vertically (lambda (bitmap m bm2 pbt) (* \; "Edited 6-Mar-87 15:02 by Masinter") (or bm2 (setq bm2 (bitmapcreate (|fetch| bitmapwidth bitmap) (times m (|fetch| bitmapheight bitmap))))) (or pbt (setq pbt (|create| pilotbbt))) (|with| pilotbbt pbt (*) (setq pbtdesthi (|ffetch| |BitMapHiLoc| bm2)) (setq pbtdestlo (|ffetch| |BitMapLoLoc| bm2)) (setq pbtsourcehi (|ffetch| |BitMapHiLoc| bitmap)) (setq pbtsourcelo (|ffetch| |BitMapLoLoc| bitmap)) (setq pbtdestbpl (times 16 m (|ffetch| bitmaprasterwidth bm2))) (setq pbtsourcebpl (times 16 (|ffetch| bitmaprasterwidth bitmap))) (setq pbtsourcebit 0) (setq pbtdestbit 0) (setq pbtflags 16384) (setq pbtheight (|fetch| bitmapheight bitmap)) (setq pbtwidth (|fetch| bitmapwidth bitmap)) (|for| i |from| 0 |while| (lessp i m) |do| (\\pilotbitblt pbt 0) (|add| pbtdestlo (|fetch| bitmaprasterwidth bm2)))) bm2) ) (expand.bitmap.horizontally (lambda (bitmap n bm2 pbt) (* \; "Edited 6-Mar-87 17:08 by Masinter") (or bm2 (setq bm2 (bitmapcreate (times n (|fetch| bitmapwidth bitmap)) (|fetch| bitmapheight bitmap)))) (or pbt (setq pbt (|create| pilotbbt))) (let ((sourcebase (|fetch| bitmapbase bitmap)) (destbase (|fetch| bitmapbase bm2))) (|with| pilotbbt pbt (setq pbtdestbpl n) (setq pbtsourcebpl 1) (setq pbtsourcebit 0) (setq pbtflags 16384) (setq pbtwidth 1) (let ((ht (times (|fetch| bitmapwidth bitmap) (|fetch| bitmapheight bitmap)))) (|do| (setq pbtdest destbase) (setq pbtsource sourcebase) (setq pbtheight (min (times 1024 16) ht)) (setq pbtdestbit 0) (|for| i |from| 0 |while| (lessp i n) |do| (\\pilotbitblt pbt 0) (|add| pbtdestbit 1)) (setq ht (- ht (times 1024 16))) (|if| (leq ht 0) |then| (return)) (setq destbase (\\addbase destbase (times n 1024))) (setq sourcebase (\\addbase sourcebase 1024)))))) bm2) ) ) (addtovar idle.functions ("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|) ("Double bits" '(lambda (\w) (|LifeIdle| \w 2))) ("Quadruple bits" '(lambda (\w) (|LifeIdle| \w 4))) ("Eight bits" '(lambda (\w) (|LifeIdle| \w 8)))))) (putprops life copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil (5774 7579 (expand.bitmap.vertically 5784 . 6658) (expand.bitmap.horizontally 6660 . 7577))))) stop \ No newline at end of file diff --git a/lispusers/LIFE.TEDIT b/lispusers/LIFE.TEDIT new file mode 100644 index 00000000..fa8454b8 Binary files /dev/null and b/lispusers/LIFE.TEDIT differ diff --git a/lispusers/LISPNERD b/lispusers/LISPNERD new file mode 100644 index 00000000..97aab149 --- /dev/null +++ b/lispusers/LISPNERD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Aug-88 16:16:39" {ERINYES}LYRIC>LISPNERD.;3 10439 changes to%: (VARS LISPNERDCOMS) previous date%: "25-Jan-88 11:18:03" {ERINYES}LYRIC>LISPNERD.;2) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LISPNERDCOMS) (RPAQQ LISPNERDCOMS ((COMS * LISPNERDDEPENDENCIES) (* must come before any FILES) (FILES ANALYZER DINFO HELPSYS (FROM {QV}LISP>) DICTCLIENT) (FNS LISPNERD.INIT IRMNERD.PRINTSEARCH) (INITVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST (IRMNERD.MAXWORDS 50)) (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS) (FNS IRMDICT.PRINTENTRY) (P (LISPNERD.INIT)))) (RPAQQ LISPNERDDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'LISPNERD 'DEPENDENCIES (for FILE in (FILECOMSLST 'LISPNERD 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES LISPNERD) (P (for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS LISPNERD DEPENDENCIES ((ANALYZER . " 3-Jun-88 17:03:38") (DINFO . " 1-Oct-87 10:11:04") (HELPSYS . " 1-Oct-87 13:40:16") (DICTCLIENT . " 8-Oct-87 15:15:08"))) [for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD  to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL] (* must come before any FILES) (FILESLOAD ANALYZER DINFO HELPSYS (FROM {QV}LISP>) DICTCLIENT) (DEFINEQ (LISPNERD.INIT [LAMBDA NIL (* jtm%: "18-Nov-87 14:36") (COND ((NULL IRMDICT) [Dict.Establish (SETQ IRMDICT (create Dict dictName _ 'IRMDict printEntryFn _ (FUNCTION IRMDICT.PRINTENTRY] (PUTASSOC 'Search% IRM '((IRMNERD.PRINTSEARCH) "Searches the Interlisp Reference Manual for entries given a list of keywords." ) BackgroundMenuCommands) (SETQ BackgroundMenu NIL]) (IRMNERD.PRINTSEARCH [LAMBDA (SYNONYMCLASSES) (* jtm%: " 7-Apr-87 12:33") (PROG (VENNDIAGRAM SELECTION MENUITEMS (MINWORD 0) (MAXWORD IRMNERD.MAXWORDS)) [COND ((NULL SYNONYMCLASSES) (CLRPROMPT) (PROMPTPRINT (CHARACTER (CHARCODE CR))) (SETQ SYNONYMCLASSES (PROMPTFORWORD "keywords to search on:" IRMNERD.LASTREQUEST NIL PROMPTWINDOW NIL NIL (CHARCODE EOL ESCAPE LF))) (COND ((NULL SYNONYMCLASSES) (PROMPTPRINT "Aborted") (RETURN)) (T (CLRPROMPT))) (COND ((NOT (STREQUAL SYNONYMCLASSES IRMNERD.LASTREQUEST)) (SETQ IRMNERD.LASTREQUEST SYNONYMCLASSES) (SETQ IRMNERD.LASTSEARCH NIL] [do [SETQ VENNDIAGRAM (COND ((AND IRMNERD.LASTSEARCH (EQ MINWORD 0)) IRMNERD.LASTSEARCH) (T (PROMPTPRINT " Searching . . . ") (DICTCLIENT.SEARCHFORWORD SYNONYMCLASSES 2 MINWORD MAXWORD 'IRMNerd] (COND ((EQ MINWORD 0) (* cache the results in case the use  calls again.) (SETQ IRMNERD.LASTSEARCH VENNDIAGRAM))) [COND ((NULL VENNDIAGRAM) (PROMPTPRINT "Sorry, no results.") (FLASHWINDOW PROMPTWINDOW) (RETURN)) ((NULL (CDR VENNDIAGRAM)) (SETQ MENUITEMS (CADAR VENNDIAGRAM))) (T (SETQ MENUITEMS (for SET in VENNDIAGRAM collect (LIST [CONCATLIST (for ELEMENT on (CAR SET) collect (COND ((CDR ELEMENT) (CONCAT (CAR ELEMENT) " ")) (T (CAR ELEMENT] (LIST 'QUOTE (CAR SET)) NIL (CONS 'SUBITEMS (CADR SET] (CLRPROMPT) (SETQ SELECTION (MENU (create MENU TITLE _ "IRM Entries" ITEMS _ MENUITEMS CENTERFLG _ T))) (COND ((NULL SELECTION) (PROMPTPRINT " No selection made.") (RETURN)) ((LISTP SELECTION) [for TAIL CLASSNAME on SELECTION do (COND ((EQ (NTHCHARCODE (CAR TAIL) -1) (CHARCODE +)) (SETQ CLASSNAME (SUBSTRING (CAR TAIL) 1 -2)) (RPLACA TAIL (for CLASS in SYNONYMCLASSES thereis (STREQUAL (CAR CLASS) CLASSNAME] (SETQ SYNONYMCLASSES SELECTION) (PROMPTPRINT "Seaching for: " SYNONYMCLASSES) (SETQ MINWORD 0) (SETQ MAXWORD IRMNERD.MAXWORDS)) ((AND (EQ 1 (STRPOS ". . .+" SELECTION)) (STRPOS "more" SELECTION)) (* the user asked for the next chunk.) (SETQ MINWORD (ADD1 MAXWORD)) (SETQ MAXWORD (IPLUS MAXWORD IRMNERD.MAXWORDS))) ((EQ 1 (STRPOS "No more" SELECTION)) (RETURN)) (T (PROMPTPRINT " Fetching definition . . . ") (IRMDICT.PRINTENTRY NIL SELECTION) (CLRPROMPT) (RETURN] (RETURN T]) ) (RPAQ? IRMDICT NIL) (RPAQ? IRMNERD.LASTSEARCH NIL) (RPAQ? IRMNERD.LASTREQUEST NIL) (RPAQ? IRMNERD.MAXWORDS 50) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS) ) (DEFINEQ (IRMDICT.PRINTENTRY [LAMBDA (DICT LEMMA) (* ; "Edited 25-Jan-88 11:10 by jtm:") (LET (FIRSTCHAR SECTION# GRAPH NODE) (SETQ FIRSTCHAR (NTHCHAR LEMMA 1)) [COND ((NUMBERP FIRSTCHAR) [SETQ SECTION# (SUBSTRING LEMMA 1 (SUB1 (OR (STRPOS " " LEMMA) 0] [COND ((EQ (NTHCHARCODE SECTION# -1) (CHARCODE %.)) (* sometimes there is a trailing  period.) (SETQ SECTION# (SUBSTRING SECTION# 1 -2] [for I from 1 to (NCHARS SECTION#) do (COND ((EQ (NTHCHARCODE SECTION# I) (CHARCODE %.)) (* DINFO uses dashes instead of  periods) (RPLCHARCODE SECTION# I (CHARCODE -] (SETQ SECTION# (MKATOM SECTION#)) (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH)) [COND ((NULL GRAPH) (DINFO.INIT) (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH] (SETQ NODE (FASSOC SECTION# (fetch (DINFOGRAPH NODELST) of GRAPH))) (AND NODE (DINFO.UPDATE NODE))) (T (IRM.SMART.LOOKUP (SUBSTRING LEMMA (COND ((EQ FIRSTCHAR '%() 2) (T 1)) (SUB1 (OR (STRPOS " " LEMMA) 0] T]) ) (LISPNERD.INIT) (PUTPROPS LISPNERD COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2875 8096 (LISPNERD.INIT 2885 . 3532) (IRMNERD.PRINTSEARCH 3534 . 8094)) (8344 10333 ( IRMDICT.PRINTENTRY 8354 . 10331))))) STOP \ No newline at end of file diff --git a/lispusers/LISPNERD.TEDIT b/lispusers/LISPNERD.TEDIT new file mode 100644 index 00000000..a0c733ba Binary files /dev/null and b/lispusers/LISPNERD.TEDIT differ diff --git a/lispusers/LISPUSERS-DEPENDENCIES.TEDIT b/lispusers/LISPUSERS-DEPENDENCIES.TEDIT new file mode 100644 index 00000000..e03997aa --- /dev/null +++ b/lispusers/LISPUSERS-DEPENDENCIES.TEDIT @@ -0,0 +1 @@ +{ERIS}LYRIC>LISPUSERS-DEPENDENCIES.TEDIT Edited 12/16/86 Susana Wessling This is a list of the LispUsers files that are to be released and their dependencies. Please add new LispUsers files to this list when you write them onto lyric>. If any of the packages on this list have changed or are not to be released, please remove them. Key: * internal release only + release source AND dcom files indented: dependent on the above package access.;1 ACE.;1 ACE-APPLEDEMO.;1 ACE-BOUNCINGBALL.;1 ACE-FOUETTE.;1 ACTIVEREGIONS.;1 ACTIVEREGIONS2.;1 AIREGIONS.;1 AIREGIONS-DEMO.;1 animate.;1 *ARCHIVETOOL.;1 ARITHDECLS.;1 ARRAYSORTER.;1 AUTOSAMEDIR.;1 AUXMENU.;2 BACKGROUND.;1 +BACKGROUNDDEMO.;1 BACKGROUNDIMAGES.;3 +BACKGROUND-*.BITMAP +BACKGROUND-*.PRESS BackgroundMenu.;1 BICLOCK.;1 BIZGRAFIX.;1 bltdemo.;1 BMFROMW.;1 BOUNCE.;1 BOUNDARY.;1 BOYERMOORE.;1 BOYERMOOREDATA.;1 BQUOTE.;1 BQUOTEGACHA10-C0.DISPLAYFONT BQUOTEGACHA12-C0.DISPLAYFONT BQUOTEGACHA8-C0.DISPLAYFONT BTMP.;1 BTMP-DEBUG.;1 BUGREPORT.;1 CALENDAR.;2 PROMPTREMINDERS.;1 CCACHE.;1 CD.;1 CD-COMMAND.;1 CHANGEPRINTER.;1 +CIAPROPOS.;1 COLORNNGS.;1 COMHACK.;1 COMPAREDIRECTORIES.;1 COMPARESOURCES.;1 COMPARETEXT.;1 COMPILEFORMSLIST.;1 CONNTITLE.;1 COURIERDEFS.;1 COURIEREVALSERVE.;1 COURIERIMAGESTREAM.;1 COURIERSERVE.;1 REMOTEGRAPHER.;1 REMOTEPSW.;1 CROCK.;1 *CRYPT.;1 DATEFNS.;1 DEDITAUG.;1 DEDITICON.;1 (no .dcom) DEDITK.;1 DEFAULTICON.;1 DEFAULTSUBITEMFN.;1 DINFOEDIT.;1 DIRECTORYTOOLS.;1 DIRGRAPHER.;1 DIRMENU.;1 DLIONFNKEYS.;1 DOCTOR.;1 DONZ.;1 *DRAWFILE.;1 DSL.;1 dumper.;1 +DUMPLOAD.;1 EDITBG.;1 EDITFONT.;1 +EDITKEYS.;1 EDITRECALL.;1 EMACS.;1 EMACSUSER.;1 EQUATIONFORMS.;1 EQUATIONS.;1 EXEC.;1 +EXECFNS.;1 FACEINVADER.;1 FASTBITMAPBIT.;1 *FILECACHEMSGWINDOW.;1 +FILEOBJ.;1 FILEPERCENT.;1 FILLPRINT.;1 FILLREGION.;1 FINGER.;1 FLAGBROWSER.;1 FLOPPY4.;3 FONTMENU.;1 FULLSCREEN.;1 GKS.;1 GKSEXTERN.;1 GKSINTERN.;1 GKSMATRIX.;1 GLISPA.;1 GLISPB.;1 GLISPDWINDOW.;1 GLISPGEV.;1 GLISPGEVAUX.;1 GLISPGEVTYPE.;1 GLISPR.;1 GLISPTEST.;1 GLISPVECTOR.;1 graphcalls.;1 *GREP.;1 HANOI.;1 HASHBUFFER.;1 HASHDATUM.;1 HEADLINE.;1 HISTMENU.;1 IDEASKETCH.;1 IDLEHAX.;1 IMAGEWRITER.;1 *IMTEDIT.;1 IMNAME.;1 IMTOOLS.;1 IMTRAN.;1 INSPECTCODE-TEDIT.;1 IRISCONSTANTS IRISDEMOFNS IRISIO IRISLIB IRISNET IRISSTREAM IRISVIEW LOADIRIS SFFONT GACHAE.LC1-SF;2 GACHAE.LC2-SF;2 GACHAE.NUM-SF;2 GACHAE.S1-SF;2 GACHAE.S2-SF;2 GACHAE.UC1-SF;2 GACHAE.UC2-SF;2 JARGON.;1 JARGON.DB KAL.;1 KEYOBJ.;1 KINETIC.;1 *LAFITEHIGHLIGHT.;1 LCROCK.;1 LIFE.;1 LISTEN.;1 LoadPatches.;1 LOGOCLOCK.;1 LSET.;1 MACWINDOW.;1 MAGNIFIER.;1 magnifyw.;1 *MAILOMAT.;1 MAKEGRAPH.;1 MANAGER.;1 MATHFNS.;1 *MESATOLISP.;1 MOVE-WINDOWS.;1 multimenu.;1 MULTIW.;1 MUSICKEYBOARD.;2 NOTEPAD.;1 NOTEPAD-CORESTYLES.;1 NQUEENS.;1 PACMAN.;1 PAGEHOLD.;1 PARSER.;1 PARSERG.;1 PATCHUP.;1 PCDAC.;1 PEANO.;1 PERFORMTRAN.;1 PIECE-MENUS.;1 PLAY.;1 PLOT.;2 PLOTEXAMPLES.;1 PLOTOBJECTS.;1 PLURAL.;1 +PQUOTE.;1 PREEMPTIVE.;1 PRESSFROMNS.;1 PRESSTOIP.;1 DPRESS.;1 PRINTERMENU.;1 Proofreader.;1 ANALYZER.;1 SpellingArray.;1 PULLDOWNMENUS.;1 +QIX.;1 *READBRUSH.;1 RECORDPRINT.;1 REGION.;1 RESETMACROS.;1 ROTATEBM.;1 *RPC.;1 RPC-EXAMPLE.;1 RPC-EXAMPLECLIENT.;1 RPC-EXAMPLESERVER.;1 RPC-EXAMPLEUSER.;1 RPC-LUPINE.;1 RPCEVAL.;1 RPCEVALCLIENT.;1 RPCEVALSERVER.;1 *SAMPLER.;1 SERVERSTATUS.;1 SETDEFAULTPRINTER.;1 SETF.;1 SHOW.;1 SIGNAL.;1 SINGLEFILEINDEX.;1 SLIDEPROJECTOR.;1 SNAPSCROLL.;1 SOLITAIRE.;1 SPACEWINDOW.;1 sprint.;1 STARBG.;1 STOCKICONS.;1 STYLESHEET.;1 +SUPERMENUEDIT.;1 +SUPERMENUS.;1 SYSTAT.;1 +TEDITKEY.;1 THERMOMETER.;1 THERMOMETERDEMO.;1 TILEDEDIT.;1 TIMEPANEL.;1 +TINYTIDY.;1 TMENU.;1 TOGMENU.;1 TRACEIN.;1 TRAJECTORY-FOLLOWER.;1 TRANSOR.;1 TRUEHAX.;1 TSET.;1 TTY.;1 ttyio.;1 TURING.;1 TWOD.;1 TWODGRAPHICS.;1 UNBOXEDOPS.;1 utilisoprs.;1 VMEMSTATE.;1 VSTATS.;1 +WAM.;1 WDWHACKS.;1 WINK.;1 WINNER.;1 WORM.;1 +YAPFF.;1 Other TEDIT files: [on {eris}koto>lispusers> or {eris}koto>] Release-intro.tedit intro for released doc's Release-rules.tedit rules for released doc's Internal-intro.tedit intro for internal doc's Internal-rules.tedit rules for internal doc's blankpage.tedit blank page for printing screwups... documentationtemplate.tedit long template for doc's easytemplate.tedit short template for doc's lispusers-rules.tedit old LU rules RELEASE-INFO.tedit This document LISPUSERS.TEDIT Short package summaries \ No newline at end of file diff --git a/lispusers/LOADIRIS b/lispusers/LOADIRIS new file mode 100644 index 00000000..a7d0c5a4 --- /dev/null +++ b/lispusers/LOADIRIS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "10-May-88 00:44:06" {ERINYES}MEDLEY>LOADIRIS.;1 15990 previous date%: " 4-Feb-87 20:09:38" {ERINYES}LYRIC>LOADIRIS.;1) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOADIRISCOMS) (RPAQQ LOADIRISCOMS ((FILES FREEMENU) (FNS LI.CIRCLES LI.LOAD LI.MAKEMENU LI.SETUP IRIS.CREATE.ICON IRIS.DOMENU IRIS.TRY LOADIRIS INSTALLIRIS LI.TRAVEL) (VARS (IRIS.DIRECTORY '{ERIS}NEXT>) IRIS.MENU.COMMANDS IRISFILES LI.SETUP.ALL LI.SETUP.CLEAR LI.SETUP.DEBUG LI.SETUP.STANDARD LI.SHADE LOCATED.IRISFILES LOCATED.IRISPATCHFILE (LI.MENU)) (BITMAPS LI.DOIT LI.IRISLOGO IRIS.ICON IRIS.ICON.MASK) (P (IRIS.CREATE.ICON) (printout T "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." T)))) (FILESLOAD FREEMENU) (DEFINEQ (LI.CIRCLES [LAMBDA (X) (* gbn " 5-Aug-85 15:25") (for F to (OR X 100) do (IRIS.COLOR (RAND 0 7)) (IRIS.CIRCF (RAND 0 1000) (RAND 0 800) (RAND 50 200))) (IRIS.GFLUSH]) (LI.LOAD [LAMBDA (item window button) (* ; "Edited 9-Jan-87 15:28 by gbn") (printout PROMPTWINDOW T "[Loading Iris Files]") (RESETLST [RESETSAVE (BITBLT NIL NIL NIL window NIL NIL NIL NIL 'TEXTURE 'INVERT LI.SHADE) `(BITBLT NIL NIL NIL ,window NIL NIL NIL NIL TEXTURE INVERT ,LI.SHADE] (* (QUOTE LIST) (QUOTE REDISPLAYW)  window) (* ;; "This cruft seems to count on the fact that the only the buttons that are selected are in fm.getstate. (so the list looks like (file1 t file2 t), and not (file1 t file2 nil file3 t))") (FOR FILENAME IN (FM.GETSTATE WINDOW) WHEN (NEQ FILENAME T) DO (SETQ FILENAME (PACKFILENAME 'DIRECTORY IRIS.DIRECTORY 'BODY FILENAME)) (IF (FILENAMEFIELD FILENAME 'EXTENSION) THEN (LOAD FILENAME) ELSE (LOAD FILENAME 'PROP]) (LI.MAKEMENU [LAMBDA NIL (* ; "Edited 9-Jan-87 15:30 by gbn") (if (WINDOWP LI.MENU) then (CLOSEW LI.MENU)) (SETQ LI.MENU (FREEMENU `(((LABEL Setup%: TYPE DISPLAY FONT (HELVETICA 10 BOLD)) (LABEL CLEAR TYPE MOMENTARY SELECTEDFN LI.SETUP) (LABEL Standard TYPE MOMENTARY SELECTEDFN LI.SETUP) (LABEL Debug TYPE MOMENTARY SELECTEDFN LI.SETUP) (LABEL ALL TYPE MOMENTARY SELECTEDFN LI.SETUP)) ,@[LET* ([strLength (ADD1 (APPLY (FUNCTION MAX) (MAPCAR IRISFILES (FUNCTION NCHARS] (spaces (ALLOCSTRING strLength " "))) (MAPCAR IRISFILES (FUNCTION (LAMBDA (FILENAME) `((LABEL ,(SUBSTRING (CONCAT FILENAME ":" spaces) 1 strLength) TYPE DISPLAY FONT (GACHA 8 BOLD)) (LABEL ,COMPILE.EXT ID ,(PACKFILENAME 'NAME FILENAME 'EXTENSION COMPILE.EXT) TYPE TOGGLE FONT (GACHA 8 STANDARD)) (LABEL Source ID ,FILENAME TYPE TOGGLE FONT (GACHA 8 STANDARD] ((LABEL "Load --" TYPE DISPLAY FONT (HELVETICA 12 BOLD)) (LABEL ,LI.IRISLOGO TYPE MOMENTARY SELECTEDFN LI.LOAD MESSAGE "Loads the selected Iris files"))) "Iris Loadup Panel")) (for setup in LI.SETUP.STANDARD when (CDR setup) do (FM.CHANGESTATE (FM.GETITEM (CAR setup) NIL LI.MENU) (CDR setup) LI.MENU)) (printout PROMPTWINDOW T "Please put the LoadIris menu somewhere") (MOVEW LI.MENU LASTMOUSEX LASTMOUSEY) (MOVEW LI.MENU) LI.MENU]) (LI.SETUP [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 24-Dec-86 14:29 by gbn") (FOR SETUP IN [EVALV (PACK* 'LI.SETUP. (U-CASE (FM.ITEMPROP ITEM 'LABEL] DO (* ; "THIS IS RIDICULOUS...") (IF (EQ (FM.CHANGESTATE (FM.GETITEM (CAR SETUP) NIL WINDOW) (CDR SETUP) WINDOW) (CDR SETUP)) THEN (FM.CHANGESTATE (FM.GETITEM (CAR SETUP) NIL WINDOW) (CDR SETUP) WINDOW]) (IRIS.CREATE.ICON [LAMBDA (position) (* ; "Edited 2-Feb-87 23:34 by gbn") (if (NOT position) then (printout PROMPTWINDOW T "Please position the Iris icon somewhere")) (LET ((window (ICONW IRIS.ICON IRIS.ICON.MASK position))) (WINDOWPROP window 'SHRINKFN 'DON'T) (WINDOWPROP window 'BUTTONEVENTFN 'IRIS.DOMENU]) (IRIS.DOMENU [LAMBDA (window) (* LeL, " 9-Sep-85 01:36") (if (NOT (WINDOWPROP window 'MENU)) then (WINDOWPROP window 'MENU (create MENU ITEMS _ IRIS.MENU.COMMANDS))) (MENU (WINDOWPROP window 'MENU]) (IRIS.TRY [LAMBDA NIL (* LeL, " 4-Sep-85 15:42") (* opens a connection and runs two  dumb demos) (OPEN.IRISCONN) (* this defaults to the value of  IRISNSHOSTNUMBER) (IRIS.GINIT) (* must be executed before the iris is ready to accept graphic commands) (for I to 5 do (LI.CIRCLES) (LI.TRAVEL]) (LOADIRIS [LAMBDA (options) (* LeL, " 3-Sep-85 11:55") (* * loads the files necessary to open a connection to the iris and use the  graphics library) [if (FMEMB %'DCOMS options) then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file) (LOAD? (PACK* file %'.DCOM] [if (FMEMB %'SOURCES options) then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file) (LOAD? file %'PROP] (if (FMEMB %'PATCHES options) then (LOAD LOCATED.IRISPATCHFILE]) (INSTALLIRIS [LAMBDA (NODCOMS NOSOURCES) (* BDV "19-Jul-85 19:08") (* * moves the iris files from my working dir to {eris}current>) (COPYFILES IRISFILES %'{ERIS}CURRENT>) (COPYFILES (for F in IRISFILES collect (PACK* F ".DCOM")) %'{ERIS}CURRENT>) (COPYFILES %'IRISIO.DCOM %'{ERIS}CURRENT>]) (LI.TRAVEL [LAMBDA (COLOR) (* gbn " 5-Aug-85 21:33") (* dumb demo to try double buffering) (IRIS.DOUBLEBUFFER) (IRIS.GCONFIG) (if (NOT COLOR) then (SETQ COLOR (RAND 0 6))) (for I from 5 to 1000 by 10 do (IRIS.COLOR 8) (IRIS.CLEAR) (IRIS.COLOR COLOR) (IRIS.CIRCF I (IQUOTIENT I 2) (IQUOTIENT I 5)) (IRIS.SWAPBUFFERS)) (IRIS.GFLUSH) (IRIS.SINGLEBUFFER) (IRIS.GCONFIG]) ) (RPAQQ IRIS.DIRECTORY {ERIS}NEXT>) (RPAQQ IRIS.MENU.COMMANDS (("Clear IRIS" (CLEARIRIS)) ("Open IRIS stream" (if (MOUSECONFIRM "New stream? (lose fonts, etc.) Left to confirm" ) then (SETQ IRISCONN) (OPENIRISSTREAM))) ("Create IRISview panel" (IV.INIT)) ("Enable bootserver" (if (GETD 'IRISBOOTSERVER) then (IRISBOOTSERVER T) else (PROMPTPRINT "IRISNET must be loaded to use the boot server" )) "Allows the Lisp Machine to boot the IRIS") ("Disable bootserver" (if (GETD 'IRISBOOTSERVER) then (IRISBOOTSERVER NIL) else (PROMPTPRINT "IRISNET must be loaded to use the boot server" )) "Prevents the Lisp Machine from booting the IRIS"))) (RPAQQ IRISFILES (IRISSTREAM IRISNET IRISVIEW)) (RPAQQ LI.SETUP.ALL ((IRISSTREAM . T) (IRISSTREAM.LCOM . T) (IRISNET . T) (IRISNET.LCOM . T) (IRISVIEW.LCOM T) (IRISVIEW T))) (RPAQQ LI.SETUP.CLEAR ((IRISSTREAM) (IRISSTREAM.LCOM) (IRISNET) (IRISNET.LCOM) (IRISVIEW) (IRISVIEW.LCOM))) (RPAQQ LI.SETUP.DEBUG ((IRISSTREAM . T) (IRISSTREAM.LCOM . T) (IRISVIEW . T) (IRISVIEW.LCOM . T) (IRISNET.LCOM . T))) (RPAQQ LI.SETUP.STANDARD ((IRISSTREAM.LCOM . T) (IRISNET.LCOM . T) (IRISVIEW.LCOM . T))) (RPAQQ LI.SHADE 18432) (RPAQQ LOCATED.IRISFILES ({QV}IRIS>GL2>IRISLIB {ERIS}IRISSTREAM {ERIS}IRISNET {QV}IRIS>GL2>IRISIO {ERIS}IRISDIGDEMO)) (RPAQQ LOCATED.IRISPATCHFILE {QV}IRIS>GL2>IRISPATCH) (RPAQQ LI.MENU NIL) (RPAQQ LI.DOIT #*(20 12)@@@@@@@@GOOOL@@@D@@@D@@@EHIGD@@@EEEBD@@@EEEBD@@@EEEBD@@@EHIBD@@@D@@@D@@@GOOOL@@@@@@@@@@@@@@@@@@@ ) (RPAQQ LI.IRISLOGO #*(16 16)@NG@CJELFBDFCHAL@NG@NCLGKHAMHNGAHBDAKJEMNBDGHJEACJELFBDFCJEL@NG@) (RPAQQ IRIS.ICON #*(75 82)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@@@@@@COAOH@@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@OOLOANGON@@@@@@@@@@COO@OANAOOH@@@@@@@@@OOL@OAN@GON@@@@@@@@COO@@OAN@AOOH@@@@@@@OOL@@OAN@@GON@@@@@@COO@@@OAN@@AOOH@@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@OOL@@@@OAN@@@@GON@@AOO@@@@@OAN@@@@AOO@@COL@@@@@OAN@@@@@GOH@COH@@@@@OAN@@@@@COH@CON@@@@@OAN@@@@@OOH@AOOH@@@@OAN@@@@COO@@@OON@@@@OAN@@@@OON@@@COOH@@@OAN@@@COOH@@@@OON@@@OAN@@@OON@@@A@COOH@@OAN@@COOHA@@CL@OON@@OAN@@OON@GH@CO@COOH@OAN@COOHAOH@COL@OON@OAN@OON@GOH@COO@COOHOANCOOHAOOH@COOL@OONCAHOON@GOOH@COOO@COOH@COOHAOOOH@CLOOL@OON@OON@GONGH@CLCOO@COOKOOHAOOHGH@CL@OOL@OOOON@GON@GH@CL@COO@COOOHAOOH@GH@CL@@OOL@OON@GON@@GH@CL@@COO@COHAOOH@@GH@CL@@@OOL@N@GON@@@GH@CL@@@COO@@AOOH@@@GH@CL@@@@OOL@GON@@@@GH@CL@@@@CON@OOH@@@@GH@CL@@@@@OOAON@@@@@GH@CL@@@@BCOAOHH@@@@GH@CL@@@@OHOANCN@@@@GH@CL@@@COLOANGOH@@@GH@CL@@@OOLOANGON@@@GH@CL@@COO@OANAOOH@@GH@CL@@OOL@OAN@GON@@GH@CL@COO@BOANHAOOH@GH@CL@OOL@NOANN@GON@GH@CLCOO@CNOANOHAOOHGH@CLOOL@ONOANON@GONGH@COOO@CONOANOOHAOOOH@COOL@OOLOANGON@GOOH@COO@COO@OANAOOHAOOH@COL@OOL@OAN@GON@GOH@CO@COO@@OAN@AOOHAOH@CL@OOL@@OAN@@GON@GH@A@COO@@@OAN@@AOOHA@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@GOL@@@@OAN@@@@GOL@@@OO@@@@@OAN@@@@AON@@@OL@@@@@OAN@@@@@GN@@@OO@@@@@OAN@@@@AON@@@OOL@@@@OAN@@@@GOL@@@COO@@@@OAN@@@AOOH@@@@OOL@@@OAN@@@GON@@@@@COO@@@OAN@@AOOH@@@@@@OOL@@OAN@@GON@@@@@@@COO@@OAN@AOOH@@@@@@@@OOL@OAN@GON@@@@@@@@@COO@OANAOOH@@@@@@@@@@OOLOANGON@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@@CN@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ IRIS.ICON.MASK #*(75 82)@@@@@@@COKOH@@@@@@@@@@@@@@@OOOON@@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@OOOOOOOON@@@@@@@@@@COOOOOOOOOH@@@@@@@@@OOOOOOOOOON@@@@@@@@COOOOOOOOOOOH@@@@@@@OOOOOOOOOOOON@@@@@@COOOOOOOOOOOOOH@@@@@OOOOOOOOOOOOOON@@@@COOOOOCOOOIOOOOOH@@@OOOOOLCOOOHGOOOON@@COOOOO@COOOHAOOOOOH@GOOOOL@COOOH@GOOOOL@OOOOO@@COOOH@AOOOON@OOOOL@@COOOH@@GOOON@OOOO@@@COOOH@@AOOON@OOON@@@COOOH@@@GOON@OOOOH@@COOOH@@AOOON@OOOON@@COOOH@@GOOON@OOOOOH@COOOH@AOOOON@GOOOON@COOOH@OOOOOL@OOOOOOHCOOOHCOOOOON@OOOOOONCOOOHOOOOOON@OOOOOOOKOOOKOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOCOOOOOOOOOOOOOION@OO@OOOOOOOOOOOONAON@OO@COOOOOOOOOOOHAON@OO@@OOOOOOOOOON@AON@OO@@COOOOOOOOOH@AON@OO@@@OOOOOOOON@@AON@OO@@@COOOOOOOH@@AON@OO@@@OOOOOOOON@@AON@OO@@COOOOOOOOOH@AON@OO@@OOOOOOOOOON@AON@OO@COOOOOOOOOOOHAON@OO@OOOOOOOOOOOONAON@OOCOOOOOOOOOOOOOION@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOCOOOIOOOOOON@OOOOOOLCOOOHGOOOOON@OOOOOO@COOOHAOOOOON@GOOOOL@COOOH@GOOOOL@COOOO@@COOOH@AOOOOH@COOOL@@COOOH@@GOOOH@COOO@@@COOOH@@AOOOH@COOOL@@COOOH@@GOOOH@COOOO@@COOOH@AOOOOH@COOOOL@COOOH@GOOOOH@AOOOOO@COOOHAOOOOO@@@OOOOOLCOOOHGOOOON@@@COOOOOCOOOIOOOOOH@@@@OOOOOOOOOOOOOON@@@@@COOOOOOOOOOOOOH@@@@@@OOOOOOOOOOOON@@@@@@@COOOOOOOOOOOH@@@@@@@@OOOOOOOOOON@@@@@@@@@COOOOOOOOOH@@@@@@@@@@OOOOOOOON@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@@OOKON@@@@@@@@ ) (IRIS.CREATE.ICON) (printout T "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." T) (PUTPROPS LOADIRIS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1223 9129 (LI.CIRCLES 1233 . 1608) (LI.LOAD 1610 . 2687) (LI.MAKEMENU 2689 . 5066) ( LI.SETUP 5068 . 5825) (IRIS.CREATE.ICON 5827 . 6230) (IRIS.DOMENU 6232 . 6559) (IRIS.TRY 6561 . 7221) (LOADIRIS 7223 . 7894) (INSTALLIRIS 7896 . 8300) (LI.TRAVEL 8302 . 9127))))) STOP \ No newline at end of file diff --git a/lispusers/LOADMENUITEMS b/lispusers/LOADMENUITEMS new file mode 100644 index 00000000..bab30218 --- /dev/null +++ b/lispusers/LOADMENUITEMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Apr-88 18:04:32" |{EG:PARC:XEROX}LISP>USERS>LOADMENUITEMS.;6| 13487 changes to%: (FNS LoadUtilityPackage) previous date%: " 3-Dec-87 11:38:28" |{EG:PARC:XEROX}LISP>USERS>LOADMENUITEMS.;5|) (* " Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOADMENUITEMSCOMS) (RPAQQ LOADMENUITEMSCOMS ( (* ;;; "Defines a new FILEPKGCOM called LOADMENUITEMS that can be used to add entries onto the background menu for easy loading of utility files") (FNS AddLoadMenuItem LoadUtilityPackage PickLoadUtilityItem LOADMENUITEMSCOMS) (FILEPKGCOMS LOADMENUITEMS) (* ;; "Make the Filemanager happy") (DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT LOADMENUITEMS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PickLoadUtilityItem))))) (* ;;; "Defines a new FILEPKGCOM called LOADMENUITEMS that can be used to add entries onto the background menu for easy loading of utility files" ) (DEFINEQ (AddLoadMenuItem (LAMBDA (group fileDescr startUpForm) (* ; "Edited 2-Dec-87 11:00 by smL") (* ;;; "Add a menu item to the background menu that will load the file{s} --- group is the submenu name for this file, default is Misc --- fileDescr is a list that can be passed to DOFILESLOAD to load the file{s} --- startUpForm is an optional form that will be evaluated after the LOAD, default will print a nice msg in the prompt window") (DECLARE (GLOBALVARS BackgroundMenu BackgroundMenuCommands)) (LET* ((group (OR group "Misc")) (fileDescr (MKLIST fileDescr)) (fileName (for x in fileDescr thereis (NOT (LISTP x)))) (startUpFormProvided (NOT (NULL startUpForm))) (startUpForm (OR startUpForm `(PROMPTPRINT ',fileName " loaded"))) (loadForm `'(LISPXEVAL '(LoadUtilityPackage ',fileDescr ',startUpForm) "_")) (topLevelItem (OR (for item in BackgroundMenuCommands thereis (STRING-EQUAL (CAR item) "Load utility")) (LET ((topLevelItem (LIST "Load utility" NIL "Load a utility file" (LIST 'SUBITEMS)))) (/push BackgroundMenuCommands topLevelItem) topLevelItem))) (groupItem (OR (for item in (CDAR (LAST topLevelItem)) thereis (STRING-EQUAL group (CAR item))) (LET ((groupList (LIST group NIL "Load a utility file" (LIST 'SUBITEMS)))) (/push (CDAR (LAST topLevelItem)) groupList) (SORT (CDAR (LAST topLevelItem)) (FUNCTION (LAMBDA (x y) (ALPHORDER (CAR x) (CAR y))))) groupList))) (newItem (LIST fileName loadForm (CONCAT "Load " fileName)))) (COND ((for item in (CAR (LAST groupItem)) thereis (EQUAL item newItem)) (* ; "Don't bother to add the item if it's already there") NIL) ((AND (NOT startUpFormProvided) (for file in fileDescr when (NOT (LISTP file)) always (NOT (NULL (GETPROP (ROOTFILENAME (U-CASE file) T) 'FILEDATES))))) (* ; "If there is no start-up form and all the files are already loaded, don't bother adding the item") NIL) (T (* ; "Go ahead and add the item") (/NCONC1 (CAR (LAST groupItem)) newItem) (SORT (CDAR (LAST groupItem)) (FUNCTION (LAMBDA (x y) (ALPHORDER (CAR x) (CAR y))))) (SETQ BackgroundMenu NIL) (UNDOSAVE `(SETQ ,BackgroundMenu NIL))))))) (LoadUtilityPackage (LAMBDA (fileDescr startUpForm) (* ; "Edited 20-Apr-88 18:04 by smL") (* ;;; "Load the package. See the function AddLoadMenuItem.") (ALLOW.BUTTON.EVENTS) (LET* ((myWindow (WFROMDS (TTYDISPLAYSTREAM))) (windowOpen? (OPENWP myWindow))) (* ; "Let the use know what is going on") (printout NIL T "Loading " (for x in fileDescr thereis (NOT (LISTP x))) T) (* ; "Do the load") (DOFILESLOAD (for x in fileDescr collect (if (LISTP x) then x else (MKATOM (U-CASE x))))) (EVAL startUpForm) (* ; "Now remove the load menu item, if you can find it") (LET ((topLevelItem (for item in BackgroundMenuCommands thereis (STRING-EQUAL (CAR item) "Load utility")))) (for groupItem in (CDAR (LAST topLevelItem)) bind thisItem eachtime (SETQ thisItem (for item in (CDAR (LAST groupItem)) thereis (EQ fileDescr (CADR (CADR (CADR (CADR (CADR (CADR item)))))))) ) when thisItem do (DREMOVE thisItem (CAR (LAST groupItem))) (if (NULL (CDAR (LAST groupItem))) then (DREMOVE groupItem (CDAR (LAST topLevelItem)) )) (change BackgroundMenu NIL))) (* ; "Close any TTY window that we may have opened") (if (NOT windowOpen?) then (CLOSEW myWindow))))) (PickLoadUtilityItem (CL:LAMBDA (XCL-USER::UTILITY-NAME &OPTIONAL XCL-USER::GROUP-NAME XCL-USER::NO-ERRORS-P) (* ; "Edited 3-Dec-87 11:29 by smL") (* ;;; "Many thanks to Andy Cameron for this function.") (* ;;; "Provides a way to programatically chose items from the LoadUtility Menu item") (* ;;; "Eg: (PickLoadUtilityItem %"FileWatch%")") (CL:LABELS ((XCL-USER::ITEM-LABEL (XCL-USER::MENU-ITEM) (CL:FIRST XCL-USER::MENU-ITEM)) (XCL-USER::ITEM-BODY (XCL-USER::MENU-ITEM) (CL:SECOND XCL-USER::MENU-ITEM)) (XCL-USER::ITEM-SUB-ITEMS (XCL-USER::MENU-ITEM) (CL:REST (CL:FOURTH XCL-USER::MENU-ITEM))) (XCL-USER::DO-ITEM (XCL-USER::MENU-ITEM) (CL:EVAL (CL:EVAL (XCL-USER::ITEM-BODY XCL-USER::MENU-ITEM)))) (XCL-USER::LOOKUP (XCL-USER::X XCL-USER::ALIST) (CL:ASSOC XCL-USER::X XCL-USER::ALIST :TEST #'STRING-EQUAL)) (XCL-USER::MAKE-MENU (&KEY XCL-USER::ITEMS XCL-USER::TITLE) (create MENU TITLE _ XCL-USER::TITLE ITEMS _ XCL-USER::ITEMS CENTERFLG _ T))) (* ;; "") (* ;; "Find all the matching utilities") (LET ((XCL-USER::GROUP-ITEMS (CL:REMOVE-IF-NOT #'(CL:LAMBDA (XCL-USER::GROUP-ITEM) (AND (XCL-USER::LOOKUP XCL-USER::UTILITY-NAME (XCL-USER::ITEM-SUB-ITEMS XCL-USER::GROUP-ITEM)) (OR (NULL XCL-USER::GROUP-NAME) (STRING-EQUAL XCL-USER::GROUP-NAME (XCL-USER::ITEM-LABEL XCL-USER::GROUP-ITEM))))) (XCL-USER::ITEM-SUB-ITEMS (XCL-USER::LOOKUP "Load utility" BackgroundMenuCommands))))) (COND ((= 1 (CL:LENGTH XCL-USER::GROUP-ITEMS)) (* ;; "Exactly one applicable item, so use it") (XCL-USER::DO-ITEM (XCL-USER::LOOKUP XCL-USER::UTILITY-NAME ( XCL-USER::ITEM-SUB-ITEMS (CL:FIRST XCL-USER::GROUP-ITEMS )))) T) (XCL-USER::NO-ERRORS-P (* ;; "Forget it.") NIL) ((NULL XCL-USER::GROUP-ITEMS) (* ;; "Not found anywhere.") (CL:CERROR "Forget loading the utility." "~%%Utility ~A not found under ~A on the LoadUtilty menu." XCL-USER::UTILITY-NAME (OR XCL-USER::GROUP-NAME "any group")) NIL) (T (* ;; "Found in more that one place.") (CL:CERROR "Pick one of them to load." "~%%Utility ~A found under multiple groups on the LoadUtilty menu.~%%~{ ~A~}" XCL-USER::UTILITY-NAME (CL:MAPCAR #'XCL-USER::ITEM-LABEL XCL-USER::GROUP-ITEMS)) (LET ((XCL-USER::GROUP-ITEM (MENU (XCL-USER::MAKE-MENU :TITLE "Load utility from which group?" :ITEMS (CL:MAPCAR #'(CL:LAMBDA (XCL-USER::GROUP-ITEM) (LIST (XCL-USER::ITEM-LABEL XCL-USER::GROUP-ITEM) XCL-USER::GROUP-ITEM)) XCL-USER::GROUP-ITEMS))))) (CL:WHEN XCL-USER::GROUP-ITEM (XCL-USER::DO-ITEM (XCL-USER::LOOKUP XCL-USER::UTILITY-NAME (XCL-USER::ITEM-SUB-ITEMS XCL-USER::GROUP-ITEM))) T)))))))) (LOADMENUITEMSCOMS (LAMBDA (GROUP X) (* smL "16-Sep-86 18:37") (* * Expand the LOADMENUITEMS filepackage command) (LIST (CONS 'P (for packageDescr in X collect (if (LITATOM packageDescr) then `(AddLoadMenuItem ',GROUP ',packageDescr) elseif (EQLENGTH packageDescr 1) then `(AddLoadMenuItem ',GROUP ',(CAR packageDescr)) elseif (EQLENGTH packageDescr 2) then `(AddLoadMenuItem ',GROUP ',(CAR packageDescr) ',(CADR packageDescr)) else (ERROR "Utility description has too many arguments" packageDescr ))))))) ) (PUTDEF (QUOTE LOADMENUITEMS) (QUOTE FILEPKGCOMS) '((COM MACRO ((GROUP . X) (COMS * (LOADMENUITEMSCOMS 'GROUP 'X))) CONTENTS NILL))) (* ;; "Make the Filemanager happy") (DECLARE%: DONTCOPY (PUTPROPS LOADMENUITEMS MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PickLoadUtilityItem) ) (PUTPROPS LOADMENUITEMS COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1383 12694 (AddLoadMenuItem 1393 . 4836) (LoadUtilityPackage 4838 . 6887) ( PickLoadUtilityItem 6889 . 11805) (LOADMENUITEMSCOMS 11807 . 12692))))) STOP \ No newline at end of file diff --git a/lispusers/LOADMENUITEMS.TEDIT b/lispusers/LOADMENUITEMS.TEDIT new file mode 100644 index 00000000..2dadae2d Binary files /dev/null and b/lispusers/LOADMENUITEMS.TEDIT differ diff --git a/lispusers/LOGIC b/lispusers/LOGIC new file mode 100644 index 00000000..d04c7c64 --- /dev/null +++ b/lispusers/LOGIC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "USER") (IL:FILECREATED "20-Dec-88 09:27:17" IL:{DSK}LOGIC>MEDLEY>LOGIC.;3 24914 IL:changes IL:to%: (IL:VARS IL:LOGICCOMS) (IL:FUNCTIONS CREATE-BACKGROUND-THEORY SHOW-THEORY) IL:previous IL:date%: "19-Dec-88 10:50:29" IL:{DSK}LOGIC>MEDLEY>LOGIC.;2) (IL:* " Copyright (c) 1988 by Roberto Ghislanzoni. All rights reserved. ") (IL:PRETTYCOMPRINT IL:LOGICCOMS) (IL:RPAQQ IL:LOGICCOMS ((IL:* IL:THESE IL:ARE IL:MACROS) (IL:FUNCTIONS AND-LEVEL ANTEC ATOMIC-FORMULAP CLAUSES-OR CONJ CONSEQP DIRECTLY-IMPLEMENTED FAILEDP FORMULA-OR GET-AND-NODE-THEORIES GET-CUT GET-OR-NODE-THEORIES GET-THEORY IMPLICATIONP NULL-AND-LEVELP NULL-OR-LEVELP NULL-TREEP OR-LEVELS SEMANTIC-ATTACHMENT-P THEORYP UNIF-ENV-OR UNIFICATION-ENV) (IL:* AND IL:THESE IL:ARE IL:FUNCTIONS) (IL:FUNCTIONS ADD-OR-LEVEL ALL ALL-PREDICATES ALL-PREDS ALL-SAS ALL-SEMANTIC-ATTACHMENTS ANY ATTACH CLEAR-AND-LEVEL CONSEQ CREATE-BACKGROUND-THEORY CREATE-THEORY DELETE-OR-NODE DELETE-OR-NODE-WITH-CUT FIND-CLAUSES IS-THERE-CUT LIST-ALL-THEORIES LOAD-THEORY LOGIC-ADDA LOGIC-ADDZ LOGIC-ASSERT LOGIC-DELETE LOGIC-DELETE-FACT LOGIC-PROVE MAKE-AND-NODE MAKE-OR-NODE MAKE-TREE MERGE-INTERNAL MERGE-THEORIES NEW-TREE PREDICATE PROVE RENAME-CUT SAVE-THEORY SHOW-DEFINITION SHOW-THEORY SOLVE SUBSTITUTE-LEVEL UPDATE-ENV UPDATE-LEVEL UPDATE-TREE) (IL:VARS *PRINT-PRETTY*) (IL:P (IL:FILESLOAD LOGIC-UNIFIER)))) (IL:* IL:THESE IL:ARE IL:MACROS) (DEFMACRO AND-LEVEL (TREE) `(CAR ,TREE)) (DEFMACRO ANTEC (WFF) `(CDDR ,WFF)) (DEFMACRO ATOMIC-FORMULAP (WFF) `[AND (LISTP ,WFF) (NULL (SECOND ,WFF]) (DEFMACRO CLAUSES-OR (OR-NODE) `(SECOND ,OR-NODE)) (DEFMACRO CONJ (AND-LEVEL) `(CAR ,AND-LEVEL)) (DEFMACRO CONSEQP (C) `[AND (LISTP ,C) (SYMBOLP (CAR ,C]) (DEFMACRO DIRECTLY-IMPLEMENTED (CLAUSES) `(EQ (CAR ,CLAUSES) 'DIRECTLY-IMPLEMENTED)) (DEFMACRO FAILEDP (ENV) `(EQ ,ENV 'FAILED)) (DEFMACRO FORMULA-OR (OR-LEVEL) `(CAR ,OR-LEVEL)) (DEFMACRO GET-AND-NODE-THEORIES (AND-NODE) `(THIRD ,AND-NODE)) (DEFMACRO GET-CUT (OR-NODE) `(SIXTH ,OR-NODE)) (DEFMACRO GET-OR-NODE-THEORIES (OR-NODE) `(FIFTH ,OR-NODE)) (DEFMACRO GET-THEORY (THEORY-NAME &OPTIONAL WINDOW) `(OR (AND ,WINDOW (GET-THEORY-INTERNAL ,THEORY-NAME ,WINDOW)) (GET 'THEORY ,THEORY-NAME))) (DEFMACRO IMPLICATIONP (WFF) `[LET [(SEPARATOR (SECOND ,WFF] (AND (EQ SEPARATOR ':-) (NOT (NULL (CDDR ,WFF]) (DEFMACRO NULL-AND-LEVELP (TREE) `(NULL (CAR ,TREE))) (DEFMACRO NULL-OR-LEVELP (TREE) `(NULL (SECOND ,TREE))) (DEFMACRO NULL-TREEP (TREE) `(AND (NULL-AND-LEVELP ,TREE) (NULL-OR-LEVELP ,TREE))) (DEFMACRO OR-LEVELS (TREE) `(SECOND ,TREE)) (DEFMACRO SEMANTIC-ATTACHMENT-P (SA) `(EQ (CAR ,SA) 'SA)) (DEFMACRO THEORYP (THEORY &OPTIONAL WINDOW) `(OR (AND (GET-THEORY ,THEORY ,WINDOW) T) (HASH-TABLE-P ,THEORY))) (DEFMACRO UNIF-ENV-OR (OR-NODE) `(FOURTH ,OR-NODE)) (DEFMACRO UNIFICATION-ENV (AND-NODE) `(SECOND ,AND-NODE)) (IL:* AND IL:THESE IL:ARE IL:FUNCTIONS) (DEFUN ADD-OR-LEVEL (WFF CLAUSES TREE &OPTIONAL CUTNAME) (IL:* IL:;;  "Adds a new or-node to the list of the nodes. The new node is put in front of the old ones") [COND ((NULL CLAUSES) TREE) (T (LET* ((LEVEL (AND-LEVEL TREE)) (NEW-OR-NODE (MAKE-OR-NODE WFF CLAUSES (CONJ LEVEL) (UNIFICATION-ENV LEVEL) (GET-AND-NODE-THEORIES LEVEL) CUTNAME))) (MAKE-TREE LEVEL (APPEND (LIST NEW-OR-NODE) (OR-LEVELS TREE]) (DEFUN ALL (VARS CONJ THS) [PROG (RESULTING-TREE (*VARIABLES-COUNTER* 0) (TREE (MAKE-TREE (MAKE-AND-NODE CONJ NIL (APPEND (LIST '*BACKGROUND-THEORY*) THS)) NIL)) COLLECTED-RESULTS NEXT-OR) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) HERE (SETF RESULTING-TREE (LOGIC-PROVE TREE)) (COND ((NULL RESULTING-TREE) (RETURN COLLECTED-RESULTS)) (T [SETF COLLECTED-RESULTS (APPEND COLLECTED-RESULTS (LIST (LOOKUP VARS (UNIFICATION-ENV (AND-LEVEL RESULTING-TREE] (SETF NEXT-OR (FIRST (OR-LEVELS RESULTING-TREE))) (SETF TREE (SOLVE (NEW-TREE RESULTING-TREE NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR))) (GO HERE]) (DEFUN ALL-PREDICATES (THEORY-NAME) (ALL-PREDS (GET-THEORY THEORY-NAME))) (DEFUN ALL-PREDS (THEORY) (IL:* IL:;; "The presence of VAL in the AND body is necessary because it is correct to test if the predicates has not been erased: in such a case its value is NIL") (PROG (PRNAMES) LABEL (MAPHASH #'[LAMBDA (KEY VAL) (AND (NOT (SEMANTIC-ATTACHMENT-P VAL)) VAL (SETF PRNAMES (APPEND PRNAMES (LIST KEY] THEORY) (RETURN PRNAMES))) (DEFUN ALL-SAS (THEORY) (PROG (SANAMES) LABEL (MAPHASH #'[LAMBDA (KEY VAL) (AND (SEMANTIC-ATTACHMENT-P VAL) VAL (SETF SANAMES (APPEND SANAMES (LIST KEY] THEORY) (RETURN SANAMES))) (DEFUN ALL-SEMANTIC-ATTACHMENTS (THEORY-NAME) (ALL-SAS (GET-THEORY THEORY-NAME))) (DEFUN ANY (HOW-MANY VARS CONJ THS) [PROG (RESULTING-TREE (*VARIABLES-COUNTER* 0) (COUNTER 0) (TREE (MAKE-TREE (MAKE-AND-NODE CONJ NIL (APPEND (LIST '*BACKGROUND-THEORY*) THS)) NIL)) COLLECTED-RESULTS NEXT-OR) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) HERE (SETF RESULTING-TREE (LOGIC-PROVE TREE)) (COND ((OR (NULL RESULTING-TREE) (EQ COUNTER HOW-MANY)) (RETURN COLLECTED-RESULTS)) (T [SETF COLLECTED-RESULTS (APPEND COLLECTED-RESULTS (LIST (LOOKUP VARS (UNIFICATION-ENV (AND-LEVEL RESULTING-TREE] (SETF NEXT-OR (FIRST (OR-LEVELS RESULTING-TREE))) (SETF TREE (SOLVE (NEW-TREE RESULTING-TREE NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR))) (INCF COUNTER) (GO HERE]) (DEFUN ATTACH (SA-NAME DEFINITION THEORY-NAME &OPTIONAL WINDOW) (SETF (GETHASH SA-NAME (GET-THEORY THEORY-NAME WINDOW)) (CONS 'SA DEFINITION)) 'ATTACHED) (DEFUN CLEAR-AND-LEVEL (TREE) (PROGN (SETF (CAR TREE) NIL) TREE)) (DEFUN CONSEQ (WFF) (CAR WFF)) (DEFUN CREATE-BACKGROUND-THEORY () [PROGN (IN-PACKAGE 'USER) (CREATE-THEORY '*BACKGROUND-THEORY*) (WITH-OPEN-FILE (FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME 'LOGIC :TYPE 'LGC)) :DIRECTION :INPUT) (PROG (NAME) LABEL (AND (EQ (SETF NAME (READ FILE)) 'THEORY-END) (RETURN)) (LOGIC-ASSERT NAME (CONS 'DIRECTLY-IMPLEMENTED (READ FILE)) '*BACKGROUND-THEORY*) (GO LABEL]) (DEFUN CREATE-THEORY (THEORY-NAME) (SETF (GET 'THEORY THEORY-NAME) (MAKE-HASH-TABLE)) THEORY-NAME) (DEFUN DELETE-OR-NODE (TAGNODE NODES) (DELETE TAGNODE NODES :TEST #'EQUAL :COUNT 1)) (DEFUN DELETE-OR-NODE-WITH-CUT (CUTNAME OR-LEVELS) (IL:* IL:;; "This function is called every time a cut is proven: all the alternatives for that clause MUST be erased. Remember that every cut has a unique identifier") [PROG ((NODES OR-LEVELS)) LABEL (COND ((NULL NODES) (RETURN OR-LEVELS)) ((EQ (GET-CUT (CAR NODES)) CUTNAME) (RETURN (DELETE-OR-NODE (CAR NODES) OR-LEVELS))) (T (SETF NODES (CDR NODES)) (GO LABEL]) (DEFUN FIND-CLAUSES (PREDICATE-NAME THEORY-NAMES &OPTIONAL WINDOW) [PROG NIL LABEL (COND ((NULL THEORY-NAMES) (RETURN NIL)) (T (LET* ((TH (FIRST THEORY-NAMES)) (CLAUSES (BINDING PREDICATE-NAME TH WINDOW))) (COND ((NULL CLAUSES) (SETF THEORY-NAMES (CDR THEORY-NAMES)) (GO LABEL)) (T (RETURN CLAUSES]) (DEFUN IS-THERE-CUT (CONJS) [OR (MEMBER '! CONJS) (PROG ((ELTS CONJS)) LABEL (COND ((NULL ELTS) NIL) ((AND (SYMBOLP (CAR ELTS)) (EQ (CHAR-CODE (CHAR (SYMBOL-NAME (CAR ELTS)) 0)) 33)) (RETURN T)) (T (SETF ELTS (CDR ELTS)) (GO LABEL]) (DEFUN LIST-ALL-THEORIES (&OPTIONAL WINDOW) [OR (AND WINDOW (LIST-ALL-THEORIES-INTERNAL WINDOW)) (DO ((LL (SYMBOL-PLIST 'THEORY) (CDDR LL)) (RESULT NIL)) ((NULL LL) RESULT) [SETF RESULT (APPEND RESULT (LIST (CAR LL])]) (DEFUN LOAD-THEORY (THEORY-NAME &OPTIONAL WINDOW) [LET [(THEORY-FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME THEORY-NAME :TYPE 'LGC] (OR (AND WINDOW (LOAD-DEVEL-THEORY WINDOW THEORY-NAME)) (OR [AND (PROBE-FILE THEORY-FILE) (WITH-OPEN-FILE (FILE THEORY-FILE :DIRECTION :INPUT) (PROG (THEORY-NAME PRED-NUMBER SAS-NUMBER) (SETF THEORY-NAME (READ FILE)) (CREATE-THEORY THEORY-NAME) (SETF SAS-NUMBER (READ FILE)) (DO ((SAS SAS-NUMBER (DECF SAS))) ((EQ SAS 0) NIL) (SETF (GETHASH (READ FILE) (GET 'THEORY THEORY-NAME)) (READ FILE))) (SETF PRED-NUMBER (READ FILE)) (DO ((PREDS PRED-NUMBER (DECF PREDS))) ((EQ PREDS 0) NIL) (SETF (GETHASH (READ FILE) (GET 'THEORY THEORY-NAME)) (READ FILE))) (RETURN 'LOADED] (FORMAT T "Theory not found"]) (DEFUN LOGIC-ADDA (PRED CLAUSES THEORY &OPTIONAL WINDOW) (PROGN [SETF (GETHASH PRED (GET-THEORY THEORY WINDOW)) (APPEND CLAUSES (GETHASH PRED (GET-THEORY THEORY WINDOW] 'ADDED)) (DEFUN LOGIC-ADDZ (PRED CLAUSES THEORY &OPTIONAL WINDOW) (PROGN (SETF (GETHASH PRED (GET-THEORY THEORY WINDOW)) (APPEND (GETHASH PRED (GET-THEORY THEORY WINDOW)) CLAUSES)) 'ADDED)) (DEFUN LOGIC-ASSERT (PREDICATE-NAME CLAUSES THEORY-NAME &OPTIONAL WINDOW) (SETF (GETHASH PREDICATE-NAME (GET-THEORY THEORY-NAME WINDOW)) CLAUSES) 'ASSERTED) (DEFUN LOGIC-DELETE (PRED-OR-SA THEORY-NAME &OPTIONAL WINDOW) (PROGN (SETF (GETHASH PRED-OR-SA (GET-THEORY THEORY-NAME WINDOW)) NIL) 'DELETED)) (DEFUN LOGIC-DELETE-FACT (FACT-NAME FACT-CLAUSE THEORY &OPTIONAL WINDOW) (IL:* IL:;; "deletes from the definition of facts one of the definitions themselves") (IL:* IL:;; "((ON a b) (ON b c)) --> ((ON a b))") (PROGN (SETF (GETHASH FACT-NAME (GET-THEORY THEORY WINDOW)) (DELETE FACT-CLAUSE (GETHASH FACT-NAME (GET-THEORY THEORY WINDOW)) :TEST #'EQUAL)) 'DELETED)) (DEFUN LOGIC-PROVE (TREE &OPTIONAL WINDOW) [PROG ((*VARIABLES-COUNTER* -1)) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) (IL:* IL:;; "This is a counter for the variables that will be used during the unification") JUMP (COND ((NULL-TREEP TREE) (RETURN NIL)) [(NULL-AND-LEVELP TREE) (LET [(NEXT-OR (FIRST (OR-LEVELS TREE] (IL:* IL:;;  "Gets the next or-node: we have now no strategy for choosing it; maybe later...") (COND ((NULL NEXT-OR) (SETF TREE (LIST NIL NIL)) (GO JUMP)) (T (SETF TREE (SOLVE (NEW-TREE TREE NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR) NIL WINDOW)) (GO JUMP] (T (LET ((NEXT-LEVEL (AND-LEVEL TREE))) (COND ((NULL (CONJ NEXT-LEVEL)) (RETURN TREE)) (T (LET* [(TO-PROVE (FIRST (CONJ NEXT-LEVEL))) (THS (GET-AND-NODE-THEORIES NEXT-LEVEL)) (CLAUSES (FIND-CLAUSES (PREDICATE TO-PROVE) THS WINDOW)) (CUT? (IS-THERE-CUT (REST (CONJ NEXT-LEVEL] (SETF TREE (SOLVE (UPDATE-TREE (UPDATE-LEVEL NEXT-LEVEL TO-PROVE) TREE) TO-PROVE CLAUSES CUT? WINDOW)) (GO JUMP]) (DEFUN MAKE-AND-NODE (CONJ UNIF-ENV THEORIES) (LIST CONJ UNIF-ENV THEORIES)) (DEFUN MAKE-OR-NODE (WFF CLAUSES BORDER UNIF-ENV THEORIES &OPTIONAL CUTNAME) (LIST WFF CLAUSES BORDER UNIF-ENV THEORIES CUTNAME)) (DEFUN MAKE-TREE (AND-LEVEL OR-LEVELS) (LIST AND-LEVEL OR-LEVELS)) (DEFUN MERGE-INTERNAL (NEW-THEORY-NAME THEORIES &OPTIONAL WINDOW) [PROGN (IL:* IL:;; "Merges the specified theories in to a new-brand theory") (LET ((ACTUAL-THEORY (GET-THEORY NEW-THEORY-NAME WINDOW))) (DO ((THS THEORIES (CDR THS))) ((NULL THS) 'MERGED) (AND (THEORYP (CAR THS) WINDOW) (MAPHASH #'(LAMBDA (KEY VAL) (AND VAL (SETF (GETHASH KEY ACTUAL-THEORY) VAL))) (GET-THEORY (CAR THS) WINDOW))))]) (DEFUN MERGE-THEORIES (NEW-THEORY-NAME &REST LIST-OF-THEORIES) (PROGN (CREATE-THEORY NEW-THEORY-NAME) (MERGE-INTERNAL NEW-THEORY-NAME LIST-OF-THEORIES) 'MERGED)) (DEFUN NEW-TREE (TREE OR-NODE) (MAKE-TREE (MAKE-AND-NODE (THIRD OR-NODE) (UNIF-ENV-OR OR-NODE) (GET-OR-NODE-THEORIES OR-NODE)) (DELETE-OR-NODE OR-NODE (OR-LEVELS TREE)))) (DEFUN PREDICATE (WFF) (COND ((LISTP WFF) (CAR WFF)) (T WFF))) (DEFUN PROVE (CONJ THS) (LET [(RESULT (LOGIC-PROVE (MAKE-TREE (MAKE-AND-NODE CONJ NIL (APPEND (LIST '*BACKGROUND-THEORY*) THS)) NIL] (COND ((NULL RESULT) NIL) (T T)))) (DEFUN RENAME-CUT (ANTECS) (IL:* IL:;; "This function returns a CONS with CAR as the renamed cut and CDR as the list of antecs with the cut renamed") (DO ((TEMPVAR ANTECS (CDR TEMPVAR)) (RESULTS NIL) (CUT-RENAMED NIL)) ((NULL TEMPVAR) (CONS CUT-RENAMED RESULTS)) [COND [(EQ (CAR TEMPVAR) '!) (SETF CUT-RENAMED (GENSYM "!")) (SETF RESULTS (APPEND RESULTS (LIST CUT-RENAMED] (T (SETF RESULTS (APPEND RESULTS (LIST (CAR TEMPVAR])) (DEFUN SAVE-THEORY (THEORY-NAME &OPTIONAL WINDOW) [LET ((THEORY (GET-THEORY THEORY-NAME WINDOW))) (COND ((NOT (THEORYP THEORY)) 'ERROR) (T (WITH-OPEN-FILE (FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME THEORY-NAME :TYPE 'LGC)) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE) (LET [(PREDS (SORT (ALL-PREDS THEORY) #'STRING-LESSP)) (SAS (SORT (ALL-SAS THEORY) #'SORT-LESSP] (PROGN (FORMAT FILE "~S~%%" THEORY-NAME) (FORMAT FILE "~D~%%" (LENGTH SAS)) (DO ((SA-NAME SAS (CDR SA-NAME))) ((NULL SA-NAME) NIL) (FORMAT FILE "~S ~S ~%%" (CAR SA-NAME) (GETHASH (CAR SA-NAME) THEORY))) (FORMAT FILE "~D~%%" (LENGTH PREDS)) (DO ((PRED-NAME PREDS (CDR PRED-NAME))) ((NULL PRED-NAME) NIL) (FORMAT FILE "~S ~S ~%%" (CAR PRED-NAME) (GETHASH (CAR PRED-NAME) THEORY))) 'SAVED]) (DEFUN SHOW-DEFINITION (ELEMENT THEORY-NAME &OPTIONAL WINDOW) [FORMAT (OR (AND WINDOW *TRACE-OUTPUT*) T) "~S~%%" (PROG [(DEF (GETHASH ELEMENT (GET-THEORY THEORY-NAME WINDOW] (OR (AND (SEMANTIC-ATTACHMENT-P DEF) (RETURN (CDR DEF))) (RETURN DEF]) (DEFUN SHOW-THEORY (THEORY-NAME &OPTIONAL VERBOSE WINDOW) [LET* ((THEORY (GET-THEORY THEORY-NAME)) (PREDICATES (SORT (ALL-PREDS THEORY) #'STRING-LESSP)) (SAS (SORT (ALL-SAS THEORY) #'STRING-LESSP)) (STREAM (OR (AND WINDOW *TRACE-OUTPUT*) T))) [OR (AND SAS (PROGN (FORMAT STREAM "Semantic attachments: ~%%") (DO ((PP SAS (CDR PP))) ((NULL PP) NIL) (PROGN (FORMAT T "~%%~S ~%% " (CAR PP)) (AND VERBOSE (FORMAT T "Definition: ~S ~%%" (CDR (GETHASH (CAR PP) THEORY)) " ")))) (FORMAT STREAM "~%% ~%%"] (OR (AND PREDICATES (PROGN (FORMAT STREAM "Predicates: ~%%") (DO ((PP PREDICATES (CDR PP))) ((NULL PP) NIL) (PROGN (FORMAT T "~%%~S ~%%" (CAR PP)) (AND VERBOSE (FORMAT STREAM "Clauses: ~S ~%%" (GETHASH (CAR PP) THEORY) " ")))) (FORMAT STREAM "~%% ~%%"]) (DEFUN SOLVE (TREE FORMULA CLAUSES &OPTIONAL CUT WINDOW) [PROG NIL JUMP (AND WINDOW (SOLVE-DEBUGGER TREE FORMULA CLAUSES WINDOW)) (COND ((NULL CLAUSES) (IL:* IL:; "demo is failed") (RETURN (CLEAR-AND-LEVEL TREE))) ((DIRECTLY-IMPLEMENTED CLAUSES) (IL:* IL:;  "clauses from the main theory") (RETURN (FUNCALL (CDR CLAUSES) TREE FORMULA CLAUSES WINDOW))) [(SEMANTIC-ATTACHMENT-P CLAUSES) (IL:* IL:;  "Semantic attachment defined by the user") (LET [(EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV (AND-LEVEL TREE] (COND ((APPLY (CDR CLAUSES) (CDR EXPANDED-FORMULA)) (RETURN TREE)) (T (RETURN (CLEAR-AND-LEVEL TREE] (T (LET* ((CANDIDATE (FIRST CLAUSES)) (ASSERT (RENAME CANDIDATE)) (NEWENV (UNIFY FORMULA (CONSEQ ASSERT) (UNIFICATION-ENV (AND-LEVEL TREE)) WINDOW))) (COND ((FAILEDP NEWENV) (SETF CLAUSES (REST CLAUSES)) (GO JUMP)) [(ATOMIC-FORMULAP ASSERT) (IL:* IL:;; "If a cut has been discovered in the previous procedure, it is necessary not to instantiate alternatives for the clause in a or-level") (RETURN (UPDATE-ENV NEWENV (OR (AND CUT TREE) (ADD-OR-LEVEL FORMULA (REST CLAUSES) TREE] ((IMPLICATIONP ASSERT) (IL:* IL:;; "If there is a cut, it is necessary to mark the alternatives for that clause; if the cut will be proved, then these alternatives will be eliminated ") (RETURN (COND [(IS-THERE-CUT (ANTEC ASSERT)) (LET* ((RENAMED-STRUCTURE (RENAME-CUT (ANTEC ASSERT))) (RENAMED-CUT (CAR RENAMED-STRUCTURE)) (RENAMED-ASSERT (CDR RENAMED-STRUCTURE))) (SUBSTITUTE-LEVEL NEWENV RENAMED-ASSERT (ADD-OR-LEVEL FORMULA (REST CLAUSES) TREE RENAMED-CUT] (T (SUBSTITUTE-LEVEL NEWENV (ANTEC ASSERT) (ADD-OR-LEVEL FORMULA (REST CLAUSES) TREE]) (DEFUN SUBSTITUTE-LEVEL (ENV ANTECS TREE) (PROGN [RPLACA TREE (MAKE-AND-NODE (APPEND ANTECS (CONJ (AND-LEVEL TREE))) ENV (GET-AND-NODE-THEORIES (AND-LEVEL TREE] TREE)) (DEFUN UPDATE-ENV (ENV TREE) (SETF (SECOND (AND-LEVEL TREE)) ENV) TREE) (DEFUN UPDATE-LEVEL (LEVEL FORMULA) (MAKE-AND-NODE (CDR (CONJ LEVEL)) (UNIFICATION-ENV LEVEL) (GET-AND-NODE-THEORIES LEVEL))) (DEFUN UPDATE-TREE (LEVEL TREE) (MAKE-TREE LEVEL (OR-LEVELS TREE))) (IL:RPAQQ *PRINT-PRETTY* T) (IL:FILESLOAD LOGIC-UNIFIER) (IL:PUTPROPS IL:LOGIC IL:COPYRIGHT ("Roberto Ghislanzoni" 1988)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/LOGIC-DEVEL b/lispusers/LOGIC-DEVEL new file mode 100644 index 00000000..d457be09 --- /dev/null +++ b/lispusers/LOGIC-DEVEL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "USER" READTABLE "INTERLISP" BASE 10) (IL:FILECREATED "19-Dec-88 15:40:33" IL:{DSK}LOGIC>MEDLEY>LOGIC-DEVEL.;7 52955 IL:changes IL:to%: (IL:VARS IL:LOGIC-DEVELCOMS) (IL:FUNCTIONS EDIT-AXIOM EDIT-SA PROMPTREAD) IL:previous IL:date%: "19-Dec-88 14:47:38" IL:{DSK}LOGIC>MEDLEY>LOGIC-DEVEL.;6) (IL:* " Copyright (c) 1987, 1988 by ROBERTO GHISLANZONI. All rights reserved. ") (IL:PRETTYCOMPRINT IL:LOGIC-DEVELCOMS) (IL:RPAQQ IL:LOGIC-DEVELCOMS ((IL:* IL:NOW IL:THESE IL:ARE IL:MACROS) (IL:FUNCTIONS DRIBBLEP SEE-ENV-P SET-MENU TRACINGP) (IL:* IL:THESE IL:ARE IL:FUNCTIONS) (IL:FUNCTIONS CREATE-DEVEL-THEORY CREATE-THEORY-MENU EDIT-AXIOM EDIT-SA GET-LIST-PROP GET-TB-PROPERTY GET-THEORY-INTERNAL LIST-ALL-THEORIES-INTERNAL LOAD-DEVEL-THEORY LOGIC-BUTTONFN LOGIC-DEVELOPER LOGIC-MENU-FUNCTION MERGE-THEORIES-DEVEL MY-CREATE-TBRECORD PRINT-TB-ITEMS PROMPTREAD SAVE-DEVEL-THEORY SHOW-PROFILE SOLVE-DEBUGGER START-PROVING UNIFY-DEBUGGER) (IL:ADDVARS (IL:BackgroundMenuCommands ("Logic" '(IL:ADD.PROCESS '(LOGIC-DEVELOPER)) "Open a window on logic programming environment" ))) (IL:VARS *LOGIC-MENU-ITEMS* *LOGIC-RELEASE-NUMBER* *LOGIC-CLOSE-ON-COMPLETION-FLG* (IL:BackgroundMenu NIL) (IL:LogicMiddleMenu NIL) IL:LogicMiddleMenuCommands) (IL:P (IL:FILESLOAD IL:TABLEBROWSER)) (IL:RECORDS IL:TABLEBROWSER IL:TABLEITEM) (IL:CONSTANTS IL:TB.LEFT.MARGIN))) (IL:* IL:NOW IL:THESE IL:ARE IL:MACROS) (DEFMACRO DRIBBLEP (WINDOW TYPE) `[COND ((EQ ,TYPE 'SOLVE) (IL:GETWINDOWPROP (IL:GETWINDOWPROP ,WINDOW 'IL:SOLVE-WINDOW) 'IL:TYPESCRIPTSTREAM)) ((EQ ,TYPE 'UNIFY) (IL:GETWINDOWPROP (IL:GETWINDOWPROP ,WINDOW 'IL:UNIFY-WINDOW) 'IL:TYPESCRIPTSTREAM]) (DEFMACRO SEE-ENV-P (WINDOW) `(IL:GETWINDOWPROP WINDOW 'IL:SEE)) (DEFMACRO SET-MENU (MENU FIELD VALUE) `(SETF (IL:FETCH ,FIELD IL:OF ,MENU) ,VALUE)) (DEFMACRO TRACINGP (WINDOW TYPE) `[COND ((EQ ,TYPE 'SOLVE) (EQ (IL:GETWINDOWPROP ,WINDOW 'IL:SOLVE) 'TRACE)) ((EQ ,TYPE 'UNIFY) (EQ (IL:GETWINDOWPROP ,WINDOW 'IL:UNIFY) 'TRACE]) (IL:* IL:THESE IL:ARE IL:FUNCTIONS) (DEFUN CREATE-DEVEL-THEORY (MAIN-WINDOW) [PROG* [(PW (IL:GETPROMPTWINDOW MAIN-WINDOW)) (THEORY-NAME (PROGN (IL:CLEARW PW) (PROMPTREAD "Theory name" PW T] (IL:* IL:;; "Every theory is stored in a tablebrowser as a tableitem") (AND THEORY-NAME (LET* [(ACTUAL-THEORY (MAKE-HASH-TABLE)) (TB-ITEM (MY-CREATE-TBRECORD (ACONS 'THEORY ACTUAL-THEORY (ACONS 'THEORY-NAME THEORY-NAME NIL] (IL:CLEARW PW) (IL:TB.INSERT.ITEM (IL:GETWINDOWPROP MAIN-WINDOW 'IL:TABLEBROWSER) TB-ITEM) (IL:CLEARW PW) (FORMAT PW "~%%Theory created"]) (DEFUN CREATE-THEORY-MENU (MAINW) (IL:* IL:;; "For speed improving, the list of all theories are kept in a menu; this menu is updated every time the user makes a change") (IL:PUTWINDOWPROP MAINW 'IL:THEORIES-MENU (PROG ((MENU (IL:CREATE IL:MENU))) (SET-MENU MENU IL:TITLE "Which theory?") (SET-MENU MENU IL:ITEMS (IL:SORT ( LIST-ALL-THEORIES MAINW) #'IL:ALPHORDER)) (RETURN MENU)))) (DEFUN EDIT-AXIOM (WINDOW) [LET [(CHOOSEN-THEORY-NAME (IL:MENU (IL:GETWINDOWPROP WINDOW 'IL:THEORIES-MENU] (AND CHOOSEN-THEORY-NAME (LET* ((THEORY (GET-THEORY CHOOSEN-THEORY-NAME WINDOW)) [CHOOSEN-AXIOM (PROG ((MENU (IL:CREATE IL:MENU))) (SET-MENU MENU IL:TITLE "Which axiom?") [SET-MENU MENU IL:ITEMS (APPEND (LIST '--NEW--) (IL:SORT (ALL-PREDS THEORY] (RETURN (IL:MENU MENU] *AXIOM-TEMPLATE*) (AND CHOOSEN-AXIOM (COND [(EQ CHOOSEN-AXIOM '--NEW--) (LET* ((PW (IL:GETPROMPTWINDOW WINDOW)) (NEWNAME (PROGN (IL:CLEARW PW) (PROMPTREAD "Axiom name" PW T))) PROC-NAME) (PROG NIL [SETF *AXIOM-TEMPLATE* (LIST (LIST (LIST 'PREDICATE] LP (IL:SPAWN.MOUSE) [SETF *AXIOM-TEMPLATE* (IL:EDITE (IL:COPYALL *AXIOM-TEMPLATE*) NIL (FORMAT NIL "New Predicate: ~A in ~A theory " NEWNAME CHOOSEN-THEORY-NAME ) NIL NIL (AND *LOGIC-CLOSE-ON-COMPLETION-FLG* '( :CLOSE-ON-COMPLETION ] [PROG ((CLAUSE-NUMBER 1) (AXS *AXIOM-TEMPLATE*)) LP1 (COND ((NULL AXS) (RETURN)) ((NOT (EQ NEWNAME (CAAAR AXS))) (IL:CLEARW PW) (FORMAT PW "Clause number ~D: incorrect predicate name: ~A" CLAUSE-NUMBER (CAAAR AXS)) (GO LP)) (T (SETF AXS (CDR AXS)) (INCF CLAUSE-NUMBER) (GO LP1] (SETF (GETHASH NEWNAME THEORY) *AXIOM-TEMPLATE*] (T (PROG NIL (IL:TTYDISPLAYSTREAM (IL:GETPROMPTWINDOW WINDOW)) (SETF *AXIOM-TEMPLATE* (GETHASH CHOOSEN-AXIOM THEORY)) LP (IL:SPAWN.MOUSE) [SETF *AXIOM-TEMPLATE* (IL:EDITE (IL:COPYALL *AXIOM-TEMPLATE*) NIL (FORMAT NIL "Predicate: ~A in ~A theory " CHOOSEN-AXIOM CHOOSEN-THEORY-NAME) NIL NIL (AND *LOGIC-CLOSE-ON-COMPLETION-FLG* '(:CLOSE-ON-COMPLETION] [PROG ((CLAUSE-NUMBER 1) (AXS *AXIOM-TEMPLATE*)) LP1 (COND ((NULL AXS) (RETURN)) ((NOT (EQ CHOOSEN-AXIOM (CAAAR AXS))) (IL:CLEARW (IL:GETPROMPTWINDOW WINDOW)) (FORMAT (IL:GETPROMPTWINDOW WINDOW) "Clause number ~D: incorrect predicate name: ~A" CLAUSE-NUMBER (CAAAR AXS)) (GO LP)) (T (SETF AXS (CDR AXS)) (INCF CLAUSE-NUMBER) (GO LP1] (SETF (GETHASH CHOOSEN-AXIOM THEORY) *AXIOM-TEMPLATE*]) (DEFUN EDIT-SA (WINDOW) [LET* [(CHOOSEN-THEORY-NAME (IL:MENU (IL:GETWINDOWPROP WINDOW 'IL:THEORIES-MENU] (AND CHOOSEN-THEORY-NAME (LET* ((THEORY (GET-THEORY CHOOSEN-THEORY-NAME WINDOW)) [CHOOSEN-SA (PROG ((MENU (IL:CREATE IL:MENU))) (SET-MENU MENU IL:TITLE "Which sa?") [SET-MENU MENU IL:ITEMS (APPEND (LIST '--NEW--) (IL:SORT (ALL-SAS THEORY] (RETURN (IL:MENU MENU] *SA-TEMPLATE*) (AND CHOOSEN-SA (COND [(EQ CHOOSEN-SA '--NEW--) (LET* [(PW (IL:GETPROMPTWINDOW WINDOW)) (NEWNAME (PROGN (IL:CLEARW PW) (PROMPTREAD "SA name" PW T] (PROGN (SETF *SA-TEMPLATE* (LIST 'LAMBDA (LIST 'ARGS) ')) (IL:SPAWN.MOUSE) (SETF *SA-TEMPLATE* (IL:EDITE (IL:COPYALL *SA-TEMPLATE*) NIL (FORMAT NIL "New SA: ~A in ~A theory " NEWNAME CHOOSEN-THEORY-NAME) )) (SETF (GETHASH NEWNAME THEORY) (CONS 'SA *SA-TEMPLATE*] (T (PROGN (IL:TTYDISPLAYSTREAM (IL:GETPROMPTWINDOW WINDOW)) (SETF *SA-TEMPLATE* (CDR (GETHASH CHOOSEN-SA THEORY) )) (IL:SPAWN.MOUSE) (SETF *SA-TEMPLATE* (IL:EDITE (IL:COPYALL *SA-TEMPLATE*) NIL (FORMAT NIL "SA: ~A in ~A theory " CHOOSEN-SA CHOOSEN-THEORY-NAME)) ) (SETF (GETHASH CHOOSEN-SA THEORY) (CONS 'SA *SA-TEMPLATE*]) (DEFUN GET-LIST-PROP (TI-LIST PROPERTY) [PROG (RES) LABEL (COND ((NULL TI-LIST) (RETURN RES)) (T [SETF RES (APPEND RES (LIST (GET-TB-PROPERTY (CAR TI-LIST) PROPERTY] (SETF TI-LIST (CDR TI-LIST)) (GO LABEL]) (DEFUN GET-TB-PROPERTY (ITEM PROP) (IL:LISTGET (IL:FETCH IL:TIDATA IL:OF ITEM) PROP)) (DEFUN GET-THEORY-INTERNAL (THEORY-NAME &OPTIONAL WINDOW) [LET* ((TB (IL:GETWINDOWPROP WINDOW 'IL:TABLEBROWSER)) (ITEMS (IL:FETCH IL:TBITEMS IL:OF TB))) (PROG NIL LABEL (COND ((NULL ITEMS)) [(STRING-EQUAL (SYMBOL-NAME (GET-TB-PROPERTY (CAR ITEMS) 'THEORY-NAME)) (SYMBOL-NAME THEORY-NAME)) (RETURN (GET-TB-PROPERTY (CAR ITEMS) 'THEORY] (T (SETF ITEMS (CDR ITEMS)) (GO LABEL]) (DEFUN LIST-ALL-THEORIES-INTERNAL (WINDOW) (GET-LIST-PROP (IL:TB.COLLECT.ITEMS (IL:GETWINDOWPROP WINDOW 'IL:TABLEBROWSER)) 'THEORY-NAME)) (DEFUN LOAD-DEVEL-THEORY (MAINW &OPTIONAL NAME-OF-THEORY) (LET* [(PW (IL:GETPROMPTWINDOW MAINW)) [THEORY-NAME (OR NAME-OF-THEORY (PROGN (IL:CLEARW PW) (PROMPTREAD "Theory name" PW T] [THEORY-FILE-NAME (MERGE-PATHNAMES (MAKE-PATHNAME :NAME THEORY-NAME :TYPE 'LGC] (ACTUAL-THEORY (MAKE-HASH-TABLE)) (TB-ITEM (MY-CREATE-TBRECORD (ACONS 'THEORY ACTUAL-THEORY (ACONS 'THEORY-NAME THEORY-NAME NIL] (IL:CLEARW PW) (OR (AND (PROBE-FILE THEORY-FILE-NAME) (PROGN [WITH-OPEN-FILE (FILE THEORY-FILE-NAME :DIRECTION :INPUT) (FORMAT PW "Loading theory ") (PROG (THEORY-NAME PRED-NUMBER SAS-NUMBER) (READ FILE) (IL:* IL:;; "skip on the theory name") (SETF SAS-NUMBER (READ FILE)) (DO ((SAS SAS-NUMBER (DECF SAS))) ((EQ SAS 0) NIL) (PROGN (FORMAT PW ".") (SETF (GETHASH (READ FILE) ACTUAL-THEORY) (READ FILE)))) (SETF PRED-NUMBER (READ FILE)) (DO ((PREDS PRED-NUMBER (DECF PREDS))) ((= PREDS 0) NIL) (PROGN (FORMAT PW ".") (SETF (GETHASH (READ FILE) ACTUAL-THEORY) (READ FILE))))] (IL:TB.INSERT.ITEM (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER) TB-ITEM) (IL:CLEARW PW) (FORMAT PW "~%%Theory loaded") T)) (FORMAT PW "~%%Theory not found")))) (DEFUN LOGIC-BUTTONFN (WINDOW) [COND ((IL:LASTMOUSESTATE IL:LEFT) T) ((IL:LASTMOUSESTATE IL:MIDDLE) (CASE (IL:MENU (OR IL:LogicMiddleMenu (PROGN (SETF IL:LogicMiddleMenu (IL:CREATE IL:MENU)) (SET-MENU IL:LogicMiddleMenu IL:ITEMS IL:LogicMiddleMenuCommands) (SET-MENU IL:LogicMiddleMenu IL:ITEMWIDTH 60) (SET-MENU IL:LogicMiddleMenu IL:ITEMHEIGHT 14) IL:LogicMiddleMenu))) (Dribble [LET ((PW (IL:GETPROMPTWINDOW WINDOW)) (STREAM NIL) (FILENAME NIL)) (IL:CLEARW PW) (SETF FILENAME (IL:PROMPTFORWORD "Typescript to file: " NIL NIL PW)) (IL:CLEARW PW) (COND ((NULL FILENAME) (CLOSE (IL:GETWINDOWPROP WINDOW 'IL:TYPESCRIPTSTREAM)) (IL:CLEARW PW) (IL:PUTWINDOWPROP WINDOW 'IL:TYPESCRIPTSTREAM NIL) (FORMAT PW "File closed")) (T (SETF STREAM (OPEN (MERGE-PATHNAMES (MAKE-PATHNAME :NAME FILENAME :TYPE 'TRC)) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE)) (IL:CLEARW PW) (FORMAT PW "~S opened" (NAMESTRING STREAM)) (IL:PUTWINDOWPROP WINDOW 'IL:TYPESCRIPTSTREAM STREAM]))]) (DEFUN LOGIC-DEVELOPER () (IN-PACKAGE 'USER) (LET* ((LOGIC-WINDOW (IL:CREATEW NIL (FORMAT NIL "Logic ~D -- Horn clauses programming environment" *LOGIC-RELEASE-NUMBER*) 6 T)) (IL:* IL:; "the main window") (UNIFY-WINDOW (IL:CREATEW '(10 10 400 400) "Logic unifier Trace Window" 4 T)) (SOLVE-WINDOW (IL:CREATEW '(410 10 400 400) "Logic solver Trace Window" 4 T)) (REGION (IL:GETWINDOWPROP LOGIC-WINDOW 'IL:REGION)) (THEORIES-WINDOW (IL:CREATEW (IL:CREATEREGION (- (FIRST REGION) 120) (SECOND REGION) 120 (FOURTH REGION)) "Theories window" 4 T)) [TABLE-BROWSER (IL:TB.MAKE.BROWSER NIL THEORIES-WINDOW '(IL:FONT (HELVETICA 12 BRR) IL:PRINTFN PRINT-TB-ITEMS] (LOGIC-CONTROL-MENU (IL:CREATE IL:MENU)) (PROC (IL:THIS.PROCESS)) LOGIC-CONTROL-MENU-WINDOW) (DECLARE (SPECIAL LOGIC-WINDOW)) (IL:CLEARW THEORIES-WINDOW) (IL:DSPSCROLL 'IL:ON UNIFY-WINDOW) (IL:DSPSCROLL 'IL:ON SOLVE-WINDOW) (IL:DSPSCROLL 'IL:ON THEORIES-WINDOW) (IL:PUTWINDOWPROP UNIFY-WINDOW 'IL:BUTTONEVENTFN 'LOGIC-BUTTONFN) (IL:PUTWINDOWPROP SOLVE-WINDOW 'IL:BUTTONEVENTFN 'LOGIC-BUTTONFN) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:MODE 'IL:FIRST) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:TRUTH-VALUE-ONLY T) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:WINDOWENTRYFN 'IL:GIVE.TTY.PROCESS) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:UNIFY-WINDOW UNIFY-WINDOW) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:SOLVE-WINDOW SOLVE-WINDOW) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:TABLEBROWSER TABLE-BROWSER) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:SOLVE 'NOTRACE) (IL:PUTWINDOWPROP LOGIC-WINDOW 'IL:UNIFY 'NOTRACE) (SET-MENU LOGIC-CONTROL-MENU IL:TITLE "Control menu") (SET-MENU LOGIC-CONTROL-MENU IL:MENUCOLUMNS 1) (SET-MENU LOGIC-CONTROL-MENU IL:ITEMS *LOGIC-MENU-ITEMS*) (SET-MENU LOGIC-CONTROL-MENU IL:WHENSELECTEDFN #'LOGIC-MENU-FUNCTION) (SET-MENU LOGIC-CONTROL-MENU IL:CENTERFLG T) (SET-MENU LOGIC-CONTROL-MENU IL:ITEMWIDTH 105) (SET-MENU LOGIC-CONTROL-MENU IL:ITEMHEIGHT 14) (IL:ATTACHWINDOW (IL:MENUWINDOW LOGIC-CONTROL-MENU) LOGIC-WINDOW 'IL:RIGHT 'IL:TOP) (IL:ATTACHWINDOW THEORIES-WINDOW LOGIC-WINDOW 'IL:LEFT 'IL:TOP) (IL:OPENW LOGIC-WINDOW) (IL:TTYDISPLAYSTREAM LOGIC-WINDOW) (IL:USEREXEC " Logic>" NIL #'START-PROVING) (IL:DEL.PROCESS PROC) (IL:CLOSEW LOGIC-WINDOW) T)) (DEFUN LOGIC-MENU-FUNCTION (ITEM MENU BUTTON) [LET [(ACTION (SECOND ITEM)) (MAINW (IL:MAINWINDOW (IL:WFROMMENU MENU] (CASE ACTION (EXIT (MAPCAR #'IL:CLOSEW (IL:ATTACHEDWINDOWS MAINW)) (IL:DEL.PROCESS (IL:GETWINDOWPROP MAINW 'IL:PROCESS)) [AND (STREAMP (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:SOLVE-WINDOW) 'IL:TYPESCRIPTSTREAM)) (CLOSE (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:SOLVE-WINDOW) 'IL:TYPESCRIPTSTREAM] [AND (STREAMP (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:UNIFY-WINDOW) 'IL:TYPESCRIPTSTREAM)) (CLOSE (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:UNIFY-WINDOW) 'IL:TYPESCRIPTSTREAM] (IL:CLOSEW MAINW)) (TRUTH-VALUE (IL:PUTWINDOWPROP MAINW 'IL:TRUTH-VALUE-ONLY T)) (ALL-VALUES (IL:PUTWINDOWPROP MAINW 'IL:TRUTH-VALUE-ONLY NIL)) (LOAD-THEORY (LOAD-DEVEL-THEORY MAINW) (CREATE-THEORY-MENU MAINW)) (SAVE-THEORY (SAVE-DEVEL-THEORY MAINW)) (CREATE-THEORY (CREATE-DEVEL-THEORY MAINW) (CREATE-THEORY-MENU MAINW)) (MERGE-THEORIES (MERGE-THEORIES-DEVEL MAINW)) (EDIT-SA [IL:ADD.PROCESS `(EDIT-SA ,MAINW]) (EDIT-AXIOM [IL:ADD.PROCESS `(EDIT-AXIOM ,MAINW]) (NO-SHOW-ENV (IL:PUTWINDOWPROP MAINW 'IL:SEE NIL)) (DELETE-AXIOM [LET [(CHOOSEN-THEORY-NAME (IL:MENU (IL:GETWINDOWPROP MAINW 'IL:THEORIES-MENU] (AND CHOOSEN-THEORY-NAME (LET [(CHOOSEN-AXIOM (PROG ((MENU (IL:CREATE IL:MENU))) (SET-MENU MENU IL:TITLE "Which axiom?" ) (SET-MENU MENU IL:ITEMS (IL:SORT (ALL-PREDS (GET-THEORY CHOOSEN-THEORY-NAME MAINW)) #'IL:ALPHORDER)) (RETURN (IL:MENU MENU] (AND CHOOSEN-AXIOM (LOGIC-DELETE CHOOSEN-AXIOM CHOOSEN-THEORY-NAME MAINW]) (DELETE-SA [LET [(CHOOSEN-THEORY-NAME (IL:MENU (IL:GETWINDOWPROP MAINW 'IL:THEORIES-MENU] (AND CHOOSEN-THEORY-NAME (LET [(CHOOSEN-SA (PROG ((MENU (IL:CREATE IL:MENU))) (SET-MENU MENU IL:TITLE "Which SA?") (SET-MENU MENU IL:ITEMS (IL:SORT (ALL-SAS (GET-THEORY CHOOSEN-THEORY-NAME MAINW)) #'IL:ALPHORDER)) (RETURN (IL:MENU MENU] (AND CHOOSEN-SA (LOGIC-DELETE CHOOSEN-SA CHOOSEN-THEORY-NAME MAINW]) (SHOW-AXIOM [LET [(CHOOSEN-THEORY-NAME (IL:MENU (IL:GETWINDOWPROP MAINW 'IL:THEORIES-MENU] (AND CHOOSEN-THEORY-NAME (PROG [(MENU (IL:CREATE IL:MENU)) CHOOSEN-AXIOM (ALL-ITEMS (IL:SORT (ALL-PREDS (GET-THEORY CHOOSEN-THEORY-NAME MAINW] (SET-MENU MENU IL:TITLE "Which axiom?") (SET-MENU MENU IL:ITEMS ALL-ITEMS) JUMP (AND (NULL ALL-ITEMS) (RETURN)) (SETF CHOOSEN-AXIOM (IL:MENU MENU)) (AND CHOOSEN-AXIOM (PROGN (SHOW-DEFINITION CHOOSEN-AXIOM CHOOSEN-THEORY-NAME MAINW) (GO JUMP]) (SHOW-SA [LET [(CHOOSEN-THEORY-NAME (IL:MENU (IL:GETWINDOWPROP MAINW 'IL:THEORIES-MENU] (AND CHOOSEN-THEORY-NAME (PROG [(MENU (IL:CREATE IL:MENU)) CHOOSEN-SA (ALL-ITEMS (IL:SORT (ALL-SAS (GET-THEORY CHOOSEN-THEORY-NAME MAINW)) #'IL:ALPHORDER] (SET-MENU MENU IL:TITLE "Which SA?") (SET-MENU MENU IL:ITEMS ALL-ITEMS) JUMP (AND (NULL ALL-ITEMS) (RETURN)) (SETF CHOOSEN-SA (IL:MENU MENU)) (AND CHOOSEN-SA (PROGN (SHOW-DEFINITION CHOOSEN-SA CHOOSEN-THEORY-NAME MAINW) (GO JUMP]) (FIRST (IL:PUTWINDOWPROP MAINW 'IL:MODE 'IL:FIRST)) (SET-MODE (IL:PUTWINDOWPROP MAINW 'IL:MODE 'IL:FIRST)) (ALL (IL:PUTWINDOWPROP MAINW 'IL:MODE 'IL:ALL)) (INTERACTIVE (IL:PUTWINDOWPROP MAINW 'IL:MODE 'IL:INTERACTIVE)) (TRACE-UNIFIER (IL:PUTWINDOWPROP MAINW 'IL:UNIFY 'TRACE)) (TRACE-SOLVER (IL:PUTWINDOWPROP MAINW 'IL:SOLVE 'TRACE)) (NOTRACE-SOLVER [PROGN (IL:PUTWINDOWPROP MAINW 'IL:SOLVE 'NOTRACE) (AND (STREAMP (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:SOLVE-WINDOW) 'IL:TYPESCRIPTSTREAM)) (CLOSE (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:SOLVE-WINDOW) 'IL:TYPESCRIPTSTREAM]) (NOTRACE-UNIFIER [PROGN (IL:PUTWINDOWPROP MAINW 'IL:UNIFY 'NOTRACE) (AND (STREAMP (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:UNIFY-WINDOW) 'IL:TYPESCRIPTSTREAM)) (CLOSE (IL:GETWINDOWPROP (IL:GETWINDOWPROP MAINW 'IL:UNIFY-WINDOW) 'IL:TYPESCRIPTSTREAM]) (DELETE-THEORY [LET [(TB (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER] (DO ((ITEMS (IL:TB.COLLECT.ITEMS TB 'IL:SELECTED) (CDR ITEMS))) ((NULL ITEMS)) (IL:TB.DELETE.ITEM TB (CAR ITEMS)))]) (UNDELETE [LET [(TB (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER] (DO ((ITEMS (IL:TB.COLLECT.ITEMS TB 'IL:SELECTED) (CDR ITEMS))) ((NULL ITEMS)) (IL:TB.UNDELETE.ITEM TB (CAR ITEMS)))]) (EXPUNGE (LET [(TB (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER] (DO ((ITEMS (IL:TB.COLLECT.ITEMS TB 'IL:DELETED) (CDR ITEMS))) ((NULL ITEMS)) (IL:TB.REMOVE.ITEM TB (CAR ITEMS))) (CREATE-THEORY-MENU MAINW))) (ERASE (LET [(TB (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER] (DO ((ITEMS (IL:TB.COLLECT.ITEMS TB) (CDR ITEMS))) ((NULL ITEMS)) (IL:TB.REMOVE.ITEM TB (CAR ITEMS))) (CREATE-THEORY-MENU MAINW))) (SHOW-PROFILE (SHOW-PROFILE MAINW)))]) (DEFUN MERGE-THEORIES-DEVEL (MAINW &OPTIONAL NEW-THEORY LIST-OF-THEORIES) [LET* [(PW (IL:GETPROMPTWINDOW MAINW)) (THEORY-NAME (OR NEW-THEORY (PROGN (IL:CLEARW PW) (PROMPTREAD "New theory name" PW T] (AND THEORY-NAME (LET* [(ACTUAL-THEORY (MAKE-HASH-TABLE)) [TB-ITEM (MY-CREATE-TBRECORD (ACONS 'THEORY ACTUAL-THEORY (ACONS 'THEORY-NAME THEORY-NAME NIL] [SELECTED-THEORIES (OR LIST-OF-THEORIES (IL:TB.COLLECT.ITEMS (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER) 'IL:SELECTED] (SELECTED-THEORY-NAMES (OR LIST-OF-THEORIES (DO ((THS SELECTED-THEORIES (CDR THS)) (RESULT NIL)) ((NULL THS) RESULT) [SETQ RESULT (APPEND RESULT (LIST (GET-TB-PROPERTY (CAR THS) 'THEORY-NAME])] (IL:CLEARW PW) (IL:TB.INSERT.ITEM (IL:GETWINDOWPROP MAINW 'IL:TABLEBROWSER) TB-ITEM) (IL:CLEARW PW) (MERGE-INTERNAL THEORY-NAME SELECTED-THEORY-NAMES MAINW) (CREATE-THEORY-MENU MAINW) (FORMAT PW "Theories merged"]) (DEFUN MY-CREATE-TBRECORD (ALIST) [PROG ((ELTS ALIST) (TI (IL:CREATE IL:TABLEITEM))) LABEL (COND ((NULL ELTS) (RETURN TI)) (T (LET* ((PAIR (CAR ELTS)) (PROP (CAR PAIR)) (VALUE (CDR PAIR))) (CASE PROP (SELECTED (SET-MENU TI IL:TISELECTED VALUE)) (DELETED (SET-MENU TI IL:TIDELETED VALUE)) (UNDELETABLE (SET-MENU TI IL:TIUNDELETABLE VALUE)) (UNSELECTABLE (SET-MENU TI IL:TIUNSELECTABLE VALUE)) (DATA (SET-MENU TI IL:TIDATA VALUE)) (T (SET-MENU TI IL:TIDATA (APPEND (IL:FETCH IL:TIDATA IL:OF TI) (LIST PROP VALUE))))) (SETF ELTS (CDR ELTS)) (GO LABEL]) (DEFUN PRINT-TB-ITEMS (BROWSER ITEM WINDOW) (IL:DSPXPOSITION 10 WINDOW) (SETF *PRINT-PRETTY* NIL) (FORMAT WINDOW "~S~%%" (GET-TB-PROPERTY ITEM 'THEORY-NAME)) (SETF *PRINT-PRETTY* T)) (DEFUN PROMPTREAD (PROMPTSTRING WINDOW SAMELINE?) (PROG [NEWVALUE (MAINWINDOW (IL:WINDOWPROP WINDOW 'IL:MAINWINDOW] (IL:RESETLST (IL:RESETSAVE (IL:TTYDISPLAYSTREAM (OR WINDOW IL:PROMPTWINDOW))) (IL:RESETSAVE (IL:TTY.PROCESS (IL:THIS.PROCESS))) (IL:CLRPROMPT) (IL:RESETSAVE (IL:PRINTLEVEL 4 3)) (FORMAT T "~A: " PROMPTSTRING) (IL:CLEARBUF T T) (IL:* IL:;  "clear tty buffer because it sometimes has stuff left.") (IL:ALLOW.BUTTON.EVENTS) (UNWIND-PROTECT [SETF NEWVALUE (CAR (IL:ERSETQ (IL:TTYINREAD T T])) (RETURN NEWVALUE))) (DEFUN SAVE-DEVEL-THEORY (MAINWINDOW) [LET [(PW (OR (CAR (IL:GETWINDOWPROP MAINWINDOW 'IL:PROMPTWINDOW)) (IL:GETPROMPTWINDOW MAINWINDOW] (DO ((TI-SELECTED (PROGN (IL:CLEARW PW) (IL:TB.COLLECT.ITEMS (IL:GETWINDOWPROP MAINWINDOW 'IL:TABLEBROWSER) 'IL:SELECTED)) (CDR TI-SELECTED))) ((NULL TI-SELECTED) (FORMAT PW "done")) [PROG [(THEORY-NAME (GET-TB-PROPERTY (CAR TI-SELECTED) 'THEORY-NAME)) (THEORY (GET-TB-PROPERTY (CAR TI-SELECTED) 'THEORY] (WITH-OPEN-FILE (FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME THEORY-NAME :TYPE 'LGC)) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE) (LET [(PREDS (IL:SORT (ALL-PREDS THEORY))) (SAS (IL:SORT (ALL-SAS THEORY] (PROGN (IL:CLEARW PW) (FORMAT PW "Saving ~A" THEORY-NAME) (FORMAT FILE "~S~%%" THEORY-NAME) (FORMAT FILE "~D~%%" (LENGTH SAS)) (DO ((SA-NAME SAS (CDR SA-NAME))) ((NULL SA-NAME) NIL) (PROGN (FORMAT PW ".") (FORMAT FILE "~S ~S ~%%" (CAR SA-NAME) (GETHASH (CAR SA-NAME) THEORY)))) (FORMAT FILE "~D~%%" (LENGTH PREDS)) (DO ((PRED-NAME PREDS (CDR PRED-NAME))) ((NULL PRED-NAME) NIL) (PROGN (FORMAT PW ".") (FORMAT FILE "~S ~S ~%%" (CAR PRED-NAME) (GETHASH (CAR PRED-NAME) THEORY))))])]) (DEFUN SHOW-PROFILE (WINDOW) [LET ((PW (IL:GETPROMPTWINDOW WINDOW))) (IL:CLEARW PW) (FORMAT PW "~%%Mode: ~A /Unifier: ~A /Solver: ~A /Values: ~A" (IL:GETWINDOWPROP WINDOW 'IL:MODE) (IL:GETWINDOWPROP WINDOW 'IL:UNIFY) (IL:GETWINDOWPROP WINDOW 'IL:SOLVE) (NOT (IL:GETWINDOWPROP WINDOW 'IL:TRUTH-VALUE-ONLY]) (DEFUN SOLVE-DEBUGGER (TREE FORMULA CLAUSES WINDOW) [COND ((TRACINGP WINDOW 'SOLVE) (IL:* IL:;; "This is the part for debugging: the main features of the language are shown to the user in specified windows") (FORMAT (IL:GETWINDOWPROP WINDOW 'IL:SOLVE-WINDOW) "Formula is ~A,~%%clauses are ~A,~%%conjs are ~A~%%~%%" FORMULA CLAUSES (CONJ (AND-LEVEL TREE))) (AND (DRIBBLEP WINDOW 'SOLVE) (FORMAT (IL:GETWINDOWPROP (IL:GETWINDOWPROP WINDOW 'IL:SOLVE-WINDOW) 'IL:TYPESCRIPTSTREAM) "Formula is ~A,~%%clauses are ~A,~%%conjs are ~A~%%~%%" FORMULA CLAUSES (CONJ (AND-LEVEL TREE]) (DEFUN START-PROVING (CONJS LINE) (IN-PACKAGE 'USER) [LET* ((*VARIABLES-COUNTER* 0) (SELECTED-TIS (IL:TB.COLLECT.ITEMS (IL:GETWINDOWPROP LOGIC-WINDOW 'IL:TABLEBROWSER) 'IL:SELECTED)) [THEORIES (APPEND (LIST '*BACKGROUND-THEORY*) (GET-LIST-PROP SELECTED-TIS 'THEORY-NAME] (TREE (MAKE-TREE (MAKE-AND-NODE CONJS NIL THEORIES) NIL)) (TRUTH-VALUE-ONLY (IL:GETWINDOWPROP LOGIC-WINDOW 'IL:TRUTH-VALUE-ONLY)) RESULT NEXT-OR) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) (PROG NIL JUMP (SETF RESULT (LOGIC-PROVE TREE LOGIC-WINDOW)) (COND ((NULL RESULT) (IL:* IL:; "The proof is failed") ) (T (CASE (IL:GETWINDOWPROP LOGIC-WINDOW 'IL:MODE) (IL:FIRST [OR (AND TRUTH-VALUE-ONLY (PROGN (FORMAT T "~A~%%" T) T)) (FORMAT T "~S~%%" (LOOKUP CONJS (UNIFICATION-ENV (AND-LEVEL RESULT]) (IL:ALL (OR (AND TRUTH-VALUE-ONLY (PROGN (FORMAT T "~A~%%" T) T)) (PROGN [FORMAT T "~S~%%" (LOOKUP CONJS (UNIFICATION-ENV (AND-LEVEL RESULT] T)) (SETF NEXT-OR (FIRST (OR-LEVELS RESULT))) (SETF TREE (SOLVE (NEW-TREE RESULT NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR))) (GO JUMP)) (IL:INTERACTIVE (OR (AND TRUTH-VALUE-ONLY (PROGN (FORMAT T "~A~%%" T) T)) (PROGN [FORMAT T "~S~%%" (LOOKUP CONJS (UNIFICATION-ENV (AND-LEVEL RESULT] T)) (FORMAT T "More? ") (AND (Y-OR-N-P) (PROGN (SETF NEXT-OR (FIRST (OR-LEVELS RESULT))) (SETF TREE (SOLVE (NEW-TREE RESULT NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR))) (GO JUMP)))))] T) (DEFUN UNIFY-DEBUGGER (PATT DAT ENV WINDOW) (IL:* IL:;; " This part is devoted to debugging, on the window and on the file") (LET* [(TRACE-WINDOW (IL:GETWINDOWPROP WINDOW 'IL:UNIFY-WINDOW)) (DRIBBLE? (DRIBBLEP WINDOW 'UNIFY)) (STREAM (AND DRIBBLE? (IL:GETWINDOWPROP TRACE-WINDOW 'IL:TYPESCRIPTSTREAM] (FORMAT TRACE-WINDOW "~%%Unifying ~A ~%%with ~A~%%in ~A~%%" PATT DAT ENV) (AND DRIBBLE? (FORMAT STREAM "~%%Unifying ~A ~%%with ~A~%%in ~A~%% " PATT DAT ENV)))) (IL:ADDTOVAR IL:BackgroundMenuCommands ("Logic" '(IL:ADD.PROCESS '(LOGIC-DEVELOPER)) "Open a window on logic programming environment")) (IL:RPAQQ *LOGIC-MENU-ITEMS* (("Show profile" SHOW-PROFILE "Show the profile on env") ("Truth value only" TRUTH-VALUE "The proof returns only T or NIL" (IL:SUBITEMS ("All values " ALL-VALUES "Returns the goal with all the variables" ))) ("Show(Axiom)" SHOW-AXIOM "Shows definition of an axiom" (IL:SUBITEMS ("Show SA" SHOW-SA "Shows definition of a semantic attachment" ))) ("Edit(Axiom)" EDIT-AXIOM "Edits the specified axiom" (IL:SUBITEMS ("Edit SA" EDIT-SA "Edits the specified SA"))) ("Delete(Axiom)" DELETE-AXIOM "Deletes the specified axiom" (IL:SUBITEMS ("Delete SA" DELETE-SA "Deletes the specified semantic attachment" ))) ("Set Mode(First)" SET-MODE "Set mode of demonstration" (IL:SUBITEMS ("First" FIRST "Stops at first solution reached") ("All" ALL "Finds out all solutions") ("Interactive" INTERACTIVE "Ask user to continue"))) ("Trace unifier" TRACE-UNIFIER "Trace the unifier" (IL:SUBITEMS ("No trace" NOTRACE-UNIFIER "Do not trace unifier"))) ("Trace solver" TRACE-SOLVER "Trace the solver" (IL:SUBITEMS ("No trace" NOTRACE-SOLVER "Do not trace solver"))) ("Create theory" CREATE-THEORY "Creates new theory") ("Delete theory" DELETE-THEORY "Deletes the labelled theories" (IL:SUBITEMS ("Expunge deleted theories" EXPUNGE "Expunged deleted theories") ("Undelete theories" UNDELETE "Undelete theories"))) ("Merge theories" MERGE-THEORIES "Merges the selected theories") ("Load theory" LOAD-THEORY "Prompts user for theory to load") ("Save theory" SAVE-THEORY "Saves selected theories") ("Erase env" ERASE "Erases all the environment") ("Exit" EXIT "Closes development window"))) (IL:RPAQQ *LOGIC-RELEASE-NUMBER* "1.3") (IL:RPAQQ *LOGIC-CLOSE-ON-COMPLETION-FLG* T) (IL:RPAQQ IL:BackgroundMenu NIL) (IL:RPAQQ IL:LogicMiddleMenu NIL) (IL:RPAQQ IL:LogicMiddleMenuCommands ((DRIBBLE 'Dribble "Dribbles on file"))) (IL:FILESLOAD IL:TABLEBROWSER) (IL:DECLARE%: IL:EVAL@COMPILE (IL:DATATYPE IL:TABLEBROWSER ((IL:TBREADY IL:FLAG) (NIL 7 IL:FLAG) (IL:TBITEMS IL:POINTER) (IL:TB#ITEMS IL:WORD) (IL:TB#DELETED IL:WORD) (IL:TB#LINESPERITEM IL:WORD) (IL:TBFIRSTSELECTEDITEM IL:WORD) (IL:TBLASTSELECTEDITEM IL:WORD) (NIL IL:WORD) (IL:TBMAXXPOS IL:WORD) (IL:TBFONTHEIGHT IL:WORD) (IL:TBFONTASCENT IL:WORD) (IL:TBFONTDESCENT IL:WORD) (IL:TBWINDOW IL:POINTER) (IL:TBLOCK IL:POINTER) (IL:TBUSERDATA IL:POINTER) (IL:TBFONT IL:POINTER) (IL:TBEXTENT IL:POINTER) (IL:TBUPDATEFROMHERE IL:POINTER) (IL:TBCOLUMNS IL:POINTER) (IL:TBPRINTFN IL:POINTER) (IL:TBCOPYFN IL:POINTER) (IL:TBFONTCHANGEFN IL:POINTER) (IL:TBCLOSEFN IL:POINTER) (IL:TBAFTERCLOSEFN IL:POINTER) (IL:TBTITLEEVENTFN IL:POINTER) (IL:TBAFTEREXPUNGEFN IL:POINTER) (IL:TBORIGIN IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER) (NIL IL:POINTER))) (IL:DATATYPE IL:TABLEITEM ((IL:TISELECTED IL:FLAG) (IL:TIDELETED IL:FLAG) (IL:TIUNDELETABLE IL:FLAG) (IL:TIUNSELECTABLE IL:FLAG) (IL:TIUNCOPYSELECTABLE IL:FLAG) (NIL 3 IL:FLAG) (IL:TIDATA IL:POINTER) (IL:TI# IL:WORD) (NIL IL:WORD))) ) (IL:/DECLAREDATATYPE 'IL:TABLEBROWSER '(IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:POINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((IL:TABLEBROWSER 0 (IL:FLAGBITS . 0)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 16)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 32)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 48)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 64)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 80)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 96)) (IL:TABLEBROWSER 0 (IL:FLAGBITS . 112)) (IL:TABLEBROWSER 0 IL:POINTER) (IL:TABLEBROWSER 2 (IL:BITS . 15)) (IL:TABLEBROWSER 3 (IL:BITS . 15)) (IL:TABLEBROWSER 4 (IL:BITS . 15)) (IL:TABLEBROWSER 5 (IL:BITS . 15)) (IL:TABLEBROWSER 6 (IL:BITS . 15)) (IL:TABLEBROWSER 7 (IL:BITS . 15)) (IL:TABLEBROWSER 8 (IL:BITS . 15)) (IL:TABLEBROWSER 9 (IL:BITS . 15)) (IL:TABLEBROWSER 10 (IL:BITS . 15)) (IL:TABLEBROWSER 11 (IL:BITS . 15)) (IL:TABLEBROWSER 12 IL:POINTER) (IL:TABLEBROWSER 14 IL:POINTER) (IL:TABLEBROWSER 16 IL:POINTER) (IL:TABLEBROWSER 18 IL:POINTER) (IL:TABLEBROWSER 20 IL:POINTER) (IL:TABLEBROWSER 22 IL:POINTER) (IL:TABLEBROWSER 24 IL:POINTER) (IL:TABLEBROWSER 26 IL:POINTER) (IL:TABLEBROWSER 28 IL:POINTER) (IL:TABLEBROWSER 30 IL:POINTER) (IL:TABLEBROWSER 32 IL:POINTER) (IL:TABLEBROWSER 34 IL:POINTER) (IL:TABLEBROWSER 36 IL:POINTER) (IL:TABLEBROWSER 38 IL:POINTER) (IL:TABLEBROWSER 40 IL:POINTER) (IL:TABLEBROWSER 42 IL:POINTER) (IL:TABLEBROWSER 44 IL:POINTER) (IL:TABLEBROWSER 46 IL:POINTER)) '48) (IL:/DECLAREDATATYPE 'IL:TABLEITEM '(IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:FLAG IL:POINTER IL:WORD IL:WORD) '((IL:TABLEITEM 0 (IL:FLAGBITS . 0)) (IL:TABLEITEM 0 (IL:FLAGBITS . 16)) (IL:TABLEITEM 0 (IL:FLAGBITS . 32)) (IL:TABLEITEM 0 (IL:FLAGBITS . 48)) (IL:TABLEITEM 0 (IL:FLAGBITS . 64)) (IL:TABLEITEM 0 (IL:FLAGBITS . 80)) (IL:TABLEITEM 0 (IL:FLAGBITS . 96)) (IL:TABLEITEM 0 (IL:FLAGBITS . 112)) (IL:TABLEITEM 0 IL:POINTER) (IL:TABLEITEM 2 (IL:BITS . 15)) (IL:TABLEITEM 3 (IL:BITS . 15))) '4) (IL:DECLARE%: IL:EVAL@COMPILE (IL:RPAQQ IL:TB.LEFT.MARGIN 8) (IL:CONSTANTS IL:TB.LEFT.MARGIN) ) (IL:PUTPROPS IL:LOGIC-DEVEL IL:COPYRIGHT ("ROBERTO GHISLANZONI" 1987 1988)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/LOGIC-EXAMPLES.LGC b/lispusers/LOGIC-EXAMPLES.LGC new file mode 100644 index 00000000..57478ad3 --- /dev/null +++ b/lispusers/LOGIC-EXAMPLES.LGC @@ -0,0 +1 @@ +LOGIC-EXAMPLES 3 NOTMEMBER (SA LAMBDA (X Y) (NOT (MEMBER X Y))) SA-MEMBER (SA LAMBDA (X Y) (MEMBER X Y)) PRINT-INFO (SA LAMBDA (FROM TO) (PROGN (FORMAT T "Current room is ~A, enter now room ~A~%%" FROM TO) T)) 9 SEARCH (((SEARCH ?FROM ?TO) :- (LOGIC-ASSERT GOAL (((GOAL ?TO))) EXAMPLES) (EXPLORE ?FROM ?TO (?FROM)) (GOAL ?TO))) GOAL (((GOAL G))) PHONE (((PHONE G))) NOT (((NOT ?X) :- (WFF ?X) ! (FAIL)) ((NOT ?X))) LOGIC-MEMBER (((LOGIC-MEMBER ?A (?A . ?B)) :- !) ((LOGIC-MEMBER ?A (?B . ?C)) :- (LOGIC-MEMBER ?A ?C))) DOOR (((DOOR A B)) ((DOOR A N)) ((DOOR B M)) ((DOOR B C)) ((DOOR M I)) ((DOOR C D)) ((DOOR D E)) ((DOOR E F)) ((DOOR F H)) ((DOOR H L)) ((DOOR L G))) APPEND (((APPEND NIL ?Q ?Q)) ((APPEND (?A . ?B) ?C (?A . ?D)) :- (APPEND ?B ?C ?D))) IS-THERE-DOOR (((IS-THERE-DOOR ?A ?B) :- (DOOR ?A ?B)) ((IS-THERE-DOOR ?A ?B) :- (DOOR ?B ?A))) EXPLORE (((EXPLORE ?X ?X ?START-LIST)) ((EXPLORE ?X ?Y ?START-LIST) :- (IS-THERE-DOOR ?X ?Z) (NOTMEMBER ?Z ?START-LIST) (PRINT-INFO ?X ?Z) (EXPLORE ?Z ?Y (?Z . ?START-LIST)))) \ No newline at end of file diff --git a/lispusers/LOGIC-UNIFIER b/lispusers/LOGIC-UNIFIER new file mode 100644 index 00000000..3f1061e8 --- /dev/null +++ b/lispusers/LOGIC-UNIFIER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "USER" READTABLE "INTERLISP") (IL:FILECREATED "20-Dec-88 09:26:18" IL:{DSK}LOGIC>MEDLEY>LOGIC-UNIFIER.;2 7635 IL:previous IL:date%: "20-Dec-88 09:24:32" IL:{DSK}LOGIC>MEDLEY>LOGIC-UNIFIER.;1) (IL:PRETTYCOMPRINT IL:LOGIC-UNIFIERCOMS) (IL:RPAQQ IL:LOGIC-UNIFIERCOMS ((IL:* IL:THESE IL:ARE IL:MACROS) (IL:FUNCTIONS NULLP VARIABLEP) (IL:* AND IL:THESE IL:ARE IL:FUNCTIONS) (IL:FUNCTIONS BINDING BUILD-NEW-ENV CREATE-NEW-VARIABLE CREATE-VARIABLES FIND-IF-MEMBER FIND-VALUES FIND-VARIABLE-VALUE LOOKUP RENAME RENAME-VARS UNIFY))) (IL:* IL:THESE IL:ARE IL:MACROS) (DEFMACRO NULLP (ATOM) `(EQ ,ATOM '*NULL*)) (DEFMACRO VARIABLEP (ITEM) `(AND (SYMBOLP ,ITEM) (EQ (CHAR-CODE (CHAR (SYMBOL-NAME ,ITEM) 0)) 63))) (IL:* AND IL:THESE IL:ARE IL:FUNCTIONS) (DEFUN BINDING (PREDICATE THEORY-NAME &OPTIONAL WINDOW) [COND [(EQ THEORY-NAME '*BACKGROUND-THEORY*) (COND [(EQ (CHAR-CODE (CHAR (SYMBOL-NAME PREDICATE) 0)) 33) (IL:* IL:;; "CUT is handled in a very particular way!! ") (GETHASH '! (GET 'THEORY '*BACKGROUND-THEORY*] (T (GETHASH PREDICATE (GET 'THEORY '*BACKGROUND-THEORY*] (T (GETHASH PREDICATE (GET-THEORY THEORY-NAME WINDOW]) (DEFUN BUILD-NEW-ENV (PAT DAT ENV) (IL:* IL:;; " It is better to make a distinction between the null value of a variable and the variables unbound") (COND ((NULL DAT) (ACONS PAT '*NULL* ENV)) (T (ACONS PAT DAT ENV)))) (DEFUN CREATE-NEW-VARIABLE () [PROGN (SETF *VARIABLES-COUNTER* (+ 1 *VARIABLES-COUNTER*)) (OR (GETHASH *VARIABLES-COUNTER* *VARIABLES-TABLE*) (SETF (GETHASH *VARIABLES-COUNTER* *VARIABLES-TABLE*) (MAKE-SYMBOL (FORMAT NIL "?~A" *VARIABLES-COUNTER*]) (DEFUN CREATE-VARIABLES () (DEFVAR *VARIABLES-TABLE* (MAKE-HASH-TABLE)) (IL:* IL:;; "all the variables used are cached in a hash-table: this is also for not generating a lot of symbols that will fill up the symbol table of the system ") (IL:* IL:;; "This function must be called before starting to work with Logic") (DO ((X 0 (+ X 1))) ((= X 4095) T) (SETF (GETHASH X *VARIABLES-TABLE*) (MAKE-SYMBOL (FORMAT NIL "?~A" X))))) (DEFUN FIND-IF-MEMBER (ELT LST) (COND ((NULL LST) NIL) [(LISTP LST) (OR (FIND-IF-MEMBER ELT (CAR LST)) (FIND-IF-MEMBER ELT (CDR LST] ((ATOM LST) (EQ LST ELT)) (T (MEMBER ELT LST)))) (DEFUN FIND-VALUES (ELT ENV) (COND ((NULL ELT) NIL) ((LISTP ELT) (CONS (FIND-VALUES (CAR ELT) ENV) (FIND-VALUES (CDR ELT) ENV))) ((VARIABLEP ELT) (FIND-VARIABLE-VALUE ELT ENV)) (T ELT))) (DEFUN FIND-VARIABLE-VALUE (VAR ENV) [LET [(VAL (CDR (ASSOC VAR ENV] (COND ((VARIABLEP VAL) (FIND-VARIABLE-VALUE VAL ENV)) ((NULL VAL) (IL:* IL:;; "The variable is unbound, so the variable itself is returned") VAR) ((NULLP VAL) (IL:* IL:;; "NULLP checks if the value is *NULL*") NIL) (T (IL:* IL:;; "This is the statement for a partial occur check") (OR (AND (NOT (FIND-IF-MEMBER VAR VAL)) (FIND-VALUES VAL ENV)) VAL]) (DEFUN LOOKUP (EXPR ENV) [COND ((NUMBERP EXPR) EXPR) ((SYMBOLP EXPR) (FIND-VALUES EXPR ENV)) (T (CONS (FIND-VALUES (CAR EXPR) ENV) (FIND-VALUES (CDR EXPR) ENV]) (DEFUN RENAME (EXPR) (LET ((VARSTABLE (MAKE-HASH-TABLE))) (DECLARE (SPECIAL VARSTABLE)) (RENAME-VARS EXPR))) (DEFUN RENAME-VARS (EXPR) (COND ((NULL EXPR) NIL) [(LISTP EXPR) (CONS (RENAME-VARS (CAR EXPR)) (RENAME-VARS (CDR EXPR] [(VARIABLEP EXPR) (LET ((ALREADY-RENAMED (GETHASH EXPR VARSTABLE))) (COND (ALREADY-RENAMED ALREADY-RENAMED) (T (LET ((NEW (CREATE-NEW-VARIABLE))) (SETF (GETHASH EXPR VARSTABLE) NEW) NEW] (T EXPR))) (DEFUN UNIFY (PATT DAT ENV &OPTIONAL WINDOW) (IL:* IL:;; "This is a very fast implementation of unifier: no stack frames are generated. The tecnique used here is that of save-rest argument: the unifier is not a true-recursive procedure, in the sense that it does not require a full stack for its implementation: in fact, when failure occurs, the value FAILED must be immediately returned ") [PROG ([DEBUGFLG (AND WINDOW (TRACINGP WINDOW 'UNIFY] (REST-PAT) (REST-DAT) TEMP) HERE (AND DEBUGFLG (UNIFY-DEBUGGER PATT DAT ENV WINDOW)) (IL:* IL:; "debugging stuff") [COND [(AND (NULL PATT) (NULL DAT)) (COND ((AND (NULL REST-DAT) REST-PAT) (RETURN 'FAILED)) ((AND (NULL REST-PAT) REST-DAT) (RETURN 'FAILED)) ((AND (NULL REST-PAT) (NULL REST-DAT)) (RETURN ENV)) (T (SETF PATT (CAR REST-PAT)) (SETF DAT (CAR REST-DAT)) (SETF REST-PAT (CDR REST-PAT)) (SETF REST-DAT (CDR REST-DAT)) (GO HERE] ((EQ ENV 'FAILED) (RETURN 'FAILED)) ((EQ PATT DAT) (GO OUT)) [(VARIABLEP DAT) (SETF TEMP (CDR (ASSOC DAT ENV))) (COND ((NULL TEMP) (SETF ENV (BUILD-NEW-ENV DAT PATT ENV)) (GO OUT)) (T (SETF DAT TEMP) (GO HERE] [(VARIABLEP PATT) (SETF TEMP (CDR (ASSOC PATT ENV))) (COND ((NULL TEMP) (SETF ENV (BUILD-NEW-ENV PATT DAT ENV)) (GO OUT)) (T (SETF PATT TEMP) (GO HERE] [(NULL PATT) (COND ((NULLP DAT) (GO OUT)) (T (RETURN 'FAILED] [(NULL DAT) (COND ((NULLP PATT) (GO OUT)) (T (RETURN 'FAILED] [(LISTP PATT) (COND ((LISTP DAT) (SETF REST-PAT (CONS (REST PATT) REST-PAT)) (SETF REST-DAT (CONS (REST DAT) REST-DAT)) (SETF PATT (CAR PATT)) (SETF DAT (CAR DAT)) (GO HERE)) (T (RETURN 'FAILED] (T (RETURN 'FAILED] OUT (IL:* IL:;; "a check is made for the end of the procedure") (COND ((AND (NULL REST-PAT) (NULL REST-DAT)) (RETURN ENV)) (T (SETF DAT NIL) (SETF PATT NIL) (GO HERE]) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/LOGIC.LGC b/lispusers/LOGIC.LGC new file mode 100644 index 00000000..2068c4ee --- /dev/null +++ b/lispusers/LOGIC.LGC @@ -0,0 +1 @@ +! (LAMBDA (TREE FORMULA CLAUSES WINDOW) (MAKE-TREE (AND-LEVEL TREE) (DELETE-OR-NODE-WITH-CUT FORMULA (OR-LEVELS TREE)))) SET (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((EXPANDED-VAR (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE)))) (EXPANDED-ARGS (LOOKUP (THIRD FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE)))) (RESULT (COND ((LISTP EXPANDED-ARGS) (APPLY (CAR EXPANDED-ARGS) (CDR EXPANDED-ARGS))) (T (EVAL EXPANDED-ARGS)))) (NEWENV (UNIFY EXPANDED-VAR RESULT (UNIFICATION-ENV (AND-LEVEL TREE))))) (COND ((FAILEDP NEWENV) (CLEAR-AND-LEVEL TREE)) (T (UPDATE-ENV NEWENV TREE))))) PRINT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((EXPANDED-CDR-FORMULA (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (FORMAT T "~S ~%" EXPANDED-CDR-FORMULA) TREE)) EVAL&PRINT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((EXPANDED-CDR-FORMULA (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (FORMAT T "~S ~%" (EVAL EXPANDED-CDR-FORMULA)) TREE)) RETRACT-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (SETF (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) (DELETE THEORY-NAME (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) :TEST (FUNCTION EQUAL))) TREE))) SAVE-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (SAVE-THEORY THEORY-NAME WINDOW) TREE))) LOAD-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (LOAD-THEORY THEORY-NAME WINDOW) TREE))) USE-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (SETF (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) (APPEND (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) (LIST THEORY-NAME))) TREE))) MERGE-THEORIES (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE)))) (LIST-OF-THEORIES (LOOKUP (REST (REST FORMULA)) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (OR (AND WINDOW (MERGE-THEORIES-DEVEL WINDOW THEORY-NAME LIST-OF-THEORIES)) (APPLY 'MERGE-THEORIES (CONS THEORY-NAME LIST-OF-THEORIES))) TREE))) FAIL (LAMBDA (TREE FORMULA CLAUSES WINDOW) (CLEAR-AND-LEVEL TREE)) TRUE (LAMBDA (TREE FORMULA CLAUSES WINDOW) TREE) WFF (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-CDR-FORMULA (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV ANDLEVEL)))) (SOLVE TREE EXPANDED-CDR-FORMULA (FIND-CLAUSES (PREDICATE EXPANDED-CDR-FORMULA) (GET-AND-NODE-THEORIES ANDLEVEL) WINDOW)))) LOGIC-ADDZ (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-ADDZ (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-ADDA (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-ADDA (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-DELETE-FACT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-DELETE-FACT (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-ASSERT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-ASSERT (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-DELETE (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-DELETE (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) WINDOW) TREE))) THEORY-END \ No newline at end of file diff --git a/lispusers/LOGIC.LISP b/lispusers/LOGIC.LISP new file mode 100644 index 00000000..48656c9d --- /dev/null +++ b/lispusers/LOGIC.LISP @@ -0,0 +1 @@ +;;; -*- Package: User; Syntax: Common-Lisp; Mode: Lisp; Base: 10 -*- ;;; File converted on 28-Oct-87 14:27:32 from source LOGIC ;;; Original source {DSK}LOGIC>MEDLEY>LOGIC.;1 created 1-Aug-88 12:07:04 ; Copyright (c) 1988 by Roberto Ghislanzoni. All rights reserved. (DEFUN ADD-OR-LEVEL (WFF CLAUSES TREE &OPTIONAL CUTNAME) ;; Adds a new or-node to the list of the nodes. The new node is ;; put in front of the old ones (COND ((NULL CLAUSES) TREE) (T (LET* ((LEVEL (AND-LEVEL TREE)) (NEW-OR-NODE (MAKE-OR-NODE WFF CLAUSES (CONJ LEVEL) (UNIFICATION-ENV LEVEL) (GET-AND-NODE-THEORIES LEVEL) CUTNAME))) (MAKE-TREE LEVEL (APPEND (LIST NEW-OR-NODE) (OR-LEVELS TREE))))))) (DEFUN ALL (VARS CONJ THS) (PROG (RESULTING-TREE (*VARIABLES-COUNTER* 0) (TREE (MAKE-TREE (MAKE-AND-NODE CONJ NIL (APPEND (LIST ' *BACKGROUND-THEORY* ) THS)) NIL)) COLLECTED-RESULTS NEXT-OR) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) HERE (SETF RESULTING-TREE (LOGIC-PROVE TREE)) (COND ((NULL RESULTING-TREE) (RETURN COLLECTED-RESULTS)) (T (SETF COLLECTED-RESULTS (APPEND COLLECTED-RESULTS (LIST (LOOKUP VARS (UNIFICATION-ENV (AND-LEVEL RESULTING-TREE )))))) (SETF NEXT-OR (FIRST (OR-LEVELS RESULTING-TREE))) (SETF TREE (SOLVE (NEW-TREE RESULTING-TREE NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR))) (GO HERE))))) (DEFUN ALL-PREDICATES (THEORY-NAME) (ALL-PREDS (GET-THEORY THEORY-NAME))) (DEFUN ALL-PREDS (THEORY) ;; The presence of VAL in the AND body is necessary because it ;; is correct to test if the predicates has not been erased: ;; in such a case its value is NIL (PROG (PRNAMES) LABEL (MAPHASH #'(LAMBDA (KEY VAL) (AND (NOT (SEMANTIC-ATTACHMENT-P VAL)) VAL (SETF PRNAMES (APPEND PRNAMES (LIST KEY))))) THEORY) (RETURN PRNAMES))) (DEFUN ALL-SAS (THEORY) (PROG (SANAMES) LABEL (MAPHASH #'(LAMBDA (KEY VAL) (AND (SEMANTIC-ATTACHMENT-P VAL) VAL (SETF SANAMES (APPEND SANAMES (LIST KEY))))) THEORY) (RETURN SANAMES))) (DEFUN ALL-SEMANTIC-ATTACHMENTS (THEORY-NAME) (ALL-SAS (GET-THEORY THEORY-NAME))) (DEFMACRO AND-LEVEL (TREE) `(CAR ,TREE)) (DEFMACRO ANTEC (WFF) `(CDDR ,WFF)) (DEFUN ANY (HOW-MANY VARS CONJ THS) (PROG (RESULTING-TREE (*VARIABLES-COUNTER* 0) (COUNTER 0) (TREE (MAKE-TREE (MAKE-AND-NODE CONJ NIL (APPEND (LIST ' *BACKGROUND-THEORY* ) THS)) NIL)) COLLECTED-RESULTS NEXT-OR) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) HERE (SETF RESULTING-TREE (LOGIC-PROVE TREE)) (COND ((OR (NULL RESULTING-TREE) (EQ COUNTER HOW-MANY)) (RETURN COLLECTED-RESULTS)) (T (SETF COLLECTED-RESULTS (APPEND COLLECTED-RESULTS (LIST (LOOKUP VARS (UNIFICATION-ENV (AND-LEVEL RESULTING-TREE )))))) (SETF NEXT-OR (FIRST (OR-LEVELS RESULTING-TREE))) (SETF TREE (SOLVE (NEW-TREE RESULTING-TREE NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR))) (INCF COUNTER) (GO HERE))))) (DEFMACRO ATOMIC-FORMULAP (WFF) `(AND (LISTP ,WFF) (NULL (SECOND ,WFF)))) (DEFUN ATTACH (SA-NAME DEFINITION THEORY-NAME &OPTIONAL WINDOW) (SETF (GETHASH SA-NAME (GET-THEORY THEORY-NAME WINDOW)) (CONS 'SA DEFINITION)) 'ATTACHED) (DEFMACRO CLAUSES-OR (OR-NODE) `(SECOND ,OR-NODE)) (DEFUN CLEAR-AND-LEVEL (TREE) (PROGN (SETF (CAR TREE) NIL) TREE)) (DEFMACRO CONJ (AND-LEVEL) `(CAR ,AND-LEVEL)) (DEFUN CONSEQ (WFF) (CAR WFF)) (DEFMACRO CONSEQP (C) `(AND (LISTP ,C) (SYMBOLP (CAR ,C)))) (DEFUN CREATE-BACKGROUND-THEORY NIL (PROGN (IN-PACKAGE 'USER) (CREATE-THEORY '*BACKGROUND-THEORY*) (WITH-OPEN-FILE (FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME 'MAIN :TYPE 'LGC)) :DIRECTION :INPUT) (PROG (NAME) LABEL (AND (EQ (SETF NAME (READ FILE)) 'THEORY-END) (RETURN)) (LOGIC-ASSERT NAME (CONS ' DIRECTLY-IMPLEMENTED (READ FILE)) '*BACKGROUND-THEORY*) (GO LABEL))))) (DEFUN CREATE-THEORY (THEORY-NAME) (SETF (GET 'THEORY THEORY-NAME) (MAKE-HASH-TABLE)) THEORY-NAME) (DEFUN DELETE-OR-NODE (TAGNODE NODES) (DELETE TAGNODE NODES :TEST #'EQUAL :COUNT 1)) (DEFUN DELETE-OR-NODE-WITH-CUT (CUTNAME OR-LEVELS) ;; This function is called every time a cut is proven: all the ;; alternatives for that clause MUST be erased. Remember that ;; every cut has a unique identifier (PROG ((NODES OR-LEVELS)) LABEL (COND ((NULL NODES) (RETURN OR-LEVELS)) ((EQ (GET-CUT (CAR NODES)) CUTNAME) (RETURN (DELETE-OR-NODE (CAR NODES) OR-LEVELS))) (T (SETF NODES (CDR NODES)) (GO LABEL))))) (DEFMACRO DIRECTLY-IMPLEMENTED (CLAUSES) `(EQ (CAR ,CLAUSES) 'DIRECTLY-IMPLEMENTED)) (DEFMACRO FAILEDP (ENV) `(EQ ,ENV 'FAILED)) (DEFUN FIND-CLAUSES (PREDICATE-NAME THEORY-NAMES &OPTIONAL WINDOW) (PROG NIL LABEL (COND ((NULL THEORY-NAMES) (RETURN NIL)) (T (LET* ((TH (FIRST THEORY-NAMES)) (CLAUSES (BINDING PREDICATE-NAME TH WINDOW))) (COND ((NULL CLAUSES) (SETF THEORY-NAMES (CDR THEORY-NAMES)) (GO LABEL)) (T (RETURN CLAUSES)))))))) (DEFMACRO FORMULA-OR (OR-LEVEL) `(CAR ,OR-LEVEL)) (DEFMACRO GET-AND-NODE-THEORIES (AND-NODE) `(THIRD ,AND-NODE)) (DEFMACRO GET-CUT (OR-NODE) `(SIXTH ,OR-NODE)) (DEFMACRO GET-OR-NODE-THEORIES (OR-NODE) `(FIFTH ,OR-NODE)) (DEFMACRO GET-THEORY (THEORY-NAME &OPTIONAL WINDOW) `(OR (AND ,WINDOW (GET-THEORY-INTERNAL ,THEORY-NAME ,WINDOW)) (GET 'THEORY ,THEORY-NAME))) (DEFMACRO IMPLICATIONP (WFF) `(LET ((SEPARATOR (SECOND ,WFF))) (AND (EQ SEPARATOR ':-) (NOT (NULL (CDDR ,WFF)))))) (DEFUN IS-THERE-CUT (CONJS) (OR (MEMBER '! CONJS) (PROG ((ELTS CONJS)) LABEL (COND ((NULL ELTS) NIL) ((AND (SYMBOLP (CAR ELTS)) (EQ (CHAR-CODE (CHAR (SYMBOL-NAME (CAR ELTS)) 0)) 33)) (RETURN T)) (T (SETF ELTS (CDR ELTS)) (GO LABEL)))))) (DEFUN LIST-ALL-THEORIES (&OPTIONAL WINDOW) (OR (AND WINDOW (LIST-ALL-THEORIES-INTERNAL WINDOW)) (DO ((LL (SYMBOL-PLIST 'THEORY) (CDDR LL)) (RESULT NIL)) ((NULL LL) RESULT) (SETF RESULT (APPEND RESULT (LIST (CAR LL))))))) (DEFUN LOAD-THEORY (THEORY-NAME &OPTIONAL WINDOW) (LET ((THEORY-FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME THEORY-NAME :TYPE 'LGC)))) (OR (AND WINDOW (LOAD-DEVEL-THEORY WINDOW THEORY-NAME)) (OR (AND (PROBE-FILE THEORY-FILE) (WITH-OPEN-FILE (FILE THEORY-FILE :DIRECTION :INPUT) (PROG (THEORY-NAME PRED-NUMBER SAS-NUMBER) (SETF THEORY-NAME (READ FILE)) (CREATE-THEORY THEORY-NAME) (SETF SAS-NUMBER (READ FILE)) (DO ((SAS SAS-NUMBER (DECF SAS))) ((EQ SAS 0) NIL) (SETF (GETHASH (READ FILE) (GET 'THEORY THEORY-NAME)) (READ FILE))) (SETF PRED-NUMBER (READ FILE)) (DO ((PREDS PRED-NUMBER (DECF PREDS))) ((EQ PREDS 0) NIL) (SETF (GETHASH (READ FILE) (GET 'THEORY THEORY-NAME)) (READ FILE))) (RETURN 'LOADED)))) (FORMAT T "Theory not found"))))) (DEFUN LOGIC-ADDA (PRED CLAUSES THEORY &OPTIONAL WINDOW) (PROGN (SETF (GETHASH PRED (GET-THEORY THEORY WINDOW)) (APPEND CLAUSES (GETHASH PRED (GET-THEORY THEORY WINDOW)))) 'ADDED)) (DEFUN LOGIC-ADDZ (PRED CLAUSES THEORY &OPTIONAL WINDOW) (PROGN (SETF (GETHASH PRED (GET-THEORY THEORY WINDOW)) (APPEND (GETHASH PRED (GET-THEORY THEORY WINDOW)) CLAUSES)) 'ADDED)) (DEFUN LOGIC-ASSERT (PREDICATE-NAME CLAUSES THEORY-NAME &OPTIONAL WINDOW) (SETF (GETHASH PREDICATE-NAME (GET-THEORY THEORY-NAME WINDOW)) CLAUSES) 'ASSERTED) (DEFUN LOGIC-DELETE (PRED-OR-SA THEORY-NAME &OPTIONAL WINDOW) (PROGN (SETF (GETHASH PRED-OR-SA (GET-THEORY THEORY-NAME WINDOW) ) NIL) 'DELETED)) (DEFUN LOGIC-DELETE-FACT (FACT-NAME FACT-CLAUSE THEORY &OPTIONAL WINDOW ) ;; deletes from the definition of facts one of the definitions ;; themselves ;; ((ON a b) (ON b c)) --> ((ON a b)) (PROGN (SETF (GETHASH FACT-NAME (GET-THEORY THEORY WINDOW)) (DELETE FACT-CLAUSE (GETHASH FACT-NAME (GET-THEORY THEORY WINDOW)) :TEST #'EQUAL)) 'DELETED)) (DEFUN LOGIC-PROVE (TREE &OPTIONAL WINDOW) (PROG ((*VARIABLES-COUNTER* -1)) (DECLARE (SPECIAL *VARIABLES-COUNTER*)) ;; This is a counter for the variables that will be used during the ;; unification JUMP (COND ((NULL-TREEP TREE) (RETURN NIL)) ((NULL-AND-LEVELP TREE) (LET ((NEXT-OR (FIRST (OR-LEVELS TREE)))) ;; Gets the next or-node: we have now no strategy for ;; choosing it; maybe later... (COND ((NULL NEXT-OR) (SETF TREE (LIST NIL NIL)) (GO JUMP)) (T (SETF TREE (SOLVE (NEW-TREE TREE NEXT-OR) (FORMULA-OR NEXT-OR) (CLAUSES-OR NEXT-OR) NIL WINDOW)) (GO JUMP))))) (T (LET ((NEXT-LEVEL (AND-LEVEL TREE))) (COND ((NULL (CONJ NEXT-LEVEL)) (RETURN TREE)) (T (LET* ((TO-PROVE (FIRST (CONJ NEXT-LEVEL))) (THS (GET-AND-NODE-THEORIES NEXT-LEVEL)) (CLAUSES (FIND-CLAUSES (PREDICATE TO-PROVE) THS WINDOW)) (CUT? (IS-THERE-CUT (REST (CONJ NEXT-LEVEL)) ))) (SETF TREE (SOLVE (UPDATE-TREE (UPDATE-LEVEL NEXT-LEVEL TO-PROVE) TREE) TO-PROVE CLAUSES CUT? WINDOW)) (GO JUMP))))))))) (DEFUN MAKE-AND-NODE (CONJ UNIF-ENV THEORIES) (LIST CONJ UNIF-ENV THEORIES)) (DEFUN MAKE-OR-NODE (WFF CLAUSES BORDER UNIF-ENV THEORIES &OPTIONAL CUTNAME) (LIST WFF CLAUSES BORDER UNIF-ENV THEORIES CUTNAME)) (DEFUN MAKE-TREE (AND-LEVEL OR-LEVELS) (LIST AND-LEVEL OR-LEVELS)) (DEFUN MERGE-INTERNAL (NEW-THEORY-NAME THEORIES &OPTIONAL WINDOW) (PROGN ;; Merges the specified theories in to a new-brand theory (LET ((ACTUAL-THEORY (GET-THEORY NEW-THEORY-NAME WINDOW))) (DO ((THS THEORIES (CDR THS))) ((NULL THS) 'MERGED) (AND (THEORYP (CAR THS) WINDOW) (MAPHASH #'(LAMBDA (KEY VAL) (AND VAL (SETF (GETHASH KEY ACTUAL-THEORY) VAL))) (GET-THEORY (CAR THS) WINDOW))))))) (DEFUN MERGE-THEORIES (NEW-THEORY-NAME &REST LIST-OF-THEORIES) (PROGN (CREATE-THEORY NEW-THEORY-NAME) (MERGE-INTERNAL NEW-THEORY-NAME LIST-OF-THEORIES) 'MERGED)) (DEFUN NEW-TREE (TREE OR-NODE) (MAKE-TREE (MAKE-AND-NODE (THIRD OR-NODE) (UNIF-ENV-OR OR-NODE) (GET-OR-NODE-THEORIES OR-NODE)) (DELETE-OR-NODE OR-NODE (OR-LEVELS TREE)))) (DEFMACRO NULL-AND-LEVELP (TREE) `(NULL (CAR ,TREE))) (DEFMACRO NULL-OR-LEVELP (TREE) `(NULL (SECOND ,TREE))) (DEFMACRO NULL-TREEP (TREE) `(AND (NULL-AND-LEVELP ,TREE) (NULL-OR-LEVELP ,TREE))) (DEFMACRO OR-LEVELS (TREE) `(SECOND ,TREE)) (DEFUN PREDICATE (WFF) (COND ((LISTP WFF) (CAR WFF)) (T WFF))) (DEFUN PROVE (CONJ THS) (LET ((RESULT (LOGIC-PROVE (MAKE-TREE (MAKE-AND-NODE CONJ NIL (APPEND (LIST ' *BACKGROUND-THEORY* ) THS)) NIL)))) (COND ((NULL RESULT) NIL) (T T)))) (DEFUN RENAME-CUT (ANTECS) ;; This function returns a CONS with CAR as the renamed cut and ;; CDR as the list of antecs with the cut renamed (DO ((TEMPVAR ANTECS (CDR TEMPVAR)) (RESULTS NIL) (CUT-RENAMED NIL)) ((NULL TEMPVAR) (CONS CUT-RENAMED RESULTS)) (COND ((EQ (CAR TEMPVAR) '!) (SETF CUT-RENAMED (GENSYM "!")) (SETF RESULTS (APPEND RESULTS (LIST CUT-RENAMED)))) (T (SETF RESULTS (APPEND RESULTS (LIST (CAR TEMPVAR))))) ))) (DEFUN SAVE-THEORY (THEORY-NAME &OPTIONAL WINDOW) (LET ((THEORY (GET-THEORY THEORY-NAME WINDOW))) (COND ((NOT (THEORYP THEORY)) 'ERROR) (T (WITH-OPEN-FILE (FILE (MERGE-PATHNAMES (MAKE-PATHNAME :NAME THEORY-NAME :TYPE 'LGC)) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE) (LET ((PREDS (SORT (ALL-PREDS THEORY) #'STRING-LESSP)) (SAS (SORT (ALL-SAS THEORY) #'STRING-LESSP))) (PROGN (FORMAT FILE "~S~%" THEORY-NAME) (FORMAT FILE "~D~%" (LENGTH SAS)) (DO ((SA-NAME SAS (CDR SA-NAME))) ((NULL SA-NAME) NIL) (FORMAT FILE "~S ~S ~%" (CAR SA-NAME) (GETHASH (CAR SA-NAME) THEORY))) (FORMAT FILE "~D~%" (LENGTH PREDS)) (DO ((PRED-NAME PREDS (CDR PRED-NAME))) ((NULL PRED-NAME) NIL) (FORMAT FILE "~S ~S ~%" (CAR PRED-NAME) (GETHASH (CAR PRED-NAME) THEORY))) 'SAVED))))))) (DEFMACRO SEMANTIC-ATTACHMENT-P (SA) `(EQ (CAR ,SA) 'SA)) (DEFUN SHOW-DEFINITION (ELEMENT THEORY-NAME &OPTIONAL WINDOW) (FORMAT (OR (AND WINDOW *TRACE-OUTPUT*) T) "~S~%" (PROG ((DEF (GETHASH ELEMENT (GET-THEORY THEORY-NAME WINDOW)))) (OR (AND (SEMANTIC-ATTACHMENT-P DEF) (RETURN (CDR DEF))) (RETURN DEF))))) (DEFUN SHOW-THEORY (THEORY-NAME &OPTIONAL VERBOSE WINDOW) (LET* ((THEORY (GET-THEORY THEORY-NAME)) (PREDICATES (SORT (ALL-PREDS THEORY) #'STRING-LESSP)) (SAS (SORT (ALL-SAS THEORY) #'STRING-LESSP)) (STREAM (OR (AND WINDOW *TRACE-OUTPUT*) T))) (OR (AND SAS (PROGN (FORMAT STREAM "Semantic attachments: ~%") (DO ((PP SAS (CDR PP))) ((NULL PP) NIL) (PROGN (FORMAT T "~%~S ~% " (CAR PP)) (AND VERBOSE (FORMAT T "Definition: ~S ~%" (CDR (GETHASH (CAR PP) THEORY)) " ")))) (FORMAT STREAM "~% ~%")))) (OR (AND PREDICATES (PROGN (FORMAT STREAM "Predicates: ~%") (DO ((PP PREDICATES (CDR PP))) ((NULL PP) NIL) (PROGN (FORMAT T "~%~S ~%" (CAR PP)) (AND VERBOSE (FORMAT STREAM "Clauses: ~S ~%" (GETHASH (CAR PP) THEORY) " ")))) (FORMAT STREAM "~% ~%")))))) (DEFUN SOLVE (TREE FORMULA CLAUSES &OPTIONAL CUT WINDOW) (PROG NIL JUMP (AND WINDOW (SOLVE-DEBUGGER TREE FORMULA CLAUSES WINDOW)) (COND ((NULL CLAUSES) ; demo is failed (RETURN (CLEAR-AND-LEVEL TREE))) ((DIRECTLY-IMPLEMENTED CLAUSES) ; clauses from the main ; theory (RETURN (FUNCALL (CDR CLAUSES) TREE FORMULA CLAUSES WINDOW))) ((SEMANTIC-ATTACHMENT-P CLAUSES) ; Semantic attachment ; defined by the user (LET ((EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV (AND-LEVEL TREE))))) (COND ((APPLY (CDR CLAUSES) (CDR EXPANDED-FORMULA)) (RETURN TREE)) (T (RETURN (CLEAR-AND-LEVEL TREE)))))) (T (LET* ((CANDIDATE (FIRST CLAUSES)) (ASSERT (RENAME CANDIDATE)) (NEWENV (UNIFY FORMULA (CONSEQ ASSERT) (UNIFICATION-ENV (AND-LEVEL TREE)) WINDOW))) (COND ((FAILEDP NEWENV) (SETF CLAUSES (REST CLAUSES)) (GO JUMP)) ((ATOMIC-FORMULAP ASSERT) ;; If a cut has been discovered in the previous ;; procedure, it is necessary not to instantiate ;; alternatives for the clause in a or-level (RETURN (UPDATE-ENV NEWENV (OR (AND CUT TREE) (ADD-OR-LEVEL FORMULA (REST CLAUSES) TREE))))) ((IMPLICATIONP ASSERT) ;; If there is a cut, it is necessary to mark the ;; alternatives for that clause; if the cut will be ;; proved, then these alternatives will be ;; eliminated (RETURN (COND ((IS-THERE-CUT (ANTEC ASSERT)) (LET* ((RENAMED-STRUCTURE (RENAME-CUT (ANTEC ASSERT))) (RENAMED-CUT (CAR RENAMED-STRUCTURE )) (RENAMED-ASSERT (CDR RENAMED-STRUCTURE ))) (SUBSTITUTE-LEVEL NEWENV RENAMED-ASSERT (ADD-OR-LEVEL FORMULA (REST CLAUSES) TREE RENAMED-CUT)))) (T (SUBSTITUTE-LEVEL NEWENV (ANTEC ASSERT) (ADD-OR-LEVEL FORMULA (REST CLAUSES ) TREE)))))))))))) (DEFUN SUBSTITUTE-LEVEL (ENV ANTECS TREE) (PROGN (RPLACA TREE (MAKE-AND-NODE (APPEND ANTECS (CONJ (AND-LEVEL TREE))) ENV (GET-AND-NODE-THEORIES (AND-LEVEL TREE)))) TREE)) (DEFMACRO THEORYP (THEORY &OPTIONAL WINDOW) `(OR (AND (GET-THEORY ,THEORY ,WINDOW) T) (HASH-TABLE-P ,THEORY))) (DEFMACRO UNIF-ENV-OR (OR-NODE) `(FOURTH ,OR-NODE)) (DEFMACRO UNIFICATION-ENV (AND-NODE) `(SECOND ,AND-NODE)) (DEFUN UPDATE-ENV (ENV TREE) (SETF (SECOND (AND-LEVEL TREE)) ENV) TREE) (DEFUN UPDATE-LEVEL (LEVEL FORMULA) (MAKE-AND-NODE (CDR (CONJ LEVEL)) (UNIFICATION-ENV LEVEL) (GET-AND-NODE-THEORIES LEVEL))) (DEFUN UPDATE-TREE (LEVEL TREE) (MAKE-TREE LEVEL (OR-LEVELS TREE))) \ No newline at end of file diff --git a/lispusers/LOGIC.TEDIT b/lispusers/LOGIC.TEDIT new file mode 100644 index 00000000..d77a4bb3 Binary files /dev/null and b/lispusers/LOGIC.TEDIT differ diff --git a/lispusers/LOGTIME b/lispusers/LOGTIME new file mode 100644 index 00000000..9d7a9cdb --- /dev/null +++ b/lispusers/LOGTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "28-Oct-89 12:13:26" {ICE}LISPUSERS>MEDLEY>LOGTIME.;3 20673 changes to%: (VARS LOGTIMECOMS) (FNS LogTime.Prompt LogTime.Proc LogTime.Update) previous date%: "24-Oct-89 17:08:48" {ICE}LISPUSERS>KOTO>LOGTIME.;6) (* " Copyright (c) 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT LOGTIMECOMS) (RPAQQ LOGTIMECOMS ((FNS LOGTIME.EDIT LOGTIME.REPORT LOGTIME.START LOGTIME.STOP LOGTIME.UPDATE) (INITVARS (LOGTIME.INTERVAL 15) (LOGTIME.DATAFILE (PACKFILENAME (QUOTE NAME) "LogTime" (QUOTE EXTENSION) "Data" (QUOTE BODY) LOGINHOST/DIR)) (LOGTIME.REPORTFILE T) (LOGTIME.PROMPT.URGENCY (QUOTE TTY))) (* ;; "Implementation") (PROP MAKEFILE-ENVIRONMENT LOGTIME) (FNS LogTime.AroundExitFn LogTime.ButtonFn LogTime.Dump LogTime.Edit LogTime.GDate LogTime.IDate LogTime.Load LogTime.Message LogTime.Proc LogTime.Prompt LogTime.Quit LogTime.Report LogTime.ReportTime LogTime.Start LogTime.Update) (RECORDS LogTimeData) (INITVARS (LogTime.process NIL) (LogTime.promptWindow NIL) (LogTime.promptWindowRegion NIL) (LogTime.suspendedLogfile NIL)) (ADDVARS (AROUNDEXITFNS LogTime.AroundExitFn) (BackgroundMenuCommands ("Log Time" (LogTime.Start) "Keep track of how time is spent" (SUBITEMS ("Update" (LogTime.Start) "Start or update log") ("Edit" (LogTime.Edit) "Edit current data") ("Report" (LogTime.Report) "Generate report on LOGTIME.REPORTFILE") ("Quit" (LogTime.Quit) "Quit keeping track of how time is spent and update log file" (SUBITEMS ("Abort" (LogTime.Quit T) "Quit keeping track of how time is spent but DON'T update log file"))))))) (VARS (BackgroundMenu NIL)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LogTime.Message))))) (DEFINEQ (LOGTIME.EDIT (LAMBDA (DATAFILE NEWDATAFILE) (* Koomen "24-Oct-89 14:11") (DECLARE (GLOBALVARS LogTime.process)) (PROG ((logtimedata (LogTime.Load DATAFILE))) (WITH.MONITOR (fetch (LogTimeData lock) of logtimedata) (PROG (entries newentries entry newentry) (for old entry in (fetch (LogTimeData entries) of logtimedata) do (for pair in (CDR entry) do (push entries (LIST (CAR pair) (CDR pair) (CAR entry))))) (SETQ entries (DREVERSE (SORT entries T))) (for old entry in entries do (RPLACA entry (LogTime.GDate (CAR entry))) (RPLACA (CDR entry) (LogTime.GDate (CADR entry)))) (SETQ entries (EDITE entries)) (if (for old entry in entries bind d1 d2 do (if (AND (SETQ d1 (LogTime.IDate (CAR entry))) (SETQ d2 (LogTime.IDate (CADR entry)))) then (RPLACA entry d1) (RPLACA (CDR entry) d2) else (LogTime.Message "Edit aborted -- bad format: " entry) (RETURN T))) then (RETURN)) (SETQ entries (SORT entries T)) (for old entry in entries do (if (SETQ newentry (SASSOC (CADDR entry) newentries)) then (push (CDR newentry) (CONS (CAR entry) (CADR entry))) else (push newentries (LIST (CADDR entry) (CONS (CAR entry) (CADR entry)))))) (UNINTERRUPTABLY (replace (LogTimeData entries) of logtimedata with newentries) (SETQ entry (CAR entries)) (replace (LogTimeData firstUpdate) of logtimedata with (CAR entry)) (SETQ entry (CAR (LAST entries))) (replace (LogTimeData lastUpdate) of logtimedata with (CADR entry)) (replace (LogTimeData lastEntry) of logtimedata with (SASSOC (CADDR entry) newentries)) (replace (LogTimeData activityMenu) of logtimedata with NIL)) (RETURN (if NEWDATAFILE then (replace (LogTimeData logfile) of logtimedata with NEWDATAFILE) (LogTime.Dump logtimedata) elseif (OR (NOT (PROCESSP LogTime.process)) (NEQ (PROCESSPROP LogTime.process (QUOTE LogTimeData)) logtimedata)) then (LogTime.Dump logtimedata))))))) ) (LOGTIME.REPORT (LAMBDA (BYDATEFLG VERBOSEFLG FROMDATE TODATE DATAFILE REPORTFILE) (* Koomen "10-Oct-89 14:51") (PROG ((logtimedata (LogTime.Load DATAFILE))) (WITH.MONITOR (fetch (LogTimeData lock) of logtimedata) (PROG (entries fromidate toidate report col1 col2 totalsecs datewidth subtotalmsg) (SETQ fromidate (MAX (fetch (LogTimeData firstUpdate) of logtimedata) (OR (AND FROMDATE (IDATE (CONCAT FROMDATE " 0:00:00"))) 0))) (SETQ toidate (MIN (fetch (LogTimeData lastUpdate) of logtimedata) (OR (AND TODATE (IDATE (CONCAT TODATE " 23:59:59"))) (IDATE)))) (* ;; "Filter out unwanted entries") (SETQ entries (for entry in (fetch (LogTimeData entries) of logtimedata) bind pairs when (SETQ pairs (for pair in (CDR entry) when (AND (LEQ fromidate (CAR pair)) (LEQ (CAR pair) toidate)) collect (CONS (CAR pair) (MIN (CDR pair) toidate)))) collect (CONS (CAR entry) (SORT pairs T)))) (SETQ datewidth (CONSTANT (NCHARS (LogTime.GDate)))) (if (NULL entries) then (LogTime.Message "no data to report between " (LogTime.GDate fromidate) " and " (LogTime.GDate toidate)) (RETURN)) (SETQ subtotalmsg " Subtotal:") (SETQ totalsecs (for entry in entries sum (for pair in (CDR entry) sum (DIFFERENCE (CDR pair) (CAR pair))))) (if (AND REPORTFILE (NEQ REPORTFILE T)) then (SETQ report (OPENSTREAM REPORTFILE (QUOTE OUTPUT))) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) report)) else (SETQ report (GETSTREAM REPORTFILE (QUOTE OUTPUT)))) (printout report "Time Log Report") (printout report 18 "-- dated" 29 (LogTime.GDate)) (printout report 18 "-- from" 29 (LogTime.GDate fromidate)) (printout report 18 "-- to" 29 (LogTime.GDate toidate) T T) (if BYDATEFLG then (SETQ entries (if VERBOSEFLG then (for entry in entries bind newentries start newentry newpair do (for pair in (CDR entry) do (SETQ start (CAR pair)) (SETQ newpair (CONS (CAR entry) (DIFFERENCE (CDR pair) (CAR pair)))) (if (SETQ newentry (SASSOC start newentries)) then (RPLACD newentry (SORT (CONS newpair (CDR newentry)) T)) else (push newentries (LIST start newpair)))) finally (RETURN newentries)) else (for entry in entries bind newentries start newentry do (for pair in (CDR entry) do (SETQ start (LogTime.GDate (CAR pair) T)) (if (SETQ newentry (SASSOC start newentries)) then (add (CDR newentry) (DIFFERENCE (CDR pair) (CAR pair))) else (push newentries (CONS start (DIFFERENCE (CDR pair) (CAR pair)))))) finally (RETURN newentries)))) (SETQ entries (SORT entries T)) (if VERBOSEFLG then (SETQ col1 (PLUS datewidth 3)) (SETQ col2 (NCHARS subtotalmsg)) (for entry in entries do (for pair in (CDR entry) do (SETQ col2 (MAX col2 (NCHARS (CAR pair)))))) (SETQ col2 (PLUS col1 col2 3)) (for entry in entries bind secs subtotsecs curday newday do (SETQ newday (\UNPACKDATE (CAR entry))) (if (OR (NEQ (CADDR newday) (CADDR curday)) (NEQ (CADR newday) (CADR curday)) (NEQ (CAR newday) (CAR curday))) then (if (AND curday (GREATERP subtotsecs secs)) then (printout report .TAB col1 subtotalmsg .TAB col2) (LogTime.ReportTime report subtotsecs totalsecs)) (SETQ curday newday) (SETQ subtotsecs 0)) (printout report (LogTime.GDate (CAR entry))) (for pair in (CDR entry) do (SETQ secs (CDR pair)) (add subtotsecs secs) (printout report .TAB col1 (CAR pair) .TAB col2) (LogTime.ReportTime report secs totalsecs)) finally (if (GREATERP subtotsecs secs) then (printout report .TAB col1 subtotalmsg .TAB col2) (LogTime.ReportTime report subtotsecs totalsecs)) (printout report T "Total:" .TAB col2) (LogTime.ReportTime report totalsecs)) else (SETQ col1 (PLUS (NCHARS (CAAR entries)) 3)) (for entry in entries do (printout report (CAR entry) .TAB col1) (LogTime.ReportTime report (CDR entry) totalsecs) finally (printout report T "Total:" .TAB col1) (LogTime.ReportTime report totalsecs))) else (SETQ entries (SORT entries T)) (SETQ col1 (CONSTANT (NCHARS "Total:"))) (for entry in entries do (SETQ col1 (MAX col1 (NCHARS (CAR entry))))) (add col1 3) (if VERBOSEFLG then (SETQ col2 (PLUS col1 datewidth 3)) (for entry in entries bind secs subtotsecs do (printout report (CAR entry)) (SETQ subtotsecs 0) (for pair in (CDR entry) do (SETQ secs (DIFFERENCE (CDR pair) (CAR pair))) (add subtotsecs secs) (printout report .TAB col1 (LogTime.GDate (CAR pair)) .TAB col2) (LogTime.ReportTime report secs totalsecs)) (if (GREATERP subtotsecs secs) then (printout report .TAB col1 subtotalmsg .TAB col2) (LogTime.ReportTime report subtotsecs totalsecs)) finally (printout report T "Total:" .TAB col2) (LogTime.ReportTime report totalsecs)) else (for entry in entries bind secs subtotsecs do (printout report (CAR entry)) (SETQ subtotsecs (for pair in (CDR entry) sum (DIFFERENCE (CDR pair) (CAR pair)))) (printout report .TAB col1) (LogTime.ReportTime report subtotsecs totalsecs) finally (printout report T "Total:" .TAB col1) (LogTime.ReportTime report totalsecs)))))))) ) (LOGTIME.START (LAMBDA (DATAFILE) (* Koomen "12-Oct-89 09:50") (LogTime.Start DATAFILE T))) (LOGTIME.STOP (LAMBDA (ABORTFLG WAITFLG) (* Koomen "24-Oct-89 14:39") (if (AND (PROCESSP LogTime.process) (NOT (PROCESS.FINISHEDP LogTime.process))) then (LogTime.Quit ABORTFLG T) (while (AND WAITFLG (PROCESSP LogTime.process) (NOT (PROCESS.FINISHEDP LogTime.process))) do (BLOCK)))) ) (LOGTIME.UPDATE (LAMBDA NIL (* Koomen "12-Oct-89 10:30") (DECLARE (GLOBALVARS LogTime.process)) (if (AND (PROCESSP LogTime.process) (NOT (PROCESS.FINISHEDP LogTime.process))) then (WAKE.PROCESS LogTime.process))) ) ) (RPAQ? LOGTIME.INTERVAL 15) (RPAQ? LOGTIME.DATAFILE (PACKFILENAME (QUOTE NAME) "LogTime" (QUOTE EXTENSION) "Data" (QUOTE BODY) LOGINHOST/DIR)) (RPAQ? LOGTIME.REPORTFILE T) (RPAQ? LOGTIME.PROMPT.URGENCY (QUOTE TTY)) (* ;; "Implementation") (PUTPROPS LOGTIME MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (DEFINEQ (LogTime.AroundExitFn (LAMBDA (EVENT) (* Koomen "24-Oct-89 17:07") (SELECTQ (SUBATOM EVENT 1 5) (BEFOR (if (AND (PROCESSP LogTime.process) (NOT (PROCESS.FINISHEDP LogTime.process))) then (LET ((logtimedata (PROCESSPROP LogTime.process (QUOTE LogTimeData)))) (LOGTIME.STOP NIL T) (SETQ LogTime.suspendedLogfile (PACKFILENAME (QUOTE VERSION) NIL (QUOTE BODY) (fetch (LogTimeData logfile) of logtimedata)))) else (SETQ LogTime.suspendedLogfile NIL))) (AFTER (if LogTime.suspendedLogfile then (LOGTIME.START LogTime.suspendedLogfile) (SETQ LogTime.suspendedLogfile NIL))) NIL) NIL) ) (LogTime.ButtonFn (LAMBDA (window) (* Koomen "20-Sep-89 14:29") (* ;; "The rightbuttoneventfn on the LogTime promptwindow ") (DECLARE (GLOBALVARS LogTime.promptWindowRegion)) (if (NOT (INSIDEP LogTime.promptWindowRegion (LASTMOUSEX window) (LASTMOUSEY window))) then (DOWINDOWCOM window) else (PROG (logdata entries menu activity) (SETQ logdata (PROCESSPROP (WINDOWPROP window (QUOTE PROCESS)) (QUOTE LogTimeData))) (SETQ entries (fetch (LogTimeData entries) of logdata)) (if (NULL entries) then (RETURN)) (SETQ activity (MENU (OR (fetch (LogTimeData activityMenu) of logdata) (replace (LogTimeData activityMenu) of logdata with (create MENU ITEMS _ (SORT (for entry in entries collect (CAR entry))) TITLE _ "Activities:"))))) (if (NULL activity) then (RETURN)) (* ;; "Erase current typein and insert menu selection") (BKSYSBUF "") (BKSYSBUF activity)))) ) (LogTime.Dump (LAMBDA (logtimedata) (* Koomen "24-Oct-89 17:07") (DECLARE (GLOBALVARS LOGTIME.DATAFILE)) (if (fetch (LogTimeData entries) of logtimedata) then (PROG ((logfile (OR (fetch (LogTimeData logfile) of logtimedata) LOGTIME.DATAFILE))) (LogTime.Message "saving data to " (FULLNAME logfile (QUOTE OLD/NEW))) (SETQ logfile (WRITEFILE (LIST* (fetch (LogTimeData firstUpdate) of logtimedata) (fetch (LogTimeData lastUpdate) of logtimedata) (fetch (LogTimeData entries) of logtimedata)) logfile)) (replace (LogTimeData logfile) of logtimedata with logfile) (LogTime.Message "done saving data to " logfile) (RETURN logfile)))) ) (LogTime.Edit (LAMBDA NIL (* Koomen "10-Oct-89 13:07") (DECLARE (GLOBALVARS LogTime.process)) (if (OR (NOT (PROCESSP LogTime.process)) (PROCESS.FINISHEDP LogTime.process)) then (LogTime.Message "not running") else (replace (LogTimeData status) of (PROCESSPROP LogTime.process (QUOTE LogTimeData)) with (QUOTE Edit)) (WAKE.PROCESS LogTime.process))) ) (LogTime.GDate (LAMBDA (DATE NOTIMEFLG) (* Koomen "10-Oct-89 14:13") (GDATE DATE (if NOTIMEFLG then (DATEFORMAT NO.TIME) else (DATEFORMAT NO.SECONDS)))) ) (LogTime.IDate (LAMBDA (DATE) (* Koomen "10-Oct-89 14:31") (* ;; "Like IDATE but round off to nearest minute") (PROG NIL (RETURN (APPLY (FUNCTION (LAMBDA (YEAR MONTH DAY HR MIN SEC) (\PACKDATE YEAR MONTH DAY HR MIN (if (LESSP SEC 30) then 0 else 60)))) (\UNPACKDATE (OR (IDATE DATE) (RETURN NIL))))))) ) (LogTime.Load (LAMBDA (datafile) (* Koomen "12-Oct-89 10:12") (DECLARE (GLOBALVARS LOGTIME.DATAFILE LogTime.process)) (LET ((logfile (INFILEP (OR datafile LOGTIME.DATAFILE))) (logdata NIL)) (if (AND (PROCESSP LogTime.process) (SETQ logdata (PROCESSPROP LogTime.process (QUOTE LogTimeData))) (EQ logfile (fetch (LogTimeData logfile) of logdata))) then (LogTime.Message "using current data") logdata elseif logfile then (LogTime.Message "loading data from " logfile) (SETQ logdata (CDR (READFILE logfile))) (PROG1 (create LogTimeData logfile _ logfile lock _ (CREATE.MONITORLOCK) firstUpdate _ (CAR logdata) lastUpdate _ (CADR logdata) entries _ (CDDR logdata)) (LogTime.Message "done loading data from " logfile)) else (if datafile then (LogTime.Message datafile " not found")) (SETQ logfile (OUTFILEP (OR datafile LOGTIME.DATAFILE))) (LogTime.Message "creating new data") (SETQ logdata (LogTime.IDate)) (create LogTimeData logfile _ logfile lock _ (CREATE.MONITORLOCK) firstUpdate _ logdata lastUpdate _ logdata)))) ) (LogTime.Message (LAMBDA NARGS (* Koomen "20-Sep-89 16:44") (DECLARE (GLOBALVARS PROMPTWINDOW)) (printout PROMPTWINDOW .TAB0 0 "" T)) ) (LogTime.Proc (LAMBDA (datafile) (* Koomen "27-Oct-89 12:41") (DECLARE (GLOBALVARS LOGTIME.INTERVAL)) (LET ((logtimedata (PROCESSPROP (THIS.PROCESS) (QUOTE LogTimeData)))) (if logtimedata then (* ;; "Already initialized (process restarted after a hardreset) so just restart the loop") else (while \IDLING do (BLOCK)) (PROCESSPROP (THIS.PROCESS) (QUOTE LogTimeData) (SETQ logtimedata (LogTime.Load datafile))) (replace (LogTimeData lastUpdate) of logtimedata with (IDATE)) (LogTime.Message "keeping track of time...")) (do (replace (LogTimeData status) of logtimedata with (QUOTE Collect)) (BLOCK (if (NOT \IDLING) then (TIMES LOGTIME.INTERVAL 60000))) (SELECTQ (fetch (LogTimeData status) of logtimedata) (Collect (LogTime.Update logtimedata)) (Edit (LogTime.Update logtimedata) (LOGTIME.EDIT)) (Report (LogTime.Update logtimedata) (LOGTIME.REPORT T T (GDATE NIL (DATEFORMAT NO.TIME)))) (Abort (RETURN NIL)) (Quit (LogTime.Update logtimedata) (RETURN (LogTime.Dump logtimedata))) (Quit! (LogTime.Update logtimedata T) (RETURN (LogTime.Dump logtimedata))) (SHOULDNT "Bad LogTime status"))) (LogTime.Message "done keeping track of time"))) ) (LogTime.Prompt (LAMBDA (candidate) (* Koomen "28-Oct-89 12:02") (* ;; "From (* bvm: %"17-Sep-85 15:04%") PopUpWindowAndGetAtom") (DECLARE (GLOBALVARS LASTMOUSEX LASTMOUSEY LOGTIME.PROMPT.URGENCY LogTime.promptWindow LogTime.promptWindowRegion SCREENHEIGHT SCREENWIDTH)) (CAR (NLSETQ (LET ((promptstring "Latest activity: ") (promptw LogTime.promptWindow)) (if (NOT (WINDOWP promptw)) then (LET* ((bordersize 10) (font (DEFAULTFONT)) (promptwidth (STRINGWIDTH promptstring font)) (answerwidth (TIMES 60 (CHARWIDTH (CHARCODE A) font))) (width (WIDTHIFWINDOW (PLUS promptwidth answerwidth) bordersize)) (height (HEIGHTIFWINDOW (TIMES (FONTPROP font (QUOTE HEIGHT)) 2) NIL bordersize))) (SETQ LogTime.promptWindowRegion (CREATEREGION 0 0 width height)) (SETQ promptw (CREATEW (COPY LogTime.promptWindowRegion) "Log Time: (click right for menu)" bordersize T)) (WINDOWPROP promptw (QUOTE RIGHTBUTTONFN) (FUNCTION LogTime.ButtonFn)) (SETQ LogTime.promptWindow promptw))) (MOVEW promptw (IMIN LASTMOUSEX (IDIFFERENCE SCREENWIDTH (fetch (REGION WIDTH) of (WINDOWREGION promptw)))) (IMIN LASTMOUSEY (IDIFFERENCE SCREENHEIGHT (fetch (REGION HEIGHT) of (WINDOWREGION promptw))))) (RESETSAVE (OPENW promptw) (LIST (FUNCTION CLOSEW) promptw)) (RESETSAVE NIL (LIST (FUNCTION CLEARW) promptw)) (PROMPTFORWORD promptstring candidate NIL promptw NIL LOGTIME.PROMPT.URGENCY (CHARCODE (CR LF))))))) ) (LogTime.Quit (LAMBDA (abortflag noninteractivep) (* Koomen "24-Oct-89 16:01") (DECLARE (GLOBALVARS LogTime.process)) (if (OR (NOT (PROCESSP LogTime.process)) (PROCESS.FINISHEDP LogTime.process)) then (if (NOT noninteractivep) then (LogTime.Message "not running")) elseif (AND abortflag (NOT noninteractivep) (NOT (MOUSECONFIRM "Abort Time Logging (current data lost!)"))) then (LogTime.Message "abort canceled") else (replace (LogTimeData status) of (PROCESSPROP LogTime.process (QUOTE LogTimeData)) with (if abortflag then (QUOTE Abort) elseif noninteractivep then (QUOTE Quit!) else (QUOTE Quit))) (WAKE.PROCESS LogTime.process))) ) (LogTime.Report (LAMBDA NIL (* Koomen "21-Sep-89 09:55") (DECLARE (GLOBALVARS LogTime.process)) (if (OR (NOT (PROCESSP LogTime.process)) (PROCESS.FINISHEDP LogTime.process)) then (ADD.PROCESS (QUOTE (LOGTIME.REPORT))) else (replace (LogTimeData status) of (PROCESSPROP LogTime.process (QUOTE LogTimeData)) with (QUOTE Report)) (WAKE.PROCESS LogTime.process))) ) (LogTime.ReportTime (LAMBDA (report secs totalsecs) (* Koomen "18-Sep-89 13:19") (PROG (mins hrs) (SETQ mins (QUOTIENT (PLUS secs 30) 60)) (SETQ hrs (QUOTIENT mins 60)) (add mins (TIMES hrs -60)) (printout report |.I3| hrs ":" (QUOTIENT mins 10) (REMAINDER mins 10)) (if totalsecs then (printout report |.I6| (TIMES (FQUOTIENT secs totalsecs) 100) " %%") (QUOTIENT (PLUS (TIMES secs 100) (QUOTIENT (ADD1 totalsecs) 2)) totalsecs)) (TERPRI report))) ) (LogTime.Start (LAMBDA (datafile noninteractivep) (* Koomen "24-Oct-89 15:39") (DECLARE (GLOBALVARS LogTime.process)) (if (OR (NOT (PROCESSP LogTime.process)) (PROCESS.FINISHEDP LogTime.process)) then (SETQ LogTime.process (ADD.PROCESS (LIST (FUNCTION LogTime.Proc) (KWOTE datafile)) (QUOTE NAME) (QUOTE Time% Logger) (QUOTE RESTARTABLE) T)) elseif (NEQ (INFILEP (OR datafile LOGTIME.DATAFILE)) (fetch (LogTimeData logfile) of (PROCESSPROP LogTime.process (QUOTE LogTimeData)))) then (LogTime.Message "Can't log time on " (OR datafile LOGTIME.DATAFILE) " while already logging time on " (fetch (LogTimeData logfile) of (PROCESSPROP LogTime.process (QUOTE LogTimeData)))) elseif (NOT noninteractivep) then (WAKE.PROCESS LogTime.process))) ) (LogTime.Update (LAMBDA (logtimedata noninteractivep) (* Koomen "27-Oct-89 12:41") (WITH.MONITOR (fetch (LogTimeData lock) of logtimedata) (PROG (entry activity lasttime thistime) (SETQ entry (fetch (LogTimeData lastEntry) of logtimedata)) (SETQ activity (if noninteractivep then (CAR entry) else (while \IDLING do (BLOCK)) (LogTime.Prompt (CAR entry)))) (SETQ lasttime (fetch (LogTimeData lastUpdate) of logtimedata)) (SETQ thistime (LogTime.IDate)) (UNINTERRUPTABLY (replace (LogTimeData lastUpdate) of logtimedata with thistime) (if (NULL activity) then (* ;; "Ignore last interval, and continue (got here through ^E under prompt)") (replace (LogTimeData lastEntry) of logtimedata with NIL) elseif (EQUAL activity (CAR entry)) then (* ;; "Extend the previous interval") (RPLACD (CADR entry) thistime) elseif (SETQ entry (SASSOC activity (fetch (LogTimeData entries) of logtimedata))) then (* ;; "Add a new interval to exiting entry") (replace (LogTimeData lastEntry) of logtimedata with entry) (push (CDR entry) (CONS lasttime thistime)) else (* ;; "Add a new entry") (replace (LogTimeData activityMenu) of logtimedata with NIL) (push (fetch (LogTimeData entries) of logtimedata) (replace (LogTimeData lastEntry) of logtimedata with (LIST activity (CONS lasttime thistime))))))))) ) ) (DECLARE%: EVAL@COMPILE (RECORD LogTimeData (logfile lock status firstUpdate lastUpdate lastEntry activityMenu . entries)) ) (RPAQ? LogTime.process NIL) (RPAQ? LogTime.promptWindow NIL) (RPAQ? LogTime.promptWindowRegion NIL) (RPAQ? LogTime.suspendedLogfile NIL) (ADDTOVAR AROUNDEXITFNS LogTime.AroundExitFn) (ADDTOVAR BackgroundMenuCommands ("Log Time" (LogTime.Start) "Keep track of how time is spent" (SUBITEMS ("Update" (LogTime.Start) "Start or update log") ("Edit" (LogTime.Edit) "Edit current data") ("Report" (LogTime.Report) "Generate report on LOGTIME.REPORTFILE") ("Quit" (LogTime.Quit) "Quit keeping track of how time is spent and update log file" (SUBITEMS ("Abort" (LogTime.Quit T) "Quit keeping track of how time is spent but DON'T update log file")))))) (RPAQQ BackgroundMenu NIL) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA LogTime.Message) ) (PUTPROPS LOGTIME COPYRIGHT ("Johannes A. G. M. Koomen" 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1821 9082 (LOGTIME.EDIT 1831 . 3658) (LOGTIME.REPORT 3660 . 8472) (LOGTIME.START 8474 . 8569) (LOGTIME.STOP 8571 . 8860) (LOGTIME.UPDATE 8862 . 9080)) (9430 19645 (LogTime.AroundExitFn 9440 . 10023) (LogTime.ButtonFn 10025 . 10886) (LogTime.Dump 10888 . 11522) (LogTime.Edit 11524 . 11878) (LogTime.GDate 11880 . 12038) (LogTime.IDate 12040 . 12347) (LogTime.Load 12349 . 13370) ( LogTime.Message 13372 . 13607) (LogTime.Proc 13609 . 14752) (LogTime.Prompt 14754 . 16143) ( LogTime.Quit 16145 . 16784) (LogTime.Report 16786 . 17151) (LogTime.ReportTime 17153 . 17607) ( LogTime.Start 17609 . 18352) (LogTime.Update 18354 . 19643))))) STOP \ No newline at end of file diff --git a/lispusers/LOGTIME.TEDIT b/lispusers/LOGTIME.TEDIT new file mode 100644 index 00000000..07c81b9f Binary files /dev/null and b/lispusers/LOGTIME.TEDIT differ diff --git a/lispusers/LOOKUPINFILES b/lispusers/LOOKUPINFILES new file mode 100644 index 00000000..4578e824 --- /dev/null +++ b/lispusers/LOOKUPINFILES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "23-Feb-89 13:20:33" |{FS8:PARC:XEROX}LISP>LOOKUPINFILES.;20| 32443 changes to%: (FNS Lookup-CacheFile) (VARS LOOKUPINFILESCOMS) previous date%: "23-Feb-89 09:48:41" |{FS8:PARC:XEROX}LISP>LOOKUPINFILES.;19|) (* " Copyright (c) 1986, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOOKUPINFILESCOMS) (RPAQQ LOOKUPINFILESCOMS ( (* ;;; "Fast lookup in files") (LOCALVARS . T) (SPECVARS PROMPTWINDOW) (FNS AddFileToList DeleteFileFromList Lookup-CacheFile Lookup-CacheFiles Lookup-EditFile Lookup-KillProcess Lookup-MakeIconWindow Lookup-RecacheFile Lookup-RightbuttonFn Lookup-CacheFile Lookup-RightbuttonFn Lookup-StartProcess Lookup-TitleMenuFn Lookup-WhenClosedFn Lookup-WhenOpenedFn LookupAttachedMenu LookupString MakeLookupWindow ShowLookUpString) (FUNCTIONS Lookup-Notify busy-protect) (VARS *LookupPrompt* DEFAULT-LOOKUP-BITMAP DEFAULT-LOOKUP-MASK (LOOKUP-DEFAULT-EDITREGION (CREATEREGION 300 300 400 200)) (LOOKUP-DEFAULT-ICONPOSITION (CREATEPOSITION 300 300))) (GLOBALVARS *LookupPrompt* DEFAULT-LOOKUP-BITMAP DEFAULT-LOOKUP-MASK LOOKUP-DEFAULT-EDITREGION LOOKUP-DEFAULT-ICONPOSITION) (DECLARE%: DONTCOPY (RECORDS Lookup-CacheRecord)))) (* ;;; "Fast lookup in files") (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS PROMPTWINDOW) ) (DEFINEQ (AddFileToList [LAMBDA (WINDOW) (* ; "Edited 26-Jan-89 10:24 by dgb:") (LET* (entry fullname (OLD.TTYPROCESS (TTY.PROCESS (THIS.PROCESS))) (OLDDISPLAYSTREAM (TTYDISPLAYSTREAM WINDOW))) (busy-protect WINDOW "adding file to list" (LET ((fileName (TTYIN "New File: " NIL NIL '(STRING NORAISE) NIL NIL NIL NIL))) (TTY.PROCESS T) (Lookup-Notify WINDOW T "Trying to add " fileName T) (COND ((SETQ fullname (FULLNAME fileName)) [WINDOWPROP WINDOW 'FileList (CONS fileName (WINDOWPROP WINDOW 'FileList] [WINDOWPROP WINDOW 'CacheForFiles (CONS (SETQ entry (create Lookup-CacheRecord fileName _ fullname originalFileName _ fileName)) (WINDOWPROP WINDOW 'CacheForFiles] (Lookup-CacheFile entry WINDOW) (Lookup-Notify WINDOW "Caching done" T)) (fileName (Lookup-Notify WINDOW T fileName " not found." T]) (DeleteFileFromList [LAMBDA (window) (* ; "Edited 26-Jan-89 21:37 by dgb:") (LET* [(ITEMS (WINDOWPROP window 'CacheForFiles] (CL:IF ITEMS [busy-protect window "deleting file from list" (LET* [(CHOSEN (MENU (create MENU ITEMS _ (for ITEM in ITEMS collect (LIST (fetch originalFileName of ITEM) (KWOTE ITEM] (CL:WHEN CHOSEN (WINDOWPROP window 'CacheForFiles (REMOVE CHOSEN ITEMS)) [WINDOWPROP window 'FileList (REMOVE (fetch originalFileName of CHOSEN) (WINDOWPROP window 'FileList])] (Lookup-Notify window "No files"))]) (Lookup-CacheFile [LAMBDA (entry msgStream window) (* ; "Edited 23-Feb-89 13:04 by dgb:") (LET* (localFile strm textStream (file (fetch fileName of entry))) (WINDOWPROP window 'lastFileIndex NIL) (WINDOWPROP window 'lastEntryIndex NIL) (CL:WHEN file (SETQ localFile (PACKFILENAME.STRING 'HOST 'NODIRCORE 'VERSION NIL 'BODY file)) (SETQ file (PACKFILENAME 'VERSION NIL 'BODY file)) (Lookup-Notify msgStream "Looking for: " (FILENAMEFIELD file 'NAME) T) (COND ((FINDFILE file) (Lookup-Notify msgStream "Caching: " (FILENAMEFIELD file 'NAME) T) (create Lookup-CacheRecord smashing entry fileName _ file openStream _ (SETQ strm (OPENSTREAM (COPYFILE file localFile) 'INPUT)) textStream _ (SETQ textStream (OPENTEXTSTREAM strm)) textLength _ (fetch TEXTLEN of (TEXTOBJ textStream)) originalFileName _ (fetch originalFileName of entry))) (T (SETQ localFile NIL) (Lookup-Notify msgStream file " not found" T) (create Lookup-CacheRecord smashing entry fileName _ file))))]) (Lookup-CacheFiles [LAMBDA (WINDOW) (* ; "Edited 26-Jan-89 21:09 by dgb:") (* ;;; "Cache the files in core") (busy-protect WINDOW "caching files." (LET* [(CACHE NIL) (OLDCACHE (WINDOWPROP WINDOW 'CacheForFiles)) (FILELIST (CL:IF OLDCACHE (for ITEM in OLDCACHE collect (fetch originalFileName of ITEM)) (WINDOWPROP WINDOW 'FileList))] (WINDOWPROP WINDOW 'FileList FILELIST) (WINDOWPROP WINDOW 'CacheForFiles NIL) (Lookup-Notify WINDOW T "Caching files in core..." T) [for file in FILELIST do (LET ((FULLNAME (FULLNAME file))) (if FULLNAME then (CL:PUSH (create Lookup-CacheRecord fileName _ FULLNAME originalFileName _ file) CACHE) else (Lookup-Notify WINDOW file " not found" T] (for entry in CACHE do (Lookup-CacheFile entry WINDOW WINDOW)) (Lookup-Notify WINDOW T "Caching done" T) (WINDOWPROP WINDOW 'CacheForFiles (REVERSE CACHE]) (Lookup-EditFile [LAMBDA (window) (* ; "Edited 26-Jan-89 15:53 by dgb:") (LET* [[file (COND [(WINDOWPROP window 'lastFileIndex) (CAR (NTH (WINDOWPROP window 'FileList) (WINDOWPROP window 'lastFileIndex] (T (LET [(ITEMS (WINDOWPROP window 'CacheForFiles] (CL:IF ITEMS [MENU (create MENU ITEMS _ (for ITEM in ITEMS collect (LIST (fetch originalFileName of ITEM) (KWOTE (fetch fileName of ITEM] (PROGN (Lookup-Notify window "No files") NIL))] [w (AND file (TEDIT (MKATOM file] (n (WINDOWPROP window 'lastEntryIndex] (AND file n (TEDIT.NORMALIZECARET w (TEDIT.SETSEL w n 0))) w]) (Lookup-KillProcess [LAMBDA (WINDOW) (* ; "Edited 23-Nov-88 13:03 by dgb:") (* ;;; "Kill the lookup process associated with the window") (LET* [(PROMPT (GETPROMPTWINDOW WINDOW)) (PROC (WINDOWPROP PROMPT 'PROCESS] (WINDOWPROP PROMPT 'PROCESS NIL) (WINDOWPROP WINDOW 'lookupProcess NIL) (COND ((PROCESSP PROC) (AND (TTY.PROCESSP PROC) (TTY.PROCESS T)) (DEL.PROCESS PROC) (PROCESSPROP PROC 'PROCWINDOW NIL]) (Lookup-MakeIconWindow [LAMBDA (window iconBM iconMask iconPosition icontitle)(* ; "Edited 26-Jan-89 15:33 by dgb:") (OR iconBM (SETQ iconBM DEFAULT-LOOKUP-BITMAP) (SETQ iconMask DEFAULT-LOOKUP-MASK)) (LET [(ICONWINDOW (COND (icontitle (TITLEDICONW (create TITLEDICON ICON _ iconBM MASK _ iconMask TITLEREG _ (CREATEREGION 2 2 (- (BITMAPWIDTH iconBM) 4) 26)) icontitle DEFAULTICONFONT (OR iconPosition LOOKUP-DEFAULT-ICONPOSITION) T)) (T (ICONW iconBM iconMask (OR iconPosition LOOKUP-DEFAULT-ICONPOSITION) T] (* ;;; "Make icon for this window") (WINDOWPROP window 'ICON ICONWINDOW) (WINDOWPROP ICONWINDOW 'CLOSEFN (FUNCTION (LAMBDA (W) (LET [(MAIN (WINDOWPROP W 'ICONFOR] (EXPANDW W]) (Lookup-RecacheFile [LAMBDA (WINDOW) (* ; "Edited 26-Jan-89 21:01 by dgb:") (busy-protect WINDOW "recaching a file." (LET [(index (WINDOWPROP WINDOW 'lastFileIndex] (CLEARW (GETPROMPTWINDOW WINDOW)) (COND (index (Lookup-Notify WINDOW "Recaching" T) (Lookup-CacheFile (CAR (NTH (WINDOWPROP WINDOW 'CacheForFiles) index)) WINDOW WINDOW) (Lookup-Notify WINDOW "Caching done" T) (CL:WHEN (OPENWP WINDOW) (ShowLookUpString (WINDOWPROP WINDOW 'searchString) WINDOW index 0))) (T (Lookup-Notify WINDOW T "No file selected" T]) (Lookup-RightbuttonFn [LAMBDA (W s) (* ; "Edited 26-Jan-89 21:24 by dgb:") (SELECTQ [MENU (create MENU ITEMS _ '(Move Shape Close Redisplay Shrink] (Move (MOVEW W)) (Shape (SHAPEW W)) (Close (CL:IF (PROGN (CLEARW W) (MOUSECONFIRM "Are you sure you want to close this Lookup window? " NIL W T))(PROGN (Lookup-KillProcess W) (CLOSEW W)) (REDISPLAYW W NIL T))) (Redisplay (REDISPLAYW W NIL T)) (Shrink (SHRINKW W)) NIL]) (Lookup-CacheFile [LAMBDA (entry msgStream window) (* ; "Edited 23-Feb-89 13:04 by dgb:") (LET* (localFile strm textStream (file (fetch fileName of entry))) (WINDOWPROP window 'lastFileIndex NIL) (WINDOWPROP window 'lastEntryIndex NIL) (CL:WHEN file (SETQ localFile (PACKFILENAME.STRING 'HOST 'NODIRCORE 'VERSION NIL 'BODY file)) (SETQ file (PACKFILENAME 'VERSION NIL 'BODY file)) (Lookup-Notify msgStream "Looking for: " (FILENAMEFIELD file 'NAME) T) (COND ((FINDFILE file) (Lookup-Notify msgStream "Caching: " (FILENAMEFIELD file 'NAME) T) (create Lookup-CacheRecord smashing entry fileName _ file openStream _ (SETQ strm (OPENSTREAM (COPYFILE file localFile) 'INPUT)) textStream _ (SETQ textStream (OPENTEXTSTREAM strm)) textLength _ (fetch TEXTLEN of (TEXTOBJ textStream)) originalFileName _ (fetch originalFileName of entry))) (T (SETQ localFile NIL) (Lookup-Notify msgStream file " not found" T) (create Lookup-CacheRecord smashing entry fileName _ file))))]) (Lookup-RightbuttonFn [LAMBDA (W s) (* ; "Edited 26-Jan-89 21:24 by dgb:") (SELECTQ [MENU (create MENU ITEMS _ '(Move Shape Close Redisplay Shrink] (Move (MOVEW W)) (Shape (SHAPEW W)) (Close (CL:IF (PROGN (CLEARW W) (MOUSECONFIRM "Are you sure you want to close this Lookup window? " NIL W T))(PROGN (Lookup-KillProcess W) (CLOSEW W)) (REDISPLAYW W NIL T))) (Redisplay (REDISPLAYW W NIL T)) (Shrink (SHRINKW W)) NIL]) (Lookup-StartProcess [LAMBDA (WINDOW) (* ; "Edited 23-Nov-88 13:26 by dgb:") (AND (OPENWP WINDOW) [NOT (PROCESSP (WINDOWPROP (GETPROMPTWINDOW WINDOW) 'PROCESS] (COND ((WINDOWPROP WINDOW 'BUSYACTION) (CLEARW WINDOW) (PRINTOUT WINDOW T "Busy with " (WINDOWPROP WINDOW 'BUSYACTION) T) (* ;; "don't start process") NIL) (T T)) (ADD.PROCESS `(LookupString ,WINDOW) 'NAME (WINDOWPROP WINDOW 'ProcessName) 'WINDOW (GETPROMPTWINDOW WINDOW]) (Lookup-TitleMenuFn [LAMBDA (window) (* ; "Edited 25-Jan-89 09:57 by dgb:") (SELECTQ [MENU (if (WINDOWPROP window 'lastFileIndex) then [LOADTIMECONSTANT (create MENU ITEMS _ '(["Edit file named in window title" 'Edit "Edit file named in window title" (SUBITEMS ("Select file to edit" 'EditFile] ("Add new file" 'AddFile "Add specified file to list") ("Delete file from list" 'DeleteFile "Delete file from those used for lookup" ) ("Recache file named in window title" 'RecacheFile "Recache file named in window title" (SUBITEMS ("Recache all files" 'Recache] else (LOADTIMECONSTANT (create MENU ITEMS _ '(("Select file to edit" 'EditFile "Make choice from current files" ) ("Add new file" 'AddFile "Add specified file to list") ("Delete file from list" 'DeleteFile "Delete file from those used for lookup" ) ("Recache all files" 'Recache] (AddFile (AddFileToList window)) (DeleteFile (DeleteFileFromList window)) (Recache (WINDOWPROP window 'TITLE "") (CLEARW window) (Lookup-CacheFiles window T)) (RecacheFile (Lookup-RecacheFile window)) (Edit (Lookup-EditFile window)) (EditFile (WINDOWPROP window 'lastFileIndex NIL) (WINDOWPROP window 'TITLE "") (Lookup-EditFile window)) NIL]) (Lookup-WhenClosedFn [LAMBDA (window) (* ; "Edited 25-Jan-89 13:34 by dgb:") (* ;;; "Kill the process associated with the window .") (Lookup-KillProcess window) (WINDOWPROP window 'CacheForFiles NIL) (WINDOWPROP window 'OPENFN NIL) window]) (Lookup-WhenOpenedFn [LAMBDA (WINDOW) (* ; "Edited 26-Jan-89 15:56 by dgb:") (* ;;; "The OPENFN for the lookup window") (WINDOWPROP WINDOW 'RIGHTBUTTONFN 'Lookup-RightbuttonFn) (CLEARW (GETPROMPTWINDOW WINDOW)) (Lookup-StartProcess WINDOW]) (LookupAttachedMenu [LAMBDA (ITEM menu button) (* ; "Edited 23-Nov-88 13:05 by dgb:") (LET* [(WINDOW (MAINWINDOW (WFROMMENU menu))) (oldName (WINDOWPROP WINDOW 'searchString] (SELECTQ (CADR ITEM) (NEXT (COND (oldName (Lookup-KillProcess WINDOW) (PRINTOUT (GETPROMPTWINDOW WINDOW) oldName T) (ShowLookUpString (WINDOWPROP WINDOW 'searchString) WINDOW (OR (NUMBERP (WINDOWPROP WINDOW 'lastFileIndex)) 1) (ADD1 (OR (NUMBERP (WINDOWPROP WINDOW 'lastEntryIndex)) -1))) (Lookup-StartProcess WINDOW)))) (SHRINK (SHRINKW WINDOW)) NIL]) (LookupString [LAMBDA (mainWindow) (* ; "Edited 26-Jan-89 19:44 by dgb:") (* ;;; "The main program for the LookupInFiles Program") (OPENW mainWindow) (LET ((w (GETPROMPTWINDOW mainWindow))) (CLEARW w) (TTYDISPLAYSTREAM w) (TTY.PROCESS (THIS.PROCESS)) (bind lookup-string do (WINDOWPROP mainWindow 'RIGHTBUTTONFN 'Lookup-RightbuttonFn) (SETQ lookup-string (RESETVAR TTYINREADMACROS '((19 T CONS)) (TTYIN *LookupPrompt* NIL NIL '(STRING NORAISE) NIL NIL NIL NIL))) (COND ((LISTP lookup-string) (SHRINKW mainWindow) (PROCESS.RETURN)) [(NULL lookup-string) (LET [(oldName (WINDOWPROP mainWindow 'searchString] (if oldName then (PRINTOUT w *LookupPrompt* oldName T) (ShowLookUpString oldName mainWindow (WINDOWPROP mainWindow 'lastFileIndex) (ADD1 (OR (WINDOWPROP mainWindow 'lastEntryIndex) -1] (T (ShowLookUpString lookup-string mainWindow))) until (NOT (OPENWP w]) (MakeLookupWindow [LAMBDA (fileList processName editRegion iconBM iconMask iconPosition iconTitle) (* ; "Edited 25-Jan-89 13:37 by dgb:") (* ;; "Compute defaults") (LET [(window (CREATEMENUEDWINDOW (create MENU CENTERFLG _ T MENUFONT _ '(HELVETICA 12 BOLD) ITEMS _ '(("Shrink" SHRINK "Shrink window to an icon") ("Next Occurrence" NEXT "Find next occurrence of string.")) WHENSELECTEDFN _ (FUNCTION LookupAttachedMenu)) "" 'TOP (OR editRegion LOOKUP-DEFAULT-EDITREGION] (* ;;; "Create Menued window with prompt") (GETPROMPTWINDOW window 2 '(HELVETICA 12 BOLD)) (* ;;; "Create icon") (Lookup-MakeIconWindow window iconBM iconMask iconPosition iconTitle) (* ;;; "Opening starts process, and checks if caching needed") (WINDOWADDPROP window 'OPENFN (FUNCTION Lookup-WhenOpenedFn)) (WINDOWADDPROP window 'EXPANDFN (FUNCTION Lookup-WhenOpenedFn)) (* ;;; "Shrinking and closing kills the process. ") [WINDOWPROP window 'CLOSEFN (CONS (FUNCTION Lookup-KillProcess) (WINDOWPROP window 'CLOSEFN] (WINDOWPROP window 'RIGHTBUTTONFN 'Lookup-RightbuttonFn) [WINDOWPROP window 'SHRINKFN (CONS (FUNCTION Lookup-KillProcess) (WINDOWPROP window 'SHRINKFN] (* ;;; "Fix title menu for this TEDIT window") (OPENTEXTSTREAM "" window NIL NIL '(READONLY T TEDIT.TITLEMENUFN Lookup-TitleMenuFn)) (WINDOWPROP window 'TEDIT.TITLEMENUFN 'Lookup-TitleMenuFn) (* ;;; "Cache FileList in Window") (WINDOWPROP window 'FileList (MKLIST fileList)) (* ;;; "Store name for PSW") (WINDOWPROP window 'ProcessName (OR processName 'Lookup)) (* ;;; "This should be default for attached window") (for w1 in (ALLATTACHEDWINDOWS window) do (WINDOWPROP w1 'PASSTOMAINCOMS T) (WINDOWPROP w1 'RIGHTBUTTONFN 'NILL)) [ADD.PROCESS `(Lookup-CacheFiles ,window] (SHRINKW window) window]) (ShowLookUpString [LAMBDA (name-or-string window lst-index start-pos) (* ; "Edited 22-Nov-88 15:10 by dgb:") (OR lst-index (SETQ lst-index 1)) (OR start-pos (SETQ start-pos 0)) (WINDOWPROP window 'searchString name-or-string) (for elt in (NTH (WINDOWPROP window 'CacheForFiles) lst-index) as file-index from lst-index bind pos openStream sel textStream when (SETQ openStream (fetch openStream of elt)) do (if (NOT (OPENP openStream)) then (OPENSTREAM openStream 'INPUT) (WINDOWPROP window 'lastFileIndex NIL)) (if (SETQ pos (FILEPOS name-or-string openStream start-pos (fetch textLength of elt) NIL NIL UPPERCASEARRAY)) then (WINDOWPROP window 'lastEntryIndex pos) (SETQ sel (TEDIT.SETSEL (SETQ textStream (fetch textStream of elt)) (ADD1 pos) (NCHARS name-or-string))) [if (EQP file-index (WINDOWPROP window 'lastFileIndex)) then (TEDIT.NORMALIZECARET textStream sel) else (WINDOWPROP window 'TITLE (CONCAT "Looking in: " (fetch fileName of elt))) (WINDOWPROP window 'lastFileIndex file-index) (OPENTEXTSTREAM textStream window NIL NIL '(READONLY T] (RETURN (PROG1 (TEDIT.SET.SEL.LOOKS sel 'PENDINGDEL) (TEDIT.SHOWSEL textStream T sel))) else (SETQ start-pos 0)) finally (WINDOWPROP window 'lastFileIndex NIL) (WINDOWPROP window 'lastEntryIndex NIL) (WINDOWPROP window 'TITLE "") (TEDIT.SETSEL (OPENTEXTSTREAM (CONCAT name-or-string " not found.") window NIL NIL '(READONLY T)) 1 (NCHARS name-or-string) 'RIGHT T]) ) (DEFMACRO Lookup-Notify (WINDOW &REST BODY) `(PRINTOUT (OR (OPENWP ,WINDOW) PROMPTWINDOW) . ,BODY)) (DEFMACRO busy-protect (WINDOW NEW-BUSY-ACTION body-form unwind-form) `(CL:UNLESS (WINDOWPROP ,WINDOW 'BUSYACTION) (CL:UNWIND-PROTECT (PROGN (WINDOWPROP ,WINDOW 'BUSYACTION ,NEW-BUSY-ACTION) (AND (OPENWP ,WINDOW) (CLEARW ,WINDOW)) (Lookup-KillProcess ,WINDOW) ,body-form) ,unwind-form (WINDOWPROP ,WINDOW 'BUSYACTION NIL) (Lookup-StartProcess ,WINDOW)))) (RPAQQ *LookupPrompt* "Lookup String: ") (RPAQQ DEFAULT-LOOKUP-BITMAP #*(62 92)OOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLN@@@@@@@@@@@@@ALL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@OOH@@@@@@@@@LL@COON@@@@@@@@@LL@GOOO@@@@@@@@@LL@OOOOH@@@@@@@@LLAOOOOL@@@@@@@@LLAOOOOL@@@@@@@@LLAOOOOL@@@@@@@@LLCOOOON@@@@@@@@LLCOOOON@@@@@@@@LLCOOOON@@@@D@@@LLCOOOON@@@@N@A@LLCOOOON@@@AO@C@LLCOOOON@@@COHG@LLCOOOON@@@GOLO@LLAOOOOL@@@OONO@LLAOOOOL@@AOOOG@LLAOOOOL@@COOOK@LL@OOOOH@@GOOOM@LL@GOOO@@@OOOOO@LL@COON@@AOOOOO@LL@@OOH@@COOOON@LL@L@@@@@GOOOOL@LL@N@@@@@GOOOOH@LL@OON@@@COOOO@@LL@OOO@@@AOOON@@LL@OOOH@@@OOOL@@LL@OOOL@@@GOOH@@LL@OOON@@@COO@@@LL@OOOO@@@AON@@@LL@OOOOH@@@OL@@@LL@OOOOL@@NGH@@@LL@OOOON@AOC@@@@LL@OOOOO@COH@@@@LL@OOOOOHGOH@@@@LL@OOOOOLOOH@@@@LL@OOOOOOOO@@@@@LL@OOOOOOON@@@@@LL@OOOOOOOL@@@@@LL@OOOOOOOH@@@@@LL@OOONOOO@@@@@@LL@OOONGON@@@@@@LL@OOONCOL@@@@@@LL@OOONAOH@@@@@@LL@OOON@O@@@@@@@LL@GOON@F@@@@@@@LL@COON@@@@@@@@@LL@AOON@@@@@@@@@LL@@OON@@@@@@@@@LL@@GON@@@@@@@@@LL@@CON@@@@@@@@@LL@@AON@@@@@@@@@LL@@@ON@@@@@@@@@LL@@@GN@@@@@@@@@LL@@@CN@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LL@@@@@@@@@@@@@@LOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOL ) (RPAQQ DEFAULT-LOOKUP-MASK #*(62 92)OOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOLOOOOOOOOOOOOOOOL ) (RPAQ LOOKUP-DEFAULT-EDITREGION (CREATEREGION 300 300 400 200)) (RPAQ LOOKUP-DEFAULT-ICONPOSITION (CREATEPOSITION 300 300)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *LookupPrompt* DEFAULT-LOOKUP-BITMAP DEFAULT-LOOKUP-MASK LOOKUP-DEFAULT-EDITREGION LOOKUP-DEFAULT-ICONPOSITION) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD Lookup-CacheRecord (fileName openStream textStream textLength originalFileName)) ) ) (PUTPROPS LOOKUPINFILES COPYRIGHT ("Xerox Corporation" 1986 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1646 28175 (AddFileToList 1656 . 3004) (DeleteFileFromList 3006 . 4253) ( Lookup-CacheFile 4255 . 6155) (Lookup-CacheFiles 6157 . 7720) (Lookup-EditFile 7722 . 8986) ( Lookup-KillProcess 8988 . 9569) (Lookup-MakeIconWindow 9571 . 11063) (Lookup-RecacheFile 11065 . 12499 ) (Lookup-RightbuttonFn 12501 . 13125) (Lookup-CacheFile 13127 . 15027) (Lookup-RightbuttonFn 15029 . 15653) (Lookup-StartProcess 15655 . 16371) (Lookup-TitleMenuFn 16373 . 19425) (Lookup-WhenClosedFn 19427 . 19745) (Lookup-WhenOpenedFn 19747 . 20061) (LookupAttachedMenu 20063 . 21060) (LookupString 21062 . 22675) (MakeLookupWindow 22677 . 25299) (ShowLookUpString 25301 . 28173))))) STOP \ No newline at end of file diff --git a/lispusers/LOOKUPINFILES.TEDIT b/lispusers/LOOKUPINFILES.TEDIT new file mode 100644 index 00000000..ee696b23 Binary files /dev/null and b/lispusers/LOOKUPINFILES.TEDIT differ diff --git a/lispusers/LUPINE b/lispusers/LUPINE new file mode 100644 index 00000000..174e1204 --- /dev/null +++ b/lispusers/LUPINE @@ -0,0 +1 @@ +(FILECREATED "30-Jun-86 16:38:25" {PHYLUM}RPC>LUPINE.;1 57734 changes to: (FNS \MakeUnmarshalRecord) previous date: " 1-Aug-85 12:16:27" {PHYLUM}KOTO>LISPUSERS>LUPINE.;1) (* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT LUPINECOMS) (RPAQQ LUPINECOMS [(DECLARE: DONTCOPY (RECORDS ArgSpec Fragment FunctionSpec FieldSpec LupineType RecordLayout TypeSpec)) (* Basic stub construction) (FNS Lupine \ServerComs \MakeUnmarshal \MakeUnmarshal1 \MakeUnmarshalRecord \FixedFetch \MakeArgsUnmarshal \ClientComs \MakeMarshal \MakeMarshal1 \MakeMarshalRecord \FixedStore \MakeArgsMarshal) (* Checking of declarations) (FNS \CheckSpec \CheckType \CheckType1 \CheckRecordDecl) (* Type table construction) (FNS \DeclareTypes \Allocate \AllocateRecord) (* Utilities) (FNS \TypeName \BaseType \TypeLayout \TypeSize \LupineNotFixed \StaticsFirst \IsStatic) (VARS \LupineGetFns \LupinePutFns \LupinePrimativeTypes \LupineInitialTypeTable \LupineNumberTypes \LupineNotFixedTypes \LupineDummyTypes \LupineStatics \LupineTypesWithParm) (GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm \LupinePrimativeTypes \LupineDummyTypes \LupineNotFixedTypes \LupineNumberTypes \LupineInitialTypeTable) (DECLARE: DONTCOPY (CONSTANTS (\FirstLupineUserCall 4) (\FirstLupineSignal 4]) (DECLARE: DONTCOPY [DECLARE: EVAL@COMPILE (RECORD ArgSpec (argName argType)) (RECORD Fragment (fixed . notFixed)) (RECORD FunctionSpec (fn . specs)) (RECORD FieldSpec (fieldName fieldType)) (RECORD LupineType (typeName . typeParm)) (RECORD RecordLayout (need . fields)) (RECORD TypeSpec (type typeType definedStubs typeSize . typeBits)) ] ) (* Basic stub construction) (DEFINEQ (Lupine [LAMBDA (packageName functionSpecList signalSpecList typeList lupineTypeString noServer noClient) (* ht: "31-Jul-85 11:47") (if (NOT (LITATOM packageName)) then (ERROR "package name must be an atom" packageName)) (if (AND functionSpecList (NLISTP functionSpecList)) then (ERROR "function spec must be a list" functionSpecList)) (if (AND signalSpecList (NLISTP signalSpecList)) then (ERROR "signal spec must be a list" signalSpecList)) (if (AND typeList (NLISTP typeList)) then (ERROR "type declarations must be a list" typeList)) (if (NOT lupineTypeString) then (printout T "type string defaulted to " [lupineTypeString_(MKSTRING (PACK (LIST packageName (GDATE) (ETHERHOSTNUMBER] T)) (if (NOT (STRINGP lupineTypeString)) then lupineTypeString_(MKSTRING lupineTypeString)) (RESETLST (RESETSAVE DFNFLG T) (LET ((typeTable (\DeclareTypes typeList)) sName cName) (for s in functionSpecList do (\CheckSpec s typeTable)) (for s in signalSpecList do (\CheckSpec s typeTable T)) [if (NOT noServer) then (SET sName_(PACK (LIST (U-CASE packageName) 'SERVERCOMS)) (\ServerComs packageName functionSpecList signalSpecList typeTable lupineTypeString)) (ADDFILE (PACK (LIST (U-CASE packageName) 'SERVER] [if (NOT noClient) then (SET cName_(PACK (LIST (U-CASE packageName) 'CLIENTCOMS)) (\ClientComs packageName functionSpecList signalSpecList typeTable lupineTypeString)) (ADDFILE (PACK (LIST (U-CASE packageName) 'CLIENT] (CONS sName cName]) (\ServerComs [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString) (* ht: " 1-Aug-85 12:13") (DECLARE (SPECVARS $packageName$)) (LET ($fns$ dfn iName selTerms $rNames$ catchTerms labelTerms movds hideFn loads) (DECLARE (SPECVARS $fns$ $rNames$)) (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here) $fns$_(NCONC (bind (i _ \FirstLupineUserCall) argNames nameMap rec rfl fn argSets end result for spec in functionSpecList unless (spec:fn= '*) collect [fn_(PACK (LIST spec:fn 'ServerStub] [argNames_(for aSpec in spec:specs as i from 1 until (if (U-CASE aSpec:argName)= 'RETURNS then result_aSpec) collect (CDAR (push nameMap (CONS aSpec:argName (PACK* 'l..arg i] [argSets_(for aSpec in (\StaticsFirst spec:specs typeTable) collect (LIST 'SETQ (CDR (ASSOC aSpec:argName nameMap)) (\MakeUnmarshal aSpec:argType spec:fn aSpec:argName typeTable] (end_(if result then (\MakeArgsMarshal result:argType fn 'RESULT 'l..result typeTable))) [APPLY* (FUNCTION DEFINEQ) (BQUOTE (, fn (l..cPup l..conv) (* Lupine generated stub) (DECLARE (SPECVARS l..cPup l..conv)) (PROG (l..result ,. argNames) ,. argSets (SETQ l..result (, (fetch fn of spec) ,. argNames)) (\StartReturn l..cPup) ,. end (RETURN l..cPup] [selTerms_(NCONC1 selTerms (BQUOTE (, i (, fn l..pup l..conv] (push movds (CONS spec:fn (CONS (PACK* 'Hidden. spec:fn) fn))) (add i 1) fn) $fns$) dfn_(PACK (LIST $packageName$ 'ServerDispatch)) (if signalSpecList then (bind (j _ \FirstLupineSignal) cName specs resultSpec margs umres for sSpec in signalSpecList unless (sSpec:fn= '*) do (specs_sSpec:specs) (margs_(if (U-CASE specs:1:argName)= 'ARGS then (\MakeArgsMarshal (pop specs):argType sSpec:fn 'SIGARGS 'arg typeTable))) (if (U-CASE specs:1:argName)= 'RETURNS then umres_(\MakeArgsUnmarshal specs:1:argType sSpec:fn 'RESULT typeTable)) [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, [SETQ cName (PACK (LIST 'Catch (fetch fn of sSpec] (arg l..conv) (* Lupine generated signal catcher) (DECLARE (USEDFREE l..cPup)) (\StartSignal l..cPup) (\AddPupWord l..cPup , j) ., margs (SETQ l..cPup (\Call l..cPup NIL l..conv)) , umres] [catchTerms_(NCONC catchTerms (APPEND (BQUOTE (, (fetch fn of sSpec)=> (sresume (, cName arg l..conv] (add j 1))) (* * the (, (QUOTE enable)) is to keep the form from being prettyprinted) [APPLY* (FUNCTION DEFINEQ) (BQUOTE (, dfn (l..pup request l..conv) (* Lupine generated dispatcher) (, 'enable ., catchTerms (SELECTQ request ., selTerms (SHOULDNT)) ., labelTerms] (push $fns$ dfn) iName_(PACK (LIST $packageName$ 'ServerInterface)) (if (NOT (BOUNDP iName)) then (SET iName NIL)) [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, (PACK (LIST 'Unexport $packageName$)) NIL (* Lupine generated interface) [UnexportInterface (OR , iName (ERROR "not exported" (QUOTE , $packageName$] (SETQ , iName NIL] [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, (PACK (LIST 'Export $packageName$)) (type instance version user password) (* Lupine generated interface) (if , iName then (ERROR "Already exported" (QUOTE , $packageName$))) (SETQ , iName (ExportInterface user password (OR type , lupineTypeString) instance version (FUNCTION , dfn] [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, [SETQ hideFn (PACK (LIST 'Hide $packageName$ 'ServerMovds] NIL (* Lupine generated utility) (for p in (QUOTE , movds) do (PUTD (CADR p) (GETD (CAR p))) (PUTD (CAR p)) (CHANGENAME (CDDR p) (CAR p) (CADR p] [LET [(files (NCONC1 (bind wh res for r in $rNames$ when (if wh_(WHEREIS r 'RECORDS) else (printout T T "Note - the record " r " is not on any known file" T)) do (pushnew res wh:1) finally (RETURN res)) 'SIGNAL] loads_(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP) ., files] (BQUOTE ( (* Created by Lupine , (GDATE)) (FNS ,. $fns$) (VARS (, iName)) (GLOBALVARS , iName) ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD) RPC)) (P (COND ((EQ 'Y (ASKUSER 15 'N "Hide server fns (must have been already loaded)? ")) (, hideFn]) (\MakeUnmarshal [LAMBDA (type fn name typeTable pupName) (* ht: " 1-Aug-85 08:57") (if type then (if (NOT pupName) then pupName_ 'l..cPup) (LET (fragment) fragment_(\MakeUnmarshal1 type fn name typeTable 0 16 pupName) (if NOT (fragment:notFixed) then fragment:fixed else (BQUOTE (LET ((l..datum , (fetch fixed of fragment))) ., (fetch notFixed of fragment) l..datum]) (\MakeUnmarshal1 [LAMBDA (type fn name typeTable whereAreWe size pupName) (* ht: " 1-Aug-85 09:09") (LET ((typeName (\TypeName type)) (typeParm (if (LISTP type) then type:typeParm)) afn typeSpec) (SELECTQ typeName ((RECORD SEQRECORD) (SHOULDNT)) [LIST (create Fragment fixed _(BQUOTE (PROGN (SETQ , pupName (\CheckPupExhausted , pupName 2)) (for l..i from 1 to (\GetArgDblWord , pupName l..conv) collect , (\MakeUnmarshal (CAR typeParm) fn name typeTable pupName] [REF (* no-op except for SEQRECORDs) (LET ((trueType (\BaseType typeParm:1 typeTable)) typeSpec) (if (AND (LISTP trueType) trueType:typeName= 'SEQRECORD) then (* * have to back up one) (\MakeUnmarshalRecord (OR typeSpec_(for tte in typeTable thereis tte:typeType=trueType) (SHOULDNT)) fn name typeTable whereAreWe (if size=16 then typeSpec:typeSize else (SHOULDNT)) pupName) else (create Fragment fixed _(LET [(nilCheck (BQUOTE (\GetArgBool , pupName l..conv] [if pupName= 'l..pup then nilCheck_(BQUOTE (PROG1 , nilCheck (SETQ l..pup l..cPup] (BQUOTE (if , nilCheck then NIL else , (\MakeUnmarshal (CAR typeParm) fn name typeTable pupName] [BITS (* Just a bit special) (create Fragment fixed _(if (ILESSP size 16) then (\FixedFetch size type whereAreWe fn name typeTable) elseif whereAreWe~=0 then (HELP "bad layout") elseif (ILEQ typeParm:1 16) then (* * note that even if we get here with a BITS record of <16 size, we just get a whole word) (BQUOTE (\GetArgWord , pupName l..conv)) elseif typeParm:1=32 then (* closest we get to LONG CARDINAL) (BQUOTE (\GetArgDblWord , pupName l..conv)) else (SHOULDNT] (if (FMEMB typeName \LupinePrimativeTypes) then (if (ILESSP size 16) then (create Fragment fixed _(\FixedFetch size type whereAreWe fn name typeTable)) elseif whereAreWe~=0 then (HELP "bad layout") elseif afn_(CDR (ASSOC typeName \LupineGetFns)) then (* * note that even if we get here with a BITS record of <16 size, we just get a whole word courtesy of the GetFns  table entry) [create Fragment fixed _(LET [(sr (BQUOTE (, afn , pupName ., (if typeParm then (LIST (KWOTE typeParm))) l..conv] (if pupName= 'l..cPup then sr else (BQUOTE (PROG1 , sr (SETQ l..pup l..cPup] else (SHOULDNT)) elseif typeSpec_(ASSOC typeName typeTable) then (if typeSpec:typeType:type= 'RECORD then (\MakeUnmarshalRecord typeSpec fn name typeTable whereAreWe (if (AND size=16 (IGREATERP typeSpec:typeSize 16)) then typeSpec:typeSize else size) pupName) else (\MakeUnmarshal1 typeSpec:typeType fn name typeTable whereAreWe size pupName)) else (ERROR "Invalid spec" (LIST fn name type]) (\MakeUnmarshalRecord [LAMBDA (spec fn name typeTable startBit bitWidth pupName) (* smL "30-Jun-86 16:17") (LET ((fnName (PACK* (QUOTE Unmarshal) $packageName$ (fetch type of spec) (QUOTE %#) startBit (QUOTE %#) bitWidth)) (bits (fetch typeBits of spec)) (seq? (EQ (fetch typeName of (fetch typeType of spec)) (QUOTE SEQRECORD))) fetches createExpr indirects umc notFixed someNot res seqSpec seqEltFetch seqSubSpec seqStatic? leftOver) [if (NOT (FMEMB fnName (fetch definedStubs of spec))) then (push $rNames$ (fetch type of spec)) (if (ILESSP (fetch typeSize of spec) bitWidth) then (SETQ bits (CONS (IPLUS (CAR bits) (DIFFERENCE bitWidth (fetch typeSize of spec))) (CDR bits))) elseif (AND (IGREATERP (fetch typeSize of spec) bitWidth) (NOT (ZEROP startBit))) then (HELP "bad layout")) [SETQ fetches (bind (whereAreWe _ startBit) (nFixed _ 0) last for field in (fetch typeParm of (fetch typeType of spec)) as size in bits join (if (AND (LISTP (fetch fieldType of field)) (EQ (fetch typeName of (fetch fieldType of field)) (QUOTE SEQUENCE))) then (if seq? then (SETQ seqSpec field) [SETQ seqSubSpec (CAR (fetch typeParm of (fetch fieldType of field] (* * * This should be a call to \MakeUnmarshal1, but because of a CEDAR Lupine bug, is not  (see below for more discussion) - If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltFetch (\MakeUnmarshal1 seqSubSpec fn name  typeTable whereAreWe size (QUOTE l..pup)))) [SETQ seqEltFetch (\MakeUnmarshal seqSubSpec fn name typeTable (if (SETQ seqStatic? (\IsStatic seqSubSpec typeTable)) then (QUOTE l..pup) else (QUOTE l..cPup] else (SHOULDNT)) NIL elseif (\LupineNotFixed field typeTable) then (add nFixed 1) (SETQ someNot T) NIL else (SETQ umc (\MakeUnmarshal1 (fetch fieldType of field) fn name typeTable whereAreWe size (QUOTE l..pup))) [if (fetch notFixed of umc) then (SETQ notFixed (NCONC1 notFixed (BQUOTE (LET ((l..datum (fetch (, (fetch type of spec) , (fetch fieldName of field)) of l..datum))) ., (fetch notFixed of umc] (SETQ umc (fetch fixed of umc)) (SETQ whereAreWe (LOGAND 15 (IPLUS whereAreWe size))) (if (NOT (ZEROP nFixed)) then (SETQ umc (BQUOTE (PROGN (SETQ l..pup (\SkipWordsIn l..pup , (LLSH nFixed 1))) , umc))) (SETQ nFixed 0)) (SETQ last (LIST (fetch fieldName of field) (QUOTE _) umc))) finally (if (NOT (ZEROP nFixed)) then (SETQ leftOver (BQUOTE (SETQ l..pup (\SkipWordsIn l..pup , (LLSH nFixed 1] (SETQ createExpr (BQUOTE (create , (fetch type of spec) ., fetches))) [if leftOver then (SETQ createExpr (BQUOTE (PROG1 , createExpr , leftOver] (if someNot then [SETQ indirects (for field in (fetch typeParm of (fetch typeType of spec)) when (\LupineNotFixed field typeTable) collect (SETQ umc (\MakeUnmarshal (fetch fieldType of field) fn name typeTable (QUOTE l..cPup))) (BQUOTE (replace (, (fetch type of spec) , (fetch fieldName of field)) of l..datum with , umc] (SETQ notFixed (NCONC notFixed indirects))) (SETQ createExpr (if seq? then [LET (prelim term f nf) (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in  fact as CEDAR Lupine stands if a sequence's element type has any non-static parts, the WHOLE element gets repeated. There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if  statement which follows this comment with this code: (if (fetch notFixed of seqEltFetch) then  (SETQ f (fetch fixed of seqEltFetch)) (SETQ nf (fetch notFixed of seqEltFetch)) elseif (\LupineNotFixed  (fetch fieldType of seqSpec) typeTable) then (SETQ prelim (BQUOTE (first (\SkipWordsIn l..pup  (LLSH size 1))))) (SETQ nf (fetch fixed of seqEltFetch)) else (SETQ f (fetch fixed of seqEltFetch)))) (if seqStatic? then (SETQ f seqEltFetch) else [SETQ prelim (BQUOTE (first (\SkipWordsIn l..pup (ITIMES , (LRSH (\TypeSize seqSubSpec typeTable) 4) l..size] (SETQ nf seqEltFetch)) [if nf then [SETQ term (if f then (BQUOTE (LET ((l..datum (CAR l..p))) ., nf)) else (BQUOTE (RPLACA l..p , nf] (SETQ notFixed (NCONC1 notFixed (BQUOTE (for l..p on (fetch (, (fetch type of spec) , (fetch fieldName of seqSpec)) of l..datum) do , term] (BQUOTE ((SETQ l..pup (\CheckPupExhausted l..pup 3)) (if (\GetArgBool l..pup l..conv) then NIL else (LET ((l..size (\GetArgDblWord l..pup l..conv))) (bind (l..result _ , createExpr) ., prelim for l..i from 1 to l..size collect , f finally (replace (, (fetch type of spec) , (fetch fieldName of seqSpec)) of l..result with $$VAL) (RETURN l..result] else (LIST createExpr))) [if (AND seq? notFixed) then (SETQ notFixed (LIST (BQUOTE (if l..datum then ., notFixed] (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, fnName (l..pup l..conv) (* Lupine generated stub) ., createExpr))) (* * must record the notFixed generated here so they get used if the function gets re-used) (PUT fnName (QUOTE LupineNotFixed) notFixed) (push $fns$ fnName) (push (fetch definedStubs of spec) fnName) else (SETQ notFixed (APPEND (GETP fnName (QUOTE LupineNotFixed] (SETQ res (BQUOTE (, fnName , pupName l..conv))) [if pupName=(QUOTE l..pup) then (* * horrible kludge as our function may have reset l..cPup but our caller won't see that) (SETQ res (LIST (QUOTE PROG1) res (QUOTE (SETQ l..pup l..cPup] (create Fragment fixed _ res notFixed _ notFixed]) (\FixedFetch [LAMBDA (size type whereAreWe fn name typeTable) (* ht: " 1-Aug-85 08:54") (LET ((typeName (\TypeName type)) (typeParm (if (LISTP type) then type:typeParm)) ff bitNum form) (SELECTQ typeName (RECORD (SHOULDNT)) ((BOOLEAN BITS ENUMERATION) (* * compute the field descriptor) bitNum_ (IPLUS (LLSH whereAreWe 4) size-1) (* * make the call to FETCHFIELD) ff_ (BQUOTE (FETCHFIELD '(NIL 0 (BITS ., bitNum)) (\CurrentPupBase l..pup))) form_ (SELECTQ typeName (BITS ff) [ENUMERATION (BQUOTE (CAR (NTH (QUOTE , typeParm) (ADD1 , ff] [BOOLEAN (BQUOTE (NOT (ZEROP , ff] (SHOULDNT)) (if (ZEROP whereAreWe) then (* * need to check there is room in the l..pup) (BQUOTE (PROGN (SETQ l..pup (\CheckPupExhausted l..pup 1)) , form)) elseif (IPLUS whereAreWe size)=16 then (* * must advance the counter) (BQUOTE (PROG1 , form (\IncrDataOffset l..pup 1))) else form)) (SHOULDNT]) (\MakeArgsUnmarshal [LAMBDA (spec fn multTypeName typeTable) (* ht: " 1-Aug-85 08:51") (LET (resultSpec) (if (AND (LITATOM spec) resultSpec_(\BaseType spec typeTable) (LISTP resultSpec) resultSpec:typeName=multTypeName) then (* create the record) (push $rNames$ spec) [NCONC (LIST 'create spec) (for rSpec in (\StaticsFirst resultSpec:typeParm typeTable) join (BQUOTE (, (fetch fieldName of rSpec)_ , (\MakeUnmarshal (fetch fieldType of rSpec) fn (fetch fieldName of rSpec) typeTable] else (\MakeUnmarshal spec fn 'l..result typeTable]) (\ClientComs [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString) (* ht: " 1-Aug-85 09:39") (DECLARE (SPECVARS $packageName$)) (LET ($fns$ dfn selTerms iName cName typeSels $rNames$ sDisp sigTerms movds movdFn result loads) (DECLARE (SPECVARS $fns$ $rNames$)) iName_(PACK (LIST $packageName$ 'ClientInterface)) sDisp_(PACK (LIST 'Dispatch $packageName$ 'Signals)) (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here) $fns$_(NCONC (bind (i _ \FirstLupineUserCall) argNames rec rfl fn argPuts end stubFn for spec in functionSpecList unless spec:fn= '* collect (fn_spec:fn) (stubFn_(PACK (LIST 'RPCClientStub. fn))) (argPuts_(for aSpec in (\StaticsFirst spec:specs typeTable) join (\MakeMarshal aSpec:argType aSpec:argName fn aSpec:argName typeTable))) [argNames_(NCONC (for aSpec in spec:specs until (if (U-CASE aSpec:argName)= 'RETURNS then result_aSpec) collect aSpec:argName) (LIST 'l..interfaceArg 'l..conv] (end_(if result then (\MakeArgsUnmarshal result:argType fn 'RESULT typeTable))) [APPLY* (FUNCTION DEFINEQ) (BQUOTE (, stubFn , argNames (* Lupine generated stub) (PROG [l..cPup (l..interface (OR l..interfaceArg (CAR , iName] (DECLARE (SPECVARS l..cPup)) (SETQ l..cPup (\StartCall (CAR l..interface) (CDR l..interface) l..conv)) (\AddPupWord l..cPup , i l..conv) ,. argPuts (SETQ l..cPup (\Call l..cPup (FUNCTION , sDisp) l..conv)) (RETURN (PROG1 , end (\RELEASE.PUP l..cPup] (push movds (CONS stubFn fn)) (add i 1) stubFn) $fns$) sigTerms_(bind (j _ \FirstLupineSignal) mres umargs specs for sSpec in signalSpecList unless sSpec:fn= '* collect (specs_sSpec:specs) (umargs_(if (U-CASE specs:1:argName)= 'ARGS then (\MakeArgsUnmarshal (pop specs):argType sSpec:fn 'SIGARGS typeTable))) (if (U-CASE specs:1:argName)= 'RETURNS then mres_(\MakeArgsMarshal specs:1:argType sSpec:fn 'RESULT 'l..result typeTable)) (PROG1 (BQUOTE (, j (PROG (l..result) (SETQ l..result (Signal (QUOTE , (fetch fn of sSpec)) , umargs)) (\StartReturn l..cPup) ., mres))) (add j 1))) (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, sDisp (l..cPup l..conv) (* Lupine generated dispatcher) (DECLARE (SPECVARS l..cPup l..conv)) (SELECTQ (\GetArgWord l..cPup l..conv) ., sigTerms (SHOULDNT)) l..cPup))) (push $fns$ sDisp) (if (NOT (BOUNDP iName)) then (SET iName NIL)) [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, (PACK (LIST 'Unimport $packageName$)) (l..interface) (* Lupine generated interface) (if l..interface then (if (FMEMB l..interface , iName) then (UnimportInterface l..interface) (SETQ , iName (DREMOVE l..interface , iName)) else (ERROR "not imported" l..interface)) else (for e in , iName do (UnimportInterface e)) (SETQ , iName NIL] [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, (PACK (LIST 'Import $packageName$)) (type instance version) (* Lupine generated interface) (CAR (push , iName (ImportInterface (OR type , lupineTypeString) instance version] [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, (SETQ movdFn (PACK (LIST 'MovdsFor $packageName$))) NIL (* Lupine generated utility) (for p in (QUOTE , movds) do (PUTD (CDR p) (GETD (CAR p] [if $rNames$ then (LET [(files (bind wh res for r in $rNames$ when (if wh_(WHEREIS r 'RECORDS) else (printout T T "Note - the record " r " is not on any known file" T)) do (pushnew res wh:1) finally (RETURN res] loads_(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP) ., files] (BQUOTE ( (* Created by Lupine , (GDATE)) (FNS ,. $fns$) (VARS (, iName)) (GLOBALVARS , iName) (P (, movdFn)) ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD) RPC]) (\MakeMarshal [LAMBDA (type val fn name typeTable pupName) (* ht: " 1-Aug-85 08:57") (if type then (if (NOT pupName) then pupName_ 'l..cPup) (LET (fragment) fragment_(\MakeMarshal1 type val fn name typeTable 0 16 pupName) (if NOT (fragment:notFixed) then fragment:fixed else (NCONC fragment:fixed (if val~= 'l..datum then [LIST (BQUOTE (LET ((l..datum , val)) ., (fetch notFixed of fragment] else fragment:notFixed]) (\MakeMarshal1 [LAMBDA (type val fn name typeTable whereAreWe size pupName) (* ht: " 1-Aug-85 08:59") (LET ((typeName (\TypeName type)) (typeParm (if (LISTP type) then type:typeParm)) afn typeSpec) (SELECTQ typeName ((RECORD SEQRECORD) (SHOULDNT)) [LIST (create Fragment fixed _(LIST (BQUOTE (PROGN (\CheckPupOverflow , pupName 4) (\AddPupDblWord , pupName (LENGTH , val) l..conv) (for l..v in , val do ., (\MakeMarshal (CAR typeParm) 'l..v fn name typeTable pupName] [REF (* no-op except for SEQRECORDs) (LET ((trueType (\BaseType typeParm:1 typeTable)) typeSpec) (if (AND (LISTP trueType) trueType:typeName= 'SEQRECORD) then (* * have to back up one) (\MakeMarshalRecord (OR typeSpec_(for tte in typeTable thereis tte:typeType=trueType) (SHOULDNT)) val fn name typeTable whereAreWe (if size=16 then typeSpec:typeSize else (SHOULDNT)) pupName) else (create Fragment fixed _(LIST (BQUOTE (if , val then (\AddPupBoolean , pupName NIL l..conv) ., (\MakeMarshal (CAR typeParm) val fn name typeTable pupName) else (\AddPupBoolean , pupName T l..conv] [BITS (create Fragment fixed _(if (ILESSP size 16) then (\FixedStore size type val whereAreWe fn name typeTable) elseif whereAreWe~=0 then (HELP "bad layout") elseif (ILEQ typeParm:1 16) then (* * note that even if we get here with a BITS record of <16 size, we just put a whole word) (LIST (BQUOTE (\AddPupWord , pupName , val l..conv))) elseif typeParm:1=32 then (* closest we get to LONG CARDINAL) (LIST (BQUOTE (\AddPupDblWord , pupName , val l..conv))) else (SHOULDNT] (if (FMEMB typeName \LupinePrimativeTypes) then (if (ILESSP size 16) then (create Fragment fixed _(\FixedStore size type val whereAreWe fn name typeTable)) elseif whereAreWe~=0 then (HELP "bad layout") elseif afn_(CDR (ASSOC typeName \LupinePutFns)) then (* * note that if we get here with a BITS record of <16 size, we just get a whole word courtesy of the PutFns table  entry) [create Fragment fixed _(LIST (BQUOTE (, afn , pupName ., (if typeParm then (LIST (KWOTE typeParm))) , val l..conv] else (SHOULDNT)) elseif typeSpec_(ASSOC typeName typeTable) then (if typeSpec:typeType:type= 'RECORD then (\MakeMarshalRecord typeSpec val fn name typeTable whereAreWe (if (AND size=16 (IGREATERP typeSpec:typeSize 16) ) then typeSpec:typeSize else size) pupName) else (\MakeMarshal1 typeSpec:typeType val fn name typeTable whereAreWe size pupName)) else (ERROR "Invalid spec" (LIST fn name type]) (\MakeMarshalRecord [LAMBDA (spec val fn name typeTable startBit bitWidth pupName) (* ht: " 1-Aug-85 12:16") (LET ((fnName (PACK* 'Marshal $packageName$ spec:type '# startBit '# bitWidth)) (bits spec:typeBits) (seq? spec:typeType:typeName= 'SEQRECORD) seqSpec seqSubSpec seqEltStore seqStatic? stores notFixed indirects mc someNot) [if (NOT (FMEMB fnName spec:definedStubs)) then (push $rNames$ spec:type) (if (ILESSP spec:typeSize bitWidth) then bits_(CONS (IPLUS bits:1 bitWidth-spec:typeSize) bits::1) elseif (AND (IGREATERP spec:typeSize bitWidth) (NOT (ZEROP startBit))) then (HELP "bad layout")) [stores_(bind (whereAreWe _ startBit) (nFixed _ 0) for field in spec:typeType:typeParm as size in bits join (if (AND (LISTP field:fieldType) field:fieldType:typeName= 'SEQUENCE) then (if seq? then (seqSpec_field) (seqSubSpec_field:fieldType:typeParm:1) (* * * This should be a call to \MakeMarshal1 but because of a CEDAR Lupine bug, is not (see below for more  discussion) - If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltStore (\MakeMarshal1 seqSubSpec  (QUOTE l..datum) fn name typeTable whereAreWe size (QUOTE l..pup)))) [seqEltStore_(\MakeMarshal seqSubSpec 'l..datum fn name typeTable (if seqStatic?_(\IsStatic seqSubSpec typeTable) then 'l..pup else 'l..cPup] else (SHOULDNT)) NIL elseif (\LupineNotFixed field typeTable) then (add nFixed 1) (someNot_T) NIL else (mc_(\MakeMarshal1 field:fieldType (BQUOTE (fetch (, (fetch type of spec) , (fetch fieldName of field)) of l..datum)) fn name typeTable whereAreWe size 'l..pup)) [if mc:notFixed then notFixed_(NCONC1 notFixed (BQUOTE (LET ((l..datum (fetch (, (fetch type of spec) , (fetch fieldName of field)) of l..datum))) ., (fetch notFixed of mc] (mc_mc:fixed) (whereAreWe_(LOGAND 15 (IPLUS whereAreWe size))) (if (NOT (ZEROP nFixed)) then (PROG1 (CONS (BQUOTE (\SkipBytesOut l..pup , (LLSH nFixed 2))) mc) nFixed_0) else mc)) finally (if (NOT (ZEROP nFixed)) then $$VAL_(NCONC1 $$VAL (BQUOTE (\SkipBytesOut l..pup , (LLSH nFixed 2] (if someNot then [indirects_(for field in spec:typeType:typeParm when (\LupineNotFixed field typeTable) join (\MakeMarshal field:fieldType (BQUOTE (fetch (, (fetch type of spec) , (fetch fieldName of field)) of l..datum)) fn name typeTable 'l..cPup] (notFixed_(NCONC notFixed indirects))) [if seq? then (LET (code f nf) (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in  fact as CEDAR Lupine stands if a sequence%'s element type has any non-static parts, the WHOLE element gets repeated. There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if  statement which follows this comment with this code: (if (fetch notFixed of seqEltStore) then  (SETQ f (fetch fixed of seqEltStore)) (SETQ nf (fetch notFixed of seqEltStore)) elseif (\LupineNotFixed  (fetch fieldType of seqSpec) typeTable) then (SETQ code (LIST (QUOTE (\SkipBytesOut l..pup (LLSH  (LENGTH l..sequence) 2))))) (SETQ nf (fetch fixed of seqEltStore)) else (SETQ f (fetch fixed of seqEltStore)))) (if seqStatic? then f_seqEltStore else [code_(LIST (BQUOTE (\SkipBytesOut l..pup (ITIMES , (LRSH (\TypeSize seqSubSpec typeTable) 3) (LENGTH l..sequence] (nf_seqEltStore)) [if f then code_(LIST (BQUOTE (for l..datum in l..sequence do ., f] [if nf then notFixed_(NCONC1 notFixed (BQUOTE (for l..datum in (fetch (, (fetch type of spec) , (fetch fieldName of seqSpec)) of l..datum) do ., nf] stores_(BQUOTE ((\CheckPupOverflow l..pup 6) (if l..datum then (LET ((l..sequence (fetch (, (fetch type of spec) , (fetch fieldName of seqSpec)) of l..datum))) (\AddPupBoolean l..pup NIL l..conv) (\AddPupDblWord l..pup (LENGTH l..sequence) l..conv) ., stores ., code) else (\AddPupBoolean l..pup T l..conv] [if (AND seq? notFixed) then notFixed_(LIST (BQUOTE (if l..datum then ., notFixed] (APPLY* (FUNCTION DEFINEQ) (BQUOTE (, fnName (l..pup l..datum l..conv) (* Lupine generated stub) ., stores))) (* * must record the notFixed generated here so they get used if the function gets re-used) (PUT fnName 'LupineNotFixed notFixed) (push $fns$ fnName) (push spec:definedStubs fnName) else notFixed_(APPEND (GETP fnName 'LupineNotFixed] (create Fragment fixed _(LIST (BQUOTE (, fnName , pupName , val l..conv))) notFixed _ notFixed]) (\FixedStore [LAMBDA (size type val whereAreWe fn name typeTable) (* ht: " 1-Aug-85 09:10") (LET ((typeName (\TypeName type)) (typeParm (if (LISTP type) then type:typeParm)) rf bitNum form) (SELECTQ typeName (RECORD (SHOULDNT)) ((BOOLEAN BITS ENUMERATION) (* * compute the field descriptor) bitNum_ (IPLUS (LLSH whereAreWe 4) size-1) (* * make the call to FETCHFIELD) form_ (SELECTQ typeName (BITS val) [ENUMERATION (BQUOTE (for l..i from 0 as l..t in (QUOTE , typeParm) do (if (EQ l..t , val) then (RETURN l..i)) finally (Signal 'BoundsCheck (CONS , val (QUOTE , typeParm] (BOOLEAN (BQUOTE (if , val then 1 else 0))) (SHOULDNT)) rf_ (BQUOTE (REPLACEFIELD '(NIL 0 (BITS ., bitNum)) (\CurrentPupPosition l..pup) , form)) (if (ZEROP whereAreWe) then (* * need to check there is room in the l..pup) (BQUOTE ((\CheckPupOverflow l..pup 2) , rf)) elseif (IPLUS whereAreWe size)=16 then (* * must advance the counter - must use LIST here because BQUOTE causes NCONC problems) (LIST rf '(\IncrPupLength l..pup 2)) else (LIST rf))) (SHOULDNT]) (\MakeArgsMarshal [LAMBDA (spec fn multTypeName varName typeTable) (* ht: "31-Jul-85 11:44") (LET (resultSpec) (if (AND (LITATOM spec) resultSpec_(\BaseType spec typeTable) (LISTP resultSpec) resultSpec:typeName=multTypeName) then (* unpack a record) (push $rNames$ spec) (for rBit in (\StaticsFirst resultSpec:typeParm typeTable) join (\MakeMarshal rBit:fieldType (BQUOTE (fetch (, spec , (fetch fieldName of rBit)) of , varName)) fn rBit:fieldName typeTable)) else (\MakeMarshal spec varName fn varName typeTable]) ) (* Checking of declarations) (DEFINEQ (\CheckSpec [LAMBDA (spec typeTable sigFlg) (* ht: "31-Jul-85 11:35") (if (NLISTP spec) then (ERROR "each spec must be a list" spec)) (if spec:fn~= '* then (if (NOT (LITATOM spec:fn)) then (ERROR "the fn/signal of a spec must be an atom" spec:fn)) (if (NLISTP spec:specs) then (if spec:specs then (ERROR "the arg specs of a spec must be a list" spec:specs))) (if (OR spec:specs=NIL (U-CASE spec:specs:1:argName)= 'RETURNS) then (printout T "Note: " spec:fn " has no args" T)) (bind aSpec argsAlready [an _(if (AND (NOT sigFlg) (GETD (fetch fn of spec))) then (ARGLIST (fetch fn of spec] for specP on spec:specs do (if (U-CASE specP:1:argName)= 'RETURNS then (if specP::1 then (ERROR "RETURNS must be the last spec" specP) else (GO $$OUT)) else aSpec_specP:1) (if sigFlg then (if (AND (U-CASE specP:1:argName)= 'ARGS (NOT argsAlready)) then argsAlready_T else (ERROR "first and only arg spec for a signal must be called ARGS")) (\CheckType aSpec typeTable NIL T) else (if an then [if aSpec:argName=an:1 then (pop an) else (ERROR "arg name not right" (CONS aSpec:argName (pop an] else (if (NOT (LITATOM aSpec:argName)) then (ERROR "arg name must be litatom" aSpec)) (if (GETD spec:fn) then (printout T "Note: spec has more arguments than function" , spec:fn , aSpec T))) (\CheckType aSpec typeTable)) finally (if an then (printout T "Note: spec has fewer arguments than function" , spec:fn T))) (LET ((last spec:-1)) (if (U-CASE last:argName)= 'RETURNS then (\CheckType last typeTable NIL T) else (printout T "Note: " spec:fn " has no result" T]) (\CheckType [LAMBDA (spec typeTable inDecl inSpecial inRef inSeq) (* ht: "30-Jul-85 09:01") (\CheckType1 spec (\TypeName spec:argType) (if (LISTP spec:argType) then spec:argType:typeParm) typeTable inDecl inSpecial inRef inSeq]) (\CheckType1 [LAMBDA (spec typeName typeParm typeTable inDecl inSpecial inRef inSeq) (* ht: "31-Jul-85 15:57") (LET (trueType) (if (FMEMB typeName \LupinePrimativeTypes) then (if (FMEMB typeName \LupineTypesWithParm) then (if (NOT typeParm) then (ERROR "Must have type parm for type" spec)) (SELECTQ typeName ((LIST REF SEQUENCE) (if (AND typeName= 'SEQUENCE (NOT inSeq)) then (ERROR "SEQUENCE field can occur only in SEQRECORDs" spec) ) (\CheckType spec:argType typeTable NIL NIL typeName= 'REF)) (BITS (if (NOT (AND (NUMBERP typeParm:1) (IGREATERP typeParm:1 0) (OR (ILEQ typeParm:1 16) typeParm:1=32) typeParm::1=NIL)) then (ERROR "BITS type must have exactly one numeric parameter in [1..16] U [32]" spec))) ((RECORD RESULT SIGARGS) (if (NOT inDecl) then (ERROR "In line RECORDs/RESULTs/SIGARGSs not allowed - must be pre-declared as a named type" spec)) (\CheckRecordDecl spec typeParm) (for fs in typeParm do (\CheckType fs typeTable))) (SEQRECORD (if (NOT inDecl) then (ERROR "In line SEQRECORDs not allowed - must be pre-declared as a named type" spec)) (\CheckRecordDecl spec typeParm) (if [NOT (for fieldSpecPointer on typeParm thereis (PROG1 (if (U-CASE (\TypeName fieldSpecPointer:1:fieldType))= 'SEQUENCE then (if fieldSpecPointer::1 then (ERROR "SEQUENCE must be the last field of a SEQRECORD" spec) else T)) (\CheckType fieldSpecPointer:1 typeTable NIL NIL NIL T] then (ERROR "SEQRECORD must end with a SEQUENCE field" spec)) (if (NOT (FMEMB (\TypeName typeParm:-2:fieldType) \LupineNumberTypes)) then (printout T "Warning - next to last field in SEQRECORD not a numeric type?" , spec))) NIL) elseif typeParm then (ERROR "Shouldnt have type parm for type" spec)) elseif (ASSOC typeName typeTable) then (if typeParm then (ERROR "Shouldnt have type parm for user-defined type" spec)) (trueType_(\BaseType typeName typeTable)) (if (LISTP trueType) then (if (AND (FMEMB trueType:typeName \LupineDummyTypes) (NOT inSpecial)) then (ERROR "Can't use RESULT/SIGARGS except from RETURNS/ARGS spec" spec) elseif (AND trueType:typeName= 'SEQRECORD (NOT inRef)) then (ERROR "Must get to SEQRECORD via a REF, not directly" spec))) else (ERROR "Not a type" spec]) (\CheckRecordDecl [LAMBDA (spec fieldSpecs) (* ht: "30-Jul-85 09:41") (LET ((recFields (RECORDFIELDNAMES spec:fieldName))) (if (NOT recFields) then (ERROR "No record declaration for record type" spec)) (if [NOT (AND (LENGTH recFields)=(LENGTH fieldSpecs) (for fieldSpec in fieldSpecs always (FMEMB fieldSpec:fieldName recFields] then (ERROR "Field names in type declaration don't match up with those of record" (LIST recFields spec]) ) (* Type table construction) (DEFINEQ (\DeclareTypes [LAMBDA (typeDecls) (* ht: "31-Jul-85 14:50") (bind newEntry (typeTable _(APPEND \LupineInitialTypeTable)) allocation for ty in typeDecls unless ty:type= '* do (if (NOT (AND ty:type (LITATOM ty:type))) then (ERROR "type declaration must begin with an atomic type name" ty)) (if (OR NOT (ty:typeType) ty::2) then (ERROR "there must be one and only one type in a type declaration" ty)) (if (U-CASE ty:type)= 'INCLUDE then (if (AND ty:typeType (LITATOM ty:typeType)) then typeTable_(NCONC typeTable (\DeclareTypes (EVALV ty:typeType))) else (ERROR "INCLUDE must be of the form (INCLUDE )" ty)) else (\CheckType ty typeTable T) (newEntry_(create TypeSpec type _ ty:type typeType _ ty:typeType)) (if (NOT (AND (LISTP ty:typeType) (FMEMB (U-CASE ty:typeType:typeName) \LupineDummyTypes))) then (allocation_(\Allocate ty:typeType typeTable)) (newEntry:typeSize_allocation:need) (newEntry:typeBits_allocation:fields)) (push typeTable newEntry)) finally (RETURN typeTable]) (\Allocate [LAMBDA (type typeTable subFlg) (* ht: "29-Jul-85 13:38") (let ((typeName (\TypeName type)) (typeParm (if (LISTP type) then type:typeParm)) res rRes) res_[SELECTQ typeName ((STRING ATOM LIST STREAM ARB FIXP REF SEQUENCE) 32) (SSMALLP 16) ((RECORD SEQRECORD) rRes_ (\AllocateRecord typeName typeParm typeTable) (if subFlg then rRes:need else rRes)) (if (FMEMB typeName \LupinePrimativeTypes) then (let [(need (SELECTQ typeName (BOOLEAN 1) (BITS typeParm:1) [ENUMERATION (IMAX 1 (bind (max _(SUB1 (LENGTH typeParm))) until (ZEROP max) count max_(LRSH max 1] (SHOULDNT] (if (IGREATERP need 16) then (SHOULDNT "Too big") else need)) else (* user defined type) (fetch typeSize of (\TypeLayout typeName typeTable] (if subFlg then (LIST res) else (OR (LISTP res) (create RecordLayout need _ res fields _(LIST res]) (\AllocateRecord [LAMBDA (typeName typeParm typeTable) (* ht: "24-Jul-85 19:33") (bind (bitsLeft _ 16) (wordsUsed _ 0) left sub need for t in typeParm join (sub_(\Allocate t:fieldType typeTable T)) (need_sub:1) (if (IGREATERP need bitsLeft) then (if (ZEROP bitsLeft) then (* * run out - fix it) (add wordsUsed 1) elseif bitsLeft~=16 then (* * expand the leftmost bit of the last thing to fit) (add left:1 bitsLeft) (add wordsUsed 1)) (bitsLeft_16) (if (IGREATERP need 15) then (* * must be some number of words) (add wordsUsed (LRSH need 4)) (need_0) else bitsLeft_bitsLeft-need) else bitsLeft_bitsLeft-need) (left_sub) finally (if (ZEROP bitsLeft) then (add wordsUsed 1) elseif (AND (NOT (ZEROP wordsUsed)) bitsLeft~=16) then (* * only sub-word records are allowed to be not a multiple of 16 - pad) (add left:1 bitsLeft) (add wordsUsed 1)) (RETURN (create RecordLayout need _(if (ZEROP wordsUsed) then 16-bitsLeft else (LLSH wordsUsed 4)) fields _ $$VAL]) ) (* Utilities) (DEFINEQ (\TypeName [LAMBDA (type) (* ht: "26-Jul-85 09:14") (LET ((typen (if (LISTP type) then type:typeName else type))) (if (FMEMB (U-CASE typen) \LupinePrimativeTypes) then (U-CASE typen) else typen]) (\BaseType [LAMBDA (type typeTable) (* ht: "26-Jul-85 09:04") (LET ((typeName (\TypeName type))) (if (FMEMB typeName \LupinePrimativeTypes) then type else (\BaseType (fetch typeType of (\TypeLayout typeName typeTable)) typeTable]) (\TypeLayout [LAMBDA (typeName typeTable) (* ht: "24-Jul-85 11:32") (OR (ASSOC typeName typeTable) (HELP "Type not defined" typeName]) (\TypeSize [LAMBDA (type typeTable) (* ht: "31-Jul-85 09:21") (LET ((typeName (\TypeName type)) entry) (if entry_(ASSOC typeName typeTable) then entry:typeSize elseif (FMEMB typeName \LupineNotFixedTypes) then 32 else 16]) (\LupineNotFixed [LAMBDA (field typeTable) (* ht: "26-Jul-85 09:08") (FMEMB (\TypeName (\BaseType field:fieldType typeTable)) \LupineNotFixedTypes]) (\StaticsFirst [LAMBDA (specs typeTable) (* ht: "25-Jul-85 16:13") (bind nonStatics for s in specs when (if (U-CASE s:argName) ~= 'RETURNS then (if (\IsStatic s:argType typeTable) else (nonStatics_(NCONC1 nonStatics s)) NIL)) collect s finally (RETURN (NCONC $$VAL nonStatics]) (\IsStatic [LAMBDA (type typeTable) (* ht: "26-Jul-85 09:01") (LET* ((trueType (\BaseType type typeTable)) (typeName (\TypeName trueType))) (OR (MEMB typeName \LupineStatics) (AND typeName= 'RECORD (for f in trueType:typeParm always (\IsStatic f:fieldType typeTable]) ) (RPAQQ \LupineGetFns ((SSMALLP . \GetArgSmallp) (FIXP . \GetArgDblWord) (BOOLEAN . \GetArgBool) (STRING . \UnmarshalString) (ATOM . \UnmarshalAtom) (STREAM . \UnmarshalStream) (ENUMERATION . \GetArgEnum) (ARB . \UnmarshalArb))) (RPAQQ \LupinePutFns ((SSMALLP . \AddPupSmallp) (FIXP . \AddPupDblWord) (BOOLEAN . \AddPupBoolean) (STRING . \MarshalString) (ATOM . \MarshalAtom) (STREAM . \MarshalStream) (ENUMERATION . \AddPupEnum) (ARB . \MarshalArb) (BITS . \AddPupWord))) (RPAQQ \LupinePrimativeTypes (SSMALLP FIXP BOOLEAN STRING ATOM STREAM ENUMERATION ARB BITS LIST RECORD RESULT SIGARGS REF SEQRECORD SEQUENCE)) (RPAQQ \LupineInitialTypeTable ((CARDINAL (BITS 16) NIL 16 16) (* the next is not true, but is as close as we get) (LONGCARDINAL (BITS 32) NIL 32 32))) (RPAQQ \LupineNumberTypes (FIXP SSMALLP ENUMERATION BITS)) (RPAQQ \LupineNotFixedTypes (STRING ATOM STREAM ARB LIST REF)) (RPAQQ \LupineDummyTypes (RESULT SIGARGS)) (RPAQQ \LupineStatics (SSMALLP FIXP BOOLEAN ENUMERATION BITS)) (RPAQQ \LupineTypesWithParm (ENUMERATION BITS LIST REF SEQRECORD SEQUENCE RECORD RESULT SIGARGS STREAM)) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm \LupinePrimativeTypes \LupineDummyTypes \LupineNotFixedTypes \LupineNumberTypes \LupineInitialTypeTable) ) (DECLARE: DONTCOPY (DECLARE: EVAL@COMPILE (RPAQQ \FirstLupineUserCall 4) (RPAQQ \FirstLupineSignal 4) (CONSTANTS (\FirstLupineUserCall 4) (\FirstLupineSignal 4)) ) ) (PUTPROPS LUPINE COPYRIGHT ("Xerox Corporation" 1984 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1917 43384 (Lupine 1927 . 3884) (\ServerComs 3886 . 10078) (\MakeUnmarshal 10080 . 10581) (\MakeUnmarshal1 10583 . 14428) (\MakeUnmarshalRecord 14430 . 22709) (\FixedFetch 22711 . 23977 ) (\MakeArgsUnmarshal 23979 . 24867) (\ClientComs 24869 . 30430) (\MakeMarshal 30432 . 31021) ( \MakeMarshal1 31023 . 34722) (\MakeMarshalRecord 34724 . 41100) (\FixedStore 41102 . 42627) ( \MakeArgsMarshal 42629 . 43382)) (43422 49673 (\CheckSpec 43432 . 45630) (\CheckType 45632 . 45912) ( \CheckType1 45914 . 49088) (\CheckRecordDecl 49090 . 49671)) (49710 53777 (\DeclareTypes 49720 . 51058 ) (\Allocate 51060 . 52323) (\AllocateRecord 52325 . 53775)) (53800 56008 (\TypeName 53810 . 54128) ( \BaseType 54130 . 54457) (\TypeLayout 54459 . 54650) (\TypeSize 54652 . 54975) (\LupineNotFixed 54977 . 55188) (\StaticsFirst 55190 . 55629) (\IsStatic 55631 . 56006))))) STOP \ No newline at end of file diff --git a/lispusers/LispUsers-README.tedit b/lispusers/LispUsers-README.tedit new file mode 100644 index 00000000..734fdd6d Binary files /dev/null and b/lispusers/LispUsers-README.tedit differ diff --git a/lispusers/LispUsers-Rules.TEdit b/lispusers/LispUsers-Rules.TEdit new file mode 100644 index 00000000..edc3a8f9 Binary files /dev/null and b/lispusers/LispUsers-Rules.TEdit differ diff --git a/lispusers/LispUsers-Summary.TEdit b/lispusers/LispUsers-Summary.TEdit new file mode 100644 index 00000000..c49645eb --- /dev/null +++ b/lispusers/LispUsers-Summary.TEdit @@ -0,0 +1,10 @@ +Lispusers Summary A one-line description of (most) LispUsers packages. All files listed here should be in {eris}lispcore>. If you want to look at the list for Koto files, see koto>, the same file. Please add any new files you create to this list. ---NO TEDIT FILE means that no documentation is needed. ---UNSUPPORTED means that there is no author or the author is unreachable. ---an asterisk before a file means its part of the previous package. ---INTERNAL means that it is not for release outside of Xerox ---SOURCE means that you load the source & not the DCOM ---Two dashes (--) before it means that it exists in Koto but hasn't been updated for lyric yet. Module Comments --ACCESS --Ace Animation Compiler; includes graphics editor. --* ACE-EDIT, ACE-Main, ACE-Prim, ACE-AppleDemo (Source), Ace-BouncingBall (Source), ACE-Fouette (Source) --ActiveRegions Mouse sensitive regions in a window. --ActiveRegions2 Rewrite of ActiveRegions --AIRegions --* AIREGIONS-DEMO (Source) --Analyzer Part of proofreader --Animate Smoothly move arrow, finger around on screen. --ArithDecls For use with decl --ArchiveTool (INTERNAL) Cedar archive system interface --ArraySorter --AutoSameDir Put sources back where you got them at MAKEFILE --Auxmenu Useful middle-button menu in background --Background BITBLT to screen background or obscured windows. --* BACKGROUNDDEMO --BackgroundImages screen backgrounds, including rhine, two dollar bill, castle BackgroundMenu Useful menu in the background BiClock Swedish clock BITMAPFNS --BizGrafix Pie & bar chart, line graph creation --BLTDemo graphics demo/idle hack --BMFromW bitmap from window --Bounce Idle hack with lines --Boundary BoyerMoore The Boyer-Moore Theorem Prover --* BoyerMooreData (Source) --BQuote Yet another backquote macro (like Common Lisp's) BSEARCH --BTMP Basic Text Macro Processor --* BTMP-Debug --BugReport --Calendar calendar/appointment-reminder program --CCache keep files on local disk, like FILECACHE but less automatic CD Connect-to-directory command --CD-Command Connect-to-directory command --Changeprinter Interface for dealing with printers CHATSERVER CHECKSET --CIApropos Case Independent apropos CIRCLPRINT --ColorNNGS For use with busmaster and Number 9 Graphics Card on 1108 --ComHack Comments in if and fors COMMENTSTRINGS COMMON-MAKEFILE Creates plain-text exportable Common Lisp source code files COMMWINDOW --CompareDirectories What files are different on two directories CompareSources Compare two lisp files --CompareText Compare two text files COMPILEBANG --CompileFormsList --ConnTitle Show where I'm connected --CourierDefs Implementation of XNS protocol for remote procedure call --CourierEvalServe EVAL server using courier --CourierImageStream Image stream server using courier CourierServe courier server --Crock Analog clock --Crypt (INTERNAL) --Datefns --DEditAug --DEditHardcopy (NEW) hardcopy of Dedit window prettyprints whole function --DEditIcon An icon for Dedit DEditK New DEdit menu with common combo's --DefaultIcon new default icon for shrunk windows --DefaultSubitemFN DES DIGEST DInfoEdit --DirectoryTools --Dirgrapher Shows a graph of directory structure DLionFNKeys Dandlion keys (center/bold/etc) for 1132 users DMSG --Doctor Infamous Eliza program (computer shrink) --Donz talking windows --DPress (INTERNAL) take apart press files DSKTEST --DSL Digital Speech Lab, uses Busmaster speech analysis --Dumper (INTERNAL) Alto Exec DUMP files --DumpLoad Alto Exec DUMP files --EditBG Edit background & background border shade --EDITFONT Create & edit display fonts --EditKeys Dandlion keys (center/bold/etc) for 1132 users --EditRecall EMACS EMACS commands on top of tedit --EMACSUser Use EMACS as your programming environment --EquationForms TEdit file=EquationEditor.tedit; for editing equations --Equations TEdit file=EquationProgram; programmatic interface --Exec Extra exec windows (like Listen) --ExecFNS INTERNAL --FaceInvader A game --FastBitmapBit FILECACHE FILECACHE-BROWSER FILECACHE-DECLS FILECACHE-HOSTUP FILECACHE-SCAVENGE FILECACHEMSGWINDOW --FileObj Files as image objects --FilePercent Lanning FILEWATCH --FillPrint --FillRegion --Finger Who else is running Finger on the net? --FlagBrowser --FontMenu --FullScreen --GKS Graphics Kernel Standard implementation --* GKSExtern --* GKSIntern --* GKSMatrix --GLISP Compiler for GLisp, an object-oriened Lisp language --* GLISPA --* GLISPB --* GLISPDWINDOW --* GLISPGEV --* GLISPGEVAUX --* GLISPGEVTYPE --* GLISPR --* GLISPTEST.LSP --* GLISPVECTOR.LSP --* GLISP.tty --GraphCalls Graph calls from interpreted,compiled code --GREP NEW. Search file(s) for strings, e.g. phone book. --Hanoi Graphics demo/idle hack --HashBuffer --HashDatum --Headline Big titles on the screen --HistMenu History list as a menu --IdeaSketch IdleHax collection of idle hacks --IdleSwap (NEW) idle hack --ImageWriter output to Apple image writer --IMName (INTERNAL) edit Interlisp Manual --IMTedit (INTERNAL) convert Interlisp Manual to TEdit --IMTools (INTERNAL) Tools for dealing with Interlisp Manual --IMTran (INTERNAL) Translate Interlisp Manual --InspectCode-TEdit INVISIBLEWINDOW --Jargon definitions from the hacker's dictionary --Kal b/w or color kaleidoscope (also in Idlehax) --? KeyboardTool Keyobj key image-objects --Kinetic Graphics demo/idle hack --LCrock Clock in the logo window Life Conway's game of life, as an Idle hack LISPXCONVERT --Listen Lisp Executives from the background menu --LoadPatches --LogoClock Another clock in the logo window --LSet Lists as sets MacWindow Shrink & expand windows like a MAC --Magnifier Magnify areas of the screen --MagnifyW --MailoMat INTERNAL --MakeGraph help for Grapher users making graphis Manager Window/menu file package interface MANDELBROT --MathFNs trig, complex functions, constants MERGE-FILEGEN --Move-Windows --MTP (INTERNAL) Mail Transfer Protocol for Lafite<->Tops-20 --MultiMenu Attached menus in groups --MultiW Heirarchical window environment --MusicKeyboard --Notepad Graphics paint program --* NOTEPAD-CORESTYLES (SOURCE) NOVAFONT NSCHATSERVER NSDISPLAYSIZES NSMAINTAIN NSREADERPATCH --NSthasize (INTERNAL NEW) Convert GV Distribution list to NS --NQueens Graphics demo --Pacman Game --Pac-Man-Idle (NEW) Idle hack PageHold Changes "window full" behavior on scrollers --Parser Parser generator for making new parsers --Patchup --PCDAC A-to-D and D-to-A using BusMaster and PC boards --Peano Graphics demo --Performtran add clisp word to record package --Piece-Menus PLANETS --Play Tunes on 1108/1186 beeper --Plot Making plots --* PlotExamples Some samples --* PlotObjects Plots as image objects in documents --Plural Plural of words --PQuote Prettyprint (QUOTE x) as 'x. --Preemptive make scheduler preemptive (caveats) --PressFromNS --PressToIP --PrinterMenu --PromptReminders reminders at a given time, used by Calendar ProofReader Spelling checker in Tedit PUPCHATSERVER --* SpellingArray --PullDownMenus --QIX Shrager --RecordPrint --Region --RemoteGrapher Grapher over XNS connection on another machine --RemotePSW Someone elses Process Status WIndow on your screen --ResetMacros --RotateBM Rotate bitmaps --RPC (Internal) Cedar-style PUP based Remote Procedure Call --* RPC-Example --* RPC-ExampleClient --* RPC-ExampleUser --* RPC-Lupine --* RPCEVAL --* RPCEVALCLIENT --* RPCEVALSERVER RS232CHATSERVER --Sampler Graphics demo SCREENPAPER --ServerStatus --SetDefaultPrinter --SetF Common Lisp style SETF --Show --Signal Mesa-style signals SingleFileIndex Add index to ListFiles output --SlideProjector Cycle thru tedit file of "slides" --SnapScroll Scrollable "snap" windows --Solitaire Graphics demo/Idle hack --SpaceWindow space allocation use in a window --SPrint --StarBG Stars in the background/Idle hack --? StockIcons --StyleSheet create block of menus --SuperMenus --* SuperMenuEdit --Systat control-T puts up window w/graphic display TCPCHATSERVER TEditKey New TEdit commands as various meta-characters --Thermometer --* THERMOMETERDEMO --TileDEdit Dedit windows place themselves so they don't overlap --TimePanel 1108 Maintenance panel => clock TinyTidy Move icons over to edge of screen --TMenu menus that stuff input buffer, pull down menus --TogMenu --TraceIn stepper/tracer for debugging --Trajectory-Follower animation of following a trajectory --Transor --* TSet --TrueHax --TTY --TTYIO --Turing Turing machine simulator --TwoD Two dimensional graphics package --TwoDGraphics Two dimensional graphics package UnboxedOps Unboxed arithmetic for dandetiger's UPCSTATS --UtilISOpr Additional iterative operators --VMemState Turn on/off VMEM.PURE.STATE --VStats Show time, space used --WAM Window Action Menu --WDWHacks WHO-LINE WHOCALLS --Wink Graphics demo --Winner --Worm Idle hack --Yapff Yet Another Page Full Function7ŽŽJž7žŽJž7ŽJž?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +5Ç8KE>8a +4j5*88?2>P. +1"+:"1E#*4  % F"L B&% %G-7  K*2 3;2+9) 3';%7G?( +! + 0  .<    89  $"!+*7=/22"", 2.-( 4+ -=%)"    >61 80 +!4'1 >& +??=  .3'$/ ++#47A,+7 ';    "(0/ +(    +&"ž4zş \ No newline at end of file diff --git a/lispusers/LispUsers-Template-Instr.TEdit b/lispusers/LispUsers-Template-Instr.TEdit new file mode 100644 index 00000000..1be280e9 Binary files /dev/null and b/lispusers/LispUsers-Template-Instr.TEdit differ diff --git a/lispusers/LispUsers-Template.TEdit b/lispusers/LispUsers-Template.TEdit new file mode 100644 index 00000000..254e6eca Binary files /dev/null and b/lispusers/LispUsers-Template.TEdit differ diff --git a/lispusers/LispUsers.tty b/lispusers/LispUsers.tty new file mode 100644 index 00000000..2cbe6b5c --- /dev/null +++ b/lispusers/LispUsers.tty @@ -0,0 +1 @@ +Finished TEdit file Index for Lispusers The released versions of these files kept on {ERIS}KOTO>LispUsers> These are the files due to be released as LispUsers packages. They are listed by filename, source (if the source file is to be released a "Y" will follow the name), author, and other comments. ---NO TEDIT FILE means that no documentation is needed. ---UNSUPPORTED means that there is no author or the author has left. If any information in this file is wrong, write me a message WITHIN ONE DAY, i.e. Tuesday April 8 at noon. If I get your message to late, the changes can't be made. Thanks, Susana Wessling, Wessling.pa@Xerox FILE SOURCE? Author Comments Ace Denber ACE-APPLEDEMO Y ACE-BOUNCINGBALL Y ACE-FOUETTE Y ActiveRegions Barstow Unsupported ActiveRegions2 Model AIRegions Wexler/Wogulis AIREGIONS-DEMO Y Analyzer Maxwell Animate Bobrow w/ Stefik ArithDecls Kaplan ArraySorter Y Peters/Pedersen AutoSameDir Model Auxmenu Newman Background Bird Support by Wexler BACKGROUNDDEMO Y BackgroundImages Stansbury BackgroundMenu MikeDixon BiClock Nilsson BizGrafix Jellinek BLTDemo Denber BMFromW Wexler Bounce Dixon Boundary Bird Support by Wexler BoyerMoore B/M Support by Roach BoyerMooreData y w/BoyerMoore BQuote MikeDixon BTMP Bird Support by Wexler BTMP-Debug Bird no TEDIT BugReport Feuerman/Newman Calendar Denber CCache HThompson CD HThompson CD-Command Hefron Changeprinter Bigham Unsupported CIApropos Martin/vanMelle ColorNNGS Roach ComHack HThompson CompareDirectories Masinter CompareSources vanMelle CompareText Sannella CompileFormsList Kaplan ConnTitle Lovstrand CourierDefs Lane CourierEvalServe Lane CourierImageStream Lane CourierServe Lane Crock Roach Datefns Anon Unsupported DEditAug Model DEditIcon Y Hefron DEditK Masinter DefaultIcon Lovstrand DefaultSubitemFN Briggs DInfoEdit Cutting DirectoryTools Wogulis/Wexler Dirgrapher Markovitch DLionFNKeys Nuyens Doctor Anon Donz Shrager DSL Thompson DumpLoad Masinter/vanMelle EditBG Lane EDITFONT Roach EditKeys Y Masinter EditRecall Model EMACS Roach EMACSUser Roach EquationForms Hogg TEdit file=EquationEditor Equations Hogg TEdit file=EquationProgram Exec Roach FaceInvader Shulman FastBitmapBit Hefron FileObj Masinter FilePercent Y Lanning FillPrint Model FillRegion Bird, Wogulis, Wexler Finger Nuyens FlagBrowser Model FontMenu Feuerman FullScreen ??? GKS Shih GKSExtern Shih no TEdit needed GKSIntern Shih no TEdit needed GKSMatrix Shih no TEdit needed GLISPA GLISPB GLISPDWINDOW GLISPGEV GLISPGEVAUX GLISPGEVTYPE GLISPR GLISPTEST.LSP GLISPVECTOR.LSP GLISP.tty Novak All GLISP one TEdit GraphCalls Lane Hanoi Anon Unsupported HashBuffer Lane HashDatum Lane Headline Henderson HistMenu Bobrow Unsupported IdeaSketch Burton IdleHax Masinter ImageWriter RClarke InspectCode-TEdit Hefron Jargon Shrager Kal Denber KeyboardTool Lindenfelser Keyobj Nuyens Kinetic Anon Bitbucketms@X LCrock White Unsupported Life Masinter Listen Fischer LoadPatches Y Lanning LogoClock Masinter LSet Roach MacWindow Lichtenberg Magnifier Burton MagnifyW Lane MakeGraph Henderson Manager Ferguson/Noble MathFNs Roach Move-Windows Henderson MultiMenu Schoen MultiW Lane MusicKeyboard Lindenfelser Notepad Henderson NOTEPAD-CORESTYLES Y Henderson no TEdit NQueens Schoen Pacman Denber PageHold JLWhite Unsupported Parser Stansbury Patchup Bobrow Unsupported PCDAC Herring Support by Thompson Peano Anon BitBucket.ms@Xerox Performtran Kaplan Piece-Menus Henderson Play Roach Plot Pedersen PlotExamples Pedersen PlotObjects Pedersen Plural Kay/White PQuote Y DonC Preemptive Masinter Pressfromns Hogg Presstoip Roach uses dpress PrinterMenu GSLWS^.pa PromptReminders JonL Support by Masinter ProofReader Maxwell PullDownMenus Richer Unsupported QIX Y Shrager RecordPrint Model Region Lane RemoteGrapher Lane RemotePSW Lane ResetMacros Model RotateBM Roach Sampler Denber ServerStatus Hill SetDefaultPrinter Briggs SetF Roach Signal HThompson SingleFileIndex Tong, White revised by vanMelle SlideProjector ColabCore^.pa SnapScroll Shrager Solitaire Sheil SpaceWindow Sannella SpellingArray Y no TEdit SPrint Smith Unsupported StarBG Foster StockIcons Anonymous StyleSheet Stansbury SuperMenuEdit Y ??? SuperMenus Y ??? Systat Roach TEditKey Nuyens Thermometer Markovitch THERMOMETERDEMO Y Markovitch no TEdit TileDEdit Shrager TimePanel Model TinyTidy Masinter TMenu Stefik,bobrow,tong TogMenu Thompson TraceIn Cohen, Dyer Trajectory-Follower Henderson Transor Anonymous TrueHax HThompson TSet Part of Transor TTY Stefik TTYIO Smith/Schoen Turing Denber TwoD Jellinek TwoDGraphics Pedersen Unboxedops Pedersen Utilisoprs Lipkis VMemState Kaplan VStats Koomen WAM Y Shrager WDWHacks Shrager Wink Masinter Winner Shrager Worm Markovitch E-mail:BitBucket.ms@X Yapff Masinter \ No newline at end of file diff --git a/lispusers/LoadPatches b/lispusers/LoadPatches new file mode 100644 index 00000000..57dd9e48 --- /dev/null +++ b/lispusers/LoadPatches @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Nov-88 14:11:42" {PHYLUM}LISP>LYRIC>LOADPATCHES.;3 3441 changes to%: (VARS LOADPATCHESCOMS) (FNS LoadPatches COLLECT-PATCH-FILES) previous date%: "27-Sep-88 22:56:49" {PHYLUM}LISP>LYRIC>LOADPATCHES.;1) (* " Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOADPATCHESCOMS) (RPAQQ LOADPATCHESCOMS ((FNS LoadPatches COLLECT-PATCH-FILES) (DECLARE%: DONTCOPY (PROP FILETYPE LOADPATCHES)))) (DEFINEQ (LoadPatches [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 16-Nov-88 13:08 by Burwell") (* ;;; "Load all compiled files from the directory") (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* bind (AFTERIDATE _ (if AFTERDATE then (OR (IDATE AFTERDATE) 0) else 0)) join (COLLECT-PATCH-FILES DIRECTORY EXT AFTERIDATE)) (FUNCTION (LAMBDA (X Y) (LESSP (CDR X) (CDR Y] (* ;  "files are sorted by increasing date") (for file in files do (SELECTQ LDFLG (HIDDEN (* ;  "Load the file, but don't put it on FILELST") (LOAD? (CAR file) T) (SETQ FILELST (DREMOVE (FILENAMEFIELD (CAR file) 'NAME) FILELST))) (LOAD? (CAR file) LDFLG))) files]) (COLLECT-PATCH-FILES [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 16-Nov-88 13:13 by Burwell") (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") (RESETLST (LET ((FILING.ENUMERATION.DEPTH 1) (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) FILE DATE) (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") '(ICREATIONDATE) '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) NAKED-DIR) (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DECLARE%: DONTCOPY (PUTPROPS LOADPATCHES FILETYPE :COMPILE-FILE) ) (PUTPROPS LOADPATCHES COPYRIGHT ("Xerox Corporation" 1985 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (608 3275 (LoadPatches 618 . 2308) (COLLECT-PATCH-FILES 2310 . 3273))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE b/lispusers/MACINTERFACE new file mode 100644 index 00000000..6b135c9b --- /dev/null +++ b/lispusers/MACINTERFACE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-2020 15:48:17"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;52 14335 changes to%: (VARS MACINTERFACECOMS) previous date%: " 8-Aug-2020 08:01:06" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>MACINTERFACE.;51) (PRETTYCOMPRINT MACINTERFACECOMS) (RPAQQ MACINTERFACECOMS [ (* ;; "Externals") (COMS (FNS MACWINDOW MACWINDOW.SETUP MACWINDOW.UNSETUP) (INITVARS (MACINTERFACECORNERMARGIN 25))) (* ;; "Internals") [COMS (FNS INTITLEBAR INCORNER MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE) (* ;; "Behavior for some known window creators") (FNS MACINT-ADD-EXEC MACINT-SNAPW) (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN)) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MACINT-ADD-EXEC]) (* ;; "Externals") (DEFINEQ (MACWINDOW [LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:") (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.") (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN) (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE) ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN)))) WINDOW]) (MACWINDOW.SETUP [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.") (* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.") (* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the write circumstances. This is typically the case where ORIGFN is a window creator.") (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.") (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.") (* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (MOVD? ORIGFN RENAMEDORIG) (IF MACWINDOWFN THEN (MOVD MACWINDOWFN ORIGFN) ELSE (PUTD ORIGFN `(LAMBDA (WINDOW) (MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG) ,ANYWHERE]) (MACWINDOW.UNSETUP [LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:") (* ; "Edited 24-Jun-2020 15:09 by rmk:") (* ;; "Moves the renamed original function back to its original name") (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN] (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it") (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP") (SETQ PKGNAME "INTERLISP")) (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN) PKGNAME)) (CL:WHEN (GETD RENAMEDORIG) (MOVD RENAMEDORIG ORIGFN]) ) (RPAQ? MACINTERFACECORNERMARGIN 25) (* ;; "Internals") (DEFINEQ (INTITLEBAR [LAMBDA (WINDOW) (* ; "Edited 3-May-2020 20:38 by rmk:") (IGREATERP (LASTMOUSEY WINDOW) (FETCH TOP OF (DSPCLIPPINGREGION NIL WINDOW]) (INCORNER [LAMBDA (WINDOW MARGIN) (* ; "Edited 13-May-2020 14:26 by rmk:") (* ; "Edited 10-May-2020 12:41 by rmk:") (* ; "Edited 3-May-2020 20:43 by rmk:") (CL:UNLESS MARGIN (SETQ MARGIN MACINTERFACECORNERMARGIN)) (LET ((CR (DSPCLIPPINGREGION NIL WINDOW)) (X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW))) (IF (ILEQ (IABS (IDIFFERENCE X (FETCH LEFT OF CR))) MARGIN) THEN (* ;; "GREATERP puts it in title bar") (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'LEFTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'LEFTBOTTOM) ELSEIF (ILEQ (IABS (IDIFFERENCE X (FETCH RIGHT OF CR))) MARGIN) THEN (IF (IGREATERP Y (FETCH TOP OF CR)) THEN 'RIGHTTOP ELSEIF (ILEQ (IABS (IDIFFERENCE Y (FETCH BOTTOM OF CR))) MARGIN) THEN 'RIGHTBOTTOM]) (MACWINDOW.BUTTONEVENTFN [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 24-Jun-2020 20:23 by rmk:") (* ; "Edited 23-May-2020 08:34 by rmk:") (* ; "Edited 10-May-2020 03:35 by rmk:") (* ; "Edited 3-May-2020 21:18 by rmk:") (IF (AND (MOUSESTATE (ONLY LEFT)) (EQ LASTKEYBOARD 0)) THEN (TOTOPW WINDOW) (LET (REGION (CORNER (INCORNER WINDOW))) (IF CORNER THEN (* ;;  "The upper corners may be in the title bar, near the side, so test this first") (SETQ REGION (WINDOWPROP WINDOW 'REGION)) [LET ((LEFT (FETCH LEFT OF REGION)) (RIGHT (FETCH RIGHT OF REGION)) (TOP (FETCH TOP OF REGION)) (BOTTOM (FETCH BOTTOM OF REGION))) (SHAPEW WINDOW (GETREGION NIL NIL NIL NIL NIL (SELECTQ CORNER (RIGHTBOTTOM (LIST LEFT TOP RIGHT BOTTOM)) (LEFTBOTTOM (LIST RIGHT TOP LEFT BOTTOM)) (RIGHTTOP (LIST LEFT BOTTOM RIGHT TOP)) (LEFTTOP (LIST RIGHT BOTTOM LEFT TOP)) (SHOULDNT] T ELSEIF (OR ANYWHERE (INTITLEBAR WINDOW)) THEN (MOVEW WINDOW) T ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW))) ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN] THEN (APPLY* ORIGFUNCTION WINDOW]) (MACWINDOW.BUTTONEVENTFN.ANYWHERE [LAMBDA (WINDOW) (* ; "Edited 24-Jun-2020 13:24 by rmk:") (* ;; "Move if left-click anywhere, not just titlebar") (MACWINDOW.BUTTONEVENTFN NIL T]) ) (* ;; "Behavior for some known window creators") (DEFINEQ (MACINT-ADD-EXEC [LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:") (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC) (FOR N FROM 1 TO U COLLECT (ARG U N] (* ;; "For some reason, the window may not be there immediately") (DISMISS 100) (MACWINDOW (PROCESSPROP PROC 'WINDOW)) PROC]) (MACINT-SNAPW [LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:") (* ;; "No point in shaping a snap window, just move it.;;") (* ;; "This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN") (LET ((W (MACORIG-SNAPW))) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W) (TOTOPW W) (MOVEW W] W]) ) (DEFINEQ (TEDIT.MACINTERFACE [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:58 by rmk:") (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN) (* ;; "All") (TEDIT.SETFUNCTION (CHARCODE "1,a") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,A") (FUNCTION TEDIT.SELECTALL) TEDIT.READTABLE) (* ;; "Quit") (TEDIT.SETFUNCTION (CHARCODE "1,q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,Q") (FUNCTION TEDIT.QUIT) TEDIT.READTABLE]) (TEDIT.SELECTALL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (CL:WHEN TEXTSTREAM (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM))) 'LEFT))]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (TEDIT.MACINTERFACE) (* ;; "Inspector") (MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER) (* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either") (* (MACWINDOW.SETUP  (QUOTE ONEDINSPECT.BUTTONEVENTFN))) (MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN) (* ;; "Freemenu") (MACWINDOW.SETUP '\FM.BUTTONEVENTFN) (* ;; "SEDIT") (MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN) (* ;; "Debugger") (MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT) (* ;; "Snap") (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW) (* ;; "New execs") (MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC) (* ;; "Existing exec of the load") (MACWINDOW (PROCESSPROP (TTY.PROCESS) 'WINDOW)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MACINT-ADD-EXEC) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3345 6723 (MACWINDOW 3355 . 3996) (MACWINDOW.SETUP 3998 . 5914) (MACWINDOW.UNSETUP 5916 . 6721)) (6792 11103 (INTITLEBAR 6802 . 7022) (INCORNER 7024 . 8439) (MACWINDOW.BUTTONEVENTFN 8441 . 10850) (MACWINDOW.BUTTONEVENTFN.ANYWHERE 10852 . 11101)) (11161 12138 (MACINT-ADD-EXEC 11171 . 11595) (MACINT-SNAPW 11597 . 12136)) (12139 13098 (TEDIT.MACINTERFACE 12149 . 12767) (TEDIT.SELECTALL 12769 . 13096))))) STOP \ No newline at end of file diff --git a/lispusers/MACINTERFACE.TXT b/lispusers/MACINTERFACE.TXT new file mode 100644 index 00000000..1875ba47 --- /dev/null +++ b/lispusers/MACINTERFACE.TXT @@ -0,0 +1,52 @@ +MACINTERFACE documentation + + Ron Kaplan, June 2020 + +MACINTERFACE is a symbol Lispusers package that changes the mouse actions on Medley windows so that moving and shaping can be done in a way that approximates the behavior of windows on the Mac desktop. + +Thus, for a window that has been created or transformed in this way, you can move the window by left-clicking in the title bar and dragging the window. + +The menu behavior for other buttons in the title bar is unchanged. + +Similarly, you can reshape a window by clicking near one of its corners and dragging it out. + +For bottom corners, "near" means inside the window within MACINTERFACECORNERMARGIN (initially 25) pixels above or to the left/right of the corner. + +For top corners, "near" means within the title bar and within the margin from the left/right edges. + +(Windows that don't have a title-bar, like Snap windows, can be set up so that moving can happen by clicking anywhere, and shaping at the top is determined by the margin inside the window region.) + +When the package is loaded, this behavior is installed for the following kinds of windows: + +Tedit +Debugger/break +Sedit +Inspector +Snap +Exec + +The function MACWINDOW.SETUP establishes the new behavior for classes of windows: + +(MACWINDOW.SETUP ORIGFN MACWINDOWFN ANYWHERE) + +ORIGFN is either the name of the BUTTONEVENTFN for a class of windows (e.g. \TEDIT.BUTTONEVENTFN for Tedit windows) or it is a function that creates windows of a particulate kind (e.g. SNAPW or ADD-EXEC). + +MACWINDOW.SETUP moves the definition of ORIGFN to the name (PACK* 'MACORIG- ORIGFN), and then provides a new definition for ORIGFN that does the moving or reshaping for clicks in the triggering locations, and otherwise passes control through to the original definition. + +If ORIGNFN is a button event function, then MACWINDOWFN should not be specified. In that case a new definition for ORIGFN is constructed to provide the desired windowing behavior. + +Otherwise, if ORIGFN is the function that creates windows of a class (e.g. SNAPW), then a MACWINDOWFN should be provided to create such window (by calling (PACK* MACORIG- ORIGFN)). The definition of MACWINDOWFN replaces the original definition of ORIGFN. + +If the flag ANYWHERE is non-NIL, especially for windows without a title bar, then the moving behavior is triggered by a click anywhere in the window (except the corners). + +Because this works by redefining existing functions, it is important that the MACINTERFACE package be loaded AFTER Tedit and Sedit, if those are not already in the sysout. And it should be called to upgrade the proper functions for other window classes that might later be added (e.g. GRAPHER). + +If it is not known or it is inconvenient to systematically upgrade a button function or a window-creation function, the new behavior can be provided after a window has been created, by invoking + +(MACWINDOW WINDOW ANYWHERE) + +This saves the windows existing BUTTONEVENTFN as a window property PREMACBUTTONEVENTFN, and installs a simple stub function in its place. + +Known issue: Clicking at the bottom-right corner of Tedit windows sometimes doesn't catch the new behavior--there seems to be a conflict with Tedit's window-splitting conventions. + +A future extension might be to add an X or some circles on the left of the title bar, to implement a close/shrink behaviors. diff --git a/lispusers/MACWINDOW b/lispusers/MACWINDOW new file mode 100644 index 00000000..6609c404 --- /dev/null +++ b/lispusers/MACWINDOW @@ -0,0 +1 @@ +(FILECREATED "26-Apr-86 13:49:13" {ERIS}LISPCORE>MACWINDOW.;4 5327 changes to: (VARS MACWINDOWCOMS) previous date: "22-Apr-86 14:29:47" {ERIS}LISPCORE>MACWINDOW.;3) (* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MACWINDOWCOMS) (RPAQQ MACWINDOWCOMS ((FNS MACWINDOW.ZOOM2 MACWINDOW.ZOOMBOX MACWINDOW.ZOOMSTEP REGION-DISTANCE) (INITVARS (MACWINDOW.ZOOMSTEPTIME 10) (MACWINDOW.SPEED 15) (MACWINDOW.ZOOMGRAY 42405)) (ADVISE EXPANDW SHRINKW))) (DEFINEQ (MACWINDOW.ZOOM2 [LAMBDA (A B M C) (* MPL "26-May-84 11:52") (IPLUS A (ITIMES C (IQUOTIENT (IDIFFERENCE B A) M]) (MACWINDOW.ZOOMBOX [LAMBDA (IW TOWHAT ICONPOSITION) (* edited: "15-Apr-86 23:46") (PROG (OLDXL OLDXR OLDYB OLDYT ZOOMXL ZOOMXR ZOOMYB ZOOMYT I M XLI XLW XRI XRW YBI YBW YTI YTW PP ) (DECLARE (SPECVARS . T)) (SETQ ZOOMXL) (SETQ PP (WINDOWPROP IW (QUOTE REGION))) (SETQ XLI (fetch (REGION LEFT) of PP)) (SETQ XRI (fetch (REGION RIGHT) of PP)) (SETQ YBI (fetch (REGION BOTTOM) of PP)) (SETQ YTI (fetch (REGION TOP) of PP)) (SETQ PP (WINDOWPROP IW (QUOTE ICONFOR))) [COND [(OR TOWHAT ICONPOSITION) (COND ((WINDOWP TOWHAT) (SETQ PP (WINDOWPROP TOWHAT (QUOTE REGION))) (GO AROUND)) (T (SETQ PP (create REGION LEFT _ (fetch (POSITION XCOORD) of ICONPOSITION) BOTTOM _ (fetch (POSITION YCOORD) of ICONPOSITION) WIDTH _ (fetch BITMAPWIDTH of TOWHAT) HEIGHT _ (fetch BITMAPHEIGHT of TOWHAT] (T (COND ((NOT PP) (SETQ PP (WINDOWPROP IW (QUOTE ICONWINDOW))) (* Can't handle the case of a window  with no icon yet. Don't know where it  will be!) (COND ((NOT PP) (RETURN] (SETQ PP (WINDOWPROP PP (QUOTE REGION))) AROUND (SETQ XLW (fetch (REGION LEFT) of PP)) (SETQ XRW (fetch (REGION RIGHT) of PP)) (SETQ YBW (fetch (REGION BOTTOM) of PP)) (SETQ YTW (fetch (REGION TOP) of PP)) [SETQ M (REGION-DISTANCE PP (WINDOWPROP IW (QUOTE REGION] (SETQ M (IQUOTIENT M MACWINDOW.SPEED)) (COND ((EQ M 0) (RETURN))) (bind TIMER for I from 1 to M do (SETQ TIMER (SETUPTIMER MACWINDOW.ZOOMSTEPTIME TIMER)) (MACWINDOW.ZOOMSTEP M I) (OR (TIMEREXPIRED? TIMER) (BLOCK NIL TIMER))) (DRAWGRAYBOX ZOOMXL ZOOMYB ZOOMXR ZOOMYT (SCREENBITMAP) MACWINDOW.ZOOMGRAY]) (MACWINDOW.ZOOMSTEP [LAMBDA (M C) (* edited: "15-Apr-86 23:46") (SETQ OLDXL ZOOMXL) (SETQ OLDXR ZOOMXR) (SETQ OLDYB ZOOMYB) (SETQ OLDYT ZOOMYT) (SETQ ZOOMXL (MACWINDOW.ZOOM2 XLI XLW M C)) (SETQ ZOOMXR (MACWINDOW.ZOOM2 XRI XRW M C)) (SETQ ZOOMYB (MACWINDOW.ZOOM2 YBI YBW M C)) (SETQ ZOOMYT (MACWINDOW.ZOOM2 YTI YTW M C)) (COND (OLDXL (DRAWGRAYBOX OLDXL OLDYB OLDXR OLDYT (SCREENBITMAP) MACWINDOW.ZOOMGRAY))) (DRAWGRAYBOX ZOOMXL ZOOMYB ZOOMXR ZOOMYT (SCREENBITMAP) MACWINDOW.ZOOMGRAY]) (REGION-DISTANCE [LAMBDA (REG1 REG2) (* mpl "10-Jan-85 19:04") (FIX (SQRT (FPLUS (EXPT [FLOAT (ABS (IDIFFERENCE (IPLUS (fetch (REGION LEFT) of REG1) (LRSH (fetch (REGION WIDTH) of REG1) 1)) (IPLUS (fetch (REGION LEFT) of REG2) (LRSH (fetch (REGION WIDTH) of REG2) 1] 2) (EXPT [FLOAT (ABS (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of REG1) (LRSH (fetch (REGION HEIGHT) of REG1) 1)) (IPLUS (fetch (REGION BOTTOM) of REG2) (fetch (REGION HEIGHT) of REG2] 2]) ) (RPAQ? MACWINDOW.ZOOMSTEPTIME 10) (RPAQ? MACWINDOW.SPEED 15) (RPAQ? MACWINDOW.ZOOMGRAY 42405) (PUTPROPS EXPANDW READVICE (NIL (BEFORE FIRST (MACWINDOW.ZOOMBOX ICONW)))) (PUTPROPS SHRINKW READVICE (NIL (BEFORE FIRST (MACWINDOW.ZOOMBOX WINDOW TOWHAT ICONPOSITION)))) (READVISE EXPANDW SHRINKW) (PUTPROPS MACWINDOW COPYRIGHT ("Xerox Corporation" 1984 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (641 4920 (MACWINDOW.ZOOM2 651 . 840) (MACWINDOW.ZOOMBOX 842 . 3501) (MACWINDOW.ZOOMSTEP 3503 . 4140) (REGION-DISTANCE 4142 . 4918))))) STOP \ No newline at end of file diff --git a/lispusers/MAGNIFIER b/lispusers/MAGNIFIER new file mode 100644 index 00000000..712a3e67 --- /dev/null +++ b/lispusers/MAGNIFIER @@ -0,0 +1 @@ +(FILECREATED "30-Jun-86 16:44:43" {PHYLUM}MAGNIFIER.;13 19020 changes to: (FNS \SLOWMAGSHOW \EXPANDBITMAPBY4 \SLOWMAGSHOW1 MAGTRACK \FFAST4BIT \SLOWEXPANDBITMAPBY4) (MACROS MAGSHOW) (VARS MAGNIFIERCOMS) previous date: "27-Jun-86 17:39:52" {PHYLUM}MAGNIFIER.;11) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MAGNIFIERCOMS) (RPAQQ MAGNIFIERCOMS ((FNS MAGNIFYW MAGTRACK \EXPANDBITMAPBY4SLOW \SLOWMAGSHOW ONFOURGRID \EXPANDBITMAPBY4 \SLOWMAGSHOW1 \FFAST4BIT) (CURSORS EMPTYCURSOR) (MACROS MAGSHOW) (ADDVARS (BackgroundMenuCommands ("Magnifier" (MAGNIFYW) "for enlarging the screen around the cursor; click to start, click to stop."))) (VARS (BackgroundMenu)) (DECLARE: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILES (LOADCOMP) LLARRAYELT)))) (DEFINEQ (MAGNIFYW [LAMBDA (WIN) (* rrb "14-Mar-86 10:03") (PROG NIL (OR (WINDOWP WIN) (SETQ WIN (CREATEW (GETREGION 28 28 NIL (FUNCTION ONFOURGRID)) NIL 12))) (WINDOWPROP WIN (QUOTE BUTTONEVENTFN) (FUNCTION MAGTRACK)) (WINDOWPROP WIN (QUOTE NEWREGIONFN) (FUNCTION ONFOURGRID)) (* make the background black so that the part of the  window that isn't a multiple of 4 is black.) (DSPTEXTURE BLACKSHADE WIN]) (MAGTRACK [LAMBDA (WIN) (* rrb "30-Jun-86 15:30") (* * tracking function for a magnify window) (* * if the mouse goes down in the window, track until it goes down again.) (PROG ((WININTERIOR (DSPCLIPPINGREGION NIL WIN)) (WINEXTERIOR (WINDOWPROP WIN (QUOTE REGION))) MAGWIDTH MAGHEIGHT WIDTH HEIGHT NEARCURSORBITMAP EXPANDEDBITMAP CURX CURY LFT BTM MOUSEBEENUP WINLFT WINBTM WINRGHT WINTOP) (COND ((LASTMOUSESTATE UP) (RETURN))) (CLEARW WIN) (SETQ WINLFT (fetch (REGION LEFT) of WINEXTERIOR)) (SETQ WINBTM (fetch (REGION BOTTOM) of WINEXTERIOR)) (SETQ WINRGHT (fetch (REGION PRIGHT) of WINEXTERIOR)) (SETQ WINTOP (fetch (REGION PTOP) of WINEXTERIOR)) [SETQ NEARCURSORBITMAP (BITMAPCREATE (SETQ WIDTH (QUOTIENT (SETQ MAGWIDTH (fetch (REGION WIDTH) of WININTERIOR)) 4)) (SETQ HEIGHT (QUOTIENT (SETQ MAGHEIGHT (fetch (REGION HEIGHT) of WININTERIOR)) 4] (SETQ EXPANDEDBITMAP (BITMAPCREATE MAGWIDTH MAGHEIGHT)) [ERSETQ (RESETFORM (CURSOR EMPTYCURSOR) (until (COND (MOUSEBEENUP (MOUSESTATE (NOT UP))) ((MOUSESTATE UP) (SETQ MOUSEBEENUP T) NIL)) when (OR (NEQ CURX LASTMOUSEX) (NEQ CURY LASTMOUSEY)) do (AND LFT (DRAWGRAYBOX (DIFFERENCE LFT 2) (DIFFERENCE BTM 2) (PLUS LFT WIDTH 2) (PLUS BTM HEIGHT 2) (SCREENBITMAP) BLACKSHADE)) (SETQ CURX LASTMOUSEX) (SETQ CURY LASTMOUSEY) [SETQ LFT (IMAX 0 (IMIN (DIFFERENCE SCREENWIDTH WIDTH) (DIFFERENCE CURX (IQUOTIENT WIDTH 2] [SETQ BTM (IMAX 0 (IMIN (DIFFERENCE SCREENHEIGHT HEIGHT) (DIFFERENCE CURY (IQUOTIENT HEIGHT 2] (COND ((OR (GEQ LFT WINRGHT) (GEQ BTM WINTOP) (GREATERP WINLFT (PLUS LFT WIDTH)) (GREATERP WINBTM (PLUS BTM HEIGHT))) (* no overlap between cursor box and magnifier  window.) (MAGSHOW WIN LFT BTM WIDTH HEIGHT NEARCURSORBITMAP EXPANDEDBITMAP)) (T (\SLOWMAGSHOW WIN LFT BTM WIDTH HEIGHT NEARCURSORBITMAP EXPANDEDBITMAP WINLFT WINBTM WINRGHT WINTOP))) (DRAWGRAYBOX (DIFFERENCE LFT 2) (DIFFERENCE BTM 2) (PLUS LFT WIDTH 2) (PLUS BTM HEIGHT 2) (SCREENBITMAP) BLACKSHADE] (* erase box from screen.) (AND BTM (DRAWGRAYBOX (DIFFERENCE LFT 2) (DIFFERENCE BTM 2) (PLUS LFT WIDTH 2) (PLUS BTM HEIGHT 2) (SCREENBITMAP) BLACKSHADE]) (\EXPANDBITMAPBY4SLOW [LAMBDA (SOURCE TARGET) (* rrb "14-Mar-86 14:22") (* expands a bitmap by a factor of 4 into another  bitmap) (DECLARE (GLOBALVARS \4BITEXPANSIONTABLE)) (PROG (NUW (BMH (fetch BITMAPHEIGHT of SOURCE)) (BMW (fetch BITMAPWIDTH of SOURCE))) (SETQ NUW (ITIMES 4 BMW)) (for I from 0 to (SUB1 BMH) as C from 0 by 4 do (\FFAST4BIT (\ADDBASE (fetch BITMAPBASE of SOURCE) (ITIMES (IDIFFERENCE BMH (ADD1 I)) (fetch BITMAPRASTERWIDTH of SOURCE))) (\ADDBASE (fetch BITMAPBASE of TARGET) (ITIMES (IDIFFERENCE (fetch BITMAPHEIGHT of TARGET) (ADD1 C)) (fetch BITMAPRASTERWIDTH of TARGET))) (fetch BITMAPRASTERWIDTH of TARGET) (fetch (ARRAYP BASE) of \4BITEXPANSIONTABLE)) (* copy line once.) (BITBLT TARGET 0 C TARGET 0 (IPLUS C 1) NUW 1 (QUOTE INPUT) (QUOTE REPLACE)) (* copy both those lines.) (BITBLT TARGET 0 C TARGET 0 (IPLUS C 2) NUW 2 (QUOTE INPUT) (QUOTE REPLACE))) (RETURN TARGET]) (\SLOWMAGSHOW [LAMBDA (WIN X Y WID HGHT NEARCURSORBITMAP EXPANDEDBITMAP WINLFT WINBTM WINRIGHT WINTOP) (* rrb "30-Jun-86 16:35") (* * displays a magnified image of the area X Y in WIN but knows that there is an overlap) (* FOR NOW NOT IMPLEMENTED) (PROG ((SAVEBM (WINDOWPROP WIN (QUOTE IMAGECOVERED))) BOTTOMHEIGHT LEFTWIDTH) [COND [(GREATERP WINBTM Y) (* bottom of nearcursor overlaps window.) (* display the area below the overlap) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) X Y NEARCURSORBITMAP WID (SETQ BOTTOMHEIGHT (DIFFERENCE WINBTM Y) ) 0 0 EXPANDEDBITMAP) (COND ((GREATERP WINLFT X) (* there is part of the screen to display before the  window.) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) X (PLUS Y BOTTOMHEIGHT) NEARCURSORBITMAP (SETQ LEFTWIDTH (DIFFERENCE WINLFT X)) (DIFFERENCE HGHT BOTTOMHEIGHT) 0 (LLSH BOTTOMHEIGHT 2) EXPANDEDBITMAP) (* display the part under the window) (\SLOWMAGSHOW1 WIN SAVEBM 0 0 NEARCURSORBITMAP (DIFFERENCE WID LEFTWIDTH) (DIFFERENCE HGHT BOTTOMHEIGHT) (LLSH LEFTWIDTH 2) (LLSH BOTTOMHEIGHT 2) EXPANDEDBITMAP)) ((LESSP WINRIGHT (PLUS X WID)) (* there is screen to display after the window.) (* display the part under the window) (\SLOWMAGSHOW1 WIN SAVEBM (DIFFERENCE X WINLFT) 0 NEARCURSORBITMAP (SETQ LEFTWIDTH (DIFFERENCE WINRIGHT X)) (DIFFERENCE HGHT BOTTOMHEIGHT) 0 (LLSH BOTTOMHEIGHT 2) EXPANDEDBITMAP) (* display the part to the right of the mag window.) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) WINRIGHT (PLUS Y BOTTOMHEIGHT) NEARCURSORBITMAP (DIFFERENCE WID LEFTWIDTH) (DIFFERENCE HGHT BOTTOMHEIGHT) (LLSH LEFTWIDTH 2) (LLSH BOTTOMHEIGHT 2) EXPANDEDBITMAP)) (T (* the width of the nearcursor area is completely  within the magnifier window;) (\SLOWMAGSHOW1 WIN SAVEBM (DIFFERENCE X WINLFT) 0 NEARCURSORBITMAP WID (DIFFERENCE HGHT BOTTOMHEIGHT) 0 (LLSH BOTTOMHEIGHT 2) EXPANDEDBITMAP] [(GREATERP (PLUS Y HGHT) WINTOP) (* top of nearcursor overlaps the magnifier window.) (* display the area above the overlap) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) X WINTOP NEARCURSORBITMAP WID (DIFFERENCE HGHT (SETQ BOTTOMHEIGHT (DIFFERENCE WINTOP Y) )) 0 (LLSH BOTTOMHEIGHT 2) EXPANDEDBITMAP) (COND ((GREATERP WINLFT X) (* there is part of the screen to display before the  window.) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) X Y NEARCURSORBITMAP (SETQ LEFTWIDTH (DIFFERENCE WINLFT X)) BOTTOMHEIGHT 0 0 EXPANDEDBITMAP) (* display the part under the window) (\SLOWMAGSHOW1 WIN SAVEBM 0 (DIFFERENCE Y WINBTM) NEARCURSORBITMAP (DIFFERENCE WID LEFTWIDTH) BOTTOMHEIGHT (LLSH LEFTWIDTH 2) 0 EXPANDEDBITMAP)) ((LESSP WINRIGHT (PLUS X WID)) (* there is screen to display after the window.) (* display the part under the window) (\SLOWMAGSHOW1 WIN SAVEBM (DIFFERENCE X WINLFT) (DIFFERENCE Y WINBTM) NEARCURSORBITMAP (SETQ LEFTWIDTH (DIFFERENCE WINRIGHT X)) BOTTOMHEIGHT 0 0 EXPANDEDBITMAP) (* display the part to the right of the mag window.) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) WINRIGHT Y NEARCURSORBITMAP (DIFFERENCE WID LEFTWIDTH) BOTTOMHEIGHT (LLSH LEFTWIDTH 2) 0 EXPANDEDBITMAP)) (T (* the width of the nearcursor area is completely  within the magnifier window;) (\SLOWMAGSHOW1 WIN SAVEBM (DIFFERENCE X WINLFT) (DIFFERENCE Y WINBTM) NEARCURSORBITMAP WID BOTTOMHEIGHT 0 0 EXPANDEDBITMAP] (T (* whole height of nearcursor overlaps the magnifier  window.) (COND ((GREATERP WINLFT X) (* there is part of the screen to display before the  window.) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) X Y NEARCURSORBITMAP (SETQ LEFTWIDTH (DIFFERENCE WINLFT X)) HGHT 0 0 EXPANDEDBITMAP) (* display the part under the window) (\SLOWMAGSHOW1 WIN SAVEBM 0 (DIFFERENCE Y WINBTM) NEARCURSORBITMAP (DIFFERENCE WID LEFTWIDTH) HGHT (LLSH LEFTWIDTH 2) 0 EXPANDEDBITMAP)) ((LESSP WINRIGHT (PLUS X WID)) (* there is screen to display after the window.) (* display the part under the window) (\SLOWMAGSHOW1 WIN SAVEBM (DIFFERENCE X WINLFT) (DIFFERENCE Y WINBTM) NEARCURSORBITMAP (SETQ LEFTWIDTH (DIFFERENCE WINRIGHT X)) HGHT 0 0 EXPANDEDBITMAP) (* display the part to the right of the mag window.) (\SLOWMAGSHOW1 WIN (SCREENBITMAP) WINRIGHT Y NEARCURSORBITMAP (DIFFERENCE WID LEFTWIDTH) HGHT (LLSH LEFTWIDTH 2) 0 EXPANDEDBITMAP)) (T (* the width of the nearcursor area is completely  within the magnifier window;) (\SLOWMAGSHOW1 WIN SAVEBM (DIFFERENCE X WINLFT) (DIFFERENCE Y WINBTM) NEARCURSORBITMAP WID HGHT 0 0 EXPANDEDBITMAP] (RETURN]) (ONFOURGRID [LAMBDA (FIXPT MOVEPT) (* rrb "14-Mar-86 10:08") (* makes sure that both points are on a mod of 4  grid.) (COND (MOVEPT (replace (POSITION XCOORD) of MOVEPT with (DIFFERENCE (fetch (POSITION XCOORD) of MOVEPT) (IMOD (fetch (POSITION XCOORD) of MOVEPT) 4))) (replace (POSITION YCOORD) of MOVEPT with (DIFFERENCE (fetch (POSITION YCOORD) of MOVEPT) (IMOD (fetch (POSITION YCOORD) of MOVEPT) 4))) MOVEPT) (T (replace (POSITION XCOORD) of FIXPT with (DIFFERENCE (fetch (POSITION XCOORD) of FIXPT) (IMOD (fetch (POSITION XCOORD) of FIXPT) 4))) (replace (POSITION YCOORD) of FIXPT with (DIFFERENCE (fetch (POSITION YCOORD) of FIXPT) (IMOD (fetch (POSITION YCOORD) of FIXPT) 4))) FIXPT]) (\EXPANDBITMAPBY4 [LAMBDA (SOURCE TARGET WIDTH HEIGHT) (* rrb "30-Jun-86 16:39") (* expands a bitmap by a factor of 4 into another  bitmap) (DECLARE (GLOBALVARS \4BITEXPANSIONTABLE)) (PROG ((NUW (ITIMES 4 WIDTH)) (NUH (ITIMES 4 HEIGHT)) (SOURCEBASE (fetch BITMAPBASE of SOURCE)) (TARGETBASE (fetch BITMAPBASE of TARGET)) (TARGETRASTERWIDTH (fetch BITMAPRASTERWIDTH of TARGET)) (TABLEBASE (fetch (ARRAYP BASE) of \4BITEXPANSIONTABLE))) (* clear out the part of the target that will be  used.) (BITBLT NIL NIL NIL TARGET 0 0 NUW NUH (QUOTE TEXTURE) (QUOTE REPLACE) 0) (for I from 1 to HEIGHT as SOURCEADDR from (TIMES (DIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of SOURCE) HEIGHT) (fetch BITMAPRASTERWIDTH of SOURCE)) by (fetch BITMAPRASTERWIDTH of SOURCE) as TARGETADDR from (ITIMES (PLUS (DIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of TARGET) NUH) 3) TARGETRASTERWIDTH) by (ITIMES 4 TARGETRASTERWIDTH) do (\FFAST4BIT (\ADDBASE SOURCEBASE SOURCEADDR) (\ADDBASE TARGETBASE TARGETADDR) (QUOTIENT (PLUS WIDTH 3) 4) TABLEBASE)) (* copy single lines once.) (BITBLT TARGET 0 0 TARGET 0 1 NUW NUH (QUOTE INPUT) (QUOTE PAINT)) (* copy both those lines.) (BITBLT TARGET 0 0 TARGET 0 2 NUW NUH (QUOTE INPUT) (QUOTE PAINT)) (RETURN TARGET]) (\SLOWMAGSHOW1 [LAMBDA (MAGW SOURCEBM SOURCEX SOURCEY TEMPBM WIDTH HEIGHT MAGWX MAGWY EXPANDEDBITMAP) (* rrb "30-Jun-86 16:41") (PROGN (* rrb "27-Jun-86 17:27") (* * displays a magnified image of the area SOURCEX SOURCEY in MAGW) (BITBLT SOURCEBM SOURCEX SOURCEY TEMPBM 0 0 WIDTH HEIGHT) (BITBLT (\EXPANDBITMAPBY4 TEMPBM EXPANDEDBITMAP WIDTH HEIGHT) 0 0 MAGW MAGWX MAGWY (LLSH WIDTH 2) (LLSH HEIGHT 2) (QUOTE INPUT) (QUOTE REPLACE]) (\FFAST4BIT [LAMBDA (A B N MAPBASE) (* rrb "14-Mar-86 14:22") (* DECLARATIONS: (BLOCKRECORD NIBBLE  ((N1 BITS 4) (N2 BITS 4) (N3 BITS 4)  (N4 BITS 4)))) (* homebrew version of \FAST4BIT that removes ELT and  is 60 percent faster.) (bind AW (I _ 0) for J from 0 do (SETQ AW (\ADDBASE A J)) (OR (IGREATERP N I) (RETURN)) (\PUTBASE B I (\GETBASE MAPBASE (fetch N1 of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (\GETBASE MAPBASE (fetch N2 of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (\GETBASE MAPBASE (fetch N3 of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (\GETBASE MAPBASE (fetch N4 of AW))) (add I 1]) ) (RPAQ EMPTYCURSOR (CURSORCREATE (READBITMAP) 0 7)) (16 16 "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@" "@@@@")(DECLARE: EVAL@COMPILE [PUTPROPS MAGSHOW MACRO ((WIN X Y WID HGHT NEARCURSORBITMAP EXPANDEDBITMAP) (* rrb "27-Jun-86 17:27") (* * displays a magnified image of the area X Y in WIN) (BITBLT (SCREENBITMAP) X Y NEARCURSORBITMAP 0 0 WID HGHT) (BITBLT (\EXPANDBITMAPBY4 NEARCURSORBITMAP EXPANDEDBITMAP WID HGHT) 0 0 WIN 0 0 (LLSH WID 2) (LLSH HGHT 2] ) (ADDTOVAR BackgroundMenuCommands ("Magnifier" (MAGNIFYW) "for enlarging the screen around the cursor; click to start, click to stop.")) (RPAQQ BackgroundMenu NIL) (DECLARE: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILESLOAD (LOADCOMP) LLARRAYELT) ) (PUTPROPS MAGNIFIER COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (892 18116 (MAGNIFYW 902 . 1485) (MAGTRACK 1487 . 4808) (\EXPANDBITMAPBY4SLOW 4810 . 6275) (\SLOWMAGSHOW 6277 . 13057) (ONFOURGRID 13059 . 14336) (\EXPANDBITMAPBY4 14338 . 16360) ( \SLOWMAGSHOW1 16362 . 17018) (\FFAST4BIT 17020 . 18114))))) STOP \ No newline at end of file diff --git a/lispusers/MAGNIFIER.TEDIT b/lispusers/MAGNIFIER.TEDIT new file mode 100644 index 00000000..4df2b948 Binary files /dev/null and b/lispusers/MAGNIFIER.TEDIT differ diff --git a/lispusers/MAILSHARE b/lispusers/MAILSHARE new file mode 100644 index 00000000..32e11512 --- /dev/null +++ b/lispusers/MAILSHARE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "20-Feb-87 08:05:52" {IVY}LISP>MAILSHARE.;1 12250 previous date%: "15-Dec-86 10:01:06" {INDIGO}BASICS>MAILSHARE.;3) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MAILSHARECOMS) (RPAQQ MAILSHARECOMS ((* Menu Functions) (FNS MASH.TopLevel MASH.CreateFreeMenu MASH.GetMail MASH.Quit MASH.Consistent MASH.MakeDirectoryName MASH.MakeProfileName MASH.MakeIconWindow) (* Icon bitmaps) (BITMAPS MASH.Icon MASH.IconMask) (* VARS) (INITVARS (MASH.VALID-HOSTS '(IVY INDIGO PHYLUM ERIS QV CHERRY))) (GLOBALVARS MASH.VALID-HOSTS) (ADDVARS (BackgroundMenuCommands (Mail% Share '(MASH.TopLevel) "Start the Mail Share menu"))) (VARS (BackgroundMenu NIL)))) (* Menu Functions) (DEFINEQ (MASH.TopLevel (LAMBDA NIL (* DSB " 5-Nov-86 09:55") (* Start the Mail Share Process) (PROG (menuWindow) (SETQ menuWindow (MASH.CreateFreeMenu)) (* * initialize to GV) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow 'NETMODE) menuWindow) (* * set up menu window) (WINDOWPROP menuWindow 'ICONFN (FUNCTION MASH.MakeIconWindow)) (SHAPEW menuWindow '(200 200 275 82)) (SHAPEW (GETPROMPTWINDOW menuWindow) '(200 282 275 35))))) (MASH.CreateFreeMenu (LAMBDA (LEFT BOTTOM) (* DSB " 5-Nov-86 09:37") (* returns a free menu window at  specified position) (FM.FORMATMENU `(((TYPE TITLE LABEL Commands%: FONT (MODERN 12 BOLD)) (LABEL GetMail SELECTEDFN MASH.GetMail) (LABEL Quit SELECTEDFN MASH.Quit)) ((TYPE EDITSTART LABEL Name%: FONT (MODERN 12 BOLD) ITEMS (NAME)) (TYPE EDIT ID NAME LABEL "")) ((TYPE EDITSTART LABEL |Mail Directory:| FONT (MODERN 12 BOLD) ITEMS (DIRECTORY)) (TYPE EDIT ID DIRECTORY LABEL "")) ((TYPE TITLE LABEL NetworkMode%: FONT (MODERN 12 BOLD)) (TYPE NWAY ID NETMODE LABEL GV) (TYPE NWAY ID NETMODE LABEL NS)) (WINDOWPROPS TITLE "Mail Share" LEFT %, LEFT BOTTOM %, BOTTOM))))) (MASH.GetMail (LAMBDA (ITEM WINDOW BUTTONS) (* DSB " 5-Nov-86 10:05") (* Gets the mail) (PROG ((state (FM.READSTATE WINDOW)) (promptW (GETPROMPTWINDOW WINDOW)) name mailDirectory networkMode consistent mailProfile (locatedDirectory NIL)) (CLEARW promptW) (* * check that name is specified) (SETQ name (U-CASE (LISTGET state 'NAME))) (COND ((EQUAL name "") (PRIN1 "Enter your name" promptW) (RETURN))) (* * check if mail directory is both entered and consistent) (* * If consistent, check if the mail directory is legitimate;  otherwise, use mail directory host list) (SETQ mailDirectory (U-CASE (LISTGET state 'DIRECTORY))) (COND ((NOT (EQUAL mailDirectory "")) (COND ((NOT (UNPACKFILENAME mailDirectory 'HOST)) (RETURN (PRIN1 "Include file server name (e.g., {ivy})" promptW)))) (SETQ consistent (MASH.Consistent name mailDirectory)) (COND ((EQ consistent 'ERROR) (CLEARW promptW) (PRIN1 "Badly formed directory name" promptW) (RETURN))) (COND (consistent (SETQ mailProfile (MASH.MakeProfileName mailDirectory)) (COND ((INFILEP mailProfile) (SETQ locatedDirectory T)) (T (PRIN1 "Can't find that mail directory. Searching..." promptW))))))) (* * look for default mail directory using mail directory host list) (for host in MASH.VALID-HOSTS while (NOT locatedDirectory) do (SETQ mailDirectory (MASH.MakeDirectoryName host name)) (SETQ mailProfile (MASH.MakeProfileName mailDirectory)) (COND ((INFILEP mailProfile) (SETQ locatedDirectory T) ))) (* * if unable to find valid mail directory, return) (COND ((NOT locatedDirectory) (CLEARW promptW) (PRIN1 "Please enter correct default mail directory name" promptW) (PRIN1 "e.g., {IVY}MAIL>" promptW) (RETURN))) (* * profile exists, so do it!) (CLEARW promptW) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW 'DIRECTORY) WINDOW mailDirectory) (PRIN1 "Quitting previous Lafite..." promptW) (LAFITE 'OFF) (PRIN1 "Done" promptW) (TERPRI promptW) (LOGIN) (COND ((NOT (EQ USERNAME (MKATOM name))) (RETURN (PRIN1 "Mail and Login names inconsistent" promptW)))) (CLEARW promptW) (PRIN1 "Mail is coming..." promptW) (SETQ networkMode (U-CASE (LISTGET state 'NETMODE))) (COND ((EQ networkMode 'GV) (LAFITEMODE 'GV)) (T (LAFITEMODE 'NS))) (SETQ LAFITEDEFAULTHOST&DIR mailDirectory) (LAFITE 'ON)))) (MASH.Quit (LAMBDA (ITEM WINDOW BUTTONS) (* DSB " 5-Nov-86 10:11") (* * Quits LAFITE, clears menu, etc.) (PROG ((promptW (GETPROMPTWINDOW WINDOW))) (CLEARW promptW) (PRIN1 "Quitting Lafite..." promptW) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW 'NAME) WINDOW "") (FM.CHANGELABEL (FM.ITEMFROMID WINDOW 'DIRECTORY) WINDOW "") (LAFITE 'OFF) (SETQ LAFITEDEFAULTHOST&DIR NIL) (LAFITEMODE 'GV) (FM.CHANGESTATE (FM.ITEMFROMID WINDOW 'NETMODE) WINDOW) (PRIN1 "Done" promptW)))) (MASH.Consistent (LAMBDA (name mailDirectory) (* DSB " 4-Nov-86 09:21") (* * returns T if name is the root directory of mailDirectory) (PROG ((nameString (MKSTRING name)) (mailDirectoryString (MKSTRING mailDirectory)) startPosition length before after) (SETQ startPosition (STRPOS nameString mailDirectoryString)) (COND ((NOT startPosition) (RETURN NIL))) (SETQ length (NCHARS nameString)) (SETQ before (STRPOS "<" mailDirectoryString)) (SETQ after (STRPOS ">" mailDirectoryString)) (COND ((AND (NUMBERP before) (NUMBERP after)) (RETURN (EQP length (DIFFERENCE (DIFFERENCE after before) 1)))) (T (RETURN 'ERROR)))))) (MASH.MakeDirectoryName (LAMBDA (host userName) (* DSB " 2-Nov-86 15:43") (PROG (directoryName) (SETQ directoryName (CONCAT userName ">MAIL>")) (RETURN (PACKFILENAME 'HOST host 'DIRECTORY directoryName))))) (MASH.MakeProfileName (LAMBDA (directory) (* DSB " 2-Nov-86 15:37") (* * returns the Lafite.Profile name) (PROG (profileName) (SETQ profileName (PACKFILENAME 'DIRECTORY directory 'NAME 'LAFITE 'EXTENSION 'PROFILE)) (RETURN profileName)))) (MASH.MakeIconWindow (LAMBDA (WINDOW OLDICON) (* DSB "15-Dec-86 09:58") (* * Creates a window with an icon formed by two bit maps.) (OR OLDICON (ICONW MASH.Icon MASH.IconMask)))) ) (* Icon bitmaps) (RPAQQ MASH.Icon #*(90 50)@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOO@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@GON@@@@@@@@OOH@@G@@@CH@@GON@@@@@@@@OOH@@G@@@CHAOOOOOOOOOOOOOOOL@G@@@CHA@@@@@@@@@@@@@@@D@G@@@CHA@@@@@@@@@@@@@@@D@G@@@CHA@@@@@@@@@@@@@@@D@G@@@CHA@@@LAH@O@A@H@@@D@G@@@CHA@@@OGH@I@A@H@@@D@G@@@CHA@@@ILHAIHA@H@@@D@G@@@CHA@@@HHHA@HA@H@@@D@G@@@CHA@@@H@HCOLA@H@@@D@G@@@CHA@@@H@HB@DA@H@@@D@G@@@CHA@@@H@HF@FA@OL@@D@G@@@CHA@@@@@@@@@@@@@@@D@G@@@CHA@@@@@G@@@@N@@@@D@G@@@CHA@@@@@G@@@@N@@@@D@G@@@CHA@@@@@B@@@@D@@@@D@G@@@CHAOOOOOOOOOOOOOOOL@G@@@CH@@@@@@B@@@@D@@@@@@G@@@CH@@@@@@COOOOL@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@CH@@@@GLHHCLAOCN@@@@G@@@CH@@@@DDHHBDAABB@@@@G@@@CH@@@@D@HHFFAAB@@@@@G@@@CH@@@@CHOHDBAOCH@@@@G@@@CH@@@@@DHHOOAHB@@@@@G@@@CH@@@@DDHHHAAFBB@@@@G@@@CH@@@@GLHIHAICCN@@@@G@@@CH@@@@@@@@@@@@@@@@@@G@@@COOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ MASH.IconMask #*(90 50)@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (* VARS) (RPAQ? MASH.VALID-HOSTS '(IVY INDIGO PHYLUM ERIS QV CHERRY)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MASH.VALID-HOSTS) ) (ADDTOVAR BackgroundMenuCommands (Mail% Share '(MASH.TopLevel) "Start the Mail Share menu")) (RPAQQ BackgroundMenu NIL) (PUTPROPS MAILSHARE COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1099 9386 (MASH.TopLevel 1109 . 1795) (MASH.CreateFreeMenu 1797 . 2978) (MASH.GetMail 2980 . 6921) (MASH.Quit 6923 . 7601) (MASH.Consistent 7603 . 8502) (MASH.MakeDirectoryName 8504 . 8783 ) (MASH.MakeProfileName 8785 . 9126) (MASH.MakeIconWindow 9128 . 9384))))) STOP \ No newline at end of file diff --git a/lispusers/MAIN.LGC b/lispusers/MAIN.LGC new file mode 100644 index 00000000..2068c4ee --- /dev/null +++ b/lispusers/MAIN.LGC @@ -0,0 +1 @@ +! (LAMBDA (TREE FORMULA CLAUSES WINDOW) (MAKE-TREE (AND-LEVEL TREE) (DELETE-OR-NODE-WITH-CUT FORMULA (OR-LEVELS TREE)))) SET (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((EXPANDED-VAR (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE)))) (EXPANDED-ARGS (LOOKUP (THIRD FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE)))) (RESULT (COND ((LISTP EXPANDED-ARGS) (APPLY (CAR EXPANDED-ARGS) (CDR EXPANDED-ARGS))) (T (EVAL EXPANDED-ARGS)))) (NEWENV (UNIFY EXPANDED-VAR RESULT (UNIFICATION-ENV (AND-LEVEL TREE))))) (COND ((FAILEDP NEWENV) (CLEAR-AND-LEVEL TREE)) (T (UPDATE-ENV NEWENV TREE))))) PRINT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((EXPANDED-CDR-FORMULA (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (FORMAT T "~S ~%" EXPANDED-CDR-FORMULA) TREE)) EVAL&PRINT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((EXPANDED-CDR-FORMULA (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (FORMAT T "~S ~%" (EVAL EXPANDED-CDR-FORMULA)) TREE)) RETRACT-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (SETF (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) (DELETE THEORY-NAME (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) :TEST (FUNCTION EQUAL))) TREE))) SAVE-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (SAVE-THEORY THEORY-NAME WINDOW) TREE))) LOAD-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (LOAD-THEORY THEORY-NAME WINDOW) TREE))) USE-THEORY (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (SETF (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) (APPEND (GET-AND-NODE-THEORIES (AND-LEVEL TREE)) (LIST THEORY-NAME))) TREE))) MERGE-THEORIES (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET ((THEORY-NAME (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV (AND-LEVEL TREE)))) (LIST-OF-THEORIES (LOOKUP (REST (REST FORMULA)) (UNIFICATION-ENV (AND-LEVEL TREE))))) (PROGN (OR (AND WINDOW (MERGE-THEORIES-DEVEL WINDOW THEORY-NAME LIST-OF-THEORIES)) (APPLY 'MERGE-THEORIES (CONS THEORY-NAME LIST-OF-THEORIES))) TREE))) FAIL (LAMBDA (TREE FORMULA CLAUSES WINDOW) (CLEAR-AND-LEVEL TREE)) TRUE (LAMBDA (TREE FORMULA CLAUSES WINDOW) TREE) WFF (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-CDR-FORMULA (LOOKUP (SECOND FORMULA) (UNIFICATION-ENV ANDLEVEL)))) (SOLVE TREE EXPANDED-CDR-FORMULA (FIND-CLAUSES (PREDICATE EXPANDED-CDR-FORMULA) (GET-AND-NODE-THEORIES ANDLEVEL) WINDOW)))) LOGIC-ADDZ (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-ADDZ (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-ADDA (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-ADDA (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-DELETE-FACT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-DELETE-FACT (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-ASSERT (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-ASSERT (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) (FOURTH EXPANDED-FORMULA) WINDOW) TREE))) LOGIC-DELETE (LAMBDA (TREE FORMULA CLAUSES WINDOW) (LET* ((ANDLEVEL (AND-LEVEL TREE)) (EXPANDED-FORMULA (LOOKUP FORMULA (UNIFICATION-ENV ANDLEVEL)))) (PROGN (LOGIC-DELETE (SECOND EXPANDED-FORMULA) (THIRD EXPANDED-FORMULA) WINDOW) TREE))) THEORY-END \ No newline at end of file diff --git a/lispusers/MAKEGRAPH b/lispusers/MAKEGRAPH new file mode 100644 index 00000000..419366eb --- /dev/null +++ b/lispusers/MAKEGRAPH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-May-88 11:52:41" {ERINYES}MEDLEY>MAKEGRAPH.;1 15546 previous date%: "10-Jul-85 19:33:14" {ERINYES}KOTO>LISPUSERS>MAKEGRAPH.;1) (* " Copyright (c) 1984, 1985, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MAKEGRAPHCOMS) (RPAQQ MAKEGRAPHCOMS ((FNS MAKE.GRAPH MAKE.GRAPH.ACCESS MAKE.GRAPH.ACCESS.NODES MAKE.GRAPH.ALREADY.SEENP MAKE.GRAPH.CONSTRUCT MAKE.GRAPH.CONSTRUCT.BELOW MAKE.GRAPH.DATUM MAKE.GRAPH.EXAMPLE.1 MAKE.GRAPH.EXAMPLE.2 MAKE.GRAPH.FATHER MAKE.GRAPH.FIND.ROOTS MAKE.GRAPH.FIND.ROOTS.BELOW MAKE.GRAPH.INTERNAL.LEFTBUTTONFN MAKE.GRAPH.INTERNAL.MIDDLEBUTTONFN MAKE.GRAPH.INTERNAL.TITLE.FN MAKE.GRAPH.INTERNAL.TITLE.FN.MENU MAKE.GRAPH.LABEL MAKE.GRAPH.LEFTBUTTONFN MAKE.GRAPH.MAKE.SUBGRAPH MAKE.GRAPH.MIDDLEBUTTONFN MAKE.GRAPH.MIDDLEBUTTONFN.MENU MAKE.GRAPH.NODE.ALREADY.SEENP MAKE.GRAPH.NODE.SONS MAKE.GRAPH.NODE.SPECS.LABEL MAKE.GRAPH.NODE.SPECS.SONS MAKE.GRAPH.PROP.PAIRS MAKE.GRAPH.SHOW.LIST MAKE.GRAPH.SHOW.SPEC MAKE.GRAPH.NODE.TYPE MAKE.GRAPH.STATE MAKE.GRAPH.UPDATE.WINDOW) (FILES (FROM VALUEOF LISPUSERSDIRECTORIES) GRAPHER) (VARS (MAKE.GRAPH.INTERNAL.TITLE.FN.MENU) MAKE.GRAPH.LIST.SPEC (MAKE.GRAPH.MIDDLEBUTTONFN.MENU) MAKE.GRAPH.SPEC.SPEC)) ) (DEFINEQ (MAKE.GRAPH (LAMBDA (WINDOW TITLE GRAPH.SPECIFICATION ROOTS CONTEXT LEFTBUTTONFN MIDDLEBUTTONFN TOPJUSTIFYFLG DEPTH) (* DAHJr " 6-MAY-83 18:45") (* * CREATES A GRAPHER WINDOW STARTING FROM ROOTS ACCORDING TO GRAPH.SPECIFICATION) (* * GRAPH.SPECIFICATION%: A PLIST OF STATES WHOSE VALUES ARE ACTIONS) (* * ACTION%: A PLIST WITH PROPERTIES%: (LABEL LABEL.SPEC) (FONT FONT.SPEC) (SONS (SONS.SPEC STATE.SPEC)) (ROOTS (ROOTS.SPEC STATE.SPEC))) (* * x.SPEC%: FORM TO BE EVAL'D IN AN ENVIRONMENT WHERE DATUM AND CONTEXT ARE BOUND) (* * ROOTS%: ((DATUM %. STATE) |...| (DATUM %. STATE))) (PROG (TTL GRAPH NEW.WINDOW LBF MBF) (SETQ LBF (OR LEFTBUTTONFN (FUNCTION MAKE.GRAPH.LEFTBUTTONFN))) (SETQ MBF (OR MIDDLEBUTTONFN (FUNCTION MAKE.GRAPH.MIDDLEBUTTONFN))) (SETQ TTL (OR TITLE "A graph")) (SETQ GRAPH (MAKE.GRAPH.CONSTRUCT GRAPH.SPECIFICATION ROOTS CONTEXT DEPTH)) (SETQ NEW.WINDOW (SHOWGRAPH GRAPH WINDOW (FUNCTION MAKE.GRAPH.INTERNAL.LEFTBUTTONFN) (FUNCTION MAKE.GRAPH.INTERNAL.MIDDLEBUTTONFN) TOPJUSTIFYFLG)) (WINDOWPROP NEW.WINDOW (QUOTE TITLE) TITLE) (WINDOWPROP NEW.WINDOW (QUOTE GRAPH.SPECIFICATION) GRAPH.SPECIFICATION) (WINDOWPROP NEW.WINDOW (QUOTE ROOTS) ROOTS) (WINDOWPROP NEW.WINDOW (QUOTE CONTEXT) CONTEXT) (WINDOWPROP NEW.WINDOW (QUOTE LEFTBUTTONFN) LBF) (WINDOWPROP NEW.WINDOW (QUOTE MIDDLEBUTTONFN) MBF) (WINDOWPROP NEW.WINDOW (QUOTE TOPJUSTIFYFLG) TOPJUSTIFYFLG) (WINDOWPROP NEW.WINDOW (QUOTE DEPTH) DEPTH) (RETURN NEW.WINDOW))) ) (MAKE.GRAPH.ACCESS (LAMBDA (DATUM ACCESS.SPEC CONTEXT) (* edited%: " 7-MAR-83 15:08") (EVAL ACCESS.SPEC))) (MAKE.GRAPH.ACCESS.NODES (LAMBDA (NODES.SPECS DATUM CONTEXT) (* DAHJr "10-MAR-83 09:50") (PROG (DATUM.SPEC STATE.SPEC NEW.NODES NEW.DATUM) (SETQ DATUM.SPEC (CAR NODES.SPECS)) (SETQ STATE.SPEC (CADR NODES.SPECS)) (RETURN (SELECTQ DATUM.SPEC (EVAL (EVAL STATE.SPEC)) (LIST (for SUB.SPEC in (CDR NODES.SPECS) collect (SETQ NEW.DATUM (MAKE.GRAPH.ACCESS DATUM (CAR SUB.SPEC) CONTEXT)) (CONS NEW.DATUM (MAKE.GRAPH.ACCESS NEW.DATUM (CADR SUB.SPEC) CONTEXT)))) (UNION (for SUB.SPEC in (CDR NODES.SPECS) join (MAKE.GRAPH.ACCESS.NODES SUB.SPEC DATUM CONTEXT))) (TRACE (SETQ NEW.NODES (MAKE.GRAPH.ACCESS.NODES (CADR NODES.SPECS) DATUM CONTEXT)) (INSPECT NEW.NODES) NEW.NODES) (for NEW.DATUM in (MAKE.GRAPH.ACCESS DATUM DATUM.SPEC CONTEXT) collect (CONS NEW.DATUM (MAKE.GRAPH.ACCESS NEW.DATUM STATE.SPEC CONTEXT))))))) ) (MAKE.GRAPH.ALREADY.SEENP (LAMBDA (NODE GRAPHNODES) (* DAHJr " 7-MAR-83 14:03") (for GRAPHNODE in GRAPHNODES bind ID thereis (SETQ ID (fetch (GRAPHNODE NODEID) of GRAPHNODE)) (AND (EQ (CAR NODE) (CAR ID)) (EQ (CDR NODE) (CDR ID))))) ) (MAKE.GRAPH.CONSTRUCT (LAMBDA (GRAPH.SPECIFICATION INITIAL.ROOTS CONTEXT DEPTH) (* DAHJr " 6-MAY-83 18:16") (PROG ((GRAPHNODES (CONS)) (ROOTS (CONS)) IROOTS ROOT) (SETQ IROOTS (APPEND INITIAL.ROOTS)) (until (NULL IROOTS) do (SETQ ROOT (CAR IROOTS)) (COND ((NOT (MAKE.GRAPH.ALREADY.SEENP ROOT (CAR GRAPHNODES))) (TCONC ROOTS ROOT) (MAKE.GRAPH.CONSTRUCT.BELOW ROOT CONTEXT GRAPH.SPECIFICATION GRAPHNODES IROOTS DEPTH))) (SETQ IROOTS (CDR IROOTS))) (RETURN (LAYOUTLATTICE (CAR GRAPHNODES) (DREVERSE (CAR ROOTS)))))) ) (MAKE.GRAPH.CONSTRUCT.BELOW (LAMBDA (NODE CONTEXT GRAPH.SPECIFICATION GRAPHNODES ROOTS DEPTH) (* rdh%: "10-Jul-85 19:31") (PROG (ALREADY.SEEN DATUM NODE.TYPE NODE.TYPE.DESCRIPTION GRAPHNODE LABEL.SPEC LABEL FONT.SPEC FONT REFERENCE SONS SONS.SPEC SON.REFERENCES ROOTS.SPEC) (SETQ DATUM (CAR NODE)) (SETQ NODE.TYPE (CDR NODE)) (SETQ NODE.TYPE.DESCRIPTION (LISTGET GRAPH.SPECIFICATION NODE.TYPE)) (OR NODE.TYPE.DESCRIPTION (ERROR NODE.TYPE "unrecognized state")) (SETQ ALREADY.SEEN (MAKE.GRAPH.ALREADY.SEENP NODE (CAR GRAPHNODES))) (SETQ REFERENCE (COND (ALREADY.SEEN (CONS (CAR NODE) (CDR NODE))) (T NODE))) (SETQ LABEL.SPEC (LISTGET NODE.TYPE.DESCRIPTION (QUOTE LABEL))) (SETQ LABEL (COND (LABEL.SPEC (MAKE.GRAPH.ACCESS DATUM LABEL.SPEC CONTEXT)) (T "???"))) (SETQ FONT.SPEC (LISTGET NODE.TYPE.DESCRIPTION (QUOTE FONT))) (SETQ FONT (COND (FONT.SPEC (MAKE.GRAPH.ACCESS DATUM FONT.SPEC CONTEXT)) (T NIL))) (SETQ GRAPHNODE (create GRAPHNODE NODEID _ REFERENCE NODELABEL _ LABEL NODEFONT _ FONT)) (TCONC GRAPHNODES GRAPHNODE) (COND (ALREADY.SEEN (replace (GRAPHNODE NODEBORDER) of GRAPHNODE with T)) ((ZEROP DEPTH)) (T (SETQ SONS.SPEC (LISTGET NODE.TYPE.DESCRIPTION (QUOTE SONS))) (COND (SONS.SPEC (SETQ SONS (MAKE.GRAPH.ACCESS.NODES SONS.SPEC DATUM CONTEXT)) (SETQ SON.REFERENCES (for SON in SONS collect (MAKE.GRAPH.CONSTRUCT.BELOW SON CONTEXT GRAPH.SPECIFICATION GRAPHNODES ROOTS (COND ((NUMBERP DEPTH) (SUB1 DEPTH)))))) (replace (GRAPHNODE TONODES) of GRAPHNODE with (DREVERSE SON.REFERENCES)))) (SETQ ROOTS.SPEC (LISTGET NODE.TYPE.DESCRIPTION (QUOTE ROOTS))) (COND (ROOTS.SPEC (NCONC ROOTS (MAKE.GRAPH.ACCESS.NODES ROOTS.SPEC DATUM CONTEXT)))))) (RETURN REFERENCE))) ) (MAKE.GRAPH.DATUM (LAMBDA (NODE) (CAR (fetch (GRAPHNODE NODEID) of NODE)))) (MAKE.GRAPH.EXAMPLE.1 (LAMBDA NIL (* DAHJr " 6-MAY-83 18:50") (MAKE.GRAPH.SHOW.SPEC MAKE.GRAPH.SPEC.SPEC))) (MAKE.GRAPH.EXAMPLE.2 (LAMBDA (DEPTH) (* DAHJr " 6-MAY-83 18:51") (MAKE.GRAPH.SHOW.LIST MAKE.GRAPH.LIST.SPEC DEPTH))) (MAKE.GRAPH.FATHER (LAMBDA (NODE WINDOW) (* DAHJr " 8-MAR-83 19:03") (PROG (GRAPH GRAPHNODES FATHERS ID) (SETQ GRAPH (WINDOWPROP WINDOW (QUOTE GRAPH))) (SETQ GRAPHNODES (fetch (GRAPH GRAPHNODES) of GRAPH)) (SETQ FATHERS (fetch (GRAPHNODE FROMNODES) of NODE)) (RETURN (COND (FATHERS (SETQ ID (CAR FATHERS)) (for GRAPHNODE in GRAPHNODES thereis (EQ (fetch (GRAPHNODE NODEID) of GRAPHNODE) ID))) (T NIL))))) ) (MAKE.GRAPH.FIND.ROOTS (LAMBDA (GRAPH.SPECIFICATION INITIAL.ROOTS CONTEXT DEPTH) (* DAHJr " 6-MAY-83 18:18") (PROG ((NODES (CONS)) (NON-ROOTS (CONS)) IROOTS ROOT) (SETQ IROOTS (APPEND INITIAL.ROOTS)) (until (NULL IROOTS) do (SETQ ROOT (CAR IROOTS)) (MAKE.GRAPH.FIND.ROOTS.BELOW ROOT CONTEXT GRAPH.SPECIFICATION NODES IROOTS NON-ROOTS DEPTH) (SETQ IROOTS (CDR IROOTS))) (RETURN (LDIFFERENCE (CAR NODES) (CAR NON-ROOTS))))) ) (MAKE.GRAPH.FIND.ROOTS.BELOW (LAMBDA (NODE CONTEXT GRAPH.SPECIFICATION NODES ROOTS NON-ROOTS DEPTH) (* DAHJr " 6-MAY-83 18:18") (PROG (DATUM STATE STATE.DESCRIPTION REFERENCE SONS SONS.SPEC SON.REFERENCES ROOTS.SPEC) (SETQ DATUM (CAR NODE)) (SETQ STATE (CDR NODE)) (SETQ STATE.DESCRIPTION (LISTGET GRAPH.SPECIFICATION STATE)) (OR STATE.DESCRIPTION (ERROR STATE "unrecognized state")) (COND ((MAKE.GRAPH.NODE.ALREADY.SEENP NODE (CAR NODES))) ((ZEROP DEPTH)) (T (TCONC NODES NODE) (SETQ SONS.SPEC (LISTGET STATE.DESCRIPTION (QUOTE SONS))) (COND (SONS.SPEC (SETQ SONS (MAKE.GRAPH.ACCESS.NODES SONS.SPEC DATUM CONTEXT)) (for SON in SONS collect (TCONC NON-ROOTS SON) (MAKE.GRAPH.FIND.ROOTS.BELOW SON CONTEXT GRAPH.SPECIFICATION NODES ROOTS NON-ROOTS (COND ((NUMBERP DEPTH) (SUB1 DEPTH))))))) (SETQ ROOTS.SPEC (LISTGET STATE.DESCRIPTION (QUOTE ROOTS))) (COND (ROOTS.SPEC (NCONC ROOTS (MAKE.GRAPH.ACCESS.NODES ROOTS.SPEC DATUM CONTEXT)))))) (RETURN))) ) (MAKE.GRAPH.INTERNAL.LEFTBUTTONFN (LAMBDA (NODE WINDOW) (* DAHJr " 9-MAR-83 12:02") (PROG (X Y REG FN) (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) (SETQ REG (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW (QUOTE DSP)))) (RETURN (COND ((INSIDEP REG X Y) (APPLY* (WINDOWPROP WINDOW (QUOTE LEFTBUTTONFN)) NODE WINDOW)) (T (SETQ FN (WINDOWPROP WINDOW (QUOTE TITLE.LEFTBUTTONFN))) (COND (FN (APPLY* FN WINDOW)) (T (MAKE.GRAPH.INTERNAL.TITLE.FN WINDOW)))))))) ) (MAKE.GRAPH.INTERNAL.MIDDLEBUTTONFN (LAMBDA (NODE WINDOW) (* DAHJr " 9-MAR-83 12:02") (PROG (X Y REG FN) (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) (SETQ REG (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW (QUOTE DSP)))) (RETURN (COND ((INSIDEP REG X Y) (APPLY* (WINDOWPROP WINDOW (QUOTE MIDDLEBUTTONFN)) NODE WINDOW)) (T (SETQ FN (WINDOWPROP WINDOW (QUOTE TITLE.MIDDLEBUTTONFN))) (COND (FN (APPLY* FN WINDOW)) (T (MAKE.GRAPH.INTERNAL.TITLE.FN WINDOW)))))))) ) (MAKE.GRAPH.INTERNAL.TITLE.FN (LAMBDA (WINDOW) (* DAHJr " 6-MAY-83 18:25") (PROG (COMMAND.MENU COMMAND) (SETQ COMMAND.MENU (MAKE.GRAPH.INTERNAL.TITLE.FN.MENU)) (SETQ COMMAND (MENU COMMAND.MENU)) (SELECTQ COMMAND (NIL NIL) (UPDATE (MAKE.GRAPH.UPDATE.WINDOW WINDOW)) (SHOW.GRAPH.SPEC (MAKE.GRAPH.SHOW.SPEC (WINDOWPROP WINDOW (QUOTE GRAPH.SPECIFICATION)))) (ERROR)))) ) (MAKE.GRAPH.INTERNAL.TITLE.FN.MENU (LAMBDA NIL (* DAHJr " 6-MAY-83 18:24") (OR MAKE.GRAPH.INTERNAL.TITLE.FN.MENU (SETQ MAKE.GRAPH.INTERNAL.TITLE.FN.MENU (create MENU ITEMS _ (QUOTE (UPDATE SHOW.GRAPH.SPEC)) CENTERFLG _ T CHANGEOFFSETFLG _ T)))) ) (MAKE.GRAPH.LABEL (LAMBDA (GRAPHNODE) (* DAHJr " 8-MAR-83 18:43") (fetch (GRAPHNODE NODELABEL) of GRAPHNODE))) (MAKE.GRAPH.LEFTBUTTONFN (LAMBDA (GRAPHNODE WINDOW) (* DAHJr "29-MAR-83 18:03") (COND (GRAPHNODE (COND ((KEYDOWNP (QUOTE LSHIFT)) (printout PROMPTWINDOW T "Left button selection:" T " Node label: " (MAKE.GRAPH.LABEL GRAPHNODE) T " Node state: " (MAKE.GRAPH.STATE GRAPHNODE))) (T (PROG (POSITION CR CX CY DX DY) (SETQ POSITION (fetch (GRAPHNODE NODEPOSITION) of GRAPHNODE)) (SETQ CR (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW (QUOTE DSP)))) (SETQ CX (IPLUS (fetch (REGION LEFT) of CR) (IQUOTIENT (fetch (REGION WIDTH) of CR) 2))) (SETQ CY (IPLUS (fetch (REGION BOTTOM) of CR) (IQUOTIENT (fetch (REGION HEIGHT) of CR) 2))) (SETQ DX (IDIFFERENCE CX (fetch (POSITION XCOORD) of POSITION))) (SETQ DY (IDIFFERENCE CY (fetch (POSITION YCOORD) of POSITION))) (SCROLLBYREPAINTFN WINDOW DX DY))))))) ) (MAKE.GRAPH.MAKE.SUBGRAPH (LAMBDA (GRAPHNODE WINDOW) (* DAHJr "25-JUN-83 16:26") (MAKE.GRAPH NIL (CONCAT (WINDOWPROP WINDOW (QUOTE TITLE)) " >") (WINDOWPROP WINDOW (QUOTE GRAPH.SPECIFICATION)) (LIST (CONS (MAKE.GRAPH.DATUM GRAPHNODE) (MAKE.GRAPH.STATE GRAPHNODE))) (WINDOWPROP WINDOW (QUOTE CONTEXT)) (WINDOWPROP WINDOW (QUOTE LEFTBUTTONFN)) (WINDOWPROP WINDOW (QUOTE MIDDLEBUTTONFN)) (WINDOWPROP WINDOW (QUOTE TOPJUSTIFYFLG)) (WINDOWPROP WINDOW (QUOTE DEPTH)))) ) (MAKE.GRAPH.MIDDLEBUTTONFN (LAMBDA (GRAPHNODE WINDOW) (* DAHJr "25-JUN-83 16:27") (COND (GRAPHNODE (COND ((KEYDOWNP (QUOTE LSHIFT)) (INSPECT GRAPHNODE)) (T (PROG (COMMAND.MENU COMMAND) (SETQ COMMAND.MENU (MAKE.GRAPH.MIDDLEBUTTONFN.MENU)) (SETQ COMMAND (MENU COMMAND.MENU)) (SELECTQ COMMAND (NIL NIL) (INSPECT (INSPECT (MAKE.GRAPH.DATUM GRAPHNODE))) (MAKE.SUBGRAPH (MAKE.GRAPH.MAKE.SUBGRAPH GRAPHNODE WINDOW)) (ERROR)))))))) ) (MAKE.GRAPH.MIDDLEBUTTONFN.MENU (LAMBDA NIL (* DAHJr " 6-MAY-83 18:39") (OR MAKE.GRAPH.MIDDLEBUTTONFN.MENU (SETQ MAKE.GRAPH.MIDDLEBUTTONFN.MENU (create MENU ITEMS _ (QUOTE (INSPECT MAKE.SUBGRAPH)) CENTERFLG _ T CHANGEOFFSETFLG _ T)))) ) (MAKE.GRAPH.NODE.ALREADY.SEENP (LAMBDA (NODE NODES) (* DAHJr "11-MAR-83 09:34") (for ND in NODES thereis (AND (EQ (CAR ND) (CAR NODE)) (EQ (CDR ND) (CDR NODE))))) ) (MAKE.GRAPH.NODE.SONS (LAMBDA (DATUM) (* DAHJr " 8-MAR-83 14:29") (COND ((FMEMB (CAR DATUM) (QUOTE (SONS ROOTS))) (LIST (CONS (CADR DATUM) (QUOTE NODE.SPECS)))) (T (LIST (CONS (CADR DATUM) (QUOTE VALUE)))))) ) (MAKE.GRAPH.NODE.SPECS.LABEL (LAMBDA (DATUM) (* DAHJr "10-MAR-83 09:55") (SELECTQ (CAR DATUM) (EVAL (QUOTE EVAL)) (LIST (QUOTE LIST)) (UNION (QUOTE UNION)) (TRACE (QUOTE TRACE)) (QUOTE SPEC.PAIR))) ) (MAKE.GRAPH.NODE.SPECS.SONS (LAMBDA (DATUM) (* DAHJr "10-MAR-83 09:53") (SELECTQ (CAR DATUM) (EVAL (LIST (CONS (CADR DATUM) (QUOTE VALUE)))) (LIST (for ELEM in (CDR DATUM) collect (CONS ELEM (QUOTE NODE.SPEC)))) (UNION (for ELEM in (CDR DATUM) collect (CONS ELEM (QUOTE NODE.SPECS)))) (TRACE (LIST (CONS (CADR DATUM) (QUOTE NODE.SPECS)))) (LIST (CONS (CAR DATUM) (QUOTE NEW.DATUM.SPEC)) (CONS (CADR DATUM) (QUOTE NEW.STATE.SPEC))))) ) (MAKE.GRAPH.PROP.PAIRS (LAMBDA (PLIST) (for ELEMENT on PLIST by (CDDR ELEMENT) collect ELEMENT))) (MAKE.GRAPH.SHOW.LIST (LAMBDA (OBJECT DEPTH) (* DAHJr " 6-MAY-83 18:20") (PROG (ROOTS SPEC.SPEC) (SETQ ROOTS (LIST (CONS OBJECT (QUOTE OBJECT)))) (RETURN (MAKE.GRAPH NIL "A list" MAKE.GRAPH.LIST.SPEC ROOTS NIL NIL NIL T DEPTH)))) ) (MAKE.GRAPH.SHOW.SPEC (LAMBDA (SPEC) (* DAHJr " 6-MAY-83 18:50") (PROG (ROOTS SPEC.SPEC) (SETQ ROOTS (LIST (CONS SPEC (QUOTE GRAPH.SPEC)))) (RETURN (MAKE.GRAPH NIL "A graph specification" MAKE.GRAPH.SPEC.SPEC ROOTS NIL NIL NIL T)))) ) (MAKE.GRAPH.NODE.TYPE (LAMBDA (GRAPHNODE) (* DAHJr " 8-MAR-83 18:43") (CDR (fetch (GRAPHNODE NODEID) of GRAPHNODE)))) (MAKE.GRAPH.STATE (LAMBDA (GRAPHNODE) (* rdh%: "10-Jul-85 17:14") (MAKE.GRAPH.NODE.TYPE GRAPHNODE))) (MAKE.GRAPH.UPDATE.WINDOW (LAMBDA (WINDOW) (* DAHJr " 6-MAY-83 18:44") (MAKE.GRAPH WINDOW (WINDOWPROP WINDOW (QUOTE TITLE)) (WINDOWPROP WINDOW (QUOTE GRAPH.SPECIFICATION)) (WINDOWPROP WINDOW (QUOTE ROOTS)) (WINDOWPROP WINDOW (QUOTE CONTEXT)) (WINDOWPROP WINDOW (QUOTE LEFTBUTTONFN)) (WINDOWPROP WINDOW (QUOTE MIDDLEBUTTONFN)) (WINDOWPROP WINDOW (QUOTE TOPJUSTIFYFLG)) (WINDOWPROP WINDOW (QUOTE DEPTH)))) ) ) (FILESLOAD (FROM VALUEOF LISPUSERSDIRECTORIES) GRAPHER) (RPAQQ MAKE.GRAPH.INTERNAL.TITLE.FN.MENU NIL) (RPAQQ MAKE.GRAPH.LIST.SPEC (OBJECT (DOC (ANY LISP OBJECT) LABEL (COND ((LISTP DATUM) "( )") (T DATUM)) SONS ((COND ((LISTP DATUM) DATUM) (T NIL)) (QUOTE OBJECT)))) ) (RPAQQ MAKE.GRAPH.MIDDLEBUTTONFN.MENU NIL) (RPAQQ MAKE.GRAPH.SPEC.SPEC (GRAPH.SPEC (DOC (A PLIST OF STATE.SPECS) LABEL (QUOTE GRAPH.SPEC) SONS ((MAKE.GRAPH.PROP.PAIRS DATUM) (QUOTE STATE.SPEC))) STATE.SPEC (DOC (A PLIST OF PROPERTIES) LABEL (CAR DATUM) SONS ((MAKE.GRAPH.PROP.PAIRS (CADR DATUM)) (QUOTE PROPERTY))) PROPERTY (DOC (A PROPERTY, EG. DOC, LABEL, FONT, SONS, ROOTS) LABEL (CAR DATUM) SONS (EVAL (MAKE.GRAPH.NODE.SONS DATUM))) NODE.SPECS (DOC (A SPEC OF DATUM/STATE PAIRS) LABEL (MAKE.GRAPH.NODE.SPECS.LABEL DATUM) SONS (EVAL (MAKE.GRAPH.NODE.SPECS.SONS DATUM))) NODE.SPEC (DOC (A SPEC OF A SINGLE DATUM/STATE PAIR) LABEL (QUOTE NODE.SPEC) SONS (LIST ((CAR DATUM) (QUOTE NEW.DATA.SPEC)) ((CADR DATUM) (QUOTE NEW.STATE.SPEC)))) NEW.DATA.SPEC (DOC (THE NEW.DATUM.SPEC) LABEL (QUOTE DATA) SONS ((LIST DATUM) (QUOTE VALUE))) NEW.DATUM.SPEC (DOC (THE NEW.DATUM.SPEC) LABEL (QUOTE DATUM) SONS ((LIST DATUM) (QUOTE VALUE))) NEW.STATE.SPEC (DOC (THE NEW.STATE.SPEC) LABEL (QUOTE STATE) SONS ((LIST DATUM) (QUOTE VALUE))) VALUE (DOC (A VALUE) LABEL DATUM)) ) (PUTPROPS MAKEGRAPH COPYRIGHT ("Xerox Corporation" 1984 1985 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1302 14106 (MAKE.GRAPH 1312 . 2755) (MAKE.GRAPH.ACCESS 2757 . 2867) ( MAKE.GRAPH.ACCESS.NODES 2869 . 3681) (MAKE.GRAPH.ALREADY.SEENP 3683 . 3921) (MAKE.GRAPH.CONSTRUCT 3923 . 4441) (MAKE.GRAPH.CONSTRUCT.BELOW 4443 . 6116) (MAKE.GRAPH.DATUM 6118 . 6197) (MAKE.GRAPH.EXAMPLE.1 6199 . 6310) (MAKE.GRAPH.EXAMPLE.2 6312 . 6433) (MAKE.GRAPH.FATHER 6435 . 6845) ( MAKE.GRAPH.FIND.ROOTS 6847 . 7274) (MAKE.GRAPH.FIND.ROOTS.BELOW 7276 . 8227) ( MAKE.GRAPH.INTERNAL.LEFTBUTTONFN 8229 . 8696) (MAKE.GRAPH.INTERNAL.MIDDLEBUTTONFN 8698 . 9171) ( MAKE.GRAPH.INTERNAL.TITLE.FN 9173 . 9543) (MAKE.GRAPH.INTERNAL.TITLE.FN.MENU 9545 . 9795) ( MAKE.GRAPH.LABEL 9797 . 9911) (MAKE.GRAPH.LEFTBUTTONFN 9913 . 10711) (MAKE.GRAPH.MAKE.SUBGRAPH 10713 . 11181) (MAKE.GRAPH.MIDDLEBUTTONFN 11183 . 11612) (MAKE.GRAPH.MIDDLEBUTTONFN.MENU 11614 . 11854) ( MAKE.GRAPH.NODE.ALREADY.SEENP 11856 . 12024) (MAKE.GRAPH.NODE.SONS 12026 . 12239) ( MAKE.GRAPH.NODE.SPECS.LABEL 12241 . 12444) (MAKE.GRAPH.NODE.SPECS.SONS 12446 . 12884) ( MAKE.GRAPH.PROP.PAIRS 12886 . 12987) (MAKE.GRAPH.SHOW.LIST 12989 . 13224) (MAKE.GRAPH.SHOW.SPEC 13226 . 13464) (MAKE.GRAPH.NODE.TYPE 13466 . 13587) (MAKE.GRAPH.STATE 13589 . 13693) ( MAKE.GRAPH.UPDATE.WINDOW 13695 . 14104))))) STOP \ No newline at end of file diff --git a/lispusers/MAKEGRAPH.TEDIT b/lispusers/MAKEGRAPH.TEDIT new file mode 100644 index 00000000..4ca3e4bf Binary files /dev/null and b/lispusers/MAKEGRAPH.TEDIT differ diff --git a/lispusers/MANAGER b/lispusers/MANAGER new file mode 100644 index 00000000..468eff8b --- /dev/null +++ b/lispusers/MANAGER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "18-Nov-87 15:18:24" |{POGO:AISNORTH:XEROX}WORK>MANAGER.;2| 76893 changes to%: (FNS Manager.DO.COMMAND Manager.SORT.COMS) previous date%: "16-Sep-87 12:30:48" |{POGO:AISNORTH:XEROX}WORK>MANAGER.;1|) (* " Copyright (c) 1986, 1987, 1900 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MANAGERCOMS) (RPAQQ MANAGERCOMS ((* ;; "The Manager : a menu based interface to the file manager. ") (* ;; "Originally written by: Jay Ferguson of Ford Aerospace & Communications Corp and Robert Noble of Intellicorp. ") (* ;; "Rewritten by Larry Masinter, winter of 1986.") (* ;; "Further modifications & significant enhancements by Andrew J. Cameron III, summer of 1987.") (* ;; "Ongoing maintenance and performance tuning by Ron Fischer at Xerox AI Systems.") (* ;; "") (* ;; "There are two patches in here that should be removed if Xerox Lisp is fixed. The first is the advice (MARKASCHANGED :IN DEFAULT.EDITDEFA0001) that removes a (mostly) redundant call to MARKASCHANGED in the editor interface, which otherwise slows down manager updates. Somehow this call is not redundant when editing FILELST (perhaps there's a special case for FILELST or when items are not in any existing files). The second is the fns Manager.REMOVE.DUPLICATE.ADVICE called by the advice on LOAD and LOADFNS, which removes redundant advice which would otherwise pile up and cause massive slow downs in manager updates!") (* ;; "") (* ;; "The edit history is now kept in the file MANAGER.HISTORY.") (* ;; "") (* ;; "Known bugs and feature requests are now kept in the documentation file MANAGER.TEDIT.") (* ;; "") (SPECVARS Manager.ACTIVEFLG MANAGER-CASES MANAGER-ADDTOFILES?) (GLOBALVARS LAMBDAFONT DEFAULTFONT MENUFONT BOLDMENUFONT MANAGER-WINDOWS LOADBFLG SAVEDBFLG MANAGER-ITEM-OPERATION-COMMANDS MANAGER-ITEM-FILE-RELATION-COMMANDS MANAGER-FILE-OPERATIONS-COMMANDS MANAGER-FILE-FILE-RELATION-COMMANDS MANAGER-MAIN-MENU-ITEMS MANAGER-ACTIVITY-WINDOW-TITLE BackgroundMenuCommands BackgroundMenu) (VARS *UNMANAGED-TYPES* MANAGER-ACTIVITY-WINDOW-TITLE (MANAGER-CASES) (MANAGER-ADDTOFILES?) MANAGER-FILE-FILE-RELATION-COMMANDS MANAGER-FILE-OPERATIONS-COMMANDS MANAGER-ITEM-FILE-RELATION-COMMANDS MANAGER-ITEM-OPERATION-COMMANDS MANAGER-MAIN-MENU-ITEMS MANAGER.BM MANAGER.BM.MASK) (INITVARS (Manager.ACTIVEFLG NIL) (Manager.SORTFILELSTFLG T) (Manager.MENUROWS 20) (Manager.DATASPACE NIL) (MANAGER-WINDOWS NIL) (MANAGER-MAIN-WINDOW NIL) (MANAGER-OPEN-WINDOWS NIL) (MANAGER-FILE-MENU NIL) (MANAGER-FILELST-MENU NIL) (MANAGER-FILE-OPERATIONS-MENU NIL) (MANAGER-FILE-FILE-RELATION-MENU NIL) (MANAGER-MARKED-SHADE BOLDMENUFONT)) (FILES FILEBROWSER) (* ; "for SEE command") (FNS MANAGER MANAGER.RESET Manager.ADDADV Manager.ADDTOFILES? Manager.ALTERMARKING Manager.DO.COMMAND Manager.HIGHLIGHT Manager.PROMPT Manager.WINDOW Manager.insurefilehighlights Manager.CHANGED? Manager.CHECKFILE Manager.COLLECTCOMS Manager.COMS.WSF Manager.COMSOPEN Manager.COMSUPDATE Manager.HIGHLIGHTED Manager.INSUREHIGHLIGHTS Manager.FILECHANGES Manager.FILELSTCHANGED? Manager.FILESUBTYPES Manager.GET.ENVIRONMENT Manager.GETFILE Manager.INTITLE? Manager.MAIN.WSF Manager.MAINCLOSE Manager.MAINMENUITEMS Manager.MAINOPEN Manager.MAINUPDATE Manager.MAKEFILE.ADV Manager.MENUCOLUMNS Manager.MENUHASITEM Manager.MENUITEMS Manager.REMOVE.DUPLICATE.ADVICE Manager.RESETSUBITEMS Manager.SORT.COMS Manager.SORTBYCOLUMN) (ADVISE ADDFILE ADDTOFILES? MAKEFILE MARKASCHANGED UNMARKASCHANGED UPDATEFILES ADDTOCOMS DELFROMCOMS \ADDTOFILEBLOCK/ADDNEWCOM LOAD LOADFNS (MARKASCHANGED :IN DEFAULT.EDITDEFA0001)) (MACROS GETDATUM PUTDATUM Manager.TTYCOMMAND) (PROP MANAGER-DEFINITION-TYPE-COMMANDS ADVICE FNS RECORDS VARS FUNCTIONS) (ADDVARS (BackgroundMenuCommands (File% Manager (MANAGER) "Starts the menu driven file manager"))) (P (LSUBST (QUOTE Manager) NIL BackgroundMenuCommands) (* ; "remove old manager entry if it exists") (SETQ BackgroundMenu NIL) (* ; " cause the backGround menu to be rebuilt") (MANAGER.RESET (CL:SYMBOL-VALUE (QUOTE Manager.ACTIVEFLG))) (* ; "Shutdown any old manager windows and restart if we're already running.") (if (STREQUAL MANAGER-ACTIVITY-WINDOW-TITLE (WINDOWPROP NIL (QUOTE TITLE))) then (* ; "If we're in the manager activity window, close it, since we dropped the pointer to it in MANAGER.RESET.") (CLOSEW NIL))) (PROP (MAKEFILE-ENVIRONMENT FILETYPE) MANAGER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA)))) ) (* ;; "The Manager : a menu based interface to the file manager. ") (* ;; "Originally written by: Jay Ferguson of Ford Aerospace & Communications Corp and Robert Noble of Intellicorp. " ) (* ;; "Rewritten by Larry Masinter, winter of 1986.") (* ;; "Further modifications & significant enhancements by Andrew J. Cameron III, summer of 1987.") (* ;; "Ongoing maintenance and performance tuning by Ron Fischer at Xerox AI Systems.") (* ;; "") (* ;; "There are two patches in here that should be removed if Xerox Lisp is fixed. The first is the advice (MARKASCHANGED :IN DEFAULT.EDITDEFA0001) that removes a (mostly) redundant call to MARKASCHANGED in the editor interface, which otherwise slows down manager updates. Somehow this call is not redundant when editing FILELST (perhaps there's a special case for FILELST or when items are not in any existing files). The second is the fns Manager.REMOVE.DUPLICATE.ADVICE called by the advice on LOAD and LOADFNS, which removes redundant advice which would otherwise pile up and cause massive slow downs in manager updates!" ) (* ;; "") (* ;; "The edit history is now kept in the file MANAGER.HISTORY.") (* ;; "") (* ;; "Known bugs and feature requests are now kept in the documentation file MANAGER.TEDIT.") (* ;; "") (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS Manager.ACTIVEFLG MANAGER-CASES MANAGER-ADDTOFILES?) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAMBDAFONT DEFAULTFONT MENUFONT BOLDMENUFONT MANAGER-WINDOWS LOADBFLG SAVEDBFLG MANAGER-ITEM-OPERATION-COMMANDS MANAGER-ITEM-FILE-RELATION-COMMANDS MANAGER-FILE-OPERATIONS-COMMANDS MANAGER-FILE-FILE-RELATION-COMMANDS MANAGER-MAIN-MENU-ITEMS MANAGER-ACTIVITY-WINDOW-TITLE BackgroundMenuCommands BackgroundMenu) ) (RPAQQ *UNMANAGED-TYPES* (EXPRESSIONS FILES FIELDS FILEVARS-ARE-NOW-OK)) (RPAQQ MANAGER-ACTIVITY-WINDOW-TITLE "Manager Command Activity") (RPAQQ MANAGER-CASES NIL) (RPAQQ MANAGER-ADDTOFILES? NIL) (RPAQQ MANAGER-FILE-FILE-RELATION-COMMANDS ((" Delete " (QUOTE DELETE) "Delete this file") ("Rename" (QUOTE RENAME) "Rename this file") ("Copy" (QUOTE COPY) "Copy this item to another file") ("Mark" (QUOTE CHANGED) "Mark this file as being changed") ("Unmark" (QUOTE UNMARK) "Unmark this file as being changed")) ) (RPAQQ MANAGER-FILE-OPERATIONS-COMMANDS (("See" (QUOTE SEE) "Show file in a window" (SUBITEMS ("Fast" (QUOTE SEE) "Show file in a window") (" Scrollable " (QUOTE TEDIT-SEE) "Show file in a scrollable window"))) ("(Re)Load" (QUOTE LOAD) "Load the source of this file" (SUBITEMS ("Load" (QUOTE LOAD) "Load the source of this file") (" SysLoad " (QUOTE SYSLOAD) "SysLoad the file: smashes everything on the way in and is not UNDOable"))) ("MakeFile" (QUOTE MAKEFILE) "Dump the source of this file" (SUBITEMS ("MakeFile" (QUOTE MAKEFILE) "Dump the source of this file, by remaking it") ("New" (QUOTE NEW) "Don't copy any definitions from old version") ("Fast" (QUOTE FAST) "Dump the source without pretty printing") (" CommonLisp " (QUOTE COMMON-MAKEFILE) "Create a .LSP file containing plain CommonLisp source Will load Common-MakeFile if necessary"))) ("List" (QUOTE LIST) "List this file on the default printer") ("CleanUp" (QUOTE CLEANUP) "Dump, list and recompile this file" (SUBITEMS ("CleanUp" (QUOTE CLEANUP) "Dump, list and recompile this file, using the default cleanup compiler") (" Set default: compile-file " CLEANUPC "Change the default cleanup compiler to compile-file; yeilding .dfasl files") ("Set default: TCOMPL" CLEANUPT "Change the default cleanup compiler to TCOMPL; yeilding .LCOM files This compiler will be going away soon"))) ("MasterScope" (QUOTE ANALYZE) "Analyze the FNS on the selected file with MasterScope" (SUBITEMS ("Analyze" (QUOTE ANALYZE) "Analyze the FNS on the selected file with MasterScope") ("Check" (QUOTE CHECK) "Check the file for problems through MasterScope") ("Show Paths" (QUOTE SHOWPATHFILE) "Show all functions called by functions in this file") (" DataBaseFNS " (QUOTE DBFILE) "Display DATABASE property for this file Will load DataBaseFNS if necessary" (SUBITEMS ("Set to Ask" (QUOTE DBFILEASK) "Ask about disposition of MasterScope information when loading and storing this file") ("Set to On" (QUOTE DBFILEON) "Automatically maintain the MasterScope information for this file") ("Set to Off" (QUOTE DBFILEOFF) "Do not automatically maintain the MasterScope information for this file") (" Load DB " (QUOTE LOADDB) "Load this file's MasterScope information, if it exists and make it's upkeep automatic") ("Dump DB" (QUOTE DUMPDB) "Dump this file's MasterScope information, if it exists and make it's upkeep automatic"))))) ("Compile" (QUOTE COMPILE) "Compile this file" (SUBITEMS ("Compile" (QUOTE COMPILE) "InterLisp compiler") (" CL:COMPILE-FILE " (QUOTE CL:COMPILE-FILE) "CommonLisp compiler"))) ("Changes" (QUOTE CHANGES) "Show the changes that have been made to this file." (SUBITEMS ("Brief" (QUOTE CHANGES) "Show the changes that have been made to this file.") (" Everything " (QUOTE PL) "Display everything on this file's property list") ("Edit PL" (QUOTE EDIT) "Edit this file's property list")))) ) (RPAQQ MANAGER-ITEM-FILE-RELATION-COMMANDS ((" Delete " (QUOTE DELETE) "Delete this item") ("EditAll" (QUOTE EDITCALLERS) "Edit occurances of this item's name in its file") ("Rename" (QUOTE RENAME) "Rename this item and update its file with new name" (SUBITEMS ("Rename" (QUOTE RENAME) "Rename this item locally and update its file with new name") ("CopyDef" (QUOTE COPYDEF) "Make a copy with a new name") (" Rename All " (QUOTE RENAME-ALL) "Rename this item in *ALL* loaded files"))) ("Move" (QUOTE MOVE) "Move this item to another file") ("Copy" (QUOTE COPY) "Copy this item to another file") ("Mark" (QUOTE CHANGED) "Mark this item as being changed" (SUBITEMS ("Changed" (QUOTE CHANGED) "Mark item as being CHANGED") (" Defined " (QUOTE DEFINED) "Mark item as being DEFINED") ("Deleted" (QUOTE DELETED) "Mark item as being DELETED"))) ("Unmark" (QUOTE UNMARK) "Unmark this item as being changed")) ) (RPAQQ MANAGER-ITEM-OPERATION-COMMANDS (("Edit" (QUOTE EDIT) "Edit this item") (" PrettyPrint " (QUOTE SHOWDEF) "Show how this item would be written to a file" (SUBITEMS ("Show" (QUOTE SHOWDEF) "Show how this item would be written to a file") ("Value" (QUOTE PV) "Display (Pretty-Print) this item's value") ("Function Def" (QUOTE PF) "Display (Pretty-Print) this item's function definition") (" Property List " (QUOTE PL) "Display this item's property list"))) (" Documentation " (QUOTE CLDOC) "Show the CommonLisp documentation string for this item" (SUBITEMS (" Documentation " (QUOTE CLDOC) "Show the CommonLisp documentation string for this item") (" Describe " (QUOTE CLDESCRIBE) "Show the CommonLisp description of this item")))) ) (RPAQQ MANAGER-MAIN-MENU-ITEMS (("MakeFiles" (QUOTE MAKEFILE) "Update the source of all changed files") ("CleanUp" (QUOTE CLEANUP) "Dump, list and recompile any changed files" (SUBITEMS ("CleanUp" (QUOTE CLEANUP) "Dump, list and recompile any changed files, using the default cleanup compiler") (" Set default: compile-file " (QUOTE CLEANUPC) "Change the default cleanup compiler to compile-file; yielding .dfasl files") ("Set default: TCOMPL" (QUOTE CLEANUPT) "Change the default cleanup compiler to TCOMPL; yielding .LCOM files This compiler will be going away soon"))) ("Changes" (QUOTE CHANGES) "Prints all the changes that have been made") ("MS DataBaseFNS" (QUOTE DB) "Displays the current MasterScope database flags, Will load DataBaseFNS if necessary" (SUBITEMS ("All" (QUOTE DB) "Displays the current MasterScope database flags" (SUBITEMS (" Set to Ask " (QUOTE DBASK) "Ask user when Loading and/or Saving files") ("Set to On" (QUOTE DBON) "Always maintain MasterScope database information") ("Set to Off" (QUOTE DBOFF) "Stop maintaining MasterScope database information"))) ("Load" (QUOTE DB) "Displays the current MasterScope database flags" (SUBITEMS (" Set to Ask " (QUOTE DBLOADASK) "Ask user when Loading files") ("Set to On" (QUOTE DBLOADON) "Maintain MasterScope database information when Loading") ("Set to Off" (QUOTE DBLOADOFF) "Don't load MasterScore information from database files"))) (" Save " (QUOTE DB) "Displays the current MasterScope database flags" (SUBITEMS (" Set to Ask " (QUOTE DBSAVEASK) "Ask user when Saving files") ("Set to On" (QUOTE DBSAVEON) "Maintain MasterScope database information when Loading") ("Set to Off" (QUOTE DBSAVEOFF) "Don't save MasterScore information in database files"))))) ("Files?" (QUOTE FILES?) "Ask for updates and display status of files") ("Add" (QUOTE LOADFNSLATER) "Add a file to the FileManager's menu" (SUBITEMS ("LoadFns" (QUOTE LOADFNSLATER) "Notice a file using LOADFNS" (SUBITEMS (" LoadFns Later " (QUOTE LOADFNSLATER) "Notice a file, but don't load the function defs until needed") ("LoadFns Now" (QUOTE LOADFNSNOW) "Notice a file and loads all it's function defs"))) ("LoadFrom" (QUOTE LOADFROMLATER) "Notice a file using LOADFROM" (SUBITEMS (" LoadFrom Later " (QUOTE LOADFROMLATER) "Notice a file with side-effects, but don't load the function defs until needed") ("LoadFrom Now" (QUOTE LOADFROMNOW) "Notice a file with side-effects and load all it's function defs"))) ("Load" (QUOTE LOAD) "Notice a file by actually LOADing it") ("AddFile" (QUOTE ADDFILE) "Notices a file via ADDFILE (buggy)") ("Edit FILELST" (QUOTE EDIT) "Edit the variable which lists the files noticed by the file package"))) ("Advice" (QUOTE SHOWADVICE) "Display the list of advised or traced fns and functions.") ("Quit" (QUOTE QUIT) "Shut down all manager windows" (SUBITEMS ("Quit" (QUOTE QUIT) "Shut down all manager windows") (" Reset " (QUOTE RESET) "Reset the manager, leaving only the main window open")))) ) (RPAQQ MANAGER.BM #*(72 40)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@LIOOOOOOOOL@@@@@@@@@MEAAAAAAOOL@@@@@@@@@MMMEMEEGOOL@@@@@@@@@MMAEAAGGOOL@@@@@@@@@MMAEAMAGOOL@@@@@@@@@OOOOOAOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@H@@@@@@@@HD@@@@@@@@@IK@@@@@@@DD@@@@@@@@@IEGGE@@@@JD@@@@@@@@FIAEEE@@@@EEOOOOOO@@FIADEE@@@@JEOOOOOO@@FIAGEG@@@@DEOGOOOO@@FH@@@@@@@@HENBCOOO@@FOOOOOOOOOOMOFKOOO@@FH@@@@@@@@HEOFKOOO@@FIL@@@B@@@DEOFCOOO@@FIB@@@B@@@JEOOOOOO@@FILNNNN@@@EEOOOOOO@@DIBBLNN@@@JD@@@@@A@@DIBNFHJ@@@DDLIEHMM@@DILNNNN@@@HEAEEEAA@@DH@@@@@@@@@DIEEIAI@@DOOOOOOOOOOLEEEEAA@@DH@@@@@@@@HEHHIDMM@@DI@B@@F@@@DD@@@@@A@@FIGGGGDNNNJEOOOOOO@@DIEBEEFBHJED@@@@@A@@DIEBDDDNHHJD@@@@@A@@DIECGDDNNNDDNJCIJA@@DH@@@@@@@@HDHJBBAA@@DOOOOOOOOOOLLJCCIA@@D@@@@@@@@@@@HJB@IA@@DDANANDDDDHLHKKKBA@@D@@@@@@@@@@@@@@@@A@@GOOOOOOOOOOOOOOOOO@@ ) (RPAQQ MANAGER.BM.MASK #*(72 40)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@@OOOOOOOOOOL@@@@@@@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@ ) (RPAQ? Manager.ACTIVEFLG NIL) (RPAQ? Manager.SORTFILELSTFLG T) (RPAQ? Manager.MENUROWS 20) (RPAQ? Manager.DATASPACE NIL) (RPAQ? MANAGER-WINDOWS NIL) (RPAQ? MANAGER-MAIN-WINDOW NIL) (RPAQ? MANAGER-OPEN-WINDOWS NIL) (RPAQ? MANAGER-FILE-MENU NIL) (RPAQ? MANAGER-FILELST-MENU NIL) (RPAQ? MANAGER-FILE-OPERATIONS-MENU NIL) (RPAQ? MANAGER-FILE-FILE-RELATION-MENU NIL) (RPAQ? MANAGER-MARKED-SHADE BOLDMENUFONT) (FILESLOAD FILEBROWSER) (* ; "for SEE command") (DEFINEQ (MANAGER [LAMBDA (POSITION) (* ; "Edited 3-Sep-87 13:58 by raf") (* ;;; "Turns manager on if its not already on") (if (OR (NULL Manager.ACTIVEFLG) (NULL MANAGER-MAIN-WINDOW) (Manager.FILELSTCHANGED?)) then (* ;; "If either the manager was off or FILELST changed, rebuild main menu.") (if Manager.ACTIVEFLG then (Manager.MAINCLOSE)) (LET ((Manager.ACTIVEFLG NIL)) (UPDATEFILES)) (if FILELST then (Manager.MAINOPEN POSITION) else (PROMPTPRINT "FILELST is empty; there are no files to manage.")) else (TOTOPW MANAGER-MAIN-WINDOW]) (MANAGER.RESET [LAMBDA (RESTARTFLG) (* ; "Edited 21-Aug-87 11:41 by raf") (* ;;; "Remove all cached menu info, close the main window, clear the global data space. If the RESTARTFLG is true, turn everything on again.") (* ;; "Delete all of the menu caches") (for X in FILEPKGCOMSPLST when (LITATOM X) do (REMPROP X 'MANAGER-ITEM-OPERATION-MENU)) (SETQ MANAGER-MAIN-MENU NIL) (SETQ MANAGER-FILE-OPERATIONS-MENU NIL) (SETQ MANAGER-ITEM-FILE-RELATION-MENU NIL) (SETQ MANAGER-ITEM-OPERATION-MENU NIL) (LET [(REGION (AND RESTARTFLG (WINDOWP MANAGER-MAIN-WINDOW) (WINDOWPROP MANAGER-MAIN-WINDOW 'REGION] (* ;  "Save away the old region (if there was one.") (* ;; "Close the main window and all subwindows.") (Manager.MAINCLOSE T) (* ;; "Clear the data space.") [SETQ Manager.DATASPACE (COPY '((NIL] (if RESTARTFLG then (* ;; "Now turn it all on again.") [MANAGER (AND REGION (create POSITION XCOORD _ (fetch (REGION LEFT) of REGION) YCOORD _ (fetch (REGION BOTTOM) of REGION] else (SETQ Manager.ACTIVEFLG NIL]) (Manager.ADDADV [LAMBDA (!VALUE FILECOMS NAME COMSTYPE) (* ; "Edited 16-Aug-87 22:38 by raf") (* ;;; "Called when any file's COMS are added to or deleted from. For each open subitem window of that file, if we're under ADDTOFILES? save the change, otherwise update the window.") (PROG (FILE SUBITEMS ITEMS) (if (OR (NULL !VALUE) (LISTP FILECOMS)) then (RETURN) else (if [SETQ FILE (for F in FILELST thereis (EQ FILECOMS (FILECOMS F] then (for WINDOW in MANAGER-OPEN-WINDOWS bind STUFF when (AND (OPENWP WINDOW) (EQ [CDR (SETQ STUFF (GETDATUM (CAR (WINDOWPROP WINDOW 'MENU] COMSTYPE) (EQ (CAR STUFF) FILE)) do (if MANAGER-ADDTOFILES? then (pushnew MANAGER-CASES STUFF) else (Manager.COMSOPEN FILE COMSTYPE))) (Manager.RESETSUBITEMS FILE COMSTYPE]) (Manager.ADDTOFILES? [LAMBDA NIL (* lmm "16-Nov-86 23:16") (for CASE in MANAGER-CASES do (Manager.COMSOPEN (CAR CASE) (CDR CASE))) (SETQ MANAGER-CASES NIL]) (Manager.ALTERMARKING [LAMBDA (ITEM TYPE MARKING?) (* ; "Edited 3-Sep-87 16:39 by raf") (* ;;; "Called from MARKSCHANGED or UNMARKASCHANGED.") (COND ((EQ MARKING? 'CLISP) (* ; " ignore") ) ((AND (EQ ITEM 'FILELST) (EQ TYPE 'VARS)) (* ; "FILELST has been edited.") (MANAGER)) ((EQ TYPE 'FILES) (* ; "A whole file has been marked.") (UPDATEFILES)) (T (* ;; "For each manager menu window that's open we look to see if it contains the named definition. We can only update a menu if the window is expanded (and can't see the menu when its window is shrunk).") (for WINDOW in MANAGER-OPEN-WINDOWS bind MENU (UPDATEFILES _ NIL) when [AND (OPENWP WINDOW) (SETQ MENU (CAR (WINDOWPROP WINDOW 'MENU] do (if [AND (Manager.MENUHASITEM ITEM MENU) (EQ TYPE (CDR (GETDATUM MENU] then (SELECTQ MARKING? ((DELETED DEFINED) (SETQ UPDATEFILES T) (Manager.COMSOPEN (CAR (GETDATUM MENU)) TYPE NIL)) (Manager.HIGHLIGHT ITEM MENU MARKING?))) finally (Manager.MAINUPDATE UPDATEFILES]) (Manager.DO.COMMAND (LAMBDA (COMMAND ITEM COMSTYPE FILE MENU) (* ; "Edited 18-Nov-87 14:30 by raf") (if (EQ COMSTYPE (QUOTE FILEVARS)) then (SETQ COMSTYPE (QUOTE VARS)) (* ; "The Manager currently does unnatural things with the FILEVARS type, this is a hack to compensate for it. E.g., editing a FILEVARS = editing the VARS, etc.")) (SELECTQ COMMAND (NIL (* ; "Do nothing.")) (EDIT (WITH-READER-ENVIRONMENT (if FILE then (Manager.GET.ENVIRONMENT FILE) else (MAKE-READER-ENVIRONMENT *PACKAGE* *READTABLE* *READ-BASE*)) (* ; "SEdit does not use *package*. ") (COND ((EQ COMSTYPE (QUOTE FILES)) (ED ITEM (QUOTE PROPERTY-LIST))) ((NULL COMSTYPE) (EDITDEF (QUOTE FILELST) (QUOTE VARS))) (T (EDITDEF ITEM COMSTYPE NIL NIL (QUOTE (:DONTWAIT))))))) (ADD.PROCESS (BQUOTE (CL:APPLY (QUOTE (\, (FUNCTION (LAMBDA (COMMAND ITEM COMSTYPE FILE MENU) (WITH-READER-ENVIRONMENT (if FILE then (Manager.GET.ENVIRONMENT FILE) else (MAKE-READER-ENVIRONMENT *PACKAGE* *READTABLE* *READ-BASE*)) (LET ((ACTIVITY-WINDOW NIL) (ACTIVITY-WINDOW-WAS-SHRUNK NIL)) (RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (if (NOT (FMEMB COMMAND (QUOTE (BREAK TRACE UNBREAK CHANGED DELETED DEFINED UNMARK SEE LIST HARDCOPY REMOVE NIL)))) then (* ; "steal the TTY, if we really need it (there are also further complementary lists at the bottom of the following BLOCK).") (TTYDISPLAYSTREAM (SETQ ACTIVITY-WINDOW (Manager.WINDOW))) (SETQ ACTIVITY-WINDOW-WAS-SHRUNK (NOT (OPENWP ACTIVITY-WINDOW)))) (CL:BLOCK NIL (CL:ECASE COMMAND (READVISE (APPLY* (FUNCTION READVISE) ITEM)) (UNADVISE (APPLY* (FUNCTION UNADVISE) ITEM)) (SHOWADVICE (printout T .FONT LAMBDAFONT "Advised and traced fns and functions:" .FONT DEFAULTFONT T) (for ITEM in ADVISEDFNS do (printout T 10 ITEM T))) (RESET (COND ((MOUSECONFIRM "Reset the Manager destroying all the menus? " NIL T) (CL:FORMAT T "Expunging and reconstructing the Manager's menus~%%Please Stand By.") (MANAGER.RESET T) (CL:FORMAT T "~&Done.~%%-----") (CLOSEW T)))) (QUIT (COND ((MOUSECONFIRM "Quit the Manager? " NIL T) (Manager.MAINCLOSE T) (CLOSEW T)))) (RELOAD (CL:FORMAT T "~&Loading ~A definition of ~S from ~A." ITEM COMSTYPE FILE) (LOADDEF ITEM COMSTYPE FILE)) (SHOWDEF (printout T .FONT LAMBDAFONT COMSTYPE " definition of " ITEM .FONT DEFAULTFONT " (source file format):" T) (SHOWDEF ITEM COMSTYPE)) (BREAK (APPLY* (QUOTE BREAK) ITEM)) (TRACE (EVAL (LIST (QUOTE TRACE) ITEM))) (UNBREAK (EVAL (LIST (QUOTE UNBREAK) ITEM))) (DISASSEMBLE (printout T .FONT LAMBDAFONT "Compiled code for " ITEM ":" .FONT DEFAULTFONT T) (INSPECTCODE ITEM)) (PV (printout T .FONT LAMBDAFONT "Value of " ITEM ":" .FONT DEFAULTFONT T (if (BOUNDP ITEM) then (EVAL ITEM) else "Not bound!"))) (PF (printout T .FONT LAMBDAFONT "Function definition of " ITEM ":" .FONT DEFAULTFONT T) (PF ITEM)) (PL (printout T .FONT LAMBDAFONT "Property list for " ITEM ":" .FONT DEFAULTFONT T) (PRINTPROPS (if (EQ COMSTYPE (QUOTE PROPS)) then (CAR ITEM) else ITEM))) (CLDESCRIBE (printout T .FONT LAMBDAFONT "Description of " ITEM ":" .FONT DEFAULTFONT T) (CL:DESCRIBE ITEM)) (CLDOC (printout T .FONT LAMBDAFONT "Documentation for " ITEM ":" .FONT DEFAULTFONT T) (CL:DOCUMENTATION ITEM)) (FIELDS (printout T .FONT LAMBDAFONT "Fields of " ITEM ":" .FONT DEFAULTFONT T (REVERSE (RECORDFIELDNAMES ITEM)))) (ARGS (printout T .FONT LAMBDAFONT "Arguments of " ITEM ": " .FONT DEFAULTFONT T 10 (SMARTARGLIST ITEM) T)) (EDITCALLERS (EDITCALLERS ITEM FILE)) (COPYDEF (LET ((FILENAME (Manager.PROMPT (CONCAT "Rename " ITEM " to: ")))) (if FILENAME then (COPYDEF ITEM FILENAME COMSTYPE)))) (RENAME (LET ((FILENAME (Manager.PROMPT (CONCAT "Rename " ITEM " to: ")))) (if FILENAME then (RENAME ITEM FILENAME COMSTYPE FILE)))) (RENAME-ALL (LET ((FILENAME (Manager.PROMPT (CONCAT "Rename " ITEM " to: ")))) (if FILENAME then (RENAME ITEM FILENAME COMSTYPE FILELST)))) (DELETE (if (MOUSECONFIRM (CONCAT "DELETE the " COMSTYPE " " ITEM " from " FILE "?")) then (DELFROMFILES ITEM COMSTYPE FILE))) (LOAD (LET ((FILENAME (Manager.PROMPT "Filename: "))) (if FILENAME then (LOAD FILENAME)))) (LOADFNSLATER (LET ((FILENAME (Manager.PROMPT "Filename: "))) (if FILENAME then (LOADFNS NIL FILENAME (QUOTE ALLPROP) (QUOTE VARS))))) (LOADFNSNOW (LET ((FILENAME (Manager.PROMPT "Filename: "))) (if FILENAME then (LOADFNS T FILENAME (QUOTE ALLPROP) (QUOTE VARS))))) (LOADFROMLATER (LET ((FILENAME (Manager.PROMPT "Filename: "))) (if FILENAME then (LOADFROM FILENAME)))) (LOADFROMNOW (LET ((FILENAME (Manager.PROMPT "Filename: "))) (if FILENAME then (LOADFROM FILENAME T)))) (ADDFILE (LET ((FILENAME (Manager.PROMPT "Filename: "))) (if FILENAME then (ADDFILE FILENAME)))) (SYSLOAD (COND ((MOUSECONFIRM (CONCAT "Do you really want to SYSLOAD " FILE "?" NIL T)) NIL (LOAD FILE (QUOTE SYSLOAD))))) (MOVE (LET ((ANSWER (Manager.GETFILE (CONCAT "File to move " COMSTYPE " " ITEM " to")))) (AND ANSWER (MOVETOFILE ANSWER ITEM COMSTYPE FILE)))) (COPY (LET ((ANSWER (Manager.GETFILE (CONCAT "File to copy " COMSTYPE " " ITEM " to")))) (AND ANSWER (ADDTOFILE ITEM COMSTYPE ANSWER)))) ((CHANGED DELETED DEFINED) (if COMSTYPE then (MARKASCHANGED ITEM COMSTYPE COMMAND) else (MARKASCHANGED (FILECOMS ITEM) (QUOTE VARS) COMMAND) (UPDATEFILES) (* ; "This is needed because the main menu is a special case. Its not in the open windows list, nor does it carry %"type%" information (like that it contains filevars)."))) (UNMARK (if (EQ COMSTYPE (QUOTE FILES)) then (* ; "whole file") (COND ((MOUSECONFIRM (CONCAT "Unmark entire contents of " FILE "?" NIL T)) (/RPLACD (GETPROP FILE (QUOTE FILE)) NIL) (Manager.insurefilehighlights FILE) (Manager.HIGHLIGHT FILE MENU))) else (* ; "single item") (UNMARKASCHANGED ITEM COMSTYPE))) (SEE (FB.FASTSEE.ONEFILE FILE (LET ((W (CREATEW NIL (CONCAT "Seeing " FILE "...")))) (DSPSCROLL (QUOTE ON) W) (WINDOWPROP W (QUOTE PAGEFULLFN) (QUOTE FB.SEEFULLFN)) (TTYDISPLAYSTREAM W) W))) (LOAD (printout T .FONT LAMBDAFONT "Loading file " FILE "." .FONT DEFAULTFONT T) (LOAD FILE)) ((MAKEFILE NEW FAST) (if FILE then (printout T .FONT LAMBDAFONT "Writing file " FILE "." .FONT DEFAULTFONT T) (PRINT (MAKEFILE FILE (if (EQ COMMAND (QUOTE MAKEFILE)) then NIL else COMMAND)) T) else (printout T .FONT LAMBDAFONT "Writing files ") (PRINT (MAKEFILES (if (EQ COMMAND (QUOTE MAKEFILE)) then NIL else (LIST COMMAND)))) (printout T .FONT DEFAULTFONT T))) (COMMON-MAKEFILE (FILESLOAD (QUOTE COMMON-MAKEFILE)) (if FILE then (printout T .FONT LAMBDAFONT "Writing CommonLisp source into " FILE ".LSP" .FONT DEFAULTFONT T) (PRINT (USER::COMMON-MAKEFILE FILE) T) else (CL:FORMAT T "~&CommonLispify must be selected separately for each file"))) ((LIST HARDCOPY) (LISTFILES1 FILE)) (CLEANUP (printout T .FONT LAMBDAFONT "Cleanup..." .FONT DEFAULTFONT T) (* ; "These are different, presumably because CLEANUP is an NLAMBDA.") (if FILE then (APPLY* (FUNCTION CLEANUP) FILE) else (CLEANUP))) (CLEANUPT (printout T .FONT LAMBDAFONT "Changing default cleanup compiler:" .FONT DEFAULTFONT T "Old value " *DEFAULT-CLEANUP-COMPILER* T "New value: " (SETQ *DEFAULT-CLEANUP-COMPILER* (QUOTE TCOMPL)) T)) (CLEANUPC (printout T .FONT LAMBDAFONT "Changing default cleanup compiler:" .FONT DEFAULTFONT T "Old value " *DEFAULT-CLEANUP-COMPILER* T "New value: " (SETQ *DEFAULT-CLEANUP-COMPILER* (QUOTE COMPILE-FILE)) T)) (* ;; " Masterscope stuff") (ANALYZE (printout T .FONT LAMBDAFONT "Analyzing the file " FILE " with MasterScope..." .FONT DEFAULTFONT T) (MASTERSCOPE (BQUOTE (ANALYZE FNS ON %, FILE)))) (CHECK (printout T .FONT LAMBDAFONT "Checking the file " FILE " with MasterScope..." .FONT DEFAULTFONT T) (MASTERSCOPE (BQUOTE (CHECK %, FILE)))) (DESCRIBE (SELECTQ COMSTYPE (VARS (CL:FORMAT T "~&~a is used by:~%% ~a" ITEM (MASTERSCOPE (BQUOTE (WHO USES (QUOTE (\, ITEM))))))) (PROGN NIL (printout T .FONT LAMBDAFONT "MasterScope analysis of " ITEM ":" .FONT DEFAULTFONT T) (MSDESCRIBE ITEM)))) (SHOWPATHTO (printout T .FONT LAMBDAFONT "Showing who calls " ITEM " with MasterScope..." .FONT DEFAULTFONT T) (MASTERSCOPE (BQUOTE (SHOW PATHS TO %, ITEM)))) (SHOWPATHFROM (printout T .FONT LAMBDAFONT "Showing who is called by " ITEM " with MasterScope..." .FONT DEFAULTFONT T) (MASTERSCOPE (BQUOTE (SHOW PATHS FROM %, ITEM)))) (SHOWPATHFILE (printout T .FONT LAMBDAFONT "Showing who is called by functions in the file " ITEM " with MasterScope..." .FONT DEFAULTFONT T) (MASTERSCOPE (BQUOTE (SHOW PATHS FROM ON %, FILE)))) (* ;; "DATABASEFNS stuff") (DB (FILESLOAD (QUOTE DATABASEFNS)) (CL:FORMAT T "~&Global DataBaseFNS Flags:~%%SAVEDBFLG = ~a, LOADDBFLG = ~a" SAVEDBFLG LOADBFLG)) (DBFILE (FILESLOAD (QUOTE DATABASEFNS)) (CL:FORMAT T "~&The DATABASE prop for ~a is: ~a" FILE (GETPROP FILE (QUOTE DATABASE))) (CL:FORMAT T "~&Global DataBaseFNS Flags:~%%SAVEDBFLG = ~a, LOADDBFLG = ~a" SAVEDBFLG LOADBFLG)) (DBON (FILESLOAD (QUOTE DATABASEFNS)) (SETQ LOADBFLG (QUOTE ON)) (SETQ SAVEDBFLG (QUOTE ON))) (DBOFF (FILESLOAD (QUOTE DATABASEFNS)) (SETQ LOADBFLG (QUOTE OFF)) (SETQ SAVEDBFLG (QUOTE OFF))) (DBASK (FILESLOAD (QUOTE DATABASEFNS)) (SETQ LOADBFLG (QUOTE ASK)) (SETQ SAVEDBFLG (QUOTE ASK))) (DBLOADON (FILESLOAD (QUOTE DATABASEFNS)) (SETQ LOADBFLG (QUOTE ON))) (DBSAVEON (FILESLOAD (QUOTE DATABASEFNS)) (SETQ SAVEDBFLG (QUOTE ON))) (DBLOADOFF (FILESLOAD (QUOTE DATABASEFNS)) (SETQ LOADBFLG (QUOTE OFF))) (DBSAVEOFF (FILESLOAD (QUOTE DATABASEFNS)) (SETQ SAVEDBFLG (QUOTE OFF))) (DBLOADASK (FILESLOAD (QUOTE DATABASEFNS)) (SETQ LOADBFLG (QUOTE ASK))) (DBSAVEASK (FILESLOAD (QUOTE DATABASEFNS)) (SETQ SAVEDBFLG (QUOTE ASK))) (DBFILEON (FILESLOAD (QUOTE DATABASEFNS)) (PUTPROP FILE (QUOTE DATABASE) (QUOTE ON))) (DBFILEOFF (FILESLOAD (QUOTE DATABASEFNS)) (PUTPROP FILE (QUOTE DATABASE) (QUOTE OFF))) (DBFILEASK (FILESLOAD (QUOTE DATABASEFNS)) (PUTPROP FILE (QUOTE DATABASE) (QUOTE ASK))) (DUMPDB (printout T .FONT LAMBDAFONT "Dumping the Masterscope Database for file " FILE .FONT DEFAULTFONT T) (FILESLOAD (QUOTE DATABASEFNS)) (DUMPDB FILE)) (LOADDB (printout T .FONT LAMBDAFONT "Loading the Masterscope Database for file " FILE .FONT DEFAULTFONT T) (FILESLOAD (QUOTE DATABASEFNS)) (LOADDB FILE)) (COMPILE (printout T .FONT LAMBDAFONT "Compiling..." .FONT DEFAULTFONT T) (if (EQ COMSTYPE (QUOTE FILES)) then (APPLY* (FUNCTION COMPILEFILES) FILE) (Manager.REMOVE.DUPLICATE.ADVICE FILE) else (PRINT (CL:COMPILE ITEM) T))) (CL:COMPILE-FILE (printout T .FONT LAMBDAFONT "Compiling using compile-file..." .FONT DEFAULTFONT T) (CL:COMPILE-FILE FILE) (Manager.REMOVE.DUPLICATE.ADVICE FILE)) (REMOVE (DELDEF FILE (QUOTE FILE))) (CHANGES (* ; "FILE is NIL from main menu") (Manager.CHANGED? FILE)) (FILES? (printout T .FONT LAMBDAFONT "Files and their changes:" .FONT DEFAULTFONT T) (FILES?))) (* ;; "Relase the window now, but get ready to shrink it back down unless another manager command comes along and need the window.") (if (NOT (FMEMB COMMAND (QUOTE (BREAK TRACE UNBREAK CHANGED DELETED DEFINED UNMARK SEE LIST HARDCOPY REMOVE QUIT RESET RENAME COPY NIL)))) then (CL:FORMAT T "~&------")))) (* ;; "Shink the dialog window after ten seconds so long as its not in use by another manager command.") (if ACTIVITY-WINDOW-WAS-SHRUNK then (if (FMEMB COMMAND (QUOTE (SHOWDEF SHOWADVICE PV PF PL CLDESCRIBE CLDOC FIELDS ARGS DB DBFILE MAKEFILE NEW FAST COMMON-MAKEFILE CLEANUPT CLEANUPC CLEANUP ANALYZE CHECK DESCRIBE CHANGES FILES? COMPILE CL:COMPILE NIL))) then (DISMISS 10000) else (DISMISS NIL)) (if (EQ ACTIVITY-WINDOW (CAR MANAGER-WINDOWS)) then (SHRINKW T))))))))) (QUOTE ((\, COMMAND) (\, ITEM) (\, COMSTYPE) (\, FILE) (\, MENU))))) (QUOTE NAME) (QUOTE MANAGER-COMMAND))) NIL) ) (Manager.HIGHLIGHT [LAMBDA (ITEM MENU ON) (* ; "Edited 31-Jul-87 17:33 by raf") (SHADEITEM (SASSOC ITEM (fetch ITEMS of MENU)) MENU (if ON then MANAGER-MARKED-SHADE else 0]) (Manager.PROMPT [LAMBDA (PROMPT) (* ; "Edited 17-Aug-87 14:31 by raf") (LET (W (Manager.WINDOW)) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (PROG1 (MKATOM (PROMPTFORWORD PROMPT NIL NIL W)) (printout W T]) (Manager.WINDOW [LAMBDA NIL (* ; "Edited 21-Aug-87 12:04 by raf") (* ;;; "Make a window for manager activity, and set TTYDISPLAYSTREAM into it.") (LET [(W (OR (pop MANAGER-WINDOWS) (CREATEW NIL MANAGER-ACTIVITY-WINDOW-TITLE] (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (W) (AND (OPENWP W) (TERPRI W)) (push MANAGER-WINDOWS W] W)) (TTYDISPLAYSTREAM W) W]) (Manager.insurefilehighlights [LAMBDA (FILE) (* ; "Edited 26-Jun-87 16:30 by andyiii") (* ;  "insures open menus of a file are correctly highlighted") (SETQ FILE (ROOTFILENAME FILE)) (for WINDOW in MANAGER-OPEN-WINDOWS bind MENU when (AND (OPENWP WINDOW) (EQ [CAR (GETDATUM (SETQ MENU (CAR (WINDOWPROP WINDOW 'MENU] FILE)) do [if (EQUAL (Manager.COLLECTCOMS FILE (CDR (GETDATUM MENU))) (fetch (MENU ITEMS) of MENU)) then (Manager.COMSUPDATE WINDOW) (* ; "no change in contents") else (Manager.COMSOPEN FILE (CDR (GETDATUM MENU] (* ; "contents changed") ]) (Manager.CHANGED? [LAMBDA (FILES) (* ; "Edited 26-Jun-87 03:42 by andyiii") (bind CHANGES for FILE inside (OR FILES FILELST) first (TERPRI T) when [SETQ CHANGES (CDR (GETPROP FILE 'FILE] do (printout T .FONT LAMBDAFONT "Changes to " FILE .FONT DEFAULTFONT T) (for CHANGE in CHANGES do (printout T (CAR CHANGE) ":" 10 .PARA 10 0 (CDR CHANGE) T]) (Manager.CHECKFILE [LAMBDA (FILE) (* ; "Edited 17-Aug-87 14:26 by raf") (* ;;; "If called from ADDTOFILES? (special flag indicates this) and the file being checked is on the main menu, checks all of a particular FILE's submenus, otherwise rebuilds the main (FILELST) menu. Called from advice on ADDFILE, ADDTOFILES? and LOAD.") (if (AND (NULL MANAGER-ADDTOFILES?) (Manager.MENUHASITEM FILE MANAGER-FILE-MENU)) then (SETQ FILE (ROOTFILENAME FILE)) [for WINDOW in MANAGER-OPEN-WINDOWS bind MENU when [AND (OPENWP WINDOW) (EQ [CAR (GETDATUM (SETQ MENU (CAR (WINDOWPROP WINDOW 'MENU] FILE) (NOT (EQUAL (Manager.COLLECTCOMS FILE (CDR (GETDATUM MENU))) (fetch (MENU ITEMS) of MENU] do (Manager.COMSOPEN FILE (CDR (GETDATUM MENU] else (MANAGER) (Manager.RESETSUBITEMS FILE]) (Manager.COLLECTCOMS [LAMBDA (FILE TYPE) (* ; "Edited 16-Aug-87 22:13 by raf") (* ;;; "Collect all the names of a particular type in a file, returning them in correct menu item format.") (PROG ((COMSLST (FILECOMSLST FILE TYPE))) (RETURN (Manager.SORTBYCOLUMN (COND ((NULL COMSLST) (RETURN)) ((EQ TYPE 'VARS) (for VAR in COMSLST bind (FILEVARS _ (FILECOMSLST FILE 'FILEVARS)) when (NOT (FMEMB VAR FILEVARS)) collect (* ;; "List of item to get around menu feature that list's first item is used for display.") (LIST VAR))) (T (* ;; "List of item to get around menu feature that list's first item is used for display.") (MAPCAR (INTERSECTION COMSLST COMSLST) (FUNCTION LIST]) (Manager.COMS.WSF [LAMBDA (ITEM MENU KEY) (* ; "Edited 25-Jun-87 02:00 by andyiii") (SETQ ITEM (CAR ITEM)) (* ; "Menu items handed in are list of item to get around menu feature that list has first item used to display!") (PROG (FILE COMSTYPE COMSLST FILECOMS COMMAND) (DECLARE (SPECVARS ITEM COMSTYPE)) (if (NULL ITEM) then (RETURN)) (if (.COPYKEYDOWNP.) then (RETURN (BKSYSBUF.GENERAL ITEM))) (SETQ COMSLST (GETDATUM MENU)) (SETQ FILE (CAR COMSLST)) (SETQ COMSTYPE (CDR COMSLST)) [SETQ COMMAND (MENU (SELECTQ KEY (LEFT [OR (GETPROP COMSTYPE 'MANAGER-ITEM-OPERATION-MENU) [AND (GETPROP COMSTYPE 'MANAGER-DEFINITION-TYPE-COMMANDS) (PUTPROP COMSTYPE 'MANAGER-ITEM-OPERATION-MENU (create MENU ITEMS _ (APPEND MANAGER-ITEM-OPERATION-COMMANDS (GETPROP COMSTYPE ' MANAGER-DEFINITION-TYPE-COMMANDS )) CENTERFLG _ T TITLE _ (CONCAT COMSTYPE " operations") CHANGEOFFSETFLG _ 'Y] MANAGER-ITEM-OPERATION-MENU (SETQ MANAGER-ITEM-OPERATION-MENU (create MENU ITEMS _ MANAGER-ITEM-OPERATION-COMMANDS CENTERFLG _ T TITLE _ (CONCAT COMSTYPE " operations") CHANGEOFFSETFLG _ 'Y]) (MIDDLE (OR MANAGER-ITEM-FILE-RELATION-MENU (create MENU ITEMS _ MANAGER-ITEM-FILE-RELATION-COMMANDS CENTERFLG _ T TITLE _ "Other operations" CHANGEOFFSETFLG _ 'Y))) (SHOULDNT] (if COMMAND then (Manager.DO.COMMAND COMMAND ITEM COMSTYPE FILE]) (Manager.COMSOPEN [LAMBDA (FILE TYPE FLASHFLG) (* ; "Edited 16-Aug-87 22:30 by raf") (* ;;; "Open a subitems window. If it already exists, and all subitems of this type have been deleted, close the window, otherwise open it, flash and check the highlights. If the file's subitems for this type have changed, then rebuild the menu. ") (PROG ((COMSLST (Manager.COLLECTCOMS FILE TYPE)) (COMSTYPE (FILECOMS FILE TYPE)) MENU WINDOW POSITION) (COND [COMSLST (COND ([AND (SETQ MENU (GETDATUM COMSTYPE)) (EQUAL (fetch (MENU ITEMS) of MENU) COMSLST) (SETQ WINDOW (OR (WFROMMENU MENU) (for W in MANAGER-OPEN-WINDOWS thereis (EQ (WINDOWPROP W 'COMSTYPE) COMSTYPE] (COND (FLASHFLG (FLASHWINDOW WINDOW 2)) (T (TOTOPW WINDOW))) (Manager.INSUREHIGHLIGHTS MENU (Manager.FILECHANGES FILE TYPE))) (T (* ;; "make sure all the title is visible. This is hard since the menu does not exist yet.") (SETQ MENU (create MENU ITEMS _ COMSLST MENUCOLUMNS _ (  Manager.MENUCOLUMNS COMSLST) WHENSELECTEDFN _ (FUNCTION Manager.COMS.WSF) MENUOUTLINESIZE _ 0)) (COND ((SETQ WINDOW (WFROMMENU (GETDATUM COMSTYPE))) (SETQ POSITION (with REGION (WINDOWPROP WINDOW 'REGION) (create POSITION XCOORD _ LEFT YCOORD _ BOTTOM)) ) (CLOSEW WINDOW))) [ADDMENU MENU (SETQ WINDOW (CREATEW [with MENU MENU (LET ((IW (WIDTHIFWINDOW IMAGEWIDTH)) (IH (HEIGHTIFWINDOW IMAGEHEIGHT T))) (with POSITION (OR POSITION (GETBOXPOSITION IW IH)) (create REGION LEFT _ XCOORD WIDTH _ IW BOTTOM _ YCOORD HEIGHT _ IH] (CONCAT TYPE " on " FILE] [WINDOWPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) [PUTDATUM (CAR (WINDOWPROP WINDOW 'MENU] (PUTDATUM (WINDOWPROP WINDOW 'COMSTYPE)) (SETQ MANAGER-OPEN-WINDOWS (DREMOVE WINDOW MANAGER-OPEN-WINDOWS] (for ITEM in (Manager.FILECHANGES FILE TYPE) do (Manager.HIGHLIGHT ITEM MENU T)) (PUTDATUM COMSTYPE MENU) (PUTDATUM MENU (CONS FILE TYPE)) (push MANAGER-OPEN-WINDOWS WINDOW) (WINDOWPROP WINDOW 'COMSTYPE COMSTYPE] ((SETQ WINDOW (WFROMMENU (GETDATUM COMSTYPE))) (CLOSEW WINDOW]) (Manager.COMSUPDATE [LAMBDA (WINDOW FLASHFLG) (* ; "Edited 16-Aug-87 22:30 by raf") (* ;;; "Open a window (if closed) and update the coms listed on the menu therein. If items are the same, their highlighting is checked, otherwise the menu is rebuilt.") (PROG ([MENU (CAR (WINDOWPROP WINDOW 'MENU] CHANGELST FILE TYPE) (SETQ FILE (CAR (GETDATUM MENU))) (SETQ TYPE (CDR (GETDATUM MENU))) (SETQ CHANGELST (Manager.FILECHANGES FILE TYPE)) [COND [(NULL (OPENWP WINDOW)) (if (OPENWP (WINDOWPROP WINDOW 'ICONWINDOW)) then (EXPANDW (WINDOWPROP WINDOW 'ICONWINDOW] (T (if FLASHFLG then (FLASHWINDOW WINDOW 2) else (TOTOPW WINDOW] (COND ((EQUAL (fetch (MENU ITEMS) of MENU) (Manager.COLLECTCOMS FILE TYPE)) (Manager.INSUREHIGHLIGHTS MENU CHANGELST)) (T (Manager.COMSOPEN FILE TYPE]) (Manager.HIGHLIGHTED [LAMBDA (MENU) (* ; "Edited 9-Jul-87 13:57 by raf") (for X in (fetch (MENU SHADEDITEMS) of MENU) collect (CAR (CAR (NTH (fetch (MENU ITEMS) of MENU) (CAR X]) (Manager.INSUREHIGHLIGHTS [LAMBDA (MENU SHOULD-BE-HIGHLIGHTED) (* ; "Edited 26-Jun-87 18:10 by andyiii") (LET ((HIGH (Manager.HIGHLIGHTED MENU))) (if (WFROMMENU MENU) then (REDISPLAYW (WFROMMENU MENU))) (for ITEM in HIGH when (NOT (FMEMB ITEM SHOULD-BE-HIGHLIGHTED)) do (Manager.HIGHLIGHT ITEM MENU NIL)) (for ITEM in SHOULD-BE-HIGHLIGHTED when (NOT (FMEMB ITEM HIGH)) do (Manager.HIGHLIGHT ITEM MENU T]) (Manager.FILECHANGES [LAMBDA (FILE COMSTYPE) (* ; "Edited 26-Jun-87 04:35 by andyiii") (CDR (FASSOC (if (EQ COMSTYPE 'FILEVARS) then 'VARS else COMSTYPE) (CDR (GETPROP FILE 'FILE]) (Manager.FILELSTCHANGED? [LAMBDA NIL (* ; "Edited 17-Aug-87 14:16 by raf") (NOT (EQUAL (if Manager.SORTFILELSTFLG then (SORT (COPY FILELST)) else FILELST) (Manager.MENUITEMS MANAGER-FILE-MENU]) (Manager.FILESUBTYPES [LAMBDA (FILE) (* ; "Edited 16-Aug-87 22:05 by raf") (* ;;; "Gather the names of all subtypes in a file's coms.") (for TYPE in FILEPKGTYPES bind COMSLST when (AND (NOT (FMEMB TYPE *UNMANAGED-TYPES*)) (SETQ COMSLST (FILECOMSLST FILE TYPE)) (if (EQ TYPE 'VARS) then (for VAR in COMSLST bind (FILEVARS _ (FILECOMSLST FILE 'FILEVARS)) thereis (NOT (FMEMB VAR FILEVARS))) else T)) collect TYPE]) (Manager.GET.ENVIRONMENT [LAMBDA (FILE) (* ; "Edited 26-Jun-87 18:53 by andyiii") (* ;; "Get's a file's environment, either from the cache in the makefile-environment property (which we initialize here if it hasn't been already) or as per the defaulting described in the Lyric release notes:") (* ;; "cache property exists? use it,") (* ;; "new file? use *DEFAULT-MAKEFILE-ENVIRONMENT*,") (* ;; "old file which has environment in it? use environment from old file,") (* ;; "otherwise use an interlisp style environment.") (LET [(ENVIRONMENT (OR (GETPROP FILE 'MAKEFILE-ENVIRONMENT) (PUTPROP FILE 'MAKEFILE-ENVIRONMENT (LET ((DATE (FILEDATE FILE))) (if (NULL DATE) then *DEFAULT-MAKEFILE-ENVIRONMENT* else (LET [(FORM (CL:WITH-OPEN-FILE (STREAM (OR (FINDFILE FILE) (CL:ERROR "Can't find file ~s to get its environment" FILE))) (LET ((*READTABLE* (FIND-READTABLE "OLD-INTERLISP-FILE" )) (*PACKAGE* (CL:FIND-PACKAGE "INTERLISP"))) (CL:READ STREAM] (if (EQ 'DEFINE-FILE-INFO (CAR FORM)) then (CDR FORM) else '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10] (APPLY #'MAKE-READER-ENVIRONMENT (CL:MAPCAR #'[LAMBDA (KEY TYPE COERCE) (LET [(VALUE (EVAL (CL:GETF ENVIRONMENT KEY] (if (TYPEP VALUE TYPE) then VALUE else (CL:FUNCALL COERCE VALUE] '(:PACKAGE :READTABLE :BASE) '(PACKAGE CL:READTABLE INTEGER) '(CL:FIND-PACKAGE FIND-READTABLE CL:IDENTITY]) (Manager.GETFILE [LAMBDA (PROMPT PASSED-IN-FILE-LIST) (* ; "Edited 17-Aug-87 14:32 by raf") (LET ((FILE-LIST (OR PASSED-IN-FILE-LIST FILELST))) [COND ((OR (NULL (CAR MANAGER-FILELST-MENU)) (Manager.FILELSTCHANGED?)) (* ; "what is this doing ???") (SETQ MANAGER-FILELST-MENU (create MENU TITLE _ PROMPT ITEMS _ (CONS '*newfile* FILE-LIST) WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU KEY) (PROG (ANSWER FILECOMS) (COND ((EQ ITEM '*newfile*) (SETQ ANSWER (  Manager.PROMPT "New file Name: " )) (ADDFILE ANSWER ) (RETURN ANSWER) ) (T (RETURN ITEM] (MENU MANAGER-FILELST-MENU]) (Manager.INTITLE? [LAMBDA (WINDOW) (* edited%: "31-Dec-00 16:40") (PROG (INTERIOR.HEIGHT REGION MENU) [SETQ MENU (CAR (WINDOWPROP WINDOW 'MENU] (SETQ INTERIOR.HEIGHT (FONTPROP (OR (fetch MENUTITLEFONT of MENU) (fetch MENUFONT of MENU)) 'HEIGHT)) (with REGION (WINDOWPROP WINDOW 'REGION) (SETQ REGION (CREATEREGION LEFT (IDIFFERENCE TOP INTERIOR.HEIGHT) WIDTH INTERIOR.HEIGHT))) (RETURN (INSIDEP REGION LASTMOUSEX LASTMOUSEY]) (Manager.MAIN.WSF [LAMBDA (ITEM MENU KEY) (DECLARE (SPECVARS ITEM)) (* ; "Edited 31-Jul-87 18:25 by raf") (PROG NIL [if (.COPYKEYDOWNP.) then (RETURN (COPYINSERT (CAR ITEM] (LET ((SLIDEOFFITEM (EQLENGTH ITEM 3))) (* ; "A slideoff subitem was selected.") (SETQ ITEM (CADR ITEM)) (SELECTQ KEY (MIDDLE (COND ((NOT SLIDEOFFITEM) (Manager.DO.COMMAND [MENU (OR MANAGER-FILE-FILE-RELATION-MENU (create MENU ITEMS _ MANAGER-FILE-FILE-RELATION-COMMANDS CENTERFLG _ T TITLE _ "Other operations" CHANGEOFFSETFLG _ 'Y] (CAR ITEM) 'FILES (CAR ITEM) MENU)) (T (FLASHWINDOW (WFROMMENU MENU) 1)))) (LEFT (COND (SLIDEOFFITEM (Manager.COMSOPEN (CAR ITEM) (CDR ITEM) T)) (T (* ; "Standard selection.") (Manager.DO.COMMAND [MENU (OR MANAGER-FILE-OPERATIONS-MENU (SETQ MANAGER-FILE-OPERATIONS-MENU (create MENU ITEMS _ MANAGER-FILE-OPERATIONS-COMMANDS CENTERFLG _ T TITLE _ "File operations"] (CAR ITEM) 'FILES (CAR ITEM) MENU)))) (FLASHWINDOW (WFROMMENU MENU) 1]) (Manager.MAINCLOSE [LAMBDA (SHUTDOWNFLG) (* ; "Edited 20-Aug-87 16:18 by raf") (PROG (MENU ICON.WINDOW) (for WINDOW in (APPEND MANAGER-OPEN-WINDOWS) when (OR SHUTDOWNFLG (NOT (FMEMB [CAR (GETDATUM (CAR (WINDOWPROP WINDOW 'MENU] FILELST))) do (CLOSEW WINDOW)) (if (SETQ ICON.WINDOW (WINDOWPROP MANAGER-MAIN-WINDOW 'ICON)) then (CLOSEW ICON.WINDOW)) (if SHUTDOWNFLG then (if (SETQ ICON.WINDOW (WINDOWPROP MANAGER-MAIN-WINDOW 'ICON)) then (CLOSEW ICON.WINDOW)) (AND MANAGER-MAIN-WINDOW (CLOSEW MANAGER-MAIN-WINDOW)) (SETQ MANAGER-MAIN-WINDOW NIL)) (for WINDOW in MANAGER-WINDOWS do (if SHUTDOWNFLG then (EXPANDW WINDOW)) (CLOSEW WINDOW)) (if SHUTDOWNFLG then (SETQ MANAGER-WINDOWS NIL]) (Manager.MAINMENUITEMS [LAMBDA NIL (* ; "Edited 17-Aug-87 14:14 by raf") (* ;;; "Returns the menu 'items' for the main manager file menu. This is, for each file, the menu element and the subitems which contain all of the 'types' . If there is already a file menu, we reuse the subitems rather than recomputing them.") (for FILE in (if Manager.SORTFILELSTFLG then (SORT (COPY FILELST)) else FILELST) collect `(%, FILE (%, FILE . FILEVARS) %, (CONCAT "Brings up a File Operations menu for the file " FILE) (SUBITEMS %,@ (for TYPE in (SORT (Manager.FILESUBTYPES FILE)) collect `(%, TYPE (%, FILE %,@ TYPE) %, (CONCAT "Creates a " TYPE " submenu for the file " FILE]) (Manager.MAINOPEN [LAMBDA (POSITION) (* ; "Edited 17-Aug-87 13:59 by raf") (* ;;; "Builds the manager main (FILELST) menu at the indicated position.") (SETQ MANAGER-FILE-MENU (create MENU ITEMS _ (Manager.MAINMENUITEMS) WHENSELECTEDFN _ (FUNCTION Manager.MAIN.WSF) MENUCOLUMNS _ 1 MENUOUTLINESIZE _ 0)) (LET (IW IH) (* ;; "some of the complexity here is so that, in the odd case that there are more files than will fit on the screen, the result will be a scrollable window") (ADDMENU MANAGER-FILE-MENU (SETQ MANAGER-MAIN-WINDOW (CREATEW (with POSITION (with MENU MANAGER-FILE-MENU (SETQ IW (MIN (WIDTHIFWINDOW IMAGEWIDTH) SCREENWIDTH)) (* ;  "width of file menu. Actually unlikely to be wider than screenwidth (!)") (SETQ IH (MIN (HEIGHTIFWINDOW IMAGEHEIGHT T) SCREENHEIGHT)) (* ;  "height of window; could possibly be higher than screen if lots of files") (if (POSITIONP POSITION) then (* ;  "gave an initial position for the manager file menu") POSITION elseif (WINDOWP MANAGER-MAIN-WINDOW) then (* ;  "if there was a window, put the new one in the same place (and close the old one)") (PROG1 (with REGION (WINDOWPROP MANAGER-MAIN-WINDOW 'REGION) (create POSITION XCOORD _ LEFT YCOORD _ BOTTOM )) (CLOSEW MANAGER-MAIN-WINDOW)) else (* ;  "let user say where to put the menu") (GETBOXPOSITION IW IH))) (create REGION LEFT _ XCOORD WIDTH _ IW BOTTOM _ YCOORD HEIGHT _ IH)) "Manager"))) [WINDOWPROP MANAGER-MAIN-WINDOW 'BUTTONEVENTFN (FUNCTION (LAMBDA (WINDOW) (if (Manager.INTITLE? WINDOW) then [Manager.DO.COMMAND (MENU (OR MANAGER-MAIN-MENU (SETQ MANAGER-MAIN-MENU (create MENU TITLE _ "Manager operations" ITEMS _ MANAGER-MAIN-MENU-ITEMS CENTERFLG _ T] else (MENUBUTTONFN WINDOW] (* ;; "Shrink to the manager icon, and remember to update when the expanding") [WINDOWPROP MANAGER-MAIN-WINDOW 'ICONFN (FUNCTION (LAMBDA (WIN OICON) (LET ((IW (if (NULL OICON) then (ICONW MANAGER.BM MANAGER.BM.MASK) else OICON))) [WINDOWPROP IW 'EXPANDFN (FUNCTION (LAMBDA NIL (  Manager.MAINUPDATE NIL] IW] (SETQ Manager.ACTIVEFLG T) (Manager.MAINUPDATE T]) (Manager.MAINUPDATE [LAMBDA (FROMUPDATE) (* ; "Edited 16-Aug-87 21:34 by raf") (* ;;; "Updates the highlighting of the main (FILELST) menu. Does not handle adding or removing of names from FILELST. Typically called after Manager.ALTERMARKING.") (if (NOT FROMUPDATE) then (LET ((Manager.ACTIVEFLG NIL)) (UPDATEFILES))) (Manager.INSUREHIGHLIGHTS MANAGER-FILE-MENU (for ITEM in (Manager.MENUITEMS MANAGER-FILE-MENU) when (CDR (GETPROP ITEM 'FILE)) collect ITEM]) (Manager.MAKEFILE.ADV [LAMBDA (FILE OPTIONS) (* ; "Edited 20-Aug-87 15:04 by raf") (* ;;; "After MAKEFILE(FILE), clear out all of file's marks") (LET ((OPTIONS (OR OPTIONS CLEANUPOPTIONS))) (if [if (LISTP OPTIONS) then (INTERSECTION '(ST STF) OPTIONS) else (FMEMB OPTIONS '(ST STF] then (* ;  "If we stored definitions (I.E. advice) remove duplicate advice.") (Manager.REMOVE.DUPLICATE.ADVICE FILE))) (bind MENU (FILENAME _ (ROOTFILENAME FILE)) for WINDOW in MANAGER-OPEN-WINDOWS when (AND (OPENWP WINDOW) (EQ [CAR (GETDATUM (SETQ MENU (CAR (WINDOWPROP WINDOW 'MENU] FILENAME)) do (Manager.INSUREHIGHLIGHTS MENU NIL) finally (Manager.HIGHLIGHT FILENAME MANAGER-FILE-MENU NIL]) (Manager.MENUCOLUMNS [LAMBDA (ITEMSLST) (* ; "Edited 27-May-87 17:26 by raf") (PROG (NUMBER.COLUMNS MAX.ROW.WIDTH (BORDER 1)) [SETQ MAX.ROW.WIDTH (IPLUS BORDER BORDER (for NAME in ITEMSLST largest (STRINGWIDTH NAME MENUFONT) finally (RETURN $$EXTREME] (SETQ NUMBER.COLUMNS (ADD1 (IQUOTIENT (SUB1 (LENGTH ITEMSLST)) Manager.MENUROWS))) [if (IGREATERP (ITIMES NUMBER.COLUMNS MAX.ROW.WIDTH) SCREENWIDTH) then (SETQ NUMBER.COLUMNS (MAX 1 (QUOTIENT SCREENWIDTH MAX.ROW.WIDTH] (RETURN NUMBER.COLUMNS]) (Manager.MENUHASITEM [LAMBDA (ITEM MENU) (* ; "Edited 31-Jul-87 17:33 by raf") (* ;  "Elaborate member check, since menu items are nested in an extra list to display properly.") (SASSOC ITEM (fetch ITEMS of MENU]) (Manager.MENUITEMS [LAMBDA (MENU) (* ; "Edited 9-Jul-87 14:06 by raf") (for ITEM in (fetch (MENU ITEMS) MANAGER-FILE-MENU) collect (CAR ITEM]) (Manager.REMOVE.DUPLICATE.ADVICE [LAMBDA (FILE) (* ; "Edited 20-Aug-87 13:45 by raf") (* ;;; "Removes (some) duplicated advice when a source file is loaded. A patch to the behavior of advice loading. This is here mostly for the convenience of the Manager implementors, since its not fully general.") (for ADVICE in (FILECOMSLST FILE 'ADVICE) do (LET [(DEFINITIONS (GETDEF ADVICE 'ADVICE 'CURRENT] (bind (CHANGED _ NIL) while (AND (GREATERP (LENGTH DEFINITIONS) 1) (EQUAL (CAR DEFINITIONS) (CADR DEFINITIONS))) do (* ;  "Note that this only checks duplications at the front of the list of advice.") (pop DEFINITIONS) (SETQ CHANGED T) finally (if CHANGED then (LET ((Manager.ACTIVEFLG NIL)) (* ;  "Turn this off so we don't see the updates animate.") (PUTDEF ADVICE 'ADVICE DEFINITIONS) (UNMARKASCHANGED ADVICE 'ADVICE]) (Manager.RESETSUBITEMS [LAMBDA (FILE COMSTYPE) (* ; "Edited 16-Aug-87 22:06 by raf") (* ;;; "Rebuilds the subitems slide off menu for a given file if they've actually changed.") (AND FILE (PROG (ITEMS MENU.ITEMS SUBTYPES) (SETQ MENU.ITEMS (FASSOC FILE (fetch (MENU ITEMS) of MANAGER-FILE-MENU))) (SETQ ITEMS (NTH MENU.ITEMS 4)) (SETQ SUBTYPES (Manager.FILESUBTYPES FILE)) (if [AND ITEMS (OR (NULL COMSTYPE) (if (FASSOC COMSTYPE (CDAR ITEMS)) then (NULL (FMEMB COMSTYPE SUBTYPES)) else (FMEMB COMSTYPE SUBTYPES] then (RPLACA ITEMS `(SUBITEMS %,@ (for TYPE in SUBTYPES collect `(%, TYPE (%, FILE %,@ TYPE) %, (CONCAT "Creates a " TYPE " submenu for the file " FILE]) (Manager.SORT.COMS (LAMBDA (A B) (* ; "Edited 18-Nov-87 15:12 by raf") (* ;;; "This allows CLOS method definitions to display in a sorted fashion.") (* ;;; "They are stored on the fileCOMS variable as:") (* ;;; "(method-name (required-arg-type-specifiers))") (ALPHORDER (COND ((LITATOM A) A) (T (CONCAT A))) (COND ((LITATOM B) B) (T (CONCAT B))))) ) (Manager.SORTBYCOLUMN [LAMBDA (ITEMS) (* ; "Edited 19-Jun-87 20:58 by andyiii") (PROG ((LNGTH (FLENGTH ITEMS)) COLUMNCOUNT COLUMNLENGTH EXTRAITEMCOLUMNS RESULT) (if (NULL ITEMS) then (RETURN)) (SORT ITEMS 'Manager.SORT.COMS) (SETQ COLUMNCOUNT (Manager.MENUCOLUMNS ITEMS)) (SETQ COLUMNLENGTH (IQUOTIENT LNGTH COLUMNCOUNT)) (SETQ EXTRAITEMCOLUMNS (IREMAINDER LNGTH COLUMNCOUNT)) [SETQ RESULT (for I to COLUMNCOUNT collect (for J to (COND ((ILEQ I EXTRAITEMCOLUMNS) (ADD1 COLUMNLENGTH)) (COLUMNLENGTH)) collect (pop ITEMS] (RETURN (while (CAR RESULT) join (DREMOVE NIL (for LST on RESULT collect (PROG1 (CAAR LST) (RPLACA LST (CDAR LST]) ) (XCL:REINSTALL-ADVICE (QUOTE ADDFILE) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (AND Manager.ACTIVEFLG (Manager.CHECKFILE FILE))))))) (XCL:REINSTALL-ADVICE (QUOTE ADDTOFILES?) :AROUND (QUOTE ((:LAST (PROG1 (LET ((MANAGER-ADDTOFILES? T)) *) (AND Manager.ACTIVEFLG (Manager.ADDTOFILES?))))))) (XCL:REINSTALL-ADVICE (QUOTE MAKEFILE) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (AND Manager.ACTIVEFLG (Manager.MAKEFILE.ADV FILE OPTIONS))))))) (XCL:REINSTALL-ADVICE (QUOTE MARKASCHANGED) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (AND Manager.ACTIVEFLG (Manager.ALTERMARKING NAME TYPE (OR REASON T)))))))) (XCL:REINSTALL-ADVICE (QUOTE UNMARKASCHANGED) :AROUND (QUOTE ((:LAST (LET (!VALUE) (PROG1 (LET ((Manager.ACTIVEFLG NIL)) (SETQ !VALUE *)) (AND Manager.ACTIVEFLG !VALUE (Manager.ALTERMARKING NAME TYPE NIL)))))))) (XCL:REINSTALL-ADVICE (QUOTE UPDATEFILES) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (AND Manager.ACTIVEFLG (Manager.MAINUPDATE T))))))) (XCL:REINSTALL-ADVICE (QUOTE ADDTOCOMS) :AROUND (QUOTE ((:LAST (LET (!VALUE) (PROG1 (LET ((Manager.ACTIVEFLG NIL)) (SETQ !VALUE *)) (AND Manager.ACTIVEFLG (Manager.ADDADV !VALUE COMS NAME TYPE)))))))) (XCL:REINSTALL-ADVICE (QUOTE DELFROMCOMS) :AROUND (QUOTE ((:LAST (LET (!VALUE) (PROG1 (LET ((Manager.ACTIVEFLG NIL)) (SETQ !VALUE *)) (AND Manager.ACTIVEFLG (Manager.ADDADV !VALUE COMS NAME TYPE)))))))) (XCL:REINSTALL-ADVICE (QUOTE \ADDTOFILEBLOCK/ADDNEWCOM) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (AND Manager.ACTIVEFLG (Manager.RESETSUBITEMS FILE TYPE))))))) (XCL:REINSTALL-ADVICE (QUOTE LOAD) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (if Manager.ACTIVEFLG then (Manager.REMOVE.DUPLICATE.ADVICE FILE) (Manager.CHECKFILE FILE))))))) (XCL:REINSTALL-ADVICE (QUOTE LOADFNS) :AROUND (QUOTE ((:LAST (PROG1 (LET ((Manager.ACTIVEFLG NIL)) *) (if Manager.ACTIVEFLG then (Manager.REMOVE.DUPLICATE.ADVICE FILE) (Manager.CHECKFILE FILE))))))) (XCL:REINSTALL-ADVICE (QUOTE (MARKASCHANGED :IN DEFAULT.EDITDEFA0001)) :AROUND (QUOTE ((:LAST (AND (AND (EQ NAME (QUOTE FILELST)) (EQ TYPE (QUOTE VARS))) *))))) (READVISE ADDFILE ADDTOFILES? MAKEFILE MARKASCHANGED UNMARKASCHANGED UPDATEFILES ADDTOCOMS DELFROMCOMS \ADDTOFILEBLOCK/ADDNEWCOM LOAD LOADFNS (MARKASCHANGED :IN DEFAULT.EDITDEFA0001)) (DECLARE%: EVAL@COMPILE (PUTPROPS GETDATUM MACRO ((KEY) (CDR (FASSOC KEY Manager.DATASPACE)))) (PUTPROPS PUTDATUM MACRO ((KEY VALUE) (PUTASSOC KEY VALUE Manager.DATASPACE))) (PUTPROPS Manager.TTYCOMMAND MACRO ((X . Y) (PROGN (ALLOW.BUTTON.EVENTS) X . Y))) ) (PUTPROPS ADVICE MANAGER-DEFINITION-TYPE-COMMANDS (("ReAdvise" (QUOTE READVISE) "Enable all advice under this name") ("UnAdvise" (QUOTE UNADVISE) "Disable all advice under this name")) ) (PUTPROPS FNS MANAGER-DEFINITION-TYPE-COMMANDS (("Break" (QUOTE BREAK) "Break this function") ("Trace" (QUOTE TRACE) "Trace this function") ("UNBreak" (QUOTE UNBREAK) "UnBreak this function") ("Compile" (QUOTE COMPILE) "Compile this function" (SUBITEMS ("Compile" (QUOTE COMPILE) "Compile this function") (DISASSEMBLE (QUOTE DISASSEMBLE) " Print the compiled code of the function"))) (" MasterScope " (QUOTE DESCRIBE) "Invoke MasterScope to DESCRIBE the function" (SUBITEMS (" Describe " (QUOTE DESCRIBE) "Invoke MasterScope to describe this function") ("Show Paths" (QUOTE SHOWPATHTO) "Invoke MasterScope to show who calls this function" (SUBITEMS ("To" (QUOTE SHOWPATHTO) "Invoke MasterScope to show who calls this function") (" From " (QUOTE SHOWPATHFROM) "Invoke MasterScope to show who is called by this function"))))) ("?=" (QUOTE ARGS) "The function's argument list")) ) (PUTPROPS RECORDS MANAGER-DEFINITION-TYPE-COMMANDS (("Fields" (QUOTE FIELDS) "List the field names")) ) (PUTPROPS VARS MANAGER-DEFINITION-TYPE-COMMANDS ((" MasterScope " (QUOTE DESCRIBE) "Who uses this?" (SUBITEMS ("Who uses?" (QUOTE DESCRIBE) "Who uses this?")))) ) (PUTPROPS FUNCTIONS MANAGER-DEFINITION-TYPE-COMMANDS (("Break" (QUOTE BREAK) "Break this function") ("Trace" (QUOTE TRACE) "Trace this function") ("UNBreak" (QUOTE UNBREAK) "UnBreak this function") ("Compile" (QUOTE COMPILE) "Compile this function" (SUBITEMS ("Compile" (QUOTE COMPILE) "Compile this function") ("Disassemble" (QUOTE DISASSEMBLE) " Print the compiled code of the function"))) ("?=" (QUOTE ARGS) "The function's argument list")) ) (ADDTOVAR BackgroundMenuCommands (File% Manager (MANAGER) "Starts the menu driven file manager")) (LSUBST (QUOTE Manager) NIL BackgroundMenuCommands) (* ; "remove old manager entry if it exists") (SETQ BackgroundMenu NIL) (* ; " cause the backGround menu to be rebuilt") (MANAGER.RESET (CL:SYMBOL-VALUE (QUOTE Manager.ACTIVEFLG))) (* ; "Shutdown any old manager windows and restart if we're already running.") (if (STREQUAL MANAGER-ACTIVITY-WINDOW-TITLE (WINDOWPROP NIL (QUOTE TITLE))) then (* ; "If we're in the manager activity window, close it, since we dropped the pointer to it in MANAGER.RESET.") (CLOSEW NIL)) (PUTPROPS MANAGER MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (PUTPROPS MANAGER FILETYPE :COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS MANAGER COPYRIGHT ("Xerox Corporation" 1986 1987 1900)) (DECLARE%: DONTCOPY (FILEMAP (NIL (16604 71487 (MANAGER 16614 . 17353) (MANAGER.RESET 17355 . 18950) (Manager.ADDADV 18952 . 20130) (Manager.ADDTOFILES? 20132 . 20402) (Manager.ALTERMARKING 20404 . 21943) (Manager.DO.COMMAND 21945 . 33442) (Manager.HIGHLIGHT 33444 . 33694) (Manager.PROMPT 33696 . 34010) (Manager.WINDOW 34012 . 34637) (Manager.insurefilehighlights 34639 . 35586) (Manager.CHANGED? 35588 . 36148) ( Manager.CHECKFILE 36150 . 37231) (Manager.COLLECTCOMS 37233 . 38716) (Manager.COMS.WSF 38718 . 41158) (Manager.COMSOPEN 41160 . 45672) (Manager.COMSUPDATE 45674 . 46786) (Manager.HIGHLIGHTED 46788 . 47124 ) (Manager.INSUREHIGHLIGHTS 47126 . 47690) (Manager.FILECHANGES 47692 . 47982) ( Manager.FILELSTCHANGED? 47984 . 48283) (Manager.FILESUBTYPES 48285 . 48911) (Manager.GET.ENVIRONMENT 48913 . 51571) (Manager.GETFILE 51573 . 53874) (Manager.INTITLE? 53876 . 54538) (Manager.MAIN.WSF 54540 . 57049) (Manager.MAINCLOSE 57051 . 58084) (Manager.MAINMENUITEMS 58086 . 59049) ( Manager.MAINOPEN 59051 . 63894) (Manager.MAINUPDATE 63896 . 64619) (Manager.MAKEFILE.ADV 64621 . 65658 ) (Manager.MENUCOLUMNS 65660 . 66548) (Manager.MENUHASITEM 66550 . 66900) (Manager.MENUITEMS 66902 . 67150) (Manager.REMOVE.DUPLICATE.ADVICE 67152 . 68575) (Manager.RESETSUBITEMS 68577 . 69884) ( Manager.SORT.COMS 69886 . 70239) (Manager.SORTBYCOLUMN 70241 . 71485))))) STOP \ No newline at end of file diff --git a/lispusers/MANAGER.HISTORY b/lispusers/MANAGER.HISTORY new file mode 100644 index 00000000..8b2000e2 --- /dev/null +++ b/lispusers/MANAGER.HISTORY @@ -0,0 +1 @@ +This is a history of edits made to the Manager. Please add your initials and a short description of what you changed to the END of the file. Be sure to include the name of the definition you modified. andyiii- All menus are sorted now. andyiii - Appropiate sub-menu update when something is changed that they contain. andyiii- un-marking a file in the main menu now works and updates all the sub-menus of that file. andyiii - added option to MAKEFILE menu item for files to write CommonLisp source using common-makefile. andyiii - added commonlisp DESCRIBE for items andyiii - Added a way to add files to the file managers main menu andyiii - Can edit files property list from CHANGES menu andyiii - Can now mark a whole file from main menu andyiii - Can chose between TCOMPL (.LCOM files) and compile-file (.dfasl files) This is awkard since is uses the global variable *default-cleanup-compiler* andyiii - Can get CommonLisp documentation string and descriptons andyiii - Can now PrettyPrint a value, function def, or prop list and also show how the item would be written to a file andyiii - Cleaned up specialized menus for FNS, FUNCTIONS, VARS and PROPS andyiii - All dialog now goes through the MANAGER ACTIVITY WINDOW RAF 7/31/87 - Fixed the rename option to not specify a source file, uses the ? search (core then file). RAF 7/31/87 - Added an "edit all occurances of item's name" option to file relations menu. RAF 7/31/87 - Manager.ACTIVEFLG is now a special that is bound by all advice to avoid redundant updates inside of themselves. This is a big speed improvement! RAF 7/31/87 - Fixed Manager.HASITEM and Manager.HIGHLIGHT to use SASSOC, so that list items in menus get highlighted properly. RAF 7/31/87 - Middle button on Manager file menu now brings up rename, etc. Used to bring up coms to edit (inconsistent). RAF 7/31/87 - Main menu flashes if bad button/command is given. RAF 8/4/87 - MANAGER-ADDTOFILES? now initialized to NIL, reducing redundant updates. RAF 8/14/87 - In Manager.ALTERMARKING: removed extra code which tracked the files containing updated menus. Removed call to Manager.CHECKFILE. Made call to Manager.MAINUPDATE pass T if the reason for marking was DEFINED or DELETED; these cases also call Manager.COMSOPEN. RAF 8/15/87 - In Manager.DO.COMMAND: moved binding of ACTIVITY-WINDOW-WAS-SHRUNK into the form eval'ed in the process where references are made. Moved setting of ACTIVITY-WINDOW-WAS-SHRUNK after the spot where its referent ACTIVITY-WINDOW is initialized. RAF 8/16/87 - Advice for LOAD and LOADFNS now call Manager.CHECKFILE instead of Manager.MAINUPDATE (latter only does highlight updating, former can rebuild main menu). Advice for ADDTOFILES? now doesn't disable manager inside of its advised form, so that the ADDTOCOMS and DELFROMCOMS advice will work. RAF 8/17/87 - Added Manager.FILELSTCHANGED? (which is tricky, since sorting in the main menu changes its order). Manager.CHECKFILE now tests whether the file being checked is in the main menu. If not the main menu is rebuilt. MANAGER fns disables manager around its call to UPDATEFILES. Manager.GETFILE takes a prompt argument (which is now passed in by Manager.DO.COMMAND). RAF 8/18/87 - Manager.REMOVE.DUPLICATE.ADVICE now disables the manager when it manipulates the advice (to avoid animating the changes in the menus). The advice on LOAD and LOADFNS now call Manager.REMOVE.DUPLICATE.ADVICE. RAF 8/20/87 - Fixed Manager.MAKEFILE.ADV to handle atomic cleanup options. Also made the top level Manager.RESET call take Manager.ACTIVEFLG, so that manager stays on when reloaded if it was on already. Manager.REMOVE.DUPLICATE.ADVICE now removes *all* duplicates of the first piece of advice (rather than only the second). RAF 8/21/87 - Made MANAGER-WINDOWS be an initvar so that Manager.RESET from top level sees the right thing on first startup. RAF 9/2/87 - Changed the manager shrunken bitmap to something more respectable. Added ADVISE and UNADVISE menu options for the ADVICE definer. Added a "Show all advice in effect" option to the manager main window middle button menu. Changed the messages printed out by Manager.DO.COMMAND to all use printout and lambdafont for highlighting. RAF 9/3/87 - Added a clause in the startup fns MANAGER which reports when FILELST is empty and manager can't start. Also fixed a bug in where marking a file didn't bold the main menu entry (added an updatefiles in Manager.ALTERMARKING). Also caused the advice on the "redundant" call to (MARKASCHANGED :IN DEFAULT.EDITDEFA0001) to fire when FILELST is being edited (seems it was the only way to call markaschanged in that one case). RAF 11/18/87 - Changed the call to EDITDEF in Manager.DO.COMMAND to include a :DONTWAIT option. The tracks a change in SEdit for the Mototwn release. RAF 11/18/87 - Added some type checking to the sort testing function Manager.SORT.COMS so that it doesn't convert its arguments to strings unless they're not LITATOMS. This should make menu generation alot faster. \ No newline at end of file diff --git a/lispusers/MANAGER.TEDIT b/lispusers/MANAGER.TEDIT new file mode 100644 index 00000000..d5391516 Binary files /dev/null and b/lispusers/MANAGER.TEDIT differ diff --git a/lispusers/MANDELBROT b/lispusers/MANDELBROT new file mode 100644 index 00000000..bd906582 --- /dev/null +++ b/lispusers/MANDELBROT @@ -0,0 +1 @@ +(FILECREATED "23-Feb-86 16:20:47" {ERIS}LISPCORE>MANDELBROT.;2 11810 changes to: (VARS MANDELBROTCOMS) (FNS MANDELBROT MANDELBROT.KOUNT MANDELBROT.DORADO.KOUNT) previous date: "21-Aug-85 13:21:38" {ERIS}LISPCORE>MANDELBROT.;1) (* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MANDELBROTCOMS) (RPAQQ MANDELBROTCOMS ((INITVARS (MANDELBROT.WINDOW NIL) (MANDELBROT.LIMIT 32)) (FNS MANDELBROT MANDELBROT.BUTTONEVENTFN MANDELBROT.KOUNT MANDELBROT.DORADO.KOUNT MANDELBROT.COLOR GRADCOLORMAP) (P (COND ((NOT (EQ (MACHINETYPE) (QUOTE DANDELION))) (MOVD (QUOTE MANDELBROT.DORADO.KOUNT) (QUOTE MANDELBROT.KOUNT))))))) (RPAQ? MANDELBROT.WINDOW NIL) (RPAQ? MANDELBROT.LIMIT 32) (DEFINEQ (MANDELBROT (LAMBDA (REGION WINDOW) (* kbr: "23-Feb-86 16:02") (PROG (MAXX MAXY MAXCOLOR RCORNER ICORNER GAP RC IC KOUNT COLOR) (COND ((NULL REGION) (SETQ REGION (create REGION LEFT _ -1.5 BOTTOM _ -1.0 WIDTH _ 3.0 HEIGHT _ 2.0)))) (COND ((NULL WINDOW) (COND ((NULL MANDELBROT.WINDOW) (SETQ MANDELBROT.WINDOW (CREATEW NIL "MANDELBROT")))) (SETQ WINDOW MANDELBROT.WINDOW))) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ RCORNER (fetch (REGION LEFT) of REGION)) (SETQ ICORNER (fetch (REGION BOTTOM) of REGION)) (SETQ GAP (FMAX (FQUOTIENT (fetch (REGION WIDTH) of REGION) MAXX) (FQUOTIENT (fetch (REGION HEIGHT) of REGION) MAXY))) (COND ((WINDOWP WINDOW) (WINDOWPROP WINDOW (QUOTE RCORNER) RCORNER) (WINDOWPROP WINDOW (QUOTE ICORNER) ICORNER) (WINDOWPROP WINDOW (QUOTE GAP) GAP) (WINDOWPROP WINDOW (QUOTE TITLE) (create REGION LEFT _ RCORNER BOTTOM _ ICORNER WIDTH _(FTIMES MAXX GAP) HEIGHT _(FTIMES MAXY GAP))) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION MANDELBROT.BUTTONEVENTFN)))) (for Y from MAXY to 0 by -1 do (SETQ IC (FPLUS ICORNER (FTIMES Y GAP))) (for X from 0 to MAXX do (SETQ RC (FPLUS RCORNER (FTIMES X GAP))) (SETQ KOUNT (MANDELBROT.KOUNT RC IC)) (SETQ COLOR (MANDELBROT.COLOR KOUNT MAXCOLOR)) (BITMAPBIT WINDOW X Y COLOR)))))) (MANDELBROT.BUTTONEVENTFN (LAMBDA (WINDOW) (* kbr: "27-Jul-85 15:31") (PROG (REGION RCORNER ICORNER GAP NEWRCORNER NEWICORNER NEWREGION) (SETQ REGION (GETREGION)) (SETQ RCORNER (WINDOWPROP WINDOW (QUOTE RCORNER))) (SETQ ICORNER (WINDOWPROP WINDOW (QUOTE ICORNER))) (SETQ GAP (WINDOWPROP WINDOW (QUOTE GAP))) (SETQ NEWRCORNER (FPLUS RCORNER (FTIMES (IDIFFERENCE (fetch (REGION LEFT) of REGION) (DSPXOFFSET NIL WINDOW)) GAP))) (SETQ NEWICORNER (FPLUS ICORNER (FTIMES (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) (DSPYOFFSET NIL WINDOW)) GAP))) (SETQ NEWREGION (create REGION LEFT _ NEWRCORNER BOTTOM _ NEWICORNER WIDTH _ (FTIMES (fetch (REGION WIDTH) of REGION) GAP) HEIGHT _ (FTIMES (fetch (REGION HEIGHT) of REGION) GAP))) (MANDELBROT NEWREGION WINDOW)))) (MANDELBROT.KOUNT (LAMBDA (RC IC) (* kbr: "23-Feb-86 16:13") (* Calculate KOUNT for imaginary number C=RC+ICi. *) (PROG (LOCALRC LOCALIC RZ IZ RZ2 IZ2 NEWRZ KOUNT) (DECLARE (TYPE FLOATP RC IC LOCALRC LOCALIC RZ IZ RZ2 IZ2 NEWRZ)) (* Unbox now instead of in loop. *) (SETQ LOCALRC RC) (SETQ LOCALIC IC) (* Z=RZ+IZ. RZ2=RZ^2. IZ2=IZ^2. Initially, Z=0. *) (SETQ RZ 0.0) (SETQ IZ 0.0) (SETQ RZ2 0.0) (SETQ IZ2 0.0) (* Keep setting Z:=Z^2+C until absolute value of Z exceeds 2.0 KOUNTing number of times this takes. If KOUNT would reach infinity, then C is in the Mandelbrot set. We assume C is in the Mandelbrot set if C reaches MANDELBROT.LIMIT *) (SETQ KOUNT (for KOUNT from 1 to (SUB1 MANDELBROT.LIMIT) do (* AR4125: FMINUS does not compile as UFNEGATE. So we use FDIFFERENCE instead. *) (SETQ NEWRZ (FPLUS (FDIFFERENCE RZ2 IZ2) LOCALRC)) (SETQ IZ (FPLUS (FTIMES 2.0 IZ RZ) LOCALIC)) (SETQ RZ NEWRZ) (SETQ RZ2 (FTIMES RZ RZ)) (SETQ IZ2 (FTIMES IZ IZ)) (COND ((UFGREATERP2 (FPLUS RZ2 IZ2) 4.0) (RETURN KOUNT))) finally (RETURN MANDELBROT.LIMIT))) (RETURN KOUNT)))) (MANDELBROT.DORADO.KOUNT (LAMBDA (RC IC) (* kbr: "23-Feb-86 16:15") (* Calculate KOUNT for imaginary number C=RC+ICi. *) (PROG (LOCALRC LOCALIC RZ IZ RZ2 IZ2 NEWRZ KOUNT) (* Unbox now instead of in loop. *) (SETQ LOCALRC RC) (SETQ LOCALIC IC) (* Z=RZ+IZ. RZ2=RZ^2. IZ2=IZ^2. Initially, Z=0. *) (SETQ RZ 0.0) (SETQ IZ 0.0) (SETQ RZ2 0.0) (SETQ IZ2 0.0) (* Keep setting Z:=Z^2+C until absolute value of Z exceeds 2.0 KOUNTing number of times this takes. If KOUNT would reach infinity, then C is in the Mandelbrot set. We assume C is in the Mandelbrot set if C reaches MANDELBROT.LIMIT *) (SETQ KOUNT (for KOUNT from 1 to (SUB1 MANDELBROT.LIMIT) do (* AR4125: FMINUS does not compile as UFNEGATE. So we use FDIFFERENCE instead. *) (SETQ NEWRZ (FPLUS (FDIFFERENCE RZ2 IZ2) LOCALRC)) (SETQ IZ (FPLUS (FTIMES 2.0 IZ RZ) LOCALIC)) (SETQ RZ NEWRZ) (SETQ RZ2 (FTIMES RZ RZ)) (SETQ IZ2 (FTIMES IZ IZ)) (COND ((FGREATERP (FPLUS RZ2 IZ2) 4.0) (RETURN KOUNT))) finally (RETURN MANDELBROT.LIMIT))) (RETURN KOUNT)))) (MANDELBROT.COLOR (LAMBDA (KOUNT MAXCOLOR) (* kbr: "21-Aug-85 13:14") (* Choose appropriate color for this KOUNT. *) (COND ((EQ KOUNT MANDELBROT.LIMIT) MAXCOLOR) (T (IMOD KOUNT MAXCOLOR))))) (GRADCOLORMAP (LAMBDA (BITSPERPIXEL) (* kbr: "23-Jul-85 19:52") (PROG (MAXCOLOR COLORMAP M V) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ COLORMAP (COLORMAPCREATE NIL BITSPERPIXEL)) (SETQ M (IQUOTIENT MAXCOLOR 6)) (for I from 0 to M do (SETQ V (IQUOTIENT (ITIMES 255 I) (SUB1 M))) (SETA COLORMAP I (LIST 0 0 V)) (SETA COLORMAP (IDIFFERENCE (ITIMES 2 M) I) (LIST 0 0 V)) (SETA COLORMAP (IPLUS (ITIMES 2 M) I) (LIST 0 V 0)) (SETA COLORMAP (IDIFFERENCE (ITIMES 4 M) I) (LIST 0 V 0)) (SETA COLORMAP (IPLUS (ITIMES 4 M) I) (LIST V 0 0)) (SETA COLORMAP (IDIFFERENCE (ITIMES 6 M) I) (LIST V 0 0))) (for I from (ADD1 (ITIMES 6 M)) to MAXCOLOR do (SETA COLORMAP I (ELT COLORMAP (ITIMES 6 M)))) (RETURN COLORMAP)))) ) (COND ((NOT (EQ (MACHINETYPE) (QUOTE DANDELION))) (MOVD (QUOTE MANDELBROT.DORADO.KOUNT) (QUOTE MANDELBROT.KOUNT)))) (PUTPROPS MANDELBROT COPYRIGHT ("Xerox Corporation" 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1033 11572 (MANDELBROT 1043 . 3622) (MANDELBROT.BUTTONEVENTFN 3624 . 4742) ( MANDELBROT.KOUNT 4744 . 7476) (MANDELBROT.DORADO.KOUNT 7478 . 10081) (MANDELBROT.COLOR 10083 . 10427) (GRADCOLORMAP 10429 . 11570))))) STOP \ No newline at end of file diff --git a/lispusers/MATHSERVER b/lispusers/MATHSERVER new file mode 100644 index 00000000..02f0953f --- /dev/null +++ b/lispusers/MATHSERVER @@ -0,0 +1 @@ +(FILECREATED "15-Apr-87 10:54:01" {IVY}LISP>MATHSERVER.;1 129647 changes to: (METHODS Server.ExecuteCommandFile) (FNS Server.ExecuteCommandFile MS.TopLevel MS.ExpandFilename MS.SubmitBatchJob MS.RunInteractiveJob MS.Compile MS.Link MS.CompileLink MS.CompileLinkRun MS.StartDefaultFE) (VARS MATHSERVERCOMS) previous date: "12-Dec-86 19:13:28" {PHYLUM}KOTO>MATHSERVER.;1) (* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MATHSERVERCOMS) (RPAQQ MATHSERVERCOMS ((* * SERVER MENU - Sets up the main Server Free Menu) (* MENU AND WINDOW FUNCTIONS) (FNS MS.TopLevel MS.CreateFreeMenu MS.SelectHost MS.ExpandFilename MS.CloseErrorWindow MS.CleanupErrorFile MS.AttachErrorWindow MS.MostRoom MS.GetMessageWindow MS.MakeIconWindow PrintMsg) (* SERVER METACLASS FUNCTIONS) (FNS MS.MakeMenuOfKnownHosts MS.DestroyInstances) (* MATH SERVER FUNCTIONS) (FNS MS.SubmitBatchJob MS.AbortBatchJob MS.Status MS.DisplayStatus MS.RunInteractiveJob MS.Compile MS.Link MS.CompileLink MS.CLR.Check MS.CLR.NoCheck MS.CompileLinkRun) (* FORTRAN EDITOR FUNCTIONS) (FNS MS.StartNewFE MS.StartDefaultFE MS.FindFortranEdit MS.CheckForDirtyFile) (* ERROR HANDLING FUNCTIONS) (FNS MS.BatchErrors? MS.BatchLog) (* Icon BITMAPS) (BITMAPS MS.Icon MS.IconMask) (* VARS) (ADDVARS (BackgroundMenuCommands (Server% Menu (QUOTE (MS.TopLevel)) "Start the Server Menu"))) (VARS (BackgroundMenu NIL)) (GLOBALVARS MS.HostPopMenu) (* * FORTRAN EDIT - Sets up a Fortran Edit Process) (* MAIN FUNCTIONS) (FNS FE.TopLevel FE.AdjustProps FE.CaretPosition TEDIT.PARA&CHAR FE.CharFn FE.GetEditProps FE.GetSourceFileName FE.LoopFn) (* WINDOW FUNCTIONS) (FNS FE.GetPositionWindow FE.GetEditWindow FE.GetMessageWindow FE.ReshapeFn FE.ShadeWindow) (* LOCALMENU FUNCTIONS) (FNS FE.CreateLocalMenu FE.SetHost FE.SetDirectory FE.MyGet FE.MyPut FE.StripVersion FE.Compile FE.Link FE.CompileLinkRun FE.RunInteractive) (* SERVER METACLASS FUNCTIONS) (FNS FE.ValidHostname FE.GetServer) (* ICON STUFF) (FNS FE.ShrinkIconCreate) (BITMAPS FE.Icon FE.IconMask) (INITVARS (FE.defaultFont (FONTCLASS (QUOTE FORTRANEDITFONT) (QUOTE (1 (GACHA 12) (GACHA 10) (GACHA 10))))) (FE.iconFont (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) (FE.iconTitleRegion (create REGION LEFT _ 8 BOTTOM _ 8 WIDTH _ 110 HEIGHT _ 40)) (FE.titledIconTemplate (create TITLEDICON ICON _ FE.Icon MASK _ FE.IconMask TITLEREG _ FE.iconTitleRegion))) (* VARS) (ADDVARS (BackgroundMenuCommands (Fortran% Edit (QUOTE (FE.TopLevel)) "Start a Fortran Edit"))) (VARS (BackgroundMenu NIL)) (GLOBALVARS FE.defaultFont FE.iconFont FE.titledIconTemplate TEDIT.READTABLE) (* * SERVERS -- Defines the Loops MathServer objects) (CLASSES Cray FortranServer MathServer Server VMSServer) (METHODS FortranServer.Compile FortranServer.Compiled? FortranServer.Link FortranServer.Linked? MathServer.AlertManager Server.AbortJob Server.CommandFileExtension Server.Description Server.Error? Server.ErrorFile Server.ErrorString Server.ExecuteCommandFile Server.ExtractFilename Server.GetQueues Server.GetTime Server.Host Server.MakeError Server.MakeFullName Server.MakePartialName Server.Name Server.PutErrorInWindow Server.PutTextInWindow Server.Result Server.RunFile Server.RunJob Server.ServerDirectory Server.SourceExtension Server.Status Server.SubmitJob Server.UserDirectory VMSServer.MakeCommandString) (FNS MS.MakeInstances StripPA) (P (MS.DestroyInstances) (MS.MakeInstances)) (* * PROGRAMCHAT - Windowless CHAT for communication) (FNS OPENCHATSTREAM PROGRAMCHAT PROGRAMCHAT.LOGIN PROGRAMCHAT.OUTPUT) (* VARS for our site) (VARS NETWORKLOGINFO) (P (pushnew NETWORKOSTYPES (QUOTE (GSLVAX . VMS)) (QUOTE (SITKA . VMS)) (QUOTE (MADVAX . VMS)))) (* * PROGRAMMER'S INTERFACE - use remote servers with LISP calls) (FNS PRIN.RunRemote PRIN.ValidateHost PRIN.ValidateFilename PRIN.Error))) (* * SERVER MENU - Sets up the main Server Free Menu) (* MENU AND WINDOW FUNCTIONS) (DEFINEQ (MS.TopLevel (LAMBDA NIL (* DSB "15-Apr-87 10:19") (* Sets up the ServerFreeMenu, with PopUpMenu for host selection and with attached messageWindow) (PROG (menuWindow menuRegion messageWindow side) (SETQ menuWindow (MS.CreateFreeMenu 470 470)) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE QUEUE)) menuWindow) (SETQ menuRegion (WINDOWPROP menuWindow (QUOTE REGION))) (* * Create PopUp menu for selection of Host) (SETQ MS.HostPopMenu (MS.MakeMenuOfKnownHosts)) (* * create, attach and save pointer to messageWindow) (SETQ messageWindow (CREATEW (CREATEREGION 0 0 200 150) "Message Window" NIL T)) (SETQ side (QUOTE LEFT)) (COND ((EQ (QUOTE LEFT) (MS.MostRoom menuWindow)) (SETQ side (QUOTE RIGHT))) (T NIL)) (ATTACHWINDOW messageWindow menuWindow side (QUOTE JUSTIFY)) (WINDOWPROP menuWindow (QUOTE MessageWindow) messageWindow) (WINDOWPROP menuWindow (QUOTE ICONFN) (FUNCTION MS.MakeIconWindow)) (OPENW menuWindow)))) (MS.CreateFreeMenu (LAMBDA (LEFT BOTTOM) (* DSB " 9-Dec-86 15:50") (* returns a free menu window at specified position) (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL FortranEdit-Commands: FONT (MODERN 12 BOLD)) (LABEL StartNew SELECTEDFN MS.StartNewFE) (LABEL StartWithDefault SELECTEDFN MS.StartDefaultFE)) ((TYPE TITLE LABEL PlotMenu-Commands: FONT (MODERN 12 BOLD)) (LABEL SimplePlot SELECTEDFN MAPL.Simple.TopLevel) (LABEL Gen.Plot SELECTEDFN MAPL.Gen.TopLevel) (LABEL MetaPlot SELECTEDFN MAPL.Meta.TopLevel)) ((TYPE TITLE LABEL Compiler-Commands: FONT (MODERN 12 BOLD)) (LABEL Compile SELECTEDFN MS.Compile) (LABEL Link SELECTEDFN MS.Link) (LABEL C/L SELECTEDFN MS.CompileLink)) ((TYPE TITLE LABEL Run-Commands: FONT (MODERN 12 BOLD)) (LABEL RunInteractive SELECTEDFN MS.RunInteractiveJob) (LABEL C/L/R SELECTEDFN MS.CLR.NoCheck) (LABEL C?/L?/R SELECTEDFN MS.CLR.Check)) ((TYPE TITLE LABEL Batch-Commands: FONT (MODERN 12 BOLD)) (LABEL Submit SELECTEDFN MS.SubmitBatchJob) (LABEL Status SELECTEDFN MS.Status) (LABEL Errors? SELECTEDFN MS.BatchErrors?) (LABEL Abort SELECTEDFN MS.AbortBatchJob) (LABEL Log SELECTEDFN MS.BatchLog)) ((TYPE TITLE LABEL "COMPUTE SERVER FILE INFO" FONT (MODERN 12 BOLD))) ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) ITEMS (FILENAME)) (TYPE EDIT ID FILENAME LABEL "")) ((TYPE EDITSTART LABEL DefaultDirectory: FONT (MODERN 12 BOLD) ITEMS (DEFAULTDIRECTORY)) (TYPE EDIT ID DEFAULTDIRECTORY LABEL "")) ((TYPE EDITSTART LABEL JobParameters: FONT (MODERN 12 BOLD) ITEMS (PARAMETERSTRING)) (TYPE EDIT ID PARAMETERSTRING LABEL "")) ((TYPE EDITSTART LABEL LinkParameters: FONT (MODERN 12 BOLD) ITEMS (LINKSTRING)) (TYPE EDIT ID LINKSTRING LABEL "")) ((TYPE TITLE LABEL "COMPUTE SERVER HOST INFO" FONT (MODERN 12 BOLD))) ((TYPE TITLE LABEL HostName: FONT (MODERN 12 BOLD) SELECTEDFN MS.SelectHost) (TYPE TITLE ID HOST LABEL "")) ((TYPE TITLE LABEL Queue: FONT (MODERN 12 BOLD)) (TYPE NWAY ID QUEUE LABEL Fast CLASSNAME FastQueue) (TYPE NWAY ID QUEUE LABEL Medium CLASSNAME MediumQueue) (TYPE NWAY ID QUEUE LABEL Slow CLASSNAME SlowQueue)) ((TYPE EDITSTART LABEL JobNumber: FONT (MODERN 12 BOLD) ITEMS (JOBNUMBER)) (TYPE EDIT ID JOBNUMBER LABEL "")) ((TYPE TITLE LABEL SERVERBROWSER-Command: FONT (MODERN 12 BOLD)) (LABEL MakeBrowser SELECTEDFN MS.MakeInstances)) (WINDOWPROPS TITLE "Server Menu" LEFT , LEFT BOTTOM , BOTTOM)))))) (MS.SelectHost (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "10-Jun-86 18:17") (* Uses the pop-up menu MS.HostPopMenu to return a  label and a pointer to the Host Server.) (PROG ((promptW (GETPROMPTWINDOW WINDOW)) (sItem (FM.ITEMFROMID WINDOW (QUOTE HOST))) server) (* * Opens the PopUp menu. Returns the object name of the selected server.) (CLEARW promptW) (PRIN1 "Select host." promptW) (SETQ server (MENU MS.HostPopMenu)) (CLEARW promptW) (* * if the server exists, set the Host prop of the "HOST" item in the menu to point to the Server object. Then change the item label to be the name of the Server object.) (COND (server (FM.ITEMPROP sItem (QUOTE Host) server) (FM.CHANGELABEL sItem WINDOW (_ server Name))) (T (* * otherwise, set both the Host prop and the label of the "HOST" item in the menu to nil.) (FM.ITEMPROP sItem (QUOTE Host) NIL) (FM.CHANGELABEL sItem WINDOW "")))))) (MS.ExpandFilename (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:22") (* if filename contains a directory, expand it into  separate slots) (* this is a shortened version of MAPL.ExpandFilename) (PROG ((state (FM.READSTATE WINDOW)) filename defaultDirectory name) (SETQ filename (LISTGET state (QUOTE FILENAME))) (* * strip off any extensions and version numbers) (SETQ name (UNPACKFILENAME filename (QUOTE NAME))) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE FILENAME)) WINDOW name) (* * if there is a directory, place it in the menu) (SETQ defaultDirectory (UNPACKFILENAME filename (QUOTE DIRECTORY))) (COND (defaultDirectory (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE DEFAULTDIRECTORY)) WINDOW defaultDirectory))) (* * update "state" and return) (SETQ state (FM.READSTATE WINDOW)) (RETURN state)))) (MS.CloseErrorWindow (LAMBDA (mainWindow) (* DSB "15-Aug-86 15:27") (* * Check if an errorWindow already exists. If so, delete the {core} file behind it, clean up props, and finally  close the window.) (LET (oldWindow oldFile) (SETQ oldWindow (find item in (ATTACHEDWINDOWS mainWindow) suchthat (WINDOWPROP item (QUOTE ERRORFILE)))) (COND (oldWindow (MS.CleanupErrorFile oldWindow) (CLOSEW oldWindow)))))) (MS.CleanupErrorFile (LAMBDA (errorWindow) (* DSB "15-Aug-86 15:30") (* deletes the error file that resides in {core}, if  it exists, and resets errorWindow prop to NIL) (LET ((oldFile (WINDOWPROP errorWindow (QUOTE ERRORFILE)))) (COND (oldFile (CLOSEF? oldFile) (DELFILE oldFile) (WINDOWPROP errorWindow (QUOTE ERRORFILE) NIL))) NIL))) (MS.AttachErrorWindow (LAMBDA (mainWindow title) (* DSB "15-Aug-86 15:22") (* Attaches an error window to the main menu window) (* * MS.CloseErrorWindow should have been called prior to this. Nevertheless, we check for an old errorWindow, and  if it exists, we call MS.CloseErrorWindow) (* * Make the error window and attach it to the appropriate side of the main window) (LET (oldWindow errorWindow) (SETQ oldWindow (find item in (ATTACHEDWINDOWS mainWindow) suchthat (WINDOWPROP item (QUOTE ERRORFILE)))) (AND oldWindow (MS.CloseErrorWindow mainWindow)) (SETQ errorWindow (CREATEW (QUOTE (0 0 470 300)) title NIL T)) (ATTACHWINDOW errorWindow mainWindow (MS.MostRoom mainWindow) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) errorWindow))) (MS.MostRoom (LAMBDA (WINDOW) (* DSB " 7-Aug-86 11:55") (* determines if attached window should be on right or left side of main window) (LET ((region (WINDOWPROP WINDOW (QUOTE REGION))) leftSpace rightSpace) (SETQ leftSpace (fetch (REGION LEFT) of region)) (SETQ rightSpace (DIFFERENCE 1025 (PLUS leftSpace (fetch (REGION WIDTH) of region)))) (COND ((GEQ leftSpace rightSpace) (QUOTE LEFT)) (T (QUOTE RIGHT)))))) (MS.GetMessageWindow (LAMBDA (WINDOW) (* DSB " 6-Jun-86 15:57") (* maybe later, we'll check if the message window  exists and if not, will make it first) (WINDOWPROP WINDOW (QUOTE MessageWindow)))) (MS.MakeIconWindow (LAMBDA (WINDOW OLDICON) (* DSB " 9-Dec-86 15:44") (* * Creates a window with an icon formed by two bit maps.) (OR OLDICON (ICONW MS.Icon MS.IconMask)))) (PrintMsg (LAMBDA (place msg) (* thh: " 6-Nov-85 11:04") (* prints message in appropriate prompt window) (* no message if place = DON'T) (COND ((Object? place) (_ place ClearPromptWindow) (_ place PromptPrint msg)) ((TYPENAMEP place (QUOTE PLOT)) (LET ((w (PLOTPROP place (QUOTE PLOTPROMPTWINDOW)))) (CLEARW w) (PRIN1 msg w))) ((WINDOWP place) (LET ((w (GETPROMPTWINDOW place 2))) (CLEARW w) (PRIN1 msg w))) ((EQ place (QUOTE DON'T))) (T (CLRPROMPT) (PROMPTPRINT msg))))) ) (* SERVER METACLASS FUNCTIONS) (DEFINEQ (MS.MakeMenuOfKnownHosts (LAMBDA NIL (* DSB "19-Aug-86 17:05") (* makes the MS.HostPopMenu) (create MENU ITEMS _(for server in (_ ($ Server) AllInstances!) collect (LIST (_ server Name) server (_ server Description)))))) (MS.DestroyInstances (LAMBDA NIL (* DSB "19-Aug-86 15:37") (* obvious! Use MS.MakeInstances after this.) (for instance in (_ ($ Server) AllInstances!) do (_ instance Destroy)))) ) (* MATH SERVER FUNCTIONS) (DEFINEQ (MS.SubmitBatchJob (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:28") (* Creates the SubmitJob message to be sent to the  appropriate host) (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename defaultDirectory host validQueues queue parameterString result) (* * check that all required data is specified) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (SETQ validQueues (_ host GetQueues)) (SETQ queue (LISTGET state (QUOTE QUEUE))) (COND ((NOT queue) (PrintMsg WINDOW "Unspecified queue.") (RETURN)) ((NOT (MEMBER queue validQueues)) (CLEARW promptW) (PRIN1 "Not a valid queue for this server" promptW) (TERPRI promptW) (PRINTOUT promptW "Valid queues: " validQueues) (RETURN))) (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING))) (COND ((STRPOS "," parameterString) (PrintMsg WINDOW "Remove comma(s) from JobParameters") (RETURN))) (* * return the SubmitJob message) (PrintMsg WINDOW "Submitting Batch Job ...") (CLEARW messageW) (MS.CloseErrorWindow WINDOW) (COND ((EQUAL parameterString "") (SETQ result (_ host SubmitJob (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) queue))) (T (SETQ result (_ host SubmitJob (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) queue (LIST (MKSTRING parameterString)))))) (PRIN1 result messageW) (CLEARW promptW) (PRIN1 "Done" promptW) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE JOBNUMBER)) WINDOW (CAR result))))) (MS.AbortBatchJob (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 09:52") (* Creates the AbortJob message to be sent to the  appropriate host) (PROG ((state (FM.READSTATE WINDOW)) (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) host jobNumber queue validQueues result) (* * check that the host name is specified) (CLEARW promptW) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (* * check that the job number is specified) (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER))) (COND ((EQUAL jobNumber "") (SETQ jobNumber NIL) (PrintMsg WINDOW "Unspecified job number.") (RETURN))) (* * check that the queue is specified and valid) (SETQ validQueues (_ host GetQueues)) (SETQ queue (LISTGET state (QUOTE QUEUE))) (COND ((NOT queue) (PrintMsg WINDOW "Unspecified queue.") (RETURN)) ((NOT (MEMBER queue validQueues)) (CLEARW promptW) (PRIN1 "Not a valid queue for this server" promptW) (TERPRI promptW) (PRINTOUT promptW "Valid queues: " validQueues) (RETURN))) (* * abort the job and return the result) (CLEARW promptW) (PRINTOUT promptW "Job " jobNumber " on queue " queue " is being aborted ...") (SETQ result (_ host AbortJob jobNumber queue)) (TERPRI promptW) (PRIN1 "Done" promptW) (CLEARW messageW) (PRIN1 result messageW)))) (MS.Status (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 17:53") (* Creates the Status message to be sent to the  appropriate host) (PROG ((state (FM.READSTATE WINDOW)) (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) host jobNumber result) (* * check that the host name is specified) (CLEARW promptW) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (* * give notice if no job number is supplied) (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER))) (COND ((NUMBERP (MKATOM jobNumber)) (PRIN1 "Finding Status ..." promptW)) (T (SETQ jobNumber NIL) (PRIN1 "Unspecified job number." promptW) (TERPRI promptW) (PRIN1 "Finding status of all batch jobs ..." promptW))) (* * return the Status message) (CLEARW messageW) (SETQ result (_ host Status jobNumber)) (MS.DisplayStatus result messageW) (CLEARW promptW) (PRIN1 "Done" promptW)))) (MS.DisplayStatus (LAMBDA (result messageW) (* DSB "12-Aug-86 18:00") (* Displays the status in nice format in  messageWindow) (PROG (number time) (TERPRI messageW) (PRIN1 " JOB CPU" messageW) (TERPRI messageW) (PRIN1 "- - - - - - - - - - - - - - - - -" messageW) (* * is it a single data item (JOB in CAAR) or...) (COND ((EQ (CAAR result) (QUOTE JOB)) (SETQ number (CADAR result)) (SETQ time (CADADR result)) (TERPRI messageW) (PRIN1 (CONCAT " " number " " time) messageW)) (T (for item in result do (SETQ number (CADAR item)) (SETQ time (CADADR item)) (TERPRI messageW) (PRIN1 (CONCAT " " number " " time) messageW))))))) (MS.RunInteractiveJob (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:30") (* Creates the RunJob message to be sent to the  appropriate host) (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename defaultDirectory host parameterString result errorFile errorWindow) (* * check that all required data is specified) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING))) (COND ((STRPOS "," parameterString) (PrintMsg WINDOW "Remove comma(s) from JobParameters") (RETURN))) (* * return the RunJob message) (CLEARW promptW) (PRIN1 "Running interactive job ..." promptW) (CLEARW messageW) (MS.CloseErrorWindow WINDOW) (COND ((EQUAL parameterString "") (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename)))) (T (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) (LIST (MKSTRING parameterString)))))) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Run-time warning or error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Run-time Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW)) (T (PRIN1 "Done" promptW)))))) (MS.Compile (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:14") (* Creates the Compile message to be sent to the  appropriate host) (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename defaultDirectory host result errorFile errorWindow) (CLEARW messageW) (* * check that all required data is specified) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (* * check for dirty file in a Fortran Edit) (COND ((MS.CheckForDirtyFile filename promptW messageW) (RETURN))) (* * send the Compile message) (CLEARW promptW) (PRIN1 "Compiling source file ..." promptW) (MS.CloseErrorWindow WINDOW) (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename))) (CLEARW messageW) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Compilation Error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW)) (T (PRIN1 "Successful Compilation" promptW)))))) (MS.Link (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:31") (* Creates the Link message to be sent to the  appropriate host) (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename defaultDirectory host linkString result errorFile errorWindow) (* * check that all required data is specified) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (SETQ linkString (LISTGET state (QUOTE LINKSTRING))) (COND ((STRPOS " " linkString) (PrintMsg WINDOW "Remove spaces from LinkParameters") (RETURN))) (* * return the Link message) (CLEARW promptW) (PRIN1 "Linking ..." promptW) (CLEARW messageW) (MS.CloseErrorWindow WINDOW) (COND ((EQUAL linkString "") (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename)))) (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) (LIST (MKSTRING linkString)))))) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Linking Error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW)) (T (PRIN1 "Done: successful link" promptW)))))) (MS.CompileLink (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:31") (* Creates the Compile and Link messages to be sent to the appropriate host) (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename defaultDirectory host linkString result errorFile errorWindow) (CLEARW messageW) (* * check that all required data is specified) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (SETQ linkString (LISTGET state (QUOTE LINKSTRING))) (COND ((STRPOS " " linkString) (PrintMsg WINDOW "Remove spaces from LinkParameters") (RETURN))) (* * check for dirty file in a Fortran Edit) (COND ((MS.CheckForDirtyFile filename promptW messageW) (RETURN))) (* * send the Compile message) (CLEARW promptW) (PRIN1 "Compiling source file ..." promptW) (MS.CloseErrorWindow WINDOW) (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename))) (CLEARW messageW) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Compilation error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW) (RETURN)) (T (PRIN1 "Compile finished. Now linking..." promptW))) (* * return the Link message) (COND ((EQUAL linkString "") (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename)))) (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) (LIST (MKSTRING linkString)))))) (CLEARW messageW) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Linking Error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW)) (T (PRIN1 "Done: successful link" promptW)))))) (MS.CLR.Check (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 10:17") (* This functin calls MS.CompileLinkRun with the check flag T) (MS.CompileLinkRun ITEM WINDOW BUTTONS T))) (MS.CLR.NoCheck (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 10:18") (* This functin calls MS.CompileLinkRun with the check flag NIL) (MS.CompileLinkRun ITEM WINDOW BUTTONS NIL))) (MS.CompileLinkRun (LAMBDA (ITEM WINDOW BUTTONS checkFlag) (* DSB "15-Apr-87 10:34") (* Sequentially creates the Compile, Link and RunJob  messages, to be sent to the appropriate host) (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename defaultDirectory host parameterString linkString result errorFile errorWindow) (CLEARW messageW) (* * check that all required data is specified) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (SETQ linkString (LISTGET state (QUOTE LINKSTRING))) (COND ((STRPOS " " linkString) (PrintMsg WINDOW "Remove spaces from LinkParameters") (RETURN))) (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING))) (COND ((STRPOS "," parameterString) (PrintMsg WINDOW "Remove comma(s) from JobParameters") (RETURN))) (* * check for dirty file in a Fortran Edit) (COND ((MS.CheckForDirtyFile filename promptW messageW) (RETURN))) (* * send the Compile message) (CLEARW promptW) (MS.CloseErrorWindow WINDOW) (COND ((AND checkFlag (_ host Compiled? host defaultDirectory filename)) (PRIN1 "Source file already compiled. " promptW)) (T (PRIN1 "Compiling source file ..." promptW) (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename))) (CLEARW messageW) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Compilation error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW) (RETURN)) (T (PRIN1 "Compile finished. " promptW))))) (* * return the Link message) (COND ((AND checkFlag (_ host Linked? host defaultDirectory filename)) (TERPRI promptW) (PRIN1 " Exec. file exists. Now running it..." promptW)) (T (PRIN1 " Now linking..." promptW) (COND ((EQUAL linkString "") (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename)))) (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) (LIST (MKSTRING linkString)))))) (CLEARW messageW) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Linking Error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW) (RETURN)) (T (PRIN1 "Link finished. Now running job ..." promptW))))) (* * return the RunJob message) (COND ((EQUAL parameterString "") (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename)))) (T (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) defaultDirectory (QUOTE BODY) filename) (LIST (MKSTRING parameterString)))))) (CLEARW messageW) (PRIN1 result messageW) (CLEARW promptW) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN1 "Run-time warning or error" promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Run-time Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow WINDOW)) (T (PRIN1 "Done" promptW)))))) ) (* FORTRAN EDITOR FUNCTIONS) (DEFINEQ (MS.StartNewFE (LAMBDA NIL (* DSB "21-Aug-86 15:38") (* starts a new Fortran Edit process without setting  defaults or getting a file) (FE.TopLevel))) (MS.StartDefaultFE (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:35") (* Starts a FE, sets defaults according to the values in the ServerMenu, and gets the source file named in the  server menu, if it exists.) (PROG (state textStream host hostname defaultDirectory directory filename name getFilename) (SETQ textStream (FE.TopLevel)) (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND (host (TEXTPROP textStream (QUOTE MS.HOST) host) (SETQ hostname (_ host Name)) (TEXTPROP textStream (QUOTE MS.HOSTNAME) hostname) (TEXTPROP textStream (QUOTE MS.DIRECTORY) (_ host UserDirectory)))) (COND ((NOT (EQUAL defaultDirectory "")) (SETQ directory (MKATOM defaultDirectory)) (TEXTPROP textStream (QUOTE MS.DIRECTORY) directory))) (COND ((NOT (EQUAL filename "")) (SETQ name (MKATOM filename)))) (COND ((AND host directory name) (SETQ getFilename (PACKFILENAME (QUOTE HOST) hostname (QUOTE DIRECTORY) directory (QUOTE NAME) name (QUOTE EXTENSION) (_ host SourceExtension))) (COND ((INFILEP getFilename) (TEDIT.GET (TEXTOBJ textStream) getFilename) (TEXTPROP textStream (QUOTE FILENAME) getFilename) (TEDIT.PROMPTPRINT textStream (CONCAT "Retrieved file " getFilename))) (T (TEDIT.PROMPTPRINT textStream (CONCAT "File " getFilename " not found"))))))) )) (MS.FindFortranEdit (LAMBDA (filename) (* DSB "22-Aug-86 09:36") (* * searches through all open windows and returns a stream number of a Fortran Edit process whose filename matches the parameter filename If no such process exists, it returns NIL.) (LET (textStream fullEditFilename editFilename) (for window in (OPENWINDOWS) do (COND ((WINDOWPROP window (QUOTE FORTRANEDIT)) (SETQ textStream (TEXTSTREAM window)) (SETQ fullEditFilename (TEXTPROP textStream (QUOTE FILENAME))) (SETQ editFilename (UNPACKFILENAME fullEditFilename (QUOTE NAME))) (COND ((EQUAL (U-CASE editFilename) (U-CASE (MKATOM filename))) (RETURN textStream)) (T NIL)))))))) (MS.CheckForDirtyFile (LAMBDA (filename promptW messageW) (* DSB "22-Aug-86 09:42") (* * returns T (to abort the operation) only if there exists a dirty file with the same name and the user does not  click the left button.) (PROG (textStream dirty) (* * see if there is an active FE with filename) (SETQ textStream (MS.FindFortranEdit filename)) (COND ((NOT textStream) (RETURN NIL))) (* * if the file has been changed, give the user the option to abort the operation) (SETQ dirty (TEDIT.STREAMCHANGEDP textStream)) (COND (dirty (CLEARW promptW) (COND ((MOUSECONFIRM "Not saved yet; LEFT to use previous version." T promptW) (PRIN1 "Using old version on the server" messageW) (RETURN NIL)) (T (PRIN1 "Operation aborted. Put file in Fortran Edit to server." messageW) (RETURN T)))) (T (PRIN1 "File in Fortran Editor has not been changed. Operation proceeds" messageW) (RETURN NIL)))))) ) (* ERROR HANDLING FUNCTIONS) (DEFINEQ (MS.BatchErrors? (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Aug-86 18:07") (* If Batch errors have occurred, it displays them in  the error window) (PROG ((state (FM.READSTATE WINDOW)) (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) host defaultDirectory jobNumber errorFile localErrorFile resultFile stream result errorWindow) (* * check that all required data is specified) (CLEARW promptW) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) (COND ((EQUAL defaultDirectory "") (PrintMsg WINDOW "Unspecified default directory.") (RETURN))) (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER))) (COND ((EQUAL jobNumber "") (SETQ jobNumber NIL) (PrintMsg WINDOW "Unspecified job number.") (RETURN))) (* * get the error file) (CLEARW promptW) (CLEARW messageW) (MS.CloseErrorWindow WINDOW) (SETQ resultFile (INFILEP (PACKFILENAME (QUOTE HOST) (_ host Name) (QUOTE DIRECTORY) defaultDirectory (QUOTE NAME) jobNumber (QUOTE EXTENSION) (QUOTE RES)))) (SETQ errorFile (INFILEP (PACKFILENAME (QUOTE HOST) (_ host Name) (QUOTE DIRECTORY) defaultDirectory (QUOTE NAME) jobNumber (QUOTE EXTENSION) (QUOTE ERR)))) (COND (errorFile (PRIN1 "Retrieving error messages..." promptW) (SETQ stream (OPENFILE resultFile (QUOTE INPUT))) (SETQ result (READ stream)) (CLOSEF stream) (DELFILE resultFile) (PRIN1 result messageW) (SETQ localErrorFile (COPYFILE errorFile (QUOTE {core}localErrorFile))) (DELFILE errorFile) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Batch Errors")) (_ host PutErrorInWindow localErrorFile errorWindow WINDOW)) (T (PRIN1 "No batch errors found" promptW)))))) (MS.BatchLog (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Aug-86 18:07") (* opens a window to display the batch log file) (PROG ((state (FM.READSTATE WINDOW)) (promptW (GETPROMPTWINDOW WINDOW)) (messageW (MS.GetMessageWindow WINDOW)) filename host logfile localLogfile errorWindow) (* * check that all required data is specified) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PrintMsg WINDOW "Unspecified file name.") (RETURN))) (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) (QUOTE Host))) (COND ((NOT host) (PrintMsg WINDOW "Unspecified host.") (RETURN))) (* * get the logfile) (CLEARW promptW) (CLEARW messageW) (MS.CloseErrorWindow WINDOW) (SETQ logfile (INFILEP (PACKFILENAME (QUOTE HOST) (_ host Name) (QUOTE DIRECTORY) (_ host UserDirectory) (QUOTE BODY) filename (QUOTE EXTENSION) (QUOTE LOG)))) (COND (logfile (SETQ localLogfile (COPYFILE logfile (QUOTE {core}localLogfile))) (DELFILE logfile) (PRIN1 "fetching Batch Log File..." promptW) (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Batch Log File")) (_ host PutErrorInWindow localLogfile errorWindow WINDOW)) (T (PRIN1 "Batch Log File not found" promptW)))))) ) (* Icon BITMAPS) (RPAQ MS.Icon (READBITMAP)) (78 74 "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@O@@@@@@@@@L" "L@@@@@@@@I@GH@@@@@@L" "L@@@@@@B@O@DHGH@@@@L" "L@@@@@@B@O@@HDH@@@@L" "L@@@@@@B@I@AHGH@@@@L" "L@@@@@@B@O@C@GH@@@@L" "L@@@@@@B@@@GLDH@@@@L" "L@@@@@@B@@@@@GH@@@@L" "L@@@@@@@@@@D@@@D@@@L" "L@@@@@@@@@@F@@@L@@@L" "L@@@@CN@@@@C@DAH@@@L" "L@@@@@F@@@@A@DA@@@@L" "L@@@@@L@@@@AHDC@@@@L" "L@@@@AH@@@@@HDB@@@@L" "L@@@CA@@@@@@LDF@@@@L" "L@@@CC@@@@@@D@D@@@@L" "L@@@@@@@@@@@D@D@CO@L" "L@@@@@@@@@@@FNL@CO@L" "L@@@GH@@@@@@BJH@AH@L" "L@@@DH@@@@@@BJH@AH@L" "L@@@@H@@@COOOOOOIH@L" "L@@@AH@@@B@@@@@@IH@L" "L@@@C@@@@B@@@@@@IH@L" "L@@@GL@@@B@@@@@@IH@L" "L@@@@@@@@B@D@@@@IH@L" "L@@@@@@@@B@D@@L@IH@L" "L@@@@@@@@B@D@@@@IH@L" "L@COOOH@@BCOHCO@IH@L" "L@COOOH@@B@D@@@@IH@L" "L@CH@CH@@B@D@@L@IH@L" "L@C@@AH@@B@D@@@@OH@L" "L@C@@AH@@B@@@@@@OH@L" "L@C@@AH@@B@@@@@@H@@L" "L@C@@AH@@B@@@@@@H@@L" "L@C@@AH@@BBDH@@@H@@L" "L@C@@AH@@BAE@@@@H@@L" "L@C@@AH@@B@N@@@@H@@L" "L@C@@AH@@BCOHCO@H@@L" "L@C@@AH@@B@N@@@@H@@L" "L@CH@CKFMJAE@@@@H@@L" "L@COOOH@@BBDH@@@H@@L" "L@COOOH@@B@@@@@@H@@L" "L@@AO@@@@COOOOOOH@@L" "LAOOOON@@@@@@@@@@@@L" "LA@@@@B@@@@@@@@@@@@L" "LA@@@@B@@@@@@@@@@@@L" "LA@@@@B@@@@@@@@@@@@L" "LAOOOON@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "LC@HNGLICLOCNDBOCN@L" "LCOIOA@IB@HBBDBHBB@L" "LBNIAA@ICLNCNFFNCN@L" "LBDIOA@O@DHCHCLHCH@L" "LB@IAA@IBDHBLAHHBL@L" "LB@IAA@ICLOBFAHOBF@L" "L@@@@@@@@@@@@@@@@@@L" "L@@@@@@@@@@@@@@@@@@L" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL") (RPAQ MS.IconMask (READBITMAP)) (78 74 "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOH@COOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOO@@AOOOOOOOOOOOOOL" "OOOH@COOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL" "OOOOOOOOOOOOOOOOOOOL") (* VARS) (ADDTOVAR BackgroundMenuCommands (Server% Menu (QUOTE (MS.TopLevel)) "Start the Server Menu")) (RPAQQ BackgroundMenu NIL) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MS.HostPopMenu) ) (* * FORTRAN EDIT - Sets up a Fortran Edit Process) (* MAIN FUNCTIONS) (DEFINEQ (FE.TopLevel (LAMBDA (program window) (* DSB "22-Aug-86 11:49") (* * Edit a Fortran program using a specialized TEdit.) (* * Program is either a File name, an open Stream, or a string. If NIL, an empty edit window is open.) (* * Window is an optional window to be used for editing. If NIL, the user will be asked to sweep out a window on  the screen.) (PROG (editProps editWindow messageWindow processHandle textStream) (* * Get prop list for edit props) (SETQ editProps (FE.GetEditProps)) (* * Get the window to be used) (SETQ editWindow (FE.GetEditWindow window)) (* * Get the message window) (SETQ messageWindow (FE.GetMessageWindow editWindow)) (* * Set up the edit process) (SETQ processHandle (TEDIT program editWindow NIL editProps)) (* * Get the textstream parameter of the edit process) (SETQ textStream (TEXTSTREAM editWindow)) (* * Do any final modifications) (FE.AdjustProps processHandle textStream) (WINDOWPROP editWindow (QUOTE FORTRANEDIT) T) (TEXTPROP textStream (QUOTE EDITWINDOW) editWindow) (TEXTPROP textStream (QUOTE MESSAGEWINDOW) messageWindow) (TEXTPROP textStream (QUOTE PROCESS) processHandle) (TEXTPROP textStream (QUOTE FE.POSITIONWINDOW) (WINDOWPROP editWindow (QUOTE POSITIONWINDOW))) (* * Finally, return the process handle) (RETURN textStream)))) (FE.AdjustProps (LAMBDA (processHandle textStream) (* DSB " 7-Jul-86 15:52") (* * Do final adjustments to Fortran editor) (LET NIL (COND ((PROCESSP processHandle) (* * The following gives the process a name) (PROCESSPROP processHandle (QUOTE NAME) (QUOTE FORTRAN% EDITOR)) (* * The following disables image object insertion into the document) (until (PROCESSPROP processHandle (QUOTE TEDITTTYWINDOW)) do (BLOCK) finally (WINDOWPROP (PROCESSPROP processHandle (QUOTE TEDITTTYWINDOW)) (QUOTE COPYINSERTFN) NIL))))))) (FE.CaretPosition (LAMBDA (textStream) (* DSB " 7-Jul-86 15:48") (* * Write the line# and the column# of the position of the caret in Textstream) (PROG* (charWidth column midpoint position positionWindow textWindow (margin 8) (textStream (TEXTSTREAM textStream))) (COND ((AND (TEXTSTREAMP textStream) (WINDOWP (SETQ positionWindow (TEXTPROP textStream (QUOTE FE.POSITIONWINDOW))))) (SETQ textWindow (WINDOWP (CAR (LISTP (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ textStream)))))) (SETQ charWidth (CHARWIDTH (CHCON1 "X") (TEXTPROP textStream (QUOTE FONT)))) (COND ((NOT (EQUAL (SETQ position (TEDIT.PARA&CHAR textStream)) (TEXTPROP textStream (QUOTE FE.POSITION)))) (SETQ midpoint (IPLUS 3 (IQUOTIENT (IQUOTIENT (WINDOWPROP positionWindow (QUOTE WIDTH)) (CHARWIDTH (CHARCODE X) (DSPFONT NIL positionWindow))) 2))) (SETQ column (IPLUS (QUOTIENT (IDIFFERENCE (DSPXPOSITION NIL textWindow) margin) charWidth) 1)) (CLEARW positionWindow) (printout positionWindow .TAB0 0 (COND ((MINUSP (IDIFFERENCE column (CDR position))) " ? ") (T "")) .CENTER midpoint (CONCAT "L: " (CAR position)) .TAB0 midpoint .CENTER 0 (CONCAT "C: " (COND ((NOT (ZEROP charWidth)) column) (T -1)))) (TEXTPROP textStream (QUOTE FE.POSITION) position))) (RETURN position)))))) (TEDIT.PARA&CHAR (LAMBDA (TEXTSTREAM SEL) (* RAR " 9-Oct-85 15:49") (* * Given a text stream, (and optionally a selection) find the pagagraph %# and ch within paragraph that the caret is at) (PROG (CH# PC PCTB (TEXTOBJ (TEXTOBJ TEXTSTREAM)) (PARA# 1) (CHAR# 1) (LASTPARACH# 1)) (SETQ PCTB (fetch PCTB of TEXTOBJ)) (SETQ PC (ELT PCTB 3)) (SETQ CH# (TEDIT.GETPOINT TEXTOBJ SEL)) (COND ((ZEROP (fetch TEXTLEN of TEXTOBJ)) (RETURN (CONS 1 0)))) (RETURN (while PC do (COND ((IGREATERP (add CHAR# (fetch PLEN of PC)) CH#) (* Passed the relevant char; return a result) (RETURN (CONS PARA# (IDIFFERENCE CH# LASTPARACH#)))) (T (* Not past the caret; keep going) (COND ((fetch PPARALAST of PC) (* Crossing a paragraph boundary. Count (QUOTE em) up.) (add PARA# 1) (SETQ LASTPARACH# CHAR#))))) (SETQ PC (fetch NEXTPIECE of PC)) finally (RETURN (CONS PARA# (IDIFFERENCE CH# LASTPARACH#)))))))) (FE.CharFn (LAMBDA (textObj charCode) (* DSB " 7-Jul-86 15:51") (* * This function filters out the effects of someone trying to alter the "LOOKS" of something in the  FORTRANEDITOR) (COND ((ILEQ charCode 127) charCode)))) (FE.GetEditProps (LAMBDA NIL (* DSB "20-Aug-86 14:19") (* * Return a prop list for TEdit call) (PROG (charWidth (font FE.defaultFont)) (SETQ charWidth (CHARWIDTH (CHCON1 "X") font)) (RETURN (APPEND (QUOTE (CLEARGET T)) (QUOTE (CLEARPUT T)) (LIST (QUOTE FONT) font) (LIST (QUOTE MENU) (FE.CreateLocalMenu)) (LIST (QUOTE PARALOOKS) (LIST (QUOTE TABS) (CONS (ITIMES 8 charWidth) NIL))) (LIST (QUOTE LOOPFN) (FUNCTION FE.LoopFn)) (LIST (QUOTE CHARFN) (FUNCTION FE.CharFn)) (QUOTE (COPYBYBKSYSBUF T)) (LIST (QUOTE READTABLE) (PROG ((table (COPYREADTABLE TEDIT.READTABLE))) (* * Return the read table to be used with this process) (TEDIT.SETSYNTAX 15 NIL table) (* Turns of inserting with CTRL-O) (RETURN table)))))))) (FE.GetSourceFileName (LAMBDA (textObj) (* DSB "22-Aug-86 14:08") (* * Return filename associated with textObj) (* * Due to a TEDIT bug, we can't use (FULLNAME (fetch TXTFILE of textObj)), because this can be changed when a  file is opened to the same non-leaf server. Thus, we use the same FILENAME textprop that FE.MyPut uses and FE.MyGet updates.) (PROG (fileStream textStream filename messageWindow promptWindow dirty) (* * Make sure we have a text object) (COND ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) (RETURN NIL))) (* * See if the file is ready to use) (SETQ fileStream (fetch TXTFILE of textObj)) (SETQ textStream (TEXTSTREAM textObj)) (SETQ filename (TEXTPROP textStream (QUOTE FILENAME))) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (SETQ promptWindow (fetch PROMPTWINDOW of textObj)) (CLEARW promptWindow) (SETQ dirty (TEDIT.STREAMCHANGEDP textStream)) (COND ((NOT dirty) (RETURN filename))) (COND ((AND dirty (NOT fileStream)) (PRIN1 "Can't. No file has been saved yet." promptWindow) (RETURN NIL))) (COND ((AND dirty fileStream) (COND ((MOUSECONFIRM "Not saved yet; LEFT to use previous version." T promptWindow) (PRIN1 "Using old version on the server" messageWindow) (RETURN filename)) (T (RETURN NIL)))))))) (FE.LoopFn (LAMBDA (textStream) (* DSB " 7-Jul-86 17:08") (* * Things to be done each time around TEdit command loop) (LET NIL (* * Shade the edit window) (FE.ShadeWindow textStream) (* * Update the position display) (FE.CaretPosition textStream)))) ) (* WINDOW FUNCTIONS) (DEFINEQ (FE.GetPositionWindow (LAMBDA (mainWindow) (* DSB " 7-Jul-86 17:13") (* * Return the window to be used as the caret-position indicator window) (PROG (height positionWindow (font FE.defaultFont)) (SETQ height (HEIGHTIFWINDOW (FONTPROP font (QUOTE HEIGHT)))) (SETQ positionWindow (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (WINDOWPROP mainWindow (QUOTE WIDTH))) height) NIL NIL T)) (DSPFONT font positionWindow) (DSPTEXTURE BLACKSHADE positionWindow) (DSPOPERATION (QUOTE INVERT) positionWindow) (WINDOWPROP positionWindow (QUOTE CLOSEFN) (QUOTE (DETACHWINDOW))) (WINDOWPROP positionWindow (QUOTE MINSIZE) (CONS 0 height)) (WINDOWPROP positionWindow (QUOTE MAXSIZE) (CONS 64000 height)) (WINDOWPROP positionWindow (QUOTE PAGEFULLFN) (FUNCTION NILL)) (RETURN positionWindow)))) (FE.GetEditWindow (LAMBDA (window) (* DSB "15-Aug-86 09:19") (* * Return a window to be used by the Fortran editor) (PROG (fontHeight minWidth minHeight positionWindow (font FE.defaultFont)) (* * Set the minimum window dimensions to be 20 characters wide by four lines high) (SETQ minWidth (WIDTHIFWINDOW (ITIMES 20 (CHARWIDTH (CHCON1 "X") font)))) (SETQ minHeight (HEIGHTIFWINDOW (ITIMES 4 (SETQ fontHeight (FONTPROP font (QUOTE HEIGHT)))) T)) (* * If not passed a window, then create one) (COND ((NOT (WINDOWP window)) (SETQ window (CREATEW (GETREGION minWidth minHeight) (QUOTE Fortran% Editor) NIL T)))) (* * Add our window properties) (WINDOWADDPROP window (QUOTE RESHAPEFN) (FUNCTION FE.ReshapeFn)) (WINDOWPROP window (QUOTE ICONFN) (FUNCTION FE.ShrinkIconCreate)) (WINDOWPROP window (QUOTE MINSIZE) (CONS minWidth minHeight)) (* * Now add a window for displaying the caret position) (SETQ positionWindow (FE.GetPositionWindow window)) (ATTACHWINDOW positionWindow window (QUOTE TOP) (QUOTE JUSTIFY)) (WINDOWPROP positionWindow (QUOTE PASSTOMAINCOMS) T) (* needed due to bug in ATTACHWINDOW which does not  set the prop correctly when WINDOWCOMACTION=MAIN) (WINDOWPROP window (QUOTE POSITIONWINDOW) positionWindow) (* * Return the main window) (RETURN window)))) (FE.GetMessageWindow (LAMBDA (editWindow) (* DSB "19-Aug-86 17:55") (* * Create, attach, and return the messageWindow on the bottom of the editWindow) (PROG (messageWindow) (SETQ messageWindow (CREATEW (CREATEREGION 0 0 200 60) "Message Window" NIL T)) (ATTACHWINDOW messageWindow editWindow (QUOTE BOTTOM) (QUOTE JUSTIFY)) (RETURN messageWindow)))) (FE.ReshapeFn (LAMBDA (window oldImage oldRegion) (* DSB " 7-Jul-86 17:23") (* * Need to set the TEXTPROP FE.POSITION to Nil to force position update following reshape of main window) (TEXTPROP (TEXTSTREAM window) (QUOTE FE.POSITION) NIL))) (FE.ShadeWindow (LAMBDA (stream) (* DSB " 7-Jul-86 17:28") (* * Highlight the sixth and seventy-third columns of the editor window) (PROG (charWidth height window (margin 8) (textObj (TEXTOBJ stream))) (SETQ window (CAR (fetch (TEXTOBJ \WINDOW) of textObj))) (SETQ charWidth (CHARWIDTH (CHCON1 "X") (TEXTPROP textObj (QUOTE FONT)))) (SETQ height (WINDOWPROP window (QUOTE HEIGHT))) (BITBLT NIL NIL NIL window (IPLUS margin (ITIMES 5 charWidth)) 0 1 height (QUOTE TEXTURE) (QUOTE REPLACE) GRAYSHADE) (BITBLT NIL NIL NIL window (SUB1 (IPLUS margin (ITIMES 6 charWidth))) 0 1 height (QUOTE TEXTURE) (QUOTE REPLACE) GRAYSHADE) (BITBLT NIL NIL NIL window (IPLUS margin (ITIMES 72 charWidth)) 0 1 height (QUOTE TEXTURE) (QUOTE REPLACE) GRAYSHADE)))) ) (* LOCALMENU FUNCTIONS) (DEFINEQ (FE.CreateLocalMenu (LAMBDA NIL (* DSB " 7-Nov-86 09:42") (* * Return the local menu that pops up when the left or middle buttons are pressed when the mouse pointer is in  the title bar area of the Fortran editor window.) (create MENU ITEMS _(QUOTE (Quit Hardcopy (Put (FUNCTION FE.MyPut) "Write edit buffer to specified file") (Get (FUNCTION FE.MyGet) "Replace contents of edit buffer with contents of specified file") (Include (QUOTE Include) "Add contents of specified file to edit buffer at present location") (Find (QUOTE Find) "Find first occurence of specified string beyond present location") (Substitute (QUOTE Substitute) "Replace all occurances of specified string with new string in selected text") (Host (FUNCTION FE.SetHost) "Declare host server") (Directory (FUNCTION FE.SetDirectory) "Declare host directory") (Compile (FUNCTION FE.Compile) "Compile file on host") (Link (FUNCTION FE.Link) "Link file on host") (C/L/R (FUNCTION FE.CompileLinkRun) "Compile,link and run file on host") (Run (FUNCTION FE.RunInteractive) "Run file on host"))) CENTERFLG _ T MENUFONT _(FONTCREATE (QUOTE HELVETICA) 10 (QUOTE BOLD)) WHENSELECTEDFN _(FUNCTION \TEDIT.MENU.WHENSELECTEDFN) WHENHELDFN _(FUNCTION \TEDIT.MENU.WHENHELDFN)))) (FE.SetHost (LAMBDA (textStream) (* DSB "22-Aug-86 13:07") (* * Ask user to declare a host server, using the present host server as a default answer.) (* * the host, hostname and default directory are all calculated and stored as TEXTPROPs) (* * Note that FE.GetServer returns the pointer to the server instance. When the message is sent to host, host is  evaled.) (* * Note also that hostname must be an upper-case atom when it is passed to FE.ValidHostname and FE.GetServer) (PROG (messageWindow host hostname (oldHostname (TEXTPROP textStream (QUOTE MS.HOSTNAME)))) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (COND ((FE.ValidHostname (SETQ hostname (U-CASE (MKATOM (TEDIT.GETINPUT textStream "Hostname :" oldHostname) )))) (TEXTPROP textStream (QUOTE MS.HOSTNAME) hostname) (SETQ host (FE.GetServer hostname)) (TEXTPROP textStream (QUOTE MS.HOST) host) (TEXTPROP textStream (QUOTE MS.DIRECTORY) (_ host UserDirectory)) (TEDIT.PROMPTPRINT textStream (CONCAT "Hostname is " hostname) T)) (T (TEDIT.PROMPTPRINT textStream (CONCAT hostname " is not valid...Hostname unchanged") T))) (RETURN NIL)))) (FE.SetDirectory (LAMBDA (textStream) (* DSB "22-Aug-86 13:09") (* * ask user to declare a default directory, using the previously defined directory as a default. The default is initially set to the user's root directory when the host is declared.) (PROG (messageWindow newDirectory (oldDirectory (TEXTPROP textStream (QUOTE MS.DIRECTORY))) (host (TEXTPROP textStream (QUOTE MS.HOST)))) (* * first clear the message window) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (* * then make sure a host has been declared) (COND ((NOT host) (RETURN (TEDIT.PROMPTPRINT textStream "No host has yet been declared. Name your host first." T)))) (* * then reset directory if changed) (SETQ newDirectory (MKATOM (TEDIT.GETINPUT textStream "Directory: " oldDirectory))) (COND ((EQUAL newDirectory oldDirectory) (TEDIT.PROMPTPRINT textStream (CONCAT newDirectory " is the same as the previous value...Directory unchanged") T)) (T (TEXTPROP textStream (QUOTE MS.DIRECTORY) newDirectory) (TEDIT.PROMPTPRINT textStream (CONCAT "Directory is " newDirectory) T)))))) (FE.MyGet (LAMBDA (textStream) (* DSB "22-Aug-86 12:59") (* My TEDIT Get Function) (* * after getting the file, it sets the FILENAME textprop to the new fullFilename. This textprop is only changed  by a Get, whereas due to an error in TEDIT, the TXTFILE slot of textObj can change whenever an OPENFILE is made to  the server) (* * Note that we only store the versionless filename, because it then gets updated properly on a Put.) (PROG (messageWindow textObj fileStream fullFilename versionlessFilename) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (SETQ textObj (TEXTOBJ textStream)) (TEDIT.GET textObj) (SETQ fileStream (fetch TXTFILE of textObj)) (SETQ fullFilename (FULLNAME fileStream)) (SETQ versionlessFilename (FE.StripVersion fullFilename)) (TEXTPROP textStream (QUOTE FILENAME) versionlessFilename)))) (FE.MyPut (LAMBDA (textStream) (* DSB " 7-Nov-86 11:03") (* my TEDIT put function) (* * When the edit buffer is to be saved for the first time, the FILENAME TEXTPROP is NIL. Subsequently, it has a  (versionless) value, which remains the same if put the the same filename or is altered if put to a different  filename) (* * The new filename is stored without version number in the FILENAME field of TEXTPROP) (* * The reason for this stuff is that the name in (FULLNAME (fetch TXTFILE of textObj)) can be altered by an  OPENFILE, when both files are on a non-leaf server. Thus, we have to keep track of the TEDIT filename ourselves.) (PROG (messageWindow newFilename textObj fileStream fullFilename versionlessFilename) (* * first clear the message window) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (* * get the filename to be put. If the user inputs a c.r., it returns the old filename; otherwise, it retains the  user input.) (SETQ oldFilename (TEXTPROP textStream (QUOTE FILENAME))) (SETQ newFilename (MKATOM (U-CASE (TEDIT.GETINPUT textStream "(Put) Filename:" oldFilename)))) (* * put the returned filename) (TEDIT.PUT textStream newFilename NIL T) (* * a new FILENAME textprop is saved only when the new filename differs from the old filename) (COND ((EQUAL oldFilename newFilename) (RETURN)) (T (SETQ textObj (TEXTOBJ textStream)) (SETQ fileStream (fetch TXTFILE of textObj)) (SETQ fullFilename (FULLNAME fileStream)) (SETQ versionlessFilename (FE.StripVersion fullFilename)) (TEXTPROP textStream (QUOTE FILENAME) versionlessFilename)))))) (FE.StripVersion (LAMBDA (fullFilename) (* DSB "20-Aug-86 13:50") (* returns a filename with the version stripped number out) (PROG (host directory name extension) (SETQ host (UNPACKFILENAME fullFilename (QUOTE HOST))) (SETQ directory (UNPACKFILENAME fullFilename (QUOTE DIRECTORY))) (SETQ name (UNPACKFILENAME fullFilename (QUOTE NAME))) (SETQ extension (UNPACKFILENAME fullFilename (QUOTE EXTENSION))) (RETURN (PACKFILENAME (QUOTE HOST) host (QUOTE DIRECTORY) directory (QUOTE NAME) name (QUOTE EXTENSION) extension))))) (FE.Compile (LAMBDA (textStream) (* DSB "22-Aug-86 11:54") (* * Compile the file associated with this edit process.) (PROG (fullFilename filename directory host result errorFile errorWindow editWindow messageWindow (textObj (TEXTOBJ textStream))) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (* * Make sure we have a text object) (COND ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) (PRIN1 "No text to compile" messageWindow) (RETURN NIL))) (* * See if the file is ready to use) (COND ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) (PRIN1 "Text non-existant or unsaved: compile aborted" messageWindow) (RETURN NIL))) (* * Check that a host has been specified) (COND ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) (PRIN1 "Can't compile. No Host has been declared" messageWindow) (RETURN NIL))) (* * Do the compile) (TEDIT.PROMPTPRINT textStream (CONCAT "Compiling " fullFilename " on " (_ host Name) "...") T) (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) (MS.CloseErrorWindow editWindow) (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) filename))) (CLEARW messageWindow) (PRIN1 result messageWindow) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (TEDIT.PROMPTPRINT textStream "Compilation errors" T) (SETQ errorWindow (MS.AttachErrorWindow editWindow "Compilation Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow editWindow)) (T (TEDIT.PROMPTPRINT textStream "Successful compilation." T)))))) (FE.Link (LAMBDA (textStream) (* DSB "22-Aug-86 12:01") (* * Link the file associated with this edit process.) (PROG (fullFilename filename directory host result errorFile errorWindow editWindow messageWindow (textObj (TEXTOBJ textStream))) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (* * Make sure we have a text object) (COND ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) (PRIN1 "No file to link" messageWindow) (RETURN NIL))) (* * See if the file is ready to use) (COND ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) (PRIN1 "File non-existant or unsaved: link aborted" messageWindow) (RETURN NIL))) (* * Check that a host has been specified) (COND ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) (PRIN1 "Can't link. No Host has been declared" messageWindow) (RETURN NIL))) (* * Do the link) (TEDIT.PROMPTPRINT textStream (CONCAT "Linking " fullFilename " on " (_ host Name) "...") T) (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) (MS.CloseErrorWindow editWindow) (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) filename))) (CLEARW messageWindow) (PRIN1 result messageWindow) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (TEDIT.PROMPTPRINT textStream "Linking error" T) (SETQ errorWindow (MS.AttachErrorWindow editWindow "Link Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow editWindow)) (T (TEDIT.PROMPTPRINT textStream "Successful link" T)))))) (FE.CompileLinkRun (LAMBDA (textStream) (* DSB "22-Aug-86 11:54") (* * sequentially compiles, links, and runs the file associated with this edit process.) (PROG (fullFilename filename directory host result errorFile errorWindow editWindow messageWindow (textObj (TEXTOBJ textStream))) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (* * Make sure we have a text object) (COND ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) (PRIN1 "No text to compile" messageWindow) (RETURN NIL))) (* * See if the file is ready to use) (COND ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) (PRIN1 "Text non-existant or unsaved: compile aborted" messageWindow) (RETURN NIL))) (* * Check that a host has been specified) (COND ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) (PRIN1 "Can't compile. No Host has been declared" messageWindow) (RETURN NIL))) (* * Do the compile) (TEDIT.PROMPTPRINT textStream (CONCAT "Compiling " fullFilename " on " (_ host Name) "...") T) (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) (MS.CloseErrorWindow editWindow) (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) filename))) (CLEARW messageWindow) (PRIN1 result messageWindow) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (TEDIT.PROMPTPRINT textStream "Compilation errors" T) (SETQ errorWindow (MS.AttachErrorWindow editWindow "Compilation Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow editWindow) (RETURN)) (T (TEDIT.PROMPTPRINT textStream "Successful compilation." T))) (* * Do the link) (TEDIT.PROMPTPRINT textStream (CONCAT "Linking " fullFilename " on " (_ host Name) "...") T) (MS.CloseErrorWindow editWindow) (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) filename))) (CLEARW messageWindow) (PRIN1 result messageWindow) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (TEDIT.PROMPTPRINT textStream "Linking error" T) (SETQ errorWindow (MS.AttachErrorWindow editWindow "Link Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow editWindow) (RETURN)) (T (TEDIT.PROMPTPRINT textStream "Successful link" T))) (* * Run the job interactively) (TEDIT.PROMPTPRINT textStream (CONCAT "Running interactive job " fullFilename " on " (_ host Name) "...") T) (MS.CloseErrorWindow editWindow) (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) filename))) (CLEARW messageWindow) (PRIN1 result messageWindow) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (TEDIT.PROMPTPRINT textStream "Run-time warning or error" T) (SETQ errorWindow (MS.AttachErrorWindow editWindow "Run-time Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow editWindow)) (T (TEDIT.PROMPTPRINT textStream "Done" T)))))) (FE.RunInteractive (LAMBDA (textStream) (* DSB "22-Aug-86 12:49") (* * Run (interactively) the file associated with this edit process.) (PROG (fullFilename filename directory host result errorFile errorWindow editWindow messageWindow (textObj (TEXTOBJ textStream))) (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) (CLEARW messageWindow) (* * Make sure we have a text object) (COND ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) (PRIN1 "No file to run" messageWindow) (RETURN NIL))) (* * See if the file is ready to use) (COND ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) (PRIN1 "File non-existant or unsaved: run aborted" messageWindow) (RETURN NIL))) (* * Check that a host has been specified) (COND ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) (PRIN1 "Can't run. No Host has been declared" messageWindow) (RETURN NIL))) (* * Run it) (TEDIT.PROMPTPRINT textStream (CONCAT "Running interactive job " fullFilename " on " (_ host Name) "...") T) (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) (MS.CloseErrorWindow editWindow) (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) filename))) (CLEARW messageWindow) (PRIN1 result messageWindow) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (TEDIT.PROMPTPRINT textStream "Run-time warning or error" T) (SETQ errorWindow (MS.AttachErrorWindow editWindow "Run-time Errors")) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow editWindow)) (T (TEDIT.PROMPTPRINT textStream "Done" T)))))) ) (* SERVER METACLASS FUNCTIONS) (DEFINEQ (FE.ValidHostname (LAMBDA (hostname) (* DSB "20-Aug-86 08:40") (* returns the hostname if it is on the list of valid  hosts) (* * Note that hostname must be passed from FE.SetHost as an upper-case atom) (PROG (server validHostname) (SETQ server (FE.GetServer hostname)) (COND (server (SETQ validHostname (_ server Name)) (RETURN validHostname)) (T NIL))))) (FE.GetServer (LAMBDA (hostname) (* DSB "20-Aug-86 08:42") (* given a hostname, returns the pointer to the  server) (* * note that the hostname must be an upper-case atom) (find server in (_ ($ Server) AllInstances!) suchthat (EQUAL hostname (_ server Name))))) ) (* ICON STUFF) (DEFINEQ (FE.ShrinkIconCreate (LAMBDA (W ICON ICONW) (* DSB " 6-Oct-86 13:52") (* Create the icon that represents this window.) (PROG ((icon (WINDOWPROP W (QUOTE ICON))) (iconTitle (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE))) (shrinkfn (WINDOWPROP W (QUOTE SHRINKFN)))) (COND ((NOT (WINDOWPROP W (QUOTE TEXTOBJ))) (* This isn't really a TEdit window any more. Don't do anything) NIL) ((WINDOWPROP W (QUOTE TEDITMENU)) (* This is a text menu, and shrinks without trace.) NIL) ((OR (IGREATERP (FLENGTH shrinkfn) 3) (AND (NOT (FMEMB (QUOTE SHRINKATTACHEDWINDOWS) shrinkfn)) (IGREATERP (FLENGTH shrinkfn) 2))) (* There are other functions that expect to handle  this. Don't bother.) NIL) ((OR (AND iconTitle (EQUAL iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W)))) (AND (NOT iconTitle) icon)) (* we built this and the title is the same, or he has  already put an icon on this. Do nothing) NIL) (icon (* There's an existing icon window; change the title in it) (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE) (SETQ iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W)))) (ICONTITLE iconTitle NIL NIL icon)) (T (* install a new icon) (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE) (SETQ iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W)))) (WINDOWPROP W (QUOTE ICON) (TITLEDICONW FE.titledIconTemplate iconTitle FE.iconFont NIL T (QUOTE TOP)))))) (WINDOWPROP W (QUOTE ICON)))) ) (RPAQ FE.Icon (READBITMAP)) (120 61 "@@@COOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@@GOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@@N@CHCHAL@L@O@GCION@C@CHAHAO@@" "@@AN@C@AH@L@L@F@CCION@C@AHAHAO@@" "@@CNGOCIILOCLNFGCAIONGOCINGNGO@@" "@@GN@GCIILOCLNFGC@ION@GCINGNGO@@" "@@ON@GCIH@OCL@F@C@AON@GCINGNGO@@" "@AONGOCIHAOCL@N@CBAONGOCINGNGO@@" "@CONGOCIIAOCLHNGCCAONGOCINGNGO@@" "@GONGO@AIHOCLLFGCCION@C@AHANGO@@" "@OONGOHCILGCLNBGCCION@C@CHANGO@@" "AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "CN@@@@@@@@@@@@@@@@@@@B@@@@@@@A@@" "GN@@@@@@@@@@@@@@@@@B@@@@@@@@@A@@" "OJ@@@@@@@@@@@@@@@@@B@@@@@@@@@A@@" "OJ@@@@@@@@@@@@@@@@@@H@@@@@@@@A@@" "NJ@@@@@@@@@@@@@@@@@@H@@@@@@@@A@@" "NJ@H@@@@@@@B@@@@@@@H@@H@@@@@@A@@" "JJ@H@@@@@@@B@@@@@@@H@@H@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "KJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@H@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@H@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@H@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@H@@@@@B@H@@@@@@@@@@@@A@@" "JN@@@@@@@@@@@@B@H@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJB@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "NJB@@@@B@B@H@B@@@B@@@@@@@@@@@A@@" "JJ@@@@@B@B@H@B@@@B@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@BH@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@BH@@@@@H@@@@B@@@@B@@@@@@@@A@@" "JJ@@@@@@@@H@@@@B@@@@B@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@B@@@@@@A@@" "JJH@@@@@@@@@@@@@@@@@@@B@@@@@@A@@" "JJH@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@B@@@@@@@@@@@@@@@@@@@@@@A@@" "JJ@@@@B@@@@@@@@@@@@@@H@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@H@@@@@@@A@@" "JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "KJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" "JKOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "JH@@@@@D@@@@@@@@A@@@@@@@@@H@@D@@" "JOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@" "J@@@@@@@@@@D@@@@@@D@@@@D@@@@A@@@" "KOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@" "H@@@A@@@@@@@@@@@H@@@@@@@@@@BD@@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@") (RPAQ FE.IconMask (READBITMAP)) (120 61 "@@@COOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@@GOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@@OOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@AOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@COOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@GOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@@OOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@AOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@COOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@GOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "@OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "COOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "GOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@" "OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@") (RPAQ? FE.defaultFont (FONTCLASS (QUOTE FORTRANEDITFONT) (QUOTE (1 (GACHA 12) (GACHA 10) (GACHA 10))))) (RPAQ? FE.iconFont (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) (RPAQ? FE.iconTitleRegion (create REGION LEFT _ 8 BOTTOM _ 8 WIDTH _ 110 HEIGHT _ 40)) (RPAQ? FE.titledIconTemplate (create TITLEDICON ICON _ FE.Icon MASK _ FE.IconMask TITLEREG _ FE.iconTitleRegion)) (* VARS) (ADDTOVAR BackgroundMenuCommands (Fortran% Edit (QUOTE (FE.TopLevel)) "Start a Fortran Edit")) (RPAQQ BackgroundMenu NIL) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FE.defaultFont FE.iconFont FE.titledIconTemplate TEDIT.READTABLE) ) (* * SERVERS -- Defines the Loops MathServer objects) (DEFCLASSES Cray FortranServer MathServer Server VMSServer) [DEFCLASS Cray (MetaClass Class doc (* If you want something to be done quickly, use this  class) Edited: (* DSB "30-May-86 14:55")) (Supers MathServer)] [DEFCLASS FortranServer (MetaClass Class Edited: (* DSB "13-May-86 16:09")) (Supers Server)] [DEFCLASS MathServer (MetaClass Class Edited: (* DSB "20-May-86 17:21")) (Supers Server) (ClassVariables (jobManagerProcess NIL doc (* the current process on which the job manager is working. All processes alert the job manager by calling the  AlertManager method and giving this variable as an argument) ))] [DEFCLASS Server (MetaClass AbstractClass Edited: (* DSB "10-Nov-86 08:20")) (Supers IndexedObject Object) (InstanceVariables (host NIL doc (* network name of host ; eg., GSLVAX)) (name NIL doc (* vernacular name of host; eg., GSLVAX)) (description NIL doc (* short description of server)) (serverDirectory NIL doc (* directory for server command files)) (queues NIL doc (* list of names of batch queues)) (sourceExtension NIL doc (* default extension, such as FOR, for source files) ) (commandFileExtension NIL doc (* default extension, such as COM, for command files) ))] [DEFCLASS VMSServer (MetaClass Class doc (* this is a DEC VMS machine) Edited: (* DSB "10-Nov-86 08:22")) (Supers MathServer FortranServer) (InstanceVariables (sourceExtension FOR doc (* VMS fortran extension)) (commandFileExtension COM doc (* VMS command file default extension)) (comFileName (SUBMITJOB submitJob.com ABORTJOB abortJob.com RUNJOB runJob.com STATUS status.com LINK link.com COMPLINK complink.com COMPILE compile.com GETTIME getTime.com) doc (* VMS com files) ) (resultFileName (SUBMITJOB submitJob.res ABORTJOB abortJob.res RUNJOB runJob.res STATUS status.res COMPILE compile.res LINK link.res COMPLINK complink.res GETTIME getTime.res) doc (* VMS result files) ))] [METH FortranServer Compile (filename) (* compiles file, which must be on the host)] [METH FortranServer Compiled? (host defaultDirectory filename) (* Checks if an object file exists on the host. If so, returns T)] [METH FortranServer Link (filename linkedFilesList) (* links object files on the host into an executable file)] [METH FortranServer Linked? (host defaultDirectory filename) (* Checks if an executable file exists on the host. If so, returns T)] [METH MathServer AlertManager NIL (* This method is called by all job processes. It starts up the JobManager process if not awakened, and passes the jobManagerProcess variable.)] [METH Server AbortJob (jobNumber queue) (* aborts specific batch job on stated queue) (category MainOps)] [METH Server CommandFileExtension NIL (* returns the extension recognized by the system as a command file)] [METH Server Description NIL (* returns description of the server)] [METH Server Error? (result) (* checks if CAR of result list is "ERROR") (category Results)] [METH Server ErrorFile (result) (* returns the full name of the error file, specified by the third element in the result list) (category Results)] [METH Server ErrorString (result) (* returns the error string: the second element in result list) (category Results)] [METH Server ExecuteCommandFile (commandFile parameterList) (* method to run a command file. The command string is assembled by the local method CommandString)] [METH Server ExtractFilename (result) (* Extract error file name from result)] [METH Server GetQueues NIL (* returns the list of queues for the server) (category Name)] [METH Server GetTime NIL (* gets the time from the server) (category MainOps)] [METH Server Host NIL (* returns local server instance variable host) (category Name)] [METH Server MakeError (string fileName) (* makes an ERROR ... list) (category Results)] [METH Server MakeFullName (fileName directory) (* Constructs full name of file and host) (category Name)] [METH Server MakePartialName (fileName directory) (* Constructs name of file with directory, but without host)] [METH Server Name NIL (* returns vernacular server name) (category Name)] [METH Server PutErrorInWindow (errorFile errorWindow mainWindow) (* puts text of errorFile in a window)] [METH Server PutTextInWindow (filename position) (* Opens a scrollable TEDIT window for the file)] [METH Server Result (result) (* returns the second element in the result list when there is no error. This is typically the jobID.) (category Results)] [METH Server RunFile (file parameterList resultFile noErrorFlg) (* general method to run a command file and get result and errors) (category MainOps)] [METH Server RunJob (filename parameterList) (* runs com file, "filename" , with additional parameters "parameterList" , all of which must be on the host, as an interactive-type job) (category MainOps)] [METH Server ServerDirectory NIL (* returns the name of the server directory for command files) (category Name)] [METH Server SourceExtension NIL (* returns default extension for source files)] [METH Server Status (jobNumber) (* get machine status of batch jobs) (category MainOps)] [METH Server SubmitJob (filename queue parameterList) (* submits file, which must be on the host, as a batch job) (category MainOps)] [METH Server UserDirectory NIL (* Gets user name on appropriate host) (category Name)] [METH VMSServer MakeCommandString (commandFile parameterList) (* assembles command string from given name of commandFile and parameterList)] (DEFINEQ (FortranServer.Compile (Method ((FortranServer Compile) self filename) (* DSB " 5-Aug-86 10:44") (* compiles file, which must be on the host) (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE COMPILE)) (_ self ServerDirectory)) filename (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE COMPILE))) T))) (FortranServer.Compiled? (Method ((FortranServer Compiled?) self host defaultDirectory filename) (* DSB "12-Aug-86 09:46") (* Checks if an object file exists on the host. If so, returns T) (INFILEP (PACKFILENAME (QUOTE HOST) (_ host Name) (QUOTE DIRECTORY) defaultDirectory (QUOTE NAME) filename (QUOTE EXTENSION) (QUOTE OBJ))))) (FortranServer.Link (Method ((FortranServer Link) self filename linkedFilesList) (* DSB " 8-Aug-86 09:33") (* links object files on the host into an executable  file) (* * linkedFilesList is either NIL or a list composed of a single string. The parameterList sent to RunFile is thus a list composed of the filename and optional string of linked files.) (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE LINK)) (_ self ServerDirectory)) (CONS filename linkedFilesList) (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE LINK))) T))) (FortranServer.Linked? (Method ((FortranServer Linked?) self host defaultDirectory filename) (* DSB "12-Aug-86 10:10") (* Checks if an executable file exists on the host. If so, returns T) (INFILEP (PACKFILENAME (QUOTE HOST) (_ host Name) (QUOTE DIRECTORY) defaultDirectory (QUOTE NAME) filename (QUOTE EXTENSION) (QUOTE EXE))))) (MathServer.AlertManager (Method ((MathServer AlertManager) self) (* DSB "22-May-86 16:54") (* This method is called by all job processes. It starts up the JobManager process if not awakened,  and passes the jobManagerProcess variable.) (* * Start MS.JobManager if it isn't going) (COND ((NOT (PROCESSP (@ ::jobManagerProcess))) (_@ ::jobManagerProcess (ADD.PROCESS (QUOTE (MS.JobManager)) (NAME (QUOTE JobManager) RESTARTABLE (QUOTE HARDRESET))))) (T NIL)))) (Server.AbortJob (Method ((Server AbortJob) self jobNumber queue) (* DSB "12-Aug-86 18:07") (* aborts specific batch job on stated queue) (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE ABORTJOB)) (_ self ServerDirectory)) (LIST jobNumber queue) (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE ABORTJOB)))))) (Server.CommandFileExtension (Method ((Server CommandFileExtension) self) (* DSB "10-Nov-86 08:19") (* returns the extension recognized by the system as a command file) (@ commandFileExtension))) (Server.Description (Method ((Server Description) self) (* DSB "19-Aug-86 14:29") (* returns description of the server) (@ description))) (Server.Error? (Method ((Server Error?) self result) (* DSB "21-May-86 11:44") (* checks if CAR of result list is "ERROR") (EQ (QUOTE ERROR) (CAR result)))) (Server.ErrorFile (Method ((Server ErrorFile) self result) (* DSB "21-May-86 11:50") (* returns the full name of the error file, specified  by the third element in the result list) (INFILEP (_ self MakeFullName (CADDR result))))) (Server.ErrorString (Method ((Server ErrorString) self result) (* DSB "21-May-86 11:46") (* returns the error string: the second element in  result list) (CADR result))) (Server.ExecuteCommandFile (Method ((Server ExecuteCommandFile) self commandFile parameterList) (* DSB "10-Nov-86 10:59") (* method to run a command file. The command string is assembled by the local method  CommandString) (PROGRAMCHAT (_ self Host) (_ self MakeCommandString commandFile parameterList) NIL))) (Server.ExtractFilename (Method ((Server ExtractFilename) self result) (* DSB " 6-Aug-86 11:28") (* Extract error file name from result) (CAR (REVERSE result)))) (Server.GetQueues (Method ((Server GetQueues) self) (* DSB " 9-Jun-86 08:41") (* returns the list of queues for the server) (@ queues))) (Server.GetTime (Method ((Server GetTime) self) (* DSB "13-Jun-86 13:17") (* gets the time from the server) (* RunFile returns a list whose CAR is OK) (_ self Result (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE GETTIME)) (_ self ServerDirectory)) NIL (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE GETTIME))) NIL)))) (Server.Host (Method ((Server Host) self) (* DSB "23-May-86 13:52") (* returns local server instance variable host) (CANONICAL.HOSTNAME (@ host)))) (Server.MakeError (Method ((Server MakeError) self string fileName) (* DSB "21-May-86 15:49") (* makes an ERROR ... list) (LIST (QUOTE ERROR) string fileName))) (Server.MakeFullName (Method ((Server MakeFullName) self fileName directory) (* DSB "22-May-86 14:54") (* Constructs full name of file and host) (* * if directory is not specified, it uses the user's login name on the host; i.e., the user's directory) (COND ((NOT directory) (PACKFILENAME (QUOTE HOST) (_ self Host) (QUOTE DIRECTORY) (_ self UserDirectory) (QUOTE BODY) fileName)) (T (* * otherwise, it uses the specified directory name) (PACKFILENAME (QUOTE HOST) (_ self Host) (QUOTE DIRECTORY) directory (QUOTE BODY) fileName))))) (Server.MakePartialName (Method ((Server MakePartialName) self fileName directory) (* DSB "13-Jun-86 13:07") (* Constructs name of file with directory, but without host) (* * if directory is not specified, it uses the user's login name on the host; i.e., the user's root directory) (COND ((NOT directory) (PACKFILENAME (QUOTE DIRECTORY) (_ self UserDirectory) (QUOTE BODY) fileName)) (T (* * otherwise, it uses the specified directory name) (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE BODY) fileName))))) (Server.Name (Method ((Server Name) self) (* DSB " 9-Jun-86 08:34") (* returns vernacular server name) (@ name))) (Server.PutErrorInWindow (Method ((Server PutErrorInWindow) self errorFile errorWindow mainWindow) (* DSB "15-Aug-86 17:42") (* puts text of errorFile in a window) (* * put the errorFile in the errorWindow and set errorWindow props) (OPENTEXTSTREAM errorFile errorWindow NIL NIL (QUOTE (PROMPTWINDOW (WINDOWPROP mainWindow (QUOTE PROMPTWINDOW))))) (WINDOWPROP errorWindow (QUOTE ERRORFILE) errorFile) (WINDOWADDPROP errorWindow (QUOTE CLOSEFN) (QUOTE MS.CleanupErrorFile)))) (Server.PutTextInWindow (Method ((Server PutTextInWindow) self filename position) (* DSB "21-Jul-86 14:23") (* Opens a scrollable TEDIT window for the file) (TEDIT filename NIL NIL (QUOTE (READONLY T))))) (Server.Result (Method ((Server Result) self result) (* DSB "21-May-86 17:52") (* returns the second element in the result list when  there is no error. This is typically the jobID.) (CADR result))) (Server.RunFile (Method ((Server RunFile) self file parameterList resultFile noErrorFlg) (* DSB " 9-Nov-86 13:49") (* general method to run a command file and get result and errors) (* * "file" is the name of the command file given to PROGRAMCHAT to be run on the host, and it must be in the  proper host format (eg, submitjob) whereas "resultFile" is the name of the result file returned on  the host, but it must be in the proper LISP naming format (eg, {GSLVAX10}submitjob.res)) (LET (f result fullResultFile newFile) (* * runs a command file) (_ self ExecuteCommandFile file parameterList) (* * look for result file) (COND ((SETQ fullResultFile (INFILEP (_ self MakeFullName resultFile))) (SETQ f (OPENFILE fullResultFile (QUOTE INPUT))) (SETQ result (READ f)) (CLOSEF f) (* (DELFILE f)) ) (T (SETQ result (_ self MakeError "no result" NIL)))) (* * handle the errors) (* * default case (noErrorFlg=NIL) is not to return on errors. In this case, generate a break with an error  message.) (* * Otherwise, do not break (if noErrorFlg=T). Instead, copy the error file to a file on core, and return its  filename (e.g., {core}compile.err)) (* * after this runs, start up Job Manager, using (_ self AlertManager)) (COND ((NOT noErrorFlg) (COND ((_ self Error? result) (DELFILE (_ self ErrorFile result)) (ERROR (CONCAT (_ self Name) ": " (_ self ErrorString result)))) (T (SETQ result (_ self Result result))))) (T (* return complete result to user) (COND ((_ self Error? result) (COND ((SETQ f (_ self ErrorFile result)) (SETQ newFile (COPYFILE f (PACKFILENAME (QUOTE HOST) (QUOTE CORE) (QUOTE BODY) (_ self ExtractFilename result)))) (* (DELFILE f)) (SETQ result (_ self MakeError (_ self ErrorString result) newFile))) (T result))) (T result)))) (* * starts up JobManager, etc. Not yet implemented) (* (_ self AlertManager)) result))) (Server.RunJob (Method ((Server RunJob) self filename parameterList) (* DSB "11-Aug-86 11:06") (* runs com file, "filename", with additional  parameters "parameterList", all of which must be on  the host, as an interactive-type job) (* * parameterList is in RunJob either NIL or a list of parameters composed of a single string. The parameterList sent to RunFile is thus a list composed of the filename and optional string of associated  parameters.) (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE RUNJOB)) (_ self ServerDirectory)) (CONS filename parameterList) (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE RUNJOB))) T))) (Server.ServerDirectory (Method ((Server ServerDirectory) self) (* DSB "22-May-86 15:37") (* returns the name of the server directory for  command files) (@ serverDirectory))) (Server.SourceExtension (Method ((Server SourceExtension) self) (* DSB "21-Aug-86 16:46") (* returns default extension for source files) (@ sourceExtension))) (Server.Status (Method ((Server Status) self jobNumber) (* DSB "12-Aug-86 13:51") (* get machine status of batch jobs) (* if a jobNumber is specified it returns either the CPU time elapsed (if running) or the error message if it  bombed, or NIL if neither.) (* if no jobNumber is specified, returns a list, each element of which is a prop list of the form  ((JOB jobNumber) (CPU timeElapsed))) (LET (errorFile f result) (* * if a jobNumber is specified, return its status) (COND (jobNumber (OR (CAR (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE STATUS)) (_ self ServerDirectory)) jobNumber (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE STATUS))) NIL)) (COND ((SETQ errorFile (INFILEP (_ self MakeFullName (CONCAT jobNumber ".res")))) (SETQ f (OPENFILE errorFile (QUOTE INPUT))) (SETQ result (READ f)) (CLOSEF f) (* (DELFILE f)) result) (T NIL)))) (T (* * else, return the status of all active jobs) (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE STATUS)) (_ self ServerDirectory)) jobNumber (LISTGET (@ resultFileName) (QUOTE STATUS)) NIL)))))) (Server.SubmitJob (Method ((Server SubmitJob) self filename queue parameterList) (* DSB " 8-Aug-86 11:47") (* submits file, which must be on the host, as a batch job) (* * parameterList in SubmitJob is either NIL or a list of parameters composed of a single string. The parameterList sent to RunFile is thus a list ocmposed of the filename, queue, and optional string of associated parameters.) (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) (QUOTE SUBMITJOB)) (_ self ServerDirectory)) (CONS filename (CONS queue parameterList)) (_ self MakeFullName (LISTGET (@ resultFileName) (QUOTE SUBMITJOB))) NIL))) (Server.UserDirectory (Method ((Server UserDirectory) self) (* DSB "13-Jun-86 11:34") (* Gets user name on appropriate host) (* Forces login if not logged in) (OR (MKATOM (CAAR (GETHASH (CANONICAL.HOSTNAME (_ self Host)) LOGINPASSWORDS))) (LOGIN (_ self Host))))) (VMSServer.MakeCommandString (Method ((VMSServer MakeCommandString) self commandFile parameterList) (* DSB "22-May-86 16:05") (* assembles command string from given name of  commandFile and parameterList) (* Note that the commandFile and the parameterList  must be quoted when this function is called) (CONCAT "@" commandFile (for p in (MKLIST parameterList) bind (s _ "") do (SETQ s (CONCAT s " " p)) finally (RETURN s))))) ) (DEFINEQ (MS.MakeInstances (LAMBDA NIL (* DSB " 9-Oct-86 11:18") (* Initialization routine: makes browser and instances of servers) (* * make class browser for Server) (LET (newBrowser) (SETQ newBrowser (_ ($ ClassBrowser) New)) (_ newBrowser AddRoot ($ Server))) (* * make $GSLVAX instance of VMSServer) (_ ($ VMSServer) New (QUOTE GSLVAX)) (_@ ($ GSLVAX) host (QUOTE GSLVAX)) (_@ ($ GSLVAX) name (QUOTE GSLVAX)) (_@ ($ GSLVAX) description "The GSL 11/780 VMS Server") (_@ ($ GSLVAX) serverDirectory (QUOTE )) (_@ ($ GSLVAX) queues (QUOTE (Fast Medium Slow))) (* * make $SITKA instance of VMSServer) (* the host value, SITKA, refers to the pup address  204#156#) (_ ($ VMSServer) New (QUOTE SITKA)) (_ ($ SITKA) PutValue (QUOTE host) (QUOTE SITKA)) (_@ ($ SITKA) name (QUOTE SITKA)) (_@ ($ SITKA) description "The GSL microVAX VMS Server") (_@ ($ SITKA) serverDirectory (QUOTE )) (_@ ($ SITKA) queues (QUOTE (Fast Slow))) (_@ ($ SITKA) comFileName (QUOTE (SUBMITJOB submitJob.com ABORTJOB abortJob.com RUNJOB runJob.com STATUS status.com COMPILE compile.com LINK link.com GETTIME getTime.com))) (_@ ($ SITKA) resultFileName (QUOTE (SUBMITJOB submitJob.res ABORTJOB abortJob.res RUNJOB runJob.res STATUS status.res COMPILE compile.res LINK link.res GETTIME getTime.res))) (* * make $MADVAX instance of VMSServer) (_ ($ VMSServer) New (QUOTE MADVAX)) (_@ ($ MADVAX) host (QUOTE MADVAX)) (_@ ($ MADVAX) name (QUOTE MADVAX)) (_@ ($ MADVAX) description "The AIS 11/750 VMS Server") (_@ ($ MADVAX) serverDirectory (QUOTE )) (_@ ($ MADVAX) queues (QUOTE (Fast Medium Slow))) (* * make $CRAYZY instance of Cray VaporServer) (_ ($ Cray) New (QUOTE CRAYZY)) (_ ($ CRAYZY) PutValue (QUOTE host) (QUOTE CRAYZY)) (_@ ($ CRAYZY) name (QUOTE CRAYZY)) (_@ ($ CRAYZY) description "Not yet plugged in..."))) (StripPA (LAMBDA (username) (* DSB "22-May-86 11:50") (SUBATOM username 1 (LET ((POS (STRPOS "." username))) (COND ((FIXP POS) (SUB1 POS)) (T NIL)))))) ) (MS.DestroyInstances) (MS.MakeInstances) (* * PROGRAMCHAT - Windowless CHAT for communication) (DEFINEQ (OPENCHATSTREAM (LAMBDA (HOST) (* ejs: "23-Feb-85 19:22") (PROG (OPENFUNCTION) (COND ((BOUNDP (QUOTE CHAT.PROTOCOLTYPES)) (COND ((for PROTOCOL in CHAT.PROTOCOLTYPES thereis (SETQ OPENFUNCTION (APPLY* (CDR PROTOCOL) HOST))) (RETURN (APPLY* (CADR OPENFUNCTION) (CAR OPENFUNCTION)))))) ((BOUNDP (QUOTE CHAT.PROTOCOLS)) (COND ((for PROTOCOL in CHAT.PROTOCOLS thereis (SETQ OPENFUNCTION (APPLY* PROTOCOL HOST))) (RETURN (APPLY* (CADR OPENFUNCTION) (CAR OPENFUNCTION)))))))))) (PROGRAMCHAT (LAMBDA (HOST CMDSTREAM LOGSTREAM) (* DSB " 9-Nov-86 13:02") (PROG ((STREAMPAIR (OPENCHATSTREAM HOST)) INCHAT OUTCHAT) (COND (STREAMPAIR (SETQ INCHAT (CAR STREAMPAIR)) (SETQ OUTCHAT (CDR STREAMPAIR)) (SETFILEINFO OUTCHAT (QUOTE ENDOFSTREAMOP) (FUNCTION CHAT.ENDOFSTREAMOP)) (SETFILEINFO INCHAT (QUOTE ENDOFSTREAMOP) (FUNCTION CHAT.ENDOFSTREAMOP)) (ADD.PROCESS (BQUOTE (PROGRAMCHAT.OUTPUT (QUOTE , INCHAT) (QUOTE , LOGSTREAM)))) (BLOCK) (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT) (COND ((STRINGP CMDSTREAM) (SETQ CMDSTREAM (OPENSTRINGSTREAM CMDSTREAM (QUOTE INPUT))))) (COND ((NULL LOGSTREAM) (SETQ LOGSTREAM (OPENSTREAM (QUOTE {NULL}) (QUOTE OUTPUT))))) (while (AND (OPENP OUTCHAT (QUOTE OUTPUT)) (NOT (EOFP CMDSTREAM))) do (BOUT OUTCHAT (BIN CMDSTREAM)) (BLOCK) finally (COND ((EOFP CMDSTREAM) (CLOSEF CMDSTREAM) (BOUT OUTCHAT (CHARCODE CR)) (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT (QUOTE LOGOUT)) (FORCEOUTPUT OUTCHAT T) (until (NOT (OPENP INCHAT (QUOTE INPUT))) do (BLOCK) finally (CLOSEF OUTCHAT)))))))))) (PROGRAMCHAT.LOGIN (LAMBDA (HOST INSTREAM OUTSTREAM OPTION) (* ejs: "24-Jan-85 18:52") (* * Login to HOST. If a job already exists on HOST, Attach to it unless OPTION overrides.) (PROG ((LOGINFO (CDR (ASSOC (OR (GETOSTYPE HOST) (QUOTE IFS)) NETWORKLOGINFO))) NAME/PASS COM) (OR LOGINFO (RETURN)) (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST)) (SETQ COM (COND (OPTION) ((ASSOC (QUOTE ATTACH) LOGINFO) (OR (CHAT.LOGINFO INSTREAM HOST (CAR NAME/PASS)) (QUOTE LOGIN))) (T (* Don't know how to do anything but login, so silly  to try anything else) (QUOTE LOGIN)))) (COND ((NULL (SETQ LOGINFO (ASSOC COM LOGINFO))) (printout PROMPTWINDOW T "Login option " COM " not implemented for this type of host") ) (T (for X in (CDR LOGINFO) do (SELECTQ X (CR (BOUT OUTSTREAM (CHARCODE CR)) (FORCEOUTPUT OUTSTREAM)) (USERNAME (PRIN3 (CAR NAME/PASS) OUTSTREAM)) (PASSWORD (PRIN3 (\DECRYPT.PWD (CDR NAME/PASS)) OUTSTREAM)) (WAIT (* Some systems do not permit typeahead) (COND ((NOT (CHAT.FLUSH&WAIT INSTREAM)) (* Couldn't sync, so wait longer.) (DISMISS CHAT.WAIT.TIME))) (DISMISS CHAT.WAIT.TIME)) (PRIN3 X OUTSTREAM))) (FORCEOUTPUT OUTSTREAM)))))) (PROGRAMCHAT.OUTPUT (LAMBDA (INCHATSTREAM LOGSTREAM) (* ejs: "23-Feb-85 19:18") (bind CH while (AND (NEQ CH -1) (OPENP INCHATSTREAM (QUOTE INPUT))) do (SETQ CH (BIN INCHATSTREAM)) (COND ((NEQ CH -1) (COND (LOGSTREAM (BOUT LOGSTREAM CH))))) finally (COND ((OPENP INCHATSTREAM) (CLOSEF INCHATSTREAM)))))) ) (* VARS for our site) (RPAQQ NETWORKLOGINFO ((TENEX (LOGIN "LOGIN " USERNAME " " PASSWORD " ") (ATTACH "ATTACH " USERNAME " " PASSWORD " ") (WHERE "WHERE " USERNAME CR "ATTACH " USERNAME " " PASSWORD CR) (LOGOUT "LOGOUT" CR)) (TOPS20 (LOGIN "LOGIN " USERNAME CR PASSWORD CR) (ATTACH "ATTACH " USERNAME "" CR PASSWORD CR) (WHERE "LOGIN " USERNAME CR PASSWORD CR) (LOGOUT "LOGOUT" CR)) (UNIX (LOGIN WAIT CR WAIT USERNAME CR WAIT PASSWORD CR WAIT WAIT WAIT WAIT CR) (LOGOUT WAIT CR "logout" CR)) (IFS (LOGIN "Login " USERNAME " " PASSWORD CR) (ATTACH) (LOGOUT "Quit" CR)) (VMS (LOGIN USERNAME CR PASSWORD CR) (LOGOUT "LOGOUT" CR)) (NS (LOGIN "Logon" CR USERNAME CR PASSWORD CR) (LOGOUT "LOGOFF" CR)))) (pushnew NETWORKOSTYPES (QUOTE (GSLVAX . VMS)) (QUOTE (SITKA . VMS)) (QUOTE (MADVAX . VMS))) (* * PROGRAMMER'S INTERFACE - use remote servers with LISP calls) (DEFINEQ (PRIN.RunRemote (LAMBDA (hostname filename parameterList) (* DSB "25-Nov-86 09:41") (* Main Programmer's Interface  (PRIN) function) (PROG (host file result) (* * check preliminaries) (SETQ host (PRIN.ValidateHost hostname)) (COND ((NOT host) (RETURN (PRIN.Error (CONCAT "Host " (U-CASE hostname) " is not valid"))))) (SETQ file (PRIN.ValidateFilename filename host hostname)) (COND ((NOT file) (RETURN (PRIN.Error (CONCAT "Command file " filename " does not exist"))))) (* * run the job) (SETQ result (_ host RunJob file parameterList)) (* * handle the results) (COND ((EQUAL (CAR result) (QUOTE ERROR)) (PRIN.Error "Run-time warning or error" host file result)) (T (PROMPTPRINT (CONCAT "Call to remote host " (U-CASE hostname) " succeeded without error")) (RETURN T)))))) (PRIN.ValidateHost (LAMBDA (hostname) (* DSB "10-Nov-86 08:06") (* returns the host, or NIL if nonexistant) (PROG (host) (SETQ host (FE.GetServer (U-CASE hostname))) (RETURN host)))) (PRIN.ValidateFilename (LAMBDA (filename host hostname) (* DSB "10-Nov-86 08:40") (* returns file if command file exists, or NIL  otherwise) (PROG (directory name extension wholename fileExists?) (SETQ directory (UNPACKFILENAME filename (QUOTE DIRECTORY))) (SETQ name (UNPACKFILENAME filename (QUOTE NAME))) (SETQ extension (_ host CommandFileExtension)) (SETQ wholename (PACKFILENAME (QUOTE HOST) (U-CASE hostname) (QUOTE DIRECTORY) directory (QUOTE NAME) name (QUOTE EXTENSION) extension)) (SETQ fileExists? (INFILEP wholename)) (COND ((NOT fileExists?) (RETURN NIL)) (T (RETURN (PACKFILENAME (QUOTE DIRECTORY) directory (QUOTE NAME) name))))))) (PRIN.Error (LAMBDA (errorString host file result) (* DSB "10-Nov-86 11:17") (* opens an error window and prints the error string  and any run-time error messages) (PROG (hostname errorWindow errorFile) (COND ((AND host file) (SETQ hostname (_ host Name)) (SETQ errorWindow (CREATEW (QUOTE (300 300 420 200)) (CONCAT "PRIN: " errorString " on host " hostname))) (SETQ errorFile (_ host ExtractFilename result)) (_ host PutErrorInWindow errorFile errorWindow)) (T (SETQ errorWindow (CREATEW (QUOTE (300 300 300 80)) "Programmer's Interface Error Window")) (PRIN1 errorString errorWindow)))))) ) (PUTPROPS MATHSERVER COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (4197 14885 (MS.TopLevel 4207 . 5531) (MS.CreateFreeMenu 5533 . 8329) (MS.SelectHost 8331 . 9538) (MS.ExpandFilename 9540 . 10736) (MS.CloseErrorWindow 10738 . 11298) (MS.CleanupErrorFile 11300 . 11832) (MS.AttachErrorWindow 11834 . 12844) (MS.MostRoom 12846 . 13508) (MS.GetMessageWindow 13510 . 13852) (MS.MakeIconWindow 13854 . 14099) (PrintMsg 14101 . 14883)) (14925 15698 ( MS.MakeMenuOfKnownHosts 14935 . 15351) (MS.DestroyInstances 15353 . 15696)) (15733 38409 ( MS.SubmitBatchJob 15743 . 18415) (MS.AbortBatchJob 18417 . 20283) (MS.Status 20285 . 21644) ( MS.DisplayStatus 21646 . 22635) (MS.RunInteractiveJob 22637 . 25063) (MS.Compile 25065 . 27193) ( MS.Link 27195 . 29585) (MS.CompileLink 29587 . 32889) (MS.CLR.Check 32891 . 33195) (MS.CLR.NoCheck 33197 . 33507) (MS.CompileLinkRun 33509 . 38407)) (38447 42814 (MS.StartNewFE 38457 . 38753) ( MS.StartDefaultFE 38755 . 40730) (MS.FindFortranEdit 40732 . 41673) (MS.CheckForDirtyFile 41675 . 42812)) (42852 47051 (MS.BatchErrors? 42862 . 45339) (MS.BatchLog 45341 . 47049)) (50865 60017 ( FE.TopLevel 50875 . 52556) (FE.AdjustProps 52558 . 53265) (FE.CaretPosition 53267 . 55145) ( TEDIT.PARA&CHAR 55147 . 56522) (FE.CharFn 56524 . 56830) (FE.GetEditProps 56832 . 57951) ( FE.GetSourceFileName 57953 . 59635) (FE.LoopFn 59637 . 60015)) (60047 64784 (FE.GetPositionWindow 60057 . 61139) (FE.GetEditWindow 61141 . 62925) (FE.GetMessageWindow 62927 . 63409) (FE.ReshapeFn 63411 . 63721) (FE.ShadeWindow 63723 . 64782)) (64817 84050 (FE.CreateLocalMenu 64827 . 66468) ( FE.SetHost 66470 . 67980) (FE.SetDirectory 67982 . 69411) (FE.MyGet 69413 . 70543) (FE.MyPut 70545 . 72589) (FE.StripVersion 72591 . 73415) (FE.Compile 73417 . 75646) (FE.Link 75648 . 77825) ( FE.CompileLinkRun 77827 . 81823) (FE.RunInteractive 81825 . 84048)) (84090 85128 (FE.ValidHostname 84100 . 84668) (FE.GetServer 84670 . 85126)) (85152 87199 (FE.ShrinkIconCreate 85162 . 87197)) (99037 117564 (FortranServer.Compile 99047 . 99571) (FortranServer.Compiled? 99573 . 100108) ( FortranServer.Link 100110 . 100890) (FortranServer.Linked? 100892 . 101427) (MathServer.AlertManager 101429 . 102140) (Server.AbortJob 102142 . 102665) (Server.CommandFileExtension 102667 . 103004) ( Server.Description 103006 . 103269) (Server.Error? 103271 . 103560) (Server.ErrorFile 103562 . 103938) (Server.ErrorString 103940 . 104248) (Server.ExecuteCommandFile 104250 . 104711) ( Server.ExtractFilename 104713 . 105001) (Server.GetQueues 105003 . 105265) (Server.GetTime 105267 . 105888) (Server.Host 105890 . 106167) (Server.MakeError 106169 . 106451) (Server.MakeFullName 106453 . 107300) (Server.MakePartialName 107302 . 108087) (Server.Name 108089 . 108328) ( Server.PutErrorInWindow 108330 . 109007) (Server.PutTextInWindow 109009 . 109329) (Server.Result 109331 . 109668) (Server.RunFile 109670 . 112378) (Server.RunJob 112380 . 113285) ( Server.ServerDirectory 113287 . 113604) (Server.SourceExtension 113606 . 113890) (Server.Status 113892 . 115534) (Server.SubmitJob 115536 . 116388) (Server.UserDirectory 116390 . 116888) ( VMSServer.MakeCommandString 116890 . 117562)) (117565 120654 (MS.MakeInstances 117575 . 120398) ( StripPA 120400 . 120652)) (120756 125312 (OPENCHATSTREAM 120766 . 121492) (PROGRAMCHAT 121494 . 122998 ) (PROGRAMCHAT.LOGIN 123000 . 124845) (PROGRAMCHAT.OUTPUT 124847 . 125310)) (126250 129561 ( PRIN.RunRemote 126260 . 127389) (PRIN.ValidateHost 127391 . 127722) (PRIN.ValidateFilename 127724 . 128739) (PRIN.Error 128741 . 129559))))) STOP \ No newline at end of file diff --git a/lispusers/MATHSERVER.COMMANDFILES b/lispusers/MATHSERVER.COMMANDFILES new file mode 100644 index 00000000..41e6e624 --- /dev/null +++ b/lispusers/MATHSERVER.COMMANDFILES @@ -0,0 +1,13 @@ +ABORTJOB.COM $ ! abortJob.com $ ! this file is used to abort a batch job $ ! p1 is the jobNumber; p2 is the queue $ ! The "show batch" command is used to determine if the job exists. If $ ! it does not, the message NIL is returned; otherwise, the job is $ ! aborted. $ ! All messages are returned to the user's root directory. $ ! If there is a serious error, ... $ ! if there is an error in the running of this com file, the detailed $ ! error message gets sent to abortJob.err in the user's root directory. $ !SET VERIFY $ delete sys$login:abortJob.err.* $ delete sys$login:abortJob.res.* $ SET NOVERIFY $ define sys$output abortJob.tmp $ show queue 'P2' $ deassign sys$output $ !SET VERIFY $ open/write result sys$login:abortJob.res $ $ loop: $ open/read file abortJob.tmp $ read/end_of_file=done file line $ jobNumber = f$integer(f$extract(32,4,line)) $ if jobNumber .eq. P1 then goto found $ goto loop $ $ done: $ write result "( OK NIL)" ! job not found $ goto finish $ $ found: $ define sys$error sys$login:abortJob.err $ on error then goto error $ stop/entry='P1' 'P2' $ deassign sys$error $ write result "( OK ( Job ",P1," on queue ",P2,- " has been aborted))" $ $ finish: $ close result $ close file $ delete abortJob.tmp.* $ exit $ error: $ @[gslws.server]error sys$login:abortJob.res '$STATUS' $ deassign sys$error $ close result $ close file $ delete abortJob.tmp.* ----------------------------------- COMPILE.COM $ ! COMPILE.COM 8/7/86 $ ! this file is used to compile a job interactively. $ ! job is the name of the user's fortran source file $ ! the file exists in the user's local directory, which may be a $ ! subdirectory of the root directory. $ ! the object file is made in the user's local directory. $ ! if there is no error in compilation, the name and date of the $ ! object file are returned in sys$login:compile.res. $ ! if there is an error in compilation, the abbreviated error message $ ! is returned in sys$login:compile.res, and the detailed $ ! error message is written to sys$login:compile.err. $ $ $ !SET VERIFY $ job = f$parse("''P1'",,,"name") $ userDirectory = f$parse("''P1'",,,"directory") $ length=f$length(job) $ ! show symbol job $ ! show symbol userDirectory $ ! show sym length $ delete sys$login:compile.err.* $ delete sys$login:compile.res.* $ delete 'P1'.obj.* $ define sys$error sys$login:compile.err $ ! define sys$error sys$login:'job'.err $ on error then goto error $ $ fortran/object='userDirectory''job' 'P1' $ deassign sys$error $ SET NOVERIFY $ define sys$output sys$login:objFile.tmp $ dir/date 'P1'.obj $ deassign sys$output $ !SET VERIFY $ open/write resultFile sys$login:compile.res $ open/read file sys$login:objFile.tmp $ $ loop: $ read/end_of_file=done file line $ ! show sym line $ name=f$extract(0,length,line) $ ! show sym name $ if name .eqs. job then goto found $ goto loop $ $ done: $ write resultFile "( OK NIL)" ! object file not found $ goto finish $ $ found: $ write resultFile "( OK (",line,"))" $ $ finish: $ close resultFile $ close file $ delete objFile.tmp.* $ exit $ $ error: $ @[gslws.server]error sys$login:compile.res '$STATUS' $ deassign sys$error ----------------------- ERROR.COM $ ! lists error status message in specified file $ ! call by: @error resultFile errorStatus $ $ open/write result 'P1' $ errorFile = f$logical("sys$error") $ ! show sym errorFile $ shortName=f$parse(errorFile,,,"name") $ ! show sym shortName $ write result "(ERROR ""''f$message(P2)'"" ''shortName'.ERR)" $ close result ---------------------------- LINK.COM $ ! LINK.COM 8/8/86 $ ! This file is used to link a series of object files to form an $ ! executable file. $ ! The parameter P1 is the object code filename of the main file. $ ! The parameter P2 is a string composed of all object files to $ ! be linked with P1. There must be a comma between these files $ ! within P2. $ ! Job is the extracted name of the user's main object code file. $ ! This file exists in the user's local directory, which may be a $ ! subdirectory of the root directory. $ ! The executable file is made in the user's local directory. $ ! If there is no error in linking, the name and date of the $ ! executable file are returned in sys$login:link.res. $ ! If there is no error in linking but no .exe file is made, a $ ! message to that effect is returned in sys$login:link.res. $ ! If there is a link warning during linking, an error message is returned $ ! in sys$login:link.res, and the detailed link warning messages are $ ! written to sys$login:link.err. $ ! If there is an error in linking, such as no existing object file, $ ! the abbreviated error message is returned, from the ERROR.COM file, $ ! in sys$login:link.res, and the detailed error message is written $ ! to sys$login:link.err. $ !SET VERIFY $ job = f$parse("''P1'",,,"name") $ userDirectory = f$parse("''P1'",,,"directory") $ length=f$length(job) $ ! show symbol job $ ! show symbol userDirectory $ ! show symbol length $ delete sys$login:link.err.* $ delete sys$login:link.res.* $ delete 'P1'.exe.* $ define sys$error sys$login:link.err $ ! define sys$error sys$login:'job'.err $ on error then goto error $ ! $ ! Note: link warnings can be very serious, such as the absence of object $ ! code modules, in which case a useless .exe file is made. Because $ ! errors (as opposed to warnings) get trapped through the error routine, $ ! these serious link warnings must be handled specially. $ ! $ ! show symbol P2 $ if P2 .eqs. "" then goto simple $ link/exe='userDirectory''job' 'P1','P2' $ goto continue1 $ ! $ simple: $ link/exe='userDirectory''job' 'P1' $ ! $ continue1: $ deassign sys$error $ open/write resultFile sys$login:link.res $ ! $ ! If we've gotten this far, it means no errors occurred. $ ! First, check if link warnings occurred, by determining if a $ ! LINK.ERR file was written. If so, continue through linkerror1. $ ! $ SET NOVERIFY $ define sys$output sys$login:linkFile.tmp $ dir/date/siz sys$login:link.err $ deassign sys$output $ !SET VERIFY $ open/read file sys$login:linkFile.tmp $ ! $ loop1: $ read/end_of_file=continue2 file line $ show sym line $ name=f$extract(0,4,line) $ show sym name $ if name .eqs. "LINK" then goto linkerror1 $ goto loop1 $ ! $ continue2: $ close file $ ! $ ! Second, check if an executable file was made. (Executable files are $ ! made in spite of link warnings. The following check flags a $ ! situation where neither a link warning nor an executable file is made.) $ ! $ SET NOVERIFY $ define sys$output sys$login:exeFile.tmp $ dir/date 'P1'.exe $ deassign sys$output $ !SET VERIFY $ open/read file sys$login:exeFile.tmp $ ! $ loop2: $ read/end_of_file=linkerror2 file line $ show sym line $ name=f$extract(0,length,line) $ show sym name $ if name .eqs. job then goto found $ goto loop2 $ ! $ linkerror1: $ message="error during linking" $ write resultFile "(ERROR ""''message'"" LINK.ERR)" ! link warning $ goto finish1 $ ! $ linkerror2: $ message="executable file not made" $ write resultFile "( OK (",message,"))" ! exe file not made $ goto finish2 $ ! $ found: $ write resultFile "( OK (",line,"))" $ goto finish2 $ ! $ finish1: $ close resultFile $ delete sys$login:linkFile.tmp.* $ exit $ ! $ finish2: $ close resultFile $ close file $ delete sys$login:exeFile.tmp.* $ delete sys$login:linkFile.tmp.* $ exit $ ! $ error: $ @[gslws.server]error sys$login:link.res '$STATUS' $ deassign sys$error ---------------------------------------------- RUNJOB.COM $ ! runjob.com 8/11/86 $ ! this file is used to run an interactive job $ ! job is the name of the user's com file $ ! P2 is the list of appended parameters (optional) $ ! If there is no error in running the job, an OK message is $ ! written out to sys$login:runjob.res. $ ! If there are warnings during the running of the job, an ERROR message $ ! is returned in sys$login:runjob.res, and the detailed warning $ ! messages are returned in sys$login:runjob.err $ ! If there is an error in the running of the job, the abbreviated $ ! error message is returned, from the ERROR.COM file, in $ ! sys$login:runjob.res, and the detailed error message is written $ ! to sys$login:runjob.err. $ !SET VERIFY $ job = f$parse("''P1'",,,"name") $ delete sys$login:runJob.err.* $ delete sys$login:runJob.res.* $ define sys$error sys$login:runJob.err $ on error then goto error $ @'P1' 'P2' $ deassign sys$error $ open/write resultFile sys$login:runJob.res $ ! $ ! If a warning occurs, it is written out to runJob.err $ ! Such warnings are handled specially, through the $ ! runwarning entry. $ ! $ SET NOVERIFY $ define sys$output sys$login:runFile.tmp $ dir/date/siz sys$login:runJob.err $ deassign sys$output $ !SET VERIFY $ open/read file sys$login:runFile.tmp $ ! $ loop: $ read/end_of_file=continue file line $ show sym line $ name=f$extract(0,6,line) $ show sym name $ if name .eqs. "RUNJOB" then goto runwarning $ goto loop $ ! $ continue: $ write resultFile "( OK (",job," ",P1," ))" $ goto finish $ ! $ runwarning: $ message="warning(s) occurred" $ write resultFile "(ERROR ""''message'"" RUNJOB.ERR)" $ ! $ finish: $ close file $ close resultFile $ delete sys$login:runFile.tmp.* $ exit $ ! $ error: $ @[gslws.server]error sys$login:runJob.res '$STATUS' $ deassign sys$error ------------------------------------------- STATUS.COM $ ! get status of batch jobs $ ! If jobNumber is specified, return only status of that job $ ! If jobNumber is not specified, return all jobs $ ! called by: @status jobNumber $ $ delete status.res.* $ $ define sys$output status.tmp $ show system/batch $ deassign sys$output $ !SET VERIFY $ $ open/read file status.tmp $ open/write result status.res $ write result "( OK (" $ if P1 .eq. "" then goto writeall $ $ loop: $ read/end_of_file=done file line $ job = f$integer(f$extract(15,4,line)) $ if job .eq. P1 then goto found $ goto loop $ $ done: $ write result "NIL" ! no data for specified job $ goto finish $ $ found: $ time = f$extract(49,11,line) $ write result "( (JOB ''P1') (CPU ''time') )" $ goto finish $ $ writeall: $ read/end_of_file=finish file line $ jobType = f$extract(9,5,line) $ if jobType .nes. "BATCH" then goto writeall $ job = f$integer(f$extract(15,4,line)) $ time = f$extract(49,11,line) $ write result "( (JOB ''job') (CPU ''time') )" $ goto writeall $ $ finish: $ write result ") )" $ close result $ close file $ delete status.tmp; $ exit ---------------------------------------- SUBCOM.COM $ ! subcom.com $ ! this is the file actually submitted by submitjob.com $ ! Parameter P1 is the name of the user's COM file to be run $ ! Parameters P2,P3, etc are passed from P3,P4, etc. in SubmitJob.com $ ! jobname is in the form BATCH_xxx $ ! job is the number (xxx) $ ! if there is an error in the running of the batch job, the detailed $ ! error message gets sent to 'job'.err. $ ! The abbreviated error message gets sent to 'job'.res $ ! SET VERIFY $ jobname = f$process() $ job = f$extract(6,f$length(jobname)-6,jobname) $ ! open/write outfile junk. $ ! write outfile jobname," ",job $ ! close outfile $ define sys$error 'job'.err $ on error then goto error $ @'P1' 'P2' 'P3' 'P4' 'P5' 'P6' $ exit $ error: $ @[gslws.server]error 'job'.res '$STATUS' ------------------------------------------ SUBMITJOB.COM $ ! submitjob.com 8/11/86 $ ! submit a job on specified queue $ ! call by: @submitjob file queue parameterString $ ! P1 is the file name of the job to be submitted $ ! P2 is the queue (eg., fast, medium) $ ! P3, P4, P5, etc. are subsidiary parameters, such as file $ ! names (eg., file1.dat, file2.sav). $ ! these files are returned in the user's root directory: $ ! P1.log for log file $ ! submitjob.res for result (job # or error message) $ ! submitjob.err for detailed errors (from sys$error) $ ! submitjob.tmp for temporary output $ ! these files are returned in the user's running (sub)directory: $ ! 'jobnumber'.res for error message to be returned $ ! 'jobnumber'.err for detailed error message $ !SET VERIFY $ job=f$parse("''P1'",,,"name") $ delete sys$login:'job'.log.* $ delete sys$login:submitjob.err.* $ delete sys$login:submitjob.res.* $ delete sys$login:submitjob.tmp.* $ errorFile = "submitjob.err" $ tempFile = "submitjob.tmp" $ resultFile = "submitjob.res" $ define sys$error 'errorFile' $ on error then goto error $ ! submit the batch job $ SET NOVERIFY $ if P3.eqs."" then goto zeropar $ if P4.eqs."" then goto onepar $ if P5.eqs."" then goto twopar $ if P6.eqs."" then goto threepar $ if P7.eqs."" then goto fourpar $ if P8.eqs."" then goto fivepar $ goto abort $ zeropar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ onepar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1','P3')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ twopar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1','P3','P4')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ threepar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1','P3','P4','P5')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ fourpar: $ define sys$output 'tempFile' $ submit/name='job'/parameters=('P1','P3','P4','P5','P6')- /noprint/queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ fivepar: $ define sys$output 'tempFile' $ submit/name='job'/parameters=('P1','P3','P4','P5','P6','P7')- /noprint/queue='P2' [gslws.server]subcom.com $ deassign sys$output $ finish: $ !SET VERIFY $ ! get job number of submitted job from string in submit.tmp $ open/read infile 'tempFile' $ read infile line $ ! line now equals " Job xxxx entered on queue ----" $ startPosition = f$locate("entry",line)+5 $ endPosition = f$locate(")",line) $ numDigits = endPosition - startPosition $ jobNumber = f$extract(startPosition,numDigits,line) $ close infile $ ! delete 'tempFile';* $ open/write outfile 'resultFile' $ write outfile "( OK (",jobNumber, " ", P1," ))" $ close outfile $ ! no (ERROR ...) message, so deassign the error file $ deassign sys$error $ exit $ abort: $ open/write outfile 'errorFile' $ write outfile "Too many job parameters (more than five)" $ close outfile $ deassign sys$error $ exit $ ! get error message $ error: $ @user1:[gslws.server]error 'resultFile' '$STATUS' $ deassign sys$output $ deassign sys$error $ ! delete 'tempFile';* $ exit -----------------------+@(GACHA  ˜ 67B);B9G=9#1!!*),0/-(&*? & + +8 +1+%"."? BCADCE*?>:@@LH%FJG#1')LIN>"+ +& ,;BF+"( ',   ICN*' ( $ !E%? & "  !" +5/ 0,6>+JD4D=F#  (-:8*$'&.  / 7 + ! +7, >3!)"(! 1 / $ .(0 + ) 9>G&G,;1#" +,+$38-B/; =>.C<2 ###'&&('' 01 +41 +91 >1 ;9 @9 +>6+#*6"47 'A  4:ŒŽzş \ No newline at end of file diff --git a/lispusers/MATHTONS b/lispusers/MATHTONS new file mode 100644 index 00000000..cf23cead --- /dev/null +++ b/lispusers/MATHTONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "13-Feb-87 11:01:14" {ERIS}LYRIC>MATHTONS.;1 1284 previous date%: "12-Dec-86 14:37:39" {PHYLUM}KOTO>MATHTONS.;2) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MATHTONSCOMS) (RPAQQ MATHTONSCOMS ((UGLYVARS \MATHTONSARRAY) (ADDVARS (ASCIITONSTRANSLATIONS (MATH \MATHTONSARRAY CLASSIC))))) (READVARS \MATHTONSARRAY) ({Y256 SMALLPOSP 0 0 61307 61234 61235 0 163 61301 61302 0 0 0 182 0 0 0 61286 0 0 0 61306 0 0 61295 {R9 0} 32 61232 61287 8551 162 184 61366 61299 194 61308 199 177 61260 61309 8552 61285 61287 8738 8740 8574 61282 61283 61284 61292 8570 199 167 0 8549 8546 8550 2 61248 61365 61258 61356 61369 61364 61233 61275 61279 61273 61274 61278 61272 61629 61259 61281 61297 61265 61358 61305 61296 61271 61367 61298 180 61626 61368 0 0 0 175 174 0 61351 61267 211 61370 61303 61266 61263 61288 61360 61361 61362 61363 61256 61290 61287 61238 61240 210 61246 61244 61247 61245 61250 61251 61270 61239 188 189 190 61264 {R129 0} }) (ADDTOVAR ASCIITONSTRANSLATIONS (MATH \MATHTONSARRAY CLASSIC)) (PUTPROPS MATHTONS COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/MATHTONS.TEDIT b/lispusers/MATHTONS.TEDIT new file mode 100644 index 00000000..69ddefb6 Binary files /dev/null and b/lispusers/MATHTONS.TEDIT differ diff --git a/lispusers/MATRIXOPS b/lispusers/MATRIXOPS new file mode 100644 index 00000000..e6df7613 --- /dev/null +++ b/lispusers/MATRIXOPS @@ -0,0 +1 @@ +(FILECREATED " 4-Jun-86 18:27:59" {QV}LISP>MATRIXOPS.;12 48308 changes to: (VARS MATRIXOPSCOMS) (FNS QRSOLV MTIMES TRANSPOSE MTRANSPOSE MINVERT MSOLVE MOLS MREGRESS) previous date: "29-May-86 12:39:55" {QV}LISP>MATRIXOPS.;10) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MATRIXOPSCOMS) (RPAQQ MATRIXOPSCOMS ((FNS CHOLESKYFACTOR MTRANSPOSE MINVERT LSOLV LUFACTOR LUINVERSE LUSOLV MTIMES QRFACTOR QROLS QRQTY QRQY QRSOLV MREGRESS RSOLV MSOLVE SVDFACTOR SVDTEST \FLOATAREFMACRO \FLOATASETMACRO) (VARS STACK) (MACROS \FLOATAREF \FLOATASET) (FILES BLAS))) (DEFINEQ (CHOLESKYFACTOR [LAMBDA (MATRIX FACTORMATRIX) (* jop: "28-May-86 12:38") (* * Lifted from LINPACK algorithm SCHDC) (BLAS.CHECKARRAY MATRIX) (LET ((P (ARRAY-DIMENSION MATRIX 0))) (* * Arg Checks) (if [NOT (AND (EQL 2 (ARRAY-RANK MATRIX)) (EQL P (ARRAY-DIMENSION MATRIX 1] then (HELP "Matrix not sqaure" MATRIX)) (if (NULL FACTORMATRIX) then (SETQ FACTORMATRIX (MAKE-ARRAY (ARRAY-DIMENSIONS MATRIX) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY FACTORMATRIX) (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX) (ARRAY-DIMENSIONS MATRIX))) then (HELP "Illegal FACTORMATRIX" FACTORMATRIX))) (* Copy MATRIX to FACTORMATRIX) (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1) (* * Compute the cholesky decomposition of FACTORMATRIX) [bind (WORK _ (MAKE-ARRAY P (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) TEMP for K from 0 to (SUB1 P) do (if (LEQ (\FLOATAREF FACTORMATRIX K K) 0.0) then (HELP "Zero pivot element")) (\FLOATASET (SQRT (\FLOATAREF FACTORMATRIX K K)) WORK K) (\FLOATASET (\FLOATAREF WORK K) FACTORMATRIX K K) (if (NOT (EQL K (SUB1 P))) then (for J from (ADD1 K) to (SUB1 P) do (\FLOATASET (FQUOTIENT (\FLOATAREF FACTORMATRIX K J) (\FLOATAREF WORK K)) FACTORMATRIX K J) (\FLOATASET (\FLOATAREF FACTORMATRIX K J) WORK J) (SETQ TEMP (FMINUS (\FLOATAREF FACTORMATRIX K J))) (BLAS.AXPY TEMP WORK (ADD1 K) 1 FACTORMATRIX (IPLUS J (ITIMES P (ADD1 K))) P (IDIFFERENCE J K] FACTORMATRIX]) (MTRANSPOSE [LAMBDA (SOURCEMATRIX DESTMATRIX) (* jop: " 4-Jun-86 14:07") (* * Transpose the M x N matrix SOURCEMATRIX. DESTMATRIX should be N x M. Returns DESTMATRIX) (BLAS.CHECKARRAY SOURCEMATRIX) (PROG ((M (ARRAY-DIMENSION SOURCEMATRIX 0)) (N (ARRAY-DIMENSION SOURCEMATRIX 1))) (if (NULL DESTMATRIX) then (SETQ DESTMATRIX (MAKE-ARRAY (LIST N M) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY DESTMATRIX) (if (NOT (EQUAL (ARRAY-DIMENSIONS DESTMATRIX) (LIST N M))) then (HELP "DESTMATRIX of incorrect size" DESTMATRIX))) (if (ILESSP M N) then (bind (SOURCEBASE _(ARRAYBASE SOURCEMATRIX)) (DESTBASE _(ARRAYBASE DESTMATRIX)) for I from 0 to (SUB1 M) do (\FLOATARRAYBLT SOURCEBASE (ITIMES N I) 1 DESTBASE I M N)) else (bind (SOURCEBASE _(ARRAYBASE SOURCEMATRIX)) (DESTBASE _(ARRAYBASE DESTMATRIX)) for J from 0 to (SUB1 N) do (\FLOATARRAYBLT SOURCEBASE J N DESTBASE (ITIMES J M) 1 M))) (RETURN DESTMATRIX]) (MINVERT [LAMBDA (MATRIX SOLUTION) (* jop: "26-May-86 18:35") (* * Solves to system A x = b. BVECTOR should to the RHS of the system. Returns SOLUTION) (LET [(PIVOTVECTOR (MAKE-ARRAY (ARRAY-DIMENSION MATRIX 0] (LUINVERSE (LUFACTOR MATRIX PIVOTVECTOR) PIVOTVECTOR SOLUTION]) (LSOLV [LAMBDA (LMATRIX CVECTOR BVECTOR) (* jop: "27-May-86 16:25") (* * Calcluate the solution vector BVECTOR for the system of linear equations  R*B=C, where LMATRIX is lower triangular M X N with non-zero diagonal elements.  BVECTOR and CVECTOR must be of size N. Always returns BVECTOR) (BLAS.CHECKARRAY LMATRIX) (BLAS.CHECKARRAY CVECTOR) (PROG ((M (ARRAY-DIMENSION LMATRIX 0)) (N (ARRAY-DIMENSION LMATRIX 1))) (* * Arg Checks) (if (ILESSP M N) then (HELP "Order of system less than" N)) (if (NOT (EQL (ARRAY-TOTAL-SIZE CVECTOR) N)) then (HELP "CVECTOR not of size" N)) (if (NULL BVECTOR) then (SETQ BVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY BVECTOR) (if (NOT (EQL (ARRAY-TOTAL-SIZE BVECTOR) N)) then (HELP "BVECTOR not of size" N))) (* Check for zero diagonal elements) (if (for I from 0 to (SUB1 N) thereis (UFEQP 0.0 (\FLOATAREF LMATRIX I I))) then (HELP "LMATRIX has a zero diagonal element")) (* * Solution by forward substitution) (* Copy CVECTOR to BVECTOR) (BLAS.ARRAYBLT CVECTOR 0 1 BVECTOR 0 1 N) (* Compute the first value) (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR 0) (\FLOATAREF LMATRIX 0 0)) BVECTOR 0) (for J from 1 to (SUB1 N) do (BLAS.AXPY (FMINUS (\FLOATAREF BVECTOR (SUB1 J))) LMATRIX (IPLUS (SUB1 J) (ITIMES J N)) N BVECTOR J 1 (IDIFFERENCE N J)) (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR J) (\FLOATAREF LMATRIX J J)) BVECTOR J)) (RETURN BVECTOR]) (LUFACTOR [LAMBDA (MATRIX PIVOTVECTOR FACTORMATRIX) (* jop: "27-May-86 20:21") (* * Computes the LU decomposition of the N x N matrix MATRIX by Gauss  elimination with row pivoting. FACTORMATRIX will be overwritten with the packed  result. PIVOTVECTOR will be a vector of smallposp's, holding the pivot  permutation, and must be supplied. Returns NIL in the normal case, else returns  the row index) (* * Lifted from LINPACK algorithm SGESL) (BLAS.CHECKARRAY MATRIX) (if (NOT (AND (type? ARRAY PIVOTVECTOR) (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR) T))) then (HELP "Must be a pointer array" PIVOTVECTOR)) (LET ((N (ARRAY-DIMENSION MATRIX 0))) (* * Arg Checks) (if [AND (EQL 2 (ARRAY-RANK MATRIX)) (NOT (EQL N (ARRAY-DIMENSION MATRIX 1] then (HELP "MATRIX not square" MATRIX)) (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR)) (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR] then (HELP "PIVOTVECTOR not of size N" PIVOTVECTOR)) (if (NULL FACTORMATRIX) then (SETQ FACTORMATRIX (MAKE-ARRAY (LIST N N) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY FACTORMATRIX) (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX) (ARRAY-DIMENSIONS MATRIX))) then (HELP "Illegal FACTORMATRIX" FACTORMATRIX))) (* Copy MATRIX to FACTORMATRIX) (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1) (* * Compute the LU decomposition of FACTORMATRIX) [bind PIVOTINDEX TEMP for K from 0 to (IDIFFERENCE N 2) do (* find pivot index) (SETQ PIVOTINDEX (IPLUS (BLAS.MAX FACTORMATRIX (IPLUS K (ITIMES N K)) N (IDIFFERENCE N K)) K)) (PASET PIVOTINDEX PIVOTVECTOR K) (if (NOT (FEQP (\FLOATAREF FACTORMATRIX PIVOTINDEX K) 0.0)) then (if (NOT (EQL PIVOTINDEX K)) then (* Interchange) (SETQ TEMP (\FLOATAREF FACTORMATRIX PIVOTINDEX K)) (\FLOATASET (\FLOATAREF FACTORMATRIX K K) FACTORMATRIX PIVOTINDEX K) (\FLOATASET TEMP FACTORMATRIX K K)) (* compute Multpliers) (BLAS.SCAL (FMINUS (FQUOTIENT 1.0 (\FLOATAREF FACTORMATRIX K K))) FACTORMATRIX (IPLUS K (ITIMES N (ADD1 K))) N (SUB1 (IDIFFERENCE N K))) (* Row eliminate with column indexing) (bind (KPLUS1 _ (ADD1 K)) for J from (ADD1 K) to (SUB1 N) do (SETQ TEMP (\FLOATAREF FACTORMATRIX PIVOTINDEX J)) (if (NOT (EQL PIVOTINDEX K)) then (* Interchange) (\FLOATASET (\FLOATAREF FACTORMATRIX K J) FACTORMATRIX PIVOTINDEX J) (\FLOATASET TEMP FACTORMATRIX K J)) (BLAS.AXPY TEMP FACTORMATRIX (IPLUS K (ITIMES N KPLUS1)) N FACTORMATRIX (IPLUS J (ITIMES N KPLUS1)) N (IDIFFERENCE N KPLUS1] (* No row elimination on last column) (PASET (SUB1 N) PIVOTVECTOR (SUB1 N)) FACTORMATRIX]) (LUINVERSE [LAMBDA (LUMATRIX PIVOTVECTOR SOLUTION) (* jop: "26-May-86 18:17") (* * Forms MATRIX inverse where LUMATRIX and PIVOTVECTOR are the outputs of  LUFACTOR.) (* * lifted from LINPACK SGEDI) (BLAS.CHECKARRAY LUMATRIX) (if (NOT (AND (type? ARRAY PIVOTVECTOR) (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR) T))) then (HELP "Must be an array of pointers" PIVOTVECTOR)) (PROG ((N (ARRAY-DIMENSION LUMATRIX 0))) (* * Arg Checks) (if [AND (EQL 2 (ARRAY-RANK LUMATRIX)) (NOT (EQL N (ARRAY-DIMENSION LUMATRIX 1] then (HELP "MATRIX not square" LUMATRIX)) (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR)) (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR] then (HELP "PIVOTVECTOR not a vector of size N" PIVOTVECTOR)) (if (NULL SOLUTION) then (SETQ SOLUTION (MAKE-ARRAY (LIST N N) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY SOLUTION) (if [NOT (AND (EQL 2 (ARRAY-RANK SOLUTION)) (EQUAL (ARRAY-DIMENSIONS LUMATRIX) (ARRAY-DIMENSIONS SOLUTION] then (HELP "SOLUTION not an N x N array" SOLUTION))) (* copy LUMATRIX to SOLUTION) (BLAS.ARRAYBLT LUMATRIX 0 1 SOLUTION 0 1) (* * first compute INVERSE (U)) [bind TEMP for K from 0 to (SUB1 N) do (\FLOATASET (FQUOTIENT 1.0 (\FLOATAREF SOLUTION K K)) SOLUTION K K) (SETQ TEMP (FMINUS (\FLOATAREF SOLUTION K K))) (BLAS.SCAL TEMP SOLUTION K N K) (bind TEMP for J from (ADD1 K) to (SUB1 N) do (SETQ TEMP (\FLOATAREF SOLUTION K J)) (\FLOATASET 0.0 SOLUTION K J) (BLAS.AXPY TEMP SOLUTION K N SOLUTION J N (ADD1 K] (* * Form INVERSE (U) *INVERSE (L)) (bind (TEMPARRAY _ (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) L for K from (IDIFFERENCE N 2) to 0 by -1 do (for I from (ADD1 K) to (SUB1 N) do (\FLOATASET (\FLOATAREF SOLUTION I K) TEMPARRAY I) (\FLOATASET 0.0 SOLUTION I K)) (bind TEMP for J from (ADD1 K) to (SUB1 N) do (SETQ TEMP (\FLOATAREF TEMPARRAY J)) (BLAS.AXPY TEMP SOLUTION J N SOLUTION K N N)) (SETQ L (PAREF PIVOTVECTOR K)) (if (NEQ L K) then (BLAS.SWAP SOLUTION K N SOLUTION L N N))) (RETURN SOLUTION]) (LUSOLV [LAMBDA (LUMATRIX PIVOTVECTOR CVECTOR SOLUTION) (* jop: "27-May-86 20:39") (* * Solves to system A x = b. LUMATRIX and PIVOTVECTOR should be the outputs  of LUFACTOR. CVECTOR should to the RHS of the system.  Returns SOLUTION) (* * lifted from LINPACK SGESL) (BLAS.CHECKARRAY LUMATRIX) (if (NOT (AND (type? ARRAY PIVOTVECTOR) (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR) T))) then (HELP "Must be an array of pointers" PIVOTVECTOR)) (BLAS.CHECKARRAY CVECTOR) (PROG ((N (ARRAY-DIMENSION LUMATRIX 0))) (* * Arg Checks) (if [AND (EQL 2 (ARRAY-RANK LUMATRIX)) (NOT (EQL N (ARRAY-DIMENSION LUMATRIX 1] then (HELP "MATRIX not square" LUMATRIX)) (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR)) (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR] then (HELP "PIVOTVECTOR not a vector of size N" PIVOTVECTOR)) (if [NOT (AND (EQL 1 (ARRAY-RANK CVECTOR)) (EQL N (ARRAY-TOTAL-SIZE CVECTOR] then (HELP "CVECTOR not a vector of size N" CVECTOR)) (if (NULL SOLUTION) then (SETQ SOLUTION (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY SOLUTION) (if [NOT (AND (EQL 1 (ARRAY-RANK SOLUTION)) (EQL N (ARRAY-TOTAL-SIZE SOLUTION] then (HELP "SOLUTION not avector of size N" SOLUTION))) (* Copy CVECTOR to SOLUTION) (BLAS.ARRAYBLT CVECTOR 0 1 SOLUTION 0 1 N) (* * First solve L*y = b) [bind PIVOTINDEX TEMP for K from 0 to (IDIFFERENCE N 2) do (SETQ PIVOTINDEX (PAREF PIVOTVECTOR K)) (SETQ TEMP (\FLOATAREF SOLUTION PIVOTINDEX)) (if (NOT (EQL PIVOTINDEX K)) then (* interchange) (\FLOATASET (\FLOATAREF SOLUTION K) SOLUTION PIVOTINDEX) (\FLOATASET TEMP SOLUTION K)) (BLAS.AXPY TEMP LUMATRIX (IPLUS K (ITIMES N (ADD1 K))) N SOLUTION (ADD1 K) 1 (IDIFFERENCE N (ADD1 K] (* * Then solve U*x = y) (bind TEMP for K from (SUB1 N) to 0 by -1 do (SETQ TEMP (FMINUS (\FLOATASET (FQUOTIENT (\FLOATAREF SOLUTION K) (\FLOATAREF LUMATRIX K K)) SOLUTION K))) (BLAS.AXPY TEMP LUMATRIX K N SOLUTION 0 1 K)) (RETURN SOLUTION]) (MTIMES [LAMBDA (A B PRODUCT) (* jop: " 4-Jun-86 13:08") (* * Matrix multiply. A may be an N vector or a (M x N) matrix and B may be a N vector or a N x P matrix. PRODUCT defualts to a M x P array. RETURNS PRODUCT) (BLAS.CHECKARRAY A) (BLAS.CHECKARRAY B) (LET ((RANKA (ARRAY-RANK A)) (RANKB (ARRAY-RANK B)) M N P RESULTDIMS) (if (NOT (OR (EQ RANKA 1) (EQ RANKA 2))) then (HELP "A not a one-d or two-d array" A)) (if (NOT (OR (EQ RANKB 1) (EQ RANKB 2))) then (HELP "B not a one-d or two-d array" B)) (SETQ M (if (EQ RANKA 1) then 1 else (ARRAY-DIMENSION A 0))) (SETQ N (if (EQ RANKA 1) then (ARRAY-DIMENSION A 0) else (ARRAY-DIMENSION A 1))) (SETQ P (if (EQ RANKB 1) then 1 else (ARRAY-DIMENSION B 1))) [SETQ RESULTDIMS (if (EQ M 1) then (if (EQ P 1) then NIL else (LIST P)) else (if (EQ P 1) then (LIST M) else (LIST M P] (* * Check args) (if (NOT (EQ (ARRAY-DIMENSION B 0) N)) then (HELP "Leading dimension of B not N" B)) (if (NULL PRODUCT) then (SETQ PRODUCT (MAKE-ARRAY RESULTDIMS (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) elseif (NOT (EQUAL (ARRAY-DIMENSIONS PRODUCT) RESULTDIMS)) then (HELP "C of incorrect size" PRODUCT)) (* * Do the multiply) [bind (ABASE _(ARRAYBASE A)) (BBASE _(ARRAYBASE B)) (CBASE _(ARRAYBASE PRODUCT)) for I from 0 to (SUB1 M) do (for J from 0 to (SUB1 P) as COFFSET from (MUL2 (ITIMES P I)) by 2 do (bind (FTEMP _ 0.0) declare (TYPE FLOATP FTEMP) for K from 0 to (SUB1 N) as AOFFSET from (MUL2 (ITIMES N I)) by 2 as BOFFSET from (MUL2 J) by (MUL2 P) do [SETQ FTEMP (FPLUS FTEMP (FTIMES (\GETBASEFLOATP ABASE AOFFSET) (\GETBASEFLOATP BBASE BOFFSET] finally (\PUTBASEFLOATP CBASE COFFSET FTEMP] PRODUCT]) (QRFACTOR [LAMBDA (MATRIX QRAUX FACTORMATRIX) (* jop: "27-May-86 16:27") (* * Computes the LU decomposition of the N x N matrix MATRIX by Gauss  elimination with row pivoting. FACTORMATRIX will be overwritten with the packed  result. QRAUX will be a vector of smallposp's, holding the pivot permutation,  and must be supplied. Returns NIL in the normal case, else returns the row  index) (* * Lifted from LINPACK algorithm SGESL) (BLAS.CHECKARRAY MATRIX) (BLAS.CHECKARRAY QRAUX) (LET ((N (ARRAY-DIMENSION MATRIX 0)) (P (ARRAY-DIMENSION MATRIX 1))) (* * Arg Checks) (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) (EQL P (ARRAY-TOTAL-SIZE QRAUX] then (HELP "QRAUX not of size P" QRAUX)) (if (NULL FACTORMATRIX) then (SETQ FACTORMATRIX (MAKE-ARRAY (ARRAY-DIMENSIONS MATRIX) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY FACTORMATRIX) (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX) (ARRAY-DIMENSIONS MATRIX))) then (HELP "Illegal FACTORMATRIX" FACTORMATRIX))) (* Copy MATRIX to FACTORMATRIX) (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1) (* * Compute the QR decomposition of FACTORMATRIX) (for I from 0 to (SUB1 P) do (\FLOATASET 0.0 QRAUX I)) (bind NRMXL for L from 0 to (SUB1 (IMIN N P)) unless (EQL L (SUB1 N)) do (* Compute the Householder  transformation for column L) (SETQ NRMXL (BLAS.NRM2 FACTORMATRIX (IPLUS L (ITIMES P L)) P (IDIFFERENCE N L))) (if (FGREATERP NRMXL 0.0) then (if (FLESSP (\FLOATAREF FACTORMATRIX L L) 0.0) then (SETQ NRMXL (FMINUS NRMXL))) (BLAS.SCAL (FQUOTIENT 1.0 NRMXL) FACTORMATRIX (IPLUS L (ITIMES P L)) P (IDIFFERENCE N L)) (\FLOATASET (FPLUS 1.0 (\FLOATAREF FACTORMATRIX L L)) FACTORMATRIX L L) (* apply the transform to the  remaining columns) (bind TEMP for J from (ADD1 L) to (SUB1 P) do [SETQ TEMP (FMINUS (FQUOTIENT (BLAS.DOTPROD FACTORMATRIX (IPLUS L (ITIMES P L)) P FACTORMATRIX (IPLUS J (ITIMES P L)) P (IDIFFERENCE N L)) (\FLOATAREF FACTORMATRIX L L] (BLAS.AXPY TEMP FACTORMATRIX (IPLUS L (ITIMES P L)) P FACTORMATRIX (IPLUS J (ITIMES P L)) P (IDIFFERENCE N L))) (\FLOATASET (\FLOATAREF FACTORMATRIX L L) QRAUX L) (\FLOATASET (FMINUS NRMXL) FACTORMATRIX L L))) FACTORMATRIX]) (QROLS [LAMBDA (QRMATRIX QRAUX Y QTY B RSD YHAT) (* jop: "27-May-86 17:21") (* * Lifted from LINPACK algorithm SQRSL) (BLAS.CHECKARRAY QRMATRIX) (BLAS.CHECKARRAY QRAUX) (BLAS.CHECKARRAY Y) (LET ((N (ARRAY-DIMENSION QRMATRIX 0)) (P (ARRAY-DIMENSION QRMATRIX 1))) (* * Arg Checks) (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) (EQL P (ARRAY-TOTAL-SIZE QRAUX] then (HELP "QRAUX not of size P" QRAUX)) (if [NOT (AND (EQL 1 (ARRAY-RANK Y)) (EQL N (ARRAY-TOTAL-SIZE Y] then (HELP "Y not of size N" Y)) (if (NULL QTY) then (SETQ QTY (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY QTY) (if (NOT (EQL N (ARRAY-TOTAL-SIZE QTY))) then (HELP "QTY not of size N" QTY))) (if (NULL B) then (SETQ B (MAKE-ARRAY P (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY B) (if (NOT (EQL P (ARRAY-TOTAL-SIZE B))) then (HELP "B not of size P" B))) (if RSD then (BLAS.CHECKARRAY RSD) (if (NOT (EQL N (ARRAY-TOTAL-SIZE RSD))) then (HELP "RSD not of size N" RSD))) (if YHAT then (BLAS.CHECKARRAY YHAT) (if (NOT (EQL N (ARRAY-TOTAL-SIZE YHAT))) then (HELP "XB not of size N" YHAT))) (* Compute TRANS (Q) * Y) (QRQTY QRMATRIX QRAUX Y QTY) (* * Compute B) (* Set up computation of B) (BLAS.ARRAYBLT QTY 0 1 B 0 1 P) (for J from (SUB1 P) to 0 by -1 do (if (UFEQP (\FLOATAREF QRMATRIX J J) 0.0) then (HELP "Singular Matrix" QRMATRIX)) (\FLOATASET (FQUOTIENT (\FLOATAREF B J) (\FLOATAREF QRMATRIX J J)) B J) (if (NOT (EQL J 0)) then (BLAS.AXPY (FMINUS (\FLOATAREF B J)) QRMATRIX J P B 0 1 J))) (* * Compute RSD) [if RSD then (* Set up computation of RSD) (if (ILESSP P N) then (BLAS.ARRAYBLT QTY P 1 RSD P 1)) (BLAS.ARRAYFILL 0.0 RSD 0 1 P) (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1 do (if (NOT (UFEQP (\FLOATAREF QRAUX J) 0.0)) then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) (\FLOATASET (\FLOATAREF QRAUX J) QRMATRIX J J) (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J (ITIMES P J)) P RSD J 1 (IDIFFERENCE N J)) (\FLOATAREF QRMATRIX J J))) QRMATRIX (IPLUS J (ITIMES P J)) P RSD J 1 (IDIFFERENCE N J)) (\FLOATASET TEMP QRMATRIX J J))) (* * Compute YHAT) (if YHAT then (* Set up computation of YHAT) (BLAS.ARRAYBLT QTY 0 1 YHAT 0 1 P) (BLAS.ARRAYFILL 0.0 YHAT P 1) (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1 do (if (NOT (UFEQP (\FLOATAREF QRAUX J) 0.0)) then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) (\FLOATASET (\FLOATAREF QRAUX J) QRMATRIX J J) (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J (ITIMES P J)) P YHAT J 1 (IDIFFERENCE N J)) (\FLOATAREF QRMATRIX J J))) QRMATRIX (IPLUS J (ITIMES P J)) P YHAT J 1 (IDIFFERENCE N J)) (\FLOATASET TEMP QRMATRIX J J] B]) (QRQTY [LAMBDA (QRMATRIX QRAUX Y PRODUCT) (* jop: "27-May-86 16:28") (* * COMPUTE (TRANS Q) * Y given a QR factorization described by QRMATRIX and  QRAUX where Y is an N vector) (* * Lifted from LINPACK algorithm SQRSL) (BLAS.CHECKARRAY QRMATRIX) (BLAS.CHECKARRAY QRAUX) (BLAS.CHECKARRAY Y) (LET ((N (ARRAY-DIMENSION QRMATRIX 0)) (P (ARRAY-DIMENSION QRMATRIX 1))) (* * Arg Checks) (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) (EQL P (ARRAY-TOTAL-SIZE QRAUX] then (HELP "QRAUX not of size P" QRAUX)) (if [NOT (AND (EQL 1 (ARRAY-RANK Y)) (EQL N (ARRAY-TOTAL-SIZE Y] then (HELP "Y not of size N" Y)) (if (NULL PRODUCT) then (SETQ PRODUCT (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY PRODUCT) (if (NOT (EQL N (ARRAY-TOTAL-SIZE PRODUCT))) then (HELP "PRODUCT not of size N" PRODUCT))) (BLAS.ARRAYBLT Y 0 1 PRODUCT 0 1 N) (bind TEMP for J from 0 to (IMIN P (SUB1 N)) do (if (NOT (UFEQP (\FLOATAREF QRAUX J) 0.0)) then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) (\FLOATASET (\FLOATAREF QRAUX J) QRMATRIX J J) (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J (ITIMES P J)) P PRODUCT J 1 (IDIFFERENCE N J)) (\FLOATAREF QRMATRIX J J))) QRMATRIX (IPLUS J (ITIMES P J)) P PRODUCT J 1 (IDIFFERENCE N J)) (\FLOATASET TEMP QRMATRIX J J))) PRODUCT]) (QRQY [LAMBDA (QRMATRIX QRAUX Y PRODUCT) (* jop: "27-May-86 16:30") (* * COMPUTE QX given a QR factorization described by QRMATRIX and QRAUX where  Y is an N vector) (* * Lifted from LINPACK algorithm SQRSL) (BLAS.CHECKARRAY QRMATRIX) (BLAS.CHECKARRAY QRAUX) (BLAS.CHECKARRAY Y) (LET ((N (ARRAY-DIMENSION QRMATRIX 0)) (P (ARRAY-DIMENSION QRMATRIX 1))) (* * Arg Checks) (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) (EQL P (ARRAY-TOTAL-SIZE QRAUX] then (HELP "QRAUX not of size P" QRAUX)) (if [NOT (AND (EQL 1 (ARRAY-RANK Y)) (EQL N (ARRAY-TOTAL-SIZE Y] then (HELP "Y not of size N" Y)) (if (NULL PRODUCT) then (SETQ PRODUCT (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY PRODUCT) (if (NOT (EQL N (ARRAY-TOTAL-SIZE PRODUCT))) then (HELP "PRODUCT not of size N" PRODUCT))) (BLAS.ARRAYBLT Y 0 1 PRODUCT 0 1 N) (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1 do (if (NOT (UFEQP (\FLOATAREF QRAUX J) 0.0)) then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) (\FLOATASET (\FLOATAREF QRAUX J) QRMATRIX J J) (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J (ITIMES P J)) P PRODUCT J 1 (IDIFFERENCE N J)) (\FLOATAREF QRMATRIX J J))) QRMATRIX (IPLUS J (ITIMES P J)) P PRODUCT J 1 (IDIFFERENCE N J)) (\FLOATASET TEMP QRMATRIX J J))) PRODUCT]) (QRSOLV [LAMBDA (QRMATRIX QRAUX BVECTOR SOLUTION) (* jop: "27-May-86 20:38") (* * Solves to system A x = b. BVECTOR should to the RHS of the system. Returns SOLUTION) (RSOLV QRMATRIX (QRQTY QRMATRIX QRAUX BVECTOR SOLUTION) SOLUTION]) (MREGRESS [LAMBDA (Y X B RSD YHAT) (* jop: " 4-Jun-86 14:12") (* * MREGRESS calculates the least squares (multiple) regression of Y on X. An N vector Y.) (LET* ((QRAUX (MAKE-ARRAY (ARRAY-DIMENSION X 1) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (QRMATRIX (QRFACTOR X QRAUX))) (QROLS QRMATRIX QRAUX Y NIL B RSD YHAT]) (RSOLV [LAMBDA (RMATRIX CVECTOR BVECTOR) (* jop: "28-May-86 20:31") (* * Calcluate the solution vector BVECTOR for the system of linear equations  R*B=C, where RMATRIX is upper triangular M X N with non-zero diagonal elements.  BVECTOR and CVECTOR must be of size N. Always returns BVECTOR) (BLAS.CHECKARRAY RMATRIX) (BLAS.CHECKARRAY CVECTOR) (PROG ((M (ARRAY-DIMENSION RMATRIX 0)) (N (ARRAY-DIMENSION RMATRIX 1))) (* * Arg Checks) (if (ILESSP M N) then (HELP "Order of system less than" N)) (if (NOT (EQL (ARRAY-TOTAL-SIZE CVECTOR) N)) then (HELP "CVECTOR not of size" N)) (if (NULL BVECTOR) then (SETQ BVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY BVECTOR) (if (NOT (EQL (ARRAY-TOTAL-SIZE BVECTOR) N)) then (HELP "BVECTOR not of size" N))) (* Check for zero diagonal elements) (if (for I from 0 to (SUB1 N) thereis (UFEQP 0.0 (\FLOATAREF RMATRIX I I))) then (HELP "RMATRIX has a zero diagonal element")) (* * Solution by backsubstitution.) (BLAS.ARRAYBLT CVECTOR 0 1 BVECTOR 0 1 N) (LET ((INDEXLIMIT (SUB1 N))) (* Compute the last value) (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR INDEXLIMIT) (\FLOATAREF RMATRIX INDEXLIMIT INDEXLIMIT)) BVECTOR INDEXLIMIT) (bind J JLESS1 for JJ from 1 to INDEXLIMIT do (SETQ J (IDIFFERENCE N JJ)) (SETQ JLESS1 (SUB1 J)) (BLAS.AXPY (FMINUS (\FLOATAREF BVECTOR J)) RMATRIX J N BVECTOR 0 1 J) (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR JLESS1) (\FLOATAREF RMATRIX JLESS1 JLESS1)) BVECTOR JLESS1))) (RETURN BVECTOR]) (MSOLVE [LAMBDA (MATRIX CVECTOR SOLUTION) (* jop: "27-May-86 20:40") (* * Solves to system A x = b. CVECTOR should to the RHS of the system. Returns SOLUTION) (LET [(PIVOTVECTOR (MAKE-ARRAY (ARRAY-DIMENSION MATRIX 0] (LUSOLV (LUFACTOR MATRIX PIVOTVECTOR) PIVOTVECTOR CVECTOR SOLUTION]) (SVDFACTOR [LAMBDA (XMATRIX SVECTOR UMATRIX VMATRIX) (* jop: "29-May-86 11:29") (* * Singular-value decomposition by means of orthogonalization by plane  rotations. Taken from Nash and Shlien: "Partial svd algorithms." On entry X  contains the M by N matrix to be decomposed, SVECTOR must be a vector of length  N and VMATRIX must be a square N by N matrix.  On return UMATRIX has been overwritten by the left singular vectors, SVECTOR  contains the singular values, and VMATRIX contains the right singular vectors.) (BLAS.CHECKARRAY XMATRIX) (LET ((M (ARRAY-DIMENSION UMATRIX 0)) (N (ARRAY-DIMENSION UMATRIX 1))) (* * Args checks) (if (NOT (EQL 2 (ARRAY-RANK XMATRIX))) then (HELP "XMATRIX not a matrix" XMATRIX)) (if (NULL SVECTOR) then (SETQ SVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY SVECTOR) (if [NOT (AND (EQL 1 (ARRAY-RANK SVECTOR)) (EQL N (ARRAY-TOTAL-SIZE SVECTOR] then (HELP "Illegal SVECTOR" SVECTOR))) (if (NULL UMATRIX) then (SETQ UMATRIX (MAKE-ARRAY (LIST M N) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY UMATRIX) (if (NOT (EQUAL (ARRAY-DIMENSIONS UMATRIX) (ARRAY-DIMENSIONS XMATRIX))) then (HELP "Illegal UMATRIX" UMATRIX))) (if (NULL VMATRIX) then (SETQ VMATRIX (MAKE-ARRAY (LIST N N) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY VMATRIX) (if (NOT (EQUAL (ARRAY-DIMENSIONS VMATRIX) (LIST N N))) then (HELP "Illegal VMATRIX" VMATRIX))) (* Copy XMATRIX to UMATRIX) (BLAS.ARRAYBLT XMATRIX NIL NIL UMATRIX) (* Initialize VMATRIX to identity  matrix.) (BLAS.ARRAYFILL 0.0 VMATRIX) (for I from 0 to (SUB1 N) do (\FLOATASET 1.0 VMATRIX I I)) (* * Start the computation) (LET ((NT N)) (* * The main loop: repeatedly sweep over all pairs of columns in U, rotating  as needed, until no rotations in a complete sweep are effective.  Check the opportunity for rank reduction at the conclusion of each sweep.) [bind (EPS _ 1.0E-6) (SLIMIT _ (IMAX (IQUOTIENT N 4) 6)) (SCOUNT _ 0) RCOUNT eachtime (SETQ RCOUNT (IQUOTIENT (ITIMES NT (SUB1 NT)) 2)) (SETQ SCOUNT (ADD1 SCOUNT)) repeatwhile (IGREATERP RCOUNT 0) do (if (IGREATERP SCOUNT SLIMIT) then (HELP "Number of sweeps exceeds sweep limit." SCOUNT)) [for J from 0 to (IDIFFERENCE NT 2) do (bind P Q R C S V for K from (ADD1 J) to (SUB1 NT) do (SETQ P (BLAS.DOTPROD UMATRIX J N UMATRIX K N M)) (SETQ Q (BLAS.DOTPROD UMATRIX J N UMATRIX J N M)) (SETQ R (BLAS.DOTPROD UMATRIX K N UMATRIX K N M)) (\FLOATASET Q SVECTOR J) (\FLOATASET R SVECTOR K) (if (FLESSP Q R) then (SETQ Q (FDIFFERENCE (FQUOTIENT Q R) 1.0)) (SETQ P (FQUOTIENT P R)) [SETQ V (SQRT (SETQ V (FPLUS (FTIMES 4.0 P P) (FTIMES Q Q] [SETQ S (SQRT (FTIMES .5 (FDIFFERENCE 1.0 (FQUOTIENT Q V] (if (FLESSP P 0.0) then (SETQ S (FDIFFERENCE 0.0 S))) (SETQ C (FQUOTIENT P (FTIMES V S))) (BLAS.ROT C S UMATRIX J N UMATRIX K N M) (BLAS.ROT C S VMATRIX J N VMATRIX K N N) elseif (OR (LEQ (FTIMES Q R) (FTIMES EPS EPS)) (LEQ (FTIMES (FQUOTIENT P Q) (FQUOTIENT P R)) EPS)) then (SETQ RCOUNT (SUB1 RCOUNT)) else (SETQ R (FDIFFERENCE 1.0 (FQUOTIENT R Q))) (SETQ P (FQUOTIENT P Q)) [SETQ V (SQRT (SETQ V (FPLUS (FTIMES 4.0 P P) (FTIMES R R] [SETQ C (SQRT (FTIMES .5 (FPLUS 1.0 (FQUOTIENT R V] (SETQ S (FQUOTIENT P (FTIMES V C))) (* box before the COLROT calls) (BLAS.ROT C S UMATRIX J N UMATRIX K N M) (BLAS.ROT C S VMATRIX J N VMATRIX K N N] (while (AND (IGEQ NT 3) (LEQ (FQUOTIENT (\FLOATAREF SVECTOR (SUB1 NT)) (FPLUS (\FLOATAREF SVECTOR 0) EPS)) EPS)) do (SETQ NT (SUB1 NT] (* * Finish the decomposition by returning all N singular values, and by  normalizing those columns of UMATRIX judged to be non-zero.) (bind Q for J from 0 to (SUB1 N) do (SETQ Q (SQRT (\FLOATAREF SVECTOR J))) (\FLOATASET Q SVECTOR J) (if (ILEQ J NT) then (BLAS.SCAL (FQUOTIENT 1.0 Q) UMATRIX J N M))) SVECTOR]) (SVDTEST [LAMBDA NIL (* jop: "30-Jan-86 17:37") (* * comment) (LET ((UU (MAKE-ARRAY (QUOTE (24 19)) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (SS (MAKE-ARRAY 19 (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (VV (MAKE-ARRAY (QUOTE (19 19)) (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) (L 0)) [for TT from 1.0 to 3.0 do (for PP from 1.0 to 2.0 do (for CC from 1.0 to 4.0 do (ASET TT UU L 0) (ASET PP UU L 1) (ASET CC UU L 2) (ASET (FTIMES TT PP) UU L 3) (ASET (FTIMES TT CC) UU L 4) (ASET (FTIMES PP CC) UU L 5) (ASET (FTIMES PP PP) UU L 6) (ASET (FTIMES CC CC) UU L 7) (ASET (FTIMES TT TT) UU L 8) (ASET (FTIMES TT PP PP) UU L 9) (ASET (FTIMES TT CC CC) UU L 10) (ASET (FTIMES PP TT TT) UU L 11) (ASET (FTIMES PP CC CC) UU L 12) (ASET (FTIMES CC TT TT) UU L 13) (ASET (FTIMES CC PP PP) UU L 14) (ASET (FTIMES TT TT TT) UU L 15) (ASET (FTIMES PP PP PP) UU L 16) (ASET (FTIMES CC CC CC) UU L 17) (ASET (FTIMES TT PP CC) UU L 18) (SETQ L (ADD1 L] (TIMEALL (SVDNASH UU SS VV]) (\FLOATAREFMACRO [LAMBDA (ARGS) (* jop: "26-May-86 16:02") (* * macro expander for \FLOATAREF) (if (IGREATERP (LENGTH ARGS) 3) then (HELP "\FLOATAREF takes no more than three args" ARGS)) (PROG ((BARRAY (CAR ARGS)) (BINDICES (CDR ARGS)) INDEXFORM) [if (EQLENGTH BINDICES 1) then (SETQ INDEXFORM (CAR BINDICES)) else (SETQ INDEXFORM (BQUOTE (IPLUS , (CADR BINDICES) (ITIMES , (CAR BINDICES) (ARRAY-DIMENSION , BARRAY 1] (RETURN (BQUOTE (\GETBASEFLOATP (ARRAYBASE , BARRAY) (LLSH , INDEXFORM 1]) (\FLOATASETMACRO [LAMBDA (ARGS) (* jop: "26-May-86 16:03") (* * macro expander for \FLOATASET) (if (IGREATERP (LENGTH ARGS) 4) then (HELP "\FLOATASET takes no more than four args" ARGS)) (PROG ((BNEWVALUE (CAR ARGS)) (BARRAY (CADR ARGS)) (BINDICES (CDDR ARGS)) INDEXFORM) [if (EQLENGTH BINDICES 1) then (SETQ INDEXFORM (CAR BINDICES)) else (SETQ INDEXFORM (BQUOTE (IPLUS , (CADR BINDICES) (ITIMES , (CAR BINDICES) (ARRAY-DIMENSION , BARRAY 1] (RETURN (BQUOTE (\PUTBASEFLOATP (ARRAYBASE , BARRAY) (LLSH , INDEXFORM 1) , BNEWVALUE]) ) (RPAQQ STACK ((80 27 89) (80 27 88) (75 25 90) (62 24 87) (62 22 87) (62 23 87) (62 24 93) (62 24 93) (58 23 87) (58 18 80) (58 18 89) (58 17 88) (58 18 82) (58 19 93) (50 18 89) (50 18 86) (50 19 72) (50 19 79) (50 20 80) (56 20 82) (70 20 91))) (DECLARE: EVAL@COMPILE (PUTPROPS \FLOATAREF MACRO (ARGS (* *) (\FLOATAREFMACRO ARGS))) (PUTPROPS \FLOATASET MACRO (ARGS (* *) (\FLOATASETMACRO ARGS))) ) (FILESLOAD BLAS) (PUTPROPS MATRIXOPS COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (665 47755 (CHOLESKYFACTOR 675 . 3149) (MTRANSPOSE 3151 . 4438) (MINVERT 4440 . 4810) ( LSOLV 4812 . 7212) (LUFACTOR 7214 . 11565) (LUINVERSE 11567 . 14760) (LUSOLV 14762 . 17799) (MTIMES 17801 . 20328) (QRFACTOR 20330 . 24388) (QROLS 24390 . 29552) (QRQTY 29554 . 31713) (QRQY 31715 . 33879) (QRSOLV 33881 . 34176) (MREGRESS 34178 . 34600) (RSOLV 34602 . 36899) (MSOLVE 36901 . 37272) ( SVDFACTOR 37274 . 44236) (SVDTEST 44238 . 46004) (\FLOATAREFMACRO 46006 . 46838) (\FLOATASETMACRO 46840 . 47753))))) STOP \ No newline at end of file diff --git a/lispusers/MESATOLISP b/lispusers/MESATOLISP new file mode 100644 index 00000000..f75bd304 --- /dev/null +++ b/lispusers/MESATOLISP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED "10-Apr-87 18:07:52" {ERIS}LYRIC>MESATOLISP.;4 285413 changes to%: (VARS MESATOLISPCOMS) (FNS SCAN.START SCAN.TOKEN PARSE.CEDAR PARSE.BIN PARSE.FILE) previous date%: " 9-Apr-87 12:25:12" {ERIS}LYRIC>MESATOLISP.;3) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MESATOLISPCOMS) (RPAQQ MESATOLISPCOMS [ (* ;; "MESATOLISP -- By Kelly Roach. Lyricized by L. Masinter") (COMS (* ;;; "SCAN: reading mesa/cedar files") [INITVARS (SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE 'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0)) (SCAN.CHAR NIL) (SCAN.QDOT NIL) (SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE %[ %] ^ _ { %| } ~)) (SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED UNCHECKED UNSAFE)) (SCAN.MESA.RESERVED '(RESIDENT] (FNS SCAN.INIT SCAN.START SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR SCAN.HEX SCAN.FLOATING SCAN.ESCAPE) (P (SCAN.INIT))) (COMS (* ; "PARSE *") [INITVARS (PARSE.FILELST NIL) (PARSE.STREAM NIL) (PARSE.FILECOMS NIL) (PARSE.LANGUAGE NIL) (PARSE.DIRLST NIL) (PARSE.CLASS NIL) (PARSE.ATOM NIL) (PARSE.CLASS2 NIL) (PARSE.ATOM2 NIL) (PARSE.CASEHEAD.FIRST '(WITH SELECT)) (PARSE.DEFHEAD.FIRST '(DEFINITIONS)) (PARSE.DEPENDENT.FIRST '(MACHINE)) (PARSE.DOTEST.FIRST '(UNTIL WHILE)) (PARSE.FORCLAUSE.FIRST '(FOR THROUGH)) (PARSE.HEAP.FIRST '(UNCOUNTED)) (PARSE.INTERVAL.FIRST '(%( %[)) (PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~)) (PARSE.ORDERED.FIRST '(ORDERED)) (PARSE.ORDERLIST.FOLLOW '(! ; END %] })) (PARSE.PACKED.FIRST '(PACKED)) (PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)) (PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT)) (PARSE.QUALIFIER.FIRST '(%. %[ ^)) (PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL WHILE %] })) (PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START TRANSFER)) (PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL)) (PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START)) (PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {)) (PARSE.TYPEOP.FIRST '(FIRST LAST NILL)) (PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE)) (PARSE.CATCHLIST.FOLLOW '(END %] })) (PARSE.CONTROLID.FOLLOW '(DECREASING IN _)) (PARSE.DECLIST.FOLLOW '(; END })) (PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] })) (PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED })) (PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES)) (PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })) (PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] })) (PARSE.SCOPE.FOLLOW '(END EXITS })) (PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT })) (PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF SHARES %] _ })) (PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION INT INTEGER MDSZone MONITORLOCK NAT REAL STRING StringBody UNSPECIFIED WORD)) (PARSE.RELOPS (LIST '= '%# '< '<= '> '>=)) (PARSE.ADDOPS (LIST '+ '-)) (PARSE.MULTOPS (LIST '* '/ 'MOD)) (PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK)) (PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)) (PARSE.TYPEOPS '(FIRST LAST NILL)) (PARSE.NOTS '(~ NOT] (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM MPOINTER CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST EXPLIST) (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE PARSE.ARGLIST PARSE.RETURNLIST)) (COMS (* ;; "BUILD ") [INITVARS (BUILD.NEXT.SCOPE NIL) (BUILD.CURRENT.SCOPE NIL) (BUILD.SCOPE.STACK NIL) (BUILD.PREFIX NIL) (BUILD.FILECOMS NIL) (BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP GEQ LEQ)) (BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR LOGXOR NTHCHARCODE SUB1)) (BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER TIMES)) (BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES LOG SIN SQRT TAN)) (BUILD.QUALIFY.WORDS '(FREE NEW SIZE)) [BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP) (CONS '%# 'IEQP) (CONS '< 'ILESSP) (CONS '<= 'ILEQ) (CONS '> 'IGREATERP) (CONS '>= 'IGEQ) (CONS '+ 'IPLUS) (CONS '- 'IDIFFERENCE) (CONS '* 'ITIMES) (CONS '/ 'IQUOTIENT) (CONS '0- 'IMINUS) (CONS 'MAX 'IMAX) (CONS 'MIN 'IMIN) (CONS 'MOD 'IMOD] [BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP) (CONS '%# 'EQP) (CONS '< 'LESSP) (CONS '<= 'GREATERP) (CONS '> 'GREATERP) (CONS '>= 'LESSP) (CONS '+ 'PLUS) (CONS '- 'DIFFERENCE) (CONS '* 'TIMES) (CONS '/ 'QUOTIENT) (CONS '0- 'MINUS) (CONS 'MAX 'MAX) (CONS 'MIN 'MIN) (CONS 'MOD 'IMOD] [BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP) (CONS '%# 'FEQP) (CONS '< 'FLESSP) (CONS '<= 'FGREATERP) (CONS '> 'FGREATERP) (CONS '>= 'FLESSP) (CONS '+ 'FPLUS) (CONS '- 'FDIFFERENCE) (CONS '* 'FTIMES) (CONS '/ 'FQUOTIENT) (CONS '0- 'FMINUS) (CONS 'MAX 'FMAX) (CONS 'MIN 'FMIN) (CONS 'MOD 'IMOD] (BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD] (RECORDS SCOPE) (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL) (P (BUILD.INIT]) (* ;; "MESATOLISP -- By Kelly Roach. Lyricized by L. Masinter") (* ;;; "SCAN: reading mesa/cedar files") (RPAQ? SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE 'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0)) (RPAQ? SCAN.CHAR NIL) (RPAQ? SCAN.QDOT NIL) (RPAQ? SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE %[ %] ^ _ { %| } ~)) (RPAQ? SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED UNCHECKED UNSAFE)) (RPAQ? SCAN.MESA.RESERVED '(RESIDENT)) (DEFINEQ (SCAN.INIT [LAMBDA NIL (* kbr%: "25-Nov-85 12:05") (PROG NIL (for ATOM in SCAN.BOTH.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'BOTH)) (for ATOM in SCAN.CEDAR.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'CEDAR)) (for ATOM in SCAN.MESA.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'MESA]) (SCAN.START [LAMBDA NIL (* ; "Edited 10-Apr-87 11:39 by Masinter") (CL:SETF (CL:FILL-POINTER SCAN.STRING) 0]) (SCAN.TEST [LAMBDA (STRING) (* ; "Edited 6-Apr-87 15:05 by Masinter") (* How would scanner parse a file containing this STRING? *) (PROG (STREAM TOKEN) (SETQ STREAM (OPENSTRINGSTREAM STRING)) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (SETQ SCAN.QDOT NIL) (SETQ TOKEN (SCAN.TOKEN STREAM)) (CLOSEF STREAM) (RETURN TOKEN]) (SCAN.TESTFILE [LAMBDA (FILE) (* kbr%: "25-Nov-85 12:05") (* How would scanner parse a file containing this STRING? *) (PROG (STREAM) (SETQ STREAM (SCAN.OPENSTREAM FILE)) [do (SETQ TOKEN (SCAN.TOKEN STREAM)) (PRINT TOKEN T) (COND ((EQ (CAR TOKEN) 'EOF) (RETURN] (CLOSEF STREAM]) (SCAN.OPENSTREAM [LAMBDA (FILE) (* ; "Edited 6-Apr-87 15:05 by Masinter") (* Open FILE, return STREAM.  *) (PROG (STREAM TOKEN) (SETQ STREAM (OPENSTREAM FILE 'INPUT)) (SETFILEPTR STREAM 0) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (SETQ SCAN.QDOT NIL) (RETURN STREAM]) (SCAN.TOKEN [LAMBDA (STREAM) (* ; "Edited 10-Apr-87 15:59 by Masinter") (* ;; "Return (CLASS VALUE) ") (PROG (SCAN CLASS VALUE VALID C ADVANCE PCHAR COMMENT DASHCRLF STATE NEST) (CL:SETF (CL:FILL-POINTER SCAN.STRING) 0) [do (while (<= (CL:CHAR-INT SCAN.CHAR) (CL:CHAR-INT '#\Space)) do (COND ((EOFP STREAM) (GO ENDFILE))) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))) (CASE SCAN.CHAR ((#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) (SCAN.START SCAN.CHAR) [do (SCAN.ACCEPT STREAM) (COND ((NOT (OR (CL:ALPHA-CHAR-P SCAN.CHAR) (CL:DIGIT-CHAR-P SCAN.CHAR))) (RETURN] (SETQ CLASS 'ID) (SETQ VALUE (MKATOM SCAN.STRING)) (SETQ VALID T) (GO GOTNEXT)) ((#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) (* TBW stuff concerning HTIndex.  *) (SCAN.START SCAN.CHAR) [do (SCAN.ACCEPT STREAM) (COND ((NOT (OR (CL:ALPHA-CHAR-P SCAN.CHAR) (CL:DIGIT-CHAR-P SCAN.CHAR))) (RETURN] (SETQ CLASS 'ID) (SETQ VALUE (MKATOM SCAN.STRING)) (SETQ VALID T) (GO GOTNEXT)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (SCAN.START SCAN.CHAR) (SETQ SCAN (SCAN.NUMBER STREAM NIL)) (SETQ CLASS (CAR SCAN)) (SETQ VALUE (CADR SCAN)) (SETQ VALID (CADDR SCAN)) (COND ((NOT VALID) (SCAN.ERROR))) (GO GOTNEXT)) ((#\_ #\Ź) (SETQ CLASS '_) (SETQ VALUE CLASS) (GO GETNEXT)) ((#\^ #\­) (SETQ CLASS '^) (SETQ VALUE CLASS) (GO GETNEXT)) ((#\, #\; #\: #\# #\+ #\* #\/ #\@ #\! #\( #\) #\[ #\] #\{ #\}) [SETQ CLASS (MKATOM (CHARACTER (CL:CHAR-INT SCAN.CHAR] (SETQ VALUE CLASS) (GO GETNEXT)) [(#\') (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (SETQ SCAN (SCAN.ESCAPE STREAM)) (SETQ VALUE (CAR SCAN)) (SETQ VALID (CADR SCAN)) (SETQ ADVANCE (CADDR SCAN)) (COND ((NOT VALID) (SCAN.ERROR))) (SETQ CLASS 'CHAR) (COND (ADVANCE (GO GETNEXT)) (T (GO GOTNEXT] [(#\") (CL:SETF (CL:FILL-POINTER SCAN.STRING) 0) (SETQ ADVANCE T) [do [COND (ADVANCE (SETQ SCAN.CHAR (CL:READ-CHAR STREAM] [CASE SCAN.CHAR ((#\") (SETQ SCAN.CHAR (\BIN STREAM)) (COND ((NOT (IEQP SCAN.CHAR (CHARCODE %"))) (RETURN] (SETQ SCAN (SCAN.ESCAPE STREAM)) (CL:VECTOR-PUSH-EXTEND (CL:INT-CHAR (CAR SCAN)) SCAN.STRING) (SETQ VALID (CADR SCAN)) (SETQ ADVANCE (CADDR SCAN)) (COND ((NOT VALID) (SCAN.ERROR] (SETQ VALUE (CL:COPY-SEQ SCAN.STRING)) (COND ((OR (EQL SCAN.CHAR '#\l) (EQL SCAN.CHAR '#\L)) (SETQ CLASS 'STRING) (GO GETNEXT)) (T (SETQ CLASS 'STRING) (COND ((EQL (CL:CHAR-UPCASE SCAN.CHAR) '#\G) (GO GETNEXT)) (T (GO GOTNEXT] ((#\-) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (COND ((NOT (EQL SCAN.CHAR '#\-)) (SETQ CLASS '-) (SETQ VALUE '-) (GO GOTNEXT))) (SETQ SCAN.CHAR '#\Null) (do (SETQ PCHAR SCAN.CHAR) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (CASE SCAN.CHAR [#\- (COND ((EQL PCHAR '#\-) (SETQ COMMENT 'DASH) (RETURN] (#\Newline (SETQ COMMENT 'CRLF) (RETURN)) NIL)) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (COND ((AND (EQ COMMENT 'DASH) (EQL SCAN.CHAR '#\Newline)) (SETQ DASHCRLF T))) (* TBW stuff about formatting *) ) [(#\.) (COND (SCAN.QDOT (SETQ SCAN.QDOT NIL) (SETQ CLASS '|..|) (SETQ VALUE '|..|) (GO GETNEXT))) (COND ((EOFP STREAM) (SETQ CLASS '%.) (SETQ VALUE '%.) (GO GOTNEXT))) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (CASE SCAN.CHAR (#\. (SETQ CLASS '|..|) (SETQ VALUE '|..|) (GO GETNEXT)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (SCAN.START '#\.) (SETQ SCAN (SCAN.NUMBER STREAM T)) (SETQ CLASS (CAR SCAN)) (SETQ VALUE (CADR SCAN)) (SETQ VALID (CADDR SCAN)) (COND ((NOT VALID) (SCAN.ERROR))) (GO GOTNEXT)) (T (SETQ CLASS '%.) (SETQ VALUE '%.) (GO GOTNEXT] [(#\=) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (COND ((EQL SCAN.CHAR '#\>) (SETQ CLASS '=>) (SETQ VALUE '=>) (GO GETNEXT)) (T (SETQ CLASS '=) (SETQ VALUE '=) (GO GOTNEXT] [(#\<) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (CASE SCAN.CHAR (#\= (SETQ CLASS '<=) (SETQ VALUE '<=) (GO GETNEXT)) (#\< (SETQ STATE 'PLAIN) (SETQ NEST 1) [do (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (CASE SCAN.CHAR (#\> (SELECTQ STATE ((PLAIN LEFTBROCKET) (SETQ STATE 'RIGHTBROCKET)) (RIGHTBROCKET (SETQ STATE 'PLAIN) (SETQ NEST (SUB1 NEST)) (COND ((ZEROP NEST) (RETURN)))) NIL)) (#\< (SELECTQ STATE ((PLAIN RIGHTBROCKET) (SETQ STATE 'LEFTBROCKET)) (RIGHTBROCKET (SETQ STATE 'PLAIN) (SETQ NEST (ADD1 NEST)) (COND ((ZEROP NEST) (RETURN)))) NIL)) (T (SETQ STATE 'PLAIN] (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (* TBW formatting stuff *) ) (T (SETQ CLASS '<) (SETQ VALUE '<) (GO GOTNEXT] [(#\>) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (COND ((EQL SCAN.CHAR '#\=) (SETQ CLASS '>=) (SETQ VALUE '>=) (GO GETNEXT)) (T (SETQ CLASS '>) (SETQ VALUE '>) (GO GOTNEXT] (T [SETQ CLASS (MKATOM (CHARACTER (CL:CHAR-INT SCAN.CHAR] (SETQ VALUE CLASS) (GO GETNEXT] GETNEXT (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) GOTNEXT [COND ((EQ CLASS 'ID) [COND ((EQ VALUE NIL) (* Hack NIL to NILL because I can't put properties on NIL.  *) (SETQ VALUE 'NILL] (COND ((GETPROP VALUE 'SCAN.RESERVED) (SETQ CLASS VALUE] (RETURN (LIST CLASS VALUE)) ENDFILE (SETQ CLASS 'EOF) (SETQ VALUE 'EOF) (RETURN (LIST CLASS VALUE]) (SCAN.NUMBER [LAMBDA (STREAM FLOAT) (* ; "Edited 6-Apr-87 15:58 by Masinter") (* Return (CLASS VALUE VALID) *) (PROG (CLASS VALUE VALID HEXCOUNT HEXSIG V START SCAN) (SETQ HEXCOUNT 0) (SETQ HEXSIG 0) (SETQ CLASS 'LNUM) [do (CASE SCAN.CHAR ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (SCAN.ACCEPT STREAM)) [(#\e #\E) [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE e) (CHARCODE a] (SETQ HEXCOUNT (ADD1 HEXCOUNT)) (SCAN.ACCEPT STREAM) (COND ([AND (IEQP HEXCOUNT 1) (OR (EQL SCAN.CHAR '#\+) (EQL SCAN.CHAR '#\-] (SETQ FLOAT T) (SCAN.ACCEPT STREAM] ((#\a #\b #\c #\d #\e #\f) [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CL:CHAR-INT SCAN.CHAR) (CHARCODE a] (SETQ HEXCOUNT (ADD1 HEXCOUNT)) (SCAN.ACCEPT STREAM)) ((#\A #\B #\C #\D #\E #\F) [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE SCAN.CHAR (CHARCODE A] (SETQ HEXCOUNT (ADD1 HEXCOUNT)) (SCAN.ACCEPT STREAM)) ((#\h #\H) [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h) (CHARCODE a] (SETQ HEXCOUNT (ADD1 HEXCOUNT)) (SCAN.ACCEPT STREAM)) ((#\.) (COND ((OR (NOT (IEQP HEXCOUNT 0)) FLOAT) (RETURN))) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (COND ((EQL SCAN.CHAR '#\.) (SETQ SCAN.QDOT T) (RETURN))) (SETQ FLOAT T) (CL:VECTOR-PUSH-EXTEND '#\. SCAN.STRING)) (T (RETURN] (CL:VECTOR-PUSH-EXTEND '#\Null SCAN.STRING) [COND (FLOAT (SETQ CLASS 'FLNUM) (SETQ SCAN (SCAN.FLOATING SCAN.STRING)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN))) ([NOT (ZEROP (LOGAND HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h) (CHARCODE a] (SETQ SCAN (SCAN.HEX SCAN.STRING)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN))) ((IEQP HEXCOUNT 0) (SETQ SCAN (SCAN.DECIMAL SCAN.STRING)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN))) ((IEQP HEXCOUNT 1) (SELECTC HEXSIG ((LLSH 1 (IDIFFERENCE (CHARCODE b) (CHARCODE a))) (SETQ SCAN (SCAN.OCTAL SCAN.STRING))) ((LLSH 1 (IDIFFERENCE (CHARCODE c) (CHARCODE a))) (SETQ CLASS 'CHAR) (SETQ SCAN (SCAN.OCTALCHAR SCAN.STRING))) ((LLSH 1 (IDIFFERENCE (CHARCODE d) (CHARCODE a))) (SETQ SCAN (SCAN.DECIMAL SCAN.STRING))) ((LLSH 1 (IDIFFERENCE (CHARCODE e) (CHARCODE a))) (SETQ CLASS 'FLNUM) (SETQ SCAN (SCAN.FLOATING SCAN.STRING))) (SETQ SCAN (SCAN.HEX SCAN.STRING))) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN))) (T (SETQ SCAN (SCAN.HEX SCAN.STRING)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (* TBW stuff *) (RETURN (LIST CLASS V VALID]) (SCAN.ACCEPT [LAMBDA (STREAM) (* ; "Edited 6-Apr-87 15:25 by Masinter") (CL:VECTOR-PUSH-EXTEND SCAN.CHAR SCAN.STRING) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM]) (SCAN.APPENDDECIMAL [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") (* DIGIT is a character code.  Return (NEWV VALID) *) (PROG (MAXV MAXD D VALID NEWV) (SETQ MAXV 429496729) (SETQ MAXD 5) (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) [SETQ VALID (OR (ILESSP V MAXV) (AND (IEQP V MAXV) (ILEQ D MAXD] (SETQ NEWV (IPLUS (ITIMES 10 V) D)) (RETURN (LIST NEWV VALID]) (SCAN.APPENDOCTAL [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") (* DIGIT is a character code.  Return (NEWV VALID) *) (PROG (MAXV D VALID NEWV) (SETQ MAXV 536870911) (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) (SETQ VALID (ILEQ V MAXV)) (SETQ NEWV (IPLUS (ITIMES 8 V) D)) (RETURN (LIST NEWV VALID]) (SCAN.APPENDHEX [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") (* DIGIT is a character code.  Return (NEWV VALID) *) (PROG (MAXV D VALID NEWV) (SETQ MAXV 268435455) [COND [(AND (IGEQ DIGIT (CHARCODE 0)) (ILEQ DIGIT (CHARCODE 9))) (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0] (T (SETQ D (IPLUS DIGIT (IMINUS (CHARCODE A)) 10] (SETQ VALID (ILEQ V MAXV)) (SETQ NEWV (IPLUS (ITIMES 16 V) D)) (RETURN (LIST NEWV VALID]) (SCAN.APPENDTOSCALE [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") (* DIGIT is a character code.  Return (NEWV VALID) *) (PROG (MAXV MAXD D VALID NEWV) (SETQ MAXV 6553) (SETQ MAXD 5) (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) [SETQ VALID (OR (ILESSP V MAXV) (AND (IEQP V MAXV) (ILEQ D MAXD] (SETQ NEWV (IPLUS (ITIMES 10 V) D)) (RETURN (LIST NEWV VALID]) (SCAN.VALIDFRACTION [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") (* DIGIT is a character code.  Return VALID. *) (PROG (MAXV MAXD D VALID) (SETQ MAXV 214748364) (SETQ MAXD 7) (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) [SETQ VALID (OR (ILESSP V MAXV) (AND (IEQP V MAXV) (ILEQ D MAXD] (RETURN VALID]) (SCAN.DECIMAL [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:48 by Masinter") (* Return (VALUE VALID) *) (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) (SETQ VALID T) (SETQ BUFFERPTR 0) (SETQ V 0) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 9))) do [COND (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) [COND ((OR (IEQP C (CHARCODE d)) (IEQP C (CHARCODE D))) (SETQ SCALE 0) (SETQ BUFFERPTR (ADD1 BUFFERPTR)) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 9))) do [COND (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) ) (SETQ SCALE (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDDECIMAL V (CHARCODE 0))) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (COND ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] (SETQ VALID NIL))) (SETQ VALUE V) (RETURN (LIST VALUE VALID]) (SCAN.OCTAL [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:55 by Masinter") (* Return (VALUE VALID) *) (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) (SETQ BUFFERPTR 0) (SETQ VALID T) (SETQ V 0) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 7))) do [COND (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) [COND ((OR (IEQP C (CHARCODE b)) (IEQP C (CHARCODE B))) (SETQ SCALE 0) (SETQ BUFFERPTR (ADD1 BUFFERPTR)) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 7))) do [COND (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) ) (SETQ SCALE (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDOCTAL V (CHARCODE 0))) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (COND ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] (SETQ VALID NIL))) (SETQ VALUE V) (RETURN (LIST VALUE VALID]) (SCAN.OCTALCHAR [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:57 by Masinter") (* Return (VALUE VALID) *) (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) (SETQ BUFFERPTR 0) (SETQ VALID T) (SETQ V 0) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 7))) do [COND (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) [COND ((OR (IEQP C (CHARCODE c)) (IEQP C (CHARCODE C))) (SETQ BUFFERPTR (ADD1 BUFFERPTR] (COND ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] (SETQ VALID NIL))) (COND ((NOT (OR (IGEQ V 0) (ILEQ V 255))) (SETQ VALID NIL))) (SETQ VALUE V) (RETURN (LIST VALUE VALID]) (SCAN.HEX [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:45 by Masinter") (* Return (VALUE VALID) *) (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) (SETQ BUFFERPTR 0) (SETQ VALID T) (SETQ V 0) (while [NOT (ZEROP (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] do (COND [[OR (AND (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9))) (AND (IGEQ C (CHARCODE A)) (ILEQ C (CHARCODE F] (COND (VALID (SETQ SCAN (SCAN.APPENDHEX V C)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] [(AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE f))) (COND (VALID [SETQ SCAN (SCAN.APPENDHEX V (IDIFFERENCE C (IDIFFERENCE (CHARCODE a) (CHARCODE A] (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (T (RETURN))) (SETQ BUFFERPTR (ADD1 BUFFERPTR))) [COND ((OR (IEQP C (CHARCODE h)) (IEQP C (CHARCODE H))) (SETQ SCALE 0) (SETQ BUFFERPTR (ADD1 BUFFERPTR)) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 9))) do [COND (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) ) (SETQ SCALE (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDHEX V (CHARCODE 0))) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN] (COND ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] (SETQ VALID NIL))) (SETQ VALUE V) (RETURN (LIST VALUE VALID]) (SCAN.FLOATING [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:46 by Masinter") (* Return (VALUE VALID) *) (PROG (VALUE VALID BUFFERPTR C V EXP SCAN SCALE OP) (SETQ BUFFERPTR 0) (SETQ VALID T) (SETQ V 0) (SETQ EXP 0) (while (AND [<= (CHARCODE 0) (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] (< C (CHARCODE 9))) do (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C))) [COND (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C)) (SETQ V (CAR SCAN))) (T (SETQ EXP (ADD1 EXP] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) [COND ((= C (CHARCODE %.)) (SETQ BUFFERPTR (ADD1 BUFFERPTR)) (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (COND ([NOT (AND (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9] (SETQ VALID NIL))) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 9))) do (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C))) [COND (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C)) (SETQ V (CAR SCAN)) (SETQ VALID (CADR SCAN)) (SETQ EXP (SUB1 EXP] (SETQ BUFFERPTR (ADD1 BUFFERPTR] (SETQ VALID T) [COND ((OR (IEQP C (CHARCODE e)) (IEQP C (CHARCODE E))) (SETQ SCALE 0) (SETQ OP 'PLUS) (SETQ BUFFERPTR (ADD1 BUFFERPTR)) (SELCHARQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)) ("+" (SETQ BUFFERPTR (ADD1 BUFFERPTR))) ("-" (SETQ OP 'MINUS) (SETQ BUFFERPTR (ADD1 BUFFERPTR))) NIL) (COND ([NOT (AND (IGEQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)) (CHARCODE 0)) (ILEQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)) (CHARCODE 9] (SETQ VALID NIL))) (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) (CHARCODE 0)) (ILEQ C (CHARCODE 9))) do [COND (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) ) (SETQ SCALE (CAR SCAN)) (SETQ VALID (CADR SCAN] (SETQ BUFFERPTR (ADD1 BUFFERPTR))) (SETQ EXP (COND ((EQ OP 'PLUS) (IPLUS EXP SCALE)) (T (IDIFFERENCE EXP SCALE] (COND ((NOT (ZEROP (CL:ELT BUFFER BUFFERPTR))) (SETQ VALID NIL))) (* TBW NOTE%: Look at MKNUMATOM & \FLOATINGSCALE to find right way to do this.  *) (SETQ VALUE (FTIMES V (EXPT 10.0 EXP))) (RETURN (LIST VALUE VALID]) (SCAN.ESCAPE [LAMBDA (STREAM) (* ; "Edited 6-Apr-87 15:28 by Masinter") (PROG (C VALID ADVANCE V NC) (SETQ VALID T) (SETQ ADVANCE T) (SETQ C SCAN.CHAR) [COND ((EQL C '#\\) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) (SETQ C (CASE SCAN.CHAR ((#\n #\N #\r #\R) (CHARCODE CR)) ((#\l #\L) (CHARCODE LF)) ((#\t #\T) (CHARCODE TAB)) ((#\b #\B) (CHARCODE BS)) ((#\f #\F) (CHARCODE FF)) ((#\' #\" #\\) (CL:CHAR-INT SCAN.CHAR)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (SETQ V 0) (SETQ NC 0) (do (COND ([NOT (AND (IGEQ (CL:CHAR-INT SCAN.CHAR) (CHARCODE 0)) (ILEQ (CL:CHAR-INT SCAN.CHAR) (CHARCODE 7] (SETQ VALID NIL) (SETQ ADVANCE NIL) (RETURN))) [SETQ V (IPLUS (ITIMES 8 V) (IDIFFERENCE (CL:CHAR-INT SCAN.CHAR) (CHARCODE 0] (COND ((IEQP (SETQ NC (ADD1 NC)) 3) (RETURN))) (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))) (COND ((IGREATERP V 255) (SETQ VALID NIL) (SETQ V 0))) (SETQ C V)) (T (SETQ VALID NIL) (SETQ ADVANCE NIL] (RETURN (LIST C VALID ADVANCE]) ) (SCAN.INIT) (* ; "PARSE *") (RPAQ? PARSE.FILELST NIL) (RPAQ? PARSE.STREAM NIL) (RPAQ? PARSE.FILECOMS NIL) (RPAQ? PARSE.LANGUAGE NIL) (RPAQ? PARSE.DIRLST NIL) (RPAQ? PARSE.CLASS NIL) (RPAQ? PARSE.ATOM NIL) (RPAQ? PARSE.CLASS2 NIL) (RPAQ? PARSE.ATOM2 NIL) (RPAQ? PARSE.CASEHEAD.FIRST '(WITH SELECT)) (RPAQ? PARSE.DEFHEAD.FIRST '(DEFINITIONS)) (RPAQ? PARSE.DEPENDENT.FIRST '(MACHINE)) (RPAQ? PARSE.DOTEST.FIRST '(UNTIL WHILE)) (RPAQ? PARSE.FORCLAUSE.FIRST '(FOR THROUGH)) (RPAQ? PARSE.HEAP.FIRST '(UNCOUNTED)) (RPAQ? PARSE.INTERVAL.FIRST '(%( %[)) (RPAQ? PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~)) (RPAQ? PARSE.ORDERED.FIRST '(ORDERED)) (RPAQ? PARSE.ORDERLIST.FOLLOW '(! ; END %] })) (RPAQ? PARSE.PACKED.FIRST '(PACKED)) (RPAQ? PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)) (RPAQ? PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT)) (RPAQ? PARSE.QUALIFIER.FIRST '(%. %[ ^)) (RPAQ? PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL WHILE %] })) (RPAQ? PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START TRANSFER)) (RPAQ? PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL)) (RPAQ? PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START)) (RPAQ? PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {)) (RPAQ? PARSE.TYPEOP.FIRST '(FIRST LAST NILL)) (RPAQ? PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE)) (RPAQ? PARSE.CATCHLIST.FOLLOW '(END %] })) (RPAQ? PARSE.CONTROLID.FOLLOW '(DECREASING IN _)) (RPAQ? PARSE.DECLIST.FOLLOW '(; END })) (RPAQ? PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] })) (RPAQ? PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED })) (RPAQ? PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES)) (RPAQ? PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })) (RPAQ? PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] })) (RPAQ? PARSE.SCOPE.FOLLOW '(END EXITS })) (RPAQ? PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT })) (RPAQ? PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF SHARES %] _ })) (RPAQ? PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION INT INTEGER MDSZone MONITORLOCK NAT REAL STRING StringBody UNSPECIFIED WORD)) (RPAQ? PARSE.RELOPS (LIST '= '%# '< '<= '> '>=)) (RPAQ? PARSE.ADDOPS (LIST '+ '-)) (RPAQ? PARSE.MULTOPS (LIST '* '/ 'MOD)) (RPAQ? PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK)) (RPAQ? PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)) (RPAQ? PARSE.TYPEOPS '(FIRST LAST NILL)) (RPAQ? PARSE.NOTS '(~ NOT)) (DECLARE%: EVAL@COMPILE (TYPERECORD PARSERSTATE (STREAM FILEPTR CHAR QDOT CLASS ATOM CLASS2 ATOM2 PREFIX NEXTSCOPE CURRENTSCOPE SCOPESTACK FILECOMS)) (TYPERECORD MINTERVAL (KIND . BOUNDS) [ACCESSFNS ((LBOUND (CAR (fetch (MINTERVAL BOUNDS) of DATUM))) (UBOUND (CADR (fetch (MINTERVAL BOUNDS) of DATUM]) (TYPERECORD MRANGE (TYPE INTERVAL)) (TYPERECORD MRELATIVE (TYPEID TYPE)) (TYPERECORD MPAINTED (TYPEID TYPE)) (TYPERECORD MENUMERATED ITEMS) (TYPERECORD MRECORD (RECORDID . FIELDLIST)) (TYPERECORD MVAR TYPE) (TYPERECORD MARRAY (INDEXTYPE TYPE)) (TYPERECORD MDESCRIPTOR TYPE) (TYPERECORD MFRAME ID) (TYPERECORD MREF TYPE) (TYPERECORD MLIST TYPE) (RECORD PAIRITEM (ID TYPEEXP DEFAULT)) (RECORD DEFAULT (EXP TRASH)) (TYPERECORD TYPELIST ITEMS) (RECORD TYPEITEM (TYPEEXP DEFAULT)) (TYPERECORD MPOINTER TYPE) (TYPERECORD CASEHEAD (ID EXP OPTEXP)) (TYPERECORD BINDITEM (ID EXP)) (RECORD KEYITEM (ID OPTEXP)) (RECORD FIELDLIST (TYPE . ITEMS) [TYPE? (AND (LISTP DATUM) (FMEMB (CAR DATUM) '(PAIRLIST TYPELIST]) (TYPERECORD PAIRLIST ITEMS) (TYPERECORD ORDERLIST ITEMS) (TYPERECORD KEYLIST ITEMS) (RECORD EXPLIST (TYPE . ITEMS) [TYPE? (AND (LISTP DATUM) (FMEMB (CAR DATUM) '(KEYLIST ORDERLIST]) ) (DEFINEQ (PARSE.MESA [LAMBDA (FILE DIRLST) (* kbr%: "25-Nov-85 12:46") (PARSE.FILE FILE 'MESA DIRLST]) (PARSE.CEDAR (CL:LAMBDA (&OPTIONAL FILE DIRLST) (* ; "Edited 10-Apr-87 16:00 by Masinter") (PARSE.FILE FILE 'CEDAR DIRLST))) (PARSE.FILE (CL:LAMBDA (&OPTIONAL FILE LANGUAGE DIRLST) (* ; "Edited 10-Apr-87 16:01 by Masinter") (PROG NIL (SETQ PARSE.DIRLST DIRLST) (SETQ PARSE.LANGUAGE LANGUAGE) (SETQ PARSE.STREAM (SCAN.OPENSTREAM FILE)) (SETQ PARSE.ATOM NIL) (SETQ PARSE.ATOM2 NIL) (PARSE.BIN) (PARSE.BIN) (PARSE.MODULE) (SETQ PARSE.FILECOMS (DREVERSE PARSE.FILECOMS)) (CLOSEF PARSE.STREAM)))) (PARSE.GET.STATE [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (* Get parser state to save before  interruption. *) (create PARSERSTATE STREAM _ PARSE.STREAM FILEPTR _ (GETFILEPTR PARSE.STREAM) CHAR _ SCAN.CHAR QDOT _ SCAN.QDOT CLASS _ PARSE.CLASS ATOM _ PARSE.ATOM CLASS2 _ PARSE.CLASS2 ATOM2 _ PARSE.ATOM2 PREFIX _ BUILD.PREFIX NEXTSCOPE _ BUILD.NEXT.SCOPE CURRENTSCOPE _ BUILD.CURRENT.SCOPE SCOPESTACK _ BUILD.SCOPE.STACK FILECOMS _ BUILD.FILECOMS]) (PARSE.SET.STATE [LAMBDA (STATE) (* kbr%: "25-Nov-85 12:46") (* Restore state after interruption.  *) (PROG NIL (SETQ PARSE.STREAM (fetch (PARSERSTATE STREAM) of STATE)) (SETFILEPTR PARSE.STREAM (fetch (PARSERSTATE FILEPTR) of STATE)) (SETQ SCAN.CHAR (fetch (PARSERSTATE CHAR) of STATE)) (SETQ SCAN.QDOT (fetch (PARSERSTATE QDOT) of STATE)) (SETQ PARSE.CLASS (fetch (PARSERSTATE CLASS) of STATE)) (SETQ PARSE.ATOM (fetch (PARSERSTATE ATOM) of STATE)) (SETQ PARSE.CLASS2 (fetch (PARSERSTATE CLASS2) of STATE)) (SETQ PARSE.ATOM2 (fetch (PARSERSTATE ATOM2) of STATE)) (SETQ BUILD.PREFIX (fetch (PARSERSTATE PREFIX) of STATE)) (SETQ BUILD.NEXT.SCOPE (fetch (PARSERSTATE NEXTSCOPE) of STATE)) (SETQ BUILD.CURRENT.SCOPE (fetch (PARSERSTATE CURRENTSCOPE) of STATE)) (SETQ BUILD.SCOPE.STACK (fetch (PARSERSTATE SCOPESTACK) of STATE)) (SETQ BUILD.FILECOMS (fetch (PARSERSTATE FILECOMS) of STATE]) (PARSE.BIN (CL:LAMBDA (EXPECTCLASS) (* ; "Edited 10-Apr-87 16:00 by Masinter") (PROG (OLDATOM TOKEN) (COND ([AND EXPECTCLASS (OR (AND (LITATOM EXPECTCLASS) (NOT (EQ EXPECTCLASS PARSE.CLASS))) (AND (LISTP EXPECTCLASS) (NOT (FMEMB PARSE.CLASS EXPECTCLASS] (SHOULDNT "PARSE.BIN"))) (SETQ OLDATOM PARSE.ATOM) (SETQ TOKEN (SCAN.TOKEN PARSE.STREAM)) (SETQ PARSE.CLASS PARSE.CLASS2) (SETQ PARSE.ATOM PARSE.ATOM2) (SETQ PARSE.CLASS2 (CAR TOKEN)) (SETQ PARSE.ATOM2 (CADR TOKEN)) (RETURN OLDATOM)))) (PARSE.VARID [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (BUILD.VARID NIL (PARSE.BIN 'ID]) (PARSE.SMURF [LAMBDA (N) (* kbr%: "25-Nov-85 12:46") (* Indicate where error occurred while  reading file *) (COND ((NULL N) (SETQ N 100))) (RESETLST (PROG (POSITION START FINISH) (* Broken file = previous input file *) (SETQ POSITION (GETFILEPTR PARSE.STREAM)) (RESETSAVE NIL (LIST 'SETFILEPTR PARSE.STREAM POSITION)) (SETQ START (IMAX 0 (IDIFFERENCE (SUB1 POSITION) N))) (SETQ FINISH (IMIN (GETEOFPTR PARSE.STREAM) (IPLUS (SUB1 POSITION) N))) (COPYBYTES PARSE.STREAM T START (SUB1 POSITION)) (PRIN1 "[PARSE]" T) (COPYBYTES PARSE.STREAM T (SUB1 POSITION) FINISH) (TERPRI T]) (PARSE.THISIS.MESA [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (* Assert this is MESA *) (COND ((NOT (EQ PARSE.LANGUAGE 'MESA)) (SHOULDNT]) (PARSE.THISIS.CEDAR [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (* Assert this is CEDAR *) (COND ((NOT (EQ PARSE.LANGUAGE 'CEDAR)) (SHOULDNT]) (PARSE.MODULE [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (PROG (IDENTLIST) (* (module directory identlist cedar  proghead trusted checked block)  (module directory identlist cedar  defhead defbody) *) (PARSE.DIRECTORY) (SETQ IDENTLIST (PARSE.IDENTLIST)) (BUILD.INIT (CAR IDENTLIST)) (BUILD.STORE.INTERFACES IDENTLIST) (PARSE.SEADIRT) (COND ((NOT (EQ PARSE.ATOM 'DEFINITIONS)) (PARSE.PROGHEAD) (PARSE.CHECKED) (PARSE.BLOCK)) (T (PARSE.DEFHEAD) (PARSE.DEFBODY))) (PUTPROP BUILD.PREFIX 'MESA.PARSED T) (pushnew PARSE.FILELST BUILD.PREFIX]) (PARSE.INCLUDEITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (PROG (ID USING) (* (includeitem id %: FROM string  using) (includeitem id %: TYPE using)  (includeitem id using)  (includeitem id %: TYPE id using) *) (SETQ ID (PARSE.BIN 'ID)) (BUILD.STORE.INTERFACE ID) (PARSE.INCLUDECHECK ID) [COND [(EQ PARSE.ATOM '%:) (PARSE.BIN) (COND ((EQ PARSE.ATOM 'FROM) (PARSE.BIN) (PARSE.BIN 'STRING) (SETQ USING (PARSE.USING))) (T (PARSE.BIN 'TYPE) (COND ((EQ PARSE.ATOM 'ID) (PARSE.BIN 'ID) (SETQ USING (PARSE.USING))) ((EQ PARSE.ATOM 'USING) (SETQ USING (PARSE.USING] (T (SETQ USING (PARSE.USING] (BUILD.STORE.USING ID USING]) (PARSE.INCLUDECHECK [LAMBDA (ID) (* kbr%: "25-Nov-85 12:46") (PROG (STATE FILE) (COND ((GETPROP ID 'MESA.PARSED) (* Interface already loaded.  *) (RETURN))) (SELECTQ (ASKUSER NIL NIL (CONCAT "Should I parse " ID ".MESA?")) (Y [SETQ FILE (OR (FINDFILE (PACK* ID '.MESA) NIL PARSE.DIRLST) (MKATOM (PROMPTFORWORD (CONCAT "Enter full filename for " ID ".MESA:" ] (COND (FILE (SETQ STATE (PARSE.GET.STATE)) (PARSE.FILE FILE PARSE.LANGUAGE PARSE.DIRLST) (PARSE.SET.STATE STATE)))) (N NIL) (SHOULDNT]) (PARSE.SEADIRT [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (* BOTH (cedar) *) (* CEDAR (cedar CEDAR) *) (COND ((EQ PARSE.ATOM 'CEDAR) (PARSE.THISIS.CEDAR) (PARSE.BIN]) (PARSE.PROGHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") (PROG NIL (* (proghead resident safe class  arguments locks interface tilde public)  *) (* In MESA, tilde must be =. This is handled by PARSE.TILDE.  *) (PARSE.RESIDENT) (PARSE.SAFE) (PARSE.CLASS) (PARSE.ARGUMENTS) (PARSE.LOCKS) (PARSE.INTERFACE) (PARSE.TILDE) (PARSE.PUBLIC]) (PARSE.RESIDENT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* BOTH (resident) *) (* MESA (resident RESIDENT) *) (COND ((EQ PARSE.ATOM 'RESIDENT) (PARSE.THISIS.MESA) (PARSE.BIN]) (PARSE.SAFE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* BOTH (safe) *) (* CEDAR (safe UNSAFE)  (safe SAFE) *) (COND ((FMEMB PARSE.ATOM '(SAFE UNSAFE)) (PARSE.THISIS.CEDAR) (PARSE.BIN]) (PARSE.DEFHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG NIL (* (defhead definitions locks imports  shares tilde public) *) (PARSE.DEFINITIONS) (PARSE.LOCKS) (PARSE.IMPORTS) (PARSE.SHARES) (PARSE.TILDE) (PARSE.PUBLIC]) (PARSE.TILDE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* BOTH (tilde =) *) (* CEDAR (tilde ~) *) (COND ((EQ PARSE.ATOM '=) (PARSE.BIN)) ((EQ PARSE.ATOM '~) (PARSE.THISIS.CEDAR) (PARSE.BIN)) (T (SHOULDNT]) (PARSE.DEFINITIONS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (definitions DEFINITIONS) *) (PARSE.BIN]) (PARSE.DEFBODY [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG NIL (* (defbody BEGIN open declist END)  (defbody BEGIN open declist ;  END) (defbody { open declist })  (defbody { open declist ;  }) *) (PARSE.BIN '(BEGIN {)) (BUILD.PUSH.SCOPE) (BUILD.STORE.OPEN (PARSE.OPEN)) (PARSE.DECLIST) (BUILD.POP.SCOPE) (BUILD.GC.SCOPE) (COND ((EQ PARSE.ATOM ';) (PARSE.BIN))) (PARSE.BIN '(END }]) (PARSE.LOCKS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG NIL (* (locks LOCKS primary lambda)  (locks) *) (COND ((EQ PARSE.ATOM 'LOCKS) (PARSE.BIN) (PARSE.PRIMARY) (PARSE.LAMBDA]) (PARSE.LAMBDA [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (IDENT TYPEEXP) (* (lambda USING ident typeexp)  (lambda) *) (COND ((EQ PARSE.ATOM 'USING) (PARSE.BIN) (SETQ IDENT (PARSE.IDENT)) (SETQ TYPEEXP (PARSE.TYPEEXP)) (BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE]) (PARSE.MODULEITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID1 ID2) (* (moduleitem id) (moduleitem id %:  id) *) (SETQ ID1 (PARSE.BIN 'ID)) [COND ((EQ PARSE.ATOM '%:) (PARSE.BIN) (SETQ ID2 (PARSE.BIN 'ID)) (PUTPROP ID1 'MESA.ABBREVIATES 'ID2] (RETURN ID1]) (PARSE.DECLARATION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (IDENTLIST TYPEEXP INITIALIZATION DEFAULT OPTSIZE ANSWER) (* (declaration identlist public entry  readonly typeexp initialization)  (declaration identlist public TYPE  tilde public typeexp default)  (declaration identlist public TYPE  optsize) *) (* In MESA, tilde must be =. This is handled by PARSE.TILDE.  *) (SETQ IDENTLIST (PARSE.IDENTLIST)) (BUILD.STORE.IDENTLIST IDENTLIST) (PARSE.PUBLIC) [COND ((NOT (EQ PARSE.ATOM 'TYPE)) (PARSE.ENTRY) (PARSE.READONLY) (SETQ TYPEEXP (PARSE.TYPEEXP)) (SETQ INITIALIZATION (PARSE.INITIALIZATION)) (SETQ ANSWER (BUILD.INITIALIZATION IDENTLIST TYPEEXP INITIALIZATION))) (T (PARSE.BIN 'TYPE) (COND ([OR (EQ PARSE.ATOM '=) (AND (EQ PARSE.LANGUAGE 'CEDAR) (EQ PARSE.ATOM '~] (PARSE.TILDE) (PARSE.PUBLIC) (SETQ TYPEEXP (PARSE.TYPEEXP)) (SETQ DEFAULT (PARSE.DEFAULT)) (BUILD.TYPE IDENTLIST TYPEEXP DEFAULT)) (T (SETQ OPTSIZE (PARSE.OPTSIZE)) (* I think this means MESA/CEDAR is to treat declared id as a type, but no  declaration of id is given in this file.  *) ] (BUILD.STORE.IDENTLIST NIL) (RETURN ANSWER]) (PARSE.PUBLIC [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (public PUBLIC) (public PRIVATE)  (public) *) (COND ((MEMB PARSE.ATOM '(PUBLIC PRIVATE)) (PARSE.BIN]) (PARSE.ENTRY [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (entry ENTRY) (entry INTERNAL)  (entry) *) (COND ((MEMB PARSE.ATOM '(ENTRY INTERNAL)) (PARSE.BIN]) (PARSE.IDLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (idlist' id) (idlist' id %, idlist')  *) (PROG (IDS ANSWER) (push IDS (PARSE.BIN 'ID)) [while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push IDS (PARSE.BIN 'ID] (SETQ ANSWER (DREVERSE IDS)) (RETURN ANSWER]) (PARSE.IDENTLIST [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:47") (* (identlist' id %:)  (identlist' id position %:)  (identlist' id %, identlist')  (identlist' id position %, identlist')  *) (PROG (IDS TYPEITEMS ANSWER) LOOP (COND ((AND (EQ KIND 'FIELDLIST) (PARSE.TYPEEXP.HERE)) (* Thought we we're parsing a pairlist, but now we learn we are in a typelist.  *) (SETQ TYPEITEMS (fetch (TYPELIST ITEMS) of (PARSE.TYPELIST))) (GO TYPELIST))) (push IDS (PARSE.BIN 'ID)) (COND ((EQ PARSE.ATOM '%() (PARSE.POSITION))) (COND ((EQ PARSE.ATOM '%,) (PARSE.BIN) (GO LOOP)) (T (GO EXIT))) (GO LOOP) EXIT (COND ((NOT (EQ PARSE.ATOM '%:)) (GO TYPELIST))) (PARSE.BIN '%:) (SETQ ANSWER (DREVERSE IDS)) (RETURN ANSWER) TYPELIST (SETQ ANSWER (create TYPELIST ITEMS _ (NCONC (DREVERSE IDS) TYPEITEMS))) (RETURN ANSWER]) (PARSE.POSITION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXP OPTBITS ANSWER) (* (position %( exp optbits %)) *) (PARSE.BIN '%() (SETQ EXP (PARSE.EXP)) (SETQ OPTBITS (PARSE.OPTBITS)) (PARSE.BIN '%)) (SETQ ANSWER (LIST 'position EXP OPTBITS)) (RETURN ANSWER]) (PARSE.OPTBITS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (optbits %: bounds)  (optbits) *) (COND ((EQ PARSE.ATOM '%:) (PARSE.BIN '%:) (PARSE.BOUNDS]) (PARSE.INTERVAL [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (KIND BOUNDS ANSWER) (* (interval %[ bounds %])  (interval %[ bounds %))  (interval %( bounds %])  (interval %( bounds %)) *) (SELECTQ PARSE.ATOM (%[ (PARSE.BIN) (SETQ BOUNDS (PARSE.BOUNDS)) (SELECTQ PARSE.ATOM (%] (SETQ KIND 'CC)) (%) (SETQ KIND 'CO)) (SHOULDNT)) (PARSE.BIN)) (%( (PARSE.BIN) (SETQ BOUNDS (PARSE.BOUNDS)) (SELECTQ PARSE.ATOM (%] (SETQ KIND 'OC)) (%) (SETQ KIND 'OO)) (SHOULDNT)) (PARSE.BIN)) (SHOULDNT)) (SETQ ANSWER (create MINTERVAL KIND _ KIND BOUNDS _ BOUNDS)) (RETURN ANSWER]) (PARSE.TYPEEXP.HERE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") NIL]) (PARSE.TYPEEXP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (typeexp id) (typeexp typeid)  (typeexp typecons)) [COND [(EQ PARSE.CLASS 'ID) (SETQ ANSWER (PARSE.BIN)) [COND ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)) (SETQ ANSWER (PARSE.TYPEID.CONT ANSWER))) (T (SETQ ANSWER (BUILD.TYPEID NIL ANSWER] (COND ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)) (SETQ ANSWER (PARSE.TYPECONS.CONT ANSWER] (T (SETQ ANSWER (PARSE.TYPECONS] (RETURN ANSWER]) (PARSE.RANGE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPE INTERVAL ANSWER) (* (range id) (range id interval)  (range typeid interval)  (range interval) (range typeid) *) [COND ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) (SETQ TYPE 'CARDINAL) (SETQ INTERVAL (PARSE.INTERVAL))) ((FMEMB PARSE.ATOM2 PARSE.RANGE.FOLLOW) (* This case occurs if TYPE itself is a range type.  *) [SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN 'ID] (RETURN TYPE)) ((FMEMB PARSE.ATOM2 PARSE.INTERVAL.FIRST) [SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN 'ID] (SETQ INTERVAL (PARSE.INTERVAL))) (T (SETQ TYPE (PARSE.TYPEID)) (COND ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) (SETQ INTERVAL (PARSE.INTERVAL] (SETQ ANSWER (create MRANGE TYPE _ TYPE INTERVAL _ INTERVAL)) (RETURN ANSWER]) (PARSE.TYPEAPPL [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG NIL (* (typeappl typeappl %.  id) (typeappl id length)  (typeappl typeid length)  (typeappl typeappl length) *) (BREAK1 NIL T]) (PARSE.TYPEAPPL.CONT [LAMBDA (TYPEAPPL) (* kbr%: "25-Nov-85 12:47") (PROG (ID LENGTH ANSWER) (SETQ ANSWER TYPEAPPL) [while (FMEMB PARSE.ATOM '(%. %[)) do (COND ((EQ PARSE.ATOM '%.) (PARSE.BIN) (SETQ ID (PARSE.BIN 'ID)) (SETQ ANSWER (LIST ANSWER ID))) (T (SETQ LENGTH (PARSE.LENGTH)) (SETQ ANSWER (LIST ANSWER LENGTH] (RETURN ANSWER]) (PARSE.TYPEID [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PARSE.TYPEID.CONT (PARSE.BIN 'ID]) (PARSE.TYPEID.CONT [LAMBDA (ID) (* kbr%: "25-Nov-85 12:47") (PROG (INTERFACE ANSWER) (* (typeid' id %. id)  (typeid' typeid' %. id)  (typeid id id) (typeid id typeid)  (typeid typeid') *) (* Should be ID+{.ID}* *) (while (EQ PARSE.CLASS 'ID) do (BREAK1 NIL T) (SETQ ID (PARSE.BIN))) [COND ((EQ PARSE.ATOM '%.) (SETQ INTERFACE ID) (PARSE.BIN) (SETQ ID (PARSE.BIN 'ID] (SETQ ANSWER (BUILD.TYPEID INTERFACE ID)) (RETURN ANSWER]) (PARSE.TYPECONS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (COND ((EQ PARSE.CLASS 'ID) (PARSE.TYPECONS1)) (T (PARSE.TYPECONS2]) (PARSE.TYPECONS1 [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* TYPECONS begining with ID token.  *) (PROG (TYPEID ANSWER) (* BOTH (typecons id interval)  (typecons typeid interval)  (typecons id RELATIVE typeexp)  (typecons typeid RELATIVE typeexp)  (typecons typeappl) *) (* CEDAR (typecons id PAINTED typeexp)  (typecons typeid PAINTED typeexp) *) (* Get id or typeid.  *) (SETQ TYPEID (PARSE.BIN 'ID)) [COND ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)) (SETQ TYPEID (PARSE.TYPEID.CONT TYPEID))) (T (SETQ TYPEID (BUILD.TYPEID NIL TYPEID] (* Finish typecons. *) (SETQ ANSWER (PARSE.TYPECONS.CONT TYPEID)) (RETURN ANSWER]) (PARSE.TYPECONS.CONT [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") (* ;  "TYPEID is an id or typeid. Finish typecons.") (PROG (INTERVAL TYPEEXP EXP1 EXP2 KIND ANSWER) (* ;; "BOTH (typecons id interval) (typecons typeid interval) (typecons id RELATIVE typeexp) (typecons typeid RELATIVE typeexp) (typecons typeappl) ") (* ;; "CEDAR (typecons id PAINTED typeexp) (typecons typeid PAINTED typeexp) *") (COND ((EQ PARSE.ATOM 'RELATIVE) (SETQ ANSWER (PARSE.TYPECONS.RELATIVE))) ((EQ PARSE.ATOM 'PAINTED) (SETQ ANSWER (PARSE.TYPECONS.PAINTED))) ((EQ PARSE.ATOM '%() (PARSE.TYPECONS.RANGE TYPEID)) [(EQ PARSE.ATOM '%[) (* ;  "This can be the start of a length or of an interval. Can't tell with bounded look ahead. ") (PARSE.BIN '%[) (SETQ EXP1 (PARSE.EXP)) (COND ((EQ PARSE.ATOM '|..|) (* ; "Interval. ") (PARSE.BIN '|..|) (SETQ EXP2 (PARSE.EXP)) [COND ((EQ PARSE.ATOM '%)) (PARSE.BIN '%)) (SETQ KIND 'CO)) (T (PARSE.BIN '%]) (SETQ KIND 'CC] (SETQ INTERVAL (create MINTERVAL KIND _ KIND BOUNDS _ (LIST EXP1 EXP2))) (SETQ ANSWER (create MRANGE TYPE _ TYPEID INTERVAL _ INTERVAL))) (T (* ; "Length. *") (PARSE.BIN '%]) (SETQ ANSWER (LIST TYPEID EXP1)) (SETQ ANSWER (PARSE.TYPEAPPL.CONT ANSWER] (T (SHOULDNT))) (RETURN ANSWER]) (PARSE.TYPECONS.RANGE [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") (PROG (INTERVAL ANSWER) (SETQ INTERVAL (PARSE.INTERVAL)) (SETQ ANSWER (create MRANGE TYPE _ TYPEID INTERVAL _ INTERVAL)) (RETURN ANSWER]) (PARSE.TYPECONS.RELATIVE [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (PARSE.BIN 'RELATIVE) (SETQ TYPE (PARSE.TYPEEXP)) (SETQ ANSWER (create MRELATIVE TYPEID _ TYPEID TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TYPECONS.PAINTED [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (PARSE.THISIS.CEDAR) (PARSE.BIN 'RELATIVE) (SETQ TYPE (PARSE.TYPEEXP)) (SETQ ANSWER (create MPAINTED TYPEID _ TYPEID TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TYPECONS2 [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* TYPECONS begining with reserved  word. *) (PROG (ANSWER) (* BOTH (typecons interval) (typecons dependent { elementlist })  (typecons dependent monitored RECORD reclist)  (typecons ordered base pointertype) (typecons VAR typeexp)  (typecons packed ARRAY indextype OF typeexp)  (typecons DESCRIPTOR FOR readonly typeexp)  (typecons safe transfermode arguments) (typecons heap ZONE)  (typecons LONG typeexp) (typecons FRAME %[ id %]) *) (* CEDAR (typecons REF readonly  typeexp) (typecons REF readonly ANY)  (typecons REF) (typecons LIST OF  readonly typeexp) *) [SETQ ANSWER (COND ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) (PARSE.TYPECONS.INTERVAL)) (T (SELECTQ PARSE.ATOM ((MACHINE MONITORED RECORD {) (PARSE.TYPECONS.DEPENDENT)) ((ORDERED BASE POINTER) (PARSE.TYPECONS.ORDERED)) (VAR (PARSE.TYPECONS.VAR)) ((PACKED ARRAY) (PARSE.TYPECONS.PACKED)) (DESCRIPTOR (PARSE.TYPECONS.DESCRIPTOR)) ((SAFE ERROR PORT PROC PROCEDURE PROCESS PROGRAM SIGNAL) (PARSE.TYPECONS.SAFE)) (UNCOUNTED (PARSE.TYPECONS.HEAP)) (LONG (PARSE.TYPECONS.LONG)) (FRAME (PARSE.TYPECONS.FRAME)) (REF (PARSE.TYPECONS.REF)) (LIST (PARSE.TYPECONS.LIST)) (SHOULDNT] (RETURN ANSWER]) (PARSE.TYPECONS.INTERVAL [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (typecons interval) *) (SETQ ANSWER (create MRANGE TYPE _ 'CARDINAL INTERVAL _ (PARSE.INTERVAL))) (RETURN ANSWER]) (PARSE.TYPECONS.DEPENDENT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ELEMENTLIST RECLIST ANSWER) (* (typecons dependent { elementlist })  (typecons dependent monitored RECORD  reclist) *) (PARSE.DEPENDENT) [SETQ ANSWER (COND ((EQ PARSE.ATOM '{) (PARSE.TYPECONS.ENUMERATED)) (T (PARSE.TYPECONS.RECORD] (RETURN ANSWER]) (PARSE.TYPECONS.ENUMERATED [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ITEMS ANSWER) (PARSE.BIN) (SETQ ITEMS (PARSE.ELEMENTLIST)) (PARSE.BIN '}) (SETQ ANSWER (create MENUMERATED ITEMS _ ITEMS)) (RETURN ANSWER]) (PARSE.TYPECONS.RECORD [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (FIELDLIST ANSWER) (PARSE.MONITORED) (PARSE.BIN 'RECORD) (SETQ FIELDLIST (PARSE.RECLIST)) (SETQ ANSWER (create MRECORD FIELDLIST _ FIELDLIST)) (RETURN ANSWER]) (PARSE.TYPECONS.ORDERED [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (typecons ordered base pointertype)  *) (PARSE.ORDERED) (PARSE.BASE) (SETQ ANSWER (PARSE.POINTERTYPE)) (RETURN ANSWER]) (PARSE.TYPECONS.VAR [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (* (typecons VAR typeexp) *) (PARSE.BIN 'VAR) (SETQ TYPE (PARSE.TYPEEXP)) (SETQ ANSWER (create MVAR TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TYPECONS.PACKED [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (PACKED INDEXTYPE TYPE ANSWER) (* (typecons packed ARRAY indextype OF  typeexp) *) (SETQ PACKED (PARSE.PACKED)) (PARSE.BIN 'ARRAY) (SETQ INDEXTYPE (PARSE.INDEXTYPE)) (PARSE.BIN 'OF) (SETQ TYPE (PARSE.TYPEEXP)) (SETQ ANSWER (create MARRAY INDEXTYPE _ INDEXTYPE TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TYPECONS.DESCRIPTOR [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (* (typecons DESCRIPTOR FOR readonly  typeexp) *) (PARSE.BIN 'DESCRIPTOR) (PARSE.BIN 'FOR) (PARSE.READONLY) (SETQ TYPE (PARSE.TYPEEXP)) (SETQ ANSWER (create MDESCRIPTOR TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TYPECONS.SAFE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TRANSFERMODE) (* (typecons safe transfermode  arguments) *) (PARSE.SAFE) (SETQ TRANSFERMODE (PARSE.TRANSFERMODE)) (PARSE.ARGUMENTS) (RETURN TRANSFERMODE]) (PARSE.TYPECONS.HEAP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG NIL (* (typecons heap ZONE) *) (PARSE.HEAP) (PARSE.BIN 'ZONE) (RETURN 'ZONE]) (PARSE.TYPECONS.LONG [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (typecons LONG typeexp) *) (PARSE.BIN 'LONG) (SETQ ANSWER (PARSE.TYPEEXP)) (RETURN ANSWER]) (PARSE.TYPECONS.FRAME [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID ANSWER) (* (typecons FRAME %[ id %]) *) (PARSE.BIN 'FRAME) (PARSE.BIN '%[) [SETQ ID (BUILD.ID NIL (PARSE.BIN 'ID] (PARSE.BIN '%]) (SETQ ANSWER (create MFRAME ID _ ID)) (RETURN ANSWER]) (PARSE.TYPECONS.REF [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (* CEDAR (typecons REF readonly  typeexp) (typecons REF readonly ANY)  (typecons REF) *) (PARSE.THISIS.CEDAR) (PARSE.BIN 'REF) [COND ((FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW) (SETQ TYPE 'ANY)) (T (PARSE.READONLY) (COND ((EQ PARSE.ATOM 'ANY) (PARSE.BIN) (SETQ TYPE 'ANY)) (T (SETQ TYPE (PARSE.TYPEEXP] (SETQ ANSWER (create MREF TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TYPECONS.LIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (* CEDAR (typecons LIST OF readonly  typeexp) *) (PARSE.THISIS.CEDAR) (PARSE.BIN 'LIST) (PARSE.BIN 'OF) (PARSE.READONLY) (SETQ TYPE (PARSE.TYPEEXP)) (SETQ ANSWER (create MLIST TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.IDENT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID) (* (ident id position %:)  (ident id %:) *) (SETQ ID (PARSE.BIN 'ID)) [COND ((EQ PARSE.ATOM '%:) (PARSE.BIN)) (T (PARSE.POSITION) (PARSE.BIN '%:] (RETURN ID]) (PARSE.ELEMENT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID EXP ANSWER) (* (element id %( exp %))  (element %( exp %)) (element id) *) [COND ((NOT (EQ PARSE.ATOM '%()) (SETQ ID (PARSE.BIN 'ID] (COND ((EQ PARSE.ATOM '%() (PARSE.BIN) (SETQ EXP (PARSE.EXP)) (SETQ ANSWER ID) (PARSE.BIN '%))) (T (SETQ ANSWER ID))) (RETURN ANSWER]) (PARSE.MONITORED [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (monitored MONITORED)  (monitored) *) (COND ((EQ PARSE.ATOM 'MONITORED) (PARSE.BIN]) (PARSE.DEPENDENT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (dependent MACHINE DEPENDENT)  (dependent) *) (COND ((EQ PARSE.ATOM 'MACHINE) (PARSE.BIN) (PARSE.BIN 'DEPENDENT) 'MACHINE.DEPENDENT]) (PARSE.RECLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (PAIRLIST TYPELIST VARIANTPAIR VARIANTPART DEFAULT ANSWER) (* (reclist %[ %]) (reclist NULL)  (reclist %[ pairlist %])  (reclist %[ typelist %])  (reclist %[ pairlist %, variantpair %])  (reclist %[ variantpart default %])  (reclist %[ variantpair %]) *) (COND ((EQ PARSE.ATOM 'NULL) (PARSE.BIN) (RETURN NIL))) (PARSE.BIN '%[) (COND ((EQ PARSE.ATOM '%]) (PARSE.BIN) (RETURN NIL))) (COND [(FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST) (SETQ VARIANTPART (PARSE.VARIANTPART)) (SETQ DEFAULT (PARSE.DEFAULT)) (SETQ ANSWER (LIST (create PAIRITEM TYPEEXP _ VARIANTPART DEFAULT _ DEFAULT] ([AND (EQ PARSE.CLASS 'ID) (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES)) (FMEMB PARSE.ATOM2 '(%( %, %:] (SETQ PAIRLIST (PARSE.PAIRLIST 'RECLIST)) [for PAIRITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) do (replace (PAIRITEM ID) of PAIRITEM with (BUILD.FIELDID NIL (fetch (PAIRITEM ID) of PAIRITEM] (SETQ ANSWER PAIRLIST)) (T (SETQ TYPELIST (PARSE.TYPELIST)) (SETQ ANSWER TYPELIST))) (PARSE.BIN '%]) (RETURN ANSWER]) (PARSE.VARIANTPAIR [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (IDENTLIST PUBLIC VARIANTPART DEFAULT ANSWER) (* (variantpair identlist public  variantpart default) *) (SETQ IDENTLIST (PARSE.IDENTLIST)) (PARSE.PUBLIC) (SETQ VARIANTPART (PARSE.VARIANTPART)) (SETQ DEFAULT (PARSE.DEFAULT)) (SETQ ANSWER (for ID in IDENTLIST collect (create PAIRITEM ID _ ID TYPEEXP _ VARIANTPART DEFAULT _ DEFAULT))) (RETURN ANSWER]) (PARSE.PAIRITEM [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:47") (PROG (IDENTLIST VARIANTPART TYPEEXP DEFAULT ANSWER) (* (pairitem identlist public typeexp  default) (variantpair identlist public  variantpart default) *) (SETQ IDENTLIST (PARSE.IDENTLIST KIND)) (COND ((type? TYPELIST IDENTLIST) (* Thought we we're parsing a pairlist but found a typelist.  *) (RETURN IDENTLIST))) (PARSE.PUBLIC) [COND ([AND (FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST) (OR (NOT (EQ PARSE.ATOM 'PACKED)) (NOT (EQ PARSE.ATOM2 'ARRAY] (* Variantpair. *) (COND ((NOT (EQ KIND 'RECLIST)) (SHOULDNT))) (SETQ TYPEEXP (PARSE.VARIANTPART))) (T (* Typeexp. *) (SETQ TYPEEXP (PARSE.TYPEEXP] (SETQ DEFAULT (PARSE.DEFAULT)) (SETQ ANSWER (for ID in IDENTLIST collect (create PAIRITEM ID _ ID TYPEEXP _ TYPEEXP DEFAULT _ DEFAULT))) (RETURN ANSWER]) (PARSE.DEFAULTOPT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXP TRASH ANSWER) (* (defaultopt TRASH)  (defaultopt NULL) (defaultopt exp %|  TRASH) (defaultopt exp %| NULL)  (defaultopt) (defaultopt exp) *) [COND ((FMEMB PARSE.ATOM '(TRASH NULL)) (PARSE.BIN) (SETQ TRASH T)) ((NOT (FMEMB PARSE.ATOM PARSE.DEFAULTOPT.FOLLOW)) (SETQ EXP (PARSE.EXP)) (COND ((EQ PARSE.ATOM '%|) (PARSE.BIN '%|) (COND ((FMEMB PARSE.ATOM '(TRASH NULL)) (PARSE.BIN) (SETQ TRASH T] (SETQ ANSWER (create DEFAULT EXP _ EXP TRASH _ TRASH)) (RETURN ANSWER]) (PARSE.VARIANTPART [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (VCASEHEAD VARIANTLIST TYPEEXP ANSWER) (* (variantpart SELECT vcasehead FROM  variantlist ENDCASE)  (variantpart SELECT vcasehead FROM  variantlist %, ENDCASE)  (variantpart packed SEQUENCE vcasehead  OF typeexp) *) [COND ((EQ PARSE.ATOM 'SELECT) (PARSE.BIN) (SETQ VCASEHEAD (PARSE.VCASEHEAD)) (PARSE.BIN 'FROM) (SETQ VARIANTLIST (PARSE.VARIANTLIST)) (COND ((EQ PARSE.ATOM '%,) (PARSE.BIN))) (PARSE.BIN 'ENDCASE) (SETQ ANSWER (LIST 'SELECT VCASEHEAD VARIANTLIST))) (T (SETQ PACKED (PARSE.PACKED)) (PARSE.BIN 'SEQUENCE) (SETQ VCASEHEAD (PARSE.VCASEHEAD)) (PARSE.BIN 'OF) (SETQ TYPEEXP (PARSE.TYPEEXP)) (SETQ ANSWER (LIST 'SEQUENCE VCASEHEAD TYPEEXP] (RETURN ANSWER]) (PARSE.VCASEHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (IDENT PUBLIC TAGTYPE ANSWER) (* (vcasehead ident public tagtype)  (vcasehead COMPUTED tagtype)  (vcasehead OVERLAID tagtype) *) [COND ([NOT (FMEMB PARSE.ATOM '(COMPUTED OVERLAID] (SETQ IDENT (PARSE.IDENT)) (SETQ PUBLIC (PARSE.PUBLIC)) (SETQ TAGTYPE (PARSE.TAGTYPE)) (SETQ ANSWER (LIST 'vcasehead IDENT PUBLIC TAGTYPE))) (T (SETQ ANSWER (LIST 'vcasehead (PARSE.BIN) (PARSE.TAGTYPE] (RETURN ANSWER]) (PARSE.TAGTYPE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (tagtype *) (tagtype typeexp) *) (COND ((EQ PARSE.ATOM '*) (PARSE.BIN)) (T (PARSE.TYPEEXP]) (PARSE.VARIANTITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (IDLIST RECLIST ANSWER) (* (variantitem idlist => reclist) *) (SETQ IDLIST (PARSE.IDLIST)) (PARSE.BIN '=>) (SETQ RECLIST (PARSE.RECLIST)) (SETQ ANSWER (LIST 'variantitem IDLIST RECLIST)) (RETURN ANSWER]) (PARSE.TYPELIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPEITEMS ANSWER) (* (typelist typecons default)  (typelist typeid default)  (typelist id) (typelist id _  defaultopt) (typelist typecons default  %, typelist) (typelist typeid default  %, typelist) (typelist id %, typelist)  (typelist id _ defaultopt %, typelist)  *) (push TYPEITEMS (PARSE.TYPEITEM)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push TYPEITEMS (PARSE.TYPEITEM))) (SETQ ANSWER (create TYPELIST ITEMS _ (DREVERSE TYPEITEMS))) (RETURN ANSWER]) (PARSE.TYPEITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPEEXP DEFAULT ANSWER) (SETQ TYPEEXP (PARSE.TYPEEXP)) [COND ((NOT (LITATOM TYPEEXP)) (SETQ DEFAULT (PARSE.DEFAULT))) ((EQ PARSE.ATOM '_) (SETQ DEFAULT (PARSE.DEFAULTOPT] (SETQ ANSWER (create TYPEITEM TYPEEXP _ TYPEEXP DEFAULT _ DEFAULT)) (RETURN ANSWER]) (PARSE.POINTERTYPE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TYPE ANSWER) (* (pointertype pointerprefix)  (pointertype pointerprefix TO readonly  typeexp) *) (PARSE.POINTERPREFIX) [COND ((EQ PARSE.ATOM 'TO) (PARSE.BIN) (PARSE.READONLY) (SETQ TYPE (PARSE.TYPEEXP))) (T (SETQ TYPE 'UNSPECIFIED] (SETQ ANSWER (create MPOINTER TYPE _ TYPE)) (RETURN ANSWER]) (PARSE.TRANSFERMODE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (transfermode PROCEDURE)  (transfermode PROC) (transfermode PORT)  (transfermode SIGNAL)  (transfermode ERROR)  (transfermode PROCESS)  (transfermode PROGRAM) *) (PROG NIL (PARSE.BIN) (RETURN 'PROC]) (PARSE.INITIALIZATION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (initialization) (initialization _  initvalue) (initialization tilde  initvalue) *) (* In MESA tilde must be =.  *) [COND ([OR (FMEMB PARSE.ATOM '(_ =)) (AND (EQ PARSE.LANGUAGE 'CEDAR) (EQ PARSE.ATOM '~] (PARSE.BIN) (SETQ ANSWER (PARSE.INITVALUE] (RETURN ANSWER]) (PARSE.INITVALUE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (INLINE BLOCK CODELIST EXP ANSWER) (* (initvalue procaccess trusted  checked inline block)  (initvalue CODE) (initvalue procaccess  trusted checked MACHINE CODE BEGIN  codelist END) (initvalue procaccess  trusted checked MACHINE CODE {  codelist }) (initvalue TRASH)  (initvalue NULL) (initvalue exp) *) [COND ((FMEMB PARSE.ATOM '(CODE TRASH NULL)) (PARSE.BIN) (SETQ ANSWER 'TRASH)) (T (PARSE.CHECKED) (COND ((FMEMB PARSE.ATOM '(INLINE BEGIN {)) (SETQ INLINE (PARSE.INLINE)) (SETQ BLOCK (PARSE.BLOCK)) (SETQ ANSWER BLOCK)) ((EQ PARSE.ATOM 'MACHINE) (PARSE.BIN) (PARSE.BIN 'CODE) (PARSE.BIN '(BEGIN {)) (SETQ CODELIST (PARSE.CODELIST)) (PARSE.BIN '(END })) (SETQ ANSWER CODELIST)) (T (SETQ EXP (PARSE.EXP)) (SETQ ANSWER EXP] (RETURN ANSWER]) (PARSE.CHECKED [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* BOTH (checked) *) (* CEDAR (checked CHECKED)  (checked TRUSTED) (checked UNCHECKED)  *) (COND ((FMEMB PARSE.ATOM '(CHECKED TRUSTED UNCHECKED)) (PARSE.THISIS.CEDAR) (PARSE.BIN]) (PARSE.CODELIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG NIL (* (codelist orderlist)  (codelist codelist ;  orderlist) *) (BREAK1 NIL T]) (PARSE.STATEMENT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (COND ((FMEMB PARSE.CLASS '(ID %()) (PARSE.STATEMENT1)) (T (PARSE.STATEMENT2]) (PARSE.STATEMENT1 [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (LHS EXP OPTCATCH ANSWER) (* (statement lhs) (statement lhs _  exp) (statement free %[ exp optcatch  %]) (statement lhs _ STATE) *) (SETQ LHS (PARSE.LHS)) (COND ((AND (EQ PARSE.ATOM '%.) (EQ PARSE.ATOM2 'FREE)) (PARSE.BIN) (PARSE.BIN) (PARSE.BIN '%[) (SETQ EXP (PARSE.EXP)) (SETQ OPTCATCH (PARSE.OPTCATCH)) (PARSE.BIN '%]) (SETQ ANSWER (LIST LHS EXP OPTCATCH))) ((AND (EQ PARSE.ATOM '_) (EQ PARSE.ATOM2 'STATE)) (PARSE.BIN) (PARSE.BIN) (SETQ ANSWER LHS)) ((EQ PARSE.ATOM '_) (PARSE.BIN) (SETQ EXP (PARSE.EXP)) (SETQ ANSWER (BUILD.SETQ LHS EXP))) (T (SETQ ANSWER LHS))) (RETURN ANSWER]) (PARSE.STATEMENT2 [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (statement %[ explist %] _ exp) (statement trusted checked block)  (statement IF exp THEN statement elsepart)  (statement casehead casestmtlist ENDCASE otherpart)  (statement forclause dotest DO scope doexit ENDLOOP)  (statement EXIT) (statement LOOP) (statement GOTO id)  (statement GO TO id) (statement RETURN optargs)  (statement transfer lhs) (statement WAIT lhs)  (statement ERROR) (statement STOP) (statement NULL)  (statement RESUME optargs) (statement REJECT)  (statement CONTINUE) (statement RETRY) *) [SETQ ANSWER (COND ((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST) (PARSE.STATEMENT.CASEHEAD)) ((OR (FMEMB PARSE.ATOM PARSE.FORCLAUSE.FIRST) (FMEMB PARSE.ATOM PARSE.DOTEST.FIRST) (EQ PARSE.ATOM 'DO)) (PARSE.STATEMENT.FORCLAUSE)) ([AND (EQ PARSE.ATOM 'RETURN) (NOT (EQ PARSE.ATOM2 'WITH] (* Don't confuse statement RETURN with the transfer RETURN WITH.  *) (PARSE.STATEMENT.RETURN)) ((FMEMB PARSE.ATOM PARSE.TRANSFER.FIRST) (PARSE.STATEMENT.TRANSFER)) (T (SELECTQ PARSE.ATOM (%[ (PARSE.STATEMENT.LBRACKET)) (({ BEGIN CHECKED TRUSTED UNCHECKED) (PARSE.CHECKED) (PARSE.BLOCK)) (IF (PARSE.STATEMENT.IF)) (EXIT (PARSE.BIN) '(RETURN)) (LOOP (PARSE.BIN) '(GO LOOP)) (GOTO (PARSE.BIN) (LIST 'GO (PARSE.BIN 'ID))) (GO (PARSE.BIN) (PARSE.BIN 'TO) (LIST 'GO (PARSE.BIN 'ID))) (WAIT (PARSE.BIN) (PARSE.LHS)) (ERROR (PARSE.BIN) '(SHOULDNT)) (STOP (PARSE.BIN) '(GO STOP)) (NULL (PARSE.BIN) NIL) (RESUME (PARSE.BIN) (PARSE.OPTARGS)) (REJECT (PARSE.BIN) '(SHOULDNT)) (CONTINUE (PARSE.BIN) '(GO CONTINUE)) (RETRY (PARSE.BIN) '(GO RETRY)) (SHOULDNT] (RETURN ANSWER]) (PARSE.STATEMENT.CASEHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (CASEHEAD CASESTMTLIST OTHERPART ANSWER) (* (statement casehead casestmtlist  ENDCASE otherpart) *) (BUILD.PUSH.SCOPE) (SETQ CASEHEAD (PARSE.CASEHEAD)) (SETQ CASESTMTLIST (PARSE.CASESTMTLIST CASEHEAD)) (PARSE.BIN 'ENDCASE) (SETQ OTHERPART (PARSE.OTHERPART)) (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASESTMTLIST OTHERPART)) (COND ((fetch (CASEHEAD ID) of CASEHEAD) (BUILD.INITIALIZE.VAR (fetch (CASEHEAD ID) of CASEHEAD) NIL (fetch (CASEHEAD EXP) of CASEHEAD) BUILD.CURRENT.SCOPE))) (SETQ ANSWER (BUILD.PROG (LIST ANSWER))) (BUILD.POP.SCOPE) (RETURN ANSWER]) (PARSE.STATEMENT.FORCLAUSE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (FORCLAUSE DOTEST SCOPE DOEXIT EXITLIST STATEMENT ANSWER) (* (statement forclause dotest DO  scope doexit ENDLOOP) *) (BUILD.STORE.IDENTLIST '(DO)) (BUILD.PUSH.SCOPE) (SETQ FORCLAUSE (PARSE.FORCLAUSE)) (SETQ DOTEST (PARSE.DOTEST)) (PARSE.BIN 'DO) (SETQ SCOPE (PARSE.SCOPE)) (SETQ DOEXIT (PARSE.DOEXIT)) (SETQ EXITLIST (CAR DOEXIT)) (SETQ STATEMENT (CADR DOEXIT)) (PARSE.BIN 'ENDLOOP) (BUILD.POP.SCOPE) [SETQ ANSWER `(,@FORCLAUSE ,@DOTEST do ,@(BUILD.TAIL SCOPE] [COND (STATEMENT (SETQ ANSWER `(,@ANSWER finally ,@(BUILD.TAIL STATEMENT] [COND (EXITLIST (SETQ ANSWER (BUILD.PROGN (CONS ANSWER EXITLIST] (RETURN ANSWER]) (PARSE.STATEMENT.RETURN [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (OPTARGS ANSWER) (* (statement RETURN optargs) *) (PARSE.BIN 'RETURN) (SETQ OPTARGS (PARSE.OPTARGS)) (SETQ ANSWER (BUILD.RETURN OPTARGS)) (RETURN ANSWER]) (PARSE.STATEMENT.TRANSFER [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TRANSFER LHS ANSWER) (* (statement transfer lhs) *) (SETQ TRANSFER (PARSE.TRANSFER)) (SETQ LHS (PARSE.LHS)) [SETQ ANSWER `(SHOULDNT ',LHS] (RETURN ANSWER]) (PARSE.STATEMENT.LBRACKET [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXPLIST EXP ANSWER) (* (statement %[ explist %] _ exp) *) (PARSE.BIN '%[) (SETQ EXPLIST (PARSE.EXPLIST)) (PARSE.BIN '%]) (PARSE.BIN '_) (SETQ EXP (PARSE.EXP)) (SETQ ANSWER (BUILD.SETQ EXPLIST EXP)) (RETURN ANSWER]) (PARSE.STATEMENT.IF [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXP STATEMENT ELSEPART HEAD TAIL ANSWER) (* (statement IF exp THEN statement  elsepart) *) (PARSE.BIN 'IF) (SETQ EXP (PARSE.EXP)) (PARSE.BIN 'THEN) (SETQ STATEMENT (PARSE.STATEMENT)) (SETQ ELSEPART (PARSE.ELSEPART)) (SETQ ANSWER (BUILD.COND EXP STATEMENT ELSEPART)) (RETURN ANSWER]) (PARSE.BLOCK [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (SCOPE EXITS ANSWER) (* (block BEGIN scope exits END)  (block { scope exits }) *) (BUILD.PUSH.SCOPE) (PARSE.BIN '(BEGIN {)) (SETQ SCOPE (PARSE.SCOPE)) (SETQ EXITS (PARSE.EXITS)) (PARSE.BIN '(END })) (BUILD.POP.SCOPE) (SETQ ANSWER (APPEND SCOPE EXITS)) (RETURN ANSWER]) (PARSE.SCOPE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (STATEMENTLIST ANSWER) (* (scope open enables statementlist)  (scope open enables declist ;  statementlist) *) (BUILD.STORE.OPEN (PARSE.OPEN)) (PARSE.ENABLES) (COND ([AND (EQ PARSE.CLASS 'ID) (FMEMB PARSE.ATOM2 '(%, %:] (PARSE.DECLIST))) (SETQ STATEMENTLIST (PARSE.STATEMENTLIST)) (SETQ ANSWER (BUILD.PROG STATEMENTLIST)) (RETURN ANSWER]) (PARSE.BINDITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID EXP ANSWER) (* BOTH (binditem exp)  (binditem id %: exp) *) (* CEDAR (binditem id ~ ~ exp) *) [COND ((AND (EQ PARSE.CLASS 'ID) (EQ PARSE.ATOM2 '%:)) (SETQ ID (PARSE.BIN)) (PARSE.BIN)) ((AND (EQ PARSE.LANGUAGE 'CEDAR) (EQ PARSE.CLASS 'ID) (EQ PARSE.ATOM2 '~)) (SETQ ID (PARSE.BIN)) (PARSE.BIN) (PARSE.BIN '~] (SETQ EXP (PARSE.EXP)) (SETQ ANSWER (create BINDITEM ID _ ID EXP _ EXP)) (RETURN ANSWER]) (PARSE.EXITS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (exits EXITS exitlist)  (exits) *) (COND ((EQ PARSE.ATOM 'EXITS) (PARSE.BIN) (PARSE.EXITLIST]) (PARSE.CASESTMTITEM [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:47") (PROG (CASELABEL STATEMENT ANSWER) (* (casestmtitem caselabel =>  statement) *) (SETQ CASELABEL (PARSE.CASELABEL)) (PARSE.BIN '=>) (SETQ STATEMENT (PARSE.STATEMENT)) (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL STATEMENT))) (RETURN ANSWER]) (PARSE.CASEEXPITEM [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:47") (PROG (CASELABEL EXP ANSWER) (* (caseexpitem caselabel => exp) *) (SETQ CASELABEL (PARSE.CASELABEL)) (PARSE.BIN '=>) (SETQ EXP (PARSE.EXP)) (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL EXP))) (RETURN ANSWER]) (PARSE.EXITITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (IDLIST STATEMENT ANSWER) (* (exititem idlist => statement) *) (SETQ IDLIST (PARSE.IDLIST)) (PARSE.BIN '=>) (SETQ STATEMENT (PARSE.STATEMENT)) [SETQ ANSWER (BUILD.PROGN (NCONC IDLIST (BUILD.TAIL STATEMENT] (RETURN ANSWER]) (PARSE.CASETEST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (OPTRELATION EXP ANSWER) (* (casetest optrelation)  (casetest exp) *) (COND ((FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST) (SETQ OPTRELATION (PARSE.OPTRELATION)) (SETQ ANSWER OPTRELATION)) (T (SETQ EXP (PARSE.EXP)) (SETQ ANSWER EXP))) (RETURN ANSWER]) (PARSE.CONTROLID [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID TYPEEXP) (* (controlid ident typeexp)  (controlid id) *) [COND ((FMEMB PARSE.ATOM2 PARSE.CONTROLID.FOLLOW) (SETQ ID (PARSE.BIN 'ID)) (SETQ TYPEEXP 'INTEGER)) (T (SETQ ID (PARSE.IDENT)) (SETQ TYPEEXP (PARSE.TYPEEXP] (BUILD.INITIALIZE.VAR ID TYPEEXP NIL BUILD.CURRENT.SCOPE) (RETURN ID]) (PARSE.FORCLAUSE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (CONTROLID EXP1 EXP2 DIRECTION RANGE ANSWER) (* (forclause FOR controlid _ exp %,  exp) (forclause FOR controlid  direction IN range) (forclause THROUGH  range) (forclause) *) [COND [(EQ PARSE.ATOM 'FOR) (PARSE.BIN) (SETQ CONTROLID (PARSE.CONTROLID)) (COND ((EQ PARSE.ATOM '_) (PARSE.BIN) (SETQ EXP1 (PARSE.EXP)) (PARSE.BIN '%,) (SETQ EXP2 (PARSE.EXP)) (SETQ ANSWER (BUILD.FORCLAUSE.BY CONTROLID EXP1 EXP2))) (T (SETQ DIRECTION (PARSE.DIRECTION)) (PARSE.BIN 'IN) (SETQ RANGE (PARSE.RANGE)) (SETQ ANSWER (BUILD.FORCLAUSE.IN CONTROLID DIRECTION RANGE] ((EQ PARSE.ATOM 'THROUGH) (PARSE.BIN) (SETQ RANGE (PARSE.RANGE)) (SETQ ANSWER (BUILD.FORCLAUSE.THROUGH RANGE] (RETURN ANSWER]) (PARSE.DIRECTION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (direction DECREASING)  (direction) *) (COND ((EQ PARSE.ATOM 'DECREASING) (PARSE.BIN]) (PARSE.DOTEST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (dotest UNTIL exp)  (dotest WHILE exp) (dotest) *) (COND ((EQ PARSE.ATOM 'UNTIL) (PARSE.BIN) (LIST 'until (PARSE.EXP))) ((EQ PARSE.ATOM 'WHILE) (PARSE.BIN) (LIST 'while (PARSE.EXP]) (PARSE.DOEXIT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXITLIST STATEMENT ANSWER) (* (doexit) (doexit REPEAT exitlist)  (doexit REPEAT exitlist FINISHED =>  statement) (doexit REPEAT exitlist  FINISHED => statement ;) *) [COND ((EQ PARSE.ATOM 'REPEAT) (PARSE.BIN) (SETQ EXITLIST (PARSE.EXITLIST)) (COND ((EQ PARSE.ATOM 'FINISHED) (PARSE.BIN) (PARSE.BIN '=>) (SETQ STATEMENT (PARSE.STATEMENT)) (COND ((EQ PARSE.ATOM ';) (PARSE.BIN] (SETQ ANSWER (LIST EXITLIST STATEMENT)) (RETURN ANSWER]) (PARSE.ENABLES [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (CATCHCASE CATCHANY CATCHLIST ANSWER) (* (enables ENABLE catchcase ;)  (enables ENABLE catchany ;)  (enables ENABLE BEGIN catchlist END ;)  (enables ENABLE { catchlist } ;)  (enables) *) [COND ((EQ PARSE.ATOM 'ENABLE) (PARSE.BIN) [COND ((EQ PARSE.ATOM 'ANY) (SETQ CATCHANY (PARSE.CATCHANY)) (SETQ ANSWER (LIST CATCHANY))) ((FMEMB PARSE.ATOM '(BEGIN {)) (PARSE.BIN) (SETQ CATCHLIST (PARSE.CATCHLIST)) (PARSE.BIN '(END })) (SETQ ANSWER CATCHLIST)) (T (SETQ CATCHCASE (PARSE.CATCHCASE)) (SETQ ANSWER (LIST CATCHCASE] (PARSE.BIN ';] (RETURN ANSWER]) (PARSE.CATCHLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (CATCHHEAD CATCHANY CATCHCASE ANSWER) (* (catchlist catchhead)  (catchlist catchhead catchcase)  (catchlist catchhead catchany)  (catchlist catchhead catchany ;) *) (SETQ CATCHHEAD (PARSE.CATCHHEAD)) [COND ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW) (SETQ ANSWER CATCHHEAD)) [(EQ PARSE.ATOM 'ANY) (SETQ CATCHANY (PARSE.CATCHANY)) (SETQ ANSWER (NCONC1 CATCHHEAD CATCHANY)) (COND ((EQ PARSE.ATOM ';) (PARSE.BIN] (T (SETQ CATCHCASE (PARSE.CATCHCASE)) (SETQ ANSWER (NCONC1 CATCHHEAD CATCHCASE] (RETURN ANSWER]) (PARSE.CATCHCASE [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (LHSLIST STATEMENT ANSWER) (* (catchcase lhslist => statement) *) (SETQ LHSLIST (PARSE.LHSLIST)) (PARSE.BIN '=>) (SETQ STATEMENT (PARSE.STATEMENT)) (SETQ ANSWER (LIST 'catchcase LHSLIST STATEMENT)) (RETURN ANSWER]) (PARSE.OPTARGS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (optargs %[ explist %])  (optargs) (optargs lhs) *) [COND ((EQ PARSE.ATOM '%[) (PARSE.BIN '%[) (SETQ ANSWER (PARSE.EXPLIST)) (PARSE.BIN '%])) ((NOT (FMEMB PARSE.ATOM PARSE.OPTARGS.FOLLOW)) (SETQ ANSWER (LIST (PARSE.LHS] (RETURN ANSWER]) (PARSE.TRANSFER [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (transfer SIGNAL) (transfer ERROR) (transfer RETURN WITH ERROR)  (transfer START) (transfer RESTART) (transfer JOIN)  (transfer NOTIFY) (transfer BROADCAST) (transfer TRANSFER WITH)  (transfer RETURN WITH) *) (COND [(EQ PARSE.ATOM 'RETURN) (PARSE.BIN) (PARSE.BIN 'WITH) (COND ((EQ PARSE.ATOM 'ERROR) 'SHOULDNT) (T 'RETURN] ((EQ PARSE.ATOM 'TRANSFER) (PARSE.BIN) (PARSE.BIN 'WITH) 'RETURN) (T (PARSE.BIN]) (PARSE.KEYITEM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ID OPTEXP ANSWER) (* BOTH (keyitem id %: optexp) *) (* CEDAR (keyitem id ~ optexp) *) (SETQ ID (PARSE.BIN 'ID)) (COND ((EQ PARSE.ATOM '%:) (PARSE.BIN)) ((AND (EQ PARSE.LANGUAGE 'CEDAR) (EQ PARSE.ATOM '~)) (PARSE.BIN)) (T (SHOULDNT))) (SETQ OPTEXP (PARSE.OPTEXP)) (SETQ ANSWER (create KEYITEM ID _ ID OPTEXP _ OPTEXP)) (RETURN ANSWER]) (PARSE.OPTEXP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (ANSWER) (* (optexp TRASH) (optexp NULL)  (optexp exp) (optexp) *) [SETQ ANSWER (COND ((FMEMB PARSE.ATOM '(NULL TRASH)) (PARSE.BIN) 'TRASH) ((FMEMB PARSE.ATOM PARSE.OPTEXP.FOLLOW) 'TRASH) (T (PARSE.EXP] (RETURN ANSWER]) (PARSE.EXP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (COND ((EQ PARSE.CLASS 'ID) (PARSE.EXP1)) (T (PARSE.EXP2]) (PARSE.EXP1 [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* First token of EXP is ID.  *) (PROG (DISJUNCT EXP ANSWER) (* (exp lhs _ exp) (exp disjunct) *) (SETQ DISJUNCT (PARSE.DISJUNCT)) (COND ((EQ PARSE.ATOM '_) (PARSE.BIN) (SETQ EXP (PARSE.EXP)) (SETQ ANSWER (BUILD.SETQ DISJUNCT EXP))) (T (SETQ ANSWER DISJUNCT))) (RETURN ANSWER]) (PARSE.EXP2 [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* First token of EXP is not ID.  *) (PROG (DISJUNCT ANSWER) (* (exp transferop lhs)  (exp IF exp THEN exp ELSE exp)  (exp casehead caseexplist ENDCASE =>  exp) (exp lhs _ exp)  (exp %[ explist %] _ exp)  (exp ERROR) (exp disjunct) *) [SETQ ANSWER (COND ([AND (FMEMB PARSE.ATOM PARSE.TRANSFEROP.FIRST) (OR (NOT (EQ PARSE.ATOM 'NEW)) (NOT (EQ PARSE.ATOM2 '%[] (* Don't confuse with  (primary new %[ typeexp initialization  optcatch %]) *) (PARSE.EXP.TRANSFEROP)) ((EQ PARSE.ATOM 'IF) (PARSE.EXP.IF)) ((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST) (PARSE.EXP.CASEHEAD)) ((EQ PARSE.ATOM) (PARSE.EXP.LBRACKET '%[)) ((EQ PARSE.ATOM 'ERROR) (PARSE.EXP.ERROR)) ((NUMBERP PARSE.ATOM) (PARSE.EXP.DISJUNCT)) ((STRINGP PARSE.ATOM) (PARSE.EXP.DISJUNCT)) ((FMEMB PARSE.ATOM '(ABS ALL BASE DESCRIPTOR FIRST ISTYPE LAST LENGTH LONG MAX MIN NILL NOT ORD PRED SIZE SUCC VAL + - @ %[)) (PARSE.EXP.DISJUNCT)) (T (PROGN (SETQ DISJUNCT (PARSE.EXP.DISJUNCT)) (COND ((EQ PARSE.ATOM '_) (PARSE.BIN) (BUILD.SETQ DISJUNCT (PARSE.EXP))) (T DISJUNCT] (RETURN ANSWER]) (PARSE.EXP.TRANSFEROP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (TRANSFEROP LHS ANSWER) (* (exp transferop lhs) *) (SETQ TRANSFEROP (PARSE.TRANSFEROP)) (SETQ LHS (PARSE.LHS)) [SETQ ANSWER `(SHOULDNT ',LHS] (RETURN ANSWER]) (PARSE.EXP.IF [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXP1 EXP2 EXP3 ANSWER) (* (exp IF exp THEN exp ELSE exp) *) (PARSE.BIN 'IF) (SETQ EXP1 (PARSE.EXP)) (PARSE.BIN 'THEN) (SETQ EXP2 (PARSE.EXP)) (PARSE.BIN 'ELSE) (SETQ EXP3 (PARSE.EXP)) (SETQ ANSWER (BUILD.COND EXP1 EXP2 EXP3)) (RETURN ANSWER]) (PARSE.EXP.CASEHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (CASEHEAD CASEEXPLIST EXP ANSWER) (* (exp casehead caseexplist ENDCASE  => exp) *) (SETQ CASEHEAD (PARSE.CASEHEAD)) (SETQ CASEEXPLIST (PARSE.CASEEXPLIST)) (PARSE.BIN 'ENDCASE) (PARSE.BIN '=>) (SETQ EXP (PARSE.EXP)) (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASEEXPLIST EXP)) (RETURN ANSWER]) (PARSE.EXP.LHS [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (LHS EXP ANSWER) (* (exp lhs _ exp) *) (SETQ LHS (PARSE.LHS)) (PARSE.BIN '_) (SETQ EXP (PARSE.EXP)) [SETQ ANSWER `(SETQ ,LHS ,EXP] (RETURN ANSWER]) (PARSE.EXP.LBRACKET [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (EXPLIST EXP ANSWER) (* (exp %[ explist %] _ exp) *) (PARSE.BIN '%[) (SETQ EXPLIST (PARSE.EXPLIST)) (PARSE.BIN '%]) (PARSE.BIN '_) (SETQ EXP (PARSE.EXP)) [SETQ ANSWER `(SETQ ,EXPLIST ,EXP] (RETURN ANSWER]) (PARSE.EXP.ERROR [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (exp ERROR) *) (PARSE.BIN 'ERROR) '(SHOULDNT]) (PARSE.EXP.DISJUNCT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (exp disjunct) *) (PARSE.DISJUNCT]) (PARSE.DISJUNCT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (CONJUNCTS ANSWER) (* (disjunct disjunct OR conjunct)  (disjunct conjunct) *) (push CONJUNCTS (PARSE.CONJUNCT)) (while (EQ PARSE.ATOM 'OR) do (PARSE.BIN) (push CONJUNCTS (PARSE.CONJUNCT))) [SETQ ANSWER (COND ((CDR CONJUNCTS) (CONS 'OR (DREVERSE CONJUNCTS))) (T (CAR CONJUNCTS] (RETURN ANSWER]) (PARSE.CONJUNCT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (NEGATIONS ANSWER) (* (conjunct conjunct AND negation)  (conjunct negation) *) (push NEGATIONS (PARSE.NEGATION)) (while (EQ PARSE.ATOM 'AND) do (PARSE.BIN) (push NEGATIONS (PARSE.NEGATION))) [SETQ ANSWER (COND ((CDR NEGATIONS) (CONS 'AND (DREVERSE NEGATIONS))) (T (CAR NEGATIONS] (RETURN ANSWER]) (PARSE.NEGATION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (NOT ANSWER) (* (negation not relation)  (negation relation) *) [COND ((FMEMB PARSE.ATOM PARSE.NOTS) (SETQ NOT (PARSE.NOT] (SETQ ANSWER (PARSE.RELATION)) [COND (NOT (SETQ ANSWER `(NOT ,ANSWER] (RETURN ANSWER]) (PARSE.RELATION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (SUM OPTRELATION NOT ANSWER) (* (relation sum optrelation)  (relation sum) *) (SETQ SUM (PARSE.SUM)) (COND ((NOT (FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST)) (RETURN SUM))) (SETQ OPTRELATION (PARSE.OPTRELATION)) [COND ((EQ (CAR OPTRELATION) 'NOT) (SETQ NOT T) (SETQ OPTRELATION (CADR OPTRELATION] [SETQ ANSWER (COND ((EQ (CAR OPTRELATION) 'IN) (BUILD.IN SUM (CADR OPTRELATION))) (T (BUILD.ARITH.EXP2 (CAR OPTRELATION) SUM (CADR OPTRELATION] [COND (NOT (SETQ ANSWER (LIST 'NOT ANSWER] (RETURN ANSWER]) (PARSE.SUM [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (PRODUCTS PRODUCT ANSWER) (* (sum sum addop product)  (sum product) *) (SETQ PRODUCT (PARSE.PRODUCT)) [while (FMEMB PARSE.ATOM PARSE.ADDOPS) do (COND ((EQ PARSE.ATOM '+) (PARSE.BIN) (push PRODUCTS PRODUCT) (SETQ PRODUCT (PARSE.PRODUCT))) [(EQ PARSE.ATOM '-) (PARSE.BIN) (SETQ PRODUCT (BUILD.ARITH.EXP2 '- PRODUCT (PARSE.PRODUCT] (T (SHOULDNT] (push PRODUCTS PRODUCT) [SETQ ANSWER (COND ((CDR PRODUCTS) (BUILD.ARITH.EXP* '+ (DREVERSE PRODUCTS))) (T (CAR PRODUCTS] (RETURN ANSWER]) (PARSE.PRODUCT [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (FACTORS FACTOR ANSWER) (* (product product multop factor)  (product factor) *) (SETQ FACTOR (PARSE.FACTOR)) [while (FMEMB PARSE.ATOM PARSE.MULTOPS) do (COND ((EQ PARSE.ATOM '*) (PARSE.BIN) (push FACTORS FACTOR) (SETQ FACTOR (PARSE.FACTOR))) [(EQ PARSE.ATOM '/) (PARSE.BIN) (SETQ FACTOR (BUILD.ARITH.EXP2 '/ FACTOR (PARSE.FACTOR] [(EQ PARSE.ATOM 'MOD) (PARSE.BIN) (SETQ FACTOR (BUILD.ARITH.EXP2 'MOD FACTOR (PARSE.FACTOR] (T (SHOULDNT] (push FACTORS FACTOR) [SETQ ANSWER (COND ((CDR FACTORS) (BUILD.ARITH.EXP* '* (DREVERSE FACTORS))) (T (CAR FACTORS] (RETURN ANSWER]) (PARSE.OPTRELATION [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (NOT ANSWER) (* (optrelation not relationtail)  (optrelation relationtail) *) (* In CEDAR, not must be NOT.  *) [COND ([OR (EQ PARSE.ATOM 'NOT) (AND (EQ PARSE.LANGUAGE 'MESA) (EQ PARSE.ATOM '~] (SETQ NOT (PARSE.NOT] (SETQ ANSWER (PARSE.RELATIONTAIL)) [COND (NOT (SETQ ANSWER (LIST 'NOT ANSWER] (RETURN ANSWER]) (PARSE.RELATIONTAIL [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (PROG (RANGE RELOP SUM ANSWER) (* (relationtail IN range)  (relationtail relop sum) *) [COND ((EQ PARSE.ATOM 'IN) (PARSE.BIN) (SETQ RANGE (PARSE.RANGE)) (SETQ ANSWER (LIST 'IN RANGE))) (T (SETQ RELOP (PARSE.RELOP)) (SETQ SUM (PARSE.SUM)) (SETQ ANSWER (LIST RELOP SUM] (RETURN ANSWER]) (PARSE.RELOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (relop =) (relop %#)  (relop <) (relop <=)  (relop >) (relop >=) *) (PARSE.BIN]) (PARSE.ADDOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") (* (addop +) (addop -) *) (PARSE.BIN]) (PARSE.MULTOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (multop *) (multop /)  (multop MOD) *) (PARSE.BIN]) (PARSE.FACTOR [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ADDOP PRIMARY ANSWER) (* (factor addop primary)  (factor primary) *) [COND ((FMEMB PARSE.ATOM PARSE.ADDOPS) (SETQ ADDOP (PARSE.BIN] (SETQ ANSWER (PARSE.PRIMARY)) [COND ((EQ ADDOP '-) (SETQ ANSWER (BUILD.ARITH.EXP1 '- ANSWER] (RETURN ANSWER]) (PARSE.PRIMARY [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ANSWER LHS) (* BOTH (primary num) (primary lnum) (primary flnum)  (primary string) (primary lstring) (primary atom)  (primary NIL) (primary %[ explist %]) (primary prefixop %[ orderlist %])  (primary VAL %[ orderlist %]) (primary ALL %[ orderlist %])  (primary new %[ typeexp initialization optcatch %])  (primary typeop %[ typeexp %]) (primary SIZE %[ typeexp %])  (primary SIZE %[ typeexp %, exp %]) (primary ISTYPE %[ exp %, typeexp %])  (primary @ lhs) (primary DESCRIPTOR %[ desclist %])  (primary lhs) *) (* CEDAR (primary cons %[ explist  optcatch %]) (primary listcons %[  explist %]) *) (* In CEDAR, new can be NEW.  *) [SETQ ANSWER (COND ((EQ PARSE.CLASS 'CHAR) (BUILD.CHARCODE (PARSE.BIN))) ((NUMBERP PARSE.ATOM) (PARSE.BIN)) ((STRINGP PARSE.ATOM) (PARSE.BIN)) ((FMEMB PARSE.ATOM PARSE.PREFIXOP.FIRST) (PARSE.PRIMARY.PREFIXOP)) ((AND [OR (FMEMB PARSE.ATOM PARSE.TYPEOP.FIRST) (AND (EQ PARSE.LANGUAGE 'CEDAR) (EQ PARSE.ATOM 'CODE] (EQ PARSE.ATOM2 '%[)) (PARSE.PRIMARY.TYPEOP)) (T (SELECTQ PARSE.ATOM ($ (PARSE.ATOM)) (NILL (PARSE.PRIMARY.NIL)) (%[ (PARSE.PRIMARY.LBRACKET)) (VAL (PARSE.PRIMARY.VAL)) (ALL (PARSE.PRIMARY.ALL)) (SIZE (PARSE.PRIMARY.SIZE)) (ISTYPE (PARSE.PRIMARY.ISTYPE)) (@ (PARSE.PRIMARY.AT)) (DESCRIPTOR (PARSE.PRIMARY.DESCRIPTOR)) (NEW (PARSE.PRIMARY.NEW)) (CONS (PARSE.PRIMARY.CONS)) (LIST (PARSE.PRIMARY.LIST)) (PARSE.PRIMARY.LHS] (RETURN ANSWER]) (PARSE.ATOM [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (atom $ id) *) (PARSE.BIN '$) `',(PARSE.BIN 'ID]) (PARSE.PRIMARY.NIL [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (primary NIL) *) (PARSE.BIN 'NILL) NIL]) (PARSE.PRIMARY.LBRACKET [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ANSWER) (* (primary %[ explist %]) *) (PARSE.BIN '%[) (SETQ ANSWER (PARSE.EXPLIST)) (PARSE.BIN '%]) (RETURN ANSWER]) (PARSE.PRIMARY.PREFIXOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (PREFIXOP ORDERLIST ANSWER) (* (primary prefixop %[ orderlist %])  *) (SETQ PREFIXOP (PARSE.PREFIXOP)) (PARSE.BIN '%[) (SETQ ORDERLIST (PARSE.ORDERLIST)) (PARSE.BIN '%]) (SETQ ANSWER (CONS PREFIXOP (fetch (ORDERLIST ITEMS) of ORDERLIST))) (RETURN ANSWER]) (PARSE.PRIMARY.VAL [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ORDERLIST ANSWER) (* (primary VAL %[ orderlist %]) *) (PARSE.BIN 'VAL) (PARSE.BIN '%[) (SETQ ORDERLIST (PARSE.ORDERLIST)) (PARSE.BIN '%]) (SETQ ANSWER (CONS 'VAL (fetch (ORDERLIST ITEMS) of ORDERLIST))) (RETURN ANSWER]) (PARSE.PRIMARY.ALL [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ORDERLIST ANSWER) (* (primary ALL %[ orderlist %]) *) (PARSE.BIN 'ALL) (PARSE.BIN '%[) (SETQ ORDERLIST (PARSE.ORDERLIST)) (PARSE.BIN '%]) (SETQ ANSWER (CONS 'ALL (fetch (ORDERLIST ITEMS) of ORDERLIST))) (RETURN ANSWER]) (PARSE.PRIMARY.NEW [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (TYPEEXP INITIALIZATION ANSWER) (* (primary new %[ typeexp  initialization optcatch %]) *) (PARSE.NEW) (PARSE.BIN '%[) (SETQ TYPEEXP (PARSE.TYPEEXP)) (SETQ INITIALIZATION (PARSE.INITIALIZATION)) (PARSE.OPTCATCH) (PARSE.BIN '%]) (SETQ ANSWER (BUILD.NEW TYPEEXP INITIALIZATION)) (RETURN ANSWER]) (PARSE.PRIMARY.TYPEOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (TYPEOP TYPEEXP ANSWER) (* (primary typeop %[ typeexp %]) *) (SETQ TYPEOP (PARSE.TYPEOP)) (PARSE.BIN '%[) (SETQ TYPEEXP (PARSE.TYPEEXP)) (PARSE.BIN '%]) (SETQ ANSWER (LIST TYPEOP TYPEEXP)) (RETURN ANSWER]) (PARSE.PRIMARY.SIZE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (TYPEEXP EXP ANSWER) (* (primary SIZE %[ typeexp %])  (primary SIZE %[ typeexp %, exp %]) *) (PARSE.BIN 'SIZE) (PARSE.BIN '%[) (SETQ TYPEEXP (PARSE.TYPEEXP)) [COND ((NOT (EQ PARSE.ATOM '%,)) (PARSE.BIN '%]) (SETQ ANSWER (LIST 'SIZE TYPEEXP))) (T (PARSE.BIN) (SETQ EXP (PARSE.EXP)) (PARSE.BIN '%]) (SETQ ANSWER (LIST 'SIZE TYPEEXP EXP] (RETURN ANSWER]) (PARSE.PRIMARY.ISTYPE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (primary ISTYPE %[ exp %, typeexp  %]) *) (PROG (EXP TYPEEXP ANSWER) (PARSE.BIN 'ISTYPE) (PARSE.BIN '%[) (SETQ EXP (PARSE.EXP)) (PARSE.BIN '%,) (SETQ TYPEEXP (PARSE.TYPEEXP)) (PARSE.BIN '%]) (SETQ ANSWER (BUILD.ISTYPE EXP TYPEEXP)) (RETURN ANSWER]) (PARSE.PRIMARY.AT [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (LHS ANSWER) (* (primary @ lhs) *) (PARSE.BIN '@) (SETQ LHS (PARSE.LHS)) (SETQ ANSWER LHS) (RETURN ANSWER]) (PARSE.PRIMARY.DESCRIPTOR [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (DESCLIST ANSWER) (* (primary DESCRIPTOR %[ desclist %])  *) (PARSE.BIN 'DESCRIPTOR) (PARSE.BIN '%[) (SETQ DESCLIST (PARSE.DESCLIST)) (PARSE.BIN '%]) (SETQ ANSWER (CONS 'DESCRIPTOR DESCLIST)) (RETURN ANSWER]) (PARSE.PRIMARY.CONS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXPLIST ANSWER) (* CEDAR (primary CONS %[ explist  optcatch %]) *) (PARSE.THISIS.CEDAR) (PARSE.BIN 'CONS) (PARSE.BIN '%[) (SETQ EXPLIST (PARSE.EXPLIST)) (PARSE.OPTCATCH) (PARSE.BIN '%]) (SETQ ANSWER (CONS 'CONS (fetch (EXPLIST ITEMS) of EXPLIST))) (RETURN ANSWER]) (PARSE.PRIMARY.LIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXPLIST ANSWER) (* CEDAR (primary LIST %[ explist %])  *) (PARSE.THISIS.CEDAR) (PARSE.BIN 'LIST) (PARSE.BIN '%[) (SETQ EXPLIST (PARSE.EXPLIST)) (PARSE.BIN '%]) (SETQ ANSWER (CONS 'LIST (fetch (EXPLIST ITEMS) of EXPLIST))) (RETURN ANSWER]) (PARSE.PRIMARY.LHS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (LHS QUALIFIER ANSWER) (* BOTH (primary lhs)  (primary new %[ typeexp initialization  optcatch %]) *) (* CEDAR (primary cons %[ explist  optcatch %]) (primary listcons %[  explist %]) *) (SETQ LHS (PARSE.LHS)) (COND ([NOT (AND (EQ PARSE.ATOM '%.) (OR (EQ PARSE.ATOM2 'NEW) (AND (EQ PARSE.LANGUAGE 'CEDAR) (FMEMB PARSE.ATOM2 '(CONS LIST] (RETURN LHS))) (PARSE.BIN '%.) (SETQ ANSWER (SELECTQ PARSE.ATOM (NEW (PARSE.PRIMARY.LHS.NEW LHS)) (CONS (PARSE.PRIMARY.LHS.CONS LHS)) (LIST (PARSE.PRIMARY.LHS.LIST LHS)) (SHOULDNT))) (RETURN ANSWER]) (PARSE.PRIMARY.LHS.NEW [LAMBDA (LHS) (* kbr%: "25-Nov-85 12:48") (PROG (TYPEEXP INITIALIZATION ANSWER) (* (primary new %[ typeexp  initialization optcatch %]) *) (PARSE.BIN 'NEW) (PARSE.BIN '%[) (SETQ TYPEEXP (PARSE.TYPEEXP)) (SETQ INITIALIZATION (PARSE.INITIALIZATION)) (PARSE.OPTCATCH) (PARSE.BIN '%]) (SETQ ANSWER (LIST 'create LHS TYPEEXP INITIALIZATION)) (RETURN ANSWER]) (PARSE.PRIMARY.LHS.CONS [LAMBDA (LHS) (* kbr%: "25-Nov-85 12:48") (PROG (EXPLIST OPTCATCH ANSWER) (* CEDAR (primary cons %[ explist  optcatch %]) *) (PARSE.BIN 'CONS) (PARSE.BIN '%[) (SETQ EXPLIST (PARSE.EXPLIST)) (PARSE.OPTCATCH) (PARSE.BIN '%]) [SETQ ANSWER `(CONS ,LHS ,@EXPLIST] (RETURN ANSWER]) (PARSE.PRIMARY.LHS.LIST [LAMBDA (LHS) (* kbr%: "25-Nov-85 12:48") (PROG (EXPLIST OPTCATCH ANSWER) (* CEDAR (primary listcons %[ explist  %]) *) (PARSE.BIN 'LIST) (PARSE.BIN '%[) (SETQ EXPLIST (PARSE.EXPLIST)) (PARSE.BIN '%]) [SETQ ANSWER `(LIST ,LHS ,@EXPLIST] (RETURN ANSWER]) (PARSE.QUALIFIER [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ANSWER) (* (qualifier %. prefixop)  (qualifier %. typeop)  (qualifier %. SIZE) (qualifier %[  explist optcatch %])  (qualifier %. id) (qualifier ^) *) [COND [(EQ PARSE.ATOM '%.) (PARSE.BIN) (COND ((FMEMB PARSE.ATOM PARSE.PREFIXOPS) (SETQ ANSWER (PARSE.PREFIXOP))) ([OR (FMEMB PARSE.ATOM PARSE.TYPEOPS) (AND (EQ PARSE.LANGUAGE 'CEDAR) (EQ PARSE.ATOM 'CODE] (SETQ ANSWER (PARSE.TYPEOP))) ((EQ PARSE.ATOM 'SIZE) (SETQ ANSWER (PARSE.BIN))) ((EQ PARSE.ATOM 'FREE) (* (free lhs %. FREE) *) (SETQ ANSWER (PARSE.BIN))) ((EQ PARSE.ATOM 'NEW) (* (new lhs %. NEW) *) (SETQ ANSWER (PARSE.BIN))) ([AND (EQ PARSE.LANGUAGE 'CEDAR) (FMEMB PARSE.ATOM '(LIST CONS] (SETQ ANSWER (PARSE.BIN))) (T (SETQ ANSWER (PARSE.BIN 'ID] ((EQ PARSE.ATOM '%[) (PARSE.BIN) (SETQ ANSWER (PARSE.EXPLIST)) (PARSE.OPTCATCH) (PARSE.BIN '%])) (T (SETQ ANSWER (PARSE.BIN '^] (RETURN ANSWER]) (PARSE.LHS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXP1 EXP2 OPTTYPE ANSWER) (* (lhs id) (lhs char)  (lhs NARROW %[ exp opttype optcatch %])  (lhs LOOPHOLE %[ exp opttype %])  (lhs APPLY %[ exp %, exp optcatch %])  (lhs %( exp %)) (lhs lhs qualifier) *) [COND ((EQ PARSE.ATOM 'TRUE) (PARSE.BIN) (SETQ ANSWER T)) ((EQ PARSE.ATOM 'FALSE) (PARSE.BIN)) ((EQ PARSE.ATOM 'NARROW) (PARSE.BIN) (PARSE.BIN '%[) (SETQ EXP1 (PARSE.EXP)) (SETQ OPTTYPE (PARSE.OPTTYPE)) (PARSE.OPTCATCH) (PARSE.BIN '%]) (SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE))) ((EQ PARSE.ATOM 'LOOPHOLE) (PARSE.BIN) (PARSE.BIN '%[) (SETQ EXP1 (PARSE.EXP)) (SETQ OPTTYPE (PARSE.OPTTYPE)) (PARSE.BIN '%]) (SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE))) ((EQ PARSE.ATOM 'APPLY) (PARSE.BIN) (PARSE.BIN '%[) (SETQ EXP1 (PARSE.EXP)) (PARSE.BIN '%,) (SETQ EXP2 (PARSE.EXP)) (PARSE.OPTCATCH) (PARSE.BIN '%]) (SETQ ANSWER (LIST 'APPLY EXP1 EXP2))) ((EQ PARSE.ATOM '%() (PARSE.BIN) (SETQ EXP1 (PARSE.EXP)) (PARSE.BIN '%)) (SETQ ANSWER EXP1)) ((EQ PARSE.CLASS 'ID) (SETQ ANSWER (PARSE.BIN))) ((EQ PARSE.CLASS 'CHAR) (SETQ ANSWER (BUILD.CHARCODE (PARSE.BIN] [while (PARSE.QUALIFIER.HERE) do (SETQ ANSWER (BUILD.QUALIFY ANSWER (PARSE.QUALIFIER] (RETURN ANSWER]) (PARSE.QUALIFIER.HERE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (AND (FMEMB PARSE.ATOM PARSE.QUALIFIER.FIRST) (NOT (AND (EQ PARSE.ATOM '%.) (OR (FMEMB PARSE.ATOM2 '(FREE NEW)) (AND (EQ PARSE.LANGUAGE 'CEDAR) (FMEMB PARSE.ATOM2 '(CONS LIST]) (PARSE.OPTCATCH [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (CATCHLIST ANSWER) (* (optcatch ! catchlist)  (optcatch) *) [COND ((EQ PARSE.ATOM '!) (PARSE.BIN) (SETQ ANSWER (PARSE.CATCHLIST] (RETURN ANSWER]) (PARSE.TRANSFEROP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (transferop SIGNAL)  (transferop ERROR) (transferop START)  (transferop JOIN) (transferop NEW)  (transferop FORK) *) (PARSE.BIN]) (PARSE.PREFIXOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (prefixop LONG) (prefixop ABS) (prefixop PRED)  (prefixop SUCC) (prefixop ORD) (prefixop MIN)  (prefixop MAX) (prefixop BASE) (prefixop LENGTH) *) (PARSE.BIN]) (PARSE.TYPEOP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* BOTH (typeop FIRST)  (typeop LAST) (typeop NIL) *) (* CEDAR (typeop CODE) *) (COND ((EQ PARSE.ATOM 'CODE) (PARSE.THISIS.CEDAR))) (PARSE.BIN]) (PARSE.DESCLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXP1 EXP2 OPTTYPE ANSWER) (* (desclist exp %, exp opttype)  (desclist exp) *) (SETQ EXP1 (PARSE.EXP)) [COND ((EQ PARSE.ATOM '%,) (PARSE.BIN) (SETQ EXP2 (PARSE.EXP)) (SETQ OPTTYPE (PARSE.OPTTYPE)) (SETQ ANSWER (LIST 'desclist EXP1 EXP2 OPTTYPE)) (RETURN ANSWER)) (T (SETQ ANSWER (LIST 'desclist EXP1] (RETURN ANSWER]) (PARSE.DIRECTORY [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG NIL (* (directory DIRECTORY ;)  (directory DIRECTORY includelist ;)  (directory) *) (COND ((EQ PARSE.ATOM 'DIRECTORY) (PARSE.BIN) (COND ((EQ PARSE.ATOM ';)) (T (PARSE.INCLUDELIST) (PARSE.BIN ';]) (PARSE.IMPORTS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG NIL (* (imports IMPORTS)  (imports IMPORTS modulelist)  (imports) *) (COND ((EQ PARSE.ATOM 'IMPORTS) (PARSE.BIN) (PARSE.MODULELIST]) (PARSE.POINTERPREFIX [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ANSWER) (* (pointerprefix POINTER)  (pointerprefix POINTER interval) *) (PARSE.BIN 'POINTER) [COND ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) (SETQ ANSWER (LIST 'POINTER (PARSE.INTERVAL] (RETURN ANSWER]) (PARSE.EXPORTS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (MODULELIST ANSWER) (* (exports EXPORTS)  (exports EXPORTS modulelist)  (exports) *) (COND ((EQ PARSE.ATOM 'EXPORTS) (PARSE.BIN) (BUILD.STORE.EXPORTS (PARSE.MODULELIST]) (PARSE.FIELDLIST [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:48") (PROG (ANSWER) (* (fieldlist %[ %])  (fieldlist %[ pairlist %])  (fieldlist %[ typelist %]) *) (PARSE.BIN '%[) [COND ((NOT (EQ PARSE.ATOM '%])) (COND [[AND (EQ PARSE.CLASS 'ID) (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES)) (FMEMB PARSE.ATOM2 '(%( %, %:] (SETQ ANSWER (PARSE.PAIRLIST 'FIELDLIST] (T (SETQ ANSWER (PARSE.TYPELIST] (PARSE.BIN '%]) (RETURN ANSWER]) (PARSE.USING [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (IDLIST) (* (using USING %[ %])  (using USING %[ idlist %])  (using) *) [COND ((EQ PARSE.ATOM 'USING) (PARSE.BIN) (PARSE.BIN '%[) (COND ((EQ PARSE.ATOM '%]) (PARSE.BIN)) (T (SETQ IDLIST (PARSE.IDLIST)) (PARSE.BIN '%]] (RETURN IDLIST]) (PARSE.CATCHHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (CATCHCASES ANSWER) (* (catchhead) (catchhead catchhead  catchcase ;) *) (COND ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW) (RETURN))) (push CATCHCASES (PARSE.CATCHCASE)) (while (EQ PARSE.ATOM ';) do (PARSE.BIN) (COND ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW) (RETURN))) (push CATCHCASES (PARSE.CATCHCASE))) (SETQ ANSWER (DREVERSE CATCHCASES)) (RETURN ANSWER]) (PARSE.DECLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (VARLIST) (* (declist declaration)  (declist declist ; declaration) *) (SETQ VARLIST (PARSE.DECLARATION)) [do (COND ((EQ PARSE.ATOM ';) (PARSE.BIN)) ((FMEMB PARSE.ATOM PARSE.DECLIST.FOLLOW) (RETURN)) (T (SHOULDNT "PARSE.DECLIST"))) (COND ([NOT (AND (EQ PARSE.CLASS 'ID) (FMEMB PARSE.ATOM2 '(%, %:] (RETURN))) (SETQ VARLIST (NCONC VARLIST (PARSE.DECLARATION] (BUILD.STORE.VARLIST VARLIST]) (PARSE.PAIRLIST [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:48") (PROG (PAIRITEMS ANSWER) (* (pairlist pairitem)  (pairlist pairlist %, pairitem) *) (* PARSE.PAIRITEM returns a list of  PAIRITEM records. *) (SETQ PAIRITEMS (PARSE.PAIRITEM KIND)) (COND ((type? TYPELIST PAIRITEMS) (* Thought we we're parsing a pairlist, but found a typelist.  *) (RETURN PAIRITEMS))) [while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (SETQ PAIRITEMS (NCONC PAIRITEMS (PARSE.PAIRITEM KIND] (SETQ ANSWER (create PAIRLIST ITEMS _ PAIRITEMS)) (RETURN ANSWER]) (PARSE.VARIANTLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (VARIANTITEMS ANSWER) (* (variantlist variantitem)  (variantlist variantlist %,  variantitem) *) (push VARIANTITEMS (PARSE.VARIANTITEM)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push VARIANTITEMS (PARSE.VARIANTITEM))) (SETQ ANSWER (CONS 'variantlist (DREVERSE VARIANTITEMS))) (RETURN ANSWER]) (PARSE.ORDERLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (OPTEXPS ANSWER) (* (orderlist optexp)  (orderlist orderlist %, optexp) *) (COND ((FMEMB PARSE.ATOM PARSE.ORDERLIST.FOLLOW) (RETURN))) (push OPTEXPS (PARSE.OPTEXP)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push OPTEXPS (PARSE.OPTEXP))) (SETQ ANSWER (create ORDERLIST ITEMS _ (DREVERSE OPTEXPS))) (RETURN ANSWER]) (PARSE.LHSLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (LHSS ANSWER) (* (lhslist lhs) (lhslist lhslist %,  lhs) *) (push LHSS (PARSE.LHS)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push LHSS (PARSE.LHS))) (SETQ ANSWER (DREVERSE LHSS)) (RETURN ANSWER]) (PARSE.INCLUDELIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG NIL (* (includelist includeitem)  (includelist includelist %,  includeitem) *) (PARSE.INCLUDEITEM) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (PARSE.INCLUDEITEM]) (PARSE.MODULELIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (MODULEITEMS ANSWER) (* (modulelist moduleitem)  (modulelist modulelist %, moduleitem)  *) (COND ((FMEMB PARSE.ATOM PARSE.MODULELIST.FOLLOW) (RETURN NIL))) (push MODULEITEMS (PARSE.MODULEITEM)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push MODULEITEMS (PARSE.MODULEITEM))) (SETQ ANSWER (DREVERSE MODULEITEMS)) (RETURN ANSWER]) (PARSE.ELEMENTLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ELEMENTS ANSWER) (* (elementlist element)  (elementlist elementlist %, element) *) (push ELEMENTS (PARSE.ELEMENT)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push ELEMENTS (PARSE.ELEMENT))) (SETQ ANSWER (DREVERSE ELEMENTS)) (RETURN ANSWER]) (PARSE.BINDLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (BINDITEMS ANSWER) (* (bindlist binditem)  (bindlist bindlist %, binditem) *) (push BINDITEMS (PARSE.BINDITEM)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push BINDITEMS (PARSE.BINDITEM))) (SETQ ANSWER (DREVERSE BINDITEMS)) (RETURN ANSWER]) (PARSE.STATEMENTLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (STATEMENTS ANSWER) (* (statementlist statement)  (statementlist statementlist ;  statement) *) (COND ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW) (RETURN))) (push STATEMENTS (PARSE.STATEMENT)) (do (COND ((EQ PARSE.ATOM ';) (PARSE.BIN))) (COND ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW) (RETURN))) (push STATEMENTS (PARSE.STATEMENT))) (SETQ ANSWER (DREVERSE STATEMENTS)) (RETURN ANSWER]) (PARSE.CASESTMTLIST [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:48") (PROG (CASESTMTITEMS ANSWER) (* (casestmtlist casestmtitem)  (casestmtlist casestmtlist ;  casestmtitem) *) (push CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD)) (do (COND ((EQ PARSE.ATOM ';) (PARSE.BIN))) (COND ((EQ PARSE.ATOM 'ENDCASE) (RETURN))) (push CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD))) (SETQ ANSWER (DREVERSE CASESTMTITEMS)) (RETURN ANSWER]) (PARSE.CASELABEL [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (CASETESTS IDENT TYPEEXP ANSWER) (* (caselabel ident typeexp)  (caselabel caselabel')  (caselabel' casetest)  (caselabel' caselabel' %, casetest) *) (COND ([AND (EQ PARSE.CLASS 'ID) (FMEMB PARSE.ATOM2 '(%: %(] (SETQ IDENT (PARSE.IDENT)) (SETQ TYPEEXP (PARSE.TYPEEXP)) (SETQ ANSWER (LIST (BUILD.ISTYPE IDENT TYPEEXP))) (BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE) (RETURN ANSWER))) (push CASETESTS (PARSE.CASETEST)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push CASETESTS (PARSE.CASETEST))) (SETQ ANSWER (DREVERSE CASETESTS)) (RETURN ANSWER]) (PARSE.EXITLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXITITEMS ANSWER) (* (exitlist exititem)  (exitlist exitlist ;  exititem) *) (COND ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW) (RETURN))) (push EXITITEMS (PARSE.EXITITEM)) (do (COND ((EQ PARSE.ATOM ';) (PARSE.BIN))) (COND ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW) (RETURN))) (push EXITITEMS (PARSE.EXITITEM))) (SETQ ANSWER (DREVERSE EXITITEMS)) (RETURN ANSWER]) (PARSE.KEYLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (KEYITEMS ANSWER) (* (keylist keyitem)  (keylist keylist %, keyitem) *) (push KEYITEMS (PARSE.KEYITEM)) (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) (push KEYITEMS (PARSE.KEYITEM))) (SETQ ANSWER (create KEYLIST ITEMS _ (DREVERSE KEYITEMS))) (RETURN ANSWER]) (PARSE.CASEEXPLIST [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:48") (PROG (CASEEXPITEMS ANSWER) (* (caseexplist caseexpitem)  (caseexplist caseexplist %,  caseexpitem) *) (push CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD)) (do (COND ((EQ PARSE.ATOM '%,) (PARSE.BIN))) (COND ((EQ PARSE.ATOM 'ENDCASE) (RETURN))) (push CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD))) (SETQ ANSWER (DREVERSE CASEEXPITEMS)) (RETURN ANSWER]) (PARSE.EXPLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (explist orderlist)  (explist keylist) *) (PROG (ORDERLIST KEYLIST ANSWER) [COND ((AND (EQ PARSE.CLASS 'ID) (EQ PARSE.ATOM2 '%:)) (SETQ ANSWER (PARSE.KEYLIST))) (T (SETQ ANSWER (PARSE.ORDERLIST] (RETURN ANSWER]) (PARSE.OPEN [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (BINDLIST) (* (open OPEN bindlist ;)  (open) *) [COND ((EQ PARSE.ATOM 'OPEN) (PARSE.BIN) (SETQ BINDLIST (PARSE.BINDLIST)) (PARSE.BIN ';] (RETURN BINDLIST]) (PARSE.CLASS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (class PROGRAM) (class MONITOR) *) (PARSE.BIN '(MONITOR PROGRAM]) (PARSE.CASEHEAD [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (ID EXP OPTEXP BINDITEM OPTEXP ANSWER) (* (casehead SELECT exp FROM)  (casehead WITH binditem SELECT optexp  FROM) *) [COND ((EQ PARSE.ATOM 'SELECT) (PARSE.BIN) (SETQ EXP (PARSE.EXP)) (PARSE.BIN 'FROM)) (T (PARSE.BIN 'WITH) (SETQ BINDITEM (PARSE.BINDITEM)) (SETQ ID (fetch (BINDITEM ID) of BINDITEM)) (SETQ EXP (fetch (BINDITEM EXP) of BINDITEM)) (PARSE.BIN 'SELECT) (SETQ OPTEXP (PARSE.OPTEXP)) (PARSE.BIN 'FROM] (SETQ ANSWER (create CASEHEAD ID _ ID EXP _ EXP OPTEXP _ OPTEXP)) (RETURN ANSWER]) (PARSE.READONLY [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (readonly READONLY)  (readonly) *) (COND ((EQ PARSE.ATOM 'READONLY) (PARSE.BIN]) (PARSE.ORDERED [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (ordered ORDERED)  (ordered) *) (COND ((EQ PARSE.ATOM 'ORDERED) (PARSE.BIN]) (PARSE.BASE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (base BASE) (base) *) (COND ((EQ PARSE.ATOM 'BASE) (PARSE.BIN]) (PARSE.PACKED [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (packed PACKED) (packed) *) (COND ((EQ PARSE.ATOM 'PACKED) (PARSE.BIN]) (PARSE.HEAP [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* BOTH (heap UNCOUNTED) *) (* CEDAR (heap) *) (COND ((EQ PARSE.ATOM 'UNCOUNTED) (PARSE.BIN)) (T (PARSE.THISIS.CEDAR]) (PARSE.INLINE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (inline INLINE) (inline) *) (COND ((EQ PARSE.ATOM 'INLINE) (PARSE.BIN]) (PARSE.ARGUMENTS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG NIL (* (arguments arglist returnlist) *) (PARSE.ARGLIST) (PARSE.RETURNLIST]) (PARSE.INTERFACE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG NIL (* (interface imports exports shares)  *) (PARSE.IMPORTS) (PARSE.EXPORTS) (PARSE.SHARES]) (PARSE.SHARES [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (shares SHARES idlist)  (shares) *) (COND ((EQ PARSE.ATOM 'SHARES) (CONS (PARSE.BIN) (PARSE.IDLIST]) (PARSE.DEFAULT [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (default _ defaultopt)  (default) *) (COND ((EQ PARSE.ATOM '_) (PARSE.BIN) (PARSE.DEFAULTOPT]) (PARSE.OPTSIZE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXP ANSWER) (* (optsize %[ exp %])  (optsize) *) (COND ((EQ PARSE.ATOM '%[) (PARSE.BIN) (SETQ EXP (PARSE.EXP)) (PARSE.BIN '%]) (SETQ ANSWER EXP))) (RETURN ANSWER]) (PARSE.BOUNDS [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXP1 EXP2 ANSWER) (* (bounds exp |..| exp) *) (SETQ EXP1 (PARSE.EXP)) (PARSE.BIN '|..|) (SETQ EXP2 (PARSE.EXP)) (SETQ ANSWER (LIST EXP1 EXP2)) (RETURN ANSWER]) (PARSE.LENGTH [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (EXP ANSWER) (* (length %[ exp %]) *) (PARSE.BIN '%[) (SETQ EXP (PARSE.EXP)) (PARSE.BIN '%]) (SETQ ANSWER EXP) (RETURN ANSWER]) (PARSE.INDEXTYPE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (indextype typeexp)  (indextype) *) (COND ((NOT (EQ PARSE.ATOM 'OF)) (PARSE.TYPEEXP]) (PARSE.ELSEPART [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (elsepart ELSE statement)  (elsepart) *) (COND ((EQ PARSE.ATOM 'ELSE) (PARSE.BIN) (PARSE.STATEMENT]) (PARSE.OTHERPART [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (otherpart => statement)  (otherpart) *) (COND ((EQ PARSE.ATOM '=>) (PARSE.BIN) (PARSE.STATEMENT]) (PARSE.FREE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (LHS ANSWER) (* (free lhs %. FREE) *) (SETQ LHS (PARSE.LHS)) (PARSE.BIN '%.) (PARSE.BIN 'FREE) (SETQ ANSWER (LIST 'FREE LHS)) (RETURN ANSWER]) (PARSE.CATCHANY [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG (STATEMENT ANSWER) (* (catchany ANY => statement) *) (PARSE.BIN 'ANY) (PARSE.BIN '=>) (SETQ STATEMENT (PARSE.STATEMENT)) (SETQ ANSWER (LIST 'ANY STATEMENT)) (RETURN ANSWER]) (PARSE.NOT [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (not ~) (not NOT) *) (PARSE.BIN]) (PARSE.NEW [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (PROG NIL (* BOTH (new lhs %. NEW) *) (* CEDAR (new NEW) *) (COND ((AND (EQ PARSE.ATOM 'NEW) (EQ PARSE.LANGUAGE 'CEDAR)) (PARSE.BIN)) (T (* Throw away lhs. Interlisp doesn't have separate storage "zone"  (QUOTE s.) *) (PARSE.LHS) (PARSE.BIN '%.) (PARSE.BIN 'NEW]) (PARSE.OPTTYPE [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* (opttype %, typeexp)  (opttype) *) (COND ((EQ PARSE.ATOM '%,) (PARSE.BIN) (PARSE.TYPEEXP)) (T 'ANY]) (PARSE.ARGLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* BOTH (arglist fieldlist)  (arglist) *) (* CEDAR (arglist ANY) *) (PROG (ARGLIST) [SETQ ARGLIST (COND ((EQ PARSE.ATOM '%[) (COND ((EQ PARSE.ATOM 'ANY) (PARSE.THISIS.CEDAR) (PARSE.BIN)) (T (PARSE.FIELDLIST 'ARGLIST] (BUILD.STORE.ARGLIST ARGLIST]) (PARSE.RETURNLIST [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") (* BOTH (returnlist RETURNS fieldlist)  (returnlist) *) (* CEDAR (returnlist RETURNS ANY) *) (PROG (RETURNLIST) [SETQ RETURNLIST (COND ((EQ PARSE.ATOM 'RETURNS) (PARSE.BIN) (COND ((EQ PARSE.ATOM 'ANY) (PARSE.THISIS.CEDAR) (PARSE.BIN)) (T (PARSE.FIELDLIST 'RETURNLIST] (BUILD.STORE.RETURNLIST RETURNLIST]) ) (* ;; "BUILD ") (RPAQ? BUILD.NEXT.SCOPE NIL) (RPAQ? BUILD.CURRENT.SCOPE NIL) (RPAQ? BUILD.SCOPE.STACK NIL) (RPAQ? BUILD.PREFIX NIL) (RPAQ? BUILD.FILECOMS NIL) (RPAQ? BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP GEQ LEQ)) (RPAQ? BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR LOGXOR NTHCHARCODE SUB1)) (RPAQ? BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER TIMES)) (RPAQ? BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES LOG SIN SQRT TAN)) (RPAQ? BUILD.QUALIFY.WORDS '(FREE NEW SIZE)) (RPAQ? BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP) (CONS '%# 'IEQP) (CONS '< 'ILESSP) (CONS '<= 'ILEQ) (CONS '> 'IGREATERP) (CONS '>= 'IGEQ) (CONS '+ 'IPLUS) (CONS '- 'IDIFFERENCE) (CONS '* 'ITIMES) (CONS '/ 'IQUOTIENT) (CONS '0- 'IMINUS) (CONS 'MAX 'IMAX) (CONS 'MIN 'IMIN) (CONS 'MOD 'IMOD))) (RPAQ? BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP) (CONS '%# 'EQP) (CONS '< 'LESSP) (CONS '<= 'GREATERP) (CONS '> 'GREATERP) (CONS '>= 'LESSP) (CONS '+ 'PLUS) (CONS '- 'DIFFERENCE) (CONS '* 'TIMES) (CONS '/ 'QUOTIENT) (CONS '0- 'MINUS) (CONS 'MAX 'MAX) (CONS 'MIN 'MIN) (CONS 'MOD 'IMOD))) (RPAQ? BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP) (CONS '%# 'FEQP) (CONS '< 'FLESSP) (CONS '<= 'FGREATERP) (CONS '> 'FGREATERP) (CONS '>= 'FLESSP) (CONS '+ 'FPLUS) (CONS '- 'FDIFFERENCE) (CONS '* 'FTIMES) (CONS '/ 'FQUOTIENT) (CONS '0- 'FMINUS) (CONS 'MAX 'FMAX) (CONS 'MIN 'FMIN) (CONS 'MOD 'IMOD))) (RPAQ? BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD)) (DECLARE%: EVAL@COMPILE (RECORD SCOPE (ID SYMBOLTABLE INITLIST ARGLIST VARLIST RETURNLIST RETURNS OPEN) [ACCESSFNS ((RETURNVARS (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) of (fetch (SCOPE RETURNLIST) of DATUM)) collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID) of PAIRITEM]) ) (DEFINEQ (BUILD.INIT [LAMBDA (PREFIX) (* kbr%: "25-Nov-85 17:27") (PROG NIL (SETQ BUILD.PREFIX PREFIX) (SETQ BUILD.FILECOMS (FILECOMS (U-CASE PREFIX))) (SETTOPVAL BUILD.FILECOMS NIL) (printout T "Creating " BUILD.FILECOMS T) (SETQ BUILD.NEXT.SCOPE (create SCOPE ID _ 'MODULE)) (SETQ BUILD.CURRENT.SCOPE NIL) (SETQ BUILD.SCOPE.STACK NIL]) (BUILD.PUSH.SCOPE [LAMBDA NIL (* kbr%: "25-Nov-85 17:27") (PROG NIL (COND (BUILD.CURRENT.SCOPE (push BUILD.SCOPE.STACK BUILD.CURRENT.SCOPE))) (SETQ BUILD.CURRENT.SCOPE BUILD.NEXT.SCOPE) (SETQ BUILD.NEXT.SCOPE (create SCOPE)) (RETURN (CAR BUILD.SCOPE.STACK]) (BUILD.POP.SCOPE [LAMBDA NIL (* kbr%: "25-Nov-85 17:27") (PROG NIL (SETQ BUILD.NEXT.SCOPE BUILD.CURRENT.SCOPE) (SETQ BUILD.CURRENT.SCOPE (pop BUILD.SCOPE.STACK)) (RETURN BUILD.CURRENT.SCOPE]) (BUILD.GC.SCOPE [LAMBDA NIL (* kbr%: "25-Nov-85 17:27") (PROG NIL (SETQ BUILD.NEXT.SCOPE (create SCOPE]) (BUILD.STORE.EXPORTS [LAMBDA (EXPORTS) (* kbr%: "25-Nov-85 17:27") (PROG NIL (COND (EXPORTS (SETQ BUILD.PREFIX (CAR EXPORTS]) (BUILD.STORE.IDENTLIST [LAMBDA (IDENTLIST) (* kbr%: "25-Nov-85 17:27") (PROG NIL (replace (SCOPE ID) of BUILD.NEXT.SCOPE with (CAR IDENTLIST]) (BUILD.STORE.INTERFACES [LAMBDA (INTERFACES) (* kbr%: "25-Nov-85 17:27") (PROG NIL (for INTERFACE in INTERFACES do (BUILD.STORE.INTERFACE INTERFACE]) (BUILD.STORE.INTERFACE [LAMBDA (INTERFACE) (* kbr%: "25-Nov-85 17:27") (PROG NIL (PUTPROP INTERFACE 'MESA.INTERFACE T]) (BUILD.STORE.OPEN [LAMBDA (OPEN) (* kbr%: "25-Nov-85 17:27") (PROG NIL (replace (SCOPE OPEN) of BUILD.NEXT.SCOPE with OPEN]) (BUILD.STORE.USING [LAMBDA (INTERFACE USING) (* kbr%: "25-Nov-85 17:27") (PROG NIL (for USE in USING do (PUTPROP USE 'MESA.USEDBY INTERFACE]) (BUILD.INITIALIZATION [LAMBDA (IDENTLIST TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) (SELECTQ (BUILD.TYPEATOM TYPEEXP) (PROC (BUILD.INITIALIZE.FN (CAR IDENTLIST) TYPEEXP INITIALIZATION)) (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST) TYPEEXP INITIALIZATION)) (SETQ ANSWER (BUILD.INITIALIZE.VARS IDENTLIST TYPEEXP INITIALIZATION BUILD.CURRENT.SCOPE))) (RETURN ANSWER]) (BUILD.INITIALIZE.VARS [LAMBDA (IDENTLIST TYPEEXP INITIALIZATION SCOPE) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) (SETQ ANSWER (for ID in IDENTLIST collect (BUILD.INITIALIZE.VAR ID TYPEEXP INITIALIZATION SCOPE))) (RETURN ANSWER]) (BUILD.INITIALIZE.VAR [LAMBDA (ID TYPEEXP INITIALIZATION SCOPE) (* kbr%: "25-Nov-85 17:27") (PROG (PAIRITEM) (SETQ PAIRITEM (create PAIRITEM ID _ ID TYPEEXP _ TYPEEXP DEFAULT _ INITIALIZATION)) (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE) of SCOPE) (LIST PAIRITEM))) (COND ((NULL BUILD.SCOPE.STACK) (BUILD.ADD.TO.FILECOMS (LIST ID (BUILD.COERCE INITIALIZATION TYPEEXP)) 'INITVARS) (PRIN1 ID T) (PRIN1 "," T))) (RETURN ID]) (BUILD.INITIALIZE.FN [LAMBDA (ID TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:27") (PROG (PROCID ARGLIST RETURNLIST LAMBDA) (SETQ PROCID (BUILD.PROCID BUILD.PREFIX ID)) (SETQ ARGLIST (fetch (SCOPE ARGLIST) of BUILD.NEXT.SCOPE)) (SETQ RETURNLIST (fetch (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE)) (PUTPROP ID 'MESA.USEDBY BUILD.PREFIX) (PUTPROP PROCID 'MESA.FN T) (PUTPROP PROCID 'MESA.ARGLIST ARGLIST) (PUTPROP PROCID 'MESA.RETURNLIST RETURNLIST) (SETQ LAMBDA (BUILD.LAMBDA ARGLIST INITIALIZATION)) (PUTD PROCID LAMBDA) (BUILD.ADD.TO.FILECOMS PROCID 'FNS) (BUILD.GC.SCOPE) (PRIN1 ID T) (PRIN1 "," T]) (BUILD.INITIALIZE.RECORD [LAMBDA (ID TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:27") (PROG (RECORDID FIELDLIST RECORD) (SETQ RECORDID (BUILD.RECORDID BUILD.PREFIX ID)) (replace (MRECORD RECORDID) of TYPEEXP with RECORDID) (SETQ RECORD (BUILD.RECORD RECORDID TYPEEXP)) (EVAL RECORD) (BUILD.ADD.TO.FILECOMS RECORDID 'RECORDS) (PUTPROP ID 'MESA.USEDBY BUILD.PREFIX) (PUTPROP RECORDID 'MESA.TYPE TYPEEXP) (PRIN1 ID T) (PRIN1 "," T]) (BUILD.RECORD [LAMBDA (RECORDID TYPEEXP) (* kbr%: "25-Nov-85 17:27") (PROG (FIELDLIST FIELDS DEFAULTS ANSWER) (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of TYPEEXP)) (COND [(NULL FIELDLIST) (* I'm not really sure what an empty FIELDLIST is supposed to get you in  MESA/CEDAR. *) (RETURN `(TYPERECORD ,RECORDID] [(type? PAIRLIST FIELDLIST) (for ITEM in (REVERSE (fetch (PAIRLIST ITEMS) of FIELDLIST)) do (push FIELDS (fetch (PAIRITEM ID) of ITEM)) (COND ((fetch (PAIRITEM DEFAULT) of ITEM) (SETQ DEFAULTS (NCONC DEFAULTS `(,(fetch (PAIRITEM ID) of ITEM) _ ,(BUILD.COERCE (fetch (PAIRITEM DEFAULT) of ITEM) (fetch (PAIRITEM TYPEEXP) of ITEM] [(type? TYPELIST FIELDLIST) (for ITEM in (REVERSE (fetch (TYPELIST ITEMS) of FIELDLIST)) as I from 1 do (push FIELDS (PACK* 'FIELD I)) (COND ((fetch (TYPEITEM DEFAULT) of ITEM) (SETQ DEFAULTS (NCONC DEFAULTS `(,(PACK* 'FIELD I) _ ,(BUILD.COERCE (fetch (TYPEITEM DEFAULT) of ITEM) (fetch (TYPEITEM TYPEEXP) of ITEM] (T (SHOULDNT))) [SETQ ANSWER `(RECORD ,RECORDID ,FIELDS ,@DEFAULTS] (RETURN ANSWER]) (BUILD.TYPE [LAMBDA (IDENTLIST TYPEEXP DEFAULT) (* kbr%: "25-Nov-85 17:27") (PROG (ID TYPEID) (SELECTQ (BUILD.TYPEATOM TYPEEXP) (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST) TYPEEXP DEFAULT)) (PROGN (SETQ TYPEID (BUILD.TYPEID BUILD.PREFIX (CAR IDENTLIST))) (COND ((NOT (EQ TYPEID TYPEEXP)) (PUTPROP (CAR IDENTLIST) 'MESA.USEDBY BUILD.PREFIX) (PUTPROP TYPEID 'MESA.TYPE TYPEEXP]) (BUILD.STORE.ARGLIST [LAMBDA (ARGLIST) (* kbr%: "25-Nov-85 17:27") (* ARGLIST = args for coming function  scope. *) (PROG NIL (replace (SCOPE ARGLIST) of BUILD.NEXT.SCOPE with ARGLIST) (COND ((type? PAIRLIST ARGLIST) (BUILD.STORE.PAIRLIST ARGLIST]) (BUILD.STORE.RETURNLIST [LAMBDA (RETURNLIST) (* kbr%: "25-Nov-85 17:27") (* RETURNLIST = args for coming  function scope. *) (PROG NIL (replace (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE with RETURNLIST) (COND ((type? PAIRLIST RETURNLIST) (BUILD.STORE.PAIRLIST RETURNLIST]) (BUILD.STORE.PAIRLIST [LAMBDA (PAIRLIST) (* kbr%: "25-Nov-85 17:27") (* PAIRLIST = args or return vals for coming function scope.  *) (PROG NIL (for PAIRITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) collect (BUILD.STORE.PAIRITEM PAIRITEM BUILD.NEXT.SCOPE]) (BUILD.STORE.PAIRITEM [LAMBDA (PAIRITEM SCOPE) (* kbr%: "25-Nov-85 17:27") (PROG NIL (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE) of SCOPE) (LIST PAIRITEM))) (RETURN (fetch (PAIRITEM ID) of PAIRITEM]) (BUILD.STORE.VARLIST [LAMBDA (VARLIST) (* kbr%: "25-Nov-85 17:27") (PROG NIL (replace (SCOPE VARLIST) of BUILD.CURRENT.SCOPE with VARLIST]) (BUILD.ID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) (COND ((STRPOS "." ID) (RETURN ID))) [SETQ INTERFACE (OR INTERFACE (GETPROP ID 'MESA.USEDBY] (SETQ ANSWER (COND (INTERFACE (PACK* INTERFACE "." ID)) (T ID))) (RETURN ANSWER]) (BUILD.FIELDID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") ID]) (BUILD.PROCID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") (BUILD.ID INTERFACE ID]) (BUILD.RECORDID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") (BUILD.ID INTERFACE ID]) (BUILD.TYPEID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") (COND ((FMEMB ID PARSE.PREDEFINED.TYPES) ID) (T (BUILD.ID INTERFACE ID]) (BUILD.VARID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) [SETQ ANSWER (COND ((BUILD.LOOKUP ID) (BUILD.LOCALVARID INTERFACE ID)) (T (BUILD.GLOBALVARID INTERFACE ID] (RETURN ANSWER]) (BUILD.LOCALVARID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") ID]) (BUILD.GLOBALVARID [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") (BUILD.ID INTERFACE ID]) (BUILD.ULTIMATE.TYPE [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") (BUILD.REFINE.TYPE (BUILD.IMMEDIATE.TYPE EXP]) (BUILD.REFINE.TYPE [LAMBDA (TYPE) (* kbr%: "25-Nov-85 17:27") (PROG (PAIRITEM NEXTTYPE) LOOP (SETQ NEXTTYPE (COND ((OR (FMEMB TYPE '(ANY MPROC INTERFACE)) (FMEMB TYPE PARSE.PREDEFINED.TYPES)) (SELECTQ TYPE (BOOL 'BOOLEAN) (CHAR 'CHARACTER) ((INT INTEGER NAT WORD) 'CARDINAL) (StringBody 'STRING) (UNSPECIFIED 'ANY) TYPE)) ((LITATOM TYPE) (OR (BUILD.LOOKUP.TYPE TYPE) (PROGN (printout T T TYPE " type unknown." T) (PUTPROP TYPE 'MESA.TYPE 'UNDECLARED) TYPE))) ((type? MINTERVAL TYPE) (fetch (MINTERVAL LBOUND) of TYPE)) ((type? MPOINTER TYPE) (fetch (MPOINTER TYPE) of TYPE)) ((type? MREF TYPE) (fetch (MREF TYPE) of TYPE)) (T TYPE))) (COND ((EQ NEXTTYPE 'UNDECLARED) (RETURN TYPE)) ((NOT (EQ NEXTTYPE TYPE)) (SETQ TYPE NEXTTYPE) (GO LOOP))) (RETURN TYPE]) (BUILD.IMMEDIATE.TYPE [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") (PROG (TYPE FN RECORDNAME FIELDNAME MRECORD FIELDLIST PAIRITEM) [SETQ TYPE (COND ((OR (NULL EXP) (EQ EXP T)) 'BOOLEAN) [(LITATOM EXP) (OR (BUILD.LOOKUP.TYPE EXP) (PROGN (printout T T EXP " type unknown." T) 'ANY] ((FIXP EXP) 'CARDINAL) ((FLOATP EXP) 'REAL) ((STRINGP EXP) 'STRING) [(LISTP EXP) (SETQ FN (CAR EXP)) (COND ((EQ FN 'SETQ) (BUILD.IMMEDIATE.TYPE (CADR EXP))) [(EQ FN 'CAR) (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP))) (COND ((type? MLIST TYPE) (fetch (MLIST TYPE) of TYPE)) (T (printout T T EXP " type unknown." T) 'ANY] [(EQ FN 'CDR) (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP))) (COND ((type? MLIST TYPE) TYPE) (T (printout T T EXP " type unknown." T) 'ANY] [(FMEMB FN '(CONS LIST)) (SETQ TYPE (BUILD.IMMEDIATE.TYPE (CADR EXP))) (COND (TYPE (create MLIST TYPE _ TYPE)) (T (printout T T EXP " type unknown." T) 'ANY] [(EQ FN 'COND) (BUILD.IMMEDIATE.TYPE (CADR (CADR EXP] [(EQ FN 'ELT) (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP))) (COND ((type? MARRAY TYPE) (fetch (MARRAY TYPE) of TYPE)) (T (printout T T EXP " type unknown." T) 'ANY] ((EQ FN 'create) (CADR EXP)) [(EQ FN 'fetch) (SETQ RECORDNAME (CAR (CADR EXP))) (SETQ FIELDNAME (CADR (CADR EXP))) (SETQ MRECORD (GETPROP RECORDNAME 'MESA.TYPE)) (COND ((EQ MRECORD 'UNDECLARED) 'ANY) (T (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD)) (COND ((type? PAIRLIST FIELDLIST) (SETQ PAIRITEM (ASSOC FIELDNAME (fetch (PAIRLIST ITEMS) of FIELDLIST))) (fetch (PAIRITEM TYPEEXP) of PAIRITEM)) (T (printout T T EXP " type unknown." T) 'ANY] ((FMEMB FN BUILD.BOOLEAN.FNS) 'BOOLEAN) ((FMEMB FN BUILD.CARDINAL.FNS) 'CARDINAL) ((FMEMB FN BUILD.MIXED.FNS) 'MIXED) ((FMEMB FN BUILD.REAL.FNS) 'REAL) (T (printout T T EXP " type unknown." T) 'ANY] (T (printout T T EXP " type unknown." T) 'ANY] (RETURN TYPE]) (BUILD.LOOKUP.TYPE [LAMBDA (ID) (* kbr%: "25-Nov-85 17:27") (PROG (PAIRITEM TYPE) (SETQ PAIRITEM (BUILD.LOOKUP ID)) (COND (PAIRITEM (SETQ TYPE (fetch (PAIRITEM TYPEEXP) of PAIRITEM)) (RETURN TYPE))) [SETQ TYPE (COND ((GETPROP ID 'MESA.TYPE)) ((GETPROP ID 'MESA.USEDBY) (BUILD.ID (GETPROP ID 'MESA.USEDBY) ID)) ((GETPROP ID 'MESA.FN) (RETURN 'MPROC)) ((GETPROP ID 'MESA.INTERFACE) (RETURN 'INTERFACE] (RETURN TYPE]) (BUILD.LOOKUP [LAMBDA (ID) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) [for SCOPE in (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK) do (SETQ ANSWER (ASSOC ID (fetch (SCOPE SYMBOLTABLE) of SCOPE))) (COND (ANSWER (RETURN] (RETURN ANSWER]) (BUILD.TYPEATOM [LAMBDA (TYPEEXP) (* kbr%: "25-Nov-85 17:27") (COND ((LITATOM TYPEEXP) TYPEEXP) (T (CAR TYPEEXP]) (BUILD.QUALIFY [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") (PROG (TYPE TYPEATOM ANSWER) (* (qualifier %. prefixop)  (qualifier %. typeop)  (qualifier %. SIZE) (qualifier %[  explist optcatch %])  (qualifier %. id) (qualifier ^) *) [SETQ ANSWER (COND ((FMEMB QUALIFIER PARSE.PREFIXOPS) (BUILD.QUALIFY.PREFIXOP LHS QUALIFIER)) ((FMEMB QUALIFIER PARSE.TYPEOPS) (BUILD.QUALIFY.TYPEOP LHS QUALIFIER)) ((EQ QUALIFIER 'SIZE) (PACK* LHS "." QUALIFIER)) [(EQ QUALIFIER 'first) `(CAR ,LHS] [(EQ QUALIFIER 'rest) `(CDR ,LHS] ((OR (NULL QUALIFIER) (LISTP QUALIFIER)) (BUILD.QUALIFY.EXPLIST LHS QUALIFIER)) ((EQ QUALIFIER '^) LHS) (T (BUILD.QUALIFY.ID LHS QUALIFIER] (RETURN ANSWER]) (BUILD.QUALIFY.PREFIXOP [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") (SELECTQ QUALIFIER ((MAX MIN) (BUILD.ARITH.EXP* QUALIFIER LHS)) (CONS QUALIFIER LHS]) (BUILD.QUALIFY.TYPEOP [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") (CONS QUALIFIER LHS]) (BUILD.QUALIFY.EXPLIST [LAMBDA (LHS EXPLIST) (* kbr%: "25-Nov-85 17:27") (* Qualify LHS with EXPLIST qualifier.  *) (PROG (TYPE TYPEATOM EXPITEMS ANSWER) [COND ((LITATOM LHS) (SETQ LHS (BUILD.ID NIL LHS] (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS)) (SETQ TYPEATOM (BUILD.TYPEATOM TYPE)) (SETQ EXPITEMS (fetch (EXPLIST ITEMS) of EXPLIST)) [SETQ ANSWER (SELECTQ TYPEATOM (MARRAY `(ELT ,LHS ,@EXPITEMS)) (MPROC (BUILD.CALL LHS EXPLIST)) (STRING `(NTHCHARCODE ,LHS ,@EXPITEMS)) (MRECORD (* Presumably record contains  SEQUENCE. *) `(ELT ,LHS ,@EXPITEMS)) (COND ((AND (LISTP LHS) (IEQP (LENGTH LHS) 2)) (* "ARG1.FN[ARG2,...,ARGn]" *) (APPEND LHS EXPITEMS)) (T (printout T T LHS " qualified by " EXPLIST "?" T) (COND [(AND (type? ORDERLIST EXPLIST) (IEQP (LENGTH EXPITEMS) 1)) (* Guess array access.  *) `(ELT ,LHS ,@EXPITEMS] (T (CONS LHS EXPITEMS] (RETURN ANSWER]) (BUILD.QUALIFY.ID [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") (* Qualify LHS with id QUALIFIER.  *) (PROG (TYPE TYPEATOM ANSWER) (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS)) (SETQ TYPEATOM (BUILD.TYPEATOM TYPE)) [SETQ ANSWER (SELECTQ TYPEATOM (MRECORD `(fetch (,(fetch (MRECORD RECORDID) of TYPE) ,QUALIFIER) of ,LHS)) (MARRAY (printout T T LHS " qualified by " QUALIFIER "?" T) `(ELT ,LHS ,QUALIFIER)) (INTERFACE (BUILD.ID LHS QUALIFIER)) (MPROC (COND (QUALIFIER (LIST LHS QUALIFIER)) (T (LIST LHS)))) (STRING (printout T T LHS " qualified by " QUALIFIER "?" T) `(NTHCHARCODE ,LHS ,QUALIFIER)) (COND [(EQ (GETPROP TYPE 'MESA.TYPE) 'UNDECLARED) (* Guess undeclared record.  *) `(fetch (,TYPE ,QUALIFIER) of ,LHS] (T (* Guess undeclared fn.  *) (LIST QUALIFIER LHS] (RETURN ANSWER]) (BUILD.ARITH.EXP1 [LAMBDA (ARITHOP EXP1) (* kbr%: "25-Nov-85 17:27") [COND ((EQ ARITHOP '-) (SETQ ARITHOP '0-] (BUILD.ARITH.EXP* ARITHOP (LIST EXP1]) (BUILD.ARITH.EXP2 [LAMBDA (ARITHOP EXP1 EXP2) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) (SETQ ANSWER (BUILD.ARITH.EXP* ARITHOP (LIST EXP1 EXP2))) (RETURN ANSWER]) (BUILD.ARITH.EXP* [LAMBDA (ARITHOP EXPS) (* kbr%: "25-Nov-85 17:27") (PROG (TYPE NEWARITHOP ANSWER) (SETQ TYPE (BUILD.STRONGEST.TYPE.AMONG EXPS)) (SETQ NEWARITHOP (BUILD.COERCE.ARITHOP ARITHOP TYPE)) [COND ((EQ TYPE 'REAL) (SETQ EXPS (for EXP in EXPS collect (COND ((FIXP EXP) (FLOAT EXP)) (T EXP] (SETQ ANSWER (CONS NEWARITHOP EXPS)) [COND ((FMEMB NEWARITHOP '(IPLUS IDIFFERENCE)) (SETQ ANSWER (BUILD.ARITH.ADD1SUB1 ANSWER))) [(AND (EQ ARITHOP '0-) (NUMBERP (CADR ANSWER))) (SETQ ANSWER (APPLY* (CAR ANSWER) (CADR ANSWER] ([OR (EQ ARITHOP '%#) (AND (FMEMB ARITHOP (LIST '<= '>=)) (NOT (EQ TYPE 'CARDINAL] (SETQ ANSWER (LIST 'NOT ANSWER] (RETURN ANSWER]) (BUILD.ARITH.ADD1SUB1 [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") (* Use ADD1 or SUB1 instead of IPLUS or IDIFFERENCE if possible.  *) (PROG (FN EXP1 EXP2 ANSWER) (COND ((NOT (IEQP (FLENGTH EXP) 3)) (RETURN EXP))) (SETQ FN (CAR EXP)) (SETQ EXP1 (CADR EXP)) (SETQ EXP2 (CADDR EXP)) (COND [(EQ FN 'IPLUS) (COND ((EQ EXP1 1) (SETQ ANSWER (BUILD.ADD1 EXP2))) ((EQ EXP2 1) (SETQ ANSWER (BUILD.ADD1 EXP1))) (T (SETQ ANSWER EXP] ((AND (EQ FN 'IDIFFERENCE) (EQ EXP2 1)) (SETQ ANSWER (BUILD.SUB1 EXP1))) (T (SETQ ANSWER EXP))) (RETURN ANSWER]) (BUILD.COERCE.ARITHOP [LAMBDA (ARITHOP TYPE) (* kbr%: "25-Nov-85 17:27") (SELECTQ TYPE (CARDINAL (CDR (ASSOC ARITHOP BUILD.CARDINAL.ARITHOP.ALIST))) (MIXED (CDR (ASSOC ARITHOP BUILD.MIXED.ARITHOP.ALIST))) (REAL (CDR (ASSOC ARITHOP BUILD.REAL.ARITHOP.ALIST))) (SHOULDNT]) (BUILD.STRONGEST.TYPE.AMONG [LAMBDA (EXPS) (* kbr%: "25-Nov-85 17:27") (PROG (TYPE) (SETQ TYPE 'CARDINAL) [for EXP in EXPS while (NOT (EQ TYPE 'REAL)) do (SETQ TYPE (BUILD.STRONGEST.TYPE TYPE (BUILD.ULTIMATE.TYPE EXP] (RETURN TYPE]) (BUILD.STRONGEST.TYPE [LAMBDA (TYPE1 TYPE2) (* kbr%: "25-Nov-85 17:27") [COND ((FMEMB TYPE1 BUILD.CARDINAL.TYPES) (SETQ TYPE1 'CARDINAL] [COND ((FMEMB TYPE2 BUILD.CARDINAL.TYPES) (SETQ TYPE2 'CARDINAL] (SELECTQ TYPE1 (CARDINAL (SELECTQ TYPE2 (CARDINAL 'CARDINAL) (REAL 'REAL) 'MIXED)) (MIXED (SELECTQ TYPE2 (REAL 'REAL) 'MIXED)) (REAL 'REAL) 'MIXED]) (BUILD.COERCE [LAMBDA (EXP TYPE) (* kbr%: "25-Nov-85 17:27") (PROG (TYPEEXP ANSWER) (SETQ TYPEEXP (BUILD.REFINE.TYPE TYPE)) (SETQ ANSWER (COND ((type? MARRAY TYPEEXP) (FRESHLINE T) (printout T T "Coercion to " TYPE " array type." T) (BUILD.COERCE.MARRAY EXP TYPEEXP)) ((type? MLIST TYPEEXP) (BUILD.COERCE.MLIST EXP TYPEEXP)) ((type? EXPLIST EXP) (BUILD.COERCE.EXPLIST EXP TYPEEXP)) (T EXP))) (RETURN ANSWER]) (BUILD.COERCE.MARRAY [LAMBDA (EXP MARRAY) (* kbr%: "25-Nov-85 17:27") (PROG (TYPE ANSWER) (* This is legal MESA/CEDAR code with no very elegant Interlisp translation.  *) (SETQ TYPE (fetch (MARRAY TYPE) of MARRAY)) (SETQ ANSWER (COND [(type? EXPLIST EXP) (* Should be an ORDERLIST.  *) (CONS 'LIST (for ITEM in (fetch (EXPLIST ITEMS) of EXP) collect (BUILD.COERCE ITEM TYPE] (T (* EXP might be an MARRAY var.  *) EXP))) (RETURN ANSWER]) (BUILD.COERCE.MLIST [LAMBDA (EXP MLIST) (* kbr%: "25-Nov-85 17:27") (PROG (TYPE ANSWER) (SETQ TYPE (fetch (MLIST TYPE) of MLIST)) (SETQ ANSWER (COND ((NOT (LISTP EXP)) EXP) [(EQ (CAR EXP) 'LIST) `(LIST ,@(for ITEM in (CDR EXP) collect (BUILD.COERCE ITEM TYPE] [(EQ (CAR EXP) 'CONS) `(CONS ,(BUILD.COERCE (CADR EXP) TYPE) ,(BUILD.COERCE (CADDR EXP) MLIST] (T EXP))) (RETURN ANSWER]) (BUILD.COERCE.EXPLIST [LAMBDA (EXPLIST MRECORD) (* kbr%: "25-Nov-85 17:27") (* Converts a Mesa explist EXPLIST (ambiguous by itself) into a CREATE TYPE  Lisp expression. *) (PROG (FIELDLIST ALIGNMENT SETTINGS ANSWER) (COND ((NOT (type? EXPLIST EXPLIST)) (RETURN EXPLIST))) [COND ((NOT (type? MRECORD MRECORD)) (printout T T MRECORD " not a record" T) (* Proceed to do the best we can.  *) [COND ((type? KEYLIST EXPLIST) [SETQ SETTINGS (for ITEM in (fetch (KEYLIST ITEMS) of EXPLIST) join `(,(fetch (KEYITEM ID) of ITEM) _ ,(fetch (KEYITEM OPTEXP) of ITEM] (RETURN `(create ,MRECORD ,@SETTINGS] (RETURN `(,MRECORD ,@(fetch (EXPLIST ITEMS) of EXPLIST] (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD)) (SETQ ALIGNMENT (BUILD.ALIGN FIELDLIST EXPLIST)) [SETQ SETTINGS (COND [(type? PAIRLIST FIELDLIST) (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) as ALIGNVALUE in ALIGNMENT when [NOT (FMEMB ALIGNVALUE '(NIL TRASH] join `(,(fetch (PAIRITEM ID) of PAIRITEM) _ ,ALIGNVALUE] [(type? TYPELIST FIELDLIST) (for TYPEITEM in (fetch (TYPELIST ITEMS) of FIELDLIST) as ALIGNVALUE in ALIGNMENT as I from 1 when [NOT (FMEMB ALIGNVALUE '(NIL TRASH] join `(,(PACK* 'FIELD I) _ ,ALIGNVALUE] (T (SHOULDNT] EXIT [SETQ ANSWER `(create ,(fetch (MRECORD RECORDID) of MRECORD) ,@SETTINGS] (RETURN ANSWER]) (BUILD.ALIGN [LAMBDA (FIELDLIST EXPLIST) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) [SETQ ANSWER (COND ((AND (NULL FIELDLIST) (NULL EXPLIST)) NIL) ((EQ FIELDLIST 'ANY) (fetch (EXPLIST ITEMS) of EXPLIST)) [(type? ORDERLIST EXPLIST) (COND ((type? PAIRLIST FIELDLIST) (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) as OPTEXP in (fetch (ORDERLIST ITEMS) of EXPLIST) collect (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM) (fetch (PAIRITEM DEFAULT) of PAIRITEM) OPTEXP))) ((type? TYPELIST FIELDLIST) (for TYPEITEM in (fetch (TYPELIST ITEMS) of FIELDLIST) as OPTEXP in (fetch (ORDERLIST ITEMS) of EXPLIST) collect (BUILD.ALIGN.VALUE (fetch (TYPEITEM TYPEEXP) of TYPEITEM) (fetch (TYPEITEM DEFAULT) of TYPEITEM) OPTEXP))) (T (SHOULDNT] [(type? KEYLIST EXPLIST) (COND ((NOT (type? PAIRLIST FIELDLIST)) (SHOULDNT))) (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) collect (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM) (fetch (PAIRITEM DEFAULT) of PAIRITEM) (fetch (KEYITEM OPTEXP) of (ASSOC (fetch (PAIRITEM ID) of PAIRITEM) (fetch (KEYLIST ITEMS) of EXPLIST] (T (SHOULDNT] (RETURN ANSWER]) (BUILD.ALIGN.VALUE [LAMBDA (TYPEEXP DEFAULT OPTEXP) (* kbr%: "25-Nov-85 17:27") (PROG (ANSWER) [SETQ ANSWER (OR (COND ((AND (fetch (DEFAULT TRASH) of DEFAULT) (EQ OPTEXP 'TRASH)) 'TRASH)) (BUILD.COERCE OPTEXP TYPEEXP) (COPY (fetch (DEFAULT EXP) of DEFAULT] (RETURN ANSWER]) (BUILD.ADD.TO.FILECOMS [LAMBDA (NAME TYPE) (* kbr%: "25-Nov-85 17:27") (PROG (FILECOMSVAR FILECOMS) (SETQ FILECOMSVAR BUILD.FILECOMS) (SETQ FILECOMS (GETTOPVAL FILECOMSVAR)) (* FILECOMS is reversed at this point.  *) [COND ((AND FILECOMS (EQ (CAR (CAR FILECOMS)) TYPE)) (NCONC (CAR FILECOMS) (LIST NAME))) (T (push FILECOMS (LIST TYPE NAME] (SETTOPVAL FILECOMSVAR FILECOMS]) (BUILD.ADD1 [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") (COND ((FIXP EXP) (ADD1 EXP)) (T `(ADD1 ,EXP]) (BUILD.CALL [LAMBDA (FN EXPLIST) (* kbr%: "25-Nov-85 17:27") (* Function call. Cons FN onto front of coerced EXPLIST items.  *) (CONS FN (BUILD.ALIGN (GETPROP FN 'MESA.ARGLIST) EXPLIST]) (BUILD.CHARCODE [LAMBDA (CHARCODE) (* kbr%: "25-Nov-85 17:27") (PROG (META CONTROL CHAR NAME ANSWER) [SETQ NAME (SELECTQ CHARCODE (0 'NULL) (7 'BELL) (8 'BS) (9 'TAB) (10 'LF) (12 'FF) (13 'CR) (27 'ESC) (32 'SPACE) (127 'DEL) (PROGN [COND ((IGEQ CHARCODE 128) (SETQ META T) (SETQ CHARCODE (IDIFFERENCE CHARCODE 128] [COND ((ILESSP CHARCODE 32) (SETQ CONTROL T) (SETQ CHARCODE (IPLUS CHARCODE 32] (SETQ CHAR (MKATOM (CHARACTER CHARCODE))) (COND ((AND META CONTROL) (PACK* '%#^ CHAR)) (META (PACK* '%# CHAR)) (CONTROL (PACK* '^ CHAR)) (T CHAR] (SETQ ANSWER (LIST 'CHARCODE NAME)) (RETURN ANSWER]) (BUILD.COND [LAMBDA (EXP1 EXP2 EXP3) (* kbr%: "25-Nov-85 17:27") (PROG (HEAD TAIL ANSWER) (SETQ HEAD (CONS EXP1 (BUILD.TAIL EXP2))) [SETQ TAIL (COND ((NULL EXP3) NIL) ((AND (LISTP EXP3) (EQ (CAR EXP3) 'COND)) (CDR EXP3)) (T `((T ,@(BUILD.TAIL EXP3] [SETQ ANSWER `(COND ,HEAD ,@TAIL] (RETURN ANSWER]) (BUILD.COPY.OF [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") (COND ((AND (LISTP EXP) (EQ (CAR EXP) 'SETQ)) (CADR EXP)) (T (COPY EXP]) (BUILD.FETCH [LAMBDA (RECORDNAME FIELDNAME DATUM) (* kbr%: "25-Nov-85 17:27") (PROG (MRECORD ANSWER) [SETQ MRECORD (COND (RECORDNAME (BUILD.REFINE.TYPE RECORDNAME)) (T (BUILD.ULTIMATE.TYPE DATUM] [SETQ ANSWER (COND [(type? MRECORD MRECORD) (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD)) `(fetch (,RECORDNAME ,FIELDNAME) of ,DATUM] (T (printout T T "Bad fetch " RECORDNAME " " FIELDNAME " " DATUM T) (LIST FIELDNAME DATUM] (RETURN ANSWER]) (BUILD.FORCLAUSE.BY [LAMBDA (CONTROLID EXP1 EXP2) (* kbr%: "25-Nov-85 17:27") `(for ,CONTROLID _ ,EXP1 by ,EXP2]) (BUILD.FORCLAUSE.IN [LAMBDA (CONTROLID DIRECTION RANGE) (* kbr%: "25-Nov-85 17:27") (PROG (INTERVAL LBOUND UBOUND ANSWER) (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE)) (SETQ LBOUND (fetch (MINTERVAL LBOUND) of INTERVAL)) (SETQ UBOUND (fetch (MINTERVAL UBOUND) of INTERVAL)) (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL) (CC) (CO (SETQ UBOUND (BUILD.SUB1 UBOUND))) (OC (SETQ LBOUND (BUILD.ADD1 LBOUND))) (OO (SETQ LBOUND (BUILD.ADD1 LBOUND)) (SETQ UBOUND (BUILD.SUB1 UBOUND))) (SHOULDNT)) [SETQ ANSWER (COND ((EQ DIRECTION 'DECREASING) `(for ,CONTROLID from ,LBOUND to ,UBOUND by -1)) (T `(for ,CONTROLID from ,LBOUND to ,UBOUND] (RETURN ANSWER]) (BUILD.FORCLAUSE.THROUGH [LAMBDA (RANGE) (* kbr%: "25-Nov-85 17:27") (BUILD.FORCLAUSE.IN 'X NIL RANGE]) (BUILD.IN [LAMBDA (EXP RANGE) (* kbr%: "25-Nov-85 17:28") (PROG (INTERVAL EXP2 LPRED UPRED ANSWER) (SETQ RANGE (BUILD.REFINE.TYPE RANGE)) [COND ((NOT (type? MRANGE RANGE)) (printout T T RANGE " not a range." T) (RETURN `(in ,RANGE] (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE)) (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL) (CC (SETQ LPRED 'IGEQ) (SETQ UPRED 'ILEQ)) (CO (SETQ LPRED 'IGEQ) (SETQ UPRED 'ILESSP)) (OC (SETQ LPRED 'IGREATERP) (SETQ UPRED 'ILEQ)) (OO (SETQ LPRED 'ILESSP) (SETQ UPRED 'IGREATERP)) (SHOULDNT)) (SETQ EXP2 (BUILD.COPY.OF EXP)) [SETQ ANSWER `(AND (,LPRED ,EXP ,(fetch (MINTERVAL LBOUND) of INTERVAL)) (,UPRED ,EXP2 ,(fetch (MINTERVAL UBOUND) of INTERVAL] (RETURN ANSWER]) (BUILD.ISTYPE [LAMBDA (EXP TYPE) (* kbr%: "25-Nov-85 17:28") (PROG (MRECORD RECORDID ANSWER) (SETQ MRECORD (BUILD.REFINE.TYPE TYPE)) (SETQ RECORDID (COND ((type? MRECORD MRECORD) (fetch (MRECORD RECORDID) of MRECORD)) (T (printout T T "Bad istype " EXP " " TYPE T) TYPE))) [SETQ ANSWER `(type? ,TYPE ,EXP] (RETURN ANSWER]) (BUILD.LAMBDA [LAMBDA (PAIRLIST BODY) (* kbr%: "25-Nov-85 17:28") (PROG (ARGLIST ANSWER) [SETQ ARGLIST (for ITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID) of ITEM] [SETQ ANSWER `(LAMBDA ,ARGLIST ,@(BUILD.TAIL BODY] (RETURN ANSWER]) (BUILD.NEW [LAMBDA (TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:28") (BUILD.COERCE INITIALIZATION TYPEEXP]) (BUILD.OR [LAMBDA (EXPS) (* kbr%: "25-Nov-85 17:28") (COND ((NULL EXPS) T) ((NULL (CDR EXPS)) (CAR EXPS)) (T `(OR ,@EXPS]) (BUILD.PROG [LAMBDA (STATEMENTLIST) (* kbr%: "25-Nov-85 17:28") (PROG (VARS LAST ANSWER) [SETQ ANSWER (APPEND (fetch (SCOPE INITLIST) of BUILD.CURRENT.SCOPE) (BUILD.TAIL (BUILD.PROGN STATEMENTLIST] (SETQ VARS (APPEND (fetch (SCOPE VARLIST) of BUILD.CURRENT.SCOPE) (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE))) [COND [(OR VARS (fetch (SCOPE RETURNS) of BUILD.CURRENT.SCOPE) (for EXP in ANSWER thereis (LITATOM EXP))) (* Local vars, return, or go here.  *) [COND (ANSWER (SETQ LAST (CAR (LAST ANSWER] [COND ([NOT (OR (NULL (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE)) (AND (LISTP LAST) (FMEMB (CAR LAST) '(GO RETURN] (SETQ ANSWER (APPEND ANSWER (LIST (BUILD.RETURN] (SETQ ANSWER `(PROG ,VARS ,@ANSWER] (T (SETQ ANSWER (BUILD.PROGN ANSWER] (RETURN ANSWER]) (BUILD.PROGN [LAMBDA (EXPS) (* kbr%: "25-Nov-85 17:28") (COND ((NULL EXPS) NIL) ((NULL (CDR EXPS)) (CAR EXPS)) (T (CONS 'PROGN (for EXP in EXPS join (BUILD.TAIL EXP]) (BUILD.REPLACE [LAMBDA (RECORDNAME FIELDNAME DATUM VALUE) (* kbr%: "25-Nov-85 17:28") (PROG (MRECORD ANSWER) [SETQ MRECORD (COND (RECORDNAME (BUILD.REFINE.TYPE RECORDNAME)) (T (BUILD.ULTIMATE.TYPE DATUM] [SETQ ANSWER (COND [(type? MRECORD MRECORD) (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD)) `(replace (,RECORDNAME ,FIELDNAME) of ,DATUM with ,VALUE] (T (printout T T "Bad replace " RECORDNAME " " FIELDNAME " " DATUM " " VALUE T) (LIST FIELDNAME DATUM] (RETURN ANSWER]) (BUILD.RETURN [LAMBDA (OPTARGS) (* kbr%: "25-Nov-85 17:28") (* COPY so DEDIT won't get confused by shared structure.  *) (PROG (SCOPE FN PROCID FIELDLIST EXPLIST ALIGNMENT ANSWER) (* Get scope of innermost PROC or DO.  *) (SETQ SCOPE (for SCOPE in (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK) thereis (fetch (SCOPE ID) of SCOPE))) (replace (SCOPE RETURNS) of SCOPE with T) (SETQ FN (fetch (SCOPE ID) of SCOPE)) [SETQ ALIGNMENT (COND ((EQ FN 'DO) OPTARGS) (OPTARGS (SETQ PROCID (BUILD.PROCID BUILD.PREFIX FN)) [SETQ FIELDLIST (OR (GETPROP PROCID 'MESA.RETURNLIST) (PROGN (printout T T "No returnlist for " PROCID "." T) 'ANY] (BUILD.ALIGN FIELDLIST OPTARGS)) (T (fetch (SCOPE RETURNVARS) of SCOPE] [SETQ ANSWER (COND ((NULL ALIGNMENT) (LIST 'RETURN)) [(NULL (CDR ALIGNMENT)) `(RETURN ,@ALIGNMENT] (T `(RETURN (LIST ,@ALIGNMENT] (RETURN ANSWER]) (BUILD.SELECTQ [LAMBDA (CASEHEAD CLAUSES OTHERWISE) (* kbr%: "25-Nov-85 17:28") (PROG (ID EXP OPTEXP TYPE FN CCLAUSES SCLAUSES ANSWER) (SETQ ID (fetch (CASEHEAD ID) of CASEHEAD)) (SETQ EXP (fetch (CASEHEAD EXP) of CASEHEAD)) (SETQ OPTEXP (fetch (CASEHEAD OPTEXP) of CASEHEAD)) (SETQ EXP (OR OPTEXP ID EXP)) (COND ((EQ EXP T) (* Mesa SELECT TRUE FROM statement.  *) (SETQ ANSWER (BUILD.SELECTTRUEFROM CLAUSES OTHERWISE)) (RETURN ANSWER))) (SETQ TYPE (BUILD.ULTIMATE.TYPE EXP)) (SETQ FN (BUILD.SELECTQ.FN TYPE)) [for CLAUSE in CLAUSES do (COND ([for CASETEST in (CAR CLAUSE) thereis (COND ((AND (LISTP CASETEST) (FMEMB (CAR CASETEST) '(IN type?] (push CCLAUSES CLAUSE)) (T (push SCLAUSES CLAUSE] (SETQ CCLAUSES (DREVERSE CCLAUSES)) (SETQ SCLAUSES (DREVERSE SCLAUSES)) (SETQ CCLAUSES (for CCLAUSE in CCLAUSES collect (BUILD.SELECTQ.CCLAUSE EXP CCLAUSE TYPE))) (SETQ SCLAUSES (for SCLAUSE in SCLAUSES collect (BUILD.SELECTQ.SCLAUSE SCLAUSE TYPE))) (SETQ ANSWER (COND [SCLAUSES `(,FN ,EXP ,@SCLAUSES ,OTHERWISE] (T OTHERWISE))) (SETQ ANSWER (COND [CCLAUSES (COND [ANSWER `(COND ,@CCLAUSES (T ,@(BUILD.TAIL ANSWER] (T `(COND ,@CCLAUSES] (T ANSWER))) (RETURN ANSWER]) (BUILD.SELECTQ.FN [LAMBDA (TYPE) (* kbr%: "25-Nov-85 17:28") (COND ((EQ TYPE 'CHARACTER) 'SELCHARQ) (T 'SELECTQ]) (BUILD.SELECTQ.CCLAUSE [LAMBDA (EXP CCLAUSE TYPE) (* kbr%: "25-Nov-85 17:28") (PROG (EXP2 KEYS TESTS ANSWER) (SETQ EXP2 (BUILD.COPY.OF EXP)) (SETQ KEYS (CAR CCLAUSE)) [SETQ TESTS (CONS (BUILD.SELECTQ.TEST EXP (CAR KEYS)) (for KEY in (CDR KEYS) collect (BUILD.SELECTQ.TEST EXP KEY] [COND ((NULL (CDR TESTS)) (SETQ TESTS (CAR TESTS))) (T (SETQ TESTS (CONS 'OR TESTS] (SETQ ANSWER (CONS TESTS (CDR CCLAUSE))) (RETURN ANSWER]) (BUILD.SELECTQ.TEST [LAMBDA (EXP KEY) (* kbr%: "25-Nov-85 17:28") (COND ((AND (LISTP KEY) (EQ (CAR KEY) 'IN)) (BUILD.IN EXP (CADR KEY))) ((AND (LISTP KEY) (EQ (CAR KEY) 'type?)) KEY) (T `(FMEMB ,EXP ',KEY]) (BUILD.SELECTQ.SCLAUSE [LAMBDA (SCLAUSE TYPE) (* kbr%: "25-Nov-85 17:28") (PROG (KEYS ANSWER) (SETQ KEYS (CAR SCLAUSE)) (SETQ KEYS (for KEY in KEYS collect (BUILD.SELECTQ.KEY KEY TYPE))) [COND ((NULL (CDR KEYS)) (SETQ KEYS (CAR KEYS] (SETQ ANSWER (CONS KEYS (CDR SCLAUSE))) (RETURN ANSWER]) (BUILD.SELECTQ.KEY [LAMBDA (KEY TYPE) (* kbr%: "25-Nov-85 17:28") (COND ((EQ TYPE 'CHARACTER) (COND [(LISTP KEY) (COND ((EQ (CAR KEY) 'CHARCODE) (CADR KEY)) ((EQ (CAR KEY) 'IN) (LIST 'IN (LIST (CAR (CADR KEY)) (BUILD.SELECTQ.KEY (CADR (CADR KEY)) 'CHARACTER) (BUILD.SELECTQ.KEY (CADDR (CADR KEY)) 'CHARACTER] (T KEY))) (T KEY]) (BUILD.SELECTTRUEFROM [LAMBDA (CLAUSES OTHERWISE) (* kbr%: "25-Nov-85 17:28") (PROG (ANSWER) (SETQ CLAUSES (for CLAUSE in CLAUSES collect (BUILD.SELECTTRUEFROM.CLAUSE CLAUSE))) (SETQ ANSWER (COND [CLAUSES (COND [OTHERWISE `(COND ,@CLAUSES (T ,@(BUILD.TAIL OTHERWISE] (T `(COND ,@CLAUSES] (T OTHERWISE))) (RETURN ANSWER]) (BUILD.SELECTTRUEFROM.CLAUSE [LAMBDA (CLAUSE) (* kbr%: "25-Nov-85 17:28") (CONS (BUILD.OR (CAR CLAUSE)) (CDR CLAUSE]) (BUILD.SETQ [LAMBDA (LHS RHS) (* kbr%: "25-Nov-85 17:28") (PROG (TYPE ANSWER) (COND ((type? ORDERLIST LHS) (SETQ ANSWER (BUILD.SETQ.ORDERLIST LHS RHS)) (RETURN ANSWER))) (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS)) (SETQ RHS (BUILD.COERCE RHS TYPE)) [SETQ ANSWER (COND ((NULL LHS) RHS) ((type? MARRAY TYPE) (BUILD.SETQ.ARRAY LHS RHS)) [(LISTP LHS) (SELECTQ (CAR LHS) (ELT `(SETA ,(CADR LHS) ,(CADDR LHS) ,RHS)) (fetch `(replace ,@(CDR LHS) with ,RHS)) (NTHCHARCODE `(RPLCHARCODE ,(CADR LHS) ,(CADDR LHS) ,RHS)) (PROGN (printout T "Bad setq " LHS " " RHS) (COND [(IEQP (LENGTH LHS) 2) (COND [(FIXP (CADR LHS)) (* Guess array access.  *) `(SETA ,(CAR LHS) ,(CADR LHS) ,RHS] (T (* Guess record access.  *) (BUILD.REPLACE NIL (CAR LHS) (CADR LHS) RHS] (T (* Guess it could be anything.  *) `(SETQ ,LHS ,RHS] (T `(SETQ ,LHS ,RHS] (RETURN ANSWER]) (BUILD.SETQ.ARRAY [LAMBDA (LHS RHS) (* kbr%: "25-Nov-85 17:28") (* SETQ array LHS. I.e., FILLARRAY.  *) (PROG (EXPS ANSWER) (COND ((NOT (type? ORDERLIST RHS)) (printout T T "Bad setq array " LHS " " RHS T) [SETQ ANSWER `(SETQ ,LHS ,RHS] (RETURN ANSWER))) (SETQ EXPS (for ORDERITEM in (fetch (ORDERLIST ITEMS) of RHS) as I from 0 collect (BUILD.SETQ `(ELT ,LHS ,I) ORDERITEM))) (SETQ ANSWER (BUILD.PROGN EXPS)) (RETURN ANSWER]) (BUILD.SETQ.ORDERLIST [LAMBDA (ORDERLIST RHS) (* kbr%: "25-Nov-85 17:28") (* SETQ orderlist ORDERLIST.  *) (PROG (ORDERITEMS TEMP TEMPPOS EXPS ANSWER) (* Get ORDERITEMS *) (SETQ ORDERITEMS (fetch (ORDERLIST ITEMS) of ORDERLIST)) (COND ((NULL ORDERITEMS) (RETURN RHS)) ((NULL (CDR ORDERITEMS)) [SETQ ANSWER (BUILD.SETQ (CAR ORDERITEMS) `(CAR ,RHS] (RETURN ANSWER))) (* Get TEMPorary variable.  *) (SETQ TEMP (CAR RHS)) (SETQ TEMPPOS (STRPOS "." TEMP)) [COND (TEMPPOS (SETQ TEMP (SUBATOM TEMP (ADD1 TEMPPOS) -1] (* Get EXPS. *) [SETQ EXPS (COND [(ILEQ (LENGTH ORDERITEMS) 3) (for ID in ORDERITEMS when ID as ACCESS in '(CAR CADR CADDR) collect (BUILD.SETQ ID `(,ACCESS ,TEMP] (T (for ID in ORDERITEMS when ID collect (BUILD.SETQ ID `(POP ,TEMP] [push EXPS `(SETQ ,TEMP ,RHS] (* Build PROGN ANSWER.  *) (SETQ ANSWER (BUILD.PROGN EXPS)) (RETURN ANSWER]) (BUILD.SUB1 [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:28") (COND ((FIXP EXP) (SUB1 EXP)) (T `(SUB1 ,EXP]) (BUILD.TAIL [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:28") (COND ((NULL EXP) NIL) ((AND (LISTP EXP) (EQ (CAR EXP) 'PROGN)) (CDR EXP)) (T (LIST EXP]) ) (BUILD.INIT) (PRETTYCOMPRINT MESATOLISPCOMS) (RPAQQ MESATOLISPCOMS [ (* ;; "MESATOLISP -- By Kelly Roach. Lyricized by L. Masinter") (COMS (* ;;; "SCAN: reading mesa/cedar files") [INITVARS (SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE 'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0)) (SCAN.CHAR NIL) (SCAN.QDOT NIL) (SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE %[ %] ^ _ { %| } ~)) (SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED UNCHECKED UNSAFE)) (SCAN.MESA.RESERVED '(RESIDENT] (FNS SCAN.INIT SCAN.START SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR SCAN.HEX SCAN.FLOATING SCAN.ESCAPE) (P (SCAN.INIT))) (COMS (* ; "PARSE *") [INITVARS (PARSE.FILELST NIL) (PARSE.STREAM NIL) (PARSE.FILECOMS NIL) (PARSE.LANGUAGE NIL) (PARSE.DIRLST NIL) (PARSE.CLASS NIL) (PARSE.ATOM NIL) (PARSE.CLASS2 NIL) (PARSE.ATOM2 NIL) (PARSE.CASEHEAD.FIRST '(WITH SELECT)) (PARSE.DEFHEAD.FIRST '(DEFINITIONS)) (PARSE.DEPENDENT.FIRST '(MACHINE)) (PARSE.DOTEST.FIRST '(UNTIL WHILE)) (PARSE.FORCLAUSE.FIRST '(FOR THROUGH)) (PARSE.HEAP.FIRST '(UNCOUNTED)) (PARSE.INTERVAL.FIRST '(%( %[)) (PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~)) (PARSE.ORDERED.FIRST '(ORDERED)) (PARSE.ORDERLIST.FOLLOW '(! ; END %] })) (PARSE.PACKED.FIRST '(PACKED)) (PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)) (PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT)) (PARSE.QUALIFIER.FIRST '(%. %[ ^)) (PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL WHILE %] })) (PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START TRANSFER)) (PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL)) (PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START)) (PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {)) (PARSE.TYPEOP.FIRST '(FIRST LAST NILL)) (PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE)) (PARSE.CATCHLIST.FOLLOW '(END %] })) (PARSE.CONTROLID.FOLLOW '(DECREASING IN _)) (PARSE.DECLIST.FOLLOW '(; END })) (PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] })) (PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED })) (PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES)) (PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })) (PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] })) (PARSE.SCOPE.FOLLOW '(END EXITS })) (PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT })) (PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF SHARES %] _ })) (PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION INT INTEGER MDSZone MONITORLOCK NAT REAL STRING StringBody UNSPECIFIED WORD)) (PARSE.RELOPS (LIST '= '%# '< '<= '> '>=)) (PARSE.ADDOPS (LIST '+ '-)) (PARSE.MULTOPS (LIST '* '/ 'MOD)) (PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK)) (PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)) (PARSE.TYPEOPS '(FIRST LAST NILL)) (PARSE.NOTS '(~ NOT] (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM MPOINTER CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST EXPLIST) (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE PARSE.ARGLIST PARSE.RETURNLIST)) (COMS (* ;; "BUILD ") [INITVARS (BUILD.NEXT.SCOPE NIL) (BUILD.CURRENT.SCOPE NIL) (BUILD.SCOPE.STACK NIL) (BUILD.PREFIX NIL) (BUILD.FILECOMS NIL) (BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP GEQ LEQ)) (BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR LOGXOR NTHCHARCODE SUB1)) (BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER TIMES)) (BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES LOG SIN SQRT TAN)) (BUILD.QUALIFY.WORDS '(FREE NEW SIZE)) [BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP) (CONS '%# 'IEQP) (CONS '< 'ILESSP) (CONS '<= 'ILEQ) (CONS '> 'IGREATERP) (CONS '>= 'IGEQ) (CONS '+ 'IPLUS) (CONS '- 'IDIFFERENCE) (CONS '* 'ITIMES) (CONS '/ 'IQUOTIENT) (CONS '0- 'IMINUS) (CONS 'MAX 'IMAX) (CONS 'MIN 'IMIN) (CONS 'MOD 'IMOD] [BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP) (CONS '%# 'EQP) (CONS '< 'LESSP) (CONS '<= 'GREATERP) (CONS '> 'GREATERP) (CONS '>= 'LESSP) (CONS '+ 'PLUS) (CONS '- 'DIFFERENCE) (CONS '* 'TIMES) (CONS '/ 'QUOTIENT) (CONS '0- 'MINUS) (CONS 'MAX 'MAX) (CONS 'MIN 'MIN) (CONS 'MOD 'IMOD] [BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP) (CONS '%# 'FEQP) (CONS '< 'FLESSP) (CONS '<= 'FGREATERP) (CONS '> 'FGREATERP) (CONS '>= 'FLESSP) (CONS '+ 'FPLUS) (CONS '- 'FDIFFERENCE) (CONS '* 'FTIMES) (CONS '/ 'FQUOTIENT) (CONS '0- 'FMINUS) (CONS 'MAX 'FMAX) (CONS 'MIN 'FMIN) (CONS 'MOD 'IMOD] (BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD] (RECORDS SCOPE) (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL) (P (BUILD.INIT))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PARSE.BIN PARSE.FILE PARSE.CEDAR]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PARSE.BIN PARSE.FILE PARSE.CEDAR) ) (PUTPROPS MESATOLISP COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (19182 54761 (SCAN.INIT 19192 . 19601) (SCAN.START 19603 . 19785) (SCAN.TEST 19787 . 20251) (SCAN.TESTFILE 20253 . 20746) (SCAN.OPENSTREAM 20748 . 21252) (SCAN.TOKEN 21254 . 32584) ( SCAN.NUMBER 32586 . 36881) (SCAN.ACCEPT 36883 . 37101) (SCAN.APPENDDECIMAL 37103 . 37792) ( SCAN.APPENDOCTAL 37794 . 38356) (SCAN.APPENDHEX 38358 . 39122) (SCAN.APPENDTOSCALE 39124 . 39808) ( SCAN.VALIDFRACTION 39810 . 40403) (SCAN.DECIMAL 40405 . 42476) (SCAN.OCTAL 42478 . 44543) ( SCAN.OCTALCHAR 44545 . 45852) (SCAN.HEX 45854 . 48496) (SCAN.FLOATING 48498 . 52403) (SCAN.ESCAPE 52405 . 54759)) (59379 203256 (PARSE.MESA 59389 . 59541) (PARSE.CEDAR 59543 . 59715) (PARSE.FILE 59717 . 60284) (PARSE.GET.STATE 60286 . 61074) (PARSE.SET.STATE 61076 . 62387) (PARSE.BIN 62389 . 63223) ( PARSE.VARID 63225 . 63384) (PARSE.SMURF 63386 . 64515) (PARSE.THISIS.MESA 64517 . 64797) ( PARSE.THISIS.CEDAR 64799 . 65082) (PARSE.MODULE 65084 . 66127) (PARSE.INCLUDEITEM 66129 . 67429) ( PARSE.INCLUDECHECK 67431 . 68401) (PARSE.SEADIRT 68403 . 68792) (PARSE.PROGHEAD 68794 . 69523) ( PARSE.RESIDENT 69525 . 69925) (PARSE.SAFE 69927 . 70400) (PARSE.DEFHEAD 70402 . 70889) (PARSE.TILDE 70891 . 71346) (PARSE.DEFINITIONS 71348 . 71585) (PARSE.DEFBODY 71587 . 72486) (PARSE.LOCKS 72488 . 72925) (PARSE.LAMBDA 72927 . 73472) (PARSE.MODULEITEM 73474 . 74008) (PARSE.DECLARATION 74010 . 76112) (PARSE.PUBLIC 76114 . 76485) (PARSE.ENTRY 76487 . 76854) (PARSE.IDLIST 76856 . 77416) ( PARSE.IDENTLIST 77418 . 79049) (PARSE.POSITION 79051 . 79489) (PARSE.OPTBITS 79491 . 79866) ( PARSE.INTERVAL 79868 . 81120) (PARSE.TYPEEXP.HERE 81122 . 81252) (PARSE.TYPEEXP 81254 . 82083) ( PARSE.RANGE 82085 . 83410) (PARSE.TYPEAPPL 83412 . 83919) (PARSE.TYPEAPPL.CONT 83921 . 84674) ( PARSE.TYPEID 84676 . 84838) (PARSE.TYPEID.CONT 84840 . 85782) (PARSE.TYPECONS 85784 . 86003) ( PARSE.TYPECONS1 86005 . 87479) (PARSE.TYPECONS.CONT 87481 . 89721) (PARSE.TYPECONS.RANGE 89723 . 90085 ) (PARSE.TYPECONS.RELATIVE 90087 . 90476) (PARSE.TYPECONS.PAINTED 90478 . 90900) (PARSE.TYPECONS2 90902 . 93362) (PARSE.TYPECONS.INTERVAL 93364 . 93760) (PARSE.TYPECONS.DEPENDENT 93762 . 94424) ( PARSE.TYPECONS.ENUMERATED 94426 . 94800) (PARSE.TYPECONS.RECORD 94802 . 95191) (PARSE.TYPECONS.ORDERED 95193 . 95622) (PARSE.TYPECONS.VAR 95624 . 96022) (PARSE.TYPECONS.PACKED 96024 . 96691) ( PARSE.TYPECONS.DESCRIPTOR 96693 . 97260) (PARSE.TYPECONS.SAFE 97262 . 97706) (PARSE.TYPECONS.HEAP 97708 . 98006) (PARSE.TYPECONS.LONG 98008 . 98327) (PARSE.TYPECONS.FRAME 98329 . 98807) ( PARSE.TYPECONS.REF 98809 . 99718) (PARSE.TYPECONS.LIST 99720 . 100302) (PARSE.IDENT 100304 . 100807) ( PARSE.ELEMENT 100809 . 101464) (PARSE.MONITORED 101466 . 101823) (PARSE.DEPENDENT 101825 . 102251) ( PARSE.RECLIST 102253 . 104422) (PARSE.VARIANTPAIR 104424 . 105219) (PARSE.PAIRITEM 105221 . 106764) ( PARSE.DEFAULTOPT 106766 . 107902) (PARSE.VARIANTPART 107904 . 109341) (PARSE.VCASEHEAD 109343 . 110179 ) (PARSE.TAGTYPE 110181 . 110490) (PARSE.VARIANTITEM 110492 . 110918) (PARSE.TYPELIST 110920 . 112135) (PARSE.TYPEITEM 112137 . 112690) (PARSE.POINTERTYPE 112692 . 113443) (PARSE.TRANSFERMODE 113445 . 114181) (PARSE.INITIALIZATION 114183 . 115006) (PARSE.INITVALUE 115008 . 116738) (PARSE.CHECKED 116740 . 117329) (PARSE.CODELIST 117331 . 117727) (PARSE.STATEMENT 117729 . 117959) (PARSE.STATEMENT1 117961 . 119184) (PARSE.STATEMENT2 119186 . 122631) (PARSE.STATEMENT.CASEHEAD 122633 . 123653) ( PARSE.STATEMENT.FORCLAUSE 123655 . 124768) (PARSE.STATEMENT.RETURN 124770 . 125149) ( PARSE.STATEMENT.TRANSFER 125151 . 125525) (PARSE.STATEMENT.LBRACKET 125527 . 126007) ( PARSE.STATEMENT.IF 126009 . 126595) (PARSE.BLOCK 126597 . 127191) (PARSE.SCOPE 127193 . 127945) ( PARSE.BINDITEM 127947 . 128924) (PARSE.EXITS 128926 . 129301) (PARSE.CASESTMTITEM 129303 . 129821) ( PARSE.CASEEXPITEM 129823 . 130249) (PARSE.EXITITEM 130251 . 130699) (PARSE.CASETEST 130701 . 131268) ( PARSE.CONTROLID 131270 . 131909) (PARSE.FORCLAUSE 131911 . 133290) (PARSE.DIRECTION 133292 . 133651) ( PARSE.DOTEST 133653 . 134147) (PARSE.DOEXIT 134149 . 135169) (PARSE.ENABLES 135171 . 136397) ( PARSE.CATCHLIST 136399 . 137433) (PARSE.CATCHCASE 137435 . 137867) (PARSE.OPTARGS 137869 . 138471) ( PARSE.TRANSFER 138473 . 139189) (PARSE.KEYITEM 139191 . 139969) (PARSE.OPTEXP 139971 . 140612) ( PARSE.EXP 140614 . 140818) (PARSE.EXP1 140820 . 141490) (PARSE.EXP2 141492 . 143831) ( PARSE.EXP.TRANSFEROP 143833 . 144203) (PARSE.EXP.IF 144205 . 144712) (PARSE.EXP.CASEHEAD 144714 . 145311) (PARSE.EXP.LHS 145313 . 145686) (PARSE.EXP.LBRACKET 145688 . 146148) (PARSE.EXP.ERROR 146150 . 146394) (PARSE.EXP.DISJUNCT 146396 . 146628) (PARSE.DISJUNCT 146630 . 147337) (PARSE.CONJUNCT 147339 . 148050) (PARSE.NEGATION 148052 . 148582) (PARSE.RELATION 148584 . 149671) (PARSE.SUM 149673 . 151062) (PARSE.PRODUCT 151064 . 152814) (PARSE.OPTRELATION 152816 . 153620) (PARSE.RELATIONTAIL 153622 . 154261) (PARSE.RELOP 154263 . 154661) (PARSE.ADDOP 154663 . 154888) (PARSE.MULTOP 154890 . 155196) (PARSE.FACTOR 155198 . 155767) (PARSE.PRIMARY 155769 . 158651) (PARSE.ATOM 158653 . 158899) ( PARSE.PRIMARY.NIL 158901 . 159141) (PARSE.PRIMARY.LBRACKET 159143 . 159493) (PARSE.PRIMARY.PREFIXOP 159495 . 160061) (PARSE.PRIMARY.VAL 160063 . 160533) (PARSE.PRIMARY.ALL 160535 . 161005) ( PARSE.PRIMARY.NEW 161007 . 161626) (PARSE.PRIMARY.TYPEOP 161628 . 162073) (PARSE.PRIMARY.SIZE 162075 . 162835) (PARSE.PRIMARY.ISTYPE 162837 . 163453) (PARSE.PRIMARY.AT 163455 . 163781) ( PARSE.PRIMARY.DESCRIPTOR 163783 . 164306) (PARSE.PRIMARY.CONS 164308 . 164919) (PARSE.PRIMARY.LIST 164921 . 165492) (PARSE.PRIMARY.LHS 165494 . 166806) (PARSE.PRIMARY.LHS.NEW 166808 . 167439) ( PARSE.PRIMARY.LHS.CONS 167441 . 167987) (PARSE.PRIMARY.LHS.LIST 167989 . 168499) (PARSE.QUALIFIER 168501 . 170328) (PARSE.LHS 170330 . 172571) (PARSE.QUALIFIER.HERE 172573 . 172955) (PARSE.OPTCATCH 172957 . 173398) (PARSE.TRANSFEROP 173400 . 173916) (PARSE.PREFIXOP 173918 . 174257) (PARSE.TYPEOP 174259 . 174743) (PARSE.DESCLIST 174745 . 175423) (PARSE.DIRECTORY 175425 . 176044) (PARSE.IMPORTS 176046 . 176542) (PARSE.POINTERPREFIX 176544 . 177053) (PARSE.EXPORTS 177055 . 177576) ( PARSE.FIELDLIST 177578 . 178417) (PARSE.USING 178419 . 179118) (PARSE.CATCHHEAD 179120 . 179975) ( PARSE.DECLIST 179977 . 180828) (PARSE.PAIRLIST 180830 . 181860) (PARSE.VARIANTLIST 181862 . 182556) ( PARSE.ORDERLIST 182558 . 183281) (PARSE.LHSLIST 183283 . 183820) (PARSE.INCLUDELIST 183822 . 184373) ( PARSE.MODULELIST 184375 . 185140) (PARSE.ELEMENTLIST 185142 . 185722) (PARSE.BINDLIST 185724 . 186299) (PARSE.STATEMENTLIST 186301 . 187188) (PARSE.CASESTMTLIST 187190 . 187990) (PARSE.CASELABEL 187992 . 189129) (PARSE.EXITLIST 189131 . 189981) (PARSE.KEYLIST 189983 . 190606) (PARSE.CASEEXPLIST 190608 . 191400) (PARSE.EXPLIST 191402 . 191952) (PARSE.OPEN 191954 . 192427) (PARSE.CLASS 192429 . 192684) ( PARSE.CASEHEAD 192686 . 193790) (PARSE.READONLY 193792 . 194144) (PARSE.ORDERED 194146 . 194493) ( PARSE.BASE 194495 . 194762) (PARSE.PACKED 194764 . 195041) (PARSE.HEAP 195043 . 195438) (PARSE.INLINE 195440 . 195717) (PARSE.ARGUMENTS 195719 . 196002) (PARSE.INTERFACE 196004 . 196383) (PARSE.SHARES 196385 . 196773) (PARSE.DEFAULT 196775 . 197152) (PARSE.OPTSIZE 197154 . 197651) (PARSE.BOUNDS 197653 . 198036) (PARSE.LENGTH 198038 . 198394) (PARSE.INDEXTYPE 198396 . 198754) (PARSE.ELSEPART 198756 . 199140) (PARSE.OTHERPART 199142 . 199525) (PARSE.FREE 199527 . 199896) (PARSE.CATCHANY 199898 . 200296 ) (PARSE.NOT 200298 . 200519) (PARSE.NEW 200521 . 201189) (PARSE.OPTTYPE 201191 . 201581) ( PARSE.ARGLIST 201583 . 202361) (PARSE.RETURNLIST 202363 . 203254)) (207200 267345 (BUILD.INIT 207210 . 207712) (BUILD.PUSH.SCOPE 207714 . 208097) (BUILD.POP.SCOPE 208099 . 208389) (BUILD.GC.SCOPE 208391 . 208574) (BUILD.STORE.EXPORTS 208576 . 208783) (BUILD.STORE.IDENTLIST 208785 . 209006) ( BUILD.STORE.INTERFACES 209008 . 209239) (BUILD.STORE.INTERFACE 209241 . 209427) (BUILD.STORE.OPEN 209429 . 209637) (BUILD.STORE.USING 209639 . 209853) (BUILD.INITIALIZATION 209855 . 210452) ( BUILD.INITIALIZE.VARS 210454 . 210808) (BUILD.INITIALIZE.VAR 210810 . 211603) (BUILD.INITIALIZE.FN 211605 . 212407) (BUILD.INITIALIZE.RECORD 212409 . 212996) (BUILD.RECORD 212998 . 215217) (BUILD.TYPE 215219 . 215849) (BUILD.STORE.ARGLIST 215851 . 216355) (BUILD.STORE.RETURNLIST 216357 . 216879) ( BUILD.STORE.PAIRLIST 216881 . 217427) (BUILD.STORE.PAIRITEM 217429 . 217821) (BUILD.STORE.VARLIST 217823 . 218043) (BUILD.ID 218045 . 218468) (BUILD.FIELDID 218470 . 218594) (BUILD.PROCID 218596 . 218743) (BUILD.RECORDID 218745 . 218894) (BUILD.TYPEID 218896 . 219113) (BUILD.VARID 219115 . 219482) (BUILD.LOCALVARID 219484 . 219611) (BUILD.GLOBALVARID 219613 . 219765) (BUILD.ULTIMATE.TYPE 219767 . 219947) (BUILD.REFINE.TYPE 219949 . 221606) (BUILD.IMMEDIATE.TYPE 221608 . 225952) (BUILD.LOOKUP.TYPE 225954 . 226724) (BUILD.LOOKUP 226726 . 227111) (BUILD.TYPEATOM 227113 . 227307) (BUILD.QUALIFY 227309 . 228793) (BUILD.QUALIFY.PREFIXOP 228795 . 229043) (BUILD.QUALIFY.TYPEOP 229045 . 229193) ( BUILD.QUALIFY.EXPLIST 229195 . 231109) (BUILD.QUALIFY.ID 231111 . 232833) (BUILD.ARITH.EXP1 232835 . 233061) (BUILD.ARITH.EXP2 233063 . 233299) (BUILD.ARITH.EXP* 233301 . 234455) (BUILD.ARITH.ADD1SUB1 234457 . 235388) (BUILD.COERCE.ARITHOP 235390 . 235746) (BUILD.STRONGEST.TYPE.AMONG 235748 . 236236) ( BUILD.STRONGEST.TYPE 236238 . 236817) (BUILD.COERCE 236819 . 237582) (BUILD.COERCE.MARRAY 237584 . 238513) (BUILD.COERCE.MLIST 238515 . 239360) (BUILD.COERCE.EXPLIST 239362 . 241622) (BUILD.ALIGN 241624 . 244083) (BUILD.ALIGN.VALUE 244085 . 244593) (BUILD.ADD.TO.FILECOMS 244595 . 245242) ( BUILD.ADD1 245244 . 245429) (BUILD.CALL 245431 . 245736) (BUILD.CHARCODE 245738 . 247182) (BUILD.COND 247184 . 247823) (BUILD.COPY.OF 247825 . 248069) (BUILD.FETCH 248071 . 248805) (BUILD.FORCLAUSE.BY 248807 . 248975) (BUILD.FORCLAUSE.IN 248977 . 249971) (BUILD.FORCLAUSE.THROUGH 249973 . 250141) ( BUILD.IN 250143 . 251232) (BUILD.ISTYPE 251234 . 251790) (BUILD.LAMBDA 251792 . 252244) (BUILD.NEW 252246 . 252404) (BUILD.OR 252406 . 252627) (BUILD.PROG 252629 . 253951) (BUILD.PROGN 253953 . 254234) (BUILD.REPLACE 254236 . 255039) (BUILD.RETURN 255041 . 256699) (BUILD.SELECTQ 256701 . 258976) ( BUILD.SELECTQ.FN 258978 . 259175) (BUILD.SELECTQ.CCLAUSE 259177 . 259801) (BUILD.SELECTQ.TEST 259803 . 260169) (BUILD.SELECTQ.SCLAUSE 260171 . 260608) (BUILD.SELECTQ.KEY 260610 . 261303) ( BUILD.SELECTTRUEFROM 261305 . 262003) (BUILD.SELECTTRUEFROM.CLAUSE 262005 . 262196) (BUILD.SETQ 262198 . 264370) (BUILD.SETQ.ARRAY 264372 . 265145) (BUILD.SETQ.ORDERLIST 265147 . 266881) (BUILD.SUB1 266883 . 267068) (BUILD.TAIL 267070 . 267343))))) STOP \ No newline at end of file diff --git a/lispusers/MICROTEK b/lispusers/MICROTEK new file mode 100644 index 00000000..2bcb697b --- /dev/null +++ b/lispusers/MICROTEK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED " 8-Sep-88 21:43:21" {LISPUSERS}MICROTEK.\;1 63396 |changes| |to:| (FNS MT.START.SCANNING MT.SETUPSCANFILE MT.INIT MT.SHRINKFN MICROTEKSCANNER RULERX RULEX# RULERY RULEY# MT.GETLENGTH MT.CURSOR.IN MT.CURSOR.OUT MT.PRINT.STATUS MT.CHANGE.BRIGHTBAR MT.CHANGE.CONTRASTBAR MT.DRAWAREABOX MT.COMMAND.MENU MT.SCAN MT.SENDCOMMAND MT.COMPUTECHECKSUM MT.SENDACK MT.SENDNAK MT.STOP.SCANNING MT.PAGEMAP MT.QUIT MT.DISPLAY.MENU MT.CREATEBM MT.BITMAPCREATE MT.CONVERTIMAGETOBM MT.CREATE.BIG.BM MT.REPAINTWINDOW MT.RESHAPEWINDOW MT.SEND.SCAN.PARAMETERS MT.PRINT.ERROR.MSG MT.RESET) (PROPS (MICROTEK MAKEFILE-ENVIRONMENT)) |previous| |date:| "23-Jul-88 15:16:49" {PHYLUM}MEDLEY>MICROTEK.\;1) ; Copyright (c) 1987, 1988 by XEROX Corporation. All rights reserved. (PRETTYCOMPRINT MICROTEKCOMS) (RPAQQ MICROTEKCOMS ((P (FILESLOAD DLRS232C EDITBITMAP)) (* * |Microtek| |Initialization| |and| |Menu| |Functions|) (FNS MT.INIT MT.SHRINKFN MICROTEKSCANNER RULERX RULEX# RULERY RULEY# MT.GETLENGTH MT.CURSOR.IN MT.CURSOR.OUT MT.PRINT.STATUS MT.CONTROL.MENU MT.CHANGE.BRIGHTBAR MT.RAISEBRIGHTNESS MT.LOWERBRIGHTNESS MT.CHANGE.CONTRASTBAR MT.RAISECONTRAST MT.LOWERCONTRAST MT.SELECT.BACKGROUND MT.GETTRANSFRAME MT.GETWINDOW1 MT.GETWINDOW2 MT.GETWINDOW3 MT.GETWINDOW4 MT.UPDATE.HTWINDOWS MT.DRAWAREABOX) (* * |Command| |Functions|) (FNS MT.COMMAND.MENU MT.GET.OUTFILENAME MT.SCAN MT.START.SCANNING MT.SETUPSCANFILE MT.SEND.SCAN.PARAMETERS MT.SENDCOMMAND MT.COMPUTECHECKSUM MT.PRINT.ERROR.MSG MT.SENDACK MT.SENDNAK MT.STOP.SCANNING MT.RESET MT.PAGEMAP MT.QUIT) (* * |Functions| |to| |convert| |and| |print| |scanned| |images|) (FNS MT.DISPLAY.MENU MT.GET.SOURCEFILENAME MT.GET.BITMAPNAME MT.CREATEBM MT.BITMAPCREATE MT.CONVERTIMAGETOBM MT.CREATE.BIG.BM MT.CREATE.DISPLAYWINDOW MT.REPAINTWINDOW MT.RESHAPEWINDOW) (ADDVARS (|BackgroundMenuCommands| ("MicrotekScanner" (MT.INIT) "Open Microtek Scanner Command and Display windows, initilalize RS232 port and verifies Microtek Scanner is ready"))) (VARS (|BackgroundMenu| NIL)) (VARS MT.ICON MT.ICON.MASK BRIGHTBAR CONTRASTBAR INITIALBRIGHTBAR INITIALCONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW MT.POINTER) (INITVARS (MT.BAUDRATE 19200) (MT.RS232C.FRAME.TIMEOUT 2) (MT.DISPLAYFRAME (QUOTE YES)) (MT.PAPERLENGTH 4) (MT.REDUCTION 0) (MT.CONTRAST 0) (MT.BRIGHTNESS 0) (MT.GREYLEVEL 0) (MT.DATACOMPRESSION (QUOTE NO)) (MT.BACKGROUND (QUOTE HALFTONE)) (MT.WINDOW (QUOTE LINEART)) (MT.FRAME (QUOTE (0 0 40 24))) (MT.FRAME.BOX (QUOTE (0 460 200 120))) (MT.TEXTW1 (QUOTE (0 0 0 0))) (MT.TEXTW2 (QUOTE (0 0 0 0))) (MT.TEXTW3 (QUOTE (0 0 0 0))) (MT.TEXTW4 (QUOTE (0 0 0 0))) (MT.TEXTW1BOX (QUOTE (0 0 0 0))) (MT.TEXTW2BOX (QUOTE (0 0 0 0))) (MT.TEXTW3BOX (QUOTE (0 0 0 0))) (MT.TEXTW4BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW1 (QUOTE (0 0 0 0))) (MT.HALFTONEW2 (QUOTE (0 0 0 0))) (MT.HALFTONEW3 (QUOTE (0 0 0 0))) (MT.HALFTONEW4 (QUOTE (0 0 0 0))) (MT.HALFTONEW1BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW2BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW3BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW4BOX (QUOTE (0 0 0 0))) (MT.OUTSTREAM NIL) (MT.INSTREAM NIL) (MT.BMSHRINKFACTOR 1)) (GLOBALVARS MT.RS232C.FRAME.TIMEOUT MT.STATUSWINDOW MT.HEIGHTRULER MT.GRID MT.PAPERLENGTH MT.REDUCTION MT.BRIGHTNESS MT.CONTRAST MT.GREYLEVEL MT.DATACOMPRESSION MT.BACKGROUND MT.WINDOW MT.HEIGHTWINDOW MT.FRAME MT.FRAME.BOX MT.TEXTW1 MT.TEXTW2 MT.TEXTW3 MT.TEXTW4 MT.HALFTONEW1 MT.HALFTONEW2 MT.HALFTONEW3 MT.HALFTONEW4 MT.OUTSTREAM MT.INSTREAM BRIGHTBAR CONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW) (PROP MAKEFILE-ENVIRONMENT MICROTEK))) (FILESLOAD DLRS232C EDITBITMAP) (* * |Microtek| |Initialization| |and| |Menu| |Functions|) (DEFINEQ (MT.INIT (LAMBDA NIL (* \; "Edited 8-Sep-88 18:58 by Briggs") (* \; "Edited 20-May-87 11:20 by ") (MICROTEKSCANNER) (MT.CONTROL.MENU) (MT.COMMAND.MENU) (MT.DISPLAY.MENU) (SETQ MT.STATUSWINDOW (CREATEW (QUOTE (0 0 387 30)) "Microtek Status Window")) (ATTACHWINDOW MT.COMMAND.MENUWINDOW MT.CONTROL.MENUWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (ATTACHWINDOW MT.DISPLAY.MENUWINDOW MT.CONTROL.MENUWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (ATTACHWINDOW MT.STATUSWINDOW MT.COMMAND.MENUWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (|if| (FNTYP (QUOTE MT.PRINT.MENU)) |then| (MT.PRINT.MENU)) (MOVEW MT.CONTROL.MENUWINDOW (QUOTE (500 . 160))) (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONFN) (QUOTE MT.SHRINKFN)) (BITBLT MT.POINTER 0 0 MTHEIGHTRULER 20 (IDIFFERENCE 453 (FIX (FTIMES 5 (FDIFFERENCE (FQUOTIENT MT.PAPERLENGTH 0.125) 24))))) (CLOSEF? MT.OUTSTREAM) (CLOSEF? MT.INSTREAM) (|if| \\RS232C.READY |then| (RS232C.SHUTDOWN)) (SETQ MT.OUTSTREAM (OPENSTREAM (QUOTE {RS232}) (QUOTE OUTPUT) NIL (QUOTE ((|BaudRate| 19200) (|BitsPerSerialChar| 8) (|Parity| NONE) (|NoOfStopBits| 1) (|FlowControl| NIL) (DTR T))))) (SETQ MT.INSTREAM (RS232C.OTHER.STREAM MT.OUTSTREAM)) (SETQ MT.OLD.RS232C.FRAME.TIME.OUT (RS232C.GET.PARAMETERS (QUOTE (FRAME.TIMEOUT)))) (RS232C.SET.PARAMETERS (LIST (BQUOTE (FRAME.TIMEOUT \\\, MT.RS232C.FRAME.TIMEOUT)))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (|if| (SETQ RESPONSE (MT.SENDCOMMAND 1 (LIST (QUOTE !)))) |then| (CLRPROMPT) (MT.PRINT.STATUS (CONCAT RESPONSE " ready")) |else| (RINGBELLS) (MT.PRINT.STATUS "Microtek Not Responding ...Check scanner and cables"))) ) (MT.SHRINKFN (LAMBDA (WINDOW ICON) (* \; "Edited 8-Sep-88 18:59 by Briggs") (PROG NIL (CLOSEW MTDISPLAYWINDOW) (CLOSEW MTDISPLAYWINDOW) (|if| (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONWINDOW)) |then| (RETURN (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONWINDOW))) |else| (RETURN (ICONW MT.ICON MT.ICON.MASK NIL T))))) ) (MICROTEKSCANNER (LAMBDA NIL (* \; "Edited 8-Sep-88 18:59 by Briggs") (PROG (MTWIDTHRULER YHEIGHT) (SETQ MTDISPLAYWINDOW (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 350 579 "Microtek Scanner Page Map" 5)) (SETQ MTHEIGHTRULER (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 50 570 NIL 5 T)) (SETQ MTWIDTHRULER (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 350 50 NIL 5 T)) (DSPFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE BRR)) MTHEIGHTRULER) (DSPFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE BRR)) MTWIDTHRULER) (ATTACHWINDOW MTHEIGHTRULER MTDISPLAYWINDOW (QUOTE LEFT) (QUOTE JUSTIFY)) (ATTACHWINDOW MTWIDTHRULER MTDISPLAYWINDOW (QUOTE TOP) (QUOTE CENTER)) (WINDOWPROP MTDISPLAYWINDOW (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (WINDOWPROP MTHEIGHTRULER (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (WINDOWPROP MTHEIGHTRULER (QUOTE CURSORINFN) (QUOTE MT.CURSOR.IN)) (WINDOWPROP MTHEIGHTRULER (QUOTE CURSOROUTFN) (QUOTE MT.CURSOR.OUT)) (WINDOWPROP MTHEIGHTRULER (QUOTE BUTTONEVENTFN) (QUOTE MT.GETLENGTH)) (WINDOWPROP MTWIDTHRULER (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (RULERX 0 1 16 16 40 1 MTWIDTHRULER) (RULERX 0 1 12 32 20 1 MTWIDTHRULER) (RULERX 0 1 8 64 10 1 MTWIDTHRULER) (RULERX 0 1 4 128 5 1 MTWIDTHRULER) (RULEX# 0 20 40 0 8 MTWIDTHRULER) (SETQ YHEIGHT 580) (RULERY YHEIGHT 1 16 15 -40 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 12 28 -20 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 8 56 -10 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 4 112 -5 1 MTHEIGHTRULER) (RULEY# 0 YHEIGHT -40 0 14 MTHEIGHTRULER) (SETQ MT.HEIGHT.BM (BITMAPCREATE 50 588)) (BITBLT MTHEIGHTRULER 0 0 MT.HEIGHT.BM) (SETQ MT.GRID (BITMAPCREATE 350 579)) (GRID (QUOTE (0 20 10 10)) 42 56 (QUOTE POINT) MTDISPLAYWINDOW) (BITBLT MTDISPLAYWINDOW 0 0 MT.GRID))) ) (RULERX (LAMBDA (STARTX STARTY LEN NUMLINES INCR LINEWIDTH WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| 1 |to| NUMLINES |do| (DRAWLINE STARTX 1 STARTX LEN LINEWIDTH NIL WIND) (SETQ STARTX (PLUS STARTX INCR)))) ) (RULEX# (LAMBDA (STARTX STARTY INCR STARTNUMBER ENDNUMBER WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| STARTNUMBER |to| ENDNUMBER |do| (MOVETO STARTX STARTY WIND) (PRINT I WIND) (SETQ STARTX (PLUS STARTX INCR)))) ) (RULERY (LAMBDA (STARTY STARTX LEN NUMLINES INCR LINEWIDTH WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| 1 |to| NUMLINES |do| (DRAWLINE (DIFFERENCE (WINDOWPROP WIND (QUOTE WIDTH)) STARTX) STARTY (DIFFERENCE (DIFFERENCE (WINDOWPROP WIND (QUOTE WIDTH)) STARTX) LEN) STARTY LINEWIDTH NIL WIND) (SETQ STARTY (PLUS STARTY INCR)))) ) (RULEY# (LAMBDA (STARTX STARTY INCR STARTNUMBER ENDNUMBER WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| STARTNUMBER |to| ENDNUMBER |do| (MOVETO STARTX STARTY WIND) (PRINT I WIND) (SETQ STARTY (PLUS STARTY INCR)))) ) (MT.GETLENGTH (LAMBDA NIL (* \; "Edited 8-Sep-88 19:00 by Briggs") (TOTOPW MTHEIGHTRULER) (|if| (MOUSESTATE LEFT) |then| (SETQ MT.PAPERLENGTH (IMIN 453 (CDR (CURSORPOSITION NIL MTHEIGHTRULER)))) (CLEARW MTHEIGHTRULER) (BITBLT MT.HEIGHT.BM 0 0 MTHEIGHTRULER 0 0) (BITBLT MT.POINTER 0 0 MTHEIGHTRULER 20 MT.PAPERLENGTH) (SETQ MT.PAPERLENGTH (FTIMES (FIX (FPLUS 24.0 (FQUOTIENT (FDIFFERENCE 453 MT.PAPERLENGTH) 5))) 0.125)) (FM.CHANGESTATE (FM.GETITEM (QUOTE PAGELENGTH) NIL MT.CONTROL.MENUWINDOW) MT.PAPERLENGTH MT.CONTROL.MENUWINDOW))) ) (MT.CURSOR.IN (LAMBDA NIL (* \; "Edited 8-Sep-88 19:00 by Briggs") (CURSOR (CURSORCREATE MT.POINTER 8 0)))) (MT.CURSOR.OUT (LAMBDA NIL (* \; "Edited 8-Sep-88 19:00 by Briggs") (CURSOR T))) (MT.PRINT.STATUS (LAMBDA (MSG) (* \; "Edited 8-Sep-88 19:00 by Briggs") (CLEARW MT.STATUSWINDOW) (PRIN1 MSG MT.STATUSWINDOW)) ) (MT.CONTROL.MENU (LAMBDA NIL (* \; "Edited 12-Mar-87 14:32 by rdc") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID RC) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL " Grain Size Levels" BOX 1 FONT (MODERN 10 BOLD) HJUSTIFY RIGHT)) ((TYPE STATE LABEL "Reduction!" MENUITEMS (" 0% = 300 DPI" " 5% = 285 DPI" "10% = 270 DPI" "15% = 255 DPI" "20% = 240 DPI" "25% = 225 DPI" "33% = 200 DPI" "35% = 195 DPI" "40% = 180 DPI" "45% = 165 DPI" "50% = 150 DPI" "55% = 135 DPI" "60% = 120 DPI" "67% = 100 DPI" "70% = 90 DPI" "75% = 75 DPI") INITSTATE " 0% = 300 DPI" LINKS (DISPLAY (GROUP REDUCTION)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID REDUCTION LABEL "" MAXWIDTH 120 BOX 1) (TYPE STATE LABEL "Gray Level!" MENUITEMS (" 0 = 8X8 33" " 1 = 8X8 33" " 2 = 8X8 33" " 3 = 8X8 33" " 4 = 6X6 37" " 5 = 5X5 26" " 6 = 5X5 18" " 7 = 4X4 17" " 8 = 4X4 17" " 9 = 4X4 17" "10 = 3X3 10" "11 = 2X2 5") INITSTATE " 0 = 8X8 33" LINKS (DISPLAY (GROUP GREYLEVEL)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID GREYLEVEL LABEL "" MAXWIDTH 120 BOX 1)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID CD) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE DISPLAY LABEL "Contrast:" FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL \, LEFTARROW HELDFN MT.LOWERCONTRAST MESSAGE "" BOX 1) (TYPE DISPLAY LABEL \, CONTRASTBAR ID CONTRASTBAR MAXWIDTH 130 BOX 1) (TYPE DISPLAY LABEL \, RIGHTARROW HELDFN MT.RAISECONTRAST MESSAGE "" BOX 1) (TYPE EDIT ID CONTRAST LABEL 0 BOX 1 MAXWIDTH 23)) ((TYPE DISPLAY LABEL |Brightness:| FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL \, LEFTARROW HELDFN MT.LOWERBRIGHTNESS MESSAGE "" BOX 1) (TYPE DISPLAY LABEL \, BRIGHTBAR ID BRIGHTBAR MAXWIDTH 130 BOX 1) (TYPE DISPLAY LABEL \, RIGHTARROW HELDFN MT.RAISEBRIGHTNESS MESSAGE "" BOX 1) (TYPE EDIT ID BRIGHTNESS LABEL 0 BOX 1 MAXWIDTH 23)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID MODE) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE STATE LABEL "Background!" ID BACK MENUITEMS ("HALFTONE" "LINEART") INITSTATE "HALFTONE" LINKS (DISPLAY (GROUP BACKGROUNDDISPLAY)) SELECTEDFN MT.SELECT.BACKGROUND FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL "" ID BACKGROUNDDISPLAY MAXWIDTH 57 BOX 1) (TYPE DISPLAY LABEL "Window Mode:" FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOWTYPE LABEL (\\\, MT.WINDOW) MAXWIDTH 58 BOX 1) (TYPE DISPLAY LABEL "Page Length:" FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID PAGELENGTH LABEL "" BOX 1 MAXWIDTH 45)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID WINDOW) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL "Frame! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETTRANSFRAME BOX 1) (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TX1 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TY1 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TX2 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TY2 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE DISPLAY LABEL "")) ((TYPE MOMENTARY LABEL "Window 1! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW1 BOX 1) (TYPE STATE LABEL "ON?" ID SW1 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW1)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW1 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X11 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y11 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X21 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y21 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 2! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW2 BOX 1) (TYPE STATE LABEL "ON?" ID SW2 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW2)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW2 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X12 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y12 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X22 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y22 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 3! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW3 BOX 1) (TYPE STATE LABEL "ON?" ID SW3 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW3)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW3 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X13 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y13 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X23 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y23 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 4! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW4 BOX 1) (TYPE STATE LABEL "ON?" ID SW4 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW4)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW4 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X14 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y14 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X24 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y24 LABEL "" MAXWIDTH 45 BOX 1))))))) (SETQ MT.CONTROL.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Configuration Menu" 23130 5)) (FM.CHANGESTATE (FM.GETITEM (QUOTE BACK) NIL MT.CONTROL.MENUWINDOW) MT.BACKGROUND MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX1) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY1) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX2) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY2) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (MT.SELECT.BACKGROUND) (FM.CHANGESTATE (FM.GETITEM (QUOTE PAGELENGTH) NIL MT.CONTROL.MENUWINDOW) MT.PAPERLENGTH MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE REDUCTION) NIL MT.CONTROL.MENUWINDOW) MT.REDUCTION MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW) (MT.CHANGE.BRIGHTBAR MT.BRIGHTNESS) (MT.CHANGE.CONTRASTBAR MT.CONTRAST) (OPENW MT.CONTROL.MENUWINDOW))) ) (MT.CHANGE.BRIGHTBAR (LAMBDA (BRIGHTNESS) (* \; "Edited 8-Sep-88 19:01 by Briggs") (* |;;;| "Moves the cursor in BRIGHTBAR from one place to another.") (BITBLT INITIALBRIGHTBAR NIL NIL BRIGHTBAR NIL NIL NIL NIL NIL (QUOTE REPLACE)) (BITBLT MANCURSOR NIL NIL BRIGHTBAR (IPLUS 60 (FIX (TIMES BRIGHTNESS 2))) 0 10 10 NIL (QUOTE INVERT)) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTBAR) NIL MT.CONTROL.MENUWINDOW) BRIGHTBAR MT.CONTROL.MENUWINDOW)) ) (MT.RAISEBRIGHTNESS (LAMBDA NIL (* \; "Edited 5-Mar-87 13:05 by RDC") (|if| (LEQ (IPLUS MT.BRIGHTNESS 4) 28) |then| (MT.CHANGE.BRIGHTBAR (SETQ MT.BRIGHTNESS (IPLUS MT.BRIGHTNESS 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW)) ) (MT.LOWERBRIGHTNESS (LAMBDA NIL (* \; "Edited 5-Mar-87 13:04 by RDC") (|if| (GEQ (IDIFFERENCE MT.BRIGHTNESS 4) -24) |then| (MT.CHANGE.BRIGHTBAR (SETQ MT.BRIGHTNESS (IDIFFERENCE MT.BRIGHTNESS 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW)) ) (MT.CHANGE.CONTRASTBAR (LAMBDA (CONTRAST) (* \; "Edited 8-Sep-88 19:01 by Briggs") (* |;;;| "Moves the diamond cursor around inside CONTRASTBAR.") (BITBLT INITIALCONTRASTBAR NIL NIL CONTRASTBAR NIL NIL NIL NIL NIL (QUOTE REPLACE)) (BITBLT MANCURSOR NIL NIL CONTRASTBAR (IPLUS 60 (FIX (TIMES CONTRAST 2))) 0 10 10 NIL (QUOTE INVERT)) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRASTBAR) NIL MT.CONTROL.MENUWINDOW) CONTRASTBAR MT.CONTROL.MENUWINDOW)) ) (MT.RAISECONTRAST (LAMBDA NIL (* \; "Edited 5-Mar-87 13:04 by RDC") (|if| (LEQ (IPLUS MT.CONTRAST 4) 28) |then| (MT.CHANGE.CONTRASTBAR (SETQ MT.CONTRAST (IPLUS MT.CONTRAST 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW)) ) (MT.LOWERCONTRAST (LAMBDA NIL (* \; "Edited 5-Mar-87 13:03 by RDC") (|if| (GEQ (IDIFFERENCE MT.CONTRAST 4) -24) |then| (MT.CHANGE.CONTRASTBAR (SETQ MT.CONTRAST (IDIFFERENCE MT.CONTRAST 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW)) ) (MT.SELECT.BACKGROUND (LAMBDA NIL (* \; "Edited 5-Mar-87 15:09 by RDC") (SETQ MT.BACKGROUND (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) (|if| (STREQUAL MT.BACKGROUND "LINEART") |then| (FM.CHANGELABEL (FM.GETITEM (QUOTE WINDOWTYPE) NIL MT.CONTROL.MENUWINDOW) "HALFTONE" MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) |else| (FM.CHANGELABEL (FM.GETITEM (QUOTE WINDOWTYPE) NIL MT.CONTROL.MENUWINDOW) "LINEART" MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW)) (MT.UPDATE.HTWINDOWS)) ) (MT.GETTRANSFRAME (LAMBDA NIL (* \; "Edited 5-Mar-87 13:28 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX1) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY1) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX2) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY2) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (SETQ MT.FRAME (LIST X1 Y1 X2 Y2)) (SETQ MT.FRAME.BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) (MT.UPDATE.HTWINDOWS))) ) (MT.GETWINDOW1 (LAMBDA NIL (* \; "Edited 5-Mar-87 14:23 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW1 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW1BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW1 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW1BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) ) (MT.GETWINDOW2 (LAMBDA NIL (* \; "Edited 5-Mar-87 14:24 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW2 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW2BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW2 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW2BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) ) (MT.GETWINDOW3 (LAMBDA NIL (* \; "Edited 5-Mar-87 14:25 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW3 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW3BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW3 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW3BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) ) (MT.GETWINDOW4 (LAMBDA NIL (* \; "Edited 5-Mar-87 14:26 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW4 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW4BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW4 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW4BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) ) (MT.UPDATE.HTWINDOWS (LAMBDA NIL (* \; "Edited 12-Mar-87 12:29 by rdc") (PROG ((PARAMETER.LIST (FM.GETSTATE MT.CONTROL.MENUWINDOW)) (WINDOW (LIST 0 0 0 0))) (CLEARW MTDISPLAYWINDOW) (BITBLT MT.GRID 0 0 MTDISPLAYWINDOW) (MT.DRAWAREABOX (CAR MT.FRAME.BOX) (CADR MT.FRAME.BOX) (CADDR MT.FRAME.BOX) (CADDDR MT.FRAME.BOX) 2 NIL MTDISPLAYWINDOW) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW1)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW1BOX) |else| (SETQ WINDOW MT.HALFTONEW1BOX))) (BLTSHADE 2000 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW2)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW2BOX) |else| (SETQ WINDOW MT.HALFTONEW2BOX))) (BLTSHADE GRAYSHADE MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW3)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW3BOX) |else| (SETQ WINDOW MT.HALFTONEW3BOX))) (BLTSHADE 45 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW4)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW4BOX) |else| (SETQ WINDOW MT.HALFTONEW4BOX))) (BLTSHADE 50000 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)))) ) (MT.DRAWAREABOX (LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) (* \; "Edited 8-Sep-88 19:02 by Briggs") (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* \; "draws lines inside the region.") (* \; "draw left edge") (BITBLT NIL NIL NIL W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT (QUOTE TEXTURE) OP TEXTURE) (* \; "draw top") (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) BORDER) (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER (QUOTE TEXTURE) OP TEXTURE) (* \; "draw bottom") (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) BOXBOTTOM (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER (QUOTE TEXTURE) OP TEXTURE) (* \; "draw right edge") (BITBLT NIL NIL NIL W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) BORDER) BOXBOTTOM BORDER BOXHEIGHT (QUOTE TEXTURE) OP TEXTURE)) ) ) (* * |Command| |Functions|) (DEFINEQ (MT.COMMAND.MENU (LAMBDA NIL (* \; "Edited 8-Sep-88 19:02 by Briggs") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID COMMAND) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL SCAN! FONT (MODERN 12 BOLD) SELECTEDFN MT.SCAN BOX 3) (TYPE MOMENTARY LABEL STOP! FONT (MODERN 12 BOLD) SELECTEDFN MT.STOP.SCANNING BOX 3) (TYPE MOMENTARY LABEL RESET! FONT (MODERN 12 BOLD) SELECTEDFN MT.RESET BOX 3) (TYPE MOMENTARY LABEL PAGEMAP! FONT (MODERN 12 BOLD) SELECTEDFN MT.PAGEMAP BOX 3) (TYPE MOMENTARY LABEL QUIT! ID QUIT FONT (MODERN 12 BOLD) SELECTEDFN MT.QUIT BOX 3)))) ((PROPS ID COMMAND2) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL "Output Filename!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.OUTFILENAME BOX 1) (TYPE EDIT ID OUTFILENAME LABEL {DSK}IMAGE BOX 1 MAXWIDTH 375))))))) (SETQ MT.COMMAND.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Command Menu" 23130 5)) (OPENW MT.COMMAND.MENUWINDOW))) ) (MT.GET.OUTFILENAME (LAMBDA NIL (* \; "Edited 12-Mar-87 14:48 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE OUTFILENAME) NIL MT.COMMAND.MENUWINDOW) MT.COMMAND.MENUWINDOW)) ) (MT.SCAN (LAMBDA NIL (* \; "Edited 8-Sep-88 19:02 by Briggs") (ADD.PROCESS (QUOTE (MT.START.SCANNING)) (QUOTE NAME) (QUOTE MICROTEK.SCANNING))) ) (MT.START.SCANNING (LAMBDA NIL (* \; "Edited 8-Sep-88 21:36 by Briggs") (PROG (HDR DATACOUNT (SCANLINECOUNT 0) CHECKSUM NUMBEROFBYTES OUTFILESTREAM CORESTREAM SOR RT (LINEBUFFERSIZE 0) LINEBUFFER GREYLEVEL REDUCTION DATASIZE) (* |;;| "Reset the Scanner") (MT.RESET) (* |;;| "Send the scan parameters") (|if| (NOT (MT.SEND.SCAN.PARAMETERS)) |then| (MT.PRINT.STATUS "Scanning parameters not valid") (RINGBELLS) (BLOCK 2000) (MT.RESET) (RETURN NIL)) (* |;;| "Setup the Core output file") (SETQ CORESTREAM (MT.SETUPSCANFILE)) (* |;;| "Send start scanning command") (MT.SENDCOMMAND 1 (LIST (QUOTE S))) (MT.PRINT.STATUS "[scanning]") (* |;;| "Get headerof each line") AGAIN (SETQ SOR (BIN MT.INSTREAM)) (SETQ RT (BIN MT.INSTREAM)) (SETQ DATACOUNT (IPLUS (ITIMES 256 (BIN MT.INSTREAM)) (BIN MT.INSTREAM))) (SELECTQ RT ((0 4) (* |;;| "since we never NAK, we can speed up the processing by ACKing early") (MT.SENDACK) (SETQ DATASIZE DATACOUNT) (* \; "needed later") (SETQ SCANLINECOUNT (IPLUS SCANLINECOUNT 1)) (COND ((IGREATERP DATACOUNT LINEBUFFERSIZE) (SETQ LINEBUFFER (ARRAY DATACOUNT (QUOTE BYTE) 0 0)))) (AIN LINEBUFFER 0 DATACOUNT MT.INSTREAM) (AOUT LINEBUFFER 0 DATACOUNT CORESTREAM) (SETQ CHECKSUM (BIN MT.INSTREAM)) (GO AGAIN)) (128 (SELCHARQ (BIN MT.INSTREAM) (E (BIN MT.INSTREAM) (MT.SENDACK) (MT.PRINT.STATUS "[scanning done]")) (? (|to| DATACOUNT |do| (MT.PRINT.ERROR.MSG (BIN MT.INSTREAM))) (MT.SENDACK) (CLOSEF? CORESTREAM) (RETURN NIL)) NIL)) (PROGN (MT.PRINT.STATUS "[ERROR: unrecognized record type from scanner]") (RETURN NIL))) (MT.PRINT.STATUS "[copying to file]") (SETQ NUMBEROFBYTES (GETFILEPTR CORESTREAM)) (SETQ OUTFILESTREAM (OPENSTREAM (LISTGET (FM.GETSTATE MT.COMMAND.MENUWINDOW) (QUOTE OUTFILENAME)) (QUOTE OUTPUT))) (* |;;| "print header on file, the NO indicates that this file does not contain compressed data") (PRINT (QUOTE NO) OUTFILESTREAM) (SETQ REDUCTION (SUBSTRING (CADR (MEMBER "Reduction!" (FM.GETSTATE MT.CONTROL.MENUWINDOW))) 1 2)) (|if| (STREQUAL (SUBSTRING REDUCTION 1 1) " ") |then| (SETQ REDUCTION (SUBSTRING REDUCTION 2 2))) (PRINT (MKATOM REDUCTION) OUTFILESTREAM) (SETQ GREYLEVEL (SUBSTRING (CADR (MEMBER "Gray Level!" (FM.GETSTATE MT.CONTROL.MENUWINDOW))) 1 2)) (|if| (STREQUAL (SUBSTRING GREYLEVEL 1 1) " ") |then| (SETQ GREYLEVEL (SUBSTRING GREYLEVEL 2 2))) (PRINT (MKATOM GREYLEVEL) OUTFILESTREAM) (PRINT (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE CONTRAST)) OUTFILESTREAM) (PRINT (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BRIGHTNESS)) OUTFILESTREAM) (PRINT SCANLINECOUNT OUTFILESTREAM) (PRINT DATASIZE OUTFILESTREAM) (SETFILEPTR CORESTREAM 0) (COPYBYTES CORESTREAM OUTFILESTREAM NUMBEROFBYTES) (CLOSEF OUTFILESTREAM) (CLOSEF CORESTREAM) (MT.PRINT.STATUS "[done]"))) ) (MT.SETUPSCANFILE (LAMBDA NIL (* \; "Edited 8-Sep-88 21:13 by Briggs") (* |;;;| "will check to see if the scratch file is in core. If it is it will dirty 500 pages to bring them into real memory (speedup when writing to them!). If there wasn't a file, it creates it and then dirtys 500 pgs. RETURNS: stream to the file") (PROG (RECOG FILE) (MT.PRINT.STATUS "[setting up scratch file]") (SETQ FILE (OPENSTREAM (QUOTE {SCRATCH}) (QUOTE BOTH) (QUOTE NEW) (QUOTE (SEQUENTIAL T)))) (* |;;;| "now expand the file so you can read and transfer fast") (|for| I |from| 0 |to| 260000 |by| 512 |do| (SETFILEPTR FILE I) (BOUT FILE 1)) (* |;;;| "and reset to the beginning") (SETFILEPTR FILE 0) (MT.PRINT.STATUS "[scratch file set up]") (RETURN FILE))) ) (MT.SEND.SCAN.PARAMETERS (LAMBDA NIL (DECLARE (GLOBALVARS MT.CONTROL.MENUWINDOW MT.PAPERLENGTH MT.FRAME)) (* \; "Edited 8-Sep-88 18:38 by Briggs") (PROG (PARAMETER.LIST PAPERLENGTH SCANFRAME BACKGROUND GREYLEVEL CONTRAST BRIGHTNESS RESOLUTION REDUCTION DATACOMPRESSION (NO.OF.WINDOWS 0) (COORD.LIST NIL)) (SETQ PARAMETER.LIST (FM.GETSTATE MT.CONTROL.MENUWINDOW)) (SETQ PAPERLENGTH (IPLUS 24 (QUOTIENT (FDIFFERENCE MT.PAPERLENGTH 3.0) 0.125))) (SETQ SCANFRAME MT.FRAME) (|if| (EQ (MKATOM (LISTGET PARAMETER.LIST (QUOTE BACK))) (QUOTE HALFTONE)) |then| (SETQ BACKGROUND (QUOTE H)) |else| (SETQ BACKGROUND (QUOTE T))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW1)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW1 |else| MT.HALFTONEW1)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW2)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW2 |else| MT.HALFTONEW2)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW3)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW3 |else| MT.HALFTONEW3)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW4)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW4 |else| MT.HALFTONEW4)))) (|if| (STREQUAL (SUBSTRING (SETQ GREYLEVEL (SUBSTRING (CADR (MEMBER "Gray Level!" PARAMETER.LIST)) 1 2)) 1 1) " ") |then| (SETQ GREYLEVEL (SUBSTRING GREYLEVEL 2 2))) (SETQ GREYLEVEL (MKATOM GREYLEVEL)) (SETQ CONTRAST (IPLUS 7 (IQUOTIENT (MKATOM (LISTGET PARAMETER.LIST (QUOTE CONTRAST))) 4))) (SETQ BRIGHTNESS (IPLUS 7 (IQUOTIENT (MKATOM (LISTGET PARAMETER.LIST (QUOTE BRIGHTNESS))) 4))) (|if| (STREQUAL (SUBSTRING (SETQ REDUCTION (SUBSTRING (CADR (MEMBER "Reduction!" PARAMETER.LIST)) 1 2)) 1 1) " ") |then| (SETQ REDUCTION (SUBSTRING REDUCTION 2 2))) (SETQ RESOLUTION (LISTGET (QUOTE (0 16 5 17 10 18 15 19 20 20 25 21 33 22 35 23 40 24 45 25 50 26 55 27 60 28 67 29 70 30 75 31)) (MKATOM REDUCTION))) (|if| (EQ (QUOTE YES) (MKATOM (LISTGET PARAMETER.LIST (QUOTE COMPRESSDATA)))) |then| (SETQ DATACOMPRESSION 1) |else| (SETQ DATACOMPRESSION 0)) (|if| (AND (MT.SENDCOMMAND 2 (LIST (QUOTE L) PAPERLENGTH)) (MT.SENDCOMMAND 5 (APPEND (LIST (QUOTE F)) SCANFRAME)) (|if| (GREATERP NO.OF.WINDOWS 0) |then| (MT.SENDCOMMAND (IPLUS 2 (ITIMES NO.OF.WINDOWS 4)) (APPEND (LIST BACKGROUND) (LIST NO.OF.WINDOWS) COORD.LIST)) |else| (MT.SENDCOMMAND 2 (APPEND (LIST BACKGROUND) (LIST 0)))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE G)) (LIST GREYLEVEL))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE K)) (LIST CONTRAST))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE B)) (LIST BRIGHTNESS))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE R)) (LIST RESOLUTION))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE C)) (LIST DATACOMPRESSION)))) |then| (RETURN T) |else| (RETURN NIL)))) ) (MT.SENDCOMMAND (LAMBDA (DATACOUNT DATALIST) (* \; "Edited 8-Sep-88 19:03 by Briggs") (PROG (DATA RESPONSE (CHECKSUM 0) (RETRYCOUNT 0)) (* \; "SEND \\ AND 80H") RETRY (BOUT MT.OUTSTREAM (CHARCODE "\\")) (BOUT MT.OUTSTREAM 128) (BOUT MT.OUTSTREAM 0) (BOUT MT.OUTSTREAM DATACOUNT) (SETQ CHECKSUM (IPLUS CHECKSUM 128 0 DATACOUNT)) (|for| DATA |in| DATALIST |do| (|if| (NUMBERP DATA) |then| (BOUT MT.OUTSTREAM DATA) (SETQ CHECKSUM (IPLUS CHECKSUM DATA)) |else| (BOUT MT.OUTSTREAM (CAR (CHCON DATA))) (SETQ CHECKSUM (IPLUS CHECKSUM (CAR (CHCON DATA)))))) (FORCEOUTPUT MT.OUTSTREAM) (BOUT MT.OUTSTREAM (IPLUS (LOGXOR 255 CHECKSUM) 1)) (FORCEOUTPUT MT.OUTSTREAM) REREAD (BLOCK 500) (SETQ RESPONSE (|while| (READP MT.INSTREAM) |collect| (BIN MT.INSTREAM))) (|if| (AND (NEQ (CAR RESPONSE) 92) (NEQ (CAR RESPONSE) 6)) |then| (SETQ CHECKSUM 0) (SETQ RETRYCOUNT (IPLUS RETRYCOUNT 1)) (|if| (EQ RETRYCOUNT 5) |then| (RETURN NIL) |else| (GO RETRY))) (|if| (GREATERP (LENGTH RESPONSE) 2) |then| (* |;;;| "Compute checksum on all characters after the \\") (|if| (NOT (SETQ RESPONSE (MT.COMPUTECHECKSUM (CDR (MEMBER (CHARCODE "\\") RESPONSE))))) |then| (GO REREAD)) (|if| (EQP (CAR RESPONSE) (CHARCODE ?)) |then| (MT.PRINT.ERROR.MSG (CADR RESPONSE)) (RETURN NIL) |else| (RETURN (PACKC RESPONSE))) |else| (RETURN T)))) ) (MT.COMPUTECHECKSUM (LAMBDA (RESPONSE) (* \; "Edited 8-Sep-88 19:03 by Briggs") (* |;;;| "Response should be all bytes after the \\. Byte 1 = Command type Byte 2 = High part data count Byte 3 = Low part of data count after databytes should be Checksum and remaining data after this is extraneous") (PROG (DATACOUNT LENGTHDIFF DATALIST CHECKSUM (SUMCHECK 0)) (SETQ DATALIST RESPONSE) (SETQ DATACOUNT (IPLUS (LLSH (CADR RESPONSE) 8) (CADDR RESPONSE))) (SETQ LENGTHDIFF (IDIFFERENCE (LENGTH RESPONSE) (IPLUS DATACOUNT 3))) (|for| I |from| 1 |to| LENGTHDIFF |do| (SETQ DATALIST (REVERSE (CDR (REVERSE DATALIST))))) (SETQ CHECKSUM (CAR (NTH RESPONSE (IPLUS 4 DATACOUNT)))) (|for| DATA |in| DATALIST |do| (SETQ SUMCHECK (IPLUS SUMCHECK DATA))) (|if| (OR (EQP CHECKSUM (IPLUS (LOGXOR 255 (LRSH (LLSH SUMCHECK 24) 24)) 1)) (EQ CHECKSUM 0)) |then| (MT.SENDACK) (* |;;;| "Return data minus the response type, hi & low data count and checksum") (RETURN (CDDDR DATALIST)) |else| (MT.SENDNAK) (RETURN NIL)))) ) (MT.PRINT.ERROR.MSG (LAMBDA (ERRORCODE) (* \; "Edited 8-Sep-88 12:52 by Briggs") (RINGBELLS) (SELECTQ ERRORCODE (1 (MT.PRINT.STATUS "U88 ROM FAILURE")) (2 (MT.PRINT.STATUS "U81 ROM FAILURE")) (3 (MT.PRINT.STATUS "U64 ROM FAILURE")) (4 (MT.PRINT.STATUS "U72 ROM FAILURE")) (6 (MT.PRINT.STATUS "U23 ROM FAILURE")) (7 (MT.PRINT.STATUS "U31 ROM FAILURE")) (8 (MT.PRINT.STATUS "U29 ROM FAILURE")) (9 (MT.PRINT.STATUS "Paper sensor failure")) (16 (MT.PRINT.STATUS "Lamp failure or image sensor circuit failure")) (128 (MT.PRINT.STATUS "Illegal Command")) (129 (MT.PRINT.STATUS "Illegal Gray Scale Setting")) (131 (MT.PRINT.STATUS "Illegal Resolution Setting")) (132 (MT.PRINT.STATUS "Illegal Data Compression Parameter")) (133 (MT.PRINT.STATUS "Illegal Scanning Frame Coordinate")) (134 (MT.PRINT.STATUS "Illegal number of windows")) (135 (MT.PRINT.STATUS "Illegal window coordinate")) (136 (MT.PRINT.STATUS "Illegal Contrast Setting")) (137 (MT.PRINT.STATUS "Illegal Paper Length setting")) (138 (MT.PRINT.STATUS "Record Type error")) (139 (MT.PRINT.STATUS "NAK receiced on 5 consecutive transmissions")) (140 (MT.PRINT.STATUS "Paper jammed or longer than length setting")) (141 (MT.PRINT.STATUS "Illegal Brightness setting")) NIL)) ) (MT.SENDACK (LAMBDA NIL (* \; "Edited 8-Sep-88 19:03 by Briggs") (BOUT MT.OUTSTREAM 6) (FORCEOUTPUT MT.OUTSTREAM)) ) (MT.SENDNAK (LAMBDA NIL (* \; "Edited 8-Sep-88 19:03 by Briggs") (BOUT MT.OUTSTREAM 21) (FORCEOUTPUT MT.OUTSTREAM)) ) (MT.STOP.SCANNING (LAMBDA NIL (* \; "Edited 8-Sep-88 19:03 by Briggs") (PROG NIL (BOUT MT.OUTSTREAM 3) (FORCEOUTPUT MT.OUTSTREAM) (DEL.PROCESS (BQUOTE MICROTEK.SCANNING)) (MT.RESET))) ) (MT.RESET (LAMBDA NIL (* \; "Edited 8-Sep-88 12:51 by Briggs") (|if| (AND (EQ \\RS232C.READY T) (EQ (CDAR (RS232C.GET.PARAMETERS (QUOTE (|BaudRate|)))) MT.BAUDRATE) (EQ (CADAR (RS232C.GET.PARAMETERS (QUOTE (|FlowControl|)))) 0) (LEQ (CDAR (RS232C.GET.PARAMETERS (QUOTE (FRAME.TIMEOUT)))) 50) (OPENP MT.OUTSTREAM) (OPENP MT.INSTREAM)) |then| (MT.SENDCOMMAND 1 (LIST (QUOTE X))) |else| (RS232C.INIT MT.BAUDRATE 8 (QUOTE NONE) 1 (QUOTE DTR)) (CLOSEF? MT.OUTSTREAM) (CLOSEF? MT.INSTREAM) (SETQ MT.OUTSTREAM (OPENSTREAM (QUOTE {RS232}) (QUOTE OUTPUT))) (SETQ MT.INSTREAM (RS232C.OTHER.STREAM MT.OUTSTREAM)) (RS232C.SET.PARAMETERS (LIST (BQUOTE (FRAME.TIMEOUT \\\, MT.RS232C.FRAME.TIMEOUT))))) (DELFILE (CLOSEF? (QUOTE {CORE}SCANNER.SCRATCH))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (LET ((RESPONSE (MT.SENDCOMMAND 1 (LIST (QUOTE !))))) (|if| RESPONSE |then| (CLRPROMPT) (MT.PRINT.STATUS (CONCAT RESPONSE " ready")) |else| (RINGBELLS) (MT.PRINT.STATUS "Microtek Not Responding ...Check scanner and cables")))) ) (MT.PAGEMAP (LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (|if| (OPENWP MTDISPLAYWINDOW) |then| (CLOSEW MTDISPLAYWINDOW) |else| (OPENW MTDISPLAYWINDOW))) ) (MT.QUIT (LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (SETQ RESPONSE (MENU (|create| MENU ITEMS _ (QUOTE ("QUIT" "SHUTDOWN RS232 PORT ONLY")) MENUFONT _ (FONTCREATE (QUOTE MODERN) 10 (QUOTE BOLD))))) (CLOSEF? MT.INSTREAM) (CLOSEF? MT.OUTSTREAM) (RS232C.SHUTDOWN) (|if| (STREQUAL RESPONSE "QUIT") |then| (DELFILE (CLOSEF? (QUOTE {CORE}SCANNER.SCRATCH))) (CLOSEW MTDISPLAYWINDOW) (CLOSEW MT.CONTROL.MENUWINDOW))) ) ) (* * |Functions| |to| |convert| |and| |print| |scanned| |images|) (DEFINEQ (MT.DISPLAY.MENU (LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID DISPLAY1) (GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130) (TYPE MOMENTARY LABEL "CREATE BITMAP!" FONT (MODERN 12 BOLD) SELECTEDFN MT.CREATEBM BOX 3 LEFT 1 BOTTOM 35) (TYPE MOMENTARY LABEL "Bitmap Name!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.BITMAPNAME BOX 1 LEFT 1 BOTTOM 18) (TYPE EDIT ID BITMAPNAME LABEL "IMAGE" BOX 1 LEFT 100 BOTTOM 18 MAXWIDTH 170) (TYPE STATE LABEL "Shrinkfactor! " MENUITEMS (10 9 8 7 6 5 4 3 2 1) INITSTATE 1 LINKS (DISPLAY (GROUP BMSHRINKFACTOR)) FONT (MODERN 10 BOLD) BOX 1 LEFT 278 BOTTOM 18) (TYPE DISPLAY LABEL "" ID BMSHRINKFACTOR BOX 1 LEFT 350 BOTTOM 18 MAXWIDTH 16) (TYPE STATE LABEL "Rotation! " MENUITEMS ("NONE" "LEFT" "RIGHT") LINKS (DISPLAY (GROUP ROTATE)) INITSTATE "NONE" FONT (MODERN 10 BOLD) BOX 1 LEFT 382 BOTTOM 18) (TYPE DISPLAY LABEL "" ID ROTATE BOX 1 LEFT 439 BOTTOM 18 MAXWIDTH 37) (TYPE DISPLAY LABEL "Source Filename!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.SOURCEFILENAME BOX 1 LEFT 1 BOTTOM 1) (TYPE EDIT ID SOURCEFILENAME LABEL {DSK}IMAGE BOX 1 LEFT 100 BOTTOM 1 MAXWIDTH 379)))))) (SETQ MT.DISPLAY.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Display Menu" 23130 5)) (FM.CHANGESTATE (FM.GETITEM (QUOTE BMSHRINKFACTOR) NIL MT.DISPLAY.MENUWINDOW) MT.BMSHRINKFACTOR MT.DISPLAY.MENUWINDOW) (OPENW MT.DISPLAY.MENUWINDOW))) ) (MT.GET.SOURCEFILENAME (LAMBDA NIL (* \; "Edited 12-Mar-87 15:41 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE SOURCEFILENAME) NIL MT.DISPLAY.MENUWINDOW) MT.DISPLAY.MENUWINDOW)) ) (MT.GET.BITMAPNAME (LAMBDA NIL (* \; "Edited 12-Mar-87 15:42 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE BITMAPNAME) NIL MT.DISPLAY.MENUWINDOW) MT.DISPLAY.MENUWINDOW)) ) (MT.CREATEBM (LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (MT.BITMAPCREATE (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE BITMAPNAME)) (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE SOURCEFILENAME)) (CADR (MEMBER "Shrinkfactor! " (FM.GETSTATE MT.DISPLAY.MENUWINDOW))) (MKATOM (CADR (MEMBER "Rotation! " (FM.GETSTATE MT.DISPLAY.MENUWINDOW)))))) ) (MT.BITMAPCREATE (LAMBDA (BITMAPNAME INFILENAME BMSHRINKFACTOR ROTATION) (* \; "Edited 8-Sep-88 19:04 by Briggs") (PROG* (SCANFILE COMPRESSION RESOLUTION GREYLEVEL CONTRAST BRIGHTNESS SCANLINES SCANTYPE BYTESPERSCANLINE SCANDENSITY FINISHEDBM) (SETQ FINISHEDBM (MKATOM BITMAPNAME)) (|if| (AND INFILENAME FINISHEDBM) |then| (SETQ SCANFILE (OPENSTREAM INFILENAME (QUOTE INPUT))) (SETQ COMPRESSION (READ SCANFILE)) (SETQ RESOLUTION (READ SCANFILE)) (SETQ GREYLEVEL (READ SCANFILE)) (SETQ CONTRAST (READ SCANFILE)) (SETQ BRIGHTNESS (READ SCANFILE)) (SETQ SCANLINES (READ SCANFILE)) (SETQ BYTESPERSCANLINE (READ SCANFILE)) (* |;;;| "To Pick up trailing CR") (BIN SCANFILE) (|if| (EQ COMPRESSION (QUOTE NO)) |then| (SET FINISHEDBM (MT.CONVERTIMAGETOBM SCANFILE SCANLINES BYTESPERSCANLINE FINISHEDBM BMSHRINKFACTOR ROTATION)) (PUTPROP (MKATOM BITMAPNAME) (QUOTE RESOLUTION) RESOLUTION) |else| (MT.PRINT.STATUS "NOT YET IMPLEMENTED") (CLOSEF? SCANFILE)) |else| (MT.PRINT.STATUS "ERROR IN BITMAP OR SCANFILE NAME") (CLOSEF? SCANFILE)) (RETURN FINISHEDBM))) ) (MT.CONVERTIMAGETOBM (LAMBDA (BFILE SCANLINES BYTESPERSCANLINE BMAPNAME SCANNERSHRINKFACTOR ROTATION) (* \; "Edited 8-Sep-88 19:04 by Briggs") (* |;;;| "Returns a bitmap that is shrunken (by factor) image of the data. Creates a temporary bitmap that is exact width but only 200 lines max long. That is shrunken then blt'ed into the final bitmap") (PROG (OFFSET BITWIDTH LINEOFFSET TEMPBM FINALBMOFFSET FINALBMWNAME FINALBMOFFSETFACTOR FINALBM FINALBMLINES CLINE BMPTR CBYTE SHRINKHEIGHTFACTOR SHRINKWIDTHFACTOR) (SETQ OFFSET 0) (SETQ BITWIDTH (ITIMES BYTESPERSCANLINE 8)) (SETQ LINEOFFSET (|if| (ODDP BYTESPERSCANLINE) |then| (IPLUS BYTESPERSCANLINE 1) |else| BYTESPERSCANLINE)) (SETQ TEMPBM (BITMAPCREATE BITWIDTH 200)) (SETQ FINALBMOFFSET -1) (SETQ FINALBMWNAME (MKATOM (CONCAT BMAPNAME (QUOTE WINDOW)))) (SETQ FINALBMOFFSETFACTOR (QUOTIENT 200 SCANNERSHRINKFACTOR)) (MT.PRINT.STATUS "SETTING UP BITMAP...") (* |;;;| "Set up the bmap parameters") (SETQ SHRINKHEIGHTFACTOR SCANNERSHRINKFACTOR) (SETQ SHRINKWIDTHFACTOR SCANNERSHRINKFACTOR) (* |;;;| "Set number of lines in final bitmap") (SETQ FINALBMLINES (IPLUS (IQUOTIENT SCANLINES SHRINKHEIGHTFACTOR) 1)) (* |;;;| "create the final bitmap FACTOR width and FACTOR high") (SETQ FINALBM (|if| (GEQ (ITIMES BITWIDTH SCANLINES) 2000000) |then| (MT.CREATE.BIG.BM BITWIDTH SCANLINES) |else| (BITMAPCREATE (QUOTIENT (ITIMES BYTESPERSCANLINE 8) SHRINKWIDTHFACTOR) FINALBMLINES))) (* |;;;| "make a window that you can bitblt the image to while you are working...") (* |;;;| "now start doing the serious work") (MT.PRINT.STATUS "WORKING...") (SETQ BMPTR (|fetch| BITMAPBASE |of| TEMPBM)) (|for| Y |from| 0 |to| (SUB1 SCANLINES) |do| (|if| (EQ OFFSET 200) |then| (* \; "We've done 200 lines, so now lets move it and reset the offset pointers!") (MT.PRINT.STATUS "BLT'ING A CHUNK...") (* |;;;| "first reset everything") (SETQ BMPTR (|fetch| BITMAPBASE |of| TEMPBM)) (SETQ OFFSET 0) (* |;;;| "set the new offset into the final bitmap DONT forget we are working top down in BMAP") (SETQ FINALBMOFFSET (IPLUS FINALBMOFFSET FINALBMOFFSETFACTOR)) (* |;;;| "BITBLT the shrunken bitmap (by SHRINKHEIGHTFACTOR) to the final bitmap and then the finalbitmap to the display window") (BITBLT (SHRINKBITMAP TEMPBM SHRINKWIDTHFACTOR SHRINKHEIGHTFACTOR) 0 0 FINALBM 0 (IDIFFERENCE FINALBMLINES FINALBMOFFSET)) (MT.PRINT.STATUS "DONE...WORKING...")) (SETQ CLINE (ITIMES OFFSET LINEOFFSET)) (|for| X |from| 0 |to| (IDIFFERENCE BYTESPERSCANLINE 1) |do| (\\PUTBASEBYTE BMPTR (PLUS X CLINE) (BIN BFILE))) (SETQ OFFSET (ADD1 OFFSET))) (* |;;;| "Now do the final shrink and blt") (MT.PRINT.STATUS " BLT'ING FINAL CHUNK...") (SETQ OFFSET (IPLUS (IMOD OFFSET SHRINKHEIGHTFACTOR) (QUOTIENT OFFSET SHRINKHEIGHTFACTOR))) (SETQ FINALBMOFFSET (IPLUS FINALBMOFFSET OFFSET)) (BITBLT (SHRINKBITMAP TEMPBM SHRINKWIDTHFACTOR SHRINKHEIGHTFACTOR) 0 (IDIFFERENCE FINALBMOFFSETFACTOR OFFSET) FINALBM 0 (IDIFFERENCE FINALBMLINES FINALBMOFFSET)) (MT.CREATE.DISPLAYWINDOW (|if| (EQ ROTATION (QUOTE LEFT)) |then| (MT.PRINT.STATUS "..ROTATING BITMAP...PLEASE WAIT") (SETQ FINALBM (ROTATE.BITMAP.LEFT FINALBM)) |elseif| (EQ ROTATION (QUOTE RIGHT)) |then| (MT.PRINT.STATUS "..ROTATING BITMAP...PLEASE WAIT") (SETQ FINALBM (ROTATE.BITMAP.RIGHT FINALBM)) |else| FINALBM)) (MT.PRINT.STATUS "DONE") (CLOSEF BFILE) (CLRPROMPT) (RETURN FINALBM))) ) (MT.CREATE.BIG.BM (LAMBDA (WIDTH HEIGHT) (* \; "Edited 8-Sep-88 19:05 by Briggs") (LET* ((RASTERWIDTH (IQUOTIENT (IPLUS WIDTH (IDIFFERENCE 16 (IMOD WIDTH 16))) 16)) (TOTALBYTES (ITIMES HEIGHT (ITIMES RASTERWIDTH 2))) (NPAGES (COND ((ZEROP (IMOD TOTALBYTES 512)) (IQUOTIENT TOTALBYTES 512)) (T (ADD1 (IQUOTIENT TOTALBYTES 512))))) (BMPTR (\\ALLOCPAGEBLOCK NPAGES)) (REALLYBIGBM (|create| BITMAP BITMAPBASE _ BMPTR BITMAPRASTERWIDTH _ RASTERWIDTH BITMAPHEIGHT _ HEIGHT BITMAPWIDTH _ WIDTH BITMAPBITSPERPIXEL _ 1))) (BLTSHADE WHITESHADE REALLYBIGBM) REALLYBIGBM)) ) (MT.CREATE.DISPLAYWINDOW (LAMBDA (BITMAP) (* \; "Edited 13-Mar-87 15:10 by rdc") (PROG (WINDOW) (RINGBELLS) (MT.PRINT.STATUS "SWEEP OUT WINDOW FOR BITMAP") (SETQ WINDOW (CREATEW NIL (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE BITMAPNAME)))) (WINDOWPROP WINDOW (QUOTE SRCBM) BITMAP) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION MT.REPAINTWINDOW)) (WINDOWPROP WINDOW (QUOTE RESHAPEFN) (FUNCTION MT.RESHAPEWINDOW)) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) (MT.RESHAPEWINDOW WINDOW) (RETURN WINDOW))) ) (MT.REPAINTWINDOW (LAMBDA (WINDOW REGION) (* \; "Edited 8-Sep-88 19:05 by Briggs") (MOVETO (WINDOWPROP WINDOW (QUOTE BMORIGX)) (WINDOWPROP WINDOW (QUOTE BMORIGY)) WINDOW) (BITBLT (WINDOWPROP WINDOW (QUOTE SRCBM)) 0 0 WINDOW)) ) (MT.RESHAPEWINDOW (LAMBDA (WINDOW) (* \; "Edited 8-Sep-88 19:05 by Briggs") (PROG NIL (DSPRESET WINDOW) (WINDOWPROP WINDOW (QUOTE BMORIGX) (DSPXPOSITION NIL WINDOW)) (WINDOWPROP WINDOW (QUOTE BMORIGY) (DSPYPOSITION NIL WINDOW)) (MT.REPAINTWINDOW WINDOW) (WINDOWPROP WINDOW (QUOTE EXTENT) (CREATEREGION 0 0 (BITMAPWIDTH (WINDOWPROP WINDOW (QUOTE SRCBM))) (BITMAPHEIGHT (WINDOWPROP WINDOW (QUOTE SRCBM))))))) ) ) (ADDTOVAR |BackgroundMenuCommands| ("MicrotekScanner" (MT.INIT) "Open Microtek Scanner Command and Display windows, initilalize RS232 port and verifies Microtek Scanner is ready")) (RPAQQ |BackgroundMenu| NIL) (RPAQQ MT.ICON #*(50 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@H@@@@H@@@@@@@@@@H@@@@H@@@@@@@@@@H@@@@OOOOL@@@@@AH@@@@H@@@L@@@@@BH@@@@H@@AD@@@@@DH@@@@H@@BD@@@@@HH@@@@H@@DD@@@@A@H@@@@H@@HD@@@@B@H@@@@H@A@D@@@@DCH@@@@N@B@D@@@@HCOOOOON@D@D@@@A@@@@@@@@@H@D@@@B@@@@@@@@A@@D@@@GOOOOOOOON@@H@@@D@@@@@@@@B@A@@@@D@@@@@@@@B@B@@@@D@@@@@@@@B@D@@@@DOOOOOOOOB@H@@@@DH@@@@@@ABA@@@@@DH@@@@@@ABB@@@@@DH@@@@@@ABD@@@@@DH@@@@@@ABH@@@@@DH@@@@@@AC@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) (RPAQQ MT.ICON.MASK #*(50 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOOOOOL@@@@@AOOOOOOOOOL@@@@@COOOOOOOOOL@@@@@GOOOOOOOOOL@@@@@OOOOOOOOOOL@@@@AOOOOOOOOOOL@@@@COOOOOOOOOOL@@@@GOOOOOOOOOOL@@@@OOOOOOOOOOOL@@@AOOOOOOOOOOOL@@@COOOOOOOOOOOL@@@GOOOOOOOOOOOH@@@GOOOOOOOOOOO@@@@GOOOOOOOOOON@@@@GOOOOOOOOOOL@@@@GOOOOOOOOOOH@@@@GOOOOOOOOOO@@@@@GOOOOOOOOON@@@@@GOOOOOOOOOL@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOO@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) (RPAQQ BRIGHTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@OGH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) (RPAQQ CONTRASTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@OGH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) (RPAQQ INITIALBRIGHTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) (RPAQQ INITIALCONTRASTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) (RPAQQ LEFTARROW #*(10 10)@H@@AH@@CH@@GOL@OOL@OOL@GOL@CH@@AH@@@H@@) (RPAQQ MANCURSOR #*(9 9)@H@@AL@@CN@@GO@@OOH@GO@@CN@@AL@@@@@@) (RPAQQ RIGHTARROW #*(10 10)@D@@@F@@@G@@OOH@OOL@OOL@OOH@@G@@@F@@@D@@) (RPAQQ MT.POINTER #*(16 16)L@@@O@@@OL@@OO@@OOL@OOO@OOOLOOOOOOOOOOOLOOO@OOL@OO@@OL@@O@@@L@@@) (RPAQ? MT.BAUDRATE 19200) (RPAQ? MT.RS232C.FRAME.TIMEOUT 2) (RPAQ? MT.DISPLAYFRAME (QUOTE YES)) (RPAQ? MT.PAPERLENGTH 4) (RPAQ? MT.REDUCTION 0) (RPAQ? MT.CONTRAST 0) (RPAQ? MT.BRIGHTNESS 0) (RPAQ? MT.GREYLEVEL 0) (RPAQ? MT.DATACOMPRESSION (QUOTE NO)) (RPAQ? MT.BACKGROUND (QUOTE HALFTONE)) (RPAQ? MT.WINDOW (QUOTE LINEART)) (RPAQ? MT.FRAME (QUOTE (0 0 40 24))) (RPAQ? MT.FRAME.BOX (QUOTE (0 460 200 120))) (RPAQ? MT.TEXTW1 (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW2 (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW3 (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW4 (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW1BOX (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW2BOX (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW3BOX (QUOTE (0 0 0 0))) (RPAQ? MT.TEXTW4BOX (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW1 (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW2 (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW3 (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW4 (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW1BOX (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW2BOX (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW3BOX (QUOTE (0 0 0 0))) (RPAQ? MT.HALFTONEW4BOX (QUOTE (0 0 0 0))) (RPAQ? MT.OUTSTREAM NIL) (RPAQ? MT.INSTREAM NIL) (RPAQ? MT.BMSHRINKFACTOR 1) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MT.RS232C.FRAME.TIMEOUT MT.STATUSWINDOW MT.HEIGHTRULER MT.GRID MT.PAPERLENGTH MT.REDUCTION MT.BRIGHTNESS MT.CONTRAST MT.GREYLEVEL MT.DATACOMPRESSION MT.BACKGROUND MT.WINDOW MT.HEIGHTWINDOW MT.FRAME MT.FRAME.BOX MT.TEXTW1 MT.TEXTW2 MT.TEXTW3 MT.TEXTW4 MT.HALFTONEW1 MT.HALFTONEW2 MT.HALFTONEW3 MT.HALFTONEW4 MT.OUTSTREAM MT.INSTREAM BRIGHTBAR CONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW) ) (PUTPROPS MICROTEK MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP")) (PUTPROPS MICROTEK COPYRIGHT ("XEROX Corporation" 1987 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3704 36121 (MT.INIT 3714 . 5283) (MT.SHRINKFN 5285 . 5611) (MICROTEKSCANNER 5613 . 7281 ) (RULERX 7283 . 7517) (RULEX# 7519 . 7756) (RULERY 7758 . 8107) (RULEY# 8109 . 8346) (MT.GETLENGTH 8348 . 8889) (MT.CURSOR.IN 8891 . 9003) (MT.CURSOR.OUT 9005 . 9090) (MT.PRINT.STATUS 9092 . 9224) ( MT.CONTROL.MENU 9226 . 16550) (MT.CHANGE.BRIGHTBAR 16552 . 16999) (MT.RAISEBRIGHTNESS 17001 . 17303) ( MT.LOWERBRIGHTNESS 17305 . 17620) (MT.CHANGE.CONTRASTBAR 17622 . 18072) (MT.RAISECONTRAST 18074 . 18366) (MT.LOWERCONTRAST 18368 . 18673) (MT.SELECT.BACKGROUND 18675 . 23111) (MT.GETTRANSFRAME 23113 . 25079) (MT.GETWINDOW1 25081 . 27252) (MT.GETWINDOW2 27254 . 29425) (MT.GETWINDOW3 29427 . 31598) ( MT.GETWINDOW4 31600 . 33771) (MT.UPDATE.HTWINDOWS 33773 . 35312) (MT.DRAWAREABOX 35314 . 36119)) ( 36156 49637 (MT.COMMAND.MENU 36166 . 37143) (MT.GET.OUTFILENAME 37145 . 37317) (MT.SCAN 37319 . 37469) (MT.START.SCANNING 37471 . 40210) (MT.SETUPSCANFILE 40212 . 40960) (MT.SEND.SCAN.PARAMETERS 40962 . 44005) (MT.SENDCOMMAND 44007 . 45314) (MT.COMPUTECHECKSUM 45316 . 46319) (MT.PRINT.ERROR.MSG 46321 . 47555) (MT.SENDACK 47557 . 47678) (MT.SENDNAK 47680 . 47802) (MT.STOP.SCANNING 47804 . 47994) ( MT.RESET 47996 . 49039) (MT.PAGEMAP 49041 . 49208) (MT.QUIT 49210 . 49635)) (49710 58061 ( MT.DISPLAY.MENU 49720 . 51177) (MT.GET.SOURCEFILENAME 51179 . 51357) (MT.GET.BITMAPNAME 51359 . 51529) (MT.CREATEBM 51531 . 51899) (MT.BITMAPCREATE 51901 . 52955) (MT.CONVERTIMAGETOBM 52957 . 56302) ( MT.CREATE.BIG.BM 56304 . 56871) (MT.CREATE.DISPLAYWINDOW 56873 . 57410) (MT.REPAINTWINDOW 57412 . 57644) (MT.RESHAPEWINDOW 57646 . 58059))))) STOP \ No newline at end of file diff --git a/lispusers/MICROTEKPRINT b/lispusers/MICROTEKPRINT new file mode 100644 index 00000000..1ebca069 --- /dev/null +++ b/lispusers/MICROTEKPRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "27-Jan-89 10:23:15" {DSK}MICROTEK>MICROTEKPRINT.;1 10179 changes to%: (FNS MT.CREATEPRINTMASTER) previous date%: "23-Jul-88 15:18:48" {ERINYES}MEDLEY>LISPUSERS>MICROTEKPRINT.;1) (* " Copyright (c) 1986, 1987, 1988, 1989 by XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT MICROTEKPRINTCOMS) (RPAQQ MICROTEKPRINTCOMS [(P (FILESLOAD MICROTEK)) (FNS MT.PRINT.MENU MT.GETXPOS MT.GETYPOS MT.CREATEPRINT MT.CREATEPRINTMASTER MT.SELECT.SCALEFACTOR) (P (IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW) (OPENWP MT.DISPLAY.MENUWINDOW)) THEN (MT.PRINT.MENU]) (FILESLOAD MICROTEK) (DEFINEQ (MT.PRINT.MENU [LAMBDA NIL (* ;  "Edited 21-May-87 09:23 by ronald clarke:xsis:xerox") (PROG (MENU.DESCRIPTION) [SETQ MENU.DESCRIPTION `(((PROPS ID MPRINT) (GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130) (TYPE MOMENTARY LABEL "PRINT" BOX 3 LEFT 0 BOTTOM 2 FONT (MODERN 12 BOLD) SELECTEDFN MT.CREATEPRINT) (TYPE STATE LABEL "Printer!: " ID PRINTERTYPE MENUITEMS (8044 4045) INITSTATE 8044 LINKS (DISPLAY (GROUP PRINTER)) FONT (MODERN 10 BOLD) BOX 1 LEFT 60 BOTTOM 3) (TYPE DISPLAY ID PRINTER LABEL "" LEFT 115 BOTTOM 3 BOX 1 MAXWIDTH 30) (TYPE MOMENTARY LABEL "XPOS!: " SELECTEDFN MT.GETXPOS FONT (MODERN 10 BOLD) LEFT 175 BOTTOM 3 BOX 1) (TYPE EDIT ID XPOS LABEL 0 MAXWIDTH 45 LEFT 220 BOTTOM 3 BOX 1) (TYPE MOMENTARY LABEL "YPOS!: " SELECTEDFN MT.GETYPOS FONT (MODERN 10 BOLD) LEFT 280 BOTTOM 3 BOX 1) (TYPE EDIT ID YPOS LABEL 0 MAXWIDTH 45 LEFT 325 BOTTOM 3 BOX 1) (TYPE MOMENTARY LABEL "SCALE!: " FONT (MODERN 10 BOLD) LEFT 385 BOTTOM 3 BOX 1 SELECTEDFN MT.SELECT.SCALEFACTOR) (TYPE EDIT LABEL "1:1" ID SCALEFACTOR LEFT 435 BOTTOM 3 BOX 1] (SETQ MT.PRINT.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Print Menu" 23130 5)) (OPENW MT.PRINT.MENUWINDOW) (ATTACHWINDOW MT.PRINT.MENUWINDOW MT.DISPLAY.MENUWINDOW 'BOTTOM 'JUSTIFY]) (MT.GETXPOS [LAMBDA NIL (* ;  "Edited 21-May-87 09:15 by ronald clarke:xsis:xerox") (FM.EDITITEM (FM.GETITEM 'XPOS NIL MT.PRINT.MENUWINDOW) MT.PRINT.MENUWINDOW]) (MT.GETYPOS [LAMBDA NIL (* ;  "Edited 21-May-87 09:17 by ronald clarke:xsis:xerox") (FM.EDITITEM (FM.GETITEM 'YPOS NIL MT.PRINT.MENUWINDOW) MT.PRINT.MENUWINDOW]) (MT.CREATEPRINT [LAMBDA NIL (* ;  "Edited 21-May-87 09:29 by ronald clarke:xsis:xerox") (PROG NIL (if (AND [BOUNDP (SETQ BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) 'BITMAPNAME] (BITMAPP (SETQ BITMAP (EVAL BITMAP))) (if (OR [AND (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'PRINTERTYPE)) 4045) (FMEMB (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'SCALEFACTOR)) '(4%:1 2%:1 1%:1 1%:2 1%:4] (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'PRINTERTYPE)) 8044)) then T else (FLASHWINDOW MT.STATUSWINDOW 3) (MT.PRINT.STATUS "Not a valid scale for 4045 printer") (RETURN NIL))) then (MT.PRINT.STATUS "") [MT.CREATEPRINTMASTER BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'XPOS)) (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'YPOS)) (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'SCALEFACTOR] else (FLASHWINDOW MT.STATUSWINDOW 3) (MT.PRINT.STATUS "This atom is not a bitmap") (RETURN NIL]) (MT.CREATEPRINTMASTER [LAMBDA (BITMAP X Y SCALEFACTOR) (* ; "Edited 27-Jan-89 10:21 by rclarke.pa") (PROG (IPS SCANFACTOR SCALE) [if (EQP (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'PRINTERTYPE) 8044) then (if [NOT (SETQ SCANFACTOR (LISTGET '(0 0.24 5 0.252 10 0.266 15 0.282 20 0.3 25 0.32 33 0.36 35 0.369 40 0.4 45 0.439 50 0.48 55 0.533 60 0.6 67 0.7200001 70 0.8 75 0.96) (GETPROP (MKATOM (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) 'BITMAPNAME)) 'RESOLUTION] then (MT.PRINT.STATUS "") (FLASHWINDOW MT.STATUSWINDOW 3) (if [NOT (NUMBERP (SETQ SCANFACTOR (MKATOM (PROMPTFORWORD "Resolution not on Bitmap proplist. Enter #:" "1" NIL MT.STATUSWINDOW] then (FLASHWINDOW MT.STATUSWINDOW 2) (MT.PRINT.STATUS "This is not a number") (RETURN NIL)) (MT.PRINT.STATUS "")) [SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR)) (CADDR (UNPACK SCALEFACTOR] (SETQ IPS (OPENIMAGESTREAM '{LPT}.IP)) (SCALEDBITBLT BITMAP 0 0 IPS X Y 21590 27940 'INPUT 'REPLACE NIL '(0 0 21590 27940) (FTIMES SCALE SCANFACTOR)) else (if [NOT (SETQ SCANFACTOR (LISTGET '(0 1 5 1 10 1 15 1 20 1 25 1 33 1 35 1 40 2 45 2 50 2 55 2 60 2 67 4 70 4 75 4) (GETPROP (MKATOM (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) 'BITMAPNAME)) 'RESOLUTION] then (MT.PRINT.STATUS "") (FLASHWINDOW MT.STATUSWINDOW 3) (if [NOT (NUMBERP (SETQ SCANFACTOR (MKATOM (PROMPTFORWORD "Resolution not on Bitmap proplist. Enter #:" "1" NIL MT.STATUSWINDOW] then (FLASHWINDOW MT.STATUSWINDOW 2) (MT.PRINT.STATUS "This is not a number") (RETURN NIL)) (MT.PRINT.STATUS "")) [SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR)) (CADDR (UNPACK SCALEFACTOR] (SETQ IPS (OPENIMAGESTREAM '{LPT}.4045XLP)) (if (GREATERP (FTIMES SCALE SCANFACTOR) 4) then (FLASHWINDOW MT.STATUSWINDOW 2) (MT.PRINT.STATUS "Not a valid scale for reduction used on this bitmap") (RETURN NIL)) (SCALEDBITBLT BITMAP 0 0 IPS X Y 2550 3300 'INPUT 'REPLACE NIL '(0 0 2550 3300) (FIXR (FTIMES SCALE SCANFACTOR] (CLOSEF IPS) (MT.PRINT.STATUS "Bitmap sent to printer"]) (MT.SELECT.SCALEFACTOR [LAMBDA NIL (* ;  "Edited 21-May-87 09:26 by ronald clarke:xsis:xerox") (PROG [(PRINTERTYPE (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) 'PRINTERTYPE] [if (EQP PRINTERTYPE 8044) then (SETQ FACTORS '(8%:1 7%:1 6%:1 5%:1 4%:1 3%:1 2%:1 1%:1 1%:2 1%:3 1%:4 1%:5 1%:6 1%:7 1%:8)) else (SETQ FACTORS '(4%:1 2%:1 1%:1 1%:2 1%:4] (FM.CHANGESTATE (FM.GETITEM 'SCALEFACTOR NIL MT.PRINT.MENUWINDOW) (MENU (create MENU ITEMS _ FACTORS)) MT.PRINT.MENUWINDOW]) ) (IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW) (OPENWP MT.DISPLAY.MENUWINDOW)) THEN (MT.PRINT.MENU)) (PUTPROPS MICROTEKPRINT COPYRIGHT ("XEROX Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (794 9954 (MT.PRINT.MENU 804 . 2630) (MT.GETXPOS 2632 . 2912) (MT.GETYPOS 2914 . 3194) ( MT.CREATEPRINT 3196 . 5070) (MT.CREATEPRINTMASTER 5072 . 9197) (MT.SELECT.SCALEFACTOR 9199 . 9952)))) ) STOP \ No newline at end of file diff --git a/lispusers/MISSILE b/lispusers/MISSILE new file mode 100644 index 00000000..d1b1b37c --- /dev/null +++ b/lispusers/MISSILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 1-May-87 17:22:51" {ERIS}F>CODE>MISSILE.;2 34474 changes to%: (FNS COIN-FLIP) previous date%: "20-May-86 20:49:29" {ERIS}F>CODE>MISSILE.;1) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MISSILECOMS) (RPAQQ MISSILECOMS ((VARS *BLASTED-SKYLINE* *MISSILE-COMMAND-ICON* *MISSILE-COMMAND-MASK* *MISSLE-COMMAND-ICON* *SCORE* *SKYLINE*) (RECORDS CITY SHOCK TRACE) (FNS BARGRAPH-ERASE BLAST-CITY BONUS-DISPLAY BUMP-TRACE COIN-FLIP COLLIDE-TRACE DISPLAY-MISSILES GEN-MIRV GEN-SHOCK GEN-TARGETS GEN-TRACES GROW-SHOCK INIT-MISSILE INIT-TRACE INTERCEPTED MAIN-LOOP MAIN-LOOP-AUX MISSILE-COMMAND MOVE-TRACE MYINSIDE NEXT-PHASE PICK-TARGETS SCORE-ADD SHOCK-COLLISION STROBE-CITIES UPDATE-BARGRAPH UPDATE-SCORE))) (RPAQQ *BLASTED-SKYLINE* #*(180 50)@@D@@@@@L@@@@@@@@@@@@@@@@@@CL@@@@@@@@@H@@@@AH@@@@@F@@@@@N@@@@@@@@@@@@@@@@@@GN@@@@@@@@AH@@@@CH@@@@@N@@@@AO@@@@@@@@@@@@@@@@@@OO@@@@@@@@AL@@@@CH@@@@@O@@@@AO@@@@@@@@@@@@@@@@@AOO@@@@@@@@CL@@@@GH@@@@@OH@@@AOH@@@@@@@@@@@@@@@@COOH@@@@@@@CL@@@@OL@@@@@OH@@@COL@@@@@@@@@@@@@@@@GOOL@@@@@@@GN@@@@OL@@@@@OL@@@CON@@@@@@@@@@@@@@@@OOON@@@@@@@GN@@@AOL@@@@@ON@@@CON@@@@@@@@@@@@@@@AOOON@@@@@@@ON@@@COL@@@@@ON@@@GOO@@@@@@@@@@@@@@@COOOO@@@@@@@OO@@@CON@@@@@OO@@@GOOH@@@@@@@@@@@@@@GOOOOH@@@@@AOO@@@GON@@@@@OOH@@GOOL@@@@@@@@@@@@@@OOOOOL@@@@@AOO@@@OON@@@@AOOH@@OOOL@@@@@@@@@@@@@AOOOOOL@@@@@COOH@@OON@@@@AOOL@@OOON@@@@@@@@@@@@@COOOOON@@@@@COOH@AOOO@@@@AOON@@OOOO@@@@@@@@@@@@@GOOOOOO@@@@@GOOH@COOO@@@@AOON@AOOOOH@@@@@@H@@@@@OOOOOOOH@@@@GOOL@COOO@@@@AOOO@AOOOOH@@@@@AN@@@@AOOOOOOOH@@@@OOOL@GOOO@@@@AOOOHAOOOOL@@@@@COH@@@COOOOOOOL@@@@OOOL@OOOO@@@@AOOOHCOOOON@@@@@GON@@@GOOOOOOON@@@AOOON@OOOO@@@@AOOOLCOOOOO@@@@@OOOH@@OOOOOOOOO@@@AOOONAOOOO@@@@AOOONCOOOOO@@@@AOOON@AOOOOOOOOO@@@COOONCOOOO@@@@COOONGOOOOOH@@@COOOOHCOOOOOOOOOH@@COOOOCOOOO@@@@COOOOGOOOOOL@@@GOOOONGOOOOOOOOOL@@GOOOOGOOOO@@@@COOOOOOOOOON@@@OOOOOOOOOOOOOOOON@@GOOOOOOOOO@@@@COOOOOOOOOON@@AOOOOOOOOOOOOOOOON@@OOOOOOOOOO@@@@COOOOOOOOOOO@@COOOOOOOOOOOOOOOOO@@OOOOOOOOOO@@@@COOOOOOOOOOOH@GOOOOOOOOOOOOOOOOOHAOOOOOOOOOO@@@@COOOOOOOOOOOL@OOOOOOOOOOOOOOOOOOLAOOOOOOOOOO@@@@COOOOOOOOOOOLAOOOOOOOOOOOOOOOOOOLCOOOOOOOOOO@@@@COOOOOOOOOOONCOOOOOOOOOOOOOOOOOONCOOOOOOOOOO@@@@GOOOOOOOOOOOOGOOOOOOOOOOOOOOOOOOOGOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@ ) (RPAQQ *MISSILE-COMMAND-ICON* #*(80 60)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@@@@@@@@@@@@@@G@@@@@@@@@@@@@@@@@@@OH@@@@@@@@@@@@@@@@@AOL@@@@@@@@@@@@@@@@@CON@@@@@@@@@@@@@@@@@GOO@@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@COOON@@@@@@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@@@@AOOOOOL@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@EOOOOOI@@@@@@@@@@@@@DAOOONA@@@@@@@@@@@@@D@@OL@A@@@@@@@@@@@@@D@@@@@A@@@@@@@@@@@@@D@@@@@A@@@@@@@@@@@@@D@B@H@A@@@@@@@@@@@@@D@C@H@A@@@@@@@@@@@@@D@BHH@A@@@@@@@@@@@@@D@BDH@A@@@@@@@@@@@@@D@BBH@A@@@@@@@@@@@@@D@BAH@A@@@@@@@@@@@@@D@B@H@A@@@@@@@@@@@@@D@@@@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@L@@D@@A@@@@@@@@@@@@AL@@D@@A@@@@@@@@@@@@CL@@D@@AH@@@@@@@@@@@GL@@@@@AL@@@@@@@@@@@GL@BAH@AN@@@@@@@@@@@OL@BB@@AO@@@@@@@@@@@OL@BD@@AOH@@@@@@@@@AOL@BH@@AOL@@@@@@@@@AOL@C@@@AOL@@@@@@@@@COL@BH@@AON@@@@@@@@@COL@BD@@AON@@@@@@@@@GOL@BB@@AOO@@@@@@@@@GOL@BAH@AOOH@@@@@@@@OOL@@@@@AOOH@@@@@@@@OOL@AOL@AOOH@@@@@@@AOOL@A@@@AOOL@@@@@@@AOOL@A@@@AOOL@@@@@@@AOOL@A@@@AOOL@@@@@@@COOL@AOH@AOON@@@@@@@COOL@A@@@AOON@@@@@@@GOOL@A@@@AOON@@@@@@@GOOL@A@@@AOON@@@@@@@GOOO@AOL@OOOO@@@@@@@GOOLN@@@GIOOO@@@@@@@@@@@CN@CLAOOO@@@@@@@@@@@@CON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ *MISSILE-COMMAND-MASK* #*(80 60)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@@@@@@@@@@@@@@G@@@@@@@@@@@@@@@@@@@OH@@@@@@@@@@@@@@@@@AOL@@@@@@@@@@@@@@@@@CON@@@@@@@@@@@@@@@@@GOO@@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@COOON@@@@@@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@@@@AOOOOOL@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@OOOOOOO@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOON@@@@@@@@@@@OOOOOOOOO@@@@@@@@@@@OOOOOOOOOH@@@@@@@@@AOOOOOOOOOL@@@@@@@@@AOOOOOOOOOL@@@@@@@@@COOOOOOOOON@@@@@@@@@COOOOOOOOON@@@@@@@@@GOOOOOOOOOO@@@@@@@@@GOOOOOOOOOOH@@@@@@@@OOOOOOOOOOOH@@@@@@@@OOOOOOOOOOOH@@@@@@@AOOOOOOOOOOOL@@@@@@@AOOOOOOOOOOOL@@@@@@@AOOOOOOOOOOOL@@@@@@@COOOOOOOOOOON@@@@@@@COOOOOOOOOOON@@@@@@@GOOOOOOOOOOON@@@@@@@GOOOOOOOOOOON@@@@@@@GOOOOOOOOOOOO@@@@@@@GOOLOOOOOIOOO@@@@@@@@@@@COOOLAOOO@@@@@@@@@@@@CON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ *MISSLE-COMMAND-ICON* #*(80 60)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@@@@@@@@@@@@@@@@@@@G@@@@@@@@@@@@@@@@@@@OH@@@@@@@@@@@@@@@@@AOL@@@@@@@@@@@@@@@@@CON@@@@@@@@@@@@@@@@@GOO@@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@COOON@@@@@@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@@@@AOOOOOL@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@EOOOOOI@@@@@@@@@@@@@DAOOONA@@@@@@@@@@@@@D@@OL@A@@@@@@@@@@@@@D@@@@@A@@@@@@@@@@@@@D@@@@@A@@@@@@@@@@@@@D@B@H@A@@@@@@@@@@@@@D@C@H@A@@@@@@@@@@@@@D@BHH@A@@@@@@@@@@@@@D@BDH@A@@@@@@@@@@@@@D@BBH@A@@@@@@@@@@@@@D@BAH@A@@@@@@@@@@@@@D@B@H@A@@@@@@@@@@@@@D@@@@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@D@@D@@A@@@@@@@@@@@@@L@@D@@A@@@@@@@@@@@@AL@@D@@A@@@@@@@@@@@@CL@@D@@AH@@@@@@@@@@@GL@@@@@AL@@@@@@@@@@@GL@BAH@AN@@@@@@@@@@@OL@BB@@AO@@@@@@@@@@@OL@BD@@AOH@@@@@@@@@AOL@BH@@AOL@@@@@@@@@AOL@C@@@AOL@@@@@@@@@COL@BH@@AON@@@@@@@@@COL@BD@@AON@@@@@@@@@GOL@BB@@AOO@@@@@@@@@GOL@BAH@AOOH@@@@@@@@OOL@@@@@AOOH@@@@@@@@OOL@AOL@AOOH@@@@@@@AOOL@A@@@AOOL@@@@@@@AOOL@A@@@AOOL@@@@@@@AOOL@A@@@AOOL@@@@@@@COOL@AOH@AOON@@@@@@@COOL@A@@@AOON@@@@@@@GOOL@A@@@AOON@@@@@@@GOOL@A@@@AOON@@@@@@@GOOO@AOL@OOOO@@@@@@@GOOLN@@@GIOOO@@@@@@@@@@@CN@CLAOOO@@@@@@@@@@@@CON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ *SCORE* 17490) (RPAQQ *SKYLINE* #*(180 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOL@GOO@@@@@@@@@@@@@@@@COOOH@@@@@@@@@@@@@@@@@@@@AOL@GOO@@AON@@@@@@@@@@@COOOH@@@@@@@@@@@@@@@@@@@@AOL@GOO@@AON@@@@@@@@@@@COOOH@@@@@@@@@@@@@@@@@@@@AOL@GOO@@AON@@@@@@@@@@@COOOH@@@@@@@@@@@@@@@@@@@@AOL@GOO@@AON@@@@@@@@@@@COOOH@@@@@@@@@@@@@@@@@@COOOL@GOO@@AON@@@@@@@@@@@COOOH@@@@@@GOOOOO@@@@@@COOOL@GOOOOOON@@@@@@@@@@@COOOH@@@@@@GOOOOO@@@@@@COOOLAOOOOOOON@@@@@@@@@@@COOOH@@@@@@GOOOOO@@@@@@COOOLAOOOOOOON@@@@@@@@@@@COOOH@@@@@@GOOOOO@@@@@@COOOLAOOOOOOONCO@@@@OOOOOOOOOH@@@@@@GOOOOO@@@@@@OOOOLAOOOOOOONCO@@@@OOOOOOOOOH@@@@GOOOOOOO@@@@@@OOOOLAOOOOOOONCO@@@@OOOOOOOOOH@@@@GOOOOOOO@@@@@@OOOOLAOOOOOOONCO@@@@OOOOOOOOOH@@@@GOOOOOOO@@@@@@OOOOLAOOOOOOONCO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@@@@OOOOOOOOOOOOONCO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@@@@OOOOOOOOOOOOONCO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@@@@OOOOOOOOOOOOONCO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@@@@OOOOOOOOOOOOONCO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@@@@OOOOOOOOOOOOONCO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@OOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOHOOO@GOOOOOOO@@@OOOOOOOOOOOOOOOOOOO@GOOOOOOOOOOOHOOO@GOOOOOOO@@@OOOOOOOOOOOOOOOOOOO@GOOOOOOOOOOOHOOO@GOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOO@GOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@ ) (DECLARE%: EVAL@COMPILE (RECORD CITY (X Y STATUS REGION) X _ 0 Y _ 0 STATUS _ 'OK [ACCESSFNS ([DRAW (COND ((EQ (FETCH (CITY STATUS) OF DATUM) 'OK) (BITBLT *SKYLINE* 0 0 *GAME-WINDOW* (FETCH (CITY X) OF DATUM) (FETCH (CITY Y) OF DATUM))) (T (BITBLT *BLASTED-SKYLINE* 0 0 *GAME-WINDOW* (FETCH (CITY X) OF DATUM) (FETCH (CITY Y) OF DATUM] [ERASE (COND ((EQ (FETCH (CITY STATUS) OF DATUM) 'OK) (BITBLT *SKYLINE* 0 0 *GAME-WINDOW* (FETCH (CITY X) OF DATUM) (FETCH (CITY Y) OF DATUM) NIL NIL NIL 'ERASE)) (T (BITBLT *BLASTED-SKYLINE* 0 0 *GAME-WINDOW* (FETCH (CITY X) OF DATUM) (FETCH (CITY Y) OF DATUM) NIL NIL NIL 'ERASE] (BLAST (BLAST-CITY DATUM]) (RECORD SHOCK (X Y RADIUS REGION) X _ 100 Y _ 100 RADIUS _ 10 REGION _ NIL [ACCESSFNS ((DRAW (PROG NIL (BLOCK *BLOCK-TIME*) (FILLCIRCLE (FETCH (SHOCK X) OF DATUM) (FETCH (SHOCK Y) OF DATUM) (FETCH (SHOCK RADIUS) OF DATUM) BLACKSHADE *GAME-WINDOW*))) (ERASE (PROG NIL (BLOCK *BLOCK-TIME*) (FILLCIRCLE (FETCH (SHOCK X) OF DATUM) (FETCH (SHOCK Y) OF DATUM) (FETCH (SHOCK RADIUS) OF DATUM) WHITESHADE *GAME-WINDOW*))) (GROW (GROW-SHOCK DATUM]) (RECORD TRACE (X0 Y0 XN YN TARGET DX DY) X0 _ 0 Y0 _ 0 XN _ 0 YN _ 0 TARGET _ (PICK-TARGETS) [ACCESSFNS ((INIT (INIT-TRACE DATUM)) (DRAW (PROG NIL (BLOCK *BLOCK-TIME*) (DRAWLINE (FETCH (TRACE X0) OF DATUM) (FETCH (TRACE Y0) OF DATUM) (FETCH (TRACE XN) OF DATUM) (FETCH (TRACE YN) OF DATUM) 2 'REPLACE *GAME-WINDOW*))) (ERASE (PROG NIL (BLOCK *BLOCK-TIME*) (DRAWLINE (fetch (TRACE X0) of DATUM) (fetch (TRACE Y0) of DATUM) (fetch (TRACE XN) of DATUM) (fetch (TRACE YN) of DATUM) 2 'ERASE *GAME-WINDOW*))) (BUMP (BUMP-TRACE DATUM)) (MOVE (MOVE-TRACE DATUM)) (COLLIDE (COLLIDE-TRACE DATUM]) ) (DEFINEQ (BARGRAPH-ERASE [LAMBDA NIL (* edited%: "19-May-86 11:49") (DSPFILL *BAR-GRAPH* WHITESHADE 'REPLACE *GAME-WINDOW*]) (BLAST-CITY [LAMBDA (X) (* edited%: "16-May-86 18:19") (if (EQ (fetch (CITY STATUS) of X) 'GONE) then (fetch (CITY ERASE) of X) (fetch (CITY DRAW) of X) else (fetch (CITY ERASE) of X) (replace (CITY STATUS) of X with 'GONE) (fetch (CITY DRAW) of X) (DREMOVE X *TARGETS*) (RINGBELLS 2]) (BONUS-DISPLAY [LAMBDA NIL (* edited%: "20-May-86 14:02") (CLEARW *GAME-WINDOW*) (MOVETO 350 700 *GAME-WINDOW*) (PRIN1 " " *GAME-WINDOW*) (MOVETO 350 700 *GAME-WINDOW*) (PRIN1 "BONUS=" *GAME-WINDOW*) (PRIN1 *BONUS* *GAME-WINDOW*) (STROBE-CITIES) (MOVETO 350 660 *GAME-WINDOW*) (PRIN1 " X " *GAME-WINDOW*) (PRIN1 (SUB1 (LENGTH *TARGETS*)) *GAME-WINDOW*) (MOVETO 350 600 *GAME-WINDOW*) (PRIN1 "TOTAL is " *GAME-WINDOW*) (PRIN1 (ITIMES (SUB1 (LENGTH *TARGETS*)) *BONUS*) *GAME-WINDOW*) (DISMISS 2000) (SETQ *SCORE* (IPLUS *SCORE* (PRIN1 (ITIMES (SUB1 (LENGTH *TARGETS*)) *BONUS*) *GAME-WINDOW*))) (SETQ *BONUS* (IPLUS *BONUS-DELTA* *BONUS*]) (BUMP-TRACE [LAMBDA (NEWTRACE) (* edited%: "19-May-86 10:07") [replace (TRACE XN) of NEWTRACE with (ABS (IDIFFERENCE (fetch (TRACE XN) of NEWTRACE) (fetch (TRACE DX) of NEWTRACE] (replace (TRACE YN) of NEWTRACE with (ABS (IDIFFERENCE (fetch (TRACE YN) of NEWTRACE) (fetch (TRACE DY) of NEWTRACE]) (COIN-FLIP [LAMBDA NIL (* edited%: "20-May-86 19:51") (if (AND (ILEQ (RAND 1 100) *GUESSFACTOR*) (IGEQ (LENGTH *TARGETS*) 3)) then T else NIL]) (COLLIDE-TRACE [LAMBDA (NEWTRACE) (* edited%: "16-May-86 16:48") (LET* ((ENDX (fetch (TRACE XN) of NEWTRACE)) (ENDY (fetch (TRACE YN) of NEWTRACE)) (TRACE-TARGET (fetch (TRACE TARGET) of NEWTRACE)) (TRACE-POS (CONS ENDX ENDY)) (TRACE-REGION (fetch (CITY REGION) of TRACE-TARGET))) (COND ((MYINSIDE TRACE-REGION TRACE-POS) (fetch (TRACE ERASE) of NEWTRACE) (fetch (CITY BLAST) of TRACE-TARGET) (DREMOVE TRACE-TARGET *TARGETS*) (DREMOVE NEWTRACE *TRACES*) T) ((NOT (MYINSIDE *LEGAL-REGION* TRACE-POS)) (fetch (TRACE ERASE) of NEWTRACE) (fetch (CITY DRAW) of TRACE-TARGET) (DREMOVE NEWTRACE *TRACES*) T) ((INTERCEPTED NEWTRACE TRACE-POS) T) (T NIL]) (DISPLAY-MISSILES [LAMBDA NIL (* edited%: "19-May-86 12:49") (BARGRAPH-ERASE) (MOVETO *BAR-GRAPHX* *BAR-GRAPHY* *GAME-WINDOW*) (SETQ *MISSILES-USED* (ADD1 *MISSILES-USED*)) (SETQ *MISSILES-LEFT* (IDIFFERENCE *MAX-MISSILES* *MISSILES-USED*)) (SETQ *BAR-GRAPH* (LIST *BARDISPX* *BARDISPY* (ITIMES *MISSILES-LEFT* *BARFACTOR*) *BARHEIGHT*)) (UPDATE-BARGRAPH]) (GEN-MIRV [LAMBDA (NEWTRACE) (* edited%: "20-May-86 20:41") (LET* [(SX (fetch (TRACE XN) of NEWTRACE)) (SY (fetch (TRACE YN) of NEWTRACE)) (CLUSTER (for N to (SUB1 (LENGTH *TARGETS*)) collect (PROG ((TMP (create TRACE))) (replace (TRACE TARGET) of TMP with (CAR (NTH *TARGETS* N))) (replace (TRACE X0) of TMP with SX) (replace (TRACE XN) of TMP with SX) (replace (TRACE Y0) of TMP with SY) (replace (TRACE YN) of TMP with SY) (replace (TRACE DX) of TMP with (IQUOTIENT (IDIFFERENCE SX (PLUS (fetch (CITY X) of (fetch (TRACE TARGET) of TMP)) *CITY-XOFST*)) *SPEED*)) (replace (TRACE DY) of TMP with (IQUOTIENT (IDIFFERENCE SY (PLUS (fetch (CITY Y) of (fetch (TRACE TARGET) of TMP)) *CITY-YOFST*)) *SPEED*)) (fetch (TRACE DRAW) of TMP) (RETURN TMP] (DREMOVE NEWTRACE *TRACES*) (SETQ *TRACES* (NCONC CLUSTER *TRACES*]) (GEN-SHOCK [LAMBDA NIL (* edited%: "19-May-86 12:54") (COND ((IGEQ *MISSILES-USED* *MAX-MISSILES*) NIL) (T (GETMOUSESTATE) (LET ((POSX (LASTMOUSEX *GAME-WINDOW*)) (POSY (LASTMOUSEY *GAME-WINDOW*)) (NEWSHOCK (create SHOCK)) (SIZE (IPLUS *RADIUS-DELTA* *RADIUS-DELTA*))) (DISPLAY-MISSILES) (replace (SHOCK X) of NEWSHOCK with POSX) (replace (SHOCK Y) of NEWSHOCK with POSY) (replace (SHOCK RADIUS) of NEWSHOCK with *RADIUS-DELTA*) (fetch (SHOCK DRAW) of NEWSHOCK) (replace (SHOCK REGION) of NEWSHOCK with (LIST (DIFFERENCE POSX *RADIUS-DELTA*) (DIFFERENCE POSY *RADIUS-DELTA*) SIZE SIZE)) (SETQ *SHOCK-WAVES* (CONS NEWSHOCK *SHOCK-WAVES*]) (GEN-TARGETS [LAMBDA NIL (* edited%: "19-May-86 20:05") (for I from 100 to 900 by 200 do (LET* ((TMP (create CITY))) (replace X of TMP with (DIFFERENCE I 90)) (replace Y of TMP with 50) (replace (CITY REGION) of TMP with (LIST (DIFFERENCE I 90) 50 *CITY-WIDTH* *CITY-HEIGHT*)) (SETQ *TARGETS* (CONS TMP *TARGETS*)) (fetch (CITY DRAW) of TMP]) (GEN-TRACES [LAMBDA NIL (* edited%: "15-May-86 17:14") [SETQ *TRACES* (for N to (RAND 1 *MAX-TRACES*) collect (PROG ((TMP (create TRACE))) (fetch (TRACE INIT) of TMP) (RETURN TMP] (NCONC *TRACES* (LIST T]) (GROW-SHOCK [LAMBDA (SHOCKWAVE) (* edited%: "16-May-86 16:21") (fetch (SHOCK ERASE) of SHOCKWAVE) (COND ((EQ T SHOCKWAVE) NIL) ((GREATERP (IPLUS (fetch (SHOCK RADIUS) of SHOCKWAVE) *RADIUS-DELTA*) *MAX-RADIUS*) (DREMOVE SHOCKWAVE *SHOCK-WAVES*)) (T (replace (SHOCK RADIUS) of SHOCKWAVE with (IPLUS *RADIUS-DELTA* (fetch (SHOCK RADIUS) of SHOCKWAVE))) (fetch (SHOCK DRAW) of SHOCKWAVE) (LET* ((DISP (fetch (SHOCK RADIUS) of SHOCKWAVE)) (SIZE (IPLUS DISP DISP))) (replace (SHOCK REGION) of SHOCKWAVE with (LIST (IDIFFERENCE (fetch (SHOCK X) of SHOCKWAVE) DISP) (IDIFFERENCE (fetch (SHOCK Y) of SHOCKWAVE) DISP) SIZE SIZE)) (SHOCK-COLLISION SHOCKWAVE]) (INIT-MISSILE [LAMBDA NIL (* edited%: "20-May-86 20:43") (SETCURSOR WAITINGCURSOR) [COND ((AND (BOUNDP '*GAME-WINDOW*) *GAME-WINDOW*) (CLEARW *GAME-WINDOW*)) (T (SETQ *GAME-WINDOW* (CREATEW '(5 20 1010 780) "Missile Command")) (WINDOWPROP *GAME-WINDOW* 'BUTTONEVENTFN 'GEN-SHOCK) (DSPFONT (FONTCREATE 'TIMESROMAN 36 'BOLD) *GAME-WINDOW*) (WINDOWPROP *GAME-WINDOW* 'ICON (ICONW *MISSILE-COMMAND-ICON* *MISSILE-COMMAND-MASK* '(20 . 20] (COND ((ASSOC 'MissileCommand BackgroundMenuCommands) NIL) (T [SETQ BackgroundMenuCommands (APPEND BackgroundMenuCommands (LIST (LIST 'MissileCommand '(MISSILE-COMMAND] (SETQ BackgroundMenu NIL))) (SETQ *TARGETS* '(T)) (SETQ *TRACES* '(T)) (SETQ *MAX-TRACES* 50) (SETQ *MISSILES* '(T)) (SETQ *LEFT* 10) (SETQ *RIGHT* 1000) (SETQ *FLOOR* 65) (SETQ *INITIAL-Y* 760) (SETQ *SPEED* 9) (SETQ *CITY-HEIGHT* 50) (SETQ *CITY-WIDTH* 180) (SETQ *CITY-XOFST* 90) (SETQ *CITY-YOFST* 25) (SETQ *SCORE* 0) (SETQ *SCOREX* 425) (SETQ *SCOREY* 5) (SETQ *SCORE-DELTA* 10) (SETQ *SCORE-INCR* 10) (SETQ *MAX-RADIUS* 75) (SETQ *RADIUS-DELTA* 26) (SETQ *SHOCK-WAVES* '(T)) (SETQ *MAX-MISSILES* 75) (SETQ *MISSILES-USED* 0) (SETQ *MISSILES-LEFT* (IDIFFERENCE *MAX-MISSILES* *MISSILES-USED*)) (SETQ *BARDISPX* 200) (SETQ *BARDISPY* 5) (SETQ *BARHEIGHT* 25) (SETQ *BARFACTOR* 2) (SETQ *BAR-GRAPH* (LIST *BARDISPX* *BARDISPY* (ITIMES *MISSILES-LEFT* *BARFACTOR*) *BARHEIGHT*)) (SETQ *BAR-GRAPHX* 5) (SETQ *BAR-GRAPHY* 5) (SETQ *BARMSGX* 10) (SETQ *BARMSGY* 5) (SETQ *BLOCK-TIME* 20) (SETQ *LEGAL-REGION* (LIST *LEFT* *FLOOR* 1005 725)) (SETQ *BONUS* 100) (SETQ *BONUS-DELTA* 100) (SETQ *ROUND* 0) (SETQ *GUESSFACTOR* 2) (GEN-TARGETS) (GEN-TRACES) (SETCURSOR DEFAULTCURSOR) (UPDATE-SCORE) (DISPLAY-MISSILES]) (INIT-TRACE [LAMBDA (NEWTRACE) (* edited%: "20-May-86 19:36") (LET [(SPOT (RAND *LEFT* *RIGHT*)) (XT (fetch (CITY X) of (fetch (TRACE TARGET) of NEWTRACE))) (YT (fetch (CITY Y) of (fetch (TRACE TARGET) of NEWTRACE] (replace (TRACE X0) of NEWTRACE with SPOT) (replace (TRACE Y0) of NEWTRACE with *INITIAL-Y*) (replace (TRACE DX) of NEWTRACE with (IQUOTIENT (IDIFFERENCE SPOT (PLUS XT *CITY-XOFST*)) *SPEED*)) (replace (TRACE DY) of NEWTRACE with (IQUOTIENT (IDIFFERENCE *INITIAL-Y* (PLUS YT *CITY-YOFST*) ) *SPEED*)) (replace (TRACE XN) of NEWTRACE with SPOT) (replace (TRACE YN) of NEWTRACE with *INITIAL-Y*]) (INTERCEPTED [LAMBDA (NEWTRACE TRACEPOS) (* edited%: "19-May-86 10:08") (LET* ((SHOCKS *SHOCK-WAVES*)) (for N from 1 to (SUB1 (LENGTH SHOCKS)) do (COND ((MYINSIDE (fetch (SHOCK REGION) of (CAR SHOCKS)) TRACEPOS) (fetch (TRACE ERASE) of NEWTRACE) (DREMOVE NEWTRACE *TRACES*) (SCORE-ADD *SCORE-DELTA*))) (SETQ SHOCKS (CDR SHOCKS]) (MAIN-LOOP [LAMBDA NIL (* edited%: "19-May-86 20:06") (INIT-MISSILE) (SETCURSOR CROSSHAIRS) (until (EQ (CAR *TARGETS*) T) do (COND ((EQ T (CAR *TRACES*)) (GEN-TRACES) (NEXT-PHASE))) (MAIN-LOOP-AUX)) (SETCURSOR DEFAULTCURSOR) (SHRINKW *GAME-WINDOW*) (WAKE.PROCESS MY-PARENT T]) (MAIN-LOOP-AUX [LAMBDA NIL (* edited%: "16-May-86 13:50") (LET [[SHOCKS (CAR (FNTH *SHOCK-WAVES* (RAND 1 (SUB1 (LENGTH *SHOCK-WAVES*] (TRACES (CAR (FNTH *TRACES* (RAND 1 (SUB1 (LENGTH *TRACES*] (COND ((AND (EQ TRACES T) (EQ SHOCKS T)) T) (T (if (AND (NEQ TRACES T) (NEQ TRACES NIL)) then (fetch (TRACE MOVE) of TRACES)) (if (AND (NEQ SHOCKS T) (NEQ SHOCKS NIL)) then (fetch (SHOCK GROW) of SHOCKS]) (MISSILE-COMMAND [LAMBDA NIL (* edited%: "19-May-86 20:06") (SETQ MISSILE-PROC (ADD.PROCESS '(MAIN-LOOP) 'NAME 'MissileCommand 'SUSPEND T)) (TTY.PROCESS MISSILE-PROC) (SPAWN.MOUSE) (SETQ MY-PARENT (THIS.PROCESS)) (WAKE.PROCESS MISSILE-PROC T) (BLOCK T) (DEL.PROCESS MISSILE-PROC]) (MOVE-TRACE [LAMBDA (NEWTRACE) (* edited%: "20-May-86 18:37") (COND ((fetch (TRACE COLLIDE) of NEWTRACE) NIL) ((COIN-FLIP) (GEN-MIRV NEWTRACE)) (T (fetch (TRACE ERASE) of NEWTRACE) (fetch (TRACE BUMP) of NEWTRACE) (fetch (TRACE DRAW) of NEWTRACE]) (MYINSIDE [LAMBDA (REGION POS) (* edited%: "16-May-86 16:52") (LET ((XT (CAR POS)) (YT (CDR POS)) (LEFT (CAR REGION)) (BOT (CADR REGION)) (WIDTH (CADDR REGION)) (HEIGHT (CADDDR REGION))) (if (AND (IGEQ XT LEFT) (IGEQ YT BOT) (ILEQ XT (IPLUS LEFT WIDTH)) (ILEQ YT (IPLUS BOT HEIGHT))) then T else NIL]) (NEXT-PHASE [LAMBDA NIL (* edited%: "20-May-86 16:59") (SETQ *ROUND* (ADD1 *ROUND*)) (CLEARW *GAME-WINDOW*) (SETQ *SHOCK-WAVES* '(T)) (OR (EQ *SPEED* 1) (SETQ *SPEED* (SUB1 *SPEED*))) (UPDATE-SCORE) (SETQ *MISSILES-USED* -1) (BONUS-DISPLAY) (CLEARW *GAME-WINDOW*) (UPDATE-SCORE) (MOVETO 375 500 *GAME-WINDOW*) (PRIN1 "End of Round " *GAME-WINDOW*) (PRIN1 *ROUND* *GAME-WINDOW*) (DISMISS 5000) (CLEARW *GAME-WINDOW*) (DISPLAY-MISSILES) (UPDATE-SCORE) (SETQ *SCORE-DELTA* (IPLUS *SCORE-DELTA* *SCORE-INCR*)) (for SOMECITY in *TARGETS* unless (EQ SOMECITY T) do (fetch (CITY DRAW) of SOMECITY]) (PICK-TARGETS [LAMBDA NIL (* edited%: "15-May-86 17:51") (CAR (NTH *TARGETS* (RAND 1 (SUB1 (LENGTH *TARGETS*]) (SCORE-ADD [LAMBDA (N) (* edited%: "19-May-86 10:04") (SETQ *SCORE* (IPLUS *SCORE* N)) (UPDATE-SCORE]) (SHOCK-COLLISION [LAMBDA (SHOCKWAVE) (* edited%: "19-May-86 10:09") (LET* ((TRACES *TRACES*)) (for N from 1 to (SUB1 (LENGTH TRACES)) do (COND ((EQ T (CAR TRACES)) NIL) ([MYINSIDE (fetch (SHOCK REGION) of SHOCKWAVE ) (CONS (fetch (TRACE XN) of (CAR TRACES)) (fetch (TRACE YN) of (CAR TRACES] (fetch (TRACE ERASE) of (CAR TRACES)) (DREMOVE (CAR TRACES) *TRACES*) (SCORE-ADD *SCORE-DELTA*))) (SETQ TRACES (CDR TRACES]) (STROBE-CITIES [LAMBDA NIL (* edited%: "20-May-86 13:32") (LET ((TMP 1)) (for SOMECITY in *TARGETS* unless (EQ SOMECITY T) do (fetch (CITY DRAW) of SOMECITY) (PLAYTUNE (LIST (CONS (IPLUS 300 (ITIMES TMP 100)) 30000))) (fetch (CITY ERASE) of SOMECITY) (SETQ TMP (ADD1 TMP)) (fetch (CITY DRAW) of SOMECITY)) (SUB1 (LENGTH *TARGETS*]) (UPDATE-BARGRAPH [LAMBDA NIL (* edited%: "19-May-86 12:42") (BARGRAPH-ERASE) (MOVETO *BARMSGX* *BARMSGY* *GAME-WINDOW*) (PRIN1 "MISSILES> " *GAME-WINDOW*) (DSPFILL *BAR-GRAPH* BLACKSHADE 'REPLACE *GAME-WINDOW*]) (UPDATE-SCORE [LAMBDA NIL (* edited%: "19-May-86 09:48") (MOVETO *SCOREX* *SCOREY* *GAME-WINDOW*) (PRIN1 "SCORE: " *GAME-WINDOW*) (PRIN1 *SCORE* *GAME-WINDOW*]) ) (PUTPROPS MISSILE COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (14185 34395 (BARGRAPH-ERASE 14195 . 14375) (BLAST-CITY 14377 . 14874) (BONUS-DISPLAY 14876 . 15841) (BUMP-TRACE 15843 . 16363) (COIN-FLIP 16365 . 16650) (COLLIDE-TRACE 16652 . 17678) ( DISPLAY-MISSILES 17680 . 18157) (GEN-MIRV 18159 . 20400) (GEN-SHOCK 20402 . 21477) (GEN-TARGETS 21479 . 22272) (GEN-TRACES 22274 . 22702) (GROW-SHOCK 22704 . 24151) (INIT-MISSILE 24153 . 26410) ( INIT-TRACE 26412 . 27516) (INTERCEPTED 27518 . 28359) (MAIN-LOOP 28361 . 28856) (MAIN-LOOP-AUX 28858 . 29528) (MISSILE-COMMAND 29530 . 29903) (MOVE-TRACE 29905 . 30307) (MYINSIDE 30309 . 30815) ( NEXT-PHASE 30817 . 31593) (PICK-TARGETS 31595 . 31770) (SCORE-ADD 31772 . 31947) (SHOCK-COLLISION 31949 . 33299) (STROBE-CITIES 33301 . 33864) (UPDATE-BARGRAPH 33866 . 34158) (UPDATE-SCORE 34160 . 34393))))) STOP \ No newline at end of file diff --git a/lispusers/MISSILE.tedit b/lispusers/MISSILE.tedit new file mode 100644 index 00000000..f519224e Binary files /dev/null and b/lispusers/MISSILE.tedit differ diff --git a/lispusers/MONITOR b/lispusers/MONITOR new file mode 100644 index 00000000..8905fe04 --- /dev/null +++ b/lispusers/MONITOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "14-Mar-88 17:29:38" |{MCS:MCS:STANFORD}MONITOR.;9| 10032 changes to%: (VARS MONITORCOMS) (FNS MONITOR.GET.BITMAP MONITOR MONITOR.BUTTONEVENTFN MONITOR.SHRINK.BITMAP MONITOR.SEND.BITMAP) (COURIERPROGRAMS MONITOR) previous date%: "14-Mar-88 09:15:11" |{MCS:MCS:STANFORD}MONITOR.;1|) (PRETTYCOMPRINT MONITORCOMS) (RPAQQ MONITORCOMS ((FNS MONITOR MONITOR.GET.BITMAP MONITOR.BUTTONEVENTFN MONITOR.SHRINK.BITMAP MONITOR.SEND.BITMAP) (COURIERPROGRAMS MONITOR) (INITVARS (MONITOR.SCALE 3) MONITOR.SCRATCH.BITMAPS) (GLOBALVARS MONITOR.SCALE MONITOR.SCRATCH.BITMAPS) (DECLARE%: DONTCOPY (RECORDS MONITOR.SCRATCH.BITMAP)) (FILES COURIERSERVE BITMAPFNS) (P (COURIER.START.SERVER)))) (DEFINEQ (MONITOR [LAMBDA (HOST SCALE) (* ; "Edited 14-Mar-88 13:46 by cdl") (LET ((COURIER.STREAM (COURIER.OPEN HOST)) BITMAP SCREEN.WINDOW CLOSEUP.WINDOW) (if (NULL SCALE) then (SETQ SCALE MONITOR.SCALE)) (SETQ BITMAP (MONITOR.GET.BITMAP COURIER.STREAM SCALE)) [SETQ SCREEN.WINDOW (CREATEW (with REGION (GETBOXREGION (WIDTHIFWINDOW (BITMAPWIDTH BITMAP)) (TIMES (HEIGHTIFWINDOW (BITMAPHEIGHT BITMAP )) 2)) (CREATEREGION LEFT BOTTOM WIDTH (QUOTIENT HEIGHT 2] (BITBLT BITMAP NIL NIL SCREEN.WINDOW) (SETQ CLOSEUP.WINDOW (CREATEW (with REGION (WINDOWPROP SCREEN.WINDOW 'REGION) (create REGION LEFT _ LEFT BOTTOM _ PTOP WIDTH _ WIDTH HEIGHT _ (HEIGHTIFWINDOW (BITMAPHEIGHT BITMAP) HOST))) HOST)) (ATTACHWINDOW CLOSEUP.WINDOW SCREEN.WINDOW) (BITBLT (MONITOR.GET.BITMAP COURIER.STREAM SCALE (DSPCLIPPINGREGION NIL SCREEN.WINDOW)) NIL NIL CLOSEUP.WINDOW) (WINDOWPROP SCREEN.WINDOW 'MONITOR.SCALE SCALE) (WINDOWPROP SCREEN.WINDOW 'COURIER.STREAM COURIER.STREAM) (WINDOWPROP SCREEN.WINDOW 'CLOSEUP.WINDOW CLOSEUP.WINDOW) (WINDOWPROP SCREEN.WINDOW 'BUTTONEVENTFN (FUNCTION MONITOR.BUTTONEVENTFN)) [WINDOWADDPROP SCREEN.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (CLOSEF? (WINDOWPROP WINDOW ' COURIER.STREAM)) (WINDOWPROP WINDOW 'CLOSEUP.WINDOW NIL] SCREEN.WINDOW]) (MONITOR.GET.BITMAP [LAMBDA (STREAM SCALE REGION) (* ; "Edited 14-Mar-88 14:01 by cdl") (LET (BULK.DATA.STREAM) (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ BULK.DATA.STREAM (COURIER.CALL STREAM 'MONITOR 'SEND.BITMAP SCALE REGION NIL] (READBM BULK.DATA.STREAM]) (MONITOR.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 14-Mar-88 13:33 by cdl") (LET ((SCALE (WINDOWPROP WINDOW 'MONITOR.SCALE)) REGION POSITION CLIPPINGREGION) (if (MOUSESTATE LEFT) then [with REGION (SETQ CLIPPINGREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ REGION (CREATEREGION NIL NIL (QUOTIENT WIDTH SCALE) (QUOTIENT HEIGHT SCALE] (until (MOUSESTATE UP) do (if [with POSITION (SETQ POSITION (CURSORPOSITION NIL WINDOW POSITION)) (with REGION REGION (OR (NEQ XCOORD LEFT) (NEQ YCOORD BOTTOM] then (with REGION REGION (if LEFT then (DSPFILL REGION BLACKSHADE 'INVERT WINDOW)) (with POSITION POSITION (SETQ LEFT XCOORD) (SETQ BOTTOM YCOORD))) (DSPFILL REGION BLACKSHADE 'INVERT WINDOW) else (BLOCK)) finally (if (with REGION REGION LEFT) then (DSPFILL REGION BLACKSHADE 'INVERT WINDOW))) (BITBLT [MONITOR.GET.BITMAP (WINDOWPROP WINDOW 'COURIER.STREAM) SCALE (with REGION CLIPPINGREGION (with POSITION (CURSORPOSITION NIL WINDOW POSITION) (create REGION LEFT _ (TIMES SCALE XCOORD) BOTTOM _ (TIMES SCALE YCOORD) WIDTH _ WIDTH HEIGHT _ HEIGHT smashing REGION] NIL NIL (WINDOWPROP WINDOW 'CLOSEUP.WINDOW)) elseif (MOUSESTATE MIDDLE) then (RESETFORM (CURSOR WAITINGCURSOR) (BITBLT (MONITOR.GET.BITMAP (WINDOWPROP WINDOW 'COURIER.STREAM) SCALE) NIL NIL WINDOW]) (MONITOR.SHRINK.BITMAP [LAMBDA (SOURCE SCALE DESTINATION SCRATCH) (* ; "Edited 14-Mar-88 11:37 by cdl") (* Specialized rewrite of SHRINKBITMAP) [if (EQP SCALE 1) then (BITBLT SOURCE NIL NIL DESTINATION) else (BLTSHADE WHITESHADE SCRATCH) (BLTSHADE WHITESHADE DESTINATION) (LET ((HEIGHT (BITMAPHEIGHT SOURCE)) (WIDTH (BITMAPWIDTH SOURCE))) (for Y from 0 to (SUB1 HEIGHT) do (BITBLT SOURCE 0 Y SCRATCH 0 (QUOTIENT Y SCALE) WIDTH 1 'INPUT 'PAINT)) (for X from 0 to (SUB1 WIDTH) do (BITBLT SCRATCH X 0 DESTINATION (QUOTIENT X SCALE) 0 1 HEIGHT 'INPUT 'PAINT] DESTINATION]) (MONITOR.SEND.BITMAP [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE SCALE REGION BULK.DATA.STREAM) (* ; "Edited 14-Mar-88 11:37 by cdl") [LET ((SCRATCH.BITMAP (ASSOC SCALE MONITOR.SCRATCH.BITMAPS))) [if (NULL SCRATCH.BITMAP) then (push MONITOR.SCRATCH.BITMAPS (SETQ SCRATCH.BITMAP (with REGION WHOLESCREEN (create MONITOR.SCRATCH.BITMAP BITMAPSCALE _ SCALE DESTINATION _ (BITMAPCREATE (QUOTIENT WIDTH SCALE) (QUOTIENT HEIGHT SCALE)) SCRATCH _ (BITMAPCREATE WIDTH (QUOTIENT HEIGHT SCALE ] (with MONITOR.SCRATCH.BITMAP SCRATCH.BITMAP (if REGION then (BLTSHADE WHITESHADE DESTINATION) (with REGION REGION (BITBLT (SCREENBITMAP) LEFT BOTTOM DESTINATION)) (WRITEBM BULK.DATA.STREAM DESTINATION) else (WRITEBM BULK.DATA.STREAM (MONITOR.SHRINK.BITMAP ( SCREENBITMAP ) SCALE DESTINATION SCRATCH] '(RETURN]) ) (COURIERPROGRAM MONITOR (1118 0) TYPES ((SCALE INTEGER) (REGION (SEQUENCE INTEGER))) PROCEDURES ((SEND.BITMAP 0 (SCALE REGION BULK.DATA.SINK) RETURNS NIL REPORTS NIL IMPLEMENTEDBY MONITOR.SEND.BITMAP)) ERRORS NIL) (RPAQ? MONITOR.SCALE 3) (RPAQ? MONITOR.SCRATCH.BITMAPS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MONITOR.SCALE MONITOR.SCRATCH.BITMAPS) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD MONITOR.SCRATCH.BITMAP (BITMAPSCALE DESTINATION SCRATCH)) ) ) (FILESLOAD COURIERSERVE BITMAPFNS) (COURIER.START.SERVER) (DECLARE%: DONTCOPY (FILEMAP (NIL (1029 9390 (MONITOR 1039 . 3201) (MONITOR.GET.BITMAP 3203 . 3685) (MONITOR.BUTTONEVENTFN 3687 . 6211) (MONITOR.SHRINK.BITMAP 6213 . 7126) (MONITOR.SEND.BITMAP 7128 . 9388))))) STOP \ No newline at end of file diff --git a/lispusers/MONITOR.TEDIT b/lispusers/MONITOR.TEDIT new file mode 100644 index 00000000..bb86fd15 Binary files /dev/null and b/lispusers/MONITOR.TEDIT differ diff --git a/lispusers/MTP b/lispusers/MTP new file mode 100644 index 00000000..418c7e59 --- /dev/null +++ b/lispusers/MTP @@ -0,0 +1 @@ +(FILECREATED "19-May-86 16:54:58" {LOGOS:AFB:SIP}MTP>MTP.;30 24943 changes to: (FNS MTP.MAKEANSWERFORM \MTP.COERCE.MSG \MTP.FILL) (VARS MTPCOMS) previous date: "18-May-86 18:34:55" {LOGOS:AFB:SIP}MTP>MTP.;27) (* Copyright (c) 1983, 1984, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MTPCOMS) (RPAQQ MTPCOMS ((COMS (* Lafite mode MTP) (FNS MTP.GET.USERDATA MTP.DELIVERMESSAGE MTP.PREPARE.SEND MTP.MAKEANSWERFORM) (ADDVARS (LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM MTP.GET.USERDATA))) (FNS \MTP.AUTHENTICATE \MTP.COERCE.MSG \MTP.FILL \MTP.INDENT \MTP.CLRBUF \MTP.PRINTADDRESSES) (INITVARS (MTP.SERVER) (MTP.LINELENGTH 70) (MTP.RIGHTMARGINWIDTH 10) (MTP.FILLMSGFLG 'ASK) (MTP.INSERTANSWERFLG T) (MTP.INSERTANSWERNSPACES 3))) [COMS (* MTP mail server) (FNS MTP.OPENMAILBOX MTP.POLLNEWMAIL MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE MTP.CLOSEMAILBOX) (FNS \MTP.ENDOFMESSAGESTATE \MTP.POLLNEWMAIL) (ADDVARS (MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE MTP.CLOSEMAILBOX ETHERPORT] (FILES LAFITE) (DECLARE: EVAL@COMPILE DONTCOPY (RECORDS MTPMAILBOX MTPPARSE) (CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES) (CONSTANTS * PUPTYPES) (GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG MTP.INSERTANSWERFLG MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT UNSUPPLIEDFIELDSTR MESSAGESTR \LAFITEUSERDATA MAILSERVERTYPES \LAFITE.AUTHENTICATION.FAILURE) (FILES (LOADCOMP) LAFITE DPUPFTP)))) (* Lafite mode MTP) (DEFINEQ (MTP.GET.USERDATA [LAMBDA NIL (* drc: "29-Apr-86 23:31") (LET ((PORT (ETHERPORT MTP.SERVER)) USER/PWD) (SETQ \LAFITEUSERDATA (if (NULL PORT) then (PRINTOUT PROMPTWINDOW T "MTP.SERVER not found -- " MTP.SERVER T) (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server") NIL else (SETQ USER/PWD (\INTERNAL/GETPASSWORD MTP.SERVER)) (AND (\MTP.AUTHENTICATE MTP.SERVER USER/PWD) (create LAFITEUSERDATA FULLUSERNAME _(CAR USER/PWD) ENCRYPTEDPASSWORD _(CDR USER/PWD) SHORTUSERNAME _(CAR USER/PWD) MAILSERVERS _(LIST (create MAILSERVER MAILPORT _ PORT MAILSERVERNAME _ MTP.SERVER MAILSERVEROPS _(CDR (ASSOC 'MTP MAILSERVERTYPES]) (MTP.DELIVERMESSAGE [LAMBDA (MSG PARSE W ABORTW) (* drc: "29-Apr-86 23:38") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (RESETLST (LET* ((USERDATA (\LAFITE.GET.USER.DATA)) (USER (fetch (LAFITEUSERDATA FULLUSERNAME) of USERDATA)) (MAILSERVER (CAR (fetch (LAFITEUSERDATA MAILSERVERS) of USERDATA))) [PLIST (LIST (LIST 'MAILBOX (fetch (MTPPARSE MAILBOX) of PARSE)) (LIST 'SENDER (CONCAT USER "@" (fetch MAILSERVERNAME of MAILSERVER] (PW (GETPROMPTWINDOW W)) (TEXT (\MTP.COERCE.MSG MSG (fetch (MTPPARSE EOH) of PARSE) PW)) INS OUTS) (AND (WINDOWPROP ABORTW 'ABORT) (ERROR!)) (PRINTOUT PW "delivering...") (SETQ INS (OPENBSPSTREAM (CONS (CAR (fetch (MAILSERVER MAILPORT) of MAILSERVER)) \PUPSOCKET.MTP) NIL '\FTP.ERRORHANDLER)) (if INS then (RESETSAVE NIL (LIST 'CLOSEBSPSTREAM INS 5000)) else (PRINTOUT PW (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) " not responding. ") (ERROR!)) (SETQ OUTS (BSPOUTPUTSTREAM INS)) (FTPPUTMARK OUTS (MARK# STORE-MAIL)) (\FTP.PRINTPLIST OUTS PLIST) (FTPPUTMARK OUTS (MARK# EOC)) (SELECTC (FTPGETMARK INS) ((MARK# YES) (FTPGETCODE INS) (\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG))) ((MARK# NO) (FTPGETCODE INS) (\FTP.FLUSH.TO.EOC INS PW) (ERROR!)) (\FTPERROR INS)) (FTPPUTMARK OUTS (MARK# HERE-IS-FILE)) (PRINTOUT OUTS (fetch (MTPPARSE FROMLINE) of PARSE) T) (PRINTOUT OUTS (fetch (MTPPARSE DATELINE) of PARSE) T) (COPYBYTES TEXT OUTS) (if (WINDOWPROP ABORTW 'ABORT) then (FTPPUTMARK OUTS (MARK# NO)) (ERROR!) else (FTPPUTMARK OUTS (MARK# YES))) (FTPPUTMARK OUTS (MARK# EOC)) (SELECTC (FTPGETMARK INS) ((MARK# YES) (FTPGETCODE INS) (\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG))) (PROGN (FTPGETCODE INS) (\FTP.FLUSH.TO.EOC INS PROMPTWINDOW) (ERROR!))) T]) (MTP.PREPARE.SEND [LAMBDA (MSG W) (* drc: "17-May-86 17:34") (LET* [(PARSE (\LAFITE.PREPARE.SEND MSG W)) (RECIPIENTS (APPEND (CDR (FASSOC 'To PARSE)) (CDR (FASSOC 'cc PARSE] (OR PARSE (\SENDMESSAGEFAIL W "Bad message format.")) (AND (FASSOC 'Sender PARSE) (\SENDMESSAGEFAIL W "Can't specify Sender!")) (AND (FASSOC ''Date PARSE) (\SENDMESSAGEFAIL W "Can't specify Date!")) (OR RECIPIENTS (\SENDMESSAGEFAIL W "No recipients?")) (create MTPPARSE FROMLINE _(CONCAT (if (ASSOC 'From PARSE) then "Sender: " else "From: ") (FULLUSERNAME)) MAILBOX _[CONCATLIST (for TAIL on RECIPIENTS collect (if (CDR TAIL) then (CONCAT (CAR TAIL) ", ") else (CAR TAIL] EOH _(CADR (FASSOC 'EOF PARSE)) DATELINE _(CONCAT "Date: " (DATE (DATEFORMAT DAY.OF.WEEK SPACES TIME.ZONE NO.SECONDS]) (MTP.MAKEANSWERFORM [LAMBDA (MSGS FOLDER) (* drc: "19-May-86 15:39") (PROG ((OLD.MSG (OR (CAR (LISTP MSGS)) MSGS)) [INSERT? (AND MTP.INSERTANSWERFLG (MENU (\LAFITE.CREATE.MENU '(("Yes" T "Insert the text of the message being answered") ("No" NIL "Normal answer form") ("Abort" 'ABORT "Abort Answer command")) "Insert Message?"] (OLD.TEXT (\LAFITE.OPEN.FOLDER FOLDER 'INPUT)) START END OLD.FIELDS SUBJECT FROM TO CC DATE REPLY-TO SENDER NEW.MSG NEW.TO NEW.CC) (if (EQ INSERT? 'ABORT) then (RETURN)) (SETQ START (fetch (LAFITEMSG START) of OLD.MSG)) (SETQ END (fetch (LAFITEMSG END) of OLD.MSG)) (SETQ OLD.FIELDS (LAFITE.PARSE.HEADER OLD.TEXT \LAPARSE.FULL START END)) (for PAIR in OLD.FIELDS do (SELECTQ (CAR PAIR) (Subject (SETQ SUBJECT (CADR PAIR))) (From (SETQ FROM (CDR PAIR))) (To (SETQ TO (CDR PAIR))) (cc (SETQ CC (CDR PAIR))) (Date (SETQ DATE (CADR PAIR))) (Reply-to (SETQ REPLY-TO (CDR PAIR))) (Sender (SETQ SENDER (CDR PAIR))) NIL)) (SETQ NEW.TO (OR REPLY-TO FROM SENDER)) (OR NEW.TO (RETURN (LAB.PROMPTPRINT FOLDER "Can't reply -- no From or Sender"))) (SETQ NEW.MSG (OPENTEXTSTREAM "" NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) (LINELENGTH MAX.SMALLP NEW.MSG) (PRINTOUT NEW.MSG "Subject: ") (if (NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3) "Re:")) then (printout NEW.MSG "Re: ")) (PRINTOUT NEW.MSG (OR SUBJECT UNSUPPLIEDFIELDSTR) T) (AND FROM (PRINTOUT NEW.MSG "In-reply-to: " (CAR FROM) "'s message of " DATE T)) (PRINTOUT NEW.MSG "To: ") (\MTP.PRINTADDRESSES NEW.TO NEW.MSG) (SETQ NEW.CC (LA.SETDIFFERENCE (if REPLY-TO then (LIST (FULLUSERNAME)) else (LA.REMOVEDUPLICATES (APPEND TO CC))) NEW.TO)) (if NEW.CC then (PRINTOUT NEW.MSG "cc: ") (\MTP.PRINTADDRESSES NEW.CC NEW.MSG)) (TERPRI NEW.MSG) (if INSERT? then (\MTP.FILL OLD.TEXT NEW.MSG MTP.INSERTANSWERNSPACES MTP.LINELENGTH START END) (PRINTOUT NEW.MSG MESSAGESTR T) else (LET [(SELECTPOSITION (ADD1 (GETFILEPTR NEW.MSG] (PRINTOUT NEW.MSG MESSAGESTR T) (TEDIT.SETSEL NEW.MSG SELECTPOSITION (NCHARS MESSAGESTR) 'RIGHT T))) (RETURN NEW.MSG]) ) (ADDTOVAR LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM MTP.GET.USERDATA)) (DEFINEQ (\MTP.AUTHENTICATE [LAMBDA (HOST USER/PWD) (* drc: "25-Apr-86 13:06") (* I couldn't get PUP authentication to work w/ our Misc server, so we just check for mailbox existence. Password checking is done when retrieving mail.) (LET* ((RESPONSE (\MTP.POLLNEWMAIL HOST (CAR USER/PWD))) (TYPE (CAR RESPONSE)) (MESSAGE (CDR RESPONSE))) (SELECTC TYPE ((LIST \PT.NEWMAIL \PT.NONEWMAIL) T) ((LIST \PT.NOMAILBOX \PT.ERROR) (SETQ \LAFITE.AUTHENTICATION.FAILURE MESSAGE) NIL) (NIL (PRINTOUT PROMPTWINDOW T HOST " not responding to authentication request." T) (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server") NIL) NIL]) (\MTP.COERCE.MSG [LAMBDA (MSG EOH ECHOSTREAM) (* drc: "19-May-86 16:08") (DECLARE (GLOBALVARS MTP.LINELENGTH)) (LET [(STREAM (COERCETEXTOBJ MSG 'STREAM)) (FILL? (SELECTQ MTP.FILLMSGFLG (ALWAYS T) (ASK (MENU (\LAFITE.CREATE.MENU '(("Yes" T "Break long lines in message to MTP.LINELENGTH") ("No" NIL "Deliver message as is") ("Abort" 'ABORT "Abort deliver command")) "Fill Text?"))) (NEVER NIL) (SHOULDNT] (if (EQ FILL? 'ABORT) then (ERROR!)) (if FILL? then (PRINTOUT ECHOSTREAM "filling...") (LET [(OUTS (OPENSTREAM '{NODIRCORE} 'BOTH] (COPYBYTES STREAM OUTS 0 EOH) (\MTP.FILL STREAM OUTS 0 MTP.LINELENGTH) (SETFILEPTR OUTS 0) OUTS) else STREAM]) (\MTP.FILL [LAMBDA (INS OUTS LMARGIN RMARGIN START END) (* drc: "19-May-86 16:46") (* * Copy bytes from INS to OUTS, indenting to LMARGIN. New lines started at last space before RMARGIN -- unless  the line ends before RMARGIN + MTP.RIGHTMARGINWIDTH anyway. Copy from START (default is current pos) to END  (default is EOF).) (until (GEQ (GETFILEPTR INS) END) as COLUMN from (ADD1 LMARGIN) bind (LINEBUF _(OPENSTREAM '{NODIRCORE} 'BOTH)) (CARRY _ LMARGIN) (END _(OR END (GETEOFPTR INS))) (LIMIT _(IPLUS RMARGIN MTP.RIGHTMARGINWIDTH)) (EDGE _(ADD1 RMARGIN)) BYTE SPACE SPACES first (AND START (SETFILEPTR INS START)) (\MTP.INDENT INS OUTS END LMARGIN) eachtime (SETQ BYTE (BIN INS)) (SELCHARQ BYTE ((SPACE TAB) (BOUT LINEBUF BYTE) (push SPACES COLUMN)) (EOL (SETFILEPTR LINEBUF 0) (\MTP.CLRBUF LINEBUF OUTS) (BOUT OUTS (CHARCODE EOL)) (\MTP.INDENT INS OUTS END LMARGIN) (SETQ CARRY (SETQ COLUMN LMARGIN))) (BOUT LINEBUF BYTE)) when (IGREATERP COLUMN LIMIT) do [if (SETQ SPACE (for SPACE in SPACES thereis (LEQ SPACE EDGE))) then (* dump line up to space) (COPYBYTES LINEBUF OUTS 0 (SUB1 (IDIFFERENCE SPACE CARRY))) (BIN LINEBUF) (* eat up space) (SETQ COLUMN (IPLUS LMARGIN (IDIFFERENCE COLUMN SPACE))) else (* punt) (COPYBYTES LINEBUF OUTS 0 (IDIFFERENCE RMARGIN CARRY)) (SETQ COLUMN (ADD1 (IPLUS LMARGIN MTP.RIGHTMARGINWIDTH] (BOUT OUTS (CHARCODE EOL)) (\MTP.INDENT INS OUTS END LMARGIN) (\MTP.CLRBUF LINEBUF OUTS) (SETQ SPACES) (SETQ CARRY COLUMN) finally (SETFILEPTR LINEBUF 0) (COPYBYTES LINEBUF OUTS]) (\MTP.INDENT [LAMBDA (INS OUTS END LMARGIN) (* drc: "18-May-86 18:31") (* * indent OUTS to LMARGIN, unless at end of INS or on an empty line) (if (AND (ILESSP (GETFILEPTR INS) END) (NEQ (PEEKCCODE INS) (CHARCODE EOL))) then (to LMARGIN do (BOUT OUTS (CHARCODE SPACE]) (\MTP.CLRBUF [LAMBDA (INS OUTS) (* drc: "30-Apr-86 00:14") (* * Flush INS to OUTS, and then clear INS) (COPYBYTES INS OUTS) (\SETEOFPTR INS 0) (SETFILEPTR INS 0]) (\MTP.PRINTADDRESSES [LAMBDA (ADDRESSLIST STREAM) (* bvm: "20-Dec-83 18:20") (for ADDR in ADDRESSLIST bind NTHTIME when ADDR do (COND (NTHTIME (PRIN1 ", " STREAM)) (T (SETQ NTHTIME T))) (PRIN1 ADDR STREAM)) (TERPRI STREAM]) ) (RPAQ? MTP.SERVER ) (RPAQ? MTP.LINELENGTH 70) (RPAQ? MTP.RIGHTMARGINWIDTH 10) (RPAQ? MTP.FILLMSGFLG 'ASK) (RPAQ? MTP.INSERTANSWERFLG T) (RPAQ? MTP.INSERTANSWERNSPACES 3) (* MTP mail server) (DEFINEQ (MTP.OPENMAILBOX [LAMBDA (PORT USER PWD MAILSERVER) (* drc: "20-Apr-86 17:49") (PROG ((MTP.PORT (CONS (CAR PORT) \PUPSOCKET.MTP)) (HOST (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER)) (LOGINFO (CONS USER PWD)) INS OUTS) (SELECTQ (MTP.POLLNEWMAIL PORT USER) (NIL (RETURN 'EMPTY)) (? (RETURN)) NIL) NEWCONNECTION (OR (SETQ INS (OPENBSPSTREAM MTP.PORT NIL (FUNCTION \FTP.ERRORHANDLER))) (RETURN)) (SETQ OUTS (BSPOUTPUTSTREAM INS)) RETRY (FTPPUTMARK OUTS (MARK# RETRIEVE-MAIL)) [\FTP.PRINTPLIST OUTS (LIST (LIST 'USER-NAME (CAR LOGINFO)) (LIST 'USER-PASSWORD (CDR LOGINFO] (.EOC. OUTS) (SELECTC (FTPGETMARK INS) [(MARK# NO) (SELECTQ (FTPGETCODE INS) ((16 17) (* bad user/pwd) (PRINTOUT PROMPTWINDOW T HOST " : ") (\FTP.FLUSH.TO.EOC INS PROMPTWINDOW) (TERPRI PROMPTWINDOW) (SETQ LOGINFO (\INTERNAL/GETPASSWORD HOST T NIL NIL NIL 'UNIX)) (MTP.GET.USERDATA) (if (BSPOPENP INS 'INPUT) then (GO RETRY) else (GO NEWCONNECTION))) (RETURN (\FTPERROR INS "MTP error"] [(MARK# HERE-IS-PLIST) (RETURN (CONS (create MTPMAILBOX MTPIN _ INS MTPOUT _ OUTS MTPSTATE _ 'OPEN] (RETURN (\FTPERROR NIL "MTP error"]) (MTP.POLLNEWMAIL [LAMBDA (HOSTPORT USER) (* drc: "25-Apr-86 12:44") (LET* ((RESPONSE (\MTP.POLLNEWMAIL HOSTPORT USER)) (TYPE (CAR RESPONSE)) (MESSAGE (CDR RESPONSE))) (SELECTC TYPE (\PT.NEWMAIL T) (\PT.NONEWMAIL NIL) ((LIST \PT.NOMAILBOX \PT.ERROR) (printout PROMPTWINDOW T HOSTPORT " : " MESSAGE T) '?) (NIL '?) NIL]) (MTP.NEXTMESSAGE [LAMBDA (MAILBOX) (* bvm: " 6-JUL-83 14:27") (SELECTQ (fetch MTPSTATE of MAILBOX) (EMPTY NIL) [OPEN (PROG ((PLIST (READPLIST (fetch MTPIN of MAILBOX))) (NEXTSTATE (QUOTE MESSAGE))) (RETURN (PROG1 (OR (for PAIR in PLIST do (SELECTQ (CAR PAIR) (LENGTH (push $$VAL (QUOTE LENGTH) (CADR PAIR))) (OPENED (SELECTQ (CADR PAIR) ((YES Yes yes) (push $$VAL (QUOTE EXAMINED) T)) NIL)) (DELETED (SELECTQ (CADR PAIR) [(YES Yes yes) (push $$VAL (QUOTE DELETEDFLG) T) (FTPGETMARK (fetch MTPIN of MAILBOX)) (\FTP.FLUSH.TO.MARK (fetch MTPIN of MAILBOX)) (SETQ NEXTSTATE ( \MTP.ENDOFMESSAGESTATE (fetch MTPIN of MAILBOX] NIL)) NIL)) T) (replace MTPSTATE of MAILBOX with NEXTSTATE] (ERROR "Mailbox not in good state for NEXTMESSAGE" MAILBOX]) (MTP.RETRIEVEMESSAGE [LAMBDA (MAILBOX OUTSTREAM) (* bvm: " 6-JUL-83 14:27") (SELECTQ (fetch MTPSTATE of MAILBOX) [MESSAGE (COND ((EQ (FTPGETMARK (fetch MTPIN of MAILBOX)) (MARK# HERE-IS-FILE)) (\FTP.FLUSH.TO.MARK (fetch MTPIN of MAILBOX) OUTSTREAM) (replace MTPSTATE of MAILBOX with (\MTP.ENDOFMESSAGESTATE (fetch MTPIN of MAILBOX] (\FTPERROR]) (MTP.CLOSEMAILBOX [LAMBDA (MAILBOX FLUSHP) (* bvm: " 9-May-84 15:35") (COND ((BSPOPENP (fetch MTPIN of MAILBOX)) (PROG1 [COND ((AND FLUSHP (EQ (fetch MTPSTATE of MAILBOX) (QUOTE EMPTY))) (FTPPUTMARK (fetch MTPOUT of MAILBOX) (MARK# FLUSH-MAILBOX)) (.EOC. (fetch MTPOUT of MAILBOX)) (SELECTC (FTPGETMARK (fetch MTPIN of MAILBOX)) ((MARK# YES) (FTPGETCODE (fetch MTPIN of MAILBOX)) (\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX) (.FTPDEBUGLOG.)) T) ((MARK# NO) (FTPGETCODE (fetch MTPIN of MAILBOX)) (\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX) PROMPTWINDOW) (QUOTE ?)) (PROGN (\FTPERROR) (QUOTE ?] (CLOSEBSPSTREAM (fetch MTPIN of MAILBOX) 5000]) ) (DEFINEQ (\MTP.ENDOFMESSAGESTATE [LAMBDA (INSTREAM) (* bvm: " 5-SEP-83 18:08") (SELECTC (FTPGETMARK INSTREAM) ((MARK# HERE-IS-PLIST) (QUOTE OPEN)) ((MARK# YES) (FTPGETCODE INSTREAM) (\FTP.FLUSH.TO.EOC INSTREAM (.FTPDEBUGLOG.)) (QUOTE EMPTY)) ((MARK# NO) (FTPGETCODE INSTREAM) (\FTP.FLUSH.TO.EOC INSTREAM PROMPTWINDOW) (QUOTE ERROR)) (\FTPERROR]) (\MTP.POLLNEWMAIL [LAMBDA (HOSTPORT USER) (* drc: "25-Apr-86 12:28") (* * Does a Laurel-style mail check for USER on machine HOSTPORT, returning NIL (timeout) or a cons of the PUP type of the response and the contents of the response) (LET ((SOC (\GETMISCSOCKET)) (OUTPUP (ALLOCATE.PUP)) INPUP RESPONSE) (SETUPPUP OUTPUP HOSTPORT \PUPSOCKET.MISCSERVICES \PT.LAURELCHECK NIL SOC T) (PUTPUPSTRING OUTPUP USER) [SETQ RESPONSE (to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T)) do (RETURN (CONS (fetch PUPTYPE of INPUP) (GETPUPSTRING INPUP))) finally (AND PUPTRACEFLG (printout PUPTRACEFILE "Mail check timed out" T] (AND INPUP (RELEASE.PUP INPUP)) (RELEASE.PUP OUTPUP) RESPONSE]) ) (ADDTOVAR MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE MTP.CLOSEMAILBOX ETHERPORT)) (FILESLOAD LAFITE) (DECLARE: EVAL@COMPILE DONTCOPY [DECLARE: EVAL@COMPILE (RECORD MTPMAILBOX (MTPIN MTPOUT MTPSTATE)) (RECORD MTPPARSE (FROMLINE MAILBOX EOH DATELINE)) ] (DECLARE: EVAL@COMPILE (RPAQQ \PUPSOCKET.MTP 7) (RPAQQ \PUPSOCKET.MISCSERVICES 4) (CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES) ) (RPAQQ PUPTYPES ((\PT.ECHOME 1) (\PT.IAMECHO 2) (\PT.IAMBADECHO 3) (\PT.ERROR 4) (\PT.RFC 8) (\PT.ABORT 9) (\PT.END 10) (\PT.ENDREPLY 11) (\PT.DATA 16) (\PT.ADATA 17) (\PT.ACK 18) (\PT.MARK 19) (\PT.INTERRUPT 20) (\PT.INTERRUPTREPLY 21) (\PT.AMARK 22) (\PT.GATEWAYREQUEST 128) (\PT.GATEWAYRESPONSE 129) (\PT.ALTOTIMEREQUEST 134) (\PT.ALTOTIMERESPONSE 135) (\PT.MSGCHECK 136) (\PT.NEWMAIL 137) (\PT.NONEWMAIL 138) (\PT.NOMAILBOX 139) (\PT.LAURELCHECK 140) (\PT.NAMELOOKUP 144) (\PT.NAMERESPONSE 145) (\PT.NAME/ADDRERROR 146) (\PT.ADDRLOOKUP 147) (\PT.ADDRRESPONSE 148) (\PT.PRINTERSTATUS 128) (\PT.STATUSRESPONSE 129) (\PT.PRINTERCAPABILITY 130) (\PT.CAPABILITYRESPONSE 131) (\PT.PRINTJOBSTATUS 132) (\PT.PRINTJOBRESPONSE 133) (\PT.WHEREUSERREQUEST 152) (\PT.WHEREUSERRESPONSE 153) (\PT.WHEREUSERERROR 154) (\PT.AUTHREQ 168) (\PT.AUTHPOSRESP 169) (\PT.AUTHNEGRESP 170))) (DECLARE: EVAL@COMPILE (RPAQQ \PT.ECHOME 1) (RPAQQ \PT.IAMECHO 2) (RPAQQ \PT.IAMBADECHO 3) (RPAQQ \PT.ERROR 4) (RPAQQ \PT.RFC 8) (RPAQQ \PT.ABORT 9) (RPAQQ \PT.END 10) (RPAQQ \PT.ENDREPLY 11) (RPAQQ \PT.DATA 16) (RPAQQ \PT.ADATA 17) (RPAQQ \PT.ACK 18) (RPAQQ \PT.MARK 19) (RPAQQ \PT.INTERRUPT 20) (RPAQQ \PT.INTERRUPTREPLY 21) (RPAQQ \PT.AMARK 22) (RPAQQ \PT.GATEWAYREQUEST 128) (RPAQQ \PT.GATEWAYRESPONSE 129) (RPAQQ \PT.ALTOTIMEREQUEST 134) (RPAQQ \PT.ALTOTIMERESPONSE 135) (RPAQQ \PT.MSGCHECK 136) (RPAQQ \PT.NEWMAIL 137) (RPAQQ \PT.NONEWMAIL 138) (RPAQQ \PT.NOMAILBOX 139) (RPAQQ \PT.LAURELCHECK 140) (RPAQQ \PT.NAMELOOKUP 144) (RPAQQ \PT.NAMERESPONSE 145) (RPAQQ \PT.NAME/ADDRERROR 146) (RPAQQ \PT.ADDRLOOKUP 147) (RPAQQ \PT.ADDRRESPONSE 148) (RPAQQ \PT.PRINTERSTATUS 128) (RPAQQ \PT.STATUSRESPONSE 129) (RPAQQ \PT.PRINTERCAPABILITY 130) (RPAQQ \PT.CAPABILITYRESPONSE 131) (RPAQQ \PT.PRINTJOBSTATUS 132) (RPAQQ \PT.PRINTJOBRESPONSE 133) (RPAQQ \PT.WHEREUSERREQUEST 152) (RPAQQ \PT.WHEREUSERRESPONSE 153) (RPAQQ \PT.WHEREUSERERROR 154) (RPAQQ \PT.AUTHREQ 168) (RPAQQ \PT.AUTHPOSRESP 169) (RPAQQ \PT.AUTHNEGRESP 170) (CONSTANTS (\PT.ECHOME 1) (\PT.IAMECHO 2) (\PT.IAMBADECHO 3) (\PT.ERROR 4) (\PT.RFC 8) (\PT.ABORT 9) (\PT.END 10) (\PT.ENDREPLY 11) (\PT.DATA 16) (\PT.ADATA 17) (\PT.ACK 18) (\PT.MARK 19) (\PT.INTERRUPT 20) (\PT.INTERRUPTREPLY 21) (\PT.AMARK 22) (\PT.GATEWAYREQUEST 128) (\PT.GATEWAYRESPONSE 129) (\PT.ALTOTIMEREQUEST 134) (\PT.ALTOTIMERESPONSE 135) (\PT.MSGCHECK 136) (\PT.NEWMAIL 137) (\PT.NONEWMAIL 138) (\PT.NOMAILBOX 139) (\PT.LAURELCHECK 140) (\PT.NAMELOOKUP 144) (\PT.NAMERESPONSE 145) (\PT.NAME/ADDRERROR 146) (\PT.ADDRLOOKUP 147) (\PT.ADDRRESPONSE 148) (\PT.PRINTERSTATUS 128) (\PT.STATUSRESPONSE 129) (\PT.PRINTERCAPABILITY 130) (\PT.CAPABILITYRESPONSE 131) (\PT.PRINTJOBSTATUS 132) (\PT.PRINTJOBRESPONSE 133) (\PT.WHEREUSERREQUEST 152) (\PT.WHEREUSERRESPONSE 153) (\PT.WHEREUSERERROR 154) (\PT.AUTHREQ 168) (\PT.AUTHPOSRESP 169) (\PT.AUTHNEGRESP 170)) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG MTP.INSERTANSWERFLG MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT UNSUPPLIEDFIELDSTR MESSAGESTR \LAFITEUSERDATA MAILSERVERTYPES \LAFITE.AUTHENTICATION.FAILURE) ) (FILESLOAD (LOADCOMP) LAFITE DPUPFTP) ) (PUTPROPS MTP COPYRIGHT ("Xerox Corporation" 1983 1984 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1752 9114 (MTP.GET.USERDATA 1762 . 2673) (MTP.DELIVERMESSAGE 2675 . 5157) ( MTP.PREPARE.SEND 5159 . 6357) (MTP.MAKEANSWERFORM 6359 . 9112)) (9234 14145 (\MTP.AUTHENTICATE 9244 . 10051) (\MTP.COERCE.MSG 10053 . 10989) (\MTP.FILL 10991 . 13160) (\MTP.INDENT 13162 . 13549) ( \MTP.CLRBUF 13551 . 13804) (\MTP.PRINTADDRESSES 13806 . 14143)) (14374 19185 (MTP.OPENMAILBOX 14384 . 16017) (MTP.POLLNEWMAIL 16019 . 16477) (MTP.NEXTMESSAGE 16479 . 17734) (MTP.RETRIEVEMESSAGE 17736 . 18259) (MTP.CLOSEMAILBOX 18261 . 19183)) (19186 20624 (\MTP.ENDOFMESSAGESTATE 19196 . 19666) ( \MTP.POLLNEWMAIL 19668 . 20622))))) STOP \ No newline at end of file diff --git a/lispusers/MULTIPLE-HARDCOPY b/lispusers/MULTIPLE-HARDCOPY new file mode 100644 index 00000000..54f38fc6 --- /dev/null +++ b/lispusers/MULTIPLE-HARDCOPY @@ -0,0 +1 @@ +(FILECREATED "22-Aug-86 12:23:34" {CSLI}PS:MULTIPLE-HARDCOPY.;2 8769 changes to: (FILEVARS MULTIPLE-HARDCOPYCOMS) (FNS MH.MAKE.GLOSSARY MULTIPLE.HARDCOPY MH.GET.INPUT.FILE MH.GET.PAGE# MH.SET.STARTINGPAGE#) (VARS MULTIPLE-HARDCOPYCOMS) previous date: "22-Aug-86 11:37:58" {CSLI}PS:MULTIPLE-HARDCOPY.;1) (PRETTYCOMPRINT MULTIPLE-HARDCOPYCOMS) (RPAQQ MULTIPLE-HARDCOPYCOMS [(FNS MH.GET.INPUT.FILE MH.MAKE.GLOSSARY MULTIPLE.HARDCOPY MH.SET.STARTINGPAGE# MH.GET.PAGE# TOC) (P (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU (QUOTE (MULTIPLE% HARDCOPY (QUOTE MULTIPLE.HARDCOPY) "HARDCOPY A LIST OF FILES."]) (DEFINEQ (MH.GET.INPUT.FILE [LAMBDA (FILE) (* edited: "22-Aug-86 12:11") (* Returns the file if the file is accessible or otherwise pesters the unwitting user until an existing file is  supplied or nil to abort) (PROG NIL LOOP(OR FILE (RETURN)) (AND (INFILEP FILE) (RETURN FILE)) (printout T (CONCAT FILE " [not found.] ") T "TYPE ANOTHER INPUT FILE (NIL TO ABORT): ") (SETQ FILE (READ T)) (OR FILE (RETURN)) (GO LOOP]) (MH.MAKE.GLOSSARY [LAMBDA (FILENAME) (* edited: "22-Aug-86 12:14") (* This function relies on the function TOC (written by Nick Briggs) to produce a table of contents. It just takes the TEdit stream returned by TOC and TEDIT.PUTs it to a file.) (COND ((BOUNDP (QUOTE MULTIPLE.HARDCOPY.LIST)) (TEDIT.PUT (TOC MULTIPLE.HARDCOPY.LIST) FILENAME)) (T (PRINTOUT T "MULTIPLE.HARDCOPY MUST BE RUN FIRST" T]) (MULTIPLE.HARDCOPY [LAMBDA (STREAM FILELST GLOSSARY.FILE TOFILE? DONTSEND UNFORMATTED? BREAKPAGETITLE SERVER PRINTOPTIONS) (* edited: "22-Aug-86 12:23") (* HARDCOPIES all the files in FILELST making sure that the files are numbered consecutively. If STREAM is supplied then it should be a TEdit stream. The intent is that one could set up one's desired page  looks in a TEdit window and then pass that TEdit stream to MULTIPLE.HARDCOPY which will use those page looks. If a STREAM is not given then a fresh TEdit window is started. FILELST should be a list of files to hardcopy in the order that they should be numbered. GLOSSARY.FILE, if given, should be the name of a file. If given then after  MULTIPLE.HARDCOPY is done hardcopying it will use the MH.MAKE.GLOSSARY to make a table of contents for the files  and save the table of contents in GLOSSARY.FILE. If TOFILE? is NON-NIL then an IP file will be created for each  file in FILELST that is the same name as the file but with extension IP. If DONTSEND is NON-NIL then the files will not be sent to the printer (this only makes sense if you're creating IP files). If UNFORMATTED? is NON-NIL then the files will be hardcopied without formatting information. BREAKPAGETITLE, SERVER and PRINTOPTIONS are the same as  per TEDIT.HARDCOPY. After MULTIPLE.HARDCOPY is done, it returns a variable MULTIPLE.HARDCOPY.LIST which is a useful list of information about this hardcopy process. The list is of the form: ( %. ) where each pair is of the form ( )) (PROG* (FRAME LOCALINFO INITIAL.DEFAULTPG PG) (OR FILELST (SETQ FILELST (TTYIN "FILELST TO HARDCOPY>>")) (RETURN (PRINTOUT T "No filelst specified."))) [OR STREAM (SETQ STREAM (TEXTSTREAM (PROCESSPROP (TEDIT (MH.GET.INPUT.FILE (CAR FILELST))) (QUOTE WINDOW] (COND ((ATOM FILELST) (SETQ FILELST (LIST FILELST))) (FILELST)) (SETQ FRAME (OR (fetch TXTPAGEFRAMES of (TEXTOBJ STREAM)) TEDIT.PAGE.FRAMES)) [SETQ LOCALINFO (fetch REGIONLOCALINFO of (COND ((LISTP FRAME) (CAR FRAME)) (T FRAME] [SETQ INITIAL.DEFAULTPG (AND (LISTGET LOCALINFO (QUOTE STARTINGPAGE#)) (SUB1 (LISTGET LOCALINFO (QUOTE STARTINGPAGE#] (SETQ PG (OR INITIAL.DEFAULTPG 0)) (SETQ MULTIPLE.HARDCOPY.LIST NIL) (ADVISE (QUOTE TEDIT.PROMPTPRINT) (QUOTE BEFORE) (QUOTE (SETQ PG MSG))) [for FILE in FILELST do (PROGN (SETQ FILE (MH.GET.INPUT.FILE FILE)) (OR FILE (RETURN)) (PROMPTPRINT "MULTIPLE.HARDCOPY: " (FULLNAME FILE)) (TEDIT.GET (TEXTOBJ STREAM) FILE UNFORMATTED?) (replace TXTPAGEFRAMES of (TEXTOBJ STREAM) with FRAME) (MH.SET.STARTINGPAGE# (ADD1 PG) FRAME) (TEDIT.HARDCOPY STREAM (COND (TOFILE? (PACKFILENAME (QUOTE NAME) TOFILE? (QUOTE EXTENSION) (QUOTE IP))) (T NIL)) DONTSEND BREAKPAGETITLE SERVER PRINTOPTIONS) (SETQ PG (MKATOM (MH.GET.PAGE# PG))) (SETQ MULTIPLE.HARDCOPY.LIST (NCONC1 MULTIPLE.HARDCOPY.LIST (CONS FILE PG] (UNADVISE TEDIT.PROMPTPRINT) (MH.SET.STARTINGPAGE# (AND INITIAL.DEFAULTPG (ADD1 INITIAL.DEFAULTPG)) FRAME) (RETURN (COND (MULTIPLE.HARDCOPY.LIST (SETQ MULTIPLE.HARDCOPY.LIST (CONS (OR (AND INITIAL.DEFAULTPG (ADD1 INITIAL.DEFAULTPG)) 1) MULTIPLE.HARDCOPY.LIST)) (COND (GLOSSARY.FILE (MH.MAKE.GLOSSARY GLOSSARY.FILE) (PRINTOUT T (CONCAT "Glossary file in: " (FULLNAME GLOSSARY.FILE) ) T))) MULTIPLE.HARDCOPY.LIST]) (MH.SET.STARTINGPAGE# [LAMBDA (PG# PAGE.FRAMES) (* edited: "22-Aug-86 12:15") (* Sets the starting page of a PAGE.FRAME.) [COND ((LISTP PAGE.FRAMES) (SETQ PAGE.FRAMES (CAR PAGE.FRAMES] (LET ((LOCAL.INFO (fetch REGIONLOCALINFO of PAGE.FRAMES))) (COND (LOCAL.INFO (LISTPUT (fetch REGIONLOCALINFO of PAGE.FRAMES) (QUOTE STARTINGPAGE#) PG#)) (T (replace REGIONLOCALINFO of PAGE.FRAMES with (LIST (QUOTE STARTINGPAGE#) PG#]) (MH.GET.PAGE# [LAMBDA (STR) (* edited: "22-Aug-86 12:13") (* This is meant to extract a number from a string such as "2pgs done." which is what TEdit prints out when it's  finished hardcopying something. This is unfortunately the way this program relies on to extract how many pages a  file was hardcopied.) (LET ((CH (GNC STR))) (COND ((NUMBERP (MKATOM CH)) (CONCAT CH (MH.GET.PAGE# STR))) (T ""]) (TOC [LAMBDA (FILE) (* edited: "22-Aug-86 11:48") (* (* N.H.Briggs " 8-Apr-86 11:23")) (LET (TOCSTREAM TOCINFO TOCOUTSTREAM STARTPAGE) (if (LISTP FILE) then (SETQ TOCINFO FILE) else [SETQ TOCINFO (READ (SETQ TOCSTREAM (OPENSTREAM FILE (QUOTE INPUT] (CLOSEF TOCSTREAM)) (SETQ TOCOUTSTREAM (OPENTEXTSTREAM "")) (SETQ STARTPAGE (CAR TOCINFO)) [for TOCENTRY in (CDR TOCINFO) do (TEDIT.INSERT TOCOUTSTREAM (FILENAMEFIELD (CAR TOCENTRY) (QUOTE NAME))) (TEDIT.INSERT TOCOUTSTREAM (CHARACTER (CHARCODE TAB))) (TEDIT.INSERT TOCOUTSTREAM (MKSTRING STARTPAGE)) (TEDIT.INSERT TOCOUTSTREAM (CHARACTER (CHARCODE CR))) (SETQ STARTPAGE (ADD1 (CDR TOCENTRY] (TEDIT.PARALOOKS TOCOUTSTREAM (QUOTE (TABS (NIL (360 . DOTTEDLEFT)) RIGHTMARGIN 456)) 1 (GETEOFPTR TOCOUTSTREAM)) TOCOUTSTREAM]) ) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU (QUOTE (MULTIPLE% HARDCOPY (QUOTE MULTIPLE.HARDCOPY) "HARDCOPY A LIST OF FILES."))) (DECLARE: DONTCOPY (FILEMAP (NIL (717 8614 (MH.GET.INPUT.FILE 727 . 1306) (MH.MAKE.GLOSSARY 1308 . 1825) ( MULTIPLE.HARDCOPY 1827 . 6270) (MH.SET.STARTINGPAGE# 6272 . 6917) (MH.GET.PAGE# 6919 . 7454) (TOC 7456 . 8612))))) STOP \ No newline at end of file diff --git a/lispusers/NEATICONS b/lispusers/NEATICONS new file mode 100644 index 00000000..dd31210c --- /dev/null +++ b/lispusers/NEATICONS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (PROG1 (DEFPACKAGE "NEATICONS" (USE "LISP" "XCL") ( IMPORT bind _ first for in until unless do collect finally if then else elseif create fetch of)) ( EXPORT (CLMAPCAR (CLFUNCTION (LAMBDA (STRING) (CLINTERN STRING "NEATICONS"))) (QUOTE ( "DEFAULT-SPACING" "DEFAULT-TOLERANCE" "NEATEN" "UNNEATEN" "USERMOVEFN"))) "NEATICONS"))) (IL:FILECREATED "17-Aug-87 14:00:19" IL:{DSK}DEV>NEATICONS.\;2 17753 IL:|changes| IL:|to:| (IL:ADVICE IL:SHRINKW) (IL:VARS IL:NEATICONSCOMS) IL:|previous| IL:|date:| "17-Aug-87 13:51:56" IL:{DSK}DEV>NEATICONS.\;1) ; Copyright (c) 1967, 1986, 1987 by Quintus Computer Systems, Inc. All rights reserved. (IL:PRETTYCOMPRINT IL:NEATICONSCOMS) (IL:RPAQQ IL:NEATICONSCOMS ( (IL:* IL:|;;| "This file makes sure that all icons (shrunken windows) created after this file is loaded are neat. This means that when an icon is near another window it is neatly placed NEATICONS:DEFAULT-SPACING (defaults to 5) pixels away, or the edge of the screen flushed with the edge of the screen, or if one of its edges is near the corresponding edge of another window, the edges will be perfectly aligned. It's a lot easier to understand what this means by trying it. An icon will be moved at most NEATICONS:DEFAULT-TOLERANCE (defaults to 100) pixels horizontally or vertically in order to make it neat. So if you put an icon in the middle of nowhere, it will stay there.") (IL:* IL:|;;| "This is done by advising SHRINKW to make newly generated icons neat. The function NEATICONS.NEATEN.WINDOW, when applied to a window, will make that window always neat. So after loading this file, newly created icons will always be neat; and users can make any window neat by calling (NEATICONS:NEATEN window). Note that existing icons can be made neat by expanding and re-shrinking them.") (IL:* IL:|;;| "Exported variables and functions") (IL:VARIABLES DEFAULT-SPACING DEFAULT-TOLERANCE) (IL:FUNCTIONS NEATEN UNNEATEN) (IL:* IL:|;;| "Private stuff") (IL:ADVISE IL:SHRINKW) (IL:FUNCTIONS BETWEEN MIN-ABSOLUTE MIN-SUM-SQUARES NEAT-POSITION) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:NEATICONS))) (IL:* IL:|;;| "This file makes sure that all icons (shrunken windows) created after this file is loaded are neat. This means that when an icon is near another window it is neatly placed NEATICONS:DEFAULT-SPACING (defaults to 5) pixels away, or the edge of the screen flushed with the edge of the screen, or if one of its edges is near the corresponding edge of another window, the edges will be perfectly aligned. It's a lot easier to understand what this means by trying it. An icon will be moved at most NEATICONS:DEFAULT-TOLERANCE (defaults to 100) pixels horizontally or vertically in order to make it neat. So if you put an icon in the middle of nowhere, it will stay there." ) (IL:* IL:|;;| "This is done by advising SHRINKW to make newly generated icons neat. The function NEATICONS.NEATEN.WINDOW, when applied to a window, will make that window always neat. So after loading this file, newly created icons will always be neat; and users can make any window neat by calling (NEATICONS:NEATEN window). Note that existing icons can be made neat by expanding and re-shrinking them." ) (IL:* IL:|;;| "Exported variables and functions") (DEFGLOBALPARAMETER DEFAULT-SPACING 5 "Number of pixels between neat icons.") (DEFGLOBALPARAMETER DEFAULT-TOLERANCE 100 "How far an icon will be moved to be neat.") (DEFUN NEATEN (&OPTIONAL (WINDOW (IL:WHICHW))) "Makes WINDOW (default: (WHICHW)) always neatly aligned with nearby windows" (IL:* IL:|;;;| "Makes WINDOW neat, i.e., makes it neatly aligned on the screen, and makes sure that wherever it is moved, it will remain neatly placed. Also makes sure that any existing MOVEFN on the window will still get called when the window is moved, and that function has the final decision as the window's actual new position. WINDOW defaults to (WHICHW)") (IL:* IL:|;;;| "For more on what it means to be neat, and how a neat postion for a window is determined, see NEATICONS::NEAT-POSITION") (|if| (IL:WINDOWP WINDOW) |then| (LET ((OLDMOVEFN (IL:WINDOWPROP WINDOW 'IL:MOVEFN 'NEAT-POSITION))) (|if| (NOT (IL:EQMEMB 'NEAT-POSITION OLDMOVEFN)) (IL:* IL:\;  "If it's not already neat ...") |then| (IL:WINDOWPROP WINDOW 'USERMOVEFN OLDMOVEFN) (IL:RELMOVEW WINDOW '(0 . 0))) (IL:* IL:\;  "invokes NEAT-POSITION to neaten WINDOW") WINDOW))) (DEFUN UNNEATEN (&OPTIONAL (WINDOW (IL:WHICHW))) "Makes WINDOW (default: (WHICHW)) a normal, non-neat window" (IL:* IL:|;;;| "undoes the effect of NEATICONS:NEATEN. WINDOW becomes a normal, sloppy, window. WINDOW defaults to (WHICHW)") (|if| (NOT (IL:WINDOWP WINDOW)) |then| (IL:ERROR "Not a window" WINDOW)) (IL:WINDOWPROP WINDOW 'IL:MOVEFN (IL:WINDOWPROP WINDOW 'USERMOVEFN NIL)) WINDOW) (IL:* IL:|;;| "Private stuff") (REINSTALL-ADVICE 'IL:SHRINKW :AROUND '((:LAST (LET ((IL:ICON IL:*)) (NEATEN IL:ICON) IL:ICON)))) (IL:READVISE IL:SHRINKW) (DEFMACRO BETWEEN (X LOWER UPPER) "X is between LOWER and UPPER?" `(LET ((XVALUE ,X)) (AND (>= XVALUE ,LOWER) (<= XVALUE ,UPPER)))) (DEFMACRO MIN-ABSOLUTE (ARG1 ARG2 &OPTIONAL ARG3) "Returns whichever arg has the smallest absolute value" `(LET* ((ARG1-VALUE ,ARG1) (ARG2-VALUE ,ARG2) (BEST-OF-TWO (|if| (< (ABS ARG2-VALUE) (ABS ARG1-VALUE)) |then| ARG2-VALUE |else| ARG1-VALUE))) ,(|if| ARG3 |then| `(LET ((ARG3-VALUE ,ARG3)) (|if| (< (ABS ARG3-VALUE) (ABS BEST-OF-TWO)) |then| ARG3-VALUE |else| BEST-OF-TWO)) |else| `BEST-OF-TWO))) (DEFMACRO MIN-SUM-SQUARES (&REST PAIRS) (IL:* IL:|;;;| "(min-sum-squares (deltax-1 deltay-1) (deltax-2 deltay-2) ...)") (IL:* IL:|;;;| "returns the (x,y) pair (2 values) that have the smallest deltax^2 + deltay^2") `(PROG ((BEST-DX ,(CAAR PAIRS)) (BEST-DY ,(CADAR PAIRS)) BEST-SUMSQ TEMP-SUMSQ) (SETQ BEST-SUMSQ (+ (* BEST-DX BEST-DX) (* BEST-DY BEST-DY))) ,@(|for| PR |in| (CDR PAIRS) |collect| `(|if| (< (SETQ TEMP-SUMSQ (+ (* ,(CAR PR) ,(CAR PR)) (* ,(CADR PR) ,(CADR PR)))) BEST-SUMSQ) |then| (SETQ BEST-SUMSQ TEMP-SUMSQ) (SETQ BEST-DX ,(CAR PR)) (SETQ BEST-DY ,(CADR PR)))) (RETURN (VALUES BEST-DX BEST-DY)))) (DEFUN NEAT-POSITION (WINDOW-TO-MOVE TENTATIVE-POSITION &OPTIONAL (TOLERANCE DEFAULT-TOLERANCE) (SPACING DEFAULT-SPACING)) "Returns the position nearest to TENTATIVE-POSITION that is neat." (|bind| (IL:* IL:|;;| "Variables describing the window we're moving and its new place:") (USERMOVEFN _ (IL:WINDOWPROP WINDOW-TO-MOVE 'USERMOVEFN)) (MYREG _ (IL:WINDOWPROP WINDOW-TO-MOVE 'IL:REGION)) (MYLEFT _ (|fetch| (IL:POSITION IL:XCOORD) |of| TENTATIVE-POSITION)) (MYBOTTOM _ (|fetch| (IL:POSITION IL:YCOORD) |of| TENTATIVE-POSITION)) MYWIDTH MYHEIGHT MYRIGHT (IL:* IL:|;;| "These describe the region WINDOW-TO-MOVE can be placed within and still meat the constraints imposed by TOLERANCE:") MYTOP MINLEFT MAXRIGHT MINBOTTOM MAXTOP (IL:* IL:|;;| "Variables to keep track of the best new place we've found so far:") BEST-DELTAX BEST-DELTAY BEST-CORNER-DELTAX BEST-CORNER-DELTAY CORNER-DELTAX-WINDOW CORNER-DELTAY-WINDOW (IL:* IL:|;;| "Variables holding information about each window in turn:") REGION LEFT RIGHT BOTTOM TOP (IL:* IL:|;;|  "When we're all done, these hold information needed to compute the final value:") BEST-POSITION USER-MOVE-VALUE |first| (SETQ MYWIDTH (|fetch| (IL:REGION IL:WIDTH) |of| MYREG)) (SETQ MYHEIGHT (|fetch| (IL:REGION IL:HEIGHT) |of| MYREG)) (SETQ MYRIGHT (+ MYLEFT MYWIDTH -1)) (SETQ MYTOP (+ MYBOTTOM MYHEIGHT -1)) (SETQ MINLEFT (- MYLEFT TOLERANCE)) (SETQ MAXRIGHT (+ MYRIGHT TOLERANCE)) (SETQ MINBOTTOM (- MYBOTTOM TOLERANCE)) (SETQ MAXTOP (+ MYTOP TOLERANCE)) (IL:* IL:|;;| "First guess at best position is nearest corner of the screen") (SETQ BEST-CORNER-DELTAX (SETQ BEST-DELTAX (MIN-ABSOLUTE (- IL:SCREENWIDTH MYRIGHT 1) (- MYLEFT)))) (SETQ BEST-CORNER-DELTAY (SETQ BEST-DELTAY (MIN-ABSOLUTE (- IL:SCREENHEIGHT MYTOP 1) (- MYBOTTOM)))) |for| WINDOW |in| (IL:OPENWINDOWS) |unless| (EQ WINDOW WINDOW-TO-MOVE) |do| (SETQ REGION (IL:WINDOWPROP WINDOW 'IL:REGION)) (SETQ LEFT (|fetch| (IL:REGION IL:LEFT) |of| REGION)) (SETQ RIGHT (|fetch| (IL:REGION IL:RIGHT) |of| REGION)) (SETQ BOTTOM (|fetch| (IL:REGION IL:BOTTOM) |of| REGION)) (SETQ TOP (|fetch| (IL:REGION IL:TOP) |of| REGION)) MYLEFT-LEFT (LET ((LEFT-MYLEFT (- LEFT MYLEFT)) (LEFT-MYRIGHT (- (- LEFT MYRIGHT) SPACING)) (RIGHT-MYLEFT (+ (- RIGHT MYLEFT) SPACING)) (RIGHT-MYRIGHT (- RIGHT MYRIGHT)) (BOTTOM-MYBOTTOM (- BOTTOM MYBOTTOM)) (BOTTOM-MYTOP (- (- BOTTOM MYTOP) SPACING)) (TOP-MYBOTTOM (+ (- TOP MYBOTTOM) SPACING)) (TOP-MYTOP (- TOP MYTOP))) (IL:* IL:|;;| "First, see if we can align with a corner of a window") (|if| (AND (OR (BETWEEN BOTTOM MINBOTTOM MAXTOP) (BETWEEN TOP MINBOTTOM MAXTOP)) (OR (BETWEEN LEFT MINLEFT MAXRIGHT) (BETWEEN RIGHT MINLEFT MAXRIGHT))) |then| (MULTIPLE-VALUE-SETQ (BEST-CORNER-DELTAX BEST-CORNER-DELTAY) (MIN-SUM-SQUARES (BEST-CORNER-DELTAX BEST-CORNER-DELTAY) (LEFT-MYRIGHT TOP-MYTOP) (LEFT-MYRIGHT BOTTOM-MYBOTTOM) (RIGHT-MYLEFT BOTTOM-MYBOTTOM) (RIGHT-MYLEFT TOP-MYTOP) (LEFT-MYLEFT BOTTOM-MYTOP) (LEFT-MYLEFT TOP-MYBOTTOM) (RIGHT-MYRIGHT BOTTOM-MYTOP) (RIGHT-MYRIGHT TOP-MYBOTTOM)))) (IL:* IL:|;;| "Now see if we can align with a side of a window") (|if| (OR (BETWEEN MYBOTTOM BOTTOM TOP) (BETWEEN MYTOP BOTTOM TOP)) |then| (SETQ BEST-DELTAX (MIN-ABSOLUTE BEST-DELTAX LEFT-MYRIGHT RIGHT-MYLEFT))) (|if| (OR (BETWEEN MYLEFT LEFT RIGHT) (BETWEEN MYRIGHT LEFT RIGHT)) |then| (SETQ BEST-DELTAY (MIN-ABSOLUTE BEST-DELTAY BOTTOM-MYTOP TOP-MYBOTTOM)))) |finally| (|if| (AND (IL:WINDOWP CORNER-DELTAX-WINDOW) (EQ CORNER-DELTAX-WINDOW CORNER-DELTAY-WINDOW)) |then| (IL:* IL:|;;| "we might be putting my window in the corner of another window. This code is meant to prevent the window from getting thrown on top of another window by preventing it from aligning two of its edges with the two corresponding edges of another window. But it doesn't work very well.") (|if| (<= (+ (* BEST-DELTAX BEST-DELTAX) (* BEST-CORNER-DELTAY BEST-CORNER-DELTAY)) (+ (* BEST-CORNER-DELTAX BEST-CORNER-DELTAX) (* BEST-DELTAY BEST-DELTAY))) |then| (SETQ BEST-DELTAY BEST-CORNER-DELTAY) |else| (SETQ BEST-DELTAX BEST-CORNER-DELTAX)) |else| (SETQ BEST-DELTAX (MIN-ABSOLUTE BEST-DELTAX BEST-CORNER-DELTAX)) (SETQ BEST-DELTAY (MIN-ABSOLUTE BEST-DELTAY BEST-CORNER-DELTAY))) (SETQ BEST-POSITION (|create| IL:POSITION IL:XCOORD _ (|if| (<= (ABS BEST-DELTAX) TOLERANCE) |then| (+ MYLEFT BEST-DELTAX) |else| MYLEFT) IL:YCOORD _ (|if| (<= (ABS BEST-DELTAY) TOLERANCE) |then| (+ MYBOTTOM BEST-DELTAY) |else| MYBOTTOM))) (SETQ USER-MOVE-VALUE (IL:* IL:\;  "find result of any other MOVEFNs") (|if| (NULL USERMOVEFN) |then| NIL |elseif| (EQ USERMOVEFN 'IL:DON\'T) |then| 'IL:DON\'T |elseif| (LISTP USERMOVEFN) |then| (|bind| (VAL _ BEST-POSITION) |for| FN |in| USERMOVEFN |until| (EQ VAL 'IL:DON\'T) |unless| (EQ FN 'NEAT-POSITION) |do| (SETQ VAL (OR (FUNCALL FN WINDOW-TO-MOVE VAL) VAL)) |finally| (RETURN VAL)) |elseif| (AND (SYMBOL-FUNCTION USERMOVEFN) (IL:NEQ USERMOVEFN 'NEAT-POSITION)) |then| (FUNCALL USERMOVEFN WINDOW-TO-MOVE BEST-POSITION) |else| NIL)) (RETURN (|if| (OR (EQ USER-MOVE-VALUE 'IL:DON\'T) (IL:POSITIONP USER-MOVE-VALUE)) |then| USER-MOVE-VALUE |else| BEST-POSITION)))) (IL:PUTPROPS IL:NEATICONS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (PROG1 (DEFPACKAGE "NEATICONS" (:USE "LISP" "XCL") (:IMPORT |bind| _ |first| |for| |in| |until| |unless| |do| |collect| |finally| |if| |then| |else| |elseif| |create| |fetch| |of|)) (EXPORT (MAPCAR #'(IL:LAMBDA (STRING) (INTERN STRING "NEATICONS")) '("DEFAULT-SPACING" "DEFAULT-TOLERANCE" "NEATEN" "UNNEATEN" "USERMOVEFN")) "NEATICONS")))) (IL:PUTPROPS IL:NEATICONS IL:COPYRIGHT ("Quintus Computer Systems, Inc" 1967 1986 1987)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/NEATICONS.TEDIT b/lispusers/NEATICONS.TEDIT new file mode 100644 index 00000000..a38b21dd Binary files /dev/null and b/lispusers/NEATICONS.TEDIT differ diff --git a/lispusers/NGROUP b/lispusers/NGROUP new file mode 100644 index 00000000..86b7b536 --- /dev/null +++ b/lispusers/NGROUP @@ -0,0 +1 @@ +(FILECREATED "18-Feb-87 15:45:59" {SUMEX-AIM}PS:NGROUP.;3 43703 changes to: (FNS NGROUP.BUTTONEVENTINFN) previous date: "17-Feb-87 14:25:08" {SUMEX-AIM}PS:NGROUP.;3) (* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) (PRETTYCOMPRINT NGROUPCOMS) (RPAQQ NGROUPCOMS ((* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (* * NUMBER ImageObject functions) (FNS NUMBEROBJ NUMBEROBJP NGROUP.NUMBEROBJP NUMBER.DISPLAYFN NUMBER.IMAGEBOXFN NUMBER.PUTFN NUMBER.GETFN NUMBER.BUTTONEVENTINFN) (FNS NGROUP.BUTTONEVENTINFN NGROUP.WHENSELECTEDFN) (* * Number Group GRAPH functions) (FNS GRAPHMENU TSP.NGROUP.GRAPHP INITIAL.NGROUP.GRAPH TSPGRAPHREGION ADD.NGROUP.TO.MOTHER.NODE ADD.NODE.TO.GRAPH COLLECT.HASHARRAY CREATE.NGROUP.NODE GET.FROMNODES GET.MOTHER.GROUP MAKE.MOTHER.NODE MAKE.NGROUP.NODELST GET.TONODES FIND.NODE) (* * Other unsorted functions) (FNS INSERT.NGROUP VERIFY.NGROUP.ORDER ADD.NUMBER.GROUP ADD.NGROUP.TO.DBASE COLLECT.NGROUPS LIST.FONT.PROPS MAP.NGROUP.LOOKS NGROUP.GETFONT CHANGE.NGROUP CHANGE.NGROUP.FONT CHANGE.NGROUP.FORMAT CHANGE.NGROUP.CHARTYPE CHANGE.NGROUP.DELIMIT CHANGE.NGROUP.START CHANGE.NGROUP.ADDTOTOC TSP.GET.NGROUP.ARRAY TSP.LEGALID) (* * Number counting functions) (FNS UPDATE.NUMBEROBJS RESET.DEPENDENT.CLASSES RESET.NCOUNTER GET.NCOUNTER NCOUNTER? LIST.ANCESTORS FLATTEN.TREE.TO.STRING NGROUP.CHARTYPE NUMBER.TO.LETTER REMOVE.ALL.COUNTERS) (* * Table-of-Contents functions) (FNS TOC.ENABLED? GET.TOC.TEXTSTRING CREATE.TOC.FILE VIEW.TOC.FILE GET.TOC.FILE WRITE.TOC.FILE) (RECORDS NGCOUNTER NGTEMPLATE NUMBEROBJ))) (* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (* * NUMBER ImageObject functions) (DEFINEQ (NUMBEROBJ (LAMBDA (USE TEMPLATE NUMSTRING LINK.TO REF.TYPE FONT) (* fsg " 4-Feb-87 13:26") (LET ((NEWOBJ (IMAGEOBJCREATE (create NUMBEROBJ REF.TYPE _ REF.TYPE NUMSTRING _(OR NUMSTRING "^n") USE _ USE TEMPLATE _ TEMPLATE LINK.TO _ LINK.TO NUMBER.TEXT _ NIL PAGE.NUMBER _ NIL FONT _ FONT) (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN) (FUNCTION NUMBER.IMAGEBOXFN) (FUNCTION NUMBER.PUTFN) (FUNCTION NUMBER.GETFN) (FUNCTION NILL) (FUNCTION NUMBER.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION XREF.WHENDELETEDFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))))) (IMAGEOBJPROP NEWOBJ 'TYPE 'NUMBEROBJ) NEWOBJ))) (NUMBEROBJP (LAMBDA (IMOBJ) (* ss: "25-Jun-85 12:11") (* Tests an imageobj to see if it is a number imageobject. By convention, testing functions for an imageobject will be named (CONCAT "P")) (AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE) 'NUMBEROBJ)))) (NGROUP.NUMBEROBJP (LAMBDA (IMOBJ) (* fsg "15-Dec-86 09:57") (* * Like NUMBEROBJP but also checks for NGroup ImageObject.) (AND (NUMBEROBJP IMOBJ) (EQ (fetch (NUMBEROBJ USE) of (fetch OBJECTDATUM of IMOBJ)) 'NGROUP)))) (NUMBER.DISPLAYFN (LAMBDA (OBJ STREAM) (* fsg "17-Feb-87 14:20") (* Display function for numberobjs. Allows different formats for display according to the use to which the  numberobj is being put. If no specific action is specified, displaying defaults to printing out as a plain  number.*) (LET* ((DATUM (fetch OBJECTDATUM of OBJ)) (NUMSTRING (MKSTRING (fetch NUMSTRING of DATUM))) (NUMBER.TEXT (fetch NUMBER.TEXT of DATUM)) (TEMPLATE (MKSTRING (fetch TEMPLATE of DATUM))) (USE (fetch USE of DATUM)) (REF.TYPE (fetch REF.TYPE of DATUM)) (MAIN.WINDOW (CAR (fetch \WINDOW of TEXTOBJ))) (FONT (SELECTQ USE (NOTE (fetch NUMBER.FONT of (GET.ENDNOTE.FONTS MAIN.WINDOW))) (NGROUP (NGROUP.GETFONT REF.TYPE MAIN.WINDOW)) (SHOULDNT "Undefined USE field, neither NOTE nor NGroup")))) (AND (STRINGP NUMBER.TEXT) (EQ USE 'NGROUP) (SETQ NUMSTRING (CONCAT NUMSTRING NUMBER.TEXT))) (AND (FONTP FONT) (DSPFONT (FONTCREATE (FONTPROP FONT 'FAMILY) (FONTPROP FONT 'SIZE) (FONTPROP FONT 'FACE)) STREAM)) (SELECTQ USE (NGROUP (PRIN3 NUMSTRING STREAM) (SELECTQ (IMAGESTREAMTYPE STREAM) (DISPLAY NIL) (replace PAGE.NUMBER of DATUM with (CAR FORMATTINGSTATE)))) (NOTE (LET ((CURRENT.YPOS (DSPYPOSITION NIL STREAM)) (IMAGEBOX (LISTGET (fetch IMAGEOBJPLIST of OBJ) 'BOUNDBOX))) (DSPYPOSITION (IPLUS CURRENT.YPOS (IDIFFERENCE (fetch YSIZE of IMAGEBOX) (FONTPROP STREAM 'HEIGHT))) STREAM) (PRIN1 NUMSTRING STREAM) (DSPYPOSITION CURRENT.YPOS STREAM))) NIL)))) (NUMBER.IMAGEBOXFN (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "17-Feb-87 11:21") (* * The YSize is computed as the current font height plus half of the NOTE or NGroup font. The reason is weird. Ask Sami for more details.) (LET* ((MAIN.WINDOW (CAR (fetch \WINDOW of TEXTOBJ))) (DATUM (fetch OBJECTDATUM of OBJ)) (USE (fetch USE of DATUM)) (REF.TYPE (fetch REF.TYPE of DATUM)) (DEFAULTSTRING (MKSTRING (fetch NUMSTRING of DATUM))) (NUMBER.TEXT (fetch NUMBER.TEXT of DATUM)) (FONT (SELECTQ USE (NOTE (fetch NUMBER.FONT of (GET.ENDNOTE.FONTS MAIN.WINDOW))) (NGROUP (NGROUP.GETFONT REF.TYPE MAIN.WINDOW)) (SHOULDNT "Undefined USE field, neither NOTE nor NGroup")))) (AND (STRINGP NUMBER.TEXT) (EQ USE 'NGROUP) (SETQ DEFAULTSTRING (CONCAT DEFAULTSTRING NUMBER.TEXT))) (AND (FONTP FONT) (DSPFONT (FONTCREATE (FONTPROP FONT 'FAMILY) (FONTPROP FONT 'SIZE) (FONTPROP FONT 'FACE)) STREAM)) (create IMAGEBOX XSIZE _(STRINGWIDTH DEFAULTSTRING STREAM) YSIZE _(IPLUS (FONTPROP (CURRENT.DISPLAY.FONT STREAM) 'HEIGHT) (FIX (TIMES .5 (FONTPROP STREAM 'HEIGHT)))) YDESC _(FONTPROP STREAM 'DESCENT) XKERN _ 0)))) (NUMBER.PUTFN (LAMBDA (OBJ STREAM) (* fsg " 4-Feb-87 13:29") (LET ((USE (fetch USE of (fetch OBJECTDATUM of OBJ))) (MAIN.WINDOW (PROCESSPROP (THIS.PROCESS) 'WINDOW))) (SELECTQ USE (NOTE (NOTE.PUTFN OBJ STREAM MAIN.WINDOW)) (NGROUP (replace (NUMBEROBJ FONT) of (fetch OBJECTDATUM of OBJ) with (LIST.FONT.PROPS (NGROUP.GETFONT (fetch REF.TYPE of (fetch OBJECTDATUM of OBJ)) MAIN.WINDOW))) (replace NGROUP.MOTHER of (fetch OBJECTDATUM of OBJ) with (GET.FROMNODES (fetch REF.TYPE of (fetch OBJECTDATUM of OBJ)) MAIN.WINDOW)) (PRIN4 (LIST 'NGroup (IMAGEOBJPROP OBJ 'TAG) (fetch OBJECTDATUM of OBJ)) STREAM)) (PRIN4 (LIST 'Unknown% Number% Type (IMAGEOBJPROP OBJ 'TAG) (fetch OBJECTDATUM of OBJ)) STREAM))))) (NUMBER.GETFN (LAMBDA (STREAM) (* edited: "29-Jan-87 16:27") (LET* ((USE/TEXT (CDR (READ STREAM))) (NEWOBJ (NUMBEROBJ)) (USE (MKATOM (fetch USE of (CADR USE/TEXT)))) (WINDOW (PROCESSPROP (THIS.PROCESS) 'WINDOW))) (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) (TSP.FMMENU (TEXTSTREAM WINDOW))) (IMAGEOBJPROP NEWOBJ 'TAG (CAR USE/TEXT)) (SETQ USE/TEXT (CADR USE/TEXT)) (replace USE of (fetch OBJECTDATUM of NEWOBJ) with USE) (SELECTQ USE (NOTE (NOTE.GETFN NEWOBJ USE/TEXT WINDOW)) (NGROUP (ADD.NGROUP.TO.DBASE (fetch REF.TYPE of USE/TEXT) (fetch TEMPLATE of USE/TEXT) (fetch NGROUP.MOTHER of USE/TEXT) (AND (fetch (NUMBEROBJ FONT) of USE/TEXT) (replace (NUMBEROBJ FONT) of USE/TEXT with (APPLY* 'FONTCREATE (fetch (NUMBEROBJ FONT) of USE/TEXT)))) (CREATE.NGROUP.NODE (fetch REF.TYPE of USE/TEXT) (fetch NGROUP.MOTHER of USE/TEXT) USE/TEXT WINDOW) WINDOW) (CREATE.NGROUP.NODE (fetch NGROUP.MOTHER of USE/TEXT) NIL NIL WINDOW) (ADD.NGROUP.TO.MOTHER.NODE (fetch REF.TYPE of USE/TEXT) (fetch NGROUP.MOTHER of USE/TEXT) WINDOW) (WINDOWPROP WINDOW 'REBUILD.GRAPHFLG T) (replace OBJECTDATUM of NEWOBJ with USE/TEXT)) (replace OBJECTDATUM of NEWOBJ with USE/TEXT)) NEWOBJ))) (NUMBER.BUTTONEVENTINFN (LAMBDA (NUMBEROBJ STREAM) (* fsg " 4-Feb-87 13:31") (LET ((USE (fetch USE of (fetch OBJECTDATUM of NUMBEROBJ))) (REF.TYPE (fetch REF.TYPE of (fetch OBJECTDATUM of NUMBEROBJ))) (CHANGED NIL)) (AND (MOUSESTATE MIDDLE) (SELECTQ USE (NOTE (NOTE.BUTTONEVENTINFN NUMBEROBJ STREAM)) (NGROUP.BUTTONEVENTINFN REF.TYPE NUMBEROBJ STREAM))) CHANGED))) ) (DEFINEQ (NGROUP.BUTTONEVENTINFN (LAMBDA (USE NUMBEROBJ STREAM) (* fsg "18-Feb-87 11:19") (LET* ((TAG (IMAGEOBJPROP NUMBEROBJ 'TAG)) (NMENU (create MENU TITLE _(COND (TAG (CONCAT USE " Tag:" TAG)) (T USE)) ITEMS _(COND (TAG '(Change% Tag)) (T '(Tag))) WHENSELECTEDFN _ 'NGROUP.WHENSELECTEDFN))) (PUTMENUPROP NMENU 'OBJ NUMBEROBJ) (MENU NMENU)))) (NGROUP.WHENSELECTEDFN (LAMBDA (ITEM MENU MB) (* fsg " 4-Feb-87 13:41") (LET ((TSTREAM (TEXTSTREAM WINDOW)) (OBJ (GETMENUPROP MENU 'OBJ)) PREV.CODE CODE) (SETQ CODE (TSP.GET.INCODE TSTREAM)) (AND (SETQ PREV.CODE (IMAGEOBJPROP OBJ 'TAG)) (TSP.PUTCODE PREV.CODE NIL WINDOW)) (IMAGEOBJPROP OBJ 'TAG CODE) (COND (CODE (TSP.PUTCODE CODE OBJ WINDOW) (TSP.PUTCODE PREV.CODE NIL WINDOW)))))) ) (* * Number Group GRAPH functions) (DEFINEQ (GRAPHMENU (LAMBDA (TSTREAM TWINDOW) (* fsg " 2-Dec-86 08:54") (LET* ((RESHAPEFLG NIL) (GRAPH (OR (AND (NOT (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG)) (WINDOWPROP TWINDOW 'NGROUP.GRAPH)) (INITIAL.NGROUP.GRAPH TWINDOW))) (REGION (TSPGRAPHREGION GRAPH TWINDOW T)) (GRAPHW (OR (WINDOWPROP TWINDOW 'NGROUPW) (CREATEW REGION "Number Group Graph" NIL T)))) (WINDOWPROP GRAPHW 'REPAINTFN NIL) (ATTACHWINDOW (SHAPEW GRAPHW REGION) TWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE) (SHOWGRAPH GRAPH GRAPHW (FUNCTION INSERT.NGROUP) (FUNCTION CHANGE.NGROUP)) (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG NIL) (WINDOWPROP TWINDOW 'NGROUPW GRAPHW) (WINDOWPROP TWINDOW 'NGROUP.GRAPH GRAPH) (WINDOWPROP GRAPHW 'CLOSEFN 'DETACHWINDOW) (WINDOWPROP GRAPHW 'TWINDOW TWINDOW) (WINDOWPROP GRAPHW 'TSTREAM TSTREAM)))) (TSP.NGROUP.GRAPHP (LAMBDA (TWINDOW) (* fsg "15-Dec-86 15:27") (LET* ((MENUW (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) (ITEM (FM.ITEMFROMID MENUW 'NGroup% Menu))) (FM.ITEMPROP ITEM 'STATE)))) (INITIAL.NGROUP.GRAPH (LAMBDA (WINDOW) (* ss: "24-Apr-86 14:31") (LET* ((ROOTNODE (NODECREATE 'NEW.NGROUP 'NEW.NGROUP NIL NIL NIL NIL 1)) (NODELST (for NODE in (COLLECT.HASHARRAY (TSP.GET.NGROUP.ARRAY WINDOW)) collect (CADR NODE)))) (OR (FIND.NODE 'NEW.NGROUP WINDOW) (PROGN (SETQ NODELST (CONS ROOTNODE NODELST)) (ADD.NGROUP.TO.DBASE 'NEW.NGROUP NIL NIL NIL ROOTNODE WINDOW))) (LAYOUTGRAPH NODELST '(NEW.NGROUP))))) (TSPGRAPHREGION (LAMBDA (GRAPH MAIN.WINDOW TITLEFLG BORDER) (* ss: " 2-Apr-86 16:28") (LET ((R (GRAPHREGION GRAPH)) (MAIN.R (WINDOWREGION MAIN.WINDOW))) (replace (REGION WIDTH) of R with (WIDTHIFWINDOW (fetch (REGION WIDTH) of R))) (replace (REGION HEIGHT) of R with (HEIGHTIFWINDOW (fetch (REGION HEIGHT) of R) TITLEFLG BORDER)) R))) (ADD.NGROUP.TO.MOTHER.NODE (LAMBDA (ID MOTHERID W) (* ss: " 3-Apr-86 17:50") (LET* ((MOTHER.NODE (FIND.NODE MOTHERID W)) (TONODES (fetch (GRAPHNODE TONODES) of MOTHER.NODE))) (OR (MEMBER ID TONODES) (replace (GRAPHNODE TONODES) of MOTHER.NODE with (CONS ID TONODES)))))) (ADD.NODE.TO.GRAPH (LAMBDA (NODE GRAPH WINDOW) (* ss: "24-Apr-86 14:26") (LET* ((PARENT.NODE (FIND.NODE (CAR (fetch (GRAPHNODE FROMNODES) of NODE)) WINDOW)) (TONODES (fetch (GRAPHNODE TONODES) of NODE))) (OR (MEMBER (fetch (GRAPHNODE NODEID) of NODE) TONODES) (PROGN (replace (GRAPHNODE TONODES) of PARENT.NODE with (CONS (fetch (GRAPHNODE NODEID) of NODE) (fetch (GRAPHNODE TONODES) of PARENT.NODE))) (replace (GRAPH GRAPHNODES) of GRAPH with (CONS NODE (fetch (GRAPH GRAPHNODES) of GRAPH))))) (LAYOUTGRAPH (fetch (GRAPH GRAPHNODES) of GRAPH) '(NEW.NGROUP))))) (COLLECT.HASHARRAY (LAMBDA (HARRAY) (* ss: " 3-Apr-86 16:46") (LET ((RESULT NIL)) (MAPHASH HARRAY '(LAMBDA (VAL KY) (SETQ RESULT (CONS VAL RESULT)))) RESULT))) (CREATE.NGROUP.NODE (LAMBDA (ID MOTHER USERDATA W) (* ss: " 4-Apr-86 13:13") (LET* ((NGROUP.HARRAY (TSP.GET.NGROUP.ARRAY W)) (NODE (GETHASH ID NGROUP.HARRAY))) (OR NODE (LET ((NEW.NODE (NODECREATE ID ID NIL NIL (LIST MOTHER)))) (PUTHASH ID (LIST USERDATA NEW.NODE) (LIST NGROUP.HARRAY)) NEW.NODE)) (OR (AND NODE (CAR NODE)) (AND USERDATA NODE (RPLACA NODE USERDATA)))))) (GET.FROMNODES (LAMBDA (NGID WINDOW) (* ss: " 3-Apr-86 16:00") (CAR (fetch (GRAPHNODE FROMNODES) of (FIND.NODE NGID WINDOW))))) (GET.MOTHER.GROUP (LAMBDA (DEPENDENT WINDOW) (* ss: " 2-Apr-86 16:30") (CAR (fetch (GRAPHNODE FROMNODES) of (FIND.NODE DEPENDENT WINDOW))))) (MAKE.MOTHER.NODE (LAMBDA NIL (* ss: " 8-Feb-86 16:01") (LET ((TONODES NIL)) (NODECREATE 'NEW.NGROUP 'NEW.NGROUP NIL (for NGROUP in (TSP.GET 'NGROUPS) do (COND ((NOT (GET.FROMNODES (fetch REF.TYPE of NGROUP))) (SETQ TONODES (CONS (fetch REF.TYPE of NGROUP) TONODES)))) finally (RETURN TONODES)) NIL NIL 1)))) (MAKE.NGROUP.NODELST (LAMBDA NIL (* ss: " 8-Feb-86 16:04") (LET* ((NODELST (for NGROUP in (TSP.GET 'NGROUPS) collect (NODECREATE (fetch REF.TYPE of NGROUP) (fetch REF.TYPE of NGROUP) NIL (GET.TONODES (fetch REF.TYPE of NGROUP)) (GET.FROMNODES (fetch REF.TYPE of NGROUP)))))) (SETQ NODELST (CONS (MAKE.MOTHER.NODE) NODELST))))) (GET.TONODES (LAMBDA (MOTHER-GROUP WINDOW) (* ss: " 2-Apr-86 16:31") (fetch (GRAPHNODE TONODES) of (FIND.NODE MOTHER-GROUP WINDOW)))) (FIND.NODE (LAMBDA (NID WINDOW) (* ss: " 3-Apr-86 18:26") (CADR (GETHASH NID (TSP.GET.NGROUP.ARRAY WINDOW))))) ) (* * Other unsorted functions) (DEFINEQ (INSERT.NGROUP (LAMBDA (NODE GRAPHW) (* fsg "13-Jan-87 16:21") (AND NODE (LET* ((TWINDOW (WINDOWPROP GRAPHW 'TWINDOW)) (TSTREAM (WINDOWPROP GRAPHW 'TSTREAM)) (LABEL (fetch (GRAPHNODE NODELABEL) of NODE)) (TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW))))) (OLDLOOKS (fetch CARETLOOKS of (TEXTOBJ TSTREAM))) (NEWLOOKS (NGROUP.GETFONT LABEL TWINDOW))) (SELECTQ LABEL (NEW.NGROUP (COND ((ADD.NUMBER.GROUP TWINDOW TSTREAM) (CLOSEW GRAPHW) (GRAPHMENU TSTREAM TWINDOW)) (T NIL))) (AND (VERIFY.NGROUP.ORDER TWINDOW TSTREAM LABEL) (PROGN (TEDIT.CARETLOOKS TSTREAM NEWLOOKS) (LET ((NEWOBJ (NUMBEROBJ 'NGROUP TEMPLATE (CONCAT "[" LABEL "]") NIL LABEL NEWLOOKS))) (AND (TOC.ENABLED? TWINDOW) (GET.TOC.TEXTSTRING NEWOBJ TSTREAM LABEL)) (IMAGEOBJPROP NEWOBJ 'TWINDOW TWINDOW) (TEDIT.INSERT.OBJECT NEWOBJ TSTREAM)) (TEDIT.CARETLOOKS TSTREAM OLDLOOKS) (AND (UPDATE? TWINDOW) (UPDATE.NUMBEROBJS TWINDOW 'NUMBEROBJP))))))))) (VERIFY.NGROUP.ORDER (LAMBDA (WINDOW STREAM LABEL) (* fsg "15-Dec-86 15:46") (* * Verify the NGroup order before inserting a new NGroup. The order is valid if the new NGroup is a top level  node or the previous NGroup is the same as or the mother of this new NGroup. Note that the "previous NGroup" must  be a member of this NGroup`s tree branch.) (OR (EQ (GET.FROMNODES LABEL WINDOW) 'NEW.NGROUP) (LET* ((ANCESTORS (LIST.ANCESTORS LABEL NIL WINDOW)) (MOTHER (CAR (LAST ANCESTORS))) (SELECTION (TEDIT.GETSEL STREAM)) (CH# (SELECTQ (fetch POINT of SELECTION) (LEFT (fetch CH# of SELECTION)) (ADD1 (fetch CH# of SELECTION)))) PREV.NGROUP) (NCONC1 ANCESTORS LABEL) (SETQ PREV.NGROUP (for OBJ in (REVERSE (TSP.LIST.OF.OBJECTS (TEXTOBJ WINDOW) ' NGROUP.NUMBEROBJP)) bind REF.TYPE do (COND ((AND (IGREATERP CH# (CADR OBJ)) (MEMB (SETQ REF.TYPE (fetch (NUMBEROBJ REF.TYPE) of (fetch OBJECTDATUM of (CAR OBJ)))) ANCESTORS)) (RETURN REF.TYPE)) (T NIL)))) (COND ((OR (EQ PREV.NGROUP LABEL) (EQ PREV.NGROUP MOTHER)) T) (T (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" not inserted, no preceding %"" MOTHER "%" NGroup.") T) NIL)))))) (ADD.NUMBER.GROUP (LAMBDA (TWINDOW STREAM) (* fsg "14-Jan-87 11:30") (OR (TSP.NGROUP.GRAPHP TWINDOW) (PROGN (FM.CHANGESTATE (FM.ITEMFROMID (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW) 'NGroup% Menu) (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) (GRAPHMENU STREAM TWINDOW))) (LET* ((PREV.ITEMS (COLLECT.NGROUPS TWINDOW)) (NEW.GROUPID (MKATOM (TSP.LEGALID NIL (CONS 'NEW.NGROUP PREV.ITEMS) STREAM))) TEMPLATE DEPENDENT.CLASS NEW.NODE) (COND (NEW.GROUPID (SETQ DEPENDENT.CLASS (MKATOM (AND PREV.ITEMS (MENU (create MENU TITLE _ "Select Parent Group OR none" ITEMS _(SORT PREV.ITEMS 'UALPHORDER))) ))) (SETQ TEMPLATE (OR TEMPLATE (create NGTEMPLATE NG.CHARTYPE _ 'Number NG.DELIMIT _ "." NG.START _ 1 NG.ADDTOTOC _ T))) (SETQ NEW.NODE (NODECREATE NEW.GROUPID NEW.GROUPID NIL NIL (LIST (OR DEPENDENT.CLASS 'NEW.NGROUP)))) (ADD.NGROUP.TO.DBASE NEW.GROUPID TEMPLATE DEPENDENT.CLASS GP.DefaultFont NEW.NODE TWINDOW) (ADD.NODE.TO.GRAPH NEW.NODE (WINDOWPROP TWINDOW 'NGROUP.GRAPH) TWINDOW)) (T NIL))))) (ADD.NGROUP.TO.DBASE (LAMBDA (NEW.GROUPID TEMPLATE DEPENDENT.CLASS FONT NGROUP.NODE TWINDOW) (* ss: "24-Apr-86 14:19") (LET ((NGROUP.ARRAY (TSP.GET.NGROUP.ARRAY TWINDOW))) (OR (GETHASH NEW.GROUPID NGROUP.ARRAY) (PROGN (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG T) (PUTHASH NEW.GROUPID (LIST (create NUMBEROBJ NGROUP.MOTHER _ DEPENDENT.CLASS FONT _ FONT REF.TYPE _ NEW.GROUPID TEMPLATE _ TEMPLATE) NGROUP.NODE) (LIST NGROUP.ARRAY))))))) (COLLECT.NGROUPS (LAMBDA (TWINDOW) (* ss: "31-Mar-86 13:53") (LET ((GRAPH (WINDOWPROP TWINDOW 'NGROUP.GRAPH))) (for NODE in (fetch (GRAPH GRAPHNODES) of GRAPH) collect (fetch (GRAPHNODE NODEID) of NODE) unless (EQ (fetch (GRAPHNODE NODEID) of NODE) 'NEW.NGROUP))))) (LIST.FONT.PROPS (LAMBDA (FONTDES) (* ss: " 6-Feb-86 16:12") (AND FONTDES (LIST (FONTPROP FONTDES 'FAMILY) (FONTPROP FONTDES 'SIZE) (FONTPROP FONTDES 'FACE))))) (MAP.NGROUP.LOOKS (LAMBDA (LABEL NEWFDESC TWINDOW) (* ss: " 2-Apr-86 18:04") (TEDIT.PROMPTPRINT (TEXTSTREAM TWINDOW) (CONCAT "Updating looks for " LABEL " numbers...") T) (for NOTE/CH# in (TSP.LIST.OF.OBJECTS (TEXTOBJ TWINDOW) (BQUOTE (LAMBDA (OBJ) (AND (IMAGEOBJP OBJ) (EQ (FETCH REF.TYPE OF OBJ:OBJECTDATUM) , (KWOTE LABEL)))))) do (TEDIT.LOOKS (TEXTSTREAM TWINDOW) NEWFDESC (CADR NOTE/CH#) 1)) (TEDIT.PROMPTPRINT (TEXTSTREAM TWINDOW) "done."))) (NGROUP.GETFONT (LAMBDA (NGROUP.NAME WINDOW) (* ss: " 3-Apr-86 18:26") (fetch (NUMBEROBJ FONT) of (CAR (GETHASH NGROUP.NAME (TSP.GET.NGROUP.ARRAY WINDOW))))) ) (CHANGE.NGROUP (LAMBDA (NODE GRAPHW) (* fsg "13-Jan-87 15:11") (* * Here when number group node is middle buttoned. Allow user to change the font and/or format of the ngroup.) (AND NODE (OR (EQ 'NEW.NGROUP (fetch (GRAPHNODE NODELABEL) of NODE)) (LET ((LABEL (fetch NODELABEL of NODE)) (ITEM.TO.CHANGE (MENU (create MENU TITLE _ "Item to change" CENTERFLG _ T ITEMS _ '(Font Format))))) (SELECTQ ITEM.TO.CHANGE (Font (CHANGE.NGROUP.FONT LABEL GRAPHW)) (Format (CHANGE.NGROUP.FORMAT LABEL GRAPHW)) NIL)))))) (CHANGE.NGROUP.FONT (LAMBDA (LABEL GRAPHW) (* fsg "13-Jan-87 15:13") (* * Change the font of a number group.) (LET* ((TSTREAM (WINDOWPROP GRAPHW 'TSTREAM)) (TWINDOW (WINDOWPROP GRAPHW 'TWINDOW)) (NBROBJ (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW)))) (OLD.FONT (fetch (NUMBEROBJ FONT) of NBROBJ)) NEW.FONT) (TEDIT.PROMPTPRINT TSTREAM (CONCAT "%"" LABEL "%" font is " (LIST (ABBREVIATE.FONT OLD.FONT)) ", change to...") T) (SETQ NEW.FONT (FONTCREATE (GET.TSP.FONT TWINDOW OLD.FONT))) (COND ((NEQ OLD.FONT NEW.FONT) (replace (NUMBEROBJ FONT) of NBROBJ with NEW.FONT) (MAP.NGROUP.LOOKS LABEL NEW.FONT TWINDOW)) (T NIL)) (TEDIT.PROMPTPRINT TSTREAM "" T)))) (CHANGE.NGROUP.FORMAT (LAMBDA (LABEL GRAPHW) (* fsg "14-Jan-87 11:40") (* * Change the format of a number group. The format is three element record; the character type, the delimiter,  and starting value.) (LET* ((TSTREAM (WINDOWPROP GRAPHW 'TSTREAM)) (TWINDOW (WINDOWPROP GRAPHW 'TWINDOW)) (NBROBJ (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW)))) (OLD.TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of NBROBJ)) NEW.CHARTYPE NEW.DELIMIT NEW.START NEW.ADDTOTOC) (AND (SETQ NEW.CHARTYPE (CHANGE.NGROUP.CHARTYPE OLD.TEMPLATE LABEL TSTREAM)) (replace (NGTEMPLATE NG.CHARTYPE) of OLD.TEMPLATE with NEW.CHARTYPE)) (AND (SETQ NEW.DELIMIT (CHANGE.NGROUP.DELIMIT OLD.TEMPLATE LABEL TSTREAM)) (replace (NGTEMPLATE NG.DELIMIT) of OLD.TEMPLATE with NEW.DELIMIT)) (AND (SETQ NEW.START (CHANGE.NGROUP.START OLD.TEMPLATE LABEL TSTREAM)) (replace (NGTEMPLATE NG.START) of OLD.TEMPLATE with NEW.START)) (AND (SETQ NEW.ADDTOTOC (CHANGE.NGROUP.ADDTOTOC OLD.TEMPLATE LABEL TSTREAM)) (replace (NGTEMPLATE NG.ADDTOTOC) of OLD.TEMPLATE with (CDR NEW.ADDTOTOC))) (COND ((OR NEW.CHARTYPE NEW.DELIMIT NEW.START) (MAP.NGROUP.LOOKS LABEL (fetch (NUMBEROBJ FONT) of NBROBJ) TWINDOW)) (T (TEDIT.PROMPTPRINT TSTREAM "" T)))))) (CHANGE.NGROUP.CHARTYPE (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "13-Jan-87 14:52") (* * Show this NGroup's display type and return a possibly new display type.) (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" displayed as " (fetch (NGTEMPLATE NG.CHARTYPE) of TEMPLATE) ", change to...") T) (MENU (create MENU TITLE _ "NGroup Types" CENTERFLG _ T ITEMS _ '(Number Null% String Uppercase% Letter Lowercase% Letter Uppercase% Roman Lowercase% Roman))))) (CHANGE.NGROUP.DELIMIT (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "13-Jan-87 14:38") (* * Show the delimiter following this NGroup and return a possibly new delimiter.) (TEDIT.PROMPTPRINT STREAM (CONCAT "Delimiter following %"" LABEL "%" is %"" (fetch (NGTEMPLATE NG.DELIMIT) of TEMPLATE) "%", change to...") T) (LET ((NEW.DELIMIT (MENU (create MENU TITLE _ "NGroup Delimiters" CENTERFLG _ T ITEMS _ '((Dot ".") (Dash "-") (Null% String "") Other))))) (COND ((EQ NEW.DELIMIT 'Other) (MKSTRING (TEDIT.GETINPUT STREAM (CONCAT "Specify delimiter following " LABEL ":")) )) (T NEW.DELIMIT))))) (CHANGE.NGROUP.START (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "13-Jan-87 15:09") (* * Show this NGroup's starting value and return a possibly new starting value.) (TEDIT.PROMPTPRINT STREAM (CONCAT "Starting value of %"" LABEL "%" is " (fetch (NGTEMPLATE NG.START) of TEMPLATE) ", change it?") T) (MENU (create MENU TITLE _ "Change start?" CENTERFLG _ T ITEMS _ '(YES NO) WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM) (COND ((EQ ITEM 'YES) (NUMBERPAD.READ (CREATE.NUMBERPAD.READER "Starting NGroup Value" NIL NIL NIL T))) (T NIL)))))))) (CHANGE.NGROUP.ADDTOTOC (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "14-Jan-87 13:17") (* * Say if this NGroup will/won't be included in the TOC, if any and retrun a possibly new ADD-TO-TOC flag.) (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" is " (COND ((fetch (NGTEMPLATE NG.ADDTOTOC) of TEMPLATE) "") (T "NOT ")) "included in TOC. Do you want it included?") T) (MENU (create MENU TITLE _ "Include in TOC?" CENTERFLG _ T ITEMS _ '(YES NO) WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM) (CONS ITEM (COND ((EQ ITEM 'YES) T) (T NIL))))))))) (TSP.GET.NGROUP.ARRAY (LAMBDA (W) (* ss: " 3-Apr-86 18:25") (WINDOWPROP W 'TSP.NGROUP.ARRAY))) (TSP.LEGALID (LAMBDA (NAME NGROUPS STREAM) (* ss: "31-Mar-86 14:23") (LET ((LEGAL T) (ID (OR NAME (MKATOM (TEDIT.GETINPUT STREAM "Group name>"))))) (COND ((MEMBER ID NGROUPS) (TSP.LEGALID (MKATOM (TEDIT.GETINPUT STREAM "Illegal name... Group name>")) NGROUPS STREAM)) (T ID))))) ) (* * Number counting functions) (DEFINEQ (UPDATE.NUMBEROBJS (LAMBDA (WINDOW TESTFN TESTFNARG) (* fsg " 3-Feb-87 10:30") (LET* ((TEXTOBJ (TEXTOBJ WINDOW)) (STREAM (TEXTSTREAM WINDOW)) (NBROBJ.LIST (TSP.LIST.OF.OBJECTS TEXTOBJ TESTFN TESTFNARG))) (TEDIT.PROMPTPRINT STREAM "Updating Number Group ImageObjects..." T) (for NUMBEROBJ in NBROBJ.LIST do (LET* ((OBJECTDATUM (fetch OBJECTDATUM of (CAR NUMBEROBJ))) (REF.TYPE (fetch REF.TYPE of OBJECTDATUM)) (NUMSTRING (MKATOM (fetch NUMSTRING of OBJECTDATUM))) (USE (fetch USE of OBJECTDATUM)) (TEMPLATE (SELECTQ USE (NGROUP (fetch TEMPLATE of OBJECTDATUM)) NIL)) (DEPENDENT.CLASS (GET.MOTHER.GROUP REF.TYPE WINDOW)) NEW.COUNT) (RESET.DEPENDENT.CLASSES WINDOW USE REF.TYPE) (SETQ NEW.COUNT (GET.NCOUNTER WINDOW USE REF.TYPE DEPENDENT.CLASS TEMPLATE)) (COND ((EQ NEW.COUNT NUMSTRING)) (T (replace NUMSTRING of OBJECTDATUM with NEW.COUNT) (TEDIT.OBJECT.CHANGED STREAM (CAR NUMBEROBJ))))) finally (REMOVE.ALL.COUNTERS WINDOW)) (TEDIT.PROMPTPRINT STREAM "done")))) (RESET.DEPENDENT.CLASSES (LAMBDA (WINDOW USE REF.TYPE) (* fsg "12-Dec-86 10:50") (for DEPENDENT in (fetch (GRAPHNODE TONODES) of (FIND.NODE REF.TYPE WINDOW)) do (PROGN (RESET.NCOUNTER WINDOW USE DEPENDENT) (RESET.DEPENDENT.CLASSES WINDOW USE DEPENDENT))))) (RESET.NCOUNTER (LAMBDA (WINDOW USE REF.TYPE) (* fsg "12-Dec-86 11:07") (LET* ((TEMPLATE (SELECTQ USE (NGROUP (fetch (NUMBEROBJ TEMPLATE) of (CAR (GETHASH REF.TYPE (TSP.GET.NGROUP.ARRAY WINDOW))))) NIL)) (COUNTER (NCOUNTER? WINDOW USE REF.TYPE TEMPLATE))) (replace NCOUNT of COUNTER with (COND (TEMPLATE (SUB1 (fetch NG.START of TEMPLATE))) (T 0)))))) (GET.NCOUNTER (LAMBDA (WINDOW USE REF.TYPE MOTHER.CLASS TEMPLATE) (* fsg "17-Dec-86 16:33") (LET ((COUNTER (NCOUNTER? WINDOW USE REF.TYPE TEMPLATE))) (COND (COUNTER (PROGN (replace NCOUNT of COUNTER with (ADD1 (fetch NCOUNT of COUNTER))) (COND (MOTHER.CLASS (FLATTEN.TREE.TO.STRING WINDOW USE REF.TYPE)) (T (fetch NCOUNT of COUNTER))))) (T NIL))))) (NCOUNTER? (LAMBDA (WINDOW USE REF.TYPE TEMPLATE) (* fsg "23-Dec-86 09:13") (* * Return the record for this number counter. If the record doesn't exist, we create one based on the USE value.) (LET ((COUNTER.ID (MKATOM (CONCAT (SELECTQ USE (NGROUP REF.TYPE) USE) "COUNTER")))) (OR (WINDOWPROP WINDOW COUNTER.ID) (PROGN (WINDOWPROP WINDOW COUNTER.ID (create NGCOUNTER NCOUNT _(COND ((AND (EQ USE 'NGROUP) TEMPLATE) (SUB1 (fetch NG.START of TEMPLATE))) (T 0)) ANCESTRY _(SELECTQ USE (NGROUP (LIST.ANCESTORS REF.TYPE NIL WINDOW)) NIL))) (WINDOWADDPROP WINDOW 'COUNTERS COUNTER.ID) (WINDOWPROP WINDOW COUNTER.ID)))))) (LIST.ANCESTORS (LAMBDA (NID ANCESTORS WINDOW) (* ss: " 2-Apr-86 16:32") (LET* ((NODE (FIND.NODE NID WINDOW)) (MOTHER (AND NODE (CAR (fetch (GRAPHNODE FROMNODES) of NODE))))) (COND ((AND MOTHER (NEQ MOTHER 'NEW.NGROUP)) (LIST.ANCESTORS MOTHER (CONS MOTHER ANCESTORS) WINDOW)) (T ANCESTORS))))) (FLATTEN.TREE.TO.STRING (LAMBDA (WINDOW USE REF.TYPE) (* fsg "17-Dec-86 16:45") (LET ((NCOUNTER (NCOUNTER? WINDOW USE REF.TYPE)) (FLAT.TREE "")) (COND ((fetch ANCESTRY of NCOUNTER) (for (ANCESTOR ANCESTOR.NCOUNT) in (REVERSE (fetch ANCESTRY of NCOUNTER)) do (SETQ ANCESTOR.NCOUNT (fetch NCOUNT of (NCOUNTER? WINDOW USE ANCESTOR))) (SETQ FLAT.TREE (CONCAT (SELECTQ USE (NGROUP (NGROUP.CHARTYPE WINDOW ANCESTOR ANCESTOR.NCOUNT T)) (CONCAT ANCESTOR.NCOUNT '-)) FLAT.TREE)) finally (SETQ FLAT.TREE (MKATOM (CONCAT FLAT.TREE (SELECTQ USE (NGROUP (NGROUP.CHARTYPE WINDOW REF.TYPE (fetch NCOUNT of NCOUNTER) NIL)) (fetch NCOUNT of NCOUNTER))))))) (T (SETQ FLAT.TREE (SELECTQ USE (NGROUP (NGROUP.CHARTYPE WINDOW REF.TYPE (fetch NCOUNT of NCOUNTER) NIL)) (fetch NCOUNT of NCOUNTER))))) FLAT.TREE))) (NGROUP.CHARTYPE (LAMBDA (WINDOW REF.TYPE NCOUNT MORE.FIELDS?) (* fsg "13-Jan-87 15:26") (* * Convert the number NCOUNT to the format specified in TEMPLATE.) (LET* ((NBROBJ (CAR (GETHASH REF.TYPE (TSP.GET.NGROUP.ARRAY WINDOW)))) (TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of NBROBJ)) (CHARTYPE (fetch (NGTEMPLATE NG.CHARTYPE) of TEMPLATE))) (CONCAT (COND ((OR (NOT (NUMBERP NCOUNT)) (ILEQ NCOUNT 0)) "?") (T (SELECTQ CHARTYPE (Number (MKSTRING NCOUNT)) (Uppercase% Letter (NUMBER.TO.LETTER NCOUNT T)) (Lowercase% Letter (NUMBER.TO.LETTER NCOUNT)) (Uppercase% Roman (ROMANNUMERALS NCOUNT T)) (Lowercase% Roman (ROMANNUMERALS NCOUNT)) (Null% String "") NIL))) (COND ((OR MORE.FIELDS? (EQ (GET.FROMNODES REF.TYPE WINDOW) 'NEW.NGROUP)) (fetch (NGTEMPLATE NG.DELIMIT) of TEMPLATE)) (T "")))))) (NUMBER.TO.LETTER (LAMBDA (NUMBER UCFLG) (* fsg " 5-Dec-86 10:18") (* * Convert NUMBER to equivalent letter code.) (LET ((LTRLST (MKSTRING (CHARACTER (IPLUS (CHARCODE A) (IREMAINDER (SUB1 NUMBER) 26))))) (LTRNBR (IQUOTIENT (SUB1 NUMBER) 26))) (until (ZEROP LTRNBR) do (SETQ LTRLST (CONCAT (CHARACTER (SUB1 (IPLUS (CHARCODE A) (IREMAINDER LTRNBR 26)))) LTRLST)) (SETQ LTRNBR (IQUOTIENT LTRNBR 26))) (COND (UCFLG (U-CASE LTRLST)) (T (L-CASE LTRLST)))))) (REMOVE.ALL.COUNTERS (LAMBDA (WINDOW) (* ss: "30-Sep-85 09:38") (for COUNTER in (WINDOWPROP WINDOW 'COUNTERS) do (WINDOWPROP WINDOW COUNTER NIL) finally (WINDOWPROP WINDOW 'COUNTERS NIL)))) ) (* * Table-of-Contents functions) (DEFINEQ (TOC.ENABLED? (LAMBDA (WINDOW) (* fsg "10-Dec-86 15:40") (WINDOWPROP WINDOW 'ENABLETOC))) (GET.TOC.TEXTSTRING (LAMBDA (NBROBJ STREAM LABEL) (* fsg "14-Jan-87 09:35") (* * Here if TOC is enabled to get the Table-Of-Contents text string for this NGroup. Because the WRITE.TOC.FILE  function uses a tab to align the page numbers, any tabs in the TOC string are converted to spaces.) (LET ((TOC.STRING (TEDIT.GETINPUT STREAM (CONCAT "Text for " LABEL ": ")))) (AND TOC.STRING (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of NBROBJ) with (CONCAT " " (MKSTRING (PACK (for TOC.CHAR in (UNPACK TOC.STRING) collect (COND ((EQ TOC.CHAR (CHARACTER (CHARCODE TAB))) (CHARACTER (CHARCODE SPACE))) (T TOC.CHAR))))))))))) (CREATE.TOC.FILE (LAMBDA (STREAM WINDOW) (* fsg "27-Jan-87 09:32") (* * Here to print the Table Of Contents. Each Line of the TOC consists of the NGroup, the corresponding text,  followed by the current listing page number.) (LET* ((TOC.LIST (TSP.LIST.OF.OBJECTS (TEXTOBJ WINDOW) 'NGROUP.NUMBEROBJP)) (TOC.FILE (GET.TOC.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW))) (TOC.TABSTOP (LIST 'PARALOOKS (LIST 'TABS (LIST NIL (CONS (FIXR (ITIMES 72.27 5.5)) 'DOTTEDLEFT))))) (TOC.STREAM (AND TOC.FILE (OPENTEXTSTREAM NIL NIL NIL NIL TOC.TABSTOP)))) (COND ((AND TOC.LIST TOC.FILE) (TEDIT.PROMPTPRINT STREAM (CONCAT "Putting Table-Of-Contents in " TOC.FILE "...") T) (WRITE.TOC.FILE TOC.STREAM TOC.LIST WINDOW) (TEDIT.PROMPTPRINT STREAM "done") (TEDIT.PUT TOC.STREAM TOC.FILE) TOC.FILE) (TOC.LIST (TEDIT.PROMPTPRINT STREAM "Specify a file name for the Table-Of-Contents first." T) NIL) (T (TEDIT.PROMPTPRINT STREAM "There are no NGroups in this document." T) NIL))))) (VIEW.TOC.FILE (LAMBDA (STREAM WINDOW) (* fsg "15-Dec-86 13:48") (* * Writes out the TOC file via CREATE.TOC.FILE and then opens another TEdit window where this new file is  displayed.) (LET ((TOC.FILE (CREATE.TOC.FILE STREAM WINDOW)) (TOC.FILEW (WINDOWPROP WINDOW 'TOC.WINDOW))) (AND TOC.FILE (COND ((WINDOWP TOC.FILEW) (COND ((OPENWP TOC.FILEW) (TEDIT.GET (TEXTOBJ TOC.FILEW) TOC.FILE)) ((OPENW TOC.FILEW) (TEDIT TOC.FILE TOC.FILEW)))) (T (WINDOWPROP WINDOW 'TOC.WINDOW (SETQ TOC.FILEW (CREATEW NIL (CONCAT "Viewing TOC file: " TOC.FILE)))) (TEDIT TOC.FILE TOC.FILEW))))))) (GET.TOC.FILE (LAMBDA (MENUW) (* fsg "11-Dec-86 10:27") (* * Return the user specified Table-Of-Contents file name.) (LET* ((ITEM (FM.ITEMFROMID MENUW 'TOC.FILE)) (TOC.FILENAME (FM.ITEMPROP ITEM 'LABEL))) (COND ((NOT (STREQUAL TOC.FILENAME "")) (MKATOM TOC.FILENAME)) (T NIL))))) (WRITE.TOC.FILE (LAMBDA (TOC.STREAM TOC.LIST WINDOW) (* fsg "28-Jan-87 13:27") (* * Here to do the actual output to the TOC file.) (DSPFONT (FONTCREATE '(HELVETICA 14 BRR)) TOC.STREAM) (PRINTOUT TOC.STREAM "Table of Contents" T) (for (TOC.ITEM OBJECTDATUM ITEM.LEVEL) in TOC.LIST when (fetch (NGTEMPLATE NG.ADDTOTOC) of (fetch (NUMBEROBJ TEMPLATE) of (fetch OBJECTDATUM of (CAR TOC.ITEM)))) do (SETQ OBJECTDATUM (fetch OBJECTDATUM of (CAR TOC.ITEM))) (DSPFONT (fetch (NUMBEROBJ FONT) of OBJECTDATUM) TOC.STREAM) (SETQ ITEM.LEVEL (LENGTH (LIST.ANCESTORS (fetch (NUMBEROBJ REF.TYPE) of OBJECTDATUM) NIL WINDOW))) (COND ((ZEROP ITEM.LEVEL) (PRINTOUT TOC.STREAM T T)) (T (RPTQ ITEM.LEVEL (PRINTOUT TOC.STREAM " ")))) (PRINTOUT TOC.STREAM (CONCAT (fetch (NUMBEROBJ NUMSTRING) of OBJECTDATUM) (OR (fetch (NUMBEROBJ NUMBER.TEXT) of OBJECTDATUM) ""))) (DSPFONT GP.DefaultFont TOC.STREAM) (PRINTOUT TOC.STREAM (CHARACTER (CHARCODE TAB)) (fetch (NUMBEROBJ PAGE.NUMBER) of OBJECTDATUM) T) (AND (ZEROP ITEM.LEVEL) (PRINTOUT TOC.STREAM T))))) ) [DECLARE: EVAL@COMPILE (RECORD NGCOUNTER (NCOUNT . ANCESTRY)) (RECORD NGTEMPLATE (NG.CHARTYPE NG.DELIMIT NG.START NG.ADDTOTOC)) (RECORD NUMBEROBJ (REF.TYPE NUMSTRING USE NGROUP.MOTHER TEMPLATE LINK.TO NUMBER.TEXT PAGE.NUMBER FONT)) ] (PUTPROPS NGROUP COPYRIGHT ("Leland Stanford Junior University" 1987)) (DECLARE: DONTCOPY (FILEMAP ((10049) (1916 NIL (NUMBEROBJ 1926 . 2911) (NUMBEROBJP 2913 . 3283) (NGROUP.NUMBEROBJP 3285 . 3616) (NUMBER.DISPLAYFN 3618 . 5633) (NUMBER.IMAGEBOXFN 5635 . 7099) (NUMBER.PUTFN 7101 . 8230) ( NUMBER.GETFN 8232 . 10048))))) STOP TONEVENTINFN 10294 . 10801)) (10806 11877 ( NGROUP.BUTTONEVENTINFN 10818 . 11322) (NGROUP.WHENSELECTEDFN 11326 . 11874)) (11922 18225 (GRAPHMENU 11934 . 13037) (TSP.NGROUP.GRAPHP 13041 . 13313) (INITIAL.NGROUP.GRAPH 13317 . 13924) (TSPGRAPHREGION 13928 . 14408) (ADD.NGROUP.TO.MOTHER.NODE 14412 . 14788) (ADD.NODE.TO.GRAPH 14792 . 15593) ( COLLECT.HASHARRAY 15597 . 15845) (CREATE.NGROUP.NODE 15849 . 16377) (GET.FROMNODES 16381 . 16577) ( GET.MOTHER.GROUP 16581 . 16785) (MAKE.MOTHER.NODE 16789 . 17307) (MAKE.NGROUP.NODELST 17311 . 17848) ( GET.TONODES 17852 . 18042) (FIND.NODE 18046 . 18222)) (18266 31833 (INSERT.NGROUP 18278 . 19721) ( VERIFY.NGROUP.ORDER 19725 . 21385) (ADD.NUMBER.GROUP 21389 . 22799) (ADD.NGROUP.TO.DBASE 22803 . 23454 ) (COLLECT.NGROUPS 23458 . 23884) (LIST.FONT.PROPS 23888 . 24139) (MAP.NGROUP.LOOKS 24143 . 24833) ( NGROUP.GETFONT 24837 . 25067) (CHANGE.NGROUP 25071 . 25812) (CHANGE.NGROUP.FONT 25816 . 26765) ( CHANGE.NGROUP.FORMAT 26769 . 28318) (CHANGE.NGROUP.CHARTYPE 28322 . 28949) (CHANGE.NGROUP.DELIMIT 28953 . 29755) (CHANGE.NGROUP.START 29759 . 30503) (CHANGE.NGROUP.ADDTOTOC 30507 . 31267) ( TSP.GET.NGROUP.ARRAY 31271 . 31432) (TSP.LEGALID 31436 . 31830)) (31875 39290 (UPDATE.NUMBEROBJS 31887 . 33206) (RESET.DEPENDENT.CLASSES 33210 . 33563) (RESET.NCOUNTER 33567 . 34089) (GET.NCOUNTER 34093 . 34583) (NCOUNTER? 34587 . 35516) (LIST.ANCESTORS 35520 . 35938) (FLATTEN.TREE.TO.STRING 35942 . 37182) (NGROUP.CHARTYPE 37186 . 38274) (NUMBER.TO.LETTER 38278 . 38989) (REMOVE.ALL.COUNTERS 38993 . 39287)) (39334 44416 (TOC.ENABLED? 39346 . 39497) (GET.TOC.TEXTSTRING 39501 . 40412) (CREATE.TOC.FILE 40416 . 41696) (VIEW.TOC.FILE 41700 . 42519) (GET.TOC.FILE 42523 . 42942) (WRITE.TOC.FILE 42946 . 44413))))) STOP \ No newline at end of file diff --git a/lispusers/NOTECARDS-4045XLPPATCH b/lispusers/NOTECARDS-4045XLPPATCH new file mode 100644 index 00000000..7e65066c --- /dev/null +++ b/lispusers/NOTECARDS-4045XLPPATCH @@ -0,0 +1 @@ +(FILECREATED "15-Dec-86 16:30:35" {DANTE}4045>V1.4>NOTECARDS-4045XLPPATCH.;2 1578 changes to: (FNS 4045XLP.NoteCardsAdvice) previous date: "26-Sep-86 14:20:43" {DANTE}4045>V1.4>NOTECARDS-4045XLPPATCH.;1) (* Copyright (c) 1986 by Xerox Corporation and Will Snow. All rights reserved.) (PRETTYCOMPRINT NOTECARDS-4045XLPPATCHCOMS) (RPAQQ NOTECARDS-4045XLPPATCHCOMS ((FNS 4045XLP.NoteCardsAdvice) (P (4045XLP.NoteCardsAdvice)))) (DEFINEQ (4045XLP.NoteCardsAdvice [LAMBDA NIL (* edited: "15-Dec-86 16:29") [ADVISE (QUOTE NC.LinkIconDisplayFn) (QUOTE BEFORE) NIL (QUOTE (COND ((OR (NULL STREAMTYPE) (EQ STREAMTYPE (QUOTE 4045XLP))) (SETQ STREAMTYPE (QUOTE DISPLAY] (ADVISE (QUOTE (STRINGWIDTH IN NC.LinkIconImageBoxFn)) (QUOTE AFTER) NIL (QUOTE (AND (EQ (IMAGESTREAMTYPE ImageStream) (QUOTE 4045XLP)) (RETURN (IQUOTIENT (STRINGWIDTH (CONCAT "nn" (if Label then (CONCAT "<" Label ">") else "") (if (AND Label Title) then " " else "") (OR Title "")) ImageStream) Scale]) ) (4045XLP.NoteCardsAdvice) (PUTPROPS NOTECARDS-4045XLPPATCH COPYRIGHT ("Xerox Corporation and Will Snow" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (478 1445 (4045XLP.NoteCardsAdvice 488 . 1443))))) STOP \ No newline at end of file diff --git a/lispusers/NOTEPAD b/lispusers/NOTEPAD new file mode 100644 index 00000000..63be4891 --- /dev/null +++ b/lispusers/NOTEPAD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Sep-91 16:43:36" |{PELE:MV:ENVOS}MEDLEY>NOTEPAD.;2| 104138 changes to%: (VARS NOTEPADCOMS NOTEPAD.DEFAULT.FONT NOTEPAD.STYLE.REPRESENTATION.NUMBER SPOTMARKER NOTEPAD.DEFAULT.BRUSH NOTEPAD.DEFAULT.MASK) (FILEPKGCOMS NOTEPADSTYLE) (FNS NOTEPAD.NAMED.OBJECT) previous date%: "11-Sep-88 20:44:42" |{PELE:MV:ENVOS}MEDLEY>NOTEPAD.;1|) (* ; " Copyright (c) 1982, 1983, 1988, 1991 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NOTEPADCOMS) (RPAQQ NOTEPADCOMS [(FNS ACQUIRE.STYLE ACQUIRE.SYMMETRY ADD.NOTEPAD.TO.BACKGROUND.MENU BITMAP.INTERIOR DELDEF.NOTEPAD.STYLE DISTANCE DUMP.NOTEPAD.STYLE ERASE.REGION EXTEND.AREA EXTEND.AREA.X EXTEND.AREA.Y GET.BITMAP GET.NOTEPAD.BITMAP GET.NOTEPAD.REGION GET.SYMMETRIC.BITMAPS GETDEF.NOTEPAD.STYLE GETPOSITION.RUBBERBAND GETPOSITION.RUBBERBAND1 MARK.SPOT MASKED.BRUSH MOVE.BITMAP MOVE.BITMAP1 NOTEPAD NOTEPAD.ADD.TO.BACKGROUND.MENU NOTEPAD.BUTTONEVENTFN NOTEPAD.BUTTONFN NOTEPAD.CIRCLE NOTEPAD.COMMAND.MENU NOTEPAD.COMMAND.MENU.CREATE NOTEPAD.COOKIE.CUT NOTEPAD.COPY.FROM.SCREEN NOTEPAD.CURVE NOTEPAD.DEFINE.BRUSH NOTEPAD.DEFINE.FONT NOTEPAD.HELP NOTEPAD.READ.FONT NOTEPAD.FONTS.IN.CORE READ.NOTEPAD.STYLE NOTEPAD.DEFINE.GRID NOTEPAD.DEFINE.GRID1 NOTEPAD.DEFINE.MASK NOTEPAD.DELETE.STYLE NOTEPAD.EDIT.BRUSH NOTEPAD.EDIT.MASK NOTEPAD.EDIT.RECTANGLE NOTEPAD.EDIT.SHADE NOTEPAD.ELLIPSE NOTEPAD.LINE NOTEPAD.MASK=BRUSH.OUTLINE NOTEPAD.NAMED.OBJECT NOTEPAD.POINT.OF.SYMMETRY NOTEPAD.RESTORE.STYLE NOTEPAD.SETUP.TO.PAINT NOTEPAD.SHADE.RECTANGLE NOTEPAD.SKETCH NOTEPAD.SKETCH1 NOTEPAD.TEXT NOTEPAD.USE.GRID NOTEPAD.USE.MASK NOTEPAD.USE.SYMMETRIC.BRUSH/MASK NOTEPAD.USE.SYMMETRY NOTEPAD.FILL NOTEPAD.CONFIRM NOTEPAD.CREATE NOTEPAD.DEFAULT.CHARACTERISTICS NOTEPAD.GETPOSITION NOTEPAD.MASK NOTEPAD.ON.GRID NOTEPAD.ON.GRID.X NOTEPAD.OPERATION NOTEPAD.SOLID.AREA BITMAP.EXTERIOR NOTEPAD.TITLEBUTTONFN PAINT.A.BITMAP PAINT.ALL.BITMAPS PAINT.AT.POSSIBLE.POINT PAINT.WITH.BITMAP PICKUP.BITMAP PICKUP.SCREEN.BITMAP READ.FROM.PROMPT.WINDOW PUTBACK.BITMAP PUTDEF.NOTEPAD.STYLE SAVE.STYLE SBIT TEST.AND.SET) (FNS GET.WINDOW.REGION GETCOLORPOSITION COLORBITMAPP) (VARS NOTEPAD.DEFAULT.FONT NOTEPAD.STYLE.REPRESENTATION.NUMBER (NOTEPAD.COMMAND.MENU) (NOTEPAD.SHOW.FILL) (NOTEPAD.USE.GRID.MENU)) (VARS (.NOTEPAD.BRUSH.1) (.NOTEPAD.BRUSH.2) (.NOTEPAD.BRUSH.3) (.NOTEPAD.BRUSH.4) (.NOTEPAD.BRUSH.5) (.NOTEPAD.BRUSH.6) (.NOTEPAD.BRUSH.7) (.NOTEPAD.BRUSH.8) (.NOTEPAD.MASK.1) (.NOTEPAD.MASK.2) (.NOTEPAD.MASK.3) (.NOTEPAD.MASK.4) (.NOTEPAD.MASK.5) (.NOTEPAD.MASK.6) (.NOTEPAD.MASK.7) (.NOTEPAD.MASK.8)) (GLOBALVARS NOTEPAD.COMMAND.MENU NOTEPAD.USE.GRID.MENU .NOTEPAD.WINDOW .NOTEPAD.OPERATION .NOTEPAD.BRUSH.1 .NOTEPAD.BRUSH.2 .NOTEPAD.BRUSH.3 .NOTEPAD.BRUSH.4 .NOTEPAD.BRUSH.5 .NOTEPAD.BRUSH.6 .NOTEPAD.BRUSH.7 .NOTEPAD.BRUSH.8 .NOTEPAD.MASK.1 .NOTEPAD.MASK.2 .NOTEPAD.MASK.3 .NOTEPAD.MASK.4 .NOTEPAD.MASK.5 .NOTEPAD.MASK.6 .NOTEPAD.MASK.7 .NOTEPAD.MASK.8 .NOTEPAD.USE.GRID .NOTEPAD.GRID.X0 .NOTEPAD.GRID.Y0 .NOTEPAD.GRID.DX .NOTEPAD.GRID.DY .NOTEPAD.USE.MASK .NOTEPAD.INVERSE.OPERATION .NOTEPAD.USE.SYMMETRIC.BRUSH/MASK .NOTEPAD.USE.SYMMETRY .NOTEPAD.POSX .NOTEPAD.POSY .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT .NOTEPAD.BRUSH.HALF.WIDTH .NOTEPAD.BRUSH.HALF.HEIGHT .NOTEPAD.MASK.WIDTH .NOTEPAD.MASK.HEIGHT .NOTEPAD.MASK.HALF.WIDTH .NOTEPAD.MASK.HALF.HEIGHT .NOTEPAD.PREVIOUS.MIDX .NOTEPAD.PREVIOUS.MIDY) (VARS (COLORSPOTMARKER)) (INITVARS (NOTEPAD.STYLES)) (GLOBALVARS NOTEPAD.STYLES) (BITMAPS SPOTMARKER NOTEPAD.DEFAULT.BRUSH NOTEPAD.DEFAULT.MASK) (GLOBALVARS SPOTMARKER NOTEPAD.DEFAULT.BRUSH NOTEPAD.DEFAULT.MASK) (CURSORS CIRCLE.CENTER CIRCLE.EDGE ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR CURVE.KNOT) (GLOBALVARS CIRCLE.CENTER CIRCLE.EDGE ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR CURVE.KNOT) (FILES (FROM VALUEOF LISPUSERSDIRECTORIES) EDITBITMAP READNUMBER) (FILEPKGCOMS NOTEPADSTYLE) [P (ADD.NOTEPAD.TO.BACKGROUND.MENU) (FONTCREATE NOTEPAD.DEFAULT.FONT) (COND ((NULL NOTEPAD.STYLES) (FILESLOAD NOTEPAD-CORESTYLES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML READ.NOTEPAD.STYLE ) (LAMA]) (DEFINEQ (ACQUIRE.STYLE [LAMBDA (BITS.PER.PIXEL NAME.PLEASE) (* DAHJr "26-JAN-83 14:29") (PROG (NAME.MENU NAME) (SETQ NAME.MENU (create MENU TITLE _ "Styles" ITEMS _ (for ELEMENT in NOTEPAD.STYLES when (EQ (LISTGET (CDR ELEMENT) 'BITS.PER.PIXEL) BITS.PER.PIXEL) collect (CAR ELEMENT)) CENTERFLG _ T CHANGEOFFSETFLG _ T)) (SETQ NAME (MENU NAME.MENU)) (RETURN (COND [NAME (COND (NAME.PLEASE NAME) (T (CDR (FASSOC NAME NOTEPAD.STYLES] (T NIL]) (ACQUIRE.SYMMETRY [LAMBDA (MESSAGE) (* edited%: "17-DEC-82 10:36") (PROG (MENU) (SETQ MENU (create MENU TITLE _ MESSAGE ITEMS _ '((none NIL) LEFT/RIGHT UP/DOWN 4-FOLD 8-FOLD) CENTERFLG _ T CHANGEOFFSETFLG _ T)) (RETURN (MENU MENU]) (ADD.NOTEPAD.TO.BACKGROUND.MENU [LAMBDA NIL (* DAHJr " 7-APR-83 20:09") (NOTEPAD.ADD.TO.BACKGROUND.MENU (LIST 'Notepad '(NOTEPAD) "Opens a NOTEPAD window")) (* don't add the color notepad unless color display is on the machine.  But since we can't test for the machine having a color board, only do it if it  is actually on.) (AND (COLORDISPLAYP) (NOTEPAD.ADD.TO.BACKGROUND.MENU (LIST 'Color% Notepad '(NOTEPAD NIL T) "Opens a NOTEPAD window for color"]) (BITMAP.INTERIOR [LAMBDA (BITMAP PT) (* rrb "19-JAN-83 18:53") (* returns a bitmap which has all 1's at all points that are the same value as  PT and touch it or another point of the same value that touches it.) (PROG ((WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP)) INTERIOR (X (fetch (POSITION XCOORD) of PT)) (Y (fetch (POSITION YCOORD) of PT)) (NBITS (BITSPERPIXEL BITMAP)) FROMVALUE MAXVAL) (SETQ MAXVAL (SUB1 (EXPT 2 NBITS))) (SETQ FROMVALUE (BITMAPBIT BITMAP X Y)) (SETQ INTERIOR (BITMAPCREATE WIDTH HEIGHT NBITS)) (EXTEND.AREA BITMAP INTERIOR X Y (SUB1 WIDTH) (SUB1 HEIGHT) FROMVALUE MAXVAL) (RETURN INTERIOR]) (DELDEF.NOTEPAD.STYLE [LAMBDA (NAME TYPE) (* DAHJr "26-JAN-83 09:46") (SETQ NOTEPAD.STYLES (DREMOVE (FASSOC NAME NOTEPAD.STYLES) NOTEPAD.STYLES]) (DISTANCE [LAMBDA (P1 P2) (* edited%: "18-OCT-82 18:04") (PROG (DX DY) (SETQ DX (IDIFFERENCE (fetch (POSITION XCOORD) of P1) (fetch (POSITION XCOORD) of P2))) (SETQ DY (IDIFFERENCE (fetch (POSITION YCOORD) of P1) (fetch (POSITION YCOORD) of P2))) (RETURN (SQRT (IPLUS (ITIMES DX DX) (ITIMES DY DY]) (DUMP.NOTEPAD.STYLE [LAMBDA (NAME) (* DAHJr "26-JAN-83 10:14") (PROG (NOTEPAD.STYLE) (SETQ NOTEPAD.STYLE (GETDEF.NOTEPAD.STYLE NAME)) (PRINT (LIST 'READ.NOTEPAD.STYLE NAME NOTEPAD.STYLE.REPRESENTATION.NUMBER)) (HPRINT NOTEPAD.STYLE NIL T) (RETURN]) (ERASE.REGION [LAMBDA (WINDOW REGION) (* edited%: "13-DEC-82 15:51") (BITBLT NIL 0 0 WINDOW (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 'TEXTURE 'REPLACE WHITESHADE]) (EXTEND.AREA [LAMBDA (DEFINING.BITMAP AREA.BITMAP X Y MAXX MAXY FROMVALUE TOVALUE) (* rrb "19-JAN-83 19:21") (DECLARE (LOCALVARS . T)) (COND ((TEST.AND.SET DEFINING.BITMAP AREA.BITMAP X Y FROMVALUE TOVALUE) (EXTEND.AREA.X DEFINING.BITMAP AREA.BITMAP X Y MAXX MAXY FROMVALUE TOVALUE]) (EXTEND.AREA.X [LAMBDA (DEFINING.BITMAP AREA.BITMAP X Y MAXX MAXY FROMVAL TOVAL) (* rrb "19-JAN-83 19:21") (DECLARE (LOCALVARS . T)) (PROG (LEFT RIGHT) (SETQ LEFT X) (for I from (SUB1 X) to 0 by -1 while (TEST.AND.SET DEFINING.BITMAP AREA.BITMAP I Y FROMVAL TOVAL) do (SETQ LEFT I)) (SETQ RIGHT X) (for I from (ADD1 X) to MAXX while (TEST.AND.SET DEFINING.BITMAP AREA.BITMAP I Y FROMVAL TOVAL) do (SETQ RIGHT I)) (for I from LEFT to RIGHT unless (EQ I X) do (EXTEND.AREA.Y DEFINING.BITMAP AREA.BITMAP I Y MAXX MAXY FROMVAL TOVAL)) (RETURN]) (EXTEND.AREA.Y [LAMBDA (DEFINING.BITMAP AREA.BITMAP X Y MAXX MAXY FROMVAL TOVAL) (* rrb "19-JAN-83 19:21") (DECLARE (LOCALVARS . T)) (PROG (BOTTOM TOP) (SETQ BOTTOM Y) (for I from (SUB1 Y) to 0 by -1 while (TEST.AND.SET DEFINING.BITMAP AREA.BITMAP X I FROMVAL TOVAL) do (SETQ BOTTOM I)) (SETQ TOP Y) (for I from (ADD1 Y) to MAXY while (TEST.AND.SET DEFINING.BITMAP AREA.BITMAP X I FROMVAL TOVAL) do (SETQ TOP I)) (for I from BOTTOM to TOP unless (EQ I Y) do (EXTEND.AREA.X DEFINING.BITMAP AREA.BITMAP X I MAXX MAXY FROMVAL TOVAL)) (RETURN]) (GET.BITMAP [LAMBDA (CHARACTERISTICS PROP) (* edited%: "17-DEC-82 12:43") (PROG (BITMAPS) (SETQ BITMAPS (LISTGET CHARACTERISTICS PROP)) (RETURN (COND ((LISTP BITMAPS) (CAR BITMAPS)) (T BITMAPS]) (GET.NOTEPAD.BITMAP [LAMBDA (WINDOW) (* edited%: "18-OCT-82 10:10") (DSPDESTINATION NIL (WINDOWPROP WINDOW 'DSP]) (GET.NOTEPAD.REGION [LAMBDA (WINDOW) (* rrb "29-JAN-83 14:22") (PROG (REGION LEFT BOTTOM RIGHT TOP CHARACTERISTICS GRID) (SETQ REGION (GET.WINDOW.REGION WINDOW)) (SETQ LEFT (fetch (REGION LEFT) of REGION)) (SETQ BOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ RIGHT (IPLUS LEFT (fetch (REGION WIDTH) of REGION))) (SETQ TOP (IPLUS BOTTOM (fetch (REGION HEIGHT) of REGION))) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (COND [(LISTGET CHARACTERISTICS 'USE.GRID.TO.DRAW) (SETQ GRID (LISTGET CHARACTERISTICS 'GRID.DEFINITION)) (SETQ LEFT (NOTEPAD.ON.GRID.X LEFT (fetch (REGION LEFT) of GRID) (fetch (REGION WIDTH) of GRID))) (SETQ RIGHT (NOTEPAD.ON.GRID.X RIGHT (fetch (REGION LEFT) of GRID) (fetch (REGION WIDTH) of GRID))) (SETQ BOTTOM (NOTEPAD.ON.GRID.X BOTTOM (fetch (REGION BOTTOM) of GRID) (fetch (REGION HEIGHT) of GRID))) (SETQ TOP (NOTEPAD.ON.GRID.X TOP (fetch (REGION BOTTOM) of GRID) (fetch (REGION HEIGHT) of GRID))) (RETURN (create REGION LEFT _ LEFT BOTTOM _ BOTTOM WIDTH _ (IDIFFERENCE RIGHT LEFT) HEIGHT _ (IDIFFERENCE TOP BOTTOM] (T (RETURN REGION]) (GET.SYMMETRIC.BITMAPS [LAMBDA (CHARACTERISTICS PROP) (* edited%: "17-DEC-82 15:33") (PROG (BITMAPS BM1 BM2 BM3 BM4 BM5 BM6 BM7 BM8 NEW.BITMAPS) (SETQ BITMAPS (LISTGET CHARACTERISTICS PROP)) (RETURN (COND ((LISTP BITMAPS) BITMAPS) (T (SETQ BM1 BITMAPS) (SETQ BM2 (INVERT.BITMAP.HORIZONTALLY BM1)) (SETQ BM3 (INVERT.BITMAP.VERTICALLY BM1)) (SETQ BM4 (INVERT.BITMAP.HORIZONTALLY BM3)) (SETQ BM5 (INVERT.BITMAP.DIAGONALLY BM1)) (SETQ BM6 (INVERT.BITMAP.HORIZONTALLY BM5)) (SETQ BM7 (INVERT.BITMAP.VERTICALLY BM5)) (SETQ BM8 (INVERT.BITMAP.HORIZONTALLY BM7)) (SETQ NEW.BITMAPS (LIST BM1 BM2 BM3 BM4 BM5 BM6 BM7 BM8)) (LISTPUT CHARACTERISTICS PROP NEW.BITMAPS) NEW.BITMAPS]) (GETDEF.NOTEPAD.STYLE [LAMBDA (NAME TYPE) (* DAHJr "26-JAN-83 09:44") (CDR (FASSOC NAME NOTEPAD.STYLES]) (GETPOSITION.RUBBERBAND [LAMBDA (STARTPOSITION WINDOW) (* rrb "27-DEC-82 16:42") (* gets the other end of a line via  a rubberband prompting) (PROG [CHARACTERISTICS GRID X0 GX0 GY0 GDX GDY Y0 DS (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (SETQ X0 (fetch (POSITION XCOORD) of STARTPOSITION)) (SETQ Y0 (fetch (POSITION YCOORD) of STARTPOSITION)) [COND ((LISTGET (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) 'USE.GRID) (SETQ GRID (LISTGET CHARACTERISTICS 'GRID.DEFINITION)) (SETQ GX0 (fetch (REGION LEFT) of GRID)) (SETQ GY0 (fetch (REGION BOTTOM) of GRID)) (SETQ GDX (fetch (REGION WIDTH) of GRID)) (SETQ GDY (fetch (REGION HEIGHT) of GRID] [SETQ DS (COND (COLORDS) (T (WINDOWPROP WINDOW 'DSP] (RETURN (COND (COLORDS (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (GETPOSITION.RUBBERBAND1 DS X0 Y0 GX0 GY0 GDX GDY))) (T (GETPOSITION.RUBBERBAND1 DS X0 Y0 GX0 GY0 GDX GDY]) (GETPOSITION.RUBBERBAND1 [LAMBDA (WHERE X0 Y0 GRIDX0 GRIDY0 GRIDDX GRIDDY) (* rrb "27-DEC-82 17:45") (PROG (X1 Y1 NEW.X1 NEW.Y1 DONE DOWN) [until DONE do (GETMOUSESTATE) (COND ((LASTMOUSESTATE (NOT UP)) (SETQ DOWN T)) ((AND X1 DOWN (LASTMOUSESTATE UP)) (SETQ DONE T)) (T (SETQ NEW.X1 (LASTMOUSEX WHERE)) (SETQ NEW.Y1 (LASTMOUSEY WHERE)) [COND (GRIDX0 (SETQ NEW.X1 (NOTEPAD.ON.GRID.X NEW.X1 GRIDX0 GRIDDX)) (SETQ NEW.Y1 (NOTEPAD.ON.GRID.X NEW.Y1 GRIDY0 GRIDDY] (COND ((OR (NEQ X1 NEW.X1) (NEQ Y1 NEW.Y1)) (COND (X1 (DRAWLINE X0 Y0 X1 Y1 1 'INVERT WHERE))) (SETQ X1 NEW.X1) (SETQ Y1 NEW.Y1) (DRAWLINE X0 Y0 X1 Y1 1 'INVERT WHERE] (DRAWLINE X0 Y0 X1 Y1 1 'INVERT WHERE) (RETURN (create POSITION XCOORD _ X1 YCOORD _ Y1]) (MARK.SPOT [LAMBDA (X/POSITION Y WINDOW) (* rrb "14-JAN-83 15:40") (PROG [X WIDTH HEIGHT (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (COND ((POSITIONP X/POSITION) (SETQ X (fetch (POSITION XCOORD) of X/POSITION)) (SETQ Y (fetch (POSITION YCOORD) of X/POSITION))) (T (SETQ X X/POSITION))) (SETQ WIDTH (BITMAPWIDTH SPOTMARKER)) (SETQ HEIGHT (BITMAPHEIGHT SPOTMARKER)) (BITBLT (COND [COLORDS (COND ((AND (BITMAPP COLORSPOTMARKER) (EQ (BITSPERPIXEL COLORSPOTMARKER) (COLORNUMBERBITSPERPIXEL))) COLORSPOTMARKER) (T (SETQ COLORSPOTMARKER (COLORIZEBITMAP SPOTMARKER 0 (MAXIMUMCOLOR) (COLORNUMBERBITSPERPIXEL] (T SPOTMARKER)) 0 0 (OR COLORDS WINDOW) (IDIFFERENCE X (IQUOTIENT WIDTH 2)) (IDIFFERENCE Y (IQUOTIENT HEIGHT 2)) WIDTH HEIGHT 'INPUT 'INVERT]) (MASKED.BRUSH [LAMBDA (WINDOW MASK) (* edited%: " 5-DEC-82 15:00") (PROG (BEEN.DOWN DONE POSITION BUFFER.BITMAP LEFT BOTTOM WIDTH HEIGHT NEW.LEFT NEW.BOTTOM BRUSH) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of MASK)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of MASK)) (SETQ BUFFER.BITMAP (BITMAPCREATE WIDTH HEIGHT)) (printout PROMPTWINDOW T "Place mask over desired brush area") [until DONE do (GETMOUSESTATE) (COND ((AND BEEN.DOWN (MOUSESTATE UP)) (* restore bitmap) [COND (LEFT (BITBLT BUFFER.BITMAP 0 0 WINDOW LEFT BOTTOM WIDTH HEIGHT 'INPUT 'REPLACE] (SETQ DONE T)) (T (COND ((MOUSESTATE (NOT UP)) (SETQ BEEN.DOWN T))) (SETQ NEW.LEFT (LASTMOUSEX WINDOW)) (SETQ NEW.BOTTOM (LASTMOUSEY WINDOW)) (COND ((OR (NEQ NEW.LEFT LEFT) (NEQ NEW.BOTTOM BOTTOM)) (* restore bitmap) [COND (LEFT (BITBLT BUFFER.BITMAP 0 0 WINDOW LEFT BOTTOM WIDTH HEIGHT 'INPUT 'REPLACE] (SETQ LEFT NEW.LEFT) (SETQ BOTTOM NEW.BOTTOM) (BITBLT WINDOW LEFT BOTTOM BUFFER.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (BITBLT MASK 0 0 WINDOW LEFT BOTTOM WIDTH HEIGHT 'INPUT 'PAINT] (SETQ BRUSH (BITMAPCOPY BUFFER.BITMAP)) (BITBLT MASK 0 0 BRUSH 0 0 NIL NIL 'INVERT 'ERASE) (RETURN BRUSH]) (MOVE.BITMAP [LAMBDA (WINDOW BITMAP OPERATION) (* rrb "22-DEC-82 11:28") (PROG [BUFFER.BITMAP WIDTH HEIGHT (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (SETQ WIDTH (BITMAPWIDTH BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) [SETQ BUFFER.BITMAP (BITMAPCREATE WIDTH HEIGHT (COND (COLORDS (COLORNUMBERBITSPERPIXEL)) (T 1] (printout PROMPTWINDOW T "Indicate where to copy area to") (COND (COLORDS (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (MOVE.BITMAP1 COLORDS BUFFER.BITMAP WIDTH HEIGHT))) (T (MOVE.BITMAP1 (WINDOWPROP WINDOW 'DSP) BUFFER.BITMAP WIDTH HEIGHT))) (RETURN]) (MOVE.BITMAP1 [LAMBDA (DS BUFFER.BITMAP WIDTH HEIGHT) (* DAHJr "31-MAY-83 12:16") (PROG (DONE DOWN LEFT BOTTOM NEW.LEFT NEW.BOTTOM) (until DONE do (GETMOUSESTATE) (COND ((LASTMOUSESTATE (NOT UP)) (SETQ DOWN T))) (COND ((AND DOWN (LASTMOUSESTATE UP)) (SETQ DONE T)) (T (SETQ NEW.LEFT (LASTMOUSEX DS)) (SETQ NEW.BOTTOM (LASTMOUSEY DS)) (COND ((OR (NEQ NEW.LEFT LEFT) (NEQ NEW.BOTTOM BOTTOM)) [COND (LEFT (BITBLT BUFFER.BITMAP 0 0 DS LEFT BOTTOM WIDTH HEIGHT 'INPUT 'REPLACE] (SETQ LEFT NEW.LEFT) (SETQ BOTTOM NEW.BOTTOM) (BITBLT WINDOW LEFT BOTTOM BUFFER.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (BITBLT BITMAP 0 0 DS LEFT BOTTOM WIDTH HEIGHT 'INPUT OPERATION]) (NOTEPAD [LAMBDA (BITMAP INCOLORFLG) (* rrb "29-JAN-83 14:30") (NOTEPAD.CREATE BITMAP (COND (INCOLORFLG (PROMPTPRINT "Making sure the color functions are loaded...") (FILESLOAD LLCOLOR COLOR HLCOLOR) (CLRPROMPT) (SELECTQ (MACHINETYPE) (DOLPHIN (* make sure color is on in 4 bit  mode) (COLORDISPLAY T 4) T) (DORADO (* make sure color is on) (COND ((COLORDISPLAYP)) (T (* used to turn the display on but this hangs the system if the machine doesn't  have a color board. (COLORDISPLAY T (OR  (SMALLP INCOLORFLG) 8))) (PROMPTPRINT " You will have to turn on the color display before you will see anything. " ))) T) NIL]) (NOTEPAD.ADD.TO.BACKGROUND.MENU [LAMBDA (ITEM) (* rrb "22-FEB-83 14:40") (* adds an item to the background  menu.) (DECLARE (GLOBALVARS BackgroundMenu BackgroundMenuCommands)) (COND ((FASSOC (CAR ITEM) BackgroundMenuCommands)) (T (SETQ BackgroundMenuCommands (NCONC1 BackgroundMenuCommands ITEM)) (SETQ BackgroundMenu]) (NOTEPAD.BUTTONEVENTFN [LAMBDA (WINDOW) (* edited%: " 4-DEC-82 17:10") (COND ((INSIDEP (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW 'DSP)) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (NOTEPAD.BUTTONFN WINDOW)) (T (NOTEPAD.TITLEBUTTONFN WINDOW]) (NOTEPAD.BUTTONFN [LAMBDA (WINDOW) (* DAHJr " 4-APR-83 16:06") (PROG (OPERATION CHARACTERISTICS DSP COMMAND.MENU COMMAND REGION BRUSH NEW.BRUSH FONT MASK NEW.MASK ORIGIN DX DY USE.GRID USE.MASK SHADE NEW.SHADE P1 P2 P3 POSITION OLD.BITMAP NEW.BITMAP TEXT NAME OBJECT TEXTWIDTH) (SETQ OPERATION (NOTEPAD.OPERATION)) (SETQ COMMAND.MENU (NOTEPAD.COMMAND.MENU)) (* USES NOTEPAD.COMMAND.MENU.CREATE) (SETQ COMMAND (MENU COMMAND.MENU)) (SELECTQ COMMAND ((NIL -- -trajectories- -objects/editing- -styles-) NIL) (* -trajectories-) (SKETCH (NOTEPAD.SKETCH WINDOW OPERATION)) (LINE (NOTEPAD.LINE WINDOW OPERATION)) (CIRCLE (NOTEPAD.CIRCLE WINDOW OPERATION)) (ELLIPSE (NOTEPAD.ELLIPSE WINDOW OPERATION)) (OPEN.CURVE (NOTEPAD.CURVE WINDOW OPERATION)) (CLOSED.CURVE (NOTEPAD.CURVE WINDOW OPERATION T)) (* -objects/editing-) (TEXT (NOTEPAD.TEXT WINDOW OPERATION)) (EDIT.RECTANGLE (NOTEPAD.EDIT.RECTANGLE WINDOW)) (SHADE.RECTANGLE (NOTEPAD.SHADE.RECTANGLE WINDOW OPERATION)) (FILL (NOTEPAD.FILL WINDOW OPERATION)) (COPY.FROM.SCREEN (NOTEPAD.COPY.FROM.SCREEN WINDOW OPERATION)) (NAMED.OBJECT (NOTEPAD.NAMED.OBJECT WINDOW OPERATION)) (* -styles-) (DEFINE.BRUSH (NOTEPAD.DEFINE.BRUSH WINDOW)) (EDIT.BRUSH (EVAL.AS.PROCESS (LIST (FUNCTION NOTEPAD.EDIT.BRUSH) (KWOTE WINDOW)))) (BRUSH=COOKIE.CUT.WITH.MASK (NOTEPAD.COOKIE.CUT WINDOW)) (USE.MASK (NOTEPAD.USE.MASK WINDOW)) (DEFINE.MASK (NOTEPAD.DEFINE.MASK WINDOW)) (EDIT.MASK (EVAL.AS.PROCESS (LIST (FUNCTION NOTEPAD.EDIT.MASK) (KWOTE WINDOW) (KWOTE WINDOW)))) (MASK=OUTLINE.OF.BRUSH (NOTEPAD.MASK=BRUSH.OUTLINE WINDOW)) (DEFINE.FONT (NOTEPAD.DEFINE.FONT WINDOW)) (DEFINE.GRID (NOTEPAD.DEFINE.GRID WINDOW)) (USE.GRID (NOTEPAD.USE.GRID WINDOW)) (USE.SYMMETRY (NOTEPAD.USE.SYMMETRY WINDOW)) (USE.SYMMETRIC.BRUSH/MASK (NOTEPAD.USE.SYMMETRIC.BRUSH/MASK WINDOW)) (DEFINE.POINT.OF.SYMMETRY (NOTEPAD.POINT.OF.SYMMETRY WINDOW)) (EDIT.SHADE (NOTEPAD.EDIT.SHADE WINDOW)) (SAVE.STYLE (SAVE.STYLE WINDOW)) (RESTORE.STYLE (NOTEPAD.RESTORE.STYLE WINDOW)) (DELETE.STYLE (NOTEPAD.DELETE.STYLE WINDOW)) (SHOULDNT (CONCAT "Unrecognized COMMAND in NOTEPAD.BUTTONFN: " COMMAND]) (NOTEPAD.CIRCLE [LAMBDA (WINDOW OPERATION) (* rrb "14-JAN-83 09:56") (PROG (CHARACTERISTICS BRUSH P1 P2) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) (printout PROMPTWINDOW T "Indicate center of circle") (SETQ P1 (NOTEPAD.GETPOSITION WINDOW CIRCLE.CENTER)) (MARK.SPOT P1 NIL WINDOW) (printout PROMPTWINDOW T "Indicate a point of the circumference of the circle") (SETQ P2 (NOTEPAD.GETPOSITION WINDOW CIRCLE.EDGE)) (* erase the center pt.) (MARK.SPOT P1 NIL WINDOW) (NOTEPAD.SETUP.TO.PAINT WINDOW OPERATION) (DRAWCIRCLE (fetch (POSITION XCOORD) of P1) (fetch (POSITION YCOORD) of P1) (DISTANCE P1 P2) 'PAINT.AT.POSSIBLE.POINT NIL WINDOW]) (NOTEPAD.COMMAND.MENU [LAMBDA NIL (* edited%: " 6-DEC-82 21:07") (COND (NOTEPAD.COMMAND.MENU) (T (SETQ NOTEPAD.COMMAND.MENU (NOTEPAD.COMMAND.MENU.CREATE]) (NOTEPAD.COMMAND.MENU.CREATE [LAMBDA NIL (* edited%: "18-DEC-82 08:50") (PROG (OPERATIONS STYLES) (* AFTER EDITING RESET WITH%:  (SETQ NOTEPAD.COMMAND.MENU)) (SETQ OPERATIONS '(-trajectories- SKETCH LINE CIRCLE ELLIPSE OPEN.CURVE CLOSED.CURVE -objects/editing- TEXT NAMED.OBJECT COPY.FROM.SCREEN SHADE.RECTANGLE FILL EDIT.RECTANGLE -- -- -- -- --)) (SETQ STYLES '(-styles- DEFINE.BRUSH EDIT.BRUSH BRUSH=COOKIE.CUT.WITH.MASK USE.MASK DEFINE.MASK EDIT.MASK MASK=OUTLINE.OF.BRUSH USE.GRID DEFINE.GRID USE.SYMMETRY DEFINE.POINT.OF.SYMMETRY USE.SYMMETRIC.BRUSH/MASK EDIT.SHADE DEFINE.FONT -- SAVE.STYLE RESTORE.STYLE DELETE.STYLE)) (RETURN (create MENU TITLE _ "Adding and editing" MENUCOLUMNS _ 2 ITEMS _ (for OPERATION in OPERATIONS as STYLE in STYLES join (LIST OPERATION STYLE)) CHANGEOFFSETFLG _ T]) (NOTEPAD.COOKIE.CUT [LAMBDA (WINDOW) (* edited%: "17-DEC-82 16:15") (PROG (CHARACTERISTICS NEW.BRUSH) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ MASK (GET.BITMAP CHARACTERISTICS 'MASK.DEFINITION)) (SETQ NEW.BRUSH (MASKED.BRUSH WINDOW MASK)) (LISTPUT CHARACTERISTICS 'BRUSH.DEFINITION NEW.BRUSH) (printout PROMPTWINDOW T "Brush defined"]) (NOTEPAD.COPY.FROM.SCREEN [LAMBDA (WINDOW OPERATION) (* rrb " 4-JAN-83 17:00") (PROG (REGION NEW.BITMAP) (printout PROMPTWINDOW T "Indicate a region of the screen to be copied") [SETQ NEW.BITMAP (COND ((WINDOWPROP WINDOW 'INCOLOR) (PICKUP.SCREEN.BITMAP (GETCOLORREGION) (COLORSCREENBITMAP))) (T (PICKUP.SCREEN.BITMAP (GETREGION) (SCREENBITMAP] (RETURN (MOVE.BITMAP WINDOW NEW.BITMAP OPERATION]) (NOTEPAD.CURVE [LAMBDA (WINDOW OPERATION CLOSED) (* DAHJr " 4-APR-83 16:53") (PROG (CHARACTERISTICS BRUSH REGION P1 P2 PTS DONE) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) [SETQ REGION (DSPCLIPPINGREGION NIL (COND ((WINDOWPROP WINDOW 'INCOLOR)) (T (WINDOWPROP WINDOW 'DSP] (printout PROMPTWINDOW T "Indicate first point of curve") (SETQ P1 (NOTEPAD.GETPOSITION WINDOW CURVE.KNOT)) (MARK.SPOT P1 NIL WINDOW) (printout PROMPTWINDOW " (indicate last point by holding down left shift key)") (printout PROMPTWINDOW ", point 2") (SETQ P2 (NOTEPAD.GETPOSITION WINDOW CURVE.KNOT)) (SETQ DONE (KEYDOWNP 'LSHIFT)) (MARK.SPOT P2 NIL WINDOW) (SETQ PTS (LIST P1 P2)) (until DONE as I from 3 do (printout PROMPTWINDOW ", " I) (SETQ P2 (NOTEPAD.GETPOSITION WINDOW CURVE.KNOT)) (SETQ DONE (KEYDOWNP 'LSHIFT)) (NCONC1 PTS P2) (MARK.SPOT P2 NIL WINDOW)) (for PT in PTS do (MARK.SPOT PT NIL WINDOW)) (NOTEPAD.SETUP.TO.PAINT WINDOW OPERATION) (DRAWCURVE PTS CLOSED 'PAINT.AT.POSSIBLE.POINT NIL WINDOW]) (NOTEPAD.DEFINE.BRUSH [LAMBDA (WINDOW) (* rrb "20-DEC-82 15:30") (PROG (CHARACTERISTICS BRUSH) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (printout PROMPTWINDOW T "Indicate a region to be used as the brush") [SETQ BRUSH (COND ((WINDOWPROP WINDOW 'INCOLOR) (PICKUP.SCREEN.BITMAP (GETCOLORREGION) (COLORSCREENBITMAP))) (T (PICKUP.SCREEN.BITMAP (GETREGION) (SCREENBITMAP] (LISTPUT CHARACTERISTICS 'BRUSH.DEFINITION BRUSH) (printout PROMPTWINDOW T "Brush defined"]) (NOTEPAD.DEFINE.FONT [LAMBDA (WINDOW) (* DAHJr " 7-APR-83 20:13") (PROG (CHARACTERISTICS FONT) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ FONT (NOTEPAD.READ.FONT)) (COND (FONT (LISTPUT CHARACTERISTICS 'PRINTING.FONT.DEFINITION FONT))) (printout PROMPTWINDOW T "Font defined to be " FONT]) (NOTEPAD.HELP [LAMBDA NIL (* DAHJr " 4-APR-83 16:01") (CLEARW PROMPTWINDOW) (printout PROMPTWINDOW "NOTEPAD is menu-driven") (printout PROMPTWINDOW T "Selection: ") (printout PROMPTWINDOW T 3 "In the title bar: commands affecting the whole") (printout PROMPTWINDOW T 3 "Within the window:") (printout PROMPTWINDOW T 6 "Using Left button:" " => paint") (printout PROMPTWINDOW T 6 "Using Middle button:" " => erase") (printout PROMPTWINDOW T 6 "Using Right button:" " window commands"]) (NOTEPAD.READ.FONT [LAMBDA NIL (* DAHJr "31-MAY-83 12:12") (PROG (LOADED.FONTS COMMAND.MENU COMMAND REGION BRUSH NEW.FONT) (SETQ LOADED.FONTS (NOTEPAD.FONTS.IN.CORE)) [SETQ COMMAND.MENU (create MENU TITLE _ "Style" ITEMS _ (NCONC1 (for FONT in LOADED.FONTS collect (LIST FONT (KWOTE FONT))) 'NEW.FONT] (SETQ COMMAND (MENU COMMAND.MENU)) (RETURN (SELECTQ COMMAND (NIL NIL) (NEW.FONT (SETQ NEW.FONT (READ.FROM.PROMPT.WINDOW "New font (FAMILY SIZE FACE):")) (printout PROMPTWINDOW T "Reading font " NEW.FONT " ... ") (FONTCREATE NEW.FONT) (printout PROMPTWINDOW "done") NEW.FONT) COMMAND]) (NOTEPAD.FONTS.IN.CORE [LAMBDA NIL (* edited%: " 4-DEC-82 15:28") (for FAMILY in \FONTSINCORE join (for SIZE in (CDR FAMILY) join (for FACE in (CDR SIZE) when (EQ (CAR (CADR (CADR FACE))) 'DISPLAY) collect (LIST (CAR FAMILY) (CAR SIZE) (CAR FACE]) (READ.NOTEPAD.STYLE [NLAMBDA (NAME VERSION) (* DAHJr "26-JAN-83 10:17") (PROG (NOTEPAD.STYLE) (SELECTQ VERSION (1 (* 1%: HPRINTED PROPERTY LIST) (SETQ NOTEPAD.STYLE (HREAD))) (SHOULDNT "Unrecognized version number in READ.NOTEPAD.STYLE")) (PUTDEF.NOTEPAD.STYLE NAME 'NOTEPAD.STYLES NOTEPAD.STYLE) (RETURN]) (NOTEPAD.DEFINE.GRID [LAMBDA (WINDOW) (* rrb "27-DEC-82 16:21") (PROG [(COLORDS (WINDOWPROP WINDOW 'INCOLOR] [LISTPUT (WINDOWPROP WINDOW 'CHARACTERISTICS) 'GRID.DEFINITION (COND (COLORDS (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (NOTEPAD.DEFINE.GRID1 COLORDS))) (T (NOTEPAD.DEFINE.GRID1 WINDOW] (printout PROMPTWINDOW T "Grid defined"]) (NOTEPAD.DEFINE.GRID1 [LAMBDA (WHERE) (* rrb "22-FEB-83 14:47") (* prompts for two points and  returns a REGION that defines a  grid.) (PROG (ORIGIN P1) (printout PROMPTWINDOW T "Indicate an origin for the grid") (SETQ ORIGIN (NOTEPAD.GETPOSITION WHERE NIL T)) (MARK.SPOT ORIGIN NIL WHERE) (printout PROMPTWINDOW T "Indicate (1, 1) on the grid") (SETQ P1 (NOTEPAD.GETPOSITION WHERE NIL T)) (MARK.SPOT ORIGIN NIL WHERE) (RETURN (create REGION LEFT _ (fetch (POSITION XCOORD) of ORIGIN) BOTTOM _ (fetch (POSITION YCOORD) of ORIGIN) WIDTH _ [MAX 1 (ABS (IDIFFERENCE (fetch (POSITION XCOORD) of P1) (fetch (POSITION XCOORD) of ORIGIN] HEIGHT _ (MAX 1 (ABS (IDIFFERENCE (fetch (POSITION YCOORD) of P1) (fetch (POSITION YCOORD) of ORIGIN]) (NOTEPAD.DEFINE.MASK [LAMBDA (WINDOW) (* rrb "21-DEC-82 15:26") (PROG (CHARACTERISTICS MASK) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (printout PROMPTWINDOW T "Indicate a region to be used as the brush") [SETQ MASK (COND ((WINDOWPROP WINDOW 'INCOLOR) (PICKUP.SCREEN.BITMAP (GETCOLORREGION) (COLORSCREENBITMAP))) (T (PICKUP.SCREEN.BITMAP (GETREGION) (SCREENBITMAP] (LISTPUT CHARACTERISTICS 'MASK.DEFINITION MASK) (printout PROMPTWINDOW T "Brush defined"]) (NOTEPAD.DELETE.STYLE [LAMBDA (WINDOW) (* DAHJr "26-JAN-83 14:27") (PROG (BITS.PER.PIXEL NAME NEW.STYLES) (SETQ BITS.PER.PIXEL (LISTGET (WINDOWPROP WINDOW 'CHARACTERISTICS) 'BITS.PER.PIXEL)) (COND [NOTEPAD.STYLES (SETQ NAME (ACQUIRE.STYLE BITS.PER.PIXEL T)) (COND ((AND NAME (NOTEPAD.CONFIRM (CONCAT "Delete style " NAME))) (DELDEF.NOTEPAD.STYLE NAME) (printout PROMPTWINDOW T "Style " NAME " deleted"] (T (printout PROMPTWINDOW T "No styles to delete"]) (NOTEPAD.EDIT.BRUSH [LAMBDA (WINDOW) (* DAHJr " 4-APR-83 16:44") (PROG (CHARACTERISTICS BRUSH NEW.BRUSH) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) (SETQ NEW.BRUSH (EDIT.BITMAP BRUSH)) (LISTPUT CHARACTERISTICS 'BRUSH.DEFINITION NEW.BRUSH) (printout PROMPTWINDOW T "Brush defined"]) (NOTEPAD.EDIT.MASK [LAMBDA (WINDOW WINDOW) (* edited%: "17-DEC-82 12:43") (PROG (CHARACTERISTICS MASK NEW.MASK) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ MASK (GET.BITMAP CHARACTERISTICS 'MASK.DEFINITION)) (SETQ NEW.MASK (EDIT.BITMAP MASK)) (LISTPUT CHARACTERISTICS 'MASK.DEFINITION NEW.MASK) (printout PROMPTWINDOW T "Mask defined"]) (NOTEPAD.EDIT.RECTANGLE [LAMBDA (WINDOW) (* rrb "11-AUG-83 12:24") (PROG (REGION OLD.BITMAP NEW.BITMAP ALLINFLG) (printout PROMPTWINDOW T "Indicate a rectangle to be edited") (SETQ REGION (GET.NOTEPAD.REGION WINDOW)) [COND ((SUBREGIONP (DSPCLIPPINGREGION NIL WINDOW) REGION) (* region is entirely within window) (SETQ ALLINFLG T) (SETQ OLD.BITMAP (PICKUP.BITMAP WINDOW REGION))) (T (* region is at least partially  outside of window Translate the  region into screen coordinates) (SETQ OLD.BITMAP (PICKUP.BITMAP NIL (CREATEREGION (IPLUS (fetch (REGION LEFT) of REGION) (DSPXOFFSET NIL WINDOW)) (IPLUS (fetch (REGION BOTTOM) of REGION) (DSPYOFFSET NIL WINDOW)) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION] (SETQ NEW.BITMAP (EDIT.BITMAP OLD.BITMAP)) (COND ((AND ALLINFLG (EQP (fetch (BITMAP BITMAPWIDTH) of OLD.BITMAP) (fetch (BITMAP BITMAPWIDTH) of NEW.BITMAP)) (EQP (fetch (BITMAP BITMAPHEIGHT) of OLD.BITMAP) (fetch (BITMAP BITMAPHEIGHT) of NEW.BITMAP))) (ERASE.REGION WINDOW REGION) (PUTBACK.BITMAP WINDOW REGION NEW.BITMAP)) (T (MOVE.BITMAP WINDOW NEW.BITMAP OPERATION]) (NOTEPAD.EDIT.SHADE [LAMBDA (WINDOW) (* DAHJr " 4-APR-83 16:44") (PROG (CHARACTERISTICS SHADE NEW.SHADE COLORDS) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ SHADE (LISTGET CHARACTERISTICS 'SHADE.DEFINITION)) [COND ((SETQ COLORDS (WINDOWPROP WINDOW 'INCOLOR)) (SETQ NEW.SHADE (RNUMBER)) (* set the color of the display stream although it doesn't appear to make any  difference it seems like it should.) (DSPCOLOR NEW.SHADE COLORDS)) (T (SETQ NEW.SHADE (EDITSHADE SHADE] (LISTPUT CHARACTERISTICS 'SHADE.DEFINITION NEW.SHADE) (printout PROMPTWINDOW T "Shade redefined"]) (NOTEPAD.ELLIPSE [LAMBDA (WINDOW OPERATION) (* rrb "14-JAN-83 09:57") (PROG (CHARACTERISTICS BRUSH P1 P2 P3 ANGLE) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) (printout PROMPTWINDOW T "Indicate center of ellipse") (SETQ P1 (NOTEPAD.GETPOSITION WINDOW ELLIPSE.CENTER)) (MARK.SPOT P1 NIL WINDOW) (printout PROMPTWINDOW T "Indicate semi-major axis") (SETQ P2 (NOTEPAD.GETPOSITION WINDOW ELLIPSE.SEMI.MAJOR)) (MARK.SPOT P2 NIL WINDOW) (printout PROMPTWINDOW T "Indicate semi-minor axis") (SETQ P3 (NOTEPAD.GETPOSITION WINDOW ELLIPSE.SEMI.MINOR)) (MARK.SPOT P2 NIL WINDOW) (MARK.SPOT P1 NIL WINDOW) (SETQ ANGLE (DIFFERENCE (ATAN (IDIFFERENCE (fetch (POSITION XCOORD) of P2) (fetch (POSITION XCOORD) of P1)) (IDIFFERENCE (fetch (POSITION YCOORD) of P2) (fetch (POSITION YCOORD) of P1))) 90)) (NOTEPAD.SETUP.TO.PAINT WINDOW OPERATION) (DRAWELLIPSE (fetch (POSITION XCOORD) of P1) (fetch (POSITION YCOORD) of P1) (DISTANCE P1 P2) (DISTANCE P1 P3) ANGLE 'PAINT.AT.POSSIBLE.POINT NIL WINDOW]) (NOTEPAD.LINE [LAMBDA (WINDOW OPERATION) (* rrb "14-JAN-83 09:57") (PROG (CHARACTERISTICS BRUSH P1 P2) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) (printout PROMPTWINDOW T "Indicate start point for the line") (SETQ P1 (NOTEPAD.GETPOSITION WINDOW)) (printout PROMPTWINDOW T "Indicate end point for the line") (SETQ P2 (GETPOSITION.RUBBERBAND P1 WINDOW)) (NOTEPAD.SETUP.TO.PAINT WINDOW OPERATION) (DRAWCURVE (LIST P1 P2) NIL 'PAINT.AT.POSSIBLE.POINT NIL WINDOW]) (NOTEPAD.MASK=BRUSH.OUTLINE [LAMBDA (WINDOW) (* edited%: "17-DEC-82 16:15") (PROG (CHARACTERISTICS NEW.MASK) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) (SETQ NEW.MASK (BITMAP.EXTERIOR BRUSH)) (BITBLT NIL 0 0 NEW.MASK 0 0 NIL NIL 'TEXTURE 'INVERT BLACKSHADE) (LISTPUT CHARACTERISTICS 'MASK.DEFINITION NEW.MASK) (printout PROMPTWINDOW T "Mask defined to an outline of the brush"]) (NOTEPAD.NAMED.OBJECT [LAMBDA (WINDOW OPERATION) (* ; "Edited 27-Sep-91 16:42 by jds") (PROG (NAME OBJECT NEW.BITMAP) (SETQ NAME (READ.FROM.PROMPT.WINDOW "Lisp expression to EVAL to get object to add to window: ")) (SETQ OBJECT (EVALV NAME)) (COND ((BITMAPP OBJECT) (SETQ NEW.BITMAP OBJECT) (MOVE.BITMAP WINDOW NEW.BITMAP OPERATION)) ((CURSORP OBJECT) (SETQ NEW.BITMAP (fetch (CURSOR CUIMAGE) of OBJECT)) (MOVE.BITMAP WINDOW NEW.BITMAP OPERATION)) (T (printout PROMPTWINDOW T "Not a bitmap" OBJECT]) (NOTEPAD.POINT.OF.SYMMETRY [LAMBDA (WINDOW) (* rrb "22-FEB-83 14:47") (PROG (CHARACTERISTICS ORIGIN) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (printout PROMPTWINDOW T "Indicate the point of symmetry") (SETQ ORIGIN (NOTEPAD.GETPOSITION WINDOW)) (LISTPUT CHARACTERISTICS 'POINT.OF.SYMMETRY.DEFINITION ORIGIN) (printout PROMPTWINDOW T "Point of symmetry defined"]) (NOTEPAD.RESTORE.STYLE [LAMBDA (WINDOW) (* DAHJr "26-JAN-83 14:05") (PROG (BITS.PER.PIXEL NEW.CHARACTERISTICS) (SETQ BITS.PER.PIXEL (LISTGET (WINDOWPROP WINDOW 'CHARACTERISTICS) 'BITS.PER.PIXEL)) (COND [NOTEPAD.STYLES (SETQ NEW.CHARACTERISTICS (ACQUIRE.STYLE BITS.PER.PIXEL)) (COND (NEW.CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS (COPYALL NEW.CHARACTERISTICS )) (printout PROMPTWINDOW T "Style restored"] (T (printout PROMPTWINDOW T "No styles to restore"]) (NOTEPAD.SETUP.TO.PAINT [LAMBDA (WINDOW OPERATION) (* rrb "27-DEC-82 16:56") (PROG (CHARACTERISTICS GRID POINT.OF.SYMMETRY BITMAPS BRUSH MASK) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (* if WINDOW is onto the color screen, its INCOLOR property is a color display  stream) (SETQ .NOTEPAD.WINDOW (COND ((WINDOWPROP WINDOW 'INCOLOR)) (T WINDOW))) (SETQ .NOTEPAD.OPERATION OPERATION) (SETQ .NOTEPAD.USE.SYMMETRIC.BRUSH/MASK (LISTGET CHARACTERISTICS 'USE.SYMMETRIC.BRUSH/MASK) ) (COND [.NOTEPAD.USE.SYMMETRIC.BRUSH/MASK (SETQ BITMAPS (GET.SYMMETRIC.BITMAPS CHARACTERISTICS 'BRUSH.DEFINITION)) (SETQ .NOTEPAD.BRUSH.1 (CAR BITMAPS)) (SETQ .NOTEPAD.BRUSH.2 (CADR BITMAPS)) (SETQ .NOTEPAD.BRUSH.3 (CADDR BITMAPS)) (SETQ .NOTEPAD.BRUSH.4 (CADDDR BITMAPS)) (SETQ .NOTEPAD.BRUSH.5 (CAR (CDDDDR BITMAPS))) (SETQ .NOTEPAD.BRUSH.6 (CADR (CDDDDR BITMAPS))) (SETQ .NOTEPAD.BRUSH.7 (CADDR (CDDDDR BITMAPS))) (SETQ .NOTEPAD.BRUSH.8 (CADDDR (CDDDDR BITMAPS] (T (SETQ BRUSH (GET.BITMAP CHARACTERISTICS 'BRUSH.DEFINITION)) (SETQ .NOTEPAD.BRUSH.1 BRUSH) (SETQ .NOTEPAD.BRUSH.2 BRUSH) (SETQ .NOTEPAD.BRUSH.3 BRUSH) (SETQ .NOTEPAD.BRUSH.4 BRUSH) (SETQ .NOTEPAD.BRUSH.5 BRUSH) (SETQ .NOTEPAD.BRUSH.6 BRUSH) (SETQ .NOTEPAD.BRUSH.7 BRUSH) (SETQ .NOTEPAD.BRUSH.8 BRUSH))) (SETQ .NOTEPAD.BRUSH.WIDTH (BITMAPWIDTH .NOTEPAD.BRUSH.1)) (SETQ .NOTEPAD.BRUSH.HEIGHT (BITMAPHEIGHT .NOTEPAD.BRUSH.1)) (SETQ .NOTEPAD.BRUSH.HALF.WIDTH (RSH .NOTEPAD.BRUSH.WIDTH 1)) (SETQ .NOTEPAD.BRUSH.HALF.HEIGHT (RSH .NOTEPAD.BRUSH.HEIGHT 1)) (SETQ .NOTEPAD.USE.GRID (LISTGET CHARACTERISTICS 'USE.GRID.TO.DRAW)) [COND (.NOTEPAD.USE.GRID (SETQ GRID (LISTGET CHARACTERISTICS 'GRID.DEFINITION)) (SETQ .NOTEPAD.GRID.X0 (fetch (REGION LEFT) of GRID)) (SETQ .NOTEPAD.GRID.Y0 (fetch (REGION BOTTOM) of GRID)) (SETQ .NOTEPAD.GRID.DX (fetch (REGION WIDTH) of GRID)) (SETQ .NOTEPAD.GRID.DY (fetch (REGION HEIGHT) of GRID] (SETQ .NOTEPAD.USE.MASK (LISTGET CHARACTERISTICS 'USE.MASK)) [COND (.NOTEPAD.USE.MASK (COND [.NOTEPAD.USE.SYMMETRIC.BRUSH/MASK (SETQ BITMAPS (GET.SYMMETRIC.BITMAPS CHARACTERISTICS 'MASK.DEFINITION)) (SETQ .NOTEPAD.MASK.1 (CAR BITMAPS)) (SETQ .NOTEPAD.MASK.2 (CADR BITMAPS)) (SETQ .NOTEPAD.MASK.3 (CADDR BITMAPS)) (SETQ .NOTEPAD.MASK.4 (CADDDR BITMAPS)) (SETQ .NOTEPAD.MASK.5 (CAR (CDDDDR BITMAPS))) (SETQ .NOTEPAD.MASK.6 (CADR (CDDDDR BITMAPS))) (SETQ .NOTEPAD.MASK.7 (CADDR (CDDDDR BITMAPS))) (SETQ .NOTEPAD.MASK.8 (CADDDR (CDDDDR BITMAPS] (T (SETQ MASK (GET.BITMAP CHARACTERISTICS 'MASK.DEFINITION)) (SETQ .NOTEPAD.MASK.1 MASK) (SETQ .NOTEPAD.MASK.2 MASK) (SETQ .NOTEPAD.MASK.3 MASK) (SETQ .NOTEPAD.MASK.4 MASK) (SETQ .NOTEPAD.MASK.5 MASK) (SETQ .NOTEPAD.MASK.6 MASK) (SETQ .NOTEPAD.MASK.7 MASK) (SETQ .NOTEPAD.MASK.8 MASK))) (SETQ .NOTEPAD.MASK.WIDTH (BITMAPWIDTH .NOTEPAD.MASK.1)) (SETQ .NOTEPAD.MASK.HEIGHT (BITMAPHEIGHT .NOTEPAD.MASK.1)) (SETQ .NOTEPAD.MASK.HALF.WIDTH (RSH .NOTEPAD.MASK.WIDTH 1)) (SETQ .NOTEPAD.MASK.HALF.HEIGHT (RSH .NOTEPAD.MASK.HEIGHT 1)) (SETQ .NOTEPAD.INVERSE.OPERATION (COND ((EQ OPERATION 'PAINT) 'ERASE) (T 'PAINT] (SETQ .NOTEPAD.USE.SYMMETRY (LISTGET CHARACTERISTICS 'USE.SYMMETRY)) [COND (.NOTEPAD.USE.SYMMETRY (SETQ POINT.OF.SYMMETRY (LISTGET CHARACTERISTICS 'POINT.OF.SYMMETRY.DEFINITION)) (SETQ .NOTEPAD.POSX (fetch (POSITION XCOORD) of POINT.OF.SYMMETRY)) (SETQ .NOTEPAD.POSY (fetch (POSITION YCOORD) of POINT.OF.SYMMETRY] (SETQ .NOTEPAD.PREVIOUS.MIDX) (SETQ .NOTEPAD.PREVIOUS.MIDY]) (NOTEPAD.SHADE.RECTANGLE [LAMBDA (WINDOW OPERATION) (* rrb "20-DEC-82 15:03") (PROG (CHARACTERISTICS REGION) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (printout PROMPTWINDOW T "Indicate rectangle to be PAINTED/ERASED with SHADE") (SETQ REGION (GET.NOTEPAD.REGION WINDOW)) (BITBLT NIL 0 0 (OR (WINDOWPROP WINDOW 'INCOLOR) WINDOW) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 'TEXTURE (COND ((WINDOWPROP WINDOW 'INCOLOR) (SELECTQ OPERATION (PAINT 'REPLACE) OPERATION)) (T OPERATION)) (LISTGET CHARACTERISTICS 'SHADE.DEFINITION]) (NOTEPAD.SKETCH [LAMBDA (WINDOW OPERATION) (* rrb "27-DEC-82 15:43") (PROG [BRUSH (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (SETQ BRUSH (GET.BITMAP (WINDOWPROP WINDOW 'CHARACTERISTICS) 'BRUSH.DEFINITION)) (NOTEPAD.SETUP.TO.PAINT WINDOW OPERATION) (COND [COLORDS (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (RESETFORM (SETDISPLAYHEIGHT 8) (NOTEPAD.SKETCH1 COLORDS (BITMAPCREATE .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT ( COLORNUMBERBITSPERPIXEL )) BRUSH] (T (NOTEPAD.SKETCH1 (WINDOWPROP WINDOW 'DSP) (BITMAPCREATE .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT) BRUSH))) (RETURN]) (NOTEPAD.SKETCH1 [LAMBDA (DS BUFFER.BITMAP BRUSH) (* rrb "22-DEC-82 11:36") (PROG (DOWN DONE MIDX MIDY NEW.MIDX NEW.MIDY) (until DONE do (GETMOUSESTATE) (COND ((LASTMOUSESTATE (NOT UP)) (SETQ DOWN T))) (COND ((AND DOWN (LASTMOUSESTATE UP)) (* RESTORE BITMAP) [COND (MIDX (BITBLT BUFFER.BITMAP 0 0 DS (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH ) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'REPLACE] (SETQ DONE T)) (T (SETQ NEW.MIDX (LASTMOUSEX DS)) (SETQ NEW.MIDY (LASTMOUSEY DS)) (COND ((OR (NEQ NEW.MIDX MIDX) (NEQ NEW.MIDY MIDY) (LASTMOUSESTATE (NOT UP))) (* RESTORE BITMAP) [COND (MIDX (BITBLT BUFFER.BITMAP 0 0 DS (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH ) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'REPLACE] (SETQ MIDX NEW.MIDX) (SETQ MIDY NEW.MIDY) (COND ((LASTMOUSESTATE (NOT UP)) (PAINT.AT.POSSIBLE.POINT MIDX MIDY))) (BITBLT DS (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) BUFFER.BITMAP 0 0 .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'REPLACE) (BITBLT BRUSH 0 0 DS (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'PAINT]) (NOTEPAD.TEXT [LAMBDA (WINDOW OPERATION) (* rrb " 4-JAN-83 16:45") (PROG [CHARACTERISTICS TEXT FONT TEXTWIDTH NEW.BITMAP DSP (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ TEXT (READ.FROM.PROMPT.WINDOW "Text to be printed: ")) [SETQ FONT (FONTCREATE (LISTGET CHARACTERISTICS 'PRINTING.FONT.DEFINITION] (SETQ TEXTWIDTH (STRINGWIDTH TEXT FONT)) [SETQ NEW.BITMAP (BITMAPCREATE TEXTWIDTH (FONTHEIGHT FONT) (COND (COLORDS (COLORNUMBERBITSPERPIXEL)) (T 1] (SETQ DSP (DSPCREATE NEW.BITMAP)) (DSPFONT FONT DSP) (AND COLORDS (DSPCOLOR (LISTGET CHARACTERISTICS 'SHADE.DEFINITION) DSP)) (MOVETO 0 (FONTDESCENT FONT) DSP) (PRIN3 TEXT DSP) (MOVE.BITMAP WINDOW NEW.BITMAP OPERATION]) (NOTEPAD.USE.GRID [LAMBDA (WINDOW) (* rrb "27-DEC-82 16:53") (PROG (CHARACTERISTICS USE.GRID USE.GRID.TO.DRAW) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SELECTQ [MENU (COND ((type? MENU NOTEPAD.USE.GRID.MENU) NOTEPAD.USE.GRID.MENU) (T (SETQ NOTEPAD.USE.GRID.MENU (create MENU ITEMS _ '((No% Grid 'NOGRID "no grid will be used") (When% specifying 'SPECIFY "the grid will be used when specifying points on the notepad." ) (When% drawing 'DRAW "the grid will be used as points are layed down in the trajectories." ) (Both 'BOTH "The grid will be used to specify points and when drawing trajectories." ] (NOGRID (SETQ USE.GRID NIL) (SETQ USE.GRID.TO.DRAW NIL)) (SPECIFY (SETQ USE.GRID T) (SETQ USE.GRID.TO.DRAW NIL)) (DRAW (SETQ USE.GRID NIL) (SETQ USE.GRID.TO.DRAW T)) (BOTH (SETQ USE.GRID T) (SETQ USE.GRID.TO.DRAW T)) (RETURN)) (LISTPUT CHARACTERISTICS 'USE.GRID USE.GRID) (LISTPUT CHARACTERISTICS 'USE.GRID.TO.DRAW USE.GRID.TO.DRAW) (printout PROMPTWINDOW T "Grid is now " (COND (USE.GRID (COND (USE.GRID.TO.DRAW "in use when drawing and specifying." ) (T "in use when specifying points." ))) (T (COND (USE.GRID.TO.DRAW "in use when drawing.") (T "not in use"]) (NOTEPAD.USE.MASK [LAMBDA (WINDOW) (* edited%: "17-DEC-82 10:05") (PROG (CHARACTERISTICS USE.MASK) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) [SETQ USE.MASK (NOT (LISTGET CHARACTERISTICS 'USE.MASK] (LISTPUT CHARACTERISTICS 'USE.MASK USE.MASK) (printout PROMPTWINDOW T "Mask is now " (COND (USE.MASK "in use") (T "not in use"]) (NOTEPAD.USE.SYMMETRIC.BRUSH/MASK [LAMBDA (WINDOW) (* edited%: "17-DEC-82 12:04") (PROG (CHARACTERISTICS USE.SYMMETRIC.BRUSH/MASK) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) [SETQ USE.SYMMETRIC.BRUSH/MASK (NOT (LISTGET CHARACTERISTICS 'USE.SYMMETRIC.BRUSH/MASK] (LISTPUT CHARACTERISTICS 'USE.SYMMETRIC.BRUSH/MASK USE.SYMMETRIC.BRUSH/MASK) (printout PROMPTWINDOW T "Symmetric brush and mask are now " (COND (USE.SYMMETRIC.BRUSH/MASK "in use") (T "not in use"]) (NOTEPAD.USE.SYMMETRY [LAMBDA (WINDOW) (* edited%: "17-DEC-82 10:36") (PROG (CHARACTERISTICS USE.SYMMETRY) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ USE.SYMMETRY (ACQUIRE.SYMMETRY)) (LISTPUT CHARACTERISTICS 'USE.SYMMETRY USE.SYMMETRY) (printout PROMPTWINDOW T "Symmetry is now " (SELECTQ USE.SYMMETRY (NIL "not in use") USE.SYMMETRY]) (NOTEPAD.FILL [LAMBDA (WINDOW OPERATION) (* DAHJr " 7-APR-83 18:23") (PROG [CHARACTERISTICS BITMAP REGION PT INTERIOR LEFT BOTTOM (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) LP (printout PROMPTWINDOW T "Indicate an exterior box for the filling.") [SETQ BITMAP (COND [COLORDS (PICKUP.BITMAP COLORDS (SETQ REGION (GETCOLORREGION] (T [SETQ REGION (INTERSECTREGIONS (GET.WINDOW.REGION WINDOW) (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW 'DSP] (COND (REGION (PICKUP.BITMAP WINDOW REGION)) (T (printout PROMPTWINDOW T "An empty region: try again") (GO LP] (printout PROMPTWINDOW T "Indicate position at which to start filling") (SETQ PT (NOTEPAD.GETPOSITION WINDOW)) (COND [(INSIDE? REGION (fetch XCOORD of PT) (fetch YCOORD of PT)) (SETQ PT (create POSITION XCOORD _ (IDIFFERENCE (fetch XCOORD of PT) (SETQ LEFT (fetch LEFT of REGION))) YCOORD _ (IDIFFERENCE (fetch YCOORD of PT) (SETQ BOTTOM (fetch BOTTOM of REGION] (T (PROMPTPRINT "The point should be inside the bounding region.") (GO LP))) (SETQ INTERIOR (BITMAP.INTERIOR BITMAP PT)) (* simulate merge since this will work for both color and b&w where as BITBLT  merge only works for b&w NIL) (BITBLT INTERIOR 0 0 (OR COLORDS WINDOW) LEFT BOTTOM NIL NIL 'INPUT 'ERASE) [BITBLT NIL NIL NIL INTERIOR 0 0 NIL NIL 'TEXTURE 'ERASE (LOGXOR (LISTGET CHARACTERISTICS 'SHADE.DEFINITION) (COND (COLORDS (MAXIMUMCOLOR)) (T BLACKSHADE] (BITBLT INTERIOR 0 0 (OR COLORDS WINDOW) LEFT BOTTOM NIL NIL 'INPUT 'PAINT]) (NOTEPAD.CONFIRM [LAMBDA (MESSAGE) (* edited%: " 2-APR-82 18:04") (PROG ((MENU (create MENU TITLE _ MESSAGE ITEMS _ '((YES T) (NO NIL)) CENTERFLG _ T CHANGEOFFSETFLG _ T))) (RETURN (MENU MENU]) (NOTEPAD.CREATE [LAMBDA (BITMAP INCOLORFLG) (* DAHJr "23-OCT-83 12:06") (PROG ((TITLE (COND (INCOLORFLG "Color Notepad control window") (T "Black and white Notepad control window"))) NPWINDOW WIDTH HEIGHT WINDOW.WIDTH WINDOW.HEIGHT) (COND ((AND (NULL INCOLORFLG) BITMAP) (GETMOUSESTATE) (SETQ WIDTH (BITMAPWIDTH BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (SETQ WINDOW.WIDTH (IPLUS 8 WIDTH)) (SETQ WINDOW.HEIGHT (IPLUS 20 HEIGHT)) (SETQ NPWINDOW (CREATEW (create REGION LEFT _ (MAX 0 (MIN (IDIFFERENCE SCREENWIDTH WINDOW.WIDTH ) LASTMOUSEX)) BOTTOM _ (MAX 0 (MIN (IDIFFERENCE SCREENHEIGHT WINDOW.HEIGHT) LASTMOUSEY)) WIDTH _ WINDOW.WIDTH HEIGHT _ WINDOW.HEIGHT) TITLE 4)) (BITBLT BITMAP 0 0 NPWINDOW 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (printout PROMPTWINDOW T "Move this new notepad to desired position") (MOVEW NPWINDOW) (CLRPROMPT)) (T (printout PROMPTWINDOW T "Indicate a region for a NOTEPAD window") (SETQ NPWINDOW (CREATEW (GETREGION) TITLE)) (CLRPROMPT))) (COND (INCOLORFLG (COLORDISPLAY T (AND (FIXP INCOLORFLG) INCOLORFLG)) [WINDOWPROP NPWINDOW 'INCOLOR (SETQ INCOLORFLG (DSPCREATE (COLORSCREENBITMAP] (DSPCLIPPINGREGION WHOLECOLORDISPLAY INCOLORFLG))) (WINDOWPROP NPWINDOW 'BUTTONEVENTFN 'NOTEPAD.BUTTONEVENTFN) (WINDOWPROP NPWINDOW 'CHARACTERISTICS (NOTEPAD.DEFAULT.CHARACTERISTICS INCOLORFLG)) (NOTEPAD.HELP) (RETURN NPWINDOW]) (NOTEPAD.DEFAULT.CHARACTERISTICS [LAMBDA (INCOLORFLG) (* DAHJr "31-MAY-83 12:05") (* returns the default  characteristics of a notepad  window's brush style etc.) (COND (INCOLORFLG (LIST 'BITS.PER.PIXEL (COLORNUMBERBITSPERPIXEL) 'BRUSH.DEFINITION (COLORIZEBITMAP NOTEPAD.DEFAULT.BRUSH 0 (MAXIMUMCOLOR) (COLORNUMBERBITSPERPIXEL)) 'MASK.DEFINITION (COLORIZEBITMAP NOTEPAD.DEFAULT.MASK 0 (MAXIMUMCOLOR) (COLORNUMBERBITSPERPIXEL)) 'USE.MASK NIL 'PRINTING.FONT.DEFINITION NOTEPAD.DEFAULT.FONT 'GRID.DEFINITION '(0 0 16 16) 'USE.GRID NIL 'USE.GRID.TO.DRAW NIL 'USE.SYMMETRY NIL 'POINT.OF.SYMMETRY.DEFINITION (CONS (IQUOTIENT COLORSCREENWIDTH 2) (IQUOTIENT COLORSCREENHEIGHT 2)) 'USE.SYMMETRIC.BRUSH/MASK NIL 'SHADE.DEFINITION (MAXIMUMCOLOR))) (T (LIST 'BITS.PER.PIXEL 1 'BRUSH.DEFINITION NOTEPAD.DEFAULT.BRUSH 'MASK.DEFINITION NOTEPAD.DEFAULT.MASK 'USE.MASK NIL 'PRINTING.FONT.DEFINITION NOTEPAD.DEFAULT.FONT 'GRID.DEFINITION '(0 0 16 16) 'USE.GRID NIL 'USE.GRID.TO.DRAW NIL 'USE.SYMMETRY NIL 'POINT.OF.SYMMETRY.DEFINITION (CONS 100 100) 'USE.SYMMETRIC.BRUSH/MASK NIL 'SHADE.DEFINITION BLACKSHADE]) (NOTEPAD.GETPOSITION [LAMBDA (WINDOW CURSOR NOGRID) (* rrb "22-FEB-83 14:46") (* IF USE.GRID IS NOT GIVEN, SEE IF  YOU NEED TO GRIDIFY;  OTHERWISE ALWAYS GRIDIFY) (PROG (PT CHARACTERISTICS USE.GRID DS) [SETQ PT (COND ((SETQ DS (WINDOWPROP WINDOW 'INCOLOR)) (GETCOLORPOSITION DS CURSOR)) (T (GETPOSITION WINDOW CURSOR] (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ USE.GRID (LISTGET CHARACTERISTICS 'USE.GRID)) (RETURN (COND [USE.GRID (NOTEPAD.ON.GRID PT (LISTGET CHARACTERISTICS 'GRID.DEFINITION] (T PT]) (NOTEPAD.MASK [LAMBDA (BITMAP) (* edited%: " 2-DEC-82 10:21") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) LEFT RIGHT BOTTOM TOP NEW.BITMAP) (SETQ NEW.BITMAP (BITMAPCREATE WIDTH HEIGHT)) (DSPFILL NIL -1 PAINT NEW.BITMAP) [for X from 0 to (SUB1 WIDTH) DO (for Y from 0 to (SUB1 HEIGHT) THEREIS (COND ((EQ 1 (BITMAPBIT BITMAP X Y)) T) ((BITMAPBIT BITMAP X Y 0] (SETQ RIGHT (for X from (SUB1 WIDTH) to 0 by -1 thereis (BIT.IN.COLUMN BITMAP X))) (SETQ BOTTOM (for X from 0 to (SUB1 HEIGHT) thereis (BIT.IN.ROW BITMAP X))) (SETQ TOP (for X from (SUB1 HEIGHT) to 0 by -1 thereis (BIT.IN.ROW BITMAP X))) (RETURN NEW.BITMAP]) (NOTEPAD.ON.GRID [LAMBDA (PT GRID) (* rrb "27-DEC-82 16:59") (create POSITION XCOORD _ (NOTEPAD.ON.GRID.X (fetch (POSITION XCOORD) of PT) (fetch (REGION LEFT) of GRID) (fetch (REGION WIDTH) of GRID)) YCOORD _ (NOTEPAD.ON.GRID.X (fetch (POSITION YCOORD) of PT) (fetch (REGION BOTTOM) of GRID) (fetch (REGION HEIGHT) of GRID]) (NOTEPAD.ON.GRID.X [LAMBDA (X X0 DX) (* edited%: " 7-DEC-82 17:30") (PROG (X1 NEGATIVE) (SETQ X1 (IDIFFERENCE X X0)) (COND ((ILESSP X1 0) (SETQ X1 (MINUS X1)) (SETQ NEGATIVE T))) (SETQ X1 (ITIMES DX (IQUOTIENT (IPLUS X1 (RSH DX 1)) DX))) [COND (NEGATIVE (SETQ X1 (MINUS X1] (RETURN (IPLUS X0 X1]) (NOTEPAD.OPERATION [LAMBDA NIL (* edited%: " 4-DEC-82 15:55") (COND ((LASTMOUSESTATE LEFT) 'PAINT) (T 'ERASE]) (NOTEPAD.SOLID.AREA [LAMBDA (WINDOW REGION OPERATION) (* edited%: " 4-DEC-82 17:31") (BITBLT NIL 0 0 WINDOW (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 'TEXTURE 'REPLACE (COND ((EQ OPERATION 'PAINT) BLACKSHADE) (T WHITESHADE]) (BITMAP.EXTERIOR [LAMBDA (BITMAP) (* rrb "19-JAN-83 19:27") (PROG ((WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP)) INTERIOR (NBITS (BITSPERPIXEL BITMAP)) FROMVALUE MAXVAL MAXX MAXY) (SETQ MAXVAL (SUB1 (EXPT 2 NBITS))) (SETQ INTERIOR (BITMAPCREATE WIDTH HEIGHT NBITS)) (SETQ MAXX (SUB1 WIDTH)) (SETQ MAXY (SUB1 HEIGHT)) (* use the upper right corner bit as the from value in the color case, 0 in the  b&w case.) [SETQ FROMVALUE (COND ((EQ NBITS 1) 0) (T (BITMAPBIT BITMAP MAXX MAXY] (for X from 0 to MAXX do (EXTEND.AREA BITMAP INTERIOR X 0 MAXX MAXY FROMVALUE MAXVAL) (EXTEND.AREA BITMAP INTERIOR X MAXY MAXX MAXY FROMVALUE MAXVAL)) (for Y from 1 to (SUB1 MAXY) do (EXTEND.AREA BITMAP INTERIOR 0 Y MAXX MAXY FROMVALUE MAXVAL) (EXTEND.AREA BITMAP INTERIOR MAXX Y MAXX MAXY FROMVALUE MAXVAL)) (RETURN INTERIOR]) (NOTEPAD.TITLEBUTTONFN [LAMBDA (WINDOW) (* DAHJr " 4-APR-83 16:42") (PROG (CHARACTERISTICS DSP COMMAND.MENU COMMAND NEW.NOTEPAD STARTPT ENDPT REGION POSITION WINDOWBITMAP BITMAP.NAME NEW.BITMAP TEXT) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ DSP (WINDOWPROP WINDOW 'DSP)) [SETQ COMMAND.MENU (create MENU TITLE _ "Operations on the whole" ITEMS _ '(HELP NEW.NOTEPAD COPY.NOTEPAD SAVE.AS.BITMAP INSPECT.STYLE] (SETQ COMMAND (MENU COMMAND.MENU)) (SELECTQ COMMAND (NIL NIL) (HELP (NOTEPAD.HELP)) (NEW.NOTEPAD (SETQ NEW.NOTEPAD (NOTEPAD.CREATE)) [WINDOWPROP NEW.NOTEPAD 'CHARACTERISTICS (COPYALL (WINDOWPROP WINDOW 'CHARACTERISTICS]) (COPY.NOTEPAD (SETQ REGION (DSPCLIPPINGREGION NIL DSP)) (SETQ NEW.BITMAP (PICKUP.BITMAP WINDOW REGION)) (SETQ NEW.NOTEPAD (NOTEPAD.CREATE NEW.BITMAP)) [WINDOWPROP NEW.NOTEPAD 'CHARACTERISTICS (COPYALL (WINDOWPROP WINDOW 'CHARACTERISTICS]) (SAVE.AS.BITMAP (printout PROMPTWINDOW T "Indicate region to be saved as a bitmap") (SETQ REGION (GET.NOTEPAD.REGION WINDOW)) (SETQ BITMAP.NAME (READ.FROM.PROMPT.WINDOW "Name for new bitmap: ")) (SETQ NEW.BITMAP (PICKUP.BITMAP WINDOW REGION)) (SET BITMAP.NAME NEW.BITMAP)) (INSPECT.STYLE (INSPECT/PLIST CHARACTERISTICS)) (SHOULDNT (CONCAT "Unrecognized COMMAND in NOTEPAD.BUTTONEVENTFN: " COMMAND]) (PAINT.A.BITMAP [LAMBDA (BRUSH MASK MIDX MIDY POSSIBLY.ROTATED) (* rrb "20-DEC-82 15:46") (* masks with mask and paints or  erases with the brush bitmaps.) (COND ((AND POSSIBLY.ROTATED .NOTEPAD.USE.SYMMETRIC.BRUSH/MASK) (COND (.NOTEPAD.USE.MASK (BITBLT MASK 0 0 .NOTEPAD.WINDOW (IDIFFERENCE MIDX .NOTEPAD.MASK.HALF.HEIGHT) (IDIFFERENCE MIDY .NOTEPAD.MASK.HALF.WIDTH) .NOTEPAD.MASK.HEIGHT .NOTEPAD.MASK.WIDTH 'INPUT .NOTEPAD.INVERSE.OPERATION))) (BITBLT BRUSH 0 0 .NOTEPAD.WINDOW (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.HEIGHT) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.WIDTH) .NOTEPAD.BRUSH.HEIGHT .NOTEPAD.BRUSH.WIDTH 'INPUT .NOTEPAD.OPERATION)) (T (COND (.NOTEPAD.USE.MASK (BITBLT MASK 0 0 .NOTEPAD.WINDOW (IDIFFERENCE MIDX .NOTEPAD.MASK.HALF.WIDTH) (IDIFFERENCE MIDY .NOTEPAD.MASK.HALF.HEIGHT) .NOTEPAD.MASK.WIDTH .NOTEPAD.MASK.HEIGHT 'INPUT .NOTEPAD.INVERSE.OPERATION))) (BITBLT BRUSH 0 0 .NOTEPAD.WINDOW (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT .NOTEPAD.OPERATION]) (PAINT.ALL.BITMAPS [LAMBDA (MIDX MIDY) (* edited%: "17-DEC-82 16:28") (SELECTQ .NOTEPAD.USE.SYMMETRY (NIL (PAINT.A.BITMAP .NOTEPAD.BRUSH.1 .NOTEPAD.MASK.1 MIDX MIDY)) (LEFT/RIGHT (PAINT.A.BITMAP .NOTEPAD.BRUSH.1 .NOTEPAD.MASK.1 MIDX MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.2 .NOTEPAD.MASK.2 (IDIFFERENCE (IPLUS .NOTEPAD.POSX .NOTEPAD.POSX ) MIDX) MIDY)) (UP/DOWN (PAINT.A.BITMAP .NOTEPAD.BRUSH.1 .NOTEPAD.MASK.1 MIDX MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.3 .NOTEPAD.MASK.3 MIDX (IDIFFERENCE (IPLUS .NOTEPAD.POSY .NOTEPAD.POSY ) MIDY))) (4-FOLD (PROG (REF.MIDX REF.MIDY) (SETQ REF.MIDX (IDIFFERENCE (IPLUS .NOTEPAD.POSX .NOTEPAD.POSX) MIDX)) (SETQ REF.MIDY (IDIFFERENCE (IPLUS .NOTEPAD.POSY .NOTEPAD.POSY) MIDY)) (PAINT.A.BITMAP .NOTEPAD.BRUSH.1 .NOTEPAD.MASK.1 MIDX MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.2 .NOTEPAD.MASK.2 REF.MIDX MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.3 .NOTEPAD.MASK.3 MIDX REF.MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.4 .NOTEPAD.MASK.4 REF.MIDX REF.MIDY))) (8-FOLD (PROG (REF.MIDX REF.MIDY DIAG.MIDX DIAG.MIDY) (SETQ REF.MIDX (IDIFFERENCE (IPLUS .NOTEPAD.POSX .NOTEPAD.POSX) MIDX)) (SETQ REF.MIDY (IDIFFERENCE (IPLUS .NOTEPAD.POSY .NOTEPAD.POSY) MIDY)) (PAINT.A.BITMAP .NOTEPAD.BRUSH.1 .NOTEPAD.MASK.1 MIDX MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.2 .NOTEPAD.MASK.2 REF.MIDX MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.3 .NOTEPAD.MASK.3 MIDX REF.MIDY) (PAINT.A.BITMAP .NOTEPAD.BRUSH.4 .NOTEPAD.MASK.4 REF.MIDX REF.MIDY) (SETQ DIAG.MIDX (IDIFFERENCE (IPLUS .NOTEPAD.POSX MIDY) .NOTEPAD.POSY)) (SETQ DIAG.MIDY (IDIFFERENCE (IPLUS .NOTEPAD.POSY MIDX) .NOTEPAD.POSX)) (SETQ REF.MIDX (IDIFFERENCE (IPLUS .NOTEPAD.POSX .NOTEPAD.POSX) DIAG.MIDX)) (SETQ REF.MIDY (IDIFFERENCE (IPLUS .NOTEPAD.POSY .NOTEPAD.POSY) DIAG.MIDY)) (PAINT.A.BITMAP .NOTEPAD.BRUSH.5 .NOTEPAD.MASK.5 DIAG.MIDX DIAG.MIDY T) (PAINT.A.BITMAP .NOTEPAD.BRUSH.6 .NOTEPAD.MASK.6 REF.MIDX DIAG.MIDY T) (PAINT.A.BITMAP .NOTEPAD.BRUSH.7 .NOTEPAD.MASK.7 DIAG.MIDX REF.MIDY T) (PAINT.A.BITMAP .NOTEPAD.BRUSH.8 .NOTEPAD.MASK.8 REF.MIDX REF.MIDY T))) (ERROR USE.SYMMETRY ": unrecognized symmetry type in PAINT.ALL.BITMAPS"]) (PAINT.AT.POSSIBLE.POINT [LAMBDA (MIDX MIDY) (* edited%: " 7-DEC-82 17:34") (PROG (USABLE.MIDX USABLE.MIDY) (SETQ USABLE.MIDX (COND (.NOTEPAD.USE.GRID (NOTEPAD.ON.GRID.X MIDX .NOTEPAD.GRID.X0 .NOTEPAD.GRID.DX)) (T MIDX))) (SETQ USABLE.MIDY (COND (.NOTEPAD.USE.GRID (NOTEPAD.ON.GRID.X MIDY .NOTEPAD.GRID.Y0 .NOTEPAD.GRID.DY)) (T MIDY))) (COND ((OR (NEQ USABLE.MIDX .NOTEPAD.PREVIOUS.MIDX) (NEQ USABLE.MIDY .NOTEPAD.PREVIOUS.MIDY)) (PAINT.ALL.BITMAPS USABLE.MIDX USABLE.MIDY) (SETQ .NOTEPAD.PREVIOUS.MIDX USABLE.MIDX) (SETQ .NOTEPAD.PREVIOUS.MIDY USABLE.MIDY]) (PAINT.WITH.BITMAP [LAMBDA (WINDOW OPERATION) (* edited%: "17-DEC-82 15:44") (PROG (BUFFER.BITMAP DOWN DONE MIDX MIDY NEW.MIDX NEW.MIDY) (NOTEPAD.SETUP.TO.PAINT WINDOW OPERATION) (SETQ BUFFER.BITMAP (BITMAPCREATE .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT)) [until DONE do ((GETMOUSESTATE) (COND ((LASTMOUSESTATE (NOT UP)) (* RESTORE BITMAP) (SETQ DOWN T))) (COND ((AND DOWN (LASTMOUSESTATE UP)) (* RESTORE BITMAP) [COND (MIDX (BITBLT BUFFER.BITMAP 0 0 WINDOW (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH ) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'REPLACE] (SETQ DONE T)) (T (SETQ NEW.MIDX (LASTMOUSEX WINDOW)) (SETQ NEW.MIDY (LASTMOUSEY WINDOW)) (COND ((OR (NEQ NEW.MIDX MIDX) (NEQ NEW.MIDY MIDY) (LASTMOUSESTATE (OR LEFT MIDDLE))) (* RESTORE BITMAP) [COND (MIDX (BITBLT BUFFER.BITMAP 0 0 WINDOW (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'REPLACE] (SETQ MIDX NEW.MIDX) (SETQ MIDY NEW.MIDY) (COND ((LASTMOUSESTATE (NOT UP)) (PAINT.AT.POSSIBLE.POINT MIDX MIDY))) (BITBLT WINDOW (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) BUFFER.BITMAP 0 0 .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'REPLACE) (BITBLT BRUSH 0 0 WINDOW (IDIFFERENCE MIDX .NOTEPAD.BRUSH.HALF.WIDTH ) (IDIFFERENCE MIDY .NOTEPAD.BRUSH.HALF.HEIGHT) .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT 'INPUT 'PAINT] (RETURN]) (PICKUP.BITMAP [LAMBDA (WINDOW REGION) (* rrb "22-DEC-82 12:14") (PROG (NEW.BITMAP WIDTH HEIGHT) (SETQ WIDTH (fetch (REGION WIDTH) of REGION)) (SETQ HEIGHT (fetch (REGION HEIGHT) of REGION)) [SETQ NEW.BITMAP (BITMAPCREATE WIDTH HEIGHT (COND (WINDOW (fetch (BITMAP BITMAPBITSPERPIXEL ) of (DSPDESTINATION NIL WINDOW ))) (T 1] (BITBLT (OR WINDOW (SCREENBITMAP)) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) NEW.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (PICKUP.SCREEN.BITMAP [LAMBDA (REGION SCREEN) (* rrb "22-DEC-82 10:35") (* pick up a piece of a screen.) (PROG (NEW.BITMAP WIDTH HEIGHT) (SETQ WIDTH (fetch (REGION WIDTH) of REGION)) (SETQ HEIGHT (fetch (REGION HEIGHT) of REGION)) (SETQ NEW.BITMAP (BITMAPCREATE WIDTH HEIGHT (BITSPERPIXEL SCREEN))) (BITBLT SCREEN (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) NEW.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (READ.FROM.PROMPT.WINDOW [LAMBDA (PRMPT) (* edited%: "15-DEC-82 23:02") (CLEARBUF T T) (CAR (PROCESS.READ PROMPTWINDOW PRMPT T]) (PUTBACK.BITMAP [LAMBDA (WINDOW REGION BITMAP) (* edited%: "18-OCT-82 11:57") (BITBLT BITMAP 0 0 WINDOW (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 'INPUT 'REPLACE]) (PUTDEF.NOTEPAD.STYLE [LAMBDA (NAME TYPE NOTEPAD.STYLE) (* DAHJr "26-JAN-83 10:33") (COND (NOTEPAD.STYLES (PUTASSOC NAME NOTEPAD.STYLE NOTEPAD.STYLES) (SORT NOTEPAD.STYLES T)) (T (SETQ NOTEPAD.STYLES (LIST (CONS NAME NOTEPAD.STYLE]) (SAVE.STYLE [LAMBDA (WINDOW) (* DAHJr "26-JAN-83 10:34") (PROG (CHARACTERISTICS NAME OLD.ENTRY) (SETQ CHARACTERISTICS (WINDOWPROP WINDOW 'CHARACTERISTICS)) (SETQ NAME (READ.FROM.PROMPT.WINDOW "Give name under which to save the style: ")) (COND (NAME (SETQ OLD.ENTRY (GETDEF.NOTEPAD.STYLE NAME 'NOTEPADSTYLE)) (COND ((OR (NULL OLD.ENTRY) (CONFIRM (CONCAT "Over-write old entry named " NAME))) (PUTDEF.NOTEPAD.STYLE NAME 'NOTEPADSTYLE (COPYALL CHARACTERISTICS)) (MARKASCHANGED NAME 'NOTEPADSTYLE (NULL OLD.ENTRY)) (printout PROMPTWINDOW T "Style saved under the name " NAME]) (SBIT [LAMBDA (X Y) (* edited%: " 5-DEC-82 12:39") (BITBLT NIL 0 0 WINDOW X Y 1 1 'TEXTURE 'INVERT BLACKSHADE]) (TEST.AND.SET [LAMBDA (DEFINING.BITMAP AREA.BITMAP X Y FROMVALUE TOVALUE) (* rrb "19-JAN-83 19:21") (DECLARE (LOCALVARS . T)) (COND ((EQ (BITMAPBIT AREA.BITMAP X Y) TOVALUE) (* already been here) NIL) ((NEQ (BITMAPBIT DEFINING.BITMAP X Y) FROMVALUE) (* hit a boundary point) NIL) (T (BITMAPBIT AREA.BITMAP X Y TOVALUE) T]) ) (DEFINEQ (GET.WINDOW.REGION [LAMBDA (W) (* DAHJr "23-OCT-83 11:13") (* gets a region from a window on either the color screen or the b&w screen.) (PROG (DS REG) (RETURN (COND ((SETQ DS (WINDOWPROP W 'INCOLOR)) (SETQ REG (GETCOLORREGION)) (create REGION LEFT _ (IDIFFERENCE (fetch LEFT of REG) (DSPXOFFSET NIL DS)) BOTTOM _ (IDIFFERENCE (fetch BOTTOM of REG) (DSPYOFFSET NIL DS)) WIDTH _ (fetch WIDTH of REG) HEIGHT _ (fetch HEIGHT of REG))) (T (SETQ REG (GETREGION)) (SETQ DS (WINDOWPROP W 'DSP)) (create REGION LEFT _ (IDIFFERENCE (fetch LEFT of REG) (DSPXOFFSET NIL DS)) BOTTOM _ (IDIFFERENCE (fetch BOTTOM of REG) (DSPYOFFSET NIL DS)) WIDTH _ (fetch WIDTH of REG) HEIGHT _ (fetch HEIGHT of REG]) (GETCOLORPOSITION [LAMBDA (DS CURSOR) (* rrb "20-DEC-82 16:07") (* gets a point from the color  screen) (RESETLST (RESETSAVE (CHANGECURSORSCREEN (COLORSCREENBITMAP))) (GETPOSITION DS CURSOR))]) (COLORBITMAPP [LAMBDA (BITMAP) (* rrb "22-DEC-82 09:42") (AND (BITMAPP BITMAP) (NEQ (BITSPERPIXEL BITMAP) 1) BITMAP]) ) (RPAQQ NOTEPAD.DEFAULT.FONT (HELVETICA 18 BOLD)) (RPAQQ NOTEPAD.STYLE.REPRESENTATION.NUMBER 1) (RPAQQ NOTEPAD.COMMAND.MENU NIL) (RPAQQ NOTEPAD.SHOW.FILL NIL) (RPAQQ NOTEPAD.USE.GRID.MENU NIL) (RPAQQ .NOTEPAD.BRUSH.1 NIL) (RPAQQ .NOTEPAD.BRUSH.2 NIL) (RPAQQ .NOTEPAD.BRUSH.3 NIL) (RPAQQ .NOTEPAD.BRUSH.4 NIL) (RPAQQ .NOTEPAD.BRUSH.5 NIL) (RPAQQ .NOTEPAD.BRUSH.6 NIL) (RPAQQ .NOTEPAD.BRUSH.7 NIL) (RPAQQ .NOTEPAD.BRUSH.8 NIL) (RPAQQ .NOTEPAD.MASK.1 NIL) (RPAQQ .NOTEPAD.MASK.2 NIL) (RPAQQ .NOTEPAD.MASK.3 NIL) (RPAQQ .NOTEPAD.MASK.4 NIL) (RPAQQ .NOTEPAD.MASK.5 NIL) (RPAQQ .NOTEPAD.MASK.6 NIL) (RPAQQ .NOTEPAD.MASK.7 NIL) (RPAQQ .NOTEPAD.MASK.8 NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NOTEPAD.COMMAND.MENU NOTEPAD.USE.GRID.MENU .NOTEPAD.WINDOW .NOTEPAD.OPERATION .NOTEPAD.BRUSH.1 .NOTEPAD.BRUSH.2 .NOTEPAD.BRUSH.3 .NOTEPAD.BRUSH.4 .NOTEPAD.BRUSH.5 .NOTEPAD.BRUSH.6 .NOTEPAD.BRUSH.7 .NOTEPAD.BRUSH.8 .NOTEPAD.MASK.1 .NOTEPAD.MASK.2 .NOTEPAD.MASK.3 .NOTEPAD.MASK.4 .NOTEPAD.MASK.5 .NOTEPAD.MASK.6 .NOTEPAD.MASK.7 .NOTEPAD.MASK.8 .NOTEPAD.USE.GRID .NOTEPAD.GRID.X0 .NOTEPAD.GRID.Y0 .NOTEPAD.GRID.DX .NOTEPAD.GRID.DY .NOTEPAD.USE.MASK .NOTEPAD.INVERSE.OPERATION .NOTEPAD.USE.SYMMETRIC.BRUSH/MASK .NOTEPAD.USE.SYMMETRY .NOTEPAD.POSX .NOTEPAD.POSY .NOTEPAD.BRUSH.WIDTH .NOTEPAD.BRUSH.HEIGHT .NOTEPAD.BRUSH.HALF.WIDTH .NOTEPAD.BRUSH.HALF.HEIGHT .NOTEPAD.MASK.WIDTH .NOTEPAD.MASK.HEIGHT .NOTEPAD.MASK.HALF.WIDTH .NOTEPAD.MASK.HALF.HEIGHT .NOTEPAD.PREVIOUS.MIDX .NOTEPAD.PREVIOUS.MIDY) ) (RPAQQ COLORSPOTMARKER NIL) (RPAQ? NOTEPAD.STYLES ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NOTEPAD.STYLES) ) (RPAQQ SPOTMARKER #*(17 18)@@@@@@@@@@@@@@@@@@L@@@@@@@L@@@@@@@L@@@@@@@L@@@@@@@@@@@@@ANMN@@@@ANMN@@@@@@@@@@@@@@L@@@@@@@L@@@@@@@L@@@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ NOTEPAD.DEFAULT.BRUSH #*(3 3)@@@@D@@@@@@@) (RPAQQ NOTEPAD.DEFAULT.MASK #*(3 3)N@@@N@@@N@@@) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SPOTMARKER NOTEPAD.DEFAULT.BRUSH NOTEPAD.DEFAULT.MASK) ) (RPAQ CIRCLE.CENTER (CURSORCREATE (QUOTE #*(16 16)@GN@AOOHCLCLG@@NFDBFNJEGLEJCLBDCLBDCLEJCNJEGFDBFG@@NCLCLAOOH@GN@ ) (QUOTE NIL) 8 8)) (RPAQ CIRCLE.EDGE (CURSORCREATE (QUOTE #*(16 16)@@AL@@@L@@@N@@@F@@BG@@CC@@CKOOOOOOOO@@CK@@CC@@BG@@@F@@@N@@@L@@AL ) (QUOTE NIL) 15 8)) (RPAQ ELLIPSE.CENTER (CURSORCREATE (QUOTE #*(16 16)@GN@AOOHCLCLG@@NFDBFNJEGLEJCLBDCLBDCLEJCNJEGFDBFG@@NCLCLAOOH@GN@ ) (QUOTE NIL) 8 8)) (RPAQ ELLIPSE.SEMI.MAJOR (CURSORCREATE (QUOTE #*(16 16)@@AL@@@L@@@N@@@F@@BG@@CC@@CKOOOOOOOO@@CK@@CC@@BG@@@F@@@N@@@L@@AL ) (QUOTE NIL) 15 8)) (RPAQ ELLIPSE.SEMI.MINOR (CURSORCREATE (QUOTE #*(16 16)@OO@COOLOIIONCLGHGNA@OO@@AH@@AH@@AH@@AH@@AH@@AH@@AH@@AH@@AH@@AH@ ) (QUOTE NIL) 8 15)) (RPAQ CURVE.KNOT (CURSORCREATE (QUOTE #*(16 16)@GN@AOOHCLCLG@@NFDBFNJEGLEJCLBDCLBDCLEJCNJEGFDBFG@@NCLCLAOOH@GN@ ) (QUOTE NIL) 8 8)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CIRCLE.CENTER CIRCLE.EDGE ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR CURVE.KNOT ) ) (FILESLOAD (FROM VALUEOF LISPUSERSDIRECTORIES) EDITBITMAP READNUMBER) (PUTDEF (QUOTE NOTEPADSTYLE) (QUOTE FILEPKGCOMS) '((COM COM T) (TYPE DESCRIPTION "NOTEPAD styles" GETDEF GETDEF.NOTEPAD.STYLE DELDEF DELDEF.NOTEPAD.STYLE PUTDEF PUTDEF.NOTEPAD.STYLE))) (ADD.NOTEPAD.TO.BACKGROUND.MENU) (FONTCREATE NOTEPAD.DEFAULT.FONT) (COND ((NULL NOTEPAD.STYLES) (FILESLOAD NOTEPAD-CORESTYLES))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML READ.NOTEPAD.STYLE) (ADDTOVAR LAMA ) ) (PUTPROPS NOTEPAD COPYRIGHT ("Xerox Corporation" 1982 1983 1988 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5480 98089 (ACQUIRE.STYLE 5490 . 6406) (ACQUIRE.SYMMETRY 6408 . 6868) ( ADD.NOTEPAD.TO.BACKGROUND.MENU 6870 . 7547) (BITMAP.INTERIOR 7549 . 8428) (DELDEF.NOTEPAD.STYLE 8430 . 8660) (DISTANCE 8662 . 9162) (DUMP.NOTEPAD.STYLE 9164 . 9514) (ERASE.REGION 9516 . 9907) ( EXTEND.AREA 9909 . 10302) (EXTEND.AREA.X 10304 . 11188) (EXTEND.AREA.Y 11190 . 12074) (GET.BITMAP 12076 . 12396) (GET.NOTEPAD.BITMAP 12398 . 12567) (GET.NOTEPAD.REGION 12569 . 14249) ( GET.SYMMETRIC.BITMAPS 14251 . 15286) (GETDEF.NOTEPAD.STYLE 15288 . 15445) (GETPOSITION.RUBBERBAND 15447 . 16834) (GETPOSITION.RUBBERBAND1 16836 . 18527) (MARK.SPOT 18529 . 19776) (MASKED.BRUSH 19778 . 21821) (MOVE.BITMAP 21823 . 22697) (MOVE.BITMAP1 22699 . 23986) (NOTEPAD 23988 . 25600) ( NOTEPAD.ADD.TO.BACKGROUND.MENU 25602 . 26154) (NOTEPAD.BUTTONEVENTFN 26156 . 26510) (NOTEPAD.BUTTONFN 26512 . 29636) (NOTEPAD.CIRCLE 29638 . 30656) (NOTEPAD.COMMAND.MENU 30658 . 30895) ( NOTEPAD.COMMAND.MENU.CREATE 30897 . 32145) (NOTEPAD.COOKIE.CUT 32147 . 32621) ( NOTEPAD.COPY.FROM.SCREEN 32623 . 33274) (NOTEPAD.CURVE 33276 . 34973) (NOTEPAD.DEFINE.BRUSH 34975 . 35711) (NOTEPAD.DEFINE.FONT 35713 . 36137) (NOTEPAD.HELP 36139 . 36712) (NOTEPAD.READ.FONT 36714 . 37852) (NOTEPAD.FONTS.IN.CORE 37854 . 38447) (READ.NOTEPAD.STYLE 38449 . 38931) (NOTEPAD.DEFINE.GRID 38933 . 39473) (NOTEPAD.DEFINE.GRID1 39475 . 40799) (NOTEPAD.DEFINE.MASK 40801 . 41527) ( NOTEPAD.DELETE.STYLE 41529 . 42226) (NOTEPAD.EDIT.BRUSH 42228 . 42696) (NOTEPAD.EDIT.MASK 42698 . 43159) (NOTEPAD.EDIT.RECTANGLE 43161 . 45615) (NOTEPAD.EDIT.SHADE 45617 . 46392) (NOTEPAD.ELLIPSE 46394 . 47988) (NOTEPAD.LINE 47990 . 48702) (NOTEPAD.MASK=BRUSH.OUTLINE 48704 . 49283) ( NOTEPAD.NAMED.OBJECT 49285 . 50004) (NOTEPAD.POINT.OF.SYMMETRY 50006 . 50496) (NOTEPAD.RESTORE.STYLE 50498 . 51351) (NOTEPAD.SETUP.TO.PAINT 51353 . 57013) (NOTEPAD.SHADE.RECTANGLE 57015 . 58029) ( NOTEPAD.SKETCH 58031 . 59169) (NOTEPAD.SKETCH1 59171 . 62806) (NOTEPAD.TEXT 62808 . 63931) ( NOTEPAD.USE.GRID 63933 . 66769) (NOTEPAD.USE.MASK 66771 . 67316) (NOTEPAD.USE.SYMMETRIC.BRUSH/MASK 67318 . 68113) (NOTEPAD.USE.SYMMETRY 68115 . 68689) (NOTEPAD.FILL 68691 . 71396) (NOTEPAD.CONFIRM 71398 . 71790) (NOTEPAD.CREATE 71792 . 74146) (NOTEPAD.DEFAULT.CHARACTERISTICS 74148 . 75946) ( NOTEPAD.GETPOSITION 75948 . 76861) (NOTEPAD.MASK 76863 . 77989) (NOTEPAD.ON.GRID 77991 . 78560) ( NOTEPAD.ON.GRID.X 78562 . 79054) (NOTEPAD.OPERATION 79056 . 79249) (NOTEPAD.SOLID.AREA 79251 . 79746) (BITMAP.EXTERIOR 79748 . 80975) (NOTEPAD.TITLEBUTTONFN 80977 . 83094) (PAINT.A.BITMAP 83096 . 84815) ( PAINT.ALL.BITMAPS 84817 . 88811) (PAINT.AT.POSSIBLE.POINT 88813 . 89779) (PAINT.WITH.BITMAP 89781 . 93856) (PICKUP.BITMAP 93858 . 94970) (PICKUP.SCREEN.BITMAP 94972 . 95647) (READ.FROM.PROMPT.WINDOW 95649 . 95838) (PUTBACK.BITMAP 95840 . 96223) (PUTDEF.NOTEPAD.STYLE 96225 . 96524) (SAVE.STYLE 96526 . 97347) (SBIT 97349 . 97519) (TEST.AND.SET 97521 . 98087)) (98090 100102 (GET.WINDOW.REGION 98100 . 99501) (GETCOLORPOSITION 99503 . 99893) (COLORBITMAPP 99895 . 100100))))) STOP \ No newline at end of file diff --git a/lispusers/NOTEPAD-CORESTYLES b/lispusers/NOTEPAD-CORESTYLES new file mode 100644 index 00000000..14a4c6a3 --- /dev/null +++ b/lispusers/NOTEPAD-CORESTYLES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Sep-88 20:43:32" {ERINYES}MEDLEY>NOTEPAD-CORESTYLES.;2 66509 changes to%: (VARS NOTEPAD-CORESTYLESCOMS) previous date%: "26-JAN-83 16:18:51" {ERINYES}MEDLEY>NOTEPAD-CORESTYLES.;1) (PRETTYCOMPRINT NOTEPAD-CORESTYLESCOMS) (RPAQQ NOTEPAD-CORESTYLESCOMS ((NOTEPADSTYLE BALL BlueDot CIS FIGURES FISH GreenDot Interlisp-D PIPELINE RING RedDot SouthAm TWODOT XEROX ALBERT))) (PUTDEF (QUOTE BALL) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(123 114)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@HGB@@@@@@@@@@@@@@@@@@@@@@@@@@@A@HCG@F@@@@@@@@@@@@@@@@@@@@@@@@@@NI@OD@@@@@@@@@@@@@@@@@@@@@@@@@AEN@DACHF@@@@@@@@@@@@@@@@@@@@@@BH@@@K@CJFJH@@@@@@@@@@@@@@@@@@@@@D@LAC@AD@ED@@@@@@@@@@@@@@@@@@@BB@LMH@KA@@@C@@@@@@@@@@@@@@@@@@@@HJN@BBC@A@KCL@@@@@@@@@@@@@@@@@@HL@@L@CMA@JKDA@@@@@@@@@@@@@@@@@D@L@E@@LCJHB@@D@@@@@@@@@@@@@@@@@DABBA@BADI@JO@@L@@@@@@@@@@@@@@@AE@@DD@AE@B@@CHCH@@@@@@@@@@@@@@@BHBAFBL@@@AH@DBCK@@@@@@@@@@@@@@@FIBDLMH@@IIDH@GECH@@@@@@@@@@@@@A@N@NDABHDKB@@IH@OH@@@@@@@@@@@@@@MH@@DD@@@DIILM@EIC@@@@@@@@@@@@@DA@FC@FEBH@F@@AH@@C@@@@@@@@@@@@@LDEBCJADD@BC@HB@BHMH@@@@@@@@@@@@DJH@ADAL@@@HB@ANDAN@@@@@@@@@@@@@DJ@@DB@LD@@B@@MDAJ@G@@@@@@@@@@@A@GD@BBCAAOB@AJ@CC@@KH@@@@@@@@@@@ICB@A@@JB@@J@AA@D@OIL@@@@@@@@@@AHGC@HC@EBH@BCE@B@B@IH@@@@@@@@@@@DAH@F@@@H@DFHM@JALDIH@@@@@@@@@@N@H@NBH@BB@FBALCHE@DHC@@@@@@@@@@@M@D@BBADBCAMJ@ALBBMHC@@@@@@@@@@D@JDFBHD@@HBB@@J@B@@HHH@@@@@@@@B@@L@E@@M@@@@@DDBF@JN@AL@@@@@@@@DLGDHIJA@EB@ABF@AAF@NDHL@@@@@@@@IIA@HAMFDJ@AJGEBHHAIEHDN@@@@@@@@D@DBAAAN@@@@BO@AKBGACF@H@@@@@@@@HBMFDBBACB@HA@@LBB@HCLHH@@@@@@@@KBBG@@DACAK@AEB@FB@BF@CM@@@@@@@@@@AFLDL@HBA@FCBBL@HJCFAM@@@@@@@AHBA@L@BK@BF@@C@@CDDHFGD@@@@@@@@BBIEAKBAAD@I@@EA@BAF@JHDHH@@@@@@AELIADBHI@AKCAHBFB@BF@BE@@@@@@@@AI@DG@BD@DHAKCAJEDA@EIAABD@@@@@@ANHABD@FJBJ@EOCIFKABJ@@KBD@@@@@@@LDIBB@IG@DAKACBBAHJD@F@LD@@@@@@L@GJBEE@ED@@AMI@II@@DLG@@@@@@@@@@NHCF@@L@I@IEEN@DMCEBH@JAB@@@@@@BH@BDAJIIOCBFMHLHFAHOIIODN@@@@@@DFEFEIAHBMFFB@HI@@IB@AB@AH@@@@@@IBEL@HJF@NBF@IEJ@DAJL@AE@@@@@@@@IL@HIOD@CLJHFIEDDH@@MDBDKG@@@@@AEIF@HJFBMBDEIEHLBFBMIMCHK@@@@@@@@JDM@HEFENLC@@BBAAAJB@EA@L@@@@@@HH@DEJEO@LCCDDHD@@@D@A@ABC@@@@@@M@FBHJ@LHICLBBGDA@@@FJ@@JL@@@@@@@@L@OA@MD@BK@BALDCHJB@CBHA@@@@@@DIAC@LALJ@JJF@@HCB@NKA@DH@@@@@@@EAAIHHLHBBNLFBDLD@FJF@IN@D@@@@@ABEAJCFMBCE@@AGADHHAIDDAJE@@@@@@AGBCBCCLAB@HLEAKDH@BA@BFHFH@@@@@AJDHABMMDCLOLHDKHLKDGD@A@@@@@@@@ANHIDFKIIFN@LNDBBCA@FBLAACN@@@@@@FDDBA@HGMNHGFJGN@MEHB@J@DD@@@@@@@KIABDDACH@FFAEJOECFEA@@DF@@@@@@HD@C@DA@@HI@DEADDNLCKKFAFD@@@@@@AAMC@AJCOBCHMANANHBMD@GDA@@@@@@@J@G@AKBKBKEBMHKCBHIAICBHHJ@@@@@@EE@JCBFHODGFEGNJANLONHCI@@@@@@@@DMHMHLMDKLOCLNNNIKMKIOFMAF@@@@@@DL@IHA@CCCBACOFNHC@ADEMJMN@@@@@@ANJACIGBEOMGJNIMKKENAFEJOL@@@@@@B@IABAJMJ@IJBGMCGNGLMNMNHD@@@@@@ACHI@DA@@FCEGOOOMOFNOFJAA@@@@@@@BHAC@EJE@JGIFLGAGLIBMKCOD@@@@@@@@KB@LEAH@JGENBHKOAODOCOEO@@@@@@@BAMDACHFALDEIFJECLOFDMBFHH@@@@@@ACHFJLHJEAIHKIJEEOOK@ALMG@@@@@@@@H@KILAIOMGJEOJ@@OBJMOFGD@@@@@@@AGHD@HCMO@FKDFHDMMGECKIGC@@@@@@@@@@@NFIFJMEA@CDFHEEOGNEKJ@@@@@@@@@AAAJHADB@LIAE@EENIFE@IB@@@@@@@@CHAHA@AFJCCBDLMLCIOCMCI@@@@@@@@@DAOLCAIFAGE@JLDAHEHIILOH@@@@@@@@@AJHOHM@LKIEHHIFCIKGJEF@@@@@@@@@@F@J@KBEEBLIHDHCDEHF@MC@@@@@@@@@@GCIAEBDCDA@AE@BEEFAIKB@@@@@@@@@@DHMHM@@OCHIBL@D@ID@MJB@@@@@@@@@@@CJEMNDBAAFFLFM@DO@KHD@@@@@@@@@@AD@IEIACCHD@A@JN@KIBDD@@@@@@@@@@@CLHJAGLHGHMFC@BDLIJI@@@@@@@@@@@AHDJE@L@JH@LC@IBAAGAN@@@@@@@@@@@@BNAH@DHBHAG@L@HDFIBL@@@@@@@@@@@@@BAIE@DG@C@A@GJBAJ@@@@@@@@@@@@@@FHMJAIDAM@@J@C@FDIAD@@@@@@@@@@@@BFLBML@CDANG@@A@EJ@@@@@@@@@@@@@@AMLBMBCE@A@A@D@@ME@@@@@@@@@@@@@@@ACAACAHA@@A@AB@B@L@@@@@@@@@@@@@@@CMB@DLI@IC@@@BHI@@@@@@@@@@@@@@@A@D@@DBDBI@DCEAC@@@@@@@@@@@@@@@@@HMN@CGD@DHDBCF@F@@@@@@@@@@@@@@@@BMA@IMJ@@EJCJFC@@@@@@@@@@@@@@@@@@E@H@DDI@@DDADD@@@@@@@@@@@@@@@@@@BMCDBMNLCO@BFH@@@@@@@@@@@@@@@@@@B@JBFLBNDFLF@@@@@@@@@@@@@@@@@@@@@HJI@K@@DMC@H@@@@@@@@@@@@@@@@@@@@@@LLH@LH@J@@@@@@@@@@@@@@@@@@@@@@@CDD@DH@D@H@@@@@@@@@@@@@@@@@@@@@@@CID@EF@B@@@@@@@@@@@@@@@@@@@@@@@@@EB@LHH@@@@@@@@@@@@@@@@@@@@@@@@@@@AM@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ MASK.DEFINITION #*(123 114)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOON@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOON@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOON@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOON@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOON@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOON@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOON@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@OOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@OOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (204 . 165) SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE BlueDot) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(12 3)@A@@AAA@@A@@ MASK.DEFINITION #*(12 3)@O@@OOO@@O@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (320 . 240) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 2 BITS.PER.PIXEL 4)) (PUTDEF (QUOTE CIS) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(77 35)@@@GOO@@@@@@@AOO@@@@@@COOOOMOOOO@OOOOG@@@@O@@GOOOOOOKL@GOOH@@AH@@@ML@@@GN@@@GGL@@F@@F@AO@@AOH@C@@GL@@L@AOLAOH@CO@@GN@GL@A@@CONAOH@CO@@OOHGL@A@@GOOAOH@CN@@OOLGL@B@@GOOAOH@CN@@OONGL@D@@OLAIOH@CN@@GLNGL@D@@OLAIOH@CN@@GNCGL@D@@OH@OOH@CN@@AOKOL@H@AOH@OOH@CN@@@OOOL@H@AOH@GNH@CO@@@COOH@H@AO@@CLH@CO@@@@OO@@H@AO@@@@H@COH@@@CO@@H@AO@@@@H@COL@@@@OH@H@AO@@@@H@CNN@@@@GL@H@AO@@@@H@CNOH@@@CN@H@AO@@@@H@COON@@@AO@H@@OH@@@H@CNOOH@@AO@L@@OH@@@H@CNGON@@@OHL@@OH@@@H@CNGOO@@@OHD@@GL@CLH@CNCNOH@@OHF@@GL@ONH@CNCNCH@AOHG@@COCIOH@CNAO@L@AOHC@@AONAOH@CN@OLL@AO@AL@@GHCOH@CN@GOL@CO@AN@@@@GO@@AN@AOH@GO@@OH@@AOL@@@FF@@@@ON@@GO@@OOOOOOOOL@@GOL@@AOOOOOOOOOOOOOOOOH@@@OOOOOCOOOOOOOOOO@@@@COOOLAOOOOOOOOON@@@@@GON@@@@@@@AOOO@@@ MASK.DEFINITION #*(77 35)@@@GOO@@@@@@@AOO@@@@@@COOOOMOOOO@OOOOG@@@@OOOOOOOOOOKOOOOOH@@AOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOL@@OOOOOOOOOOOOOOOOOL@AOOOOOOOOOOOOOOOOOL@AOOOOOOOOOOOOOOOOOL@COOOOOOOOOOOOOOOOOL@GOOOLAOOOOOOOOOLOOL@GOOOLAOOOOOOOOONCOL@GOOOH@OOOOOOOOOOKOL@OOOOH@OOOOOOOOOOOOL@OOOOH@GNOOOOOOOOOOH@OOOO@@CLOOOOOOOOOO@@OOOO@@@@OOOOOOOOOO@@OOOO@@@@OOOOOOOOOOH@OOOO@@@@OOONOOOOOOL@OOOO@@@@OOONOOOOOON@OOOO@@@@OOOOOOOOOOO@OOOOH@@@OOOOOOOOOOO@OOOOH@@@OOOOOOOOOOOHOOOOH@@@OOOOOOOOOOOHGOOOL@CLOOOOONOOOOOHGOOOL@ONOOOOONCOOOOHGOOOOCOOOOOOOO@OOOOHCOOOOOOOOOOOOOLOOOO@AOOOOOOOOOOOOOOOOOO@AOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOOL@@AOOOOOOOOOOOOOOOOH@@@OOOOOCOOOOOOOOOO@@@@COOOLAOOOOOOOOON@@@@@GON@@@@@@@AOOO@@@ USE.MASK T PRINTING.FONT.DEFINITION (TIMESROMAND 36 (MEDIUM REGULAR REGULAR)) GRID.DEFINITION (259 53 19 10) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (100 . 100) SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE FIGURES) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(3 3)@@@@D@@@@@@@ MASK.DEFINITION #*(3 3)N@@@N@@@N@@@ USE.MASK NIL PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (100 . 100) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE FISH) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(53 28)@@@@@@@AH@@@@@@@@@@@@@@O@@@@D@@@@@@@@GOJ@@@@N@@@@@@AOL@F@@@AJ@@@@@@O@CND@@@CB@@@@@GH@@AD@@@FC@@@@@L@@@@L@@@DA@@@@C@@@@@B@@@HA@@@@F@@@@@C@@AHC@@@@L@@@@@AL@F@N@@@AH@DH@@@GOLCC@@@A@NFL@@@@@ALA@@@C@NCB@@@@@@@A@@@F@NAB@@@@@@@A@@@D@@AB@@@@@AOJ@@@H@@ABAC@@@@@N@@@H@@ABCAH@@@DA@@@F@@CBB@H@@@G@H@@CN@FFB@LGOHAMH@@AKHLLF@GLAO@G@@@@LNAHGOOH@ALC@@@@FC@@@@C@@@DA@@@@AH@@@@F@@@BA@@@@@N@@@@J@@@CC@@@@@CH@@CAH@@AB@@@@@@N@@D@D@@AF@@@@@@AOOL@B@@AL@@@@@@@@@GOO@@@L@@@ MASK.DEFINITION #*(53 28)@@@@@@@AH@@@@@@@@@@@@@@O@@@@D@@@@@@@@GON@@@@N@@@@@@AOOON@@@AN@@@@@@OOOOL@@@CN@@@@@GOOOOL@@@GO@@@@@OOOOOL@@@GO@@@@COOOOON@@@OO@@@@GOOOOOO@@AOO@@@@OOOOOOOL@GON@@@AOOOOOOOOOOOO@@@AOOOOOOOOOOOO@@@COOOOOOOOOOOO@@@GOOOOOOOOOOOO@@@GOOOOOOOOOOON@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@GOOOOOOOOOOOOH@@COOOOOOOOOOOOH@@AOOOOOOOLAOOO@@@@OOOOOOOH@AOO@@@@GOOOOOO@@@GO@@@@AOOOOON@@@CO@@@@@OOOOON@@@CO@@@@@COOOOOH@@AN@@@@@@OOOOOL@@AN@@@@@@AOOOON@@AL@@@@@@@@@GOO@@@L@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 10 (BOLD REGULAR REGULAR)) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (100 . 100) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE GreenDot) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(12 3)@B@@BBB@@B@@ MASK.DEFINITION #*(12 3)@O@@OOO@@O@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (320 . 240) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 2 BITS.PER.PIXEL 4)) (PUTDEF (QUOTE Interlisp-D) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(73 25)@@@@@@COOOON@@@@@@@@@@@@AOL@@@@AOL@@@@@@@@@AN@@@@@@@@CL@@@@@@@AN@@@@@@@@@@CL@@@@@@N@@@@@@@@@@@@CH@@@@C@@@@@@@@@@@@@@F@@@@D@@@@@@@@@@@@@@A@@@AH@@@@@@@@@@@@@@@L@@B@@@@@@@@F@@@@@@@B@@DF@@@@@@CF@@@@@OLA@@DF@@L@@@C@@@@@@LFA@@HFOIOCLOKFGKN@@LF@H@HFLLLFFMKFLKCCNLF@H@HFLLLGNLCFNCCCNLF@H@DFLLLF@LCFCKC@@LFA@@DFLLLFFLCFIKC@@LFA@@BFLLGCLLCFOCN@@OLB@@AH@@@@@@@@@C@@@@@L@@@D@@@@@@@@@C@@@@A@@@@C@@@@@@@@@C@@@@F@@@@@N@@@@@@@@@@@@CH@@@@@AN@@@@@@@@@@CL@@@@@@@AN@@@@@@@@CL@@@@@@@@@AOL@@@@AOL@@@@@@@@@@@@COOOON@@@@@@@@ MASK.DEFINITION #*(73 25)@@@@@@COOOON@@@@@@@@@@@@AOOOOOOOOL@@@@@@@@@AOOOOOOOOOOL@@@@@@@AOOOOOOOOOOOOL@@@@@@OOOOOOOOOOOOOOH@@@@COOOOOOOOOOOOOON@@@@GOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOL@@COOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@GOOOOOOOOOOOOOOOOO@@GOOOOOOOOOOOOOOOOO@@COOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOO@@@@COOOOOOOOOOOOOON@@@@@OOOOOOOOOOOOOOH@@@@@AOOOOOOOOOOOOL@@@@@@@AOOOOOOOOOOL@@@@@@@@@AOOOOOOOOL@@@@@@@@@@@@COOOON@@@@@@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 10 (BOLD REGULAR REGULAR)) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (100 . 100) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE PIPELINE) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(59 14)@OL@AOH@CO@@GN@@CHG@G@N@NALALCH@F@AHL@CAH@FC@@L@F@AHL@CAH@FC@@L@L@@MH@AK@@CF@@F@L@@MH@AK@@CF@@F@L@@MH@AK@@CF@@F@L@@MH@AK@@CF@@F@L@@MH@AK@@CF@@F@L@@MH@AK@@CF@@F@F@AHL@CAH@FC@@L@F@AHL@CAH@FC@@L@CHG@G@N@NALALCH@@OL@AOH@CO@@GN@@ MASK.DEFINITION #*(59 14)@OL@AOH@CO@@GN@@COO@GON@OOLAOOH@GOOHOOOAOONCOOL@GOOHOOOAOONCOOL@OOOMOOOKOOOGOON@OOOMOOOKOOOGOON@OOOMOOOKOOOGOON@OOOMOOOKOOOGOON@OOOMOOOKOOOGOON@OOOMOOOKOOOGOON@GOOHOOOAOONCOOL@GOOHOOOAOONCOOL@COO@GON@OOLAOOH@@OL@AOH@CO@@GN@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (266 . 142) SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE RING) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(153 153)@@@@@@@@@@@@@@@@@HGJ@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@B@ILC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@EHAMCED@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@F@IH@J@BJ@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@FFL@EHH@@AK@@@@@@@@@@@@@@@@@@@@@@@@@@@DEG@AAAH@HEIN@H@@@@@@@@@@@@@@@@@@@@@@@@@F@@F@ANHHEEJ@H@@@@@@@@@@@@@@@@@@@@@@@@@@F@C@NDAMDA@@B@E@@@@@@@@@@@@@@@@@@@@@@@B@IBA@FN@LHEGH@FHB@@@@@@@@@@@@@@@@@@@@@@JH@AMBANH@@@ALALCD@@@@@@@@@@@@@@@@@@@@@CDABKL@HBG@L@BAAMJ@@@@@@@@@@@@@@@@@@@@@@CDM@@@AF@GDME@CJILAO@@@@@@@@@@@@@@@@@@@@HF@HAHBF@BH@JHL@GLDA@@@@@@@@@@@@@@@@@@@DFLDAIK@AFB@@@FHBLIHIC@@@@@@@@@@@@@@@@@@F@AAEL@DDF@BAFGL@@AHI@@@@@@@@@@@@@@@@@@AFAAH@AH@GJBAEFHBADFMK@D@@@@@@@@@@@@@@@@@BHAH@J@AHGE@D@@HB@O@AAA@@@@@@@@@@@@@@@@FBHBDDB@DBIBAEN@AHM@CL@CH@@@@@@@@@@@@@@@FJJ@@HLCI@@D@@G@GAH@ELIAL@@@@@@@@@@@@@@C@E@DBHDAKHCC@@HDGF@GLO@IL@@@@@@@@@@@@@@@DMBDHGDHGJ@@I@@NJGA@DLLAB@@@@@@@@@@@@@@BJAL@JO@B@ILC@AC@AO@BDLIAA@@@@@@@@@@@@@A@AKAD@@@EHAMCEEJ@KBFBDAHGJH@@@@@@@@@@@@BDHB@B@F@IH@J@BJC@@@FFLALCJ@@@@@@@@@@@@@@CHIA@FFL@EHH@@AH@EAK@DDFH@@@@@@@@@@@@@@EDIDDEG@AAAH@HEIOLHCLC@@NIAJ@@@@@@@@@@@@@@IDF@@F@ANHHEEJ@HCD@OBDFJ@OD@@@@@@@@@@A@BB@F@BH@FAMDA@@BBF@AGLBGBDH@@@@@@@@@@@@CAB@IA@HA@JDHEGH@FHAOCK@DFDM@@@@@@@@@@@BKCJH@BB@@JHA@@@@AL@DACFDDAHLK@@@@@@@@@@@@ADA@KAFALH@@@@@@AKHIC@ANH@@K@@@@@@@@@A@AKDIBFDB@ML@@@@@@@@@I@HGBAI@@L@@@@@@@@@HHHG@G@CJDC@@@@@@@@@ELCI@G@FHC@@@@@@@@@@A@FL@@EGHA@@@@@@@@@@@DAKHCD@@@@@@@@@@@@@EF@HCJ@@@B@@@@@@@@@@@@NDB@@HF@C@@@@@@@@I@NBBHA@C@@@@@@@@@@@@@@FN@LC@FJK@@@@@@@@CEBEDHHCCF@@@@@@@@@@@@@FD@@CEDED@@@@@@@@@BBE@BBKH@@@@@@@@@@@@@@@N@LLBJ@C@@@@@@@AA@HCJC@@C@@@@@@@@@@@@@@@D@@AEAKCL@@@@@@@DDDI@C@AD@@@@@@@@@@@@@@@B@LLBIOD@@@@@@@DF@LA@DHHD@@@@@@@@@@@@@@@@H@AEF@HD@@@@@@@F@BED@AAH@@@@@@@@@@@@@@@@G@LBKJ@@@@@@@@@IG@J@HEH@@@@@@@@@@@@@@@@@AHMEFBFCH@@@@@H@@EJDI@H@@@@@@@@@@@@@@@@@@@@JKHLCH@@@@@A@BDCHCD@@@@@@@@@@@@@@@@@@@AH@FCII@@@@@@IA@CF@@B@@@@@@@@@@@@@@@@@@@IJJGHALL@@@@C@BG@DAA@@@@@@@@@@@@@@@@@@@@@AE@CJL@@@@@@BDOAADDD@@@@@@@@@@@@@@@@@@@@@@LHAAH@@@@@@JABJDF@@@@@@@@@@@@@@@@@@@@@BLOAJAH@@@@BHDABJ@F@@@@@@@@@@@@@@@@@@@@@JM@GAFM@@@@D@EDAJ@I@@@@@@@@@@@@@@@@@@@@@H@AAF@@@@@@DA@BDJH@@@@@@@@@@@@@@@@@@@@@@AL@CGFCH@@@E@LFADA@@@@@@@@@@@@@@@@@@@@@@AF@NC@H@@@@HC@ACDIB@@@@@@@@@@@@@@@@@@@@@BJHNL@G@@@@IBKHHG@D@@@@@@@@@@@@@@@@@@@@@@AIDLJO@@@@N@HBFL@@@@@@@@@@@@@@@@@@@@@@@@INCD@@@@@AH@AB@HC@@@@@@@@@@@@@@@@@@@@@@@J@HB@F@@@A@DHFBBH@@@@@@@@@@@@@@@@@@@@@@@@CA@FFL@@@FGCBEDD@@@@@@@@@@@@@@@@@@@@@@@D@DEG@@@@BJBFBEB@@@@@@@@@@@@@@@@@@@@@@@@BDF@@F@@@BJI@HCJ@@@@@@@@@@@@@@@@@@@@@@@@B@F@BH@@@CDB@DIJH@@@@@@@@@@@@@@@@@@@@@@@B@IA@H@@@CDJLLCD@@@@@@@@@@@@@@@@@@@@@@@@@H@BB@@@@@G@@BCDH@@@@@@@@@@@@@@@@@@@@@@@@A@KAF@@@FLFG@HG@@@@@@@@@@@@@@@@@@@@@@@@@IBFFL@@@@HH@FFL@@@@@@@@@@@@@@@@@@@@@@@@@@GB@ID@@BBDBB@H@@@@@@@@@@@@@@@@@@@@@@@@@@@BB@@@@EFE@FBBH@@@@@@@@@@@@@@@@@@@@@@@@CAHCBI@@EDFFBED@@@@@@@@@@@@@@@@@@@@@@@@@AAM@JB@@BLDLBEA@@@@@@@@@@@@@@@@@@@@@@@@@@@J@N@@@JCB@HCJ@@@@@@@@@@@@@@@@@@@@@@@@@@BA@FB@@AHD@DIF@@@@@@@@@@@@@@@@@@@@@@@@@@AAAHHH@H@EHLC@@@@@@@@@@@@@@@@@@@@@@@@@@@@H@EA@@HI@@B@L@@@@@@@@@@@@@@@@@@@@@@@@@@DAHBI@@IFLG@D@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@@D@@ICA@FLD@@@@@@@@@@@@@@@@@@@@@@@@@CAD@AA@@@LJB@DJ@@@@@@@@@@@@@@@@@@@@@@@@@@AA@JA@@B@M@@DJ@@@@@@@@@@@@@@@@@@@@@@@@@CADB@@@@@HNFA@F@@@@@@@@@@@@@@@@@@@@@@@@@BH@FH@@@IHDLHIB@@@@@@@@@@@@@@@@@@@@@@@@@@M@HBI@@@NB@AHD@@@@@@@@@@@@@@@@@@@@@@@@@@NKBE@@@HHDA@DD@@@@@@@@@@@@@@@@@@@@@@@@@@HO@@@@@BAEHN@L@@@@@@@@@@@@@@@@@@@@@@@@@AA@II@@@AB@@@MD@@@@@@@@@@@@@@@@@@@@@@@@@@B@IHMH@CDL@D@D@@@@@@@@@@@@@@@@@@@@@@@@@BF@DA@H@@EAB@A@@@@@@@@@@@@@@@@@@@@@@@@@@@AEHAC@@DJJLL@H@@@@@@@@@@@@@@@@@@@@@@@@@A@HJ@D@@A@LIIAH@@@@@@@@@@@@@@@@@@@@@@@@@ADDH@M@@@DOD@@D@@@@@@@@@@@@@@@@@@@@@@@@@AB@BD@@@@DFHBN@@@@@@@@@@@@@@@@@@@@@@@@@@@CEAE@@@@F@KB@M@@@@@@@@@@@@@@@@@@@@@@@@@@DKHB@@@B@F@@D@@@@@@@@@@@@@@@@@@@@@@@@@@BHBJ@@@@@AEHB@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@DHD@@AJBBLLD@@@@@@@@@@@@@@@@@@@@@@@@@MDLOIH@@@LIEIICH@@@@@@@@@@@@@@@@@@@@@@@@HLAFKB@@@DIID@@@@@@@@@@@@@@@@@@@@@@@@@@@EC@GAB@@@JINHBA@@@@@@@@@@@@@@@@@@@@@@@@AJ@ANED@@A@@LKBH@@@@@@@@@@@@@@@@@@@@@@@@ACAFIB@@@@DL@@AC@@@@@@@@@@@@@@@@@@@@@@@@@BKBOF@@@@F@MHBFD@@@@@@@@@@@@@@@@@@@@@@@ABOHFAH@@@@BJBI@@@@@@@@@@@@@@@@@@@@@@@@@A@FDDIH@@@BDEEJ@J@@@@@@@@@@@@@@@@@@@@@@@@HFJ@A@@@@BIAIBLH@@@@@@@@@@@@@@@@@@@@@@@F@NE@E@@@@@IINH@A@@@@@@@@@@@@@@@@@@@@@@@DFDAAG@@@@CEHLF@J@@@@@@@@@@@@@@@@@@@@@@@KFIAJH@@@@@@L@HJE@@@@@@@@@@@@@@@@@@@@@@@IN@I@D@@@@BH@NEGB@@@@@@@@@@@@@@@@@@@@@@AFNJANF@@@@@MBHFDBL@@@@@@@@@@@@@@@@@@@@@CELLKG@@@@@@@DFGJ@@@@@@@@@@@@@@@@@@@@@@@@HDCNOD@@@@@DIBCAF@@@@@@@@@@@@@@@@@@@@@@ABB@IL@@@@@@DIO@AHJ@@@@@@@@@@@@@@@@@@@@@HB@H@D@@@@@@CEHCJEG@@@@@@@@@@@@@@@@@@@@@H@MAOI@@@@@@F@HJ@FD@@@@@@@@@@@@@@@@@@@@@@MIEIE@@@@@@BHIAHGJD@@@@@@@@@@@@@@@@@@@AAICDGJ@@@@@@BMBDHCAB@@@@@@@@@@@@@@@@@@@FLFFJEN@@@@@@@@BGC@AC@@@@@@@@@@@@@@@@@@@DL@HAIH@@@@@@@DMFDCJCH@@@@@@@@@@@@@@@@@@@ILKIBL@@@@@@@E@BHJ@AH@@@@@@@@@@@@@@@@@@HI@MFM@@@@@@@@BBBAAIH@@@@@@@@@@@@@@@@@@DDHB@H@@@@@@@@@GCDBDHAM@@@@@@@@@@@@@@@@@@IHBMBH@@@@@@@@B@@BG@E@D@@@@@@@@@@@@@@@AI@FBHL@@@@@@@@@@IBEFDHLH@@@@@@@@@@@@@@@@NJ@ILC@@@@@@@@@@AD@BIBDI@@@@@@@@@@@@@@@ILCEFDE@@@@@@@@@@LIBBACHB@@@@@@@@@@@@@@AD@ELN@LH@@@@@@@@@ELKDBKBLI@@@@@@@@@@@@@@KLB@DAN@@@@@@@@@@BI@@@ADDN@@@@@@@@@@@@@F@@@GCDJ@@@@@@@@@@AJABEA@JLJ@@@@@@@@@@@@CH@HHMD@@@@@@@@@@@@IADEJ@@EB@@@@@@@@@@@FGAL@L@H@@@@@@@@@@@@BLID@ADD@D@@@@@@@@@AM@B@ONAH@@@@@@@@@@@@AELHIBFHC@H@@@@@@@ADBO@@MDGL@@@@@@@@@@@@@FI@JB@@FBBH@@@@@ADEH@@C@E@D@@@@@@@@@@@@@GJBDJBDHADCJ@@@A@E@N@BCILHH@@@@@@@@@@@@@AIBNDBHHFBD@ODODILILG@BDFL@@@@@@@@@@@@@@@BODIIBHHMBE@E@ED@D@HCLAMB@@@@@@@@@@@@@@@ACMAKIAJAE@ILILEIKL@CDJ@D@@@@@@@@@@@@@@@DDLHMBDODAGDADA@NH@@L@AN@@@@@@@@@@@@@@@@@@AGODDNJDBEHEIIL@@HNGLB@@@@@@@@@@@@@@@@AE@HCBBCEBG@O@ND@EL@IAID@@@@@@@@@@@@@@@@@FBC@EL@BM@ILILKLB@O@GD@@@@@@@@@@@@@@@@@@AD@DB@D@BOD@D@@@@@MBHC@@@@@@@@@@@@@@@@@@@JJ@HNHJ@@KLKL@@HC@@GH@@@@@@@@@@@@@@@@@@@IKE@CMDF@@@@@AL@CIO@H@@@@@@@@@@@@@@@@@@@AHBJHBHHG@@H@J@OJDFD@@@@@@@@@@@@@@@@@@@@@MBFLBF@HALAL@@MDAM@@@@@@@@@@@@@@@@@@@@@@ABF@BFDHB@N@OC@DJ@@@@@@@@@@@@@@@@@@@@@@@@@OE@ODLL@L@MCILAH@@@@@@@@@@@@@@@@@@@@@@@A@DI@@HNC@C@BDFL@@@@@@@@@@@@@@@@@@@@@@@@@ILDII@ICICILAM@@@@@@@@@@@@@@@@@@@@@@@@@@@@ID@B@BDBDDJ@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@EIHBHALAL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@NC@DJ@J@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AL@G@ANA@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@F@EL@@@@@@@@@@@@@@@@@@@ MASK.DEFINITION #*(153 153)@@@@@@@@@@@@@@@@@OOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOON@@@COOOOOOOOOOOOH@@@@@@@@@OOOOOOOOOOOOL@@@@@AOOOOOOOOOOOH@@@@@@@@AOOOOOOOOOOON@@@@@@@COOOOOOOOOOL@@@@@@@@COOOOOOOOOOO@@@@@@@@@GOOOOOOOOON@@@@@@@@GOOOOOOOOOOH@@@@@@@@@@OOOOOOOOOO@@@@@@@@GOOOOOOOOON@@@@@@@@@@@COOOOOOOOO@@@@@@@@OOOOOOOOOOH@@@@@@@@@@@@OOOOOOOOOH@@@@@@AOOOOOOOOOO@@@@@@@@@@@@@GOOOOOOOOL@@@@@@AOOOOOOOOOL@@@@@@@@@@@@@AOOOOOOOOL@@@@@@COOOOOOOOOH@@@@@@@@@@@@@@OOOOOOOON@@@@@@COOOOOOOON@@@@@@@@@@@@@@@COOOOOOON@@@@@@GOOOOOOOOL@@@@@@@@@@@@@@@AOOOOOOOO@@@@@@GOOOOOOOOH@@@@@@@@@@@@@@@@OOOOOOOO@@@@@@OOOOOOOOO@@@@@@@@@@@@@@@@@GOOOOOOOH@@@@@OOOOOOOOL@@@@@@@@@@@@@@@@@AOOOOOOOH@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@OOOOOOOL@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@OOOOOOOL@@@@COOOOOOOO@@@@@@@@@@@@@@@@@@@GOOOOOON@@@@COOOOOOON@@@@@@@@@@@@@@@@@@@COOOOOON@@@@GOOOOOOOL@@@@@@@@@@@@@@@@@@@AOOOOOOO@@@@GOOOOOOOH@@@@@@@@@@@@@@@@@@@@OOOOOOO@@@@GOOOOOOOH@@@@@@@@@@@@@@@@@@@@OOOOOOO@@@@OOOOOOOO@@@@@@@@@@@@@@@@@@@@@GOOOOOOH@@@OOOOOOON@@@@@@@@@@@@@@@@@@@@@COOOOOOH@@@OOOOOOON@@@@@@@@@@@@@@@@@@@@@COOOOOOH@@AOOOOOOOL@@@@@@@@@@@@@@@@@@@@@AOOOOOOL@@AOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@OOOOOOL@@AOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@OOOOOOL@@COOOOOOO@@@@@@@@@@@@@@@@@@@@@@@GOOOOON@@COOOOOOO@@@@@@@@@@@@@@@@@@@@@@@GOOOOON@@COOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOON@@COOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOON@@COOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOON@@GOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@AOOOOOO@@GOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@AOOOOOO@@GOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@AOOOOOO@@GOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@OOOOOO@@GOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@OOOOOO@@GOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@OOOOOO@@OOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOH@OOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOH@OOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOH@OOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOH@OOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@GOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOO@@GOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOO@@GOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOO@@GOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOO@@GOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOO@@GOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOO@@COOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOON@@COOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOON@@COOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@OOOOON@@COOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@OOOOON@@COOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@OOOOON@@AOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@AOOOOOL@@AOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@AOOOOOL@@AOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@AOOOOOL@@@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@@@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@@@OOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOOH@@@GOOOOOO@@@@@@@@@@@@@@@@@@@@@@@GOOOOO@@@@GOOOOOO@@@@@@@@@@@@@@@@@@@@@@@GOOOOO@@@@GOOOOOOH@@@@@@@@@@@@@@@@@@@@@@OOOOOO@@@@COOOOOOH@@@@@@@@@@@@@@@@@@@@@@OOOOON@@@@COOOOOOL@@@@@@@@@@@@@@@@@@@@@AOOOOON@@@@AOOOOOON@@@@@@@@@@@@@@@@@@@@@COOOOOL@@@@AOOOOOON@@@@@@@@@@@@@@@@@@@@@COOOOOL@@@@@OOOOOOO@@@@@@@@@@@@@@@@@@@@@GOOOOOH@@@@@OOOOOOOH@@@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@GOOOOOOH@@@@@@@@@@@@@@@@@@@@OOOOOO@@@@@@GOOOOOOL@@@@@@@@@@@@@@@@@@@AOOOOOO@@@@@@COOOOOON@@@@@@@@@@@@@@@@@@@COOOOON@@@@@@COOOOOOO@@@@@@@@@@@@@@@@@@@GOOOOON@@@@@@AOOOOOOOH@@@@@@@@@@@@@@@@@@OOOOOOL@@@@@@AOOOOOOOH@@@@@@@@@@@@@@@@@@OOOOOOL@@@@@@@OOOOOOOL@@@@@@@@@@@@@@@@@AOOOOOOH@@@@@@@GOOOOOOO@@@@@@@@@@@@@@@@@GOOOOOO@@@@@@@@GOOOOOOOH@@@@@@@@@@@@@@@@OOOOOOO@@@@@@@@COOOOOOOL@@@@@@@@@@@@@@@AOOOOOON@@@@@@@@AOOOOOOON@@@@@@@@@@@@@@@COOOOOOL@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@OOOOOOOH@@@@@@@@@OOOOOOOOL@@@@@@@@@@@@@AOOOOOOOH@@@@@@@@@GOOOOOOOO@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@COOOOOOOOH@@@@@@@@@@@@OOOOOOON@@@@@@@@@@AOOOOOOOON@@@@@@@@@@@COOOOOOOL@@@@@@@@@@@OOOOOOOOOH@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@GOOOOOOOOO@@@@@@@@@GOOOOOOOO@@@@@@@@@@@@COOOOOOOOON@@@@@@@COOOOOOOON@@@@@@@@@@@@AOOOOOOOOOOL@@@@@AOOOOOOOOOL@@@@@@@@@@@@@OOOOOOOOOOON@@@COOOOOOOOOOH@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOH@@@@@@@@@@@@@@@@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (204 . 165) SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE RedDot) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(12 3)@C@@CCC@@C@@ MASK.DEFINITION #*(12 3)@O@@OOO@@O@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (320 . 240) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 3 BITS.PER.PIXEL 4)) (PUTDEF (QUOTE SouthAm) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(85 124)@@@@G@@@@@@@@@@@@@@@@@@@@@@AON@@@@@@@@@@@@@@@@@@@@@OEOH@@@@@@@@@@@@@@@@@@@AJKJOAOL@@@@@@@@@@@@@@@@CEGEMONL@@@@@@@@@@@@@@@@BJOJJJKL@@@@@@@@@@@@@@@@GEGEEEED@@@@@@@@@@@@@@@ANJJJJJKO@@@@@@@@@@@@@@@CEEEEEEEEH@@@@@@@@@@@@@@BJJJJJJNJL@@@@@@@@@@@@@@CEEEEEEEEF@@@@@@@@@@@@@@AJJJJJJJJO@@@@@@@@@@@@@@AEEEEEEEEEON@@@@@@@@@@@@AJJJJJJJJKJOH@@@@@@@@@@@AEEEEEEEEEEML@@@@@@@@@@@AJJJJJJJJJJJN@@@@@@@@@@@AMEEEEEEEEEEE@@@@@@@@@@@AJJJJJJJJJJJK@@@@@@@@@@@GEEEEEEEEEEEE@@@@@@@@@@@FJJJJJJJJJJJKL@@@@@@@@@@MEEEEEEEEEEEED@@@@@@@@@CJJJJJJJJJJJJJL@@@@@@@@@CEEEEEEEEEEEEEN@@@@@@@@@BJJJJJJJJJJJJKK@@@@@@@@@GEEEEEEEEEEEEGIOH@@@@@@@FJJJJJJJJJJNJOOJN@@@@@@@EEEEEEEEEEEGEEOEF@@@@@@@GJJJJJJJJJJJJJNJKN@@@@@@CEEEEEEEEMEEEEEEGEOH@@@@FJJJJJJJNJJJJJJJJJJL@@@@MEEEEEEEEEEEEEEEEEEF@@@@JJJJJJJJJJJJJJJJJJJKH@@@MEEEEEEEEEEEEEEEEEEEG@@@NJJJJJJJJJJJJJJJJJJJK@@@GEEEEEEEEEEEEEEEEEEMEH@@AJJJJJJJJJJJJJJJJJJJJH@@AEEEEEEEEEEEEEEEEEEEEH@@AJJJJJJJJJJJJJJJJJJJJH@@@MEEEEEEEEEEEEEEEEEEE@@@@FJJJJJJJJJJJJJJJJJJK@@@@CEEEEEEEEEEEEEEEEEEF@@@@BJJJJJJJJJJJJJJJJJJN@@@@CEEEEEEEEEEEEEEEEEEH@@@@AJJJJJJJJJJJJJJJJJKH@@@@@MEEEEEEEEEEEEEEEEE@@@@@@NJJJJJJJJJJJJJJJJN@@@@@@EEEEEEEEEEEEEEEEED@@@@@@FJJJJJJJJJJJJJJJJH@@@@@@GEEEEEEEEEEEEEEEEH@@@@@@BJJJJJJJJJJJJJJJJH@@@@@@AMEEEEEEEEEEEEEEEH@@@@@@@NJOJJJJJJJJJJJJJH@@@@@@@CMGEEEEEEEEEEEEEH@@@@@@@@NJJJJJJJJJJJJJJH@@@@@@@@CEEEEEEEEEEEEEEH@@@@@@@@AJNJJJJJJJJJJJK@@@@@@@@@@MGEEEEEEEEEGEE@@@@@@@@@@JJJJJJJJJJJNJK@@@@@@@@@@MEEEEEEEEEEEEG@@@@@@@@@@JJJJJJJJJJJJJJ@@@@@@@@@@MEEEEEEEEEEMED@@@@@@@@@@JJJJJJJJJJKNJL@@@@@@@@@@MEEEEEEEEEEEEL@@@@@@@@@@JJJJJJJJJKJJOH@@@@@@@@@@MEEEEEEEEGEGO@@@@@@@@@@AJJJJJJJJJKJN@@@@@@@@@@@@MEEEEEEEEEG@@@@@@@@@@@@AJNJJJJJJJJL@@@@@@@@@@@@@MEEEEEEEEEH@@@@@@@@@@@@AJNJJJJJJJK@@@@@@@@@@@@@AGMEEEEEEEE@@@@@@@@@@@@@AJJKJJJJJJK@@@@@@@@@@@@@AEEEMEEMEEE@@@@@@@@@@@@@CJKJJJJJJJK@@@@@@@@@@@@@CEEEEEEEEEG@@@@@@@@@@@@@BJJKJJJJJJL@@@@@@@@@@@@@CEEOEEEEEEL@@@@@@@@@@@@@FJJNJJJJJKH@@@@@@@@@@@@@GEEEGEEEEGH@@@@@@@@@@@@@BJJJJJJJJO@@@@@@@@@@@@@@CEGEEEEEEF@@@@@@@@@@@@@@BJJJJJJOKH@@@@@@@@@@@@@@GEEEEEGOGH@@@@@@@@@@@@@@FJJJJJNJK@@@@@@@@@@@@@@@EEEEEEGEF@@@@@@@@@@@@@@@FJJJJJOOL@@@@@@@@@@@@@@@MEEEEEEH@@@@@@@@@@@@@@@AJJJJJJK@@@@@@@@@@@@@@@@AEEEEEEEH@@@@@@@@@@@@@@@CJJJJJJJH@@@@@@@@@@@@@@@CEEEEEEEH@@@@@@@@@@@@@@@BJJJJJJK@@@@@@@@@@@@@@@@CEEEEEGN@@@@@@@@@@@@@@@@AJJJJKN@@@@@@@@@@@@@@@@@CEEEEG@@@@@@@@@@@@@@@@@@BJJJNJ@@@@@@@@@@@@@@@@@@GOEEGF@@@@@@@@@@@@@@@@@@GNJJLL@@@@@@@@@@@@@@@@@@GMEEGH@@@@@@@@@@@@@@@@@@GJJJOH@@@@@@@@@@@@@@@@@@GMEEGH@@@@@@@@@@@@@@@@@@EJJJL@@@@@@@@@@@@@@@@@@@EOEED@@@@@@@@@@@@@@@@@@@GNJJL@@@@@@@@@@@@@@@@@@@GEGGH@@@@@@@@@@@@@@@@@@AOJKL@@@@@@@@@@@@@@@@@@@ANOED@@@@@@@@@@@@@@@@@@@CMNJKH@@@@@@@@@@@@@@@@@@@NMEEH@@@@@@@@@@@@@@@@@@AOJJKH@@@@@@@@@@@@@@@@@@CMMEG@@@@@@@@@@@@@@@@@@@COJJL@@@@@@@@@@@@@@@@@@@COMED@@@@@@@@@@@@@@@@@@@AOJKH@@@@@@@@@@@@@@@@@@@AOEF@@@@@@@@@@@@@@@@@@@@AOJJ@@@@@@@@@@@@@@@@@@@@AOMG@@@@@@@@@@@@@@@@@@@@@OOO@@@@@@@@@@@@@@@@@@@@@OOMH@@@@@@@@@@@@@@@@@@@@CONH@@@@@@@@@@@@@@@@@@@@AONF@@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@@ MASK.DEFINITION #*(85 124)@@@@G@@@@@@@@@@@@@@@@@@@@@@AON@@@@@@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@@@@@AOOOOAOL@@@@@@@@@@@@@@@@COOOOOOL@@@@@@@@@@@@@@@@COOOOOOL@@@@@@@@@@@@@@@@GOOOOOOL@@@@@@@@@@@@@@@AOOOOOOOO@@@@@@@@@@@@@@@COOOOOOOOH@@@@@@@@@@@@@@COOOOOOOOL@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@@AOOOOOOOOO@@@@@@@@@@@@@@AOOOOOOOOOON@@@@@@@@@@@@AOOOOOOOOOOOH@@@@@@@@@@@AOOOOOOOOOOOL@@@@@@@@@@@AOOOOOOOOOOON@@@@@@@@@@@AOOOOOOOOOOOO@@@@@@@@@@@AOOOOOOOOOOOO@@@@@@@@@@@GOOOOOOOOOOOO@@@@@@@@@@@GOOOOOOOOOOOOL@@@@@@@@@@OOOOOOOOOOOOOL@@@@@@@@@COOOOOOOOOOOOOL@@@@@@@@@COOOOOOOOOOOOON@@@@@@@@@COOOOOOOOOOOOOO@@@@@@@@@GOOOOOOOOOOOOOOOH@@@@@@@GOOOOOOOOOOOOOOON@@@@@@@GOOOOOOOOOOOOOOON@@@@@@@GOOOOOOOOOOOOOOOON@@@@@@COOOOOOOOOOOOOOOOOOH@@@@GOOOOOOOOOOOOOOOOOOL@@@@OOOOOOOOOOOOOOOOOOON@@@@OOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOO@@@@GOOOOOOOOOOOOOOOOOOO@@@@COOOOOOOOOOOOOOOOOON@@@@COOOOOOOOOOOOOOOOOON@@@@COOOOOOOOOOOOOOOOOOH@@@@AOOOOOOOOOOOOOOOOOOH@@@@@OOOOOOOOOOOOOOOOOO@@@@@@OOOOOOOOOOOOOOOOON@@@@@@GOOOOOOOOOOOOOOOOL@@@@@@GOOOOOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOOH@@@@@@AOOOOOOOOOOOOOOOOH@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@@COOOOOOOOOOOOOOOH@@@@@@@@OOOOOOOOOOOOOOOH@@@@@@@@COOOOOOOOOOOOOOH@@@@@@@@AOOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOOO@@@@@@@@@@OOOOOOOOOOOOON@@@@@@@@@@OOOOOOOOOOOOOL@@@@@@@@@@OOOOOOOOOOOOOL@@@@@@@@@@OOOOOOOOOOOOOL@@@@@@@@@@OOOOOOOOOOOOOH@@@@@@@@@@OOOOOOOOOOOOO@@@@@@@@@@AOOOOOOOOOOON@@@@@@@@@@@@OOOOOOOOOOO@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@@OOOOOOOOOOH@@@@@@@@@@@@AOOOOOOOOOO@@@@@@@@@@@@@AOOOOOOOOOO@@@@@@@@@@@@@AOOOOOOOOOO@@@@@@@@@@@@@AOOOOOOOOOO@@@@@@@@@@@@@COOOOOOOOOO@@@@@@@@@@@@@COOOOOOOOOO@@@@@@@@@@@@@COOOOOOOOOL@@@@@@@@@@@@@COOOOOOOOOL@@@@@@@@@@@@@GOOOOOOOOOH@@@@@@@@@@@@@GOOOOOOOOOH@@@@@@@@@@@@@COOOOOOOOO@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@@COOOOOOOOH@@@@@@@@@@@@@@GOOOOOOOOH@@@@@@@@@@@@@@GOOOOOOOO@@@@@@@@@@@@@@@GOOOOOOON@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@@@@@OOOOOOOH@@@@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@@@@@AOOOOOOOH@@@@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@@@@@COOOOOOO@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@AOOOOON@@@@@@@@@@@@@@@@@COOOOO@@@@@@@@@@@@@@@@@@COOOON@@@@@@@@@@@@@@@@@@GOOOON@@@@@@@@@@@@@@@@@@GOOOOL@@@@@@@@@@@@@@@@@@GOOOOH@@@@@@@@@@@@@@@@@@GOOOOH@@@@@@@@@@@@@@@@@@GOOOOH@@@@@@@@@@@@@@@@@@GOOOL@@@@@@@@@@@@@@@@@@@GOOOL@@@@@@@@@@@@@@@@@@@GOOOL@@@@@@@@@@@@@@@@@@@GOOOH@@@@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@@@@@COOOOH@@@@@@@@@@@@@@@@@@@OOOOH@@@@@@@@@@@@@@@@@@AOOOOH@@@@@@@@@@@@@@@@@@COOOO@@@@@@@@@@@@@@@@@@@COOOL@@@@@@@@@@@@@@@@@@@COOOL@@@@@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@@@@@AOON@@@@@@@@@@@@@@@@@@@@AOON@@@@@@@@@@@@@@@@@@@@AOOO@@@@@@@@@@@@@@@@@@@@@OOO@@@@@@@@@@@@@@@@@@@@@OOOH@@@@@@@@@@@@@@@@@@@@COOH@@@@@@@@@@@@@@@@@@@@AOON@@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@@AOO@@@@@@@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (100 . 100) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE TWODOT) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(2 2)L@@@L@@@ MASK.DEFINITION #*(1 1)H@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (204 . 165) SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE XEROX) (QUOTE NOTEPADSTYLE) '(BRUSH.DEFINITION #*(101 101)@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@@@@@@@@OOOOOOOOOH@@@@@@@@@@@@@@@@@COOOMCKOOON@@@@@@@@@@@@@@@@@OONGMOGCOOOH@@@@@@@@@@@@@@@COBGOOOOOKOON@@@@@@@@@@@@@@@OOOONOOOOLIOGH@@@@@@@@@@@@@AOOOOMOLIGOOOCL@@@@@@@@@@@@@GOOCCIKLKOOOOLG@@@@@@@@@@@@@OOHGGOGNCOHCOOKH@@@@@@@@@@@AOLGOOOOOOOOOKOKL@@@@@@@@@@@GOIOOOOOOOOOOOOKO@@@@@@@@@@@OOOOOOOOOOOOOOOGOH@@@@@@@@@AOKONOOOH@@COOOOAML@@@@@@@@@COOOOOOH@@@@CONCKIN@@@@@@@@@GONLOOL@@@@@@GOOIOO@@@@@@@@@ONOMOO@@@@@@@AOOMOOH@@@@@@@@OONEOL@@@@@@@@GOOOOH@@@@@@@AOMOOO@@@@@@@@@AOOCOL@@@@@@@COLOOL@@@@@@@@@@GOCON@@@@@@@GOOOOH@@@@@@@@@@COCOO@@@@@@@GOOOO@@@@@@@@@@@AOKOO@@@@@@@OOOKL@@@@@@@@@@@@GNOGH@@@@@AOIMOH@@@@@@@@@@@@CNOGL@@@@@AOIMO@@@@@@@@@@@@@AOOOL@@@@@COLON@@@@@@@@@@@@@@OOON@@@@@CLOGN@@@@@@@@@@@@@@OOON@@@@@GOOOL@@@@@@@@@@@@@@GOOO@@@@@GOOOH@@@@@@@@@@@@@@COKO@@@@@OMGO@@@@@@@@@@@@@@@AOGOH@@@@OKGO@@@@@@@@@@@@@@@AOGOH@@@AOKGN@@@@@@@@@@@@@@@@OGCL@@@AOOKN@@@@@@@@@@@@@@@@OCOL@@@AONGL@@@@@@@@@@@@@@@@GKML@@@CONOL@@@@@@@@@@@@@@@@GOMN@@@COOOH@@@@@@@@@@@@@@@@COMN@@@CMOOH@@@@@@@@@@@@@@@@COMN@@@GOOO@@@@@@@@@@@@@@@@@ANOO@@@GOIO@@@@@@@@@@@@@@@@@AOOO@@@GOOO@@@@@@@@@@@@@@@@@AOOO@@@GONN@@@@@@@@@@@@@@@@@@OOO@@@GONN@@@@@@@@@@@@@@@@@@ONO@@@GOMN@@@@@@@@@@@@@@@@@@OAO@@@OOON@@@@@@@@@@@@@@@@@@NGOH@@NLOL@OANOONOOL@ONANCL@FOOH@@OOOL@GALOONOONCOOHNCH@FOOH@@OOOL@GKLN@@N@OCLGHOGH@FOOH@@OOOL@CKHN@@N@GGHCLGG@@FOGH@@OOML@COHN@@N@GG@ALGO@@GNOH@@OOOL@AO@OOLN@OG@ALCN@@GNOH@@NOOL@AO@OOLOONG@ALCN@@GOOH@@ONGL@COHN@@OONG@ALGO@@GOOH@@OOCL@CKHN@@N@OG@ALGG@@GOOH@@OOIL@GKLN@@N@GGHCLOGH@GMOH@@OOML@GALN@@N@GCLGHNCH@GOOH@@OOML@OANOONN@GCOOINCL@GOOH@@GOOL@N@NOONN@G@ONALAL@GOO@@@GNON@@@@@@@@@@@@@@@@@@LOO@@@GMON@@@@@@@@@@@@@@@@@@LMG@@@GOON@@@@@@@@@@@@@@@@@@OOO@@@GOON@@@@@@@@@@@@@@@@@@OOO@@@GOOO@@@@@@@@@@@@@@@@@AOOO@@@COOO@@@@@@@@@@@@@@@@@AMNN@@@COOG@@@@@@@@@@@@@@@@@AONN@@@COGGH@@@@@@@@@@@@@@@@COON@@@AOGOH@@@@@@@@@@@@@@@@COOL@@@AOGOL@@@@@@@@@@@@@@@@GHCL@@@AOGOL@@@@@@@@@@@@@@@@GKOL@@@@OOMN@@@@@@@@@@@@@@@@OCOH@@@@OOMN@@@@@@@@@@@@@@@@OGGH@@@@GOMO@@@@@@@@@@@@@@@AOGG@@@@@GOMO@@@@@@@@@@@@@@@AOGO@@@@@COMOH@@@@@@@@@@@@@@COON@@@@@COMOL@@@@@@@@@@@@@@GOGN@@@@@AOMIN@@@@@@@@@@@@@@OOCL@@@@@AOOOF@@@@@@@@@@@@@@NOGL@@@@@@OOGG@@@@@@@@@@@@@AOOGH@@@@@@GOOGH@@@@@@@@@@@@COOO@@@@@@@GOOGL@@@@@@@@@@@@GOOO@@@@@@@COOOO@@@@@@@@@@@AOMON@@@@@@@AOOKOH@@@@@@@@@@CLGOL@@@@@@@@OOKML@@@@@@@@@@GOOOH@@@@@@@@OOKIO@@@@@@@@@AOOOOH@@@@@@@@GOMAOL@@@@@@@@GOOGO@@@@@@@@@COMOOO@@@@@@@AOONGN@@@@@@@@@AOOOGOL@@@@@@GOOOOL@@@@@@@@@@OOOGOOH@@@@COOGCOH@@@@@@@@@@GOOGOGOH@@COOCIOO@@@@@@@@@@@AOOGOGOOOOOOOOOOL@@@@@@@@@@@@OOMOKOOOOOONOOOH@@@@@@@@@@@@GOMOOGOOOOOMOOO@@@@@@@@@@@@@AOLMOGONEOOOOOL@@@@@@@@@@@@@@OOOOKKOMOOOOOH@@@@@@@@@@@@@@COOOOGOLOOOON@@@@@@@@@@@@@@@@OOOO@KOMNCOH@@@@@@@@@@@@@@@@COOOOOOLOON@@@@@@@@@@@@@@@@@@OOOOOOOOOH@@@@@@@@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@ MASK.DEFINITION #*(101 101)@@@@@@@@@@AOOOL@@@@@@@@@@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@@@@@@@@OOOOOOOOOH@@@@@@@@@@@@@@@@@COOOOOOOOON@@@@@@@@@@@@@@@@@OOOOOOOOOOOH@@@@@@@@@@@@@@@COOOOOOOOOOON@@@@@@@@@@@@@@@OOOOOOOOOOOOOH@@@@@@@@@@@@@AOOOOOOOOOOOOOL@@@@@@@@@@@@@GOOOOOOOOOOOOOO@@@@@@@@@@@@@OOOOOOOOOOOOOOOH@@@@@@@@@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@GOOOOOOOOOOOOOOOO@@@@@@@@@@@OOOOOOOOOOOOOOOOOH@@@@@@@@@AOOOOOOOOOOOOOOOOOL@@@@@@@@@COOOOOOOOOOOOOOOOON@@@@@@@@@GOOOOOOOOOOOOOOOOOO@@@@@@@@@OOOOOOOOOOOOOOOOOOOH@@@@@@@@OOOOOOOOOOOOOOOOOOOH@@@@@@@AOOOOOOOOOOOOOOOOOOOL@@@@@@@COOOOOOOOOOOOOOOOOOON@@@@@@@GOOOOOOOOOOOOOOOOOOOO@@@@@@@GOOOOOOOOOOOOOOOOOOOO@@@@@@@OOOOOOOOOOOOOOOOOOOOOH@@@@@AOOOOOOOOOOOOOOOOOOOOOL@@@@@AOOOOOOOOOOOOOOOOOOOOOL@@@@@COOOOOOOOOOOOOOOOOOOOON@@@@@COOOOOOOOOOOOOOOOOOOOON@@@@@GOOOOOOOOOOOOOOOOOOOOOO@@@@@GOOOOOOOOOOOOOOOOOOOOOO@@@@@OOOOOOOOOOOOOOOOOOOOOOOH@@@@OOOOOOOOOOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOL@@@@OOOOOOOOOOOOOOOOOOOOOOOH@@@@OOOOOOOOOOOOOOOOOOOOOOOH@@@@GOOOOOOOOOOOOOOOOOOOOOO@@@@@GOOOOOOOOOOOOOOOOOOOOOO@@@@@COOOOOOOOOOOOOOOOOOOOON@@@@@COOOOOOOOOOOOOOOOOOOOON@@@@@AOOOOOOOOOOOOOOOOOOOOOL@@@@@AOOOOOOOOOOOOOOOOOOOOOL@@@@@@OOOOOOOOOOOOOOOOOOOOOH@@@@@@GOOOOOOOOOOOOOOOOOOOO@@@@@@@GOOOOOOOOOOOOOOOOOOOO@@@@@@@COOOOOOOOOOOOOOOOOOON@@@@@@@AOOOOOOOOOOOOOOOOOOOL@@@@@@@@OOOOOOOOOOOOOOOOOOOH@@@@@@@@OOOOOOOOOOOOOOOOOOOH@@@@@@@@GOOOOOOOOOOOOOOOOOO@@@@@@@@@COOOOOOOOOOOOOOOOON@@@@@@@@@AOOOOOOOOOOOOOOOOOL@@@@@@@@@@OOOOOOOOOOOOOOOOOH@@@@@@@@@@GOOOOOOOOOOOOOOOO@@@@@@@@@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@OOOOOOOOOOOOOOOH@@@@@@@@@@@@GOOOOOOOOOOOOOO@@@@@@@@@@@@@AOOOOOOOOOOOOOL@@@@@@@@@@@@@@OOOOOOOOOOOOOH@@@@@@@@@@@@@@COOOOOOOOOOON@@@@@@@@@@@@@@@@OOOOOOOOOOOH@@@@@@@@@@@@@@@@COOOOOOOOON@@@@@@@@@@@@@@@@@@OOOOOOOOOH@@@@@@@@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@@@@@@@@@COOOOON@@@@@@@@@@@@@@@@@@@@@@AOOOL@@@@@@@@@@@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY NIL POINT.OF.SYMMETRY.DEFINITION (100 . 100) SHADE.DEFINITION 65535 BITS.PER.PIXEL 1)) (PUTDEF (QUOTE ALBERT) (QUOTE NOTEPADSTYLE) '(BITS.PER.PIXEL 1 BRUSH.DEFINITION #*(185 210)@@@@@@@@@@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CNB@@@CMIND@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@@BD@@@@KL@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOLI@@@@@@H@GO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@D@BDB@@@@@@@M@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@IEB@@H@H@B@B@@@CL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOFDD@D@B@@@A@@@@AG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MFHB@H@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@@@@@@@@@@@MABIDBHA@@@@@@@@@@@B@@@@@@@@@@@@@@@@@@@@@@@@@@@BID@D@@@H@@@D@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@C@@MBEAED@@@@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@AONIMABE@@HAB@@@@@A@@@@@C@@@@@@@@@@@@@@@@@@@@@@@IDKNEL@@ED@D@@@@HHHB@@@@CH@@@@@@@@@@@@@@@@@@@@@@JJDDJDE@@@I@A@@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@@@EDIEBEH@AEB@@HB@D@BAA@@@@@AH@@@@@@@@@@@@@@@@@@@MJJE@EBD@@@@DB@@@@@@@D@@@@@@L@@@@@@@@@@@@@@@@@@OFMEDJID@@DHH@@A@B@I@B@@@@@@@F@@@@@@@@@@@@@@@@@CJJJAGOG@@HED@I@D@@@@@H@@@@@@@CH@@@@@@@@@@@@@@@@AGMIBKEMM@@DEB@B@@@@@@@D@@@D@AAD@@@@@@@@@@@@@@@@CMBDJOOG@@DIDH@H@I@@@I@@@@@@B@@CH@@@@@@@@@@@@@@@MFIBOOOMJI@EEGD@D@@@@@BB@@@@@@@@F@@@@@@@@@@@@@@BOJHKGOOMJJ@BJI@A@@@@@@H@@@@@@@@@C@@@@@@@@@@@@@@KFMEEOOMFJDIBJJJDAB@DH@@H@@@@@@@@AL@@@@@@@@@@@@DGOJJGOOOOJJDJJLI@@@@@@DD@@@@@@@@@@F@@@@@@@@@@@@KKFJGOOOOMMAFJMBBE@EDHB@ADDHHB@@@@@CH@@@@@@@@@@AFOMMKOOOEFKMEEGLEEFHAA@EDA@@@HA@@@@BL@@@@@@@@@@BGMGDOOOOOKMEEEEDIBI@DD@H@H@D@@@@@@@@I@@@@@@@@@@CNOMFOOOMDDKFMEEDJIDJ@BDBIE@HB@@@@@@@E@@@@@@@@@@GOJJOOOOKAEEEGKOJHBFJIDH@DDH@@@H@@@@BF@@@@@@@@@@CMMEOOONMEBJJMNOFJIAEDIBABE@@@DB@@HB@A@@@@@@@@@@GONKOOOOMDIEBGEOKDDEDJDHDDJI@@A@@D@@@A@@@@@@@@@AONJDOONJKBBJBOOEMEBDJABH@BE@J@@B@@@@@AH@@@@@@@@COGICOOMMMHJHJMJNKHEBIDIBBH@D@@@@@@@@@@H@@@@@@@@COMFOOOGFODA@EOOKFJHHLBDHHBJA@@H@@@@@@HH@@@@@@@@ENNJOOOMKEDD@JJMEMEBAFHI@@I@DAB@@@A@@@AH@@@@@@@@KOEGOOEFOO@I@BOOOFJHIBDBE@@B@@@@@@@@@@@H@@@@@@@@GNNOEEMEOIBH@JOGEJJHDJBH@BA@@@@@@@@B@@AH@@@@@@@AOOKDHMBKKFMD@GGOOFLEBI@A@H@@@@@@@@@@@@@L@@@@@@@BONMKBEEFOME@@KOMEJK@IDDDB@D@@@@@@@@H@@AL@@@@@@@COOMDDHBKNOMDBFJOOEIDNH@@@@@@@@@@B@@@H@@D@@@@@@@CONJBHBJOKKE@AEOOEFJJB@@B@@@@@@@@@@@@@@AD@@@@@@@GOOEDA@BGMOMHBKOGNMEEDH@H@@@@@@@@@@@@@@@L@@@@@@@OOMHBHBEDFMM@EGGOEEJJHBB@HA@@@@@@@@@@@@HN@@@@@@@GONDH@D@JKOJ@BKOOOJJHBI@B@@@@@@@@@HH@@B@F@@@@@@AOODH@J@DAGGDKBNOMEFJE@J@@@@@@@@@@@@@@@@@B@@@@@@CONL@@@D@JOOI@IGOONME@JH@@@@@@@@@@@B@@@@@CH@@@@@BOMJH@EAEEKODJEJKJKFIFJE@@@B@D@@@@@@@@@DB@L@@@@@GOJH@EBJEOOMK@JNOOMJMJM@BH@H@@IB@@@@@@@@@@D@@@@@GNND@BMEJJMODDEEOFJIEFEJ@A@@@@@@JJI@@@@@HHH@@@@@GOJIABFMGGGGI@JNOOEDJME@HD@@@@@DDHD@@@@@@@B@@@@@GNJDDIKEJOOMDJBEMMJMMEDJ@@@@@@@@@EEE@@@@@@A@@@@@OOJ@BFOFOKGFMEAFOFKFFIJ@A@@@@@@@@@@@I@@@@@I@@@@@ONIBIJJMEOOMEDEEEOGJJ@KGEE@@@@@@@@@@@@@@@@@H@@@AOOLHEMMEFMMGJHBJOJMEMEDIEBDH@@@@@@@DD@D@HD@L@@@AONBACEBJKKGMEDEDKKNMEAGFHH@@@@@@@@B@@A@@@@@D@@@COMIDNHHJOOMEBH@KNNKEEEIEB@@@@@@@@@@@@@@@@@HL@@@COL@CBJBKFKFME@EEGGNMBMBHAB@@@@@@BI@@@@@@@@@D@@@CONJILHDEOOKJJ@@KEKKJHJIED@@@@@@@@@@@@@@D@DDL@@@COHDNHBCOEEFLMBJKGFNMGDJDHJ@@@H@@@IB@@@@@D@@D@@@CNJBDBAFJOOOEB@AFNOOEI@EBB@@@@@@@@@@JAB@@@@@D@@@CNIEBEFOOEGOEHEDGMGEMFJHHIDH@@@@@@@@ADA@@@DIL@@@GNHAHBBOJMNMEDDBEOONKJ@E@E@@@@B@@@@@DEDD@H@@L@@@GLJDEEOOGGGOJIADEJOGLMK@BJNH@@@@@@@@@@@B@@@AH@@@GKABKOOMJMNMMBJHDOEJKBHMFAABH@@@@@@@@@@@@ABEH@@@GJJMJMOFOOEOFIA@KEKGJJIEI@@@@BAB@@@@@@@@JD@C@@@@GJIEMOMMEMOGKDE@DNMMJJEFJB@@@@D@@@@@@@@@D@@A@@@@FJEGKKGKKGEMMEBHJGFGFJHK@@@@@@@@@@H@@@@@@@BE@@@@NICNOKNJNMOOGJHBBOJKKEAMDD@@@@@@@@@HB@D@@@HA@@@@NJOGEGKGENJKOFM@EEMNMHJNA@B@A@@@@@D@@EB@@D@A@@@@NHGNNKMJNKONKK@@BOEGJMEE@@HDHD@@@A@H@@D@@@@E@@@@NEOOENMGEMKKOMMBEAMGOBIJEE@ID@@@@@@B@@BL@@@AH@@@MEMMEGKJOGONOOB@BMGNJMJHINOGFH@@@@H@@@@@@HB@L@@@LIOMGNMGKOOKOJIAEFMGMFKBNOEMJB@@@@@A@@@@J@@@B@@@MEOMKOMJMFOOOKDDBENONKEAEONONH@@@@@D@@@@@A@@A@@@JCOEGMFMOONOOMBAJNKOJMDIONOJKD@@@@@@@@@@DD@@C@@@IGGKONKGGMOOOEIBEMMGMEBEGOOONID@@@H@@@@@A@@@@H@@LKNEKEEJMOOOONDBKFKNOJMENOKOKDJ@@@@@@@@@@@@@@L@@IGNKOMJMNOOKOJJEEJNOJKDJKKNOME@@@@@@@@@@@HB@@D@@DKFOFJKGGNOOOMIBKGGFOEJJNFJJOBN@@@@@@AD@@@@@@F@@KOOGONKMMONOMFLJMEEMMKFHEEKAEIJI@@@@@@A@@@@@BC@@JNOOOKOOOOOKOKJJJJKGNOKEEENMNNJ@@@@@@@J@@DD@HCH@KOFMONOOMOMNMGDKJJKNOGMHJKKJEIMB@@@H@@HD@@@@@A@@KGOONKOOGMOOOMKFKEEGMOFDEGOOOGNH@@B@IBNH@@@@@@H@ONOOOOOKOOOONOGMJJJOOOOCGOOOOOKC@@@@@IGFIB@@@@H@OOGOOOLOOOONOKONMJKONMEDMMFOOEODJBH@EFMN@@@@@@H@OMMKOOOGOOOOKNMKFJJOOONJKKKGOKOE@@@@@KOEE@@@@@H@ONOOOOIBOOGMOKGOJJOGKFKENJDINMGJ@@HAEDJMB@H@@@H@OONOMOMEGONOOONKEEEOOONJKIBDKIOKDDBDEKOFMD@@@@H@OOGOKOOJKKOOOMGFMBNOEONFMOOOODMNH@IAEOOKM@@@@@H@OMOKOOMJNOKFOOJMJJKOGOGEKOOEGHOK@@D@JKEMFDA@@@H@OONOKOONONNOOJOFMBMMJMJGOOGOOJEOJ@BGONOGK@D@@@H@OOOFOOOOOOOOOMEJJJNNMOJMOOKOONOOD@@JJOOMMJ@@@@H@OOJOOOOOOOOOKMGMEEGGFMEOOOOIOKEEJ@EOOKJOGL@@@AH@OOOFOOOOOOOOOMMJDJMMEMEGOOOEMOGNH@@JMNOKOD@@@K@@OOMGGONOOOOOOJFMEEFJJJEOOOOHONMCD@GOKEDOOD@@@B@@OONJOOOOOOOOJMKJHJODBJOOKOO@KKNM@@EFOOFKOL@@@F@@GOJOOOMKOOOOOKOOFHEJJMKNEGJ@EMGE@@AOJMOEOD@@@L@@GONJOOOOOOOONMGEIEGHEGGKAOLAEEJGD@GMMOOGOL@@AH@@GOJOOOMOOOOOOKOOJHHMBJNOD@B@A@FE@@EGGKOJJ@DAC@@@GOJJOOGGOOOOOOMFNJH@DDKMBJ@DD@ME@@FOOOONND@@B@@@GNMEGOOOOOOOMMOMKGO@HBLKOEA@@BKFH@AEOOJON@@DB@@@GOJGONMOOOOONONOEKDDBJKFMND@@HNKB@ENOOOJNA@@F@@@GOEDGOOGOOOOONOMNNMEJJLMOEJIB@JM@@@JKOJONDB@F@@@GOJMCNMOOOOOKKOOKKDBBJJBKKEE@BAFH@@EEOAON@@@B@@@GNJDKOKOOMMONOMONOHHEENAMFJINIHGB@@D@J@KN@@IA@@@GOJLKNNOMOOOOOOGMOD@CFJDKKABEEAFH@@BJJAONDH@AH@@COJDGOKOOOOOGOOOOODIEC@BDHHMHB@K@@@J@@@CJ@@@BH@@ANMEGNMGOOGKNOKOOMJBHEJJBDEFJDHG@@@MNHDAN@DH@N@@AOJHGOKOOONOOONOGOI@JB@KMKMJ@@@MJ@@GCG@CLD@A@B@@@NLECNJOMOOOONOOOOE@HBJJKFKE@@@JJ@@MIDJCD@H@@C@@@KMDKOKOOMOOMOMOOGHE@IF@EEEB@DBJIBDGMJHALH@@BC@@@OJ@GNHGOGOOOFOKONLD@E@E@@@H@@AEB@@EF@@EJ@BD@@H@@OLHGOEGONOMOMOOOOEAB@BD@@@HAEDJHH@COD@ANB@@HJH@@OLDCNHOOKOOMNOOMMJL@A@JH@@@@HBNDB@EJA@AD@@H@@H@@OJHKOJGONOMOGJOOOJ@D@BGB@B@@OECBJ@AOHA@M@JA@BH@@KL@GNIGOOKOGJOMOMMB@@E@@@@@HJIEE@@AOM@@@B@@D@H@@OJICOLAOOOGNOKGMOED@D@D@@@@BNDKDJ@DOOD@@@JKBBH@@OL@EOJJOMKOOJNOOGJH@@BAB@@@@KBIE@@AGK@@HIEDHHH@@OJHGOJEGOOMJOENMOFIB@HD@@@@EMDODJH@MONB@@JKBAH@@GHBCOMGKOFOOKKKKOMH@HA@D@@@@IAEE@@@GNBH@HJIEAH@@GL@COOKJOOOONNONMO@@@@BD@@@BHENJIB@JODD@@CEDDH@@GJDEOFOKOMOOOKOGOGH@@@DJ@@@IB@KE@@@CE@HBBJBJ@H@@GL@COKOHGOKFKGKMMNHHHI@@@@@@HKMJHH@@EJ@H@BJJEH@@GH@EONOKGOOOOMNOOGB@@@@@@@@BBOONB@@@A@@@HJJLI@@@GLBCOMNLKNOOFKGOJMH@H@@@@@@@KEON@@@@@J@@EBEDA@@@GD@GOOKJKOMMOMMGOM@D@@@@@@I@JOOJH@@@@I@B@JJJK@@@CJ@GOOOIGOOOKGOOMFI@HB@@@D@AEMON@@@@@@@@JKEDB@@@CHICOOOJGOOGONKNOMJB@HB@@@@@KFMN@@@@@DBADJNHD@@@CM@GOONMCOOOOOOOOGD@@@@@A@@EFJOJH@@@@A@AEEJJH@@@CJ@COOGIGOOONKOMMM@JD@@@@@@AEIGO@@@@@J@AEFLIH@@@BNHKOOOJKOOOONMNNKJD@@J@@@IGN@GN@@@@@E@AJKFE@@@@CFDGOOOJGOOOGKOKOLHJH@@@@@AMJBFO@@@@@ADEFMJK@@@@CFHCOOMJKOOONOKNMFIAAA@@@@JFM@GNH@@@@A@AJKFB@@@@BODGOOOJGOOGOMOOOEBJJ@B@BDIKN@EO@@B@@DHBMMMD@@@@BKHCOOOEBOONMGOKMMABHD@@@BHOOBGE@@@@@@DCNJDL@@@@BNLAOOOLJOOOONOOKJDKG@D@DJ@EO@EOJBDH@@@BJMBH@@@@AGJEOOKECOOOOKOOMMBJJD@@@DIGNJEKHH@B@@@KFHI@@@@@BNMAGOOLBOOKKOGOMDAEMB@@ED@OOJNNJ@IH@@@AEFG@@@@@CGN@KOOOIOOONOOOFHDJK@IAC@AOOOKONMBJ@@@FIDF@@@@@AOMJGOOMEOOOOOOKKDBOMJ@@DBDOOOONKJMHH@@IEEL@@@@@AFNDCOONJOOOOKONMHBME@@@O@AOOOOONNKD@@@CJIH@@@@@AOMIEOKOOOONNOMOMAAGMDDDHD@OOOOOOKOI@@@AEG@@@@@@AKGDJOOOKOOGKOOME@BOOE@@JA@KOOOOOONEJ@@KJN@@@@@@AGOKGOOOOOOOONOOM@BOEDAD@D@EFOOOOOIOH@@IGH@@@@@@@MNOENOMOOONMKNOEBBKMJ@A@@ABOOOOOOJGD@@EN@@@@@@@@OGKOGOOOOOOOOOOM@BONHDHBD@ADKOOON@MN@ABH@@@@@@@@GOOMOOOOMOKOOOME@EOMB@B@HHH@MGOO@@CJHAEH@@@@@@@@AOOOOOOOOOOOOOGJBFEGHJ@E@@HHGJNNB@@J@AG@@@@@@@@@@OKOOOOOOOOOOOOE@JOMBA@@BA@AEGOO@@BM@AF@@@@@@@@@@GONOOOOOOOOGGKM@EFOHD@EH@D@BIMD@@@I@EL@@@@@@@@@@@COOOOOOOOKOONM@JKJBFBA@A@BAAAB@@@@HAH@@@@@@@@@@@@OMOOOKOOOOOGJHIFMMI@AJE@A@@H@@@@@ABH@@@@@@@@@@@@GOOOOOOOOOGMM@JKEEDJEDAA@DH@@@@@B@@H@@@@@@@@@@@@COOONOOOOOOFJJJMDEE@II@HBH@@@@@@@DKH@@@@@@@@@@@@AMOKGOKOGOMMNJMOIEIJJN@@A@@@@@@@@@I@@@@@@@@@@@@@AOOOMOOOOKGFKBKDHBJJFJAJE@A@@@@@@@K@@@@@@@@@@@@@@OOKOKKOOOOEMEGMDIEDKNH@A@@H@@@@@DJ@@@@@@@@@@@@@@GOOOONNNOKOFJNKDGMJDJAJEBA@@@@@@@F@@@@@@@@@@@@@@AOOMOKOOOOCKEGM@EKFEGHIG@AJ@@H@@@B@@@@@@@@@@@@@@@GOGOOOKOKMEJONIFOOAKENMIED@D@@@@C@@@@@@@@@@@@@@@CKOOOMOONKFKOMHEOJEFJJOHEJDAB@@@A@@@@@@@@@@@@@@@@OOOFOOMKMEBONHEOOJMMOEEJJ@DDB@AA@@@@@@@@@@@@@@@@CMGOOOOOGEBOODKOOOOOMOONMA@HH@@A@@@@@@@@@@@@@@@@AOOOOMFMMEEGMJGOOOOKOONKJHJE@@@C@@@@@@@@@@@@@@@@@GOOMOOOFJJOOEEOONNOOOKOFAED@@@A@@@@@@@@@@@@@@@@@BOEOMKGMEEOMIGONOOOOOOOOEEEB@@AH@@@@@@@@@@@@@@@@AKOJOOOKEBOOMKOOOOMOOOOEJJJ@D@@H@@@@@@@@@@@@@@@@@NOONMONNMGOJMOOOOGGGKONJOFHAB@H@@@@@@@@@@@@@@@@@COOKOGKEEGOJKOKKOOMOOOGEEF@D@CH@@@@@@@@@@@@@@@@@CNMOGNOOEOOJMONONMGOOOMKOKE@@N@@@@@@@@@@@@@@@@@@BKOOOKNJJGOEGOOOOOMOEGOMEOJCOH@@@@@@@@@@@@@@@@@@AOJKNOMMOOOHEOKOGGKOOOKFOOON@@@@@@@@@@@@@@@@@@@@AOONOOGFJOOLKOOOMONMOOONJOF@@@@@@@@@@@@@@@@@@@@@@MGKKMOOOGODFNKNOFOOOOJJOOL@@@@@@@@@@@@@@@@@@@@@@GOOOGMEEKOICEMKJOEOGEKGOOH@@@@@@@@@@@@@@@@@@@@@@GNOEOGOFOGLEKFMGDOKMNKJKO@@@@@@@@@@@@@@@@@@@@@@@CGKOKKEMEODEFKKJKEOGKEEOO@@@@@@@@@@@@@@@@@@@@@@@COOOMOOFOOIAEMMKFOOMOJNJN@@@@@@@@@@@@@@@@@@@@@@@AKGKGEMKCOLFJBFIEKJKFKIGN@@@@@@@@@@@@@@@@@@@@@@@AOOOONOMNOKEEDI@@DEEBIDON@@@@@@@@@@@@@@@@@@@@@@@@EOJKKKNKOMGEBFIEEDIEEEEJ@@@@@@@@@@@@@@@@@@@@@@@@NMOOMNKFOJIEA@@@@@@@@@ON@@@@@@@@@@@@@@@@@@@@@@@@COMGFMOOMMFJDD@@@@@@@BK@@@@@@@@@@@@@@@@@@@@@@@@@GFOMOGMEONMIBA@@AB@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@CKJOJMGOOEFJHD@@@@D@@@J@@@@@@@@@@@@@@@@@@@@@@@@@AOOFOKKFOOKJJ@B@D@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@JKKJNMOOFNOEE@@@B@@@BH@@@@@@@@@@@@@@@@@@@@@@@@@@GNNOKOGMOGONE@D@HD@@E@@@@@@@@@@@@@@@@@@@@@@@@@@@CKGKOGMOMONKBD@H@@@@EH@@@@@@@@@@@@@@@@@@@@@@@@@@AOJNKMGOOOOMEA@@A@@@K@@@@@@@@@@@@@@@@@@@@@@@@@@@@FOKNONMNOOOJJDEDBD@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@EJNKEKOKONNOEE@BHIEF@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMKNNOMNOKOEHHJHD@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GFKGMOOMONOGE@JJMDH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MMMGEOGOOOOEFJMEB@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGGOOOOOKNONJMOJL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MMEOOOOOOMKJKEF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@BKONOOOOKOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANOOMGOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GMMOONOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@JOONOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGOONOMOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AMMJOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GGOKOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CNNOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@KOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OJ@@@@@@@@@@@@@@@@@@@@@@ MASK.DEFINITION #*(185 210)@@@@@@@@@@@@@@@@@@@@@AOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOND@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CGOOOOOOOOL@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOLOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOM@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOJ@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@C@COOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@AONOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@IOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@KOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@EOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@MOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@BOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@KOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@DGOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOI@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOM@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOM@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGH@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOG@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOONH@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOONH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@KOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OJ@@@@@@@@@@@@@@@@@@@@@@ USE.MASK T PRINTING.FONT.DEFINITION (HELVETICA 18 BOLD) GRID.DEFINITION (0 0 16 16) USE.GRID NIL USE.GRID.TO.DRAW NIL USE.SYMMETRY 8-FOLD POINT.OF.SYMMETRY.DEFINITION (312 . 281) USE.SYMMETRIC.BRUSH/MASK NIL SHADE.DEFINITION 65535)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/NOTEPAD.TEDIT b/lispusers/NOTEPAD.TEDIT new file mode 100644 index 00000000..861db88e Binary files /dev/null and b/lispusers/NOTEPAD.TEDIT differ diff --git a/lispusers/NOVAFONT b/lispusers/NOVAFONT new file mode 100644 index 00000000..06c58165 --- /dev/null +++ b/lispusers/NOVAFONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 9-Feb-89 13:52:01" {ERINYES}MEDLEY>NOVAFONT.\;5 37388 |changes| |to:| (FNS \\READNOVAFONTFILE.IP) (VARS NOVAFONTCOMS) |previous| |date:| " 8-Feb-89 11:09:51" {ERINYES}MEDLEY>NOVAFONT.\;3) ; Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT NOVAFONTCOMS) (RPAQQ NOVAFONTCOMS ((* |;;;| "user callable functions (either load-on-demand or load them all") (FNS NOTICE-NOVAFONT-FILE LOAD-NOVAFONT-FILE) (* |;;;| "the parts necessary for using with FONTCREATE") (FNS \\READNOVAFONTFILE.DISPLAY \\READNOVAFONTFILE.IP) (* |;;;| "modified versions of functions from the default font handling system") (FNS \\READDISPLAYFONTFILE.NOVA \\CREATECHARSET.IP.NOVA) (* |;;;| "the parts for general hacking of the NOVAFONT files") (FNS DESCRIBE-FONT SELECT-FONT ENUMERATE-FONTS VIEWPOINT-FONT-FILE-P) (VARS (*WARN-ON-KERNING* NIL)) (GLOBALVARS *WARN-ON-KERNING*) (* |;;;| "where the NovaFont files are likely to be") (VARIABLES *NOVAFONT-PATHNAME-DEFAULTS*) (* |;;;| "things for dealing with the structure of what we read") (MACROS READSWAPPEDFIXP) (FNS READ-BLOCK-OF-BYTES READ-NOVAFONT-CHARACTERSET READ-NOVAFONT-FILEHEADER READ-NOVAFONT-FONTHEADER \\TEXTBLT) (* |;;;| "the datastructures that we use and their sizes") (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS FONTTREENODEBLOCK CHARSETBLOCK FONTDESCRIPTION) (CONSTANTS (FONTTREENODEBLOCKBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (FONTTREENODEBLOCK DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (CHARSETBLOCKBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (CHARSETBLOCK DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (FONTDESCRIPTIONBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (FONTDESCRIPTION DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))))) (DECLARE\: EVAL@COMPILE DONTEVAL@LOAD DOCOPY (INITRECORDS FONTTREENODEBLOCK CHARSETBLOCK FONTDESCRIPTION)) (* |;;;| "the mapping from font family number to font family name for those fonts which don't have the name embedded in the font file.") (CONSTANTS \\NOVAFONTFAMILYNAMES) (* |;;;| "initialize the \"noticed\" fonts structure and set up the extensions so we can use the font files") (VARIABLES *NOVAFONT-INFO*) (* |;;;| "correct some omissions in the family aliases and printwheel fonts") (P (LISTPUT INTERPRESSFAMILYALIASES (QUOTE XEROXLOGO) (QUOTE LOGOTYPES-XEROX)) (|pushnew| INTERPRESSPRINTWHEELFAMILIES (QUOTE SCIENTIFICTHIN) (QUOTE OCRB) (QUOTE OCRA))) (* |;;;| "some things we need for compiling. Also need EXPORTS.ALL") (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) INTERPRESS LLCHAR)) (* |;;;| "install this:") (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE \\READDISPLAYFONTFILE) (QUOTE \\NO-NOVA-READDISPLAYFONTFILE)) (MOVD? (QUOTE \\CREATECHARSET.IP) (QUOTE \\NO-NOVA-CREATECHARSET.IP)) (MOVD (QUOTE \\READDISPLAYFONTFILE.NOVA) (QUOTE \\READDISPLAYFONTFILE)) (MOVD (QUOTE \\CREATECHARSET.IP.NOVA) (QUOTE \\CREATECHARSET.IP)))) (* |;;;| "some hints for the compiler (system generated)") (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA READ-NOVAFONT-FONTHEADER READ-NOVAFONT-FILEHEADER))))) (* |;;;| "user callable functions (either load-on-demand or load them all") (DEFINEQ (NOTICE-NOVAFONT-FILE (LAMBDA (NOVAFONT-FILENAME NOTRACE) (* \; "Edited 6-Dec-88 12:22 by Briggs") (CL:WITH-OPEN-FILE (NOVAFONT-STREAM NOVAFONT-FILENAME :INPUT) (LET ((MINIMAL-FILE-NAME (CL:ENOUGH-NAMESTRING (CL:MAKE-PATHNAME :VERSION NIL :DEFAULTS NOVAFONT-STREAM) *NOVAFONT-PATHNAME-DEFAULTS*)) NUMBER-OF-FONTS FONT-OFFSETS) (CL:MULTIPLE-VALUE-SETQ (NUMBER-OF-FONTS FONT-OFFSETS) (READ-NOVAFONT-FILEHEADER NOVAFONT-STREAM)) (|for| FONT-NUMBER |from| 1 |to| NUMBER-OF-FONTS |bind| FONT-NAME NOVAFONT-DESCRIPTOR CHARACTER-SET-OFFSETS FONT-FACE CHARACTER-SETS FAMILY-INFO SIZE-INFO FACE-INFO |do| (CL:MULTIPLE-VALUE-SETQ (FONT-NAME NOVAFONT-DESCRIPTOR CHARACTER-SET-OFFSETS) (READ-NOVAFONT-FONTHEADER NOVAFONT-STREAM (ELT FONT-OFFSETS FONT-NUMBER))) (SETQ FONT-FACE (+ (|fetch| (FONTDESCRIPTION EMPHASIS) |of| NOVAFONT-DESCRIPTOR) (CL:* 2 (|fetch| (FONTDESCRIPTION WEIGHT) |of| NOVAFONT-DESCRIPTOR)))) (* |;;| "was (list (cl:ecase (|fetch| (fontdescription weight) |of| novafont-descriptor) (0 'light) (1 'medium) (2 'bold)) (cl:ecase (|fetch| (fontdescription emphasis) |of| novafont-descriptor) (0 'regular) (1 'italic)) 'regular) ") (CL:UNLESS NOTRACE (CL:FORMAT T "~A~D~A~S" FONT-NAME (|fetch| (FONTDESCRIPTION SIZE) |of| NOVAFONT-DESCRIPTOR) (LIST (CL:ECASE (|fetch| (FONTDESCRIPTION WEIGHT) |of| NOVAFONT-DESCRIPTOR) (0 (QUOTE LIGHT)) (1 (QUOTE MEDIUM)) (2 (QUOTE BOLD))) (CL:ECASE (|fetch| (FONTDESCRIPTION EMPHASIS) |of| NOVAFONT-DESCRIPTOR) (0 (QUOTE REGULAR)) (1 (QUOTE ITALIC)))) (|for| I |from| 0 |to| (- (ARRAYSIZE CHARACTER-SET-OFFSETS) 1) |when| (NEQ (ELT CHARACTER-SET-OFFSETS I) 0) |collect| I))) (|for| I |from| 0 |to| (- (ARRAYSIZE CHARACTER-SET-OFFSETS) 1) |when| (NEQ (ELT CHARACTER-SET-OFFSETS I) 0) |do| (CL:SETF (CL:GETF (CL:GETF (CL:GETF (CL:GETF *NOVAFONT-INFO* (MKATOM (U-CASE FONT-NAME))) (|fetch| (FONTDESCRIPTION SIZE) |of| NOVAFONT-DESCRIPTOR)) FONT-FACE) I) (LIST MINIMAL-FILE-NAME (+ (ELT CHARACTER-SET-OFFSETS I) (ELT FONT-OFFSETS FONT-NUMBER)))))) NUMBER-OF-FONTS))) ) (LOAD-NOVAFONT-FILE (LAMBDA (|filename|) (* \; "Edited 9-Jul-87 16:23 by mdd") (CL:WITH-OPEN-FILE (|stream| |filename| :INPUT) (CL:MULTIPLE-VALUE-BIND (|nfonts| |fontaddrs|) (READ-NOVAFONT-FILEHEADER |stream|) (* |;;| " loop through the font nodes. fontAddrs are relative to wd 0 of file and have been converted to byte offsets when read in.") (|for| |fontnumber| |from| 1 |to| |nfonts| |bind| |name| |fontdescriptor| |charsetaddrs| |fontpos| |font| |font-face| (|rasterinfos| _ (ARRAY 256 (QUOTE WORD) 0 0)) (|fontprinterwidths| _ (ARRAY 256 (QUOTE WORD) 0 0)) (|fontspacingwidths| _ (ARRAY 256 (QUOTE BYTE) 0 0)) |do| (SETQ |fontpos| (ELT |fontaddrs| |fontnumber|)) (* |;;| "read the second level FontTreeNode (known as a font header, since it collects the character sets of the font)") (* |;;| "reads font header located at fontBlockPos into fontHeaderBuffer. Returns number of character sets in ncharSets, allocates an array to hold their word offsets from beginning of font block, and reads in those offsets.") (CL:MULTIPLE-VALUE-SETQ (|name| |fontdescriptor| |charsetaddrs|) (READ-NOVAFONT-FONTHEADER |stream| |fontpos|)) (* |;;| "now read the third level char set nodes") (SETQ |font-face| (LIST (CL:ECASE (|fetch| (FONTDESCRIPTION WEIGHT) |of| |fontdescriptor|) (0 (QUOTE LIGHT)) (1 (QUOTE MEDIUM)) (2 (QUOTE BOLD))) (CL:ECASE (|fetch| (FONTDESCRIPTION EMPHASIS) |of| |fontdescriptor|) (0 (QUOTE REGULAR)) (1 (QUOTE ITALIC))) (QUOTE REGULAR))) (SETQ |name| (MKATOM (U-CASE |name|))) (SETQ |font| (|create| FONTDESCRIPTOR FONTDEVICE _ (QUOTE DISPLAY) FONTFAMILY _ |name| FONTSIZE _ (|fetch| (FONTDESCRIPTION SIZE) |of| |fontdescriptor|) FONTFACE _ |font-face| |\\SFAscent| _ 0 |\\SFDescent| _ 0 |\\SFHeight| _ 0 ROTATION _ 0 FONTDEVICESPEC _ (LIST |name| (|fetch| (FONTDESCRIPTION SIZE) |of| |fontdescriptor|) |font-face| 0 (QUOTE DISPLAY)))) (|for| \j |from| 0 |to| (- (ARRAYSIZE |charsetaddrs|) 1) |bind| |csinfo| |charsetoffset| |do| (SETQ |charsetoffset| (ELT |charsetaddrs| \j)) (|if| (NEQ |charsetoffset| 0) |then| (* |;;| "read in enough to get charSet # and bc,ec ") (SETQ |csinfo| (\\READNOVAFONTFILE.DISPLAY |stream| (PLUS |fontpos| |charsetoffset|) NIL NIL NIL \j |rasterinfos| |fontprinterwidths| |fontspacingwidths|)) (|replace| |\\SFAscent| |of| |font| |with| (IMAX (|fetch| |\\SFAscent| |of| |font|) (|fetch| CHARSETASCENT |of| |csinfo|))) (|replace| |\\SFDescent| |of| |font| |with| (IMAX (|fetch| |\\SFDescent| |of| |font|) (|ffetch| CHARSETDESCENT |of| |csinfo|))) (|replace| |\\SFHeight| |of| |font| |with| (IPLUS (|fetch| |\\SFAscent| |of| |font|) (|ffetch| |\\SFDescent| |of| |font|))) (\\SETCHARSETINFO (|ffetch| FONTCHARSETVECTOR |of| |font|) \j |csinfo|))) (|replace| (FONTDESCRIPTOR FONTAVGCHARWIDTH) |of| |font| |with| (\\AVGCHARWIDTH |font|)) (SETFONTDESCRIPTOR |name| (|fetch| (FONTDESCRIPTION SIZE) |of| |fontdescriptor|) |font-face| 0 (QUOTE DISPLAY) |font|))))) ) ) (* |;;;| "the parts necessary for using with FONTCREATE") (DEFINEQ (\\READNOVAFONTFILE.DISPLAY (LAMBDA (STREAM OFFSET FAMILY SIZE FACE CHARSET RASTERINFOS FONTPRINTERWIDTHS FONTSPACINGWIDTHS) (* \; "Edited 9-Jul-87 16:23 by mdd") (DECLARE (GLOBALVARS \\SYSPILOTBBT)) (SETFILEPTR STREAM OFFSET) (LET ((CHARSETINFO (|create| CHARSETINFO IMAGEWIDTHS _ (\\CREATECSINFOELEMENT))) (CHARSETHEADER (READ-BLOCK-OF-BYTES STREAM CHARSETBLOCKBYTESIZE)) RASTEROFFSET RAWRASTERS) (|replace| (CHARSETINFO CHARSETASCENT) |of| CHARSETINFO |with| (|fetch| (CHARSETBLOCK ASCENT) |of| CHARSETHEADER)) (|replace| (CHARSETINFO CHARSETDESCENT) |of| CHARSETINFO |with| (|fetch| (CHARSETBLOCK DESCENT) |of| CHARSETHEADER)) (SETFILEPTR STREAM (+ OFFSET CHARSETBLOCKBYTESIZE)) (* |;;| "read the raster information, spacing for the printer (not used here) and spacing for the display as they are stored in the novafont file") (OR (AND RASTERINFOS (ARRAYP RASTERINFOS) (EQ (ARRAYSIZE RASTERINFOS) 256)) (SETQ RASTERINFOS (ARRAY 256 (QUOTE WORD) 0 0))) (AIN RASTERINFOS 0 (ARRAYSIZE RASTERINFOS) STREAM) (OR (AND FONTPRINTERWIDTHS (ARRAYP FONTPRINTERWIDTHS) (EQ (ARRAYSIZE FONTPRINTERWIDTHS) 256)) (SETQ FONTPRINTERWIDTHS (ARRAY 256 (QUOTE WORD) 0 0))) (AIN FONTPRINTERWIDTHS 0 (ARRAYSIZE FONTPRINTERWIDTHS) STREAM) (OR (AND FONTSPACINGWIDTHS (ARRAYP FONTSPACINGWIDTHS) (EQ (ARRAYSIZE FONTSPACINGWIDTHS) 256)) (SETQ FONTSPACINGWIDTHS (ARRAY 256 (QUOTE BYTE) 0 0))) (AIN FONTSPACINGWIDTHS 0 (ARRAYSIZE FONTSPACINGWIDTHS) STREAM) (* |;;| "position to the start of the rasters, after the rasterinfo (256 words), printer width (256 words) and spacing width (256 bytes) arrays (this should be a noop if there's no padding)") (SETFILEPTR STREAM (+ OFFSET CHARSETBLOCKBYTESIZE (+ 256 (CL:* 256 BYTESPERWORD 2)))) (* |;;| "the rasters should be all the remaining storage in the character set block.") (SETQ RAWRASTERS (READ-BLOCK-OF-BYTES STREAM (- (CL:* BYTESPERWORD (|fetch| (CHARSETBLOCK SIZE) |of| CHARSETHEADER)) (+ (+ 256 (CL:* 256 BYTESPERWORD 2)) CHARSETBLOCKBYTESIZE)))) (* |;;| "process the novafont format information to that required for a regular font descriptor. We must compute the actual image width based on the kerning information (bits 15 and 16) passed in the raster infos. The \"slug\" is always the first character in a novafont. ") (|for| CHARACTER |from| 1 |to| 255 |bind| (SLUGRASTERINFO _ (ELT RASTERINFOS 0)) |first| (* |;;| "we set up the slug first, then process all the other characters") (\\FSETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) 0 0) (\\FSETWIDTH (|fetch| (CHARSETINFO WIDTHS) |of| CHARSETINFO) 0 (ELT FONTSPACINGWIDTHS 0)) (\\FSETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) 0 (+ (ELT FONTSPACINGWIDTHS 0) (LOGAND (RSH (ELT RASTERINFOS 0) 14) 1) (RSH (ELT RASTERINFOS 0) 15))) (SETQ RASTEROFFSET (\\FGETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) 0)) |do| (\\FSETWIDTH (|fetch| (CHARSETINFO WIDTHS) |of| CHARSETINFO) CHARACTER (ELT FONTSPACINGWIDTHS CHARACTER)) (\\FSETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) CHARACTER (+ (ELT FONTSPACINGWIDTHS CHARACTER) (LOGAND (RSH (ELT RASTERINFOS CHARACTER) 14) 1) (RSH (ELT RASTERINFOS CHARACTER) 15))) (|if| (NOT (EQUAL (ELT RASTERINFOS CHARACTER) SLUGRASTERINFO)) |then| (\\FSETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) CHARACTER RASTEROFFSET) (SETQ RASTEROFFSET (+ RASTEROFFSET (\\FGETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) CHARACTER))))) (* |;;| "we used the rasteroffset calculated above to determine the width of the character bitmap that we must create -- otherwise this would be folded into the previous loop. We also allocate some extra bits in case we have to fake the space character") (|replace| (CHARSETINFO CHARSETBITMAP) |of| CHARSETINFO |with| (BITMAPCREATE (+ RASTEROFFSET (\\FGETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) 0)) (|fetch| (CHARSETBLOCK HEIGHT) |of| CHARSETHEADER))) (* |;;| "set up the slug first to speed up the check in the next loop") (\\TEXTBLT \\SYSPILOTBBT (\\ADDBASE RAWRASTERS (LOGAND (ELT RASTERINFOS 0) 16383)) (\\FGETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) 0) (|fetch| (CHARSETBLOCK HEIGHT) |of| CHARSETHEADER) (|fetch| (CHARSETINFO CHARSETBITMAP) |of| CHARSETINFO) (\\FGETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) 0)) (* |;;| "extract the bitmaps for all the characters in the font.") (|for| CHARACTER |from| 1 |to| 255 |bind| (HEIGHT _ (|fetch| (CHARSETBLOCK HEIGHT) |of| CHARSETHEADER)) (SLUGOFFSET _ (\\FGETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) 0)) |when| (NOT (EQL SLUGOFFSET (\\FGETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) CHARACTER))) |do| (\\TEXTBLT \\SYSPILOTBBT (\\ADDBASE RAWRASTERS (LOGAND (ELT RASTERINFOS CHARACTER) 16383)) (\\FGETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) CHARACTER) HEIGHT (|fetch| (CHARSETINFO CHARSETBITMAP) |of| CHARSETINFO) (\\FGETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) CHARACTER))) (* |;;| "if this is character set 0, and the space is a slug then we've got to fix up a space at the end of the bitmaps. For now we'll make it a 1 ex space.") (|if| (AND (EQ CHARSET 0) (EQL (\\FGETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) 0) (\\FGETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) (CHARCODE SP)))) |then| (\\FSETOFFSET (|fetch| (CHARSETINFO OFFSETS) |of| CHARSETINFO) (CHARCODE SP) RASTEROFFSET) (\\FSETWIDTH (|fetch| (CHARSETINFO WIDTHS) |of| CHARSETINFO) (CHARCODE SP) (\\FGETWIDTH (|fetch| (CHARSETINFO WIDTHS) |of| CHARSETINFO) (CHARCODE \x))) (\\FSETIMAGEWIDTH (|fetch| (CHARSETINFO IMAGEWIDTHS) |of| CHARSETINFO) (CHARCODE SP) (\\FGETWIDTH (|fetch| (CHARSETINFO WIDTHS) |of| CHARSETINFO) (CHARCODE \x)))) (* |;;| "finally, return the newly created charsetinfo") CHARSETINFO)) ) (\\READNOVAFONTFILE.IP (LAMBDA (STREAM OFFSET CHARSET CHARSETINFO) (* \; "Edited 9-Feb-89 13:51 by Briggs") (SETFILEPTR STREAM OFFSET) (LET ((CHARSETHEADER (READ-BLOCK-OF-BYTES STREAM CHARSETBLOCKBYTESIZE)) FONTPRINTERWIDTHS MINUS-FBBOY RASTERINFOS) (* |;;| "Descent from -FBBOY -- note that -FBBOY *could* be negative (lose!)") (|if| (ILESSP (SETQ MINUS-FBBOY (IMINUS (SIGNED (|fetch| (CHARSETBLOCK FBBOY) |of| CHARSETHEADER) BITSPERWORD))) 0) |then| (|replace| (CHARSETINFO CHARSETDESCENT) |of| CHARSETINFO |with| 0) (|replace| (CHARSETINFO CHARSETASCENT) |of| CHARSETINFO |with| (|fetch| (CHARSETBLOCK FBBDY) |of| CHARSETHEADER)) |else| (|replace| (CHARSETINFO CHARSETDESCENT) |of| CHARSETINFO |with| MINUS-FBBOY) (|replace| (CHARSETINFO CHARSETASCENT) |of| CHARSETINFO |with| (IDIFFERENCE (|fetch| (CHARSETBLOCK FBBDY) |of| CHARSETHEADER) MINUS-FBBOY))) (SETFILEPTR STREAM (+ OFFSET CHARSETBLOCKBYTESIZE)) (* |;;| "read the raster information, spacing for the printer (not used here) and spacing for the display as they are stored in the novafont file") (SETQ RASTERINFOS (ARRAY 256 (QUOTE WORD) 0 0)) (AIN RASTERINFOS 0 (ARRAYSIZE RASTERINFOS) STREAM) (SETQ FONTPRINTERWIDTHS (ARRAY 256 (QUOTE WORD) 0 0)) (AIN FONTPRINTERWIDTHS 0 (ARRAYSIZE FONTPRINTERWIDTHS) STREAM) (|for| CHARACTER |from| 0 |to| 255 |do| (\\FSETWIDTH (|fetch| (CHARSETINFO WIDTHS) |of| CHARSETINFO) CHARACTER (ELT FONTPRINTERWIDTHS CHARACTER))) CHARSETINFO)) ) ) (* |;;;| "modified versions of functions from the default font handling system") (DEFINEQ (\\READDISPLAYFONTFILE.NOVA (LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* \; "Edited 6-Dec-88 14:59 by Briggs") (OR (LET ((CS (CL:GETF (CL:GETF (CL:GETF (CL:GETF *NOVAFONT-INFO* (U-CASE FAMILY)) SIZE) (+ (CL:ECASE (CADR FACE) (REGULAR 0) (ITALIC 1)) (CL:* 2 (CL:ECASE (CAR FACE) (LIGHT 0) (MEDIUM 1) (BOLD 2))))) (OR CHARSET (SETQ CHARSET 0))))) (CL:WHEN CS (CL:WITH-OPEN-FILE (STREAM (CL:MERGE-PATHNAMES (CAR CS) *NOVAFONT-PATHNAME-DEFAULTS*) :DIRECTION :INPUT) (\\READNOVAFONTFILE.DISPLAY STREAM (CADR CS) FAMILY SIZE FACE CHARSET)))) (\\NO-NOVA-READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET))) ) (\\CREATECHARSET.IP.NOVA (LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* \; "Edited 6-Dec-88 15:08 by Briggs") (OR (LET ((CS (CL:GETF (CL:GETF (CL:GETF (CL:GETF *NOVAFONT-INFO* (U-CASE FAMILY)) PSIZE) (+ (CL:ECASE (CADR FACE) (REGULAR 0) (ITALIC 1)) (CL:* 2 (CL:ECASE (CAR FACE) (LIGHT 0) (MEDIUM 1) (BOLD 2))))) (OR CHARSET (SETQ CHARSET 0))))) (AND CS (CL:WITH-OPEN-FILE (STREAM (CL:MERGE-PATHNAMES (CAR CS) *NOVAFONT-PATHNAME-DEFAULTS*) :DIRECTION :INPUT) (\\READNOVAFONTFILE.IP STREAM (CADR CS) CHARSET (|create| CHARSETINFO))))) (\\NO-NOVA-CREATECHARSET.IP FAMILY PSIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?))) ) ) (* |;;;| "the parts for general hacking of the NOVAFONT files") (DEFINEQ (DESCRIBE-FONT (LAMBDA (NAME FONTDESCRIPTOR CHARSETHEADER FONTSPACINGWIDTHS FONTPRINTERWIDTHS FONTRASTER) (* |briggs| "11-Nov-86 22:58") (|if| (AND (BOUNDP (QUOTE LASTFONTDESCRIPTOR)) (NEQ FONTDESCRIPTOR LASTFONTDESCRIPTOR)) |then| (SETQ LASTFONTDESCRIPTOR FONTDESCRIPTOR) (PRINTOUT T T NAME ":" \, (|fetch| (FONTDESCRIPTION SIZE) |of| FONTDESCRIPTOR) "pt. " (CASE (|fetch| (FONTDESCRIPTION WEIGHT) |of| FONTDESCRIPTOR) (0 "light ") (1 "medium ") (2 "bold ") (OTHERWISE "unknown ")) (CASE (|fetch| (FONTDESCRIPTION EMPHASIS) |of| FONTDESCRIPTOR) (0 "regular") (1 "italic") (OTHERWISE "unknown")) " character sets: ")) (PRINTOUT T (|fetch| (CHARSETBLOCK CHARSETNUM) |of| CHARSETHEADER) \,)) ) (SELECT-FONT (LAMBDA (NAME FONTDESCRIPTOR CHARSETHEADER FONTSPACINGWIDTHS FONTPRINTERWIDTHS FONTRASTER) (* BRIGGS " 6-Nov-86 23:14") (|if| (EQL 12 (|fetch| (FONTDESCRIPTION SIZE) |of| FONTDESCRIPTOR)) |then| (CL:ASSERT NIL))) ) (ENUMERATE-FONTS (LAMBDA (STREAM PROC READ-RASTERS-P) (* |briggs| "11-Nov-86 23:03") (* |;;| "\"assumes stream is open to a viewpoint font file with read access. Calls PROC for each font in the file. Used in listing the contents of a ViewPoint screenfont file. Returns error TRUE of an error of any kind occurs in working through the file (I/O errors, format errors, etc.)\"") (SETFILEPTR STREAM 0) (OR (VIEWPOINT-FONT-FILE-P STREAM) (CL:ERROR "not a font file")) (LET (FONTADDRS NFONTS) (CL:MULTIPLE-VALUE-SETQ (NFONTS FONTADDRS) (READ-NOVAFONT-FILEHEADER STREAM)) (* |;;| " loop through the font nodes. fontAddrs are relative to wd 0 of file and have been converted to byte offsets when read in.") (|for| FONTNUMBER |from| 1 |to| NFONTS |bind| NAME FONTDESCRIPTOR CHARSETADDRS FONTPOS |do| (SETQ FONTPOS (ELT FONTADDRS FONTNUMBER)) (* |;;| "read the second level FontTreeNode (known as a font header, since it collects the character sets of the font)") (* |;;| "reads font header located at fontBlockPos into fontHeaderBuffer. Returns number of character sets in ncharSets, allocates an array to hold their word offsets from beginning of font block, and reads in those offsets.") (CL:MULTIPLE-VALUE-SETQ (NAME FONTDESCRIPTOR CHARSETADDRS) (READ-NOVAFONT-FONTHEADER STREAM FONTPOS)) (* |;;| "now read the third level char set nodes") (|for| J |from| 0 |to| (- (ARRAYSIZE CHARSETADDRS) 1) |bind| CHARSETHEADER FONTSPACINGWIDTHS FONTPRINTERWIDTHS FONTRASTER RASTEROFFSETS CHARSETOFFSET |do| (SETQ CHARSETOFFSET (ELT CHARSETADDRS J)) (|if| (NEQ CHARSETOFFSET 0) |then| (* |;;| "read in enough to get charSet # and bc,ec ") (CL:MULTIPLE-VALUE-SETQ (CHARSETHEADER FONTSPACINGWIDTHS FONTPRINTERWIDTHS FONTRASTER RASTEROFFSETS) (READ-NOVAFONT-CHARACTERSET STREAM (+ FONTPOS CHARSETOFFSET) READ-RASTERS-P)) (|if| PROC |then| (APPLY* PROC NAME FONTDESCRIPTOR CHARSETHEADER FONTSPACINGWIDTHS FONTPRINTERWIDTHS FONTRASTER RASTEROFFSETS)) (* |;;| "Get pointsize (? bits) pitch (either fixed or variable) weight (light medium heavy other) posture (roman italic) and character set - charsetheader includes height descent") (* |;;| "SETQ STARTOFRASTERS (+ CHARSTART 1280 (* 2 FONTSEGMENTHEADERSIZE)) (LET ((FONT (create FONTDESCRIPTOR FONTDEVICE _ (QUOTE DISPLAY) FONTFAMILY _ (MKATOM (U-CASE NAME)) FONTSIZE _ SIZE FONTFACE _ FACE \\SFAscent _ 0 \\SFDescent _ 0 \\SFHeight _ 0 ROTATION _ ROTATION)) (CSI (CREATE CHARSETINFO)))) (FILLINFONTOBJECT FONT FONTINFO CHARSETHEADER STARMODE) (FUNCALL PROC FONT BC EC FONTPOS CHARSETPOS)")))))) ) (VIEWPOINT-FONT-FILE-P (LAMBDA (STREAM) (* |briggs| "11-Nov-86 22:44") "assumes stream is open to a file with read access. returns TRUE iff the file is a ViewPoint screen font file" (LET (FILEHEADER FIRSTFONTADDR FIRSTCHARSETADDR) (* |;;| "read first 12 words of file & check for pattern in first 3 words") (SETQ FILEHEADER (READ-BLOCK-OF-BYTES STREAM FONTTREENODEBLOCKBYTESIZE)) (|if| (|with| FONTTREENODEBLOCK FILEHEADER (AND (EQ ID 0) (EQ TYPE 65535) (EQL (GETEOFPTR STREAM) (+ FONTTREENODEBLOCKBYTESIZE (CL:* BYTESPERWORD (+ (CL:* 2 NCHILDREN) SIZEFILLER1 SIZECHILDREN)))))) |then| (* |;;| "\"at this point, we could have either a ViewPoint or Star font. First follow offsets to the first char set of the first font\"") (SETQ FIRSTFONTADDR (PROGN (SETFILEPTR STREAM FONTTREENODEBLOCKBYTESIZE) (READSWAPPEDFIXP STREAM))) (SETQ FIRSTCHARSETADDR (PROGN (SETFILEPTR STREAM (+ FIRSTFONTADDR FONTTREENODEBLOCKBYTESIZE)) (READSWAPPEDFIXP STREAM))) (* |;;| "\"Viewpoint files contain (here) a 256 word array of kern + offset, then a 256 word array of printer widths. Offset words are zero if no character, otherwise are monotonically increasing, since bitmaps are inserted in character code order. Printer widths are initialized to a default constant value for characters with no bitmap. So if first 256 words (masked to low order 14 bits and not counting 0 values) are monotonically increasing, we have a ViewPoint file. Legal ViewPoint arrays have monotonically increasing non-zero elements, whereas star arrays will be mixed in with printer widths and will not be monotonically increasing.\"") (* |;;;| "Punt for now") T))) ) ) (RPAQQ *WARN-ON-KERNING* NIL) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *WARN-ON-KERNING*) ) (* |;;;| "where the NovaFont files are likely to be") (DEFGLOBALVAR *NOVAFONT-PATHNAME-DEFAULTS* (PATHNAME (AND (BOUNDP (QUOTE DISPLAYFONTDIRECTORIES)) (LISTP DISPLAYFONTDIRECTORIES) (CAR DISPLAYFONTDIRECTORIES)))) (* |;;;| "things for dealing with the structure of what we read") (DECLARE\: EVAL@COMPILE (PUTPROPS READSWAPPEDFIXP DMACRO (OPENLAMBDA (STREAM) (+ (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM)) (CL:ASH (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM)) 16)))) ) (DEFINEQ (READ-BLOCK-OF-BYTES (LAMBDA (STREAM NUMBER-OF-BYTES) (* |briggs| " 9-Nov-86 23:16") (LET ((RESULT (\\ALLOCBLOCK (FOLDHI NUMBER-OF-BYTES BYTESPERCELL) UNBOXEDBLOCK.GCT))) (\\BINS STREAM RESULT 0 NUMBER-OF-BYTES) (* |;;| "(|for| byteindex |from| 0 |to| (- number-of-bytes 1) |do| (\\\\putbasebyte result byteindex (bin stream)))") RESULT)) ) (READ-NOVAFONT-CHARACTERSET (LAMBDA (STREAM OFFSETTOCHARSET READ-RASTERS-P) (* |briggs| "11-Nov-86 23:18") (DECLARE (GLOBALVARS *WARN-ON-KERNING* \\SYSPILOTBBT)) (SETFILEPTR STREAM OFFSETTOCHARSET) (LET ((CHARSETHEADER (READ-BLOCK-OF-BYTES STREAM CHARSETBLOCKBYTESIZE)) RASTERINFOS FONTPRINTERWIDTHS FONTSPACINGWIDTHS FONTRASTER RAWRASTER OFFSETSBLOCK) (* |;;| "The header portion of a CharacterSet contains information such as character set number, height (which is constant for all characters), max width, ascender & descender, and font bounding box.") (* |;;| "reads the raster infos array of the character set located at charsetPos and determines bc:ec") (SETFILEPTR STREAM (+ OFFSETTOCHARSET CHARSETBLOCKBYTESIZE)) (* |;;| "The rasterinfos field is basically an array 14 bit word offsets in the fontrasters array of where each bitmap starts. The offsets are relative to the start of the fontRasters field. fontprinterwidths & fontspacingwidths are initialized to certain default values, and fontrasters starts out with a 'missing character' bitmap - a black rectangle with a one pixel white outline at each side, sitting on the baseline, and running up to the ascend of the font, such that the whole thing is exactly font height by max width in size. Bitmaps include sufficient white space so that they can be placed contiguously (or in the case of kerned ones, overlapping previous by one pixel) without additional adjustments for spacing. I.e. they are in the right format for TextBlt. Padding is added so that all FontTreeNodes and CharacterSets begin on four word boundries, for some reason that is lost in antiquity.") (SETQ RASTERINFOS (ARRAY 256 (QUOTE WORD) 0 0)) (AIN RASTERINFOS 0 (ARRAYSIZE RASTERINFOS) STREAM) (SETQ FONTPRINTERWIDTHS (ARRAY 256 (QUOTE WORD) 0 0)) (AIN FONTPRINTERWIDTHS 0 (ARRAYSIZE FONTPRINTERWIDTHS) STREAM) (SETQ FONTSPACINGWIDTHS (ARRAY 256 (QUOTE BYTE) 0 0)) (AIN FONTSPACINGWIDTHS 0 (ARRAYSIZE FONTSPACINGWIDTHS) STREAM) (|if| *WARN-ON-KERNING* |then| (LET ((KERNS (|for| I |from| 0 |to| 255 |when| (> (ELT RASTERINFOS I) 16383) |collect| I))) (|if| KERNS |then| (CL:WARN "Kerning on characters~{ ~S~}." KERNS)))) (|for| I |from| 0 |to| 255 |do| (|if| (>= (ELT FONTSPACINGWIDTHS I) (|fetch| (CHARSETBLOCK MAXWIDTH) |of| CHARSETHEADER)) |then| (|replace| (CHARSETBLOCK MAXWIDTH) |of| CHARSETHEADER |with| (ELT FONTSPACINGWIDTHS I)))) (|if| READ-RASTERS-P |then| (SETQ FONTRASTER (BITMAPCREATE (CL:* (|fetch| (CHARSETBLOCK MAXWIDTH) |of| CHARSETHEADER) 256) (|fetch| (CHARSETBLOCK HEIGHT) |of| CHARSETHEADER))) (SETFILEPTR STREAM (+ OFFSETTOCHARSET 1280 CHARSETBLOCKBYTESIZE)) (SETQ RAWRASTER (READ-BLOCK-OF-BYTES STREAM (- (CL:* BYTESPERWORD (|fetch| (CHARSETBLOCK SIZE) |of| CHARSETHEADER)) (+ 1280 CHARSETBLOCKBYTESIZE)))) (SETQ OFFSETSBLOCK (\\CREATECSINFOELEMENT)) (|for| I |from| 0 |to| 254 |bind| (OFFSET _ 0) SPACINGWIDTH |do| (|if| (OR (EQL I 0) (NOT (EQL (LOGAND (ELT RASTERINFOS I) 16383) (LOGAND (ELT RASTERINFOS 0) 16383)))) |then| (SETQ SPACINGWIDTH (+ (ELT FONTSPACINGWIDTHS I) (LOGAND (RSH (ELT RASTERINFOS I) 14) 1) (RSH (ELT RASTERINFOS I) 15))) (CL:ASSERT (< (+ OFFSET SPACINGWIDTH) (BITMAPWIDTH FONTRASTER)) NIL "Attempted to blt beyond end of bitmap") (\\TEXTBLT \\SYSPILOTBBT (\\ADDBASE RAWRASTER (LOGAND (ELT RASTERINFOS I) 16383)) SPACINGWIDTH (|fetch| (CHARSETBLOCK HEIGHT) |of| CHARSETHEADER) FONTRASTER OFFSET) (\\FSETOFFSET OFFSETSBLOCK I OFFSET) (SETQ OFFSET (+ OFFSET (ELT FONTSPACINGWIDTHS I))) |else| (\\FSETOFFSET OFFSETSBLOCK I 0)))) (CL:VALUES CHARSETHEADER FONTSPACINGWIDTHS FONTPRINTERWIDTHS (|if| READ-RASTERS-P |then| FONTRASTER |else| NIL) (|if| READ-RASTERS-P |then| OFFSETSBLOCK |else| NIL)))) ) (READ-NOVAFONT-FILEHEADER (CL:LAMBDA (STREAM) (* \; "Edited 24-Nov-86 22:41 by BRIGGS") (* |;;| "reads file header of an open viewpoint font file to determine number of fonts, allocates an array to hold their offsets from beginning of file, and reads in those font offsets. While reading it converts from WORD offsets to BYTE offsets. This function also verifies that what it is passed is a plausible NOVAFONT format file.") (LET (NFONTS FILEHEADERBUFFER FONTADDRS FILESIZE) (SETQ FILESIZE (GETEOFPTR STREAM)) (* |;;| "verify that there are enough bytes to be a plausible font file") (CL:ASSERT (>= FILESIZE FONTTREENODEBLOCKBYTESIZE) NIL "~(~A~) is not a NOVAFONT format font file." (FULLNAME STREAM)) (SETFILEPTR STREAM 0) (SETQ FILEHEADERBUFFER (READ-BLOCK-OF-BYTES STREAM FONTTREENODEBLOCKBYTESIZE)) (* |;;| "check that what we read is a plausible font file header") (CL:ASSERT (|with| FONTTREENODEBLOCK FILEHEADERBUFFER (AND (EQ ID 0) (EQ TYPE 65535) (EQL FILESIZE (+ FONTTREENODEBLOCKBYTESIZE (CL:* BYTESPERWORD (+ (CL:* 2 NCHILDREN) SIZEFILLER1 SIZECHILDREN)))))) NIL "~(~A~) is not a NOVAFONT format font file." (FULLNAME STREAM)) (SETQ NFONTS (|fetch| (FONTTREENODEBLOCK NCHILDREN) |of| FILEHEADERBUFFER)) (SETQ FONTADDRS (ARRAY NFONTS (QUOTE FIXP) 0 1)) (|for| I |from| 1 |to| NFONTS |do| (SETA FONTADDRS I (CL:* (READSWAPPEDFIXP STREAM) BYTESPERWORD))) (CL:VALUES NFONTS FONTADDRS))) ) (READ-NOVAFONT-FONTHEADER (CL:LAMBDA (STREAM FONTPOS) (* \; "Edited 6-Dec-88 10:47 by Briggs") (* |;;| "reads font header located at fontPos into fontHeaderBuffer. Returns number of character sets in ncharSets, allocates an array to hold their word offsets from beginning of font block, and reads in those offsets.") (* |;;| "reads font header located at fontBlockPos into fontHeaderBuffer. Also returns the name of the font") (LET (FONTHEADER MAXCHARSETNUMBER CHARSETADDRS FONTDESCRIPTOR NAME) (SETFILEPTR STREAM FONTPOS) (SETQ FONTHEADER (READ-BLOCK-OF-BYTES STREAM FONTTREENODEBLOCKBYTESIZE)) (SETQ MAXCHARSETNUMBER (|fetch| (FONTTREENODEBLOCK NCHILDREN) |of| FONTHEADER)) (SETQ CHARSETADDRS (ARRAY MAXCHARSETNUMBER (QUOTE FIXP) 0 0)) (SETFILEPTR STREAM (+ FONTPOS FONTTREENODEBLOCKBYTESIZE)) (|for| I |from| 0 |to| (- MAXCHARSETNUMBER 1) |do| (* |;;| "contains swapped count of 16-bit words, turn into count of number of bytes") (SETA CHARSETADDRS I (CL:* 2 (READSWAPPEDFIXP STREAM)))) (* |;;| "skip to the nodeInfo field, which is of type FontInfo") (SETFILEPTR STREAM (+ FONTPOS FONTTREENODEBLOCKBYTESIZE (CL:* 2 (+ (CL:* 2 MAXCHARSETNUMBER) (|fetch| (FONTTREENODEBLOCK SIZEFILLER1) |of| FONTHEADER))))) (CL:ASSERT (EQL (BIN16 STREAM) 3325)) (SETQ FONTDESCRIPTOR (READ-BLOCK-OF-BYTES STREAM FONTDESCRIPTIONBYTESIZE)) (BIN STREAM) (* \; "a piece of junk") (SETQ NAME (LET* ((SIZE (BIN STREAM)) (STRING (ALLOCSTRING SIZE))) (|for| I |from| 1 |to| SIZE |do| (RPLCHARCODE STRING I (BIN STREAM))) STRING)) (|if| (ZEROP (NCHARS NAME)) |then| (* |;;| "ugh! no name, try to guess from the family number") (SETQ NAME (OR (CDR (ASSOC (|fetch| (FONTDESCRIPTION FAMILY) |of| FONTDESCRIPTOR) \\NOVAFONTFAMILYNAMES)) (CONCAT "UnknownFont-" (|fetch| (FONTDESCRIPTION FAMILY) |of| FONTDESCRIPTOR))))) (CL:VALUES NAME FONTDESCRIPTOR CHARSETADDRS))) ) (\\TEXTBLT (LAMBDA (PILOTBBT |SourceHunk| |SourceWidth| |SourceHeight| |DestinationBitMap| |DestinationLeft|) (* \; "Edited 12-Mar-87 18:00 by Briggs") (\\DTEST PILOTBBT (QUOTE PILOTBBT)) (\\DTEST |DestinationBitMap| (QUOTE BITMAP)) (UNINTERRUPTABLY (|freplace| (PILOTBBT PBTFLAGS) |of| PILOTBBT |with| 0) (|freplace| (PILOTBBT PBTDESTBPL) |of| PILOTBBT |with| (UNFOLD (|ffetch| (BITMAP BITMAPRASTERWIDTH) |of| |DestinationBitMap|) BITSPERWORD)) (|freplace| (PILOTBBT PBTDESTBIT) |of| PILOTBBT |with| |DestinationLeft|) (|freplace| (PILOTBBT PBTUSEGRAY) |of| PILOTBBT |with| NIL) (* \; "the raster width of the source") (|freplace| (PILOTBBT PBTSOURCEBPL) |of| PILOTBBT |with| |SourceWidth|) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOTBBT |with| |SourceWidth|) (|freplace| (PILOTBBT PBTHEIGHT) |of| PILOTBBT |with| |SourceHeight|) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOTBBT |with| 0) (|freplace| (PILOTBBT PBTDISJOINT) |of| PILOTBBT |with| T) (|freplace| (PILOTBBT PBTSOURCE) |of| PILOTBBT |with| |SourceHunk|) (|freplace| (PILOTBBT PBTDEST) |of| PILOTBBT |with| (|ffetch| (BITMAP BITMAPBASE) |of| |DestinationBitMap|)) (\\SETPBTFUNCTION PILOTBBT (QUOTE INPUT) (QUOTE PAINT)) (\\PILOTBITBLT PILOTBBT 0))) ) ) (* |;;;| "the datastructures that we use and their sizes") (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD FONTTREENODEBLOCK ((ID FIXP) (TYPE WORD) (NCHILDREN WORD) (SIZEFILLER1 SWAPPEDFIXP) (SIZENODEINFO SWAPPEDFIXP) (SIZEFILLER2 SWAPPEDFIXP) (SIZECHILDREN SWAPPEDFIXP) (DUMMY-LAST-FIELD-DONT-REFERENCE-THIS WORD)) ) (BLOCKRECORD CHARSETBLOCK ((SIZE SWAPPEDFIXP) (VERSION WORD) (CHARSETNUM WORD) (MAXWIDTH WORD) (HEIGHT WORD) (ASCENT WORD) (DESCENT WORD) (FBBOX WORD) (FBBOY WORD) (FBBDX WORD) (FBBDY WORD) (DUMMY-LAST-FIELD-DONT-REFERENCE-THIS WORD)) ) (BLOCKRECORD FONTDESCRIPTION ((SIZE BITS 8) (WEIGHT BITS 2) (EMPHASIS BITS 1) (UNDERLINE BITS 1) (STRIKEOUT BITS 1) (PLACEMENT BITS 3) (MBZ1 BITS 1) (PITCH BITS 1) (ORNATENESS BITS 1) (FAMILY BITS 12) (MBZ2 BITS 1) (MBZ3 BITS 1) (OFFSET BITS 14) (MBZ4 BITS 1) (MBZ5 BITS 1) (DOUBLEUNDERLINE BITS 1) (UNUSED BITS 14) (DUMMY-LAST-FIELD-DONT-REFERENCE-THIS WORD)) ) ) (DECLARE\: EVAL@COMPILE (RPAQ FONTTREENODEBLOCKBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (FONTTREENODEBLOCK DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (RPAQ CHARSETBLOCKBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (CHARSETBLOCK DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (RPAQ FONTDESCRIPTIONBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (FONTDESCRIPTION DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (CONSTANTS (FONTTREENODEBLOCKBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (FONTTREENODEBLOCK DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (CHARSETBLOCKBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (CHARSETBLOCK DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T))))) (FONTDESCRIPTIONBYTESIZE (CONSTANT (ITIMES BYTESPERWORD (INDEXF (FETCH (FONTDESCRIPTION DUMMY-LAST-FIELD-DONT-REFERENCE-THIS) OF T)))))) ) ) (DECLARE\: EVAL@COMPILE DONTEVAL@LOAD DOCOPY ) (* |;;;| "the mapping from font family number to font family name for those fonts which don't have the name embedded in the font file." ) (DECLARE\: EVAL@COMPILE (RPAQQ \\NOVAFONTFAMILYNAMES ((0 . |Classic|) (1 . |Modern|) (2 . |Titan|) (3 . |Pica|) (4 . |Trojan|) (5 . |Vintage|) (6 . |Elite|) (7 . |LetterGothic|) (8 . |Master|) (9 . |Cubic|) (10 . |Roman|) (11 . |Scientific|) (12 . |Gothic|) (13 . |Bold|) (14 . |OcrB|) (15 . |Spokesman|) (16 . |XeroxLogo|) (17 . |CenturyThin|) (18 . |ScientificThin|) (19 . |Helvetica|) (20 . |HelveticaCondensed|) (21 . |Optima|) (22 . |Times|) (23 . |Baskerville|) (24 . |Spartan|) (25 . |Bodoni|) (26 . |Palatino|) (27 . |Caledonia|) (28 . |Memphis|) (29 . |Excelsior|) (30 . |Olympian|) (31 . |Univers|) (32 . |UniversCondensed|) (33 . |Trend|) (34 . |BoxPS|) (35 . |Terminal|) (36 . |OcrA|) (37 . |Logo1|) (38 . |Logo2|) (39 . |Logo3|) (40 . |Geneva2|) (41 . |Times2|) (42 . |Square3|) (43 . |Courier|) (44 . |Futura|) (45 . |Prestige|) (46 . |ALLetterGothic|) (47 . |CenturySchoolBook|) (48 . |Spare1|) (49 . |Spare2|) (50 . |Spare3|) (51 . |Spare4|) (52 . |Spare5|) (53 . |Melior|) (54 . |PCTerminal|) (55 . |ITCAmericanTypewriter|) (56 . |ITCAvantGardeGothic|) (57 . |ITCAvantGardeGothicCondensed|) (58 . |ITCBauhaus|) (59 . |ITCBarcelona|) (60 . |ITCBenguiat|) (61 . |ITCBenguiatCondensed|) (62 . |ITCBenguiatGothic|) (63 . |ITCBerkeleyOldStyle|) (64 . |ITCBookman|) (65 . |ITCCaslonNo224|) (66 . |ITCCentury|) (67 . |ITCCheltenham|) (68 . |ITCClearface|) (69 . |ITCCushing|) (70 . |ITCEras|) (71 . |ITCFenice|) (72 . |ITCFranklinGothic|) (73 . |ITCFrizQuadrata|) (74 . |ITCGalliard|) (75 . |ITCGaramond|) (76 . |ITCIsbell|) (77 . |ITCItalia|) (78 . |ITCKabel|) (79 . |ITCKorinna|) (80 . |ITCLubalinGraph|) (81 . |ITCModernNo216|) (82 . |ITCNewBaskerville|) (83 . |ITCNewtext|) (84 . |ITCNovarese|) (85 . |ITCQuorum|) (86 . |ITCSerifGothic|) (87 . |ITCSouvenir|) (88 . |ITCSymbol|) (89 . |ITCTiffany|) (90 . |ITCUsherwood|) (91 . |ITCWeidemann|) (92 . |ITCVeljovic|) (93 . |ITCZapfBook|) (94 . |ITCZapfChancery|) (95 . |ITCZapfDingbats|) (96 . |ITCZapfInternational|) (97 . |Cipher|) (98 . |FlemishScriptII|) (99 . |Quartz|) (100 . |QuartzA|) (101 . |QuartzT|) (102 . |Souvenir|) (103 . |Shimmer|) (104 . APL) (105 . |Arrows|) (106 . |BravoX|) (107 . |ClassicPiOne|) (108 . |ClassicPiTwo|) (109 . |Cream|) (110 . |Cyrillic|) (111 . |Dots|) (112 . |Gacha|) (113 . |Gates|) (114 . |HelveticaD|) (115 . |Hippo|) (116 . |Keyhole|) (117 . |Laurel|) (118 . |LogoOutline|) (119 . |LSIGates|) (120 . |MarqHippo|) (121 . |MarqRoman|) (122 . |Math|) (123 . |Mathology|) (124 . |OldEnglish|) (125 . |RomanPS|) (126 . |Sigma|) (127 . |Splunk|) (128 . |Template|) (129 . |Testfont|) (130 . |TimesRoman|) (131 . |TimesRomanD|) (132 . |TitanLegal|) (133 . WSSA) (134 . |XeroxBook|) (135 . |LucidaRoman|) (136 . |MonoSpace|) (137 . |Spare6|) (138 . |Spare7|) (139 . |Spare8|) (140 . |Spare9|) (141 . |Spare10|))) (CONSTANTS \\NOVAFONTFAMILYNAMES) ) (* |;;;| "initialize the \"noticed\" fonts structure and set up the extensions so we can use the font files") (DEFGLOBALVAR *NOVAFONT-INFO* NIL) (* |;;;| "correct some omissions in the family aliases and printwheel fonts") (LISTPUT INTERPRESSFAMILYALIASES (QUOTE XEROXLOGO) (QUOTE LOGOTYPES-XEROX)) (|pushnew| INTERPRESSPRINTWHEELFAMILIES (QUOTE SCIENTIFICTHIN) (QUOTE OCRB) (QUOTE OCRA)) (* |;;;| "some things we need for compiling. Also need EXPORTS.ALL") (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) INTERPRESS LLCHAR) ) (* |;;;| "install this:") (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? (QUOTE \\READDISPLAYFONTFILE) (QUOTE \\NO-NOVA-READDISPLAYFONTFILE)) (MOVD? (QUOTE \\CREATECHARSET.IP) (QUOTE \\NO-NOVA-CREATECHARSET.IP)) (MOVD (QUOTE \\READDISPLAYFONTFILE.NOVA) (QUOTE \\READDISPLAYFONTFILE)) (MOVD (QUOTE \\CREATECHARSET.IP.NOVA) (QUOTE \\CREATECHARSET.IP)) ) (* |;;;| "some hints for the compiler (system generated)") (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA READ-NOVAFONT-FONTHEADER READ-NOVAFONT-FILEHEADER) ) (PUTPROPS NOVAFONT COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3332 8259 (NOTICE-NOVAFONT-FILE 3342 . 5349) (LOAD-NOVAFONT-FILE 5351 . 8257)) (8326 15596 (\\READNOVAFONTFILE.DISPLAY 8336 . 14151) (\\READNOVAFONTFILE.IP 14153 . 15594)) (15686 16980 ( \\READDISPLAYFONTFILE.NOVA 15696 . 16322) (\\CREATECHARSET.IP.NOVA 16324 . 16978)) (17053 22158 ( DESCRIBE-FONT 17063 . 17758) (SELECT-FONT 17760 . 17991) (ENUMERATE-FONTS 17993 . 20522) ( VIEWPOINT-FONT-FILE-P 20524 . 22156)) (22744 31254 (READ-BLOCK-OF-BYTES 22754 . 23098) ( READ-NOVAFONT-CHARACTERSET 23100 . 26783) (READ-NOVAFONT-FILEHEADER 26785 . 28188) ( READ-NOVAFONT-FONTHEADER 28190 . 30034) (\\TEXTBLT 30036 . 31252))))) STOP \ No newline at end of file diff --git a/lispusers/NOVAFONT.TEDIT b/lispusers/NOVAFONT.TEDIT new file mode 100644 index 00000000..56ccd192 Binary files /dev/null and b/lispusers/NOVAFONT.TEDIT differ diff --git a/lispusers/NSALLOCATION b/lispusers/NSALLOCATION new file mode 100644 index 00000000..fd3bdbdb --- /dev/null +++ b/lispusers/NSALLOCATION @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "19-Feb-88 19:27:57" {QV}LISP>NSALLOCATION.\;3 6361 |changes| |to:| (FNS NSALLOCATION.STATS NSALLOCATION) |previous| |date:| "19-Feb-88 18:05:54" {QV}LISP>NSALLOCATION.\;1) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT NSALLOCATIONCOMS) (RPAQQ NSALLOCATIONCOMS ((FNS NSALLOCATION NSALLOCATION.STATS))) (DEFINEQ (NSALLOCATION (LAMBDA (|FileServers| |ReportFile| |Filter|) (* \; "Edited 19-Feb-88 18:10 by bbb") (LET ((|NSDiskSizeInPages| 433907) |ReportFileStream|) (CL:WITH-OPEN-FILE (|ReportFileStream| |ReportFile| :DIRECTION :OUTPUT) (|if| |Filter| |then| (|printout| |ReportFileStream| "Using Filter " |Filter| T T)) (|printout| |ReportFileStream| .FONT '(TERMINAL 12) "File Service" .TAB 20 "# Pages Used" .TAB 35 "as %" .TAB 45 "# Pages Used" .TAB 60 "as %" .TAB 70 "# Pages" .TAB 80 "as %" .TAB 90 "Total % Used" T) (|printout| |ReportFileStream| "Name" .TAB 20 "Unrestricted" .TAB 35 "of disk" .TAB 45 "Restricted" .TAB 60 "of alloc" .TAB 70 "alloc" .TAB 80 "of disk" .TAB 90 "of disk" T) (|printout| |ReportFileStream| "----------------" .TAB 20 "------------" .TAB 35 "-------" .TAB 45 "------------" .TAB 60 "--------" .TAB 70 "-------" .TAB 80 "-------" .TAB 90 "------------" T) (|printout| |ReportFileStream| T) (|for| |Server| |in| |FileServers| |bind| |Result| |PagesUnrestricted| |PagesRestricted| |PagesAllocated| |PercentUnrestricted| |PercentRestrictedofAllocated| |PercentAllocated| |TotalPercentUsed| |when| (SETQ |Result| (NSALLOCATION.STATS |Server| |Filter|)) |do| (SETQ |PagesUnrestricted| (CAR (NTH |Result| 1))) (SETQ |PagesRestricted| (CAR (NTH |Result| 2))) (SETQ |PagesAllocated| (CAR (NTH |Result| 3))) (SETQ |PercentUnrestricted| (TIMES (FQUOTIENT |PagesUnrestricted| |NSDiskSizeInPages|) 100.0)) (SETQ |PercentRestrictedofAllocated| (TIMES (FQUOTIENT |PagesRestricted| |PagesAllocated|) 100.0)) (SETQ |PercentAllocated| (TIMES (FQUOTIENT |PagesAllocated| |NSDiskSizeInPages|) 100.0)) (SETQ |TotalPercentUsed| (TIMES (FQUOTIENT (PLUS |PagesUnrestricted| |PagesRestricted|) |NSDiskSizeInPages|) 100.0)) (|printout| |ReportFileStream| |Server| .TAB 20 |.I12| |PagesUnrestricted| .TAB 35 |.F7.1| |PercentUnrestricted| .TAB 45 |.I12| |PagesRestricted| .TAB 60 |.F8.2| |PercentRestrictedofAllocated| .TAB 70 |.I7| |PagesAllocated| .TAB 80 |.F7.1| |PercentAllocated| .TAB 90 |.F12.1| |TotalPercentUsed| T)))))) (NSALLOCATION.STATS (LAMBDA (|FileServiceName| |Filter|) (* \; "Edited 19-Feb-88 19:20 by bbb") (* |;;|  "Given a file service name the following three pieces of data are returned in a list: ") (* |;;| " 1) number of pages in use of unrestricted file drawers") (* |;;| " 2) number of pages in use in restricted file drawers") (* |;;| " 3) number of pages allocated to file drawers") (* |;;| "") (* |;;| " If Filter is NON-NIL then it is used as a file pattern for selecting directories") (LET* ((|FileServiceDirectories| (DIRECTORY (CONCAT "{" |FileServiceName| "}") 'COLLECT)) (|FileServiceDevice| (\\GETDEVICEFROMNAME |FileServiceName|)) (|NumBytesUnrestricted| 0) (|NumBytesRestricted| 0) (|NumBytesAllocated| 0) (|BytesPerPage| 512) (|Filter| (|if| |Filter| |then| (DIRECTORY.MATCH.SETUP |Filter|)))) (|for| |Directory| |in| |FileServiceDirectories| |bind| |DirectoryAllocation| |DirectoryUsed| |when| (OR (NULL |Filter|) (DIRECTORY.MATCH |Filter| |Directory|)) |do| (SETQ |DirectoryAllocation| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE.LIMIT |FileServiceDevice|)) (SETQ |DirectoryUsed| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE |FileServiceDevice|)) (|if| (IGEQ |DirectoryAllocation| 0) |then| (|add| |NumBytesAllocated| |DirectoryAllocation|) (|add| |NumBytesRestricted| |DirectoryUsed|) |else| (|add| |NumBytesUnrestricted| |DirectoryUsed|))) (LIST (FQUOTIENT |NumBytesUnrestricted| |BytesPerPage|) (FQUOTIENT |NumBytesRestricted| |BytesPerPage|) (FQUOTIENT |NumBytesAllocated| |BytesPerPage|))))) ) (PUTPROPS NSALLOCATION COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (457 6277 (NSALLOCATION 467 . 3985) (NSALLOCATION.STATS 3987 . 6275))))) STOP \ No newline at end of file diff --git a/lispusers/NSCOPYFILE b/lispusers/NSCOPYFILE new file mode 100644 index 00000000..89187667 --- /dev/null +++ b/lispusers/NSCOPYFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "10-Dec-87 11:40:53" {ERIS}LISP>NSCOPYFILE.;3 2187 changes to%: (FNS NSCOPYFILE) previous date%: " 9-Oct-87 17:35:59" {ERIS}LISP>NSCOPYFILE.;2) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSCOPYFILECOMS) (RPAQQ NSCOPYFILECOMS ((FNS NSCOPYFILE) (PROP FILETYPE NSCOPYFILE) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE)) (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) (AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T))))) ) (DEFINEQ (NSCOPYFILE (LAMBDA (FROMFILE TOFILE DESTPARAMETERS) (* ; "Edited 10-Dec-87 11:40 by bvm:") (* ;; "Special version of COPYFILE that lets NS servers do efficient or information-preserving copy. Perhaps COPYFILE will be a device method some day.") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FROMDEV TODEV) (if (AND (NULL DESTPARAMETERS) (NOT (NULL TOFILE)) (NEQ TOFILE T) (SETQ FROMDEV (\GETDEVICEFROMNAME (SETQ FROMFILE (\ADD.CONNECTED.DIR (if (TYPEP FROMFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME FROMFILE) else FROMFILE))))) (EQ (fetch (FDEV OPENFILE) of FROMDEV) (FUNCTION \NSFILING.OPENFILE)) (SETQ TODEV (\GETDEVICEFROMNAME (SETQ TOFILE (\ADD.CONNECTED.DIR (if (TYPEP TOFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME TOFILE) else TOFILE))))) (EQ (fetch (FDEV OPENFILE) of TODEV) (FUNCTION \NSFILING.OPENFILE))) then (* ; "Both source and destination are NS servers.") (\NSFILING.COPYFILE FROMDEV FROMFILE TODEV TOFILE) else (\GENERIC.COPYFILE FROMFILE TOFILE DESTPARAMETERS)))) ) ) (PUTPROPS NSCOPYFILE FILETYPE :COMPILE-FILE) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE)) (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) (AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T)) ) (PUTPROPS NSCOPYFILE COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (738 1735 (NSCOPYFILE 748 . 1733))))) STOP \ No newline at end of file diff --git a/lispusers/NSCOPYFILE.TEDIT b/lispusers/NSCOPYFILE.TEDIT new file mode 100644 index 00000000..95bc9dd9 Binary files /dev/null and b/lispusers/NSCOPYFILE.TEDIT differ diff --git a/lispusers/NSDISPLAYSIZES b/lispusers/NSDISPLAYSIZES new file mode 100644 index 00000000..eccdd5cd --- /dev/null +++ b/lispusers/NSDISPLAYSIZES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "14-Sep-96 09:32:32" {DSK}medley2.0>lispusers>NSDISPLAYSIZES.;13 8499 changes to%: (FNS NSDISPLAYSIZE PURGENSFONTS) (VARS NSDISPLAYSIZESCOMS) previous date%: "16-Nov-95 10:10:26" {DSK}medley2.0>lispusers>NSDISPLAYSIZES.;9) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1993, 1995, 1996 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSDISPLAYSIZESCOMS) (RPAQQ NSDISPLAYSIZESCOMS [(FNS NSDISPLAYSIZE NS\FONTFILENAME NS\FONTFILENAME.OLD PURGENSFONTS) (ADDVARS (NSFONTFAMILIES CLASSIC MODERN TERMINAL OPTIMA TITAN)) (INITVARS (*SMALLSCREEN* (ILESSP SCREENWIDTH 700))) [COMS (* ;  "VirtualKeyboard font needs adjusting so that real Classic 12 still appears") (FNS VKBD.FIX.FONT) (DECLARE%: EVAL@COMPILE DONTCOPY (P (OR (RECLOOK 'KEYBOARDCONFIGURATION) (LOADDEF 'KEYBOARDCONFIGURATION 'RECORDS 'VIRTUALKEYBOARDS] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? '\FONTFILENAME 'OLD\FONTFILENAME) (MOVD 'NS\FONTFILENAME '\FONTFILENAME) (MOVD? '\FONTFILENAME.OLD 'OLD\FONTFILENAME.OLD) (MOVD 'NS\FONTFILENAME.OLD '\FONTFILENAME.OLD) (PURGENSFONTS) (VKBD.FIX.FONT]) (DEFINEQ (NSDISPLAYSIZE [LAMBDA (FAMILY SIZE FACE EXTENSION) (* ; "Edited 14-Sep-96 09:32 by rmk:") (* ; "Edited 16-Nov-95 10:08 by ") (* ;  "Edited 5-Mar-93 18:12 by kaplan") (* ; "Edited 15-Jan-87 15:22 by bvm:") (* ;; "Returns size that we would prefer to see the font of requested family, size, face, extension. Used to make bigger ns display fonts than you would get by default. Don't do it for small screens, as on DOS and laptops.") (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS NSFONTFAMILIES)) (OR (AND (CL:MEMBER EXTENSION DISPLAYFONTEXTENSIONS :TEST 'STRING-EQUAL) (COND (*SMALLSCREEN* (CL:UNLESS (CL:MEMBER FAMILY NSFONTFAMILIES :TEST 'STRING-EQUAL) (* ;  " Small screen, shrink non-NS fonts ") (SELECTQ SIZE (12 10) (10 8) (8 6) NIL))) ((CL:MEMBER FAMILY NSFONTFAMILIES :TEST 'STRING-EQUAL) (* ; "Large screen, enlarge NS fonts") (AND (SELECTQ SIZE (12 (COND ((STRING-EQUAL FAMILY 'TERMINAL) (* ; "Until Terminal 14 exists") 12) (T 14))) (10 12) (8 10) (6 8) NIL))) ((AND NIL (CL:MEMBER EXTENSION INTERPRESSFONTEXTENSIONS :TEST 'STRING-EQUAL) (STRING-EQUAL FAMILY 'SYMBOL)) (* ;  "Fake NS size on Interpress printing, even tho display fonts don't exist") 10))) SIZE]) (NS\FONTFILENAME [LAMBDA (FAMILY SIZE FACE EXTENSION CHARACTERSET) (* ; "Edited 15-Jan-87 15:23 by bvm:") (OLD\FONTFILENAME FAMILY (NSDISPLAYSIZE FAMILY SIZE FACE EXTENSION) FACE EXTENSION CHARACTERSET]) (NS\FONTFILENAME.OLD [LAMBDA (FAMILY SIZE FACE EXTENSION CHARACTERSET) (* ; "Edited 15-Jan-87 15:29 by bvm:") (OLD\FONTFILENAME.OLD FAMILY (NSDISPLAYSIZE FAMILY SIZE FACE EXTENSION) FACE EXTENSION CHARACTERSET]) (PURGENSFONTS [LAMBDA (TYPES) (* ; "Edited 14-Sep-96 09:27 by rmk:") (* ; "Edited 14-Dec-87 14:53 by bvm:") (/SETTOPVAL '\FONTSINCORE (FOR ENTRY IN \FONTSINCORE BIND BADTYPES TMP COLLECT (SETQ BADTYPES (IF (AND (MEMB (CAR ENTRY) NSFONTFAMILIES) (OR (NULL TYPES) (EQMEMB 'NS TYPES))) THEN (CONS 'DISPLAY TYPES) ELSE (MKLIST TYPES))) (CONS (CAR ENTRY) (FOR SIZES IN (CDR ENTRY) WHEN [SETQ TMP (IF (AND (NULL TYPES) (> (CAR SIZES) 12)) THEN (* ;  "Only have to get rid of sizes smaller than 14") (CDR SIZES) ELSE (FOR FACE IN (CDR SIZES) WHEN (SETQ TMP (FOR ROT IN (CDR FACE) WHEN (SETQ TMP (FOR DEV IN (CDR ROT) COLLECT DEV UNLESS (MEMB (CAR DEV) BADTYPES))) COLLECT (CONS (CAR ROT) TMP))) COLLECT (CONS (CAR FACE) TMP] COLLECT (CONS (CAR SIZES) TMP]) ) (ADDTOVAR NSFONTFAMILIES CLASSIC MODERN TERMINAL OPTIMA TITAN) (RPAQ? *SMALLSCREEN* (ILESSP SCREENWIDTH 700)) (* ; "VirtualKeyboard font needs adjusting so that real Classic 12 still appears") (DEFINEQ (VKBD.FIX.FONT [LAMBDA (NEWFONT) (* ; "Edited 9-Mar-93 14:03 by rmk:") (* ; "Edited 1-Jul-88 16:55 by bvm") (* ;; "Change the VirtualKeyboard's configuration definitions to use NEWFONT (default Classic 10). The original font is Classic 12, but with NSDISPLAYSIZES loaded, that coerces to Classic 14, so we have to fool it by setting it back a notch.") [SETQ DEFAULTKEYBOARDDISPLAYFONT (OR NEWFONT (SETQ NEWFONT '(CLASSIC 10] (for X in (LISTP (EVALV 'VKBD.CONFIGURATIONS)) do (replace (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) of X with DEFAULTKEYBOARDDISPLAYFONT ]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (OR (RECLOOK 'KEYBOARDCONFIGURATION) (LOADDEF 'KEYBOARDCONFIGURATION 'RECORDS 'VIRTUALKEYBOARDS)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? '\FONTFILENAME 'OLD\FONTFILENAME) (MOVD 'NS\FONTFILENAME '\FONTFILENAME) (MOVD? '\FONTFILENAME.OLD 'OLD\FONTFILENAME.OLD) (MOVD 'NS\FONTFILENAME.OLD '\FONTFILENAME.OLD) (PURGENSFONTS) (VKBD.FIX.FONT) ) (PUTPROPS NSDISPLAYSIZES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1993 1995 1996)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1696 6738 (NSDISPLAYSIZE 1706 . 4036) (NS\FONTFILENAME 4038 . 4279) ( NS\FONTFILENAME.OLD 4281 . 4530) (PURGENSFONTS 4532 . 6736)) (6950 7988 (VKBD.FIX.FONT 6960 . 7986)))) ) STOP \ No newline at end of file diff --git a/lispusers/NSDISPLAYSIZES.TEDIT b/lispusers/NSDISPLAYSIZES.TEDIT new file mode 100644 index 00000000..ff7e2b08 Binary files /dev/null and b/lispusers/NSDISPLAYSIZES.TEDIT differ diff --git a/lispusers/NSPROTECTION b/lispusers/NSPROTECTION new file mode 100644 index 00000000..a4e3ee71 --- /dev/null +++ b/lispusers/NSPROTECTION @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Nov-87 12:34:18" {ERIS}LISP>NSPROTECTION.;21 30480 changes to%: (FNS NSPROT.FETCH.PROTECTION NSPROT.SET.TO.DEFAULT NSPROT.TOP.LEVELP) (VARS NSPROTECTIONCOMS) previous date%: " 2-Sep-87 15:03:55" {ERIS}LISP>NSPROTECTION.;20) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSPROTECTIONCOMS) (RPAQQ NSPROTECTIONCOMS ((COMS (* ; "Main window selection handlers") (FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND) (FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST NSPROT.EXPAND.FULLNAME)) (COMS (* ; "Handle protection submenus") (FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE)) (COMS (* ; "utilities") (FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN)) (INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT) (VARS NSPROT.ICON) (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) (LOCALVARS . T) (COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)))) (FNS ADD.NSPROTECTION) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION)))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NSPROT.PROMPT)))) ) (* ; "Main window selection handlers") (DEFINEQ (NSPROTECTION (LAMBDA NIL (* ; "Edited 1-Sep-87 10:31 by bvm:") (* ;; "Main entry--create the NS protection tool main window and prompt window.") (LET* ((PLAINFONT (NSPROT.GET.FONT)) (BOLDFONT (NSPROT.GET.FONT T)) (HEIGHTDIFFERENCE (- (FONTPROP BOLDFONT (QUOTE HEIGHT)) (FONTPROP PLAINFONT (QUOTE HEIGHT)))) (W (FREEMENU (BQUOTE ((PROPS COLUMNSPACE 14 FONT (\, BOLDFONT)) ((LABEL "Show" SELECTEDFN NSPROT.SHOW MESSAGE "Show the current protection of the specified directory/file.") (LABEL "New Entry" SELECTEDFN NSPROT.NEW.ENTRY MESSAGE "Add a new protection entry (you fill it in).") (LABEL "Apply" SELECTEDFN NSPROT.APPLY MESSAGE "Apply the indicated protections to the file.") (LABEL "Set to Default" SELECTEDFN NSPROT.SET.TO.DEFAULT MESSAGE "Make the file inherit protection from its parent (sub)directory." MAXWIDTH 275)) ((PROPS COLUMNSPACE 4) (LABEL "Type:" TYPE STATE CHANGESTATE NSPROT.HANDLE.TYPE INITSTATE "Principal" MESSAGE "Show directory's own protection, or default for its children? (can be different)" ID TYPE LINKS (DISPLAY PROTECTION-TYPE)) (LABEL "" TYPE DISPLAY ID PROTECTION-TYPE FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "Children Only " PLAINFONT))) (LABEL "Check:" TYPE STATE CHANGESTATE NSPROT.HANDLE.VERIFY INITSTATE "New Names Only" MESSAGE "Check names in protection entries against Clearinghouse?" ID CHECK LINKS (DISPLAY VERIFYFLG)) (LABEL "" TYPE DISPLAY ID VERIFYFLG FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "New Names Only" PLAINFONT)))) ((PROPS COLUMNSPACE (\, (+ 6 (- (STRINGWIDTH "Dir/File:" BOLDFONT) (STRINGWIDTH "Host:" BOLDFONT))))) (LABEL "Host:" TYPE EDITSTART MESSAGE "Fill in the name of the NS file server" LINKS (EDIT HOST)) (LABEL (\, (CONCAT)) TYPE EDIT ID HOST LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))) ((PROPS COLUMNSPACE 6) (LABEL "Dir/File:" TYPE EDITSTART MESSAGE "Fill in the name of the desired directory or file." LINKS (EDIT DIR)) (LABEL (\, (CONCAT)) TYPE EDIT ID DIR LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))))) "NS File Protection Tool")) (REG (WINDOWREGION W)) PW) (* ;; "The HEIGHTDIFFERENCE hacking is to get the baselines of the bold and plain fonts to line up (odd that they don't already). (CONCAT) instead of %"%" to ease my pain of debugging--otherwise, the edit items would all be fat, and Lyric's Courier doesn't handle that gracefully.") (WINDOWPROP W (QUOTE FM.DONTRESHAPE) T) (WINDOWPROP W (QUOTE MINSIZE) (CONS (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG))) (* ; "Don't let window shape any smaller than it is.") (WINDOWPROP W (QUOTE VERIFYFLG) :NEW) (WINDOWPROP W (QUOTE PROTECTION-TYPE) T) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION NSPROT.ICONFN)) (MOVEW W (GETBOXPOSITION (fetch (REGION WIDTH) of REG) (+ (fetch (REGION HEIGHT) of REG) (HEIGHTIFWINDOW (FONTPROP PLAINFONT (QUOTE HEIGHT)))))) (OPENW W) (SETQ PW (GETPROMPTWINDOW W NIL PLAINFONT)) (* ; "Arrange for prompt window to expand itself by one line at a time if it overflows") (WINDOWPROP PW (QUOTE PAGEFULLFN) (QUOTE NSPROT.PAGEFULLFN)) (WINDOWPROP W (QUOTE FM.PROMPTWINDOW) PW) NIL)) ) (NSPROT.SHOW (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 1-Sep-87 10:50 by bvm:") (LET ((DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) OLDWINDOWS) (if DEV&FILESPEC then (NSPROT.REMOVE.SUBMENUS WINDOW) (CL:MULTIPLE-VALUE-BIND (PROT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.FETCH.PROTECTION WINDOW DEV FILESPEC))) (if CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION) ELSE (for P in PROT do (NSPROT.SHOW.PROT.VALUE P WINDOW))) (NSPROT.RESTORE.VERIFY WINDOW))))) ) (NSPROT.FETCH.PROTECTION (LAMBDA (WINDOW DEV FILESPEC) (* ; "Edited 20-Nov-87 12:27 by bvm:") (* ;; "Return the access list of FILESPEC on DEV of the flavor requested by window (or implicitly by the filespec being a non-directory). This fn prints its own messages when the defaulting is interesting.") (if (SETQ FILESPEC (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) then (LET* ((TYPE (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE ACCESS.LIST))) (DIRP (NSPROT.DIRECTORY.SYNTAXP FILESPEC)) (DESIREDPROPS (if DIRP then (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)) (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST)))) else (LIST (\FILING.ATTRIBUTE.TYPE TYPE)))) (PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) PROT OTHER) (DECLARE (CL:SPECIAL DESIREDPROPS)) (* ; "Go thru internal filing interface in order to intercept errors and get more than one attribute at once. DESIREDPROPS is used free under \nsfiling.get/setinfo.") (if (EQ (CAR PROPS) (QUOTE ERROR)) then (NSPROT.PROMPT WINDOW "Failed: ~A" (CADDR PROPS)) elseif (NULL (SETQ PROT (CADR (ASSOC TYPE PROPS)))) then (NSPROT.PROMPT WINDOW "Failed to fetch protection.") else (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ OTHER (CADR (ASSOC (QUOTE DEFAULT.ACCESS.LIST) PROPS))) (NOT (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))) then (* ; "We're fetching the principal access list for a directory, but it has a non-defaulted DEFAULT.ACCESS.LIST, so warn user") (NSPROT.PROMPT WINDOW "Note: this ~:[~;protection is inherited, but the ~]directory has a separate default protection for its children." (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT)) elseif (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT) then (* ; "defaulted value, explain.") (if (EQ TYPE (QUOTE ACCESS.LIST)) then (NSPROT.PROMPT WINDOW "The protection shown is inherited from the parent.") else (NSPROT.PROMPT WINDOW "This is the directory's principal protection~:[~;, which is itself inherited~]." (AND (SETQ OTHER (CADR (ASSOC (QUOTE ACCESS.LIST) PROPS))) (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))))) (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (NSPROT.TOP.LEVELP FILESPEC)) then (* ; "Top-level directory, also give usage stats.") (SETQ DESIREDPROPS (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE)) (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE.LIMIT))))) (SETQ PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) (if (AND PROPS (NEQ (CAR PROPS) (QUOTE ERROR))) then (LET ((USED (CADR (ASSOC (QUOTE SUBTREE.SIZE) PROPS))) (LIMIT (CADR (ASSOC (QUOTE SUBTREE.SIZE.LIMIT) PROPS)))) (NSPROT.PROMPT WINDOW "~&Directory contains ~D pages ~:[(unlimited allocation)~;out of ~:*~D allocated~]" (FOLDHI USED BYTESPERPAGE) (AND (>= LIMIT 0) (FOLDHI LIMIT BYTESPERPAGE)))))) (COURIER.FETCH (FILING . ACCESS.LIST) ENTRIES of PROT))))) ) (NSPROT.NEW.ENTRY (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 16:14 by bvm:") (* ;; "Handles the NEW ENTRY button -- adds another protection entry and starts editing the name field of it") (NSPROT.BEGIN.COMMAND WINDOW) (LET* ((SUBW (NSPROT.GET.SUBMENU WINDOW)) (NAMEITEM (FM.GETITEM (QUOTE NAME) NIL SUBW))) (FM.CHANGESTATE (FM.GETITEM (QUOTE READ) NIL SUBW) T SUBW) (* ; "Initial protection = READ") (FM.CHANGELABEL NAMEITEM (CONCAT) SUBW) (* ; "Initial name is empty") (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) NIL) (* ; "erase any previous cache") (NSPROT.ADD.SUBMENU SUBW WINDOW) (FM.EDITITEM NAMEITEM SUBW))) ) (NSPROT.APPLY (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 14:38 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm setting the displayed protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) (SETQ PROT (NSPROT.PARSE.PROTECTIONS WINDOW))) then (if (AND (NULL (SETQ PROT (CAR PROT))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW "Can't set empty protection.") elseif (AND (for PAIR in PROT never (MEMB (QUOTE OWNER) (CADR PAIR))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW T "Can't: Somebody must retain owner access.") else (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC PROT))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION)))) (NSPROT.RESTORE.VERIFY WINDOW)))) ) (NSPROT.SET.PROTECTION (LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 31-Aug-87 18:22 by bvm:") (if (STRPOS "*" FILESPEC) then (NSPROT.SET.MULTIPLE WINDOW DEV FILESPEC PROT) elseif (NULL (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) elseif (NSPROT.SET.PROTECTION.ONE DEV FILESPEC PROT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) then (NSPROT.PROMPT WINDOW "Done, ~:[~;children's default ~]protection set ~A." (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (if (EQ PROT T) then "to default" else "as shown")) else (NSPROT.PROMPT WINDOW "Failed to set protection."))) ) (NSPROT.SET.PROTECTION.ONE (LAMBDA (DEV FILESPEC PROT DEFAULTP) (* ; "Edited 27-Aug-87 13:51 by bvm:") (* ;; "Performs the filing call that sets the protection of FILESPEC on DEV to be PROT. PROT=T means default protection. DEFAULTP = NIL means access, T means default access.") (if (EQ PROT T) then (* ; "Set to default protection. Can't do this in the obvious way, because the PROTECTION attribute hides the hair about defaulted") (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))) else (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)))) (CONSTANT (COURIER.WRITE.REP (COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T) (QUOTE FILING) (QUOTE ACCESS.LIST))) DEV) else (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE PROTECTION)) PROT DEV))) ) (NSPROT.SET.MULTIPLE (LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 27-Aug-87 15:29 by bvm:") (if (NSPROT.RESTORE.TYPE WINDOW) then (NSPROT.PROMPT WINDOW "(Will set Principal protection) ")) (NSPROT.PROMPT WINDOW "Enumerating...") (LET ((FILES (RESETLST (LET* ((FILING.ENUMERATION.DEPTH MAX.SMALLP) (GEN (\GENERATEFILES FILESPEC (QUOTE (FILE.ID)) (QUOTE (RESETLST)))) FILE) (DECLARE (CL:SPECIAL FILING.ENUMERATION.DEPTH)) (* ; "sets depth to infinity without telling the generator to filter out directories.") (while (SETQ FILE (\GENERATENEXTFILE GEN)) collect (NSPROT.PROMPT WINDOW T "~A" (SETQ FILE (CDR (NSPROT.STRIP.HOST FILE)))) (LIST (\GENERATEFILEINFO GEN (QUOTE FILE.ID)) (\GENERATEFILEINFO GEN (QUOTE IS.DIRECTORY)) FILE)))))) (if (NULL FILES) then (NSPROT.PROMPT WINDOW "no files match the pattern.") else (NSPROT.PROMPT WINDOW T "Setting...") (for F in FILES bind (OK _ 0) (FAILED _ 0) do (* ;; "Set explicit protection for file with this id. If it's a directory, also set its default access list to defaulted.") (if (AND (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) PROT) (OR (NULL (CADR F)) (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) T T))) then (add OK 1) else (add FAILED 1) (NSPROT.PROMPT WINDOW T "Failed on ~A" (CADDR F))) finally (NSPROT.PROMPT WINDOW T "Done, set ~A on ~D files~:[~; out of ~D~]." (if (EQ PROT T) then "default protection" else "the displayed protection") OK (NEQ FAILED 0) (+ OK FAILED)))))) ) (NSPROT.SET.TO.DEFAULT (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm restoring the file to inherited protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW))) then (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (if (AND (NSPROT.TOP.LEVELP FILESPEC) (NOT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) THEN (* ; "Dangerous operation!") (NSPROT.PROMPT WINDOW "Can't set top-level directory to default protection.") ELSE (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC T)))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION))) (NSPROT.RESTORE.VERIFY WINDOW)))) ) (NSPROT.BEGIN.COMMAND (LAMBDA (WINDOW) (* ; "Edited 20-Aug-87 17:35 by bvm:") (* ;; "Begin a new command. Clear old prompt window, if any, and stop any editing.") (LET ((PW (GETPROMPTWINDOW WINDOW NIL NIL T))) (AND PW (CLEARW PW))) (FM.ENDEDIT WINDOW) (for W in (WINDOWPROP WINDOW (QUOTE PROTMENUS)) do (FM.ENDEDIT W)) (if (EQ (GETSTREAM WINDOW) (TTYDISPLAYSTREAM)) then (* ; "Bug--freemenu leaves this guy being the ttydisplaystream") (TTYDISPLAYSTREAM \DEFAULTTTYDISPLAYSTREAM))) ) ) (DEFINEQ (NSPROT.HANDLE.TYPE (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 13:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) (SELECTQ (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (T (SETQ LABEL "Principal") NIL) (NIL (SETQ LABEL "Children Only") T) (SHOULDNT))) LABEL)) ) (NSPROT.RESTORE.TYPE (LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 13:56 by bvm:") (* ;; "Replace the %"children only%" state with %"Principal%"--do this when working on a non-directory. Returns T if it changed.") (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) NIL) then (FM.CHANGESTATE (FM.GETITEM (QUOTE TYPE) NIL WINDOW) "Principal" WINDOW) T)) ) (NSPROT.HANDLE.VERIFY (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 14:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) (SELECTQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) (:NEW (SETQ LABEL "All Names") T) (T (SETQ LABEL "Don't") NIL) (NIL (SETQ LABEL "I really mean it") :NO) (:NO (SETQ LABEL "New Names Only") :NEW) (SHOULDNT))) LABEL)) ) (NSPROT.RESTORE.VERIFY (LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 15:11 by bvm:") (* ;; "Replace the %"I really mean it%" state with a better one.") (if (EQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO) then (FM.CHANGESTATE (FM.GETITEM (QUOTE CHECK) NIL WINDOW) "New Names Only" WINDOW) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) :NEW))) ) (NSPROT.PARSE.FILENAME (LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (NSPROT.BEGIN.COMMAND WINDOW) (PROG ((STATE (FM.GETSTATE WINDOW)) HOST FILENAME FULLNAME HOST&FILE FULLHOST DEV) (for TL on STATE by (CDDR TL) do (SELECTQ (CAR TL) (HOST (SETQ HOST (CADR TL))) (DIR (SETQ FILENAME (CADR TL))) NIL)) (if (OR (NULL FILENAME) (EQ (NCHARS FILENAME) 0)) then (NSPROT.PROMPT WINDOW "No directory or file name was specified.") (RETURN NIL)) (if (SETQ HOST&FILE (NSPROT.STRIP.HOST FILENAME)) then (* ;; "User gave a full file name including host in the %"Dir/File%" field. Separate them out now.") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) (SETQ FILENAME (CDR HOST&FILE)) WINDOW) (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) (SETQ HOST (CAR HOST&FILE)) WINDOW)) (if (OR (NULL HOST) (EQ (NCHARS HOST) 0)) then (NSPROT.PROMPT WINDOW "No host was specified.") (RETURN NIL)) (SETQ FULLHOST (CAR (LOOKUP.NS.SERVER HOST NIL T))) (if (NOT (STRING-EQUAL HOST (SETQ HOST (NSNAME.TO.STRING (OR FULLHOST (PARSE.NSNAME HOST)) T)))) then (* ;; "Show fully-qualified name, either from lookup or from parse. In latter case, we may be reminding user of default domain.") (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) HOST WINDOW)) (if (NEQ (CHCON1 FILENAME) (CHARCODE "<")) then (SETQ FILENAME (CONCAT "<" FILENAME)) (if (NOT (STRPOS ">" FILENAME 2)) then (SETQ FILENAME (CONCAT FILENAME ">"))) (* ; "Show modified file name") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) FILENAME WINDOW)) (if (OR (NOT FULLHOST) (NULL (SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (CONCAT "{" HOST "}" FILENAME)) T)))) then (NSPROT.PROMPT WINDOW "Server ~A not found." HOST) (RETURN NIL)) (RETURN (CONS DEV FULLNAME)))) ) (NSPROT.PARSE.PROTECTIONS (LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (* ;; "Parse and as necessary validate the protection entries attached to WINDOW, returning a valid PROTECTION value, or NIL if something is wrong.") (LET ((PROTWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS))) (VERIFYFLG (WINDOWPROP WINDOW (QUOTE VERIFYFLG))) WHO HOW NSWHO OLDWHO FULLNAME DEADWINDOWS PROT VERIFIEDNAME) (for W in PROTWINDOWS do (SETQ WHO NIL) (SETQ HOW (for TAIL on (FM.GETSTATE W) by (CDDR TAIL) when (SELECTQ (CAR TAIL) ((READ WRITE ADD REMOVE OWNER) (CADR TAIL)) (NAME (SETQ WHO (CADR TAIL)) NIL) NIL) collect (CAR TAIL))) (if (NOT (AND HOW WHO (> (NCHARS WHO) 0))) then (* ; "No protection, remove this guy") (push DEADWINDOWS W) elseif (AND (NEQ VERIFYFLG T) (STREQUAL WHO (CAR (SETQ OLDWHO (WINDOWPROP W (QUOTE KNOWN-VALUE)))))) then (* ;; "This name hasn't been changed since we put it up, so use the parse that's there. We're assuming that not having to validate old protection names makes up for occasionally reinstalling a bogus name that just happened to be there.") (push PROT (LIST (CADR OLDWHO) HOW)) else (SETQ NSWHO (PARSE.NSNAME WHO)) (if (NOT (STREQUAL WHO (SETQ WHO (NSNAME.TO.STRING (OR (SETQ FULLNAME (if (SELECTQ VERIFYFLG ((NIL :NO) T) (STRPOS "*" WHO)) then (* ; "for now, accept any pattern") NSWHO else (* ; "get canonical name") (SETQ VERIFIEDNAME (CH.LOOKUP.OBJECT NSWHO)))) NSWHO) T)))) then (* ; "Show our parse or canonical name") (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL W) WHO W)) (if FULLNAME then (* ; "good name") (SETQ NSWHO FULLNAME) (if VERIFIEDNAME then (* ; "Remember this parse") (WINDOWPROP W (QUOTE KNOWN-VALUE) (LIST WHO VERIFIEDNAME HOW))) else (NSPROT.PROMPT WINDOW "~A not a registered name." WHO) (RETURN NIL)) (push PROT (LIST NSWHO HOW))) finally (if DEADWINDOWS then (* ; "Remove the windows showing no entry") (LET ((LASTDEAD (CAR DEADWINDOWS)) LOWERWINDOWS) (* ; "First detach everything up to the last dead one.") (for OLDW in PROTWINDOWS do (DETACHWINDOW OLDW) (if (MEMB OLDW DEADWINDOWS) then (CLOSEW OLDW) else (push LOWERWINDOWS OLDW)) repeatuntil (EQ OLDW LASTDEAD)) (* ; "Now reattach the good ones") (for OLDW in LOWERWINDOWS do (ATTACHWINDOW OLDW WINDOW (QUOTE BOTTOM))) (* ; "Add the dead ones to scratch heap") (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND DEADWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))) (WINDOWPROP WINDOW (QUOTE PROTMENUS) (CL:SET-DIFFERENCE PROTWINDOWS DEADWINDOWS)))) (RETURN (LIST PROT))))) ) (NSPROT.STRIP.HOST (LAMBDA (FILENAME) (* ; "Edited 20-Aug-87 14:17 by bvm:") (* ;; "Strips the host field off the front of FILENAME and returns a dotted pair (host . restOfName).") (PROG (I) (RETURN (AND (SETQ I (STRPOS (SELCHARQ (CHCON1 FILENAME) ({ "}") ("[" "]") ("(" ")") (RETURN NIL)) FILENAME 2)) (CONS (SUBSTRING FILENAME 2 (SUB1 I)) (SUBSTRING FILENAME (ADD1 I))))))) ) (NSPROT.EXPAND.FULLNAME (LAMBDA (WINDOW DEV FILENAME) (* ; "Edited 27-Aug-87 15:19 by bvm:") (* ;; "Looks up FILENAME on DEV, returning the full name (sans host). WINDOW is the window in which FILENAME is the DIR item--we will change it if appropriate. Returns NIL on file not found.") (LET ((FULLNAME (\NSFILING.GETFILE DEV FILENAME (QUOTE NONE) (QUOTE OLD) (QUOTE HANDLE) (FUNCTION \NSFILING.FULLNAME) T)) STRIPPED-NAME) (if (NULL FULLNAME) then (NSPROT.PROMPT WINDOW "~A not found." (if (NSPROT.DIRECTORY.SYNTAXP FILENAME) then "Directory" elseif (STRPOS ">" FILENAME) then (* ; "Looks like a file") "File" else (* ; "Could be either if they were sloppy") "Directory/file")) NIL else (SETQ STRIPPED-NAME (CDR (NSPROT.STRIP.HOST FULLNAME))) (if (NOT (STREQUAL STRIPPED-NAME FILENAME)) then (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) STRIPPED-NAME WINDOW)) (if (NOT (NSPROT.DIRECTORY.SYNTAXP FULLNAME)) then (* ; "Force Principal protection, since non-directories don't have a default access list.") (NSPROT.RESTORE.TYPE WINDOW)) FULLNAME))) ) ) (* ; "Handle protection submenus") (DEFINEQ (NSPROT.GET.SUBMENU (LAMBDA (MAINWINDOW) (* ; "Edited 26-Aug-87 18:03 by bvm:") (LET ((SUBW (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS))) HEIGHT) (if SUBW then (* ; "Return a cached window to avoid overhead of creating a whole new freemenu. Don't forget to clear the old one out!") (PROG1 (NSPROT.CHANGE.STATE (CAR SUBW) NIL) (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS) (CDR SUBW))) else (SETQ SUBW (FREEMENU (BQUOTE ((PROPS FONT (\, (NSPROT.GET.FONT)) COLUMNSPACE 5) ((LABEL "Read" ID READ TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Read: User may read (if a file) or enumerate (if a directory)") (LABEL "Wrt" ID WRITE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Write: User may write/change/delete the file.") (LABEL "Add" ID ADD TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Add: User can create files in the directory.") (LABEL "Del" ID REMOVE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Delete: User can remove files from the directory.") (LABEL "Own" ID OWNER TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Owner: User can change the protection.") (LABEL "All" ID ALL TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.ALL MESSAGE NSPROT.MESSAGE.ALL) (LABEL " to:" ID TO TYPE EDITSTART MESSAGE "Fill in name (user or group) or pattern (*:Domain)." FONT (\, (NSPROT.GET.FONT T)) LINKS (EDIT NAME)) (LABEL (\, (CONCAT)) TYPE EDIT ID NAME)))) NIL NIL 3)) (WINDOWPROP SUBW (QUOTE FM.DONTRESHAPE) T) (* ; "Don't want any extra space added between columns when the window gets wider--add it all on the right.") (WINDOWPROP SUBW (QUOTE MINSIZE) (CONS 0 (SETQ HEIGHT (fetch (REGION HEIGHT) of (WINDOWPROP SUBW (QUOTE REGION)))))) (WINDOWPROP SUBW (QUOTE MAXSIZE) (CONS MAX.SMALLP HEIGHT)) (WINDOWPROP SUBW (QUOTE FM.PROMPTWINDOW) (GETPROMPTWINDOW MAINWINDOW)) SUBW))) ) (NSPROT.ADD.SUBMENU (LAMBDA (MENUW MAINWINDOW) (* ; "Edited 20-Aug-87 10:13 by bvm:") (* ;; "Appends MENUW to MAINWINDOW's set of protection value entries") (ATTACHWINDOW MENUW MAINWINDOW (QUOTE BOTTOM)) (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS) (CONS MENUW (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS))))) ) (NSPROT.REMOVE.SUBMENUS (LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 12:34 by bvm:") (* ;; "Removes all the submenus (protection entries) from WINDOW, adding them to the scratch list for the window.") (LET ((OLDWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS) NIL))) (for W in OLDWINDOWS do (DETACHWINDOW W) (CLOSEW W)) (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND OLDWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))))) ) (NSPROT.CHANGE.STATE (LAMBDA (WINDOW NEWSTATE) (* ; "Edited 19-Aug-87 16:15 by bvm:") (* ;; "Change all the protection buttons to the specified state") (for ID in (QUOTE (READ WRITE ADD REMOVE OWNER ALL)) do (FM.CHANGESTATE (FM.GETITEM ID NIL WINDOW) NEWSTATE WINDOW)) WINDOW) ) (NSPROT.HANDLE.ALL (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 16:16 by bvm:") (* ;; "Called when ALL is selected--turn all protection bits to the specified state") (NSPROT.CHANGE.STATE WINDOW (FM.ITEMPROP ITEM (QUOTE STATE)))) ) (NSPROT.MESSAGE.ALL (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Aug-87 14:15 by bvm:") (* ;; "Called when ALL is held--return appropriate help message") (if (FM.ITEMPROP ITEM (QUOTE STATE)) then "Deny user all access rights" else "Grant user all 5 access rights")) ) (NSPROT.HANDLE.SUBTYPE (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 14:46 by bvm:") (LET ((OTHER (FM.GETITEM (QUOTE ALL) NIL WINDOW))) (if (FM.ITEMPROP OTHER (QUOTE STATE)) then (* ; "If the ALL button was on, turn it off") (FM.CHANGESTATE OTHER NIL WINDOW)) (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) ((WRITE ADD) (* ; "these accesses really need READ as well") (if (AND (FM.ITEMPROP ITEM (QUOTE STATE)) (NOT (FM.ITEMPROP (SETQ OTHER (FM.GETITEM (QUOTE READ) NIL WINDOW)) (QUOTE STATE)))) then (FM.CHANGESTATE OTHER T WINDOW))) NIL))) ) (NSPROT.SHOW.PROT.VALUE (LAMBDA (ENTRY MAINWINDOW) (* ; "Edited 24-Aug-87 16:16 by bvm:") (DESTRUCTURING-BIND (NAME TYPES) ENTRY (LET ((SUBW (NSPROT.GET.SUBMENU MAINWINDOW)) (STRINGNAME (NSNAME.TO.STRING NAME T)) ITEM) (for P in TYPES do (FM.CHANGESTATE (OR (SETQ ITEM (FM.GETITEM P NIL SUBW)) (HELP "Bad protection value" P)) T SUBW) (if (EQ P (QUOTE ALL)) then (NSPROT.HANDLE.ALL ITEM SUBW))) (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL SUBW) STRINGNAME SUBW) (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) (CONS STRINGNAME ENTRY)) (* ; "Save the parse of this value so we can avoid worrying about it later.") (NSPROT.ADD.SUBMENU SUBW MAINWINDOW) SUBW))) ) ) (* ; "utilities") (DEFINEQ (NSPROT.DIRECTORY.SYNTAXP (LAMBDA (FILENAME) (* ; "Edited 27-Aug-87 14:53 by bvm:") (* ; "True if FILENAME looks like a directory") (EQ (NTHCHARCODE FILENAME -1) (CHARCODE ">"))) ) (NSPROT.TOP.LEVELP (LAMBDA (FILESPEC) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (I) (NOT (AND (SETQ I (STRPOS ">" FILESPEC)) (NEQ I (NCHARS FILESPEC)))))) ) (NSPROT.GET.FONT (LAMBDA (BOLDP) (* ; "Edited 1-Sep-87 17:23 by bvm:") (if BOLDP then (OR NSPROT.BOLD.FONT (SETQ NSPROT.BOLD.FONT (FONTCOPY (NSPROT.GET.FONT) (QUOTE WEIGHT) (QUOTE BOLD)))) elseif NSPROT.PLAIN.FONT elseif (> (FONTHEIGHT (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 10))) 12) then (* ; "Yes, this is the one I had in mind (10 pt coerced to 12)") NSPROT.PLAIN.FONT else (* ; "The %"real%" 12 pt display font is about the right size.") (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 12)))) ) (NSPROT.PROMPT (LAMBDA WINDOW&ARGS (* ; "Edited 2-Sep-87 14:12 by bvm:") (LET* ((*PRINT-CASE* :UPCASE) (WINDOW (GETPROMPTWINDOW (ARG WINDOW&ARGS 1))) (ARGS (for J from (if (EQ (ARG WINDOW&ARGS 2) T) then (* ; "First arg of T means clear window first.") (CLEARW WINDOW) 3 else 2) to WINDOW&ARGS collect (ARG WINDOW&ARGS J)))) (RESETFORM (TTYDISPLAYSTREAM WINDOW) (* ; "Unfortunately, have to make it the tty to get pagefullfn action.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW ARGS)) NIL)) ) (NSPROT.LIMITCHARS (LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Aug-87 12:00 by bvm:") (SELECTQ CHAR ((% Â) (FM.SKIPNEXT WINDOW) NIL) T))) (NSPROT.PAGEFULLFN (LAMBDA (PW) (* ; "Edited 27-Aug-87 17:11 by bvm:") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (GETPROMPTWINDOW (MAINWINDOW PW) (+ 2 \CURRENTDISPLAYLINE)) (* ; "\Currentdisplayline is the line we're on when window fills, origin zero")))) ) (NSPROT.ICONFN (LAMBDA (WINDOW OLDICON) (* ; "Edited 1-Sep-87 10:29 by bvm:") (LET ((HOST (FM.ITEMPROP (FM.GETITEM (QUOTE HOST) NIL WINDOW) (QUOTE LABEL)))) (SETQ HOST (if (AND HOST (NEQ (NCHARS HOST) 0) (SETQ HOST (PARSE.NSNAME HOST))) then (fetch NSOBJECT of HOST) else "")) (* ; "show host's main name") (if OLDICON then (ICONW.TITLE OLDICON HOST) OLDICON else (TITLEDICONW NSPROT.ICON HOST (NSPROT.GET.FONT))))) ) ) (RPAQ? NSPROT.PLAIN.FONT NIL) (RPAQ? NSPROT.BOLD.FONT NIL) (RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO NIL (4 22 51 14)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) ) (DEFINEQ (ADD.NSPROTECTION (LAMBDA (LST) (* ; "Edited 2-Sep-87 11:53 by bvm:") (* ;; "Add an entry for the NSPROTECTION tool to the background menu") (for X in (if LST then (* ; "Mumbling thru sub items") (CDR LST) else (SETQ LST BackgroundMenuCommands)) bind (COM _ (QUOTE ("NS Protection" (QUOTE (NSPROTECTION)) "Start up the NS File protection tool."))) do (if (STRING-EQUAL (CAR X) "NS Protection") then (RETURN (RPLACD X (CDR COM))) elseif (AND (STRING-EQUAL (CAR X) "System") (CADDDR X)) then (RETURN (ADD.NSPROTECTION (CADDDR X)))) finally (NCONC1 LST COM)) (SETQ BackgroundMenu NIL) (* ; "also, load fonts") (NSPROT.GET.FONT T) (COND ((CCODEP (QUOTE ADD.NSPROTECTION)) (* ; "self destruct") (AND (PUTD (QUOTE ADD.NSPROTECTION)))))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADD.NSPROTECTION) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA NSPROT.PROMPT) ) (PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1808 14263 (NSPROTECTION 1818 . 5004) (NSPROT.SHOW 5006 . 5524) ( NSPROT.FETCH.PROTECTION 5526 . 8468) (NSPROT.NEW.ENTRY 8470 . 9093) (NSPROT.APPLY 9095 . 10024) ( NSPROT.SET.PROTECTION 10026 . 10602) (NSPROT.SET.PROTECTION.ONE 10604 . 11480) (NSPROT.SET.MULTIPLE 11482 . 12957) (NSPROT.SET.TO.DEFAULT 12959 . 13771) (NSPROT.BEGIN.COMMAND 13773 . 14261)) (14264 21296 (NSPROT.HANDLE.TYPE 14274 . 14574) (NSPROT.RESTORE.TYPE 14576 . 14927) (NSPROT.HANDLE.VERIFY 14929 . 15289) (NSPROT.RESTORE.VERIFY 15291 . 15622) (NSPROT.PARSE.FILENAME 15624 . 17353) ( NSPROT.PARSE.PROTECTIONS 17355 . 19850) (NSPROT.STRIP.HOST 19852 . 20233) (NSPROT.EXPAND.FULLNAME 20235 . 21294)) (21340 25891 (NSPROT.GET.SUBMENU 21350 . 23154) (NSPROT.ADD.SUBMENU 23156 . 23463) ( NSPROT.REMOVE.SUBMENUS 23465 . 23885) (NSPROT.CHANGE.STATE 23887 . 24169) (NSPROT.HANDLE.ALL 24171 . 24413) (NSPROT.MESSAGE.ALL 24415 . 24687) (NSPROT.HANDLE.SUBTYPE 24689 . 25234) ( NSPROT.SHOW.PROT.VALUE 25236 . 25889)) (25918 28228 (NSPROT.DIRECTORY.SYNTAXP 25928 . 26112) ( NSPROT.TOP.LEVELP 26114 . 26276) (NSPROT.GET.FONT 26278 . 26797) (NSPROT.PROMPT 26799 . 27291) ( NSPROT.LIMITCHARS 27293 . 27434) (NSPROT.PAGEFULLFN 27436 . 27802) (NSPROT.ICONFN 27804 . 28226)) ( 29447 30196 (ADD.NSPROTECTION 29457 . 30194))))) STOP \ No newline at end of file diff --git a/lispusers/NSPROTECTION.TEDIT b/lispusers/NSPROTECTION.TEDIT new file mode 100644 index 00000000..c285ca00 Binary files /dev/null and b/lispusers/NSPROTECTION.TEDIT differ diff --git a/lispusers/NSREADERPATCH b/lispusers/NSREADERPATCH new file mode 100644 index 00000000..6ea66386 --- /dev/null +++ b/lispusers/NSREADERPATCH @@ -0,0 +1 @@ +(FILECREATED "18-Jun-86 16:14:22" {ERIS}LISPCORE>NSREADERPATCH.;1 577 changes to: (VARS NSREADERPATCHCOMS)) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT NSREADERPATCHCOMS) (RPAQQ NSREADERPATCHCOMS [(ADDVARS (FILEINFOTYPES (READER 11)) (\LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY]) (ADDTOVAR FILEINFOTYPES (READER 11)) (ADDTOVAR \LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY)) (PUTPROPS NSREADERPATCH COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/NSROUTINGHASH b/lispusers/NSROUTINGHASH new file mode 100644 index 00000000..2c73c564 --- /dev/null +++ b/lispusers/NSROUTINGHASH @@ -0,0 +1 @@ +(FILECREATED " 7-Feb-89 23:16:44" {ERINYES}KOTO>NSROUTINGHASH.;2 13641 changes to: (RECORDS NSROUTINGINFO) (VARS NSROUTINGHASHCOMS) previous date: "11-Jan-88 21:27:31" {ERINYES}KOTO>NSROUTINGHASH.;1) (* Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT NSROUTINGHASHCOMS) (RPAQQ NSROUTINGHASHCOMS ((FNS \AGE.ROUTING.TABLE.HASH \HANDLE.NS.ROUTING.INFO.NEW \HANDLE.RAW.XIP.NEW \LOCATE.NSNET.NEW \FLUSHNDBS.NEW \MAP.ROUTING.TABLE.NEW \NSGATELISTENER.NEW \NSROUTING.HASHBITSFN \NSROUTING.EQUIVFN PRINTROUTINGTABLE) (GLOBALVARS \NS.ROUTING.TABLE) (* * LOADCOMP LLNS *before* loading this module so that this record declaration is in effect) (RECORDS NSROUTINGINFO) (FNS INSTALL UNINSTALL) (* installation utilities) (COMS (* debugging tools) (FNS ROUTINGPROBE)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) ( INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE \HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE \LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL (QUOTE \NSGATELISTENER)) (RESTART.ETHER) ( \LOCATE.NSNET -1)))))) (DEFINEQ (\AGE.ROUTING.TABLE.HASH (LAMBDA (TABLE) (* ; "Edited 21-Jun-87 23:23 by BRIGGS") (MAPHASH TABLE (FUNCTION (LAMBDA (ENTRY KEY) (if (if (AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (TIMEREXPIRED? (fetch RTTIMER of ENTRY))) then (COND ((fetch RTRECENT of ENTRY) (* New entry, make it old) (replace RTRECENT of ENTRY with NIL) (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)) NIL) (T \RT.PURGEFLG))) then (PUTHASH KEY NIL TABLE)))) ))) (\HANDLE.NS.ROUTING.INFO.NEW (LAMBDA (XIP) (* edited: "11-Jan-88 20:48") (* ; "Edited 21-Jun-87 23:11 by BRIGGS") (* Processes a routing info XIP) (COND ((EQ (fetch XIPFIRSTDATAWORD of XIP) \XROUTINGINFO.OP.RESPONSE) (* Unless we're a gateway, we only handle responses) (PROG ((HOST (fetch XIPSOURCEHOST of XIP)) (NDB (fetch EPNETWORK of XIP)) (LENGTH (SUB1 (FOLDLO (IDIFFERENCE (fetch XIPLENGTH of XIP) \XIPOVLEN) BYTESPERWORD ))) (BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) ENTRY NET HOPS NETHASH) (COND ((NEQ (fetch NETTYPE of NDB) 10) (OR (SETQ HOST (\TRANSLATE.10TO3 HOST NDB)) (RETURN)))) (SETQ \NSROUTER.PROBECOUNT 0) ( while (IGEQ LENGTH \NS.ROUTINGINFO.WORDS) do (SETQ HOPS (fetch (NSROUTINGINFO #HOPS) of BASE)) (COND ( (OR (SETQ ENTRY (GETHASH BASE \NS.ROUTING.TABLE)) (COND ((ILEQ HOPS \NS.ROUTING.TABLE.RADIUS) (SETQ NET (fetch (NSROUTINGINFO NET#) of BASE)) (PUTHASH NET (SETQ ENTRY (create ROUTING RTNET# _ NET RTTIMER _ (SETUPTIMER 0))) \NS.ROUTING.TABLE) T))) (* Update the entry if this entry not for directly connected net and - current entry timed out, or - new gateway same as old, or - new route has fewer hops than old) (COND ((AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (OR (NOT (fetch RTRECENT of ENTRY)) ( AND (EQUAL HOST (fetch RTGATEWAY# of ENTRY)) (EQ NDB (fetch RTNDB of ENTRY))) (ILESSP HOPS (fetch RTHOPCOUNT of ENTRY)))) (replace RTGATEWAY# of ENTRY with HOST) (replace RTNDB of ENTRY with NDB) ( replace RTHOPCOUNT of ENTRY with HOPS) (COND ((ILESSP HOPS \RT.INFINITY) (replace RTRECENT of ENTRY with T) (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)))))))) (SETQ LENGTH (IDIFFERENCE LENGTH \NS.ROUTINGINFO.WORDS)) (SETQ BASE (\ADDBASE BASE \NS.ROUTINGINFO.WORDS)))))) ( \RELEASE.ETHERPACKET XIP))) (\HANDLE.RAW.XIP.NEW (LAMBDA (XIP TYPE) (* edited: "11-Jan-88 20:47") (* N.H.Briggs "21-Jun-87 23:53") (* Handles the arrival of a raw XIP. If it is destined for a local socket that has room for it, we queue it up, else release it) (COND ((EQ TYPE \EPT.XIP) (PROG (NSOC CSUM NDB DESTNET MYNET) (COND ((NULL \NS.READY) ( RETURN (RELEASE.XIP XIP)))) (COND ((AND (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) \MY.NSHOSTNUMBER)) (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER))) (* Not for us) (RETURN (\FORWARD.XIP XIP)))) (SETQ NDB (fetch EPNETWORK of XIP)) (COND ((AND (NOT (IEQP (SETQ DESTNET (fetch XIPDESTNET of XIP)) (SETQ MYNET (fetch NDBNSNET# of NDB)))) (NEQ MYNET 0) (NEQ DESTNET 0)) (* explicitly for a net other than us) (RETURN (\FORWARD.XIP XIP)))) (COND ((NULL (SETQ NSOC ( \NSOCKET.FROM# (fetch XIPDESTSOCKET of XIP)))) (* Packets addressed to non-active sockets are just ignored.) (COND (XIPTRACEFLG (PRIN1 (QUOTE '&) XIPTRACEFILE))) (PROG (XIPBASE) (COND ((AND (EQ (fetch XIPTYPE of XIP) \XIPT.ECHO) (EQ (fetch XIPDESTSOCKET of XIP) \NS.WKS.Echo) (EQ (\GETBASE (SETQ XIPBASE (fetch XIPCONTENTS of XIP)) 0) \XECHO.OP.REQUEST)) (* Play echo server) (COND ((AND (NEQ (SETQ CSUM ( fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 ( FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (\PUTBASE XIPBASE 0 \XECHO.OP.REPLY) (SWAPXIPADDRESSES XIP) (replace EPREQUEUE of XIP with (QUOTE FREE)) (SENDXIP NIL XIP)))) (T (\XIPERROR XIP \XIPE.NOSOCKET))))) ((IGEQ (fetch (NSOCKET INQUEUELENGTH) of NSOC) (fetch ( NSOCKET NSOC#ALLOCATION) of NSOC)) (* Note that packets are just "dropped" when the queue overflows.) (\XIPERROR XIP \XIPE.SOCKETFULL)) ((AND \NS.CHECKSUMFLG (NEQ (SETQ CSUM (fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP ) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (COND ((EQ DESTNET 0) (* Fill in unspecified destination net (possibly redundantly with zero)) (replace XIPDESTNET of XIP with MYNET)) ((EQ MYNET 0 ) (* Packet of specific destination net has arrived on a socket that we listen to. If we don't know our own net number, assume sender is telling the truth) (replace NDBNSNET# of NDB with DESTNET) ( replace NSNET of \MY.NSADDRESS with (SETQ \MY.NSNETNUMBER DESTNET)) (PROG ((ENTRY (\LOCATE.NSNET DESTNET T))) (OR ENTRY (PUTHASH DESTNET (SETQ ENTRY (create ROUTING RTNET# _ DESTNET)) \NS.ROUTING.TABLE)) (replace RTHOPCOUNT of ENTRY with 0) (replace RTGATEWAY# of ENTRY with NIL) ( replace RTNDB of ENTRY with NDB) (replace RTRECENT of ENTRY with T)))) (UNINTERRUPTABLY (\ENQUEUE ( fetch (NSOCKET INQUEUE) of NSOC) XIP) (add (fetch (NSOCKET INQUEUELENGTH) of NSOC) 1) (NOTIFY.EVENT ( fetch NSOCEVENT of NSOC)))))) T)))) (\LOCATE.NSNET.NEW (LAMBDA (NET DONTPROBE) (* edited: "11-Jan-88 20:49") (* N.H.Briggs "21-Jun-87 23:54") (LET ((DATA ( GETHASH NET \NS.ROUTING.TABLE))) (if DATA then (AND (ILESSP (fetch RTHOPCOUNT of DATA) \RT.INFINITY) DATA) elseif (NOT DONTPROBE) then (PUTHASH NET (create ROUTING RTNET# _ NET RTHOPCOUNT _ \RT.INFINITY RTTIMER _ (SETUPTIMER 30000)) \NS.ROUTING.TABLE) (* Insert an entry for the net, to be purged in 30 sec if router process hasn't filled it by then) (SETQ \NSROUTER.PROBECOUNT 5) (SETQ \NSROUTER.PROBETIMER (SETUPTIMER 0 \NSROUTER.PROBETIMER)) (WAKE.PROCESS (QUOTE \NSGATELISTENER)) ( BLOCK) (* ;; "return NIL in this case to indicate we didn't find it yet.") NIL)))) (\FLUSHNDBS.NEW (LAMBDA (EVENT) (* edited: "11-Jan-88 21:20") (* bvm: " 4-AUG-83 22:51") (bind NDB QUEUE while (SETQ NDB \LOCALNDBS) do (SETQ \LOCALNDBS (fetch NDBNEXT of NDB)) (replace NDBNEXT of NDB with NIL) (COND (( EQ EVENT (QUOTE RESTART)) (APPLY* (fetch NDBETHERFLUSHER of NDB) NDB))) (DEL.PROCESS (fetch NDBWATCHER of NDB)) (replace NDBWATCHER of NDB with (replace NDBTRANSLATIONS of NDB with NIL)) (COND ((SETQ QUEUE (fetch NDBTQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE OUTPUT)) (* Don't do this just yet, because of possible race in \PUPGATELISTENER - (replace NDBTQ of NDB with NIL)))) (COND ((SETQ QUEUE ( fetch NDBIQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE INPUT)) (replace NDBIQ of NDB with NIL)))) ( SETQ \PUP.ROUTING.TABLE (CONS)) (SETQ \NS.ROUTING.TABLE (HASHARRAY 100 50 (FUNCTION \NSROUTING.HASHBITSFN) (FUNCTION \NSROUTING.EQUIVFN))))) (\MAP.ROUTING.TABLE.NEW (LAMBDA (TABLE MAPFN) (* edited: "11-Jan-88 20:53") (* bvm: "22-SEP-83 14:21") (if (HARRAYP TABLE) then (MAPHASH TABLE MAPFN) else (for ENTRY in (APPEND (CDR (OR TABLE \PUP.ROUTING.TABLE))) do (APPLY* MAPFN ENTRY))))) (\NSGATELISTENER.NEW (LAMBDA NIL (* edited: "11-Jan-88 20:47") (* ; "Edited 16-Jun-87 15:32 by BRIGGS") (PROG ((NSOC ( OPENNSOCKET \NS.WKS.RoutingInformation T)) (TIMER (SETUPTIMER 0)) EVENT XIP BASE) (SETQ EVENT (fetch NSOCEVENT of NSOC)) LP (COND ((SETQ XIP (GETXIP NSOC)) (\HANDLE.NS.ROUTING.INFO XIP) (BLOCK)) ((EQ ( AWAIT.EVENT EVENT (COND ((IGREATERP \NSROUTER.PROBECOUNT 0) \NSROUTER.PROBETIMER) (T TIMER)) T) EVENT) (GO LP))) (COND ((TIMEREXPIRED? TIMER) (\AGE.ROUTING.TABLE.HASH \NS.ROUTING.TABLE) (SETUPTIMER \RT.AGEINTERVAL TIMER))) (COND ((AND (IGREATERP \NSROUTER.PROBECOUNT 0) (TIMEREXPIRED? \NSROUTER.PROBETIMER)) (* Routing info desired. Broadcast a routing request on each directly-connected net) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 (IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD \NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD of XIP with \XROUTINGINFO.OP.REQUEST) (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace ( NSROUTINGINFO NET#) of BASE with -1) (replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) ( SENDXIP NSOC XIP) (SETUPTIMER \NSROUTER.PROBEINTERVAL \NSROUTER.PROBETIMER) (SETQ \NSROUTER.PROBECOUNT (SUB1 \NSROUTER.PROBECOUNT)))) (GO LP)))) (\NSROUTING.HASHBITSFN (LAMBDA (OBJECT) (* ; "Edited 21-Jun-87 23:08 by BRIGGS") (SELECTQ (TYPENAME OBJECT) (ETHERPACKET (* ; "a piece of a routing table packet") (LOGXOR (fetch (NSROUTINGINFO NET#-HI) of OBJECT) (fetch ( NSROUTINGINFO NET#-LO) of OBJECT))) (SMALLP (* ; "a net as a small number") OBJECT) (FIXP (* ; "a net as a number") (LOGXOR (\GETBASE OBJECT 0) (\GETBASE OBJECT 1))) (ERROR "Illegal arg (neither FIXP, SMALLP, nor ETHERPACKET)" OBJECT)))) (\NSROUTING.EQUIVFN (LAMBDA (X Y) (* N.H.Briggs "22-Jun-87 14:34") (SELECTQ (TYPENAME X) (ETHERPACKET (SELECTQ (TYPENAME Y ) (SMALLP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) Y) )) (FIXP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (\GETBASE Y 0)) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) (\GETBASE Y 1)))) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (fetch ( NSROUTINGINFO NET#-HI) of Y)) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) (fetch (NSROUTINGINFO NET#-LO) of Y)))) NIL)) (SMALLP (SELECTQ (TYPENAME Y) (SMALLP (EQ X Y)) (FIXP (EQUAL X Y)) (ETHERPACKET (AND ( EQ (fetch (NSROUTINGINFO NET#-HI) of Y) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) X))) NIL)) (FIXP ( SELECTQ (TYPENAME Y) ((SMALLP FIXP) (EQUAL X Y)) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of Y) (\GETBASE X 0)) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) (\GETBASE X 1)))) NIL)) NIL))) (PRINTROUTINGTABLE (LAMBDA (TABLE SORT? FILE) (* edited: "11-Jan-88 21:25") (* N.H.Briggs "14-Dec-87 12:17") (PROG ( HASHENTRIES) (SELECTQ TABLE (NS (MAPHASH \NS.ROUTING.TABLE (FUNCTION (LAMBDA (X) (push HASHENTRIES X)) )) (SETQ TABLE (CONS NIL HASHENTRIES))) ((NIL PUP) (SETQ TABLE \PUP.ROUTING.TABLE)) NIL) (RESETFORM ( RADIX 8) (printout FILE " Net# Gateway #Hops Recent?" T) (for ENTRY in (COND (SORT? ( SORT (APPEND (CDR TABLE)) (if (EQ SORT? (QUOTE HOPS)) then (FUNCTION (LAMBDA (X Y) (ILESSP (fetch RTHOPCOUNT of X) (fetch RTHOPCOUNT of Y)))) else T))) (T (CDR TABLE))) bind GATE do (printout FILE .I6.8 (fetch RTNET# of ENTRY)) (COND ((NOT (SETQ GATE (fetch RTGATEWAY# of ENTRY))) (PRIN1 " --- " FILE)) ((FIXP GATE) (printout FILE .I9.8 GATE)) (T (SPACES 2 FILE) (PRINTNSHOSTNUMBER GATE FILE))) (printout FILE 30 .I2 (fetch RTHOPCOUNT of ENTRY) (COND ((fetch RTRECENT of ENTRY) " Yes") ((TIMEREXPIRED? (fetch RTTIMER of ENTRY)) " timed out") (T " No")) T)) (TERPRI FILE)) ))) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NS.ROUTING.TABLE) ) (* * LOADCOMP LLNS *before* loading this module so that this record declaration is in effect) [DECLARE: EVAL@COMPILE (BLOCKRECORD NSROUTINGINFO ((* Format of each entry in a routing info packet, the hashing code relys on the fact that the net number comes first.) (NET#-HI WORD) (NET#-LO WORD) (#HOPS WORD)) (ACCESSFNS ((NET# (\GETBASEFIXP DATUM 0) (\PUTBASEFIXP DATUM 0 NEWVALUE))))) ] (DEFINEQ (INSTALL (LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (NOT (GETD (MKATOM (CONCAT FN ".OLD")))) then (MOVD FN (MKATOM (CONCAT FN ".OLD")) NIL T)) (MOVD (MKATOM (CONCAT FN ".NEW")) FN NIL T))) (UNINSTALL (LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (GETD (MKATOM (CONCAT FN ".OLD"))) then ( MOVD (MKATOM (CONCAT FN ".OLD")) FN NIL T)))) ) (* installation utilities) (* debugging tools) (DEFINEQ (ROUTINGPROBE (LAMBDA NIL (* ; "Edited 17-Jun-87 18:16 by BRIGGS") (LET ((NSOC (OPENNSOCKET \NS.WKS.RoutingInformation T)) XIP BASE) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 (IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD \NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD of XIP with \XROUTINGINFO.OP.REQUEST) (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (NSROUTINGINFO NET#) of BASE with -1) ( replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) (SENDXIP NSOC XIP)))) ) (DECLARE: DONTEVAL@LOAD DOCOPY (UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) (INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE \HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE \LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL ( QUOTE \NSGATELISTENER)) (RESTART.ETHER) (\LOCATE.NSNET -1)) ) (PUTPROPS NSROUTINGHASH COPYRIGHT ("Xerox Corporation" 1987 1988 1989)) (DECLARE: DONTCOPY (FILEMAP (NIL (1158 11765 (\AGE.ROUTING.TABLE.HASH 1168 . 1612) (\HANDLE.NS.ROUTING.INFO.NEW 1614 . 3371) (\HANDLE.RAW.XIP.NEW 3373 . 6241) (\LOCATE.NSNET.NEW 6243 . 6939) (\FLUSHNDBS.NEW 6941 . 7817) ( \MAP.ROUTING.TABLE.NEW 7819 . 8066) (\NSGATELISTENER.NEW 8068 . 9335) (\NSROUTING.HASHBITSFN 9337 . 9803) (\NSROUTING.EQUIVFN 9805 . 10738) (PRINTROUTINGTABLE 10740 . 11763)) (12235 12617 (INSTALL 12245 . 12453) (UNINSTALL 12455 . 12615)) (12681 13250 (ROUTINGPROBE 12691 . 13248))))) STOP \ No newline at end of file diff --git a/lispusers/NSTALK b/lispusers/NSTALK new file mode 100644 index 00000000..a20f03c7 --- /dev/null +++ b/lispusers/NSTALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Jul-88 09:09:52" |{MCS:MCS:STANFORD}NSTALK.;3| 16112 changes to%: (FNS DEFINE.GAP.SERVER) previous date%: "16-Jun-88 17:33:04" |{MCS:MCS:STANFORD}NSTALK.;1|) (PRETTYCOMPRINT NSTALKCOMS) (RPAQQ NSTALKCOMS ((* TALK NS (GAP) Interface) (LOCALVARS . T) (FNS CH.USER.WORKSTATION TALK.NS.SERVER) (FNS TALK.NS.USERNAME TALK.NS.CONNECT TALK.NS.EVENT TALK.NS.CREDENTIALS) (* GAP Server) (FNS GAP.SERVER DEFINE.GAP.SERVER) (INITVARS GAP.SERVICETYPES [TALK.GAP.HANDLE '((0 0] (TALK.GAP.UNKNOWN "(Viewpoint or XDE User)")) (VARS TALK.GAP.PARAMETERS TALK.GAP.TRANSPORT) (GLOBALVARS GAP.SERVICETYPES TALK.GAP.HANDLE TALK.GAP.UNKNOWN TALK.GAP.PARAMETERS TALK.GAP.TRANSPORT) (DECLARE%: DONTCOPY (RECORDS GAP.SERVICETYPE)) (* etc) (FILES TALK COURIERSERVE) (APPENDVARS (TALK.PROTOCOLTYPES (NS COERCE-TO-NSADDRESS TALK.NS.USERNAME TALK.NS.CONNECT TALK.NS.EVENT COURIER.START.SERVER))) [DECLARE%: DOCOPY (COMS (DECLARE%: EVAL@LOADWHEN (NOT (HASDEF 'GAP 'COURIERPROGRAM)) (FILES NSTALKGAP] (* DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILES ETHERRECORDS SPPDECLS) (* Also need to load EXPORTS.ALL)) (* COURIER.RESET.SOCKET used to be defined by TALK, now defined in COURIERSERVE module) (APPENDVARS (BEFORELOGOUTFORMS (COURIER.RESET.SOCKET))) (P (DEFINE.GAP.SERVER) (COURIER.START.SERVER)))) (* TALK NS (GAP) Interface) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (CH.USER.WORKSTATION [LAMBDA (USER WORKSTATION) (* ; "Edited 3-Jun-88 09:18 by cdl") (if WORKSTATION then (LET (NSADDRESS) (if (SETQ NSADDRESS (COERCE-TO-NSADDRESS WORKSTATION (ZERO))) then (CH.DELETE.PROPERTY USER 'ADDRESS.LIST) (CH.ADD.ITEM.PROPERTY USER 'ADDRESS.LIST (SETQ NSADDRESS (CONS NSADDRESS )) '(SEQUENCE NSADDRESS)) (CONS USER NSADDRESS) else (ERROR WORKSTATION "Address for host not found!"))) else (CH.DELETE.PROPERTY USER 'ADDRESS.LIST]) (TALK.NS.SERVER [LAMBDA (INPUTSTREAM PROGRAM PROCEDURE PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER) (* ; "Edited 15-Jun-88 11:10 by cdl") (* DECLARATIONS%: (ASSOCRECORD ALST  (service))) (LET ((USER (TALK.NS.CREDENTIALS CREDENTIALS)) (ADDRESS (create NSADDRESS NSSOCKET _ (ZERO) using (SPP.DESTADDRESS INPUTSTREAM))) SERVICETYPE) (with GAP.SERVICETYPE [for SERVICETYPE in GAP.SERVICETYPES thereis (for NUMBER in (CAR (with ALST TRANSPORT service)) thereis (with GAP.SERVICETYPE SERVICETYPE (EQP NUMBER GAP.UNSPECIFIED ] (if (OR TALK.GAG (NOT (TALK.ANSWER (OR USER TALK.GAP.UNKNOWN) GAP.SERVICENAME 'NS ADDRESS))) then (if (AND (EQ GAP.SERVICENAME 'TTY) (NULL VERIFIER)) then (* Should be noAnswerOrBusy, but that 915's XDE/Viewpoint so use VERIFIER to  determine if called by Lisp, can't count on this for future) '(ABORT serviceNotFound) else '(ABORT noAnswerOrBusy)) else (COURIER.RETURN INPUTSTREAM PROGRAM PROCEDURE TALK.GAP.HANDLE) (TALK.PROCESS INPUTSTREAM (SPPOUTPUTSTREAM INPUTSTREAM) GAP.SERVICENAME 'NS 'SERVER USER]) ) (DEFINEQ (TALK.NS.USERNAME [LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE MODE USER) (* ; "Edited 9-Jun-88 12:42 by cdl") (LET (OBJECT NAME (SERVICE (with TALK.SERVICETYPE SERVICETYPE TALK.SERVICENAME))) (DECLARE (GLOBALVARS LOCAL.CLEARINGHOUSE CH.NET.HINT)) (if (OR (EQ SERVICE 'TEdit) (EQ MODE 'CLIENT)) then (if (STREQUAL (SETQ NAME (USERNAME)) (CONSTANT null)) then (SETQ NAME NIL) elseif (OR LOCAL.CLEARINGHOUSE CH.NET.HINT) then (if (SETQ OBJECT (CH.LOOKUP.OBJECT NAME)) then (SETQ NAME OBJECT))) (PRINTOUT OUTPUTSTREAM NAME T) (FORCEOUTPUT OUTPUTSTREAM)) (if (OR (EQ SERVICE 'TEdit) (EQ MODE 'SERVER)) then (if (SETQ OBJECT (RATOM INPUTSTREAM TALK.READTABLE)) then (SETQ USER OBJECT)) (* Eat EOL) (BIN INPUTSTREAM)) (SELECTQ SERVICE (TTY (with SPPCON (with SPPSTREAM OUTPUTSTREAM SPP.CONNECTION) (SETQ SPPEOMONFORCEOUT T))) NIL) USER]) (TALK.NS.CONNECT [LAMBDA (HOST SERVICETYPES) (* ; "Edited 15-Jun-88 10:40 by cdl") (* DECLARATIONS%: (RECORD  AUTHENTICATOR (CREDENTIALS VERIFIER))) (PROG (USER STREAM SERVICETYPE RESULT (CREDENTIALS (with AUTHENTICATOR (CH.GETAUTHENTICATOR T) CREDENTIALS)) (VERIFIER (with AUTHENTICATOR (CH.GETAUTHENTICATOR) VERIFIER))) (DECLARE (GLOBALVARS SPP.USER.TIMEOUT)) (if (SETQ STREAM (COURIER.OPEN HOST NIL T (PACK* 'TALK# HOST))) then (if (SETQ SERVICETYPE (for SERVICETYPE in SERVICETYPES thereis (SELECTQ [CAR (SETQ RESULT (COURIER.CALL STREAM 'GAP 'Create TALK.GAP.PARAMETERS `([service (,(with GAP.SERVICETYPE [for TYPE in GAP.SERVICETYPES thereis (with GAP.SERVICETYPE TYPE (with TALK.SERVICETYPE SERVICETYPE (EQ GAP.SERVICENAME TALK.SERVICENAME] GAP.UNSPECIFIED] ,@TALK.GAP.TRANSPORT) SPP.USER.TIMEOUT CREDENTIALS VERIFIER 'RETURNERRORS] (ERROR (SELECTQ (CADR RESULT) (noAnswerOrBusy (* User hung up or didn't answer,  don't try another service) (RETURN)) (serviceNotFound (* Old Lisp TTY service returns this when it really means noAnswerOrBusy for  compatibility with Tajo/Viewpoint.) (if (with TALK.SERVICETYPE SERVICETYPE (EQ TALK.SERVICENAME 'TTY)) then (* Don't try services following TTY service for NS we don't know if remote  service wasn't there or remote user refused connection so we may annoy the  remote user, of course we may miss a possible connection) (RETURN))) NIL)) RESULT))) then [RETURN (CONS SERVICETYPE (CONS STREAM (SPPOUTPUTSTREAM STREAM] else (CLOSEF? STREAM) (RETURN 'ANSWER)) else (RETURN 'CONNECT]) (TALK.NS.EVENT [LAMBDA (INPUTSTREAM OUTPUTSTREAM) (* cdl "10-Jun-87 07:55") (if (AND (OPENP INPUTSTREAM) (OPENP OUTPUTSTREAM) (NOT (READP INPUTSTREAM))) then (AWAIT.EVENT (with SPPCON (with SPPSTREAM INPUTSTREAM SPP.CONNECTION) SPPINPUTEVENT))) (if (OPENP INPUTSTREAM) then (SELECTQ (EOFP INPUTSTREAM) (ATTENTION (SPP.CLEARATTENTION INPUTSTREAM) (BIN INPUTSTREAM)) (EOM (SPP.CLEAREOM INPUTSTREAM)) (T (CLOSEF INPUTSTREAM)) NIL]) (TALK.NS.CREDENTIALS [LAMBDA (CREDENTIALS) (* cdl " 6-May-87 15:58") (if (AND CREDENTIALS (SETQ CREDENTIALS (CADR CREDENTIALS))) then (SUBATOM (COURIER.READ.REP CREDENTIALS 'CLEARINGHOUSE 'NAME) 1 -2]) ) (* GAP Server) (DEFINEQ (GAP.SERVER [LAMBDA (STREAM PROGRAM PROCEDURE PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER) (* ; "Edited 9-Jun-88 12:06 by cdl") (* DECLARATIONS%: (ASSOCRECORD ALST  (service))) (LET (SERVICETYPE) (if [OR [for NUMBER in (CAR (with ALST TRANSPORT service)) thereis (SETQ SERVICETYPE (for SERVICETYPE in GAP.SERVICETYPES thereis (with GAP.SERVICETYPE SERVICETYPE (AND (EQP NUMBER GAP.UNSPECIFIED ) GAP.SERVERFN] (AND (SETQ SERVICETYPE (ASSOC T GAP.SERVICETYPES)) (with GAP.SERVICETYPE SERVICETYPE (* There was a server in place  before TALK was loaded) (FGETD GAP.SERVERFN] then (APPLY* (with GAP.SERVICETYPE SERVICETYPE GAP.SERVERFN) STREAM PROGRAM PROCEDURE PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER) else '(ABORT serviceNotFound]) (DEFINE.GAP.SERVER [LAMBDA NIL (* ; "Edited 27-Jul-88 09:08 by cdl") (* DECLARATIONS%: (ASSOCRECORD  PROCEDURES (Create))  (PROPRECORD PROCEDURE  (IMPLEMENTEDBY))) (if (HASDEF 'GAP 'COURIERPROGRAM) then (PROG [SERVERFN PROCEDURE (COURIERDEF (GETDEF 'GAP 'COURIERPROGRAM] [with COURIERPGM COURIERDEF (SETQ PROCEDURE (with PROCEDURES PROCEDURES Create)) [if (SETQ SERVERFN (with PROCEDURE PROCEDURE IMPLEMENTEDBY)) then (if (EQ SERVERFN 'GAP.SERVER) then (RETURN)) (* Make the existing GAP server the  default) (if GAP.SERVICETYPES then (PUTASSOC T `(DEFAULT ,SERVERFN) GAP.SERVICETYPES) else (push GAP.SERVICETYPES `(T DEFAULT ,SERVERFN] (with PROCEDURE PROCEDURE (SETQ IMPLEMENTEDBY 'GAP.SERVER] (PUTDEF 'GAP 'COURIERPROGRAM COURIERDEF) (UNMARKASCHANGED 'GAP 'COURIERPROGRAM)) else (ERROR "Courier program GAP not defined!"]) ) (RPAQ? GAP.SERVICETYPES NIL) (RPAQ? TALK.GAP.HANDLE '((0 0))) (RPAQ? TALK.GAP.UNKNOWN "(Viewpoint or XDE User)") (RPAQQ TALK.GAP.PARAMETERS (ttyHost (seven even two 100 (none 0 0)))) (RPAQQ TALK.GAP.TRANSPORT ((teletype))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GAP.SERVICETYPES TALK.GAP.HANDLE TALK.GAP.UNKNOWN TALK.GAP.PARAMETERS TALK.GAP.TRANSPORT) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GAP.SERVICETYPE (GAP.UNSPECIFIED GAP.SERVICENAME GAP.SERVERFN)) ) ) (* etc) (FILESLOAD TALK COURIERSERVE) (APPENDTOVAR TALK.PROTOCOLTYPES (NS COERCE-TO-NSADDRESS TALK.NS.USERNAME TALK.NS.CONNECT TALK.NS.EVENT COURIER.START.SERVER)) (DECLARE%: DOCOPY (DECLARE%: EVAL@LOADWHEN (NOT (HASDEF 'GAP 'COURIERPROGRAM)) (FILESLOAD NSTALKGAP) ) ) (* DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILES ETHERRECORDS SPPDECLS) (* Also need to load EXPORTS.ALL)) (* COURIER.RESET.SOCKET used to be defined by TALK, now defined in COURIERSERVE module) (APPENDTOVAR BEFORELOGOUTFORMS (COURIER.RESET.SOCKET)) (DEFINE.GAP.SERVER) (COURIER.START.SERVER) (DECLARE%: DONTCOPY (FILEMAP (NIL (2304 5420 (CH.USER.WORKSTATION 2314 . 3215) (TALK.NS.SERVER 3217 . 5418)) (5421 11213 ( TALK.NS.USERNAME 5431 . 6816) (TALK.NS.CONNECT 6818 . 10218) (TALK.NS.EVENT 10220 . 10917) ( TALK.NS.CREDENTIALS 10919 . 11211)) (11237 14919 (GAP.SERVER 11247 . 13041) (DEFINE.GAP.SERVER 13043 . 14917))))) STOP \ No newline at end of file diff --git a/lispusers/NSTALKGAP b/lispusers/NSTALKGAP new file mode 100644 index 00000000..991661f1 --- /dev/null +++ b/lispusers/NSTALKGAP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Jul-88 15:50:38" |{MCS:MCS:STANFORD}NSTALKGAP.;2| 7994 changes to%: (COURIERPROGRAMS GAP) (VARS NSTALKGAPCOMS) previous date%: "16-Jun-88 17:40:28" |{MCS:MCS:STANFORD}MEDLEYTALK>NSTALKGAP.;3|) (PRETTYCOMPRINT NSTALKGAPCOMS) (RPAQQ NSTALKGAPCOMS ((COURIERPROGRAMS GAP))) (COURIERPROGRAM GAP (3 3) TYPES ((WaitTime CARDINAL) (CharLength (ENUMERATION (five 0) (six 1) (seven 2) (eight 3))) (Parity (ENUMERATION (none 0) (odd 1) (even 2) (one 3) (zero 4))) (StopBits (ENUMERATION (one 0) (two 1))) (FlowControl (RECORD (type (ENUMERATION (none 0) (xOnXOff 1))) (xOn UNSPECIFIED) (xOff UNSPECIFIED))) (SessionHandle (ARRAY 2 UNSPECIFIED)) (SessionParameterObject (CHOICE (xerox800 0 NIL) (xerox850 1 UNSPECIFIED) (xerox860 2 UNSPECIFIED) (system6 3 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (cmcll 4 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm2770 5 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm2770Host 6 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm6670 7 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm6670Host 8 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm3270 9 NIL) (ibm3270Host 10 NIL) (OldTtyHost 11 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL))) (OldTty 12 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL))) (other 13 NIL) (unknown 14 NIL) (ibm2780 15 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm2780Host 16 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm3780 17 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm3780Host 18 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (siemens9750 19 NIL) (siemens9750Host 20 NIL) (ttyHost 21 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL) (flowControl FlowControl))) (tty 22 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL) (flowControl FlowControl))))) (TransportObject (CHOICE (rs232c 0 (RECORD (CommParams CommParamObject) (preemptOthers ReserveType) (preemptMe ReserveType) (phoneNumber STRING) (line (CHOICE (alreadyReserved 0 (RECORD (resource Resource))) (reserveNeeded 1 (RECORD (lineNumber CARDINAL))))))) (bsc 1 (RECORD (localTerminalID STRING) (localSecurityID STRING) (lineControl LineControl) (authenticateProc UNSPECIFIED))) (teletype 2 NIL) (polledBSCController 3 (RECORD (hostControllerName STRING) (controllerAddress ControllerAddress) (portsOnController CARDINAL))) (sdlcController 4 (RECORD (hostControllerName STRING) (controllerAddress ControllerAddress) (portsOnController CARDINAL))) (polledBSCTerminal 5 (RECORD (hostControllerName STRING) (terminalAddress TerminalAddress))) (sdlcTerminal 6 (RECORD (hostControllerName STRING) (terminalAddress TerminalAddress))) (service 7 (RECORD (id LONGCARDINAL))) (unused 8 NIL) (polledBSCPrinter 9 (RECORD (hostControllerName STRING) (printerAddress TerminalAddress))) (sdlcPrinter 10 (RECORD (hostControllerName STRING) (printerAddress TerminalAddress))))) (Sequence.TransportObject (SEQUENCE TransportObject)) (BidReply (ENUMERATION (wack 0) (nack 1) (default 2))) (ExtendedBoolean (ENUMERATION (true 0) (false 1) (default 2))) (DeviceType (ENUMERATION (undefined 0) (terminal 1) (printer 2))) (AccessDetail (CHOICE (directConn 0 (RECORD (duplex (ENUMERATION (full 0) (half 1))) (lineType LineType) (lineSpeed LineSpeed))) (dialConn 1 (RECORD (duplex (ENUMERATION (full 0) (half 1))) (lineType LineType) (lineSpeed LineSpeed) (dialMode (ENUMERATION (manual 0) (auto 1))) (dialerNumber CARDINAL) (retryCount CARDINAL))))) (CommParamObject (RECORD (accessDetail AccessDetail))) (LineType (ENUMERATION (bitSynchronous 0) (byteSynchronous 1) (asynchronous 2) (autoRecognition 3))) (LineSpeed (ENUMERATION (bps50 0) (bps75 1) (bps110 2) (bps135p5 3) (bps150 4) (bps300 5) (bps600 6) (bps1200 7) (bps2400 8) (bps3600 9) (bps4800 10) (bps7200 11) (bps9600 12) (bps19200 13) (bps28800 14) (bps38400 15) (bps48000 16) (bps56000 17) (bps57600 18))) (LineControl (ENUMERATION (primary 0) (secondary 1))) (ControllerAddress CARDINAL) (TerminalAddress CARDINAL) (credentials (AUTHENTICATION . CREDENTIALS)) (verifier (AUTHENTICATION . VERIFIER)) (Duplexity (ENUMERATION (full 0) (half 1))) (PortClientType (ENUMERATION (unassigned 0) (outOfService 1) (its 2) (irs 3) (gws 4) (ibm3270Host 5) (ttyEmulation 6) (rbs 7) (fax 8) (mailGateway 9) (phototypesetter 10))) (PortDialerType (ENUMERATION (none 0) (vadic 1) (hayes 2) (ventel 3) (rs366 4))) (PortEchoingLocation (ENUMERATION (application 0) (ciu 1) (terminal 2))) (ReserveType (ENUMERATION (preemptNever 0) (preemptAlways 1) (preemptInactive 2))) (RS232CData (RECORD (cIUPort BOOLEAN) (owningClientType PortClientType) (preemptionAllowed BOOLEAN) (lineNumber CARDINAL) (dialerNumber CARDINAL) (duplexity Duplexity) (dialingHardware PortDialerType) (charLength CharLength) (echoing PortEchoingLocation) (flowControl FlowControl) (lineSpeed LineSpeed) (parity Parity) (stopBits StopBits) (portActsAsDCE BOOLEAN) (accessControl NSNAME) (validLineSpeeds (SEQUENCE LineSpeed)))) (RS232CBack (RECORD (owningCIU STRING) (owningECS STRING) (owningClient STRING) (portNumber CARDINAL))) (IBMDeviceType (ENUMERATION (unused 0) (model1 1) (model2 2) (model3 3) (model4 4) (model5 5) (printer 6) (other 7))) (IBM3270Languages (ENUMERATION (USenglish 0) (Austrian 1) (AustrianAlt 2) (German 3) (GermanAlt 4) (Belgian 5) (Brazilian 6) (CanadianFrench 7) (Danish 8) (DanishAlt 9) (Norwegian 10) (NorwegianAlt 11) (Finnish 12) (FinnishAlt 13) (Swedish 14) (SwedishAlt 15) (French 16) (International 17) (Italian 18) (JapaneseEnglish 19) (JapaneseKana 20) (Portuguese 21) (Spanish 22) (SpanishAlt 23) (SpanishSpeaking 24) (UKenglish 25) (unused1 26) (unused2 27) (unused3 28) (unused4 29) (unused5 30) (unused6 31))) (ControllerLinkType (ENUMERATION (sdlc 0) (bsc 1))) (IBM3270Device (RECORD (model IBMDeviceType) (accessControl NSNAME))) (IBM3270Controller (RECORD (controllerAddress CARDINAL) (portsOnController CARDINAL) (linkType ControllerLinkType) (language IBM3270Languages) (devices (SEQUENCE IBM3270Device)))) (IBM3270HostData (SEQUENCE IBM3270Controller)) (IBM3270HostBack (RECORD (path NSNAME)))) PROCEDURES ((Reset 0) (Create 2 (SessionParameterObject Sequence.TransportObject WaitTime credentials verifier) RETURNS (SessionHandle) REPORTS (badAddressFormat controllerAlreadyExists controllerDoesNotExist dialingHardwareProblem illegalTransport inconsistentParams mediumConnectFailed noCommunicationHardware noDialingHardware terminalAddressInUse terminalAddressInvalid tooManyGateStreams transmissionMediumUnavailable serviceTooBusy userNotAuthenticated userNotAuthorized serviceNotFound registeredTwice transmissionMediumHardwareProblem transmissionMediumUnavailable transmissionMediumNotReady noAnswerOrBusy noRouteToGAPService gapServiceNotResponding courierProtocolMismatch gapVersionMismatch))) ERRORS ((unimplemented 0) (noCommunicationHardware 1) (illegalTransport 2) (mediumConnectFailed 3) (badAddressFormat 4) (noDialingHardware 5) (dialingHardwareProblem 6) (transmissionMediumUnavailable 7) (inconsistentParams 8) (tooManyGateStreams 9) (bugInGAPCode 10) (gapNotExported 11) (gapCommunicationError 12) (controllerAlreadyExists 13) (controllerDoesNotExist 14) (terminalAddressInUse 15) (terminalAddressInvalid 16) (serviceTooBusy 17) (userNotAuthenticated 18) (userNotAuthorized 19) (serviceNotFound 20) (registeredTwice 21) (transmissionMediumHardwareProblem 22) (transmissionMediumUnavailable 23) (transmissionMediumNotReady 24) (noAnswerOrBusy 25) (noRouteToGAPService 26) (gapServiceNotResponding 27) (courierProtocolMismatch 28) (gapVersionMismatch 29)) ) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/NSTHASIZE b/lispusers/NSTHASIZE new file mode 100644 index 00000000..6447a9ed --- /dev/null +++ b/lispusers/NSTHASIZE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Mar-89 18:17:39" {ERINYES}MEDLEY>NSTHASIZE.;1 13450 changes to%: (FNS NSTHASIZE) (VARS NSTHASIZECOMS) previous date%: " 8-Apr-86 09:09:30" {DSK}/usr/local/koto/lispusers/nsthasize.;1) (* " Copyright (c) 1986, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSTHASIZECOMS) (RPAQQ NSTHASIZECOMS ((INITVARS (GV.TO.NS.REG)) (FNS CONVERT.GV.TO.NS GV.READFORWARDING READ-GV-NS-MAPPING NSTHASIZE \GETSTRING \GV.COLLECT.ENTRY \GV.COLLECT.ENTRY.1 \GV.COLLECT.ENTRY.LIST) (FILES (LOADCOMP) MAINTAIN))) (RPAQ? GV.TO.NS.REG ) (DEFINEQ (CONVERT.GV.TO.NS [LAMBDA (X) (* lmm " 7-Apr-86 16:23") (COND ((SETQ X (\CHECKNAME X)) (PROG ([REG (MKATOM (U-CASE (CDR X] NSREG) (RETURN (if (EQ REG 'NS) then (OR (CH.LOOKUP.OBJECT (SUBSTRING (CAR X) 2 -2)) (PROGN (PRINTOUT T "[Unable to check " X " in clearinghouse, assuming correct]") (SUBSTRING (CAR X) 2 -2))) else (OR (SETQ NSREG (ASSOC REG GV.TO.NS.REG)) (RETURN)) (LET (NAME) (OR [CH.LOOKUP.OBJECT (SETQ NAME (CONCAT (CAR X) ":" (CDR NSREG] (PROGN (PRINTOUT T "[Unable to check " NAME " in clearinghouse, assuming correct]") NAME]) (GV.READFORWARDING [LAMBDA (X) (* lmm "19-Nov-85 11:20") (CDR (ASSOC 'Forwarding (GV.READENTRY X NIL '\GV.COLLECT.ENTRY]) (READ-GV-NS-MAPPING [LAMBDA NIL (* lmm " 4-Apr-86 16:56") (SETQ GV.TO.NS.REG (RESETLST (PROG ((STREAM (OPENSTREAM '{INDIGO}GV>GV-NS-MAPPING.TXT 'INPUT 'OLD)) (RT (COPYREADTABLE 'ORIG)) LINES) RESTART (RESETSAVE NIL (LIST 'CLOSEF? STREAM)) (SETSEPR NIL NIL RT) (SETBRK (CHARCODE (CR)) NIL RT) (OR (FFILEPOS "GV-to-NS Mappings:" STREAM 0 NIL NIL T) (ERROR "Couldn't find string GV-to-NS Mappings in " (FULLNAME STREAM))) (FILEPOS " " STREAM) [RETURN (do (SELCHARQ (BIN STREAM) (TAB) (CR (RETURN LINES)) (%. [LET ((LINE (RSTRING STREAM RT))) (PRINTOUT T LINE T) (push LINES (LET ((POS (STRPOS " -> " LINE))) (OR POS (GO BADFORMAT)) (CONS [MKATOM (U-CASE (SUBSTRING LINE 1 (SUB1 POS] (SUBSTRING LINE (PLUS POS 4) -1] (BIN STREAM)) (GO BADFORMAT] BADFORMAT (ERROR "bad format on {INDIGO}GV>GV-NS-MAPPING.TXT")))]) (NSTHASIZE [LAMBDA (GVDL NSDL NODELETE) (* ; "Edited 3-Mar-89 18:16 by masinter") (OR GV.TO.NS.REG (PROGN (PRIN1 "Reading gv to ns mapping ...") (READ-GV-NS-MAPPING))) (* lmm " 8-Apr-86 09:03") (SETQ GVDL (OR (\CHECKNAME GVDL) (ERROR "Invalid grapevine group" GVDL))) (SETQ NSDL (OR (CH.LOOKUP.OBJECT NSDL) (ERROR "Invalid NS distribution list" NSDL))) (LET (FORWARDING NSADDRESS) (for X in (CDR (GV.READMEMBERS GVDL)) do (if (OR (COND ((SETQ NSADDRESS (CONVERT.GV.TO.NS X)) (PRINTOUT T X) T)) (AND (SETQ FORWARDING (GV.READFORWARDING X)) (PROGN (PRINTOUT T X " => " FORWARDING) (if (CDR FORWARDING) then (PRINTOUT T " -- more than one address." T) NIL else T)) (if [NOT (SETQ NSADDRESS (CONVERT.GV.TO.NS (CAR FORWARDING] then (PRINTOUT T " not an NS equivalent address." T) NIL else T))) then (PRINTOUT T " => " NSADDRESS "...") (PROG (VALUE) LP (if (OR (type? NSNAME (SETQ VALUE (CH.ADD.MEMBER NSDL 'MEMBERS NSADDRESS))) (MATCH VALUE WITH (%'ERROR %'UPDATE.ERROR %'NoChange --))) then (if (AND NODELETE (OR (NEQ NODELETE 'FIRST) (NLISTP VALUE))) then (PRINTOUT T "ok." T) else (PRINTOUT T "ok, delete: " (GV.REMOVEMEMBER GVDL X) T)) elseif (COND ((AND (EQ (CAR VALUE) 'ERROR) (SELECTQ (CAR (CDR VALUE)) (CALL.ERROR (SELECTQ (CADDR VALUE) (TooBusy (PRINTOUT T " error:" VALUE " ... retrying" " ...")) (AccessRightsInsufficient (PRINTOUT T " error:" VALUE " will not move..." T) (RETURN)) (HELP VALUE)) (GO LP)) (HELP VALUE))) T)) then (TERPRI T) NIL else (HELP VALUE]) (\GETSTRING [LAMBDA (STREAM LENGTH) (* lmm "19-Nov-85 10:21") (COND ((IGREATERP LENGTH \MAXGVSTRING) (ERROR "stream must be confused - string too long" LENGTH)) (T (LET ((STRING (ALLOCSTRING LENGTH))) (AIN STRING 1 LENGTH STREAM) (COND ((ODDP LENGTH) (BIN STREAM))) STRING]) (\GV.COLLECT.ENTRY [LAMBDA (INSTREAM) (* lmm " 4-Apr-86 16:53") (* * Called by GV.READENTRY to parse and display some of what Grapevine sends  back as "the entire database entry" for NAME.  The contents are different for groups, individuals, and dead folk) (LET (NAMETYPE (RESULTS)) (\RECEIVESTAMP INSTREAM T) (* Skip stamp) (BIN16 INSTREAM) (* Skip component count) (* First component is the "prefix" %, which contains, among other things, the  name's type and its "official" name) (BIN16 INSTREAM) (* Length of this component) (\RECEIVESTAMP INSTREAM T) (* Skip stamp) (SETQ NAMETYPE (BIN16 INSTREAM)) (\RECEIVERNAME INSTREAM) (SELECTC NAMETYPE (\NAMETYPE.INDIVIDUAL (\SKIPCOMPONENT INSTREAM) (* Skip password) (SETQ RESULTS (\GV.COLLECT.ENTRY.1 INSTREAM 'ConnectSite RESULTS)) (SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'Forwarding RESULTS)) (SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'MailboxSites RESULTS))) (\NAMETYPE.GROUP (\GV.COLLECT.ENTRY.1 INSTREAM 'Remark RESULTS) (\MT.SKIPSTRINGLIST INSTREAM) (\SKIPCOMPONENT INSTREAM) (* Skip stamp list) (\SKIPCOMPONENT INSTREAM) (* Skip DelMembers) (\SKIPCOMPONENT INSTREAM) (* Skip stamp list) (PROGN (* owners) (\MT.SKIPSTRINGLIST INSTREAM) (\SKIPCOMPONENT INSTREAM) (\SKIPCOMPONENT INSTREAM) (\SKIPCOMPONENT INSTREAM)) (PROGN (* friends) (\MT.SKIPSTRINGLIST INSTREAM) (\SKIPCOMPONENT INSTREAM) (\SKIPCOMPONENT INSTREAM) (\SKIPCOMPONENT INSTREAM)) '((GROUP . T))) (\NAMETYPE.DEAD '((DEAD . T))) NIL]) (\GV.COLLECT.ENTRY.1 [LAMBDA (INSTREAM HEADING RESULTS) (* lmm " 2-Apr-86 12:51") (COND ((EQ (BIN16 INSTREAM) 0) RESULTS) (T (CONS (CONS HEADING (LET [(STRLEN (PROGN (\RECEIVESTAMP INSTREAM T) (* Skip stamp) (BIN16 INSTREAM] (LET ((STRING (ALLOCSTRING STRLEN))) (AIN STRING 1 STRLEN INSTREAM) (COND ((ODDP STRLEN) (BIN INSTREAM))) STRING))) RESULTS]) (\GV.COLLECT.ENTRY.LIST [LAMBDA (INSTREAM HEADING RESULTS) (* lmm " 2-Apr-86 12:52") (* * return a component consisting of an RList, a stamp list, a "removal" RList  (not interesting) and another stamp list) (PROG1 (PROG ((CNT 0) (NWORDS (BIN16 INSTREAM)) STRLEN RMAR VAL) (COND ((EQ NWORDS 0) (RETURN RESULTS))) [do (add CNT 1) (SETQ STRLEN (BIN16 INSTREAM)) (BIN16 INSTREAM) (* ignore maxLength) (push VAL (\GETSTRING INSTREAM STRLEN)) (SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (QUOTIENT (ADD1 STRLEN) 2) 2))) (COND ((ILEQ NWORDS 0) (RETURN] (RETURN (CONS (CONS HEADING VAL) RESULTS))) (\SKIPCOMPONENT INSTREAM) (\SKIPCOMPONENT INSTREAM) (\SKIPCOMPONENT INSTREAM))]) ) (FILESLOAD (LOADCOMP) MAINTAIN) (PUTPROPS NSTHASIZE COPYRIGHT ("Xerox Corporation" 1986 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (830 13324 (CONVERT.GV.TO.NS 840 . 2194) (GV.READFORWARDING 2196 . 2378) ( READ-GV-NS-MAPPING 2380 . 4071) (NSTHASIZE 4073 . 8385) (\GETSTRING 8387 . 8814) (\GV.COLLECT.ENTRY 8816 . 11260) (\GV.COLLECT.ENTRY.1 11262 . 12058) (\GV.COLLECT.ENTRY.LIST 12060 . 13322))))) STOP \ No newline at end of file diff --git a/lispusers/OSS-LYRIC-PATCHES b/lispusers/OSS-LYRIC-PATCHES new file mode 100644 index 00000000..aa713ab0 --- /dev/null +++ b/lispusers/OSS-LYRIC-PATCHES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "24-Mar-88 18:01:18" {eris}oss>lyric>oss-lyric-patches.\;1 2853 |changes| |to:| (vars oss-lyric-patchescoms) |previous| |date:| "24-Mar-88 16:56:45" {eris}oss>lyric>lyric-do-patch.\;1) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint oss-lyric-patchescoms) (rpaqq oss-lyric-patchescoms ((* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") (fns (* |;;| "from CMLSPECIALFORMS") \\do.translate) (functions (* |;;| "from CMLLIST") cl::%mapcar-multiple cl::%fill-slice-from-lists)) ) (* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") (defineq (\\do.translate (lambda (vars end-test body sequentialp env) (* \; "Edited 24-Mar-88 16:40 by drc:") (let ((vars-and-initial-values (mapcar vars (function (lambda (x) (cond ((nlistp x) (list x nil)) (t (list (car x) (cadr x)))))))) (subsequent-values (mapcar vars (function (lambda (x) (and (listp x) (cddr x) (list (car x) (caddr x))))))) (tag (gensym))) (and (setq subsequent-values (remove nil subsequent-values)) (setq subsequent-values (cons (cond (sequentialp (quote cl:setq)) (t (quote cl:psetq))) (apply (function append) subsequent-values)))) (cl:multiple-value-bind (body decls) (parse-body body env) (bquote ((\\\, (cond (sequentialp (quote prog*)) (t (quote prog)))) (\\\, vars-and-initial-values) (\\\,@ decls) (\\\, tag) (cond ((\\\, (car end-test)) (return (progn (\\\,@ (cdr end-test)))))) (\\\,@ body) (\\\, subsequent-values) (go (\\\, tag))))))) ) ) (cl:defun cl::%mapcar-multiple (cl::fn cl::lists) (let ((cl::arg-slice (cl:make-list (length cl::lists)))) (cl:do ((cl::result nil) (cl::result-tail nil) (cl::current-slice cl::arg-slice) cl::element) ((null cl::current-slice) cl::result) (cl:setq cl::current-slice (cl::%fill-slice-from-lists cl::lists cl::arg-slice (car cl::arg-tail))) (cond (cl::current-slice (* \; "There is really more work to do.") (cl:setq cl::element (cl:apply cl::fn cl::current-slice)) (cl::%list-collect cl::result cl::result-tail (list cl::element))))))) (defmacro cl::%fill-slice-from-lists (cl::lists cl::arg-slice cl::arg-tail-form) (bquote (cl:do ((cl::subslice (\\\, cl::arg-slice) (cdr cl::subslice)) (cl::sublist (\\\, cl::lists) (cdr cl::sublist)) (cl::some-list-empty nil) list) ((null cl::sublist) (cond (cl::some-list-empty (* \; "Ran out of entries in a list.") nil) (t (* \; "still work to do; return it.") (\\\, cl::arg-slice)))) (cl:setq list (car cl::sublist)) (cl:setq cl::some-list-empty (or cl::some-list-empty (null list))) (rplaca cl::subslice (prog1 (\\\, (cl:subst (quote list) (quote cl::arg-tail) cl::arg-tail-form)) (rplaca cl::sublist (cdr list))))))) (putprops oss-lyric-patches copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil (723 1605 (\\do.translate 733 . 1603))))) stop \ No newline at end of file diff --git a/lispusers/PAC-MAN-IDLE b/lispusers/PAC-MAN-IDLE new file mode 100644 index 00000000..6c7da3e7 --- /dev/null +++ b/lispusers/PAC-MAN-IDLE @@ -0,0 +1 @@ +(FILECREATED "30-Jun-86 18:01:00" {PHYLUM}LISP>USERS>PAC-MAN-IDLE.;11 14703 changes to: (VARS PAC-MAN-IDLECOMS) (FNS Pac-Man-Eat-Window Slow-Fade Pac-Man-Idle) previous date: " 2-May-86 18:42:49" {PHYLUM}LISP>USERS>PAC-MAN-IDLE.;10) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PAC-MAN-IDLECOMS) (RPAQQ PAC-MAN-IDLECOMS [(* * The Pac-Man idle function) (FNS Pac-Man-Eat-Window Pac-Man-Idle) (VARS DefaultPacManEatMask DefaultPacManIcon DefaultPacManMask) (INITVARS (Pac-Man-Delay 100) (pacManHorizonFactor .75) (pacManStarvationTime 75) (pacManEatMask DefaultPacManEatMask) (pacManIcon DefaultPacManIcon) (pacManMask DefaultPacManMask)) (GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime pacManEatMask pacManIcon pacManMask) (FNS Pac-Man-Scout-Food) (* * Stuff for counting the bits on in a bitmap) (FNS Pac-Man-Amount-Of-Food) (MACROS Pac-Man-Convert-Word) (VARS (Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T))) (GLOBALVARS Pac-Man-Convert-Byte-Array) [P (for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i (bind (j _ i) while (NOT (ZEROP j)) count (SETQ j (LOGAND j (SUB1 j] (* * Another idle function) (FNS Slow-Fade) [INITVARS (Slow-Fade-Delay 1000) (Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE (QUOTE DISPLAYFN] (GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function) (* * Add them as idle functions) (ADDVARS (IDLE.FUNCTIONS ("Pac-man" (QUOTE Pac-Man-Idle)) ("Slow fade" (QUOTE Slow-Fade]) (* * The Pac-Man idle function) (DEFINEQ (Pac-Man-Eat-Window [LAMBDA (window) (* smL "30-Jun-86 17:38") (* * Comment) (RESETLST (bind (minX _(MINUS (QUOTIENT (BITMAPWIDTH pacManIcon) 2))) (minY _(MINUS (QUOTIENT (BITMAPHEIGHT pacManIcon) 2))) (maxX _(DIFFERENCE (WINDOWPROP window (QUOTE WIDTH)) (QUOTIENT (BITMAPWIDTH pacManIcon) 2))) (maxY _(DIFFERENCE (WINDOWPROP window (QUOTE HEIGHT)) (QUOTIENT (BITMAPHEIGHT pacManIcon) 2))) (minimumSpeed _ .2) (maximumSpeed _ 1.0) (icon _(DEFERREDCONSTANT (BITMAPCOPY pacManIcon))) (delayTimer _(DEFERREDCONSTANT (SETUPTIMER 250))) [horizon _(FIX (MAX 2 (TIMES (MIN (BITMAPWIDTH pacManIcon) (BITMAPHEIGHT pacManIcon)) pacManHorizonFactor] (delta _(QUOTE (0 . 0))) possibleDeltas x y (xSpeed _ 0) (ySpeed _ 0) [maxSpeed _(TIMES 10 (MIN (BITMAPWIDTH pacManIcon) (BITMAPHEIGHT pacManIcon] (maxAcceleration _(MIN (BITMAPWIDTH pacManIcon) (BITMAPHEIGHT pacManIcon))) (stepsWithoutFood _ 0) first [SETQ possibleDeltas (for pair in (QUOTE ((0 . -1) (-1 . 0) (1 . 0) (0 . 1) (.707 . .707) (-.707 . .707) (.707 . -.707) (-.707 . -.707))) collect (CONS (FIX (TIMES horizon (CAR pair))) (FIX (TIMES horizon (CDR pair] (* Pick a random starting place) (SELECTQ (RAND 0 1) [0 (SETQ x (TIMES (WINDOWPROP window (QUOTE WIDTH)) (RAND 0 1))) (SETQ y (RAND 0 (WINDOWPROP window (QUOTE HEIGHT] [1 [SETQ x (RAND 0 (WINDOWPROP window (QUOTE WIDTH] (SETQ y (TIMES (WINDOWPROP window (QUOTE WIDTH)) (RAND 0 1] NIL) while T do (* * Try to figure out which direction to go. Pick the one that would get us the most food. Make sure to block, and don't move to quickly (hah!)) (SETQ delayTimer (SETUPTIMER Pac-Man-Delay delayTimer)) [SETQ delta (Pac-Man-Scout-Food window x y pacManEatMask possibleDeltas delta (DEFERREDCONSTANT (BITMAPCREATE (PLUS (TIMES 16 (QUOTIENT (BITMAPWIDTH pacManMask) 16)) (if (ZEROP (REMAINDER (BITMAPWIDTH pacManMask) 16)) then 0 else 16)) (BITMAPHEIGHT pacManMask] (COND ((NOT (NULL delta)) (* Found some food) NIL) ((GREATERP stepsWithoutFood pacManStarvationTime) (* Starving, so make a random jump) (change xSpeed (RAND (DIFFERENCE minX x) (DIFFERENCE maxX x))) (change ySpeed (RAND (DIFFERENCE minY y) (DIFFERENCE maxY y))) (SETQ stepsWithoutFood 0) (SETQ delta (CONS xSpeed ySpeed))) (T (add stepsWithoutFood 1) (change xSpeed (RAND (MINUS maxAcceleration) maxAcceleration)) (change xSpeed (MAX (DIFFERENCE minX x) (MIN (DIFFERENCE maxX x) DATUM))) (change ySpeed (RAND (MINUS maxAcceleration) maxAcceleration)) (change ySpeed (MAX (DIFFERENCE minY y) (MIN (DIFFERENCE maxY y) DATUM))) (SETQ delta (CONS xSpeed ySpeed))) (T (SETQ stepsWithoutFood 0) (SETQ xSpeed 0) (SETQ ySpeed 0))) (do (BLOCK) repeatuntil (TIMEREXPIRED? delayTimer)) (* * Eat the food at the current location) (BITBLT pacManEatMask NIL NIL window x y NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (* * Update my location) [change x (FIX (MAX minX (MIN maxX (PLUS DATUM (TIMES (RAND minimumSpeed maximumSpeed) (CAR delta] [change y (FIX (MAX minY (MIN maxY (PLUS DATUM (TIMES (RAND minimumSpeed maximumSpeed) (CDR delta] (BITBLT window x y icon NIL NIL NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT pacManMask NIL NIL icon NIL NIL NIL NIL (QUOTE INPUT) (QUOTE ERASE)) (BITBLT pacManIcon NIL NIL icon NIL NIL NIL NIL (QUOTE INPUT) (QUOTE PAINT)) (BITBLT icon NIL NIL window x y NIL NIL (QUOTE INPUT) (QUOTE REPLACE]) (Pac-Man-Idle [LAMBDA (window) (* smL "30-Jun-86 17:41") (* * A hungry idle function) (BITBLT (WINDOWPROP window (QUOTE IMAGECOVERED)) NIL NIL window NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) (Pac-Man-Eat-Window window]) ) (RPAQ DefaultPacManEatMask (READBITMAP)) (27 27 "@@AO@@@@" "@@GOL@@@" "@AOOO@@@" "@GOOOL@@" "@OOOON@@" "AOOOOO@@" "AOOOOO@@" "COOOOOH@" "COOOOOH@" "GOOOOOL@" "GOOOOOL@" "OOOOOON@" "OOOOOON@" "OOOOOON@" "OOOOOON@" "OOOOOON@" "GOOOOOL@" "GOOOOOL@" "COOOOOH@" "COOOOOH@" "AOOOOO@@" "AOOOOO@@" "@OOOON@@" "@GOOOL@@" "@AOOO@@@" "@@GOL@@@" "@@AO@@@@") (RPAQ DefaultPacManIcon (READBITMAP)) (27 27 "@@AE@@@@" "@@EED@@@" "@@JJJ@@@" "@BJJJH@@" "@EEEED@@" "AEEGME@@" "@JJONJ@@" "BJJONJH@" "AEEEEE@@" "EEEEEED@" "BJJJJJH@" "JJJJJJJ@" "EEEEEED@" "EEEEEED@" "JJJH@@@@" "JJJJ@@@@" "EEEE@@@@" "EEEE@@@@" "BJJJH@@@" "BJJJJ@@@" "AEEEE@@@" "AEEEE@@@" "@JJJJH@@" "@BJJJH@@" "@AEEE@@@" "@@EED@@@" "@@@J@@@@") (RPAQ DefaultPacManMask (READBITMAP)) (27 27 "@@AO@@@@" "@@GOL@@@" "@AOOO@@@" "@GOOOL@@" "@OOOON@@" "AOOOOO@@" "AOOOOO@@" "COOOOOH@" "COOOOOH@" "GOOOOOL@" "GOOOOOL@" "OOOOOON@" "OOOOOON@" "OOOOOON@" "OOOL@@@@" "OOON@@@@" "GOOO@@@@" "GOOOH@@@" "COOOL@@@" "COOON@@@" "AOOOO@@@" "AOOOOH@@" "@OOOOL@@" "@GOOOL@@" "@AOOO@@@" "@@GOL@@@" "@@AO@@@@") (RPAQ? Pac-Man-Delay 100) (RPAQ? pacManHorizonFactor .75) (RPAQ? pacManStarvationTime 75) (RPAQ? pacManEatMask DefaultPacManEatMask) (RPAQ? pacManIcon DefaultPacManIcon) (RPAQ? pacManMask DefaultPacManMask) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime pacManEatMask pacManIcon pacManMask) ) (DEFINEQ (Pac-Man-Scout-Food [LAMBDA (window x y mask possibleDeltas prevDelta tempBitMap) (* smL "29-Apr-86 12:55") (* * Return the x-y pair of directions to go to get the most food) (for i from 1 to 8 bind direction thereis [SETQ direction (for offsetPair in [for x in possibleDeltas collect (CONS (TIMES i (CAR x)) (TIMES i (CDR x] bind xoffset yoffset amountOfFood (mostFood _ 0) (mostFoodDirections _ NIL) do (SETQ xoffset (CAR offsetPair)) (SETQ yoffset (CDR offsetPair)) (* * Build a bitmap of the food available at the location. - This requires computing the number of bits that are black both in the window and in the mask. - We want black bits in the window because things have been inverted by idle and we are trying to eat white bits, and we want black bits in the mask because that is what defines the mask.) (* Copy the screen bits into the temp bitmap.) (BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) (BITBLT window (PLUS xoffset x) (PLUS yoffset y) tempBitMap NIL NIL NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (* Or in the white bits of the mask at the appropriate location.) (BITBLT mask NIL NIL tempBitMap NIL NIL NIL NIL (QUOTE INVERT) (QUOTE ERASE)) (* Clear out the image of the current position of the  mask.) (BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE) (BITBLT mask (MAX 0 xoffset) (MAX 0 yoffset) tempBitMap (MAX 0 (MINUS xoffset)) (MAX 0 (MINUS yoffset)) NIL NIL (QUOTE INPUT) (QUOTE PAINT)) (BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE) (* Compute the amount of food) (SETQ amountOfFood (Pac-Man-Amount-Of-Food tempBitMap)) (* Remember the directions with the most food) (if (LESSP amountOfFood mostFood) then (* This direction loses) NIL elseif (EQP amountOfFood mostFood) then (* This is a possible direction) (push mostFoodDirections offsetPair) else (* This direction dominates) (SETQ mostFood amountOfFood) (SETQ mostFoodDirections (LIST offsetPair))) finally (RETURN (if (ZEROP mostFood) then NIL else (CAR (NTH mostFoodDirections (RAND 1 (LENGTH mostFoodDirections] finally (RETURN direction]) ) (* * Stuff for counting the bits on in a bitmap) (DEFINEQ (Pac-Man-Amount-Of-Food [LAMBDA (bitMap) (* smL "29-Apr-86 13:23") (* * How much food is there in the bitmap?) (for j from 0 to (QUOTIENT (TIMES (BITMAPHEIGHT bitMap) (BITMAPWIDTH bitMap)) 16) bind (bitmapBase _(fetch (BITMAP BITMAPBASE) of bitMap)) sum (Pac-Man-Convert-Word (\GETBASE bitmapBase j]) ) (DECLARE: EVAL@COMPILE [DEFMACRO Pac-Man-Convert-Word (word) (* * Count up the number of bits on in the word) (BQUOTE (PLUS (\GETBASE Pac-Man-Convert-Byte-Array (LRSH , word 8)) (\GETBASE Pac-Man-Convert-Byte-Array (LOGAND , word 255] ) (RPAQ Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T)) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS Pac-Man-Convert-Byte-Array) ) [for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i (bind (j _ i) while (NOT (ZEROP j)) count (SETQ j (LOGAND j (SUB1 j] (* * Another idle function) (DEFINEQ (Slow-Fade [LAMBDA (window) (* smL "30-Jun-86 17:16") (* * Slowly fade the idle window to black) (BITBLT (WINDOWPROP window (QUOTE IMAGECOVERED)) NIL NIL window NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) [LET [(fadeTextures (for i from 0 to 15 collect (LLSH 1 i] (while fadeTextures bind selectedTexture do (BLOCK Slow-Fade-Delay) (SETQ selectedTexture (LLSH 1 (RAND 0 15))) (BITBLT NIL NIL NIL window NIL NIL NIL NIL (QUOTE TEXTURE) (QUOTE ERASE) selectedTexture) (SETQ fadeTextures (DREMOVE selectedTexture fadeTextures] (BLOCK Slow-Fade-Delay) (APPLY* (OR Default-Slow-Fade-Idle-Function (FUNCTION IDLE.BOUNCING.BOX)) window]) ) (RPAQ? Slow-Fade-Delay 1000) (RPAQ? Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE (QUOTE DISPLAYFN))) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function) ) (* * Add them as idle functions) (ADDTOVAR IDLE.FUNCTIONS ("Pac-man" (QUOTE Pac-Man-Idle)) ("Slow fade" (QUOTE Slow-Fade))) (PUTPROPS PAC-MAN-IDLE COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1826 7263 (Pac-Man-Eat-Window 1836 . 6918) (Pac-Man-Idle 6920 . 7261)) (8683 12226 ( Pac-Man-Scout-Food 8693 . 12224)) (12282 12768 (Pac-Man-Amount-Of-Food 12292 . 12766)) (13370 14261 ( Slow-Fade 13380 . 14259))))) STOP \ No newline at end of file diff --git a/lispusers/PACKED-STRUCTURE b/lispusers/PACKED-STRUCTURE new file mode 100644 index 00000000..af6d27bb --- /dev/null +++ b/lispusers/PACKED-STRUCTURE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "19-Oct-87 14:53:33" il:{erinyes}lyric>packed-structure.\;1 4305 il:|changes| il:|to:| (il:setfs logbitp) (il:functions def-packed-structure signed-ldb) il:|previous| il:|date:| "29-Sep-87 18:13:33" il:|{IE:PARC:XEROX}LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:packed-structurecoms) (il:rpaqq il:packed-structurecoms ((il:functions def-packed-structure signed-ldb) (il:setfs logbitp) (il:prop il:makefile-environment il:packed-structure)) ) (defdefiner def-packed-structure il:structures (name &rest slots) (let* ((*package* (symbol-package name)) (count 0) (max-count 0) (locations)) (labels ((slot-name (slot) (car slot)) (slot-type (slot) (let ((type (getf (cddr slot) (quote :type) t))) (cond ((subtypep type (quote (member nil t))) (quote :boolean)) (t (il:* il:\; " punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte ") type)))) (infix (x y) (intern (format nil "~A-~A" (string x) (string y)))) (slot-location (slot) (cdr (assoc (slot-name slot) locations))) (slot-supplied-p (slot) (infix (slot-name slot) "SUPPLIED-P")) (slot-signed (slot) (and (listp (slot-type slot)) (eq (car (slot-type slot)) (quote signed-byte)))) (slot-size (slot) (let ((type (slot-type slot))) (case type (:boolean 1) (t (ecase (car type) ((unsigned-byte signed-byte) (second type)))))))) (mapc (function (lambda (slot) (when (getf (cddr slot) (quote :overlay)) (setq count 0)) (push (cons (slot-name slot) count) locations) (incf count (slot-size slot)) (setq max-count (max max-count count)))) slots) (il:bquote (progn (deftype (il:\\\, name) nil (quote (unsigned-byte (il:\\\, count)))) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (defmacro (il:\\\, (infix name (slot-name s))) (x) (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logbitp (il:\\\, (quote (il:\\\, (slot-location s)))) (il:\\\, x))))) (t (il:bquote (il:bquote ((il:\\\, (quote (il:\\\, (if (slot-signed s) (quote signed-ldb) (quote ldb))))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, x))))))))))) slots)) (defmacro (il:\\\, (infix "MAKE" name)) (&key (il:\\\,@ (mapcar (function (lambda (s) (list (slot-name s) (second s) (slot-supplied-p s)))) slots)) &aux (value 0)) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (when (il:\\\, (slot-supplied-p s)) (setq value (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logior (if (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (ash 1 (slot-location s))))) 0) (il:\\\, value))))) ((slot-signed s) (il:bquote (il:bquote (dpb (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, value))))) (t (il:bquote (il:bquote (logior (ash (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (slot-location s))))) (il:\\\, value)))))))))))) slots)) value)))))) (defun signed-ldb (bytespec integer) (flet ((sign-extend (number position) (if (logbitp (1- position) number) (dpb number (byte position 0) -1) number))) (sign-extend (ldb bytespec integer) (byte-size bytespec)))) (define-setf-method logbitp (index integer) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method integer) (il:* il:\; "get SETF method for integer.") (let ((btemp (il:gensym)) (il:* il:\; "Temp var for index") (store (il:gensym)) (il:* il:\; "Temp var for new value") (stemp (first stores)) (il:* il:\; "Temp var for int to store.")) (values (cons btemp temps) (il:* il:\; "Temporary variables.") (cons index vals) (il:* il:\; "Value forms.") (list store) (il:* il:\; "Store variables.") (il:bquote (let (((il:\\\, stemp) (if (il:\\\, store) (logior (il:\\\, access-form) (ash 1 (il:\\\, btemp))) (logandc2 (il:\\\, access-form) (ash 1 (il:\\\, btemp)))))) (il:\\\, store-form) (il:\\\, store))) (il:* il:\; "Storing form") (il:bquote (logbitp (il:\\\, btemp) (il:\\\, access-form))))))) (il:putprops il:packed-structure il:makefile-environment (:readtable "XCL" :package "XCL-USER")) (il:putprops il:packed-structure il:copyright ("Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/PACMAN b/lispusers/PACMAN new file mode 100644 index 00000000..712ac2ad --- /dev/null +++ b/lispusers/PACMAN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Feb-89 15:12:20" {ERIS}INTERNAL>LIBRARY>PACMANCORE>PACMAN.;6 153326 changes to%: (FNS INCOLORQ HASCOLORDISPLAYP PACMANINITNEW MOVEPACMAN ASSIGNDIR BLINKENERGIZERS PLAYERBOARDVAL BOARDVAL CHECKAT COLLISIONCHECK DECIDE DOTCHECK DRAWBOARD DRAWBOARDNEW ENERGIZERCHECK ERASEOBJ FRUITCHECK FRUITINIT GETHISCORES GETMONEY GETMOVE VOICEINPUT XLOCTOSCREEN XSCREENTOLOC YLOCTOSCREEN YSCREENTOLOC HISCORE INPUTMODEQ INTERMISSION1 ISIGN JOYSTICK LOSE MOVEDOWN MOVEGHOST MOVELEFT MOVEOBJ MOVERIGHT MOVEUP NEWHISCORES PACINTRO PACMAN PACMANINIT PACMANNEWGAME PACMANREINIT PAINTOBJ PAINTDOT PUTDOTS PUTDOTSAGAIN PUTENERGIZERS REDODOT REPLACEOBJ SCAN SETBITMAPS SETBOARDVAL SETCHARPROPS SETGCANS SETGLOCS SETPLAYERBOARDVAL SHOW SHOWCAP SHOWHISCORES SPEEDQ) (VARS PACMANCOMS 1600BITMAP 200BITMAP 400BITMAP 800BITMAP APPLEBITMAP ATTRACTMODE BELLBITMAP BIGPMANC BIGPMANR BIRDBITMAP BLUETIME BOARD BOARDLIST CHERRY CHERRYBITMAP COLORPMANDOWN COLORPMANLEFT COLORPMANRIGHT COLORPMANUP DOT ENERGIZER ENERGIZEROBJ EYESBITMAP FRUIT# FRUITTIME G1BITMAP G2BITMAP G3BITMAP G4BITMAP GINVBITMAP KEYBITMAP MRIGHT ORANGEBITMAP PACMANC PACMANINCOLOR PINEAPPLEBITMAP PMAN PMANDOWN PMANLEFT PMANRIGHT PMANUP PMGAMEOVER) previous date%: " 3-Feb-89 12:51:56" {ERIS}INTERNAL>LIBRARY>PACMANCORE>PACMAN.;3) (* " Copyright (c) 1984, 1985, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PACMANCOMS) (RPAQQ PACMANCOMS ((FNS ASSIGNDIR BLINKENERGIZERS PLAYERBOARDVAL BOARDVAL CHECKAT COLLISIONCHECK DECIDE DOTCHECK DRAWBOARD DRAWBOARDNEW ENERGIZERCHECK ERASEOBJ FRUITCHECK FRUITINIT GETHISCORES GETMONEY GETMOVE VOICEINPUT XLOCTOSCREEN XSCREENTOLOC YLOCTOSCREEN YSCREENTOLOC HISCORE INCOLORQ INPUTMODEQ HASCOLORDISPLAYP INTERMISSION1 ISIGN JOYSTICK LOSE MOVEDOWN MOVEGHOST MOVELEFT MOVEOBJ MOVEPACMAN MOVERIGHT MOVEUP NEWHISCORES PACINTRO PACMAN PACMANINIT PACMANINITNEW PACMANNEWGAME PACMANREINIT PAINTOBJ PAINTDOT PUTDOTS PUTDOTSAGAIN PUTENERGIZERS REDODOT REPLACEOBJ SCAN SETBITMAPS SETBOARDVAL SETCHARPROPS SETGCANS SETGLOCS SETPLAYERBOARDVAL SHOW SHOWCAP SHOWHISCORES SPEEDQ) (VARS 1600BITMAP 200BITMAP 400BITMAP 800BITMAP APPLEBITMAP ATTRACTMODE BELLBITMAP BIGPMANC BIGPMANR BIRDBITMAP BLUETIME BOARD BOARDLIST CHERRY CHERRYBITMAP COLORPMANDOWN COLORPMANLEFT COLORPMANRIGHT COLORPMANUP DOT ENERGIZER ENERGIZEROBJ EYESBITMAP FRUIT# FRUITTIME G1BITMAP G2BITMAP G3BITMAP G4BITMAP GINVBITMAP KEYBITMAP MRIGHT (NEXTMOVE 0) ORANGEBITMAP PACMANC PACMANINCOLOR PINEAPPLEBITMAP PMAN PMANDOWN PMANLEFT PMANRIGHT PMANUP PMGAMEOVER PSTREAM (PWINDOW) QUARTERBITMAP ROW SIGLOGO STRAWBERRYBITMAP (PACMANWAITTIME 100) (PMANINPUTMODE)) (BITMAPS PMANUPMAP COLORPMANUP PMANRIGHTMAP COLORPMANRIGHT PMANDOWNMAP COLORPMANDOWN PMANLEFTMAP COLORPMANLEFT PACMANCMAP COLORPACMANC DOT COLORDOT ENERGIZER COLORENERGIZER BWG1BITMAP COLORG1BITMAP BWG2BITMAP COLORG2BITMAP BWG3BITMAP COLORG3BITMAP BWG4BITMAP COLORG4BITMAP BWGINVBITMAP COLORGINVBITMAP CHERRYBITMAP COLORCHERRYBITMAP STRAWBERRYBITMAP COLORSTRAWBERRYBITMAP ORANGEBITMAP COLORORANGEBITMAP APPLEBITMAP COLORAPPLEBITMAP PINEAPPLEBITMAP COLORPINEAPPLEBITMAP BIRDBITMAP COLORBIRDBITMAP BELLBITMAP COLORBELLBITMAP KEYBITMAP COLORKEYBITMAP 200BITMAP COLOR200BITMAP 400BITMAP COLOR400BITMAP 800BITMAP COLOR800BITMAP 1600BITMAP COLOR1600BITMAP SIGLOGO COLORSIGLOGO EYESBITMAP COLOREYESBITMAP BIGPMANC COLORBIGPMANC BIGPMANR COLORBIGPMANR QUARTERBITMAP COLORQUARTERBITMAP) (ARRAY BOARD VIRGINBOARD) (DECLARE%: DOEVAL@COMPILE (GLOBALVARS 1600BITMAP 200BITMAP 400BITMAP 800BITMAP APPLEBITMAP ATTRACTMODE BELLBITMAP BIGPMANC BIGPMANR BIRDBITMAP BLUETIME BOARD BOARDLIST BWG1BITMAP BWG2BITMAP BWG3BITMAP BWG4BITMAP BWGINVBITMAP CHERRYBITMAP COLOR1600BITMAP COLOR200BITMAP COLOR400BITMAP COLOR800BITMAP COLORAPPLEBITMAP COLORBELLBITMAP COLORBIGPMANC COLORBIGPMANR COLORBIRDBITMAP COLORCHERRYBITMAP COLORDOT COLORENERGIZER COLOREYESBITMAP COLORG1BITMAP COLORG2BITMAP COLORG3BITMAP COLORG4BITMAP COLORGINVBITMAP COLORKEYBITMAP COLORORANGEBITMAP COLORPACMANC COLORPINEAPPLEBITMAP COLORPMANDOWN COLORPMANLEFT COLORPMANRIGHT COLORPMANUP COLORQUARTERBITMAP COLORSIGLOGO COLORSTRAWBERRYBITMAP DOT ENERGIZER ENERGIZEROBJ EYESBITMAP FOLLOW FRUIT# FRUITLIST FRUITTIME FRUITVISIBLE G1 G1BITMAP G2 G2BITMAP G3 G3BITMAP G4 G4BITMAP GINVBITMAP GVALUE GVALUEBITMAPLIST GVALUEPOS HASDOT HILIST HINAMES HIVALUES KEYBITMAP LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY NAME NETP NEXTMOVE NUMDOTS NUMMEN OLDG1 OLDG2 OLDG3 OLDG4 OLDPMAN ORANGEBITMAP PMANINPUTMODE PACMANC PACMANCMAP PACMANINCOLOR PACMANVERSION PINEAPPLEBITMAP PIT PMANDOWN PMANDOWNMAP PMANLEFT PMANLEFTMAP PMANRIGHT PMANRIGHTMAP PMANUP PMANUPMAP PMGAMEOVER PMOLDCOLORMAP PMWANTMORE PSTREAM PWINDOW QUARTERBITMAP SAVEGVALUE SCORE SIGLOGO STRAWBERRYBITMAP VIRGINBOARD)))) (DEFINEQ (ASSIGNDIR [LAMBDA (GNUM WANT) (* MD "27-JAN-84 11:32" When a ghost has a choice of directions to move in,  this makes sure they don't all choose the same way  (avoids piggybacking) Returns the final assignment of direction for move) (SELECTQ GNUM (1 [for TRY in '(8 2 4 1) as ANS in '(2 1 3 4) do (COND ((NEQ (LOGAND WANT TRY) 0) (RETURN ANS]) (2 [for TRY in '(2 8 1 4) as ANS in '(1 2 4 3) do (COND ((NEQ (LOGAND WANT TRY) 0) (RETURN ANS]) (3 [for TRY in '(4 8 2 1) as ANS in '(3 2 1 4) do (COND ((NEQ (LOGAND WANT TRY) 0) (RETURN ANS]) (4 [for TRY in '(1 8 4 2) as ANS in '(4 2 3 1) do (COND ((NEQ (LOGAND WANT TRY) 0) (RETURN ANS]) T]) (BLINKENERGIZERS [LAMBDA NIL (* MD "11-AUG-83 13:04") (COND ((CHECKAT 1 3 32) (PAINTOBJ ENERGIZEROBJ (ITIMES 1 11) (ITIMES 11 (IDIFFERENCE 30 3)) 8 8 PSTREAM))) (COND ((CHECKAT 26 3 32) (PAINTOBJ ENERGIZEROBJ (ITIMES 26 11) (ITIMES 11 (IDIFFERENCE 30 3)) 8 8 PSTREAM))) (COND ((CHECKAT 1 23 32) (PAINTOBJ ENERGIZEROBJ (ITIMES 1 11) (ITIMES 11 (IDIFFERENCE 30 23)) 8 8 PSTREAM))) (COND ((CHECKAT 26 23 32) (PAINTOBJ ENERGIZEROBJ (ITIMES 26 11) (ITIMES 11 (IDIFFERENCE 30 23)) 8 8 PSTREAM]) (PLAYERBOARDVAL [LAMBDA (PLAYER) (* rrb " 3-Feb-84 10:55") (* returns the representation of the  board square that PLAYER is  currently located at.) (BOARDVAL (GETPROP PLAYER 'XLOC) (GETPROP PLAYER 'YLOC]) (BOARDVAL [LAMBDA (X Y) (* MD "28-NOV-83 16:44") (CAR (FNTH (ELT BOARD Y) X]) (CHECKAT [LAMBDA (X Y BIT) (* rrb "31-Jan-84 14:02") (NEQ (LOGAND (BOARDVAL X Y) BIT) 0]) (COLLISIONCHECK [LAMBDA (PMAN) (* MD " 4-JAN-84 14:01") (PROG (X Y GHOST OLDGHOST) (SETQ X (GETPROP PMAN 'XLOC)) (SETQ Y (GETPROP PMAN 'YLOC)) (COND ((CHECKAT X Y 3840) (* Was there a collision?) (SETQ GNUM (LOGAND (BOARDVAL X Y) 3840)) (COND ((IGEQ GNUM 2048) (SETQ GHOST G4) (SETQ OLDGHOST OLDG4)) ((IGEQ GNUM 1024) (SETQ GHOST G3) (SETQ OLDGHOST OLDG3)) ((IGEQ GNUM 512) (SETQ GHOST G2) (SETQ OLDGHOST OLDG2)) ((IGEQ GNUM 256) (SETQ GHOST G1) (SETQ OLDGHOST OLDG1))) (COND ((EQ FOLLOW 1) (* A ghost got him) (LOSE)) (T (* He got a ghost) (SHOW (add SCORE GVALUE)) (SETQ SAVEGVALUE GVALUE) (PUTPROP (CAR (NTH GVALUEBITMAPLIST (IQUOTIENT GVALUE 20))) 'OPERATION 'INVERT) (COND ((IGREATERP (CAR GVALUEPOS) 0) (* Erase the previously displayed  point value before painting the new  one.) (ERASEOBJ (CAR (NTH GVALUEBITMAPLIST (IQUOTIENT (IQUOTIENT GVALUE 2) 20))) (CAR GVALUEPOS) (CDR GVALUEPOS) 16 16 PSTREAM))) (PAINTOBJ (CAR (NTH GVALUEBITMAPLIST (IQUOTIENT GVALUE 20))) (change (CAR GVALUEPOS) (IDIFFERENCE (ITIMES (GETPROP GHOST 'XLOC) 11) 6)) (change (CDR GVALUEPOS) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP GHOST 'YLOC)) 11) 6)) 16 16 PSTREAM) (SETQ GVALUE (ITIMES GVALUE 2)) (PUTPROP GHOST 'EATEN 1))) (DISMISS 1500) (ERASEOBJ GHOST (IDIFFERENCE (ITIMES (GETPROP GHOST 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP GHOST 'YLOC)) 11) 6) 16 16 PSTREAM) (COND [(EQ (GETPROP GHOST 'EATEN) 1) (PUTPROP GHOST 'BITMAP (COND (PACMANINCOLOR COLOREYESBITMAP) (T EYESBITMAP))) (PUTPROP OLDGHOST 'BITMAP (GETPROP GHOST 'BITMAP)) (SETBOARDVAL X Y (IDIFFERENCE (BOARDVAL X Y) (GETPROP GHOST 'BIT] (T [for G in '(G1 G2 G3 G4) do [SETBOARDVAL (GETPROP (EVAL G) 'XLOC) (GETPROP (EVAL G) 'YLOC) (IDIFFERENCE (BOARDVAL (GETPROP (EVAL G) 'XLOC) (GETPROP (EVAL G) 'YLOC)) (GETPROP (EVAL G) 'BIT] (PUTPROP (EVAL G) 'XLOC (GETPROP (EVAL G) 'INITX)) (PUTPROP (EVAL G) 'YLOC (GETPROP (EVAL G) 'INITY)) (SETBOARDVAL (GETPROP (EVAL G) 'XLOC) (GETPROP (EVAL G) 'YLOC) (IPLUS (BOARDVAL (GETPROP (EVAL G) 'XLOC) (GETPROP (EVAL G) 'YLOC)) (GETPROP (EVAL G) 'BIT] (SETGCANS]) (DECIDE [LAMBDA (GHOST) (* rrb " 3-Feb-84 10:55") (* MD "27-JAN-84 11:28" Choose a  direction for this ghost to move in) (PROG (GXINC GYINC WANT CURLOC) [COND [(EQ (GETPROP GHOST 'EATEN) 0) (SETQ GXINC (ISIGN 1 (ITIMES (IDIFFERENCE (GETPROP PMAN 'XLOC) (GETPROP GHOST 'XLOC)) FOLLOW))) (SETQ GYINC (ISIGN 1 (ITIMES (IDIFFERENCE (GETPROP PMAN 'YLOC) (GETPROP GHOST 'YLOC)) FOLLOW] (T [SETQ GXINC (ISIGN 1 (IDIFFERENCE 13 (GETPROP GHOST 'XLOC] (SETQ GYINC (ISIGN 1 (IDIFFERENCE 12 (GETPROP GHOST 'YLOC] (* GXINC & GYINC point towards the  desired goal (either the Pacman or  home)) (SETQ WANT 0) (SETQ CURLOC (PLAYERBOARDVAL GHOST)) (* The direction you WANT to move in  is (possibly) constrained by your  CURrent LOCaction) [COND ((AND (EQ GXINC 1) (EQ GYINC 1)) (SETQ WANT (LOGAND 5 CURLOC] [COND ((AND (EQ GXINC 1) (EQ GYINC -1)) (SETQ WANT (LOGAND 6 CURLOC] [COND ((AND (EQ GXINC -1) (EQ GYINC 1)) (SETQ WANT (LOGAND 9 CURLOC] [COND ((AND (EQ GXINC -1) (EQ GYINC -1)) (SETQ WANT (LOGAND 10 CURLOC] (* WANT is further constrained to  prohibit backing up  (to avoid getting stuck in local  minima)) [SETQ WANT (LOGAND WANT (GETPROP GHOST 'CAN] [COND ((EQ WANT 0) (* Too much constraint! Try and make  the best of it.) (SETQ WANT (LOGAND CURLOC (GETPROP GHOST 'CAN] (RETURN (ASSIGNDIR (GETPROP GHOST 'NUMBER) WANT]) (DOTCHECK [LAMBDA (PMAN) (* MD "26-Mar-84 13:10") (* Gives Pacman points if now on a dot.  Invokes next board when all dots gone.) (PROG [(X (GETPROP PMAN 'XLOC)) (Y (GETPROP PMAN 'YLOC] (COND ((CHECKAT X Y 16) (SETBOARDVAL X Y (IDIFFERENCE (BOARDVAL X Y) 16)) (SHOW (add SCORE 1)) (add NUMDOTS -1) (COND ((EQ NUMDOTS 0) (PACMANREINIT]) (DRAWBOARD [LAMBDA NIL (* MD "16-AUG-83 11:44") (PROG (X1 Y1 X2 Y2) (DSPRESET PSTREAM) (SETQ X1 0) (while (NEQ (SETQ X1 (READ)) 99) do (SETQ Y1 (READ)) (SETQ X2 (READ)) (SETQ Y2 (READ)) [SETQ BOARDLIST (APPEND BOARDLIST (LIST (LIST X1 Y1 X2 Y2] (COND ((AND (EQ X1 X2) (ILESSP Y1 Y2)) (DRAWLINE (ITIMES X1 11) (IPLUS (ITIMES 11 (IDIFFERENCE 30 Y1)) 2) (ITIMES 11 X2) (ITIMES 11 (IDIFFERENCE 30 Y2)) 4 'PAINT PSTREAM)) (T (DRAWLINE (ITIMES X1 11) (ITIMES 11 (IDIFFERENCE 30 Y1)) (ITIMES 11 X2) (ITIMES 11 (IDIFFERENCE 30 Y2)) 4 'PAINT PSTREAM]) (DRAWBOARDNEW [LAMBDA NIL (* MD " 8-NOV-83 16:12") (PROG (X1 Y1 X2 Y2) (DSPRESET PSTREAM) (for XYPAIR in BOARDLIST do (SETQ X1 (CAR XYPAIR)) (SETQ Y1 (CADR XYPAIR)) (SETQ X2 (CADDR XYPAIR)) (SETQ Y2 (CADDDR XYPAIR)) (COND ((AND (EQ X1 X2) (ILESSP Y1 Y2)) (DRAWLINE (ITIMES X1 11) (IPLUS (ITIMES 11 (IDIFFERENCE 30 Y1)) 2) (ITIMES 11 X2) (ITIMES 11 (IDIFFERENCE 30 Y2)) 4 'PAINT PSTREAM 1)) (T (DRAWLINE (ITIMES X1 11) (ITIMES 11 (IDIFFERENCE 30 Y1)) (ITIMES 11 X2) (ITIMES 11 (IDIFFERENCE 30 Y2)) 4 'PAINT PSTREAM 1]) (ENERGIZERCHECK [LAMBDA (PMAN) (* MD "22-JUL-83 10:56") (PROG (X Y) (SETQ X (GETPROP PMAN 'XLOC)) (SETQ Y (GETPROP PMAN 'YLOC)) (COND ((CHECKAT X Y 32) (SETBOARDVAL X Y (IDIFFERENCE (BOARDVAL X Y) 32)) (MOVETO 130 350 PSTREAM) (PRIN1 (SETQ SCORE (IPLUS SCORE 5)) PSTREAM) (PRIN1 0 PSTREAM) (SETQ GVALUE 20) (SETQ FOLLOW -1) (SETQ BLUETIME 0]) (ERASEOBJ [LAMBDA (OBJ X Y W H STREAM) (* KW "18-MAY-83 14:52") (BITBLT (GETPROP OBJ 'BITMAP) NIL NIL STREAM X Y W H NIL 'ERASE NIL NIL]) (FRUITCHECK [LAMBDA NIL (* MD "30-AUG-83 14:23") (SETQ FRUITTIME (ADD1 FRUITTIME)) (COND ((EQ FRUITTIME 60) (PUTPROP (CAR (NTH FRUITLIST FRUIT#)) 'OPERATION 'PAINT) (PAINTOBJ (CAR (NTH FRUITLIST FRUIT#)) (IDIFFERENCE (ITIMES 13 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 17) 11) 6) 16 16 PSTREAM)) ((IGREATERP FRUITTIME 120) (ERASEOBJ (CAR (NTH FRUITLIST FRUIT#)) (IDIFFERENCE (ITIMES 13 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 17) 11) 6) 16 16 PSTREAM)) ((IGREATERP FRUITTIME 60) (COND ((CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) 16384) [SETQ SCORE (IPLUS SCORE (GETPROP (CAR (NTH FRUITLIST FRUIT#)) 'VALUE] (SHOW SCORE) (SETQ FRUITVISIBLE NIL) (ERASEOBJ (CAR (NTH FRUITLIST FRUIT#)) (IDIFFERENCE (ITIMES 13 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 17) 11) 6) 16 16 PSTREAM) (PAINTOBJ (CAR (NTH FRUITLIST FRUIT#)) (IPLUS 160 (ITIMES FRUIT# 20)) 350 16 16 PSTREAM]) (FRUITINIT [LAMBDA NIL (* MD "10-NOV-83 13:18") (SETQ FRUIT# 0) (SETQ FRUITLIST '(CHERRY STRAWBERRY ORANGE ORANGE APPLE APPLE PINEAPPLE PINEAPPLE BIRD BIRD BELL BELL KEY)) (PUTPROP 'CHERRY 'BITMAP (COND (PACMANINCOLOR COLORCHERRYBITMAP) (T CHERRYBITMAP))) (PUTPROP 'CHERRY 'VALUE 10) (PUTPROP 'STRAWBERRY 'BITMAP (COND (PACMANINCOLOR COLORSTRAWBERRYBITMAP) (T STRAWBERRYBITMAP))) (PUTPROP 'STRAWBERRY 'VALUE 30) (PUTPROP 'ORANGE 'BITMAP (COND (PACMANINCOLOR COLORORANGEBITMAP) (T ORANGEBITMAP))) (PUTPROP 'ORANGE 'VALUE 50) (PUTPROP 'APPLE 'BITMAP (COND (PACMANINCOLOR COLORAPPLEBITMAP) (T APPLEBITMAP))) (PUTPROP 'APPLE 'VALUE 70) (PUTPROP 'PINEAPPLE 'BITMAP (COND (PACMANINCOLOR COLORPINEAPPLEBITMAP) (T PINEAPPLEBITMAP))) (PUTPROP 'PINEAPPLE 'VALUE 100) (PUTPROP 'BIRD 'BITMAP (COND (PACMANINCOLOR COLORBIRDBITMAP) (T BIRDBITMAP))) (PUTPROP 'BIRD 'VALUE 200) (PUTPROP 'BELL 'BITMAP (COND (PACMANINCOLOR COLORBELLBITMAP) (T BELLBITMAP))) (PUTPROP 'BELL 'VALUE 300) (PUTPROP 'KEY 'BITMAP (COND (PACMANINCOLOR COLORKEYBITMAP) (T KEYBITMAP))) (PUTPROP 'KEY 'VALUE 500]) (GETHISCORES [LAMBDA NIL (* rrb " 3-Feb-84 14:36") (CLEARW PWINDOW) (SHOWCAP "Read high scores?" 70 200) (* move cursor to near question.) (CURSORPOSITION (create POSITION XCOORD _ (IPLUS (DSPXPOSITION NIL PWINDOW) 20) YCOORD _ (IDIFFERENCE (DSPYPOSITION NIL PWINDOW) 50)) PWINDOW) (COND ((EQ [MENU (create MENU ITEMS _ '((Yes 'Y) (No 'N] 'Y) (SETQ NETP T) (INFILE '{ICE}PSYSICE 'READ) (SETQ HILIST (READ)) (SHOWHISCORES) (CLOSEF '{ICE}PSYSICE) (SHOWCAP "Click LEFT or FIRE (joystick) when ready." 6 20) (until (OR (UNTILMOUSESTATE (OR LEFT MIDDLE) 10) (KEYDOWNP 'PAD1)) do)) (T (SETQ NETP NIL]) (GETMONEY [LAMBDA NIL (* MD "15-Mar-85 16:05") (PROG (PMHADENOUGH) (SHOWCAP "INSERT QUARTER TO START GAME" 50 20) (SHOWCAP "(Click anywhere else to quit)" 50 6) (PUTPROP INTROOBJ 'BITMAP (COND (PACMANINCOLOR COLORQUARTERBITMAP) (T QUARTERBITMAP))) (PAINTOBJ INTROOBJ 150 40 64 32 PSTREAM) (GETMOUSESTATE) (until [OR (SETQ PMWANTMORE (KEYDOWNP 'PAD1)) (SETQ PMWANTMORE (COND ((AND (EQ PMANINPUTMODE 'VOICE) (EQ (VOICEINPUT) 0)) T) (T NIL))) [SETQ PMWANTMORE (AND (MOUSESTATE (OR LEFT MIDDLE)) (INSIDEP '(150 40 32 32) (LASTMOUSEX PSTREAM) (LASTMOUSEY PSTREAM] (SETQ PMHADENOUGH (AND (MOUSESTATE (OR LEFT MIDDLE)) (NOT (INSIDEP '(150 40 32 32) (LASTMOUSEX PSTREAM) (LASTMOUSEY PSTREAM] do ( GETMOUSESTATE )) (COND (PMHADENOUGH (SETQ PMWANTMORE NIL]) (GETMOVE [LAMBDA (MOVE) (* MJD "11-Dec-85 14:05") (PROG (CHAR OLDX OLDY (XINC 0) (YINC 0)) (CONTROL T) (SETQ CHAR (OR (AND (EQ PMANINPUTMODE 'VOICE) (VOICEINPUT)) (JOYSTICK))) [COND ((AND (NOT CHAR) (NOT (READP T))) (SETQ OLDX LASTMOUSEX) (SETQ OLDY LASTMOUSEY) (GETMOUSESTATE) (if (EQ (MACHINETYPE) 'DORADO) then (DISMISS 3)) (* This is needed to give LMX & LMY  time to change values.) (SETQ XINC (IDIFFERENCE LASTMOUSEX OLDX)) (SETQ YINC (IDIFFERENCE LASTMOUSEY OLDY)) (COND ((ILESSP OLDX 32) (ADJUSTCURSORPOSITION 64 0))) (* Keep cursor from bumping into  edge of screen.) (COND ((ILESSP OLDY 32) (ADJUSTCURSORPOSITION 0 64))) (COND ((IGREATERP OLDX (COND (PACMANINCOLOR 620) (T 1000))) (ADJUSTCURSORPOSITION -64 0))) (COND ((IGREATERP OLDY (COND (PACMANINCOLOR 460) (T 780))) (ADJUSTCURSORPOSITION 0 -64] [COND ((AND (NOT CHAR) (NOT (READP T)) (NOT ATTRACTMODE) (ILESSP (ABS XINC) 6) (ILESSP (ABS YINC) 6)) (COND ((AND (NEQ NEXTMOVE 0) (CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) NEXTMOVE)) (RETURN NEXTMOVE)) ((CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) MOVE) (RETURN MOVE)) (T (RETURN 0] [SETQ DIR (COND (CHAR CHAR) [(READP T) (RESETFORM (ECHOMODE NIL) (SETQ CHAR (READC)) (COND ((EQ CHAR 'L) 4) ((EQ CHAR 'J) 8) ((EQ CHAR 'I) 2) ((EQ CHAR '% ) 1) (T MOVE] [ATTRACTMODE (CAR (NTH '(1 2 4 8) (RAND 1 4] (T (COND ((AND (IGREATERP XINC 0) (IGREATERP (ABS XINC) (ABS YINC))) 4) ((AND (ILESSP XINC 0) (IGREATERP (ABS XINC) (ABS YINC))) 8) ((AND (IGREATERP YINC 0) (IGEQ (ABS YINC) (ABS XINC))) 2) ((AND (ILESSP YINC 0) (IGEQ (ABS YINC) (ABS XINC))) 1] (COND ((CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) DIR) (SETQ NEXTMOVE DIR) (RETURN DIR)) (T (SETQ NEXTMOVE DIR) (COND ((CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) MOVE) (RETURN MOVE)) (T (RETURN 0]) (VOICEINPUT [LAMBDA NIL (* MD "15-Mar-85 13:15") (NUMBERP (CHARACTER (OR (RS232READBYTE) 0]) (XLOCTOSCREEN [LAMBDA (XLOC) (* rrb " 3-Feb-84 12:20") (* converts from a pacman board  square to a screen coordinate.) (IDIFFERENCE (ITIMES XLOC 11) 6]) (XSCREENTOLOC [LAMBDA (XLOC) (* rrb " 3-Feb-84 12:29") (* converts from a screen coordinate  to a pacman board square) (IQUOTIENT (IPLUS XLOC 6) 11]) (YLOCTOSCREEN [LAMBDA (YLOC) (* rrb " 3-Feb-84 12:31") (* converts from a y location to  window coordinates.) (IPLUS (IQUOTIENT (IPLUS 6 YLOC) 11) 30]) (YSCREENTOLOC [LAMBDA (YLOC) (* rrb " 3-Feb-84 12:41") (* converts from a screen coordinate  to a pacman board square) (IDIFFERENCE 30 (IQUOTIENT (IPLUS YLOC 6) 11]) (HISCORE [LAMBDA NIL (* MD "29-AUG-83 17:11") (PROG (Y) (CLEARW PWINDOW) (SHOWCAP "Read high scores?" 70 200) (COND ((EQ (READ) 'Y) (SHOWCAP "Y" 200 200) (SETPASSWORD '{ICE} 'PSYS "PRTZKRK" 'SYSIFS) (INFILE '{ICE}PSYSICE 'READ) (SETQ HINAMES (READ)) (SETQ HIVALUES (READ)) (CLEARW PWINDOW) (SHOWCAP "High scores" 100 330) (SETQ Y 300) (for I in HINAMES as J in HIVALUES do (SHOWCAP I 50 Y) (SHOWCAP J 200 Y) (SETQ Y (IDIFFERENCE Y 16))) (CLOSEF '{ICE}PSYSICE]) (INCOLORQ [LAMBDA NIL (* ; "Edited 3-Feb-89 15:07 by FS") (SELECTQ (MACHINETYPE) ((DOLPHIN DORADO MAIKO) (COND [(HASCOLORDISPLAYP) (printout T "In color?" T) (MENU (create MENU ITEMS _ '((Yes T "Will play Pacman in color. - Only if you have a color display." ) (No 'NIL "Plays Pacman on the standard display.")) TITLE _ 'Color?] (T NIL))) ((DANDELION DOVE) NIL) (LET NIL (PRINTOUT T "Unknown machine type.") NIL]) (INPUTMODEQ [LAMBDA NIL (* MJD "11-Dec-85 14:08") (* returns the mode of input after  querying the user.) (printout T T "You can input your moves using the " "MOUSE (by having " "PMAN move " "in the same direction " "as the cursor moved), " "KEYBOARD (I is up, " "J is left, " "L is right, " "space is down) " "or " "JOYSTICK (if you have one on your machine), " "or voice control (if you have the voice board).") (PRINTOUT T "You can change modes any time even during a game." T) (OR (MENU (create MENU ITEMS _ '((Cursor 'SAMEDIRASCURSOR "PMAN will move in the same direction as the cursor just moved." ) (Keyboard 'KEYS "PMAN is controlled by I, J, L and spacebar.") (Joystick 'JOYSTICK "PMAN is controlled by the Joystick.") (Voice 'VOICE "Pacman is controlled by voice control ('up', 'down', 'left', 'right'" )) CENTERFLG _ T TITLE _ "Choose mode")) 'SAMEDIRASCURSOR]) (HASCOLORDISPLAYP [LAMBDA NIL (* ; "Edited 3-Feb-89 15:05 by FS") (* does this machine have a color  display. Returns MAYBE if is can't  tell.) (SELECTQ (MACHINETYPE) (DOLPHIN (EQ (LRSH (\DEVICE.INPUT 80) 8) 175)) (DORADO 'MAYBE) (MAIKO 'MAYBE) NIL]) (INTERMISSION1 [LAMBDA NIL (* MD "29-NOV-83 15:58") (PROG (BIGOBJ OLDBIGOBJ) (PUTPROP G1 'BITMAP G1BITMAP) (CLEARW PWINDOW) [for X from 350 to -45 by -1 do (COND ((EQ (IREMAINDER (IQUOTIENT X 10) 2) 0) (PUTPROP PMAN 'BITMAP PMANLEFT)) (T (PUTPROP PMAN 'BITMAP PACMANC))) (MOVEOBJ PMAN OLDPMAN X 200 (SUB1 X) 200 16 16 PSTREAM) (MOVEOBJ G1 G1 (IPLUS X 30) 200 (IPLUS X 29) 200 16 16 PSTREAM) (PUTPROP OLDPMAN 'BITMAP (GETPROP PMAN 'BITMAP] (SETQ BIGOBJ 'BIGP) (SETQ OLDBIGOBJ 'OLDBIGP) [for X from -45 to 350 by 2 do [COND [(EQ (IREMAINDER (IQUOTIENT X 10) 2) 0) (PUTPROP BIGOBJ 'BITMAP (COND (PACMANINCOLOR COLORBIGPMANR) (T BIGPMANR] (T (PUTPROP BIGOBJ 'BITMAP (COND (PACMANINCOLOR COLORBIGPMANC) (T BIGPMANC] (MOVEOBJ BIGOBJ OLDBIGOBJ X 200 (IPLUS X 2) 200 64 64 PSTREAM) (MOVEOBJ G1 G1 (IPLUS X 75) 200 (IPLUS X 77) 200 16 16 PSTREAM) (PUTPROP OLDBIGOBJ 'BITMAP (GETPROP BIGOBJ 'BITMAP] (DISMISS 2000]) (ISIGN [LAMBDA (VALUE SIGN) (* MD " 4-JAN-84 16:55") (COND ((IGREATERP SIGN 0) VALUE) ((ILESSP SIGN 0) (ITIMES (IABS VALUE) -1)) (T (* If sign is 0 then make + or -  randomly) (ITIMES (IABS VALUE) (CAR (NTH '(-1 1) (RAND 1 2]) (JOYSTICK [LAMBDA NIL (* MD "28-NOV-83 12:13") (* Pinouts%: (Atari D0) (Fire PAD1) (E PAD2)  (W PAD3) (S PAD4) (N PAD5) Atari connector%: Top row  (view from outside) 0 E W S N; bottom row%: 0 GND 0 Fire ;  D0 connector%: middle row%: 0 0 Fire E W S N;  bottom row GND 0 0 0 0 0) (COND ((KEYDOWNP 'PAD2) 4) ((KEYDOWNP 'PAD3) 8) ((KEYDOWNP 'PAD4) 1) ((KEYDOWNP 'PAD5) 2]) (LOSE [LAMBDA NIL (* MD " 8-DEC-83 12:50") (SETQ NUMMEN (SUB1 NUMMEN)) (PUTPROP PMAN 'BITMAP PACMANC) (ERASEOBJ PMAN (IDIFFERENCE (ITIMES (GETPROP PMAN 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP PMAN 'YLOC)) 11) 6) 16 16 PSTREAM) (COND ((EQ NUMMEN 2) (ERASEOBJ PMAN 40 345 16 16 PSTREAM)) ((EQ NUMMEN 1) (ERASEOBJ PMAN 20 345 16 16 PSTREAM)) ((EQ NUMMEN 0) (SHOWCAP "GAME OVER" (ITIMES 11 11) (ITIMES (IDIFFERENCE 30 17) 11)) (COND ([AND NETP (IGREATERP (ITIMES SCORE 10) (CAAR (LAST HILIST] (DISMISS 2000) (NEWHISCORES))) (CLEARBUF T T) (CONTROL NIL) (SETQ PMGAMEOVER T))) (PUTPROP PMAN 'XLOC 13) (PUTPROP PMAN 'YLOC 23) (SETQ MOVE 8]) (MOVEDOWN [LAMBDA (OBJ OLDOBJ) (* MD " 6-JAN-83 16:22") (MOVEOBJ OBJ OLDOBJ (IDIFFERENCE (ITIMES (GETPROP OLDOBJ 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDOBJ 'YLOC)) 11) 6) (IDIFFERENCE (ITIMES (GETPROP OBJ 'XLOC) 11) 6) (IDIFFERENCE (ITIMES [IDIFFERENCE 30 (PUTPROP OBJ 'YLOC (ADD1 (GETPROP OBJ 'YLOC] 11) 6) 16 16 PSTREAM]) (MOVEGHOST [LAMBDA (GHOST OLDGHOST) (* rrb " 3-Feb-84 11:03") (COND ((AND (EQ CYCLE 2) (CHECKAT (GETPROP GHOST 'XLOC) (GETPROP GHOST 'YLOC) 4096)) (* Slow spot) T) [(IGREATERP (GETPROP GHOST 'GIT) 0) (* In tunnel) (add (GETPROP GHOST 'GIT) 1) (COND ((IGREATERP (GETPROP GHOST 'GIT) 4) (PUTPROP GHOST 'GIT 0] (T [COND ((EQ (GETPROP GHOST 'EATEN) 0) (SETPLAYERBOARDVAL GHOST (IDIFFERENCE (PLAYERBOARDVAL GHOST) (GETPROP GHOST 'BIT] [COND ((EQ (GETPROP GHOST 'EATEN) 0) (COND [(IGREATERP BLUETIME 30) (* Blink all uneaten ghosts) (COND ((EQ CYCLE 1) (PUTPROP GHOST 'BITMAP GINVBITMAP)) (T (PUTPROP GHOST 'BITMAP (EVAL (CAR (NTH '(G1BITMAP G2BITMAP G3BITMAP G4BITMAP) (GETPROP GHOST 'NUMBER] ((IGREATERP BLUETIME 0) (PUTPROP GHOST 'BITMAP GINVBITMAP] (SELECTQ (DECIDE GHOST) (1 (MOVEUP GHOST OLDGHOST) (PUTPROP GHOST 'CAN 14)) (2 (COND ((CHECKAT (GETPROP GHOST 'XLOC) (GETPROP GHOST 'YLOC) 64) (ERASEOBJ OLDGHOST (IDIFFERENCE (ITIMES (GETPROP OLDGHOST 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDGHOST 'YLOC)) 11) 6) 16 16 PSTREAM) (PUTPROP GHOST 'XLOC 26) (PUTPROP GHOST 'GIT 1)) (T (MOVELEFT GHOST OLDGHOST))) (PUTPROP GHOST 'CAN 11)) (3 (COND ((CHECKAT (GETPROP GHOST 'XLOC) (GETPROP GHOST 'YLOC) 128) (ERASEOBJ OLDGHOST (IDIFFERENCE (ITIMES (GETPROP OLDGHOST 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDGHOST 'YLOC)) 11) 6) 16 16 PSTREAM) (PUTPROP GHOST 'XLOC 1) (PUTPROP GHOST 'GIT 1)) (T (MOVERIGHT GHOST OLDGHOST))) (PUTPROP GHOST 'CAN 7)) (4 (MOVEDOWN GHOST OLDGHOST) (PUTPROP GHOST 'CAN 13)) T) (REDODOT (GETPROP OLDGHOST 'XLOC) (GETPROP OLDGHOST 'YLOC)) (PUTPROP OLDGHOST 'XLOC (GETPROP GHOST 'XLOC)) (PUTPROP OLDGHOST 'YLOC (GETPROP GHOST 'YLOC)) (COND [(IGREATERP BLUETIME 30) (PUTPROP OLDGHOST 'BITMAP (GETPROP GHOST 'BITMAP] ((AND (EQ (GETPROP GHOST 'EATEN) 0) (IGREATERP BLUETIME 0)) (PUTPROP OLDGHOST 'BITMAP GINVBITMAP))) [COND ((AND (EQ (GETPROP GHOST 'EATEN) 1) (EQ (GETPROP GHOST 'YLOC) 12) (EQ (GETPROP GHOST 'XLOC) 13)) (PUTPROP GHOST 'EATEN 0) [PUTPROP GHOST 'BITMAP (EVAL (CAR (NTH '(G1BITMAP G2BITMAP G3BITMAP G4BITMAP) (GETPROP GHOST 'NUMBER] (PUTPROP OLDGHOST 'BITMAP (GETPROP GHOST 'BITMAP] (COND ((EQ (GETPROP GHOST 'EATEN) 0) (SETBOARDVAL (GETPROP GHOST 'XLOC) (GETPROP GHOST 'YLOC) (IPLUS (BOARDVAL (GETPROP GHOST 'XLOC) (GETPROP GHOST 'YLOC)) (GETPROP GHOST 'BIT]) (MOVELEFT [LAMBDA (OBJ OLDOBJ) (* rrb "31-Jan-84 10:15") (MOVEOBJ OBJ OLDOBJ (IDIFFERENCE (ITIMES (GETPROP OLDOBJ 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDOBJ 'YLOC)) 11) 6) (IDIFFERENCE (ITIMES [PUTPROP OBJ 'XLOC (SUB1 (GETPROP OBJ 'XLOC] 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OBJ 'YLOC)) 11) 6) 16 16 PSTREAM]) (MOVEOBJ [LAMBDA (OBJ OLDOBJ X1 Y1 X2 Y2 W H STREAM) (* MD " 3-JAN-83 14:51") (ERASEOBJ OLDOBJ X1 Y1 W H STREAM) (PAINTOBJ OBJ X2 Y2 W H STREAM]) (MOVEPACMAN [LAMBDA (PMAN DIR) (* ; "Edited 3-Feb-89 13:09 by FS") (SELECTQ DIR (1 (PUTPROP PMAN 'BITMAP (COND ((EQ CYCLE 1) PMANDOWN) (T PACMANC))) (MOVEDOWN PMAN OLDPMAN)) (2 (PUTPROP PMAN 'BITMAP (COND ((EQ CYCLE 1) PMANUP) (T PACMANC))) (MOVEUP PMAN OLDPMAN)) (4 (PUTPROP PMAN 'BITMAP (COND ((EQ CYCLE 1) PMANRIGHT) (T PACMANC))) (COND ((CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) 128) (ERASEOBJ OLDPMAN (IDIFFERENCE (ITIMES (GETPROP OLDPMAN 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDPMAN 'YLOC)) 11) 6) 16 16 PSTREAM) (PUTPROP PMAN 'XLOC 1) (SETQ PIT 1)) (T (MOVERIGHT PMAN OLDPMAN)))) (8 (PUTPROP PMAN 'BITMAP (COND ((EQ CYCLE 1) PMANLEFT) (T PACMANC))) (COND ((CHECKAT (GETPROP PMAN 'XLOC) (GETPROP PMAN 'YLOC) 64) (ERASEOBJ OLDPMAN (IDIFFERENCE (ITIMES (GETPROP OLDPMAN 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDPMAN 'YLOC)) 11) 6) 16 16 PSTREAM) (PUTPROP PMAN 'XLOC 26) (SETQ PIT 1)) (T (MOVELEFT PMAN OLDPMAN)))) NIL) (PUTPROP OLDPMAN 'BITMAP (GETPROP PMAN 'BITMAP)) (PUTPROP OLDPMAN 'XLOC (GETPROP PMAN 'XLOC)) (PUTPROP OLDPMAN 'YLOC (GETPROP PMAN 'YLOC]) (MOVERIGHT [LAMBDA (OBJ OLDOBJ) (* MD " 6-JAN-83 16:21") (MOVEOBJ OBJ OLDOBJ (IDIFFERENCE (ITIMES (GETPROP OLDOBJ 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDOBJ 'YLOC)) 11) 6) (IDIFFERENCE (ITIMES [PUTPROP OBJ 'XLOC (ADD1 (GETPROP OBJ 'XLOC] 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OBJ 'YLOC)) 11) 6) 16 16 PSTREAM]) (MOVEUP [LAMBDA (OBJ OLDOBJ) (* MD " 6-JAN-83 16:21") (MOVEOBJ OBJ OLDOBJ (IDIFFERENCE (ITIMES (GETPROP OLDOBJ 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP OLDOBJ 'YLOC)) 11) 6) (IDIFFERENCE (ITIMES (GETPROP OBJ 'XLOC) 11) 6) (IDIFFERENCE (ITIMES [IDIFFERENCE 30 (PUTPROP OBJ 'YLOC (SUB1 (GETPROP OBJ 'YLOC] 11) 6) 16 16 PSTREAM]) (NEWHISCORES [LAMBDA NIL (* MD "30-AUG-83 14:09") (CLEARW PWINDOW) (SHOWCAP "What is your name?" 70 200) (SETSYNTAX '% 'OTHER) (SETQ NAME (RSTRING)) (SETSYNTAX '% 'SEPRCHAR) (SETPASSWORD '{ICE} 'PSYS "PRTZKRK" 'SYSIFS) (INFILE '{ICE}PSYSICE) [SETQ HILIST (REVERSE (CDR (SORT (APPEND (READ) (LIST (LIST (ITIMES SCORE 10) NAME))) T] (SHOWHISCORES) (CLOSEF '{ICE}PSYSICE) (OUTFILE '{ICE}PSYSICE.;2) (PRINT HILIST) (CLOSEF '{ICE}PSYSICE.;2]) (PACINTRO [LAMBDA NIL (* rrb "31-Jan-84 11:00") (PROG (CHAR CHARNAME X Y) (CLEARW PWINDOW) (PUTPROP INTROOBJ 'BITMAP (COND (PACMANINCOLOR COLORSIGLOGO) (T SIGLOGO))) (PUTPROP INTROOBJ 'OPERATION 'PAINT) (PAINTOBJ INTROOBJ 110 330 64 32 PSTREAM) (DISMISS 400) (SHOWCAP "by Michel Denber" 150 300) (DISMISS 400) (SHOWCAP "CHARACTER / NICKNAME" 80 250) (SETQ Y 200) (for CHAR in [COND (PACMANINCOLOR '(COLORG1BITMAP COLORG2BITMAP COLORG3BITMAP COLORG4BITMAP)) (T '(G1BITMAP G2BITMAP G3BITMAP G4BITMAP] as CHARNAME in '("SHADOW 'BLINKY'" "SPEEDY 'PINKY'" "BASHFUL 'INKY'" "POKEY 'CLYDE'" ) do (PUTPROP INTROOBJ 'BITMAP (EVAL CHAR)) [for X from 360 to 50 by -1 do (MOVEOBJ INTROOBJ INTROOBJ X Y (SUB1 X) Y 16 16 PSTREAM) (GETMOUSESTATE) (COND ((MOUSESTATE LEFT) (RETURN NIL] (COND ((MOUSESTATE LEFT) (RETURN NIL))) (SHOWCAP CHARNAME 90 (IPLUS Y 5)) (DISMISS 100) (SETQ Y (IDIFFERENCE Y 30))) (COND ((MOUSESTATE LEFT) (RETURN NIL))) (GETMONEY]) (PACMAN [LAMBDA NIL (* MJD "11-Dec-85 13:20") (DECLARE (GLOBALVARS PACMANWAITTIME)) (PROG ((PMAN 'X) (INTROOBJ 'TEMP) (MOVE 8)) (* Bit assignments%: (15 32768 Unused) (14 16384 fruit-loc)  (13 8192 starts-w/dot) (12 4096 slow-area)  (11 2048 G4) (10 1024 G3) (9 512 G2) (8 256 G1)  (7 128 R-tunnel-exit) (6 64 L-tunnel-exit)  (5 32 has-energizer) (4 16 still-has-dot)  (3 8 W) (2 4 E) (1 2 N) (0 1 S)) (SETQ OLDPMAN 'Y) (SETQ G1 'A) (SETQ G2 'B) (SETQ G3 'C) (SETQ G4 'D) (SETQ OLDG1 'E) (SETQ OLDG2 'F) (SETQ OLDG3 'G) (SETQ OLDG4 'H) (SETQ PMWANTMORE T) (SETQ PMGAMEOVER NIL) (PACMANINITNEW PMAN) (PACINTRO) (while PMWANTMORE do (PACMANNEWGAME) (until PMGAMEOVER do (for CYCLE from 1 to 3 do (DISMISS PACMANWAITTIME) [COND [(IGREATERP PIT 0) (add PIT 1) (COND ((IGREATERP PIT 4) (SETQ PIT 0] (T (MOVEPACMAN PMAN (SETQ MOVE (GETMOVE MOVE] (BLINKENERGIZERS) (DOTCHECK PMAN) (FRUITCHECK) (COND ((EQ FOLLOW -1) (add BLUETIME 1))) [COND ((IGREATERP BLUETIME 60) (SETQ FOLLOW 1) (SETQ BLUETIME 0) [COND ((NEQ (CAR GVALUEPOS) 0) (* Erase any remaining point value) (* Caution -  a kludge%:) (ERASEOBJ (CAR (NTH GVALUEBITMAPLIST (IQUOTIENT SAVEGVALUE 20))) (CAR GVALUEPOS) (CDR GVALUEPOS) 16 16 PSTREAM) (SETQ GVALUEPOS '(280 . 291] (for GHOST in '(G1 G2 G3 G4) as GBITMAP in '(G1BITMAP G2BITMAP G3BITMAP G4BITMAP) when (EQ (GETPROP (EVAL GHOST) 'EATEN) 0) do (PUTPROP (EVAL GHOST) 'BITMAP (EVAL GBITMAP))) (for OLDGHOST in '(OLDG1 OLDG2 OLDG3 OLDG4) as GHOST in '(G1 G2 G3 G4) do (PUTPROP (EVAL OLDGHOST) 'BITMAP (GETPROP (EVAL GHOST) 'BITMAP] (ENERGIZERCHECK PMAN) (COLLISIONCHECK PMAN) (COND ((EQ (MACHINETYPE) 'DORADO) (DISMISS 3))) [COND [(EQ CYCLE 3) (COND ((EQ FOLLOW 1) (for GHOST in '(G1 G2 G3 G4) as OLDGHOST in '(OLDG1 OLDG2 OLDG3 OLDG4) do (MOVEGHOST (EVAL GHOST) (EVAL OLDGHOST] (T (for GHOST in '(G1 G2 G3 G4) as OLDGHOST in '(OLDG1 OLDG2 OLDG3 OLDG4) do (MOVEGHOST (EVAL GHOST) (EVAL OLDGHOST] (COLLISIONCHECK PMAN))) (SETQ PMGAMEOVER NIL) (DISMISS 2000) (CLEARW PWINDOW) (GETMONEY)) (COND (PACMANINCOLOR (CHANGECURSORSCREEN (SCREENBITMAP)) (SCREENCOLORMAP PMOLDCOLORMAP) (SETDISPLAYHEIGHT T]) (PACMANINIT [LAMBDA (PMAN) (* MD "18-AUG-83 16:03") [CLEARW (OR PWINDOW (PROG1 (SETQ PWINDOW (CREATEW (create REGION LEFT _ 32 BOTTOM _ 32 WIDTH _ 307 HEIGHT _ 390) "PACMAN" NIL] (SETQ PSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM PWINDOW NIL "PACMAN" NIL)) (CLOSEF? '{DSK}PACMAN.DAT) (INFILE '{DSK}PACMAN.DAT 'READ) (SETQ NUMMEN 3) (SETQ SCORE 0) (SETQ NUMDOTS 0) (DRAWBOARD) (PUTDOTS) (PAINTOBJ PMAN 20 345 16 16 PSTREAM) (PAINTOBJ PMAN 40 345 16 16 PSTREAM) (SETBOARDVAL 13 17 (IPLUS (BOARDVAL 13 17) 16384)) (* Fruit location) (SETBOARDVAL 26 14 (IPLUS (BOARDVAL 26 14) 128 4)) (* Tunnel exits) (SETBOARDVAL 1 14 (IPLUS (BOARDVAL 1 14) 64 8)) (for I from 1 to 5 do (SETBOARDVAL I 14 (IPLUS (BOARDVAL I 14) 4096))) (for I from 22 to 26 do (SETBOARDVAL I 14 (IPLUS (BOARDVAL I 14) 4096))) (* Slow spots) [for X from 13 to 15 do (for Y from 13 to 15 do (SETBOARDVAL X Y (IPLUS (BOARDVAL X Y) 2] (SETBOARDVAL 12 13 (IPLUS (BOARDVAL 12 13) 4 2)) (SETBOARDVAL 15 13 (IPLUS (BOARDVAL 15 13) 8)) (SETQ ENERGIZEROBJ 'I) (SETBOARDVAL 1 3 (IPLUS (BOARDVAL 1 3) 32)) (SETBOARDVAL 26 3 (IPLUS (BOARDVAL 26 3) 32)) (SETBOARDVAL 1 23 (IPLUS (BOARDVAL 1 23) 32)) (SETBOARDVAL 26 23 (IPLUS (BOARDVAL 26 23) 32)) (* Energizers) [SETBOARDVAL 13 11 (IPLUS (BOARDVAL 13 11) (GETPROP G1 'BIT] (* Ghosts) [SETBOARDVAL 13 12 (IPLUS (BOARDVAL 13 12) (GETPROP G2 'BIT] [SETBOARDVAL 12 13 (IPLUS (BOARDVAL 12 13) (GETPROP G3 'BIT] (SETBOARDVAL 15 13 (IPLUS (BOARDVAL 15 13) (GETPROP G4 'BIT]) (PACMANINITNEW [LAMBDA (PMAN) (* ; "Edited 3-Feb-89 15:10 by FS") (printout T (SETQ PACMANVERSION "PACMAN Version 1.5") T) (CURSORPOSITION (create POSITION XCOORD _ (IPLUS (DSPXPOSITION NIL T) 20) YCOORD _ (IDIFFERENCE (DSPYPOSITION NIL T) 75)) T) (SETQ PMANINPUTMODE (INPUTMODEQ)) (if (EQ PMANINPUTMODE 'VOICE) then (LOAD? (PACKFILENAME 'NAME 'RS232.LCOM 'DIRECTORY (CAR DIRECTORIES))) (RS232INIT (MENU (create MENU ITEMS _ '(75 150 300 600 1200 2400 4800 9600) TITLE _ "Baud rate for voice input:")) 8 NIL 1)) (SETQ PACMANWAITTIME (SPEEDQ)) (SETQ PACMANINCOLOR (INCOLORQ)) [CLEARW (OR PWINDOW (SETQ PWINDOW (COND (PACMANINCOLOR (COLORCREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 307 HEIGHT _ 390) PACMANVERSION 1 1)) (T (CREATEW (create REGION LEFT _ 32 BOTTOM _ 32 WIDTH _ 307 HEIGHT _ 390) PACMANVERSION NIL] [SETQ PSTREAM (COND (PACMANINCOLOR (DSPCREATE (COLORSCREENBITMAP))) (T (GETSTREAM PWINDOW] (COND (PACMANINCOLOR (COLORDISPLAY T) (COLORBACKGROUND) (SETQ PMOLDCOLORMAP (SCREENCOLORMAP (COLORMAPCREATE))) (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (SETDISPLAYHEIGHT 0))) (SETQ ENERGIZEROBJ 'I) (SETBITMAPS) (SETCHARPROPS) (GETHISCORES]) (PACMANNEWGAME [LAMBDA NIL (* MD " 7-DEC-83 14:50") (SETQ NUMMEN 3) (SETQ SCORE 0) (SETQ NUMDOTS 0) (DRAWBOARDNEW) (FRUITINIT) (SETQ GVALUEBITMAPLIST '(GHOST1 GHOST2 T GHOST3 T T T GHOST4)) (PAINTOBJ PMAN 20 345 16 16 PSTREAM) (PAINTOBJ PMAN 40 345 16 16 PSTREAM) (PACMANREINIT]) (PACMANREINIT [LAMBDA NIL (* rrb " 3-Feb-84 14:04") [COND ((EQ FRUIT# 2) (INTERMISSION1) (DISMISS 200) (CLEARW PWINDOW) (DRAWBOARDNEW) (PUTPROP PMAN 'BITMAP PMANLEFT) (COND ((IGREATERP NUMMEN 1) (PAINTOBJ PMAN 20 345 16 16 PSTREAM))) (COND ((IGREATERP NUMMEN 2) (PAINTOBJ PMAN 40 345 16 16 PSTREAM] (for I from 1 to FRUIT# do (PAINTOBJ (CAR (NTH FRUITLIST I)) (IPLUS 160 (ITIMES I 20)) 350 16 16 PSTREAM)) (PUTPROP PMAN 'BITMAP PACMANC) (ERASEOBJ PMAN (IDIFFERENCE (ITIMES (GETPROP PMAN 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP PMAN 'YLOC)) 11) 6) 16 16 PSTREAM) [for I from 1 to 29 do (SETA BOARD I (COPY (ELT VIRGINBOARD I] (for GHOST in '(G1 G2 G3 G4) do (ERASEOBJ (EVAL GHOST) (IDIFFERENCE (ITIMES (GETPROP (EVAL GHOST) 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP (EVAL GHOST) 'YLOC)) 11) 6) 16 16 PSTREAM)) (SETCHARPROPS) (for GHOST in '(G1 G2 G3 G4) do (PAINTOBJ (EVAL GHOST) (IDIFFERENCE (ITIMES (GETPROP (EVAL GHOST) 'XLOC) 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 (GETPROP (EVAL GHOST) 'YLOC)) 11) 6) 16 16 PSTREAM)) (SHOWCAP '"READY!" (ITIMES 12 11) (ITIMES (IDIFFERENCE 30 17) 11) PSTREAM) (PUTPROP PMAN 'XLOC 13) (PUTPROP PMAN 'YLOC 23) (SETQ FOLLOW 1) (SETQ BLUETIME 0) (SETQ FRUITTIME 0) (SETQ FRUITVISIBLE T) (* Used by REDODOT) (SETQ FRUIT# (ADD1 FRUIT#)) (SETQ GVALUEPOS '(159 . 269)) (* Used by COLLISIONCHECK) (SETQ MOVE 8) (SETQ PIT 0) (* Pacman in tunnel) (PUTDOTSAGAIN) (PUTENERGIZERS) (DISMISS 2000) (SHOWCAP '" " (ITIMES 12 11) (ITIMES (IDIFFERENCE 30 17) 11) PSTREAM]) (PAINTOBJ [LAMBDA (OBJ X Y W H STREAM) (* MD " 3-JAN-83 14:22") (BITBLT (GETPROP OBJ 'BITMAP) NIL NIL STREAM X Y W H NIL (GETPROP OBJ 'OPERATION) NIL NIL]) (PAINTDOT [LAMBDA (OBJ X Y W H) (* MD "19-NOV-82 10:30") (BITBLT OBJ NIL NIL PSTREAM X Y W H NIL 'PAINT NIL NIL]) (PUTDOTS [LAMBDA NIL (* MD " 8-NOV-83 16:20") (PROG (ROW N E S W) (for Y from 1 to 29 do (SETQ ROW (LIST NIL)) [for X from 1 to 26 do (SETQ ROW (APPEND ROW (LIST (READ] (SETA BOARD Y (DREMOVE NIL ROW))) (for Y from 1 to 29 do (SETQ ROW (ELT BOARD Y)) (for X from 1 to 26 when (NEQ (CAR (NTH ROW X)) 0) do (COND ((EQ (CAR (NTH ROW X)) 1) (PAINTDOT (IF PACMANINCOLOR THEN COLORDOT ELSE DOT) (ITIMES X 11) (ITIMES (IDIFFERENCE 30 Y) 11) 4 4) (SETQ HASDOT 8208) (SETQ NUMDOTS (ADD1 NUMDOTS))) (T (SETQ HASDOT 0))) (SETQ N 0) (SETQ E 0) (SETQ S 0) (SETQ W 0) [COND ((IGREATERP X 1) (SETQ W (IMIN (CAR (NTH ROW (SUB1 X))) 1] [COND ((ILESSP X 26) (SETQ E (IMIN (CAR (NTH ROW (ADD1 X))) 1] [COND ((IGREATERP Y 1) (SETQ N (IMIN (CAR (NTH (ELT BOARD (SUB1 Y)) X)) 1] [COND ((ILESSP Y 29) (SETQ S (IMIN (CAR (NTH (ELT BOARD (ADD1 Y)) X)) 1] (RPLACA (NTH ROW X) (IPLUS HASDOT (ITIMES W 8) (ITIMES E 4) (ITIMES N 2) S))) (SETA BOARD Y ROW]) (PUTDOTSAGAIN [LAMBDA NIL (* MD " 8-NOV-83 16:23") (for Y from 1 to 29 do (for X from 1 to 26 do (COND ((CHECKAT X Y 8192) (PAINTDOT (COND (PACMANINCOLOR COLORDOT) (T DOT)) (ITIMES X 11) (ITIMES (IDIFFERENCE 30 Y) 11) 4 4) (SETQ NUMDOTS (ADD1 NUMDOTS]) (PUTENERGIZERS [LAMBDA NIL (* MD " 7-JAN-83 15:57") (PAINTOBJ ENERGIZEROBJ (ITIMES 1 11) (ITIMES 11 (IDIFFERENCE 30 3)) 8 8 PSTREAM) (PAINTOBJ ENERGIZEROBJ (ITIMES 26 11) (ITIMES 11 (IDIFFERENCE 30 3)) 8 8 PSTREAM) (PAINTOBJ ENERGIZEROBJ (ITIMES 1 11) (ITIMES 11 (IDIFFERENCE 30 23)) 8 8 PSTREAM) (PAINTOBJ ENERGIZEROBJ (ITIMES 26 11) (ITIMES 11 (IDIFFERENCE 30 23)) 8 8 PSTREAM]) (REDODOT [LAMBDA (X Y) (* MD "10-NOV-83 12:46") (COND ((CHECKAT X Y 16) (PAINTDOT (COND (PACMANINCOLOR COLORDOT) (T DOT)) (ITIMES X 11) (ITIMES (IDIFFERENCE 30 Y) 11) 4 4)) ((AND (CHECKAT X Y 16384) (IGREATERP FRUITTIME 60) (ILESSP FRUITTIME 120) FRUITVISIBLE) (PAINTOBJ (CAR (NTH FRUITLIST FRUIT#)) (IDIFFERENCE (ITIMES 13 11) 6) (IDIFFERENCE (ITIMES (IDIFFERENCE 30 17) 11) 6) 16 16 PSTREAM)) (T NIL]) (REPLACEOBJ [LAMBDA (OBJ X Y W H STREAM) (* MD " 8-DEC-82 17:54") (BITBLT OBJ NIL NIL STREAM X Y W H NIL 'REPLACE NIL NIL]) (SCAN [LAMBDA NIL (* MD "17-AUG-83 11:40") (for X from 1 to 26 do (for Y from 1 to 29 do (COND ((CHECKAT X Y 3840) (printout T X %, Y %, (BOARDVAL X Y) T]) (SETBITMAPS [LAMBDA NIL (* MD "10-NOV-83 16:19") (SETQ PMANLEFT (COND (PACMANINCOLOR COLORPMANLEFT) (T PMANLEFTMAP))) (SETQ PMANRIGHT (COND (PACMANINCOLOR COLORPMANRIGHT) (T PMANRIGHTMAP))) (SETQ PMANUP (COND (PACMANINCOLOR COLORPMANUP) (T PMANUPMAP))) (SETQ PMANDOWN (COND (PACMANINCOLOR COLORPMANDOWN) (T PMANDOWNMAP))) (SETQ PACMANC (COND (PACMANINCOLOR COLORPACMANC) (T PACMANCMAP))) (SETQ G1BITMAP (COND (PACMANINCOLOR COLORG1BITMAP) (T BWG1BITMAP))) (SETQ G2BITMAP (COND (PACMANINCOLOR COLORG2BITMAP) (T BWG2BITMAP))) (SETQ G3BITMAP (COND (PACMANINCOLOR COLORG3BITMAP) (T BWG3BITMAP))) (SETQ G4BITMAP (COND (PACMANINCOLOR COLORG4BITMAP) (T BWG4BITMAP))) (SETQ GINVBITMAP (COND (PACMANINCOLOR COLORGINVBITMAP) (T BWGINVBITMAP]) (SETBOARDVAL [LAMBDA (X Y VAL) (* MD "28-NOV-83 16:48") (FRPLACA (FNTH (ELT BOARD Y) X) VAL]) (SETCHARPROPS [LAMBDA NIL (* MD "10-NOV-83 16:53") (PUTPROP PMAN 'BITMAP PMANLEFT) (PUTPROP 'GHOST1 'BITMAP (COND (PACMANINCOLOR COLOR200BITMAP) (T 200BITMAP))) (PUTPROP 'GHOST2 'BITMAP (COND (PACMANINCOLOR COLOR400BITMAP) (T 400BITMAP))) (PUTPROP 'GHOST3 'BITMAP (COND (PACMANINCOLOR COLOR800BITMAP) (T 800BITMAP))) (PUTPROP 'GHOST4 'BITMAP (COND (PACMANINCOLOR COLOR1600BITMAP) (T 1600BITMAP))) (PUTPROP ENERGIZEROBJ 'BITMAP (COND (PACMANINCOLOR COLORENERGIZER) (T ENERGIZER))) (PUTPROP ENERGIZEROBJ 'OPERATION 'INVERT) (* Energizers) (PUTPROP OLDPMAN 'BITMAP PACMANC) (PUTPROP OLDPMAN 'OPERATION 'PAINT) (PUTPROP PMAN 'OPERATION 'PAINT) (PUTPROP PMAN 'XLOC 13) (PUTPROP PMAN 'YLOC 23) (PUTPROP OLDPMAN 'XLOC 13) (PUTPROP OLDPMAN 'YLOC 23) (SETGLOCS) (SETGCANS) (PUTPROP G1 'BITMAP G1BITMAP) (* Ghost 1) (PUTPROP OLDG1 'BITMAP (GETPROP G1 'BITMAP)) (PUTPROP G1 'NUMBER 1) (PUTPROP G1 'BIT 256) (PUTPROP G1 'OPERATION 'INVERT) (PUTPROP G1 'EATEN 0) (PUTPROP G1 'GIT 0) (* Ghost 2) (PUTPROP G2 'BITMAP G2BITMAP) (PUTPROP OLDG2 'BITMAP (GETPROP G2 'BITMAP)) (PUTPROP G2 'BIT 512) (PUTPROP G2 'NUMBER 2) (PUTPROP G2 'OPERATION 'INVERT) (PUTPROP G2 'EATEN 0) (PUTPROP G2 'GIT 0) (* Ghost 3) (PUTPROP G3 'BITMAP G3BITMAP) (PUTPROP OLDG3 'BITMAP (GETPROP G3 'BITMAP)) (PUTPROP G3 'BIT 1024) (PUTPROP G3 'NUMBER 3) (PUTPROP G3 'OPERATION 'INVERT) (PUTPROP G3 'EATEN 0) (PUTPROP G3 'GIT 0) (* Ghost 4) (PUTPROP G4 'BITMAP G4BITMAP) (PUTPROP OLDG4 'BITMAP (GETPROP G4 'BITMAP)) (PUTPROP G4 'BIT 2048) (PUTPROP G4 'NUMBER 4) (PUTPROP G4 'OPERATION 'INVERT) (PUTPROP G4 'EATEN 0) (PUTPROP G4 'GIT 0]) (SETGCANS [LAMBDA NIL (* MD "19-AUG-83 17:25") (PUTPROP G1 'CAN 12) (PUTPROP G2 'CAN 2) (PUTPROP G3 'CAN 4) (PUTPROP G4 'CAN 8]) (SETGLOCS [LAMBDA NIL (* MD "18-AUG-83 14:55") (PUTPROP OLDG1 'INITX 13) (PUTPROP OLDG1 'INITY 11) (PUTPROP OLDG1 'XLOC 13) (PUTPROP OLDG1 'YLOC 11) (PUTPROP G1 'INITX 13) (PUTPROP G1 'INITY 11) (PUTPROP G1 'XLOC 13) (PUTPROP G1 'YLOC 11) (PUTPROP OLDG2 'INITX 13) (PUTPROP OLDG2 'INITY 12) (PUTPROP OLDG2 'XLOC 13) (PUTPROP OLDG2 'YLOC 12) (PUTPROP G2 'INITX 13) (PUTPROP G2 'INITY 12) (PUTPROP G2 'XLOC 13) (PUTPROP G2 'YLOC 12) (PUTPROP OLDG3 'INITX 12) (PUTPROP OLDG3 'INITY 13) (PUTPROP OLDG3 'XLOC 12) (PUTPROP OLDG3 'YLOC 13) (PUTPROP G3 'INITX 12) (PUTPROP G3 'INITY 13) (PUTPROP G3 'XLOC 12) (PUTPROP G3 'YLOC 13) (PUTPROP OLDG4 'INITX 15) (PUTPROP OLDG4 'INITY 13) (PUTPROP OLDG4 'XLOC 15) (PUTPROP OLDG4 'YLOC 13) (PUTPROP G4 'INITX 15) (PUTPROP G4 'INITY 13) (PUTPROP G4 'XLOC 15) (PUTPROP G4 'YLOC 13]) (SETPLAYERBOARDVAL [LAMBDA (PLAYER VAL) (* sets the board representation of  the current location of player.) (SETBOARDVAL (GETPROP PLAYER 'XLOC) (GETPROP PLAYER 'YLOC) VAL]) (SHOW [LAMBDA (VALUE) (* MD "10-JAN-83 15:07") (MOVETO 130 350 PSTREAM) (PRIN1 VALUE PSTREAM) (PRIN1 0 PSTREAM]) (SHOWCAP [LAMBDA (MESSAGE X Y) (* MD "10-NOV-83 12:31") (MOVETO X Y PSTREAM) (PRIN1 MESSAGE PSTREAM]) (SHOWHISCORES [LAMBDA NIL (* MD "30-AUG-83 11:39") (PROG (Y) (CLEARW PWINDOW) (SHOWCAP "High scores" 100 330) (SETQ Y 300) (for I in HILIST do (SHOWCAP (CADR I) 50 Y) (SHOWCAP (CAR I) 200 Y) (SETQ Y (IDIFFERENCE Y 16]) (SPEEDQ [LAMBDA NIL (* rrb " 3-Feb-84 14:55") (* queries about the speed of the  game.) (IMAX 0 (IDIFFERENCE (MENU (create MENU ITEMS _ '((Fast 50 "Expert players") (Medium 100 "Intermediate players") (Slow 200 "Beginning Players") (Snail 400 "First time players")) TITLE _ "How fast?" CENTERFLG _ T)) (SELECTQ (MACHINETYPE) (DOLPHIN 75) (DANDELION 40) 0]) ) (RPAQQ 1600BITMAP #*(16 16)@@@@@@@@@@@@IHLFJEBIJABIJABIKIBIJEBIJEBIJEBIIHLF@@@@@@@@@@@@@@@@) (RPAQQ 200BITMAP #*(16 16)@@@@@@@@@@@@FAHFIBDIABDIABDIBBDIDBDIHBDIHBDIOAHF@@@@@@@@@@@@@@@@) (RPAQQ 400BITMAP #*(16 16)@@@@@@@@@@@@IAHFIBDIIBDIIBDIOJDIABDIABDIABDIAAHF@@@@@@@@@@@@@@@@) (RPAQQ 800BITMAP #*(16 16)@@@@@@@@@@@@FAHFIBDIIBDIIBDIFBDIIBDIIBDIIBDIFAHF@@@@@@@@@@@@@@@@) (RPAQQ APPLEBITMAP #*(16 16)@@L@@AH@@OO@COOLCOOLGOONGOONGOONGONFGOLFGOHFCOHLCOILAOOH@ON@@GL@) (RPAQQ ATTRACTMODE NIL) (RPAQQ BELLBITMAP #*(16 16)@GN@@OO@AOOHAGOHCGOLCGOLCGOLCGOLCGOLCGOLCGOLCGOLGOONOOOO@@@@@@@@) (RPAQQ BIGPMANC #*(64 64)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOL@@@@@@@@@@@GOOOON@@@@@@@@@AOOOOOOL@@@@@@@@GOOOOOOO@@@@@@@AOOOOOOOOL@@@@@@GOOOOOOOOO@@@@@@OOOOOOOOOOH@@@@COOOOOOOOOOL@@@@GOOOOOOOOOON@@@@OOOOOOOOOOOO@@@AOOOOOOOOOOOOH@@COOOOOOOOOOOOL@@COOOOOOOOOOOON@@GOOOOOOOOOOOOO@@GOOOOOOOOOOOOO@@OOOOOOOOOOOOOOHAOOOOOOOOOOOOOOHAOOOOOOOOOOOOOOLCOOOOOOOOOOOOOOLCOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGOOOOOOOOOOOOOOOGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONCOOOOOOOOOOOOOOLCOOOOOOOOOOOOOOLAOOOOOOOOOOOOOOLAOOOOOOOOOOOOOOH@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@GOOOOOOOOOOOON@@GOOOOOOOOOOOON@@COOOOOOOOOOOOL@@AOOOOOOOOOOOOH@@@OOOOOOOOOOOO@@@@GOOOOOOOOOON@@@@COOOOOOOOOOL@@@@@OOOOOOOOOO@@@@@@GOOOOOOOOL@@@@@@AOOOOOOOO@@@@@@@@GOOOOOOL@@@@@@@@@GOOOON@@@@@@@@@@@COON@@@@@@ ) (RPAQQ BIGPMANR #*(64 64)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOL@@@@@@@@@@@GOOOON@@@@@@@@@AOOOOOOL@@@@@@@@GOOOOOOO@@@@@@@AOOOOOOOOL@@@@@@GOOOOOOOOO@@@@@@OOOOOOOOOOH@@@@COOOOOOOOOOL@@@@GOOOOOOOOOOH@@@@OOOOOOOOOOO@@@@AOOOOOOOOOON@@@@COOOOOOOOOOL@@@@COOOOOOOOOOH@@@@GOOOOOOOOOO@@@@@GOOOOOOOOON@@@@@OOOOOOOOOOL@@@@AOOOOOOOOOOH@@@@AOOOOOOOOOO@@@@@COOOOOOOOON@@@@@COOOOOOOOOL@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOO@@@@@@GOOOOOOOON@@@@@@GOOOOOOOOL@@@@@@OOOOOOOOOH@@@@@@OOOOOOOOO@@@@@@@OOOOOOOON@@@@@@@OOOOOOOOL@@@@@@@OOOOOOOOH@@@@@@@OOOOOOOOH@@@@@@@OOOOOOOOH@@@@@@@OOOOOOOOL@@@@@@@OOOOOOOON@@@@@@@OOOOOOOOO@@@@@@@OOOOOOOOOH@@@@@@GOOOOOOOOL@@@@@@GOOOOOOOON@@@@@@GOOOOOOOOO@@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOOL@@@@@COOOOOOOOON@@@@@COOOOOOOOOO@@@@@AOOOOOOOOOOH@@@@AOOOOOOOOOOL@@@@@OOOOOOOOOON@@@@@OOOOOOOOOOO@@@@@GOOOOOOOOOOH@@@@GOOOOOOOOOOL@@@@COOOOOOOOOON@@@@AOOOOOOOOOOO@@@@@OOOOOOOOOOOH@@@@GOOOOOOOOOOL@@@@COOOOOOOOOOH@@@@@OOOOOOOOOO@@@@@@GOOOOOOOOL@@@@@@AOOOOOOOO@@@@@@@@GOOOOOOL@@@@@@@@@GOOOON@@@@@@@@@@@COON@@@@@@ ) (RPAQQ BIRDBITMAP #*(16 16)AOOH@HA@@DB@@BD@@BD@OOOOH@@AH@@ADFFBBJEDABDH@BD@@BD@@BD@@AH@@@@@) (RPAQQ BLUETIME 0) (RPAQ BOARD (READARRAY-FROM-LIST 29 (QUOTE DOUBLEPOINTER) 1 (QUOTE ((8213 8220 8220 8220 8220 8221 8220 8220 8220 8220 8220 8217 0 0 8213 8220 8220 8220 8220 8220 8221 8220 8220 8220 8220 8217) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (35 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 35) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211 ) (8215 8220 8220 8220 8220 8223 8220 8220 8221 8220 8220 8222 8220 8220 8222 8220 8220 8221 8220 8220 8223 8220 8220 8220 8220 8219) (8211 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 8211 ) (8211 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 8211) (8214 8220 8220 8220 8220 8219 0 0 8214 8220 8220 8217 0 0 8213 8220 8220 8218 0 0 8215 8220 8220 8220 8220 8218) (0 0 0 0 0 8211 0 0 0 0 0 3 0 0 3 0 0 0 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 0 0 0 3 0 0 3 0 0 0 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 5 12 268 526 13 13 14 12 12 9 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 1030 2058 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 4 2 2 8 0 0 3 0 0 8211 0 0 0 0 0) ( 4172 4108 4108 4108 4108 8223 12 12 11 0 0 0 2 2 2 0 0 7 12 12 8223 4108 4108 4108 4108 4236) (0 0 0 0 0 8211 0 0 3 0 0 0 2 2 2 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 7 12 12 12 16396 12 12 12 12 11 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) ( 8213 8220 8220 8220 8220 8223 8220 8220 8222 8220 8220 8217 0 0 8213 8220 8220 8222 8220 8220 8223 8220 8220 8220 8220 8217) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) ( 8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (38 8220 8217 0 0 8215 8220 8220 8205 8204 8204 8206 12 12 8222 8220 8220 8221 8220 8220 8219 0 0 8213 8220 42) (0 0 8211 0 0 8211 0 0 8195 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 8211 0 0) (0 0 8211 0 0 8211 0 0 8195 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 8211 0 0) (8213 8220 8222 8220 8220 8218 0 0 8198 8204 8204 8201 0 0 8197 8204 8204 8202 0 0 8214 8220 8220 8222 8220 8217) (8211 0 0 0 0 0 0 0 0 0 0 8195 0 0 8195 0 0 0 0 0 0 0 0 0 0 8211) (8211 0 0 0 0 0 0 0 0 0 0 8195 0 0 8195 0 0 0 0 0 0 0 0 0 0 8211) (8214 8220 8220 8220 8220 8220 8220 8220 8220 8220 8220 8206 8204 8204 8206 8220 8220 8220 8220 8220 8220 8220 8220 8220 8220 8218) NIL))) ) (RPAQQ BOARDLIST ((0 0 13 0) (13 0 13 4) (13 4 14 4) (14 4 14 0) (14 0 27 0) (27 0 27 9) (27 9 22 9) (22 9 22 13) (22 13 27 13) (27 15 22 15) (22 15 22 19) (22 19 27 19) (27 19 27 24) (27 24 25 24) (25 24 25 25) (25 25 27 25) (27 25 27 30) (27 30 0 30) (0 30 0 25) (0 25 2 25) (2 25 2 24) (2 24 0 24) (0 24 0 19) (0 19 5 19) (5 19 5 15) (5 15 0 15) (0 13 5 13) (5 13 5 9) (5 9 0 9) (0 9 0 0) (2 2 5 2) (5 2 5 4) (5 4 2 4) (2 4 2 2) (7 2 11 2) (11 2 11 4) (11 4 7 4) (7 4 7 2) (16 2 20 2) (20 2 20 4) (20 4 16 4) (16 4 16 2) (22 2 25 2) (25 2 25 4) (25 4 22 4) (22 4 22 2) (2 6 5 6) (5 6 5 7) (5 7 2 7) (2 7 2 6) (22 6 25 6) (25 6 25 7) (25 7 22 7) (22 7 22 6) (7 6 8 6) (8 6 8 9) (8 9 11 9) (11 9 11 10) (11 10 8 10) (8 10 8 13) (8 13 7 13) (7 13 7 6) (19 6 20 6) (20 6 20 13) (20 13 19 13) (19 13 19 10) (19 10 16 10) (16 10 16 9) (16 9 19 9) (19 9 19 6) (10 6 17 6) (17 6 17 7) (17 7 14 7) (14 7 14 10) (14 10 13 10) (13 10 13 7) (13 7 10 7) (10 7 10 6) (12 12 10 12) (10 12 10 16) (10 16 17 16) (17 16 17 12) (17 12 15 12) (7 15 8 15) (8 15 8 19) (8 19 7 19) (7 19 7 15) (19 15 20 15) (20 15 20 19) (20 19 19 19) (19 19 19 15) (10 18 17 18) (17 18 17 19) (17 19 14 19) (14 19 14 22) (14 22 13 22) (13 22 13 19) (13 19 10 19) (10 19 10 18) (7 21 11 21) (11 21 11 22) (11 22 7 22) (7 22 7 21) (16 21 20 21) (20 21 20 22) (20 22 16 22) (16 22 16 21) (2 21 5 21) (5 21 5 25) (5 25 4 25) (4 25 4 22) (4 22 2 22) (2 22 2 21) (22 21 25 21) (25 21 25 22) (25 22 23 22) (23 22 23 25) (23 25 22 25) (22 25 22 21) (10 24 17 24) (17 24 17 25) (17 25 14 25) (14 25 14 28) (14 28 13 28) (13 28 13 25) (13 25 10 25) (10 25 10 24) (7 24 8 24) (8 24 8 27) (8 27 11 27) (11 27 11 28) (11 28 2 28) (2 28 2 27) (2 27 7 27) (7 27 7 24) (19 24 20 24) (20 24 20 27) (20 27 25 27) (25 27 25 28) (25 28 16 28) (16 28 16 27) (16 27 19 27) (19 27 19 24) (0 0 13 0) (13 0 13 4) (13 4 14 4) (14 4 14 0) (14 0 27 0) (27 0 27 9) (27 9 22 9) (22 9 22 13) (22 13 27 13) (27 15 22 15) (22 15 22 19) (22 19 27 19) (27 19 27 24) (27 24 25 24) (25 24 25 25) (25 25 27 25) (27 25 27 30) (27 30 0 30) (0 30 0 25) (0 25 2 25) (2 25 2 24) (2 24 0 24) (0 24 0 19) (0 19 5 19) (5 19 5 15) (5 15 0 15) (0 13 5 13) (5 13 5 9) (5 9 0 9) (0 9 0 0) (2 2 5 2) (5 2 5 4) (5 4 2 4) (2 4 2 2) (7 2 11 2) (11 2 11 4) (11 4 7 4) (7 4 7 2) (16 2 20 2) (20 2 20 4) (20 4 16 4) (16 4 16 2) (22 2 25 2) (25 2 25 4) (25 4 22 4) (22 4 22 2) (2 6 5 6) (5 6 5 7) (5 7 2 7) (2 7 2 6) (22 6 25 6) (25 6 25 7) (25 7 22 7) (22 7 22 6) (7 6 8 6) (8 6 8 9) (8 9 11 9) (11 9 11 10) (11 10 8 10) (8 10 8 13) (8 13 7 13) (7 13 7 6) (19 6 20 6) (20 6 20 13) (20 13 19 13) (19 13 19 10) (19 10 16 10) (16 10 16 9) (16 9 19 9) (19 9 19 6) (10 6 17 6) (17 6 17 7) (17 7 14 7) (14 7 14 10) (14 10 13 10) (13 10 13 7) (13 7 10 7) (10 7 10 6) (12 12 10 12) (10 12 10 16) (10 16 17 16) (17 16 17 12) (17 12 15 12) (7 15 8 15) (8 15 8 19) (8 19 7 19) (7 19 7 15) (19 15 20 15) (20 15 20 19) (20 19 19 19) (19 19 19 15) (10 18 17 18) (17 18 17 19) (17 19 14 19) (14 19 14 22) (14 22 13 22) (13 22 13 19) (13 19 10 19) (10 19 10 18) (7 21 11 21) (11 21 11 22) (11 22 7 22) (7 22 7 21) (16 21 20 21) (20 21 20 22) (20 22 16 22) (16 22 16 21) (2 21 5 21) (5 21 5 25) (5 25 4 25) (4 25 4 22) (4 22 2 22) (2 22 2 21) (22 21 25 21) (25 21 25 22) (25 22 23 22) (23 22 23 25) (23 25 22 25) (22 25 22 21) (10 24 17 24) (17 24 17 25) (17 25 14 25) (14 25 14 28) (14 28 13 28) (13 28 13 25) (13 25 10 25) (10 25 10 24) (7 24 8 24) (8 24 8 27) (8 27 11 27) (11 27 11 28) (11 28 2 28) (2 28 2 27) (2 27 7 27) (7 27 7 24) (19 24 20 24) (20 24 20 27) (20 27 25 27) (25 27 25 28) (25 28 16 28) (16 28 16 27) (16 27 19 27) (19 27 19 24) (0 0 13 0) (13 0 13 4) (13 4 14 4) (14 4 14 0) (14 0 27 0) (27 0 27 9) (27 9 22 9) (22 9 22 13) (22 13 27 13) (27 15 22 15) (22 15 22 19) (22 19 27 19) (27 19 27 24) (27 24 25 24) (25 24 25 25) (25 25 27 25) (27 25 27 30) (27 30 0 30) (0 30 0 25) (0 25 2 25) (2 25 2 24) (2 24 0 24) (0 24 0 19) (0 19 5 19) (5 19 5 15) (5 15 0 15) (0 13 5 13) (5 13 5 9) (5 9 0 9) (0 9 0 0) (2 2 5 2) (5 2 5 4) (5 4 2 4) (2 4 2 2) (7 2 11 2) (11 2 11 4) (11 4 7 4) (7 4 7 2) (16 2 20 2) (20 2 20 4) (20 4 16 4) (16 4 16 2) (22 2 25 2) (25 2 25 4) (25 4 22 4) (22 4 22 2) (2 6 5 6) (5 6 5 7) (5 7 2 7) (2 7 2 6) (22 6 25 6) (25 6 25 7) (25 7 22 7) (22 7 22 6) (7 6 8 6) (8 6 8 9) (8 9 11 9) (11 9 11 10) (11 10 8 10) (8 10 8 13) (8 13 7 13) (7 13 7 6) (19 6 20 6) (20 6 20 13) (20 13 19 13) (19 13 19 10) (19 10 16 10) (16 10 16 9) (16 9 19 9) (19 9 19 6) (10 6 17 6) (17 6 17 7) (17 7 14 7) (14 7 14 10) (14 10 13 10) (13 10 13 7) (13 7 10 7) (10 7 10 6) (12 12 10 12) (10 12 10 16) (10 16 17 16) (17 16 17 12) (17 12 15 12) (7 15 8 15) (8 15 8 19) (8 19 7 19) (7 19 7 15) (19 15 20 15) (20 15 20 19) (20 19 19 19) (19 19 19 15) (10 18 17 18) (17 18 17 19) (17 19 14 19) (14 19 14 22) (14 22 13 22) (13 22 13 19) (13 19 10 19) (10 19 10 18) (7 21 11 21) (11 21 11 22) (11 22 7 22) (7 22 7 21) (16 21 20 21) (20 21 20 22) (20 22 16 22) (16 22 16 21) (2 21 5 21) (5 21 5 25) (5 25 4 25) (4 25 4 22) (4 22 2 22) (2 22 2 21) (22 21 25 21) (25 21 25 22) (25 22 23 22) (23 22 23 25) (23 25 22 25) (22 25 22 21) (10 24 17 24) (17 24 17 25) (17 25 14 25) (14 25 14 28) (14 28 13 28) (13 28 13 25) (13 25 10 25) (10 25 10 24) (7 24 8 24) (8 24 8 27) (8 27 11 27) (11 27 11 28) (11 28 2 28) (2 28 2 27) (2 27 7 27) (7 27 7 24) (19 24 20 24) (20 24 20 27) (20 27 25 27) (25 27 25 28) (25 28 16 28) (16 28 16 27) (16 27 19 27) (19 27 19 24) (0 0 13 0) (13 0 13 4) (13 4 14 4) (14 4 14 0) (14 0 27 0) (27 0 27 9) (27 9 22 9) (22 9 22 13) (22 13 27 13) (27 15 22 15) (22 15 22 19) (22 19 27 19) (27 19 27 24) (27 24 25 24) (25 24 25 25) (25 25 27 25) (27 25 27 30) (27 30 0 30) (0 30 0 25) (0 25 2 25) (2 25 2 24) (2 24 0 24) (0 24 0 19) (0 19 5 19) (5 19 5 15) (5 15 0 15) (0 13 5 13) (5 13 5 9) (5 9 0 9) (0 9 0 0) (2 2 5 2) (5 2 5 4) (5 4 2 4) (2 4 2 2) (7 2 11 2) (11 2 11 4) (11 4 7 4) (7 4 7 2) (16 2 20 2) (20 2 20 4) (20 4 16 4) (16 4 16 2) (22 2 25 2) (25 2 25 4) (25 4 22 4) (22 4 22 2) (2 6 5 6) (5 6 5 7) (5 7 2 7) (2 7 2 6) (22 6 25 6) (25 6 25 7) (25 7 22 7) (22 7 22 6) (7 6 8 6) (8 6 8 9) (8 9 11 9) (11 9 11 10) (11 10 8 10) (8 10 8 13) (8 13 7 13) (7 13 7 6) (19 6 20 6) (20 6 20 13) (20 13 19 13) (19 13 19 10) (19 10 16 10) (16 10 16 9) (16 9 19 9) (19 9 19 6) (10 6 17 6) (17 6 17 7) (17 7 14 7) (14 7 14 10) (14 10 13 10) (13 10 13 7) (13 7 10 7) (10 7 10 6) (12 12 10 12) (10 12 10 16) (10 16 17 16) (17 16 17 12) (17 12 15 12) (7 15 8 15) (8 15 8 19) (8 19 7 19) (7 19 7 15) (19 15 20 15) (20 15 20 19) (20 19 19 19) (19 19 19 15) (10 18 17 18) (17 18 17 19) (17 19 14 19) (14 19 14 22) (14 22 13 22) (13 22 13 19) (13 19 10 19) (10 19 10 18) (7 21 11 21) (11 21 11 22) (11 22 7 22) (7 22 7 21) (16 21 20 21) (20 21 20 22) (20 22 16 22) (16 22 16 21) (2 21 5 21) (5 21 5 25) (5 25 4 25) (4 25 4 22) (4 22 2 22) (2 22 2 21) (22 21 25 21) (25 21 25 22) (25 22 23 22) (23 22 23 25) (23 25 22 25) (22 25 22 21) (10 24 17 24) (17 24 17 25) (17 25 14 25) (14 25 14 28) (14 28 13 28) (13 28 13 25) (13 25 10 25) (10 25 10 24) (7 24 8 24) (8 24 8 27) (8 27 11 27) (11 27 11 28) (11 28 2 28) (2 28 2 27) (2 27 7 27) (7 27 7 24) (19 24 20 24) (20 24 20 27) (20 27 25 27) (25 27 25 28) (25 28 16 28) (16 28 16 27) (16 27 19 27) (19 27 19 24) (0 0 13 0) (13 0 13 4) (13 4 14 4) (14 4 14 0) (14 0 27 0) (27 0 27 9) (27 9 22 9) (22 9 22 13) (22 13 27 13) (27 15 22 15) (22 15 22 19) (22 19 27 19) (27 19 27 24) (27 24 25 24) (25 24 25 25) (25 25 27 25) (27 25 27 30) (27 30 0 30) (0 30 0 25) (0 25 2 25) (2 25 2 24) (2 24 0 24) (0 24 0 19) (0 19 5 19) (5 19 5 15) (5 15 0 15) (0 13 5 13) (5 13 5 9) (5 9 0 9) (0 9 0 0) (2 2 5 2) (5 2 5 4) (5 4 2 4) (2 4 2 2) (7 2 11 2) (11 2 11 4) (11 4 7 4) (7 4 7 2) (16 2 20 2) (20 2 20 4) (20 4 16 4) (16 4 16 2) (22 2 25 2) (25 2 25 4) (25 4 22 4) (22 4 22 2) (2 6 5 6) (5 6 5 7) (5 7 2 7) (2 7 2 6) (22 6 25 6) (25 6 25 7) (25 7 22 7) (22 7 22 6) (7 6 8 6) (8 6 8 9) (8 9 11 9) (11 9 11 10) (11 10 8 10) (8 10 8 13) (8 13 7 13) (7 13 7 6) (19 6 20 6) (20 6 20 13) (20 13 19 13) (19 13 19 10) (19 10 16 10) (16 10 16 9) (16 9 19 9) (19 9 19 6) (10 6 17 6) (17 6 17 7) (17 7 14 7) (14 7 14 10) (14 10 13 10) (13 10 13 7) (13 7 10 7) (10 7 10 6) (12 12 10 12) (10 12 10 16) (10 16 17 16) (17 16 17 12) (17 12 15 12) (7 15 8 15) (8 15 8 19) (8 19 7 19) (7 19 7 15) (19 15 20 15) (20 15 20 19) (20 19 19 19) (19 19 19 15) (10 18 17 18) (17 18 17 19) (17 19 14 19) (14 19 14 22) (14 22 13 22) (13 22 13 19) (13 19 10 19) (10 19 10 18) (7 21 11 21) (11 21 11 22) (11 22 7 22) (7 22 7 21) (16 21 20 21) (20 21 20 22) (20 22 16 22) (16 22 16 21) (2 21 5 21) (5 21 5 25) (5 25 4 25) (4 25 4 22) (4 22 2 22) (2 22 2 21) (22 21 25 21) (25 21 25 22) (25 22 23 22) (23 22 23 25) (23 25 22 25) (22 25 22 21) (10 24 17 24) (17 24 17 25) (17 25 14 25) (14 25 14 28) (14 28 13 28) (13 28 13 25) (13 25 10 25) (10 25 10 24) (7 24 8 24) (8 24 8 27) (8 27 11 27) (11 27 11 28) (11 28 2 28) (2 28 2 27) (2 27 7 27) (7 27 7 24) (19 24 20 24) (20 24 20 27) (20 27 25 27) (25 27 25 28) (25 28 16 28) (16 28 16 27) (16 27 19 27) (19 27 19 24) (0 0 13 0) (13 0 13 4) (13 4 14 4) (14 4 14 0) (14 0 27 0) (27 0 27 9) (27 9 22 9) (22 9 22 13) (22 13 27 13) (27 15 22 15) (22 15 22 19) (22 19 27 19) (27 19 27 24) (27 24 25 24) (25 24 25 25) (25 25 27 25) (27 25 27 30) (27 30 0 30) (0 30 0 25) (0 25 2 25) (2 25 2 24) (2 24 0 24) (0 24 0 19) (0 19 5 19) (5 19 5 15) (5 15 0 15) (0 13 5 13) (5 13 5 9) (5 9 0 9) (0 9 0 0) (2 2 5 2) (5 2 5 4) (5 4 2 4) (2 4 2 2) (7 2 11 2) (11 2 11 4) (11 4 7 4) (7 4 7 2) (16 2 20 2) (20 2 20 4) (20 4 16 4) (16 4 16 2) (22 2 25 2) (25 2 25 4) (25 4 22 4) (22 4 22 2) (2 6 5 6) (5 6 5 7) (5 7 2 7) (2 7 2 6) (22 6 25 6) (25 6 25 7) (25 7 22 7) (22 7 22 6) (7 6 8 6) (8 6 8 9) (8 9 11 9) (11 9 11 10) (11 10 8 10) (8 10 8 13) (8 13 7 13) (7 13 7 6) (19 6 20 6) (20 6 20 13) (20 13 19 13) (19 13 19 10) (19 10 16 10) (16 10 16 9) (16 9 19 9) (19 9 19 6) (10 6 17 6) (17 6 17 7) (17 7 14 7) (14 7 14 10) (14 10 13 10) (13 10 13 7) (13 7 10 7) (10 7 10 6) (12 12 10 12) (10 12 10 16) (10 16 17 16) (17 16 17 12) (17 12 15 12) (7 15 8 15) (8 15 8 19) (8 19 7 19) (7 19 7 15) (19 15 20 15) (20 15 20 19) (20 19 19 19) (19 19 19 15) (10 18 17 18) (17 18 17 19) (17 19 14 19) (14 19 14 22) (14 22 13 22) (13 22 13 19) (13 19 10 19) (10 19 10 18) (7 21 11 21) (11 21 11 22) (11 22 7 22) (7 22 7 21) (16 21 20 21) (20 21 20 22) (20 22 16 22) (16 22 16 21) (2 21 5 21) (5 21 5 25) (5 25 4 25) (4 25 4 22) (4 22 2 22) (2 22 2 21) (22 21 25 21) (25 21 25 22) (25 22 23 22) (23 22 23 25) (23 25 22 25) (22 25 22 21) (10 24 17 24) (17 24 17 25) (17 25 14 25) (14 25 14 28) (14 28 13 28) (13 28 13 25) (13 25 10 25) (10 25 10 24) (7 24 8 24) (8 24 8 27) (8 27 11 27) (11 27 11 28) (11 28 2 28) (2 28 2 27) (2 27 7 27) (7 27 7 24) (19 24 20 24) (20 24 20 27) (20 27 25 27) (25 27 25 28) (25 28 16 28) (16 28 16 27) (16 27 19 27) (19 27 19 24))) (RPAQQ CHERRY 10) (RPAQQ CHERRYBITMAP #*(16 16)@@@C@@CN@@NDCMHHGNA@OMC@OHJ@OHJ@OLOHOOONGOOKCOOA@COA@COI@AON@@OL) (RPAQQ COLORPMANDOWN #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDDDD@@DDDDDDDDDDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@DDDDDD@DDDD@@@@@@DDDD@@DDD@@@@@@@@DDD@@@D@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ COLORPMANLEFT #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDDD@@@@@@DDDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDD@@@@DDDDDDDDDDD@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ COLORPMANRIGHT #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@DDDDDDDDDDD@@@@DDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDDD@@@@@@DDDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ COLORPMANUP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@D@@@DDD@@@@@@@@DDD@@DDDD@@@@@@DDDD@DDDDDD@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDDDDDDDDDD@@DDDDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ DOT #*(4 4)O@@@O@@@O@@@O@@@) (RPAQQ ENERGIZER #*(8 8)CL@@GN@@OO@@OO@@OO@@OO@@GN@@CL@@) (RPAQQ ENERGIZEROBJ I) (RPAQQ EYESBITMAP #*(16 16)@@@@@@@@@@@@@@@@@@@@ALCHBFDLBFDLBFDLALCH@@@@@@@@@@@@@@@@@@@@@@@@) (RPAQQ FRUIT# 2) (RPAQQ FRUITTIME 60) (RPAQQ G1BITMAP #*(16 16)@GN@ALCHB@@DD@@BH@@AILCIJFDMJFDMJFDMILCIH@@AH@@AH@@AICLIJJEELFFC) (RPAQQ G2BITMAP #*(16 16)@GN@ALCHC@@LF@@FMNGCKAHIJC@MJC@MJC@MKAHIINGAH@@AH@@AKKMMNNGGLFFC) (RPAQQ G3BITMAP #*(16 16)@GN@ALCHB@@DD@@BH@@AILCIJFDMJFDMJFDMILCIH@@AH@@AH@@AICLIJJEELFFC) (RPAQQ G4BITMAP #*(16 16)@GN@AMEHBJJLEEEFJBJEMMCKJFDMNFDOJFDMOMKKJJMEMEJKJJEEMEJKJJEELFFC) (RPAQQ GINVBITMAP #*(16 16)@GN@AOOHCOOLGOONOOOOOOOONGLONGLONGLOOOOOOOOOOOOOOOOOOOOONNGGLFFC) (RPAQQ KEYBITMAP #*(16 16)@GN@AOOHANGHCNGLCOOLCOOLCOOLAOOH@OO@@GF@@CD@@CD@@CD@@CH@@C@@@B@@) (RPAQQ MRIGHT {BITMAP}#7,66154) (RPAQQ NEXTMOVE 0) (RPAQQ ORANGEBITMAP #*(16 16)@GN@@OOLCIL@G@@LGOONOOOOOOOOOOOOOOOOOOOOOOOOGOONGOONCOOL@GN@@@@@) (RPAQQ PACMANC #*(16 16)@GN@AOOHCOOLGOONGOONOOOOOOOOOOOOOOOOOOOOOOOOGOONGOONCOOLAOOH@GN@) (RPAQQ PACMANINCOLOR NIL) (RPAQQ PINEAPPLEBITMAP #*(16 16)@CL@@EJ@@EJ@@EJ@@EJ@@OK@@OO@AJMHAGOH@NK@AENHAOKHAJO@AOKH@MO@@GN@) (RPAQQ PMAN X) (RPAQQ PMANDOWN #*(16 16)@GN@AOOHCOOLGOONGOONOOOOOOOOOOOOOOOOOOOOOLCOGHANG@@NB@@D@@@@@@@@) (RPAQQ PMANLEFT #*(16 16)@GN@AOOHCOOLAOON@OON@GOO@COO@COO@COO@COO@GOO@OONAOONCOOLAOOH@GN@) (RPAQQ PMANRIGHT #*(16 16)@GN@AOOHCOOLGOOHGOO@OON@OOL@OOL@OOL@OOL@OON@GOO@GOOHCOOLAOOH@GN@) (RPAQQ PMANUP #*(16 16)@@@@@@@@B@@DG@@NGHANOLCOOOOOOOOOOOOOOOOOOOOOGOONGOONCOOLAOOH@GN@) (RPAQQ PMGAMEOVER NIL) (RPAQQ PSTREAM NIL) (RPAQQ PWINDOW NIL) (RPAQQ QUARTERBITMAP #*(32 32)@@@GN@@@@@GHAL@@@@NAIC@@@CIIJHL@@EEECAJ@@LDMJII@ADB@@BBHAFHGO@BDCKAIOLEDA@A@ON@BD@A@ON@BF@ADGO@AB@B@CO@AL@D@CO@AH@D@@F@AN@B@@F@A@@C@@F@AL@B@@B@AN@CL@C@A@@@D@E@ALEDB@DHAB@@B@F@BDBHD@B@BB@@OON@DC@@@@@@DA@BLI@@H@HBMDHA@@DBLI@B@@BBEDHL@@AHLIA@@@@G@@N@@@@@OO@@@ ) (RPAQQ ROW (8214 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8222 8210)) (RPAQQ SIGLOGO #*(64 32)@@@@@AOHC@@@@@@@@@@@@GOHCH@@@@@@@@@@@GO@GH@@@@@@@@@@@ON@GH@L@@@@@@@@@OL@GLCL@@@@@@@@@OL@GLGH@@@@@@@@@OH@GLOH@@@@@@B@@OONOOOH@@@@@@CL@OONOOO@@G@@@@CN@GOLOON@AN@@@@AOHGOIOON@GN@@@@AONAO@OOL@OL@@@@AOOH@@COLCOL@H@@@OOL@@@GHOOLAH@O@OOH@@@@IOOHAHAOHGO@@@@@COOHCHCOLGN@@@@@COO@GHCOLGL@@@@@AOO@O@GOLCH@@@@@@GN@O@GOLC@@@@@@@CNAO@GOLB@@@@@@@ALCN@OOL@@@@@@@@@LGNAOOH@@@@@@@@@@ONCOOH@@@@@@@@@COLGOOH@@@@@@@@@AOLOGON@@@@@@@@@@OOOAON@@@@@@@@@@OOO@OL@@@@@@@@@@GON@CL@@@@@@@@@@GOH@AH@@@@@@@@@@CO@@@H@@@@@@@@@@CL@@@@@@@@@@@@@@@@@ ) (RPAQQ STRAWBERRYBITMAP #*(16 16)@AH@@AH@AOOHGMKNMNGNHMCKH@@AIHCADAHBD@CFFNBDC@@LCBI@AHC@@IJ@@GL@) (RPAQQ PACMANWAITTIME 100) (RPAQQ PMANINPUTMODE NIL) (RPAQQ PMANUPMAP #*(16 16)@@@@@@@@B@@DG@@NGHANOLCOOOOOOOOOOOOOOOOOOOOOGOONGOONCOOLAOOH@GN@) (RPAQQ COLORPMANUP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@D@@@DDD@@@@@@@@DDD@@DDDD@@@@@@DDDD@DDDDDD@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDDDDDDDDDD@@DDDDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ PMANRIGHTMAP #*(16 16)@GN@AOOHCOOLGOOHGOO@OON@OOL@OOL@OOL@OOL@OON@GOO@GOOHCOOLAOOH@GN@) (RPAQQ COLORPMANRIGHT #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@DDDDDDDDDDD@@@@DDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDDD@@@@@@DDDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ PMANDOWNMAP #*(16 16)@GN@AOOHCOOLGOONGOONOOOOOOOOOOOOOOOOOOOOOLCOGHANG@@NB@@D@@@@@@@@) (RPAQQ COLORPMANDOWN #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDDDD@@DDDDDDDDDDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@DDDDDD@DDDD@@@@@@DDDD@@DDD@@@@@@@@DDD@@@D@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ PMANLEFTMAP #*(16 16)@GN@AOOHCOOLAOON@OON@GOO@COO@COO@COO@COO@GOO@OONAOONCOOLAOOH@GN@) (RPAQQ COLORPMANLEFT #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDDDD@@@@@DDDDDDDDDDD@@@@@@DDDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDD@@@@DDDDDDDDDDD@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ PACMANCMAP #*(16 16)@GN@AOOHCOOLGOONGOONOOOOOOOOOOOOOOOOOOOOOOOOGOONGOONCOOLAOOH@GN@) (RPAQQ COLORPACMANC #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDDDD@@DDDDDDDDDDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDDDDDDDDDD@@DDDDDDDDDDDDDD@@@DDDDDDDDDDDD@@@@@DDDDDDDDDD@@@@@@@@DDDDDD@@@@@ ) (RPAQQ DOT #*(4 4)O@@@O@@@O@@@O@@@) (RPAQQ COLORDOT #*(4 4 4)DDDDDDDDDDDDDDDD) (RPAQQ ENERGIZER #*(8 8)CL@@GN@@OO@@OO@@OO@@OO@@GN@@CL@@) (RPAQQ COLORENERGIZER #*(8 8 4)@@DDDD@@@DDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDD@@@DDDD@@) (RPAQQ BWG1BITMAP #*(16 16)@GN@ALCHB@@DD@@BH@@AILCIJFDMJFDMJFDMILCIH@@AH@@AH@@AICLIJJEELFFC) (RPAQQ COLORG1BITMAP #*(16 16 4)@@@@@CCCCCC@@@@@@@@CCCCCCCCCC@@@@@CCCCCCCCCCCC@@@CCCCCCCCCCCCCC@CCCGGGCCCCGGGCCCCCCGGGCCCCGGGCCCCCCGG@@CCCGG@@CCCCCGG@@CCCGG@@CCCCCGG@@CCCGG@@CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC@CCC@@CCC@CCCCC@@@CC@@CC@@@CC ) (RPAQQ BWG2BITMAP #*(16 16)@GN@ALCHC@@LF@@FMNGCKAHIJC@MJC@MJC@MKAHIINGAH@@AH@@AKKMMNNGGLFFC) (RPAQQ COLORG2BITMAP #*(16 16 4)@@@@@IIIIII@@@@@@@@IIIIIIIIII@@@@@IIIIIIIIIIII@@@IIIIIIIIIIIIII@IIIGGIIIIIGGGIIIIIIGGIIIIIGGGIIIIIIG@@AIIIG@@AIIIIIG@@AIIIG@@AIIIIIG@@AIIIG@@AIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII@III@@III@IIIII@@@II@@II@@@II ) (RPAQQ BWG3BITMAP #*(16 16)@GN@ALCHB@@DD@@BH@@AILCIJFDMJFDMJFDMILCIH@@AH@@AH@@AICLIJJEELFFC) (RPAQQ COLORG3BITMAP #*(16 16 4)@@@@@DDDDDD@@@@@@@@DDDDDDDDDD@@@@@DDDDDDDDDDDD@@@DDDDDDDDDDDDDD@DDGGGDDDDGGGDDDDDDGGGDDDDGGGDDDDDDGG@@@DDGG@@@DDDDGG@@@DDGG@@@DDDDDG@@@DDDG@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDD@@DDD@DDDDD@@@DD@@DD@@@DD ) (RPAQQ BWG4BITMAP #*(16 16)@GN@AMEHBJJLEEEFJBJEMMCKJFDMNFDOJFDMOMKKJJMEMEJKJJEEMEJKJJEELFFC) (RPAQQ COLORG4BITMAP #*(16 16 4)@@@@@GGGGGG@@@@@@@@GGGGGGGGGG@@@@@GGGGGGGGGGGG@@@GGGGGGGGGGGGGG@GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG@@GGGGG@@GGGGGGG@@GGGGG@@GGGGGGG@@GGGGG@@GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG@GGG@@GGG@GGGGG@@@GG@@GG@@@GG ) (RPAQQ BWGINVBITMAP #*(16 16)@GN@AOOHCOOLGOONOOOOOOOONGLONGLONGLOOOOOOOOOOOOOOOOOOOOONNGGLFFC) (RPAQQ COLORGINVBITMAP #*(16 16 4)@@@@@AAAAAA@@@@@@@@AAAAAAAAAA@@@@@AAAAAAAAAAAA@@@AAAAAAAAAAAAAA@AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA@@AAAAA@@AAAAAAA@@AAAAA@@AAAAAAA@@AAAAA@@AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA@AAA@@AAA@AAAAA@@@AA@@AA@@@AA ) (RPAQQ CHERRYBITMAP #*(16 16)@@@C@@CN@@NDCMHHGNA@OMC@OHJ@OHJ@OLOHOOONGOOKCOOA@COA@COI@AON@@OL) (RPAQQ COLORCHERRYBITMAP #*(16 16 4)@@@@@@@@@@@@@@CC@@@@@@@@@@CCCCC@@@@@@@@@CCC@@C@@@@CCCC@CC@@@C@@@@CCCCCC@@@@C@@@@CCCCCC@C@@CC@@@@CCCCC@@@C@C@@@@@CCCCC@@@C@C@@@@@CCCCCC@@CCCCC@@@CCCCCCCCCCCCCCC@@CCCCCCCCCCCC@CC@@CCCCCCCCCC@@@C@@@@@@CCCCCC@@@C@@@@@@CCCCCCC@@C@@@@@@@CCCCCCCC@@@@@@@@@CCCCCC@@ ) (RPAQQ STRAWBERRYBITMAP #*(16 16)@AH@@AH@AOOHGMKNMNGNHMCKH@@AIHCADAHBD@CFFNBDC@@LCBI@AHC@@IJ@@GL@) (RPAQQ COLORSTRAWBERRYBITMAP #*(16 16 4)@@@@@@@EE@@@@@@@@@@@@@@EE@@@@@@@@@@EEEEEEEEEE@@@@EEEEE@EE@EEEEE@EE@EEEE@@EEEEEE@E@@@EE@E@@EEE@EEE@@@@@@@@@@@@@@EE@@EE@@@@@EE@@@E@E@@@@@EE@@@@@E@@E@@@@@@@@EE@EE@@EE@EEE@@@E@@E@@@@EE@@@@@@@@EE@@@@EE@@E@E@@E@@@@@@@EE@@@@@EE@@@@@@@@E@@EE@E@@@@@@@@@@EEEEE@@@@@@ ) (RPAQQ ORANGEBITMAP #*(16 16)@GN@@OOLCIL@G@@LGOONOOOOOOOOOOOOOOOOOOOOOOOOGOONGOONCOOL@GN@@@@@) (RPAQQ COLORORANGEBITMAP #*(16 16 4)@@@@@CCCCCC@@@@@@@@@CCCCCCCCCC@@@@CCC@@CCC@@@@@@@CCC@@@@@@@@CC@@@CCCCCCCCCCCCCC@CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC@CCCCCCCCCCCCCC@@CCCCCCCCCCCCCC@@@CCCCCCCCCCCC@@@@@@@CCCCCC@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ APPLEBITMAP #*(16 16)@@L@@AH@@OO@COOLCOOLGOONGOONGOONGONFGOLFGOHFCOHLCOILAOOH@ON@@GL@) (RPAQQ COLORAPPLEBITMAP #*(16 16 4)@@@@@@@@CC@@@@@@@@@@@@@CC@@@@@@@@@@@CCCCCCCC@@@@@@CCCCCCCCCCCC@@@@CCCCCCCCCCCC@@@CCCCCCCCCCCCCC@@CCCCCCCCCCCCCC@@CCCCCCCCCCCCCC@@CCCCCCCCCC@@CC@@CCCCCCCCC@@@CC@@CCCCCCCC@@@@CC@@@CCCCCCC@@@CC@@@@CCCCCCC@@CCC@@@@@CCCCCCCCCC@@@@@@@CCCCCCC@@@@@@@@@@CCCCC@@@@@@ ) (RPAQQ PINEAPPLEBITMAP #*(16 16)@CL@@EJ@@EJ@@EJ@@EJ@@OK@@OO@AJMHAGOH@NK@AENHAOKHAJO@AOKH@MO@@GN@) (RPAQQ COLORPINEAPPLEBITMAP #*(16 16 4)@@@@@@BBBB@@@@@@@@@@@B@BB@B@@@@@@@@@@B@BB@B@@@@@@@@@@B@BB@B@@@@@@@@@@B@BB@B@@@@@@@@@BBBBB@BB@@@@@@@@BBBBBBBB@@@@@@@BB@B@BB@BB@@@@@@B@BBBBBBBB@@@@@@@BBB@B@BB@@@@@@@B@B@BBBB@B@@@@@@BBBBBB@BBB@@@@@@BB@B@BBBB@@@@@@@BBBBBB@BBB@@@@@@@BB@BBBBB@@@@@@@@@BBBBBB@@@@@ ) (RPAQQ BIRDBITMAP #*(16 16)AOOH@HA@@DB@@BD@@BD@OOOOH@@AH@@ADFFBBJEDABDH@BD@@BD@@BD@@AH@@@@@) (RPAQQ COLORBIRDBITMAP #*(16 16 4)@@@FFFFFFFFFF@@@@@@@F@@@@@@F@@@@@@@@@F@@@@F@@@@@@@@@@@F@@F@@@@@@@@@@@@F@@F@@@@@@FFFFFFFFFFFFFFFFF@@@@@@@@@@@@@@FF@@@@@@@@@@@@@@F@F@@@FF@@FF@@@F@@@F@F@F@@F@F@F@@@@@F@@F@@F@@F@@@@@@@@@F@@F@@@@@@@@@@@@F@@F@@@@@@@@@@@@F@@F@@@@@@@@@@@@@FF@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ BELLBITMAP #*(16 16)@GN@@OO@AOOHAGOHCGOLCGOLCGOLCGOLCGOLCGOLCGOLCGOLGOONOOOO@@@@@@@@) (RPAQQ COLORBELLBITMAP #*(16 16 4)@@@@@FFFFFF@@@@@@@@@FFFFFFFF@@@@@@@FFFFFFFFFF@@@@@@F@FFFFFFFF@@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@@FF@FFFFFFFFF@@@FFFFFFFFFFFFFF@FFFFFFFFFFFFFFFF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ KEYBITMAP #*(16 16)@GN@AOOHANGHCNGLCOOLCOOLCOOLAOOH@OO@@GF@@CD@@CD@@CD@@CH@@C@@@B@@) (RPAQQ COLORKEYBITMAP #*(16 16 4)@@@@@GGGGGG@@@@@@@@GGGGGGGGGG@@@@@@GGGG@@GGGG@@@@@GGGGG@@GGGGG@@@@GGGGGGGGGGGG@@@@GGGGGGGGGGGG@@@@GGGGGGGGGGGG@@@@@GGGGGGGGGG@@@@@@@GGGGGGGG@@@@@@@@@GGG@GG@@@@@@@@@@@GG@G@@@@@@@@@@@@GG@G@@@@@@@@@@@@GG@G@@@@@@@@@@@@GGG@@@@@@@@@@@@@GG@@@@@@@@@@@@@@G@@@@@@@@@ ) (RPAQQ 200BITMAP #*(16 16)@@@@@@@@@@@@FAHFIBDIABDIABDIBBDIDBDIHBDIHBDIOAHF@@@@@@@@@@@@@@@@) (RPAQQ COLOR200BITMAP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GG@@@@GG@@@@GG@G@@G@@G@@G@@G@@G@@@G@@G@@G@@G@@G@@@G@@G@@G@@G@@G@@G@@@G@@G@@G@@G@G@@@@G@@G@@G@@GG@@@@@G@@G@@G@@GG@@@@@G@@G@@G@@GGGGG@@@GG@@@@GG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ 400BITMAP #*(16 16)@@@@@@@@@@@@IAHFIBDIIBDIIBDIOJDIABDIABDIABDIAAHF@@@@@@@@@@@@@@@@) (RPAQQ COLOR400BITMAP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@G@@@GG@@@@GG@G@@G@@G@@G@@G@@GG@@G@@G@@G@@G@@GG@@G@@G@@G@@G@@GGGGGG@G@@G@@G@@G@@@G@@G@@G@@G@@G@@@G@@G@@G@@G@@G@@@G@@G@@G@@G@@G@@@G@@@GG@@@@GG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ 800BITMAP #*(16 16)@@@@@@@@@@@@FAHFIBDIIBDIIBDIFBDIIBDIIBDIIBDIFAHF@@@@@@@@@@@@@@@@) (RPAQQ COLOR800BITMAP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GG@@@@GG@@@@GG@G@@G@@G@@G@@G@@GG@@G@@G@@G@@G@@GG@@G@@G@@G@@G@@G@GG@@@G@@G@@G@@GG@@G@@G@@G@@G@@GG@@G@@G@@G@@G@@GG@@G@@G@@G@@G@@G@GG@@@@GG@@@@GG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ 1600BITMAP #*(16 16)@@@@@@@@@@@@IHLFJEBIJABIJABIKIBIJEBIJEBIJEBIIHLF@@@@@@@@@@@@@@@@) (RPAQQ COLOR1600BITMAP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@GG@@@GG@@@GG@G@G@@G@G@@G@G@@GG@G@@@@G@@G@G@@GG@G@@@@G@@G@G@@GG@GGG@@G@@G@G@@GG@G@@G@G@@G@G@@GG@G@@G@G@@G@G@@GG@G@@G@G@@G@G@@GG@@GG@@@GG@@@GG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ SIGLOGO #*(64 32)@@@@@AOHC@@@@@@@@@@@@GOHCH@@@@@@@@@@@GO@GH@@@@@@@@@@@ON@GH@L@@@@@@@@@OL@GLCL@@@@@@@@@OL@GLGH@@@@@@@@@OH@GLOH@@@@@@B@@OONOOOH@@@@@@CL@OONOOO@@G@@@@CN@GOLOON@AN@@@@AOHGOIOON@GN@@@@AONAO@OOL@OL@@@@AOOH@@COLCOL@H@@@OOL@@@GHOOLAH@O@OOH@@@@IOOHAHAOHGO@@@@@COOHCHCOLGN@@@@@COO@GHCOLGL@@@@@AOO@O@GOLCH@@@@@@GN@O@GOLC@@@@@@@CNAO@GOLB@@@@@@@ALCN@OOL@@@@@@@@@LGNAOOH@@@@@@@@@@ONCOOH@@@@@@@@@COLGOOH@@@@@@@@@AOLOGON@@@@@@@@@@OOOAON@@@@@@@@@@OOO@OL@@@@@@@@@@GON@CL@@@@@@@@@@GOH@AH@@@@@@@@@@CO@@@H@@@@@@@@@@CL@@@@@@@@@@@@@@@@@ ) (RPAQQ COLORSIGLOGO #*(64 32 4)@@@@@@@@@@@@@@@@@@@@@@@DDDDDD@@@@@DD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDD@@@@@DDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDD@@@@@DDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDD@@@@@@DDDD@@@@@@@DD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDD@@@@@@@DDDDD@@@@DDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDD@@@@@@@DDDDD@@@DDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDD@@@@@@@@DDDDD@@DDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@@@DDDDDDDDDDD@DDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDD@@@@@@DDDDDDDDDDD@DDDDDDDDDDDD@@@@@@@@@DDD@@@@@@@@@@@@@@@@@@DDDDD@@@@@@DDDDDDDDD@@DDDDDDDDDDD@@@@@@@@DDDD@@@@@@@@@@@@@@@@@@@@DDDDDD@@@@DDDDDDDD@@DDDDDDDDDDDD@@@@@@DDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDD@@@@DDDDD@@@@DDDDDDDDDD@@@@@@DDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDD@@@@@@@@@@@@@DDDDDDDD@@@@DDDDDDDD@@@@@@D@@@@@@@@@@@@@@@DDDDDDDDDD@@@@@@@@@@@@@@@DDDD@@@DDDDDDDDDD@@@@@DD@@@@@@@DDDD@@@@DDDDDDDDD@@@@@@@@@@@@@@@@@@@D@@DDDDDDDDDD@@@@@@DD@@@@@@DDDDDD@@@@DDDDDDD@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDD@@@@@DDD@@@@@DDDDDDDD@@@DDDDDD@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDD@@@@@DDDD@@@@@DDDDDDDD@@@DDDDD@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDD@@@@DDDD@@@@@DDDDDDDDD@@@@DDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDD@@@@@DDDD@@@@@DDDDDDDDD@@@@DD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDD@@@@DDDDD@@@@@DDDDDDDDD@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDD@@@@DDDDD@@@@@DDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DD@@@DDDDDD@@@@DDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDD@@@DDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDD@@@DDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDD@@DDDD@DDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDD@@@DDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDD@@@@DDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDD@@@@@@@DDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDD@@@@@@@@@@DD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDD@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ EYESBITMAP #*(16 16)@@@@@@@@@@@@@@@@@@@@ALCHBFDLBFDLBFDLALCH@@@@@@@@@@@@@@@@@@@@@@@@) (RPAQQ COLOREYESBITMAP #*(16 16 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CCC@@@@CCC@@@@@C@@CC@@C@@CC@@@@C@@CC@@C@@CC@@@@C@@CC@@C@@CC@@@@@CCC@@@@CCC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ BIGPMANC #*(64 64)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOL@@@@@@@@@@@GOOOON@@@@@@@@@AOOOOOOL@@@@@@@@GOOOOOOO@@@@@@@AOOOOOOOOL@@@@@@GOOOOOOOOO@@@@@@OOOOOOOOOOH@@@@COOOOOOOOOOL@@@@GOOOOOOOOOON@@@@OOOOOOOOOOOO@@@AOOOOOOOOOOOOH@@COOOOOOOOOOOOL@@COOOOOOOOOOOON@@GOOOOOOOOOOOOO@@GOOOOOOOOOOOOO@@OOOOOOOOOOOOOOHAOOOOOOOOOOOOOOHAOOOOOOOOOOOOOOLCOOOOOOOOOOOOOOLCOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGOOOOOOOOOOOOOOOGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONGOOOOOOOOOOOOOONCOOOOOOOOOOOOOOLCOOOOOOOOOOOOOOLAOOOOOOOOOOOOOOLAOOOOOOOOOOOOOOH@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@GOOOOOOOOOOOON@@GOOOOOOOOOOOON@@COOOOOOOOOOOOL@@AOOOOOOOOOOOOH@@@OOOOOOOOOOOO@@@@GOOOOOOOOOON@@@@COOOOOOOOOOL@@@@@OOOOOOOOOO@@@@@@GOOOOOOOOL@@@@@@AOOOOOOOO@@@@@@@@GOOOOOOL@@@@@@@@@GOOOON@@@@@@@@@@@COON@@@@@@ ) (RPAQQ COLORBIGPMANC #*(64 64 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ BIGPMANR #*(64 64)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOL@@@@@@@@@@@GOOOON@@@@@@@@@AOOOOOOL@@@@@@@@GOOOOOOO@@@@@@@AOOOOOOOOL@@@@@@GOOOOOOOOO@@@@@@OOOOOOOOOOH@@@@COOOOOOOOOOL@@@@GOOOOOOOOOOH@@@@OOOOOOOOOOO@@@@AOOOOOOOOOON@@@@COOOOOOOOOOL@@@@COOOOOOOOOOH@@@@GOOOOOOOOOO@@@@@GOOOOOOOOON@@@@@OOOOOOOOOOL@@@@AOOOOOOOOOOH@@@@AOOOOOOOOOO@@@@@COOOOOOOOON@@@@@COOOOOOOOOL@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOO@@@@@@GOOOOOOOON@@@@@@GOOOOOOOOL@@@@@@OOOOOOOOOH@@@@@@OOOOOOOOO@@@@@@@OOOOOOOON@@@@@@@OOOOOOOOL@@@@@@@OOOOOOOOH@@@@@@@OOOOOOOOH@@@@@@@OOOOOOOOH@@@@@@@OOOOOOOOL@@@@@@@OOOOOOOON@@@@@@@OOOOOOOOO@@@@@@@OOOOOOOOOH@@@@@@GOOOOOOOOL@@@@@@GOOOOOOOON@@@@@@GOOOOOOOOO@@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOOL@@@@@COOOOOOOOON@@@@@COOOOOOOOOO@@@@@AOOOOOOOOOOH@@@@AOOOOOOOOOOL@@@@@OOOOOOOOOON@@@@@OOOOOOOOOOO@@@@@GOOOOOOOOOOH@@@@GOOOOOOOOOOL@@@@COOOOOOOOOON@@@@AOOOOOOOOOOO@@@@@OOOOOOOOOOOH@@@@GOOOOOOOOOOL@@@@COOOOOOOOOOH@@@@@OOOOOOOOOO@@@@@@GOOOOOOOOL@@@@@@AOOOOOOOO@@@@@@@@GOOOOOOL@@@@@@@@@GOOOON@@@@@@@@@@@COON@@@@@@ ) (RPAQQ COLORBIGPMANR #*(64 64 4)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DDDDDDDDDDDDD@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ QUARTERBITMAP #*(32 32)@@@GN@@@@@GHAL@@@@NAIC@@@CIIJHL@@EEECAJ@@LDMJII@ADB@@BBHAFHGO@BDCKAIOLEDA@A@ON@BD@A@ON@BF@ADGO@AB@B@CO@AL@D@CO@AH@D@@F@AN@B@@F@A@@C@@F@AL@B@@B@AN@CL@C@A@@@D@E@ALEDB@DHAB@@B@F@BDBHD@B@BB@@OON@DC@@@@@@DA@BLI@@H@HBMDHA@@DBLI@B@@BBEDHL@@AHLIA@@@@G@@N@@@@@OO@@@ ) (RPAQQ COLORQUARTERBITMAP #*(32 32 4)@@@@@@@@@@@@@GGGGGG@@@@@@@@@@@@@@@@@@@@@@GGGG@@@@@@GGG@@@@@@@@@@@@@@@@@@GGG@@@@GG@@G@@GG@@@@@@@@@@@@@@GGG@@GG@@GG@G@G@@@GG@@@@@@@@@@@G@G@G@G@G@G@@GG@@@GG@G@@@@@@@@@GG@@@G@@GG@GG@G@G@@GG@@G@@@@@@@G@G@@@@G@@@@@@@@@@@G@@@G@G@@@@@@G@GG@G@@@@GGGGGGG@@@@@@G@@G@@@@GGG@GG@@@GG@@GGGGGGG@@@G@G@G@@@@@G@@@@@@@G@@@@GGGGGGG@@@@@@@G@@G@@@@@@@@@G@@@@GGGGGGG@@@@@@@G@@GG@@@@@@@@G@G@@@GGGGGGG@@@@@@@G@@G@@@@@@@G@@@@@@@GGGGGG@@@@@@@GGG@@@@@@@G@@@@@@@@GGGGGG@@@@@@@GG@@@@@@@@G@@@@@@@@@@@GG@@@@@@@@GGGG@@@@@@@G@@@@@@@@@@GG@@@@@@@@G@@@@@@@@@@GG@@@@@@@@@GG@@@@@@@@GGG@@@@@@@@G@@@@@@@@@@@G@@@@@@@@GGGG@@@@@@@GGGG@@@@@@@@GG@@@@@@@G@@@@@@@@@@@@@G@@@@@@@G@G@@@@@@@GGG@@@G@G@G@@@@G@@@@@@G@@G@@@@@@G@@G@@@@@@@@@@@G@@@@@@GG@@@@@@@G@@G@@@@G@G@@@@G@@@@@@@@G@@@@@@@G@@@G@@@@@@@@@GGGGGGGGGGG@@@@@@G@@@@GG@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@G@@@@@@G@GG@@G@@G@@@@@@@@G@@@@@@@G@@@@@G@GG@G@G@@G@@@@@@G@@@@@@@@@G@@@@G@GG@@G@@G@@@@@@G@@@@@@@@@@@G@@@G@@G@G@G@@G@@@GG@@@@@@@@@@@@@GG@@@GG@@G@@G@@@G@@@@@@@@@@@@@@@@@GGG@@@@@@@@GGG@@@@@@@@@@@@@@@@@@@@@GGGGGGGG@@@@@@@@@@@@ ) (RPAQ BOARD (READARRAY-FROM-LIST 29 (QUOTE DOUBLEPOINTER) 1 (QUOTE ((8213 8220 8220 8220 8220 8221 8220 8220 8220 8220 8220 8217 0 0 8213 8220 8220 8220 8220 8220 8221 8220 8220 8220 8220 8217) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (35 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 35) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211 ) (8215 8220 8220 8220 8220 8223 8220 8220 8221 8220 8220 8222 8220 8220 8222 8220 8220 8221 8220 8220 8223 8220 8220 8220 8220 8219) (8211 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 8211 ) (8211 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 8211) (8214 8220 8220 8220 8220 8219 0 0 8214 8220 8220 8217 0 0 8213 8220 8220 8218 0 0 8215 8220 8220 8220 8220 8218) (0 0 0 0 0 8211 0 0 0 0 0 3 0 0 3 0 0 0 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 0 0 0 3 0 0 3 0 0 0 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 5 12 268 526 13 13 14 12 12 9 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 1030 2058 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 4 2 2 8 0 0 3 0 0 8211 0 0 0 0 0) ( 4172 4108 4108 4108 4108 8223 12 12 11 0 0 0 2 2 2 0 0 7 12 12 8223 4108 4108 4108 4108 4236) (0 0 0 0 0 8211 0 0 3 0 0 0 2 2 2 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 7 12 12 12 16396 12 12 12 12 11 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) ( 8213 8220 8220 8220 8220 8223 8220 8220 8222 8220 8220 8217 0 0 8213 8220 8220 8222 8220 8220 8223 8220 8220 8220 8220 8217) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) ( 8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (38 8220 8217 0 0 8215 8220 8220 8205 8204 8204 8206 12 12 8222 8220 8220 8221 8220 8220 8219 0 0 8213 8220 42) (0 0 8211 0 0 8211 0 0 8195 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 8211 0 0) (0 0 8211 0 0 8211 0 0 8195 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 8211 0 0) (8213 8220 8222 8220 8220 8218 0 0 8198 8204 8204 8201 0 0 8197 8204 8204 8202 0 0 8214 8220 8220 8222 8220 8217) (8211 0 0 0 0 0 0 0 0 0 0 8195 0 0 8195 0 0 0 0 0 0 0 0 0 0 8211) (8211 0 0 0 0 0 0 0 0 0 0 8195 0 0 8195 0 0 0 0 0 0 0 0 0 0 8211) (8214 8220 8220 8220 8220 8220 8220 8220 8220 8220 8220 8206 8204 8204 8206 8220 8220 8220 8220 8220 8220 8220 8220 8220 8220 8218) NIL))) ) (RPAQ VIRGINBOARD (READARRAY-FROM-LIST 29 (QUOTE DOUBLEPOINTER) 1 (QUOTE ((8213 8220 8220 8220 8220 8221 8220 8220 8220 8220 8220 8217 0 0 8213 8220 8220 8220 8220 8220 8221 8220 8220 8220 8220 8217) ( 8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (35 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 35) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (8215 8220 8220 8220 8220 8223 8220 8220 8221 8220 8220 8222 8220 8220 8222 8220 8220 8221 8220 8220 8223 8220 8220 8220 8220 8219) (8211 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 8211) (8211 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 8211) (8214 8220 8220 8220 8220 8219 0 0 8214 8220 8220 8217 0 0 8213 8220 8220 8218 0 0 8215 8220 8220 8220 8220 8218) (0 0 0 0 0 8211 0 0 0 0 0 3 0 0 3 0 0 0 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 0 0 0 3 0 0 3 0 0 0 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 5 12 12 14 269 13 14 12 12 9 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 518 10 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 1028 2 2 2056 0 0 3 0 0 8211 0 0 0 0 0) (4172 4108 4108 4108 4108 8223 12 12 11 0 0 0 2 2 2 0 0 7 12 12 8223 4108 4108 4108 4108 4236) (0 0 0 0 0 8211 0 0 3 0 0 0 2 2 2 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 7 12 12 12 16396 12 12 12 12 11 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (0 0 0 0 0 8211 0 0 3 0 0 0 0 0 0 0 0 3 0 0 8211 0 0 0 0 0) (8213 8220 8220 8220 8220 8223 8220 8220 8222 8220 8220 8217 0 0 8213 8220 8220 8222 8220 8220 8223 8220 8220 8220 8220 8217) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (8211 0 0 0 0 8211 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 8211 0 0 0 0 8211) (38 8220 8217 0 0 8215 8220 8220 8221 8220 8220 8222 12 12 8222 8220 8220 8221 8220 8220 8219 0 0 8213 8220 42) (0 0 8211 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 8211 0 0) (0 0 8211 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 8211 0 0) (8213 8220 8222 8220 8220 8218 0 0 8214 8220 8220 8217 0 0 8213 8220 8220 8218 0 0 8214 8220 8220 8222 8220 8217) (8211 0 0 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 0 0 8211) (8211 0 0 0 0 0 0 0 0 0 0 8211 0 0 8211 0 0 0 0 0 0 0 0 0 0 8211) (8214 8220 8220 8220 8220 8220 8220 8220 8220 8220 8220 8222 8220 8220 8222 8220 8220 8220 8220 8220 8220 8220 8220 8220 8220 8218) NIL))) ) (DECLARE%: DOEVAL@COMPILE (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS 1600BITMAP 200BITMAP 400BITMAP 800BITMAP APPLEBITMAP ATTRACTMODE BELLBITMAP BIGPMANC BIGPMANR BIRDBITMAP BLUETIME BOARD BOARDLIST BWG1BITMAP BWG2BITMAP BWG3BITMAP BWG4BITMAP BWGINVBITMAP CHERRYBITMAP COLOR1600BITMAP COLOR200BITMAP COLOR400BITMAP COLOR800BITMAP COLORAPPLEBITMAP COLORBELLBITMAP COLORBIGPMANC COLORBIGPMANR COLORBIRDBITMAP COLORCHERRYBITMAP COLORDOT COLORENERGIZER COLOREYESBITMAP COLORG1BITMAP COLORG2BITMAP COLORG3BITMAP COLORG4BITMAP COLORGINVBITMAP COLORKEYBITMAP COLORORANGEBITMAP COLORPACMANC COLORPINEAPPLEBITMAP COLORPMANDOWN COLORPMANLEFT COLORPMANRIGHT COLORPMANUP COLORQUARTERBITMAP COLORSIGLOGO COLORSTRAWBERRYBITMAP DOT ENERGIZER ENERGIZEROBJ EYESBITMAP FOLLOW FRUIT# FRUITLIST FRUITTIME FRUITVISIBLE G1 G1BITMAP G2 G2BITMAP G3 G3BITMAP G4 G4BITMAP GINVBITMAP GVALUE GVALUEBITMAPLIST GVALUEPOS HASDOT HILIST HINAMES HIVALUES KEYBITMAP LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY NAME NETP NEXTMOVE NUMDOTS NUMMEN OLDG1 OLDG2 OLDG3 OLDG4 OLDPMAN ORANGEBITMAP PMANINPUTMODE PACMANC PACMANCMAP PACMANINCOLOR PACMANVERSION PINEAPPLEBITMAP PIT PMANDOWN PMANDOWNMAP PMANLEFT PMANLEFTMAP PMANRIGHT PMANRIGHTMAP PMANUP PMANUPMAP PMGAMEOVER PMOLDCOLORMAP PMWANTMORE PSTREAM PWINDOW QUARTERBITMAP SAVEGVALUE SCORE SIGLOGO STRAWBERRYBITMAP VIRGINBOARD) ) ) (PUTPROPS PACMAN COPYRIGHT ("Xerox Corporation" 1984 1985 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6098 83833 (ASSIGNDIR 6108 . 7285) (BLINKENERGIZERS 7287 . 8060) (PLAYERBOARDVAL 8062 . 8529) (BOARDVAL 8531 . 8682) (CHECKAT 8684 . 8857) (COLLISIONCHECK 8859 . 14228) (DECIDE 14230 . 17019) (DOTCHECK 17021 . 17635) (DRAWBOARD 17637 . 19204) (DRAWBOARDNEW 19206 . 20904) (ENERGIZERCHECK 20906 . 21522) (ERASEOBJ 21524 . 21716) (FRUITCHECK 21718 . 23358) (FRUITINIT 23360 . 25095) ( GETHISCORES 25097 . 26175) (GETMONEY 26177 . 27987) (GETMOVE 27989 . 32338) (VOICEINPUT 32340 . 32521) (XLOCTOSCREEN 32523 . 32873) (XSCREENTOLOC 32875 . 33221) (YLOCTOSCREEN 33223 . 33589) (YSCREENTOLOC 33591 . 33969) (HISCORE 33971 . 34891) (INCOLORQ 34893 . 35690) (INPUTMODEQ 35692 . 37111) ( HASCOLORDISPLAYP 37113 . 37696) (INTERMISSION1 37698 . 40635) (ISIGN 40637 . 41138) (JOYSTICK 41140 . 41686) (LOSE 41688 . 42768) (MOVEDOWN 42770 . 43447) (MOVEGHOST 43449 . 48028) (MOVELEFT 48030 . 48709 ) (MOVEOBJ 48711 . 48897) (MOVEPACMAN 48899 . 51299) (MOVERIGHT 51301 . 51980) (MOVEUP 51982 . 52657) (NEWHISCORES 52659 . 53384) (PACINTRO 53386 . 55391) (PACMAN 55393 . 61110) (PACMANINIT 61112 . 64127) (PACMANINITNEW 64129 . 66345) (PACMANNEWGAME 66347 . 66739) (PACMANREINIT 66741 . 70580) (PAINTOBJ 70582 . 70803) (PAINTDOT 70805 . 70969) (PUTDOTS 70971 . 73776) (PUTDOTSAGAIN 73778 . 74758) ( PUTENERGIZERS 74760 . 75317) (REDODOT 75319 . 76114) (REPLACEOBJ 76116 . 76283) (SCAN 76285 . 76764) ( SETBITMAPS 76766 . 78035) (SETBOARDVAL 78037 . 78215) (SETCHARPROPS 78217 . 80551) (SETGCANS 80553 . 80754) (SETGLOCS 80756 . 81756) (SETPLAYERBOARDVAL 81758 . 82073) (SHOW 82075 . 82252) (SHOWCAP 82254 . 82410) (SHOWHISCORES 82412 . 82934) (SPEEDQ 82936 . 83831))))) STOP \ No newline at end of file diff --git a/lispusers/PACMAN.TEDIT b/lispusers/PACMAN.TEDIT new file mode 100644 index 00000000..7dd2754d Binary files /dev/null and b/lispusers/PACMAN.TEDIT differ diff --git a/lispusers/PAGEHOLD b/lispusers/PAGEHOLD new file mode 100644 index 00000000..c3b4c8ca --- /dev/null +++ b/lispusers/PAGEHOLD @@ -0,0 +1 @@ +(FILECREATED " 8-Jul-86 17:40:07" {ERIS}LISPCORE>PAGEHOLD.;3 31304 changes to: (VARS PAGEHOLDCOMS) (MACROS CTRLREALLYDOWN?) (FNS END.OF.PAGE.HOLD \EOP.DO.BUTTON) previous date: "15-Apr-86 11:21:20" {ERIS}LISPCORE>PAGEHOLD.;1) (* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PAGEHOLDCOMS) (RPAQQ PAGEHOLDCOMS ((COMS (* "Parameters adjustable by user.") [INITVARS (PAGE.WAIT.SECONDS 20) (PAGE.WAIT.ACTIVITY (QUOTE WINKING)) (PAGE.WAIT.IGNORETYPEAHEAD NIL) (PAGE.WAIT.FONT (FONTCREATE (QUOTE HELVETICA) 12)) (PAGE.WAIT.HOLDMSG (QUOTE (" -- SHIFT to hold typeout -- " 198))) (PAGE.WAIT.RELEASEMSG (QUOTE (" -- Release SHIFT for more -- " 215))) (PAGE.WAIT.STOPMSG (QUOTE (" -- Scrolling Stopped -- " 169] (GLOBALVARS PAGE.WAIT.SECONDS PAGE.WAIT.ACTIVITY PAGE.WAIT.IGNORETYPEAHEAD PAGE.WAIT.FONT PAGE.WAIT.HOLDMSG PAGE.WAIT.RELEASEMSG PAGE.WAIT.STOPMSG)) (DECLARE: DONTCOPY (MACROS TYPEAHEADP CTRLREALLYDOWN?) (RECORDS PAGEHOLDBUTTON PAGEHOLDMSG)) [VARS (HoldingButtonMenu NIL) (HoldButtonBottomLine (FONTDESCENT PAGE.WAIT.FONT)) (TitleBarHeight (FONTHEIGHT (DSPFONT NIL WindowTitleDisplayStream] (GLOBALVARS HoldingButtonMenu HoldButtonBottomLine TitleBarHeight) (FNS END.OF.PAGE.HOLD \EOP.DO.BUTTON \PageHold.printMessage \PageHold.buttonEventFn \PageHold.doMenu) (COMS (* "Items related to the PAGEHOLDBUTTON resource") (DECLARE: DONTCOPY (RESOURCES PAGEHOLDBUTTON)) (INITRESOURCES PAGEHOLDBUTTON) (FNS MakePageHoldButton \PageHold.GET) (GLOBALVARS \PAGEHOLDBUTTONS)) [DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE PAGEFULLFN) (QUOTE OLDPAGEFULLFN) NIL T) (/MOVD (QUOTE END.OF.PAGE.HOLD) (QUOTE PAGEFULLFN] (LOCALVARS . T))) (* "Parameters adjustable by user.") (RPAQ? PAGE.WAIT.SECONDS 20) (RPAQ? PAGE.WAIT.ACTIVITY (QUOTE WINKING)) (RPAQ? PAGE.WAIT.IGNORETYPEAHEAD NIL) (RPAQ? PAGE.WAIT.FONT (FONTCREATE (QUOTE HELVETICA) 12)) (RPAQ? PAGE.WAIT.HOLDMSG (QUOTE (" -- SHIFT to hold typeout -- " 198))) (RPAQ? PAGE.WAIT.RELEASEMSG (QUOTE (" -- Release SHIFT for more -- " 215))) (RPAQ? PAGE.WAIT.STOPMSG (QUOTE (" -- Scrolling Stopped -- " 169))) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PAGE.WAIT.SECONDS PAGE.WAIT.ACTIVITY PAGE.WAIT.IGNORETYPEAHEAD PAGE.WAIT.FONT PAGE.WAIT.HOLDMSG PAGE.WAIT.RELEASEMSG PAGE.WAIT.STOPMSG) ) (DECLARE: DONTCOPY (DECLARE: EVAL@COMPILE [PUTPROPS TYPEAHEADP MACRO (NIL (AND (NOT PAGE.WAIT.IGNORETYPEAHEAD) (READP T] [PUTPROPS CTRLREALLYDOWN? MACRO ((N) (AND (SHIFTDOWNP (QUOTE CTRL)) (PROGN (* Consider it a spazz if he didn't keep the CTRL key down for at least N milliseconds) (DISMISS N NIL T) (SHIFTDOWNP (QUOTE CTRL] ) [DECLARE: EVAL@COMPILE (RECORD PAGEHOLDBUTTON (TIMERS ACTIVITY BUTTONIMAGE PAGEHOLDBUTTONWIDTH)) (RECORD PAGEHOLDMSG (MSG WIDTH)) ] ) (RPAQQ HoldingButtonMenu NIL) (RPAQ HoldButtonBottomLine (FONTDESCENT PAGE.WAIT.FONT)) (RPAQ TitleBarHeight (FONTHEIGHT (DSPFONT NIL WindowTitleDisplayStream))) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HoldingButtonMenu HoldButtonBottomLine TitleBarHeight) ) (DEFINEQ (END.OF.PAGE.HOLD [LAMBDA (STREAM) (* bvm: " 8-Jul-86 12:41") (LET* ([WINDOW (WFROMDS (COND ((NULL STREAM) (TTYDISPLAYSTREAM)) (T (\DTEST STREAM (QUOTE STREAM] (WAIT.SECS (OR (WINDOWPROP WINDOW (QUOTE PAGE.WAIT.SECONDS)) PAGE.WAIT.SECONDS))) (COND ((OR (NULL WAIT.SECS) (AND (NOT (FIXP WAIT.SECS)) (NEQ WAIT.SECS (QUOTE STOP))) (EQ (DSPSCROLL NIL WINDOW) (QUOTE OFF))) (* If we're losing because of an  invalid value in PAGE.WAIT.SECONDS  then try to fix it up.) (COND ((NULL (WINDOWPROP WINDOW (QUOTE PAGE.WAIT.SECONDS))) (SETQ PAGE.WAIT.SECONDS 0))) T) ((AND (NOT (SHIFTDOWNP (QUOTE SHIFT))) (NEQ WAIT.SECS (QUOTE STOP)) (OR (ILESSP WAIT.SECS 1) (CTRLREALLYDOWN? 125) (TYPEAHEADP))) (* Immediate release case) T) (T (\EOP.DO.BUTTON STREAM WINDOW WAIT.SECS]) (\EOP.DO.BUTTON [LAMBDA (STREAM WINDOW WAIT.SECS) (* bvm: " 8-Jul-86 12:49") (RESETLST (* A RESETLST so that the button can  be forced down, regardless of how  things got exited) (LET* ((CURRENTBUTTON (GETRESOURCE PAGEHOLDBUTTON (OR (WINDOWPROP WINDOW (QUOTE PAGE.WAIT.ACTIVITY )) PAGE.WAIT.ACTIVITY))) (BORDERSIZE (OR (FIXP (WINDOWPROP WINDOW (QUOTE BORDER))) 0)) (REG (WINDOWPROP WINDOW (QUOTE REGION))) (LEFT (IDIFFERENCE (IDIFFERENCE (fetch (REGION PRIGHT) of REG) BORDERSIZE) (fetch PAGEHOLDBUTTONWIDTH of CURRENTBUTTON))) (BOTTOM (IDIFFERENCE (fetch (REGION PTOP) of REG) (IPLUS TitleBarHeight BORDERSIZE))) (BUTTON.WINDOW (fetch BUTTONIMAGE of CURRENTBUTTON))) [COND ((IGREATERP LEFT (IDIFFERENCE SCREENWIDTH 25)) (* If the right edge of the window is  almost off the screen then put the  "button" on the left side.) (SETQ LEFT (IPLUS BORDERSIZE (fetch (REGION LEFT) of REG] [COND ((IGREATERP BOTTOM (IDIFFERENCE SCREENHEIGHT 12)) (* If the top of the window is almost  off the screen then put the "button"  on the bottom.) (SETQ BOTTOM (IPLUS BORDERSIZE (IDIFFERENCE (fetch (REGION BOTTOM) of REG) (WINDOWPROP (fetch BUTTONIMAGE of CURRENTBUTTON) (QUOTE HEIGHT] (PROG ((INFINITY MAX.FIXP) (BUTTON.WINDOW (fetch BUTTONIMAGE of CURRENTBUTTON)) (ACTIVITY (fetch ACTIVITY of CURRENTBUTTON)) (FIRSTIMEP T) (MESSAGESTATE 1) FLASHINTERVAL MESSAGESTATEINIT STOPFLG INDEFINITEHOLD HOLDPROP WAITTIMER FLASHTIMER MENUSIGNAL TIMERSLST) (WINDOWPROP BUTTON.WINDOW (QUOTE END.OF.PAGE.HOLD) T) (MOVEW BUTTON.WINDOW LEFT BOTTOM) (DSPRESET BUTTON.WINDOW) [RESETSAVE (PROGN BUTTON.WINDOW) (QUOTE (AND (WINDOWP OLDVALUE) (CLOSEW OLDVALUE] (OPENW BUTTON.WINDOW) INITIALIZETIMERS (SETQ TIMERSLST (fetch TIMERS of CURRENTBUTTON)) (SETQ FLASHTIMER (SETUPTIMER 0 (pop TIMERSLST) (QUOTE TICKS))) [SETQ FLASHINTERVAL (COND [(EQ ACTIVITY (QUOTE FLASHING)) (SETQ MESSAGESTATEINIT 4) (SELECTC \MACHINETYPE (\DANDELION (CONSTANT (TIMES 1250 \DLION.RCLKMILLISECOND ))) (CONSTANT (TIMES 1250 \ALTO.RCLKMILLISECOND] (T (* So it's WINKING or NIL) (SETQ MESSAGESTATEINIT 2) (SELECTC \MACHINETYPE (\DANDELION (CONSTANT (TIMES 750 \DLION.RCLKMILLISECOND ))) (CONSTANT (TIMES 750 \ALTO.RCLKMILLISECOND] [SETQ WAITTIMER (COND ((EQ WAIT.SECS (QUOTE STOP)) (* Initialization done in case a menu  selection changes state) (SETQ FIRSTIMEP (SETQ STOPFLG T)) (SETQ MESSAGESTATE (SETQ MESSAGESTATEINIT 1)) NIL) (T (SETQ STOPFLG) (SETUPTIMER WAIT.SECS (pop TIMERSLST) (QUOTE SECONDS] (AND INDEFINITEHOLD (BLOCK 375)) LOOP [COND (FLASHTIMER (COND ((AND (SHIFTDOWNP (QUOTE SHIFT)) (OR (NULL INDEFINITEHOLD) (TIMEREXPIRED? INDEFINITEHOLD (QUOTE SECONDS))) (NOT STOPFLG))(* Lock in on holding message while  SHIFT is down) (DSPRESET BUTTON.WINDOW) (\PageHold.printMessage CURRENTBUTTON T PAGE.WAIT.RELEASEMSG) (SETQ WAITTIMER (SETQ FLASHTIMER))) ((TIMEREXPIRED? FLASHTIMER (QUOTE TICKS)) (COND [(OR FIRSTIMEP (AND ACTIVITY (NOT STOPFLG))) (SETQ FIRSTIMEP) (COND ((ILEQ (add MESSAGESTATE -1) 0) (\PageHold.printMessage CURRENTBUTTON T (COND (STOPFLG PAGE.WAIT.STOPMSG) (T PAGE.WAIT.RELEASEMSG))) (SETQ MESSAGESTATE MESSAGESTATEINIT)) (INDEFINITEHOLD (DSPRESET BUTTON.WINDOW)) (T (SELECTQ ACTIVITY (WINKING (\PageHold.printMessage CURRENTBUTTON NIL PAGE.WAIT.HOLDMSG)) (FLASHING [COND ((ODDP MESSAGESTATE) (DSPRESET BUTTON.WINDOW)) (T (\PageHold.printMessage CURRENTBUTTON NIL (COND ((IGEQ MESSAGESTATE 2) PAGE.WAIT.HOLDMSG) (T PAGE.WAIT.RELEASEMSG]) NIL] (T (* Make sure the button continues to  be visible, even when there is no  activity) (TOTOPW BUTTON.WINDOW))) (SETQ FLASHTIMER (SETUPTIMER FLASHINTERVAL FLASHTIMER (QUOTE TICKS] (BLOCK) [SELECTQ (SETQ HOLDPROP (WINDOWPROP BUTTON.WINDOW (QUOTE END.OF.PAGE.HOLD))) ((NIL END.OF.PAGE.HOLD) (* Release by simple LEFT mousing) (RETURN T)) ((MENU) (* Aha, some intervention via MENU so  first restore the windowprop to the  "waiting" state.) (WINDOWPROP BUTTON.WINDOW (QUOTE END.OF.PAGE.HOLD) T) (SELECTQ (SETQ MENUSIGNAL (\PageHold.doMenu)) (END.OF.PAGE.HOLD (RETURN T)) (PAGE.WAIT.SECONDS (FRESHLINE PROMPTWINDOW) (SETQ WAIT.SECS (MKATOM (PROMPTFORWORD "Default holding timelimit for this window = " WAIT.SECS NIL PROMPTWINDOW NIL 30))) (COND ((NUMBERP WAIT.SECS) (SETQ WAIT.SECS (FIX WAIT.SECS))) ((EQ WAIT.SECS (QUOTE STOP))) (T (SETQ WAIT.SECS))) (WINDOWPROP WINDOW (QUOTE PAGE.WAIT.SECONDS) WAIT.SECS) (SELECTQ WAIT.SECS (0 (RETURN T)) (NIL (SETQ WAIT.SECS PAGE.WAIT.SECONDS)) NIL) (GO INITIALIZETIMERS)) ((0 INFINITY DEFAULT STOP) (SETQ WAIT.SECS (SELECTQ MENUSIGNAL (0 0) (INFINITY INFINITY) (DEFAULT PAGE.WAIT.SECONDS) (STOP (QUOTE STOP)) NIL)) (FLASHWINDOW WINDOW) (PROMPTPRINT "Setting Default timelimit for this window to " MENUSIGNAL) (WINDOWPROP WINDOW (QUOTE PAGE.WAIT.SECONDS) (AND (NEQ MENUSIGNAL (QUOTE DEFAULT)) WAIT.SECS)) (COND ((EQ 0 WAIT.SECS) (RETURN)) (T (GO INITIALIZETIMERS)))) (T (GO SETUPINDEFINITEHOLD)) (PAGE.WAIT.STOPMSG (SETQ WAIT.SECS (QUOTE STOP)) (GO INITIALIZETIMERS)) NIL)) (COND ((TYPEAHEADP) (* Flush the character he typed to  "release") (\GETKEY) (RETURN)) ((AND (NOT STOPFLG) (CTRLREALLYDOWN? 125)) (COND ((NOT (SHIFTDOWNP (QUOTE SHIFT))) (* If only the CTRL key is down, then  immediate release.) (RETURN)) ((OR (NULL INDEFINITEHOLD) (TIMEREXPIRED? INDEFINITEHOLD (QUOTE SECONDS))) (GO SETUPINDEFINITEHOLD] (COND ((AND WAITTIMER (TIMEREXPIRED? WAITTIMER (QUOTE SECONDS))) (SETQ WAITTIMER))) (COND ([AND (NOT STOPFLG) (NULL WAITTIMER) (NOT (SHIFTDOWNP (QUOTE SHIFT] (* Basic return from timeout, where no  holding action is present) (RETURN T))) (GO LOOP) SETUPINDEFINITEHOLD (SETQ WAIT.SECS INFINITY) (SETQ INDEFINITEHOLD (SETUPTIMER 5 (OR INDEFINITEHOLD (pop TIMERSLST)) (QUOTE SECONDS))) (GO INITIALIZETIMERS)) (FREERESOURCE PAGEHOLDBUTTON CURRENTBUTTON) T]) (\PageHold.printMessage [LAMBDA (PAGEHOLDBUTTON BOTTOMP MSG) (* JonL " 1-Dec-84 17:03") (DECLARE (GLOBALVARS HoldButtonBottomLine)) (LET ((BUTTON.WINDOW (fetch BUTTONIMAGE of PAGEHOLDBUTTON))) (DSPRESET BUTTON.WINDOW) (if BOTTOMP then (DSPYPOSITION HoldButtonBottomLine BUTTON.WINDOW)) (DSPXPOSITION (LRSH (DIFFERENCE (fetch PAGEHOLDBUTTONWIDTH of PAGEHOLDBUTTON) (fetch (PAGEHOLDMSG WIDTH) of MSG)) 1) BUTTON.WINDOW) (PRIN3 (fetch (PAGEHOLDMSG MSG) of MSG) BUTTON.WINDOW]) (\PageHold.buttonEventFn [LAMBDA (W) (* JonL " 5-Oct-84 23:54") (WINDOWPROP W (QUOTE END.OF.PAGE.HOLD) (if (LASTMOUSESTATE MIDDLE) then (QUOTE MENU) elseif (LASTMOUSESTATE LEFT) then (QUOTE END.OF.PAGE.HOLD) else]) (\PageHold.doMenu [LAMBDA NIL (* JonL " 6-Oct-84 18:28") (MENU (OR HoldingButtonMenu (SETQ HoldingButtonMenu (create MENU ITEMS _ (QUOTE (( "set Window Wait to read-in" (QUOTE PAGE.WAIT.SECONDS ) "Window gets new PAGE.WAIT.SECS property from type-in." ) ( "set Window Wait to infinity" (QUOTE INFINITY) "Set Window's PAGE.WAIT.SECS prop to infinity" ) ( "set Window Wait to 0" 0 "Set Window's PAGE.WAIT.SECS prop to 0" ) ( "use default Wait value" (QUOTE DEFAULT) "Remove Window's PAGE.WAIT.SECS property" ) ( "set Window Wait to 'stop'" (QUOTE T) "Set Window's PAGE.WAIT.SECS prop for 'stopping' mode" ) ( "Keep this hold indefinitely" (QUOTE T) "Go into indefinite hold mode" ) ("simple 'stop' now" (QUOTE HoldMessage.stop ) "Puts current hold into 'stopped' state" ) ("Release this hold!" (QUOTE END.OF.PAGE.HOLD ) "Simple release from holding" ))) MENUBORDERSIZE _ 1 TITLE _ "Window Wait Options"]) ) (* "Items related to the PAGEHOLDBUTTON resource") (DECLARE: DONTCOPY (DECLARE: EVAL@COMPILE [PUTDEF (QUOTE PAGEHOLDBUTTON) (QUOTE RESOURCES) (QUOTE (NEW (MakePageHoldButton . ARGS) FREE (RPLACA (OR (find L on (CDR \PAGEHOLDBUTTONS) suchthat (NULL (CAR L))) (LAST (NCONC1 \PAGEHOLDBUTTONS NIL))) (PROG1 . ARGS)) GET (\PageHold.GET . ARGS) INIT (/SETTOPVAL (QUOTE \PAGEHOLDBUTTONS) (LIST NIL] ) ) (/SETTOPVAL (QUOTE \PAGEHOLDBUTTONS) (LIST NIL)) (DEFINEQ (MakePageHoldButton [LAMBDA (ACTIVITY) (* JonL " 1-Dec-84 17:04") (PROG ((BORDERSIZE (SELECTQ (OR ACTIVITY PAGE.WAIT.ACTIVITY) ((WINKING) 8) ((FLASHING) 2) ((NIL) 0) (PROGN (if ACTIVITY then (\ILLEGAL.ARG ACTIVITY)) (* Patch up the global variable) (SETQ PAGE.WAIT.ACTIVITY) 0))) (MOREWIDTH (STRINGWIDTH (fetch (PAGEHOLDMSG MSG) of PAGE.WAIT.HOLDMSG) PAGE.WAIT.FONT)) (HOLDINGWIDTH (STRINGWIDTH (fetch (PAGEHOLDMSG MSG) of PAGE.WAIT.RELEASEMSG) PAGE.WAIT.FONT)) (HoldMessageAdjustment 4) WINDOW HoldingButtonWidth) (OR ACTIVITY (SETQ ACTIVITY PAGE.WAIT.ACTIVITY)) (SETQ HoldingButtonWidth (WIDTHIFWINDOW (IPLUS HoldMessageAdjustment HOLDINGWIDTH HoldMessageAdjustment) BORDERSIZE)) (SETQ WINDOW (CREATEW (create REGION WIDTH _ HoldingButtonWidth HEIGHT _ (HEIGHTIFWINDOW (TIMES (SELECTQ ACTIVITY (WINKING 2) 1) (FONTHEIGHT PAGE.WAIT.FONT)) NIL BORDERSIZE)) NIL BORDERSIZE T)) (DSPFONT PAGE.WAIT.FONT WINDOW) (DSPTEXTURE GRAYSHADE WINDOW) (WINDOWPROP WINDOW (QUOTE SHRINKFN) (QUOTE DON'T)) (WINDOWPROP WINDOW (QUOTE RESHAPEFN) (QUOTE DON'T)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (QUOTE \PageHold.buttonEventFn)) (WINDOWPROP WINDOW (QUOTE END.OF.PAGE.HOLD) T) (RETURN (create PAGEHOLDBUTTON TIMERS _ (to 3 collect (SETUPTIMER 0)) ACTIVITY _ ACTIVITY BUTTONIMAGE _ WINDOW PAGEHOLDBUTTONWIDTH _ (WINDOWPROP WINDOW (QUOTE WIDTH]) (\PageHold.GET [LAMBDA (ACTIVITY) (* JonL "12-Nov-84 20:28") (OR [for L on (PROG1 (CDR \PAGEHOLDBUTTONS) (* Comment PPLossage) ) when (EQ ACTIVITY (fetch (PAGEHOLDBUTTON ACTIVITY) of (CAR L))) do (RETURN (PROG1 (CAR L) (RPLACA L NIL] (NEWRESOURCE PAGEHOLDBUTTON ACTIVITY]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PAGEHOLDBUTTONS) ) (DECLARE: DONTEVAL@LOAD DOCOPY (MOVD? (QUOTE PAGEFULLFN) (QUOTE OLDPAGEFULLFN) NIL T) (/MOVD (QUOTE END.OF.PAGE.HOLD) (QUOTE PAGEFULLFN)) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS PAGEHOLD COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (4517 27056 (END.OF.PAGE.HOLD 4527 . 5958) (\EOP.DO.BUTTON 5960 . 20975) ( \PageHold.printMessage 20977 . 21684) (\PageHold.buttonEventFn 21686 . 22052) (\PageHold.doMenu 22054 . 27054)) (27804 30923 (MakePageHoldButton 27814 . 30475) (\PageHold.GET 30477 . 30921))))) STOP \ No newline at end of file diff --git a/lispusers/PAGEHOLD.TEDIT b/lispusers/PAGEHOLD.TEDIT new file mode 100644 index 00000000..08089818 Binary files /dev/null and b/lispusers/PAGEHOLD.TEDIT differ diff --git a/lispusers/PARSER b/lispusers/PARSER new file mode 100644 index 00000000..1f178a4c --- /dev/null +++ b/lispusers/PARSER @@ -0,0 +1 @@ +(FILECREATED "17-Apr-86 16:28:32" {PHYLUM}PARSER>RELEASE.1>PARSER.;10 70376 changes to: (FNS PG.BACKUP PG.RESOLVE PG.BUILD.LOOKAHEAD.SETS PG.CODE.PARSER) previous date: " 4-Apr-86 16:29:22" {PHYLUM}PARSER>RELEASE.1>PARSER.;7) (* Copyright (c) 1983, 1984, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PARSERCOMS) (RPAQQ PARSERCOMS ((* * Parser generation system.) (FNS MAKEPARSER PG.INITIALIZE.GRAMMAR) (RECORDS PARSERSPEC GRAMMAR) (DECLARE: EVAL@COMPILE DONTCOPY (RECORDS FPRODUCTION ALTERNATIVE)) (MACROS SELF STRICTEOF TCONC.FRONT) (* * State machine generation. For an explanation of the parser technology, see "Theory & Construction of LR(k) Parsers" (Preliminary Version) , Benjamin M. Brosgol, Center for Research in Computing Technology, Harvard University, March 1973) (FNS PG.LR0FSM PG.AFSMS PG.ROOTPRODUCTION PG.AFSM.ADDPROD PG.CONNECT PG.ADD.ARC PG.DETERMINISTIC PG.DETERMINISTIC1 PG.CONNECT.AFSMS PG.CONNECT.AFSMS1 PG.SINGLETON PG.CONNECTED PG.OWNS.LINKS PG.RABIN.SCOTT PG.RABIN.SCOTT1 PG.REPLACEMENT PG.TRANSITION.SYMBOLS PG.NEXT.STATES PG.COMPOSITE.STATE.NAME PG.DISCONNECT PG.NONTERMINALP PG.TERMINALP) (FNS PG.LALRKFSM PG.BUILD.BackLinks PG.CONNECT.BACK PG.STATETYPE PG.RESOLVE PG.PRINT.INADEQUATE PG.BUILD.LOOKAHEAD.SETS PG.DISJOINT PG.LLA PG.LLA.LOOKAHEAD PG.LLA.READ PG.LLA.REDUCE PG.BACKUP PG.LOOKAHEAD.SOURCE PG.REDUCE.TARGET PG.LOOKAHEADP) (FNS PG.OLD.LLA) (DECLARE: EVAL@COMPILE DONTCOPY (RECORDS PRODUCTION FSM STATE LINK)) (INITRECORDS PRODUCTION FSM STATE LINK) (FNS PG.SMASH.FSM) (FNS PG.PPL PG.PPM PG.PPP PG.PPS) (FNS PG.STATES PG.STATES1 PG.STATE.ORDER) (* * Lisp code generation) (FNS PG.CODE.PARSER PG.CODE.STATES) (FNS PG.CODE.LOOKAHEAD PG.CODE.LOOKAHEAD.ALL.TOKENS PG.CODE.LOOKAHEAD.TOKEN PG.CODE.LOOKAHEAD.SWITCH PG.CODE.LOOKAHEAD.MATCH) (FNS PG.CODE.READ PG.CODE.READ.TOKEN PG.CODE.READ.SWITCH) (FNS PG.CODE.REDUCE PG.CODE.REDUCE.STACKS PG.CODE.REDUCE.SWITCH) (* * Other) (FNS PRINT.FUNCTION))) (* * Parser generation system.) (DEFINEQ (MAKEPARSER [LAMBDA (PARSERSPEC SORTED?) (* hts: " 3-Apr-86 16:20") (* * Constructs a parser according to PARSERSPEC) (LET ((GRAMMAR (fetch GRAMMAR of PARSERSPEC)) (NAME (fetch PARSERNAME of PARSERSPEC))) (PG.INITIALIZE.GRAMMAR GRAMMAR) (LET [(M (PG.LALRKFSM (PG.LR0FSM GRAMMAR] (/PUTD NAME (PG.CODE.PARSER M PARSERSPEC SORTED?)) (PG.SMASH.FSM M)) NAME]) (PG.INITIALIZE.GRAMMAR [LAMBDA (G) (* hts: "28-Feb-86 17:45") (* * Builds the SymbolTable for GRAMMAR G. The SymbolTable is a hashtable which maps each symbol in the alphabet of grammar G onto {NONTERMINAL, TERMINAL}. Also checks the grammar for syntactic correctness) (LET ((PRODS (fetch PRODUCTIONS of G)) (TABLE (fetch (GRAMMAR SymbolTable) of G))) (* * Note the nonterminals) (CLRHASH TABLE) (for P in PRODS do (if (NOT (type? FPRODUCTION P)) then (ERROR "Improper grammar format")) (PUTHASH (fetch LEFTHAND of P) (QUOTE NONTERMINAL) TABLE)) (* * Note the terminals) [for P in PRODS do (for A in (fetch ALTERNATIVES of P) do (if (NOT (type? ALTERNATIVE A)) then (ERROR "Improper grammar format")) (for SYMBOL in (fetch RULE of A) do (if (NOT (ATOM SYMBOL)) then (ERROR "Improper grammar format")) (if (NULL (GETHASH SYMBOL TABLE)) then (PUTHASH SYMBOL (QUOTE TERMINAL) TABLE))] (PUTHASH (QUOTE EOF) (QUOTE TERMINAL) TABLE) G]) ) [DECLARE: EVAL@COMPILE (DATATYPE PARSERSPEC (PARSERNAME (* name to be given to parser) GRAMMAR (* specifies language to be parsed) READFN (* called to read next token) CLASSFN (* called to determine class of a token) INSTANCEFN (* called to determine instance of a token) EOFFN (* called to verify that token read may be interpreted as EOF) STACKINITFN (* initializes empty stacks) PUSHFN (* push method for stacks) POPFN (* pop method for stacks) TOPFN (* tells what's on top of the stack) LAQUEUEINITFN (* initializes main lookahead queue) QUEUEINITFN (* initializes empty temp lookahead queue) ENQUEUEFN (* enqueueing method for queues) DEQUEUEFN (* dequeueing method for queues) QUEUENOTEMPTYFN (* tells if queue is empty) SAVESTATEFN (* bundles up state to be saved) ) CLASSFN _ (QUOTE SELF) INSTANCEFN _ (QUOTE SELF) EOFFN _ (QUOTE STRICTEOF) STACKINITFN _ (QUOTE NILL) PUSHFN _ (QUOTE push) POPFN _ (QUOTE pop) TOPFN _ (QUOTE CAR) LAQUEUEINITFN _ (QUOTE SELF) QUEUEINITFN _ (QUOTE CONS) ENQUEUEFN _ (QUOTE TCONC) DEQUEUEFN _ (QUOTE TCONC.FRONT) QUEUENOTEMPTYFN _ (QUOTE CDR) SAVESTATEFN _ (QUOTE SELF)) (DATATYPE GRAMMAR (StartSymbol (* the atom which is the start symbol) PRODUCTIONS (* rules; should be a list of FPRODUCTIONs) SymbolTable (* hasharray which tells class of symbols) ) SymbolTable _ (HASHARRAY 33)) ] (/DECLAREDATATYPE (QUOTE PARSERSPEC) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PARSERSPEC 0 POINTER) (PARSERSPEC 2 POINTER) (PARSERSPEC 4 POINTER) (PARSERSPEC 6 POINTER) (PARSERSPEC 8 POINTER) (PARSERSPEC 10 POINTER) (PARSERSPEC 12 POINTER) (PARSERSPEC 14 POINTER) (PARSERSPEC 16 POINTER) (PARSERSPEC 18 POINTER) (PARSERSPEC 20 POINTER) (PARSERSPEC 22 POINTER) (PARSERSPEC 24 POINTER) (PARSERSPEC 26 POINTER) (PARSERSPEC 28 POINTER) (PARSERSPEC 30 POINTER))) (QUOTE 32)) (/DECLAREDATATYPE (QUOTE GRAMMAR) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((GRAMMAR 0 POINTER) (GRAMMAR 2 POINTER) (GRAMMAR 4 POINTER))) (QUOTE 6)) (DECLARE: EVAL@COMPILE DONTCOPY [DECLARE: EVAL@COMPILE (RECORD FPRODUCTION (LEFTHAND . ALTERNATIVES) (* * LEFTHAND is the left-hand side of the rule; ALTERNATIVES is a list of ALTERNATIVEs, which are alternative  right-hand sides) [TYPE? (AND (LISTP DATUM) (LITATOM (fetch LEFTHAND of DATUM)) (LISTP (fetch ALTERNATIVES of DATUM]) (RECORD ALTERNATIVE (RULE AUGMENT) [TYPE? (AND (LISTP DATUM) (EQ 2 (LENGTH DATUM]) ] ) (DECLARE: EVAL@COMPILE (PUTPROPS SELF MACRO ((A B) A)) [PUTPROPS STRICTEOF MACRO ((CLASS) (EQ CLASS (QUOTE EOF] [PUTPROPS TCONC.FRONT MACRO (LAMBDA (PTR) (* Removes and returns the first element of a TCONC list; returns NIL if empty.) (PROG1 (CAAR PTR) (* Return the first element.) (if (EQ (CAR PTR) (CDR PTR)) then (* * If there is only one element in the list, the pointer to the tail of the list must be set to NIL. If the list is empty, this will be a no-op.) (RPLACA PTR NIL) (RPLACD PTR NIL) else (* * Otherwise remove the first element of the list (for n elements in list, n>=1.)) (RPLACA PTR (CDAR PTR)))] ) (* * State machine generation. For an explanation of the parser technology, see "Theory & Construction of LR(k) Parsers" (Preliminary Version) , Benjamin M. Brosgol, Center for Research in Computing Technology, Harvard University, March 1973) (DEFINEQ (PG.LR0FSM [LAMBDA (G) (* hts: " 3-Apr-86 16:08") (* * Builds and returns the "LR(0)-FSM" of grammar G.) (BLOCK) (* * First build the "[A]-FSM" for each production in the grammar, and save them in the list NTSL  (whose CAR will be the start state of the root production of the grammar)) (LET ((NTSL (PG.AFSMS G))) (* * Connect the "[A]-FSMs" together. This is the so-called dotted-linking and -unlinking stage.) (LET [(M (PG.CONNECT.AFSMS NTSL (fetch (GRAMMAR SymbolTable) of G] (* * Using the Rabin-Scott algorithm, remove nondeterminism from the FSM.) (PG.RABIN.SCOTT M]) (PG.AFSMS [LAMBDA (G) (* hts: " 3-Apr-86 16:08") (* * Constructs the "[A]-FSM" for each non terminal by linking the productions together as single strand transition nets. Returns a list of their start states, with the start state of the root production as the first element of  that list.) (* * Details: There is a single final state, FINAL, that all the "[A]-FSMs" share. The start states should be  accumulated in order so that the "LR(0)-FSM" and machines built from it will be more comprehensible to humans --  hence the use of TCONC. The hasharray mapping NAME.TO.START.STATE makes it faster to find the start state of the  "[A]-FSM" associated with a given nonterminal (faster than looking on the TCONC list). Finally, the "[A]-FSMs" had  better all be deterministic.) (BLOCK) (for P in (CONS (PG.ROOTPRODUCTION G) (fetch PRODUCTIONS of G)) bind START FINAL START.STATES NAME.TO.START.STATE first (SETQ FINAL (create STATE NAME _ (QUOTE FINAL))) (SETQ START.STATES (CONS)) (SETQ NAME.TO.START.STATE (HASHARRAY 33)) do (SETQ START (GETHASH (fetch LEFTHAND of P) NAME.TO.START.STATE)) (if (NOT (type? STATE START)) then (SETQ START (create STATE NAME _ (fetch LEFTHAND of P))) (TCONC START.STATES START) (PUTHASH (fetch LEFTHAND of P) START NAME.TO.START.STATE)) (for A in (fetch ALTERNATIVES of P) do (PG.AFSM.ADDPROD (create PRODUCTION LHS _ (fetch LEFTHAND of P) RHS _ (fetch RULE of A) AUGMENT _ (fetch (ALTERNATIVE AUGMENT) of A)) START FINAL)) finally (SETQ START.STATES (CAR START.STATES)) (* Get rid of TCONC cell) (if (NOT (for S in START.STATES always (PG.DETERMINISTIC S))) then (SHOULDNT "Nondeterminism")) (if (NEQ (QUOTE START) (fetch NAME of (CAR START.STATES))) then (SHOULDNT)) (RETURN START.STATES]) (PG.ROOTPRODUCTION [LAMBDA (G) (* hts: "28-Feb-86 17:45") (* * Generates and returns a production rule which can serve as the root production -- it worries with the problem  of EOF as terminating the parse.) (create FPRODUCTION LEFTHAND _ (QUOTE START) ALTERNATIVES _ (LIST (create ALTERNATIVE RULE _ (LIST (fetch StartSymbol of G) (QUOTE EOF)) AUGMENT _ NIL]) (PG.AFSM.ADDPROD [LAMBDA (PROD S FIN) (* hts: " 3-Apr-86 16:08") (if (NEQ (fetch NAME of S) (fetch LHS of PROD)) then (\ILLEGAL.ARG S)) (if (NOT (type? STATE FIN)) then (\ILLEGAL.ARG FIN)) (* * Adds the given production to S, creating new states if necessary, finally linking it in to the FINAL state. Builds new states in such a way as to ensure determinism.) (BLOCK) (for TOKEN in (fetch RHS of PROD) bind S2 L S3 first (SETQ S2 S) do (SETQ L (for L2 in (fetch OUT of S2) thereis (EQ (fetch SYM of L2) TOKEN))) (SETQ S2 (if (type? LINK L) then (CAR (fetch ST of L)) else (SETQ S3 (create STATE)) (PG.CONNECT S2 S3 TOKEN) S3)) finally (PG.CONNECT S2 FIN PROD)) S]) (PG.CONNECT [LAMBDA (FROM.STATE TO.STATE TRANSITION.SYMBOL) (* hts: " 3-Apr-86 16:08") (* * Connects FROM.STATE to TO.STATE with a transition labelled TRANSITION.SYMBOL) (BLOCK) (replace OUT of FROM.STATE with (PG.ADD.ARC (fetch OUT of FROM.STATE) TO.STATE TRANSITION.SYMBOL]) (PG.ADD.ARC [LAMBDA (LINKS TO.STATE TRANSITION.SYMBOL) (* hts: "28-Feb-86 14:48") (* * Augments the set of transitions LINKS by adding a transition via TRANSITION.SYMBOL to TO.STATE %. Returns the augmented transition sets. Note: tries to keep them in order of acquisition) (LET [(TRANSITION (for LINK in LINKS thereis (EQ (fetch SYM of LINK) TRANSITION.SYMBOL] (if (type? LINK TRANSITION) then (if (FMEMB TO.STATE (fetch ST of TRANSITION)) then (fetch ST of TRANSITION) else (push (fetch ST of TRANSITION) TO.STATE)) LINKS else (CONS (create LINK SYM _ TRANSITION.SYMBOL ST _ (LIST TO.STATE)) LINKS))]) (PG.DETERMINISTIC [LAMBDA (S) (* hts: " 3-Apr-86 16:08") (if (type? FSM S) then (SETQ S (fetch START of S))) (* * Returns T if S is a deterministic FSM, NIL otherwise. For a state to have deterministic transitions to the  next state, (a) there may not be more than one arc out with the same transition symbol, and  (b) there may not be more than one state reachable by any transition symbol. (* * Details: HASHARRAY glop is to  ensure you don't get into infinite loops because of cycles in the FSM. Could have implemented this by calling  STATES, but that would CONS a lot more and require essentially two traversals instead of one. Recursion shouldn't hurt because these FSMs are more bushy than they are deep.)) (BLOCK) (PG.DETERMINISTIC1 S (HASHARRAY 33]) (PG.DETERMINISTIC1 [LAMBDA (S DONE) (* hts: " 3-Apr-86 16:08") (* * Tells whether the submachine beginning at S is deterministic. See comments in DETERMINISTIC.) (OR (GETHASH S DONE) (PROGN (PUTHASH S T DONE) (for ARC in (fetch OUT of S) bind (SYMBOLS _ NIL) always (AND (PROG1 (NOT (FMEMB (fetch SYM of ARC) SYMBOLS)) (push SYMBOLS (fetch SYM of ARC))) (PG.SINGLETON (fetch ST of ARC)) (PG.DETERMINISTIC1 (CAR (fetch ST of ARC)) DONE]) (PG.CONNECT.AFSMS [LAMBDA (NTSL SYMBOL.TABLE) (* hts: " 3-Apr-86 17:46") (* * Interconnects all the "[A]-FSMs" This is the dotted linking and unlinking phase. NTSL is a list of start  states of the various "[A]-FSMs", with the overall start state first. SYMBOL.TABLE maps symbols onto {TERMINAL,  NONTERMINAL}.) (LET [(START (HASHARRAY (LENGTH NTSL))) (DONE (HASHARRAY (TIMES 5 (LENGTH NTSL] (* * Build a hasharray which implements a fast mapping: name of the nonterminal to which an "[A]-FSM" reduces ->  the start state of that "[A]-FSM") (for S in NTSL do (PUTHASH (fetch NAME of S) S START)) (* * Absorb to each state all the links of any machine which reduces to a nonterminal which the state is supposed  to read) (for S in (PG.STATES NTSL) do (PG.CONNECT.AFSMS1 S (LIST S) SYMBOL.TABLE START DONE)) (* * Check to make sure everything got connected up properly.) (PG.CONNECTED NTSL SYMBOL.TABLE START)) (* * Start state better be first in the list) (if (NEQ (QUOTE START) (fetch NAME of (CAR NTSL))) then (SHOULDNT "Start state in wrong place")) (* * Return the fully-connected state machine) (create FSM START _ (CAR NTSL) SymbolTable _ SYMBOL.TABLE]) (PG.CONNECT.AFSMS1 [LAMBDA (S PATH SYMBOL.TABLE START DONE) (* hts: " 4-Apr-86 16:29") (* * For each transition out of S, if it is a transition on a nonterminal (say A) and is not immediately reentrant  (ie, the first state of the "[A]-FSM" for A -> Ax for some x), then S inherits all the out-links of the "[A]-FSM"  (for A). The inheritance is done depth-first, since the "[A]-FSM" may have a first transition on a nonterminal, and so may need to inherit some transitions itself. When a state has been completed, it is entered in the hashtable  DONE; if a state is already in this table, it can have links copied from it directly, and does not have its  inheritance checked again. Of course, if there are cyclically left-recursive rules (eg, A -> Bx, B -> Ay) then this depth first search could result in a cycle. To avoid this, the routine remembers and checks its current search  chain. If a cycle is detected, it is returned and not dealt with. If the caller's state is not involved in the  cycle, he deals with it (see CONNECT.CYCLES); else he returns it to his caller.) [if (NOT (GETHASH S DONE)) then (for TRANSITION in (fetch OUT of S) bind SYMBOL AFSM CYCLE NONTERMINAL (COMPLETED _ T) do (SETQ SYMBOL (fetch SYM of TRANSITION)) (SETQ NONTERMINAL (PG.NONTERMINALP SYMBOL SYMBOL.TABLE)) (SETQ CYCLE (FMEMB SYMBOL PATH)) (SETQ AFSM (GETHASH SYMBOL START)) (if (AND NONTERMINAL (NOT CYCLE) (NEQ S AFSM)) then (PG.CONNECT.AFSMS1 AFSM (CONS SYMBOL PATH) SYMBOL.TABLE START DONE) (if (NOT (GETHASH AFSM DONE)) then (SETQ COMPLETED NIL)) [for TRANSITION2 in (fetch OUT of AFSM) do (for S2 in (fetch ST of TRANSITION2) do (PG.CONNECT S S2 (fetch SYM of TRANSITION2] elseif (AND NONTERMINAL CYCLE (NEQ S AFSM)) then (SETQ COMPLETED NIL)) finally (if COMPLETED then (PUTHASH S T DONE]]) (PG.SINGLETON [LAMBDA (LST) (* hts: "16-Feb-86 13:48") (* * Returns T if LST is a singleton list, NIL otherwise.) (AND (LISTP LST) (NOT (CDR LST]) (PG.CONNECTED [LAMBDA (NTSL SYMBOL.TABLE START) (* hts: " 3-Apr-86 16:09") (* * Checks to see if CONNECT.AFSMS has done its work correctly. calls SHOULDNT iff it hasnt.) (for S in (PG.STATES NTSL) do (for L in (fetch OUT of S) do (if (PG.NONTERMINALP (fetch SYM of L) SYMBOL.TABLE) then (OR (PG.OWNS.LINKS S (GETHASH (fetch SYM of L) START)) (SHOULDNT "Ownership fault")))]) (PG.OWNS.LINKS [LAMBDA (S1 S2) (* hts: "21-Feb-86 17:10") (* * Returns non-NIL iff S1s transitions are a superset of S2s.) (BLOCK) (for L2 in (fetch OUT of S2) always (for NEXT2 in (fetch ST of L2) always (for L1 in (fetch OUT of S1) thereis (AND (EQ (fetch SYM of L2) (fetch SYM of L1)) (for NEXT1 in (fetch ST of L1) thereis (EQ NEXT1 NEXT2]) (PG.RABIN.SCOTT [LAMBDA (M) (* hts: " 3-Apr-86 16:08") (* * Rabin-Scott algorithm for making deterministic a FSM. Returns the determinized FSM.) (PG.RABIN.SCOTT1 (fetch START of M) (HASHARRAY 33) (HASHARRAY 33)) (if (NOT (PG.DETERMINISTIC M)) then (SHOULDNT "Nondeterminism")) M]) (PG.RABIN.SCOTT1 [LAMBDA (S STATES DONE) (* hts: " 3-Apr-86 16:08") (* * Does the actual work of the Rabin-Scott determinizing algorithm. Tail recursively enumerates the states of the machine (including replacement states). Recursion should be ok here because FSMs should be more bushy than deep. Basically, if S has transitions to two or more states S1, ..., Sn on the same symbol, replaces those transitions  with a single transition to a union state (which has all the out transitions of S1 thru Sn). DONE hashtable has an  entry for each state visited, so that you can detect cycles and not go catatonic over them. STATES hashtable maps replacement state names onto union states; this is used to avoid unnecessary duplication of  union states) (LET ((S.NAME (fetch NAME of S))) (if (GETHASH S.NAME DONE) then S else (PUTHASH S.NAME T DONE) (for SYM in (PG.TRANSITION.SYMBOLS S) bind NEXT PG.REPLACEMENT do (SETQ NEXT (PG.NEXT.STATES S SYM)) (SETQ PG.REPLACEMENT (PG.REPLACEMENT NEXT STATES)) (if PG.REPLACEMENT then (for N inside NEXT do (PG.DISCONNECT S N SYM)) (PG.CONNECT S PG.REPLACEMENT SYM))) (for L in (fetch OUT of S) do (OR (PG.SINGLETON (fetch ST of L)) (SHOULDNT "Nondeterministic state")) (PG.RABIN.SCOTT1 (CAR (fetch ST of L)) STATES DONE)) S)]) (PG.REPLACEMENT [LAMBDA (S STATES) (* hts: " 3-Apr-86 16:08") (* * Finds or generates the union state (if any) for the list of states S.) (if (AND (LISTP S) (CDR S)) then (LET* ((NAME (PG.COMPOSITE.STATE.NAME S)) (PG.REPLACEMENT (GETHASH NAME STATES))) (if (NOT (type? STATE PG.REPLACEMENT)) then (SETQ PG.REPLACEMENT (create STATE NAME _ NAME)) (for SYM in (PG.TRANSITION.SYMBOLS S) do (for NEXT inside (PG.NEXT.STATES S SYM) do (PG.CONNECT PG.REPLACEMENT NEXT SYM))) (PUTHASH NAME PG.REPLACEMENT STATES)) PG.REPLACEMENT) else NIL)]) (PG.TRANSITION.SYMBOLS [LAMBDA (STATESET) (* hts: "25-Feb-86 23:19") (* * Finds all the transition symbols that come from any of the states in STATESET) (LET ((SYMS (CONS))) [for S inside STATESET do (for L in (fetch OUT of S) do (if (NOT (FMEMB (fetch SYM of L) (CAR SYMS))) then (TCONC SYMS (fetch SYM of L)))] (CAR SYMS]) (PG.NEXT.STATES [LAMBDA (STATESET SYMBOL) (* hts: " 3-Apr-86 16:08") (LET [(NEXT (for S inside STATESET bind TRANSITION when [type? LINK (SETQ TRANSITION (for L in (fetch OUT of S) thereis (EQ SYMBOL (fetch SYM of L] join (COPY (fetch ST of TRANSITION] (if (PG.SINGLETON NEXT) then (CAR NEXT) else NEXT)]) (PG.COMPOSITE.STATE.NAME [LAMBDA (STATESET) (* hts: "25-Feb-86 23:15") (* * Gives a unique name to the set of states STATESET) [if (NLISTP STATESET) then (fetch NAME of STATESET) else (PACK (SORT (for S in STATESET collect (fetch NAME of S)) (FUNCTION ALPHORDER]]) (PG.DISCONNECT [LAMBDA (A B TRANSITION.SYMBOL) (* hts: " 3-Apr-86 16:08") (* * Breaks the link between states A and B along TRANSITION.SYMBOL) (BLOCK) (LET [(TRANSITION (for LINK in (fetch OUT of A) thereis (EQ TRANSITION.SYMBOL (fetch SYM of LINK] [if (type? LINK TRANSITION) then (if (PG.SINGLETON (fetch ST of TRANSITION)) then (* this is the only transition that is keeping the  link alive, so kill the link) (replace OUT of A with (DREMOVE TRANSITION (fetch OUT of A))) else (* chop B out of the link) (replace ST of TRANSITION with (DREMOVE B (fetch ST of TRANSITION] (QUOTE DISCONNECTED]) (PG.NONTERMINALP [LAMBDA (SYM SYMBOL.TABLE) (* hts: " 1-Mar-86 17:06") (* * Returns T if SYM is a nonterminal symbol according to SYMBOL.TABLE , which was built from the current grammar) (EQ (GETHASH SYM SYMBOL.TABLE) (QUOTE NONTERMINAL]) (PG.TERMINALP [LAMBDA (SYM SYMBOL.TABLE) (* hts: "24-Feb-86 16:28") (* * Determines if SYM is a terminal for the current grammar. NIL is a terminal for all grammars.) (OR (EQ (GETHASH SYM SYMBOL.TABLE) (QUOTE TERMINAL)) (NULL SYM]) ) (DEFINEQ (PG.LALRKFSM [LAMBDA (FSM) (* hts: " 3-Apr-86 16:09") (* Transforms an "LR(0)-FSM" into a "LALR(K)-FSM" by adding lookahead states to resolve inadequate states of the  "LR(0)-FSM". Also builds inverse transition links; the backlinks, in addition to helping determine the lookahead  sets, help in building the actual parser (because you have to backtrack states on reduction)) (LET ((PG.STATES (PG.STATES FSM)) (SYMBOL.TABLE (fetch (FSM SymbolTable) of FSM))) (* * Build inverse transition links.) (PG.BUILD.BackLinks PG.STATES) (* * Resolve all inadequate states by adding lookahead states.) (for S in PG.STATES do (SELECTQ (PG.STATETYPE S SYMBOL.TABLE) (INADEQUATE (PG.PRINT.INADEQUATE S SYMBOL.TABLE) (PG.RESOLVE S SYMBOL.TABLE)) ((READ REDUCE LOOKAHEAD) NIL) (NIL (if (NEQ (fetch NAME of S) (QUOTE FINAL)) then (SHOULDNT "Null state type"))) (SHOULDNT "Queer state type"))) (* * Make sure there are no remaining inadequate states.) (if (for S in (PG.STATES FSM) thereis (EQ (PG.STATETYPE S SYMBOL.TABLE) (QUOTE INADEQUATE))) then (SHOULDNT "Inadequate states remaining"))) FSM]) (PG.BUILD.BackLinks [LAMBDA (STATES) (* hts: " 3-Apr-86 16:08") (* * Puts backward links on each of the state S in FSM, showing which from which states you could have arrived at S and by what token transition.) [for S1 in STATES do (for L in (fetch OUT of S1) do (for S2 in (fetch ST of L) do (PG.CONNECT.BACK S2 S1 (fetch SYM of L] (QUOTE BACKLINKED]) (PG.CONNECT.BACK [LAMBDA (FROM.STATE TO.STATE TRANSITION.SYMBOL) (* hts: " 3-Apr-86 16:08") (* * Connects FROM.STATE to TO.STATE with a backwards transition labelled TRANSITION.SYMBOL) (BLOCK) (replace BackLinks of FROM.STATE with (PG.ADD.ARC (fetch BackLinks of FROM.STATE) TO.STATE TRANSITION.SYMBOL)) (QUOTE CONNECTED-BACKWARDS]) (PG.STATETYPE [LAMBDA (S SYMBOL.TABLE) (* hts: " 3-Apr-86 16:09" posted: "20-MAY-77 23:03") (* * Examines a state and determines its type for the parser.) (for L in (fetch OUT of S) bind (TYPE _ NIL) do [COND ((PG.LOOKAHEADP L) (SELECTQ TYPE ((NIL LOOKAHEAD) (SETQQ TYPE LOOKAHEAD)) (SHOULDNT))) ((type? PRODUCTION (fetch SYM of L)) (SELECTQ TYPE ((READ REDUCE INADEQUATE) (SETQQ TYPE INADEQUATE)) (NIL (SETQQ TYPE REDUCE)) (SHOULDNT))) ((PG.TERMINALP (fetch SYM of L) SYMBOL.TABLE) (SELECTQ TYPE ((READ NIL) (SETQQ TYPE READ)) ((REDUCE INADEQUATE) (SETQQ TYPE INADEQUATE)) (SHOULDNT] finally (RETURN TYPE]) (PG.RESOLVE [LAMBDA (S SYMBOL.TABLE) (* hts: "16-Apr-86 15:26") (* * Attempts to resolve inadequacy in a state. Note that if the language is not "LALR(k)" for any k, this routine  will go into an infinite loop; but it will announce its progress to the user so he can (a) stop it if it looks  runaway, and (b) know what the conflict is.) (LET ((LOOKAHEAD (PG.BUILD.LOOKAHEAD.SETS S SYMBOL.TABLE))) (for LOOK in LOOKAHEAD bind EXTRA.STATE LINK SYMBOL DEST LLA do (SETQ LINK (CAR LOOK)) (SETQ SYMBOL (fetch SYM of LINK)) (SETQ DEST (CAR (fetch ST of LINK))) (SETQ LLA (CDR LOOK)) (SETQ EXTRA.STATE (create STATE)) (PG.CONNECT EXTRA.STATE DEST SYMBOL) (for SYMS in LLA do (PG.CONNECT S EXTRA.STATE SYMS)) (replace BackLinks of EXTRA.STATE with S) (PG.DISCONNECT S DEST SYMBOL))) (QUOTE RESOLVED]) (PG.PRINT.INADEQUATE [LAMBDA (S SYMBOL.TABLE) (* hts: " 3-Apr-86 16:08") (* * Prints out information about the inadequate state about to be resolved. Tells what transitions are possible  from this state, thus showing the conflict. Should the parser generator enter an infinite loop trying to resolve  this state (ie, if the language is not "LALR(k)" for any k), this will help the user find the rules in his grammar  which are responsible for the problem.) (PRINTOUT NIL "Adding lookahead to resolve conflict in state " (fetch NAME of S) ":" T) (for L in (fetch OUT of S) do (LET ((SYM (fetch SYM of L))) (if (PG.TERMINALP SYM SYMBOL.TABLE) then (PRINTOUT NIL " Read: " SYM T) elseif (type? PRODUCTION SYM) then (PRINTOUT NIL " Reduce: " (fetch LHS of SYM) " -> ") (for THING in (fetch RHS of SYM) do (PRINTOUT NIL THING " ")) (PRINTOUT NIL T))]) (PG.BUILD.LOOKAHEAD.SETS [LAMBDA (S SYMBOL.TABLE) (* hts: "16-Apr-86 15:26") (* * Attempts to resolve inadequacy in a state. Note that if the language is not "LALR(k)" for any k, this routine  will go into an infinite loop; but it will announce its progress to the user so he can (a) stop it if it looks  runaway, and (b) know what the conflict is. If possible, returns a list of things of the form  (link %. set of lookahead strings) such that each link from S is given a set of lookahead strings disjoint from any belonging to another of S's links.) (for K from 1 bind LLAS do (* * Tell user how deep you're going, so he can detect runaway (in case the grammar he gave is more complex than he expected)) (PRINTOUT NIL " " K "-level lookahead from state " (fetch NAME of S) T) [SETQ LLAS (for L in (fetch OUT of S) when (NOT (PG.NONTERMINALP (fetch SYM of L) SYMBOL.TABLE)) collect (CONS L (PG.LLA K (LIST S) L SYMBOL.TABLE NIL] (if (PG.DISJOINT LLAS) then (RETURN LLAS))]) (PG.DISJOINT [LAMBDA (LLASET) (* hts: " 1-Mar-86 21:59") (* * Tells whether the lookahead sets in LLASET are all disjoint. Note that entries on LLASET are of the form  (link . set-of-lookahead-chars)) (for L on LLASET bind L1 never (SETQ L1 (CAR L)) (for L2 in (CDR L) thereis (INTERSECTION (CDR L1) (CDR L2]) (PG.LLA [LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: " 3-Apr-86 16:09") (* * Finds the level-K set of lookahead symbols generated by looking along the state path PATH  (which is backwards). This local lookahead set is used to build the next level of lookahead states to resolve an  inadequate state. ALREADY is a set of states already visited, and it is intended to prevent infinite recursion  because of cycles.) (COND ((LEQ K 0) (* * The lookahead set for lookahead strings of length 0 is the set containing the empty string. This stops the recursion.) (LIST NIL)) ((LISTP (fetch SYM of LINK)) (PG.LLA.LOOKAHEAD K PATH LINK SYMBOL.TABLE ALREADY)) ((PG.TERMINALP (fetch SYM of LINK) SYMBOL.TABLE) (PG.LLA.READ K PATH LINK SYMBOL.TABLE ALREADY)) ((type? PRODUCTION (fetch SYM of LINK)) (PG.LLA.REDUCE K PATH LINK SYMBOL.TABLE ALREADY)) (T (\ILLEGAL.ARG LINK]) (PG.LLA.LOOKAHEAD [LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: " 3-Apr-86 16:08") (* * Lookahead transition. Skip over it.) (LET* [(NEXT.STATE (CAR (fetch ST of LINK))) (NEXT.LOOKAHEAD (for L in (fetch OUT of NEXT.STATE) when (NOT (PG.NONTERMINALP (fetch SYM of L) SYMBOL.TABLE)) join (PG.LLA K PATH L SYMBOL.TABLE ALREADY] (INTERSECTION NEXT.LOOKAHEAD NEXT.LOOKAHEAD]) (PG.LLA.READ [LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: " 3-Apr-86 16:08") (* * Read transition. Current lookahead symbol, obviously, is the transition symbol of the current link. Recurse to find deeper lookahead. (Except if current symbol is EOF, in which case all deeper lookahead must be EOF  also, by definition of LLA.)) (if (EQ (QUOTE EOF) (fetch SYM of LINK)) then (LIST (to K collect (QUOTE EOF))) else (LET* [(NEXT.STATE (CAR (fetch ST of LINK))) (NEXT.LOOKAHEAD (for L in (fetch OUT of NEXT.STATE) when (NOT (PG.NONTERMINALP (fetch SYM of L) SYMBOL.TABLE)) join (for LOOK in (PG.LLA (SUB1 K) (CONS NEXT.STATE PATH) L SYMBOL.TABLE ALREADY) collect (CONS (fetch SYM of LINK) (COPY LOOK] (INTERSECTION NEXT.LOOKAHEAD NEXT.LOOKAHEAD)))]) (PG.LLA.REDUCE [LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: " 3-Apr-86 16:09") (* * Reduce transition: Back up along symbols of right-hand side of reduction rule %. Then follow the symbol of the left hand side to get to another state. Now we've essentially performed the reduction and got back in the FSM to  where we would have been if we had just read the nonterminal symbol (if such were possible). Lookahead symbol  search can proceed (recursively) from there.) (LET* [(PRODUCTION (fetch SYM of LINK)) (LHS (fetch LHS of PRODUCTION)) (RHS (fetch RHS of PRODUCTION)) (PG.BACKUP (PG.BACKUP PATH (REVERSE RHS))) (SHORTENED.PATH (FNTH PATH (PLUS 2 (LENGTH RHS] (LET [(LOOK (for S in PG.BACKUP join (LET ((TARGET (PG.REDUCE.TARGET S LHS))) [if (FMEMB TARGET ALREADY) then NIL else (for L in (fetch OUT of TARGET) when (NOT (PG.NONTERMINALP (fetch SYM of L) SYMBOL.TABLE)) join (PG.LLA K (CONS TARGET (CONS S SHORTENED.PATH)) L SYMBOL.TABLE (CONS TARGET ALREADY]] (INTERSECTION LOOK LOOK]) (PG.BACKUP [LAMBDA (STATE.PATH SYMBOL.PATH) (* hts: "17-Apr-86 16:25" posted: "23-JUN-77 13:45") (* * Designates the set of states along PATH from which you could have reached (CAR PATH) by reading the symbols in SYMBOL.PATH. STATE.PATH is a (perhaps incomplete) path of states along which to back up; (CAR STATE.PATH) is the  state from which to start backing. SYMBOL.PATH is the list of symbols along which to back up  (empty in the case of rules like A -> e).) (SETQ STATE.PATH (for S in STATE.PATH collect (PG.LOOKAHEAD.SOURCE S))) (* * Back up as far as you are fully constrained by the symbol path provided.) (while (AND SYMBOL.PATH (CDR STATE.PATH)) do (if [NOT (for LNK in (fetch BackLinks of (CAR STATE.PATH)) thereis (AND (EQ (fetch SYM of LNK) (CAR SYMBOL.PATH)) (FMEMB (CADR STATE.PATH) (fetch ST of LNK] then (SHOULDNT)) (SETQ STATE.PATH (CDR STATE.PATH)) (SETQ SYMBOL.PATH (CDR SYMBOL.PATH))) (* * Back up the rest of the way (if any). This may produce some fanning out.) (bind (STATE.SET _ (LIST (CAR STATE.PATH))) while SYMBOL.PATH do (for S in STATE.SET bind (STATES _ NIL) do (for PREV in [fetch ST of (for L in (fetch BackLinks of S) thereis (EQ (fetch SYM of L) (CAR SYMBOL.PATH] do (if (NOT (FMEMB PREV STATES)) then (SETQ STATES (NCONC1 STATES PREV))) finally (SETQ STATE.SET STATES))) (SETQ SYMBOL.PATH (CDR SYMBOL.PATH)) finally (RETURN STATE.SET]) (PG.LOOKAHEAD.SOURCE [LAMBDA (S) (* hts: "20-Feb-86 11:53") (* * If S was generated to do lookahead, you really want to start backign up from the state that S came from. States generated to do lookahead always have their source (the state from which they do lookahead) in their  BackLinks field; other states have lists of states in their BackLinks field.) (if (type? STATE (fetch BackLinks of S)) then (fetch BackLinks of S) else S)]) (PG.REDUCE.TARGET [LAMBDA (STATE NONTERMINAL) (* hts: "24-Feb-86 18:59") (* * Returns the state connected by a transition from STATE along the nonterminal symbol NONTERMINAL) (CAR (fetch ST of (for LNK in (fetch OUT of STATE) thereis (EQ NONTERMINAL (fetch SYM of LNK]) (PG.LOOKAHEADP [LAMBDA (L) (* hts: "24-Feb-86 15:53") (* * Tells whether the given link is a lookahead link. Ordinary backlinks fields contain lists of links; states generated by lookahead have just a state as their backlink: the state from which the lookahead was  generated.) (type? STATE (fetch BackLinks of (CAR (fetch ST of L]) ) (DEFINEQ (PG.OLD.LLA [LAMBDA (K PATH LINK FIRST.LOOKAHEAD.SYMBOLS SYMBOL.TABLE ALREADY) (* hts: " 3-Apr-86 16:09") (if (NOT (AND (FIXP K) (GREATERP K 0))) then (\ILLEGAL.ARG K)) (if (NOT (OR (type? PRODUCTION (fetch SYM of LINK)) (PG.TERMINALP (fetch SYM of LINK) SYMBOL.TABLE))) then (\ILLEGAL.ARG LINK)) (if [NOT (AND (OR (NULL FIRST.LOOKAHEAD.SYMBOLS) (LISTP FIRST.LOOKAHEAD.SYMBOLS)) (EQ (LENGTH FIRST.LOOKAHEAD.SYMBOLS) (SUB1 K] then (\ILLEGAL.ARG FIRST.LOOKAHEAD.SYMBOLS)) (* hts: "21-Feb-86 13:41") (* * Finds the level-K set of lookahead symbols generated by looking along the state path PATH  (which is backwards), given that you've already found the lookahead symbols FIRST.LOOKAHEAD.SYMBOLS  (K-1th, ..., 1st.). This local lookahead set is used to build the next level of lookahead states to resolve an  inadequate state. ALREADY is a set of states already visited, and it is intended to prevent infinite recursion  because of cycles.) (LET [(PG.OLD.LLA [if (NOT (type? PRODUCTION (fetch SYM of LINK))) then (* * Read transition: the lookahead is just what you're about to read.) (if (EQ K 1) then (* * Terminal case: just return a list containing the symbol in the current transition) (LIST (fetch SYM of LINK)) else (* * Got to recurse to find the desired level of lookahead -- constrained by the lookahead symbols already found,  FIRST.LOOKAHEAD.SYMBOLS.) (if (EQ (fetch SYM of LINK) (CAR FIRST.LOOKAHEAD.SYMBOLS)) then (LET [(NEXT.STATE (CAR (fetch ST of LINK] (for NEXT.LINK in (fetch OUT of NEXT.STATE) when (NOT (PG.NONTERMINALP (fetch SYM of NEXT.LINK) SYMBOL.TABLE)) join (PG.OLD.LLA (SUB1 K) (CONS NEXT.STATE PATH) NEXT.LINK (CDR FIRST.LOOKAHEAD.SYMBOLS) SYMBOL.TABLE ALREADY))) else NIL)) else (* * Reduce transition: Back up along symbols of right-hand side of reduction rule (constrained insofar as possible by the state path PATH). Then follow the symbol of the left hand side to get to another state. Now we've essentially performed the reduction and got back in the FSM to where we would have been if we had just  read the nonterminal symbol (if such were possible). Lookahead symbol search can proceed (recursively) from there.) (LET* [(PRODUCTION (fetch SYM of LINK)) (LHS (fetch LHS of PRODUCTION)) (RHS (fetch RHS of PRODUCTION)) (PG.BACKUP (PG.BACKUP PATH (REVERSE RHS))) (SHORTENED.PATH (FNTH PATH (PLUS 2 (LENGTH RHS] (for S in PG.BACKUP join (LET* ((TARGET (PG.REDUCE.TARGET S LHS))) (if (FMEMB TARGET ALREADY) then NIL else (for L in (fetch OUT of TARGET) when (NOT (PG.NONTERMINALP (fetch SYM of L) SYMBOL.TABLE)) join (PG.OLD.LLA K (CONS TARGET (CONS S SHORTENED.PATH)) L FIRST.LOOKAHEAD.SYMBOLS SYMBOL.TABLE (CONS TARGET ALREADY]] (INTERSECTION PG.OLD.LLA PG.OLD.LLA]) ) (DECLARE: EVAL@COMPILE DONTCOPY [DECLARE: EVAL@COMPILE (DATATYPE PRODUCTION (LHS (* an atom, the name of the nonterminal) RHS (* a list of atoms, the right hand side of this rule) AUGMENT (* name of a semantic action to be performed on  reducing to this rule) )) (DATATYPE FSM (START (* Start state of the state machine) SymbolTable (* a hashtable mapping symbols onto {terminal,  nonterminal}) )) (DATATYPE STATE (NAME (* name of this state; an atom) OUT (* transitions from this state; a list of LINKs) BackLinks (* how you could have got to this state) ) NAME _ (GENSYM)) (DATATYPE LINK (SYM (* thing to read or reduction rule for this  transition. Either an ATOM or a PRODUCTION) ST (* list of states to which this transition brings you. One element if deterministic) )) ] (/DECLAREDATATYPE (QUOTE PRODUCTION) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((PRODUCTION 0 POINTER) (PRODUCTION 2 POINTER) (PRODUCTION 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE FSM) (QUOTE (POINTER POINTER)) (QUOTE ((FSM 0 POINTER) (FSM 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE STATE) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((STATE 0 POINTER) (STATE 2 POINTER) (STATE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE LINK) (QUOTE (POINTER POINTER)) (QUOTE ((LINK 0 POINTER) (LINK 2 POINTER))) (QUOTE 4)) ) (/DECLAREDATATYPE (QUOTE PRODUCTION) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((PRODUCTION 0 POINTER) (PRODUCTION 2 POINTER) (PRODUCTION 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE FSM) (QUOTE (POINTER POINTER)) (QUOTE ((FSM 0 POINTER) (FSM 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE STATE) (QUOTE (POINTER POINTER POINTER)) (QUOTE ((STATE 0 POINTER) (STATE 2 POINTER) (STATE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE LINK) (QUOTE (POINTER POINTER)) (QUOTE ((LINK 0 POINTER) (LINK 2 POINTER))) (QUOTE 4)) (DEFINEQ (PG.SMASH.FSM [LAMBDA (M) (* hts: " 3-Apr-86 16:09") (* * Kills circularity in the finite state machine M so that the silly refcount garbage collector can collect it.) (for S in (PG.STATES M) do (replace BackLinks of S with NIL)) M]) ) (DEFINEQ (PG.PPL [LAMBDA (L) (* hts: " 3-Apr-86 16:09") (* * Prints where the link L leads and via what.) (printout NIL .TAB0 10 "(") (if (type? PRODUCTION (fetch SYM of L)) then (PG.PPP (fetch SYM of L)) else (printout NIL (fetch SYM of L))) (printout NIL ";") (for I in (fetch ST of L) do (printout NIL , (fetch NAME of I))) (printout NIL ")" T) L]) (PG.PPM [LAMBDA (M) (* hts: " 3-Apr-86 16:09") (* * Prints out a representation of the finite state machine M) (for S in (SORT (PG.STATES M) (FUNCTION PG.STATE.ORDER)) do (PG.PPS S)) (TERPRI) M]) (PG.PPP [LAMBDA (P) (* hts: "25-Feb-86 00:14") (* * Prints out a representation of a production rule) (printout NIL (fetch LHS of P) " ->") (for TOKEN in (fetch RHS of P) do (PRINTOUT NIL " " TOKEN)) P]) (PG.PPS [LAMBDA (S) (* hts: " 3-Apr-86 16:09") (* * Prints crucial info about state S: transitions from it, whether it is a lookahead state, etc.) (printout NIL (fetch NAME of S)) (if (for L in (fetch OUT of S) thereis (PG.LOOKAHEADP L)) then (printout NIL .TAB 10 "Lookahead" T) else (printout NIL T)) (if (fetch OUT of S) then (printout NIL " Out: ") (for L in (fetch OUT of S) do (PG.PPL L))) S]) ) (DEFINEQ (PG.STATES [LAMBDA (S) (* hts: " 3-Apr-86 18:06") (* * Forms a list of the states of an FSM. Uses a hashtable (DONE) to determine whether a state has been visited. If not, it gets appended to the list of states. Recursion shouldn't hurt because these FSMs are more bushy than  they are deep.) (BLOCK) (LET ((DONE (HASHARRAY 33)) (STATES (CONS))) (COND ((type? FSM S) (PG.STATES1 (fetch START of S) STATES DONE)) ((LISTP S) (for S1 in S join (PG.STATES1 S1 STATES DONE))) (T (PG.STATES1 S STATES DONE))) (CAR STATES]) (PG.STATES1 [LAMBDA (S STATES DONE) (* hts: "24-Feb-86 22:33") (* * Collects substates of state S. See comments in STATES.) [if (NOT (GETHASH S DONE)) then (TCONC STATES S) (PUTHASH S T DONE) (for ARC in (fetch OUT of S) do (for S2 in (fetch ST of ARC) do (PG.STATES1 S2 STATES DONE] NIL]) (PG.STATE.ORDER [LAMBDA (S1 S2) (* hts: "26-Feb-86 14:30") (* * Returns T if S1's name should come before S2's; NIL otherwise) (LET ((S1-NAME (fetch NAME of S1)) (S2-NAME (fetch NAME of S2))) (COND ((EQ S1-NAME (QUOTE START)) T) ((EQ S2-NAME (QUOTE START)) NIL) ((EQ S1-NAME (QUOTE FINAL)) NIL) ((EQ S2-NAME (QUOTE FINAL)) T) (T (ALPHORDER S1-NAME S2-NAME]) ) (* * Lisp code generation) (DEFINEQ (PG.CODE.PARSER [LAMBDA (M PARSERSPEC SORTED?) (* hts: "16-Apr-86 15:31" posted: "20-MAY-77 23:01") (* * Outputs a LISP program for the parser. PARSERSPEC is a parser specification, and M is the "LALR(k)-FSM"  generated from that specification. Parser program structurally is just a great big PROG, with labels for each of  the states in M and GOs to accomplish transitions from state to state. There are two stacks: USERSTACK contains the developing parse tree, and CONTROLSTACK keeps a record of the states that have been seen so far and so makes it  possible to back up to the right place after reducing.) (LIST (QUOTE LAMBDA) (LIST (QUOTE EXPECTED) (QUOTE STATE)) (LIST (QUOTE *) (QUOTE *) (QUOTE Parser) (fetch PARSERNAME of PARSERSPEC)) (CONS (QUOTE PROG) (CONS (LIST (LIST (QUOTE CONTROLSTACK) (LIST (fetch STACKINITFN of PARSERSPEC))) (LIST (QUOTE USERSTACK) (LIST (fetch STACKINITFN of PARSERSPEC))) [LIST (QUOTE LOOKAHEAD) (LIST (fetch LAQUEUEINITFN of PARSERSPEC) (LIST (QUOTE CAR) (QUOTE STATE] (LIST (QUOTE TEMP.LOOKAHEAD) (LIST (fetch QUEUEINITFN of PARSERSPEC))) (QUOTE TOKEN) (QUOTE CLASS) (QUOTE LHS) (QUOTE RHS)) (CONS (LIST (fetch PUSHFN of PARSERSPEC) (QUOTE CONTROLSTACK) (KWOTE (QUOTE START))) (CONS (LIST (QUOTE GO) (QUOTE START)) (PG.CODE.STATES M PARSERSPEC SORTED?]) (PG.CODE.STATES [LAMBDA (M SPEC SORTED?) (* hts: " 3-Apr-86 16:09") (* * Generates code for each of the states in the stack-configuration-recognizing machine M. Sorts the states by name if SORTED? is non-NIL. (This makes the code significantly easier for humans to read.)) (for STATE in (if SORTED? then (SORT (PG.STATES M) (FUNCTION PG.STATE.ORDER)) else (PG.STATES M)) unless (EQ (fetch NAME of STATE) (QUOTE FINAL)) join (LET ((SYMBOL.TABLE (fetch (FSM SymbolTable) of M))) (CONS (fetch NAME of STATE) (SELECTQ (PG.STATETYPE STATE SYMBOL.TABLE) (READ (PG.CODE.READ STATE SYMBOL.TABLE SPEC)) (REDUCE (PG.CODE.REDUCE STATE SPEC)) (LOOKAHEAD (PG.CODE.LOOKAHEAD STATE SYMBOL.TABLE SPEC)) (SHOULDNT]) ) (DEFINEQ (PG.CODE.LOOKAHEAD [LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: " 3-Apr-86 16:09") (* * Generates the code to peek a token from the input stream and act on it appropriately.) (LIST (LIST (QUOTE *) (QUOTE Lookahead)) (PG.CODE.LOOKAHEAD.ALL.TOKENS STATE SYMBOL.TABLE PARSERSPEC) (PG.CODE.LOOKAHEAD.SWITCH STATE SYMBOL.TABLE PARSERSPEC]) (PG.CODE.LOOKAHEAD.ALL.TOKENS [LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: " 3-Apr-86 16:09") (* * Generates the code to peek all the tokens necessary to do lookahead discrimination. For 1-symbol lookahead,  CLASS gets bound to the symbol; for n-symbol lookahead, n>1, CLASS gets bound to a list of symbols) (LET* [(LOOKAHEAD (for L in (fetch OUT of STATE) when (LISTP (fetch SYM of L)) collect (fetch SYM of L))) (NSYMS (LENGTH (CAR LOOKAHEAD] [if (EQ NSYMS 1) then (* * CLASS is just the class of the token read; stick the token on the regular lookahead queue.) (LIST (QUOTE SETQ) (QUOTE CLASS) (PG.CODE.LOOKAHEAD.TOKEN PARSERSPEC (for L in LOOKAHEAD collect (CAR L)) (QUOTE LOOKAHEAD))) else (* * If peeking multiple tokens, must first stick them on a special queue and then shift them onto the normal  lookahead queue. This makes it possible for lookaheads to look at results of previous lookaheads without themselves looping on the same symbol.) (LIST (QUOTE PROG1) [LIST (QUOTE SETQ) (QUOTE CLASS) (CONS (QUOTE LIST) (for N from 1 to NSYMS collect (PG.CODE.LOOKAHEAD.TOKEN PARSERSPEC (for L in LOOKAHEAD collect (CAR (FNTH L N))) (QUOTE TEMP.LOOKAHEAD] (LIST (QUOTE for) (QUOTE TOKEN) (QUOTE in) (QUOTE CLASS) (QUOTE do) (LIST (fetch ENQUEUEFN of PARSERSPEC) (QUOTE LOOKAHEAD) (QUOTE TOKEN]]) (PG.CODE.LOOKAHEAD.TOKEN [LAMBDA (PARSERSPEC EXPECTED QUEUE) (* hts: "28-Feb-86 21:59") (* * Generates the code for peeking a token from the input stream. Stores the thing on the lookahead buffer ,  determines its class and returns its class.) (LIST (QUOTE LET*) [LIST (LIST (QUOTE EXPECTED.OWN) (KWOTE EXPECTED)) (LIST (QUOTE TOKEN) (LIST (QUOTE if) (LIST (fetch QUEUENOTEMPTYFN of PARSERSPEC) (QUOTE LOOKAHEAD)) (QUOTE then) (LIST (fetch DEQUEUEFN of PARSERSPEC) (QUOTE LOOKAHEAD)) (QUOTE else) (LIST (fetch READFN of PARSERSPEC) (QUOTE EXPECTED.OWN) (LIST (QUOTE CDR) (QUOTE STATE] (LIST (fetch ENQUEUEFN of PARSERSPEC) QUEUE (QUOTE TOKEN)) (LIST (fetch CLASSFN of PARSERSPEC) (QUOTE TOKEN) (QUOTE EXPECTED.OWN]) (PG.CODE.LOOKAHEAD.SWITCH [LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: " 3-Apr-86 16:09") (* * Generates the code to make appropriate transitions from lookahead states. Gotta watch out: EOF transitions  must be checked last, in case of overly permissive EOF-acceptor fns.) (CONS (QUOTE COND) (NCONC1 [for L in [SORT (COPY (fetch OUT of STATE)) (FUNCTION (LAMBDA (L1 L2) (GREATERP (for TOKEN in (fetch SYM of L1) when (NEQ TOKEN (QUOTE EOF)) sum 1) (for TOKEN in (fetch SYM of L2) when (NEQ TOKEN (QUOTE EOF)) sum 1] when (LISTP (fetch SYM of L)) collect (LIST (PG.CODE.LOOKAHEAD.MATCH (fetch SYM of L) PARSERSPEC) (LIST (QUOTE GO) (fetch NAME of (CAR (fetch ST of L] (LIST T (LIST (QUOTE PARSE.ERROR]) (PG.CODE.LOOKAHEAD.MATCH [LAMBDA (LOOKAHEAD.PATH PARSERSPEC) (* hts: "28-Feb-86 17:46") (* * Generates code which will be true if the tokens read match those in LOOKAHEAD.PATH, and false otherwise. Matching is a little tricky, for two reasons: (a) if lookahead is only 1 token deep, it will be stored in CLASS  bare (ie, not wrapped in a list); and (b) you don't want to read eof more than once, and you want to check it  specially so that peculiar things can be admitted as pseudo-eof tokens.) (LET* ((PATH (for SYM in LOOKAHEAD.PATH when (NOT (EQ SYM (QUOTE EOF))) collect SYM)) (LPLEN (LENGTH LOOKAHEAD.PATH)) (PLEN (LENGTH PATH))) [if (EQ LPLEN PLEN) then (* No eof) (if (EQ PLEN 1) then (* Single-token lookahead) (LIST (QUOTE EQ) (QUOTE CLASS) (KWOTE (CAR PATH))) else (* Multiple-token lookahead) (LIST (QUOTE EQUAL) (QUOTE CLASS) (KWOTE PATH))) else (* Check for eof last) (if (EQ LPLEN 1) then (* just check eof) (LIST (fetch EOFFN of PARSERSPEC) (QUOTE CLASS)) else (* Check other tokens first, then eof) (LIST (QUOTE AND) (LIST (QUOTE for) (QUOTE READ) (QUOTE in) (QUOTE CLASS) (QUOTE as) (QUOTE NEED) (QUOTE in) (KWOTE PATH) (QUOTE always) (LIST (QUOTE EQ) (QUOTE READ) (QUOTE NEED))) (LIST (fetch EOFFN of PARSERSPEC) (LIST (QUOTE CAR) (LIST (QUOTE FNTH) (QUOTE CLASS) (ADD1 PLEN]]) ) (DEFINEQ (PG.CODE.READ [LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: " 3-Apr-86 16:09") (* * Generates the code to read a token from the input stream and act on it appropriately. Also records the name of this state on the control stack for later use in backup after reducing.) (LIST (LIST (QUOTE *) (QUOTE Read)) (PG.CODE.READ.TOKEN PARSERSPEC (for L in (fetch OUT of STATE) when (PG.TERMINALP (fetch SYM of L) SYMBOL.TABLE) collect (fetch SYM of L))) (PG.CODE.READ.SWITCH STATE SYMBOL.TABLE PARSERSPEC]) (PG.CODE.READ.TOKEN [LAMBDA (PARSERSPEC EXPECTED) (* hts: "28-Feb-86 21:59") (* * Generates the code for reading a token from the input stream. Reads token from lookahead buffer if anything  there, else from stream itself. Determines the class and instance of the token. Pushes the instance on the user  stack and returns the class.) (LIST (QUOTE LET) (LIST (LIST (QUOTE EXPECTED.OWN) (KWOTE EXPECTED))) [LIST (QUOTE SETQ) (QUOTE TOKEN) (LIST (QUOTE if) (LIST (fetch QUEUENOTEMPTYFN of PARSERSPEC) (QUOTE LOOKAHEAD)) (QUOTE then) (LIST (fetch DEQUEUEFN of PARSERSPEC) (QUOTE LOOKAHEAD)) (QUOTE else) (LIST (fetch READFN of PARSERSPEC) (QUOTE EXPECTED.OWN) (LIST (QUOTE CDR) (QUOTE STATE] (LIST (QUOTE SETQ) (QUOTE CLASS) (LIST (fetch CLASSFN of PARSERSPEC) (QUOTE TOKEN) (QUOTE EXPECTED.OWN))) (LIST (fetch PUSHFN of PARSERSPEC) (QUOTE USERSTACK) (LIST (fetch INSTANCEFN of PARSERSPEC) (QUOTE TOKEN) (QUOTE EXPECTED.OWN))) (QUOTE CLASS]) (PG.CODE.READ.SWITCH [LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: " 3-Apr-86 16:08") (* * Generates the code to make appropriate transitions from lookahead states. EOF transitions checked specially  (and last), because of possible permissivity in what counts as EOF. Note for read transitions, you must record your state path on the control stack so subsequent reduces can know where to unwind to.) (CONS (QUOTE SELECTQ) (CONS (QUOTE CLASS) (NCONC1 [for L in (fetch OUT of STATE) when (AND (PG.TERMINALP (fetch SYM of L) SYMBOL.TABLE) (NEQ (QUOTE EOF) (fetch SYM of L))) collect (LIST (fetch SYM of L) [LIST (fetch PUSHFN of PARSERSPEC) (QUOTE CONTROLSTACK) (KWOTE (fetch NAME of (CAR (fetch ST of L] (LIST (QUOTE GO) (fetch NAME of (CAR (fetch ST of L] (LET [(EOF.TRANSITION (for L in (fetch OUT of STATE) thereis (EQ (QUOTE EOF) (fetch SYM of L] (if EOF.TRANSITION then [LET [(NEXT (fetch NAME of (CAR (fetch ST of EOF.TRANSITION] (LIST (QUOTE if) (LIST (fetch EOFFN of PARSERSPEC) (QUOTE CLASS)) (QUOTE then) (LIST (fetch ENQUEUEFN of PARSERSPEC) (QUOTE LOOKAHEAD) (QUOTE TOKEN)) (LIST (fetch PUSHFN of PARSERSPEC) (QUOTE CONTROLSTACK) (KWOTE NEXT)) (LIST (QUOTE GO) NEXT) (QUOTE else) (LIST (QUOTE PARSE.ERROR] else (LIST (QUOTE PARSE.ERROR)))]) ) (DEFINEQ (PG.CODE.REDUCE [LAMBDA (STATE PARSERSPEC) (* hts: " 3-Apr-86 16:09") (* * Outputs the code for a REDUCE operation.) (LET [(PROD (fetch SYM of (for L in (fetch OUT of STATE) thereis (type? PRODUCTION (fetch SYM of L] (* PROD is the production rule according to which we  will reduce.) (if (EQ (fetch LHS of PROD) (QUOTE START)) then (* * if you're reducing the start state, you're done: just return the user stack) [LIST (LIST (QUOTE *) (QUOTE Reduce) (QUOTE start) (QUOTE state)) (LIST (QUOTE RPLACA) (QUOTE STATE) (LIST (fetch SAVESTATEFN of PARSERSPEC) (QUOTE LOOKAHEAD))) (LIST (fetch POPFN of PARSERSPEC) (QUOTE USERSTACK)) (LIST (QUOTE RETURN) (LIST (fetch POPFN of PARSERSPEC) (QUOTE USERSTACK] else (* * Otherwise generate code to munge stacks and proceed to the next appropriate state.) (LIST (LIST (QUOTE *) (QUOTE Reduce)) (PG.CODE.REDUCE.STACKS (fetch LHS of PROD) (fetch RHS of PROD) (fetch (PRODUCTION AUGMENT) of PROD) PARSERSPEC) (PG.CODE.REDUCE.SWITCH STATE (fetch LHS of PROD) (fetch RHS of PROD) PARSERSPEC)))]) (PG.CODE.REDUCE.STACKS [LAMBDA (LHS RHS AUGMENT PARSERSPEC) (* hts: " 1-Mar-86 15:44") (* * Generates the code to perform a reduce action for the parser. Must pop the things being reduced off the user  stack and replace them with the result of the semantic action for this rule. Then must pop states being reduced off the control stack. They will later be replaced by the name of the state to which the LHS transition goes.) (LET ((LEN (LENGTH RHS))) (LIST (QUOTE PROGN) (LIST (QUOTE SETQ) (QUOTE LHS) (KWOTE LHS)) (LIST (QUOTE SETQ) (QUOTE RHS) NIL) (LIST (QUOTE to) LEN (QUOTE do) (LIST (QUOTE push) (QUOTE RHS) (LIST (fetch POPFN of PARSERSPEC) (QUOTE USERSTACK))) (LIST (fetch POPFN of PARSERSPEC) (QUOTE CONTROLSTACK))) (LIST (fetch PUSHFN of PARSERSPEC) (QUOTE USERSTACK) (COPY AUGMENT)) (QUOTE LHS]) (PG.CODE.REDUCE.SWITCH [LAMBDA (S LHS RHS PARSERSPEC) (* hts: " 3-Apr-86 16:09") (* * Generates the code to go to the next state from a reduce state. Where you go depends on where you have been  already (your left-context), which can be determined from the top of the control stack.) (CONS (QUOTE SELECTQ) (CONS (LIST (fetch TOPFN of PARSERSPEC) (QUOTE CONTROLSTACK)) (NCONC1 [for FROM.STATE in (PG.BACKUP (LIST S) (REVERSE RHS)) collect (LET [(TARGET.NAME (fetch NAME of (PG.REDUCE.TARGET FROM.STATE LHS] (LIST (fetch NAME of FROM.STATE) (LIST (fetch PUSHFN of PARSERSPEC) (QUOTE CONTROLSTACK) (KWOTE TARGET.NAME)) (LIST (QUOTE GO) TARGET.NAME] (LIST (QUOTE SHOULDNT]) ) (* * Other) (DEFINEQ (PRINT.FUNCTION [LAMBDA (FUNC FILE) (* hts: "24-Feb-86 22:44") (* * PRETTY-PRINTS FUNCTION FUNC TO FILE (OR THE DEFAULT PRINTER IF FILE IS NIL)) (LET [(DEF (OR (LISTP (GETD FUNC)) (LISTP (GETPROP FUNC (QUOTE EXPR] (if DEF then (LET [(S (OPENSTREAM (OR FILE (QUOTE {LPT})) (QUOTE OUTPUT] (PRINTDEF (LIST FUNC DEF) NIL T NIL NIL S) (CLOSEF S)))]) ) (PUTPROPS PARSER COPYRIGHT ("Xerox Corporation" 1983 1984 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (2128 4045 (MAKEPARSER 2138 . 2633) (PG.INITIALIZE.GRAMMAR 2635 . 4043)) (8581 27301 ( PG.LR0FSM 8591 . 9344) (PG.AFSMS 9346 . 11806) (PG.ROOTPRODUCTION 11808 . 12336) (PG.AFSM.ADDPROD 12338 . 13325) (PG.CONNECT 13327 . 13684) (PG.ADD.ARC 13686 . 14517) (PG.DETERMINISTIC 14519 . 15435) (PG.DETERMINISTIC1 15437 . 16122) (PG.CONNECT.AFSMS 16124 . 17646) (PG.CONNECT.AFSMS1 17648 . 19888) ( PG.SINGLETON 19890 . 20132) (PG.CONNECTED 20134 . 20738) (PG.OWNS.LINKS 20740 . 21420) (PG.RABIN.SCOTT 21422 . 21847) (PG.RABIN.SCOTT1 21849 . 23459) (PG.REPLACEMENT 23461 . 24230) (PG.TRANSITION.SYMBOLS 24232 . 24760) (PG.NEXT.STATES 24762 . 25274) (PG.COMPOSITE.STATE.NAME 25276 . 25682) (PG.DISCONNECT 25684 . 26660) (PG.NONTERMINALP 26662 . 26978) (PG.TERMINALP 26980 . 27299)) (27302 42121 (PG.LALRKFSM 27312 . 28781) (PG.BUILD.BackLinks 28783 . 29300) (PG.CONNECT.BACK 29302 . 29729) (PG.STATETYPE 29731 . 30903) (PG.RESOLVE 30905 . 31930) (PG.PRINT.INADEQUATE 31932 . 33092) (PG.BUILD.LOOKAHEAD.SETS 33094 . 34351) (PG.DISJOINT 34353 . 34819) (PG.LLA 34821 . 35885) (PG.LLA.LOOKAHEAD 35887 . 36415) ( PG.LLA.READ 36417 . 37465) (PG.LLA.REDUCE 37467 . 38810) (PG.BACKUP 38812 . 40714) ( PG.LOOKAHEAD.SOURCE 40716 . 41282) (PG.REDUCE.TARGET 41284 . 41669) (PG.LOOKAHEADP 41671 . 42119)) ( 42122 46093 (PG.OLD.LLA 42132 . 46091)) (48612 48967 (PG.SMASH.FSM 48622 . 48965)) (48968 50745 ( PG.PPL 48978 . 49497) (PG.PPM 49499 . 49824) (PG.PPP 49826 . 50150) (PG.PPS 50152 . 50743)) (50746 52483 (PG.STATES 50756 . 51479) (PG.STATES1 51481 . 51936) (PG.STATE.ORDER 51938 . 52481)) (52517 55307 (PG.CODE.PARSER 52527 . 54332) (PG.CODE.STATES 54334 . 55305)) (55308 61951 (PG.CODE.LOOKAHEAD 55318 . 55745) (PG.CODE.LOOKAHEAD.ALL.TOKENS 55747 . 57599) (PG.CODE.LOOKAHEAD.TOKEN 57601 . 58666) ( PG.CODE.LOOKAHEAD.SWITCH 58668 . 59785) (PG.CODE.LOOKAHEAD.MATCH 59787 . 61949)) (61952 66036 ( PG.CODE.READ 61962 . 62627) (PG.CODE.READ.TOKEN 62629 . 63996) (PG.CODE.READ.SWITCH 63998 . 66034)) ( 66037 69723 (PG.CODE.REDUCE 66047 . 67682) (PG.CODE.REDUCE.STACKS 67684 . 68762) ( PG.CODE.REDUCE.SWITCH 68764 . 69721)) (69742 70289 (PRINT.FUNCTION 69752 . 70287))))) STOP \ No newline at end of file diff --git a/lispusers/PARSERG b/lispusers/PARSERG new file mode 100644 index 00000000..908d9064 --- /dev/null +++ b/lispusers/PARSERG @@ -0,0 +1 @@ +(FILECREATED "16-Apr-86 13:56:19" {PHYLUM}PARSER>RELEASE.1>PARSERG.;5 14900 changes to: (VARS PARSERGCOMS ARITHLEXG) (FNS MAKE.ARITH) previous date: " 3-Apr-86 16:57:21" {PHYLUM}PARSER>RELEASE.1>PARSERG.;3) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PARSERGCOMS) (RPAQQ PARSERGCOMS ((* * TOY1 stuff %. This grammar is "LALR(0)" and the language is "ABC") (FNS MAKE.TOY1 READCHAR TEST.TOY1) (VARS TOY1G) (GLOBALVARS TOY1G TOY1) (* * TOY2 stuff %. This grammar is "LALR(1)" and the language is "(aa*)|(aa*+aa*)" %. This is G1 from the Brosgol paper.) (FNS MAKE.TOY2 TEST.TOY2) (GLOBALVARS TOY2 TOY2G) (VARS TOY2G) (* * TOY3 stuff %. This grammar is "LALR(1)" and the language is "b|(bb)" %. This is G2 from the Brosgol paper.) (FNS MAKE.TOY3 TEST.TOY3) (GLOBALVARS TOY3 TOY3G) (VARS TOY3G) (* * TOY4 stuff %. This grammar is "LALR(2)" and the language is "a|(aaa)|(aab)" %.) (FNS MAKE.TOY4 TEST.TOY4) (GLOBALVARS TOY4 TOY4G) (VARS TOY4G) (* * TOY5 stuff %. The language is "(afc)|(afd)|(bfd)|(bfc)" , but the grammar is not "LALR(k)" for any k, so the parser-generator will loop forever, indicating its progress.) (FNS MAKE.TOY5 TEST.TOY5) (GLOBALVARS TOY5 TOY5G) (VARS TOY5G) (* * ARITH stuff %. This translates a conventional arithmetic expression language into something evaluable by Interlisp EVAL. The language is "LALR(1)" %. Special features: It has a lexical analyzer, ARITHLEX, generated by the same mechanism. The lexical analyzer uses semantic actions cleverly to remove whitespace and construct number values. The structure parser uses semantic actions to generate the Lisp function calls from the parse tree. Since the language is "LALR(1)" , the lookahead queue need only be one token deep, and so is specially implemented that way to avoid consing. In the lexical language (ARITHLEX) , because of the order of reduction implied by the grammar rules, the stack can never be very deep, and it is implemented with a small array to minimize consing.) (FNS MAKE.ARITH TEST.ARITH MAKE.ARITHLEX TEST.ARITHLEX) (GLOBALVARS ARITH ARITHG ARITHLEX ARITHLEXG) (VARS ARITHG ARITHLEXG) (MACROS ARITHDQ FUNNYCAR FUNNYCDR ARITHTOP ARITHPUSH ARITHPOP ARITHSTACK) (RECORDS ARITHSTACK))) (* * TOY1 stuff %. This grammar is "LALR(0)" and the language is "ABC") (DEFINEQ (MAKE.TOY1 [LAMBDA NIL (* hts: " 3-Apr-86 16:18") (* * Makes the parser generator specification for the TOY1 language) (SETQ TOY1 (create PARSERSPEC PARSERNAME _ (QUOTE TOY1) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE TOP) PRODUCTIONS _ TOY1G) READFN _ (FUNCTION READCHAR]) (READCHAR [LAMBDA (EXPECTED STATE) (* hts: "28-Feb-86 22:02") (if (EOFP (CAR STATE)) then (QUOTE EOF) else (READC (CAR STATE]) (TEST.TOY1 [LAMBDA NIL (* hts: "28-Feb-86 22:20") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (PROG1 (TOY1 NIL (LIST (CONS) S)) (CLOSEF S]) ) (RPAQQ TOY1G [(TOP ((A B C) (CONS LHS RHS]) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TOY1G TOY1) ) (* * TOY2 stuff %. This grammar is "LALR(1)" and the language is "(aa*)|(aa*+aa*)" %. This is G1 from the Brosgol paper.) (DEFINEQ (MAKE.TOY2 [LAMBDA NIL (* hts: " 3-Apr-86 16:25") (* * Makes the parser generator specification for the TOY2 language) (SETQ TOY2 (create PARSERSPEC PARSERNAME _ (QUOTE TOY2) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE S) PRODUCTIONS _ TOY2G) READFN _ (FUNCTION READCHAR]) (TEST.TOY2 [LAMBDA NIL (* hts: "28-Feb-86 22:23") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (PROG1 (TOY2 NIL (LIST (CONS) S)) (CLOSEF S]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TOY2 TOY2G) ) (RPAQQ TOY2G [(S ((S + A) (CONS LHS RHS)) ((A) (CONS LHS RHS))) (A ((a A) (CONS LHS RHS)) ((a) (CONS LHS RHS]) (* * TOY3 stuff %. This grammar is "LALR(1)" and the language is "b|(bb)" %. This is G2 from the Brosgol paper.) (DEFINEQ (MAKE.TOY3 [LAMBDA NIL (* hts: " 3-Apr-86 16:27") (* * Makes the parser generator specification for the TOY3 language) (SETQ TOY3 (create PARSERSPEC PARSERNAME _ (QUOTE TOY3) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE S) PRODUCTIONS _ TOY3G) READFN _ (FUNCTION READCHAR]) (TEST.TOY3 [LAMBDA NIL (* hts: "28-Feb-86 22:28") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (PROG1 (TOY3 NIL (LIST (CONS) S)) (CLOSEF S]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TOY3 TOY3G) ) (RPAQQ TOY3G [(S ((A A) (CONS LHS RHS)) ((b) (CONS LHS RHS))) (A ((B) (CONS LHS RHS))) (B ((b) (CONS LHS RHS]) (* * TOY4 stuff %. This grammar is "LALR(2)" and the language is "a|(aaa)|(aab)" %.) (DEFINEQ (MAKE.TOY4 [LAMBDA NIL (* hts: " 3-Apr-86 16:30") (* * Makes the parser generator specification for the TOY4 language) (SETQ TOY4 (create PARSERSPEC PARSERNAME _ (QUOTE TOY4) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE S) PRODUCTIONS _ TOY4G) READFN _ (FUNCTION READCHAR]) (TEST.TOY4 [LAMBDA NIL (* hts: " 1-Mar-86 21:08") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (PROG1 (TOY4 NIL (LIST (CONS) S)) (CLOSEF S]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TOY4 TOY4G) ) (RPAQQ TOY4G [(S ((A a a) (CONS LHS RHS)) ((B a b) (CONS LHS RHS)) ((C) (CONS LHS RHS))) (A ((a) (CONS LHS RHS))) (B ((a) (CONS LHS RHS))) (C ((a) (CONS LHS RHS]) (* * TOY5 stuff %. The language is "(afc)|(afd)|(bfd)|(bfc)" , but the grammar is not "LALR(k)" for any k, so the parser-generator will loop forever, indicating its progress.) (DEFINEQ (MAKE.TOY5 [LAMBDA NIL (* hts: " 3-Apr-86 16:37") (* * Makes the parser generator specification for the TOY5 language) (SETQ TOY5 (create PARSERSPEC PARSERNAME _ (QUOTE TOY5) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE S) PRODUCTIONS _ TOY5G) READFN _ (FUNCTION READCHAR]) (TEST.TOY5 [LAMBDA NIL (* hts: " 1-Mar-86 21:47") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (PROG1 (TOY5 NIL (LIST (CONS) S)) (CLOSEF S]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TOY5 TOY5G) ) (RPAQQ TOY5G [(S ((a A1 c) (CONS LHS RHS)) ((a A2 d) (CONS LHS RHS)) ((b A1 d) (CONS LHS RHS)) ((b A2 c) (CONS LHS RHS))) (A1 ((f) (CONS LHS RHS))) (A2 ((f) (CONS LHS RHS]) (* * ARITH stuff %. This translates a conventional arithmetic expression language into something evaluable by Interlisp EVAL. The language is "LALR(1)" %. Special features: It has a lexical analyzer, ARITHLEX, generated by the same mechanism. The lexical analyzer uses semantic actions cleverly to remove whitespace and construct number values. The structure parser uses semantic actions to generate the Lisp function calls from the parse tree. Since the language is "LALR(1)" , the lookahead queue need only be one token deep, and so is specially implemented that way to avoid consing. In the lexical language (ARITHLEX) , because of the order of reduction implied by the grammar rules, the stack can never be very deep, and it is implemented with a small array to minimize consing.) (DEFINEQ (MAKE.ARITH [LAMBDA NIL (* hts: "16-Apr-86 13:42") (* * Makes the parser generator specification for the ARITH language) (SETQ ARITH (create PARSERSPEC PARSERNAME _ (QUOTE ARITH) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE EXP) PRODUCTIONS _ ARITHG) READFN _ (QUOTE ARITHLEX) CLASSFN _ (QUOTE FUNNYCAR) INSTANCEFN _ (QUOTE FUNNYCDR) QUEUEINITFN _ (QUOTE NILL) ENQUEUEFN _ (QUOTE SETQ) DEQUEUEFN _ (QUOTE ARITHDQ) QUEUENOTEMPTYFN _ (QUOTE SELF]) (TEST.ARITH [LAMBDA NIL (* hts: " 1-Mar-86 19:14") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (PROG1 (ARITH NIL (LIST NIL NIL S)) (CLOSEF S]) (MAKE.ARITHLEX [LAMBDA NIL (* hts: " 3-Apr-86 16:53") (* * Makes the parser generator specification for the ARITHLEX language) (SETQ ARITHLEX (create PARSERSPEC PARSERNAME _ (QUOTE ARITHLEX) GRAMMAR _ (create GRAMMAR StartSymbol _ (QUOTE TOKEN) PRODUCTIONS _ ARITHLEXG) READFN _ (QUOTE READCHAR) EOFFN _ (QUOTE TRUE) STACKINITFN _ (QUOTE ARITHSTACK) PUSHFN _ (QUOTE ARITHPUSH) POPFN _ (QUOTE ARITHPOP) TOPFN _ (QUOTE ARITHTOP) QUEUEINITFN _ (QUOTE NILL) ENQUEUEFN _ (QUOTE SETQ) DEQUEUEFN _ (QUOTE ARITHDQ) QUEUENOTEMPTYFN _ (QUOTE SELF]) (TEST.ARITHLEX [LAMBDA NIL (* hts: " 1-Mar-86 19:10") (* * Run the parser on the file {core}foo) (CLOSEF? (QUOTE {CORE}FOO)) (LET [(S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT] (bind S TOKEN DONE STATE first (SETQ DONE NIL) (SETQ S (OPENSTREAM (QUOTE {CORE}FOO) (QUOTE INPUT))) (SETQ STATE (LIST NIL S)) while (NOT DONE) collect (SETQ TOKEN (ARITHLEX NIL STATE)) (OR (NEQ (QUOTE EOF) (CAR TOKEN)) (SETQ DONE T)) TOKEN finally (CLOSEF S]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ARITH ARITHG ARITHLEX ARITHLEXG) ) (RPAQQ ARITHG [(EXP ((EXP + FACTOR) (LIST (QUOTE PLUS) (CAR RHS) (CADDR RHS))) ((EXP - FACTOR) (LIST (QUOTE DIFFERENCE) (CAR RHS) (CADDR RHS))) ((FACTOR) (CAR RHS))) (FACTOR ((FACTOR * POWER) (LIST (QUOTE TIMES) (CAR RHS) (CADDR RHS))) ((FACTOR / POWER) (LIST (QUOTE FQUOTIENT) (CAR RHS) (CADDR RHS))) ((POWER) (CAR RHS))) (POWER ((MINUS ^ POWER) (LIST (QUOTE EXPT) (CAR RHS) (CADDR RHS))) ((MINUS) (CAR RHS))) (MINUS ((- PAREN) (LIST (QUOTE MINUS) (CADR RHS))) ((PAREN) (CAR RHS))) (PAREN ((%( EXP %)) (CADR RHS)) ((NUMBER) (CAR RHS]) (RPAQQ ARITHLEXG ((TOKEN ((SPACES REALTOKEN) (CADR RHS))) (SPACES (NIL NIL) ((SPACES % ) NIL)) [REALTOKEN ((+) (QUOTE (+ . +))) ((-) (QUOTE (- . -))) ((*) (QUOTE (* . *))) ((/) (QUOTE (/ . /))) ((^) (QUOTE (^ . ^))) ((%() (QUOTE (%( . %())) ((%)) (QUOTE (%) . %)))) ((NUMBER) (CONS (QUOTE NUMBER) (CAR RHS))) ((EOF) (QUOTE (EOF . EOF] (NUMBER ((DIGITS %. FRACTION) (PLUS (CAR RHS) (CADDR RHS))) ((%. FRACTION) (CADR RHS)) ((DIGITS %.) (CAR RHS)) ((DIGITS) (CAR RHS))) (DIGITS ((DIGITS DIGIT) (PLUS (TIMES 10 (CAR RHS)) (CADR RHS))) ((DIGIT) (CAR RHS))) [FRACTION ((FRAC) (FQUOTIENT (CAR (CAR RHS)) (EXPT 10 (CDR (CAR RHS] (FRAC [(FRAC DIGIT) (CONS (PLUS (TIMES 10 (CAR (CAR RHS))) (CADR RHS)) (ADD1 (CDR (CAR RHS] ((DIGIT) (CONS (CAR RHS) 1))) (DIGIT ((0) 0) ((1) 1) ((2) 2) ((3) 3) ((4) 4) ((5) 5) ((6) 6) ((7) 7) ((8) 8) ((9) 9)))) (DECLARE: EVAL@COMPILE [PUTPROPS ARITHDQ MACRO ((Q) (PROG1 Q (SETQ Q NIL] (PUTPROPS FUNNYCAR MACRO ((A B) (CAR A))) (PUTPROPS FUNNYCDR MACRO ((A B) (CDR A))) [PUTPROPS ARITHTOP MACRO (OPENLAMBDA (S) (ELT (fetch STACK of S) (fetch STACKPTR of S] (PUTPROPS ARITHPUSH MACRO (OPENLAMBDA (S NEW) (add (fetch STACKPTR of S) 1) (SETA (fetch STACK of S) (fetch STACKPTR of S) NEW))) [PUTPROPS ARITHPOP MACRO (OPENLAMBDA (S) (PROG1 (ARITHTOP S) (add (fetch STACKPTR of S) -1] [PUTPROPS ARITHSTACK MACRO (NIL (create ARITHSTACK STACKPTR _ 0 STACK _ (ARRAY 7] ) [DECLARE: EVAL@COMPILE (DATATYPE ARITHSTACK (STACKPTR STACK)) ] (/DECLAREDATATYPE (QUOTE ARITHSTACK) (QUOTE (POINTER POINTER)) (QUOTE ((ARITHSTACK 0 POINTER) (ARITHSTACK 2 POINTER))) (QUOTE 4)) (PUTPROPS PARSERG COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (2648 3662 (MAKE.TOY1 2658 . 3079) (READCHAR 3081 . 3294) (TEST.TOY1 3296 . 3660)) (3910 4707 (MAKE.TOY2 3920 . 4339) (TEST.TOY2 4341 . 4705)) (5041 5838 (MAKE.TOY3 5051 . 5470) (TEST.TOY3 5472 . 5836)) (6140 6937 (MAKE.TOY4 6150 . 6569) (TEST.TOY4 6571 . 6935)) (7402 8199 (MAKE.TOY5 7412 . 7831) (TEST.TOY5 7833 . 8197)) (9295 11844 (MAKE.ARITH 9305 . 9953) (TEST.ARITH 9955 . 10314) ( MAKE.ARITHLEX 10316 . 11130) (TEST.ARITHLEX 11132 . 11842))))) STOP \ No newline at end of file diff --git a/lispusers/PATCH-LARGEIPBITMAP b/lispusers/PATCH-LARGEIPBITMAP new file mode 100644 index 00000000..645100e4 --- /dev/null +++ b/lispusers/PATCH-LARGEIPBITMAP @@ -0,0 +1 @@ +(FILECREATED "25-Aug-87 14:23:20" {ERINYES}KOTO>PATCH-LARGEIPBITMAP.;1 5638 changes to: (VARS PATCH-LARGEIPBITMAPCOMS) (FNS SHOWBITMAP1.IP)) (* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PATCH-LARGEIPBITMAPCOMS) (RPAQQ PATCH-LARGEIPBITMAPCOMS ((* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a large bitmap in the wrong order) (FNS SHOWBITMAP1.IP))) (* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a large bitmap in the wrong order) (DEFINEQ (SHOWBITMAP1.IP [LAMBDA (IPSTREAM BITMAP LEFT FIRSTROW XPIXELS YPIXELS SCALEFACTOR ROTATION HEIGHT XBYTES REGIONBOTTOM) (* N.H.Briggs "25-Aug-87 14:06") (* jds "13-Jan-86 18:13") (* ;; "Move a segment of bitmap to an INTERPRESS file.") (* ;;   "FIRSTROW is the row count -- STARTING FROM THE TOP OF THE BITMAP AS ZERO -- for the first row to be displayed.") (* ;;   "By the time we get here, XBYTES should have been raised to the next multiple of 32-bits-worth, since that's the required width of packed pixel vectors." ) (PROG [(TOTALBYTES (ITIMES XBYTES YPIXELS)) (SCRATCHBM (BITMAPCREATE (CEIL XPIXELS BITSPERCELL) 1)) (BMBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BITMAP) (ITIMES (IDIFFERENCE (IPLUS HEIGHT (OR REGIONBOTTOM 0)) (IPLUS FIRSTROW YPIXELS)) (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP] (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {) (* ;   "Start the SIMPLEBODY for displaying this part of the bitmap.") (TRANS.IP IPSTREAM) (* ; "Translate to the current position") (APPENDNUMBER.IP IPSTREAM YPIXELS) (* ;   "For the master, this is the number of pixels in the slow direction") (APPENDNUMBER.IP IPSTREAM (CEIL XPIXELS BITSPERCELL)) (* ; "Number of pixels in the master's fast direction" ) (APPENDINTEGER.IP IPSTREAM 1) (* ; "Reserved for future expansion") (APPENDINTEGER.IP IPSTREAM 1) (APPENDINTEGER.IP IPSTREAM 1) (SELECTQ (IMOD (OR ROTATION 0) 360) (0 (* ;   "Bitmaps are really shown on their sides, hanging from the upper left corner (I think--JDS)") (ROTATE.IP IPSTREAM -90) (TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS)) (* ;;   "Push this segment up to its 'true' height -- i.e., The first segment gets pushed up all the way (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-#ofRowsIn1stSeg (to account for the first segment), and so on." ) (CONCAT.IP IPSTREAM)) (90 (* ; "need nop") (TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS)) 0) (* ;;   "Push this segment up to its 'true' bottom -- i.e., The first segment gets pushed up to bitmapHeight-HeightOfSegment (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-RowsIn1stSeg-RowsThisSeg (to account for the first segment), and so on." ) ) (180 (* ;;   "The translation for this hasn't been tested yet. It may well be the inverse of the rotation-0 correction") (ROTATE.IP IPSTREAM 90) (TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS)) (CONCAT.IP IPSTREAM)) (270 (* ;;   "The translation for this hasn't been tested yet. It may well be the inverse of the rotation-90 correction") (ROTATE.IP IPSTREAM 180) (TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS)) 0) (CONCAT.IP IPSTREAM)) (ERROR ROTATION "rotation by other than multiples of 90 degrees not implemented")) (SCALE.IP IPSTREAM SCALEFACTOR) (* ; "Scale the bitmap to its final size") (CONCAT.IP IPSTREAM) (APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQPACKEDPIXELVECTOR (IPLUS 4 TOTALBYTES)) (APPENDINT.IP IPSTREAM 1 2) (APPENDINT.IP IPSTREAM (CEIL XPIXELS BITSPERCELL) 2) (* ;;   "Now put put the bitmap -- each line must be a 32-bit multiple long") (for Y (XWORDS _ (FOLDHI XBYTES BYTESPERWORD)) from 1 to YPIXELS do (BITBLT BITMAP (OR LEFT 0) (IDIFFERENCE (IPLUS (OR REGIONBOTTOM 0) FIRSTROW YPIXELS) Y) SCRATCHBM 0 0 XPIXELS 1 (QUOTE INPUT) (QUOTE REPLACE)) (\BOUTS IPSTREAM (fetch (BITMAP BITMAPBASE) of SCRATCHBM) 0 (CEIL XBYTES BYTESPERCELL))) (APPENDOP.IP IPSTREAM MAKEPIXELARRAY) (APPENDOP.IP IPSTREAM MASKPIXEL) (APPENDOP.IP IPSTREAM }]) ) (PUTPROPS PATCH-LARGEIPBITMAP COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (565 5548 (SHOWBITMAP1.IP 575 . 5546))))) STOP \ No newline at end of file diff --git a/lispusers/PATCH-TWOSIDED b/lispusers/PATCH-TWOSIDED new file mode 100644 index 00000000..ec86e1fa --- /dev/null +++ b/lispusers/PATCH-TWOSIDED @@ -0,0 +1 @@ +(FILECREATED " 1-Sep-87 11:23:23" {ERINYES}KOTO>PATCH-TWOSIDED.;1 6479 previous date: "15-Oct-86 12:20:47" {QV}LISP>PATCH-TWOSIDED.;1) (* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PATCH-TWOSIDEDCOMS) (RPAQQ PATCH-TWOSIDEDCOMS ((FNS \NSPRINT.INTERNAL) (DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) NSPRINT)))) (DEFINEQ (\NSPRINT.INTERNAL [LAMBDA (PRINTER OPTIONS TRANSFERFN) (* N.H.Briggs "27-Sep-86 16:31") (* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options. TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master) (PROG ((MEDIUM (OR (LISTGET OPTIONS (QUOTE MEDIUM)) NSPRINT.DEFAULT.MEDIUM)) (STAPLE? (LISTGET OPTIONS (QUOTE STAPLE?))) (TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS (QUOTE #SIDES)) EMPRESS#SIDES))) (SENDER.NAME (OR (LISTGET OPTIONS (QUOTE SENDER.NAME)) (USERNAME NIL NIL T))) (DOCNAME (OR (LISTGET OPTIONS (QUOTE DOCUMENT.NAME)) "Document")) PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS) [SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , DOCNAME) (PRINT.OBJECT.CREATE.DATE , (OR (LISTGET OPTIONS (QUOTE DOCUMENT.CREATION.DATE)) (IDATE))) (SENDER.NAME , SENDER.NAME] [SETQ PRINTOPTIONS (BQUOTE ((COPY.COUNT , (FIX (OR (LISTGET OPTIONS (QUOTE #COPIES)) 1] (* This "option" seems to be required) [COND ((SETQ VALUE (LISTGET OPTIONS (QUOTE RECIPIENT.NAME))) (push PRINTOPTIONS (LIST (QUOTE RECIPIENT.NAME) (OR (STRINGP VALUE) (MKSTRING VALUE] [COND ((SETQ VALUE (LISTGET OPTIONS (QUOTE PRIORITY))) (push PRINTOPTIONS (LIST (QUOTE PRIORITY.HINT) (SELECTQ VALUE ((HOLD LOW NORMAL HIGH) VALUE) (\ILLEGAL.ARG VALUE] [COND ((SETQ VALUE (LISTGET OPTIONS (QUOTE MESSAGE))) (push PRINTOPTIONS (LIST (QUOTE MESSAGE) (OR (STRINGP VALUE) (MKSTRING VALUE] [COND ((SETQ VALUE (LISTGET OPTIONS (QUOTE PAGES.TO.PRINT))) (* A page range to print, (first# last#)) (COND ((AND (LISTP VALUE) (LISTP (CDR VALUE)) (NULL (CDDR VALUE)) (SMALLPOSP (CAR VALUE)) (SMALLPOSP (CADR VALUE))) (push PRINTOPTIONS (LIST (QUOTE PAGES.TO.PRINT) VALUE))) (T (\ILLEGAL.ARG VALUE] RETRY (COND ((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER))) (printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME of PRINTER)) (DISMISS 5000) (GO RETRY))) (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) COURIERSTREAM)) (* Check the status of the printer.) (bind (LASTSTATUS _ 0) do (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING) (QUOTE GET.PRINTER.STATUS) (QUOTE RETURNERRORS))) [COND ((EQ (CAR STATUS) (QUOTE ERROR)) (COND ((NOT (EQUAL STATUS LASTSTATUS)) (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER) " Error: " (SUBSTRING (CDR STATUS) 2 -2) "; will retry]"))) (* Wait longer for this problem) (DISMISS 30000)) ((NEQ (SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER) STATUS))) LASTSTATUS) (SELECTQ STATUS (Available (RETURN)) (Busy (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER) " Status: Spooler busy; will retry]")) (ERROR "Printer spooler" STATUS] (SETQ LASTSTATUS STATUS) (DISMISS 5000)) [COND ((OR MEDIUM STAPLE? TWO.SIDED?) (* Check that the printer supports these options.) (SETQ PROPERTIES (COURIER.CALL COURIERSTREAM (QUOTE PRINTING) (QUOTE GET.PRINTER.PROPERTIES) (QUOTE RETURNERRORS))) (COND ((EQ (CAR PROPERTIES) (QUOTE ERROR)) (SETQ STATUS PROPERTIES) (GO HANDLE.ERROR))) [COND (MEDIUM (COND ((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM (CADR (ASSOC (QUOTE MEDIA) PROPERTIES)) PRINTER)) (push PRINTOPTIONS (LIST (QUOTE MEDIUM.HINT) VALUE)) (SETQ MEDIUM] [COND (STAPLE? (COND ((CADR (ASSOC (QUOTE STAPLE) PROPERTIES)) (push PRINTOPTIONS (LIST (QUOTE STAPLE) T)) (SETQ STAPLE?)) (T (printout PROMPTWINDOW .TAB0 0 "[Printer does not support stapled copies]"] (COND (TWO.SIDED? (COND ((CADR (ASSOC (QUOTE TWO.SIDED) PROPERTIES)) (push PRINTOPTIONS (QUOTE (TWO.SIDED T))) (SETQ TWO.SIDED?)) (T (printout PROMPTWINDOW .TAB0 0 "Printer does not support two-sided copies"] (* * Finally, send the print document) (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING) (QUOTE PRINT) TRANSFERFN ATTRIBUTES PRINTOPTIONS (QUOTE RETURNERRORS))) (COND ((NEQ (CAR STATUS) (QUOTE ERROR)) (RETURN STATUS))) HANDLE.ERROR (ERROR (CONCAT "Unexpected error from " (fetch NSPRINTERNAME of PRINTER) " attempting to print " DOCNAME " RETURN to try again.") (CDR STATUS)) (CLOSEF COURIERSTREAM) (GO RETRY]) ) (DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILESLOAD (LOADCOMP) NSPRINT) ) (PUTPROPS PATCH-TWOSIDED COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (433 6305 (\NSPRINT.INTERNAL 443 . 6303))))) STOP \ No newline at end of file diff --git a/lispusers/PCMEMTEST b/lispusers/PCMEMTEST new file mode 100644 index 00000000..184b936a --- /dev/null +++ b/lispusers/PCMEMTEST @@ -0,0 +1 @@ +(FILECREATED "29-Sep-85 18:11:53" {ERIS}BUSMASTER>KOTO>TEST2>PCMEMTEST.;7 33835 changes to: (FNS ShowResults StartBltTest PCMEM.MAKETEST BMTSetValue BMTChangeDirection FastTestBltIn QuietTestBltIn QuietTestBltOut TestBltOut TestBltIn RecordError) previous date: "18-Sep-85 14:58:03" {ERIS}BUSMASTER>KOTO>TEST2>PCMEMTEST.;1) (* Copyright (c) 1985 by Speech Input Project, Univ. of Edinburgh. All rights reserved.) (PRETTYCOMPRINT PCMEMTESTCOMS) (RPAQQ PCMEMTESTCOMS [(* PC memory checkout and test tools) (FNS PCMEM.CHECKOUT RecordError SetupTestArray ShowErrors ShowResults ShowWords StartBltTest StopBltTest TestBltIn TestBltOut FastTestBltIn QuietTestBltIn QuietTestBltOut) (VARS PCMEM.READTESTPATS PCMEM.THRESH PCMEM.WRITETESTPATS) (FNS PCMEM.MAKETEST BMTRead BMTChangeDirection BMTSetValue DoTB) [VARS (BMTArray1) (BMTArray2) (BMTInPatternSpecs ' ((zeros 0) (ones 65535) (alt0 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 0") (alt1 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 1") (rand NIL NIL "random words") ((TogMenuValue) (BMTRead "Pattern") NIL "will prompt and read" Other))) (BMTOutPatternSpecs ' ((zeros 0) (ones 65535) (alt0 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 0") (alt1 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 1") (alt NIL NIL "0 -1 ... alternating every other pass with -1 0 ...") (altAll NIL NIL "zeros alternating every other pass with ones") (newRand NIL NIL "random words, new each pass") (fixedRand NIL NIL "random words, same each pass") ((TogMenuValue) (BMTRead "Pattern") NIL "will prompt and read" Other))) (BMTestTogMenuSpecs ' (("Direction" (In (BMTChangeDirection 'In)) (Out (BMTChangeDirection 'Out)) (FastIn (BMTChangeDirection 'FastIn)) (FastOut (BMTChangeDirection 'FastOut) )) ("Mode" (Straight (NILL)) (Swapped SWAP)) (Pattern) ("Save results" (No (BMTSetValue 'save NIL)) (Yes (BMTSetValue 'save T))) ("Show every error" (No (BMTSetValue 'show NIL)) (Yes (BMTSetValue 'show T))) ("Summarize every" (1 (BMTSetValue 'sumEvery 1)) (10 (BMTSetValue 'sumEvery 10)) ((TogMenuValue) (BMTSetValue 'sumEvery (BMTRead "Summarize every")) NIL "will prompt and read" Other) ) ("Type of summary" (%. (BMTSetValue 'sumType '.)) (Full (BMTSetValue 'sumType 'Full) )) ("# passes" (Forever 2147483647) ((TogMenuValue) (BMTRead "# passes") NIL "will prompt and read" Other)) ("Size of block" 100 1000 5000 10000 32768 ((TogMenuValue) (BMTRead "Size of block") NIL "will prompt and read" Other)) ("Dismiss" (Yes (BMTSetValue 'block? T)) (No (BMTSetValue 'block? NIL) NIL "Enable/disable blocking - No is dangerous!"] (P (PUTASSOC 'Pattern BMTInPatternSpecs BMTestTogMenuSpecs)) (BITMAPS BusmasterIcon) (FILES (SYSLOAD) BUSMASTER) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T)) (GLOBALVARS BMTArray1 BMTArray2) (FILES (LOADCOMP) BUSEXTENDER.DCOM)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML DoTB) (LAMA]) (* PC memory checkout and test tools) (DEFINEQ (PCMEM.CHECKOUT [LAMBDA (maxPageNumber) (* ht: " 4-Jun-85 10:28") (* * run some simple tests to validate the 1109-Busmaster-PCmemory paths and contents - assumes that BUS.CHECKOUT and PCRCVR.CHECKOUT have been run successfully) (PROG NIL (BUS.RESET) (BUSDMA.INIT) (LET ((pages (for i from 0 to (IMAX (OR maxPageNumber 0) 15) when (AND (PROGN (PCBUS.WRITEHL i 0 0) (PCBUS.READHL i 0)=0) (PROGN (PCBUS.WRITEHL i 0 255) (PCBUS.READHL i 0)=255)) collect i))) (if pages=NIL then (printout T "There does not appear to be any memory connected to the PC in page address range 0 - " (IMAX (OR maxPageNumber 0) 15) "." T "Please check that the busmaster and PC are powered up and running correctly by calling (BUS.CHECKOUT) and (PCRCVR.CHECKOUT), and check that there is at least one memory board installed in the PC. If that doesn't help, check the page address switches on the memory board to see that they are in the indicated range." T) (RETURN) else (printout T "There is memory on the PC at page address(es) " .PPVTL pages "." T)) (if [AND (BUSDMA.READADDRESS 0)=(PROGN (DISMISS 1) (BUSDMA.READADDRESS 0)) (NOT (AND (BUSDMA.READTCBIT 0 T) (PROGN (DISMISS 50) (BUSDMA.READTCBIT 0 T] then (printout T "The memory refresh DMA is not running." T) else (printout T "Memory refresh DMA OK" T)) (if (NOT (ARRAYP BMTArray1)) then BMTArray1_(ARRAY 32768 'WORD)) (if (NOT (ARRAYP BMTArray2)) then BMTArray2_(ARRAY 32768 'WORD)) (bind result for p in pages do (if result_(for pat in PCMEM.READTESTPATS thereis (if (GREATERP (QuietTestBltIn p 'STRAIGHT pat 5 32768 BMTArray1 BMTArray2) PCMEM.THRESH) else (PRIN1 "+" T) NIL)) then (printout T "Page " p " read test errors for pattern " result T) else (printout T "Page " p " read test OK" T)) (if result_(for pat in PCMEM.WRITETESTPATS thereis (if (GREATERP (QuietTestBltOut p 'STRAIGHT pat 2 32768 BMTArray1 BMTArray2) PCMEM.THRESH) else (PRIN1 "+" T) NIL)) then (printout T "Page " p " write test errors for pattern " result T) else (printout T "Page " p " write test OK" T]) (RecordError [LAMBDA (aList value firstIndex secondIndex) (* edited: "29-Sep-85 17:17") (LET ((topEntry (CDR (ASSOC firstIndex aList))) subEntry) (if (NOT topEntry) then (PUTASSOC firstIndex (SETQ topEntry (LIST NIL)) aList)) (if (SETQ subEntry (CDR (ASSOC secondIndex topEntry))) then (if (NOT (FMEMB value subEntry)) then (NCONC1 subEntry value)) else (PUTASSOC secondIndex (LIST value) topEntry]) (SetupTestArray [LAMBDA (array1 pattern n) (* ht: " 7-Apr-85 09:31") (for i from 1 to n do (SETA array1 i (SELECTQ pattern (0 0) ((NIL rand) (RAND 0 65535)) (alt0 (if (EVENP i) then 65535 else 0)) (alt1 (if (EVENP i) then 0 else 65535)) (if (NUMBERP pattern) then pattern else (SHOULDNT "not a valid pattern" pattern]) (ShowErrors [LAMBDA (aList) (* ht: " 7-Apr-85 14:47") (RESETFORM (RADIX 16) (for topEntry in aList do (printout NIL 20 .I4.16 topEntry:1 # (for subEntry in topEntry::2 do (printout NIL 25 .I4.16 subEntry:1 , .PARA 30 50 (SORT subEntry::1]) (ShowResults [LAMBDA (j n pattern mode c1 c2 c3 ln lp mn mp sn sp out?) (* ht: "12-Apr-85 14:05") (printout T T j " passes * " n " words = " (TIMES j n) (if out? then " writes" else " reads") " of pattern " # (RESETFORM (RADIX 16) (PRIN1 pattern)) " in " (OR mode (QUOTE STRAIGHT)) " mode." T) (if (OR lp mp) then (printout T 20 c1 25 c2 30 c3 T)) (printout T ln # (if (NEQ ln 0) then (printout NIL " (" (FQUOTIENT ln (QUOTIENT (TIMES j n) 1000.0)) " per thousand)")) (if lp then " read errors: " else " read errors,")) (if lp then (ShowErrors lp)) (printout T T mn # (if (NEQ mn 0) then (printout NIL " (" (FQUOTIENT mn (QUOTIENT (TIMES j n) 1000.0)) " per thousand)")) (if mp then (if out? then " write errors: " else " memory decays: ") else (if out? then " write errors," else " memory decays,"))) (if mp then (ShowErrors mp)) (if sp then (printout T T 20 "1st" 25 "2nd" 30 "addrs")) (printout T T sn # (if (NEQ sn 0) then (printout NIL " (" (FQUOTIENT sn (QUOTIENT (PLUS ln mn) 1000.0)) " per thousand)")) (if sp then " slow faults: " else " slow faults.")) (if sp then (ShowErrors sp)) (TERPRI T]) (ShowWords [LAMBDA (inRadix outRadix offset) (* edited: " 3-Jun-85 17:08") (RESETFORM (RADIX (OR outRadix 16)) (bind addr until (PEEKC T)= 's do (printout T (PCBUS.READWORD 1 (OR offset -1)+(TrueRadixRead (OR inRadix 16))) T) finally (READC T]) (StartBltTest [LAMBDA NIL (* ht: "14-Apr-85 16:28") (LET* [(mw (MAINWINDOW $$TogWindow$$ T)) (menus (WINDOWPROP mw (QUOTE BMTMenus] (WINDOWPROP mw (QUOTE PROCESS) (ADD.PROCESS [LIST (QUOTE DoTB) (SELECTQ (TogMenuValue (CAR menus)) (In (QUOTE TestBltIn)) (Out 'TestBltOut) (FastIn 'FastTestBltIn) (FastOut 'FastTestBltOut) (SHOULDNT)) (NCONC (for m in (CDR menus) collect (TogMenuValue m)) (WINDOWPROP mw (QUOTE BMTArrays] (QUOTE WINDOW) mw]) (StopBltTest [LAMBDA NIL (* ht: "10-Apr-85 15:21") (LET*[(mw (MAINWINDOW $$TogWindow$$ T)) (proc (WINDOWPROP mw 'PROCESS] (printout mw T "Stopping...") (PROCESS.EVAL proc '(SETQ $Stop$ T)]) (TestBltIn [LAMBDA (mode pattern save show sumEvery sumType numPasses n block? array1 array2) (* edited: "29-Sep-85 17:32") (DECLARE (SPECVARS save show sumEvery sumType block?)) (if (NOT n) then (SETQ n (ARRAYSIZE array1))) (SetupTestArray array1 pattern n) (if block? then (BLOCK)) (BUSDMA.INIT) (PCBUS.WRITEARRAY array1 0 n mode) (if block? then (BLOCK)) (printout T "Pattern stored, " (for i from 1 to n unless (EQ (PCBUS.READWORD 1 (DIFFERENCE i 1) mode) (ELT array1 i)) count (PCBUS.WRITEWORD 1 (DIFFERENCE i 1) (ELT array1 i) mode)) " errors," T "starting test." T) (PROG ((losses 0) (memFaults 0) (slowFaults 0) (lossPairs (LIST NIL)) (memPairs (LIST NIL)) (slowPairs (LIST NIL)) type $Stop$ true) (declare (SPECVARS $Stop$) for j from 1 to (OR numPasses MAX.SMALLP) until (OR $Stop$ (KEYDOWNP (QUOTE STOP))) do (PCBUS.READARRAY array2 0 n mode) (if block? then (BLOCK)) [for i from 1 to n unless (EQ (ELT array1 i) (ELT array2 i)) do (bind prev do (SETQ true (PCBUS.READWORD 1 (DIFFERENCE i 1) mode)) repeatuntil (if (EQ true (ELT array1 i)) then (SETQQ type r) [if save then (SELECTQ pattern (rand (RecordError lossPairs (ELT array2 i) i (ELT array1 i))) (RecordError lossPairs i (ELT array1 i) (ELT array2 i] (add losses 1) elseif prev then (if (EQ prev true) then (SETQQ type m) (add memFaults 1) [if save then (SELECTQ pattern (rand (RecordError memPairs (ELT array1 i) i (ELT array2 i))) (RecordError memPairs i (ELT array1 i) (ELT array2 i] (PCBUS.WRITEWORD 1 (DIFFERENCE i 1) (ELT array1 i)) else (add slowFaults 1) (if save then (RecordError slowPairs i prev true)) (if show then (RESETFORM (RADIX 16) (printout T "s" i 6 prev , true T))) (SETQ prev true) NIL) else (SETQ prev true) NIL)) (if show then (RESETFORM (RADIX 16) (printout T type i 6 (ELT array1 i) 12 (ELT array2 i) 18 true T] (if block? then (BLOCK)) (if (EQ (IMOD j (OR sumEvery 10)) 0) then (SELECTQ sumType (%. (PRIN1 "." T)) (printout T losses , "read errors, " memFaults " memory decays, " slowFaults " slow faults." T))) finally (SELECTQ pattern (rand (ShowResults (DIFFERENCE j 1) n pattern mode "addr" "val" "errs" losses (SORT (CDR lossPairs) T) memFaults (SORT (CDR memPairs) T) slowFaults (CDR slowPairs))) (ShowResults (DIFFERENCE j 1) n pattern mode "val" "err" "addrs" losses (CDR lossPairs) memFaults (CDR memPairs) slowFaults (CDR slowPairs]) (TestBltOut [LAMBDA (mode pattern save show sumEvery sumType numPasses n block? array1 array2) (* edited: "29-Sep-85 17:43") (DECLARE (SPECVARS save show sumEvery sumType block?)) (if (NOT n) then (SETQ n (ARRAYSIZE array1))) (SELECTQ pattern ((alt altAll newRand)) (fixedRand (SetupTestArray array1 'rand n)) (SetupTestArray array1 pattern n)) (if block? then (BLOCK)) (printout T "Pattern initialized, starting test." T) (PROG ((losses 0) (memFaults 0) (slowFaults 0) (lossPairs (LIST NIL)) (memPairs (LIST NIL)) (slowPairs (LIST NIL)) type $Stop$ true) (declare (SPECVARS $Stop$) for j from 1 to (OR numPasses MAX.SMALLP) until (OR $Stop$ (KEYDOWNP (QUOTE STOP))) do (SELECTQ pattern (newRand (SetupTestArray array1 pattern n)) (alt (SetupTestArray array1 (if (EVENP j) then (QUOTE alt0) else (QUOTE alt1)) n)) (altAll (SetupTestArray array1 (if (EVENP j) then 0 else 65535) n)) NIL) (if block? then (BLOCK)) (PCBUS.WRITEARRAY array1 0 n) (if block? then (BLOCK)) (PCBUS.READARRAY array2 0 n) (if block? then (BLOCK)) [for i from 1 to n unless (EQ (ELT array1 i) (ELT array2 i)) do (bind prev do (SETQ true (PCBUS.READWORD 1 (DIFFERENCE i 1) mode)) repeatuntil (if (EQ true (ELT array1 i)) then (SETQQ type r) [if save then (SELECTQ pattern (rand (RecordError lossPairs (ELT array2 i) i (ELT array1 i))) (RecordError lossPairs i (ELT array1 i) (ELT array2 i] (add losses 1) elseif prev then (if (EQ prev true) then (SETQQ type w) (add memFaults 1) [if save then (SELECTQ pattern (rand (RecordError memPairs (ELT array1 i) i (ELT array2 i))) (RecordError memPairs i (ELT array1 i) (ELT array2 i] (PCBUS.WRITEWORD 1 (DIFFERENCE i 1) (ELT array1 i)) else (add slowFaults 1) (if save then (RecordError slowPairs i prev true)) (if show then (RESETFORM (RADIX 16) (printout T "s" i 6 prev , true T))) (SETQ prev true) NIL) else (SETQ prev true) NIL)) (if show then (RESETFORM (RADIX 16) (printout T type i 6 (ELT array1 i) 12 (ELT array2 i) 18 true T] (if block? then (BLOCK)) (if (EQ (IMOD j (OR sumEvery 10)) 0) then (SELECTQ sumType (%. (PRIN1 "." T)) (printout T losses , "read errors, " memFaults " write errors, " slowFaults " slow faults." T))) finally (SELECTQ pattern (rand (ShowResults (DIFFERENCE j 1) n pattern mode "addr" "val" "errs" losses (SORT (CDR lossPairs) T) memFaults (SORT (CDR memPairs) T) slowFaults (CDR slowPairs) T)) (ShowResults (DIFFERENCE j 1) n pattern mode "val" "err" "addrs" losses (CDR lossPairs) memFaults (CDR memPairs) slowFaults (CDR slowPairs) T]) (FastTestBltIn [LAMBDA (mode pattern save show sumEvery sumType numPasses n block? array1 array2) (* edited: "29-Sep-85 17:50") (DECLARE (SPECVARS save show sumEvery sumType block?)) (if (NOT n) then n_(ARRAYSIZE array1)) (SetupTestArray array1 pattern n) (BUSDMA.INIT) (PCBUS.WRITEARRAY array1 0 n mode) (printout T "Pattern stored, " (for i from 1 to n unless (PCBUS.READWORD 1 (DIFFERENCE i 1) mode)=(ELT array1 i) count (PCBUS.WRITEWORD 1 (DIFFERENCE i 1) (ELT array1 i) mode)) " errors," T "starting test." T) (PROG ((losses 0) (memFaults 0) (slowFaults 0) (lossPairs (LIST NIL)) (memPairs (LIST NIL)) (slowPairs (LIST NIL)) type true) (declare for j from 1 to (OR numPasses MAX.SMALLP) until (KEYDOWNP 'STOP) do (bind (top _ n) firstBad until (OR top=0 firstBad_(PCBUS.TESTARRAY array1 0 top mode)=0) do (bind prev do true_(PCBUS.READWORD 1 firstBad-1 mode) repeatuntil (if true=(ELT array1 firstBad) then (type_ 'r) (if save then (SELECTQ pattern (rand (RecordError lossPairs NIL firstBad (ELT array1 firstBad))) (RecordError lossPairs firstBad (ELT array1 firstBad) NIL))) (add losses 1) elseif prev then (if prev=true then (type_ 'm) (add memFaults 1) (if save then (SELECTQ pattern (rand (RecordError memPairs (ELT array1 firstBad) firstBad NIL)) (RecordError memPairs firstBad (ELT array1 firstBad) NIL))) (PCBUS.WRITEWORD 1 (DIFFERENCE firstBad 1) (ELT array1 firstBad)) else (add slowFaults 1) (if save then (RecordError slowPairs firstBad prev true)) (if show then (RESETFORM (RADIX 16) (printout T "s" firstBad 6 prev , true T))) (prev_true) NIL) else (prev_true) NIL)) (if show then (RESETFORM (RADIX 16) (printout T type firstBad 6 (ELT array1 firstBad) 12 true T))) (top_firstBad-1)) (if (IMOD j (OR sumEvery 10))=0 then (SELECTQ sumType (%. (PRIN1 "." T)) (printout T losses , "read errors, " memFaults " memory decays, " slowFaults " slow faults." T))) finally (SELECTQ pattern (rand (ShowResults (DIFFERENCE j 1) n pattern mode "addr" "val" "errs" losses (SORT lossPairs::1 T) memFaults (SORT memPairs::1 T) slowFaults slowPairs::1)) (ShowResults (DIFFERENCE j 1) n pattern mode "val" "err" "addrs" losses lossPairs::1 memFaults memPairs::1 slowFaults slowPairs::1]) (QuietTestBltIn [LAMBDA (page mode pattern numPasses n array1 array2) (* edited: "29-Sep-85 17:51") (LET ((total 0)) (if (NOT n) then n_(ARRAYSIZE array1)) (SetupTestArray array1 pattern n) (BUS.RESET) (BUSDMA.INIT) (PCBUS.WRITEARRAY array1 0 n mode 1 page) (add total (for i from 1 to n unless (PCBUS.READWORD page (DIFFERENCE i 1) mode)=(ELT array1 i) count (PCBUS.WRITEWORD page (DIFFERENCE i 1) (ELT array1 i) mode))) (PROG ((losses 0) (memFaults 0) (slowFaults 0) type true) (for j from 1 to (OR numPasses MAX.SMALLP) until (KEYDOWNP 'STOP) do (PCBUS.READARRAY array2 0 n mode 1 page) (for i from 1 to n unless (ELT array1 i)=(ELT array2 i) do (bind prev do true_(PCBUS.READWORD page (DIFFERENCE i 1) mode) repeatuntil (if true=(ELT array1 i) then (type_ 'r) (add losses 1) elseif prev then (if prev=true then (type_ 'm) (add memFaults 1) (PCBUS.WRITEWORD page (DIFFERENCE i 1) (ELT array1 i)) else (add slowFaults 1) (prev_true) NIL) else (prev_true) NIL))) (PRIN1 "." T) finally total_(PLUS total losses memFaults slowFaults))) total]) (QuietTestBltOut [LAMBDA (page mode pattern numPasses n array1 array2) (* edited: "29-Sep-85 17:52") (if (NOT n) then n_(ARRAYSIZE array1)) (SELECTQ pattern ((alt altAll newRand)) (fixedRand (SetupTestArray array1 'rand n)) (SetupTestArray array1 pattern n)) (BUS.RESET) (BUSDMA.INIT) (PROG ((losses 0) (memFaults 0) (slowFaults 0) type true) (for j from 1 to (OR numPasses MAX.SMALLP) until (KEYDOWNP 'STOP) do (SELECTQ pattern (newRand (SetupTestArray array1 pattern n)) (alt (SetupTestArray array1 (if (EVENP j) then 'alt0 else 'alt1) n)) (altAll (SetupTestArray array1 (if (EVENP j) then 0 else 65535) n)) NIL) (PCBUS.WRITEARRAY array1 0 n mode 1 page) (PCBUS.READARRAY array2 0 n mode 1 page) (for i from 1 to n unless (ELT array1 i)=(ELT array2 i) do (bind prev do true_(PCBUS.READWORD page i-1 mode) repeatuntil (if true=(ELT array1 i) then (type_ 'r) (add losses 1) elseif prev then (if prev=true then (type_ 'w) (add memFaults 1) (PCBUS.WRITEWORD page i-1 (ELT array1 i)) else (add slowFaults 1) (prev_true) NIL) else (prev_true) NIL))) (PRIN1 "." T) finally (RETURN losses+memFaults+slowFaults]) ) (RPAQQ PCMEM.READTESTPATS (0 65535 rand)) (RPAQQ PCMEM.THRESH 15) (RPAQQ PCMEM.WRITETESTPATS (altAll fixedRand)) (DEFINEQ (PCMEM.MAKETEST [LAMBDA (array1 array2) (* edited: "29-Sep-85 18:04") (LET ((mw (CREATEW NIL "PC Memory Test Window")) mwRight controlW controlM reg) [SETQ mwRight (PLUS (fetch LEFT of (WINDOWPROP mw (QUOTE REGION))) (fetch WIDTH of (WINDOWPROP mw (QUOTE REGION] [WINDOWPROP mw (QUOTE BMTArrays) (LIST [OR array1 BMTArray1 (SETQ BMTArray1 (ARRAY 32768 (QUOTE WORD] (OR array2 BMTArray2 (SETQ BMTArray2 (ARRAY 32768 (QUOTE WORD] (DSPSCROLL (QUOTE ON) mw) (WINDOWPROP mw (QUOTE ICON) BusmasterIcon) (WINDOWPROP mw (QUOTE BMTMenus) (bind (nw _ mw) tm aw tw ttw for tms in BMTestTogMenuSpecs collect (SETQ ttw (TogMenu (SETQ tm (MakeTogMenu (CDR tms))) (CAR tms) NIL 0 0 T)) (if (EQ (CAR tms) (QUOTE Pattern)) then (* * widen it to take the biggest name in the out patterns) [SETQ reg (APPEND (WINDOWPROP ttw (QUOTE REGION] [replace WIDTH of reg with (WIDTHIFWINDOW (STRINGWIDTH "fixedRand" (DSPFONT NIL ttw] (SHAPEW ttw reg) (WINDOWPROP mw (QUOTE PatternMenu) tm)) (if (OR (NULL aw) (AND tw (IGREATERP [PLUS (fetch LEFT of (WINDOWPROP tw (QUOTE REGION))) (fetch WIDTH of (WINDOWPROP tw (QUOTE REGION))) (fetch WIDTH of (WINDOWPROP ttw (QUOTE REGION] mwRight))) then (SETQ aw nw) (SETQ tw NIL) (SETQ nw ttw)) (if tw then (ATTACHWINDOW ttw tw (QUOTE RIGHT)) else (ATTACHWINDOW ttw aw (QUOTE TOP) (QUOTE LEFT))) (SETQ tw ttw) (REDISPLAYW ttw) tm)) (ATTACHWINDOW (SETQ controlW (TogMenu [SETQ controlM (MakeTogMenu (QUOTE ((Start NIL ( StartBltTest)) (Stop NIL (StopBltTest ] "Control" NIL 0 0 T)) mw (QUOTE RIGHT) (QUOTE TOP)) (WINDOWPROP mw (QUOTE ControlMenu) controlM) (REDISPLAYW controlW) mw]) (BMTRead [LAMBDA (message) (* edited: "12-Apr-85 11:05") (RESETFORM (TTYDISPLAYSTREAM (GETPROMPTWINDOW (MAINWINDOW $$TogWindow$$ T))) (printout NIL message ": ") (PROG1 (READ) (CLOSEW (GETPROMPTWINDOW (MAINWINDOW $$TogWindow$$ T]) (BMTChangeDirection [LAMBDA (direction) (* ht: "14-Apr-85 16:31") [if (BOUNDP (QUOTE $$TogWindow$$)) then (TogMenuReset (WINDOWPROP (MAINWINDOW $$TogWindow$$ T) (QUOTE PatternMenu)) NIL (SELECTQ direction ((In FastIn) BMTInPatternSpecs) ((Out FastOut) BMTOutPatternSpecs) (SHOULDNT] direction]) (BMTSetValue [LAMBDA (var value) (* edited: "12-Apr-85 10:48") [if (BOUNDP (QUOTE $$TogWindow$$)) then (LET (proc) (SETQ proc (WINDOWPROP (MAINWINDOW $$TogWindow$$ T) (QUOTE PROCESS))) (if (AND proc (PROCESS.APPLY proc (FUNCTION BOUNDP) (LIST var) T)) then (PROCESS.APPLY proc (FUNCTION SET) (LIST var value] value]) (DoTB [NLAMBDA (fn args) (* ht: "14-Apr-85 16:26") (RESETFORM (TTYDISPLAYSTREAM (PROCESSPROP (THIS.PROCESS) 'WINDOW)) (APPLY fn args)) (TogMenuReset (WINDOWPROP (PROCESSPROP (THIS.PROCESS) 'WINDOW) 'ControlMenu]) ) (RPAQQ BMTArray1 NIL) (RPAQQ BMTArray2 NIL) (RPAQ BMTInPatternSpecs ' ((zeros 0) (ones 65535) (alt0 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 0") (alt1 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 1") (rand NIL NIL "random words") ((TogMenuValue) (BMTRead "Pattern") NIL "will prompt and read" Other))) (RPAQ BMTOutPatternSpecs ' ((zeros 0) (ones 65535) (alt0 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 0") (alt1 NIL NIL "fixed pattern of alternating 0s and 1s, starting with 1") (alt NIL NIL "0 -1 ... alternating every other pass with -1 0 ...") (altAll NIL NIL "zeros alternating every other pass with ones") (newRand NIL NIL "random words, new each pass") (fixedRand NIL NIL "random words, same each pass") ((TogMenuValue) (BMTRead "Pattern") NIL "will prompt and read" Other))) (RPAQ BMTestTogMenuSpecs ' (("Direction" (In (BMTChangeDirection 'In)) (Out (BMTChangeDirection 'Out)) (FastIn (BMTChangeDirection 'FastIn)) (FastOut (BMTChangeDirection 'FastOut))) ("Mode" (Straight (NILL)) (Swapped SWAP)) (Pattern) ("Save results" (No (BMTSetValue 'save NIL)) (Yes (BMTSetValue 'save T))) ("Show every error" (No (BMTSetValue 'show NIL)) (Yes (BMTSetValue 'show T))) ("Summarize every" (1 (BMTSetValue 'sumEvery 1)) (10 (BMTSetValue 'sumEvery 10)) ((TogMenuValue) (BMTSetValue 'sumEvery (BMTRead "Summarize every")) NIL "will prompt and read" Other)) ("Type of summary" (%. (BMTSetValue 'sumType '.)) (Full (BMTSetValue 'sumType 'Full))) ("# passes" (Forever 2147483647) ((TogMenuValue) (BMTRead "# passes") NIL "will prompt and read" Other)) ("Size of block" 100 1000 5000 10000 32768 ((TogMenuValue) (BMTRead "Size of block") NIL "will prompt and read" Other)) ("Dismiss" (Yes (BMTSetValue 'block? T)) (No (BMTSetValue 'block? NIL) NIL "Enable/disable blocking - No is dangerous!")))) (PUTASSOC 'Pattern BMTInPatternSpecs BMTestTogMenuSpecs) (RPAQ BusmasterIcon (READBITMAP)) (64 64 "OOOOOOOOOOOOOOOO" "OOOOOOOOOOOOOOOO" "LBBBBBBBBBBBBB@C" "LBBBBBBNCOOOOOHC" "L@HHHHHLKOOOOOHC" "L@HLIHHLKOOOOOHC" "LBBNCJBNCOOOOOHC" "LBBNCJBNCOOOOOHC" "L@HLIHHLKOOOOOHC" "L@HNKHHLKOOOOOHC" "LBBOOJBNCOOOOOHC" "LBBGOBBNCOOOOOHC" "L@HKNHHLHHIOHHHC" "L@HILHHLHHIOHHHC" "LBBCNBBNBBCOBB@C" "LBBCNBBNBBCOJB@C" "L@HKLHHLHHIOHHHC" "L@HILHHLHHIOHHHC" "LBBCNBBNBBCOBB@C" "LBBCNBBNBBCOBB@C" "L@HILHHLHHIOHHHC" "L@HILHHLHHIOHHHC" "LBBCNBBNBBCOBB@C" "LBBCNBBNBBCOBB@C" "L@HILHHLHHIOHHHC" "L@HILHHLHHIOHHHC" "LBBCNBBNBBCOBB@C" "LBBCNBBNBBCOBB@C" "L@HILHHLHHIOHHHC" "L@HILHHLHHIOHHHC" "LBBCNBBNBBCOBB@C" "LBBCNBBNBBCOBB@C" "L@HILHHLHHIOHHHC" "L@HILHINHHIOHHHC" "LBBCNBCOBBCOBB@C" "LBBCNBGOJBCOBB@C" "L@HILHOOHHIOHHHC" "L@HILHOOHHIOHHHC" "LBBCNBGOJBCOBB@C" "LBBCNBGOJBCOBB@C" "L@HILHOOHHIOHHHC" "L@HKNHOOHHIOHHHC" "LBBCOBGOJBCOBB@C" "LBBOOJGOJBCOBB@C" "L@HOOHOOHHIOHHHC" "L@HNKHOOHHIOHHHC" "LBBNCJGOJBCOBB@C" "LBBNCJGOJBCOBB@C" "L@HLIHKOHHIOHHHC" "L@HLIHINHHHHHHHC" "L@@@@@@@@@@@@@@C" "L@@@@@@@@@@@@@@C" "L@@@@@@@@@@@@@@C" "LO@O@B@H@@@@@@@C" "LHI@HCAHLEKAHJIC" "LHI@@CAIBFMBDNIC" "LOA@@BJINDIBDHEC" "LHA@HBJI@DIBDHFC" "LH@O@BDHNDIAHHBC" "L@@@@@@@@@@@@@BC" "L@@@@@@@@@@@@@LC" "L@@@@@@@@@@@@@@C" "L@@@@@@@@@@@@@@C" "OOOOOOOOOOOOOOOO") (FILESLOAD (SYSLOAD) BUSMASTER) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (RESETSAVE DWIMIFYCOMPFLG T) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BMTArray1 BMTArray2) ) (FILESLOAD (LOADCOMP) BUSEXTENDER.DCOM) ) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML DoTB) (ADDTOVAR LAMA ) ) (PUTPROPS PCMEMTEST COPYRIGHT ("Speech Input Project, Univ. of Edinburgh" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (3736 25516 (PCMEM.CHECKOUT 3746 . 6576) (RecordError 6578 . 7146) (SetupTestArray 7148 . 7704) (ShowErrors 7706 . 8091) (ShowResults 8093 . 9719) (ShowWords 9721 . 10100) (StartBltTest 10102 . 10786) (StopBltTest 10788 . 11073) (TestBltIn 11075 . 14858) (TestBltOut 14860 . 18867) ( FastTestBltIn 18869 . 22248) (QuietTestBltIn 22250 . 23870) (QuietTestBltOut 23872 . 25514)) (25645 29849 (PCMEM.MAKETEST 25655 . 28180) (BMTRead 28182 . 28531) (BMTChangeDirection 28533 . 28992) ( BMTSetValue 28994 . 29503) (DoTB 29505 . 29847))))) STOP \ No newline at end of file diff --git a/lispusers/PHONE-DIRECTORY b/lispusers/PHONE-DIRECTORY new file mode 100644 index 00000000..d965e118 --- /dev/null +++ b/lispusers/PHONE-DIRECTORY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 2-Feb-87 10:38:19" {ERIS}LYRIC>PHONE-DIRECTORY.;1 9029 changes to%: (VARS PHONE-DIRECTORYCOMS) previous date%: " 9-Jan-87 19:45:25" {ERIS}KOTO>PHONE-DIRECTORY.;3) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PHONE-DIRECTORYCOMS) (RPAQQ PHONE-DIRECTORYCOMS ((FNS Cache-Phone-Directory-Files Let-your-fingers-do-the-walking Phone-Directory-Kill-Proc Phone-Window-ButtonEventFn Lookup-Person Phone-Window-WhenOpenedFn) (VARS fingersIconMask fingersIconBM) (INITVARS (*Cached-Phone-Directory-Files* NIL) (*Phone-Directory-Pos* (create POSITION XCOORD _ 15 YCOORD _ (DIFFERENCE SCREENHEIGHT 75))) (*Phone-Directory-Region* (CREATEREGION 15 (DIFFERENCE SCREENHEIGHT 258 ) 400 250))) (GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* *Phone-Directory-Region* fingersIconMask fingersIconBM) (FILES GREP) (P (Let-your-fingers-do-the-walking)))) (DEFINEQ (Cache-Phone-Directory-Files [LAMBDA (msgStream) (* smL " 9-Jan-87 19:40") (* * Cache the phone directory files in core) (printout msgStream T "Caching phone directory files...") (LET ((oldFiles *Cached-Phone-Directory-Files*)) (SETQ *Cached-Phone-Directory-Files* (for file in (for f inside PHONELISTFILES collect (FINDFILE f)) bind localFile when (NOT (NULL file)) collect (printout msgStream T "Caching " file "...") (SETQ localFile (PACKFILENAME.STRING 'HOST 'CORE 'VERSION NIL 'BODY file)) (COPYFILE file localFile) localFile)) (for file in oldFiles do (DELFILE file))) (printout NIL "done" T T]) (Let-your-fingers-do-the-walking [LAMBDA NIL (* smL "21-Aug-86 14:08") (* * Create a directory lookup window) (LET ((w (CREATEW *Phone-Directory-Region* "Phone directory" NIL))) [WINDOWPROP w 'ICONFN (FUNCTION (LAMBDA (w icon) (OR icon (ICONW fingersIconBM fingersIconMask *Phone-Directory-Pos* T] (WINDOWADDPROP w 'OPENFN (FUNCTION Phone-Window-WhenOpenedFn)) (WINDOWADDPROP w 'EXPANDFN (FUNCTION Phone-Window-WhenOpenedFn)) (WINDOWADDPROP w 'CLOSEFN (FUNCTION Phone-Directory-Kill-Proc)) (WINDOWADDPROP w 'SHRINKFN (FUNCTION Phone-Directory-Kill-Proc)) (WINDOWPROP w 'BUTTONEVENTFN (FUNCTION Phone-Window-ButtonEventFn)) [WINDOWPROP w 'RIGHTBUTTONFN (FUNCTION (LAMBDA (w) (if (EQ (THIS.PROCESS) (WINDOWPROP w 'PROCESS)) then [ADD.PROCESS `(DOWINDOWCOM ,w] else (DOWINDOWCOM w] (SHRINKW w) w]) (Phone-Directory-Kill-Proc [LAMBDA (window) (* smL "21-Aug-86 13:05") (* * Kill the phone directory process associated with the window) (LET [(proc (WINDOWPROP window 'PROCESS] (if (PROCESSP proc) then (if (TTY.PROCESSP proc) then (TTY.PROCESS T)) (DEL.PROCESS proc]) (Phone-Window-ButtonEventFn [LAMBDA (w) (* smL " 1-Aug-86 09:37") (* * The button event fn for the phone directory lookup window -  if the user bugs in the title, lets them re-cache the phone list) (if [AND (NOT (MOUSESTATE UP)) (NOT (INSIDEP (DSPCLIPPINGREGION NIL w) (LASTMOUSEX w) (LASTMOUSEY w))) (MENU (LOADTIMECONSTANT (create MENU ITEMS _ '("Recache the directory files?"] then (Cache-Phone-Directory-Files PROMPTWINDOW]) (Lookup-Person [LAMBDA (w) (* smL "21-Aug-86 13:46") (* * The main program for the Phone-Directory) (OPENW w) (TTYDISPLAYSTREAM w) (TTY.PROCESS (THIS.PROCESS)) (OR *Cached-Phone-Directory-Files* (Cache-Phone-Directory-Files T)) (bind name do (TERPRI) (SETQ name (TTYIN "Name: " NIL NIL '(STRING NORAISE) NIL NIL NIL NIL)) (if (NOT (NULL name)) then (GREP name *Cached-Phone-Directory-Files*)) until (NOT (OPENWP w]) (Phone-Window-WhenOpenedFn [LAMBDA (w) (* smL "21-Aug-86 13:21") (* * The OPENFN for the Phone lookup window) (if (WINDOWPROP w 'PROCESS) then (TTY.PROCESS (WINDOWPROP w 'PROCESS)) else (OPENW w) (ADD.PROCESS `(Lookup-Person ,w) 'NAME 'Lookup-Person 'WINDOW w]) ) (RPAQQ fingersIconMask #*(57 62)AOOOOOOOOOOOOL@@GOOOOOOOOOOOOO@@GOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOH@GOOOOOOOOOOOOO@@GOOOOOOOOOOOOO@@COOOOOOOOOOOON@@@OOOOOOOOOOOOH@@ ) (RPAQQ fingersIconBM #*(57 62)AOOOOOOOOOOOOL@@GOOOOOOOOOOOOO@@GOOOOOOOOOOOOO@@O@@@@@@@@@@@@GH@N@@@@@@@@@@@@CH@N@@GOOL@@@@@@CH@N@@COON@@@@@@CH@N@@AOON@@@@@@CH@N@@AOOO@@@@@@CH@N@@AOOO@@@@@@CH@N@@COOO@@@@@@CH@N@@COOOH@@@@@CH@N@@COOOH@@@@@CH@N@@COOOL@@@@@CH@N@@COOOL@@@@@CH@N@@@OOON@@@@@CH@N@@@OOON@@@@@CH@N@@@OOOO@@@@@CH@N@@@GOOO@@@@@CH@N@@@GOOOH@@@@CH@N@@@OOOOH@@@@CH@N@@AOOGOL@@@@CH@N@@AONCOL@@@@CH@N@@COHIOL@@@@CH@N@@COIION@@@@CH@N@@GOALON@@@@CH@N@@GLCLOO@@@@CH@N@@OHCNGO@@@@CH@N@@@@GNGOH@@@CH@N@@@@GOCOH@@@CH@N@@@@ONAOH@@@CH@N@@@AOLAOL@@@CH@N@@@AOL@OL@@@CH@N@@@COH@ON@@@CH@N@@@COH@GN@@@CH@N@@@GO@@GO@@@CH@N@@@GN@@CO@@@CH@N@@@OL@@AO@@@CH@N@@@OL@@AOH@@CH@N@@AOH@@@OH@@CH@N@@AO@@@@OL@@CH@N@@AO@@@@GL@@CH@N@@AN@@@@CN@@CH@N@@AL@@@@CN@@CH@N@@@@@@@@AO@@CH@N@@@@@@@@@O@@CH@N@@@@@@@@@F@@CH@O@@@GOHAON@@@GH@O@@AOONCOOH@@GH@OL@GOOOGOON@AOH@OOOOL@OOHAOOOOH@OOOO@@GO@@GOOOH@NOOL@@GO@@AOOKH@NAO@@@CN@@@GLCH@N@@@@@CN@@@@@CH@N@@@@@@@@@@@@CH@N@@@@@@@@@@@@CH@N@@@@@@@@@@@@CH@G@@@@@@@@@@@@G@@GOOOOOOOOOOOOO@@COOOOOOOOOOOON@@@OOOOOOOOOOOOH@@ ) (RPAQ? *Cached-Phone-Directory-Files* NIL) (RPAQ? *Phone-Directory-Pos* (create POSITION XCOORD _ 15 YCOORD _ (DIFFERENCE SCREENHEIGHT 75))) (RPAQ? *Phone-Directory-Region* (CREATEREGION 15 (DIFFERENCE SCREENHEIGHT 258) 400 250)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* *Phone-Directory-Region* fingersIconMask fingersIconBM) ) (FILESLOAD GREP) (Let-your-fingers-do-the-walking) (PUTPROPS PHONE-DIRECTORY COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1649 6373 (Cache-Phone-Directory-Files 1659 . 2954) (Let-your-fingers-do-the-walking 2956 . 4251) (Phone-Directory-Kill-Proc 4253 . 4684) (Phone-Window-ButtonEventFn 4686 . 5362) ( Lookup-Person 5364 . 5976) (Phone-Window-WhenOpenedFn 5978 . 6371))))) STOP \ No newline at end of file diff --git a/lispusers/PHONE-DIRECTORY.TEDIT b/lispusers/PHONE-DIRECTORY.TEDIT new file mode 100644 index 00000000..b6851cb4 Binary files /dev/null and b/lispusers/PHONE-DIRECTORY.TEDIT differ diff --git a/lispusers/PIECE-MENUS b/lispusers/PIECE-MENUS new file mode 100644 index 00000000..e2e6d926 --- /dev/null +++ b/lispusers/PIECE-MENUS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 4-Apr-88 12:02:12" {ERINYES}MEDLEY>PIECE-MENUS.;1 15813 changes to%: (FNS CHUNK.MENU.CREATE CHUNK.MENU.GET.REAL.MENU CHUNK.MENU.INVOKE KEYWORD.MENU.CREATE KEYWORD.MENU.GET.MENU KEYWORD.MENU.INVOKE KEYWORD.MENU.MAKE.MENU PIECE.MENU.MAKE.MENU) previous date%: "12-Feb-86 18:31:27" {PHYLUM}KOTO>LISPUSERS>PIECE-MENUS.;1) (* " Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PIECE-MENUSCOMS) (RPAQQ PIECE-MENUSCOMS ((FNS CHUNK.MENU.CREATE CHUNK.MENU.GET.REAL.MENU CHUNK.MENU.INVOKE KEYWORD.MENU.CREATE KEYWORD.MENU.GET.MENU KEYWORD.MENU.INVOKE KEYWORD.MENU.MAKE.MENU PIECE.MENU.MAKE.MENU) (BITMAPS CHUNK.MENU.DOWN.BITMAP CHUNK.MENU.UP.BITMAP KEYWORD.MENU.KEYWORD.BITMAP) (DECLARE%: DOEVAL@LOAD (LOCALVARS .T) (GLOBALVARS CHUNK.MENU.DOWN.BITMAP CHUNK.MENU.UP.BITMAP KEYWORD.MENU.KEYWORD.BITMAP)))) (DEFINEQ (CHUNK.MENU.CREATE [LAMBDA (ITEMS PROPERTIES REQUIRED.ITEMS) (* ;  "Edited 4-Apr-88 11:56 by Briggs") (PROG (BLANK.ITEM UP.ITEM DOWN.ITEM CHUNK.COUNT IT.LISTS ITS N MENU.COUNT BLOCK.ITS ITM STR MENUS ) (SETQ BLANK.ITEM (LIST " " (KWOTE '$BLANK$) "No action")) (SETQ UP.ITEM (LIST CHUNK.MENU.UP.BITMAP (KWOTE '$UP$) "Jump to preceding section")) (SETQ DOWN.ITEM (LIST CHUNK.MENU.DOWN.BITMAP (KWOTE '$DOWN$) "Jump to following section")) (SETQ CHUNK.COUNT (OR (LISTGET PROPERTIES 'CHUNK.COUNT) 30)) (SETQ IT.LISTS (CONS)) (SETQ ITS (CONS)) (SETQ N 0) (for ITEM in ITEMS do (if (EQP N CHUNK.COUNT) then (TCONC IT.LISTS (CAR ITS)) (SETQ ITS (CONS)) (SETQ N 0)) (TCONC ITS ITEM) (SETQ N (ADD1 N)) finally (TCONC IT.LISTS (CAR ITS))) (SETQ IT.LISTS (CAR IT.LISTS)) (SETQ MENU.COUNT (LENGTH IT.LISTS)) [SETQ BLOCK.ITS (for LST in IT.LISTS as I from 1 collect (SETQ ITM (CAR LST)) (SETQ STR (if (LISTP ITM) then (CAR ITM) else ITM)) (LIST (CONCAT STR "...") (LIST 'QUOTE (CONS '$CHUNK$ I)) (CONCAT "Jump to menu chunk starting with item " STR] (SETQ MENUS (for LST in IT.LISTS as I from 1 collect (SETQ ITS (CONS)) (if REQUIRED.ITEMS then (for RIT in REQUIRED.ITEMS do (TCONC ITS RIT)) (TCONC ITS BLANK.ITEM)) (if (IGREATERP MENU.COUNT 1) then (for BLOCK.ITM in BLOCK.ITS as J from 1 do (if (EQ J I) then (if (NEQ I 1) then (TCONC ITS UP.ITEM)) (if (NEQ I MENU.COUNT) then (TCONC ITS DOWN.ITEM)) else (TCONC ITS BLOCK.ITM))) (TCONC ITS BLANK.ITEM)) (SETQ ITS (NCONC (CAR ITS) LST)) (PIECE.MENU.MAKE.MENU ITS PROPERTIES))) (RETURN (CONS MENUS 1]) (CHUNK.MENU.GET.REAL.MENU [LAMBDA (CHUNK.MENU) (* ;  "Edited 4-Apr-88 11:57 by Briggs") (PROG (MENUS N) (SETQ MENUS (CAR CHUNK.MENU)) (SETQ N (CDR CHUNK.MENU)) (RETURN (CAR (NTH MENUS N]) (CHUNK.MENU.INVOKE [LAMBDA (CHUNK.MENU POSITION) (* ;  "Edited 4-Apr-88 11:57 by Briggs") (PROG (MENUS N CURRENT.MENU DONE POS NEW.POSITION RESULT THUMB.ITEMS THUMB.MENU PROPERTIES) (SETQ MENUS (CAR CHUNK.MENU)) (GETMOUSESTATE) (SETQ POS (OR POSITION (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY))) [until DONE do (SETQ N (CDR CHUNK.MENU)) (SETQ CURRENT.MENU (CAR (NTH MENUS N))) [SETQ NEW.POSITION (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of POS) (IQUOTIENT (fetch (MENU IMAGEWIDTH) of CURRENT.MENU ) 2)) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of POS) (IQUOTIENT (fetch (MENU IMAGEHEIGHT) of CURRENT.MENU ) 2] (SETQ RESULT (MENU CURRENT.MENU NEW.POSITION)) (if (LISTP RESULT) then (SELECTQ (CAR RESULT) ($CHUNK$ (RPLACD CHUNK.MENU (CDR RESULT))) (SETQ DONE T)) else (SELECTQ RESULT ($BLANK$) ($UP$ (RPLACD CHUNK.MENU (SUB1 N))) ($DOWN$ (RPLACD CHUNK.MENU (ADD1 N))) (SETQ DONE T] (RETURN RESULT]) (KEYWORD.MENU.CREATE [LAMBDA (OBJECTS KEYWORDFN PROPERTIES ITEMFN) (* ;  "Edited 4-Apr-88 11:58 by Briggs") (PROG (TITLE ALST ENTRY ITEM ITEMS KEYWORD.ITEMS KEYWORD) [for OBJECT in OBJECTS do (SETQ ITEM (if ITEMFN then (APPLY* ITEMFN OBJECT) else OBJECT)) (for KEYWD in (APPLY* KEYWORDFN OBJECT) do (SETQ ENTRY (FASSOC KEYWD ALST)) (if ENTRY then (SETQ ITEMS (CADR ENTRY)) (NCONC1 ITEMS ITEM) else (SETQ ALST (CONS (CONS KEYWD (CONS (LIST ITEM) NIL)) ALST)) (SETQ ALST (SORT ALST T] [SETQ KEYWORD.ITEMS (for ENT in ALST collect (SETQ KEYWORD (CAR ENT)) (LIST (CONCAT KEYWORD "'s") (KWOTE (CONS '$KEYWORD$ KEYWORD)) (CONCAT "Jump to section for " KEYWORD] (RETURN (LIST (CAAR ALST) ALST PROPERTIES KEYWORD.ITEMS]) (KEYWORD.MENU.GET.MENU [LAMBDA (ENTRY KEYWORD.MENU) (* ;  "Edited 4-Apr-88 11:58 by Briggs") (OR (CDDR ENTRY) (PROG (ITEMS KEYWORD PROPERTIES KEYWORD.ITEMS TITLE) (SETQ ITEMS (CADR ENTRY)) (SETQ KEYWORD (CAR ENTRY)) (SETQ PROPERTIES (CADDR KEYWORD.MENU)) (SETQ KEYWORD.ITEMS (CADDDR KEYWORD.MENU)) (RPLACD (CDR ENTRY) (CHUNK.MENU.CREATE ITEMS (NCONC (LIST 'TITLE (if (SETQ TITLE (LISTGET PROPERTIES 'TITLE)) then (CONCAT TITLE ": " KEYWORD) else KEYWORD)) PROPERTIES) KEYWORD.ITEMS)) (RETURN (CDDR ENTRY]) (KEYWORD.MENU.INVOKE [LAMBDA (KEYWORD.MENU POSITION) (* ;  "Edited 4-Apr-88 11:59 by Briggs") (PROG (ALST DONE ENTRY RESULT SUBMENU REALMENU NEW.POS POS) (SETQ ALST (CADR KEYWORD.MENU)) (SETQ POS (if POSITION else (GETMOUSESTATE) (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY))) (until DONE do (SETQ ENTRY (FASSOC (CAR KEYWORD.MENU) ALST)) (SETQ SUBMENU (KEYWORD.MENU.GET.MENU ENTRY KEYWORD.MENU)) (SETQ REALMENU (CHUNK.MENU.GET.REAL.MENU SUBMENU)) [SETQ NEW.POS (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of POS) (IQUOTIENT (fetch (MENU IMAGEWIDTH) of REALMENU) 2)) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of POS) (IQUOTIENT (fetch (MENU IMAGEHEIGHT) of REALMENU) 2] (SETQ RESULT (CHUNK.MENU.INVOKE SUBMENU NEW.POS)) (if (AND (LISTP RESULT) (EQ (CAR RESULT) '$KEYWORD$)) then (RPLACA KEYWORD.MENU (CDR RESULT)) else (SETQ DONE T))) (RETURN RESULT]) (KEYWORD.MENU.MAKE.MENU [LAMBDA (ITEMS TITLE PROPERTIES) (* ;  "Edited 4-Apr-88 12:00 by Briggs") (* ;  "Edited 10-AUG-83 17:28 by DAHJr") (CHUNK.MENU.CREATE ITEMS (NCONC (LIST 'TITLE TITLE) PROPERTIES]) (PIECE.MENU.MAKE.MENU [LAMBDA (ITEMS PROPERTIES) (* ;  "Edited 4-Apr-88 12:00 by Briggs") (PROG (MENU VALUE) (SETQ MENU (create MENU ITEMS _ ITEMS)) (AND (SETQ VALUE (LISTGET PROPERTIES 'TITLE)) (replace (MENU TITLE) of MENU with VALUE)) (AND (SETQ VALUE (LISTGET PROPERTIES 'CENTERFLG)) (replace (MENU CENTERFLG) of MENU with VALUE)) (AND (SETQ VALUE (LISTGET PROPERTIES 'MENUFONT)) (replace (MENU MENUFONT) of MENU with VALUE)) (AND (SETQ VALUE (LISTGET PROPERTIES 'ITEMWIDTH)) (replace (MENU ITEMWIDTH) of MENU with VALUE)) (AND (SETQ VALUE (LISTGET PROPERTIES 'ITEMHEIGHT)) (replace (MENU ITEMHEIGHT) of MENU with VALUE)) (AND (SETQ VALUE (LISTGET PROPERTIES 'MENUBORDERSIZE)) (replace (MENU MENUBORDERSIZE) of MENU with VALUE)) (AND (SETQ VALUE (LISTGET PROPERTIES 'MENUOUTLINESIZE)) (replace (MENU MENUOUTLINESIZE) of MENU with VALUE)) (RETURN MENU]) ) (RPAQQ CHUNK.MENU.DOWN.BITMAP #*(56 12)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@@C@@@@@@@@@@@@F@@F@@@@@@@@@@@@C@@L@@@@@@@@@@@@AHAH@@@@@@@@@@@@@LC@@@@@@@@@@@@@@FF@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ CHUNK.MENU.UP.BITMAP #*(56 12)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@FF@@@@@@@@@@@@@@LC@@@@@@@@@@@@@AHAH@@@@@@@@@@@@C@@L@@@@@@@@@@@@F@@F@@@@@@@@@@@@L@@C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQQ KEYWORD.MENU.KEYWORD.BITMAP #*(24 10)AL@@@@@@CF@@@@@@FC@@@@@@LAOOOO@@LAOOOO@@FC@@AH@@CF@@GN@@AL@@GF@@@@@@FF@@@@@@DB@@) (DECLARE%: DOEVAL@LOAD (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS .T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHUNK.MENU.DOWN.BITMAP CHUNK.MENU.UP.BITMAP KEYWORD.MENU.KEYWORD.BITMAP) ) ) (PUTPROPS PIECE-MENUS COPYRIGHT ("Xerox Corporation" 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1249 14902 (CHUNK.MENU.CREATE 1259 . 4388) (CHUNK.MENU.GET.REAL.MENU 4390 . 4723) ( CHUNK.MENU.INVOKE 4725 . 7610) (KEYWORD.MENU.CREATE 7612 . 9215) (KEYWORD.MENU.GET.MENU 9217 . 10474) (KEYWORD.MENU.INVOKE 10476 . 13139) (KEYWORD.MENU.MAKE.MENU 13141 . 13621) (PIECE.MENU.MAKE.MENU 13623 . 14900))))) STOP \ No newline at end of file diff --git a/lispusers/PIECE-MENUS.TEDIT b/lispusers/PIECE-MENUS.TEDIT new file mode 100644 index 00000000..8f3d22b4 Binary files /dev/null and b/lispusers/PIECE-MENUS.TEDIT differ diff --git a/lispusers/PIXELBLT b/lispusers/PIXELBLT new file mode 100644 index 00000000..60449dd7 --- /dev/null +++ b/lispusers/PIXELBLT @@ -0,0 +1 @@ +(FILECREATED "30-Sep-85 11:41:40" {ERIS}LIBRARY>PIXELBLT.;2 5205 changes to: (FNS PIXELBLT) previous date: "14-Jun-85 18:58:32" {ERIS}LIBRARY>PIXELBLT.;1) (* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PIXELBLTCOMS) (RPAQQ PIXELBLTCOMS ((FNS BLUE+YELLOW=GREEN PIXELBLT PIXELBLT.TABLEBUILDER SPECKLE TESTFN) (VARS BLUECOLOR GREENCOLOR YELLOWCOLOR))) (DEFINEQ (BLUE+YELLOW=GREEN [LAMBDA (SOURCE DEST XLO YLO) (* hdj "14-Jun-85 17:38") (LET ((BLUECOLOR 1) (YELLOWCOLOR 4) (GREENCOLOR 2)) (if (OR (AND (EQ SOURCE BLUECOLOR) (EQ DEST YELLOWCOLOR)) (AND (EQ SOURCE YELLOWCOLOR) (EQ DEST BLUECOLOR))) then GREENCOLOR else SOURCE]) (PIXELBLT [LAMBDA (COLORTABLE SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT) (* hdj "30-Sep-85 11:26") (PROG ((REALWIDTH (OR WIDTH (BITMAPWIDTH SOURCEBITMAP))) (REALHEIGHT (OR HEIGHT (BITMAPHEIGHT SOURCEBITMAP))) (REALDESTINATIONLEFT (OR DESTINATIONLEFT 0)) (REALDESTINATIONBOTTOM (OR DESTINATIONBOTTOM 0)) (REALSOURCELEFT (OR SOURCELEFT 0)) (REALSOURCEBOTTOM (OR SOURCEBOTTOM 0)) VALID-SOURCE-REGION VALID-DEST-REGION) (\DTEST REALWIDTH (QUOTE SMALLP)) (\DTEST REALHEIGHT (QUOTE SMALLP)) (\DTEST REALDESTINATIONLEFT (QUOTE SMALLP)) (\DTEST REALDESTINATIONBOTTOM (QUOTE SMALLP)) (\DTEST COLORTABLE (QUOTE ARRAYP)) (\DTEST SOURCEBITMAP (QUOTE BITMAP)) (\DTEST DESTBITMAP (QUOTE BITMAP)) (OR (AND (IGEQ REALSOURCELEFT 0) (IGEQ REALSOURCEBOTTOM 0) (IGEQ REALWIDTH 0) (IGEQ REALHEIGHT 0) (ILESSP REALSOURCELEFT (BITMAPWIDTH SOURCEBITMAP)) (ILESSP REALSOURCEBOTTOM (BITMAPHEIGHT SOURCEBITMAP)) (ILESSP REALDESTINATIONLEFT (BITMAPWIDTH DESTBITMAP)) (ILESSP REALDESTINATIONBOTTOM (BITMAPHEIGHT DESTBITMAP))) (RETURN)) (SETQ VALID-SOURCE-REGION (INTERSECTREGIONS (CREATEREGION 0 0 (BITMAPWIDTH SOURCEBITMAP) (BITMAPHEIGHT SOURCEBITMAP)) (CREATEREGION REALSOURCELEFT REALSOURCEBOTTOM REALWIDTH REALHEIGHT))) (SETQ VALID-DEST-REGION (INTERSECTREGIONS (CREATEREGION 0 0 (BITMAPWIDTH DESTBITMAP) (BITMAPHEIGHT DESTBITMAP)) (CREATEREGION REALDESTINATIONLEFT REALDESTINATIONBOTTOM REALWIDTH REALHEIGHT))) (NOT-PIXELBLT (fetch (ARRAYP BASE) of COLORTABLE) SOURCEBITMAP REALSOURCELEFT REALSOURCEBOTTOM DESTBITMAP REALDESTINATIONLEFT REALDESTINATIONBOTTOM (IMIN (fetch WIDTH of VALID-SOURCE-REGION) (fetch WIDTH of VALID-DEST-REGION)) 0 (IMIN (fetch HEIGHT of VALID-SOURCE-REGION) (fetch HEIGHT of VALID-DEST-REGION]) (PIXELBLT.TABLEBUILDER [LAMBDA (FN) (* hdj "14-Jun-85 16:41") (LET ((TABLE (ARRAY 256 (QUOTE WORD) 0 0 128))) [for sourceNybble from 0 to 15 do (for destNybble from 0 to 15 do (for XLowBit from 0 to 1 do (for YLowBit from 0 to 1 do (* The (LLSH ... (UNFOLD ...)) stuff below maps from (XLowBit YLowBit) into the position of the corresponding nybble in the value. Believe it or not, we are saying (0 0) -> LLSH 12 , (1 0) -> LLSH 8 , (0 1) -> LLSH 4 ,  (1 1) -> LLSH 0) (LET ((ELEMENT (LOGOR (LLSH sourceNybble 4) destNybble))) (SETA TABLE ELEMENT (LOGOR (ELT TABLE ELEMENT) (LLSH (APPLY* FN sourceNybble destNybble XLowBit YLowBit) (UNFOLD (IDIFFERENCE (IDIFFERENCE 3 (UNFOLD YLowBit 2)) XLowBit) 4] TABLE]) (SPECKLE [LAMBDA (SOURCE DEST XLO YLO) (* hdj "14-Jun-85 18:24") (LET ((BLUECOLOR 1) (YELLOWCOLOR 4) (GREENCOLOR 2) (REDCOLOR 3)) (if (OR (AND (ODDP XLO) (EQ SOURCE YELLOWCOLOR) (EQ DEST BLUECOLOR)) (AND (ODDP XLO) (EQ SOURCE BLUECOLOR) (EQ DEST YELLOWCOLOR))) then YELLOWCOLOR elseif (OR (AND (EVENP XLO) (EQ SOURCE YELLOWCOLOR) (EQ DEST BLUECOLOR)) (AND (EVENP XLO) (EQ SOURCE BLUECOLOR) (EQ DEST YELLOWCOLOR))) then REDCOLOR else SOURCE]) (TESTFN [LAMBDA (SOURCE DEST XLOW YLOW) (* hdj "14-Jun-85 16:17") (if (NEQ DEST 15) then SOURCE else DEST]) ) (RPAQQ BLUECOLOR 1) (RPAQQ GREENCOLOR 2) (RPAQQ YELLOWCOLOR 4) (PUTPROPS PIXELBLT COPYRIGHT ("Xerox Corporation" 1985)) (DECLARE: DONTCOPY (FILEMAP (NIL (443 5048 (BLUE+YELLOW=GREEN 453 . 842) (PIXELBLT 844 . 3166) (PIXELBLT.TABLEBUILDER 3168 . 4216) (SPECKLE 4218 . 4873) (TESTFN 4875 . 5046))))) STOP \ No newline at end of file diff --git a/lispusers/PLAY b/lispusers/PLAY new file mode 100644 index 00000000..84631588 --- /dev/null +++ b/lispusers/PLAY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Sep-91 12:55:09" |{PELE:MV:ENVOS}MEDLEY>PLAY.;2| 38792 changes to%: (VARS PLAYCOMS DEMO.MELODY DEMO.TUNE) (RECORDS MELODY PASSAGE BEEP) (FNS PLAY.TRANSCRIBE) previous date%: "11-Jul-86 13:55:55" |{PELE:MV:ENVOS}MEDLEY>PLAY.;1|) (* ; " Copyright (c) 1986, 1991 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PLAYCOMS) (RPAQQ PLAYCOMS ( (* ; "PLAY -- By Kelly Roach. *") (COMS (* ; "PLAYLISP *") (CONSTANTS (PLAY.ROOM 10000) (PLAY.TOY 32) (PLAY.FREQA 1760) (PLAY.SILENT NIL)) (INITVARS (PLAY.OCTAVE NIL) (PLAY.DURATION NIL) (PLAY.BREAK NIL) (PLAY.SHARP NIL) (PLAY.FLAT NIL) (PLAY.TWELFTHS NIL) (PLAY.POWERS NIL)) (RECORDS MELODY PASSAGE BEEP) (FNS PLAY.RESTART PLAY.NOTES PLAY.MELODY PLAY.MELODY1 PLAY.OCTAVE PLAY.TEMPO PLAY.KEY PLAY.REPEAT PLAY.PASSAGE PLAY.NOTE PLAY.NOTE1)) (COMS (* ; "PLAYKBD *") (INITVARS (PLAY.KEYBOARD.ALIST NIL) (PLAY.TRANSCRIBE.ALIST NIL)) (FNS PLAY.KEYBOARD PLAY.TRANSCRIBE PLAY.ADJUST.TEMPO PLAY.ADJUST.PITCH)) (COMS (* ; "PLAYMESA *") (INITVARS (PLAY.MESA.OCTAVE NIL) (PLAY.MESA.TRIPLE NIL) (PLAY.MESA.DURATION NIL) (PLAY.MESA.BREAK NIL)) (FNS PLAY.MESA PLAY.MESA.NOTE PLAY.MESA.NOTE1)) (COMS (* ; "DEMO *") (VARS DEMO.MELODY DEMO.TUNE) (FNS PLAY.DEMO)) (P (PLAY.RESTART)))) (* ; "PLAY -- By Kelly Roach. *") (* ; "PLAYLISP *") (DECLARE%: EVAL@COMPILE (RPAQQ PLAY.ROOM 10000) (RPAQQ PLAY.TOY 32) (RPAQQ PLAY.FREQA 1760) (RPAQQ PLAY.SILENT NIL) (CONSTANTS (PLAY.ROOM 10000) (PLAY.TOY 32) (PLAY.FREQA 1760) (PLAY.SILENT NIL)) ) (RPAQ? PLAY.OCTAVE NIL) (RPAQ? PLAY.DURATION NIL) (RPAQ? PLAY.BREAK NIL) (RPAQ? PLAY.SHARP NIL) (RPAQ? PLAY.FLAT NIL) (RPAQ? PLAY.TWELFTHS NIL) (RPAQ? PLAY.POWERS NIL) (DECLARE%: EVAL@COMPILE (TYPERECORD MELODY (TEMPO KEY METER BEAT PASSAGES)) (RECORD PASSAGE (REPEATS MEASURES)) (RECORD BEEP (FREQ . DURATION)) ) (DEFINEQ (PLAY.RESTART [LAMBDA NIL (* kbr%: " 8-Feb-84 10:47") (PROG NIL (* PLAY. *) (SETQ PLAY.TWELFTHS (ARRAY 7 'FIXP 0 0)) (for I from 0 to 6 as J in '(12 14 3 5 7 8 10) do (SETA PLAY.TWELFTHS I J)) (SETQ PLAY.POWERS (ARRAY 12 'FIXP 0 0)) [for I from 0 to 11 do (SETA PLAY.POWERS I (FIXR (FTIMES (EXPT 2.0 (FQUOTIENT (FLOAT I) 12.0)) (FLOAT PLAY.ROOM] (* Global Environment.  *) (PLAY.OCTAVE 8) (PLAY.TEMPO 'MODERATE) (PLAY.KEY 'CMAJOR) (* KEYBOARD. *) [SETQ PLAY.KEYBOARD.ALIST (for CODE in (CHCON "ASDFGHJKL;'_WRTUIO[]") as NOTE in '(c >d >e c# >d#) collect (CONS CODE (fetch (BEEP FREQ) of (CAR (PLAY.NOTE NOTE] (SETQ PLAY.TRANSCRIBE.ALIST (for BUCKET in PLAY.KEYBOARD.ALIST as NOTE in '(c >d >e c# >d#) collect (CONS (CDR BUCKET) NOTE]) (PLAY.NOTES [LAMBDA (NOTES) (* kbr%: " 8-Feb-84 10:47") (* Converts series of NOTES into a  TUNE sutiable for playing by  PLAYTUNE. *) (FOR NOTE IN NOTES JOIN (PLAY.NOTE NOTE]) (PLAY.MELODY [LAMBDA (MELODY) (* kbr%: " 8-Feb-84 10:47") (* Converts a MELODY into a TUNE  sutiable for playing by PLAYTUNE.  *) (PROG (TUNE) (COND ((NOT (TYPE? MELODY MELODY)) (printout T "Illegal MELODY " MELODY " ignored") (RETURN NIL))) (PLAY.OCTAVE 8) (PLAY.TEMPO (fetch (MELODY TEMPO) of MELODY) (fetch (MELODY BEAT) of MELODY)) (PLAY.KEY (fetch (MELODY KEY) of MELODY)) (SETQ TUNE (PLAY.MELODY1 MELODY)) (RETURN TUNE]) (PLAY.MELODY1 [LAMBDA (MELODY) (* kbr%: " 8-Feb-84 10:47") (PROG (MAXREPEAT TUNE) (* Calc MAXREPEAT.  *) (SETQ MAXREPEAT MIN.FIXP) [FOR PASSAGE IN (fetch (MELODY PASSAGES) of MELODY) DO (SETQ MAXREPEAT (IMAX MAXREPEAT (APPLY 'IMAX (fetch (PASSAGE REPEATS) of PASSAGE] (* Calc TUNE. *) (SETQ TUNE (FOR REPEAT FROM 1 TO MAXREPEAT JOIN (PLAY.REPEAT MELODY REPEAT))) (RETURN TUNE]) (PLAY.OCTAVE [LAMBDA (OCTAVE) (* kbr%: " 8-Feb-84 10:47") (PROG NIL (SETQ PLAY.OCTAVE OCTAVE]) (PLAY.TEMPO [LAMBDA (TEMPO BEAT) (* kbr%: " 8-Feb-84 10:47") (* Establish TEMPO = beats per  minute. *) (COND ((NULL BEAT) (SETQ BEAT 4))) (PROG NIL (SETQ TEMPO (SELECTQ TEMPO ((ALLEGRO FAST) 120) ((MODERATO MODERATE NIL) 90) ((ADAGIO SLOW) 60) TEMPO)) (SETQ PLAY.DURATION (IQUOTIENT (ITIMES 600000 BEAT) (ITIMES TEMPO 2]) (PLAY.KEY [LAMBDA (KEY) (* kbr%: "11-Jul-86 12:59") (* Establish KEY signature.  *) (PROG NIL [SETQ KEY (COND ((LISTP KEY) KEY) (T (SELECTQ KEY (CMAJOR '(%#)) (GMAJOR '(%# F)) (DMAJOR '(%# F C)) (AMAJOR '(%# F C G)) (EMAJOR '(%# F C G D)) (BMAJOR '(%# F C G D A)) (F#MAJOR '(%# F C G D A E)) (C#MAJOR '(%# F C G D A E B)) (FMAJOR '(@ B)) (B@MAJOR '(@ B E)) (E@MAJOR '(@ B E A)) (A@MAJOR '(@ B E A D)) (D@MAJOR '(@ B E A D G)) (G@MAJOR '(@ B E A D G C)) (C@MAJOR '(@ B E A D G C F)) NIL] (SELECTQ (CAR KEY) (%# (SETQ PLAY.SHARP (CDR KEY)) (SETQ PLAY.FLAT NIL)) (@ (SETQ PLAY.SHARP NIL) (SETQ PLAY.FLAT (CDR KEY))) (PROGN (SETQ PLAY.SHARP NIL) (SETQ PLAY.FLAT NIL))) (PROGN (SETQ PLAY.SHARP (for LETTER in PLAY.SHARP collect (CHCON1 LETTER))) (SETQ PLAY.FLAT (for LETTER in PLAY.FLAT collect (CHCON1 LETTER]) (PLAY.REPEAT [LAMBDA (MELODY REPEAT) (* kbr%: " 8-Feb-84 10:47") (* Return TUNE for this REPEAT of  MELODY. *) (FOR PASSAGE IN (fetch (MELODY PASSAGES) of MELODY) WHEN (MEMB REPEAT (fetch (PASSAGE REPEATS) of PASSAGE)) JOIN (PLAY.PASSAGE PASSAGE]) (PLAY.PASSAGE [LAMBDA (PASSAGE) (* kbr%: " 8-Feb-84 10:47") (* Return TUNE for PASSAGE.  *) (FOR MEASURE IN (fetch (PASSAGE MEASURES) of PASSAGE) JOIN (PLAY.NOTES MEASURE]) (PLAY.NOTE [LAMBDA (NOTE) (* kbr%: "11-Jul-86 12:56") (* Return TUNE for NOTE.  *) (PROG (LETTER OCTAVE DURATION BREAK ACCIDENTAL DOTS TUNE) (SETQ OCTAVE PLAY.OCTAVE) (SETQ DURATION PLAY.DURATION) (SETQ BREAK PLAY.ROOM) (SETQ DOTS 0) [for CODE in (CHCON NOTE) do (SELCHARQ CODE ((A B C D E F G R a b c d e f g r) (SETQ LETTER CODE)) ("<" (SETQ OCTAVE (ITIMES OCTAVE 2))) (">" (SETQ OCTAVE (IQUOTIENT OCTAVE 2))) ("x" (SETQ DURATION (ITIMES DURATION 2))) ("/" "/" (SETQ DURATION (IQUOTIENT DURATION 2))) (("1" "2" "3" "4" "5" "6" "7" "8" "9") [SETQ DURATION (IQUOTIENT (ITIMES (CHARACTER CODE) DURATION) (ADD1 (CHARACTER CODE]) ("+" (SETQ DOTS (ADD1 DOTS))) ("^" (SETQ BREAK (ITIMES BREAK 2))) ("_" (SETQ BREAK (IQUOTIENT BREAK 2))) ("@" [COND ((NULL ACCIDENTAL) (SETQ ACCIDENTAL -1)) (T (SETQ ACCIDENTAL (SUB1 ACCIDENTAL]) ("#" [COND ((NULL ACCIDENTAL) (SETQ ACCIDENTAL 1)) (T (SETQ ACCIDENTAL (ADD1 ACCIDENTAL]) ((N n) (SETQ ACCIDENTAL 0)) (PROGN (printout T "Illegal note " NOTE " ignored.") (RETURN NIL] [COND ((NULL ACCIDENTAL) (COND ((MEMB LETTER PLAY.SHARP) (SETQ ACCIDENTAL 1)) ((MEMB LETTER PLAY.FLAT) (SETQ ACCIDENTAL -1)) (T (SETQ ACCIDENTAL 0] [SELECTQ DOTS (0 (* Do nothing. *)) (1 (SETQ DURATION (IQUOTIENT (ITIMES 3 DURATION) 2))) (2 (SETQ DURATION (IQUOTIENT (ITIMES 7 DURATION) 4))) (SETQ DURATION (IQUOTIENT (ITIMES (SUB1 (EXPT 2 (ADD1 DOTS))) DURATION) (EXPT 2 DOTS] (* Compute DURATION & BREAK.  *) (SETQ BREAK (IQUOTIENT (ITIMES 3 BREAK DURATION) (ITIMES 8 PLAY.ROOM))) (SELCHARQ LETTER ((A B C D E F G R) (SETQ BREAK 0)) (r (SETQ BREAK 0) (SETQ LETTER (CHARCODE R))) ((a b c d e f g) (SETQ BREAK (IMIN BREAK DURATION)) (SETQ DURATION (IDIFFERENCE DURATION BREAK)) [SETQ LETTER (IPLUS LETTER (IDIFFERENCE (CHARCODE A) (CHARCODE a]) (SHOULDNT)) (* Compute TUNE. *) (SETQ TUNE (PLAY.NOTE1 OCTAVE LETTER ACCIDENTAL DURATION BREAK)) (RETURN TUNE]) (PLAY.NOTE1 [LAMBDA (OCTAVE LETTER ACCIDENTAL DURATION BREAK) (* kbr%: " 8-Feb-84 10:47") (PROG (FREQ TWELFTH TUNE) (* Compute FREQ. *) [COND ((IEQP LETTER (CHARCODE R)) (* Rest. *) (SETQ FREQ PLAY.SILENT)) (T (* Compute TWELFTH.  *) [SETQ TWELFTH (ELT PLAY.TWELFTHS (IDIFFERENCE LETTER (CHARCODE A] (SETQ TWELFTH (IPLUS TWELFTH ACCIDENTAL)) [COND [(IGEQ TWELFTH 12) (while (IGEQ TWELFTH 12) do (SETQ TWELFTH (IDIFFERENCE TWELFTH 12)) (SETQ OCTAVE (IQUOTIENT OCTAVE 2] ((ILESSP TWELFTH 0) (WHILE (ILESSP TWELFTH 0) DO (SETQ TWELFTH (IPLUS TWELFTH 12)) (SETQ OCTAVE (ITIMES OCTAVE 2] (* Constant PLAY.TOY is to help reduce round off error.  Adding (IQUOTIENT OCTAVE 2) then dividing by OCTAVE amounts to dividing by  OCTAVE then adding one-half, but less round off error.  *) (SETQ FREQ (ITIMES PLAY.TOY PLAY.FREQA)) (SETQ OCTAVE (ITIMES PLAY.TOY OCTAVE)) (SETQ FREQ (IQUOTIENT (ITIMES FREQ (ELT PLAY.POWERS TWELFTH)) PLAY.ROOM)) (SETQ FREQ (IQUOTIENT (IPLUS FREQ (IQUOTIENT OCTAVE 2)) OCTAVE] (* Compute TUNE. *) [COND ((NOT (ZEROP BREAK)) (push TUNE (create BEEP FREQ _ PLAY.SILENT DURATION _ BREAK] [COND ((NOT (ZEROP DURATION)) (push TUNE (create BEEP FREQ _ FREQ DURATION _ DURATION] (* Okey Dokey. *) (RETURN TUNE]) ) (* ; "PLAYKBD *") (RPAQ? PLAY.KEYBOARD.ALIST NIL) (RPAQ? PLAY.TRANSCRIBE.ALIST NIL) (DEFINEQ (PLAY.KEYBOARD [LAMBDA NIL (* kbr%: " 5-Feb-84 19:55") (PROG (KEY FREQ TUNE CLOCK OLDCLOCK OCTAVE) (SETQ OLDCLOCK (CLOCK 0)) (SETQ OCTAVE PLAY.OCTAVE) [do (* Get note. *) (SETQ KEY (\GETKEY)) (SELCHARQ KEY (" " (RETURN)) (">" (SETQ OCTAVE (ITIMES OCTAVE 2))) ("<" (SETQ OCTAVE (IQUOTIENT OCTAVE 2))) (PROGN (* Record rest. *) (SETQ CLOCK (CLOCK 0)) (push TUNE (create BEEP FREQ _ PLAY.SILENT DURATION _ (IDIFFERENCE CLOCK OLDCLOCK))) (SETQ OLDCLOCK CLOCK) (* Play note. *) (SETQ FREQ (CDR (ASSOC KEY PLAY.KEYBOARD.ALIST))) (SETQ FREQ (IQUOTIENT (ITIMES FREQ OCTAVE) PLAY.OCTAVE)) (COND (FREQ (BEEPON FREQ) (while (KEYDOWNP (CHARACTER KEY)) do (* Hold note. *)) (BEEPOFF))) (* Record note. *) (SETQ CLOCK (CLOCK 0)) (push TUNE (create BEEP FREQ _ FREQ DURATION _ (IDIFFERENCE CLOCK OLDCLOCK))) (SETQ OLDCLOCK CLOCK] (SETQ TUNE (DREVERSE TUNE)) (RETURN TUNE]) (PLAY.TRANSCRIBE [LAMBDA (TUNE) (* ; "Edited 28-Sep-91 12:54 by jds") (* Transcribe TUNE into NOTES.  *) (for BEEP in TUNE when (NOT (EQ (fetch (BEEP FREQ) of BEEP) PLAY.SILENT)) collect (CDR (ASSOC (fetch (BEEP FREQ) of BEEP) PLAY.TRANSCRIBE.ALIST]) (PLAY.ADJUST.TEMPO [LAMBDA (TUNE FACTOR) (* kbr%: " 5-Feb-84 19:55") (* Adjust tempo of TUNE by FACTOR.  *) (PROG (ANSWER) (SETQ FACTOR (FIXR (FTIMES (FLOAT FACTOR) PLAY.ROOM))) [SETQ ANSWER (for BEEP in TUNE collect (create BEEP FREQ _ (fetch (BEEP FREQ) of BEEP) DURATION _ (IQUOTIENT (ITIMES FACTOR (fetch (BEEP DURATION) of BEEP)) PLAY.ROOM] (RETURN ANSWER]) (PLAY.ADJUST.PITCH [LAMBDA (TUNE SEMITONES) (* kbr%: " 5-Feb-84 19:55") (* Adjust pitch of TUNE by number of  SEMITONES. *) (PROG (FACTOR ANSWER) (SETQ FACTOR (FIXR (FTIMES (EXPT 2.0 (FQUOTIENT (FLOAT SEMITONES) 12.0)) PLAY.ROOM))) [SETQ ANSWER (for BEEP in TUNE collect (create BEEP FREQ _ (COND ((EQ (fetch (BEEP FREQ) of BEEP) PLAY.SILENT) PLAY.SILENT) (T (IQUOTIENT (ITIMES FACTOR (fetch (BEEP FREQ) of BEEP)) PLAY.ROOM))) DURATION _ (fetch (BEEP DURATION) of BEEP] (RETURN ANSWER]) ) (* ; "PLAYMESA *") (RPAQ? PLAY.MESA.OCTAVE NIL) (RPAQ? PLAY.MESA.TRIPLE NIL) (RPAQ? PLAY.MESA.DURATION NIL) (RPAQ? PLAY.MESA.BREAK NIL) (DEFINEQ (PLAY.MESA [LAMBDA (STRING DURATION) (* kbr%: " 5-Feb-84 19:55") (COND ((NULL DURATION) (SETQ DURATION 0))) (PROG (STREAM NOTES NOTE) (SETQ PLAY.MESA.NOTES NIL) (SETQ PLAY.MESA.OCTAVE 0) (SETQ PLAY.MESA.TRIPLE NIL) (SETQ PLAY.MESA.DURATION DURATION) (SETQ PLAY.MESA.BREAK 0) (SETQ STREAM (OPENSTRINGSTREAM STRING)) (SETQ NOTES (while (AND (NOT (EOFP STREAM)) (SETQ NOTE (PLAY.MESA.NOTE STREAM))) collect NOTE)) (RETURN NOTES]) (PLAY.MESA.NOTE [LAMBDA (STREAM) (* kbr%: " 5-Feb-84 19:55") (* Read mesa note then add lisp note  to PLAY.MESA.NOTES.  *) (PROG (LETTER SHARP DURATION DOT CODE NOTE) (* Read mesa note.  *) (SETQ SHARP 0) (SETQ DURATION PLAY.MESA.DURATION) (SETQ DOT 0) (while [AND (NOT (EOFP STREAM)) (OR (NULL LETTER) (MEMB (\PEEKBIN STREAM) '(%# -] do (SETQ CODE (\BIN STREAM)) (SELCHARQ CODE ((A B C D E F G a b c d e f g) (SETQ LETTER CODE)) (%% (SETQ LETTER (CHARCODE r))) ("#" (SETQ SHARP (ADD1 SHARP))) (">" (SETQ PLAY.MESA.OCTAVE (ADD1 PLAY.MESA.OCTAVE))) ("<" (SETQ PLAY.MESA.OCTAVE (SUB1 PLAY.MESA.OCTAVE))) ("/" "/" (SETQ PLAY.MESA.DURATION (SUB1 PLAY.MESA.DURATION)) (SETQ DURATION (SUB1 DURATION))) ("*" (SETQ PLAY.MESA.DURATION (ADD1 PLAY.MESA.DURATION)) (SETQ DURATION (ADD1 DURATION))) ("^" (SETQ PLAY.MESA.BREAK (ADD1 PLAY.MESA.BREAK))) ("_" (SETQ PLAY.MESA.BREAK (SUB1 PLAY.MESA.BREAK))) ("+" (SETQ DOT (ADD1 DOT))) ("-" (SETQ DURATION (SUB1 DURATION))) ("(" (SETQ PLAY.MESA.TRIPLE T)) (")" (SETQ PLAY.MESA.TRIPLE NIL)) (* Do nothing. *))) (* Calc Lisp note.  *) [COND (LETTER (SETQ NOTE (PLAY.MESA.NOTE1 LETTER SHARP DURATION DOT] (* Okey Dokey. *) (RETURN NOTE]) (PLAY.MESA.NOTE1 [LAMBDA (LETTER SHARP DURATION DOT) (* kbr%: " 5-Feb-84 19:55") (PROG (NOTE) [SETQ NOTE (PACKC (\BQUOTE ([\COMMAAT (COND ((NOT (IEQP LETTER (CHARCODE r))) (COND ((IGREATERP PLAY.MESA.OCTAVE 0) (FOR I FROM 1 TO PLAY.MESA.OCTAVE COLLECT (CHARCODE >))) ((ILESSP PLAY.MESA.OCTAVE 0) (FOR I FROM 1 TO (IMINUS PLAY.MESA.OCTAVE) COLLECT (CHARCODE <] (\COMMA LETTER) (\COMMAAT (FOR I FROM 1 TO SHARP COLLECT (CHARCODE %#))) [\COMMAAT (COND (PLAY.MESA.TRIPLE (LIST (CHARCODE "3"] [\COMMAAT (COND ((IGREATERP DURATION 0) (FOR I FROM 1 TO DURATION COLLECT (CHARCODE x))) ((ILESSP DURATION 0) (FOR I FROM 1 TO (IMINUS DURATION) COLLECT (CHARCODE /] (\COMMAAT (FOR I FROM 1 TO DOT COLLECT (CHARCODE +] (RETURN NOTE]) ) (* ; "DEMO *") (RPAQQ DEMO.MELODY [MELODY MODERATE (%# F) 4 4 (((1) ((b/+ >c//) (>Dx >d/+ b// a/+ b//) (gx+ b/+ b//) (A/+ G// E e/+ e// b/+ b//) (ax+ b/+ >c//) (>Dx >d/+ b// a/+ b//) (gx+ b/+ b//) (A/+ G// E e/+ e// b/+ b//) (ax+ b/ >c//) (>Dx >d/+ b// a/+ b//) (gx+ b/+ b//) (A/+ G// E e/+ e// b/+ b//) (ax+ b/ >c//+) (>Dx >d/+ b// a/+ b//) (gx+ b/+ b/) (a/+ g// ex b/+ b//) (axx))) ((1 2 3) ((>d >d >d >d/+ >e//) (a/+ a// a/+ a// ax) (a/+ a// a/+ a// ax) (g/+ g// g/+ g// gx) (>d >d >d >d/+ >e//) (a/+ a// a/+ a// ax) (a/+ a// a/+ a// ax) (g/+ g// g/+ g// g))) ((1 2) ((b/+ >c//) (>Dx >d/+ b// a/+ b/) (gx+ b/+ b//) (a/+ g// ex b/+ b//) (ax+ b/+ >c/) (>Dx >d/+ b// a/+ b//))) ((1) ((gx+ d3/ e3/ f3/) (g/ B// A#// b/ B// A#// b MEDLEY>PLOT.;3| 211578 changes to%: (FNS COPYMENU PLOTPROPMACRO ADDPLOTOBJECT ADJUSTSCALE? ADJUSTVIEWPORT APPLY.AFTERFN.MACRO ASKFORLABEL ASKFORSCALE BOXREGION CHOOSESCALE CHOOSETICS CLOSEPLOTWINDOW CLOSESTPLOTOBJECT COMPOUNDSUBTYPE COMPUTEBOTTOMMARGIN COMPUTELEFTMARGIN COMPUTERIGHTMARGIN COMPUTETOPMARGIN CREATEPLOT CREATEPLOTFNS CREATEPLOTOBJECT DEFAULTSCALEFN DEFAULTTICFN DEFAULTTICMETHOD DELETEPLOTOBJECT DESELECTPLOTOBJECT DISTANCETOPLOTOBJECT DRAWBOTTOMMARGIN DRAWLEFTMARGIN DRAWMARGIN DRAWPLOTOBJECT DRAWPLOT DRAWRIGHTMARGIN DRAWTOPMARGIN ERASEPLOTOBJECT EXTENDEDSCALEFN EXTENTOFPLOTOBJECT EXTENTOFPLOT GETPLOTWINDOW GETTICLIST HIGHLIGHTPLOTOBJECT LABELPLOTOBJECT LOWLIGHTPLOTOBJECT MANUALRESCALE MINSTREAMREGIONSIZE MOVEPLOTOBJECT OPENPLOTWINDOW PLOT.BUTTONEVENTFN PLOT.CLOSEFN PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOT.HARDCOPYFN PLOT.ICONFN PLOT.LABELTOWORLD PLOT.REPAINTFN PLOT.RESET PLOT.SETUP PLOT.SKETCH.CREATE PLOT.WHENSELECTEDFN PLOT.WORLDTOLABEL PLOTADDMENUITEMS PLOTADDPROP PLOTAXISINTERVAL PLOTDELMENUITEMS PLOTDELPROP PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTOBJECTADDPROP PLOTOBJECTDELPROP PLOTOBJECTLABEL PLOTOBJECTPROP PLOTOBJECTPROPMACRO PLOTOBJECTSUBTYPE PLOTOPERROR PLOTPROMPT PLOTPROP PLOTREMPROP PLOTSCALEFN PLOTTICFN PLOTTICINFO PLOTTICMETHOD PLOTTICS PRINTFONT PRINTMENU REDRAWPLOTWINDOW RELABELSELECTEDPLOTOBJECT RESCALEPLOT SCALE TOGGELLABEL TOGGLEEXTENDEDAXES TOGGLEFIXEDMENU TOGGLETICS TRANSLATEPLOTOBJECT UNDELETEPLOTOBJECT UNLABELPLOTOBJECT WHICHLABEL WHICHPLOT PLOT.PRINTNUM PLOT.FNUM-STRING PLOT.ENUM-STRING CREATETICLISTS NORMALIZE-TICLIST DRAW-TICS-LEFT-RIGHT DRAW-TICS-TOP-BOTTOM DRAW-LABEL-LEFT-RIGHT DRAW-LABEL-TOP-BOTTOM COPYPLOTOBJECT COPYPLOT PLOTOBJECTPRINT PRINTPLOTOBJECT PRINTPLOT READFONT READMENU READPLOTOBJECT READPLOT PRINT-VECTOR READ-VECTOR PLOT.EXP10 PLOT.LOG10 PLOT.FLOOR PLOT.CEILING SINEWAVE CREATEPLOTIMAGEOBJ CREATEPLOTBITMAPOBJ PLIO.BUTTONEVENTINFN PLIO.COPYFN PLIO.GETFN PLIO.PUTFN PLIO.REINSERTOBJ PLOT.COPYBUTTONEVENTFN PLIO.DISPLAYFN PLIO.IMAGEBOXFN PLIO.EDITCLOSEFN IMAGE.OBJECT.CHANGED) (FILEPKGCOMS PLOTS) (VARS PLOTCOMS) previous date%: "28-Sep-91 17:11:50" |{PELE:MV:ENVOS}MEDLEY>PLOT.;2|) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1991, 1992 by Venue. All rights reserved. ") (PRETTYCOMPRINT PLOTCOMS) (RPAQQ PLOTCOMS [ (* ;;; "PLOT manager fns") (FNS ADDPLOTOBJECT ADJUSTSCALE? ADJUSTVIEWPORT APPLY.AFTERFN.MACRO ASKFORLABEL ASKFORSCALE BOXREGION CHOOSESCALE CHOOSETICS CLOSEPLOTWINDOW CLOSESTPLOTOBJECT COMPOUNDSUBTYPE COMPUTEBOTTOMMARGIN COMPUTELEFTMARGIN COMPUTERIGHTMARGIN COMPUTETOPMARGIN COPYMENU CREATEPLOT CREATEPLOTFNS CREATEPLOTOBJECT DEFAULTSCALEFN DEFAULTTICFN DEFAULTTICMETHOD DELETEPLOTOBJECT DESELECTPLOTOBJECT DISTANCETOPLOTOBJECT DRAWBOTTOMMARGIN DRAWLEFTMARGIN DRAWMARGIN DRAWPLOTOBJECT DRAWPLOT DRAWRIGHTMARGIN DRAWTOPMARGIN ERASEPLOTOBJECT EXTENDEDSCALEFN EXTENTOFPLOTOBJECT EXTENTOFPLOT GETPLOTWINDOW GETTICLIST HIGHLIGHTPLOTOBJECT LABELPLOTOBJECT LOWLIGHTPLOTOBJECT MANUALRESCALE MINSTREAMREGIONSIZE MOVEPLOTOBJECT OPENPLOTWINDOW PLOT.BUTTONEVENTFN PLOT.CLOSEFN PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOT.HARDCOPYFN PLOT.ICONFN PLOT.LABELTOWORLD PLOT.REPAINTFN PLOT.RESET PLOT.SETUP PLOT.SKETCH.CREATE PLOT.WHENSELECTEDFN PLOT.WORLDTOLABEL PLOTADDMENUITEMS PLOTADDPROP PLOTAXISINTERVAL PLOTDELMENUITEMS PLOTDELPROP PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTOBJECTADDPROP PLOTOBJECTDELPROP PLOTOBJECTLABEL PLOTOBJECTPROP PLOTOBJECTPROPMACRO PLOTOBJECTSUBTYPE PLOTOPERROR PLOTPROMPT PLOTPROP PLOTPROPMACRO PLOTREMPROP PLOTSCALEFN PLOTTICFN PLOTTICINFO PLOTTICMETHOD PLOTTICS PRINTFONT PRINTMENU REDRAWPLOTWINDOW RELABELSELECTEDPLOTOBJECT RESCALEPLOT SCALE TOGGELLABEL TOGGLEEXTENDEDAXES TOGGLEFIXEDMENU TOGGLETICS TRANSLATEPLOTOBJECT UNDELETEPLOTOBJECT UNLABELPLOTOBJECT WHICHLABEL WHICHPLOT) (* ;; "Fns to do our own number printing") (FNS PLOT.PRINTNUM PLOT.FNUM-STRING PLOT.ENUM-STRING CREATETICLISTS NORMALIZE-TICLIST) (FNS DRAW-TICS-LEFT-RIGHT DRAW-TICS-TOP-BOTTOM DRAW-LABEL-LEFT-RIGHT DRAW-LABEL-TOP-BOTTOM) (VARS PLOT.DEFAULTMIDDLEMENUITEMS PLOT.DEFAULTRIGHTMENUITEMS OBJECTOPSTABLE) (RECORDS EXTENT MARGIN PLOT PLOTFNS PLOTOBJECT AXISINFO AXISINTERVAL PLOTSCALE TICINFO) (MACROS APPLY.AFTERFN PLOTOBJECTSUBTYPE? PLOTOBJECTPROP PLOTPROP) (PROP ARGNAMES PLOTOBJECTPROP PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTPRETTYFNS PLOTPROP PLOTSCALEFN PLOTTICFN PLOTTICS) [INITVARS (SMALLPLOTFONT '(GACHA 8 MRR)) (LARGEPLOTFONT '(GACHA 12 BRR] (* ;;; "PLOT I/O") (FNS COPYPLOTOBJECT COPYPLOT PLOTOBJECTPRINT PRINTPLOTOBJECT PRINTPLOT READFONT READMENU READPLOTOBJECT READPLOT) (FNS PRINT-VECTOR READ-VECTOR) (FILEPKGCOMS PLOTS) (ADDVARS (HPRINTMACROS (FONTDESCRIPTOR . PRINTFONT) (MENU . PRINTMENU) (PLOT . PRINTPLOT) (PLOTOBJECT . PRINTPLOTOBJECT) (ONED-ARRAY . PRINT-VECTOR))) (ADDVARS (HPRINTREADFNS READPLOT READPLOTOBJECT READFONT READMENU READ-VECTOR)) (P (DEFPRINT 'PLOTOBJECT (FUNCTION PLOTOBJECTPRINT))) (* ;;; "Numeric fns") (FNS PLOT.EXP10 PLOT.LOG10 PLOT.FLOOR PLOT.CEILING SINEWAVE) (* ;;; "PLOT image object FNS") (FNS CREATEPLOTIMAGEOBJ CREATEPLOTBITMAPOBJ PLIO.BUTTONEVENTINFN PLIO.COPYFN PLIO.GETFN PLIO.PUTFN PLIO.REINSERTOBJ PLOT.COPYBUTTONEVENTFN PLIO.DISPLAYFN PLIO.IMAGEBOXFN) (* ;; "additional fns to allow plot im. objs. to work in Sketch") (FNS PLIO.EDITCLOSEFN IMAGE.OBJECT.CHANGED) [INITVARS (PLOTIMAGEFNS (IMAGEFNSCREATE (FUNCTION PLIO.DISPLAYFN) (FUNCTION PLIO.IMAGEBOXFN) (FUNCTION PLIO.PUTFN) (FUNCTION PLIO.GETFN) (FUNCTION PLIO.COPYFN) (FUNCTION PLIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL] (GLOBALVARS PLOTIMAGEFNS) (* ;;; "Initialize") (P (PLOT.SETUP OBJECTOPSTABLE) (PLOT.DEFAULTMENU 'MIDDLE PLOT.DEFAULTMIDDLEMENUITEMS) (PLOT.DEFAULTMENU 'RIGHT PLOT.DEFAULTRIGHTMENUITEMS)) (* ;;; "Dependent files") (FILES TWODGRAPHICS PLOTOBJECTS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PLOTTICS PLOTTICFN PLOTSCALEFN PLOTPROP PLOTOBJECTPROP PLOTMENUITEMS PLOTMENU PLOTLABEL PLOT.FIXRIGHTMENU PLOT.DEFAULTMENU]) (* ;;; "PLOT manager fns") (DEFINEQ (ADDPLOTOBJECT [LAMBDA (OBJECT PLOT NODRAWFLG) (* ; "Edited 28-Sep-91 16:15 by jds") (PROG ((WHENADDEDFN (PLOTOBJECTPROP OBJECT 'WHENADDEDFN)) REDRAWFLG NEWSCALES) [COND ((NOT (MEMB OBJECT (fetch (PLOT PLOTOBJECTS) of PLOT))) (replace (PLOT PLOTOBJECTS) of PLOT with (CONS OBJECT (fetch (PLOT PLOTOBJECTS) of PLOT] (COND ((ADJUSTSCALE? (EXTENTOFPLOTOBJECT OBJECT PLOT) PLOT) (SETQ REDRAWFLG T))) [COND ((NULL NODRAWFLG) (COND ([OR REDRAWFLG (NOT (OPENWP (fetch (PLOT PLOTWINDOW) of PLOT] (REDRAWPLOTWINDOW PLOT)) (T (DRAWPLOTOBJECT OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT] (APPLY.AFTERFN WHENADDEDFN OBJECT PLOT NODRAWFLG) (RETURN OBJECT]) (ADJUSTSCALE? [LAMBDA (EXTENT PLOT) (* ; "Edited 28-Sep-91 16:03 by jds") (* ;; "Determines whether the plotting scale must be adjusted to included the extrema 'minx' , 'maxx' , etc. If so returns T. Side effects the PLOTSCALE of PLOT") (LET* ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (XAXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) (XTICINFO (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (YAXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) (YTICINFO (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) (MINX (fetch (EXTENT MINX) of EXTENT)) (MAXX (fetch (EXTENT MAXX) of EXTENT)) (MINY (fetch (EXTENT MINY) of EXTENT)) (MAXY (fetch (EXTENT MAXY) of EXTENT)) CHANGEDFLG) [COND ((OR (LESSP MINX (fetch (AXISINTERVAL MIN) of XINTERVAL)) (GREATERP MAXX (fetch (AXISINTERVAL MAX) of XINTERVAL))) (SETQ CHANGEDFLG T) (LET [(NEWMIN (FMIN MINX (fetch (AXISINTERVAL MIN) of XINTERVAL))) (NEWMAX (FMAX MAXX (fetch (AXISINTERVAL MAX) of XINTERVAL] (SETQ XTICINFO (CHOOSETICS NEWMIN NEWMAX XAXISINFO PLOT)) (SETQ XINTERVAL (CHOOSESCALE NEWMIN NEWMAX XAXISINFO XTICINFO PLOT] [COND ((OR (LESSP MINY (fetch (AXISINTERVAL MIN) of YINTERVAL)) (GREATERP MAXY (fetch (AXISINTERVAL MAX) of YINTERVAL))) (SETQ CHANGEDFLG T) (LET [(NEWMIN (FMIN MINY (fetch (AXISINTERVAL MIN) of YINTERVAL))) (NEWMAX (FMAX MAXY (fetch (AXISINTERVAL MAX) of YINTERVAL] (SETQ YTICINFO (CHOOSETICS NEWMIN NEWMAX YAXISINFO PLOT)) (SETQ YINTERVAL (CHOOSESCALE NEWMIN NEWMAX YAXISINFO YTICINFO PLOT] (COND (CHANGEDFLG (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with XINTERVAL) (replace (PLOTSCALE XTICINFO) of PLOTSCALE with XTICINFO) (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with YINTERVAL) (replace (PLOTSCALE YTICINFO) of PLOTSCALE with YTICINFO))) CHANGEDFLG]) (ADJUSTVIEWPORT [LAMBDA (VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 16:59 by jds") (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (PARENTSTREAM (fetch PARENTSTREAM of VIEWPORT)) BOTTOMMARGINSIZE LEFTMARGINSIZE RIGHTMARGINSIZE TOPMARGINSIZE) (SETQ BOTTOMMARGINSIZE (COMPUTEBOTTOMMARGIN PARENTSTREAM (fetch (PLOT BOTTOMMARGIN) of PLOT) PLOT)) (SETQ LEFTMARGINSIZE (COMPUTELEFTMARGIN PARENTSTREAM (fetch (PLOT LEFTMARGIN) of PLOT) PLOT)) (SETQ RIGHTMARGINSIZE (COMPUTERIGHTMARGIN PARENTSTREAM (fetch (PLOT RIGHTMARGIN) of PLOT) PLOT)) (SETQ TOPMARGINSIZE (COMPUTETOPMARGIN PARENTSTREAM (fetch (PLOT TOPMARGIN) of PLOT) PLOT)) [replace WORLDREGION of VIEWPORT with (CREATEREGION (fetch (AXISINTERVAL MIN) of (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (fetch (AXISINTERVAL MIN) of (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (fetch (AXISINTERVAL INTERVALLENGTH) of (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (fetch (AXISINTERVAL INTERVALLENGTH) of (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE] [replace STREAMSUBREGION of VIEWPORT with (CREATEREGION (PLUS (fetch (REGION LEFT) of STREAMREGION) (CAR LEFTMARGINSIZE)) (PLUS (fetch (REGION BOTTOM) of STREAMREGION) (CDR BOTTOMMARGINSIZE)) (IDIFFERENCE (fetch (REGION WIDTH) of STREAMREGION) (IPLUS (CAR LEFTMARGINSIZE) (CAR RIGHTMARGINSIZE)) ) (IDIFFERENCE (fetch (REGION HEIGHT) of STREAMREGION) (IPLUS (CDR BOTTOMMARGINSIZE) (CDR TOPMARGINSIZE] (COMPUTETRANSFORM VIEWPORT) (RETURN VIEWPORT]) (APPLY.AFTERFN.MACRO [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:16 by jop") (PROG ((FNS (CAR ARGS)) (ARGLST (CDR ARGS))) (RETURN `(if ,FNS then (if (AND (LISTP ,FNS) (NEQ (CAR ,FNS) 'LAMBDA)) then (for FN in ,FNS do (CL:FUNCALL FN ,@ARGLST)) else (CL:FUNCALL ,FNS ,@ARGLST]) (ASKFORLABEL [LAMBDA (PLOT MARGINNAME) (* ; "Edited 28-Sep-91 16:16 by jds") (* ;; "Prompt for new label and make the required call to LABELPLOT") [COND ((EQ MARGINNAME 'TITLE) (SETQ MARGINNAME 'TOP] (PROG ((PLOTPROMPT (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) (MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "ILLEGAL MARGIN NAME" MARGINNAME))) (PROMPT (SELECTQ MARGINNAME (BOTTOM "BOTTOM MARGIN LABEL?") (LEFT "LEFT MARGIN LABEL?") (TOP "TITLE?") (RIGHT "RIGHT MARGIN LABEL?") (HELP "ILLEGAL MARGIN NAME" MARGINNAME))) LABEL NEWLABEL) (SETQ LABEL (fetch (MARGIN LABEL) of MARGIN)) (TERPRI PLOTPROMPT) [SETQ NEWLABEL (PROMPTFORWORD PROMPT LABEL "Type a label" PLOTPROMPT NIL NIL (CHARCODE (EOL LF ESCAPE TAB] (COND ((AND (NEQ NEWLABEL LABEL) (NOT (STREQUAL NEWLABEL LABEL))) (PLOTLABEL PLOT MARGINNAME NEWLABEL]) (ASKFORSCALE [LAMBDA (PLOT AXIS) (* ; "Edited 28-Sep-91 16:16 by jds") (PROG ((PLOTPROMPT (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) (LOWER (PLOT.WORLDTOLABEL (SELECTQ AXIS (X (fetch (PLOT XLOWER) of PLOT)) (Y (fetch (PLOT YLOWER) of PLOT)) (HELP "Illegal axis" AXIS)) PLOT AXIS)) (UPPER (PLOT.WORLDTOLABEL (SELECTQ AXIS (X (fetch (PLOT XUPPER) of PLOT)) (Y (fetch (PLOT YUPPER) of PLOT)) (HELP "Illegal axis" AXIS)) PLOT AXIS))) (TERPRI PLOTPROMPT) (SETQ LOWER (PLOT.LABELTOWORLD [READ (OPENSTRINGSTREAM (PROMPTFORWORD (CONCAT AXIS " axis: From ") LOWER "Type a number" PLOTPROMPT NIL NIL (CHARCODE (EOL LF ESCAPE TAB] PLOT AXIS)) (SETQ UPPER (PLOT.LABELTOWORLD [READ (OPENSTRINGSTREAM (PROMPTFORWORD " to " UPPER "Type a number" PLOTPROMPT NIL NIL (CHARCODE (EOL LF ESCAPE TAB] PLOT AXIS)) (RETURN (CONS LOWER UPPER]) (BOXREGION [LAMBDA (REGION STREAM) (* ; "Edited 28-Sep-91 17:00 by jds") (* ;; "Draw a box around a region in STREAM") (PROG ((RLEFT (fetch (REGION LEFT) of REGION)) (RBOTTOM (fetch (REGION BOTTOM) of REGION)) (RRIGHT (fetch (REGION RIGHT) of REGION)) (RTOP (fetch (REGION TOP) of REGION)) (LINEWIDTH (DSPSCALE NIL STREAM))) (DRAWLINE RLEFT RBOTTOM RRIGHT RBOTTOM LINEWIDTH 'REPLACE STREAM) (DRAWLINE RRIGHT RBOTTOM RRIGHT RTOP LINEWIDTH 'REPLACE STREAM) (DRAWLINE RRIGHT RTOP RLEFT RTOP LINEWIDTH 'REPLACE STREAM) (DRAWLINE RLEFT RTOP RLEFT RBOTTOM LINEWIDTH 'REPLACE STREAM]) (CHOOSESCALE [LAMBDA (MIN MAX AXISINFO TICINFO PLOT) (* ; "Edited 5-May-87 18:25 by jop") (PROG ((SCALEFN (fetch (AXISINFO SCALEFN) of AXISINFO)) NEWINTERVAL) [SETQ NEWINTERVAL (COND (SCALEFN (CL:FUNCALL SCALEFN MIN MAX TICINFO PLOT)) (T (DEFAULTSCALEFN MIN MAX TICINFO] (AND (NOT (type? AXISINTERVAL NEWINTERVAL)) (HELP "Not an AXISINTERVAL" NEWINTERVAL)) (RETURN NEWINTERVAL]) (CHOOSETICS [LAMBDA (MIN MAX AXISINFO PLOT) (* ; "Edited 5-May-87 18:25 by jop") (PROG ((TICFN (fetch (AXISINFO TICFN) of AXISINFO)) NEWTICINFO) [SETQ NEWTICINFO (COND (TICFN (CL:FUNCALL TICFN MIN MAX PLOT)) (T (DEFAULTTICFN MIN MAX] (AND (NOT (type? TICINFO NEWTICINFO)) (HELP "Not a TICINFO" NEWTICINFO)) (RETURN NEWTICINFO]) (CLOSEPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:17 by jop") (LET [(PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (WHENCLOSEDFN (PLOTPROP PLOT 'WHENCLOSEDFN] (* ;; "Unfix the right menu") (PLOT.FIXRIGHTMENU PLOT NIL) (* ;; "Cleanup Window Props") (COND ((WINDOWP PLOTWINDOW) (WINDOWPROP PLOTWINDOW 'PLOT NIL) (WINDOWDELPROP PLOTWINDOW 'REPAINTFN (FUNCTION PLOT.REPAINTFN)) (WINDOWDELPROP PLOTWINDOW 'RESHAPEFN (FUNCTION PLOT.REPAINTFN)) (WINDOWDELPROP PLOTWINDOW 'CLOSEFN (FUNCTION PLOT.CLOSEFN)) (WINDOWPROP PLOTWINDOW 'BUTTONEVENTFN (FUNCTION TOTOPW)) (WINDOWPROP PLOTWINDOW 'RIGHTBUTTONFN NIL) (WINDOWPROP PLOTWINDOW 'COPYBUTTONEVENTFN NIL) (WINDOWPROP PLOTWINDOW 'HARDCOPYFN NIL) (WINDOWPROP PLOTWINDOW 'ICONFN NIL) (CLOSEW PLOTWINDOW) (DETACHALLWINDOWS PLOTWINDOW))) (* ;; "A user hook") (APPLY.AFTERFN WHENCLOSEDFN PLOT]) (CLOSESTPLOTOBJECT [LAMBDA (PLOT STREAMPOSITION) (* ; "Edited 28-Sep-91 16:16 by jds") (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) smallest (DISTANCETOPLOTOBJECT OBJECT STREAMPOSITION PLOT]) (COMPOUNDSUBTYPE [LAMBDA (COMPOUNDOBJECT) (* ; "Edited 28-Sep-91 16:28 by jds") (fetch COMPOUNDTYPE of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT]) (COMPUTEBOTTOMMARGIN [LAMBDA (STREAM BOTTOMMARGIN PLOT) (* ; "Edited 5-May-87 18:18 by jop") (* ;; "Returns a size cons pair (width . height) in streamcoordinates") (DECLARE (SPECVARS SMALLFONT LARGEFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of BOTTOMMARGIN)) (LABEL (fetch (MARGIN LABEL) of BOTTOMMARGIN)) (WIDTH 0) SMALLASCENT LARGEHEIGHT HEIGHT) (SETQ SMALLASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ LARGEHEIGHT (FONTPROP LARGEFONT 'HEIGHT)) (* ;  "margin of at least one LARGEHEIGHT") [SETQ HEIGHT (COND ((OR TICS? LABEL) LARGEHEIGHT) (T (ITIMES 2 LARGEHEIGHT] [COND (TICS? (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 3 SMALLASCENT] [COND (LABEL (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 2 LARGEHEIGHT))) (SETQ WIDTH (STRINGWIDTH LABEL LARGEFONT] (RETURN (CONS WIDTH HEIGHT]) (COMPUTELEFTMARGIN [LAMBDA (STREAM LEFTMARGIN PLOT) (* ; "Edited 13-May-87 13:36 by jop") (* ;; "Returns a (width . height) pair") (DECLARE (SPECVARS PRXFLG SMALLPLOTFONT LARGEPLOTFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of LEFTMARGIN)) (TICLIST (fetch (MARGIN TICLIST) of LEFTMARGIN)) (LABEL (fetch (MARGIN LABEL) of LEFTMARGIN)) (HEIGHT 0) LARGEWIDTH SMALLWIDTH WIDTH) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ LARGEWIDTH (STRINGWIDTH 'A LARGEFONT)) [SETQ WIDTH (COND ((OR TICS? LABEL) LARGEWIDTH) (T (ITIMES 2 LARGEWIDTH] [COND (TICS? (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 SMALLWIDTH) (bind TICWIDTH for TICPAIR in TICLIST largest (STRINGWIDTH (CDR TICPAIR) SMALLFONT) finally (RETURN $$EXTREME ] [COND (LABEL (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 LARGEWIDTH))) (SETQ HEIGHT (ITIMES (NCHARS LABEL) (FONTPROP LARGEFONT 'HEIGHT] (RETURN (CONS WIDTH HEIGHT]) (COMPUTERIGHTMARGIN [LAMBDA (STREAM RIGHTMARGIN PLOT) (* ; "Edited 13-May-87 13:37 by jop") (* ;; "Returns a (width . height) pair") (DECLARE (SPECVARS PRXFLG SMALLFONT LARGEFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of RIGHTMARGIN)) (TICLIST (fetch (MARGIN TICLIST) of RIGHTMARGIN)) (LABEL (fetch (MARGIN LABEL) of RIGHTMARGIN)) (HEIGHT 0) SMALLWIDTH LARGEWIDTH WIDTH) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ LARGEWIDTH (STRINGWIDTH 'A LARGEFONT)) [SETQ WIDTH (COND ((OR TICS? LABEL) LARGEWIDTH) (T (ITIMES 2 LARGEWIDTH] [COND (TICS? (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 SMALLWIDTH) (for TICPAIR in TICLIST largest (STRINGWIDTH (CDR TICPAIR) SMALLFONT) finally (RETURN $$EXTREME ] [COND (LABEL (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 LARGEWIDTH))) (SETQ HEIGHT (ITIMES (NCHARS LABEL) (FONTPROP LARGEFONT 'HEIGHT] (RETURN (CONS WIDTH HEIGHT]) (COMPUTETOPMARGIN [LAMBDA (STREAM TOPMARGIN PLOT) (* ; "Edited 5-May-87 18:19 by jop") (DECLARE (SPECVARS SMALLFONT LARGEFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of TOPMARGIN)) (LABEL (fetch (MARGIN LABEL) of TOPMARGIN)) (WIDTH 0) SMALLASCENT LARGEHEIGHT HEIGHT) (SETQ SMALLASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ LARGEHEIGHT (FONTPROP LARGEFONT 'HEIGHT)) (* ;  "margin of at least one LARGEHEIGHT") [SETQ HEIGHT (COND ((OR TICS? LABEL) LARGEHEIGHT) (T (ITIMES 2 LARGEHEIGHT] [COND (TICS? (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 3 SMALLASCENT] [COND (LABEL (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 2 LARGEHEIGHT))) (SETQ WIDTH (IMAX WIDTH (STRINGWIDTH LABEL LARGEFONT] (RETURN (CONS WIDTH HEIGHT]) (COPYMENU [LAMBDA (MENU NEWITEMS) (* ; "Edited 1-Jun-92 13:59 by jds") (* ;; "Note that menu props are not copied") (create MENU ITEMS _ (OR NEWITEMS (fetch (MENU ITEMS) of MENU)) WHENSELECTEDFN _ (fetch (MENU WHENSELECTEDFN) of MENU) WHENHELDFN _ (fetch (MENU WHENHELDFN) of MENU) WHENUNHELDFN _ (fetch (MENU WHENUNHELDFN) of MENU) MENUPOSITION _ (fetch (MENU MENUPOSITION) of MENU) MENUOFFSET _ (fetch (MENU MENUOFFSET) of MENU) MENUFONT _ (fetch (MENU MENUFONT) of MENU) MENUTITLEFONT _ (fetch (MENU MENUTITLEFONT) of MENU) TITLE _ (fetch (MENU TITLE) of MENU) CENTERFLG _ (fetch (MENU CENTERFLG) of MENU) MENUBORDERSIZE _ (fetch (MENU MENUBORDERSIZE) of MENU) MENUOUTLINESIZE _ (fetch (MENU MENUOUTLINESIZE) of MENU) CHANGEOFFSETFLG _ (fetch (MENU CHANGEOFFSETFLG) of MENU]) (CREATEPLOT [LAMBDA (OPENFLG REGION TITLE BORDER) (* ; "Edited 5-May-87 18:19 by jop") (* ;; "Creates a PLOT. If OPENFLG is T then the PLOT's asssociated window is opened. The other arguments are passed to CREATEW") (PROG ((PLOT (create PLOT))) (replace (PLOT PLOTSCALE) of PLOT with (create PLOTSCALE XAXISINFO _ (create AXISINFO) XINTERVAL _ (create AXISINTERVAL MIN _ 0.0 MAX _ 1.0) XTICINFO _ (create TICINFO TICMIN _ 0.0 TICMAX _ 1.0 TICINC _ 1.0 NTICS _ 2) YAXISINFO _ (create AXISINFO) YINTERVAL _ (create AXISINTERVAL MIN _ 0.0 MAX _ 1.0) YTICINFO _ (create TICINFO TICMIN _ 0.0 TICMAX _ 1.0 TICINC _ 1.0 NTICS _ 2))) (PLOTMENU PLOT 'MIDDLE (PLOT.DEFAULTMENU 'MIDDLE)) (PLOTMENU PLOT 'RIGHT (PLOT.DEFAULTMENU 'RIGHT)) (* ;  "Compute size of margins in stream coordinates") (replace (PLOT BOTTOMMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (replace (PLOT LEFTMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (replace (PLOT TOPMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (replace (PLOT RIGHTMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (* ;  "Cache display parameters until OPENPLOTWINDOW is called") [COND ((OR REGION TITLE BORDER) (replace (PLOT PLOTWINDOW) of PLOT with (LIST REGION TITLE BORDER] (COND (OPENFLG (OPENPLOTWINDOW PLOT))) (RETURN PLOT]) (CREATEPLOTFNS [LAMBDA (DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN GETFN BORROWFROM) (* ; "Edited 28-Sep-91 16:22 by jds") (* ;; "Create an instance of PLOTFNS, a vector of functions that implement generic plot object operations. A DRAWFN , ERASEFN , and a EXTENTFN are required. If there is a DISTANCEFN then a HIGHLIGHTFN must also be supplied. Supplies defaults for some generic operations. If BORROWFROM then it must be another PLOTFNS, in which case NIL functions are inherited from USING.") (DECLARE (SPECVARS DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN GETFN)) [COND (BORROWFROM [COND ((AND (NULL LOWLIGHTFN) (NULL HIGHLIGHTFN)) (SETQ LOWLIGHTFN (fetch (PLOTFNS LOWLIGHTFN) of BORROWFROM] (for FN in '(DRAWFN ERASEFN EXTENTFN HIGHLIGHTFN LABELFN DISTANCEFN MOVEFN COPYFN PUTFN GETFN) do (COND ((NULL (EVAL FN)) (SET FN (RECORDACCESS FN BORROWFROM] (COND ((NOT (AND DRAWFN ERASEFN EXTENTFN)) (HELP "Attempt to create PLOTFNS without required FNS"))) (COND ((AND DISTANCEFN (NOT HIGHLIGHTFN)) (HELP "DISTANCEFN without a HIGHLIGHTFN"))) (create PLOTFNS DRAWFN _ DRAWFN ERASEFN _ ERASEFN HIGHLIGHTFN _ (OR HIGHLIGHTFN (FUNCTION PLOTOPERROR)) LOWLIGHTFN _ (OR LOWLIGHTFN HIGHLIGHTFN (FUNCTION PLOTOPERROR)) MOVEFN _ (OR MOVEFN (FUNCTION PLOTOPERROR)) LABELFN _ (OR LABELFN (FUNCTION LABELGENERIC)) EXTENTFN _ EXTENTFN DISTANCEFN _ [OR DISTANCEFN (FUNCTION (LAMBDA NIL MAX.SMALLP] COPYFN _ (OR COPYFN (FUNCTION COPYGENERIC)) PUTFN _ (OR PUTFN (FUNCTION PUTGENERIC)) GETFN _ (OR GETFN (FUNCTION GETGENERIC]) (CREATEPLOTOBJECT [LAMBDA (OBJECTFNS OBJECTSUBTYPE OBJECTLABEL OBJECTMENU OBJECTDATA) (* ; "Edited 5-May-87 18:20 by jop") (COND ((NOT (AND OBJECTFNS OBJECTDATA)) (HELP "Attempt to create a PLOTOBJECT without a FNS vector or OBJECTDATA"))) (PROG ((PLOTOBJECT (create PLOTOBJECT OBJECTFNS _ OBJECTFNS OBJECTSUBTYPE _ OBJECTSUBTYPE OBJECTLABEL _ OBJECTLABEL OBJECTDATA _ OBJECTDATA))) (* ;  "PLOTOBJECTPROP coerces OBJECTMENU to a menu if it is an item list") (PLOTOBJECTPROP PLOTOBJECT 'OBJECTMENU OBJECTMENU) (RETURN PLOTOBJECT]) (DEFAULTSCALEFN [LAMBDA (MIN MAX TICINFO) (* ; "Edited 5-May-87 18:20 by jop") (create AXISINTERVAL MIN _ (fetch (TICINFO TICMIN) of TICINFO) MAX _ (fetch (TICINFO TICMAX) of TICINFO]) (DEFAULTTICFN [LAMBDA (MIN MAX TICS ROUND POWER) (* ; "Edited 28-Sep-91 16:54 by jds") (* ;; "Computes an interval that includes (MIN,MAX) and can be exactly spanned by (NTICS-1) *some increment. If TICS is NIL tries a few values and chooses the one that yields the shortest interval.") (COND [(NULL TICS) (SETQ TICS '(3 4 5 6 7 8] ((FIXP TICS) (SETQ TICS (LIST TICS))) ((NLISTP TICS) (HELP "Not a list of FIXP's" TICS))) (bind (SHORTEST _ (SCALE MIN MAX (CAR TICS) ROUND POWER)) CURRENT for NTICS in (CDR TICS) do (SETQ CURRENT (SCALE MIN MAX NTICS ROUND POWER)) (COND ((LESSP (fetch (TICINFO TICINTERVALLENGTH ) of CURRENT ) (fetch (TICINFO TICINTERVALLENGTH ) of SHORTEST )) (SETQ SHORTEST CURRENT))) finally (RETURN SHORTEST]) (DEFAULTTICMETHOD [LAMBDA (MARGIN PLOTSCALE PLOT) (* ; "Edited 5-May-87 18:21 by jop") (* ;; "Return the default tic list based on the values of PLOTSCALE") (PROG ((TICINFO (SELECTQ MARGIN ((BOTTOM TOP) (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) ((RIGHT LEFT) (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) (HELP "MARGIN must be one of RIGHT, LEFT, TOP, BOTTOM" MARGIN))) TICINC) (SETQ TICINC (fetch (TICINFO TICINC) of TICINFO)) (RETURN (COND ((LISTP TICINC) TICINC) ((NUMBERP TICINC) (* ;  "Be carefull that min and max tics correspond to min and max of interval") (NCONC1 (for I from 1 to (SUB1 (fetch (TICINFO NTICS) of TICINFO)) as X from (fetch (TICINFO TICMIN) of TICINFO) by TICINC collect X) (fetch (TICINFO TICMAX) of TICINFO))) (T (HELP "Invalid TICINC" TICINC]) (DELETEPLOTOBJECT [LAMBDA (OBJECT PLOT NODRAWFLG NOSAVEFLG) (* ; "Edited 5-May-87 18:21 by jop") (* ;; "Delete object from display list of plot. If (NULL NODRAWFLG) then update the display (open it if necessary) if (NULL NOSAVEFLG) then intern the object on the save list.") (LET [(PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) (PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (WHENDELETEDFN (PLOTOBJECTPROP OBJECT 'WHENDELETEDFN] (if (MEMB OBJECT PLOTOBJECTS) then (if (EQ OBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) then (if (NULL NODRAWFLG) then (if (OPENWP PLOTWINDOW) then (LOWLIGHTPLOTOBJECT OBJECT PLOT))) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL)) (replace (PLOT PLOTOBJECTS) of PLOT with (DREMOVE OBJECT PLOTOBJECTS)) (if (NULL NOSAVEFLG) then (push (fetch (PLOT PLOTSAVELIST) of PLOT) OBJECT)) (if (NULL NODRAWFLG) then (if (NOT (OPENWP PLOTWINDOW)) then (OPENPLOTWINDOW PLOT) else (ERASEPLOTOBJECT OBJECT PLOT))) (APPLY.AFTERFN WHENDELETEDFN OBJECT PLOT NODRAWFLG NOSAVEFLG) OBJECT]) (DESELECTPLOTOBJECT [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:21 by jop") (if (fetch (PLOT SELECTEDOBJECT) of PLOT) then (LOWLIGHTPLOTOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT) PLOT) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL]) (DISTANCETOPLOTOBJECT [LAMBDA (OBJECT STREAMPOSITION PLOT) (* ; "Edited 5-May-87 18:25 by jop") (CL:FUNCALL (fetch (PLOTFNS DISTANCEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT STREAMPOSITION PLOT]) (DRAWBOTTOMMARGIN [LAMBDA (BOTTOMMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 16:40 by jds") (* ;; "DRAW the BOTTOM MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of BOTTOMMARGIN)) (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLPLOTFONTASCENT BOTTOM) (SETQ SMALLPLOTFONTASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ BOTTOM (fetch (REGION BOTTOM) of (fetch STREAMSUBREGION of VIEWPORT)) ) (if (fetch (MARGIN TICS?) of BOTTOMMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-TOP-BOTTOM (fetch (MARGIN TICLIST) of BOTTOMMARGIN) (fetch (AXISINTERVAL MIN) of XINTERVAL) (fetch (AXISINTERVAL MAX) of XINTERVAL) (IPLUS SMALLPLOTFONTASCENT BOTTOM) (IDIFFERENCE BOTTOM SMALLPLOTFONTASCENT) (ITIMES 2 SMALLPLOTFONTASCENT) SMALLFONT STREAM VIEWPORT T)) (if LABEL then (DRAW-LABEL-TOP-BOTTOM LABEL LARGEFONT [PLUS (fetch (REGION BOTTOM) of STREAMREGION) (IPLUS (FONTPROP STREAM 'DESCENT) (FONTPROP LARGEFONT 'HEIGHT] STREAMREGION STREAM]) (DRAWLEFTMARGIN [LAMBDA (LEFTMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 17:00 by jds") (* ;; "DRAW the BOTTOM MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of LEFTMARGIN)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLWIDTH LEFT) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ LEFT (fetch (REGION LEFT) of (fetch STREAMSUBREGION of VIEWPORT))) (if (fetch (MARGIN TICS?) of LEFTMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-LEFT-RIGHT (fetch (MARGIN TICLIST) of LEFTMARGIN) (fetch (AXISINTERVAL MIN) of YINTERVAL) (fetch (AXISINTERVAL MAX) of YINTERVAL) (IPLUS SMALLWIDTH LEFT) (IDIFFERENCE LEFT SMALLWIDTH) SMALLWIDTH SMALLFONT STREAM VIEWPORT T)) (if LABEL then (DRAW-LABEL-LEFT-RIGHT LABEL LARGEFONT (PLUS (fetch (REGION LEFT) of STREAMREGION) (STRINGWIDTH 'A LARGEFONT)) STREAMREGION STREAM]) (DRAWMARGIN [LAMBDA (MARGIN STREAM STREAMVIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (* ;; "Draws the margin MARGIN (one of RIGHT LEFT BOTTOM or TOP)") (SELECTQ MARGIN (RIGHT (DRAWRIGHTMARGIN (fetch (PLOT RIGHTMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (LEFT (DRAWLEFTMARGIN (fetch (PLOT LEFTMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (BOTTOM (DRAWBOTTOMMARGIN (fetch (PLOT BOTTOMMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (TOP (DRAWTOPMARGIN (fetch (PLOT TOPMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (HELP "MARGIN must be one of RIGHT, LEFT, BOTTOM, or TOP " MARGIN]) (DRAWPLOTOBJECT [LAMBDA (OBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 18:23 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENDRAWNFN (PLOTOBJECTPROP OBJECT 'WHENDRAWNFN] (CL:FUNCALL (fetch (PLOTFNS DRAWFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT VIEWPORT PLOT) (COND (TEXTOBJECT (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT))) (APPLY.AFTERFN WHENDRAWNFN OBJECT VIEWPORT PLOT]) (DRAWPLOT [LAMBDA (PLOT CURRENTSTREAM STREAMVIEWPORT STREAMREGION) (* ; "Edited 28-Sep-91 16:17 by jds") (* ;; "Draws a plot on CURRENTSTREAM. STREAMREGION is the region the PLOT will occupy. Does not blank the STREAMREGION before drawing") (COND ((NOT (type? PLOT PLOT)) (HELP "Not a PLOT " PLOT))) (* ;  "Will not check, for the moment, that the streamregion is large enough") (BOXREGION (fetch STREAMSUBREGION of STREAMVIEWPORT) CURRENTSTREAM) (for MARGIN in '(BOTTOM LEFT TOP RIGHT) do (DRAWMARGIN MARGIN CURRENTSTREAM STREAMVIEWPORT STREAMREGION PLOT)) (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (DRAWPLOTOBJECT OBJECT STREAMVIEWPORT PLOT]) (DRAWRIGHTMARGIN [LAMBDA (RIGHTMARGIN STREAM VIEWPORT STREAMREGION PLOT)(* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "DRAW the RIGHT MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of RIGHTMARGIN)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLWIDTH RIGHT) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ RIGHT (fetch (REGION RIGHT) of (fetch STREAMSUBREGION of VIEWPORT))) (if (fetch (MARGIN TICS?) of RIGHTMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-LEFT-RIGHT (fetch (MARGIN TICLIST) of RIGHTMARGIN) (fetch (AXISINTERVAL MIN) of YINTERVAL) (fetch (AXISINTERVAL MAX) of YINTERVAL) (IPLUS SMALLWIDTH RIGHT) (IDIFFERENCE RIGHT SMALLWIDTH) SMALLWIDTH SMALLFONT STREAM VIEWPORT)) (if LABEL then (DRAW-LABEL-LEFT-RIGHT LABEL LARGEFONT (DIFFERENCE (fetch (REGION RIGHT) of STREAMREGION) (ITIMES 2 (STRINGWIDTH 'A LARGEFONT))) STREAMREGION STREAM]) (DRAWTOPMARGIN [LAMBDA (TOPMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "DRAW the Top MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of TOPMARGIN)) (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLFONTASCENT TOP) (SETQ SMALLFONTASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ TOP (fetch (REGION TOP) of (fetch STREAMSUBREGION of VIEWPORT))) (if (fetch (MARGIN TICS?) of TOPMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-TOP-BOTTOM (fetch (MARGIN TICLIST) of TOPMARGIN) (fetch (AXISINTERVAL MIN) of XINTERVAL) (fetch (AXISINTERVAL MAX) of XINTERVAL) (IPLUS SMALLFONTASCENT TOP) (IDIFFERENCE TOP SMALLFONTASCENT) SMALLFONTASCENT SMALLFONT STREAM VIEWPORT)) (if LABEL then (DRAW-LABEL-TOP-BOTTOM LABEL LARGEFONT [IDIFFERENCE (fetch (REGION TOP) of STREAMREGION) (IPLUS (FONTPROP LARGEFONT 'HEIGHT) (FONTPROP STREAM 'ASCENT] STREAMREGION STREAM]) (ERASEPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:24 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENERASEDFN (PLOTOBJECTPROP OBJECT 'WHENERASEDFN] (CL:FUNCALL (fetch (PLOTFNS ERASEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT) (COND (TEXTOBJECT (ERASEPLOTOBJECT TEXTOBJECT PLOT))) (APPLY.AFTERFN WHENERASEDFN OBJECT PLOT]) (EXTENDEDSCALEFN [LAMBDA (MIN MAX TICINFO) (* ; "Edited 5-May-87 18:28 by jop") (PROG ((NEWMIN (fetch (TICINFO TICMIN) of TICINFO)) (NEWMAX (fetch (TICINFO TICMAX) of TICINFO)) (EPISILON 0.05) DELTA) (SETQ DELTA (FTIMES EPISILON (FDIFFERENCE NEWMAX NEWMIN))) (RETURN (create AXISINTERVAL MIN _ (FDIFFERENCE NEWMIN DELTA) MAX _ (FPLUS NEWMAX DELTA]) (EXTENTOFPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:28 by jop") (CL:FUNCALL (fetch (PLOTFNS EXTENTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT) ) OBJECT PLOT]) (EXTENTOFPLOT [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (bind EXTENT (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (SETQ EXTENT (EXTENTOFPLOTOBJECT OBJECT)) [COND ((LESSP (fetch (EXTENT MINX) of EXTENT) MINX) (SETQ MINX (fetch (EXTENT MINX) of EXTENT] [COND ((GREATERP (fetch (EXTENT MAXX) of EXTENT) MAXX) (SETQ MAXX (fetch (EXTENT MAXX) of EXTENT] [COND ((LESSP (fetch (EXTENT MINY) of EXTENT) MINY) (SETQ MINY (fetch (EXTENT MINY) of EXTENT] [COND ((GREATERP (fetch (EXTENT MAXY) of EXTENT) MAXY) (SETQ MAXY (fetch (EXTENT MAXY) of EXTENT] finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY]) (GETPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:29 by jop") (WINDOWP (fetch (PLOT PLOTWINDOW) of PLOT]) (GETTICLIST [LAMBDA (MARGINNAME PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (LET* ((MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (SHOULDNT))) (TICMETHOD (fetch (MARGIN TICMETHOD) of MARGIN))) (COND ((EQ TICMETHOD 'DEFAULT) (DEFAULTTICMETHOD MARGINNAME (fetch (PLOT PLOTSCALE) of PLOT) PLOT)) ((LITATOM TICMETHOD) (CL:FUNCALL TICMETHOD MARGINNAME (fetch (PLOT PLOTSCALE) of PLOT) PLOT)) ((LISTP TICMETHOD) TICMETHOD) (T (HELP "Illegal ticmethod" TICMETHOD]) (HIGHLIGHTPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENHIGHLIGHTEDFN (PLOTOBJECTPROP OBJECT 'WHENHIGHLIGHTEDFN] (CL:FUNCALL (fetch (PLOTFNS HIGHLIGHTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT) (COND (TEXTOBJECT (HIGHLIGHTPLOTOBJECT TEXTOBJECT PLOT))) (APPLY.AFTERFN WHENHIGHLIGHTEDFN OBJECT PLOT]) (LABELPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") (PROG [(WHENLABELEDFN (PLOTOBJECTPROP OBJECT 'WHENLABELEDFN] (CL:FUNCALL (fetch (PLOTFNS LABELFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT PLOT) (APPLY.AFTERFN WHENLABELEDFN OBJECT PLOT]) (LOWLIGHTPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENLOWLIGHTEDFN (PLOTOBJECTPROP OBJECT 'WHENLOWLIGHTEDFN] (CL:FUNCALL (fetch (PLOTFNS LOWLIGHTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT) (COND (TEXTOBJECT (LOWLIGHTPLOTOBJECT TEXTOBJECT PLOT))) (APPLY.AFTERFN WHENLOWLIGHTEDFN OBJECT PLOT]) (MANUALRESCALE [LAMBDA (PLOT AXIS) (* ; "Edited 28-Sep-91 16:17 by jds") [COND ((NULL AXIS) (SETQ AXIS 'BOTH] (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) NEWSCALE) [COND ((OR (EQ AXIS 'BOTH) (EQ AXIS 'X)) (SETQ NEWSCALE (ASKFORSCALE PLOT 'X)) (COND ((GREATERP (CDR NEWSCALE) (CAR NEWSCALE)) (LET ((NEWMIN (CAR NEWSCALE)) (NEWMAX (CDR NEWSCALE)) (AXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE))) (replace (PLOTSCALE XTICINFO) of PLOTSCALE with (CHOOSETICS NEWMIN NEWMAX AXISINFO PLOT)) (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with (create AXISINTERVAL MIN _ NEWMIN MAX _ NEWMAX] [COND ((OR (EQ AXIS 'BOTH) (EQ AXIS 'Y)) (SETQ NEWSCALE (ASKFORSCALE PLOT 'Y)) (COND ((GREATERP (CDR NEWSCALE) (CAR NEWSCALE)) (LET ((NEWMIN (CAR NEWSCALE)) (NEWMAX (CDR NEWSCALE)) (AXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE))) (replace (PLOTSCALE YTICINFO) of PLOTSCALE with (CHOOSETICS NEWMIN NEWMAX AXISINFO PLOT)) (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with (create AXISINTERVAL MIN _ NEWMIN MAX _ NEWMAX] (REDRAWPLOTWINDOW PLOT]) (MINSTREAMREGIONSIZE [LAMBDA (STREAM PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (* ;; "Compute the minimun acceptable size for a plot STREAMREGION. In the case of PLOTWINDOWS, corresponds to the min exceptable interior size of the WINDOW. Returns a dotted pair (MINX . MINY)") (* ;  "Sizes are (width . height) pairs") (PROG ((BOTTOMMARGINSIZE (COMPUTEBOTTOMMARGIN STREAM (fetch (PLOT BOTTOMMARGIN) of PLOT) PLOT)) (LEFTMARGINSIZE (COMPUTELEFTMARGIN STREAM (fetch (PLOT LEFTMARGIN) of PLOT) PLOT)) (RIGHTMARGINSIZE (COMPUTERIGHTMARGIN STREAM (fetch (PLOT RIGHTMARGIN) of PLOT) PLOT)) (TOPMARGINSIZE (COMPUTETOPMARGIN STREAM (fetch (PLOT TOPMARGIN) of PLOT) PLOT)) MINX MINY) (* ; "The constant 100 is heuristic") (SETQ MINX (IPLUS (CAR LEFTMARGINSIZE) (IMAX (CAR BOTTOMMARGINSIZE) (CAR TOPMARGINSIZE) 100) (CAR RIGHTMARGINSIZE))) (SETQ MINY (IPLUS (CDR BOTTOMMARGINSIZE) (IMAX (CDR LEFTMARGINSIZE) (CDR RIGHTMARGINSIZE) 100) (CDR TOPMARGINSIZE))) (RETURN (CONS MINX MINY]) (MOVEPLOTOBJECT [LAMBDA (OBJECT DX DY PLOT) (* ; "Edited 5-May-87 18:30 by jop") (CL:FUNCALL (fetch (PLOTFNS MOVEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT DX DY PLOT]) (OPENPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "Open window associated with PLOT. Creates circularities later broken by PLOT.CLOSEFN") (COND ((NOT (type? PLOT PLOT)) (HELP "Not a plot" PLOT))) (PROG ((WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) (WHENOPENEDFN (PLOTPROP PLOT 'WHENOPENEDFN)) MINSIZE WINDOWRESHAPEFLG PROMPTCREATEDFLG MINWINDOWEXTENT) (COND ((OPENWP WINDOW) (* ; "No need to continue") (RETURN WINDOW))) [COND ((NOT (WINDOWP WINDOW)) (LET (REGION TITLE BORDER) [COND ((LISTP WINDOW) (SETQ REGION (CAR WINDOW)) (SETQ TITLE (CADR WINDOW)) (SETQ BORDER (CADDR WINDOW] (SETQ WINDOW (CREATEW (OR REGION (CREATEREGION 0 0 100 100)) (OR TITLE "Plot Window") BORDER T)) (replace (PLOT PLOTWINDOW) of PLOT with WINDOW) (SETQ WINDOWRESHAPEFLG (NOT REGION] (* ;; "setup plot window props") (WINDOWPROP WINDOW 'PLOT PLOT) (WINDOWADDPROP WINDOW 'REPAINTFN (FUNCTION PLOT.REPAINTFN)) (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION PLOT.REPAINTFN)) (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION PLOT.CLOSEFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION PLOT.BUTTONEVENTFN)) (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION PLOT.BUTTONEVENTFN)) (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (FUNCTION PLOT.COPYBUTTONEVENTFN)) (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION PLOT.HARDCOPYFN)) (WINDOWPROP WINDOW 'ICONFN (FUNCTION PLOT.ICONFN)) (* ;  "Rest of VIEWPORT initializations in REDRAWPLOTWINDOW") [replace (PLOT PLOTWINDOWVIEWPORT) of PLOT with (CREATEVIEWPORT (WINDOWPROP WINDOW 'DSP] (* ;; "Get a prompt window, if none exists") (COND ((NULL PLOTPROMPTWINDOW) (SETQ PLOTPROMPTWINDOW (CREATEW [CREATEREGION 0 0 100 (HEIGHTIFWINDOW (FONTPROP (DEFAULTFONT 'DISPLAY) 'HEIGHT] NIL NIL T)) (WINDOWPROP PLOTPROMPTWINDOW 'PAGEFULLFN (FUNCTION NILL)) [WINDOWPROP PLOTPROMPTWINDOW 'MAXSIZE (CONS MAX.SMALLP (fetch (REGION HEIGHT) of (WINDOWPROP PLOTPROMPTWINDOW 'REGION] (DSPSCROLL 'ON PLOTPROMPTWINDOW) (replace (PLOT PLOTPROMPTWINDOW) of PLOT with PLOTPROMPTWINDOW) (SETQ PROMPTCREATEDFLG T))) (* ;  "Establish a min size for the window") (CREATETICLISTS PLOT) (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP WINDOW 'DSP) PLOT)) [WINDOWPROP WINDOW (COND ((NULL (ATTACHEDWINDOWS WINDOW)) 'MINSIZE) (T 'MAINWINDOWMINSIZE)) (CONS (WIDTHIFWINDOW (CAR MINSIZE) (WINDOWPROP WINDOW 'BORDER)) (HEIGHTIFWINDOW (CDR MINSIZE) (WINDOWPROP WINDOW 'TITLE) (WINDOWPROP WINDOW 'BORDER] (COND ([AND (NOT WINDOWRESHAPEFLG) (OR (ILESSP (WINDOWPROP WINDOW 'WIDTH) (CAR MINSIZE)) (ILESSP (WINDOWPROP WINDOW 'HEIGHT) (CDR MINSIZE] (SETQ WINDOWRESHAPEFLG T) (PROMPTPRINT "Window too small: reshape"))) [IF WINDOWRESHAPEFLG THEN (* ;  "Shaping window implies redrawing it") (SHAPEW WINDOW) ELSE (LET ((PLOTWINDOWVIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT))) (OPENW WINDOW) (ADJUSTVIEWPORT PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL WINDOW) PLOT) (DRAWPLOT PLOT (WINDOWPROP WINDOW 'DSP) PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL WINDOW)) (IF SELECTEDOBJECT THEN (HIGHLIGHTPLOTOBJECT SELECTEDOBJECT PLOT] (* ;  "Attach the promptwindow if necessary") (ATTACHWINDOW PLOTPROMPTWINDOW WINDOW 'TOP) (* ; "attach the fixed menu") (COND ((PLOTPROP PLOT 'FIXEDRIGHTMENU?) (PLOT.FIXRIGHTMENU PLOT T))) (* ; "A user hook") (APPLY.AFTERFN WHENOPENEDFN PLOT) (RETURN WINDOW]) (PLOT.BUTTONEVENTFN [LAMBDA (PLOTWINDOW) (* ; "Edited 7-May-87 10:14 by jop") (TOTOPW PLOTWINDOW) (LET* ((PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT))) (COND [(LASTMOUSESTATE LEFT) (LET ((OLDX 0) (OLDY 0) (PLOTSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of (fetch (PLOT PLOTWINDOWVIEWPORT ) of PLOT))) (POSITION (create POSITION)) NEWX NEWY NEWSELECTEDOBJECT) (while (MOUSESTATE LEFT) do (replace (POSITION XCOORD) of POSITION with (SETQ NEWX (LASTMOUSEX PLOTWINDOW))) (replace (POSITION YCOORD) of POSITION with (SETQ NEWY (LASTMOUSEY PLOTWINDOW))) [COND [(INSIDEP PLOTSUBREGION POSITION) (COND ((NOT (AND (EQ OLDX NEWX) (EQ OLDY NEWY))) (SETQ NEWSELECTEDOBJECT (CLOSESTPLOTOBJECT PLOT POSITION)) (COND ((AND NEWSELECTEDOBJECT (NEQ NEWSELECTEDOBJECT SELECTEDOBJECT) ) (COND (SELECTEDOBJECT (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT))) (HIGHLIGHTPLOTOBJECT NEWSELECTEDOBJECT PLOT) (replace (PLOT SELECTEDOBJECT) of PLOT with NEWSELECTEDOBJECT ) (SETQ SELECTEDOBJECT NEWSELECTEDOBJECT) (* ;  "Try to print a meaningfull message in the PLOTPROMPTWINDOW") (PLOTPROMPT (fetch (PLOTOBJECT OBJECTLABEL) of NEWSELECTEDOBJECT) PLOT] (T (COND (SELECTEDOBJECT (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT) (SETQ SELECTEDOBJECT NIL) (replace (PLOT SELECTEDOBJECT) of PLOT with SELECTEDOBJECT] (SETQ OLDX NEWX) (SETQ OLDY NEWY] [(AND SELECTEDOBJECT (LASTMOUSESTATE MIDDLE)) (LET ((MIDDLEMENU (fetch (PLOT MIDDLEMENU) of PLOT)) (OBJECTMENU (fetch (PLOTOBJECT OBJECTMENU) of SELECTEDOBJECT)) MIDMENU) (SETQ MIDMENU (COND (OBJECTMENU [COND ((LITATOM OBJECTMENU) (SETQ OBJECTMENU (LISTGET (fetch (PLOT OTHERMENUS ) of PLOT) OBJECTMENU] OBJECTMENU) (T MIDDLEMENU))) (COND (MIDMENU (PUTMENUPROP MIDMENU 'PLOT PLOT) (PUTMENUPROP MIDMENU 'MODE 'MIDDLE) (MENU MIDMENU) (PUTMENUPROP MIDMENU 'MODE NIL) (PUTMENUPROP MIDMENU 'PLOT NIL] ((LASTMOUSESTATE RIGHT) (LET [(RIGHTMENU (fetch (PLOT RIGHTMENU) of PLOT)) (FIXEDRIGHTMENU? (PLOTPROP PLOT 'FIXEDRIGHTMENU?] (COND ([OR FIXEDRIGHTMENU? (IGREATERP (fetch (POSITION YCOORD) of (CURSORPOSITION NIL PLOTWINDOW)) (WINDOWPROP PLOTWINDOW 'HEIGHT] (DOWINDOWCOM PLOTWINDOW)) (RIGHTMENU (PUTMENUPROP RIGHTMENU 'PLOT PLOT) (MENU RIGHTMENU) (PUTMENUPROP RIGHTMENU 'PLOT NIL]) (PLOT.CLOSEFN [LAMBDA (W) (* ; "Edited 5-May-87 18:38 by jop") (CLOSEPLOTWINDOW (WINDOWPROP W 'PLOT]) (PLOT.DEFAULTMENU [LAMBDA ARGS (* ; "Edited 5-May-87 18:38 by jop") (* ;; "If no third argument then simply return items list for given menu (middle or right), else replace the cached menu with the new list of items") (DECLARE (GLOBALVARS PLOT.DEFAULTMIDDLEMENU PLOT.DEFAULTRIGHTMENU)) (COND ((LESSP ARGS 1) (HELP "Must have at least one arg, MENUNAME"))) (PROG ((MENUNAME (ARG ARGS 1)) (NEWITEMS (AND (GREATERP ARGS 1) (ARG ARGS 2))) MENU) (COND ((AND (GREATERP ARGS 1) (NOT (LISTP NEWITEMS))) (HELP "Not a list" NEWITEMS))) (SETQ MENU (SELECTQ MENUNAME (MIDDLE (AND (BOUNDP 'PLOT.DEFAULTMIDDLEMENU) PLOT.DEFAULTMIDDLEMENU)) (RIGHT (AND (BOUNDP 'PLOT.DEFAULTRIGHTMENU) PLOT.DEFAULTRIGHTMENU)) (SHOULDNT))) [COND ((GREATERP ARGS 1) [SETQ MENU (AND NEWITEMS (COND (MENU (COPYMENU MENU NEWITEMS)) (T (create MENU ITEMS _ NEWITEMS] (SELECTQ MENUNAME (MIDDLE (SETQ PLOT.DEFAULTMIDDLEMENU MENU)) (RIGHT (SETQ PLOT.DEFAULTRIGHTMENU MENU)) (SHOULDNT] (RETURN MENU]) (PLOT.FIXRIGHTMENU [LAMBDA ARGS (* ; "Edited 5-May-87 18:39 by jop") (COND ((ILESSP ARGS 1) (HELP "Must have at least one arg"))) (LET* ((PLOT (ARG ARGS 1)) [FIXEDFLG (COND ((IGREATERP ARGS 1) (ARG ARGS 2] (OLDVALUE (PLOTPROP PLOT 'FIXEDRIGHTMENU?)) (PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT))) [COND ((IGREATERP ARGS 1) (LET [(FIXEDRIGHTMENU (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU] (PLOTPROP PLOT 'FIXEDRIGHTMENU? (NOT (NULL FIXEDFLG))) (COND [FIXEDFLG (COND ((AND (OPENWP PLOTWINDOW) (NULL FIXEDRIGHTMENU)) (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU (ATTACHMENU (fetch (PLOT RIGHTMENU ) of PLOT) PLOTWINDOW 'RIGHT 'TOP] (T (COND (FIXEDRIGHTMENU (CLOSEW FIXEDRIGHTMENU) (DETACHWINDOW FIXEDRIGHTMENU) (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU NIL] OLDVALUE]) (PLOT.HARDCOPYFN [LAMBDA (PLOTWINDOW PRINTERSTREAM) (* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "Modified to allow hardcopy of plots on PRESS printers -- no landscape drawing") (* ;; "Modified to center plot on page") (PROG ((WINDOWREGION (DSPCLIPPINGREGION NIL PLOTWINDOW)) (PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) (VIEWPORT (CREATEVIEWPORT PRINTERSTREAM)) PRINTERCLIPREGION STREAMREGION K) [if (EQ (IMAGESTREAMTYPE PRINTERSTREAM) 'INTERPRESS) then (LET ((MICASPERINCH 2540)) (if (GREATERP (fetch (REGION WIDTH) of WINDOWREGION) (fetch (REGION HEIGHT) of WINDOWREGION)) then (* ; "Print in landscape mode") (ROTATE.IP PRINTERSTREAM 90) (CONCATT.IP PRINTERSTREAM) [TRANSLATE.IP PRINTERSTREAM 0 (FIX (MINUS (TIMES 8.5 MICASPERINCH] (CONCATT.IP PRINTERSTREAM) (* ;  "Make sure the clippingregion is rational") (DSPCLIPPINGREGION (CREATEREGION (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 10 MICASPERINCH)) (FIX (TIMES 7.5 MICASPERINCH))) PRINTERSTREAM) else (* ;  "Make sure the clippingregion is rational") (DSPCLIPPINGREGION (CREATEREGION (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 7.5 MICASPERINCH)) (FIX (TIMES 10 MICASPERINCH))) PRINTERSTREAM] (SETQ PRINTERCLIPREGION (DSPCLIPPINGREGION NIL PRINTERSTREAM)) (* ; "Reset the margins") (DSPLEFTMARGIN (fetch (REGION LEFT) of PRINTERCLIPREGION) PRINTERSTREAM) (DSPBOTTOMMARGIN (fetch (REGION BOTTOM) of PRINTERCLIPREGION) PRINTERSTREAM) (DSPRIGHTMARGIN (fetch (REGION RIGHT) of PRINTERCLIPREGION) PRINTERSTREAM) (DSPTOPMARGIN (fetch (REGION TOP) of PRINTERCLIPREGION) PRINTERSTREAM) (* ;  "maintain the PLOTWINDOW's aspect ratio") [SETQ K (MIN (QUOTIENT (fetch (REGION WIDTH) of PRINTERCLIPREGION) (fetch (REGION WIDTH) of WINDOWREGION)) (QUOTIENT (fetch (REGION HEIGHT) of PRINTERCLIPREGION) (fetch (REGION HEIGHT) of WINDOWREGION] (SETQ STREAMREGION (LET [(SWIDTH (TIMES K (fetch (REGION WIDTH) of WINDOWREGION))) (SHEIGHT (TIMES K (fetch (REGION HEIGHT) of WINDOWREGION] (* ;; "center plot on page") (CREATEREGION (PLUS (fetch (REGION LEFT) of PRINTERCLIPREGION ) (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PRINTERCLIPREGION ) SWIDTH) 2)) (PLUS (fetch (REGION BOTTOM) of PRINTERCLIPREGION) (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PRINTERCLIPREGION) SHEIGHT) 2)) SWIDTH SHEIGHT))) (CREATETICLISTS PLOT) (ADJUSTVIEWPORT VIEWPORT STREAMREGION PLOT) (DRAWPLOT PLOT PRINTERSTREAM VIEWPORT STREAMREGION]) (PLOT.ICONFN [LAMBDA (PLOTWINDOW OLDICON) (* ; "Edited 28-Sep-91 17:02 by jds") (PROG ((PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) (TITLEFONT (WINDOWTITLEFONT)) ICONWWIDTH ICONWHEIGHT SUBREGION ICONW VIEWPORT) (if (GREATERP (WINDOWPROP PLOTWINDOW 'WIDTH) (WINDOWPROP PLOTWINDOW 'HEIGHT)) then (SETQ ICONWWIDTH (WIDTHIFWINDOW 100)) [SETQ ICONWHEIGHT (HEIGHTIFWINDOW (FIXR (TIMES 100 (FQUOTIENT (WINDOWPROP PLOTWINDOW 'HEIGHT) (WINDOWPROP PLOTWINDOW 'WIDTH] else [SETQ ICONWWIDTH (WIDTHIFWINDOW (FIXR (TIMES 100 (FQUOTIENT (WINDOWPROP PLOTWINDOW 'WIDTH) (WINDOWPROP PLOTWINDOW 'HEIGHT] (SETQ ICONWHEIGHT (HEIGHTIFWINDOW 100))) (if OLDICON then (SHAPEW OLDICON (CREATEREGION (fetch (REGION LEFT) of (WINDOWPROP OLDICON 'REGION)) (fetch (REGION BOTTOM) of (WINDOWPROP OLDICON 'REGION)) ICONWWIDTH ICONWHEIGHT)) (SETQ ICONW OLDICON) else (SETQ ICONW (CREATEW (GETBOXREGION ICONWWIDTH ICONWHEIGHT))) (DSPFONT TITLEFONT ICONW)) (CLEARW ICONW) [SETQ SUBREGION (CREATEREGION [FIXR (TIMES 0.1 (WINDOWPROP ICONW 'WIDTH] [FIXR (TIMES 0.1 (WINDOWPROP ICONW 'HEIGHT] [FIXR (TIMES 0.8 (WINDOWPROP ICONW 'WIDTH] (FIXR (TIMES 0.8 (WINDOWPROP ICONW 'HEIGHT] [SETQ VIEWPORT (CREATEVIEWPORT (WINDOWPROP ICONW 'DSP) SUBREGION (fetch WORLDREGION of (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT] (BOXREGION SUBREGION ICONW) [LET ((OBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) TOBJECTS) (if (ILESSP (SETQ TOBJECTS (LENGTH OBJECTS)) 50) then (* ;  "few enough objects so that all of them may be drawn") (for OBJECT in OBJECTS do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT)) else (* ; "Sample the display list") (bind (SAMPLERATE _ (FIXR (FQUOTIENT TOBJECTS 50))) for OBJECT in OBJECTS as I from 1 when (IEQP 0 (IMOD I SAMPLERATE)) do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT] (CENTERPRINTINREGION (OR (PLOTLABEL PLOT 'TOP) (if (NOT (STREQUAL (WINDOWPROP PLOTWINDOW 'TITLE) "Plot Window")) then (WINDOWPROP PLOTWINDOW 'TITLE)) "Plot Icon") NIL ICONW) (RETURN ICONW]) (PLOT.LABELTOWORLD [LAMBDA (VALUE PLOT AXIS) (* ; "Edited 5-May-87 18:26 by jop") (* ;; "given label VALUE computes corresponding VALUE in world coords") (PROG [(FN (SELECTQ AXIS (X (PLOTPROP PLOT 'XWORLDFN)) (Y (PLOTPROP PLOT 'YWORLDFN)) (HELP "Illegal axis" AXIS] (RETURN (COND (FN (CL:FUNCALL FN VALUE PLOT AXIS)) (T (* ; "use identity transformation") VALUE]) (PLOT.REPAINTFN [LAMBDA (WINDOW) (* ; "Edited 5-May-87 18:40 by jop") (* ;; "Redraws a PLOT WINDOW based on data stored on property list of WINDOW") (REDRAWPLOTWINDOW (WINDOWPROP WINDOW 'PLOT]) (PLOT.RESET [LAMBDA (PLOT XSCALE YSCALE FLUSHMARGINS FLUSHPROPS NODRAWFLG) (* ; "Edited 5-May-87 18:40 by jop") (* ;; "Reset a PLOT for reuse. XSCALE must be an AXISINTERVAL, defaults to the current interval. Similarly for YSCALE. Non-NIL FLUSHMARGINS means flush all labels, ticmethods, etc. Non-NIL FLUSHPROPS means flush all PLOTPROPS and cached menus") (if (NOT (type? PLOT PLOT)) then (HELP "NOT A PLOT" PLOT)) (* ; "Flush display list") (replace (PLOT PLOTOBJECTS) of PLOT with NIL) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL) (replace (PLOT PLOTSAVELIST) of PLOT with NIL) (if FLUSHMARGINS then (for MARGIN in '(BOTTOM LEFT TOP RIGHT) do (PLOTLABEL PLOT MARGIN NIL T) (PLOTTICS PLOT MARGIN NIL T) (PLOTTICMETHOD PLOT MARGIN NIL T))) (if XSCALE then (PLOTAXISINTERVAL PLOT 'X XSCALE T)) (if YSCALE then (PLOTAXISINTERVAL PLOT 'Y YSCALE T)) (* ; "Flush PLOT PROPS") (if FLUSHPROPS then (replace (PLOT PLOTUSERDATA) of PLOT with NIL) (replace (PLOT OTHERMENUS) of PLOT with NIL)) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT]) (PLOT.SETUP [LAMBDA (OPSTABLE) (* ; "Edited 7-May-87 18:28 by jop") (* ;; "Assume opstable is a list of lists, one list for each PLOT object. The CAR of each sublist is the the name of the PLOT object, e.g. POINT. Then follows pairs of method-names and function-names, e.g. (ADDFN ADDPOINTOBJECT)") [bind ASSOCLST for OBJECTLST in OPSTABLE do (SET (PACK* (CAR OBJECTLST) 'FNS) (APPLY (FUNCTION CREATEPLOTFNS) (first (SETQ ASSOCLST (CDR OBJECTLST)) for FNNAME in '(DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN GETFN) collect (CADR (ASSOC FNNAME ASSOCLST] (SETQ LARGEPLOTFONT (FONTCREATE LARGEPLOTFONT)) (SETQ SMALLPLOTFONT (FONTCREATE SMALLPLOTFONT]) (PLOT.SKETCH.CREATE [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 17:02 by jds") (* ;; "Creates a SKETCH STREAM and dumps the contents of PLOT into it") (if (NOT (type? PLOT PLOT)) then (HELP "Not a PLOT " PLOT)) (if (NOT (CL:FBOUNDP 'OPENSKETCHSTREAM)) then (PLOTPROMPT "SKETCHSTREAM not loaded" PLOT) else (PROG ([SKETCHSTREAM (OPENSKETCHSTREAM "LAYOUT OF PLOT" (if (fetch (PLOT PLOTWINDOW) of PLOT) then (LET [(PLOTREGION (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'REGION] (LIST 'REGION (GETBOXREGION (fetch (REGION WIDTH) of PLOTREGION) (fetch (REGION HEIGHT) of PLOTREGION] SKETCHVIEWPORT) (SETQ SKETCHVIEWPORT (CREATEVIEWPORT SKETCHSTREAM)) (ADJUSTVIEWPORT SKETCHVIEWPORT (DSPCLIPPINGREGION NIL SKETCHSTREAM) PLOT) (DRAWPLOT PLOT SKETCHSTREAM SKETCHVIEWPORT (DSPCLIPPINGREGION NIL SKETCHSTREAM]) (PLOT.WHENSELECTEDFN [LAMBDA (ITEM MENU) (* ; "Edited 5-May-87 18:42 by jop") (LET* ([PLOT (OR (GETMENUPROP MENU 'PLOT) (WINDOWPROP (MAINWINDOW (WFROMMENU MENU)) 'PLOT] (MODE (GETMENUPROP MENU 'MODE)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) (SELECTEDFN (CADR ITEM)) EXTRAARGS ARGSTOPASS) [COND ((LISTP SELECTEDFN) (SETQ EXTRAARGS (CDR SELECTEDFN)) (SETQ SELECTEDFN (CAR SELECTEDFN] (SETQ ARGSTOPASS (for ARG in EXTRAARGS collect (EVAL ARG))) (COND ((EQ MODE 'MIDDLE) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL) (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT) (CL:APPLY SELECTEDFN SELECTEDOBJECT PLOT ARGSTOPASS)) (T (CL:APPLY SELECTEDFN PLOT ARGSTOPASS]) (PLOT.WORLDTOLABEL [LAMBDA (VALUE PLOT AXIS) (* ; "Edited 5-May-87 18:26 by jop") (* ;; "Given VALUE in world coords, computes corresponding label VALUE") (PROG [(FN (SELECTQ AXIS (X (PLOTPROP PLOT 'XLABELFN)) (Y (PLOTPROP PLOT 'YLABELFN)) (HELP "Illegal axis" AXIS] (RETURN (COND (FN (CL:FUNCALL FN VALUE PLOT AXIS)) (T (* ; "use identity transformation") VALUE]) (PLOTADDMENUITEMS [LAMBDA (PLOT MENUNAME ITEMSTOADD) (* ; "Edited 28-Sep-91 16:18 by jds") (* ;; "Add ITEMSTOADD to end of menu MENUNAME item list") (PROG ((MENU (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) (MENUITEMS (PLOTMENUITEMS PLOT MENUNAME))) (if ITEMSTOADD then (SETQ ITEMSTOADD (for ITEM in ITEMSTOADD unless (for ELEMENT in MENUITEMS thereis (EQUAL (CAR ELEMENT) (CAR ITEM))) collect ITEM)) (PLOTMENUITEMS PLOT MENUNAME (APPEND MENUITEMS ITEMSTOADD))) (RETURN MENUITEMS]) (PLOTADDPROP [LAMBDA (PLOT PROP ITEMTOADD FIRSTFLG) (* ; "Edited 5-May-87 18:42 by jop") (* ;; "As in WINDOWADDPROP.") (PROG [(PROPVAL (MKLIST (PLOTPROP PLOT PROP] [if (NOT (MEMB ITEMTOADD PROPVAL)) then (if FIRSTFLG then (SETQ PROPVAL (CONS ITEMTOADD PROPVAL)) else (SETQ PROPVAL (APPEND PROPVAL (LIST ITEMTOADD] (RETURN (PLOTPROP PLOT PROP PROPVAL]) (PLOTAXISINTERVAL [LAMBDA (PLOT AXIS INTERVAL NODRAWFLG) (* ; "Edited 28-Sep-91 16:18 by jds") (* ;; "If INTERVAL is NIL returns the current INTERVAL for AXIS of PLOT. If INTERVAL is non-NIL it must be an INTERVAL, in which case the interval for axis AXIS of PLOT is set to INTERVAL") (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) OLDVALUE) (SETQ OLDVALUE (SELECTQ AXIS (X (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (Y (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (SHOULDNT))) (if (type? AXISINTERVAL INTERVAL) then (SELECTQ AXIS (X (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with INTERVAL)) (Y (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with INTERVAL)) (SHOULDNT)) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT))) (RETURN OLDVALUE]) (PLOTDELMENUITEMS [LAMBDA (PLOT MENUNAME ITEMSTODELETE) (* ; "Edited 1-Jun-92 14:02 by jds") (* ;; "Delete ITEMSTODELETE from menu MENUNAME item list. RETURNS new item list if something deleted or else NIL. ITEMSTODELETE may be a list of lists or of atoms, in which case the atoms are compared to secessive CARS of MENUNAME's item list") (SETQ ITEMSTODELETE (MKLIST ITEMSTODELETE)) (PROG ((MENU (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) MENUITEMS SOMETHINGDELETED) (SETQ MENUITEMS (AND MENU (fetch (MENU ITEMS) of MENU))) [bind TARGET for ITEMTODELETE in ITEMSTODELETE do (if (LITATOM ITEMTODELETE) then (if [SETQ TARGET (for ITEM in MENUITEMS thereis (EQUAL ITEMTODELETE (CAR ITEM] then (SETQ SOMETHINGDELETED T) (SETQ MENUITEMS (REMOVE TARGET MENUITEMS))) elseif [AND (LISTP ITEMTODELETE) (SETQ TARGET (CAR (MEMBER ITEMTODELETE MENUITEMS] then (SETQ SOMETHINGDELETED T) (SETQ MENUITEMS (REMOVE TARGET MENUITEMS] (RETURN (if SOMETHINGDELETED then (PLOTMENUITEMS PLOT MENUNAME MENUITEMS) MENUITEMS]) (PLOTDELPROP [LAMBDA (PLOT PROP ITEMTODELETE) (* ; "Edited 5-May-87 18:43 by jop") (* ;; "As in WINDOWDELPROP") (PROG ((PROPVAL (PLOTPROP PLOT PROP))) (RETURN (if (EQ ITEMTODELETE PROPVAL) then (PLOTPROP PLOT PROP NIL) elseif (MEMB ITEMTODELETE PROPVAL) then (PLOTPROP PLOT PROP (REMOVE ITEMTODELETE PROPVAL]) (PLOTLABEL [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:18 by jds") (* ;; "IF NEWLABEL is not present then return current POSITION label of PLOT, else set the label to NEWLABEL and return the old value. NODRAWFLG T suppresses redrawing. POSITIOn may be one of X , Y , TITLE") (COND ((LESSP ARGS 2) (HELP "PLOTLABEL takes at least two args, plot and position"))) (PROG ((PLOT (ARG ARGS 1)) (POSITION (ARG ARGS 2)) (NEWLABEL (AND (GREATERP ARGS 2) (ARG ARGS 3))) (NODRAWFLG (AND (GREATERP ARGS 3) (ARG ARGS 4))) MARGIN OLDLABEL) (SETQ MARGIN (SELECTQ POSITION (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "Illegal margin" POSITION))) (SETQ OLDLABEL (fetch (MARGIN LABEL) of MARGIN)) [COND ((GREATERP ARGS 2) (replace (MARGIN LABEL) of MARGIN with (AND NEWLABEL (MKSTRING NEWLABEL))) (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT] (RETURN OLDLABEL]) (PLOTMENU [LAMBDA ARGS (* ; "Edited 1-Jun-92 14:02 by jds") (* * If no third argument then simply return items list for given menu  (middle or right)%, else replace the cached menu with the new list of items.  If the NEWMENU's whenselectedfn is NIL it is replaced with PLOT.WHENSELECTEDFN) (COND ((ILESSP ARGS 2) (HELP "Must have at least two args, PLOT and MENUNAME"))) (PROG ((PLOT (ARG ARGS 1)) (MENUNAME (ARG ARGS 2)) (NEWMENU (AND (IGREATERP ARGS 2) (ARG ARGS 3))) PLOTWINDOW OLDVALUE) (SETQ PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (SETQ OLDVALUE (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) [COND ((NOT (OR (NULL NEWMENU) (type? MENU NEWMENU))) (HELP "Not a menu" NEWMENU)) ((AND NEWMENU (NULL (fetch (MENU WHENSELECTEDFN) of NEWMENU))) (replace (MENU WHENSELECTEDFN) of NEWMENU with (FUNCTION PLOT.WHENSELECTEDFN] [COND ((IGREATERP ARGS 2) [SELECTQ MENUNAME (MIDDLE (replace (PLOT MIDDLEMENU) of PLOT with NEWMENU)) (RIGHT (replace (PLOT RIGHTMENU) of PLOT with NEWMENU)) (COND ((NULL (fetch (PLOT OTHERMENUS) of PLOT)) (replace (PLOT OTHERMENUS) of PLOT with (LIST MENUNAME NEWMENU)) NEWMENU) (T (LISTPUT (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME NEWMENU] (COND ((AND (OPENWP PLOTWINDOW) (EQ MENUNAME 'RIGHT) (PLOTPROP PLOT 'FIXEDRIGHTMENU?)) (* Update the fixed menu) (PLOT.FIXRIGHTMENU PLOT NIL) (PLOT.FIXRIGHTMENU PLOT T] (RETURN OLDVALUE]) (PLOTMENUITEMS [LAMBDA ARGS (* ; "Edited 1-Jun-92 14:02 by jds") (* * If no third argument then simply return items list for given menu  (middle or right)%, else replace the cached menu with the new list of items) (if (LESSP ARGS 2) then (HELP "Must have at least two args, PLOT and MENUNAME")) (PROG ((PLOT (ARG ARGS 1)) (MENUNAME (ARG ARGS 2)) (NEWITEMS (AND (GREATERP ARGS 2) (ARG ARGS 3))) MENU) (if (AND (GREATERP ARGS 2) (NOT (LISTP NEWITEMS))) then (HELP "Not a list" NEWITEMS)) (SETQ MENU (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) (if (GREATERP ARGS 2) then [SETQ MENU (AND NEWITEMS (if MENU then (COPYMENU MENU NEWITEMS) else (create MENU ITEMS _ NEWITEMS] (PLOTMENU PLOT MENUNAME MENU)) (RETURN (if (LESSP ARGS 3) then (if MENU then (fetch (MENU ITEMS) of MENU)) else NEWITEMS]) (PLOTOBJECTADDPROP [LAMBDA (OBJECT PROP ITEMTOADD FIRSTFLG) (* jop%: "20-Jan-86 16:03") (* * As in WINDOWADDPROP.) (PROG [(PROPVAL (MKLIST (PLOTOBJECTPROP OBJECT PROP] [if (NOT (MEMB ITEMTOADD PROPVAL)) then (if FIRSTFLG then (SETQ PROPVAL (CONS ITEMTOADD PROPVAL)) else (SETQ PROPVAL (APPEND PROPVAL (LIST ITEMTOADD] (RETURN (PLOTOBJECTPROP OBJECT PROP PROPVAL]) (PLOTOBJECTDELPROP [LAMBDA (OBJECT PROP ITEMTODELETE) (* jop%: "20-Jan-86 16:03") (* * As in WINDOWDELPROP) (PROG ((PROPVAL (PLOTOBJECTPROP OBJECT PROP))) (RETURN (if (EQ ITEMTODELETE PROPVAL) then (PLOTOBJECTPROP OBJECT PROP NIL) elseif (MEMB ITEMTODELETE PROPVAL) then (PLOTOBJECTPROP OBJECT PROP (REMOVE ITEMTODELETE PROPVAL]) (PLOTOBJECTLABEL [LAMBDA (OBJECT LABEL PLOT NODRAWFLG) (* edited%: "27-Mar-86 21:29") (* * IF LABEL is NIL then return current label of OBJECT, else set the label to  LABEL and return the old value. NODRAWFLG T suppresses drawing) (if (NOT (type? PLOTOBJECT OBJECT)) then (HELP "NOT A PLOTOBJECT" OBJECT)) (PROG ((OLDLABEL (fetch (PLOTOBJECT OBJECTLABEL) of OBJECT))) (if LABEL then (if (AND (NULL NODRAWFLG) (PLOTOBJECTPROP OBJECT 'LABEL) PLOT) then (UNLABELPLOTOBJECT OBJECT PLOT)) (replace (PLOTOBJECT OBJECTLABEL) of OBJECT with LABEL) (if (AND PLOT (NULL NODRAWFLG)) then (LABELPLOTOBJECT OBJECT PLOT))) (RETURN OLDLABEL]) (PLOTOBJECTPROP [LAMBDA ARGS (* ; "Edited 1-Jun-92 14:02 by jds") (* ;; "As in WINDOWPROP. Operates on field OBJECTUSERDATA of PLOTOBJECT. If PROP is (QUOTE MENU) then accesses the object menu") (COND ((LESSP ARGS 2) (HELP "OBJECTPROP takes at least two arguments, plotobject and prop"))) (PROG ((PLOTOBJECT (ARG ARGS 1)) (PROPNAME (ARG ARGS 2)) (NEWVALUE (AND (GREATERP ARGS 2) (ARG ARGS 3))) (FIELDNAMES '(OBJECTMENU OBJECTLABEL OBJECTDATA)) OLDVALUE OBJECTUSERDATA) (SETQ OBJECTUSERDATA (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT)) [SETQ OLDVALUE (COND ((MEMB PROPNAME FIELDNAMES) (SELECTQ PROPNAME (OBJECTMENU (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT)) (OBJECTLABEL (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) (SHOULDNT))) (T (LISTGET OBJECTUSERDATA PROPNAME] [COND ((GREATERP ARGS 2) (COND ((MEMB PROPNAME FIELDNAMES) (SELECTQ PROPNAME (OBJECTMENU (replace (PLOTOBJECT OBJECTMENU) of PLOTOBJECT with (OR [COND ((LISTP NEWVALUE) (COND ((type? MENU OLDVALUE) (LET ((NEWMENU (COPYMENU OLDVALUE NEWVALUE))) [COND ((NULL (fetch (MENU WHENSELECTEDFN ) of NEWMENU)) (replace (MENU WHENSELECTEDFN) of NEWMENU with (FUNCTION PLOT.WHENSELECTEDFN] NEWMENU)) (T (create MENU ITEMS _ NEWVALUE WHENSELECTEDFN _ (FUNCTION PLOT.WHENSELECTEDFN] NEWVALUE))) (OBJECTLABEL (replace (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT with NEWVALUE)) (OBJECTDATA (replace (PLOTOBJECT OBJECTDATA) of PLOTOBJECT with NEWVALUE)) (SHOULDNT))) (T (COND ((NULL OBJECTUSERDATA) (replace (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT with (LIST PROPNAME NEWVALUE))) (T (LISTPUT OBJECTUSERDATA PROPNAME NEWVALUE] (RETURN OLDVALUE]) (PLOTOBJECTPROPMACRO [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:44 by jop") (LET [(BPLOTOBJECT (CAR ARGS)) (BPROPNAME (CADR ARGS)) (FIELDNAMES '(OBJECTMENU OBJECTLABEL OBJECTDATA] (COND ((OR (NOT (EQLENGTH ARGS 2)) (NEQ (CAR BPROPNAME) 'QUOTE) (MEMB (CADR BPROPNAME) FIELDNAMES)) 'IGNOREMACRO) (T `(LISTGET (fetch (PLOTOBJECT OBJECTUSERDATA) of ,BPLOTOBJECT) ,BPROPNAME]) (PLOTOBJECTSUBTYPE [LAMBDA (PLOTOBJECT) (* jop%: "20-Jan-86 16:21") (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT]) (PLOTOPERROR [LAMBDA NIL (* edited%: "19-May-85 13:48") (HELP "ATTEMPT To APPLY a generic PLOT operation to a deficient PLOT OBJECT"]) (PLOTPROMPT [LAMBDA (TEXT PLOT) (* ; "Edited 28-Sep-91 16:19 by jds") (PROG ((PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT))) (printout PLOTPROMPTWINDOW T TEXT]) (PLOTPROP [LAMBDA ARGS (* ; "Edited 5-May-87 18:45 by jop") (* ;; "As in WINDOWPROP. See also PLOTPROPMACRO") (COND ((LESSP ARGS 2) (HELP "PLOTPROP TAKES AT LEAST TWO ARGUMENTS, PLOT and PROPNAME"))) (PROG ((PLOT (ARG ARGS 1)) (PROPNAME (ARG ARGS 2)) (NEWVALUE (AND (GREATERP ARGS 2) (ARG ARGS 3))) (FIELDS '(XLOWER XUPPER YLOWER YUPPER MIDDLEMENU RIGHTMENU OTHERMENUS LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST)) OLDVALUE USERDATA) (* ;; "FIELDS is given as an explicit LIST for efficiency reasons -- RECORDFIELDNAMES, although more robust, takes too long") (SETQ USERDATA (fetch (PLOT PLOTUSERDATA) of PLOT)) [SETQ OLDVALUE (COND ((MEMB PROPNAME FIELDS) (RECORDACCESS PROPNAME PLOT)) (T (LISTGET USERDATA PROPNAME] [COND ((GREATERP ARGS 2) (COND ((MEMB PROPNAME FIELDS) (RECORDACCESS PROPNAME PLOT NIL 'REPLACE NEWVALUE)) (T (COND ((NULL USERDATA) (replace (PLOT PLOTUSERDATA) of PLOT with (LIST PROPNAME NEWVALUE ))) (T (LISTPUT USERDATA PROPNAME NEWVALUE] (RETURN OLDVALUE]) (PLOTPROPMACRO [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:47 by jop") (LET [(BPLOT (CAR ARGS)) (BPROPNAME (CADR ARGS)) (BVALUE (CADDR ARGS)) (FIELDNAMES '(XLOWER XUPPER YLOWER YUPPER MIDDLEMENU RIGHTMENU OTHERMENUS LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST] (COND ((NEQ (CAR BPROPNAME) 'QUOTE) 'IGNOREMACRO) (T (COND [(MEMB (CADR BPROPNAME) FIELDNAMES) (COND [(EQLENGTH ARGS 3) `(PROG1 (fetch (PLOT ,(CADR BPROPNAME)) of ,BPLOT) (replace (PLOT ,(CADR BPROPNAME)) of ,BPLOT with ,BVALUE))] (T `(fetch (PLOT ,(CADR BPROPNAME)) of ,BPLOT] (T (COND ((NOT (EQLENGTH ARGS 2)) 'IGNOREMACRO) (T `(LISTGET (fetch (PLOT PLOTUSERDATA) of ,BPLOT) ,BPROPNAME]) (PLOTREMPROP [LAMBDA (PLOT PROPNAME) (* ; "Edited 5-May-87 18:47 by jop") (* ;; "Destructively removes PROPNAME from proplist of PLOT") (if (NOT (type? PLOT PLOT)) then (HELP "Not a plot" PLOT)) (PROG ((FIELDS (RECORDFIELDNAMES 'PLOT)) (USERDATA (fetch (PLOT PLOTUSERDATA) of PLOT)) LSTPTR OLDVALUE) (SETQ OLDVALUE (if (MEMB PROPNAME FIELDS) then (RECORDACCESS PROPNAME PLOT) else (LISTGET USERDATA PROPNAME))) [if (MEMB PROPNAME FIELDS) then (RECORDACCESS PROPNAME PLOT NIL 'REPLACE NIL) else (if (SETQ LSTPTR (MEMB PROPNAME USERDATA)) then (* ; "Splice out the offending links") (if (EQ LSTPTR USERDATA) then (replace (PLOT PLOTUSERDATA) of PLOT with (CDDR USERDATA)) else (RPLACD (NLEFT USERDATA 1 LSTPTR) (CDDR LSTPTR] (RETURN OLDVALUE]) (PLOTSCALEFN [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:19 by jds") (* *) (COND ((ILESSP ARGS 2) (HELP "Must have at least two args"))) (PROG ((PLOT (ARG ARGS 1)) (AXIS (ARG ARGS 2)) AXISINFO OLDVALUE) (SETQ AXISINFO (SELECTQ AXIS (X (fetch (PLOTSCALE XAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (Y (fetch (PLOTSCALE YAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (SHOULDNT))) (SETQ OLDVALUE (fetch (AXISINFO SCALEFN) of AXISINFO)) [COND ((IGREATERP ARGS 2) (LET [(NEWVALUE (ARG ARGS 3)) (NODRAWFLG (AND (IGREATERP ARGS 3) (ARG ARGS 4] (replace (AXISINFO SCALEFN) of AXISINFO with NEWVALUE) (RESCALEPLOT PLOT AXIS NODRAWFLG] (RETURN OLDVALUE]) (PLOTTICFN [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:19 by jds") (if (ILESSP ARGS 2) then (HELP "Must have at least two args")) (PROG ((PLOT (ARG ARGS 1)) (AXIS (ARG ARGS 2)) AXISINFO OLDVALUE) (SETQ AXISINFO (SELECTQ AXIS (X (fetch (PLOTSCALE XAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (Y (fetch (PLOTSCALE YAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (SHOULDNT))) (SETQ OLDVALUE (fetch (AXISINFO TICFN) of AXISINFO)) (if (IGREATERP ARGS 2) then (LET [(NEWVALUE (ARG ARGS 3)) (NODRAWFLG (AND (IGREATERP ARGS 3) (ARG ARGS 4] (replace (AXISINFO TICFN) of AXISINFO with NEWVALUE) (RESCALEPLOT PLOT AXIS NODRAWFLG))) (RETURN OLDVALUE]) (PLOTTICINFO [LAMBDA (PLOT AXIS NEWTICINFO NODRAWFLG) (* ; "Edited 28-Sep-91 16:19 by jds") (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) OLDVALUE) (SETQ OLDVALUE (SELECTQ AXIS (X (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) (Y (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) (SHOULDNT))) (if (type? TICINFO NEWTICINFO) then (SELECTQ AXIS (X (replace (PLOTSCALE XTICINFO) of PLOTSCALE with NEWTICINFO)) (Y (replace (PLOTSCALE YTICINFO) of PLOTSCALE with NEWTICINFO)) (SHOULDNT)) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT))) (RETURN OLDVALUE]) (PLOTTICMETHOD [LAMBDA (PLOT MARGINNAME NEWMETHOD NODRAWFLG) (* ; "Edited 28-Sep-91 16:19 by jds") (* ;; "If NEWMETHOD not present then RETURNS current tic method for margin MARGIN , else replaces the method with NEWMETHOD, which may be a list of numbers, or a list of CONS pairs (VALUE . LABEL), or a function to be APPLIED to MARGIN PLOTSCALE PLOT, or the atom DEFAULT") (PROG (MARGIN OLDVALUE) (SETQ MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "ILLEGAL MARGIN" MARGIN))) (SETQ OLDVALUE (fetch (MARGIN TICMETHOD) of MARGIN)) (if NEWMETHOD then (replace (MARGIN TICMETHOD) of MARGIN with NEWMETHOD) (if (AND (NULL NODRAWFLG) (fetch (MARGIN TICS?) of MARGIN)) then (REDRAWPLOTWINDOW PLOT))) (RETURN OLDVALUE]) (PLOTTICS [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:19 by jds") (COND ((ILESSP ARGS 2) (HELP "Must have at least two args"))) (PROG ((PLOT (ARG ARGS 1)) (MARGINNAME (ARG ARGS 2)) MARGIN OLDVALUE) (SETQ MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "Illegal margin" MARGINNAME))) (SETQ OLDVALUE (fetch (MARGIN TICS?) of MARGIN)) [COND ((IGREATERP ARGS 2) (LET [(NEWVALUE (ARG ARGS 3)) (NODRAWFLG (AND (IGREATERP ARGS 3) (ARG ARGS 4] (replace (MARGIN TICS?) of MARGIN with NEWVALUE) (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT] (RETURN OLDVALUE]) (PRINTFONT [LAMBDA (FONT STREAM) (* ; "Edited 6-May-87 09:25 by jop") (PRINTOUT STREAM "(READFONT)(FAMILY" %, .P2 (FONTPROP FONT 'FAMILY) %, "SIZE" %, .P2 (FONTPROP FONT 'SIZE) %, "FACE" %, (FONTPROP FONT 'FACE) %, "ROTATION" %, (FONTPROP FONT 'ROTATION) %, "DEVICE" %, (FONTPROP FONT 'DEVICE) ")") T]) (PRINTMENU [LAMBDA (MENU STREAM) (* ; "Edited 1-Jun-92 14:03 by jds") (* ;; "Function for dumping menus on file") (PRINTOUT STREAM "(READMENU)(ITEMS" %, .P2 (fetch (MENU ITEMS) of MENU) %, "WHENSELECTEDFN" %, .P2 (fetch (MENU WHENSELECTEDFN) of MENU) %, "WHENHELDFN" %, .P2 (fetch (MENU WHENHELDFN) of MENU) %, "WHENUNHELDFN" %, .P2 (fetch (MENU WHENUNHELDFN) of MENU) %, "MENUPOSITION" %, .P2 (fetch (MENU MENUPOSITION) of MENU) %, "MENUOFFSET" %, .P2 (fetch (MENU MENUOFFSET) of MENU) %,) (* ;  "use HPRINT here to avoid dumping the whole font") (PRINTOUT STREAM "MENUFONT" %,) (HPRINT (fetch (MENU MENUFONT) of MENU) STREAM T T) (PRINTOUT STREAM %,) (PRINTOUT STREAM "TITLE" %, .P2 (fetch (MENU TITLE) of MENU) %, "CENTERFLG" %, .P2 (fetch (MENU CENTERFLG) of MENU) %, "MENUROWS" %, .P2 (fetch (MENU MENUROWS) of MENU) %, "MENUCOLUMNS" %, .P2 (fetch (MENU MENUCOLUMNS) of MENU) %, "ITEMHEIGHT" %, .P2 (fetch (MENU ITEMHEIGHT) of MENU) %, "ITEMWIDTH" %, .P2 (fetch (MENU ITEMWIDTH) of MENU) %, "MENUBORDERSIZE" %, .P2 (fetch (MENU MENUBORDERSIZE) of MENU) %, "MENUOUTLINESIZE" %, .P2 (fetch (MENU MENUOUTLINESIZE) of MENU) %, "CHANGEOFFSETFLG" %, .P2 (fetch (MENU CHANGEOFFSETFLG) of MENU) ")") T]) (REDRAWPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 7-May-87 18:16 by jop") (* ;; "Redraws the PLOTWINDOW of a PLOT") (PROG ((PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (PLOTWINDOWVIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) MINSIZE) (COND ((NOT (OPENWP PLOTWINDOW)) (* ;  "Assumes OPENPLOTWINDOW will call REDRAWPLOTWINDOW") (OPENPLOTWINDOW PLOT)) (T (CREATETICLISTS PLOT) (* ; "Setup the tic lists ") (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP PLOTWINDOW 'DSP) PLOT)) (* ;  "Establish a min size for the WINDOW") (* ;  "Uses MAINWINDOWMINSIZE since PLOTWINDOW is the main window of a group") [WINDOWPROP PLOTWINDOW 'MAINWINDOWMINSIZE (CONS (WIDTHIFWINDOW (CAR MINSIZE) (WINDOWPROP PLOTWINDOW 'BORDER)) (HEIGHTIFWINDOW (CDR MINSIZE) (WINDOWPROP PLOTWINDOW 'TITLE) (WINDOWPROP PLOTWINDOW 'BORDER] (COND ((OR (LESSP (WINDOWPROP PLOTWINDOW 'WIDTH) (CAR MINSIZE)) (LESSP (WINDOWPROP PLOTWINDOW 'HEIGHT) (CDR MINSIZE))) (PROMPTPRINT "Plotwindow too small: reshape") (* ;  "Assumes SHAPEW will call REDRAWPLOTWINDOW") (SHAPEW PLOTWINDOW)) (T (ADJUSTVIEWPORT PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL PLOTWINDOW) PLOT) (CLEARW PLOTWINDOW) (DRAWPLOT PLOT (WINDOWPROP PLOTWINDOW 'DSP) PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL PLOTWINDOW)) (COND (SELECTEDOBJECT (HIGHLIGHTPLOTOBJECT SELECTEDOBJECT PLOT]) (RELABELSELECTEDPLOTOBJECT [LAMBDA (SELECTEDOBJECT PLOT) (* ; "Edited 6-May-87 09:26 by jop") (PROG ((PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) LABEL LABELFLG) (* ;  "If the object is labeled, delete the label.") (if (PLOTOBJECTPROP SELECTEDOBJECT 'LABEL) then (UNLABELPLOTOBJECT SELECTEDOBJECT PLOT) (SETQ LABELFLG T)) (SETQ LABEL (fetch (PLOTOBJECT OBJECTLABEL) of SELECTEDOBJECT)) (TERPRI PLOTPROMPTWINDOW) [SETQ LABEL (PROMPTFORWORD "TYPE NEW LABEL :" LABEL "ENTER NIL FOR NO LABEL" PLOTPROMPTWINDOW NIL NIL (CHARCODE (EOL LF ESCAPE TAB] (replace (PLOTOBJECT OBJECTLABEL) of SELECTEDOBJECT with LABEL) (LABELPLOTOBJECT SELECTEDOBJECT PLOT]) (RESCALEPLOT [LAMBDA (PLOT AXIS NODRAWFLG) (* ; "Edited 28-Sep-91 16:19 by jds") [COND ((NULL AXIS) (SETQ AXIS 'BOTH] (LET* ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) (PLOTEXTENT (EXTENTOFPLOT PLOT)) (MINX (fetch (EXTENT MINX) of PLOTEXTENT)) (MAXX (fetch (EXTENT MAXX) of PLOTEXTENT)) (MINY (fetch (EXTENT MINY) of PLOTEXTENT)) (MAXY (fetch (EXTENT MAXY) of PLOTEXTENT))) (COND (PLOTOBJECTS (LET ((XINTERVAL (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (XAXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (YAXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) TEMP) [COND ((AND (OR (EQ AXIS 'BOTH) (EQ AXIS 'X)) (GREATERP MAXX MINX)) (LET ((AXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE) ) TICINFO) (SETQ TICINFO (CHOOSETICS MINX MAXX AXISINFO PLOT)) (replace (PLOTSCALE XTICINFO) of PLOTSCALE with TICINFO) (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with (CHOOSESCALE MINX MAXX AXISINFO TICINFO PLOT] [COND ((AND (OR (EQ AXIS 'BOTH) (EQ AXIS 'Y)) (GREATERP MAXY MINY)) (LET ((AXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE) ) TICINFO) (SETQ TICINFO (CHOOSETICS MINY MAXY AXISINFO PLOT)) (replace (PLOTSCALE YTICINFO) of PLOTSCALE with TICINFO) (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with (CHOOSESCALE MINY MAXY AXISINFO TICINFO PLOT] (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT]) (SCALE [LAMBDA (MIN MAX NTICS ROUND POWER) (* ; "Edited 6-May-87 09:26 by jop") (* ;; "Scaling algorithm for plots. NTICS is the desired number of tics. Round is a list of acceptable scaling factors. POWER is the power of ten to use. Returns a TICINFO including NEWMAX, NEWMIN, INC, and NTICS") [COND ((NULL ROUND) (SETQ ROUND '(5.0 2.5 2.0 1.5 1.0] (* ;  "Rounding Constants. Notice that they are in decreasing order and end with 1.0") (PROG ((NUMINC (SUB1 NTICS)) RAWINC MANTISSA INDEX) (SETQ RAWINC (FQUOTIENT (DIFFERENCE MAX MIN) NUMINC)) (* ; "POWER is the power of ten") [SETQ POWER (EXPT 10.0 (OR POWER (PLOT.FLOOR (PLOT.LOG10 RAWINC] (* ; "MANTISSA is the scale factor") (SETQ MANTISSA (FQUOTIENT RAWINC POWER)) [COND ((GREATERP MANTISSA (CAR ROUND)) (SETQ POWER (TIMES 10 POWER)) (SETQ INDEX (LAST ROUND))) (T (SETQ INDEX (for MARK on ROUND as TEST in (CDR ROUND) until (GREATERP MANTISSA TEST) finally (RETURN MARK] (* ;; "Find new max and new min") (RETURN (bind (NEWMAX _ MIN) NEWMIN INC FACTOR LOWERMULT UPPERMULT while (LESSP NEWMAX MAX) do (SETQ INC (TIMES (CAR INDEX) POWER)) (SETQ FACTOR (FQUOTIENT (FDIFFERENCE (FPLUS MAX MIN) (FTIMES NUMINC INC)) (FTIMES 2.0 INC))) [SETQ NEWMIN (FTIMES INC (SETQ LOWERMULT (PLOT.CEILING FACTOR] [COND ((GREATERP NEWMIN MIN) (SETQ NEWMIN (FTIMES INC (SETQ LOWERMULT (SUB1 LOWERMULT] (COND ((AND (GEQ MIN 0.0) (MINUSP NEWMIN)) (SETQ LOWERMULT 0) (SETQ NEWMIN 0.0))) (SETQ UPPERMULT (IPLUS LOWERMULT NUMINC)) (SETQ NEWMAX (FTIMES INC UPPERMULT)) [COND ((AND (LEQ MAX 0.0) (GREATERP NEWMAX 0.0)) (SETQ UPPERMULT 0) (SETQ NEWMAX 0.0) (SETQ LOWERMULT (IMINUS NUMINC)) (SETQ NEWMIN (SETQ NEWMIN (FTIMES INC LOWERMULT] [COND ((NULL (SETQ INDEX (NLEFT ROUND 1 INDEX))) (SETQ INDEX (LAST ROUND)) (SETQ POWER (TIMES 10 POWER] finally (RETURN (create TICINFO TICMAX _ NEWMAX TICMIN _ NEWMIN TICINC _ INC NTICS _ NTICS]) (TOGGELLABEL [LAMBDA (SELECTEDOBJECT PLOT) (* ; "Edited 6-May-87 09:26 by jop") (COND ((PLOTOBJECTPROP SELECTEDOBJECT 'LABEL) (UNLABELPLOTOBJECT SELECTEDOBJECT PLOT)) (T (LABELPLOTOBJECT SELECTEDOBJECT PLOT]) (TOGGLEEXTENDEDAXES [LAMBDA (PLOT AXIS) (* jop%: "10-Dec-85 17:56") (* *) [COND ((NULL AXIS) (SETQ AXIS 'BOTH] [PROG [(XSCALEFN (PLOTSCALEFN PLOT 'X)) (YSCALEFN (PLOTSCALEFN PLOT 'Y] [COND ((OR (EQ AXIS 'X) (EQ AXIS 'BOTH)) (COND ((EQ XSCALEFN (FUNCTION EXTENDEDSCALEFN)) (* recover previous state) (PLOTSCALEFN PLOT 'X (PLOTPROP PLOT 'OLDXSCALEFN) T)) (T (* Remember the old fn for next time) (PLOTPROP PLOT 'OLDXSCALEFN (PLOTSCALEFN PLOT 'X)) (PLOTSCALEFN PLOT 'X (FUNCTION EXTENDEDSCALEFN) T] (COND ((OR (EQ AXIS 'Y) (EQ AXIS 'BOTH)) (COND ((EQ YSCALEFN (FUNCTION EXTENDEDSCALEFN)) (PLOTSCALEFN PLOT 'Y (PLOTPROP PLOT 'OLDYSCALEFN) T)) (T (PLOTPROP PLOT 'OLDYSCALEFN (PLOTSCALEFN PLOT 'Y)) (PLOTSCALEFN PLOT 'Y (FUNCTION EXTENDEDSCALEFN) T] (RESCALEPLOT PLOT AXIS]) (TOGGLEFIXEDMENU [LAMBDA (PLOT) (* jop%: "12-Dec-85 10:34") (* *) (PLOT.FIXRIGHTMENU PLOT (NOT (PLOT.FIXRIGHTMENU PLOT]) (TOGGLETICS [LAMBDA (PLOT MARGINNAME) (* jop%: "10-Dec-85 21:27") [COND [(NULL MARGINNAME) (for MARGIN in '(BOTTOM LEFT) do (COND ((PLOTTICS PLOT MARGIN) (PLOTTICS PLOT MARGIN NIL T)) (T (PLOTTICS PLOT MARGIN T T] (T (COND ((PLOTTICS PLOT MARGINNAME) (PLOTTICS PLOT MARGINNAME NIL T)) (T (PLOTTICS PLOT MARGINNAME T T] (REDRAWPLOTWINDOW PLOT]) (TRANSLATEPLOTOBJECT [LAMBDA (OBJECT DX DY PLOT NODRAWFLG) (* ; "Edited 6-May-87 09:27 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENTRANSLATEDFN (PLOTOBJECTPROP OBJECT 'WHENTRANSLATEDFN] (if (NULL NODRAWFLG) then (if (EQ OBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) then (LOWLIGHTPLOTOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT) PLOT) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL)) (ERASEPLOTOBJECT OBJECT PLOT)) (* ;  "Destructively modify the data structure for OBJECT") (MOVEPLOTOBJECT OBJECT DX DY PLOT) (if (NULL NODRAWFLG) then (DRAWPLOTOBJECT OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT)) (if TEXTOBJECT then (TRANSLATEPLOTOBJECT TEXTOBJECT DX DY PLOT NODRAWFLG)) (APPLY.AFTERFN WHENTRANSLATEDFN OBJECT DX DY PLOT NODRAWFLG]) (UNDELETEPLOTOBJECT [LAMBDA (PLOT MODE) (* ; "Edited 6-May-87 09:27 by jop") (* ;; "MODE MAY BE ONE OF TOP, SELECT, ABOVE, ALL,. NIL defaults to TOP. TOP means restore the top element of the save stack. SELECT means choose an object to restore from a menu. ABOVE means restore all objects above the selected object. ALL means restore all the objects on the save stack.") (if (NULL MODE) then (SETQ MODE 'TOP)) (PROG ((SAVELIST (fetch (PLOT PLOTSAVELIST) of PLOT)) SELECTION OBJECTSTORESTORE) (if (NULL SAVELIST) then (PLOTPROMPT "No object to undelete" PLOT) (RETURN NIL)) (SETQ OBJECTSTORESTORE (SELECTQ MODE (TOP (LIST (CAR SAVELIST))) (ALL SAVELIST) ((ABOVE SELECT) [SETQ SELECTION (MENU (create MENU ITEMS _ (bind OBJECTLABEL for OBJECT in SAVELIST as I from 1 collect (SETQ OBJECTLABEL (fetch (PLOTOBJECT OBJECTLABEL) of OBJECT)) (LIST (if OBJECTLABEL then (CONCAT (PLOTOBJECTSUBTYPE OBJECT) " " OBJECTLABEL) else (PLOTOBJECTSUBTYPE OBJECT)) I] (AND SELECTION (if (EQ MODE 'SELECT) then (LIST (CAR (NTH SAVELIST SELECTION))) else (for I from 1 to SELECTION as OBJECT in SAVELIST collect OBJECT)))) (SHOULDNT "Illegal mode"))) [if OBJECTSTORESTORE then (for OBJECT in OBJECTSTORESTORE do (ADDPLOTOBJECT OBJECT PLOT) ) (replace (PLOT PLOTSAVELIST) of PLOT with (SELECTQ MODE (TOP (CDR SAVELIST)) (ALL NIL) (ABOVE (CDR (NTH SAVELIST SELECTION))) (SELECT (DREMOVE (CAR OBJECTSTORESTORE) SAVELIST)) (SHOULDNT "ILLEGAL MODE"] (RETURN OBJECTSTORESTORE]) (UNLABELPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 6-May-87 09:27 by jop") (* *) (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENUNLABELEDFN (PLOTOBJECTPROP OBJECT 'WHENUNLABELEDFN] (COND (TEXTOBJECT (ERASEPLOTOBJECT TEXTOBJECT PLOT) (PLOTOBJECTPROP OBJECT 'LABEL NIL) (APPLY.AFTERFN WHENUNLABELEDFN OBJECT PLOT)) (T (PLOTPROMPT "NOT A LABELED OBJECT" PLOT]) (WHICHLABEL [LAMBDA (PLOT) (* ; "Edited 6-May-87 09:27 by jop") (* ;; "Prompt for new label and make the required call to ASKFORLABEL") (PROG ([LMENU (CONSTANT (create MENU ITEMS _ '(TOP LEFT BOTTOM RIGHT] MARGIN) (PLOTPROMPT "Select a margin" PLOT) (SETQ MARGIN (MENU LMENU)) (AND MARGIN (ASKFORLABEL PLOT MARGIN]) (WHICHPLOT [LAMBDA (X Y) (* ; "Edited 6-May-87 09:27 by jop") (* ;; "like WHICHW but returns corresponding plot. First arg may be a window") (PROG ((W (OR (WINDOWP X) (WHICHW X Y))) PLOT) [SETQ PLOT (OR (WINDOWPROP W 'PLOT) (WINDOWPROP (WINDOWPROP W 'ICONFOR) 'PLOT] (RETURN (COND ((type? PLOT PLOT) PLOT]) ) (* ;; "Fns to do our own number printing") (DEFINEQ (PLOT.PRINTNUM [LAMBDA (F) (* ; "Edited 7-May-87 17:23 by jop") (SETQ F (FLOAT F)) (LET ((STR (CL:MAKE-ARRAY 14 :ELEMENT-TYPE 'CL:STRING-CHAR :FILL-POINTER 0)) [MINUSFLAG (AND (< F 0.0) (SETQ F (- F] (ROUND 5) NUMSTR INTEXP) (IF (AND (OR (< F 0.001) (>= F 1.0E+7)) (NOT (ZEROP F))) THEN (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) (FLTSTR F ROUND)) (PLOT.ENUM-STRING STR NUMSTR INTEXP MINUSFLAG) ELSE (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) (FLTSTR F ROUND)) (PLOT.FNUM-STRING STR NUMSTR INTEXP MINUSFLAG]) (PLOT.FNUM-STRING [LAMBDA (OUTSTR MANTSTR INTEXP MINUSP) (* ; "Edited 7-May-87 17:21 by jop") (LET* ((DIGITS (CL:LENGTH MANTSTR)) (POINTPLACE (+ DIGITS INTEXP)) (INDEX 0)) (COND (MINUSP (CL:SETF (CL:AREF OUTSTR 0) #\-) (SETQ INDEX 1))) [COND [(< POINTPLACE 0) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX)) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:DOTIMES (I (- POINTPLACE)) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX))) (CL:DOTIMES (I DIGITS) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX)))] [(< INTEXP 0) (CL:DOTIMES (I POINTPLACE) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:DO ((I POINTPLACE (CL:1+ I))) ((EQ I DIGITS)) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX)))] (T (CL:DOTIMES (I DIGITS) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (CL:DOTIMES (I INTEXP) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX))) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX] [COND ((OR (< POINTPLACE 0) (< INTEXP 0)) (* ;; "Trim off extraneous zeros") (CL:DO ((I (CL:1- INDEX) (CL:1- I))) [(NOT (EQ (CL:AREF OUTSTR I) #\0)) (CL:IF (NOT (EQ (CL:AREF OUTSTR I) #\.)) (SETQ INDEX (CL:1+ I)) (SETQ INDEX (+ I 2)))])] (CL:SETF (CL:FILL-POINTER OUTSTR) INDEX) OUTSTR]) (PLOT.ENUM-STRING [LAMBDA (OUTSTR MANTSTR INTEXP MINUSP) (* ; "Edited 13-May-87 09:21 by jop") (* ;; "Prints exponential notation observing rounding & exponent spacing") (LET ((DIGITS (CL:LENGTH MANTSTR)) (INDEX 0) EXPOFFSET) (COND (MINUSP (CL:SETF (CL:AREF OUTSTR 0) #\-) (SETQ INDEX 1))) (* ;; "Print the mantissa") (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR 0)) (SETQ INDEX (CL:1+ INDEX)) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:DO ((I 1 (CL:1+ I))) ((EQ I DIGITS)) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (* ;; "Trim off extraneous zeros") (CL:DO ((I (CL:1- INDEX) (CL:1- I))) [(NOT (EQ (CL:AREF OUTSTR I) #\0)) (CL:IF (NOT (EQ (CL:AREF OUTSTR I) #\.)) (SETQ INDEX (CL:1+ I)) (SETQ INDEX (+ I 2)))]) (* ;; "mantissa done - now for the exponent") (SETQ EXPOFFSET (- (+ INTEXP DIGITS) 1)) (SETQ MANTSTR (MKSTRING EXPOFFSET)) (SETQ DIGITS (CL:LENGTH MANTSTR)) (CL:SETF (CL:AREF OUTSTR INDEX) #\E) (SETQ INDEX (CL:1+ INDEX)) (CL:DOTIMES (I DIGITS) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (CL:SETF (CL:FILL-POINTER OUTSTR) INDEX) OUTSTR]) (CREATETICLISTS [LAMBDA (PLOT) (* ; "Edited 7-May-87 18:08 by jop") (LET ((BOTTOMMARGIN (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFTMARGIN (fetch (PLOT LEFTMARGIN) of PLOT)) (RIGHTMARGIN (fetch (PLOT RIGHTMARGIN) of PLOT)) (TOPMARGIN (fetch (PLOT TOPMARGIN) of PLOT))) [IF (fetch (MARGIN TICS?) of BOTTOMMARGIN) THEN (replace (MARGIN TICLIST) of BOTTOMMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'BOTTOM PLOT] [IF (fetch (MARGIN TICS?) of LEFTMARGIN) THEN (replace (MARGIN TICLIST) of LEFTMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'LEFT PLOT] [IF (fetch (MARGIN TICS?) of RIGHTMARGIN) THEN (replace (MARGIN TICLIST) of RIGHTMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'RIGHT PLOT] [IF (fetch (MARGIN TICS?) of TOPMARGIN) THEN (replace (MARGIN TICLIST) of TOPMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'TOP PLOT] NIL]) (NORMALIZE-TICLIST [LAMBDA (TICLIST) (* ; "Edited 27-May-87 18:19 by jop") (BIND VALUE LABEL FOR TIC IN TICLIST COLLECT (IF (LISTP TIC) THEN (SETQ VALUE (CAR TIC)) (SETQ LABEL (CDR TIC)) ELSE (SETQ VALUE (SETQ LABEL TIC))) (CONS VALUE (IF (FLOATP LABEL) THEN (PLOT.PRINTNUM LABEL) ELSE LABEL]) ) (DEFINEQ (DRAW-TICS-LEFT-RIGHT [LAMBDA (TICLIST MIN MAX RIGHTTIC LEFTTIC TICOFFSET TICFONT STREAM VIEWPORT LEFT-P) (* ; "Edited 13-May-87 16:56 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT TICFONT STREAM) [bind YWINDOWLOC TICVALUE TICLABEL for TICPAIR in TICLIST do (SETQ TICVALUE (CAR TICPAIR)) (SETQ TICLABEL (CDR TICPAIR)) (if (AND (GEQ TICVALUE MIN) (LEQ TICVALUE MAX)) then (SETQ YWINDOWLOC (WORLDTOSTREAMY TICVALUE VIEWPORT)) (MOVETO LEFTTIC YWINDOWLOC STREAM) (DRAWTO RIGHTTIC YWINDOWLOC (DSPSCALE NIL STREAM) 'REPLACE STREAM) (if TICLABEL then (IF LEFT-P THEN (MOVETO (DIFFERENCE LEFTTIC (PLUS TICOFFSET (STRINGWIDTH TICLABEL STREAM ))) YWINDOWLOC STREAM) ELSE (MOVETO (PLUS RIGHTTIC TICOFFSET) YWINDOWLOC STREAM)) (PRIN1 TICLABEL STREAM] (DSPFONT FONT STREAM]) (DRAW-TICS-TOP-BOTTOM [LAMBDA (TICLIST MIN MAX TOPOFTIC BOTTOMOFTIC TICOFFSET TICFONT STREAM VIEWPORT BOTTOM-P) (* ; "Edited 13-May-87 17:03 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT TICFONT STREAM) [bind XWINDOWLOC TICVALUE TICLABEL for TICPAIR in TICLIST do (SETQ TICVALUE (CAR TICPAIR)) (SETQ TICLABEL (CDR TICPAIR)) (if (AND (GEQ TICVALUE MIN) (LEQ TICVALUE MAX)) then (SETQ XWINDOWLOC (WORLDTOSTREAMX TICVALUE VIEWPORT)) (* ; "always draw the tic mark") (MOVETO XWINDOWLOC TOPOFTIC STREAM) (DRAWTO XWINDOWLOC BOTTOMOFTIC (DSPSCALE NIL STREAM) 'REPLACE STREAM) (if TICLABEL then (IF BOTTOM-P THEN (MOVETO XWINDOWLOC (DIFFERENCE BOTTOMOFTIC TICOFFSET) STREAM) ELSE (MOVETO XWINDOWLOC (PLUS TOPOFTIC TICOFFSET) STREAM)) (RELMOVETO (IMINUS (IQUOTIENT (STRINGWIDTH TICLABEL TICFONT) 2)) 0 STREAM) (PRIN1 TICLABEL STREAM] (DSPFONT FONT STREAM]) (DRAW-LABEL-LEFT-RIGHT [LAMBDA (LABEL LABELFONT XOFFSET STREAMREGION STREAM) (* ; "Edited 13-May-87 17:15 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT LABELFONT STREAM) (MOVETO XOFFSET (DIFFERENCE (fetch (REGION TOP) of STREAMREGION) (IQUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of STREAMREGION ) (ITIMES (FONTPROP STREAM 'HEIGHT) (NCHARS LABEL))) 2)) STREAM) (bind (LF _ (DSPLINEFEED NIL STREAM)) for I from 0 to (SUB1 (CL:LENGTH LABEL)) do (CL:PRINC (CL:AREF LABEL I) STREAM) (MOVETO XOFFSET (IPLUS (DSPYPOSITION NIL STREAM) LF) STREAM)) (DSPFONT FONT STREAM]) (DRAW-LABEL-TOP-BOTTOM [LAMBDA (LABEL LABELFONT YOFFSET STREAMREGION STREAM) (* ; "Edited 13-May-87 16:34 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT LABELFONT STREAM) (MOVETO (PLUS (fetch (REGION LEFT) of STREAMREGION) (IMAX 0 (IQUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of STREAMREGION) (STRINGWIDTH LABEL STREAM)) 2))) YOFFSET STREAM) (PRIN1 LABEL STREAM) (DSPFONT FONT STREAM]) ) (RPAQQ PLOT.DEFAULTMIDDLEMENUITEMS ((Label TOGGELLABEL "Toggle label on/off" (SUBITEMS (Relabel RELABELSELECTEDPLOTOBJECT "Change label"))) (Delete DELETEPLOTOBJECT "Delete object"))) (RPAQQ PLOT.DEFAULTRIGHTMENUITEMS ((Layout PLOT.SKETCH.CREATE "Create a sketch of the PLOT") (Redraw REDRAWPLOTWINDOW "Redraw plot") [Rescale RESCALEPLOT "Rescale plot axes" (SUBITEMS (X% Axis (RESCALEPLOT 'X) "Rescale X axis" (SUBITEMS (Automatic (RESCALEPLOT 'X) "Rescale automatically") (Manual (MANUALRESCALE 'X) "Rescale manually"))) (Y% Axis (RESCALEPLOT 'Y) "Rescale Y axis" (SUBITEMS (Automatic (RESCALEPLOT 'Y) "Rescale automatically") (Manual (MANUALRESCALE 'Y) "Rescale manually"] (Extend TOGGLEEXTENDEDAXES "Extend plot axes on/off" (SUBITEMS (X% Axis (TOGGLEEXTENDEDAXES 'X) "Extend X axis on/off") (Y% Axis (TOGGLEEXTENDEDAXES 'Y) "Extend Y axis on/off"))) (Labels WHICHLABEL "Relabel plot" (SUBITEMS (Title (ASKFORLABEL 'TOP) "Title plot") (Left (ASKFORLABEL 'LEFT) "Label left of plot") (Bottom (ASKFORLABEL 'BOTTOM) "Label bottom of plot") (Right (ASKFORLABEL 'RIGHT) "Label right of plot"))) (Tics TOGGLETICS "Tics on or off" (SUBITEMS (Top (TOGGLETICS 'TOP) "Top tics on/off") (Left (TOGGLETICS 'LEFT) "Left tics on/off") (Bottom (TOGGLETICS 'BOTTOM) "Bottom tics on/off") (Right (TOGGLETICS 'RIGHT) "Right tics on/off"))) (Undelete UNDELETEPLOTOBJECT "Undelete last deleted object" (SUBITEMS (Top (UNDELETEPLOTOBJECT 'TOP) "Undelete last deleted object" ) (Select (UNDELETEPLOTOBJECT 'SELECT) "Select object to undelete" ) (Above (UNDELETEPLOTOBJECT 'ABOVE) "Undelete all objects above selected object" ) (All (UNDELETEPLOTOBJECT 'ALL) "Undelete all deleted objects" ))) (Fixed% Menu TOGGLEFIXEDMENU "Fix Plot menu"))) (RPAQQ OBJECTOPSTABLE ((POINT (DRAWFN DRAWPOINTOBJECT) (ERASEFN ERASEPOINTOBJECT) (HIGHLIGHTFN HIGHLIGHTPOINT) (MOVEFN MOVEPOINT) (LABELFN LABELPOINT) (EXTENTFN EXTENTOFPOINT) (DISTANCEFN DISTANCETOPOINT) (COPYFN COPYPOINT) (PUTFN PUTPOINT) (GETFN GETPOINT)) (CURVE (DRAWFN DRAWCURVEOBJECT) (ERASEFN ERASECURVEOBJECT) (HIGHLIGHTFN HIGHLIGHTCURVE) (MOVEFN MOVECURVE) (EXTENTFN EXTENTOFCURVE) (DISTANCEFN DISTANCETOCURVE) (COPYFN COPYCURVE) (PUTFN PUTCURVE) (GETFN GETCURVE)) (POLYGON (DRAWFN DRAWPOLYGONOBJECT) (ERASEFN ERASEPOLYGONOBJECT) (HIGHLIGHTFN HIGHLIGHTPOLYGON) (MOVEFN MOVEPOLYGON) (EXTENTFN EXTENTOFPOLYGON) (DISTANCEFN DISTANCETOPOLYGON) (COPYFN COPYPOLYGON) (PUTFN PUTPOLYGON) (GETFN GETPOLYGON)) (LINE (DRAWFN DRAWLINEOBJECT) (ERASEFN ERASELINEOBJECT) (HIGHLIGHTFN HIGHLIGHTLINE) (MOVEFN MOVELINE) (EXTENTFN EXTENTOFLINE) (DISTANCEFN DISTANCETOLINE) (COPYFN COPYLINE) (PUTFN PUTLINE) (GETFN GETLINE)) (GRAPH (DRAWFN DRAWGRAPHOBJECT) (ERASEFN ERASEGRAPHOBJECT) (HIGHLIGHTFN HIGHLIGHTGRAPH) (EXTENTFN EXTENTOFGRAPH) (DISTANCEFN DISTANCETOGRAPH) (COPYFN COPYGRAPHOBJECT) (PUTFN PUTGRAPH) (GETFN GETGRAPH)) (TEXT (DRAWFN DRAWTEXTOBJECT) (ERASEFN ERASETEXTOBJECT) (HIGHLIGHTFN HIGHLIGHTTEXT) (MOVEFN MOVETEXT) (LABELFN LABELTEXT) (EXTENTFN EXTENTOFTEXT) (DISTANCEFN DISTANCETOTEXT) (COPYFN COPYTEXT) (PUTFN PUTTEXT) (GETFN GETTEXT)) (COMPOUND (DRAWFN DRAWCOMPOUNDOBJECT) (ERASEFN ERASECOMPOUNDOBJECT) (HIGHLIGHTFN HIGHLIGHTCOMPOUND) (LOWLIGHTFN LOWLIGHTCOMPOUND) (MOVEFN MOVECOMPOUND) (EXTENTFN EXTENTOFCOMPOUND) (DISTANCEFN DISTANCETOCOMPOUND) (COPYFN COPYCOMPOUND) (PUTFN PUTCOMPOUND) (GETFN GETCOMPOUND)) (FILLEDRECTANGLE (DRAWFN DRAWFILLEDRECTANGLEOBJECT) (ERASEFN ERASEFILLEDRECTANGLEOBJECT) (HIGHLIGHTFN HIGHLIGHTFILLEDRECTANGLE) (MOVEFN MOVEFILLEDRECTANGLE) (EXTENTFN EXTENTOFFILLEDRECTANGLE) (DISTANCEFN DISTANCETOFILLEDRECTANGLE) (COPYFN COPYFILLEDRECTANGLE) (PUTFN PUTFILLEDRECTANGLE) (GETFN GETFILLEDRECTANGLE)))) (DECLARE%: EVAL@COMPILE (DATATYPE EXTENT ((MINX FLOATING) (MAXX FLOATING) (MINY FLOATING) (MAXY FLOATING))) (DATATYPE MARGIN (TICS? TICMETHOD LABEL TICLIST)) (DATATYPE PLOT (PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST) (* ;; "PLOTOBJECTS is a display list, PLOTSCALE describes the scale in world coordinates, USERDATA is a prop list, SAVELIST is for undelete") (* ;;  "WINDOWINFO descibes the associated PLOTWINDOW and its attached PLOTPROMPTWINDOW") (DATATYPE WINDOWINFO (PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW)) (* ;; "MARGININFO describes the size of the plot margins in stream coordinates") (DATATYPE MARGININFO (LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN)) (* ;; "MENUINFO decribes the PLOT's menus") (DATATYPE MENUINFO (MIDDLEMENU RIGHTMENU OTHERMENUS)) [ACCESSFNS PLOT ([XLOWER (fetch MIN of (fetch XINTERVAL of (fetch PLOTSCALE of DATUM] [XUPPER (fetch MAX of (fetch XINTERVAL of (fetch PLOTSCALE of DATUM] [YLOWER (fetch MIN of (fetch YINTERVAL of (fetch PLOTSCALE of DATUM] (YUPPER (fetch MAX of (fetch YINTERVAL of (fetch PLOTSCALE of DATUM]) (DATATYPE PLOTFNS (DRAWFN ERASEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN EXTENTFN DISTANCEFN COPYFN PUTFN GETFN)) (DATATYPE PLOTOBJECT (OBJECTFNS OBJECTSUBTYPE OBJECTUSERDATA OBJECTMENU OBJECTLABEL OBJECTDATA)) (DATATYPE AXISINFO (SCALEFN TICFN) (* ; "SCALEFN and TICFN are functions") ) (DATATYPE AXISINTERVAL ((MIN FLOATING) (MAX FLOATING)) [ACCESSFNS (INTERVALLENGTH (FDIFFERENCE (fetch MAX of DATUM) (fetch MIN of DATUM]) (DATATYPE PLOTSCALE (XINTERVAL XAXISINFO XTICINFO YINTERVAL YAXISINFO YTICINFO) (* ;; "XINTERVAL YINTERVAL are instances of AXISINTERVAL, XAXISINFO and YAXISINFO are instances of AXISINFO and XTICINFO and YTICINFO are instances of TICINFO") ) (DATATYPE TICINFO ((TICMIN FLOATING) (TICMAX FLOATING) TICINC NTICS) [ACCESSFNS (TICINTERVALLENGTH (FDIFFERENCE (fetch (TICINFO TICMAX) of DATUM) (fetch (TICINFO TICMIN) of DATUM]) ) (/DECLAREDATATYPE 'EXTENT '(FLOATP FLOATP FLOATP FLOATP) '((EXTENT 0 FLOATP) (EXTENT 2 FLOATP) (EXTENT 4 FLOATP) (EXTENT 6 FLOATP)) '8) (/DECLAREDATATYPE 'MARGIN '(POINTER POINTER POINTER POINTER) '((MARGIN 0 POINTER) (MARGIN 2 POINTER) (MARGIN 4 POINTER) (MARGIN 6 POINTER)) '8) (/DECLAREDATATYPE 'MENUINFO '(POINTER POINTER POINTER) '((MENUINFO 0 POINTER) (MENUINFO 2 POINTER) (MENUINFO 4 POINTER)) '6) (/DECLAREDATATYPE 'MARGININFO '(POINTER POINTER POINTER POINTER) '((MARGININFO 0 POINTER) (MARGININFO 2 POINTER) (MARGININFO 4 POINTER) (MARGININFO 6 POINTER)) '8) (/DECLAREDATATYPE 'WINDOWINFO '(POINTER POINTER POINTER) '((WINDOWINFO 0 POINTER) (WINDOWINFO 2 POINTER) (WINDOWINFO 4 POINTER)) '6) (/DECLAREDATATYPE 'PLOT '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOT 0 POINTER) (PLOT 2 POINTER) (PLOT 4 POINTER) (PLOT 6 POINTER) (PLOT 8 POINTER) (PLOT 10 POINTER) (PLOT 12 POINTER) (PLOT 14 POINTER)) '16) (/DECLAREDATATYPE 'PLOTFNS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTFNS 0 POINTER) (PLOTFNS 2 POINTER) (PLOTFNS 4 POINTER) (PLOTFNS 6 POINTER) (PLOTFNS 8 POINTER) (PLOTFNS 10 POINTER) (PLOTFNS 12 POINTER) (PLOTFNS 14 POINTER) (PLOTFNS 16 POINTER) (PLOTFNS 18 POINTER) (PLOTFNS 20 POINTER)) '22) (/DECLAREDATATYPE 'PLOTOBJECT '(POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTOBJECT 0 POINTER) (PLOTOBJECT 2 POINTER) (PLOTOBJECT 4 POINTER) (PLOTOBJECT 6 POINTER) (PLOTOBJECT 8 POINTER) (PLOTOBJECT 10 POINTER)) '12) (/DECLAREDATATYPE 'AXISINFO '(POINTER POINTER) '((AXISINFO 0 POINTER) (AXISINFO 2 POINTER)) '4) (/DECLAREDATATYPE 'AXISINTERVAL '(FLOATP FLOATP) '((AXISINTERVAL 0 FLOATP) (AXISINTERVAL 2 FLOATP)) '4) (/DECLAREDATATYPE 'PLOTSCALE '(POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTSCALE 0 POINTER) (PLOTSCALE 2 POINTER) (PLOTSCALE 4 POINTER) (PLOTSCALE 6 POINTER) (PLOTSCALE 8 POINTER) (PLOTSCALE 10 POINTER)) '12) (/DECLAREDATATYPE 'TICINFO '(FLOATP FLOATP POINTER POINTER) '((TICINFO 0 FLOATP) (TICINFO 2 FLOATP) (TICINFO 4 POINTER) (TICINFO 6 POINTER)) '8) (DECLARE%: EVAL@COMPILE (PUTPROPS APPLY.AFTERFN MACRO (ARGS (APPLY.AFTERFN.MACRO ARGS))) (PUTPROPS PLOTOBJECTSUBTYPE? MACRO [ARGS `(EQ ',(CAR ARGS) (fetch (PLOTOBJECT OBJECTSUBTYPE) of ,(CADR ARGS]) (PUTPROPS PLOTOBJECTPROP MACRO (ARGS (PLOTOBJECTPROPMACRO ARGS))) (PUTPROPS PLOTPROP MACRO (ARGS (PLOTPROPMACRO ARGS))) ) (PUTPROPS PLOTOBJECTPROP ARGNAMES (NIL (PLOTOBJECT PROP NEWVALUE) . PROPARGS)) (PUTPROPS PLOT.DEFAULTMENU ARGNAMES (NIL (MENUNAME NEWMENUITEMS) . MENUARGS)) (PUTPROPS PLOT.FIXRIGHTMENU ARGNAMES (NIL (PLOT FIXEDFLG) . PROPARGS)) (PUTPROPS PLOTLABEL ARGNAMES (NIL (PLOT MARGINNAME NEWLABEL NODRAWFLG) . LABELARGS)) (PUTPROPS PLOTMENU ARGNAMES (NIL (PLOT MENUNAME NEWMENU) . MENUARGS)) (PUTPROPS PLOTMENUITEMS ARGNAMES (NIL (PLOT MENUNAME NEWMENUITEMS) . MENUARGS)) (PUTPROPS PLOTPRETTYFNS ARGNAMES (NIL (PLOT AXIS NEWPRETTYSCALEFN NEWINVPRETTYSCALEFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTPROP ARGNAMES (NIL (PLOT PROP NEWVALUE) . PROPARGS)) (PUTPROPS PLOTSCALEFN ARGNAMES (NIL (PLOT AXIS NEWSCALEFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTTICFN ARGNAMES (NIL (PLOT AXIS NEWTICFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTTICS ARGNAMES (NIL (PLOT MARGINNAME NEWTICFLG NODRAWFLG) . LABELARGS)) (RPAQ? SMALLPLOTFONT '(GACHA 8 MRR)) (RPAQ? LARGEPLOTFONT '(GACHA 12 BRR)) (* ;;; "PLOT I/O") (DEFINEQ (COPYPLOTOBJECT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 28-Sep-91 16:32 by jds") (* ;; "Returns a copy of PLOTOBJECT. OBJECTPROPS are handled as follows. If the PLOTOBJECT has a COPYFN (which may be a list of fns) on its prop list, apply's it to NEWPLOTOBJECT PLOTOBJECT PLOT and expects it to copy the OBJECTPROPs, else calls COPYALL, except for PLOTOBJECTS or lists of PLOTOBJECTS which are COPYOBJECT'ed") (PROG ([OBJECTCOPYFN (MKLIST (PLOTOBJECTPROP PLOTOBJECT 'COPYFN] NEWPLOTOBJECT) (SETQ NEWPLOTOBJECT (CREATEPLOTOBJECT (fetch (PLOTOBJECT OBJECTFNS) of PLOTOBJECT ) (PLOTOBJECTSUBTYPE PLOTOBJECT) (COPYALL (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT)) (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT) (CL:FUNCALL (fetch (PLOTFNS COPYFN) of (fetch (PLOTOBJECT OBJECTFNS) of PLOTOBJECT)) PLOTOBJECT PLOT))) [for PROPNAME in (for PROP in (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT) by (CDDR PROP) collect PROP) do (PLOTOBJECTPROP NEWPLOTOBJECT PROPNAME (OR (AND OBJECTCOPYFN (bind PROPVALUE for FN in OBJECTCOPYFN until (SETQ PROPVALUE (CL:FUNCALL FN NEWPLOTOBJECT PLOTOBJECT PLOT PROPNAME)) finally (RETURN PROPVALUE))) (LET ((PROPVALUE (PLOTOBJECTPROP PLOTOBJECT PROPNAME))) (COND ((type? PLOTOBJECT PROPVALUE) (COPYPLOTOBJECT PROPVALUE)) [(LISTP PROPVALUE) (for ITEM in PROPVALUE collect (COND ((type? PLOTOBJECT ITEM) (COPYPLOTOBJECT ITEM PLOT)) (T (HCOPYALL ITEM] (T (HCOPYALL PROPVALUE] (COND ([OR (NOT (type? PLOTOBJECT NEWPLOTOBJECT)) (NOT (EQ (PLOTOBJECTSUBTYPE NEWPLOTOBJECT) (PLOTOBJECTSUBTYPE PLOTOBJECT] (HELP "Not a plotobject of correct type" NEWPLOTOBJECT))) (RETURN NEWPLOTOBJECT]) (COPYPLOT [LAMBDA (PLOT OPENFLG REGION TITLE BORDER) (* ; "Edited 5-May-87 18:27 by jop") (* ;; "Copies a PLOT. Copying of PLOTPROP's is handled as follows. If PLOT has a COPYPLOTFN, (which may be a list of fns) calls it with NEWPLOT PLOT as args, and expects it to copy the PLOTPROPS intelligently, else HCOPYALL's the PROPS, except for PLOTOBJECTS or lists of PLOTOBJECTS which are COPYOBJECT'ed") (PROG ([COPYFN (MKLIST (PLOTPROP PLOT 'COPYFN] (NEWPLOT (create PLOT))) (* ; "OK to share Menus") (replace (PLOT MIDDLEMENU) of NEWPLOT with (fetch (PLOT MIDDLEMENU) of PLOT)) (replace (PLOT RIGHTMENU) of NEWPLOT with (fetch (PLOT RIGHTMENU) of PLOT)) (* ;  "OTHERMENUS copied since it is a list in prop format and consists of MENU's or LITATOMS") (replace (PLOT OTHERMENUS) of NEWPLOT with (COPY (fetch (PLOT OTHERMENUS) of PLOT))) (replace (PLOT LEFTMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT LEFTMARGIN) of PLOT))) (replace (PLOT RIGHTMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT RIGHTMARGIN) of PLOT))) (replace (PLOT TOPMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT TOPMARGIN) of PLOT))) (replace (PLOT BOTTOMMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT BOTTOMMARGIN ) of PLOT))) (* ;  "Plot objects not shared since they can be distructively modified") (replace (PLOT PLOTOBJECTS) of NEWPLOT with (for OBJECT in (fetch (PLOT PLOTOBJECTS ) of PLOT) collect (COPYPLOTOBJECT OBJECT PLOT))) (replace (PLOT PLOTSCALE) of NEWPLOT with (create PLOTSCALE copying (fetch (PLOT PLOTSCALE) of PLOT))) (* ;  "Does a HCOPYALL since we don't know what's cached here") [for PROPNAME in (for PROP in (fetch (PLOT PLOTUSERDATA) of PLOT) by (CDDR PROP) collect PROP) do (PLOTPROP NEWPLOT PROPNAME (OR (AND COPYFN (bind PROPVALUE for FN in COPYFN until (SETQ PROPVALUE (CL:FUNCALL FN NEWPLOT PLOT PROPNAME)) finally (RETURN PROPVALUE))) (LET ((PROPVALUE (PLOTPROP PLOT PROPNAME))) (COND ((type? PLOTOBJECT PROPVALUE) (COPYPLOTOBJECT PROPVALUE)) [(LISTP PROPVALUE) (for ITEM in PROPVALUE collect (COND ((type? PLOTOBJECT ITEM) (COPYPLOTOBJECT ITEM PLOT)) (T (HCOPYALL ITEM] (T (HCOPYALL PROPVALUE] (* ; "Cache the display parameters") [COND ((OR REGION TITLE BORDER) (replace (PLOT PLOTWINDOW) of NEWPLOT with (LIST REGION TITLE BORDER] (COND (OPENFLG (OPENPLOTWINDOW NEWPLOT))) (RETURN NEWPLOT]) (PLOTOBJECTPRINT [LAMBDA (PLOTOBJECT STREAM) (* ; "Edited 28-Sep-91 16:32 by jds") (PRINTOUT STREAM "#<" (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT) " PLOTOBJECT>@") (\PRINTADDR PLOTOBJECT STREAM) T]) (PRINTPLOTOBJECT [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 28-Sep-91 16:32 by jds") (* ;; "Puts a plot object on STREAM") (PROG [(OBJECTPUTFN (MKLIST (PLOTOBJECTPROP PLOTOBJECT 'PUTFN] (PRINTOUT STREAM "(READPLOTOBJECT)(" %, "OBJECTSUBTYPE" %, .P2 (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT) %, "OBJECTDATA" %,) (CL:FUNCALL (fetch (PLOTFNS PUTFN) of (fetch (PLOTOBJECT OBJECTFNS) of PLOTOBJECT)) PLOTOBJECT PLOT STREAM) (PRINTOUT STREAM %, "OBJECTMENU" %,) (HPRINT (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT) STREAM T T) (PRINTOUT STREAM %, "OBJECTLABEL" %, .P2 (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT ) %,) (PRINTOUT STREAM "OBJECTUSERDATA (") (for PROPNAME in (for PROP in (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT) by (CDDR PROP) collect PROP) do (PRINTOUT STREAM PROPNAME %,) (if (NULL (for FN in OBJECTPUTFN thereis (CL:FUNCALL FN PLOTOBJECT PLOT PROPNAME STREAM))) then (HPRINT (PLOTOBJECTPROP PLOTOBJECT PROPNAME) STREAM NIL T))) (PRINTOUT STREAM "))") (RETURN T]) (PRINTPLOT [LAMBDA (PLOT STREAM) (* ; "Edited 5-May-87 18:27 by jop") (* ;; "Puts out a symbolic representation of PLOT on STREAM") (PROG ([PUTFN (MKLIST (PLOTPROP PLOT 'PUTFN] MENU) (PRINTOUT STREAM "(READPLOT)(") (PRINTOUT STREAM "RIGHTMENU" %,) (if (EQ (PLOT.DEFAULTMENU 'RIGHT) (fetch (PLOT RIGHTMENU) of PLOT)) then (PRINTOUT STREAM "DEFAULT" %,) else (HPRINT (fetch (PLOT RIGHTMENU) of PLOT) STREAM T T)) (PRINTOUT STREAM "MIDDLEMENU" %,) (if (EQ (PLOT.DEFAULTMENU 'MIDDLE) (fetch (PLOT MIDDLEMENU) of PLOT)) then (PRINTOUT STREAM "DEFAULT" %,) else (HPRINT (fetch (PLOT MIDDLEMENU) of PLOT) STREAM T T)) (for FIELDNAME in '((PLOT OTHERMENUS) (PLOT LEFTMARGIN) (PLOT TOPMARGIN) (PLOT RIGHTMARGIN) (PLOT BOTTOMMARGIN) (PLOT PLOTSCALE)) do (PRINTOUT STREAM (CADR FIELDNAME) %,) (HPRINT (RECORDACCESS FIELDNAME PLOT) STREAM T T)) (PRINTOUT STREAM %, "PLOTOBJECTS (") (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (HPRINT OBJECT STREAM T T)) (PRINTOUT STREAM ")" %,) (PRINTOUT STREAM %, "PLOTUSERDATA (") (for PROPNAME in (for PROP in (fetch (PLOT PLOTUSERDATA) of PLOT) by (CDDR PROP) collect PROP) do (PRINTOUT STREAM %, PROPNAME %,) (if (NULL (for FN in PUTFN thereis (CL:FUNCALL FN PLOT PROPNAME STREAM))) then (HPRINT (PLOTPROP PLOT PROPNAME) STREAM NIL T))) (PRINTOUT STREAM ")" %,) (PRINTOUT STREAM ")") (RETURN T]) (READFONT [LAMBDA (STREAM) (* jop%: "27-Aug-85 13:34") (PROG ((PROPLIST (READ STREAM))) (RETURN (FONTCREATE (LISTGET PROPLIST 'FAMILY) (LISTGET PROPLIST 'SIZE) (LISTGET PROPLIST 'FACE) (LISTGET PROPLIST 'ROTATION) (LISTGET PROPLIST 'DEVICE]) (READMENU [LAMBDA (STREAM) (* ; "Edited 6-May-87 09:31 by jop") (* ;; "Function For Reading Menus From File") (PROG ((PROPLIST (HREAD STREAM))) (RETURN (create MENU ITEMS _ (LISTGET PROPLIST 'ITEMS) WHENSELECTEDFN _ (LISTGET PROPLIST 'WHENSELECTEDFN) WHENHELDFN _ (LISTGET PROPLIST 'WHENHELDFN) WHENUNHELDFN _ (LISTGET PROPLIST 'WHENUNHELDFN) MENUPOSITION _ (LISTGET PROPLIST 'MENUPOSITION) MENUOFFSET _ (LISTGET PROPLIST 'MENUOFFSET) MENUFONT _ (LISTGET PROPLIST 'MENUFONT) TITLE _ (LISTGET PROPLIST 'TITLE) CENTERFLG _ (LISTGET PROPLIST 'CENTERFLG) MENUROWS _ (LISTGET PROPLIST 'MENUROWS) MENUCOLUMNS _ (LISTGET PROPLIST 'MENUCOLUMNS) ITEMHEIGHT _ (LISTGET PROPLIST 'ITEMHEIGHT) ITEMWIDTH _ (LISTGET PROPLIST 'ITEMWIDTH) MENUBORDERSIZE _ (LISTGET PROPLIST 'MENUBORDERSIZE) MENUOUTLINESIZE _ (LISTGET PROPLIST 'MENUOUTLINESIZE) CHANGEOFFSETFLG _ (LISTGET PROPLIST 'CHANGEOFFSETFLG]) (READPLOTOBJECT [LAMBDA (STREAM) (* ; "Edited 5-May-87 18:27 by jop") (* ;; "Reads a plot object from STREAM previously written out by PRINTOBJECT") (PROG ((PROPLST (HREAD STREAM)) OBJECTSUBTYPE OBJECTFNS OBJECTGETFN NEWOBJECT OBJECTUSERDATA) (SETQ OBJECTSUBTYPE (LISTGET PROPLST 'OBJECTSUBTYPE)) [SETQ OBJECTFNS (EVAL (PACK* OBJECTSUBTYPE 'FNS] (SETQ OBJECTGETFN (fetch (PLOTFNS GETFN) of OBJECTFNS)) [SETQ NEWOBJECT (CREATEPLOTOBJECT OBJECTFNS OBJECTSUBTYPE (LISTGET PROPLST 'OBJECTLABEL) (LISTGET PROPLST 'OBJECTMENU) (CL:FUNCALL OBJECTGETFN (LISTGET PROPLST 'OBJECTDATA] (SETQ OBJECTUSERDATA (LISTGET PROPLST 'OBJECTUSERDATA)) (for PROPNAME in OBJECTUSERDATA by (CDDR PROPNAME) as PROPVALUE in (CDR OBJECTUSERDATA) by (CDDR PROPVALUE) do (PLOTOBJECTPROP NEWOBJECT PROPNAME (if (AND (LISTP PROPVALUE) (EQ (CAR PROPVALUE) 'FUNCTION)) then (SETQ PROPVALUE (CL:FUNCALL (CADR PROPVALUE) NEWOBJECT PROPNAME)) else PROPVALUE))) (RETURN NEWOBJECT]) (READPLOT [LAMBDA (STREAM) (* ; "Edited 5-May-87 18:28 by jop") (* ;;  "Reads In a Symbolic Representation Of A PLOT From Stream Previously Written Out By PRINTPLOT") (LET* [(PROPLST (HREAD STREAM)) (RIGHTMENU (LISTGET PROPLST 'RIGHTMENU)) (MIDDLEMENU (LISTGET PROPLST 'MIDDLEMENU)) (USERDATA (LISTGET PROPLST 'PLOTUSERDATA)) (PLOT (create PLOT OTHERMENUS _ (LISTGET PROPLST 'OTHERMENUS) LEFTMARGIN _ (LISTGET PROPLST 'LEFTMARGIN) TOPMARGIN _ (LISTGET PROPLST 'TOPMARGIN) RIGHTMARGIN _ (LISTGET PROPLST 'RIGHTMARGIN) BOTTOMMARGIN _ (LISTGET PROPLST 'BOTTOMMARGIN) PLOTSCALE _ (LISTGET PROPLST 'PLOTSCALE) PLOTOBJECTS _ (LISTGET PROPLST 'PLOTOBJECTS] (PLOTMENU PLOT 'RIGHT (if (EQ RIGHTMENU 'DEFAULT) then (PLOT.DEFAULTMENU 'RIGHT) else RIGHTMENU)) (PLOTMENU PLOT 'MIDDLE (if (EQ MIDDLEMENU 'DEFAULT) then (PLOT.DEFAULTMENU 'MIDDLE) else MIDDLEMENU)) (for PROPNAME in USERDATA by (CDDR PROPNAME) as PROPVALUE in (CDR USERDATA) by (CDDR PROPVALUE) do (PLOTPROP PLOT PROPNAME (if [AND (LISTP PROPVALUE) (AND (LISTP (CAR PROPVALUE)) (EQ (CAAR PROPVALUE) 'FUNCTION] then (* ;  "Assumes Lists Of Form ((Function Foo) Bar)") (SETQ PROPVALUE (CL:FUNCALL (CADAR PROPVALUE ) PLOT PROPNAME (CADR PROPVALUE))) else PROPVALUE))) PLOT]) ) (DEFINEQ (PRINT-VECTOR [LAMBDA (VECTOR STREAM) (* ; "Edited 1-Jun-87 17:34 by jop") (PRINTOUT STREAM "(READ-VECTOR)") (PRIN2 (COERCE VECTOR 'LIST) STREAM]) (READ-VECTOR [LAMBDA (STREAM) (* ; "Edited 1-Jun-87 17:39 by jop") (LET ((LST (HREAD STREAM))) (CL:MAKE-ARRAY (LENGTH LST) :INITIAL-CONTENTS LST]) ) (PUTDEF (QUOTE PLOTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (PLTS (HORRIBLEVARS . PLTS]) (ADDTOVAR HPRINTMACROS (FONTDESCRIPTOR . PRINTFONT) (MENU . PRINTMENU) (PLOT . PRINTPLOT) (PLOTOBJECT . PRINTPLOTOBJECT) (ONED-ARRAY . PRINT-VECTOR)) (ADDTOVAR HPRINTREADFNS READPLOT READPLOTOBJECT READFONT READMENU READ-VECTOR) (DEFPRINT 'PLOTOBJECT (FUNCTION PLOTOBJECTPRINT)) (* ;;; "Numeric fns") (DEFINEQ (PLOT.EXP10 [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (* ;; "this procedure returns exact power of ten for integer args") (EXPT 10.0 X]) (PLOT.LOG10 [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (* ;; "Returns log base 10 of X") (PROG [(C (CONSTANT (FQUOTIENT 1.0 (LOG 10.0] (RETURN (FTIMES C (LOG X]) (PLOT.FLOOR [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (SETQ X (FLOAT X)) (PROG ((FIXX (FIX X))) (RETURN (COND [(MINUSP X) (COND ((EQP FIXX X) FIXX) (T (SUB1 FIXX] (T FIXX]) (PLOT.CEILING [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (SETQ X (FLOAT X)) (PROG ((FIXX (FIX X))) (RETURN (COND ((MINUSP X) FIXX) (T (COND ((EQP FIXX X) FIXX) (T (ADD1 FIXX]) (SINEWAVE [LAMBDA (N FREQUENCY FROM TO AMPLITUDE) (* ; "Edited 6-May-87 09:33 by jop") (* ;; "produce N points on a sine wave") (PROG ((TWOPI (TIMES 2.0 3.14159)) (RANGE (FDIFFERENCE TO FROM))) (if (NULL FREQUENCY) then (SETQ FREQUENCY 1)) (if (NULL AMPLITUDE) then (SETQ AMPLITUDE 1)) (RETURN (bind (X _ FROM) (INC _ (FQUOTIENT RANGE N)) POINT for I from 1 to N collect [SETQ POINT (create POSITION XCOORD _ X YCOORD _ (TIMES AMPLITUDE (SIN (TIMES FREQUENCY X ) T] (SETQ X (PLUS X INC)) POINT]) ) (* ;;; "PLOT image object FNS") (DEFINEQ (CREATEPLOTIMAGEOBJ [LAMBDA (PLOT) (* ; "Edited 27-May-87 18:38 by jop") (* ;; "creates PLOT image object from PLOT") (LET* ((WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (REGION (IF (WINDOWP WINDOW) THEN (WINDOWPROP WINDOW 'REGION) ELSE (CAR WINDOW))) (OBJ (IMAGEOBJCREATE (COPYPLOT PLOT) PLOTIMAGEFNS))) (IMAGEOBJPROP OBJ 'WIDTH (FETCH (REGION WIDTH) OF REGION)) (IMAGEOBJPROP OBJ 'HEIGHT (FETCH (REGION HEIGHT) OF REGION)) OBJ]) (CREATEPLOTBITMAPOBJ [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:19 by jop") (LET* [(WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (BITMAP (BITMAPCREATE (WINDOWPROP WINDOW 'WIDTH) (WINDOWPROP WINDOW 'HEIGHT] (BITBLT WINDOW NIL NIL BITMAP) (BITMAPTEDITOBJ BITMAP 1 0]) (PLIO.BUTTONEVENTINFN [LAMBDA (PLOTIMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) (* ; "Edited 28-Sep-91 17:05 by jds") (PROG ([CHOICEMENU (CONSTANT (create MENU CENTERFLG _ T ITEMS _ '(("Select" 'SELECT "Select the image object") ("Reshape" 'RESHAPE "Reshape the image objcet") ("Plot Window" 'EDIT "Open a window containing plot"] (PLOT (IMAGEOBJPROP PLOTIMAGEOBJ 'OBJECTDATUM)) (IMAGEWIDTH (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH)) (IMAGEHEIGHT (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT)) MINSIZE NEWREGION WIN NEWPLOT) (* ;; "consider selection if BUTTON=NIL to handle plots in Koto version of Sketch") (COND ((OR (NOT BUTTON) (EQ BUTTON 'LEFT)) (SELECTQ (MENU CHOICEMENU) (RESHAPE (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP (fetch (PLOT PLOTWINDOW ) of PLOT) 'DSP) PLOT)) (* ;  "Assumes the WINDOWSTREAM has been changed to fit the imageobj") (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE) (CREATEREGION (DSPXOFFSET NIL WINDOWSTREAM) (DSPYOFFSET NIL WINDOWSTREAM) IMAGEWIDTH IMAGEHEIGHT))) (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH (fetch (REGION WIDTH) of NEWREGION )) (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT (fetch (REGION HEIGHT) of NEWREGION)) (* ; "Redraw the Image object") (RETURN 'CHANGED)) (EDIT (SETQ NEWPLOT (COPYPLOT PLOT NIL (GETBOXREGION (WIDTHIFWINDOW IMAGEWIDTH) (HEIGHTIFWINDOW IMAGEHEIGHT T)) "Plot Edit Window")) (SETQ WIN (OPENPLOTWINDOW NEWPLOT)) (* ;; "Cache some info some that changes to NEWPLOT may be reinserted into TEXTSTREAM. Windowprops are used because they are not copied (HACK)") (* ;;  "sketch doesn't pass down anything for TEXTSTREAM arg so must use viewer window instead") (WINDOWPROP WIN 'SOURCEHOST (OR TEXTSTREAM WINDOW WINDOWSTREAM)) (WINDOWPROP WIN 'SOURCEIMAGEOBJ PLOTIMAGEOBJ) (WINDOWADDPROP WIN 'CLOSEFN 'PLIO.EDITCLOSEFN T) (* ;; "handle reinsert by a closefn rather than an new menu item -- similar to the behavior of Sketch image object edits (PLOTADDMENUITEMS NEWPLOT (QUOTE RIGHT) (QUOTE ((Reinsert PLIO.REINSERTOBJ 'Change source image object'))))") (RETURN T)) (RETURN NIL))) (T (RETURN NIL]) (PLIO.COPYFN [LAMBDA (PLOTIOBJ) (* ; "Edited 6-May-87 09:35 by jop") (* ; "simple copy") (PROG ((NEWOBJ (IMAGEOBJCREATE NIL PLOTIMAGEFNS))) [IMAGEOBJPROP NEWOBJ 'OBJECTDATUM (COPYPLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM] (IMAGEOBJPROP NEWOBJ 'WIDTH (IMAGEOBJPROP PLOTIOBJ 'WIDTH)) (IMAGEOBJPROP NEWOBJ 'HEIGHT (IMAGEOBJPROP PLOTIOBJ 'HEIGHT)) (RETURN NEWOBJ]) (PLIO.GETFN [LAMBDA (STREAM TEXTSTREAM) (* ; "Edited 6-May-87 09:35 by jop") (* ;; "PLOT IMAGEOBJECT GETFN") (PROG ((PROPLST (HREAD STREAM)) PLOTIMAGEOBJ) (SETQ PLOTIMAGEOBJ (IMAGEOBJCREATE (LISTGET PROPLST 'PLOT) PLOTIMAGEFNS)) (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH (LISTGET PROPLST 'WIDTH)) (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT (LISTGET PROPLST 'HEIGHT)) (RETURN PLOTIMAGEOBJ]) (PLIO.PUTFN [LAMBDA (PLOTIMAGEOBJ STREAM) (* ; "Edited 6-May-87 09:35 by jop") (* ;; "PLOT IMAGEOBJECT PUTFN") (PRINTOUT STREAM "(WIDTH" %, (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH) %, "HEIGHT" %, (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT) %, "PLOT" %,) (HPRINT (IMAGEOBJPROP PLOTIMAGEOBJ 'OBJECTDATUM) STREAM T T) (PRINTOUT STREAM ")"]) (PLIO.REINSERTOBJ [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 16:21 by jds") (* ;; "allows modified plot to be reinserted in document") (* ;; "modified to work with Sketch as well as TEdit sources") (PROG ((PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) HOST OBJ) (SETQ HOST (WINDOWPROP PLOTWINDOW 'SOURCEHOST)) (SETQ OBJ (WINDOWPROP PLOTWINDOW 'SOURCEIMAGEOBJ)) (COND ((NOT (IMAGEOBJP OBJ)) (HELP "Not an IMAGEOBJ" OBJ))) (* ;  "Destructively change imageobj to retain EQ ness") (IMAGEOBJPROP OBJ 'OBJECTDATUM (COPYPLOT PLOT)) (IMAGEOBJPROP OBJ 'WIDTH (WINDOWPROP PLOTWINDOW 'WIDTH)) (IMAGEOBJPROP OBJ 'HEIGHT (WINDOWPROP PLOTWINDOW 'HEIGHT)) (IMAGE.OBJECT.CHANGED HOST OBJ]) (PLOT.COPYBUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-May-87 09:36 by jop") (* ;; "Allows plots to be copy selected") (PROG ((PLOT (WINDOWPROP WINDOW 'PLOT)) [IMAGETYPEMENU (CONSTANT (create MENU ITEMS _ '((Plot 'PLOT) (Bitmap 'BITMAP] IMAGEOBJ) (INVERTW WINDOW) (UNTILMOUSESTATE UP) (INVERTW WINDOW) (COND ((INSIDEP WINDOW (CURSORPOSITION NIL WINDOW)) (SELECTQ (MENU IMAGETYPEMENU) (PLOT (SETQ IMAGEOBJ (CREATEPLOTIMAGEOBJ PLOT))) (BITMAP (SETQ IMAGEOBJ (CREATEPLOTBITMAPOBJ PLOT))) NIL) (AND IMAGEOBJ (COPYINSERT IMAGEOBJ]) (PLIO.DISPLAYFN [LAMBDA (PLOTIOBJ IMAGESTREAM) (* ; "Edited 7-May-87 18:21 by jop") (* ;; "Displays plot image object") (PROG ((PLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM)) (VIEWPORT (IMAGEOBJPROP PLOTIOBJ 'VIEWPORT)) (SCALE (DSPSCALE NIL IMAGESTREAM)) STREAMREGION) (COND ((OR (NULL VIEWPORT) (NOT (EQ (fetch PARENTSTREAM of VIEWPORT) IMAGESTREAM))) (SETQ VIEWPORT (CREATEVIEWPORT IMAGESTREAM)) (IMAGEOBJPROP PLOTIOBJ 'VIEWPORT VIEWPORT))) [SETQ STREAMREGION (CREATEREGION (DSPXPOSITION NIL IMAGESTREAM) (DSPYPOSITION NIL IMAGESTREAM) [FIXR (TIMES SCALE (IMAGEOBJPROP PLOTIOBJ 'WIDTH] (FIXR (TIMES SCALE (IMAGEOBJPROP PLOTIOBJ 'HEIGHT] (CREATETICLISTS PLOT) (ADJUSTVIEWPORT VIEWPORT STREAMREGION PLOT) (DRAWPLOT PLOT IMAGESTREAM VIEWPORT STREAMREGION]) (PLIO.IMAGEBOXFN [LAMBDA (PLOTIOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 6-May-87 09:36 by jop") (* ;; "Determines size of plotimageobj") (PROG ((IMAGEWIDTH (IMAGEOBJPROP PLOTIOBJ 'WIDTH)) (IMAGEHEIGHT (IMAGEOBJPROP PLOTIOBJ 'HEIGHT)) (PLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM)) (SCALE (COND (IMAGESTREAM (DSPSCALE NIL IMAGESTREAM)) (T 1))) NEWREGION MINSIZE) (* ;; "(* this doesn't work with Sketch which has no rightmargin) (if (GREATERP (TIMES SCALE IMAGEWIDTH) (DIFFERENCE RIGHTMARGIN CURRENTX)) then (if (NOT (EQ (IMAGESTREAMTYPE IMAGESTREAM) (QUOTE DISPLAY))) then (HELP 'PLOT image object too big')) (PROMPTPRINT 'Image object too wide. Choose a smaller region') (SETQ MINSIZE (MINSTREAMREGIONSIZE IMAGESTREAM PLOT)) (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE))) (SETQ IMAGEWIDTH (fetch WIDTH of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE WIDTH) IMAGEWIDTH) (SETQ IMAGEHEIGHT (fetch HEIGHT of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE HEIGHT) IMAGEHEIGHT))") (RETURN (create IMAGEBOX XSIZE _ (TIMES SCALE IMAGEWIDTH) YSIZE _ (TIMES SCALE IMAGEHEIGHT) YDESC _ 0 XKERN _ 0]) ) (* ;; "additional fns to allow plot im. objs. to work in Sketch") (DEFINEQ (PLIO.EDITCLOSEFN [LAMBDA (W) (* ; "Edited 5-May-87 18:10 by jop") (* ;; "this plot window is from an image object. Reinsert plot if requested") (* ;; "later could test if plot has been changed -- if no changes don't ask to reinsert") (LET (RESULT) (SETQ RESULT (SELECTQ (MENU (CONSTANT (create MENU TITLE _ "Change source image object?" ITEMS _ '(("Yes" 'YES "This image used in the document instead of the one that is there." ) ("No" 'NO "The changes made to this image will not be put into the document." )) CENTERFLG _ T))) (YES (PLIO.REINSERTOBJ (WHICHPLOT W)) NIL) (NO NIL) (NIL (* ;  "user selected outside the menu -- abort the close") 'DON'T) NIL)) (OR RESULT (WINDOWDELPROP W 'CLOSEFN 'PLIO.EDITCLOSEFN)) (* ;  "clean up window prop -- required since currently PLOT.CLOSEFN calls CLOSEW!") RESULT]) (IMAGE.OBJECT.CHANGED [LAMBDA (HOST OBJECT) (* ; "Edited 5-May-87 18:11 by jop") (* ;; "notifies HOST that OBJECT has changed and needs to be redisplayed") (* ;; "currently assumes object is in TEdit or Sketch") (LET (CANONICALHOST) (COND ([SETQ CANONICALHOST (CAR (NLSETQ (TEXTSTREAM HOST] (TEDIT.OBJECT.CHANGED CANONICALHOST OBJECT)) ([SETQ CANONICALHOST (CAR (NLSETQ (INSURE.SKETCH HOST] (* ;  "INSURE.SKETCH noerrorflg doesn't work") (SK.MARK.DIRTY CANONICALHOST) (* ;  "this sets SKETCHCHANGED prop of all viewers on the sketch") (for SKW in (SKETCH.ALL.VIEWERS CANONICALHOST) do (REDISPLAYW SKW))) (T (HELP "Can't update image object in " HOST]) ) (RPAQ? PLOTIMAGEFNS (IMAGEFNSCREATE (FUNCTION PLIO.DISPLAYFN) (FUNCTION PLIO.IMAGEBOXFN) (FUNCTION PLIO.PUTFN) (FUNCTION PLIO.GETFN) (FUNCTION PLIO.COPYFN) (FUNCTION PLIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PLOTIMAGEFNS) ) (* ;;; "Initialize") (PLOT.SETUP OBJECTOPSTABLE) (PLOT.DEFAULTMENU 'MIDDLE PLOT.DEFAULTMIDDLEMENUITEMS) (PLOT.DEFAULTMENU 'RIGHT PLOT.DEFAULTRIGHTMENUITEMS) (* ;;; "Dependent files") (FILESLOAD TWODGRAPHICS PLOTOBJECTS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PLOTTICS PLOTTICFN PLOTSCALEFN PLOTPROP PLOTOBJECTPROP PLOTMENUITEMS PLOTMENU PLOTLABEL PLOT.FIXRIGHTMENU PLOT.DEFAULTMENU) ) (PUTPROPS PLOT COPYRIGHT ("Venue" 1985 1986 1987 1988 1991 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8386 143842 (ADDPLOTOBJECT 8396 . 9560) (ADJUSTSCALE? 9562 . 12146) (ADJUSTVIEWPORT 12148 . 17120) (APPLY.AFTERFN.MACRO 17122 . 17776) (ASKFORLABEL 17778 . 19256) (ASKFORSCALE 19258 . 21120) (BOXREGION 21122 . 21874) (CHOOSESCALE 21876 . 22422) (CHOOSETICS 22424 . 22925) ( CLOSEPLOTWINDOW 22927 . 24074) (CLOSESTPLOTOBJECT 24076 . 24346) (COMPOUNDSUBTYPE 24348 . 24565) ( COMPUTEBOTTOMMARGIN 24567 . 25830) (COMPUTELEFTMARGIN 25832 . 27435) (COMPUTERIGHTMARGIN 27437 . 29018 ) (COMPUTETOPMARGIN 29020 . 30203) (COPYMENU 30205 . 31294) (CREATEPLOT 31296 . 34171) (CREATEPLOTFNS 34173 . 36425) (CREATEPLOTOBJECT 36427 . 37247) (DEFAULTSCALEFN 37249 . 37523) (DEFAULTTICFN 37525 . 39434) (DEFAULTTICMETHOD 39436 . 40822) (DELETEPLOTOBJECT 40824 . 42447) (DESELECTPLOTOBJECT 42449 . 42826) (DISTANCETOPLOTOBJECT 42828 . 43190) (DRAWBOTTOMMARGIN 43192 . 45380) (DRAWLEFTMARGIN 45382 . 47104) (DRAWMARGIN 47106 . 48024) (DRAWPLOTOBJECT 48026 . 48627) (DRAWPLOT 48629 . 49604) ( DRAWRIGHTMARGIN 49606 . 51487) (DRAWTOPMARGIN 51489 . 53557) (ERASEPLOTOBJECT 53559 . 54224) ( EXTENDEDSCALEFN 54226 . 54745) (EXTENTOFPLOTOBJECT 54747 . 55025) (EXTENTOFPLOT 55027 . 56364) ( GETPLOTWINDOW 56366 . 56543) (GETTICLIST 56545 . 57530) (HIGHLIGHTPLOTOBJECT 57532 . 58228) ( LABELPLOTOBJECT 58230 . 58674) (LOWLIGHTPLOTOBJECT 58676 . 59365) (MANUALRESCALE 59367 . 61388) ( MINSTREAMREGIONSIZE 61390 . 63259) (MOVEPLOTOBJECT 63261 . 63515) (OPENPLOTWINDOW 63517 . 69583) ( PLOT.BUTTONEVENTFN 69585 . 75343) (PLOT.CLOSEFN 75345 . 75512) (PLOT.DEFAULTMENU 75514 . 77093) ( PLOT.FIXRIGHTMENU 77095 . 78943) (PLOT.HARDCOPYFN 78945 . 84229) (PLOT.ICONFN 84231 . 88438) ( PLOT.LABELTOWORLD 88440 . 89043) (PLOT.REPAINTFN 89045 . 89309) (PLOT.RESET 89311 . 90787) (PLOT.SETUP 90789 . 91769) (PLOT.SKETCH.CREATE 91771 . 93622) (PLOT.WHENSELECTEDFN 93624 . 94613) ( PLOT.WORLDTOLABEL 94615 . 95219) (PLOTADDMENUITEMS 95221 . 96351) (PLOTADDPROP 96353 . 96863) ( PLOTAXISINTERVAL 96865 . 97993) (PLOTDELMENUITEMS 97995 . 99727) (PLOTDELPROP 99729 . 100191) ( PLOTLABEL 100193 . 101658) (PLOTMENU 101660 . 104063) (PLOTMENUITEMS 104065 . 105688) ( PLOTOBJECTADDPROP 105690 . 106214) (PLOTOBJECTDELPROP 106216 . 106700) (PLOTOBJECTLABEL 106702 . 107667) (PLOTOBJECTPROP 107669 . 111635) (PLOTOBJECTPROPMACRO 111637 . 112240) (PLOTOBJECTSUBTYPE 112242 . 112419) (PLOTOPERROR 112421 . 112616) (PLOTPROMPT 112618 . 112861) (PLOTPROP 112863 . 114619) (PLOTPROPMACRO 114621 . 115975) (PLOTREMPROP 115977 . 117251) (PLOTSCALEFN 117253 . 118469) ( PLOTTICFN 118471 . 119697) (PLOTTICINFO 119699 . 120618) (PLOTTICMETHOD 120620 . 121870) (PLOTTICS 121872 . 123069) (PRINTFONT 123071 . 123484) (PRINTMENU 123486 . 125176) (REDRAWPLOTWINDOW 125178 . 128081) (RELABELSELECTEDPLOTOBJECT 128083 . 129066) (RESCALEPLOT 129068 . 131981) (SCALE 131983 . 135390) (TOGGELLABEL 135392 . 135678) (TOGGLEEXTENDEDAXES 135680 . 137031) (TOGGLEFIXEDMENU 137033 . 137234) (TOGGLETICS 137236 . 137901) (TRANSLATEPLOTOBJECT 137903 . 139181) (UNDELETEPLOTOBJECT 139183 . 142289) (UNLABELPLOTOBJECT 142291 . 142834) (WHICHLABEL 142836 . 143308) (WHICHPLOT 143310 . 143840 )) (143894 151602 (PLOT.PRINTNUM 143904 . 144721) (PLOT.FNUM-STRING 144723 . 147445) (PLOT.ENUM-STRING 147447 . 149256) (CREATETICLISTS 149258 . 150534) (NORMALIZE-TICLIST 150536 . 151600)) (151603 156830 (DRAW-TICS-LEFT-RIGHT 151613 . 153270) (DRAW-TICS-TOP-BOTTOM 153272 . 155068) (DRAW-LABEL-LEFT-RIGHT 155070 . 156238) (DRAW-LABEL-TOP-BOTTOM 156240 . 156828)) (173375 193394 (COPYPLOTOBJECT 173385 . 176643) (COPYPLOT 176645 . 182624) (PLOTOBJECTPRINT 182626 . 182903) (PRINTPLOTOBJECT 182905 . 184809) (PRINTPLOT 184811 . 187281) (READFONT 187283 . 187690) (READMENU 187692 . 189056) (READPLOTOBJECT 189058 . 190803) (READPLOT 190805 . 193392)) (193395 193848 (PRINT-VECTOR 193405 . 193616) ( READ-VECTOR 193618 . 193846)) (194361 196693 (PLOT.EXP10 194371 . 194586) (PLOT.LOG10 194588 . 194837) (PLOT.FLOOR 194839 . 195234) (PLOT.CEILING 195236 . 195639) (SINEWAVE 195641 . 196691)) (196734 207524 (CREATEPLOTIMAGEOBJ 196744 . 197399) (CREATEPLOTBITMAPOBJ 197401 . 197784) ( PLIO.BUTTONEVENTINFN 197786 . 201790) (PLIO.COPYFN 201792 . 202315) (PLIO.GETFN 202317 . 202833) ( PLIO.PUTFN 202835 . 203253) (PLIO.REINSERTOBJ 203255 . 204199) (PLOT.COPYBUTTONEVENTFN 204201 . 205060 ) (PLIO.DISPLAYFN 205062 . 206167) (PLIO.IMAGEBOXFN 206169 . 207522)) (207599 210334 (PLIO.EDITCLOSEFN 207609 . 209318) (IMAGE.OBJECT.CHANGED 209320 . 210332))))) STOP \ No newline at end of file diff --git a/lispusers/PLOT.TEDIT b/lispusers/PLOT.TEDIT new file mode 100644 index 00000000..5221384d --- /dev/null +++ b/lispusers/PLOT.TEDIT @@ -0,0 +1,348 @@ +enˇvĹos PLOT 2 4 1 PLOT 1 4 By: Jan Pedersen (pedersen.PA @ Xerox.com) Uses: TWODGRAPHICS and PLOTOBJECTS PLOT is a module designed to assist in the production of analytic graphics. PLOT provides automatic scaling, labeling, incremental modification, generalized selection, and a collection of standard graphics primitives which may be combined to produce interactive plots of great diversity. PLOT is to some degree object-oriented. The primitive components of a plot are plot objects (e.g. points, lines, etc.). A plot manager maintains a display list of plot objects which are individually responsible for displaying themselves, highlighting themselves, etc. The user constructs a plot incrementally, adding plot objects, while the plot manager handles details such as the appropriate scale for the plot. Each plot object is active, in the sense that it is selectable and may have a menu associated with it. In addition, the plot manager may be directed to modify the appearance of the entire plot through a command menu. The module is open, in the sense that most default behaviors may be overridden by the user, although it is hoped that the defaults will be sufficient for most applications. A functional interface is provided for programmatic access to all of PLOT's facilities. The plot manager is abstracted as a datatype of type PLOT, along with a collection of functions which operate on PLOT's. Functions are provided to create PLOT's, manipulate their display lists, and modify default menus. Plot objects are abstracted as instances of datatype PLOTOBJECT. A set of default plot objects are provided, along with a mechanism of defining new plot objects. Plots exist independently of their representation on the screen. Indeed, it is intended that plots may be displayed on ANY imagestream. However, the most common usage is to display a plot in a window, and a PLOT does have an associated WINDOW which may be opened, closed, etc. Plots may be hard copied, made into image objects, and dumped to file. The lispuser`s module PLOTEXAMPLES contains a few examples of how PLOT may be used to create high level plotting facilities. BASIC OPERATION A plot is abstracted as an instance of datatype PLOT which includes a display list, a property list, and an associated window, among other things. PLOT's may be create via the function CREATEPLOT. (CREATEPLOT openflg region title border) [Function] Returns a PLOT. If openflg is T then the PLOT's associated window is opened with an empty plot. The other arguments are treated as in CREATEW. An empty plot is initialized to have a world coordinate system extending from 0.0 to 1.0 on either axis, with no labels or tic marks displayed. As objects are added to the plot, the world coordinate system is grown to accommodate the new objects. A PLOT has an associated window, which is closed by default. The window is used as the primary display device and may be manipulated with the following functions. (OPENPLOTWINDOW plot) [Function] Opens the plot's associated window. Returns the associated window. (CLOSEPLOTWINDOW plot) [Function] Closes the plot's associated window. (REDRAWPLOTWINDOW plot) [Function] Redraws, by running down the current display list, the contents of the associated window. Opens the window if it is closed. (GETPLOTWINDOW plot) [Function] Returns the window associated with plot. (WHICHPLOT x y) [Function] Returns the PLOT associated with the window (or icon) at position (x . y), or at the current cursor position if x and y are defaulted. x may be a WINDOW, in which case the associated PLOT is returned. A plot object is abstracted as an instance of datatype PLOTOBJECT. A point plot object is an instance of PLOTOBJECT whose data component describes a point. That is, a point plot object is a subtype of PLOTOBJECT; all plot objects satisfy (type? PLOTOBJECT FOO), but only a point plot object satisfies in addition (PLOTOBJECTSUBTYPE? POINT FOO). A collect of standard plot objects has been implemented, including point, curve, polygon, line, and filled rectangle plot objects. The module is designed so that new objects may defined at any time, but that mechanism is described in a separate document. PLOTOBJECT's may be added to or deleted from a PLOT. The following functions provide an add facility for the standard objects. (PLOTPOINT plot position label symbol menu nodrawflg) [Function] Only the plot and position arguments are required. Position is a POSITION in world coordinates. Label is an expression which will be PRIN1 'ed whenever a label is required (typically an atom or a string). Symbol is a BITMAP which will be plotted centered at position. The litatoms CROSS, CIRCLE, STAR are bound to convenient BITMAPS. Symbol defaults to STAR. Menu is either a MENU, a litatom, in which case a MENU of that name must be cached on plot (more about this later), or an item list which may be coerced into a MENU. If nodrawflg is non-NIL then a point object will be added to the display list of plot, but the associated window will not be updated. If Nodrawflg is NIL, and the plot's associated window is not open, it will be opened. Returns a POINT PLOTOBJECT. (PLOTPOINTS plot positions labels symbol menu nodrawflg) [Function] As above except that positions is a list of POSITIONS and labels may also be a list. Reasonable things happen if positions and labels are of unequal length. Returns a list of POINT PLOTOBJECT's. (PLOTCURVE plot positions label style menu nodrawflg) [Function] The list of POSITION's defines a piecewise linear curve. Style may be an integer which specifies the line width (in pixels) or a list of (linewidth dashing color), any of which may be NIL; defaults to one. For convenience the atoms DOT, DASH and DOTDASH have been bound to a few dashing patterns. Returns a CURVE PLOTOBJECT. (PLOTPOLYGON plot positions label style menu nodrawflg) [Function] As in PLOTCURVE, although a polygon is a closed figure Returns a POLYGON PLOTOBJECT. (PLOTTEXT plot position text label font menu nodrawflg) [Function] Text should be a STRING to be printed at position. Returns a TEXT PLOTOBJECT. (PLOTFILLEDRECTANGLE plot left bottom width height label texture borderwidth menu nodrawflg) [Function] Texture must be TEXTURE. SHADE1, ...., SHADE8 are bound to some convenient textures. Defaults to SHADE3. Returns a FILLEDRECTANGLE PLOTOBJECT. The following two functions add analytic plot objects to the display list of a PLOT. Analytic objects differ from points, curves, etc. by having infinite extents; their appearance on a plot depends on the current world coordinate scale, but adding an analytic object to a plot will not effect the current scale. (PLOTLINE plot slope constant label style menu nodrawflg) [Function] Slope and constant define an analytic line, y = slope * x + constant. If slope is NIL, it is taken to be infinite; i.e. the line is vertical. Returns a LINE PLOTOBJECT. (PLOTGRAPH plot graphfn nsamples label style menu nodrawflg) [Function] Graphfn should be a function of one variable which defines a graph (or the graph of a function) to be drawn on plot. Nsamples is the number of equispaced points along the x-axis of plot at which graphfn is to be sampled when drawn; defaults to 100. Returns a GRAPH PLOTOBJECT. Complex objects may be built up from the preceding primitives by defining a compound plot object, which is simply a collection of other plot objects, including other compound objects. (PLOTCOMPOUND plot component1 ... componentn typename label menu nodrawflg) [NoSpread Function] A compound plot object is specified by listing its components. In addition, a compound plot object may have its own menu and label. The typename field is supplied to allow different compound objects to be differentiated. Drawing a compound object amounts to drawing its components recursively. In general, operations on compound objects are applied recursively. Components 1 through n are plot objects. Typename is required and serves to tag this compound object, and is accessable via the function COMPOUNDSUBTYPE. Label and menu are as in other plot objects. Returns a COMPOUND PLOTOBJECT. All plot objects may be created independently of the previous functions. This is useful if it is desired to create a plot object without entering it on a PLOT's display list. The following functions create and return the standard plot objects. (CREATEPOINT position label symbol menu) [Function] Returns a POINT PLOTOBJECT. (CREATECURVE positions label style menu) [Function] Returns a CURVE PLOTOBJECT. (CREATEPOLYGON positions label style menu) [Function] Returns a POLYGON PLOTOBJECT. (CREATETEXT position text label font menu) [Function] Returns a TEXT PLOTOBJECT. (CREATEFILLEDRECTANGLE left bottom width height label texture style menu) [Function] Returns a FILLEDRECTANGLE PLOTOBJECT. (CREATELINE slope constant label style menu) [Function] Returns a LINE PLOTOBJECT. (CREATGRAPH graphfn nsamples label style menu) [Function] Returns a GRAPH PLOTOBJECT. (CREATECOMPOUND compoundtype components label menu) [Function] Components must be a list of PLOTOBJECT's. Returns a COMPOUND PLOTOBJECT. Each PLOT has a display list which is nothing more than a list of plot objects. The display list may be manipulated directly via the following functions. (ADDPLOTOBJECT plotobject plot nodrawflg) [Function] Interns plotobject on the display list of plot, and updates the associated window. The update is suppressed if nodrawflg is non NIL. One might think of PLOTPOINT as being equivalent to: (ADDPLOTOBJECT (CREATEPOINT position ....) plot nodrawflg) Interns plotobject on the display list of plot, and updates the associated window. The update is suppressed if nodrawflg is non NIL. Returns plotobject. (DELETEPLOTOBJECT plotobject plot nodrawflg nosaveflg) [Function] Deletes plotobject from the display list of plot, and updates the associated window accordingly. The update is suppressed if nodrawflg is T. If nosaveflg is T, then the deleted objected will not be saved for possible later undeletion. Returns plotobject if it was deleted from the display list, else NIL. A PLOT has collection of properties, some of which are maintained by the plot manager, and others which may be used to cache arbitrary user data. All plot properties are accessed via the function PLOTPROP. (PLOTPROP plot prop newvalue) [NoSpread Function] If newvalue is absent then the current value of prop is returned. If newvalue is supplied (even if it is NIL) then the value of prop is set and the old value returned. The distinguished prop's PLOTOBJECTS, PLOTSCALE, SELECTEDOBJECT, PLOTWINDOW, PLOTWINDOWVIEWPORT, PLOTPROMPTWINDOW, and PLOTSAVELIST refer system maintained properties plot, and should be treated as read only. Compiles open in some cases. For example, The display list of plot may be accessed by the expression. (PLOTPROP plot 'PLOTOBJECTS) For convenience in manipulating the property list of a PLOT, the following functions are provided. (PLOTADDPROP plot prop itemtoadd firstflg) [Function] If the value of prop is a list then itemtoadd is added to the end of the list. If the value of prop is NIL, it is set to (LIST itemtoadd). Firstflg indicates that the new item is to be the first in the list rather than the last. Works only for user defined properties. Returns the new value. (PLOTDELPROP plot prop itemtodelete) [Function] If itemtodelete is a member (MEMB) of the prop value, it is deleted. Works only for user defined properties. Returns NIL if nothing was deleted, else the new value of prop. (PLOTREMPROP plot prop) [Function] Destructively removes prop from property list of plot. Works only for user defined properties. Each plot object also has a property list. As with PLOT's, some of the properties are maintained by the system, but the rest may be used to store arbitrary data objects. The property list of a plot object is accessed through the function PLOTOBJECTPROP. (PLOTOBJECTPROP object prop newvalue) [NoSpread Function] As in PLOTPROP. The distinguished props are OBJECTMENU, OBJECTLABEL, and OBJECTDATA. The property, OBJECTMENU, may be set as well as read; if the newvalue is a list of items, it will be coerced into a menu. (PLOTOBJECTADDPROP object prop itemtoadd firstflg) [Function] As in PLOTADDPROP. Firstflg indicates that the new item is to be the first in the list rather than the last. (PLOTOBJECTDELPROP object prop itemtodelete) [Function] As in PLOTDELPROP. DEFAULT MOUSE BUTTON ACTIONS The user may interact with a plot through its associated window. A plot provides two default menu's, the RIGHT menu, which pops up if the right mouse button is depressed within a plot's window, and typically contains items relevant to the plot as a whole, and the MIDDLE menu, which pops up if the middle mouse button is depressed, and typically contains items relevant to the currently selected plot object. The left mouse button is used exclusively for selection. The right menu may optionally be fixed to the right hand side of the plot window for easy reference. In summary: Left Button While depressed will select the closest plot object. Middle Button Pops up a menu of default actions on the selected object Right Button Pops up a menu of default actions on the plot as a whole DEFAULT MIDDLE MENU ITEMS Label Label the selected object. Either a default location for the label is selected (for point plot objects), or the user is queried for a location. Unlabel If the object is label, remove the label. Relabel Change the object's label Delete Remove the object from the plot. May be undeleted later. DEFAULT RIGHT MENU ITEMS Layout Create a SKETCH of the contents of the PLOT. Requires SKETCH and SKETCHSTREAM to be loaded. Redraw Redraw the plot Rescale Compute a new scale for both the X and the Y axis based on the objects currently displayed. May also rescale the X or Y axis separately. Extend Extend the axes slightly on either side so plot objects occuring on the borders may become visible. May be applied separately to either axis. Labels Change the marginal labels. May either Choose a margin explicitly, or respond to query. Tics Enable or disable marginal tics. Undelete Restore the last plot object deleted. Subsidiary items allow selected objects to be restored. Deselect Deselects the current selected object. The default menus may be altered or superceded altogether. Each plot object may either use the default middle menu, another cached menu, or provide its own individual menu. Menus are described by item lists of the form (label function helpstring [(subitems ....)]). Function may be a litatom in which case the function is called with one argument, plot, for right menu items,or two arguments, plotobject and plot, for all other menus. If function is a list the CAR of the list is a APPLIED to (CONS PLOTOBJECT (CONS PLOT (CDR list))), etc. The following functions facilitate modifying existing menus, and creating new menus. (PLOTMENU plot menuname newmenu) [NoSpread Function] Plot and menuname are required. If newmenu is not present, then the current value of menu menuname is returned. Menuname may be RIGHT or MIDDLE, in which case the default menus are referred to, or any LITATOM, in which case the cached menu by that name is referred to. Menus other than RIGHT or MIDDLE will typically be specialized menus for particular plot objects. If present, newmenu must be a MENU. (PLOTMENUITEMS plot menuname menuitems) [NoSpread Function] Plot and menuname are required. If menuitems is not present, then the current item list for the MENU menuname is returned. If menuitems is present, then menu menuname is replaced with a new menu with items list menuitems. All the properties (if any) of the old menu are copied over. Menuname may be one of RIGHT or MIDDLE, in which case the operations refer to the default right or middle mouse button menus or any other LITATOM, in which case the operations refer to a menu cached on plot by that name. Menus other than RIGHT or MIDDLE will typically be specialized menus for particular plot objects. (PLOTADDMENUITEMS plot menuname itemstoadd) [Function] Itemstoadd must be a list of menu items. Adds each item in itemstoadd to the end of the item list for menu menuname and replaces menu menuname with a new MENU having the appropriate item list. Returns the the new item list for menuname. (PLOTDELMENUITEM plot menuname itemstodelete) [Function] Itemstodelete must be a list of items. For each element of itemstodelete, if it is a LITATOM, then deletes the item whose CAR is EQ to it. If it is a LISTP, then deletes the item EQUAL to it. Replaces menu menuname with a new MENU having the appropriate item list. Returns NIL if no items were deleted, else the new item list. (PLOT.FIXRIGHTMENU plot fixedflg) [NoSpread Function] Fixedflg is optional. If not present that the current state of the right menu of plot is returned; T implies the right menu is fixed. If Fixedflg is supplied the right menu state is correspondingly changed. The middle button menu for a particular plot object is a property of that plot object, and may be accessed via the function PLOTOBJECTPROP. For example, the expression, (PLOTOBJECTPROP object 'OBJECTMENU) will return the current middle button menu for object. If the OBJECTMENU property is NIL, then the system default MIDDLE menu is used, if it is a LITATOM, than a specialized cached menu by that name is used, finally, if it is a MENU, then that menu is used. Two default fonts are provided, a large font for labels and a small font for tic marks. Both may be reset and that aspect of a plot will change accordingly with the next redraw. LARGEPLOTFONT [Variable] Default value: (Gacha 12 BRR) SMALLPLOTFONT [Variable] Default value: (Gacha 8 MRR) Detailed Operation Most visible aspects of a PLOT may be changed programmatically. The following functions allow the user to specify labels, etc., as well as override the default algorithms for drawing tics, etc. (PLOTLABEL plot margin newlabel nodrawflg) [NoSpread Function] Plot and position are required. Margin must be one of TOP, BOTTOM, LEFT, OR RIGHT. If newlabel is absent, then the current margin label is returned (may be NIL). If newlabel is present then the margin label is set to newlabel. The display is automatically updated unless nodrawflg is non NIL. (PLOTTICS plot margin newvalue nodrawflg) [NoSpread Function] Plot and margin are required. Margin must be one of TOP, BOTTOM, LEFT, OR RIGHT. If newvalue is absent, returns the tic status of that margin. NIL implies no tics or labels, T implies both. If newvalue is present, then sets margin's tic status. The display is automatically updated unless nodrawflg is non NIL. The appearance of the tic marks will also depend on the tic generation method employed. The default is simply to make down tics at "pretty" intervals from the max to the min of each axis in world coordinates. However, non-numeric tic marks, and other behaviors are user specifiable by the function PLOTTICMETHOD. (PLOTTICMETHOD plot margin newmethod nodrawflg) [NoSpread Function] Plot and margin are required. Margin must be one of TOP, BOTTOM, LEFT, OR RIGHT.If newmethod is absent, returns the current tic method for margin margin. Newmethod may be one of NIL, implying the default tic method, a list of CONS pairs ( value . label ), in which case label (if non-NIL) will be printed at value, or a list of numbers, which is equivalent to ((value . value) ...) or a function which will be called with args, margin plotscale plot, and should return a list as above. Plotscale is a datatype which descibes the current scale of the plot. (DEFAULTTICMETHOD margin plotscale plot) [Function] The result depends on the ticinfo field of plotscale, which should be an instance of the PLOTSCALE datatype. The ticinfo field will be an instance of datatype TICINFO. If its ticinc field is a number (the usual case) then it returns a list of numbers, starting at ticmin and ending at ticmax in increments of ticinc, otherwise returns ticinc (should be a list). When a plot object is added to a plot, the scale of the plot is adjusted so that the object is visible. This is accomplished by comparing the extent (in world coordinates) of the object with the current scale of the plot. If the scale needs to be enlarged, a new interval is chosen for each axis which is guaranteed to include the object and also be some multiple of a "round" increment -- in other words, a pretty tic interval. The default behavior of this scaling algorithm may be altered in several ways. The pretty tic interval is determined by the TICFN for each axis. The default uses the function SCALE to find a suitable interval. This may be altered by supplying a TICFN other than the default. Given a pretty tic interval, the default is to simply use the end points of that interval as the endpoints of the scale for each axis. This may be altered by supplying a SCALEFN other than the default. In other words the actually displayed interval (for each axis) in world coordinates (what I will call the plot interval) is separated from the pretty tic interval (for each axis). The pretty tic interval is computed first, then the plot interval is computed in the presence of that information. This separation is useful if the user wishes to plot objects in a coordinate system different from the one used to display tic marks. The current state of each axis of a PLOT is cached in the plot property plotscale, whose value is an instance of datatype PLOTSCALE. A PLOTSCALE has three fields for each axis, one which contains an instance of AXISINTERVAL, describing the actual plot interval for that axis, another which contains an instance of TICINFO, which describes the pretty tic interval for that axis, and a third which is a simply a place to cache a user supplied TICFN and SCALEFN. (PLOTTICFN plot axis ticfn nodrawflg) [NoSpread Function] Ticfn is optional. If not present the current ticfn for the indicated axis is returned. If supplied, the state of that axis is correspondingly updated. A ticfn is called with args min, max, and plot and should return an instance of TICINFO. If the state of plot is changed, the appropriate axis is rescaled. A value of NIL implies the default ticfn. (DEFAULTTICFN min max -- -- --) [Function] The default ticfn for each axis. Uses the function SCALE to find a suitable pretty tic interval. (PLOTSCALEFN plot axis scalefn nodrawflg) [NoSpread Function] Scalefn is optional. If not present the current scalefn for that axis of plot is returned. If supplied, the state of that axis is updated. A scalefn is called with four arguments, the min and max extent (in world coordinates) on that axis of the plotobjects currently displayed, the TICINFO for that axis, and the plot; the scalefn should return an AXISINTERVAL which will determine the scale for that axis of plot. A value of NIL implies the default scalefn. (DEFAULTSCALEFN min max ticinfo) [Function] The default scalefn for each axis. Returns an AXISINTERVAL with endpoints identical to the endpoints of ticinfo. (ADJUSTSCALE? extent plot) [Function] Determines whether extent will fit into the current viewing area of plot. If so, returns NIL. If not, returns T and updates the plotscale of plot. (EXTENTOFPLOT plot) [Function] Computes the current extent of plot by mapping EXTENTOBJECT down the display list. Returns an EXTENT. To be precise, the scaling algorithm operates as follows; a min and max extent of the data is computed (via EXTENTOFPLOT or entered manually in the case manual rescaling), then CHOOSETICS is called, which returns an instance of TICINFO. CHOOSETICS either uses a default TICFN, or one supplied by the user, The default TICFN, calls SCALE repeatedly to find an "optimal" tic interval in world coordinates. Once the TICINFO instance has been computed, CHOOSESCALE is called with the original min, max and the TICINFO, and returns an instance of AXISINTERVAL, which will determine the actually displayed plot interval. Again, CHOOSESCALE either uses a default SCALEFN, or one supplied by the user. The default SCALEFN simply uses the end points of the passed in pretty tic interval as the end points of the AXISINTERVAL which it returns. Finally, the PLOT is redrawn with the new scale -- notice that the plot interval may either be larger or smaller than the pretty tic interval; the margin drawing routines are robust enough to deal with all cases. For example, suppose the world coordinates are in centigrade and it is desired to produce a pretty tic interval in units of Fahrenheit (this is an easy case since the transformation between scales is linear -- more about that later). The user would then supply a TICFN which would transform the incoming min and max to Fahrenheit , apply the default TICFN on the transformed min and max, obtain a TICINFO in Fahrenheit, transform the fields of that record back to Centigrade, and return that record. Note, it is always assumed that the fields of a returned TICINFO are in the units of the world coordinate system. The rest of the machinery would then go through as before. A tricker example is one in which it is desired to produce unequispaced tic marks. Suppose the data were plotted on a log scale (that is, log was applied BEFORE plotting the data).The default algorithm would produce a pretty tic interval in the log scale. It might be desired instead to produce one pretty in the original scale. The user would then supply a TICFN which would exponentiate the incoming min and max, apply the default TICFN on the transformed min and max, obtain a TICINFO in the original scale, then return a TICINFO in the logscale. Note; since equispaced tic marks in the orginal scale are not equispaced in the log scale, the TICINC field of the returned TICINFO would be a list of the unequispaced tic marks values, rather than a number. The plot scale of each axis may be manipulated directly through the following functions. (PLOTAXISINTERVAL plot axis newinterval nodrawflg) [Function] Plot and axis are required. Axis must be one of X, or Y. If newinterval is NIL , returns the current AXISINTERVAL for that axis. If newinterval is non-NIL it must be an AXISINTERVAL. (PLOTTICINFO plot axis newticinfo nodrawflg) [Function] Plot and axis are required. Axis must be one of X, or Y. If newticinfo is NIL , returns the current TICINFO for that axis. If newticinfo is non-NIL it must be a TICINFO. On occasion it is useful to clean out an existing plot instead of creating a new one. (PLOT.RESET plot xscale yscale flushmargins flushprops nodrawflg) [Function] Returns plot to a pristine state. If xscale and yscale are provided, the scale of the plot is set accordingly. Finer control over the behavior of plot objects is possible through the following functions. (TRANSLATEPLOTOBJECT plotobject dx dy plot nodrawflg) [Function] Moves plotobject dx, dy in world coordinates and updates the associated window accordingly. The update is suppressed if nodrawflg is non NIL. (DRAWPLOTOBJECT plotobject plot) [Function] Draw plotobject in the window asssociated with plot. As with all the display functions, the window should be opened beforehand. DRAWOBJECT does NOT check that the window is open. APPLY's the plotobject's DRAWFN. (ERASEPLOTOBJECT plotobject plot) [Function] APPLY's the plotobject's ERASEFN (HIGHLIGHTPLOTOBJECT plotobject plot) [Function] Invoked when a plotobject is selected (LOWLIGHTPLOTOBJECT plotobject plot) [Function] Invoked when a plotobject is deselected (EXTENTOFPLOTOBJECT plotobject plot) [Function] Computes the extent of plotobject in world coordinates. Returns an EXTENT, which has fields MAXX, MINX, etc. (DISTANCETOPLOTOBJECT plotobject streamposition plot) [Function] Returns the "distance" to plotobject from streamposition in stream coordinates. Value returned may be a FIXP or a FLOATP, but is always a distance in stream coordinates. (CLOSESTPLOTOBJECT plot streamposition) [Function] Returns the "closest" plotobject on plot's display list to streamposition. (DESELECTPLOTOBJECT plot) [Function] Deselects the current selected object of plot Plot objects also have "afterfns". That is, functions which are optionally invoked after some standard operation. These are stored as plot object properties with distinguished names, and invoked with at least two args, the plotobject and the plot. WHENADDEDFN [Property] The WHENADDEDFN is called with three arguments, plotobject, plot, and nodrawflg WHENDELETEDFN [Property] The WHENDELETEDFN is called with four arguments, plotobject, plot, nodrawflg, and nosaveflg. WHENDRAWNFN [Property] The WHENDRAWNFN is called with three arguments, plotobject, viewport and plot. WHENERASEDFN [Property] WHENHIGHLIGHTEDFN [Property] WHENLOWLIGHTEDFN [Property] WHENTRANSLATEDFN [Property] A PLOT has two associated windows, the mainwindow in which the graphics, labels, tics, etc. are displayed and an attached promptwindow. The mainwindow is cached as plot property and may be accessed via the function PLOTPROP. A function is provided for easy access to the prompt window. (PLOTPROMPT text plot) [Function] Text is output in the one character high prompt window of plot. PLOT's may be drawn in ANY imagestream (but only interacted with in the PLOT's associated window). The following function is the fundamental draw primitive. (DRAWPLOT plot stream streamviewport streamregion) [Function] Stream is any imagestream. Streamviewport is a viewport on that stream that defines the the world to stream transformation. Streamregion is a region in stream coordinates that will contain the entire image (for a window it will be the CLIPPINGREGION). Streamviewport is usually the result of ADJUSTVIEWPORT. For more information about viewport, consult the documentation for the TWODGRAPHICS module. (ADJUSTVIEWPORT viewport streamregion plot) [Function] Viewport is a VIEWPORT whose parentstream is the imagestream of interest. Streamregion is a region in stream coordinates that will contain the entire image. Adjusts the Streamsubregion and Worldregion of viewport to reflect the current scale and margin setting of plot. (MINSTREAMREGIONSIZE stream plot) [Function] Returns a CONS pair (minwidth . minheight) of the plot in stream coordinates. A plot has "afterfns" for two major operations, opening and closing the plotwindow. These are stored as plot properties with distinguished names. The values of these properties may be a single function or a list of functions which are called in sequence with the plot as an argument. WHENOPENEDFN [Property] WHENCLOSEDFN [Property] PLOT's may be copied, made into image objects, dumped onto files, sent in the mail, etc. (COPYPLOT plot) [Function] Returns a copy of plot. The user defined properties require special handling. If there exists a plot prop COPYFN, which may be function or list of functions, the function (or functions) will be invoked with the arguments newplot plot and propname for each user defined property on plot. If the function returns a non-NIL value, it will be used as the value of propname on newplot. In the case of a list of functions, the first non-NIL value (traveling from the head to the tail of the list of functions) will be used as the new prop value. Otherwise the prop will be HCOPYALL'ed. (COPYPLOTOBJECT plotobject plot) [Function] Returns a copy of plotobject. The protocol for copying objectprops is similar to plot props. The plotobject may have a COPYFN prop which may be a function or list of functions. The function (or functions) will be invoked with the arguments newplotobject plotobject plot propname. The first non-NIL value will be used as the prop value else the property will be HCOPYALL'ed. (PRINTPLOT plot stream) [Function] Writes out an HREADable symbolic representation of plot on stream. Again, user defined properties require special handling. If there exists a plot prop PUTFN, which may be function or list of functions, the function (or functions) will be invoked with the arguments plot propname and stream for each user defined property on plot. If the function returns a non-NIL value, it is assumed an HREADable representation of the prop value has been written out on stream. In the case of a list of functions, the functions will invoked one at time, starting from the head of the list, until a non-NIL result is obtained. If there is no PUTFN, or the function (or none of the functions) returns a non-NIL value, the prop is HPRINT'ed. Lists of the form ((FUNCTION function) arg) are recognized by the inverse of PRINTPLOT, READPLOT, to imply that function should be called with plot and arg as arguments at HREAD time, and the value returned to be the prop value. (PRINTPLOTOBJECT plotobject plot stream) [Function] Writes out an HREADable symbolic representation of plotobject on stream. As in PRINTPLOT user defined object properties require special handling. The protocol is the same as in PRINTPLOT. The following data types have HPRINT macros and need no special handling: FONTDESCRIPTOR, MENU, PLOT, and PLOTOBJECT. A file package command has been defined to simplyfy dumping PLOT's on files. (PLOTS . plots) [FilePkgCom] The syntax is identical to VARS. A plot image object is fully supported. (CREATEPLOTIMAGEOBJ plot) [Function] Returns an image object which contains a copy of plot. These image objects can also be created by copy-selecting from a plot window into a host window (e.g. TEdit or Sketch) that supports image objects. Such a selection will ask whether the plot should be inserted as a bitmap or a plot, the latter case constructing a plot image object. Buttoning on the image object provides the option of reshaping the plot or creating a separate plot window in which the plot can be modified. Closing the plot window will ask whether the new plot should be reinserted in the host. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 174) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 42 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) -ČT-ČT3ČČT,Č2ČČ,Č,Č ,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD CLASSICCLASSICCLASSICMODERN +MODERN +€TERMINAL +MODERN +MODERN MODERNMODERN + +TIMESROMAN +   +  HRULE.GETFNMODERN + + + HRULE.GETFNMODERN + + + HRULE.GETFNMODERN + +   HRULE.GETFNMODERN  + HRULE.GETFNMODERN , +" +  +w + +~ + +G +} +Ĺ + + + +ř +Ł + + +$ + + + +% + + +| + + +) + + +É +Y + + +) + +Ü + + ++ + +& + +) +) + + +) +7 + + + +, +3 + + +€ +i +& +8 + + +. +Ž + + +0 +ů + +¸ + +i +j +Ç + +ô + + + + + + + + + + + + + +1 +& + + + + +! + + +" ++ + +› + + +… +5 +>… + + +# +ë +F +Î + + + +– +I + +c + + + + + + +m +@ + +  +_ +ţ + + +Đ + + +m + + + + +E + 5 +9 + 9 + + +* + +9 + +] + +‰ + +X +! + ] + ' +­ +@ +( +U + + + +“ + + +Z + + +Á +, + + + + +> + +  +Ď +Š +# + +˛ + + + + + + + + +% + + + +7 +9 + + +. + + +j +ý +Ä +Ę +­ +Í + + +^ + + +a + + +Î + + +# +N + +  +“ + + +f + +Ą +ö +Z + + +ˇ + + +Ş +V + +4 +p +^ + + +Ž + + +´ +" + + +! + + +& + + +( + + +8 +5 + + +Ş + + +K + + +. +ř + +Q + +_ + +O + + + + + + +  +@ +ž + +' +4 +G +  + + +ž +q + +  +N + + + +Y + + + +D + + +v + +  +Ő +ć + + +ź +v +M + + +! +) + + +; +„‹Ęzş \ No newline at end of file diff --git a/lispusers/PLOTANDNC-PATCH b/lispusers/PLOTANDNC-PATCH new file mode 100644 index 00000000..58762322 --- /dev/null +++ b/lispusers/PLOTANDNC-PATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "22-Jan-88 15:45:26" {indigo}lyric>library>plotandnc-patch.\;1 1853 |changes| |to:| (vars plotandnc-patchcoms) (fns read.fontintodescriptor)) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint plotandnc-patchcoms) (rpaqq plotandnc-patchcoms ( (* |;;| "define font read fns used by plot and notecards so system can read either kind") (fns readfont read.fontintodescriptor) (p (* |;;| "make sure these read fns are registered to avoid messages when reading") (pushnew hprintreadfns 'readfont) (pushnew hprintreadfns 'read.fontintodescriptor)))) (* |;;| "define font read fns used by plot and notecards so system can read either kind") (defineq (readfont (lambda (stream) (* |jop:| "27-Aug-85 13:34") (prog ((proplist (read stream))) (return (fontcreate (listget proplist 'family) (listget proplist 'size) (listget proplist 'face) (listget proplist 'rotation) (listget proplist 'device)))))) (read.fontintodescriptor (lambda (stream) (* \; "Edited 22-Jan-88 15:36 by thh:") (apply 'fontcreate (read stream)))) ) (* |;;| "make sure these read fns are registered to avoid messages when reading") (pushnew hprintreadfns 'readfont) (pushnew hprintreadfns 'read.fontintodescriptor) (putprops plotandnc-patch copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil (967 1575 (readfont 977 . 1393) (read.fontintodescriptor 1395 . 1573))))) stop \ No newline at end of file diff --git a/lispusers/PLOTBOXPATCH b/lispusers/PLOTBOXPATCH new file mode 100644 index 00000000..7177ea93 --- /dev/null +++ b/lispusers/PLOTBOXPATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated " 4-Oct-88 10:13:44" {ivy}lisp>plotboxpatch.\;1 2342 ) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint plotboxpatchcoms) (rpaqq plotboxpatchcoms ((fns boxregion drawplot))) (defineq (boxregion (lambda (region stream noleft noright notop nobottom) (* \; "Edited 4-Oct-88 10:04 by thh:") (* |;;| "Draw a box around a region in STREAM, omitting specified sides") (prog ((rleft (|fetch| left |of| region)) (rbottom (|fetch| bottom |of| region)) (rright (|fetch| right |of| region)) (rtop (|fetch| top |of| region)) (linewidth (dspscale nil stream))) (or nobottom (drawline rleft rbottom rright rbottom linewidth 'replace stream)) (or noright (drawline rright rbottom rright rtop linewidth 'replace stream)) (or notop (drawline rright rtop rleft rtop linewidth 'replace stream)) (or noleft (drawline rleft rtop rleft rbottom linewidth 'replace stream))))) (drawplot (lambda (plot currentstream streamviewport streamregion) (* \; "Edited 4-Oct-88 10:06 by thh:") (* |;;| "Draws a plot on CURRENTSTREAM. STREAMREGION is the region the PLOT will occupy. Does not blank the STREAMREGION before drawing") (cond ((not (|type?| plot plot)) (help "Not a PLOT " plot))) (* \;  "Will not check, for the moment, that the streamregion is large enough") (boxregion (|fetch| streamsubregion |of| streamviewport) currentstream (plotprop plot 'noleft) (plotprop plot 'noright) (plotprop plot 'notop) (plotprop plot 'nobottom)) (|for| margin |in| '(bottom left top right) |do| (drawmargin margin currentstream streamviewport streamregion plot)) (|for| object |in| (|fetch| plotobjects |of| plot) |do| (drawplotobject object streamviewport plot)))) ) (putprops plotboxpatch copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil (298 2258 (boxregion 308 . 1126) (drawplot 1128 . 2256))))) stop \ No newline at end of file diff --git a/lispusers/PLOTBOXPATCH.TEDIT b/lispusers/PLOTBOXPATCH.TEDIT new file mode 100644 index 00000000..5635b14e Binary files /dev/null and b/lispusers/PLOTBOXPATCH.TEDIT differ diff --git a/lispusers/PLOTEXAMPLES b/lispusers/PLOTEXAMPLES new file mode 100644 index 00000000..ff3db4b2 --- /dev/null +++ b/lispusers/PLOTEXAMPLES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 5-May-87 15:24:37" {PHYLUM}LYRIC>PLOTEXAMPLES.;1 37750 changes to%: (FNS HISTO.DRAW HISTPLOT MAKEBININTERVAL SCATPLOT SCAT.LOGSCALE LOGTICFN) previous date%: "18-Jun-86 12:50:08" {PHYLUM}KOTO>PLOTEXAMPLES.;1) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PLOTEXAMPLESCOMS) (RPAQQ PLOTEXAMPLESCOMS ((* * HISTOGRAM FNS) (FNS COMPUTEMULTIPLE HISTO.CHANGEBINS HISTO.COPYFN HISTO.DRAW HISTO.INTSCALEFN HISTO.INTTICFN HISTO.MAKEBINS HISTO.RESET HISTO.TICFN HISTO.VALUES HISTPLOT MAKEBININTERVAL SUMMARYWINDOW.REPAINTFN) (RECORDS BININTERVAL) (* * SCATTERPLOT FNS) (FNS SCATPLOT SCAT.LOGSCALE SCAT.POINTCOORDS SCAT.WORLDCOORD LOGTICFN) (* * Depends on PLOT) (FILES PLOT) (MACROS HISTO.GETFREQ HISTO.GETVALUE) (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T)))) (* * HISTOGRAM FNS) (DEFINEQ (COMPUTEMULTIPLE [LAMBDA (MIN MAX INC MUTIPLE) (* jop%: "25-Feb-86 12:15") (* *) (LET* [(NEWINC (TIMES INC MUTIPLE)) (MINMULT (PLOT.FLOOR (QUOTIENT MIN NEWINC))) (MAXMULT (PLOT.CEILING (QUOTIENT MAX NEWINC] (create TICINFO TICMIN _ (TIMES MINMULT NEWINC) TICMAX _ (TIMES MAXMULT NEWINC) TICINC _ NEWINC NTICS _ (ADD1 (DIFFERENCE MAXMULT MINMULT]) (HISTO.CHANGEBINS [LAMBDA (HISTOGRAM) (* jop%: "27-Feb-86 15:05") (* * Allow the use to specify a range and a bin interval for the histogram) (PROG ((PLOTPROMPTWINDOW (PLOTPROP HISTOGRAM 'PLOTPROMPTWINDOW)) (INTFLG (PLOTPROP HISTOGRAM 'INTFLG)) (BININTERVAL (PLOTPROP HISTOGRAM 'BININTERVAL)) INC START END NBINS) (SETQ INC (fetch (BININTERVAL BININC) of BININTERVAL)) (SETQ START (fetch (BININTERVAL BINMIN) of BININTERVAL)) (SETQ END (fetch (BININTERVAL BINMAX) of BININTERVAL)) (* have a dialogue with the user) (TERPRI PLOTPROMPTWINDOW) [SETQ START (READ (OPENSTRINGSTREAM (PROMPTFORWORD "From " START "Type start point of bin sequence" PLOTPROMPTWINDOW] (SETQ START (if INTFLG then (PLOT.FLOOR START) else (FLOAT START))) [SETQ END (READ (OPENSTRINGSTREAM (PROMPTFORWORD " to " END "Type end point of bin sequence" PLOTPROMPTWINDOW] (SETQ END (if INTFLG then (PLOT.CEILING END) else (FLOAT END))) [SETQ INC (READ (OPENSTRINGSTREAM (PROMPTFORWORD " by " INC "Type an increment" PLOTPROMPTWINDOW] (SETQ INC (if INTFLG then (PLOT.CEILING INC) else (FLOAT INC))) (SETQ NBINS (PLOT.CEILING (FQUOTIENT (DIFFERENCE END START) INC))) (SETQ END (PLUS START (TIMES INC NBINS))) (if INTFLG then (SETQ NBINS (ADD1 NBINS))) (* Inform the user of what will happen) (PLOTPROMPT (CONCAT "Using: from " START " to " END " by " INC) HISTOGRAM) (PLOTPROP HISTOGRAM 'BININTERVAL (create BININTERVAL BINMIN _ START BINMAX _ END BININC _ INC NBINS _ NBINS)) (* redraw the histogram based on the  new parameters) (HISTO.DRAW HISTOGRAM]) (HISTO.COPYFN [LAMBDA (NEWHIST OLDHIST PROPNAME) (* jop%: "24-Feb-86 23:11") (SELECTQ PROPNAME (N (PLOTPROP OLDHIST 'N)) (NBINS (PLOTPROP OLDHIST 'NBINS)) (OBATCH (PLOTPROP OLDHIST 'OBATCH)) (INTFLG (PLOTPROP OLDHIST 'INTFLG)) (BINEDNUMBERS (PLOTPROP OLDHIST 'BINEDNUMBERS)) (MARKS (PLOTPROP OLDHIST 'MARKS)) NIL]) (HISTO.DRAW [LAMBDA (HISTOGRAM) (* edited%: "27-Mar-86 21:56") (* *) (LET* ((SHADE (PLOTPROP HISTOGRAM 'SHADE)) (OBATCH (PLOTPROP HISTOGRAM 'OBATCH)) (INTFLG (PLOTPROP HISTOGRAM 'INTFLG)) (BININTERVAL (OR (PLOTPROP HISTOGRAM 'BININTERVAL) (LET ((NEWINTERVAL (MAKEBININTERVAL (HISTO.GETVALUE (CAR OBATCH)) (HISTO.GETVALUE (CAR (LAST OBATCH))) (PLOTPROP HISTOGRAM 'NBINS) INTFLG))) (PLOTPROP HISTOGRAM 'BININTERVAL NEWINTERVAL) NEWINTERVAL))) (BINMIN (fetch (BININTERVAL BINMIN) of BININTERVAL)) (BINMAX (fetch (BININTERVAL BINMAX) of BININTERVAL)) (BININC (fetch (BININTERVAL BININC) of BININTERVAL)) (NBINS (fetch (BININTERVAL NBINS) of BININTERVAL)) BINS) (* Erase the old image, if any) [for OBJECT in (COPY (PLOTPROP HISTOGRAM 'PLOTOBJECTS)) do (COND ((AND (PLOTOBJECTSUBTYPE? FILLEDRECTANGLE OBJECT) (PLOTOBJECTPROP OBJECT 'FROMHISTOGRAM?)) (DELETEPLOTOBJECT OBJECT HISTOGRAM T T] [COND (INTFLG (SETQ BINMIN (DIFFERENCE BINMIN 0.5)) (SETQ BINMAX (PLUS BINMAX 0.5] (SETQ BINS (bind (NUMBERS _ OBATCH) FREQ for I from 1 to NBINS as MARK from (PLUS BINMIN BININC) by BININC eachtime (SETQ FREQ (bind NUM eachtime (SETQ NUM (CAR NUMBERS)) while (AND NUMBERS (LESSP (HISTO.GETVALUE NUM) MARK)) sum (SETQ NUMBERS (CDR NUMBERS)) (HISTO.GETFREQ NUM))) when (NEQ FREQ 0) collect (CONS MARK FREQ))) (* An optimization to speed up adding rectangles to the plot --  extends the scale once) (ADJUSTSCALE? [create EXTENT MINX _ BINMIN MAXX _ BINMAX MINY _ 0 MAXY _ (CDR (for BIN in BINS largest (CDR BIN] HISTOGRAM) (* Construct the new image) (RESETLST [RESETSAVE (FLTFMT '(FLOAT NIL NIL NIL NIL 5] (* Round to five significant figures) (RESETSAVE PRXFLG T) (bind RECTANGLE LOWMARK HIGHMARK FREQ for BIN in BINS do (SETQ HIGHMARK (CAR BIN)) (SETQ LOWMARK (DIFFERENCE HIGHMARK BININC)) (SETQ FREQ (CDR BIN)) (SETQ RECTANGLE (PLOTFILLEDRECTANGLE HISTOGRAM LOWMARK 0 BININC FREQ (COND [INTFLG (LET ((ILOWMARK (PLOT.CEILING LOWMARK)) (IHIGHMARK (PLOT.FLOOR HIGHMARK))) (COND ((IEQP ILOWMARK IHIGHMARK) (CONCAT FREQ " Obs. at " ILOWMARK)) (T (CONCAT FREQ " Obs. between " ILOWMARK " and " IHIGHMARK] (T (CONCAT FREQ " Obs. between " LOWMARK " and " HIGHMARK))) SHADE NIL 'BINMENU T)) (PLOTOBJECTPROP RECTANGLE 'FROMHISTOGRAM? T) (PLOTOBJECTPROP RECTANGLE 'LOWMARK LOWMARK) (PLOTOBJECTPROP RECTANGLE 'HIGHMARK HIGHMARK))) (* Rescale the Histogram) (RESCALEPLOT HISTOGRAM 'BOTH T) (* refresh the image) (REDRAWPLOTWINDOW HISTOGRAM]) (HISTO.INTSCALEFN [LAMBDA (MIN MAX TICINFO) (* jop%: "24-Feb-86 23:29") (with TICINFO TICINFO (create AXISINTERVAL MIN _ (DIFFERENCE TICMIN 0.5) MAX _ (PLUS TICMAX 0.5]) (HISTO.INTTICFN [LAMBDA (MIN MAX) (* jop%: "12-Feb-86 22:38") (* *) (LET* ((INTMAX (PLOT.FLOOR MAX)) (INTMIN (PLOT.CEILING MIN)) (TICINFO (DEFAULTTICFN INTMIN INTMAX)) NEWMAX NEWMIN INC NTICS) [SETQ NEWMIN (IMIN INTMIN (PLOT.CEILING (fetch (TICINFO TICMIN) of TICINFO] (SETQ INC (PLOT.CEILING (fetch (TICINFO TICINC) of TICINFO))) [SETQ NTICS (ADD1 (PLOT.CEILING (FQUOTIENT (DIFFERENCE INTMAX NEWMIN) INC] [SETQ NEWMAX (IPLUS NEWMIN (ITIMES INC (SUB1 NTICS] (create TICINFO TICMIN _ NEWMIN TICMAX _ NEWMAX TICINC _ INC NTICS _ NTICS]) (HISTO.MAKEBINS [LAMBDA (HISTOGRAM) (* jop%: "24-Feb-86 23:07") (* * Computes a BIN interval and the BINEDNUMBERS based on PLOT props.) (PROG ((OBATCH (PLOTPROP HISTOGRAM 'OBATCH)) (BININTERVAL (PLOTPROP HISTOGRAM 'BININTERVAL)) (INTFLG (PLOTPROP HISTOGRAM 'INTFLG)) NBINS MARKS BINEDNUMBERS) (if (NULL BININTERVAL) then (SETQ BININTERVAL (MAKEBININTERVAL (HISTO.GETVALUE (CAR OBATCH)) (HISTO.GETVALUE (CAR (LAST OBATCH))) (PLOTPROP HISTOGRAM 'NBINS) INTFLG))) (* MARKS is a list of the NBINS plus 1 bin end points) (SETQ NBINS (fetch (BININTERVAL NBINS) of BININTERVAL)) (SETQ MARKS (LET ((BINMIN (fetch (BININTERVAL BINMIN) of BININTERVAL)) (BINMAX (fetch (BININTERVAL BINMAX) of BININTERVAL)) (BININC (fetch (BININTERVAL BININC) of BININTERVAL))) (if INTFLG then (SETQ BINMIN (DIFFERENCE BINMIN 0.5)) (SETQ BINMAX (PLUS BINMAX 0.5))) (NCONC1 (for I from 1 to NBINS as MARK from BINMIN by BININC collect MARK) BINMAX))) (* BINEDNUMBERS is a list of numbers, one for each bin, so that each entry is  the number of elements of BATCH that fall in that bin) [SETQ BINEDNUMBERS (bind (NUMBERS _ OBATCH) for MARK in (CDR MARKS) collect (bind NUM eachtime (SETQ NUM (CAR NUMBERS)) while (AND NUMBERS (LESSP (HISTO.GETVALUE NUM) MARK)) sum (SETQ NUMBERS (CDR NUMBERS)) (HISTO.GETFREQ NUM] (PLOTPROP HISTOGRAM 'BININTERVAL BININTERVAL) (PLOTPROP HISTOGRAM 'BINEDNUMBERS BINEDNUMBERS) (PLOTPROP HISTOGRAM 'MARKS MARKS]) (HISTO.RESET [LAMBDA (HISTOGRAM) (* jop%: "27-Feb-86 15:06") (* * Resets the range and bin interval to their original values) (PLOTPROP HISTOGRAM 'BININTERVAL NIL) (HISTO.DRAW HISTOGRAM]) (HISTO.TICFN [LAMBDA (MIN MAX HISTOGRAM) (* jop%: "25-Feb-86 12:43") (* *) (LET* ((RANGE (DIFFERENCE MAX MIN)) (BININTERVAL (PLOTPROP HISTOGRAM 'BININTERVAL)) (BININC (fetch (BININTERVAL BININC) of BININTERVAL)) (NBINS (fetch (BININTERVAL NBINS) of BININTERVAL))) (bind (MININTERVALLENGTH _ MAX.FLOAT) MININTERVAL INTERVAL INTERVALLENGTH for MULTIPLE from (PLOT.CEILING (QUOTIENT RANGE (TIMES BININC 9))) to (PLOT.CEILING (QUOTIENT RANGE BININC)) do (SETQ INTERVAL (COMPUTEMULTIPLE MIN MAX BININC MULTIPLE)) (SETQ INTERVALLENGTH (fetch (TICINFO TICINTERVALLENGTH ) of INTERVAL)) (if (LESSP INTERVALLENGTH MININTERVALLENGTH ) then (SETQ MININTERVAL INTERVAL) (SETQ MININTERVALLENGTH INTERVALLENGTH)) finally (RETURN MININTERVAL]) (HISTO.VALUES [LAMBDA (RECTANGLE HISTOGRAM) (* jop%: "24-Feb-86 23:25") (PROG [(SUMMARYWINDOW (WINDOWPROP (PLOTPROP HISTOGRAM 'PLOTWINDOW) 'SUMMARYWINDOW)) (LOWMARK (PLOTOBJECTPROP RECTANGLE 'LOWMARK)) (HIGHMARK (PLOTOBJECTPROP RECTANGLE 'HIGHMARK)) (OBATCH (PLOTPROP HISTOGRAM 'OBATCH] (COND ((NULL SUMMARYWINDOW) (* Make a window five chars high) (SETQ SUMMARYWINDOW (CREATEW (CREATEREGION 0 0 100 (HEIGHTIFWINDOW (ITIMES 5 (FONTPROP (DEFAULTFONT 'DISPLAY) 'HEIGHT)) T)) "SUMMARY WINDOW" NIL T)) (* Supply a simple repaintfn) (WINDOWADDPROP SUMMARYWINDOW 'REPAINTFN (FUNCTION SUMMARYWINDOW.REPAINTFN)) (WINDOWADDPROP SUMMARYWINDOW 'RESHAPEFN (FUNCTION SUMMARYWINDOW.REPAINTFN)) (WINDOWPROP (PLOTPROP HISTOGRAM 'PLOTWINDOW) 'SUMMARYWINDOW SUMMARYWINDOW))) (* cache the output as a window prop) (WINDOWPROP SUMMARYWINDOW 'OUTPUT (bind NUM for ITEM in OBATCH eachtime (SETQ NUM (HISTO.GETVALUE ITEM)) when (AND (GEQ NUM LOWMARK) (LESSP NUM HIGHMARK)) collect ITEM)) (* If the window is not yet attached, then attach it) (COND ((NOT (OPENWP SUMMARYWINDOW)) (ATTACHWINDOW SUMMARYWINDOW (fetch PLOTWINDOW of HISTOGRAM) 'TOP NIL 'LOCALCLOSE)) (T (SUMMARYWINDOW.REPAINTFN SUMMARYWINDOW]) (HISTPLOT [LAMBDA (BATCH LABEL SHADE) (* jop%: "27-Feb-86 22:55") (* * Batch is assumed to be a list of numbers or a list of pairs  (number . frequency) Label, a label to be associated with those numbers) (PROG ((HISTOGRAM (CREATEPLOT)) (BINMENU (LIST (LIST 'Values (FUNCTION HISTO.VALUES) "Output values in bin"))) [RIGHTMENUITEMS (LIST (LIST 'Change% bins (FUNCTION HISTO.CHANGEBINS) "Change number of bins" (LIST 'SUBITEMS (LIST 'RESET (FUNCTION HISTO.RESET) "Reset range and bin interval to original value" ] (LEFTLABEL "Frequency") (BOTTOMLABEL (OR LABEL "Values")) (N (for ITEM in BATCH sum (HISTO.GETFREQ ITEM))) (TOPLABEL (COND (LABEL (CONCAT "Histogram of " LABEL)) (T "Histogram"))) OBATCH INTFLG NBINS) (* * BINMENU is aspecial menu for the rectangle of the histogram.  RIGHTMENUITEMS are additional right menu items.) [SETQ OBATCH (SORT (COPY BATCH) (FUNCTION (LAMBDA (X Y) (LESSP (HISTO.GETVALUE X) (HISTO.GETVALUE Y] (* Order the data) [SETQ INTFLG (for X in OBATCH always (FIXP (HISTO.GETVALUE X] (* check if data are all integers) [SETQ NBINS (COND [INTFLG (ADD1 (DIFFERENCE (HISTO.GETVALUE (CAR (LAST OBATCH))) (HISTO.GETVALUE (CAR OBATCH] (T (COND [(LESSP N 20) (FIX (TIMES 2 (SQRT N] (T (FIX (TIMES 10 (PLOT.LOG10 N] (* Default number of bins set by an  heuristic) (* Set up a few key PLOT PROP'S) (PLOTPROP HISTOGRAM 'N N) (PLOTPROP HISTOGRAM 'NBINS NBINS) (PLOTPROP HISTOGRAM 'OBATCH OBATCH) (PLOTPROP HISTOGRAM 'INTFLG INTFLG) (PLOTPROP HISTOGRAM 'SHADE (OR SHADE SHADE3)) (* Function to copy the plot props) (PLOTPROP HISTOGRAM 'COPYFN (FUNCTION HISTO.COPYFN)) (* Initialize the histogram so that labels and tics are displayed) (PLOTTICS HISTOGRAM 'BOTTOM T T) (PLOTTICS HISTOGRAM 'LEFT T T) (PLOTLABEL HISTOGRAM 'BOTTOM BOTTOMLABEL T) (PLOTLABEL HISTOGRAM 'LEFT LEFTLABEL T) (PLOTLABEL HISTOGRAM 'TOP TOPLABEL T) (* add items to the right menu) (PLOTADDMENUITEMS HISTOGRAM 'RIGHT RIGHTMENUITEMS) (* Establish a special "bin" menu) (PLOTMENUITEMS HISTOGRAM 'BINMENU BINMENU) [COND (INTFLG (PLOTTICFN HISTOGRAM 'X (FUNCTION HISTO.INTTICFN)) (PLOTSCALEFN HISTOGRAM 'X (FUNCTION HISTO.INTSCALEFN))) (T (PLOTTICFN HISTOGRAM 'X (FUNCTION HISTO.TICFN] (* Draw the histogram based on the  PLOT PROP's) (HISTO.DRAW HISTOGRAM) (* Returns a PLOT) (RETURN HISTOGRAM]) (MAKEBININTERVAL [LAMBDA (BATCHMIN BATCHMAX NBINS INTFLG) (* jop%: "25-Feb-86 12:48") (* *) (COND [INTFLG (LET ((NINT (ADD1 (IDIFFERENCE BATCHMAX BATCHMIN))) MULT) (COND ((IGEQ NBINS NINT) (create BININTERVAL BINMIN _ BATCHMIN BINMAX _ BATCHMAX BININC _ 1 NBINS _ NINT)) (T (SETQ MULT (PLOT.CEILING (FQUOTIENT (DIFFERENCE BATCHMAX BATCHMIN) NBINS))) (create BININTERVAL BINMIN _ BATCHMIN BINMAX _ (PLUS BATCHMIN (TIMES MULT NBINS)) BININC _ MULT NBINS _ NBINS] (T (LET [(TICINFO (SCALE BATCHMIN BATCHMAX (ADD1 NBINS] (create BININTERVAL BINMIN _ (fetch (TICINFO TICMIN) of TICINFO) BINMAX _ (fetch (TICINFO TICMAX) of TICINFO) BININC _ (fetch (TICINFO TICINC) of TICINFO) NBINS _ NBINS]) (SUMMARYWINDOW.REPAINTFN [LAMBDA (WINDOW) (* jop%: "12-May-85 14:40") (* * PRIN1 whatever happens to be under the OUTPUT PROP) (PROG [(OUTPUT (WINDOWPROP WINDOW 'OUTPUT] (CLEARW WINDOW) (printout WINDOW OUTPUT T]) ) (DECLARE%: EVAL@COMPILE (RECORD BININTERVAL (BINMIN BINMAX BININC NBINS)) ) (* * SCATTERPLOT FNS) (DEFINEQ (SCATPLOT [LAMBDA (Y X POINTLABELS YLABEL XLABEL TITLE SYMBOL) (* jop%: "26-Feb-86 12:44") (* * X and Y are equal length list of numbers, or X is NIL) (COND ((NULL X) (SETQ X (for I from 1 to (LENGTH Y) collect I))) ((NOT (EQLENGTH Y (LENGTH X))) (HELP "X and Y must be of equal length"))) [COND ((NULL TITLE) (SETQ TITLE (COND ((AND XLABEL YLABEL) (CONCAT "Scatterplot of" YLABEL " vs " XLABEL)) (T "Scatterplot"] (COND ((NULL SYMBOL) (SETQ SYMBOL STAR))) (LET* [(SCATPLOT (CREATEPLOT)) [RIGHTMENUITEMS '((Logscale SCAT.LOGSCALE "Toggle exponential tics" (SUBITEMS (X% axis (SCAT.LOGSCALE 'X) "X axis only") (Y% axis (SCAT.LOGSCALE 'Y) "Y axis only"))) (Coordinates SCAT.WORLDCOORD "Display world coordinates at cursor position"] (POINTMENUITEMS '((Coordinates SCAT.POINTCOORDS "Display point coordinates"] (PLOTPOINTS SCATPLOT (for XVALUE in X as YVALUE in Y collect (CREATEPOSITION XVALUE YVALUE) ) POINTLABELS SYMBOL 'POINTMENU T) (PLOTTICS SCATPLOT 'BOTTOM T T) (PLOTTICS SCATPLOT 'LEFT T T) (PLOTLABEL SCATPLOT 'BOTTOM XLABEL T) (PLOTLABEL SCATPLOT 'LEFT YLABEL T) (PLOTLABEL SCATPLOT 'TOP TITLE T) (PLOTADDMENUITEMS SCATPLOT 'RIGHT RIGHTMENUITEMS) (PLOTMENUITEMS SCATPLOT 'POINTMENU (APPEND (PLOTMENUITEMS SCATPLOT 'MIDDLE) POINTMENUITEMS)) (RESCALEPLOT SCATPLOT 'BOTH T) (OPENPLOTWINDOW SCATPLOT) SCATPLOT]) (SCAT.LOGSCALE [LAMBDA (PLOT AXIS) (* jop%: "25-Feb-86 13:22") (* * sets up PLOT to have log scale on AXIS --  X, Y or both) [COND ((NULL AXIS) (SETQ AXIS 'BOTH] (PROG ((XON (EQ (PLOTTICFN PLOT 'X) (FUNCTION LOGTICFN))) (YON (EQ (PLOTTICFN PLOT 'Y) (FUNCTION LOGTICFN))) (XLOWER (fetch (PLOT XLOWER) of PLOT)) (XUPPER (fetch (PLOT XUPPER) of PLOT)) (YLOWER (fetch (PLOT YLOWER) of PLOT)) (YUPPER (fetch (PLOT YUPPER) of PLOT))) [COND ((OR (EQ AXIS 'X) (EQ AXIS 'BOTH)) (COND ((AND (NULL XON) (OR (LESSP XLOWER -35) (GREATERP XUPPER 35))) (PLOTPROMPT "X axis scale not appropriate" PLOT)) (T (PLOTTICFN PLOT 'X (AND (NULL XON) (FUNCTION LOGTICFN)) T) (PLOTPROP PLOT 'XLABELFN (AND (NULL XON) (FUNCTION PLOT.EXP10))) (PLOTPROP PLOT 'XWORLDFN (AND (NULL XON) (FUNCTION PLOT.LOG10))) (RESCALEPLOT PLOT 'X T] [COND ((OR (EQ AXIS 'Y) (EQ AXIS 'BOTH)) (COND ((AND (NULL YON) (OR (LESSP YLOWER -35) (GREATERP YUPPER 35))) (PLOTPROMPT "Y axis scale not appropriate" PLOT)) (T (PLOTTICFN PLOT 'Y (AND (NULL YON) (FUNCTION LOGTICFN)) T) (PLOTPROP PLOT 'YLABELFN (AND (NULL YON) (FUNCTION PLOT.EXP10))) (PLOTPROP PLOT 'YWORLDFN (AND (NULL YON) (FUNCTION PLOT.LOG10))) (RESCALEPLOT PLOT 'Y T] (REDRAWPLOTWINDOW PLOT) (RETURN PLOT]) (SCAT.POINTCOORDS [LAMBDA (POINTOBJECT SCATTERPLOT) (* jop%: "20-Jan-86 21:18") (PROG ([POINTPOSITION (fetch (POINTDATA POINTPOSITION) of (PLOTOBJECTPROP POINTOBJECT 'OBJECTDATA] (XLABEL (CONCAT (OR (PLOTLABEL SCATTERPLOT 'BOTTOM) "XCOORD") " ")) (YLABEL (CONCAT " " (OR (PLOTLABEL SCATTERPLOT 'LEFT) "YCOORD") " "))) (PLOTPROMPT (CONCAT XLABEL (PLOT.WORLDTOLABEL (fetch XCOORD of POINTPOSITION) SCATTERPLOT 'X) YLABEL (PLOT.WORLDTOLABEL (fetch YCOORD of POINTPOSITION) SCATTERPLOT 'Y)) SCATTERPLOT]) (SCAT.WORLDCOORD [LAMBDA (SCATTERPLOT) (* jop%: "20-Jan-86 17:46") (PROG ((PLOTWINDOW (PLOTPROP SCATTERPLOT 'PLOTWINDOW)) (PLOTPROMPTWINDOW (PLOTPROP SCATTERPLOT 'PLOTPROMPTWINDOW)) (PLOTVIEWPORT (PLOTPROP SCATTERPLOT 'PLOTWINDOWVIEWPORT)) (XLABEL (CONCAT (OR (PLOTLABEL SCATTERPLOT 'BOTTOM) "X") " at ")) (YLABEL (CONCAT " " (OR (PLOTLABEL SCATTERPLOT 'LEFT) "Y") " at ")) (OLDCURSORPOS (CONSTANT (create POSITION XCOORD _ 0 YCOORD _ 0))) (NEWCURSORPOS (CONSTANT (create POSITION))) STARTXCOORDX STARTXCOORDY STARTYCOORDX STARTYCOORDY) (PRINTOUT PLOTPROMPTWINDOW T XLABEL) (SETQ STARTXCOORDX (DSPXPOSITION NIL PLOTPROMPTWINDOW)) (SETQ STARTXCOORDY (DSPYPOSITION NIL PLOTPROMPTWINDOW)) (PRINTOUT PLOTPROMPTWINDOW .SP 10 YLABEL) (SETQ STARTYCOORDX (DSPXPOSITION NIL PLOTPROMPTWINDOW)) (SETQ STARTYCOORDY (DSPYPOSITION NIL PLOTPROMPTWINDOW)) (while (MOUSESTATE UP) do (SETQ NEWCURSORPOS (CURSORPOSITION NIL PLOTWINDOW NEWCURSORPOS)) (if [NOT (AND (EQP (fetch XCOORD of OLDCURSORPOS) (fetch XCOORD of NEWCURSORPOS)) (EQP (fetch YCOORD of OLDCURSORPOS) (fetch YCOORD of NEWCURSORPOS] then (MOVETO STARTXCOORDX STARTXCOORDY PLOTPROMPTWINDOW) (PRINTOUT PLOTPROMPTWINDOW |.F10.4| (STREAMTOWORLDX (fetch XCOORD of NEWCURSORPOS) PLOTVIEWPORT)) (MOVETO STARTYCOORDX STARTYCOORDY PLOTPROMPTWINDOW) (PRINTOUT PLOTPROMPTWINDOW |.F10.4| (STREAMTOWORLDY (fetch YCOORD of NEWCURSORPOS) PLOTVIEWPORT)) (replace XCOORD of OLDCURSORPOS with (fetch XCOORD of NEWCURSORPOS)) (replace YCOORD of OLDCURSORPOS with (fetch YCOORD of NEWCURSORPOS]) (LOGTICFN [LAMBDA (MIN MAX) (* jop%: "18-Jun-86 12:49") (* * returns TICINFO for log scale) (* assumes log to base 10 -- later base could be determined by plot prop) (COND [(GREATERP (DIFFERENCE MAX MIN) 1) (* spans more than 1 decade; use equispaced tics on logscale) (LET ((NEWMIN (PLOT.FLOOR MIN)) (NEWMAX (PLOT.CEILING MAX)) RANGE NUMINT INC EXCESS) (SETQ RANGE (IDIFFERENCE NEWMAX NEWMIN)) [SETQ NUMINT (for NUMINT from 2 to 7 smallest (* NUMINT is %# of intervals =  %#tics-1) (TIMES NUMINT (PLOT.CEILING (FQUOTIENT RANGE NUMINT] (SETQ INC (PLOT.CEILING (FQUOTIENT RANGE NUMINT))) (SETQ EXCESS (DIFFERENCE (TIMES NUMINT INC) RANGE)) (* EXCESS is additional number of decades to include for pretty RANGE) (add NEWMIN (MINUS (IQUOTIENT EXCESS 2))) (add NEWMAX (DIFFERENCE EXCESS (IQUOTIENT EXCESS 2))) (create TICINFO TICMAX _ NEWMAX TICMIN _ NEWMIN TICINC _ (for I from NEWMIN to NEWMAX by INC collect (CONS I (EXPT 10.0 I] (T (* plot is in a single decade; use equispaced tics on exponential scale) (LET ((MINEXP (EXPT 10.0 MIN)) (MAXEXP (EXPT 10.0 MAX)) (UNITSIZE (PLOT.FLOOR MIN)) TICINFO) (* UNITSIZE is the unit interval in  this decade) (bind (RANGE _ (PLOT.LOG10 (DIFFERENCE MAXEXP MINEXP))) while (LESSP RANGE UNITSIZE) do (SETQ UNITSIZE (SUB1 UNITSIZE))) (SETQ TICINFO (DEFAULTTICFN MINEXP MAXEXP NIL NIL UNITSIZE)) (* check for zero endpoint) (with TICINFO TICINFO [COND [(EQP 0 TICMIN) (LET* ((UNITSIZEEXP (EXPT 10.0 UNITSIZE)) (LOWERMULT (PLOT.FLOOR (FQUOTIENT MINEXP UNITSIZEEXP))) (UPPERMULT (PLOT.CEILING (FQUOTIENT MAXEXP UNITSIZEEXP))) UPPERUNITSIZEEXP) (COND [(LEQ UPPERMULT 10) (* entire plot fits in single decade -- put a tic at each unit) (SETQ TICMIN (TIMES UNITSIZEEXP LOWERMULT)) (SETQ TICMAX (TIMES UNITSIZEEXP UPPERMULT)) (SETQ TICINC UNITSIZEEXP) (SETQ NTICS (ADD1 (DIFFERENCE UPPERMULT LOWERMULT))) (SETQ TICINC (NCONC1 (for VALUE from TICMIN by TICINC as I from 1 to (SUB1 NTICS) collect (CONS (PLOT.LOG10 VALUE) VALUE)) (CONS (PLOT.LOG10 TICMAX) TICMAX] (T (* plot crosses decade bound -- switch to larger units after decade bound to  avoid possibility of large number of tic marks) (SETQ UPPERUNITSIZEEXP (TIMES 10 UNITSIZEEXP)) (SETQ UPPERMULT (PLOT.CEILING (FQUOTIENT MAXEXP UPPERUNITSIZEEXP ))) (SETQ TICMIN (TIMES UNITSIZEEXP LOWERMULT)) (SETQ TICMAX (TIMES UPPERUNITSIZEEXP UPPERMULT)) (* 10-LOWERMULT tics using small units, UPPERMULT tics using large units) (SETQ NTICS (PLUS 10 (DIFFERENCE UPPERMULT LOWERMULT))) (SETQ TICINC (NCONC1 (NCONC (for VALUE from TICMIN by UNITSIZEEXP as I from LOWERMULT to 9 collect (CONS (PLOT.LOG10 VALUE) VALUE)) (for VALUE from UPPERUNITSIZEEXP by UPPERUNITSIZEEXP as I from 1 to (SUB1 UPPERMULT) collect (CONS (PLOT.LOG10 VALUE) VALUE))) (CONS (PLOT.LOG10 TICMAX) TICMAX] (T (* no adjustment needed) (SETQ TICINC (NCONC1 (for VALUE from TICMIN by TICINC as I from 1 to (SUB1 NTICS) collect (CONS (PLOT.LOG10 VALUE) VALUE)) (CONS (PLOT.LOG10 TICMAX) TICMAX] (SETQ TICMIN (PLOT.LOG10 TICMIN)) (SETQ TICMAX (PLOT.LOG10 TICMAX))) TICINFO]) ) (* * Depends on PLOT) (FILESLOAD PLOT) (DECLARE%: EVAL@COMPILE [PUTPROPS HISTO.GETFREQ MACRO (OPENLAMBDA (ITEM) (COND ((LISTP ITEM) (CDR ITEM)) (T 1] [PUTPROPS HISTO.GETVALUE MACRO (OPENLAMBDA (ITEM) (COND ((LISTP ITEM) (CAR ITEM)) (T ITEM] ) (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS PLOTEXAMPLES COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1236 22599 (COMPUTEMULTIPLE 1246 . 1769) (HISTO.CHANGEBINS 1771 . 4356) (HISTO.COPYFN 4358 . 4770) (HISTO.DRAW 4772 . 9295) (HISTO.INTSCALEFN 9297 . 9591) (HISTO.INTTICFN 9593 . 10432) ( HISTO.MAKEBINS 10434 . 12734) (HISTO.RESET 12736 . 13014) (HISTO.TICFN 13016 . 14701) (HISTO.VALUES 14703 . 16987) (HISTPLOT 16989 . 20921) (MAKEBININTERVAL 20923 . 22276) (SUMMARYWINDOW.REPAINTFN 22278 . 22597)) (22709 37054 (SCATPLOT 22719 . 24759) (SCAT.LOGSCALE 24761 . 27017) (SCAT.POINTCOORDS 27019 . 28040) (SCAT.WORLDCOORD 28042 . 30859) (LOGTICFN 30861 . 37052))))) STOP \ No newline at end of file diff --git a/lispusers/PLOTEXAMPLES.TEDIT b/lispusers/PLOTEXAMPLES.TEDIT new file mode 100644 index 00000000..ac4bae83 Binary files /dev/null and b/lispusers/PLOTEXAMPLES.TEDIT differ diff --git a/lispusers/PLOTINSKETCH b/lispusers/PLOTINSKETCH new file mode 100644 index 00000000..6923daf9 --- /dev/null +++ b/lispusers/PLOTINSKETCH @@ -0,0 +1 @@ +(FILECREATED " 9-Apr-87 11:43:55" {ERIS}KOTO>PLOTINSKETCH.;3 8424 changes to: (FNS IMAGE.OBJECT.CHANGED PLIO.EDITCLOSEFN) (VARS PLOTINSKETCHCOMS) previous date: " 8-Apr-87 11:38:56" {ERIS}KOTO>PLOTINSKETCH.;2) (* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PLOTINSKETCHCOMS) (RPAQQ PLOTINSKETCHCOMS ((FNS PLIO.IMAGEBOXFN PLIO.BUTTONEVENTINFN PLIO.REINSERTOBJ PLIO.EDITCLOSEFN) (FNS IMAGE.OBJECT.CHANGED))) (DEFINEQ (PLIO.IMAGEBOXFN (LAMBDA (PLOTIOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* thh: " 6-Aug-86 09:09") (* * Determines size of plotimageobj) (PROG ((IMAGEWIDTH (IMAGEOBJPROP PLOTIOBJ (QUOTE WIDTH))) (IMAGEHEIGHT (IMAGEOBJPROP PLOTIOBJ (QUOTE HEIGHT))) (PLOT (IMAGEOBJPROP PLOTIOBJ (QUOTE OBJECTDATUM))) (SCALE (COND (IMAGESTREAM (DSPSCALE NIL IMAGESTREAM)) (T 1))) NEWREGION MINSIZE) (* (* this doesn't work with Sketch which has no rightmargin) (if (GREATERP (TIMES SCALE IMAGEWIDTH)  (DIFFERENCE RIGHTMARGIN CURRENTX)) then (if (NOT (EQ (IMAGESTREAMTYPE IMAGESTREAM) (QUOTE DISPLAY))) then  (HELP "PLOT image object too big")) (PROMPTPRINT "Image object too wide. Choose a smaller region")  (SETQ MINSIZE (MINSTREAMREGIONSIZE IMAGESTREAM PLOT)) (SETQ NEWREGION (GETREGION (CAR MINSIZE)  (CDR MINSIZE))) (SETQ IMAGEWIDTH (fetch WIDTH of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE WIDTH) IMAGEWIDTH)  (SETQ IMAGEHEIGHT (fetch HEIGHT of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE HEIGHT) IMAGEHEIGHT))) (RETURN (create IMAGEBOX XSIZE _(TIMES SCALE IMAGEWIDTH) YSIZE _(TIMES SCALE IMAGEHEIGHT) YDESC _ 0 XKERN _ 0))))) (PLIO.BUTTONEVENTINFN (LAMBDA (PLOTIMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) (* thh: " 6-Aug-86 10:34") (PROG ((CHOICEMENU (CONSTANT (create MENU CENTERFLG _ T ITEMS _(QUOTE ((Select (QUOTE SELECT) "Select the image object") (Reshape (QUOTE RESHAPE) "Reshape the image objcet") (Plot% Window (QUOTE EDIT) "Open a window containing plot"))))) ) (PLOT (IMAGEOBJPROP PLOTIMAGEOBJ (QUOTE OBJECTDATUM))) (IMAGEWIDTH (IMAGEOBJPROP PLOTIMAGEOBJ (QUOTE WIDTH))) (IMAGEHEIGHT (IMAGEOBJPROP PLOTIMAGEOBJ (QUOTE HEIGHT))) MINSIZE NEWREGION WIN NEWPLOT) (* * consider selection if BUTTON=NIL to handle plots in Koto version of Sketch) (COND ((OR (NOT BUTTON) (EQ BUTTON (QUOTE LEFT))) (SELECTQ (MENU CHOICEMENU) (RESHAPE (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP (fetch PLOTWINDOW of PLOT) (QUOTE DSP)) PLOT)) (* Assumes the WINDOWSTREAM has been changed to fit  the imageobj) (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE) (CREATEREGION (DSPXOFFSET NIL WINDOWSTREAM) (DSPYOFFSET NIL WINDOWSTREAM) IMAGEWIDTH IMAGEHEIGHT))) (IMAGEOBJPROP PLOTIMAGEOBJ (QUOTE WIDTH) (fetch WIDTH of NEWREGION)) (IMAGEOBJPROP PLOTIMAGEOBJ (QUOTE HEIGHT) (fetch HEIGHT of NEWREGION)) (* Redraw the Image object) (RETURN (QUOTE CHANGED))) (EDIT (SETQ NEWPLOT (COPYPLOT PLOT NIL (GETBOXREGION ( WIDTHIFWINDOW IMAGEWIDTH) ( HEIGHTIFWINDOW IMAGEHEIGHT T)) "Plot Edit Window")) (SETQ WIN (OPENPLOTWINDOW NEWPLOT)) (* Cache some info some that changes to NEWPLOT may be reinserted into TEXTSTREAM. Windowprops are used because they are not copied  (HACK)) (* * sketch doesn't pass down anything for TEXTSTREAM arg so must use viewer window instead) (WINDOWPROP WIN (QUOTE SOURCEHOST) (OR TEXTSTREAM WINDOW WINDOWSTREAM)) (WINDOWPROP WIN (QUOTE SOURCEIMAGEOBJ) PLOTIMAGEOBJ) (WINDOWADDPROP WIN (QUOTE CLOSEFN) (QUOTE PLIO.EDITCLOSEFN) T) (* * handle reinsert by a closefn rather than an new menu item -- similar to the behavior of Sketch image object  edits (PLOTADDMENUITEMS NEWPLOT (QUOTE RIGHT) (QUOTE ((Reinsert PLIO.REINSERTOBJ "Change source image object"))))) (RETURN T)) (RETURN NIL))) (T (RETURN NIL)))))) (PLIO.REINSERTOBJ (LAMBDA (PLOT) (* thh: " 6-Aug-86 09:48") (* * allows modified plot to be reinserted in document) (* * modified to work with Sketch as well as TEdit sources) (PROG ((PLOTWINDOW (fetch PLOTWINDOW of PLOT)) HOST OBJ) (SETQ HOST (WINDOWPROP PLOTWINDOW (QUOTE SOURCEHOST))) (SETQ OBJ (WINDOWPROP PLOTWINDOW (QUOTE SOURCEIMAGEOBJ))) (COND ((NOT (IMAGEOBJP OBJ)) (HELP "Not an IMAGEOBJ" OBJ))) (* Destructively change imageobj to retain EQ ness) (IMAGEOBJPROP OBJ (QUOTE OBJECTDATUM) (COPYPLOT PLOT)) (IMAGEOBJPROP OBJ (QUOTE WIDTH) (WINDOWPROP PLOTWINDOW (QUOTE WIDTH))) (IMAGEOBJPROP OBJ (QUOTE HEIGHT) (WINDOWPROP PLOTWINDOW (QUOTE HEIGHT))) (IMAGE.OBJECT.CHANGED HOST OBJ)))) (PLIO.EDITCLOSEFN (LAMBDA (W) (* thh: " 8-Apr-87 11:38") (* * this plot window is from an image object. Reinsert plot if requested) (* * later could test if plot has been changed -- if no changes don't ask to reinsert) (LET (RESULT) (SETQ RESULT (SELECTQ (MENU (CONSTANT (create MENU TITLE _ "Change source image object?" ITEMS _(QUOTE ((Yes (QUOTE YES) "this image used in the document instead of the one that is there.") (No (QUOTE NO) "the changes made to this image will not be put into the document."))) CENTERFLG _ T))) (YES (PLIO.REINSERTOBJ (WHICHPLOT W)) NIL) (NO NIL) (NIL (* user selected outside the menu -- abort the close) (QUOTE DON'T)) NIL)) (OR RESULT (WINDOWDELPROP W (QUOTE CLOSEFN) (QUOTE PLIO.EDITCLOSEFN))) (* clean up window prop -- required since currently  PLOT.CLOSEFN calls CLOSEW!) RESULT))) ) (DEFINEQ (IMAGE.OBJECT.CHANGED (LAMBDA (HOST OBJECT) (* thh: " 9-Apr-87 10:15") (* notifies HOST that OBJECT has changed and needs to  be redisplayed) (* * currently assumes object is in TEdit or Sketch) (LET (CANONICALHOST) (COND ((SETQ CANONICALHOST (CAR (NLSETQ (TEXTSTREAM HOST)))) (TEDIT.OBJECT.CHANGED CANONICALHOST OBJECT)) ((SETQ CANONICALHOST (CAR (NLSETQ (INSURE.SKETCH HOST)))) (* INSURE.SKETCH noerrorflg doesn't work) (SK.MARK.DIRTY CANONICALHOST) (* this sets SKETCHCHANGED prop of all viewers on the  sketch) (for SKW in (SKETCH.ALL.VIEWERS CANONICALHOST) do (REDISPLAYW SKW))) (T (HELP "Can't update image object in " HOST)))))) ) (PUTPROPS PLOTINSKETCH COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (511 7336 (PLIO.IMAGEBOXFN 521 . 1825) (PLIO.BUTTONEVENTINFN 1827 . 5107) ( PLIO.REINSERTOBJ 5109 . 6079) (PLIO.EDITCLOSEFN 6081 . 7334)) (7337 8341 (IMAGE.OBJECT.CHANGED 7347 . 8339))))) STOP \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS b/lispusers/PLOTOBJECTS new file mode 100644 index 00000000..f3629ca6 --- /dev/null +++ b/lispusers/PLOTOBJECTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Jun-92 16:56:29" |{PELE:MV:ENVOS}MEDLEY>PLOTOBJECTS.;2| 103453 changes to%: (VARS PLOTOBJECTSCOMS) (FNS COPYGENERIC DISTANCETOCOMPOUND DISTANCETOCURVE DISTANCETOFILLEDRECTANGLE DISTANCETOGRAPH DISTANCETOLINE DISTANCETOPOINT DISTANCETOPOLYGON DISTANCETOTEXT EXTENTOFCOMPOUND EXTENTOFCURVE EXTENTOFFILLEDRECTANGLE EXTENTOFPOINT EXTENTOFPOLYGON EXTENTOFTEXT LABELGENERIC MOVECOMPOUND MOVECURVE MOVEFILLEDRECTANGLE MOVELINE MOVEPOLYGON MOVETEXT PUTGENERIC) previous date%: " 5-May-87 18:01:23" |{PELE:MV:ENVOS}MEDLEY>PLOTOBJECTS.;1|) (* ; " Copyright (c) 1985, 1986, 1987, 1992 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PLOTOBJECTSCOMS) (RPAQQ PLOTOBJECTSCOMS [(FNS COPYCOMPOUND COPYCURVE COPYFILLEDRECTANGLE COPYGENERIC COPYGRAPHOBJECT COPYLINE COPYPOINT COPYPOLYGON COPYTEXT CREATECOMPOUND CREATECURVE CREATEFILLEDRECTANGLE CREATEGRAPH CREATELINE CREATEPOINT CREATEPOLYGON CREATETEXT DISTANCETOCOMPOUND DISTANCETOCURVE DISTANCETOFILLEDRECTANGLE DISTANCETOGRAPH DISTANCETOLINE DISTANCETOPOINT DISTANCETOPOLYGON DISTANCETOTEXT DRAWCOMPOUNDOBJECT DRAWCURVEOBJECT DRAWFILLEDRECTANGLEOBJECT DRAWGRAPHOBJECT DRAWLINEOBJECT DRAWPOINTOBJECT DRAWPOLYGONOBJECT DRAWTEXTOBJECT ERASECOMPOUNDOBJECT ERASECURVEOBJECT ERASEFILLEDRECTANGLEOBJECT ERASEGRAPHOBJECT ERASELINEOBJECT ERASEPOINTOBJECT ERASEPOLYGONOBJECT ERASETEXTOBJECT EXTENTOFCOMPOUND EXTENTOFCURVE EXTENTOFFILLEDRECTANGLE EXTENTOFGRAPH EXTENTOFLINE EXTENTOFPOINT EXTENTOFPOLYGON EXTENTOFTEXT GETCOMPOUND GETCURVE GETFILLEDRECTANGLE GETGENERIC GETGRAPH GETLINE GETPOINT GETPOLYGON GETTEXT HIGHLIGHTCOMPOUND HIGHLIGHTCURVE HIGHLIGHTFILLEDRECTANGLE HIGHLIGHTGRAPH HIGHLIGHTLINE HIGHLIGHTPOINT HIGHLIGHTPOLYGON HIGHLIGHTTEXT LABELGENERIC LABELPOINT LABELTEXT LOWLIGHTCOMPOUND MOVECOMPOUND MOVECURVE MOVEFILLEDRECTANGLE MOVELINE MOVEPOINT MOVEPOLYGON MOVETEXT PLOTCOMPOUND PLOTCURVE PLOTFILLEDRECTANGLE PLOTGRAPH PLOTLINE PLOTPOINT PLOTPOINTS PLOTPOLYGON PLOTTEXT PUTCOMPOUND PUTCURVE PUTFILLEDRECTANGLE PUTGENERIC PUTGRAPH PUTLINE PUTPOINT PUTPOLYGON PUTTEXT) (MACROS L1METRIC L2METRIC) (VARS CIRCLE CROSS DASH DOT DOTDASH SHADE1 SHADE2 SHADE3 SHADE4 SHADE5 SHADE6 SHADE7 SHADE8 STAR) (RECORDS COMPOUNDDATA CURVEDATA FILLEDRECTANGLEDATA GRAPHDATA LINEDATA PLOT.STYLE POINTDATA POLYGONDATA TEXTDATA) (PROP ARGNAMES PLOTCOMPOUND) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PLOTCOMPOUND]) (DEFINEQ (COPYCOMPOUND [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:45 by jop") (* ;; "Copyfn for COMPOUND objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create COMPOUNDDATA COMPONENTS _ (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of OBJECTDATA) collect (COPYPLOTOBJECT OBJECT PLOT)) COMPOUNDTYPE _ (fetch (COMPOUNDDATA COMPOUNDTYPE) of OBJECTDATA]) (COPYCURVE [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for CURVE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create CURVEDATA CURVEPOINTS _ (COPYALL (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA)) STYLE _ (COPYALL (fetch (CURVEDATA STYLE) of OBJECTDATA]) (COPYFILLEDRECTANGLE [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for FILLEDRECTANGLE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create FILLEDRECTANGLEDATA OBJECTLEFT _ (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA) OBJECTBOTTOM _ (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) OBJECTWIDTH _ (fetch (FILLEDRECTANGLEDATA OBJECTWIDTH) of OBJECTDATA) OBJECTHEIGHT _ (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of OBJECTDATA) BORDERWIDTH _ (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) TEXTURE _ (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA]) (COPYGENERIC [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 1-Jun-92 16:41 by jds") (* ;; "Default COPYFN") (HCOPYALL (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT]) (COPYGRAPHOBJECT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create GRAPHDATA GRAPHFN _ (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA) NSAMPLES _ (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA) STYLE _ (COPYALL (fetch (GRAPHDATA STYLE) of OBJECTDATA]) (COPYLINE [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for LINE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create LINEDATA INFINITESLOPE? _ (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) SLOPE _ (fetch (LINEDATA SLOPE) of OBJECTDATA) CONSTANT _ (fetch (LINEDATA CONSTANT) of OBJECTDATA) STYLE _ (COPYALL (fetch (LINEDATA STYLE) of OBJECTDATA]) (COPYPOINT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for POINT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create POINTDATA POINTPOSITION _ (COPYALL (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) SYMBOL _ (fetch (POINTDATA SYMBOL) of OBJECTDATA]) (COPYPOLYGON [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for POLYGON objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create POLYGONDATA POLYGONPOINTS _ (COPYALL (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA)) STYLE _ (COPYALL (fetch (POLYGONDATA STYLE) of OBJECTDATA]) (COPYTEXT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Copyfn for TEXT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create TEXTDATA TEXTPOSITION _ (COPYALL (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA)) TEXT _ (COPYALL (fetch (TEXTDATA TEXT) of OBJECTDATA)) FONT _ (fetch (TEXTDATA FONT) of OBJECTDATA]) (CREATECOMPOUND [LAMBDA (COMPOUNDTYPE COMPONENTS LABEL MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "create a compound plot object. First is the required Compoundtype, then the components, a list of plotobjects, then the optional label,and menu") (CREATEPLOTOBJECT COMPOUNDFNS 'COMPOUND LABEL MENU (create COMPOUNDDATA COMPONENTS _ COMPONENTS COMPOUNDTYPE _ COMPOUNDTYPE]) (CREATECURVE [LAMBDA (POSITIONS LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Create a curve plot object") (CREATEPLOTOBJECT CURVEFNS 'CURVE LABEL MENU (create CURVEDATA CURVEPOINTS _ POSITIONS STYLE _ (COND ((FIXP STYLE) (create PLOT.STYLE LINEWIDTH _ STYLE)) ((LISTP STYLE) (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE))) (T (create PLOT.STYLE LINEWIDTH _ 1]) (CREATEFILLEDRECTANGLE [LAMBDA (LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Create a filledrectangle plot object") (if (NULL TEXTURE) then (SETQ TEXTURE 'SHADE3)) (CREATEPLOTOBJECT FILLEDRECTANGLEFNS 'FILLEDRECTANGLE LABEL MENU (create FILLEDRECTANGLEDATA OBJECTLEFT _ LEFT OBJECTBOTTOM _ BOTTOM OBJECTWIDTH _ WIDTH OBJECTHEIGHT _ HEIGHT BORDERWIDTH _ (OR BORDERWIDTH 1) TEXTURE _ TEXTURE]) (CREATEGRAPH [LAMBDA (GRAPHFN NSAMPLES LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") (CREATEPLOTOBJECT GRAPHFNS 'GRAPH LABEL MENU (create GRAPHDATA GRAPHFN _ GRAPHFN NSAMPLES _ (OR (FIXP NSAMPLES) 100) STYLE _ (if (FIXP STYLE) then (create PLOT.STYLE LINEWIDTH _ STYLE) elseif (LISTP STYLE) then (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE)) else (create PLOT.STYLE LINEWIDTH _ 1]) (CREATELINE [LAMBDA (SLOPE CONSTANT LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Create a line plot object") (CREATEPLOTOBJECT LINEFNS 'LINE LABEL MENU (create LINEDATA INFINITESLOPE? _ (NOT SLOPE) SLOPE _ (OR SLOPE 0.0) CONSTANT _ CONSTANT STYLE _ (COND ((FIXP STYLE) (create PLOT.STYLE LINEWIDTH _ STYLE)) ((LISTP STYLE) (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE))) (T (create PLOT.STYLE LINEWIDTH _ 1]) (CREATEPOINT [LAMBDA (POSITION LABEL SYMBOL MENU) (* ; "Edited 5-May-87 17:48 by jop") (* ;; "Create a point plot object") (if (NULL SYMBOL) then (SETQ SYMBOL STAR)) (CREATEPLOTOBJECT POINTFNS 'POINT LABEL MENU (create POINTDATA POINTPOSITION _ POSITION SYMBOL _ SYMBOL]) (CREATEPOLYGON [LAMBDA (POSITIONS LABEL STYLE MENU) (* ; "Edited 5-May-87 17:48 by jop") (* ;; "Create a polygon Plot object") (CREATEPLOTOBJECT POLYGONFNS 'POLYGON LABEL MENU (create POLYGONDATA POLYGONPOINTS _ POSITIONS STYLE _ (if (FIXP STYLE) then (create PLOT.STYLE LINEWIDTH _ STYLE) elseif (LISTP STYLE) then (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE)) else (create PLOT.STYLE LINEWIDTH _ 1]) (CREATETEXT [LAMBDA (POSITION TEXT LABEL FONT MENU) (* ; "Edited 5-May-87 17:48 by jop") (* ;; "Create a Text Plot object") (CREATEPLOTOBJECT TEXTFNS 'TEXT LABEL MENU (create TEXTDATA TEXTPOSITION _ POSITION TEXT _ TEXT FONT _ FONT]) (DISTANCETOCOMPOUND [LAMBDA (COMPOUNDDATA STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:42 by jds") (PROG [(COMPONENTS (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDDATA] (RETURN (bind (CMIN _ (DISTANCETOPLOTOBJECT (CAR COMPONENTS) STREAMPOSITION PLOT)) PMIN for PART in (CDR COMPONENTS) do (SETQ PMIN (DISTANCETOPLOTOBJECT PART STREAMPOSITION PLOT)) (if (LESSP PMIN CMIN) then (SETQ CMIN PMIN)) finally (RETURN CMIN]) (DISTANCETOCURVE [LAMBDA (CURVEDATA STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC STREAMPOSITION (for POINT in (fetch (CURVEDATA STREAMPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of CURVEDATA)) smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLE STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) (CLOSEST (CONSTANT (create POSITION))) (STREAMX (fetch XCOORD of STREAMPOSITION)) (STREAMY (fetch YCOORD of STREAMPOSITION)) STREAMLEFT STREAMBOTTOM STREAMRIGHT STREAMTOP INSIDEFLG) (SETQ STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) (SETQ STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) (SETQ STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) (SETQ STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA)) [replace XCOORD of CLOSEST with (if (GREATERP STREAMX STREAMRIGHT) then STREAMRIGHT elseif (LESSP STREAMX STREAMLEFT) then STREAMLEFT else (if (OR (GREATERP STREAMY STREAMTOP) (LESSP STREAMY STREAMBOTTOM)) then STREAMX else (SETQ INSIDEFLG T) (* ;; "Hack to deal with the case of adjacent filledrectangles. Bonus subtracted from metric if cursor inside rectangle") (if (LESSP (IMIN (IDIFFERENCE STREAMTOP STREAMY) (IDIFFERENCE STREAMY STREAMBOTTOM)) (IMIN (IDIFFERENCE STREAMRIGHT STREAMX) (IDIFFERENCE STREAMX STREAMLEFT))) then STREAMX else (if (LESSP (IDIFFERENCE STREAMRIGHT STREAMX) (IDIFFERENCE STREAMX STREAMLEFT)) then STREAMRIGHT else STREAMLEFT] [replace YCOORD of CLOSEST with (if (GREATERP STREAMY STREAMTOP) then STREAMTOP elseif (LESSP STREAMY STREAMBOTTOM) then STREAMBOTTOM else (if (OR (GREATERP STREAMX STREAMRIGHT) (LESSP STREAMX STREAMLEFT)) then STREAMY else (if (LESSP (IMIN (IDIFFERENCE STREAMRIGHT STREAMX) (IDIFFERENCE STREAMX STREAMLEFT)) (IMIN (IDIFFERENCE STREAMTOP STREAMY) (IDIFFERENCE STREAMY STREAMBOTTOM))) then STREAMY else (if (LESSP (IDIFFERENCE STREAMTOP STREAMY) (IDIFFERENCE STREAMY STREAMBOTTOM)) then STREAMTOP else STREAMBOTTOM] (RETURN (if INSIDEFLG then (IDIFFERENCE (L1METRIC STREAMPOSITION CLOSEST) 2) else (L1METRIC STREAMPOSITION CLOSEST]) (DISTANCETOGRAPH [LAMBDA (GRAPHOBJECT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC STREAMPOSITION (for POINT in (fetch (GRAPHDATA STREAMPOSITIONS) of (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOLINE [LAMBDA (LINEOBJECT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (PROG ((X0 (fetch XCOORD of STREAMPOSITION)) (Y0 (fetch YCOORD of STREAMPOSITION)) (STREAMSLOPE (fetch STREAMSLOPE of (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) ) (STREAMCONSTANT (fetch STREAMCONSTANT of (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT))) MP BP XI YI) (* ; "Assumes use of the L1metric") (RETURN (FIXR (COND ((fetch INFINITESLOPE? of (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (FABS (FDIFFERENCE X0 STREAMCONSTANT))) ((EQP STREAMSLOPE 0.0) (FABS (FDIFFERENCE Y0 STREAMCONSTANT))) (T (SETQ MP (FMINUS (FQUOTIENT 1.0 STREAMSLOPE))) (SETQ BP (FDIFFERENCE Y0 (FTIMES MP X0))) (SETQ XI (FQUOTIENT (FDIFFERENCE BP STREAMCONSTANT) (FDIFFERENCE STREAMSLOPE MP))) (SETQ YI (FPLUS (FTIMES MP XI) BP)) (L1METRIC STREAMPOSITION (create POSITION XCOORD _ XI YCOORD _ YI]) (DISTANCETOPOINT [LAMBDA (POINT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC (fetch (POINTDATA STREAMPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT)) STREAMPOSITION]) (DISTANCETOPOLYGON [LAMBDA (POLYGONDATA STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC STREAMPOSITION (for POINT in (fetch (POLYGONDATA STREAMPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of POLYGONDATA)) smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOTEXT [LAMBDA (TEXTOBJECT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC (fetch (TEXTDATA STREAMPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) STREAMPOSITION]) (DRAWCOMPOUNDOBJECT [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:25") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT]) (DRAWCURVEOBJECT [LAMBDA (CURVEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:49 by jop") (* ;; "Draw a series of connected lines in VIEWPORT. Style is the line width in pixels.") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) (POINTS (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA)) (STREAMPOINTS (for PT in POINTS collect (WORLDTOSTREAM PT VIEWPORT))) (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) (fetch YCOORD of (CAR STREAMPOINTS)) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'REPLACE STREAM COLOR DASHING)) (COND ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) (replace (CURVEDATA STREAMPOINTS) of OBJECTDATA with STREAMPOINTS]) (DRAWFILLEDRECTANGLEOBJECT [LAMBDA (FILLEDRECTANGLEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:49 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLEOBJECT)) (TEXTURE (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA)) (BORDERWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA))) STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT STREAMRIGHT STREAMTOP) (SETQ STREAMLEFT (WORLDTOSTREAMX (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA) VIEWPORT)) (SETQ STREAMBOTTOM (WORLDTOSTREAMY (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) VIEWPORT)) (SETQ STREAMWIDTH (DIFFERENCE (WORLDTOSTREAMX (fetch (FILLEDRECTANGLEDATA OBJECTRIGHT) of OBJECTDATA) VIEWPORT) STREAMLEFT)) (SETQ STREAMHEIGHT (DIFFERENCE (WORLDTOSTREAMY (fetch (FILLEDRECTANGLEDATA OBJECTTOP) of OBJECTDATA) VIEWPORT) STREAMBOTTOM)) (SETQ STREAMRIGHT (PLUS STREAMLEFT STREAMWIDTH)) (SETQ STREAMTOP (PLUS STREAMBOTTOM STREAMHEIGHT)) (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT 'TEXTURE 'PAINT TEXTURE) (MOVETO STREAMLEFT STREAMBOTTOM STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'REPLACE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'REPLACE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'REPLACE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'REPLACE STREAM) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA with STREAMLEFT) (replace (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA with STREAMBOTTOM) (replace (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA with STREAMWIDTH) (replace (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA with STREAMHEIGHT]) (DRAWGRAPHOBJECT [LAMBDA (GRAPHOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) (XUPPER (fetch (PLOT XUPPER) of PLOT)) (XLOWER (fetch (PLOT XLOWER) of PLOT)) (YUPPER (fetch (PLOT YUPPER) of PLOT)) (YLOWER (fetch (PLOT YLOWER) of PLOT)) (GRAPHFN (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA)) (NSAMPLES (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA)) (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) STREAMPOSITIONS) [SETQ STREAMPOSITIONS (NCONC1 (bind (INC _ (FQUOTIENT (FDIFFERENCE XUPPER XLOWER) (SUB1 NSAMPLES))) for I from 1 to (SUB1 NSAMPLES) as X from XLOWER by INC collect (CREATEPOSITION (WORLDTOSTREAMX X VIEWPORT) (WORLDTOSTREAMY (APPLY* GRAPHFN X) VIEWPORT))) (CREATEPOSITION (WORLDTOSTREAMX XUPPER VIEWPORT) (WORLDTOSTREAMY (APPLY* GRAPHFN XUPPER) VIEWPORT] (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) (fetch YCOORD of (CAR STREAMPOSITIONS)) STREAM) for PT in (CDR STREAMPOSITIONS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'REPLACE STREAM COLOR DASHING)) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA with STREAMPOSITIONS]) (DRAWLINEOBJECT [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (XUPPER (fetch (PLOT XUPPER) of PLOT)) (XLOWER (fetch (PLOT XLOWER) of PLOT)) (YUPPER (fetch (PLOT YUPPER) of PLOT)) (YLOWER (fetch (PLOT YLOWER) of PLOT)) (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) (INFINITESLOPE? (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA)) (SLOPE (fetch (LINEDATA SLOPE) of OBJECTDATA)) (CONSTANT (fetch (LINEDATA CONSTANT) of OBJECTDATA)) STREAMSLOPE STREAMCONSTANT STREAMPT1 STREAMPT2 X1 Y1 X2 Y2) (SETQ X1 (COND (INFINITESLOPE? CONSTANT) (T XLOWER))) [SETQ Y1 (COND (INFINITESLOPE? YLOWER) (T (FPLUS CONSTANT (FTIMES SLOPE X1] (SETQ X2 (COND (INFINITESLOPE? CONSTANT) (T XUPPER))) [SETQ Y2 (COND (INFINITESLOPE? YUPPER) (T (FPLUS CONSTANT (FTIMES SLOPE X2] [SETQ STREAMSLOPE (AND (NOT INFINITESLOPE?) (FTIMES SLOPE (FQUOTIENT (fetch (VIEWPORT WORLDTOSTREAMMY) of VIEWPORT) (fetch (VIEWPORT WORLDTOSTREAMMX) of VIEWPORT] [SETQ STREAMCONSTANT (COND (INFINITESLOPE? (WORLDTOSTREAMX CONSTANT VIEWPORT)) (T (FDIFFERENCE (WORLDTOSTREAMY CONSTANT VIEWPORT) (FTIMES STREAMSLOPE (fetch (VIEWPORT WORLDTOSTREAMAX) of VIEWPORT] (SETQ STREAMPT1 (CREATEPOSITION (WORLDTOSTREAMX X1 VIEWPORT) (WORLDTOSTREAMY Y1 VIEWPORT))) (SETQ STREAMPT2 (CREATEPOSITION (WORLDTOSTREAMX X2 VIEWPORT) (WORLDTOSTREAMY Y2 VIEWPORT))) (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'REPLACE STREAM COLOR DASHING) (COND ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) (COND (STREAMSLOPE (replace (LINEDATA STREAMSLOPE) of OBJECTDATA with STREAMSLOPE)) (T (replace (LINEDATA STREAMSLOPE) of OBJECTDATA with 0.0))) (replace (LINEDATA STREAMCONSTANT) of OBJECTDATA with STREAMCONSTANT) (replace (LINEDATA STREAMPT1) of OBJECTDATA with STREAMPT1) (replace (LINEDATA STREAMPT2) of OBJECTDATA with STREAMPT2]) (DRAWPOINTOBJECT [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (* ;; "Draw a glyph at POINTPOSITION. SYMBOL is the glyph to be drawn.") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (PT (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) (STREAMPT (WORLDTOSTREAM PT VIEWPORT))) (CLIPPED.PLOTAT STREAMSUBREGION STREAMPT SYMBOL STREAM) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (POINTDATA STREAMPOSITION) of OBJECTDATA with STREAMPT]) (DRAWPOLYGONOBJECT [LAMBDA (POLYGONOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (* ;; "Draws a polygon in VIEWPORT.") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) (POINTS (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA)) (STREAMPOINTS (for PT in POINTS collect (WORLDTOSTREAM PT VIEWPORT))) (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) (fetch YCOORD of START) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'REPLACE STREAM COLOR DASHING) finally (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of START) (fetch YCOORD of START) LINEWIDTH 'REPLACE STREAM COLOR DASHING)) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (POLYGONDATA STREAMPOINTS) of OBJECTDATA with STREAMPOINTS]) (DRAWTEXTOBJECT [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (PT (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA)) STREAMX STREAMY) (SETQ STREAMX (WORLDTOSTREAMX (fetch XCOORD of PT) VIEWPORT)) (SETQ STREAMY (WORLDTOSTREAMY (fetch YCOORD of PT) VIEWPORT)) (RESETLST (RESETSAVE (DSPFONT FONT STREAM) (LIST 'DSPFONT (DSPFONT NIL STREAM) STREAM)) (MOVETO STREAMX STREAMY STREAM) (CLIPPED.PRIN1 STREAMSUBREGION TEXT STREAM)) (COND ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) (replace (TEXTDATA STREAMPOSITION) of OBJECTDATA with (CREATEPOSITION STREAMX STREAMY]) (ERASECOMPOUNDOBJECT [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:26") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (ERASEPLOTOBJECT OBJECT PLOT]) (ERASECURVEOBJECT [LAMBDA (CURVEOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:51 by jop") (* ;; "Erase the CURVEOBJECT, using the cached stream coordinates") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) (STREAMPOINTS (fetch (CURVEDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) (fetch YCOORD of (CAR STREAMPOINTS)) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'ERASE STREAM COLOR]) (ERASEFILLEDRECTANGLEOBJECT [LAMBDA (FILLEDRECTANGLE VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) (TEXTURE (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA)) (BORDERWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA))) (STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) (STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) (STREAMWIDTH (fetch (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA)) (STREAMHEIGHT (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA)) (STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) (STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA))) (MOVETO STREAMLEFT STREAMBOTTOM STREAM) (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT 'TEXTURE 'INVERT TEXTURE) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'ERASE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'ERASE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'ERASE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'ERASE STREAM]) (ERASEGRAPHOBJECT [LAMBDA (GRAPHOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) (STREAMPOSITIONS (fetch (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA)) (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) (fetch YCOORD of (CAR STREAMPOSITIONS)) STREAM) for PT in (CDR STREAMPOSITIONS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'ERASE STREAM COLOR]) (ERASELINEOBJECT [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS (fetch (PLOT.STYLE LINEWIDTH) of STYLE) 2)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) (STREAMPT1 (fetch (LINEDATA STREAMPT1) of OBJECTDATA)) (STREAMPT2 (fetch (LINEDATA STREAMPT2) of OBJECTDATA))) (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'ERASE STREAM COLOR]) (ERASEPOINTOBJECT [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (* ;; "Erase POINT, using cached stream coordinates") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (STREAMPT (fetch (POINTDATA STREAMPOSITION) of OBJECTDATA))) (CLIPPED.PLOTAT STREAMSUBREGION STREAMPT SYMBOL STREAM 'ERASE]) (ERASEPOLYGONOBJECT [LAMBDA (POLYGONOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:52 by jop") (* ;; "Erase a POLYGONDATA") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) (STREAMPOINTS (fetch (POLYGONDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) (fetch YCOORD of START) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'ERASE STREAM COLOR) finally (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of START) (fetch YCOORD of START) LINEWIDTH 'ERASE STREAM COLOR]) (ERASETEXTOBJECT [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:52 by jop") (* ;; "ERASE the TEXTDATA") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (STREAMPOSITION (fetch (TEXTDATA STREAMPOSITION) of OBJECTDATA)) (STREAMX (fetch XCOORD of STREAMPOSITION)) (STREAMY (fetch YCOORD of STREAMPOSITION)) BLANCREGION) (RESETLST (RESETSAVE (DSPFONT FONT STREAM) (LIST 'DSPFONT (DSPFONT NIL STREAM) STREAM)) (MOVETO STREAMX STREAMY STREAM) (SETQ BLANCREGION (STRINGREGION TEXT STREAM)) (with REGION BLANCREGION (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE]) (EXTENTOFCOMPOUND [LAMBDA (COMPOUNDOBJECT) (* ; "Edited 1-Jun-92 16:46 by jds") (bind (CMINX _ MAX.FLOAT) (CMAXX _ MIN.FLOAT) (CMINY _ MAX.FLOAT) (CMAXY _ MIN.FLOAT) PEXTENT for PART in (fetch (COMPOUNDDATA COMPONENTS) of (fetch OBJECTDATA of COMPOUNDOBJECT)) declare (TYPE FLOATING CMINX CMAXX CMINY CMAXY) do (SETQ PEXTENT (EXTENTOFPLOTOBJECT PART)) (if (LESSP (fetch (EXTENT MINX) of PEXTENT) CMINX) then (SETQ CMINX (fetch (EXTENT MINX) of PEXTENT))) (if (GREATERP (fetch (EXTENT MAXX) of PEXTENT) CMAXX) then (SETQ CMAXX (fetch (EXTENT MAXX) of PEXTENT))) (if (LESSP (fetch (EXTENT MINY) of PEXTENT) CMINY) then (SETQ CMINY (fetch (EXTENT MINY) of PEXTENT))) (if (GREATERP (fetch (EXTENT MAXY) of PEXTENT) CMAXY) then (SETQ CMAXY (fetch (EXTENT MAXY) of PEXTENT))) finally (RETURN (create EXTENT MINX _ CMINX MAXX _ CMAXX MINY _ CMINY MAXY _ CMAXY]) (EXTENTOFCURVE [LAMBDA (CURVEOBJECT) (* ; "Edited 1-Jun-92 16:46 by jds") (bind (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) X Y for POSITION in (fetch (CURVEDATA CURVEPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT )) declare (TYPE FLOATING MINX MAXX MINY MAXY X Y) do (SETQ X (fetch XCOORD of POSITION)) (SETQ Y (fetch YCOORD of POSITION)) (COND ((FLESSP X MINX) (SETQ MINX X))) (COND ((FGREATERP X MAXX) (SETQ MAXX X))) (COND ((FLESSP Y MINY) (SETQ MINY Y))) (COND ((FGREATERP Y MAXY) (SETQ MAXY Y))) finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY]) (EXTENTOFFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLE) (* ; "Edited 1-Jun-92 16:46 by jds") (create EXTENT MINX _ (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) MAXX _ (fetch (FILLEDRECTANGLEDATA OBJECTRIGHT) of (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) MINY _ (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) MAXY _ (fetch (FILLEDRECTANGLEDATA OBJECTTOP) of (fetch (PLOTOBJECT OBJECTDATA ) of FILLEDRECTANGLE ]) (EXTENTOFGRAPH [LAMBDA (GRAPHOBJECT) (* ; "Edited 5-May-87 17:53 by jop") (create EXTENT MINX _ MAX.FLOAT MAXX _ MIN.FLOAT MINY _ MAX.FLOAT MAXY _ MIN.FLOAT]) (EXTENTOFLINE [LAMBDA (LINEOBJECT) (* jop%: " 5-Mar-85 14:03") (create EXTENT MINX _ MAX.FLOAT MAXX _ MIN.FLOAT MINY _ MAX.FLOAT MAXY _ MIN.FLOAT]) (EXTENTOFPOINT [LAMBDA (POINT) (* ; "Edited 1-Jun-92 16:47 by jds") (PROG [(POSITION (fetch (POINTDATA POINTPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT] (RETURN (create EXTENT MINX _ (fetch XCOORD of POSITION) MAXX _ (fetch XCOORD of POSITION) MINY _ (fetch YCOORD of POSITION) MAXY _ (fetch YCOORD of POSITION]) (EXTENTOFPOLYGON [LAMBDA (POLYGONOBJECT) (* ; "Edited 1-Jun-92 16:47 by jds") (bind (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) X Y for POSITION in (fetch POLYGONPOINTS of (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) declare (TYPE FLOATING MINX MAXX MINY MAXY X Y) do (SETQ X (fetch XCOORD of POSITION)) (SETQ Y (fetch YCOORD of POSITION)) (if (FLESSP X MINX) then (SETQ MINX X)) (if (FGREATERP X MAXX) then (SETQ MAXX X)) (if (FLESSP Y MINY) then (SETQ MINY Y)) (if (FGREATERP Y MAXY) then (SETQ MAXY Y)) finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY]) (EXTENTOFTEXT [LAMBDA (TEXTOBJECT) (* ; "Edited 1-Jun-92 16:47 by jds") (PROG [(POSITION (fetch TEXTPOSITION of (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT ] (RETURN (create EXTENT MINX _ (fetch XCOORD of POSITION) MAXX _ (fetch XCOORD of POSITION) MINY _ (fetch YCOORD of POSITION) MAXY _ (fetch YCOORD of POSITION]) (GETCOMPOUND [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:53 by jop") (* ;; "GETFN for COMPOUND objects") (create COMPOUNDDATA COMPOUNDTYPE _ (LISTGET PROPLST 'COMPOUNDTYPE) COMPONENTS _ (LISTGET PROPLST 'COMPONENTS]) (GETCURVE [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "GETFN for CURVE objects") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create CURVEDATA CURVEPOINTS _ (LISTGET PROPLST 'CURVEPOINTS) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETFILLEDRECTANGLE [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "GETFN for FILLEDRECTANGLE objects") (create FILLEDRECTANGLEDATA OBJECTLEFT _ (LISTGET PROPLST 'OBJECTLEFT) OBJECTBOTTOM _ (LISTGET PROPLST 'OBJECTBOTTOM) OBJECTWIDTH _ (LISTGET PROPLST 'OBJECTWIDTH) OBJECTHEIGHT _ (LISTGET PROPLST 'OBJECTHEIGHT) BORDERWIDTH _ (LISTGET PROPLST 'BORDERWIDTH) TEXTURE _ (LISTGET PROPLST 'TEXTURE]) (GETGENERIC [LAMBDA (EXPR) (* jop%: "27-Aug-85 17:11") EXPR]) (GETGRAPH [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create GRAPHDATA GRAPHFN _ (LISTGET PROPLST 'GRAPHFN) NSAMPLES _ (LISTGET PROPLST 'NSAMPLES) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETLINE [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "GETFN for LINE objects") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create LINEDATA INFINITESLOPE? _ (LISTGET PROPLST 'INFINITESLOPE?) SLOPE _ (LISTGET PROPLST 'SLOPE) CONSTANT _ (LISTGET PROPLST 'CONSTANT) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETPOINT [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "Putfn for POINT objects") (create POINTDATA POINTPOSITION _ (LISTGET PROPLST 'POINTPOSITION) SYMBOL _ (LET [(SYMBOL (LISTGET PROPLST 'SYMBOL] (if (LITATOM SYMBOL) then (EVAL SYMBOL) else SYMBOL]) (GETPOLYGON [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:55 by jop") (* ;; "GETFN for POLYGON objects") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create POLYGONDATA POLYGONPOINTS _ (LISTGET PROPLST 'POLYGONPOINTS) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETTEXT [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:55 by jop") (* ;; "GETFN for TEXT objects") (create TEXTDATA TEXTPOSITION _ (LISTGET PROPLST 'TEXTPOSITION) TEXT _ (LISTGET PROPLST 'TEXT) FONT _ (LISTGET PROPLST 'FONT]) (HIGHLIGHTCOMPOUND [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:26") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (HIGHLIGHTPLOTOBJECT OBJECT PLOT]) (HIGHLIGHTCURVE [LAMBDA (CURVEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (* ;; "Highlight the CURVEOBJECT, by redrawing in invert mode with fatter lines") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) (STREAMPOINTS (fetch (CURVEDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) (fetch YCOORD of (CAR STREAMPOINTS)) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLE VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) (BORDERWIDTH (IPLUS 2 (OR (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) 1))) (STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) (STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) (STREAMWIDTH (fetch (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA)) (STREAMHEIGHT (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA)) (STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) (STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA))) (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT 'TEXTURE 'INVERT BLACKSHADE) (MOVETO STREAMLEFT STREAMBOTTOM STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'INVERT STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'INVERT STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'INVERT STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'INVERT STREAM]) (HIGHLIGHTGRAPH [LAMBDA (GRAPHOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) (STREAMPOSITIONS (fetch (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA)) (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) (fetch YCOORD of (CAR STREAMPOSITIONS)) STREAM) for PT in (CDR STREAMPOSITIONS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTLINE [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS (fetch (PLOT.STYLE LINEWIDTH) of STYLE) 2)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) (STREAMPT1 (fetch (LINEDATA STREAMPT1) of OBJECTDATA)) (STREAMPT2 (fetch (LINEDATA STREAMPT2) of OBJECTDATA))) (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTPOINT [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "Highlight POINT") (LET* [(STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (STREAMPT (fetch (POINTDATA STREAMPOSITION) of OBJECTDATA)) (WIDTHGLYPH (BITMAPWIDTH SYMBOL)) (HEIGHTGLYPH (BITMAPHEIGHT SYMBOL)) (OFFSETX (IDIFFERENCE (fetch XCOORD of STREAMPT) (IQUOTIENT WIDTHGLYPH 2))) (OFFSETY (IDIFFERENCE (fetch YCOORD of STREAMPT) (IQUOTIENT HEIGHTGLYPH 2] (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM OFFSETX OFFSETY WIDTHGLYPH HEIGHTGLYPH 'TEXTURE 'INVERT BLACKSHADE]) (HIGHLIGHTPOLYGON [LAMBDA (POLYGONOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "Highlight a Polygon") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) (STREAMPOINTS (fetch (POLYGONDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) (fetch YCOORD of START) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'INVERT STREAM COLOR) finally (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of START) (fetch YCOORD of START) LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTTEXT [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "HIGHLIGHT the TEXTDATA") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (STREAMPOSITION (fetch (TEXTDATA STREAMPOSITION) of OBJECTDATA)) (STREAMX (fetch XCOORD of STREAMPOSITION)) (STREAMY (fetch YCOORD of STREAMPOSITION)) BLANCREGION) (RESETLST (RESETSAVE (DSPFONT FONT STREAM) (LIST 'DSPFONT (DSPFONT NIL STREAM) STREAM)) (MOVETO STREAMX STREAMY STREAM) (SETQ BLANCREGION (STRINGREGION TEXT STREAM)) (with REGION BLANCREGION (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE 'INVERT BLACKSHADE]) (LABELGENERIC [LAMBDA (OBJECT PLOT) (* ; "Edited 1-Jun-92 16:49 by jds") (* ;; "Generic label routine. Intended for interactive use only") (PROG ((LABEL (fetch OBJECTLABEL of OBJECT)) (VIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) LABELPOSITION) (COND (TEXTOBJECT (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT)) (T (PLOTPROMPT (CONCAT "SELECT A POSITION FOR LABEL " LABEL) PLOT) (SETQ LABELPOSITION (STREAMTOWORLD (GETPOSITION (fetch (PLOT PLOTWINDOW) of PLOT)) VIEWPORT)) (SETQ TEXTOBJECT (CREATETEXT LABELPOSITION LABEL NIL SMALLPLOTFONT)) (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) (PLOTOBJECTPROP OBJECT 'LABEL TEXTOBJECT]) (LABELPOINT [LAMBDA (POINT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "Label a POINT") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (VIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (LABEL (fetch (PLOTOBJECT OBJECTLABEL) of POINT)) (TEXTOBJECT (PLOTOBJECTPROP POINT 'LABEL)) SYMBOL LABELPOSITION) (SETQ LABELPOSITION (create POSITION using (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) ) (SETQ SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (* ;  "Displace Label to right of point object") (if TEXTOBJECT then (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) else [replace XCOORD of LABELPOSITION with (PLUS (fetch XCOORD of LABELPOSITION) (TIMES 2 (STREAMTOWORLDXLENGTH (BITMAPWIDTH SYMBOL) VIEWPORT] (SETQ TEXTOBJECT (CREATETEXT LABELPOSITION LABEL NIL SMALLPLOTFONT)) (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) (* ;  "CACHE LABEL ON PROP LIST OF OBJECT") (PLOTOBJECTPROP POINT 'LABEL TEXTOBJECT]) (LABELTEXT [LAMBDA (TEXTOBJECT PLOT) (* jop%: "20-Feb-86 17:56") (PLOTPROMPT "Cannot label text" PLOT]) (LOWLIGHTCOMPOUND [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:27") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (LOWLIGHTPLOTOBJECT OBJECT PLOT]) (MOVECOMPOUND [LAMBDA (COMPOUNDOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT)) do (MOVEPLOTOBJECT OBJECT DX DY PLOT]) (MOVECURVE [LAMBDA (CURVEOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG [(POINTS (fetch (CURVEDATA CURVEPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT] (for POINT in POINTS do (replace XCOORD of POINT with (PLUS DX (fetch XCOORD of POINT))) (replace YCOORD of POINT with (PLUS DY (fetch YCOORD of POINT]) (MOVEFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLEOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLEOBJECT))) (replace (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA with (PLUS DX (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA))) (replace (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA with (PLUS DY (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA]) (MOVELINE [LAMBDA (LINEOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT))) (replace (LINEDATA CONSTANT) of OBJECTDATA with (if (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) then (PLUS DX (fetch (LINEDATA CONSTANT) of OBJECTDATA)) else (DIFFERENCE (PLUS (fetch (LINEDATA CONSTANT) of OBJECTDATA) (TIMES DX (fetch (LINEDATA SLOPE) of OBJECTDATA)) ) DY]) (MOVEPOINT [LAMBDA (POINT DX DY PLOT) (* jop%: "24-Feb-86 14:43") (PROG [(POSITION (fetch (POINTDATA POINTPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT] (replace XCOORD of POSITION with (PLUS DX (fetch XCOORD of POSITION))) (replace YCOORD of POSITION with (PLUS DY (fetch YCOORD of POSITION]) (MOVEPOLYGON [LAMBDA (POLYGONOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG [(POINTS (fetch POLYGONPOINTS of (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT ] (for POINT in POINTS do (replace XCOORD of POINT with (PLUS DX (fetch XCOORD of POINT))) (replace YCOORD of POINT with (PLUS DY (fetch YCOORD of POINT]) (MOVETEXT [LAMBDA (TEXTOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG [(POSITION (fetch TEXTPOSITION of (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT ] (replace XCOORD of POSITION with (PLUS DX (fetch XCOORD of POSITION))) (replace YCOORD of POSITION with (PLUS DY (fetch YCOORD of POSITION]) (PLOTCOMPOUND [LAMBDA ARGS (* ; "Edited 5-May-87 17:57 by jop") (* ;; "ADD A COMPOUND OBJECT with an unknown number of COMPONENTS. First arg must be a PLOT. Second arg must be the compound object type. Next are the Nospread COMPONENTS, then the optional LABEL, MENU, and NODRAWFLG") (if (LESSP ARGS 3) then (HELP "Must have at least 3 args. Plot, compound type, and one component")) (PROG ((PLOT (ARG ARGS 1)) (COMPOUNDTYPE (ARG ARGS 2)) COMPONENTS STARTRESTARGS) (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (SETQ COMPONENTS (for I from 3 to ARGS while (type? PLOTOBJECT (ARG ARGS I)) collect (ARG ARGS I))) (SETQ STARTRESTARGS (PLUS 3 (LENGTH COMPONENTS))) (RETURN (ADDPLOTOBJECT [CREATECOMPOUND COMPOUNDTYPE COMPONENTS (if (GEQ ARGS STARTRESTARGS) then (ARG ARGS STARTRESTARGS)) (if (GEQ ARGS (PLUS 1 STARTRESTARGS)) then (ARG ARGS (PLUS 1 STARTRESTARGS] PLOT (if (GEQ ARGS (PLUS 2 STARTRESTARGS)) then (ARG ARGS (PLUS 2 STARTRESTARGS]) (PLOTCURVE [LAMBDA (PLOT POSITIONS LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:57 by jop") (* ;; "User Entry Point. Draw a piecewise linear curve in a Plotting WINDOW. Style is either the line width to use or a list (width dashing color) or an instance of PLOT.STYLE. POSITIONS is a list of positions to be contected.") (COND ((NOT (type? PLOT PLOT)) (HELP "NOT a PLOT " PLOT))) (ADDPLOTOBJECT (CREATECURVE POSITIONS LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTFILLEDRECTANGLE [LAMBDA (PLOT LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU NODRAWFLG) (* ; "Edited 5-May-87 17:57 by jop") (* ;;  "User Entry Point. Draw a FILLEDRECTANGLE in a Plotting WINDOW. Style is the line width to use.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (if (NULL TEXTURE) then (SETQ TEXTURE SHADE3)) (ADDPLOTOBJECT (CREATEFILLEDRECTANGLE LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU) PLOT NODRAWFLG]) (PLOTGRAPH [LAMBDA (PLOT GRAPHFN NSAMPLES LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (ADDPLOTOBJECT (CREATEGRAPH GRAPHFN NSAMPLES LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTLINE [LAMBDA (PLOT SLOPE CONSTANT LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point.") (COND ((NOT (type? PLOT PLOT)) (HELP "NOT a PLOT " PLOT))) (ADDPLOTOBJECT (CREATELINE SLOPE CONSTANT LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTPOINT [LAMBDA (PLOT POSITION LABEL SYMBOL MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User entry point. Add a point to the plotwindow WINDOW, at world position POSITION, with Label LABEL and plotting symbol SYMBOL") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (ADDPLOTOBJECT (CREATEPOINT POSITION LABEL SYMBOL MENU) PLOT NODRAWFLG]) (PLOTPOINTS [LAMBDA (PLOT POSITIONS LABELS SYMBOL MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point. Draw the POINTs at POSITIONS in a Plotting WINDOW. Symbol is a LITATOM which Describes the glyph to use.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (PROG (EXTENT NEWSCALES OBJECTS) [SETQ EXTENT (bind (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) for PT in POSITIONS do (if (LESSP (fetch XCOORD of PT) MINX) then (SETQ MINX (fetch XCOORD of PT))) (if (GREATERP (fetch XCOORD of PT) MAXX) then (SETQ MAXX (fetch XCOORD of PT))) (if (LESSP (fetch YCOORD of PT) MINY) then (SETQ MINY (fetch YCOORD of PT))) (if (GREATERP (fetch YCOORD of PT) MAXY) then (SETQ MAXY (fetch YCOORD of PT))) finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY] (ADJUSTSCALE? EXTENT PLOT) (* ;  "Scale up the plot so that each ADDOBJECT need not rescale") [SETQ OBJECTS (bind (LABEL _ LABELS) for POSITION in POSITIONS collect (PROG1 (CREATEPOINT POSITION (CAR LABEL) SYMBOL MENU) (SETQ LABEL (CDR LABEL] (* ; "Do surgury on the display list") (replace (PLOT PLOTOBJECTS) of PLOT with (APPEND OBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT))) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT)) (RETURN OBJECTS]) (PLOTPOLYGON [LAMBDA (PLOT POSITIONS LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point. Draw a POLYGON in a Plotting WINDOW. Style is the line width to use. POSITIONS is a list of positions to be contected.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (ADDPLOTOBJECT (CREATEPOLYGON POSITIONS LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTTEXT [LAMBDA (PLOT POSITION TEXT LABEL FONT MENU NODRAWFLG) (* edited%: "27-Mar-86 21:22") (COND ((NOT (type? PLOT PLOT)) (HELP "NOT A PLOT " PLOT))) (COND ((NULL FONT) (SETQ FONT SMALLPLOTFONT))) (ADDPLOTOBJECT (CREATETEXT POSITION TEXT LABEL FONT MENU) PLOT NODRAWFLG]) (PUTCOMPOUND [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "PUTFN for COMPOUND objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (PRINTOUT STREAM "(" %,) (PRINTOUT STREAM "COMPOUNDTYPE" %, |.P2| (fetch (COMPOUNDDATA COMPOUNDTYPE) of OBJECTDATA) %,) (PRINTOUT STREAM "COMPONENTS (" %,) (* ;  "THIS ASSUMES APPROPRIATE HPRINT MACROS") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of OBJECTDATA) do (HPRINT OBJECT STREAM T T)) (PRINTOUT STREAM "))"]) (PUTCURVE [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "Putfn for CURVE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "CURVEPOINTS" %, |.P2| (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA ) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) %, ")"]) (PUTFILLEDRECTANGLE [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "PUTFN for FILLEDRECTANGLE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (PRINTOUT STREAM "(" %,) (PRINTOUT STREAM "OBJECTLEFT" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA ) %,) (PRINTOUT STREAM "OBJECTBOTTOM" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) %,) (PRINTOUT STREAM "OBJECTWIDTH" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTWIDTH) of OBJECTDATA) %,) (PRINTOUT STREAM "OBJECTHEIGHT" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of OBJECTDATA) %,) (PRINTOUT STREAM "BORDERWIDTH" %, |.P2| (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) %,) (PRINTOUT STREAM "TEXTURE" %, |.P2| (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA) %,) (PRINTOUT STREAM ")"]) (PUTGENERIC [LAMBDA (OBJECT PLOT STREAM) (* ; "Edited 1-Jun-92 16:52 by jds") (HPRINT (fetch (PLOTOBJECT OBJECTDATA) of OBJECT) STREAM NIL T]) (PUTGRAPH [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "Putfn for CURVE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "GRAPHFN" %, |.P2| (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA) %, "NSAMPLES" %, |.P2| (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) %, ")"]) (PUTLINE [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "Putfn for LINE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "INFINITESLOPE?" %, |.P2| (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) %, "SLOPE" %, |.P2| (fetch (LINEDATA SLOPE) of OBJECTDATA) %, "CONSTANT" %, |.P2| (fetch (LINEDATA CONSTANT) of OBJECTDATA) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) ")"]) (PUTPOINT [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") (* ;; "Putfn for POINT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) SYMBOL LAB) (SETQ SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (SETQ LAB (if (EQ SYMBOL STAR) then 'STAR elseif (EQ SYMBOL CROSS) then 'CROSS elseif (EQ SYMBOL CIRCLE) then 'CIRCLE)) (PRINTOUT STREAM "(" %, "POINTPOSITION" %, |.P2| (fetch (POINTDATA POINTPOSITION) of OBJECTDATA) %, "SYMBOL" %,) (if LAB then (PRINTOUT STREAM |.P2| LAB %,) else (HPRINT SYMBOL STREAM T T)) (PRINTOUT STREAM ")"]) (PUTPOLYGON [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") (* ;; "Putfn for POLYGON objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "POLYGONPOINTS" %, |.P2| (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) %, ")"]) (PUTTEXT [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") (* ;; "Putfn for TEXT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) FONT) (SETQ FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "TEXTPOSITION" %, |.P2| (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA ) %, "TEXT" %, |.P2| (fetch (TEXTDATA TEXT) of OBJECTDATA) %, "FONT" %,) (* ; "Assumes FONT has an HPRINTMACRO") (HPRINT FONT STREAM T T) (PRINTOUT STREAM ")"]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS L1METRIC MACRO [OPENLAMBDA (POINT1 POINT2) (* jop%: "17-Jan-85 15:27") (* ;; "Computes the L 1 metric between POINT1 and POINT2") (PLUS (IABS (DIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2))) (IABS (DIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2]) (PUTPROPS L2METRIC MACRO [OPENLAMBDA (POINT1 POINT2 PLOT) (* jop%: "17-Jan-85 15:27") (* ;; "Computes the L 2 metric between POINT1 and POINT2") (FPLUS (FTIMES (FDIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2)) (FDIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2))) (FTIMES (FTIMES (fetch NORMCONSTANT of PLOT) (FDIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2) )) (FTIMES (fetch NORMCONSTANT of PLOT) (FDIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2]) ) (RPAQQ CIRCLE #*(5 5)G@@@HH@@HH@@HH@@G@@@) (RPAQQ CROSS #*(5 5)B@@@B@@@OH@@B@@@B@@@) (RPAQQ DASH (5)) (RPAQQ DOT (1 5)) (RPAQQ DOTDASH (5 5 1 5)) (RPAQQ SHADE1 64) (RPAQQ SHADE2 576) (RPAQQ SHADE3 4680) (RPAQQ SHADE4 37449) (RPAQQ SHADE5 55899) (RPAQQ SHADE6 31710) (RPAQQ SHADE7 64479) (RPAQQ SHADE8 65023) (RPAQQ STAR #*(5 5)JH@@G@@@OH@@G@@@JH@@) (DECLARE%: EVAL@COMPILE (DATATYPE COMPOUNDDATA (COMPOUNDTYPE COMPONENTS)) (DATATYPE CURVEDATA (CURVEPOINTS STREAMPOINTS STYLE)) (DATATYPE FILLEDRECTANGLEDATA ((OBJECTLEFT FLOATING) (OBJECTBOTTOM FLOATING) (OBJECTWIDTH FLOATING) (OBJECTHEIGHT FLOATING) STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT BORDERWIDTH TEXTURE) BORDERWIDTH _ 1 [ACCESSFNS ((OBJECTRIGHT (PLUS (fetch ( FILLEDRECTANGLEDATA OBJECTLEFT) of DATUM) (fetch ( FILLEDRECTANGLEDATA OBJECTWIDTH) of DATUM))) (OBJECTTOP (PLUS (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of DATUM) (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of DATUM))) (STREAMRIGHT (PLUS (fetch ( FILLEDRECTANGLEDATA STREAMLEFT) of DATUM) (fetch ( FILLEDRECTANGLEDATA STREAMWIDTH) of DATUM))) (STREAMTOP (PLUS (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of DATUM) (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of DATUM]) (DATATYPE GRAPHDATA (GRAPHFN NSAMPLES STYLE STREAMPOSITIONS)) (DATATYPE LINEDATA (STYLE INFINITESLOPE? (SLOPE FLOATING) (CONSTANT FLOATING) (STREAMSLOPE FLOATING) (STREAMCONSTANT FLOATING) STREAMPT1 STREAMPT2) STYLE _ 1) (DATATYPE PLOT.STYLE (LINEWIDTH DASHING COLOR) LINEWIDTH _ 1) (DATATYPE POINTDATA (POINTPOSITION STREAMPOSITION SYMBOL) SYMBOL _ STAR) (DATATYPE POLYGONDATA (POLYGONPOINTS STREAMPOINTS STYLE) STYLE _ 1) (DATATYPE TEXTDATA (TEXTPOSITION STREAMPOSITION TEXT FONT) FONT _ SMALLPLOTFONT) ) (/DECLAREDATATYPE 'COMPOUNDDATA '(POINTER POINTER) '((COMPOUNDDATA 0 POINTER) (COMPOUNDDATA 2 POINTER)) '4) (/DECLAREDATATYPE 'CURVEDATA '(POINTER POINTER POINTER) '((CURVEDATA 0 POINTER) (CURVEDATA 2 POINTER) (CURVEDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'FILLEDRECTANGLEDATA '(FLOATP FLOATP FLOATP FLOATP POINTER POINTER POINTER POINTER POINTER POINTER) '((FILLEDRECTANGLEDATA 0 FLOATP) (FILLEDRECTANGLEDATA 2 FLOATP) (FILLEDRECTANGLEDATA 4 FLOATP) (FILLEDRECTANGLEDATA 6 FLOATP) (FILLEDRECTANGLEDATA 8 POINTER) (FILLEDRECTANGLEDATA 10 POINTER) (FILLEDRECTANGLEDATA 12 POINTER) (FILLEDRECTANGLEDATA 14 POINTER) (FILLEDRECTANGLEDATA 16 POINTER) (FILLEDRECTANGLEDATA 18 POINTER)) '20) (/DECLAREDATATYPE 'GRAPHDATA '(POINTER POINTER POINTER POINTER) '((GRAPHDATA 0 POINTER) (GRAPHDATA 2 POINTER) (GRAPHDATA 4 POINTER) (GRAPHDATA 6 POINTER)) '8) (/DECLAREDATATYPE 'LINEDATA '(POINTER POINTER FLOATP FLOATP FLOATP FLOATP POINTER POINTER) '((LINEDATA 0 POINTER) (LINEDATA 2 POINTER) (LINEDATA 4 FLOATP) (LINEDATA 6 FLOATP) (LINEDATA 8 FLOATP) (LINEDATA 10 FLOATP) (LINEDATA 12 POINTER) (LINEDATA 14 POINTER)) '16) (/DECLAREDATATYPE 'PLOT.STYLE '(POINTER POINTER POINTER) '((PLOT.STYLE 0 POINTER) (PLOT.STYLE 2 POINTER) (PLOT.STYLE 4 POINTER)) '6) (/DECLAREDATATYPE 'POINTDATA '(POINTER POINTER POINTER) '((POINTDATA 0 POINTER) (POINTDATA 2 POINTER) (POINTDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'POLYGONDATA '(POINTER POINTER POINTER) '((POLYGONDATA 0 POINTER) (POLYGONDATA 2 POINTER) (POLYGONDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'TEXTDATA '(POINTER POINTER POINTER POINTER) '((TEXTDATA 0 POINTER) (TEXTDATA 2 POINTER) (TEXTDATA 4 POINTER) (TEXTDATA 6 POINTER)) '8) (PUTPROPS PLOTCOMPOUND ARGNAMES (NIL (PLOT COMPOUNDTYPE COMPONENT1 |...| LABEL MENU NODRAWFLG ) . COMPOUNDARGS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PLOTCOMPOUND) ) (PUTPROPS PLOTOBJECTS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3192 93498 (COPYCOMPOUND 3202 . 3810) (COPYCURVE 3812 . 4306) (COPYFILLEDRECTANGLE 4308 . 5251) (COPYGENERIC 5253 . 5475) (COPYGRAPHOBJECT 5477 . 5987) (COPYLINE 5989 . 6640) (COPYPOINT 6642 . 7133) (COPYPOLYGON 7135 . 7643) (COPYTEXT 7645 . 8213) (CREATECOMPOUND 8215 . 8779) ( CREATECURVE 8781 . 10109) (CREATEFILLEDRECTANGLE 10111 . 10807) (CREATEGRAPH 10809 . 12202) ( CREATELINE 12204 . 13659) (CREATEPOINT 13661 . 14135) (CREATEPOLYGON 14137 . 15494) (CREATETEXT 15496 . 15862) (DISTANCETOCOMPOUND 15864 . 16616) (DISTANCETOCURVE 16618 . 17085) ( DISTANCETOFILLEDRECTANGLE 17087 . 21005) (DISTANCETOGRAPH 21007 . 21479) (DISTANCETOLINE 21481 . 23257 ) (DISTANCETOPOINT 23259 . 23581) (DISTANCETOPOLYGON 23583 . 24056) (DISTANCETOTEXT 24058 . 24382) ( DRAWCOMPOUNDOBJECT 24384 . 24910) (DRAWCURVEOBJECT 24912 . 26547) (DRAWFILLEDRECTANGLEOBJECT 26549 . 29377) (DRAWGRAPHOBJECT 29379 . 31949) (DRAWLINEOBJECT 31951 . 35386) (DRAWPOINTOBJECT 35388 . 36325) (DRAWPOLYGONOBJECT 36327 . 38423) (DRAWTEXTOBJECT 38425 . 39751) (ERASECOMPOUNDOBJECT 39753 . 40196) ( ERASECURVEOBJECT 40198 . 41371) (ERASEFILLEDRECTANGLEOBJECT 41373 . 43088) (ERASEGRAPHOBJECT 43090 . 44185) (ERASELINEOBJECT 44187 . 45036) (ERASEPOINTOBJECT 45038 . 45698) (ERASEPOLYGONOBJECT 45700 . 47297) (ERASETEXTOBJECT 47299 . 48527) (EXTENTOFCOMPOUND 48529 . 50047) (EXTENTOFCURVE 50049 . 52434) (EXTENTOFFILLEDRECTANGLE 52436 . 53844) (EXTENTOFGRAPH 53846 . 54109) (EXTENTOFLINE 54111 . 54362) ( EXTENTOFPOINT 54364 . 54973) (EXTENTOFPOLYGON 54975 . 56852) (EXTENTOFTEXT 56854 . 57538) (GETCOMPOUND 57540 . 57867) (GETCURVE 57869 . 58459) (GETFILLEDRECTANGLE 58461 . 59027) (GETGENERIC 59029 . 59152) (GETGRAPH 59154 . 59742) (GETLINE 59744 . 60459) (GETPOINT 60461 . 60933) (GETPOLYGON 60935 . 61535) (GETTEXT 61537 . 61882) (HIGHLIGHTCOMPOUND 61884 . 62329) (HIGHLIGHTCURVE 62331 . 63517) ( HIGHLIGHTFILLEDRECTANGLE 63519 . 65151) (HIGHLIGHTGRAPH 65153 . 66247) (HIGHLIGHTLINE 66249 . 67097) ( HIGHLIGHTPOINT 67099 . 68152) (HIGHLIGHTPOLYGON 68154 . 69755) (HIGHLIGHTTEXT 69757 . 71006) ( LABELGENERIC 71008 . 72036) (LABELPOINT 72038 . 73693) (LABELTEXT 73695 . 73849) (LOWLIGHTCOMPOUND 73851 . 74294) (MOVECOMPOUND 74296 . 74760) (MOVECURVE 74762 . 75416) (MOVEFILLEDRECTANGLE 75418 . 75978) (MOVELINE 75980 . 76814) (MOVEPOINT 76816 . 77242) (MOVEPOLYGON 77244 . 77976) (MOVETEXT 77978 . 78553) (PLOTCOMPOUND 78555 . 80040) (PLOTCURVE 80042 . 80595) (PLOTFILLEDRECTANGLE 80597 . 81233) ( PLOTGRAPH 81235 . 81592) (PLOTLINE 81594 . 81945) (PLOTPOINT 81947 . 82408) (PLOTPOINTS 82410 . 84826) (PLOTPOLYGON 84828 . 85304) (PLOTTEXT 85306 . 85661) (PUTCOMPOUND 85663 . 86442) (PUTCURVE 86444 . 87260) (PUTFILLEDRECTANGLE 87262 . 88775) (PUTGENERIC 88777 . 88983) (PUTGRAPH 88985 . 89819) (PUTLINE 89821 . 90808) (PUTPOINT 90810 . 91801) (PUTPOLYGON 91803 . 92628) (PUTTEXT 92630 . 93496))))) STOP \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS.TEDIT b/lispusers/PLOTOBJECTS.TEDIT new file mode 100644 index 00000000..f08e12f8 --- /dev/null +++ b/lispusers/PLOTOBJECTS.TEDIT @@ -0,0 +1,145 @@ +enˇvĹos PLOTOBJECTS 2 4 1 PLOT OBJECTS 1 4 By: Jan Pedersen (pedersen.PA @ Xerox.com) Uses: PLOT and TWODGRAPHICS Plot objects are the primitive quantities of the PLOT module. A plot object is abstracted as an instance of datatype PLOTOBJECT. A point plot object is an instance of PLOTOBJECT whose data component describes a point. That is, a point plot object is a subtype of PLOTOBJECT; all plot objects satisfy (type? PLOTOBJECT FOO), but only a point plot object satisfies in addition (PLOTOBJECTSUBTYPE? POINT FOO). A PLOTOBJECT is both a datatype and a collection of functions that implements a set of generic operations on that plot object. A plot object must know how to draw itself, erase itself, highlight itself, etc. The PLOT module then deals only with generic operations, and allows the plot objects to implement them as is appropriate. PLOTOBJECT [Datatype] OBJECTFNS [Field] Must be an instance of PLOTFNS OBJECTSUBTYPE [Field] Describes the plot objects subtype OBJECTUSERDATA [Field] Space for a propery list OBJECTMENU [Field] The object's MENU OBJECTLABEL [Field] Something to print OBJECTDATA [Field] Space for a datatype that describes the subtype of this PLOTOBJECT The field OBJECTFNS must be an instance of PLOTFNS, essentially a vector of functions which implements the generic operations. PLOTFNS [Datatype] DRAWFN [Field] Implements the DRAWOBJECT generic operation ERASEFN [Field] etc. HIGHLIGHTFN [Field] LOWLIGHTFN [Field] LABELFN [Field] MOVEFN [Field] EXTENTFN [Field] DISTANCEFN [Field] COPYFN [Field] PUTFN [Field] GETFN [Field] The generic operations are: (DRAWPLOTOBJECT object viewport plot) [Function] Draw the object within viewport. A VIEWPORT may be thought of as a sub imagestream. It will usually be associated with the plot's PLOTWINDOW, but might might also be associated with some other image stream. Typically this generic operation will make use of functions from TWODGRAPHICS and the position of the object in world coordinates. The plot is also passed as an argument, so that the draw operation may make use of information cached on the property list of plot. The only operation that is expected to draw on streams other than the PLOTWINDOW is drawobject, so the drawfn may have to behave differently depending on the imagestreamtype of the stream. All other generic operations are assumed to operate on the PLOTWINDOW. The idea here is that plot's may be drawn on any stream, but may be interacted with only through the PLOTWINDOW. It is also guaranteed that an object will be drawn before it is erased, highlighted, etc. (ERASEPLOTOBJECT object viewport plot) [Function] Erase the object from the viewport. The inverse of DRAWOBJECT. It is guaranteed that the viewport will be on the PLOTWINDOW (HIGHLIGHTPLOTOBJECT object plot) [Function] Highlight the object. Used in selection. (LOWLIGHTPLOTOBJET object plot) [Function] The inverse of HIGHLIGHTOBJECT. With XOR drawing the HIGHLIGHTFN and the LOWLIGHTFN can often be the same. (MOVEPLOTOBJECT object dx dy plot) [Function] Destructively alter the object's OBJECTDATA, so that its position is moved dx, dy units (in world coordinates). (LABELPLOTOBJECT object plot) [Function] If it is desired to label the object, the LABELFN will be called. Often the function LABELGENERIC will do the trick. (EXTENTOFPLOTOBJECT object plot) [Function] Should return an EXTENT, which expresses the range of the object in world coordinates. EXTENT [Datatype] MINX [Field] Minimun extent in the X (horizontal) direction MAXX [Field] Maximun extent in the X (horizontal) direction MINY [Field] Minimun extent in the Y (vertical) direction MAXY [Field] Maximun extent in the Y (vertical) direction All fields are type floating. (DISTANCETOPLOTOBJECT object streamposition plot) [Function] Should return a number (more efficient if it returns a SMALLP), which is some measure of the distance from the REPRESENTATION of the object to the POSITION streamposition. Note that distance is calculated in stream coordinates, NOT world coordinates. This is done for efficiency and logical consistency. Selection makes most sense as an activity in stream coordinates. A plot object will typically cache its stream coordinates when it is drawn. Although not strictly necessary (it is always possible to backsolve to stream coordinates from world coordinates), this improves efficiency many fold by avoiding generation of floating point boxes. The following functions are provided to allow the plot object to customize how it is copied, printed on file, etc. The generic defaults will usually be satisfactory. (COPYPLOTOBJECT object plot) [Function] Returns a copy of object. COPYOBJECT will create a new instance of PLOTOBJECT and copyover all the fields of object except for OBJECTDATA. The object's COPYFN is evoked with the agruments object and plot and is expected to return a new instance of OBJECTDATUM. The objects property list is handled as follows: If object has a prop COPYFN (which may be a function or list of functions), for each property it is called with the arguments newobject, oldobject, plot, propname. If the returned value is non-nil it is used as the value for that property on newobject; else the prop value is HCOPYALL'ed. If the value of COPYFN is a list of functions, they are invoked in order head to tail, and the first non-NIL value is used as the new value. (PRINTPLOTOBJECT object plot stream) [Function] Writes out to stream an HREADable symbolic representation of object. As in COPYOBJECT, PRINTOBJECT takes care of all PLOTOBJECT fields except of OBJECTDATUM. The objects PUTFN will be invoked with the arguments object plot stream and is expected to write out a representation of OBJECTDATUM which is HREADable. This will usually be in prop list format. Again the prop list of object requires special handling. The special object prop PUTFN may be a function or list of functions. For each property it will be invoked with the arguments object plot propname and stream and if it returns a non-NIL value, it is assumed that property has been written out in a HREADable format. Again, if the the PUTFN prop is a list of fns then if any one of them returns non-NIL then the property is assumed written out. If there is no PUTFN then the property is (HPRINT prop stream NIL T) 'ed. PUTFNS may put out special lists of the form ((FUNCTION fnname) arg) in which case fnname will be invoked at HREAD time with args object plot propname arg and fnname will be expected to return the propvalue of propname. (READPLOTOBJECT stream) [Function] Reads in the product of PRINTOBJECT. Calls the objects GETFN to read in the OBJECTDATA field. An instance of PLOTFNS may be created by the function: (CREATEPLOTFNS drawfn erasefn extentfn distancefn highlightfn lowlightfn labelfn movefn copyfn putfn getfn borrowfrom) [Function] Returns an instance of PLOTFNS. Drawfn, erasefn, and extentfn are required. If a distancefn is supplied then so must be a highlightfn. Lowlightfn defaults to highlightfn, labelfn defaults to LABELGENERIC. The other arguments also default to some safe, if not too efficient genericfn. A primitive inheritance scheme is implemented via the optional argument borrowfrom. If supplied, borrowfrom must be an instance of PLOTFNS. Before creating the new instance of PLOTFNS, the NIL arguments passed are filled in from the fields of borrowfrom, with the following exception; lowlightfn is only inherited if highlightfn is also NIL. The OBJECTDATA field will typically be a datatype which holds the data characterizing the PLOTOBJECT. For example a point plot object will have an OBJECTDATA field whose value is an instance of the datatype POINTDATA (has fields position, symbol, etc). So, a point PLOTOBJECT is a specialization of PLOTOBJECT. The field OBJECTSUBTYPE is supplied to make the subtype explicit. The following macro is provided to facilitate testing for plot object subtypes. (PLOTOBJECTSUBTYPE? subtype plotobject) [Macro] Essentially tests if (EQ subtype (fetch OBJECTSUBTYPE of plotobject)) (PLOTOBJECTSUBTYPE plotobject) [Function] Returns the value of the OBJECTSUBTYPE field. PLOTOBJECTS may be created via the function: (CREATEPLOTOBJECT objectfns objectlabel objectmenu objectdata) [Function] Returns an instance of PLOTOBJECT. Coerces objectmenu into a MENU if it is an item list. The following subtypes of PLOTOBJECT are currently implemented. pointPLOTOBJECT, curvePLOTOBJECT, polygonPLOTOBJECT, linePLOTOBJECT, graphPLOTOBJECT, texttPLOTOBJECT, filledrectanglePLOTOBJECT, compound PLOTOBJECT The functions CREATEPOINT, etc. return an instance of PLOTOBJECT, with the appropriate OBJECTFNS and OBJECTDATA. In order for this to work, some intializations must be done at load time. The function PLOT.SETUP performs the intializations at LOAD time. (PLOT.SETUP opstable) [Function] Opstable must be a list of lists of the form: ( (subtypename1 (opname1 function1) (opname2 function2) .... (subtypename2 (opname1 function1) (opname2 function2) .... ..... (subtypenamen (opname1 function1)(opname2 function2) .... ) Creates one instance of PLOTFNS for each subtypename. In summary, to add a new plot object you need to: ˙˙ďf˙ Determine the data required to describe the new subtype. This may involve declaring a new datatype. ˙˙ďf˙ Write functions similar to CREATEPOINT and PLOTPOINT for the new subtype. ˙˙ďf˙ Write (or borrow) the functions which implement the generic ops described above. ˙˙ďf ˙Invoke MAKEPLOTFNS to create an instance of PLOTFNS for the new plot object subtype, which all objects of that subtype will refer to. ˙˙ďf˙ If continued use of the new plot object is contemplated, PLOT.SETUP should be evoked at load time to effect the proper initializations. Look at the code for existing plot objects for more details. The point plot object is the simplest example. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 189) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 42 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) +2ČČ3ČČT,Č2ČČ,Č,Č ,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD +CLASSICCLASSICCLASSICMODERN +TERMINAL +TERMINAL +MODERN +MODERNMODERN MODERN + + + + HRULE.GETFNMODERN + +  HRULE.GETFNMODERN + +  HRULE.GETFNMODERN + +  HRULE.GETFNMODERN    HRULE.GETFNMODERN  , + +2 +ř +5 + +J + + + + +# + + + + + + + +C + + + +, + + + + + + + + + + + + + + +Ö +Ď + + +| + +  +) + +  +k + + +p + +  +u + +  +W + + +/ + +1 + +- + +/ + + + +q + +Ś + +  +ä + + +b + +Ý + + +^ +7 + +‘ + +V +É + + + +G + + + +. +- + ++ +Y +@ +™ +ť +B + + +/ + +? +? + += + +6 +2 + +g + +N + +T + +ˆ + +‹ +l +&źzş \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS1 b/lispusers/PLOTOBJECTS1 new file mode 100644 index 00000000..1c57010f --- /dev/null +++ b/lispusers/PLOTOBJECTS1 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "30-Jun-88 16:35:35" {erinyes}lyric>plotobjects1.\;1 52951 |changes| |to:| (vars plotobjects1coms) (fns log-error-bar make-position-range log-error-range-list log-error-range) |previous| |date:| " 5-Jun-87 09:29:30" {phylum}lyric>lispusers>plotobjects1.\;1) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint plotobjects1coms) (rpaqq plotobjects1coms ( (* |;;;| "errorpoint functions") (fns createerrorpoint ploterrorpoint ploterrorpoints drawerrorpointobject eraseerrorpointobject highlighterrorpoint moveerrorpoint extentoferrorpoint distancetoerrorpoint copyerrorpoint puterrorpoint geterrorpoint) (fns log-error-bar log-error-range log-error-range-list make-position-range) (* |;;;| "sample set functions") (fns createsampleset plotsampleset drawsamplesetobject erasesamplesetobject highlightsampleset movesampleset extentofsampleset distancetosampleset copysampleset putsampleset getsampleset) (vars object1opstable) (records errorpointdata samplesetdata) (* |;;;| "initialization") (p (plot.setup object1opstable)))) (* |;;;| "errorpoint functions") (defineq (createerrorpoint (lambda (position-range label symbol style menu) (* \; "Edited 4-Jun-87 15:27 by thh:") (* |;;| "Create a errorpoint plot object") (* |;;| "POSITION-RANGE is of the form (POSITION XRANGE YRANGE) where a range is either (negShift . posShift) or a nonnegative number n which is equivalent to (n . n), or NIL") (cond ((null symbol) (setq symbol star))) (let ((position (car position-range)) (x (cadr position-range)) (y (caddr position-range))) (createplotobject errorpointfns 'errorpoint label menu (|create| errorpointdata pointposition _ position symbol _ symbol style _ (cond ((fixp style) (|create| plot.style linewidth _ style)) ((listp style) (|create| plot.style linewidth _ (car style) dashing _ (cadr style) color _ (caddr style))) (t (|create| plot.style linewidth _ 1))) xrange _ (cond (x (let ((c (|fetch| (position xcoord) |of| position))) (cons (difference c (or (numberp x) (car x))) (plus c (or (numberp x) (cdr x)))))) (t (* \; "no range specified") nil)) yrange _ (cond (y (let ((c (|fetch| (position ycoord) |of| position))) (cons (difference c (or (numberp y) (car y))) (plus c (or (numberp y) (cdr y)))))) (t (* \; "no range specified") nil))))))) (ploterrorpoint (lambda (plot position-range label symbol style menu nodrawflg) (* \; "Edited 4-Jun-87 14:09 by thh:") (* |;;| "User entry point. Add an errorpoint to the plot.") (cond ((not (|type?| plot plot)) (help "NOT a PLOT " plot))) (addplotobject (createerrorpoint position-range label symbol style menu) plot nodrawflg))) (ploterrorpoints (lambda (plot position-ranges labels symbol style menu nodrawflg) (* \; "Edited 5-Jun-87 09:26 by thh:") (* |;;| "User entry point. Draw the errorpoints in plot.") (cond ((not (|type?| plot plot)) (help "NOT a PLOT " plot))) (prog (extent newscales objects) (setq extent (|bind| (minx _ max.float) (maxx _ min.float) (miny _ max.float) (maxy _ min.float) |for| pt |in| position-ranges |bind| p v range |do| (setq p (car pt)) (* |;;| "check x coords") (setq range (cadr pt)) (setq v (difference (|fetch| xcoord |of| p) (or (numberp range) (car range) 0))) (cond ((lessp v minx) (setq minx v))) (setq v (plus (|fetch| xcoord |of| p) (or (numberp range) (cdr range) 0))) (cond ((greaterp v maxx) (setq maxx v))) (* |;;| "check y coords") (setq range (caddr pt)) (setq v (difference (|fetch| ycoord |of| p) (or (numberp range) (car range) 0))) (cond ((lessp v miny) (setq miny v))) (setq v (plus (|fetch| ycoord |of| p) (or (numberp range) (cdr range) 0))) (cond ((greaterp v maxy) (setq maxy v))) |finally| (return (|create| extent minx _ minx maxx _ maxx miny _ miny maxy _ maxy)))) (adjustscale? extent plot) (* \;  "Scale up the plot so that each ADDPLOTOBJECT need not rescale") (setq objects (|bind| (label _ labels) |for| position-range |in| position-ranges |collect| (prog1 (createerrorpoint position-range (car label) symbol style menu) (setq label (cdr label)) (* \;  "note that LABELS can be a shorter list than POSITION-RANGES") ))) (* |;;| "Add the objects to the display list of the plot") (|replace| (plot plotobjects) |of| plot |with| (append objects (|fetch| (plot plotobjects) |of| plot))) (cond ((null nodrawflg) (redrawplotwindow plot))) (return objects)))) (drawerrorpointobject (lambda (errorpoint viewport plot) (* \; "Edited 4-Jun-87 10:15 by thh:") (* |;;| "Draw a glyph at point and error bars.") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| errorpoint)) (symbol (|fetch| (errorpointdata symbol) |of| objectdata)) (style (|fetch| (errorpointdata style) |of| objectdata)) (linewidth (times (dspscale nil stream) (|fetch| (plot.style linewidth) |of| style))) (dashing (|fetch| (plot.style dashing) |of| style)) (color (|fetch| (plot.style color) |of| style)) (pt (|fetch| (errorpointdata pointposition) |of| objectdata)) (xrange (|fetch| (errorpointdata xrange) |of| objectdata)) (yrange (|fetch| (errorpointdata yrange) |of| objectdata)) (streampt (worldtostream pt viewport)) sxmin sxmax symin symax) (clipped.plotat streamsubregion streampt symbol stream) (cond (xrange (* \; "draw horizontal bar") (setq sxmin (worldtostreamx (car xrange) viewport)) (setq sxmax (worldtostreamx (cdr xrange) viewport)) (clipped.drawline streamsubregion sxmin (|fetch| (position ycoord) |of| streampt) sxmax (|fetch| (position ycoord) |of| streampt) linewidth 'replace stream color dashing))) (cond (yrange (* \; "draw vertical bar") (setq symin (worldtostreamy (car yrange) viewport)) (setq symax (worldtostreamy (cdr yrange) viewport)) (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| streampt) symin (|fetch| (position xcoord) |of| streampt) symax linewidth 'replace stream color dashing))) (* |;;| "") (* |;;| "cache stream coords if this is drawn in the plotwindow") (cond ((eq stream (windowprop (|fetch| (plot plotwindow) |of| plot) 'dsp)) (|replace| (errorpointdata streamposition) |of| objectdata |with| streampt) (cond (xrange (|replace| (errorpointdata xstreamrange) |of| objectdata |with| (cons sxmin sxmax)))) (cond (yrange (|replace| (errorpointdata ystreamrange) |of| objectdata |with| (cons symin symax))))))))) (eraseerrorpointobject (lambda (errorpoint viewport plot) (* \; "Edited 4-Jun-87 10:20 by thh:") (* |;;| "Erase errorpoint object using cached stream coords.") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| errorpoint)) (symbol (|fetch| (errorpointdata symbol) |of| objectdata)) (style (|fetch| (errorpointdata style) |of| objectdata)) (linewidth (times (dspscale nil stream) (|fetch| (plot.style linewidth) |of| style))) (color (|fetch| (plot.style color) |of| style)) (streampt (|fetch| (errorpointdata streamposition) |of| objectdata)) (xstreamrange (|fetch| (errorpointdata xstreamrange) |of| objectdata)) (ystreamrange (|fetch| (errorpointdata ystreamrange) |of| objectdata))) (clipped.plotat streamsubregion streampt symbol stream 'erase) (cond (xstreamrange (* \; "erase horizontal bar") (clipped.drawline streamsubregion (car xstreamrange) (|fetch| (position ycoord) |of| streampt) (cdr xstreamrange) (|fetch| (position ycoord) |of| streampt) linewidth 'erase stream color))) (cond (ystreamrange (* \; "erase vertical bar") (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| streampt) (car ystreamrange) (|fetch| (position xcoord) |of| streampt) (cdr ystreamrange) linewidth 'erase stream color)))))) (highlighterrorpoint (lambda (errorpoint viewport plot) (* \; "Edited 4-Jun-87 16:42 by thh:") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| errorpoint)) (symbol (|fetch| (errorpointdata symbol) |of| objectdata)) (style (|fetch| (errorpointdata style) |of| objectdata)) (linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style)) (* \; "this is called on display streams only -- extra line width so inversion will be visible against white background") ) (color (|fetch| (plot.style color) |of| style)) (streampt (|fetch| (errorpointdata streamposition) |of| objectdata)) (xsrange (|fetch| (errorpointdata xstreamrange) |of| objectdata)) (ysrange (|fetch| (errorpointdata ystreamrange) |of| objectdata)) (widthglyph (bitmapwidth symbol)) (heightglyph (bitmapheight symbol)) (offsetx (idifference (|fetch| xcoord |of| streampt) (iquotient widthglyph 2))) (offsety (idifference (|fetch| ycoord |of| streampt) (iquotient heightglyph 2)))) (clipped.bitblt streamsubregion nil nil nil stream offsetx offsety widthglyph heightglyph 'texture 'invert blackshade) (* |;;| "invert the error bars") (cond (xsrange (* \; "draw horizontal bar") (clipped.drawline streamsubregion (car xsrange) (|fetch| (position ycoord) |of| streampt) (cdr xsrange) (|fetch| (position ycoord) |of| streampt) linewidth 'invert stream color))) (cond (ysrange (* \; "draw vertical bar") (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| streampt) (car ysrange) (|fetch| (position xcoord) |of| streampt) (cdr ysrange) linewidth 'invert stream color)))))) (moveerrorpoint (lambda (errorpoint dx dy plot) (* \; "Edited 4-Jun-87 13:41 by thh:") (let* ((objectdata (|fetch| (plotobject objectdata) |of| errorpoint)) (position (|fetch| (errorpointdata pointposition) |of| objectdata)) (xrange (|fetch| (errorpointdata xrange) |of| objectdata)) (yrange (|fetch| (errorpointdata yrange) |of| objectdata))) (|replace| xcoord |of| position |with| (plus dx (|fetch| xcoord |of| position))) (|replace| ycoord |of| position |with| (plus dy (|fetch| ycoord |of| position))) (|if| xrange |then| (|replace| (errorpointdata xrange) |of| objectdata |with| (cons (plus dx (car xrange)) (plus dx (cdr xrange))))) (|if| yrange |then| (|replace| (errorpointdata yrange) |of| objectdata |with| (cons (plus dy (car yrange)) (plus dy (cdr yrange)))))))) (extentoferrorpoint (lambda (errorpoint) (* \; "Edited 4-Jun-87 15:13 by thh:") (let* ((objectdata (|fetch| (plotobject objectdata) |of| errorpoint)) (pt (|fetch| (errorpointdata pointposition) |of| objectdata)) (xrange (|fetch| (errorpointdata xrange) |of| objectdata)) (yrange (|fetch| (errorpointdata yrange) |of| objectdata))) (|create| extent minx _ (or (car xrange) (|fetch| (position xcoord) |of| pt)) maxx _ (or (cdr xrange) (|fetch| (position xcoord) |of| pt)) miny _ (or (car yrange) (|fetch| (position ycoord) |of| pt)) maxy _ (or (cdr yrange) (|fetch| (position ycoord) |of| pt)))))) (distancetoerrorpoint (lambda (errorpoint streamposition plot) (* \; "Edited 4-Jun-87 13:49 by thh:") (* |;;| "distance is to central point") (l1metric (|fetch| (errorpointdata streamposition) |of| (|fetch| (plotobject objectdata) |of| errorpoint)) streamposition))) (copyerrorpoint (lambda (plotobject plot) (* \; "Edited 4-Jun-87 13:54 by thh:") (* |;;| " Copyfn for ERRORPOINT objects") (let ((objectdata (|fetch| (plotobject objectdata) |of| plotobject))) (|create| errorpointdata pointposition _ (copyall (|fetch| (errorpointdata pointposition) |of| objectdata)) symbol _ (|fetch| (errorpointdata symbol) |of| objectdata) style _ (copyall (|fetch| (errorpointdata style) |of| objectdata)) xrange _ (copyall (|fetch| (errorpointdata xrange) |of| objectdata)) yrange _ (copyall (|fetch| (errorpointdata yrange) |of| objectdata)))))) (puterrorpoint (lambda (plotobject plot stream) (* \; "Edited 4-Jun-87 14:01 by thh:") (* |;;| "Putfn for ERRORPOINT objects") (prog ((objectdata (|fetch| (plotobject objectdata) |of| plotobject)) symbol lab style) (setq symbol (|fetch| (errorpointdata symbol) |of| objectdata)) (setq style (|fetch| (errorpointdata style) |of| objectdata)) (setq lab (cond ((eq symbol star) 'star) ((eq symbol cross) 'cross) ((eq symbol circle) 'circle))) (printout stream "(" \, "POINTPOSITION" \, |.P2| (|fetch| (errorpointdata pointposition) |of| objectdata) \, "XRANGE" \, |.P2| (|fetch| (errorpointdata xrange) |of| objectdata) \, "YRANGE" \, |.P2| (|fetch| (errorpointdata yrange) |of| objectdata) \, "SYMBOL" \,) (cond (lab (printout stream |.P2| lab \,)) (t (hprint symbol stream t t))) (printout stream \, "STYLE" \, |.P2| (list (|fetch| (plot.style linewidth) |of| style) (|fetch| (plot.style dashing) |of| style) (|fetch| (plot.style color) |of| style)) \, ")")))) (geterrorpoint (lambda (proplst) (* \; "Edited 4-Jun-87 14:07 by thh:") (* |;;| " Getfn for ERRORPOINT objects.") (|create| errorpointdata pointposition _ (listget proplst 'pointposition) symbol _ (let ((symbol (listget proplst 'symbol))) (cond ((litatom symbol) (eval symbol)) (t symbol))) xrange _ (listget proplst 'xrange) yrange _ (listget proplst 'yrange) style _ (let ((stylelst (listget proplst 'style))) (|create| plot.style linewidth _ (car stylelst) dashing _ (cadr stylelst) color _ (caddr stylelst)))))) ) (defineq (log-error-bar (lambda (p range base) (* \; "Edited 30-Jun-88 16:22 by thh:") (cl:assert (cl:plusp p) (p) "Position ~G must be positive to take log." p) (cl:if (null range) nil (let (plus minus) (cond ((numberp range) (setq minus range) (setq plus range)) (t (setq minus (car range)) (setq plus (cdr range)))) (cl:assert (cl:plusp (- 1 (/ minus p))) (minus) "Error bar of length ~G from point ~G gives negative value: can't take log."   minus p) (cons (abs (cl:log (- 1 (/ minus p)) base)) (cl:log (+ 1 (/ plus p)) base)))))) (log-error-range (lambda (position-range axis base) (* \; "Edited 30-Jun-88 16:24 by thh:") (* |;;;| "converts POSITION-RANGE to log scale: AXIS specifies which axis to convert (:X, :Y or NIL for both)") (or base (setq base 10)) (let ((position (car position-range)) (xrange (cadr position-range)) (yrange (caddr position-range)) x y) (setq x (|fetch| (position xcoord) |of| position)) (setq y (|fetch| (position ycoord) |of| position)) (cl:unless (eq axis :y) (* \; "convert the x-coord") (setq xrange (log-error-bar x xrange base)) (setq x (cl:log x base))) (cl:unless (eq axis :x) (* \; "convert the y-coord") (setq yrange (log-error-bar y yrange base)) (setq y (cl:log y base))) (make-position-range (|create| position xcoord _ x ycoord _ y) xrange yrange)))) (log-error-range-list (lambda (position-ranges axis base) (* \; "Edited 30-Jun-88 16:05 by thh:") (|for| p |in| position-ranges |collect| (log-error-range p axis base)))) (make-position-range (lambda (position xrange yrange) (* \; "Edited 30-Jun-88 15:54 by thh:") (list position xrange yrange))) ) (* |;;;| "sample set functions") (defineq (createsampleset (lambda (positions constant vertical? side label style menu) (* \; "Edited 4-Jun-87 17:45 by thh:") (* |;;| "Create a sample plot object") (createplotobject samplesetfns 'sampleset label menu (|create| samplesetdata samplepoints _ positions style _ (cond ((fixp style) (|create| plot.style linewidth _ style)) ((listp style) (|create| plot.style linewidth _ (car style) dashing _ (cadr style) color _ (caddr style))) (t (|create| plot.style linewidth _ 1))) constant _ constant vertical? _ vertical? side _ side)))) (plotsampleset (lambda (plot positions constant vertical? side label style menu) (* \; "Edited 4-Jun-87 17:42 by thh:") (* |;;| "User Entry Point. Plots samples with line segments to specified constant. SIDE is NIL to plot only values greater than constant, T to plot only those less and otherwise all values are plotted") (cond ((not (|type?| plot plot)) (help "NOT a PLOT " plot))) (addplotobject (createsampleset positions constant vertical? side label style menu) plot))) (drawsamplesetobject (lambda (sampleset viewport plot) (* \; "Edited 4-Jun-87 16:37 by thh:") (* |;;| "Draw line segments from positions to constant value.") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| sampleset)) (style (|fetch| (samplesetdata style) |of| objectdata)) (linewidth (times (dspscale nil stream) (|fetch| (plot.style linewidth) |of| style))) (dashing (|fetch| (plot.style dashing) |of| style)) (color (|fetch| (plot.style color) |of| style)) (points (|fetch| (samplesetdata samplepoints) |of| objectdata)) (streampoints (|for| pt |in| points |collect| (worldtostream pt viewport))) (constant (|fetch| (samplesetdata constant) |of| objectdata)) (vertical? (|fetch| (samplesetdata vertical?) |of| objectdata)) (streamconstant (cond (vertical? (worldtostreamx constant viewport)) (t (worldtostreamy constant viewport)))) (side (|fetch| (samplesetdata side) |of| objectdata))) (cond (vertical? (|for| pt |in| streampoints |when| (cond ((null side) (* \; "plot values > constant") (greaterp (|fetch| (position xcoord) |of| pt) streamconstant)) ((eq side t) (* \; "plot values < constant") (lessp (|fetch| (position xcoord) |of| pt) streamconstant)) (t (* \; "plot all values") t)) |do| (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| pt) (|fetch| (position ycoord) |of| pt) streamconstant (|fetch| (position ycoord) |of| pt) linewidth 'replace stream color dashing))) (t (|for| pt |in| streampoints |when| (cond ((null side) (* \; "plot values > constant") (greaterp (|fetch| (position ycoord) |of| pt) streamconstant)) ((eq side t) (* \; "plot values < constant") (lessp (|fetch| (position ycoord) |of| pt) streamconstant)) (t (* \; "plot all values") t)) |do| (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| pt) (|fetch| (position ycoord) |of| pt) (|fetch| (position xcoord) |of| pt) streamconstant linewidth 'replace stream color dashing)))) (* |;;| "") (* |;;| "cache stream coords if this is drawn in the plotwindow") (cond ((eq stream (windowprop (|fetch| (plot plotwindow) |of| plot) 'dsp)) (|replace| (samplesetdata streampoints) |of| objectdata |with| streampoints) (|replace| (samplesetdata streamconstant) |of| objectdata |with| streamconstant)))))) (erasesamplesetobject (lambda (sampleset viewport plot) (* \; "Edited 4-Jun-87 16:40 by thh:") (* |;;| "Erase sampleset using cached stream coords.") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| sampleset)) (style (|fetch| (samplesetdata style) |of| objectdata)) (linewidth (times (dspscale nil stream) (|fetch| (plot.style linewidth) |of| style))) (color (|fetch| (plot.style color) |of| style)) (streampoints (|fetch| (samplesetdata streampoints) |of| objectdata)) (streamconstant (|fetch| (samplesetdata streamconstant) |of| objectdata)) (vertical? (|fetch| (samplesetdata vertical?) |of| objectdata)) (side (|fetch| (samplesetdata side) |of| objectdata))) (cond (vertical? (|for| pt |in| streampoints |when| (cond ((null side) (* \; "plot values > constant") (greaterp (|fetch| (position xcoord) |of| pt) streamconstant)) ((eq side t) (* \; "plot values < constant") (lessp (|fetch| (position xcoord) |of| pt) streamconstant)) (t (* \; "plot all values") t)) |do| (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| pt) (|fetch| (position ycoord) |of| pt) streamconstant (|fetch| (position ycoord) |of| pt) linewidth 'erase stream color))) (t (|for| pt |in| streampoints |when| (cond ((null side) (* \; "plot values > constant") (greaterp (|fetch| (position ycoord) |of| pt) streamconstant)) ((eq side t) (* \; "plot values < constant") (lessp (|fetch| (position ycoord) |of| pt) streamconstant)) (t (* \; "plot all values") t)) |do| (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| pt) (|fetch| (position ycoord) |of| pt) (|fetch| (position xcoord) |of| pt) streamconstant linewidth 'erase stream color))))))) (highlightsampleset (lambda (sampleset viewport plot) (* \; "Edited 4-Jun-87 16:48 by thh:") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| sampleset)) (style (|fetch| (samplesetdata style) |of| objectdata)) (linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style)) (* \; "this is called on display streams only -- extra line width so inversion will be visible against white background") ) (color (|fetch| (plot.style color) |of| style)) (streampoints (|fetch| (samplesetdata streampoints) |of| objectdata)) (streamconstant (|fetch| (samplesetdata streamconstant) |of| objectdata)) (vertical? (|fetch| (samplesetdata vertical?) |of| objectdata)) (side (|fetch| (samplesetdata side) |of| objectdata))) (cond (vertical? (|for| pt |in| streampoints |when| (cond ((null side) (* \; "plot values > constant") (greaterp (|fetch| (position xcoord) |of| pt) streamconstant)) ((eq side t) (* \; "plot values < constant") (lessp (|fetch| (position xcoord) |of| pt) streamconstant)) (t (* \; "plot all values") t)) |do| (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| pt) (|fetch| (position ycoord) |of| pt) streamconstant (|fetch| (position ycoord) |of| pt) linewidth 'invert stream color))) (t (|for| pt |in| streampoints |when| (cond ((null side) (* \; "plot values > constant") (greaterp (|fetch| (position ycoord) |of| pt) streamconstant)) ((eq side t) (* \; "plot values < constant") (lessp (|fetch| (position ycoord) |of| pt) streamconstant)) (t (* \; "plot all values") t)) |do| (clipped.drawline streamsubregion (|fetch| (position xcoord) |of| pt) (|fetch| (position ycoord) |of| pt) (|fetch| (position xcoord) |of| pt) streamconstant linewidth 'invert stream color))))))) (movesampleset (lambda (sampleset dx dy plot) (* \; "Edited 5-Jun-87 09:25 by thh:") (let* ((objectdata (|fetch| (plotobject objectdata) |of| sampleset)) (points (|fetch| (samplesetdata samplepoints) |of| objectdata)) (constant (|fetch| (samplesetdata constant) |of| objectdata)) (vertical? (|fetch| (samplesetdata vertical?) |of| objectdata))) (|for| point |in| points |do| (|replace| xcoord |of| point |with| (plus dx (|fetch| xcoord |of| point))) (|replace| ycoord |of| point |with| (plus dy (|fetch| ycoord |of| point)))) (cond (vertical? (|replace| (samplesetdata constant) |of| objectdata |with| (plus dx constant) )) (t (|replace| (samplesetdata constant) |of| objectdata |with| (plus dy constant))))))) (extentofsampleset (lambda (sampleset) (* \; "Edited 4-Jun-87 17:04 by thh:") (let* ((objectdata (|fetch| (plotobject objectdata) |of| sampleset)) (points (|fetch| (samplesetdata samplepoints) |of| objectdata)) (vertical? (|fetch| (samplesetdata vertical?) |of| objectdata)) (side (|fetch| (samplesetdata side) |of| objectdata))) (|bind| (minx _ max.float) (maxx _ min.float) (miny _ max.float) (maxy _ min.float) (constant _ (|fetch| (samplesetdata constant) |of| objectdata)) x y |for| position |in| points |declare| (type floating minx maxx miny maxy x y constant) |do| (setq x (|fetch| xcoord |of| position)) (setq y (|fetch| ycoord |of| position)) (cond ((cond (vertical? (cond ((null side) (* \; "plot values > constant") (fgreaterp x constant)) ((eq side t) (* \; "plot values < constant") (flessp x constant)) (t (* \; "plot all values") t))) (t (cond ((null side) (* \; "plot values > constant") (fgreaterp y constant)) ((eq side t) (* \; "plot values < constant") (flessp y constant)) (t (* \; "plot all values") t)))) (* \;  " count this point only if it is actually drawn") (cond ((flessp x minx) (setq minx x))) (cond ((fgreaterp x maxx) (setq maxx x))) (cond ((flessp y miny) (setq miny y))) (cond ((fgreaterp y maxy) (setq maxy y))))) |finally| (cond (vertical? (setq minx (min minx constant)) (setq maxx (max maxx constant))) (t (setq miny (min miny constant)) (setq maxy (max maxy constant)))) (return (|create| extent minx _ minx maxx _ maxx miny _ miny maxy _ maxy)))))) (distancetosampleset (lambda (sampleset streamposition plot) (* \; "Edited 5-Jun-87 09:24 by thh:") (* |;;| "distance is to actual points that are plotted") (let* ((objectdata (|fetch| (plotobject objectdata) |of| sampleset)) (streampoints (|fetch| (samplesetdata streampoints) |of| objectdata)) (streamconstant (|fetch| (samplesetdata streamconstant) |of| objectdata)) (vertical? (|fetch| (samplesetdata vertical?) |of| objectdata)) (side (|fetch| (samplesetdata side) |of| objectdata))) (l1metric streamposition (|for| pt |in| streampoints |when| (cond (vertical? (cond ((null side) (greaterp (|fetch| (position xcoord) |of| pt) streamconstant)) ((eq side t) (lessp (|fetch| (position xcoord) |of| pt) streamconstant)) (t (* \; "plot all points") t))) (t (cond ((null side) (greaterp (|fetch| (position ycoord) |of| pt) streamconstant)) ((eq side t) (lessp (|fetch| (position ycoord) |of| pt) streamconstant)) (t (* \; "plot all points") t)))) |smallest| (l1metric pt streamposition )))))) (copysampleset (lambda (plotobject plot) (* \; "Edited 5-Jun-87 08:45 by thh:") (* |;;| " Copyfn for SAMPLESET objects") (let ((objectdata (|fetch| (plotobject objectdata) |of| plotobject))) (|create| samplesetdata samplepoints _ (copyall (|fetch| (samplesetdata samplepoints) |of| objectdata)) style _ (copyall (|fetch| (samplesetdata style) |of| objectdata)) constant _ (|fetch| (samplesetdata constant) |of| objectdata) vertical? _ (|fetch| (samplesetdata vertical?) |of| objectdata) side _ (|fetch| (samplesetdata side) |of| objectdata))))) (putsampleset (lambda (plotobject plot stream) (* \; "Edited 4-Jun-87 17:23 by thh:") (* |;;| "Putfn for SAMPLESET objects") (prog ((objectdata (|fetch| (plotobject objectdata) |of| plotobject)) style) (setq style (|fetch| (samplesetdata style) |of| objectdata)) (printout stream "(" \, "SAMPLEPOINTS" \, |.P2| (|fetch| (samplesetdata samplepoints) |of| objectdata) \, "CONSTANT" \, |.P2| (|fetch| (samplesetdata constant) |of| objectdata) \, "VERTICAL?" \, |.P2| (|fetch| (samplesetdata vertical?) |of| objectdata) \, "SIDE" \, |.P2| (|fetch| (samplesetdata side) |of| objectdata) \,) (printout stream "STYLE" \, |.P2| (list (|fetch| (plot.style linewidth) |of| style) (|fetch| (plot.style dashing) |of| style) (|fetch| (plot.style color) |of| style)) \, ")")))) (getsampleset (lambda (proplst) (* \; "Edited 4-Jun-87 17:27 by thh:") (* |;;| " Getfn for SAMPLESET objects.") (|create| samplesetdata samplepoints _ (listget proplst 'samplepoints) constant _ (listget proplst 'constant) vertical? _ (listget proplst 'vertical?) side _ (listget proplst 'side) style _ (let ((stylelst (listget proplst 'style))) (|create| plot.style linewidth _ (car stylelst) dashing _ (cadr stylelst) color _ (caddr stylelst)))))) ) (rpaqq object1opstable ((errorpoint (drawfn drawerrorpointobject) (erasefn eraseerrorpointobject) (highlightfn highlighterrorpoint) (movefn moveerrorpoint) (labelfn labelgeneric) (extentfn extentoferrorpoint) (distancefn distancetoerrorpoint) (copyfn copyerrorpoint) (putfn puterrorpoint) (getfn geterrorpoint)) (sampleset (drawfn drawsamplesetobject) (erasefn erasesamplesetobject) (highlightfn highlightsampleset) (movefn movesampleset) (labelfn labelgeneric) (extentfn extentofsampleset) (distancefn distancetosampleset) (copyfn copysampleset) (putfn putsampleset) (getfn getsampleset)))) (declare\: eval@compile (datatype errorpointdata (* |;;| "range is of the form (minValue . maxValue)") (pointposition streamposition symbol style xrange yrange xstreamrange ystreamrange) symbol _ star) (datatype samplesetdata (samplepoints streampoints style (constant floating) (streamconstant floating) (vertical? flag (* \;  "non-NIL if bound is a vertical line (i.e. segments are to be drawn horizontally) ") ) side)) ) (/declaredatatype 'errorpointdata '(pointer pointer pointer pointer pointer pointer pointer pointer) '((errorpointdata 0 pointer) (errorpointdata 2 pointer) (errorpointdata 4 pointer) (errorpointdata 6 pointer) (errorpointdata 8 pointer) (errorpointdata 10 pointer) (errorpointdata 12 pointer) (errorpointdata 14 pointer)) '16) (/declaredatatype 'samplesetdata '(pointer pointer pointer floatp floatp flag pointer) '((samplesetdata 0 pointer) (samplesetdata 2 pointer) (samplesetdata 4 pointer) (samplesetdata 6 floatp) (samplesetdata 8 floatp) (samplesetdata 4 (flagbits . 0)) (samplesetdata 10 pointer)) '12) (* |;;;| "initialization") (plot.setup object1opstable) (putprops plotobjects1 copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil (1388 21815 (createerrorpoint 1398 . 3969) (ploterrorpoint 3971 . 4445) (ploterrorpoints 4447 . 8009) (drawerrorpointobject 8011 . 11268) (eraseerrorpointobject 11270 . 13382) ( highlighterrorpoint 13384 . 16028) (moveerrorpoint 16030 . 17186) (extentoferrorpoint 17188 . 18132) ( distancetoerrorpoint 18134 . 18553) (copyerrorpoint 18555 . 19342) (puterrorpoint 19344 . 20920) ( geterrorpoint 20922 . 21813)) (21816 24266 (log-error-bar 21826 . 22734) (log-error-range 22736 . 23864) (log-error-range-list 23866 . 24093) (make-position-range 24095 . 24264)) (24308 50438 ( createsampleset 24318 . 25407) (plotsampleset 25409 . 26028) (drawsamplesetobject 26030 . 31509) ( erasesamplesetobject 31511 . 36150) (highlightsampleset 36152 . 40869) (movesampleset 40871 . 41973) ( extentofsampleset 41975 . 45083) (distancetosampleset 45085 . 47760) (copysampleset 47762 . 48525) ( putsampleset 48527 . 49720) (getsampleset 49722 . 50436))))) stop \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS1.TEDIT b/lispusers/PLOTOBJECTS1.TEDIT new file mode 100644 index 00000000..630ba83a Binary files /dev/null and b/lispusers/PLOTOBJECTS1.TEDIT differ diff --git a/lispusers/PLOTOBJECTS2 b/lispusers/PLOTOBJECTS2 new file mode 100644 index 00000000..c685aaae --- /dev/null +++ b/lispusers/PLOTOBJECTS2 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated " 7-Oct-88 12:26:27" {indigo}lyric>library>plotobjects2.\;6 23088 |changes| |to:| (fns clipped.fillpolygon clipped.polygon finish-clip-polygon clip-polygon-vertex clip-insidep clip-intersect getfilledpolygon drawfilledpolygon createfilledpolygon distancetofilledpolygon erasefilledpolygon extentoffilledpolygon highlightfilledpolygon plotfilledpolygon clipped.findto clipped.findline copyfilledpolygon movefilledpolygon putfilledpolygon) (vars plotobjects2coms) (records clipedgeinfo filledpolygondata) |previous| |date:| " 5-Oct-88 11:21:10" {indigo}lyric>library>plotobjects2.\;1) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (prettycomprint plotobjects2coms) (rpaqq plotobjects2coms ((fns copyfilledpolygon createfilledpolygon distancetofilledpolygon drawfilledpolygon erasefilledpolygon extentoffilledpolygon getfilledpolygon highlightfilledpolygon movefilledpolygon plotfilledpolygon putfilledpolygon) (vars object2opstable) (records filledpolygondata) (p (plot.setup object2opstable)) (fns clipped.fillpolygon clipped.polygon clip-polygon-vertex finish-clip-polygon clip-insidep clip-intersect) (records clipedgeinfo))) (defineq (copyfilledpolygon (lambda (plotobject plot) (* \; "Edited 5-Oct-88 10:23 by thh:") (* |;;| "Copyfn for FILLEDPOLYGON objects") (let ((objectdata (fetch (plotobject objectdata) of plotobject))) (create filledpolygondata polygonpoints _ (copyall (fetch (filledpolygondata polygonpoints) of objectdata)) style _ (copyall (fetch (filledpolygondata style) of objectdata)) texture _ (fetch (filledpolygondata texture) of objectdata))))) (createfilledpolygon (lambda (positions label style texture menu) (* \; "Edited 5-Oct-88 12:49 by thh:") (createplotobject filledpolygonfns 'filledpolygon label menu (|create| filledpolygondata polygonpoints _ positions style _ (cond ((fixp style) (|create| plot.style linewidth _ style)) ((listp style) (|create| plot.style linewidth _ (car style) dashing _ (cadr style) color _ (caddr style))) (t (|create| plot.style linewidth _ 1))) texture _ texture)))) (distancetofilledpolygon (lambda (filledpolygon streamposition plot) (* \; "Edited 5-Oct-88 10:32 by thh:") (l1metric streamposition (|for| point |in| (|fetch| (filledpolygondata streampoints) |of| (|fetch| objectdata |of| filledpolygon)) |smallest| (l1metric point streamposition))))) (drawfilledpolygon (lambda (filledpolygon viewport plot) (* \; "Edited 5-Oct-88 13:05 by thh:") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| filledpolygon)) (points (|fetch| (filledpolygondata polygonpoints) |of| objectdata)) (streampoints (|for| pt |in| points |collect| (worldtostream pt viewport))) (style (|fetch| (filledpolygondata style) |of| objectdata)) (linewidth (times (dspscale nil stream) (|fetch| (plot.style linewidth) |of| style))) (dashing (|fetch| (plot.style dashing) |of| style)) (color (|fetch| (plot.style color) |of| style))) (clipped.fillpolygon streamsubregion streampoints (|fetch| (filledpolygondata texture) |of| objectdata) stream 'replace nil (< 0 linewidth) linewidth 'replace color dashing) (cond ((eq stream (windowprop (|fetch| (plot plotwindow) |of| plot) 'dsp)) (|replace| (filledpolygondata streampoints) |of| objectdata |with| streampoints)))))) (erasefilledpolygon (lambda (filledpolygon viewport plot) (* \; "Edited 5-Oct-88 13:05 by thh:") (* |;;| "Erase a FILLEDPOLYGONDATA") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| filledpolygon)) (streampoints (|fetch| (filledpolygondata streampoints) |of| objectdata)) (style (|fetch| (filledpolygondata style) |of| objectdata)) (linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style))) (color (|fetch| (plot.style color) |of| style))) (clipped.fillpolygon streamsubregion streampoints (|fetch| (filledpolygondata texture) |of| objectdata) stream 'erase nil (< 0 (|fetch| (plot.style linewidth) |of| style)) linewidth 'erase color)))) (extentoffilledpolygon (lambda (filledpolygon) (* \; "Edited 5-Oct-88 10:50 by thh:") (|bind| (minx _ max.float) (maxx _ min.float) (miny _ max.float) (maxy _ min.float) x y |for| position |in| (|fetch| (filledpolygondata polygonpoints) |of| (|fetch| objectdata |of| filledpolygon)) |declare| (type floating minx maxx miny maxy x y) |do| (setq x (|fetch| xcoord |of| position)) (setq y (|fetch| ycoord |of| position)) (cond ((flessp x minx) (setq minx x))) (cond ((fgreaterp x maxx) (setq maxx x))) (cond ((flessp y miny) (setq miny y))) (cond ((fgreaterp y maxy) (setq maxy y))) |finally| (return (|create| extent minx _ minx maxx _ maxx miny _ miny maxy _ maxy))))) (getfilledpolygon (lambda (proplst) (* \; "Edited 5-Oct-88 13:22 by thh:") (let ((stylelst (listget proplst 'style))) (|create| filledpolygondata polygonpoints _ (listget proplst 'polygonpoints) style _ (|create| plot.style linewidth _ (car stylelst) dashing _ (cadr stylelst) color _ (caddr stylelst)) texture _ (listget proplst 'texture))))) (highlightfilledpolygon (lambda (filledpolygon viewport plot) (* \; "Edited 5-Oct-88 13:12 by thh:") (let* ((stream (|fetch| (viewport parentstream) |of| viewport)) (streamsubregion (|fetch| (viewport streamsubregion) |of| viewport)) (objectdata (|fetch| (plotobject objectdata) |of| filledpolygon)) (streampoints (|fetch| (filledpolygondata streampoints) |of| objectdata)) (style (|fetch| (filledpolygondata style) |of| objectdata)) (linewidth (iplus 2 (|fetch| (plot.style linewidth) |of| style))) (color (|fetch| (plot.style color) |of| style))) (clipped.fillpolygon streamsubregion streampoints blackshade stream 'invert nil (< 0 (|fetch| (plot.style linewidth) |of| style)) linewidth 'invert color)))) (movefilledpolygon (lambda (filledpolygon dx dy plot) (* \; "Edited 5-Oct-88 11:09 by thh:") (let ((points (fetch (filledpolygondata polygonpoints) of (fetch objectdata of filledpolygon)))) (for point in points do (replace xcoord of point with (plus dx (fetch xcoord of point))) (replace ycoord of point with (plus dy (fetch ycoord of point))))))) (plotfilledpolygon (lambda (plot positions label style texture menu nodrawflg)(* \; "Edited 5-Oct-88 11:11 by thh:") (cond ((not (|type?| plot plot)) (help "NOT a PLOT" plot))) (addplotobject (createfilledpolygon positions label style texture menu) plot nodrawflg))) (putfilledpolygon (lambda (plotobject plot stream) (* \; "Edited 5-Oct-88 11:13 by thh:") (prog ((objectdata (|fetch| (plotobject objectdata) |of| plotobject)) style) (setq style (|fetch| (filledpolygondata style) |of| objectdata)) (printout stream "(" \, "POLYGONPOINTS" \, |.P2| (|fetch| (filledpolygondata polygonpoints) |of| objectdata) \, "TEXTURE" \, |.P2| (|fetch| (filledpolygondata texture) |of| objectdata) \, "STYLE" \, |.P2| (list (|fetch| (plot.style linewidth) |of| style) (|fetch| (plot.style dashing) |of| style) (|fetch| (plot.style color) |of| style)) \, ")")))) ) (rpaqq object2opstable ((filledpolygon (drawfn drawfilledpolygon) (erasefn erasefilledpolygon) (highlightfn highlightfilledpolygon) (movefn movefilledpolygon) (labelfn labelgeneric) (extentfn extentoffilledpolygon) (distancefn distancetofilledpolygon) (copyfn copyfilledpolygon) (putfn putfilledpolygon) (getfn getfilledpolygon)))) (declare\: eval@compile (datatype filledpolygondata (polygonpoints streampoints style texture) style _ 1) ) (/declaredatatype 'filledpolygondata '(pointer pointer pointer pointer) '((filledpolygondata 0 pointer) (filledpolygondata 2 pointer) (filledpolygondata 4 pointer) (filledpolygondata 6 pointer)) '8) (plot.setup object2opstable) (defineq (clipped.fillpolygon (lambda (clippingregion points texture stream operation windnumber draw? width drawoperation color dashing) (* \; "Edited 7-Oct-88 09:03 by thh:") (* |;;| "Clip filled polygon against CLIPPINGREGION. If DRAW? is non-NIL, the clipped perimeter of the polygon is drawn as well using the remaining parameters.") (let ((clippedpoints (clipped.polygon clippingregion points))) (* \;  "CLIPPEDPOINTS is NIL if polygon doesn't intersect CLIPPINGREGION") (cond (clippedpoints (* |;;| "fill clipped polygon") (fillpolygon clippedpoints texture stream operation windnumber) (* |;;| "draw if requested") (and draw? (|bind| (start _ (car points)) |first| (moveto (|fetch| xcoord |of| start) (|fetch| ycoord |of| start) stream) |for| pt |in| (cdr points) |do| (clipped.drawto clippingregion (|fetch| xcoord |of| pt) (|fetch| ycoord |of| pt) width drawoperation stream color dashing) |finally| (clipped.drawto clippingregion (|fetch| xcoord |of| start) (|fetch| ycoord |of| start) width drawoperation stream color dashing)))))))) (clipped.polygon (lambda (clippingregion points) (* \; "Edited 6-Oct-88 17:10 by thh:") (* |;;| "clips polygon whose vertices are given in POINTS to CLIPPINGREGION using Sutherland-Hodgman algorithm. cf. p.450 of Foley and Van Dam") (let* ((left (|fetch| left |of| clippingregion)) (right (|fetch| right |of| clippingregion)) (top (|fetch| top |of| clippingregion)) (bottom (|fetch| bottom |of| clippingregion)) (edges (list (|create| clipedgeinfo x _ left y _ bottom end _ top vertical? _ t) (|create| clipedgeinfo x _ left y _ top end _ right vertical? _ nil) (|create| clipedgeinfo x _ right y _ top end _ bottom vertical? _ t) (|create| clipedgeinfo x _ right y _ bottom end _ left vertical? _ nil))) clippedpoints) (* |;;| "each edge in EDGES is a pair of points such that on moving from first to second, inside of CLIPPINGREGION is on the right. THESE ARE LEFT, TOP, RIGHT AND BOTTOM EDGES RESPECTIVELY.") (for pt in points do (setq clippedpoints (clip-polygon-vertex pt edges clippedpoints))) (finish-clip-polygon edges clippedpoints)))) (clip-polygon-vertex (lambda (point edges clippedpoints) (* \; "Edited 6-Oct-88 16:02 by thh:") (* |;;;| "implements single step of Sutherland-Hodgman algorithm") (cond (edges (let* ((edge (car edges)) (prevpoint (|fetch| (clipedgeinfo prevpt) |of| edge)) (previnside? (|fetch| (clipedgeinfo previnside?) |of| edge)) (inside? (clip-insidep point edge))) (* |;;| "update points and check for intersection") (cond ((|fetch| (clipedgeinfo firstpt) |of| edge) (* |;;| "this is not first point of polygon to be clipped with this edge") (cond ((neq previnside? inside?) (* \; "polygon side crosses edge") (setq clippedpoints (clip-polygon-vertex (clip-intersect prevpoint point edge) (cdr edges) clippedpoints))))) (t (* |;;| "this is first point of the polygon for this edge") (|replace| (clipedgeinfo firstpt) |of| edge |with| point) (|replace| (clipedgeinfo firstinside?) |of| edge |with| inside?))) (|replace| (clipedgeinfo prevpt) |of| edge |with| point) (|replace| (clipedgeinfo previnside?) |of| edge |with| inside?) (* |;;| "") (* |;;| "check if new point should be included") (cond (inside? (setq clippedpoints (clip-polygon-vertex point (cdr edges) clippedpoints)))))) (t (* \; "nothing to clip against") (push clippedpoints point))) clippedpoints)) (finish-clip-polygon (lambda (edges clippedpoints) (* \; "Edited 6-Oct-88 16:10 by thh:") (cond (edges (let ((edge (car edges))) (cond ((and clippedpoints (neq (|fetch| (clipedgeinfo firstinside?) |of| edge) (|fetch| (clipedgeinfo previnside?) |of| edge))) (* \;  "last side of polygon crosses edge") (setq clippedpoints (clip-polygon-vertex (clip-intersect (|fetch| ( clipedgeinfo firstpt) |of| edge) (|fetch| (clipedgeinfo prevpt) |of| edge) edge) (cdr edges) clippedpoints)))) (|replace| (clipedgeinfo firstpt) |of| edge |with| nil) (finish-clip-polygon (cdr edges) clippedpoints))) (t clippedpoints)))) (clip-insidep (lambda (pt edge) (* \; "Edited 6-Oct-88 16:32 by thh:") (* |;;| "T if PT is on or to the right of the directed EDGE (which is the inside of the region of which it is a part)") (cond ((|fetch| (clipedgeinfo vertical?) |of| edge) (* \; "vertical edge") (cond ((greaterp (|fetch| (clipedgeinfo end) |of| edge) (|fetch| (clipedgeinfo y) |of| edge)) (* \;  "edge is going up, right is positive x-axis") (geq (|fetch| xcoord |of| pt) (|fetch| (clipedgeinfo x) |of| edge))) (t (leq (|fetch| xcoord |of| pt) (|fetch| (clipedgeinfo x) |of| edge))))) (t (* \; "horizontal edge") (cond ((greaterp (|fetch| (clipedgeinfo end) |of| edge) (|fetch| (clipedgeinfo x) |of| edge)) (* \;  "edge is going right, right is negative y-axis") (leq (|fetch| ycoord |of| pt) (|fetch| (clipedgeinfo y) |of| edge))) (t (geq (|fetch| ycoord |of| pt) (|fetch| (clipedgeinfo y) |of| edge)))))))) (clip-intersect (lambda (p1 p2 edge) (* \; "Edited 6-Oct-88 16:42 by thh:") (* |;;| "returns point where segment between P1 and P2 intersect EDGE (the two points are on opposite sides of the edge)") (cond ((|fetch| (clipedgeinfo vertical?) |of| edge) (* \; "vertical edge") (let ((x (|fetch| (clipedgeinfo x) |of| edge))) (|create| position xcoord _ x ycoord _ (plus (|fetch| ycoord |of| p1) (quotient (times (difference x (|fetch| xcoord |of| p1)) (difference (|fetch| ycoord |of| p2) (|fetch| ycoord |of| p1))) (difference (|fetch| xcoord |of| p2) (|fetch| xcoord |of| p1))))))) (t (* \; "horizontal edge") (let ((y (|fetch| (clipedgeinfo y) |of| edge))) (|create| position xcoord _ (plus (|fetch| xcoord |of| p1) (quotient (times (difference y (|fetch| ycoord |of| p1)) (difference (|fetch| xcoord |of| p2) (|fetch| xcoord |of| p1))) (difference (|fetch| ycoord |of| p2) (|fetch| ycoord |of| p1)))) ycoord _ y)))))) ) (declare\: eval@compile (record clipedgeinfo (x y end vertical? firstpt firstinside? prevpt previnside?)) ) (putprops plotobjects2 copyright ("Xerox Corporation" 1988)) (declare\: dontcopy (filemap (nil (1540 11177 (copyfilledpolygon 1550 . 2136) (createfilledpolygon 2138 . 3044) ( distancetofilledpolygon 3046 . 3475) (drawfilledpolygon 3477 . 4973) (erasefilledpolygon 4975 . 6088) (extentoffilledpolygon 6090 . 7929) (getfilledpolygon 7931 . 8492) (highlightfilledpolygon 8494 . 9435 ) (movefilledpolygon 9437 . 9937) (plotfilledpolygon 9939 . 10262) (putfilledpolygon 10264 . 11175)) ( 12069 22891 (clipped.fillpolygon 12079 . 13948) (clipped.polygon 13950 . 15777) (clip-polygon-vertex 15779 . 17993) (finish-clip-polygon 17995 . 19602) (clip-insidep 19604 . 21079) (clip-intersect 21081 . 22889))))) stop \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS2.TEDIT b/lispusers/PLOTOBJECTS2.TEDIT new file mode 100644 index 00000000..2c379a0d Binary files /dev/null and b/lispusers/PLOTOBJECTS2.TEDIT differ diff --git a/lispusers/PORT-CLFILE b/lispusers/PORT-CLFILE new file mode 100644 index 00000000..86240bf0 --- /dev/null +++ b/lispusers/PORT-CLFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL" BASE 10) (il:filecreated "23-Dec-87 16:56:46" "{FireFS:CS:Univ Rochester}LispUsers>Lyric>PORT-CLFILE.;14" 13433 il:|changes| il:|to:| (il:functions export-clfile) il:|previous| il:|date:| " 3-Nov-87 16:27:35" "{FireFS:CS:Univ Rochester}LispUsers>Lyric>PORT-CLFILE.;12") ; Copyright (c) 1987 by Johannes Koomen, Larry Masinter. All rights reserved. (il:prettycomprint il:port-clfilecoms) (il:rpaqq il:port-clfilecoms ((il:functions import-clfile export-clfile) (il:p (export (quote (import-clfile export-clfile)) (find-package "XCL")) (import (quote (import-clfile export-clfile)) (find-package "INTERLISP"))) (il:functions clfile-export-filecom clfile-parse-form clfile-parse-mode clfile-read-semi clfile-set-mode) (il:prop (il:filetype il:makefile-environment) il:port-clfile)) ) (defun import-clfile (filepath) "Load a standard CommonLisp file FILEPATH, creating COMS for FILEPATH" (with-open-file (*standard-input* filepath :direction :input) (declare (special *standard-input*)) (let ((*package* (find-package "USER")) (*readtable* (copy-readtable nil)) (*read-base* 10) (comslst nil) (eof-value (list :eof)) (file-id (intern (string-upcase (pathname-name *standard-input*)) (find-package "INTERLISP")))) (declare (special *package* *readtable* *read-base*)) (il:* il:|;;| "Copy readtable, change ; macro to preserve comments") (set-macro-character #\; (function clfile-read-semi) nil *readtable*) (do ((clform (read nil nil eof-value) (read nil nil eof-value)) (firstclformp t) (nextcomsentry nil) (lastcomsentry nil) (nextcomsweirdp nil)) ((eq clform eof-value) (if lastcomsentry (push lastcomsentry comslst)) (setq comslst (nreverse comslst))) (when firstclformp (setq firstclformp nil) (cond ((and (consp clform) (eq (car clform) (quote il:*)) (do ((cltail (cdr clform) (cdr cltail))) ((not (consp cltail)) nil) (if (stringp (car cltail)) (return (clfile-parse-mode (car cltail) file-id))))) (setq clform nil)))) (unless (null clform) (eval clform) (setq nextcomsentry (clfile-parse-form clform)) (setq nextcomsweirdp (or (eq (car nextcomsentry) (quote il:*)) (consp (cddr nextcomsentry)))) (when (and lastcomsentry (or nextcomsweirdp (not (eq (car nextcomsentry) (car lastcomsentry))))) (push lastcomsentry comslst) (setq lastcomsentry nil)) (cond (nextcomsweirdp (push nextcomsentry comslst)) (lastcomsentry (nconc lastcomsentry (cdr nextcomsentry))) (t (setq lastcomsentry nextcomsentry))))) (setf (get file-id (quote il:filetype)) :compile-file) (set (il:filecoms file-id) (nconc comslst (il:bquote ((il:prop (il:filetype il:makefile-environment) (il:\\\, file-id)))))) (pushnew file-id il:filelst) (il:markaschanged file-id (quote il:files) (quote il:defined)) file-id))) (defun export-clfile (filepath &optional (linelength 72)) "Write a standard CommonLisp file FILEPATH, using COMS for FILEPATH" (declare (global il:filelinelength)) (il:resetvars ((il:filelinelength linelength)) (return (with-open-file (*standard-output* (make-pathname :type "LISP" :version :newest :defaults filepath) :direction :output) (declare (special *standard-output*)) (let ((*package* (find-package "USER")) (*readtable* (il:find-readtable "LISP")) (*print-base* 10) (*print-array* t) (*print-level* nil) (*print-length* nil) (il:fontchangeflg nil) (il:\#rpars nil) (il:**comment**flg nil) (il:*print-semicolon-comments* t) (il:*print-structure* t) (file-id (intern (string-upcase (pathname-name *standard-output*)) (find-package "INTERLISP")))) (declare (special *package* *readtable* *print-base* *print-array* *print-level* *print-length* il:fontchangeflg il:\#rpars il:**comment**flg il:*print-semicolon-comments* il:*print-structure*)) (clfile-set-mode (get file-id (quote il:makefile-environment))) (format t ";;; -*- Package: ~A; Syntax: ~A; Mode: Lisp; Base: ~D -*-" (string-capitalize (package-name *package*)) (let ((rdtblname (il:readtableprop *readtable* (quote il:name)))) (cond ((or (not (stringp rdtblname)) (string-equal rdtblname "XCL") (string-equal rdtblname "LISP")) "Common-Lisp") (t (string-capitalize rdtblname)))) *print-base*) (format t "~2%;;; File converted on ~A from source ~A" (il:date (il:dateformat il:no.leading.spaces)) (symbol-name file-id)) (let ((dates (get file-id (quote il:filedates)))) (when dates (format t "~&;;; Original source ~A created ~A" (cdar dates) (caar dates)))) (terpri) (terpri) (il:printcopyright file-id) (mapc (function clfile-export-filecom) (il:listp (il:gettopval (il:filecoms file-id)))) (namestring *standard-output*)))))) (export (quote (import-clfile export-clfile)) (find-package "XCL")) (import (quote (import-clfile export-clfile)) (find-package "INTERLISP")) (defun clfile-export-filecom (command) (flet ((save-prop (symbol prop val) (case prop ((il:filetype il:makefile-environment) (il:* il:\; "IGNORE") nil) (t (pprint (il:bquote (setf (get (quote (il:\\\, symbol)) (quote (il:\\\, prop))) (quote (il:\\\, val))))))))) (case (il:getfilepkgtype (car command) (quote command)) (il:fns (mapc (function (lambda (fn) (pprint (let ((def (il:getdef fn (quote il:fns)))) (ecase (car def) ((lambda) (il:bquote (defun (il:\\\, fn) (il:\\\,@ (cdr def))))) ((il:lambda) (il:bquote (defun (il:\\\, fn) (&optional (il:\\\,@ (second def))) (il:\\\,@ (cddr def)))))))))) (il:prettycom1 command t t))) (il:vars (mapc (function (lambda (var) (if (listp var) (il:bquote (defparameter (first var) (second var))) (il:bquote (defparameter (il:\\\, var) (quote (il:\\\, (il:gettopval var)))))))) (il:prettycom1 command t t))) (il:declare\: (let ((context (quote (load eval))) (when-clause t)) (do ((tail (il:prettycom1 command t t) (cdr tail))) ((null tail)) (case (car tail) ((il:eval@loadwhen) (pushnew (quote eval) context) (setq when-clause (if (eq when-clause t) (cadr tail) (il:bquote (and (il:\\\, (cadr tail)) (il:\\\, when-clause))))) (setq tail (cdr tail)) (il:* il:\; " consumes two tokens, one by the DO")) ((il:eval@compilewhen) (pushnew (quote compile) context) (setq when-clause (if (eq when-clause t) (cadr tail) (il:bquote (and (il:\\\, (cadr tail)) (il:\\\, when-clause))))) (setq tail (cdr tail))) ((il:copywhen) (pushnew (quote load) context) (setq when-clause (if (eq when-clause t) (cadr tail) (il:bquote (and (il:\\\, (cadr tail)) (il:\\\, when-clause))))) (setq tail (cdr tail))) ((il:first il:notfirst) (il:* il:\; "IGNORE")) ((il:compilervars) (il:* il:|;;| "throw these out") (return-from clfile-export-filecom nil)) ((il:copy il:docopy) (pushnew (quote load) context)) ((il:doeval@compile il:eval@compile) (pushnew (quote compile) context)) ((il:doeval@load il:eval@load) (pushnew (quote eval) context)) ((il:dontcopy) (setq context (remove (quote load) context))) ((il:donteval@compile) (setq context (remove (quote compile) context))) ((il:donteval@load) (setq context (remove (quote eval) context))) (t (format t "~&(eval-when &S " context) (clfile-export-filecom (car tail)) (format t ")")))))) ((il:specvars) (pprint (il:bquote (proclaim (quote (special (il:\\\,@ (il:prettycom1 command t t)))))))) ((il:globalvars) (pprint (il:bquote (proclaim (quote (global (il:\\\,@ (il:prettycom1 command t t)))))))) ((il:localvars) (pprint (il:bquote (proclaim (quote (lexical (il:\\\,@ (il:prettycom1 command t t)))))))) ((il:prop il:ifprop) (prog ((optional (eq (car command) (quote il:ifprop))) (props (cadr command)) (not-found "NOT ON ANY PROPERTY LIST") (symbols (il:prettycom1 (cdr command) t t))) (il:* il:\; "IFPROP only dumps those property values that are non-NIL.") (mapc (function (lambda (symbol) (declare (special il:sysprops)) (flet ((do-prop (prop) (unless (and optional (eq not-found (get symbol prop not-found))) (save-prop symbol prop (get symbol prop))))) (cond ((consp props) (mapc (function do-prop) props)) ((eq props (quote il:all)) (do ((tail (symbol-plist symbol) (cddr tail))) ((null tail)) (unless (member (car tail) il:sysprops) (do-prop (car tail))))) (t (do-prop props)))))) symbols))) (il:p (mapc (function (lambda (x) (case (car x) ((il:putprops) (do ((tail (cdr x) (cdddr tail))) ((null tail)) (save-prop (first tail) (second tail) (third tail)))) (t (pprint x))))) (il:prettycom1 command t))) (il:initvars (mapc (function (lambda (x) (declare (special il:commentflg)) (pprint (cond ((listp x) (if (eq (car x) il:commentflg) x (il:bquote (defvar (il:\\\,@ x))))) (t (help)))))) (il:prettycom1 command t t))) (il:coms (mapc (function clfile-export-filecom) (il:prettycom1 command t))) ((il:*) (cond ((eq (cadr command) (quote il:*)) (il:* il:\; "Form-feed if super-comment indicated. Use * no matter what current COMMENTFLG is.") (write-char #\Page))) (pprint command)) (t (let ((def (cdr (assoc (car command) il:prettydefmacros)))) (if def (mapc (function clfile-export-filecom) (il:subpair (car def) (il:prettycom1 command t t) (cdr def))) (help "CAN'T HANDLE" (car command)))))))) (defun clfile-parse-form (clform) "Given CommonLisp FORM, creates (filepkgtype object)" (cond ((or (not (consp clform)) (not (symbolp (car clform)))) (il:bquote (il:p (il:\\\, clform)))) ((eq (car clform) (quote il:*)) clform) ((let ((comstype (get (car clform) (quote il:definer-for))) (comsname (cadr clform))) (if comstype (list comstype (if (consp comsname) (il:* il:\; "e.g. STRUCTURES") (car comsname) comsname))))) ((case (car clform) (proclaim (let ((declspec (car (il:constantexpressionp (cadr clform))))) (case (car declspec) (global (cons (quote il:globalvars) (cdr declspec))) (special (cons (quote il:specvars) (cdr declspec))) (lexical (cons (quote il:localvars) (cdr declspec)))))) (eval-when (let (evalflg loadflg compileflg) (do ((context (cadr clform) (cdr context))) ((null context)) (case (car context) (eval (setq evalflg t)) (load (setq loadflg t)) (compile (setq compileflg t)))) (il:bquote (il:declare\: (il:\\\, (if evalflg (quote il:eval@load) (quote il:donteval@load))) (il:\\\, (if loadflg (quote il:copy) (quote il:dontcopy))) (il:\\\, (if compileflg (quote il:eval@compile) (quote il:donteval@compile))) (coms (il:\\\,@ (mapcar (function clfile-parse-form) (caddr clform)))))))))) (t (il:bquote (il:p (il:\\\, clform)))))) (defun clfile-parse-mode (mode-string &optional file-id) "Setf *PACKAGE*, *READTABLE* and *READ-BASE* according to file mode comment" (declare (special *package* *readtable* *read-base*)) (when (search "-*-" mode-string :end2 3) (prog ((modestr (string-upcase mode-string)) modepos modename object) (when (setq modepos (search "PACKAGE: " modestr)) (setq modename (string (read-from-string modestr nil nil :start (+ modepos (length "PACKAGE: "))))) (setq object (find-package modename)) (cond ((packagep object) (setq *package* object)) (t (error "~&Non-existent package: ~A~%" modename)))) (when (setq modepos (search "SYNTAX: " modestr)) (setq modename (string (read-from-string modestr nil nil :start (+ modepos (length "SYNTAX: "))))) (if (string-equal modename "COMMON-LISP") (setq modename "LISP")) (setq object (il:find-readtable modename)) (cond ((readtablep object) (il:* il:|;;| "Need to continue intercepting comments!") (setq *readtable* (copy-readtable object)) (il:readtableprop *readtable* (quote il:name) (il:readtableprop object (quote il:name))) (set-macro-character #\; (function clfile-read-semi) nil *readtable*)) (t (error "~&Non-existent readtable: ~A~%" modename)))) (when (setq modepos (search "BASE: " modestr)) (setq object (read-from-string modestr nil nil :start (+ modepos (length "BASE: ")))) (cond ((and (numberp object) (> object 0)) (setq *read-base* (truncate object))) (t (error "~&Bad read base: ~A~%" object)))) (when file-id (setf (get file-id (quote il:makefile-environment)) (list :package (package-name *package*) :readtable (let ((rdtblname (il:readtableprop *readtable* (quote il:name)))) (cond ((or (not (stringp rdtblname)) (string-equal rdtblname "LISP")) "XCL") (t rdtblname))) :base *read-base*))) (return t)))) (defun clfile-read-semi (stream rdtbl) "A ; was seen. Collect more ;'s, then wrap comment in IL:*" (declare (ignore rdtbl)) (do ((ch (read-char stream) (read-char stream)) (lvl 1) (comment "")) ((or (null ch) (not (char= ch #\;))) (unread-char ch stream) (cond ((setq comment (read-line stream)) (list (quote il:*) (cond ((> lvl 2) (quote il:|;;;|)) ((= lvl 2) (quote il:|;;|)) (t (quote il:\;))) (string-trim (quote (#\Space #\Tab)) comment))))) (incf lvl 1))) (defun clfile-set-mode (makefile-environment) (il:* il:|;;;| "Using the MAKEFILE-ENVIRONMENT, sets the appropriate free vars (bound above in EXPORT-CLFILE) to the specified package, readtable and print base.") (declare (special *package* *readtable* *print-base*)) (let ((file-package (getf makefile-environment :package)) (read-table (getf makefile-environment :readtable)) (print-base (getf makefile-environment :base))) (let ((pkg (if (stringp file-package) (find-package file-package) (eval file-package)))) (when (packagep pkg) (setq *package* pkg))) (let ((rdtbl (if (stringp read-table) (il:find-readtable read-table) (eval read-table)))) (when (readtablep rdtbl) (setq *readtable* rdtbl))) (let ((base (if (numberp print-base) print-base (eval print-base)))) (when (numberp base) (setq *print-base* base))))) (il:putprops il:port-clfile il:filetype :compile-file) (il:putprops il:port-clfile il:makefile-environment (:readtable "XCL" :package "XCL" :base 10)) (il:putprops il:port-clfile il:copyright ("Johannes Koomen, Larry Masinter" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/POSTSCRIPT/BECKMAN01-MRR-C0.PSCFONT b/lispusers/POSTSCRIPT/BECKMAN01-MRR-C0.PSCFONT new file mode 100644 index 00000000..7c85ecd3 Binary files /dev/null and b/lispusers/POSTSCRIPT/BECKMAN01-MRR-C0.PSCFONT differ diff --git a/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM b/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM new file mode 100644 index 00000000..c2112627 --- /dev/null +++ b/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "18-Feb-91 11:52:53" {DSK}gadener>medley>work>PS>POSTSCRIPTSTREAM.;5 149573 changes to%: (VARS POSTSCRIPTSTREAMCOMS) previous date%: "15-Feb-91 16:35:41" {DSK}gadener>medley>work>PS>POSTSCRIPTSTREAM.;4) (* ; " Copyright (c) 1989, 1990, 1991 by Savoir and Beckman. All rights reserved. ") (PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS) (RPAQQ POSTSCRIPTSTREAMCOMS [(RECORDS FONTID PSCFONT \POSTSCRIPTDATA) (FNS CLOSEPOSTSCRIPTSTREAM OPENPOSTSCRIPTSTREAM POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.ENDPAGE POSTSCRIPT.FONTCREATE POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.GETFONTID POSTSCRIPT.HARDCOPYW POSTSCRIPT.INIT POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.WRITEFONT READ-AFM-FILE \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC \DSPSCALE.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \FIXLINELENGTH.PSC \MOVETO.PSC \NEWPAGE.PSC \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK \PS.SCALEREGION \SCALEDBITBLT.PSC \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC \SWITCHFONTS.PSC \TERPRI.PSC) (FNS \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.SYMBOLOUTCHAR) (VARS (\POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T "Print this file/document/image in Landscape Orientation" ) ("Portrait" 'NIL "Print this file/document/image in Portrait Orientation" )) TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) CHANGEOFFSETFLG _ 'Y)) (\POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS _ '(("Ask" 'ASK "Always ask whether to print in Landscape or Portrait Orientation" ) ("Landscape" T "Default printing to Landscape Orientation" ) ("Portrait" 'NIL "Default printing to Portrait Orientation" )) TITLE _ "Default Orientation" CENTERFLG _ T)) PS.BITMAPARRAY \POSTSCRIPT.JOB.SETUP SlopeMenuItems WeightMenuItems) [ADDVARS (BackgroundMenuCommands ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE (MENU \POSTSCRIPT.ORIENTATION.OPTIONS.MENU )) "Select the default Orientation for PostScript output" (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) "Always ask whether to print in Landscape or Portrait Orientation" ) ("Landscape" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE T) "Default printing to Landscape Orientation" ) ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE NIL) "Default printing to Portrait Orientation" ] (VARS (BackgroundMenu NIL)) (CONSTANTS (GOLDEN.RATIO 1.618034) (\PS.SCALE0 100) (\PS.TEMPARRAYLEN 20)) (INITVARS (POSTSCRIPT.BITMAP.SCALE 1) (POSTSCRIPT.EOL 'CR) (POSTSCRIPT.IMAGESIZEFACTOR 1) (POSTSCRIPT.PREFER.LANDSCAPE NIL) (POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) (POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800)) (POSTSCRIPT.TEXTURE.SCALE 4) (POSTSCRIPTFONTDIRECTORIES (LIST (IF (EQL (MACHINETYPE) 'MAIKO) then "{DSK}/usr/local/lde/fonts/postscript/" else "{DSK}FONTS>PSC>"))) (\POSTSCRIPT.MAX.WILD.FONTSIZE 72)) [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (HELVETICAD . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMES) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (TITAN . COURIER)) [PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPT.SEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT] (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET NILL] (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER)) [APPENDVARS (POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) (0.197 0.197 8.1 10.6)) (LEGAL (0 0 8.5 14) (0.89 0.5 6.72 13.0)) (NOTE (0 0 8.5 11) (0.405 0.42 7.69 10.16] (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (POSTSCRIPT.INIT))) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) POSTSCRIPTSTREAM) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA POSTSCRIPT.PUTCOMMAND ]) (DECLARE%: EVAL@COMPILE (RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR)) (RECORD PSCFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS)) (DATATYPE \POSTSCRIPTDATA (POSTSCRIPTFONT (* ;  "The fontdescriptor of the current font") POSTSCRIPTX (* ; "The current X") POSTSCRIPTY (* ; "... and Y") POSTSCRIPTLEFTMARGIN (* ; "The margins") POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLINESPACING (* ; "Line to line spacing") POSTSCRIPTCOLOR POSTSCRIPTSCALE (* ; "Scale of the stream") POSTSCRIPTOPERATION (* ;  "Default operation (PAINT, REPLACE, ...)") POSTSCRIPTCLIPPINGREGION (* ;  "The current region available to be written into") POSTSCRIPTPAGENUM (* ; "Current page number") POSTSCRIPTHEADING (* ; "The heading") POSTSCRIPTHEADINGFONT (* ; "Font for the heading") POSTSCRIPTSPACEFACTOR (* ;  "Expansion factor for spaces (see DSPSPACEFACTOR)") POSTSCRIPTSPACEWIDTH (* ;  "The width of a space in the current font") POSTSCRIPTLANDSCAPE (* ;  "non-NIL for paper in 'landscape' mode") POSTSCRIPTCHARSTOSHOW (* ;  "non-NIL if the string (PostScript-type string) of chars has already been started") POSTSCRIPTFONTCHANGEDFLG (* ; "Font has changed") POSTSCRIPTMOVEFLG (* ; "Need to move") POSTSCRIPTWIDTHS (* ;  "The widths vector of the current font") POSTSCRIPTTRANSX (* ; "Translation in X") POSTSCRIPTTRANSY (* ; "... and Y") POSTSCRIPTPENDINGXFORM (* ;  "A userspace to devicespace transform is pending") POSTSCRIPTPAGEREGION (* ; "The whole page") POSTSCRIPTPAGEBLANK (* ; "This page is blank flag") POSTSCRIPTSCALEHACK (* ;  "For \PS.SCALEHACK since DSPSCALE doesn't change the scale of the stream") POSTSCRIPTTEMPARRAY (* ;  "For converting FIXP to string of digit chars") ) POSTSCRIPTX _ 0 POSTSCRIPTY _ 0 POSTSCRIPTTRANSX _ 0 POSTSCRIPTTRANSY _ 0 POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0 POSTSCRIPTSCALEHACK _ 1 POSTSCRIPTTEMPARRAY _ (ARRAY \PS.TEMPARRAYLEN 'BYTE 0 0)) ) (/DECLAREDATATYPE '\POSTSCRIPTDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((\POSTSCRIPTDATA 0 POINTER) (\POSTSCRIPTDATA 2 POINTER) (\POSTSCRIPTDATA 4 POINTER) (\POSTSCRIPTDATA 6 POINTER) (\POSTSCRIPTDATA 8 POINTER) (\POSTSCRIPTDATA 10 POINTER) (\POSTSCRIPTDATA 12 POINTER) (\POSTSCRIPTDATA 14 POINTER) (\POSTSCRIPTDATA 16 POINTER) (\POSTSCRIPTDATA 18 POINTER) (\POSTSCRIPTDATA 20 POINTER) (\POSTSCRIPTDATA 22 POINTER) (\POSTSCRIPTDATA 24 POINTER) (\POSTSCRIPTDATA 26 POINTER) (\POSTSCRIPTDATA 28 POINTER) (\POSTSCRIPTDATA 30 POINTER) (\POSTSCRIPTDATA 32 POINTER) (\POSTSCRIPTDATA 34 POINTER) (\POSTSCRIPTDATA 36 POINTER) (\POSTSCRIPTDATA 38 POINTER) (\POSTSCRIPTDATA 40 POINTER) (\POSTSCRIPTDATA 42 POINTER) (\POSTSCRIPTDATA 44 POINTER) (\POSTSCRIPTDATA 46 POINTER) (\POSTSCRIPTDATA 48 POINTER) (\POSTSCRIPTDATA 50 POINTER) (\POSTSCRIPTDATA 52 POINTER) (\POSTSCRIPTDATA 54 POINTER) (\POSTSCRIPTDATA 56 POINTER)) '58) (DEFINEQ (CLOSEPOSTSCRIPTSTREAM [LAMBDA (STREAM) (* ; "Edited 30-Mar-90 17:18 by Matt Heffron") (POSTSCRIPT.ENDPAGE STREAM) (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Trailer" :EOL) (BOUT STREAM (CHARCODE ^D]) (OPENPOSTSCRIPTSTREAM [LAMBDA (FILE OPTIONS) (* ; "Edited 30-Mar-90 17:02 by Matt Heffron") (LET ([FP (OPENSTREAM FILE 'OUTPUT NIL `((EOL ,POSTSCRIPT.EOL) (TYPE POSTSCRIPT) (SEQUENTIAL T] (IMAGEDATA (create \POSTSCRIPTDATA)) PAPER IMAGESIZEFACTOR CLIP REG) (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN) (replace (STREAM IMAGEDATA) of FP with IMAGEDATA) (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS) (printout FP "%%!PS-Adobe-2.0" T "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 'DOCUMENT.NAME) FILE)) T "%%%%Creator: PostScript ImageStream Driver Copyright Beckman Instruments and Savoir" T "%%%%CreationDate: " (DATE) T "%%%%For: " (if (STRING-EQUAL INITIALS "Edited:") then (MKSTRING USERNAME) else INITIALS) T "%%%%EndComments" T) (for X in \POSTSCRIPT.JOB.SETUP do (POSTSCRIPT.OUTSTR FP X) (\FILEOUTCHARFN FP (CHARCODE EOL))) (SETQ PAPER (OR (CDR (FASSOC (SETQ PAPER (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) POSTSCRIPT.PAGEREGIONS)) (ERROR "Unknown PostScript page type" PAPER))) (if (NOT (AND [SETQ IMAGESIZEFACTOR (NUMBERP (LISTGET OPTIONS 'IMAGESIZEFACTOR] (CL:PLUSP IMAGESIZEFACTOR))) then (SETQ IMAGESIZEFACTOR 1)) (if (AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR) (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR)) then (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR))) (printout FP "/imagesizefactor " IMAGESIZEFACTOR " def" T) (printout FP "%%%%EndSetup" T) (replace POSTSCRIPTSCALE of IMAGEDATA with \PS.SCALE0) (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN) (replace POSTSCRIPTPAGEREGION of IMAGEDATA with (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (CAR PAPER))) [replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with (SETQ CLIP (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (CADR PAPER] (* ;; "If a REGION parameter was supplied, it establishes the initial margins.") (SETQ REG (OR (AND (SETQ REG (LISTGET OPTIONS 'REGION)) (INTERSECTREGIONS REG CLIP)) CLIP)) (replace POSTSCRIPTLEFTMARGIN of IMAGEDATA with (fetch LEFT of REG)) (replace POSTSCRIPTBOTTOMMARGIN of IMAGEDATA with (fetch BOTTOM of REG)) (replace POSTSCRIPTTOPMARGIN of IMAGEDATA with (PLUS (fetch BOTTOM of REG) (fetch HEIGHT of REG) -1)) (replace POSTSCRIPTRIGHTMARGIN of IMAGEDATA with (PLUS (fetch LEFT of REG) (fetch WIDTH of REG) -1)) (\DSPFONT.PSC FP (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS] DEFAULTFONT) NIL NIL NIL FP)) [if (replace POSTSCRIPTHEADING of IMAGEDATA with (LISTGET OPTIONS 'HEADING)) then (replace POSTSCRIPTHEADINGFONT of IMAGEDATA with (if (LISTGET OPTIONS 'HEADINGFONT) then (FONTCREATE (LISTGET OPTIONS 'HEADINGFONT) NIL NIL NIL FP) else (fetch POSTSCRIPTFONT of IMAGEDATA] (if (if (EQL (CL:GETF OPTIONS 'ROTATION 'DEFAULT) 'DEFAULT) then (if (EQL POSTSCRIPT.PREFER.LANDSCAPE 'ASK) then (MENU \POSTSCRIPT.ORIENTATION.MENU) else POSTSCRIPT.PREFER.LANDSCAPE) else (CL:GETF OPTIONS 'ROTATION)) then (\DSPROTATE.PSC FP 90)) (POSTSCRIPT.STARTPAGE FP) FP]) (POSTSCRIPT.BITMAPSCALE [LAMBDA (WIDTH HEIGHT) (* ; "Edited 26-Jul-89 19:11 by Matt Heffron") (LET* ([PAGEREGION (\PS.SCALEREGION (/ 72 POSTSCRIPT.BITMAP.SCALE) (CADDR (FASSOC POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS] (LONGEDGE (MAX (fetch WIDTH of PAGEREGION) (fetch HEIGHT of PAGEREGION))) (SHORTEDGE (MIN (fetch WIDTH of PAGEREGION) (fetch HEIGHT of PAGEREGION))) [MINDIMP (MIN (FQUOTIENT LONGEDGE (SETQ HEIGHT (TIMES HEIGHT POSTSCRIPT.BITMAP.SCALE))) (FQUOTIENT SHORTEDGE (SETQ WIDTH (TIMES WIDTH POSTSCRIPT.BITMAP.SCALE] (MINDIML (MIN (FQUOTIENT SHORTEDGE HEIGHT) (FQUOTIENT LONGEDGE WIDTH))) (PPL (if (EQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) then (MENU \POSTSCRIPT.ORIENTATION.MENU) else POSTSCRIPT.PREFER.LANDSCAPE)) MINDIM OTHERDIM SF1 SF2) (if PPL then (SETQ MINDIM MINDIML) (SETQ OTHERDIM MINDIMP) else (SETQ MINDIM MINDIMP) (SETQ OTHERDIM MINDIML)) (SETQ SF1 (if (GREATERP MINDIM 1) then 1 elseif (GREATERP MINDIM 0.75) then 0.75 elseif (GREATERP MINDIM 0.5) then 0.5 elseif (GREATERP MINDIM 0.25) then 0.25 else MINDIM)) (SETQ SF2 (if (GREATERP OTHERDIM 1) then 1 elseif (GREATERP OTHERDIM 0.75) then 0.75 elseif (GREATERP OTHERDIM 0.5) then 0.5 elseif (GREATERP OTHERDIM 0.25) then 0.25 else OTHERDIM)) (if (AND (LESSP SF1 1) (LESSP SF1 SF2)) then (CONS SF2 (NOT PPL)) else (CONS SF1 PPL]) (POSTSCRIPT.CLOSESTRING [LAMBDA (STREAM) (* ; "Edited 12-Jan-88 12:33 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (if (fetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA) then (POSTSCRIPT.OUTSTR STREAM ") ") (replace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with NIL) T else NIL]) (POSTSCRIPT.ENDPAGE [LAMBDA (STREAM) (* ; "Edited 30-Mar-90 17:20 by Matt Heffron") (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) (POSTSCRIPT.SHOWACCUM STREAM) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with NIL) (if (NOT (PROG1 (fetch POSTSCRIPTPAGEBLANK of IMAGEDATA) (POSTSCRIPT.PUTCOMMAND STREAM "grestore savepage restore "))) then (POSTSCRIPT.PUTCOMMAND STREAM "showpage" :EOL]) (POSTSCRIPT.FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 13-Jul-90 01:41 by jds") (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS CHARSETINFO0 CHARSETINFO357 WIDTHS357 WIDTHSBLOCK FD FACECHANGED (WEIGHT (CAR FACE)) (SLOPE (CADR FACE)) (EXPANSION (CADDR FACE))) (* ;;  "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.") [COND [(EQ SIZE 1) (* ;; "Since a 1 point font is rediculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info") (COND ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) (SETQ FACECHANGED NIL)) ((AND (NEQ EXPANSION 'REGULAR) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) ROTATION DEVICE))) (SETQ FACECHANGED T)) ((AND (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) ROTATION DEVICE))) (SETQ FACECHANGED T)) ((AND (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) ROTATION DEVICE))) (SETQ FACECHANGED T)) ((AND (NEQ WEIGHT 'MEDIUM) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION ) ROTATION DEVICE))) (SETQ FACECHANGED T)) ((AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) ROTATION DEVICE))) (SETQ FACECHANGED T)) ((AND (NEQ WEIGHT 'MEDIUM) (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) ROTATION DEVICE))) (SETQ FACECHANGED T)) ((AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) ROTATION DEVICE))) (SETQ FACECHANGED T))) (COND (FULLNAME (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD) 0.1))) (SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD) 0.1))) (COND (FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD with (POSTSCRIPT.GETFONTID (fetch (PSCFONT FID) of PSCFD) WEIGHT SLOPE EXPANSION] ((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T)) (SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT) 'PSCFONT)) (* ;; "Scale the ASCENT and DESCENT") (SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD) 0.1))) (SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD) 0.1))) (SETQ SCALEFONTP T)) (T (* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.") (COND ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD)) (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD)) (SETQ SCALEFONTP NIL] (COND (PSCFD (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD)) (SETQ CHARSETINFO0 (create CHARSETINFO)) (SETQ CHARSETINFO357 (create CHARSETINFO)) (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of CHARSETINFO0)) (SETQ FD (create FONTDESCRIPTOR OTHERDEVICEFONTPROPS _ (LIST 'PSCFONT PSCFD) FONTSCALE _ 100 FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE ROTATION _ 0 \SFHeight _ (IPLUS ASCENT DESCENT) \SFAscent _ ASCENT \SFDescent _ DESCENT)) (replace (CHARSETINFO IMAGEWIDTHS) of CHARSETINFO0 with WIDTHSBLOCK) (replace (CHARSETINFO CHARSETASCENT) of CHARSETINFO0 with ASCENT) (replace (CHARSETINFO CHARSETDESCENT) of CHARSETINFO0 with DESCENT) (replace (CHARSETINFO IMAGEWIDTHS) of CHARSETINFO357 with (SETQ WIDTHS357 (fetch (CHARSETINFO WIDTHS) of CHARSETINFO357) )) (replace (CHARSETINFO CHARSETASCENT) of CHARSETINFO357 with ASCENT) (replace (CHARSETINFO CHARSETDESCENT) of CHARSETINFO357 with DESCENT) [COND [SCALEFONTP (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE (ELT FIXPWIDTHS CH) 0.1] (T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (ELT FIXPWIDTHS CH] [LET [(TMP (COND (FULLNAME (\FONTINFOFROMFILENAME FULLNAME DEVICE)) (UNITFONT (fetch FONTDEVICESPEC of UNITFONT] (* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got") (COND ((AND TMP (NEQ FAMILY (CAR TMP))) (replace FONTDEVICESPEC of FD with (LIST (CAR TMP) SIZE (COPY FACE) 0 DEVICE] (* ;; "Fill in character widths for known NS characters with PSC equivalents in CS0: Bullet, M-dash, N-dash, dagger, and double-dagger, respectiely.") (for NSCHAR in '(36 37 48 49 102) as PSCCHAR in '(183 208 177 178 179) do (\FSETWIDTH WIDTHS357 NSCHAR (ELT FIXPWIDTHS PSCCHAR))) [LET* [(SYMBOLFILE (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) ROTATION DEVICE)) (SYMBOLPS (AND SYMBOLFILE (PSCFONT.READFONT SYMBOLFILE))) (SYMWIDTHS (AND SYMBOLPS (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of SYMBOLPS] (AND SYMWIDTHS (for NSCHAR in '(210 211 212) as SYMCHAR in '(226 227 228) do (\FSETWIDTH WIDTHSBLOCK NSCHAR (FIXR (TIMES SIZE (ELT SYMWIDTHS SYMCHAR) 0.1] (\SETCHARSETINFO (fetch FONTCHARSETVECTOR of FD) 0 CHARSETINFO0) (\SETCHARSETINFO (fetch FONTCHARSETVECTOR of FD) 239 CHARSETINFO357) FD) (T NIL]) (POSTSCRIPT.FONTSAVAILABLE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 12-Jan-88 13:04 by Matt Heffron") (* ;; "the filtering code was borrowed from Richard Burton's \SEARCHINTERPRESSFONTS. Note that without it [HELVETICA * (MEDIUM REGULAR REGULAR)] would pick up [HELVETICA-NARROW * (MEDIUM REGULAR REGULAR)] as well.") (LET ((PATTERN (\FONTFILENAME (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST)) FAMILY) SIZE FACE 'PSCFONT)) [INVERSE.ALIST (for PAIR in POSTSCRIPT.FONT.ALIST collect (CONS (CDR PAIR) (CAR PAIR] FONTSAVAILABLE) (SETQ FONTSAVAILABLE (for FD in [for DIRECTORY in POSTSCRIPTFONTDIRECTORIES join (for FILE in (DIRECTORY (CONCAT DIRECTORY PATTERN)) collect (LET* ((RAWFD (\FONTINFOFROMFILENAME FILE DEVICE) ) (RAWNAME (CAR RAWFD))) (RPLACA RAWFD (OR (CDR (ASSOC RAWNAME INVERSE.ALIST)) RAWNAME] when (AND (OR (EQ FAMILY '*) (EQ FAMILY (CAR FD))) (OR (EQ SIZE '*) (EQ SIZE (CADR FD)) (EQ (CADR FD) 1)) (OR (EQ FACE '*) (EQUAL FACE (CADDR FD)) (EQUAL [CDR (ASSOC FACE '((MRR MEDIUM REGULAR REGULAR) (STANDARD MEDIUM REGULAR REGULAR) (MIR MEDIUM ITALIC REGULAR) (ITALIC MEDIUM ITALIC REGULAR) (BRR BOLD REGULAR REGULAR) (BOLD BOLD REGULAR REGULAR) (BIR BOLD ITALIC REGULAR) (BOLDITALIC BOLD ITALIC REGULAR] (CADDR FD))) (NOT (MEMBER FD $$VAL))) collect FD)) (if (EQ SIZE '*) then (* ;;; "If SIZE was wildcarded, then provide list of pointsizes for Postscript scaled fonts (those with a 1 point descriptor file)") (for FD in FONTSAVAILABLE join (if (EQ 1 (CADR FD)) then (CONS FD (for NF in (for S from 2 to \POSTSCRIPT.MAX.WILD.FONTSIZE collect (LET ((NFD (COPY FD))) (RPLACA (CDR NFD) S) NFD)) unless (MEMBER NF FONTSAVAILABLE) collect NF)) else (LIST FD))) else FONTSAVAILABLE]) (POSTSCRIPT.GETFONTID [LAMBDA (FID WEIGHT SLOPE EXPANSION) (* ; "Edited 12-Jan-88 12:58 by Matt Heffron") (LET (FONTID) (SETQ FONTID (create FONTID FONTIDNAME _ (CAR FID) FONTXFACTOR _ 1.0 FONTOBLIQUEFACTOR _ 0.0)) [if (AND (NEQ (CADDR FID) SLOPE) (EQ SLOPE 'ITALIC)) then (replace FONTOBLIQUEFACTOR of FONTID with (CONSTANT (TAN 7.0] (if (AND (NEQ (CADR FID) WEIGHT) (EQ WEIGHT 'BOLD)) then (* ; "Fake bold by slight expansion.") (replace FONTXFACTOR of FONTID with 1.1)) [if (NEQ EXPANSION 'REGULAR) then (replace FONTXFACTOR of FONTID with (TIMES (fetch FONTXFACTOR of FONTID) (if (EQ EXPANSION 'COMPRESSED) then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO)) else GOLDEN.RATIO] FONTID]) (POSTSCRIPT.HARDCOPYW [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE) (* ; "Edited 30-Mar-90 17:07 by Matt Heffron") (ALLOW.BUTTON.EVENTS) (LET* ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape? 'IMAGESIZEFACTOR SCALEFACTOR))) (IMAGEDATA (fetch IMAGEDATA of STREAM)) (SCLIP (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)) SCALE) [if REGION then (SETQ REGION (COPY REGION)) (* ; "In case we need to change it.") [if (< (fetch BITMAPWIDTH of BITMAP) (+ (fetch (REGION LEFT) of REGION) (fetch (REGION WIDTH) of REGION))) then (replace (REGION WIDTH) of REGION with (- (fetch BITMAPWIDTH of BITMAP) (fetch (REGION LEFT) of REGION] [if (< (fetch BITMAPHEIGHT of BITMAP) (+ (fetch (REGION BOTTOM) of REGION) (fetch (REGION HEIGHT) of REGION))) then (replace (REGION HEIGHT) of REGION with (- (fetch BITMAPHEIGHT of BITMAP) (fetch (REGION BOTTOM) of REGION] else (SETQ REGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch BITMAPWIDTH of BITMAP) HEIGHT _ (fetch BITMAPHEIGHT of BITMAP] (SETQ SCALE (TIMES POSTSCRIPT.BITMAP.SCALE (fetch POSTSCRIPTSCALE of IMAGEDATA))) (BITBLT BITMAP (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) STREAM (PLUS (fetch LEFT of SCLIP) (QUOTIENT (DIFFERENCE (fetch WIDTH of SCLIP) (TIMES SCALE (fetch WIDTH of REGION))) 2)) (PLUS (fetch BOTTOM of SCLIP) (QUOTIENT (DIFFERENCE (fetch HEIGHT of SCLIP) (TIMES SCALE (fetch HEIGHT of REGION))) 2)) (fetch WIDTH of REGION) (fetch HEIGHT of REGION) 'INPUT 'REPLACE) (CLOSEF STREAM) (FULLNAME STREAM]) (POSTSCRIPT.INIT [LAMBDA NIL (* ; "Edited 7-Apr-89 15:36 by TAL") (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE)) [MAPC [CL:REMOVE-DUPLICATES (NCONC (for FD in FONTDEFS join (for FP in (CDR (ASSOC 'FONTPROFILE (CDR FD))) collect (CAR FP))) '(FONT7 FONT6 FONT5 FONT4 FONT3 FONT2 FONT1 BOLDFONT LITTLEFONT BIGFONT PRETTYCOMFONT COMMENTFONT USERFONT SYSTEMFONT CLISPFONT LAMBDAFONT CHANGEFONT DEFAULTFONT] (FUNCTION (LAMBDA (CLASS) (LET (COPYFD OLDPSCFD) (if (BOUNDP CLASS) then (SETQ CLASS (EVALV CLASS)) (if (TYPEP CLASS 'FONTCLASS) then (SETQ COPYFD (OR (fetch (FONTCLASS PRESSFD) of CLASS) (fetch (FONTCLASS INTERPRESSFD) of CLASS) (fetch (FONTCLASS DISPLAYFD) of CLASS))) (if (SETQ OLDPSCFD (ASSOC 'POSTSCRIPT (fetch (FONTCLASS OTHERFDS) of CLASS))) then [if (NOT (CDR OLDPSCFD)) then (RPLACD OLDPSCFD (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD] else (push (fetch (FONTCLASS OTHERFDS) of CLASS) (CONS 'POSTSCRIPT (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD] (SETQ \POSTSCRIPT.CHARTYPE (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT T)) (* ;; "\POSTSCRIPT.OUTCHARFN uses this array to quickly determine whether a character needs any special processing -- T means yes") (for x from (CHARCODE SP) to 126 unless (FMEMB x (CHARCODE (%( %) \))) do (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE x) NIL)) (SETQ \POSTSCRIPTIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'POSTSCRIPT IMCLOSEFN _ (FUNCTION CLOSEPOSTSCRIPTSTREAM) IMXPOSITION _ (FUNCTION \DSPXPOSITION.PSC) IMYPOSITION _ (FUNCTION \DSPYPOSITION.PSC) IMMOVETO _ (FUNCTION \MOVETO.PSC) IMFONT _ (FUNCTION \DSPFONT.PSC) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.PSC) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.PSC) IMLINEFEED _ (FUNCTION \DSPLINEFEED.PSC) IMDRAWLINE _ (FUNCTION \DRAWLINE.PSC) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.PSC) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.PSC) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.PSC) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.PSC) IMBLTSHADE _ (FUNCTION \BLTSHADE.PSC) IMBITBLT _ (FUNCTION \BITBLT.PSC) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.PSC) IMNEWPAGE _ (FUNCTION \NEWPAGE.PSC) IMSCALE _ (FUNCTION \DSPSCALE.PSC) IMTERPRI _ (FUNCTION \TERPRI.PSC) IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PSC) IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PSC) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PSC) IMFONTCREATE _ 'POSTSCRIPT IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.PSC) IMRESET _ (FUNCTION \DSPRESET.PSC) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.PSC) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.PSC) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.PSC) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.PSC) IMDRAWARC _ (FUNCTION \DRAWARC.PSC) IMROTATE _ (FUNCTION \DSPROTATE.PSC) IMTRANSLATE _ (FUNCTION \DSPTRANSLATE.PSC) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.PSC]) (POSTSCRIPT.OUTSTR [LAMBDA (STREAM X) (* ; "Edited 14-Jul-89 14:05 by Matt Heffron") (DECLARE (LOCALVARS . T)) (if (FIXP X) then (* ; "Common case, speed helps") (\PS.BOUTFIXP STREAM X) elseif (STRINGP X) then (* ; "Other common case") (if (ffetch (STRINGP FATSTRINGP) of X) then (for c infatstring X do (BOUT STREAM (\CHAR8CODE c))) else (\BOUTS STREAM (ffetch (STRINGP BASE) of X) (ffetch (STRINGP OFFST) of X) (ffetch (STRINGP LENGTH) of X))) elseif (LITATOM X) then (for c inatom X do (BOUT STREAM (\CHAR8CODE c))) elseif (ZEROP X) then (BOUT STREAM (CHARCODE 0)) else (if (TYPEP X 'RATIO) then (SETQ X (FLOAT X))) (for c in (CHCON X) do (BOUT STREAM (\CHAR8CODE c]) (POSTSCRIPT.PUTBITMAPBYTES [LAMBDA (STREAM BITMAP DELIMFLG) (DECLARE (GLOBALVARS PS.BITMAPARRAY) (LOCALVARS . T)) (* ; "Edited 30-Mar-90 20:15 by Matt Heffron") (LET* ((WIDTH (fetch BITMAPWIDTH of BITMAP)) (HEIGHT (fetch BITMAPHEIGHT of BITMAP)) (BMBASE (fetch BITMAPBASE of BITMAP)) (BYTESPERROW (LRSH (IPLUS WIDTH 7) 3)) (BYTEOFFSETPERROW (LSH (fetch BITMAPRASTERWIDTH of BITMAP) 1)) (PS.BITMAPARRAYBASE (fetch (ARRAYP BASE) of PS.BITMAPARRAY))) (if DELIMFLG then (LET ((POS 0) BYTE) (\FILEOUTCHARFN STREAM (CHARCODE SPACE)) (\FILEOUTCHARFN STREAM (CHARCODE <)) (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (for R from (SUB1 HEIGHT) to 0 by -1 as ROWOFFSET from (ITIMES (SUB1 HEIGHT) BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW) do (for B from 1 to BYTESPERROW as BYTEOFFSET from ROWOFFSET by 1 do (if (IGEQ POS 254) then (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (SETQ POS 0)) (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 (LRSH BYTE 4] (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE))) (SETQ POS (IPLUS POS 2))) (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (SETQ POS 0)) (\FILEOUTCHARFN STREAM (CHARCODE SPACE)) (\FILEOUTCHARFN STREAM (CHARCODE >)) (\FILEOUTCHARFN STREAM (CHARCODE EOL))) else (LET* ((PRVBM (BITMAPCREATE WIDTH 1)) (PRVBASE (fetch BITMAPBASE of PRVBM))) (for R from 0 to (SUB1 HEIGHT) as ROWOFFSET from (ITIMES (SUB1 HEIGHT) BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW) do (LET ((POS 0) (BYTEOFFSET ROWOFFSET) (B 1) (PRVO 0) BYTE REPC) [while (ILEQ B BYTESPERROW) do (SETQ REPC (for BB from B to BYTESPERROW as BO from BYTEOFFSET by 1 as PO from PRVO by 1 while (EQ (\GETBASEBYTE BMBASE BO) (\GETBASEBYTE PRVBASE PO)) count T)) (if (IGEQ REPC 3) then (SETQ B (IPLUS B REPC)) (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) (SETQ PRVO (IPLUS PRVO REPC)) (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) do (if (IGEQ POS 251) then (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (SETQ POS 0)) (BOUT STREAM (CHARCODE B)) (BOUT STREAM (CHARCODE 3)) [if (IGEQ REPC 256) then (BOUT STREAM (CHARCODE F)) (BOUT STREAM (CHARCODE F)) else [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 (LRSH REPC 4] (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 REPC] (SETQ REPC (IDIFFERENCE REPC 256)) (SETQ POS (IPLUS POS 4))) else (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) (SETQ REPC (for BB from B to BYTESPERROW as BO from BYTEOFFSET by 1 while (EQ (\GETBASEBYTE BMBASE BO) BYTE) count T)) (if (IGEQ REPC 3) then (SETQ B (IPLUS B REPC)) (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) (SETQ PRVO (IPLUS PRVO REPC)) (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) do (if (IGEQ POS 249) then (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (SETQ POS 0)) (BOUT STREAM (CHARCODE B)) (BOUT STREAM (CHARCODE 2)) [if (IGEQ REPC 256) then (BOUT STREAM (CHARCODE F)) (BOUT STREAM (CHARCODE F)) else [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 (LRSH REPC 4] (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 REPC] [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 (LRSH BYTE 4] (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE))) (SETQ REPC (IDIFFERENCE REPC 256)) (SETQ POS (IPLUS POS 4))) else (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) (if (IGEQ POS 251) then (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (SETQ POS 0)) (if (FMEMB BYTE '(178 179 180)) then (* ;; "BYTE is B2, B3, or B4; quote it") (BOUT STREAM (CHARCODE B)) (BOUT STREAM (CHARCODE 4)) (SETQ POS (IPLUS POS 2))) [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 (LRSH BYTE 4] (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE))) (SETQ B (IPLUS B 1)) (SETQ BYTEOFFSET (IPLUS BYTEOFFSET 1)) (SETQ PRVO (IPLUS PRVO 1)) (SETQ POS (IPLUS POS 2] (\FILEOUTCHARFN STREAM (CHARCODE EOL))) (\MOVEBYTES BMBASE ROWOFFSET PRVBASE 0 BYTESPERROW]) (POSTSCRIPT.PUTCOMMAND [LAMBDA S.STRS (* ; "Edited 30-Mar-90 17:37 by Matt Heffron") (LET* ((STREAM (ARG S.STRS 1)) (IMAGEDATA (fetch IMAGEDATA of STREAM)) S#S) (freplace POSTSCRIPTPAGEBLANK of IMAGEDATA with NIL) (if (ffetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA) then (POSTSCRIPT.SHOWACCUM STREAM)) (if (ffetch POSTSCRIPTPENDINGXFORM of IMAGEDATA) then (\SETXFORM.PSC STREAM IMAGEDATA)) (for STR# from 2 to S.STRS do (if (EQ (SETQ S#S (ARG S.STRS STR#)) :EOL) then (\FILEOUTCHARFN STREAM (CHARCODE EOL)) else (POSTSCRIPT.OUTSTR STREAM S#S]) (POSTSCRIPT.SHOWACCUM [LAMBDA (STREAM) (* ; "Edited 30-Mar-90 17:38 by Matt Heffron") (LET ((IMAGEDATA (ffetch IMAGEDATA of STREAM))) (if (fetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA) then [if (EQP (ffetch POSTSCRIPTSPACEFACTOR of IMAGEDATA) 1) then (POSTSCRIPT.OUTSTR STREAM ") S") else (POSTSCRIPT.OUTSTR STREAM ") ") [POSTSCRIPT.OUTSTR STREAM (DIFFERENCE (ffetch POSTSCRIPTSPACEWIDTH of IMAGEDATA) (\FGETWIDTH (ffetch POSTSCRIPTWIDTHS of IMAGEDATA) (CHARCODE SPACE] (POSTSCRIPT.OUTSTR STREAM (CONSTANT (CONCAT " 0 " (CHARCODE SPACE) " 4 -1 roll widthshow"] (\FILEOUTCHARFN STREAM (CHARCODE EOL)) (freplace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with NIL]) (POSTSCRIPT.STARTPAGE [LAMBDA (STREAM) (* ; "Edited 30-Mar-90 17:41 by Matt Heffron") (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with NIL) (* ; "shouldnt need this") (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%BeginPageSetup" :EOL "/savepage save def" :EOL (FQUOTIENT 1 \PS.SCALE0) " imagesizefactor mul dup scale" :EOL "%%%%EndPageSetup" :EOL "%%%%Page" :EOL) (\SETXFORM.PSC STREAM IMAGEDATA T) (* ;; "Lisp depends on the current font being carried over from page to page, but in postscript there is no current font at the beginning of a page, so force a setfont.") (replace POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA with T) (replace POSTSCRIPTPAGEBLANK of IMAGEDATA with T) (if (fetch POSTSCRIPTHEADING of IMAGEDATA) then (* ;; "Here we handle headings. This imitates the INTERPRESS code.") (LET [(FONT (\DSPFONT.PSC STREAM (fetch POSTSCRIPTHEADINGFONT of IMAGEDATA] (\DSPRESET.PSC STREAM) (PRIN3 (fetch POSTSCRIPTHEADING of IMAGEDATA) STREAM) (RELMOVETO (CONSTANT (TIMES 72 \PS.SCALE0)) 0 STREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " STREAM) (PRIN3 (CL:INCF (fetch POSTSCRIPTPAGENUM of IMAGEDATA)) STREAM) (\TERPRI.PSC STREAM) (* ; "Skip 2 lines") (\TERPRI.PSC STREAM) (\DSPFONT.PSC STREAM FONT)) else (\DSPRESET.PSC STREAM]) (POSTSCRIPT.TEDIT [LAMBDA (FILE PFILE) (* ; "Edited 15-Feb-91 16:34 by gadener") [SETQ FILE (OPENTEXTSTREAM (OR (STREAMP FILE) (MKATOM FILE] (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'POSTSCRIPT) (CLOSEF? FILE) PFILE]) (POSTSCRIPT.TEXT [LAMBDA (FILE PSCFILE FONTS HEADING TABS) (* ; "Edited 23-Apr-89 11:31 by TAL") (TEXTTOIMAGEFILE FILE PSCFILE 'POSTSCRIPT FONTS HEADING TABS `(REGION ,POSTSCRIPT.DEFAULT.PAGEREGION ROTATION ,(NOT (NOT POSTSCRIPT.TEXTFILE.LANDSCAPE]) (POSTSCRIPTFILEP [LAMBDA (FILE) (* ; "Edited 27-Aug-90 23:59 by jds") (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION) '("PS" "PSC") :TEST (FUNCTION STRING-EQUAL)) (PROGN (SETFILEPTR FILE 0) (AND (EQ (BIN FILE) (CHARCODE %%)) (EQ (BIN FILE) (CHARCODE !]) (PSCFONT.READFONT [LAMBDA (FONTFILENAME) (* ; "Edited 1-Sep-89 10:55 by jds") (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics.") (LET ((PF (create PSCFONT)) [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T] FID W) [replace (PSCFONT FID) of PF with (SETQ FID (READ S (FIND-READTABLE "INTERLISP"] (* ;; "Read until we hit a 255 byte, marking the end of the font-id section.") (CL:DO NIL ((EQ (BIN S) 255)) (* ;; "Body of the loop is empty, the test does all of the work") ) (replace (PSCFONT IL-FONTID) of PF with (CAR FID)) (replace (PSCFONT FIRSTCHAR) of PF with (\WIN S)) (replace (PSCFONT LASTCHAR) of PF with (\WIN S)) (replace (PSCFONT ASCENT) of PF with (\WIN S)) (replace (PSCFONT DESCENT) of PF with (\WIN S)) (replace (PSCFONT WIDTHS) of PF with (SETQ W (ARRAY 256 'SMALLPOSP 0 0))) (for C from 0 to 255 do (SETA W C (\WIN S))) (CLOSEF S) (* ;;  "PATCH JDS 9/1/89: The afm font reader made fonts too tall. This should fix things pro tem.") (replace (PSCFONT ASCENT) of PF with (- 1000 (fetch (PSCFONT DESCENT) OF PF))) PF]) (PSCFONT.SPELLFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 3-Apr-89 13:30 by TAL") (FINDFILE (\FONTFILENAME (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST)) FAMILY) SIZE FACE '.PSCFONT) NIL POSTSCRIPTFONTDIRECTORIES]) (PSCFONT.WRITEFONT [LAMBDA (FONTFILENAME PF) (* ; "Edited 15-Oct-87 11:12 by Matt Heffron") (LET ([S (OPENSTREAM FONTFILENAME 'OUTPUT NIL '((TYPE BINARY) (SEQUENTIAL T] (W (fetch (PSCFONT WIDTHS) of PF)) (*READTABLE* (FIND-READTABLE "INTERLISP"))) (PRIN3 (fetch (PSCFONT FID) of PF) S) (BOUT S 0) (BOUT S 255) (\WOUT S (fetch (PSCFONT FIRSTCHAR) of PF)) (\WOUT S (fetch (PSCFONT LASTCHAR) of PF)) (\WOUT S (fetch (PSCFONT ASCENT) of PF)) (\WOUT S (fetch (PSCFONT DESCENT) of PF)) (for C from 0 to 255 do (\WOUT S (ELT W C))) (CLOSEF S) FONTFILENAME]) (READ-AFM-FILE [LAMBDA (FILE) (* ; "Edited 20-Jan-88 17:22 by Matt Heffron") (LET ((IFILE (OPENSTREAM FILE 'INPUT)) (PSCFONT (create PSCFONT)) (FCHAR 1000) (LCHAR 0) (W (ARRAY 256 'SMALLPOSP 0 0)) TOKEN WEIGHT SLOPE CMCOUNT FBBOX) (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE)) do (READCCODE IFILE)) (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE))) do (READCCODE IFILE)) [if (NOT (AND (BOUNDP 'WeightMenu) (type? MENU WeightMenu))) then (SETQ WeightMenu (create MENU ITEMS _ WeightMenuItems MENUFONT _ (FONTCREATE 'HELVETICA 12] [if (NOT (AND (BOUNDP 'SlopeMenu) (type? MENU SlopeMenu))) then (SETQ SlopeMenu (create MENU ITEMS _ SlopeMenuItems MENUFONT _ (FONTCREATE 'HELVETICA 12] (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu)) T) (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu)) T) (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR)) [SETQ IL-FONTID (if (AND (EQ SLOPE 'REGULAR) (EQ WEIGHT 'MEDIUM)) then TOKEN else (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR] (repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN) do (SETQ TOKEN (RSTRING IFILE)) (if (STRING-EQUAL "FontBBox" TOKEN) then (SETQ FBBOX (LIST (READ IFILE) (READ IFILE) (READ IFILE) (READ IFILE))) (* ;; "The Ascender and Descender properties from the AFM file are currently ignored, and the values from the FontBBox are used.") (SETQ DESCENT (IABS (CADR FBBOX))) (SETQ ASCENT (CADDDR FBBOX)) else (READCCODE IFILE))) (SETQ CMCOUNT (RATOM IFILE)) (repeatuntil (EQ (CHARCODE EOL) (READCCODE IFILE)) do) (SETQ WIDTHS W) (for CC from 1 to CMCOUNT do (LET (CCODE) (repeatuntil (EQ 'C (RATOM IFILE)) do) (SETQ CCODE (READ IFILE)) (if (CL:PLUSP CCODE) then (if (ILESSP CCODE FCHAR) then (SETQ FCHAR CCODE)) (if (IGREATERP CCODE LCHAR) then (SETQ LCHAR CCODE)) (RATOMS 'WX IFILE) (SETA W CCODE (READ IFILE))) (repeatuntil (EQ (CHARCODE EOL) (READCCODE IFILE)) do))) (SETQ FIRSTCHAR FCHAR) (SETQ LASTCHAR LCHAR)) (CLOSEF IFILE) PSCFONT]) (\BITBLT.PSC [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 7-Apr-89 19:53 by TAL") (\SCALEDBITBLT.PSC SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM 1]) (\BLTSHADE.PSC [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 30-Mar-90 17:44 by Matt Heffron") (* ;; "Maybe we should do something with OPERATION") (LET ((RGN (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT)) (IMAGEDATA (fetch IMAGEDATA of STREAM)) TEXTUREBM TEXTUREWIDTH LEFT BOTTOM WIDTH HEIGHT) [if CLIPPINGREGION then (SETQ RGN (INTERSECTREGIONS RGN CLIPPINGREGION (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))) else (SETQ RGN (INTERSECTREGIONS RGN (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA ] (if RGN then (SETQ LEFT (fetch (REGION LEFT) of RGN)) (SETQ BOTTOM (fetch (REGION BOTTOM) of RGN)) (SETQ WIDTH (CL:1- (fetch (REGION WIDTH) of RGN))) (SETQ HEIGHT (CL:1- (fetch (REGION HEIGHT) of RGN))) (if (FIXP TEXTURE) then (SETQ TEXTURE (SELECT TEXTURE ((BLACKSHADE -1) 0.0) (WHITESHADE 1.0) TEXTURE))) (if (AND (FLOATP TEXTURE) (<= 0.0 TEXTURE 1.0)) then (POSTSCRIPT.PUTCOMMAND STREAM HEIGHT " " WIDTH " " LEFT " " BOTTOM " " TEXTURE " R" :EOL) elseif (OR (TEXTUREP TEXTURE) (NULL TEXTURE)) then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) (SETQ TEXTUREWIDTH 16) (BLTSHADE TEXTURE TEXTUREBM) elseif (BITMAPP TEXTURE) then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) (fetch BITMAPHEIGHT of TEXTUREBM))) (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) (if TEXTUREBM then (POSTSCRIPT.PUTCOMMAND STREAM "gsave newpath ") (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale " (QUOTIENT LEFT 100.0) " " (QUOTIENT BOTTOM 100.0) " M " (SETQ WIDTH (QUOTIENT WIDTH 100.0)) " 0 rlineto 0 " (QUOTIENT HEIGHT 100.0) " rlineto " (MINUS WIDTH) " 0 rlineto closepath" :EOL) (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch BITMAPRASTERWIDTH of TEXTUREBM) 1) " 0 " (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) 100.0)) " findresolution " TEXTUREWIDTH " div div ceiling " POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) T else NIL]) (\CHARWIDTH.PSC [LAMBDA (STREAM CHARCODE) (* ; "Edited 14-Jul-89 14:37 by Matt Heffron") (* ;; "no NS character set treatment yet") (LET ((IMAGEDATA (ffetch IMAGEDATA of STREAM))) (if (EQ CHARCODE (CHARCODE SPACE)) then (fetch POSTSCRIPTSPACEWIDTH of IMAGEDATA) else (\FGETWIDTH (fetch POSTSCRIPTWIDTHS of IMAGEDATA) (\CHAR8CODE CHARCODE]) (\DRAWARC.PSC [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* ; "Edited 30-Mar-90 17:46 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) WIDTH COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) elseif (LISTP BRUSH) then (if (NEQ (fetch BRUSHSHAPE of BRUSH) 'ROUND) then (printout T T "[In \DRAWARC.PSC: Non-ROUND BRUSH not supported.] [Using ROUND BRUSH]" T)) (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;  "If FUNCTIONAL BRUSH big trouble!") (printout T T "[In \DRAWARC.PSC: Functional BRUSH not supported.] [Using ROUND 1 point BRUSH]" T) (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA))) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;  "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL) (* ;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX " " CENTERY " " RADIUS " " STARTANGLE " " (+ STARTANGLE NDEGREES) " arc stroke" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWCIRCLE.PSC [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* ; "Edited 30-Mar-90 17:48 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) WIDTH COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) elseif (LISTP BRUSH) then (if (NEQ (fetch BRUSHSHAPE of BRUSH) 'ROUND) then (printout T T "[In \DRAWCIRCLE.PSC: Non-ROUND BRUSH not supported.] [Using ROUND BRUSH]" T)) (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;  "If FUNCTIONAL BRUSH big trouble!") (printout T T "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA))) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;  "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL) (* ;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX " " CENTERY " " RADIUS " 0 360 arc stroke" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWCURVE.PSC [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 30-Mar-90 20:12 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) (SETQ SHAPE 'ROUND) elseif (LISTP BRUSH) then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") (printout T T "[In \DRAWCURVE.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA)) (SETQ SHAPE 'ROUND)) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ") (* ;;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL)) (SETQ PSPLINE (PARAMETRICSPLINE KNOTS CLOSED NIL)) (SETQ N (pop PSPLINE)) (SETQ XA (pop PSPLINE)) (SETQ YA (pop PSPLINE)) (SETQ DXA (pop PSPLINE)) (SETQ DYA (pop PSPLINE)) (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE (ROUND " 1 setlinecap 1 setlinejoin ") (SQUARE " 2 setlinecap 0 setlinejoin ") " 0 setlinecap 0 setlinejoin ") WIDTH " setlinewidth " (SETQ PREVX (ELT XA 1)) " " (SETQ PREVY (ELT YA 1)) " M" :EOL) (SETQ PREV-DX3 (FQUOTIENT (ELT DXA 1) 3.0)) (SETQ PREV-DY3 (FQUOTIENT (ELT DYA 1) 3.0)) (for C from 2 to N do (POSTSCRIPT.PUTCOMMAND STREAM (FPLUS PREVX PREV-DX3) " " (FPLUS PREVY PREV-DY3) " " (FDIFFERENCE (SETQ PREVX (ELT XA C)) (SETQ PREV-DX3 (FQUOTIENT (ELT DXA C) 3.0))) " " (FDIFFERENCE (SETQ PREVY (ELT YA C)) (SETQ PREV-DY3 (FQUOTIENT (ELT DYA C) 3.0))) " " PREVX " " PREVY " curveto" :EOL)) (POSTSCRIPT.PUTCOMMAND STREAM "stroke" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM PREVX PREVY)) NIL]) (\DRAWELLIPSE.PSC [LAMBDA (STREAM CENTERX CENTERY MINORRADIUS MAJORRADIUS ORIENTATION BRUSH DASHING) (* ; "Edited 30-Mar-90 17:51 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) WIDTH COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) elseif (LISTP BRUSH) then (if (NEQ (fetch BRUSHSHAPE of BRUSH) 'ROUND) then (printout T T "[In \DRAWELLIPSE.PSC: Non-ROUND BRUSH not supported.] [Using ROUND BRUSH]" T)) (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;  "If FUNCTIONAL BRUSH, big trouble!") (printout T T "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA))) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;  "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ") (* ;;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL)) (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX " " CENTERY " " MAJORRADIUS " " MINORRADIUS " " ORIENTATION " 0 360 ellipse stroke" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWLINE.PSC [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 30-Mar-90 17:52 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (if (NOT (NUMBERP WIDTH)) then (* ;; "The WIDTH = NIL should have been handled before here, but just in case!") (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA))) (if (NOT (ZEROP WIDTH)) then (if (NOT (OR (FLOATP COLOR) (LISTP DASHING))) then (* ; "Simple case, no dash or gray") (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " L" :EOL) else (* ;  "COLOR is interpreted as gray factor") (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " " (OR (FLOATP COLOR) "0") " [") (for D in (LISTP DASHING) do (* ;;  "Interlisp DASHING is in terms of BRUSH units, so multiply by the brush size.") (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.PUTCOMMAND STREAM "] L1" :EOL))) (replace POSTSCRIPTX of IMAGEDATA with X2) (freplace POSTSCRIPTY of IMAGEDATA with Y2) (freplace POSTSCRIPTMOVEFLG of IMAGEDATA with NIL]) (\DRAWPOINT.PSC [LAMBDA (STREAM X Y BRUSH OPERATION) (* ; "Edited 30-Mar-90 17:53 by Matt Heffron") (* ;; "draw a point on the stream ") (if (BITMAPP BRUSH) then (LET ((WIDTH (fetch BITMAPWIDTH of BRUSH)) (HEIGHT (fetch BITMAPHEIGHT of BRUSH))) (BITBLT BRUSH 0 0 STREAM (- X (IQUOTIENT WIDTH 2)) (- Y (IQUOTIENT HEIGHT 2)) WIDTH HEIGHT OPERATION)) else (\DRAWLINE.PSC STREAM X Y X Y BRUSH OPERATION]) (\DRAWPOLYGON.PSC [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 30-Mar-90 17:54 by Matt Heffron") (LET ((LASTPOINT (CAR (LAST POINTS))) (IMAGEDATA (fetch IMAGEDATA of STREAM)) WIDTH SHAPE COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) (SETQ SHAPE 'ROUND) elseif (LISTP BRUSH) then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") (printout T T "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA)) (SETQ SHAPE 'ROUND)) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ") (* ;;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL)) (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE (ROUND " 1 setlinecap 1 setlinejoin ") (SQUARE " 2 setlinecap 0 setlinejoin ") " 0 setlinecap 0 setlinejoin ") WIDTH " setlinewidth " (fetch XCOORD of (CAR POINTS)) " " (fetch YCOORD of (CAR POINTS)) " M" :EOL) (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of P) " " (fetch YCOORD of P) " lineto" :EOL)) (if CLOSED then (POSTSCRIPT.PUTCOMMAND STREAM " closepath")) (POSTSCRIPT.PUTCOMMAND STREAM " stroke" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT) (fetch YCOORD of LASTPOINT]) (\DSPBOTTOMMARGIN.PSC [LAMBDA (STREAM YPOSITION) (* ; "Edited 12-Jan-88 13:14 by Matt Heffron") (PROG1 (fetch POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM)) (if YPOSITION then (replace POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM) with YPOSITION)))]) (\DSPCLIPPINGREGION.PSC [LAMBDA (STREAM REGION) (* ; "Edited 14-Jul-89 14:41 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (OLDCLIP (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))) (if [AND REGION (NOT (AND (EQP (fetch LEFT of OLDCLIP) (fetch LEFT of REGION)) (EQP (fetch BOTTOM of OLDCLIP) (fetch BOTTOM of REGION)) (EQP (fetch WIDTH of OLDCLIP) (fetch WIDTH of REGION)) (EQP (fetch HEIGHT of OLDCLIP) (fetch HEIGHT of REGION] then (POSTSCRIPT.SHOWACCUM STREAM) (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with REGION) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T) (\FIXLINELENGTH.PSC STREAM IMAGEDATA)) OLDCLIP]) (\DSPFONT.PSC [LAMBDA (STREAM FONT) (* ; "Edited 14-Jul-89 14:42 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (OLDFONT (fetch POSTSCRIPTFONT of IMAGEDATA)) NEWFONT) (if (AND FONT (SETQ NEWFONT (OR (\COERCEFONTDESC FONT STREAM) (FONTCOPY OLDFONT FONT))) (type? FONTDESCRIPTOR NEWFONT) (NEQ NEWFONT OLDFONT)) then (POSTSCRIPT.SHOWACCUM STREAM) (replace POSTSCRIPTFONT of IMAGEDATA with NEWFONT) (replace POSTSCRIPTWIDTHS of IMAGEDATA with (fetch (CHARSETINFO WIDTHS) of (\GETBASEPTR (fetch FONTCHARSETVECTOR of NEWFONT ) 0))) [replace POSTSCRIPTSPACEWIDTH of IMAGEDATA with (FIXR (TIMES (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA) (\FGETWIDTH (fetch POSTSCRIPTWIDTHS of IMAGEDATA ) (CHARCODE SPACE] (replace POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA with T) (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of NEWFONT))) (\FIXLINELENGTH.PSC STREAM IMAGEDATA)) OLDFONT]) (\DSPLEFTMARGIN.PSC [LAMBDA (STREAM XPOSITION) (* ; "Edited 6-Apr-89 14:01 by TAL") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (PROG1 (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) (COND (XPOSITION (replace POSTSCRIPTLEFTMARGIN of IMAGEDATA with XPOSITION) (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) (\DSPLINEFEED.PSC [LAMBDA (STREAM LINELEADING) (* ; "Edited 12-Jan-88 13:16 by Matt Heffron") (PROG1 (fetch POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM)) (if LINELEADING then (replace POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM) with LINELEADING)))]) (\DSPRESET.PSC [LAMBDA (STREAM) (* ; "Edited 6-Apr-89 13:18 by TAL") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (replace (STREAM CHARPOSITION) of STREAM with 0) (\MOVETO.PSC STREAM (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) (DIFFERENCE (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA) (FONTPROP (fetch POSTSCRIPTFONT of IMAGEDATA) 'ASCENT]) (\DSPRIGHTMARGIN.PSC [LAMBDA (STREAM XPOSITION) (* ; "Edited 14-Jul-89 14:44 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (PROG1 (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA) (if XPOSITION then (replace POSTSCRIPTRIGHTMARGIN of IMAGEDATA with XPOSITION) (\FIXLINELENGTH.PSC STREAM IMAGEDATA)))]) (\DSPROTATE.PSC [LAMBDA (STREAM ROTATION) (* ; "Edited 27-Jul-89 18:03 by Matt Heffron") (* ;; "rotate the postscript stream by ROTATION") (* ;;  "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).") (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) (OLAND (COND ((fetch POSTSCRIPTLANDSCAPE of IMAGEDATA) 90) (T 0))) LAND C0 P0 C P ML MB MR MT) (if (AND ROTATION (NEQ (SETQ LAND (NOT (ZEROP ROTATION))) (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA))) then (POSTSCRIPT.SHOWACCUM STREAM) (\DSPTRANSLATE.PSC STREAM 0 0) (SETQ C0 (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)) (SETQ P0 (fetch POSTSCRIPTPAGEREGION of IMAGEDATA)) (SETQ C (create REGION WIDTH _ (fetch HEIGHT of C0) HEIGHT _ (fetch WIDTH of C0))) (SETQ P (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch HEIGHT of P0) HEIGHT _ (fetch WIDTH of P0))) (if LAND then (replace LEFT of C with (fetch BOTTOM of C0)) [replace BOTTOM of C with (- (fetch WIDTH of P0) (+ (fetch LEFT of C0) (fetch WIDTH of C0] (SETQ ML (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA)) (SETQ MB (- (fetch WIDTH of P0) (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA) 1)) (SETQ MR (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA)) (SETQ MT (- (fetch WIDTH of P0) (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) 1)) else [replace LEFT of C with (- (fetch HEIGHT of P0) (+ (fetch BOTTOM of C0) (fetch HEIGHT of C0] (replace BOTTOM of C with (fetch LEFT of C0)) (SETQ ML (- (fetch HEIGHT of P0) (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA) 1)) (SETQ MB (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)) (SETQ MR (- (fetch HEIGHT of P0) (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA) 1)) (SETQ MT (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA))) (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with C) (replace POSTSCRIPTPAGEREGION of IMAGEDATA with P) (replace POSTSCRIPTLEFTMARGIN of IMAGEDATA with ML) (replace POSTSCRIPTBOTTOMMARGIN of IMAGEDATA with MB) (replace POSTSCRIPTRIGHTMARGIN of IMAGEDATA with MR) (replace POSTSCRIPTTOPMARGIN of IMAGEDATA with MT) (replace POSTSCRIPTLANDSCAPE of IMAGEDATA with LAND) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T) (\DSPRESET.PSC STREAM)) OLAND]) (\DSPSCALE.PSC [LAMBDA (STREAM SCALE) (* ; "Edited 30-Mar-90 17:56 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (OSCALE (fetch POSTSCRIPTSCALE of IMAGEDATA)) NSCALE) (if (AND NIL (* ;; "Changing SCALE is not implemented. According to IRM.") (NUMBERP SCALE) (CL:PLUSP SCALE)) then (SETQ NSCALE (QUOTIENT SCALE OSCALE)) (* ;;  "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.") (POSTSCRIPT.PUTCOMMAND STREAM " " NSCALE " " NSCALE " scale" :EOL) (replace POSTSCRIPTSCALE of IMAGEDATA with SCALE)) OSCALE]) (\DSPSPACEFACTOR.PSC [LAMBDA (STREAM FACTOR) (* ; "Edited 14-Jul-89 14:48 by Matt Heffron") (DECLARE (LOCALVARS . T)) (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (OLDFACTOR (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA))) [if (AND (NUMBERP FACTOR) (NOT (EQUAL FACTOR OLDFACTOR))) then (POSTSCRIPT.SHOWACCUM STREAM) (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with FACTOR) (replace POSTSCRIPTSPACEWIDTH of IMAGEDATA with (FIXR (TIMES FACTOR (\FGETWIDTH (fetch POSTSCRIPTWIDTHS of IMAGEDATA) (CHARCODE SPACE] OLDFACTOR]) (\DSPTOPMARGIN.PSC [LAMBDA (STREAM YPOSITION) (* ; "Edited 12-Jan-88 13:17 by Matt Heffron") (PROG1 (fetch POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM)) (if YPOSITION then (replace POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM) with YPOSITION)))]) (\DSPTRANSLATE.PSC [LAMBDA (STREAM TX TY) (* ; "Edited 14-Jul-89 14:58 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (MDX (DIFFERENCE (fetch POSTSCRIPTTRANSX of IMAGEDATA) TX)) (MDY (DIFFERENCE (fetch POSTSCRIPTTRANSY of IMAGEDATA) TY))) (if (NOT (AND (ZEROP MDX) (ZEROP MDY))) then (POSTSCRIPT.SHOWACCUM STREAM) (for REG in (LIST (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA) (fetch POSTSCRIPTPAGEREGION of IMAGEDATA)) do (CL:INCF (fetch LEFT of REG) MDX) (CL:INCF (fetch BOTTOM of REG) MDY)) (CL:INCF (fetch POSTSCRIPTX of IMAGEDATA) MDX) (CL:INCF (fetch POSTSCRIPTY of IMAGEDATA) MDY) (CL:INCF (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) MDX) (CL:INCF (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA) MDX) (CL:INCF (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA) MDY) (CL:INCF (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA) MDY) (replace POSTSCRIPTTRANSX of IMAGEDATA with TX) (replace POSTSCRIPTTRANSY of IMAGEDATA with TY) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T]) (\DSPXPOSITION.PSC [LAMBDA (STREAM XPOSITION) (* ; "Edited 9-Sep-88 10:58 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) OLDX) (PROG1 (SETQ OLDX (fetch POSTSCRIPTX of IMAGEDATA)) (if (AND XPOSITION (NOT (EQUAL XPOSITION OLDX))) then (\MOVETO.PSC STREAM XPOSITION (fetch POSTSCRIPTY of IMAGEDATA)) ))]) (\DSPYPOSITION.PSC [LAMBDA (STREAM YPOSITION) (* ; "Edited 9-Sep-88 10:58 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) OLDY) (PROG1 (SETQ OLDY (fetch POSTSCRIPTY of IMAGEDATA)) (if (AND YPOSITION (NOT (EQUAL YPOSITION OLDY))) then (\MOVETO.PSC STREAM (fetch POSTSCRIPTX of IMAGEDATA) YPOSITION)))]) (\FILLCIRCLE.PSC [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 30-Mar-90 17:59 by Matt Heffron") (LET (TEXTUREBM TEXTUREWIDTH) (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (FIXP TEXTURE) then (if (ZEROP TEXTURE) then (SETQ TEXTURE 1.0) (* ; "The setgray version of white") elseif (OR (EQL TEXTURE 65535) (EQL TEXTURE -1)) then (SETQ TEXTURE 0.0) (* ; "The setgray version of black") )) (if (FLOATP TEXTURE) then (* ;;  "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.") (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ") elseif (OR (TEXTUREP TEXTURE) (NULL TEXTURE)) then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) (SETQ TEXTUREWIDTH 16) (BLTSHADE TEXTURE TEXTUREBM) elseif (BITMAPP TEXTURE) then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) (fetch BITMAPHEIGHT of TEXTUREBM))) (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) (POSTSCRIPT.PUTCOMMAND STREAM " " CENTERX " " CENTERY " " RADIUS " 0 360 arc" :EOL) (if TEXTUREBM then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ") (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch BITMAPRASTERWIDTH of TEXTUREBM) 1) " 0 " (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) 100.0)) " findresolution " TEXTUREWIDTH " div div ceiling " POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" :EOL) else (POSTSCRIPT.PUTCOMMAND STREAM " eofill" :EOL "grestore" :EOL)) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\FILLPOLYGON.PSC [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER) (* ; "Edited 30-Mar-90 18:01 by Matt Heffron") (DECLARE (SPECVARS FILL.WRULE)) (* ;; "OPERATION is ignored here") (LET ((LASTPOINT (CAR (LAST KNOTS))) TEXTUREBM TEXTUREWIDTH) (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") (if (NOT (OR (ZEROP WINDNUMBER) (EQL WINDNUMBER 1))) then (SETQ WINDNUMBER FILL.WRULE)) (if (FIXP TEXTURE) then (if (ZEROP TEXTURE) then (SETQ TEXTURE 1.0) (* ; "The setgray version of white") elseif (OR (EQL TEXTURE 65535) (EQL TEXTURE -1)) then (SETQ TEXTURE 0.0) (* ; "The setgray version of black") )) (if (FLOATP TEXTURE) then (* ;;  "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.") (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ") elseif (OR (TEXTUREP TEXTURE) (NULL TEXTURE)) then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) (SETQ TEXTUREWIDTH 16) (BLTSHADE TEXTURE TEXTUREBM) elseif (BITMAPP TEXTURE) then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) (fetch BITMAPHEIGHT of TEXTUREBM))) (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of (CAR KNOTS)) " " (fetch YCOORD of (CAR KNOTS)) " M" :EOL) (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of K) " " (fetch YCOORD of K) " lineto" :EOL)) (POSTSCRIPT.PUTCOMMAND STREAM " closepath" :EOL) (if TEXTUREBM then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ") (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch BITMAPRASTERWIDTH of TEXTUREBM) 1) " 0 " (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) 100.0)) " findresolution " TEXTUREWIDTH " div div ceiling " POSTSCRIPT.TEXTURE.SCALE " mul setpattern")) (POSTSCRIPT.PUTCOMMAND STREAM (if (ZEROP WINDNUMBER) then " fill" else " eofill") :EOL "grestore" :EOL) (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT) (fetch YCOORD of LASTPOINT]) (\FIXLINELENGTH.PSC [LAMBDA (STREAM IMAGEDATA) (* ; "Edited 27-Jul-89 17:59 by Matt Heffron") (* ;; "Called by margin, font or rotation change to update the LINELENGTH field in the stream.") (LET [(TMP (MIN MAX.SMALLP (FIX (QUOTIENT (DIFFERENCE (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA) (ffetch POSTSCRIPTLEFTMARGIN of IMAGEDATA )) (fetch FONTAVGCHARWIDTH of (ffetch POSTSCRIPTFONT of IMAGEDATA] (replace (STREAM LINELENGTH) of STREAM with (if (GREATERP TMP 1) then TMP else 10]) (\MOVETO.PSC [LAMBDA (STREAM X Y) (* ; "Edited 14-Jul-89 14:49 by Matt Heffron") (LET ((IMAGEDATA (ffetch IMAGEDATA of STREAM))) (if [NOT (AND (EQP X (fetch POSTSCRIPTX of IMAGEDATA)) (EQP Y (ffetch POSTSCRIPTY of IMAGEDATA] then (POSTSCRIPT.SHOWACCUM STREAM) (freplace POSTSCRIPTX of IMAGEDATA with X) (freplace POSTSCRIPTY of IMAGEDATA with Y) (freplace POSTSCRIPTMOVEFLG of IMAGEDATA with T]) (\NEWPAGE.PSC [LAMBDA (STREAM) (* ; "Edited 5-Apr-89 17:31 by TAL") (POSTSCRIPT.ENDPAGE STREAM) (POSTSCRIPT.STARTPAGE STREAM]) (\POSTSCRIPTTAB [LAMBDA (POSTSCRIPTDATA) (* ; "Edited 2-Apr-89 14:22 by TAL") (LET [(TABSPACE (TIMES 8 (ffetch FONTAVGCHARWIDTH of (ffetch POSTSCRIPTFONT of POSTSCRIPTDATA] (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (ffetch POSTSCRIPTX of POSTSCRIPTDATA ) (ffetch POSTSCRIPTLEFTMARGIN of POSTSCRIPTDATA )) TABSPACE]) (\PS.BOUTFIXP [LAMBDA (STREAM N) (* ; "Edited 14-Jul-89 14:11 by Matt Heffron") (* ;; "BOUT the decimal representation of N to STREAM using temp storage from the imagedata. Done this way for speed.") (DECLARE (LOCALVARS . T)) (if (MINUSP N) then (BOUT STREAM (CHARCODE -)) (SETQ N (IMINUS N))) (if (LESSP N 10) then (BOUT STREAM (IPLUS N (CHARCODE 0))) elseif (LESSP N 1000000000) then (LET ([BASE (fetch (ARRAYP BASE) of (fetch POSTSCRIPTTEMPARRAY of (fetch (STREAM IMAGEDATA) of STREAM] (i (SUB1 \PS.TEMPARRAYLEN))) [for old i by -1 do (\PUTBASEBYTE BASE i (IPLUS (IREMAINDER N 10) (CHARCODE 0))) repeatwhile (NEQ 0 (SETQ N (IQUOTIENT N 10] (\BOUTS STREAM BASE i (IDIFFERENCE \PS.TEMPARRAYLEN i))) else (* ; "Just in case we get a bignum") (for c in (CHCON N) do (BOUT STREAM (\CHAR8CODE c]) (\PS.SCALEHACK [LAMBDA (STREAM SCALEFACTOR) (* ; "Edited 14-Jul-89 15:03 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (OLDSCALE (fetch POSTSCRIPTSCALEHACK of IMAGEDATA)) FACTOR) (if (AND (NUMBERP SCALEFACTOR) (NOT (EQP OLDSCALE SCALEFACTOR))) then (POSTSCRIPT.SHOWACCUM STREAM) (SETQ FACTOR (/ OLDSCALE SCALEFACTOR)) [for REG in (LIST (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA) (fetch POSTSCRIPTPAGEREGION of IMAGEDATA)) do (change (fetch LEFT of REG) (FIXR (CL:* DATUM FACTOR))) (change (fetch BOTTOM of REG) (FIXR (CL:* DATUM FACTOR))) (change (fetch WIDTH of REG) (FIXR (CL:* DATUM FACTOR))) (change (fetch HEIGHT of REG) (FIXR (CL:* DATUM FACTOR] (change (fetch POSTSCRIPTX of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTY of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTTRANSX of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (change (fetch POSTSCRIPTTRANSY of IMAGEDATA) (FIXR (CL:* DATUM FACTOR))) (replace POSTSCRIPTSCALEHACK of IMAGEDATA with SCALEFACTOR) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T)) OLDSCALE]) (\PS.SCALEREGION [LAMBDA (SCALE REGION) (* ; "Edited 5-Apr-89 16:15 by TAL") (* ; "Scales a region") (create REGION LEFT _ (FIXR (TIMES SCALE (fetch (REGION LEFT) of REGION))) BOTTOM _ (FIXR (TIMES SCALE (fetch (REGION BOTTOM) of REGION))) WIDTH _ (FIXR (TIMES SCALE (fetch (REGION WIDTH) of REGION))) HEIGHT _ (FIXR (TIMES SCALE (fetch (REGION HEIGHT) of REGION]) (\SCALEDBITBLT.PSC [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE) (* ; "Edited 30-Mar-90 19:06 by Matt Heffron") (* ;; "Postscript can only handle OPERATION REPLACE and PAINT. SOURCETYPE = TEXTURE is converted to BLTSHADE before getting here (so the TEXTURE argument can be ignored). If the destination region lies completely outside the clipping region we do nothing, otherwise we output the whole thing and let the printer clip. Could be more clever.") (OR (NUMBERP SCALE) (SETQ SCALE 1)) (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (SCALE1 (TIMES SCALE (fetch POSTSCRIPTSCALE of IMAGEDATA))) (SCALE2 (TIMES SCALE1 (OR (NUMBERP POSTSCRIPT.BITMAP.SCALE) 1))) DESTREGION (BITMAPWIDTH (fetch BITMAPWIDTH of SOURCEBITMAP)) (BITMAPHEIGHT (fetch BITMAPHEIGHT of SOURCEBITMAP)) TEMPBM) (if (NULL DESTINATIONLEFT) then (SETQ DESTINATIONLEFT (fetch POSTSCRIPTX of IMAGEDATA))) (if (NULL DESTINATIONBOTTOM) then (SETQ DESTINATIONBOTTOM (fetch POSTSCRIPTY of IMAGEDATA))) (if (OR (NULL WIDTH) (NULL HEIGHT)) then (SETQ WIDTH BITMAPWIDTH) (SETQ HEIGHT BITMAPHEIGHT) elseif (OR (GREATERP WIDTH BITMAPWIDTH) (GREATERP HEIGHT BITMAPHEIGHT)) then (SETQ WIDTH (FIXR (QUOTIENT WIDTH SCALE1))) (SETQ HEIGHT (FIXR (QUOTIENT HEIGHT SCALE1))) (if (OR (GREATERP WIDTH BITMAPWIDTH) (GREATERP HEIGHT BITMAPHEIGHT)) then (SETQ WIDTH BITMAPWIDTH) (SETQ HEIGHT BITMAPHEIGHT))) [SETQ DESTREGION (INTERSECTREGIONS (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA) (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES SCALE1 WIDTH ) (TIMES SCALE1 HEIGHT] (if (AND DESTREGION (OR (NULL CLIPPINGREGION) (REGIONSINTERSECTP DESTREGION CLIPPINGREGION))) then (if (AND (EQ SOURCELEFT 0) (EQ SOURCEBOTTOM 0) (EQP WIDTH BITMAPWIDTH) (EQP HEIGHT BITMAPHEIGHT)) then (* ;  "Avoid copy if sending entire bitmap") (SETQ TEMPBM SOURCEBITMAP) else (SETQ TEMPBM (BITMAPCREATE WIDTH HEIGHT 1)) (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM TEMPBM 0 0 WIDTH HEIGHT SOURCETYPE 'REPLACE)) (POSTSCRIPT.PUTCOMMAND STREAM "/bitbltsave save def " DESTINATIONLEFT " " DESTINATIONBOTTOM " translate " (TIMES SCALE2 WIDTH) " " (TIMES SCALE2 HEIGHT) " scale " WIDTH " " HEIGHT (if (EQ OPERATION 'PAINT) then " true" else " false") " thebitimage" :EOL) (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL) (POSTSCRIPT.PUTCOMMAND STREAM :EOL "bitbltsave restore" :EOL) (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) T else NIL]) (\SETPOS.PSC [LAMBDA (STREAM IMAGEDATA) (* ; "Edited 3-Apr-89 18:09 by TAL") (POSTSCRIPT.PUTCOMMAND STREAM (fetch POSTSCRIPTX of IMAGEDATA) " " (ffetch POSTSCRIPTY of IMAGEDATA) " M ") (freplace POSTSCRIPTMOVEFLG of IMAGEDATA with NIL]) (\SETXFORM.PSC [LAMBDA (STREAM IMAGEDATA NORESTORE) (* ; "Edited 4-Apr-90 17:22 by Matt Heffron") (LET ((CLIP (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))) (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with NIL) (if (NOT NORESTORE) then (POSTSCRIPT.OUTSTR STREAM "grestore ")) (POSTSCRIPT.PUTCOMMAND STREAM "gsave" :EOL) (if (NOT (EQP (fetch POSTSCRIPTSCALEHACK of IMAGEDATA) 1)) then (POSTSCRIPT.PUTCOMMAND STREAM (fetch POSTSCRIPTSCALEHACK of IMAGEDATA ) " dup scale" :EOL)) (if (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA) then (POSTSCRIPT.OUTSTR STREAM " 90 rotate ")) (if [NOT (AND (ZEROP (fetch POSTSCRIPTTRANSX of IMAGEDATA)) (ZEROP (fetch POSTSCRIPTTRANSY of IMAGEDATA] then (POSTSCRIPT.PUTCOMMAND STREAM (fetch POSTSCRIPTTRANSX of IMAGEDATA) " " (fetch POSTSCRIPTTRANSY of IMAGEDATA) " translate" :EOL)) (POSTSCRIPT.PUTCOMMAND STREAM (fetch HEIGHT of CLIP) " " (fetch WIDTH of CLIP) " " (fetch LEFT of CLIP) " " (fetch BOTTOM of CLIP) " CLP" :EOL) (replace POSTSCRIPTMOVEFLG of IMAGEDATA with T) (replace POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA with T]) (\STRINGWIDTH.PSC [LAMBDA (STREAM STR RDTBL) (* ; "Edited 2-Apr-89 18:13 by TAL") (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) (\STRINGWIDTH.GENERIC STR (fetch POSTSCRIPTFONT of IMAGEDATA) RDTBL (ffetch POSTSCRIPTSPACEWIDTH of IMAGEDATA]) (\SWITCHFONTS.PSC [LAMBDA (STREAM POSTSCRIPTDATA) (* ; "Edited 30-Mar-90 18:07 by Matt Heffron") (LET* [(FONT (ffetch POSTSCRIPTFONT of POSTSCRIPTDATA)) (FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS ) of FONT) 'PSCFONT] (if (LISTP FONTID) then (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch FONTIDNAME of FONTID) " findfont [" (TIMES (fetch FONTXFACTOR of FONTID) (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " 0 " (TIMES (fetch FONTOBLIQUEFACTOR of FONTID) (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " " (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " 0 0] makefont setfont" :EOL) else (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " /" FONTID " F" :EOL)) (replace POSTSCRIPTFONTCHANGEDFLG of POSTSCRIPTDATA with NIL]) (\TERPRI.PSC [LAMBDA (STREAM) (* ; "Edited 30-Mar-90 18:08 by Matt Heffron") (LET* [(IMAGEDATA (fetch IMAGEDATA of STREAM)) (NEWY (PLUS (ffetch POSTSCRIPTY of IMAGEDATA) (ffetch POSTSCRIPTLINESPACING of IMAGEDATA] (if [LESSP NEWY (IPLUS (ffetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA) (fetch (FONTDESCRIPTOR \SFDescent) of (ffetch POSTSCRIPTFONT of IMAGEDATA] then (\NEWPAGE.PSC STREAM) else (replace (STREAM CHARPOSITION) of STREAM with 0) (\MOVETO.PSC STREAM (ffetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) NEWY)) NIL]) ) (DEFINEQ (\POSTSCRIPT.OUTCHARFN [LAMBDA (STREAM CHAR) (* ; "Edited 12-Jul-90 12:22 by jds") (* ;;; "Output a character to be printed. NS chars are not handled yet.") (* ;;; "Change font if necessary, do newline if at right margin, check for special chars and do appropriate thing, quote char and/or start postscript string if necessary.") (* ;;; "This is called a lot, so the code is unrolled for efficiancy.") (* ;;;; "") (* ;;;; "Need to inc CHARPOSITION of STREAM") (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE) (LOCALVARS . T)) (PROG* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (XPOS (fetch POSTSCRIPTX of IMAGEDATA)) (FONT (ffetch POSTSCRIPTFONT of IMAGEDATA)) [CHARWID (SELCHARQ CHAR (SPACE (ffetch POSTSCRIPTSPACEWIDTH of IMAGEDATA)) (\FGETWIDTH (ffetch POSTSCRIPTWIDTHS of IMAGEDATA) (\CHAR8CODE CHAR] NEWXPOS) [COND ((AND (ILEQ CHAR 254) (NOT (CL:AREF \POSTSCRIPT.CHARTYPE CHAR))) (* ;  "non-NIL if char is special in any way") [COND ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) (ffetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)) (\TERPRI.PSC STREAM) (SETQ NEWXPOS (IPLUS (ffetch POSTSCRIPTX of IMAGEDATA) CHARWID] (COND ((NOT (ffetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)) (COND ((ffetch POSTSCRIPTPENDINGXFORM of IMAGEDATA) (\SETXFORM.PSC STREAM IMAGEDATA))) (COND ((ffetch POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA) (* ;  "If font was changed then switch before printing") (\SWITCHFONTS.PSC STREAM IMAGEDATA))) (COND ((ffetch POSTSCRIPTMOVEFLG of IMAGEDATA) (* ; "likewise for position") (\SETPOS.PSC STREAM IMAGEDATA))) (BOUT STREAM (CHARCODE %()) (freplace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with T))) (BOUT STREAM CHAR) (freplace POSTSCRIPTX of IMAGEDATA with NEWXPOS)) (T (* ; "Special char") (SELCHARQ CHAR ((EOL LF) (\TERPRI.PSC STREAM)) (FF (DSPNEWPAGE STREAM)) (TAB (SETQ NEWXPOS (IPLUS XPOS (\POSTSCRIPTTAB IMAGEDATA))) [COND ((IGREATERP NEWXPOS (ffetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA) ) (\TERPRI.PSC STREAM) (SETQ NEWXPOS (IPLUS (ffetch POSTSCRIPTX of IMAGEDATA) (\POSTSCRIPTTAB IMAGEDATA] (\MOVETO.PSC STREAM NEWXPOS (ffetch POSTSCRIPTY of IMAGEDATA))) ("357,146" (* ; "Bullet") (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,267"))) ("357,45" (* ; "M-Dash") (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,320"))) ("357,44" (* ; "N-dash") (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,261"))) ("357,60" (* ; "Dagger") (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,262"))) ("357,61" (* ; "Double dagger") (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,263"))) ("0,322" (* ; "R-circle is in Symbol") (\POSTSCRIPT.SYMBOLOUTCHAR STREAM (CHARCODE "0,342"))) ("0,323" (* ; "C-circle is in Symbol") (\POSTSCRIPT.SYMBOLOUTCHAR STREAM (CHARCODE "0,343"))) ("0,324" (* ; "TM is in Symbol") (\POSTSCRIPT.SYMBOLOUTCHAR STREAM (CHARCODE "0,344"))) (PROGN (SETQ CHAR (\CHAR8CODE CHAR)) [COND ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) (ffetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)) (\TERPRI.PSC STREAM) (SETQ NEWXPOS (IPLUS (ffetch POSTSCRIPTX of IMAGEDATA) CHARWID] (COND ((NOT (ffetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)) (COND ((ffetch POSTSCRIPTPENDINGXFORM of IMAGEDATA) (\SETXFORM.PSC STREAM IMAGEDATA))) (COND ((ffetch POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA) (* ;  "If font was changed then switch before printing") (\SWITCHFONTS.PSC STREAM IMAGEDATA))) (COND ((ffetch POSTSCRIPTMOVEFLG of IMAGEDATA) (* ; "likewise for position") (\SETPOS.PSC STREAM IMAGEDATA))) (BOUT STREAM (CHARCODE %()) (freplace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with T))) (BOUT STREAM (CHARCODE \)) [SELCHARQ CHAR ((%( %) \) (BOUT STREAM CHAR)) (PROGN [BOUT STREAM (IPLUS (CHARCODE 0) (LOGAND 3 (LRSH CHAR 6] [BOUT STREAM (IPLUS (CHARCODE 0) (LOGAND 7 (LRSH CHAR 3] (BOUT STREAM (IPLUS (CHARCODE 0) (LOGAND 7 CHAR] (freplace POSTSCRIPTX of IMAGEDATA with NEWXPOS] (RETURN CHAR]) (\POSTSCRIPT.SYMBOLOUTCHAR [LAMBDA (STREAM CHARCODE) (* ; "Edited 12-Jul-90 12:20 by jds") (* ;; "Print a character that's really in the Symbol font: Change to Symbol, print the char, then change back.") (LET* ((OLDFONT (DSPFONT NIL STREAM)) (SIZE (FETCH (FONTDESCRIPTOR FONTSIZE) OF OLDFONT))) (DSPFONT (LIST 'SYMBOL SIZE) STREAM) (\POSTSCRIPT.OUTCHARFN STREAM CHARCODE) (DSPFONT OLDFONT STREAM]) ) (RPAQ \POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T "Print this file/document/image in Landscape Orientation" ) ("Portrait" 'NIL "Print this file/document/image in Portrait Orientation")) TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) CHANGEOFFSETFLG _ 'Y)) (RPAQ \POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS _ '(("Ask" 'ASK "Always ask whether to print in Landscape or Portrait Orientation" ) ("Landscape" T "Default printing to Landscape Orientation" ) ("Portrait" 'NIL "Default printing to Portrait Orientation" )) TITLE _ "Default Orientation" CENTERFLG _ T)) (RPAQ PS.BITMAPARRAY (READARRAY-FROM-LIST 16 (QUOTE BYTE) 0 (QUOTE (48 49 50 51 52 53 54 55 56 57 65 66 67 68 69 70 NIL)))) (RPAQQ \POSTSCRIPT.JOB.SETUP ("/bdef {bind def} bind def" "/ldef {load def} bdef" "/S /show ldef" "/M /moveto ldef" "/DR {transform round exch round exch itransform} bdef" "/L {gsave newpath setlinewidth 0 setlinecap" " M lineto currentpoint stroke grestore M} bdef" "/L1 {gsave newpath 0 setdash setgray setlinewidth 0 setlinecap" " M lineto currentpoint stroke grestore M} bdef" "/F {findfont exch scalefont setfont} bdef" "/CLP {newpath M dup 0 rlineto exch 0 exch rlineto" " neg 0 rlineto closepath clip newpath} bdef" "/R {gsave setgray newpath M dup 0 rlineto exch 0 exch" " rlineto neg 0 rlineto closepath eofill grestore} bdef" "/ellipsedict 9 dict def" "ellipsedict /mtrx matrix put" "/ellipse" " { ellipsedict begin" " /endangle exch def" " /startangle exch def" " /orientation exch def" " /minorrad exch def" " /majorrad exch def" " /y exch def" " /x exch def" " /savematrix mtrx currentmatrix def" " x y translate" " orientation rotate" " majorrad minorrad scale" " 0 0 1 startangle endangle arc" " savematrix setmatrix" " end } bdef" "/concatprocs" " {/proc2 exch cvlit def" " /proc1 exch cvlit def" " /newproc proc1 length proc2 length add array def" " newproc 0 proc1 putinterval" " newproc proc1 length proc2 putinterval" " newproc cvx" " } bdef" "/resmatrix matrix def" "/findresolution" " {72 0 resmatrix defaultmatrix dtransform" " /yres exch def /xres exch def" " xres dup mul yres dup mul add sqrt" " } bdef" "/thebitimage" " {/maskp exch def" " /bihgt exch def" " /biwid exch def" " /byte 1 string def" " /strbufl biwid 8 div ceiling cvi def" " /strbuf strbufl string def" " maskp not{{1 exch sub} currenttransfer concatprocs settransfer} if" " biwid bihgt" " maskp { true } { 1 } ifelse" " [biwid 0 0 bihgt 0 0]" " {/col 0 def" " {currentfile byte readhexstring pop 0 get" " dup 16#B2 eq {pop" " currentfile byte readhexstring pop 0 get 1 add" " currentfile byte readhexstring pop pop /nbyte byte 0 get def" " { strbuf col nbyte put /col col 1 add def} repeat}" " {dup 16#B3 eq {pop /col col" " currentfile byte readhexstring pop" " 0 get add 1 add def}" " {16#B4 eq {currentfile byte readhexstring pop pop} if" " strbuf col byte 0 get put /col col 1 add def} ifelse" " } ifelse" " col strbufl ge { exit } if } loop" " strbuf }" " maskp { imagemask } { image } ifelse" " } bdef" "/setuserscreendict 22 dict def" "setuserscreendict begin" " /tempctm matrix def" " /temprot matrix def" " /tempscale matrix def" "end" "/setuserscreen" " {setuserscreendict begin" " /spotfunction exch def" " /screenangle exch def" " /cellsize exch def" " /m tempctm currentmatrix def" " /rm screenangle temprot rotate def" " /sm cellsize dup tempscale scale def" " sm rm m m concatmatrix m concatmatrix pop" " 1 0 m dtransform /y1 exch def /x1 exch def" " /veclength x1 dup mul y1 dup mul add sqrt def" " /frequency findresolution veclength div def" " /newscreenangle y1 x1 atan def" " m 2 get m 1 get mul m 0 get m 3 get mul sub" " 0 gt { { neg } /spotfunction load concatprocs" " /spotfunction exch def } if" " frequency newscreenangle /spotfunction load setscreen" " end" " } bdef" "/setpatterndict 18 dict def" "setpatterndict begin" " /bitison" " {/ybit exch def /xbit exch def" " /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def" " /mask 1 7 xbit 8 mod sub bitshift def" " bytevalue mask and 0 ne" " } bdef" "end" "/bitpatternspotfunction" " {setpatterndict begin" " /y exch def /x exch def" " /xindex x 1 add 2 div bpside mul cvi def" " /yindex y 1 add 2 div bpside mul cvi def" " xindex yindex bitison" " {/onbits onbits 1 add def 1}" " {/offbits offbits 1 add def 0} ifelse" " end" " } bdef" "/setpattern" " {setpatterndict begin" " /cellsz exch def" " /angle exch def" " /bwidth exch def" " /bpside exch def" " /bstring exch def" " /onbits 0 def /offbits 0 def" " cellsz angle /bitpatternspotfunction load setuserscreen" " {} settransfer" " offbits offbits onbits add div setgray" " end" " } bdef" "%%%%EndProlog" "%%%%BeginSetup")) (RPAQQ SlopeMenuItems ((Italic 'ITALIC "This is an Italic Slope font") (Regular 'REGULAR "This is a Regular Slope font"))) (RPAQQ WeightMenuItems ((Bold 'BOLD "This is a Bold Weight font") (Medium 'MEDIUM "This is a Medium Weight font") (Light 'LIGHT "This is a Light Weight font"))) (ADDTOVAR BackgroundMenuCommands ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE (MENU \POSTSCRIPT.ORIENTATION.OPTIONS.MENU )) "Select the default Orientation for PostScript output" (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) "Always ask whether to print in Landscape or Portrait Orientation") ("Landscape" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE T) "Default printing to Landscape Orientation") ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE NIL) "Default printing to Portrait Orientation")))) (RPAQQ BackgroundMenu NIL) (DECLARE%: EVAL@COMPILE (RPAQQ GOLDEN.RATIO 1.618034) (RPAQQ \PS.SCALE0 100) (RPAQQ \PS.TEMPARRAYLEN 20) (CONSTANTS (GOLDEN.RATIO 1.618034) (\PS.SCALE0 100) (\PS.TEMPARRAYLEN 20)) ) (RPAQ? POSTSCRIPT.BITMAP.SCALE 1) (RPAQ? POSTSCRIPT.EOL 'CR) (RPAQ? POSTSCRIPT.IMAGESIZEFACTOR 1) (RPAQ? POSTSCRIPT.PREFER.LANDSCAPE NIL) (RPAQ? POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) (RPAQ? POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800)) (RPAQ? POSTSCRIPT.TEXTURE.SCALE 4) (RPAQ? POSTSCRIPTFONTDIRECTORIES (LIST (IF (EQL (MACHINETYPE) 'MAIKO) then "{DSK}/usr/local/lde/fonts/postscript/" else "{DSK}FONTS>PSC>"))) (RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72) (ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (HELVETICAD . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMES) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (TITAN . COURIER)) (ADDTOVAR PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPT.SEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT)))) (ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET NILL))) (RPAQ? POSTSCRIPT.PAGETYPE 'LETTER) (APPENDTOVAR POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) (0.197 0.197 8.1 10.6)) (LEGAL (0 0 8.5 14) (0.89 0.5 6.72 13.0)) (NOTE (0 0 8.5 11) (0.405 0.42 7.69 10.16))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (POSTSCRIPT.INIT) ) (PUTPROPS POSTSCRIPTSTREAM FILETYPE :TCOMPL) (PUTPROPS POSTSCRIPTSTREAM MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND) ) (PUTPROPS POSTSCRIPTSTREAM COPYRIGHT ("Savoir and Beckman" 1989 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (14441 129927 (CLOSEPOSTSCRIPTSTREAM 14451 . 14713) (OPENPOSTSCRIPTSTREAM 14715 . 20560) (POSTSCRIPT.BITMAPSCALE 20562 . 22808) (POSTSCRIPT.CLOSESTRING 22810 . 23259) (POSTSCRIPT.ENDPAGE 23261 . 23823) (POSTSCRIPT.FONTCREATE 23825 . 33862) (POSTSCRIPT.FONTSAVAILABLE 33864 . 37630) ( POSTSCRIPT.GETFONTID 37632 . 38912) (POSTSCRIPT.HARDCOPYW 38914 . 41832) (POSTSCRIPT.INIT 41834 . 47366) (POSTSCRIPT.OUTSTR 47368 . 48530) (POSTSCRIPT.PUTBITMAPBYTES 48532 . 56630) ( POSTSCRIPT.PUTCOMMAND 56632 . 57666) (POSTSCRIPT.SHOWACCUM 57668 . 59202) (POSTSCRIPT.STARTPAGE 59204 . 61319) (POSTSCRIPT.TEDIT 61321 . 61642) (POSTSCRIPT.TEXT 61644 . 61935) (POSTSCRIPTFILEP 61937 . 62391) (PSCFONT.READFONT 62393 . 63951) (PSCFONT.SPELLFILE 63953 . 64281) (PSCFONT.WRITEFONT 64283 . 65115) (READ-AFM-FILE 65117 . 69013) (\BITBLT.PSC 69015 . 69568) (\BLTSHADE.PSC 69570 . 73845) ( \CHARWIDTH.PSC 73847 . 74332) (\DRAWARC.PSC 74334 . 76962) (\DRAWCIRCLE.PSC 76964 . 79512) ( \DRAWCURVE.PSC 79514 . 83477) (\DRAWELLIPSE.PSC 83479 . 86097) (\DRAWLINE.PSC 86099 . 88284) ( \DRAWPOINT.PSC 88286 . 88874) (\DRAWPOLYGON.PSC 88876 . 92109) (\DSPBOTTOMMARGIN.PSC 92111 . 92504) ( \DSPCLIPPINGREGION.PSC 92506 . 93715) (\DSPFONT.PSC 93717 . 95665) (\DSPLEFTMARGIN.PSC 95667 . 96105) (\DSPLINEFEED.PSC 96107 . 96498) (\DSPRESET.PSC 96500 . 97027) (\DSPRIGHTMARGIN.PSC 97029 . 97482) ( \DSPROTATE.PSC 97484 . 102019) (\DSPSCALE.PSC 102021 . 102880) (\DSPSPACEFACTOR.PSC 102882 . 103766) ( \DSPTOPMARGIN.PSC 103768 . 104152) (\DSPTRANSLATE.PSC 104154 . 105996) (\DSPXPOSITION.PSC 105998 . 106461) (\DSPYPOSITION.PSC 106463 . 106938) (\FILLCIRCLE.PSC 106940 . 109586) (\FILLPOLYGON.PSC 109588 . 113303) (\FIXLINELENGTH.PSC 113305 . 114512) (\MOVETO.PSC 114514 . 115132) (\NEWPAGE.PSC 115134 . 115329) (\POSTSCRIPTTAB 115331 . 116105) (\PS.BOUTFIXP 116107 . 117537) (\PS.SCALEHACK 117539 . 120034 ) (\PS.SCALEREGION 120036 . 120596) (\SCALEDBITBLT.PSC 120598 . 124712) (\SETPOS.PSC 124714 . 125066) (\SETXFORM.PSC 125068 . 126914) (\STRINGWIDTH.PSC 126916 . 127278) (\SWITCHFONTS.PSC 127280 . 129073) (\TERPRI.PSC 129075 . 129925)) (129928 137959 (\POSTSCRIPT.OUTCHARFN 129938 . 137430) ( \POSTSCRIPT.SYMBOLOUTCHAR 137432 . 137957))))) STOP \ No newline at end of file diff --git a/lispusers/POSTSCRIPTSTREAM.TEDIT b/lispusers/POSTSCRIPTSTREAM.TEDIT new file mode 100644 index 00000000..c135019b --- /dev/null +++ b/lispusers/POSTSCRIPTSTREAM.TEDIT @@ -0,0 +1,11 @@ +enˇvĹos POSTSCRIPTSTREAM 2 4 1 POSTSCRIPTSTREAM 1 4 By: Matt Heffron (mheffron@orion.cf.uci.edu) INTRODUCTION The PostScript package defines a set of imageops for printers which understand the PostScript page description language by Adobe. At Beckman we have successfully used TEdit, Sketch, LISTFILES, and HARDCOPYW to an Apple LaserWriter and an AST TurboLaser PS. The PostScript imagestream driver installs itself when it is loaded. All symbols in the PostScript driver are located in the INTERLISP: package. VARIABLES POSTSCRIPT.FONT.ALIST [InitVariable] POSTSCRIPT.FONT.ALIST is an ALIST mapping Xerox Lisp font names into the root names of PostScript font files. It is also used for font family coercions. The default value should be acceptable for any of the fonts which are built into the Apple Laserwriter. POSTSCRIPTFONTDIRECTORIES [InitVariable] POSTSCRIPTFONTDIRECTORIES is the list of directories where the PostScript .PSCFONT font files can be found. The default value is: ("{DSK}/usr/local/lde/fonts/postscript/") on a Sun or IBM workstation and ("{DSK}FONTS>PSC>") for other cases . POSTSCRIPT.DEFAULT.PAGEREGION [InitVariable] POSTSCRIPT.DEFAULT.PAGEREGION indicates the area of the page to use for text file listings (i.e. LISTFILES). It is in units of 100'ths of points. The default value is: (4800 4800 52800 70800), which gives left and bottom margins of 0.75 inch and top and right margins of 0.5 inch on 8.5 x 11 paper. POSTSCRIPT.PAGEREGIONS [InitVariable] POSTSCRIPT.PAGEREGIONS is an ALIST mapping pagetypes into paper size and actual imageable area on the page. By default, it knows about LETTER, LEGAL, and NOTE pagetypes, and the corresponding sizes and imageable areas for the Apple Laserwriter. Others can be defined by the user by adding the appropriate entries onto this ALIST. POSTSCRIPT.PAGETYPE [InitVariable] POSTSCRIPT.PAGETYPE is used by OPENIMAGESTREAM to lookup the paper size and actual imageable area of the page in POSTSCRIPT.PAGEREGIONS to determine the initial margins. This value can be overridden with the PAGETYPE or PAPERTYPE options in the OPENIMAGESTREAM call. The name of the type of page selected is NOT passed through to the PostScript output. \POSTSCRIPT.MAX.WILD.FONTSIZE [InitVariable] \POSTSCRIPT.MAX.WILD.FONTSIZE indicates the maximum point size that should be returned from FONTSAVAILABLE when the SIZE argument is wild (i.e. *). All integer pointsizes from 1 to \POSTSCRIPT.MAX.WILD.FONTSIZE will be indicated as available. The default value is: 72. POSTSCRIPT.PREFER.LANDSCAPE [InitVariable] POSTSCRIPT.PREFER.LANDSCAPE indicates if the OPENIMAGESTREAM method should default the orientation of output files to LANDSCAPE. It can have one of three values: NIL, T, or ASK. NIL means prefer portrait orientation output, T means prefer landscape, and ASK says to bring up a menu to ask the preferred orientation if it wasn't explicitly indicated in the OPENIMAGESTREAM call (with the ROTATION option). The default value is: NIL. An item (PS Orientation) is added to the Background Menu to let you change the value of this variable. POSTSCRIPT.TEXTFILE.LANDSCAPE [InitVariable] POSTSCRIPT.TEXTFILE.LANDSCAPE indicates if the printing of TEXT files (e.g. LISTFILES, ...) should force the orientation of output files to LANDSCAPE. When it is non-NIL the orientation of output files is forced to LANDSCAPE. (There is no ASK option here.) The default value is: NIL. POSTSCRIPT.BITMAP.SCALE [InitVariable] POSTSCRIPT.BITMAP.SCALE specifies an independent scale factor for display of bitmap images (e.g. window hardcopies). Values less than 1 will reduce the image size. (I.e. a value of 0.5 will give a half size bitmap image.) The position of the scaled bitmap will still have the SAME lower-left corner (i.e. the scaled bitmap is not centered in the region of the full size bitmap image). The default value is: 1. HINT Setting POSTSCRIPT.BITMAP.SCALE to 0.96, instead of 1, will give cleaner BITMAP images on a 300 dpi printer. (This corrects for the 72 ppi imagestream vs. the 75 dpi printer, using 4x4 device dots per bitmap pixel.) Also, values of 0.24, 0.48 and 0.72, instead of 0.25, 0.5 and 0.75, will also give cleaner images for reduced size output. In general, use integer multiples of 0.24 for a 300 dpi printer. POSTSCRIPT.TEXTURE.SCALE [InitVariable] POSTSCRIPT.TEXTURE.SCALE specifies an independent scale for the display of bitmap textures. The value represents the number of device space units per texture unit (bitmap bit). The default value is 4, which represents each bit of the texture as a 4x4 block, so that textures are approximately the same resolution as on the screen (for 300 dpi output devices, such as the Apple Laserwriter). The PostScript package extends the allowed representations of a texture, beyond 16-bit FIXP and 16x16 bitmap, to ANY square bitmap. (If the bitmap is not square, its longer edge is truncated from the top or right to make it square.) Use this feature with caution, as large bitmap textures, or sizes other than multiples of 16 bits square, require large amounts of storage in the PostScript interpreter (in the printer controller), and can cause limitcheck errors when actually printing. Anywhere that a texture or color can be used on an imagestream or in the specification of a BRUSH, you can instead give a FLOATP between 0.0 and 1.0 (inclusive) to represent a PostScript halftone gray shade. (0.0 is black and 1.0 is white. Specifically, the value sets the brightness of the shade.) The value you specify will not be range checked, and will be passed directly through to the PostScript setgray operator. (E.g. you can pass 0.33 as the color to DRAWLINE to get a dark gray line with approximately 67% of the pixels in the line black.) POSTSCRIPT.IMAGESIZEFACTOR [InitVariable] POSTSCRIPT.IMAGESIZEFACTOR specifies an independent factor to change the overall size of the printed image. This re-sizing affects the entire printed output (specifically, it superimposes its effects upon those of POSTSCRIPT.BITMAP.SCALE and POSTSCRIPT.TEXTURE.SCALE). Values greater than 1 enlarge the printed image, and values less than 1 reduce it. An invalid POSTSCRIPT.IMAGESIZEFACTOR (i.e. not a positive, non-zero number) will use a value of 1. The BITMAPSCALE function for the POSTSCRIPT printer type does NOT consider the POSTSCRIPT.IMAGESIZEFACTOR when determining the scale factor for a bitmap. MISCELLANEOUS The SCALE of a PostScript imagestream is 100. This is to allow enough resolution in the width information for fonts to enable TEdit to correctly fill and justify text. The first time any PostScript imagestream is created (even if only to hardcopy a bitmap or window) the DEFAULTFONT is instantiated (unless a FONTS option was given to the OPENIMAGESTREAM, in which case the initial font for the imagestream will be set to that font, or to the CAR if a list). The PostScript imagestream method for FILLPOLYGON uses the global variable FILL.WRULE as the default value for the WINDINGNUMBER argument. (This is the same variable which is used by the DISPLAY imagestream method for FILLPOLYGON.) The PostScript imagestream method for OPENIMAGESTREAM (and, therefore, SEND.FILE.TO.PRINTER), supports an IMAGESIZEFACTOR option to change the size of the printed image. The IMAGESIZEFACTOR re-sizing is combined with the POSTSCRIPT.IMAGESIZEFACTOR to produce an overall re-sizing of the printed image. A HEADING option is also supported to give a running header on each page of output. The value of the HEADING option is printed at the top left of the page, followed by "Page " and the appropriate page number. They are printed in the DEFAULTFONT (unless a FONTS option was given to the OPENIMAGESTREAM, in which case it will be that font, or to the CAR if a list). The PostScript package is contained in the files: POSTSCRIPTSTREAM.LCOM & PS-SEND.LCOM, with the source in the files: POSTSCRIPTSTREAM & PS-SEND. The module PS-SEND.LCOM is required and will be loaded automatically when POSTSCRIPTSTREAM.LCOM is loaded. It contains the function which is called by SEND.FILE.TO.PRINTER to actually transmit the file to the printer. It is, by its nature, quite site specific, so it is in a separate file to make modifying it for any site relatively simple. System record declarations required to compile POSTSCRIPTSTREAM can be found in EXPORTS.ALL. I'm pretty sure that the output generated by the PostScript imageops fully conforms to the Adobe Systems Document Structuring Conventions, Version 2.0, January 31, 1987. Including Other PostScript Operations If you wish to insert your own specific PostScript operations into a PostScript imagestream, you can do so with the following functions: (POSTSCRIPT.OUTSTR STREAM STRING) [Function] POSTSCRIPT.OUTSTR outputs a string or value to the imagestream. STREAM must be an open PostScript imagestream. STRING is the value to output (STRINGP and LITATOM are most efficient, but any value can be output (its PRIN1 pname is used)). (POSTSCRIPT.PUTCOMMAND STREAM STRING1 ... STRINGn) [NoSpread Function] POSTSCRIPT.PUTCOMMAND is more general for sequences of commands and values. It calls POSTSCRIPT.OUTSTR repeatedly to output each of the STRINGi arguments to STREAM. (\POSTSCRIPT.OUTCHARFN STREAM CHAR) [Function] \POSTSCRIPT.OUTCHARFN is used to output the characters forming the text of a PostScript string (e.g. the argument to a show or charpath operator). STREAM is the open PostScript imagestream to output to, and CHAR is the CHARCODE of the character to output. The / (slash), ( and ) (parenthesis) characters will be quoted with /, and characters with ASCII values less than 32 (space) or greater than 126 (tilde) will be output as /nnn (in octal). \POSTSCRIPT.OUTCHARFN will output the ( character to open the string, if necessary. Use POSTSCRIPT.CLOSESTRING (below) to close the string. (POSTSCRIPT.CLOSESTRING STREAM) [Function] POSTSCRIPT.CLOSESTRING closes a PostScript string (e.g. the argument to a show or charpath operator). STREAM is the open PostScript imagestream. It is important to use POSTSCRIPT.CLOSESTRING to output the ) character to close the string, because it also clears the stream state flag that indicates that a string is in progress (otherwise, the next POSTSCRIPT.PUTCOMMAND would output the commands to close the string and show it). Warning Do not attempt to create a PostScript font larger than about 600 points, as much of Interlisp's font information is stored in SMALLP integers, and too large a font would overflow the font's height, or the width for any of the wider characters. (I know that 600 points is a ridiculously large limit (about 8.3 inches), but I thought I'd better mention it, or someone might try it!) Changes from the Initial Medley Release This second Medley release of the PostScript imagestream driver includes some performance enhancements when writing bitmaps to the output, some SUN-specific code (from Will Snow of envos), implementation of the SCALEDBITBLT, DSPROTATE, and DSPTRANSLATE operations, and a lot of performance enhancements (many thanks to Tom Lipkis of Savoir). Changes from the Lyric Release The Medley release of this PostScript imagestream driver changed the default value of POSTSCRIPT.TEXTFILE.LANDSCAPE from T to NIL. It also added the support for the HEADING option. Known Problems/Limitations The output generated for a PostScript imagestream is rather brute force. It isn't particularly careful to generate the smallest output file for a given sequence of operations. Specifically, it often generates extra end-of-lines between PostScript operator sequences (this has no effect on the printed output, only on the file size). Using BITMAPs or Functions as BRUSH arguments to the curve drawing functions is not supported, nor is using a non-ROUND BRUSH with DRAWCIRCLE or DRAWELLIPSE. The implementation of DSPROTATE accepts ROTATION argument values of 0 and 90 (any non-NIL, non-zero value is converted to 90). A value of 0 converts the page orientation to Portrait, and 90 converts the page orientation to Landscape. These conversions perform the translations necessary to keep the clipping region on the page. (This may or may not be the right thing to do, but since DSPROTATE is undocumented in what it should do, this is what the PostScript driver does). There is no support for NS character sets other than 0, and there is no translation of the character code values from NS encoding to PostScript encoding. There is no support for color. \POSTSCRIPT.OUTCHARFN is pretty wimpy in its handling of TAB characters. It just moves to the next multiple of (eight times the average character width of the current font) from the current left margin. I haven't yet documented how to build the .PSCFONT files from .AFM files for new fonts that become available.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))))) 5Č Č,66’,Č5Č Č,Č ,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD CLASSICCLASSICMODERN +˙ţ HELVETICA +MODERN +MODERN +MODERN MODERN +MODERN    HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN  HRULE.GETFNMODERN . • +˙-Lc˜ýŠé*eŠ#é˘KŠ&‰  A*y  ‰  ”62 +-f4f gbá~(VśOžŢšĚm2WÝzş \ No newline at end of file diff --git a/lispusers/PP-CODE-FILE b/lispusers/PP-CODE-FILE new file mode 100644 index 00000000..3059582e --- /dev/null +++ b/lispusers/PP-CODE-FILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (il:filecreated "23-Feb-88 11:13:23" il:{erinyes}lyric>pp-code-file.\;1 13344 il:|changes| il:|to:| (il:functions pp-code-file-internal) il:|previous| il:|date:| " 3-Nov-87 12:26:37" il:|{IE:PARC:XEROX}LYRIC>LISPUSERS>PP-CODE-FILE.;2|) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:pp-code-filecoms) (il:rpaqq il:pp-code-filecoms ((il:prop (il:makefile-environment il:filetype) il:pp-code-file) (il:functions pp-code-file pp-code-file-internal file-manager-file-p maybe-pp-code-file pretty-listfiles1) (il:commands "see") (il:p (il:movd? (quote il:listfiles1) (quote il:listfiles1-original)) (il:/movd (quote pretty-listfiles1) (quote il:listfiles1)) (il:changename (quote il:fb.fastsee.onefile) (quote il:pfcopybytes) (quote maybe-pp-code-file))) (il:coms (il:fns il:superprint/comment) (il:declare\: il:eval@compile il:dontcopy (il:files (il:loadcomp) il:newprintdef)))) ) (il:putprops il:pp-code-file il:makefile-environment (:readtable "XCL" :package "XCL")) (il:putprops il:pp-code-file il:filetype :compile-file) (defun pp-code-file (code-file &optional (output *standard-output*) (reader-env (file-manager-file-p code-file))) "Pretty print contents of file manager file" (declare (special il:*old-interlisp-read-environment*)) (if reader-env (let ((in-stream (if (streamp code-file) code-file (open code-file :direction :input)))) (unwind-protect (let ((out-stream (cond ((streamp output) output) ((il:windowp output) (il:getstream output)) (t (open output :direction :output :if-exists :new-version)))) (abort t)) (unwind-protect (il:with-reader-environment reader-env (unless (eq reader-env il:*old-interlisp-read-environment*) (il:* il:|;;| "if FILE-MANAGER-FILE-P read a IL:DEFINE-FILE-INFO expression to get the reader environment then we have to both print one to the output as well as read this one again.") (il:print-reader-environment reader-env out-stream) (terpri out-stream) (il:with-reader-environment il:*old-interlisp-read-environment* (read in-stream))) (pp-code-file-internal in-stream out-stream) (setq abort nil) (pathname out-stream)) (unless (or (streamp output) (il:windowp output)) (close out-stream :abort abort)))) (unless (streamp code-file) (close in-stream)))) (error "~S not a File Manager file" code-file))) (defun pp-code-file-internal (il:in-stream il:out-stream) (il:* il:|;;| "presume read environment has been set up for us") (il:* il:|;;| "we just need to pretty print from IN-STREAM to OUT-STREAM ") (il:* il:|;;| "i can write this much easier in interlisp...") (il:bind (il:**comment**flg il:_ nil) (il:*print-semicolon-comments* il:_ t) (il:*divide-long-strings* il:_ t) (il:prettyflg il:_ t) il:names il:sexp declare (il:specvars il:**comment**flg il:*print-semicolon-comments* il:*divide-long-strings* il:prettyflg) il:eachtime (il:skipseprs il:in-stream *readtable*) il:until (il:eofp il:in-stream) il:do (il:* il:\; "read an expression") (il:setq il:sexp (il:read il:in-stream *readtable*)) (cond ((and (null il:names) (il:listp il:sexp) (eq (car il:sexp) (quote il:rpaqq)) (il:strequal (il:substring (cadr il:sexp) -4) "COMS")) (il:* il:|;;| "found the COMS") (let ((il:coms (caddr il:sexp))) (il:* il:|;;| "pull out the function names") (il:setq il:names (il:append (il:infilecoms? nil (quote il:fns) il:coms) (il:infilecoms? nil (quote il:functions) il:coms)))))) (il:* il:|;;| "pretty print the expression") (if (eq (car il:sexp) (quote il:defineq)) (progn (il:* il:|;;| "print blank lines between DEFINEQ defs") (format il:out-stream "(~S~%" (car il:sexp)) (dolist (il:def (cdr il:sexp)) (il:terpri il:out-stream) (il:printdef il:def nil (and (il:listp il:sexp) (eq (car il:sexp) (quote il:defineq))) nil il:names il:out-stream) (il:terpri il:out-stream)) (format il:out-stream ")~%" (car il:sexp))) (il:printdef il:sexp nil nil nil il:names il:out-stream)) (il:* il:|;;| "leave a blank line between each") (il:terpri il:out-stream))) (defun file-manager-file-p (file) (il:* il:|;;| "Returns NIL or a reader environment.") (declare (special il:*old-interlisp-read-environment*)) (with-open-stream (stream (open file :direction :input)) (il:with-reader-environment il:*old-interlisp-read-environment* (and (eql #\( (peek-char t stream nil nil)) (let ((define-file-info (car (il:nlsetq (read stream))))) (if (consp define-file-info) (case (car define-file-info) (il:define-file-info (il:\\do-define-file-info nil (cdr define-file-info))) (il:filecreated il:*old-interlisp-read-environment*)))))))) (defun maybe-pp-code-file (input &optional (output *standard-output*)) (let ((reader-env (file-manager-file-p input))) (if reader-env (pp-code-file input output reader-env) (let ((in-stream (if (streamp input) input (open input :direction :input)))) (unwind-protect (il:copychars in-stream (il:getstream output (quote il:output))) (unless (streamp input) (close in-stream))))))) (defun pretty-listfiles1 (file options) (il:* il:|;;| "MOVD'd onto IL:LISTFILES1.") (let ((reader-env (file-manager-file-p file))) (if reader-env (let* ((pathname (probe-file file)) (namestring (namestring pathname)) (temp-file (quote nil))) (declare (global il:defaultprintertype)) (with-open-stream (print-stream (il:openimagestream "{LPT}" il:defaultprintertype)) (pp-code-file pathname print-stream) (il:streamprop print-stream (quote il:printoptions) (list* (quote il:document.name) (or (il:listget options (quote il:document.name)) namestring) (quote il:document.creation.date) (il:getfileinfo pathname (quote il:icreationdate)) (quote il:heading) (or (il:listget options (quote il:heading)) (il:concat namestring " " (il:getfileinfo pathname (quote il:creationdate)))) options))) (if (il:listget options (quote il:delete)) (delete-file pathname))) (il:* il:|;;| "not a code file -- punt") (il:listfiles1-original file options)))) (defcommand "see" (il:file) "print the contents of FILE on the screen" (maybe-pp-code-file il:file)) (il:movd? (quote il:listfiles1) (quote il:listfiles1-original)) (il:/movd (quote pretty-listfiles1) (quote il:listfiles1)) (il:changename (quote il:fb.fastsee.onefile) (quote il:pfcopybytes) (quote maybe-pp-code-file)) (il:defineq (il:superprint/comment (il:lambda (il:l il:file) (il:* il:\; "Edited 2-Nov-87 14:13 by drc:") (cond ((and il:**comment**flg (not il:fileflg) (not il:makemap)) (il:* il:\; "If:") (il:* il:\;  "There's a shorthand for comments, and") (il:* il:\;  "We're not printing to a file, and") (il:* il:\;  "Ww're not making the file map, then") (il:* il:|;;|  "Print out the shorthand version of the comment, watching out for overflowing the current line.") (cond ((> (+ (il:dspxposition nil il:file) (il:stringwidth il:**comment**flg il:file)) (il:dsprightmargin nil il:file)) (il:prinendline (il:dspleftmargin nil il:file) il:file))) (il:prin1s il:**comment**flg nil il:file)) (t (prog (il:comment-lmargin il:comment-rmargin il:rightflg il:flush-leftp il:semip il:body) (cond ((il:setq il:rightflg (not (or (il:superprinteq (cadr il:l) il:commentflg) (cond ((il:setq il:semip (il:semi-colon-comment-p il:l)) (il:* il:\;  "Only 1-semi comments go in right margin") (il:neq il:semip 1)) (t (il:* il:\; "use size heuristic") (> (il:length il:l) 10)))))) (il:* il:\;  "Print comment in the righthand margin") (il:setq il:comment-lmargin (or il:commentcol (il:superprint/comment1 il:l il:rmargin il:file))) (il:setq il:comment-rmargin il:rmargin)) ((and (eq il:semip 3) (not il:makemap)) (il:* il:\;  "Comment should be printed flush left. Don't do this with DEdit lest we confuse it") (il:setq il:comment-lmargin (il:dspleftmargin nil il:file)) (il:setq il:comment-rmargin il:rmargin)) ((and (eq il:semip 2) (not il:makemap)) (il:* il:\; "indent like code") (il:setq il:comment-lmargin (min il:left (+ (il:dspleftmargin nil il:file) (il:iquotient (- il:rmargin (il:dspleftmargin nil il:file)) 3)))) (il:setq il:comment-rmargin il:rmargin)) (t (il:* il:\;  "Print comment centered and wide") (il:setq il:comment-lmargin (il:fixr (il:times 0.1 il:rmargin))) (il:setq il:comment-rmargin (- il:rmargin il:comment-lmargin)) (cond ((eq il:comment-lmargin (il:dspxposition nil il:file)) (il:* il:|;;| "HACK: Almost certainly called from REPP, so we must supress the normal leading and trailing blank lines as they have already been done") (il:setq il:rightflg t))))) (cond ((null il:rightflg) (il:prinendline il:comment-lmargin il:file)) ((< il:comment-lmargin (il:dspxposition nil il:file)) (il:prinendline il:comment-lmargin il:file)) (t (il:dspxposition il:comment-lmargin il:file))) (il:setfont (prog1 (il:setfont il:commentfont il:file) (cond ((and il:semip (not il:makemap) (il:stringp (il:setq il:body (car (il:listp (cdr (il:listp (cdr il:l))))) )) (null (cdddr il:l)) (or (il:imagestreamp il:file) il:*print-semicolon-comments*)) (il:* il:\; "do nice semi-colon stuff") (il:prin2-long-string il:body il:file nil nil il:comment-lmargin il:comment-rmargin t il:semip)) (t (il:superprint/comment2 il:l il:comment-lmargin (il:iquotient (+ il:comment-lmargin il:comment-rmargin) 2) il:comment-rmargin il:file)))) il:file) (cond ((and (or (and il:semip (not il:makemap)) (not il:rightflg)) (not (= (il:dspxposition nil il:file) (il:dspleftmargin nil il:file)))) (il:* il:|;;| "AR 8475 JDS 4/16/87: If there's a semi-colon comment on this line, and we're not making the file map (??), and RIGHTFLG is NIL (whatever that means) then force a new line.") (il:prinendline (il:dspleftmargin nil il:file) il:file))) (il:* il:\;  "(OR RIGHTFLG (PRINENDLINE 0 FILE))") (return il:l)))))) ) (il:declare\: il:eval@compile il:dontcopy (il:filesload (il:loadcomp) il:newprintdef) ) (il:putprops il:pp-code-file il:copyright ("Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil (6248 13151 (il:superprint/comment 6261 . 13149))))) il:stop \ No newline at end of file diff --git a/lispusers/PREEMPTIVE b/lispusers/PREEMPTIVE new file mode 100644 index 00000000..c827ec3c --- /dev/null +++ b/lispusers/PREEMPTIVE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated " 4-Apr-88 12:40:00" {erinyes}medley>preemptive.\;3 5218 |changes| |to:| (fns preemptive preemptive.block) (vars preemptivecoms) (variables no-periodic-interrupt-functions) |previous| |date:| " 4-Apr-88 12:27:36" {erinyes}medley>preemptive.\;2) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint preemptivecoms) (rpaqq preemptivecoms ((fns preemptive.block preemptive) (variables no-periodic-interrupt-functions) (declare\: donteval@load docopy (p (preemptive ':on))) (declare\: eval@compile dontcopy (p (or (hasdef 'process 'records) (eval (sysreclook1 'process))))) (advise messagedisplayer) (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama) (nlaml) (lama preemptive))))) (defineq (preemptive.block (lambda nil (* \; "Edited 4-Apr-88 12:26 by drc:") (cond ((and \\interruptable (uninterruptably (and (not (|fetch| (process procsystemp) |of| (this.process) )) (or (eq lastmousebuttons 0) (progn (getmousestate) (eq lastmousebuttons 0))) (prog (name (frame (|fetch| (fx clink) (\\myalink)))) sampleloop (cond ((and (litatom (setq name (\\stkname frame))) (fmemb name no-periodic-interrupt-functions)) (return nil))) (cond ((not (|fetch| (fx invalidp) (setq frame (|fetch| (fx clink) frame)))) (go sampleloop)) (t (return t))))))) (block))))) (preemptive (lambda (state) (* \; "Edited 4-Apr-88 12:37 by drc:") (prog1 (cond ((eq \\periodic.interrupt 'preemptive.block) ':on) (t ':off)) (and state (selectq (cl:intern (string state) 'keyword) ((:on) (setq \\periodic.interrupt.frequency 25) (setq \\periodic.interrupt 'preemptive.block)) ((:off) (setq \\periodic.interrupt nil)) (error state "not valid argument")))))) ) (defglobalvar no-periodic-interrupt-functions '(getkey ttwaitforinput getmousestate menu.handler \\bltshade.display \\bitblt.display \\bitblt.bitmap \\bltshade.bitmap \\totopwds \\bitbltsub menu) ) (declare\: donteval@load docopy (preemptive ':on) ) (declare\: eval@compile dontcopy (or (hasdef 'process 'records) (eval (sysreclook1 'process))) ) (xcl:reinstall-advice 'messagedisplayer :before '((:last (allow.button.events)))) (readvise messagedisplayer) (declare\: donteval@load doeval@compile dontcopy compilervars (addtovar nlama ) (addtovar nlaml ) (addtovar lama preemptive) ) (prettycomprint preemptivecoms) (rpaqq preemptivecoms ((fns preemptive.block preemptive) (variables no-periodic-interrupt-functions) (declare\: donteval@load docopy (p (preemptive ':on))) (declare\: eval@compile dontcopy (p (or (hasdef 'process 'records) (eval (sysreclook1 'process))))) (advise messagedisplayer) (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama) (nlaml) (lama))))) (declare\: donteval@load doeval@compile dontcopy compilervars (addtovar nlama ) (addtovar nlaml ) (addtovar lama ) ) (putprops preemptive copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil (1236 3474 (preemptive.block 1246 . 2773) (preemptive 2775 . 3472))))) stop \ No newline at end of file diff --git a/lispusers/PREEMPTIVE.TEDIT b/lispusers/PREEMPTIVE.TEDIT new file mode 100644 index 00000000..58ea2d42 Binary files /dev/null and b/lispusers/PREEMPTIVE.TEDIT differ diff --git a/lispusers/PRESSFROMNS b/lispusers/PRESSFROMNS new file mode 100644 index 00000000..90fff874 --- /dev/null +++ b/lispusers/PRESSFROMNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 9-Mar-88 15:54:25" {IVY}LISP>MEDLEY>PRESSFROMNS.;13 81335 changes to%: (VARS PRESSFROMNSCOMS) (FNS \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS \CREATEPRESSFONT \COERCEFONT) (RECORDS PRESSDATA) previous date%: " 4-Mar-88 12:52:46" {IVY}LISP>MEDLEY>PRESSFROMNS.;9) (* " Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PRESSFROMNSCOMS) (RPAQQ PRESSFROMNSCOMS [(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before changing this file.) (FNS \SMASHPRESSFONTS) (FNS GETCHARPRESSTRANSLATION PRESS.NSARRAY PUTCHARPRESSTRANSLATION) (FNS \DSPFONT.PRESS \DSPSPACEFACTOR.PRESS \ENTITYSTART.PRESS \SETSPACE.PRESS \STARTPAGE.PRESS \PRESS.COERCEFONT \DSPFONT.PRESSFONT SETUPFONTS.PRESS) (FNS \CREATEPRESSFONT \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS) (FNS \PRESSCURVE2) (COMS (* Generic utility for coercing fonts, could be used by other devices) (FNS \COERCEFONT)) (ALISTS (FONTCOERCIONS PRESS) (MISSINGFONTCOERCIONS PRESS)) (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) (FNS \STRINGWIDTH.PRESS \CHARWIDTH.PRESS \OUTCHARFN.PRESS) (* * new declaration for PRESSDATA) (DECLARE%: DONTCOPY (RECORDS PRESSDATA)) (INITRECORDS PRESSDATA) (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) %, where translationArrayName is bound to a translation array for charset which contains (fontFamily charcode) lists) (FNS \NSTOASCIIARRAY \NSTOASCIITRANSLATION) (GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES) [INITVARS (PRESSFONTFAMILIES '((GACHA) (TIMESROMAN) (HELVETICA) (SYMBOL) (MATH) (HIPPO) (CYRILLIC) (NEWVEC) (SNEWVEC) (HNEWVEC) (VNEWVEC] (INITVARS (NSTOASCIITRANSLATIONS)) (ADDVARS (NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) (38 ASCIIFROM38ARRAY) (39 ASCIIFROM39ARRAY) (239 ASCIIFROM239ARRAY))) (UGLYVARS ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) (P (\SMASHPRESSFONTS)) (DECLARE%: DONTCOPY (CONSTANTS (unknownCharTranslation '(MATH 59]) (* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before changing this file.) (DEFINEQ (\SMASHPRESSFONTS [LAMBDA NIL (* ; "Edited 29-Feb-88 10:21 by thh:") (* ;; "Executed after all patchfns have been loaded, coerces existing Koto press fonts into NS-type press fonts") (for F in (FONTSAVAILABLE '* '* '* '* 'PRESS) do (\CREATECHARSET 0 (FONTCREATE F]) ) (DEFINEQ (GETCHARPRESSTRANSLATION [LAMBDA (CHARCODE FONT) (* thh%: "28-Feb-86 12:03") (* returns the Press translation for a character in a font) (COND ((OR (CHARCODEP CHARCODE) (EQ CHARCODE 256)) (* bitmap for char 256 is what gets printed if char not found) ) ((OR (STRINGP CHARCODE) (LITATOM CHARCODE)) (SETQ CHARCODE (CHCON1 CHARCODE))) (T (\ILLEGAL.ARG CHARCODE))) (LET [TR CSINFO (FONTDESC (\GETFONTDESC FONT 'PRESS] (* fetch the csinfo for the character set of this character.) (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (SETQ TR (\GETBASEPTR (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) (UNFOLD (\CHAR8CODE CHARCODE) 2))) (* Return a copy) (LIST (CAR TR) (CDR TR]) (PRESS.NSARRAY [LAMBDA (CHARSET FAMILY ASCIIARRAY) (* thh%: "28-Feb-86 12:08") (* using info in ASCIIARRAY or ASCIITONSTRANSLATIONS, creates an array of  (pressFont charcode) lists) (LET* ((min (TIMES 256 CHARSET)) (max (PLUS min 255)) (array (ARRAY 256 NIL NIL 0))) [for item in (COND [ASCIIARRAY `((%, FAMILY ASCIIARRAY] (T ASCIITONSTRANSLATIONS)) bind asciiArray do (* * item is of the form (PressFont TranslationArray NSFont)) (SETQ asciiArray (EVAL (CADR item))) (COND (asciiArray (for i from 0 to 255 do (SETA array (REMAINDER (ELT asciiArray i) 256) (LIST (CAR item) i)) when (AND (LEQ min (ELT asciiArray i)) (LEQ (ELT asciiArray i) max] array]) (PUTCHARPRESSTRANSLATION [LAMBDA (CHARCODE FONT NEWTRANSLATION) (* ; "Edited 29-Feb-88 10:28 by thh:") (* ;  "Changes the Press translation for a character in a font") (COND ((CHARCODEP CHARCODE)) ((OR (STRINGP CHARCODE) (LITATOM CHARCODE)) (SETQ CHARCODE (CHCON1 CHARCODE))) (T (\ILLEGAL.ARG CHARCODE))) (PROG* ((FONTDESC (\GETFONTDESC FONT 'PRESS)) (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (CHAR8CODE (\CHAR8CODE CHARCODE)) (TR (\NSTOASCIITRANSLATION NEWTRANSLATION NIL FONTDESC))) (UNINTERRUPTABLY (\RPLPTR (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) (UNFOLD CHAR8CODE 2) TR) (\PUTBASE (ffetch (CHARSETINFO WIDTHS) of CSINFO) CHAR8CODE (\FGETCHARWIDTH (CAR TR) (CDR TR))) [change (ffetch CHARSETASCENT of CSINFO) (MAX DATUM (ffetch \SFAscent of (CAR TR] [change (ffetch CHARSETDESCENT of CSINFO) (MAX DATUM (ffetch \SFDescent of (CAR TR] [freplace \SFHeight of FONTDESC with (PLUS (change (ffetch \SFAscent of FONTDESC) (MAX DATUM (ffetch CHARSETASCENT of CSINFO))) (change (ffetch \SFDescent of FONTDESC) (MAX DATUM (ffetch CHARSETDESCENT of CSINFO]) (RETURN NEWTRANSLATION]) ) (DEFINEQ (\DSPFONT.PRESS [LAMBDA (PRSTREAM FONT) (* rmk%: "25-Feb-86 11:05") (* * The DSPFONT method for PRESS-type image streams --  change the stream's current logical font to FONT;  the device font changes only when we print a character) (PROG (OLDFONT FDENTRY (PRDATA (ffetch IMAGEDATA of PRSTREAM))) (SETQ OLDFONT (ffetch PRLOGICALFONT of PRDATA)) (COND ([OR (NULL FONT) (EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'PRESS T) (FONTCOPY OLDFONT FONT] (RETURN OLDFONT))) (freplace PRLOGICALFONT of PRDATA with FONT) (freplace PRLOGICALCHARSET of PRDATA with NIL) [\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA) (\FGETCHARWIDTH FONT (CHARCODE SPACE] [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS MicasPerPoint )) (FONTPROP FONT 'HEIGHT] (\FIXLINELENGTH.PRESS PRSTREAM) (RETURN OLDFONT]) (\DSPSPACEFACTOR.PRESS [LAMBDA (STREAM FACTOR) (* rmk%: "24-Feb-86 09:49") (LET ((PRDATA (ffetch IMAGEDATA of STREAM))) (PROG1 (ffetch PRSPACEFACTOR of PRDATA) (COND (FACTOR (SHOW.PRESS STREAM) (freplace PRSPACEFACTOR of PRDATA with FACTOR) (\SETSPACE.PRESS STREAM (FIXR (TIMES FACTOR (\FGETCHARWIDTH (ffetch PRLOGICALFONT of PRDATA) (CHARCODE SPACE]) (\ENTITYSTART.PRESS [LAMBDA (PRSTREAM) (* thh%: "10-Dec-86 08:33") (PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))) (freplace PRSPACEWIDTH of PRDATA with NIL) (* This really should be the spacewidth of the current font.  But then, if we switch fonts to one whose space*spacefactor comes out the  same, we won't know to put out a setspace command.  So when we actually set up the first font in this entity, we will end up  putting out an explicit setspace (even if the space factor is 1)) (freplace PRFONT of PRDATA with NIL) (freplace PRLOGICALFONT of PRDATA with NIL) (* We set the font to NIL, knowing that the current font can be recoverd from  the PRCURRFDE. This font will be set in the press file before the first show,  if no explicit dspfont intervenes. Note, however, that up until the first  dspfont, the widthscache still corresponds to what was the PRLOGICALFONT) (freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM)) (freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM of PRDATA))) (freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM)) (* Entity starts with position at 0,0 so must re-establish current position  (?)) (SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA) (fetch PRYPOS of PRDATA]) (\SETSPACE.PRESS [LAMBDA (PRSTREAM S) (* rmk%: "31-Mar-86 16:08") (PROG (ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM))) (AND (EQ S (ffetch PRSPACEWIDTH of PRDATA)) (RETURN)) (SHOW.PRESS PRSTREAM) (SETQ ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM))) (if (ILEQ S 2047) then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8) S)) else (\BOUT ELSTREAM SetSpaceXCode) (\WOUT ELSTREAM S)) (freplace PRSPACEWIDTH of PRDATA with S]) (\STARTPAGE.PRESS [LAMBDA (PRSTREAM) (* rmk%: "25-Feb-86 11:36") (* Should be called only when no previous page is open) (PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch IMAGEDATA of PRSTREAM))) (SETQ CFONT (ffetch PRLOGICALFONT of PRDATA)) (* Save current font so that \ENTITYSTART.PRESS can make PRLOGICALFONT be  NIL, indicating that there is no actual font at the beginning of a page) (\ENTITYSTART.PRESS PRSTREAM) [COND ((ffetch PRHEADING of PRDATA) (SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA)) (freplace PRSPACEFACTOR of PRDATA with 1) (SETQ HFONT (ffetch PRHEADINGFONT of PRDATA)) (\DSPFONT.PRESS PRSTREAM HFONT) (* Set up heading font) [SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) (IDIFFERENCE (ffetch PRTOP of PRDATA) (FONTPROP HFONT 'ASCENT] (PRIN3 (ffetch PRHEADING of PRDATA) PRSTREAM) (* Skip an inch before page number) (SHOW.PRESS PRSTREAM) (SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA))) (PRIN3 "Page " PRSTREAM) (PRIN3 (add (ffetch PRPAGENUM of PRDATA) 1) PRSTREAM) (NEWLINE.PRESS PRSTREAM) (* Skip 2 lines) (NEWLINE.PRESS PRSTREAM) (freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR)) (T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) (IDIFFERENCE (ffetch PRTOP of PRDATA) (FONTPROP CFONT 'ASCENT] (* Now we set the font to our (previous) current font) (\DSPFONT.PRESS PRSTREAM CFONT]) (\PRESS.COERCEFONT [LAMBDA (FONT FAMILY) (* rmk%: "25-Mar-86 15:44") (* coerces FONT to be new FAMILY FAMILY, and caches result on  \PRESS.COERCEDFONTS) (DECLARE (GLOBALVARS \PRESS.COERCEDFONTS)) (COND [[OR (NOT FAMILY) (EQ FAMILY (FONTPROP FONT 'FAMILY] (* Don't call FONTCOPY if it's the same font.  This avoids circularity thru AVGCHARWIDTH and CHARWIDTH before the font has  been stored in \FONTSINCORE.) (COND ((EQ 'PRESS (FONTPROP FONT 'DEVICE)) (* How could it not be PRESS? Ask  Tad.) FONT) (T (FONTCOPY FONT 'DEVICE 'PRESS] ((OR (FONTP FAMILY) (LISTP FAMILY)) (* FAMILY is a font specification) (FONTCOPY FAMILY 'DEVICE 'PRESS)) [(FONTP (CADR (ASSOC FONT (CDR (ASSOC FAMILY \PRESS.COERCEDFONTS] (T (LET [(pressFont (OR (FONTCOPY FONT 'FAMILY FAMILY 'DEVICE 'PRESS 'NOERROR T) (FONTCOPY FONT 'FAMILY FAMILY 'FACE 'STANDARD 'DEVICE 'PRESS] (push [CDR (OR (ASSOC FAMILY \PRESS.COERCEDFONTS) (CAR (push \PRESS.COERCEDFONTS (CONS FAMILY] (LIST FONT pressFont)) pressFont]) (\DSPFONT.PRESSFONT [LAMBDA (PRSTREAM PRFONT) (* thh%: "16-Jun-86 10:50") (* Changes the Pressfiles device  font) (PROG (FDENTRY LFONT OLDFONT (PRDATA (ffetch IMAGEDATA of PRSTREAM))) (SETQ OLDFONT (ffetch PRFONT of PRDATA)) (SHOW.PRESS PRSTREAM) (SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM PRFONT)) (COND ((NEQ (ffetch FONTSET# of FDENTRY) (ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA))) (* Swtich font sets) (* must save and restore current logical font since \ENTITYSTART.PRESS makes  it NIL) (SETQ LFONT (ffetch PRLOGICALFONT of PRDATA)) (\ENTITYEND.PRESS PRSTREAM) (\ENTITYSTART.PRESS PRSTREAM) (\DSPFONT.PRESS PRSTREAM LFONT))) (freplace PRCURRFDE of PRDATA with FDENTRY) (freplace PRFONT of PRDATA with PRFONT) (\BOUT (ffetch ELSTREAM of PRDATA) (LOGOR FontCode (ffetch FONT# of FDENTRY))) (RETURN OLDFONT]) (SETUPFONTS.PRESS [LAMBDA (PRSTREAM FONTS) (* thh%: "10-Dec-86 08:43") (* creates fonts in the initial fontset.  and sets heading font. Leaves PRFONT as NIL.  This means that \DSPFONT.PRESS of the heading font will establish that as the  current font when the first page opens.) (* since FONTS are logical, not device, fonts, they are not added to the  fontset here) (for F FLG inside (OR FONTS DEFAULTFONT) do (SETQ F (FONTCREATE F NIL NIL NIL 'PRESS)) (COND (FLG NIL) (T (\DSPFONT.PRESS PRSTREAM F) (* Install first font as current logical font and heading font.) (\ENTITYEND.PRESS PRSTREAM) (replace PRHEADINGFONT of (fetch IMAGEDATA of PRSTREAM) with F) (SETQ FLG T]) ) (DEFINEQ (\CREATEPRESSFONT [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* ; "Edited 9-Mar-88 15:54 by thh:") (* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS") (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES)) (RESETLST (* ;  "RESETLST to make sure the fontfiles get closed") (PROG ((FD (create FONTDESCRIPTOR FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ PSIZE FONTFACE _ FACE \SFFACECODE _ (\FACECODE FACE) ROTATION _ ROTATION FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72)) \SFHeight _ 0 \SFAscent _ 0 \SFDescent _ 0))) (OR (\GETCHARSETINFO 0 FD T) (RETURN NIL)) (RETURN FD]) (\CREATECHARSET.PRESS [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC) (* ; "Edited 9-Mar-88 15:19 by thh:") (* ;;; "determines widths and translations to print the charset with Press fonts. Note that we get widths from widths of font translated to, which should be original press values because translations are always to press fonts.") (* ;;; "NOTE: This code makes fonts that translate to themselves circular, and also gives fonts high reference counts. The translations should not be circular.") (DECLARE (GLOBALVARS PRESSFONTFAMILIES)) (PROG ((CSETTRANSLATIONARRAY (\NSTOASCIIARRAY CHARSET)) CSINFO widths (translationArray (ARRAY 256 NIL NIL 0)) (ascent 0) (descent 0) CSETZEROTRANSLATIONS) (* ;; "Determine translations for this charset") [COND [(ZEROP CHARSET) (* ;; "set up charsetinfo -- includes any coercions to known press fonts") (SETQ CSINFO (\CREATECHARSETZERO.PRESS FAMILY SIZE FACE ROTATION DEVICE FONTDESC)) (OR CSINFO (RETURN NIL)) (* ;  "unable to coerce to a press font") (* ;; "get translations for charset-0") (COND [(SETQ CSETZEROTRANSLATIONS (ASSOC (FONTPROP FONTDESC 'FAMILY) PRESSFONTFAMILIES)) (* ; "use identity transformation") (for i from 0 to 255 do (SETA translationArray i (CONS FONTDESC i)) ) (* ;  "except for font-specific non-identities") (for X in (CDR CSETZEROTRANSLATIONS) do (SETA translationArray (CAR X) (\NSTOASCIITRANSLATION (CADR X) FAMILY FONTDESC] (T (* ;; "Not a press font: assume NS font which will be translated into a press font") (for i from 0 to 255 do (SETA translationArray i (\NSTOASCIITRANSLATION (COND ((AND CSETTRANSLATIONARRAY (ELT CSETTRANSLATIONARRAY i))) (T (LIST (OR FAMILY (FONTPROP FONTDESC 'FAMILY)) i))) FAMILY FONTDESC] (T (* ;; "CHARSET not zero, assume NS codes") (for i from 0 to 255 do (SETA translationArray i (\NSTOASCIITRANSLATION (AND CSETTRANSLATIONARRAY (ELT CSETTRANSLATIONARRAY i)) FAMILY FONTDESC] (* ;; "Set the widths array and install the translations in the CHARSETINFO") (OR CSINFO (SETQ CSINFO (create CHARSETINFO))) (SETQ widths (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for i from 0 to 255 bind translation pressFont newAscent newDescent do (SETQ translation (ELT translationArray i)) (SETQ pressFont (CAR translation)) [COND ((AND (ZEROP CHARSET) (EQ pressFont FONTDESC)) (* ;  "this is charset-0 font translating to itself, use widths already defined") (\FSETWIDTH widths i (\FGETWIDTH widths (CDR translation))) (SETQ newAscent (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (SETQ newDescent (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) (T (\FSETWIDTH widths i (\FGETCHARWIDTH pressFont (CDR translation))) (SETQ newAscent (ffetch (FONTDESCRIPTOR \SFAscent) of pressFont)) (SETQ newDescent (ffetch (FONTDESCRIPTOR \SFDescent) of pressFont] (SETQ ascent (MAX ascent newAscent)) (SETQ descent (MAX descent newDescent))) (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (ffetch (ARRAYP BASE) of translationArray) ) (replace (CHARSETINFO CHARSETASCENT) of CSINFO with ascent) (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with descent) (RETURN CSINFO]) (\CREATECHARSETZERO.PRESS [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FD) (* ; "Edited 9-Mar-88 15:27 by thh:") (* ;;; "creates CSINFO for charset 0 of press fonts from info in widths file (without translations).") (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES FONTCOERCIONS MISSINGFONTCOERCIONS)) (RESETLST (* ;  "RESETLST to make sure the fontfiles get closed") (PROG* (WSTRM STRMCACHE FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY WIDTHS (PRESSMICASIZE (IQUOTIENT (ITIMES SIZE 2540) 72)) (NSMICASIZE (FIXR (FQUOTIENT (ITIMES SIZE 2540) 72))) (FACECODE (\FACECODE FACE)) (CSINFO (create CHARSETINFO)) CHARSETHEIGHT FOO FBBOX) (* ;;; "Go look for the fonts.widths file that has this font's info in it.") (OR [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE for F inside PRESSFONTWIDTHSFILES when (INFILEP F) first (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION 'PRESS FONTCOERCIONS)) [COND (XLATEDNAME (SETQ NEWFAMILY (CAR XLATEDNAME)) (SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR XLATEDNAME ) 2540) 72))) (SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME] do (* ;  "Look thru the candidate PRESSFONTWIDTHSFILES for a file that has a description for this font.") [COND [(SETQ WSTRM (\GETSTREAM F 'INPUT T)) (COND ((RANDACCESSP WSTRM) (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM))) (SETFILEPTR WSTRM 0] (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8)) '(PROGN (CLOSEF? OLDVALUE] [OR (RANDACCESSP WSTRM) (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW] (push STRMCACHE WSTRM) (* ; "Save for coercions below") (COND ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM (OR NEWNSMICASIZE NSMICASIZE) FIRSTCHAR LASTCHAR (OR NEWFAMILY FAMILY) (OR NEWFACECODE FACECODE))) (* ;  "OK, we found this font described in this file.") (COND (XLATEDNAME (replace FONTDEVICESPEC of FD with XLATEDNAME) (SETQ NSMICASIZE NEWNSMICASIZE))) (RETURN T] [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE XLATEDNAMES first (SETQ STRMCACHE (DREVERSE STRMCACHE)) while (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION 'PRESS MISSINGFONTCOERCIONS XLATEDNAMES)) thereis (push XLATEDNAMES XLATEDNAME) (for old WSTRM in STRMCACHE first (SETQ NEWFAMILY (CAR XLATEDNAME)) (SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR XLATEDNAME ) 2540) 72))) (SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME))) do (* ;  "Now try coercing the family name") (* ;; "We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the file list") (SETFILEPTR WSTRM 0) (COND ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NEWNSMICASIZE FIRSTCHAR LASTCHAR NEWFAMILY NEWFACECODE)) (replace FONTDEVICESPEC of FD with XLATEDNAME ) (SETQ NSMICASIZE NEWNSMICASIZE) (RETURN T] (RETURN NIL)) (* ;;; "Having found the font-widths file, now read the width info from it.") (SETQ RELFLAG (ZEROP RELFLAG)) (* ; "Actually, \POSITIONFONTFILE returns zero if the font metrics are size-relative and must be scaled.") (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM) BYTESPERWORD)) (* ;; "Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.") (SETQ FBBOX (SIGNED (\WIN WSTRM) BITSPERWORD)) (* ;  "replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)") (* ;  "Get the max bounding width for the font") (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (IMINUS (SIGNED (\WIN WSTRM) BITSPERWORD))) (* ; "Descent is -FBBOY") (SETQ FOO (\WIN WSTRM)) (* ;  "replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)") (* ; "And the standard kern value (?)") (SETQ CHARSETHEIGHT (SIGNED (\WIN WSTRM) BITSPERWORD)) (* ;  "replace \SFHeight of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)") (* ; "Height is FBBDY") [COND (RELFLAG (* ;  "Dimensions are relative, must be scaled") (* ;; "replace (FONTDESCRIPTOR FBBOX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD) NSMICASIZE) 1000)") (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (IQUOTIENT (ITIMES (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO) NSMICASIZE) 1000)) (* ;; "replace (FONTDESCRIPTOR FBBDX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD) NSMICASIZE) 1000)") (SETQ CHARSETHEIGHT (IQUOTIENT (ITIMES CHARSETHEIGHT NSMICASIZE) 1000] (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (IDIFFERENCE CHARSETHEIGHT (fetch CHARSETDESCENT of CSINFO))) (SETQ FIXEDFLAGS (LRSH (\BIN WSTRM) 6)) (* ; "The fixed flags") (\BIN WSTRM) (* ; "Skip the spares") [COND ((EQ 2 (LOGAND FIXEDFLAGS 2)) (* ; "This font is fixed width.") (SETQ TEM (\WIN WSTRM)) (* ;  "Read the fixed width for this font") [COND ((AND RELFLAG (NOT (ZEROP TEM))) (* ;  "If it's size relative, scale it.") (SETQ TEM (IQUOTIENT (ITIMES TEM NSMICASIZE) 1000] (for I from FIRSTCHAR to LASTCHAR do (* ;  "Fill in the char widths table with the width.") (\FSETWIDTH WIDTHS I TEM))) (T (* ;  "Variable width font, so we have to read widths.") (* ;  "AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) WSTRM") (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHS I noInfoCode)) (\BINS (\GETOFD WSTRM 'INPUT) WIDTHS (UNFOLD FIRSTCHAR BYTESPERWORD) (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) BYTESPERWORD)) (* ; "Read the X widths.") (for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHS I)) do (* ;  "For chars that have no width info, let width be zero.") (\FSETWIDTH WIDTHS I 0)) (COND (RELFLAG (* ;  "If the widths are size-relative, scale them.") (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHS I (IQUOTIENT (ITIMES (\FGETWIDTH WIDTHS I) NSMICASIZE) 1000] [COND [(EQ 1 (LOGAND FIXEDFLAGS 1)) (COND ((ILESSP (GETFILEPTR WSTRM) (GETEOFPTR WSTRM)) (SETQ WIDTHSY (\WIN WSTRM))) (T (* ;  "STAR FONT FILES LIKE TO LEAVE OFF THE Y WIDTH.") (SETQ WIDTHSY 0))) (* ;  "The fixed width-Y for this font; the width-Y field is a single integer in the FD") (replace (CHARSETINFO YWIDTHS) of CSINFO with (COND ((AND RELFLAG (NOT (ZEROP WIDTHSY))) (IQUOTIENT (ITIMES WIDTHSY NSMICASIZE) 1000)) (T WIDTHSY] (T (* ;  "Variable Y-width font. Fill it in as above") (SETQ WIDTHSY (replace (CHARSETINFO YWIDTHS) of CSINFO with ( \CREATECSINFOELEMENT ))) (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHSY I noInfoCode)) (\BINS (\GETOFD WSTRM 'INPUT) WIDTHSY (UNFOLD FIRSTCHAR BYTESPERWORD) (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) BYTESPERWORD)) (* ; "Read the Y widths") (for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHSY I)) do (* ;  "Let any characters with no width info be zero height") (\FSETWIDTH WIDTHSY I 0)) (COND (RELFLAG (* ;  "If the widths are size-relative, scale them.") (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHSY I (IQUOTIENT (ITIMES (\FGETWIDTH WIDTHSY I) NSMICASIZE) 1000] (RETURN CSINFO]) ) (DEFINEQ (\PRESSCURVE2 [LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT) (* thh%: "16-Jun-86 10:53") (* Given a spline curve and a font, draw the lines to PRSTREAM) (RESETLST (RESETSAVE NIL (LIST '\DSPFONT.PRESSFONT PRSTREAM (\DSPFONT.PRESSFONT PRSTREAM BRUSHFONT))) [PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))) (COND ((IGREATERP (IDIFFERENCE (GETFILEPTR (fetch ELSTREAM of PRDATA)) (fetch ELSTARTBYTE of PRDATA)) 25000) (\ENTITYEND.PRESS PRSTREAM) (* Hack to prevent mysterious  overflow in length of entities) (\ENTITYSTART.PRESS PRSTREAM] (\BOUT (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM)) ResetSpaceCode) (* because the space code shouldn't be interpreted specially when we are  drawing in the vector font) (PROG ((XPOLY (create POLYNOMIAL)) (X'POLY (create POLYNOMIAL)) (YPOLY (create POLYNOMIAL)) (Y'POLY (create POLYNOMIAL)) (X (fetch (SPLINE SPLINEX) of SPLINE)) (Y (fetch (SPLINE SPLINEY) of SPLINE)) (X' (fetch (SPLINE SPLINEDX) of SPLINE)) (Y' (fetch (SPLINE SPLINEDY) of SPLINE)) (X'' (fetch (SPLINE SPLINEDDX) of SPLINE)) (Y'' (fetch (SPLINE SPLINEDDY) of SPLINE)) (X''' (fetch (SPLINE SPLINEDDDX) of SPLINE)) (Y''' (fetch (SPLINE SPLINEDDDY) of SPLINE)) (%#KNOTS (fetch %#KNOTS of SPLINE)) (X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1)) (Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1)) IX IY DX DY XT YT X'T Y'T NEWXT NEWYT XDIFF YDIFF XWALLDT YWALLDT DUPLICATEKNOT EXTRANEOUS TT NEWT DELTA DASHON DASHLST DASHCNT HALFVECWIDTH PUTDX EXTRADX PUTDY EXTRADY) (SETQ HALFVECWIDTH (FONTPROP BRUSHFONT 'SIZE)) (* Half the width of the brush, in dots.  Used to help decide when the line we're drawing goes off-paper.) (SETQ DASHON T) (* These are initialized outside the prog-bindings cause the compiler can't  hack so many initialized variables) (SETQ DASHLST DASHING) (SETQ DASHCNT (CAR DASHING)) (SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan)) (FIXR (FTIMES Y0 MicasPerScan))) (* Move to the first knot on the  curve) (replace VECMOVINGRIGHT of (fetch IMAGEDATA of PRSTREAM) with T) (* Start by assuming we're moving in  increasing X (since the vector fonts  only have strokes that work in that  direction)) (replace VECWASDISPLAYING of (fetch IMAGEDATA of PRSTREAM) with (AND (GEQ X0 0) (GEQ Y0 0))) (replace VECSEGCHARS of (fetch IMAGEDATA of PRSTREAM) with NIL) (replace VECCURX of (fetch IMAGEDATA of PRSTREAM) with X0) (* And set the current X and Y positions, denominated in dover spots) (replace VECCURY of (fetch IMAGEDATA of PRSTREAM) with Y0) (* Set up initial values in vec  variables, perform SetX/SetY.) (SETQ TT 0.0) (SETQ DELTA 16) (SETQ IX (FIXR X0)) (SETQ IY (FIXR Y0)) [for KNOT# from 1 to (SUB1 %#KNOTS) do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#) (ELT X'' KNOT#) (ELT X' KNOT#) (ELT X KNOT#)) (* Set up the polynomials that describe X and X' over this segment) (LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#) (ELT Y'' KNOT#) (ELT Y' KNOT#) (ELT Y KNOT#)) (* Set up the polynomials that describe Y and Y' over this segment) (SETQ XT (POLYEVAL TT XPOLY 3)) (* XT _ X (t) --Evaluate the next  point) (SETQ YT (POLYEVAL TT YPOLY 3)) (* YT _ Y (t)) (COND [(NOT (IEQP KNOT# (SUB1 %#KNOTS))) (* This isn't the last knot. Check to see if the next knot in line is a  duplicated knot.) (SETQ DUPLICATEKNOT (AND (EQP (ELT X (ADD1 KNOT#)) (ELT X (IPLUS KNOT# 2))) (EQP (ELT Y (ADD1 KNOT#)) (ELT Y (IPLUS KNOT# 2] (T (SETQ DUPLICATEKNOT NIL))) [until (GEQ TT 1.0) do (* Run the parameter, TT, from 0.0 up to |1.0.|  That moves the X and Y locations smoothly from this knot to the next one.) (SETQ X'T (POLYEVAL TT X'POLY 2)) (* X'T _ X' (t)) (SETQ Y'T (POLYEVAL TT Y'POLY 2)) (* Y'T _ Y' (t)) (COND ((EQP X'T 0.0) (* Never let X' really get to 0.0 -- things become ill-conditioned there.) (SETQ X'T 5.0E-4))) (COND ((EQP Y'T 0.0) (* Likewise Y'.) (SETQ Y'T 5.0E-4))) [COND ((FGTP X'T 0.0) (* If X' is positive, we'll try moving in the +X direction) (SETQ DX DELTA)) (T (* If not, we'll try the -X  direction.) (SETQ DX (IMINUS DELTA] [COND ((FGTP Y'T 0.0) (* Likewise, if Y' is positive, try moving by DELTA in the +Y direction) (SETQ DY DELTA)) (T (SETQ DY (IMINUS DELTA] (SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX) XT) X'T)) (* Compute a dT, based on moving by DELTA in X.) (SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY) YT) Y'T)) (* And a dT based on moving by DELTA in Y.) [COND ((FLESSP XWALLDT YWALLDT) (* Use the smaller of the two dT's. In this case, dT for X was smaller, so  compute a new DY as depending on DX.) (SETQ NEWT (FPLUS TT XWALLDT)) (SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T))) IY))) (T (* Changing Y gave the smaller dT. Compute a new DX, as though it depended on  DY.) (SETQ NEWT (FPLUS TT YWALLDT)) (SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T))) IX] (SETQ PUTDX DX) (SETQ EXTRADX 0) (SETQ PUTDY DY) (SETQ EXTRADY 0) [COND ((IGREATERP DX 16) (SETQ PUTDX 16) (SETQ EXTRADX (IDIFFERENCE DX 16] [COND ((IGREATERP -16 DX) (SETQ PUTDX -16) (SETQ EXTRADX (IPLUS DX 16] [COND ((IGREATERP DY 16) (SETQ PUTDY 16) (SETQ EXTRADY (IDIFFERENCE DY 16] [COND ((IGREATERP -16 DY) (SETQ PUTDY -16) (SETQ EXTRADY (IPLUS DY 16] (COND ([AND (FGTP NEWT 1.0) (OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS] (SETQ NEWT 1.0))) (SETQ NEWXT (POLYEVAL NEWT XPOLY 3)) (* New XT _ X (new t)) (SETQ NEWYT (POLYEVAL NEWT YPOLY 3)) (* New YT _ Y (new t)) (SETQ XDIFF (ABS (FDIFFERENCE (IPLUS IX DX) NEWXT))) (SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY) NEWYT))) (COND ((AND (IGREATERP DELTA 1) (OR (FGTP XDIFF 1.0) (FGTP YDIFF 1.0))) (* If we're more than a dover spot off where we'd expect to be because of the  size of DELTA--and if there's room to make DELTA smaller--then try  DELTA_DELTA/2) (SETQ DELTA (LRSH DELTA 1))) (T (* No, this estimate is close enough. Put out a vector segment based on it,  and move to the new TT.) (\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH) (* Print out a stroke using the  vector font.) (COND ((OR (NEQ EXTRADX 0) (NEQ EXTRADY 0)) (* If, actually, it was too big for one stroke, use another.) (\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH))) (SETQ IX (IPLUS IX DX)) (* Our new current location, in  Dover spots) (SETQ IY (IPLUS IY DY)) (SETQ TT NEWT) (* Set TT to its new value) (SETQ XT NEWXT) (* And set the new floating-point values for X  (t) and Y (t)%.) (SETQ YT NEWYT) (COND ((AND (ILESSP DELTA 16) (OR (FLESSP XDIFF 0.5) (FLESSP YDIFF 0.5))) (* If we were especially close, try making DELTA larger for the next go  round.) (SETQ DELTA (LLSH DELTA 1] (SETQ TT (FDIFFERENCE TT 1.0)) (* Having moved past a knot, back the value of the parameter TT back down.  However, don't set it to 0.0--let's try to keep the line going from where it  got to in passing the last knot.) (COND (DUPLICATEKNOT (* This next knot is a duplicate. Skip over it, and start from the following  knot. This will avoid odd problems trying to go nowhere while obeying the  constraints of X' and Y' at that knot--since it's a duplicate, X' and Y' are  discontinuous there.) (add KNOT# 1] (\ENDVECRUN PRSTREAM HALFVECWIDTH]) ) (* Generic utility for coercing fonts, could be used by other devices) (DEFINEQ (\COERCEFONT [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE COERCELIST BUTNOT CREATEFLG) (* ; "Edited 9-Mar-88 12:58 by thh:") (* ;; "Returns a font name that the requested font specification coerces to according to COERCELIST. If CREATEFLG is T, only returns name-lists for which a font descriptor has been created. BUTNOT can be a list of font-specs which are not an acceptable coercion--e.g. a previous one that failed, so we want to keep looking beyond that one.") (* ;;; "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL (probably only useful for display fonts)") (* ;; "COERCELIST is an alist of font coercions indexed by device, with the value for each device being a list of the form ((user-font real-font) (user-font real-font) ...) --- Each user-font is either simply a family name, or a list of FAMILY, and optionally SIZE, and FACE, in standard font-name order. Any of these can be NIL, meaning that any requested value matches. In addition, the SIZE can be either a specific number, or a constraint of the form (< n) or (> n), which matches requested sizes that are less than or greater than the constraint size n. --- The real-font is a similar family-name or list, except that a NIL field here means that the requested parameter is simply carried over. Also, no size constraints, only explicit sizes, are allowed. (e.g., (GACHA) or (GACHA (< 10)) or (GACHA 10))") (for TRANSL in (CDR (ASSOC DEVICE COERCELIST)) bind NEWCSINFO USERSPEC REALSPEC FAMCONSTRAINT SIZECONSTRAINT FACECONSTRAINT NEWFONTNAME when (AND (SETQ USERSPEC (CAR TRANSL)) (OR [NULL (SETQ FAMCONSTRAINT (COND ((LISTP USERSPEC) (pop USERSPEC)) (T (PROG1 USERSPEC (SETQ USERSPEC NIL] (EQ FAMILY FAMCONSTRAINT)) (OR (NOT (SETQ SIZECONSTRAINT (pop USERSPEC))) (EQ SIZE SIZECONSTRAINT) (AND (LISTP SIZECONSTRAINT) (SELECTQ (CAR SIZECONSTRAINT) (< (LESSP SIZE (CADR SIZECONSTRAINT))) (> (GREATERP SIZE (CADR SIZECONSTRAINT))) NIL))) (OR (NOT (SETQ FACECONSTRAINT (pop USERSPEC))) (EQUAL FACE FACECONSTRAINT)) (SETQ REALSPEC (CADR TRANSL)) (SETQ NEWFONTNAME (LIST (OR [COND ((LISTP REALSPEC) (pop REALSPEC)) (T (PROG1 REALSPEC (SETQ REALSPEC NIL] FAMILY) (OR (pop REALSPEC) SIZE) (\FONTFACE (OR (pop REALSPEC) FACE)) ROTATION DEVICE)) (NOT (for EXCLUDE in BUTNOT thereis (EQUAL EXCLUDE NEWFONTNAME))) (OR (NULL CREATEFLG) (FONTCREATE NEWFONTNAME NIL NIL NIL NIL T))) do (RETURN NEWFONTNAME]) ) (ADDTOVAR FONTCOERCIONS (PRESS ((SYMBOL (< 10)) (SYMBOL 10)) ((SYMBOL (> 12)) (SYMBOL 12)))) (ADDTOVAR MISSINGFONTCOERCIONS (PRESS (MODERN HELVETICA) (CLASSIC TIMESROMAN) (LOGOTYPE LOGO) (TERMINAL GACHA) (MODERN FRUTIGER) (CLASSIC CENTURY))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) ) (DEFINEQ (\STRINGWIDTH.PRESS [LAMBDA (STREAM STRING RDTBL) (* rmk%: "24-Feb-86 09:49") (* Returns the width of STRING in the press STREAM, observing spacefactor) (\STRINGWIDTH.GENERIC STRING (ffetch PRLOGICALFONT of (ffetch IMAGEDATA of STREAM )) RDTBL (ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM]) (\CHARWIDTH.PRESS [LAMBDA (STREAM CHARCODE) (* rmk%: "24-Feb-86 09:49") (* Gets the width of CHARCODE in a Press STREAM, observing spacefactor) (COND ((EQ CHARCODE (CHARCODE SPACE)) (ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM))) (T (\FGETCHARWIDTH (ffetch PRLOGICALFONT of (ffetch IMAGEDATA of STREAM)) CHARCODE]) (\OUTCHARFN.PRESS [LAMBDA (PRSTREAM CHARCODE) (* rmk%: "24-Feb-86 12:18") (* Handle all the special-purpose characters going to a PRESS file) (SELCHARQ CHARCODE (EOL (* New Line) (NEWLINE.PRESS PRSTREAM) (replace (STREAM CHARPOSITION) of PRSTREAM with 0)) (LF (* Line feed--move down, but not  over) (\DSPXPOSITION.PRESS PRSTREAM (PROG1 (DSPXPOSITION NIL PRSTREAM) (NEWLINE.PRESS PRSTREAM)))) (^L (* Form Feed) (replace (STREAM CHARPOSITION) of PRSTREAM with 0) (NEWPAGE.PRESS PRSTREAM)) (PROG (XPOS NEWXPOS CLIPPINGREGION PRCHARCODE TRANSLATION (CHARSET (\CHARSET CHARCODE)) (PRDATA (fetch IMAGEDATA of PRSTREAM))) [if (NEQ CHARSET (ffetch PRLOGICALCHARSET of PRDATA)) then (LET [(CSINFO (\GETCHARSETINFO CHARSET (ffetch PRLOGICALFONT of PRDATA] (UNINTERRUPTABLY (freplace PRWIDTHSCACHE of PRDATA with (fetch (CHARSETINFO WIDTHS) of CSINFO)) (freplace PRTRANSLATIONCACHE of PRDATA with (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO )) (freplace PRLOGICALCHARSET of PRDATA with CHARSET))] (SETQ TRANSLATION (\GETBASEPTR (ffetch PRTRANSLATIONCACHE of PRDATA) (UNFOLD (\CHAR8CODE CHARCODE) 2))) (if (NEQ (CAR TRANSLATION) (fetch PRFONT of PRDATA)) then (\DSPFONT.PRESSFONT PRSTREAM (CAR TRANSLATION))) (SETQ PRCHARCODE (CDR TRANSLATION)) (SETQ XPOS (fetch PRXPOS of PRDATA)) [SETQ NEWXPOS (IPLUS XPOS (COND ((EQ CHARCODE (CHARCODE SPACE)) (ffetch PRSPACEWIDTH of PRDATA)) (T (\FGETWIDTH (ffetch (PRESSDATA PRWIDTHSCACHE) of PRDATA) (\CHAR8CODE CHARCODE] (COND ((AND [IGEQ XPOS (fetch LEFT of (SETQ CLIPPINGREGION (fetch PRClippingRegion of PRDATA] (ILEQ NEWXPOS (fetch RIGHT of CLIPPINGREGION)) (IGEQ (fetch PRYPOS of PRDATA) (fetch BOTTOM of CLIPPINGREGION))) (* Bottom test should really subtract off the descent, and also should do a  top-test) (* The Y-tests can probably be done inside SETXY, SETY, and DSPFONT.) [COND ((NOT (ffetch CHARWASDISPLAYING of PRDATA)) (* Was being clipped, now not) (freplace CHARWASDISPLAYING of PRDATA with T) (SHOW.PRESS PRSTREAM) (* SHOW shouldn't be necessary, but  |...|) (SETXY.PRESS PRSTREAM XPOS (fetch PRYPOS of PRDATA] (\BOUT PRSTREAM PRCHARCODE)) (T (SHOW.PRESS PRSTREAM) (* Don't put out any characters if out of the clipping region) (freplace CHARWASDISPLAYING of PRDATA with NIL))) (replace PRXPOS of PRDATA with NEWXPOS]) ) (* * new declaration for PRESSDATA) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE PRESSDATA (PRHEADING (* ;  "The string to be printed atop each page.") PRHEADINGFONT (* ; "Font to print the heading in") PRXPOS (* ; "Current X position") PRYPOS (* ; "Current Y position") PRFONT (* ; "Current font") PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER (* ;  "Widths table for the current logical character set") ) PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME (PRLEFT WORD) (* ; "Page left margin") (PRBOTTOM WORD) (* ; "Page bottom margin") (PRRIGHT WORD) (* ; "Page right margin") (PRTOP WORD) (* ; "Page top margin") (PRPAGENUM WORD) (* ; "Current Page number") (PRNEXTFONT# BYTE) (PRMAXFONTSET BYTE) (PRPARTSTART INTEGER) (DLSTARTBYTE INTEGER) (ELSTARTBYTE INTEGER) (STARTCHARBYTE INTEGER) (VECMOVINGRIGHT FLAG) (* ;  "If we're drawing a curve with vector fonts, are we moving to the right?") (VECWASDISPLAYING FLAG) (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.") VECSEGCHARS (* ;  "Cache for vector characters while we're moving to the left.") VECCURX (* ;  "Current X position within vector code, in Dover spots") VECCURY (* ;  "Current Y position with vector code, in Dover spots") PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG) (* ;  "Says whether we have been printing characters inside the clipping region") PRClippingRegion (* ;; "The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image goes off-paper") PRLOGICALFONT (* ; "Current logical font") PRLOGICALCHARSET (* ;  "Current logical character set, whose info is cached. NIL if cache is invalid") (PRTRANSLATIONCACHE POINTER (* ;  "Translation table for the current logical character set") )) PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 (* ;  "We assume that the origin is translated to the bottom-left of the page region") PRClippingRegion _ (create REGION LEFT _ SPRUCEPAPERLEFTMICAS BOTTOM _ SPRUCEPAPERBOTTOMMICAS WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS SPRUCEPAPERLEFTMICAS) HEIGHT _ 29210) [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM) (fetch (PRESSDATA PRLEFT) of DATUM))) (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM) (fetch (PRESSDATA PRBOTTOM) of DATUM))) (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM) (PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM with NEWVALUE) (replace (PRESSDATA PRLEFT) of DATUM with (fetch (REGION LEFT) of NEWVALUE )) (replace (PRESSDATA PRBOTTOM) of DATUM with (fetch (REGION BOTTOM) of NEWVALUE)) (replace (PRESSDATA PRRIGHT) of DATUM with (IPLUS (fetch (REGION LEFT) of NEWVALUE) (fetch (REGION WIDTH) of NEWVALUE))) (replace (PRESSDATA PRTOP) of DATUM with (IPLUS (fetch (REGION BOTTOM) of NEWVALUE) (fetch (REGION HEIGHT) of NEWVALUE]) ) (/DECLAREDATATYPE 'PRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER ) '((PRESSDATA 0 POINTER) (PRESSDATA 2 POINTER) (PRESSDATA 4 POINTER) (PRESSDATA 6 POINTER) (PRESSDATA 8 POINTER) (PRESSDATA 10 POINTER) (PRESSDATA 12 POINTER) (PRESSDATA 14 POINTER) (PRESSDATA 16 POINTER) (PRESSDATA 18 POINTER) (PRESSDATA 20 POINTER) (PRESSDATA 22 POINTER) (PRESSDATA 24 POINTER) (PRESSDATA 26 POINTER) (PRESSDATA 28 POINTER) (PRESSDATA 30 (BITS . 15)) (PRESSDATA 31 (BITS . 15)) (PRESSDATA 32 (BITS . 15)) (PRESSDATA 33 (BITS . 15)) (PRESSDATA 34 (BITS . 15)) (PRESSDATA 28 (BITS . 7)) (PRESSDATA 26 (BITS . 7)) (PRESSDATA 35 FIXP) (PRESSDATA 37 FIXP) (PRESSDATA 39 FIXP) (PRESSDATA 41 FIXP) (PRESSDATA 24 (FLAGBITS . 0)) (PRESSDATA 24 (FLAGBITS . 16)) (PRESSDATA 44 POINTER) (PRESSDATA 46 POINTER) (PRESSDATA 48 POINTER) (PRESSDATA 50 POINTER) (PRESSDATA 52 POINTER) (PRESSDATA 52 (FLAGBITS . 0)) (PRESSDATA 54 POINTER) (PRESSDATA 56 POINTER) (PRESSDATA 58 POINTER) (PRESSDATA 60 POINTER)) '62) ) (/DECLAREDATATYPE 'PRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER ) '((PRESSDATA 0 POINTER) (PRESSDATA 2 POINTER) (PRESSDATA 4 POINTER) (PRESSDATA 6 POINTER) (PRESSDATA 8 POINTER) (PRESSDATA 10 POINTER) (PRESSDATA 12 POINTER) (PRESSDATA 14 POINTER) (PRESSDATA 16 POINTER) (PRESSDATA 18 POINTER) (PRESSDATA 20 POINTER) (PRESSDATA 22 POINTER) (PRESSDATA 24 POINTER) (PRESSDATA 26 POINTER) (PRESSDATA 28 POINTER) (PRESSDATA 30 (BITS . 15)) (PRESSDATA 31 (BITS . 15)) (PRESSDATA 32 (BITS . 15)) (PRESSDATA 33 (BITS . 15)) (PRESSDATA 34 (BITS . 15)) (PRESSDATA 28 (BITS . 7)) (PRESSDATA 26 (BITS . 7)) (PRESSDATA 35 FIXP) (PRESSDATA 37 FIXP) (PRESSDATA 39 FIXP) (PRESSDATA 41 FIXP) (PRESSDATA 24 (FLAGBITS . 0)) (PRESSDATA 24 (FLAGBITS . 16)) (PRESSDATA 44 POINTER) (PRESSDATA 46 POINTER) (PRESSDATA 48 POINTER) (PRESSDATA 50 POINTER) (PRESSDATA 52 POINTER) (PRESSDATA 52 (FLAGBITS . 0)) (PRESSDATA 54 POINTER) (PRESSDATA 56 POINTER) (PRESSDATA 58 POINTER) (PRESSDATA 60 POINTER)) '62) (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) %, where translationArrayName is bound to a translation array for charset which contains (fontFamily charcode) lists) (DEFINEQ (\NSTOASCIIARRAY [LAMBDA (CHARSET) (* thh%: "17-Feb-86 09:05") (* gets the translation array to use  for this charset) (EVAL (CADR (ASSOC CHARSET NSTOASCIITRANSLATIONS]) (\NSTOASCIITRANSLATION [LAMBDA (TRANSLATION FAMILY FONTDESC) (* thh%: " 5-Mar-86 10:23") (* returns (fontdesc . charcode) to use in place of the specified 8-bit  charcode) (* FAMILY, if specified, is font family to use when not specified by the  translation array) (* * determine the (family charcode) translation) (OR TRANSLATION (SETQ TRANSLATION unknownCharTranslation)) [COND ((FIXP TRANSLATION) (SETQ TRANSLATION (LIST (OR FAMILY FONTDESC) TRANSLATION] (* * coerce to a full font descriptor) (CONS (\PRESS.COERCEFONT FONTDESC (CAR TRANSLATION)) (CADR TRANSLATION]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES) ) (RPAQ? PRESSFONTFAMILIES '((GACHA) (TIMESROMAN) (HELVETICA) (SYMBOL) (MATH) (HIPPO) (CYRILLIC) (NEWVEC) (SNEWVEC) (HNEWVEC) (VNEWVEC))) (RPAQ? NSTOASCIITRANSLATIONS ) (ADDTOVAR NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) (38 ASCIIFROM38ARRAY) (39 ASCIIFROM39ARRAY) (239 ASCIIFROM239ARRAY)) (READVARS-FROM-STRINGS '(ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) "({Y256 POINTER 0 {R163 NIL} (SYMBOL 126) (SYMBOL 127) NIL NIL (SYMBOL 120) NIL 96 NIL NIL (SYMBOL 55) (SYMBOL 34) (SYMBOL 33) (SYMBOL 35) NIL (SYMBOL 6) NIL NIL (SYMBOL 2) NIL (SYMBOL 123) NIL (SYMBOL 13) 39 {R25 NIL} (SYMBOL 125) {R44 NIL} } {Y256 POINTER 0 (HIPPO 118) {R64 NIL} (HIPPO 65) (HIPPO 66) NIL (HIPPO 71) (HIPPO 68) (HIPPO 69) NIL NIL (HIPPO 90) (HIPPO 72) (HIPPO 81) ( HIPPO 73) (HIPPO 75) (HIPPO 76) (HIPPO 77) (HIPPO 78) (HIPPO 67) (HIPPO 79) (HIPPO 80) NIL ( HIPPO 82) (HIPPO 83) NIL (HIPPO 84) (HIPPO 85) (HIPPO 70) (HIPPO 88) (HIPPO 89) (HIPPO 87) NIL NIL NIL (HIPPO 97) (HIPPO 98) NIL (HIPPO 103) (HIPPO 100) (HIPPO 101) NIL NIL (HIPPO 122) ( HIPPO 104) (HIPPO 113) (HIPPO 105) (HIPPO 107) (HIPPO 108) (HIPPO 109) (HIPPO 110) (HIPPO 99) (HIPPO 111) (HIPPO 112) NIL (HIPPO 114) (HIPPO 115) (HIPPO 106) (HIPPO 116) (HIPPO 117) (HIPPO 102) (HIPPO 120) (HIPPO 121) (HIPPO 119) {R130 NIL} } {Y256 POINTER 0 (CYRILLIC 127) {R32 NIL} ( CYRILLIC 65) (CYRILLIC 66) (CYRILLIC 86) (CYRILLIC 71) (CYRILLIC 68) (CYRILLIC 69) (CYRILLIC 36) (CYRILLIC 87) (CYRILLIC 90) (CYRILLIC 73) (CYRILLIC 74) (CYRILLIC 75) (CYRILLIC 76) (CYRILLIC 77) (CYRILLIC 78) (CYRILLIC 79) (CYRILLIC 80) (CYRILLIC 82) (CYRILLIC 83) (CYRILLIC 84) ( CYRILLIC 85) (CYRILLIC 70) (CYRILLIC 81) (CYRILLIC 126) (CYRILLIC 42) (CYRILLIC 123) (CYRILLIC 125) (CYRILLIC 94) (CYRILLIC 88) (CYRILLIC 67) (CYRILLIC 64) (CYRILLIC 89) (CYRILLIC 72) {R15 NIL} (CYRILLIC 97) (CYRILLIC 98) (CYRILLIC 118) (CYRILLIC 103) (CYRILLIC 100) (CYRILLIC 101) ( CYRILLIC 52) (CYRILLIC 119) (CYRILLIC 122) (CYRILLIC 105) (CYRILLIC 106) (CYRILLIC 107) ( CYRILLIC 108) (CYRILLIC 109) (CYRILLIC 110) (CYRILLIC 111) (CYRILLIC 112) (CYRILLIC 114) ( CYRILLIC 115) (CYRILLIC 116) (CYRILLIC 117) (CYRILLIC 102) (CYRILLIC 113) (CYRILLIC 54) ( CYRILLIC 56) (CYRILLIC 91) (CYRILLIC 93) (CYRILLIC 95) (CYRILLIC 120) (CYRILLIC 143) (CYRILLIC 50) (CYRILLIC 121) (CYRILLIC 104) {R12 NIL} (CYRILLIC 99) {R129 NIL} } {Y256 POINTER 0 {R36 NIL} (TIMESROMAN 155) (TIMESROMAN 156) {R6 NIL} (TIMESROMAN 152) (TIMESROMAN 153) NIL (TIMESROMAN 159) (MATH 33) (MATH 70) (SYMBOL 104) (SYMBOL 105) NIL NIL (SYMBOL 96) (SYMBOL 97) (MATH 113) NIL ( SYMBOL 109) (SYMBOL 108) (MATH 116) (MATH 118) (MATH 115) (MATH 117) (MATH 64) NIL (SYMBOL 37) (SYMBOL 38) {R4 NIL} (MATH 109) NIL (MATH 66) (MATH 78) (MATH 44) (SYMBOL 40) (SYMBOL 44) ( SYMBOL 41) (MATH 126) (MATH 81) (SYMBOL 36) (MATH 98) NIL NIL (SYMBOL 92) (SYMBOL 91) (SYMBOL 19) (SYMBOL 18) (SYMBOL 27) (SYMBOL 26) NIL NIL (MATH 75) (MATH 72) NIL (MATH 79) (SYMBOL 8) ( SYMBOL 9) (MATH 54) (SYMBOL 11) (TIMESROMAN 183) (SYMBOL 5) (MATH 104) NIL (SYMBOL 58) NIL ( SYMBOL 54) NIL NIL (MATH 22) (SYMBOL 16) (MATH 80) (SYMBOL 17) (SYMBOL 29) NIL (SYMBOL 115) ( MATH 7) (SYMBOL 39) NIL (SYMBOL 25) (MATH 19) (MATH 1) (SYMBOL 112) (SYMBOL 7) {R41 NIL} ( SYMBOL 59) {R6 NIL} (MATH 82) NIL (SYMBOL 100) (SYMBOL 101) (SYMBOL 98) (SYMBOL 99) (SYMBOL 57) (SYMBOL 56) (SYMBOL 94) (SYMBOL 95) (MATH 90) (MATH 68) (MATH 100) {R69 NIL} }) ") (\SMASHPRESSFONTS) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ unknownCharTranslation (MATH 59)) [CONSTANTS (unknownCharTranslation '(MATH 59] ) ) (PUTPROPS PRESSFROMNS COPYRIGHT ("Xerox Corporation" 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3994 4370 (\SMASHPRESSFONTS 4004 . 4368)) (4371 8600 (GETCHARPRESSTRANSLATION 4381 . 5419) (PRESS.NSARRAY 5421 . 6744) (PUTCHARPRESSTRANSLATION 6746 . 8598)) (8601 19311 (\DSPFONT.PRESS 8611 . 10062) (\DSPSPACEFACTOR.PRESS 10064 . 10916) (\ENTITYSTART.PRESS 10918 . 12640) ( \SETSPACE.PRESS 12642 . 13344) (\STARTPAGE.PRESS 13346 . 15454) (\PRESS.COERCEFONT 15456 . 16922) ( \DSPFONT.PRESSFONT 16924 . 18298) (SETUPFONTS.PRESS 18300 . 19309)) (19312 41000 (\CREATEPRESSFONT 19322 . 20520) (\CREATECHARSET.PRESS 20522 . 25622) (\CREATECHARSETZERO.PRESS 25624 . 40998)) (41001 55544 (\PRESSCURVE2 41011 . 55542)) (55624 59376 (\COERCEFONT 55634 . 59374)) (60032 65529 ( \STRINGWIDTH.PRESS 60042 . 60535) (\CHARWIDTH.PRESS 60537 . 61002) (\OUTCHARFN.PRESS 61004 . 65527)) ( 75785 76950 (\NSTOASCIIARRAY 75795 . 76147) (\NSTOASCIITRANSLATION 76149 . 76948))))) STOP \ No newline at end of file diff --git a/lispusers/PRESSFROMNS.TEDIT b/lispusers/PRESSFROMNS.TEDIT new file mode 100644 index 00000000..26a478d1 Binary files /dev/null and b/lispusers/PRESSFROMNS.TEDIT differ diff --git a/lispusers/PRETTYFILEINDEX b/lispusers/PRETTYFILEINDEX new file mode 100644 index 00000000..44e101cc --- /dev/null +++ b/lispusers/PRETTYFILEINDEX @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Aug-92 17:27:48" "{Pele:mv:envos}Medley>PRETTYFILEINDEX.;3" 90678 changes to%: (VARS PRETTYFILEINDEXCOMS) (FNS PFI.MAKE.LPT.STREAM) previous date%: "11-Jun-92 16:01:31" "{Pele:mv:envos}Medley>PRETTYFILEINDEX.;2") (* ; " Copyright (c) 1988, 1992 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PRETTYFILEINDEXCOMS) (RPAQQ PRETTYFILEINDEXCOMS [(COMS (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX) (FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN PFI.COLLECT.DEFINERS PFI.AFTER.NEW.PAGE) (FNS PFI.PRINT.FILECREATED PFI.PRINT.TO.TAB PFI.PRINT.ENVIRONMENT) (FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE PFI.ESTIMATE.SIZE1)) (COMS (* ; "Expression handlers") (FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE)) (COMS (* ; "Previewers") (FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ)) (COMS (* ; "Printing the index") (FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME) (FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES)) (COMS (* ; "Combined listings") (FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST PFI.MERGE.INDICES)) (COMS (* ;  "Hooks for seeing files pretty elsewhere") (FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION) (INITVARS (*PRINT-PRETTY-FROM-FILES* T))) (COMS (* ; "Bitmap hack") (FNS PFI.PRINT.BITMAP) (INITVARS (*PRINT-PRETTY-BITMAPS* T))) (INITVARS [*PFI-PRINTOPTIONS* '(REGION (72 54 504 702] (*PFI-DONT-SPAWN*) (*PFI-MAX-WASTED-LINES* 12) [*PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC] (*PFI-INDEX-ORDER* '(FUNCTIONS)) [*PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))) (* ;;  "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN] (\PFI.PROCESS.COMMANDS) (\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (\PFI.PROCESS)) (COMS (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex") (INITVARS (*PFI-TITLE*) (*PFI-PAGE-COUNT* 0))) (ADDVARS (*PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (*PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (*PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (*PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (*PFI-FILTERS* (VARIABLES . CONSTANTS))) (COMS (* ;  "Prettyprint augmentation to mimic system makefile dumping") (FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT MAYBE.PRETTYPRINT.BOLD) (ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) [P (CL:PROCLAIM '(CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG] (RECORDS PFITYPE) (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*)) [DECLARE%: EVAL@COMPILE DOCOPY (* ;  "Public variables to declare special") (P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (GETD 'CODEWRAPPER.PRETTYPRINT) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ;  "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ;  "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE" )) (* ; "Also fix SEE") (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ;  "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION) (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP) 'NILL) 'NON.PFI.PRINT.BITMAP NIL T]) (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (DEFINEQ (PFI.NEW.LISTFILES1 (LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Substitute for LISTFILES1") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FULL (FINDFILE FILENAME T))) (COND ((NOT FULL) (* ; "When called by LISTFILES, FILENAME will already be a full file name") (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FILENAME)) (*PFI-DONT-SPAWN* (MAYBE.PRETTYFILEINDEX FULL PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MAYBE.PRETTYFILEINDEX) FULL PRINTOPTIONS)) FULL)))) ) (PFI.ENQUEUE (LAMBDA (FORM) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Add FORM to the background hardcopy's task list") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (COND ((AND \PFI.PROCESS (NOT (FIND.PROCESS \PFI.PROCESS))) (* ; "Process died, flush handle and any old listing requests") (SETQ \PFI.PROCESS (SETQ \PFI.PROCESS.COMMANDS NIL)))) (SETQ \PFI.PROCESS.COMMANDS (NCONC1 \PFI.PROCESS.COMMANDS FORM)) (COND ((NULL \PFI.PROCESS) (SETQ \PFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \PFI.DO.HARDCOPY)) (QUOTE BEFOREEXIT) (QUOTE DON'T) (QUOTE NAME) "Do-Hardcopy")))))) ) (\PFI.DO.HARDCOPY (LAMBDA NIL (* ; "Edited 25-Mar-88 16:49 by bvm") (* ;;; "Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (while \PFI.PROCESS.COMMANDS bind FORM do (SETQ FORM (pop \PFI.PROCESS.COMMANDS)) (RELEASE.MONITORLOCK \PFI.PROCESSLOCK) (* ; "Release lock while listing so that others can add to my queue") (APPLY (CAR FORM) (CDR FORM)) (OBTAIN.MONITORLOCK \PFI.PROCESSLOCK) finally (* ; "Nothing left to do, so exit") (SETQ \PFI.PROCESS NIL)))) ) (MAYBE.PRETTYFILEINDEX (LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 11-Apr-88 10:50 by bvm") (* ;;; "Performs PRETTYFILEINDEX on FILENAME if it is a file manager file, else calls the old listfiles1.") (COND ((COND ((PRETTYFILEINDEX FILENAME PRINTOPTIONS) T) (T (PFI.ORIGINAL.LISTFILES1 FILENAME PRINTOPTIONS))) (* ;; "Do this here since there is little coordination between the various multiple processes which are listing files") (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FILENAME) NOTLISTEDFILES)) NIL))) ) ) (DEFINEQ (PRETTYFILEINDEX [LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 11-Jun-92 15:58 by cat") (* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.") (RESETLST [PROG ((*STANDARD-OUTPUT* *STANDARD-OUTPUT*) (*STANDARD-INPUT* *STANDARD-INPUT*) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*UPPER-CASE-FILE-NAMES* NIL) (PRETTYFLG T) (*PRINT-PRETTY-BITMAPS* 'PRETTYFILEINDEX) (*PFI-PAGE-COUNT*) (*PFI-PAGE-PREFIX* "Page ") (*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS '%#SIDES) EMPRESS#SIDES) 2)) (*PFI-TITLE*) (*PFI-ITEM*) (*PFI-TYPES* *PFI-TYPES*) (*PFI-FILEVARS*) (*PFI-FNSLST*) (*PFI-LOCATIONS*) (*PFI-MAX-WASTED-LINES* *PFI-MAX-WASTED-LINES*) (*PFI-FUNNY-CHARS*) (*PFI-BITMAP-BASELINE*) (*PFI-PENDING-COMMENTS*) FILECREATED ENV WASOPEN MULTIFILEINDEX CRDATE INDICES PART# FIRSTPAGE LASTPAGE CRDATE) (* ;; "Specials are as follows:") (* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image") (* ;; "*PFI-PAGE-COUNT* -- number of current page") (* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing") (* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers") (* ;; "*PFI-ITEM* -- function, etc currently being printed") (* ;; "*PFI-TYPES* -- list specifying the type associated with an expression") (* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*") (* ;;  "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF") (* ;;  "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences") (* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.") (* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars") (* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default") (* ;;  "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed") (* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.") [if (TYPENAMEP FILENAME 'STREAM) then (* ; "Already have input stream") [SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT] else (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME 'INPUT 'OLD '((SEQUENTIAL T] (SETQ FILENAME (FULLNAME *STANDARD-INPUT*)) (CL:FORMAT PROMPTWINDOW "~%%Starting index of ~A." FILENAME) [if (LISTGET PRINTOPTIONS :COMMON) then (* ; "Common Lisp file") (SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*) else (* ;  "Figure out if this is a file manager file, and if so get environment") (CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED) (\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T)) (if (NULL FILECREATED) then (* ; "Not a File Manager file") (RETURN NIL) elseif (NEQ (CAR (LISTP FILECREATED)) 'FILECREATED) then (* ;  "File started with open paren, but isn't file manager file.") (RETURN (if WASOPEN then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy") (PRINTDEF FILECREATED T T NIL NIL OUTSTREAM) (PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME)) elseif (LISTP (CADDR FILECREATED)) then (* ;  "A compiled file--just use COPYBYTES to avoid binary hassles.") (RETURN (if WASOPEN then (* ;  "Print environment and filecreated before copying rest") (PRINT-READER-ENVIRONMENT ENV OUTSTREAM) (WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED OUTSTREAM)) (COPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME] [if OUTSTREAM then (SETQ *PFI-TITLE* FILENAME) (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT)) else (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) (push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME))) (SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT) (if NOPRINT then (* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually") (\CORE.CLOSEFILE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (\GENERIC-UNREGISTER-STREAM (fetch (STREAM DEVICE) of STREAM) STREAM) (\CORE.DELETEFILE (FULLNAME STREAM) (fetch (STREAM DEVICE) of STREAM)) else (CLOSEF? STREAM] *STANDARD-OUTPUT* (LISTGET PRINTOPTIONS :DONTPRINT] (* ;  "Make sure printer knows original name of file") (RESETSAVE (LINELENGTH (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) *STANDARD-OUTPUT*)) (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (PFI.SETUP.TRANSLATIONS)) [if DONTINDEX then (* ; "This is for SEE etc") (SETQ *PFI-MAX-WASTED-LINES* 0) (SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother") (SETQ *PFI-LOCATIONS* :NONE) else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE)) (* ; "Enable header printing") [SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND] (* ; "Says to do something with coms") [if (NOT (FIXP *PFI-MAX-WASTED-LINES*)) then (* ;  "a parameter expressed as a fraction of page") (SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES* (- (PFI.LINES.REMAINING ) 2] [SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES) (PFI.COLLECT.DEFINERS *PFI-TYPES*] (* ;  "Add known record types and definers to the list.") (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE] [SETQ *PFI-PAGE-COUNT* (SETQ FIRSTPAGE (LOGOR (OR (LISTGET PRINTOPTIONS :FIRSTPAGE) 1) (if *PFI-TWO-SIDED* then (* ; "Make first page odd") 1 else 0] (if (SETQ PART# (LISTGET PRINTOPTIONS :PART)) then (SETQ *PFI-PAGE-PREFIX* (CONCAT *PFI-PAGE-PREFIX* PART# "-"))) (RETURN (WITH-READER-ENVIRONMENT ENV (if FILECREATED then (PFI.PRINT.FILECREATED FILECREATED ENV)) (PFI.PROCESS.FILE DONTINDEX) (if (NOT WASOPEN) then (* ;  "We're through with input file now, so release it") (CLOSEF *STANDARD-INPUT*)) (if (SETQ MULTIFILEINDEX (LISTGET PRINTOPTIONS 'MULTIFILEINDEX)) then (* ;  "True on calls from multifileindex-remember the date and last page#") (SETQ LASTPAGE *PFI-PAGE-COUNT*)) (if (NOT DONTINDEX) then (* ;  "Now that we've scanned whole file, print the index") (SETQ INDICES (PFI.PRINT.INDEX CRDATE))) [if (NULL OUTSTREAM) then (CL:FORMAT PROMPTWINDOW "~%%Finished indexing ~A (~D pages)" FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE] (if (NULL MULTIFILEINDEX) then FILENAME else (push INDICES (LIST FILENAME CRDATE LASTPAGE ENV)) (if (NLISTP MULTIFILEINDEX) then (* ;  "More to do yet, so just return this index") INDICES else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX INDICES) PRINTOPTIONS))))])]) (PFI.MAKE.LPT.STREAM [LAMBDA (PRINTOPTIONS) (* ; "Edited 19-Aug-92 13:57 by jds") (LET ([PRINTER (OR (LISTGET PRINTOPTIONS 'SERVER) (LISTGET PRINTOPTIONS 'HOST] (DEFAULTOPTIONS *PFI-PRINTOPTIONS*) REG S TEMPS SCALE) (* ;; "Get a dummy stream of the right image type, so we can get scaling right, etc. The (CAR (MKLIST ... code is stolen from OPENIMAGESTREAM's decision for IMAGETYPE.") [SETQ TEMPS (OPENIMAGESTREAM "{NODIRCORE}" (CAR (MKLIST (PRINTERPROP (PRINTERTYPE (OR PRINTER (OR (CAR (LISTP DEFAULTPRINTINGHOST )) DEFAULTPRINTINGHOST))) 'CANPRINT] (SETQ SCALE (DSPSCALE NIL TEMPS)) (CLOSEF TEMPS) (* ;; "Set up the margins (REGION) for the page correctly.") [COND [[AND (LISTGET PRINTOPTIONS 'LANDSCAPE) (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION] (* ;  "Don't use default region when caller specified landscape (tee hee)") (SETQ DEFAULTOPTIONS (for TAIL on DEFAULTOPTIONS by (CDDR TAIL) unless (EQ (CAR TAIL) 'REGION) join (LIST (CAR TAIL) (CADR TAIL] [[AND *PFI-TWO-SIDED* (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION)) (NOT (LISTGET PRINTOPTIONS 'REGION] (* ; "Shift image to the left 1/4%" so that it is balanced. Default region is assumed to be 1%" on left and 1/2%" on right. No adjustment if user gave region explicitly") (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS)) 'REGION (create REGION using REG LEFT _ (- (fetch (REGION LEFT) of REG) (FIXR (FTIMES 18 SCALE] (T (* ;;  "Scale the REGION option in *PFI-PRINTOPTIONS* from points into the real stream's units.") (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS)) 'REGION (SCALEREGION SCALE (LISTGET DEFAULTOPTIONS 'REGION] (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS DEFAULTOPTIONS)) [SETQ S (COND (PRINTER (OPENIMAGESTREAM (CONCAT "{LPT}" PRINTER) (CAR (PRINTERPROP (PRINTERTYPE PRINTER) 'CANPRINT)) PRINTOPTIONS)) (T (* ; "Use default printer & type") (OPENIMAGESTREAM NIL NIL PRINTOPTIONS] [STREAMPROP S 'PRINTOPTIONS (APPEND PRINTOPTIONS (STREAMPROP S 'PRINTOPTIONS] S]) (PFI.SETUP.TRANSLATIONS (LAMBDA NIL (* ; "Edited 14-Apr-88 11:51 by bvm") (* ;; "Prepare character translation table for this output stream") (* ;; "*PFI-CHARACTER-TRANSLATIONS* is an alist of (imagetype . charpairs), where each char pair is (sourcecode destcode . fontplist) describing the translation and optional font change for a specified input character. We set *PFI-FUNNY-CHARS* to (oldoutcharfn . triples), where each triple is (sourcecode destcode fontplist . fontcacheplist). ") (LET ((CHARPAIRS (CDR (ASSOC (IMAGESTREAMTYPE *STANDARD-OUTPUT*) *PFI-CHARACTER-TRANSLATIONS*)))) (SETQ *PFI-FUNNY-CHARS* (CONS (fetch (STREAM OUTCHARFN) of *STANDARD-OUTPUT*) (AND CHARPAIRS (LET ((FONT (DSPFONT))) (if (NEQ (CHARWIDTH (CHARCODE i) FONT) (CHARWIDTH (CHARCODE W) FONT)) then (* ; "Font is not fixed width, so don't need this kludge when substituting fonts") (SETQ FONT NIL)) (for PAIR in CHARPAIRS collect (* ;; "Each entry is (oldchar newchar . fontspec), where fontspec is optional plist to give to FONTCOPY to get a font derived from current font to print the char. Here we copy each entry, preparing cache for font change entries") (LIST* (pop PAIR) (pop PAIR) PAIR (if FONT then (* ; "First oldfont-newfont pair designates a fixed-width font") (LIST FONT (CL:APPLY (FUNCTION FONTCOPY) FONT PAIR)) else (* ; "Just waste this fixed-width entry") (LIST NIL NIL)))))))) (if CHARPAIRS then (* ; "Yes, want translation") (replace (STREAM OUTCHARFN) of *STANDARD-OUTPUT* with (FUNCTION PFI.OUTCHARFN))))) ) (PFI.OUTCHARFN (LAMBDA (STREAM CHAR) (* ; "Edited 14-Apr-88 12:40 by bvm") (* ;; "Our own OUTCHARFN that does character translation.") (DESTRUCTURING-BIND (FN . CASES) *PFI-FUNNY-CHARS* (do (if (NULL CASES) then (* ; "Not funny, just do it regular") (if (AND (EQ CHAR (CHARCODE EOL)) *PFI-BITMAP-BASELINE*) then (* ; "End of line on a line where we have printed bitmaps below the baseline--make sure we terpri far enough") (if (AND *PFI-BITMAP-BASELINE* (< *PFI-BITMAP-BASELINE* (DSPYPOSITION NIL STREAM))) then (* ; "Could be false if new page in between") (MOVETO (DSPXPOSITION NIL STREAM) *PFI-BITMAP-BASELINE* STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL) (if (NULL (CDR *PFI-FUNNY-CHARS*)) then (* ; "We existed only for this kludge--restore normal outcharfn") (replace (STREAM OUTCHARFN) of STREAM with FN))) (RETURN (CL:FUNCALL FN STREAM CHAR)) elseif (EQ (CAAR CASES) CHAR) then (* ; "Yes, it's a special char") (RETURN (DESTRUCTURING-BIND (C . FONTINFO) (CDAR CASES) (if (NULL FONTINFO) then (* ; "Simple translation in this font") (CL:FUNCALL FN STREAM C) else (* ; "Want to use char from another font") (LET* ((FONT (DSPFONT NIL STREAM)) (NEWFONT (LISTGET (CDR FONTINFO) FONT)) EXTRASPACE) (if (NOT NEWFONT) then (* ; "Other font not cached yet. FONTINFO = (spec . fontplist), where SPEC is something to give to FONTCOPY to modify the current font.") (NCONC FONTINFO (LIST FONT (SETQ NEWFONT (CL:APPLY (FUNCTION FONTCOPY) FONT (CAR FONTINFO)))))) (DSPFONT NEWFONT STREAM) (if (AND (EQ FONT (CADR FONTINFO)) (> (SETQ EXTRASPACE (- (CHARWIDTH C FONT) (CHARWIDTH C NEWFONT))) 0)) then (* ; "We were in a fixed width font, but substitution is from a font where the char is narrower, so make some space to maintain the fixed-width illusion.") (RELMOVETO (IQUOTIENT EXTRASPACE 2) 0 STREAM) (CL:FUNCALL FN STREAM C) (RELMOVETO (- EXTRASPACE (IQUOTIENT EXTRASPACE 2)) 0 STREAM) else (CL:FUNCALL FN STREAM C)) (DSPFONT FONT STREAM))))) else (SETQ CASES (CDR CASES)))))) ) (PFI.COLLECT.DEFINERS (LAMBDA (KNOWNTYPES) (* ; "Edited 11-Apr-88 12:26 by bvm") (* ;; "Scan all the definers in the system, creating PFITYPE entries for them if they're not already in the entries in KNOWNTYPES (e.g., might want DEFMACRO to be MACROS not FUNCTIONS). Bunch of conditionals in here because between Lyric and Medley the prop names changed from IL symbols to keywords. *PFI-DEFINER-PROPS* = (:definer-for :defined-by :definition-name)") (for TYPE in FILEPKGTYPES bind (BYPROP _ (CADR *PFI-DEFINER-PROPS*)) (NAMEPROP _ (CADDR *PFI-DEFINER-PROPS*)) when (LITATOM TYPE) join (for DEFINER in (GET TYPE BYPROP) collect (create PFITYPE NAME _ TYPE PATTERNS _ DEFINER TESTFN _ (GET DEFINER NAMEPROP)) unless (for ENTRY in KNOWNTYPES thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))))) ) (PFI.AFTER.NEW.PAGE (LAMBDA (STREAM) (* ; "Edited 12-May-88 09:58 by bvm") (DECLARE (USEDFREE *PFI-TITLE* *PFI-ITEM* *PFI-PAGE-COUNT*)) (* ;; "Called after the output image stream has turned the page. Bump our page count and print a suitable header.") (add *PFI-PAGE-COUNT* 1) (if *PFI-TITLE* then (LET ((*PRINT-BASE* 10) (LEFT *PFI-TITLE*) (RIGHT) (OLDFONT (DSPFONT))) (CHANGEFONT DEFAULTFONT) (* ; "Get back to canonical font for the header, saving whatever font was in effect at the page turn") (if (EQ *PFI-ITEM* :INDEX) then (* ; "In the index, omit page numbers") (SETQ *PFI-ITEM* NIL) else (SETQ RIGHT (CONCAT *PFI-PAGE-PREFIX* *PFI-PAGE-COUNT*))) (if (AND *PFI-TWO-SIDED* (EVENP *PFI-PAGE-COUNT*)) then (* ; "On even pages, print page numbers on outside (left)") (swap LEFT RIGHT)) (if LEFT then (PRIN3 LEFT)) (if (AND *PFI-ITEM* (NEQ *PFI-ITEM* :INDEX)) then (printout NIL " (" .FONT BOLDFONT |.P2| *PFI-ITEM* .FONT ITALICFONT " cont." .FONT DEFAULTFONT ")")) (if RIGHT then (DSPXPOSITION (- (DSPRIGHTMARGIN) (STRINGWIDTH RIGHT STREAM))) (PRIN3 RIGHT)) (TERPRI) (TERPRI) (DSPFONT OLDFONT)))) ) ) (DEFINEQ (PFI.PRINT.FILECREATED (LAMBDA (EXPR ENV) (* ; "Edited 13-Apr-88 11:14 by bvm") (* ;; "Display the FILECREATED expression and environment prettily") (* ;; "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") (pop EXPR) (CHANGEFONT ITALICFONT) (LET* ((STRINGS (QUOTE ("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"))) (FONT (DSPFONT)) (STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT))) (TABSTOP (+ (DSPLEFTMARGIN) (APPLY (FUNCTION MAX) STRWIDTHS)))) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "File created:") (PRINTOUT NIL (pop EXPR) " " .FONT LAMBDAFONT (pop EXPR) T T) (* ; "date and file name") (if (OR (NULL (CAR EXPR)) (FIXP (CAR EXPR))) then (* ; "Skip over filemaploc") (pop EXPR)) (if (EQ (CAR EXPR) (QUOTE changes)) then (* ; "handle %"Changes to:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) T NIL T) (TERPRI) (TERPRI) else (pop STRINGS) (pop STRWIDTHS)) (if (EQ (CAR EXPR) (QUOTE previous)) then (* ; "Handle %"Previous date:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTOUT NIL (pop EXPR) " " (pop EXPR) T T) else (pop STRINGS) (pop STRWIDTHS)) (LET ((SPEC (fetch RESPEC of ENV))) (* ; "Show environment") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Read table") (PFI.PRINT.ENVIRONMENT SPEC :READTABLE) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Package") (PFI.PRINT.ENVIRONMENT SPEC :PACKAGE) (if (NEQ *PRINT-BASE* 10) then (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (PFI.PRINT.ENVIRONMENT SPEC :BASE))))) ) (PFI.PRINT.TO.TAB (LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT)) ) (PFI.PRINT.ENVIRONMENT (LAMBDA (SPEC KEYWORD) (* ; "Edited 29-Mar-88 12:46 by bvm") (* ;; "Display the KEYWORD component of a reader environment spec") (LET ((VALUE (LISTGET SPEC KEYWORD))) (if (LISTP VALUE) then (* ; "An expression to create it--show pretty. Use IL package, since that's what they appear in at beginning of file") (LET ((*PACKAGE* *INTERLISP-PACKAGE*)) (PRINTDEF VALUE T T)) else (* ; "Just show the value, sans quotations, etc. The selectq is just in case this environment has no spec, something that shouldn't happen if it came from a define-file-info") (PRIN3 (OR VALUE (SELECTQ KEYWORD (:READTABLE (READTABLEPROP *READTABLE* (QUOTE NAME))) (:PACKAGE (CL:PACKAGE-NAME *PACKAGE*)) (SHOULDNT))))) (TERPRI) (TERPRI))) ) ) (DEFINEQ (PFI.PROCESS.FILE (LAMBDA (DONTINDEX) (* ; "Edited 13-Apr-88 12:59 by bvm") (* ;; "The main loop for PRETTYFILEINDEX--process expressions on the file until we're done.") (bind CH FN EXPR while (SETQ CH (SKIPSEPRCODES)) do (if (EQ CH (CHARCODE ";")) then (PFI.PASS.COMMENT) elseif (AND DONTINDEX (EQ CH (CHARCODE "("))) then (* ;; "From SEE. Want to have a look at the car so we don't take a long time reading the WHOLE expression that we can easily process in pieces, like DEFINEQ") (READCCODE) (* ; "Eat the paren") (if (AND (NOT (SYNTAXP (SKIPSEPRCODES) (QUOTE RIGHTPAREN))) (LITATOM (SETQ FN (CL:READ))) (SETQ EXPR (ASSOC FN *PFI-PREVIEWERS*))) then (* ; "Next thing was a symbol, and we have a previewer for this kind of expression--do it. SYNTAXP is just in case we encountered ( ).") (if *PFI-PENDING-COMMENTS* then (* ; "First dispose of pending comments") (PFI.PRINT.COMMENTS)) (CL:FUNCALL (CDR EXPR) FN) else (* ; "Failed--fall back on reading the whole thing") (PFI.HANDLE.EXPR (CONS FN (CL:READ-DELIMITED-LIST #\))))) elseif (OR (EQ (SETQ EXPR (CL:READ *STANDARD-INPUT* NIL *STANDARD-INPUT*)) *STANDARD-INPUT*) (EQ EXPR (QUOTE STOP))) then (* ; "Hit end of file") (RETURN) else (PFI.HANDLE.EXPR EXPR)) (BLOCK))) ) (PFI.PASS.COMMENT (LAMBDA NIL (* ; "Edited 15-Apr-88 18:16 by bvm") (* ;; "Copy a semi-colon comment to the output stream") (TERPRI) (CHANGEFONT COMMENTFONT) (bind CH do (if (NEQ (SETQ CH (READCCODE *STANDARD-INPUT*)) (CHARCODE EOL)) then (* ; "Pass a character") (\OUTCHAR *STANDARD-OUTPUT* CH) else (TERPRI) (if (NEQ (PEEKCCODE *STANDARD-INPUT* T) (CHARCODE ";")) then (* ; "End of comment") (RETURN)))) (CHANGEFONT DEFAULTFONT)) ) (PFI.HANDLE.EXPR (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:56 by bvm") (* ;; "Prettyprint the expression we just read to the output file, and also do any appropriate indexing") (if (AND *PFI-PENDING-COMMENTS* (NEQ (CAR (LISTP EXPR)) COMMENTFLG)) then (* ; "Dispose of pending comments") (PFI.PRINT.COMMENTS EXPR)) (if (NLISTP EXPR) then (* ; "Not a form") (TERPRI) (PRINT EXPR) elseif (NOT (LITATOM (CAR EXPR))) then (* ; "Odd random form on file. I hope the car is actually a lambda expression") (TERPRI) (PFI.MAYBE.NEW.PAGE EXPR) (PFI.PRETTYPRINT EXPR NIL T) else (CL:FUNCALL (OR (CDR (ASSOC (CAR EXPR) *PFI-HANDLERS*)) (FUNCTION PFI.DEFAULT.HANDLER)) EXPR))) ) (PFI.DEFAULT.HANDLER (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:54 by bvm") (* ;; "The default handler for an expression. Looks up in *PFI-TYPES* for matching entries, then prettyprints the expression.") (LET ((CAR-OF-FORM (CAR EXPR)) PAT ITEMNAME MAINITEM TESTFN TEMPLATE) (if (GET CAR-OF-FORM (CAR *PFI-DEFINER-PROPS*)) then (* ; "Put a little extra space before definers") (TERPRI)) (PFI.MAYBE.NEW.PAGE EXPR) (SETQ TEMPLATE (GET CAR-OF-FORM :DEFINITION-PRINT-TEMPLATE)) (for ENTRY in *PFI-TYPES* when (COND ((EQ (SETQ PAT (fetch (PFITYPE PATTERNS) of ENTRY)) T) (* ; "Matches anything -- TESTFN must be doing all the work") T) ((LISTP PAT) (MEMB CAR-OF-FORM PAT)) (T (EQ CAR-OF-FORM PAT))) do (SETQ TESTFN (fetch (PFITYPE TESTFN) of ENTRY)) (COND ((NULL TESTFN) (* ; "Extract default name") (if (NLISTP (SETQ ITEMNAME (if (AND TEMPLATE (MEMB :NAME TEMPLATE)) then (* ; "We're told more explicitly where the name is") (CL:NTH (CL:POSITION :NAME TEMPLATE) (CDR EXPR)) else (* ; "Name defaultly is second elt") (CADR EXPR)))) then (if (AND ITEMNAME (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) elseif (EQ (CAR ITEMNAME) (QUOTE QUOTE)) then (* ; "A quoted form, like (I.S.OPR 'COLLECT ...)") (PFI.ADD.TO.INDEX (SETQ MAINITEM (CADR ITEMNAME)) ENTRY) elseif (AND (SETQ ITEMNAME (CAR ITEMNAME)) (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (* ; "Some definer that takes a (name . options) slot here") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY))) ((SETQ ITEMNAME (CAR (NLSETQ (CL:FUNCALL TESTFN EXPR ENTRY)))) (COND ((NLISTP ITEMNAME) (* ; "Single object to be indexed as the type in ENTRY") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) (T (* ; "Index as some other type") (for PAIR in (COND ((LITATOM (CAR ITEMNAME)) (* ; "a single pair") (LIST ITEMNAME)) (T (* ; "many") ITEMNAME)) do (for NAME in (CDR PAIR) do (push *PFI-LOCATIONS* (LIST (CAR PAIR) NAME *PFI-PAGE-COUNT*)))))) (COND ((NOT (fetch (PFITYPE AMBIGUOUS?) of ENTRY)) (RETURN)))))) (PFI.PRETTYPRINT EXPR MAINITEM T))) ) (PFI.PRETTYPRINT (LAMBDA (EXPR NAME FORMFLG) (* ; "Edited 7-Apr-88 11:06 by bvm") (* ;; "Prettyprints EXPR. NAME is the %"name%" of the thing being prettyprinted, for benefit of header hackers. FORMFLG is true if thing should be printed as code.") (LET ((*PFI-ITEM* NAME)) (PRINTDEF EXPR T FORMFLG NIL *PFI-FNSLST*)) (TERPRI)) ) (PFI.LINES.REMAINING (LAMBDA NIL (* ; "Edited 11-Apr-88 17:23 by bvm") (* ;; "Returns number of lines left on this page, or a large number if stream does not tell us") (LET ((BOTTOM (DSPBOTTOMMARGIN))) (if (NULL BOTTOM) then 999 else (ADD1 (IQUOTIENT (- (DSPYPOSITION) BOTTOM) (- (DSPLINEFEED NIL *STANDARD-OUTPUT*))))))) ) (PFI.MAYBE.NEW.PAGE (LAMBDA (EXPR MINLINES) (* ; "Edited 13-Apr-88 14:32 by bvm") (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") (LET (REMAINING) (if (OR (DISPLAYSTREAMP *STANDARD-OUTPUT*) (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) *PFI-MAX-WASTED-LINES*) (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR)))) then (TERPRI) else (* ; "put it on a new page") (DSPNEWPAGE)))) ) (PFI.ESTIMATE.SIZE (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:37 by bvm") (* ;; "Guess how many lines EXPR will take, so that we can try getting it all on one page if we're near the bottom. Heuristic is that after the first list element in any element, each subsequent element gets its own line") (+ (LET ((TEMPLATE (AND (LITATOM (CAR EXPR)) (GET (CAR EXPR) :DEFINITION-PRINT-TEMPLATE)))) (if (AND TEMPLATE (MEMB :BODY TEMPLATE)) then (* ; "Make extra space for things that have body") 2 else 1)) (PFI.ESTIMATE.SIZE1 EXPR 0))) ) (PFI.ESTIMATE.SIZE1 (LAMBDA (EXPR INITSUM) (* ; "Edited 13-Apr-88 11:24 by bvm") (* ;; "Recursive part of PFI.ESTIMATE.SIZE's heuristic. We add on to INITSUM, and stop when it looks pointless to dive deeper. Heuristic says we have a new line every time there's a list element with something after it.") (if (LISTP EXPR) then (LET ((TAIL (SOME EXPR (FUNCTION LISTP)))) (add INITSUM (LENGTH (CDR TAIL))) (until (OR (NLISTP TAIL) (> INITSUM *PFI-MAX-WASTED-LINES*)) do (SETQ INITSUM (PFI.ESTIMATE.SIZE1 (pop TAIL) INITSUM))))) INITSUM) ) ) (* ; "Expression handlers") (DEFINEQ (PFI.HANDLE.RPAQQ (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET* ((NAME (CADR EXPR)) (COMSINFO (ASSOC NAME *PFI-FILEVARS*))) (COND ((AND COMSINFO (EQ (CDR COMSINFO) (QUOTE NOBIND))) (* ; "We don't yet know the value of this filevar, so here it is.") (RPLACD COMSINFO (CADDR EXPR)) (LET ((*MAINFILECOMS* (CDAR *PFI-FILEVARS*)) VARS VALUES) (* ;; "*PFI-FILEVARS* is an alist of (filevar . value), for all filevars we've discovered so far and any values of same. Since we have newly discovered the value of this var, the INFILECOMS? below may have changed some, so reevaluate them.") (for PAIR in (CDR *PFI-FILEVARS*) unless (EQ (CDR PAIR) (QUOTE NOBIND)) do (push VARS (CAR PAIR)) (push VALUES (CDR PAIR))) (CL:PROGV VARS VALUES (SETQ *PFI-FNSLST* (APPEND (INFILECOMS? NIL (QUOTE FNS) *MAINFILECOMS*) (INFILECOMS? NIL (QUOTE FUNCTIONS) *MAINFILECOMS*))) (for FV in (INFILECOMS? NIL (QUOTE FILEVARS) *MAINFILECOMS*) unless (OR (ASSOC FV *PFI-FILEVARS*) (BOUNDP FV)) do (* ;; "Add to the list any new filevars uncovered by this evaluation. Don't bother if they're already bound in the sysout, since then their values have already been made use of.") (push (CDR *PFI-FILEVARS*) (CONS FV (QUOTE NOBIND)))))))) (if (NEQ NAME (CAAR *PFI-FILEVARS*)) then (* ; "Don't bother indexing the main COMS") (PFI.ADD.TO.INDEX NAME (QUOTE VARIABLES))) (PFI.PRETTYPRINT EXPR NAME))) ) (PFI.HANDLE.DECLARE (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:33 by bvm") (* ;; "Handle (DECLARE: tags coms ...)") (if (NOT (LET ((TAIL (CDR EXPR))) (* ;; "Filter out (DECLARE: DONTCOPY (FILEMAP --))") (AND (LISTP TAIL) (EQ (pop TAIL) (QUOTE DONTCOPY)) (LISTP TAIL) (EQ (CAR (LISTP (pop TAIL))) (QUOTE FILEMAP)) (NULL TAIL)))) then (TERPRI) (PRIN1 "(") (PROG (STARTOFLINE NEXT) TOP (SETQ STARTOFLINE T) NEXTITEM (if (NLISTP EXPR) then (* ; "Done, except for possible malformed dotted tail") (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI) (RETURN)) (if (NLISTP (SETQ NEXT (pop EXPR))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) (GO NEXTITEM)) (* ;; "Have an interesting com, so go to new line and process it") (TERPRI) (do (PFI.HANDLE.EXPR NEXT) repeatwhile (AND (LISTP EXPR) (LISTP (SETQ NEXT (pop EXPR))))) (GO TOP)))) ) (PFI.HANDLE.EVAL-WHEN (LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:51 by bvm") (* ;; "Handle EVAL-WHEN. This is a lot like DECLARE: -- the inner expressions get treated as top-level.") (PFI.MAYBE.NEW.PAGE NIL (+ 2 (PFI.ESTIMATE.SIZE (CADDR EXPR)))) (* ; "Make space for the first expression, plus the eval-when & .. line") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (PRINT (pop EXPR)) (while (LISTP EXPR) do (PFI.HANDLE.EXPR (pop EXPR))) (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI)) ) (PFI.HANDLE.DEFDEFINER (LAMBDA (EXPR) (* ; "Edited 12-Apr-88 11:16 by bvm") (* ;; "Notice DEFDEFINER expressions. We don't actually evaluate them (let's not side-effect the environment too much), but notice that we should index them and that they should prettyprint interestingly.") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((DEFINER (CADR EXPR)) OPTIONS) (if (LISTP DEFINER) then (SETQ OPTIONS (CDR DEFINER)) (SETQ DEFINER (CAR DEFINER))) (if (NOT (LITATOM DEFINER)) then (* ; "Bogus") (SETQ DEFINER NIL) elseif *PFI-TYPES* then (* ; "We're indexing, maybe add this type") (if (NOT (for ENTRY in *PFI-TYPES* thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))) then (* ; "We don't know about this one yet") (push *PFI-TYPES* (create PFITYPE NAME _ (CADDR EXPR) PATTERNS _ DEFINER TESTFN _ (CADR (ASSOC :NAME OPTIONS))))) (if (NOT (ASSOC DEFINER PRETTYPRINTMACROS)) then (* ; "Help it prettyprint better") (push PRETTYPRINTMACROS (CONS DEFINER (CL:INTERN "PPRINT-DEFINER" (CL:FIND-PACKAGE (if (EQ MAKESYSNAME :LYRIC) then "IL" else "XCL"))))) (if (AND (SETQ OPTIONS (ASSOC :TEMPLATE OPTIONS)) (NOT (GET DEFINER :DEFINITION-PRINT-TEMPLATE))) then (PUT DEFINER :DEFINITION-PRINT-TEMPLATE (CADR OPTIONS)))) (PFI.ADD.TO.INDEX DEFINER (QUOTE DEFINERS))) (PFI.PRETTYPRINT EXPR DEFINER T))) ) (PFI.HANDLE.DEFINEQ (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:34 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...)") (TERPRI) (PRIN1 "(") (PRINT (CAR EXPR)) (for DEF in (CDR EXPR) do (PFI.PRINT.LAMBDA DEF)) (PRIN1 ")") (TERPRI)) ) (PFI.PRINT.LAMBDA (LAMBDA (DEF) (* ; "Edited 11-Apr-88 17:21 by bvm") (* ;; "Print one piece of a DEFINEQ. DEF is (fn (lambda ...)).") (PFI.MAYBE.NEW.PAGE NIL (PFI.ESTIMATE.SIZE1 (CDR DEF) 3)) (LET ((*PFI-ITEM* (CAR DEF))) (PFI.ADD.TO.INDEX *PFI-ITEM* (QUOTE FUNCTIONS)) (PFI.PRINT.LAMBDA.BODY DEF *PFI-FNSLST*)) (TERPRI) (TERPRI)) ) (PFI.PRINT.LAMBDA.BODY (LAMBDA (DEF FNSLST) (* ; "Edited 29-Mar-88 18:46 by bvm") (* ;; "Just the stuff that prints a lambda form. DEF = (name (lambda ...))") (PRIN1 "(") (CHANGEFONT (OR LAMBDAFONT BOLDFONT)) (PRIN2 (CAR DEF)) (CHANGEFONT DEFAULTFONT) (TERPRI) (SPACES 2) (PRINTDEF (CDR DEF) T (QUOTE FNS) T FNSLST) (PRIN1 ")")) ) (PFI.HANDLE.PUTDEF (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:10 by bvm") (* ;; "Called to handle PUTDEF. If in form (PUTDEF 'name 'type 'value), we can index name by type.") (PFI.MAYBE.NEW.PAGE EXPR) (DESTRUCTURING-BIND (NAME TYPE) EXPR (PFI.PRETTYPRINT EXPR (if (AND (LISTP NAME) (EQ (CAR NAME) (QUOTE QUOTE)) (LISTP TYPE) (EQ (CAR TYPE) (QUOTE QUOTE)) (LITATOM (SETQ TYPE (CADR TYPE)))) then (PFI.ADD.TO.INDEX (SETQ NAME (CADR NAME)) TYPE) (* ; "Yes, it is a quoted form we like") NAME)))) ) (PFI.HANDLE.PUTPROPS (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((NAME (CADR EXPR)) (PROP (CADDR EXPR)) TYPE) (* ; "See if PROP means something more specific than 'property'") (PFI.PRETTYPRINT EXPR (if (AND (LITATOM NAME) (SETQ TYPE (COND ((MEMB PROP MACROPROPS) (QUOTE MACRO)) (T (for PAIR in *PFI-PROPERTIES* when (EQ (CAR PAIR) PROP) do (* ; "Index it under this other type") (RETURN (CADR PAIR)) finally (* ; "Nothing better, so index it as having a property") (RETURN (QUOTE PROPERTY))))))) then (PFI.ADD.TO.INDEX NAME TYPE) (* ; "Yes, can name it this") NAME)))) ) (PFI.HANDLE./DECLAREDATATYPE (LAMBDA (EXPR) (* ; "Edited 13-Apr-88 11:29 by bvm") (* ;; "No point in wasting space printing the entirely redundant list of field descriptors from (/DECLAREDATATYPE typename fieldspecs fielddescriptors len supertype)") (PFI.MAYBE.NEW.PAGE EXPR 2) (PFI.PRETTYPRINT (if (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR)))))) then (* ; "Well-formed--bash the third argument") (LIST* (pop EXPR) (pop EXPR) (pop EXPR) (LIST (QUOTE *) (QUOTE ;;) "---field descriptor list elided by lister---") (CDR EXPR)) else EXPR) NIL T)) ) (PFI.HANDLE.* (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:38 by bvm") (* ;; "Handle * comments found at top level. Turn single-semis into double semis so that they print at the left. Save all comments until the next non-comment so we can achieve some locality.") (LET* ((NSEMIS (SEMI-COLON-COMMENT-P EXPR)) (LINEGUESS (+ (CL:CEILING (STRINGWIDTH (if NSEMIS then (CADDR EXPR) else (CDR EXPR)) *STANDARD-OUTPUT*) (TIMES (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) 0.9)) (if (AND NSEMIS (< NSEMIS 3)) then 1 else 2)))) (CASE NSEMIS (1 (* ; "Make it 2 semis") (SETQ EXPR (LIST* (QUOTE *) (QUOTE ;;) (CDDR EXPR)))) ((NIL) (* ; "Interlisp style") (if (NLISTP (CDR EXPR)) elseif (AND (NULL (CDDR EXPR)) (STRINGP (CADR EXPR))) then (* ; "Body is a string, so can print with superior semi-colon printer") (SETQ EXPR (LIST (QUOTE *) (QUOTE ;;) (CADR EXPR))) elseif (NEQ (CADR EXPR) COMMENTFLG) then (* ; "Turn single * into double star so it prints centered") (SETQ EXPR (LIST* (QUOTE *) (QUOTE *) (CDR EXPR)))))) (* ;; "Now don't print the comment yet, since we'd like it to attach to what follows") (if *PFI-PENDING-COMMENTS* then (add (CAR *PFI-PENDING-COMMENTS*) LINEGUESS) (NCONC1 *PFI-PENDING-COMMENTS* EXPR) else (SETQ *PFI-PENDING-COMMENTS* (LIST LINEGUESS EXPR))))) ) (PFI.PRINT.COMMENTS (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:27 by bvm") (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") (TERPRI) (DESTRUCTURING-BIND (LINES . BODIES) *PFI-PENDING-COMMENTS* (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (LET ((REMAINING (PFI.LINES.REMAINING))) (if (OR (>= LINES REMAINING) (AND (< REMAINING *PFI-MAX-WASTED-LINES*) (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) LINES)))) then (* ; "put it on a new page") (DSPNEWPAGE)))) (for B in BODIES do (PRINTDEF B T T) (if (> (DSPXPOSITION) (DSPLEFTMARGIN)) then (* ; "Go to new line for next comment. Usually this has already been done") (TERPRI))) (SETQ *PFI-PENDING-COMMENTS* NIL))) ) (PFI.HANDLE.FILEMAP (LAMBDA (EXPR) (* ; "Edited 31-Mar-88 15:28 by bvm") (* ;; "Only get here from declare: previewer (during SEE), since declare: expression handler filters out the whole thing.") (PFI.PRETTYPRINT (LIST (QUOTE *) (QUOTE ;;) "---Filemap elided by lister---") NIL T)) ) (PFI.HANDLE.PACKAGE (LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:38 by bvm") (* ;; "Handler for package-related functions, such as in-package, import, export, etc. Eval the form so that the package environment is set correctly for what follows.") (CL:EVAL EXPR) (TERPRI) (PFI.PRETTYPRINT EXPR NIL T)) ) ) (* ; "Previewers") (DEFINEQ (PFI.PREVIEW.DECLARE (LAMBDA (FN) (* ; "Edited 1-Apr-88 11:27 by bvm") (* ;; "Handle (DECLARE: tags coms ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRIN2 FN) (bind STARTOFLINE NEXT until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (if (NLISTP (SETQ NEXT (READ))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) else (* ; "Have an interesting com") (if (NOT STARTOFLINE) then (TERPRI) (* ; "Start expressions on new line") (SETQ STARTOFLINE T)) (PFI.HANDLE.EXPR NEXT)) finally (READCCODE) (* ; "Eat the closing paren") (PRIN1 ")") (TERPRI))) ) (PFI.PREVIEW.DEFINEQ (LAMBDA (FN) (* ; "Edited 8-Apr-88 16:38 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRINT FN) (until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (PFI.PRINT.LAMBDA (READ))) (READCCODE) (* ; "Consume the paren") (PRIN1 ")") (TERPRI)) ) ) (* ; "Printing the index") (DEFINEQ (PFI.PRINT.INDEX (LAMBDA (CRDATE) (* ; "Edited 16-May-88 15:48 by bvm") (* ;; "Compute the indices from the entries we have accumulated, print them, and return them (for multifileindex)") (LET ((LASTPAGE *PFI-PAGE-COUNT*) (*PFI-ITEM* :INDEX)) (LET ((*PFI-TITLE* NIL)) (* ; "Leave off the heading on the first index page, since it is intended to be the cover page--will have the title centered.") (DSPNEWPAGE) (COND ((AND *PFI-TWO-SIDED* (ODDP LASTPAGE)) (* ; "Ensure that the index will not be on the back-side of a two-sided listing") (DSPNEWPAGE)))) (PROGN (* ; "Print title.") (PFI.CENTER.PRINT (LIST *PFI-TITLE* CRDATE) T) (PFI.CENTER.PRINT (CONCAT "-- Listed on " (DATE) " --"))) (LET ((LINESPERPAGE (PFI.LINES.REMAINING)) (INDICES (PFI.CONDENSE.INDEX *PFI-LOCATIONS* LASTPAGE))) (PFI.PRINT.INDICES (APPEND INDICES) LINESPERPAGE) INDICES))) ) (PFI.CONDENSE.INDEX (LAMBDA (TRIPLES LASTPAGE) (* ; "Edited 12-May-88 13:07 by bvm") (* ;; "Condense TRIPLES into a set of indices, one per type. Each element is of the form (type name page), while the resulting indices are of the form (type entries . shape), with each entry looking like (name . pagenumbers). LASTPAGE is maximum page number (for gauging space).") (LET (*PFI-INDEX-ALIST* INDEX OLDNAME) (* ; "*PFI-INDEX-ALIST* is special so filters can look up entries") (for TRIP in TRIPLES do (* ; "Distribute to the correct type") (COND ((NULL (SETQ INDEX (ASSOC (CAR TRIP) *PFI-INDEX-ALIST*))) (push *PFI-INDEX-ALIST* (SETQ INDEX (LIST (CAR TRIP)))))) (COND ((SETQ OLDNAME (ASSOC (CADR TRIP) INDEX)) (* ; "Duplicate entry, so add a page number") (RPLACD OLDNAME (SORT (UNION (CDDR TRIP) (CDR OLDNAME))))) (T (push (CDR INDEX) (CDR TRIP))))) (* ;; "Now remove redundancies") (for TYPEPAIR in *PFI-INDEX-ALIST* bind FILTERS when (SETQ FILTERS (for FILTER in *PFI-FILTERS* collect (CDR FILTER) when (EQ (CAR FILTER) (CAR TYPEPAIR)))) do (* ; "Each filter is either a type name or a list whose car is a function") (RPLACD TYPEPAIR (for PAIR in (CDR TYPEPAIR) collect PAIR unless (for F in FILTERS thereis (COND ((NLISTP F) (* ; "Name exists as another type") (PFI.LOOKUP.NAME (CAR PAIR) F)) (T (CL:FUNCALL (CAR F) PAIR))))))) (PFI.SORT.INDICES (for TYPEPAIR in *PFI-INDEX-ALIST* when (CDR TYPEPAIR) collect (* ;; "Sort them and lay them out, changing format to (type entries . shape). Shape = (#rows #columns colwidth). WHEN is because filters could have removed everyone from a type.") (RPLACD TYPEPAIR (CONS (SORT (CDR TYPEPAIR) (FUNCTION (LAMBDA (X Y) (* ; "Sort case-insensitively by CAR") (ALPHORDER (CAR X) (CAR Y) UPPERCASEARRAY)))) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) LASTPAGE))))))) ) (PFI.SORT.INDICES (LAMBDA (INDICES) (* ; "Edited 12-May-88 12:37 by bvm") (* ;; "INDICES is a list of (TYPE INDEXPAIRS . SHAPE). Sort them into a preferred order of printing.") (if (NULL (CDR INDICES)) then INDICES else (LET ((RESULT (for X in INDICES bind PRIORITY when (SETQ PRIORITY (CL:POSITION (CAR X) *PFI-INDEX-ORDER*)) collect (* ; "Gather up the types that the user-specified order handles") (CONS PRIORITY X)))) (if RESULT then (* ; "Sort them by priority") (SETQ RESULT (MAPCAR (SORT RESULT (FUNCTION (LAMBDA (X Y) (< (CAR X) (CAR Y))))) (FUNCTION CDR))) (* ; "Then remove them from the master list") (SETQ INDICES (CL:SET-DIFFERENCE INDICES RESULT))) (* ;; "Finally, sort remaining indices by decreasing size to facilitate indexer's selection. Leave a marker in between so we can tell the difference between required order and optional.") (NCONC RESULT (LIST T) (SORT INDICES (FUNCTION (LAMBDA (X Y) (LET ((ROWDIF (- (CADDR X) (CADDR Y)))) (if (> ROWDIF 0) then (* ; "X has more rows than Y") T elseif (EQ ROWDIF 0) then (* ; "If same number of rows, go for more items") (> (LENGTH (CADR X)) (LENGTH (CADR Y)))))))))))) ) (PFI.COMPUTE.INDEX.SHAPE (LAMBDA (INDEXPAIRS MAXINDEXNO) (* ; "Edited 11-May-88 19:06 by bvm") (* ;; "Figures out how to lay out INDEXPAIRS, given that the largest possible page number is MAXINDEXNO. Returns a list (nrows ncolumns colwidth).") (LET ((INDEXNOWIDTH (AND MAXINDEXNO (COND ((< MAXINDEXNO 10) 1) ((< MAXINDEXNO 100) 2) (T (NCHARS MAXINDEXNO))))) (INDEXLEN (LENGTH INDEXPAIRS)) NROWS NCOLUMNS WIDTH) (SETQ WIDTH (+ (for PAIR in INDEXPAIRS largest (+ (NCHARS (CAR PAIR) T) (COND ((CDDR PAIR) (* ;; "Multiple page nos--turn into printed rep") (PROG1 (NCHARS (CAR (RPLACA (CDR PAIR) (CONCATLIST (CDR (for P in (CDR PAIR) join (LIST "," P))))))) (RPLACD (CDR PAIR) NIL))) ((STRINGP (CADR PAIR)) (* ; "It's already a string") (NCHARS (CADR PAIR))) (T INDEXNOWIDTH))) finally (RETURN $$EXTREME)) 1)) (* ; "WIDTH is the widest any entry gets: name plus page numbers. Conservative in that we assume page numbers can take up as much space as the largest") (SETQ NCOLUMNS (MAX 1 (MIN INDEXLEN (IQUOTIENT (LINELENGTH) (+ WIDTH 2))))) (* ; "Number of columns that fit if you allow 2 spaces between columns") (SETQ NROWS (CL:CEILING INDEXLEN NCOLUMNS)) (* ;; "Finally recompute NCOLUMNS. This might reduce the number of columns if all the items, printed in NROWS rows, take fewer columns than originally allocated. E.g. 11 items in 5 cols take 3 rows, but in 3 rows you only need 4 cols to print 11 items.") (LIST NROWS (CL:CEILING INDEXLEN NROWS) WIDTH))) ) (PFI.PRINT.INDICES (LAMBDA (INDICES LINESPERPAGE) (* ; "Edited 16-May-88 15:45 by bvm") (* ;; "Print a set of INDICES. LINESPERPAGE is number of lines we expect to fit per page not counting page headers.") (PROG ((HALFPAGE (IQUOTIENT LINESPERPAGE 2)) (LINELEN (LINELENGTH)) (SPACEWIDTH (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) (LINESREMAINING (- (PFI.LINES.REMAINING) 2)) ITEM FREECHOICE PREVITEM) NEWPAGE (* ;; "At this point we are at the top of a page") (TERPRI) (PFI.INDEX.BREAK) TOP (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (NULL FREECHOICE) then (* ; "Have to take the first batch in order") (SETQ ITEM (pop INDICES)) (if (EQ ITEM T) then (* ; "Marks start of optional order. Items from here on are sorted by decreasing size, but we can print them in any order we want") (SETQ FREECHOICE T) (GO TOP)) elseif (SETQ ITEM (find X in INDICES suchthat (<= (CADDR X) (- LINESREMAINING 5)))) then (* ; "Found an item that fits") (SETQ INDICES (DREMOVE ITEM INDICES)) elseif (OR (> LINESREMAINING HALFPAGE) (> (+ (CADDR (CAR (LAST INDICES))) 7) LINESPERPAGE)) then (* ; "Print something here anyway, since we're either less than halfway down the page, or the smallest index doesn't fit on a page") (SETQ ITEM (pop INDICES)) else (* ; "Start a new page and try again") (GO STARTNEWPAGE)) (DESTRUCTURING-BIND (TYPE INDEXPAIRS NROWS NCOLUMNS COLWIDTH) ITEM (PROG ((NROWSREMAINING NROWS) LASTITEM SPACING) (if (AND (EQ NROWS 1) PREVITEM (<= COLWIDTH (CADR PREVITEM)) (<= NCOLUMNS (CAR PREVITEM))) then (* ; "There's only one row, so it would be nice if it could line up with another index. Can do this if this column width is not larger than previous. PREVITEM = (ncolumns colwidth spacing ...)") (SETQ COLWIDTH (CADR PREVITEM)) (SETQ SPACING (CADDR PREVITEM)) else (LET ((NC NCOLUMNS)) (if (OR (NEQ NC 1) (if (< COLWIDTH (IQUOTIENT LINELEN 2)) then (* ; "format as if 2 columns") (SETQ NC 2) else (* ; "Too wide for 2 columns, so use whole width") (SETQ COLWIDTH LINELEN) (SETQ SPACING 0) NIL)) then (* ; "Divide the excess space up between dots and intercolumn spacing") (SETQ COLWIDTH (MIN (PROGN (* ; "Add to COLWIDTH half the excess space") (+ COLWIDTH (IQUOTIENT (- LINELEN (TIMES (+ COLWIDTH 2) NC)) 2))) (PROGN (* ; "Allow 2 spaces between columns") (- (IQUOTIENT LINELEN NC) 2)))) (SETQ SPACING (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN) (TIMES COLWIDTH NC SPACEWIDTH)) (SUB1 NC)))) (SETQ PREVITEM (LIST NC COLWIDTH SPACING)))) (if (AND (> (+ NROWS 5) LINESREMAINING) (< LINESREMAINING HALFPAGE) (<= (+ NROWS 8) LINESPERPAGE)) then (* ;; "This index doesn't fit on the page, we've filled less than half the page, and the index would fit starting on a new page. Each index takes 5 additional lines: blank, heading, blank blank breakline. If on a new page it would take 3 more (blank breakline blank).") (DSPNEWPAGE) (* ; "Start new page") (TERPRI) (* ; "Make top breaklines line up on all index pages") (PFI.INDEX.BREAK) (SETQ LINESREMAINING (- LINESPERPAGE 2))) (TERPRI) (PFI.CENTER.PRINT (CONCAT (if (AND (EQ (NTHCHARCODE TYPE -1) (CHARCODE S)) (NEQ (NTHCHARCODE TYPE -2) (CHARCODE S)) (NOT (STRPOS "IE" TYPE -3))) then (* ; "Turn plural type into singular. Second clause filters out DROSS and CANDIES.") (SUBSTRING TYPE 1 -2) else TYPE) " INDEX") T) (CHANGEFONT DEFAULTFONT) (TERPRI) (SETQ LINESREMAINING (- LINESREMAINING 3)) (while INDEXPAIRS do (SETQ NROWS (IMIN NROWSREMAINING (- LINESREMAINING 1))) (for ROW from 1 to NROWS bind NEXTINDEX do (SETQ NEXTINDEX ROW) (for COLUMN from 1 to NCOLUMNS do (COND ((SETQ LASTITEM (FNTH INDEXPAIRS NEXTINDEX)) (DESTRUCTURING-BIND (LABEL PAGENO) (CAR LASTITEM) (PRIN2 LABEL) (SPACES 1) (FRPTQ (- COLWIDTH (ADD1 (NCHARS LABEL T)) (NCHARS PAGENO)) (\OUTCHAR *STANDARD-OUTPUT* (CHARCODE %.))) (PRIN1 PAGENO) (COND ((NEQ COLUMN NCOLUMNS) (RELMOVETO SPACING 0)))))) (add NEXTINDEX NROWS)) (TERPRI)) (COND ((SETQ INDEXPAIRS (CDR LASTITEM)) (DSPNEWPAGE) (TERPRI) (SETQ LINESREMAINING (- LINESPERPAGE 1)) (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) NCOLUMNS)))) (T (SETQ LINESREMAINING (- LINESREMAINING NROWS))))) (TERPRI) (PFI.INDEX.BREAK T) (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (< (SETQ LINESREMAINING (- LINESREMAINING 2)) 6) then (* ; "No room left here, go to new page. ") (GO STARTNEWPAGE) else (* ; "T in PFI.INDEX.BREAK told it to hold the terpri") (TERPRI)))) (GO TOP) STARTNEWPAGE (DSPNEWPAGE) (SETQ LINESREMAINING (- LINESPERPAGE 2)) (* ; "Account for the break line and blank line we are about to print") (GO NEWPAGE))) ) (PFI.CENTER.PRINT (LAMBDA (STR BOLDFLG) (* ; "Edited 30-Mar-88 14:31 by bvm") (LET ((LMAR (DSPLEFTMARGIN)) GAP) (if BOLDFLG then (CHANGEFONT BOLDFONT)) (DSPXPOSITION (+ LMAR (IQUOTIENT (- (DSPRIGHTMARGIN) LMAR (if (LISTP STR) then (+ (TIMES (SUB1 (LENGTH STR)) (SETQ GAP (TIMES (DSPSCALE) 16))) (for X in STR sum (STRINGWIDTH X *STANDARD-OUTPUT*))) else (STRINGWIDTH STR *STANDARD-OUTPUT*))) 2))) (if (LISTP STR) then (for TAIL on STR do (PRIN3 (CAR TAIL)) (AND (CDR TAIL) (RELMOVETO GAP 0))) else (PRIN3 STR)) (if BOLDFLG then (CHANGEFONT DEFAULTFONT)) (TERPRI))) ) (PFI.INDEX.BREAK (LAMBDA (NOTERPRI) (* ; "Edited 11-Apr-88 16:47 by bvm") (* ;; "Draw the line separating one type index from the next. NOTERPRI suppresses the new line") (LET* ((OLDY (DSPYPOSITION)) (Y (+ (- OLDY (FONTPROP *STANDARD-OUTPUT* (QUOTE DESCENT))) (IQUOTIENT (- (DSPLINEFEED)) 2)))) (* ; "Draw a horizontal line centered on this line") (DRAWLINE (DSPLEFTMARGIN) Y (DSPRIGHTMARGIN) Y (DSPSCALE)) (DSPYPOSITION OLDY)) (OR NOTERPRI (TERPRI))) ) (PFI.LOOKUP.NAME (LAMBDA (NAME TYPE) (* ; "Edited 25-Mar-88 14:07 by bvm") (ASSOC NAME (CDR (ASSOC TYPE *PFI-INDEX-ALIST*)))) ) ) (DEFINEQ (PFI.ADD.TO.INDEX (LAMBDA (NAME TYPE/ENTRY) (* ; "Edited 6-Apr-88 16:15 by bvm") (* ;; "Add to the index an entry for NAME of type TYPE/ENTRY. TYPE/ENTRY can be an element of *pfi-types*, in which case we use its type name component.") (if (NEQ *PFI-LOCATIONS* :NONE) then (push *PFI-LOCATIONS* (LIST (if (NLISTP TYPE/ENTRY) then (* ; "the type directly") TYPE/ENTRY else (* ; "a types triple") (LET ((TYPE (fetch (PFITYPE NAME) of TYPE/ENTRY))) (OR (CAR (LISTP TYPE)) TYPE))) NAME *PFI-PAGE-COUNT*)))) ) (PFI.VARNAME (LAMBDA (EXPR) (* ; "Edited 24-Mar-88 16:09 by bvm") (* ;;; "Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR. Filters after the fact will remove duplications with other variable types") (LET ((NAME (CADR EXPR))) (* ; "Ignore compiler-internal vars") (AND (LITATOM NAME) (NEQ NAME T) (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA)))) NAME))) ) (PFI.CONSTANTNAMES (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 14:24 by bvm") (* ;;; "Called when expression is (CONSTANTS --) -- return all elements (or CAR of element when it's a pair) as type CONSTANTS") (CONS (QUOTE CONSTANTS) (for X in (CDR EXPR) collect (COND ((LISTP X) (CAR X)) (T X))))) ) ) (* ; "Combined listings") (DEFINEQ (MULTIFILEINDEX (LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 20-May-88 14:08 by bvm") (* ;; "Produce a pretty file index listing for each of FILES, plus a master index for the set") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (SETQ FILES (for F inside FILES join (if (STRPOS "*" F) then (* ; "Enumerate a pattern--default extension to null and version to highest") (DIRECTORY (DIRECTORY.FILL.PATTERN F "" "")) elseif (LISTP F) then (* ; "Hack that says don't print these") (for FL in F collect (LIST (OR (FINDFILE FL T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FL)))) else (LIST (OR (FINDFILE F T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME F)))))) (COND (*PFI-DONT-SPAWN* (MULTIFILEINDEX1 FILES PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MULTIFILEINDEX1) FILES PRINTOPTIONS)) FILES)))) ) (MULTIFILEINDEX1 (LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 19-May-88 12:35 by bvm") (* ;; "Pretty list each of the files in FILES, followed by master index") (LET ((CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) INDICES OPTIONS NOTPRINTED) (SETQ PRINTOPTIONS (LIST* (QUOTE MULTIFILEINDEX) T PRINTOPTIONS)) (* ; "Our own option") (for TAIL on FILES as I from 1 do (* ; "Print and gather indices for all but last file") (SETQ OPTIONS (if CONSECUTIVE then (* ; "Tell it which page to start on") (LIST* :FIRSTPAGE (if INDICES then (* ; "One past the end of the last one") (ADD1 (CADDR (CAAR INDICES))) else 1) PRINTOPTIONS) else (* ; "Tell it which part to work on") (LIST* :PART I PRINTOPTIONS))) (push INDICES (if (SETQ NOTPRINTED (LISTP (CAR TAIL))) then (* ; "Go thru the motions but don't print it") (PRETTYFILEINDEX (CAAR TAIL) (LIST* :DONTPRINT T OPTIONS)) else (if (NULL (CDR TAIL)) then (* ; "When printing last file, send along all the indices for a combined listing") (RPLACA (CDR PRINTOPTIONS) (REVERSE INDICES))) (PRETTYFILEINDEX (CAR TAIL) OPTIONS)))) (IF NOTPRINTED THEN (* ; "The last file wasn't printed, so have to make index on our own") (LET* ((*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS (QUOTE %#SIDES)) EMPRESS#SIDES) 2)) (*STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM (LIST* (QUOTE DOCUMENT.NAME) (QUOTE INDEX) PRINTOPTIONS)))) (CL:UNWIND-PROTECT (PFI.PRINT.MULTI.INDEX (REVERSE INDICES) PRINTOPTIONS) (CLOSEF *STANDARD-OUTPUT*)))))) ) (PFI.PRINT.MULTI.INDEX (LAMBDA (INDEXENTRIES PRINTOPTIONS) (* ; "Edited 19-May-88 17:37 by bvm") (* ;; "Print the master index for a set of indexed files. INDEXENTRIES has one element per file, each of the form ((filename creationdate lastpage# env) . indices), the indices having come out of PFI.PRINT.INDEX") (LET ((MAXNAME 0) (MAXDATE 0) (CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) (ENV (LISTGET PRINTOPTIONS :ENVIRONMENT)) BESTPACKAGE BESTREADTABLE MAXPAGE# MASTERINDICES LINESPERPAGE NAMES&DATES) (STREAMPROP *STANDARD-OUTPUT* (QUOTE AFTERNEWPAGEFN) NIL) (* ; "No more header hacking") (IF (NEQ (LISTGET PRINTOPTIONS (QUOTE MULTIFILEINDEX)) T) THEN (* ; "If it was T, then we must be called from MULTFILEINDEX1 to print only the index, so are on the first page right now.") (DSPNEWPAGE) (* ; "Start a new page") (if (AND *PFI-TWO-SIDED* (ODDP *PFI-PAGE-COUNT*)) then (* ; "Ensure that the master index will not be on the back-side of a two-sided listing") (DSPNEWPAGE))) (SETQ LINESPERPAGE (PFI.LINES.REMAINING)) (PFI.CENTER.PRINT (CONCAT "Master index generated on " (DATE (DATEFORMAT NO.SECONDS)))) (TERPRI) (CHANGEFONT BOLDFONT) (for PAIR in INDEXENTRIES as I from 1 bind PREFIX MASTERENTRY FILEINFO E TEM do (push NAMES&DATES (SETQ FILEINFO (CAR PAIR))) (* ; "FILEINFO = (name date last# env)") (SETQ MAXNAME (MAX MAXNAME (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXDATE (MAX MAXDATE (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXPAGE# (POP FILEINFO)) (if (NOT ENV) then (SETQ E (CAR FILEINFO)) (if (SETQ TEM (ASSOC (fetch REPACKAGE of E) BESTPACKAGE)) then (add (CDR TEM) 1) else (push BESTPACKAGE (CONS (fetch REPACKAGE of E) 1))) (if (SETQ TEM (ASSOC (fetch REREADTABLE of E) BESTREADTABLE)) then (add (CDR TEM) 1) else (push BESTREADTABLE (CONS (fetch REREADTABLE of E) 1)))) (if (NOT CONSECUTIVE) then (* ; "This gets in front of all page#s") (SETQ PREFIX (CONCAT I "-"))) (for INDEX in (CDR PAIR) unless (EQ INDEX T) do (* ; "INDEX = (type pairs . shape). T is a separator that we no longer care about.") (if (NOT CONSECUTIVE) then (* ; "Prefix page numbers with file number") (for INDEXITEM in (CADR INDEX) do (RPLACA (CDR INDEXITEM) (CONCAT PREFIX (CADR INDEXITEM))))) (if (NULL (SETQ MASTERENTRY (ASSOC (CAR INDEX) MASTERINDICES))) then (* ; "Haven't seen any yet, just store it") (push MASTERINDICES (CONS (CAR INDEX) (CADR INDEX))) else (* ; "Merge with what's there") (RPLACD MASTERENTRY (PFI.MERGE.INDICES (CDR MASTERENTRY) (CADR INDEX)))))) (LET* ((LEFT (DSPLEFTMARGIN)) (FATSPACE (TIMES (DSPSCALE) 8)) (RANGEWIDTH (if CONSECUTIVE then (+ (STRINGWIDTH "[-]" *STANDARD-OUTPUT*) (TIMES (+ FATSPACE (STRINGWIDTH MAXPAGE# *STANDARD-OUTPUT*)) 2)) else (* ; "No page ranges to print") FATSPACE)) (DIGITSWIDTH (STRINGWIDTH "99." *STANDARD-OUTPUT*)) (MAXWIDTH (+ DIGITSWIDTH RANGEWIDTH MAXNAME FATSPACE FATSPACE MAXDATE)) (LINEWIDTH (- (DSPRIGHTMARGIN) LEFT)) (LASTPAGE 0) TAB1 TAB2 TAB3 TEM) (if (< MAXWIDTH LINEWIDTH) then (SETQ TAB1 (+ LEFT DIGITSWIDTH (IQUOTIENT (- LINEWIDTH MAXWIDTH) 2))) (* ; "Digit flush against here") (SETQ TAB2 (+ TAB1 RANGEWIDTH)) (* ; "Name starts here") (SETQ TAB3 (+ TAB2 MAXNAME FATSPACE FATSPACE MAXDATE)) (* ; "Date flush right here")) (for N&D in (REVERSE NAMES&DATES) as I from 1 do (CHANGEFONT BOLDFONT) (SETQ TEM (CONCAT I ".")) (if TAB1 then (DSPXPOSITION (- TAB1 (STRINGWIDTH TEM *STANDARD-OUTPUT*)))) (PRIN3 TEM) (if CONSECUTIVE then (SETQ TEM (CONCAT "[" (LOGOR (+ LASTPAGE 1) (if *PFI-TWO-SIDED* then 1 else 0)) "-" (SETQ LASTPAGE (CADDR N&D)) "]")) (if TAB2 then (DSPXPOSITION (+ TAB1 (IQUOTIENT (- RANGEWIDTH (STRINGWIDTH TEM *STANDARD-OUTPUT*)) 2)))) (PRIN3 TEM)) (if TAB2 then (DSPXPOSITION TAB2) else (RELMOVETO FATSPACE 0)) (PRIN3 (CAR N&D)) (if TAB3 then (DSPXPOSITION (- TAB3 (STRINGWIDTH (CADR N&D) *STANDARD-OUTPUT*))) else (RELMOVETO FATSPACE 0)) (PRIN3 (CADR N&D)) (CHANGEFONT DEFAULTFONT) (TERPRI))) (for TYPEPAIR in MASTERINDICES do (* ;; "Now that each index is complete, turn (type . indices) into (type indices . shape)") (RPLACD TYPEPAIR (CONS (CDR TYPEPAIR) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) MAXPAGE#)))) (if (NOT ENV) then (SETQ BESTPACKAGE (PFI.CHOOSE.BEST BESTPACKAGE)) (SETQ BESTREADTABLE (PFI.CHOOSE.BEST BESTREADTABLE)) elseif (TYPENAMEP ENV (QUOTE READER-ENVIRONMENT)) then (SETQ BESTPACKAGE (fetch REPACKAGE of ENV)) (SETQ BESTREADTABLE (fetch REREADTABLE of ENV)) else (SETQ BESTPACKAGE (LISTGET ENV :PACKAGE)) (if (LISTP BESTPACKAGE) then (SETQ BESTPACKAGE (EVAL BESTPACKAGE))) (if (NOT (OR (CL:PACKAGEP BESTPACKAGE) (SETQ BESTPACKAGE (CL:FIND-PACKAGE BESTPACKAGE)))) then (SETQ BESTPACKAGE (CL:ERROR "No valid package in environment ~S" ENV))) (SETQ BESTREADTABLE (LISTGET ENV :READTABLE)) (if (LISTP BESTREADTABLE) then (SETQ BESTREADTABLE (EVAL BESTREADTABLE))) (if (NOT (OR (READTABLEP BESTREADTABLE) (SETQ BESTREADTABLE (FIND-READTABLE BESTREADTABLE)))) then (SETQ BESTREADTABLE (CL:ERROR "No valid read table in environment ~S" ENV)))) (LET ((*PACKAGE* BESTPACKAGE) (*READTABLE* BESTREADTABLE)) (PFI.PRINT.INDICES (PFI.SORT.INDICES MASTERINDICES) LINESPERPAGE)))) ) (PFI.CHOOSE.BEST (LAMBDA (LST) (* ; "Edited 19-May-88 12:30 by bvm") (* ;; "Return the car of the element in ALIST having the largest vote, or first such if a tie.") (CAAR (CL:STABLE-SORT LST (QUOTE >) :KEY (QUOTE CDR)))) ) (PFI.MERGE.INDICES (LAMBDA (MASTER NEWINDEX) (* ; "Edited 12-May-88 14:25 by bvm") (* ;; "Merge two lists of index entries. Each is a list (name location). In case of collision, it is known that MASTER locations appear before NEWINDEX locations") (NCONC (while (AND NEWINDEX MASTER) collect (SELECTQ (ALPHORDER (CAAR MASTER) (CAAR NEWINDEX) UPPERCASEARRAY) (EQUAL (* ; "Same name in two places, so merge the locations") (RPLACA (CDAR MASTER) (CONCAT (CADAR MASTER) "," (CADR (pop NEWINDEX)))) (pop MASTER)) (LESSP (* ; "Master less, so take it first") (pop MASTER)) (PROGN (* ; "NEWINDEX less, so take it") (pop NEWINDEX)))) (PROGN (* ; "Plus whichever, if either, is left over") (OR NEWINDEX MASTER)))) ) ) (* ; "Hooks for seeing files pretty elsewhere") (DEFINEQ (PFI.MAYBE.SEE.PRETTY (LAMBDA (FROMFILE TOFILE) (* ; "Edited 1-Apr-88 11:23 by bvm") (* ;; "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) OUTSTREAM INSTREAM) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NULL (SETQ OUTSTREAM (DISPLAYP TOFILE)))) then (* ; "Not a display window, or don't want prettyprinting") (if (STREAMP FROMFILE) then (* ; "Wanted PFCOPYBYTES") (PFCOPYBYTES FROMFILE TOFILE) else (COPYALLBYTES FROMFILE TOFILE)) else (if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ INSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) else (PFCOPYBYTES INSTREAM OUTSTREAM) (FULLNAME INSTREAM)))))) ) (PFI.MAYBE.PP.DEFINITION (LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 1-Apr-88 11:22 by bvm") (LET (ENV) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NOT (DISPLAYP OUTSTREAM)) (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) (WITH-READER-ENVIRONMENT ENV (SETFILEPTR INSTREAM START) (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) (IGNORE-ERRORS (READ INSTREAM)) (LET ((*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT)))) (if CONDITION then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) T else (PFI.PRINT.LAMBDA.BODY DEF) (TERPRI) NIL))))) then (* ;; "Punt to what we were called for in the first place") (PFCOPYBYTES INSTREAM OUTSTREAM START END)))) ) ) (RPAQ? *PRINT-PRETTY-FROM-FILES* T) (* ; "Bitmap hack") (DEFINEQ (PFI.PRINT.BITMAP (LAMBDA (BM STREAM) (* ; "Edited 14-Apr-88 12:44 by bvm") (* ;; "DEFPRINT function for bitmaps that displays the actual bitmap when going to an image stream.") (if (OR (NULL *PRINT-ARRAY*) (NULL *PRINT-PRETTY-BITMAPS*)) then (* ; "do the clunky way") (NON.PFI.PRINT.BITMAP BM STREAM) elseif (IMAGESTREAMP STREAM) then (PROG ((CURX (DSPXPOSITION NIL STREAM)) (CURY (DSPYPOSITION NIL STREAM)) (UNITS (DSPSCALE NIL STREAM)) (LINEHEIGHT (DSPLINEFEED NIL STREAM)) HEIGHT WIDTH MINX NLINESDOWN BOTTOM BMARG BELOWBASELINE SCALE RATIO) (if (NOT (AND CURX CURY UNITS LINEHEIGHT)) then (* ; "Stream doesn't really support it") (RETURN (NON.PFI.PRINT.BITMAP BM STREAM))) (SETQ HEIGHT (TIMES UNITS (BITMAPHEIGHT BM))) (SETQ WIDTH (TIMES UNITS (BITMAPWIDTH BM))) (SETQ BMARG (DSPBOTTOMMARGIN NIL STREAM)) (if (AND (NOT (DISPLAYSTREAMP STREAM)) (< (SETQ RATIO (MIN (FQUOTIENT (- (DSPRIGHTMARGIN NIL STREAM) (DSPLEFTMARGIN NIL STREAM)) (TIMES WIDTH 1.5)) (FQUOTIENT (- (DSPTOPMARGIN NIL STREAM) BMARG) (TIMES HEIGHT 1.5)))) 1.0)) then (* ; "It takes up more than 2/3 the page in some dimension. This code is tuned for Interpress.") (SETQ SCALE (if (> RATIO 0.75) then 0.75 elseif (> RATIO 0.5) then 0.5 elseif (> RATIO 0.25) then 0.25 else RATIO)) (SETQ HEIGHT (FIXR (TIMES SCALE HEIGHT))) (SETQ WIDTH (FIXR (TIMES SCALE WIDTH)))) (if (> CURX (SETQ MINX (- (DSPRIGHTMARGIN NIL STREAM) WIDTH))) then (* ; "Won't fit between here and margin, so start nwe line") (TERPRI STREAM) (SETQ CURX (MAX MINX 0)) (SETQ CURY (DSPYPOSITION NIL STREAM))) (SETQ BELOWBASELINE (MAX 0 (- HEIGHT (FONTPROP STREAM (QUOTE ASCENT))))) (if BMARG then (* ; "We know stream's bottom margin, so can be reasonable") (if (< (- CURY BELOWBASELINE) BMARG) then (* ; "Won't fit on page") (DSPNEWPAGE STREAM) (SETQ CURY (DSPYPOSITION NIL STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL)) else (* ; "Have to use silly terpri method") (SETQ NLINESDOWN (IQUOTIENT HEIGHT (SETQ LINEHEIGHT (- LINEHEIGHT)))) (to NLINESDOWN do (* ; "Do enough cr's so that we have space for bitmap. This might cause scrolling, for example") (TERPRI STREAM) finally (* ; "If this was display, terpri may have scrolled, and Y changed out from under us") (SETQ CURY (+ (DSPYPOSITION NIL STREAM) (TIMES NLINESDOWN LINEHEIGHT))))) (SETQ BOTTOM (- CURY BELOWBASELINE)) (* ; "BOTTOM computed so that bitmap top lines up with font top") (SCALEDBITBLT BM 0 0 STREAM CURX BOTTOM WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL NIL SCALE) (MOVETO (+ CURX WIDTH) (if (AND (< BOTTOM CURY) (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) *PFI-FUNNY-CHARS*) then (* ; "Don't move the baseline down, just remember it for when we hit end of line") (if (OR (NULL *PFI-BITMAP-BASELINE*) (< BOTTOM *PFI-BITMAP-BASELINE*)) then (* ; "Lower than before, or first time") (SETQ *PFI-BITMAP-BASELINE* BOTTOM) (if (NEQ (fetch (STREAM OUTCHARFN) of STREAM) (FUNCTION PFI.OUTCHARFN)) then (* ; "Also have to %"advise%" the outcharfn to notice terpri") (replace (STREAM OUTCHARFN) of STREAM with (FUNCTION PFI.OUTCHARFN)))) CURY else (* ; "Move baseline down to bitmap baseline") BOTTOM) STREAM) (RETURN T)) else (LET ((POS (AND (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) (PNAMESTREAMP STREAM) (STKPOS (QUOTE STRINGWIDTH)))) IMSTREAM) (if (AND POS (IMAGESTREAMP (SETQ IMSTREAM (STKEVAL POS (QUOTE *STANDARD-OUTPUT*) T)))) then (* ;; "Big kludge: This is somebody in the prettyprinter trying to figure out the width of the bitmap--fake them out by printing something about the width of the bitmap. IMSTREAM is the stream to which the real output will go. To be conservative, only do this under PRETTYFILEINDEX.") (RPTQ (CL:CEILING (TIMES (DSPSCALE NIL IMSTREAM) (BITMAPWIDTH BM)) (CHARWIDTH (CHARCODE X) IMSTREAM)) (\OUTCHAR STREAM (CHARCODE X))) T else (NON.PFI.PRINT.BITMAP BM STREAM))))) ) ) (RPAQ? *PRINT-PRETTY-BITMAPS* T) (RPAQ? *PFI-PRINTOPTIONS* '(REGION (72 54 504 702))) (RPAQ? *PFI-DONT-SPAWN* ) (RPAQ? *PFI-MAX-WASTED-LINES* 12) (RPAQ? *PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC)))) (RPAQ? *PFI-INDEX-ORDER* '(FUNCTIONS)) (RPAQ? *PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*)) ) (* ;;  "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN)))) (RPAQ? \PFI.PROCESS.COMMANDS ) (RPAQ? \PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (RPAQ? \PFI.PROCESS ) (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex" ) (RPAQ? *PFI-TITLE* ) (RPAQ? *PFI-PAGE-COUNT* 0) (ADDTOVAR *PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (ADDTOVAR *PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (ADDTOVAR *PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (ADDTOVAR *PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (ADDTOVAR *PFI-FILTERS* (VARIABLES . CONSTANTS)) (* ; "Prettyprint augmentation to mimic system makefile dumping") (DEFINEQ (PUTPROPS.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 30-Mar-88 11:35 by bvm") (* ;; "does prettyprinting for PUTPROPS forms. Main thing we do is embolden the variable.") (if (NLISTP (CDR EXPR)) then (* ; "Degenerate (PUTPROPS) or (PUTPROPS . FOO)") (PRIN2 EXPR) else (PRIN1 (QUOTE %()) (PRIN2 (pop EXPR)) (* ; "Print the PUTPROPS") (SPACES 1) (LET ((TEM (DSPXPOSITION)) PROP) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Print the symbol") (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate illegal form like (PUTPROPS var . foo)") (SPACES 1) (PRINTDEF EXPR T NIL T) elseif (CDDR EXPR) then (* ; "There are multiple prop value pairs") (while EXPR do (* ;; "EXPR looks like (PROP VALUE . tail)") (TERPRI) (* ; "Start next prop on new line") (DSPXPOSITION TEM) (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate tail") (RETURN (PRINTDEF EXPR T NIL T))) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (SPACES 1) (PRINTDEF (pop EXPR) T (MEMB PROP MACROPROPS) NIL FNSLST)) else (* ; "Normal type: (PUTPROPS var prop value)") (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (COND ((AND (LISTP (CAR EXPR)) (NOT (FITP EXPR T NIL NIL *STANDARD-OUTPUT*))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF EXPR T (MEMB PROP MACROPROPS) T FNSLST)) (PRIN1 (QUOTE %))))) NIL) ) (RPAQX.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 8-Apr-88 16:34 by bvm") (* ;; "does prettyprinting for RPAQxx forms and ADDTOVAR. Main thing we do is embolden the variable.") (if (NOT (LISTP (CDR EXPR))) then (* ; "Handle (RPAQ) and (RPAQ . FOO)") EXPR else (DESTRUCTURING-BIND (OP VAR . TAIL) EXPR (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (LET ((TEM (DSPXPOSITION))) (MAYBE.PRETTYPRINT.BOLD VAR) (* ; "Embolden the variable") (COND ((AND (LISTP (CAR TAIL)) (OR (> (COUNT TAIL) 30) (NOT (FITP TAIL T NIL NIL *STANDARD-OUTPUT*)))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF TAIL T NIL T) (PRIN1 (QUOTE %))))) NIL)) ) (COURIERPROGRAM.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 13-Apr-88 10:55 by bvm") (if (NOT (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR))))))) then (* ; "Degenerate") EXPR else (LET* ((TAB1 (+ (DSPXPOSITION) (TIMES 4 SPACEWIDTH))) (TAB2 (+ TAB1 (TIMES 2 SPACEWIDTH)))) (PROGN (* ;; "Print %"(COURIERPROGRAM name (version)%"") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (SPACES 1) (PRIN2 (pop EXPR))) (* ; "Version pair") (while (LISTP EXPR) do (PRINENDLINE TAB1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Property name") (PRINENDLINE TAB2) (AND (LISTP EXPR) (PRINTDEF (pop EXPR) T))) (if EXPR then (* ; "degenerate tail?") (PRINTDEF EXPR T T T)) (PRIN1 ")") NIL))) ) (MAYBE.PRETTYPRINT.BOLD (LAMBDA (VAR) (* ; "Edited 28-Mar-88 11:59 by bvm") (* ;; "Print VAR, in makefile's bold font if enabled") (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT) (PRIN2 VAR) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 VAR)))) ) ) (ADDTOVAR PRETTYPRINTMACROS (RPAQ . RPAQX.PRETTYPRINT) (RPAQQ . RPAQX.PRETTYPRINT) (RPAQ? . RPAQX.PRETTYPRINT) (ADDTOVAR . RPAQX.PRETTYPRINT) (PUTPROPS . PUTPROPS.PRETTYPRINT) (COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (CL:PROCLAIM '(CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG)) (DECLARE%: EVAL@COMPILE (RECORD PFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*) ) ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (OR (GETD 'CODEWRAPPER.PRETTYPRINT) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ;  "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ;  "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE")) (* ; "Also fix SEE") (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ;  "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION) (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP) 'NILL) 'NON.PFI.PRINT.BITMAP NIL T) ) (PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10120 12355 (PFI.NEW.LISTFILES1 10130 . 10624) (PFI.ENQUEUE 10626 . 11250) ( \PFI.DO.HARDCOPY 11252 . 11838) (MAYBE.PRETTYFILEINDEX 11840 . 12353)) (12356 35139 (PRETTYFILEINDEX 12366 . 26413) (PFI.MAKE.LPT.STREAM 26415 . 29720) (PFI.SETUP.TRANSLATIONS 29722 . 31236) ( PFI.OUTCHARFN 31238 . 33212) (PFI.COLLECT.DEFINERS 33214 . 34026) (PFI.AFTER.NEW.PAGE 34028 . 35137)) (35140 37996 (PFI.PRINT.FILECREATED 35150 . 36882) (PFI.PRINT.TO.TAB 36884 . 37249) ( PFI.PRINT.ENVIRONMENT 37251 . 37994)) (37997 44648 (PFI.PROCESS.FILE 38007 . 39237) (PFI.PASS.COMMENT 39239 . 39676) (PFI.HANDLE.EXPR 39678 . 40345) (PFI.DEFAULT.HANDLER 40347 . 42400) (PFI.PRETTYPRINT 42402 . 42737) (PFI.LINES.REMAINING 42739 . 43066) (PFI.MAYBE.NEW.PAGE 43068 . 43571) ( PFI.ESTIMATE.SIZE 43573 . 44104) (PFI.ESTIMATE.SIZE1 44106 . 44646)) (44685 54172 (PFI.HANDLE.RPAQQ 44695 . 46103) (PFI.HANDLE.DECLARE 46105 . 47044) (PFI.HANDLE.EVAL-WHEN 47046 . 47529) ( PFI.HANDLE.DEFDEFINER 47531 . 48821) (PFI.HANDLE.DEFINEQ 48823 . 49067) (PFI.PRINT.LAMBDA 49069 . 49407) (PFI.PRINT.LAMBDA.BODY 49409 . 49744) (PFI.HANDLE.PUTDEF 49746 . 50243) (PFI.HANDLE.PUTPROPS 50245 . 50860) (PFI.HANDLE./DECLAREDATATYPE 50862 . 51409) (PFI.HANDLE.* 51411 . 52673) ( PFI.PRINT.COMMENTS 52675 . 53575) (PFI.HANDLE.FILEMAP 53577 . 53865) (PFI.HANDLE.PACKAGE 53867 . 54170 )) (54200 55192 (PFI.PREVIEW.DECLARE 54210 . 54872) (PFI.PREVIEW.DEFINEQ 54874 . 55190)) (55228 66216 (PFI.PRINT.INDEX 55238 . 56089) (PFI.CONDENSE.INDEX 56091 . 57898) (PFI.SORT.INDICES 57900 . 59039) ( PFI.COMPUTE.INDEX.SHAPE 59041 . 60505) (PFI.PRINT.INDICES 60507 . 65049) (PFI.CENTER.PRINT 65051 . 65621) (PFI.INDEX.BREAK 65623 . 66081) (PFI.LOOKUP.NAME 66083 . 66214)) (66217 67448 (PFI.ADD.TO.INDEX 66227 . 66737) (PFI.VARNAME 66739 . 67149) (PFI.CONSTANTNAMES 67151 . 67446)) (67483 75796 ( MULTIFILEINDEX 67493 . 68289) (MULTIFILEINDEX1 68291 . 69747) (PFI.PRINT.MULTI.INDEX 69749 . 74852) ( PFI.CHOOSE.BEST 74854 . 75081) (PFI.MERGE.INDICES 75083 . 75794)) (75853 77471 (PFI.MAYBE.SEE.PRETTY 75863 . 76793) (PFI.MAYBE.PP.DEFINITION 76795 . 77469)) (77541 81376 (PFI.PRINT.BITMAP 77551 . 81374)) (84221 87335 (PUTPROPS.PRETTYPRINT 84231 . 85642) (RPAQX.PRETTYPRINT 85644 . 86369) ( COURIERPROGRAM.PRETTYPRINT 86371 . 87071) (MAYBE.PRETTYPRINT.BOLD 87073 . 87333))))) STOP \ No newline at end of file diff --git a/lispusers/PRETTYFILEINDEX.TEDIT b/lispusers/PRETTYFILEINDEX.TEDIT new file mode 100644 index 00000000..b0609345 --- /dev/null +++ b/lispusers/PRETTYFILEINDEX.TEDIT @@ -0,0 +1,22 @@ +enˇvĹos PRETTYFILEINDEX 2 4 1 PRETTYFILEINDEX 1 4 By: Bill van Melle (vanMelle.PA@Xerox.com) INTRODUCTION PRETTYFILEINDEX is a program for generating indexed listings for Lisp source files. PRETTYFILEINDEX operates by reading expressions from the file and reprettyprinting them to the output image stream, building up an index of the objects as it goes. The index is partitioned by type (e.g. FUNCTIONS, VARIABLES, MACROS, etc.); within each type, the objects are listed alphabetically by name along with the page number(s) on which their definitions appear in the listing. PRETTYFILEINDEX also modifies the Exec's and the FileBrowser's SEE command to prettyprint the file being viewed, if it is a Lisp source file. It also modifies the PF and PF* commands to prettyprint the requested function body. Together, these features mean you can use the NEW & FAST options to MAKEFILE to speed up file creation without sacrificing the ability to get pretty listings or see the files prettily inside Lisp. PRETTYFILEINDEX performs some additional niceties in the listing: it prints bitmaps by "displaying" them, rather than dumping their bits; it translates underscore to left arrow (for the benefit of Interlisp listings); it prints quote and backquote in a font in which they are clearly distinguishable; and it suppresses some of the "noise" in source files, such as the filemap. The module also contains a function MULTIFILEINDEX that can be used to generate a merged index of items from a whole set of files being listed. PRETTYFILEINDEX subsumes, and is incompatible with, the modules SINGLEFILEINDEX and PP-CODE-FILE. You can, however, load PRETTYFILEINDEX on top of either one, and it will successfully wrest control of LISTFILES from them. PRETTYFILEINDEX has several advantages over SINGLEFILEINDEX: the prettyprinter has fine control over positioning of the output stream, so things that are supposed to line up do, despite font changes and variable-width fonts; the entire page is used, rather than sacrificing the bottom quarter or so due to lack of control over page breaks; and the use of an image stream allows bitmaps to be rendered directly. USING PRETTYFILEINDEX For ordinary use, just load PRETTYFILEINDEX.LCOM. This redefines LISTFILES1 so that calling LISTFILES or using the File Browser's Hardcopy command invokes PRETTYFILEINDEX if the file is a Lisp source file. The listing is created by default in a single background process that handles all LISTFILES requests. The file being indexed needn't be loaded, or even noticed (in the File Manager sense) as long as the file's commands don't require customized prettyprinting defined by the file itself. The index is printed at the end of the listing; you are expected to manually transpose the index to the front of the collection of paper that emerges from the printer. PRETTYFILEINDEX normally assumes that you are printing one-sided listings. However, if your global default is for two-sided (currently this means that EMPRESS#SIDES = 2) or you specified two-sided in the options you passed to LISTFILES, it will prepare the output as if for two-sided listing. For example, from an Interlisp exec, (LISTFILES (SERVER "Perfector:" %#SIDES 2) FOOBAR) causes the file FOOBAR to be listed two-sided on the print server Perfector: (the % is the Interlisp reader's escape character, needed to quote the special character #; in an XCL exec the escape character is \, and from other packages you also have to qualify the symbols LISTFILES, SERVER and #SIDES with the package prefix IL:). For two-sided listings, the margins are symmetric, instead of being shifted a bit to the right, page numbers appear on the outside edge of the page, and a blank page is inserted at the end of the listing if necessary to ensure that the index starts on an odd page (and hence is transposable to the front). PRETTYFILEINDEX prettyprints the file's contents and prints indexed names using the package and read table specified in the file's reader environment, which appears at the beginning of the file. It assumes, as does most of the file manager, that the reader environment is sufficient to read any expression on the file. If you have violated this assumption, for example, by referring in the file to a symbol in another package that is defined on a file that is indirectly loaded by the file somewhere in its coms, you will probably need to LOADFROM the file before you can list it. INDEXING MULTIPLE FILES Ordinarily, you list files and get one index per file. If a module is made up of several files, you may want a master index of the whole set of files, so that you don't have to remember which file contains a function, macro, etc. that you are looking up. This job is handled by MULTIFILEINDEX: (MULTIFILEINDEX files printoptions) [Function] This function lists each of the files in the list files using PRETTYFILEINDEX and then produces a master index by merging all the individual indices. The master index is appended to the output of the last file listed. The argument files can be a list of file names and/or file patterns, such as "{FS:}RED*", or a single such pattern. In the pattern, unless explicitly specified, the extension defaults to null and the version to "highest". The argument printoptions is a property-list of options, the same as the printoptions argument to SEND.FILE.TO.PRINTER or PRETTYFILEINDEX, with the addition of some options recognized by MULTIFILEINDEX, described further below. As each file is listed, its pages are numbered with an ordinal file number plus the page number within the file; e.g., in the first file the pages are numbered 1-1, 1-2, ..., in the second file 2-1, 2-2, etc. The master index then refers to page numbers in this form, although each individual file's own index shows only the file-relative page numbers. Alternatively, you can tell MULTIFILEINDEX to number all the pages consecutively, rather than using "part numbers", by giving the option :CONSECUTIVE, value T in printoptions. In the event that some files in the set have different reader environments, the master index is printed in the environment used by the majority of the files. More specifically, MULTIFILEINDEX independently chooses the package used by the majority of the files and the readtable used by the majority; in the case of a tie, the file later in the set wins. If this default is not adequate, you can specify the environment yourself by giving the :ENVIRONMENT option. The value should either be a reader environment object, such as produced by MAKE-READER-ENVIRONMENT, or a property list of the form used by the MAKEFILE-ENVIRONMENT property. For example, (MULTIFILEINDEX "Rub*" '(:CONSECUTIVE T :ENVIRONMENT (:PACKAGE "JABBA" :READTABLE "XCL"))) would list each of the files matching "Rub*.;", numbering the pages consecutively from the first file through the last, and printing the master index with respect to the package JABBA and read table XCL. INCREMENTALLY REPRINTING MULTIPLE FILES If you have used MULTIFILEINDEX to list a group of files, and later one of the files changes, or maybe the printer just ate part of your listing, you might want to update your listing without reprinting the entire set of files. You have two options. (1) You can have PRETTYFILEINDEX reprint the one file that changed (or was eaten). Specify the print option :PART n to have it treat the single file as the nth part of a multiple listing, or the option :FIRSTPAGE n to have it start numbering the pages at n instead of 1 (for the case where you used the :CONSECUTIVE option to MULTFILEINDEX). For example, (LISTFILES (:PART 3) "Rubric") would reprint Rubric as the third file in a group. Of course, this doesn't reprint the master index, but it only has to process the one file, which may be adequate for your needs if things didn't move around too much. (2) You can have MULTIFILEINDEX process the entire set of files again, but only print some of them. You specify this by parenthesizing the files you don't want printed. That is, each element of the files argument to MULTIFILEINDEX is a file name or a list of file name(s); those files inside sublists are processed but not printed. You cannot specify patterns. The master index is listed after the last file, as usual, except that if the last file was in a sublist, and hence not printed, the master index will appear as a separate listing. Calling MULTIFILEINDEX in this manner is nearly as computationally expensive as calling it to list the whole set for real (it omits only the transportation to the printer), but it does save paper and printer time. LISTING COMMON LISP FILES Ordinarily, PRETTYFILEINDEX only processes files produced by the Lisp File Manager; it passes all others off to the default hardcopy routines. However, you can tell it to process a plain Common Lisp text file by passing the print option :COMMON; e.g., (LISTFILES (:COMMON T) "conjugate.lisp") PRETTYFILEINDEX still processes the file by reading and prettyprinting, just as for Lisp files. It starts in the default Common Lisp reading environment (package USER and read table LISP), and evaluates top-level package expressions, such as in-package and import, in order to continue reading correctly. The index is printed in whatever the environment was at the end of the file. Of course, this is of fairly limited utility, as all read-time conditional syntax is lost: comments, #+, #o, etc. The one exception is that top-level semi-colon comments are preserved˙˙ď%˙they are copied to the output directly, rather than being read. Customizing PRETTYFILEINDEX The remainder of this document describes various ways in which PRETTYFILEINDEX can be customized. HOW TO SPECIFY INDEXING TYPES Initially, PRETTYFILEINDEX knows about most of the standard file manager types. In addition, it handles all the types defined by DEFDEFINER. For definers with a :NAME option, it assumes that the function is free of side effects. PRETTYFILEINDEX also notices (but does not evaluate) DEFDEFINERs that appear on the file it is currently indexing, which should appear before any instances of the type so defined in order for correct indexing to occur. Of course, it can't know about definer types that are defined on some other file unless you load it. You can augment the set of indexing types, or override the default handling of definers, by adding elements to the following variable: *PFI-TYPES* [Variable] A list of entries describing types to be indexed and a way of testing whether an expression on the file is of the desired type. Each entry is a list of up to 4 elements of the form (type dumpfn namefn ambiguous), the first two of which are required: type The name of the type, e.g., MACRO. This name will appear as the name of the index for this type, e.g., "MACRO INDEX". type is usually the name of a file package type, though it need not be. It must be a symbol. dumpfn The name of the function that appears as the CAR of the form that defines objects of type type on the file, or a list of such names. E.g., for type TEMPLATE it is SETTEMPLATE; for type VARIABLES it is (RPAQ RPAQQ RPAQ? ADDTOVAR). namefn A function that tests whether the expression that starts with dumpfn really is of the desired type, and returns the name of the object defined in the expression. The function takes as arguments (expr entry), where expr is the expression whose CAR matched the entry. The testfn should return one of the following: NIL the expression is not of the desired type. name the expression defines a single object of this name and of the type given in the entry. a list the value is either a single list or a list of lists, each of the form (type . names), meaning that the expression defines each of the names as having the specified type. If the namefn is NIL or omitted, the name of the object is obtained from the second element of the expression. If that element is a list, the name is taken to be its CAR, or its CADR if the element is a quoted atom. ambiguous True if the expression is ambiguous, in the sense that even if namefn returns a non-NIL value, it is possible for this expression to also satisfy other entries in *PFI-TYPES*. E.g., the expression (RPAQ --) is ambiguous, because it could define either a variable or a constant. If ambiguous is true, you usually want a corresponding entry on *PFI-FILTERS* (below). *PFI-PROPERTIES* [Variable] A list used by the default handler for the PUTPROPS form. It associates property names with a type (something more specific than the type PROPERTY) under which objects having this property should be indexed. Each element is of the form (propname type). If type is NIL or omitted, then objects having this property are ignored. In addition, the default PUTPROPS handler treats all elements of the list MACROPROPS as implying type MACRO. The initial value of *PFI-PROPERTIES* is ((COPYRIGHT) (READVICE ADVICE)), meaning that the COPYRIGHT property should be ignored, and the READVICE property implies that the object should be indexed as type ADVICE. *PFI-FILTERS* [Variable] A list describing potential index entries that should be filtered out of the final index. Each element of *PFI-FILTERS* is a list (type filterfn), where type is one of the types in *PFI-TYPES* and filterfn is a function of one argument, an index entry. If filterfn returns true, then the index entry is discarded. An index entry is of the form (name . pagenumbers). For convenience, an element of *PFI-FILTERS* can also take the form (type . subtype), meaning that if an object is already indexed as a subtype then it should not also be indexed as a type. The initial value of *PFI-FILTERS* is ((VARIABLES . CONSTANTS)), meaning that "variables" that successfully index as constants should not also be listed in the VARIABLES index. This extra pass is needed because the CONSTANTS File Manager command causes expressions of the form (RPAQ var value) to be dumped on the file, and at the time this expression is read, it is not known whether there will later on appear a CONSTANTS form for the same variable. Filter functions may want to call the following function: (PFI.LOOKUP.NAME name type) [Function] Looks up name in the index being built for type type. If it finds an entry, it returns it. Index entries are of the form (name . pagenumbers). It is permissible for a filter function as a side effect to destructively change another index entry by adding page numbers to it. You might want to do so, for example, in the case where there is a kind of object that dumps two expressions on a file, each of which is a different type (according to *PFI-TYPES*), but you want both occurrences indexed as a single type. MORE EXPLICIT EXPRESSION HANDLING The functions and variables described below allow you to completely control how certain expressions in the input file are handled. You can use these hooks to perform custom prettyprinting, to suppress the printing of some expressions, or to perform indexing more complex than that supported by *PFI-TYPES*. *PFI-HANDLERS* [Variable] An association list specifying explicit "handlers" for expressions that appear on the input file. Each element is a pair (car-of-form . handler), where handler is a function of one argument, an expression read from the file whose first element is car-of-form. The handler is completely in charge of indexing the expression and/or printing it to *STANDARD-OUTPUT*. Unless the handler chooses to suppress the printing altogether, it is expected to print at least one blank line first, so that expressions are attractively separated in the listing (see PFI.MAYBE.NEW.PAGE). *PFI-PREVIEWERS* [Variable] This list is used when PRETTYFILEINDEX is used by the SEE command. During the SEE command, real-time performance is important, so it is undesirable to have long delays while reading a very large expression. For example, all the functions in an Interlisp FNS command appear on the file inside a single DEFINEQ expression. If handled in the obvious way, the user would have to wait for the entire expression to be read before any output appeared. A previewer has the opportunity to read the expression in pieces and prettyprint it as it goes. Each element of *PFI-PREVIEWERS* is a pair (car-of-form . previewer), where previewer is a function of one argument, the car-of-form. The previewer is called when PRETTYFILEINDEX encounters an expression of the form "(car-of-form " on the file. Its job is to read expressions from *STANDARD-INPUT* (currently positioned after the car of form) until it encounters the closing right parenthesis, which it should consume, and prettyprint the elements appropriately to *STANDARD-OUTPUT*. *PFI-PREVIEWERS* is used only from the SEE command, so indexing is not necessary (but also not harmful, other than to waste some time). If an expression does not have a previewer, PRETTYFILEINDEX reads the reset of the expression itself and handles it normally, i.e., performs (PFI.HANDLE.EXPR (CONS car-of-form (CL:READ-DELIMITED-LIST #\)). (PFI.DEFAULT.HANDLER expr) [Function] This is the function PRETTYFILEINDEX uses to process expressions that have no explicit handler. It indexes the expression according to *PFI-TYPES* and then prettyprints the expression. You can call this function from your handler if you decide you have an expression you didn't want to handle specially. (PFI.HANDLE.EXPR expr) [Function] Performs PRETTYFILEINDEX's normal handling of the expression expr, including looking on *PFI-HANDLERS*. Handlers and previewers of forms that encapsulate arbitrary expressions, such as DECLARE:, typically call this to process subexpressions. (PFI.ADD.TO.INDEX name type/entry) [Function] Adds an entry to the index for type/entry specifying that name occurs on the current page. type/entry is either a type or an entry from *PFI-TYPES* from which the type will be extracted. (PFI.PRETTYPRINT expr name formflg) [Function] Prettyprints expr. Optional name is the name of the object being printed; if a page crossing occurs in the middle of the prettyprinting, this name will be displayed in the page header. If formflg is true, print the expression as code; otherwise as data. (PFI.MAYBE.NEW.PAGE expr minlines) [Function] Starts a new page if the listing is currently near the bottom of the page and expr won't fit, else performs a single (TERPRI). If minlines is specified, it is an explicit estimate of how much space the expression will require, in which case expr can be NIL; otherwise, the function estimates the size. Handlers should call this before calling PFI.ADD.TO.INDEX, so that the page number in the index is correct. The typical handler calls PFI.MAYBE.NEW.PAGE, then PFI.ADD.TO.INDEX, then prints the expression, possibly via PFI.PRETTYPRINT. OTHER VARIABLES *PFI-INDEX-ORDER* [Variable] A list of types (as in *PFI-TYPES*) in the order in which the various types should appear in the index. Types not in this list are printed in an order of the program's choosing, currently a "best fit" algorithm (print the largest type index that will fit on the page). The initial value is (FUNCTIONS), meaning that the function index will appear first, with no constraints on the order of other types. *PFI-PRINTOPTIONS* [Variable] A plist of print options that PRETTYFILEINDEX appends to the list of print options passed to LISTFILES, thus supplying some printing defaults. The initial value is (REGION (72 54 504 702)), which on standard letter size paper in portrait mode results in left, bottom, top, and right margins of 1", ž", ˝" and ˝", respectively. If the print options passed to LISTFILES call for a two-sided listing, the default region is shifted ź" to the left. If the print options specify LANDSCAPE mode, the default region is ignored. Any REGION option specified in *PFI-PRINTOPTIONS* must be in points; it is scaled appropriately to the actual hardcopy device being used. *PFI-MAX-WASTED-LINES* [Variable] If an expression looks like it won't fit on the current page and there are no more than this many lines remaining on the page, PRETTYFILEINDEX starts a new page before printing the expression. A floating-point value indicates a fraction of the page; an integer indicates an absolute number of lines. The initial value is 12. *PFI-CHARACTER-TRANSLATIONS* [Variable] A list specifying how certain characters should be rendered on the output stream. This is used to get around the poor rendering of certain characters in the default font. Each element is of the form (imagetype . charpairs), where imagetype is the type of image stream being printed to and each element of charpairs is an alist whose elements are of the form (sourcecode destcode . looks-plist), specifying the character code to use on the destination image stream for a specified character code in the input stream. If looks-plist is non-NIL, destcode is printed in a font obtained by applying FONTCOPY to the current font and looks-plist. The initial value is ((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC))) meaning if the output stream is an Interpress stream the lister should turn character 95 (underscore) into 172 (left arrow), backquote into left single quote in the Classic font (of the same size and weight), and single quote into right single quote in Classic. *PRINT-PRETTY-FROM-FILES* [Variable] If true, the SEE (in the Exec and Filebrowser), PF and PF* commands attempt to prettyprint to the display, rather than copying the file as it is currently formatted. The initial value is T. *PRINT-PRETTY-BITMAPS* [Variable] If true, then when *PRINT-ARRAY* is true and a bitmap is to be printed to an image stream, the bitmap itself is displayed as an image on the stream, rather than as the machine-readable representation of its bits (of the form #*(16 16)H@@@L...). This variable has no effect on printing to files, such as in MAKEFILE, nor on PRETTYFILEINDEX, which binds it true; thus, changing the value mainly affects the display. The initial value is T. *PFI-DONT-SPAWN* [Variable] If NIL, LISTFILES arranges for a separate process to do the hardcopying (whether using PRETTYFILEINDEX or not) and returns immediately; if T, it makes the listing directly, not returning until it is finished. The initial value is NIL. LISTING ELSEWHERE THAN THE PRINTER Ordinarily, you call LISTFILES (or uses the File Browser) to create listings. However, you can also call PRETTYFILEINDEX directly if you want to direct the output elsewhere, such as to an Interpress file: (PRETTYFILEINDEX filename printoptions outstream dontindex) [Function] Lists filename, the name of a Lisp source file or a stream open for input on such a file, printing it and its index to outstream. outstream is either an open image stream, or NIL, in which case the output goes to (OPENIMAGESTREAM) and the stream is closed afterwards, which results in it being sent to the default printer. If filename or outstream is open on entry, it is left open on exit. printoptions is a plist of options of interest to either LISTFILES or OPENIMAGESTREAM. If dontindex is true, no index is produced; this argument is used by the SEE command. If the file is not a File manager file, PRETTYFILEINDEX takes no action and returns NIL; otherwise, it returns the full file name. However, if filename is an open stream, then PRETTYFILEINDEX copies the remainder of the stream to outstream (which must be given) using PFCOPYBYTES, and returns the full file name. This is so that the stream does not need to be backed up after discovering that the file is not a File Manager file, an operation not possible for a sequential-access stream. LIMITATIONS PRETTYFILEINDEX assumes that the default font, which is used to print the index, is fixed-width. PRETTYFILEINDEX uses the regular Interlisp prettyprinter. This means that if you have File Manager commands that produce their output in a customized way, e.g., by printing inside the E command, then the output will look different between MAKEFILE and PRETTYFILEINDEX. You can usually remedy this by supplying PRETTYPRINTMACROS for the types of expressions your command dumps (which may also let you replace the E with a simpler P command), or by defining handlers for the expressions (see *PFI-HANDLERS*). PRETTYFILEINDEX already supplies PRETTYPRINTMACROS for most of the customized printing done by the current File Manager: RPAQ, RPAQQ, RPAQ?, ADDTOVAR, PUTPROPS and COURIERPROGRAM. With the exception of noticing the reader environment and DEFDEFINER expressions, PRETTYFILEINDEX does not interpret the contents of the file. If your file depends on itself for proper prettyprinting or indexing, you need to LOAD (or possibly just LOADFROM) the file first.(LIST ((PAGE NIL (PAPERSIZE LETTER FOLIOINFO (ARABIC "" "") STARTINGPAGE# 206) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE LETTER FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 72 456 624) NIL))) (PAGE NIL (PAPERSIZE LETTER FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 72 456 624) NIL)))))0$$ T0HH T0$$Č T2ČČ6 ÂT3ČČT2ČČ5llČ `l5´Č ¨´5lČ `l/$$Č 2ČČ2ČČHČČ PAGEHEADING RUNNINGHEAD,ŠŠ8,ŠŠ8,Č/HH CLASSIC +CLASSIC +CLASSIC +CLASSICCLASSICGACHA +MODERN MODERN HRULE.GETFNCLASSIC + HRULE.GETFNCLASSIC + HRULE.GETFNCLASSIC + HRULE.GETFNMODERN  HRULE.GETFNMODERN , ŘŞy{šL 2RS)? 2G(   2˛ć 0 ě  ź V-  tÔ'űn)- +)/ ) 'ÇÉ+î )ó +x¸Bb)‡   ˇ ( +WZ +[7    +?€ 5% , Y IWĹ + +@^  L 4  +  +X\V) +   %<   k    4R# 5)  _ my :  #H0 <"'   { X Y˝  !    $ W 5¨x Ž   ˆ    =T2 +   + +# )   <  N#gU N+    f  xŮ  ť  Ę  B - +€  + b   ż   ÁÉ  ě"jU     j  ź - O J (Y' ú b8Ł%G: +ÎaEƒzş \ No newline at end of file diff --git a/lispusers/PRINTERMENU b/lispusers/PRINTERMENU new file mode 100644 index 00000000..d93de768 --- /dev/null +++ b/lispusers/PRINTERMENU @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 4-Oct-88 18:01:30" |{EG:PARC:XEROX}LISPUSERS>PRINTERMENU.;3| 13173 changes to%: (VARS PRINTERMENUCOMS) (FNS PRINTERMENU PRINTERMENU.ADDMENUTOWINDOW PRINTERMENU.ADDORDELETE? PRINTERMENU.INFOHOOK PRINTERMENU.SELECTPRINTER PRINTERMENU.WATCH PRINTERMENU.WHENSELECTEDFN PRINTERMENU.CLOSEFN PRINTERMENU.GETNAME PRINTERMENU.CREATEMENU PRINTERMENU.CREATEPROMPTWINDOW PRINTERMENU.TOFRONTOFLIST) previous date%: "13-Feb-87 09:11:46" {PHYLUM}MEDLEY>PRINTERMENU.;1) (* " Copyright (c) 1985, 1987, 1988 by Robert Ridder. All rights reserved. ") (PRETTYCOMPRINT PRINTERMENUCOMS) (RPAQQ PRINTERMENUCOMS ((FNS PRINTERMENU PRINTERMENU.ADDMENUTOWINDOW PRINTERMENU.ADDORDELETE? PRINTERMENU.AFTERMOVEFN PRINTERMENU.CLOSEFN PRINTERMENU.CREATEMENU PRINTERMENU.CREATEPROMPTWINDOW PRINTERMENU.GETNAME PRINTERMENU.INFOHOOK PRINTERMENU.SELECTPRINTER PRINTERMENU.TOFRONTOFLIST PRINTERMENU.WATCH PRINTERMENU.WHENHELDFN PRINTERMENU.WHENSELECTEDFN) (INITVARS (PRINTERMENU.POSITION NIL) (PRINTERMENU.SHADE1 9345) (PRINTERMENU.WATCH.WAIT 5) (PRINTERMENU.WINDOW NIL)) (VARS PRINTERMENU.PRINTERSHADE) (GLOBALVARS PRINTERMENU.POSITION PRINTERMENU.SHADE1 PRINTERMENU.WATCH.WAIT PRINTERMENU.WINDOW PROMPTWINDOW) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (if (POSITIONP PRINTERMENU.POSITION) then (PRINTERMENU)))))) (DEFINEQ (PRINTERMENU (LAMBDA NIL (* ; "Edited 30-Sep-88 18:38 by hdj") (* ;;; "Creates a menu window which can be used to alter the value of DEFAULTPRINTINGHOST such that one can add printers, delete printers, and rearrange the order of printers on the list.") (LET* ((PROCESS (FIND.PROCESS "PrinterMenu")) (MENU (PRINTERMENU.CREATEMENU)) (WIDTH (XCL:RECORD-FETCH :MENU :IMAGEWIDTH MENU)) (HEIGHT (XCL:RECORD-FETCH :MENU :IMAGEHEIGHT MENU)) LEFT BOTTOM) (* ;; "Find out where to put it") (COND ((NOT (POSITIONP PRINTERMENU.POSITION)) (SETQ PRINTERMENU.POSITION (GETBOXPOSITION WIDTH HEIGHT)))) (SETQ LEFT (fetch (POSITION XCOORD) of PRINTERMENU.POSITION)) (SETQ BOTTOM (fetch (POSITION YCOORD) of PRINTERMENU.POSITION)) (* ;; "Zap PRINTERMENU.WATCH if it's running") (COND (PROCESS (SUSPEND.PROCESS PROCESS))) (* ;; "Only one window allowed. Close any old one.") (COND ((WINDOWP PRINTERMENU.WINDOW) (WINDOWPROP PRINTERMENU.WINDOW (QUOTE CLOSEFN) NIL) (CLOSEW PRINTERMENU.WINDOW))) (* ;; "Create a new window") (SETQ PRINTERMENU.WINDOW (CREATEW (CREATEREGION LEFT BOTTOM WIDTH HEIGHT) NIL 0 T)) (WINDOWPROP PRINTERMENU.WINDOW (QUOTE AFTERMOVEFN) (FUNCTION PRINTERMENU.AFTERMOVEFN)) (WINDOWPROP PRINTERMENU.WINDOW (QUOTE RESHAPEFN) (QUOTE DON'T)) (WINDOWPROP PRINTERMENU.WINDOW (QUOTE DEFAULTPRINTINGHOST) (COPYALL DEFAULTPRINTINGHOST)) (WINDOWPROP PRINTERMENU.WINDOW (QUOTE CLOSEFN) (FUNCTION PRINTERMENU.CLOSEFN)) (* ;; "Add the menu to PRINTERMENU.WINDOW") (PRINTERMENU.ADDMENUTOWINDOW MENU) (* ;; "Start the process to monitor the value of DEFAULTPRINTINGHOST") (if PROCESS then (WAKE.PROCESS PROCESS) else (ADD.PROCESS (QUOTE (PRINTERMENU.WATCH)) (QUOTE NAME) "PrinterMenu" (QUOTE INFOHOOK) (FUNCTION PRINTERMENU.INFOHOOK) (QUOTE RESTARTABLE) T)) (* ;; "Open the menu window and return it") (OPENW PRINTERMENU.WINDOW) PRINTERMENU.WINDOW)) ) (PRINTERMENU.ADDMENUTOWINDOW (LAMBDA (MENU) (* ; "Edited 30-Sep-88 13:30 by hdj") (* ;; "Place Menu in PRINTERMENU.WINDOW and shade first two items of menu") (LET ((MENU-ITEMS (fetch (MENU ITEMS) of MENU))) (ADDMENU MENU PRINTERMENU.WINDOW) (SHADEITEM (CAR MENU-ITEMS) MENU BLACKSHADE PRINTERMENU.WINDOW) (COND ((CADR MENU-ITEMS) (SHADEITEM (CADR MENU-ITEMS) MENU PRINTERMENU.PRINTERSHADE PRINTERMENU.WINDOW))))) ) (PRINTERMENU.ADDORDELETE? (LAMBDA NIL (* ; "Edited 30-Sep-88 11:01 by hdj") (* ;;; "Add or Delete from DEFAULTPRINTINGHOST") (LET ((ITEM (MENU (create MENU ITEMS _ (QUOTE (("Add printer" (QUOTE Add) "Allows you to add a printer to DEFAULTPRINTINGHOST") ("Delete printer" (QUOTE Delete) "Allows you to delete a printer from DEFAULTPRINTINGHOST"))) CENTERFLG _ T MENUBORDERSIZE _ 1))) PRINTER-NAME) (* ;; "Pop up a menu to find out if add or delete wanted") (if ITEM then (* ;; "Since we'll be requiring the use of the mouse for a while, spawn a new mouse so things can't get locked up.") (SPAWN.MOUSE) (* ;; "Find out what to Add or Delete") (SETQ PRINTER-NAME (PRINTERMENU.GETNAME ITEM)) (* ;; "If nothing selected, do nothing") (if PRINTER-NAME then (* ;; "If Add or Delete, then do it") (SELECTQ ITEM (Add (COND ((NOT (MEMBER PRINTER-NAME DEFAULTPRINTINGHOST)) (SETQ DEFAULTPRINTINGHOST (CONS PRINTER-NAME DEFAULTPRINTINGHOST)) ITEM))) (Delete (COND ((SETQ PRINTER-NAME (for PRINTER-DESCR in DEFAULTPRINTINGHOST do (COND ((OR (AND (LISTP PRINTER-DESCR) (STRING-EQUAL PRINTER-NAME (OR (CADR PRINTER-DESCR) (CAR PRINTER-DESCR)))) (AND (NLISTP PRINTER-NAME) (NLISTP PRINTER-DESCR) (STRING-EQUAL PRINTER-NAME PRINTER-DESCR))) (RETURN PRINTER-DESCR))))) (COND ((NOT (CDR DEFAULTPRINTINGHOST)) (SETQ DEFAULTPRINTINGHOST NIL)) (T (SETQ DEFAULTPRINTINGHOST (REMOVE PRINTER-NAME DEFAULTPRINTINGHOST)))) ITEM))) NIL))))) ) (PRINTERMENU.AFTERMOVEFN (LAMBDA (Window) (* RAR " 8-Oct-85 08:43") (* * Update the value of PRINTERMENU.POSITION) (PROG ((Region (WINDOWPROP Window 'REGION))) (SETQ PRINTERMENU.POSITION (create POSITION XCOORD _ (fetch (REGION LEFT) of Region) YCOORD _ (fetch (REGION BOTTOM) of Region)))))) (PRINTERMENU.CLOSEFN (LAMBDA NIL (* ; "Edited 30-Sep-88 18:27 by hdj") (* ;; "Set the globalvar for the printermenu window to NIL") (SETQ PRINTERMENU.WINDOW NIL) (* ;; "If PRINTERMENU.WINDOW closed, then shut down process to monitor DEFAULTPRINTINGHOST") (LET ((PROCESS (FIND.PROCESS "PrinterMenu"))) (if PROCESS then (DEL.PROCESS PROCESS)))) ) (PRINTERMENU.CREATEMENU (LAMBDA NIL (* ; "Edited 29-Sep-88 18:19 by hdj") (* ;;; "Create and return the menu to be used by PRINTERMENU") (create MENU ITEMS _ (CONS "-- Default Printer --" (for PRINTER-DESCR in DEFAULTPRINTINGHOST collect (COND ((LISTP PRINTER-DESCR) (OR (CADR PRINTER-DESCR) (CAR PRINTER-DESCR))) (T PRINTER-DESCR)))) WHENSELECTEDFN _ (FUNCTION PRINTERMENU.WHENSELECTEDFN) WHENHELDFN _ (FUNCTION PRINTERMENU.WHENHELDFN) CENTERFLG _ T MENUBORDERSIZE _ 1)) ) (PRINTERMENU.CREATEPROMPTWINDOW (LAMBDA NIL (* ; "Edited 29-Sep-88 17:34 by hdj") (* ;;; "Return a window to be used to ask for the name of a printer to add to the menu") (PROG (Bottom Font Height Left MouseX MouseY Width) (SETQ Font (DEFAULTFONT (QUOTE DISPLAY))) (SETQ Width (WIDTHIFWINDOW (ITIMES 60 (CHARWIDTH (CHCON1 "X") Font)))) (SETQ Height (HEIGHTIFWINDOW (ITIMES 2 (FONTPROP Font (QUOTE HEIGHT))) T)) (SETQ Left (COND ((IGEQ (IDIFFERENCE SCREENWIDTH (SETQ MouseX LASTMOUSEX)) Width) MouseX) (T (IMAX 0 (IDIFFERENCE MouseX Width))))) (SETQ Bottom (COND ((IGEQ (IDIFFERENCE SCREENHEIGHT (SETQ MouseY LASTMOUSEY)) Height) MouseY) (T (IMAX 0 (IDIFFERENCE MouseY Height))))) (RETURN (CREATEW (CREATEREGION Left Bottom Width Height) "Question from PRINTERMENU:" NIL T)))) ) (PRINTERMENU.GETNAME (LAMBDA (ITEM) (* ; "Edited 30-Sep-88 18:29 by hdj") (* ;;; "Return name of printer to add or delete.") (COND ((EQ ITEM (QUOTE Add)) (* ;; "Add") (LET ((WINDOW (PRINTERMENU.CREATEPROMPTWINDOW))) (PROG1 (PROMPTFORWORD "Enter name of printer to add: " NIL NIL WINDOW NIL (QUOTE TTY) (CHARCODE (EOL ESCAPE LF))) (CLOSEW WINDOW)))) (T (* ;; "Delete") (CL:FORMAT PROMPTWINDOW "~&Select a printer to delete") (PROG1 (PRINTERMENU.SELECTPRINTER) (CLEARW PROMPTWINDOW))))) ) (PRINTERMENU.INFOHOOK (LAMBDA (PROCESS BUTTON) (* ; "Edited 30-Sep-88 10:35 by hdj") (CL:FORMAT PROMPTWINDOW "~&Monitors the value of DEFAULTPRINTINGHOST for PRINTERMENU.~%%")) ) (PRINTERMENU.SELECTPRINTER (LAMBDA NIL (* ; "Edited 30-Sep-88 10:58 by hdj") (* ;;; "Return the printer selected with the mouse from the PRINTERMENU menu, or return NIL if none chosen") (LET ((MENU (WINDOWPROP PRINTERMENU.WINDOW (QUOTE MENU))) LIST-OF-PRINTERS MENU-POSITION PRINTER SCREEN-POSITION (WINDOW-REGION (WINDOWPROP PRINTERMENU.WINDOW (QUOTE REGION)))) (* ;; "Get the menu in the PRINTERMENU.WINDOW") (COND ((LISTP MENU) (SETQ MENU (CAR MENU)))) (* ;; "Get the list of printers") (SETQ LIST-OF-PRINTERS (CDR (fetch (MENU ITEMS) of MENU))) (* ;; "Wait until mouse button down") (until (MOUSESTATE (OR LEFT MIDDLE RIGHT)) do (for ITEM in LIST-OF-PRINTERS do (SHADEITEM ITEM MENU WHITESHADE PRINTERMENU.WINDOW))) (* ;; "I didn't use the function UNTILMOUSESTATE because I want to keep control of the mouse until the user clicks it somewhere.") (* ;; "While mouse button down, if cursor in menu-item region, grayout region") (while (MOUSESTATE (OR LEFT MIDDLE RIGHT)) do (COND ((INSIDEP WINDOW-REGION LASTMOUSEX LASTMOUSEY) (for ITEM in LIST-OF-PRINTERS do (COND ((INSIDEP (MENUITEMREGION ITEM MENU) (LASTMOUSEX PRINTERMENU.WINDOW) (LASTMOUSEY PRINTERMENU.WINDOW)) (SHADEITEM ITEM MENU GRAYSHADE PRINTERMENU.WINDOW)) (T (SHADEITEM ITEM MENU WHITESHADE PRINTERMENU.WINDOW))))) (T (for ITEM in LIST-OF-PRINTERS do (SHADEITEM ITEM MENU WHITESHADE PRINTERMENU.WINDOW)))) finally (for ITEM in LIST-OF-PRINTERS do (SHADEITEM ITEM MENU (COND ((EQ ITEM (CAR LIST-OF-PRINTERS)) BLACKSHADE) (T WHITESHADE)) PRINTERMENU.WINDOW))) (* ;; "Get the position of the mouse following the click in the coordinates of the PRINTERMENU.WINDOW") (* ;; "If not in the PRINTERMENU.WINDOW, we're done") (COND ((INSIDEP WINDOW-REGION (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)) (* ;; "See if the position of the mouse cursor is inside the menu-item-region for a printer on the menu") (for ITEM in (CDR (fetch (MENU ITEMS) of MENU)) do (COND ((INSIDEP (MENUITEMREGION ITEM MENU) (LASTMOUSEX PRINTERMENU.WINDOW) (LASTMOUSEY PRINTERMENU.WINDOW)) (SETQ PRINTER ITEM)))) PRINTER)))) ) (PRINTERMENU.TOFRONTOFLIST (LAMBDA (PRINTER-NAME) (* ; "Edited 29-Sep-88 18:17 by hdj") (* ;;; "Move Item to front of DEFAULTPRINTINGHOST") (LET ((THING-TO-MOVE NIL)) (* ;; "First find the element of DEFAULTPRINTINGHOST to be moved to first place") (for PRINTER-DESCR in DEFAULTPRINTINGHOST do (COND ((OR (AND (LISTP PRINTER-DESCR) (STRING-EQUAL PRINTER-NAME (OR (CADR PRINTER-DESCR) (CAR PRINTER-DESCR)))) (AND (NLISTP PRINTER-NAME) (NLISTP PRINTER-DESCR) (STRING-EQUAL PRINTER-NAME PRINTER-DESCR))) (SETQ THING-TO-MOVE PRINTER-DESCR))) repeatuntil THING-TO-MOVE) (* ;;; "Now place the element in first place") (SETQ DEFAULTPRINTINGHOST (CONS THING-TO-MOVE (REMOVE THING-TO-MOVE DEFAULTPRINTINGHOST))))) ) (PRINTERMENU.WATCH (LAMBDA NIL (* ; "Edited 30-Sep-88 18:37 by hdj") (* ;;; "Every PRINTERMENU.WATCH.WAIT seconds check to see if DEFAULTPRINTINGHOST has changed. If it has, then update the printer menu.") (do (* ; "forever") (COND ((NOT (EQUAL DEFAULTPRINTINGHOST (WINDOWPROP PRINTERMENU.WINDOW (QUOTE DEFAULTPRINTINGHOST)))) (PRINTERMENU))) (BLOCK (ITIMES PRINTERMENU.WATCH.WAIT 1000)))) ) (PRINTERMENU.WHENHELDFN (LAMBDA (Item Menu Button) (* Ridder%: " 2-Aug-85 13:30") (* * Print an appropriate message in PROMPTWINDOW.) (PROG ((Menuitems (fetch (MENU ITEMS) of Menu))) (COND ((EQ Item (CAR Menuitems)) (printout PROMPTWINDOW "This item allows you to add or delete printers" T)) (T (printout PROMPTWINDOW "Will make " Item " the first element of DEFAULTPRINTINGHOST" T)))))) (PRINTERMENU.WHENSELECTEDFN (LAMBDA (ITEM MENU BUTTON) (* ; "Edited 30-Sep-88 18:27 by hdj") (* ;; "Respond to item selected in menu") (PROG ((MENU-ITEMS (fetch (MENU ITEMS) of MENU))) (* ;; "If the value of DEFAULTPRINTINGHOST has been changed outside of PRINTERMENU, or if the monitor process has been killed, then update the menu and return") (COND ((OR (NOT (EQUAL DEFAULTPRINTINGHOST (WINDOWPROP PRINTERMENU.WINDOW (QUOTE DEFAULTPRINTINGHOST)))) (NOT (FIND.PROCESS "PrinterMenu"))) (PRINTERMENU) (RETURN NIL))) (* ;; "If selecting the 'title bar' , then popup the add-or-delete menu and add or delete a printer") (if (EQ ITEM (CAR MENU-ITEMS)) then (if (PRINTERMENU.ADDORDELETE?) then (PRINTERMENU)) (RETURN NIL)) (* ;; "If a printer was selected, move it to the top of the menu and the front of DEFAULTPRINTINGHOST") (PRINTERMENU.TOFRONTOFLIST ITEM) (DELETEMENU MENU NIL PRINTERMENU.WINDOW) (PRINTERMENU.ADDMENUTOWINDOW (PRINTERMENU.CREATEMENU)) (WINDOWPROP PRINTERMENU.WINDOW (QUOTE DEFAULTPRINTINGHOST) (COPYALL DEFAULTPRINTINGHOST)))) ) ) (RPAQ? PRINTERMENU.POSITION NIL) (RPAQ? PRINTERMENU.SHADE1 9345) (RPAQ? PRINTERMENU.WATCH.WAIT 5) (RPAQ? PRINTERMENU.WINDOW NIL) (RPAQQ PRINTERMENU.PRINTERSHADE 33825) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PRINTERMENU.POSITION PRINTERMENU.SHADE1 PRINTERMENU.WATCH.WAIT PRINTERMENU.WINDOW PROMPTWINDOW) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (if (POSITIONP PRINTERMENU.POSITION) then (PRINTERMENU)) ) (PUTPROPS PRINTERMENU COPYRIGHT ("Robert Ridder" 1985 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1407 12672 (PRINTERMENU 1417 . 3257) (PRINTERMENU.ADDMENUTOWINDOW 3259 . 3677) ( PRINTERMENU.ADDORDELETE? 3679 . 5097) (PRINTERMENU.AFTERMOVEFN 5099 . 5595) (PRINTERMENU.CLOSEFN 5597 . 5945) (PRINTERMENU.CREATEMENU 5947 . 6424) (PRINTERMENU.CREATEPROMPTWINDOW 6426 . 7207) ( PRINTERMENU.GETNAME 7209 . 7699) (PRINTERMENU.INFOHOOK 7701 . 7883) (PRINTERMENU.SELECTPRINTER 7885 . 9962) (PRINTERMENU.TOFRONTOFLIST 9964 . 10674) (PRINTERMENU.WATCH 10676 . 11072) ( PRINTERMENU.WHENHELDFN 11074 . 11619) (PRINTERMENU.WHENSELECTEDFN 11621 . 12670))))) STOP \ No newline at end of file diff --git a/lispusers/PRINTERMENU.TEDIT b/lispusers/PRINTERMENU.TEDIT new file mode 100644 index 00000000..ec3f7491 Binary files /dev/null and b/lispusers/PRINTERMENU.TEDIT differ diff --git a/lispusers/PROGRAMCHAT b/lispusers/PROGRAMCHAT new file mode 100644 index 00000000..f53ce7b9 --- /dev/null +++ b/lispusers/PROGRAMCHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Sep-88 01:18:17" {PHYLUM}LISP>LYRIC>PROGRAMCHAT.;1 10721 changes to%: (FNS OPENCHATSTREAM PROGRAMCHAT PROGRAMCHAT.LOGIN) previous date%: "12-May-88 21:46:25" {QV}LISP>PROGRAMCHAT.;1) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PROGRAMCHATCOMS) (RPAQQ PROGRAMCHATCOMS [(FNS OPENCHATSTREAM PROGRAMCHAT PROGRAMCHAT.LOGIN PROGRAMCHAT.OUTPUT) (P [if (ASSOC 'TENEX NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("LOGOUT" CR) (CDR (ASSOC 'TENEX NETWORKLOGINFO] [if (ASSOC 'TOPS20 NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("LOGOUT" CR) (CDR (ASSOC 'TOPS20 NETWORKLOGINFO] [if (ASSOC 'UNIX NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '(WAIT CR "logout" CR) (CDR (ASSOC 'UNIX NETWORKLOGINFO] [if (ASSOC 'VMS NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("LOGOUT" CR) (CDR (ASSOC 'VMS NETWORKLOGINFO] [if (ASSOC 'IFS NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("Quit" CR) (CDR (ASSOC 'IFS NETWORKLOGINFO] (if (ASSOC 'NS NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("Quit" CR) (CDR (ASSOC 'NS NETWORKLOGINFO]) (DEFINEQ (OPENCHATSTREAM [LAMBDA (HOST) (* ; "Edited 23-Sep-88 16:57 by bbb") (PROG (OPENFN SLASH PROTOCOL) (COND ((BOUNDP 'CHAT.PROTOCOLTYPES) [if [AND (SETQ SLASH (STRPOS "/" HOST)) (SETQ PROTOCOL (CDR (CL:ASSOC (SUBSTRING HOST (ADD1 SLASH)) CHAT.PROTOCOL.ABBREVS :TEST 'STRING-EQUAL] then (* ;  "Caller explicitly specified protocol to use") [if [NOT (SETQ OPENFN (CDR (ASSOC PROTOCOL CHAT.PROTOCOLTYPES] then (printout PROMPTWINDOW T (CONCAT "The " PROTOCOL " Chat protocol is not loaded.")) (RETURN NIL) elseif [NOT (SETQ OPENFN (CL:FUNCALL OPENFN (SETQ HOST (SUBSTRING HOST 1 (SUB1 SLASH] then (printout PROMPTWINDOW T (CONCAT HOST " is not a recognized " PROTOCOL " host.")) (RETURN NIL) else (RETURN (APPLY* (CADR OPENFN) (CAR OPENFN] elseif (AND [SETQ PROTOCOL (CDR (CL:ASSOC HOST CHAT.HOST.TO.PROTOCOL :TEST 'STRING-EQUAL] (SETQ OPENFN (CDR (ASSOC PROTOCOL CHAT.PROTOCOLTYPES))) (SETQ OPENFN (CL:FUNCALL OPENFN HOST))) then (* ;  "use protocol that worked the last time. Clear PROTOCOL to skip the test below for remembering it") (SETQ PROTOCOL NIL) (RETURN (APPLY* (CADR OPENFN) (CAR OPENFN))) else (* ; "Try all protocols") (for PAIR in CHAT.PROTOCOLTYPES when (SETQ OPENFN (CL:FUNCALL (CDR PAIR) HOST)) do (* ;  "Value returned is (CanonicalHostName OpenFn)") (SETQ PROTOCOL (CAR PAIR)) (RETURN (APPLY* (CADR OPENFN) (CAR OPENFN] (* old code (if (for PROTOCOL in  CHAT.PROTOCOLTYPES thereis  (SETQ OPENFN (APPLY*  (CDR PROTOCOL) HOST))) then  (RETURN (APPLY* (CADR OPENFN)  (CAR OPENFN))))) ]) (PROGRAMCHAT [LAMBDA (HOST CMDSTREAM LOGSTREAM) (* ; "Edited 29-Sep-88 00:48 by bbb") (PROG ((STREAMPAIR (OPENCHATSTREAM HOST)) INCHAT OUTCHAT) [if (STRPOS "/" HOST) then (SETQ HOST (SUBSTRING HOST 1 (SUB1 (STRPOS "/" HOST] (COND (STREAMPAIR (SETQ INCHAT (CAR STREAMPAIR)) (SETQ OUTCHAT (CDR STREAMPAIR)) (SETFILEINFO OUTCHAT 'ENDOFSTREAMOP (FUNCTION CHAT.ENDOFSTREAMOP)) (SETFILEINFO INCHAT 'ENDOFSTREAMOP (FUNCTION CHAT.ENDOFSTREAMOP)) [ADD.PROCESS `(PROGRAMCHAT.OUTPUT (QUOTE %, INCHAT) (QUOTE %, LOGSTREAM] (BLOCK) (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT) [COND ((STRINGP CMDSTREAM) (SETQ CMDSTREAM (OPENSTRINGSTREAM CMDSTREAM 'INPUT] [COND ((NULL LOGSTREAM) (SETQ LOGSTREAM (OPENSTREAM '{NULL} 'OUTPUT] (while (AND (OPENP OUTCHAT 'OUTPUT) (NOT (EOFP CMDSTREAM))) do (BOUT OUTCHAT (BIN CMDSTREAM)) (BLOCK) finally (COND ((EOFP CMDSTREAM) (CLOSEF CMDSTREAM) (BOUT OUTCHAT (CHARCODE CR)) (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT 'LOGOUT) (FORCEOUTPUT OUTCHAT T) (until (NOT (OPENP INCHAT 'INPUT)) do (BLOCK) finally (CLOSEF? OUTCHAT]) (PROGRAMCHAT.LOGIN [LAMBDA (HOST INSTREAM OUTSTREAM OPTION) (* ; "Edited 29-Sep-88 01:08 by bbb") (* * Login to HOST. If a job already exists on HOST, Attach to it unless OPTION  overrides.) (PROG ((LOGINFO (CDR (ASSOC (OR (GETOSTYPE HOST) 'IFS) NETWORKLOGINFO))) NAME/PASS COM) (OR LOGINFO (RETURN)) (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST)) [SETQ COM (COND (OPTION) ((ASSOC 'ATTACH LOGINFO) (OR (CHAT.LOGINFO INSTREAM HOST (CAR NAME/PASS)) 'LOGIN)) (T (* Don't know how to do anything but  login, so silly to try anything else) 'LOGIN] (COND ((NULL (SETQ LOGINFO (ASSOC COM LOGINFO))) (printout PROMPTWINDOW T "Login option " COM " not implemented for this type of host")) (T (for X in (CDR LOGINFO) do (SELECTQ X ((CR LF) (BOUT OUTSTREAM (CHARCODE CR)) (FORCEOUTPUT OUTSTREAM)) (USERNAME (PRIN3 (CAR NAME/PASS) OUTSTREAM)) (PASSWORD (PRIN3 (\DECRYPT.PWD (CDR NAME/PASS)) OUTSTREAM)) (WAIT (* Some systems do not permit  typeahead) (COND ((NOT (CHAT.FLUSH&WAIT INSTREAM)) (* Couldn't sync, so wait longer.) (DISMISS CHAT.WAIT.TIME))) (DISMISS CHAT.WAIT.TIME)) (PRIN3 X OUTSTREAM))) (FORCEOUTPUT OUTSTREAM]) (PROGRAMCHAT.OUTPUT (LAMBDA (INCHATSTREAM LOGSTREAM) (* ejs%: "23-Feb-85 19:18") (bind CH while (AND (NEQ CH -1) (OPENP INCHATSTREAM 'INPUT)) do (SETQ CH (BIN INCHATSTREAM)) (COND ((NEQ CH -1) (COND (LOGSTREAM (BOUT LOGSTREAM CH))))) finally (COND ((OPENP INCHATSTREAM) (CLOSEF INCHATSTREAM)))))) ) [if (ASSOC 'TENEX NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("LOGOUT" CR) (CDR (ASSOC 'TENEX NETWORKLOGINFO] [if (ASSOC 'TOPS20 NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("LOGOUT" CR) (CDR (ASSOC 'TOPS20 NETWORKLOGINFO] [if (ASSOC 'UNIX NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '(WAIT CR "logout" CR) (CDR (ASSOC 'UNIX NETWORKLOGINFO] [if (ASSOC 'VMS NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("LOGOUT" CR) (CDR (ASSOC 'VMS NETWORKLOGINFO] [if (ASSOC 'IFS NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("Quit" CR) (CDR (ASSOC 'IFS NETWORKLOGINFO] [if (ASSOC 'NS NETWORKLOGINFO) then (PUTASSOC 'LOGOUT '("Quit" CR) (CDR (ASSOC 'NS NETWORKLOGINFO] (PUTPROPS PROGRAMCHAT COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1546 9817 (OPENCHATSTREAM 1556 . 4847) (PROGRAMCHAT 4849 . 6706) (PROGRAMCHAT.LOGIN 6708 . 9151) (PROGRAMCHAT.OUTPUT 9153 . 9815))))) STOP \ No newline at end of file diff --git a/lispusers/PROGRAMCHAT.TEDIT b/lispusers/PROGRAMCHAT.TEDIT new file mode 100644 index 00000000..e4fade78 Binary files /dev/null and b/lispusers/PROGRAMCHAT.TEDIT differ diff --git a/lispusers/PROMPTREMINDERS b/lispusers/PROMPTREMINDERS new file mode 100644 index 00000000..0c158e93 --- /dev/null +++ b/lispusers/PROMPTREMINDERS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-May-88 14:13:53" {ERINYES}MEDLEY>PROMPTREMINDERS.;1 25212 previous date%: "18-Nov-85 13:39:10" {ERINYES}KOTO>LISPUSERS>PROMPTREMINDERS.;1) (* " Copyright (c) 1982, 1983, 1984, 1985, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PROMPTREMINDERSCOMS) (RPAQQ PROMPTREMINDERSCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PERIODIC.PROMPT.REMINDER)) (FNS SETREMINDER SHOW.REMINDER ACTIVEREMINDERNAMES REMINDER.NEXTREMINDDATE REMINDER.EXPIRATIONDATE REMINDER.PERIOD REMINDERS.RESTART REMINDERS.WATCHDOG) (PROP ARGNAMES REMINDER.NEXTREMINDDATE REMINDER.EXPIRATIONDATE REMINDER.PERIOD) (FNS \PUTREMINDER \GETREMINDER \DELREMINDER) (FNS PERIODICALLYCHECKREMINDERS) (INITVARS (\PR.REMOVALS NIL)) (INITVARS (DEFAULT.REMINDER.DURATION 60) (DEFAULT.REMINDER.WINKINGDURATION 10) (PERIODIC.PROMPT.REMINDERS NIL) (REMINDERSTREAM PROMPTWINDOW)) (GLOBALVARS \PR.REMOVALS REMINDERSTREAM PERIODIC.PROMPT.REMINDERS DEFAULT.REMINDER.DURATION DEFAULT.REMINDER.WINKINGDURATION DEFAULT.REMINDER.PERIOD) (FILEPKGCOMS REMINDERS) (INITVARS (CLOSEREMINDERSTREAMFLG)) [VARS (\REMINDER.EVENT (CREATE.EVENT 'PERIODIC.PROMPT.REMINDERS] (GLOBALVARS CLOSEREMINDERSTREAMFLG \REMINDER.EVENT) (ADDVARS (AFTERLOGOUTFORMS (REMINDERS.RESTART))) (P (REMINDERS.RESTART)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA REMINDER.PERIOD REMINDER.EXPIRATIONDATE REMINDER.NEXTREMINDDATE]) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD PERIODIC.PROMPT.REMINDER (REMINDER.TIMEOUTBOX REMINDER.MESSAGE REMINDER.PERIOD REMINDER.WINKINGDURATION REMINDER.DURATION REMINDER.FINALTIME REMINDER.NAME) REMINDER.TIMEOUTBOX _ (SETUPTIMER 0 'SECONDS) [ACCESSFNS ([REMINDER.NEXTREMINDDATE [GDATE (AND (fetch REMINDER.TIMEOUTBOX of DATUM) (ALTO.TO.LISP.DATE (fetch REMINDER.TIMEOUTBOX of DATUM] (replace REMINDER.TIMEOUTBOX of DATUM with (SETUPTIMER.DATE NEWVALUE (fetch REMINDER.TIMEOUTBOX of DATUM] (REMINDER.EXPIRATIONDATE [GDATE (AND (fetch REMINDER.FINALTIME of DATUM) (ALTO.TO.LISP.DATE (fetch REMINDER.FINALTIME of DATUM] (replace REMINDER.FINALTIME of DATUM with (AND NEWVALUE (SETUPTIMER.DATE NEWVALUE]) ) ) (DEFINEQ (SETREMINDER [LAMBDA (NAME PERIOD MESSAGE INITIALDELAY EXPIRATION REMINDINGDURATION WINKINGDURATION) (* lmm "23-Apr-85 14:06") (PROG ((RNAME (OR NAME (GENSYM))) REMINDER) [if [NULL (SETQ REMINDER (GETDEF RNAME 'REMINDERS NIL 'NOERROR] then (* Big time delay before first "reminding" to allow time for the completion of  this function!) (SETQ REMINDER (create PERIODIC.PROMPT.REMINDER REMINDER.TIMEOUTBOX _ (SETUPTIMER 16000 NIL 'SECONDS] (replace REMINDER.MESSAGE of REMINDER with (OR MESSAGE RNAME)) (replace REMINDER.DURATION of REMINDER with (OR (FIXP REMINDINGDURATION) DEFAULT.REMINDER.DURATION)) (replace REMINDER.WINKINGDURATION of REMINDER with (OR (FIXP WINKINGDURATION) DEFAULT.REMINDER.WINKINGDURATION )) (PUTDEF RNAME 'REMINDERS REMINDER) (* This call is made even for "old" reminders, to get the action of  MARKASCHANGED * Note also how the PERIOD was null during this time, so that it  didn't reset the timer.) (replace REMINDER.PERIOD of REMINDER with PERIOD) [replace REMINDER.TIMEOUTBOX of REMINDER with (if (STRINGP INITIALDELAY) then (SETUPTIMER.DATE INITIALDELAY (fetch REMINDER.TIMEOUTBOX of REMINDER)) else (SETUPTIMER (OR (FIXP INITIALDELAY) PERIOD 0) (fetch REMINDER.TIMEOUTBOX of REMINDER) 'SECONDS] (if EXPIRATION then (REMINDER.EXPIRATIONDATE REMINDER (if (FIXP EXPIRATION) then (IPLUS EXPIRATION (IDATE (  REMINDER.NEXTREMINDDATE REMINDER))) else (STRINGP EXPIRATION)) T)) (NOTIFY.EVENT \REMINDER.EVENT) (RETURN RNAME]) (SHOW.REMINDER [LAMBDA (REMINDER) (* lmm "19-Apr-85 18:04") (PROG ((MESSAGE (fetch REMINDER.MESSAGE of REMINDER))) [if (LISTP MESSAGE) then (NLSETQ (EVAL MESSAGE)) else (PRINTBELLS) (DSPRESET REMINDERSTREAM) (bind (FIRSTTIME _ T) (LUACTION _ (COPYALL \LASTUSERACTION)) (VISIBLE _ NIL) (DURATION _ (SETUPTIMER (fetch REMINDER.DURATION of REMINDER) NIL 'SECONDS)) repeatuntil (TIMEREXPIRED? DURATION 'SECONDS) do (bind (WINKING _ (SETUPTIMER (fetch REMINDER.WINKINGDURATION of REMINDER) NIL 'SECONDS)) repeatuntil (TIMEREXPIRED? WINKING 'SECONDS) do (if (SETQ VISIBLE (NOT VISIBLE)) then (PRIN3 MESSAGE REMINDERSTREAM) (TERPRI REMINDERSTREAM) (if (NOT (EQUAL LUACTION \LASTUSERACTION)) then (GO DONE)) else (DSPRESET REMINDERSTREAM)) (DISMISS 500] DONE]) (ACTIVEREMINDERNAMES [LAMBDA NIL (* JonL "29-NOV-82 16:58") (MAPCAR PERIODIC.PROMPT.REMINDERS (FUNCTION CAR]) (REMINDER.NEXTREMINDDATE [LAMBDA N (* lmm "19-Apr-85 18:07") (* * 1-arg case is only asking for information;  multi-arg for update; 3'rd arg, if non-null, says don't mark as changed.) (AND (IGEQ N 1) ([LAMBDA (DEF) (AND DEF ([LAMBDA (SDATE NEWDATE) (if (EQ N 1) then SDATE else [SETQ NEWDATE (OR (STRINGP (ARG N 2)) (GDATE (ARG N 2] (if [AND (NOT (IEQP (IDATE SDATE) (IDATE NEWDATE))) (OR (ILEQ N 2) (NULL (ARG N 3] then (MARKASCHANGED (fetch REMINDER.NAME of DEF) 'REMINDERS 'CHANGED)) (replace REMINDER.NEXTREMINDDATE of DEF with NEWDATE) (NOTIFY.EVENT \REMINDER.EVENT] (fetch REMINDER.NEXTREMINDDATE of DEF] (if (type? PERIODIC.PROMPT.REMINDER (ARG N 1)) then (ARG N 1) else (GETDEF (ARG N 1) 'REMINDERS NIL '(NOERROR NOCOPY]) (REMINDER.EXPIRATIONDATE [LAMBDA N (* lmm "19-Apr-85 17:26") (* * 1-arg case is only asking for information;  multi-arg for update; 3'rd arg, if non-null, says don't mark as changed.) (PROG (DEF SDATE NEWDATE) (if [OR (NOT (IGEQ N 1)) (NULL (SETQ DEF (if (type? PERIODIC.PROMPT.REMINDER (ARG N 1)) then (ARG N 1) else (GETDEF (ARG N 1) 'REMINDERS NIL '(NOERROR NOCOPY] then (RETURN NIL)) (SETQ SDATE (fetch REMINDER.EXPIRATIONDATE of DEF)) (* Note that SDATE must be either a  STRINGP or NIL) (if (IGREATERP N 1) then [SETQ NEWDATE (OR (STRINGP (ARG N 2)) (GDATE (ARG N 2] (if [AND (NOT (EQUAL (IDATE SDATE) (OR (IDATE NEWDATE) -1))) (OR (ILEQ N 2) (NULL (ARG N 3] then (MARKASCHANGED (fetch REMINDER.NAME of DEF) 'REMINDERS 'CHANGED)) (replace REMINDER.EXPIRATIONDATE of DEF with (SETQ SDATE NEWDATE))) (RETURN SDATE]) (REMINDER.PERIOD [LAMBDA N (* JonL "11-Jun-84 13:49") (AND (IGEQ N 1) ([LAMBDA (DEF PERIOD) (AND (PROG1 DEF (* Comment PPLossage)) ([LAMBDA (PERIOD NEWPERIOD) (if (IEQP N 1) then PERIOD else (OR (IGEQ (SETQ NEWPERIOD (FIX (ARG N 2))) 1) (ERRORX (LIST 27 NEWPERIOD))) (if (NOT (IEQP PERIOD NEWPERIOD)) then (MARKASCHANGED (fetch REMINDER.NAME of DEF) 'REMINDERS 'CHANGED)) (replace REMINDER.PERIOD of DEF with NEWPERIOD] (fetch REMINDER.PERIOD of DEF] (if (type? PERIODIC.PROMPT.REMINDER (ARG N 1)) then (ARG N 1) else (GETDEF (ARG N 1) 'REMINDERS NIL '(NOERROR NOCOPY]) (REMINDERS.RESTART [LAMBDA NIL (* lmm "20-Apr-85 12:32") (DEL.PROCESS 'REMINDERS.WATCHDOG) (OR (FIND.PROCESS 'REMINDERS.WATCHDOG) (ADD.PROCESS '(REMINDERS.WATCHDOG) 'RESTARTABLE 'HARDRESET 'NAME 'REMINDERS.WATCHDOG]) (REMINDERS.WATCHDOG [LAMBDA NIL (* lmm "20-Apr-85 12:15") (bind DELAY do (PERIODICALLYCHECKREMINDERS) (AWAIT.EVENT \REMINDER.EVENT (for PR in PERIODIC.PROMPT.REMINDERS when (\TIMER.TIMERP (fetch REMINDER.TIMEOUTBOX of (CADR PR))) smallest (ALTO.TO.LISP.DATE (fetch REMINDER.TIMEOUTBOX of (CADR PR))) finally (RETURN (if $$EXTREME then (IMIN (ITIMES 30 60 1000) (IMAX 0 (ITIMES 1000 (IDIFFERENCE $$EXTREME (IDATE]) ) (PUTPROPS REMINDER.NEXTREMINDDATE ARGNAMES (REMINDER NEWVALUE)) (PUTPROPS REMINDER.EXPIRATIONDATE ARGNAMES (REMINDER NEWVALUE)) (PUTPROPS REMINDER.PERIOD ARGNAMES (REMINDER NEWVALUE)) (DEFINEQ (\PUTREMINDER [LAMBDA (NAME FILEPKGTYPE DEF) (* lmm "19-Apr-85 17:31") (DECLARE (GLOBALVARS PERIODIC.PROMPT.REMINDERS)) (PROG ((OLDDEF (ASSOC NAME PERIODIC.PROMPT.REMINDERS)) (PERIOD (fetch REMINDER.PERIOD of DEF))) (replace REMINDER.NAME of DEF) (MARKASCHANGED NAME FILEPKGTYPE (if (NULL OLDDEF) then (/SETTOPVAL 'PERIODIC.PROMPT.REMINDERS (CONS (LIST NAME DEF) PERIODIC.PROMPT.REMINDERS)) 'DEFINED elseif (EQUAL (CDDR DEF) (CDDR (CADR OLDDEF))) then (* Blaaag! Notice how the CDDR depends upon PERIODIC.PROMPT.REMINDER being a  TYPERECORD so as to skip checking the REMINDER.TIMEOUTBOX) (RETURN) else (/RPLACA (CDR OLDDEF) DEF) 'CHANGED)) [AND (FIXP PERIOD) (replace REMINDER.TIMEOUTBOX of DEF with (SETUPTIMER PERIOD (fetch REMINDER.TIMEOUTBOX of DEF) 'SECONDS] (NOTIFY.EVENT \REMINDER.EVENT)) NAME]) (\GETREMINDER [LAMBDA (NAME TYPE) (* JonL "21-NOV-82 17:11") (CADR (ASSOC NAME PERIODIC.PROMPT.REMINDERS]) (\DELREMINDER [LAMBDA (NAME FILEPKGTYPE) (* JonL "26-FEB-83 12:24") [if (OR (NULL NAME) (NOT (LITATOM NAME)) (NEQ FILEPKGTYPE 'REMINDERS)) then (ERRORX (LIST 27 (if (EQ FILEPKGTYPE 'REMINDERS) then NAME else FILEPKGTYPE] (PROG ((OLDDEF (ASSOC NAME PERIODIC.PROMPT.REMINDERS))) (if OLDDEF then (MARKASCHANGED NAME FILEPKGTYPE 'DELETED) (/SETTOPVAL 'PERIODIC.PROMPT.REMINDERS (REMOVE OLDDEF PERIODIC.PROMPT.REMINDERS)) (RETURN T]) ) (DEFINEQ (PERIODICALLYCHECKREMINDERS [LAMBDA (RESETP) (* lmm "19-Apr-85 18:28") (RESETLST (SETQ \PR.REMOVALS) [RESETSAVE NIL '(PROGN (MAPC \PR.REMOVALS (FUNCTION (LAMBDA (X) (DELDEF (CAR X) 'REMINDERS] (PROG (ACTED REMINDER Reminder'sTimer Reminmder'sPeriod Reminder'sExpiration MESSAGE FLASHFLG ) [for X in PERIODIC.PROMPT.REMINDERS do (SETQ REMINDER (CADR X)) (if [AND (SETQ Reminder'sExpiration (fetch REMINDER.FINALTIME of REMINDER)) (OR (NOT (\TIMER.TIMERP Reminder'sExpiration)) (TIMEREXPIRED? Reminder'sExpiration 'SECONDS] then (* An expiration date was set, and  he has expired!) (push \PR.REMOVALS X) elseif [OR (NULL (SETQ Reminder'sTimer (fetch REMINDER.TIMEOUTBOX of REMINDER))) (AND Reminder'sTimer (NOT (\TIMER.TIMERP Reminder'sTimer)) (PROG1 T (replace REMINDER.TIMEOUTBOX of REMINDER with (SETQ Reminder'sTimer)))] then (* This guy is just an old "one-shot" reminder which has already fired off, but  is being kept around for the benefit of Denber.wbst) (if (NULL Reminder'sExpiration) then (* If he has a non-null expiration field, then the previous clause will  eventuall delete him.) (push \PR.REMOVALS X)) else (SETQ Reminmder'sPeriod (FIXP (fetch REMINDER.PERIOD of REMINDER))) (if RESETP then (* Reset timers upon startup after SYSOUT or LOGOUT as if the call to  SETUPTIMER were made upon startup) [if Reminmder'sPeriod then (replace REMINDER.TIMEOUTBOX of REMINDER with (SETUPTIMER Reminmder'sPeriod Reminder'sTimer 'SECONDS] elseif (TIMEREXPIRED? Reminder'sTimer 'SECONDS) then (* When a reminder's timer has expired, then flash it at the luser, or "run" it  as a form to be eval'd.) (if Reminmder'sPeriod then (* For periodic reminders, set the next reminder time now, just in case he  quits out of this with a ^D) (replace REMINDER.TIMEOUTBOX of REMINDER with (SETUPTIMER Reminmder'sPeriod Reminder'sTimer 'SECONDS)) elseif (NULL Reminder'sExpiration) then (* After having "fired off" a one-shot reminder, then delete it, unless of  course there is a future expiration date.) (push \PR.REMOVALS X) else (* This is to prevent a  "kept, one-shot" reminder from  firing off continuously.) (replace REMINDER.TIMEOUTBOX of REMINDER with NIL)) (SETQ ACTED T) (SHOW.REMINDER REMINDER) (if Reminmder'sPeriod then (* Make the next reminder timeout  more current.) (replace REMINDER.TIMEOUTBOX of REMINDER with (SETUPTIMER Reminmder'sPeriod Reminder'sTimer 'SECONDS] (AND ACTED CLOSEREMINDERSTREAMFLG (CLOSEW REMINDERSTREAM))))]) ) (RPAQ? \PR.REMOVALS NIL) (RPAQ? DEFAULT.REMINDER.DURATION 60) (RPAQ? DEFAULT.REMINDER.WINKINGDURATION 10) (RPAQ? PERIODIC.PROMPT.REMINDERS NIL) (RPAQ? REMINDERSTREAM PROMPTWINDOW) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PR.REMOVALS REMINDERSTREAM PERIODIC.PROMPT.REMINDERS DEFAULT.REMINDER.DURATION DEFAULT.REMINDER.WINKINGDURATION DEFAULT.REMINDER.PERIOD) ) (PUTDEF (QUOTE REMINDERS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "Periodic PROMPT Reminders" GETDEF \GETREMINDER DELDEF \DELREMINDER PUTDEF \PUTREMINDER))) (RPAQ? CLOSEREMINDERSTREAMFLG ) (RPAQ \REMINDER.EVENT (CREATE.EVENT 'PERIODIC.PROMPT.REMINDERS)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSEREMINDERSTREAMFLG \REMINDER.EVENT) ) (ADDTOVAR AFTERLOGOUTFORMS (REMINDERS.RESTART)) (REMINDERS.RESTART) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA REMINDER.PERIOD REMINDER.EXPIRATIONDATE REMINDER.NEXTREMINDDATE) ) (PUTPROPS PROMPTREMINDERS COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4937 15545 (SETREMINDER 4947 . 7827) (SHOW.REMINDER 7829 . 9670) (ACTIVEREMINDERNAMES 9672 . 9842) (REMINDER.NEXTREMINDDATE 9844 . 11349) (REMINDER.EXPIRATIONDATE 11351 . 13031) ( REMINDER.PERIOD 13033 . 14212) (REMINDERS.RESTART 14214 . 14567) (REMINDERS.WATCHDOG 14569 . 15543)) ( 15745 18507 (\PUTREMINDER 15755 . 17658) (\GETREMINDER 17660 . 17819) (\DELREMINDER 17821 . 18505)) ( 18508 23967 (PERIODICALLYCHECKREMINDERS 18518 . 23965))))) STOP \ No newline at end of file diff --git a/lispusers/PROMPTREMINDERS.TEDIT b/lispusers/PROMPTREMINDERS.TEDIT new file mode 100644 index 00000000..3de1ffa8 Binary files /dev/null and b/lispusers/PROMPTREMINDERS.TEDIT differ diff --git a/lispusers/PROOFREADER b/lispusers/PROOFREADER new file mode 100644 index 00000000..bb20b138 --- /dev/null +++ b/lispusers/PROOFREADER @@ -0,0 +1 @@ +(FILECREATED "13-Oct-87 12:01:34" {QV}TOOLS>PROOFREADER.;34 22618 changes to: (FNS Proofreader.New) previous date: " 6-Feb-87 16:02:15" {QV}TOOLS>PROOFREADER.;33) (* Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT PROOFREADERCOMS) (RPAQQ PROOFREADERCOMS [(FILES ANALYZER SPELLINGARRAY) (FNS Proofreader.New Proofreader.Open Proofreader.AddEntry Proofreader.Lookup Proofreader.AllForms) (FNS Proofreader.CharTable Proofreader.LookupBit Proofreader.SetBit) (FNS Proofreader.Correct Proofreader.NextWord) (MACROS Proofreader.Hash1 Proofreader.Hash2 \Proofreader.TestCorruption) (INITVARS Proofreader Proofreader.AutoLoad Proofreader.Lisp) (* Proofreader.AutoLoad is a file or list of files to be loaded whenever a proofreader is opened.) (P (Analyzer.Establish (SETQ Proofreader (Proofreader.New (QUOTE Proofreader]) (FILESLOAD ANALYZER SPELLINGARRAY) (DEFINEQ (Proofreader.New [LAMBDA (name fileName) (* jtm: "13-Oct-87 11:57") (PROG [(analyzer (create Morphalyzer analyzerName _ name openFn _(FUNCTION Proofreader.Open) lookupFn _(FUNCTION Proofreader.Lookup) addEntryFn _(FUNCTION Proofreader.AddEntry] (RETURN analyzer]) (Proofreader.Open [LAMBDA (analyzer stream) (* jtm: " 6-Feb-87 15:24") (COND ((NULL (fetch (Morphalyzer index) of analyzer)) [replace (Morphalyzer index) of analyzer with (PROG [(file (Analyzer.Prop analyzer (QUOTE FileName] [COND ((AND (NULL SpellingArray) (NULL file)) (ERROR "No Spelling Array for" analyzer)) ((NULL SpellingArray) (COND ((NULL stream) (PROMPTPRINT "initializing Proofreader")) (T (TEDIT.PROMPTPRINT stream "initializing Proofreader" T))) (RESETLST (PROG (LENGTH ALENGTH BLOCK STREAM (START 0) (HEADERSIZE 6)) [RESETSAVE (SETQ STREAM (OPENSTREAM file (QUOTE INPUT) (QUOTE OLD))) (QUOTE (PROGN (CLOSEF OLDVALUE] (SETQ LENGTH (IDIFFERENCE (GETFILEINFO file (QUOTE LENGTH)) (IPLUS HEADERSIZE 2) )) (for i from 1 to HEADERSIZE do (BIN STREAM)) (* skip header) (while (ILESSP START LENGTH) do (SETQ ALENGTH (MIN 64000 (IDIFFERENCE LENGTH START))) (SETQ BLOCK (\ALLOCBLOCK (LRSH (IPLUS 3 ALENGTH) 2))) (\BINS STREAM BLOCK 0 ALENGTH) (add START ALENGTH) (push SpellingArray (CONS START BLOCK))) (SETQ SpellingArray (REVERSE SpellingArray] (RETURN (CONS SpellingArray (Proofreader.CharTable] (for file inside Proofreader.AutoLoad do (Analyzer.DefaultLoadWordList analyzer file]) (Proofreader.AddEntry [LAMBDA (analyzer lemma entry dontRecord) (* jtm: " 6-Feb-87 15:24") (* * adds "lemma" to the SpellingArray. This procedure is just like Lookup, only it sets the bits rather than just  reading them.) (PROG (char p x1 x2 x3 x4 x5 x6 x7 hash1 hash2 hash3 hash4 hash5 hash6 hash7 hashArray hashArray.CharTable start length) (* first save the word on a property list.) (COND ((NULL dontRecord) (Analyzer.PushProp analyzer (QUOTE WordList) lemma))) (SETQ hashArray (fetch (Morphalyzer index) of analyzer)) [COND ((NULL entry) (SETQ entry (Proofreader.AllForms lemma] [COND ((NULL hashArray) (Proofreader.Open analyzer) (SETQ hashArray (fetch (Morphalyzer index) of analyzer] (SETQ hashArray.CharTable (CDR hashArray)) (SETQ hashArray (CAR hashArray)) (SETQ hash1 953) (SETQ hash2 63869) (SETQ hash3 2441) (SETQ hash4 62265) (SETQ hash5 4079) (SETQ hash6 60585) (SETQ hash7 5807) (SETQ p 359) (Stream.Init lemma start length) (while (SETQ char (Stream.NextChar lemma length start)) do [COND ((ALPHACHARP char) (SETQ char (ELT hashArray.CharTable (IDIFFERENCE char 64] (add p 1009) (SETQ x1 (LOGAND 65535 (IDIFFERENCE (LOGXOR char (Proofreader.Hash1 hash2)) p))) [SETQ x2 (LOGAND 65535 (IDIFFERENCE p (IDIFFERENCE (Proofreader.Hash2 hash3) char] [SETQ x3 (LOGAND 65535 (LOGXOR p (IDIFFERENCE (Proofreader.Hash1 hash4) char] (SETQ x4 (LOGAND 65535 (IDIFFERENCE (IDIFFERENCE char (Proofreader.Hash2 hash5)) p))) (SETQ x5 (LOGAND 65535 (IDIFFERENCE (LOGXOR char (Proofreader.Hash1 hash6)) p))) (SETQ x6 (LOGAND 65535 (IDIFFERENCE (IDIFFERENCE (Proofreader.Hash2 hash7) char) p))) [SETQ x7 (LOGAND 65535 (IDIFFERENCE p (IDIFFERENCE (Proofreader.Hash1 hash1) char] (SETQ hash1 x1) (SETQ hash2 x2) (SETQ hash3 x3) (SETQ hash4 x4) (SETQ hash5 x5) (SETQ hash6 x6) (SETQ hash7 x7)) (* * set the bits.) (Proofreader.SetBit hash1 hash7 hashArray) (Proofreader.SetBit hash2 hash6 hashArray) (Proofreader.SetBit hash3 hash5 hashArray) (Proofreader.SetBit hash4 hash4 hashArray) (Proofreader.SetBit hash5 hash3 hashArray) (Proofreader.SetBit hash6 hash2 hashArray) (Proofreader.SetBit hash7 hash1 hashArray) (RETURN lemma]) (Proofreader.Lookup [LAMBDA (analyzer stream start length) (* jtm: " 6-Feb-87 15:25") (* * hashes the string into the array using a probabalistic technique. This may produce a false positive.) (PROG (char word p x1 x2 x3 x4 x5 x6 x7 hash1 hash2 hash3 hash4 hash5 hash6 hash7 hashArray hashArray.CharTable) (SETQ hashArray (fetch (Morphalyzer index) of analyzer)) [COND ((NULL hashArray) (Proofreader.Open analyzer) (SETQ hashArray (fetch (Morphalyzer index) of analyzer] (SETQ hashArray.CharTable (CDR hashArray)) (SETQ hashArray (CAR hashArray)) (SETQ hash1 953) (SETQ hash2 63869) (SETQ hash3 2441) (SETQ hash4 62265) (SETQ hash5 4079) (SETQ hash6 60585) (SETQ hash7 5807) (SETQ p 359) (Stream.Init stream start length) (while (SETQ char (Stream.NextChar stream length start)) do [COND ((IGREATERP char 255) (SETQ char (IMOD char 256] [COND ((ALPHACHARP char) (SETQ char (ELT hashArray.CharTable (IDIFFERENCE char 64] (add p 1009) (SETQ x1 (LOGAND 65535 (IDIFFERENCE (LOGXOR char (Proofreader.Hash1 hash2)) p))) [SETQ x2 (LOGAND 65535 (IDIFFERENCE p (IDIFFERENCE (Proofreader.Hash2 hash3) char] [SETQ x3 (LOGAND 65535 (LOGXOR p (IDIFFERENCE (Proofreader.Hash1 hash4) char] (SETQ x4 (LOGAND 65535 (IDIFFERENCE (IDIFFERENCE char (Proofreader.Hash2 hash5)) p))) (SETQ x5 (LOGAND 65535 (IDIFFERENCE (LOGXOR char (Proofreader.Hash1 hash6)) p))) (SETQ x6 (LOGAND 65535 (IDIFFERENCE (IDIFFERENCE (Proofreader.Hash2 hash7) char) p))) [SETQ x7 (LOGAND 65535 (IDIFFERENCE p (IDIFFERENCE (Proofreader.Hash1 hash1) char] (SETQ hash1 x1) (SETQ hash2 x2) (SETQ hash3 x3) (SETQ hash4 x4) (SETQ hash5 x5) (SETQ hash6 x6) (SETQ hash7 x7)) (COND ((AND (Proofreader.LookupBit hash1 hash7 hashArray) (Proofreader.LookupBit hash2 hash6 hashArray) (Proofreader.LookupBit hash3 hash5 hashArray) (Proofreader.LookupBit hash4 hash4 hashArray) (Proofreader.LookupBit hash5 hash3 hashArray) (Proofreader.LookupBit hash6 hash2 hashArray) (Proofreader.LookupBit hash7 hash1 hashArray)) (RETURN T]) (Proofreader.AllForms [LAMBDA (lemma) (* jtm: " 6-Feb-87 15:25") (* * ask the user for the forms to fill out this word.) (PROG (forms form newForms menuPos) (SETQ forms (LIST (QUOTE NOUN) (QUOTE VERB) (QUOTE ADJ) (English.Suffix lemma "s") (English.Suffix lemma "s") (English.Suffix lemma "er") " " (English.Suffix lemma "ed") (English.Suffix lemma "est") " " (English.Suffix lemma "ing") " " " " (QUOTE *OTHER*))) (while [SETQ form (MENU (create MENU TITLE _ "parts of speech" CENTERFLG _ T ITEMS _ forms MENUCOLUMNS _ 3 CHANGEOFFSETFLG _ T MENUPOSITION _(COND (menuPos) (T (GETMOUSESTATE) (SETQ menuPos (CONS LASTMOUSEX LASTMOUSEY] do (pushnew newForms form)) (RETURN newForms]) ) (DEFINEQ (Proofreader.CharTable [LAMBDA NIL (* jtm: " 6-Feb-87 15:27") (* * comment) (PROG (SpellingArray.CharTable) (SETQ SpellingArray.CharTable (ARRAY 58)) (for i in (QUOTE (0 32)) do (SETA SpellingArray.CharTable (IPLUS i 1) 65325) (SETA SpellingArray.CharTable (IPLUS i 2) 65204) (SETA SpellingArray.CharTable (IPLUS i 3) 449) (SETA SpellingArray.CharTable (IPLUS i 4) 588) (SETA SpellingArray.CharTable (IPLUS i 5) 7102) (SETA SpellingArray.CharTable (IPLUS i 6) 64682) (SETA SpellingArray.CharTable (IPLUS i 7) 64545) (SETA SpellingArray.CharTable (IPLUS i 8) 64418) (SETA SpellingArray.CharTable (IPLUS i 9) 1278) (SETA SpellingArray.CharTable (IPLUS i 10) 1433) (SETA SpellingArray.CharTable (IPLUS i 11) 63968) (SETA SpellingArray.CharTable (IPLUS i 12) 63827) (SETA SpellingArray.CharTable (IPLUS i 13) 1874) (SETA SpellingArray.CharTable (IPLUS i 14) 2027) (SETA SpellingArray.CharTable (IPLUS i 15) 2180) (SETA SpellingArray.CharTable (IPLUS i 16) 63195) (SETA SpellingArray.CharTable (IPLUS i 17) 63058) (SETA SpellingArray.CharTable (IPLUS i 18) 62865) (SETA SpellingArray.CharTable (IPLUS i 19) 2798) (SETA SpellingArray.CharTable (IPLUS i 20) 2963) (SETA SpellingArray.CharTable (IPLUS i 21) 62372) (SETA SpellingArray.CharTable (IPLUS i 22) 62216) (SETA SpellingArray.CharTable (IPLUS i 23) 62067) (SETA SpellingArray.CharTable (IPLUS i 24) 3624) (SETA SpellingArray.CharTable (IPLUS i 25) 3793) (SETA SpellingArray.CharTable (IPLUS i 26) 3944)) (RETURN SpellingArray.CharTable]) (Proofreader.LookupBit [LAMBDA (row column SpellingArray) (* jtm: " 6-Feb-87 15:27") (* * There are 4096 bits per row, but only 4093 of them are used.) (PROG (byte (startByte 0)) (SETQ row (IMOD row 199)) (SETQ column (IMOD column 4093)) (SETQ byte (IPLUS (LLSH row 9) (LRSH column 3))) (for block in SpellingArray do (COND ((ILESSP byte (CAR block)) (SETQ byte (\GETBASEBYTE (CDR block) (IDIFFERENCE byte startByte))) (RETURN))) (SETQ startByte (CAR block))) (RETURN (BITTEST byte (MASK.1'S (IDIFFERENCE 7 (LOGAND column 7)) 1]) (Proofreader.SetBit [LAMBDA (row column SpellingArray) (* jtm: " 6-Feb-87 15:28") (* * There are 4096 bits per row, but only 4093 of them are used.) (PROG (address (startByte 0)) (SETQ row (IMOD row 199)) (SETQ column (IMOD column 4093)) (SETQ address (IPLUS (LLSH row 9) (LRSH column 3))) (for block byte in SpellingArray do (COND ((ILESSP address (CAR block)) (SETQ byte (\GETBASEBYTE (CDR block) (IDIFFERENCE address startByte))) (SETQ byte (BITSET byte (MASK.1'S (IDIFFERENCE 7 (LOGAND column 7)) 1))) (\PUTBASEBYTE (CDR block) (IDIFFERENCE address startByte) byte) (RETURN))) (SETQ startByte (CAR block]) ) (DEFINEQ (Proofreader.Correct [LAMBDA (analyzer stream start length) (* jtm: " 6-Feb-87 15:28") (* * returns a list of possible spelling corrections for the given word.) (PROG (form word wordList caps periods) [COND ((NOT (LISTP stream)) (SETFILEPTR stream start) (SETQ word (for i from 1 to length collect (READC stream] (SETQ caps (Analyzer.Capitalization word)) (SETQ periods (FMEMB (QUOTE %.) word)) (* * first try transpositions) (for tail temp on word while (CDR tail) do (SETQ temp (CAR tail)) (RPLACA tail (CADR tail)) (RPLACA (CDR tail) temp) (COND ((AND (EQ caps (QUOTE FIRST)) (EQ tail word)) (* don't transpose the first letters of a capitalized  word.) NIL) (T (\Proofreader.TestCorruption analyzer word wordList))) (RPLACA (CDR tail) (CAR tail)) (RPLACA tail temp)) (* * next try deletions) (COND ((CDR word) (\Proofreader.TestCorruption analyzer (CDR word) wordList))) (for tail temp on word while (CDR tail) do (SETQ temp (CDR tail)) (RPLACD tail (CDDR tail)) (\Proofreader.TestCorruption analyzer word wordList) (RPLACD tail temp)) (* * prepend a character.) (SETQ word (CONS (QUOTE A) word)) (SELECTQ caps (FIRST (* don't prepend a character before a capitalized  word.) NIL) (ALL (* prepend a capital letter.) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA word (CHARACTER c)) (\Proofreader.TestCorruption analyzer word wordList))) (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA word (CHARACTER c)) (\Proofreader.TestCorruption analyzer word wordList))) (SETQ word (CDR word)) (* * insert characters.) (for tail on word do (RPLACD tail (CONS (QUOTE A) (CDR tail))) [COND ((EQ caps (QUOTE ALL)) (for c from (CHARCODE A) to (CHARCODE Z) do (RPLACA (CDR tail) (CHARACTER c)) (\Proofreader.TestCorruption analyzer word wordList))) (T (for c from (CHARCODE a) to (CHARCODE z) do (RPLACA (CDR tail) (CHARACTER c)) (\Proofreader.TestCorruption analyzer word wordList] (COND (periods (RPLACA (CDR tail) (QUOTE %.)) (\Proofreader.TestCorruption analyzer word wordList))) (RPLACD tail (CDDR tail))) (* * replace characters) (for tail temp on word do (SETQ temp (CAR tail)) [COND ((OR (EQ caps (QUOTE ALL)) (AND (EQ caps (QUOTE FIRST)) (EQ tail word))) (for c from (CHARCODE A) to (CHARCODE Z) do (COND ((NEQ temp (CHARACTER c)) (RPLACA tail (CHARACTER c)) (\Proofreader.TestCorruption analyzer word wordList] [COND ((OR (EQ caps NIL) (NOT (ALPHACHARP (CHCON1 temp))) (AND (EQ caps (QUOTE FIRST)) (NEQ tail word))) (for c from (CHARCODE a) to (CHARCODE z) do (COND ((NEQ temp (CHARACTER c)) (RPLACA tail (CHARACTER c)) (\Proofreader.TestCorruption analyzer word wordList] (COND (periods (RPLACA tail (QUOTE %.)) (\Proofreader.TestCorruption analyzer word wordList))) (RPLACA tail temp)) (SETQ wordList (SORT wordList)) [for i on wordList do (while (STREQUAL (CAR i) (CADR i)) do (RPLACD i (CDDR i] (RETURN wordList]) (Proofreader.NextWord [LAMBDA (analyzer stream startPtr searchLength NWFn) (* jtm: " 6-Feb-87 15:29") (* * Scans the stream looking for a word, i.e. a sequence of alphabetic charqacters. If the file ptr is already in  the middle of such a sequence, it backs up to the beginning of that sequence. The function applies NWFn to  (stream start stop) for each such word.) (SETFILEPTR stream (OR startPtr (SETQ startPtr 0))) (bind char end endPtr word length start value quote period number (filePtr _(GETFILEPTR stream)) (EOFPtr _(GETEOFPTR stream)) first (SETQ endPtr (COND (searchLength (IMIN EOFPtr (IPLUS startPtr searchLength))) (T EOFPtr))) do (SETQ char (AND (ILESSP (GETFILEPTR stream) endPtr) (BIN stream))) (COND [(AND char (AND (NUMBERP char) (ILESSP char 128) (Analyzer.AlphaCharP char))) [OR start (SETQ start (SUB1 (GETFILEPTR stream] (COND (number (* we have a number followed by some characters. (e.g. 7th, 21st, etc.) Take in the last digit of the  number.) (add start -1) (SETQ number NIL))) (COND (quote (COND ((EQ quote T) (* don't make a list until you need to.) (SETQ quote NIL))) (push quote char))) (COND (period (COND ((EQ period T) (SETQ period NIL))) (push period char] ((AND start char (EQUAL char (CHARCODE '))) (* if the quote is in the middle of a word, leave it  in.) (SETQ quote T)) ((AND start char (EQUAL char (CHARCODE %.))) (* look for e.g., i.e.) (OR period (SETQ period T))) (start (SETQ end (GETFILEPTR stream)) (SETQ length (IDIFFERENCE end start)) (AND char (add length -1)) (* back up to the last legal char.) (COND ((EQ quote T) (* delete final quotes) (add length -1)) ([OR (EQUAL quote (QUOTE (115))) (EQUAL quote (QUOTE (83] (* delete 's) (add length -2))) (SETQ quote NIL) (COND ((EQ period T) (* delete final periods) (add length -1))) (SETQ period NIL) (COND ((AND (EQ length 1) (EQ char (CHARCODE %)))) (* letters used for outlines.) (add length 1))) [COND [NWFn (SETQ value (APPLY* NWFn analyzer stream start length)) (COND ((EQ value T) (RETURN (CONS start length))) (value (RETURN value] (T (RETURN (CONS start length] (SETFILEPTR stream end) (SETQ start NIL)) ((AND char (NUMBERP char) (IGEQ char 48) (ILEQ char 57)) (* a number) (SETQ number char)) (T (SETQ number NIL))) (OR char (RETURN]) ) (DECLARE: EVAL@COMPILE (PUTPROPS Proofreader.Hash1 MACRO ((X) (IPLUS (LLSH (LOGAND X 2047) 5) (LRSH X 11)))) (PUTPROPS Proofreader.Hash2 MACRO ((X) (IPLUS (LLSH (LOGAND X 8191) 3) (LRSH X 13)))) (PUTPROPS \Proofreader.TestCorruption MACRO [(analyzer word wordList) (COND ((Proofreader.Lookup analyzer word NIL NIL) (push wordList (CONCATLIST word]) ) (RPAQ? Proofreader NIL) (RPAQ? Proofreader.AutoLoad NIL) (RPAQ? Proofreader.Lisp NIL) (* Proofreader.AutoLoad is a file or list of files to be loaded whenever a proofreader is opened.) [Analyzer.Establish (SETQ Proofreader (Proofreader.New (QUOTE Proofreader] (PUTPROPS PROOFREADER COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (1007 10101 (Proofreader.New 1017 . 1378) (Proofreader.Open 1380 . 3320) ( Proofreader.AddEntry 3322 . 6312) (Proofreader.Lookup 6314 . 9110) (Proofreader.AllForms 9112 . 10099) ) (10102 13915 (Proofreader.CharTable 10112 . 12273) (Proofreader.LookupBit 12275 . 13040) ( Proofreader.SetBit 13042 . 13913)) (13916 21770 (Proofreader.Correct 13926 . 18270) ( Proofreader.NextWord 18272 . 21768))))) STOP \ No newline at end of file diff --git a/lispusers/PROOFREADER.TEDIT b/lispusers/PROOFREADER.TEDIT new file mode 100644 index 00000000..83120495 Binary files /dev/null and b/lispusers/PROOFREADER.TEDIT differ diff --git a/lispusers/PS-PATCH b/lispusers/PS-PATCH new file mode 100644 index 00000000..2efe322b --- /dev/null +++ b/lispusers/PS-PATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 8-Nov-90 18:53:15" |{PELE:MV:ENVOS}MEDLEY>POSTSCRIPT>PS-PATCH.;2| 24907 changes to%: (VARS PS-PATCHCOMS) (PROPS (PS-PATCH MAKEFILE-ENVIRONMENT)) (FNS FIX-SKETCH) previous date%: "22-Feb-89 14:11:29" |{PELE:MV:ENVOS}MEDLEY>POSTSCRIPT>PS-PATCH.;1| ) (* ; " Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved. ") (PRETTYCOMPRINT PS-PATCHCOMS) (RPAQQ PS-PATCHCOMS ((PROP (MAKEFILE-ENVIRONMENT FILETYPE) PS-PATCH) (FNS ADD.KNOWN.SKETCH.FONT NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST NEW-SKETCHW-HARDCOPYFN FIX-SKETCH) [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT) (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN] (* ;;  "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded.") (FNS \BUILDSLUGCSINFO \CREATECHARSET) (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) (TIMESROMAND . TIMESROMAN) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMESROMAN) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (MODERN . HELVETICA))) (VARS (\KNOWN.SKETCH.FONTSIZES)) (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) POSTSCRIPT.FONT.CONVERSIONS) (* ;; "finally actually do the patching of sketch.") (P (FIX-SKETCH)))) (PUTPROPS PS-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 )) (PUTPROPS PS-PATCH FILETYPE :TCOMPL) (DEFINEQ (ADD.KNOWN.SKETCH.FONT [LAMBDA (FAMILY WID DEVICE FONT) (* ; "Edited 21-Feb-89 15:06 by snow") (* ;; "add to the globally cached font list") (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES)) (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES)) (CACHED)) (COND [(NULL CACHE) (if \KNOWN.SKETCH.FONTSIZES then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT] else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE (CONS WID FONT] (T (COND ((SETQ CACHED (ASSOC DEVICE CACHE)) (NCONC1 CACHED (CONS WID FONT))) (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT]) (NEW-SK-PICK-FONT [LAMBDA (WID STRING DEVICE FAMILY) (* ; "Edited 22-Feb-89 07:53 by snow") (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide") (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES)) (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT) (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES] THEN (RETURN (CDR CACHEDFONT))) (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE) when (NOT (GREATERP [SETQ LASTSIZE (COND ((SETQ SCALE (FONTPROP FONT 'SCALE)) (* ;;  "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.") (QUOTIENT (STRINGWIDTH STRING FONT) SCALE)) ((SETQ DISPLAYFONT (FONTCOPY (SETQ LASTFONT FONT) 'DEVICE 'DISPLAY 'NOERROR T)) (* ; "use display if it exists.") (STRINGWIDTH STRING DISPLAYFONT)) (T (* ;  "in some cases, font exists for devices other than display.") (QUOTIENT (STRINGWIDTH STRING FONT) (FONTPROP FONT 'SCALE] WID)) do (* ;  "return a font for the proper device even though the display fonts are used to pick a size.") (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE (FONTCOPY FONT 'DEVICE DEVICE)) (RETURN (FONTCOPY FONT 'DEVICE DEVICE)) finally (RETURN (COND ((OR (NULL LASTFONT) (GREATERP LASTSIZE (TIMES 1.5 WID))) 'SHADE) (T (* ;  "use the smallest if it isn't too large.") (FONTCOPY LASTFONT 'DEVICE DEVICE]) (NEW-SK-DECREASING-FONT-LIST [LAMBDA (FAMILY DEVICETYPE) (* ; "Edited 21-Feb-89 11:26 by snow") (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE") [COND ((NULL FAMILY) (SETQ FAMILY 'MODERN] (* ;; "convert to families that exist on the known devices.") (* ;;; "NOTE: this is a very bad way to convert the family. It HARDCODES in the conversions for PRESS and INTERPRESS and does nothing for new device types. I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.) --was 2/19/89") (LET ((CONVERSION)) [COND [(EQ DEVICETYPE 'PRESS) (COND ((EQ FAMILY 'MODERN) (SETQ FAMILY 'HELVETICA)) ((EQ FAMILY 'CLASSIC) (SETQ FAMILY 'TIMESROMAN)) ((EQ FAMILY 'TERMINAL) (SETQ FAMILY 'GACHA] [(EQ DEVICETYPE 'INTERPRESS) (COND ((EQ FAMILY 'HELVETICA) (SETQ FAMILY 'MODERN)) ((EQ FAMILY 'TIMESROMAN) (SETQ FAMILY 'CLASSIC)) ((EQ FAMILY 'GACHA) (SETQ FAMILY 'TERMINAL] ((EQ DEVICETYPE 'POSTSCRIPT) (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS)) then (* ;;  "convert the family here for postscript as well as the other well known devices.") (SETQ FAMILY (CDR CONVERSION] (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE) collect (FONTCOPY FONT 'DEVICE DEVICETYPE]) (NEW-SKETCHW-HARDCOPYFN [LAMBDA (SKETCHW OPENIMAGESTREAM) (* ; "Edited 22-Feb-89 13:34 by snow") (* ;  "dumps the sketch onto OPENIMAGESTREAM.") (* ;  "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM") (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM)) (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW)) (SCALE (VIEWER.SCALE SKETCHW)) SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX) (OR SKETCH (RETURN)) (SPAWN.MOUSE) (* ;; "move the margins out of the way") (* ;;  "smallp is to maintain compatibility with koto. For Lute release, this could be increased.") (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION)) OPENIMAGESTREAM) (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION)) OPENIMAGESTREAM) (DSPTOPMARGIN (MAX MAX.SMALLP (fetch (REGION TOP) of PAGEREGION)) OPENIMAGESTREAM) (DSPRIGHTMARGIN (MAX MAX.SMALLP (fetch (REGION RIGHT) of PAGEREGION)) OPENIMAGESTREAM) (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.") (STATUSPRINT SKETCHW "Hardcopying ...") [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE SKETCHW) "A Sketch")) (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS] (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM))) (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR)) (COND ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM) 'PRESS)) (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS) OF OPENIMAGESTREAM)) 'NILL)) (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) (fetch WIDTH of PAGEREGION)) (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) (fetch HEIGHT of SKETCHREGIONINPAGECOORDS))) (* ;; "we ;have a stream that supports rotation, use it!") (DSPROTATE 90 OPENIMAGESTREAM) (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION)) OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM) (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)") (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big. Now it tries to do it on any stream that has a dsprotate function.") )) (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS )) 2)) (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS )) 2)) (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.") [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE (SETQ PAGELEFTSPACE (PLUS (fetch (REGION LEFT) of PAGEREGION) PAGELEFTSPACE)) (fetch (REGION LEFT) of SKETCHREGIONINPAGECOORDS )) PAGETOSKETCHFACTOR)) (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE (PLUS (fetch (REGION BOTTOM) of PAGEREGION) PAGEBOTTOMSPACE)) (fetch (REGION BOTTOM) of SKETCHREGIONINPAGECOORDS )) PAGETOSKETCHFACTOR] (* ;  "calculate the local parts for the interpress sketch.") (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE PAGETOSKETCHFACTOR) (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR) (fetch (REGION WIDTH) of SKETCHREGION ) (fetch (REGION HEIGHT) of SKETCHREGION )) PAGETOSKETCHFACTOR OPENIMAGESTREAM)) (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS ) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS ))) (STATUSPRINT SKETCHW " done.") (RETURN OPENIMAGESTREAM]) (FIX-SKETCH [LAMBDA NIL (* ; "Edited 8-Nov-90 16:32 by jds") (COND ((BOUNDP 'ALL.SKETCHES) (* ;; "sketch is loaded") (for PATCHED-FN in '(NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST NEW-SKETCHW-HARDCOPYFN) as ORIGINAL-FN in '(SK.PICK.FONT SK.DECREASING.FONT.LIST SKETCHW.HARDCOPYFN) do (MOVD PATCHED-FN ORIGINAL-FN NIL T)) (PROMPTPRINT "Sketch has been patched!") T) (T (PROMPTPRINT "Sketch doesn't seem to be loaded!") (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!") NIL]) ) (RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT) (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN))) (* ;; "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded." ) (DEFINEQ (\BUILDSLUGCSINFO [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 14-Feb-89 16:46 by snow") (* ;;; "builds a csinfo which contains only the slug (black rectangle) character") (SETQ SCALE (OR SCALE 1)) (PROG ((CSINFO (create CHARSETINFO CHARSETASCENT _ ASCENT CHARSETDESCENT _ DESCENT IMAGEWIDTHS _ (\CREATECSINFOELEMENT))) WIDTHS OFFSETS BITMAP IMAGEWIDTHS) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) [SELECTQ DEVICE (INTERPRESS (* ;  "don't need offsets in INTERPRESS fonts") NIL) (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS ( \CREATECSINFOELEMENT ))) (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) [replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) (ROUND (QUOTIENT (IPLUS ASCENT DESCENT) SCALE] (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] (RETURN CSINFO]) (\CREATECHARSET [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 14-Feb-89 16:29 by snow") (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") (* ;  "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) (AND (IGREATERP CHARSET \MAXCHARSET) (\ILLEGAL.ARG CHARSET)) (PROG (CSINFO CREATEFN) (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.") (if (OR (AND (IGEQ CHARSET 1) (ILEQ CHARSET 32)) (AND (IGEQ CHARSET 127) (ILEQ CHARSET 160))) then (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG? is T)") [if NOSLUG? then (RETURN NIL) else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT) (FONTPROP FONT 'ASCENT) (FONTPROP FONT 'DESCENT) (FONTPROP FONT 'DEVICE) (FONTPROP FONT 'SCALE] else [SETQ CREATEFN (COND ((FMEMB (FONTPROP FONT 'DEVICE) \DISPLAYSTREAMTYPES) (FUNCTION \CREATECHARSET.DISPLAY)) (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT 'DEVICE) IMAGESTREAMTYPES] [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC) (LIST CHARSET FONT NOSLUG?] then (* ;  "the create method returned NIL. so if NOSLUG? return NIL else build a slug charsetinfo") (RETURN (if NOSLUG? then (* ;  "the caller just wants NIL back to signal that nothing was found") NIL else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT) (FONTPROP FONT 'ASCENT) (FONTPROP FONT 'HEIGHT) (FONTPROP FONT 'DEVICE) (FONTPROP FONT 'SCALE] (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT) (fetch CHARSETASCENT of CSINFO))) (replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT) (ffetch CHARSETDESCENT of CSINFO))) (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent of FONT) (ffetch \SFDescent of FONT))) (* ;  "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") ) (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT) CHARSET CSINFO]) ) (ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) (TIMESROMAND . TIMESROMAN) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMESROMAN) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (MODERN . HELVETICA)) (RPAQQ \KNOWN.SKETCH.FONTSIZES NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) POSTSCRIPT.FONT.CONVERSIONS) ) (* ;; "finally actually do the patching of sketch.") (FIX-SKETCH) (PUTPROPS PS-PATCH COPYRIGHT ("ENVOS Corporation" 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2086 16850 (ADD.KNOWN.SKETCH.FONT 2096 . 2973) (NEW-SK-PICK-FONT 2975 . 6357) ( NEW-SK-DECREASING-FONT-LIST 6359 . 8183) (NEW-SKETCHW-HARDCOPYFN 8185 . 16115) (FIX-SKETCH 16117 . 16848)) (17182 23954 (\BUILDSLUGCSINFO 17192 . 19090) (\CREATECHARSET 19092 . 23952))))) STOP \ No newline at end of file diff --git a/lispusers/PS-RS232 b/lispusers/PS-RS232 new file mode 100644 index 00000000..5749b1fa --- /dev/null +++ b/lispusers/PS-RS232 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 2-Aug-89 13:35:49" {DSK}PS>PS-RS232.;1 2639 changes to%: (VARS PS-RS232COMS) (PROPS (PS-RS232 MAKEFILE-ENVIRONMENT) (PS-RS232 PRINTERTYPE) (PS-RS232 SPOOLFILE)) (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT)) (* " Copyright (c) 1989 by Beckman Instruments, Inc. All rights reserved. ") (PRETTYCOMPRINT PS-RS232COMS) (RPAQQ PS-RS232COMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS) DLRS232C) (INITVARS (PS-RS232-BAUD 9600) (PS-RS232-DATABITS 8) (PS-RS232-PARITY 'NONE) (PS-RS232-STOPBITS 1) (PS-RS232-FLOWCONTROL 'XOnXOff)) (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT) (ADDVARS (DEFAULTPRINTINGHOST PS-RS232) (AROUNDEXITFNS PS-RS232-AFTERLOGOUT)) (P (PS-RS232-INIT)) (PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE) PS-RS232))) (FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS) DLRS232C) (RPAQ? PS-RS232-BAUD 9600) (RPAQ? PS-RS232-DATABITS 8) (RPAQ? PS-RS232-PARITY 'NONE) (RPAQ? PS-RS232-STOPBITS 1) (RPAQ? PS-RS232-FLOWCONTROL 'XOnXOff) (DEFINEQ (PS-RS232-AFTERLOGOUT [LAMBDA (EVENT) (if (EQ EVENT 'AFTERLOGOUT) then (RS232C.INIT PS-RS232-BAUD PS-RS232-DATABITS PS-RS232-PARITY PS-RS232-STOPBITS PS-RS232-FLOWCONTROL]) (PS-RS232-INIT [LAMBDA NIL [PUTPROP 'PS-RS232 'SPOOLOPTIONS `((BaudRate ,PS-RS232-BAUD) (BitsPerSerialChar ,PS-RS232-DATABITS) (Parity ,PS-RS232-PARITY) (NoOfStopBits ,PS-RS232-STOPBITS) (FlowControl ,PS-RS232-FLOWCONTROL] (PS-RS232-AFTERLOGOUT 'AFTERLOGOUT) (* ; "Fake it") NIL]) ) (ADDTOVAR DEFAULTPRINTINGHOST PS-RS232) (ADDTOVAR AROUNDEXITFNS PS-RS232-AFTERLOGOUT) (PS-RS232-INIT) (PUTPROPS PS-RS232 MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS PS-RS232 PRINTERTYPE POSTSCRIPT) (PUTPROPS PS-RS232 SPOOLFILE "{RS232}FOO.PS") (PUTPROPS PS-RS232 COPYRIGHT ("Beckman Instruments, Inc" 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1528 2244 (PS-RS232-AFTERLOGOUT 1538 . 1761) (PS-RS232-INIT 1763 . 2242))))) STOP \ No newline at end of file diff --git a/lispusers/PS-RS232.TEDIT b/lispusers/PS-RS232.TEDIT new file mode 100644 index 00000000..dcc1d6ae Binary files /dev/null and b/lispusers/PS-RS232.TEDIT differ diff --git a/lispusers/PS-SEND b/lispusers/PS-SEND new file mode 100644 index 00000000..aff039ac --- /dev/null +++ b/lispusers/PS-SEND @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED " 2-Aug-89 13:02:26" {DSK}PS>PS-SEND.;9 5519 changes to%: (VARS PS-SENDCOMS) (PROPS (PS-SEND MAKEFILE-ENVIRONMENT)) previous date%: "27-Jan-89 12:09:04" {DSK}PS>PS-SEND.;8) (* " Copyright (c) 1988, 1989 by Beckman Instruments, Inc. All rights reserved. ") (PRETTYCOMPRINT PS-SENDCOMS) (RPAQQ PS-SENDCOMS ((FNS POSTSCRIPT.SEND SUN.PS.SEND) [P (* ;; " %"load the unixcomm software if you are on a sun.") (IF (EQ (MACHINETYPE) 'MAIKO) THEN (FILESLOAD 'UNIXCOMM] (PROP (FILETYPE MAKEFILE-ENVIRONMENT) PS-SEND))) (DEFINEQ (POSTSCRIPT.SEND [LAMBDA (HOST FILE PRINTOPTIONS) (* ; "Edited 27-Jan-89 10:53 by Matt Heffron") (if (EQ (MACHINETYPE) 'MAIKO) then (* ;; "Sun code compliments of Will Snow @ Envos.") (* ;; "we're on a SUN, let's print this file as directly as possible.") (SUN.PS.SEND HOST FILE PRINTOPTIONS) else [OR HOST (SETQ HOST (CAR (MKLIST DEFAULTPRINTINGHOST] (if (LISTP HOST) then (SETQ HOST (CADR HOST))) (LET* ([INFILE (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T] (SPOOLDIRECTORY (GETPROP HOST 'SPOOLDIRECTORY)) (SPOOLFILE (GETPROP HOST 'SPOOLFILE)) (SPOOLOPTIONS (GETPROP HOST 'SPOOLOPTIONS)) (OUTFILE (if SPOOLFILE then (OPENSTREAM SPOOLFILE 'OUTPUT NIL (APPEND '((TYPE TEXT) (SEQUENTIAL T)) SPOOLOPTIONS)) elseif SPOOLDIRECTORY then (OPENSTREAM (CONCAT SPOOLDIRECTORY (GENSYM USERNAME) ".PS") 'OUTPUT NIL (APPEND '((TYPE TEXT) (SEQUENTIAL T)) SPOOLOPTIONS)) else (CL:ERROR "~&Don't know how to send to: ~S" HOST))) (PRETTYDEST (if (OR SPOOLFILE SPOOLDIRECTORY) then (CONCAT (FULLNAME OUTFILE) " (" HOST ")") else HOST))) (if OUTFILE then (printout PROMPTWINDOW "[Sending " FILE " to " PRETTYDEST "...]" T) (LET [(POSTSCRIPTSTRING (LISTGET PRINTOPTIONS 'POSTSCRIPT.CONTROL.STRING] (PRIN1 (GET HOST 'HOST.CONTROL.STRING "") OUTFILE) (if POSTSCRIPTSTRING then (PRIN1 (CL:READ-LINE INFILE) OUTFILE) (TERPRI OUTFILE) (PRIN1 POSTSCRIPTSTRING OUTFILE))) (COPYBYTES INFILE OUTFILE) (CLOSEF INFILE) (PRIN1 (GET HOST 'HOST.CONTROL.AFTER.STRING "") OUTFILE) (CLOSEF OUTFILE) (printout PROMPTWINDOW "[Finished sending " FILE " to " PRETTYDEST ".]" T ) else (printout PROMPTWINDOW "[Unable to send " FILE " to " PRETTYDEST ".]" T]) (SUN.PS.SEND [LAMBDA (HOST FILE PRINTOPTIONS) (* ; "Edited 30-Dec-88 18:59 by demo") (* ;; "print a postscript file when you're on a sun. The printoptions get dropped for now.") [IF (NULL HOST) THEN (SETQ HOST (OR DEFAULTPRINTINGHOST (UNIX-GETENV "PRINTER"] (IF (LISTP HOST) THEN (SETQ HOST (CAR HOST))) (CL:UNLESS (STRINGP HOST) (L-CASE (MKSTRING HOST))) (* ;; "now we have a %"real%" host name for the printer") (CL:WITH-OPEN-STREAM [INSTREAM (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T] (CL:WITH-OPEN-STREAM (OUTSTREAM (CREATE-PROCESS-STREAM (CONCAT "/usr/ucb/lpr -P" HOST))) (PRINTOUT PROMPTWINDOW "[Sending " FILE " to " HOST "...]" T) (COPYBYTES INSTREAM OUTSTREAM) (PRINTOUT PROMPTWINDOW "[Finished sending " FILE " to " HOST ".]" T]) ) (* ;; " %"load the unixcomm software if you are on a sun.") (IF (EQ (MACHINETYPE) 'MAIKO) THEN (FILESLOAD 'UNIXCOMM)) (PUTPROPS PS-SEND FILETYPE :TCOMPL) (PUTPROPS PS-SEND MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (PUTPROPS PS-SEND COPYRIGHT ("Beckman Instruments, Inc" 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (894 5146 (POSTSCRIPT.SEND 904 . 4146) (SUN.PS.SEND 4148 . 5144))))) STOP \ No newline at end of file diff --git a/lispusers/PS-SEND.TEDIT b/lispusers/PS-SEND.TEDIT new file mode 100644 index 00000000..7ba8e008 Binary files /dev/null and b/lispusers/PS-SEND.TEDIT differ diff --git a/lispusers/PS-SKETCH-PATCH b/lispusers/PS-SKETCH-PATCH new file mode 100644 index 00000000..9e713a97 --- /dev/null +++ b/lispusers/PS-SKETCH-PATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED " 4-Aug-89 16:46:48" {DSK}LIBRARY>PS-SKETCH-PATCH.;1 25983 changes to%: (VARS PS-SKETCH-PATCHCOMS) (PROPS (PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT)) (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN \BUILDSLUGCSINFO \CREATECHARSET)) (* " Copyright (c) 1989 by ENVOS Corporation. All rights reserved. ") (PRETTYCOMPRINT PS-SKETCH-PATCHCOMS) (RPAQQ PS-SKETCH-PATCHCOMS ((FILES (SYSLOAD FROM LISPUSERS) SKETCH) (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN) (* ;;  "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.") (FNS \BUILDSLUGCSINFO \CREATECHARSET) [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT) (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN] (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) (TIMESROMAND . TIMESROMAN) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMESROMAN) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (MODERN . HELVETICA))) (VARS (\KNOWN.SKETCH.FONTSIZES)) (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) POSTSCRIPT.FONT.CONVERSIONS) (* ;; "finally actually do the patching of sketch.") (P (FIX-SKETCH)) (PROP (MAKEFILE-ENVIRONMENT FILETYPE) PS-SKETCH-PATCH))) (FILESLOAD (SYSLOAD FROM LISPUSERS) SKETCH) (DEFINEQ (FIX-SKETCH [LAMBDA NIL (* ; "Edited 7-Jul-89 19:40 by Matt Heffron") (COND ((BOUNDP 'ALL.SKETCHES) (* ;; "sketch is loaded") (for X in SKETCH-PATCHES do (MOVD (CAR X) (CDR X) NIL T)) (PROMPTPRINT "Sketch has been patched!") T) (T (PROMPTPRINT "Sketch doesn't seem to be loaded!") (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!") NIL]) (ADD.KNOWN.SKETCH.FONT [LAMBDA (FAMILY WID DEVICE FONT) (* ; "Edited 21-Feb-89 15:06 by snow") (* ;; "add to the globally cached font list") (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES)) (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES)) (CACHED)) (COND [(NULL CACHE) (if \KNOWN.SKETCH.FONTSIZES then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT] else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE (CONS WID FONT] (T (COND ((SETQ CACHED (ASSOC DEVICE CACHE)) (NCONC1 CACHED (CONS WID FONT))) (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT]) (NEW-SK-DECREASING-FONT-LIST [LAMBDA (FAMILY DEVICETYPE) (* ; "Edited 21-Feb-89 11:26 by snow") (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE") [COND ((NULL FAMILY) (SETQ FAMILY 'MODERN] (* ;; "convert to families that exist on the known devices.") (* ;;; "NOTE: this is a very bad way to convert the family. It HARDCODES in the conversions for PRESS and INTERPRESS and does nothing for new device types. I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.) --was 2/19/89") (LET ((CONVERSION)) [COND [(EQ DEVICETYPE 'PRESS) (COND ((EQ FAMILY 'MODERN) (SETQ FAMILY 'HELVETICA)) ((EQ FAMILY 'CLASSIC) (SETQ FAMILY 'TIMESROMAN)) ((EQ FAMILY 'TERMINAL) (SETQ FAMILY 'GACHA] [(EQ DEVICETYPE 'INTERPRESS) (COND ((EQ FAMILY 'HELVETICA) (SETQ FAMILY 'MODERN)) ((EQ FAMILY 'TIMESROMAN) (SETQ FAMILY 'CLASSIC)) ((EQ FAMILY 'GACHA) (SETQ FAMILY 'TERMINAL] ((EQ DEVICETYPE 'POSTSCRIPT) (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS)) then (* ;;  "convert the family here for postscript as well as the other well known devices.") (SETQ FAMILY (CDR CONVERSION] (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE) collect (FONTCOPY FONT 'DEVICE DEVICETYPE]) (NEW-SK-PICK-FONT [LAMBDA (WID STRING DEVICE FAMILY) (* ; "Edited 22-Feb-89 07:53 by snow") (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide") (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES)) (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT) (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES] THEN (RETURN (CDR CACHEDFONT))) (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE) when (NOT (GREATERP [SETQ LASTSIZE (COND ((SETQ SCALE (FONTPROP FONT 'SCALE)) (* ;;  "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.") (QUOTIENT (STRINGWIDTH STRING FONT) SCALE)) ((SETQ DISPLAYFONT (FONTCOPY (SETQ LASTFONT FONT) 'DEVICE 'DISPLAY 'NOERROR T)) (* ; "use display if it exists.") (STRINGWIDTH STRING DISPLAYFONT)) (T (* ;  "in some cases, font exists for devices other than display.") (QUOTIENT (STRINGWIDTH STRING FONT) (FONTPROP FONT 'SCALE] WID)) do (* ;  "return a font for the proper device even though the display fonts are used to pick a size.") (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE (FONTCOPY FONT 'DEVICE DEVICE)) (RETURN (FONTCOPY FONT 'DEVICE DEVICE)) finally (RETURN (COND ((OR (NULL LASTFONT) (GREATERP LASTSIZE (TIMES 1.5 WID))) 'SHADE) (T (* ;  "use the smallest if it isn't too large.") (FONTCOPY LASTFONT 'DEVICE DEVICE]) (NEW-SKETCHW-HARDCOPYFN [LAMBDA (SKETCHW OPENIMAGESTREAM) (* ; "Edited 27-Jul-89 17:52 by Matt Heffron") (* ;  "dumps the sketch onto OPENIMAGESTREAM.") (* ;  "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM") (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM)) (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW)) (SCALE (VIEWER.SCALE SKETCHW)) SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX) (OR SKETCH (RETURN)) (SPAWN.MOUSE) (* ;; "move the margins out of the way") (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION)) OPENIMAGESTREAM) (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION)) OPENIMAGESTREAM) (DSPTOPMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP) (fetch (REGION TOP) of PAGEREGION)) OPENIMAGESTREAM) (* ;  "MAX.SMALLP^2 ought to be big enough...") (DSPRIGHTMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP) (fetch (REGION RIGHT) of PAGEREGION)) OPENIMAGESTREAM) (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.") (STATUSPRINT SKETCHW "Hardcopying ...") [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE SKETCHW) "A Sketch")) (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS] (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM))) (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR)) (COND ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM) 'PRESS)) (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS) OF OPENIMAGESTREAM)) 'NILL)) (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) (fetch WIDTH of PAGEREGION)) (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) (fetch HEIGHT of SKETCHREGIONINPAGECOORDS))) (* ;; "we have a stream that supports rotation, use it!") (DSPROTATE 90 OPENIMAGESTREAM) (COND ((NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM) 'POSTSCRIPT)) (* ;; "Since PostScript's DSPROTATE does the translate also..., dont't do it here. --HACK! HACK! HACK! --Matt.") (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION)) OPENIMAGESTREAM))) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM) (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)") (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big. Now it tries to do it on any stream that has a dsprotate function.") )) (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS )) 2)) (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS )) 2)) (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.") [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE (SETQ PAGELEFTSPACE (PLUS (fetch (REGION LEFT) of PAGEREGION) PAGELEFTSPACE)) (fetch (REGION LEFT) of SKETCHREGIONINPAGECOORDS )) PAGETOSKETCHFACTOR)) (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE (PLUS (fetch (REGION BOTTOM) of PAGEREGION) PAGEBOTTOMSPACE)) (fetch (REGION BOTTOM) of SKETCHREGIONINPAGECOORDS )) PAGETOSKETCHFACTOR] (* ;  "calculate the local parts for the interpress sketch.") (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE PAGETOSKETCHFACTOR) (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR) (fetch (REGION WIDTH) of SKETCHREGION ) (fetch (REGION HEIGHT) of SKETCHREGION )) PAGETOSKETCHFACTOR OPENIMAGESTREAM)) (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS ) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS ))) (STATUSPRINT SKETCHW " done.") (RETURN OPENIMAGESTREAM]) ) (* ;; "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.") (DEFINEQ (\BUILDSLUGCSINFO [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 14-Feb-89 16:46 by snow") (* ;;; "builds a csinfo which contains only the slug (black rectangle) character") (SETQ SCALE (OR SCALE 1)) (PROG ((CSINFO (create CHARSETINFO CHARSETASCENT _ ASCENT CHARSETDESCENT _ DESCENT IMAGEWIDTHS _ (\CREATECSINFOELEMENT))) WIDTHS OFFSETS BITMAP IMAGEWIDTHS) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) [SELECTQ DEVICE (INTERPRESS (* ;  "don't need offsets in INTERPRESS fonts") NIL) (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS ( \CREATECSINFOELEMENT ))) (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) [replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) (ROUND (QUOTIENT (IPLUS ASCENT DESCENT) SCALE] (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] (RETURN CSINFO]) (\CREATECHARSET [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 14-Feb-89 16:29 by snow") (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") (* ;  "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) (AND (IGREATERP CHARSET \MAXCHARSET) (\ILLEGAL.ARG CHARSET)) (PROG (CSINFO CREATEFN) (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.") (if (OR (AND (IGEQ CHARSET 1) (ILEQ CHARSET 32)) (AND (IGEQ CHARSET 127) (ILEQ CHARSET 160))) then (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG? is T)") [if NOSLUG? then (RETURN NIL) else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT) (FONTPROP FONT 'ASCENT) (FONTPROP FONT 'DESCENT) (FONTPROP FONT 'DEVICE) (FONTPROP FONT 'SCALE] else [SETQ CREATEFN (COND ((FMEMB (FONTPROP FONT 'DEVICE) \DISPLAYSTREAMTYPES) (FUNCTION \CREATECHARSET.DISPLAY)) (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT 'DEVICE) IMAGESTREAMTYPES] [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC) (LIST CHARSET FONT NOSLUG?] then (* ;  "the create method returned NIL. so if NOSLUG? return NIL else build a slug charsetinfo") (RETURN (if NOSLUG? then (* ;  "the caller just wants NIL back to signal that nothing was found") NIL else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT) (FONTPROP FONT 'ASCENT) (FONTPROP FONT 'HEIGHT) (FONTPROP FONT 'DEVICE) (FONTPROP FONT 'SCALE] (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT) (fetch CHARSETASCENT of CSINFO))) (replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT) (ffetch CHARSETDESCENT of CSINFO))) (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent of FONT) (ffetch \SFDescent of FONT))) (* ;  "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") ) (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT) CHARSET CSINFO]) ) (RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT) (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN))) (ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) (TIMESROMAND . TIMESROMAN) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMESROMAN) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (MODERN . HELVETICA)) (RPAQQ \KNOWN.SKETCH.FONTSIZES NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) POSTSCRIPT.FONT.CONVERSIONS) ) (* ;; "finally actually do the patching of sketch.") (FIX-SKETCH) (PUTPROPS PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (PUTPROPS PS-SKETCH-PATCH FILETYPE :TCOMPL) (PUTPROPS PS-SKETCH-PATCH COPYRIGHT ("ENVOS Corporation" 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2758 17798 (FIX-SKETCH 2768 . 3382) (ADD.KNOWN.SKETCH.FONT 3384 . 4261) ( NEW-SK-DECREASING-FONT-LIST 4263 . 6087) (NEW-SK-PICK-FONT 6089 . 9471) (NEW-SKETCHW-HARDCOPYFN 9473 . 17796)) (17888 24660 (\BUILDSLUGCSINFO 17898 . 19796) (\CREATECHARSET 19798 . 24658))))) STOP \ No newline at end of file diff --git a/lispusers/PS-SKETCH-PATCH.TEDIT b/lispusers/PS-SKETCH-PATCH.TEDIT new file mode 100644 index 00000000..2a0f2937 Binary files /dev/null and b/lispusers/PS-SKETCH-PATCH.TEDIT differ diff --git a/lispusers/PS-TTY b/lispusers/PS-TTY new file mode 100644 index 00000000..bc4747d1 --- /dev/null +++ b/lispusers/PS-TTY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 2-Aug-89 13:43:41" {DSK}PS>PS-TTY.;10 2608 changes to%: (PROPS (PS-TTY MAKEFILE-ENVIRONMENT)) (VARS PS-TTYCOMS) previous date%: " 6-Sep-88 17:09:36" {DSK}PS>PS-TTY.;9) (* " Copyright (c) 1988, 1989 by Beckman Instruments, Inc. All rights reserved. ") (PRETTYCOMPRINT PS-TTYCOMS) (RPAQQ PS-TTYCOMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS) DLTTY) (INITVARS (PS-TTY-BAUD 4800) (PS-TTY-DATABITS 8) (PS-TTY-PARITY 'NONE) (PS-TTY-STOPBITS 1) (PS-TTY-FLOWCONTROL 'XOnXOff)) (FNS PS-TTY-AFTERLOGOUT PS-TTY-INIT) (ADDVARS (DEFAULTPRINTINGHOST PS-TTY) (AROUNDEXITFNS PS-TTY-AFTERLOGOUT)) (P (PS-TTY-INIT)) (PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE) PS-TTY))) (FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS) DLTTY) (RPAQ? PS-TTY-BAUD 4800) (RPAQ? PS-TTY-DATABITS 8) (RPAQ? PS-TTY-PARITY 'NONE) (RPAQ? PS-TTY-STOPBITS 1) (RPAQ? PS-TTY-FLOWCONTROL 'XOnXOff) (DEFINEQ (PS-TTY-AFTERLOGOUT [LAMBDA (EVENT) (* ; "Edited 19-Apr-88 13:25 by Matt Heffron") (if (EQ EVENT 'AFTERLOGOUT) then (TTY.INIT PS-TTY-BAUD PS-TTY-DATABITS PS-TTY-PARITY PS-TTY-STOPBITS PS-TTY-FLOWCONTROL]) (PS-TTY-INIT [LAMBDA NIL (* ; "Edited 19-Apr-88 13:24 by Matt Heffron") [PUTPROP 'PS-TTY 'SPOOLOPTIONS `((BaudRate ,PS-TTY-BAUD) (BitsPerSerialChar ,PS-TTY-DATABITS) (Parity ,PS-TTY-PARITY) (NoOfStopBits ,PS-TTY-STOPBITS) (FlowControl ,PS-TTY-FLOWCONTROL] (PS-TTY-AFTERLOGOUT 'AFTERLOGOUT) (* ; "Fake it") NIL]) ) (ADDTOVAR DEFAULTPRINTINGHOST PS-TTY) (ADDTOVAR AROUNDEXITFNS PS-TTY-AFTERLOGOUT) (PS-TTY-INIT) (PUTPROPS PS-TTY MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS PS-TTY PRINTERTYPE POSTSCRIPT) (PUTPROPS PS-TTY SPOOLFILE "{TTY}FOO.PS") (PUTPROPS PS-TTY COPYRIGHT ("Beckman Instruments, Inc" 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1377 2224 (PS-TTY-AFTERLOGOUT 1387 . 1662) (PS-TTY-INIT 1664 . 2222))))) STOP \ No newline at end of file diff --git a/lispusers/PS-TTY.TEDIT b/lispusers/PS-TTY.TEDIT new file mode 100644 index 00000000..64d24852 Binary files /dev/null and b/lispusers/PS-TTY.TEDIT differ diff --git a/lispusers/PS-patch.tedit b/lispusers/PS-patch.tedit new file mode 100644 index 00000000..e5e51519 Binary files /dev/null and b/lispusers/PS-patch.tedit differ diff --git a/lispusers/PSCFONT-FIX-FILENAME b/lispusers/PSCFONT-FIX-FILENAME new file mode 100644 index 00000000..e699ca4b --- /dev/null +++ b/lispusers/PSCFONT-FIX-FILENAME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "11-May-87 16:33:49" {DSK}PS>PSCFONT-FIX-FILENAME.\;1 5877 |changes| |to:| (VARS PSCFONT-FIX-FILENAMECOMS) (FNS PSCFONT-FILENAME-FIX) (FILEVARS PSCFONT-FIX-FILENAMECOMS)) ; Copyright (c) 1987 by Beckman Instruments, Inc. All rights reserved. (PRETTYCOMPRINT PSCFONT-FIX-FILENAMECOMS) (RPAQQ PSCFONT-FIX-FILENAMECOMS ((FNS PSCFONT-FILENAME-FIX) (VARS POSTSCRIPT-FONT-FILENAME-FIXLIST))) (DEFINEQ (PSCFONT-FILENAME-FIX (LAMBDA NIL (* \; "Edited 11-May-87 15:34 by Matt Heffron") (FOR D IN POSTSCRIPTFONTDIRECTORIES DO (FOR F IN POSTSCRIPT-FONT-FILENAME-FIXLIST DO (LET (FN) (CL:WHEN (SETQ FN (INFILEP (CONCAT D (CAR F)))) (PRINTOUT T FN " => " (RENAMEFILE FN (CONCAT D (\\FONTFILENAME (CADR F) 1 (CADDR F) '.PSCFONT))) T))))))) ) (RPAQQ POSTSCRIPT-FONT-FILENAME-FIXLIST (("AVANTGARDE-BOOK1" AVANTGARDE-BOOK (MEDIUM REGULAR REGULAR) ) ("AVANTGARDE-BOOK1I" AVANTGARDE-BOOK (MEDIUM ITALIC REGULAR) ) ("AVANTGARDE-DEMI1" AVANTGARDE-DEMI (MEDIUM REGULAR REGULAR) ) ("AVANTGARDE-DEMI1I" AVANTGARDE-DEMI (MEDIUM ITALIC REGULAR) ) ("BOOKMAN-DEMI1" BOOKMAN-DEMI (MEDIUM REGULAR REGULAR)) ("BOOKMAN-DEMI1I" BOOKMAN-DEMI (MEDIUM ITALIC REGULAR)) ("BOOKMAN-LIGHT1" BOOKMAN-LIGHT (MEDIUM REGULAR REGULAR)) ("BOOKMAN-LIGHT1I" BOOKMAN-LIGHT (MEDIUM ITALIC REGULAR)) ("COURIER1" COURIER (MEDIUM REGULAR REGULAR)) ("COURIER1B" COURIER (BOLD REGULAR REGULAR)) ("COURIER1BI" COURIER (BOLD ITALIC REGULAR)) ("COURIER1I" COURIER (MEDIUM ITALIC REGULAR)) ("HELVETICA-NARROW1" HELVETICA-NARROW (MEDIUM REGULAR REGULAR)) ("HELVETICA-NARROW1B" HELVETICA-NARROW (BOLD REGULAR REGULAR )) ("HELVETICA-NARROW1BI" HELVETICA-NARROW (BOLD ITALIC REGULAR )) ("HELVETICA-NARROW1I" HELVETICA-NARROW (MEDIUM ITALIC REGULAR)) ("HELVETICA1" HELVETICA (MEDIUM REGULAR REGULAR)) ("HELVETICA1B" HELVETICA (BOLD REGULAR REGULAR)) ("HELVETICA1BI" HELVETICA (BOLD ITALIC REGULAR)) ("HELVETICA1I" HELVETICA (MEDIUM ITALIC REGULAR)) ("NEWCENTURYSCHLBK1" NEWCENTURYSCHLBK (MEDIUM REGULAR REGULAR)) ("NEWCENTURYSCHLBK1B" NEWCENTURYSCHLBK (BOLD REGULAR REGULAR )) ("NEWCENTURYSCHLBK1BI" NEWCENTURYSCHLBK (BOLD ITALIC REGULAR )) ("NEWCENTURYSCHLBK1I" NEWCENTURYSCHLBK (MEDIUM ITALIC REGULAR)) ("PALATINO1" PALATINO (MEDIUM REGULAR REGULAR)) ("PALATINO1B" PALATINO (BOLD REGULAR REGULAR)) ("PALATINO1BI" PALATINO (BOLD ITALIC REGULAR)) ("PALATINO1I" PALATINO (MEDIUM ITALIC REGULAR)) ("SYMBOL1" SYMBOL (MEDIUM REGULAR REGULAR)) ("TIMES1" TIMES (MEDIUM REGULAR REGULAR)) ("TIMES1B" TIMES (BOLD REGULAR REGULAR)) ("TIMES1BI" TIMES (BOLD ITALIC REGULAR)) ("TIMES1I" TIMES (MEDIUM ITALIC REGULAR)) ("ZAPFCHANCERY-MEDIUM1I" ZAPFCHANCERY-MEDIUM (MEDIUM REGULAR REGULAR)) ("ZAPFCHANCERY1I" ZAPFCHANCERY (MEDIUM ITALIC REGULAR)) ("ZAPFDINGBATS1" ZAPFDINGBATS (MEDIUM REGULAR REGULAR)))) (PUTPROPS PSCFONT-FIX-FILENAME COPYRIGHT ("Beckman Instruments, Inc" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (572 1404 (PSCFONT-FILENAME-FIX 582 . 1402))))) STOP \ No newline at end of file diff --git a/lispusers/QEDIT b/lispusers/QEDIT new file mode 100644 index 00000000..a64c91c7 --- /dev/null +++ b/lispusers/QEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "25-Jan-88 14:27:06" "{FireFS:CS:Univ Rochester}LispUsers>Lyric>QEDIT.;9" 30305 changes to%: (VARS QEDITCOMS) (RECORDS QEDITOR QENTRY) (FNS QEDIT QEDIT.CURRENT.QUEUE QEDIT.RESET QE-ACQUIRE-EDITOR QE-ADJUST-SCROLL-PARAMS QE-BUTTONEVENTFN QE-CLOSEFN QE-CMD-INSERT QE-CMD-EDIT QE-CMD-DELETE QE-CMD-LEFT QE-CMD-RIGHT QE-COLLECT-QUEUE QE-COMPUTE-LABEL QE-CREATE-EDITOR QE-CREATE-ENTRIES QE-CREATE-ENTRY QE-DISPLAY-ENTRIES QE-DISPLAY-ENTRIES-AUX QE-DISPLAY-ENTRY QE-FOCUS-SELECTION QE-INIT-EDITOR QE-MARKASCHANGED QE-MARK-VISIBLE-ENTRIES QE-MAX-INDEX-WIDTH QE-MAX-LABEL-WIDTH QE-MOUSE-IN-ENTRYP QE-MOUSED-ENTRY QE-PLACE-ENTRIES QE-PROMPTPRINT QE-REDISPLAY-ENTRY QE-RELEASE-EDITOR QE-REPAINTFN QE-RESET-DSP QE-RESHAPEFN QE-RUN-EDITOR QE-SCROLLFN QE-SELECT-ENTRY QE-SLIDE-ENTRY QE-TOGGLE-ENTRY QE-UNMARKASCHANGED QE-WHENSELECTEDFN QE-CMD-ADD) previous date%: "22-Jan-88 15:59:42" {ICE}LISPUSERS>KOTO>QEDIT.;9) (* " Copyright (c) 1987, 1988 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT QEDITCOMS) (RPAQQ QEDITCOMS ((* ;; "Interface") (FNS QEDIT QEDIT.CURRENT.QUEUE QEDIT.RESET) (INITVARS (*QEDITPROPS* (QUOTE (TITLE "Queue Editor" LABELFONT (HELVETICA 8))))) (* ;; "Implementation") (COMS (DECLARE%: DONTCOPY (RECORDS QEDITOR QENTRY)) (INITRECORDS QEDITOR QENTRY)) (FNS QE-ACQUIRE-EDITOR QE-ADJUST-SCROLL-PARAMS QE-BUTTONEVENTFN QE-CLOSEFN QE-CMD-INSERT QE-CMD-EDIT QE-CMD-DELETE QE-CMD-LEFT QE-CMD-RIGHT QE-COLLECT-QUEUE QE-COMPUTE-LABEL QE-CREATE-EDITOR QE-CREATE-ENTRIES QE-CREATE-ENTRY QE-DISPLAY-ENTRIES QE-DISPLAY-ENTRIES-AUX QE-DISPLAY-ENTRY QE-FOCUS-SELECTION QE-INIT-EDITOR QE-MARKASCHANGED QE-MARK-VISIBLE-ENTRIES QE-MAX-INDEX-WIDTH QE-MAX-LABEL-WIDTH QE-MOUSE-IN-ENTRYP QE-MOUSED-ENTRY QE-PLACE-ENTRIES QE-PROMPTPRINT QE-REDISPLAY-ENTRY QE-RELEASE-EDITOR QE-REPAINTFN QE-RESET-DSP QE-RESHAPEFN QE-RUN-EDITOR QE-SCROLLFN QE-SELECT-ENTRY QE-SLIDE-ENTRY QE-TOGGLE-ENTRY QE-UNMARKASCHANGED QE-WHENSELECTEDFN) (INITVARS (*QEDITORS*)) (GLOBALVARS *QEDITORS*) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) QEDIT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA QE-PROMPTPRINT)))) ) (* ;; "Interface") (DEFINEQ (QEDIT (LAMBDA (QUEUE PROPS) (* Koomen "11-Dec-87 14:43") (* ; "Edited 27-Nov-87 14:36 by Koomen") (* ;; "Brings up a QEditor for rearranging the elements of QUEUE.") (* ;; "PROPS is a proplist customizing this particular editing session. The following props are currently supported:") (* ;; " TITLE - a string indicating the window title of the QEditor") (* ;; " CONTEXT - a Lisp object given as extra argument to the following functions") (* ;; " LABELFN - (labelfn qelt context) returns a label for displaying qelt") (* ;; " LABELFONT - a font spec -- defaults to (HELVETICA 8)") (* ;; " ADDFN - (addfn context) returns a new queue element") (* ;; " EDITFN - (editfn qelt context) returns a (possibly different) queue element ") (* ;; " DELETEFN - (deletefn qelt context) returns T iff the element can be deleted") (* ;; "") (* ;; "Default props are taken from the freevar *QEDITPROPS*") (LET ((QEDITOR (QE-ACQUIRE-EDITOR))) (RESETLST (RESETSAVE NIL (BQUOTE (QE-RELEASE-EDITOR (\, QEDITOR)))) (QE-RUN-EDITOR (QE-INIT-EDITOR QEDITOR (MKLIST QUEUE) (APPEND PROPS *QEDITPROPS*)))))) ) (QEDIT.CURRENT.QUEUE (LAMBDA NIL (* Koomen "11-Dec-87 16:54") (DECLARE (SPECVARS QEDITOR)) (if (AND (BOUNDP (QUOTE QEDITOR)) (type? QEDITOR QEDITOR)) then (QE-COLLECT-QUEUE QEDITOR) else (ERROR "No current QEdit in progress"))) ) (QEDIT.RESET (LAMBDA NIL (* Koomen "11-Dec-87 14:52") (* ; "Edited 27-Nov-87 14:43 by Koomen") (if (for QEDITOR in *QEDITORS* thereis (NEQ (fetch (QEDITOR QUEUE) of QEDITOR) (QUOTE RELEASED))) then (QE-PROMPTPRINT NIL "Can't reset QEdit while edits in progress") NIL else (SETQ *QEDITORS*) T)) ) ) (RPAQ? *QEDITPROPS* (QUOTE (TITLE "Queue Editor" LABELFONT (HELVETICA 8)))) (* ;; "Implementation") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE QEDITOR (QUEUE TITLE ENTRIES ENTRYCNT SELECTION LABELFONT LABELFN INSERTFN EDITFN DELETEFN XOFFSET YOFFSET WINDOW DSP PROMPTWINDOW MENU COMMAND USERCONTEXT CHANGES? UNDOLIST REDOLIST) ) (DATATYPE QENTRY (ELEMENT LABEL LABELWIDTH INDEX BIGBOX LBLBOX ORDBOX INVBOX OBSBOX VISIBLE? SELECTED?) ) ) (/DECLAREDATATYPE (QUOTE QEDITOR) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((QEDITOR 0 POINTER) (QEDITOR 2 POINTER) (QEDITOR 4 POINTER) (QEDITOR 6 POINTER) (QEDITOR 8 POINTER) (QEDITOR 10 POINTER) (QEDITOR 12 POINTER) (QEDITOR 14 POINTER) (QEDITOR 16 POINTER) (QEDITOR 18 POINTER) (QEDITOR 20 POINTER) (QEDITOR 22 POINTER) (QEDITOR 24 POINTER) (QEDITOR 26 POINTER) (QEDITOR 28 POINTER) (QEDITOR 30 POINTER) (QEDITOR 32 POINTER) (QEDITOR 34 POINTER) (QEDITOR 36 POINTER) (QEDITOR 38 POINTER) (QEDITOR 40 POINTER))) (QUOTE 42)) (/DECLAREDATATYPE (QUOTE QENTRY) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((QENTRY 0 POINTER) (QENTRY 2 POINTER) (QENTRY 4 POINTER) (QENTRY 6 POINTER) (QENTRY 8 POINTER) (QENTRY 10 POINTER) (QENTRY 12 POINTER) (QENTRY 14 POINTER) (QENTRY 16 POINTER) (QENTRY 18 POINTER) (QENTRY 20 POINTER))) (QUOTE 22)) ) (/DECLAREDATATYPE (QUOTE QEDITOR) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((QEDITOR 0 POINTER) (QEDITOR 2 POINTER) (QEDITOR 4 POINTER) (QEDITOR 6 POINTER) (QEDITOR 8 POINTER) (QEDITOR 10 POINTER) (QEDITOR 12 POINTER) (QEDITOR 14 POINTER) (QEDITOR 16 POINTER) (QEDITOR 18 POINTER) (QEDITOR 20 POINTER) (QEDITOR 22 POINTER) (QEDITOR 24 POINTER) (QEDITOR 26 POINTER) (QEDITOR 28 POINTER) (QEDITOR 30 POINTER) (QEDITOR 32 POINTER) (QEDITOR 34 POINTER) (QEDITOR 36 POINTER) (QEDITOR 38 POINTER) (QEDITOR 40 POINTER))) (QUOTE 42)) (/DECLAREDATATYPE (QUOTE QENTRY) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((QENTRY 0 POINTER) (QENTRY 2 POINTER) (QENTRY 4 POINTER) (QENTRY 6 POINTER) (QENTRY 8 POINTER) (QENTRY 10 POINTER) (QENTRY 12 POINTER) (QENTRY 14 POINTER) (QENTRY 16 POINTER) (QENTRY 18 POINTER) (QENTRY 20 POINTER))) (QUOTE 22)) (DEFINEQ (QE-ACQUIRE-EDITOR (LAMBDA NIL (* ; "Edited 27-Nov-87 15:09 by Koomen") (for QEDITOR in *QEDITORS* when (EQ (QUOTE RELEASED) (fetch (QEDITOR QUEUE) of QEDITOR)) do (RETURN QEDITOR) finally (SETQ QEDITOR (QE-CREATE-EDITOR)) (SETQ *QEDITORS* (NCONC1 *QEDITORS* QEDITOR)) (RETURN QEDITOR))) ) (QE-ADJUST-SCROLL-PARAMS (LAMBDA (QEDITOR WIDTH HEIGHT XOFFSET YOFFSET) (* ; "Edited 25-Nov-87 16:15 by Koomen") (replace (QEDITOR XOFFSET) of QEDITOR with XOFFSET) (replace (QEDITOR YOFFSET) of QEDITOR with YOFFSET) (WINDOWPROP (fetch (QEDITOR WINDOW) of QEDITOR) (QUOTE EXTENT) (CREATEREGION 0 0 WIDTH HEIGHT))) ) (QE-BUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 21-Jan-88 23:13 by Koomen") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS)) (PROG ((QEDITOR (WINDOWPROP WINDOW (QUOTE QEDITOR))) (BUTTON (if (LASTMOUSESTATE (ONLY LEFT)) then (QUOTE LEFT) elseif (LASTMOUSESTATE (ONLY MIDDLE)) then (QUOTE MIDDLE)))) (TOTOPW WINDOW) (if (AND QEDITOR BUTTON) then (QE-SLIDE-ENTRY QEDITOR (QE-MOUSED-ENTRY QEDITOR) BUTTON)))) ) (QE-CLOSEFN (LAMBDA (WINDOW) (* ; "Edited 27-Nov-87 11:42 by Koomen") (PROG ((QEDITOR (WINDOWPROP WINDOW (QUOTE QEDITOR)))) (if QEDITOR then (if (fetch (QEDITOR COMMAND) of QEDITOR) then (RETURN (QUOTE DON'T)) else (replace (QEDITOR COMMAND) of QEDITOR with (QUOTE Done)))))) ) (QE-CMD-INSERT (LAMBDA (QEDITOR) (* Koomen "22-Jan-88 13:41") (PROG (NEWENTRY ENTRIES) (if (NULL (fetch (QEDITOR INSERTFN) of QEDITOR)) then (QE-PROMPTPRINT QEDITOR "Don't know how to insert elements") (RETURN)) (SETQ NEWENTRY (APPLY* (fetch (QEDITOR INSERTFN) of QEDITOR) (fetch (QEDITOR USERCONTEXT) of QEDITOR))) (if (NULL NEWENTRY) then (QE-PROMPTPRINT QEDITOR "Nothing to insert") (RETURN)) (SETQ NEWENTRY (QE-CREATE-ENTRY QEDITOR NEWENTRY)) (SETQ ENTRIES (fetch (QEDITOR ENTRIES) of QEDITOR)) (if (NULL ENTRIES) then (replace (QEDITOR ENTRIES) of QEDITOR with (LIST NEWENTRY)) else (for ENTRYP on ENTRIES when (fetch (QENTRY SELECTED?) of (CAR ENTRYP)) do (RPLNODE ENTRYP NEWENTRY (CONS (CAR ENTRYP) (CDR ENTRYP))) (RETURN) finally (replace (QEDITOR ENTRIES) of QEDITOR with (CONS NEWENTRY ENTRIES)))) (add (fetch (QEDITOR ENTRYCNT) of QEDITOR) 1) (QE-MARKASCHANGED QEDITOR) (QE-PLACE-ENTRIES QEDITOR) (QE-DISPLAY-ENTRIES QEDITOR) (QE-SELECT-ENTRY QEDITOR NEWENTRY))) ) (QE-CMD-EDIT (LAMBDA (QEDITOR) (* ; "Edited 22-Jan-88 00:15 by Koomen") (PROG (ENTRY RESULT OLDLABEL NEWLABEL) (SETQ ENTRY (fetch (QEDITOR SELECTION) of QEDITOR)) (if (NULL ENTRY) then (QE-PROMPTPRINT QEDITOR "Nothing selected") (RETURN)) (if (NULL (fetch (QEDITOR EDITFN) of QEDITOR)) then (QE-PROMPTPRINT QEDITOR "QEdit selection cannot be edited") (RETURN)) (SETQ RESULT (APPLY* (fetch (QEDITOR EDITFN) of QEDITOR) (fetch (QENTRY ELEMENT) of ENTRY) (fetch (QEDITOR USERCONTEXT) of QEDITOR))) (if RESULT then (replace (QENTRY ELEMENT) of ENTRY with RESULT) (SETQ OLDLABEL (fetch (QENTRY LABEL) of ENTRY)) (QE-COMPUTE-LABEL QEDITOR ENTRY) (SETQ NEWLABEL (fetch (QENTRY LABEL) of ENTRY)) (if (NOT (EQUAL NEWLABEL OLDLABEL)) then (QE-PLACE-ENTRIES QEDITOR) (QE-DISPLAY-ENTRIES QEDITOR))))) ) (QE-CMD-DELETE (LAMBDA (QEDITOR) (* ; "Edited 21-Jan-88 23:43 by Koomen") (* ;; "Delete the current selection provided there is a DELETEP function returning T") (PROG ((OLDENTRY (fetch (QEDITOR SELECTION) of QEDITOR))) (if (NULL OLDENTRY) then (QE-PROMPTPRINT QEDITOR "Nothing selected") elseif (AND (fetch (QEDITOR DELETEFN) of QEDITOR) (APPLY* (fetch (QEDITOR DELETEFN) of QEDITOR) (fetch (QENTRY ELEMENT) of OLDENTRY) (fetch (QEDITOR USERCONTEXT) of QEDITOR))) then (replace (QEDITOR ENTRIES) of QEDITOR with (DREMOVE OLDENTRY (fetch (QEDITOR ENTRIES) of QEDITOR))) (add (fetch (QEDITOR ENTRYCNT) of QEDITOR) -1) (replace (QEDITOR SELECTION) of QEDITOR with NIL) (QE-MARKASCHANGED QEDITOR) (QE-PLACE-ENTRIES QEDITOR) (QE-DISPLAY-ENTRIES QEDITOR) else (QE-PROMPTPRINT QEDITOR "QEdit selection cannot be deleted")))) ) (QE-CMD-LEFT (LAMBDA (QEDITOR) (* ; "Edited 21-Jan-88 23:00 by Koomen") (* ;; "Moves the current selection one place to the left, if possible. Returns the new current selection.") (PROG ((LEFT) (RIGHT (fetch (QEDITOR SELECTION) of QEDITOR)) (ENTRIES (fetch (QEDITOR ENTRIES) of QEDITOR))) (if (NULL RIGHT) then (QE-PROMPTPRINT QEDITOR "Nothing selected") (RETURN)) (if (EQ RIGHT (CAR ENTRIES)) then (QE-PROMPTPRINT QEDITOR "Can't move selection further left") (RETURN RIGHT)) (do (SETQ LEFT (pop ENTRIES)) repeatuntil (EQ RIGHT (CAR ENTRIES))) (swap (fetch (QENTRY LABEL) of LEFT) (fetch (QENTRY LABEL) of RIGHT)) (swap (fetch (QENTRY ELEMENT) of LEFT) (fetch (QENTRY ELEMENT) of RIGHT)) (QE-MARKASCHANGED QEDITOR) (QE-REDISPLAY-ENTRY QEDITOR RIGHT) (QE-REDISPLAY-ENTRY QEDITOR LEFT) (RETURN (QE-SELECT-ENTRY QEDITOR LEFT)))) ) (QE-CMD-RIGHT (LAMBDA (QEDITOR) (* ; "Edited 21-Jan-88 23:03 by Koomen") (PROG ((LEFT (fetch (QEDITOR SELECTION) of QEDITOR)) (RIGHT) (ENTRIES (fetch (QEDITOR ENTRIES) of QEDITOR))) (if (NULL LEFT) then (QE-PROMPTPRINT QEDITOR "Nothing selected") (RETURN)) (do (SETQ RIGHT (CADR ENTRIES)) repeatuntil (EQ LEFT (pop ENTRIES))) (if (NULL RIGHT) then (QE-PROMPTPRINT QEDITOR "Can't move selection further right") (RETURN LEFT)) (swap (fetch (QENTRY LABEL) of LEFT) (fetch (QENTRY LABEL) of RIGHT)) (swap (fetch (QENTRY ELEMENT) of LEFT) (fetch (QENTRY ELEMENT) of RIGHT)) (QE-MARKASCHANGED QEDITOR) (QE-REDISPLAY-ENTRY QEDITOR LEFT) (QE-REDISPLAY-ENTRY QEDITOR RIGHT) (RETURN (QE-SELECT-ENTRY QEDITOR RIGHT)))) ) (QE-COLLECT-QUEUE (LAMBDA (QEDITOR) (* Koomen "25-May-87 12:05") (for ENTRY in (fetch (QEDITOR ENTRIES) of QEDITOR) collect (fetch (QENTRY ELEMENT) of ENTRY))) ) (QE-COMPUTE-LABEL (LAMBDA (QEDITOR ENTRY) (* ; "Edited 27-Nov-87 11:57 by Koomen") (PROG ((LABEL (OR (AND (fetch (QEDITOR LABELFN) of QEDITOR) (APPLY* (fetch (QEDITOR LABELFN) of QEDITOR) (fetch (QENTRY ELEMENT) of ENTRY) (fetch (QEDITOR USERCONTEXT) of QEDITOR))) (fetch (QENTRY ELEMENT) of ENTRY))) (LABELFONT (fetch (QEDITOR LABELFONT) of QEDITOR))) (replace (QENTRY LABEL) of ENTRY with LABEL) (replace (QENTRY LABELWIDTH) of ENTRY with (STRINGWIDTH LABEL LABELFONT)) (RETURN ENTRY))) ) (QE-CREATE-EDITOR (LAMBDA NIL (* Koomen "22-Jan-88 14:30") (LET* ((QEDITMENU (create MENU ITEMS _ (QUOTE (("<--" Left "Moves selected entry to the left") ("-->" Right "Moves selected entry to the right") (Insert Insert "Insert a new entry before the selected one") (Edit Edit "Edit the selected entry") (Delete Delete "Delete the selected entry") (Abort Abort "Abort Queue Editor, returning original queue") (Done Done "Exit Queue Editor, returning current queue"))) MENUFONT _ (QUOTE (MODERN 12)) CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION QE-WHENSELECTEDFN))) (QEDITWINDOW (CREATEMENUEDWINDOW QEDITMENU "Queue Editor"))) (WINDOWADDPROP QEDITWINDOW (QUOTE CLOSEFN) (FUNCTION QE-CLOSEFN)) (WINDOWADDPROP QEDITWINDOW (QUOTE REPAINTFN) (FUNCTION QE-REPAINTFN)) (WINDOWADDPROP QEDITWINDOW (QUOTE RESHAPEFN) (FUNCTION QE-RESHAPEFN)) (WINDOWPROP QEDITWINDOW (QUOTE BUTTONEVENTFN) (FUNCTION QE-BUTTONEVENTFN)) (WINDOWPROP QEDITWINDOW (QUOTE SCROLLFN) (FUNCTION QE-SCROLLFN)) (WINDOWPROP QEDITWINDOW (QUOTE SCROLLEXTENTUSE) (QUOTE (LIMIT . LIMIT))) (create QEDITOR MENU _ QEDITMENU WINDOW _ QEDITWINDOW DSP _ (WINDOWPROP QEDITWINDOW (QUOTE DSP)) PROMPTWINDOW _ (GETPROMPTWINDOW QEDITWINDOW)))) ) (QE-CREATE-ENTRIES (LAMBDA (QEDITOR) (* ; "Edited 27-Nov-87 17:15 by Koomen") (PROG ((ENTRIES (for ELEMENT in (fetch (QEDITOR QUEUE) of QEDITOR) collect (QE-CREATE-ENTRY QEDITOR ELEMENT)))) (replace (QEDITOR ENTRIES) of QEDITOR with ENTRIES) (replace (QEDITOR ENTRYCNT) of QEDITOR with (LENGTH ENTRIES)) (replace (QEDITOR SELECTION) of QEDITOR with NIL))) ) (QE-CREATE-ENTRY (LAMBDA (QEDITOR ELEMENT) (* Koomen "26-May-87 00:20") (QE-COMPUTE-LABEL QEDITOR (create QENTRY ELEMENT _ ELEMENT))) ) (QE-DISPLAY-ENTRIES (LAMBDA (QEDITOR) (* ; "Edited 21-Jan-88 23:46 by Koomen") (QE-RESET-DSP QEDITOR) (QE-DISPLAY-ENTRIES-AUX QEDITOR (fetch (QEDITOR ENTRIES) of QEDITOR) (QE-MARK-VISIBLE-ENTRIES QEDITOR)) (QE-SELECT-ENTRY QEDITOR (fetch (QEDITOR SELECTION) of QEDITOR))) ) (QE-DISPLAY-ENTRIES-AUX (LAMBDA (QEDITOR ENTRIES N) (* ; "Edited 25-Nov-87 16:15 by Koomen") (* ;; "Recursively display the entries (back to front) [first N, if non-NIL]") (if (AND ENTRIES (OR (NULL N) (IGREATERP N 0))) then (QE-DISPLAY-ENTRIES-AUX QEDITOR (CDR ENTRIES) (AND N (SUB1 N))) (QE-DISPLAY-ENTRY QEDITOR (CAR ENTRIES)))) ) (QE-DISPLAY-ENTRY (LAMBDA (QEDITOR ENTRY) (* ; "Edited 21-Jan-88 21:51 by Koomen") (DECLARE (GLOBALVARS BLACKSHADE)) (if (fetch (QENTRY VISIBLE?) of ENTRY) then (LET ((DSP (fetch (QEDITOR DSP) of QEDITOR))) (with REGION (fetch (QENTRY BIGBOX) of ENTRY) (GRAYBOXAREA LEFT BOTTOM WIDTH HEIGHT 1 BLACKSHADE DSP)) (with REGION (fetch (QENTRY LBLBOX) of ENTRY) (MOVETO LEFT BOTTOM DSP)) (PRINTOUT DSP (fetch (QENTRY LABEL) of ENTRY)) (with REGION (fetch (QENTRY ORDBOX) of ENTRY) (MOVETO LEFT BOTTOM DSP)) (PRINTOUT DSP (fetch (QENTRY INDEX) of ENTRY)) (replace (QENTRY SELECTED?) of ENTRY with NIL)))) ) (QE-FOCUS-SELECTION (LAMBDA (QEDITOR COMMAND) (* ; "Edited 22-Jan-88 00:18 by Koomen") (PROG (QENTRY QENTRYBOX QEDITWINDOW QEDITREGION) (if (AND (SETQ QENTRY (fetch (QEDITOR SELECTION) of QEDITOR)) (NOT (SUBREGIONP (SETQ QEDITREGION (DSPCLIPPINGREGION NIL (SETQ QEDITWINDOW (fetch (QEDITOR WINDOW) of QEDITOR)))) (SETQ QENTRYBOX (fetch (QENTRY BIGBOX) of QENTRY))))) then (SCROLLW QEDITWINDOW (QUOTIENT (DIFFERENCE (with REGION QEDITREGION (PLUS LEFT RIGHT)) (with REGION QENTRYBOX (PLUS LEFT RIGHT))) 2) 0) (if COMMAND then (QE-PROMPTPRINT QEDITOR "Queue Editor command `" COMMAND "' ignored")) (RETURN T)))) ) (QE-INIT-EDITOR (LAMBDA (QEDITOR QUEUE PROPS) (* Koomen "22-Jan-88 14:29") (LET ((QEDITMENU (fetch (QEDITOR MENU) of QEDITOR)) (QEDITWINDOW (fetch (QEDITOR WINDOW) of QEDITOR))) (PUTMENUPROP QEDITMENU (QUOTE QEDITOR) QEDITOR) (WINDOWPROP QEDITWINDOW (QUOTE QEDITOR) QEDITOR) (WINDOWPROP QEDITWINDOW (QUOTE TITLE) (replace (QEDITOR TITLE) of QEDITOR with (LISTGET PROPS (QUOTE TITLE)))) (replace (QEDITOR QUEUE) of QEDITOR with (MKLIST QUEUE)) (replace (QEDITOR LABELFN) of QEDITOR with (LISTGET PROPS (QUOTE LABELFN))) (replace (QEDITOR LABELFONT) of QEDITOR with (FONTCREATE (LISTGET PROPS (QUOTE LABELFONT)))) (replace (QEDITOR INSERTFN) of QEDITOR with (OR (LISTGET PROPS (QUOTE INSERTFN)) (LISTGET PROPS (QUOTE ADDFN)))) (replace (QEDITOR EDITFN) of QEDITOR with (LISTGET PROPS (QUOTE EDITFN))) (replace (QEDITOR DELETEFN) of QEDITOR with (LISTGET PROPS (QUOTE DELETEFN))) (replace (QEDITOR USERCONTEXT) of QEDITOR with (LISTGET PROPS (QUOTE CONTEXT))) (replace (QEDITOR COMMAND) of QEDITOR with NIL) (replace (QEDITOR CHANGES?) of QEDITOR with NIL) (DSPFONT (fetch (QEDITOR LABELFONT) of QEDITOR) (fetch (QEDITOR DSP) of QEDITOR)) (CLEARW QEDITWINDOW) (CLEARW (fetch (QEDITOR PROMPTWINDOW) of QEDITOR)) QEDITOR)) ) (QE-MARKASCHANGED (LAMBDA (QEDITOR) (* Koomen "11-Dec-87 15:04") (* ; "Edited 27-Nov-87 17:10 by Koomen") (if (NOT (fetch (QEDITOR CHANGES?) of QEDITOR)) then (replace (QEDITOR CHANGES?) of QEDITOR with T) (WINDOWPROP (fetch (QEDITOR WINDOW) of QEDITOR) (QUOTE TITLE) (CONCAT "* " (fetch (QEDITOR TITLE) of QEDITOR)))) QEDITOR) ) (QE-MARK-VISIBLE-ENTRIES (LAMBDA (QEDITOR) (* ; "Edited 22-Jan-88 00:19 by Koomen") (for ENTRY in (fetch (QEDITOR ENTRIES) of QEDITOR) bind (LASTINDEX _ 0) (CLIPPINGREGION _ (DSPCLIPPINGREGION NIL (fetch (QEDITOR WINDOW) of QEDITOR))) do (if (replace (QENTRY VISIBLE?) of ENTRY with (REGIONSINTERSECTP CLIPPINGREGION (fetch (QENTRY BIGBOX) of ENTRY))) then (SETQ LASTINDEX (fetch (QENTRY INDEX) of ENTRY))) finally (RETURN LASTINDEX))) ) (QE-MAX-INDEX-WIDTH (LAMBDA (QEDITOR) (* ; "Edited 27-Nov-87 17:05 by Koomen") (STRINGWIDTH (TIMES (fetch (QEDITOR ENTRYCNT) of QEDITOR) 10) (fetch (QEDITOR LABELFONT) of QEDITOR))) ) (QE-MAX-LABEL-WIDTH (LAMBDA (QEDITOR) (* Koomen "26-May-87 00:14") (for ENTRY in (fetch (QEDITOR ENTRIES) of QEDITOR) bind (W _ (STRINGWIDTH "Some Label" (fetch (QEDITOR LABELFONT) of QEDITOR))) do (SETQ W (IMAX W (fetch (QENTRY LABELWIDTH) of ENTRY))) finally (RETURN W))) ) (QE-MOUSE-IN-ENTRYP (LAMBDA (QEDITOR ENTRY) (* ; "Edited 21-Jan-88 22:23 by Koomen") (LET ((QWINDOW (fetch (QEDITOR WINDOW) of QEDITOR))) (INSIDEP (fetch (QENTRY BIGBOX) of ENTRY) (LASTMOUSEX QWINDOW) (LASTMOUSEY QWINDOW)))) ) (QE-MOUSED-ENTRY (LAMBDA (QEDITOR) (* Koomen "25-May-87 12:44") (for ENTRY in (fetch (QEDITOR ENTRIES) of QEDITOR) thereis (QE-MOUSE-IN-ENTRYP QEDITOR ENTRY))) ) (QE-PLACE-ENTRIES (LAMBDA (QEDITOR) (* Koomen "22-Jan-88 15:59") (PROG (DSP ENTRIES FONT FONTHEIGHT LABEL-W INDEX-W BIGBOX-H YOFFSET REGION XOFFSET BIGBOX-W XLBLOFFSET YLBLOFFSET X Y LASTBOX NEXTBOX XVISIBLE YVISIBLE) (SETQ DSP (fetch (QEDITOR DSP) of QEDITOR)) (SETQ ENTRIES (fetch (QEDITOR ENTRIES) of QEDITOR)) (SETQ FONT (fetch (QEDITOR LABELFONT) of QEDITOR)) (SETQ FONTHEIGHT (FONTHEIGHT FONT)) (SETQ LABEL-W (QE-MAX-LABEL-WIDTH QEDITOR)) (SETQ INDEX-W (QE-MAX-INDEX-WIDTH QEDITOR)) (SETQ BIGBOX-H (QUOTIENT (TIMES FONTHEIGHT 7) 2)) (SETQ YOFFSET (ADD1 (QUOTIENT BIGBOX-H 2))) (SETQ BIGBOX-W (PLUS LABEL-W INDEX-W 8)) (SETQ XOFFSET (PLUS INDEX-W 8)) (SETQ REGION (DSPCLIPPINGREGION NIL DSP)) (SETQ XVISIBLE (ADD1 (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of REGION) BIGBOX-W) XOFFSET))) (SETQ YVISIBLE (ADD1 (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of REGION) BIGBOX-H) YOFFSET))) (if (LESSP YVISIBLE XVISIBLE) then (LET ((NEWXOFFSET (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of REGION) BIGBOX-W) YVISIBLE))) (add BIGBOX-W (DIFFERENCE NEWXOFFSET XOFFSET)) (SETQ XOFFSET NEWXOFFSET))) (SETQ XLBLOFFSET 3) (SETQ YLBLOFFSET (DIFFERENCE BIGBOX-H (PLUS FONTHEIGHT 2))) (SETQ X 4) (SETQ Y 4) (for ENTRY in ENTRIES as I from 1 do (replace (QENTRY INDEX) of ENTRY with I) (SETQ LASTBOX NEXTBOX) (SETQ NEXTBOX (CREATEREGION X Y BIGBOX-W BIGBOX-H)) (replace (QENTRY BIGBOX) of ENTRY with NEXTBOX) (replace (QENTRY INVBOX) of ENTRY with (CREATEREGION (ADD1 X) (ADD1 Y) (DIFFERENCE BIGBOX-W 2) (DIFFERENCE BIGBOX-H 2))) (LET ((LABEL-X (PLUS X XLBLOFFSET)) (LABEL-Y (PLUS Y YLBLOFFSET))) (replace (QENTRY LBLBOX) of ENTRY with (CREATEREGION LABEL-X LABEL-Y LABEL-W FONTHEIGHT))) (SETQ INDEX-W (STRINGWIDTH I FONT)) (LET ((INDEX-X (DIFFERENCE (PLUS X BIGBOX-W) (PLUS INDEX-W 4))) (INDEX-Y (PLUS Y 3))) (replace (QENTRY ORDBOX) of ENTRY with (CREATEREGION INDEX-X INDEX-Y INDEX-W FONTHEIGHT))) (if LASTBOX then (with REGION (INTERSECTREGIONS LASTBOX NEXTBOX) (replace (QENTRY OBSBOX) of ENTRY with (CREATEREGION (ADD1 LEFT) (ADD1 BOTTOM) WIDTH HEIGHT)))) (add X XOFFSET) (add Y YOFFSET)) (QE-ADJUST-SCROLL-PARAMS QEDITOR (PLUS X BIGBOX-W) (PLUS Y BIGBOX-H) XOFFSET YOFFSET))) ) (QE-PROMPTPRINT (LAMBDA PROMPTCNT (* Koomen "22-Jan-88 14:28") (if (LESSP PROMPTCNT 1) then (SHOULDNT "Missing QEditor arg") else (LET ((QEDITOR (ARG PROMPTCNT 1))) (if (type? QEDITOR QEDITOR) then (LET ((PROMPTW (fetch (QEDITOR PROMPTWINDOW) of QEDITOR))) (CLEARW PROMPTW) (for I from 2 to PROMPTCNT do (printout PROMPTW (ARG PROMPTCNT I)))) else (TERPRI PROMPTWINDOW) (for I from 2 to PROMPTCNT do (printout PROMPTWINDOW (ARG PROMPTCNT I))) (TERPRI PROMPTWINDOW))))) ) (QE-REDISPLAY-ENTRY (LAMBDA (QEDITOR ENTRY) (* ; "Edited 21-Jan-88 23:39 by Koomen") (* ;; "ENTRY's label has changed, so deselect if necessary and reprint label") (DECLARE (GLOBALVARS BLACKSHADE)) (if (fetch (QENTRY VISIBLE?) of ENTRY) then (QE-TOGGLE-ENTRY QEDITOR ENTRY) (PROG ((DSP (fetch (QEDITOR DSP) of QEDITOR)) (LBLBOX (fetch (QENTRY LBLBOX) of ENTRY))) (DSPFILL LBLBOX WHITESHADE (QUOTE REPLACE) DSP) (with REGION LBLBOX (MOVETO LEFT BOTTOM DSP)) (PRINTOUT DSP (fetch (QENTRY LABEL) of ENTRY))))) ) (QE-RELEASE-EDITOR (LAMBDA (QEDITOR) (* Koomen "22-Jan-88 14:43") (* ;; "Done editing, so squirrel it away for future use. Break the circular links for GC purposes ") (DECLARE (GLOBALVARS *QEDITORS*)) (LET ((QEDITMENU (fetch (QEDITOR MENU) of QEDITOR)) (QEDITWINDOW (fetch (QEDITOR WINDOW) of QEDITOR)) (PROMPTW (fetch (QEDITOR PROMPTWINDOW) of QEDITOR))) (PUTMENUPROP QEDITMENU (QUOTE QEDITOR) NIL) (WINDOWPROP QEDITWINDOW (QUOTE QEDITOR) NIL) (if (OPENWP QEDITWINDOW) then (CLOSEW QEDITWINDOW)) (if (OPENWP PROMPTW) then (CLOSEW PROMPTW)) (replace (QEDITOR QUEUE) of QEDITOR with (QUOTE RELEASED)))) ) (QE-REPAINTFN (LAMBDA (WINDOW) (* ; "Edited 21-Jan-88 22:12 by Koomen") (PROG ((QEDITOR (WINDOWPROP WINDOW (QUOTE QEDITOR)))) (if QEDITOR then (QE-DISPLAY-ENTRIES QEDITOR)))) ) (QE-RESET-DSP (LAMBDA (QEDITOR) (* ; "Edited 21-Jan-88 22:01 by Koomen") (PROG* ((DSP (fetch (QEDITOR DSP) of QEDITOR))) (DSPRIGHTMARGIN MAX.SMALLP DSP) (DSPFILL NIL NIL NIL DSP) (with REGION (DSPCLIPPINGREGION NIL DSP) (MOVETO (PLUS LEFT 4) (DIFFERENCE TOP (PLUS (FONTHEIGHT (fetch (QEDITOR LABELFONT) of QEDITOR)) 2)) DSP)) (printout DSP (fetch (QEDITOR ENTRYCNT) of QEDITOR) " elements"))) ) (QE-RESHAPEFN (LAMBDA (WINDOW OLDBM OLDREG) (* ; "Edited 21-Jan-88 22:07 by Koomen") (PROG ((QEDITOR (WINDOWPROP WINDOW (QUOTE QEDITOR)))) (if QEDITOR then (QE-PLACE-ENTRIES QEDITOR) (QE-DISPLAY-ENTRIES QEDITOR) else (BITBLT OLDBM (fetch (REGION LEFT) of OLDREG) (fetch (REGION BOTTOM) of OLDREG) WINDOW)))) ) (QE-RUN-EDITOR (LAMBDA (QEDITOR) (* Koomen "22-Jan-88 13:38") (while T bind COMMAND first (QE-CREATE-ENTRIES QEDITOR) (QE-PLACE-ENTRIES QEDITOR) (QE-DISPLAY-ENTRIES QEDITOR) eachtime (BLOCK) when (SETQ COMMAND (fetch (QEDITOR COMMAND) of QEDITOR)) do (QE-PROMPTPRINT QEDITOR) (SELECTQ COMMAND (Left (OR (QE-FOCUS-SELECTION QEDITOR COMMAND) (QE-CMD-LEFT QEDITOR))) (Right (OR (QE-FOCUS-SELECTION QEDITOR COMMAND) (QE-CMD-RIGHT QEDITOR))) (Insert (OR (QE-FOCUS-SELECTION QEDITOR COMMAND) (QE-CMD-INSERT QEDITOR))) (Edit (OR (QE-FOCUS-SELECTION QEDITOR COMMAND) (QE-CMD-EDIT QEDITOR))) (Delete (OR (QE-FOCUS-SELECTION QEDITOR COMMAND) (QE-CMD-DELETE QEDITOR))) (Abort (RETURN (fetch (QEDITOR QUEUE) of QEDITOR))) (Done (RETURN (QE-COLLECT-QUEUE QEDITOR))) (Display (QE-DISPLAY-ENTRIES QEDITOR)) (QE-PROMPTPRINT QEDITOR "Queue Editor command `" COMMAND "' not yet implemented.")) (replace (QEDITOR COMMAND) of QEDITOR with NIL))) ) (QE-SCROLLFN (LAMBDA (WINDOW XDELTA YDELTA CONTINUOUSFLG) (* ; "Edited 22-Jan-88 00:20 by Koomen") (* ;; "Adjust XDELTA and YDELTA such that scrolling always takes place along the diagonal axis, rather than along the horizontal or vertical axes") (PROG (QEDITOR DSP XOFFSET YOFFSET OLDREG NEWREG EXTENT TOSTARTFLG THUMBFLG DX DY) (SETQ QEDITOR (WINDOWPROP WINDOW (QUOTE QEDITOR))) (if (NULL QEDITOR) then (RETURN)) (SETQ DSP (fetch (QEDITOR DSP) of QEDITOR)) (SETQ XOFFSET (fetch (QEDITOR XOFFSET) of QEDITOR)) (SETQ YOFFSET (fetch (QEDITOR YOFFSET) of QEDITOR)) (SETQ OLDREG (DSPCLIPPINGREGION NIL DSP)) (SETQ NEWREG (COPY OLDREG)) (SETQ EXTENT (WINDOWPROP WINDOW (QUOTE EXTENT))) (if (LESSP XDELTA 0) then (SETQ TOSTARTFLG T) (SETQ DX (MINUS XDELTA)) else (SETQ DX XDELTA)) (if (LESSP YDELTA 0) then (SETQ TOSTARTFLG T) (SETQ DY (MINUS YDELTA)) else (SETQ DY YDELTA)) (if CONTINUOUSFLG then (SETQ DX XOFFSET) (SETQ DY YOFFSET) elseif (FLOATP DX) then (SETQ DY DX) (SETQ THUMBFLG T) elseif (FLOATP DY) then (SETQ DX (SETQ DY (DIFFERENCE 1 DY))) (SETQ THUMBFLG T) elseif (ZEROP DX) then (SETQ DX (QUOTIENT (TIMES DY XOFFSET) YOFFSET)) else (SETQ DY (QUOTIENT (TIMES DX YOFFSET) XOFFSET))) (replace (REGION LEFT) of NEWREG with (if THUMBFLG then (FIX (DIFFERENCE (TIMES DX (fetch (REGION WIDTH) of EXTENT)) (TIMES 0.5 (fetch (REGION WIDTH) of NEWREG)))) elseif TOSTARTFLG then (PLUS (fetch (REGION LEFT) of NEWREG) DX) else (DIFFERENCE (fetch (REGION LEFT) of NEWREG) DX))) (replace (REGION BOTTOM) of NEWREG with (if THUMBFLG then (FIX (DIFFERENCE (TIMES DY (fetch (REGION HEIGHT) of EXTENT)) (TIMES 0.5 (fetch (REGION HEIGHT) of NEWREG)))) elseif TOSTARTFLG then (PLUS (fetch (REGION BOTTOM) of NEWREG) DY) else (DIFFERENCE (fetch (REGION BOTTOM) of NEWREG) DY))) (MAKEWITHINREGION NEWREG (WINDOWPROP WINDOW (QUOTE EXTENT))) (if (NOT (EQUAL NEWREG OLDREG)) then (PROG ((NEWDSPX (PLUS (DSPXOFFSET NIL DSP) (DIFFERENCE (fetch (REGION LEFT) of OLDREG) (fetch (REGION LEFT) of NEWREG)))) (NEWDSPY (PLUS (DSPYOFFSET NIL DSP) (DIFFERENCE (fetch (REGION BOTTOM) of OLDREG) (fetch (REGION BOTTOM) of NEWREG))))) (UNINTERRUPTABLY (DSPCLIPPINGREGION NEWREG DSP) (DSPXOFFSET NEWDSPX DSP) (DSPYOFFSET NEWDSPY DSP))) (QE-DISPLAY-ENTRIES QEDITOR)))) ) (QE-SELECT-ENTRY (LAMBDA (QEDITOR NEW-SELECTION) (* ; "Edited 21-Jan-88 23:56 by Koomen") (LET ((OLD-SELECTION (fetch (QEDITOR SELECTION) of QEDITOR))) (if OLD-SELECTION then (QE-TOGGLE-ENTRY QEDITOR OLD-SELECTION)) (if NEW-SELECTION then (QE-TOGGLE-ENTRY QEDITOR NEW-SELECTION T)) (replace (QEDITOR SELECTION) of QEDITOR with NEW-SELECTION) (if (AND NEW-SELECTION (NEQ NEW-SELECTION OLD-SELECTION)) then (QE-FOCUS-SELECTION QEDITOR)) NEW-SELECTION)) ) (QE-SLIDE-ENTRY (LAMBDA (QEDITOR ENTRY BUTTON) (* Koomen "22-Jan-88 14:43") (* ;; "Selects ENTRY.") (* ;; "If BUTTON = LEFT and mouse leaves ENTRY's region, deselects ENTRY and returns.") (* ;; "If BUTTON = MIDDLE and mouse leaves ENTRY's region on the right, moves selection to the right if possible and loops.") (* ;; "If BUTTON = MIDDLE and mouse leaves ENTRY's region on the left, moves selection to the left if possible and loops.") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY)) (bind X Y REG (L-OK _ T) (R-OK _ T) (QR _ (WINDOWREGION (fetch (QEDITOR WINDOW) of QEDITOR))) first (QE-PROMPTPRINT QEDITOR) (QE-SELECT-ENTRY QEDITOR ENTRY) while (AND ENTRY (if (EQ BUTTON (QUOTE LEFT)) then (MOUSESTATE (ONLY LEFT)) elseif (EQ BUTTON (QUOTE MIDDLE)) then (MOUSESTATE (ONLY MIDDLE)))) do (SETQ REG (fetch (QENTRY BIGBOX) of ENTRY)) (SETQ X (LASTMOUSEX (fetch (QEDITOR WINDOW) of QEDITOR))) (SETQ Y (LASTMOUSEY (fetch (QEDITOR WINDOW) of QEDITOR))) (if (INSIDEP REG X Y) then (* ; "sit tight") elseif (EQ BUTTON (QUOTE LEFT)) then (QE-SELECT-ENTRY QEDITOR) (RETURN) elseif (NOT (INSIDEP QR LASTMOUSEX LASTMOUSEY)) then (* ; "sit tight") elseif (AND (LESSP X (fetch (REGION LEFT) of REG)) (LESSP Y (fetch (REGION TOP) of REG))) then (if L-OK then (QE-PROMPTPRINT QEDITOR) (if (EQ ENTRY (SETQ ENTRY (QE-CMD-LEFT QEDITOR))) then (SETQ L-OK) else (SETQ R-OK T))) elseif (AND (GREATERP X (fetch (REGION RIGHT) of REG)) (GREATERP Y (fetch (REGION BOTTOM) of REG))) then (if R-OK then (QE-PROMPTPRINT QEDITOR) (if (EQ ENTRY (SETQ ENTRY (QE-CMD-RIGHT QEDITOR))) then (SETQ R-OK) else (SETQ L-OK T)))))) ) (QE-TOGGLE-ENTRY (LAMBDA (QEDITOR ENTRY SELECT?) (* ; "Edited 21-Jan-88 23:17 by Koomen") (if (AND (fetch (QENTRY VISIBLE?) of ENTRY) (NEQ SELECT? (fetch (QENTRY SELECTED?) of ENTRY))) then (LET ((DSP (fetch (QEDITOR DSP) of QEDITOR)) (BOX (fetch (QENTRY INVBOX) of ENTRY))) (DSPFILL BOX BLACKSHADE (QUOTE INVERT) DSP) (if (SETQ BOX (fetch (QENTRY OBSBOX) of ENTRY)) then (DSPFILL BOX BLACKSHADE (QUOTE INVERT) DSP))) (replace (QENTRY SELECTED?) of ENTRY with SELECT?))) ) (QE-UNMARKASCHANGED (LAMBDA (QEDITOR) (* ; "Edited 27-Nov-87 17:11 by Koomen") (replace (QEDITOR CHANGES?) of QEDITOR with NIL) (WINDOWPROP (fetch (QEDITOR WINDOW) of QEDITOR) (fetch (QEDITOR TITLE) of QEDITOR)) QEDITOR) ) (QE-WHENSELECTEDFN (LAMBDA (ITEM MENU) (* Koomen "11-Dec-87 14:53") (* ; "Edited 25-Nov-87 16:53 by Koomen") (PROG ((QEDITOR (GETMENUPROP MENU (QUOTE QEDITOR)))) (if QEDITOR then (if (fetch (QEDITOR COMMAND) of QEDITOR) then (QE-PROMPTPRINT QEDITOR "Queue Editor busy, executing `" (fetch (QEDITOR COMMAND) of QEDITOR) "'") else (replace (QEDITOR COMMAND) of QEDITOR with (CADR ITEM)))))) ) ) (RPAQ? *QEDITORS* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *QEDITORS*) ) (PUTPROPS QEDIT FILETYPE :TCOMPL) (PUTPROPS QEDIT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA QE-PROMPTPRINT) ) (PUTPROPS QEDIT COPYRIGHT ("Johannes A. G. M. Koomen" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2284 3923 (QEDIT 2294 . 3393) (QEDIT.CURRENT.QUEUE 3395 . 3624) (QEDIT.RESET 3626 . 3921)) (6458 29869 (QE-ACQUIRE-EDITOR 6468 . 6757) (QE-ADJUST-SCROLL-PARAMS 6759 . 7074) ( QE-BUTTONEVENTFN 7076 . 7473) (QE-CLOSEFN 7475 . 7752) (QE-CMD-INSERT 7754 . 8729) (QE-CMD-EDIT 8731 . 9521) (QE-CMD-DELETE 9523 . 10342) (QE-CMD-LEFT 10344 . 11172) (QE-CMD-RIGHT 11174 . 11883) ( QE-COLLECT-QUEUE 11885 . 12046) (QE-COMPUTE-LABEL 12048 . 12538) (QE-CREATE-EDITOR 12540 . 13726) ( QE-CREATE-ENTRIES 13728 . 14085) (QE-CREATE-ENTRY 14087 . 14222) (QE-DISPLAY-ENTRIES 14224 . 14497) ( QE-DISPLAY-ENTRIES-AUX 14499 . 14832) (QE-DISPLAY-ENTRY 14834 . 15433) (QE-FOCUS-SELECTION 15435 . 16046) (QE-INIT-EDITOR 16048 . 17267) (QE-MARKASCHANGED 17269 . 17598) (QE-MARK-VISIBLE-ENTRIES 17600 . 18037) (QE-MAX-INDEX-WIDTH 18039 . 18222) (QE-MAX-LABEL-WIDTH 18224 . 18499) (QE-MOUSE-IN-ENTRYP 18501 . 18727) (QE-MOUSED-ENTRY 18729 . 18890) (QE-PLACE-ENTRIES 18892 . 21068) (QE-PROMPTPRINT 21070 . 21540) (QE-REDISPLAY-ENTRY 21542 . 22050) (QE-RELEASE-EDITOR 22052 . 22656) (QE-REPAINTFN 22658 . 22834) (QE-RESET-DSP 22836 . 23230) (QE-RESHAPEFN 23232 . 23541) (QE-RUN-EDITOR 23543 . 24470) ( QE-SCROLLFN 24472 . 26710) (QE-SELECT-ENTRY 26712 . 27164) (QE-SLIDE-ENTRY 27166 . 28777) ( QE-TOGGLE-ENTRY 28779 . 29251) (QE-UNMARKASCHANGED 29253 . 29475) (QE-WHENSELECTEDFN 29477 . 29867)))) ) STOP \ No newline at end of file diff --git a/lispusers/QEDIT.TEDIT b/lispusers/QEDIT.TEDIT new file mode 100644 index 00000000..078db77c Binary files /dev/null and b/lispusers/QEDIT.TEDIT differ diff --git a/lispusers/QIX b/lispusers/QIX new file mode 100644 index 00000000..7440766e --- /dev/null +++ b/lispusers/QIX @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "12-Aug-87 03:05:50" {PHYLUM}LISP>QIX.\;3 11097 |changes| |to:| (VARS QIXCOMS) |previous| |date:| " 1-Aug-87 17:04:27" {PHYLUM}LISP>QIX.\;2) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT QIXCOMS) (RPAQQ QIXCOMS ((FNS QIX.GROW QIX.IDLE QIX.MOVE.POINT QIX.PLAY) (RECORDS QIX.POINT) (P (SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE) IDLE.FUNCTIONS))))) (DEFINEQ (QIX.GROW (LAMBDA (WINDOW DONTDISMISS) (* \; "Edited 1-Aug-87 16:57 by JEFF.SHRAGER") (* * |This| |sets| |up| \a QIX |the| |specified| |window.|  |The| |QIX's| |parameters| |are| |defined| |at| |random,| |but| |with|  |reasonable| |value| |ranges.| |The| |dismiss| |argument| |tell| |the| QIX  |whether| |to| DISMISS |every| |cycle| |or| |not.|  B\e |careful.|) (PROG (P P2 (W (OR WINDOW (CREATEW))) L) (SETQ *STOP.QIXS* NIL) (* * P |and| P2 |define| \a QIX.) (SETQ P (|create| QIX.POINT X _ (RAND 1 200) Y _ (RAND 1 100) VH _ (RAND 1 20) VV _ (RAND 1 20))) (SETQ P2 (|create| QIX.POINT X _ (RAND 1 200) Y _ (RAND 1 100) VH _ (RAND 1 20) VV _ (RAND 1 20))) (* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|  |gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|  |own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|) (SETQ L (APPEND (|for| X |from| 1 |to| (RAND 5 25) |collect| (COPY '(A S D F))) (LIST (LIST (|fetch| X P) (|fetch| Y P) (|fetch| X P2) (|fetch| Y P2))))) (RPLACD (LAST L) L) LOOP (COND (*STOP.QIXS* (RPLACD L NIL) (RETURN NIL))) (* * |Draw| |the| |QIX's| |head| |line.|) (MOVETO (|fetch| X P) (|fetch| Y P) W) (DRAWTO (|fetch| X P2) (|fetch| Y P2) 1 'REPLACE W) (* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|) (QIX.MOVE.POINT P W) (QIX.MOVE.POINT P2 W) (* * |Take| \a |deep| |breath| |if| |the| |user| |asks| |you| |to.|  |This| |slows| |things| |down.|) (OR DONTDISMISS (DISMISS)) (* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|) (COND ((EQ (CAAR L) 'A)) (T (PROG ((OLD (CAR L))) (MOVETO (CAR OLD) (CADR OLD) W) (DRAWTO (CADDR OLD) (CADDDR OLD) 1 'ERASE W)))) (* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|  |effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we|  |them| |immediately| |move| |to| |the| |next| |elt| |in| |this| |circular|  |list.|) (RPLACA (CAR L) (|fetch| X P)) (RPLACA (CDAR L) (|fetch| Y P)) (RPLACA (CDDAR L) (|fetch| X P2)) (RPLACA (CDDDAR L) (|fetch| Y P2)) (SETQ L (CDR L)) (GO LOOP)))) (QIX.IDLE (LAMBDA (W) (* \; "Edited 1-Aug-87 16:58 by JEFF.SHRAGER") (* * CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND  (WASTING SPACE) FROM BEFORE.) (AND (BOUNDP '*OLD-QIXS*) (FOR Q IN *OLD-QIXS* DO (RPLACD Q NIL))) (PROG (P P2 L QIXS) (* * P |and| P2 |define| \a QIX.) (SETQ QIXS (|for| I |from| 1 |to| 5 |collect| (PROGN (SETQ P (|create| QIX.POINT X _ (RAND 1 200) Y _ (RAND 1 100) VH _ (RAND 1 20) VV _ (RAND 1 20))) (SETQ P2 (|create| QIX.POINT X _ (RAND 1 200) Y _ (RAND 1 100) VH _ (RAND 1 20) VV _ (RAND 1 20))) (* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|  |gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|  |own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|) (SETQ L (APPEND (|for| X |from| 1 |to| (RAND 5 25) |collect| (COPY '(A S D F))) (LIST (LIST (|fetch| X P) (|fetch| Y P) (|fetch| X P2) (|fetch| Y P2))))) (RPLACD (LAST L) L) (LIST P P2 L)))) (SETQ *OLD-QIXS* QIXS) LOOP (DISMISS) (|for| Q |in| QIXS |do| (SETQ P (CAR Q)) (SETQ P2 (CADR Q)) (SETQ L (CADDR Q)) (* * |Draw| |the| |QIX's| |head| |line.|) (MOVETO (|fetch| X P) (|fetch| Y P) W) (DRAWTO (|fetch| X P2) (|fetch| Y P2) 1 'REPLACE W) (* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|) (QIX.MOVE.POINT P W) (QIX.MOVE.POINT P2 W) (* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|) (COND ((EQ (CAAR L) 'A)) (T (PROG ((OLD (CAR L))) (MOVETO (CAR OLD) (CADR OLD) W) (DRAWTO (CADDR OLD) (CADDDR OLD) 1 'ERASE W)))) (* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|  |effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we| THEN  |immediately| |move| |to| |the| |next| |elt| |in| |this| |circular| |list.|) (RPLACA (CAR L) (|fetch| X P)) (RPLACA (CDAR L) (|fetch| Y P)) (RPLACA (CDDAR L) (|fetch| X P2)) (RPLACA (CDDDAR L) (|fetch| Y P2)) (RPLACA (CDDR Q) (CDR L))) (GO LOOP)))) (QIX.MOVE.POINT (LAMBDA (P W) (* |edited:| "16-May-85 00:39") (* * |This| |guy| |updates| |the| QIX |line| |endpoints| |according| |to|  |their| |velocities| |in| |the| X |and| Y |directions.|  I\f |we| |hit| \a |wall,| |then| |simply| |negate| |the| |relevant| |velocity|  |vector.|) (PROG ((VV (|fetch| VV P)) (VH (|fetch| VH P)) (X (|fetch| X P)) (Y (|fetch| Y P))) (PROG ((NEWX (IPLUS X VH)) (NEWY (IPLUS Y VV))) (COND ((LESSP NEWY 0) (SETQ NEWY 0) (SETQ VV (ITIMES -1 VV))) ((GREATERP NEWY (WINDOWPROP W 'HEIGHT)) (SETQ NEWY (WINDOWPROP W 'HEIGHT)) (SETQ VV (ITIMES -1 VV)))) (COND ((LESSP NEWX 0) (SETQ NEWX 0) (SETQ VH (ITIMES -1 VH))) ((GREATERP NEWX (WINDOWPROP W 'WIDTH)) (SETQ NEWX (WINDOWPROP W 'WIDTH)) (SETQ VH (ITIMES -1 VH)))) (|replace| Y P NEWY) (|replace| X P NEWX) (|replace| VV P VV) (|replace| VH P VH))))) (QIX.PLAY (LAMBDA (N) (* |Jeff.Shrager| " 8-Sep-85 14:01") (* "Jeff Shrager" "24-May-84 22:17") (* |This| |takes| |over| |the| |screen| |and| |sets| |up| \a |number| |of| QIX  |on| |it.| I\t |also| |hangs| |itself| |at| |the| |end| |so| |that| |the| TTY  |window| |doesn't| |come| |to| |the| |surface.|) (PROG ((W (CREATEW '(0 0 1024 830) NIL 1))) (|for| X |from| 1 |to| N |do| (ADD.PROCESS (LIST 'QIX.GROW (KWOTE W)))) (UNTILMOUSESTATE (AND LEFT RIGHT MIDDLE))))) ) (DECLARE\: EVAL@COMPILE (RECORD QIX.POINT (X Y VH VV)) ) (SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE) IDLE.FUNCTIONS)) (PUTPROPS QIX COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (539 10893 (QIX.GROW 549 . 4105) (QIX.IDLE 4107 . 8821) (QIX.MOVE.POINT 8823 . 10205) ( QIX.PLAY 10207 . 10891))))) STOP \ No newline at end of file diff --git a/lispusers/READAIS b/lispusers/READAIS new file mode 100644 index 00000000..5c40b1e5 --- /dev/null +++ b/lispusers/READAIS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Apr-88 17:04:57" {ERINYES}MEDLEY>READAIS.;1 48154 changes to%: (FNS AISBLT AISBLT1TO1 24BITCOLORTO8BITMAP AISBLT8TO4MODUL AISBLT8TOLESSFSA AISBLT8TO4TRUNC AISBLT8TO8 AISBLT4TO4 AISBLT8TO4LESSFSA AISBLT8TO1FSA AISBLT8TO1TRUNC CLOSEST.COLOR GRAPHAISHISTOGRAM AISHISTOGRAM SMOOTHEDFILTER SLOW.COLOR.DISTANCE FAST.COLOR.DISTANCE INSUREAISFILE SHOWCOLORAIS SHOWCOLORAIS1 WRITEAIS WRITEAIS1 \GETBASENYBBLE \PUTBASENYBBLE) (VARS READAISCOMS) previous date%: "27-Apr-88 12:12:58" {QV}LISP>MEDLEY>READAIS.;2) (* " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT READAISCOMS) (RPAQQ READAISCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NYBBLESPERWORD 4))) (* ;; "fixed INSUREAISFILE, AISBLT, AISBLT8TO8. nhb 27-Apr-88 01:58:56") (FNS 24BITCOLORTO8BITMAP AISBLT AISBLT1TO1 AISBLT8TO4MODUL AISBLT8TOLESSFSA AISBLT8TO4TRUNC AISBLT8TO8 AISBLT4TO4 AISBLT8TO4LESSFSA AISBLT8TO1FSA AISBLT8TO1TRUNC CLOSEST.COLOR GRAPHAISHISTOGRAM AISHISTOGRAM SMOOTHEDFILTER SLOW.COLOR.DISTANCE FAST.COLOR.DISTANCE INSUREAISFILE SHOWCOLORAIS SHOWCOLORAIS1 WRITEAIS WRITEAIS1 \GETBASENYBBLE \PUTBASENYBBLE) (MACROS .GET.4BIT.AND.SPREAD.ERR. .GET.1BIT.AND.SPREAD.ERR. .GET.NBIT.AND.SPREAD.ERR. .GET.LEFTMOST.4BIT .GET.LEFTMOST.BIT. .GET.BESTCOLOR.AND.SPREAD.ERR. .4BIT.MODULATE.INTENSITY.VALUE. .MODULATE.INTENSITY.VALUE. SQUARE) (P (MOVD? (QUOTE FAST.COLOR.DISTANCE) (QUOTE COLOR.DISTANCE))) (VARS AISDIRECTORIES) (GLOBALVARS AISDIRECTORIES))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ NYBBLESPERWORD 4) (CONSTANTS (NYBBLESPERWORD 4)) ) ) (* ;; "fixed INSUREAISFILE, AISBLT, AISBLT8TO8. nhb 27-Apr-88 01:58:56") (DEFINEQ (24BITCOLORTO8BITMAP (LAMBDA (REDSTREAM GREENSTREAM BLUESTREAM WIDTH HEIGHT BASE BYTESPERLINE BITMAPRASTERWIDTH COLORMAP) (* kbr%: "13-Jul-85 19:28") (* internal function that puts pixels from an ais file into an 8 bit per pixel bitmap) (DECLARE (LOCALVARS . T)) (PROG (LINEBASE DATABEG NEXTLINEREDERRORTABLE NEXTLINEGREENERRORTABLE NEXTLINEBLUEERRORTABLE THISPIXELREDERROR REDERRTABLEPTR THISPIXELGREENERROR GREENERRTABLEPTR THISPIXELBLUEERROR BLUEERRTABLEPTR REDBYTE GREENBYTE BLUEBYTE ERR COLOR RGB) (SETQ LINEBASE BASE) (SETQ DATABEG (GETFILEPTR REDSTREAM)) (SETQ NEXTLINEREDERRORTABLE (\ALLOCBLOCK (ADD1 WIDTH) T)) (SETQ NEXTLINEGREENERRORTABLE (\ALLOCBLOCK (ADD1 WIDTH) T)) (SETQ NEXTLINEBLUEERRORTABLE (\ALLOCBLOCK (ADD1 WIDTH) T)) (* error tables are 1 larger so no end check is necessary in error propagation code.) (* initialize error tables.) (for I from 0 to (ITIMES WIDTH 2) by 2 do (\PUTBASEPTR NEXTLINEREDERRORTABLE I 0)) (for I from 0 to (ITIMES WIDTH 2) by 2 do (\PUTBASEPTR NEXTLINEGREENERRORTABLE I 0)) (for I from 0 to (ITIMES WIDTH 2) by 2 do (\PUTBASEPTR NEXTLINEBLUEERRORTABLE I 0)) (* set width to width in words.) (SETQ WIDTH (LRSH WIDTH 1)) (for Y from 0 to (ITIMES (SUB1 HEIGHT) BYTESPERLINE) by BYTESPERLINE do (SETQ BASE LINEBASE) (SETQ REDERRTABLEPTR NEXTLINEREDERRORTABLE) (SETQ THISPIXELREDERROR (\GETBASEPTR REDERRTABLEPTR 0)) (\PUTBASEPTR REDERRTABLEPTR 0 0) (SETQ GREENERRTABLEPTR NEXTLINEGREENERRORTABLE) (SETQ THISPIXELGREENERROR (\GETBASEPTR GREENERRTABLEPTR 0)) (\PUTBASEPTR GREENERRTABLEPTR 0 0) (SETQ BLUEERRTABLEPTR NEXTLINEBLUEERRORTABLE) (SETQ THISPIXELBLUEERROR (\GETBASEPTR BLUEERRTABLEPTR 0)) (\PUTBASEPTR BLUEERRTABLEPTR 0 0) (\SETFILEPTR REDSTREAM Y) (\SETFILEPTR GREENSTREAM Y) (\SETFILEPTR BLUESTREAM Y) (for X from 1 to WIDTH do (\PUTBASE BASE 0 (\PUTBASE BASE 0 (LOGOR (LLSH (.GET.BESTCOLOR.AND.SPREAD.ERR.) 8) (.GET.BESTCOLOR.AND.SPREAD.ERR.)))) (SETQ BASE (\ADDBASE BASE 1))) (SETQ LINEBASE (\ADDBASE LINEBASE BITMAPRASTERWIDTH))) (RETURN NIL))) ) (AISBLT (LAMBDA (FILE SOURCELEFT SOURCEBOTTOM DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT HOW FILTER NBITS LOBITADDRESS) (* ; "Edited 28-Apr-88 17:04 by Briggs") (* ;; "puts an ais image from FILE into a bitmap. The arguments are the same as BITBLTs where possible. HOW specifies how the number of bits per pixel is condensed if reduction is necessary; TRUNCATE is truncate; FSA is Floyd-Steinberg algorithm; MODULATE is modulated with a random function. If NBITS is given, the file is reduced to that number of bits and they are put into the byte so that the low order bit is at LOBITADDRESS.") (PROG (STREAM stodx stody left top bottom right width height DESTDD DESTSTRM SRASTERWIDTH SOURCEBASE DESTRASTERWIDTH DESTBASE BITSPERPIXEL BITSPERSAMPLE SFILEWIDTH SFILEHEIGHT DIRECTION TMP STARTSAMPLELINE STARTPIXEL BITOFFSET) (COND ((EQ NBITS 0) (RETURN))) (OR SOURCELEFT (SETQ SOURCELEFT 0)) (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0)) (OR DESTLEFT (SETQ DESTLEFT 0)) (OR DESTBOTTOM (SETQ DESTBOTTOM 0)) (OR HOW (SETQ HOW (QUOTE FSA))) (OR LOBITADDRESS (SETQ LOBITADDRESS 0)) (COND ((OR (SETQ STREAM (FINDFILE FILE NIL AISDIRECTORIES)) (SETQ STREAM FILE)) (SETQ STREAM (OPENSTREAM STREAM (QUOTE INPUT))))) (* ; "make sure the file is an AIS file and read its bits per sample, width and height.") (SETQ TMP (INSUREAISFILE STREAM)) (SETQ BITSPERSAMPLE (CAR TMP)) (SETQ SFILEWIDTH (CADR TMP)) (SETQ SFILEHEIGHT (CADDR TMP)) (* ; "convert the words per sample line into bytes") (SETQ SRASTERWIDTH (CADDDR TMP)) (SETQ DIRECTION (CADDDR (CDR TMP))) (COND ((NOT (EQ DIRECTION 3)) (ERROR "Scan direction is not top-left to bottom-right" DIRECTION))) (COND ((type? BITMAP DESTINATION) (SETQ left 0) (SETQ bottom 0) (SETQ right (SUB1 (fetch (BITMAP BITMAPWIDTH) of DESTINATION))) (SETQ top (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION)))) ((\GETDISPLAYDATA DESTINATION) (COND ((NEQ BITSPERSAMPLE 1) (ERROR "Sorry, can't AISBLT to window if source is not 1 bpp"))) (LET ((REGION (DSPCLIPPINGREGION NIL DESTINATION))) (* ; "compute limits based on clipping regions.") (SETQ left (fetch (REGION LEFT) of REGION)) (SETQ bottom (fetch (REGION BOTTOM) of REGION)) (SETQ right (fetch (REGION PRIGHT) of REGION)) (SETQ top (fetch (REGION PTOP) of REGION))))) (* ;; "left, bottom, right, top are in destination coordinates, and describe the bounding region") (* ;; "right and top are the pixel number counting from 0 of the last useable pixel") (* ;; "DESTLEFT and DESTBOTTOM have been transformed into the destination coordinates") (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (COND ((NULL NBITS) (SETQ NBITS BITSPERPIXEL)) ((IGREATERP NBITS BITSPERPIXEL) (ERROR "Can't put this many bits into this bitmap" NBITS)) ((IGREATERP (IPLUS LOBITADDRESS NBITS) BITSPERPIXEL) (\ILLEGAL.ARG LOBITADDRESS))) (* ;; "reduce the region if required by user's DESTLEFT and DESTBOTTOM or WIDTH and HEIGHT") (PROGN (SETQ left (IMAX DESTLEFT left)) (SETQ bottom (IMAX DESTBOTTOM bottom)) (COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTLEFT WIDTH) right)))) (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTBOTTOM HEIGHT) top))))) (SETQ stodx (IDIFFERENCE DESTLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTBOTTOM SOURCEBOTTOM)) (* ;; "reduce by boundary of source (0,0) -- (sfilewidth, sfileheight)") (PROGN (SETQ left (IMAX 0 left)) (SETQ bottom (IMAX 0 bottom)) (SETQ right (IMIN (IPLUS stodx SFILEWIDTH) right)) (SETQ top (IMIN (IPLUS stody SFILEHEIGHT) top))) (* ;; "calculate effective width and height") (SETQ width (ADD1 (IDIFFERENCE right left))) (SETQ height (ADD1 (IDIFFERENCE top bottom))) (COND ((OR (ILEQ width 0) (ILEQ height 0)) (* ; "left is past right or bottom is past top; there is nothing to transfer.") (CLOSEF STREAM) (RETURN))) (* ;; "compute the parameters for the ais file. This assumes the picture is scanned from upper left to lower right.") (* ;; "DESTBASE is the start of the TOP row") (* ;; "DESTRASTERWIDTH and DESTBASE are not used in the 1 bpp case (which is also the Window case)") (AND (BITMAPP DESTINATION) (SETQ DESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DESTINATION)) (SETQ DESTBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of DESTINATION) (ITIMES (\SFInvert DESTINATION top) DESTRASTERWIDTH)))) (* ;; "STARTSAMPLELINE is number of source sample lines to skip to get to correct data") (SETQ STARTSAMPLELINE (IDIFFERENCE bottom stody)) (* ;; "STARTPIXEL is number of pixels to skip to get to correct data") (SETQ STARTPIXEL (IDIFFERENCE left stodx)) (SELECTQ BITSPERSAMPLE (8 (COND ((EQ BITSPERPIXEL 8) (COND ((AND (EQ HOW (QUOTE FSA)) (NOT (EQ NBITS 8))) (AISBLT8TOLESSFSA STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height NBITS LOBITADDRESS)) (T (AISBLT8TO8 STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height NBITS LOBITADDRESS)))) ((EQ BITSPERPIXEL 4) (COND ((EQ HOW (QUOTE FSA)) (AISBLT8TO4LESSFSA STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height NBITS LOBITADDRESS)) ((EQ HOW (QUOTE TRUNCATE)) (AISBLT8TO4TRUNC STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height NBITS LOBITADDRESS)) ((EQ HOW (QUOTE MODULATE)) (AISBLT8TO4MODUL STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height NBITS LOBITADDRESS)) (T (ERROR "Unknown HOW argument")))) ((EQ BITSPERPIXEL 1) (COND ((EQ HOW (QUOTE FSA)) (* ; "default to Floyd-Steinberg algorithm when going to single bit.") (AISBLT8TO1FSA STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height)) ((EQ HOW (QUOTE TRUNCATE)) (AISBLT8TO1TRUNC STREAM width height DESTBASE DESTRASTERWIDTH left STARTSAMPLELINE SRASTERWIDTH BITOFFSET FILTER)) ((EQ HOW (QUOTE MODULATE)) (AISBLT8TO1FSA STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTBASE left DESTRASTERWIDTH width height)) (T (ERROR "Unknown HOW argument")))) (T (ERROR "Unknown bit per pixel size")))) (4 (COND ((EQ BITSPERPIXEL 8) (ERROR "8 BIT IMAGE FROM A 4 BIT FILE NOT IMPLEMENTED YET.")) ((EQ BITSPERPIXEL 4) (AISBLT4TO4 STREAM HOW width height DESTBASE DESTRASTERWIDTH left STARTSAMPLELINE SRASTERWIDTH NBITS LOBITADDRESS)) (T (ERROR "Blting from a 4 bit per sample file is only implemented for 4 or 8 bit per pixel bitmaps.")))) (1 (COND ((EQ BITSPERPIXEL 1) (AISBLT1TO1 STREAM STARTPIXEL STARTSAMPLELINE SRASTERWIDTH SFILEHEIGHT DESTINATION left bottom width height)) (T (ERROR "Can only go from a 1 bit sources to a 1 bit destination.")))) (ERROR "not a 4 or 8 bit per sample file")) (CLOSEF STREAM))) ) (AISBLT1TO1 (LAMBDA (STREAM SOURCEPIXEL STARTSAMPLELINE SRASTERWIDTH SOURCEHEIGHT DEST DESTLEFT DESTBOTTOM WIDTH HEIGHT) (* kbr%: "16-Jul-86 20:56") (* internal function that puts pixels from an ais file into an 1 bit per pixel bitmap *) (* Assumes file has been left pointing at the beginning of the data. *) (PROG (BYTESPERLINE DATABEG BEG END TEMPBITMAP TEMPBASE MAXX) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ END (IPLUS DATABEG (UNFOLD (IPLUS (FOLDLO SOURCEPIXEL BITSPERWORD) (ITIMES (IDIFFERENCE (SUB1 SOURCEHEIGHT) STARTSAMPLELINE) SRASTERWIDTH)) BYTESPERWORD))) (SETQ BEG (IDIFFERENCE END (ITIMES (SUB1 HEIGHT) BYTESPERLINE))) (* Avoid complications of boundary alignment and clipping by using TEMPBITMAP buffer and BITBLT *) (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS BITSPERWORD WIDTH BITSPERWORD) 1)) (SETQ TEMPBASE (fetch (BITMAP BITMAPBASE) of TEMPBITMAP)) (SETQ MAXX (SUB1 (IDIFFERENCE (FOLDHI (IPLUS SOURCEPIXEL WIDTH -1) BITSPERWORD) (FOLDLO SOURCEPIXEL BITSPERWORD)))) (for Y from BEG to END by BYTESPERLINE as BOTTOM from (IPLUS DESTBOTTOM HEIGHT -1) by -1 do (\SETFILEPTR STREAM Y) (for X from 0 to MAXX do (\PUTBASE TEMPBASE X (\WIN STREAM))) (BITBLT TEMPBITMAP (IMOD SOURCEPIXEL BITSPERWORD) 0 DEST DESTLEFT BOTTOM WIDTH 1)))) ) (AISBLT8TO4MODUL (LAMBDA (STREAM WIDTH HEIGHT BASE BITMAPRASTERWIDTH STARTBYTE STARTSAMPLELINE SRASTERWIDTH NBITS LOBITADDRESS) (* kbr%: "16-Jul-86 19:47") (* internal function that puts pixels from an ais file into an 4 bit per pixel bitmap modulating the 8 bits.) (DECLARE (LOCALVARS . T)) (PROG (BYTESPERLINE LINEBASE DATABEG WORD BITSTOSET RIGHTSHIFT COMPLMASK MODMAX MODMIN) (SETQ LINEBASE BASE) (SETQ DATABEG (GETFILEPTR STREAM)) (* put bits in specified positions) (* set the maximum and minimum values for the random modulation function.) (SETQ MODMAX (IPLUS (SUB1 (LLSH 1 (IDIFFERENCE 6 (OR NBITS 4)))) (SUB1 (LLSH 1 (IDIFFERENCE 5 (OR NBITS 4)))))) (SETQ MODMIN (IMINUS MODMAX)) (COND ((OR (ILESSP (SETQ RIGHTSHIFT (IDIFFERENCE 4 (IPLUS NBITS LOBITADDRESS))) 0) (IGREATERP RIGHTSHIFT 4)) (ERROR "NBITS plus LOBITADDRESS is too large."))) (SETQ BITSTOSET (SUB1 (EXPT 2 NBITS))) (SETQ BITSTOSET (LOGOR (LLSH BITSTOSET (IPLUS 12 LOBITADDRESS)) (LLSH BITSTOSET (IPLUS 8 LOBITADDRESS)) (LLSH BITSTOSET (IPLUS 4 LOBITADDRESS)) (LLSH BITSTOSET LOBITADDRESS))) (SETQ COMPLMASK (LOGXOR BITSTOSET 65535)) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (for Y from 0 to (SUB1 HEIGHT) do (SETQ BASE LINEBASE) (\SETFILEPTR STREAM (IPLUS DATABEG (ITIMES Y BYTESPERLINE))) (for X from 1 to (LRSH WIDTH 2) do (\PUTBASE BASE 0 (LOGOR (LOGAND (\GETBASE BASE 0) COMPLMASK) (LOGAND (LRSH (LOGOR (LLSH (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) 8) (LLSH (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) 4) (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) (LRSH (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) 4)) RIGHTSHIFT) BITSTOSET))) (SETQ BASE (\ADDBASE BASE 1))) (SETQ LINEBASE (\ADDBASE LINEBASE BITMAPRASTERWIDTH))) (RETURN NIL))) ) (AISBLT8TOLESSFSA (LAMBDA (STREAM SOURCEBYTE STARTSAMPLELINE SRASTERWIDTH SOURCEHEIGHT DESTBASE DESTPIXEL DESTRASTERWIDTH WIDTH HEIGHT NBITS LOBITADDRESS) (* kbr%: "16-Jul-86 19:44") (* internal function that goes from an 8 bit file to NBITS in LOBITADDRESS position using a Floyd-Steinberg algorithm.) (* assumes starting addresses are all word aligned. Assumes file has been left pointing at the beginning of the data. NIL) (PROG (BYTESPERLINE DESTRIGHT DATABEG NEXTLINEERRORTABLE THISPIXELERROR ERRTABLEPTR BYTE ERR WORD BEG END COMPLMASK VAL DELBITS LOBITSMASK MAXVALUE INTENSITYBASE THREEEIGHTSERR) (SETQ DESTRIGHT (IPLUS DESTPIXEL WIDTH -1)) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ NEXTLINEERRORTABLE (\ALLOCBLOCK (ADD1 WIDTH) T)) (SETQ DELBITS (IDIFFERENCE 8 NBITS)) (SETQ LOBITSMASK (SUB1 (EXPT 2 (IDIFFERENCE 8 NBITS)))) (SETQ MAXVALUE (SUB1 (EXPT 2 NBITS))) (SETQ INTENSITYBASE (\ALLOCBLOCK (EXPT 2 NBITS))) (* BYTE and ERR are used by .GET.4BIT.AND.SPREAD.ERR. macro) (* initialize the intensity values for each color number.) (for I from 0 to MAXVALUE do (\PUTBASE INTENSITYBASE I (IQUOTIENT (ITIMES 255 I) MAXVALUE))) (for I from 0 to (ITIMES WIDTH 2) by 2 do (\PUTBASEPTR NEXTLINEERRORTABLE I 0)) (* NEXTLINEERRORTABLE is 1 larger so no end check is necessary in error propagation code.) (* set width to width in words.) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ WIDTH (LRSH WIDTH 1)) (SETQ END (IPLUS DATABEG SOURCEBYTE (ITIMES (IDIFFERENCE (SUB1 SOURCEHEIGHT) STARTSAMPLELINE) BYTESPERLINE))) (SETQ BEG (IDIFFERENCE END (ITIMES (SUB1 HEIGHT) BYTESPERLINE))) (SETQ COMPLMASK (LOGXOR (LLSH MAXVALUE LOBITADDRESS) 255)) (for Y from BEG to END by BYTESPERLINE do (SETQ ERRTABLEPTR NEXTLINEERRORTABLE) (SETQ THISPIXELERROR (\GETBASEPTR ERRTABLEPTR 0)) (\PUTBASEPTR ERRTABLEPTR 0 0) (\SETFILEPTR STREAM Y) (for X from DESTPIXEL to DESTRIGHT do (\PUTBASEBYTE DESTBASE X (LOGOR (LOGAND (\GETBASEBYTE DESTBASE X) COMPLMASK) (LLSH (.GET.NBIT.AND.SPREAD.ERR. STREAM) LOBITADDRESS)))) (COND ((NOT (EQ Y END)) (SETQ DESTBASE (\ADDBASE DESTBASE DESTRASTERWIDTH))))))) ) (AISBLT8TO4TRUNC (LAMBDA (STREAM SOURCEBYTE STARTSAMPLELINE SRASTERWIDTH SOURCEHEIGHT DESTBASE DESTPIXEL DESTRASTERWIDTH WIDTH HEIGHT NBITS LOBITADDRESS) (* kbr%: "16-Jul-86 19:46") (* internal function that puts pixels from an ais file into an 8 bit per pixel bitmap) (* Assumes file has been left pointing at the beginning of the data. NIL) (PROG (BYTESPERLINE DESTRIGHT DATABEG WORD BEG END MASK COMPLMASK LEFTSHIFT MAXVALUE) (SETQ DESTRIGHT (IPLUS DESTPIXEL WIDTH -1)) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ MAXVALUE (SUB1 (EXPT 2 NBITS))) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ END (IPLUS DATABEG SOURCEBYTE (ITIMES (IDIFFERENCE (SUB1 SOURCEHEIGHT) STARTSAMPLELINE) BYTESPERLINE))) (SETQ BEG (IDIFFERENCE END (ITIMES (SUB1 HEIGHT) BYTESPERLINE))) (SETQ LEFTSHIFT (IDIFFERENCE (IPLUS NBITS LOBITADDRESS) 8)) (SETQ MASK (LLSH MAXVALUE LOBITADDRESS)) (SETQ COMPLMASK (LOGXOR MASK 15)) (for Y from BEG to END by BYTESPERLINE do (\SETFILEPTR STREAM Y) (for X from DESTPIXEL to DESTRIGHT do (\PUTBASENYBBLE DESTBASE X (LOGOR (LOGAND (\GETBASENYBBLE DESTBASE X) COMPLMASK) (LOGAND (LLSH (IDIFFERENCE 255 (\BIN STREAM)) LEFTSHIFT) MASK)))) (COND ((NOT (EQ Y END)) (SETQ DESTBASE (\ADDBASE DESTBASE DESTRASTERWIDTH))))))) ) (AISBLT8TO8 (LAMBDA (STREAM SOURCEBYTE STARTSAMPLELINE SRASTERWIDTH SOURCEHEIGHT DESTBASE DESTPIXEL DESTRASTERWIDTH WIDTH HEIGHT NBITS LOBITADDRESS) (* ; "Edited 27-Apr-88 01:57 by Briggs") (* ;; "internal function that puts pixels from an ais file into an 8 bit per pixel bitmap") (* ;; "Assumes file has been left pointing at the beginning of the data.") (PROG (BYTESPERLINE DESTRIGHT DATABEG WORD BEG END MASK COMPLMASK LEFTSHIFT MAXVALUE) (SETQ DESTRIGHT (IPLUS DESTPIXEL WIDTH -1)) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ MAXVALUE (SUB1 (EXPT 2 NBITS))) (SETQ BYTESPERLINE (ITIMES BYTESPERWORD SRASTERWIDTH)) (SETQ END (IPLUS DATABEG SOURCEBYTE (ITIMES (IDIFFERENCE (SUB1 SOURCEHEIGHT) STARTSAMPLELINE) BYTESPERLINE))) (SETQ BEG (IDIFFERENCE END (ITIMES (SUB1 HEIGHT) BYTESPERLINE))) (SETQ LEFTSHIFT (IDIFFERENCE (IPLUS NBITS LOBITADDRESS) 8)) (SETQ MASK (LLSH MAXVALUE LOBITADDRESS)) (SETQ COMPLMASK (LOGXOR MASK 255)) (if (AND (EQ NBITS 8) (EQ DESTRASTERWIDTH SRASTERWIDTH) (EQ SOURCEBYTE 0) (EQ DESTPIXEL 0) (EQ SRASTERWIDTH (FOLDHI WIDTH BYTESPERWORD))) then (* ;; "we will use all the bits of the source bytes") (* ;; "the source and destination have the same raster width so we can ignore the line boundaries") (* ;; "there is no offset in the source or destination lines") (* ;; "the width we desire is the full source raster width modulo a possible slack byte for padding") (* ;; "SO, we can just slurp up the bytes in one large block") (\SETFILEPTR STREAM BEG) (\BINS STREAM DESTBASE 0 (ITIMES HEIGHT BYTESPERLINE)) elseif (EQ NBITS 8) then (* ;; "we will use all the bits of the source bytes") (* ;; "but there are pixel offsets or we do not require all the bytes in a line") (for Y from BEG to END by BYTESPERLINE do (\SETFILEPTR STREAM Y) (\BINS STREAM DESTBASE DESTPIXEL WIDTH) (COND ((NOT (EQ Y END)) (SETQ DESTBASE (\ADDBASE DESTBASE DESTRASTERWIDTH))))) else (* ;; "we are doing some processing of the source bytes") (for Y from BEG to END by BYTESPERLINE do (\SETFILEPTR STREAM Y) (for X from DESTPIXEL to DESTRIGHT do (\PUTBASEBYTE DESTBASE X (LOGOR (LOGAND (\GETBASEBYTE DESTBASE X) COMPLMASK) (LOGAND (LLSH (\BIN STREAM) LEFTSHIFT) MASK)))) (COND ((NOT (EQ Y END)) (SETQ DESTBASE (\ADDBASE DESTBASE DESTRASTERWIDTH)))))))) ) (AISBLT4TO4 (LAMBDA (STREAM MODULATIONFLG WIDTH HEIGHT BASE BITMAPRASTERWIDTH STARTBYTE STARTSAMPLELINE SRASTERWIDTH NBITS LOBITADDRESS) (* kbr%: "16-Jul-86 19:51") (* internal function that puts pixels from a 4 bit ais file into a 4 bit per pixel bitmap) (DECLARE (LOCALVARS . T)) (PROG (BYTESPERLINE LINEBASE DATABEG WORD MASK RIGHTSHIFT COMPLMASK MODMAX MODMIN) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ LINEBASE BASE) (SETQ DATABEG (GETFILEPTR STREAM)) (* set width to width in words.) (SETQ WIDTH (LRSH WIDTH 2)) (COND (NBITS (* put bits in specified positions) (COND (MODULATIONFLG (COND ((EQ NBITS 4) (* turn off modulation; there's enough bits for all information.) (SETQ MODULATIONFLG NIL)) ((EQ NBITS 3) (* special case of 3 bits) (SETQ MODMAX 1) (SETQ MODMIN 0)) (T (* set the maximum and minimum values for the random modulation function.) (SETQ MODMAX (SUB1 (LLSH 1 (IDIFFERENCE 2 NBITS)))) (SETQ MODMIN (IMINUS MODMAX)))))) (COND ((OR (ILESSP (SETQ RIGHTSHIFT (IDIFFERENCE 4 (IPLUS NBITS LOBITADDRESS))) 0) (IGREATERP RIGHTSHIFT 4)) (ERROR "NBITS plus LOBITADDRESS is too large."))) (SETQ MASK (SUB1 (EXPT 2 NBITS))) (SETQ MASK (LOGOR (LLSH MASK (IPLUS 12 LOBITADDRESS)) (LLSH MASK (IPLUS 8 LOBITADDRESS)) (LLSH MASK (IPLUS 4 LOBITADDRESS)) (LLSH MASK LOBITADDRESS))) (SETQ COMPLMASK (LOGXOR MASK 65535)) (for Y from (IPLUS DATABEG STARTBYTE (ITIMES STARTSAMPLELINE BYTESPERLINE)) to (IPLUS DATABEG STARTBYTE (ITIMES (SUB1 (IPLUS STARTSAMPLELINE HEIGHT)) BYTESPERLINE)) by BYTESPERLINE do (SETQ BASE LINEBASE) (\SETFILEPTR STREAM Y) (for X from 1 to WIDTH do (\PUTBASE BASE 0 (LOGOR (LOGAND (\GETBASE BASE 0) COMPLMASK) (LOGAND (LRSH (COND (NIL (* not implemented correctly) MODULATIONFLG (LOGOR (LLSH (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) 8) (LLSH (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) 4) (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) (LRSH (.4BIT.MODULATE.INTENSITY.VALUE. STREAM) 4))) (T (LOGOR (LLSH (\BIN STREAM) 8) (\BIN STREAM)))) RIGHTSHIFT) MASK))) (SETQ BASE (\ADDBASE BASE 1))) (SETQ LINEBASE (\ADDBASE LINEBASE BITMAPRASTERWIDTH)))) (T (* use all of the bits) (for Y from (IPLUS DATABEG STARTBYTE (ITIMES STARTSAMPLELINE BYTESPERLINE)) to (IPLUS DATABEG STARTBYTE (ITIMES (SUB1 (IPLUS STARTSAMPLELINE HEIGHT)) BYTESPERLINE)) by BYTESPERLINE do (SETQ BASE LINEBASE) (\SETFILEPTR STREAM Y) (for X from 1 to WIDTH do (\PUTBASE BASE 0 (\WIN STREAM)) (SETQ BASE (\ADDBASE BASE 1))) (SETQ LINEBASE (\ADDBASE LINEBASE BITMAPRASTERWIDTH))))) (RETURN))) ) (AISBLT8TO4LESSFSA (LAMBDA (STREAM SOURCEBYTE STARTSAMPLELINE SRASTERWIDTH SOURCEHEIGHT DESTBASE DESTPIXEL DESTRASTERWIDTH WIDTH HEIGHT NBITS LOBITADDRESS) (* kbr%: "16-Jul-86 19:46") (* internal function that goes from an 8 bit file to NBITS in LOBITADDRESS position using a Floyd-Steinberg algorithm.) (* assumes starting addresses are all word aligned. Assumes file has been left pointing at the beginning of the data. NIL) (PROG (BYTESPERLINE DESTRIGHT DATABEG NEXTLINEERRORTABLE THISPIXELERROR ERRTABLEPTR BYTE ERR WORD BEG END COMPLMASK VAL DELBITS LOBITSMASK MAXVALUE INTENSITYBASE THREEEIGHTSERR) (SETQ DESTRIGHT (IPLUS DESTPIXEL WIDTH -1)) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ NEXTLINEERRORTABLE (\ALLOCBLOCK (ADD1 WIDTH) T)) (SETQ DELBITS (IDIFFERENCE 8 NBITS)) (SETQ LOBITSMASK (SUB1 (EXPT 2 (IDIFFERENCE 8 NBITS)))) (SETQ MAXVALUE (SUB1 (EXPT 2 NBITS))) (SETQ INTENSITYBASE (\ALLOCBLOCK (EXPT 2 NBITS))) (* initialize the intensity values for each color number.) (for I from 0 to MAXVALUE do (\PUTBASE INTENSITYBASE I (IQUOTIENT (ITIMES 255 I) MAXVALUE))) (for I from 0 to (ITIMES WIDTH 2) by 2 do (\PUTBASEPTR NEXTLINEERRORTABLE I 0)) (* NEXTLINEERRORTABLE is 1 larger so no end check is necessary in error propagation code.) (* set width to width in words.) (SETQ WIDTH (LRSH WIDTH 1)) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ END (IPLUS DATABEG SOURCEBYTE (ITIMES (IDIFFERENCE (SUB1 SOURCEHEIGHT) STARTSAMPLELINE) BYTESPERLINE))) (SETQ BEG (IDIFFERENCE END (ITIMES (SUB1 HEIGHT) BYTESPERLINE))) (SETQ COMPLMASK (LOGXOR (LLSH MAXVALUE LOBITADDRESS) 15)) (for Y from BEG to END by BYTESPERLINE do (SETQ ERRTABLEPTR NEXTLINEERRORTABLE) (SETQ THISPIXELERROR (\GETBASEPTR ERRTABLEPTR 0)) (\PUTBASEPTR ERRTABLEPTR 0 0) (\SETFILEPTR STREAM Y) (for X from DESTPIXEL to DESTRIGHT do (\PUTBASENYBBLE DESTBASE X (LOGOR (LOGAND (\GETBASENYBBLE DESTBASE X) COMPLMASK) (LLSH (.GET.NBIT.AND.SPREAD.ERR. STREAM) LOBITADDRESS)))) (COND ((NOT (EQ Y END)) (SETQ DESTBASE (\ADDBASE DESTBASE DESTRASTERWIDTH))))))) ) (AISBLT8TO1FSA (LAMBDA (STREAM SOURCEBYTE STARTSAMPLELINE SRASTERWIDTH SOURCEHEIGHT DESTBASE DESTPIXEL DESTRASTERWIDTH WIDTH HEIGHT) (* kbr%: "16-Jul-86 19:49") (* internal function that puts pixels from an ais file into an 1 bit per pixel bitmap propagating error with the Floyd-Steinberg algorithm.) (* Assumes file has been left pointing at the beginning of the data.) (PROG (BYTESPERLINE DATABEG NEXTLINEERRORTABLE THISPIXELERROR ERRTABLEPTR BYTE ERR BITPTR BMWORD BEG END VAL DESTRIGHT DESTLEFTWORD DESTRIGHTWORD BITOFFSET FIRSTWORDBITS FINALWORDMASK INTENSITYBASE THREEEIGHTSERR) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ NEXTLINEERRORTABLE (\ALLOCBLOCK (ADD1 WIDTH) T)) (SETQ DESTRIGHT (IPLUS DESTPIXEL WIDTH -1)) (SETQ DESTLEFTWORD (FOLDLO DESTPIXEL BITSPERWORD)) (SETQ DESTRIGHTWORD (FOLDLO DESTRIGHT BITSPERWORD)) (SETQ BITOFFSET (LOGAND DESTPIXEL 15)) (SETQ FIRSTWORDBITS (IDIFFERENCE BITSPERWORD BITOFFSET)) (SETQ FINALWORDMASK (SUB1 (EXPT 2 (IDIFFERENCE BITSPERWORD (LOGAND (IPLUS BITOFFSET WIDTH) 15))))) (SETQ INTENSITYBASE (\ALLOCBLOCK 2)) (* BYTE and ERR are used by .GET.1BIT.AND.SPREAD.ERR. macro) (* NEXTLINEERRORTABLE is 1 larger so no end check is necessary in error propagation code.) (* initialize the intensity values for each color number.) (\PUTBASE INTENSITYBASE 0 255) (\PUTBASE INTENSITYBASE 1 0) (for I from 0 to (ITIMES WIDTH 2) by 2 do (\PUTBASEPTR NEXTLINEERRORTABLE I 0)) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ END (IPLUS DATABEG SOURCEBYTE (ITIMES (IDIFFERENCE (SUB1 SOURCEHEIGHT) STARTSAMPLELINE) BYTESPERLINE))) (SETQ BEG (IDIFFERENCE END (ITIMES (SUB1 HEIGHT) BYTESPERLINE))) (for Y from BEG to END by BYTESPERLINE do (* load BMWORD with the bits in the first word that won't be clobbered.) (SETQ BMWORD (LRSH (\GETBASE DESTBASE DESTLEFTWORD) FIRSTWORDBITS)) (SETQ BITPTR BITOFFSET) (SETQ ERRTABLEPTR NEXTLINEERRORTABLE) (SETQ THISPIXELERROR (\GETBASEPTR ERRTABLEPTR 0)) (\PUTBASEPTR ERRTABLEPTR 0 0) (\SETFILEPTR STREAM Y) (for X from DESTPIXEL to DESTRIGHT do (SETQ BMWORD (LOGOR (LLSH BMWORD 1) (.GET.1BIT.AND.SPREAD.ERR. STREAM))) (COND ((EQ (SETQ BITPTR (ADD1 BITPTR)) 16) (* store this word and move to next word.) (\PUTBASE DESTBASE (FOLDLO X BITSPERWORD) BMWORD) (SETQ BITPTR (SETQ BMWORD 0)))) finally (* get the unset bits from the final word on the line.) (OR (EQ BITPTR 0) (\PUTBASE DESTBASE DESTRIGHTWORD (LOGOR (LLSH BMWORD (IDIFFERENCE 16 BITPTR)) (LOGAND (\GETBASE DESTBASE DESTRIGHTWORD) FINALWORDMASK))))) (COND ((NOT (EQ Y END)) (SETQ DESTBASE (\ADDBASE DESTBASE DESTRASTERWIDTH))))))) ) (AISBLT8TO1TRUNC (LAMBDA (STREAM WIDTH HEIGHT BASE BITMAPRASTERWIDTH STARTBYTE STARTSAMPLELINE SRASTERWIDTH BITOFFSET FILTER) (* kbr%: "16-Jul-86 19:49") (* internal function that puts pixels from an ais file into an 1 bit per pixel bitmap (truncating the error.)) (* Assumes file has been left pointing at the beginning of the data.) (DECLARE (LOCALVARS . T)) (PROG (BYTESPERLINE LINEBASE FILTERARRAY DATABEG BYTE BITPTR BMWORD BEG END VAL FIRSTWORDBITS FINALWORDMASK) (SETQ LINEBASE BASE) (SETQ FILTERARRAY FILTER) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ FIRSTWORDBITS (IDIFFERENCE BITSPERWORD BITOFFSET)) (SETQ FINALWORDMASK (SUB1 (EXPT 2 (IDIFFERENCE BITSPERWORD (LOGAND (IPLUS BITOFFSET WIDTH) 15))))) (SETQ BYTESPERLINE (ITIMES 2 SRASTERWIDTH)) (SETQ BEG (IPLUS DATABEG STARTBYTE (ITIMES STARTSAMPLELINE BYTESPERLINE))) (SETQ END (IPLUS DATABEG STARTBYTE (ITIMES (SUB1 (IPLUS STARTSAMPLELINE HEIGHT)) BYTESPERLINE))) (for Y from BEG to END by BYTESPERLINE do (SETQ BASE LINEBASE) (* load BMWORD with the bits in the first word that won't be clobbered.) (SETQ BMWORD (LRSH (\GETBASE BASE 0) FIRSTWORDBITS)) (SETQ BITPTR BITOFFSET) (\SETFILEPTR STREAM Y) (for X from 1 to WIDTH do (SETQ BMWORD (LOGOR (LLSH BMWORD 1) (.GET.LEFTMOST.BIT. STREAM))) (COND ((EQ (SETQ BITPTR (ADD1 BITPTR)) 16) (* store this word and move to next word.) (\PUTBASE BASE 0 BMWORD) (SETQ BITPTR (SETQ BMWORD 0)) (SETQ BASE (\ADDBASE BASE 1)))) finally (* get the unset bits from the final word on the line.) (OR (EQ BITPTR 0) (\PUTBASE BASE 0 (LOGOR (LLSH BMWORD (IDIFFERENCE 16 BITPTR)) (LOGAND (\GETBASE BASE 0) FINALWORDMASK))))) (SETQ LINEBASE (\ADDBASE LINEBASE BITMAPRASTERWIDTH))) (RETURN NIL))) ) (CLOSEST.COLOR (LAMBDA (COLORMAP RED GREEN BLUE) (* kbr%: "26-May-85 14:51") (* Which color of COLORMAP is closest to RGB? *) (PROG (DISTANCE ANSWER) (SETQ DISTANCE MAX.FIXP) (for COLOR from 0 to (SUB1 (ARRAYSIZE COLORMAP)) when (ILESSP (COLOR.DISTANCE (ELT COLORMAP COLOR) RED GREEN BLUE) DISTANCE) do (SETQ ANSWER (ELT COLORMAP COLOR))) (RETURN ANSWER))) ) (GRAPHAISHISTOGRAM (LAMBDA (HISTOGRAM W) (* lmm "13-DEC-82 18:42") (* draws a historgram of the intensity levels of a picture.) (PROG (W ARSIZE MAX MAXELT) (SETQ W (OR W (CREATEW (GETBOXREGION 270 215)))) (SETQ MAX 0) (SETQ MAXELT 0) (for I from 0 to (SETQ ARSIZE (ARRAYSIZE HISTOGRAM)) by 32 do (DRAWLINE I 10 I 0 1 (QUOTE REPLACE) W)) (for I from 0 to (SUB1 ARSIZE) do (COND ((IGREATERP (ELT HISTOGRAM I) MAX) (SETQ MAX (ELT HISTOGRAM I)) (SETQ MAXELT I)))) (for I from 0 to (SUB1 ARSIZE) do (DRAWLINE I 10 I (IPLUS 10 (IQUOTIENT (ITIMES (ELT HISTOGRAM I) 200) MAX)) 1 (QUOTE REPLACE) W)) (RETURN W))) ) (AISHISTOGRAM (LAMBDA (FILE REGION) (* kbr%: "13-Jul-85 19:28") (* returns an array that have the number of pixels in FILE that have each intensity.) (PROG (STREAM DATABEG AISHISTOGRAM TMP BITSPERSAMPLE SFILEWIDTH SFILEHEIGHT SFILEBYTESPERLINE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT BEG END) (COND ((OR (SETQ STREAM (FINDFILE FILE NIL AISDIRECTORIES)) (SETQ STREAM FILE)) (SETQ STREAM (GETSTREAM (OPENFILE STREAM (QUOTE INPUT)) (QUOTE INPUT))))) (SETQ TMP (INSUREAISFILE STREAM)) (SETQ BITSPERSAMPLE (CAR TMP)) (SETQ SFILEWIDTH (CADR TMP)) (SETQ SFILEHEIGHT (CADDR TMP)) (SETQ SFILEBYTESPERLINE (LLSH (CADDDR TMP) 1)) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ AISHISTOGRAM (ARRAY (EXPT 2 BITSPERSAMPLE) NIL 0 0)) (COND (REGION (SETQ LEFT (IMAX (IMIN (fetch (REGION LEFT) of REGION) (SUB1 SFILEWIDTH)) 0)) (SETQ RIGHT (IMAX (IMIN SFILEWIDTH (fetch (REGION PRIGHT) of REGION)) 0)) (COND ((IGEQ LEFT RIGHT) (RETURN AISHISTOGRAM)) (T (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)))) (SETQ BOTTOM (IMIN (fetch (REGION BOTTOM) of REGION) (SUB1 SFILEHEIGHT))) (SETQ TOP (IMIN SFILEHEIGHT (fetch (REGION PTOP) of REGION))) (COND ((IGREATERP BOTTOM TOP) (RETURN AISHISTOGRAM))) (SETQ BEG (IPLUS DATABEG (IPLUS (ITIMES SFILEBYTESPERLINE (IDIFFERENCE SFILEHEIGHT TOP)) LEFT))) (SETQ END (IPLUS DATABEG (IPLUS (ITIMES SFILEBYTESPERLINE (IDIFFERENCE SFILEHEIGHT BOTTOM)) LEFT))) (for LINE from BEG to END by SFILEBYTESPERLINE do (\SETFILEPTR STREAM LINE) (for BIT from 1 to WIDTH do (SETA AISHISTOGRAM (SETQ TMP (\BIN STREAM)) (ADD1 (ELT AISHISTOGRAM TMP)))))) (T (for LINE from 1 to SFILEHEIGHT do (for BIT from 1 to SFILEBYTESPERLINE do (SETA AISHISTOGRAM (SETQ TMP (\BIN STREAM)) (ADD1 (ELT AISHISTOGRAM TMP))))))) (CLOSEF STREAM) (RETURN AISHISTOGRAM))) ) (SMOOTHEDFILTER (LAMBDA (HISTOGRAM) (* kbr%: "13-Jul-85 15:05") (* returns a 256 to 256 mapping array that maximally distributes the intensity values by looking at the histogram array HISTOGRAM) (PROG (ARSIZE SMOOTHARRAY TOTALPOINTS POINTSLESS FILEINTENSITY NEWINTENSITY POINTSPAST BUCKETSIZE NTOMOVE NPTS) (SETQ ARSIZE (ARRAYSIZE HISTOGRAM)) (SETQ POINTSLESS 0) (SETQ NEWINTENSITY 0) (SETQ POINTSPAST 0) (SETQ SMOOTHARRAY (ARRAY ARSIZE NIL 0 0)) (SETQ TOTALPOINTS (for I from 0 to (SUB1 ARSIZE) sum (ELT HISTOGRAM I))) (SETQ BUCKETSIZE (IQUOTIENT TOTALPOINTS 256)) (for I from 0 to (SUB1 ARSIZE) do (SETQ NPTS (ELT HISTOGRAM I)) (SETQ POINTSLESS (IPLUS POINTSLESS NPTS)) (COND ((IGREATERP POINTSLESS BUCKETSIZE) (SETQ NTOMOVE (IQUOTIENT POINTSLESS BUCKETSIZE)) (SETA SMOOTHARRAY I (IPLUS NEWINTENSITY (IQUOTIENT NTOMOVE 2))) (SETQ NEWINTENSITY (COND ((IGREATERP NEWINTENSITY 255) 255) (T (IPLUS NEWINTENSITY NTOMOVE)))) (SETQ POINTSLESS (IDIFFERENCE POINTSLESS (ITIMES NTOMOVE BUCKETSIZE)))) (T (SETA SMOOTHARRAY I NEWINTENSITY)))) (RETURN SMOOTHARRAY))) ) (SLOW.COLOR.DISTANCE (LAMBDA (RGB RED GREEN BLUE) (* kbr%: "26-May-85 14:55") (* returns a closeness measure for colors.) (IPLUS (SQUARE (IDIFFERENCE (fetch (RGB RED) of RGB) RED)) (SQUARE (IDIFFERENCE (fetch (RGB GREEN) of RGB) GREEN)) (SQUARE (IDIFFERENCE (fetch (RGB BLUE) of RGB) BLUE)))) ) (FAST.COLOR.DISTANCE (LAMBDA (RGB RED GREEN BLUE) (* kbr%: "26-May-85 14:52") (* returns a closeness measure for colors.) (IPLUS (IABS (IDIFFERENCE (fetch (RGB RED) of RGB) RED)) (IABS (IDIFFERENCE (fetch (RGB GREEN) of RGB) GREEN)) (IABS (IDIFFERENCE (fetch (RGB BLUE) of RGB) BLUE)))) ) (INSUREAISFILE (LAMBDA (FILE) (* ; "Edited 26-Apr-88 23:54 by Briggs") (* ;; "make sure a file is an ais file and put fileptr at beginning of data. Returns a list of bitspersample, width and height") (PROG (STREAM HEADERLENGTH WIDTH HEIGHT BITSPERPIXEL RASTERWIDTH DIRECTION) (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT))) (\SETFILEPTR STREAM 0) (COND ((EQ (\WIN STREAM) 33962) (* ; "check for AIS password") NIL) (T (ERROR (FULLNAME STREAM) " is not an AIS file."))) (SETQ HEADERLENGTH (\WIN STREAM)) (COND ((NOT (EQ (LRSH (\WIN STREAM) 10) 1)) (* ; "unknown raster part type --- ignore the raster part length NIL") (ERROR "not implemented to handle raster parts of this type."))) (SETQ HEIGHT (\WIN STREAM)) (SETQ WIDTH (\WIN STREAM)) (SETQ DIRECTION (\WIN STREAM)) (COND ((NOT (EQ (\WIN STREAM) 1)) (ERROR "not 1 sample per pixel."))) (COND ((NOT (EQ (\WIN STREAM) 1)) (ERROR "Coding type is not 1 - UCA" NIL))) (SETQ BITSPERPIXEL (\WIN STREAM)) (COND ((EQ BITSPERPIXEL 0) (SETQ BITSPERPIXEL 1))) (SETQ RASTERWIDTH (\WIN STREAM)) (\SETFILEPTR STREAM (ITIMES 2 HEADERLENGTH)) (COND ((NOT (EQ FILE STREAM)) (CLOSEF STREAM))) (RETURN (LIST BITSPERPIXEL WIDTH HEIGHT RASTERWIDTH DIRECTION)))) ) (SHOWCOLORAIS (LAMBDA (BASEFILE COLORMAPINFO HOW SOURCELEFT SOURCEBOTTOM DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT) (* kbr%: "21-Aug-85 20:46") (* reads a color image from three files - REDFILE GREENFILE and BLUEFILE If COLORMAPINFO is a colormap, each point is taken into the closed color in colormap. If COLORMAPINFO is a list of numbers totaling the number of bits in the color bitmap) (PROG (UBASEFILE BASENAME REDFILE GREENFILE BLUEFILE) (COND ((AND (LISTP BASEFILE) (EQLENGTH BASEFILE 3)) (* BASEFILE = (REDFILE BLUEFILE GREENFILE) *) (SETQ REDFILE (CAR BASEFILE)) (SETQ GREENFILE (CADR BASEFILE)) (SETQ BLUEFILE (CADDR BASEFILE))) ((LITATOM BASEFILE) (* BASEFILE = prefix for REDFILE GREENFILE & BLUEFILE *) (SETQ UBASEFILE (UNPACKFILENAME BASEFILE)) (SETQ BASENAME (LISTGET UBASEFILE (QUOTE NAME))) (SETQ REDFILE (INFILEP (PACKFILENAME (APPEND (LIST (QUOTE NAME) (CONCAT BASENAME "-RED") (QUOTE EXTENSION) "AIS") UBASEFILE)))) (SETQ GREENFILE (OR (INFILEP (PACKFILENAME (APPEND (LIST (QUOTE NAME) (CONCAT BASENAME "-GREEN") (QUOTE EXTENSION) "AIS") UBASEFILE))) (INFILEP (PACKFILENAME (APPEND (LIST (QUOTE NAME) (CONCAT BASENAME "-GRN") (QUOTE EXTENSION) "AIS") UBASEFILE))))) (SETQ BLUEFILE (OR (INFILEP (PACKFILENAME (APPEND (LIST (QUOTE NAME) (CONCAT BASENAME "-BLUE") (QUOTE EXTENSION) "AIS") UBASEFILE))) (INFILEP (PACKFILENAME (APPEND (LIST (QUOTE NAME) (CONCAT BASENAME "-BLU") (QUOTE EXTENSION) "AIS") UBASEFILE)))))) (T (\ILLEGAL.ARG BASEFILE))) (COND ((LISTP COLORMAPINFO) (PROG (REDBITS GREENBITS BLUEBITS) (SETQ REDBITS (CAR COLORMAPINFO)) (SETQ GREENBITS (CADR COLORMAPINFO)) (SETQ BLUEBITS (CADDR COLORMAPINFO)) (AISBLT REDFILE SOURCELEFT SOURCEBOTTOM DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT HOW NIL REDBITS (IPLUS GREENBITS BLUEBITS)) (AISBLT GREENFILE SOURCELEFT SOURCEBOTTOM DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT HOW NIL GREENBITS BLUEBITS) (AISBLT BLUEFILE SOURCELEFT SOURCEBOTTOM DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT HOW NIL BLUEBITS 0))) ((ARRAYP COLORMAPINFO) (* KBR%: This is WRONG! All clipping info is being lost. *) (SHOWCOLORAIS1 REDFILE GREENFILE BLUEFILE HOW DESTINATION COLORMAPINFO)) (T (\ILLEGAL.ARG COLORMAPINFO))))) ) (SHOWCOLORAIS1 (LAMBDA (REDFILE GREENFILE BLUEFILE HOW COLORBM COLORMAP) (* kbr%: "13-Jul-85 16:05") (* puts a color image into a color bitmap choosing colors that are closest to the ones in COLORMAP.) (PROG (REDSTREAM GREENSTREAM BLUESTREAM BITSPERPIXEL BASE BITMAPHEIGHT BITMAPWIDTH BITMAPRASTERWIDTH WIDTH HEIGHT BITSPERSAMPLE BYTESPERLINE) (SETQ REDSTREAM (OPENSTREAM REDFILE (QUOTE INPUT))) (SETQ GREENSTREAM (OPENSTREAM GREENFILE (QUOTE INPUT))) (SETQ BLUESTREAM (OPENSTREAM BLUEFILE (QUOTE INPUT))) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of COLORBM)) (SETQ BITMAPRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of COLORBM)) (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of COLORBM)) (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of COLORBM)) (SETQ BASE (fetch (BITMAP BITMAPBASE) of COLORBM)) (SETQ HEIGHT (INSUREAISFILE REDSTREAM)) (COND ((IGREATERP (SETQ WIDTH (CADR HEIGHT)) BITMAPWIDTH) (ERROR "Can't read AIS files whose width is greater than the target bitmap - yet."))) (SETQ BITSPERSAMPLE (CAR HEIGHT)) (SETQ BYTESPERLINE (LLSH (CADDDR HEIGHT) 1)) (SETQ HEIGHT (CADDR HEIGHT)) (INSUREAISFILE GREENSTREAM) (INSUREAISFILE BLUESTREAM) (COND ((AND (EQ BITSPERPIXEL 8) (EQ BITSPERSAMPLE 8)) (24BITCOLORTO8BITMAP REDSTREAM GREENSTREAM BLUESTREAM (IMIN WIDTH BITMAPWIDTH) (IMIN HEIGHT BITMAPHEIGHT) BASE BYTESPERLINE BITMAPRASTERWIDTH COLORMAP)) (T (ERROR " can only go from three 8 bit color files into an 8 bit colormap for now."))) (CLOSEF REDSTREAM) (CLOSEF GREENSTREAM) (CLOSEF BLUESTREAM) (RETURN T))) ) (WRITEAIS (LAMBDA (BITMAP FILE REGION) (* kbr%: "16-Jul-86 17:36") (* writes a bitmap on to a file in AIS format.) (PROG (STREAM TEMPBITMAP HEADERLENGTH BITSPERPIXEL RASTERWIDTH WIDTH HEIGHT) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) (COND ((REGIONP REGION) (* Get copy of selected REGION of BITMAP into temporary bitmap to avoid having to deal with odd boundary problems when writing contents of BITMAP to STREAM *) (SETQ TEMPBITMAP (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) BITSPERPIXEL)) (BITBLT BITMAP (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) TEMPBITMAP) (SETQ BITMAP TEMPBITMAP)) (REGION (\ILLEGAL.ARG REGION))) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT))) (* write AIS password) (\WOUT STREAM 33962) (* write header length in words - must be a multiple of 1024) (SETQ HEADERLENGTH 1024) (\WOUT STREAM HEADERLENGTH) (* set type and length of raster part header) (\WOUT STREAM (LOGOR (LLSH 1 10) 10)) (* Scan count) (\WOUT STREAM HEIGHT) (* ScanLength) (\WOUT STREAM WIDTH) (* Scan Dir) (\WOUT STREAM 3) (* samples per pixel.) (\WOUT STREAM 1) (* coding type - UnCompressedArray) (\WOUT STREAM 1) (* bits per sample) (\WOUT STREAM BITSPERPIXEL) (* words per sample line.) (\WOUT STREAM RASTERWIDTH) (* Sample lines per block - no blocks is 16 bit -1) (\WOUT STREAM 65535) (* padding words per block - -1 if no blocks.) (\WOUT STREAM 65535) (* header length is in words.) (\SETFILEPTR STREAM (ITIMES 2 HEADERLENGTH)) (* this would be a good place to dump the color map information) (\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) 0 (ITIMES HEIGHT RASTERWIDTH 2)) (RETURN (CLOSEF STREAM)))) ) (WRITEAIS1 (LAMBDA (STREAM LINEBASE NBYTESPERLINE FIRSTBYTEOFFSET HEIGHT RASTERWIDTH) (* kbr%: "16-Jul-86 17:13") (* dumps the bits from the bitmap with base BASE onto the file OFD.) (for Y from 1 to HEIGHT do (\BOUTS STREAM LINEBASE FIRSTBYTEOFFSET NBYTESPERLINE) (SETQ LINEBASE (\ADDBASE LINEBASE RASTERWIDTH)))) ) (\GETBASENYBBLE (LAMBDA (X D) (* kbr%: "21-Jul-85 23:37") (PROG (ANSWER) (SETQ ANSWER (\GETBASE X (FOLDLO D NYBBLESPERWORD))) (SETQ ANSWER (SELECTQ (LOGAND D 3) (0 (LRSH ANSWER 12)) (1 (LRSH ANSWER 8)) (2 (LRSH ANSWER 4)) ANSWER)) (SETQ ANSWER (LOGAND ANSWER 15)) (RETURN ANSWER))) ) (\PUTBASENYBBLE (LAMBDA (X D V) (* kbr%: "21-Jul-85 23:40") (PROG (N ANSWER) (SETQ N (FOLDLO D NYBBLESPERWORD)) (SETQ ANSWER (\GETBASE X N)) (SETQ ANSWER (SELECTQ (LOGAND D 3) (0 (LOGOR (LLSH V 12) (LOGAND ANSWER (LOGNOT (LLSH 15 12))))) (1 (LOGOR (LLSH V 8) (LOGAND ANSWER (LOGNOT (LLSH 15 8))))) (2 (LOGOR (LLSH V 4) (LOGAND ANSWER (LOGNOT (LLSH 15 4))))) (LOGOR V (LOGAND ANSWER (LOGNOT 15))))) (\PUTBASE X N ANSWER) (RETURN ANSWER))) ) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .GET.4BIT.AND.SPREAD.ERR. MACRO ((STREAM) (PROGN (* returns the 4 most significant bits taking into account the error and spreads the error into the appropriate places.) (SETQ BYTE (IPLUS (\BIN STREAM) THISPIXELERROR)) (PROG1 (COND ((IGREATERP BYTE 255) (* overflow case) 15) (T (LRSH BYTE 4))) (SETQ ERR (LOGAND BYTE 15)) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELERROR (IPLUS (\GETBASE ERRTABLEPTR 1) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASE ERRTABLEPTR 1 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASE ERRTABLEPTR 0 (IPLUS (\GETBASE ERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))) (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 1)))))) (PUTPROPS .GET.1BIT.AND.SPREAD.ERR. MACRO ((STREAM) (PROGN (* returns the most significant bit taking into account the error and spreads the error into the appropriate places.) (SETQ BYTE (IPLUS (\BIN STREAM) THISPIXELERROR)) (PROG1 (SETQ VAL (COND ((IGREATERP BYTE 255) (* overflow case) 0) ((IGREATERP 0 BYTE) (* overflow case) 1) (T (LOGXOR (LRSH BYTE 7) 1)))) (SETQ ERR (IDIFFERENCE BYTE (\GETBASE INTENSITYBASE VAL))) (* put |3/8| of error into next pixel, |3/8| to one below and |1/4| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 2) 64)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THREEEIGHTSERR (IPLUS ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 1) 128))) (SETQ THISPIXELERROR (IPLUS (\GETBASEPTR ERRTABLEPTR 2) THREEEIGHTSERR)) (* |1/4| of error to next one down to right.) (\PUTBASEPTR ERRTABLEPTR 2 ERR) (* |3/8| to one below) (\PUTBASEPTR ERRTABLEPTR 0 (IPLUS (\GETBASEPTR ERRTABLEPTR 0) THREEEIGHTSERR)) (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 2)))))) (PUTPROPS .GET.NBIT.AND.SPREAD.ERR. MACRO ((STREAM) (PROGN (* returns the NBITS most significant bits taking into account the error and spreads the error into the appropriate places.) (SETQ BYTE (IPLUS (IDIFFERENCE 255 (\BIN STREAM)) THISPIXELERROR)) (PROG1 (SETQ VAL (COND ((IGREATERP BYTE 255) (* overflow case) MAXVALUE) ((IGREATERP 0 BYTE) 0) (T (LRSH BYTE DELBITS)))) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (SETQ ERR (IDIFFERENCE BYTE (\GETBASE INTENSITYBASE VAL))) (* calculate |1/4| of error.) (SETQ ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 2) 64)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THREEEIGHTSERR (IPLUS ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 1) 128))) (SETQ THISPIXELERROR (IPLUS (\GETBASEPTR ERRTABLEPTR 2) THREEEIGHTSERR)) (* |1/8| of error to next one down to right.) (\PUTBASEPTR ERRTABLEPTR 2 ERR) (* |3/8| to one below) (\PUTBASEPTR ERRTABLEPTR 0 (IPLUS (\GETBASEPTR ERRTABLEPTR 0) THREEEIGHTSERR)) (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 2)))))) (PUTPROPS .GET.LEFTMOST.4BIT MACRO ((STREAM) (* returns the 4 most significant bits) (LRSH (\BIN STREAM) 4))) (PUTPROPS .GET.LEFTMOST.BIT. MACRO ((STREAM) (* returns the most significant bit from an 8 bit sample. It also inverts the sign of the bit since 1 is black and 0 white. NIL) (COND ((IGREATERP (COND (FILTERARRAY (ELT FILTERARRAY (\BIN STREAM))) (T (\BIN STREAM))) 127) 0) (T 1)))) (PUTPROPS .GET.BESTCOLOR.AND.SPREAD.ERR. MACRO (NIL (PROGN (* returns the best matching color bits taking into account the error and spreads the error into the appropriate places.) (SETQ COLOR (CLOSEST.COLOR COLORMAP (SETQ REDBYTE (IPLUS (\BIN REDSTREAM) THISPIXELREDERROR)) (SETQ GREENBYTE (IPLUS (\BIN GREENSTREAM) THISPIXELGREENERROR)) (SETQ BLUEBYTE (IPLUS (\BIN BLUESTREAM) THISPIXELBLUEERROR)))) (SETQ RGB (ELT COLORMAP COLOR)) (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB RED) of RGB) REDBYTE)) (COND ((IGREATERP ERR -1) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELREDERROR (IPLUS (\GETBASEPTR REDERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR REDERRTABLEPTR 2 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASEPTR REDERRTABLEPTR 0 (IPLUS (\GETBASEPTR REDERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1))))) (T (* error is negative, do things differently.) (* calculate |1/4| of error.) (SETQ ERR (LRSH (IMINUS ERR) 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELREDERROR (IDIFFERENCE (\GETBASEPTR REDERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR REDERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) (* |3/8| to one below) (\PUTBASEPTR REDERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR REDERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))))) (SETQ REDERRTABLEPTR (\ADDBASE REDERRTABLEPTR 2))) (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB GREEN) of RGB) GREENBYTE)) (COND ((IGREATERP ERR -1) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELGREENERROR (IPLUS (\GETBASEPTR GREENERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR GREENERRTABLEPTR 2 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASEPTR GREENERRTABLEPTR 0 (IPLUS (\GETBASEPTR GREENERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1))))) (T (* error is negative, do things differently.) (* calculate |1/4| of error.) (SETQ ERR (LRSH (IMINUS ERR) 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELGREENERROR (IDIFFERENCE (\GETBASEPTR GREENERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR GREENERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) (* |3/8| to one below) (\PUTBASEPTR GREENERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR GREENERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))))) (SETQ GREENERRTABLEPTR (\ADDBASE GREENERRTABLEPTR 2))) (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB BLUE) of RGB) BLUEBYTE)) (COND ((IGREATERP ERR -1) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELBLUEERROR (IPLUS (\GETBASEPTR BLUEERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR BLUEERRTABLEPTR 2 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASEPTR BLUEERRTABLEPTR 0 (IPLUS (\GETBASEPTR BLUEERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1))))) (T (* error is negative, do things differently.) (* calculate |1/4| of error.) (SETQ ERR (LRSH (IMINUS ERR) 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELBLUEERROR (IDIFFERENCE (\GETBASEPTR BLUEERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR BLUEERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) (* |3/8| to one below) (\PUTBASEPTR BLUEERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR BLUEERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))))) (SETQ BLUEERRTABLEPTR (\ADDBASE BLUEERRTABLEPTR 2))) COLOR))) (PUTPROPS .4BIT.MODULATE.INTENSITY.VALUE. MACRO ((STREAM) (LOGAND (IMIN 255 (IMAX (IPLUS (\BIN STREAM) (RAND MODMIN MODMAX)) 0)) 240))) (PUTPROPS .MODULATE.INTENSITY.VALUE. MACRO ((STREAM) (IMIN 255 (IMAX (IPLUS (\BIN STREAM) (RAND MODMIN MODMAX)) 0)))) (PUTPROPS SQUARE MACRO (LAMBDA (X) (* coded this way because negative arith is not is microcode for ITIMES) (COND ((IGREATERP X -1) (ITIMES X X)) (T (ITIMES (SETQ X (IMINUS X)) X))))) ) (MOVD? (QUOTE FAST.COLOR.DISTANCE) (QUOTE COLOR.DISTANCE)) (RPAQQ AISDIRECTORIES (T {CORE} {DSK} {CYAN})) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS AISDIRECTORIES) ) (PUTPROPS READAIS COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1827 40089 (24BITCOLORTO8BITMAP 1837 . 3843) (AISBLT 3845 . 10524) (AISBLT1TO1 10526 . 11817) (AISBLT8TO4MODUL 11819 . 13524) (AISBLT8TOLESSFSA 13526 . 15610) (AISBLT8TO4TRUNC 15612 . 16848 ) (AISBLT8TO8 16850 . 19104) (AISBLT4TO4 19106 . 21591) (AISBLT8TO4LESSFSA 21593 . 23620) ( AISBLT8TO1FSA 23622 . 26181) (AISBLT8TO1TRUNC 26183 . 27872) (CLOSEST.COLOR 27874 . 28236) ( GRAPHAISHISTOGRAM 28238 . 28847) (AISHISTOGRAM 28849 . 30585) (SMOOTHEDFILTER 30587 . 31648) ( SLOW.COLOR.DISTANCE 31650 . 31948) (FAST.COLOR.DISTANCE 31950 . 32242) (INSUREAISFILE 32244 . 33441) ( SHOWCOLORAIS 33443 . 35628) (SHOWCOLORAIS1 35630 . 37166) (WRITEAIS 37168 . 39031) (WRITEAIS1 39033 . 39353) (\GETBASENYBBLE 39355 . 39642) (\PUTBASENYBBLE 39644 . 40087))))) STOP \ No newline at end of file diff --git a/lispusers/READAIS.TEDIT b/lispusers/READAIS.TEDIT new file mode 100644 index 00000000..00ed95e8 Binary files /dev/null and b/lispusers/READAIS.TEDIT differ diff --git a/lispusers/READAPPLEFONT b/lispusers/READAPPLEFONT new file mode 100644 index 00000000..034bff38 --- /dev/null +++ b/lispusers/READAPPLEFONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Jul-88 16:34:43" |{MCS:MCS:STANFORD}READAPPLEFONT.;18| 8757 changes to%: (VARS READAPPLEFONTCOMS) (RECORDS APPLEFONTREC) (FNS READAPPLEFONTREC \READAPPLEFONTFILE READAPPLEFONTFILE) previous date%: "20-May-88 10:56:08" |{MCS:MCS:STANFORD}READAPPLEFONT.;12|) (* " Copyright (c) 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT READAPPLEFONTCOMS) (RPAQQ READAPPLEFONTCOMS ((FNS READAPPLEFONTFILE READAPPLEFONTREC) (INITVARS (APPLEFONTREC.OFFSET 264) READAPPLEFONT.DEBUG) (GLOBALVARS APPLEFONTREC.OFFSET READAPPLEFONT.DEBUG) (DECLARE%: DONTCOPY (RECORDS APPLEFONTREC)) (INITRECORDS APPLEFONTREC) (FILES READDISPLAYFONT) (APPENDVARS (DISPLAYFONTTYPES (APPLE READAPPLEFONTFILE)) (DISPLAYFONTEXTENSIONS APPLE)))) (DEFINEQ (READAPPLEFONTFILE [LAMBDA (STREAM FAMILY SIZE FACE) (* ; "Edited 15-Jul-88 09:37 by cdl") (LET ((APPLEFONTREC (READAPPLEFONTREC STREAM)) (CSINFO (create CHARSETINFO IMAGEWIDTHS _ (\CREATECSINFOELEMENT) YWIDTHS _ (\CREATECSINFOELEMENT))) OFFSETS WIDTHS IMAGEWIDTHS YWIDTHS NUMBCODES BITMAP CHARBITMAP) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ IMAGEWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (SETQ YWIDTHS (fetch (CHARSETINFO YWIDTHS) of CSINFO)) (with APPLEFONTREC APPLEFONTREC (replace (CHARSETINFO CHARSETASCENT) of CSINFO with ASCENT) (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with DESCENT) (SETQ BITMAP (BITMAPCREATE (UNFOLD ROWWORDS BITSPERWORD) FRECTHEIGHT)) (\BINS STREAM (fetch BITMAPBASE of BITMAP) 0 (UNFOLD (TIMES ROWWORDS FRECTHEIGHT) BYTESPERWORD)) (SETQ NUMBCODES (PLUS (DIFFERENCE LASTCHAR FIRSTCHAR) 3)) (bind (YWIDTH _ (PLUS LEADING FRECTHEIGHT)) for I from 0 to (PLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0) (* ;  "initialize the offsets and widths") (\FSETWIDTH WIDTHS I 0) (\FSETWIDTH IMAGEWIDTHS I 0) (\FSETWIDTH YWIDTHS I YWIDTH)) (for I from FIRSTCHAR as N to NUMBCODES do (\FSETOFFSET OFFSETS I (BIN16 STREAM))) (SETFILEPTR STREAM OWTLOC) (SETQ CHARBITMAP (BITMAPCREATE (TIMES FRECTWIDTH NUMBCODES) FRECTHEIGHT)) (bind WORD CHAROFFSET OLDOFFSET for CHAR from FIRSTCHAR as N to (SUB1 NUMBCODES) as OFFSET from 0 by FRECTWIDTH unless (EQUAL (SETQ WORD (BIN16 STREAM)) (MASK.1'S 0 16)) do (\FSETWIDTH WIDTHS CHAR (LOGAND WORD (MASK.1'S 0 8))) (SETQ CHAROFFSET (RSH WORD 8)) (SETQ OLDOFFSET (\FGETOFFSET OFFSETS CHAR)) (\FSETWIDTH IMAGEWIDTHS CHAR (PLUS CHAROFFSET (DIFFERENCE (\FGETOFFSET OFFSETS (ADD1 CHAR)) OLDOFFSET))) (BITBLT BITMAP OLDOFFSET 0 CHARBITMAP (PLUS CHAROFFSET OFFSET) 0 (\FGETWIDTH IMAGEWIDTHS CHAR)) (\FSETOFFSET OFFSETS CHAR OFFSET))) (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CHARBITMAP) CSINFO]) (READAPPLEFONTREC [LAMBDA (STREAM) (* ; "Edited 15-Jul-88 09:53 by cdl") (SETFILEPTR STREAM APPLEFONTREC.OFFSET) (LET ((APPLEFONTREC (create APPLEFONTREC))) (with APPLEFONTREC APPLEFONTREC (SETQ FONTTYPE (BIN16 STREAM)) (SETQ FIRSTCHAR (BIN16 STREAM)) (SETQ LASTCHAR (BIN16 STREAM)) (SETQ WIDMAX (BIN16 STREAM)) (SETQ KERNMAX (BIN16 STREAM)) (SETQ NDESCENT (BIN16 STREAM)) (SETQ FRECTWIDTH (BIN16 STREAM)) (SETQ FRECTHEIGHT (BIN16 STREAM)) [SETQ OWTLOC (PLUS (GETFILEPTR STREAM) (TIMES 2 (BIN16 STREAM] (SETQ ASCENT (BIN16 STREAM)) (SETQ DESCENT (BIN16 STREAM)) (SETQ LEADING (BIN16 STREAM)) (SETQ ROWWORDS (BIN16 STREAM))) (if READAPPLEFONT.DEBUG then (INSPECT APPLEFONTREC)) APPLEFONTREC]) ) (RPAQ? APPLEFONTREC.OFFSET 264) (RPAQ? READAPPLEFONT.DEBUG NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS APPLEFONTREC.OFFSET READAPPLEFONT.DEBUG) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE APPLEFONTREC ((FONTTYPE WORD) (FIRSTCHAR WORD) (* ; "minimum ascii code") (LASTCHAR WORD) (* ; "maximum ascii code") (WIDMAX WORD) (* ; "maximum width") (KERNMAX WORD) (* ;  "negative of maximum character kern") (NDESCENT WORD) (* ; "negative of descent") (FRECTWIDTH WORD) (* ; "width of font rectangle") (FRECTHEIGHT WORD) (* ;  "height of font rectangle, also height of bitmap") (OWTLOC FIXP) (* ; "offset to offset/width table") (ASCENT WORD) (* ;  "ascent in scan lines (=FBBdy+FBBoy)") (DESCENT WORD) (* ; "descent in scan lines (=FBBoy)") (LEADING WORD) (ROWWORDS WORD) (* ; "raster width of bitmap") )) ) (/DECLAREDATATYPE 'APPLEFONTREC '(WORD WORD WORD WORD WORD WORD WORD WORD FIXP WORD WORD WORD WORD) '((APPLEFONTREC 0 (BITS . 15)) (APPLEFONTREC 1 (BITS . 15)) (APPLEFONTREC 2 (BITS . 15)) (APPLEFONTREC 3 (BITS . 15)) (APPLEFONTREC 4 (BITS . 15)) (APPLEFONTREC 5 (BITS . 15)) (APPLEFONTREC 6 (BITS . 15)) (APPLEFONTREC 7 (BITS . 15)) (APPLEFONTREC 8 FIXP) (APPLEFONTREC 10 (BITS . 15)) (APPLEFONTREC 11 (BITS . 15)) (APPLEFONTREC 12 (BITS . 15)) (APPLEFONTREC 13 (BITS . 15))) '14) ) (/DECLAREDATATYPE 'APPLEFONTREC '(WORD WORD WORD WORD WORD WORD WORD WORD FIXP WORD WORD WORD WORD) '((APPLEFONTREC 0 (BITS . 15)) (APPLEFONTREC 1 (BITS . 15)) (APPLEFONTREC 2 (BITS . 15)) (APPLEFONTREC 3 (BITS . 15)) (APPLEFONTREC 4 (BITS . 15)) (APPLEFONTREC 5 (BITS . 15)) (APPLEFONTREC 6 (BITS . 15)) (APPLEFONTREC 7 (BITS . 15)) (APPLEFONTREC 8 FIXP) (APPLEFONTREC 10 (BITS . 15)) (APPLEFONTREC 11 (BITS . 15)) (APPLEFONTREC 12 (BITS . 15)) (APPLEFONTREC 13 (BITS . 15))) '14) (FILESLOAD READDISPLAYFONT) (APPENDTOVAR DISPLAYFONTTYPES (APPLE READAPPLEFONTFILE)) (APPENDTOVAR DISPLAYFONTEXTENSIONS APPLE) (PUTPROPS READAPPLEFONT COPYRIGHT ("Stanford University" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1145 5691 (READAPPLEFONTFILE 1155 . 4653) (READAPPLEFONTREC 4655 . 5689))))) STOP \ No newline at end of file diff --git a/lispusers/READAPPLEFONT.TEDIT b/lispusers/READAPPLEFONT.TEDIT new file mode 100644 index 00000000..dfe44524 Binary files /dev/null and b/lispusers/READAPPLEFONT.TEDIT differ diff --git a/lispusers/READBRUSH b/lispusers/READBRUSH new file mode 100644 index 00000000..0ec35642 --- /dev/null +++ b/lispusers/READBRUSH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Jun-88 02:13:42" {ERINYES}MEDLEY>READBRUSH.;2 9683 changes to%: (VARS READBRUSHCOMS) (FNS CHOOSE.IDLE.BITMAP IDLE.GLIDING.BOX) previous date%: "23-Jul-86 21:26:54" {ERINYES}MEDLEY>READBRUSH.;1) (* " Copyright (c) 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT READBRUSHCOMS) (RPAQQ READBRUSHCOMS ((FNS CHOOSE.IDLE.BITMAP READBRUSHFILE READBRUSH READROOTPICTURE IDLE.GLIDING.BOX) (FILES BITMAPFNS) [ADDVARS (IDLE.FUNCTIONS ("Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen" (SUBITEMS ("Pick image from MesaHacks" (PROGN ( CHOOSE.IDLE.BITMAP ) ' IDLE.GLIDING.BOX ] (INITVARS (IDLE.BITMAP) (BRUSHMENU) (ROOTPICTUREMENU) (BRUSHDIRECTORY "{goofy:osbu north:xerox}data>brushes>")))) (DEFINEQ (CHOOSE.IDLE.BITMAP [LAMBDA NIL (* ; "Edited 23-Jun-88 01:51 by masinter") (PROG NIL (ALLOW.BUTTON.EVENTS) (SETQ IDLE.BOUNCING.BOX (CAR (READBRUSHFILE (OR [MENU (OR BRUSHMENU (SETQ BRUSHMENU (create MENU ITEMS _ (for FILE infiles ( DIRECTORY.FILL.PATTERN BRUSHDIRECTORY "brush" "") collect (NAMEFIELD FILE] (RETURN]) (READBRUSHFILE [LAMBDA (FILE) (* lmm "23-Jul-86 21:26") (OR (AND (LITATOM FILE) (GET FILE 'BRUSH)) (PROG ((STR (OPENSTREAM (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY BRUSHDIRECTORY 'EXTENSION 'BRUSH) 'INPUT 'OLD)) M W H BM MASK REG) (BIN STR) (SETQ M (SELECTQ (BIN STR) (1 T) (0 NIL) NIL)) (SETQ W (BIN16 STR)) (SETQ H (BIN16 STR)) (RPTQ 10 (BIN STR)) (SETQ BM (READBINARYBITMAP W H STR)) (if M then (SETQ MASK (READBINARYBITMAP W H STR))) (CLOSEF STR) (SETQ BM (CONS BM MASK)) (IF (LITATOM FILE) THEN (PUT FILE 'BRUSH BM)) (RETURN BM]) (READBRUSH [LAMBDA (FILE) (* lmm " 4-Aug-85 07:31") (PROG ((BMS (READBRUSHFILE FILE)) WIN REG) (if (CDR BMS) then (SETQ WIN (ICONW (CAR BMS) (CDR BMS))) else (MOVEW (SETQ WIN (CREATEWFROMIMAGE (CAR BMS))) [fetch (REGION LEFT) of (SETQ REG (GETBOXREGION (WINDOWPROP WIN 'WIDTH) (WINDOWPROP WIN 'HEIGHT] (fetch (REGION BOTTOM) of REG)) (OPENW WIN)) (WINDOWPROP WIN 'BUTTONEVENTFN 'MOVEW) (RETURN WIN]) (READROOTPICTURE [LAMBDA (FILE) (* edited%: "17-May-85 19:21") (CHANGEBACKGROUND (READPRESS (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY "{GOOFY:OSBU NORTH}DATA>ROOTPICTURES>" 'EXTENSION 'PRESS]) (IDLE.GLIDING.BOX [LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 23-Jun-88 01:53 by masinter") (OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX)) [OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW] (OR MAXD (SETQ MAXD 4)) [SETQ BITMAPS (for X inside BITMAPS collect (if (LITATOM X) then [OR (GETPROP X 'BITMAP) (PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE X)) (BITMAPCREATE 10 10] else (IDLE.BITMAP NIL X] (LET ((W (for X in BITMAPS largest (BITMAPWIDTH X) finally (RETURN $$EXTREME))) (H (for X in BITMAPS largest (BITMAPHEIGHT X) finally (RETURN $$EXTREME))) (REG (DSPCLIPPINGREGION NIL WIN))) (LET ((XBM (BITMAPCREATE (PLUS MAXD MAXD W) (PLUS MAXD MAXD H))) (MAXX (MAX (DIFFERENCE (fetch WIDTH REG) (ADD1 W)) 10)) (MAXY (MAX (DIFFERENCE (fetch HEIGHT REG) (ADD1 W)) 10)) (MAXDD (FIX (SQRT MAXD))) X Y (CNT 0) DX DY STEPS NEWX NEWY REALX REALY ORIGX ORIGY TOY TOX THISBITMAP) (SETQ X (RAND 1 MAXX)) (SETQ Y (RAND 1 MAXY)) (BITBLT (SETQ THISBITMAP (CAR BITMAPS)) NIL NIL WIN X Y NIL NIL NIL 'INVERT) (while T do [COND ((ILEQ CNT 0) (SETQ ORIGX X) (SETQ ORIGY Y) (SETQ TOX (RAND 1 (SUB1 MAXX))) (SETQ TOY (RAND 1 (SUB1 MAXY))) (SETQ CNT (SETQ STEPS (QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X)) (ABS (DIFFERENCE TOY Y))) MAXD -1) MAXD))) (QUOTIENT (PLUS (ABS (DIFFERENCE TOX X)) STEPS -1) STEPS)) (T (SETQ CNT (SUB1 CNT] (SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX)) STEPS) TOX)) (if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X))) MAXD) then (SHOULDNT)) (SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY)) STEPS) TOY)) (if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y))) MAXD) then (SHOULDNT)) (BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE) (BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT) (BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX) (PLUS MAXD DY) NIL NIL NIL 'INVERT) (BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD) (DIFFERENCE Y MAXD) NIL NIL NIL 'INVERT) (add X DX) (add Y DY) (DISMISS WAIT]) ) (FILESLOAD BITMAPFNS) (ADDTOVAR IDLE.FUNCTIONS ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen" (SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP ) 'IDLE.GLIDING.BOX]) (RPAQ? IDLE.BITMAP ) (RPAQ? BRUSHMENU ) (RPAQ? ROOTPICTUREMENU ) (RPAQ? BRUSHDIRECTORY "{goofy:osbu north:xerox}data>brushes>") (PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1525 9021 (CHOOSE.IDLE.BITMAP 1535 . 2533) (READBRUSHFILE 2535 . 3581) (READBRUSH 3583 . 4395) (READROOTPICTURE 4397 . 4736) (IDLE.GLIDING.BOX 4738 . 9019))))) STOP \ No newline at end of file diff --git a/lispusers/READBRUSH.TEDIT b/lispusers/READBRUSH.TEDIT new file mode 100644 index 00000000..a57ad883 Binary files /dev/null and b/lispusers/READBRUSH.TEDIT differ diff --git a/lispusers/READDATATYPE b/lispusers/READDATATYPE new file mode 100644 index 00000000..6d294551 --- /dev/null +++ b/lispusers/READDATATYPE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Sep-87 14:41:03" |{MCS:MCS:STANFORD}READDATATYPE.;3| 2108 changes to%: (VARS READDATATYPECOMS) (FNS READDATATYPE) previous date%: " 8-Sep-87 11:45:52" |{MCS:MCS:STANFORD}READDATATYPE.;1|) (* " Copyright (c) 1986, 1987 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT READDATATYPECOMS) (RPAQQ READDATATYPECOMS [(FNS READDATATYPE) (P (SETSYNTAX '%@ '(MACRO FIRST READDATATYPE) (FIND-READTABLE "INTERLISP"]) (DEFINEQ (READDATATYPE [LAMBDA (FILE RDTBL) (* ; "Edited 8-Sep-87 14:38 by cdl") (if (EQ '{ (PEEKC FILE)) then [PROG (TYPE START LOC FLG (DATUM (READ FILE RDTBL))) [SETQ TYPE (SUBATOM DATUM [ADD1 (SETQ START (OR (STRPOS '{ DATUM) (RETURN] (SUB1 (SETQ START (OR (STRPOS '} DATUM START) (RETURN] [SETQ START (ADD1 (OR (STRPOS '%# DATUM START) (RETURN] [SETQ LOC (CONS (if (SETQ FLG (STRPOS '%, DATUM START)) then (PACK* (SUBATOM DATUM START (SUB1 FLG)) 'Q) else 0) (PACK* (SUBATOM DATUM (if FLG then (ADD1 FLG) else START)) 'Q] (if [EQ TYPE (TYPENAME (SETQ DATUM (VAG LOC] then (RETURN (KWOTE DATUM] else '%@]) ) (SETSYNTAX '%@ '(MACRO FIRST READDATATYPE) (FIND-READTABLE "INTERLISP")) (PUTPROPS READDATATYPE COPYRIGHT ("Stanford University" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (590 1944 (READDATATYPE 600 . 1942))))) STOP \ No newline at end of file diff --git a/lispusers/READDATATYPE.TEDIT b/lispusers/READDATATYPE.TEDIT new file mode 100644 index 00000000..b0cfab5f Binary files /dev/null and b/lispusers/READDATATYPE.TEDIT differ diff --git a/lispusers/READDISPLAYFONT b/lispusers/READDISPLAYFONT new file mode 100644 index 00000000..6e7e2611 --- /dev/null +++ b/lispusers/READDISPLAYFONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Jul-88 16:33:54" |{MCS:MCS:STANFORD}READDISPLAYFONT.;2| 4644 changes to%: (VARS READDISPLAYFONTCOMS) previous date%: " 3-May-88 10:33:05" |{MCS:MCS:STANFORD}READDISPLAYFONT.;1|) (* " Copyright (c) 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT READDISPLAYFONTCOMS) (RPAQQ READDISPLAYFONTCOMS ((* Redefinition of DISPLAY font functions to facilitate addition of new font types) (FNS \READDISPLAYFONTFILE FONTFILEFORMAT) (ADDVARS (DISPLAYFONTTYPES (AC \READACFONTFILE) (STRIKE \READSTRIKEFONTFILE))) (GLOBALVARS DISPLAYFONTTYPES) (DECLARE%: DONTCOPY (RECORDS DISPLAYFONTTYPE)))) (* Redefinition of DISPLAY font functions to facilitate addition of new font types) (DEFINEQ (\READDISPLAYFONTFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 3-May-88 10:31 by cdl") (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES)) (bind FONTFILE FONTTYPE CSINFO STREAM for EXTENSION inside DISPLAYFONTEXTENSIONS when (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET DISPLAYFONTDIRECTORIES (LIST EXTENSION))) do (* Use CLOSE? to avoid redundant CLOSEF in AC font file case) (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTREAM FONTFILE 'INPUT] (if (SETQ FONTTYPE (ASSOC (FONTFILEFORMAT STREAM T) DISPLAYFONTTYPES)) then (SETQ CSINFO (with DISPLAYFONTTYPE FONTTYPE (APPLY* READFN STREAM FAMILY SIZE FACE))) else (SHOULDNT))) (RETURN CSINFO]) (FONTFILEFORMAT [LAMBDA (STREAM LEAVEOPEN) (* ; "Edited 3-May-88 10:26 by cdl") (* Returns the font format of STREAM) [OR (OPENP STREAM 'INPUT) (SETQ STREAM (OPENSTREAM STREAM 'INPUT] (PROG1 (OR (LET [(EXTENSION (FILENAMEFIELD (FULLNAME STREAM) 'EXTENSION] (* AC and Strike files count on side effects of this function so we have to  handle them separately for now) (if (AND [NOT (FMEMB EXTENSION '(AC STRIKE] (ASSOC EXTENSION DISPLAYFONTTYPES)) then EXTENSION)) (SELECTC (\WIN STREAM) ((LIST (LLSH 1 15) (LOGOR (LLSH 1 15) (LLSH 1 13))) (* If high bit of type is on, then must be strike.  If 2nd bit is on, must be strike-index, and we punt.  We don't care about the 3rd bit) (* first word has high bits (onebit index fixed)%.  Onebit means "new-style font" %, index is 0 for simple strike, 1 for index, and  fixed is if all chars have max width. Lisp doesn't care about "fixed") 'STRIKE) ((LOGOR (LLSH 16 8) 12) (* This is the length of a standard index header.  Other files could also have this value, but it's a pretty good discriminator) (* Skip to byte 25; do it with BINS so works for non-randaccessp devices.  This skips the standard name header, then look for type 3 in the following  header) (FRPTQ 22 (\BIN STREAM)) (* (SETFILEPTR STREAM 25)) (AND (EQ 3 (LRSH (\BIN STREAM) 4)) 'AC)) NIL)) (OR LEAVEOPEN (CLOSEF STREAM]) ) (ADDTOVAR DISPLAYFONTTYPES (AC \READACFONTFILE) (STRIKE \READSTRIKEFONTFILE)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DISPLAYFONTTYPES) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD DISPLAYFONTTYPE (TYPE READFN)) ) ) (PUTPROPS READDISPLAYFONT COPYRIGHT ("Stanford University" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1028 4280 (\READDISPLAYFONTFILE 1038 . 2081) (FONTFILEFORMAT 2083 . 4278))))) STOP \ No newline at end of file diff --git a/lispusers/READDISPLAYFONT.TEDIT b/lispusers/READDISPLAYFONT.TEDIT new file mode 100644 index 00000000..2b774494 Binary files /dev/null and b/lispusers/READDISPLAYFONT.TEDIT differ diff --git a/lispusers/READEBCDIC b/lispusers/READEBCDIC new file mode 100644 index 00000000..4be9de9c --- /dev/null +++ b/lispusers/READEBCDIC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED " 9-Nov-89 15:32:46" {ICE}LISP>LYRIC>READEBCDIC.\;1 1847 |changes| |to:| (VARS READEBCDICCOMS) (FNS READEBCDIC)) (PRETTYCOMPRINT READEBCDICCOMS) (RPAQQ READEBCDICCOMS ((FNS READEBCDIC))) (DEFINEQ (READEBCDIC (LAMBDA (INFILE OUTFILE ADDCR) (* \; "Edited 9-Nov-89 15:31 by MJD") (* |;;| "Converts EBCDIC to ASCII. If ADDCR is T, adds a CR after every 80 chars.") (PROG (TRTAB TRLIST SPCHARS LCASE UCASE NUMBERS INSTREAM OUTSTREAM (COL 0)) (SETQ TRTAB (ARRAY 256 NIL " " 0)) (SETQ SPCHARS " .<(+|& !$*);~ / ,%_>? :#@'=\" ") (SETQ LCASE "abcdefghi jklmnopqr stuvwxyz ") (SETQ UCASE "ABCDEFGHI JKLMNOPQR STUVWXYZ ") (SETQ NUMBERS "0123456789") (SETQ TRLIST (UNPACK (CONCAT SPCHARS LCASE UCASE NUMBERS))) (|for| I |from| 0 |to| 31 |do| (SETA TRTAB I (CHARACTER I))) (|for| I |from| 64 |as| CHAR |in| TRLIST |do| (SETA TRTAB I CHAR)) (SETQ INSTREAM (OPENSTREAM INFILE 'INPUT 'OLD)) (SETQ OUTSTREAM (OPENSTREAM OUTFILE 'OUTPUT 'NEW)) (|until| (EOFP INSTREAM) |do| (PRIN1 (ELT TRTAB (BIN INSTREAM)) OUTSTREAM) (ADD COL 1) (IF (EQ COL 80) THEN (SETQ COL 0) (AND ADDCR (TERPRI OUTSTREAM)))) (CLOSEF INSTREAM) (CLOSEF OUTSTREAM)))) ) (DECLARE\: DONTCOPY (FILEMAP (NIL (312 1824 (READEBCDIC 322 . 1822))))) STOP \ No newline at end of file diff --git a/lispusers/READINTERPRESS b/lispusers/READINTERPRESS new file mode 100644 index 00000000..644591c4 --- /dev/null +++ b/lispusers/READINTERPRESS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-Mar-88 17:54:27" {ERINYES}MEDLEY>READINTERPRESS.;2 8705 changes to%: (FNS READINT.IP) previous date%: "15-Jul-86 21:58:05" {PHYLUM}LYRIC>READINTERPRESS.;1) (* " Copyright (c) 1983, 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT READINTERPRESSCOMS) (RPAQQ READINTERPRESSCOMS ((* "Utilities for reading Interpress files") (FNS PRINTMASTER) (FNS OPCODE TOKEN FINDNONPRIMNAME FINDOPNAME SHORTINT TOKENFORMAT FINDSEQUENCETYPE PRINTTOKEN PRINTSEQUENCE SEARCHIPLIST READINT.IP SHOWFILE SHOWBYTE) (MACROS BIN.RIP) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) INTERPRESS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA SHORTINT TOKEN)))) ) (* "Utilities for reading Interpress files") (DEFINEQ (PRINTMASTER (LAMBDA (FILE OUTPUTFILE FROM TO) (* hdj "15-Jul-86 21:04") (RESETLST (PROG (ISTREAM) (RESETSAVE (SETQ ISTREAM (OPENSTREAM FILE (QUOTE INPUT))) (QUOTE (PROGN (CLOSEF OLDVALUE)))) (if OUTPUTFILE then (RESETSAVE (SETQ OUTPUTFILE (OPENSTREAM OUTPUTFILE (QUOTE OUTPUT))) (QUOTE (PROGN (CLOSEF OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE)))))) (* Print the encoding string) (bind C until (EQ (SETQ C (BIN ISTREAM)) (CHARCODE SPACE)) do (PRINTCCODE C OUTPUTFILE)) (TERPRI OUTPUTFILE) (SETFILEPTR ISTREAM (IMAX (\GETFILEPTR ISTREAM) (OR FROM 0))) (until (EOFP ISTREAM) do (printout OUTPUTFILE |.I5| (GETFILEPTR ISTREAM) "|" 8) (PRINTTOKEN ISTREAM OUTPUTFILE))))) ) ) (DEFINEQ (OPCODE (LAMBDA (BYTE1 BYTE2) (* rmk%: "19-APR-83 17:51") (FINDOPNAME (IPLUS (LLSH (LOGAND BYTE1 31) 8) (OR BYTE2 0)))) ) (TOKEN (LAMBDA BYTES (* edited%: "20-APR-83 10:06") (COND ((ZEROP BYTES) NIL) ((NLISTP (ARG BYTES 1)) (APPLY (FUNCTION TOKEN) (ARG BYTES 1))) (T (SELECTQ (TOKENFORMAT (ARG BYTES 1)) (SHORTINT (APPLY (FUNCTION SHORTINT) (for I from 1 to BYTES collect (ARG BYTES I)))) (SHORTOP (FINDOPNAME (LOGAND (ARG BYTES 1) 31))) (LONGOP (FINDOPNAME (IPLUS (LLSH (LOGAND (ARG BYTES 1) 31) 8) (OR (ARG BYTES 2) 0)))) (SHORTSEQUENCE (PROG (LEN (TYPE (FINDSEQUENCETYPE (LOGAND (ARG BYTES 1) 31)))) (COND ((IGREATERP BYTES 0) (SETQ LEN (ARG BYTES 2)))))) (LONGSEQUENCE) (SHOULDNT))))) ) (FINDNONPRIMNAME (LAMBDA (CODE) (* rmk%: "15-Mar-84 09:07") (SEARCHIPLIST CODE (CONSTANT NONPRIMS)))) (FINDOPNAME (LAMBDA (CODE) (* rmk%: "16-Jun-84 15:24") (SEARCHIPLIST CODE (CONSTANT (for OP DOTLOC in OPERATORS collect (* Strip off extension) (COND ((SETQ DOTLOC (STRPOS "." (CAR OP))) (LIST (SUBATOM (CAR OP) 1 (SUB1 DOTLOC)) (CADR OP))) (T OP)))))) ) (SHORTINT (LAMBDA BYTES (* rmk%: "19-APR-83 17:34") (for I (RESULT _ 0) from 1 to BYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8) (ARG BYTES I))) finally (RETURN (IDIFFERENCE RESULT 4000)))) ) (TOKENFORMAT (LAMBDA (BYTE) (* rmk%: "19-APR-83 17:41") (SELECTQ (LRSH BYTE 7) (0 (QUOTE SHORTINT)) (SELECT (LOGAND (LRSH BYTE 5) 3) (0 (QUOTE SHORTOP)) (1 (QUOTE LONGOP)) (2 (QUOTE SHORTSEQUENCE)) (3 (QUOTE LONGSEQUENCE)) (SHOULDNT)))) ) (FINDSEQUENCETYPE (LAMBDA (CODE) (* rmk%: "15-Mar-84 09:04") (for X in (CONSTANT SEQUENCETYPES) when (EQ CODE (CADR X)) do (RETURN (CAR X)) finally (RETURN (LIST CODE (QUOTE NOT-A-SEQUENCE-TYPE))))) ) (PRINTTOKEN (LAMBDA (ISTREAM OSTREAM) (* hdj "15-Jul-86 21:55") (PROG (CODE BYTE2 (BYTE1 (BIN.RIP ISTREAM OSTREAM))) (SELECTQ (TOKENFORMAT BYTE1) (SHORTINT (SETQ BYTE2 (BIN.RIP ISTREAM OSTREAM)) (printout OSTREAM .TAB 20) (PRINT (SHORTINT BYTE1 BYTE2) OSTREAM)) (SHORTOP (SETQ CODE (LOGAND BYTE1 31)) (printout OSTREAM .TAB 20) (printout OSTREAM (OR (FINDOPNAME CODE) (FINDNONPRIMNAME CODE) (CONCAT CODE "not an opcode")) T)) (LONGOP (SETQ CODE (IPLUS (LLSH (LOGAND BYTE1 31) 8) (BIN.RIP ISTREAM OSTREAM))) (printout OSTREAM .TAB 20) (printout OSTREAM (OR (FINDOPNAME CODE) (FINDNONPRIMNAME CODE) (CONCAT CODE "not an opcode")) T)) (SHORTSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31)) (BIN.RIP ISTREAM OSTREAM))) (LONGSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31)) (LOGOR (LLSH (BIN.RIP ISTREAM OSTREAM) 16) (LLSH (BIN.RIP ISTREAM OSTREAM) 8) (BIN.RIP ISTREAM OSTREAM)))) (SHOULDNT)))) ) (PRINTSEQUENCE (LAMBDA (ISTREAM OUTSTREAM TYPE LENGTH) (* hdj "15-Jul-86 21:43") (SELECTQ TYPE (SEQIDENTIFIER (printout OUTSTREAM 20 "ID: ") (CHARSET ISTREAM 0) (bind (CHARSET _ 0) until (EQ LENGTH 0) do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH) OUTSTREAM))) (SEQINTEGER (printout OUTSTREAM 20) (for I from 1 to LENGTH do (PRINTTOKEN ISTREAM OUTSTREAM))) (SEQRATIONAL (PROG ((NUM (READINT.IP ISTREAM (LRSH LENGTH 1))) (DENOM (READINT.IP ISTREAM (LRSH LENGTH 1)))) (printout OUTSTREAM 20 NUM "/" DENOM " = " (FQUOTIENT NUM DENOM)))) (SEQSTRING (printout OUTSTREAM 20 "STR[" LENGTH "] = %"") (CHARSET ISTREAM 0) (bind (CHARSET _ 0) until (EQ LENGTH 0) do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH) OUTSTREAM)) (printout OUTSTREAM (QUOTE %"))) (SEQCOMMENT (for I from 1 to LENGTH first (printout OUTSTREAM 20 "Comment vector of " LENGTH " bytes" 22) do (printout OUTSTREAM |.I4| (BIN ISTREAM)))) (SEQPACKEDPIXELVECTOR (bind YBYTES (I _ 5) (XBITS _ (READINT.IP ISTREAM 2)) (YBITS _ (READINT.IP ISTREAM 2)) first (printout OUTSTREAM 20 "Packed pixel" " vector of " LENGTH " bytes [" XBITS "X" YBITS "]") (SETQ YBYTES (UNFOLD (FOLDHI YBITS BITSPERWORD) BYTESPERWORD)) (* "The number of bytes on a line is always even--gets to a word boundary") while (ILEQ I LENGTH) do (printout OUTSTREAM T 10) (for J from 1 to YBYTES do (printout OUTSTREAM |.I8.-2.T| (BIN ISTREAM)) (add I 1)))) (SEQLARGEVECTOR (for I VAL (BYTESPERELT _ (BIN ISTREAM)) from 2 to LENGTH first (printout OUTSTREAM 20 "Large vector of " BYTESPERELT " bytes per element") do (SETQ VAL (READINT.IP ISTREAM BYTESPERELT)) (printout OUTSTREAM 22 |.I5| I ": " VAL))) (SEQCONTINUED (HELP "Can't handle SEQCONTINUED yet")) (SEQINSERTFILE (HELP "Can't handle SEQINSERTFILE yet")) (SEQCOMPRESSPIXELVECTOR (HELP "Can't handle SEQCOMPRESSPIXELVECTOR yet")) (SHOULDNT)) (TERPRI OUTSTREAM)) ) (SEARCHIPLIST (LAMBDA (CODE IPLIST) (* rmk%: "15-Mar-84 09:15") (for X in IPLIST when (EQ CODE (CADR X)) do (RETURN (CAR X)))) ) (READINT.IP (LAMBDA (ISTREAM NBYTES) (* ; "Edited 25-Mar-88 17:50 by bvm") (for I (RESULT _ 0) from 1 to NBYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8) (BIN.RIP ISTREAM))) finally (RETURN (SIGNED RESULT (UNFOLD NBYTES BITSPERBYTE))))) ) (SHOWFILE (LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES) (* rmk%: "16-Jun-84 15:29") (OR MAXZEROLINES (SETQ MAXZEROLINES 5)) (RESETLST (PROG (STREAM) (RESETSAVE (SETQ STREAM (OPENFILE IPFILE (QUOTE INPUT))) (QUOTE (PROGN (CLOSEF? OLDVALUE)))) (SETQ STREAM (GETSTREAM STREAM)) (* Don't do an OPENSTREAM until (OPENP stream) is NIL if stream is closed.) (RESETSAVE (OUTPUT)) (RESETSAVE (SETQ OUTPUTFILE (OPENFILE OUTPUTFILE (QUOTE OUTPUT))) (QUOTE (PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE))))) (OUTPUT OUTPUTFILE) (printout NIL .FONT DEFAULTFONT (OPENP STREAM (QUOTE INPUT)) T T) (for I B1 B2 B3 B4 B5 B6 B7 B8 (NZEROLINES _ 0) from 1 by 8 until (\EOFP STREAM) do (printout NIL |.I5| I %,,) (SETQ B1 (SHOWBYTE STREAM)) (SETQ B2 (SHOWBYTE STREAM)) (SETQ B3 (SHOWBYTE STREAM)) (SETQ B4 (SHOWBYTE STREAM)) (printout NIL %,,) (SETQ B5 (SHOWBYTE STREAM)) (SETQ B6 (SHOWBYTE STREAM)) (SETQ B7 (SHOWBYTE STREAM)) (SETQ B8 (SHOWBYTE STREAM)) (TAB 23) (COND (B1 (printout NIL |.I4| B1))) (COND (B2 (printout NIL |.I4| B2))) (COND (B3 (printout NIL |.I4| B3))) (COND (B4 (printout NIL |.I4| B4))) (printout NIL %,,) (COND (B5 (printout NIL |.I4| B5))) (COND (B6 (printout NIL |.I4| B6))) (COND (B7 (printout NIL |.I4| B7))) (COND (B8 (printout NIL |.I4| B8 T)))) (RETURN (LIST (CLOSEF IPFILE) (CLOSEF OUTPUTFILE)))))) ) (SHOWBYTE (LAMBDA (STREAM) (* rmk%: "13-JUL-82 18:01") (PROG ((BYTE (COND ((NOT (\EOFP STREAM)) (\BIN STREAM))))) (COND (BYTE (PRIN1 (COND ((AND (IGEQ BYTE (CHARCODE SPACE)) (ILESSP BYTE (CHARCODE DEL)) (NEQ BYTE 96)) (CHARACTER BYTE)) (T (QUOTE %.)))))) (RETURN BYTE))) ) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BIN.RIP MACRO (ARGS (LET ((ISTREAM (CAR ARGS)) (OSTREAM (CADR ARGS))) (BQUOTE (LET ((C (BIN (\, ISTREAM)))) (COND ((IGREATERP (POSITION (\, OSTREAM)) 15) (printout (\, OSTREAM) 5 "|" 8))) (printout (\, OSTREAM) |.I3| C " ") C))))) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) INTERPRESS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA SHORTINT TOKEN) ) (PUTPROPS READINTERPRESS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (910 1596 (PRINTMASTER 920 . 1594)) (1597 8114 (OPCODE 1607 . 1732) (TOKEN 1734 . 2306) (FINDNONPRIMNAME 2308 . 2413) (FINDOPNAME 2415 . 2672) (SHORTINT 2674 . 2867) (TOKENFORMAT 2869 . 3111 ) (FINDSEQUENCETYPE 3113 . 3317) (PRINTTOKEN 3319 . 4270) (PRINTSEQUENCE 4272 . 6133) (SEARCHIPLIST 6135 . 6267) (READINT.IP 6269 . 6508) (SHOWFILE 6510 . 7834) (SHOWBYTE 7836 . 8112))))) STOP \ No newline at end of file diff --git a/lispusers/README.md b/lispusers/README.md new file mode 100644 index 00000000..4154ef8e --- /dev/null +++ b/lispusers/README.md @@ -0,0 +1,5 @@ +# lispusers +folder of user contributed code; a subproject of Interlisp/Medley because it has a different update cycle. + +These were contributed to to allow distribution without any promise of support. + The copyright of files may or may not be marked in their sources. diff --git a/lispusers/REGION b/lispusers/REGION new file mode 100644 index 00000000..9bc67ad5 --- /dev/null +++ b/lispusers/REGION @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Nov-87 15:59:49" {QV}LISP>LYRIC>USERS>REGION.;5 9127 changes to%: (VARS REGIONCOMS) (FNS MAKEREGIONEVENT ENABLE-WINDOW DISABLE-WINDOW REMOVEREGIONEVENT ADDREGIONEVENT) (VARIABLES DISABLEDFLG) (PROPS (REGION MAKEFILE-ENVIRONMENT)) previous date%: "12-Nov-87 18:11:28" {QV}LISP>LYRIC>USERS>REGION.;4) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT REGIONCOMS) (RPAQQ REGIONCOMS ((RECORDS REGIONEVENT) (FNS ADDREGIONEVENT DISABLE-WINDOW DISABLED-WINDOW? ENABLE-WINDOW MAKEREGIONEVENT MOUSE-POSITION MOUSE-REGIONS REGIONEVENTFN REGIONINFN REGIONMOVEDFN REGIONOUTFN REGIONREPAINTFN REMOVEREGIONEVENT SET-REGIONS SETUP-FOR-REGIONS UPDATE-MOUSE-IN-WINDOW) (GLOBALVARS DISABLEDFLG) (PROP MAKEFILE-ENVIRONMENT REGION) (VARIABLES DISABLEDFLG)) ) (DECLARE%: EVAL@COMPILE (RECORD REGIONEVENT (EVENTREGION REGIONBUTTONFN REGIONMOVEDFN REGIONINFN REGIONOUTFN REGIONREPAINTFN DATA) ) ) (DEFINEQ (ADDREGIONEVENT [LAMBDA (Window RegionEvent) (* ; "Edited 12-Nov-87 18:07 by hed") (WINDOWADDPROP Window 'REGIONEVENTLST RegionEvent T]) (DISABLE-WINDOW [LAMBDA (Window) (* ; "Edited 12-Nov-87 18:10 by hed") (if (EQ DISABLEDFLG T) then NIL elseif (NULL DISABLEDFLG) then (SETQ DISABLEDFLG (LIST Window)) elseif (WINDOWP DISABLEDFLG) then (SETQ DISABLEDFLG (LIST Window DISABLEDFLG)) elseif (NLISTP DISABLEDFLG) then (SETQ DISABLEDFLG (LIST Window)) else (CL:PUSHNEW Window DISABLEDFLG]) (DISABLED-WINDOW? [LAMBDA (Window) (* ; "Edited 10-Nov-87 19:33 by hed") (OR (EQ DISABLEFLG T) (EQ DISABLEFLG Window) (AND (LISTP DISABLEFLG) (FMEMB Window DISABLEFLG]) (ENABLE-WINDOW [LAMBDA (Window) (* ; "Edited 12-Nov-87 18:07 by hed") (if (EQ DISABLEDFLG Window) then (SETQ DISABLEDFLG NIL) elseif (LISTP DISABLEDFLG) then (DREMOVE Window DISABLEDFLG) else (ERROR "Can't enable just one window when DISABLEDFLG is T."]) (MAKEREGIONEVENT (LAMBDA (EventRegion Data ButtonFn MovedFn InFn OutFn RepaintFn) (* ; "Edited 13-Nov-87 15:56 by hed") (create REGIONEVENT EVENTREGION _ EventRegion REGIONBUTTONFN _ ButtonFn REGIONMOVEDFN _ MovedFn REGIONINFN _ InFn REGIONOUTFN _ OutFn REGIONREPAINTFN _ RepaintFn DATA _ Data)) ) (MOUSE-POSITION [LAMBDA (Window) (* ; "Edited 10-Nov-87 19:25 by hed") (create POSITION (XCOORD _ (WINDOWPROP Window 'LASTMOUSEX)) (YCOORD _ (WINDOWPROP Window 'LASTMOUSEY]) (MOUSE-REGIONS [LAMBDA (Window) (* ; "Edited 11-Nov-87 11:22 by hed") (for Reg in (WINDOWPROP Window 'REGIONEVENTLST) collect Reg when (INSIDEP (fetch EVENTREGION of Reg) (WINDOWPROP Window 'LASTMOUSEX) (WINDOWPROP Window 'LASTMOUSEY]) (REGIONEVENTFN [LAMBDA (Window) (* ; "Edited 11-Nov-87 11:39 by hed") (* ;; " Called whenever a mouse button is changed in a regionized window. Calls the REGIONBUTTONFN of every region the mouse is in.") (if (NOT (DISABLED-WINDOW? Window)) then (for Reg in (MOUSE-REGIONS Window) bind FN do (if (SETQ FN (fetch REGIONBUTTONFN of Reg)) then (APPLY* FN Window (MOUSE-POSITION Window]) (REGIONINFN [LAMBDA (Window) (* ; "Edited 11-Nov-87 11:34 by hed") (* ;; "Called whenever the cursor moves into a regionized window. Calls the CURSORINFN of every region which the cursor is now in.") (UPDATE-MOUSE-IN-WINDOW Window) (if (NOT (DISABLED-WINDOW? Window)) then (for Reg in (MOUSE-REGIONS Window) bind FN do (if (SETQ FN (fetch REGIONINFN of Reg)) then (APPLY* FN Window Reg]) (REGIONMOVEDFN [LAMBDA (Window) (* ; "Edited 11-Nov-87 11:37 by hed") (* ;; " Called whenever the mouse moves within a regionized window. Calls the REGIONOUTFN of any regions the mouse has left, the REGIONINFN of any regions the mouse has now entered, and the REGIONMOVEDFN of any regions the mouse has moved around in. Also updates the LASTMOUSEX and LASTMOUSEY window properties for the next time.") (LET ((OldActives (MOUSE-REGIONS Window)) NewActives) (UPDATE-MOUSE-IN-WINDOW Window) (if (NOT (DISABLED-WINDOW? Window)) then (SETQ NewActives (MOUSE-REGIONS Window)) [for Reg in (INTERSECTION OldActives NewActives) bind FN do (if (SETQ FN (fetch REGIONMOVEDFN of Reg)) then (APPLY* FN Window (MOUSE-POSITION Window] (for Reg in (LDIFFERENCE OldActives NewActives) bind FN do (if (SETQ FN (fetch REGIONOUTFN of Reg)) then (APPLY* FN Window Reg))) (for Reg in (LDIFFERENCE NewActives OldActives) bind FN do (if (SETQ FN (fetch REGIONINFN of Reg)) then (APPLY* FN Window Reg]) (REGIONOUTFN [LAMBDA (Window) (* ; "Edited 11-Nov-87 11:36 by hed") (* ;; "Called whenever the mouse leaves a regionized window. Calls the CURSOROUTFN of every region the mouse was in. The mouse's position within the window is cached on the window properties LASTMOUSEX and LASTMOUSEY, updated by REGIONINFN and REGIONMOVEDFN, so we can tell where the mouse was before leaving.") [if (NOT (DISABLED-WINDOW? Window)) then (for Reg in (MOUSE-REGIONS Window) bind FN do (if (SETQ FN (fetch REGIONOUTFN of Reg)) then (APPLY* FN Window Reg] (UPDATE-MOUSE-IN-WINDOW Window) (* ;  "Will put some negative numbers in there, but that's OK.") ]) (REGIONREPAINTFN [LAMBDA (Window RepaintRegion) (* ; "Edited 11-Nov-87 11:41 by hed") (* ;; "Called whenever a regionized window is repainted. Calls the REGIONREPAINTFN of every region intersecting the RepaintRegion.") (if (NOT (DISABLED-WINDOW? Window)) then (for Reg in (WINDOWPROP Window 'REGIONEVENTLST) bind FN do (if (SETQ FN (fetch REGIONREPAINTFN of Reg)) then (APPLY* FN Window Reg)) when (REGIONSINTERSECTP RepaintRegion (fetch EVENTREGION of Reg]) (REMOVEREGIONEVENT [LAMBDA (Window RegionEvent) (* ; "Edited 12-Nov-87 18:07 by hed") (WINDOWDELPROP Window 'REGIONEVENTLST RegionEvent]) (SET-REGIONS [LAMBDA (Window RegionEvents) (* ; "Edited 11-Nov-87 11:08 by hed") (WINDOWPROP Window 'REGIONEVENTLST RegionEvents) (SETUP-FOR-REGIONS Window) (UPDATE-MOUSE-IN-WINDOW Window]) (SETUP-FOR-REGIONS [LAMBDA (Window) (* ; "Edited 10-Nov-87 19:32 by hed") (WINDOWPROP Window 'CURSORINFN (FUNCTION REGIONINFN)) (WINDOWPROP Window 'CURSOROUTFN (FUNCTION REGIONOUTFN)) (WINDOWPROP Window 'REPAINTFN (FUNCTION REGIONREPAINTFN)) (WINDOWPROP Window 'CURSORMOVEDFN (FUNCTION REGIONMOVEDFN)) (WINDOWPROP Window 'BUTTONEVENTFN (FUNCTION REGIONEVENTFN]) (UPDATE-MOUSE-IN-WINDOW [LAMBDA (Window) (* ; "Edited 11-Nov-87 10:59 by hed") (* ;; "Updates LASTMOUSEX and LASTMOUSEY properties of Window with latest mouse location in window co-ordinates.") (LET [(WinReg (WINDOWPROP Window 'REGION] (WINDOWPROP Window 'LASTMOUSEX (LASTMOUSEX Window)) (WINDOWPROP Window 'LASTMOUSEY (LASTMOUSEX Window]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DISABLEDFLG) ) (PUTPROPS REGION MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (CL:DEFVAR DISABLEDFLG NIL "NIL -> REGIONs is running for all windows; T -> REGIONs is off for all windows; Window or list of windows -> REGIONs is disabled for the specified windows.") (PUTPROPS REGION COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1045 8710 (ADDREGIONEVENT 1055 . 1240) (DISABLE-WINDOW 1242 . 1744) (DISABLED-WINDOW? 1746 . 2004) (ENABLE-WINDOW 2006 . 2369) (MAKEREGIONEVENT 2371 . 2672) (MOUSE-POSITION 2674 . 2923) ( MOUSE-REGIONS 2925 . 3290) (REGIONEVENTFN 3292 . 3843) (REGIONINFN 3845 . 4406) (REGIONMOVEDFN 4408 . 5821) (REGIONOUTFN 5823 . 6713) (REGIONREPAINTFN 6715 . 7396) (REMOVEREGIONEVENT 7398 . 7584) ( SET-REGIONS 7586 . 7839) (SETUP-FOR-REGIONS 7841 . 8279) (UPDATE-MOUSE-IN-WINDOW 8281 . 8708))))) STOP \ No newline at end of file diff --git a/lispusers/REGION.TEDIT b/lispusers/REGION.TEDIT new file mode 100644 index 00000000..3a687b3f Binary files /dev/null and b/lispusers/REGION.TEDIT differ diff --git a/lispusers/REGISTER-MACHINE b/lispusers/REGISTER-MACHINE new file mode 100644 index 00000000..2f35aad5 --- /dev/null +++ b/lispusers/REGISTER-MACHINE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Jan-88 18:02:00" {ERINYES}LYRIC>REGISTER-MACHINE.;2 4471 changes to%: (FNS Requst-NS-Registry AmIRegistered) (VARS REGISTER-MACHINECOMS) previous date%: "13-Feb-87 16:07:50" {PHYLUM}FORMS>REGISTER-MACHINE.;3) (* " Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT REGISTER-MACHINECOMS) (RPAQQ REGISTER-MACHINECOMS ( (* ;;; "Add a Lafite form that will request that the current machine be registered with the local Clearinghouse") (FNS Requst-NS-Registry AmIRegistered) (ADDVARS (LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry "Make a form to request that the current machine be registered on the local Clearinghouse" ))) (P (UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS) (SETQ LAFITEFORMSMENU NIL)))) (* ;;; "Add a Lafite form that will request that the current machine be registered with the local Clearinghouse" ) (DEFINEQ (Requst-NS-Registry [LAMBDA NIL (* ; "Edited 8-Jan-88 18:00 by Masinter") (* ;;; "Format a nice note requsting that the current machine be registered on the local Clearinghouse.") (LET ((*STANDARD-OUTPUT* (OPENTEXTSTREAM "" NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) (netNumber (fetch NSNET \MY.NSADDRESS)) (me (FULLUSERNAME)) (CURRENTLY (AmIRegistered))) (CL:FORMAT T "To: UserAdministration~A~A~&" (SELECTQ (LAFITEMODE) (GV ".") ":") CH.DEFAULT.DOMAIN) (CL:FORMAT T "Cc: ~A~%%Reply-to: ~A~%%~%%" me me) (if CURRENTLY then (CL:FORMAT T ">>This machine is already registered as ~A <<~%%~%%" CURRENTLY)) (printout NIL "Primary User: " me T T) (printout NIL "Name: %"" (OR (ETHERHOSTNAME) ">>Desired machine name<<") "%"" T) (CL:FORMAT T "Network Number: ~5,,'-:D~&" (fetch NSNET \MY.NSADDRESS)) (CL:FORMAT T "Processor Number: ~5,,'-:D~&" (+ (LSH (fetch NSHNM0 \MY.NSADDRESS) 32) (LSH (fetch NSHNM1 \MY.NSADDRESS) 16) (fetch NSHNM2 \MY.NSADDRESS))) (printout NIL "Description: A " (L-CASE (MACHINETYPE) T) " (typically running Lisp)" T) (printout NIL T T "Thank you." T T "-- " FIRSTNAME T) (LET ((field (TEDIT.FIND *STANDARD-OUTPUT* ">>*<<" 1 NIL T))) (if field then (TEDIT.SETSEL *STANDARD-OUTPUT* (CAR field) (ADD1 (DIFFERENCE (CADR field) (CAR field))) 'LEFT T))) *STANDARD-OUTPUT*]) (AmIRegistered [LAMBDA NIL (* ; "Edited 8-Jan-88 18:00 by Masinter") (CL:FLET [(OK (NAMES) (for wsn in (CH.LIST.OBJECTS NAMES 'WORKSTATION) when (EQUALALL \MY.NSADDRESS (LOOKUP.NS.SERVER wsn)) do (RETURN (LIST wsn] (OR (AND (ETHERHOSTNAME) (OK (ETHERHOSTNAME))) (OK "*"]) ) (ADDTOVAR LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry "Make a form to request that the current machine be registered on the local Clearinghouse" )) (UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS) (SETQ LAFITEFORMSMENU NIL) (PUTPROPS REGISTER-MACHINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1298 4072 (Requst-NS-Registry 1308 . 3473) (AmIRegistered 3475 . 4070))))) STOP \ No newline at end of file diff --git a/lispusers/REMOTEPSW b/lispusers/REMOTEPSW new file mode 100644 index 00000000..58057793 --- /dev/null +++ b/lispusers/REMOTEPSW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "18-Jul-88 13:37:07" |{MCS:MCS:STANFORD}REMOTEPSW.;13| 21089 changes to%: (VARS REMOTEPSWCOMS) (FNS \REMOTE.PSWOP.SELECTED REMOTE.PROCESS.STATUS.WINDOW REMOTE.PROCESS.BACKTRACE REMOTE.PSW.REDISPLAY \REMOTE.PROCESS.BACKTRACE \REMOTE.PROCESS.RESTART \REMOTE.PROCESS.SUSPEND \REMOTE.PROCESS.TTY \REMOTE.PROCESS.WAKE) (RECORDS PROCESSDATA) previous date%: " 9-Nov-87 09:27:45" |{MCS:MCS:STANFORD}REMOTEPSW.;9|) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University. All rights reserved. ") (PRETTYCOMPRINT REMOTEPSWCOMS) (RPAQQ REMOTEPSWCOMS ((FNS REMOTE.PROCESS.STATUS.WINDOW) (FNS REMOTE.PROCESS.BACKTRACE REMOTE.PSW.REDISPLAY REMOTE.PROCESS.ERROR \REMOTE.GET.PROCESS.DATA \REMOTE.PROCESS.BACKTRACE \REMOTE.PROCESS.KILL \REMOTE.PROCESS.RESTART \REMOTE.PROCESS.SUSPEND \REMOTE.PROCESS.TTY \REMOTE.PROCESS.WAKE \REMOTE.PSW.SELECTED \REMOTE.PSWOP.SELECTED) (VARS REMOTE.PSW.ITEMS REMOTE.PROCESS.ERRORS REMOTE.PROCESS.BACKTRACE.COMMANDS) (GLOBALVARS REMOTE.PSW.ITEMS REMOTE.PROCESS.ERRORS REMOTE.PROCESS.BACKTRACE.COMMANDS) (DECLARE%: DONTCOPY (RECORDS PROCESSDATA REMOTE.PSW.MENUS) (CONSTANTS (SELECTIONSHADE 520))) (FILES COURIERSERVE COURIERDEFS) (COURIERPROGRAMS PROCESS) (P (COURIER.START.SERVER)))) (DEFINEQ (REMOTE.PROCESS.STATUS.WINDOW [LAMBDA (HOST) (* ; "Edited 18-Jul-88 11:15 by cdl") (LET ((COURIERSTREAM (COURIER.OPEN HOST)) (WINDOW (CREATEW (CREATEREGION 0 0 100 100) HOST NIL T))) (WINDOWPROP WINDOW 'COURIERSTREAM COURIERSTREAM) (WINDOWPROP WINDOW 'LOCK (CREATE.MONITORLOCK)) [WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (CLOSEF? (WINDOWPROP WINDOW 'COURIERSTREAM NIL] (REMOTE.PSW.REDISPLAY WINDOW) (MOVEW WINDOW) WINDOW]) ) (DEFINEQ (REMOTE.PROCESS.BACKTRACE [LAMBDA (PROCESS CMD WINDOW) (* ; "Edited 18-Jul-88 10:11 by cdl") (DECLARE (GLOBALVARS BACKTRACEFONT PROCBACKTRACEHEIGHT)) (PROG (PLACE REGION BACKTRACEWINDOW BULK.DATA.STREAM) (DECLARE (SPECVARS BACKTRACEWINDOW BULK.DATA.STREAM)) (if [NOT (WINDOWP (SETQ BACKTRACEWINDOW (CAR (ATTACHEDWINDOWS WINDOW] then (SETQ BACKTRACEWINDOW (CREATEW (with REGION (SETQ REGION (WINDOWPROP WINDOW 'REGION)) (create REGION BOTTOM _ (if (LESSP BOTTOM PROCBACKTRACEHEIGHT ) then (SETQ PLACE 'TOP) TOP else (SETQ PLACE 'BOTTOM) (DIFFERENCE BOTTOM PROCBACKTRACEHEIGHT )) HEIGHT _ PROCBACKTRACEHEIGHT using REGION)) "Process backtrace" NIL T)) (ATTACHWINDOW BACKTRACEWINDOW WINDOW PLACE 'JUSTIFY 'LOCALCLOSE) (DSPSCROLL 'OFF BACKTRACEWINDOW) (DSPFONT BACKTRACEFONT BACKTRACEWINDOW)) (DSPRESET BACKTRACEWINDOW) (SETQ BULK.DATA.STREAM (COURIER.CALL (WINDOWPROP WINDOW 'COURIERSTREAM) 'PROCESS 'BACKTRACE PROCESS CMD NIL)) (RESETLST [RESETSAVE NIL `(CLOSEF? ,BULK.DATA.STREAM] (COPYBYTES BULK.DATA.STREAM BACKTRACEWINDOW))]) (REMOTE.PSW.REDISPLAY [LAMBDA (WINDOW PROCESSDATA) (* ; "Edited 18-Jul-88 10:15 by cdl") (DECLARE (GLOBALVARS DEFAULTFONT)) (PROG ((COURIERSTREAM (WINDOWPROP WINDOW 'COURIERSTREAM)) PMENU OPMENU SELECTED WIDTH) [if (NULL PROCESSDATA) then (SETQ PROCESSDATA (COURIER.CALL COURIERSTREAM 'PROCESS 'GET.PROCESS.DATA] (for ATTACHEDWINDOW in (WINDOWPROP WINDOW 'ATTACHEDWINDOWS) do (DETACHWINDOW ATTACHEDWINDOW) (CLOSEW ATTACHEDWINDOW)) (with REMOTE.PSW.MENUS (WINDOWPROP WINDOW 'MENU) (if COMMANDMENU then (SETQ OPMENU COMMANDMENU) else (SETQ OPMENU (create MENU ITEMS _ REMOTE.PSW.ITEMS WHENSELECTEDFN _ (FUNCTION \REMOTE.PSWOP.SELECTED) CENTERFLG _ T MENUCOLUMNS _ 3))) (if PROCESSMENU then (DELETEMENU PROCESSMENU NIL WINDOW))) (SETQ PMENU (create MENU ITEMS _ (with PROCESSDATA PROCESSDATA PROCESSES) WHENSELECTEDFN _ (FUNCTION \REMOTE.PSW.SELECTED) MENUFONT _ DEFAULTFONT CENTERFLG _ T)) [SHAPEW WINDOW (create REGION WIDTH _ [WIDTHIFWINDOW (SETQ WIDTH (MAX (fetch IMAGEWIDTH of PMENU) (fetch IMAGEWIDTH of OPMENU] HEIGHT _ (HEIGHTIFWINDOW (PLUS (fetch IMAGEHEIGHT of PMENU) (fetch IMAGEHEIGHT of OPMENU) 4) T) using (WINDOWPROP WINDOW 'REGION] (if (NULL (with REMOTE.PSW.MENUS (WINDOWPROP WINDOW 'MENUS) COMMANDMENU)) then (ADDMENU OPMENU WINDOW (create POSITION XCOORD _ (QUOTIENT (DIFFERENCE WIDTH (fetch IMAGEWIDTH of OPMENU)) 2) YCOORD _ 0))) (ADDMENU PMENU WINDOW (create POSITION XCOORD _ (QUOTIENT (DIFFERENCE (with REGION (DSPCLIPPINGREGION NIL WINDOW) WIDTH) (fetch IMAGEWIDTH of PMENU)) 2) YCOORD _ (PLUS (fetch IMAGEHEIGHT of OPMENU) 4))) (if (SETQ SELECTED (with PROCESSDATA PROCESSDATA SELECTED)) then (if (FMEMB SELECTED (with PROCESSDATA PROCESSDATA PROCESSES)) then (SHADEITEM SELECTED PMENU SELECTIONSHADE))) (WINDOWPROP WINDOW 'PROCESSDATA PROCESSDATA]) (REMOTE.PROCESS.ERROR [LAMBDA (ERROR) (* ; "Edited 4-Sep-87 07:30 by cdl") (* DECLARATIONS%: (RECORD ERROR  (NIL TYPE)) (RECORD ALST  (KEY . VALUE))) (LET ((ALST (ASSOC (with ERROR ERROR TYPE) REMOTE.PROCESS.ERRORS))) (if ALST then (PROMPTPRINT (with ALST ALST VALUE)) else (PROMPTPRINT (with ERROR ERROR TYPE) (with ALST (ASSOC T REMOTE.PROCESS.ERRORS) VALUE]) (\REMOTE.GET.PROCESS.DATA [LAMBDA NIL (* ; "Edited 26-Aug-87 11:33 by cdl") (DECLARE (GLOBALVARS \PROCESSES)) `(RETURN (,(PROCESS.NAME (TTY.PROCESS)) ,(in \PROCESSES collect PROCESS.NAME]) (\REMOTE.PROCESS.BACKTRACE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE PROCESS COMMAND BULK.DATA.STREAM) (* ; "Edited 18-Jul-88 10:35 by cdl") (if (SETQ PROCESS (FIND.PROCESS PROCESS)) then (LET (STKP (PLVLFILEFLG T) (FX (fetch (PROCESS PROCFX) of PROCESS))) (BAKTRACE (if (ZEROP FX) then (* The currently active proc!) (FUNCTION \REMOTE.PROCESS.BACKTRACE) else (SETQ STKP (\MAKESTACKP NIL FX))) NIL NIL (CDR (OR (ASSOC COMMAND REMOTE.PROCESS.BACKTRACE.COMMANDS) (ASSOC 'BT REMOTE.PROCESS.BACKTRACE.COMMANDS))) BULK.DATA.STREAM) (if STKP then (RELSTK STKP))) '(RETURN) else '(ABORT NO.SUCH.PROCESS]) (\REMOTE.PROCESS.KILL [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE PROCESS) (* cdl " 3-Dec-85 18:59") (if (NOT (SETQ PROCESS (FIND.PROCESS PROCESS))) then '(ABORT NO.SUCH.PROCESS) elseif (EQ PROCESS (TTY.PROCESS)) then '(ABORT TTY.PROCESS) elseif (fetch PROCSYSTEMP of PROCESS) then '(ABORT SYSTEM.PROCESS) else (DEL.PROCESS PROCESS) '(RETURN]) (\REMOTE.PROCESS.RESTART [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE PROCESS) (* ; "Edited 18-Jul-88 10:18 by cdl") (if (SETQ PROCESS (FIND.PROCESS PROCESS)) then (RESTART.PROCESS PROCESS) '(RETURN) else '(ABORT NO.SUCH.PROCESS]) (\REMOTE.PROCESS.SUSPEND [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE PROCESS) (* ; "Edited 18-Jul-88 10:19 by cdl") (if (SETQ PROCESS (FIND.PROCESS PROCESS)) then (if (NEQ PROCESS (THIS.PROCESS)) then (SUSPEND.PROCESS PROCESS)) '(RETURN) else '(ABORT NO.SUCH.PROCESS]) (\REMOTE.PROCESS.TTY [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE PROCESS) (* ; "Edited 18-Jul-88 10:23 by cdl") (if PROCESS then (if (SETQ PROCESS (FIND.PROCESS PROCESS)) then (TTY.PROCESS PROCESS) '(RETURN) else '(ABORT NO.SUCH.PROCESS)) else `(RETURN ,(if (TTY.PROCESS) then (PROCESS.NAME (TTY.PROCESS]) (\REMOTE.PROCESS.WAKE [LAMBDA (COURIERSTREAM PROGRAM PROCEDURE PROCESS STATUS) (* ; "Edited 18-Jul-88 10:20 by cdl") (if (SETQ PROCESS (FIND.PROCESS PROCESS)) then (WAKE.PROCESS PROCESS STATUS) '(RETURN) else '(ABORT NO.SUCH.PROCESS]) (\REMOTE.PSW.SELECTED [LAMBDA (ITEM MENU BUTTON) (* cdl " 3-Dec-85 20:00") (with PROCESSDATA (WINDOWPROP (WFROMMENU MENU) 'PROCESSDATA) (if (AND SELECTED (NEQ ITEM SELECTED)) then (SHADEITEM SELECTED MENU WHITESHADE)) (SHADEITEM ITEM MENU SELECTIONSHADE) (SETQ SELECTED ITEM]) (\REMOTE.PSWOP.SELECTED [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 18-Jul-88 11:24 by cdl") (DECLARE (GLOBALVARS PROCOP.WAKEMENU WAITINGCURSOR) (SPECVARS ITEM)) (ALLOW.BUTTON.EVENTS) (LET (VALUE PROCESS ERROR NEWPROCESSDATA COURIERSTREAM (WINDOW (WFROMMENU MENU))) (DECLARE (SPECVARS WINDOW)) (WITH.MONITOR (WINDOWPROP WINDOW 'LOCK) (SETQ COURIERSTREAM (WINDOWPROP WINDOW 'COURIERSTREAM)) [with PROCESSDATA (WINDOWPROP WINDOW 'PROCESSDATA) (if [NOT (EQUAL PROCESSES (fetch (PROCESSDATA PROCESSES) of (SETQ NEWPROCESSDATA (COURIER.CALL COURIERSTREAM 'PROCESS 'GET.PROCESS.DATA] then (if (MEMB SELECTED (fetch (PROCESSDATA PROCESSES) of NEWPROCESSDATA )) then (replace (PROCESSDATA SELECTED) of NEWPROCESSDATA with SELECTED)) (REMOTE.PSW.REDISPLAY WINDOW NEWPROCESSDATA)) (SELECTQ ITEM (WHO? (if (SETQ PROCESS (COURIER.CALL COURIERSTREAM 'PROCESS 'GET.TTY.PROCESS)) then (with REMOTE.PSW.MENUS (WINDOWPROP WINDOW 'MENU) (\REMOTE.PSW.SELECTED PROCESS PROCESSMENU)) else (PROMPTPRINT "No process has the tty!!!"))) (UPDATE NIL) (if SELECTED then (SELECTQ ITEM (KBD_ (if (SETQ ERROR (COURIER.CALL COURIERSTREAM 'PROCESS 'SET.TTY.PROCESS SELECTED 'RETURNERRORS)) then (REMOTE.PROCESS.ERROR ERROR))) (INFO (PROMPTPRINT "Not yet implemented")) (KILL (if (SETQ ERROR (COURIER.CALL COURIERSTREAM 'PROCESS 'KILL SELECTED 'RETURNERRORS)) then (REMOTE.PROCESS.ERROR ERROR) else (REMOTE.PSW.REDISPLAY WINDOW))) (RESTART (if (SETQ ERROR (COURIER.CALL COURIERSTREAM 'PROCESS 'RESTART SELECTED 'RETURNERRORS)) then (REMOTE.PROCESS.ERROR ERROR))) (WAKE (PROG NIL (if (SETQ ERROR (COURIER.CALL COURIERSTREAM 'PROCESS 'WAKE SELECTED (SELECTQ [MENU (OR PROCOP.WAKEMENU (SETQ PROCOP.WAKEMENU (create MENU ITEMS _ '((NIL 'NULL) T Other) TITLE _ "WakeUp Value" CENTERFLG _ T] (NIL (RETURN)) (NULL NIL) (T T) (Other (CAR (OR (LISTP (PROCESS.READ "Value to return to woken process: " )) (RETURN)))) NIL) 'RETURNERRORS)) then (REMOTE.PROCESS.ERROR ERROR)))) (SUSPEND (if (SETQ ERROR (COURIER.CALL COURIERSTREAM 'PROCESS 'SUSPEND SELECTED 'RETURNERRORS)) then (REMOTE.PROCESS.ERROR ERROR))) (if (ASSOC ITEM REMOTE.PROCESS.BACKTRACE.COMMANDS) then (RESETFORM (CURSOR WAITINGCURSOR) (REMOTE.PROCESS.BACKTRACE SELECTED ITEM WINDOW])]) ) (RPAQQ REMOTE.PSW.ITEMS (BT WHO? KILL BTV KBD_ RESTART BTV* INFO WAKE BTV! UPDATE SUSPEND)) (RPAQQ REMOTE.PROCESS.ERRORS ((NO.SUCH.PROCESS . "Process not found!") (TTY.PROCESS . "Can't, TTY process!") (SYSTEM.PROCESS . "Can't, SYSTEM process!") (T . " remote process error!"))) (RPAQQ REMOTE.PROCESS.BACKTRACE.COMMANDS ((BT . 0) (BTV . 1) (BTV* . 7) (BTV! . 39))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS REMOTE.PSW.ITEMS REMOTE.PROCESS.ERRORS REMOTE.PROCESS.BACKTRACE.COMMANDS) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD PROCESSDATA (SELECTED PROCESSES)) (RECORD REMOTE.PSW.MENUS (COMMANDMENU PROCESSMENU)) ) (DECLARE%: EVAL@COMPILE (RPAQQ SELECTIONSHADE 520) (CONSTANTS (SELECTIONSHADE 520)) ) ) (FILESLOAD COURIERSERVE COURIERDEFS) (COURIERPROGRAM PROCESS (1199 0) TYPES [[PROCESSDATA (RECORD (SELECTED PROCESS) (PROCESSES (SEQUENCE PROCESS] (PROCESS ATOM) (STATUS ATOM) (COMMAND (ENUMERATION (BT 0) (BTV 1) (BTV* 7) (BTV! 39] INHERITS (INTERLISP) PROCEDURES ((GET.PROCESS.DATA 0 NIL RETURNS (PROCESSDATA) REPORTS NIL IMPLEMENTEDBY \REMOTE.GET.PROCESS.DATA) (BACKTRACE 1 (PROCESS COMMAND BULK.DATA.SINK) RETURNS NIL REPORTS NIL IMPLEMENTEDBY \REMOTE.PROCESS.BACKTRACE) (KILL 2 (PROCESS) RETURNS NIL REPORTS (NO.SUCH.PROCESS TTY.PROCESS SYSTEM.PROCESS) IMPLEMENTEDBY \REMOTE.PROCESS.KILL) (RESTART 3 (PROCESS) RETURNS NIL REPORTS (NO.SUCH.PROCESS) IMPLEMENTEDBY \REMOTE.PROCESS.RESTART) (WAKE 4 (PROCESS STATUS) RETURNS NIL REPORTS (NO.SUCH.PROCESS) IMPLEMENTEDBY \REMOTE.PROCESS.WAKE) (SUSPEND 5 (PROCESS) RETURNS NIL REPORTS (NO.SUCH.PROCESS) IMPLEMENTEDBY \REMOTE.PROCESS.SUSPEND) (GET.TTY.PROCESS 6 NIL RETURNS (PROCESS) REPORTS NIL IMPLEMENTEDBY \REMOTE.PROCESS.TTY) (SET.TTY.PROCESS 7 (PROCESS) RETURNS NIL REPORTS (NO.SUCH.PROCESS) IMPLEMENTEDBY \REMOTE.PROCESS.TTY)) ERRORS ((NO.SUCH.PROCESS 0) (TTY.PROCESS 1) (SYSTEM.PROCESS 3))) (COURIER.START.SERVER) (PUTPROPS REMOTEPSW COPYRIGHT ("Xerox Corporation & Stanford University" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1860 2513 (REMOTE.PROCESS.STATUS.WINDOW 1870 . 2511)) (2514 18392 ( REMOTE.PROCESS.BACKTRACE 2524 . 5193) (REMOTE.PSW.REDISPLAY 5195 . 9103) (REMOTE.PROCESS.ERROR 9105 . 9857) (\REMOTE.GET.PROCESS.DATA 9859 . 10129) (\REMOTE.PROCESS.BACKTRACE 10131 . 11208) ( \REMOTE.PROCESS.KILL 11210 . 11666) (\REMOTE.PROCESS.RESTART 11668 . 11957) (\REMOTE.PROCESS.SUSPEND 11959 . 12316) (\REMOTE.PROCESS.TTY 12318 . 12785) (\REMOTE.PROCESS.WAKE 12787 . 13140) ( \REMOTE.PSW.SELECTED 13142 . 13553) (\REMOTE.PSWOP.SELECTED 13555 . 18390))))) STOP \ No newline at end of file diff --git a/lispusers/REMOTEPSW.TEDIT b/lispusers/REMOTEPSW.TEDIT new file mode 100644 index 00000000..0a938675 Binary files /dev/null and b/lispusers/REMOTEPSW.TEDIT differ diff --git a/lispusers/RPC b/lispusers/RPC new file mode 100644 index 00000000..a97e3e50 --- /dev/null +++ b/lispusers/RPC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "RPC2" (USE "LISP" "XCL"))) (il:filecreated " 8-Aug-88 11:40:06" il:{erinyes}medley>rpc.\;2 2644 il:|changes| il:|to:| (il:vars il:rpccoms) il:|previous| il:|date:| "28-Apr-88 17:22:12" il:{erinyes}medley>rpc.\;1) ; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. (il:prettycomprint il:rpccoms) (il:rpaqq il:rpccoms ((il:* il:|;;;;| "SUN REMOTE PROCEDURE CALLS") (il:* il:|;;;;| "Originally written by Jeff Finger at the SUMEX-AIM Computing Resource at Stanford University under support from National Institutes of Health Grant NIH 5P41 RR00785.") (il:* il:|;;;;| "Modified to work under Maiko by Atty Mullins & Doug Cutting.") (il:props (il:rpc il:makefile-environment il:filetype)) (il:variables *use-os-networking*) (eval-when (load) (il:p (il:* il:\; "Load the appropriate transport.") (cond (*use-os-networking* (il:filesload (il:sysload) il:rpcos)) (t (il:* il:\; "Load only UDP. If you want to use RPC over TCP, you must load TCP yourself") (il:filesload (il:sysload il:from il:lispusers) il:tcpllip il:tcpudp il:rpclowlevel) (when (eq il:makesysname :lyric) (il:filesload (il:sysload) il:ippatches))))) (il:files (il:sysload) il:rpcstruct il:rpccommon il:rpcxdr il:rpcrpc il:rpcportmapper)))) (il:* il:|;;;;| "SUN REMOTE PROCEDURE CALLS") (il:* il:|;;;;| "Originally written by Jeff Finger at the SUMEX-AIM Computing Resource at Stanford University under support from National Institutes of Health Grant NIH 5P41 RR00785." ) (il:* il:|;;;;| "Modified to work under Maiko by Atty Mullins & Doug Cutting.") (il:putprops il:rpc il:makefile-environment (:readtable "XCL" :package (defpackage "RPC2" (:use "LISP" "XCL")))) (il:putprops il:rpc il:filetype :compile-file) (defglobalparameter *use-os-networking* (eq (il:machinetype) (quote il:maiko)) "If false, RPC will use Interlisp-D TCP/IP, if true RPC will use the host operating system's IPC mechanism.") (eval-when (load) (il:* il:\; "Load the appropriate transport.") (cond (*use-os-networking* (il:filesload (il:sysload) il:rpcos)) (t (il:* il:\; "Load only UDP. If you want to use RPC over TCP, you must load TCP yourself") (il:filesload (il:sysload il:from il:lispusers) il:tcpllip il:tcpudp il:rpclowlevel) (when (eq il:makesysname :lyric) (il:filesload (il:sysload) il:ippatches)))) (il:filesload (il:sysload) il:rpcstruct il:rpccommon il:rpcxdr il:rpcrpc il:rpcportmapper) ) (il:putprops il:rpc il:copyright ("Stanford University and Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/RPC.TEDIT b/lispusers/RPC.TEDIT new file mode 100644 index 00000000..c457cc92 Binary files /dev/null and b/lispusers/RPC.TEDIT differ diff --git a/lispusers/RPCCOMMON b/lispusers/RPCCOMMON new file mode 100644 index 00000000..a0e32369 Binary files /dev/null and b/lispusers/RPCCOMMON differ diff --git a/lispusers/RPCLOWLEVEL b/lispusers/RPCLOWLEVEL new file mode 100644 index 00000000..b777927f --- /dev/null +++ b/lispusers/RPCLOWLEVEL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-88 11:21:37" {ERINYES}MEDLEY>RPCLOWLEVEL.;3 3722 changes to%: (VARS RPCLOWLEVELCOMS) (FNS STRING.ZEROBYTES) previous date%: " 8-Aug-88 11:13:29" {ERINYES}MEDLEY>RPCLOWLEVEL.;2) (* " Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT RPCLOWLEVELCOMS) (RPAQQ RPCLOWLEVELCOMS ((PROPS (RPCLOWLEVEL MAKEFILE-ENVIRONMENT FILETYPE)) (FNS TCP.STREAM.SOCKET TCP.SOCKET.EVENT STRING.ZEROBYTES STRING.BOUTS STRING.BINS \IP.APPEND.BYTES UDP.APPEND.BYTES UDP.GET.BYTES UDP.MYGET.STRING \UDP.SET.CHECKSUM.ZERO) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TCPEXPORTS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CHANGENAME (QUOTE UDP.SEND) (QUOTE \UDP.SET.CHECKSUM) (QUOTE \UDP.SET.CHECKSUM.ZERO)))))) (PUTPROPS RPCLOWLEVEL MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS RPCLOWLEVEL FILETYPE :COMPILE-FILE) (DEFINEQ (TCP.STREAM.SOCKET (LAMBDA (STREAM) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Return IPSOCKET of a TCP Stream") (fetch TCB.IPSOCKET of (fetch F1 of STREAM))) ) (TCP.SOCKET.EVENT (LAMBDA (IPSOCKET) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "For some reason Eric did not include this function, but it is identical to UDP.SOCKET.NUMBER, anyway.") (fetch (IPSOCKET IPSEVENT) of IPSOCKET)) ) (STRING.ZEROBYTES (LAMBDA (STRING FIRST NBYTES) (* ; "Edited 5-Aug-88 18:20 by bvm") (* ;;; "Zero bytes of a string") (\CLEARBYTES (fetch (STRINGP BASE) of STRING) FIRST NBYTES)) ) (STRING.BOUTS (LAMBDA (STREAM STRING FIRST NBYTES) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Write substring to stream") (\BOUTS STREAM (fetch (STRINGP BASE) of STRING) FIRST NBYTES)) ) (STRING.BINS (LAMBDA (STREAM STRING FIRST NBYTES) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Read substring from stream") (\BINS STREAM (fetch (STRINGP BASE) of STRING) FIRST NBYTES)) ) (\IP.APPEND.BYTES (LAMBDA (IP ADDR OFFSET LENGTH) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Append bytes (not necessarily a string) to IPPACKET. ") (\MOVEBYTES ADDR OFFSET (fetch (IP IPBASE) of IP) (fetch (IP IPTOTALLENGTH) of IP) LENGTH) (add (ffetch (IP IPTOTALLENGTH) of IP) LENGTH)) ) (UDP.APPEND.BYTES (LAMBDA (UDP ADDR OFFSET NBYTES) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Append bytes (not necessarily a string) to UDP Packet") (\IP.APPEND.BYTES UDP ADDR OFFSET NBYTES) (add (fetch (UDP UDPLENGTH) of UDP) NBYTES)) ) (UDP.GET.BYTES (LAMBDA (UDP SOFFSET DEST DOFFSET NBYTES) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Move bytes out of UDP Packet to another buffer without string creation") (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) SOFFSET DEST DOFFSET NBYTES) DEST) ) (UDP.MYGET.STRING (LAMBDA (UDP OFFSET LENGTH) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Fetch string from packet. String does not go to end of packet as in UDP.GET.STRING.") (OR (SMALLP OFFSET) (SETQ OFFSET 0)) (LET* ((STRING (ALLOCSTRING LENGTH))) (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) OFFSET (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) LENGTH) STRING)) ) (\UDP.SET.CHECKSUM.ZERO (LAMBDA (UDP) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Avoid doing a UDP checksum. Packet already gets IP Checksum.") (replace (UDP UDPCHECKSUM) of UDP with 0)) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TCPEXPORTS) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (CHANGENAME (QUOTE UDP.SEND) (QUOTE \UDP.SET.CHECKSUM) (QUOTE \UDP.SET.CHECKSUM.ZERO)) ) (PUTPROPS RPCLOWLEVEL COPYRIGHT ("Stanford University and Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1018 3418 (TCP.STREAM.SOCKET 1028 . 1196) (TCP.SOCKET.EVENT 1198 . 1432) ( STRING.ZEROBYTES 1434 . 1619) (STRING.BOUTS 1621 . 1815) (STRING.BINS 1817 . 2010) (\IP.APPEND.BYTES 2012 . 2309) (UDP.APPEND.BYTES 2311 . 2557) (UDP.GET.BYTES 2559 . 2821) (UDP.MYGET.STRING 2823 . 3218) (\UDP.SET.CHECKSUM.ZERO 3220 . 3416))))) STOP \ No newline at end of file diff --git a/lispusers/RPCOS b/lispusers/RPCOS new file mode 100644 index 00000000..8ca5c9c4 --- /dev/null +++ b/lispusers/RPCOS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated "23-May-88 18:55:42" il:{eris}rpc>current>rpcos.\;11 30632 il:|changes| il:|to:| (il:vars il:rpcoscoms) il:|previous| il:|date:| "20-May-88 12:56:30" il:{eris}rpc>current>rpcos.\;9) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:rpcoscoms) (il:rpaqq il:rpcoscoms ((il:* il:|;;| "OS networking code") (il:props (il:rpcos il:makefile-environment il:filetype)) (eval-when (compile) (il:files (il:loadcomp) il:llsubrs)) (il:functions os-exchange-udp-packets os-resolve-host read-string-address) (il:* il:|;;| "XDR data block") (il:records xdr-data-block) (il:variables *cells-per-xdr-data-block* *free-xdr-data-blocks* *max-xdr-data-blocks* *words-per-cell*) (il:functions xdr-initialize-cache allocate-xdr-data-block reclaim-xdr-data-block) (il:functions foldlo unfold) (il:functions os-udp-getbyte os-udp-getbytes os-udp-putbyte os-udp-putbytes os-udp-getcell os-udp-putcell os-udp-getoffset os-udp-putoffset) (eval-when (load) (il:p (xdr-initialize-cache))))) (il:* il:|;;| "OS networking code") (il:putprops il:rpcos il:makefile-environment (:readtable "XCL" :package "RPC2")) (il:putprops il:rpcos il:filetype :compile-file) (eval-when (compile) (il:filesload (il:loadcomp) il:llsubrs) ) (defun os-exchange-udp-packets (rpcstream msec-until-timeout msec-between-tries errorflg) (let ((xdr-arg-block (rpc-stream-outstream rpcstream)) (xdr-arg-block-length (rpc-stream-outbyteptr rpcstream)) (xdr-result-block (rpc-stream-instream rpcstream))) (setq xdr-arg-block (il:\\dtest xdr-arg-block (quote xdr-data-block))) (setq xdr-result-block (il:\\dtest xdr-result-block (quote xdr-data-block))) (il:* il:|;;| "Need to add a dispatch on the type of the error.") (unless (il:subrcall il:rpc-call (rpc-stream-os-destaddr rpcstream) (rpc-stream-ipsocket rpcstream) xdr-arg-block xdr-result-block msec-until-timeout msec-between-tries xdr-arg-block-length) (case errorflg (:noerrors (throw (quote goforit) nil)) (:returnerrors (throw (quote goforit) (quote (error timeout)))) (otherwise (error "RPC Call failed")))) (il:* il:|;;| "Put the result block in the instream.") (setf (rpc-stream-instream rpcstream) xdr-result-block) (progn (when *debug* (format-t "It returned!~%") (and (numberp *debug*) (> *debug* 5) (break "Reply Packet in INSTREAM of RPC-STREAM *RPCSTREAM*"))) t))) (defun os-resolve-host (destination) (il:* il:|;;;| " Convert an address from it's string representation into a number.") (let ((addr (read-string-address (if (symbolp destination) destination (intern destination "IL"))))) (if addr addr destination))) (defun read-string-address (string-or-atom) (il:|for| il:char il:|instring| (il:mkstring string-or-atom) il:|bind| (il:result il:_ (il:ncreate (quote il:fixp))) (il:index il:_ 0) byte il:|do| (il:|if| (> il:index 3) il:|then| (il:* il:\; "Got 3 parts and there's still more to go, must be bad") (return nil) il:|elseif| (eq il:char (il:charcode il:\.)) il:|then| (il:|if| byte il:|then| (il:\\putbasebyte il:result il:index byte)) (il:setq byte nil) (il:|add| il:index 1) il:|elseif| (and (il:setq il:char (digit-char-p (int-char il:char))) (< (il:setq byte (+ (il:|if| byte il:|then| (il:times byte 10) il:|else| 0) il:char)) 256)) il:|then| (il:* il:\; "Accumulated decimal digit, and we haven't overflowed a byte yet") il:|else| (il:* il:\; "Malformed") (return nil)) il:|finally| (il:|if| byte il:|then| (il:\\putbasebyte il:result il:index byte) (il:|add| il:index 1)) (return (and (eq il:index 4) il:result)))) (il:* il:|;;| "XDR data block") (il:declare\: il:eval@compile (il:datatype xdr-data-block ((xdr-public 500 il:word))) ) (il:/declaredatatype (quote xdr-data-block) (quote (il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word il:word)) (quote ((xdr-data-block 0 (il:bits . 15)) (xdr-data-block 1 (il:bits . 15)) (xdr-data-block 2 (il:bits . 15)) (xdr-data-block 3 (il:bits . 15)) (xdr-data-block 4 (il:bits . 15)) (xdr-data-block 5 (il:bits . 15)) (xdr-data-block 6 (il:bits . 15)) (xdr-data-block 7 (il:bits . 15)) (xdr-data-block 8 (il:bits . 15)) (xdr-data-block 9 (il:bits . 15)) (xdr-data-block 10 (il:bits . 15)) (xdr-data-block 11 (il:bits . 15)) (xdr-data-block 12 (il:bits . 15)) (xdr-data-block 13 (il:bits . 15)) (xdr-data-block 14 (il:bits . 15)) (xdr-data-block 15 (il:bits . 15)) (xdr-data-block 16 (il:bits . 15)) (xdr-data-block 17 (il:bits . 15)) (xdr-data-block 18 (il:bits . 15)) (xdr-data-block 19 (il:bits . 15)) (xdr-data-block 20 (il:bits . 15)) (xdr-data-block 21 (il:bits . 15)) (xdr-data-block 22 (il:bits . 15)) (xdr-data-block 23 (il:bits . 15)) (xdr-data-block 24 (il:bits . 15)) (xdr-data-block 25 (il:bits . 15)) (xdr-data-block 26 (il:bits . 15)) (xdr-data-block 27 (il:bits . 15)) (xdr-data-block 28 (il:bits . 15)) (xdr-data-block 29 (il:bits . 15)) (xdr-data-block 30 (il:bits . 15)) (xdr-data-block 31 (il:bits . 15)) (xdr-data-block 32 (il:bits . 15)) (xdr-data-block 33 (il:bits . 15)) (xdr-data-block 34 (il:bits . 15)) (xdr-data-block 35 (il:bits . 15)) (xdr-data-block 36 (il:bits . 15)) (xdr-data-block 37 (il:bits . 15)) (xdr-data-block 38 (il:bits . 15)) (xdr-data-block 39 (il:bits . 15)) (xdr-data-block 40 (il:bits . 15)) (xdr-data-block 41 (il:bits . 15)) (xdr-data-block 42 (il:bits . 15)) (xdr-data-block 43 (il:bits . 15)) (xdr-data-block 44 (il:bits . 15)) (xdr-data-block 45 (il:bits . 15)) (xdr-data-block 46 (il:bits . 15)) (xdr-data-block 47 (il:bits . 15)) (xdr-data-block 48 (il:bits . 15)) (xdr-data-block 49 (il:bits . 15)) (xdr-data-block 50 (il:bits . 15)) (xdr-data-block 51 (il:bits . 15)) (xdr-data-block 52 (il:bits . 15)) (xdr-data-block 53 (il:bits . 15)) (xdr-data-block 54 (il:bits . 15)) (xdr-data-block 55 (il:bits . 15)) (xdr-data-block 56 (il:bits . 15)) (xdr-data-block 57 (il:bits . 15)) (xdr-data-block 58 (il:bits . 15)) (xdr-data-block 59 (il:bits . 15)) (xdr-data-block 60 (il:bits . 15)) (xdr-data-block 61 (il:bits . 15)) (xdr-data-block 62 (il:bits . 15)) (xdr-data-block 63 (il:bits . 15)) (xdr-data-block 64 (il:bits . 15)) (xdr-data-block 65 (il:bits . 15)) (xdr-data-block 66 (il:bits . 15)) (xdr-data-block 67 (il:bits . 15)) (xdr-data-block 68 (il:bits . 15)) (xdr-data-block 69 (il:bits . 15)) (xdr-data-block 70 (il:bits . 15)) (xdr-data-block 71 (il:bits . 15)) (xdr-data-block 72 (il:bits . 15)) (xdr-data-block 73 (il:bits . 15)) (xdr-data-block 74 (il:bits . 15)) (xdr-data-block 75 (il:bits . 15)) (xdr-data-block 76 (il:bits . 15)) (xdr-data-block 77 (il:bits . 15)) (xdr-data-block 78 (il:bits . 15)) (xdr-data-block 79 (il:bits . 15)) (xdr-data-block 80 (il:bits . 15)) (xdr-data-block 81 (il:bits . 15)) (xdr-data-block 82 (il:bits . 15)) (xdr-data-block 83 (il:bits . 15)) (xdr-data-block 84 (il:bits . 15)) (xdr-data-block 85 (il:bits . 15)) (xdr-data-block 86 (il:bits . 15)) (xdr-data-block 87 (il:bits . 15)) (xdr-data-block 88 (il:bits . 15)) (xdr-data-block 89 (il:bits . 15)) (xdr-data-block 90 (il:bits . 15)) (xdr-data-block 91 (il:bits . 15)) (xdr-data-block 92 (il:bits . 15)) (xdr-data-block 93 (il:bits . 15)) (xdr-data-block 94 (il:bits . 15)) (xdr-data-block 95 (il:bits . 15)) (xdr-data-block 96 (il:bits . 15)) (xdr-data-block 97 (il:bits . 15)) (xdr-data-block 98 (il:bits . 15)) (xdr-data-block 99 (il:bits . 15)) (xdr-data-block 100 (il:bits . 15)) (xdr-data-block 101 (il:bits . 15)) (xdr-data-block 102 (il:bits . 15)) (xdr-data-block 103 (il:bits . 15)) (xdr-data-block 104 (il:bits . 15)) (xdr-data-block 105 (il:bits . 15)) (xdr-data-block 106 (il:bits . 15)) (xdr-data-block 107 (il:bits . 15)) (xdr-data-block 108 (il:bits . 15)) (xdr-data-block 109 (il:bits . 15)) (xdr-data-block 110 (il:bits . 15)) (xdr-data-block 111 (il:bits . 15)) (xdr-data-block 112 (il:bits . 15)) (xdr-data-block 113 (il:bits . 15)) (xdr-data-block 114 (il:bits . 15)) (xdr-data-block 115 (il:bits . 15)) (xdr-data-block 116 (il:bits . 15)) (xdr-data-block 117 (il:bits . 15)) (xdr-data-block 118 (il:bits . 15)) (xdr-data-block 119 (il:bits . 15)) (xdr-data-block 120 (il:bits . 15)) (xdr-data-block 121 (il:bits . 15)) (xdr-data-block 122 (il:bits . 15)) (xdr-data-block 123 (il:bits . 15)) (xdr-data-block 124 (il:bits . 15)) (xdr-data-block 125 (il:bits . 15)) (xdr-data-block 126 (il:bits . 15)) (xdr-data-block 127 (il:bits . 15)) (xdr-data-block 128 (il:bits . 15)) (xdr-data-block 129 (il:bits . 15)) (xdr-data-block 130 (il:bits . 15)) (xdr-data-block 131 (il:bits . 15)) (xdr-data-block 132 (il:bits . 15)) (xdr-data-block 133 (il:bits . 15)) (xdr-data-block 134 (il:bits . 15)) (xdr-data-block 135 (il:bits . 15)) (xdr-data-block 136 (il:bits . 15)) (xdr-data-block 137 (il:bits . 15)) (xdr-data-block 138 (il:bits . 15)) (xdr-data-block 139 (il:bits . 15)) (xdr-data-block 140 (il:bits . 15)) (xdr-data-block 141 (il:bits . 15)) (xdr-data-block 142 (il:bits . 15)) (xdr-data-block 143 (il:bits . 15)) (xdr-data-block 144 (il:bits . 15)) (xdr-data-block 145 (il:bits . 15)) (xdr-data-block 146 (il:bits . 15)) (xdr-data-block 147 (il:bits . 15)) (xdr-data-block 148 (il:bits . 15)) (xdr-data-block 149 (il:bits . 15)) (xdr-data-block 150 (il:bits . 15)) (xdr-data-block 151 (il:bits . 15)) (xdr-data-block 152 (il:bits . 15)) (xdr-data-block 153 (il:bits . 15)) (xdr-data-block 154 (il:bits . 15)) (xdr-data-block 155 (il:bits . 15)) (xdr-data-block 156 (il:bits . 15)) (xdr-data-block 157 (il:bits . 15)) (xdr-data-block 158 (il:bits . 15)) (xdr-data-block 159 (il:bits . 15)) (xdr-data-block 160 (il:bits . 15)) (xdr-data-block 161 (il:bits . 15)) (xdr-data-block 162 (il:bits . 15)) (xdr-data-block 163 (il:bits . 15)) (xdr-data-block 164 (il:bits . 15)) (xdr-data-block 165 (il:bits . 15)) (xdr-data-block 166 (il:bits . 15)) (xdr-data-block 167 (il:bits . 15)) (xdr-data-block 168 (il:bits . 15)) (xdr-data-block 169 (il:bits . 15)) (xdr-data-block 170 (il:bits . 15)) (xdr-data-block 171 (il:bits . 15)) (xdr-data-block 172 (il:bits . 15)) (xdr-data-block 173 (il:bits . 15)) (xdr-data-block 174 (il:bits . 15)) (xdr-data-block 175 (il:bits . 15)) (xdr-data-block 176 (il:bits . 15)) (xdr-data-block 177 (il:bits . 15)) (xdr-data-block 178 (il:bits . 15)) (xdr-data-block 179 (il:bits . 15)) (xdr-data-block 180 (il:bits . 15)) (xdr-data-block 181 (il:bits . 15)) (xdr-data-block 182 (il:bits . 15)) (xdr-data-block 183 (il:bits . 15)) (xdr-data-block 184 (il:bits . 15)) (xdr-data-block 185 (il:bits . 15)) (xdr-data-block 186 (il:bits . 15)) (xdr-data-block 187 (il:bits . 15)) (xdr-data-block 188 (il:bits . 15)) (xdr-data-block 189 (il:bits . 15)) (xdr-data-block 190 (il:bits . 15)) (xdr-data-block 191 (il:bits . 15)) (xdr-data-block 192 (il:bits . 15)) (xdr-data-block 193 (il:bits . 15)) (xdr-data-block 194 (il:bits . 15)) (xdr-data-block 195 (il:bits . 15)) (xdr-data-block 196 (il:bits . 15)) (xdr-data-block 197 (il:bits . 15)) (xdr-data-block 198 (il:bits . 15)) (xdr-data-block 199 (il:bits . 15)) (xdr-data-block 200 (il:bits . 15)) (xdr-data-block 201 (il:bits . 15)) (xdr-data-block 202 (il:bits . 15)) (xdr-data-block 203 (il:bits . 15)) (xdr-data-block 204 (il:bits . 15)) (xdr-data-block 205 (il:bits . 15)) (xdr-data-block 206 (il:bits . 15)) (xdr-data-block 207 (il:bits . 15)) (xdr-data-block 208 (il:bits . 15)) (xdr-data-block 209 (il:bits . 15)) (xdr-data-block 210 (il:bits . 15)) (xdr-data-block 211 (il:bits . 15)) (xdr-data-block 212 (il:bits . 15)) (xdr-data-block 213 (il:bits . 15)) (xdr-data-block 214 (il:bits . 15)) (xdr-data-block 215 (il:bits . 15)) (xdr-data-block 216 (il:bits . 15)) (xdr-data-block 217 (il:bits . 15)) (xdr-data-block 218 (il:bits . 15)) (xdr-data-block 219 (il:bits . 15)) (xdr-data-block 220 (il:bits . 15)) (xdr-data-block 221 (il:bits . 15)) (xdr-data-block 222 (il:bits . 15)) (xdr-data-block 223 (il:bits . 15)) (xdr-data-block 224 (il:bits . 15)) (xdr-data-block 225 (il:bits . 15)) (xdr-data-block 226 (il:bits . 15)) (xdr-data-block 227 (il:bits . 15)) (xdr-data-block 228 (il:bits . 15)) (xdr-data-block 229 (il:bits . 15)) (xdr-data-block 230 (il:bits . 15)) (xdr-data-block 231 (il:bits . 15)) (xdr-data-block 232 (il:bits . 15)) (xdr-data-block 233 (il:bits . 15)) (xdr-data-block 234 (il:bits . 15)) (xdr-data-block 235 (il:bits . 15)) (xdr-data-block 236 (il:bits . 15)) (xdr-data-block 237 (il:bits . 15)) (xdr-data-block 238 (il:bits . 15)) (xdr-data-block 239 (il:bits . 15)) (xdr-data-block 240 (il:bits . 15)) (xdr-data-block 241 (il:bits . 15)) (xdr-data-block 242 (il:bits . 15)) (xdr-data-block 243 (il:bits . 15)) (xdr-data-block 244 (il:bits . 15)) (xdr-data-block 245 (il:bits . 15)) (xdr-data-block 246 (il:bits . 15)) (xdr-data-block 247 (il:bits . 15)) (xdr-data-block 248 (il:bits . 15)) (xdr-data-block 249 (il:bits . 15)) (xdr-data-block 250 (il:bits . 15)) (xdr-data-block 251 (il:bits . 15)) (xdr-data-block 252 (il:bits . 15)) (xdr-data-block 253 (il:bits . 15)) (xdr-data-block 254 (il:bits . 15)) (xdr-data-block 255 (il:bits . 15)) (xdr-data-block 256 (il:bits . 15)) (xdr-data-block 257 (il:bits . 15)) (xdr-data-block 258 (il:bits . 15)) (xdr-data-block 259 (il:bits . 15)) (xdr-data-block 260 (il:bits . 15)) (xdr-data-block 261 (il:bits . 15)) (xdr-data-block 262 (il:bits . 15)) (xdr-data-block 263 (il:bits . 15)) (xdr-data-block 264 (il:bits . 15)) (xdr-data-block 265 (il:bits . 15)) (xdr-data-block 266 (il:bits . 15)) (xdr-data-block 267 (il:bits . 15)) (xdr-data-block 268 (il:bits . 15)) (xdr-data-block 269 (il:bits . 15)) (xdr-data-block 270 (il:bits . 15)) (xdr-data-block 271 (il:bits . 15)) (xdr-data-block 272 (il:bits . 15)) (xdr-data-block 273 (il:bits . 15)) (xdr-data-block 274 (il:bits . 15)) (xdr-data-block 275 (il:bits . 15)) (xdr-data-block 276 (il:bits . 15)) (xdr-data-block 277 (il:bits . 15)) (xdr-data-block 278 (il:bits . 15)) (xdr-data-block 279 (il:bits . 15)) (xdr-data-block 280 (il:bits . 15)) (xdr-data-block 281 (il:bits . 15)) (xdr-data-block 282 (il:bits . 15)) (xdr-data-block 283 (il:bits . 15)) (xdr-data-block 284 (il:bits . 15)) (xdr-data-block 285 (il:bits . 15)) (xdr-data-block 286 (il:bits . 15)) (xdr-data-block 287 (il:bits . 15)) (xdr-data-block 288 (il:bits . 15)) (xdr-data-block 289 (il:bits . 15)) (xdr-data-block 290 (il:bits . 15)) (xdr-data-block 291 (il:bits . 15)) (xdr-data-block 292 (il:bits . 15)) (xdr-data-block 293 (il:bits . 15)) (xdr-data-block 294 (il:bits . 15)) (xdr-data-block 295 (il:bits . 15)) (xdr-data-block 296 (il:bits . 15)) (xdr-data-block 297 (il:bits . 15)) (xdr-data-block 298 (il:bits . 15)) (xdr-data-block 299 (il:bits . 15)) (xdr-data-block 300 (il:bits . 15)) (xdr-data-block 301 (il:bits . 15)) (xdr-data-block 302 (il:bits . 15)) (xdr-data-block 303 (il:bits . 15)) (xdr-data-block 304 (il:bits . 15)) (xdr-data-block 305 (il:bits . 15)) (xdr-data-block 306 (il:bits . 15)) (xdr-data-block 307 (il:bits . 15)) (xdr-data-block 308 (il:bits . 15)) (xdr-data-block 309 (il:bits . 15)) (xdr-data-block 310 (il:bits . 15)) (xdr-data-block 311 (il:bits . 15)) (xdr-data-block 312 (il:bits . 15)) (xdr-data-block 313 (il:bits . 15)) (xdr-data-block 314 (il:bits . 15)) (xdr-data-block 315 (il:bits . 15)) (xdr-data-block 316 (il:bits . 15)) (xdr-data-block 317 (il:bits . 15)) (xdr-data-block 318 (il:bits . 15)) (xdr-data-block 319 (il:bits . 15)) (xdr-data-block 320 (il:bits . 15)) (xdr-data-block 321 (il:bits . 15)) (xdr-data-block 322 (il:bits . 15)) (xdr-data-block 323 (il:bits . 15)) (xdr-data-block 324 (il:bits . 15)) (xdr-data-block 325 (il:bits . 15)) (xdr-data-block 326 (il:bits . 15)) (xdr-data-block 327 (il:bits . 15)) (xdr-data-block 328 (il:bits . 15)) (xdr-data-block 329 (il:bits . 15)) (xdr-data-block 330 (il:bits . 15)) (xdr-data-block 331 (il:bits . 15)) (xdr-data-block 332 (il:bits . 15)) (xdr-data-block 333 (il:bits . 15)) (xdr-data-block 334 (il:bits . 15)) (xdr-data-block 335 (il:bits . 15)) (xdr-data-block 336 (il:bits . 15)) (xdr-data-block 337 (il:bits . 15)) (xdr-data-block 338 (il:bits . 15)) (xdr-data-block 339 (il:bits . 15)) (xdr-data-block 340 (il:bits . 15)) (xdr-data-block 341 (il:bits . 15)) (xdr-data-block 342 (il:bits . 15)) (xdr-data-block 343 (il:bits . 15)) (xdr-data-block 344 (il:bits . 15)) (xdr-data-block 345 (il:bits . 15)) (xdr-data-block 346 (il:bits . 15)) (xdr-data-block 347 (il:bits . 15)) (xdr-data-block 348 (il:bits . 15)) (xdr-data-block 349 (il:bits . 15)) (xdr-data-block 350 (il:bits . 15)) (xdr-data-block 351 (il:bits . 15)) (xdr-data-block 352 (il:bits . 15)) (xdr-data-block 353 (il:bits . 15)) (xdr-data-block 354 (il:bits . 15)) (xdr-data-block 355 (il:bits . 15)) (xdr-data-block 356 (il:bits . 15)) (xdr-data-block 357 (il:bits . 15)) (xdr-data-block 358 (il:bits . 15)) (xdr-data-block 359 (il:bits . 15)) (xdr-data-block 360 (il:bits . 15)) (xdr-data-block 361 (il:bits . 15)) (xdr-data-block 362 (il:bits . 15)) (xdr-data-block 363 (il:bits . 15)) (xdr-data-block 364 (il:bits . 15)) (xdr-data-block 365 (il:bits . 15)) (xdr-data-block 366 (il:bits . 15)) (xdr-data-block 367 (il:bits . 15)) (xdr-data-block 368 (il:bits . 15)) (xdr-data-block 369 (il:bits . 15)) (xdr-data-block 370 (il:bits . 15)) (xdr-data-block 371 (il:bits . 15)) (xdr-data-block 372 (il:bits . 15)) (xdr-data-block 373 (il:bits . 15)) (xdr-data-block 374 (il:bits . 15)) (xdr-data-block 375 (il:bits . 15)) (xdr-data-block 376 (il:bits . 15)) (xdr-data-block 377 (il:bits . 15)) (xdr-data-block 378 (il:bits . 15)) (xdr-data-block 379 (il:bits . 15)) (xdr-data-block 380 (il:bits . 15)) (xdr-data-block 381 (il:bits . 15)) (xdr-data-block 382 (il:bits . 15)) (xdr-data-block 383 (il:bits . 15)) (xdr-data-block 384 (il:bits . 15)) (xdr-data-block 385 (il:bits . 15)) (xdr-data-block 386 (il:bits . 15)) (xdr-data-block 387 (il:bits . 15)) (xdr-data-block 388 (il:bits . 15)) (xdr-data-block 389 (il:bits . 15)) (xdr-data-block 390 (il:bits . 15)) (xdr-data-block 391 (il:bits . 15)) (xdr-data-block 392 (il:bits . 15)) (xdr-data-block 393 (il:bits . 15)) (xdr-data-block 394 (il:bits . 15)) (xdr-data-block 395 (il:bits . 15)) (xdr-data-block 396 (il:bits . 15)) (xdr-data-block 397 (il:bits . 15)) (xdr-data-block 398 (il:bits . 15)) (xdr-data-block 399 (il:bits . 15)) (xdr-data-block 400 (il:bits . 15)) (xdr-data-block 401 (il:bits . 15)) (xdr-data-block 402 (il:bits . 15)) (xdr-data-block 403 (il:bits . 15)) (xdr-data-block 404 (il:bits . 15)) (xdr-data-block 405 (il:bits . 15)) (xdr-data-block 406 (il:bits . 15)) (xdr-data-block 407 (il:bits . 15)) (xdr-data-block 408 (il:bits . 15)) (xdr-data-block 409 (il:bits . 15)) (xdr-data-block 410 (il:bits . 15)) (xdr-data-block 411 (il:bits . 15)) (xdr-data-block 412 (il:bits . 15)) (xdr-data-block 413 (il:bits . 15)) (xdr-data-block 414 (il:bits . 15)) (xdr-data-block 415 (il:bits . 15)) (xdr-data-block 416 (il:bits . 15)) (xdr-data-block 417 (il:bits . 15)) (xdr-data-block 418 (il:bits . 15)) (xdr-data-block 419 (il:bits . 15)) (xdr-data-block 420 (il:bits . 15)) (xdr-data-block 421 (il:bits . 15)) (xdr-data-block 422 (il:bits . 15)) (xdr-data-block 423 (il:bits . 15)) (xdr-data-block 424 (il:bits . 15)) (xdr-data-block 425 (il:bits . 15)) (xdr-data-block 426 (il:bits . 15)) (xdr-data-block 427 (il:bits . 15)) (xdr-data-block 428 (il:bits . 15)) (xdr-data-block 429 (il:bits . 15)) (xdr-data-block 430 (il:bits . 15)) (xdr-data-block 431 (il:bits . 15)) (xdr-data-block 432 (il:bits . 15)) (xdr-data-block 433 (il:bits . 15)) (xdr-data-block 434 (il:bits . 15)) (xdr-data-block 435 (il:bits . 15)) (xdr-data-block 436 (il:bits . 15)) (xdr-data-block 437 (il:bits . 15)) (xdr-data-block 438 (il:bits . 15)) (xdr-data-block 439 (il:bits . 15)) (xdr-data-block 440 (il:bits . 15)) (xdr-data-block 441 (il:bits . 15)) (xdr-data-block 442 (il:bits . 15)) (xdr-data-block 443 (il:bits . 15)) (xdr-data-block 444 (il:bits . 15)) (xdr-data-block 445 (il:bits . 15)) (xdr-data-block 446 (il:bits . 15)) (xdr-data-block 447 (il:bits . 15)) (xdr-data-block 448 (il:bits . 15)) (xdr-data-block 449 (il:bits . 15)) (xdr-data-block 450 (il:bits . 15)) (xdr-data-block 451 (il:bits . 15)) (xdr-data-block 452 (il:bits . 15)) (xdr-data-block 453 (il:bits . 15)) (xdr-data-block 454 (il:bits . 15)) (xdr-data-block 455 (il:bits . 15)) (xdr-data-block 456 (il:bits . 15)) (xdr-data-block 457 (il:bits . 15)) (xdr-data-block 458 (il:bits . 15)) (xdr-data-block 459 (il:bits . 15)) (xdr-data-block 460 (il:bits . 15)) (xdr-data-block 461 (il:bits . 15)) (xdr-data-block 462 (il:bits . 15)) (xdr-data-block 463 (il:bits . 15)) (xdr-data-block 464 (il:bits . 15)) (xdr-data-block 465 (il:bits . 15)) (xdr-data-block 466 (il:bits . 15)) (xdr-data-block 467 (il:bits . 15)) (xdr-data-block 468 (il:bits . 15)) (xdr-data-block 469 (il:bits . 15)) (xdr-data-block 470 (il:bits . 15)) (xdr-data-block 471 (il:bits . 15)) (xdr-data-block 472 (il:bits . 15)) (xdr-data-block 473 (il:bits . 15)) (xdr-data-block 474 (il:bits . 15)) (xdr-data-block 475 (il:bits . 15)) (xdr-data-block 476 (il:bits . 15)) (xdr-data-block 477 (il:bits . 15)) (xdr-data-block 478 (il:bits . 15)) (xdr-data-block 479 (il:bits . 15)) (xdr-data-block 480 (il:bits . 15)) (xdr-data-block 481 (il:bits . 15)) (xdr-data-block 482 (il:bits . 15)) (xdr-data-block 483 (il:bits . 15)) (xdr-data-block 484 (il:bits . 15)) (xdr-data-block 485 (il:bits . 15)) (xdr-data-block 486 (il:bits . 15)) (xdr-data-block 487 (il:bits . 15)) (xdr-data-block 488 (il:bits . 15)) (xdr-data-block 489 (il:bits . 15)) (xdr-data-block 490 (il:bits . 15)) (xdr-data-block 491 (il:bits . 15)) (xdr-data-block 492 (il:bits . 15)) (xdr-data-block 493 (il:bits . 15)) (xdr-data-block 494 (il:bits . 15)) (xdr-data-block 495 (il:bits . 15)) (xdr-data-block 496 (il:bits . 15)) (xdr-data-block 497 (il:bits . 15)) (xdr-data-block 498 (il:bits . 15)) (xdr-data-block 499 (il:bits . 15)))) (quote 500)) (defconstant *cells-per-xdr-data-block* 250 "Number of 32 bit cells in a data block.") (defglobalparameter *free-xdr-data-blocks* nil "A list of free xdr data blocks.") (defglobalparameter *max-xdr-data-blocks* 5 "The maximum size of the data block cache.") (defconstant *words-per-cell* 2 "The number of words (16 bits) per cell.") (defun xdr-initialize-cache nil (let ((cache-length (length *free-xdr-data-blocks*))) (unless (>= cache-length *max-xdr-data-blocks*) (dotimes (i (- *max-xdr-data-blocks* cache-length)) (push (il:|create| xdr-data-block) *free-xdr-data-blocks*))))) (defun allocate-xdr-data-block nil "If an xdr data block is available then return it, otherwise create one." (or (pop *free-xdr-data-blocks*) (il:|create| xdr-data-block))) (defun reclaim-xdr-data-block (xdr-data-block) (when (< (length *free-xdr-data-blocks*) *max-xdr-data-blocks*) (push xdr-data-block *free-xdr-data-blocks*)) t) (defmacro foldlo (form divisor) (let ((div (if (constantp divisor) (eval divisor) divisor))) (or (and div (il:poweroftwop div)) (il:\\illegal.arg div)) (list (quote il:lrsh) form (il:sub1 (il:integerlength div))))) (defmacro unfold (form divisor) (let ((div (if (constantp divisor) (eval divisor) divisor))) (or (and div (il:poweroftwop div)) (il:\\illegal.arg div)) (list (quote il:llsh) form (il:sub1 (il:integerlength div))))) (defun os-udp-getbyte (rpcstream) "Get a byte from the instream of the rpcstream and increment the offset." (let ((offset (rpc-stream-inbyteptr rpcstream)) (xdr-data-block (rpc-stream-instream rpcstream))) (prog1 (il:\\getbasebyte (il:locf (il:|fetch| xdr-public il:|of| (setq xdr-data-block (il:\\dtest xdr-data-block (quote xdr-data-block))))) offset) (setf (rpc-stream-inbyteptr rpcstream) (+ 1 offset))))) (defun os-udp-getbytes (rpcstream nbytes) "Get nbytes bytes from the rpcstream and increment the offset" (let* ((xdr-data-block (rpc-stream-instream rpcstream)) (string (il:allocstring nbytes))) (il:\\movebytes (il:locf (il:|fetch| (xdr-data-block xdr-public) il:|of| (setq xdr-data-block (il:\\dtest xdr-data-block (quote xdr-data-block))))) (or (il:smallp (rpc-stream-inbyteptr rpcstream)) 0) (il:|fetch| (il:stringp il:base) il:|of| string) (il:|fetch| (il:stringp il:offst) il:|of| string) nbytes) (incf (rpc-stream-inbyteptr rpcstream) nbytes) string)) (defun os-udp-putbyte (rpcstream byte) "Put a byte of data at the next position in the rpcstream and increment the offset." (let ((xdr-data-block (rpc-stream-outstream rpcstream))) (il:\\putbasebyte (il:locf (il:|fetch| xdr-public il:|of| (setq xdr-data-block (il:\\dtest xdr-data-block (quote xdr-data-block))))) (rpc-stream-outbyteptr rpcstream) byte)) (incf (rpc-stream-outbyteptr rpcstream) 1)) (defun os-udp-putbytes (rpcstream string) "Put a string of bytes into the outstream of rpcstream and increment the offset." (let ((xdr-data-block (rpc-stream-outstream rpcstream)) (length (length string))) (il:\\movebytes (il:|fetch| (il:stringp il:base) il:|of| string) (il:|fetch| (il:stringp il:offst) il:|of| string) (il:locf (il:|fetch| (xdr-data-block xdr-public) il:|of| (setq xdr-data-block (il:\\dtest xdr-data-block (quote xdr-data-block))))) (rpc-stream-outbyteptr rpcstream) length) (incf (rpc-stream-outbyteptr rpcstream) length))) (defun os-udp-getcell (rpcstream) "Get a cell from the rpcstream and increment the offset." (let* ((byteoffset (rpc-stream-inbyteptr rpcstream)) (xdr-data-block (rpc-stream-instream rpcstream)) (cell# (ash byteoffset -2))) (if (and (>= cell# 0) (<= cell# *cells-per-xdr-data-block*)) (let ((base (il:locf (il:|fetch| (xdr-data-block xdr-public) il:|of| (setq xdr-data-block (il:\\dtest xdr-data-block (quote xdr-data-block))))))) (prog1 (il:\\makenumber (il:\\getbase base (unfold cell# *words-per-cell*)) (il:\\getbase base (1+ (unfold cell# *words-per-cell*)))) (setf (rpc-stream-inbyteptr rpcstream) (+ 4 byteoffset)))) (error "Attempt to fetch cell outside of buffer.")))) (defun os-udp-putcell (rpcstream value) (let* ((byteoffset (rpc-stream-outbyteptr rpcstream)) (xdr-data-block (rpc-stream-outstream rpcstream)) (base (il:locf (il:|fetch| (xdr-data-block xdr-public) il:|of| (setq xdr-data-block (il:\\dtest xdr-data-block (quote xdr-data-block))))))) (il:\\putbasebyte base byteoffset (ldb (byte 8 24) value)) (il:\\putbasebyte base (il:\\addbase byteoffset 1) (ldb (byte 8 16) value)) (il:\\putbasebyte base (il:\\addbase byteoffset 2) (ldb (byte 8 8) value)) (il:\\putbasebyte base (il:\\addbase byteoffset 3) (ldb (byte 8 0) value)) (setf (rpc-stream-outbyteptr rpcstream) (+ 4 byteoffset)))) (defun os-udp-getoffset (rpcstream) (cons (rpc-stream-instream rpcstream) (rpc-stream-inbyteptr rpcstream))) (defun os-udp-putoffset (rpcstream byteoffset) (setf (rpc-stream-inbyteptr rpcstream) byteoffset)) (eval-when (load) (xdr-initialize-cache) ) (il:putprops il:rpcos il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/RPCPORTMAPPER b/lispusers/RPCPORTMAPPER new file mode 100644 index 00000000..91fd9ac2 --- /dev/null +++ b/lispusers/RPCPORTMAPPER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated " 8-Aug-88 11:53:57" il:{erinyes}medley>rpcportmapper.\;3 2642 il:|changes| il:|to:| (il:vars il:rpcportmappercoms) (il:functions portmapperdef) il:|previous| il:|date:| " 8-Aug-88 11:40:30" il:{erinyes}medley>rpcportmapper.\;2 ) ; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. (il:prettycomprint il:rpcportmappercoms) (il:rpaqq il:rpcportmappercoms ((il:props (il:rpcportmapper il:makefile-environment il:filetype)) (eval-when (compile load eval) (il:structures mapsequence mapstruct)) (il:functions portmapperdef) (eval-when (load eval) (il:p (portmapperdef))))) (il:putprops il:rpcportmapper il:makefile-environment (:readtable "XCL" :package "RPC2")) (il:putprops il:rpcportmapper il:filetype :compile-file) (eval-when (compile load eval) (defstruct mapsequence program vers protocol port) (defstruct mapstruct program vers prot port therest) ) (defun portmapperdef nil (il:* il:|;;| "Program that maps from programs to ports") (il:nill) (il:* il:\; "Keep DEFUN from expanding the DEFINE-REMOTE-PROGRAM macro any more than necessary") (define-remote-program (quote portmapper) 100000 2 (quote udp) :types (quote ((mapstruct (:union :boolean (nil :void) (t (:struct mapstruct (program :unsigned) (vers :unsigned) (prot :unsigned) (port :unsigned) (therest mapstruct))))) (mapsequence (:sequence (:struct mapsequence (program :unsigned) (vers :unsigned) (protocol :unsigned) (port :unsigned)))))) :procedures (quote ((null 0 nil nil) (lookup 3 (:unsigned :unsigned :unsigned :unsigned) (:unsigned)) (dump 4 nil (mapsequence)) (baddump 4 nil (mapstruct)) (indirect 5 (:unsigned :unsigned :unsigned :string) (:unsigned :string))))) (il:* il:|;;| "TCP version of same. Sad that we need this redundancy.") (define-remote-program (quote tcpportmapper) 100000 2 (quote tcp) :types (quote ((mapstruct (:union :boolean (nil :void) (t (:struct mapstruct (program :unsigned) (vers :unsigned) (prot :unsigned) (port :unsigned) (therest mapstruct))))) (mapsequence (:sequence (:struct mapsequence (program :unsigned) (vers :unsigned) (protocol :unsigned) (port :unsigned)))))) :procedures (quote ((null 0 nil nil) (lookup 3 (:unsigned :unsigned :unsigned :unsigned) (:unsigned)) (dump 4 nil (mapsequence)) (baddump 4 nil (mapstruct)) (indirect 5 (:unsigned :unsigned :unsigned :string) (:unsigned :string)))))) (eval-when (load eval) (portmapperdef) ) (il:putprops il:rpcportmapper il:copyright ("Stanford University and Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/RPCRPC b/lispusers/RPCRPC new file mode 100644 index 00000000..4f81941c --- /dev/null +++ b/lispusers/RPCRPC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated " 1-Aug-88 11:51:33" il:{erinyes}medley>rpcrpc.\;2 38993 il:|changes| il:|to:| (il:functions define-remote-program) il:|previous| il:|date:| "28-Apr-88 17:26:39" il:{erinyes}medley>rpcrpc.\;1) ; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. (il:prettycomprint il:rpcrpccoms) (il:rpaqq il:rpcrpccoms ((il:props (il:rpcrpc il:makefile-environment il:filetype)) (il:variables *debug* *rpc-call* *rpc-version* *rpc-programs* *msec-until-timeout* *msec-between-tries* *internal-time-units-per-msec* *rpc-reply-stats* *rpc-accept-stats* *rpc-reject-stats* *rpc-authentication-stats* *rpc-ok-to-cache* *rpc-socket-cache* *xid-count* *rpc-def-in-progress* *rpc-well-known-sockets* *rpc-protocols* *rpcstream* *rpc-pgname* *rpc-pcname*) (il:* il:|;;;| "Define RPC Program") (il:functions define-remote-program define-remote-prog cons-up-rpc-procs clear-any-name-conflicts def-rpc-types def-rpc-inherits def-rpc-procedures def-rpc-procedure def-rpc-constants undefine-remote-program xdr-gencode-makefcn xdr-gencode-inline) (il:* il:|;;;| "Remote Procedure Call") (il:functions remote-procedure-call setup-rpc perform-rpc rpc-resolve-host rpc-resolve-prog rpc-resolve-proc rpc-find-socket encode-rpc-args actually-do-the-rpc exchange-udp-packets exchange-tcp-packets parse-rpc-reply create-xid) (il:* il:|;;;| "RPC Utility Functions") (il:functions get-reply-stat get-accept-stat get-reject-stat get-authentication-stat get-protocol-number find-cached-socket) (il:* il:|;;;| "RPC Error Messages") (il:functions rpc-error-prm-mismatch rpc-error-prm-unavailable rpc-error-prc-unavailable rpc-error-garbage-args rpc-error-mismatch rpc-error-authentication) (il:* il:|;;;| "Authentication") (il:variables *authentication-typedef* *null-authentication*) (il:functions create-unix-authentication encode-authentication decode-authentication))) (il:putprops il:rpcrpc il:makefile-environment (:readtable "XCL" :package "RPC2")) (il:putprops il:rpcrpc il:filetype :compile-file) (defglobalparameter *debug* nil "T for printout, NUMBER for even more.") (defconstant *rpc-call* 0 "Constant 0 in packet means RPC call, 1 means reply") (defconstant *rpc-version* 2 "This code will only work for SUN RPC Version 2") (defglobalvar *rpc-programs* nil " A list of RPC-PROGRAM structs. This list is consulted by various routines to find infomation about known remote programs. It is assumed that a given NAME field uniquely identifies a (NUMBER, VERSION, PROTOCOL). On the other hand, there may be several NAMEs (and hence, several RPC-STRUCTs) for a given (NUMBER, VERSION, PROTOCOL). ") (defparameter *msec-until-timeout* 10000 "Total time in msec before giving up on UDP exchange with remote host") (defparameter *msec-between-tries* 1000 "Time in msec between UDP retries") (defconstant *internal-time-units-per-msec* (/ internal-time-units-per-second 1000) "This gets used in EXCHANGE-UDP-PACKETS.") (defconstant *rpc-reply-stats* '((0 . accepted) (1 . rejected)) " Assoc list for internal use by PARSE-RPC-REPLY. ") (defconstant *rpc-accept-stats* '((0 . success) (1 . program-unavailable) (2 . program-mismatch) (3 . procedure-unavailable) (4 . garbage-arguments)) " Assoc list for internal use by PARSE-RPC-REPLY. ") (defconstant *rpc-reject-stats* '((0 . rpc-mismatch) (1 . authentication-error)) " Assoc list for internal use by PARSE-RPC-REPLY. ") (defconstant *rpc-authentication-stats* '((1 . bad-credential) (2 . rejected-credential) (3 . bad-verifier) (4 . rejected-verifier) (5 too-weak)) "NIL") (defparameter *rpc-ok-to-cache* t " If NIL, does not attempt to cache socket numbers for non-well-known sockets ") (defvar *rpc-socket-cache* nil " A list of ( ) quintuples.") (defvar *xid-count* 0 "Contains the XID stamp of the next remote procedure call") (defvar *rpc-def-in-progress* nil "Used for debugging only") (defglobalvar *rpc-well-known-sockets* `((* 100000 2 udp 111) (* 100000 2 tcp 111) (* 100003 2 udp 2049)) " List of well-known RPC programs and their sockets. Each element is a list: (host-address prog-number prog-version protocol socket-number) Host-address may be *, in which case it matches any host address. Protocol should be either rpc2::UDP or rpc2::TCP. ") (defvar *rpc-protocols* '((tcp . 6) (udp . 17))) (defvar *rpcstream* nil "This global is not used exceptin debugging. It holds a copy of the RPC-STREAM even after the RPC-CALL returns.") (defglobalvar *rpc-pgname* nil "Name of RPC Program. Used only for *debug* printout.") (defglobalvar *rpc-pcname* nil "Name of RPC Procedure. Used only for *debug* printout.") (il:* il:|;;;| "Define RPC Program") (defmacro define-remote-program (name number version protocol &key constants types inherits procedures) " This macro expands into code to add a new RPC-PROGRAM struct to *RPC-PROGRAMS*. The generated code checks first to see that there are no name conflicts with existing remote programs and then adds the new structure to *RPC-PROGRAMS*. " (let ((ename (eval name)) (enumber (eval number)) (eversion (eval version)) (eprotocol (or (eval protocol) 'udp)) (econstants (eval constants)) (etypes (eval types)) (einherits (eval inherits)) (eprocedures (eval procedures))) (check-type ename symbol) (check-type enumber number) (check-type eversion number) (cond ((member eprotocol '(udp tcp)) (if (and *use-os-networking* (eq eprotocol 'tcp)) (error "~a is an unsupported protocol." eprotocol) t)) ((equal "UDP" (string eprotocol)) (setq eprotocol 'udp)) ((equal "TCP" (string eprotocol)) (if *use-os-networking* (error "~a is an unsupported protocol." eprotocol) (setq eprotocol 'tcp))) ((error "~a is unknown prototype." eprotocol))) (let ((rprog (define-remote-prog ename enumber eversion eprotocol econstants etypes einherits eprocedures))) `(let ((dummy (format-t "Defining remote program ~a, version ~a~%" ',ename ',eversion)) (newprog (make-rpc-program :number ,enumber :version ,eversion :name ',ename :protocol ',eprotocol :types ',(rpc-program-types rprog) :constants ',(rpc-program-constants rprog) :inherits ',(rpc-program-inherits rprog) :procedures ,(cons-up-rpc-procs (rpc-program-procedures rprog))))) (if (clear-any-name-conflicts ',ename ',enumber ',eversion ',eprotocol) (progn (undefine-remote-program ',ename ',enumber ',eversion) (push newprog *rpc-programs*) ',ename) (progn (format-t "Old RPC program not overwritten.~%") nil)))))) (defun define-remote-prog (name number version protocol constants types inherits procedures) (il:* il:|;;|  "This guy does the work, so that DEFINE-REMOTE-PROGRAM can cons up the macro easily.") (il:* il:|;;| "An RPC-PROGRAM struct RPROG is passed back to DEFINE-REMOTE-PROGRAM. Its innards are then used by DEFINE-REMOTE-PROGRAM to build up the big cons that will cons up the proper RPC-PROGRAM later.") (let (rprog) (format-t "Building XDR routines for remote program ~a, version ~a~%" name version) (setq rprog (make-rpc-program :number number :version version :name name :protocol protocol) *rpc-def-in-progress* rprog) (setf (rpc-program-types rprog) (def-rpc-types rprog types)) (setf (rpc-program-inherits rprog) (def-rpc-inherits rprog inherits)) (setf (rpc-program-constants rprog) (def-rpc-constants rprog constants)) (setf (rpc-program-procedures rprog) (def-rpc-procedures rprog procedures)) rprog)) (defun cons-up-rpc-procs (procs) " Given a list of RPC-PROCEDURE structs, conses up code to produce that set of RPC-PROCEDURE structs. " `(list ,@(map 'list #'(lambda (proc) `(make-rpc-procedure :name ',(rpc-procedure-name proc) :procnum ',(rpc-procedure-procnum proc) :argtypes ,(if (rpc-procedure-argtypes proc) `(list ,@(map 'list #'(lambda (fcn) (list 'function fcn)) (rpc-procedure-argtypes proc)))) :resulttypes ,(if (rpc-procedure-resulttypes proc) `(list ,@(map 'list #'(lambda (fcn) (list 'function fcn)) (rpc-procedure-resulttypes proc)))))) procs))) (defun clear-any-name-conflicts (name number version protocol) " Determines whether a proposed (NAME, NUMBER, VERSION, PROTOCOL) would violate the assumption that a NAME uniquely specifies the other three components. If there exists a violation, the user is given a chance to remove the old program. Returns T if no violation of assumption (or violation is resolved by removing old program), Returns NIL if there is an unresolved violation. " (let (oldrpc) (cond ((and (setq oldrpc (find-rpc-program :name name)) (or (/= number (rpc-program-number oldrpc)) (/= version (rpc-program-version oldrpc)) (not (eql protocol (rpc-program-protocol oldrpc))))) (format *query-io* "Remote program name conflict with existing program:~% Name ~a, Protocol ~A, Number ~a, Version ~a~%" name (rpc-program-protocol oldrpc) (rpc-program-number oldrpc) (rpc-program-version oldrpc)) (and (yes-or-no-p "Do you want to remove the old program? ") (undefine-remote-program (rpc-program-name oldrpc) (rpc-program-number oldrpc) (rpc-program-version oldrpc) (rpc-program-protocol oldrpc)))) (t t)))) (defun def-rpc-types (context typedefs) " Essentially a no-op, as typedefs are copied directly from the DEFINE-REMOTE-PROGRAM into the RPC-PROGRAM struct. Just prints out the name of each type as it is encountered. " (if typedefs (format-t " Types~%")) (dolist (i typedefs) (format-t " ~A~%" (first i))) typedefs) (defun def-rpc-inherits (context proglist) " Checks remote program inherited by this one to make sure that it exists. Issues a warning if it cannot find the program to be inherited. " (if proglist (format-t " Inherits~%")) (dolist (prg proglist proglist) (format-t " ~A~%" prg) (if (not (and (symbolp prg) (find-rpc-program :name prg))) (warn "Trying to inherit from remote program ~a, but ~a not found.~%" prg prg)))) (defun def-rpc-procedures (context procs) "Returns a list of RPC-PROCEDURE structs returned by DEF-RPC-PROCEDURE." (check-type procs list "A list of RPC procedure declarations") (if procs (format-t " Procedures~%")) (map 'list #'(lambda (proc) (def-rpc-procedure context proc)) procs)) (defun def-rpc-procedure (context proc) " For a procedure specified to DEFINE-REMOTE-PROGRAM's :PROCEDURES argument, creates and returns an RPC-PROCEDURE struct. XDR procedure code is generated via the call to XDR-GENCODE-MAKEFCN. " (check-type (first proc) (and symbol (not null)) "a non-null symbol naming the RPC procedure.") (check-type (second proc) (integer 0 *) "a non-negative integer RPC procedure number") (check-type (third proc) list) (check-type (fourth proc) list) (let ((rp (make-rpc-procedure))) (setf (rpc-procedure-name rp) (first proc)) (setf (rpc-procedure-procnum rp) (second proc)) (setf (rpc-procedure-argtypes rp) (map 'list #'(lambda (td) (xdr-gencode-makefcn context td 'write)) (third proc))) (setf (rpc-procedure-resulttypes rp) (map 'list #'(lambda (td) (xdr-gencode-makefcn context td 'read)) (fourth proc))) (format-t " ~A~%" (rpc-procedure-name rp)) rp)) (defun def-rpc-constants (context pairs) " Checks that constants specified to DEFINE-REMOTE-PROGRAM are syntactically reasonable. " (if pairs (format-t " Constants~%")) (dolist (pair pairs) (check-type (first pair) (and (not null) symbol)) (check-type (second pair) (and (not null) number)) (format-t " ~A~%" (first pair))) pairs) (defun undefine-remote-program (name number version &optional (protocol 'udp)) " If finds NAME-NUMBER-VERSION-PROTOCOL match in *RPC-PROGRAMS*, deletes. If finds NUMBER-VERSION match with NAME mismatch, asks first. If deletes something, returns NAME of DELETED program, otherwise NIL." (il:* il:\; "") (let ((rpc (find-rpc-program :number number :version version :name name :protocol protocol))) (if rpc (if (or (eql name (rpc-program-name rpc)) (yes-or-no-p "Do you really want to remove/overwrite RPC program ~a?" (rpc-program-name rpc))) (progn (setq *rpc-programs* (delete rpc *rpc-programs*)) (rpc-program-name rpc)))))) (defun xdr-gencode-makefcn (context typedef oper &optional compilesw) " Calls XDR-CODEGEN to generate an XDR function for TYPEDEF. If COMPILESW, then compiles the function. COMPILESW is not used anymore since DEFINE-REMOTE-PROGRAM became a macro. " (let ((code (xdr-codegen context typedef oper))) (if compilesw (compile nil code) code))) (defmacro xdr-gencode-inline (context typedef oper &rest vars) "NIL" (il:* il:|;;| " Note that using a NIL context is valid here. It just means that no typedefs from other Remote Program Definitions are available.") "NIL" `(funcall #',(xdr-codegen context (eval typedef) (eval oper)) ,.vars)) (il:* il:|;;;| "Remote Procedure Call") (defun remote-procedure-call (destination program procid arglist &key (protocol 'udp) remotesocket version credentials dynamic-prognum ( dynamic-version 1) (errorflg t) leave-stream-open (msec-until-timeout *msec-until-timeout*) (msec-between-tries *msec-between-tries*) results) " This is the high-level way of making a remote procedure call (PERFORM-RPC is the low-level way). REMOTE-PROCEDURE-CALL resolves all the arguments, creates a new RPC-STREAM, makes the call, optionally closes the RPC-STREAM, and returns the results of the call. The resolution of arguments is designed such that all arguments may be either unresolved (e.g., a remote host name), or already resolved (e.g., an IP address). " (when (numberp *debug*) (format-t "Remote-Procedure-Call...~%") (format-t " Destination=~A~%" destination) (format-t " Program=~A~%" program) (format-t " ProcID=~A~%" procid) (format-t " ArgList=~A~%" arglist)) (multiple-value-bind (destaddr destsocket rprog rproc rpcstream) (setup-rpc destination program procid remotesocket version dynamic-prognum dynamic-version protocol) (setq rpcstream (open-rpcstream (rpc-program-protocol rprog) destaddr destsocket)) (setq results (perform-rpc destaddr destsocket rprog rproc rpcstream arglist credentials :errorflg errorflg :msec-until-timeout msec-until-timeout :msec-between-tries msec-between-tries)) (unless leave-stream-open (close-rpcstream rpcstream)) results)) (defun setup-rpc (destination program procid &optional destsocket version dynamic-prognum dynamic-version (protocol 'udp)) " Resolves arguments to REMOTE-PROCEDURE-CALL. Takes arguments in more or less any reasonable form and returns multiple values (destination-address, socket-number, RPC-PROGRAM struct, RPC-PROCEDURE struct). See individual RPC-RESOLVE-* programs for details on what inputs are acceptable. " (let* ((destaddr (rpc-resolve-host destination)) (rprog (rpc-resolve-prog program version protocol)) (dummy (il:* il:\; " This code may set RPROG") (when dynamic-prognum (setf rprog (copy-rpc-program rprog)) (setf (rpc-program-number rprog) dynamic-prognum) (setf (rpc-program-version rprog) dynamic-version))) (rproc (rpc-resolve-proc rprog procid)) (socket (or destsocket (rpc-find-socket destaddr rprog (rpc-program-protocol rprog))))) (values destaddr socket rprog rproc))) (defun perform-rpc (destaddr destsocket rprog rproc stream arglist credentials &key (errorflg t) (msec-until-timeout *msec-until-timeout*) (msec-between-tries *msec-between-tries*)) " The low-level remote procedure call function. " (let (retvals) (reinitialize-rpcstream stream destaddr destsocket) (progn (il:* il:|;;| " These are for debugging printouts only") (setq *rpcstream* stream) (setq *rpc-pgname* (rpc-program-name rprog)) (setq *rpc-pcname* (rpc-procedure-name rproc))) (xdr-unsigned stream (create-xid)) (xdr-unsigned stream *rpc-call*) (xdr-unsigned stream *rpc-version*) (xdr-unsigned stream (rpc-program-number rprog)) (xdr-unsigned stream (rpc-program-version rprog)) (xdr-unsigned stream (rpc-procedure-procnum rproc)) (encode-authentication stream credentials) (encode-authentication stream *null-authentication*) (encode-rpc-args stream arglist rproc) (setq retvals (catch 'goforit (actually-do-the-rpc stream msec-until-timeout msec-between-tries errorflg) (parse-rpc-reply stream (rpc-procedure-resulttypes rproc) errorflg))) (when (and (numberp *debug*) (> *debug* 0)) (format-t " Values Returned by RPC: ~A~%" retvals)) retvals)) (defun rpc-resolve-host (destination) " Takes an IPADDRESS, symbol, or string and tries to find an IPADDRESS for a remote host. Signals an error if it cannot resolve the host. " (or (typecase destination (number destination) (symbol (if *use-os-networking* (os-resolve-host (string destination)) (il:iphostaddress destination))) (string (if *use-os-networking* (os-resolve-host destination) (il:iphostaddress (intern destination)))) (t (il:\\illegal.arg destination))) (error "Could not find an IP net address for DESTINATION ~A" destination))) (defun rpc-resolve-prog (program &optional version protocol) " Takes an RPC-PROGRAM, a number, a symbol, or a string along with an optional VERSION and PROTOCOL and tries to find the matching RPC-PROGRAM. Signals an error if it cannot find the intended program. " (cond ((typep program 'rpc-program) program) ((and (typep program 'symbol) (find-rpc-program :name program :version version :protocol protocol))) ((and (numberp program) (find-rpc-program :number program :version version :protocol protocol))) ((and (stringp program) (find-rpc-program :name (intern program) :version version :protocol protocol))) (t (error "Could not find definition for program ~a~a~a.~%" program (if version (format nil ", version ~a" version) "") (if protocol (format nil ", protocol ~a" protocol) ""))))) (defun rpc-resolve-proc (rprog procid) " Given an RPC-PROGRAM struct RPROG, tries to find and return an RPC-PROCEDURE in RPROG specified by a number, string, symbol, or RPC-PROCEDURE. Signals an error if it cannot find the intended rpc-procedure " (cond ((typep procid 'rpc-procedure) procid) ((and (or (numberp procid) (symbolp procid)) (find-rpc-procedure (rpc-program-procedures rprog) procid))) ((and (stringp procid) (find-rpc-procedure (rpc-program-procedures rprog) (intern procid)))) (t (error "Could not find definition for program ~a, procedure ~a~%" (rpc-program-name rprog) procid)))) (defun rpc-find-socket (destaddr prg protocol) " Tries to find and return a remote socket number. (1) Looks in *RPC-WELL-KNOWN-SOCKETS*, (2) Looks in *RPC-SOCKET-CACHE*, but only if *RPC-OK-TO-CACHE*, (3) Requests socket number via remote procedure call to Portmapper on remote machine. If found and *RPC-OK-TO-CACHE*, caches the new socket number on *RPC-SOCKET-CACHE*. (4) If all the above have failed, signals an error. " (let ((prognum (rpc-program-number prg)) (progvers (rpc-program-version prg)) skt) (cond ((setq skt (find-cached-socket '* prognum progvers protocol *rpc-well-known-sockets*)) (if *debug* (format-t "Cached well-known socket ~a found for program ~a~%" skt (rpc-program-name prg))) skt) ((and *rpc-ok-to-cache* (setq skt (find-cached-socket destaddr prognum progvers protocol *rpc-socket-cache*))) (if *debug* (format-t "Cached non-well-known socket ~a found for program ~a~%" skt ( rpc-program-name prg))) skt) ((progn (if *debug* (format-t "Looking up socket for program ~a on ~a.~%" (rpc-program-name prg) destaddr)) (setq skt (first (remote-procedure-call destaddr 'portmapper 'lookup `(,(rpc-program-number prg) ,(rpc-program-version prg) ,(get-protocol-number protocol) 0) :remotesocket 111))) (if *debug* (format-t "Socket ~a found via portampper on ~a for program ~a~%" skt destaddr (rpc-program-name prg))) (if (and *rpc-ok-to-cache* (> skt 0)) (push `(,destaddr ,prognum ,progvers ,protocol ,skt) *rpc-socket-cache*) skt) (if (> skt 0) skt))) ((error "Could not find remote socket number for~%~ Host ~a, Remote Program ~a, Number ~a, Version ~a, Protocol ~a" destaddr (rpc-program-name prg) prognum progvers protocol))))) (defun encode-rpc-args (stream arglist rpc-proc) " Takes a list of arguments and the corresponding list of XDR procedures and converts the arguments into XDR, writing them into the RPC-STREAM. " (when (and (numberp *debug*) (> *debug* 0)) (format-t " RPC Arguments: ~A~%" arglist)) (do ((xdr-fns (rpc-procedure-argtypes rpc-proc) (rest xdr-fns)) (args arglist (rest args))) ((or (null args) (null xdr-fns)) (if (or xdr-fns args) (error "Mismatch of arguments and parameters to RPC call.~ Number or arguments:~a, Number of parameters:~a" (length arglist) (length (rpc-procedure-argtypes rpc-proc))) (rpc-procedure-name rpc-proc))) (funcall (first xdr-fns) stream (first args)))) (defun actually-do-the-rpc (stream msec-until-timeout msec-between-tries errorflg) " Calls the appropriate function (for the protocol) to actually send the packets over the net and await an answer. " (ecase (rpc-stream-protocol stream) (udp (if *use-os-networking* (os-exchange-udp-packets stream msec-until-timeout msec-between-tries errorflg) (exchange-udp-packets stream msec-until-timeout msec-between-tries errorflg))) (tcp (exchange-tcp-packets stream msec-until-timeout errorflg)))) (defun exchange-udp-packets (stream msec-until-timeout msec-between-tries errorflg) " Given the specified timeout and time between tries, this routine continues to send out UDP packets until it either gets a reply or times out. " (if (and (numberp *debug*) (> *debug* 5)) (break "Packet ready to go from PACKET of *RPCSTREAM*")) (do* ((init-time (get-internal-real-time)) (final-time (+ init-time (* msec-until-timeout *internal-time-units-per-msec*)))) ((>= (get-internal-real-time) final-time) (case errorflg (:noerrors (throw 'goforit nil)) (:returnerrors (throw 'goforit '(error timeout))) (otherwise (error "Timeout of RPC Call")))) (when *debug* (format-t "Trying RPC Call: Program ~a, Procedure ~a...~%" *rpc-pgname* *rpc-pcname*)) (if (setf (rpc-stream-instream stream) (il:udp.exchange (rpc-stream-ipsocket stream) (rpc-stream-outstream stream) msec-between-tries)) (progn (when *debug* (format-t "It returned!~%") (and (numberp *debug*) (> *debug* 5) (break "Reply Packet in INSTREAM of RPC-STREAM *RPCSTREAM*"))) (return t))))) (defun exchange-tcp-packets (rpcstream timeout &optional errorflg) " Given the specified timeout, this routine writes onto the TCP stream and waits until it either gets a reply or times out. " (il:* il:|;;|  "Yes, I know EXCHANGE-TCP-PACKETS is a misnomer, but I wanted it to parallel Exchange-UDP-Packets") (let* ((outstring (rpc-stream-outstring rpcstream)) (outstream (rpc-stream-outstream rpcstream)) (instream (rpc-stream-instream rpcstream)) (event (il:tcp.socket.event (il:tcp.stream.socket (rpc-stream-outstream rpcstream))))) (when (numberp *debug*) (inspect-string1 outstring (rpc-stream-outbyteptr rpcstream)) (and (> *debug* 4) (break "Ready to write to tcp stream"))) (rm-forceoutput rpcstream t) (il:forceoutput outstream t) (if *debug* (format-t "Output forced out. Will wait ~a msec for reply~%" timeout)) (il:await.event (il:tcp.socket.event (il:tcp.stream.socket (rpc-stream-outstream rpcstream)) ) timeout nil) (if (il:readp instream) (progn (if *debug* (format-t "It returned!!!!~%")) (rm-new-input-record rpcstream) t) (case errorflg (:noerrors (throw 'goforit nil)) (:returnerrors (throw 'goforit '(error timeout))) (otherwise (error "Timeout of TCP Call after ~a msec.~%" timeout)))))) (defun parse-rpc-reply (rpcstream rettypes &optional errorflg) " Parses a reply message. If all goes well, returns a list of the values returned (or T if RETTYPES is NIL). If RPC was REJECTED, or ACCEPTED but with an ACCEPT-STAT other than SUCCESS, then (Following Courier) the response depends on the value of ERRORFLG: If ERRORFLG = 'NOERROR, then returns NIL If ERRORFLG = 'RETURNERRORS, then returns a list of the form (ERROR reply-stat accept-or-reject-stat otherinfo) If ERRORFLG = anything else, signals Lisp error. " (il:* il:\; " ") (let (xid msgtype reply-stat verf accept-stat reject-stat) (setq xid (xdr-unsigned rpcstream)) (setq msgtype (xdr-unsigned rpcstream)) (if (not (eql msgtype 1)) (error "RPC message is not a reply. MSGTYPE is ~A" msgtype)) (case (get-reply-stat (setq reply-stat (xdr-unsigned rpcstream))) (accepted (setq verf (decode-authentication rpcstream)) (case (get-accept-stat (setq accept-stat (xdr-unsigned rpcstream))) (success (if (null rettypes) t (do ((rs rettypes (cdr rs)) (vals)) ((null rs) (nreverse vals)) (push (funcall (car rs) rpcstream) vals)))) (program-mismatch (rpc-error-prm-mismatch errorflg reply-stat accept-stat (xdr-unsigned rpcstream) (xdr-unsigned rpcstream))) (program-unavailable (rpc-error-prm-unavailable errorflg reply-stat accept-stat)) (procedure-unavailable (rpc-error-prc-unavailable errorflg reply-stat accept-stat)) (garbage-arguments (rpc-error-garbage-args errorflg reply-stat accept-stat)))) (rejected (case (get-reject-stat (setq reject-stat (xdr-unsigned rpcstream))) (rpc-mismatch (rpc-error-mismatch errorflg reply-stat accept-stat (xdr-unsigned rpcstream) (xdr-unsigned rpcstream))) (authentication-error (rpc-error-authentication errorflg reply-stat reject-stat (xdr-unsigned rpcstream))) (otherwise (error "Unknown RPC reply status: ~A" reply-stat))))))) (defun create-xid () "Returns a number to use as the ID of a given transmisssion." (setq *xid-count* (logand twoto32minusone (+ 1 *xid-count*)))) (il:* il:|;;;| "RPC Utility Functions") (defun get-reply-stat (number) "Map number to corresponding reply-stat symbol of remote procedure call" (cdr (assoc number *rpc-reply-stats*))) (defun get-accept-stat (number) "Map number to corresponding accept-stat symbol of remote procedure call" (cdr (assoc number *rpc-accept-stats*))) (defun get-reject-stat (number) "Map number to corresponding reject-stat symbol of remote procedure call" (cdr (assoc number *rpc-reject-stats*))) (defun get-authentication-stat (number) "Map number to corresponding authentication-stat symbol of remote procedure call" (cdr (assoc number *rpc-authentication-stats*))) (defun get-protocol-number (protocol) "Map protocol name (e.g., RPC2::UDP) to corresponding protocol number (e.g., 17)" (or (cdr (assoc protocol *rpc-protocols*)) (error "Could not find number for protocol ~a in *RPC-PROTOCOLS*" protocol))) (defun find-cached-socket (destaddr prognum progvers protocol cache) "Looks up a given (DESTADDR, PROGNUM, PROGVERS, PROTOCOL) in the specified CACHE." (fifth (find-if #'(lambda (quint) (and (eql (first quint) destaddr) (eql (second quint) prognum) (eql (third quint) progvers) (eql (fourth quint) protocol))) cache))) (il:* il:|;;;| "RPC Error Messages") (defun rpc-error-prm-mismatch (errorflg reply-stat accept-stat low high) "NIL" (case errorflg (:noerrors nil) (:returnerrors `(error ,(get-reply-stat reply-stat) ,(get-accept-stat accept-stat) `(,low ,high))) (otherwise (error "RPC Program Mismatch: High: ~A Low: ~A" low high)))) (defun rpc-error-prm-unavailable (errorflg reply-stat accept-stat) "NIL" (case errorflg (:noerrors nil) (:returnerrors `(error ,(get-reply-stat reply-stat) ,(get-accept-stat accept-stat))) (otherwise (error "RPC Program Unavailable")))) (defun rpc-error-prc-unavailable (errorflg reply-stat accept-stat) "NIL" (case errorflg (:noerrors nil) (:returnerrors `(error ,(get-reply-stat reply-stat) ,(get-accept-stat accept-stat))) (otherwise (error "RPC Procedure Unavailable")))) (defun rpc-error-garbage-args (errorflg reply-stat accept-stat) "NIL" (case errorflg (:noerrors nil) (:returnerrors `(error ,(get-reply-stat reply-stat) ,(get-accept-stat accept-stat))) (otherwise (error "RPC Garbage Arguments")))) (defun rpc-error-mismatch (errorflg reply-stat reject-stat low high) "NIL" (case errorflg (:noerrors nil) (:returnerrors `(error ,(get-reply-stat reply-stat) ,(get-reject-stat reject-stat) `(,low ,high))) (otherwise (error "RPC Mismatch: High: ~A Low: ~A" low high)))) (defun rpc-error-authentication (errorflg reply-stat reject-stat authentication-stat) "NIL" (case errorflg (:noerrors nil) (:returnerrors `(error ,(get-reply-stat reply-stat) ,(get-reject-stat reject-stat) ,(get-authentication-stat authentication-stat))) (otherwise (error "Authorization Error: ~A" (get-authentication-stat authentication-stat))))) (il:* il:|;;;| "Authentication") (defconstant *authentication-typedef* '(:struct authentication (type (:enumeration (:null 0) (:unix 1) (:short 2))) (string :string)) "NIL") (defconstant *null-authentication* (make-authentication :type :null :string "")) (defun create-unix-authentication (stamp machine-name uid gid gids) " Given the fields of a Unix authentication, creates an AUTHENTICATION struct with these fields encoded as a string. " (let ((unix-auth (make-authentication)) (tempstream (create-string-rpc-stream))) (xdr-unsigned tempstream stamp) (xdr-string tempstream machine-name) (xdr-unsigned tempstream uid) (xdr-unsigned tempstream gid) (xdr-gencode-inline nil '(:counted-array :unsigned) 'write tempstream gids) (setf (authentication-type unix-auth) :unix) (setf (authentication-string unix-auth) (get-output-stream-string (rpc-stream-outstream tempstream))) unix-auth)) (defun encode-authentication (rpcstream auth) " Given an AUTHENTICATION struct, converts the struct to its XDR encoding and writes it to the RPC-STREAM specified. " (if (null auth) (setq auth *null-authentication*)) (check-type auth authentication) (xdr-gencode-inline nil *authentication-typedef* 'write rpcstream auth)) (defun decode-authentication (rpcstream) " Reads an authentication from specified RPC-STREAM and returns it as an AUTHENTICATION struct. " (xdr-gencode-inline nil *authentication-typedef* 'read rpcstream)) (il:putprops il:rpcrpc il:copyright ("Stanford University and Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/RPCSTRUCT b/lispusers/RPCSTRUCT new file mode 100644 index 00000000..dd175165 --- /dev/null +++ b/lispusers/RPCSTRUCT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated "28-Apr-88 17:29:39" il:{eris}rpc>rpcstruct.\;4 4046 il:|changes| il:|to:| (il:vars il:rpcstructcoms) (il:structures rpc-stream) (file-environments il:rpcstruct) il:|previous| il:|date:| "15-Oct-87 18:49:03" il:{erinyes}medley>rpcstruct.lsp\;1) ; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. (il:prettycomprint il:rpcstructcoms) (il:rpaqq il:rpcstructcoms ((il:props (il:rpcstruct il:makefile-environment il:filetype)) (il:structures rpc-program rpc-procedure rpc-stream authentication))) (il:putprops il:rpcstruct il:makefile-environment (:readtable "XCL" :package "RPC2")) (il:putprops il:rpcstruct il:filetype :compile-file) (defstruct rpc-program " Structure describing a Sun RPC Protocol Remote Program. " (number 0 :type integer) (il:* il:\; "RPC Program Number") (version 0 :type integer) (il:* il:\; "RPC Version Number") name (il:* il:\; "String or Symbol. This name is used only by this program and has no significance to the remote program. The name is assumed to uniquely specify an RPC structure. ") protocol (il:* il:\; "A symbol. Either RPC::UDP or RPC::TCP.") constants (il:* il:\; "List of ( ) pairs.") types (il:* il:\; "List of ( ) pairs") inherits (il:* il:\; "List of names of RPC names whose types and constants are inherited by this RPC.") procedures (il:* il:\; "List of RPC-PROCEDURE structures defining the procedures for this remote program.")) (defstruct rpc-procedure "Strcture defining a single procedure of a SUN RPC Protcol remote program. " name (il:* il:\; "The procedure name. A string or symbol.") (procnum 0 :type integer) (il:* il:\; "The procedure number. An integer.") argtypes (il:* il:\; "List of argument types. May be typenames or typedefs. NIL for no arguments.") resulttypes (il:* il:\; "Same as ARGTYPES except for returned values.")) (defstruct rpc-stream "Holds info and functions for encoding, decoding and executing remote procedure calls" protocol (il:* il:\; " UDP, TCP, or STRING") ipsocket (il:* il:\; "Local IP Socket") instream (il:* il:\; "Incoming (Reply) Stream or Packet") inbyteptr (il:* il:\; "Byte Pointer to current position in incoming data. For UDP it is the byte pointer in the UDP packet. For TCP it is decremented, saying how many bytes left in this RM record before another RM header must be read.") outstream (il:* il:\; "UDP outgoing packet, or outgoing stream used by TCP and STRING.") outbyteptr (il:* il:\; "Byte Pointer to current position in outgoing string used to build RM record for TCP. See page 10 of \"Remote Procedure Call Protocol Specification\" for details of the RM 'Record Marking Standard'.") outstring (il:* il:\; "Used by TCP to encode as string before sending") getbyte (il:* il:\; "Function to read byte of incoming data") getbytes (il:* il:\; "Function to do bulk read of incoming data") getcell (il:* il:\; "Function to get 32 bit two's complement integer of incoming data. Would be better to have 32 bit unsigned as the primitive") getoffset (il:* il:\; "Get current offset into incoming data.") putbyte (il:* il:\; "Function to write byte of outgoing data") putbytes (il:* il:\; "Function to do bulk write of outgoing data.") putcell (il:* il:\; "Function to write 32 bit two's complement integer of outgoing data.") putoffset (il:* il:\; "Set current position in incoming data.") private (il:* il:\; "Can be used by user as desired") os-destaddr (il:* il:\; "Address of the destination. Only used by os-networking.")) (defstruct authentication "Sun RPC Version 2 Authentication Record" type (il:* il:\; "0 = NULL") (il:* il:\; "1 = Unix") (il:* il:\; "2 = Short") string (il:* il:\; "") (il:* il:\; "Encoding of any fields of that type authentication. String is a Common Lisp string rather than an XDR-STRING.")) (il:putprops il:rpcstruct il:copyright ("Stanford University and Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/RPCXDR b/lispusers/RPCXDR new file mode 100644 index 00000000..887a0657 --- /dev/null +++ b/lispusers/RPCXDR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated "28-Apr-88 18:39:29" il:{eris}rpc>rpcxdr.\;6 23367 il:|changes| il:|to:| (il:functions xdr-string-pointer) (il:vars il:rpcxdrcoms) (file-environments il:rpcxdr) il:|previous| il:|date:| "28-Apr-88 18:34:44" il:{eris}rpc>rpcxdr.\;5) ; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. (il:prettycomprint il:rpcxdrcoms) (il:rpaqq il:rpcxdrcoms ((il:props (il:rpcxdr il:makefile-environment il:filetype)) (il:* il:|;;;| "Useful Constants") (il:variables twoto31minusone twoto31st twoto32nd twoto32minusone twoto63minusone twoto64minusone twoto64th minus2to31 minus2to63) (il:variables *xdr-primitive-types* *xdr-constructed-types* *xdr-codegen-recursivelst*) (il:structures typstk) (il:* il:\; "Miscellaneous XDR Utility Functions") (il:functions access-fcn-name constructor-fcn-name find-in-type-stack) (il:* il:|;;;| "Type Declarations and Predicates") (il:types xdr-integer xdr-unsigned xdr-hyperinteger xdr-hyperunsigned) (il:functions xdr-integer-p xdr-unsigned-p xdr-hyperinteger-p xdr-hyperunsigned-p) (il:* il:|;;;| "XDR Code Generation for Constructed Functions") (il:functions xdr-codegen-comment xdr-codegen xdr-codegen-1 xdr-codegen-2 xdr-codegen-3 xdr-codegen-recursion xdr-codegen-primitive xdr-codegen-inherited xdr-codegen-qualified xdr-codegen-local xdr-codegen-constructed xdr-codegen-constant xdr-codegen-enumeration xdr-codegen-union xdr-codegen-list xdr-codegen-struct xdr-codegen-fixed-array xdr-codegen-counted-array xdr-codegen-opaque xdr-codegen-skip xdr-codegen-sequence) (il:* il:|;;;| "XDR PRIMITIVES") (il:functions xdr-boolean xdr-integer xdr-unsigned xdr-hyperinteger xdr-hyperunsigned xdr-opaque-primitive xdr-skip-primitive xdr-string xdr-string-pointer xdr-float xdr-void))) (il:putprops il:rpcxdr il:makefile-environment (:readtable "XCL" :package "RPC2")) (il:putprops il:rpcxdr il:filetype :compile-file) (il:* il:|;;;| "Useful Constants") (defconstant twoto31minusone 2147483647 "NIL") (defconstant twoto31st 2147483648) (defconstant twoto32nd 4294967296 "NIL") (defconstant twoto32minusone 4294967295 "NIL") (defconstant twoto63minusone 9223372036854775807 "NIL") (defconstant twoto64minusone 18446744073709551615 "NIL") (defconstant twoto64th 18446744073709551616 "NIL") (defconstant minus2to31 -2147483648 "NIL") (defconstant minus2to63 -9223372036854775808 "NIL") (defparameter *xdr-primitive-types* (quote ((:integer . xdr-integer) (:boolean . xdr-boolean) (:unsigned . xdr-unsigned) (:hyperinteger . xdr-hyperinteger) (:hyperunsigned . xdr-hyperunsigned) (:string . xdr-string) (:void . xdr-void) (:float . xdr-float) (:double . xdr-double) (:string-pointer . xdr-string-pointer))) "An alist of XDR primitive types and the function that encodes/decodes that type") (defparameter *xdr-constructed-types* (quote ((:enumeration . xdr-codegen-enumeration) (:union . xdr-codegen-union) (:struct . xdr-codegen-struct) (:list . xdr-codegen-list) (:fixed-array . xdr-codegen-fixed-array) (:counted-array . xdr-codegen-counted-array) (:opaque . xdr-codegen-opaque) (:skip . xdr-codegen-skip) (:sequence . xdr-codegen-sequence))) " Association list of XDR constructed types and the functions that create functions to read/write them") (defglobalvar *xdr-codegen-recursivelst* nil " Place for XDR-CODEGEN to save recursive functions it found in making an expansion. A list of TYPSTK structs ") (defstruct typstk "Element on stack of types for which code already generated." prog type xdrproc oper args) (il:* il:\; "Miscellaneous XDR Utility Functions") (defun access-fcn-name (struct field) " Maps struct name and field name (strings or symbols) into the access function name for that slot." (il:* il:\; "") (intern (concatenate (quote string) (string struct) "-" (string field)) (symbol-package struct))) (defun constructor-fcn-name (struct) " Maps a symbol or string naming a defstruct into the constructor function symbol for that defstruct type" (intern (concatenate (quote string) "MAKE-" (string struct)) (symbol-package struct))) (defun find-in-type-stack (prg typ stack) " Find the first element in a list of TYPSTK's such that PRG and TYP match the PROG and TYPE fields of the TYPSTK. " (dolist (el stack) (if (and (eql prg (typstk-prog el)) (eql typ (typstk-type el))) (return el)))) (il:* il:|;;;| "Type Declarations and Predicates") (deftype xdr-integer nil (quote (and integer (satisfies xdr-integer-p)))) (deftype xdr-unsigned nil (quote (and integer (satisfies xdr-unsigned-p)))) (deftype xdr-hyperinteger nil (quote (and integer (satisfies xdr-hyperinteger-p)))) (deftype xdr-hyperunsigned nil (quote (and integer (satisfies xdr-hyperunsigned-p)))) (defun xdr-integer-p (i) (and (>= i minus2to31) (< i twoto31st))) (defun xdr-unsigned-p (i) (or (and (typep i (quote fixnum)) (>= (the fixnum i) 0)) (and (>= i 0) (< i twoto32nd)))) (defun xdr-hyperinteger-p (i) (and (>= i minus2to63) (<= i twoto63minusone))) (defun xdr-hyperunsigned-p (i) (and (>= i 0) (<= i twoto64minusone))) (il:* il:|;;;| "XDR Code Generation for Constructed Functions") (defun xdr-codegen-comment nil " *************************************************** **** Code Generation for XCL Constructed Types **** *************************************************** The following functions generate code for translating between Common Lisp and XDR. For each function, CONTEXT is an RPC-PROGRAM structure with respect to which a typedef is being constructed. TYPEDEF is an XDR type definition, and OPER is either READ (decode) or WRITE (encode). For all functions except XDR-CODEGEN, a third argument ARGS is a list of arguments to the code being generated. It always begins with an XDR-stream argument and for OPER=WRITE is usually followed by the object to be written. WARNINGS: (1) DO NOT, REPEAT DO NOT pass an (XDR-CODEGEN-xxx) as the argument of an (XDR-CODEGEN-xxx). If you do, you might cause the code generated for the argument to be evaluated multiple times in the code for the resulting expression. (2) The XDR-CODEGEN-xxx functions code in-line rather than wrap themselves in LET's or LAMBDA's or whatever. To avoid complications with functions that require a location-specifier (CHECK-TYPE or CCASE, for example), an XDR-CODEGEN-xxx function may ***not*** generate code that assumes that its arguments ARGS or various COUNTs are legitimate location-specifiers. If a CHECK-TYPE or similar function is to be done, a LET (or other binding mechanism) should be generated to create a legal location-specifier." nil) (defun xdr-codegen (context typedef oper) " Top-level XDR Code Generation function. Returns code to read/write an XDR element of type TYPEDEF. CONTEXT is an RPC-PROGRAM structure with respect to which the TYPEDEF is interpreted (in terms of inheritance). TYPEDEF is an XDR Type or Type definition. OPER is either 'RPC2::READ or 'RPC::WRITE. See documentation of XDR-CODEGEN-COMMENT. " (setq *xdr-codegen-recursivelst* nil) (let* ((args (ecase oper (read (quote (xdr-stream))) (write (quote (xdr-stream xdr-toplevel-item))))) (fcn (xdr-codegen-1 context typedef oper args nil))) (if fcn (if (null *xdr-codegen-recursivelst*) (list (quote lambda) args fcn) (list (quote lambda) args (il:bquote (labels (il:\\\, (xdr-codegen-3 *xdr-codegen-recursivelst*)) (il:\\\, fcn))))) (error "Could not parse XDR Type ~S" typedef)))) (defun xdr-codegen-1 (context typedef oper args stk) " Generates code to read or write an element of type TYPEDEF. CONTEXT, TYPEDEF, and OPER are as in XDR-CODEGEN. ARGS is a list of the arguments forms for the generated code. For OPER=READ it will (), and For OPER=WRITE it will be ( ). STK is a list of TYPSTK elements, one for each named type above this one in this expansion. " (or (xdr-codegen-primitive context typedef oper args stk) (xdr-codegen-constructed context typedef oper args stk) (xdr-codegen-local context typedef oper args stk) (xdr-codegen-inherited context typedef oper args stk) (xdr-codegen-qualified context typedef oper args stk) (error "Could not resolve XDR Type Definition: ~a" typedef))) (defun xdr-codegen-2 (context typename oper args stk) " Expands named types. (1) Sees whether type already seen above here in this expansion. Otherwise, (2) Notes the name on TYPESTK, (3) Finds the definition of this type, (4) Calls XDR-CODEGEN-1 to expand the type definition. (5) Sees whether the XDR-CODEGEN-1 call found this type below, if so, notes this on *XDR-CODEGEN-RECURSIVELST* and returns call to the recursive function for this type. otherwise just returns the code. " (il:* il:|;;| "Every named type expansion passes through here and gets expanded. Since it is only named types that can be recursive, this is the only place we check for recursion") (or (xdr-codegen-recursion context typename oper args stk) (let (td code top) (il:* il:\; "No") (push (make-typstk :prog context :type typename :oper oper :args (if (eql oper (quote read)) args (quote (rpcstream rvalue)))) stk) (il:* il:\; "Push type on stack") (unless (setq td (find-rpc-typedef context typename)) (error "Null type definition for Program ~A, Type ~A" (and context (rpc-program-name context)) typename)) (setq code (xdr-codegen-1 context td oper args stk)) (il:* il:\; "Generate code") (setq top (car stk)) (il:* il:\; "\"Pop\" stack") (if (null (typstk-xdrproc top)) (il:* il:\; "Was this type called recursively?") code (il:* il:\; "No, just return code") (progn (push top *xdr-codegen-recursivelst*) (il:* il:\; "Yes, save recursive type") (il:bquote ((il:\\\, (typstk-xdrproc top)) (il:\\\,@ args))) (il:* il:\; "Return call to recursive function")))))) (defun xdr-codegen-3 (rlist) (il:* il:|;;| "Generate the set of function definitions for LABELS. RLIST is a list of TYPSTK structs. .") (map (quote list) (function (lambda (typstk) (il:bquote ((il:\\\, (typstk-xdrproc typstk)) (il:\\\, (typstk-args typstk)) (il:\\\, (xdr-codegen-1 (typstk-prog typstk) (or (find-rpc-typedef (typstk-prog typstk) (typstk-type typstk)) (error "No typedef for Program ~A, Type ~A" (rpc-program-name (typstk-prog typstk)) (typstk-type typstk))) (typstk-oper typstk) (typstk-args typstk) rlist)))))) rlist)) (defun xdr-codegen-recursion (prg typ oper args stack) (il:* il:|;;| " If type has already be seen, mark as recursive and return code calling that function") (let ((instack (find-in-type-stack prg typ stack))) (when instack (il:* il:\; "Seen it before") (setf (typstk-xdrproc instack) (or (typstk-xdrproc instack) (intern (symbol-name (gensym (concatenate (quote string) "XDR-" (symbol-name oper) "-" (symbol-name typ) "-")))))) (il:bquote ((il:\\\, (typstk-xdrproc instack)) (il:\\\,@ args)))))) (defun xdr-codegen-primitive (context typedef oper args stk) "NIL" (let (fcn) (if (and (symbolp typedef) (setq fcn (cdr (assoc typedef *xdr-primitive-types*)))) (il:bquote ((il:\\\, fcn) (il:\\\,@ args)))))) (defun xdr-codegen-inherited (context typedef oper args stk) "NIL" (and (symbolp typedef) (some (function (lambda (progname) (let* ((prg (find-rpc-program :name progname)) (td (find-rpc-typename prg typedef))) (if (and prg td) (xdr-codegen-2 prg td oper args stk))))) (rpc-program-inherits context)))) (defun xdr-codegen-qualified (context typedef oper args stk) "NIL" (if (and (consp typedef) (symbolp (car typedef)) (symbolp (cdr typedef))) (let* ((prg (find-rpc-program :name (car typedef))) (td (find-rpc-typedef prg (cdr typedef)))) (if (and prg td) (xdr-codegen-2 prg td oper args stk) (error "Could not find qualified XDR definition ~A from RPC program ~A" (cdr typedef) (car typedef)))))) (defun xdr-codegen-local (context typedef oper args stk) "NIL" (if (symbolp typedef) (let ((td (find-rpc-typename context typedef))) (if td (xdr-codegen-2 context td oper args stk))))) (defun xdr-codegen-constructed (context typedef oper args stk) "NIL" (let (fcn) (if (and (consp typedef) (setq fcn (cdr (assoc (car typedef) *xdr-constructed-types*)))) (funcall fcn context typedef oper args stk)))) (defun xdr-codegen-constant (context constant) (cond ((null constant) (error "Could not resolve nil constant definition from RPC program ~a~%" (rpc-program-name context))) ((integerp constant) constant) (il:* il:\; " Immediate Constant Definition") ((and (symbolp constant) (or (find-xdr-constant context constant) (il:* il:\; " Local Constant Definition") (some (function (lambda (cntx) (find-xdr-constant (find-rpc-program :name cntx) constant))) (rpc-program-inherits context)) (il:* il:\; " Inherited Constant Definition")))) ((and (consp constant) (il:* il:\; "Qualified Constant Definition ") (symbolp (cdr constant)) (find-xdr-constant (find-rpc-program :name (car constant)) (cdr constant)))) ((error "Could not resolve XDR constant ~a~%" constant)))) (defun xdr-codegen-enumeration (context typedef oper args stk) "NIL" (let ((alist (map (quote list) (function (lambda (x) (cons (car x) (xdr-codegen-constant context (cadr x))))) (cdr typedef)))) (if (eql oper (quote read)) (il:bquote (car (rassoc (xdr-integer (il:\\\, (car args))) (quote (il:\\\, alist))))) (il:bquote (xdr-integer (il:\\\, (car args)) (cdr (assoc (il:\\\, (cadr args)) (quote (il:\\\, alist))))))))) (defun xdr-codegen-union (context typedef oper args stk) " (UNION ( ) ...(<> <>)) Read Calling Sequence: XDR-UNION(xdrstream) Read Input: An integer followed by the encoding of that arm. Read Output: The enumeration element from the type of the discriminant The discriminant and arm are returned as a dotted pair. Write Input: An enumeration element and an unencoded arm. Write calling sequence: XDR-UNION(xdrstream,discriminant,arm) Write Output: The (integer) encoding of the discriminant and the encoded arm. " (let ((discrim-type (second typedef)) (xdrstream (first args)) (unionlist (second args))) (if (eql oper (quote read)) (il:bquote (let (discriminant) (setq discriminant (il:\\\, (xdr-codegen-1 context discrim-type oper args stk))) (list discriminant (case discriminant (il:\\\,. (do ((pairs (cddr typedef) (cdr pairs)) (arms) (pair)) ((null pairs) (nreverse arms)) (setq pair (first pairs)) (push (il:bquote ((il:\\\, (if (eql (car pair) (quote default)) (quote otherwise) (il:bquote ((il:\\\, (car pair)))))) (il:\\\, (xdr-codegen-1 context (cadr pair) oper args stk)))) arms))))))) (il:bquote (progn (il:\\\, (xdr-codegen-1 context discrim-type oper (il:bquote ((il:\\\, xdrstream) (car (il:\\\, unionlist)))) stk)) (case (car (il:\\\, unionlist)) (il:\\\,. (do ((pairs (cddr typedef) (cdr pairs)) (arms) (pair)) ((null pairs) (nreverse arms)) (setq pair (car pairs)) (push (il:bquote ((il:\\\, (if (eql (car pair) (quote default)) (quote otherwise) (il:bquote ((il:\\\, (car pair)))))) (il:\\\, (xdr-codegen-1 context (cadr pair) oper (il:bquote ((il:\\\, xdrstream) (cadr (il:\\\, unionlist)))) stk)))) arms))))))))) (defun xdr-codegen-list (context typedef oper args stk) "TYPEDEF = (LIST ... )" (if (eql oper (quote read)) (il:bquote (list (il:\\\,. (map (quote list) (function (lambda (td) (xdr-codegen-1 context td oper args stk))) (cdr typedef))))) (let ((xdrstream (first args)) (thelist (second args))) (il:bquote (progn (il:\\\,. (do ((td (cdr typedef) (cdr td)) (indx 0 (+ 1 indx)) (code)) ((null td) (nreverse code)) (push (xdr-codegen-1 context (car td) oper (il:bquote ((il:\\\, xdrstream) (elt (il:\\\, thelist) (il:\\\, indx)))) stk) code)))))))) (defun xdr-codegen-struct (context typedef oper args stk) "(STRUCT ( ) ... ( ))" (let ((struct-type (cadr typedef)) (xdrstream (first args)) (thestruct (second args))) (if (eql oper (quote read)) (let ((newstruct (intern (symbol-name (gensym "XDR-"))))) (il:bquote (let (((il:\\\, newstruct) ((il:\\\, (constructor-fcn-name struct-type))))) (il:\\\,@ (map (quote list) (function (lambda (x) (il:bquote (setf ((il:\\\, (access-fcn-name struct-type (car x))) (il:\\\, newstruct)) (il:\\\, (xdr-codegen-1 context (cadr x) oper args stk)))))) (cddr typedef))) (il:\\\, newstruct)))) (il:bquote (progn (il:\\\,@ (map (quote list) (function (lambda (x) (xdr-codegen-1 context (cadr x) oper (il:bquote ((il:\\\, xdrstream) ((il:\\\, (access-fcn-name struct-type (car x))) (il:\\\, thestruct)))) stk))) (cddr typedef)))))))) (defun xdr-codegen-fixed-array (context typedef oper args stk &optional dont-resolve-count) "typedef is (fixed-array elttype count)" (il:* il:\; "") "typedef is (fixed-array elttype count)" (let* ((element-type (second typedef)) (count (if dont-resolve-count (third typedef) (il:* il:\; " This hack enables XDR-CODEGEN-FIXED-ARRAY to be used by XDR-CODEGEN-COUNTED-ARRAY. Normally, the count must be resolvable at codegen-time, but when called by XDR-CODEGEN, COUNT is an expression that needs to be evaluated at run time. ") (xdr-codegen-constant context (third typedef)))) (xdrstream (first args)) (thearray (second args)) (newarray (intern (symbol-name (gensym "XDR-ARRAY-")))) (thecount (intern (symbol-name (gensym "XDR-COUNT-"))))) (if (eql oper (quote read)) (il:bquote (let (((il:\\\, newarray) (make-array (il:\\\, count))) ((il:\\\, thecount) (il:\\\, count))) (check-type (il:\\\, thecount) (integer 0 *)) (dotimes (i (il:\\\, thecount) (il:\\\, newarray)) (setf (elt (il:\\\, newarray) i) (il:\\\, (xdr-codegen-1 context element-type oper args stk)))))) (il:bquote (let (((il:\\\, thecount) (il:\\\, count))) (check-type (il:\\\, thecount) (integer 0 *)) (dotimes (i (il:\\\, thecount) (il:\\\, thearray)) (il:\\\, (xdr-codegen-1 context element-type oper (il:bquote ((il:\\\, xdrstream) (elt (il:\\\, thearray) i))) stk)))))))) (defun xdr-codegen-counted-array (context typedef oper args stk) "typedef is (fixed-array element-type)" (il:* il:\; "") "typedef is (fixed-array element-type)" (let ((element-type (second typedef)) (xdrstream (first args)) (thearray (second args))) (if (eql oper (quote read)) (il:bquote (let ((thecount (il:\\\, (xdr-codegen-1 context :unsigned oper args stk)))) (list thecount (il:\\\, (xdr-codegen-fixed-array context (il:bquote (:fixed-array (il:\\\, element-type) thecount)) oper args stk t))))) (il:bquote (let ((thecount (length (il:\\\, thearray)))) (il:\\\, (xdr-codegen-1 context :unsigned oper (il:bquote ((il:\\\, xdrstream) thecount)) stk)) (il:\\\, (xdr-codegen-fixed-array context (il:bquote (:fixed-array (il:\\\, element-type) thecount)) oper args stk t))))))) (defun xdr-codegen-opaque (context typedef oper args stk) "Declaration is (opaque )" (let ((bytecount (xdr-codegen-constant context (second typedef))) (xdrstream (first args)) (bytestring (second args))) (check-type bytecount (integer 0 *)) (if (eql oper (quote read)) (il:bquote (xdr-opaque-primitive (il:\\\, xdrstream) (il:\\\, bytecount))) (il:bquote (xdr-opaque-primitive (il:\\\, xdrstream) (il:\\\, bytecount) (il:\\\, bytestring)))))) (defun xdr-codegen-skip (context typedef oper args stk) (let ((bytecount (xdr-codegen-constant context (second typedef))) (xdrstream (first args)) (bytestring (second args))) (check-type bytecount (integer 0 *)) (if (eql oper (quote read)) (il:bquote (xdr-skip-primitive (il:\\\, xdrstream) (il:\\\, bytecount))) (il:bquote (xdr-skip-primitive (il:\\\, xdrstream) (il:\\\, bytecount) (il:\\\, bytestring)))))) (defun xdr-codegen-sequence (context typedef oper args stk) (let ((stream (first args)) (elements (second args)) (elttype (second typedef))) (if (eql oper (quote read)) (il:bquote (do ((items)) nil (ecase (xdr-boolean (il:\\\, stream)) ((nil) (return (nreverse items))) ((t) (push (il:\\\, (xdr-codegen-1 context elttype oper args stk)) items))))) (il:bquote (dolist (el (il:\\\, elements) (xdr-boolean (il:\\\, stream) nil)) (xdr-boolean (il:\\\, stream) t) (il:\\\, (xdr-codegen-1 context elttype oper (il:bquote ((il:\\\, stream) el)) stk))))))) (il:* il:|;;;| "XDR PRIMITIVES") (defun xdr-boolean (xdrstream &optional (value t writep)) "NIL" (if writep (putcell xdrstream (if (null value) 0 1)) (progn (setq value (getcell xdrstream)) (ccase value (0 nil) (1 t))))) (defun xdr-integer (xdrstream &optional value) "NIL" (if value (progn (check-type value integer) (putcell xdrstream value)) (getcell xdrstream))) (defun xdr-unsigned (xdrstream &optional value) "NIL" (if value (putunsigned xdrstream value) (getunsigned xdrstream))) (defun xdr-hyperinteger (xdrstream &optional (value t writep)) "NIL" (if writep (progn (check-type value xdr-hyperinteger) (if (minusp value) (setq value (+ twoto64th value))) (putunsigned xdrstream (ash value -32)) (putunsigned xdrstream (logand value twoto32minusone))) (progn (setq value (+ (ash (getunsigned xdrstream) 32) (getunsigned xdrstream))) (if (> value twoto63minusone) (setq value (- value twoto64th)) value)))) (defun xdr-hyperunsigned (xdrstream &optional (value t writep)) "NIL" (if writep (progn (check-type value xdr-hyperunsigned) (putunsigned xdrstream (ash value -32)) (putunsigned xdrstream (logand value twoto32minusone))) (+ (ash (getunsigned xdrstream) 32) (getunsigned xdrstream)))) (defun xdr-opaque-primitive (xdrstream n &optional (value t writep)) "NIL" (if writep (progn (check-type n (integer 0 *)) (putbytes xdrstream value) (setq n (logand n 3)) (dotimes (i (case n ((0 2) n) (1 3) (3 1))) (putbyte xdrstream 0))) (prog1 (setq value (getbytes xdrstream n)) (setq n (logand n 3)) (dotimes (i (case n ((0 2) n) (1 3) (3 1))) (getbyte xdrstream))))) (defun xdr-skip-primitive (xdrstream n &optional (value t writep)) (if writep (error "SKIP is currently defined for input only.") (progn (setq value (getoffset xdrstream)) (putoffset xdrstream (+ n (cdr value))) n))) (defun xdr-string (xdrstream &optional value) "NIL" (if value (let ((nbytes (length value))) (xdr-unsigned xdrstream nbytes) (xdr-opaque-primitive xdrstream nbytes value)) (xdr-opaque-primitive xdrstream (xdr-unsigned xdrstream)))) (defun xdr-string-pointer (xdrstream &optional (value t writep)) "This is a hack to avoid copying 512 byte VMEMPAGEP's" (if writep (let ((buffer (car value)) (nbytes (cdr value)) (outstream (rpc-stream-outstream xdrstream)) (mod4)) (il:* il:|;;| " This only works for UDP!!") (xdr-unsigned xdrstream nbytes) (if *use-os-networking* (il:\\movebytes buffer 0 (il:locf (il:|fetch| (xdr-data-block xdr-public) il:|of| (setq outstream (il:\\dtest outstream (quote xdr-data-block))))) (rpc-stream-outbyteptr xdrstream) nbytes) (il:udp.append.bytes outstream buffer 0 nbytes)) (if (not (= 0 (setq mod4 (logand 3 nbytes)))) (il:* il:\; "Pad to multiple of 4 with zeros.") (dotimes (i (case mod4 ((0 2) mod4) (1 3) (3 1))) (putbyte outstream 0)))) (let* ((nbytes (xdr-unsigned xdrstream)) (place (getoffset xdrstream)) (packet (car place)) (byteoffset (cdr place))) (il:* il:|;;| " Returns ((packet . byteoffset) . number-of-bytes))") (il:* il:|;;| " Note that this does NOT update rpcstream ponter.") (cons (cons packet byteoffset) nbytes)))) (defun xdr-float (s &optional (v t writep)) "NIL" (error "Not yet implemented")) (defun xdr-void (xdrstream &optional (value t writep)) nil) (il:putprops il:rpcxdr il:copyright ("Stanford University and Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/RS232CNETWORK b/lispusers/RS232CNETWORK new file mode 100644 index 00000000..0206e6cf --- /dev/null +++ b/lispusers/RS232CNETWORK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "21-Oct-88 12:30:07" {QV}LISP>RS232CNETWORK.\;49 52468 |changes| |to:| (FNS \\RS232C.EVENTFN) (VARS RS232CNETWORKCOMS) |previous| |date:| "13-Oct-88 18:05:26" {QV}LISP>RS232CNETWORK.\;48) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT RS232CNETWORKCOMS) (RPAQQ RS232CNETWORKCOMS ((COMS (DECLARE\: FIRST DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) DLRS232C)) (DECLARE\: FIRST EVAL@LOAD DONTCOPY (FILES (LOADCOMP) LLETHER 10MBDRIVER LLNS PUP (SOURCE) DLRS232C))) (COMS (* |;;| "Addition to DOVERS232C Opie definitions") (DECLARE\: DONTCOPY (EXPORT (RECORDS |Dove.i8274.WR7|) (CONSTANTS * |Dove.i8274.WR7.Constants|)))) (* |;;| "This should have been in the DLRS232C file") (GLOBALVARS \\DLRS232C.OUTPUT.TIMEOUT) (* |;;| "a hint that the code should install itself as the network handler...") (INITVARS (*RS232C-NETWORK* T) (*RS232C-NETWORK-DIALING-TIMEOUT* 30) (*RS232C-NETWORK-AUTODIAL*)) (GLOBALVARS *RS232C-NETWORK* *RS232C-NETWORK-DIALING-TIMEOUT* *RS232C-NETWORK-AUTODIAL*) (FNS \\DVRS232C.SET.PARAMETERS \\DVRS232C.INIT \\DLRS232C.INIT RS232C.INIT \\RS232C.HANDLE.PACKET \\RS232CNETWORKINIT \\DLRS232C.CREATE.NDB) (* |;;| "because it needed to know to reinit the rs232c if that was the network interface...") (FNS \\ETHEREVENTFN) (* |;;| "because it was closing too many sockets when it shouldn't have...") (FNS TURN.OFF.ETHER) (* |;;| "because it didn't check to see if it had an NDBIQ or NDBTQ before dequeuing...") (FNS \\DVRS232C.SHUTDOWN) (* |;;| "because etherpackets are actually 2 pages, and we want to use it all if necessary (bytesperpage - etherheader + 8bytes from encapsulation which we put data into)") (VARS (\\DLRS232C.DEFAULT.PACKET.LENGTH 968) (\\RS232C.OUTPUT.PACKET.LENGTH 968)) (* |;;| "because translate.3to10 isn't the right thing on a phone line... in actual fact, the things that call translate.3to10 should know better than to do so on a phone line, but since we're masquerading as a 10Mb/s net due to some other bogosity this is the easiest place to fix it.") (FNS \\TRANSLATE.3TO10) (VARS (\\RS232CNETWORK.NSHOSTNUMBER \\MY.NSHOSTNUMBER)) (GLOBALVARS \\RS232CNETWORK.NSHOSTNUMBER \\DLRS232C.LOCAL.NDB) (* |;;| "because this one has some bugs fixed, and it must not reinitialize a running RS232 driver.") (FNS \\RS232C.EVENTFN) (* |;;| "because it has to use the \\LOCALNDBS if you route packets to net# 0, not the \"known\" NDBs.") (FNS \\ROUTE.XIP) (* |;;| "the IOCB status dataLost (5) was missing") (CONSTANTS * |Dove.RS232MiscConstants|) (FNS \\DVRS232C.PARSE.STATUS) (* |;;| "") (RECORDS RS232C.INIT) (VARS (RS232C.DEFAULT.INIT.INFO (|create| RS232C.INIT |using| RS232C.DEFAULT.INIT.INFO))) (* |;;| "") (RECORDS RS232CNETWORK.ENCAPSULATION) (CONSTANTS \\RS232CNETWORKENCAPSULATION.WORDS \\RS232CNETWORKTYPE.PUP \\RS232CNETWORKTYPE.XIP) (FNS \\RS232CNETWORKENCAPSULATE) (* |;;| "these are because they used RS232C.ENCAPSULATION, which changed") (RECORDS RS232C.ENCAPSULATION) (FNS \\DVRS232C.INPUT.INTERRUPT \\DLRS232C.INPUT.INTERRUPT \\DLRS232C.START.DRIVER \\DLRS232C.SEND.PACKET \\RS232C.FORCEOUTPUT \\RS232C.GETNEXTBUFFER \\RS232C.TRACE.PACKET))) (DECLARE\: FIRST DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) DLRS232C) ) (DECLARE\: FIRST EVAL@LOAD DONTCOPY (FILESLOAD (LOADCOMP) LLETHER 10MBDRIVER LLNS PUP (SOURCE) DLRS232C) ) (* |;;| "Addition to DOVERS232C Opie definitions") (DECLARE\: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE\: EVAL@COMPILE (BLOCKRECORD |Dove.i8274.WR7| ((|mustBe7EinSDLC| BYTE))) ) (RPAQQ |Dove.i8274.WR7.Constants| ((|sdlcFlag| 126))) (DECLARE\: EVAL@COMPILE (RPAQQ |sdlcFlag| 126) (CONSTANTS (|sdlcFlag| 126)) ) (* "END EXPORTED DEFINITIONS") ) (* |;;| "This should have been in the DLRS232C file") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\DLRS232C.OUTPUT.TIMEOUT) ) (* |;;| "a hint that the code should install itself as the network handler...") (RPAQ? *RS232C-NETWORK* T) (RPAQ? *RS232C-NETWORK-DIALING-TIMEOUT* 30) (RPAQ? *RS232C-NETWORK-AUTODIAL*) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *RS232C-NETWORK* *RS232C-NETWORK-DIALING-TIMEOUT* *RS232C-NETWORK-AUTODIAL*) ) (DEFINEQ (\\DVRS232C.SET.PARAMETERS (LAMBDA (PARAMETERLIST) (* \; "Edited 24-Aug-88 16:46 by Briggs") (* |;;| "Set the RS232 line parameters for the 1186.") (* |;;;| "PARAMETERLIST is in association list format. This function sets the parameters of the IOP accordingly") (DECLARE (GLOBALVARS \\DLRS232C.OUTPUT.TIMEOUT)) (COND (PARAMETERLIST (|bind| NOTFOUND (|rsWorkListImage| _ (|\\DoveIO.ByteSwap| (|fetch| (|Dove.RS232DCB| |rsWorkList|) |of| |\\DoveRS232C.DCBPointer|))) (|rsCommandWorkListImage| _ (|\\DoveIO.ByteSwap| (|fetch| (|Dove.RS232DCB| |rsCommandWorkList|) |of| |\\DoveRS232C.DCBPointer|))) MAJORFLG COMMANDWORK PROP VAL BAUDRATE |for| PROP.VAL |in| PARAMETERLIST |do| ((SETQ PROP (CAR PROP.VAL)) (SETQ VAL (CDR PROP.VAL)) (SELECTQ PROP (FRAME.TIMEOUT (COND ((<= 0 VAL 255) (* \; "Make sure we got a legit value.")) (T (\\ILLEGAL.ARG VAL))) (COND ((NEQ VAL (|\\DoveIO.ByteSwap| (|fetch| (|Dove.RS232DCB| |rsFrameTimeoutValue|) |of| |\\DoveRS232C.DCBPointer|))) (|replace| (|Dove.RS232DCB| |rsFrameTimeoutValue|) |of| |\\DoveRS232C.DCBPointer| |with| (|\\DoveIO.ByteSwap| (FIX (TIMES 10 VAL))))))) (CORRESPONDENT (|replace| (|Dove.RS232DCB| |rsTTYHost|) |of| |\\DoveRS232C.DCBPointer| |with| (COND ((EQ VAL RS232C.CP.TTYHOST) |\\DoveIO.ByteTRUE|) (T |\\DoveIO.ByteFALSE|)))) (SYNCH.CHAR (* \; "Not supported on Dove") NIL) ((STOP.BITS |NoOfStopBits|) (COND ((<= 0 VAL 2) (* \; "Make sure we got a legit value.")) (T (\\ILLEGAL.ARG VAL))) (|replace| (RS232C.INIT |NoOfStopBits|) |of| RS232C.DEFAULT.INIT.INFO |with| VAL) (COND ((NEQ (|fetch| (|Dove.i8274.WR4| |stopBits|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) (SELECTC VAL (1 |oneStopBit|) (1.5 |oneAndHalfStopBit|) (2 |twoStopBits|) (COND ((FEQP VAL 1.5) |oneAndHalfStopBit|) (T (\\ILLEGAL.ARG VAL))))) (SETQ MAJORFLG T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsWorkWR4|)) (|replace| (|Dove.i8274.WR4| |stopBits|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| (SELECTC VAL (1 |oneStopBit|) (1.5 |oneAndHalfStopBit|) (2 |twoStopBits|) (COND ((FEQP VAL 1.5) |oneAndHalfStopBit|) (T (\\ILLEGAL.ARG VAL)))))))) ((PARITY |Parity|) (|replace| (RS232C.INIT |Parity|) |of| RS232C.DEFAULT.INIT.INFO |with| VAL) (COND ((NEQ VAL (COND ((NOT (|fetch| (|Dove.i8274.WR4| |enableParity|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|)))) (QUOTE NONE)) ((EQ (|fetch| (|Dove.i8274.WR4| |parityOddOrEven|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) |parityOdd|) (QUOTE ODD)) ((EQ (|fetch| (|Dove.i8274.WR4| |parityOddOrEven|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) |parityEven|) (QUOTE EVEN)))) (SETQ MAJORFLG T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsWorkWR4|)) (COND ((EQ VAL (QUOTE NONE)) (|replace| (|Dove.i8274.WR4| |enableParity|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| NIL)) (T (|replace| (|Dove.i8274.WR4| |enableParity|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| T) (|replace| (|Dove.i8274.WR4| |parityOddOrEven|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| (SELECTQ VAL (EVEN |parityEven|) (ODD |parityOdd|) (\\ILLEGAL.ARG VAL)))))))) ((CHAR.LENGTH |BitsPerSerialChar|) (COND ((<= 5 VAL 8) (* \; "Make sure we got a legit value.")) (T (\\ILLEGAL.ARG VAL))) (|replace| (RS232C.INIT |BitsPerSerialChar|) |of| RS232C.DEFAULT.INIT.INFO |with| VAL) (COND ((NEQ VAL (|fetch| (|Dove.i8274.WR5| |txCharLength|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|)))) (SETQ MAJORFLG T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| (LOGOR |rsWorkWR3| |rsWorkWR5|))) (* |;;| "Set the bits in the UART register:") (* |;;| " 8-bit chars 1 1") (* |;;| " 7-bit chars 0 1") (* |;;| " 6-bit chars 1 0") (* |;;| " 5-bit chars 0 0") (|replace| (|Dove.i8274.WR5| |txCharLength|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| (SELECTQ VAL (8 3) (7 1) (6 2) (5 0) (\\ILLEGAL.ARG VAL))) (|replace| (|Dove.i8274.WR3| |rxCharLength|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR3ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| (SELECTQ VAL (8 3) (7 1) (6 2) (5 0) (\\ILLEGAL.ARG VAL)))))) ((LINE.SPEED |BaudRate|) (LET ((NV (CDR (SASSOC VAL \\DVRS232C.BAUD.RATES)))) (COND (NV (|replace| (RS232C.INIT |BaudRate|) |of| RS232C.DEFAULT.INIT.INFO |with| VAL) (SETQ \\DLRS232C.OUTPUT.TIMEOUT (\\RS232C.PACKET.TIMEOUT VAL)) (COND ((AND (SETQ VAL NV) (NEQ VAL (|\\DoveIO.ByteSwap| (|fetch| (|Dove.RS232DCB| |rsBaudRateChA|) |of| |\\DoveRS232C.DCBPointer|)))) (SETQ MAJORFLG T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsNewBaudRate|)) (|replace| (|Dove.RS232DCB| |rsBaudRateChA|) |of| |\\DoveRS232C.DCBPointer| |with| (|\\DoveIO.ByteSwap| VAL)))))))) ((FLOW.CONTROL |FlowControl|) (SETQ MAJORFLG T) (|replace| (RS232C.INIT |FlowControl|) |of| RS232C.DEFAULT.INIT.INFO |with| VAL) (COND ((OR (LISTP VAL) (AND (OR (STRING.EQUAL VAL "xonxoff") (STRING.EQUAL VAL "xon-xoff") (STRING.EQUAL VAL "xon/xoff")) (SETQ VAL (CONSTANT (|create| RS232C.XONXOFF FLAG _ 1 XON.CHAR _ (CHARCODE ^Q) XOFF.CHAR _ (CHARCODE ^S)))))) (|replace| (|Dove.RS232FlowControl| |type|) |of| (|fetch| (|Dove.RS232DCB| |rs232FlowControl|) |of| |\\DoveRS232C.DCBPointer|) |with| (COND ((ZEROP (|fetch| (RS232C.XONXOFF FLAG) |of| VAL)) |noFlowControl|) (T |XOnXOffFlowControl|))) (|replace| (|Dove.RS232FlowControl| XO\n) |of| (|fetch| (|Dove.RS232DCB| |rs232FlowControl|) |of| |\\DoveRS232C.DCBPointer|) |with| (|\\DoveIO.ByteSwap| (OR (|fetch| (RS232C.XONXOFF XON.CHAR) |of| VAL) 0))) (|replace| (|Dove.RS232FlowControl| |XOff|) |of| (|fetch| (|Dove.RS232DCB| |rs232FlowControl|) |of| |\\DoveRS232C.DCBPointer|) |with| (|\\DoveIO.ByteSwap| (OR (|fetch| (RS232C.XONXOFF XOFF.CHAR) |of| VAL) 0)))) (T (* \; "No flow control.") (|replace| (|Dove.RS232FlowControl| |type|) |of| (|fetch| (|Dove.RS232DCB| |rs232FlowControl|) |of| |\\DoveRS232C.DCBPointer|) |with| |noFlowControl|)))) (LINE.TYPE (LET ((|WR1Base| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR1ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) (|WR3Base| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR3ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) (|WR4Base| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR4ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) (|WR5Base| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|))) (|WR7Base| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR7ofi8274|) |of| |\\DoveRS232C.DCBPointer|)))) (SELECTC VAL (RS232C.LT.ASYNCH (|replace| (RS232C.INIT |LineType|) |of| RS232C.DEFAULT.INIT.INFO |with| (QUOTE ASYNCH)) (|replace| (|Dove.RS232DCB| |rs232Mode|) |of| |\\DoveRS232C.DCBPointer| |with| |asynchMode|) (|replace| (|Dove.i8274.WR1| |extInterruptEnable|) |of| |WR1Base| |with| NIL) (|replace| (|Dove.i8274.WR3| |enterHuntMode|) |of| |WR3Base| |with| NIL) (|replace| (|Dove.i8274.WR3| |rxCRCenable|) |of| |WR3Base| |with| NIL) (|replace| (|Dove.i8274.WR3| |addrSearchMode|) |of| |WR3Base| |with| NIL) (|replace| (|Dove.i8274.WR3| |syncCharLoadInhibit|) |of| |WR3Base| |with| T) (|replace| (|Dove.i8274.WR4| |clockRate|) |of| |WR4Base| |with| |x16clk|) (|replace| (|Dove.i8274.WR5| |txCRCenable|) |of| |WR5Base| |with| NIL) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| (LOGOR |rsWorkWR1| |rsWorkWR3| |rsWorkWR4| |rsWorkWR5| |rsChangeMode|))) (SETQ MAJORFLG T)) (RS232C.LT.BIT.SYNCH (|replace| (RS232C.INIT |LineType|) |of| RS232C.DEFAULT.INIT.INFO |with| (QUOTE SYNCH)) (|replace| (|Dove.RS232DCB| |rs232Mode|) |of| |\\DoveRS232C.DCBPointer| |with| |synchMode|) (|replace| (|Dove.i8274.WR1| |extInterruptEnable|) |of| |WR1Base| |with| T) (|replace| (|Dove.i8274.WR3| |enterHuntMode|) |of| |WR3Base| |with| T) (|replace| (|Dove.i8274.WR3| |rxCRCenable|) |of| |WR3Base| |with| T) (|replace| (|Dove.i8274.WR3| |addrSearchMode|) |of| |WR3Base| |with| NIL) (|replace| (|Dove.i8274.WR3| |syncCharLoadInhibit|) |of| |WR3Base| |with| NIL) (|replace| (|Dove.i8274.WR4| |clockRate|) |of| |WR4Base| |with| |x1clk|) (|replace| (|Dove.i8274.WR4| |synchCharControl|) |of| |WR4Base| |with| |SdlcHdlc|) (|replace| (|Dove.i8274.WR4| |stopBits|) |of| |WR4Base| |with| |enableSyncModes|) (|replace| (|Dove.i8274.WR5| |txCRCenable|) |of| |WR5Base| |with| T) (|replace| (|Dove.i8274.WR5| |modeSDLCOrCRC16|) |of| |WR5Base| |with| SDLC) (|replace| (|Dove.i8274.WR7| |mustBe7EinSDLC|) |of| |WR7Base| |with| |sdlcFlag|) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| (LOGOR |rsWorkWR1| |rsWorkWR3| |rsWorkWR4| |rsWorkWR5| |rsWorkWR7| |rsChangeMode|))) (SETQ MAJORFLG T)) (ERROR "Illegal line type" VAL)))) (RESET.RING.HEARD (|replace| (|Dove.RSLatchedStatus| |ringHeard|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsLatchedStatus|) |of| |\\DoveRS232C.DCBPointer|)) |with| NIL)) (RESET.BREAK.DETECTED (|replace| (|Dove.RSLatchedStatus| |breakDetected|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsLatchedStatus|) |of| |\\DoveRS232C.DCBPointer|)) |with| NIL)) (RESET.DATA.LOST (|replace| (|Dove.RSLatchedStatus| |dataLost|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsLatchedStatus|) |of| |\\DoveRS232C.DCBPointer|)) |with| NIL)) ((REQUEST.TO.SEND RTS) (SETQ COMMANDWORK T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsWorkWR5|)) (COND ((|replace| (|Dove.i8274.WR5| |rts|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| VAL) (SETQ |rsCommandWorkListImage| (BITSET |rsCommandWorkListImage| |rtsCommand|))) (T (SETQ |rsCommandWorkListImage| (BITCLEAR |rsCommandWorkListImage| |rtsCommand|))))) ((DATA.TERMINAL.READY DTR) (SETQ COMMANDWORK T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsWorkWR5|)) (COND ((|replace| (|Dove.i8274.WR5| |dtr|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| VAL) (SETQ |rsCommandWorkListImage| (BITSET |rsCommandWorkListImage| |dtrCommand|))) (T (SETQ |rsCommandWorkListImage| (BITCLEAR |rsCommandWorkListImage| |dtrCommand|))))) (|ModemControl| (|for| SIGNAL |in| VAL |do| (SELECTQ SIGNAL (RTS (SETQ COMMANDWORK T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsWorkWR5|)) (COND ((|replace| (|Dove.i8274.WR5| |rts|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| VAL) (SETQ |rsCommandWorkListImage| (BITSET |rsCommandWorkListImage| |rtsCommand|))) (T (SETQ |rsCommandWorkListImage| (BITCLEAR |rsCommandWorkListImage| |rtsCommand|))))) (DTR (SETQ COMMANDWORK T) (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |rsWorkWR5|)) (COND ((|replace| (|Dove.i8274.WR5| |dtr|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsWR5ofi8274|) |of| |\\DoveRS232C.DCBPointer|)) |with| VAL) (SETQ |rsCommandWorkListImage| (BITSET |rsCommandWorkListImage| |dtrCommand|))) (T (SETQ |rsCommandWorkListImage| (BITCLEAR |rsCommandWorkListImage| |dtrCommand|))))) (SETQ NOTFOUND T)))) (SETQ NOTFOUND T))) |finally| (COND (COMMANDWORK (|replace| (|Dove.RS232DCB| |rsCommandWorkList|) |of| |\\DoveRS232C.DCBPointer| |with| (|\\DoveIO.ByteSwap| |rsCommandWorkListImage|)) (SETQ MAJORFLG T))) (COND ((NOT MAJORFLG) (RETURN (NOT NOTFOUND))) (T (SETQ |rsWorkListImage| (BITSET |rsWorkListImage| |workFori8274|)) (|replace| (|Dove.RS232DCB| |rsWorkList|) |of| |\\DoveRS232C.DCBPointer| |with| (|\\DoveIO.ByteSwap| |rsWorkListImage|)) (|\\DoveIO.NotifyIOP| (|fetch| (|Dove.RS232FCB| |rs232WorkMask|) |of| |\\DoveRS232C.FCBPointer|)) (|repeatwhile| (BITTEST (|\\DoveIO.ByteSwap| (|fetch| (|Dove.RS232DCB| |rsWorkList|) |of| |\\DoveRS232C.DCBPointer|)) |workFori8274|) |do| (BLOCK)) (RETURN (NOT NOTFOUND)))))))) ) (\\DVRS232C.INIT (LAMBDA (|BaudRate| |BitsPerSerialChar| |Parity| |NoOfStopBits| |FlowControl| |LineType|) (* \; "Edited 28-Sep-88 23:32 by briggs") (* |;;;| "Initialize the IOP") (SETQ |\\DoveRS232C.FCBPointer| (|\\DoveIO.GetHandlerIORegionPtr| |DoveIO.rs232Handler|)) (SETQ |\\DoveRS232C.DCBPointer| (\\ADDBASE |\\DoveRS232C.FCBPointer| (CONSTANT (MESASIZE |Dove.RS232FCB|)))) (\\DVRS232C.SHUTDOWN) (* |;;| "Changes 20-Jan-87 by JDS:") (* |;;| " FRAME.TIMEOUT from 5 to 32Q, to match Mesa") (* |;;| " DATA.TERMINAL.READY to NIL to match Mesa ") (\\DLRS232C.CREATE.NDB) (SELECTQ |LineType| ((ASYNCH ASYNC NIL) (\\DVRS232C.SET.PARAMETERS (BQUOTE ((FRAME.TIMEOUT . 5) (CORRESPONDENT \,@ RS232C.CP.TTYHOST) (RESET.RING.HEARD . T) (RESET.BREAK.DETECTED . T) (RESET.DATA.LOST . T) (REQUEST.TO.SEND . T) (DATA.TERMINAL.READY) (LINE.TYPE \,@ RS232C.LT.ASYNCH) (|NoOfStopBits| \,@ |NoOfStopBits|) (|Parity| \,@ |Parity|) (|BitsPerSerialChar| \,@ |BitsPerSerialChar|) (|BaudRate| \,@ |BaudRate|) (|FlowControl| \,@ |FlowControl|)))) (\\DVRS232C.ISSUE.SHORT.COMMAND ON) (SETQ \\DLRS232C.OUTPUT.TIMEOUT (\\RS232C.PACKET.TIMEOUT |BaudRate|))) ((SYNC SYNCH) (\\DVRS232C.SET.PARAMETERS (BQUOTE ((FRAME.TIMEOUT . 0) (CORRESPONDENT \,@ RS232C.CP.NS.ELEMENT) (RESET.RING.HEARD . T) (RESET.BREAK.DETECTED . T) (RESET.DATA.LOST . T) (REQUEST.TO.SEND . T) (DATA.TERMINAL.READY) (LINE.TYPE \,@ RS232C.LT.BIT.SYNCH) (|Parity| \,@ |Parity|) (|BitsPerSerialChar| \,@ |BitsPerSerialChar|) (|BaudRate| \,@ |BaudRate|)))) (\\DVRS232C.ISSUE.SHORT.COMMAND ON) (SETQ \\DLRS232C.OUTPUT.TIMEOUT 0)) (\\ILLEGAL.ARG |LineType|)) (* |;;| "default init info has been updated by \\DVRS232C.SET.PARAMETERS; the FDEV create fn will create the FDEV if it does not exist, and insert this into the FDEV regardless .") (\\RS232C.CREATE.FDEV RS232C.DEFAULT.INIT.INFO) (SETQ \\RS232C.READY T) (SETQ \\RS232FLG T)) ) (\\DLRS232C.INIT (LAMBDA (|BaudRate| |BitsPerSerialChar| |Parity| |NoOfStopBits| |FlowControl|) (* \; "Edited 13-Jul-88 19:20 by Briggs") (* |;;;| "Initialize the IOP") (* |;;| "let's catch the case when the user said some odd combination of XOnXoff capitalization/hyphenation.") (|if| (OR (STRING.EQUAL |FlowControl| "xonxoff") (STRING.EQUAL |FlowControl| "xon-xoff") (STRING.EQUAL |FlowControl| "xon/xoff")) |then| (SETQ |FlowControl| (QUOTE (1 17 19)))) (COND ((NOT (|fetch| (DLRS232C.HDW.CONF RS232C.ABSENT) |of| \\IOPAGE)) (\\DLRS232C.SHUTDOWN) (COND ((\\RS232C.ISSUE.SHORT.COMMAND ON) (SETQ \\DLRS232C.PARAMETER.CSB (LOCF (|fetch| (IOPAGE DLRS232CPARAMETERCSBLO.11) |of| \\IOPAGE))) (|replace| (DLRS232C.PARAMETER.CSB FRAME.TIMEOUT) |of| \\DLRS232C.PARAMETER.CSB |with| 5) (|replace| (DLRS232C.PARAMETER.CSB CORRESPONDENT) |of| \\DLRS232C.PARAMETER.CSB |with| RS232C.CP.TTYHOST) (|replace| (DLRS232C.PARAMETER.CSB SYNCH.CHAR) |of| \\DLRS232C.PARAMETER.CSB |with| 0) (|replace| (DLRS232C.PARAMETER.CSB RESET.RING.HEARD) |of| \\DLRS232C.PARAMETER.CSB |with| T) (|replace| (DLRS232C.PARAMETER.CSB RESET.BREAK.DETECTED) |of| \\DLRS232C.PARAMETER.CSB |with| T) (|replace| (DLRS232C.PARAMETER.CSB RESET.DATA.LOST) |of| \\DLRS232C.PARAMETER.CSB |with| T) (|replace| (DLRS232C.PARAMETER.CSB REQUEST.TO.SEND) |of| \\DLRS232C.PARAMETER.CSB |with| T) (|replace| (DLRS232C.PARAMETER.CSB DATA.TERMINAL.READY) |of| \\DLRS232C.PARAMETER.CSB |with| T) (|replace| (DLRS232C.PARAMETER.CSB STOP.BITS) |of| \\DLRS232C.PARAMETER.CSB |with| (SELECTC |NoOfStopBits| (1 0) (2 1) (ERROR "ILLEGAL NUMBER OF STOP BITS (MUST BE 1 OR 2)" |NoOfStopBits|))) (|replace| (DLRS232C.PARAMETER.CSB LINE.TYPE) |of| \\DLRS232C.PARAMETER.CSB |with| RS232C.LT.ASYNCH) (|replace| (DLRS232C.PARAMETER.CSB PARITY) |of| \\DLRS232C.PARAMETER.CSB |with| (SELECTQ |Parity| (ODD 1) (EVEN 2) 0)) (|replace| (DLRS232C.PARAMETER.CSB CHAR.LENGTH) |of| \\DLRS232C.PARAMETER.CSB |with| (IDIFFERENCE |BitsPerSerialChar| 5)) (|replace| (DLRS232C.PARAMETER.CSB SYNCH.COUNT) |of| \\DLRS232C.PARAMETER.CSB |with| 0) (|replace| (DLRS232C.PARAMETER.CSB LINE.SPEED) |of| \\DLRS232C.PARAMETER.CSB |with| (OR (CDR (SASSOC |BaudRate| \\DLRS232C.BAUD.RATES)) (ERROR "ILLEGAL BAUD RATE" |BaudRate|))) (SETQ \\DLRS232C.OUTPUT.TIMEOUT (\\RS232C.PACKET.TIMEOUT |BaudRate|)) (|replace| (DLRS232C.PARAMETER.CSB INTERRUPT.MASK) |of| \\DLRS232C.PARAMETER.CSB |with| 0) (COND ((LISTP |FlowControl|) (|replace| (DLRS232C.PARAMETER.CSB FLOWCONTROL.ON) |of| \\DLRS232C.PARAMETER.CSB |with| (CAR |FlowControl|)) (|replace| (DLRS232C.PARAMETER.CSB FLOWCONTROL.XON.CHAR) |of| \\DLRS232C.PARAMETER.CSB |with| (OR (CADR |FlowControl|) 0)) (|replace| (DLRS232C.PARAMETER.CSB FLOWCONTROL.XOFF.CHAR) |of| \\DLRS232C.PARAMETER.CSB |with| (OR (CADDR |FlowControl|) 0))) (T (|replace| (DLRS232C.PARAMETER.CSB FLOWCONTROL.ON) |of| \\DLRS232C.PARAMETER.CSB |with| 0))) (\\DLRS232C.ISSUE.SHORT.COMMAND MAJOR.SET.PARAMETERS) (COND ((|fetch| (DLRS232C.PARAMETER.OUTCOME SUCCESS) |of| \\IOPAGE) (\\DLRS232C.CREATE.NDB) (\\RS232C.CREATE.FDEV (SETQ RS232C.DEFAULT.INIT.INFO (|create| RS232C.INIT |BaudRate| _ |BaudRate| |BitsPerSerialChar| _ |BitsPerSerialChar| |Parity| _ |Parity| |NoOfStopBits| _ |NoOfStopBits| |FlowControl| _ |FlowControl| |LineType| _ (QUOTE ASYNCH)))) (SETQ \\RS232C.READY T) (SETQ \\RS232FLG T)) (T (HELP "Error setting parameters for RS232C")))) (T (HELP "Unable to activate RS232C interface")))) (T (HELP "There is no RS232C hardware in your machine!")))) ) (RS232C.INIT (LAMBDA (BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL LINETYPE) (* \; "Edited 8-Jul-88 16:37 by Briggs") (* \; "User interface to low level initialization") (SELECTC \\MACHINETYPE (\\DANDELION (COND ((NULL BAUDRATE) (APPLY (FUNCTION \\DLRS232C.INIT) RS232C.DEFAULT.INIT.INFO)) ((ZEROP BAUDRATE) (ERROR "Invalid baudrate")) ((LISTP BAUDRATE) (APPLY (FUNCTION \\DLRS232C.INIT) BAUDRATE)) (T (\\DLRS232C.INIT BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL)))) (\\DAYBREAK (COND ((NULL BAUDRATE) (APPLY (FUNCTION \\DVRS232C.INIT) RS232C.DEFAULT.INIT.INFO)) ((ZEROP BAUDRATE) (ERROR "Invalid baudrate")) ((LISTP BAUDRATE) (APPLY (FUNCTION \\DVRS232C.INIT) BAUDRATE)) (T (\\DVRS232C.INIT BAUDRATE BITSPERCHAR PARITY STOPBITS FLOWCONTROL LINETYPE)))) (ERROR "RS232 is currently not supported on " (MACHINETYPE)))) ) (\\RS232C.HANDLE.PACKET (LAMBDA (PACKET) (* \; "Edited 28-Sep-88 00:23 by briggs") (* * |Handle| \a |received| |packet| |from| |the| RS232 |device|) (COND ((|type?| FDEV \\RS232C.FDEV) (LET* ((INSTREAM (|fetch| (RS232C.DEVICEINFO INSTREAM) |of| (|fetch| (FDEV DEVICEINFO) |of| \\RS232C.FDEV))) MAX.BUFFERS PACKET.QUEUE NDB) (COND ((AND (|type?| STREAM INSTREAM) (|type?| SYSQUEUE (SETQ PACKET.QUEUE (|fetch| (RS232C.STREAM PACKET.QUEUE) |of| INSTREAM))) (EQ (|fetch| (STREAM ACCESS) |of| INSTREAM) (QUOTE INPUT)) (NEQ 0 (|fetch| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| PACKET))) (\\ENQUEUE PACKET.QUEUE PACKET) (|add| (|fetch| (RS232C.STREAM QUEUE.LENGTH) |of| INSTREAM) 1) (NOTIFY.EVENT (|fetch| (RS232C.STREAM EVENT) |of| INSTREAM))) ((AND (EQ \\MACHINETYPE \\DAYBREAK) *RS232C-NETWORK* (EQ (|fetch| (|Dove.RS232DCB| |rs232Mode|) |of| |\\DoveRS232C.DCBPointer|) |synchMode|) (EQ (|fetch| RS232CNETWORK.STATUS |of| PACKET) T)) (* |;;| "") (SELECTC (|ffetch| RS232CNETWORK.TYPE |of| PACKET) (\\RS232CNETWORKTYPE.XIP (|freplace| EPTYPE |of| PACKET |with| \\10MBTYPE.XIP) (\\HANDLE.RAW.PACKET PACKET)) (\\RS232CNETWORKTYPE.PUP (SETQ NDB (|ffetch| EPNETWORK |of| PACKET)) (COND ((NULL (|ffetch| NDBTRANSLATIONS |of| NDB)) (|freplace| NDBTRANSLATIONS |of| NDB |with| (LIST (CONS (|ffetch| (PUP PUPSOURCENET) |of| PACKET) (|ffetch| (RS232CNETWORK.ENCAPSULATION RS232CNETWORK.SOURCEHOST) |of| PACKET)))))) (|freplace| EPTYPE |of| PACKET |with| \\10MBTYPE.PUP) (\\HANDLE.RAW.PACKET PACKET)) (\\RELEASE.ETHERPACKET PACKET))) (T (\\RELEASE.ETHERPACKET PACKET))))) (T (\\RELEASE.ETHERPACKET PACKET))) (|freplace| EPUSERFIELD |of| PACKET |with| NIL)) ) (\\RS232CNETWORKINIT (LAMBDA (EVENT) (* \; "Edited 25-Aug-88 10:59 by Briggs") (* |;;| "ensure that RS232 is ready to run (bleah!) -- this code had better not care about being run twice! (it doesn't at the moment)") (* |;;| "The reason we do this is that we are running *before* the rs232 event fn normally gets run, and we require the initialization of the IOCB pages. At this point \\RS232FLG will most likely be NIL (at least on startup it is) so the only thing that will happen is the IOCB page allocation") (\\RS232C.EVENTFN \\RS232C.FDEV EVENT) (* |;;| "RS232 may be shutdown at this point, start it with the current parameters") (RS232C.INIT) (* |;;| "the Codex 2260 modems take a few seconds to actually hang up after DTR drops, we must wait for them to lower DSR, and then a couple more seconds before they are ready to dial again.") (COND ((RS232MODEMSTATUSP (QUOTE DSR)) (|while| (RS232MODEMSTATUSP (QUOTE DSR)) |do| (BLOCK) |finally| (DISMISS 2000)))) (COND ((OR (FMEMB EVENT (QUOTE (RESTART NIL))) *RS232C-NETWORK-AUTODIAL*) (* |;;| "DTR raised should cause a properly configured modem to dial") (|printout| PROMPTWINDOW T "[Raising DTR]") (RS232C.SET.PARAMETERS (QUOTE ((DATA.TERMINAL.READY . T)))) (|until| (RS232MODEMSTATUSP (QUOTE DSR)) |forDuration| *RS232C-NETWORK-DIALING-TIMEOUT* |timerUnits| (QUOTE SECONDS) |do| (BLOCK) |finally| (|if| (NOT (RS232MODEMSTATUSP (QUOTE DSR))) |then| (|printout| PROMPTWINDOW T "[Data set not ready after " *RS232C-NETWORK-DIALING-TIMEOUT* " seconds]") |else| (|printout| PROMPTWINDOW T "[Data set ready]")))))) ) (\\DLRS232C.CREATE.NDB (LAMBDA NIL (* \; "Edited 24-Aug-88 18:21 by Briggs") (* * DLRS232C |face| |entry| |for| |driver| |initialization.| |Note| |that| |the| |driver| |resembles| |closely| |the| 10MB |Ethernet| |driver.| |This| |will| |hopefully| |simplify| |our| |lives| |when| |we| |try| |to| |support| |Clusternet| |communications|) (COND (*RS232C-NETWORK* (SETQ \\DLRS232C.LOCAL.NDB (\\DLRS232C.START.DRIVER (|create| NDB NETTYPE _ 10 NDBPUPNET# _ 0 NDBNSNET# _ 0 NDBTASK# _ 0 NDBBROADCASTP _ (FUNCTION NILL) NDBPUPHOST# _ 0 NDBTRANSMITTER _ (FUNCTION \\DLRS232C.SEND.PACKET) NDBENCAPSULATOR _ (FUNCTION \\RS232CNETWORKENCAPSULATE) NDBCSB _ NIL NDBETHERFLUSHER _ (FUNCTION RS232C.SHUTDOWN) NDBCANHEARSELF _ NIL NDBIPNET# _ 0 NDBIPHOST# _ 0 NDBPUPTYPE _ \\EPT.PUP))) (* |;;| "if there is a local NDB already link the rs232 one to it.") (COND (\\LOCALNDBS (|replace| NDBNEXT |of| \\DLRS232C.LOCAL.NDB |with| \\LOCALNDBS))) (* |;;| "Set rs232 as the primary network connection") (SETQ \\LOCALNDBS \\DLRS232C.LOCAL.NDB)) (T (SETQ \\DLRS232C.LOCAL.NDB (\\DLRS232C.START.DRIVER (|create| NDB NDBTRANSMITTER _ (FUNCTION \\DLRS232C.SEND.PACKET) NDBENCAPSULATOR _ (FUNCTION NILL) NDBBROADCASTP _ (FUNCTION NILL) NDBETHERFLUSHER _ (FUNCTION RS232C.SHUTDOWN) NDBCANHEARSELF _ NIL)))))) ) ) (* |;;| "because it needed to know to reinit the rs232c if that was the network interface...") (DEFINEQ (\\ETHEREVENTFN (LAMBDA (DEV EVENT) (* \; "Edited 24-Aug-88 18:21 by Briggs") (SELECTQ EVENT ((NIL AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM RESTART) (PROG (NDB TURNOFFNS TIMESET) (SETQ \\PUP.READY (SETQ \\NS.READY (SETQ \\IP.READY))) (\\SETETHERFLAGS) (\\SETLOCALNSNUMBERS) (\\FLUSHNDBS EVENT) (SETQ \\3MBLOCALNDB (COND (\\3MBFLG (SETQ \\LOCALNDBS (\\3MB.CREATENDB \\3MBFLG))))) (SETQ \\10MBLOCALNDB (COND (\\10MBFLG (SETQ NDB (\\10MB.CREATENDB \\10MBFLG)) (COND (\\LOCALNDBS (|replace| NDBNEXT |of| \\LOCALNDBS |with| NDB)) (T (SETQ \\LOCALNDBS NDB))) NDB))) (|for| (DB _ \\LOCALNDBS) |by| (|fetch| NDBNEXT |of| DB) |while| DB |do| (\\LOCKWORDS DB (|fetch| DTDSIZE |of| (\\GETDTD (NTYPX DB))))) (* |;;| "if the rs232 device is acting as the network connection it should be reinitialized before we attempt to start NS") (COND (*RS232C-NETWORK* (\\RS232CNETWORKINIT EVENT))) (COND ((OR \\NSFLG (SETQ TURNOFFNS \\10MBFLG)) (* |Start| NS |before| |Pup| |so| |that| |when| |on| 10 |we| |can| |find| |out| |our| |pup| |number,| |which| |is| |done| |via| NS |protocol|) (\\NSINIT EVENT) (SETQ TIMESET (\\NS.SETTIME)))) (\\STARTPUP EVENT) (OR TIMESET (AND (EQ \\PUP.READY T) (\\PUP.SETTIME)) (SELECTC \\MACHINETYPE (\\DANDELION (NEQ 0 (|fetch| DLTODVALID |of| \\IOPAGE))) (\\DAYBREAK (|\\DoveMisc.TODValid|)) (IGREATERP (IDATE) (CONSTANT (IDATE " 1-JAN-84 12:00")))) (|printout| PROMPTWINDOW T "[Time not set]")) (COND (TURNOFFNS (STOPNS))) (COND (\\GATEWAYFLG (\\INIT.GATEWAY))) T)) ((BEFOREMAKESYS BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM) (COND ((EQ EVENT (QUOTE BEFORESAVEVM)) (* |Save| |passwords| |in| |place| |outside| |vmem| |to| |avoid| |having| |to| |reenter| |them| |later|) (\\STASH.PASSWORDS)) (T (* N\o |need| |to| |flush| |this| |before| SAVEVM) (CLRHASH \\ETHERPORTS))) (CLRHASH LOGINPASSWORDS)) NIL)) ) ) (* |;;| "because it was closing too many sockets when it shouldn't have...") (DEFINEQ (TURN.OFF.ETHER (LAMBDA NIL (* \; "Edited 17-Oct-88 12:14 by Briggs") (BREAKCONNECTION T) (DEL.PROCESS (QUOTE \\PUPGATELISTENER)) (CLOSEPUPSOCKET (OPENPUPSOCKET \\PUPSOCKET.ROUTING T) T) (DEL.PROCESS (QUOTE \\NSGATELISTENER)) (CLOSENSOCKET (OPENNSOCKET |\\NS.WKS.RoutingInformation| T) T) (DEL.PROCESS (QUOTE \\IPLISTENER)) (DEL.PROCESS (QUOTE \\IPGATELISTENER)) (\\FLUSHNDBS (QUOTE RESTART))) ) ) (* |;;| "because it didn't check to see if it had an NDBIQ or NDBTQ before dequeuing...") (DEFINEQ (\\DVRS232C.SHUTDOWN (LAMBDA NIL (* \; "Edited 12-Jul-88 00:49 by Briggs") (* * |Disables| RS232C |if| |currently| |running|) (LET (PACKET) (COND (\\DLRS232C.LOCAL.NDB (SETQ \\RS232C.READY (SETQ \\RS232FLG NIL)) (DEL.PROCESS (|fetch| NDBWATCHER |of| \\DLRS232C.LOCAL.NDB)) (BLOCK) (\\DVRS232C.ABORT.QUEUE (|fetch| (|Dove.RS232FCB| |rsQueueRxChA|) |of| |\\DoveRS232C.FCBPointer|)) (\\RS232C.ISSUE.SHORT.COMMAND ABORT.INPUT) (\\DVRS232C.ABORT.QUEUE (|fetch| (|Dove.RS232FCB| |rsQueueTxChA|) |of| |\\DoveRS232C.FCBPointer|)) (\\RS232C.ISSUE.SHORT.COMMAND ABORT.OUTPUT) (\\RS232C.ISSUE.SHORT.COMMAND OFF) (|\\Dove.ClearQueueBlock| (|fetch| (|Dove.RS232FCB| |rsQueueTxChA|) |of| |\\DoveRS232C.FCBPointer|)) (|\\Dove.ClearQueueBlock| (|fetch| (|Dove.RS232FCB| |rsQueueRxChA|) |of| |\\DoveRS232C.FCBPointer|)) (AND (|fetch| NDBIQ |of| \\DLRS232C.LOCAL.NDB) (|while| (SETQ PACKET (\\DEQUEUE (|fetch| NDBIQ |of| \\DLRS232C.LOCAL.NDB))) |do| (\\TEMPUNLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE)) (\\RELEASE.ETHERPACKET PACKET))) (AND (|fetch| NDBTQ |of| \\DLRS232C.LOCAL.NDB) (|while| (SETQ PACKET (\\DEQUEUE (|fetch| NDBTQ |of| \\DLRS232C.LOCAL.NDB))) |do| (\\TEMPUNLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE)) (\\RELEASE.ETHERPACKET PACKET))))))) ) ) (* |;;| "because etherpackets are actually 2 pages, and we want to use it all if necessary (bytesperpage - etherheader + 8bytes from encapsulation which we put data into)" ) (RPAQQ \\DLRS232C.DEFAULT.PACKET.LENGTH 968) (RPAQQ \\RS232C.OUTPUT.PACKET.LENGTH 968) (* |;;| "because translate.3to10 isn't the right thing on a phone line... in actual fact, the things that call translate.3to10 should know better than to do so on a phone line, but since we're masquerading as a 10Mb/s net due to some other bogosity this is the easiest place to fix it." ) (DEFINEQ (\\TRANSLATE.3TO10 (LAMBDA (PUPHOSTNUMBER NDB) (* \; "Edited 11-Jul-88 17:12 by Briggs") (* |;;| "Translate from an PUPHOSTNUMBER to a NSHOSTNUMBER for the indicated network. If we don't have the translation, we initiate a probe for it and return NIL") (* |;;| "Bletch: if the NDB we got was the \\DLRS232C.LOCAL.NDB then we'll just return a bogus nshostnumber -- no one cares in this case.") (COND ((EQ NDB \\DLRS232C.LOCAL.NDB) \\RS232CNETWORK.NSHOSTNUMBER) ((CADR (ASSOC PUPHOSTNUMBER (|ffetch| NDBTRANSLATIONS |of| (\\DTEST NDB (QUOTE NDB)))))) ((PROG ((MYPUPHOSTNUMBER (|ffetch| NDBPUPHOST# |of| NDB)) PACKET) (COND ((EQ MYPUPHOSTNUMBER 0) (* \; "We don't know who we are yet") (RETURN))) (SETQ PACKET (\\ALLOCATE.ETHERPACKET)) (|replace| EPTYPE |of| PACKET |with| \\EPT.3TO10) (|freplace| TRANSOPERATION |of| PACKET |with| \\TRANS.OP.REQUEST) (|freplace| TRANSPUPHOST |of| PACKET |with| PUPHOSTNUMBER) (|freplace| TRANSSENDERNSHOST |of| PACKET |with| (\\LOCALNSHOSTNUMBER)) (|freplace| TRANSSENDERPUPHOST |of| PACKET |with| MYPUPHOSTNUMBER) (ENCAPSULATE.ETHERPACKET NDB PACKET BROADCASTNSHOSTNUMBER \\TRANS.DATALENGTH \\10MBTYPE.3TO10) (AND XIPTRACEFLG (\\MAYBEPRINTPACKET PACKET (QUOTE PUT))) (|freplace| EPREQUEUE |of| PACKET |with| (QUOTE FREE)) (TRANSMIT.ETHERPACKET NDB PACKET) (* \; "We didn't find out this time, but we will later on") (RETURN))))) ) ) (RPAQ \\RS232CNETWORK.NSHOSTNUMBER \\MY.NSHOSTNUMBER) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\RS232CNETWORK.NSHOSTNUMBER \\DLRS232C.LOCAL.NDB) ) (* |;;| "because this one has some bugs fixed, and it must not reinitialize a running RS232 driver.") (DEFINEQ (\\RS232C.EVENTFN (LAMBDA (DEVICE EVENT) (* \; "Edited 21-Oct-88 12:26 by Briggs") (SELECTQ EVENT ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) (COND ((AND \\DLRS232C.IOCB.PAGE \\DLRS232C.IOCB.ENDPAGE) (|bind| (BASE _ \\DLRS232C.IOCB.PAGE) DONE |until| DONE |do| (\\DONEWEPHEMERALPAGE BASE T) (COND ((NEQ BASE \\DLRS232C.IOCB.ENDPAGE) (SETQ BASE (\\ADDBASE BASE WORDSPERPAGE))) (T (SETQ DONE T)))))) (* |;;| "don't try to initialize rs232 if it is already running (from the \\ETHEREVENTFN when using the rs232 network interface.") (COND ((AND \\RS232FLG (NOT \\RS232C.READY) (SELECTC \\MACHINETYPE (\\DANDELION (NOT (|fetch| (DLRS232C.HDW.CONF RS232C.ABSENT) |of| \\IOPAGE))) (\\DAYBREAK T) NIL)) (RS232C.INIT (OR (AND \\RS232C.FDEV (|fetch| (RS232C.DEVICEINFO INIT) |of| (|fetch| (FDEV DEVICEINFO) |of| \\RS232C.FDEV))) RS232C.DEFAULT.INIT.INFO))))) NIL)) ) ) (* |;;| "because it has to use the \\LOCALNDBS if you route packets to net# 0, not the \"known\" NDBs.") (DEFINEQ (\\ROUTE.XIP (LAMBDA (XIP READONLY) (* \; "Edited 13-Oct-88 18:02 by Briggs") (* |;;| "Encapsulates XIP, choosing the right network and immediate destination host. Returns an NDB for the transmission. Unless READONLY is true, defaults source and destination nets if needed") (* |;;;| "modified to use \\LOCALNDBS instead of (OR known ndbs...)") (GLOBALRESOURCE \\ROUTEBOX.HOST (PROG ((NET (|fetch| XIPDESTNET |of| XIP)) PDH ROUTE NDB) (COND ((EQ 0 NET) (OR (SETQ NDB \\LOCALNDBS) (RETURN))) ((SETQ ROUTE (\\LOCATE.NSNET NET)) (SETQ NDB (|fetch| RTNDB |of| ROUTE))) (T (RETURN))) (SETQ PDH (COND ((AND ROUTE (NEQ (|fetch| RTHOPCOUNT |of| ROUTE) 0)) (|fetch| RTGATEWAY# |of| ROUTE)) ((EQ (|fetch| NETTYPE |of| NDB) 10) (LOADNSHOSTNUMBER (LOCF (|fetch| XIPDESTWORD1 |of| XIP)) \\ROUTEBOX.HOST) \\ROUTEBOX.HOST) ((EQNSHOSTNUMBER (|fetch| XIPDESTHOST |of| XIP) BROADCASTNSHOSTNUMBER) (* \; "On 3, broadcast goes to zero") 0) ((PROGN (LOADNSHOSTNUMBER (LOCF (|fetch| XIPDESTWORD1 |of| XIP)) \\ROUTEBOX.HOST) (\\TRANSLATE.10TO3 \\ROUTEBOX.HOST NDB))) (T (RETURN)))) (|replace| EPNETWORK |of| XIP |with| NDB) (ENCAPSULATE.ETHERPACKET NDB XIP PDH (|fetch| XIPLENGTH |of| XIP) \\EPT.XIP) (COND ((NOT READONLY) (COND ((EQ 0 NET) (|replace| XIPDESTNET |of| XIP |with| (|fetch| NDBNSNET# |of| NDB)))) (|replace| XIPSOURCENET |of| XIP |with| (|fetch| NDBNSNET# |of| NDB)))) (RETURN NDB)))) ) ) (* |;;| "the IOCB status dataLost (5) was missing") (RPAQQ |Dove.RS232MiscConstants| ((|noFlowControl| 0) (|XOnXOffFlowControl| 256) (|asynchMode| 0) (|synchMode| 1) (|IOCBpollRxOrTx| 0) (|IOCBcomplete| 1) (|IOCBaborted| 2) (|IOCBframeTimeout| 3) (|IOCBdisaster| 4) (|rsNoClient| 0) (|rsNormal| 1) (|rsDebugger| 2) (|latchRingHeard| 32) (|latchDataLost| 64) (|latchBreakDet| 128))) (DECLARE\: EVAL@COMPILE (RPAQQ |noFlowControl| 0) (RPAQQ |XOnXOffFlowControl| 256) (RPAQQ |asynchMode| 0) (RPAQQ |synchMode| 1) (RPAQQ |IOCBpollRxOrTx| 0) (RPAQQ |IOCBcomplete| 1) (RPAQQ |IOCBaborted| 2) (RPAQQ |IOCBframeTimeout| 3) (RPAQQ |IOCBdisaster| 4) (RPAQQ |rsNoClient| 0) (RPAQQ |rsNormal| 1) (RPAQQ |rsDebugger| 2) (RPAQQ |latchRingHeard| 32) (RPAQQ |latchDataLost| 64) (RPAQQ |latchBreakDet| 128) (CONSTANTS (|noFlowControl| 0) (|XOnXOffFlowControl| 256) (|asynchMode| 0) (|synchMode| 1) (|IOCBpollRxOrTx| 0) (|IOCBcomplete| 1) (|IOCBaborted| 2) (|IOCBframeTimeout| 3) (|IOCBdisaster| 4) (|rsNoClient| 0) (|rsNormal| 1) (|rsDebugger| 2) (|latchRingHeard| 32) (|latchDataLost| 64) (|latchBreakDet| 128)) ) (DEFINEQ (\\DVRS232C.PARSE.STATUS (LAMBDA (IOCB) (* \; "Edited 11-Jul-88 14:14 by Briggs") (LET ((|rsIOCBType| (|fetch| (|Dove.RS232IOCB| |rsIOCBType|) |of| IOCB))) (LET ((STATUS (SELECTC (|fetch| (|Dove.RS232IOCB| |currentOpStatus|) |of| IOCB) (|IOCBpollRxOrTx| (QUOTE |PollRxOrTx|)) (|IOCBaborted| (QUOTE |Aborted|)) (|IOCBdisaster| (QUOTE |Disaster|)) (|IOCBframeTimeout| (COND ((EQ |rsIOCBType| |rsIOCBTypeRx|) T) (T (QUOTE |FrameTimeout|)))) (|IOCBdataLost| (QUOTE |DataLost|)) (|IOCBcomplete| (COND ((EQ |rsIOCBType| |rsIOCBTypeTx|) T) (T (LET ((|rsIocbSB1Base| (LOCF (|fetch| (|Dove.RS232IOCB| |rsIocbStatusByte1|) |of| IOCB)))) (COND ((|fetch| (|Dove.RSLatchedStatus| |dataLost|) |of| (LOCF (|fetch| (|Dove.RS232DCB| |rsLatchedStatus|) |of| |\\DoveRS232C.DCBPointer|))) (QUOTE |DataLost|)) ((|fetch| (|Dove.i8274.RR1| |rxOverrunError|) |of| |rsIocbSB1Base|) (QUOTE |DataLost|)) ((|fetch| (|Dove.i8274.RR1| |parityError|) |of| |rsIocbSB1Base|) (QUOTE |ParityError|)) ((|fetch| (|Dove.i8274.RR1| |crcFramingError|) |of| |rsIocbSB1Base|) (COND ((EQ (|fetch| (|Dove.RS232DCB| |rs232Mode|) |of| |\\DoveRS232C.DCBPointer|) |asynchMode|) (QUOTE |asynchFramingError|)) ((|fetch| (|Dove.i8274.RR1| |endOfFrameSDLCMode|) |of| |rsIocbSB1Base|) (QUOTE |checksumError|)) (T T))) (T T)))))) (QUOTE |Disaster|)))) (COND ((AND (NEQ STATUS T) (NEQ STATUS (QUOTE |Aborted|)) STATUS) (COND ((OR (EQ \\RS232C.REPORT.STATUS T) (AND (EQ \\RS232C.REPORT.STATUS (QUOTE OUTPUT)) (EQ |rsIOCBType| |rsIOCBTypeTx|)) (AND (EQ \\RS232C.REPORT.STATUS (QUOTE INPUT)) (EQ |rsIOCBType| |rsIOCBTypeRx|))) (|printout| RS232C.ERROR.STREAM T "RS232 error: " (SELECTQ STATUS (|Aborted| "Operation aborted") (|Disaster| "Error during transmission, data lost") (|FrameTimeout| "transmission timeout") (|DataLost| "data lost") (|ParityError| "parity error") (|asynchFramingError| "transmission frame out of sync") (|checksumError| "checksum error") STATUS) T))))) STATUS))) ) ) (* |;;| "") (DECLARE\: EVAL@COMPILE (RECORD RS232C.INIT (|BaudRate| |BitsPerSerialChar| |Parity| |NoOfStopBits| |FlowControl| |LineType|)) ) (RPAQ RS232C.DEFAULT.INIT.INFO (|create| RS232C.INIT |using| RS232C.DEFAULT.INIT.INFO)) (* |;;| "") (DECLARE\: EVAL@COMPILE (ACCESSFNS RS232CNETWORK.ENCAPSULATION ((RS232ETHERBASE (LOCF (|fetch| (ETHERPACKET EPENCAPSULATION) |of| DATUM))) (RS232CNETWORK.STATUS (|fetch| (ETHERPACKET EPUSERFIELD) |of| DATUM) (|replace| (ETHERPACKET EPUSERFIELD) |of| DATUM |with| NEWVALUE))) (BLOCKRECORD RS232ETHERBASE ((RS232CNETWORK.LENGTH WORD) (* |;;| "Length of data in words") (NIL 3 WORD) (* |;;| "Padding to align sync packet data with EPBODY") (RS232CNETWORK.TYPE WORD) (* |;;| "phone encapsulation type") (RS232CNETWORK.SOURCEWORD1 3 WORD) (* |;;| "48 bit source host number") (RS232CNETWORK.DATA WORD)) (ACCESSFNS RS232CNETWORK.SOURCEWORD1 (RS232CNETWORK.SOURCEHOST (\\LOADNSHOSTNUMBER (LOCF DATUM)) (\\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)))) ) ) (DECLARE\: EVAL@COMPILE (RPAQQ \\RS232CNETWORKENCAPSULATION.WORDS 4) (RPAQQ \\RS232CNETWORKTYPE.PUP 64) (RPAQQ \\RS232CNETWORKTYPE.XIP 192) (CONSTANTS \\RS232CNETWORKENCAPSULATION.WORDS \\RS232CNETWORKTYPE.PUP \\RS232CNETWORKTYPE.XIP) ) (DEFINEQ (\\RS232CNETWORKENCAPSULATE (LAMBDA (NDB PACKET PDH LENGTH TYPE) (* \; "Edited 24-Aug-88 12:13 by briggs") (* |;;| "encapsulates packets for transmission over the rs232 synchronous link") (SELECTC TYPE (\\EPT.XIP (* |;;| "XIPs have a 1 word checksum which is not included in the length, so we must account for it here in the transmission length.") (|replace| RS232CNETWORK.LENGTH |of| PACKET |with| (IPLUS LENGTH (UNFOLD \\RS232CNETWORKENCAPSULATION.WORDS BYTESPERWORD) 2))) (\\EPT.PUP (* |;;| "PUPs have a 1 word checksum which is not included in the length, so we must account for it here in the transmission length.") (|replace| RS232CNETWORK.LENGTH |of| PACKET |with| (IPLUS LENGTH (UNFOLD \\RS232CNETWORKENCAPSULATION.WORDS BYTESPERWORD) 2))) (SHOULDNT "Bad type for encapsulation")) (|replace| RS232CNETWORK.TYPE |of| PACKET |with| (SELECTC TYPE (\\EPT.XIP \\RS232CNETWORKTYPE.XIP) (\\EPT.PUP \\RS232CNETWORKTYPE.PUP) (SHOULDNT "Bad type for encapsulation"))) (|replace| RS232CNETWORK.SOURCEHOST |of| PACKET |with| \\MY.NSHOSTNUMBER) PACKET) ) ) (* |;;| "these are because they used RS232C.ENCAPSULATION, which changed") (DECLARE\: EVAL@COMPILE (ACCESSFNS RS232C.ENCAPSULATION ((RS232CBASE (LOCF (|fetch| (ETHERPACKET EPENCAPSULATION) |of| DATUM))) (RS232C.STATUS (|fetch| (ETHERPACKET EPUSERFIELD) |of| DATUM) (|replace| (ETHERPACKET EPUSERFIELD) |of| DATUM |with| NEWVALUE))) (BLOCKRECORD RS232CBASE ((RS232C.LENGTH WORD) (* |Length| |of| |packet| |in| |words|) (NIL 3 WORD) (* |padding| |to| |align| |sync| |data| "body" |with| EPBODY) (RS232C.DATA WORD) (* |Data| |starts| |here|)) (ACCESSFNS RS232C.DATA ((RS232C.PACKET.BASE (LOCF DATUM))))) (TYPE? (|type?| ETHERPACKET DATUM))) ) (DEFINEQ (\\DVRS232C.INPUT.INTERRUPT (LAMBDA (NDB) (* \; "Edited 9-Jul-88 17:51 by Briggs") (* |;;| "Poll the IOP to see if there are any input requests completed") (LET ((PACKET (|fetch| SYSQUEUEHEAD |of| (|fetch| NDBIQ |of| NDB))) IOCB ACCEPTSTATUS) (COND ((AND PACKET (SETQ IOCB (|fetch| EPNETWORK |of| PACKET)) (NEQ (|fetch| (|Dove.RS232IOCB| |currentOpStatus|) |of| IOCB) |IOCBpollRxOrTx|)) (\\DEQUEUE (|fetch| NDBIQ |of| NDB)) (|replace| RS232C.STATUS |of| PACKET |with| (SETQ ACCEPTSTATUS (\\DVRS232C.PARSE.STATUS IOCB))) (\\DVRS232C.DEQUEUE.IOCB IOCB (|fetch| (|Dove.RS232FCB| |rsQueueRxChA|) |of| |\\DoveRS232C.FCBPointer|)) (PROG ((LENGTH (|\\DoveIO.ByteSwap| (|fetch| (|Dove.RS232IOCB| |rsTransferCountChA|) |of| IOCB)))) (|replace| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| PACKET |with| LENGTH) (|replace| EPNETWORK |of| PACKET |with| NDB) (COND ((IGREATERP LENGTH (CONSTANT (UNFOLD \\MIN2PAGEBUFLENGTH BYTESPERWORD))) (* |;;| "The DLion ether code doesn't dirty the pages of an etherpacket. There are hints in the Mesa RS232C face that the IOP doesn't dirty the pages of an RS232C packet either. Hence, we dirty the second page of the packet if it's long enough to warrent it") (\\PUTBASE PACKET (SUB1 (ITIMES WORDSPERPAGE 2)) 0))) (COND (\\RS232FLG (\\ENQUEUE \\DLRS232C.RAW.PACKET.QUEUE PACKET))) (\\TEMPUNLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE))) (* * I\f RS232 |is| |still| |alive,| |queue| |up| |another| |packet| |for| |the| |receiver|) (COND (\\RS232FLG (SETQ PACKET (\\DLRS232C.ALLOCATE.PACKET)) (\\TEMPLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE)) (|replace| EPNETWORK |of| PACKET |with| IOCB) (\\DLRS232C.QUEUE.INPUT.IOCB IOCB (|fetch| RS232C.PACKET.BASE |of| PACKET) \\DLRS232C.DEFAULT.PACKET.LENGTH) (\\ENQUEUE (|fetch| NDBIQ |of| NDB) PACKET))))) ACCEPTSTATUS)) ) (\\DLRS232C.INPUT.INTERRUPT (LAMBDA (NDB) (* |ejs:| " 7-Sep-85 22:01") (* * |Poll| |the| IOP |to| |see| |if| |there| |are| |any| |input| |requests| |completed|) (LET ((PACKET (|fetch| SYSQUEUEHEAD |of| (|fetch| NDBIQ |of| NDB))) IOCB NEXTIOCB ACCEPTSTATUS) (|if| (AND PACKET \\DLRS232C.ACTIVE.GET (NOT (|fetch| (DLRS232C.IOP.GET.FLAG BUSY) |of| \\IOPAGE)) (SETQ IOCB (|fetch| EPNETWORK |of| PACKET)) (EQ \\DLRS232C.ACTIVE.GET IOCB)) |then| (\\DEQUEUE (|fetch| NDBIQ |of| NDB)) (|if| (NULL (SETQ \\DLRS232C.GET.QUEUE.START (SETQ NEXTIOCB (|fetch| (DLRS232C.IOCB NEXT) |of| IOCB)))) |then| (SETQ \\DLRS232C.GET.QUEUE.END NIL)) (SETQ ACCEPTSTATUS (OR (|fetch| (DLRS232C.IOCB SUCCESS) |of| IOCB) (|fetch| (DLRS232C.IOCB TRANSFER.STATUS) |of| IOCB))) (PROG ((LENGTH (|fetch| (DLRS232C.IOCB RETURNED.BYTE.COUNT) |of| IOCB))) (|replace| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| PACKET |with| LENGTH) (|replace| EPNETWORK |of| PACKET |with| NDB) (COND ((AND (EQ \\MACHINETYPE \\DANDELION) (IGREATERP LENGTH (CONSTANT (UNFOLD \\MIN2PAGEBUFLENGTH BYTESPERWORD)))) (* * |The| |DLion| |ether| |code| |doesn't| |dirty| |the| |pages| |of| |an| |etherpacket.| |There| |are| |hints| |in| |the| |Mesa| RS232C |face| |that| |the| IOP |doesn't| |dirty| |the| |pages| |of| |an| RS232C |packet| |either.| |Hence,| |we| |dirty| |the| |second| |page| |of| |the| |packet| |if| |it's| |long| |enough| |to| |warrent| |it|) (\\PUTBASE PACKET (SUB1 (ITIMES WORDSPERPAGE 2)) 0))) (\\ENQUEUE \\DLRS232C.RAW.PACKET.QUEUE PACKET) (\\DLRS232C.FINISH.GET.AND.PUT IOCB) (|if| NEXTIOCB |then| (\\DLRS232C.START.INPUT NEXTIOCB)) (\\TEMPUNLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE))) (PROGN (SETQ PACKET (\\DLRS232C.ALLOCATE.PACKET)) (\\TEMPLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE)) (|replace| EPNETWORK |of| PACKET |with| IOCB) (\\DLRS232C.QUEUE.INPUT.IOCB IOCB (|fetch| RS232C.PACKET.BASE |of| PACKET) \\DLRS232C.DEFAULT.PACKET.LENGTH) (\\ENQUEUE (|fetch| NDBIQ |of| NDB) PACKET))) (COND ((AND ACCEPTSTATUS (NEQ ACCEPTSTATUS T) (OR (EQ \\RS232C.REPORT.STATUS T) (EQ \\RS232C.REPORT.STATUS (QUOTE INPUT)))) (\\DLRS232C.PARSE.STATUS ACCEPTSTATUS (QUOTE IN)))) ACCEPTSTATUS)) ) (\\DLRS232C.START.DRIVER (LAMBDA (NDB RESTARTFLG) (* |ejs:| "19-Jun-85 17:52") (* * |Device-specific| RS232C |startup|) (* * |Get| |some| IOCB |space|) (OR (\\DLRS232C.ALLOCATE.IOCBS) (ERROR "Unable to create IOCB pool")) (|replace| NDBTQ |of| NDB |with| (|create| SYSQUEUE)) (* * |Initialize| |the| |device| |at| |the| IOP |level|) (\\DLRS232C.STARTUP NDB) (* * |Load| |the| |initial| RS232C |input| |queue|) (LET ((LEN 0) (IQ (|fetch| NDBIQ |of| NDB))) (COND (IQ (SETQ LEN (\\DLRS232C.LOADINPUTQ NDB (|fetch| SYSQUEUEHEAD |of| IQ)))) (T (|replace| NDBIQ |of| NDB |with| (SETQ IQ (|create| SYSQUEUE))))) (|bind| IOCB PACKET |to| (IDIFFERENCE \\DLRS232C.IDEAL.INPUT.LENGTH LEN) |while| (SETQ IOCB (\\DLRS232C.GET.IOCB (QUOTE INPUT))) |do| (SETQ PACKET (\\DLRS232C.ALLOCATE.PACKET)) (\\TEMPLOCKPAGES PACKET (FOLDHI \\DLRS232C.DEFAULT.PACKET.LENGTH BYTESPERPAGE)) (|replace| EPNETWORK |of| PACKET |with| IOCB) (\\DLRS232C.QUEUE.INPUT.IOCB IOCB (|fetch| (RS232C.ENCAPSULATION RS232C.PACKET.BASE) |of| PACKET) \\DLRS232C.DEFAULT.PACKET.LENGTH) (\\ENQUEUE IQ PACKET) (|add| LEN 1)) (|replace| NDBIQLENGTH |of| NDB |with| LEN) (* * |This| |process| |will| |eventually| |be| |replaced| |by| |interrupts|) (|replace| NDBWATCHER |of| NDB |with| (ADD.PROCESS (LIST (FUNCTION \\DLRS232C.WATCHER) (KWOTE NDB)) (QUOTE RESTARTABLE) (QUOTE SYSTEM) (QUOTE AFTEREXIT) (QUOTE DELETE))) NDB)) ) (\\DLRS232C.SEND.PACKET (LAMBDA (NDB PACKET EVENT) (* \; "Edited 22-Dec-86 14:00 by lmm") (PROG ((DROPIT (AND \\RS232C.LIGHTNING (EQ 0 (RAND 0 \\RS232C.LIGHTNING)))) IOCB BUFLENGTH) (UNINTERRUPTABLY (|replace| EPTRANSMITTING |of| PACKET |with| T) (COND (DROPIT (* \; "Fake transmission") (\\ENQUEUE (|fetch| NDBTQ |of| NDB) PACKET) (|replace| EPNETWORK |of| PACKET |with| NIL)) (T (SETQ IOCB (\\DLRS232C.GET.IOCB (QUOTE OUTPUT))) (CL:ASSERT (NOT (NULL IOCB))) (|replace| EPNETWORK |of| PACKET |with| IOCB) (SETQ BUFLENGTH (|fetch| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| PACKET)) (\\TEMPLOCKPAGES PACKET (COND ((IGEQ BUFLENGTH (CONSTANT (UNFOLD \\MIN2PAGEBUFLENGTH BYTESPERWORD))) 2) (T 1))) (LET ((CLOCK (CREATECELL \\FIXP))) (\\CLOCK0 CLOCK) (|replace| EPTIMESTAMP |of| PACKET |with| CLOCK)) (* \; "Put on microcode queue") (\\ENQUEUE (|fetch| NDBTQ |of| NDB) PACKET) (SELECTC \\MACHINETYPE (\\DANDELION (|replace| (DLRS232C.IOCB SYNCH.EVENT) |of| IOCB |with| EVENT) (\\DLRS232C.QUEUE.OUTPUT.IOCB IOCB (|fetch| (RS232C.ENCAPSULATION RS232C.PACKET.BASE) |of| PACKET) BUFLENGTH)) (\\DAYBREAK (|replace| (|Dove.RS232IOCB| |rsLispSynchEvent|) |of| IOCB |with| EVENT) (\\DLRS232C.QUEUE.OUTPUT.IOCB IOCB (|fetch| (RS232C.ENCAPSULATION RS232C.PACKET.BASE) |of| PACKET) BUFLENGTH)) (\\NOMACHINETYPE)) T)) (* \; "Put on driver's queue to pick up after microcode finishes with it")) (RETURN (AND IOCB T)))) ) (\\RS232C.FORCEOUTPUT (LAMBDA (STREAM WAITFORFINISH) (* \; "Edited 29-May-87 15:27 by Snow") (COND ((OPENP STREAM (QUOTE OUTPUT)) (LET ((PACKET (|fetch| (STREAM CBUFPTR) |of| STREAM)) (EVENT (|fetch| (RS232C.STREAM EVENT) |of| STREAM))) (COND ((|type?| ETHERPACKET PACKET) (|replace| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| PACKET |with| (IDIFFERENCE (|fetch| COFFSET |of| STREAM) (CONSTANT (UNFOLD (IPLUS (INDEXF (FETCH (RS232C.ENCAPSULATION RS232C.DATA) OF T)) (INDEXF (FETCH EPENCAPSULATION OF T))) BYTESPERWORD)))) (\\RS232C.TRACE.PACKET PACKET (QUOTE OUTPUT)) (|replace| COFFSET |of| STREAM |with| (|replace| CBUFSIZE |of| STREAM |with| (|replace| CBUFMAXSIZE |of| STREAM |with| 0))) (|replace| CBUFPTR |of| STREAM |with| NIL) (\\DLRS232C.SEND.PACKET \\DLRS232C.LOCAL.NDB PACKET (AND WAITFORFINISH EVENT)) (COND (WAITFORFINISH (|while| (|fetch| EPTRANSMITTING |of| PACKET) |do| (AWAIT.EVENT EVENT))) (T (BLOCK))))))))) ) (\\RS232C.GETNEXTBUFFER (LAMBDA (STREAM WHATFOR NOERRORFLG) (* |ejs:| "24-Dec-85 14:05") (LET ((QUEUE (|fetch| (RS232C.STREAM PACKET.QUEUE) |of| STREAM)) (EVENT (|ffetch| (RS232C.STREAM EVENT) |of| STREAM)) (OLDPACKET (|ffetch| (STREAM CBUFPTR) |of| STREAM)) (LASTBUFFER (|ffetch| (RS232C.STREAM LASTBUFFER) |of| STREAM)) NEXTPACKET) (SELECTQ WHATFOR (READ (COND ((|ffetch| (RS232C.STREAM DID.BACKFILEPTR) |of| STREAM) (UNINTERRUPTABLY (|freplace| (RS232C.STREAM DID.BACKFILEPTR) |of| STREAM |with| NIL) (|swap| (|ffetch| CBUFPTR |of| STREAM) (|ffetch| (RS232C.STREAM LASTBUFFER) |of| STREAM)) (|swap| (|ffetch| CBUFSIZE |of| STREAM) (|ffetch| (RS232C.STREAM LASTBUFFER.CBUFSIZE) |of| STREAM)) (|freplace| COFFSET |of| STREAM |with| (UNFOLD (CONSTANT (IPLUS (INDEXF (|fetch| (RS232C.ENCAPSULATION RS232C.DATA) |of| T)) (INDEXF (|fetch| EPENCAPSULATION |of| T)))) BYTESPERWORD)) T)) (T (COND (OLDPACKET (COND (LASTBUFFER (\\RELEASE.ETHERPACKET LASTBUFFER))) (|freplace| (RS232C.STREAM LASTBUFFER) |of| STREAM |with| OLDPACKET) (|freplace| (RS232C.STREAM LASTBUFFER.CBUFSIZE) |of| STREAM |with| (|ffetch| CBUFSIZE |of| STREAM)) (|freplace| CBUFPTR |of| STREAM |with| NIL) (|freplace| COFFSET |of| STREAM |with| (|freplace| CBUFSIZE |of| STREAM |with| 0)))) (|until| (SETQ NEXTPACKET (\\DEQUEUE QUEUE)) |do| (AWAIT.EVENT EVENT) |finally| (|add| (|fetch| (RS232C.STREAM QUEUE.LENGTH) |of| STREAM) -1) (\\RS232C.TRACE.PACKET NEXTPACKET (QUOTE INPUT)) (|freplace| CBUFSIZE |of| STREAM |with| (IPLUS (|fetch| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| NEXTPACKET) (|freplace| COFFSET |of| STREAM |with| (UNFOLD (CONSTANT (IPLUS (INDEXF (|fetch| (RS232C.ENCAPSULATION RS232C.DATA) |of| T)) (INDEXF (|fetch| EPENCAPSULATION |of| T)))) BYTESPERWORD)))) (|freplace| CBUFPTR |of| STREAM |with| NEXTPACKET)))) T) (WRITE (COND ((NEQ (|fetch| COFFSET |of| STREAM) (CONSTANT (UNFOLD (IPLUS (INDEXF (|fetch| (RS232C.ENCAPSULATION RS232C.DATA) |of| T)) (INDEXF (|fetch| EPENCAPSULATION |of| T))) BYTESPERWORD))) (\\RS232C.FORCEOUTPUT STREAM))) (|freplace| CBUFSIZE |of| STREAM |with| (|freplace| CBUFMAXSIZE |of| STREAM |with| \\RS232C.OUTPUT.PACKET.LENGTH)) (|freplace| COFFSET |of| STREAM |with| (CONSTANT (UNFOLD (IPLUS (INDEXF (|fetch| (RS232C.ENCAPSULATION RS232C.DATA) |of| T)) (INDEXF (|fetch| EPENCAPSULATION |of| T))) BYTESPERWORD))) (|freplace| CBUFPTR |of| STREAM |with| (SETQ NEXTPACKET (\\ALLOCATE.ETHERPACKET))) (|freplace| EPREQUEUE |of| NEXTPACKET |with| (QUOTE FREE)) T) (ERROR "Illegal stream operation " WHATFOR)))) ) (\\RS232C.TRACE.PACKET (LAMBDA (PACKET FORWHAT) (* \; "Edited 5-Nov-87 11:54 by FS") (COND ((TYPENAMEP PACKET (QUOTE ETHERPACKET)) (SELECTQ RS232C.TRACEFLG (T (|printout| RS232C.TRACEFILE T FORWHAT ": ") (|bind| CH |for| CHINDEX |from| (CONSTANT (TIMES BYTESPERWORD (IPLUS (INDEXF (|fetch| (RS232C.ENCAPSULATION RS232C.DATA) |of| T)) (INDEXF (|fetch| EPENCAPSULATION |of| T))))) |to| (SUB1 (IPLUS (|fetch| (RS232C.ENCAPSULATION RS232C.LENGTH) |of| PACKET) (CONSTANT (TIMES BYTESPERWORD (IPLUS (INDEXF (|fetch| (RS232C.ENCAPSULATION RS232C.DATA) |of| T)) (INDEXF (|fetch| EPENCAPSULATION |of| T))))))) |do| (SETQ CH (\\GETBASEBYTE PACKET CHINDEX)) (COND ((< (LOGAND CH 127) (CHARCODE SPACE)) (CL:FORMAT RS232C.TRACEFILE "[~o]" CH)) (T (CL:WRITE-CHAR (CL:INT-CHAR CH) RS232C.TRACEFILE))))) (PEEK (PRIN1 (SELECTQ FORWHAT (INPUT "+") "!") RS232C.TRACEFILE)) NIL)))) ) ) (PUTPROPS RS232CNETWORK COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4261 26695 (\\DVRS232C.SET.PARAMETERS 4271 . 15969) (\\DVRS232C.INIT 15971 . 17852) ( \\DLRS232C.INIT 17854 . 21350) (RS232C.INIT 21352 . 22184) (\\RS232C.HANDLE.PACKET 22186 . 23833) ( \\RS232CNETWORKINIT 23835 . 25406) (\\DLRS232C.CREATE.NDB 25408 . 26693)) (26799 28633 (\\ETHEREVENTFN 26809 . 28631)) (28719 29130 (TURN.OFF.ETHER 28729 . 29128)) (29229 30541 (\\DVRS232C.SHUTDOWN 29239 . 30539)) (31112 32492 (\\TRANSLATE.3TO10 31122 . 32490)) (32760 33640 (\\RS232C.EVENTFN 32770 . 33638)) (33755 35150 (\\ROUTE.XIP 33765 . 35148)) (36276 38224 (\\DVRS232C.PARSE.STATUS 36286 . 38222) ) (39483 40548 (\\RS232CNETWORKENCAPSULATE 39493 . 40546)) (41204 52383 (\\DVRS232C.INPUT.INTERRUPT 41214 . 43061) (\\DLRS232C.INPUT.INTERRUPT 43063 . 45266) (\\DLRS232C.START.DRIVER 45268 . 46647) ( \\DLRS232C.SEND.PACKET 46649 . 48055) (\\RS232C.FORCEOUTPUT 48057 . 48988) (\\RS232C.GETNEXTBUFFER 48990 . 51511) (\\RS232C.TRACE.PACKET 51513 . 52381))))) STOP \ No newline at end of file diff --git a/lispusers/RS232CNETWORK.TEDIT b/lispusers/RS232CNETWORK.TEDIT new file mode 100644 index 00000000..41c142bd Binary files /dev/null and b/lispusers/RS232CNETWORK.TEDIT differ diff --git a/lispusers/SCREENPAPER b/lispusers/SCREENPAPER new file mode 100644 index 00000000..8735b25c --- /dev/null +++ b/lispusers/SCREENPAPER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 5-Aug-88 15:17:16" |{POGO:AISNORTH:XEROX}MEDLEY>USERS>SCREENPAPER.;1| 10019 changes to%: (FNS SCREENPAPER KALSHOW SCREENPAPERNEWREGIONFN) (VARS SCREENPAPERCOMS) previous date%: " 4-Aug-88 13:46:25" {ERINYES}MEDLEY>SCREENPAPER.;4) (* " Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SCREENPAPERCOMS) (RPAQQ SCREENPAPERCOMS ((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN) (ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" (QUOTE SCREENPAPER)))) (* ;;; "faster versions of editbitmap functions") (FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP) (VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT))) (DEFINEQ (SCREENPAPER (LAMBDA (WINDOW REGION.OR.SIZE OPTION) (* ; "Edited 5-Aug-88 15:07 by drc:") (OR WINDOW (SETQ WINDOW (CREATEW))) (OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if (EQ OPTION (QUOTE PICK)) then (GETREGION 0 0 NIL (FUNCTION SCREENPAPERNEWREGIONFN)) else SCREENPAPERSIZE))) (LET ((SIZE (if (REGIONP REGION.OR.SIZE) then (fetch (REGION WIDTH) REGION.OR.SIZE) else REGION.OR.SIZE)) TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD)) (DECLARE (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT)) (SETQ TRIANGLE (BITMAPCREATE SIZE SIZE)) (SETQ BUF1 (BITMAPCREATE SIZE SIZE)) (SETQ STREAM (DSPCREATE TRIANGLE)) (FILLPOLYGON (LIST (QUOTE (-1 . -1)) (CONS SIZE SIZE) (CONS -1 SIZE)) BLACKSHADE STREAM) (SETQ BUF2 (BITMAPCREATE SIZE SIZE)) (SETQ BUF3 (BITMAPCREATE SIZE SIZE)) (SETQ 2SIZE (PLUS SIZE SIZE)) (SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE)) (SETQ PBT (create PILOTBBT)) (DSPDESTINATION BUF1 STREAM) (if (EQ OPTION (QUOTE PICK)) then (bind POS do (RESETFORM (CURSOR CROSSHAIRS) (until (MOUSESTATE (OR LEFT MIDDLE RIGHT)))) (if (LASTMOUSESTATE (ONLY MIDDLE)) then (RETURN BIGBUF) elseif (LASTMOUSESTATE (ONLY RIGHT)) then (RETURN NIL) elseif (REGIONP REGION.OR.SIZE) then (SETQ POS (CONS (fetch (REGION LEFT) REGION.OR.SIZE) (fetch (REGION BOTTOM) REGION.OR.SIZE))) (SETQ REGION.OR.SIZE) else (SETQ POS (GETBOXPOSITION SIZE SIZE))) (BITBLT (SCREENBITMAP) (CAR POS) (CDR POS) BUF1 0 0 SIZE SIZE) (KALSHOW BUF1 WINDOW SIZE (if (SHIFTDOWNP (QUOTE SHIFT)) then (QUOTE INVERT) else NIL))) else (MAPN WINDOW (FUNCTION (LAMBDA (X Y) (BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)) X Y BUF1 0 0 SIZE SIZE) (DRAWLINE (SUB1 SIZE) 0 (RAND 0 (SUB1 SIZE)) (RAND 0 (SUB1 SIZE)) 1 (QUOTE INVERT) STREAM) (KALSHOW BUF1 WINDOW SIZE (if (VIDEOCOLOR) then NIL else (QUOTE INVERT))) (if (LEQ (add CNT -1) 0) then (SETQ CNT SCREENPERIOD) (to SCREENREPEAT do (BITBLT WINDOW 0 0 BUF1) (KALSHOW BUF1 WINDOW SIZE))))))))) ) (SCREENPAPERNEWREGIONFN (LAMBDA (FP MP) (* BN "17-Sep-84 10:40") (COND (MP (with POSITION MP (PROG ((DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP))) (DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP)))) (COND ((IGREATERP (IABS DX) (IABS DY)) (SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP) (ITIMES DX (COND ((MINUSP (ITIMES DX DY)) -1) (T 1)))))) (T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP) (ITIMES DY (COND ((MINUSP (ITIMES DX DY)) -1) (T 1))))))) (RETURN MP)))) (T FP))) ) (KALSHOW (LAMBDA (BUF1 WINDOW SIZE MODE) (* ; "Edited 5-Aug-88 11:54 by drc:") (BITBLT TRIANGLE NIL NIL BUF1 NIL NIL NIL NIL NIL (QUOTE ERASE)) (* THAT ERASED ALL BUT THE TRIANGLE) (ROTATE.BITMAP BUF1 BUF2 PBT) (INVERT.BITMAP.VERTICALLY BUF2 BUF3 PBT) (BITBLT BUF3 NIL NIL BUF1 NIL NIL NIL NIL NIL (QUOTE PAINT)) (LET (CX CY) (BITBLT BUF1 NIL NIL BIGBUF 0 SIZE) (INVERT.BITMAP.HORIZONTALLY BUF1 BUF2 PBT) (BITBLT BUF2 NIL NIL BIGBUF SIZE SIZE) (INVERT.BITMAP.VERTICALLY BUF1 BUF3 PBT) (BITBLT BUF3 NIL NIL BIGBUF 0 0) (INVERT.BITMAP.HORIZONTALLY BUF3 BUF2 PBT) (BITBLT BUF2 NIL NIL BIGBUF SIZE 0) (SETQ CX (QUOTIENT (WINDOWPROP WINDOW (QUOTE WIDTH)) 2)) (SETQ CY (QUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) 2)) (for I from 0 while (LESSP I (QUOTIENT (PLUS 2SIZE (MAX CX CY)) 2SIZE)) do (for J from 0 while (LEQ J I) do (DOPOINT (FUNCTION (LAMBDA (X Y) (BITBLT BIGBUF NIL NIL WINDOW (PLUS CX (TIMES X 2SIZE)) (PLUS CY (TIMES Y 2SIZE)) NIL NIL MODE (QUOTE REPLACE)))) J I))) (BLOCK))) ) (DOPOINT [LAMBDA (FN X Y) (* edited%: "31-Dec-00 16:08") (if (LESSP X Y) then (DOPOINT FN Y X)) (APPLY* FN X Y 1) (APPLY* FN (DIFFERENCE -1 X) Y 1) (APPLY* FN X (DIFFERENCE -1 Y) 1) (APPLY* FN (DIFFERENCE -1 X) (DIFFERENCE -1 Y) 1]) (MAPN [LAMBDA (WINDOW FN) (* edited%: " 1-Jan-01 00:09") (LET ((MAXX (DIFFERENCE (WINDOWPROP WINDOW 'WIDTH) SIZE)) (MAXY (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) SIZE)) X Y NX NY STEPS) (SETQ X (RAND 0 MAXX)) (SETQ Y (RAND 0 MAXY)) (while T do (SETQ NX (RAND 0 MAXX)) (SETQ NY (RAND 0 MAXY)) (SETQ STEPS (QUOTIENT (PLUS (ABS (DIFFERENCE NX X)) (ABS (DIFFERENCE NY Y))) 4)) (if (NEQ STEPS 0) then [for I from 1 to STEPS do (APPLY* FN (PLUS X (QUOTIENT (TIMES (DIFFERENCE NX X) I) STEPS)) (PLUS Y (QUOTIENT (TIMES (DIFFERENCE NY Y) I) STEPS] (SETQ X NX) (SETQ Y NY]) ) (ADDTOVAR IDLE.FUNCTIONS ("Screen wallpaper" (QUOTE SCREENPAPER))) (* ;;; "faster versions of editbitmap functions") (DEFINEQ (INVERT.BITMAP.HORIZONTALLY [LAMBDA (BITMAP BM2 PBT) (* edited%: "31-Dec-00 17:15") (OR BM2 (SETQ BM2 (BITMAPCOPY BITMAP))) (OR PBT (SETQ PBT (create PILOTBBT))) (with PILOTBBT PBT (SETQ PBTDESTLO (ffetch BitMapLoLoc BM2)) (SETQ PBTDESTHI (ffetch BitMapHiLoc BM2)) (SETQ PBTSOURCELO (ffetch BitMapLoLoc BITMAP)) (SETQ PBTSOURCEHI (ffetch BitMapHiLoc BITMAP)) (SETQ PBTDESTBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BM2))) (SETQ PBTSOURCEBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BITMAP))) (SETQ PBTFLAGS 16384) (* by experiment, disjoint replace) (SETQ PBTHEIGHT (ffetch BITMAPHEIGHT BITMAP)) (SETQ PBTWIDTH 1) (for I from 0 while (LESSP I (ffetch BITMAPWIDTH BITMAP)) do (SETQ PBTSOURCEBIT I) (SETQ PBTDESTBIT (DIFFERENCE (SUB1 (ffetch BITMAPWIDTH BITMAP)) I)) (\PILOTBITBLT PBT 0))) BM2]) (INVERT.BITMAP.VERTICALLY [LAMBDA (BITMAP BM2 PBT) (* edited%: "31-Dec-00 18:13") (OR BM2 (SETQ BM2 (BITMAPCOPY BITMAP))) (OR PBT (SETQ PBT (create PILOTBBT))) [with PILOTBBT PBT (*) (SETQ PBTDESTHI (ffetch BitMapHiLoc BM2)) [SETQ PBTDESTLO (PLUS (ffetch BitMapLoLoc BM2) (TIMES (SUB1 (ffetch BITMAPHEIGHT BITMAP)) (ffetch BITMAPRASTERWIDTH BM2] (SETQ PBTSOURCELO (ffetch BitMapLoLoc BITMAP)) (SETQ PBTSOURCEHI (ffetch BitMapHiLoc BITMAP)) (SETQ PBTDESTBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BM2))) (SETQ PBTSOURCEBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BITMAP))) (SETQ PBTSOURCEBIT 0) (SETQ PBTDESTBIT 0) (SETQ PBTFLAGS 16384) (* by experiment, disjoint replace) (SETQ PBTHEIGHT 1) (SETQ PBTWIDTH (ffetch BITMAPWIDTH BITMAP)) (for I from 0 while (LESSP I (ffetch BITMAPHEIGHT BITMAP)) do (\PILOTBITBLT PBT 0) (add PBTSOURCELO (ffetch BITMAPRASTERWIDTH BITMAP)) (add PBTDESTLO (MINUS (ffetch BITMAPRASTERWIDTH BM2] BM2]) (ROTATE.BITMAP [LAMBDA (BITMAP BM2 PBT) (* edited%: "31-Dec-00 16:24") [OR BM2 (SETQ BM2 (BITMAPCREATE (ffetch BITMAPHEIGHT BITMAP) (ffetch BITMAPWIDTH BITMAP] (OR PBT (SETQ PBT (create PILOTBBT))) [with PILOTBBT PBT (*) (SETQ PBTDESTHI (ffetch BitMapHiLoc BM2)) (SETQ PBTDESTLO (ffetch BitMapLoLoc BM2)) (SETQ PBTSOURCELO (ffetch BitMapLoLoc BITMAP)) (SETQ PBTSOURCEHI (ffetch BitMapHiLoc BITMAP)) (SETQ PBTDESTBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BM2))) (SETQ PBTSOURCEBPL 1) (SETQ PBTSOURCEBIT 0) (SETQ PBTDESTBIT (ffetch BITMAPWIDTH BM2)) (SETQ PBTFLAGS 0) (* by experiment, disjoint replace) (SETQ PBTHEIGHT (ffetch BITMAPHEIGHT BM2)) (SETQ PBTWIDTH 1) (for I from 0 while (LESSP I (ffetch BITMAPHEIGHT BITMAP)) do (add PBTDESTBIT -1) (\PILOTBITBLT PBT 0) (add PBTSOURCELO (ffetch BITMAPRASTERWIDTH BITMAP] BM2]) ) (RPAQQ SCREENPAPERSIZE 64) (RPAQQ SCREENPERIOD 100) (RPAQQ SCREENREPEAT 0) (PUTPROPS SCREENPAPER COPYRIGHT ("Xerox Corporation" 1901 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (805 5979 (SCREENPAPER 815 . 2782) (SCREENPAPERNEWREGIONFN 2784 . 3291) (KALSHOW 3293 . 4283) (DOPOINT 4285 . 4657) (MAPN 4659 . 5977)) (6106 9848 (INVERT.BITMAP.HORIZONTALLY 6116 . 7233) ( INVERT.BITMAP.VERTICALLY 7235 . 8611) (ROTATE.BITMAP 8613 . 9846))))) STOP \ No newline at end of file diff --git a/lispusers/SCREENPAPER.TEDIT b/lispusers/SCREENPAPER.TEDIT new file mode 100644 index 00000000..49c591c5 Binary files /dev/null and b/lispusers/SCREENPAPER.TEDIT differ diff --git a/lispusers/SEARCHMENU b/lispusers/SEARCHMENU new file mode 100644 index 00000000..4f802a72 --- /dev/null +++ b/lispusers/SEARCHMENU @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Apr-89 17:14:26" {ERINYES}MEDLEY>SEARCHMENU.;5 32974 previous date%: "21-Nov-88 08:18:13" {ERINYES}MEDLEY>SEARCHMENU.;4) (* " Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SEARCHMENUCOMS) (RPAQQ SEARCHMENUCOMS ((COMS * SEARCHMENUDEPENDENCIES) (FILES DICTTOOL ANALYZER FREEMENU (FROM {PIGLET/N}DICTSERVER>LISP>) DICTCLIENT) (INITVARS SearchMenu SearchMenu.Stream (SearchMenu.Cutoff 39)) (FNS SearchMenu.Create SearchMenu.GetData SearchMenu.PrintData SearchMenu.PrintDef SearchMenu.PrintSearch SearchMenu.ToggleKey SearchMenu.ToggleSample SearchMenu.PrintUses SearchMenu.Clear SearchMenu.MatchWords SearchMenu.MatchKeys SearchMenu.SearchFn SearchMenu.SetDatabase SearchMenu.DeleteKey SearchMenu.DeleteKeys SearchMenu.IconFn) (FNS TEdit.MatchWords DictTool.MatchWords) (VARS SearchKey SearchDelete SearchMatch SearchPrint SearchDatabase SearchClear SearchUses SearchDef SearchSample SearchExamples SearchMatchKeys SearchMenuIcon SearchMenuMask) (P (SETQ SearchIcon NIL) (SearchMenu.Create)))) (RPAQQ SEARCHMENUDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'SEARCHMENU 'DEPENDENCIES (for FILE in (FILECOMSLST 'SEARCHMENU 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES SEARCHMENU) (P (for FILE FILEDATE in (GETPROP 'SEARCHMENU 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS SEARCHMENU DEPENDENCIES ((DICTTOOL . "28-Feb-89 10:54:26") (ANALYZER . " 9-Mar-89 15:24:58") (FREEMENU . " 7-Jan-88 16:23:54") (DICTCLIENT . " 8-Oct-87 15:15:08"))) [for FILE FILEDATE in (GETPROP 'SEARCHMENU 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force  FILESLOAD to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL] (FILESLOAD DICTTOOL ANALYZER FREEMENU (FROM {PIGLET/N}DICTSERVER>LISP>) DICTCLIENT) (RPAQ? SearchMenu NIL) (RPAQ? SearchMenu.Stream NIL) (RPAQ? SearchMenu.Cutoff 39) (DEFINEQ (SearchMenu.Create [LAMBDA (MATCHES KEYWEIGHTS KEYMENU CLEAR ICON) (* ; "Edited 30-Mar-88 14:29 by walj") (* "w.a.l.johnson" "30-Nov-87 10:02") (* "w.a.l.johnson" "11-Nov-87 17:16") (* jtm%: "30-Oct-87 15:39") (LET (REGION EXAMPLES SEARCHMENUDATA POSWORDS NEGWORDS NEGKEYS MISSINGWORDS MENUTYPE) (COND (SearchMenu (SETQ REGION (WINDOWPROP SearchMenu 'REGION)) (SETQ SEARCHMENUDATA (AND (NOT CLEAR) (SearchMenu.GetData SearchMenu))) [OR KEYWEIGHTS (SETQ KEYWEIGHTS (LISTGET SEARCHMENUDATA 'KEYWEIGHTS] [OR MATCHES (SETQ MATCHES (LISTGET SEARCHMENUDATA 'MATCHES] (SETQ POSWORDS (LISTGET SEARCHMENUDATA 'POSWORDS)) (SETQ NEGWORDS (LISTGET SEARCHMENUDATA 'NEGWORDS)) (SETQ NEGKEYS (LISTGET SEARCHMENUDATA 'NEGKEYS)) (SETQ EXAMPLES (LISTGET SEARCHMENUDATA 'EXAMPLES)) (FM.ENDEDIT SearchMenu) (CLOSEW SearchMenu))) [SETQ MENUTYPE (COND (KEYMENU 'KEYMENU) (T 'SAMPLEMENU] (COND ((NULL SEARCHMENUDATA) (SETQ SEARCHMENUDATA (LIST 'MENUTYPE MENUTYPE))) (T (LISTPUT SEARCHMENUDATA 'MENUTYPE MENUTYPE))) (LISTPUT SEARCHMENUDATA 'KEYWEIGHTS KEYWEIGHTS) (LISTPUT SEARCHMENUDATA 'MATCHES MATCHES) (MOVEW (SETQ SearchMenu (FREEMENU [APPEND `[(PROPS FORMAT ROW LEFT %, (OR 0 (AND REGION (CAR REGION))) BOTTOM %, (OR 0 (AND REGION (CADR REGION] [COND [KEYMENU `(((LABEL ,SearchSample SELECTEDFN SearchMenu.ToggleSample) (LABEL ,SearchMatchKeys SELECTEDFN SearchMenu.MatchKeys) (LABEL ,SearchPrint SELECTEDFN SearchMenu.PrintSearch) (LABEL ,SearchDatabase SELECTEDFN SearchMenu.SetDatabase) (LABEL ,SearchClear SELECTEDFN SearchMenu.Clear] (T `(((LABEL ,SearchKey SELECTEDFN SearchMenu.ToggleKey) (LABEL ,SearchMatch SELECTEDFN SearchMenu.MatchWords) (LABEL ,SearchPrint SELECTEDFN SearchMenu.PrintSearch) (LABEL ,SearchDelete SELECTEDFN SearchMenu.DeleteKeys) (LABEL ,SearchDatabase SELECTEDFN SearchMenu.SetDatabase) (LABEL ,SearchClear SELECTEDFN SearchMenu.Clear)) ((TYPE EDITSTART LABEL ,SearchExamples LINKS (EDIT EXAMPLES )) (TYPE EDIT ID EXAMPLES LABEL %, (OR EXAMPLES ""] (COND [KEYMENU (* (TYPE 3STATE LABEL %,  (CONCAT (CAR KEY) ":") STATE %,  (COND ((MEMBER (CAR KEY) NEGKEYS) NIL)  (T (QUOTE NEUTRAL))))) (for KEY ID in KEYWEIGHTS collect `((LABEL ,SearchUses ID %, (COPYALL (CAR KEY)) SELECTEDFN SearchMenu.PrintUses) (TYPE EDITSTART LABEL %, (CONCAT (CAR KEY) ":") LINKS %, (LIST 'EDIT (CAR KEY))) (TYPE EDIT ID %, (CAR KEY) LABEL %, (CADR KEY] (T (for MATCH ID inside MATCHES collect (SETQ ID (COND ((LISTP MATCH) (CAR MATCH)) (T MATCH))) [COND ((AND (LISTP MATCH) (NTH (CADDR MATCH) 5)) (RPLACD (NTH (CADDR MATCH) 5) (LIST "..."] `((LABEL ,SearchDef ID %, (COPYALL ID) SELECTEDFN SearchMenu.PrintDef) (TYPE 3STATE ID %, ID LABEL %, (MKSTRING MATCH) INITSTATE %, (COND ((MEMBER ID POSWORDS) T) ((MEMBER ID NEGWORDS) OFF] "Search Menu")) (OR (AND REGION (CAR REGION)) 0) (OR (AND REGION (CADR REGION)) 0)) (OPENW SearchMenu) (COND ((SETQ MISSINGWORDS (AND MATCHES (for KEY in POSWORDS when [NOT (COND ((LISTP (CAR MATCHES)) (SASSOC KEY MATCHES)) (T (MEMBER KEY MATCHES] collect KEY))) (PROMPTPRINT "Lost keys: " MISSINGWORDS) (FLASHWINDOW PROMPTWINDOW) (SETQ POSWORDS (LDIFFERENCE POSWORDS MISSINGWORDS)) (LISTPUT SEARCHMENUDATA 'POSWORDS POSWORDS))) (WINDOWPROP SearchMenu 'SEARCHMENUDATA SEARCHMENUDATA)) (COND ((NULL ICON) (WINDOWPROP SearchMenu 'ICONIMAGE SearchMenuIcon) (WINDOWPROP SearchMenu 'ICONMASK SearchMenuMask) (WINDOWPROP SearchMenu 'ICONFN 'SearchMenu.IconFn)) (T (WINDOWPROP SearchMenu 'SHRINKFN NIL) (WINDOWPROP SearchMenu 'ICON ICON]) (SearchMenu.GetData [LAMBDA (WINDOW) (* ; "Edited 21-Nov-88 08:16 by Maxwell") (LET (STATE SEARCHMENUDATA KEYWEIGHTS EXAMPLES MATCHES POSWORDS NEGWORDS) (SETQ STATE (FM.GETSTATE WINDOW)) (SETQ SEARCHMENUDATA (WINDOWPROP WINDOW 'SEARCHMENUDATA)) (COND ((EQ 'KEYMENU (LISTGET SEARCHMENUDATA 'MENUTYPE)) (SETQ KEYWEIGHTS (for TAIL WEIGHT on STATE by (CDDR TAIL) when (AND TAIL (STRINGP (CAR TAIL)) [NUMBERP (SETQ WEIGHT (MKATOM (CADR TAIL] (NOT (ZEROP WEIGHT))) collect (LIST (CAR TAIL) WEIGHT))) (LISTPUT SEARCHMENUDATA 'KEYWEIGHTS KEYWEIGHTS)) (T (SETQ EXAMPLES (LISTGET STATE 'EXAMPLES)) (LISTPUT SEARCHMENUDATA 'EXAMPLES EXAMPLES) (SETQ POSWORDS (LISTGET SEARCHMENUDATA 'POSWORDS)) (for WORD inside (PARSEBYCOLONS EXAMPLES) do (push POSWORDS WORD)) (SETQ MATCHES (LISTGET SEARCHMENUDATA 'MATCHES)) (for MATCH KEY in MATCHES do (SETQ KEY (COND ((LISTP MATCH) (CAR MATCH)) (T MATCH))) (SELECTQ (LISTGET STATE KEY) (T (AND (NOT (MEMBER KEY POSWORDS)) (push POSWORDS KEY)) [COND ((MEMBER KEY NEGWORDS) (SETQ NEGWORDS (REMOVE KEY NEGWORDS]) (OFF (push NEGWORDS KEY) [COND ((MEMBER KEY POSWORDS) (SETQ POSWORDS (REMOVE KEY POSWORDS]) NIL)) (LISTPUT SEARCHMENUDATA 'POSWORDS (INTERSECTION POSWORDS POSWORDS)) (LISTPUT SEARCHMENUDATA 'NEGWORDS NEGWORDS))) SEARCHMENUDATA]) (SearchMenu.PrintData [LAMBDA (STREAM POSWORDS NEGWORDS KEYS MATCHES) (* jtm%: "28-Oct-87 15:17") (OR STREAM (SETQ STREAM (OPENTEXTSTREAM))) (COND ((AND (BOUNDP 'SquareSampleFreq) (BOUNDP 'InvertedDict.MinimumMatches)) (printout STREAM "(" InvertedDict.MinimumMatches " min, " (COND (SquareSampleFreq "") (T "not")) " squared)"))) (printout STREAM "***" "SEARCH MENU PRINTED ON " (DATE) "***" T T) (COND (POSWORDS (printout STREAM "SELECTED WORDS: ") [for TAIL on POSWORDS do (printout STREAM (CAR TAIL) (COND ((CDR TAIL) "; ") (T ""] (printout STREAM T))) (COND (NEGWORDS (printout STREAM "IGNOREDKEYS: ") [for TAIL on NEGWORDS do (printout STREAM (CAR TAIL) (COND ((CDR TAIL) "; ") (T ""] (printout STREAM T))) (printout STREAM T "KEY WEIGHTS:" T) (for KEY in KEYS do (printout STREAM .FR 6 (CADR KEY) %, (CAR KEY) T)) (printout STREAM T "MATCHES:" T) (for MATCH in MATCHES do [COND ((NTH (CADDR MATCH) 5) (RPLACD (NTH (CADDR MATCH) 5) (LIST "..."] (printout STREAM .FR 6 (CADR MATCH) %, (CAR MATCH) %, (CADDR MATCH) T)) (printout STREAM T) STREAM]) (SearchMenu.PrintDef [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 28-Oct-88 12:10 by jtm:") (LET (WORD NERD DICT) (SETQ WORD (FM.ITEMPROP ITEM 'ID)) [AND (SETQ NERD (NerdForStream SearchMenu.Stream)) (SETQ DICT (InvertedDict.Prop NERD 'DICTIONARY] (COND ((Dict.DisplayEntry DICT WORD (FMEMB 'MIDDLE BUTTONS)) NIL) (T (TEdit.PrintDefinition NIL DICT WORD]) (SearchMenu.PrintSearch [LAMBDA (MENUITEM WINDOW BUTTONS) (* jtm%: "28-Oct-87 14:43") (LET (SEARCHMENUDATA POSWORDS NEGWORDS KEYWEIGHTS MATCHES SCRATCH) (SETQ SEARCHMENUDATA (SearchMenu.GetData WINDOW)) (SETQ POSWORDS (LISTGET SEARCHMENUDATA 'POSWORDS)) (SETQ NEGWORDS (LISTGET SEARCHMENUDATA 'NEGWORDS)) (SETQ KEYWEIGHTS (LISTGET SEARCHMENUDATA 'KEYWEIGHTS)) (SETQ MATCHES (LISTGET SEARCHMENUDATA 'MATCHES)) (SETQ SCRATCH (SearchMenu.PrintData NIL POSWORDS NEGWORDS KEYWEIGHTS MATCHES)) (TEDIT.INCLUDESTREAM (Dict.OutputStream) SCRATCH) (CLOSEF SCRATCH]) (SearchMenu.ToggleKey [LAMBDA (MENUITEM WINDOW BUTTONS) (* "w.a.l.johnson" "11-Nov-87 15:57") (* jtm%: " 9-Oct-87 10:46") (SearchMenu.GetData WINDOW) (SearchMenu.Create NIL NIL T]) (SearchMenu.ToggleSample [LAMBDA (MENUITEM WINDOW BUTTONS) (* "w.a.l.johnson" "11-Nov-87 16:00") (* jtm%: " 9-Oct-87 10:46") (SearchMenu.GetData WINDOW) (SearchMenu.Create NIL NIL NIL NIL]) (SearchMenu.PrintUses [LAMBDA (ITEM WINDOW BUTTONS) (* jtm%: "13-Oct-87 10:11") (LET (WORD) (SETQ WORD (FM.ITEMPROP ITEM 'ID)) (TEdit.PrintSearch NIL (NerdForStream SearchMenu.Stream) WORD]) (SearchMenu.Clear [LAMBDA (ITEM WINDOW BUTTONS) (* "w.a.l.johnson" "11-Nov-87 15:58") (* jtm%: "28-Oct-87 14:17") (SearchMenu.Create NIL NIL NIL T]) (SearchMenu.MatchWords [LAMBDA (MENUITEM WINDOW BUTTONS) (* ; "Edited 3-Aug-88 15:13 by rmk:") (* "w.a.l.johnson" "11-Nov-87 15:58") (LET (SEARCHMENUDATA POSWORDS NEGKEYS MATCHES NERD MATCHWORDSFN (STARTTIME (CLOCK 0))) (SETQ SEARCHMENUDATA (SearchMenu.GetData WINDOW)) (SETQ POSWORDS (LISTGET SEARCHMENUDATA 'POSWORDS)) (SETQ NEGKEYS (LISTGET SEARCHMENUDATA 'NEGKEYS)) (SETQ NERD (SearchMenu.SetDatabase NIL WINDOW)) (PROMPTPRINT "Searching in " (InvertedDict.Name NERD) " for words like: " POSWORDS (COND (NEGKEYS (CONCAT ", ignoring the keys: " NEGKEYS)) (T ""))) [SETQ MATCHES (COND ((SETQ MATCHWORDSFN (InvertedDict.Prop NERD 'RELEVANCESEARCHFN)) (APPLY* MATCHWORDSFN NERD POSWORDS NEGKEYS 0 SearchMenu.Cutoff)) (T (DICTCLIENT.MATCHWORDS POSWORDS NEGKEYS 0 SearchMenu.Cutoff (InvertedDict.Prop NERD 'RemoteDict] (PROMPTPRINT "Search time: " (QUOTIENT (IDIFFERENCE (CLOCK 0) STARTTIME) 1000.0) " seconds.") (SearchMenu.Create (CADR MATCHES) (CAR MATCHES]) (SearchMenu.MatchKeys [LAMBDA (MENUITEM WINDOW BUTTONS) (* "w.a.l.johnson" "11-Nov-87 16:08") (* jtm%: "28-Oct-87 14:22") (LET (SEARCHMENUDATA MATCHES KEYWEIGHTS NERD WEIGHTSEARCHFN (STARTTIME (CLOCK 0))) (SETQ SEARCHMENUDATA (SearchMenu.GetData WINDOW)) (SETQ KEYWEIGHTS (LISTGET SEARCHMENUDATA 'KEYWEIGHTS)) (SETQ NERD (SearchMenu.SetDatabase NIL WINDOW)) (PROMPTPRINT "Searching on keys: " KEYWEIGHTS) [SETQ MATCHES (COND ((SETQ WEIGHTSEARCHFN (InvertedDict.Prop NERD 'WEIGHTSEARCHFN)) (APPLY* WEIGHTSEARCHFN NERD KEYWEIGHTS 0 SearchMenu.Cutoff)) (T (DICTCLIENT.WEIGHTEDSEARCH KEYWEIGHTS 0 SearchMenu.Cutoff (InvertedDict.Prop NERD 'RemoteDict] (PROMPTPRINT "Search time: " (QUOTIENT (IDIFFERENCE (CLOCK 0) STARTTIME) 1000.0) " seconds.") (SearchMenu.Create (CADR MATCHES) (CAR MATCHES]) (SearchMenu.SearchFn [LAMBDA (MENUITEM WINDOW BUTTONS) (* ; "Edited 25-Mar-88 15:31 by jtm:") (LET (KEYS SEARCHRESULT) (SETQ KEYS (LISTGET (FM.GETSTATE WINDOW) 'SearchKeys)) (SETQ SEARCHRESULT (InvertedDict.WeightedSearch WordNerd KEYS)) (RPLACD (NTH SEARCHRESULT SearchMenu.Cutoff)) (SearchMenu.Create SEARCHRESULT]) (SearchMenu.SetDatabase [LAMBDA (MENUITEM WINDOW BUTTONS) (* jtm%: "30-Nov-87 11:32") [COND ((NULL SearchMenu.Stream) (SETQ SearchMenu.Stream (OPENTEXTSTREAM] (COND [(NULL MENUITEM) (* called by SearchMenu.MatchWords and  SearchMenu.MatchKeys) (COND ((STREAMPROP SearchMenu.Stream 'nerd)) (T (TEdit.SetNerd SearchMenu.Stream] (T (TEdit.SetNerd SearchMenu.Stream]) (SearchMenu.DeleteKey [LAMBDA (MENUITEM WINDOW BUTTONS) (* "w.a.l.johnson" "30-Nov-87 10:27") (* jtm%: "30-Oct-87 16:04") (LET (SEARCHMENUDATA POSWORDS KEYWEIGHTS NEGKEYS NEGKEY) (SETQ SEARCHMENUDATA (SearchMenu.GetData WINDOW)) (SETQ NEGKEYS (LISTGET SEARCHMENUDATA 'NEGKEYS)) (SETQ KEYWEIGHTS (LISTGET SEARCHMENUDATA 'KEYWEIGHTS)) (PROG NIL LP (COND ((SETQ NEGKEY (MENU (create MENU TITLE _ "key to delete:" ITEMS _ (for KEYWEIGHT in KEYWEIGHTS unless (MEMBER (CAR KEYWEIGHT) NEGKEYS) collect (LIST (CONCAT (CAR KEYWEIGHT) ": " "(" (CADR KEYWEIGHT ) ")") (CAR KEYWEIGHT))) CENTERFLG _ T))) (pushnew NEGKEYS NEGKEY) (LISTPUT SEARCHMENUDATA 'NEGKEYS NEGKEYS) (GO LP]) (SearchMenu.DeleteKeys [LAMBDA (MENUITEM WINDOW BUTTONS) (* "w.a.l.johnson" "30-Nov-87 10:27") (* "w.a.l.johnson" "30-Nov-87 10:10") (* jtm%: "30-Oct-87 16:04") (LET (SEARCHMENUDATA POSWORDS KEYWEIGHTS NEGKEYS NEGKEY) (SETQ SEARCHMENUDATA (SearchMenu.GetData WINDOW)) (SETQ NEGKEYS (LISTGET SEARCHMENUDATA 'NEGKEYS)) (SETQ KEYWEIGHTS (LISTGET SEARCHMENUDATA 'KEYWEIGHTS)) (PROG NIL LP (COND ((SETQ NEGKEY (MENU (create MENU TITLE _ "key to delete:" ITEMS _ (for KEYWEIGHT in KEYWEIGHTS unless (MEMBER (CAR KEYWEIGHT) NEGKEYS) collect (LIST (CONCAT (CAR KEYWEIGHT) ": " "(" (CADR KEYWEIGHT ) ")") (CAR KEYWEIGHT))) CENTERFLG _ T))) (pushnew NEGKEYS NEGKEY) (LISTPUT SEARCHMENUDATA 'NEGKEYS NEGKEYS) (GO LP]) (SearchMenu.IconFn [LAMBDA (one two) (* "w.a.l.johnson" " 9-Jan-88 14:42") (COND (SearchIcon SearchIcon) (two two) (T (SETQ SearchIcon (ICONW (WINDOWPROP one 'ICONIMAGE) (WINDOWPROP one 'ICONMASK]) ) (DEFINEQ (TEdit.MatchWords [LAMBDA (stream dict words) (* jtm%: "28-Sep-87 15:17") (* * prints out the definitions that have a particular phrase in them.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (NerdForStream stream) (FUNCTION DictTool.MatchWords) stream words "Type sample words:" "Searching for words like" 'SAMPLEWORDS]) (DictTool.MatchWords [LAMBDA (dict selection stream) (* jtm%: " 9-Oct-87 13:43") (LET (looks words fn pos) [SETQ words (CADR (COND ((SETQ fn (InvertedDict.Prop dict 'MATCHWORDSFN)) (APPLY* fn dict selection)) ((InvertedDict.Prop dict 'RemoteDict) (DICTCLIENT.MATCHWORDS (PARSEBYCOLONS selection) NIL NIL NIL (InvertedDict.Prop dict 'RemoteDict] (SETQ pos (TEDIT.GETPOINT stream)) (TEDIT.INSERT stream (CONCAT selection ": ")) (SETQ looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) pos))) [for tail on words do (TEDIT.INSERT stream (CONCAT (CAR (CAR tail)) (COND ((CDR tail) "; ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (* do the looks last to avoid messing up the text placement.) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) 1 (TEDIT.GETPOINT stream)) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) (CAR looks) (CDR looks)) words]) ) (RPAQQ SearchKey #*(64 23)COOOOOOOOOOOOOO@GOOOOOOOOOOOOOOHN@@@@@@@@@@@@@CLL@@@@@@@@@@@@@ANL@@@@@@@@@@@@@AKL@@@@@@@@@@@@@AMLLINLDCAINFBFBAKLMIHLLCAIHGBFBAMLMAHFHCKIHGJFBAKLOANGHCKINEJFBAMLMIHC@BNMHENFBAKLMIHC@BNMHDNGBAMLLMNC@FDMNDFCLAKL@@@@@@@@@@@@@AML@@@@@@@@@@@@@AKL@@@@@@@@@@@@@AML@@@@@@@@@@@@@AKN@@@@@@@@@@@@@CMOOOOOOOOOOOOOOOKGOOOOOOOOOOOOOOMCBJJJJJJJJJJJJJOAMEEEEEEEEEEEEEF@OOOOOOOOOOOOOOL ) (RPAQQ SearchDelete #*(70 23)COOOOOOOOOOOOOOOL@@@GOOOOOOOOOOOOOOON@@@N@@@@@@@@@@@@@@@O@@@L@@@@@@@@@@@@@@@GH@@L@@@@@@@@@@@@@@@FL@@L@@@@@@@@@@@@@@@GD@@LO@OCANOMN@LINLDFL@@LMLLCAHCAH@MIHLLGD@@LLLLCAHCAH@MAHFHFL@@LLNOCANCAN@OANGHGD@@LLLLCAHCAH@MIHC@FL@@LMLLCAHCAH@MIHC@GD@@LO@OCMNCAN@LMNC@FL@@L@@@@@@@@@@@@@@@GD@@L@@@@@@@@@@@@@@@FL@@L@@@@@@@@@@@@@@@GD@@L@@@@@@@@@@@@@@@FL@@N@@@@@@@@@@@@@@@OD@@OOOOOOOOOOOOOOOONL@@GOOOOOOOOOOOOOOOOD@@CBJJJJJJJJJJJJJJKL@@AMEEEEEEEEEEEEEEEH@@@OOOOOOOOOOOOOOOO@@@ ) (RPAQQ SearchMatch #*(90 23)COOOOOOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOOOOOON@@N@@@@@@@@@@@@@@@@@@@@O@@L@@@@@@@@@@@@@@@@@@@@GH@L@@@@@@@@@@@@@@@@@@@@FL@L@@@@@@@@@@@@@@@@@@@@GD@LLFACOALLLCCCALCLGHCHFL@LLFAHLGFLLCCBGGCFFNF@GD@LNNCHLF@LLAKJFCCFFFG@FL@LNNBLLN@OLAIJNCKLFGCHGD@LKKGLLF@LLAMLFCCFFFAHFL@LKKDDLGBLL@LLGGCFFNEHGD@MICLDLALLL@LLALCCGHG@FL@L@@@@@@@@@@@@@@@@@@@@GD@L@@@@@@@@@@@@@@@@@@@@FL@L@@@@@@@@@@@@@@@@@@@@GD@L@@@@@@@@@@@@@@@@@@@@FL@N@@@@@@@@@@@@@@@@@@@@OD@OOOOOOOOOOOOOOOOOOOOONL@GOOOOOOOOOOOOOOOOOOOOOD@CBJJJJJJJJJJJJJJJJJJJKL@AMEEEEEEEEEEEEEEEEEEEEH@@OOOOOOOOOOOOOOOOOOOOO@@ ) (RPAQQ SearchPrint #*(42 23)COOOOOOOOL@@GOOOOOOOON@@N@@@@@@@@O@@L@@@@@@@@GH@L@@@@@@@@FL@L@@@@@@@@GD@LOCLFFBOLFL@LMKFFGBC@GD@LMKFFGJC@FL@LOCLFEJC@GD@LLCFFENC@FL@LLCFFDNC@GD@LLCCFDFC@FL@L@@@@@@@@GD@L@@@@@@@@FL@L@@@@@@@@GD@L@@@@@@@@FL@N@@@@@@@@OD@OOOOOOOOONL@GOOOOOOOOOD@CBJJJJJJJKL@AMEEEEEEEEH@@OOOOOOOOO@@ ) (RPAQQ SearchDatabase #*(82 23)COOOOOOOOOOOOOOOOOOL@@@@GOOOOOOOOOOOOOOOOOON@@@@N@@@@@@@@@@@@@@@@@@O@@@@L@@@@@@@@@@@@@@@@@@GH@@@L@@@@@@@@@@@@@@@@@@FL@@@L@@@@@@@@@@@@@@@@@@GD@@@LGCMOHGHACOAAN@HGCLFL@@@LLC@F@FNAHLAIK@LLC@GD@@@LNC@F@FFCHLCIKALNC@FL@@@LGCLF@FGBLLBMNAFGCLGD@@@LCC@F@FFGLLGMKCNCC@FL@@@LKC@F@FNDDLDEKBBKC@GD@@@LNCLF@GHLDLLENFBNCLFL@@@L@@@@@@@@@@@@@@@@@@GD@@@L@@@@@@@@@@@@@@@@@@FL@@@L@@@@@@@@@@@@@@@@@@GD@@@L@@@@@@@@@@@@@@@@@@FL@@@N@@@@@@@@@@@@@@@@@@OD@@@OOOOOOOOOOOOOOOOOOONL@@@GOOOOOOOOOOOOOOOOOOOD@@@CBJJJJJJJJJJJJJJJJJKL@@@AMEEEEEEEEEEEEEEEEEEH@@@@OOOOOOOOOOOOOOOOOOO@@@@ ) (RPAQQ SearchClear #*(42 23)COOOOOOOOL@@GOOOOOOOON@@N@@@@@@@@O@@L@@@@@@@@GH@L@@@@@@@@FL@L@@@@@@@@GD@LCIHO@HO@FL@LNMHL@LMHGD@LLAHLALMHFL@MLAHOAFO@GD@LLAHLCNMHFL@LNEHLBBMHGD@LCINOFBLLFL@L@@@@@@@@GD@L@@@@@@@@FL@L@@@@@@@@GD@L@@@@@@@@FL@N@@@@@@@@OD@OOOOOOOOONL@GOOOOOOOOOD@CBJJJJJJJKL@AMEEEEEEEEH@@OOOOOOOOO@@ ) (RPAQQ SearchUses #*(29 15)GOOOOOL@L@@@@@G@H@@@@@BHKBGGILCHKBLFC@BHKBNGKHCHKBGFALBHKBCF@LCHILNGKHBHH@@@@@CHL@@@@@FHOOOOOOOHGOOOOONHCJJJJJK@AOOOOON@ ) (RPAQQ SearchDef #*(23 12)COOOOH@@D@@@AL@@KNGKLJ@@KCFC@N@@KCGKLJ@@KCFC@N@@KCFC@J@@KNGK@N@@H@@@AJ@@OOOOON@@FJJJJL@@COOOOH@@ ) (RPAQQ SearchSample #*(82 23)COOOOOOOOOOOOOOOOOOL@@@@GOOOOOOOOOOOOOOOOOON@@@@N@@@@@@@@@@@@@@@@@@O@@@@L@@@@@@@@@@@@@@@@@@GH@@@L@@@@@@@@@@@@@@@@@@FL@@@L@@@@@@@@@@@@@@@@@@GD@@@LG@HLFGIHO@FCCLLDLDFL@@@LL@LLFFMHL@FCC@NDLDGD@@@LNALNNFMHL@GGC@ODLDFL@@@LGAFNNGIHO@GGCLKDLDGD@@@LCCNKKFAHL@EMK@KLLDFL@@@LKBBKKFAHL@EMK@ILNDGD@@@LNFCICFANO@LIKLHLGHFL@@@L@@@@@@@@@@@@@@@@@@GD@@@L@@@@@@@@@@@@@@@@@@FL@@@L@@@@@@@@@@@@@@@@@@GD@@@L@@@@@@@@@@@@@@@@@@FL@@@N@@@@@@@@@@@@@@@@@@OD@@@OOOOOOOOOOOOOOOOOOONL@@@GOOOOOOOOOOOOOOOOOOOD@@@CBJJJJJJJJJJJJJJJJJKL@@@AMEEEEEEEEEEEEEEEEEEH@@@@OOOOOOOOOOOOOOOOOOO@@@@ ) (RPAQQ SearchExamples #*(123 20)COOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@N@@@@@@@@@@@@@@@@@@AOOOOOOOOON@@L@@@@@@@@@@@@@@@@@@AHHHHHHHICF@@LO@@D@@@GH@@@@@AH@@AHHHHHHHICJ@@LL@@L@@@F@@@@@@AH@@AOOOOOOOOOFF@LLEINNFHFCELKFGIILGAHDDDDDDDCJF@LOFLMKG@GKHFMKFMKFLAHDDDDDDDKFF@LLFLMOF@FAINMKFMKNOAOOOOOOONKJ@@LLFLMHF@FAMFMKFMK@CAHBBBBBBBCF@@LOFLFOF@GJMKMKGIINOAHBBBBBBBCJ@@L@@@@@@@@@@@@@F@@@@AOOOOOOOOOFF@L@@@@@@@@@@@@@F@@@@AI@HHHHHHCJF@L@@@@@@@@@@@@@F@@@@AI@HHHHHHCFF@N@@@@@@@@@@@@@@@@@@AOOOOOOOOOJ@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOF@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOJ@@CBJJJJJJJJJJJJJJJJJJJJJJJJJJJN@@AMEEEEEEEEEEEEEEEEEEEEEEEEEEEL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@ ) (RPAQQ SearchMatchKeys #*(74 23)COOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOON@@N@@@@@@@@@@@@@@@@O@@L@@@@@@@@@@@@@@@@GH@L@@@@@@@@@@@@@@@@FL@L@@@@@@@@@@@@@@@@GD@LLFACOALLLAICMHILFL@LLFAHLGFLLAKCAIK@GD@LNNCHLF@LLAJC@MCHFL@LNNBLLN@OLANCLOALGD@LKKGLLF@LLAKC@F@LFL@LKKDDLGBLLAKC@FBLGD@MICLDLALLLAIKLFCHFL@L@@@@@@@@@@@@@@@@GD@L@@@@@@@@@@@@@@@@FL@L@@@@@@@@@@@@@@@@GD@L@@@@@@@@@@@@@@@@FL@N@@@@@@@@@@@@@@@@OD@OOOOOOOOOOOOOOOOONL@GOOOOOOOOOOOOOOOOOD@CBJJJJJJJJJJJJJJJKL@AMEEEEEEEEEEEEEEEEH@@OOOOOOOOOOOOOOOOO@@ ) (RPAQQ SearchMenuIcon #*(44 29)@@@GN@GN@@@@@@AOOIOOH@@@@@COOOOOL@@@@@GOOOOON@@@@@OLGOLAO@@@@CO@AO@AOH@@OON@B@@@GOO@COHCOOO@COL@AO@N@@AL@G@@@CMHC@@GON@@@AN@L@OAOL@@@@LA@A@OOH@@@AHB@GOON@@@@F@D@OOOL@@@@H@HAOOOH@@@A@A@AOOO@@@@B@@@COON@@@@DAN@COO@@@@@DCC@GOH@@@@@H@A@D@@@@@@@H@C@L@@@@@@@HAN@H@@@@@@@HC@@H@@@@@@@HF@A@@@@@@@@D@@B@@@@@@@@DL@D@@@@@@@@B@@H@@@@@@@@A@C@@@@@@@@@@OL@@@@@@@@@ ) (RPAQQ SearchMenuMask #*(44 29)@@@GN@GN@@@@@@AOOIOOH@@@@@COOOOOL@@@@@GOOOOON@@@@@OOOOOOO@@@@COOOOOOOH@@OOOOOOOOOOO@COOOOOOOOOL@AOOOOOOOOO@@@COOOOOOON@@@AOOOOOOOL@@@@OOOOOOOH@@@AOOOOOON@@@@GOOOOOOL@@@@OOOOOOOH@@@AOOOOOOO@@@@COOOOOON@@@@GOOOOOO@@@@@GOOOOOH@@@@@OOOOL@@@@@@@OOOOL@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOO@@@@@@@@GOON@@@@@@@@GOOL@@@@@@@@COOH@@@@@@@@AOO@@@@@@@@@@OL@@@@@@@@@ ) (SETQ SearchIcon NIL) (SearchMenu.Create) (PUTPROPS SEARCHMENU COPYRIGHT ("Xerox Corporation" 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3464 25282 (SearchMenu.Create 3474 . 11127) (SearchMenu.GetData 11129 . 13392) ( SearchMenu.PrintData 13394 . 15703) (SearchMenu.PrintDef 15705 . 16179) (SearchMenu.PrintSearch 16181 . 16875) (SearchMenu.ToggleKey 16877 . 17173) (SearchMenu.ToggleSample 17175 . 17480) ( SearchMenu.PrintUses 17482 . 17753) (SearchMenu.Clear 17755 . 18015) (SearchMenu.MatchWords 18017 . 19528) (SearchMenu.MatchKeys 19530 . 20746) (SearchMenu.SearchFn 20748 . 21176) ( SearchMenu.SetDatabase 21178 . 21753) (SearchMenu.DeleteKey 21755 . 23310) (SearchMenu.DeleteKeys 23312 . 24971) (SearchMenu.IconFn 24973 . 25280)) (25283 27304 (TEdit.MatchWords 25293 . 25738) ( DictTool.MatchWords 25740 . 27302))))) STOP \ No newline at end of file diff --git a/lispusers/SEARCHMENU.TEDIT b/lispusers/SEARCHMENU.TEDIT new file mode 100644 index 00000000..1477705b Binary files /dev/null and b/lispusers/SEARCHMENU.TEDIT differ diff --git a/lispusers/SEDIT-COMMONLISP b/lispusers/SEDIT-COMMONLISP new file mode 100644 index 00000000..0c53a0ac --- /dev/null +++ b/lispusers/SEDIT-COMMONLISP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE "INTERLISP") (FILESLOAD TEXTMODULES) *PACKAGE*) BASE 10) (FILECREATED " 2-Oct-87 18:07:39" {DSK}WORK>SEDIT-COMMONLISP.;29 63962 changes to%: (FNS \\unread.read.time.conditional? \\subnode.changed.read.time.conditional \\delete.read.time.conditional \\replace.read.time.conditional \\set.point.read.time.conditional \\initialize.commonlisp \\insert.read.time.conditional \\parse..conditional.read \\cfv.read.time.conditional \\linearize.read.time.conditional \\compute.point.position.read.time.conditional \\undo.replace.read.time.conditional \\backspace.read.time.conditional \\stringify.read.time.conditional \\copy.structure.read.time.conditional \\set.selection.read.time.conditional \\stringify.comment SUPERPRINT/COMMENT \\linearize.comment \\cfv.form \\parse..hash.bar.comment) (VARS SEDIT-COMMONLISPCOMS) (PROPS (SEDIT-COMMONLISP MAKEFILE-ENVIRONMENT)) (PRESENTATIONS TM::HASH-R) previous date%: "29-Sep-87 14:05:07" {DSK}WORK>SEDIT-COMMONLISP.;17) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SEDIT-COMMONLISPCOMS) (RPAQQ SEDIT-COMMONLISPCOMS ((* ;;; " This file contains patches to the following files: SEDIT-COMMENTS (adds 4 semicolon and balanced comments), SEDIT-LISTS (form CFV and linearize of the new comment types), DSPRINTDEF and NEWPRINTDEF (new comment type printing).") (LOCALVARS . T) (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES SEDIT-DECLS)) (CONSTANTS (\\level4.comment (QUOTE ;;;;)) (\\level5.comment (QUOTE %|)) (\\level5.comment.close.string (\\create.string.item "|#" (fetch (EditENV CommentFont) of \\lisp.edit.environment))) (\\comment.markers (LIST \\level1.comment \\level2.comment \\level3.comment \\level4.comment \\level5.comment)) (\\comment.level.table (LIST \\level1.comment 1 \\level2.comment 2 \\level3.comment 3 \\level4.comment 4 \\level5.comment 5))) (GLOBALVARS \\type.new.quote \\type.read.time.conditional) (* ;;; "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP.") (MACROS \\select.comment.indent) (FNS PRIN2-LONG-STRING SEMI-COLON-COMMENT-P SUPERPRINT/COMMENT \\backspace.read.time.conditional \\cfv.clisp \\cfv.comment \\cfv.form \\cfv.lambda \\cfv.read.time.conditional \\compute.point.position.read.time.conditional \\copy.structure.new.quote \\copy.structure.read.time.conditional \\create.new.quoted.gap \\degrade.comment \\delete.read.time.conditional \\initialize.commonlisp \\input.bit.vector \\input.conditional.read \\input.new.quote \\insert.new.quoted.gap \\insert.read.time.conditional \\linearize.clisp \\linearize.comment \\linearize.form \\linearize.lambda \\linearize.list \\linearize.read.time.conditional \\parse..bit.vector \\parse..comment \\parse..conditional.read \\parse..new.quote \\replace.new.quote \\replace.read.time.conditional \\set.point.read.time.conditional \\set.selection.read.time.conditional \\split.comment \\stringify.comment \\stringify.new.quote \\stringify.read.time.conditional \\subnode.changed.new.quote \\subnode.changed.read.time.conditional \\undo.replace.read.time.conditional \\unread.read.time.conditional? \\upgrade.comment) (P (\\initialize.commonlisp)) (PROP MAKEFILE-ENVIRONMENT SEDIT-COMMONLISP)) ) (* ;;; " This file contains patches to the following files: SEDIT-COMMENTS (adds 4 semicolon and balanced comments), SEDIT-LISTS (form CFV and linearize of the new comment types), DSPRINTDEF and NEWPRINTDEF (new comment type printing)." ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILESLOAD SEDIT-DECLS) ) (DECLARE%: EVAL@COMPILE (RPAQQ \\level4.comment ;;;;) (RPAQQ \\level5.comment %|) (RPAQ \\level5.comment.close.string (\\create.string.item "|#" (fetch (EditENV CommentFont) of \\lisp.edit.environment)) ) (RPAQ \\comment.markers (LIST \\level1.comment \\level2.comment \\level3.comment \\level4.comment \\level5.comment) ) (RPAQ \\comment.level.table (LIST \\level1.comment 1 \\level2.comment 2 \\level3.comment 3 \\level4.comment 4 \\level5.comment 5) ) (CONSTANTS (\\level4.comment (QUOTE ;;;;)) (\\level5.comment (QUOTE %|)) (\\level5.comment.close.string (\\create.string.item "|#" (fetch (EditENV CommentFont) of \\lisp.edit.environment))) (\\comment.markers (LIST \\level1.comment \\level2.comment \\level3.comment \\level4.comment \\level5.comment)) (\\comment.level.table (LIST \\level1.comment 1 \\level2.comment 2 \\level3.comment 3 \\level4.comment 4 \\level5.comment 5))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\type.new.quote \\type.read.time.conditional) ) (* ;;; "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP." ) (DECLARE%: EVAL@COMPILE (PUTPROPS \\select.comment.indent MACRO ((key level1.indent level2.indent level3.indent) (SELECTQ key (1 level1.indent) (2 level2.indent) ((3 4 5) level3.indent) (SHOULDNT "unexpected comment level")))) ) (DEFINEQ (PRIN2-LONG-STRING (LAMBDA (STRING STREAM P2FLG TAIL LMARG RMARG COMMENTP USE-SEMI-COLONS) (* ; "Edited 20-Sep-87 19:20 by raf") (PROG ((ESC (fetch (READTABLEP ESCAPECHAR) of *READTABLE*)) (SA (fetch (READTABLEP READSA) of *READTABLE*)) (HERE (DSPXPOSITION NIL STREAM)) (FONT (DSPFONT NIL STREAM)) ESCWIDTH SPACEWIDTH CLOSEWIDTH SEMIWIDTH LASTSPACE I C NEXTC POS J MAPX1 MAPY1 SINGLELEFT SEMISTRING) (COND ((NOT (type? FONTDESCRIPTOR FONT)) (* ; "Ugh, happens for files") (SETQ FONT STREAM))) (SETQ ESCWIDTH (CHARWIDTH ESC FONT)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) FONT)) (SETQ CLOSEWIDTH (COND (P2FLG (STRINGWIDTH "%")" FONT)) (T 0))) (SELECTQ USE-SEMI-COLONS ((1 2 3 4) (* ; "Semicolon comment") (SETQ SEMIWIDTH (+ SPACEWIDTH (TIMES USE-SEMI-COLONS (CHARWIDTH (CHARCODE ";") FONT)))) (SETQ SEMISTRING (CONCAT (ALLOCSTRING USE-SEMI-COLONS (CHARCODE ";")) " "))) (5 (* ; "Balanced (hash bar) comment") (SETQ SEMIWIDTH 0) (SETQ SEMISTRING "")) NIL) (COND ((for C instring STRING as I from 1 bind (POS _ (+ HERE (COND (P2FLG (CHARWIDTH (CHARCODE %") FONT)) ((LEQ USE-SEMI-COLONS 4) SEMIWIDTH) ((EQ USE-SEMI-COLONS 5) (STRINGWIDTH "#||#" FONT)) (T 0)) CLOSEWIDTH)) do (COND ((EQ C (CHARCODE CR)) (* ; "Always want to print these strings specially") (SETQ LASTSPACE I) (RETURN NIL)) ((AND P2FLG (OR (EQ C (CHARCODE %")) (EQ C ESC))) (* ; "Need escape") (add POS ESCWIDTH))) (COND ((GREATERP (add POS (CHARWIDTH C FONT)) RMARG) (RETURN NIL))) (COND ((EQ C (CHARCODE SPACE)) (SETQ LASTSPACE I))) finally (RETURN T)) (* ; "It all fits on this line") (RETURN (COND (P2FLG (PRIN2S STRING TAIL STREAM)) (T (if (LEQ USE-SEMI-COLONS 4) then (PRIN1 SEMISTRING STREAM) elseif (EQ USE-SEMI-COLONS 5) then (PRIN1 "#|" STREAM)) (PRIN1S STRING TAIL STREAM) (if (EQ USE-SEMI-COLONS 5) then (PRIN1 "|#" STREAM))))))) (COND ((OR (NULL LASTSPACE) (AND (NULL COMMENTP) (NEQ HERE LMARG))) (* ;; "Can't print anything on this line before the end. Comments are allowed to have different first and subsequent margin.") (PRINENDLINE LMARG STREAM) (SETQ HERE LMARG) (SETQ LASTSPACE 0))) (COND (MAKEMAP (* ; "Note start") (SETQ MAPX1 HERE) (SETQ MAPY1 (DSPYPOSITION NIL STREAM)) (SETQ SINGLELEFT (EQ HERE LMARG)))) (COND (P2FLG (COND ((NOT (IMAGESTREAMP STREAM)) (* ; "Need to be able to read it back") (LET ((HASH (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))) (\OUTCHAR STREAM HASH) (add HERE (CHARWIDTH HASH FONT))))) (\OUTCHAR STREAM (CHARCODE %")) (add HERE (CHARWIDTH (CHARCODE %") FONT))) ((LEQ USE-SEMI-COLONS 4) (PRIN1 SEMISTRING STREAM) (add HERE SEMIWIDTH)) ((EQ USE-SEMI-COLONS 5) (PRIN1 "#|" STREAM) (add HERE (STRINGWIDTH "#|" FONT)))) (* ;;; "Now loop, printing as much as we can while there's room") (SETQ I 0) LP (COND ((NULL (SETQ C (NTHCHARCODE STRING (add I 1)))) (* ; "Done") (GO DONE)) ((NOT (LESSP I LASTSPACE)) (* ;; "Must find the next safe place to print up to. LASTSPACE is either a space or CR position, or is 0, which is our state when printing from the left margin until we encounter a space.") (SETQ POS HERE) (SETQ J I) (* ; "Ordinarily, J is pointing at a space or CR except when we have just printed an endline") (SELCHARQ C (SPACE (* ; "Would like all spaces before the eol, where they're invisible, not after") (SELCHARQ (NTHCHARCODE STRING (ADD1 J)) ((SPACE CR NIL) (SETQ LASTSPACE (ADD1 J)) (* ; "Go ahead and print this space, and note that it is now okay to break the line") (COND ((AND (IGEQ (+ HERE SPACEWIDTH) RMARG) (IMAGESTREAMP STREAM)) (* ; "Extra spaces have no effect, so don't print them at all, lest the dsprightmargin bite") (GO LP)) (T (GO PRINTIT)))) NIL) (add POS SPACEWIDTH)) (CR (* ; "If two cr's in a row, print them all; if only one, must escape it") (COND ((EQ (SETQ C (NTHCHARCODE STRING (add I 1))) (CHARCODE CR)) (PRINENDLINE LMARG STREAM) (while (EQ (SETQ C (NTHCHARCODE STRING (add I 1))) (CHARCODE CR)) do (PRINENDLINE LMARG STREAM))) (T (\OUTCHAR STREAM ESC))) (SETQ LASTSPACE 0) (GO ENDLINE)) (PROGN (* ;; "Gets set this way at left edge. Must print something on this line, even if there are no spaces before the right edge") (GO CHECKESCAPE))) (SETQ LASTSPACE 0) (while (LESSP POS RMARG) do (SELCHARQ (SETQ NEXTC (NTHCHARCODE STRING (add J 1))) ((CR SPACE) (* ; "Can safely go this far") (SETQ LASTSPACE J) (RETURN)) (NIL (* ; "End of string -- ok if there is space for closing quote and paren as well") (COND ((LESSP (PLUS POS CLOSEWIDTH) RMARG) (SETQ LASTSPACE J) (RETURN)) (T (GO $$OUT)))) NIL) (COND ((OR (EQ NEXTC (CHARCODE %")) (EQ NEXTC ESC)) (add POS ESCWIDTH))) (add POS (CHARWIDTH NEXTC FONT)) finally (COND ((EQ LASTSPACE 0) (* ; "Need break") (COND ((EQ C (CHARCODE SPACE)) (* ; "Will turn this space into CR") (SETQ C (NTHCHARCODE STRING (add I 1)))) (T (SHOULDNT))) (GO ENDLINE)))))) CHECKESCAPE (COND ((AND P2FLG (OR (EQ C (CHARCODE %")) (EQ C ESC))) (\OUTCHAR STREAM ESC) (add HERE ESCWIDTH))) PRINTIT (\OUTCHAR STREAM C) (add HERE (CHARWIDTH C FONT)) (GO LP) ENDLINE (PRINENDLINE LMARG STREAM) (SETQ HERE LMARG) (COND ((NULL C) (* ; "Done") (GO DONE)) ((AND P2FLG (EQ (\SYNCODE SA C) SEPRCHAR.RC)) (* ; "Have to quote sepr immediately following CR") (\OUTCHAR STREAM ESC) (add HERE ESCWIDTH) (GO PRINTIT)) (T (COND (USE-SEMI-COLONS (PRIN1 SEMISTRING STREAM) (add HERE SEMIWIDTH))) (GO CHECKESCAPE))) DONE (COND (P2FLG (\OUTCHAR STREAM (CHARCODE %")))) (COND (MAKEMAP (LET ((ENTRY (MAKEMAPENTRY TAIL (AND (NEQ MAKEMAP T) MAKEMAP) MAPX1 MAPY1 (DSPXPOSITION NIL STREAM) (DSPYPOSITION NIL STREAM) (\DEDITFONT# STREAM)))) (replace LONGSTRINGP of ENTRY with T) (COND (SINGLELEFT (replace LONGSTRING1MARGINP of ENTRY with T))) (COND ((EQ (- (DSPRIGHTMARGIN NIL STREAM) LMARG) RMARG) (* ;; "Assume that RMARG not equal to stream's right margin only happens for centered comments. In reality, it happens as well inside REPP, where RESETCLIP hides the true right margin.") (replace LONGSTRINGSYMMETRICP of ENTRY with T))))) ((EQ USE-SEMI-COLONS 5) (PRIN1 "|#" STREAM))) (RETURN))) ) (SEMI-COLON-COMMENT-P (LAMBDA (E) (* ; "Edited 20-Sep-87 18:30 by raf") (* ;; "If E is a comment, returns a number giving number of semis (or type).") (SELECTQ (CADR E) (; (* ; "SEdit-style right-margin comment") 1) (;; (* ; "SEdit-style current-indent comment") 2) (;;; (* ; "SEdit-style flush left comment") 3) (;;;; (* ; "Page boundary type comment") 4) (%| (* ; "Balanced (hash vertical bar) comment") 5) NIL)) ) (SUPERPRINT/COMMENT (LAMBDA (L FILE) (* ; "Edited 21-Sep-87 12:35 by raf") (COND ((AND **COMMENT**FLG (NOT FILEFLG) (NOT MAKEMAP)) (* ; "If:") (* ; "There's a shorthand for comments, and") (* ; "We're not printing to a file, and") (* ; "Ww're not making the file map, then") (* ;; "Print out the shorthand version of the comment, watching out for overflowing the current line.") (COND ((> (+ (DSPXPOSITION NIL FILE) (STRINGWIDTH **COMMENT**FLG FILE)) (DSPRIGHTMARGIN NIL FILE)) (PRINENDLINE 0 FILE))) (PRIN1S **COMMENT**FLG NIL FILE)) (T (PROG (COMMENT-LMARGIN COMMENT-RMARGIN RIGHTFLG FLUSH-LEFTP SEMIP BODY) (COND ((SETQ RIGHTFLG (NOT (OR (SUPERPRINTEQ (CADR L) COMMENTFLG) (COND ((SETQ SEMIP (SEMI-COLON-COMMENT-P L)) (* ; "Only 1-semi comments go in right margin") (NEQ SEMIP 1)) (T (* ; "use size heuristic") (> (LENGTH L) 10)))))) (* ; "Print comment in the righthand margin") (SETQ COMMENT-LMARGIN (OR COMMENTCOL (SUPERPRINT/COMMENT1 L RMARGIN FILE))) (SETQ COMMENT-RMARGIN RMARGIN)) ((AND (GEQ SEMIP 3) (NOT MAKEMAP)) (* ; "Comment should be printed flush left. Don't do this with DEdit lest we confuse it") (SETQ COMMENT-LMARGIN 0) (SETQ COMMENT-RMARGIN RMARGIN)) (T (* ; "Print comment centered and wide") (SETQ COMMENT-LMARGIN (FIXR (TIMES 0.1 RMARGIN))) (SETQ COMMENT-RMARGIN (- RMARGIN COMMENT-LMARGIN)) (COND ((EQ COMMENT-LMARGIN (DSPXPOSITION NIL FILE)) (* ;; "HACK: Almost certainly called from REPP, so we must supress the normal leading and trailing blank lines as they have already been done") (SETQ RIGHTFLG T))))) (COND ((< COMMENT-LMARGIN (DSPXPOSITION NIL FILE)) (PRINENDLINE COMMENT-LMARGIN FILE)) (T (DSPXPOSITION COMMENT-LMARGIN FILE))) (SETFONT (PROG1 (SETFONT COMMENTFONT FILE) (COND ((AND SEMIP (NOT MAKEMAP) (STRINGP (SETQ BODY (CAR (LISTP (CDR (LISTP (CDR L))))))) (NULL (CDDDR L)) (OR (IMAGESTREAMP FILE) *PRINT-SEMICOLON-COMMENTS*)) (* ; "do nice semi-colon stuff") (PRIN2-LONG-STRING BODY FILE NIL NIL COMMENT-LMARGIN COMMENT-RMARGIN T SEMIP)) (T (SUPERPRINT/COMMENT2 L COMMENT-LMARGIN (IQUOTIENT (+ COMMENT-LMARGIN COMMENT-RMARGIN) 2) COMMENT-RMARGIN FILE)))) FILE) (COND ((AND SEMIP (NEQ SEMIP 5) (NOT MAKEMAP)) (* ;; "AR 8475 JDS 4/16/87: If there's a semi-colon comment on this line, and we're not making the file map (??), and RIGHTFLG is NIL (whatever that means) then force a new line.") (OR RIGHTFLG (PRINENDLINE 0 FILE)))) (RETURN L))))) ) (\\backspace.read.time.conditional (LAMBDA (node context index) (* ; "Edited 30-Sep-87 14:01 by raf") (if (NULL index) then (* ; "backspace from right boundary puts caret into the read.time.conditional's FORM.") (LET ((point (fetch CaretPoint of context))) (replace PointNode of point with node) (replace PointIndex of point with (CAR (fetch SubNodes of node))) (replace PointType of point with (QUOTE Structure))) (\\set.selection.nowhere (fetch Selection of context)) elseif (ZEROP index) then (* ; "backspace from before first element deletes the read.time.conditional if its empty.") (if (NULL (CDR (fetch SubNodes of node))) then (\\delete (fetch SuperNode of node) context node NIL (fetch CaretPoint of context))) else (* ; "backspacing after an element of the read.time.conditional is handled by that subnode.") (SETQ node (\\subnode index node)) (APPLY* (fetch BackSpace of (fetch NodeType of node)) node context))) ) (\\cfv.clisp (LAMBDA (x environment) (* ; "Edited 21-Sep-87 11:40 by raf") (* compute the width estimates for a clisp expression) (bind (pwidth _ 0) (mwidth _ 0) (iwidth _ 0) (first.subnode _ T) (paren.width _ (fetch Width of (fetch LParenString of environment))) (space.width _ (fetch SpaceWidth of environment)) plll mlll indent pcomment.indent mcomment.indent first (SETQ indent paren.width) (SETQ pcomment.indent paren.width) (SETQ mcomment.indent paren.width) for subnode in (CDR (fetch SubNodes of x)) do (if (EQ (fetch NodeType of subnode) \\type.comment) then (SELECTQ (fetch Unassigned of subnode) (1 (SETQ pwidth (IMAX pwidth (IPLUS pcomment.indent (fetch PreferredWidth of subnode)))) (SETQ mwidth (IMAX mwidth (IPLUS mcomment.indent (fetch MinWidth of subnode))))) ((2 3 4 5) (SETQ pwidth (IMAX pwidth (IPLUS indent (fetch PreferredWidth of subnode)))) (SETQ mwidth (IMAX mwidth (IPLUS indent (fetch MinWidth of subnode))))) (SHOULDNT "unexpected value for comment level")) (SETQ plll (SETQ mlll paren.width)) (SETQ iwidth NIL) else (if iwidth then (if (fetch InlineWidth of subnode) then (SETQ iwidth (IPLUS iwidth (if (ZEROP iwidth) then paren.width else space.width) (fetch InlineWidth of subnode))) else (SETQ iwidth NIL))) (if (AND (NOT first.subnode) (EQ (fetch ParseMode of subnode) (QUOTE KeyWord))) then (* indentable keywords are indented by the minimum indentation, except for the first keyword of the expression. other keywords are only indented by the width of the left parenthesis) (if (AND (MEMB (CDR (GETPROP (fetch Structure of subnode) (QUOTE CLISPWORD))) \\clisp.indent.words) (NOT first.subnode)) then (SETQ indent (fetch MinIndent of environment)) else (SETQ indent paren.width) (SETQ iwidth NIL))) (SETQ plll (IPLUS indent (fetch PreferredLLength of subnode))) (SETQ mlll (IPLUS indent (fetch MinLLength of subnode))) (SETQ pcomment.indent plll) (SETQ mcomment.indent mlll) (SETQ pwidth (IMAX pwidth (IPLUS (fetch PreferredWidth of subnode) indent))) (SETQ mwidth (IMAX mwidth (IPLUS (fetch MinWidth of subnode) indent))) (if (EQ (fetch ParseMode of subnode) (QUOTE KeyWord)) then (* the subnodes following a keyword are indented by the keyword's indentation plus its width plus a blank) (SETQ indent (IPLUS indent (fetch InlineWidth of subnode) space.width))) (SETQ first.subnode NIL)) finally (replace InlineWidth of x with (AND iwidth (ILESSP iwidth (fetch MaxWidth of environment)) (IPLUS iwidth paren.width))) (replace PreferredWidth of x with (IMAX pwidth (replace PreferredLLength of x with (IPLUS plll paren.width)))) (replace MinWidth of x with (IMAX mwidth (replace MinLLength of x with (IPLUS mlll paren.width)))))) ) (\\cfv.comment (LAMBDA (node environment context) (* ; "Edited 18-Sep-87 17:58 by raf") (* ; "compute the width estimates for a comment node") (replace InlineWidth of node with NIL) (* ; "dispatch on the comment level") (LET ((width (fetch CommentWidth of context))) (SELECTQ (fetch Unassigned of node) (1 (* ; "here we know the comment width") (replace PreferredWidth of node with width) (replace MinWidth of node with width) (replace PreferredLLength of node with width) (replace MinLLength of node with width)) (2 (* ; "here just guess twice single semi comment width") (replace PreferredWidth of node with (ITIMES 2 width)) (replace MinWidth of node with width) (replace PreferredLLength of node with (ITIMES 2 width)) (replace MinLLength of node with width)) ((3 4 5) (* ; "since these won't affect supernode's formattng, just guess small") (replace PreferredWidth of node with 30) (replace MinWidth of node with 30) (replace PreferredLLength of node with 30) (replace MinLLength of node with 30)) (SHOULDNT "unexpected value for comment level")))) ) (\\cfv.form (LAMBDA (x environment) (* ; "Edited 20-Sep-87 18:00 by raf") (* compute the width estimates for a lisp function call) (bind (pwidth _ 0) (mwidth _ 0) (iwidth _ 0) (first.subnode _ T) (paren.width _ (fetch Width of (fetch LParenString of environment))) (space.width _ (fetch SpaceWidth of environment)) plll mlll indent pcomment.indent mcomment.indent first (if (NULL (CDR (fetch SubNodes of x))) then (SETQ pwidth (ITIMES paren.width 2)) (replace InlineWidth of x with pwidth) (replace PreferredLLength of x with pwidth) (replace PreferredWidth of x with pwidth) (replace MinLLength of x with pwidth) (replace MinWidth of x with pwidth) (RETURN)) (SETQ indent paren.width) (SETQ pcomment.indent paren.width) (SETQ mcomment.indent paren.width) for subnode in (CDR (fetch SubNodes of x)) do (if (EQ (fetch NodeType of subnode) \\type.comment) then (SELECTQ (fetch Unassigned of subnode) (1 (SETQ pwidth (IMAX pwidth (IPLUS pcomment.indent (fetch PreferredWidth of subnode)))) (SETQ mwidth (IMAX mwidth (IPLUS mcomment.indent (fetch MinWidth of subnode))))) ((2 3 4 5) (SETQ pwidth (IMAX pwidth (IPLUS indent (fetch PreferredWidth of subnode)))) (SETQ mwidth (IMAX mwidth (IPLUS indent (fetch MinWidth of subnode))))) (SHOULDNT "unexpected value for comment level")) (SETQ plll (SETQ mlll paren.width)) (SETQ iwidth NIL) else (if iwidth then (if (fetch InlineWidth of subnode) then (SETQ iwidth (IPLUS iwidth (if (ZEROP iwidth) then paren.width else space.width) (fetch InlineWidth of subnode))) else (SETQ iwidth NIL))) (SETQ plll (IPLUS indent (fetch PreferredLLength of subnode))) (SETQ mlll (IPLUS indent (fetch MinLLength of subnode))) (SETQ pcomment.indent plll) (SETQ mcomment.indent mlll) (SETQ pwidth (IMAX pwidth (IPLUS (fetch PreferredWidth of subnode) indent))) (SETQ mwidth (IMAX mwidth (IPLUS (fetch MinWidth of subnode) indent))) (if first.subnode then (* the remaining subnodes are indented by the width of the CAR, unless it's too wide or won't go inline) (SETQ indent (if (AND iwidth (OR (ATOM (fetch Structure of subnode)) (ILESSP iwidth (fetch DefaultIndent of environment))) (ILESSP iwidth (fetch MaxIndent of environment))) then (IPLUS iwidth space.width) else (fetch DefaultIndent of environment))) (SETQ first.subnode NIL))) finally (replace InlineWidth of x with (AND iwidth (ILESSP iwidth (fetch MaxWidth of environment)) (IPLUS iwidth paren.width))) (replace PreferredWidth of x with (IMAX pwidth (replace PreferredLLength of x with (IPLUS plll paren.width)))) (replace MinWidth of x with (IMAX mwidth (replace MinLLength of x with (IPLUS mlll paren.width)))) (replace Unassigned of x with indent))) ) (\\cfv.lambda (LAMBDA (x environment) (* ; "Edited 21-Sep-87 11:37 by raf") (* ;; "compute the width estimates for a lambda expression or similar structure. PROGs and PROG*s also go through here, but are treated specially (because of the labels)") (bind (pwidth _ 0) (mwidth _ 0) (first.subnode _ T) (prog? _ (MEMB (fetch Structure of (CADR (fetch SubNodes of x))) (QUOTE (PROG PROG* NIL)))) (paren.width _ (fetch Width of (fetch LParenString of environment))) plll mlll indent pcomment.indent mcomment.indent first (SETQ indent paren.width) (SETQ pcomment.indent paren.width) (SETQ mcomment.indent paren.width) for subnode in (CDR (fetch SubNodes of x)) do (if (EQ (fetch NodeType of subnode) \\type.comment) then (SELECTQ (fetch Unassigned of subnode) (1 (SETQ pwidth (IMAX pwidth (IPLUS pcomment.indent (fetch PreferredWidth of subnode)))) (SETQ mwidth (IMAX mwidth (IPLUS mcomment.indent (fetch MinWidth of subnode))))) ((2 3 4 5) (SETQ pwidth (IMAX pwidth (IPLUS indent (fetch PreferredWidth of subnode)))) (SETQ mwidth (IMAX mwidth (IPLUS indent (fetch MinWidth of subnode))))) (SHOULDNT "unexpected value for comment level")) (SETQ plll (SETQ mlll paren.width)) else (if (AND prog? (ATOM (fetch Structure of subnode)) (NULL (fetch ParseMode of subnode))) then (* ; "it's a label -- only indentation is the width of a paren") (SETQ indent paren.width)) (SETQ plll (IPLUS indent (fetch PreferredLLength of subnode))) (SETQ mlll (IPLUS indent (fetch MinLLength of subnode))) (SETQ pcomment.indent plll) (SETQ mcomment.indent mlll) (SETQ pwidth (IMAX pwidth (IPLUS (fetch PreferredWidth of subnode) indent))) (SETQ mwidth (IMAX mwidth (IPLUS (fetch MinWidth of subnode) indent))) (if first.subnode then (* ; "the second (noncomment) subnode (i.e. the arg list) is indented by the width of the keyword") (SETQ indent (IPLUS paren.width (fetch PreferredWidth of subnode) (fetch SpaceWidth of environment))) (SETQ first.subnode NIL) else (SETQ indent (fetch MinIndent of environment)))) finally (* ; "these things deserve a line to themselves") (replace InlineWidth of x with NIL) (replace PreferredWidth of x with (IMAX pwidth (replace PreferredLLength of x with (IPLUS plll paren.width)))) (replace MinWidth of x with (IMAX mwidth (replace MinLLength of x with (IPLUS mlll paren.width)))))) ) (\\cfv.read.time.conditional (LAMBDA (node environment context) (* ; "Edited 30-Sep-87 16:24 by raf") (LET ((hash.width (fetch Width of (LISTGET (fetch QuoteString of environment) :HASH))) (sign (CADR (fetch SubNodes of node))) (feature (CADDR (fetch SubNodes of node))) (form (CADDDR (fetch SubNodes of node)))) (LET ((total.width (IPLUS hash.width (fetch InlineWidth of sign) (fetch InlineWidth of feature) (fetch InlineWidth of form)))) (replace InlineWidth of node with total.width) (replace PreferredWidth of node with total.width) (replace MinWidth of node with total.width) (replace PreferredLLength of node with (fetch MinLLength of sign)) (replace MinLLength of node with (fetch MinLLength of sign))))) ) (\\compute.point.position.read.time.conditional (LAMBDA (point context) (* ; "Edited 30-Sep-87 17:09 by raf") (LET ((node (fetch PointNode of point)) subnode item) (if (ZEROP (fetch PointIndex of point)) then (* ;; "Before the first element -- right after the hash, which we assume is the first item in the linear form.") (replace PointX of point with (IPLUS (fetch StartX of node) (fetch Width of (CAR (fetch LinearForm of node))))) (replace PointLine of point with (fetch FirstLine of node)) else (* ; "Find the subnode the point will follow.") (SETQ subnode (\\subnode (fetch PointIndex of point) node)) (replace PointLine of point with (fetch LastLine of subnode)) (SETQ item (CADR (fetch LinearThread of subnode))) (replace PointX of point with (IPLUS (fetch StartX of subnode) (fetch ActualLLength of subnode) (if (SMALLP item) then (* ; "it's followed by space -- put the caret in the middle") (IMIN (HALF item) 6) else (* ; "it's followed by something else -- presumably the close paren -- so put the caret immediately after it") 0)))))) ) (\\copy.structure.new.quote [LAMBDA (node) (* ; "Edited 27-Jul-87 16:15 by raf") (replace Structure of node with (LET [(struc (TM::COPY-PREFIX-QUOTE (fetch Structure of node] (CL:SETF (TM::PREFIX-QUOTE-CONTENTS struc) (fetch Structure of (\\subnode 1 node))) struc]) (\\copy.structure.read.time.conditional (LAMBDA (node) (* ; "Edited 30-Sep-87 13:56 by raf") (replace Structure of node with (CL:FUNCALL (CL:ETYPECASE (fetch Structure of node) (TM::HASH-PLUS (QUOTE TM::COPY-HASH-PLUS)) (TM::HASH-MINUS (QUOTE TM::COPY-HASH-MINUS))) (fetch Structure of node)))) ) (\\create.new.quoted.gap [LAMBDA (gap context quote.type) (* ; "Edited 27-Jul-87 16:15 by raf") (* ;;; "Create a new quote structure with a gap in it, and the node to represent it.") (LET* [(gap.node (\\create.gap.node gap)) (quote.node (create EditNode NodeType _ \\type.new.quote Structure _ (TM::MAKE-PREFIX-QUOTE :TYPE quote.type :PREFIX (fetch (StringItem String) of (LISTGET (fetch QuoteString of (fetch Environment of context)) quote.type)) :CONTENTS gap) SubNodes _ (LIST 1 gap.node) Unassigned _ (LISTGET (fetch QuoteString of (fetch Environment of context)) quote.type] (replace SuperNode of gap.node with quote.node) (replace SubNodeIndex of gap.node with 1) (replace SelfLink of quote.node with (create WeakLink Destination _ quote.node)) (replace LinearForm of quote.node with (fetch SelfLink of quote.node)) (\\note.change quote.node context) quote.node]) (\\degrade.comment (LAMBDA (context node) (* ; "Edited 18-Sep-87 19:09 by raf") (RPLACA (CDR (fetch Structure of node)) (CAR (NTH \\comment.markers (add (fetch Unassigned of node) -1)))) (\\note.change node context) (if (fetch SuperNode of (fetch SuperNode of node)) then (* ; "this node has a supernode that is not the root") (\\note.change (fetch SuperNode of node) context)) (\\undo.by \\upgrade.comment node)) ) (\\delete.read.time.conditional (LAMBDA (node context start end set.point?) (* ; "Edited 1-Oct-87 16:33 by raf") (* ;; "Replace any deleted subnodes with gaps, since this is a fixed length object.") (if (NOT (SMALLP start)) then (SETQ start (fetch SubNodeIndex of start)) (SETQ end start)) (\\replace.read.time.conditional node context start end (for i from start to end collect (\\create.gap.node \\basic.gap))) (if set.point? then (\\set.selection.me (fetch Selection of context) context (\\subnode end node)) (\\pending.delete set.point? (fetch Selection of context))) T) ) (\\initialize.commonlisp (LAMBDA NIL (* ; "Edited 1-Oct-87 11:04 by raf") "Creates SEdit nodes for Common Lisp presentation types. Fully re-entrant." (* ;; "Hash o, x, b, comma, and dot are handled with a variant of the existing quote node. Hash vertical bar, plus, minus, and star are more or less new types.") (LET ((PLIST (fetch (EditENV ParseInfo) of \\lisp.edit.environment))) (MAPC (QUOTE ((TM::HASH-B . \\parse..new.quote) (TM::HASH-COMMA . \\parse..new.quote) (TM::HASH-DOT . \\parse..new.quote) (TM::HASH-O . \\parse..new.quote) (TM::HASH-X . \\parse..new.quote) (TM::HASH-MINUS . \\parse..conditional.read) (TM::HASH-PLUS . \\parse..conditional.read))) (FUNCTION (LAMBDA (CELL) (LISTPUT PLIST (CAR CELL) (CDR CELL)))))) (LET ((PLIST (fetch (EditENV QuoteString) of \\lisp.edit.environment)) (FONT (fetch (EditENV DefaultFont) of \\lisp.edit.environment))) (MAPC (LIST (CONS :HASH-DOT (\\create.string.item "#." FONT)) (CONS :HASH-COMMA (\\create.string.item "#," FONT)) (CONS :HASH-O (\\create.string.item "#o" FONT)) (CONS :HASH-X (\\create.string.item "#x" FONT)) (CONS :HASH-B (\\create.string.item "#b" FONT)) (CONS :HASH (\\create.string.item "#" FONT))) (FUNCTION (LAMBDA (CELL) (LISTPUT PLIST (CAR CELL) (CDR CELL)))))) (* ;;; "Fix comments to allow 4 semicolon and balanced (hash bar) comments.") (if (NOT (FMEMB (QUOTE %|) (fetch (EditENV CommentString) of \\lisp.edit.environment))) then (LET ((FONT (fetch (EditENV CommentFont) of \\lisp.edit.environment))) (replace (EditENV CommentString) of \\lisp.edit.environment with (LIST 1 (\\create.string.item ";" FONT) 2 (\\create.string.item ";;" FONT) 3 (\\create.string.item ";;;" FONT) 4 (\\create.string.item ";;;;" FONT) 5 (\\create.string.item "#|" FONT))))) (SETQ \\type.new.quote (create EditNodeType using \\type.root Name _ (QUOTE new.quote) ComputeFormatValues _ (QUOTE \\cfv.quote) Linearize _ (QUOTE \\linearize.quote) SubNodeChanged _ (QUOTE \\subnode.changed.new.quote) SetPoint _ (QUOTE \\set.point.quote) SetSelection _ (QUOTE \\set.selection.quote) GrowSelection _ (QUOTE \\grow.selection.default) Insert _ (QUOTE \\replace.new.quote) Delete _ (QUOTE \\delete.quote) CopyStructure _ (QUOTE \\copy.structure.new.quote) CopySelection _ (QUOTE \\copy.selection.default) Stringify _ (QUOTE \\stringify.quote) BackSpace _ (QUOTE \\backspace.quote))) (SETQ \\type.read.time.conditional (create EditNodeType using \\type.root Name _ (QUOTE read.time.conditional) ComputeFormatValues _ (QUOTE \\cfv.read.time.conditional) ReParse _ (QUOTE HELP) Linearize _ (QUOTE \\linearize.read.time.conditional) SubNodeChanged _ (QUOTE \\subnode.changed.read.time.conditional) ComputePointPosition _ (QUOTE \\compute.point.position.read.time.conditional) ComputeSelectionPosition _ (QUOTE \\compute.selection.position.default) SetPoint _ (QUOTE \\set.point.read.time.conditional) SetSelection _ (QUOTE \\set.selection.read.time.conditional) GrowSelection _ (QUOTE \\grow.selection.default) Insert _ (QUOTE \\insert.read.time.conditional) Delete _ (QUOTE \\delete.read.time.conditional) CopyStructure _ (QUOTE \\copy.structure.read.time.conditional) CopySelection _ (QUOTE \\copy.selection.default) Stringify _ (QUOTE \\stringify.read.time.conditional) BackSpace _ (QUOTE \\backspace.read.time.conditional))) (LET ((inserted.nq NIL) (inserted.rtc NIL)) (for typetail on \\types do (if (EQ (fetch Name of \\type.new.quote) (fetch Name of (CAR typetail))) then (SETQ inserted.nq T) (RPLACA typetail \\type.new.quote) elseif (EQ (fetch Name of \\type.read.time.conditional) (fetch Name of (CAR typetail))) then (SETQ inserted.rtc T) (RPLACA typetail \\type.read.time.conditional))) (if (NOT inserted.nq) then (SETQ \\types (LIST* \\type.new.quote \\types))) (if (NOT inserted.rtc) then (SETQ \\types (LIST* \\type.read.time.conditional \\types)))) (* ;; "Commands which enter the hash objects (very hard to do this right).") (LET ((commands (\\create.command.table (APPEND (QUOTE (((\\input.new.quote :HASH-DOT) NIL 3) ((\\input.new.quote :HASH-COMMA) NIL 6) ((\\input.new.quote :HASH-O) NIL 9) ((\\input.new.quote :HASH-X) NIL 10) ((\\input.new.quote :HASH-B) NIL 11) ((\\input.conditional.read :HASH-PLUS) NIL 18) ((\\input.conditional.read :HASH-MINUS) NIL 14) (\\input.bit.vector NIL 17))) \\command.table.spec)))) (replace (EditENV CommandTable) of \\lisp.edit.environment with (CAR commands)) (replace (EditENV HelpMenu) of \\lisp.edit.environment with (CADR commands))) T) ) (\\input.bit.vector [LAMBDA (context charcode type) (* ; "Edited 15-Jul-87 16:32 by raf") (HELP "Unimplemented"]) (\\input.conditional.read [LAMBDA (context charcode type) (* ; "Edited 15-Jul-87 16:32 by raf") (HELP "Unimplemented"]) (\\input.new.quote [LAMBDA (context charcode quote.type) (* ; "Edited 15-Jul-87 17:53 by raf") (* ;;; "Control character command to insert a new quote type with gap.") (SELECTQ (\\type.of.input context) (Structure (* ; "If we're structure pointing (between the hairs of the universe) a new quote object is made and inserted.") (\\close.open.node context) (\\insert.new.quoted.gap context charcode quote.type)) (Atom (* ; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (APPLY* (fetch DefaultCharHandler of (fetch Environment of context)) context charcode)) NIL]) (\\insert.new.quoted.gap [LAMBDA (context charcode quote.type) (* ; "Edited 15-Jul-87 18:01 by raf") (* ;  "implements the ' command: insert a quoted gap") (if (EQ (\\type.of.input context) 'Structure) then (LET ((selection (fetch Selection of context)) (point (fetch CaretPoint of context)) new.quote gap) (SETQ new.quote (\\create.new.quoted.gap \\basic.gap context quote.type)) (SETQ gap (\\subnode 1 new.quote)) (* ;  "we get our hands on the gap node now, to handle the case where the insert reparses the new.quote") (\\insert (fetch CaretPoint of context) context (LIST new.quote)) (if (NOT (\\dead.node? new.quote)) then (\\set.selection.me selection context gap) (\\pending.delete point selection))) (* ;  "must return non-NIL if command executed") T]) (\\insert.read.time.conditional (LAMBDA (node context where subnodes point) (* ; "Edited 1-Oct-87 11:05 by raf") (LET (start end) (if (type? EditSelection where) then (SETQ start (fetch SelectStart of where)) (SETQ end (OR (fetch SelectEnd of where) start)) elseif (type? EditPoint where) then (SETQ end (fetch PointIndex of where)) (SETQ start (ADD1 end)) else (SETQ start (fetch SubNodeIndex of where)) (SETQ end start)) (\\replace.read.time.conditional node context start end subnodes point))) ) (\\linearize.clisp (LAMBDA (node context index) (* ; "Edited 21-Sep-87 11:45 by raf") (* ;; "the Linearize method for clisp expressions. the variable ok keeps track of our state: (NIL: next item starts a new line) (T: next item stays on this line) (check: next item goes on this line if it fits) (atom: next item goes on this line if it fits and is an atom)") (* ;; "the formatting rules are that (1) keywords not on \\clisp.indent.words always start new lines (2) always start a new line after anything non-atomic (3) non-atomic things can only follow keywords on the same line (4) \\clisp.indent.words can go on the same line as the preceding material if they're the last thing in the expression or followed by another keyword or by something that will fit inline on the same line (5) if \\clisp.indent.words start a new line they are indented by the minimum indentation (6) if anything else starts a new line it is indented by the width of the most recent keyword to start a line, plus one blank") (* ;; "at present, if keywords always start new lines. this could be improved with a little more smarts") (bind indent comment.start.x comment.indent comment? program.word? (keyword? _ T) (second.subnode _ T) (ok _ T) (space.width _ (fetch SpaceWidth of (fetch Environment of context))) (min.indent _ (IPLUS (fetch StartX of node) (fetch MinIndent of (fetch Environment of context)))) (paren.width _ (fetch Width of (fetch LParenString of (fetch Environment of context)))) first (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) else (* ;; "start with an open paren and the first subnode (which should be a keyword) since system won't recognize clisp if first subnode is comment, don't have to handle that case here. it will be formatted as a form.") (\\output.constant.string context (fetch LParenString of (fetch Environment of context))) (\\linearize (CADR (fetch SubNodes of node)) context)) (* ;; "set indentation to one blank after the end of the keyword") (SETQ indent (IPLUS (fetch StartX of node) paren.width (fetch InlineWidth of (CADR (fetch SubNodes of node))) space.width)) (\\set.comment.positions comment.start.x comment.indent indent paren.width node context) for subnode in (CDDR (fetch SubNodes of node)) do (if index then (* ;; "we don't actually linearize this subnode, but need to update our state as if we had") (SETQ index (AND (NEQ index 1) (SUB1 index))) (if (SETQ comment? (EQ (fetch NodeType of subnode) \\type.comment)) then (* ;; "this is a comment, so the next guy must start a new line. if following the first keyword, change indent to min.indent") (SETQ ok NIL) (if second.subnode then (SETQ indent min.indent)) elseif (SETQ keyword? (EQ (fetch ParseMode of subnode) (QUOTE KeyWord))) then (* ; "this is a keyword. is it the first thing on this line?") (if (EQ subnode (CADR (MEMB (fetch LastLine of subnode) (fetch LinearForm of node)))) then (* test used to be EQ subnode (CADR (fetch LastLineLinear of subnode))) (* ; "yep. set the indentation to be one blank after the end of it") (SETQ indent (IPLUS (fetch StartX of subnode) (fetch InlineWidth of subnode) space.width)) (* ; "and the next thing goes on this line") (SETQ ok T) else (* ; "the next thing goes on this line if it fits") (SETQ ok (QUOTE check))) else (* ; "the next thing can go on this line if i'm atomic, and it's atomic too") (SETQ ok (AND (ATOM (fetch Structure of subnode)) (QUOTE atom)))) else (* ; "we really are linearizing this subnode") (if (SETQ comment? (EQ (fetch NodeType of subnode) \\type.comment)) then (if (OR (NEQ (fetch Unassigned of subnode) 1) (IGREATERP (fetch CurrentX of context) comment.start.x)) then (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent indent (fetch StartX of (fetch Root of context)))) else (\\output.space context (IDIFFERENCE comment.indent (fetch CurrentX of context)))) (SETQ ok NIL) (if second.subnode then (SETQ indent min.indent)) elseif (SETQ keyword? (EQ (fetch ParseMode of subnode) (QUOTE KeyWord))) then (* ; "we've got a keyword") (SETQ program.word? (FMEMB (CDR (GETPROP (fetch Structure of subnode) (QUOTE CLISPWORD))) \\clisp.program.words)) (if (FMEMB (CDR (GETPROP (fetch Structure of subnode) (QUOTE CLISPWORD))) \\clisp.indent.words) then (* ; "perhaps it can go on this line") (if (AND ok (NEQ (fetch Unassigned of node) (QUOTE IFWORD)) (ILEQ (IPLUS (fetch CurrentX of context) space.width (fetch InlineWidth of subnode) (if (AND (CDR $$LST1) (NEQ (fetch ParseMode of (CADR $$LST1)) (QUOTE KeyWord))) then (IPLUS space.width (OR (fetch InlineWidth of (CADR $$LST1)) (fetch RightMargin of node))) else 0)) (fetch RightMargin of node))) then (* ; "it'll go on this line") (\\output.space context space.width) (SETQ ok (QUOTE check)) else (* ; "new line, indented by minimum indentation") (\\output.cr context min.indent) (SETQ indent (IPLUS min.indent (fetch InlineWidth of subnode) space.width)) (SETQ ok T)) else (* ; "new line, no indentation") (\\output.cr context (IPLUS (fetch StartX of node) paren.width)) (SETQ indent (IPLUS (fetch StartX of node) paren.width (fetch InlineWidth of subnode) space.width)) (SETQ ok T)) else (if (OR (EQ ok T) (AND ok (fetch InlineWidth of subnode) (ILEQ (IPLUS (fetch CurrentX of context) space.width (fetch InlineWidth of subnode)) (fetch RightMargin of node)) (OR (EQ ok (QUOTE check)) (ATOM (fetch Structure of subnode))))) then (\\output.space context space.width) else (\\output.cr context indent)) (SETQ ok (QUOTE atom))) (\\linearize subnode context) (if (AND (EQ ok (QUOTE atom)) (NOT (fetch Inline? of subnode))) then (SETQ ok NIL))) (SETQ second.subnode NIL) finally (if comment? then (\\output.cr context (IPLUS (fetch StartX of node) paren.width)))) (if index then (SHOULDNT "linearize index out of range")) (\\output.constant.string context (fetch RParenString of (fetch Environment of context)))) ) (\\linearize.comment (LAMBDA (node context index) (* ; "Edited 20-Sep-87 18:18 by raf") (LET* ((level (fetch Unassigned of node)) (prefix (LISTGET (fetch CommentString of (fetch Environment of context)) level))) (bind (first _ T) for subnode in (if index then (CDDR (NTH (fetch SubNodes of node) index)) else (* we're at the beginning, so display the prefix) (\\output.constant.string context prefix) (CDR (fetch SubNodes of node))) do (if (OR first (ILEQ (IPLUS (fetch CurrentX of context) (fetch InlineWidth of subnode)) (fetch RightMargin of node))) then (\\linearize subnode context) else (\\output.cr context (fetch StartX of node)) (if (NOT (EQ 5 level)) then (\\output.constant.string context prefix)) (\\linearize subnode context)) (SETQ first NIL)) (if (EQ 5 level) then (\\output.constant.string context \\level5.comment.close.string)))) ) (\\linearize.form (LAMBDA (node context index) (* ; "Edited 20-Sep-87 18:11 by raf") (* ; "the linearize method for forms") (if (NOT index) then (\\output.constant.string context (fetch LParenString of (fetch Environment of context)))) (if (CDR (fetch SubNodes of node)) then (bind (same.line? _ T) (space.width _ (fetch SpaceWidth of (fetch Environment of context))) (paren.width _ (fetch Width of (fetch LParenString of (fetch Environment of context)))) (first.subnode _ T) indent last.comment.level comment.start.x comment.indent line.skip first (SETQ indent (IPLUS (fetch StartX of node) (if (NOT (ATOM (fetch Structure of (CADR (fetch SubNodes of node))))) then (* ;; "this will handle the case of comment first, too, like in COMS. it will be ugly for comment at beginning of function call, but who cares.") paren.width elseif (ILEQ (IPLUS (fetch StartX of node) (fetch PreferredWidth of node)) (fetch RightMargin of node)) then (OR (fetch Unassigned of node) 0) else (fetch MinIndent of (fetch Environment of context))))) (\\set.comment.positions comment.start.x comment.indent (IPLUS paren.width (fetch StartX of node)) paren.width node context) for subnode in (CDR (fetch SubNodes of node)) do (if (EQ (fetch NodeType of subnode) \\type.comment) then (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) else (if (EQ last.comment.level (fetch Unassigned of subnode)) then (* ;; "we're following a comment of the same level. force a cr and extra line space") (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent indent (fetch StartX of (fetch Root of context))) 8) elseif (AND first.subnode (NEQ (fetch Unassigned of subnode) 1)) then (* ;; "dont' have to move at all") elseif (OR first.subnode (AND (EQ (fetch Unassigned of subnode) 1) same.line? (ILEQ (fetch CurrentX of context) comment.start.x))) then (* ;; "just space if first subnode or its a single semi comment that will fit") (\\output.space context (IDIFFERENCE comment.indent (fetch CurrentX of context))) else (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent indent (fetch StartX of (fetch Root of context))))) (\\linearize subnode context)) (SETQ same.line? NIL) (SETQ last.comment.level (fetch Unassigned of subnode)) else (if index then NIL elseif first.subnode then (if (NOT same.line?) then (\\output.cr context (IPLUS paren.width (fetch StartX of node)))) else (if (AND same.line? (NEQ same.line? (QUOTE paren)) (LEQ (IPLUS (fetch CurrentX of context) space.width) indent)) then (* ; "we're to the left of the indentation tab, so just space enough to get there") (\\output.space context (IDIFFERENCE indent (fetch CurrentX of context))) elseif (AND same.line? (NEQ same.line? (QUOTE paren)) (fetch InlineWidth subnode) (LEQ (IPLUS (fetch CurrentX of context) space.width (fetch InlineWidth subnode) (if (AND (CDR $$LST1) (EQ (fetch NodeType of (CADR $$LST1)) \\type.comment) (EQ (fetch Unassigned of (CADR $$LST1)) 1)) then (fetch PreferredWidth of (CADR $$LST1)) else 0)) (fetch RightMargin of node)) (OR (EQ same.line? T) (ILESSP (CAR (fetch SubNodes of subnode)) 2))) then (* ; "it will fit on this line") (\\output.space context space.width) else (\\output.cr context indent))) (SETQ same.line? (OR (AND (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) (fetch Inline? of subnode) else (\\linearize subnode context)) (OR (ILESSP (CAR (fetch SubNodes of subnode)) 2) (QUOTE no.lists))) (QUOTE paren))) (SETQ last.comment.level NIL)) (SETQ first.subnode NIL) finally (if (NULL same.line?) then (\\output.cr context (IPLUS paren.width (fetch StartX of node)))))) (if index then (SHOULDNT "linearize index out of range")) (\\output.constant.string context (fetch RParenString of (fetch Environment of context)))) ) (\\linearize.lambda (LAMBDA (node context index) (* ; "Edited 21-Sep-87 11:52 by raf") (* ;;; "the Linearize method for lambda expressions. the opening keyword and second subnode (the argument list) go on the same line, and everything else is on a separate line indented by the minimum indentation, except for PROG labels which aren't indented. the variable before keeps track of this: it's NIL for the first subnode, space for the second, and cr for all of the remaining subnodes") (if (NOT index) then (\\output.constant.string context (fetch LParenString of (fetch Environment of context)))) (bind (prog? _ (MEMB (fetch Structure of (CADR (fetch SubNodes of node))) (QUOTE (PROG PROG* NIL)))) (indent _ (IPLUS (fetch StartX of node) (fetch MinIndent of (fetch Environment of context)))) (paren.width _ (fetch Width of (fetch LParenString of (fetch Environment of context)))) comment? comment.start.x comment.indent first (\\set.comment.positions comment.start.x comment.indent indent paren.width node context) for subnode in (CDR (fetch SubNodes of node)) as subnode.count from 1 do (SETQ comment? (EQ (fetch NodeType of subnode) \\type.comment)) (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) else (if comment? then (if (OR (NEQ (fetch Unassigned of subnode) 1) (IGREATERP (fetch CurrentX of context) comment.start.x)) then (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent indent (fetch StartX of (fetch Root of context)))) else (\\output.space context (IDIFFERENCE comment.indent (fetch CurrentX of context)))) elseif (IGREATERP subnode.count 2) then (* ; "we're past the special cases of lambda keyword and arglist") (\\output.cr context (if (AND prog? (EQ (fetch NodeType of subnode) \\type.litatom)) then (IPLUS (fetch StartX of node) paren.width) else indent)) elseif (EQ subnode.count 2) then (* ; "at the second subnode which is not a comment, so it is the arglist in the proper position") (\\output.space context (fetch SpaceWidth of (fetch Environment of context)))) (* ; "otherwise, we're at first non comment, which must be the lambda keyword, so just linearize it here") (\\linearize subnode context)) finally (if comment? then (\\output.cr context (IPLUS (fetch StartX of node) paren.width)))) (if index then (SHOULDNT "linearize index out of range")) (\\output.constant.string context (fetch RParenString of (fetch Environment of context)))) ) (\\linearize.list (LAMBDA (node context index) (* ; "Edited 21-Sep-87 11:54 by raf") (* ;; "the Linearize method for vanilla and dotted lists. nothing is indented, non-atomic things go on separate lines, and we put as many atoms on a line as we can fit. the last element of a dotted list is preceded by a dot.") (if (NOT index) then (\\output.constant.string context (fetch LParenString of (fetch Environment of context)))) (if (CDR (fetch SubNodes of node)) then (bind (first.time? _ T) (space.width _ (fetch SpaceWidth of (fetch Environment of context))) (paren.width _ (fetch Width of (fetch LParenString of (fetch Environment of context)))) this.line? needs.dot? comment? comment.start.x comment.indent first (\\set.comment.positions comment.start.x comment.indent paren.width paren.width node context) for subnode in (CDR (fetch SubNodes of node)) do (SETQ comment? (EQ (fetch NodeType of subnode) \\type.comment)) (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) (if comment? then (\\output.cr context (IPLUS paren.width (fetch StartX of node)))) else (SETQ needs.dot? (AND (EQ (fetch NodeType of node) \\type.dotlist) (NULL (CDR $$LST1)) (IPLUS space.width (fetch Width of (fetch DotString of (fetch Environment of context)))))) (if comment? then (SETQ first.time? NIL) (if (OR (NEQ (fetch Unassigned of subnode) 1) (IGREATERP (fetch CurrentX of context) comment.start.x)) then (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent (IPLUS paren.width (fetch StartX of node)) (fetch StartX of (fetch Root of context)))) else (\\output.space context (IDIFFERENCE comment.indent (fetch CurrentX of context)))) elseif (AND first.time? (NOT comment?)) then (* ; "first time through, if not a comment, then i'm already in the right place for the first subnode") (SETQ first.time? NIL) elseif (AND this.line? (NULL (CDR (fetch SubNodes of subnode))) (LEQ (IPLUS (fetch CurrentX of context) space.width (fetch InlineWidth subnode) (OR needs.dot? 0)) (fetch RightMargin of node))) then (* ; "the last node said i could go on this line, i'm atomic so i can go on this line, and i will fit") (\\output.space context space.width) else (* ; "somebody forced be to the next line") (\\output.cr context (IPLUS paren.width (fetch StartX of node)))) (if needs.dot? then (\\output.constant.string context (fetch DotString of (fetch Environment of context))) (\\output.space context space.width)) (\\linearize subnode context)) (SETQ this.line? (AND (NOT comment?) (NULL (CDR (fetch SubNodes of subnode))))) finally (if comment? then (\\output.cr context (IPLUS paren.width (fetch StartX of node)))))) (if index then (SHOULDNT "linearize index out of range")) (\\output.constant.string context (fetch RParenString of (fetch Environment of context)))) ) (\\linearize.read.time.conditional (LAMBDA (node context right.margin) (* ; "Edited 30-Sep-87 16:26 by raf") (LET ((hash (LISTGET (fetch QuoteString of (fetch Environment of context)) :HASH)) (sign (CADR (fetch SubNodes of node))) (feature (CADDR (fetch SubNodes of node))) (form (CADDDR (fetch SubNodes of node)))) (\\output.constant.string context hash) (\\linearize sign context right.margin) (\\linearize feature context right.margin) (\\linearize form context right.margin))) ) (\\parse..bit.vector [LAMBDA (structure context mode) (* ; "Edited 15-Jul-87 16:29 by raf") (HELP "Unimplemented"]) (\\parse..comment (LAMBDA (structure context) (* ; "Edited 18-Sep-87 18:59 by raf") (* ;; "try to parse this list as a common lisp comment. the second element should be one or more semicolons, and the rest of the list should be a string") (LET (comment.words (level (AND (CDR structure) (LISTGET \\comment.level.table (CADR structure))))) (if (AND level (CDDR structure) (NULL (CDDDR structure)) (STRINGP (CADDR structure)) (OR (NULL (fetch CurrentNode of context)) (FMEMB (fetch Name of (fetch NodeType of (fetch CurrentNode of context))) (QUOTE (form clisp lambda list))))) then (\\build.node structure context \\type.comment NIL T) (if (NOT (fetch \X of context)) then (* ;; "we're here for the first time (not a reparse) so go ahead. otherwize lie and say that everything matched. we do this because comment words are kept in lists in the comment subnodes. parsing conses these lists anew each time, so reparsing a comment that hadn't changed would think that it *had* changed because of the new lists. so hack this to avoid lots of relinearizing comments.") (SETQ comment.words (\\parse.string.into.words (CADDR structure))) (for word in comment.words do (\\parse word context (QUOTE CommentWord))) (for subnode in (CDR (fetch SubNodes of (fetch CurrentNode of context))) as wordptr on comment.words do (replace Structure of subnode with wordptr)) (replace Unassigned of (fetch CurrentNode of context) with level) else (* ;; "flag that everything matched.") (replace \X of context with NIL)) T))) ) (\\parse..conditional.read (LAMBDA (structure context mode) (* ; "Edited 30-Sep-87 16:21 by raf") (if (TM::READ-TIME-CONDITIONAL-P structure) then (\\build.node structure context \\type.read.time.conditional) (replace Unassigned of (fetch CurrentNode of context) with (TM::READ-TIME-CONDITIONAL-UNREAD-P structure)) (\\parse (CL:ETYPECASE structure (TM::HASH-PLUS (QUOTE +)) (TM::HASH-MINUS (QUOTE -))) context NIL) (\\parse (TM::READ-TIME-CONDITIONAL-FEATURE structure) context NIL) (\\parse (TM::READ-TIME-CONDITIONAL-FORM structure) context NIL) T)) ) (\\parse..new.quote [LAMBDA (structure context mode) (* ; "Edited 27-Jul-87 16:19 by raf") (if (AND (OR (NULL mode) (EQ mode 'Data)) (TM::PREFIX-QUOTE-CONTENTS structure)) then (\\build.node structure context \\type.new.quote) (replace Unassigned of (fetch CurrentNode of context) with (LISTGET (fetch QuoteString of (fetch Environment of context)) (TM::PREFIX-QUOTE-TYPE structure))) (\\parse (TM::PREFIX-QUOTE-CONTENTS structure) context NIL) T]) (\\replace.new.quote [LAMBDA (node context where subnodes point) (* ; "Edited 27-Jul-87 16:20 by raf") (LET ((subnode (CAR subnodes))) (if (NOT (OR (AND (type? EditSelection where) (EQ (fetch SelectStart of where) 1) (EQ (fetch SelectEnd of where) 1)) (type? EditNode where))) then (SHOULDNT "weird bounds for replace.quote")) (\\undo.by \\undo.replace.quote node (\\subnode 1 node)) (\\kill.node (\\subnode 1 node)) (RPLACA (CDR (fetch SubNodes of node)) subnode) (replace SuperNode of subnode with node) (replace SubNodeIndex of subnode with 1) (CL:SETF (TM::PREFIX-QUOTE-CONTENTS (fetch Structure of node)) (fetch Structure of subnode)) (\\set.depth subnode (ADD1 (fetch Depth of node))) (\\note.change node context) (if point then (\\punt.set.point point context node T)) (CDR subnodes]) (\\replace.read.time.conditional (LAMBDA (node context start end subnodes point) (* ; "Edited 1-Oct-87 17:05 by raf") (\\undo.by \\undo.replace.read.time.conditional node (for i from start to end collect (\\subnode i node))) (for i from start to end as subnode in subnodes as smashnode on (NTH (CDR (fetch SubNodes of node)) start) do (* ;; "Update the EditNode itself.") (\\kill.node (\\subnode i node)) (RPLACA smashnode subnode) (replace SuperNode of subnode with node) (replace SubNodeIndex of subnode with i) (\\set.depth subnode (ADD1 (fetch Depth of node))) (\\subnode.changed subnode context) (* ; "Updates the data underlying this EditNode.")) (\\note.change node context) (if point then (\\punt.set.point point context node T)) NIL) ) (\\set.point.read.time.conditional (LAMBDA (point context node index offset item type compute.location?) (* ; "Edited 1-Oct-87 17:33 by raf") (if (type? StringItem item) then (* ; "pointing to the HASH.") (SETQ offset (ILESSP offset (HALF (fetch Width of item)))) elseif (type? EditNode item) then (SETQ type (QUOTE Structure))) (if (NULL index) then (\\punt.set.point point context node offset compute.location?) else (if (AND (EQ type (QUOTE Atom)) (NEQ index 0) (ILEQ index 3)) then (\\set.point point context (\\subnode index node) NIL offset NIL (QUOTE Atom) compute.location?) elseif (EQ index 3) then (* ; "can't insert structure after the last item") (\\set.point.nowhere point) else (replace PointNode of point with node) (replace PointIndex of point with (if offset then index else (SETQ index (SUB1 index)))) (replace PointType of point with (QUOTE Structure)) (if compute.location? then (\\compute.point.position.read.time.conditional point context))))) ) (\\set.selection.read.time.conditional (LAMBDA (selection context node index offset item type) (* ; "Edited 30-Sep-87 13:37 by raf") (* ;; "Pointing to the hash selects the whole read.time.conditional.") (\\set.selection.me selection context node)) ) (\\split.comment (LAMBDA (node point context start) (* ; "Edited 18-Sep-87 19:10 by raf") (\\close.open.node context) (LET* ((comment (CADDR (fetch Structure of node))) (length (NCHARS comment)) (split.string (SUBSTRING comment (ADD1 start) length))) (\\set.point point context (fetch SuperNode of node) (fetch SubNodeIndex of node) T node (QUOTE Structure)) (if (NEQ start length) then (* ; "split in middle of comment.") (\\delete node context (ADD1 start) length NIL comment) (\\insert point context (\\parse.new (LIST (QUOTE *) (CAR (NTH \\comment.markers (fetch Unassigned of node))) split.string) context)) (\\set.point point context (fetch SuperNode of node) (fetch SubNodeIndex of node) T node (QUOTE Structure))))) ) (\\stringify.comment (LAMBDA (node environment) (* ; "Edited 29-Sep-87 13:48 by raf") (LET ((level (fetch Unassigned of node))) (if (ILESSP level 4) then (CONCAT (CADR (fetch Structure of node)) " " (CADDR (fetch Structure of node))) elseif (EQ level 4) then (CONCAT \\level4.comment " " (CADDR (fetch Structure of node))) else (CONCAT "#|" (CADDR (fetch Structure of node)) "|#")))) ) (\\stringify.new.quote [LAMBDA NIL (* ; "Edited 27-Jul-87 16:20 by raf") NIL]) (\\stringify.read.time.conditional (LAMBDA (node environment) (* ; "Edited 30-Sep-87 13:55 by raf") (LET ((structure (fetch Structure of node))) (CONCAT (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:FORMAT NIL "#~a~s" (CL:ETYPECASE structure (TM::HASH-PLUS "+") (TM::HASH-MINUS "-")) (TM::READ-TIME-CONDITIONAL-FEATURE structure))) (if (TM::READ-TIME-CONDITIONAL-UNREAD-P structure) then (TM::READ-TIME-CONDITIONAL-FORM structure) else (CL:FORMAT NIL "~S" (TM::READ-TIME-CONDITIONAL-FORM structure)))))) ) (\\subnode.changed.new.quote [LAMBDA (node subnode) (* ; "Edited 27-Jul-87 16:20 by raf") (CL:SETF (TM::PREFIX-QUOTE-CONTENTS (fetch Structure of node)) (fetch Structure of subnode]) (\\subnode.changed.read.time.conditional (LAMBDA (node subnode context) (* ; "Edited 2-Oct-87 15:25 by raf") (LET ((subnode.structure (fetch Structure of subnode)) (node.structure (fetch Structure of node))) (SELECTQ (fetch SubNodeIndex of subnode) (1 (if (SELECTQ subnode.structure (+ (TM::HASH-MINUS-P node.structure)) (- (TM::HASH-PLUS-P node.structure)) (HELP "Bad read time conditional polarity")) then (* ; "We've changed the polarity of this conditional read, need to make new structure and copy the old fields into it.") (replace Structure of node with (CL:FUNCALL (SELECTQ subnode.structure (+ (QUOTE TM::MAKE-HASH-PLUS)) (- (QUOTE TM::MAKE-HASH-MINUS)) NIL) :UNREAD-P (TM::READ-TIME-CONDITIONAL-UNREAD-P node.structure) :FEATURE (TM::READ-TIME-CONDITIONAL-FEATURE node.structure) :FORM (TM::READ-TIME-CONDITIONAL-FORM node.structure))) (\\unread.read.time.conditional? node context) (* ; "Check whether the %"read-ness%" of the conditional read has changed (according to the features list and the polarity of the conditional read).") (\\subnode.changed node context))) (2 (CL:SETF (TM::READ-TIME-CONDITIONAL-FEATURE node.structure) subnode.structure) (\\unread.read.time.conditional? node context)) (3 (CL:SETF (TM::READ-TIME-CONDITIONAL-FORM node.structure) subnode.structure)) (SHOULDNT "Bad subnode index")))) ) (\\undo.replace.read.time.conditional (LAMBDA (context node old.subnodes) (* ; "Edited 30-Sep-87 14:44 by raf") (\\replace.read.time.conditional node context (fetch SubNodeIndex of (CAR old.subnodes)) (fetch SubNodeIndex of (CAR (LAST old.subnodes))) old.subnodes NIL)) ) (\\unread.read.time.conditional? (LAMBDA (node context) (* ; "Edited 2-Oct-87 18:07 by raf") (* ;;; "If the conditional.read doesn't match the %"unread-ness%" of the features (as indicated by its UNREAD-P flag), then return the converted form.") (LET* ((conditional.read (fetch Structure of node)) (unread (TM::READ-TIME-CONDITIONAL-UNREAD-P conditional.read)) (read-p (CMLREAD.FEATURE.PARSER (TM::READ-TIME-CONDITIONAL-FEATURE conditional.read)))) (if (TM::HASH-MINUS-P conditional.read) then (SETQ read-p (NOT read-p))) (if (AND unread read-p) then (* ; "Flag says currently UNREAD, features say now READ, try to read string into structure.") (CL:WITH-INPUT-FROM-STRING (s (TM::READ-TIME-CONDITIONAL-FORM conditional.read)) (LET ((form (NLSETQ (CL:READ s)))) (if form then (\\replace.read.time.conditional node context 3 3 (LIST (\\parse.new form context))) (CL:SETF (TM::READ-TIME-CONDITIONAL-UNREAD-P conditional.read) NIL) else (printout (\\get.prompt.window context) T "Error during read. Not unread.")))) elseif (AND (NOT unread) (NOT read-p)) then (* ; "Flag says currently READ, features say now UNREAD, print structure into string.") (\\replace.read.time.conditional node context 3 3 (LIST (\\parse.new (CL:FORMAT NIL "~s" (TM::READ-TIME-CONDITIONAL-FORM conditional.read)) context))) (CL:SETF (TM::READ-TIME-CONDITIONAL-UNREAD-P conditional.read) T)))) ) (\\upgrade.comment (LAMBDA (context node) (* ; "Edited 18-Sep-87 18:48 by raf") (if (ILESSP (fetch Unassigned of node) (LENGTH \\comment.markers)) then (RPLACA (CDR (fetch Structure of node)) (CAR (NTH \\comment.markers (add (fetch Unassigned of node) 1)))) (\\note.change node context) (if (fetch SuperNode of (fetch SuperNode of node)) then (* ; "this node has a supernode that is not the root") (\\note.change (fetch SuperNode of node) context)) (\\undo.by \\degrade.comment node))) ) ) (\\initialize.commonlisp) (PUTPROPS SEDIT-COMMONLISP MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CL:IN-PACKAGE "INTERLISP") (FILESLOAD TEXTMODULES) *PACKAGE*) :BASE 10) ) (PUTPROPS SEDIT-COMMONLISP COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5096 63658 (PRIN2-LONG-STRING 5106 . 11058) (SEMI-COLON-COMMENT-P 11060 . 11480) ( SUPERPRINT/COMMENT 11482 . 13870) (\\backspace.read.time.conditional 13872 . 14801) (\\cfv.clisp 14803 . 17469) (\\cfv.comment 17471 . 18530) (\\cfv.form 18532 . 21174) (\\cfv.lambda 21176 . 23476) ( \\cfv.read.time.conditional 23478 . 24195) (\\compute.point.position.read.time.conditional 24197 . 25248) (\\copy.structure.new.quote 25250 . 25709) (\\copy.structure.read.time.conditional 25711 . 26011) (\\create.new.quoted.gap 26013 . 27521) (\\degrade.comment 27523 . 27942) ( \\delete.read.time.conditional 27944 . 28525) (\\initialize.commonlisp 28527 . 32974) ( \\input.bit.vector 32976 . 33135) (\\input.conditional.read 33137 . 33302) (\\input.new.quote 33304 . 34203) (\\insert.new.quoted.gap 34205 . 35440) (\\insert.read.time.conditional 35442 . 35945) ( \\linearize.clisp 35947 . 41825) (\\linearize.comment 41827 . 42680) (\\linearize.form 42682 . 46477) (\\linearize.lambda 46479 . 48902) (\\linearize.list 48904 . 51699) (\\linearize.read.time.conditional 51701 . 52187) (\\parse..bit.vector 52189 . 52349) (\\parse..comment 52351 . 53863) ( \\parse..conditional.read 53865 . 54423) (\\parse..new.quote 54425 . 55055) (\\replace.new.quote 55057 . 56177) (\\replace.read.time.conditional 56179 . 56928) (\\set.point.read.time.conditional 56930 . 57902) (\\set.selection.read.time.conditional 57904 . 58158) (\\split.comment 58160 . 58889) ( \\stringify.comment 58891 . 59280) (\\stringify.new.quote 59282 . 59426) ( \\stringify.read.time.conditional 59428 . 59932) (\\subnode.changed.new.quote 59934 . 60182) ( \\subnode.changed.read.time.conditional 60184 . 61513) (\\undo.replace.read.time.conditional 61515 . 61790) (\\unread.read.time.conditional? 61792 . 63163) (\\upgrade.comment 63165 . 63656))))) STOP \ No newline at end of file diff --git a/lispusers/SEDIT-MENU-ALWAYS b/lispusers/SEDIT-MENU-ALWAYS new file mode 100644 index 00000000..18cbfefa --- /dev/null +++ b/lispusers/SEDIT-MENU-ALWAYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "10-Jan-89 08:03:31" {ERINYES}MEDLEY>SEDIT-MENU-ALWAYS.;1 1349 previous date%: " 8-Sep-88 14:42:58" {DSK}MATT>SEDIT-MENU-ALWAYS.;4) (* " Copyright (c) 1988, 1989 by Beckman Instruments, Inc. All rights reserved. ") (PRETTYCOMPRINT SEDIT-MENU-ALWAYSCOMS) (RPAQQ SEDIT-MENU-ALWAYSCOMS ((PROP (MAKEFILE-ENVIRONMENT FILETYPE) SEDIT-MENU-ALWAYS) (ADVISE SEDIT::SETUP-WINDOW-AND-PROCESS))) (PUTPROPS SEDIT-MENU-ALWAYS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (PUTPROPS SEDIT-MENU-ALWAYS FILETYPE :COMPILE-FILE) [XCL:REINSTALL-ADVICE 'SEDIT::SETUP-WINDOW-AND-PROCESS :AFTER '((:LAST (CL:WHEN (GETTOPVAL SEditMenuAlwaysFlg) (CL:UNLESS (WINDOWPROP (fetch (SEDIT::EDIT-CONTEXT SEDIT::DISPLAY-WINDOW) of CONTEXT) 'SEDIT::MENU) (SEDIT::ADD-MENU CONTEXT)))] (READVISE SEDIT::SETUP-WINDOW-AND-PROCESS) (PUTPROPS SEDIT-MENU-ALWAYS COPYRIGHT ("Beckman Instruments, Inc" 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/SEDIT-MENU-ALWAYS.TEDIT b/lispusers/SEDIT-MENU-ALWAYS.TEDIT new file mode 100644 index 00000000..f77f799a Binary files /dev/null and b/lispusers/SEDIT-MENU-ALWAYS.TEDIT differ diff --git a/lispusers/SEDIT-PATCHES b/lispusers/SEDIT-PATCHES new file mode 100644 index 00000000..c46c9567 --- /dev/null +++ b/lispusers/SEDIT-PATCHES @@ -0,0 +1 @@ +(FILECREATED "29-Jul-88 15:58:41" {ICE}LISPUSERS>KOTO>SEDIT-PATCHES.;20 43681 changes to: (VARS SEDIT-PATCHESCOMS) (FNS \\exit.from.keyboard \\edit.selection \\substitute.text) previous date: "11-Jul-88 10:29:41" {ICE}LISPUSERS>KOTO>SEDIT-PATCHES.;17) (* Copyright (c) 1987, 1988 by Johannes A. G. M. Koomen. All rights reserved.) (PRETTYCOMPRINT SEDIT-PATCHESCOMS) (RPAQQ SEDIT-PATCHESCOMS [(FILES (SYSLOAD) SEDIT) (DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE (LOCALVARS . T) (FILES (LOADCOMP) SEDIT) (VARS (CompilingForKoto T))) (* ;;; "Make SEdit able to edit something other than functions") (FNS \\edit.selection \\editdef) (* ;;; "Make SEdit show in the title bar (with *) that something has changed") (FNS \\mark.context) (* ; "new") (FNS SEditTTYfn \\handle.completion \\note.change \\undo) (* ;;; " Facility for adding and removing commands") (FNS ADD.SEDIT.COMMAND REMOVE.SEDIT.COMMAND) (FNS \\flatten.command.table \\cmdorder) (* ;;; "Facility for adding quote-type functiona") (FNS ADD.SEDIT.QUOTE \\create.constant.strings) [INITVARS (\\quotestring.info (COPYALL (QUOTE ((QUOTE . "'") (BQUOTE . "`") (\, . ",") (\,@ . ",@") (CL:FUNCTION . "#'"] (* ;;; "Patch to remove AddMenu command, as freemenu description and interface is bogus") [DECLARE: DONTEVAL@LOAD DOCOPY (P (REMOVE.SEDIT.COMMAND (QUOTE \\add.menu] (* ;;; "New functionality: DefineFunction using current selection, Text Substitution, and keyboard exit") (FNS \\define.function \\exit.from.keyboard \\substitute.text) (INITVARS (\\substitute.text.old.candidate NIL) (\\substitute.text.new.candidate NIL)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (ADD.SEDIT.COMMAND (QUOTE ("1,d" "1,D" (DefineFunction))) (FUNCTION \\define.function) "Define Function M-D" "Define function using current selection and substitute call") (ADD.SEDIT.COMMAND (QUOTE ("1,^X" (ExitFromKeyboard))) (FUNCTION \\exit.from.keyboard) "Done & Close M-^X" "Same as closing this SEdit window") (ADD.SEDIT.COMMAND (QUOTE ("1,t" "1,T" (SubstituteText))) (FUNCTION \\substitute.text) "Substitute Text M-T" "Prompt for text patterns to substitute in current selection (cf. ESUBST, IRM 16.73)"))) (* ;;; "Provide Lyric-style interface to edit window regions") (FNS SEDIT.GET.WINDOW.REGION SEDIT.SAVE.WINDOW.REGION) (FNS \\build.window \\disintegrate.context \\expandfn \\shrinkfn) (VARS (:CREATE (QUOTE :CREATE)) (:EXPAND (QUOTE :EXPAND)) (:CLOSE (QUOTE :CLOSE)) (:SHRINK (QUOTE :SHRINK))) (* ;;; "Patch to circumvent bug in \\linearize.form") (FNS \\linearize.form) (* ;;; "Patch to fix deadly bug when typing non-list after PROG, LAMBDA, etc") (FNS \\reparse.litatom) (* ;;; "I/O Patch ") [DECLARE: DONTEVAL@LOAD DOCOPY (P (CHANGENAME (QUOTE \\sedit) (QUOTE READP) (QUOTE \SYSBUFP] (* ;;; "Give Dorado a BQUOTE character") (DECLARE: DONTEVAL@LOAD DOCOPY (P (COND ((EQ (MACHINETYPE) (QUOTE DORADO)) (METASHIFT T) (* ;; "Make BLANK-TOP key a BQUOTE") (KEYACTION (QUOTE BLANK-TOP) (QUOTE ((96 96]) (FILESLOAD (SYSLOAD) SEDIT) (DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (LOADCOMP) SEDIT) (RPAQQ CompilingForKoto T) ) (* ;;; "Make SEdit able to edit something other than functions") (DEFINEQ (\\edit.selection [LAMBDA (context) (* Koomen "22-Jun-88 07:26") (* jow "18-Sep-86 12:50") (* ;;   "(Koomen -- 22-Jun-88) Replaced EDITDEF by \\editdef to allow editing of things other than functions") [LET ((structure (\\selected.fn.name context))) (if structure then (\\set.selection.nowhere (fetch (EditContext Selection) of context)) (\\set.point.nowhere (fetch (EditContext CaretPoint) of context)) (\\update context) (if [NULL (NLSETQ (if (CompilingForKoto) then (\\editdef structure) else (ED structure T] then (printout (GETPROMPTWINDOW (fetch DisplayWindow of context)) T structure " not editable."] T]) (\\editdef [LAMBDA (structure) (* Koomen "13-Nov-87 14:26") (* ;;   "Patch to get around the problem of SEdit insisting on editing FNS on META-O, instead of checking if more than one type is defined (as the documentation claims)." ) (PROG* [(STYPES (TYPESOF structure NIL NIL (QUOTE ?))) (DEFTYPE (if (OR (NULL STYPES) (CDR STYPES)) then (MENU (create MENU TITLE _ "Select type: " ITEMS _ [OR STYPES (QUOTE ((" New Function " (QUOTE NEWFN) "Create and edit a new function") (" New Macro " (QUOTE NEWMACRO) "Create and edit a new macro"] CENTERFLG _ T)) else (CAR STYPES] (RETURN (if DEFTYPE then (if (NULL STYPES) then (SELECTQ DEFTYPE (NEWFN (PUTDEF structure (SETQ DEFTYPE (QUOTE FNS)) (LIST (QUOTE LAMBDA) \\args.gap \\body.gap)) ) [NEWMACRO (PUTDEF structure (SETQ DEFTYPE (QUOTE MACROS)) (BQUOTE (PUTPROPS (\, structure) MACRO ((\, \\args.gap) (\, \\body.gap] (SHOULDNT))) (EDITDEF structure DEFTYPE]) ) (* ;;; "Make SEdit show in the title bar (with *) that something has changed") (DEFINEQ (\\mark.context [LAMBDA (context changed?) (* Koomen "15-Jun-88 13:18") (* ;;   "This sets the ChangedStructure? flag according to the argument changed? This used to be done inline. Seperated so that this function will also chnage the window title to make this flag visible" ) (PROG (waschanged? dspwin title oldtitle) (SETQ waschanged? (fetch ChangedStructure? of context)) (replace ChangedStructure? of context with changed?) (SETQ dspwin (fetch DisplayWindow of context)) (if (AND dspwin (NEQ changed? waschanged?) (OPENWP dspwin)) then (SETQ oldtitle (WINDOWPROP dspwin (QUOTE TITLE))) (SETQ title (OR (WINDOWPROP dspwin (QUOTE OLDTITLE)) (CONCAT "* " oldtitle))) (WINDOWPROP dspwin (QUOTE TITLE) title) (WINDOWPROP dspwin (QUOTE OLDTITLE) oldtitle)) (RETURN waschanged?]) ) (* ; "new") (DEFINEQ (SEditTTYfn [LAMBDA (ATM TYPE) (* Koomen "15-Jun-88 13:17") (* mdd "24-Oct-86 15:26") (DECLARE (USEDFREE L)) (* ;;   "this is a replacement for the TTY editor's TTY: command, which starts and SEdit process to do interactive editing for a while. it uses the TTY editor's edit chain to determine the initial selection in the structure, and scrolls the window to make sure the selection's visible. it then waits until the user signals that they've done enough editing (usually by closing or shrinking the window)" ) (* ;;   "Koomen 15-Jun-88 Replaced (replace ChangedStructure? ...) with \\mark.context") (LET ((context (SEdit (CAR (LAST L)) (LIST (QUOTE NAME) ATM (QUOTE TYPE) TYPE (QUOTE DONTWAIT) T))) node) (DECLARE (USEDFREE EDITCHANGES)) [WITH.MONITOR (fetch ContextLock of context) (if (SETQ node (\\locate.node.from.editchain L (fetch Root of context))) then (\\selection.down context) (\\select.node context node) (\\compute.selection.position (fetch Selection of context) context) (\\set.point.nowhere (fetch CaretPoint of context)) (\\normalize.selection context) (if (NOT (fetch SelectionDisplayed? of context)) then (\\display.selection (fetch Selection of context) (fetch DisplayWindow of context)) (replace SelectionDisplayed? of context with T] (* ; "let the user do their editing before we return") (AWAIT.EVENT (fetch CompletionEvent of context)) (if (\\mark.context context NIL) then (RPLACA (CDR EDITCHANGES) T]) (\\handle.completion [LAMBDA (context) (* Koomen "15-Jun-88 13:17") (* mdd " 1-Aug-86 11:54") (* ;;   "Koomen 15-Jun-88 Replaced (replace ChangedStructure? ...) with \\mark.context") (NOTIFY.EVENT (fetch CompletionEvent of context)) (replace UndoList of context with NIL) (replace UndoUndoList of context with NIL) (replace AtomStarted of context with NIL) (replace AtomStartedUndoPointer of context with NIL) (if (\\mark.context context NIL) then (LET ((fn (fetch CompletionFn of context))) (if fn then (APPLY (if (LISTP fn) then (CAR fn) else fn) (LIST* context (fetch Structure of (\\subnode 1 (fetch Root of context))) (CDR (LISTP fn]) (\\note.change [LAMBDA (node context) (* Koomen "15-Jun-88 13:17") (* mdd "20-Jun-86 18:11") (* we've made some change to this node. clobber any clisp translation, and insert it into the ChangedNodes list  (which is sorted by depth)) (* ;;   "Koomen 15-Jun-88 Replaced (replace ChangedStructure? ...) with \\mark.context") (if (NOT (fetch Changed? of node)) then (for (super _ node) by (fetch SuperNode of super) while super when (LISTP (fetch Structure of super)) do (\\zap.clisp.translation (fetch Structure of super))) (replace Changed? of node with T) (bind next (last _ (fetch ChangedNodes of context)) while (AND (SETQ next (CDR last)) (IGREATERP (fetch Depth of (CAR next)) (fetch Depth of node))) do (SETQ last next) finally (RPLACD last (CONS node next))) (\\mark.context context T]) (\\undo [LAMBDA (context) (* Koomen "15-Jun-88 13:17") (* jow " 4-Sep-86 14:38") (* ;;   "Koomen 15-Jun-88 Replaced (replace ChangedStructure? ...) with \\mark.context") (\\close.open.node context) [LET [(undo.list (fetch UndoList of context)) (promptwindow (GETPROMPTWINDOW (fetch DisplayWindow of context] (if undo.list then (replace UndoList of context with (fetch UndoUndoList of context)) (\\set.selection.nowhere (fetch Selection of context)) (\\set.point.nowhere (fetch CaretPoint of context)) (\\undo.event (CAR undo.list) context) (replace UndoUndoList of context with (fetch UndoList of context)) (if (NULL (replace UndoList of context with (CDR undo.list))) then (\\mark.context context NIL)) else (printout promptwindow T (if (fetch UndoUndoList of context) then "Nothing else to Undo" else "Nothing to Undo"] T]) ) (* ;;; " Facility for adding and removing commands") (DEFINEQ (ADD.SEDIT.COMMAND [LAMBDA (keyspec commandfn menulabel menucomment) (* Koomen "22-Jun-88 08:56") (DECLARE (GLOBALVARS \\SEdit.Contexts \\command.table.spec)) (PROG* [(cmdtbl (\\flatten.command.table)) (cmdname commandfn) [keyspec2 (for key inside keyspec collect (if (LISTP key) then (SETQ cmdname (CAR key)) key else (\\charcode key] (menuspec (if menulabel then (LIST (CONS menulabel (MKLIST menucomment] (for key in keyspec2 bind cmd do (if [SETQ cmd (if (FIXP key) then (ASSOC key cmdtbl) else (for c in cmdtbl thereis (AND (LISTP (CAR c)) (EQUAL key (CAAR c] then (if (NOT (EQUAL (CADR cmd) commandfn)) then (PROMPTPRINT "Rebinding " (if (FIXP (CAR cmd)) then (CHARACTER (CAR cmd)) else (CAR cmd)) " from " (CADR cmd) " to " cmdname)) (RPLACA (CDR cmd) commandfn) (RPLACD (CDR cmd) menuspec) (SETQ keyspec2 (REMOVE key keyspec2)) (SETQ menuspec NIL))) (for key in keyspec2 do (push cmdtbl (LIST* (if (FIXP key) then key else (LIST key)) commandfn menuspec)) (SETQ menuspec NIL)) (SETQ \\command.table.spec (SORT cmdtbl (FUNCTION \\cmdorder))) (if (NULL \\SEdit.Contexts) then (SEDIT.RESET) else (PROMPTPRINT "Close SEdit windows, then (SEDIT.RESET) to enable " cmdname)) (RETURN cmdname]) (REMOVE.SEDIT.COMMAND [LAMBDA (commandfn) (* Koomen "22-Jun-88 08:04") (DECLARE (GLOBALVARS \\SEdit.Contexts \\command.table.spec)) (SETQ \\command.table.spec (SORT (for cmd in (\\flatten.command.table) unless (EQ commandfn (if (LISTP (CADR cmd)) then (CAR (CADR cmd)) else (CADR cmd))) collect cmd) (FUNCTION \\cmdorder))) (if (NULL \\SEdit.Contexts) then (SEDIT.RESET) else (PROMPTPRINT "Close SEdit windows, then (SEDIT.RESET) to disable " commandfn)) commandfn]) ) (DEFINEQ (\\flatten.command.table [LAMBDA NIL (* Koomen "22-Jun-88 07:45") (* ;;   "Normalize table, so we can redefine things more easily") (DECLARE (GLOBALVARS \\command.table.spec)) (for spec in \\command.table.spec join (if (FIXP (CAR spec)) then (LIST spec) else (for key inside (CAR spec) bind (entry _ (CADDR spec)) collect (LIST* (if (LISTP key) then (LIST key) else (\\charcode key)) (CADR spec) (if entry then (PROG1 (LIST entry) (SETQ entry]) (\\cmdorder [LAMBDA (cmd.x cmd.y) (* Koomen "22-Jun-88 07:57") (DECLARE (GLOBALVARS UPPERCASEARRAY)) (LET ((key.x (CAR cmd.x)) (key.y (CAR cmd.y))) (if (FIXP key.x) then (if (FIXP key.y) then (LEQ key.x key.y) else T) elseif [AND (LISTP (CAR (LISTP key.x))) (LISTP (CAR (LISTP key.y] then (ALPHORDER (CAAR key.x) (CAAR key.y) UPPERCASEARRAY]) ) (* ;;; "Facility for adding quote-type functiona") (DEFINEQ (ADD.SEDIT.QUOTE [LAMBDA (QUOTESTR QUOTEFN) (* Koomen "22-Jun-88 09:09") (LISTPUT \\list.ParseInfo QUOTEFN (CONS (QUOTE \\parse..quote) (QUOTE \\reparse.list.to.quote))) (PUTASSOC QUOTEFN QUOTESTR \\quotestring.info) (ADD.SEDIT.COMMAND QUOTESTR (LIST (QUOTE \\insert.quoted.gap) QUOTEFN]) (\\create.constant.strings [LAMBDA (env) (* Koomen "22-Jun-88 09:03") (* jow "17-Oct-86 16:39") (* ;;   "[Koomen 22-Jun-88] replace inline list with variable \\quotestring.info") (LET ((font (fetch DefaultFont of env))) (replace LParenString of env with (\\create.string.item "(" font)) (replace RParenString of env with (\\create.string.item ")" font)) (replace DotString of env with (\\create.string.item "." font)) [replace QuoteString of env with (for prefix in \\quotestring.info join (LIST (CAR prefix) (\\create.string.item (CDR prefix) font] (replace CommentString of env with (for prefix in (QUOTE ((1 . "; ") (2 . ";; ") (3 . ";;; "))) join (LIST (CAR prefix) (\\create.string.item (CDR prefix) (fetch KeywordFont of env]) ) (RPAQ? \\quotestring.info [COPYALL (QUOTE ((QUOTE . "'") (BQUOTE . "`") (\, . ",") (\,@ . ",@") (CL:FUNCTION . "#'"]) (* ;;; "Patch to remove AddMenu command, as freemenu description and interface is bogus") (DECLARE: DONTEVAL@LOAD DOCOPY (REMOVE.SEDIT.COMMAND (QUOTE \\add.menu)) ) (* ;;; "New functionality: DefineFunction using current selection, Text Substitution, and keyboard exit" ) (DEFINEQ (\\define.function [LAMBDA (context) (* Koomen "22-Jun-88 09:14") (* ;;   "This command prompts for the name of a new function, and defines the function using the current selection (which may be extended over several forms) as the body. The current selection is then replaced by a call to this new function." ) (PROG (promptwindow fnname selection node) (SETQ promptwindow (GETPROMPTWINDOW (fetch DisplayWindow of context))) (TERPRI promptwindow) (SETQ fnname (PROMPTFORWORD "Define function: " NIL NIL promptwindow)) (if (NOT (STRINGP fnname)) then (TERPRI promptwindow) (RETURN)) (SETQ fnname (MKATOM fnname)) (if (AND (DEFINEDP fnname) (NOT (MOUSECONFIRM (CONCAT "Redefine " fnname " ? ") NIL promptwindow))) then (TERPRI promptwindow) (RETURN)) (\\parenthesize.current.selection context) (SETQ selection (fetch Selection of context)) (SETQ node (fetch SelectNode of selection)) (if (AND node (fetch Structure of node) (EQ (fetch SelectType of selection) (QUOTE Structure)) (NULL (fetch SelectStart of selection))) then (PUTDEF fnname (QUOTE FNS) (LIST* (QUOTE LAMBDA) NIL (fetch Structure of node))) (\\replace.node context node (\\parse.new (LIST fnname) context)) else (printout promptwindow T "Nothing appropriate selected."))) T]) (\\exit.from.keyboard [LAMBDA (context) (* Koomen "29-Jul-88 12:47") (CLOSEW (fetch DisplayWindow of context)) T]) (\\substitute.text [LAMBDA (context) (* Koomen "29-Jul-88 11:26") (DECLARE (GLOBALVARS \\substitute.text.new.candidate \\substitute.text.old.candidate)) (PROG (promptwindow selection node struct parenthesized old new rplstruct rplnode) (SETQ promptwindow (GETPROMPTWINDOW (fetch DisplayWindow of context))) (SETQ selection (fetch Selection of context)) (if [OR (NEQ (fetch SelectType of selection) (QUOTE Structure)) (NULL (SETQ node (fetch SelectNode of selection))) (NULL (SETQ struct (fetch Structure of node] then (printout promptwindow T "Nothing appropriate selected.") (RETURN)) (TERPRI promptwindow) [SETQ old (PROMPTFORWORD "Replace old text: " \\substitute.text.old.candidate NIL promptwindow NIL NIL (CHARCODE (EOL LF] (if (NULL old) then (printout promptwindow T "Text substitution aborted.") (RETURN)) (SETQ \\substitute.text.old.candidate (SETQ old (MKATOM old))) (TERPRI promptwindow) (SETQ new (OR (PROMPTFORWORD "with new text: " \\substitute.text.new.candidate NIL promptwindow NIL NIL (CHARCODE (EOL LF))) "")) (SETQ \\substitute.text.new.candidate (SETQ new (MKATOM new))) (if (fetch SelectStart of selection) then (\\parenthesize.current.selection context) (SETQ selection (fetch Selection of context)) (SETQ node (fetch SelectNode of selection)) (SETQ struct (fetch Structure of node)) (SETQ parenthesized T)) (SETQ struct (COPYALL struct)) (SETQ rplstruct (NLSETQ (ESUBST new old struct NIL T))) (if (NULL rplstruct) then (printout promptwindow T "No text substitutions made.") else (SETQ rplnode (\\parse.new (CAR rplstruct) context)) (if (type? EditNode rplnode) then (\\replace.node context node rplnode) (printout promptwindow T "Done.") else (printout promptwindow T "Oops! Returned ESUBST value unparsable!!!"))) (if parenthesized then (\\extract.current.selection context))) T]) ) (RPAQ? \\substitute.text.old.candidate NIL) (RPAQ? \\substitute.text.new.candidate NIL) (DECLARE: DONTEVAL@LOAD DOCOPY (ADD.SEDIT.COMMAND (QUOTE ("1,d" "1,D" (DefineFunction))) (FUNCTION \\define.function) "Define Function M-D" "Define function using current selection and substitute call") (ADD.SEDIT.COMMAND (QUOTE ("1,^X" (ExitFromKeyboard))) (FUNCTION \\exit.from.keyboard) "Done & Close M-^X" "Same as closing this SEdit window") (ADD.SEDIT.COMMAND (QUOTE ("1,t" "1,T" (SubstituteText))) (FUNCTION \\substitute.text) "Substitute Text M-T" "Prompt for text patterns to substitute in current selection (cf. ESUBST, IRM 16.73)") ) (* ;;; "Provide Lyric-style interface to edit window regions") (DEFINEQ (SEDIT.GET.WINDOW.REGION [LAMBDA (CONTEXT REASON) (* Koomen "11-Jul-88 10:27") (* ;; "Reason ignored") (OR (pop \\SEdit.Regions) (GETREGION MINWIDTH MINHEIGHT]) (SEDIT.SAVE.WINDOW.REGION [LAMBDA (CONTEXT REASON) (* Koomen "11-Jul-88 10:27") (* ;; "REASON ignored") (push \\SEdit.Regions (LET [(REG (WINDOWPROP (fetch (EditContext DisplayWindow) of CONTEXT) (QUOTE REGION] (* ;;   "Make a copy, with HEIGHT extended by a one-line promptwindow, because SEdit destructively modifies regions by subtracting from HEIGHT a one-line promptwindow!" ) (CREATEREGION (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) (fetch (REGION WIDTH) of REG) (IPLUS (fetch (REGION HEIGHT) of REG) (HEIGHTIFWINDOW (FONTPROP NIL (QUOTE HEIGHT]) ) (DEFINEQ (\\build.window [LAMBDA (context) (* Koomen "22-Jun-88 08:21") (* mdd "17-Sep-86 20:45") (* ;   "this is a new context. fill in all the important fields and set things up for editing") (* ;;   "[Koomen 13-Nov-87] Save initial region if necessary, obtain one using SEDIT.GET.WINDOW.REGION instead of GETREGION" ) (DECLARE (GLOBALVARS \\type.root)) (LET* [(environment (fetch Environment of context)) (structure (fetch Root of context)) (root (create EditNode NodeType _ \\type.root Depth _ 1 SubNodes _ (LIST 0) LinearForm _ (CONS) StartX _ 1 ActualWidth _ 0)) [package (AND (CompilingPostKoto) (PACKAGE-NAME (fetch Package of context] (display.window (CREATEW (LET (region) (if (REGIONP (fetch DisplayWindow of context)) then (push \\SEdit.Regions (fetch DisplayWindow of context))) (replace (EditContext DisplayWindow) of context with NIL) (SETQ region (SEDIT.GET.WINDOW.REGION context :CREATE)) (* ;   "this will subtract the height of a one line prompt window in the defualt font") [replace (REGION HEIGHT) of region with (IDIFFERENCE (fetch (REGION HEIGHT) of region) (HEIGHTIFWINDOW (FONTPROP NIL (QUOTE HEIGHT] region) (if package then (CONCAT (PROCESSPROP (THIS.PROCESS) (QUOTE NAME)) " in " package) else (PROCESSPROP (THIS.PROCESS) (QUOTE NAME] (GETPROMPTWINDOW display.window 1) (if SEDIT.WANT.MENU then (\\add.menu display.window)) (replace CommentWidth of context with 200) (replace CommentSeparation of context with 30) (replace Environment of context with environment) (replace Root of context with root) (replace DisplayWindow of context with display.window) (replace CaretPoint of context with (create EditPoint)) (replace Selection of context with (create EditSelection)) (replace SelfLink of root with (create WeakLink Destination _ root)) (WYOFFSET (SUB1 (WINDOWPROP display.window (QUOTE HEIGHT))) display.window) (replace WindowLeft of context with (fetch LEFT of (DSPCLIPPINGREGION NIL display.window))) (replace WindowBottom of context with (fetch BOTTOM of (DSPCLIPPINGREGION NIL display.window))) (replace WindowRight of context with (fetch RIGHT of (DSPCLIPPINGREGION NIL display.window))) (replace WindowTop of context with (fetch TOP of (DSPCLIPPINGREGION NIL display.window))) (DSPLINEFEED (IMINUS (IPLUS (FONTPROP (fetch DefaultFont of environment) (QUOTE HEIGHT)) (fetch DefaultLineSkip of environment))) display.window) (* ;;   "set the window's right margin big enough that things won't be wrapped on us. this is sort of gross -- there should be a way to completely disable wrap" ) (DSPRIGHTMARGIN 64000 display.window) (WINDOWPROP display.window (QUOTE EditContext) context) (replace CurrentNode of context with root) (replace \X of context with NIL) (replace OpenNode of context with NIL) [LET ((string (ALLOCSTRING 512 NIL NIL T))) (replace OpenNodeInfo of context with (create OpenString BufferString _ string Substring _ (SUBSTRING string 1 1] (\\parse structure context) (\\build.linear.form context) (LET [(height (IDIFFERENCE (fetch LineHeight of (fetch LastLine of root)) (fetch YCoord of (fetch LastLine of root] (WINDOWPROP display.window (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _ (IDIFFERENCE 1 height) WIDTH _ (fetch ActualWidth of root) HEIGHT _ height))) (WINDOWPROP display.window (QUOTE SCROLLEXTENTUSE) (QUOTE (- . +))) (WINDOWPROP display.window (QUOTE REPAINTFN) (FUNCTION \\repaintfn)) (WINDOWPROP display.window (QUOTE SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) (WINDOWPROP display.window (QUOTE WINDOWENTRYFN) (FUNCTION \\new.buttoneventfn)) (WINDOWPROP display.window (QUOTE BUTTONEVENTFN) (FUNCTION \\new.buttoneventfn)) (WINDOWPROP display.window (QUOTE RIGHTBUTTONFN) (FUNCTION \\new.buttoneventfn)) (* ;   "use windowaddprop to preserve attached window functions already there") (WINDOWADDPROP display.window (QUOTE CLOSEFN) (FUNCTION \\closefn)) (WINDOWADDPROP display.window (QUOTE SHRINKFN) (FUNCTION \\shrinkfn)) (WINDOWADDPROP display.window (QUOTE EXPANDFN) (FUNCTION \\expandfn)) (WINDOWADDPROP display.window (QUOTE RESHAPEFN) (FUNCTION \\reshapefn]) (\\disintegrate.context [LAMBDA (CONTEXT) (* Koomen " 6-Nov-87 17:13") (* ;;   "Replaces inline window region saving with call to SEDIT.SAVE.WINDOW.REGION") (DECLARE (GLOBALVARS \\SEdit.Contexts)) (if CONTEXT then (replace (EditContext ContextLock) of CONTEXT with (QUOTE Dead)) (SEDIT.SAVE.WINDOW.REGION CONTEXT (QUOTE CLOSED)) (WINDOWPROP (fetch (EditContext DisplayWindow) of CONTEXT) (QUOTE EditContext) NIL) (replace (EditContext DisplayWindow) of CONTEXT with NIL) (SETQ \\SEdit.Contexts (DREMOVE CONTEXT \\SEdit.Contexts]) (\\expandfn [LAMBDA (window) (* Koomen "22-Jun-88 08:26") (* jow "21-Aug-86 14:45") (* called by the window system when SEdit window icons are expanded. start a new command process for the  window) (* ;;   "[Koomen 13-Nov-87] Get a (possibly new) region through interface") (LET [(context (WINDOWPROP window (QUOTE EditContext] (SHAPEW window (SEDIT.GET.WINDOW.REGION context :EXPAND)) (if (NOT (WINDOWPROP window (QUOTE PROCESS))) then (replace EvalInProcess of context with (\\eval.in.process)) (ADD.PROCESS (LIST (QUOTE \\sedit) (KWOTE context)) (QUOTE NAME) (CONCAT "SEdit " (fetch IconTitle of context]) (\\shrinkfn [LAMBDA (window) (* Koomen "22-Jun-88 08:34") (* jow "13-Aug-86 11:40") (* called by the window system when an SEdit window is shrunk. if it doesn't already, have one, give it a pretty  icon with an appropriate title. also make sure the command process notices that it should die) (* ;;   "[Koomen 13-Nov-87] Save the region through interface") (LET [(context (WINDOWPROP window (QUOTE EditContext] (SEDIT.SAVE.WINDOW.REGION context :SHRINK) (if (NOT (WINDOWPROP window (QUOTE ICON))) then (WINDOWPROP window (QUOTE ICON) (TITLEDICONW \\titled.icon (fetch IconTitle of context) NIL T))) (\\awake.command.process context NIL]) ) (RPAQQ :CREATE :CREATE) (RPAQQ :EXPAND :EXPAND) (RPAQQ :CLOSE :CLOSE) (RPAQQ :SHRINK :SHRINK) (* ;;; "Patch to circumvent bug in \\linearize.form") (DEFINEQ (\\linearize.form [LAMBDA (node context index) (* Koomen "16-Jun-88 16:01") (* jow "26-Sep-86 12:10") (* ; "the linearize method for forms") (* ;;   "Koomen 16-Jun-88 -- there was a reference to (fetch Unassigned of node) as one of the branches in the conditional under `first' which maybe NIL. Hence, wrapped it in an OR to compute some alternate valid indent value (dunno if it's right) instead." ) [if (NOT index) then (\\output.constant.string context (fetch LParenString of (fetch Environment of context] [if (CDR (fetch SubNodes of node)) then (bind (same.line? _ T) (space.width _ (fetch SpaceWidth of (fetch Environment of context))) [paren.width _ (fetch Width of (fetch LParenString of (fetch Environment of context] (first.subnode _ T) indent last.comment.level comment.start.x comment.indent line.skip first [SETQ indent (IPLUS (fetch StartX of node) (if [NOT (ATOM (fetch Structure of (CADR (fetch SubNodes of node] then (* ;;   "this will handle the case of comment first, too, like in COMS. it will be ugly for comment at beginning of function call, but who cares." ) paren.width elseif (ILEQ (IPLUS (fetch StartX of node) (fetch PreferredWidth of node)) (fetch RightMargin of node)) then [OR (fetch Unassigned of node) (MAX (fetch MinIndent of (fetch Environment of context)) (MIN (fetch MaxIndent of (fetch Environment of context)) (IPLUS paren.width (fetch (EditNode ActualWidth) of (CADR (fetch SubNodes of node))) space.width] else (fetch MinIndent of (fetch Environment of context] (\\set.comment.positions comment.start.x comment.indent (IPLUS paren.width (fetch StartX of node)) paren.width node context) for subnode in (CDR (fetch SubNodes of node)) do (if (EQ (fetch NodeType of subnode) \\type.comment) then (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) else [if (EQ last.comment.level (fetch Unassigned of subnode)) then (* ;;   "we're following a comment of the same level. force a cr and extra line space") (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent indent (fetch StartX of (fetch Root of context))) 8) elseif (AND first.subnode (NEQ (fetch Unassigned of subnode) 1)) then (* ;; "dont' have to move at all") elseif (OR first.subnode (AND (EQ (fetch Unassigned of subnode) 1) same.line? (ILEQ (fetch CurrentX of context) comment.start.x))) then (* ;;   "just space if first subnode or its a single semi comment that will fit") (\\output.space context (IDIFFERENCE comment.indent (fetch CurrentX of context))) else (\\output.cr context (\\select.comment.indent (fetch Unassigned of subnode) comment.indent indent (fetch StartX of (fetch Root of context] (\\linearize subnode context)) (SETQ same.line? NIL) (SETQ last.comment.level (fetch Unassigned of subnode)) else (if index then NIL elseif first.subnode then [if (NOT same.line?) then (\\output.cr context (IPLUS paren.width (fetch StartX of node] else (if (AND same.line? (NEQ same.line? (QUOTE paren)) (LEQ (IPLUS (fetch CurrentX of context) space.width) indent)) then (* ;   "we're to the left of the indentation tab, so just space enough to get there") (\\output.space context (IDIFFERENCE indent (fetch CurrentX of context))) elseif (AND same.line? (NEQ same.line? (QUOTE paren)) (fetch InlineWidth subnode) (LEQ (IPLUS (fetch CurrentX of context) space.width (fetch InlineWidth subnode) (if (AND (CDR $$LST1) (EQ (fetch NodeType of (CADR $$LST1)) \\type.comment) (EQ (fetch Unassigned of (CADR $$LST1)) 1)) then (fetch PreferredWidth of (CADR $$LST1)) else 0)) (fetch RightMargin of node)) (OR (EQ same.line? T) (ILESSP (CAR (fetch SubNodes of subnode)) 2))) then (* ; "it will fit on this line") (\\output.space context space.width) else (\\output.cr context indent))) (SETQ same.line? (OR (AND (if index then (SETQ index (AND (NEQ index 1) (SUB1 index))) (fetch Inline? of subnode) else (\\linearize subnode context)) (OR (ILESSP (CAR (fetch SubNodes of subnode)) 2) (QUOTE no.lists))) (QUOTE paren))) (SETQ last.comment.level NIL)) (SETQ first.subnode NIL) finally (if (NULL same.line?) then (\\output.cr context (IPLUS paren.width (fetch StartX of node] (if index then (SHOULDNT "linearize index out of range")) (\\output.constant.string context (fetch RParenString of (fetch Environment of context]) ) (* ;;; "Patch to fix deadly bug when typing non-list after PROG, LAMBDA, etc") (DEFINEQ (\\reparse.litatom [LAMBDA (node mode context) (* Koomen "29-Apr-88 17:05") (* mdd " 5-Sep-86 12:23") (* ;;   "Koomen [4/29/88] Patched to avoid severe problem with SEdit attempts to reparse the CADR of a LAMBDA/LET/PROG list after typing a litatom instead of a ParamList" ) (* this atom is either (a) switching to or from a keyword, or (b) a NIL which is to be parsed as an empty list) (if (AND (PROGN (* * This doesn't work. Try leaving it alone.) NIL) (NULL (fetch Structure of node)) (EQ mode (QUOTE BindingList)) (NEQ (fetch PointNode of (fetch CaretPoint of context)) node)) then (\\reparse.list node mode context) elseif (EQ mode (QUOTE BindingList)) then NIL elseif (NEQ (SETQ mode (AND (EQ mode (QUOTE KeyWord)) (QUOTE KeyWord))) (fetch ParseMode of node)) then (replace ParseMode of node with mode) (\\note.change node context]) ) (* ;;; "I/O Patch ") (DECLARE: DONTEVAL@LOAD DOCOPY (CHANGENAME (QUOTE \\sedit) (QUOTE READP) (QUOTE \SYSBUFP)) ) (* ;;; "Give Dorado a BQUOTE character") (DECLARE: DONTEVAL@LOAD DOCOPY [COND ((EQ (MACHINETYPE) (QUOTE DORADO)) (METASHIFT T) (* ;; "Make BLANK-TOP key a BQUOTE") (KEYACTION (QUOTE BLANK-TOP) (QUOTE ((96 96] ) (PUTPROPS SEDIT-PATCHES COPYRIGHT ("Johannes A. G. M. Koomen" 1987 1988)) (DECLARE: DONTCOPY (FILEMAP (NIL (3824 6352 (\\edit.selection 3834 . 4795) (\\editdef 4797 . 6350)) (6440 7553 ( \\mark.context 6450 . 7551)) (7574 13277 (SEditTTYfn 7584 . 9696) (\\handle.completion 9698 . 10760) ( \\note.change 10762 . 11996) (\\undo 11998 . 13275)) (13339 15945 (ADD.SEDIT.COMMAND 13349 . 15254) ( REMOVE.SEDIT.COMMAND 15256 . 15943)) (15946 17371 (\\flatten.command.table 15956 . 16819) (\\cmdorder 16821 . 17369)) (17431 19087 (ADD.SEDIT.QUOTE 17441 . 17828) (\\create.constant.strings 17830 . 19085) ) (19542 23904 (\\define.function 19552 . 21297) (\\exit.from.keyboard 21299 . 21484) ( \\substitute.text 21486 . 23902)) (24662 25883 (SEDIT.GET.WINDOW.REGION 24672 . 24960) ( SEDIT.SAVE.WINDOW.REGION 24962 . 25881)) (25884 34803 (\\build.window 25894 . 31996) ( \\disintegrate.context 31998 . 32792) (\\expandfn 32794 . 33834) (\\shrinkfn 33836 . 34801)) (34980 41852 (\\linearize.form 34990 . 41850)) (41940 43203 (\\reparse.litatom 41950 . 43201))))) STOP \ No newline at end of file diff --git a/lispusers/SEDIT-PROFILE b/lispusers/SEDIT-PROFILE new file mode 100644 index 00000000..a93520d2 --- /dev/null +++ b/lispusers/SEDIT-PROFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10) (il:filecreated " 5-May-88 10:47:42" il:|{EG:PARC:XEROX}LISP>MEDLEY>SEDIT-PROFILE.;2| 5216 il:|changes| il:|to:| (il:fns sedit::setup-profile) il:|previous| il:|date:| " 5-May-88 09:59:40" il:|{EG:PARC:XEROX}LISP>MEDLEY>SEDIT-PROFILE.;1|) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (il:prettycomprint il:sedit-profilecoms) (il:rpaqq il:sedit-profilecoms ((il:* il:|;;;| "Patch to SEdit that makes SEdit use the package and readtable for the file that contains an item, rather than the package of the name of the item and the current readtable.") (il:functions sedit::profile-package sedit::profile-readtable) (il:* il:|;;| "A hacked version of an SEdit function that uses the above functions") (il:fns sedit::setup-profile) (il:* il:|;;| "") (il:declare\: il:donteval@load il:eval@compile il:dontcopy (il:files il:sedit-decls) (il:globalvars il:*default-makefile-environment*)) (il:* il:|;;| "") (il:declare\: il:dontcopy (il:props (il:sedit-profile il:makefile-environment) (il:sedit-profile il:filetype))))) (il:* il:|;;;| "Patch to SEdit that makes SEdit use the package and readtable for the file that contains an item, rather than the package of the name of the item and the current readtable." ) (defun sedit::profile-package (il:name type) "What package should be used when editing the item?" (labels ((il:coerce-to-package (il:x) (cond ((null il:x) nil) ((packagep il:x) il:x) ((consp il:x) (il:coerce-to-package (eval il:x))) ((or (stringp il:x) (symbolp il:x)) (find-package il:x)) (t nil))) (il:makefile-environment-package (il:mfe) (cond (il:mfe (il:coerce-to-package (getf il:mfe :package))) (t nil)))) (or (ignore-errors (or (and il:name (not (il:memb type (quote (il:proplst il:|Expression|)))) (let ((il:files (il:whereis il:name type))) (cond (il:files (or (dolist (il:file (il:whereis il:name type)) (let ((il:file-package (il:makefile-environment-package (get il:file (quote il:makefile-environment))))) (cond (il:file-package (return il:file-package)) (t nil)))) (il:if (il:litatom il:name) il:then (symbol-package il:name) il:else nil) (il:makefile-environment-package il:*default-makefile-environment*)))))) (and il:name (symbolp il:name) (symbol-package il:name)) (il:makefile-environment-package il:*default-makefile-environment*))) *package*))) (defun sedit::profile-readtable (il:name type) "What readtable should be used when editing the item?" (labels ((il:coerce-to-readtable (il:x) (cond ((null il:x) nil) ((readtablep il:x) il:x) ((consp il:x) (il:coerce-to-readtable (eval il:x))) ((or (stringp il:x) (symbolp il:x)) (il:find-readtable il:x)) (t nil)))) (or (and il:name (not (il:memb type (quote (il:proplst il:|Expression|)))) (let ((il:files (il:whereis il:name type))) (when il:files (il:coerce-to-readtable (getf (or (get (first il:files) (quote il:makefile-environment)) il:*default-makefile-environment*) :readtable))))) *readtable*))) (il:* il:|;;| "A hacked version of an SEdit function that uses the above functions") (il:defineq (sedit::setup-profile (il:lambda (sedit::profile sedit::context) (il:* il:\; "Edited 5-May-88 10:46 by Rao") (il:* il:|;;;| "here we set up the specifics about the profile of the world we're editing in, based on what we're editing. this function must be called under WITH-PROFILE, so that the current bindings reflect the profile, because we update the profile by changing the binding as necessary and then re-saving the profile.") (il:* il:|;;;| "Use current readtable, print-base, print-case, print-level, print-length.") (il:* il:|;;;| "Set package based on name of structure editing. Maybe should be changed to reflect package of profile of file function lives in.") (il:* il:|;;;| "The rest get forced to appropriate values for editing.") (let ((sedit::name (il:|fetch| sedit::icon-title il:of sedit::context)) (type (il:fetch sedit::edit-type il:of sedit::context))) (il:setq *read-base* 10) (il:setq *read-suppress* nil) (il:* il:|;;| "Set package and readtable as determined by the file that the item lives in.") (il:setq *package* (sedit::profile-package sedit::name type)) (il:setq *readtable* (sedit::profile-readtable sedit::name type)) (il:* il:|;;| "") (il:setq *print-escape* t) (il:* il:\; "shouldn't matter") (il:setq *print-pretty* nil) (il:setq *print-circle* nil) (il:setq *print-radix* (il:neq *print-base* 10)) (il:* il:\; "interlisp semantics ") (il:setq *print-gensym* t) (il:setq *print-array* nil) (il:* il:\; "until we can edit ") (il:setq *print-structure* nil) (il:* il:\; "the structures.") (save-profile sedit::profile))) ) ) (il:* il:|;;| "") (il:declare\: il:donteval@load il:eval@compile il:dontcopy (il:filesload il:sedit-decls) (il:declare\: il:doeval@compile il:dontcopy (il:globalvars il:*default-makefile-environment*) ) ) (il:* il:|;;| "") (il:declare\: il:dontcopy (il:putprops il:sedit-profile il:makefile-environment (:package "XCL-USER" :readtable "XCL" :base 10)) (il:putprops il:sedit-profile il:filetype :compile-file) ) (il:putprops il:sedit-profile il:copyright ("Xerox Corporation" 1988)) (il:declare\: il:dontcopy (il:filemap (nil (3105 4681 (sedit::setup-profile 3118 . 4679))))) il:stop \ No newline at end of file diff --git a/lispusers/SETDEFAULTPRINTER b/lispusers/SETDEFAULTPRINTER new file mode 100644 index 00000000..d2bb41db --- /dev/null +++ b/lispusers/SETDEFAULTPRINTER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 4-Mar-87 15:57:29" {PHYLUM}LYRIC>SETDEFAULTPRINTER.;1 4454 previous date%: " 8-Jul-86 12:37:19" {PHYLUM}KOTO>SETDEFAULTPRINTER.;1) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SETDEFAULTPRINTERCOMS) (RPAQQ SETDEFAULTPRINTERCOMS ((* * the regular DEFAULTSUBITEMFN modified to recognize EVAL as a key to EVAL the CADR of the list to get the subitems) (FILES DEFAULTSUBITEMFN) (* * the setdefaultprinter functions) (FNS \sdp.get.printer \sdp.menu.subitems \sdp.set.printer) (* * SDP.PRINTERINFO is the place to look up things like printer location, it also looks on the name of the printer for a LOCATION property) (INITVARS (SDP.PRINTERINFO NIL) (\\sdp.read.table (COPYREADTABLE (QUOTE ORIG)))) (* * the variables that signal recreating the menu subitems) (VARS (\\sdp.known.printers) (\\sdp.menu.subitems)) (* * insinuate self into background menu) (ADDVARS (BackgroundMenuCommands ("Set Default Printer" (\sdp.set.printer (\sdp.get.printer)) "Asks for (new) default printer name. without entering name aborts change." (EVAL (\sdp.menu.subitems))))) (* * reset the background menu so our change takes effect, and remove space from the separators when reading printer names) (P (SETQ BackgroundMenu) (SETSYNTAX 32 (QUOTE OTHER) \\sdp.read.table))) ) (* * the regular DEFAULTSUBITEMFN modified to recognize EVAL as a key to EVAL the CADR of the list to get the subitems) (FILESLOAD DEFAULTSUBITEMFN) (* * the setdefaultprinter functions) (DEFINEQ (\sdp.get.printer (LAMBDA NIL (* N.H.Briggs "24-Mar-86 16:24") (* TBigham " 2-Dec-85 07:48") (DECLARE (GLOBALVARS LASTMOUSEX LASTMOUSEY \\sdp.read.table)) (LET* ((font (DEFAULTFONT (QUOTE DISPLAY))) (prompt "Enter printer name: ") (window (CREATEW (MAKEWITHINREGION (CREATEREGION LASTMOUSEX LASTMOUSEY (WIDTHIFWINDOW (IPLUS (STRINGWIDTH prompt font) (ITIMES 40 (CHARWIDTH (CHARCODE M) font)))) (HEIGHTIFWINDOW (FONTPROP font (QUOTE HEIGHT))))) NIL NIL T))) (RESETLST (RESETSAVE (OPENW window) (BQUOTE (CLOSEW %, window))) (SETQ input (PROMPTFORWORD prompt NIL NIL window NIL NIL (CHARCODE EOL))) (AND input (CAR (NLSETQ (READ (OPENSTRINGSTREAM input (QUOTE INPUT)) \\sdp.read.table))))))) ) (\sdp.menu.subitems (LAMBDA NIL (* N.H.Briggs "24-Mar-86 16:09") (if (AND \\sdp.menu.subitems (EQUAL \\sdp.known.printers DEFAULTPRINTINGHOST)) then \\sdp.menu.subitems else (SETQ \\sdp.known.printers (COPY DEFAULTPRINTINGHOST)) (SETQ \\sdp.menu.subitems (NCONC1 (for printer inside \\sdp.known.printers collect (LIST printer (LIST (QUOTE \sdp.set.printer) (KWOTE printer)) (OR (GETPROP (U-CASE printer) (QUOTE LOCATION)) (CDR (ASSOC (U-CASE printer) SDP.PRINTERINFO))))) (LIST "Other..." (QUOTE (\sdp.set.printer (\sdp.get.printer))) "Asks for (new) default printer name. without entering name aborts change."))))) ) (\sdp.set.printer (LAMBDA (printer) (* N.H.Briggs " 8-Jul-86 12:29") (LET ((canonicalprintername (CANONICAL.HOSTNAME printer))) (if (AND printer (NOT (STRING-EQUAL canonicalprintername (CANONICAL.HOSTNAME (CAR (SETQ DEFAULTPRINTINGHOST (MKLIST DEFAULTPRINTINGHOST))))))) then (SETQ DEFAULTPRINTINGHOST (CONS printer (SUBSET DEFAULTPRINTINGHOST (FUNCTION (LAMBDA (x) (NOT (STRING-EQUAL (CANONICAL.HOSTNAME x) canonicalprintername))))))) (PROMPTPRINT "default printer set to " printer) else (PROMPTPRINT "default printer not changed"))) NIL) ) ) (* * SDP.PRINTERINFO is the place to look up things like printer location, it also looks on the name of the printer for a LOCATION property) (RPAQ? SDP.PRINTERINFO NIL) (RPAQ? \\sdp.read.table (COPYREADTABLE (QUOTE ORIG))) (* * the variables that signal recreating the menu subitems) (RPAQQ \\sdp.known.printers NIL) (RPAQQ \\sdp.menu.subitems NIL) (* * insinuate self into background menu) (ADDTOVAR BackgroundMenuCommands ("Set Default Printer" (\sdp.set.printer (\sdp.get.printer)) "Asks for (new) default printer name. without entering name aborts change." (EVAL (\sdp.menu.subitems))) ) (* * reset the background menu so our change takes effect, and remove space from the separators when reading printer names) (SETQ BackgroundMenu) (SETSYNTAX 32 (QUOTE OTHER) \\sdp.read.table) (PUTPROPS SETDEFAULTPRINTER COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1632 3514 (\sdp.get.printer 1642 . 2336) (\sdp.menu.subitems 2338 . 2965) ( \sdp.set.printer 2967 . 3512))))) STOP \ No newline at end of file diff --git a/lispusers/SETDEFAULTPRINTER.TEDIT b/lispusers/SETDEFAULTPRINTER.TEDIT new file mode 100644 index 00000000..34c61c2a Binary files /dev/null and b/lispusers/SETDEFAULTPRINTER.TEDIT differ diff --git a/lispusers/SFFONT b/lispusers/SFFONT new file mode 100644 index 00000000..2c2295ce --- /dev/null +++ b/lispusers/SFFONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 1-Oct-91 14:10:29" |{PELE:MV:ENVOS}MEDLEY>SFFONT.;2| 36558 changes to%: (VARS SFFONTCOMS) previous date%: " 4-Feb-87 23:04:29" |{PELE:MV:ENVOS}MEDLEY>SFFONT.;1|) (* ; " Copyright (c) 1991 by Venue. All rights reserved. ") (PRETTYCOMPRINT SFFONTCOMS) (RPAQQ SFFONTCOMS ((RECORDS SF.CHARACTER SF.CHARDESC SF.DERIVATIVE SF.FACE SF.FAMILY SF.FIDUCIAL SF.MADE-FROM SF.SPLINE SF.SPLINES SF.VERSION SF.WIDTH) (FNS READ.SPLINE.FONT SF.DERIVS.TO.BEZIER SF.PRINT SFDRAW SFDRAW.CLOSED.CURVE TEST VIEW.FONT.FILES \LOOKUPSPLINEFONT \SETSPLINEFONT ginit) (DECLARE%: EVAL@LOAD DONTCOPY (FILES (LOADCOMP) IRISSTREAM) (VARS TIMESROMANDFILES TRA TRB TRC TRFILES)) (INITVARS (\SPLINEFONTSINCORE (LIST NIL))) (GLOBALVARS \SPLINEFONTSINCORE) (CONSTANTS (\CHARSEGMENTS.IRIS 10)))) (DECLARE%: EVAL@COMPILE (RECORD SF.CHARACTER (CHARCODE)) (ASSOCRECORD SF.CHARDESC (FAMILY CHARACTER FACE WIDTH FIDUCIAL VERSION SPLINES) (ACCESSFNS (SF.WIDTH (FETCH WIDTH OF DATUM)))) (RECORD SF.DERIVATIVE (XPRIME YPRIME XDPRIME YDPRIME XTPRIME YTPRIME)) (RECORD SF.FACE (WEIGHT SLOPE EXPANSION)) (RECORD SF.FAMILY (SFFAMILY)) (RECORD SF.FIDUCIAL (XFIDUCIAL YFIDUCIAL)) (RECORD SF.MADE-FROM (FILENAME XCHAR.ORIGIN YCHAR.ORIGIN XFIDUCIAL.ORIGIN YFIDUCIAL.ORIGIN)) (RECORD SF.SPLINE (%#OFKNOTS KNOTLIST WEIGHTLIST DERIVATIVELIST . OPTIONALSOLNMETHOD)) (RECORD SF.SPLINES (CLOSEDCURVELIST)) (RECORD SF.VERSION (VERSION DATE TIME)) (RECORD SF.WIDTH (XWIDTH YWIDTH)) ) (DEFINEQ (READ.SPLINE.FONT [LAMBDA (FILES FAMILY CHARSET) (* ; "Edited 4-Feb-87 22:54 by gbn") (* ;;; "reads SF files and updates \SPLINEFONTSINCORE. \SPLINEFONTSINCORE looks like (((FAMILY1 CHARSET#) FONTARRAY1) ...)") (* ;;; "should learn about sd files") (PROG (FONTARRAY FAM I CHAR) (PROG1 (RETURN (BIND INPUTSTREAM for F in (OR (LISTP FILES) (LIST FILES)) collect (RESETLST (RESETSAVE NIL (LIST 'CLOSEF? INPUTSTREAM)) (SETQ INPUTSTREAM (OPENSTREAM F 'INPUT)) (SETQ CHAR (READ INPUTSTREAM FILERDTBL)) [SETQ FAM (OR FAMILY (U-CASE (fetch SFFAMILY of (fetch FAMILY of CHAR] (* ;  "the fontarray can already be here, since a single file need not contain a whole character set.") [if (NOT (SETQ FONTARRAY (\LOOKUPSPLINEFONT FAM CHARSET))) then (\SETSPLINEFONT FAM CHARSET (SETQ FONTARRAY (ARRAY (ADD1 \MAXTHINCHAR ] (PROG1 (CONS FAM (bind C repeatwhile (NEQ 'STOP (SETQ CHAR (READ INPUTSTREAM FILERDTBL))) collect (SETA FONTARRAY (SETQ C (fetch CHARCODE of (fetch CHARACTER of CHAR))) CHAR) (PRINTOUT PROMPTWINDOW (SETQ C (CHARACTER C))) C)) (CLOSEF INPUTSTREAM]) (SF.DERIVS.TO.BEZIER [LAMBDA (KNOT XOFFSET YOFFSET SCALE DERIVATIVES) (* gbn " 1-Aug-84 05:51") (* * Compute the Bezier control points from the derivative coefficients.  Stolen from graphics>cgcubicimpl.mesa Returns an array of 4 xyz  points suitable for handing to the iris draw curve function  (IRIS.CURVE format)) (PROG [[BEZ (create BEZIER B0X _ (PLUS XOFFSET (TIMES SCALE (fetch XCOORD of KNOT))) B0Y _ (PLUS YOFFSET (TIMES SCALE (fetch YCOORD of KNOT] (DERIVS (for I from 1 to (LENGTH DERIVATIVES) collect (TIMES SCALE (QUOTIENT (CAR (NTH DERIVATIVES I)) (ELT \FACT.IRIS (IQUOTIENT (ADD1 I) 2] (replace B1X of BEZ with (PLUS (fetch B0X of BEZ) (QUOTIENT (fetch XPRIME of DERIVS) 3))) (replace B1Y of BEZ with (PLUS (fetch B0Y of BEZ) (QUOTIENT (fetch YPRIME of DERIVS) 3))) (replace B2X of BEZ with (PLUS (fetch B1X of BEZ) (QUOTIENT (PLUS (fetch XPRIME of DERIVS) (fetch XDPRIME of DERIVS)) 3))) (replace B2Y of BEZ with (PLUS (fetch B1Y of BEZ) (QUOTIENT (PLUS (fetch YPRIME of DERIVS) (fetch YDPRIME of DERIVS)) 3))) (replace B3X of BEZ with (PLUS (fetch B0X of BEZ) (fetch XPRIME of DERIVS) (fetch XDPRIME of DERIVS) (fetch XTPRIME of DERIVS))) (replace B3Y of BEZ with (PLUS (fetch B0Y of BEZ) (fetch YPRIME of DERIVS) (fetch YDPRIME of DERIVS) (fetch YTPRIME of DERIVS))) (RETURN BEZ]) (SF.PRINT [LAMBDA (STRING FONTFAMILY SCALE STREAM) (* ; "Edited 16-Jan-87 16:22 by gbn") (DECLARE%: (GLOBALVARS \SPLINEFONTSINCORE)) (* ;;; "Uses SFDRAW to draw a single char at a time to print out a string in the chosen font. Defaults to GACHA") (PROG ((FONTARRAY (ASSOC (OR FONTFAMILY 'GACHA) \SPLINEFONTSINCORE)) CHAR CHARDESC) (if FONTARRAY then (SETQ FONTARRAY (CADR FONTARRAY)) else (printout T "Spline font" %, FONTFAMILY %, "not in core. Load it with READ.SPLINE.FONT") (LISPERROR)) (for I to (NCHARS STRING) do (SETQ CHAR (NTHCHARCODE STRING I)) (SETQ CHARDESC (ELT FONTARRAY CHAR)) (if CHARDESC then (SFDRAW CHARDESC NIL NIL NIL SCALE STREAM) else (* ;  "well, what to do? ignore for now. The char is not currently there") )) (FLUSHOUTPUT STREAM) (RETURN STRING]) (SFDRAW [LAMBDA (CHARDESC PRECISION XOFFSET YOFFSET SCALE STREAM) (* gbn "24-Oct-85 16:59") (* * takes a character descriptor in SF format and draws it on STREAM) (PROG ((PRECISION (OR PRECISION \CHARSEGMENTS.IRIS)) (X (OR XOFFSET (DSPXPOSITION NIL STREAM))) (Y (OR YOFFSET (DSPYPOSITION NIL STREAM))) (SCALE (OR SCALE 1.0)) XWIDTH) (for CCURVE in (fetch SPLINES of CHARDESC) do (SFDRAW.CLOSED.CURVE CCURVE PRECISION X Y SCALE STREAM)) (MOVETO [IPLUS X (SETQ XWIDTH (TIMES SCALE (fetch XWIDTH of (fetch SF.WIDTH of CHARDESC] [IPLUS Y (TIMES SCALE (fetch YWIDTH of (fetch SF.WIDTH of CHARDESC] STREAM) (RETURN XWIDTH]) (SFDRAW.CLOSED.CURVE [LAMBDA (CCURVE PRECISION XOFFSET YOFFSET SCALE STREAM) (* gbn "21-Jun-85 03:00") (* * A closed curve looks like a list of splines.  Each spline is described by the record SF.SPLINE) (PROG ((STREAM (if (EQ (TYPENAME STREAM) 'WINDOW) then (WINDOWPROP STREAM 'DSP) else STREAM)) (SCALE (OR SCALE 1.0)) SPPOUTSTREAM) [for SPLINE in CCURVE do (* if necessary destructively change the knot list to be a list of postions) [if [NOT (type? POSITION (CAR (fetch KNOTLIST of SPLINE] then (for KNOT in (fetch KNOTLIST of SPLINE) do (RPLACD KNOT (CADR KNOT] (* draw a single spline, driven off  the stream type) (SELECTQ (TYPENAME (fetch IMAGEDATA of STREAM)) (IRISDATA (* this is for the iris colour monitor, which is interested in Bezier control  points. Use the knots together with the derivative list to produce the Bezier  points to send to the Iris) (SETQ SPPOUTSTREAM (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM))) (bind BEZIER for I to (SUB1 (fetch %#OFKNOTS of SPLINE)) as KNOT in (fetch KNOTLIST of SPLINE) as DERIVS in (fetch DERIVATIVELIST of SPLINE) do (SETQ BEZIER (SF.DERIVS.TO.BEZIER KNOT XOFFSET YOFFSET SCALE DERIVS)) (* get the bezier control points corresponding to the parametric  (derivative) definition) (SELECTQ \IRIS.VERSION (GL2 (IRIS.CRV BEZIER SPPOUTSTREAM)) (R1C (IRIS.CURVE PRECISION \BEZIERBASIS.IRIS BEZIER SPPOUTSTREAM)) (ERROR)))) (\DISPLAYDATA (* since the display is interested in the control points in the derivative form  as found here, just call the internal parametric spline drawing routine for the  display) (* (GLOBALRESOURCE \BRUSHBBT  (PROG ((%#KNOTS (fetch %#OFKNOTS of  SPLINE)) (BBT \BRUSHBBT)  (RESULT)) (SETQ RESULT  (create SPLINE %#KNOTS _ %#KNOTS DX _  (ARRAY %#KNOTS 0 0.0) DDX _  (ARRAY %#KNOTS 0 0.0) DDDX _  (ARRAY %#KNOTS 0 0.0) DY _  (ARRAY %#KNOTS 0 0.0) DDY _  (ARRAY %#KNOTS 0 0.0) DDDY _  (ARRAY %#KNOTS 0 0.0) X _  (ARRAY %#KNOTS 0 0.0) Y _  (ARRAY %#KNOTS 0 0.0)))  (for I to (SUB1 %#KNOTS) as KNOT in  (fetch KNOTLIST of SPLINE) as DERIVS  in (fetch DERIVATIVELIST of SPLINE) do  (SETA (fetch X of RESULT) I  (PLUS XOFFSET (TIMES SCALE  (fetch XCOORD of KNOT))))  (SETA (fetch Y of RESULT) I  (PLUS YOFFSET (TIMES SCALE  (fetch YCOORD of KNOT))))  (SETA (fetch (SPLINE DX) of RESULT) I  (TIMES SCALE (fetch XPRIME of DERIVS)))  (SETA (fetch DY of RESULT) I  (TIMES SCALE (fetch YPRIME of DERIVS)))  (SETA (fetch DDX of RESULT) I  (TIMES SCALE (fetch XDPRIME of DERIVS)))  (SETA (fetch DDY of RESULT) I  (TIMES SCALE (fetch YDPRIME of DERIVS)))  (SETA (fetch DDDX of RESULT) I  (TIMES SCALE (fetch XTPRIME of DERIVS)))  (SETA (fetch DDDY of RESULT) I  (TIMES SCALE (fetch YTPRIME of DERIVS)))  finally (\CURVE2 RESULT 1 NIL BBT  STREAM))))) ) (PROGN (* Don't know what kind of stream so just do it using the standard DSP fns.) (* * "JUNK TO NOT TYPE AGAIN" (SETQ %#KNOTS  (fetch %#OFKNOTS of SPLINE)) (replace %#KNOTS of RESULT with %#KNOTS)  (replace DX OF RESULT WITH (ARRAY %#KNOTS 0 0.0))  (replace DDX of RESULT with (ARRAY %#KNOTS 0 0.0))  (replace DDDX of RESULT with (ARRAY %#KNOTS 0 0.0))  (replace DY of RESULT with (ARRAY %#KNOTS 0 0.0))  (replace DDY of RESULT with (ARRAY %#KNOTS 0 0.0))  (replace DDDY of RESULT with (ARRAY %#KNOTS 0 0.0))  (replace X of RESULT with (ARRAY %#KNOTS 0 0.0))  (replace Y of RESULT with (ARRAY %#KNOTS 0 0.0))) (if SCALE then (printout T "SCALE specified for device which does not support it") (LISPERROR)) (DRAWCURVE (for KNOT in (fetch KNOTLIST of SPLINE) collect (create POSITION XCOORD _ (PLUS (fetch XCOORD of KNOT) XOFFSET) YCOORD _ (PLUS (fetch YCOORD of KNOT) YOFFSET))) NIL NIL NIL STREAM] (RETURN]) (TEST [LAMBDA (STRING COLOR SCALE) (* gbn " 1-Aug-84 02:45") (* * comment) (PROG NIL (IRIS.COLOR IRIS.BLACK) (IRIS.CLEAR) (IRIS.COLOR (OR COLOR IRIS.BLUE)) (SF.PRINT (OR STRING "Greg") NIL SCALE STR) (IRIS.GFLUSH) (RETURN]) (VIEW.FONT.FILES [LAMBDA (FILES) (* edited%: " 9-Aug-84 05:35") (* * comment) (PROG (FONTARRAY FAMILY I CHAR) (RETURN (for F in (OR (LISTP FILES) (LIST FILES)) collect (SETQ I (OPENSTREAM F 'INPUT)) (SETQ CHAR (READ I)) (CONS FAMILY (bind C repeatwhile (NEQ 'STOP (SETQ CHAR (READ I))) collect [SETQ C (CHARACTER (fetch CHARCODE of (fetch CHARACTER of CHAR] (printout T C %,) C finally (CLOSEF I]) (\LOOKUPSPLINEFONT [LAMBDA (FAMILY CHARSET) (* gbn "22-Oct-85 12:09") (* * if there is a font array in core for this charset of this font family,  this returns it, else nil) (LET ((ENTRY (SASSOC (LIST FAMILY CHARSET) \SPLINEFONTSINCORE))) (AND ENTRY (CDR ENTRY]) (\SETSPLINEFONT [LAMBDA (FAMILY CHARSET ARRAY) (* gbn "22-Oct-85 11:42") (* * installs a font array in \splinefontsincore for this family and charset) (PUTASSOC (LIST FAMILY CHARSET) ARRAY \SPLINEFONTSINCORE]) (ginit [LAMBDA NIL (* edited%: " 6-Aug-84 12:00") (if (MOUSECONFIRM "do you really want to ginit. You destroy font definitions which must be reloaded?" NIL (if (HASTTYWINDOWP) then T else PROMPTWINDOW)) then (IRIS.GINIT) (IRIS.CURSOFF) (IRIS.CLEAR) (makecolormap) (IRIS.SETCURSOR 0 1 255) (IRIS.COLOR IRIS.RED]) ) (DECLARE%: EVAL@LOAD DONTCOPY (FILESLOAD (LOADCOMP) IRISSTREAM) (RPAQQ TIMESROMANDFILES (TIMESROMAND.LC1-SF;1 TIMESROMAND.LC2-SF;1 TIMESROMAND.NUM-SF;1 TIMESROMAND.S1-SF;1 TIMESROMAND.S3-SF;1 TIMESROMAND.UC1-SF;1 TIMESROMAND.UC2-SF;1)) (RPAQQ TRA [(FAMILY TIMESROMAND) (CHARACTER 97) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 |16:35:46|) (MADE-FROM NIL 121 130 62 40) (SPLINES ((2 ((200 . 153) (200 . 45)) NIL ((0 -108.0 0 0 0 0)) NATURAL) (4 ((200 . 45) (202 . 28) (214 . 23) (223 . 27)) NIL ((-0.866666 -19.6 0 0 17.2 15.6) (7.733334 -11.8 17.2 15.6 -26.0 -6.000002) (11.93333 0.8000005 -8.8 9.599998 8.8 -9.599998)) NATURAL) (2 ((223 . 27) (227 . 20)) NIL ((4.0 -7.0 0 0 0 0)) NATURAL) (7 ((227 . 20) (216 . 9) (197 . -1) (170 . -6) (144 . -2) (126 . 7) (117 . 23)) NIL ((-9.420512 -11.06538 0 0 -9.476924 0.3923078) (-14.15898 -10.86923 -9.476924 0.3923078 -0.6153832 4.038461) (-23.94359 -8.457692 -10.09231 4.430769 11.93846 7.453844) (-28.06666 -0.2999992 1.846154 11.88461 6.861538 -9.853844) (-22.78974 6.657692 8.707692 2.030769 2.615385 7.961536) (-12.77436 12.66923 11.32308 9.992306 -11.32308 -9.992306)) NATURAL) (10 ((117 . 23) (89 . 4) (62 . -3) (37 . 3) (18 . 25) (18 . 52) (32 . 77) (60 . 98) (92 . 113) (118 . 125)) NIL ((-28.15654 -21.56226 0 0 0.9392528 15.37358) (-27.68691 -13.87547 0.9392528 15.37358 1.303736 -4.867924) (-26.0958 -0.9358488 2.242989 10.50566 -0.1541991 10.09811) (-23.9299 14.61887 2.08879 20.60377 23.31306 -17.52453) (-10.18458 26.46038 25.40185 3.079245 -15.09804 -6.0) (7.668246 26.53962 10.30381 -2.920755 7.079094 -0.4754715) (21.51161 23.38113 17.3829 -3.396226 -13.21835 -4.098113) (32.28533 17.93585 4.164558 -7.494339 -14.20569 4.867924) (29.34705 12.87547 -10.04114 -2.626415 10.04114 2.626415)) NATURAL) (2 ((118 . 125) (118 . 166)) NIL ((0 41.0 0 0 0 0)) NATURAL) (17 ((118 . 166) (110 . 187) (91 . 189) (88 . 171) (98 . 152) (85 . 130) (59 . 124) (32 . 132) (21 . 154) (31 . 182) (55 . 198) (86 . 205) (118 . 208) (148 . 205) (175 . 196) (195 . 177) (200 . 153)) NIL ((-4.255993 24.64079 0 0 -22.46404 -21.84477) (-15.48801 13.71841 -22.46404 -21.84477 46.32022 -4.776135) (-14.79195 -10.51443 23.85617 -26.62091 -0.8168106 34.94932) (8.655816 -19.66068 23.03936 8.328413 -61.05298 -21.02116) (1.168687 -21.84285 -38.01361 -12.69275 29.0287 37.13531) (-22.33057 -15.96793 -8.984904 24.44257 4.938131 -13.52012) (-28.8464 1.714581 -4.046773 10.92245 23.21877 4.945154) (-21.2838 15.10961 19.172 15.86761 4.186775 -6.260496) (-0.01840973 27.84697 23.35877 9.607112 -9.965858 -27.90316) (18.35743 23.5025 13.39291 -18.29605 -6.323341 9.873148) (28.58868 10.14302 7.069574 -8.422904 -6.740779 6.410579) (32.28786 4.925408 0.3287937 -2.012324 -2.713542 -5.515475) (31.25988 0.1553465 -2.384749 -7.527798 -0.4050512 3.651317) (28.67261 -5.546795 -2.7898 -3.876482 -1.666252 -9.089788) (25.04968 -13.96817 -4.456052 -12.96627 -16.92993 8.707838) (12.12866 -22.58052 -21.38599 -4.258433 21.38599 4.258433)) NATURAL)) ((2 ((118 . 108) (118 . 58)) NIL ((0 -50.0 0 0 0 0)) NATURAL) (9 ((118 . 58) (118 . 49) (111 . 38) (97 . 39) (90 . 49) (88 . 66) (93 . 83) (104 . 99) (118 . 108)) NIL ((1.256443 -7.739323 0 0 -7.53866 -7.564064) (-2.512887 -11.52136 -7.53866 -7.564064 -4.3067 25.82032) (-12.2049 -6.175257 -11.84536 18.25626 24.76546 -11.71723) (-11.66752 6.222386 12.9201 6.539029 -10.75515 3.048599) (-4.124999 14.28571 2.164949 9.587628 6.255152 -12.47717) (1.167526 17.63475 8.420102 -2.889543 -2.265462 4.860088) (8.454898 17.17526 6.154639 1.970545 -3.193299 -12.96318) (13.01289 12.66421 2.96134 -10.99263 -2.96134 10.99263)) NATURAL]) (RPAQQ TRB [(FAMILY TIMESROMAND) (CHARACTER 99) (FACE M R R) (WIDTH 211 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 |16:50:06|) (MADE-FROM NIL 118 130 57 78) (SPLINES ((2 ((181 . 46) (189 . 37)) NIL ((8.0 -9.0 0 0 0 0)) NATURAL) (32 ((189 . 37) (166 . 14) (135 . -1) (92 . -4) (59 . 7) (33 . 30) (16 . 66) (12 . 101) (17 . 136) (30 . 166) (51 . 189) (86 . 204) (125 . 206) (154 . 202) (180 . 189) (196 . 168) (196 . 143) (178 . 127) (155 . 124) (138 . 134) (130 . 155) (130 . 176) (124 . 189) (111 . 184) (96 . 160) (91 . 129) (93 . 95) (102 . 63) (117 . 42) (144 . 33) (167 . 39) (181 . 46)) NIL ((-21.8826 -24.50792 0 0 -6.704422 9.047542) (-25.23481 -19.98415 -6.704422 9.047542 -14.47789 2.762293) (-39.17817 -9.555464 -21.18231 11.80983 40.61599 3.903284) (-40.05249 4.206011 19.43367 15.71312 -15.98606 -6.375422) (-28.61185 16.73142 3.447612 9.337696 5.328262 9.5984) (-22.50011 30.86831 8.775874 18.9361 6.673012 -26.01818) (-10.38772 36.79532 15.44889 -7.082087 -8.020304 10.47433) (1.051008 34.95039 7.428581 3.392247 1.408212 -9.879148) (9.183696 33.40307 8.836792 -6.486902 -3.612545 -0.9577408) (16.21421 26.4373 5.224247 -7.444641 13.04197 1.710107) (27.95945 19.84771 18.26621 -5.734535 -12.55532 -11.88268) (39.948 8.171835 5.710896 -17.61722 -22.82069 15.82064) (34.24855 -1.535063 -17.1098 -1.796579 19.83808 -9.399882) (27.05779 -8.031584 2.728286 -11.19646 -14.53163 3.778893) (22.52026 -17.3386 -11.80335 -7.417568 -3.711554 0.2843065) (8.861142 -24.61401 -15.5149 -7.133261 -6.622156 19.08388) (-9.964836 -22.20533 -22.13706 11.95062 18.20018 1.380173) (-23.0018 -9.564632 -3.936874 13.33079 11.82142 -0.6045686) (-21.02796 3.463873 7.884551 12.72622 0.5141201 1.038099) (-12.88635 16.70915 8.39867 13.76432 4.122093 -15.54783) (-2.426633 22.69955 12.52076 -1.783509 -23.00249 -4.846774) (-1.407115 18.49265 -10.48173 -6.630284 3.887866 -13.06508) (-9.944906 5.329831 -6.59386 -19.69536 1.451023 -2.892914) (-15.81326 -15.81199 -5.142837 -22.58827 20.30804 18.63673) (-10.80207 -29.08189 15.16521 -3.951541 -10.6832 0.3459764) (-0.978461 -32.86044 4.482012 -3.605564 4.424731 3.979362) (5.715916 -34.47633 8.906742 0.373798 -7.015726 13.73657) (11.1148 -27.23424 1.891017 14.11037 17.63817 -4.92565) (21.8249 -15.5867 19.52919 9.184722 -27.53697 11.96602) (27.5856 -0.4189663 -8.007784 21.15074 -3.490269 -24.93843) (17.83268 8.262562 -11.49805 -3.787686 11.49805 3.787686)) NATURAL]) (RPAQQ TRC [(FAMILY TIMESROMAND) (CHARACTER 100) (FACE M R R) (WIDTH 250 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 |16:56:16|) (MADE-FROM NIL 103 130 57 78) (SPLINES ((2 ((136 . 269) (136 . 189)) NIL ((0 -80.0 0 0 0 0)) NATURAL) (15 ((136 . 189) (114 . 204) (86 . 211) (57 . 203) (40 . 190) (25 . 168) (16 . 140) (12 . 110) (13 . 82) (20 . 51) (32 . 28) (52 . 8) (82 . -2) (111 . 7) (136 . 25)) NIL ((-20.69145 16.12365 0 0 -7.851328 -6.741922) (-24.61711 12.75269 -7.851328 -6.741922 3.256639 -14.29039) (-30.84012 -1.134427 -4.594689 -21.03232 24.82477 21.9035) (-23.02242 -11.21499 20.23008 0.8711902 -24.55573 -13.32363) (-15.0702 -17.00562 -4.325648 -12.45244 13.39815 7.391023) (-12.69677 -25.76255 9.072504 -5.061419 -5.036883 1.759538) (-6.142708 -29.9442 4.035622 -3.30188 0.749383 9.57082) (-1.732394 -28.46066 4.785005 6.268941 2.039351 -16.04282) (4.072286 -30.21314 6.824355 -9.773884 -2.906779 24.60048) (9.443252 -27.68678 3.917576 14.82659 3.587763 -16.35907) (15.15471 -21.03973 7.505339 -1.532484 6.555731 10.83583) (25.93791 -17.1543 14.06107 9.303344 -17.81069 15.01576) (31.09364 -0.3430727 -3.749619 24.31911 -1.312975 -16.89888) (26.68753 15.52659 -5.062595 7.420223 5.062595 -7.420223)) NATURAL) (2 ((136 . 25) (136 . -3)) NIL ((0 -28.0 0 0 0 0)) NATURAL) (2 ((136 . -3) (241 . 10)) NIL ((105.0 13.0 0 0 0 0)) NATURAL) (2 ((241 . 10) (241 . 15)) NIL ((0 5.0 0 0 0 0)) NATURAL) (5 ((241 . 15) (231 . 19) (222 . 26) (217 . 37) (217 . 50)) NIL ((-10.07143 3.446428 0 0 0.4285715 3.321429) (-9.857142 5.107143 0.4285715 3.321429 3.857143 1.392856) (-7.5 9.125 4.285714 4.714285 2.142858 -2.892857) (-2.142857 12.39286 6.428572 1.821428 -6.428572 -1.821428)) NATURAL) (2 ((217 . 50) (217 . 300)) NIL ((0 250.0 0 0 0 0)) NATURAL) (2 ((217 . 300) (117 . 300)) NIL ((-100.0 0 0 0 0 0)) NATURAL) (2 ((117 . 300) (117 . 295)) NIL ((0 -5.0 0 0 0 0)) NATURAL) (4 ((117 . 295) (128 . 291) (134 . 283) (136 . 269)) NIL ((12.06667 -3.333333 0 0 -6.4 -4.0) (8.866666 -5.333333 -6.4 -4.0 2.0 -4.0) (3.466666 -11.33333 -4.4 -8.0 4.4 8.0)) NATURAL)) ((2 ((136 . 159) (136 . 79)) NIL ((0 -80.0 0 0 0 0)) NATURAL) (12 ((136 . 79) (133 . 52) (122 . 34) (108 . 40) (100 . 62) (96 . 88) (95 . 116) (97 . 143) (104 . 168) (117 . 179) (130 . 174) (136 . 159)) NIL ((-1.169987 -27.97882 0 0 -10.98008 5.872907) (-6.660026 -25.04236 -10.98008 5.872907 6.900384 24.63546) (-14.18991 -6.851724 -4.079692 30.50837 13.37854 -14.41478) (-11.58033 16.44926 9.298848 16.0936 -6.414546 -14.97637) (-5.488757 25.05467 2.884301 1.117225 0.279644 2.320276) (-2.464635 27.33204 3.163945 3.437501 -0.7040282 -6.304729) (0.3472968 27.61717 2.459917 -2.867228 2.536468 4.898638) (4.075448 27.19927 4.996385 2.03141 2.558155 -19.28982) (10.35091 19.58576 7.55454 -17.25841 -6.769083 0.2606583) (14.52091 2.457678 0.785456 -16.99775 -11.48182 6.247193) (9.565454 -11.41648 -10.69636 -10.75056 10.69636 10.75056)) NATURAL]) (RPAQQ TRFILES ({INDIGO}OLDSF>TIMESROMAND.LC1-SF;1 {INDIGO}OLDSF>TIMESROMAND.LC2-SF;1 {INDIGO}OLDSF>TIMESROMAND.NUM-SF;1 {INDIGO}OLDSF>TIMESROMAND.S1-SF;1 {INDIGO}OLDSF>TIMESROMAND.S3-SF;1 {INDIGO}OLDSF>TIMESROMAND.UC1-SF;1 {INDIGO}OLDSF>TIMESROMAND.UC2-SF;1)) ) (RPAQ? \SPLINEFONTSINCORE (LIST NIL)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SPLINEFONTSINCORE) ) (DECLARE%: EVAL@COMPILE (RPAQQ \CHARSEGMENTS.IRIS 10) (CONSTANTS (\CHARSEGMENTS.IRIS 10)) ) (PUTPROPS SFFONT COPYRIGHT ("Venue" 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1784 19991 (READ.SPLINE.FONT 1794 . 4813) (SF.DERIVS.TO.BEZIER 4815 . 7456) (SF.PRINT 7458 . 8733) (SFDRAW 8735 . 9574) (SFDRAW.CLOSED.CURVE 9576 . 17439) (TEST 17441 . 17819) ( VIEW.FONT.FILES 17821 . 18759) (\LOOKUPSPLINEFONT 18761 . 19148) (\SETSPLINEFONT 19150 . 19442) (ginit 19444 . 19989))))) STOP \ No newline at end of file diff --git a/lispusers/SHOWTIME b/lispusers/SHOWTIME new file mode 100644 index 00000000..2e30bb6a --- /dev/null +++ b/lispusers/SHOWTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Apr-89 18:56:29" {ERINYES}MEDLEY>SHOWTIME.;1 24672 changes to%: (FNS SHOWTIME.READ.LISPBM) previous date%: "13-May-88 16:31:25" {POOH/N}LISP>MEDLEY>LISPUSERS>SHOWTIME;1) (* " Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SHOWTIMECOMS) (RPAQQ SHOWTIMECOMS ((* ;;; "Mitch Gaarnat and (Mike?) Gocek wrote the original versions of these fns in 1985. They were later modified added to by T. Bigham in 1986 and 1987. Ron Fischer at Xerox AI Systems made a quick pass to convert the file to run in Medley XAIE.") (FNS GET.SHOWTIME.MENU MAKEBRUSH MAKEBRUSH.HEADER&BITMAP INFORES READ.RES SHOWTIME SHOWTIME.BUTTONEVENTFN SHOWTIME.GET.NAME SHOWTIME.ICONFN SHOWTIME.LOAD.BITMAP SHOWTIME.LOAD.BRUSH SHOWTIME.LOAD.DIF.FILE SHOWTIME.LOAD.RES.FILE SHOWTIME.MAKE.RES SHOWTIME.MAKE.RES.HEADER SHOWTIME.MAKE.RES.TAIL SHOWTIME.READ.BRUSH SHOWTIME.READ.LISPBM SHOWTIME.READ.PRESS SHOWTIME.READ.RES SHOWTIME.RES.CHECK&MASSAGE SHOWTIME.RESHAPE.WINDOW SHOWTIME.SAVE.BITMAP SHOWTIME.SAVE.LISPBM SHOWTIME.SCALE.BITMAP SHOWTIME.ADD.FORMAT SHOWTIME.SETUP.WINDOWPROPS SHOWTIME.SHOW.BITMAP SHOWTIME.WRITEBM) (VARS SHOWTIME.ICON SHOWTIME.MASK (SHOWTIME.LOAD.SUBITEMS) (SHOWTIME.SAVE.SUBITEMS) (SHOWTIME.MENU) (SHOWTIMETITLEREGION (QUOTE (7 7 56 29))) (SHOWTIME.DEFAULT.FORMAT (QUOTE LISP)) (BackgroundMenu) (SHOWTIME.FORMAT.FNS (QUOTE (SHOWTIME.FORMAT.FNS (RES READ.RES SHOWTIME.MAKE.RES) (LISP SHOWTIME.READ.LISPBM SHOWTIME.SAVE.LISPBM) (DIF SHOWTIME.LOAD.DIF.FILE NIL) (BRUSH SHOWTIME.LOAD.BRUSH MAKEBRUSH) (PRESS READPRESS PRESSBITMAP))))) (APPENDVARS (BackgroundMenuCommands (Showtime (QUOTE (SHOWTIME)) "Opens a showtime window for use."))) (FILES BITMAPFNS SCALEBITMAP READBRUSH) (P (SHOWTIME.ADD.FORMAT)))) (* ;;; "Mitch Gaarnat and (Mike?) Gocek wrote the original versions of these fns in 1985. They were later modified added to by T. Bigham in 1986 and 1987. Ron Fischer at Xerox AI Systems made a quick pass to convert the file to run in Medley XAIE." ) (DEFINEQ (GET.SHOWTIME.MENU (LAMBDA NIL (* ; "Edited 13-May-88 15:19 by raf") (DECLARE (GLOBALVARS SHOWTIME.MENU)) (OR SHOWTIME.MENU (SETQ SHOWTIME.MENU (create MENU TITLE _ "Viewer Options" CENTERFLG _ T MENUFONT _ (FONTCREATE (QUOTE TIMESROMAN) 12) ITEMS _ (BQUOTE ((" Load Another Picture " (QUOTE LOAD) NIL (SUBITEMS (\,@ SHOWTIME.LOAD.SUBITEMS))) ("Show a Bitmap" (QUOTE SHOW) NIL (SUBITEMS ("Put bitmap in this window" (QUOTE SHOW)) ("Reshape window to fit new Bitmap" (QUOTE RESHAPE&SHOW)))) ("Edit Bitmap" (QUOTE EDIT)) ("Redisplay" (QUOTE REDISPLAY) NIL (SUBITEMS ("Redisplay bitmap in this window" (QUOTE REDISPLAY)) ("Reshape window to fit this bitmap" (QUOTE RESHAPE&SHOW)))) ("Scale" (QUOTE SCALE)) ("Save this Picture" (QUOTE SAVE) NIL (SUBITEMS (\,@ SHOWTIME.SAVE.SUBITEMS))))))))) ) (MAKEBRUSH (LAMBDA (FILESPEC BITMAP) (* ; "Edited 13-May-88 16:00 by raf") (LET ((STREAM (GETSTREAM FILESPEC (QUOTE OUTPUT)))) (MAKEBRUSH.HEADER&BITMAP BITMAP STREAM) (CLOSEF STREAM))) ) (MAKEBRUSH.HEADER&BITMAP (LAMBDA (BITMAP STREAM) (* ; "Edited 13-May-88 16:01 by raf") (LET ((BASE (fetch BITMAPBASE of BITMAP)) (HEIGHT (fetch BITMAPHEIGHT of BITMAP)) (WIDTH (fetch BITMAPWIDTH of BITMAP)) (RWIDTH (fetch BITMAPRASTERWIDTH of BITMAP))) (BOUT STREAM 1) (BOUT STREAM 0) (BOUT STREAM (LRSH (LOGAND WIDTH 65280) 8)) (BOUT STREAM (LOGAND WIDTH 255)) (BOUT STREAM (LRSH (LOGAND HEIGHT 65280) 8)) (BOUT STREAM (LOGAND HEIGHT 255)) (for I from 1 to 8 do (BOUT STREAM 0)) (BOUT STREAM (LRSH (LOGAND RWIDTH 65280) 8)) (BOUT STREAM (LOGAND RWIDTH 255)) (for Y from 0 to (SUB1 HEIGHT) do (for X from 0 to (SUB1 RWIDTH) do (BOUT STREAM (\GETBASEBYTE BASE 0)) (BOUT STREAM (\GETBASEBYTE BASE 1)) (SETQ BASE (\ADDBASE BASE 1)))))) ) (INFORES (LAMBDA (FILE) (* ; "Edited 13-May-88 16:01 by raf") (LET (STREAM PATTERN WIDTH HEIGHT HI.X LO.X HI.Y LO.Y REAL.X REAL.Y (Header (QUOTE Interpress/Xerox/2.1/RasterEncoding/1.0% ))) (* ; "Return the width, height, bits per pixel and address of the first data byte as a list.") (SETQ STREAM (GETSTREAM (OPENFILE FILE (QUOTE INPUT)) (QUOTE INPUT))) (if (EQ Header (PACK (for X from 1 to 40 collect (CHARACTER (\BIN STREAM))))) then (* ; "bypass BEGIN 254/720000 DUP 2 MAKEVEC") (until (EQUAL (NTH (REVERSE PATTERN) (IDIFFERENCE (LENGTH PATTERN) 4)) (QUOTE (181 15 162 161 27))) do (SETQ PATTERN (push PATTERN (\BIN STREAM)))) (SETQ HI.X (\BIN STREAM)) (SETQ LO.X (\BIN STREAM)) (SETQ HI.Y (\BIN STREAM)) (SETQ LO.Y (\BIN STREAM)) (SETQ REAL.X (IDIFFERENCE (PLUS (LSH HI.X 8) LO.X) 4000)) (SETQ REAL.Y (IDIFFERENCE (PLUS (LSH HI.Y 8) LO.Y) 4000)) (LIST REAL.X REAL.Y STREAM) else (CLOSEF STREAM) NIL))) ) (READ.RES (LAMBDA (FILE) (* ; "Edited 13-May-88 16:02 by raf") (LET (STREAM A B BITMAP BASE WORDS Attributes WIDTH HEIGHT) (if (SETQ FILE (FULLNAME FILE)) then (* ; "If the file exists, check to see if it's RES format.") (if (SETQ Attributes (INFORES FILE)) then (SETQ WIDTH (CAR Attributes)) (SETQ HEIGHT (CADR Attributes)) (SETQ STREAM (CADDR Attributes)) (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT 1)) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (* ; "RESINFO leaves the file open at byte 62.0 Image data begins at byte 95") (for X from 63 to 94 do (\BIN STREAM)) (for X from 1 to (IQUOTIENT (ITIMES WIDTH HEIGHT) 16) do (SETQ A (\BIN STREAM)) (SETQ B (\BIN STREAM)) (\PUTBASE BASE 0 (LOGOR (LLSH A 8) B)) (SETQ BASE (\ADDBASE BASE 1)) (ZEROP (LOGAND X 1023))) (CLOSEF STREAM) BITMAP else (printout PROMPTWINDOW T FILE "isn't an RES file")) else (printout PROMPTWINDOW T "Can't find " FILE) NIL))) ) (SHOWTIME (LAMBDA (FILENAME FORMAT) (* TBigham " 7-Feb-87 18:05") (LET (BITMAP WIDTH HEIGHT WINDOW BITMAP.NAME) (if FILENAME then (SETQ FILENAME (\ADD.CONNECTED.DIR FILENAME)) (if (BITMAPP (SETQ BITMAP (SHOWTIME.LOAD.BITMAP FILENAME FORMAT))) then (SETQ WIDTH (BITMAPWIDTH BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (SETQ WINDOW (CREATEW (LIST 200 200 WIDTH HEIGHT))) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION SHOWTIME.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE ICONFN) (FUNCTION SHOWTIME.ICONFN)) (CLEARW WINDOW) (BITBLT BITMAP 0 0 WINDOW) (SETQ BITMAP.NAME (SET (U-CASE (FILENAMEFIELD FILENAME (QUOTE NAME))) BITMAP)) (SHOWTIME.SETUP.WINDOWPROPS WINDOW BITMAP FILENAME) else (PROMPTPRINT (CONCAT "Couldn't find " FILENAME))) else (SETQ WINDOW (CREATEW NIL "Empty Viewer")) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION SHOWTIME.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE ICONFN) (FUNCTION SHOWTIME.ICONFN)) (WINDOWPROP WINDOW (QUOTE BITMAP.VALUE) NIL) (WINDOWPROP WINDOW (QUOTE BITMAP.NAME) NIL)))) ) (SHOWTIME.BUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 13-May-88 15:35 by raf") (DECLARE (GLOBALVARS PROMPTWINDOW)) (LET (BITMAP SELECTION BITMAP.NAME ICON PERIOD.POS SWITCH) (SETQ SELECTION (MENU (GET.SHOWTIME.MENU))) (if (SETQ PERIOD.POS (STRPOS "." SELECTION)) then (SETQ SWITCH (MKATOM (SUBSTRING SELECTION 1 (SUB1 PERIOD.POS)))) else (SETQ SWITCH SELECTION)) (SELECTQ SWITCH (LOAD (SHOWTIME.LOAD.BITMAP NIL (MKATOM (SUBSTRING SELECTION 6)) WINDOW)) (SHOW (SETQ BITMAP.NAME (SHOWTIME.GET.NAME "Bitmap Name (CR to end)")) (if BITMAP.NAME then (SETQ BITMAP (EVAL BITMAP.NAME)) (SHOWTIME.SHOW.BITMAP BITMAP BITMAP.NAME WINDOW SELECTION))) (RESHAPE&SHOW (SETQ BITMAP (WINDOWPROP WINDOW (QUOTE BITMAP))) (if (BITMAPP BITMAP) then (SHOWTIME.SHOW.BITMAP BITMAP (WINDOWPROP WINDOW (QUOTE BITMAP.NAME)) WINDOW SELECTION))) (RESHAPE (SHOWTIME.RESHAPE.WINDOW BITMAP WINDOW) (CLEARW WINDOW) (BITBLT BITMAP 0 0 WINDOW)) (REDISPLAY (SETQ BITMAP (WINDOWPROP WINDOW (QUOTE BITMAP))) (CLEARW WINDOW) (BITBLT BITMAP 0 0 WINDOW)) (EDIT (if (BITMAPP (SETQ BITMAP (WINDOWPROP WINDOW (QUOTE BITMAP)))) then (SETQ BITMAP (EDIT.BITMAP BITMAP)) (WINDOWPROP WINDOW (QUOTE BITMAP) BITMAP) (CLEARW WINDOW) (BITBLT BITMAP 0 0 WINDOW) else (printout PROMPTWINDOW T "No bitmap in Viewer to edit!"))) (SAVE (if (BITMAPP (SETQ BITMAP (WINDOWPROP WINDOW (QUOTE BITMAP)))) then (SHOWTIME.SAVE.BITMAP NIL BITMAP (MKATOM (SUBSTRING SELECTION 6))))) (SCALE (SHOWTIME.SCALE.BITMAP (WINDOWPROP WINDOW (QUOTE BITMAP)) WINDOW)) NIL) (if (SETQ ICON (WINDOWPROP WINDOW (QUOTE ICONWINDOW))) then (ICONW.TITLE ICON BITMAP.NAME)))) ) (SHOWTIME.GET.NAME (LAMBDA (PROMPTSTRING USE.EOL) (* TBigham "27-Mar-86 10:42") (DECLARE (GLOBALVARS LASTMOUSEX LASTMOUSEY)) (OR PROMPTSTRING (SETQ PROMPTSTRING "Name (CR to end) ")) (LET* ((FONT (DEFAULTFONT)) (WIDTH (IPLUS (STRINGWIDTH PROMPTSTRING FONT) (ITIMES 60 (CHARWIDTH (CHARCODE A) FONT)))) (PROMPTW (CREATEW (MAKEWITHINREGION (CREATEREGION LASTMOUSEX LASTMOUSEY (WIDTHIFWINDOW WIDTH) (HEIGHTIFWINDOW (FONTPROP FONT (QUOTE HEIGHT))))) NIL NIL T))) (if USE.EOL then (RESETLST (RESETSAVE (OPENW PROMPTW) (BQUOTE (CLOSEW %, PROMPTW))) (MKATOM (PROMPTFORWORD PROMPTSTRING NIL NIL PROMPTW NIL NIL (CHARCODE EOL)))) else (RESETLST (RESETSAVE (OPENW PROMPTW) (BQUOTE (CLOSEW %, PROMPTW))) (MKATOM (PROMPTFORWORD PROMPTSTRING NIL NIL PROMPTW NIL)))))) ) (SHOWTIME.ICONFN (LAMBDA (WINDOW OLDICON) (* TBigham " 7-Feb-87 18:10") (DECLARE (GLOBALVARS SHOWTIME.ICON SHOWTIME.MASK SHOWTIMETITLEREGION)) (OR OLDICON (TITLEDICONW (create TITLEDICON ICON _ SHOWTIME.ICON MASK _ SHOWTIME.MASK TITLEREG _ SHOWTIMETITLEREGION) (WINDOWPROP WINDOW (QUOTE BITMAP.NAME)) (FONTCREATE (QUOTE GACHA) 8)))) ) (SHOWTIME.LOAD.BITMAP (LAMBDA (FILENAME FORMAT WINDOW) (* ; "Edited 13-May-88 16:18 by raf") (DECLARE (GLOBALVARS SHOWTIME.DEFAULT.FORMAT PROMPTWINDOW SHOWTIME.FORMAT.FNS WAITINGCURSOR)) (OR FILENAME (SETQ FILENAME (SHOWTIME.GET.NAME NIL T))) (OR FORMAT (SETQ FORMAT SHOWTIME.DEFAULT.FORMAT)) (LET ((NAME (U-CASE (FILENAMEFIELD FILENAME (QUOTE NAME)))) (LOADFN (CADR (FASSOC FORMAT SHOWTIME.FORMAT.FNS))) ICON BITMAP OPTION) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (if (NULL (INFILEP FILENAME)) THEN (printout PROMPTWINDOW T "Couldn't find " FILENAME) ELSEIF (NULL LOADFN) THEN (printout PROMPTWINDOW T "Can't read bitmaps in " FORMAT " format.") ELSEIF (NULL (BITMAPP (PROGN (printout PROMPTWINDOW T "Loading " FILENAME "...") (SETQ BITMAP (EVAL (LIST LOADFN (KWOTE FILENAME))))))) THEN (printout PROMPTWINDOW T "Problem loading " FORMAT " format " FILENAME) ELSE (SHOWTIME.SHOW.BITMAP BITMAP NAME WINDOW OPTION) (SETTOPVAL (U-CASE (FILENAMEFIELD FILENAME (QUOTE NAME))) BITMAP) (if (WINDOWP WINDOW) then (WINDOWPROP WINDOW (QUOTE BITMAP.NAME) NAME) (if (SETQ ICON (WINDOWPROP WINDOW (QUOTE ICONWINDOW))) then (ICONW.TITLE ICON NAME))) (printout PROMPTWINDOW "done!"))))) ) (SHOWTIME.LOAD.BRUSH (LAMBDA (FILE) (* TBigham "11-Feb-87 20:26") (CAR (READBRUSHFILE FILE)))) (SHOWTIME.LOAD.DIF.FILE (LAMBDA (FILE) (* TBigham "10-Jun-86 14:34") (* Mitch Garnaat) (LET (BITMAP BASE BITMAPRASTERWIDTH TEMPBASE WIDTH WIDTHLOW WIDTHHIGH HEIGHT HEIGHTLOW HEIGHTHIGH FILENAME STREAM) (if (INFILEP FILE) then (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT))) (for I from 0 to 7 do (\BIN STREAM)) (SETQ WIDTHLOW (\BIN STREAM)) (SETQ WIDTHHIGH (\BIN STREAM)) (SETQ WIDTH (LOGOR WIDTHLOW (LLSH WIDTHHIGH 8))) (SETQ HEIGHTLOW (\BIN STREAM)) (SETQ HEIGHTHIGH (\BIN STREAM)) (SETQ HEIGHT (LOGOR HEIGHTLOW (LLSH HEIGHTHIGH 8))) (for I from 12 to 63 do (\BIN STREAM)) (SETQ BITMAP (BITMAPCREATE (ITIMES WIDTH 8) HEIGHT 1)) (SETQ BASE (fetch BITMAPBASE of BITMAP)) (SETQ BITMAPRASTERWIDTH (fetch BITMAPRASTERWIDTH of BITMAP)) (for Y from 0 to (SUB1 HEIGHT) do (SETQ TEMPBASE (\ADDBASE BASE (ITIMES Y BITMAPRASTERWIDTH))) (for X from 0 to (SUB1 WIDTH) do (\PUTBASEBYTE TEMPBASE (IREMAINDER X 2) (\BIN STREAM)) (COND ((EQUAL (IREMAINDER X 2) 1) (SETQ TEMPBASE (\ADDBASE TEMPBASE 1)))))) (CLOSEF? STREAM) BITMAP else (PROMPTPRINT (CONCAT "Couldn't find " FILE))))) ) (SHOWTIME.LOAD.RES.FILE (LAMBDA (FILENAME) (* TBigham "30-Dec-86 12:03") (* load an RES image and makes it into a lisp bitmap) (DECLARE (GLOBALVARS WAITINGCURSOR)) (LET (BITMAP) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ BITMAP (READ.RES FILENAME))))) ) (SHOWTIME.MAKE.RES (LAMBDA (FILENAME BITMAP) (* TBigham " 1-Mar-87 18:24") (LET (STREAM) (if (AND FILENAME (SETQ STREAM (OPENSTREAM FILENAME (QUOTE OUTPUT)))) then (SETQ BITMAP (SHOWTIME.RES.CHECK&MASSAGE BITMAP)) (SHOWTIME.MAKE.RES.HEADER STREAM BITMAP) (SHOWTIME.WRITEBM BITMAP STREAM) (SHOWTIME.MAKE.RES.TAIL STREAM) (SETFILEINFO (CLOSEF? STREAM) (QUOTE TYPE) 4428)))) ) (SHOWTIME.MAKE.RES.HEADER (LAMBDA (STREAM BITMAP) (* TBigham "26-Jun-87 09:11") (LET* ((WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP)) (HEADER (QUOTE Interpress/Xerox/2.1/RasterEncoding/1.0% )) (OFFSETWIDTH (PLUS 4000 WIDTH)) (OFFSETHEIGHT 400 HEIGHT) (CLEANX (LOGAND 65535 (PLUS 4000 WIDTH))) (CLEANY (LOGAND 65535 (PLUS 4000 HEIGHT))) (LO.X.ICS (LOGAND 255 CLEANX)) (HI.X.ICS (RSH CLEANX 8)) (LO.Y.ICS (LOGAND 255 CLEANY)) (HI.Y.ICS (RSH CLEANY 8)) BOUNDARY) (SETQ BOUNDARY (for NUMBER from 32 by 32 thereis (if (ILEQ WIDTH NUMBER) then NUMBER else NIL))) (for CHAR in (UNPACK HEADER) do (PRINTCCODE (CAR (CHCON CHAR)) STREAM)) (* BEGIN |254/720000| DUP 2 MAKEVEC) (for BYTE in (QUOTE (160 102 196 8 0 0 0 254 0 10 252 128 160 181 15 162 161 27)) do (\BOUT STREAM BYTE)) (* x dimension in TCS) (\BOUT STREAM HI.X.ICS) (\BOUT STREAM LO.X.ICS) (* y dimension in TCS) (\BOUT STREAM HI.Y.ICS) (\BOUT STREAM LO.Y.ICS) (* mask image -- null) (\BOUT STREAM (QUOTE 15)) (\BOUT STREAM (QUOTE 160)) (* x dimension in ICS same as y dimension in TCS) (\BOUT STREAM HI.Y.ICS) (\BOUT STREAM LO.Y.ICS) (* y dimension in ICS same as x dimension in TCS) (\BOUT STREAM HI.X.ICS) (\BOUT STREAM LO.X.ICS) (* samples per pixel) (\BOUT STREAM (QUOTE 15)) (\BOUT STREAM (QUOTE 161)) (* max sample value) (\BOUT STREAM (QUOTE 15)) (\BOUT STREAM (QUOTE 161)) (* samples interleaved) (\BOUT STREAM (QUOTE 15)) (\BOUT STREAM (QUOTE 160)) (* first transformation from ICS to TCS) (\BOUT STREAM (QUOTE 15)) (* -90 rotate) (\BOUT STREAM (QUOTE 70)) (* second transformation from ICS to TCS) (\BOUT STREAM (QUOTE 160)) (\BOUT STREAM (QUOTE 163)) (* short integer) (\BOUT STREAM (QUOTE 15)) (\BOUT STREAM (QUOTE 160)) (* sense of the transform) (\BOUT STREAM HI.Y.ICS) (\BOUT STREAM LO.Y.ICS) (* translate transform) (\BOUT STREAM (QUOTE 160)) (\BOUT STREAM (QUOTE 162)) (* CONCAT) (\BOUT STREAM (QUOTE 160)) (\BOUT STREAM (QUOTE 165)) (\BOUT STREAM (QUOTE 233)) (LET (HI.NIBBLE MID.NIBBLE LO.NIBBLE PACKED.PIXEL.VECTOR.SIZE CLEANNUM) (SETQ PACKED.PIXEL.VECTOR.SIZE (PLUS 4 (IQUOTIENT (ITIMES BOUNDARY HEIGHT) 8))) (SETQ CLEANNUM (LOGAND 16777215 PACKED.PIXEL.VECTOR.SIZE)) (SETQ HI.NIBBLE (RSH (LOGAND 16711680 CLEANNUM) 16)) (SETQ MID.NIBBLE (RSH (LOGAND 65280 CLEANNUM) 8)) (SETQ LO.NIBBLE (LOGAND 255 CLEANNUM)) (\BOUT STREAM HI.NIBBLE) (\BOUT STREAM MID.NIBBLE) (\BOUT STREAM LO.NIBBLE)) (* bits per sample) (\BOUT STREAM (QUOTE 0)) (\BOUT STREAM (QUOTE 1)) (\BOUT STREAM HI.X.ICS) (\BOUT STREAM LO.X.ICS))) ) (SHOWTIME.MAKE.RES.TAIL (LAMBDA (STREAM) (* TBigham " 4-Apr-86 06:38") (LET ((DATA (QUOTE (161 194 15 160 15 161 15 160 15 163 197 5 88 101 114 111 120 197 10 71 114 97 121 76 105 110 101 97 114 15 162 161 27 161 166 160 231 15 160 66 190 160 103)))) (for BYTE in DATA do (BOUT STREAM BYTE)))) ) (SHOWTIME.READ.BRUSH (LAMBDA (FILENAME) (* TBigham "30-Dec-86 12:00") (CAR (READBRUSHFILE FILENAME)))) (SHOWTIME.READ.LISPBM (LAMBDA (FILENAME) (* ; "Edited 10-Apr-89 18:51 by Briggs") (LET ((STREAM (OPENSTREAM FILENAME (QUOTE INPUT)))) (if (STREAMP STREAM) then (PROG1 (READBM STREAM) (CLOSEF STREAM)) else NIL))) ) (SHOWTIME.READ.PRESS (LAMBDA (FILENAME) (* TBigham "30-Dec-86 11:59") (READPRESS (OPENFILE FILENAME (QUOTE INPUT))))) (SHOWTIME.READ.RES (LAMBDA (FILENAME) (* TBigham "30-Dec-86 12:03") (* load an RES image and makes it into a lisp bitmap) (DECLARE (GLOBALVARS WAITINGCURSOR)) (LET (BITMAP) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ BITMAP (READ.RES FILENAME))))) ) (SHOWTIME.RES.CHECK&MASSAGE (LAMBDA (BITMAP) (* TBigham " 1-Mar-87 19:31") (LET ((HEIGHT (fetch BITMAPHEIGHT of BITMAP)) (WIDTH (fetch BITMAPWIDTH of BITMAP)) BOUNDARY BM) (* if the bitmap doesn't fit on a 32 bit boundary, extend the bitmap to do so) (if (ZEROP (REMAINDER WIDTH 32)) then BITMAP else (SETQ BOUNDARY (for NUMBER from 32 by 32 thereis (if (ILEQ WIDTH NUMBER) then NUMBER))) (SETQ BM (BITMAPCREATE BOUNDARY HEIGHT)) (BITBLT BITMAP 0 0 BM) BM))) ) (SHOWTIME.RESHAPE.WINDOW (LAMBDA (BITMAP WINDOW) (* TBigham "10-Mar-86 15:51") (LET NIL (SHAPEW WINDOW (CREATEREGION (CAR (WINDOWPROP WINDOW (QUOTE REGION))) (CADR (WINDOWPROP WINDOW (QUOTE REGION))) (WIDTHIFWINDOW (BITMAPWIDTH BITMAP)) (HEIGHTIFWINDOW (BITMAPHEIGHT BITMAP) T))))) ) (SHOWTIME.SAVE.BITMAP (LAMBDA (FILENAME BITMAP FORMAT) (* ; "Edited 13-May-88 15:56 by raf") (DECLARE (GLOBALVARS SHOWTIME.DEFAULT.FORMAT PROMPTWINDOW SHOWTIME.FORMAT.FNS WAITINGCURSOR)) (OR FILENAME (SETQ FILENAME (SHOWTIME.GET.NAME NIL T))) (OR FORMAT (SETQ FORMAT SHOWTIME.DEFAULT.FORMAT)) (LET ((SAVEFN (CADDR (FASSOC FORMAT SHOWTIME.FORMAT.FNS)))) (if (NULL FILENAME) THEN (printout PROMPTWINDOW "Null filename.") ELSEIF (NOT (BITMAPP BITMAP)) THEN (printout PROMPTWINDOW BITMAP " not a bitmap.") ELSEIF (NULL SAVEFN) THEN (printout PROMPTWINDOW "Can't write bitmaps out in " FORMAT " format.") ELSE (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (printout PROMPTWINDOW T "Saving " FILENAME "...") (EVAL (LIST SAVEFN (KWOTE FILENAME) (KWOTE BITMAP))) (printout PROMPTWINDOW "done!"))))) ) (SHOWTIME.SAVE.LISPBM (LAMBDA (FILENAME BITMAP) (* ; "Edited 13-May-88 15:59 by raf") (LET (STREAM) (if (AND FILENAME (SETQ STREAM (OPENSTREAM FILENAME (QUOTE OUTPUT)))) then (WRITEBM STREAM BITMAP) (CLOSEF STREAM)))) ) (SHOWTIME.SCALE.BITMAP (LAMBDA (BITMAP WINDOW) (* TBigham "31-Mar-86 15:42") (DECLARE (GLOBALVARS PROMPTWINDOW WAITINGCURSOR)) (LET (XSCALE YSCALE SCALE) (if (BITMAPP BITMAP) then (OR (SETQ XSCALE (RNUMBER "X SCALE FACTOR" NIL NIL NIL T T)) (SETQ XSCALE 1)) (OR (SETQ YSCALE (RNUMBER "Y SCALE FACTOR" NIL NIL NIL T T)) (SETQ YSCALE 1)) (SETQ SCALE (CONS (FLOAT XSCALE) (FLOAT YSCALE))) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ BITMAP (SCALEBITMAP BITMAP SCALE))) (WINDOWPROP WINDOW (QUOTE BITMAP) BITMAP) (SETTOPVAL (WINDOWPROP WINDOW (QUOTE BITMAP.NAME)) BITMAP) (CLEARW WINDOW) (BITBLT BITMAP 0 0 WINDOW) else (printout PROMPTWINDOW T (CONCAT BITMAP " not a bitmap."))))) ) (SHOWTIME.ADD.FORMAT (LAMBDA (FORMAT READFN WRITEFN) (* TBigham "30-Dec-86 13:11") (DECLARE (GLOBALVARS SHOWTIME.FORMAT.FNS SHOWTIME.LOAD.SUBITEMS SHOWTIME.MENU SHOWTIME.SAVE.SUBITEMS)) (* adds information to an assoc list which identifies read and write functions for different bitmap formats) (LET NIL (if FORMAT then (PUTASSOC FORMAT (LIST READFN WRITEFN) SHOWTIME.FORMAT.FNS)) (SETQ SHOWTIME.LOAD.SUBITEMS (for EACH in (CDR SHOWTIME.FORMAT.FNS) collect (LIST (CONCAT (CAR EACH) " Format") (KWOTE (MKATOM (CONCAT "LOAD." (CAR EACH))))))) (SETQ SHOWTIME.SAVE.SUBITEMS (for EACH in (CDR SHOWTIME.FORMAT.FNS) collect (LIST (CONCAT (CAR EACH) " Format") (KWOTE (MKATOM (CONCAT "SAVE." (CAR EACH))))))) (SETQ SHOWTIME.MENU))) ) (SHOWTIME.SETUP.WINDOWPROPS (LAMBDA (WINDOW BITMAP NAME) (* TBigham "27-Mar-86 10:41") (PROGN (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT "Viewer of " NAME)) (WINDOWPROP WINDOW (QUOTE BITMAP.NAME) NAME) (WINDOWPROP WINDOW (QUOTE BITMAP) BITMAP))) ) (SHOWTIME.SHOW.BITMAP (LAMBDA (BITMAP NAME WINDOW OPTION) (* TBigham " 7-Feb-87 18:43") (DECLARE (GLOBALVARS PROMPTWINDOW)) (LET NIL (if (BITMAPP BITMAP) then (OR NAME (SETQ NAME (WINDOWPROP WINDOW (QUOTE BITMAP.NAME)))) (if (EQ OPTION (QUOTE RESHAPE&SHOW)) then (SHOWTIME.RESHAPE.WINDOW BITMAP WINDOW)) (CLEARW WINDOW) (BITBLT BITMAP 0 0 WINDOW) (SHOWTIME.SETUP.WINDOWPROPS WINDOW BITMAP NAME) else (printout PROMPTWINDOW T BITMAP " not a bitmap")))) ) (SHOWTIME.WRITEBM (LAMBDA (BITMAP STREAM) (* TBigham " 1-Mar-87 18:19") (* "TBigham & Wall" " 7-Apr-86 10:19") (LET* ((BASE (fetch BITMAPBASE of BITMAP)) (HEIGHT (fetch BITMAPHEIGHT of BITMAP)) (WIDTH (fetch BITMAPWIDTH of BITMAP)) (RWIDTH (fetch BITMAPRASTERWIDTH of BITMAP)) BOUNDARY BM) (if (ZEROP (REMAINDER WIDTH 32)) then (for Y from 0 to (SUB1 HEIGHT) do (for X from 0 to (SUB1 RWIDTH) do (\BOUT STREAM (\GETBASEBYTE BASE 0)) (\BOUT STREAM (\GETBASEBYTE BASE 1)) (SETQ BASE (\ADDBASE BASE 1)))) else (SETQ BOUNDARY (for NUMBER from 32 by 32 thereis (if (ILEQ WIDTH NUMBER) then NUMBER))) (SETQ BM (BITMAPCREATE BOUNDARY HEIGHT)) (BITBLT BITMAP 0 0 BM) (SHOWTIME.WRITEBM BM STREAM)))) ) ) (RPAQQ SHOWTIME.ICON #*(80 84)@C@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@CMOO@@@@@@@@@@@@@@@@GLAOO@@@@@@@@@@@@@@@GL@AOO@@@@@@@@@@@@@@GN@@OOO@@@@@@@@@@@@@GN@@OOOO@@@@@@@@@@@@ON@@GOMOO@@@@@@@@@@@ON@@GOLAOO@@@@@@@@@@OO@@GOL@AOO@@@@@@@@@OO@@GON@@OOO@@@@@@@AOO@@CON@@OOOO@@@@@@AOO@@CON@@GOMOO@@@@@AOOH@CON@@GOLAOO@@@@AOOH@COO@@GOL@AOO@@@AOOH@AOO@@GON@@OOO@@@AOO@AOO@@CON@@OOOO@@@AOOAOO@@CON@@OOMOO@@@AOOOOH@CON@@GOLAO@@@@AOOOH@COO@@GOL@C@@@@@AOOH@AOO@@GON@C@@@@@@AOO@AOO@@GON@G@@@@@@@AOOAOO@@CON@F@@@@@@@@AOOOOH@CON@F@@@@@@@@@AOOOH@COO@F@@@@@@@@@@AOOH@COO@N@@@@@@@@@@@AOO@AOO@L@@@@@@@@@@@@AOOAOO@L@@@@@@@@@@@@@AOOOOHL@@@@@@@@@@@@@@AOOOIL@@@@@@@@@@@@@@@AOOIH@@@@@@@@@@@@@@@@AOIH@@@@@@@@@@@@@@@@@AOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOHGALF@LGLD@DDOND@GHOGKKNMOFONMKFNGLNOGHOGOKNMOFNNOKNNCHNOOHOGOKNMOFFLOKNNKJNOOHOHGH@MOGFMOKNNIBN@OHOOKKNMOGFMOKNNMFNOOHOOKKNMOG@AOKNNLFNOOHOGKKNMOGKKOKNNNNNOGHOHGALF@OKKOALDGLD@GHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH) (RPAQQ SHOWTIME.MASK #*(80 84)@C@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@COOO@@@@@@@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@GOOOOO@@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@OOOOOOOOO@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@OOOOOOOOOOO@@@@@@@@@OOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOO@@@@AOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOO@@@@AOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOON@@@@@@@@AOOOOOOOOOON@@@@@@@@@AOOOOOOOOON@@@@@@@@@@AOOOOOOOON@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@AOOOOOOL@@@@@@@@@@@@@AOOOOOL@@@@@@@@@@@@@@AOOOOL@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@@AOOH@@@@@@@@@@@@@@@@@AOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH) (RPAQQ SHOWTIME.LOAD.SUBITEMS NIL) (RPAQQ SHOWTIME.SAVE.SUBITEMS NIL) (RPAQQ SHOWTIME.MENU NIL) (RPAQQ SHOWTIMETITLEREGION (7 7 56 29)) (RPAQQ SHOWTIME.DEFAULT.FORMAT LISP) (RPAQQ BackgroundMenu NIL) (RPAQQ SHOWTIME.FORMAT.FNS (SHOWTIME.FORMAT.FNS (RES READ.RES SHOWTIME.MAKE.RES) (LISP SHOWTIME.READ.LISPBM SHOWTIME.SAVE.LISPBM) (DIF SHOWTIME.LOAD.DIF.FILE NIL) (BRUSH SHOWTIME.LOAD.BRUSH MAKEBRUSH) (PRESS READPRESS PRESSBITMAP))) (APPENDTOVAR BackgroundMenuCommands (Showtime (QUOTE (SHOWTIME)) "Opens a showtime window for use.") ) (FILESLOAD BITMAPFNS SCALEBITMAP READBRUSH) (SHOWTIME.ADD.FORMAT) (PUTPROPS SHOWTIME COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2126 20535 (GET.SHOWTIME.MENU 2136 . 2931) (MAKEBRUSH 2933 . 3123) ( MAKEBRUSH.HEADER&BITMAP 3125 . 3863) (INFORES 3865 . 4778) (READ.RES 4780 . 5689) (SHOWTIME 5691 . 6711) (SHOWTIME.BUTTONEVENTFN 6713 . 8306) (SHOWTIME.GET.NAME 8308 . 9067) (SHOWTIME.ICONFN 9069 . 9407) (SHOWTIME.LOAD.BITMAP 9409 . 10592) (SHOWTIME.LOAD.BRUSH 10594 . 10692) (SHOWTIME.LOAD.DIF.FILE 10694 . 11765) (SHOWTIME.LOAD.RES.FILE 11767 . 12032) (SHOWTIME.MAKE.RES 12034 . 12411) ( SHOWTIME.MAKE.RES.HEADER 12413 . 14913) (SHOWTIME.MAKE.RES.TAIL 14915 . 15214) (SHOWTIME.READ.BRUSH 15216 . 15322) (SHOWTIME.READ.LISPBM 15324 . 15541) (SHOWTIME.READ.PRESS 15543 . 15664) ( SHOWTIME.READ.RES 15666 . 15926) (SHOWTIME.RES.CHECK&MASSAGE 15928 . 16392) (SHOWTIME.RESHAPE.WINDOW 16394 . 16681) (SHOWTIME.SAVE.BITMAP 16683 . 17478) (SHOWTIME.SAVE.LISPBM 17480 . 17703) ( SHOWTIME.SCALE.BITMAP 17705 . 18394) (SHOWTIME.ADD.FORMAT 18396 . 19125) (SHOWTIME.SETUP.WINDOWPROPS 19127 . 19376) (SHOWTIME.SHOW.BITMAP 19378 . 19835) (SHOWTIME.WRITEBM 19837 . 20533))))) STOP \ No newline at end of file diff --git a/lispusers/SHOWTIME.TEDIT b/lispusers/SHOWTIME.TEDIT new file mode 100644 index 00000000..89b284b4 Binary files /dev/null and b/lispusers/SHOWTIME.TEDIT differ diff --git a/lispusers/SIGMA20-MRR-C0.DISPLAYFONT b/lispusers/SIGMA20-MRR-C0.DISPLAYFONT new file mode 100644 index 00000000..9b1a5b85 Binary files /dev/null and b/lispusers/SIGMA20-MRR-C0.DISPLAYFONT differ diff --git a/lispusers/SIMPLECHAT b/lispusers/SIMPLECHAT new file mode 100644 index 00000000..e7c38ae1 --- /dev/null +++ b/lispusers/SIMPLECHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "20-Sep-88 20:44:51" {erinyes}medley>simplechat.\;2 12467 |changes| |to:| (fns ttychat) |previous| |date:| "30-Oct-87 16:20:30" {erinyes}medley>simplechat.\;1) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint simplechatcoms) (rpaqq simplechatcoms ((fns ttychat ttychat.eosop ttychat.login ttychat.typeout ttychat.close) (vars (ttychat.ttbl nil)) (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama) (nlaml) (lama ttychat))))) (defineq (ttychat (cl:lambda (&optional host logoption) (* \; "Edited 20-Sep-88 20:44 by masinter") (prog (connection streams openfn result) (or host (setq host defaultchathost)) (cond ((not (or host (setq host (promptforword " Host: " nil "Enter name of host to chat to, or to abort" nil nil nil (charcode (cr)))))) (return nil))) (cond ((not (setq openfn (find.chat.protocol host))) (* \;  "Don't know how to talk to this host") (return (concat "Unknown Chat host: " host))) ((not (setq streams (apply* (progn (setq host (car openfn)) (* \;  "Value returned was (CanonicalHostName OpenFn)") (cadr openfn)) host))) (return "Failed")) (t (let* ((instream (car streams)) (outstream (cdr streams))) (streamprop instream 'oldeosop (|fetch| endofstreamop |of| instream)) (|replace| endofstreamop |of| instream |with| (function ttychat.eosop)) (cond ((not (fmemb host chat.allhosts)) (setq chat.allhosts (cons host chat.allhosts)) (setq chat.hostmenu))) (let (typeout (key (|fetch| (linebuffer keyboardstream) |of| \\linebuf.ofd) ) ch (state (list ':binary)) (okey \\currentkeyaction) (nkey nil)) (cl:unwind-protect (progn (cond ((eq key \\keyboard.stream) (setq \\currentkeyaction (setq nkey (let ((keyaction (keyactiontable \\defaultkeyaction))) (|for| pair |in| (currentinterrupts keyaction) |when| (leq (car pair) 255) |do| (intchar (car pair) nil nil keyaction)) (* \;  " turn off all interrupts in charset 0") (|for| pair |in| chat.interrupts |do| (intchar (car pair) nil nil keyaction)) (|for| pair |in| chat.keyactions |do| (keyaction (car pair) (cdr pair) keyaction)) keyaction))))) (printout t "[Connected to " host ", type ^] to escape]" t) (setq typeout (add.process `(ttychat.typeout ',instream ',(getstream t 'output) ',state ',(this.process)) 'name 'chat.typeout)) (and (neq logoption 'none) (ttychat.login instream outstream host logoption)) (prog nil wait-for-typein (cond ((null (car state)) (return nil))) (cond ((not (readp key)) (go wait))) got-char (setq ch (bin key)) (cond ((eq ch chat.controlchar) (setq ch (logand (bin key) 31))) ((eq ch chat.metachar) (setq ch (logor (bin key) 128))) ((eq ch (charcode "^]")) (forceoutput outstream) (selectq (askuser nil nil "Chat command:" '((b . "inary") (t . "ext") (c . "lose") (" "))) (b (rplaca state ':binary)) (t (rplaca state ':terminal)) (c (return nil)) nil) (terpri t) (go no-char)) ((igeq ch \\maxthinchar) (cond ((eq (lrsh ch 8) 1) (setq ch (logor 128 (logand ch 127)))) (t (ringbells) (go no-char))))) (bout outstream ch) (cond ((readp key) (go got-char))) no-char (cond ((null (car state)) (* |;;|  "check here 'cause the other process might have aborted") (return nil))) (forceoutput outstream) wait (cond ((null (car state)) (return nil))) (waitforinput 1000) (go wait-for-typein))) (* |;;| "here be unwind protect clauses ") (cond ((eq \\currentkeyaction nkey) (setq \\currentkeyaction okey))) (add.process `(ttychat.close ',typeout ',instream ',outstream))))) (return host)))))) (ttychat.eosop (lambda (stream) (* \; "Edited 30-Oct-87 13:32 by Masinter") (* |;;;| "Return -1 to indicate EOS to CHAT, and restore the streams EOS op incase it's needed for other things.") (|replace| endofstreamop |of| stream |with| (or (streamprop stream (quote eosop)) (function \\eoserror))) -1) ) (ttychat.login (lambda (instream outstream host option) (* \; "Edited 30-Oct-87 13:47 by Masinter") (prog ((ostype (getostype host)) (loginfo (gethostinfo host (quote loginfo))) name/pass com) (or loginfo (return)) (setq name/pass (\\internal/getpassword host nil nil nil nil ostype)) (setq com (cond (option) ((assoc (quote attach) loginfo) (or (chat.loginfo instream host (car name/pass)) (quote login))) (t (* \; "Don't know how to do anything but login, so silly to try anything else") (quote login)))) (cond ((null (setq loginfo (assoc com loginfo))) (|printout| promptwindow t "Login option " com " not implemented for this type of host")) (t (|for| x |in| (cdr loginfo) |do| (selectq x (cr (bout outstream (charcode cr)) (forceoutput outstream)) (lf (bout outstream (charcode lf)) (forceoutput outstream)) (username (prin3 (car name/pass) outstream)) (password (prin3 (\\decrypt.pwd (cdr name/pass)) outstream)) (wait (* \; "Some systems do not permit typeahead") (cond ((not (chat.flush&wait instream)) (* \; "Couldn't sync, so wait longer.") (dismiss chat.wait.time))) (dismiss chat.wait.time)) (prin3 x outstream))) (forceoutput outstream))))) ) (ttychat.typeout (lambda (instream terminal state proc) (* \; "Edited 30-Oct-87 16:19 by masinter") (settermtable (or ttychat.ttbl (setq ttychat.ttbl (let ((tt (copytermtable (quote orig)))) (|for| i |from| 0 |to| 31 |do| (echochar i (quote real) tt)) (echochar (charcode lf) (quote ignore) tt) tt)))) (let (msg ch last-char space-width) (or (equal (charwidth (charcode "i") terminal) (charwidth (charcode "W") terminal)) (dspfont defaultfont terminal)) (setq space-width (charwidth (charcode space) terminal)) (|while| (igeq (setq ch (bin instream)) 0) |do| (* \; "Print any protocol related msgs that might have come along while we where asleep") (if (eq (car state) (quote :binary)) then (bout terminal ch) else (selcharq ch (lf (|if| (eq last-char (charcode cr)) |then| (* \; " ignore ") nil)) (^h (dspbackup space-width terminal)) (progn (setq last-char ch) (bout terminal ch)))))) (printout terminal "[Connection closed remotely]" t) (rplaca state nil) (* \; "tell other process we aborted") (wake.process proc t)) ) (ttychat.close (lambda (typeout instream outstream) (* \; "Edited 30-Oct-87 14:39 by Masinter") (* |;;;| "Close the streams for a connection if they are open.") (del.process typeout) (cond ((openp instream) (closef instream))) (cond ((openp outstream) (closef outstream)))) ) ) (rpaqq ttychat.ttbl nil) (declare\: donteval@load doeval@compile dontcopy compilervars (addtovar nlama ) (addtovar nlaml ) (addtovar lama ttychat) ) (putprops simplechat copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil (792 12210 (ttychat 802 . 9430) (ttychat.eosop 9432 . 9738) (ttychat.login 9740 . 10899) (ttychat.typeout 10901 . 11927) (ttychat.close 11929 . 12208))))) stop \ No newline at end of file diff --git a/lispusers/SIMPLIFY b/lispusers/SIMPLIFY new file mode 100644 index 00000000..a9713358 --- /dev/null +++ b/lispusers/SIMPLIFY @@ -0,0 +1 @@ +(FILECREATED "19-Feb-87 09:42:40" {QV}PARSER>SIMPLIFY.;1 4714 previous date: " 6-NOV-79 17:25:50" SIMPLIFY.;3) (* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT SIMPLIFYCOMS) (RPAQQ SIMPLIFYCOMS ((* Tools for symbolic simplification of LISP forms) (FNS SIMPLIFY) (FNS APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL) (BLOCKS (APPLYFORM APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL)))) (* Tools for symbolic simplification of LISP forms) (DEFINEQ (SIMPLIFY [LAMBDA (FORM) (* bas: " 6-NOV-79 16:51") (* Eventually this will be a general symbolic  simplification package, but for now its just a dummy  entry) FORM]) ) (DEFINEQ (APPLYFORM [LAMBDA (FN ARG1) (* bas: " 6-NOV-79 17:24") (PROG (FNARG FNFORM) (RETURN (if (AND (EQ (CAR (LISTP FN)) (QUOTE LAMBDA)) [LISTP (CAR (LISTP (CDR FN] (NULL (CDADR FN)) (LITATOM (SETQ FNARG (CAADR FN))) FNARG (OR (PROGN (SETQ FNFORM (if (CDDDR FN) then (CONS (QUOTE PROGN) (CDDR FN)) else (CADDR FN))) (SIMPLEP ARG1)) (ONCE FNARG FNFORM))) then (* We know that FN is a LAMBDA with one non-NIL litatom argument, and that either FNARG can be safely evaluated  multiple times or the function body only references it once.) (if (EQ FNARG ARG1) then (* Arg and arg name are same so body will do) FNFORM else (SUBSTVAL ARG1 FNARG FNFORM)) else (LIST FN ARG1]) (ONCE [LAMBDA (ATOM FORM FLG) (* bas: "19-AUG-78 17:34") (DECLARE (SPECVARS FLG)) (ONCE1 ATOM FORM) (NEQ FLG (QUOTE FAILED]) (ONCE1 [LAMBDA (A L) (* bas: "18-SEP-79 17:03") (for I in L do [if (LISTP I) then (OR (OPAQUE I A) (ONCE1 A I)) elseif (EQ A I) then (SETQ FLG (if FLG then (QUOTE FAILED) else (QUOTE ONCE] until (EQ FLG (QUOTE FAILED]) (OPAQUE [LAMBDA (FORM VAR) (* rmk: " 5-AUG-79 22:11") (* Determines if VAR substitution can take place in  FORM) (SELECTQ (CAR FORM) (QUOTE T) ([LAMBDA NLAMBDA] (FMEMB VAR (CADR FORM))) [PROG (for I in (CADR FORM) thereis (EQ VAR (if (LISTP I) then (CAR I) else I] NIL]) (SIMPLEP [LAMBDA (FORM) (* rmk: " 5-AUG-79 22:06") (* Decides if a form is simple enough so that it can  be evaluated repeatedly rather than taking a LAMBDA  binding) (OR (ATOM FORM) (SELECTQ (CAR (LISTP FORM)) ((QUOTE CAR CDR CADR CDDR) (LITATOM (CADR FORM))) NIL) (STRINGP FORM]) (SUBSTVAL [LAMBDA (NEW OLD FORM) (* bas: " 8-MAR-79 20:39") (* Substitutes NEW for OLD in FORM. Just like SUBST except is sensitive to opacity) (if (LISTP FORM) then [if (OPAQUE FORM OLD) then FORM else (PROG (NSCR OSCR) (RETURN (if [SETQ OSCR (for I in FORM thereis (NEQ I (SETQ NSCR (SUBSTVAL NEW OLD I] then (for I in FORM collect (if (NULL OSCR) then (SUBSTVAL NEW OLD I) elseif (EQ OSCR I) then (SETQ OSCR NIL) NSCR else I)) else FORM] elseif (EQ FORM OLD) then NEW else FORM]) ) [DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK: APPLYFORM APPLYFORM ONCE ONCE1 OPAQUE SIMPLEP SUBSTVAL) ] (PUTPROPS SIMPLIFY COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (541 874 (SIMPLIFY 551 . 872)) (875 4521 (APPLYFORM 885 . 1935) (ONCE 1937 . 2140) ( ONCE1 2142 . 2557) (OPAQUE 2559 . 3085) (SIMPLEP 3087 . 3588) (SUBSTVAL 3590 . 4519))))) STOP \ No newline at end of file diff --git a/lispusers/SINGLEFILEINDEX b/lispusers/SINGLEFILEINDEX new file mode 100644 index 00000000..1c8ed084 --- /dev/null +++ b/lispusers/SINGLEFILEINDEX @@ -0,0 +1 @@ +(FILECREATED "15-Apr-88 09:50:23" {ERINYES}KOTO>SINGLEFILEINDEX.;2 41909 changes to: (FNS \SFI.CENTERPRINT) previous date: "31-Mar-86 17:15:30" {ERINYES}KOTO>LISPUSERS>SINGLEFILEINDEX.;1) (* Copyright (c) 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT SINGLEFILEINDEXCOMS) (RPAQQ SINGLEFILEINDEXCOMS [(COMS (* * "Created by Christopher Tong and JonL White, February 1984. Heavily revised by Bill van Melle, March 1986." ) (* SINGLEFILEINDEX) (FNS SINGLEFILEINDEX \SFI.Q1UP \FILELISTING SINGLEFILEINDEX2 SINGLEFILEINDEX1 \SFI.AnalyzeLine \SFI.FLUSHFONTCHANGE PrintFnDef INDEXCOPYBYTES INDEXNEWLINE INDEXNEWPAGE \SFI.SORTINDEX UALPHORDERCAR \SFI.FILTER.INDEX) (FNS PrintFileTitle \SFI.PRINT.INDEX PrintIndex \SFI.PrintIndexFactors PrintRelativeFunctionIndex \SFI.CENTERPRINT PRINTDOTS \SFI.LISTINGHEADER \SFI.BreakLine) ) (INITVARS (PRINTERDEVICEFILENAME (QUOTE {LPT})) (RELATIVEINDEXFLG) (SINGLEFILEINDEX.TWOSIDED) (SINGLEFILEINDEX.DONTSPAWN) (\SFI.PROCESS.COMMANDS) (\SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX")) (\SFI.PROCESS) (ERRORMESSAGESTREAM T)) (ADDVARS (SINGLEFILEINDEX.TYPES (MACRO DEFMACRO) (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR) TestForVar T) (VAR READVARS TestForUglyVars) (BITMAP RPAQ TestForBitmap) (CONSTANTS CONSTANTS TestForConstants) (RECORD (eval CLISPRECORDTYPES)) (PROPERTY PUTPROPS TestForProp) (COURIERPROGRAM COURIERPROGRAM) (TEMPLATE SETTEMPLATE TestForQuotedType) (I.S.OPR I.S.OPR TestForQuotedType) (RESOURCES PUTDEF TestForResource) (ADVICE READVISE)) (SINGLEFILEINDEX.PROPERTIES (COPYRIGHT) (READVICE ADVICE)) (SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS) (VAR . BITMAP))) (COMS (* "Functions that find types") (FNS TestForType TestForQuotedType TestForVar TestForBitmap TestForProp TestForResource TestForUglyVars TestForGenericDefinition TestForConstants SFI.WHOLE.EXPRESSION SFI.LOOKUP.NAME)) (DECLARE: EVAL@COMPILE DONTCOPY (MACROS .ERRORSTREAM.) (RECORDS SFITYPE) (FILES (IMPORT) FILEIO) (GLOBALVARS DEFAULTFONT NOTLISTEDFILES) (GLOBALVARS FILERDTBL RELATIVEINDEXFLG) (GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK \SFI.PROCESS SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES SINGLEFILEINDEX.PROPERTIES SINGLEFILEINDEX.FILTERS FILELINELENGTH MACROPROPS PRINTERDEVICEFILENAME) DONTEVAL@LOAD (SPECVARS . T)) (COMS (FNS SFI.LISTFILES1) (DECLARE: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE LISTFILES1) (QUOTE OLDLISTFILES1)) (/MOVD (QUOTE SFI.LISTFILES1) (QUOTE LISTFILES1))) (INITVARS (LINESPERPAGE 65]) (* * "Created by Christopher Tong and JonL White, February 1984. Heavily revised by Bill van Melle, March 1986." ) (* SINGLEFILEINDEX) (DEFINEQ (SINGLEFILEINDEX [LAMBDA (INF OUTF mergedIndexFlg PRINTOPTIONS) (* bvm: "28-Mar-86 17:31") (LET ((FULL (FINDFILE INF T))) (COND ((NOT FULL) (* When called by LISTFILES INF will already be a full file name) (printout (.ERRORSTREAM.) T INF " not found.")) (SINGLEFILEINDEX.DONTSPAWN (SINGLEFILEINDEX2 FULL OUTF mergedIndexFlg PRINTOPTIONS)) (T (\SFI.Q1UP (FUNCTION SINGLEFILEINDEX2) FULL OUTF mergedIndexFlg PRINTOPTIONS) (* Used to return NIL so that LISTFILES won't try  removing from NOTLISTEDFILES) FULL]) (\SFI.Q1UP [LAMBDA (FUN FULL OUTF mergedIndexFlg PRINTOPTIONS) (* bvm: "15-Mar-86 17:11") (* * Add a command to list file FULL to OUTF applying FUN) (WITH.MONITOR \SFI.PROCESSLOCK (* Lock protects \SFI.PROCESS.COMMANDS and  \SFI.PROCESS) [COND ((AND \SFI.PROCESS (NOT (FIND.PROCESS \SFI.PROCESS))) (* Process died, flush handle and any old listing  requests) (SETQ \SFI.PROCESS (SETQ \SFI.PROCESS.COMMANDS NIL] (SETQ \SFI.PROCESS.COMMANDS (NCONC1 \SFI.PROCESS.COMMANDS (LIST FUN FULL OUTF mergedIndexFlg PRINTOPTIONS))) (COND ((NULL \SFI.PROCESS) (SETQ \SFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \FILELISTING)) (QUOTE BEFOREEXIT) (QUOTE DON'T]) (\FILELISTING [LAMBDA NIL (* bvm: "15-Mar-86 16:58") (* * Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them) (WITH.MONITOR \SFI.PROCESSLOCK (* Lock protects \SFI.PROCESS.COMMANDS and  \SFI.PROCESS) (while \SFI.PROCESS.COMMANDS bind FORM do (SETQ FORM (pop \SFI.PROCESS.COMMANDS)) (RELEASE.MONITORLOCK \SFI.PROCESSLOCK) (* Release lock while listing so that others can add  to my queue) (APPLY (CAR FORM) (CDR FORM)) (OBTAIN.MONITORLOCK \SFI.PROCESSLOCK) finally (* Nothing left to do, so exit) (SETQ \SFI.PROCESS NIL]) (SINGLEFILEINDEX2 [LAMBDA (FULL OUTF mergedIndexFlg PRINTOPTIONS) (* bvm: "28-Mar-86 17:44") (* * Process a single file FULL to OUTF with options. SINGLEFILEINDEX should have already computed the fullname of  the input file) (COND ((COND ((SINGLEFILEINDEX1 FULL OUTF mergedIndexFlg PRINTOPTIONS) (AND (NULL OUTF) (printout (.ERRORSTREAM.) T "indexed version of " FULL " => " PRINTERDEVICEFILENAME)) T) (OUTF (printout (.ERRORSTREAM.) T FULL " is not LISPSOURCEFILEP -- COPYFILE being called")) (T (OLDLISTFILES1 FULL PRINTOPTIONS))) (* Do this here since there is little coordination  between the various multiple processes which are  listing files) (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FULL) NOTLISTEDFILES)) NIL]) (SINGLEFILEINDEX1 [LAMBDA (FULL OUTF RETINDEXFLG PRINTOPTIONS) (* bvm: "31-Mar-86 15:53") (* Makes an indexed file (default is the line printer). The index file will have a number of indices, one for each  type in INDEXEDTYPESLIST. Each type index will list all the items of that type NIL in alphabetical order and the  page number of where that item's definition is in the file. - NOTE1: The indices will be printed last. - NOTE2: The index file is not "loadable" into LISP.) (DECLARE (SPECVARS FULL) (USEDFREE LINESPERPAGE)) (RESETLST (PROG ((LINESPERPAGE LINESPERPAGE) [typesLST (OR (NULL RELATIVEINDEXFLG) (EQ RELATIVEINDEXFLG (QUOTE BOTH] (FNUM 0) (SOURCESTREAM) (PAGECOUNT) (LINECOUNT 1) (ItemPages) (INDICES) lastPage MAP FULLEOLC COMS currentItem nextFnGroup nextFnStart FNSMAPSL TEM) (DECLARE (SPECVARS MAP LINECOUNT PAGECOUNT LINESPERPAGE SOURCESTREAM ItemPages typesLST FNUM currentItem linePos newPos INDICES)) (* * Specials are as follows - SOURCESTREAM -- stream on the input file being formatted - currentItem -- function, etc currently being printed - FNUM -- ordinal number of function currently being printed, when RELATIVEINDEXFLG - PAGECOUNT -- number of current page - LINECOUNT -- number of current line on page - ItemPages -- list of (name type page#) constituting the actual index) [RESETSAVE (SETQ SOURCESTREAM (OPENSTREAM FULL (QUOTE INPUT) (QUOTE OLD))) (QUOTE (PROGN (CLOSEF? OLDVALUE] (SETQ FULL (FULLNAME SOURCESTREAM)) (COND ([EQ FULL (CAR (SETQ TEM (LISTP (GETP (ROOTFILENAME FULL) (QUOTE FILEMAP] (* It appears as though the file has already been  loaded in some way so that the MAP is already loaded) (SETQ MAP (CADR TEM))) ((NULL USEMAPFLG) (RESETSAVE NIL (QUOTE (SETQ USEMAPFLG))) (* Really should bind USEMAPFLG to T but this works if the system still thinks it's a globalvar) (SETQ USEMAPFLG T))) (COND ([OR (AND (NOT (RANDACCESSP SOURCESTREAM)) (OR typesLST (NULL MAP))) (AND (NULL MAP) (NULL (SETQ MAP (GETFILEMAP FULL))) (NOT (LISPSOURCEFILEP FULL] (* We just let the "old" listfiles do it when the file isn't RANDACCESSP or when it's probably some kind of  binary file) (RETURN))) (OR OUTF (SETQ OUTF PRINTERDEVICEFILENAME)) [COND [(OPENP OUTF (QUOTE OUTPUT)) (RESETSAVE (OUTPUT (SETQ OUTF (GETSTREAM OUTF (QUOTE OUTPUT] (T (RESETSAVE [OUTPUT (SETQ OUTF (OPENSTREAM OUTF (QUOTE OUTPUT) (QUOTE NEW] (QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE] [STREAMPROP OUTF (QUOTE PRINTOPTIONS) (APPEND PRINTOPTIONS (LIST (QUOTE DOCUMENT.NAME) FULL) (STREAMPROP OUTF (QUOTE PRINTOPTIONS] (* Make sure printer knows original name of file) (RESETSAVE (RADIX 10)) (SETQ LINESPERPAGE (OR (GETFILEINFO OUTF (QUOTE PAGEHEIGHT)) LINESPERPAGE)) (* Determine printing parameters.) (RESETSAVE (LINELENGTH 1000 OUTF)) (COND (RELATIVEINDEXFLG (* All index info up front, derived from file map, no  absolute page numbers) (PrintFileTitle FULL (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE))) (PrintRelativeFunctionIndex MAP))) [COND (typesLST (SETQ typesLST (for ENTRY in SINGLEFILEINDEX.TYPES collect (COND ((EQ (CAR (LISTP (fetch (SFITYPE PATTERNS) of ENTRY))) (QUOTE eval)) (create SFITYPE PATTERNS _(EVAL (CADR (fetch (SFITYPE PATTERNS) of ENTRY))) reusing ENTRY)) (T ENTRY] (PROGN (SETQ FNSMAPSL (CDR MAP)) (SETQ FULLEOLC (fetch EOLCONVENTION of SOURCESTREAM)) (SETQ PAGECOUNT 1) (SETQ nextFnGroup (CDDR (CAR FNSMAPSL))) (SETQ nextFnStart (CADAR nextFnGroup))) (* * Locate and print definitions for each item.) (bind linePos newPos (currentPos _ 0) [EOL _(SELECTC FULLEOLC [CR.EOLC (CONCATCODES (CHARCODE (CR] [LF.EOLC (CONCATCODES (CHARCODE (LF] (CONCATCODES (CHARCODE (CR LF] while (SETQ newPos (FILEPOS EOL SOURCESTREAM currentPos)) do (* currentPos = how far we have copied; linePos = start of current line; newPos = start of next line) (SETFILEPTR SOURCESTREAM (SETQ linePos currentPos)) (COND ([COND [(EQ (PEEKCCODE SOURCESTREAM) (CHARCODE ^F)) (* Line might start with a fontchange sequence) (\SFI.FLUSHFONTCHANGE SOURCESTREAM) (* Advance linePos to after any font change chars) (AND nextFnStart (OR (IEQP linePos nextFnStart) (IEQP currentPos nextFnStart] (T (AND nextFnStart (IEQP linePos nextFnStart] (* Index and print function group.) (for function in nextFnGroup do (SETQ newPos (PrintFnDef function OUTF))) (* Should point us at the first of two closing parens) (pop FNSMAPSL) (SETQ nextFnGroup (CDDAR FNSMAPSL)) (SETQ nextFnStart (CADAR nextFnGroup))) (T (* Print and index (when appropriate) next line.) (SELECTC FULLEOLC (CRLF.EOLC (READC SOURCESTREAM) (add newPos 1)) 0) (COND (typesLST (\SFI.AnalyzeLine SOURCESTREAM typesLST))) (INDEXCOPYBYTES SOURCESTREAM OUTF currentPos newPos) (* Print the line.) (INDEXNEWLINE))) (SETQ currentPos (ADD1 newPos))) (SETQ lastPage PAGECOUNT) (* * Print file index or indices.) (COND ((OR (NULL RELATIVEINDEXFLG) (EQ RELATIVEINDEXFLG (QUOTE BOTH))) (SETQ INDICES (\SFI.SORTINDEX ItemPages)) [LET ((VARS (ASSOC (QUOTE VAR) INDICES))) (* Manually filter out the filecoms var) (RPLACD VARS (DREMOVE (ASSOC (FILECOMS FULL) (CDR VARS)) (CDR VARS] (\SFI.FILTER.INDEX INDICES) (INDEXNEWPAGE T) (COND ((AND (EVENP PAGECOUNT) SINGLEFILEINDEX.TWOSIDED) (* Ensure that the index will not be on the back-side  of a two-sided listing) (INDEXNEWPAGE T))) (PrintFileTitle FULL (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE)) ) (\SFI.PRINT.INDEX INDICES))) (RETURN (COND (RETINDEXFLG (CONS FULL INDICES)) (T FULL]) (\SFI.AnalyzeLine [LAMBDA (SOURCESTREAM TYPETRIPLES FLG) (* bvm: "30-Mar-86 15:07") (* * Retrieve line as string, beginning with first character that isn't a font change char,) (DECLARE (USEDFREE ItemPages)) (SELECTQ (GETSYNTAX (READCCODE SOURCESTREAM) FILERDTBL) [(LEFTPAREN LEFTBRACKET) (* Note that if the first character on the line isn't  a parens then this line can't be the start of anything interesting) (COND ((EQ (PEEKCCODE SOURCESTREAM) (CHARCODE ^F)) (* It is possible to have a fontchange sequence just after the open parens, though most forms reserve the font  change for the named object, coming up next) (\SFI.FLUSHFONTCHANGE SOURCESTREAM))) (LET ((FN (READ SOURCESTREAM FILERDTBL)) HERE PAT MOVED? ITEMNAME) (SETQ HERE (GETFILEPTR SOURCESTREAM)) (for ENTRY in TYPETRIPLES when (COND ((EQ (SETQ PAT (fetch (SFITYPE PATTERNS) of ENTRY)) T) (* Matches anything -- TESTFN must be doing all the  work) T) ((LISTP PAT) (MEMB FN PAT)) (T (EQ FN PAT))) do (* ENTRY thinks this line might be interesting) (COND (MOVED? (* Previous test may have moved the file pointer, so  bring it back) (SETFILEPTR SOURCESTREAM HERE) (SETQ MOVED? NIL))) [COND ([SETQ ITEMNAME (CAR (NLSETQ (APPLY* (OR (fetch (SFITYPE TESTFN) of ENTRY) (FUNCTION TestForType)) SOURCESTREAM FN ENTRY] [COND ((NLISTP ITEMNAME) (* Single object to be indexed as the type in ENTRY) (push ItemPages (LIST (LET ((TYPE (fetch (SFITYPE NAME) of ENTRY))) (OR (CAR (LISTP TYPE)) TYPE)) ITEMNAME PAGECOUNT))) (T (* Index as some other type) (for PAIR in (COND ((LITATOM (CAR ITEMNAME)) (* a single pair) (LIST ITEMNAME)) (T (* many) ITEMNAME)) do (for NAME in (CDR PAIR) do (push ItemPages (LIST (CAR PAIR) NAME PAGECOUNT] (COND ((NOT (fetch (SFITYPE AMBIGUOUS?) of ENTRY)) (RETURN] (SETQ MOVED? T] ((RIGHTPAREN RIGHTBRACKET) (* Well, some lines will be the closing of a DEFINEQ  or a DECLARE: or whatever) NIL) NIL]) (\SFI.FLUSHFONTCHANGE [LAMBDA (STREAM) (* bvm: "15-Mar-86 17:41") (while (EQ (PEEKCCODE STREAM) (CHARCODE ^F)) do (READCCODE STREAM) (READCCODE STREAM) (add linePos 2]) (PrintFnDef [LAMBDA (FNDEF OUTSTREAM) (DECLARE (USEDFREE ItemPages FNUM SOURCESTREAM PAGECOUNT LINESPERPAGE LINECOUNT) (SPECVARS currentItem)) (* bvm: "28-Mar-86 17:41") (* * Prints a FNDEF definition on the file OUTSTREAM - FNDEF is map entry of form (name start . end)) (PROG ((END (CDDR FNDEF)) (currentItem (CAR FNDEF))) (add FNUM 1) (INDEXNEWLINE) (COND (RELATIVEINDEXFLG (printout NIL .SP (IDIFFERENCE FILELINELENGTH (IPLUS 2 (NCHARS FNUM))) .FONT BOLDFONT "[" FNUM "]" .FONT DEFAULTFONT .RESET))) (INDEXNEWLINE) (COND ((NOT (ILEQ (IPLUS LINECOUNT 3) LINESPERPAGE)) (INDEXNEWPAGE))) (push ItemPages (LIST (QUOTE FUNCTION) currentItem PAGECOUNT)) (* Print out function.) (INDEXCOPYBYTES SOURCESTREAM OUTSTREAM (CADR FNDEF) END) (RETURN END]) (INDEXCOPYBYTES [LAMBDA (IN OUT START END) (DECLARE (USEDFREE LINECOUNT LINESPERPAGE)) (* bvm: "15-Mar-86 17:50") (* This is similar to COPYBYTES except that, INDEXNEWLINE is called whenever an EOL is read, and IndexNewPage is  called whenever a form feed is read) (SETFILEPTR IN START) [PROG ((INSTRM (GETSTREAM IN (QUOTE INPUT))) (OUTSTRM (GETSTREAM OUT (QUOTE OUTPUT))) EOLC NLFLG LOOKFORLF CH) (SETQ EOLC (fetch EOLCONVENTION of INSTRM)) (FRPTQ (IDIFFERENCE END START) (SELCHARQ (SETQ CH (BIN INSTRM)) [CR (SELECTC EOLC [CR.EOLC (SETQ LOOKFORLF NIL) (COND ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE LINESPERPAGE 5)) ) (* double cr near end of page) (INDEXNEWPAGE) (SETQ NLFLG NIL)) (T (INDEXNEWLINE) (SETQ NLFLG T] (CRLF.EOLC (* Flag says that EOLC is CRLF and we are looking for next char to be LF. Expanded out this way so that we can keep track of the character counts accurately) (SETQ LOOKFORLF T)) (PROGN (SETQ LOOKFORLF NIL) (\OUTCHAR OUTSTRM (CHARCODE CR] (LF [COND [(OR LOOKFORLF (EQ EOLC LF.EOLC)) (COND ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE LINESPERPAGE 5))) (* double cr near end of page) (INDEXNEWPAGE) (SETQ NLFLG NIL)) (T (INDEXNEWLINE) (SETQ NLFLG T] (T (\OUTCHAR OUTSTRM (CHARCODE LF)) (* If LF comes thru, it is just a vertical tab. Want to keep horizontal position the same, but update  line-counts) (COND ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE LINESPERPAGE 5))) (* double cr near end of page) (INDEXNEWPAGE) (SETQ NLFLG NIL)) (T (COND ((IGREATERP (add LINECOUNT 1) LINESPERPAGE) (INDEXNEWPAGE))) (SETQ NLFLG T] (SETQ LOOKFORLF NIL)) (FF (INDEXNEWPAGE) (SETQ NLFLG NIL) (SETQ LOOKFORLF NIL)) (PROGN (\BOUT OUTSTRM CH) (SETQ NLFLG NIL) (SETQ LOOKFORLF NIL] T]) (INDEXNEWLINE [LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04") (TERPRI) (COND ((IGREATERP (add LINECOUNT 1) LINESPERPAGE) (INDEXNEWPAGE DontPrintPageNbrFlg]) (INDEXNEWPAGE [LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04") (PRIN3 (FCHARACTER (CHARCODE FF))) (POSITION NIL 0) (SETQ LINECOUNT 0) (COND (PAGECOUNT (add PAGECOUNT 1))) (\SFI.LISTINGHEADER DontPrintPageNbrFlg]) (\SFI.SORTINDEX [LAMBDA (TRIPLES) (* bvm: "29-Mar-86 17:26") (* * Sort TRIPLES into a set of indices, one per type. Each element is of the form (type name page), while the  resulting indices are of the form (type . entries), with each entry looking like (name . pagenumbers)) (LET ([TYPENAMES (CONS (QUOTE FUNCTION) (for X in SINGLEFILEINDEX.TYPES collect (CAR X] RESULT INDEX OLDNAME) [for TRIP in TRIPLES do [COND ((NULL (SETQ INDEX (ASSOC (CAR TRIP) RESULT))) (push RESULT (SETQ INDEX (LIST (CAR TRIP] (COND [(SETQ OLDNAME (ASSOC (CADR TRIP) INDEX)) (* Duplicate entry, so add a page number) (RPLACD OLDNAME (SORT (UNION (CDDR TRIP) (CDR OLDNAME] (T (push (CDR INDEX) (CDR TRIP] (for PAIR in RESULT do (SORT (CDR PAIR) (FUNCTION UALPHORDERCAR))) (SORT RESULT (FUNCTION (LAMBDA (X Y) (* X is before Y if its car appears before Y's in  TYPENAMES) (FMEMB (CAR Y) (CDR (FMEMB (CAR X) TYPENAMES]) (UALPHORDERCAR [LAMBDA (A B) (* JonL " 7-Mar-84 19:52") (* does case independent sort on the CAR of two  elements.) (UALPHORDER (CAR A) (CAR B]) (\SFI.FILTER.INDEX [LAMBDA (INDICES) (* bvm: "30-Mar-86 14:11") (* * Remove redundancies from the prepared INDICES) (DECLARE (SPECVARS INDICES)) (* For SFI.LOOKUP.NAME) (for TYPEPAIR in INDICES bind FILTERS when [SETQ FILTERS (for FILTER in SINGLEFILEINDEX.FILTERS collect (CDR FILTER) when (EQ (CAR FILTER) (CAR TYPEPAIR] do (* Each filter is either a type name or a list whose  car is a function) (RPLACD TYPEPAIR (for PAIR in (CDR TYPEPAIR) collect PAIR unless (for F in FILTERS thereis (COND ((NLISTP F) (* Name exists as another type) (SFI.LOOKUP.NAME (CAR PAIR) F)) (T (APPLY* (CAR F) PAIR]) ) (DEFINEQ (PrintFileTitle [LAMBDA (FILENAME DATE) (* bvm: "15-Mar-86 17:17") (* * Print FILENAME title. Should not be called unless FILENAME is essentially "at the top of the page") (\SFI.CENTERPRINT (CONCAT FILENAME " " DATE) T) (\SFI.CENTERPRINT (CONCAT "-- Listed on " (DATE) " --")) (INDEXNEWLINE]) (\SFI.PRINT.INDEX [LAMBDA (INDICES) (* bvm: "30-Mar-86 15:52") (* * For each (type . entries) pair in INDICES print a pretty index for the items of the type) (for PAIR in INDICES when (CDR PAIR) do (PrintIndex (CDR PAIR) lastPage (CAR PAIR)) (INDEXNEWLINE T)) (\SFI.BreakLine]) (PrintIndex [LAMBDA (INDEXPAIRS MaxIndexNo TYPE) (* bvm: "30-Mar-86 15:34") (* * print index of items in IndexedList.) (DECLARE (USEDFREE LINESPERPAGE LINECOUNT)) (PROG ([INDEXNOWIDTH (COND ((ILESSP MaxIndexNo 10) 1) ((ILESSP MaxIndexNo 100) 2) (T (NCHARS MaxIndexNo] NCOLUMNS NROWS WIDTH LEFT SPACING NROWSREMAINING LastItem) (DECLARE (SPECVARS NCOLUMNS LEFT WIDTH SPACING NROWS)) (SETQ WIDTH (IPLUS (for PAIR in INDEXPAIRS bind largest (PLUS (NCHARS (CAR PAIR)) (COND ((CDDR PAIR) (* When multiple page nos, must count the extra pages, plus an additional char each for the separating comma) (ITIMES (LENGTH (CDDR PAIR)) (IPLUS 1 INDEXNOWIDTH))) (T 0))) finally (RETURN $$EXTREME)) INDEXNOWIDTH 1)) (* WIDTH is the widest any entry gets: name plus page  numbers) (\SFI.PrintIndexFactors INDEXPAIRS) (* Compute NCOLUMNS LEFT WIDTH SPACING NROWS) (SETQ NROWSREMAINING NROWS) (AND TYPE (\SFI.BreakLine)) (* When TYPE is non-null, call is from  PrintOneTypeIndex) (INDEXNEWLINE T) (COND (TYPE [COND ((AND (IGREATERP (IPLUS NROWS 3) (IDIFFERENCE LINESPERPAGE LINECOUNT)) (IGREATERP LINECOUNT (LRSH LINESPERPAGE 1))) (* * Don't start an indexing on the bottom half of a page which is going to cross a page boundary before the  "breaker") (INDEXNEWPAGE T) (AND TYPE (\SFI.BreakLine] (\SFI.CENTERPRINT (CONCAT TYPE " INDEX") T T) (INDEXNEWLINE T))) (while INDEXPAIRS do (SETQ NROWS (IMIN NROWSREMAINING (IDIFFERENCE LINESPERPAGE LINECOUNT))) (for ROW from 1 to NROWS bind NEXTINDEX do (SETQ NEXTINDEX ROW) (for COLUMN from 1 to NCOLUMNS do [COND ((SETQ LastItem (FNTH INDEXPAIRS NEXTINDEX)) (LET* ((ITEM (CAR LastItem)) (LABEL (CAR ITEM)) (PAGENO (CDR ITEM))) [SETQ PAGENO (COND [(LISTP PAGENO) (* More than one occurrence) (CONCATLIST (CDR (for P in PAGENO join (LIST "," P] (T (MKSTRING PAGENO] (printout NIL .FONT DEFAULTFONT LABEL ,) (PRINTDOTS (IDIFFERENCE (IDIFFERENCE WIDTH (ADD1 (NCHARS LABEL))) (NCHARS PAGENO))) (PRIN1 PAGENO) (COND ((NEQ COLUMN NCOLUMNS) (SPACES SPACING] (add NEXTINDEX NROWS)) (INDEXNEWLINE T)) (COND ((SETQ INDEXPAIRS (CDR LastItem)) (INDEXNEWPAGE T) (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) NCOLUMNS]) (\SFI.PrintIndexFactors [LAMBDA (IndexedList) (* bvm: "30-Mar-86 15:00") (DECLARE (USEDFREE NCOLUMNS LEFT WIDTH SPACING NROWS)) (LET ((LEN (LENGTH IndexedList))) [SETQ NCOLUMNS (IMAX 1 (IMIN LEN (IQUOTIENT FILELINELENGTH (IPLUS WIDTH 2] (* Number of columns that fit if you allow 2 spaces  between columns) (SETQ NROWS (IQUOTIENT (IPLUS LEN (SUB1 NCOLUMNS)) NCOLUMNS)) (SETQ NCOLUMNS (IQUOTIENT (IPLUS LEN (SUB1 NROWS)) NROWS)) (* This might reduce the number of columns if all the  items, printed in NROWS rows, take fewer columns than  originally allocated) (SETQ LEFT (IDIFFERENCE FILELINELENGTH (ITIMES (IPLUS WIDTH 2) NCOLUMNS))) (* LEFT is number of spaces remaining after allocating the columns) (COND ((EQ NCOLUMNS 1) (* Only one column, so either make it half the page  width or the full width) [SETQ WIDTH (COND ((GREATERP WIDTH (IQUOTIENT FILELINELENGTH 2)) FILELINELENGTH) (T (IQUOTIENT FILELINELENGTH 2] (SETQ SPACING 0)) (T (SETQ WIDTH (IMIN (IPLUS WIDTH (IQUOTIENT LEFT 2)) (IDIFFERENCE (IQUOTIENT FILELINELENGTH NCOLUMNS) 2))) (* Spaces LEFT gets divided between the dots an the  between-column spaces.) (SETQ SPACING (COND ((EQ NCOLUMNS 1) 0) (T (IQUOTIENT (IDIFFERENCE FILELINELENGTH (ITIMES WIDTH NCOLUMNS)) (SUB1 NCOLUMNS]) (PrintRelativeFunctionIndex [LAMBDA (MAP) (* bvm: "31-Mar-86 15:59") (* * Create and print an index for the functions on the file.) (PROG ((MaxIndexNo 0) IndexedList currentItem) [SETQ IndexedList (for DFQ in MAP join (for function in (CDDR DFQ) collect (LIST (CAR function) (add MaxIndexNo 1] (* Printout function index.) (COND ((NOT IndexedList) (INDEXNEWLINE T) (INDEXNEWLINE T) (printout NIL .FONT BOLDFONT "No Functions." .FONT DEFAULTFONT)) (T (PrintIndex (SORT IndexedList (FUNCTION UALPHORDERCAR)) MaxIndexNo))) (INDEXNEWPAGE T) (RETURN MAP]) (\SFI.CENTERPRINT [LAMBDA (STR BOLDFLG DontPrintPageNbrFlg) (* //Z\\ "15-Apr-88 09:49") (* JonL "13-Mar-84 22:07") (* Be sure to only TAB with a positive index) (TAB (IQUOTIENT (if (IGREATERP FILELINELENGTH (NCHARS STR)) then (IDIFFERENCE FILELINELENGTH (NCHARS STR)) else 0) 2)) (COND (BOLDFLG (printout NIL .FONT BOLDFONT STR .FONT DEFAULTFONT)) (T (printout NIL STR))) (INDEXNEWLINE DontPrintPageNbrFlg]) (PRINTDOTS [LAMBDA (N FILE) (* bvm: "15-Mar-86 16:28") (LET [(STRM (GETSTREAM FILE (QUOTE OUTPUT] (FRPTQ N (\OUTCHAR STRM (CHARCODE %.]) (\SFI.LISTINGHEADER [LAMBDA (dontPrintPageNumberFlg) (* cht: " 5-JAN-84 15:15") (COND (FULL (PRIN1 FULL))) (COND ((AND currentItem FNUM RELATIVEINDEXFLG) (printout NIL " (" .P2 currentItem "[" FNUM "] cont.)")) (currentItem (printout NIL " (" .P2 currentItem " cont.)"))) (TAB (IDIFFERENCE FILELINELENGTH 9) T) (COND ((AND PAGECOUNT (NOT dontPrintPageNumberFlg)) (PRIN1 "Page ") (PRINTNUM (QUOTE (FIX 4)) PAGECOUNT))) (INDEXNEWLINE) (INDEXNEWLINE]) (\SFI.BreakLine [LAMBDA NIL (* bvm: "15-Mar-86 16:28") (INDEXNEWLINE T) [LET [(STRM (GETSTREAM NIL (QUOTE OUTPUT] (FRPTQ FILELINELENGTH (\OUTCHAR STRM (CHARCODE ~] (INDEXNEWLINE T]) ) (RPAQ? PRINTERDEVICEFILENAME (QUOTE {LPT})) (RPAQ? RELATIVEINDEXFLG ) (RPAQ? SINGLEFILEINDEX.TWOSIDED ) (RPAQ? SINGLEFILEINDEX.DONTSPAWN ) (RPAQ? \SFI.PROCESS.COMMANDS ) (RPAQ? \SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX")) (RPAQ? \SFI.PROCESS ) (RPAQ? ERRORMESSAGESTREAM T) (ADDTOVAR SINGLEFILEINDEX.TYPES (MACRO DEFMACRO) (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR) TestForVar T) (VAR READVARS TestForUglyVars) (BITMAP RPAQ TestForBitmap) (CONSTANTS CONSTANTS TestForConstants) (RECORD (eval CLISPRECORDTYPES)) (PROPERTY PUTPROPS TestForProp) (COURIERPROGRAM COURIERPROGRAM) (TEMPLATE SETTEMPLATE TestForQuotedType) (I.S.OPR I.S.OPR TestForQuotedType) (RESOURCES PUTDEF TestForResource) (ADVICE READVISE)) (ADDTOVAR SINGLEFILEINDEX.PROPERTIES (COPYRIGHT) (READVICE ADVICE)) (ADDTOVAR SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS) (VAR . BITMAP)) (* "Functions that find types") (DEFINEQ (TestForType [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 13:20") (* * Default testfn for types that are dumped in a form whose second element is the object's name) (LET ((NAME (READ STREAM FILERDTBL))) (AND NAME (LITATOM NAME) NAME]) (TestForQuotedType [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 13:29") (* * Like TestForType, but tests for something where the second element of the form is the quoted name.) (LET ((NAME (READ STREAM FILERDTBL))) (AND (EQ (CAR (LISTP NAME)) (QUOTE QUOTE)) (CADR NAME]) (TestForVar [LAMBDA (STREAM FN TRIPLE) (* bvm: "29-Mar-86 17:02") (* * Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR -- read the variable name following  it. Filters after the fact will remove duplications with other variable types) (LET (NAME) (COND ([AND (SETQ NAME (READ STREAM FILERDTBL)) (LITATOM NAME) (NEQ NAME T) (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA] (* Ignore compiler-internal vars) NAME]) (TestForBitmap [LAMBDA (STREAM FN TRIPLE) (* bvm: "28-Mar-86 17:06") (* * Called on (RPAQ --) in case the expression is (RPAQ var (READBITMAP))) (LET ((NAME (READ STREAM FILERDTBL)) CHAR) (COND ([AND NAME (LITATOM NAME) (EQ (SETQ CHAR (SKIPSEPRCODES STREAM FILERDTBL)) (CHARCODE "(")) (PROGN (READCCODE STREAM) (* After the VARS name is the form  (READBITMAP ...)) (EQ (RATOM STREAM FILERDTBL) (QUOTE READBITMAP] NAME]) (TestForProp [LAMBDA (STREAM FN TRIPLE) (* bvm: "31-Mar-86 12:13") (* * Called when given a PUTPROPS expression. Determine what type it is by looking at the property name. If no more specific type known, then index it as a PROPERTY) (LET ((NAME (READ STREAM FILERDTBL)) (PROP (READ STREAM FILERDTBL))) (* See if PROP means something more specific than  "property") (COND ((MEMB PROP MACROPROPS) (* Do macros in line so that MACRONAMES can be  dynamically changed.) (LIST (QUOTE MACRO) NAME)) (T (for PAIR in SINGLEFILEINDEX.PROPERTIES when (EQ (CAR PAIR) PROP) do (* Index it under this other type) (RETURN (AND (CADR PAIR) (LIST (CADR PAIR) NAME))) finally (* Nothing better, so index it as having a property) (RETURN NAME]) (TestForResource [LAMBDA (STREAM FN TRIPLE) (* bvm: "28-Mar-86 17:08") (TestForGenericDefinition STREAM FN (QUOTE ((RESOURCES GLOBALRESOURCES]) (TestForUglyVars [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 15:42") (* * Uglyvars are dumped as (READVARS var1 var2 ...)) (CONS (QUOTE VAR) (CDR (SFI.WHOLE.EXPRESSION STREAM]) (TestForGenericDefinition [LAMBDA (STREAM FN TRIPLE) (* bvm: "31-Mar-86 12:02") (* * Tests to see if expression is of the form (PUTDEF (QUOTE name) (QUOTE type) (QUOTE value)) where type is one  specified in TRIPLE) (LET ((DESIREDTYPE (CAR TRIPLE)) NAME TYPE) (COND ([AND (PROGN (* After the PUTDEF should find  (QUOTE name)) (EQ [CAR (LISTP (SETQ NAME (READ STREAM FILERDTBL] (QUOTE QUOTE))) (PROGN (* then (QUOTE DESIREDTYPE)) (EQ [CAR (LISTP (SETQ TYPE (READ STREAM FILERDTBL] (QUOTE QUOTE))) (OR (EQ [SETQ TYPE (CAR (LISTP (CDR TYPE] DESIREDTYPE) (AND (LISTP DESIREDTYPE) (MEMB TYPE DESIREDTYPE] (CADR NAME]) (TestForConstants [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 14:17") (* * Called when expression is (CONSTANTS --) -- return all elements (or CAR of element when it's a pair) as type  CONSTANTS) (CONS (QUOTE CONSTANTS) (for X in (CDR (SFI.WHOLE.EXPRESSION STREAM)) collect (COND ((LISTP X) (CAR X)) (T X]) (SFI.WHOLE.EXPRESSION [LAMBDA (STREAM) (* bvm: "30-Mar-86 13:34") (DECLARE (USEDFREE linePos)) (* * Called by testfns that want to see the whole expression) (SETFILEPTR STREAM linePos) (READ STREAM FILERDTBL]) (SFI.LOOKUP.NAME [LAMBDA (NAME TYPE) (* bvm: "30-Mar-86 13:44") (ASSOC NAME (CDR (ASSOC TYPE INDICES]) ) (DECLARE: EVAL@COMPILE DONTCOPY (DECLARE: EVAL@COMPILE (PUTPROPS .ERRORSTREAM. MACRO (NIL (SELECTQ ERRORMESSAGESTREAM (T PROMPTWINDOW) ERRORMESSAGESTREAM))) ) [DECLARE: EVAL@COMPILE (RECORD SFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?)) ] (FILESLOAD (IMPORT) FILEIO) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTFONT NOTLISTEDFILES) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FILERDTBL RELATIVEINDEXFLG) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK \SFI.PROCESS SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES SINGLEFILEINDEX.PROPERTIES SINGLEFILEINDEX.FILTERS FILELINELENGTH MACROPROPS PRINTERDEVICEFILENAME) ) DONTEVAL@LOAD (DECLARE: DOEVAL@COMPILE DONTCOPY (SPECVARS . T) ) ) (DEFINEQ (SFI.LISTFILES1 [LAMBDA (FILE PRINTOPTIONS) (* rmk: "26-Feb-85 10:36") (SINGLEFILEINDEX FILE NIL NIL PRINTOPTIONS]) ) (DECLARE: DOCOPY DONTEVAL@LOAD (MOVD? (QUOTE LISTFILES1) (QUOTE OLDLISTFILES1)) (/MOVD (QUOTE SFI.LISTFILES1) (QUOTE LISTFILES1)) (RPAQ? LINESPERPAGE 65) ) (PUTPROPS SINGLEFILEINDEX COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988)) (DECLARE: DONTCOPY (FILEMAP (NIL (3020 25431 (SINGLEFILEINDEX 3030 . 3773) (\SFI.Q1UP 3775 . 4729) (\FILELISTING 4731 . 5618) (SINGLEFILEINDEX2 5620 . 6523) (SINGLEFILEINDEX1 6525 . 14860) (\SFI.AnalyzeLine 14862 . 17966) (\SFI.FLUSHFONTCHANGE 17968 . 18246) (PrintFnDef 18248 . 19344) (INDEXCOPYBYTES 19346 . 22103) ( INDEXNEWLINE 22105 . 22350) (INDEXNEWPAGE 22352 . 22669) (\SFI.SORTINDEX 22671 . 24007) (UALPHORDERCAR 24009 . 24309) (\SFI.FILTER.INDEX 24311 . 25429)) (25432 34128 (PrintFileTitle 25442 . 25842) ( \SFI.PRINT.INDEX 25844 . 26259) (PrintIndex 26261 . 29594) (\SFI.PrintIndexFactors 29596 . 31498) ( PrintRelativeFunctionIndex 31500 . 32356) (\SFI.CENTERPRINT 32358 . 33005) (PRINTDOTS 33007 . 33228) ( \SFI.LISTINGHEADER 33230 . 33837) (\SFI.BreakLine 33839 . 34126)) (35163 40656 (TestForType 35173 . 35494) (TestForQuotedType 35496 . 35877) (TestForVar 35879 . 36548) (TestForBitmap 36550 . 37165) ( TestForProp 37167 . 38291) (TestForResource 38293 . 38490) (TestForUglyVars 38492 . 38754) ( TestForGenericDefinition 38756 . 39712) (TestForConstants 39714 . 40177) (SFI.WHOLE.EXPRESSION 40179 . 40485) (SFI.LOOKUP.NAME 40487 . 40654)) (41455 41631 (SFI.LISTFILES1 41465 . 41629))))) STOP \ No newline at end of file diff --git a/lispusers/SKETCHCOLOR b/lispusers/SKETCHCOLOR new file mode 100644 index 00000000..4af9d6bd --- /dev/null +++ b/lispusers/SKETCHCOLOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 9-Jan-87 16:47:16" {ERIS}LIBRARY>SKETCHCOLOR.;2 4779 changes to%: (VARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE GREENTEXTURE BLUETEXTURE SKETCHCOLORCOMS) previous date%: "29-Oct-85 14:44:30" {ERIS}LIBRARY>SKETCHCOLOR.;1) (* " Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHCOLORCOMS) (RPAQQ SKETCHCOLORCOMS ((FNS COLORTEXTURETEST LEVELTEXTURE PRIMARYTEXTURE) (VARS (SKETCHINCOLORFLG T)) (FILES COLOR STYLESHEET) (ADVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY))) (DEFINEQ (COLORTEXTURETEST [LAMBDA (W) (* rrb "22-Aug-85 10:16") (* puts up a test pattern of primary  colors.) (PROG ((LFT 90)) (CLEARW W) (for BLUELEVEL from 94 by 50 to 300 do (printout W "BLUE: " BLUELEVEL " " 'RED) (DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W) 50) W) (DSPXPOSITION 0 W) (for GREENLEVEL from 94 by 50 to 300 do (printout W "Green: " GREENLEVEL) [for REDLEVEL from 94 by 50 to 300 do (BITBLT NIL 0 0 W (DIFFERENCE REDLEVEL 20) (DSPYPOSITION NIL W) 45 45 'TEXTURE 'REPLACE (TEXTUREOFCOLOR (LIST REDLEVEL GREENLEVEL BLUELEVEL] (DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W) 50) W) (DSPXPOSITION 0 W]) (LEVELTEXTURE [LAMBDA (LEVEL) (* rrb "20-Aug-85 16:42") (* returns a |16x16| texture which is merged so that only light bits on both go  to light with a primary color pattern to get a level primary pattern.) (COND ((ILESSP LEVEL 100) BLACKSHADE16) ((ILESSP LEVEL 150) DARKGRAY16) ((ILESSP LEVEL 200) MEDIUMGRAY16) ((ILESSP LEVEL 245) LIGHTGRAY16) (T WHITESHADE16]) (PRIMARYTEXTURE [LAMBDA (PRIMARY LEVEL) (* rrb "20-Aug-85 16:42") (* returns the |16x16| texture for a  primary color level.) (PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY (RED REDTEXTURE) (BLUE BLUETEXTURE) (GREEN GREENTEXTURE) (\ILLEGAL.ARG PRIMARY] (BITBLT (LEVELTEXTURE LEVEL) 0 0 TEXTURE 0 0 16 16 'INPUT 'ERASE) (RETURN TEXTURE]) ) (RPAQQ SKETCHINCOLORFLG T) (FILESLOAD COLOR STYLESHEET) (PUTPROPS \FILLCIRCLE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP TEXTURE) (COND ((TEXTUREP (CAR TEXTURE)) (SETQ TEXTURE (CAR TEXTURE))) (T (SETQ TEXTURE (TEXTUREOFCOLOR (CADR TEXTURE]) (PUTPROPS \POLYSHADE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP FILL.SHADE) (COND ((TEXTUREP (CAR FILL.SHADE)) (SETQ FILL.SHADE (CAR FILL.SHADE ))) (T (SETQ FILL.SHADE (TEXTUREOFCOLOR (CADR FILL.SHADE]) (READVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY) (PUTPROPS SKETCHCOLOR COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (771 3368 (COLORTEXTURETEST 781 . 2128) (LEVELTEXTURE 2130 . 2662) (PRIMARYTEXTURE 2664 . 3366))))) STOP \ No newline at end of file diff --git a/lispusers/SKETCHTALK b/lispusers/SKETCHTALK new file mode 100644 index 00000000..8fc9f94c --- /dev/null +++ b/lispusers/SKETCHTALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Jul-88 15:32:46" |{MCS:MCS:STANFORD}SKETCHTALK.;26| 20834 previous date%: "13-Jun-88 16:34:08" |{MCS:MCS:STANFORD}SKETCHTALK.;25|) (* " Copyright (c) 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT SKETCHTALKCOMS) (RPAQQ SKETCHTALKCOMS ((* TALK Sketch Service) (LOCALVARS . T) (FNS TALK.SKETCH.DISPLAY TALK.SKETCH.LISTEN) (FNS TALK.SKETCH.FIND.ELEMENT TALK.SKETCH.FIND.SYMBOLS) (* Sketch Viewer Control Properties) (FNS TALK.SKETCH.WHENADDEDFN TALK.SKETCH.WHENCHANGEDFN TALK.SKETCH.WHENDELETEDFN TALK.SKETCH.WHENMOVEDFN TALK.SKETCH.PREMOVEFN) (FNS TALK.SKETCH.WHENGROUPEDFN TALK.SKETCH.WHENUNGROUPEDFN) (VARS TALK.TO.SKETCH.PROPS TALK.SKETCH.REDISPLAY.PROPS) (* TALK Sketch Actions) (FNS TALK.SKETCH.ADD.ELEMENT TALK.SKETCH.CHANGE.ELEMENT TALK.SKETCH.DELETE.ELEMENTS TALK.SKETCH.MOVE.ELEMENTS TALK.SKETCH.POSITION.ELEMENTS) (VARS TALK.SKETCH.ACTIONS) (* TALK Sketch Data) (VARS TALK.SKETCH.DELETE.ITEMS) (INITVARS TALK.SKETCH.TRACK) (GLOBALVARS TALK.SKETCH.ACTIONS TALK.TO.SKETCH.PROPS TALK.SKETCH.REDISPLAY.PROPS TALK.SKETCH.DELETE.ITEMS TALK.SKETCH.TRACK) (* etc) (FILES TALK SKETCH) (APPENDVARS (GAP.SERVICETYPES (7 Sketch TALK.NS.SERVER)) (TALK.SERVICETYPES (Sketch TALK.SKETCH.DISPLAY TALK.SKETCH.LISTEN)) ) (* Sketch Bug Fixes) (FNS TALK.SKETCH.NOP) (P (CHANGENAME '\SK.PUT.FONT 'SK.INSURE.TEXT 'TALK.SKETCH.NOP)) (ADVISE BITMAPELT.CHANGEFN SK.IMAGEOBJ.CHANGEFN (TEXTUREP :IN SKFILLINGP)) )) (* TALK Sketch Service) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (TALK.SKETCH.DISPLAY [LAMBDA (MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOL USER) (* ; "Edited 9-Jun-88 16:36 by cdl") (LET (MENUWINDOW) (SKETCH NIL MAINWINDOW) (SKETCH NIL WINDOW) (DETACHWINDOW (SETQ MENUWINDOW (WINDOWPROP WINDOW 'SKETCHFIXEDMENU NIL))) (CLOSEW MENUWINDOW) (DETACHWINDOW (SETQ MENUWINDOW (WINDOWPROP MAINWINDOW 'SKETCHFIXEDMENU NIL))) (CLOSEW MENUWINDOW) (WINDOWPROP MAINWINDOW 'SKETCHFIXEDMENU (ATTACHMENU (LET ((ITEMS (SKETCH.COMMANDMENU.ITEMS NIL T))) (for KEY in TALK.SKETCH.DELETE.ITEMS do (SETQ ITEMS (DREMOVE (SASSOC KEY ITEMS) ITEMS))) (SKETCH.COMMANDMENU ITEMS)) MAINWINDOW 'RIGHT 'TOP)) (WINDOWPROP MAINWINDOW 'SKETCHPOPUPMENU NIL) (WINDOWPROP WINDOW 'SKETCHPOPUPMENU NIL) (for PAIR on TALK.TO.SKETCH.PROPS do (PUTSKETCHPROP MAINWINDOW (CAR PAIR) (CADR PAIR))) (PUTSKETCHPROP MAINWINDOW 'TALK OUTPUTSTREAM) (* Still need to combine the two  prompt windows into one) (WINDOWPROP MAINWINDOW 'SCROLLFN NIL) (WINDOWPROP WINDOW 'SCROLLFN NIL) (PUTWINDOWPROP MAINWINDOW 'DONTQUERYCHANGES T) (PUTWINDOWPROP WINDOW 'DONTQUERYCHANGES T) (RPLACA (CDAR (INSURE.SKETCH MAINWINDOW)) (CONCAT "Talk with " USER)) (WINDOWDELPROP WINDOW 'SHRINKFN 'SK.SHRINK.ICONCREATE) (WINDOWDELPROP WINDOW 'SHRINKFN 'SK.RETURN.TTY) (with REGION (DSPCLIPPINGREGION NIL MAINWINDOW) (SKED.SET.SELECTION (CREATEPOSITION (QUOTIENT WIDTH 2) (QUOTIENT HEIGHT 2)) MAINWINDOW)) (TTY.PROCESS (WINDOWPROP MAINWINDOW 'PROCESS]) (TALK.SKETCH.LISTEN [LAMBDA (MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOLTYPE) (* ; "Edited 7-Jun-88 08:46 by cdl") (* DECLARATIONS%: (RECORD EXPR  (KEY . ARGUMENTS))  (RECORD OPERATION (KEY FUNCTION))) (PROG [OPERATION (EVENTFN (with TALK.PROTOCOLTYPE PROTOCOLTYPE TALK.EVENTFN)) (SKETCH (INSURE.SKETCH (MAINWINDOW WINDOW] (DECLARE (GLOBALVARS TALK.CLOSED.STRING)) (while (OPENWP WINDOW) do (APPLY* EVENTFN INPUTSTREAM OUTPUTSTREAM) (if (NOT (AND (OPENP INPUTSTREAM) (OPENP OUTPUTSTREAM))) then (RETURN)) [SELCHARQ (PEEKCCODE INPUTSTREAM) (^G (TALK.RINGBELLS WINDOW)) (with EXPR (HREAD INPUTSTREAM) (if (SETQ OPERATION (ASSOC KEY TALK.SKETCH.ACTIONS)) then (with OPERATION OPERATION (APPLY FUNCTION (CONS WINDOW ARGUMENTS))) else (PRINTOUT (GETPROMPTWINDOW MAINWINDOW) "Unknown Sketch Talk operation:" %, KEY] (BIN INPUTSTREAM)) (RPLACA (CDAR SKETCH) (CONCAT (CADAR SKETCH) TALK.CLOSED.STRING)) (PUTSKETCHPROP MAINWINDOW 'TALK NIL]) ) (DEFINEQ (TALK.SKETCH.FIND.ELEMENT [LAMBDA (SKETCH SYMBOLS) (* ; "Edited 18-Jun-87 09:21 by cdl") (DECLARE (SPECVARS SYMBOLS)) (SKETCH.LIST.OF.ELEMENTS SKETCH (FUNCTION (LAMBDA (ELEMENT) (EQMEMB (GETSKETCHELEMENTPROP ELEMENT 'TALK) SYMBOLS]) (TALK.SKETCH.FIND.SYMBOLS [LAMBDA (SKETCH ELEMENTS) (* ; "Edited 18-Jun-87 11:11 by cdl") (for ELEMENT in ELEMENTS collect (GETSKETCHELEMENTPROP ELEMENT 'TALK]) ) (* Sketch Viewer Control Properties) (DEFINEQ (TALK.SKETCH.WHENADDEDFN [LAMBDA (VIEWER ELEMENT) (* ; "Edited 23-Jun-87 07:48 by cdl") (LET [(STREAM (GETSKETCHPROP VIEWER 'TALK] (if (AND STREAM (OPENP STREAM)) then (PROG [(SCRATCHSTREAM (OPENSTREAM '{NODIRCORE} 'BOTH] (PUTSKETCHELEMENTPROP ELEMENT 'TALK (GENSYM 'TALK)) (HPRINT `(ADD ,ELEMENT) SCRATCHSTREAM) (SETFILEPTR SCRATCHSTREAM 0) (COPYBYTES SCRATCHSTREAM STREAM) (FORCEOUTPUT STREAM) (CLOSEF? SCRATCHSTREAM]) (TALK.SKETCH.WHENCHANGEDFN [LAMBDA (VIEWER ELEMENT PROPERTY NEWVALUE OLDVALUE) (* ; "Edited 10-Jun-88 09:17 by cdl") (PROG [(STREAM (GETSKETCHPROP VIEWER 'TALK] (if (AND STREAM (OPENP STREAM)) then (SELECTQ PROPERTY (HASBOX (TALK.SKETCH.WHENDELETEDFN VIEWER (LIST OLDVALUE)) (TALK.SKETCH.WHENADDEDFN VIEWER NEWVALUE) (RETURN)) (DATA (SELECTQ NEWVALUE ((NIL CHANGED) (SETQ NEWVALUE OLDVALUE)) NIL)) NIL) (LET [(SCRATCHSTREAM (OPENSTREAM '{NODIRCORE} 'BOTH] (HPRINT `(CHANGE ,(TALK.SKETCH.FIND.SYMBOLS VIEWER (CONS ELEMENT)) ,PROPERTY ,NEWVALUE) SCRATCHSTREAM) (SETFILEPTR SCRATCHSTREAM 0) (COPYBYTES SCRATCHSTREAM STREAM) (FORCEOUTPUT STREAM) (CLOSEF? SCRATCHSTREAM]) (TALK.SKETCH.WHENDELETEDFN [LAMBDA (VIEWER ELEMENTS) (* ; "Edited 23-Jun-87 07:48 by cdl") (PROG [(STREAM (GETSKETCHPROP VIEWER 'TALK] (if (AND STREAM (OPENP STREAM)) then (HPRINT `(DELETE ,(TALK.SKETCH.FIND.SYMBOLS VIEWER ELEMENTS)) STREAM) (FORCEOUTPUT STREAM]) (TALK.SKETCH.WHENMOVEDFN [LAMBDA (VIEWER ELEMENTS DELTA) (* ; "Edited 23-Jun-87 10:14 by cdl") (PROG [(STREAM (GETSKETCHPROP VIEWER 'TALK] (if (AND STREAM (OPENP STREAM)) then [SETQ ELEMENTS (if (EQ (CAR ELEMENTS) T) then [if (NULL TALK.SKETCH.TRACK) then (if (LISTP (CAADR ELEMENTS)) then [for ELEMENT in (CDR ELEMENTS) collect (CONS T (  TALK.SKETCH.FIND.SYMBOLS VIEWER (LIST ELEMENT] else (* Fix for Sketch UNDO/MOVE bug) (with POSITION DELTA (SETQ XCOORD (MINUS XCOORD) ) (SETQ YCOORD (MINUS YCOORD))) (LIST (CONS T (TALK.SKETCH.FIND.SYMBOLS VIEWER (CONS (CDR ELEMENTS] elseif (in (CAR ELEMENTS) always NUMBERP) then [LIST (CONS (CAR ELEMENTS) (TALK.SKETCH.FIND.SYMBOLS VIEWER (LIST (CDR ELEMENTS] else (for ELEMENT in ELEMENTS when (OR (NEQ (CAR ELEMENT) T) (NOT TALK.SKETCH.TRACK)) collect (CONS (CAR ELEMENT) (TALK.SKETCH.FIND.SYMBOLS VIEWER (CONS (CDR ELEMENT] (HPRINT `(MOVE ,ELEMENTS ,DELTA) STREAM) (FORCEOUTPUT STREAM]) (TALK.SKETCH.PREMOVEFN [LAMBDA (VIEWER ELEMENTS ALIGNHOW) (* ; "Edited 23-Jun-87 07:53 by cdl") (LET [(STREAM (GETSKETCHPROP VIEWER 'TALK] (if (AND TALK.SKETCH.TRACK (NULL ALIGNHOW) (EQ (CAR ELEMENTS) T) STREAM (OPENP STREAM)) then (LET [(SYMBOLS (TALK.SKETCH.FIND.SYMBOLS VIEWER (CDR ELEMENTS] (SKETCH.TRACK.ELEMENTS (CDR ELEMENTS) VIEWER [FUNCTION (LAMBDA (POSITION VIEWER STREAM) (HPRINT `(POSITION ,SYMBOLS ,POSITION) STREAM) (FORCEOUTPUT STREAM] NIL NIL STREAM]) ) (DEFINEQ (TALK.SKETCH.WHENGROUPEDFN [LAMBDA (VIEWER ELEMENTS) (* ; "Edited 18-Jun-87 11:02 by cdl") 'DON'T]) (TALK.SKETCH.WHENUNGROUPEDFN [LAMBDA (VIEWER ELEMENTS) (* ; "Edited 18-Jun-87 11:02 by cdl") 'DON'T]) ) (RPAQQ TALK.TO.SKETCH.PROPS (WHENADDEDFN TALK.SKETCH.WHENADDEDFN WHENDELETEDFN TALK.SKETCH.WHENDELETEDFN WHENMOVEDFN TALK.SKETCH.WHENMOVEDFN WHENCHANGEDFN TALK.SKETCH.WHENCHANGEDFN WHENGROUPEDFN TALK.SKETCH.WHENGROUPEDFN WHENUNGROUPEDFN TALK.SKETCH.WHENUNGROUPEDFN PREMOVEFN TALK.SKETCH.PREMOVEFN)) (RPAQQ TALK.SKETCH.REDISPLAY.PROPS ((TEXT FONT) (TEXTBOX FONT BRUSH) (CLOSEDWIRE DASHING))) (* TALK Sketch Actions) (DEFINEQ (TALK.SKETCH.ADD.ELEMENT [LAMBDA (SKETCH ELEMENT) (* ; "Edited 21-Jun-87 11:24 by cdl") (SKETCH.ADD.ELEMENT ELEMENT SKETCH]) (TALK.SKETCH.CHANGE.ELEMENT [LAMBDA (SKETCH ELEMENT PROPERTY VALUE) (* ; "Edited 10-Jun-88 09:35 by cdl") (* DECLARATIONS%: (RECORD ENTRY  (TYPE . PROPERTIES))) (bind ENTRY for ELEMENT in (TALK.SKETCH.FIND.ELEMENT SKETCH ELEMENT) do (PUTSKETCHELEMENTPROP ELEMENT PROPERTY VALUE SKETCH) (if (SETQ ENTRY (ASSOC (SKETCH.ELEMENT.TYPE ELEMENT) TALK.SKETCH.REDISPLAY.PROPS)) then (with ENTRY ENTRY (if (OR (NULL PROPERTIES) (MEMB PROPERTY PROPERTIES)) then (REDISPLAYW SKETCH]) (TALK.SKETCH.DELETE.ELEMENTS [LAMBDA (SKETCH ELEMENTS) (* ; "Edited 18-Jun-87 09:47 by cdl") (for ELEMENT inside (TALK.SKETCH.FIND.ELEMENT SKETCH ELEMENTS) do (SKETCH.DELETE.ELEMENT ELEMENT SKETCH]) (TALK.SKETCH.MOVE.ELEMENTS [LAMBDA (SKETCH ELEMENTS DELTA) (* ; "Edited 18-Jun-87 17:48 by cdl") (for PAIR in ELEMENTS do (SELECTQ (CAR PAIR) (T (SKETCH.MOVE.ELEMENTS (TALK.SKETCH.FIND.ELEMENT SKETCH (CDR PAIR)) DELTA SKETCH)) (bind POSITIONS POSITION CONTROLPT [ELEMENT _ (CAR (TALK.SKETCH.FIND.ELEMENT SKETCH (CDR PAIR] for NUMBER in (CAR PAIR) do (SELECTQ NUMBER ((1 2 3) (SETQ CONTROLPT (SELECTQ NUMBER (1 '1STCONTROLPT) (2 '2NDCONTROLPT) (3 '3RDCONTROLPT) (SHOULDNT))) (with POSITION (SETQ POSITION (COPY (GETSKETCHELEMENTPROP ELEMENT CONTROLPT))) (add XCOORD (fetch (POSITION XCOORD) of DELTA)) (add YCOORD (fetch (POSITION YCOORD) of DELTA))) (PUTSKETCHELEMENTPROP ELEMENT CONTROLPT POSITION SKETCH)) (if [SETQ POSITIONS (COPY (GETSKETCHELEMENTPROP ELEMENT 'DATA] then (with POSITION (CAR (NTH POSITIONS NUMBER)) (add XCOORD (fetch (POSITION XCOORD) of DELTA)) (add YCOORD (fetch (POSITION YCOORD) of DELTA))) (PUTSKETCHELEMENTPROP ELEMENT 'DATA POSITIONS SKETCH]) (TALK.SKETCH.POSITION.ELEMENTS [LAMBDA (SKETCH SYMBOLS POSITION) (* ; "Edited 19-Jun-87 09:17 by cdl") (LET ((ELEMENTS (TALK.SKETCH.FIND.ELEMENT SKETCH SYMBOLS))) (SKETCH.MOVE.ELEMENTS ELEMENTS (with POSITION (GETSKETCHELEMENTPROP (CAR ELEMENTS) '1STCONTROLPT) (create POSITION XCOORD _ (DIFFERENCE (fetch (POSITION XCOORD) of POSITION) XCOORD) YCOORD _ (DIFFERENCE (fetch (POSITION YCOORD) of POSITION) YCOORD))) SKETCH]) ) (RPAQQ TALK.SKETCH.ACTIONS ((ADD TALK.SKETCH.ADD.ELEMENT) (DELETE TALK.SKETCH.DELETE.ELEMENTS) (MOVE TALK.SKETCH.MOVE.ELEMENTS) (CHANGE TALK.SKETCH.CHANGE.ELEMENT) (POSITION TALK.SKETCH.POSITION.ELEMENTS))) (* TALK Sketch Data) (RPAQQ TALK.SKETCH.DELETE.ITEMS (Group UnGroup Put "Move view")) (RPAQ? TALK.SKETCH.TRACK NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.SKETCH.ACTIONS TALK.TO.SKETCH.PROPS TALK.SKETCH.REDISPLAY.PROPS TALK.SKETCH.DELETE.ITEMS TALK.SKETCH.TRACK) ) (* etc) (FILESLOAD TALK SKETCH) (APPENDTOVAR GAP.SERVICETYPES (7 Sketch TALK.NS.SERVER)) (APPENDTOVAR TALK.SERVICETYPES (Sketch TALK.SKETCH.DISPLAY TALK.SKETCH.LISTEN)) (* Sketch Bug Fixes) (DEFINEQ (TALK.SKETCH.NOP [LAMBDA (X) (* ; "Edited 19-Jun-87 07:50 by cdl") X]) ) (CHANGENAME '\SK.PUT.FONT 'SK.INSURE.TEXT 'TALK.SKETCH.NOP) [XCL:REINSTALL-ADVICE 'BITMAPELT.CHANGEFN :AFTER '((:LAST (RPLACA (CDDAR (CADAR !VALUE)) (CADDAR (CAAR !VALUE] [XCL:REINSTALL-ADVICE 'SK.IMAGEOBJ.CHANGEFN :AFTER '((:LAST (RPLACA (CDDAR (CADAR !VALUE)) (CADDAR (CAAR !VALUE] [XCL:REINSTALL-ADVICE '(TEXTUREP :IN SKFILLINGP) :BEFORE '((:LAST (IF (NULL OBJECT) THEN (RETURN T] (READVISE BITMAPELT.CHANGEFN SK.IMAGEOBJ.CHANGEFN (TEXTUREP :IN SKFILLINGP)) (PUTPROPS SKETCHTALK COPYRIGHT ("Stanford University" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2500 6848 (TALK.SKETCH.DISPLAY 2510 . 4998) (TALK.SKETCH.LISTEN 5000 . 6846)) (6849 7473 (TALK.SKETCH.FIND.ELEMENT 6859 . 7250) (TALK.SKETCH.FIND.SYMBOLS 7252 . 7471)) (7519 13184 ( TALK.SKETCH.WHENADDEDFN 7529 . 8234) (TALK.SKETCH.WHENCHANGEDFN 8236 . 9498) ( TALK.SKETCH.WHENDELETEDFN 9500 . 9896) (TALK.SKETCH.WHENMOVEDFN 9898 . 12275) (TALK.SKETCH.PREMOVEFN 12277 . 13182)) (13185 13493 (TALK.SKETCH.WHENGROUPEDFN 13195 . 13341) (TALK.SKETCH.WHENUNGROUPEDFN 13343 . 13491)) (14060 19099 (TALK.SKETCH.ADD.ELEMENT 14070 . 14242) (TALK.SKETCH.CHANGE.ELEMENT 14244 . 15104) (TALK.SKETCH.DELETE.ELEMENTS 15106 . 15374) (TALK.SKETCH.MOVE.ELEMENTS 15376 . 17890) ( TALK.SKETCH.POSITION.ELEMENTS 17892 . 19097)) (19962 20105 (TALK.SKETCH.NOP 19972 . 20103))))) STOP \ No newline at end of file diff --git a/lispusers/SNAPW-ICON b/lispusers/SNAPW-ICON new file mode 100644 index 00000000..a09e9a9c --- /dev/null +++ b/lispusers/SNAPW-ICON @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Dec-88 18:04:22" {ERINYES}MEDLEY>SNAPW-ICON.;1 2156 previous date%: " 8-Aug-88 14:37:38" {PHYLUM}LYRIC>SNAPW-ICON.;1) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SNAPW-ICONCOMS) (RPAQQ SNAPW-ICONCOMS ((BITMAPS SNAP.BITMAP SNAP.MASK) (FNS SNAP.SHRINKFN) (ADVISE SNAPW))) (RPAQQ SNAP.BITMAP #*(50 35)@@@@@OOL@@@@@@@@@@@@A@@B@@@@@@@@@@@@BGOI@OOL@@@@@AN@DOOLHH@D@@@@COOOHOOLGOOO@@@@D@@@@OOL@@@@H@@@H@@@@OOL@@@@D@@@H@@@@OOL@@@@D@@@KOOONGOIOOOOD@@@OOOOO@@COOOOL@@@L@@@GOOOH@@@L@@@OOOOOH@OOOOOL@@@OOOON@@COOOOL@@@OOOOLCNAOOOOL@@@OOOOHOOHOOOOL@@@OOOOAOOLGOOOL@@@OOONCOHNCOLOL@@@OOONGOLGCOHGL@@@OOOLGONCAN@AL@@@OOODOOOCIOOOL@@@OONDOOOKIOOOL@@@OONDOOOOIOOOL@@@OONDOOOOIOOOL@@@OOODOOOOIOOOL@@@OOOLGOOOAOOOL@@@OOONGOOOCOOOL@@@OOONCOONCOOOL@@@OOOOAOOLFGOOL@@@OOOOHOOHMOOOL@@@OOOOLCNANIICL@@@N@@@N@@COBCEL@@@OOOOOH@OLJHCL@@@KOOOOOOOOOOGD@@@D@@@@@@@@@@@H@@@COOOOOOOOOOO@@@@ ) (RPAQQ SNAP.MASK #*(50 35)@@@@@OOL@@@@@@@@@@@@AOON@@@@@@@@@@@@COOO@OOL@@@@@AN@GOOOHOOL@@@@COOOOOOOOOOO@@@@GOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOOL@@@GOOOOOOOOOOOH@@@COOOOOOOOOOO@@@@ ) (DEFINEQ (SNAP.SHRINKFN [LAMBDA (W) (* Randy.Gobbel "12-Oct-87 19:12") (DECLARE (GLOBALVARS SNAP.BITMAP SNAP.MASK)) (OR (WINDOWPROP W 'ICON) (WINDOWPROP W 'ICON (ICONW SNAP.BITMAP SNAP.MASK NIL T]) ) [XCL:REINSTALL-ADVICE 'SNAPW :AFTER '((:LAST (WINDOWPROP !VALUE 'SHRINKFN 'SNAP.SHRINKFN] (READVISE SNAPW) (PUTPROPS SNAPW-ICON COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1692 1965 (SNAP.SHRINKFN 1702 . 1963))))) STOP \ No newline at end of file diff --git a/lispusers/SNAPW-ICON.TEDIT b/lispusers/SNAPW-ICON.TEDIT new file mode 100644 index 00000000..dfb6128b Binary files /dev/null and b/lispusers/SNAPW-ICON.TEDIT differ diff --git a/lispusers/SOLID-MOVEW b/lispusers/SOLID-MOVEW new file mode 100644 index 00000000..bfeb805d --- /dev/null +++ b/lispusers/SOLID-MOVEW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "26-Jun-88 00:05:44" |{NEWTON:EUROPARC:RX}LISP>LYRIC>SOLID-MOVEW.;23| 11836 changes to%: (VARS SOLID-MOVEWCOMS) (FNS SOLID-MOVEW \SOLID-MOVEW-CLOSEW-WATCHER) previous date%: " 8-May-88 01:58:13" |{NEWTON:EUROPARC:RX}LISP>LYRIC>SOLID-MOVEW.;21| ) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SOLID-MOVEWCOMS) (RPAQQ SOLID-MOVEWCOMS ((INITVARS (*SOLID-MOVEW-FLAG* 15000) (*SOLID-MOVEW-SHADOW* T) (*SOLID-MOVEW-SHADOW-SHADE* 42405) (*SOLID-MOVEW-GRIDDING* NIL) (*SOLID-MOVEW-CASHING* T) (\SOLID-LAST-SAVMAP) (\SOLID-LAST-TMPMAP)) (FNS MAYBE-SOLID-MOVEW SOLID-MOVEW \SOLID-MOVEW-CLOSEW-WATCHER) (APPENDVARS (GAINSPACEFORMS ((OR \SOLID-LAST-SAVMAP \SOLID-LAST-TMPMAP) "discard SOLID-MOVEW cached bitmaps" (PROGN (SETQ \SOLID-LAST-SAVMAP) (SETQ \SOLID-LAST-TMPMAP))))) (P (MOVD? (FUNCTION MOVEW) (FUNCTION ORIGINAL-MOVEW)) (CL:UNLESS (AND (BOUNDP (QUOTE LDFLG)) (FMEMB LDFLG (QUOTE (PROP ALLPROP)))) (MOVD (FUNCTION MAYBE-SOLID-MOVEW) (FUNCTION MOVEW)))) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) SOLID-MOVEW) (GLOBALVARS *SOLID-MOVEW-FLAG* *SOLID-MOVEW-SHADOW* *SOLID-MOVEW-SHADOW-SHADE* *SOLID-MOVEW-GRIDDING* *SOLID-MOVEW-CASHING* \SOLID-LAST-SAVMAP \SOLID-LAST-TMPMAP))) (RPAQ? *SOLID-MOVEW-FLAG* 15000) (RPAQ? *SOLID-MOVEW-SHADOW* T) (RPAQ? *SOLID-MOVEW-SHADOW-SHADE* 42405) (RPAQ? *SOLID-MOVEW-GRIDDING* NIL) (RPAQ? *SOLID-MOVEW-CASHING* T) (RPAQ? \SOLID-LAST-SAVMAP) (RPAQ? \SOLID-LAST-TMPMAP) (DEFINEQ (MAYBE-SOLID-MOVEW (LAMBDA (WINDOW POSorX Y) (* ; "Edited 8-May-88 00:50 by Magic Squirrel") (with REGION (WINDOWREGION WINDOW) (if (COND ((EQ *SOLID-MOVEW-FLAG* (QUOTE ICON)) (* ; "Only move solidly if window is an icon.") (OR (WINDOWPROP WINDOW (QUOTE ICONFOR)) (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))) ((POSITIONP *SOLID-MOVEW-FLAG*) (* ; "Only move solidly if window contains less than specified number of bits.") (AND (ILEQ WIDTH (fetch XCOORD of *SOLID-MOVEW-FLAG*)) (ILEQ HEIGHT (fetch YCOORD of *SOLID-MOVEW-FLAG*)))) ((NUMBERP *SOLID-MOVEW-FLAG*) (* ; "Only move solidly if window is smaller than specified width x height.") (ILEQ (ITIMES WIDTH HEIGHT) *SOLID-MOVEW-FLAG*)) (T (* ; "Move solidly if *SOLID-MOVEW-FLAG* says so.") *SOLID-MOVEW-FLAG*)) then (SOLID-MOVEW WINDOW POSorX Y) else (ORIGINAL-MOVEW WINDOW POSorX Y)))) ) (SOLID-MOVEW (LAMBDA (WINDOW POSorX Y) (* ; "Edited 26-Jun-88 00:04 by Lennart") (DECLARE (GLOBALVARS LAMBDASPLST) (LOCALVARS . T)) (PROG (left bottom width height shadowWidth shadowHeight savMap tmpMap x y savX savY tmpX tmpY intX intY savWidth savHeight tmpWidth tmpHeight intWidth intHeight image mask shade windows screen moveFns oldCursor buttonWait result wxOff wyOff cxOff cyOff firstTime) (* ;; "Punt if position already is given") (if POSorX then (RETURN (ORIGINAL-MOVEW WINDOW POSorX Y))) (* ;; "Make sure this window is moveable") (SETQ moveFns (MKLIST (fetch (WINDOW MOVEFN) of WINDOW))) (if (FMEMB (CAR moveFns) LAMBDASPLST) then (SETQ moveFns (LIST moveFns))) (if (FMEMB (QUOTE DON'T) moveFns) then (PROMPTPRINT "Can't move this window.") (RETURN)) (* ;; "Optional shadowing") (SETQ shadowWidth (ABS (COND ((POSITIONP *SOLID-MOVEW-SHADOW*) (fetch (POSITION XCOORD) of *SOLID-MOVEW-SHADOW*)) ((NUMBERP *SOLID-MOVEW-SHADOW*) *SOLID-MOVEW-SHADOW*) (*SOLID-MOVEW-SHADOW* 3) (T 0)))) (SETQ shadowHeight (ABS (COND ((POSITIONP *SOLID-MOVEW-SHADOW*) (fetch (POSITION YCOORD) of *SOLID-MOVEW-SHADOW*)) ((NUMBERP *SOLID-MOVEW-SHADOW*) *SOLID-MOVEW-SHADOW*) (*SOLID-MOVEW-SHADOW* 3) (T 0)))) (* ;; "Set window dependent parameters.") (with REGION (WINDOWREGION WINDOW) (* ; "This will be the union of the window's region and all its attached windows.") (SETQ left LEFT) (SETQ bottom BOTTOM) (SETQ width WIDTH) (SETQ height HEIGHT)) (SETQ savX left) (SETQ savY (IDIFFERENCE bottom shadowHeight)) (SETQ savWidth (IPLUS width shadowWidth)) (SETQ savHeight (IPLUS height shadowHeight)) (SETQ tmpWidth (ITIMES savWidth 2)) (SETQ tmpHeight (ITIMES savHeight 2)) (* ;; "Create temporary data structures.") (if *SOLID-MOVEW-CASHING* then (LET ((lastSavWidth 0) (lastSavHeight 0) (lastTmpWidth 0) (lastTmpHeight 0)) (CL:WHEN (BITMAPP \SOLID-LAST-SAVMAP) (SETQ lastSavWidth (BITMAPWIDTH \SOLID-LAST-SAVMAP)) (SETQ lastSavHeight (BITMAPHEIGHT \SOLID-LAST-SAVMAP))) (CL:WHEN (BITMAPP \SOLID-LAST-TMPMAP) (SETQ lastTmpWidth (BITMAPWIDTH \SOLID-LAST-TMPMAP)) (SETQ lastTmpHeight (BITMAPHEIGHT \SOLID-LAST-TMPMAP))) (CL:UNLESS (AND (IGEQ lastSavWidth savWidth) (IGEQ lastSavHeight savHeight)) (SETQ \SOLID-LAST-SAVMAP (BITMAPCREATE (IMAX savWidth lastSavWidth) (IMAX savHeight lastSavHeight)))) (CL:UNLESS (AND (IGEQ lastTmpWidth tmpWidth) (IGEQ lastTmpHeight tmpHeight)) (SETQ \SOLID-LAST-TMPMAP (BITMAPCREATE (IMAX tmpWidth lastTmpWidth) (IMAX tmpHeight lastTmpHeight)))) (SETQ savMap \SOLID-LAST-SAVMAP) (SETQ tmpMap \SOLID-LAST-TMPMAP)) else (SETQ savMap (BITMAPCREATE savWidth height)) (SETQ tmpMap (BITMAPCREATE tmpWidth tmpHeight))) (SETQ windows (CONS WINDOW (ATTACHEDWINDOWS WINDOW (QUOTE MOVEW)))) (SETQ screen (fetch (WINDOW SCREEN SCDESTINATION) of WINDOW)) (with REGION (fetch (WINDOW REG) of WINDOW) (SETQ wxOff (IDIFFERENCE LEFT savX)) (SETQ wyOff (IDIFFERENCE BOTTOM savY))) (if (CDR windows) then (* ; "Tricky case, lots of windows -- form the union image & mask. (no caching here yet)") (SETQ image (BITMAPCREATE width height)) (SETQ mask (BITMAPCREATE width height)) (for w in windows do (with REGION (fetch (WINDOW REG) of w) (if (WINDOWPROP w (QUOTE ICONMASK)) then (BITBLT (WINDOWPROP w (QUOTE ICONIMAGE)) 0 0 image (IDIFFERENCE LEFT left) (IDIFFERENCE BOTTOM bottom)) (BITBLT (WINDOWPROP w (QUOTE ICONMASK)) 0 0 mask (IDIFFERENCE LEFT left) (IDIFFERENCE BOTTOM bottom)) else (BITBLT screen LEFT BOTTOM image (IDIFFERENCE LEFT left) (IDIFFERENCE BOTTOM bottom) WIDTH HEIGHT) (BLTSHADE BLACKSHADE mask (IDIFFERENCE LEFT left) (IDIFFERENCE BOTTOM bottom) WIDTH HEIGHT)))) else (* ; "Easy case, just one window.") (SETQ image (OR (WINDOWPROP WINDOW (QUOTE IMAGE)) (WINDOWPROP WINDOW (QUOTE ICONIMAGE)) (fetch (WINDOW SAVE) of WINDOW))) (SETQ mask (OR (WINDOWPROP WINDOW (QUOTE MASK)) (WINDOWPROP WINDOW (QUOTE ICONMASK)))) (SETQ shade (WINDOWPROP WINDOW (QUOTE SHADEIMAGE)))) (TOTOPW WINDOW) (BITBLT screen savX savY savMap 0 0 savWidth savHeight) (* ; "Save screen image around attached windows (concave corners' case).") (for w in windows when (OPENWP w) do (UNINTERRUPTABLY (\INTERNALTOTOPW w) (* ; "Make sure the window is softly on top...") (with REGION (fetch (WINDOW REG) of w) (BITBLT (fetch (WINDOW SAVE) of w) 0 0 savMap (IDIFFERENCE LEFT savX) (IDIFFERENCE BOTTOM savY)) (* ; "Save the screen image behind the window.") (BITBLT screen LEFT BOTTOM (fetch (WINDOW SAVE) of w) 0 0) (* ; "Put a copy of the window's image in the SAVE map so that closing it won't produce any flickering.")) (\CLOSEW1 w)) (* ; "Then softly close the target window to make it %"movable%".")) (CL:UNWIND-PROTECT (first (SETQ oldCursor (CURSOR (CONSTANT (CURSORCREATE (BITMAPCREATE 0 0))))) (SETQ cxOff (IDIFFERENCE LASTMOUSEX savX)) (SETQ cyOff (IDIFFERENCE LASTMOUSEY savY)) (\CURSORPOSITION savX savY) (GETMOUSESTATE) (SETQ buttonWait T) (SETQ firstTime T) eachtime (GETMOUSESTATE) (SETQ x LASTMOUSEX) (SETQ y LASTMOUSEY) while (if (LASTMOUSESTATE UP) then buttonWait else (SETQ buttonWait NIL) (LASTMOUSESTATE (NOT UP))) when (OR (NEQ savX x) (NEQ savY y) firstTime) do (SETQ firstTime NIL) (if (AND *SOLID-MOVEW-GRIDDING* (FMEMB (FUNCTION ICONW.MOVEFN) moveFns)) then (* ;; "Handle gridded icons here.") (with POSITION (ICONW.MOVEFN WINDOW (CREATEPOSITION x y)) (SETQ x XCOORD) (SETQ y YCOORD))) (COND ((OR (IGEQ (ABS (IDIFFERENCE x savX)) savWidth) (IGEQ (ABS (IDIFFERENCE y savY)) savHeight)) (* ;; "This jump is large enough not to have the window intersect with itself.") (BITBLT savMap 0 0 screen savX savY savWidth savHeight) (UNINTERRUPTABLY (BITBLT screen x y savMap 0 0 savWidth savHeight) (SETQ savX x) (SETQ savY y)) (BITBLT screen x y tmpMap 0 0 tmpWidth tmpHeight) (if mask then (AND *SOLID-MOVEW-SHADOW* (BITBLT mask 0 0 tmpMap shadowWidth 0 width height (QUOTE MERGE) (QUOTE PAINT) *SOLID-MOVEW-SHADOW-SHADE*)) (BITBLT mask 0 0 tmpMap 0 shadowHeight width height NIL (QUOTE ERASE)) (BITBLT image 0 0 tmpMap 0 shadowHeight width height NIL (QUOTE PAINT)) else (AND *SOLID-MOVEW-SHADOW* (BLTSHADE *SOLID-MOVEW-SHADOW-SHADE* tmpMap shadowWidth 0 width height (QUOTE PAINT))) (BITBLT image 0 0 tmpMap 0 shadowHeight width height)) (AND shade (BITBLT shade 0 0 tmpMap 0 shadowHeight width height NIL (QUOTE PAINT))) (BITBLT tmpMap 0 0 screen x y tmpWidth tmpHeight)) (T (* ;; "The new image intersects with the old.") (SETQ tmpX (IMIN x savX)) (SETQ tmpY (IMIN y savY)) (SETQ intX (IDIFFERENCE x tmpX)) (SETQ intY (IDIFFERENCE y tmpY)) (SETQ intWidth (IPLUS (ABS (IDIFFERENCE x savX)) savWidth)) (SETQ intHeight (IPLUS (ABS (IDIFFERENCE y savY)) savHeight)) (BITBLT screen tmpX tmpY tmpMap 0 0 intWidth intHeight) (BITBLT savMap 0 0 tmpMap (IDIFFERENCE savX tmpX) (IDIFFERENCE savY tmpY) savWidth savHeight) (UNINTERRUPTABLY (BITBLT tmpMap intX intY savMap 0 0 savWidth savHeight) (SETQ savX x) (SETQ savY y)) (if mask then (AND *SOLID-MOVEW-SHADOW* (BITBLT mask 0 0 tmpMap (IPLUS intX shadowWidth) intY width height (QUOTE MERGE) (QUOTE PAINT) *SOLID-MOVEW-SHADOW-SHADE*)) (BITBLT mask 0 0 tmpMap intX (IPLUS intY shadowHeight) width height NIL (QUOTE ERASE)) (BITBLT image 0 0 tmpMap intX (IPLUS intY shadowHeight) width height NIL (QUOTE PAINT)) else (AND *SOLID-MOVEW-SHADOW* (BLTSHADE *SOLID-MOVEW-SHADOW-SHADE* tmpMap (IPLUS intX shadowWidth) intY width height (QUOTE PAINT))) (BITBLT image 0 0 tmpMap intX (IPLUS intY shadowHeight) width height)) (AND shade (BITBLT shade 0 0 tmpMap intX (IPLUS intY shadowHeight) width height NIL (QUOTE PAINT))) (BITBLT tmpMap 0 0 screen tmpX tmpY intWidth intHeight)))) (* ;; "Finally cleanup before we exit, ie. restore cursor, put original bits back on the screen, open the windows again...") (\CURSORPOSITION (IPLUS savX cxOff) (IPLUS savY cyOff)) (CURSOR oldCursor) (* ;; "Blink, blink...") (BITBLT savMap 0 0 screen savX savY savWidth savHeight) (* ;; "Only move if the operation was completed, ie not if user aborted by hitting ^E etc") (CL:WHEN (LASTMOUSESTATE UP) (WINDOWADDPROP WINDOW (QUOTE CLOSEFN) (QUOTE \SOLID-MOVEW-CLOSEW-WATCHER)) (SETQ result (ORIGINAL-MOVEW WINDOW (IPLUS x wxOff) (IPLUS y wyOff))) (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (QUOTE \SOLID-MOVEW-CLOSEW-WATCHER))) (if (WINDOWPROP WINDOW (QUOTE SOLID-CLIENT-CLOSED)) then (* ;; "Some side effect of the (original) movew explicitly closed the window -- don't reopen it. ") (WINDOWPROP WINDOW (QUOTE SOLID-CLIENT-CLOSED) NIL) else (MAPC (REVERSE windows) (CL:FUNCTION \OPENW1))) (DOUSERFNS (WINDOWPROP WINDOW (QUOTE TOTOPFN)) WINDOW)) (RETURN result))) ) (\SOLID-MOVEW-CLOSEW-WATCHER (LAMBDA (WINDOW) (* ; "Edited 25-Jun-88 23:58 by Lennart") (WINDOWPROP WINDOW (QUOTE SOLID-CLIENT-CLOSED) T)) ) ) (APPENDTOVAR GAINSPACEFORMS ((OR \SOLID-LAST-SAVMAP \SOLID-LAST-TMPMAP) "discard SOLID-MOVEW cached bitmaps" (PROGN (SETQ \SOLID-LAST-SAVMAP) (SETQ \SOLID-LAST-TMPMAP))) ) (MOVD? (FUNCTION MOVEW) (FUNCTION ORIGINAL-MOVEW)) (CL:UNLESS (AND (BOUNDP (QUOTE LDFLG)) (FMEMB LDFLG (QUOTE (PROP ALLPROP)))) (MOVD (FUNCTION MAYBE-SOLID-MOVEW) (FUNCTION MOVEW))) (PUTPROPS SOLID-MOVEW FILETYPE :COMPILE-FILE) (PUTPROPS SOLID-MOVEW MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *SOLID-MOVEW-FLAG* *SOLID-MOVEW-SHADOW* *SOLID-MOVEW-SHADOW-SHADE* *SOLID-MOVEW-GRIDDING* *SOLID-MOVEW-CASHING* \SOLID-LAST-SAVMAP \SOLID-LAST-TMPMAP) ) (PUTPROPS SOLID-MOVEW COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1565 11052 (MAYBE-SOLID-MOVEW 1575 . 2415) (SOLID-MOVEW 2417 . 10904) ( \SOLID-MOVEW-CLOSEW-WATCHER 10906 . 11050))))) STOP \ No newline at end of file diff --git a/lispusers/SOLID-MOVEW.TEDIT b/lispusers/SOLID-MOVEW.TEDIT new file mode 100644 index 00000000..e6d60272 Binary files /dev/null and b/lispusers/SOLID-MOVEW.TEDIT differ diff --git a/lispusers/SOLITAIRE b/lispusers/SOLITAIRE new file mode 100644 index 00000000..d548eac6 --- /dev/null +++ b/lispusers/SOLITAIRE @@ -0,0 +1 @@ +(FILECREATED "15-Jan-86 23:32:05" {ERIS}KOTO>SOLITAIRE.;5 23494 changes to: (VARS SOLITAIRECOMS) (FNS SOLO DEALDECK NXTCARD CARDIMAGE COUNTCARDS GOODMOVE? MOVESSS CARDNAME CREATEHAND CREATESTACK STACKLOC POSTVALUE) (MACROS KINGP) previous date: "15-Dec-85 22:01:18" {ERIS}KOTO>SOLITAIRE.;3) (* Copyright (c) 1982, 1985, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT SOLITAIRECOMS) (RPAQQ SOLITAIRECOMS [(FNS SOLO SOLITAIRE) (FNS CARDIMAGE COUNTCARDS CREATEHAND CREATESTACK DEALDECK FLIPSTACK GETCARD GOODMOVE? HTOS? MOVECARD DOMOVE MOVEHS MOVES MOVES1 UPCARD MOVESSS NXTCARD PUSHCARD POSTVALUE SEARCHSTACKS SHOWCARDSTACK SHUFFLEDECK STACKLOC STOS? TOPSUITSTACK) (FNS HIST ARRAYMAX) (DECLARE: DONTCOPY (FNS SHOWCONFIG PRINTCARDSTACK CARDNAME)) (DECLARE: EVAL@COMPILE DONTCOPY (MACROS BOTTOM KINGP STACK TOP) (RECORDS CARD CARDSTACK) (CONSTANTS (Spades 0) (Clubs 1) (Diamonds 2) (Hearts 3) (CostOfDeck 50) (PayForCard 5) (NStacks 7) (NSuits 4) (CardsPerSuit 13) (TotalCards 52)) (CONSTANTS (BACKSHADE 52275) (BetweenStacks 2) (Overlap .667) (CardWidth 30) (CardHeight 45)) (GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS) (GLOBALVARS MaxCardMove WaitBetweenMoves)) (INITRECORDS CARD CARDSTACK) (BITMAPS SpadesBits ClubsBits DiamondsBits HeartsBits 10Bits) (INITVARS (MaxCardMove 8) (WaitBetweenMoves 10) (DECK) (SOLORESULTS)) (ADDVARS (IDLE.FUNCTIONS ("Solitaire" (QUOTE SOLO]) (DEFINEQ (SOLO [LAMBDA (W) (* bas: "15-Jan-86 23:31") (if (AND (BOUNDP (QUOTE SOLORESULTS)) (ARRAYP SOLORESULTS)) else (SETQ SOLORESULTS (ARRAY (ADD1 TotalCards) (QUOTE FIXP) 0 0))) (if (WINDOWP W) else (SETQ W (CREATEW [GETREGION (CONSTANT (ITIMES (IPLUS BetweenStacks (ITIMES NStacks (ADD1 BetweenStacks))) CardWidth)) (CONSTANT (ITIMES CardHeight (IPLUS 5 (FTIMES CardsPerSuit Overlap] "Just waiting Patiently...")) (DSPTEXTURE 1088 W) (DSPFONT (FONTCREATE (QUOTE HELVETICA) 18) W)) (bind X do (SETQ X (SOLITAIRE W)) (DISMISS 1500) (SETA SOLORESULTS X (ADD1 (ELT SOLORESULTS X))) (HIST SOLORESULTS W "Number of cards up") (DISMISS 1500]) (SOLITAIRE [LAMBDA (SOLOW REPLAY) (* bas: "15-Dec-85 21:33") (DECLARE (SPECVARS SOLOW)) (CLEARW SOLOW) (DEALDECK REPLAY) (PROG ((GAMEVALUE (IMINUS CostOfDeck))) (DECLARE (SPECVARS GAMEVALUE)) (POSTVALUE GAMEVALUE) (while (OR [for I from NStacks to 1 by -1 thereis (MOVES (STACK I) (STOS? (STACK I] (MOVESSS HAND) (MOVEHS HAND (HTOS? HAND)) (for I to NStacks thereis (MOVESSS (STACK I))) (FLIPSTACK HAND)) do (DISMISS WaitBetweenMoves))) (COUNTCARDS]) ) (DEFINEQ (CARDIMAGE [LAMBDA (C) (* bas: "15-Jan-86 21:37") (PROG [(BM (BITMAPCREATE CardWidth CardHeight)) (SUITBM (SELECTQ (fetch SUIT of C) (0 SpadesBits) (1 ClubsBits) (2 DiamondsBits) (3 HeartsBits) (SHOULDNT))) (RANKBM (if (EQ 10 (fetch (CARD RANK) of C)) then 10Bits else (GETCHARBITMAP (SELECTQ (fetch (CARD RANK) of C) (13 (CHARCODE K)) (12 (CHARCODE Q)) (11 (CHARCODE J)) (IPLUS (fetch (CARD RANK) of C) (CHARCODE 0))) (FONTCREATE (QUOTE HELVETICA) 18] (BLTSHADE BLACKSHADE BM 0 0 CardWidth CardHeight (QUOTE REPLACE)) (BLTSHADE WHITESHADE BM 1 1 (IDIFFERENCE CardWidth 2) (IDIFFERENCE CardHeight 2) (QUOTE REPLACE)) (BITBLT SUITBM 0 0 BM 2 32 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT RANKBM 0 0 BM (IQUOTIENT (IDIFFERENCE CardWidth (fetch BITMAPWIDTH of RANKBM)) 2) (IQUOTIENT (IDIFFERENCE CardHeight (fetch BITMAPHEIGHT of RANKBM)) 2) NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT SUITBM 0 0 BM 17 3 NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (RETURN BM]) (COUNTCARDS [LAMBDA NIL (* bas: "15-Jan-86 21:37") (for S from Spades to Hearts sum (fetch (CARD RANK) of (TOPSUITSTACK S]) (CREATEHAND [LAMBDA (F) (* bas: "15-Jan-86 23:25") (FLIPSTACK (SHOWCARDSTACK (create CARDSTACK FACEUP _ NIL FACEDOWN _(for I from F to TotalCards collect (GETCARD I)) CSX _(fetch CSX of (STACK 1)) CSY _(FIX (FTIMES CardHeight .6)) XO _(FIX (FTIMES CardWidth Overlap)) YO _ 0]) (CREATESTACK [LAMBDA (N) (* bas: "15-Jan-86 23:00") (FLIPSTACK (SHOWCARDSTACK (create CARDSTACK FACEUP _ NIL FACEDOWN _(for I from (ADD1 (IQUOTIENT (ITIMES N (SUB1 N)) 2)) as J to N collect (GETCARD I)) CSX _(STACKLOC N NStacks) CSY _(ITIMES CardHeight (IPLUS 2 (FTIMES CardsPerSuit Overlap))) XO _ 0 YO _(FIX (FTIMES CardHeight (FMINUS Overlap]) (DEALDECK [LAMBDA (REDEAL) (* bas: "11-Jan-86 20:14") (OR (AND REDEAL (ARRAYP DECK)) (SHUFFLEDECK)) (SETQ SUITSTACKS (ARRAY NSuits (QUOTE POINTER) (create CARD RANK _ 0) 0)) (SETQ STACKS (ARRAY NStacks (QUOTE POINTER))) (for I to NStacks do (SETA STACKS I (CREATESTACK I))) (SETQ HAND (CREATEHAND (CONSTANT (ADD1 (IQUOTIENT (ITIMES NStacks (ADD1 NStacks)) 2]) (FLIPSTACK [LAMBDA (H) (* bas: "29-JUL-82 15:07") (if (fetch FACEDOWN of H) then (PUSHCARD H (NXTCARD H)) H else NIL]) (GETCARD [LAMBDA (I) (* bas: "30-JUL-82 19:04") (PROG ((C (ELT DECK I))) (if (fetch FACE of C) else (replace FACE of C with (CARDIMAGE C)) (replace SAV of C with (BITMAPCREATE CardWidth CardHeight))) (replace CX of C with (replace CY of C with NIL)) (RETURN C]) (GOODMOVE? [LAMBDA (TOP BOT) (* bas: "15-Jan-86 21:38") (if TOP then (AND (EQ (fetch (CARD RANK) of TOP) (ADD1 (fetch (CARD RANK) of BOT))) (NEQ (fetch (CARD COLOR) of TOP) (fetch (CARD COLOR) of BOT))) else (KINGP BOT]) (HTOS? [LAMBDA (H) (* bas: "30-JUL-82 19:30") (if (TOP H) then (SEARCHSTACKS (TOP H]) (MOVECARD [LAMBDA (C X Y) (* lmm " 6-Aug-85 00:04") (if (fetch CX of C) then (DOMOVE (fetch FACE of C) (fetch CX of C) (fetch CY of C) X Y (fetch SAV of C)) else (BITBLT SOLOW X Y (fetch SAV of C) NIL NIL NIL NIL (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT (fetch FACE of C) NIL NIL SOLOW X Y NIL NIL (QUOTE INPUT) (QUOTE REPLACE))) (replace CX of C with X) (replace CY of C with Y) C]) (DOMOVE [LAMBDA (IMAGE LEFT BOTTOM NX NY SAVE) (* lmm " 6-Aug-85 00:04") (PROG (N YWP YFP XWP XFP) (SETQ N (IQUOTIENT (IPLUS (IMAX (ABS (IDIFFERENCE NX LEFT)) (ABS (IDIFFERENCE NY BOTTOM))) (SUB1 MaxCardMove)) MaxCardMove)) (* Number of steps) (SETQ XWP (IQUOTIENT (IDIFFERENCE NX LEFT) N)) (SETQ XFP (IREMAINDER (IDIFFERENCE NX LEFT) N)) (SETQ YWP (IQUOTIENT (IDIFFERENCE NY BOTTOM) N)) (SETQ YFP (IREMAINDER (IDIFFERENCE NY BOTTOM) N)) (bind OLDLEFT OLDLOW (XFC _ 0) (YFC _ 0) until (AND (EQ LEFT NX) (EQ BOTTOM NY)) do (SETQ OLDLEFT LEFT) (SETQ OLDLOW BOTTOM) [add LEFT XWP (PROG1 (IQUOTIENT (add XFC XFP) N) (SETQ XFC (IREMAINDER XFC N] [add BOTTOM YWP (PROG1 (IQUOTIENT (add YFC YFP) N) (SETQ YFC (IREMAINDER YFC N] (BITBLT SAVE 0 0 SOLOW OLDLEFT OLDLOW CardWidth CardHeight (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT SOLOW LEFT BOTTOM SAVE 0 0 CardWidth CardHeight (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT IMAGE 0 0 SOLOW LEFT BOTTOM CardWidth CardHeight (QUOTE INPUT) (QUOTE REPLACE]) (MOVEHS [LAMBDA (H SN) (* bas: "30-JUL-82 19:30") (if SN then (PUSHCARD SN (pop (fetch FACEUP of H))) (OR (TOP H) (FLIPSTACK H)) SN]) (MOVES [LAMBDA (S1 S2) (* bas: "30-JUL-82 12:47") (if S2 then (MOVES1 (fetch FACEUP of S1) NIL S2) (replace FACEUP of S1 with NIL) (FLIPSTACK S1) S2]) (MOVES1 [LAMBDA (L P S2) (* bas: "30-JUL-82 19:12") (if L then (MOVES1 (CDR L) (CAR L) S2) (UPCARD (CAR L) P) (PUSHCARD S2 (CAR L]) (UPCARD [LAMBDA (X Y) (* lmm " 6-Aug-85 00:04") (* Brings up X image which is assumed to be overlapped  by Y image. Assumes YOFFSET only) (if Y then (PROG [(DY (IDIFFERENCE (fetch CY of X) (fetch CY of Y] (BITBLT (fetch SAV of X) 0 0 (fetch SAV of Y) 0 DY CardWidth (IDIFFERENCE CardHeight DY) (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT SOLOW (fetch CX of X) (fetch CY of X) (fetch SAV of X) 0 0 CardWidth (IDIFFERENCE CardHeight DY) (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT (fetch FACE of X) 0 0 SOLOW (fetch CX of X) (fetch CY of X) CardWidth (IDIFFERENCE CardHeight DY) (QUOTE INPUT) (QUOTE REPLACE]) (MOVESSS [LAMBDA (S) (* bas: "15-Jan-86 23:23") (PROG (STS (TS (TOP S))) (DECLARE (USEDFREE GAMEVALUE)) (AND TS [EQ (fetch (CARD RANK) of TS) (ADD1 (fetch (CARD RANK) of (TOPSUITSTACK (SETQ STS (fetch SUIT of TS] (PROGN [SETA SUITSTACKS STS (MOVECARD (pop (fetch FACEUP of S)) (STACKLOC (ADD1 STS) NSuits) (IPLUS (fetch CSY of (STACK NStacks)) (FTIMES CardHeight 1.5] (OR (TOP S) (FLIPSTACK S)) (POSTVALUE (add GAMEVALUE PayForCard)) (RETURN T]) (NXTCARD [LAMBDA (S) (* bas: "15-Jan-86 21:44") (PROG1 (pop (fetch FACEDOWN of S)) (if (fetch FACEDOWN of S) else (* Last card up, replace surface of card table and  adjust saved image for possibly overlapping exposed  card in the pile) (BLTSHADE (DSPTEXTURE NIL SOLOW) SOLOW (fetch CSX of S) [IPLUS (fetch CSY of S) (if (OR (NULL (fetch FACEUP of S)) (ZEROP (fetch YO of S))) then 0 else (IPLUS CardHeight (fetch YO of S] (if (OR (NULL (fetch FACEUP of S)) (ZEROP (fetch XO of S))) then CardWidth else (fetch XO of S)) (if (OR (NULL (fetch FACEUP of S)) (ZEROP (fetch YO of S))) then CardHeight else (IMINUS (fetch YO of S))) (QUOTE REPLACE)) (if (fetch FACEUP of S) then (BLTSHADE (DSPTEXTURE NIL SOLOW) (fetch SAV of (BOTTOM S)) 0 (IMINUS (fetch YO of S)) (IDIFFERENCE CardWidth (fetch XO of S)) CardHeight (QUOTE REPLACE]) (PUSHCARD [LAMBDA (S C) (* bas: "30-JUL-82 14:37") [MOVECARD C (IPLUS (fetch XO of S) (if (fetch FACEUP of S) then (fetch CX of (CAR (fetch FACEUP of S))) else (fetch CSX of S))) (IPLUS (fetch YO of S) (if (fetch FACEUP of S) then (fetch CY of (CAR (fetch FACEUP of S))) else (fetch CSY of S] (push (fetch FACEUP of S) C]) (POSTVALUE [LAMBDA (V) (* bas: "15-Jan-86 23:25") (MOVETO (CONSTANT (FIX (FTIMES 25 Overlap CardWidth))) CardHeight SOLOW) (DSPFONT (FONTCREATE (QUOTE HELVETICA) 18) SOLOW) (BLTSHADE (DSPTEXTURE NIL SOLOW) SOLOW (DSPXPOSITION NIL SOLOW) (IDIFFERENCE (DSPYPOSITION NIL SOLOW) (FONTPROP (DSPFONT NIL SOLOW) (QUOTE DESCENT))) 1000 (FONTPROP (DSPFONT NIL SOLOW) (QUOTE HEIGHT)) (QUOTE REPLACE)) (DSPOPERATION (PROG1 (DSPOPERATION (QUOTE PAINT) SOLOW) (if (ILESSP V 0) then (printout SOLOW "Down by $" (IMINUS V) " ") elseif (ZEROP V) then (printout SOLOW "Dead even! ") else (printout SOLOW "Ahead by $" V " "))) SOLOW]) (SEARCHSTACKS [LAMBDA (K) (* bas: "30-JUL-82 19:19") (for I to NStacks when (GOODMOVE? (TOP (STACK I)) K) do (RETURN (STACK I]) (SHOWCARDSTACK [LAMBDA (S) (* lmm " 6-Aug-85 00:04") (if (fetch FACEDOWN of S) then (BITBLT NIL NIL NIL SOLOW (fetch CSX of S) (fetch CSY of S) CardWidth CardHeight (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL SOLOW (ADD1 (fetch CSX of S)) (ADD1 (fetch CSY of S)) (IDIFFERENCE CardWidth 2) (IDIFFERENCE CardHeight 2) (QUOTE TEXTURE) (QUOTE REPLACE) BACKSHADE)) S]) (SHUFFLEDECK [LAMBDA NIL (* bas: "30-JUL-82 14:08") [if (AND (BOUNDP (QUOTE DECK)) (ARRAYP DECK)) else (SETQ DECK (ARRAY TotalCards (QUOTE POINTER))) (bind (I _ 0) for S from Spades to Hearts do (for R to CardsPerSuit do (SETA DECK (add I 1) (create CARD SUIT _ S RANK _ R] (bind Y for I to TotalCards do (SETQ Y (RAND 1 TotalCards)) (SETA DECK I (PROG1 (ELT DECK Y) (SETA DECK Y (ELT DECK I]) (STACKLOC [LAMBDA (I N) (* bas: "15-Jan-86 22:21") (IPLUS [ITIMES I (FIXR (FQUOTIENT (IDIFFERENCE (WINDOWPROP SOLOW (QUOTE WIDTH)) (ITIMES N CardWidth)) (ADD1 N] (ITIMES CardWidth (SUB1 I]) (STOS? [LAMBDA (SN) (* bas: " 7-JAN-81 22:01") (AND (fetch FACEUP of SN) [OR (fetch FACEDOWN of SN) (NOT (KINGP (BOTTOM SN] (SEARCHSTACKS (BOTTOM SN]) (TOPSUITSTACK [LAMBDA (I) (* bas: " 4-JAN-81 01:39") (ELT SUITSTACKS I]) ) (DEFINEQ (HIST [LAMBDA (A W L) (* bas: "15-Dec-85 20:22") (PROG ((WH (WINDOWPROP W (QUOTE HEIGHT))) (WW (WINDOWPROP W (QUOTE WIDTH))) (HM NIL) (VM (IPLUS (FONTPROP (DSPFONT NIL W) (QUOTE HEIGHT)) 4))) (SETQ HM VM) (* Margins could be different eg if Y labels were  used) (BLTSHADE WHITESHADE W 0 0 WW WH (QUOTE REPLACE)) [PROG [(HS (IQUOTIENT (IDIFFERENCE WW (ITIMES HM 2)) (ARRAYSIZE A))) (VS (FQUOTIENT (IDIFFERENCE WH (ITIMES VM 2)) (ARRAYMAX A] (for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A) (ARRAYORIG A) -1) do (BLTSHADE GRAYSHADE W (IPLUS HM (ITIMES I HS)) VM HS (FIX (FTIMES VS (ELT A I))) (QUOTE REPLACE] (DRAWLINE HM VM (IDIFFERENCE WW HM) VM 2 (QUOTE REPLACE) W) (DRAWLINE HM VM HM (IDIFFERENCE WH VM) 2 (QUOTE REPLACE) W) (MOVETO (IDIFFERENCE (IDIFFERENCE WW HM) (STRINGWIDTH L (DSPFONT NIL W))) (IPLUS (FONTPROP (DSPFONT NIL W) (QUOTE DESCENT)) 2) W) (PRIN1 L W]) (ARRAYMAX [LAMBDA (A) (* bas: " 5-AUG-82 14:59") (bind (M _ 0) for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A) (ARRAYORIG A) -1) when (LESSP M (ELT A I)) do (SETQ M (ELT A I)) finally (RETURN M]) ) (DECLARE: DONTCOPY (DEFINEQ (SHOWCONFIG [LAMBDA NIL (* bas: "30-JUL-82 19:20") (printout NIL "Suits: " 10) (for I from Spades to Hearts do (printout NIL (CARDNAME (TOPSUITSTACK I)) ,)) (TERPRI) (for I to NStacks do (PRINTCARDSTACK (STACK I) (CONCAT "Stack " I))) (PRINTCARDSTACK HAND "Hand"]) (PRINTCARDSTACK [LAMBDA (X S) (* bas: " 6-JAN-81 16:47") (printout NIL S ":" 10 .I2 (LENGTH (fetch FACEDOWN X)) " down. Up: ") (for J in (fetch FACEUP of X) do (printout NIL (CARDNAME J) ,)) (TERPRI]) (CARDNAME [LAMBDA (C) (* bas: "15-Jan-86 21:40") (if (ZEROP (fetch (CARD RANK) of C)) then "None" else (PACK (LIST (SELECTQ (fetch (CARD SUIT) of C) (0 (QUOTE S)) (1 (QUOTE C)) (2 (QUOTE D)) (3 (QUOTE H)) (SHOULDNT)) (SELECTQ (fetch (CARD RANK) of C) (1 (QUOTE A)) (11 (QUOTE J)) (12 (QUOTE Q)) (13 (QUOTE K)) (fetch (CARD RANK) of C]) ) ) (DECLARE: EVAL@COMPILE DONTCOPY (DECLARE: EVAL@COMPILE [PUTPROPS BOTTOM MACRO ((S) (CAR (LAST (fetch FACEUP of S] [PUTPROPS KINGP MACRO ((C) (EQ CardsPerSuit (fetch (CARD RANK) of C] (PUTPROPS STACK MACRO ((N) (ELT STACKS N))) [PUTPROPS TOP MACRO ((S) (CAR (fetch FACEUP of S] ) [DECLARE: EVAL@COMPILE (DATATYPE CARD (SUIT RANK FACE SAV CX CY) (ACCESSFNS CARD (COLOR (ILESSP (fetch SUIT of DATUM) Diamonds)))) (RECORD CARDSTACK (FACEUP FACEDOWN CSX CSY XO YO)) ] (/DECLAREDATATYPE (QUOTE CARD) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((CARD 0 POINTER) (CARD 2 POINTER) (CARD 4 POINTER) (CARD 6 POINTER) (CARD 8 POINTER) (CARD 10 POINTER))) (QUOTE 12)) (DECLARE: EVAL@COMPILE (RPAQQ Spades 0) (RPAQQ Clubs 1) (RPAQQ Diamonds 2) (RPAQQ Hearts 3) (RPAQQ CostOfDeck 50) (RPAQQ PayForCard 5) (RPAQQ NStacks 7) (RPAQQ NSuits 4) (RPAQQ CardsPerSuit 13) (RPAQQ TotalCards 52) (CONSTANTS (Spades 0) (Clubs 1) (Diamonds 2) (Hearts 3) (CostOfDeck 50) (PayForCard 5) (NStacks 7) (NSuits 4) (CardsPerSuit 13) (TotalCards 52)) ) (DECLARE: EVAL@COMPILE (RPAQQ BACKSHADE 52275) (RPAQQ BetweenStacks 2) (RPAQQ Overlap .667) (RPAQQ CardWidth 30) (RPAQQ CardHeight 45) (CONSTANTS (BACKSHADE 52275) (BetweenStacks 2) (Overlap .667) (CardWidth 30) (CardHeight 45)) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MaxCardMove WaitBetweenMoves) ) ) (/DECLAREDATATYPE (QUOTE CARD) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((CARD 0 POINTER) (CARD 2 POINTER) (CARD 4 POINTER) (CARD 6 POINTER) (CARD 8 POINTER) (CARD 10 POINTER))) (QUOTE 12)) (RPAQ SpadesBits (READBITMAP)) (11 11 "@D@@" "@N@@" "AO@@" "COH@" "GOL@" "GOL@" "GOL@" "COH@" "@D@@" "AO@@" "COH@") (RPAQ ClubsBits (READBITMAP)) (11 11 "@D@@" "@N@@" "AO@@" "@N@@" "BDH@" "GEL@" "OON@" "GEL@" "BDH@" "@N@@" "COH@") (RPAQ DiamondsBits (READBITMAP)) (11 11 "@D@@" "@N@@" "AK@@" "CAH@" "F@L@" "L@F@" "F@L@" "CAH@" "AK@@" "@N@@" "@D@@") (RPAQ HeartsBits (READBITMAP)) (11 11 "@@@@" "CAH@" "GKL@" "DND@" "D@D@" "F@L@" "CAH@" "AK@@" "@N@@" "@D@@" "@@@@") (RPAQ 10Bits (READBITMAP)) (20 18 "@@@@@@@@" "@F@GL@@@" "@N@ON@@@" "GNALG@@@" "GNAHC@@@" "@FAHC@@@" "@FAHC@@@" "@FAHC@@@" "@FAHC@@@" "@FAHC@@@" "@FAHC@@@" "@FALG@@@" "@F@ON@@@" "@F@GL@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@" "@@@@@@@@") (RPAQ? MaxCardMove 8) (RPAQ? WaitBetweenMoves 10) (RPAQ? DECK ) (RPAQ? SOLORESULTS ) (ADDTOVAR IDLE.FUNCTIONS ("Solitaire" (QUOTE SOLO))) (PUTPROPS SOLITAIRE COPYRIGHT ("Xerox Corporation" 1982 1985 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (1624 3406 (SOLO 1634 . 2699) (SOLITAIRE 2701 . 3404)) (3407 17559 (CARDIMAGE 3417 . 4854) (COUNTCARDS 4856 . 5068) (CREATEHAND 5070 . 5525) (CREATESTACK 5527 . 6136) (DEALDECK 6138 . 6687) (FLIPSTACK 6689 . 6909) (GETCARD 6911 . 7339) (GOODMOVE? 7341 . 7706) (HTOS? 7708 . 7867) ( MOVECARD 7869 . 8491) (DOMOVE 8493 . 9921) (MOVEHS 9923 . 10158) (MOVES 10160 . 10429) (MOVES1 10431 . 10672) (UPCARD 10674 . 11691) (MOVESSS 11693 . 12456) (NXTCARD 12458 . 13928) (PUSHCARD 13930 . 14484) (POSTVALUE 14486 . 15427) (SEARCHSTACKS 15429 . 15654) (SHOWCARDSTACK 15656 . 16269) ( SHUFFLEDECK 16271 . 16859) (STACKLOC 16861 . 17182) (STOS? 17184 . 17423) (TOPSUITSTACK 17425 . 17557) ) (17560 19275 (HIST 17570 . 18957) (ARRAYMAX 18959 . 19273)) (19296 20605 (SHOWCONFIG 19306 . 19716) (PRINTCARDSTACK 19718 . 20040) (CARDNAME 20042 . 20603))))) STOP \ No newline at end of file diff --git a/lispusers/SOLITAIRE.TEDIT b/lispusers/SOLITAIRE.TEDIT new file mode 100644 index 00000000..66fd4783 Binary files /dev/null and b/lispusers/SOLITAIRE.TEDIT differ diff --git a/lispusers/SPELLINGARRAY b/lispusers/SPELLINGARRAY new file mode 100644 index 00000000..f9ebdee3 Binary files /dev/null and b/lispusers/SPELLINGARRAY differ diff --git a/lispusers/STARBG b/lispusers/STARBG new file mode 100644 index 00000000..d6e5b200 --- /dev/null +++ b/lispusers/STARBG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Aug-88 03:26:58" {ERINYES}MEDLEY>STARBG.;2 16928 changes to%: (FNS Cosmos) previous date%: "12-Oct-87 17:02:01" {ERINYES}LYRIC>LISPUSERS>STARBG.;2) (* " Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT STARBGCOMS) (RPAQQ STARBGCOMS [(INITVARS (eventPause 0) (changeStars NIL) (starShade WHITESHADE) (voidShade BLACKSHADE) (stars1 '(500 . 3000)) (stars2 '(40 . 400)) (stars3 '(6 . 70)) (stars4 '(1 . 3)) (stars5 '(1 . 10)) (constellations '(1 . 9)) (clusters '(0 . 5)) (clusterRadius '(5 . 15)) (starsInCluster '(50 . 150)) (superClusters '(0 . 1)) (superClusterRadius '(8 . 20)) (interiorClusters '(2 . 7)) (starsInterior '(30 . 100)) (BM1 (SETQ BM1 (BITMAPCREATE 1 1))) (BM2 (BITMAPCREATE 2 2)) (BM4 (BITMAPCREATE 3 3))) (BITMAPS BM3 BM5 nova) (VARS noReverseVideo saucer darkSaucer saucerMask supernova STARBGParameters trekNotes) (FNS Between BlackHole Catastrophe ChanceIn CloseFollower Constellation Cosmos InvertBM FillWithStars Marble OneChanceIn LowerBound OpenFollower PlusOrMinus RandGrey SaucerOn SaucerOff STARBG StarCluster SuperCluster SomethingCosmic StarFollowCursor StarryWindow Stomp TimePasses UFO UpperBound) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA))) (P (RANDSET T) (OR (BOUNDP 'cursorFollower) (SETQ cursorFollower (ICONW saucer saucerMask (CREATEPOSITION 0 0) T))) (if (BOUNDP 'IDLE.FUNCTIONS) then (PUSH IDLE.FUNCTIONS '("Cosmos" 'Cosmos "Go where no one has gone before... "]) (RPAQ? eventPause 0) (RPAQ? changeStars NIL) (RPAQ? starShade WHITESHADE) (RPAQ? voidShade BLACKSHADE) (RPAQ? stars1 '(500 . 3000)) (RPAQ? stars2 '(40 . 400)) (RPAQ? stars3 '(6 . 70)) (RPAQ? stars4 '(1 . 3)) (RPAQ? stars5 '(1 . 10)) (RPAQ? constellations '(1 . 9)) (RPAQ? clusters '(0 . 5)) (RPAQ? clusterRadius '(5 . 15)) (RPAQ? starsInCluster '(50 . 150)) (RPAQ? superClusters '(0 . 1)) (RPAQ? superClusterRadius '(8 . 20)) (RPAQ? interiorClusters '(2 . 7)) (RPAQ? starsInterior '(30 . 100)) (RPAQ? BM1 (SETQ BM1 (BITMAPCREATE 1 1))) (RPAQ? BM2 (BITMAPCREATE 2 2)) (RPAQ? BM4 (BITMAPCREATE 3 3)) (RPAQQ BM3 #*(3 3)J@@@@@@@J@@@) (RPAQQ BM5 #*(5 5)MH@@HH@@@@@@HH@@MH@@) (RPAQQ nova #*(9 9)OGH@OGH@NCH@LAH@@@@@LAH@NCH@OGH@OGH@) (RPAQQ noReverseVideo NIL) (RPAQQ saucer #*(24 16)@@@@@@@@C@@@@L@@C@CL@L@@@HDBA@@@@DHAB@@@@C@@L@@@@OG@O@@@CBE@DL@@DBG@DB@@HB@@DA@@LAHAHC@@K@GN@O@@FN@@GJ@@CKOOJL@@@NJJO@@@@AOOH@@@ ) (RPAQQ darkSaucer #*(24 16)A@@@@D@@D@@@A@@@@H@@@B@@B@CL@H@@@@GN@@@@@@OO@@@@@@HO@@@@@MJOK@@@CMHOKL@@GMOOKN@@CNGNGL@@DOHAO@@@AAOOHD@@@D@@E@@@@AEE@@@@@@@@@@@@ ) (RPAQQ saucerMask #*(24 16)EH@@AF@@G@@@AL@@CHCL@N@@FHGNAJ@@@DOOB@@@@COOL@@@@OOOO@@@COOOOL@@GOOOON@@OOOOOO@@OOOOOO@@OOOOOO@@GOOOON@@COOOOL@@@OOOO@@@@AOOH@@@ ) (RPAQQ supernova #*(13 13)OMOHOMOHOHOHN@CHN@CHL@AH@@@@L@AHN@CHN@CHOHOHOMOHOMOH) (RPAQQ STARBGParameters (SBM BM1 BM2 BM3 BM4 BM5 nova supernova stars1 stars2 stars3 stars4 stars5 changeStars eventPause clusters clusterRadius constellations starsInCluster superClusters superClusterRadius interiorClusters starsInterior)) (RPAQQ trekNotes (MATT>STEP-COMMAND-MENU.\;11 7859 |changes| |to:| (FUNCTIONS USER::STEP-COMMAND-AFTER USER::STEP-COMMAND-ASKUSER-MENUSELFN USER::STEP-COMMAND-BEFORE USER::STEP-COMMAND-WRAPPER USER::STEP-COMMAND-ASKUSER) (VARS STEP-COMMAND-MENUCOMS) |previous| |date:| " 4-May-87 16:45:38" {DSK}MATT>STEP-COMMAND-MENU.\;8) ; Copyright (c) 1987 by Beckman Instruments, Inc. All rights reserved. (PRETTYCOMPRINT STEP-COMMAND-MENUCOMS) (RPAQQ STEP-COMMAND-MENUCOMS ((INITVARS (*STEP-COMMAND-MENU* T) (USER::*STEP-COMMAND-INVERT-MENU-SHADE* 1)) (P (CL:PROCLAIM '(CL:SPECIAL *STEP-COMMAND-MENU* USER::*STEP-COMMAND-INVERT-MENU-SHADE*))) (FUNCTIONS USER::STEP-COMMAND-AFTER USER::STEP-COMMAND-ASKUSER USER::STEP-COMMAND-ASKUSER-MENUSELFN USER::STEP-COMMAND-BEFORE USER::STEP-COMMAND-WRAPPER) (P (CHANGENAME 'CL::STEP-COMMAND 'ASKUSER 'USER::STEP-COMMAND-ASKUSER) (MOVD 'CL::STEP-COMMAND 'USER::STEP-COMMAND-ORIGINAL) (MOVD 'USER::STEP-COMMAND-WRAPPER 'CL::STEP-COMMAND)) (PROP (MAKEFILE-ENVIRONMENT) STEP-COMMAND-MENU))) (RPAQ? *STEP-COMMAND-MENU* T) (RPAQ? USER::*STEP-COMMAND-INVERT-MENU-SHADE* 1) (CL:PROCLAIM '(CL:SPECIAL *STEP-COMMAND-MENU* USER::*STEP-COMMAND-INVERT-MENU-SHADE*)) (CL:DEFUN USER::STEP-COMMAND-AFTER NIL  (* \; "Edited 29-Sep-87 11:39 by Matt Heffron") (LET ((USER::STEP-WINDOW (WFROMDS CL::*STEP-IO*))) (CL:WHEN (AND *STEP-COMMAND-MENU* (CL:ZEROP CL::*STEP-INDENTATION-LEVEL* )) (REMOVEWINDOW (WINDOWPROP USER::STEP-WINDOW 'USER::STEP-MENUW)) (WINDOWPROP USER::STEP-WINDOW 'USER::STEP-MENUW NIL) (WINDOWPROP USER::STEP-WINDOW 'USER::STEP-EVENT NIL)))) (CL:DEFUN USER::STEP-COMMAND-ASKUSER (USER::WAIT USER::DEFAULT USER::MESS USER::KEYLIST)  (* \; "Edited 1-May-87 10:25 by Matt Heffron") (CL:IF *STEP-COMMAND-MENU* (LET ((USER::MENUW (WINDOWPROP (WFROMDS CL::*STEP-IO*) 'USER::STEP-MENUW))) (INVERTW USER::MENUW USER::*STEP-COMMAND-INVERT-MENU-SHADE*) (WINDOWPROP USER::MENUW 'USER::STEP-ACTIVE T) (AWAIT.EVENT (WINDOWPROP USER::MENUW 'USER::STEP-EVENT)) (WINDOWPROP USER::MENUW 'USER::STEP-ACTIVE NIL) (INVERTW USER::MENUW USER::*STEP-COMMAND-INVERT-MENU-SHADE*) (WINDOWPROP USER::MENUW 'USER::STEP-VALUE)) (ASKUSER USER::WAIT USER::DEFAULT USER::MESS USER::KEYLIST))) (CL:DEFUN USER::STEP-COMMAND-ASKUSER-MENUSELFN (USER::ITEM USER::MENU USER::BUTTON)  (* \; "Edited 1-May-87 10:25 by Matt Heffron") (LET ((USER::W (WFROMMENU USER::MENU))) (CL:WHEN (WINDOWPROP USER::W 'USER::STEP-ACTIVE) (WINDOWPROP USER::W 'USER::STEP-VALUE (CADR USER::ITEM)) (NOTIFY.EVENT (WINDOWPROP USER::W 'USER::STEP-EVENT))))) (CL:DEFUN USER::STEP-COMMAND-BEFORE NIL  (* \; "Edited 29-Sep-87 11:43 by Matt Heffron") (LET ((USER::STEP-WINDOW (WFROMDS CL::*STEP-IO*))) (CL:WHEN (AND *STEP-COMMAND-MENU* (NOT (WINDOWPROP USER::STEP-WINDOW 'USER::STEP-MENUW))) (LET ((USER::WREGION (WINDOWREGION USER::STEP-WINDOW)) USER::MENUW USER::MREGION) (CL:SETQ USER::MENUW (MENUWINDOW (|create| MENU ITEMS _ '(("Step" \ "Step - Evaluate this expression, stepping on the sub-expressions" ) ("Next" N "Next - Evaluate this expression without stepping" ) ("Finish" F "Finish - Complete evaluation without the stepper" ) ("Abort" ^ "Abort - Abort this evaluation")) WHENSELECTEDFN _ #' USER::STEP-COMMAND-ASKUSER-MENUSELFN MENUCOLUMNS _ 1 TITLE _ " Commands " CENTERFLG _ T) T)) (CL:SETQ USER::MREGION (WINDOWREGION USER::MENUW)) (ATTACHWINDOW USER::MENUW USER::STEP-WINDOW (CL:IF (> (+ (|fetch| (REGION LEFT) |of| USER::WREGION) (|fetch| (REGION WIDTH) |of| USER::WREGION) (|fetch| (REGION WIDTH) |of| USER::MREGION)) SCREENWIDTH) 'LEFT 'RIGHT) 'BOTTOM) (WINDOWPROP USER::STEP-WINDOW 'USER::STEP-MENUW USER::MENUW) (WINDOWPROP USER::MENUW 'USER::STEP-EVENT (CREATE.EVENT 'USER::STEP-MENU)) (INVERTW USER::MENUW USER::*STEP-COMMAND-INVERT-MENU-SHADE*))))) (CL:DEFUN USER::STEP-COMMAND-WRAPPER (USER::FORM USER::ENVIRONMENT)  (* \; "Edited 1-May-87 11:33 by Matt Heffron") (CL:IF *STEP-COMMAND-MENU* (CL:UNWIND-PROTECT (PROGN (USER::STEP-COMMAND-BEFORE) (USER::STEP-COMMAND-ORIGINAL USER::FORM USER::ENVIRONMENT)) (USER::STEP-COMMAND-AFTER)) (USER::STEP-COMMAND-ORIGINAL USER::FORM USER::ENVIRONMENT))) (CHANGENAME 'CL::STEP-COMMAND 'ASKUSER 'USER::STEP-COMMAND-ASKUSER) (MOVD 'CL::STEP-COMMAND 'USER::STEP-COMMAND-ORIGINAL) (MOVD 'USER::STEP-COMMAND-WRAPPER 'CL::STEP-COMMAND) (PUTPROPS STEP-COMMAND-MENU MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP")) (PUTPROPS STEP-COMMAND-MENU COPYRIGHT ("Beckman Instruments, Inc" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/STEP-COMMAND-MENU.TEDIT b/lispusers/STEP-COMMAND-MENU.TEDIT new file mode 100644 index 00000000..403f963f Binary files /dev/null and b/lispusers/STEP-COMMAND-MENU.TEDIT differ diff --git a/lispusers/STORAGE b/lispusers/STORAGE new file mode 100644 index 00000000..501dc20a --- /dev/null +++ b/lispusers/STORAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Sep-87 15:17:45" |{MCS:MCS:STANFORD}STORAGE.;16| 16510 changes to%: (VARS STORAGECOMS) (FNS SHOWSTORAGEREPAINT) previous date%: " 9-Sep-87 10:06:41" |{MCS:MCS:STANFORD}STORAGE.;13|) (* " Copyright (c) 1984, 1985, 1986, 1987 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT STORAGECOMS) (RPAQQ STORAGECOMS [(LOCALVARS . T) (FNS SHOWSTORAGE) (FNS SHOWSTORAGEBUTTONFN SHOWSTORAGEREPAINT SHOWSTORAGEUPDATE SHOWSTORAGEDISPLAY SHOWSTORAGEALLOCMDS) (ADDVARS (SHOWSTORAGEIGNORE SMALLP LITATOM CHARACTER CL::STRUCTURE-OBJECT)) (INITVARS (SHOWSTORAGEMODES '(ITEM PAGE BOX)) (SHOWSTORAGEWINDOWSIZE 275) (SHOWSTORAGEDEFAULTTHRESHOLD 1) (SHOWSTORAGEFONT (bind FONT for ROTATION in '(90 0) thereis (for SIZE from 5 to 10 thereis (SETQ FONT (FONTCREATE 'HELVETICA SIZE 'MRR ROTATION 'DISPLAY T))) finally (RETURN FONT))) SHOWSTORAGEPRIN2FLG) (GLOBALVARS SHOWSTORAGEIGNORE SHOWSTORAGEMODES SHOWSTORAGEWINDOWSIZE SHOWSTORAGEDEFAULTTHRESHOLD SHOWSTORAGEFONT SHOWSTORAGEPRIN2FLG) (DECLARE%: DONTCOPY (CONSTANTS (SHOWSTORAGESHADE 42405]) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (SHOWSTORAGE [LAMBDA (PAGETHRESHOLD MODE ROTATION) (* ; "Edited 9-Sep-87 10:06 by cdl") (if (NOT (MEMB MODE SHOWSTORAGEMODES)) then (SETQ MODE (CAR SHOWSTORAGEMODES))) (if (NOT (NUMBERP PAGETHRESHOLD)) then (SETQ PAGETHRESHOLD SHOWSTORAGEDEFAULTTHRESHOLD)) (LET (WINDOW SIZE (TYPES (SHOWSTORAGEALLOCMDS PAGETHRESHOLD)) (FONT (if ROTATION then (FONTCOPY SHOWSTORAGEFONT 'ROTATION ROTATION) else SHOWSTORAGEFONT))) [SETQ SIZE (TIMES (LENGTH TYPES) (FONTPROP FONT 'HEIGHT] (SETQ WINDOW (CREATEW (SELECTQ (FONTPROP FONT 'ROTATION) (90 (GETBOXREGION (WIDTHIFWINDOW SIZE) (HEIGHTIFWINDOW SHOWSTORAGEWINDOWSIZE T))) (GETBOXREGION (WIDTHIFWINDOW SHOWSTORAGEWINDOWSIZE) (HEIGHTIFWINDOW SIZE T))) (CONCAT "Datatype Storage by " MODE " count, threshold = " PAGETHRESHOLD ))) (DSPFONT FONT WINDOW) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION SHOWSTORAGEBUTTONFN)) (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION SHOWSTORAGEREPAINT)) (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION SHOWSTORAGEREPAINT)) (WINDOWPROP WINDOW 'EXPANDFN (FUNCTION SHOWSTORAGEUPDATE)) (WINDOWPROP WINDOW 'MODE MODE) (WINDOWPROP WINDOW 'THRESHOLD PAGETHRESHOLD) (WINDOWPROP WINDOW 'ALLOCMDS TYPES) (REDISPLAYW WINDOW]) ) (DEFINEQ (SHOWSTORAGEBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 9-Sep-87 08:10 by cdl") (if (MOUSESTATE LEFT) then (SHOWSTORAGEUPDATE WINDOW) elseif (MOUSESTATE MIDDLE) then [LET [(MODE (OR (CADR (MEMB (WINDOWPROP WINDOW 'MODE) SHOWSTORAGEMODES)) (CAR SHOWSTORAGEMODES] (WINDOWPROP WINDOW 'MODE MODE) (WINDOWPROP WINDOW 'TITLE (CONCAT "Datatype Storage by " MODE " count, threshold = " (WINDOWPROP WINDOW 'THRESHOLD] (DSPFILL (SELECTQ (FONTPROP (DSPFONT NIL WINDOW) 'ROTATION) (90 (create REGION HEIGHT _ (WINDOWPROP WINDOW 'DIVISION) using (DSPCLIPPINGREGION NIL WINDOW))) (create REGION WIDTH _ (WINDOWPROP WINDOW 'DIVISION) using (DSPCLIPPINGREGION NIL WINDOW))) WHITESHADE 'REPLACE WINDOW) (SHOWSTORAGEUPDATE WINDOW)) (until (MOUSESTATE UP) do (BLOCK]) (SHOWSTORAGEREPAINT [LAMBDA (WINDOW) (* ; "Edited 17-Sep-87 15:07 by cdl") (PROG ((FONT (DSPFONT NIL WINDOW)) (REGION (DSPCLIPPINGREGION NIL WINDOW)) DATATYPES SIZE DIVISION FONTHEIGHT ROTATION) [if [NULL (SETQ DATATYPES (WINDOWPROP WINDOW 'ALLOCMDS] then (WINDOWPROP WINDOW 'ALLOCMDS (SETQ DATATYPES (SHOWSTORAGEALLOCMDS (WINDOWPROP WINDOW 'THRESHOLD] (WINDOWPROP WINDOW 'DATATYPES (SETQ DATATYPES (in DATATYPES collect CAR))) (if (NEQ [SETQ SIZE (TIMES (LENGTH DATATYPES) (SETQ FONTHEIGHT (FONTPROP FONT 'HEIGHT] (with REGION REGION (SELECTQ (SETQ ROTATION (FONTPROP FONT 'ROTATION)) (90 WIDTH) HEIGHT))) then [SHAPEW WINDOW (SELECTQ ROTATION (90 (create REGION WIDTH _ (WIDTHIFWINDOW SIZE) using (WINDOWPROP WINDOW 'REGION))) (create REGION HEIGHT _ (HEIGHTIFWINDOW SIZE T) using (WINDOWPROP WINDOW 'REGION] (RETURN)) [WINDOWPROP WINDOW 'DIVISION (SETQ DIVISION (DIFFERENCE (with REGION REGION (SELECTQ ROTATION (90 TOP) RIGHT)) (STRINGWIDTH (for DATATYPE in DATATYPES largest (NCHARS DATATYPE SHOWSTORAGEPRIN2FLG )) FONT SHOWSTORAGEPRIN2FLG] (bind (WIDTH _ (ADD1 DIVISION)) [HEIGHT _ (SELECTQ ROTATION (90 (FONTPROP FONT 'ASCENT)) (FONTPROP FONT 'DESCENT] for DATATYPE in DATATYPES do (SELECTQ ROTATION (90 (MOVETO HEIGHT WIDTH WINDOW)) (MOVETO WIDTH HEIGHT WINDOW)) (if SHOWSTORAGEPRIN2FLG then (printout WINDOW |.P2| DATATYPE) else (printout WINDOW DATATYPE)) (add HEIGHT FONTHEIGHT)) (SHOWSTORAGEUPDATE WINDOW]) (SHOWSTORAGEUPDATE [LAMBDA (WINDOW) (* ; "Edited 9-Sep-87 07:48 by cdl") (DECLARE (SPECVARS WINDOW) (GLOBALVARS WAITINGCURSOR)) (RESETFORM (CURSOR WAITINGCURSOR) (LET ((FONT (DSPFONT NIL WINDOW)) (DIVISION (WINDOWPROP WINDOW 'DIVISION)) (MODE (WINDOWPROP WINDOW 'MODE)) (DATATYPES (WINDOWPROP WINDOW 'DATATYPES)) (ALLOCMDSLST (WINDOWPROP WINDOW 'ALLOCMDS NIL)) (FREE (CREATECELL \FIXP)) ALLOCMDS DATATYPE REGION ITEMSPERMDS TYPENUMBER ROTATION FONTHEIGHT) (DECLARE (SPECVARS ALLOCMDS)) (SETQ FONTHEIGHT (FONTPROP FONT 'HEIGHT)) (SETQ REGION (SELECTQ (SETQ ROTATION (FONTPROP FONT 'ROTATION)) (90 (create REGION WIDTH _ FONTHEIGHT LEFT _ 1)) (create REGION HEIGHT _ FONTHEIGHT BOTTOM _ 0))) (for DATATYPE in DATATYPES do (SETQ TYPENUMBER (\TYPENUMBERFROMNAME DATATYPE)) (SELECTQ MODE ((PAGE ITEM) (\StatsZero FREE) (if (NULL ALLOCMDSLST) then (SETQ ALLOCMDSLST (SHOWSTORAGEALLOCMDS (WINDOWPROP WINDOW 'THRESHOLD) DATATYPE))) (SETQ ALLOCMDS (CADR (pop ALLOCMDSLST))) [if (EQ 'LISTP (\TYPENAMEFROMNUMBER TYPENUMBER)) then [SETQ ITEMSPERMDS (CONSTANT (FIX (FQUOTIENT \MDSIncrement 2.2] (for (LSTPAG _ (create POINTER PAGE# _ (fetch (DTD DTDNEXTPAGE) of \LISTPDTD ))) by (create POINTER PAGE# _ (fetch (CONSPAGE NEXTPAGE) of LSTPAG)) while LSTPAG do (\BOXIPLUS FREE (fetch (CONSPAGE CNT) of LSTPAG))) else (with DTD (\GETDTD TYPENUMBER) (SETQ ITEMSPERMDS (QUOTIENT \MDSIncrement DTDSIZE)) (for (PTR _ DTDFREE) by (\GETBASEPTR PTR 0) while PTR do (\BOXIPLUS FREE 1]) NIL) (SELECTQ MODE (PAGE (SHOWSTORAGEDISPLAY (TIMES ALLOCMDS (QUOTIENT \MDSIncrement WORDSPERPAGE)) (TIMES (QUOTIENT FREE ITEMSPERMDS) (QUOTIENT \MDSIncrement WORDSPERPAGE)) WINDOW REGION)) (ITEM (SHOWSTORAGEDISPLAY (TIMES ALLOCMDS ITEMSPERMDS) FREE WINDOW REGION)) (BOX (SHOWSTORAGEDISPLAY (BOXCOUNT TYPENUMBER) NIL WINDOW REGION)) (SHOULDNT)) (with REGION REGION (SELECTQ ROTATION (90 (add LEFT FONTHEIGHT)) (add BOTTOM FONTHEIGHT]) (SHOWSTORAGEDISPLAY [LAMBDA (TOTAL FREE WINDOW REGION) (* cdl "28-Jan-87 18:22") (PROG ((FONT (DSPFONT NIL WINDOW)) (DIVISION (WINDOWPROP WINDOW 'DIVISION)) ROTATION INUSE OFFSET STRINGWIDTH) (with REGION REGION [SELECTQ (SETQ ROTATION (FONTPROP FONT 'ROTATION)) (90 (SETQ HEIGHT TOTAL) (SETQ BOTTOM (DIFFERENCE DIVISION TOTAL)) [SETQ OFFSET (PLUS LEFT (SUB1 (FONTPROP FONT 'ASCENT]) (PROGN (SETQ WIDTH TOTAL) (SETQ LEFT (DIFFERENCE DIVISION TOTAL)) (SETQ OFFSET (PLUS BOTTOM (FONTPROP FONT 'DESCENT] (DSPFILL REGION BLACKSHADE NIL WINDOW) (if (NULL FREE) then (if (GREATERP TOTAL (STRINGWIDTH TOTAL FONT)) then (SELECTQ ROTATION (90 (MOVETO OFFSET (ADD1 (MAX BOTTOM 0)) WINDOW)) (MOVETO (ADD1 (MAX LEFT 0)) OFFSET WINDOW)) (printout WINDOW TOTAL)) (RETURN)) (if (GREATERP (SETQ INUSE (DIFFERENCE TOTAL FREE)) (STRINGWIDTH INUSE FONT)) then (SELECTQ ROTATION (90 (MOVETO OFFSET (ADD1 (MAX (PLUS BOTTOM FREE) 0)) WINDOW)) (MOVETO (ADD1 (MAX (PLUS LEFT FREE) 0)) OFFSET WINDOW)) (DSPOPERATION 'INVERT WINDOW) (PRIN1 INUSE WINDOW) (DSPOPERATION 'REPLACE WINDOW)) (SELECTQ ROTATION (90 (SETQ HEIGHT FREE)) (SETQ WIDTH FREE)) (DSPFILL REGION SHOWSTORAGESHADE NIL WINDOW) (if (AND (GREATERP FREE (SETQ STRINGWIDTH (STRINGWIDTH FREE FONT))) (GREATERP (DIFFERENCE DIVISION INUSE) STRINGWIDTH)) then (SELECTQ ROTATION (90 (MOVETO OFFSET (ADD1 (MAX BOTTOM 0)) WINDOW)) (MOVETO (ADD1 (MAX LEFT 0)) OFFSET WINDOW)) (PRIN1 FREE WINDOW]) (SHOWSTORAGEALLOCMDS [LAMBDA (THRESHOLD TYPES) (* ; "Edited 9-Sep-87 10:05 by cdl") (DECLARE (SPECVARS THRESHOLD) (GLOBALVARS WAITINGCURSOR)) (RESETFORM (CURSOR WAITINGCURSOR) (bind ALLOCMDS declare%: (SPECVARS ALLOCMDS) for DATATYPE inside (OR TYPES (LDIFFERENCE (DATATYPES) SHOWSTORAGEIGNORE)) eachtime (SETQ ALLOCMDS 0) [\MAPMDS (\TYPENUMBERFROMNAME DATATYPE) (FUNCTION (LAMBDA NIL (ADD1VAR ALLOCMDS] when (GEQ (TIMES ALLOCMDS (QUOTIENT \MDSIncrement WORDSPERPAGE)) THRESHOLD) collect (LIST DATATYPE ALLOCMDS]) ) (ADDTOVAR SHOWSTORAGEIGNORE SMALLP LITATOM CHARACTER CL::STRUCTURE-OBJECT) (RPAQ? SHOWSTORAGEMODES '(ITEM PAGE BOX)) (RPAQ? SHOWSTORAGEWINDOWSIZE 275) (RPAQ? SHOWSTORAGEDEFAULTTHRESHOLD 1) (RPAQ? SHOWSTORAGEFONT (bind FONT for ROTATION in '(90 0) thereis (for SIZE from 5 to 10 thereis (SETQ FONT (FONTCREATE 'HELVETICA SIZE 'MRR ROTATION 'DISPLAY T))) finally (RETURN FONT))) (RPAQ? SHOWSTORAGEPRIN2FLG NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SHOWSTORAGEIGNORE SHOWSTORAGEMODES SHOWSTORAGEWINDOWSIZE SHOWSTORAGEDEFAULTTHRESHOLD SHOWSTORAGEFONT SHOWSTORAGEPRIN2FLG) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ SHOWSTORAGESHADE 42405) (CONSTANTS (SHOWSTORAGESHADE 42405)) ) ) (PUTPROPS STORAGE COPYRIGHT ("Stanford University" 1984 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1791 3480 (SHOWSTORAGE 1801 . 3478)) (3481 15428 (SHOWSTORAGEBUTTONFN 3491 . 4996) ( SHOWSTORAGEREPAINT 4998 . 7973) (SHOWSTORAGEUPDATE 7975 . 11637) (SHOWSTORAGEDISPLAY 11639 . 14411) ( SHOWSTORAGEALLOCMDS 14413 . 15426))))) STOP \ No newline at end of file diff --git a/lispusers/STORAGE.TEDIT b/lispusers/STORAGE.TEDIT new file mode 100644 index 00000000..e84febb2 Binary files /dev/null and b/lispusers/STORAGE.TEDIT differ diff --git a/lispusers/STREAMDECLS b/lispusers/STREAMDECLS new file mode 100644 index 00000000..4f17cade --- /dev/null +++ b/lispusers/STREAMDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "10-Sep-87 12:12:37" {DSK}STREAMDECLS.\;1 10202 |changes| |to:| (VARS STREAMDECLSCOMS) (RECORDS STREAM)) (PRETTYCOMPRINT STREAMDECLSCOMS) (RPAQQ STREAMDECLSCOMS ((RECORDS STREAM))) (DECLARE\: EVAL@COMPILE (DATATYPE STREAM ( (* |;;| "First 8 words are fixed for BIN, BOUT opcodes. Used to require length of whole datatype be multiple of 4, but Dolphin dead now.") (COFFSET WORD) (* \;  "Offset in CPPTR of next bin or bout") (CBUFSIZE WORD) (* \;  "Offset past last byte in that buffer") (BINABLE FLAG) (* \; "BIN punts unless this bit on") (BOUTABLE FLAG) (* \; "BOUT punts unless this bit on") (EXTENDABLE FLAG) (* \;  "BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512") (CBUFDIRTY FLAG) (* \;  "true if BOUT has sullied the current buffer") (PEEKEDCHARP FLAG) (* \;  "if true, PEEKEDCHAR contains value of recent call to unread-char") (ACCESSBITS BITS 3) (* \;  "What kind of access file is open for (read, write, append)") (CBUFPTR POINTER) (* \; "Pointer to current buffer") (BYTESIZE BYTE) (* \;  "Byte size of stream, always 8 for now") (CHARSET BYTE) (* \; "the current character set for this stream. If 255, stream is not runcoded, so read-char consumes two bytes every time") (PEEKEDCHAR WORD) (* \; "value of unread-char call") (CHARPOSITION WORD) (* \; "Used by POSITION etc.") (CBUFMAXSIZE WORD) (* \;  "on output, the size of the physical buffer--can't extend beyond this") (* |;;| "-------- Above fields (8 words) potentially known to microcode. --------") (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* \;  "True if stream likes to read and write more than one buffer at a time") (USERCLOSEABLE FLAG) (* \;  "Can be closed by CLOSEF; NIL for terminal, dribble...") (USERVISIBLE FLAG) (* \;  "Listed by OPENP; NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* \; "End-of-line convention") (NIL FLAG) (FULLFILENAME POINTER) (* \;  "Name by which file is known to user") (DEVICE POINTER) (* \; "FDEV of this guy") (VALIDATION POINTER) (* \;  "A number somehow identifying file, used to determine if file has changed in our absence") (CPAGE POINTER) (* \;  "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams") (EPAGE POINTER) (EOFFSET WORD) (* \; "Page, byte offset of eof") (LINELENGTH WORD) (* \;  "LINELENGTH of stream, or -1 for no line length") (* |;;| "----Following are device-specific fields----") (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (* |;;| "----Following only filled in for open streams----") (STRMBINFN POINTER) (* \;  "Either the BIN fn from the FDEV, or a trap") (STRMBOUTFN POINTER) (* \;  "Either the BIN fn from the FDEV, or a trap") (OUTCHARFN POINTER) (ENDOFSTREAMOP POINTER) (OTHERPROPS POINTER) (IMAGEOPS POINTER) (* \; "Image operations vector") (IMAGEDATA POINTER) (* \;  "Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* \; "Buffer chain for pmapped streams") (MAXBUFFERS WORD) (NIL WORD) (EXTRASTREAMOP POINTER) (* \;  "For use of applications programs, not devices") ) (BLOCKRECORD STREAM ((NIL 2 WORD) (UCODEFLAGS BITS 5) (* |;;| "respecification of access bits:") (RANDOMWRITEABLE FLAG) (* \;  "File open for output (access = OUTPUT or BOTH)") (APPENDABLE FLAG) (* \;  "File open for append (OUTPUT or APPEND or BOTH)") (READABLE FLAG) (* \;  "File open for read (READ or BOTH)") (NIL POINTER))) (ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS) (FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM) DATUM)) (NAMEDP (AND (|fetch| (STREAM FULLFILENAME) |of| DATUM) T)))) (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ |NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (GLOBALVARS \\STREAM.DEFAULT.MAXBUFFERS )) \\STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _ (LET NIL (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN) ENDOFSTREAMOP _ (FUNCTION \\EOSERROR) IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE) (D CR.EOLC) (VAX LF.EOLC) (JERICHO CRLF.EOLC) CR.EOLC) STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN) STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN)) ) (/DECLAREDATATYPE 'STREAM '(WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 3) POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 2) FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((STREAM 0 (BITS . 15)) (STREAM 1 (BITS . 15)) (STREAM 2 (FLAGBITS . 0)) (STREAM 2 (FLAGBITS . 16)) (STREAM 2 (FLAGBITS . 32)) (STREAM 2 (FLAGBITS . 48)) (STREAM 2 (FLAGBITS . 64)) (STREAM 2 (BITS . 82)) (STREAM 2 POINTER) (STREAM 4 (BITS . 7)) (STREAM 4 (BITS . 135)) (STREAM 5 (BITS . 15)) (STREAM 6 (BITS . 15)) (STREAM 7 (BITS . 15)) (STREAM 8 (FLAGBITS . 0)) (STREAM 8 (FLAGBITS . 16)) (STREAM 8 (FLAGBITS . 32)) (STREAM 8 (FLAGBITS . 48)) (STREAM 8 (FLAGBITS . 64)) (STREAM 8 (BITS . 81)) (STREAM 8 (FLAGBITS . 112)) (STREAM 8 POINTER) (STREAM 10 POINTER) (STREAM 12 POINTER) (STREAM 14 POINTER) (STREAM 16 POINTER) (STREAM 18 (BITS . 15)) (STREAM 19 (BITS . 15)) (STREAM 20 POINTER) (STREAM 22 POINTER) (STREAM 24 POINTER) (STREAM 26 POINTER) (STREAM 28 POINTER) (STREAM 30 (BITS . 15)) (STREAM 31 (BITS . 15)) (STREAM 32 (BITS . 15)) (STREAM 33 (BITS . 15)) (STREAM 34 POINTER) (STREAM 36 POINTER) (STREAM 38 POINTER) (STREAM 40 POINTER) (STREAM 42 POINTER) (STREAM 44 POINTER) (STREAM 46 POINTER) (STREAM 48 POINTER) (STREAM 50 POINTER) (STREAM 52 (BITS . 15)) (STREAM 53 (BITS . 15)) (STREAM 54 POINTER)) '56) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/lispusers/STYLESHEET b/lispusers/STYLESHEET new file mode 100644 index 00000000..a599f68e --- /dev/null +++ b/lispusers/STYLESHEET @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "26-Jan-88 17:58:05" {QV}LISP>STYLESHEET.;2 37593 changes to%: (FNS STYLESHEET.CHANGE.ITEMS STYLESHEET.FILL.IN.WINDOW STYLESHEET.IMAGEHEIGHT STYLESHEET.IMAGEWIDTH STYLESHEET.AT.LOAD) (VARS STYLESHEETCOMS) previous date%: "27-Aug-87 13:10:53" |{IE:PARC:XEROX}LYRIC>STYLESHEET.;1|) (* " Copyright (c) 1983, 1985, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT STYLESHEETCOMS) (RPAQQ STYLESHEETCOMS [(DECLARE%: DONTCOPY (PROPS (STYLESHEET MAKEFILE-ENVIRONMENT) (STYLESHEET FILETYPE))) (DECLARE%: (LOCALVARS . T)) (* * Public entry) (FNS CREATE.STYLE STYLESHEETP STYLE.PROP STYLESHEET STYLESHEET.IMAGEHEIGHT STYLESHEET.IMAGEWIDTH) (* * Private routines.) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS STYLEBLOCK)) (INITRECORDS STYLEBLOCK) (FNS STYLESHEET.CHANGE.FILL STYLESHEET.CHANGE.ITEMS STYLESHEET.CHANGE.SELECTIONS STYLESHEET.CHANGE.TITLES STYLESHEET.MENUITEM ) (FNS STYLESHEET.SETUP STYLESHEET.WAIT.TILL.DONE STYLESHEET.GET.SELECTIONS STYLESHEET.CLEANUP) (FNS STYLESHEET.WHENSELECTEDFN STYLESHEET.CLEAR.WHENSELECTEDFN STYLESHEET.DONE.FN) (FNS STYLESHEET.ITEM.HEIGHT STYLESHEET.ITEM.WIDTH) (FNS STYLESHEET.CREATE.WINDOW STYLESHEET.FILL.IN.WINDOW STYLESHEET.ADD.MENU STYLESHEET.SHADE.SELECTIONS) (FNS STYLESHEET.AT.LOAD) (P (STYLESHEET.AT.LOAD)) (GLOBALVARS STYLESHEET.SELECTED.SHADE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA STYLE.PROP CREATE.STYLE]) (DECLARE%: DONTCOPY (PUTPROPS STYLESHEET MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (PUTPROPS STYLESHEET FILETYPE :TCOMPL) ) (DECLARE%: (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (* * Public entry) (DEFINEQ (CREATE.STYLE [LAMBDA STYLE (* hts%: "21-Mar-85 14:14") (* * Stylesheet constructor.) (LET* [(PLIST (for I to STYLE collect (ARG STYLE I))) (ITEMS (LISTP (LISTGET PLIST 'ITEMS] (if ITEMS then (LET ((STYLESHEET (LIST 'STYLESHEET 'ITEMS ITEMS))) (for PROP on PLIST by (CDDR PROP) do (STYLE.PROP STYLESHEET (CAR PROP) (CADR PROP))) STYLESHEET) else NIL]) (STYLESHEETP [LAMBDA (THING) (* hts%: "22-Mar-85 13:00") (* * Tells whether THING is probably a stylesheet.) (AND (LISTP THING) (EQ (CAR THING) 'STYLESHEET) (LISTP (LISTGET (CDR THING) 'ITEMS]) (STYLE.PROP [LAMBDA PROPSTUFF (* hts%: "22-Mar-85 13:22") (* * Get or put a "field" of a stylesheet.  Works externally the same way as WINDOWPROP.  A stylesheet is represented as the cons of the atom STYLESHEET and a plist  containing all the requisite data.) (OR (EQ PROPSTUFF 2) (EQ PROPSTUFF 3) (\ILLEGAL.ARG)) (LET ((STYLESHEET (ARG PROPSTUFF 1))) (OR (STYLESHEETP STYLESHEET) (\ILLEGAL.ARG STYLESHEET)) (LET [(PROP (MKATOM (ARG PROPSTUFF 2] (if (EQ PROPSTUFF 2) then (LISTGET (CDR STYLESHEET) PROP) else (LET ((OLDVAL (LISTGET (CDR STYLESHEET) PROP)) (NEWVAL (ARG PROPSTUFF 3))) (LISTPUT (CDR STYLESHEET) PROP NEWVAL) (* * Certain stylesheet properties are normalized and collected into a list of  "styleblocks" %, one for each item. Styleblocks make it easier later on to  handle the information for each item. Styleblocks store the items themselves,  selections, fill information, titles, and CLEAR-ALL submenus  (if any)%.) (SELECTQ (ARG PROPSTUFF 2) (ITEMS (STYLESHEET.CHANGE.ITEMS STYLESHEET NEWVAL)) (NEED.NOT.FILL.IN (STYLESHEET.CHANGE.FILL STYLESHEET NEWVAL)) (SELECTIONS (STYLESHEET.CHANGE.SELECTIONS STYLESHEET NEWVAL)) (ITEM.TITLES (STYLESHEET.CHANGE.TITLES STYLESHEET NEWVAL)) NIL) OLDVAL]) (STYLESHEET [LAMBDA (STYLE) (* ; "Edited 27-Aug-87 13:08 by Stansbury") (* ;;; "Creates a window, lays out the menus in it, and waits for BACKGROUND to notify it that the the user has made all his selections and hit the DONE button. Then removes the window and returns the selections the user made.") (OR (STYLESHEETP STYLE) (\ILLEGAL.ARG STYLE)) (LET ((OLD.WHENSELECTEDFNS (STYLESHEET.SETUP STYLE) (* ;  "Hold onto old WHENSELECTEDFNs so that they can be restored on exit.") ) (W (STYLESHEET.CREATE.WINDOW STYLE) (* ;  "Lay out stylesheet of appropriate size and fill it in.") )) (* ;;  "Wait until the user has filled everything in he needs to, and has hit the DONE button.") (STYLESHEET.WAIT.TILL.DONE W STYLE) (* ;; "Clean things up and return user's selections.") (PROG1 (if (EQ (WINDOWPROP W 'HOW NIL) 'ABORT) then (* ;;  "user selected ABORT: restore original selections, in case stylesheet is reused. Return NIL.") (STYLE.PROP STYLE 'SELECTIONS (STYLE.PROP STYLE 'SELECTIONS)) NIL else (* ;; "normal exit: return new selections.") (STYLESHEET.GET.SELECTIONS STYLE)) (STYLESHEET.CLEANUP W STYLE OLD.WHENSELECTEDFNS]) (STYLESHEET.IMAGEHEIGHT [LAMBDA (STYLESHEET) (* ; "Edited 26-Jan-88 11:48 by Trigg") (* ;;; "Tells how high in pixels the given stylesheet would be if it were displayed.") (* ;;  "rht 1/26/88: Now grabs Done/Reset/Abort styleblock off of STYLEPROP rather than from globalvar.") (HEIGHTIFWINDOW (bind THIS.ONE (BIG _ 0) (TITLEFONT _ (STYLE.PROP STYLESHEET 'ITEM.TITLE.FONT)) for BLOCK in (CONS (STYLE.PROP STYLESHEET '\DONE.STYLEBLOCK) (STYLE.PROP STYLESHEET '\STYLE.BLOCKS)) do (if (IGREATERP (SETQ THIS.ONE (STYLESHEET.ITEM.HEIGHT BLOCK TITLEFONT)) BIG) then (SETQ BIG THIS.ONE)) finally (RETURN BIG)) (STYLE.PROP STYLESHEET 'TITLE]) (STYLESHEET.IMAGEWIDTH [LAMBDA (STYLESHEET) (* ; "Edited 26-Jan-88 11:50 by Trigg") (* ;;; "returns the width in pixels this entire stylesheet would take up on the screen were it displayed.") (* ;;  "rht 1/26/88: Now grabs Done/Reset/Abort styleblock off of STYLEPROP rather than from globalvar.") (WIDTHIFWINDOW (LET [(BLOCKS (STYLE.PROP STYLESHEET '\STYLE.BLOCKS] (IPLUS (bind (TITLEFONT _ (STYLE.PROP STYLESHEET 'ITEM.TITLE.FONT)) for BLOCK in (CONS (STYLE.PROP STYLESHEET '\DONE.STYLEBLOCK) BLOCKS) sum (STYLESHEET.ITEM.WIDTH BLOCK TITLEFONT)) (ITIMES 2 (LENGTH BLOCKS]) ) (* * Private routines.) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE STYLEBLOCK (TITLE MENU SUBMENU FILL SELECTIONS)) ) (/DECLAREDATATYPE 'STYLEBLOCK '(POINTER POINTER POINTER POINTER POINTER) '((STYLEBLOCK 0 POINTER) (STYLEBLOCK 2 POINTER) (STYLEBLOCK 4 POINTER) (STYLEBLOCK 6 POINTER) (STYLEBLOCK 8 POINTER)) '10) ) (/DECLAREDATATYPE 'STYLEBLOCK '(POINTER POINTER POINTER POINTER POINTER) '((STYLEBLOCK 0 POINTER) (STYLEBLOCK 2 POINTER) (STYLEBLOCK 4 POINTER) (STYLEBLOCK 6 POINTER) (STYLEBLOCK 8 POINTER)) '10) (DEFINEQ (STYLESHEET.CHANGE.FILL [LAMBDA (STYLESHEET NEWFILL BLOCKS) (* hts%: "23-Mar-85 16:22") (* * Modifies the given stylesheet to reflect new menu fill information.  Must be called either when the fill info changes or when the styleblock list  must be rebuilt (since fill info is cached in styleblocks)%.  Note that it calls STYLESHEET.CHANGE.SELECTIONS, since changing the fill to or  from MULTI requires changing the format in which selections are represented.) (* * Fill in defaulted arguments.) [OR NEWFILL (SETQ NEWFILL (STYLE.PROP STYLESHEET 'NEED.NOT.FILL.IN] [OR BLOCKS (SETQ BLOCKS (STYLE.PROP STYLESHEET '\STYLE.BLOCKS] (* * update fill info in styleblocks.) [for BLOCK in BLOCKS as N from 1 do (LET ((FILL (if (LISTP NEWFILL) then (CAR (FNTH NEWFILL N)) else NEWFILL))) (* * Record new fill type. Note if new fill type is just a single atom rather  than a list, that atom applies to all items in the stylesheet.) (replace (STYLEBLOCK FILL) of BLOCK with FILL) (* * Build ALL-CLEAR submenu if necessary%: Menus that need not have any  selections are always equipped with a CLEAR button in the submenu  (not strictly necessary, since pressing a selected item on such a menu will  deselect that item; but it serves as a simple visual aid to the user to tell  him he need not make any selections in this menu);  menus that can have multiple selections are equipped with an ALL button in the  submenu (same reason as for the CLEAR button);  and other menus have no submenu.) (replace (STYLEBLOCK SUBMENU) of BLOCK with (SELECTQ FILL (MULTI (create MENU ITEMS _ '(ALL CLEAR) WHENSELECTEDFN _ (FUNCTION STYLESHEET.CLEAR.WHENSELECTEDFN) MENUUSERDATA _ (fetch (STYLEBLOCK MENU) of BLOCK))) (T (create MENU ITEMS _ '(CLEAR) WHENSELECTEDFN _ (FUNCTION STYLESHEET.CLEAR.WHENSELECTEDFN) MENUUSERDATA _ (fetch (STYLEBLOCK MENU) of BLOCK))) (NIL NIL) (\ILLEGAL.ARG NEWFILL] (* * Build mapping from submenus to styleblocks, which will enable the  WHENSELECTEDFN of the submenu to get hold of the corresponding styleblock to  modify its selections as necessary.) (STYLE.PROP STYLESHEET '\SUBMENU.TO.BLOCK (for BLOCK in BLOCKS bind SUBMENU when (SETQ SUBMENU (fetch (STYLEBLOCK SUBMENU) of BLOCK)) collect (CONS SUBMENU BLOCK))) (* * Change selection format%: MULTI requires a list of selections, T or NIL  require a single selection.) (STYLESHEET.CHANGE.SELECTIONS STYLESHEET NIL BLOCKS]) (STYLESHEET.CHANGE.ITEMS [LAMBDA (STYLESHEET NEWITEMS) (* ; "Edited 26-Jan-88 17:56 by Trigg") (* ;;; "Rebuilds all the styleblocks. Should be called whenever the user changes the items of a stylesheet.") (* ;; "rht 1/26/88: Now computes Done/Reset/Abort styleblock here and stashes on STYLEPROP rather than using globalvar.") (LET [(BLOCKS (for MENU in NEWITEMS collect (create STYLEBLOCK MENU _ MENU] (STYLE.PROP STYLESHEET '\STYLE.BLOCKS BLOCKS) [STYLE.PROP STYLESHEET '\DONE.STYLEBLOCK (create STYLEBLOCK MENU _ (create MENU ITEMS _ '(DONE RESET ABORT) WHENSELECTEDFN _ (FUNCTION STYLESHEET.DONE.FN] (* ;; "Build mapping from menus to styleblocks. This will allow the menus' WHENSELECTEDFN to get hold of the appropriate styleblock to change its selection information.") (STYLE.PROP STYLESHEET '\MENU.TO.BLOCK (for BLOCK in BLOCKS collect (CONS (fetch (STYLEBLOCK MENU) of BLOCK) BLOCK))) (* ;;  "Fill in fill info and selections (STYLESHEET.CHANGE.FILL calls STYLESHEET.CHANGE.SELECTIONS)") (STYLESHEET.CHANGE.FILL STYLESHEET NIL BLOCKS) (* ;; "Fill in item titles.") (STYLESHEET.CHANGE.TITLES STYLESHEET NIL BLOCKS]) (STYLESHEET.CHANGE.SELECTIONS [LAMBDA (STYLESHEET NEWSELECTIONS BLOCKS) (* hts%: "22-Mar-85 13:45") (* * Records new default selections in the styleblocks.) (* * Fill in defaulted arguments.) [OR NEWSELECTIONS (SETQ NEWSELECTIONS (STYLE.PROP STYLESHEET 'SELECTIONS] [OR BLOCKS (SETQ BLOCKS (STYLE.PROP STYLESHEET '\STYLE.BLOCKS] (* * Normalize selections and stick them into styleblocks.  Selections must be normalized in two ways%: abbreviations for a menu item must  be replaced by the entire menu item; and items with fill = MULTI should have a  list of selections, but other items should have just a single selection  (or NIL)) (for BLOCK in BLOCKS as N from 1 do (replace (STYLEBLOCK SELECTIONS) of BLOCK with (LET [(MENU (fetch (STYLEBLOCK MENU) of BLOCK)) (SELECTIONS (CAR (FNTH NEWSELECTIONS N] (SELECTQ (fetch (STYLEBLOCK FILL) of BLOCK) (MULTI (SETQ SELECTIONS (MKLIST SELECTIONS)) (for MULTISEL in [LET [(FULL.SELECTIONS (for SUBSEL in SELECTIONS collect (STYLESHEET.MENUITEM SUBSEL MENU] (if (for SUBSEL in FULL.SELECTIONS always SUBSEL) then FULL.SELECTIONS else (LIST (STYLESHEET.MENUITEM SELECTIONS MENU] when MULTISEL collect MULTISEL)) ((T NIL) (STYLESHEET.MENUITEM SELECTIONS MENU)) (SHOULDNT]) (STYLESHEET.CHANGE.TITLES [LAMBDA (STYLESHEET NEWTITLES BLOCKS) (* hts%: "22-Mar-85 13:49") (* * Fills in item titles in styleblocks) (* * FIll in defaulted args.) [OR NEWTITLES (SETQ NEWTITLES (STYLE.PROP STYLESHEET 'ITEM.TITLES] [OR BLOCKS (SETQ BLOCKS (STYLE.PROP STYLESHEET '\STYLE.BLOCKS] (* * Fill in titles in styleblocks. ((CAR  (FNTH xxx)) stuff ensures that if the title list is too short, titles in  leftover styleblocks will be NILLed apropriately.)) (for BLOCK in BLOCKS as N from 1 do (replace (STYLEBLOCK TITLE) of BLOCK with (CAR (FNTH NEWTITLES N]) (STYLESHEET.MENUITEM [LAMBDA (SELECTION MENU) (* hts%: "22-Mar-85 13:50") (* * Finds the full menu item corresponding to the given abbreviation.) (for MENUITEM in (fetch (MENU ITEMS) of MENU) thereis (OR (EQUAL MENUITEM SELECTION) (STREQUAL (MKSTRING MENUITEM) (MKSTRING SELECTION)) (AND (LISTP MENUITEM) (STREQUAL (MKSTRING (CAR MENUITEM)) (MKSTRING SELECTION]) ) (DEFINEQ (STYLESHEET.SETUP [LAMBDA (STYLESHEET) (* hts%: "22-Mar-85 14:05") (* * Changes the WHENSELECTEDFNs of all the menus to be the appropriate one for  stylesheet menus, and returns the old WHENSELECTEDFNs.  Also NILLs the SHADEDITEMS of each menu, since STYLESHEET.SHADE.SELECTIONS  depends on the validity of this field. (ADDMENU should really do it --  submit AR.)) (for BLOCK in (STYLE.PROP STYLESHEET '\STYLE.BLOCKS) collect (LET ((MENU (fetch (STYLEBLOCK MENU) of BLOCK))) (PROG1 (fetch (MENU WHENSELECTEDFN) of MENU) (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION STYLESHEET.WHENSELECTEDFN)) (replace (MENU SHADEDITEMS) of MENU with NIL]) (STYLESHEET.WAIT.TILL.DONE [LAMBDA (W STYLESHEET) (* hts%: "21-Mar-85 18:39") (* * Wait until the user has filled everything in he needs to, and has hit the  DONE button.) (* * make sure there is a mouse process running.) (SPAWN.MOUSE) (bind QUIT.TYPE do (* * keep the window on top to bring the users attention to it and to keep it  from being covered.) (TOTOPW W) (WINDOWPROP W 'HOW NIL) (WINDOWPROP W 'DONE (CREATE.EVENT 'DONE)) (AWAIT.EVENT (WINDOWPROP W 'DONE) 1000) repeatuntil (if (SETQ QUIT.TYPE (WINDOWPROP W 'HOW)) then (* if not this was a timeout to bring the window back to the top.) [if (EQ QUIT.TYPE 'ABORT) then (* user selected the abort button.) T else (* wait until the user hits the "done" button AND all menus have been selected  from.) (for BLOCK in (STYLE.PROP STYLESHEET '\STYLE.BLOCKS) always (OR (fetch (STYLEBLOCK FILL) of BLOCK) (fetch (STYLEBLOCK SELECTIONS) of BLOCK] else NIL]) (STYLESHEET.GET.SELECTIONS [LAMBDA (STYLESHEET) (* hts%: "22-Mar-85 14:09") (* * Gathers up the selections the user made, and records them as the new  default selections for the stylesheet, so that if it is reused  (and the default selections are not changed in between)%, the user will see his  last selections.) (LET [(SELECTIONS (for BLOCK in (STYLE.PROP STYLESHEET '\STYLE.BLOCKS) collect (LET ((SEL (fetch (STYLEBLOCK SELECTIONS) of BLOCK))) (SELECTQ (fetch (STYLEBLOCK FILL) of BLOCK) (MULTI (for SUBSEL in SEL collect (if (AND (LISTP SUBSEL) (LISTP (CDR SUBSEL))) then (CADR SUBSEL) else SUBSEL))) ((T NIL) (if (AND (LISTP SEL) (LISTP (CDR SEL))) then (CADR SEL) else SEL)) (SHOULDNT] (STYLE.PROP STYLESHEET 'SELECTIONS SELECTIONS) SELECTIONS]) (STYLESHEET.CLEANUP [LAMBDA (W STYLESHEET OLD.WHENSELECTEDFNS) (* hts%: "22-Mar-85 14:10") (* * cleans up the WHENSELECTEDFNs in a stylesheet.  And closes its window.) (for I in (STYLE.PROP STYLESHEET 'ITEMS) as W in OLD.WHENSELECTEDFNS do (* * Restore the old WHENSELECTEDFNs and MENUUSERDATAs.) (replace WHENSELECTEDFN of I with W)) (* * Get rid of the stylesheet window) (CLOSEW W]) ) (DEFINEQ (STYLESHEET.WHENSELECTEDFN [LAMBDA (ELEMENT MENU BUTTON) (* hts%: "22-Mar-85 14:11") (* * Special whenselectedfn for menus inside stylesheets.  Permanently shades the selected item and records the new selection.) (LET* ([BLOCK (CDR (FASSOC MENU (STYLE.PROP (WINDOWPROP (WFROMMENU MENU) 'STYLESHEET) '\MENU.TO.BLOCK] (SELECTIONS (fetch (STYLEBLOCK SELECTIONS) of BLOCK))) (* * Modify recorded selections.) (replace (STYLEBLOCK SELECTIONS) of BLOCK with (SELECTQ (fetch (STYLEBLOCK FILL) of BLOCK) (T (* * Can have 0 or 1 selection. If selected same one twice, undo the selection,  else change selection.) (if (EQ ELEMENT SELECTIONS) then NIL else ELEMENT)) (MULTI (* * Can have any number of selection. If made same selection twice, remove it;  else add it to the list of selections so far.) (if (FMEMB ELEMENT SELECTIONS) then (REMOVE ELEMENT SELECTIONS) else (CONS ELEMENT SELECTIONS))) (NIL (* * Must have exactly one selection. Change the current selection.) ELEMENT) (SHOULDNT))) (* * Display new selections.) (STYLESHEET.SHADE.SELECTIONS BLOCK]) (STYLESHEET.CLEAR.WHENSELECTEDFN [LAMBDA (ELEMENT CLEAR.MENU BUTTON) (* hts%: "22-Mar-85 14:14") (* * WHENSELECTEDFN for the ALL-CLEAR submenus.  Finds the styleblock corresponding to this submenu.  If the user punched CLEAR, deselects all items in that styleblock's menu;  if the user punched ALL, selects all the items in the menu.  Changes shading to reflect new selections.) (LET [(BLOCK (CDR (FASSOC CLEAR.MENU (STYLE.PROP (WINDOWPROP (WFROMMENU CLEAR.MENU) 'STYLESHEET) '\SUBMENU.TO.BLOCK] (replace (STYLEBLOCK SELECTIONS) of BLOCK with (SELECTQ ELEMENT (CLEAR NIL) (ALL (for MENUITEM in (fetch (MENU ITEMS) of (fetch (STYLEBLOCK MENU) of BLOCK)) collect MENUITEM)) NIL)) (STYLESHEET.SHADE.SELECTIONS BLOCK]) (STYLESHEET.DONE.FN [LAMBDA (ITEM M BUTTON) (* hts%: "21-Mar-85 16:39") (* * WHENSELECTEDFN for the DONE-ABORT-RESET menu.) (LET ((W (WFROMMENU M))) (SELECTQ ITEM ((DONE ABORT) (* * Done selecting from this stylesheet.  Notify calling process.) (WINDOWPROP W 'HOW ITEM) (NOTIFY.EVENT (WINDOWPROP W 'DONE))) (RESET (LET [(STYLESHEET (WINDOWPROP W 'STYLESHEET] (* * Restore the original selections.) (STYLE.PROP STYLESHEET 'SELECTIONS (STYLE.PROP STYLESHEET 'SELECTIONS)) (* * Shade the original selections.) (for BLOCK in (STYLE.PROP STYLESHEET '\STYLE.BLOCKS) do (STYLESHEET.SHADE.SELECTIONS BLOCK)))) NIL]) ) (DEFINEQ (STYLESHEET.ITEM.HEIGHT [LAMBDA (BLOCK TITLEFONT) (* hts%: "20-Mar-85 19:50") (* * Returns the height in pixels the given block would occupy in a stylesheet.) (PLUS (if (fetch (STYLEBLOCK TITLE) of BLOCK) then (PLUS 2 (FONTHEIGHT TITLEFONT)) else 0) (fetch (MENU IMAGEHEIGHT) of (fetch (STYLEBLOCK MENU) of BLOCK)) (LET ((SUBMENU (fetch (STYLEBLOCK SUBMENU) of BLOCK))) (if SUBMENU then (PLUS 2 (fetch (MENU IMAGEHEIGHT) of SUBMENU)) else 0]) (STYLESHEET.ITEM.WIDTH [LAMBDA (BLOCK TITLEFONT) (* hts%: "20-Mar-85 19:59") (* * returns the width in piexels that the given block would occupy were it  printed in a stylesheet.) (MAX (LET ((TITLE (fetch (STYLEBLOCK TITLE) of BLOCK))) (if TITLE then (STRINGWIDTH TITLE TITLEFONT) else 0)) (fetch (MENU IMAGEWIDTH) of (fetch (STYLEBLOCK MENU) of BLOCK)) (LET ((SUBMENU (fetch (STYLEBLOCK SUBMENU) of BLOCK))) (if SUBMENU then (fetch (MENU IMAGEWIDTH) of SUBMENU) else 0]) ) (DEFINEQ (STYLESHEET.CREATE.WINDOW [LAMBDA (STYLESHEET) (* hts%: "22-Mar-85 14:18") (* * Lay out stylesheet window of appropriate size and fill it in.) (LET ((POS (STYLE.PROP STYLESHEET 'POSITION)) (TITLE (STYLE.PROP STYLESHEET 'TITLE)) (HEIGHT (STYLESHEET.IMAGEHEIGHT STYLESHEET)) (WIDTH (STYLESHEET.IMAGEWIDTH STYLESHEET))) (* * If position for stylesheet is not provided, prompt for it.) (if (NULL POS) then (SETQ POS (GETBOXPOSITION WIDTH HEIGHT))) (* * Ensure that stylesheet is on the screen.) [replace XCOORD of POS with (MAX 1 (MIN (fetch XCOORD of POS) (IDIFFERENCE SCREENWIDTH WIDTH] [replace YCOORD of POS with (MAX 1 (MIN (fetch YCOORD of POS) (IDIFFERENCE SCREENHEIGHT HEIGHT] (* * Lay out a window big enough to fit all the items.) (LET ((W (CREATEW (CREATEREGION (fetch XCOORD of POS) (fetch YCOORD of POS) WIDTH HEIGHT) TITLE))) (* * Save the stylesheet on its window, where it can be accessed by the  WHENSELECTEDFNS etc. running in a different process.) (WINDOWPROP W 'STYLESHEET STYLESHEET) (* * Give the window a REPAINTFN so it can be redisplayed properly.) (WINDOWPROP W 'REPAINTFN (FUNCTION STYLESHEET.FILL.IN.WINDOW)) (* * Fill in the window.) (REDISPLAYW W) W]) (STYLESHEET.FILL.IN.WINDOW [LAMBDA (W) (* ; "Edited 26-Jan-88 17:56 by Trigg") (* ;;; "Put items into stylesheet and shade default menu selections.") (* ;;  "rht 1/26/88: Now gets Done/Reset/Abort styleblock off of STYLEPROP rather than using globalvar.") (for M in (WINDOWPROP W 'MENU) do (DELETEMENU M NIL W)) (LET [(STYLESHEET (WINDOWPROP W 'STYLESHEET] (bind (TITLEFONT _ (STYLE.PROP STYLESHEET 'ITEM.TITLE.FONT)) (HEIGHT _ (WINDOWPROP W 'HEIGHT)) (XOFFSET _ 0) WIDTH for BLOCK in [APPEND (STYLE.PROP STYLESHEET '\STYLE.BLOCKS) (LIST (STYLE.PROP STYLESHEET '\DONE.STYLEBLOCK] do (SETQ WIDTH (STYLESHEET.ITEM.WIDTH BLOCK TITLEFONT)) (STYLESHEET.ADD.MENU BLOCK W XOFFSET HEIGHT WIDTH TITLEFONT) (SETQ XOFFSET (PLUS XOFFSET WIDTH 2]) (STYLESHEET.ADD.MENU [LAMBDA (BLOCK W XOFFSET HEIGHT WIDTH TITLEFONT) (* hts%: "22-Mar-85 14:24") (* * Adds the current styleblock (title, menu, and submenu) to the stylesheet.  XOFFSET determines the placement of left boundary of the styleblock.  HEIGHT and WIDTH bound the styleblock above and to the right.  Centers the pieces of the styleblock within this box.) (LET ((TOP HEIGHT)) (* * Title stuff) [LET ((TITLE (fetch (STYLEBLOCK TITLE) of BLOCK))) (if TITLE then (MOVETO (IPLUS XOFFSET (IQUOTIENT (DIFFERENCE WIDTH (STRINGWIDTH TITLE TITLEFONT)) 2)) [DIFFERENCE TOP (DIFFERENCE (FONTPROP TITLEFONT 'HEIGHT) (FONTPROP TITLEFONT 'DESCENT] W) (printout W .FONT TITLEFONT TITLE) (SETQ TOP (DIFFERENCE TOP (PLUS (FONTHEIGHT TITLEFONT) 2] (* * Stick the menu on the stylesheet window.) [LET ((MENU (fetch (STYLEBLOCK MENU) of BLOCK))) [ADDMENU MENU W (create POSITION XCOORD _ (IPLUS XOFFSET (IQUOTIENT (DIFFERENCE WIDTH (fetch (MENU IMAGEWIDTH) of MENU)) 2)) YCOORD _ (IDIFFERENCE TOP (fetch IMAGEHEIGHT of MENU] (SETQ TOP (DIFFERENCE TOP (PLUS (fetch IMAGEHEIGHT of MENU) 2] (* * Shade in selections.) (STYLESHEET.SHADE.SELECTIONS BLOCK) (* * Add clear/all menu at bottom of this item.) [LET ((SUBMENU (fetch (STYLEBLOCK SUBMENU) of BLOCK))) (if SUBMENU then (ADDMENU SUBMENU W (create POSITION XCOORD _ (IPLUS XOFFSET (IQUOTIENT (DIFFERENCE WIDTH (fetch (MENU IMAGEWIDTH) of SUBMENU)) 2)) YCOORD _ (IDIFFERENCE TOP (fetch IMAGEHEIGHT of SUBMENU] NIL]) (STYLESHEET.SHADE.SELECTIONS [LAMBDA (BLOCK) (* hts%: "22-Mar-85 14:26") (* * Updates the selections shaded on the screen to reflect those recorded  internally for the specified Makes use of the SHADEDITEMS field of the menu to  tell what has already been shaded. Format of SHADEDITEMS is an alist mapping  the number of the menu item onto its shade.) (LET* ((MENU (fetch (STYLEBLOCK MENU) of BLOCK)) (SHADEDITEMS (fetch (MENU SHADEDITEMS) of MENU)) (SELECTIONS (fetch (STYLEBLOCK SELECTIONS) of BLOCK))) (if (NEQ (fetch (STYLEBLOCK FILL) of BLOCK) 'MULTI) then (SETQ SELECTIONS (LIST SELECTIONS))) (for MENUITEM in (fetch (MENU ITEMS) of MENU) as ITEMNUMBER from 1 do (LET* [(SELECTED (FMEMB MENUITEM SELECTIONS)) (SHADENTRY (FASSOC ITEMNUMBER SHADEDITEMS)) (SHADED (AND (LISTP SHADENTRY) (NEQ (CDR SHADENTRY) 0] (if (AND SHADED (NOT SELECTED)) then (SHADEITEM MENUITEM MENU WHITESHADE) elseif (AND SELECTED (NOT SHADED)) then (SHADEITEM MENUITEM MENU STYLESHEET.SELECTED.SHADE]) ) (DEFINEQ (STYLESHEET.AT.LOAD [LAMBDA NIL (* ; "Edited 26-Jan-88 11:51 by Trigg") (* ;;; "Sets up global variables for the stylesheet package.") (* ;; "rht 1/26/88: No longer computes STYLESHEET.DONE.MENU globalvar here. It gets computed each time STYLESHEET is called. ") (SETQ STYLESHEET.SELECTED.SHADE BLACKSHADE]) ) (STYLESHEET.AT.LOAD) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS STYLESHEET.SELECTED.SHADE) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA STYLE.PROP CREATE.STYLE) ) (PUTPROPS STYLESHEET COPYRIGHT ("Xerox Corporation" 1983 1985 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2524 9062 (CREATE.STYLE 2534 . 3185) (STYLESHEETP 3187 . 3521) (STYLE.PROP 3523 . 5467) (STYLESHEET 5469 . 7168) (STYLESHEET.IMAGEHEIGHT 7170 . 8133) (STYLESHEET.IMAGEWIDTH 8135 . 9060)) ( 10225 19271 (STYLESHEET.CHANGE.FILL 10235 . 13800) (STYLESHEET.CHANGE.ITEMS 13802 . 15786) ( STYLESHEET.CHANGE.SELECTIONS 15788 . 17876) (STYLESHEET.CHANGE.TITLES 17878 . 18681) ( STYLESHEET.MENUITEM 18683 . 19269)) (19272 23908 (STYLESHEET.SETUP 19282 . 20280) ( STYLESHEET.WAIT.TILL.DONE 20282 . 21940) (STYLESHEET.GET.SELECTIONS 21942 . 23359) (STYLESHEET.CLEANUP 23361 . 23906)) (23909 27835 (STYLESHEET.WHENSELECTEDFN 23919 . 25706) ( STYLESHEET.CLEAR.WHENSELECTEDFN 25708 . 26859) (STYLESHEET.DONE.FN 26861 . 27833)) (27836 29270 ( STYLESHEET.ITEM.HEIGHT 27846 . 28526) (STYLESHEET.ITEM.WIDTH 28528 . 29268)) (29271 36824 ( STYLESHEET.CREATE.WINDOW 29281 . 31120) (STYLESHEET.FILL.IN.WINDOW 31122 . 32153) (STYLESHEET.ADD.MENU 32155 . 35318) (STYLESHEET.SHADE.SELECTIONS 35320 . 36822)) (36825 37242 (STYLESHEET.AT.LOAD 36835 . 37240))))) STOP \ No newline at end of file diff --git a/lispusers/STYLESHEET.TEDIT b/lispusers/STYLESHEET.TEDIT new file mode 100644 index 00000000..27e55113 Binary files /dev/null and b/lispusers/STYLESHEET.TEDIT differ diff --git a/lispusers/SUPERPARENTHESES b/lispusers/SUPERPARENTHESES new file mode 100644 index 00000000..42efc8ca --- /dev/null +++ b/lispusers/SUPERPARENTHESES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL") (il:filecreated "19-Oct-87 19:12:18" il:{phylum}lisp>superparentheses.\;8 3991 il:|changes| il:|to:| (il:vars il:superparenthesescoms) il:|previous| il:|date:| "27-Aug-87 17:45:28" il:{phylum}lisp>superparentheses.\;7) ; Copyright (c) 1987 by Andrew J Cameron, III and Xerox Corporation. All rights reserved. (il:prettycomprint il:superparenthesescoms) (il:rpaqq il:superparenthesescoms ( (il:* il:|;;;| " This file provides CommonLisp with SUPERPARENTHESES") (il:* il:|;;| " This is done by simply copying the SyntaxClass of [ (LEFTBRACKET) and ] (RIGHTBRACKET) from the original InterLisp readtable to a copy of the CommonLisp readtable which becomes named LISP[].") (il:* il:|;;| "This new readtable can be accessed via: (IL:FIND-READTABLE \"LISP[]\")") (il:* il:|;;|  "The original CommonLisp readtable can be re-obtained via: (setq *readtable* (copy-readtable nil))") (il:* il:|;;| "Thanks to Bill VanMelle for suggestions and simplifications.") (il:prop il:makefile-environment il:superparentheses) (il:p (let ((rdtbl (copy-readtable nil))) (il:* il:|;;| "Copy the original readtable") (il:* il:|;;| "Transfer the charMacro definition of [ and ]") (set-syntax-from-char #\[ #\[ rdtbl 'il:orig) (set-syntax-from-char #\] #\] rdtbl 'il:orig) (il:* il:|;;| "give the readtable a printname") (il:readtableprop rdtbl 'il:name "LISP[]") (il:* il:|;;| "Would actually like it to become the readtable of the primary EXEC window, but this may not be what the used expects.") (il:* il:|;;| "(setq *readtable* (IL:FIND-READTABLE \"LISP[]\"))") )))) (il:* il:|;;;| " This file provides CommonLisp with SUPERPARENTHESES") (il:* il:|;;| " This is done by simply copying the SyntaxClass of [ (LEFTBRACKET) and ] (RIGHTBRACKET) from the original InterLisp readtable to a copy of the CommonLisp readtable which becomes named LISP[]." ) (il:* il:|;;| "This new readtable can be accessed via: (IL:FIND-READTABLE \"LISP[]\")") (il:* il:|;;| "The original CommonLisp readtable can be re-obtained via: (setq *readtable* (copy-readtable nil))") (il:* il:|;;| "Thanks to Bill VanMelle for suggestions and simplifications.") (il:putprops il:superparentheses il:makefile-environment (:package "XCL-USER" :readtable "XCL")) (let ((rdtbl (copy-readtable nil))) (il:* il:|;;| "Copy the original readtable") (il:* il:|;;| "Transfer the charMacro definition of [ and ]") (set-syntax-from-char #\[ #\[ rdtbl 'il:orig) (set-syntax-from-char #\] #\] rdtbl 'il:orig) (il:* il:|;;| "give the readtable a printname") (il:readtableprop rdtbl 'il:name "LISP[]") (il:* il:|;;| "Would actually like it to become the readtable of the primary EXEC window, but this may not be what the used expects.") (il:* il:|;;| "(setq *readtable* (IL:FIND-READTABLE \"LISP[]\"))") ) (il:putprops il:superparentheses il:copyright ("Andrew J Cameron, III and Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/SUPERPARENTHESES.TEDIT b/lispusers/SUPERPARENTHESES.TEDIT new file mode 100644 index 00000000..13243b56 Binary files /dev/null and b/lispusers/SUPERPARENTHESES.TEDIT differ diff --git a/lispusers/SYSTATS b/lispusers/SYSTATS new file mode 100644 index 00000000..d15e3bfe --- /dev/null +++ b/lispusers/SYSTATS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "30-Oct-87 01:18:07" "{FireFS:CS:Univ Rochester}LispUsers>Lyric>SYSTATS.;1" 7592 changes to%: (VARS SYSTATSCOMS) (MACROS \SYSTATSREADBODY \MKSYSTATSBODY \NEWSYSTATSBODY \SYSTATSPROPBODY \SYSTATSDIFFBODY) (FNS \LOADFIXP \LOADFIXP2 SYSTATSDIFF \NEWSYSTATS \MKSYSTATS SYSTATSREAD SYSTATSPROP) (RECORDS SYSTATS) (PROPS (SYSTATS MAKEFILE-ENVIRONMENT)) previous date%: "29-Oct-87 15:16:18" {DSK}SYSTATS.;1) (* " Copyright (c) 1987 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT SYSTATSCOMS) (RPAQQ SYSTATSCOMS ((* ;; "Implementation") (DECLARE%: (LOCALVARS . T)) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (COMS (FILES (SOURCE FROM LISPUSERS) SYSEDIT) (P (SETQ SYSTATSPROPS (SORT (CONS (QUOTE ELAPSEDTIME) (INTERSECTION (RECORDFIELDNAMES (QUOTE MISCSTATS)) (QUOTE (DISKIOTIME DISKOPS GCTIME KEYBOARDWAITTIME NETIOOPS NETIOTIME PAGEFAULTS STARTTIME SWAPWAITTIME SWAPWRITES TOTALTIME)))))) (EVAL (BQUOTE (DATATYPE SYSTATS (\, SYSTATSPROPS) (CREATE (\NEWSYSTATS)))))))) (DECLARE%: DONTCOPY (COMS (RECORDS SYSTATS) (MACROS \SYSTATSPROPBODY \SYSTATSREADBODY \SYSTATSDIFFBODY \MKSYSTATSBODY \NEWSYSTATSBODY) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) SYSTATS))) (INITRECORDS SYSTATS) (INITVARS (\SYSTATS NIL)) (FNS \NEWSYSTATS \MKSYSTATS \LOADFIXP \LOADFIXP2) (* ;; "Interface") (VARS SYSTATSPROPS) (FNS SYSTATSREAD SYSTATSDIFF SYSTATSPROP CLOCKTICKS)) ) (* ;; "Implementation") (DECLARE%: (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILESLOAD (SOURCE FROM LISPUSERS) SYSEDIT) (SETQ SYSTATSPROPS (SORT (CONS (QUOTE ELAPSEDTIME) (INTERSECTION (RECORDFIELDNAMES (QUOTE MISCSTATS)) (QUOTE (DISKIOTIME DISKOPS GCTIME KEYBOARDWAITTIME NETIOOPS NETIOTIME PAGEFAULTS STARTTIME SWAPWAITTIME SWAPWRITES TOTALTIME)))))) (EVAL (BQUOTE (DATATYPE SYSTATS (\, SYSTATSPROPS) (CREATE (\NEWSYSTATS))))) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE SYSTATS (DISKIOTIME DISKOPS ELAPSEDTIME GCTIME KEYBOARDWAITTIME NETIOOPS NETIOTIME PAGEFAULTS STARTTIME SWAPWAITTIME SWAPWRITES TOTALTIME) (CREATE (\NEWSYSTATS))) ) (/DECLAREDATATYPE (QUOTE SYSTATS) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((SYSTATS 0 POINTER) (SYSTATS 2 POINTER) (SYSTATS 4 POINTER) (SYSTATS 6 POINTER) (SYSTATS 8 POINTER) (SYSTATS 10 POINTER) (SYSTATS 12 POINTER) (SYSTATS 14 POINTER) (SYSTATS 16 POINTER) (SYSTATS 18 POINTER) (SYSTATS 20 POINTER) (SYSTATS 22 POINTER))) (QUOTE 24)) (DECLARE%: EVAL@COMPILE (PUTPROPS \SYSTATSPROPBODY MACRO (NOARGS (BQUOTE (SELECTQ PROP (\,@ (for P in SYSTATSPROPS unless (EQ P (QUOTE ELAPSEDTIME)) collect (BQUOTE ((\, P) (ffetch (SYSTATS (\, P)) of FROMSYSTATS))))) (ERROR "Unsupported SYSTATS property:" PROP))))) (PUTPROPS \SYSTATSREADBODY MACRO (NOARGS (BQUOTE (PROGN (\,@ (for P in SYSTATSPROPS collect (BQUOTE (\LOADFIXP2 (ffetch (SYSTATS (\, P)) of INTOSYSTATS) (ffetch (SYSTATS (\, P)) of FROMSYSTATS))))))))) (PUTPROPS \SYSTATSDIFFBODY MACRO (NOARGS (BQUOTE (PROGN (\,@ (for P in SYSTATSPROPS collect (BQUOTE (\LOADFIXP (ffetch (SYSTATS (\, P)) of DIFSYSTATS) (IDIFFERENCE (ffetch (SYSTATS (\, P)) of NEWSYSTATS) (ffetch (SYSTATS (\, P)) of OLDSYSTATS)))))))))) (PUTPROPS \MKSYSTATSBODY MACRO (NOARGS (BQUOTE (PROG NIL (DECLARE (GLOBALVARS \MISCSTATS \SYSTATS)) (if (NOT NOCLOCKFLG) then (\LOADFIXP2 (ffetch (SYSTATS ELAPSEDTIME) of \SYSTATS) (CLOCK0 \SYSTATSCLOCK0))) (\,@ (for P in SYSTATSPROPS unless (EQ P (QUOTE ELAPSEDTIME)) collect (BQUOTE (\LOADFIXP2 (ffetch (SYSTATS (\, P)) of \SYSTATS) (LOCF (ffetch (MISCSTATS (\, P)) of \MISCSTATS)))))))))) (PUTPROPS \NEWSYSTATSBODY MACRO (NOARGS (BQUOTE (PROG ((STATS (NCREATE (QUOTE SYSTATS)))) (\,@ (for P in SYSTATSPROPS collect (BQUOTE (freplace (SYSTATS (\, P)) of STATS with (create FIXP))))) (RETURN STATS))))) ) (PUTPROPS SYSTATS FILETYPE :TCOMPL) (PUTPROPS SYSTATS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) ) (/DECLAREDATATYPE (QUOTE SYSTATS) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((SYSTATS 0 POINTER) (SYSTATS 2 POINTER) (SYSTATS 4 POINTER) (SYSTATS 6 POINTER) (SYSTATS 8 POINTER) (SYSTATS 10 POINTER) (SYSTATS 12 POINTER) (SYSTATS 14 POINTER) (SYSTATS 16 POINTER) (SYSTATS 18 POINTER) (SYSTATS 20 POINTER) (SYSTATS 22 POINTER))) (QUOTE 24)) (RPAQ? \SYSTATS NIL) (DEFINEQ (\NEWSYSTATS (LAMBDA NIL (* ; "Edited 30-Oct-87 00:16 by Koomen") (\NEWSYSTATSBODY))) (\MKSYSTATS (LAMBDA (STATS SYSFLG NOCLOCKFLG) (* ; "Edited 29-Oct-87 22:14 by Koomen") (DECLARE (GLOBALVARS \MISCSTATS \SYSTATS \SYSTATSCLOCK0)) (if STATS then (\DTEST STATS (QUOTE SYSTATS)) elseif (NOT SYSFLG) then (create SYSTATS) else (if (NULL \SYSTATS) then (SETQ \SYSTATS (create SYSTATS)) (SETQ \SYSTATSCLOCK0 (create FIXP)) else (\DTEST \SYSTATS (QUOTE SYSTATS))) (\MKSYSTATSBODY) \SYSTATS)) ) (\LOADFIXP (LAMBDA (DST SRC) (* ; "Edited 30-Oct-87 00:27 by Koomen") (* ;; "DST is assumed to be a FIXP") (* ;; "SRC is assumed to be either a FIXP or a SMALLP") (if (type? FIXP SRC) then (freplace (FIXP HINUM) of DST with (ffetch (FIXP HINUM) of SRC)) (freplace (FIXP LONUM) of DST with (ffetch (FIXP LONUM) of SRC)) elseif (ILESSP SRC 0) then (freplace (FIXP HINUM) of DST with MAX.SMALLP) (freplace (FIXP LONUM) of DST with (ADD1 (IPLUS SRC MAX.SMALLP))) else (freplace (FIXP HINUM) of DST with 0) (freplace (FIXP LONUM) of DST with SRC)) DST) ) (\LOADFIXP2 (LAMBDA (DST SRC) (* ; "Edited 30-Oct-87 00:27 by Koomen") (* ;; "DST and SRC are assumed to be a FIXP") (freplace (FIXP HINUM) of DST with (ffetch (FIXP HINUM) of SRC)) (freplace (FIXP LONUM) of DST with (ffetch (FIXP LONUM) of SRC)) DST) ) ) (* ;; "Interface") (RPAQQ SYSTATSPROPS (DISKIOTIME DISKOPS ELAPSEDTIME GCTIME KEYBOARDWAITTIME NETIOOPS NETIOTIME PAGEFAULTS STARTTIME SWAPWAITTIME SWAPWRITES TOTALTIME) ) (DEFINEQ (SYSTATSREAD (LAMBDA (INTOSTATS FROMSTATS) (* ; "Edited 29-Oct-87 12:52 by Koomen") (PROG ((INTOSYSTATS (\MKSYSTATS INTOSTATS)) (FROMSYSTATS (\MKSYSTATS FROMSTATS T))) (\SYSTATSREADBODY) (RETURN INTOSYSTATS))) ) (SYSTATSDIFF (LAMBDA (OLDSTATS NEWSTATS DIFSTATS) (* ; "Edited 30-Oct-87 00:35 by Koomen") (PROG ((OLDSYSTATS (\MKSYSTATS OLDSTATS T)) (NEWSYSTATS (\MKSYSTATS NEWSTATS T)) (DIFSYSTATS (\MKSYSTATS DIFSTATS))) (\SYSTATSDIFFBODY) (RETURN DIFSYSTATS))) ) (SYSTATSPROP (LAMBDA (PROP FROMSTATS) (* ; "Edited 29-Oct-87 14:51 by Koomen") (if (EQ PROP (QUOTE ELAPSEDTIME)) then (ffetch (SYSTATS ELAPSEDTIME) of (\MKSYSTATS FROMSTATS T)) else (PROG ((FROMSYSTATS (\MKSYSTATS FROMSTATS T T))) (RETURN (\SYSTATSPROPBODY))))) ) (CLOCKTICKS (LAMBDA (interval timerunits) (* Koomen "12-Jan-87 17:22") (DECLARE (GLOBALVARS \RCLKSECOND)) (PROG ((ticks (if (NULL interval) then 1 elseif (NOT (NUMBERP interval)) then (ERROR "Non-numeric arg: " interval) elseif (NOT (GREATERP interval 0)) then (ERROR "Non-positive arg: " interval) else interval))) (SELECTQ (U-CASE timerunits) ((TICK TICKS)) ((MSEC MILLISEC MSECS MILLISECS) (SETQ ticks (FTIMES 0.001 \RCLKSECOND ticks))) ((NIL SEC SECOND SECS SECONDS) (SETQ ticks (TIMES \RCLKSECOND ticks))) ((MIN MINUTE MINS MINUTES) (SETQ ticks (TIMES 60 \RCLKSECOND ticks))) ((HR HOUR HRS HOURS) (SETQ ticks (TIMES 3600 \RCLKSECOND ticks))) (ERROR "unknown timerunits: " timerunits)) (RETURN (if (FLOATP ticks) then (FIX (FPLUS ticks 0.5)) else ticks)))) ) ) (PUTPROPS SYSTATS COPYRIGHT ("Johannes A. G. M. Koomen" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4518 5824 (\NEWSYSTATS 4528 . 4613) (\MKSYSTATS 4615 . 5016) (\LOADFIXP 5018 . 5567) ( \LOADFIXP2 5569 . 5822)) (6002 7506 (SYSTATSREAD 6012 . 6223) (SYSTATSDIFF 6225 . 6475) (SYSTATSPROP 6477 . 6740) (CLOCKTICKS 6742 . 7504))))) STOP \ No newline at end of file diff --git a/lispusers/SYSTATS.TEDIT b/lispusers/SYSTATS.TEDIT new file mode 100644 index 00000000..8c600062 Binary files /dev/null and b/lispusers/SYSTATS.TEDIT differ diff --git a/lispusers/SetStringLength.Tedit b/lispusers/SetStringLength.Tedit new file mode 100644 index 00000000..61ddbd36 Binary files /dev/null and b/lispusers/SetStringLength.Tedit differ diff --git a/lispusers/Standalone-LispUsers-Templ-Instr.TEdit b/lispusers/Standalone-LispUsers-Templ-Instr.TEdit new file mode 100644 index 00000000..e2ae24df Binary files /dev/null and b/lispusers/Standalone-LispUsers-Templ-Instr.TEdit differ diff --git a/lispusers/TALK b/lispusers/TALK new file mode 100644 index 00000000..6e05a53e --- /dev/null +++ b/lispusers/TALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Jul-88 15:43:07" |{MCS:MCS:STANFORD}TALK.;10| 38505 previous date%: "16-Jun-88 09:25:17" |{MCS:MCS:STANFORD}TALK.;9|) (* " Copyright (c) 1987, 1988 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT TALKCOMS) (RPAQQ TALKCOMS ((* TALK client/server code) (LOCALVARS . T) (FNS TALK) (FNS TALK.RECONNECT TALK.PROCESS TALK.DISPLAY TALK.LISTEN TALK.CLOSEFN TALK.ANSWER TALK.ANSWER.WINDOW TALK.ANSWER.USERNAME TALK.GET.NAME TALK.ADD.NAME TALK.FLASH.CARET TALK.WHENSELECTEDFN TALK.RINGBELLS TALK.START.SERVER) (FNS TALK.ICON.BUTTONEVENTFN TALK.ICON.CLOSEFN) (* TALK data) (DECLARE%: DONTCOPY (RECORDS TALK.SERVICETYPE TALK.PROTOCOLTYPE)) (VARS TALK.MENU.ITEMS TALK.USER.MESSAGES) (INITVARS TALK.SERVICETYPES TALK.PROTOCOLTYPES TALK.GAG TALK.HOSTNAMES TALK.ICON.WINDOWS (TALK.ANSWER.WAIT 15) (TALK.READTABLE (COPYREADTABLE 'ORIG)) (TALK.DEFAULT.REGION (CREATEREGION 0 0 500 500)) (TALK.CLOSED.STRING " -- Connection Closed") (TALK.ICON.FONT LITTLEFONT)) (GLOBALVARS TALK.MENU.ITEMS TALK.USER.MESSAGES TALK.SERVICETYPES TALK.PROTOCOLTYPES TALK.GAG TALK.HOSTNAMES TALK.ICON.WINDOWS TALK.ANSWER.WAIT TALK.READTABLE TALK.DEFAULT.REGION TALK.CLOSED.STRING TALK.ICON.FONT) (ALISTS (BackgroundMenuCommands Talk)) (VARS (BackgroundMenu)) (APPENDVARS (BACKGROUNDFNS TALK.START.SERVER) (AFTERMAKESYSFORMS (TALK.START.SERVER NIL T))) (BITMAPS TALK.ICON.BITMAP) (GLOBALVARS TALK.ICON.BITMAP) (P (SETSYNTAX (CHARCODE SPACE) (CHARCODE A) TALK.READTABLE)))) (* TALK client/server code) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (TALK [LAMBDA (USER.OR.HOSTNAME SERVICE PROTOCOL) (* ; "Edited 9-Jun-88 12:32 by cdl") (* DECLARATIONS%: (RECORD RESULT  (SERVICETYPE INPUTSTREAM   . OUTPUTSTREAM))) (PROG (USER PROTOCOLTYPE PROTOCOLTYPES SERVICETYPE SERVICETYPES RESULT ADDRESSABLE?) (if (NULL USER.OR.HOSTNAME) then (if (SETQ USER.OR.HOSTNAME (TALK.GET.NAME)) then (if (LISTP USER.OR.HOSTNAME) then (RETURN (TALK.RECONNECT USER.OR.HOSTNAME))) else (RETURN))) (if SERVICE then (if [SETQ SERVICETYPE (for SERVICETYPE in TALK.SERVICETYPES thereis (with TALK.SERVICETYPE SERVICETYPE (STRING-EQUAL SERVICE TALK.SERVICENAME] then (SETQ SERVICETYPES (LIST SERVICETYPE)) else (RETURN (LIST "Unknown service type!" SERVICE))) else (if (NULL (SETQ SERVICETYPES TALK.SERVICETYPES)) then (RETURN "No services available!"))) (if PROTOCOL then (if (SETQ PROTOCOLTYPE (ASSOC PROTOCOL TALK.PROTOCOLTYPES)) then (SETQ PROTOCOLTYPES (LIST PROTOCOLTYPE)) else (RETURN (LIST "Unknown protocol!" PROTOCOL))) else (if (NULL (SETQ PROTOCOLTYPES TALK.PROTOCOLTYPES)) then (RETURN "No protocols available!"))) (if [SETQ PROTOCOLTYPE (bind ADDRESS for PROTOCOLTYPE in PROTOCOLTYPES when (with TALK.PROTOCOLTYPE PROTOCOLTYPE (SETQ ADDRESS (APPLY* TALK.HOSTNAMEFN USER.OR.HOSTNAME))) thereis (PROGN (TALK.ADD.NAME USER.OR.HOSTNAME ADDRESS (with TALK.PROTOCOLTYPE PROTOCOLTYPE TALK.PROTOCOLNAME)) (SETQ ADDRESSABLE? T) (SELECTQ (SETQ RESULT (with TALK.PROTOCOLTYPE PROTOCOLTYPE (APPLY* TALK.CONNECTFN ADDRESS SERVICETYPES))) (ANSWER (RETURN)) (LISTP RESULT] then (with RESULT RESULT (RETURN (TALK.PROCESS INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE 'CLIENT USER.OR.HOSTNAME T))) else (RETURN (if ADDRESSABLE? then (SELECTQ RESULT (ANSWER "No answer from TALK service!") (LIST "Can't connect to host!" USER.OR.HOSTNAME)) else (LIST "Host not found!" USER.OR.HOSTNAME]) ) (DEFINEQ (TALK.RECONNECT [LAMBDA (DESTINATION) (* ; "Edited 10-Jun-88 14:59 by cdl") (* DECLARATIONS%: (RECORD RESULT  (SERVICETYPE INPUTSTREAM   . OUTPUTSTREAM))  (RECORD DESTINATION  (NAME . ENTRIES)) (RECORD ENTRY  (PROTOCOL . ADDRESS))) (DECLARE (SPECVARS DESTINATION)) (if TALK.SERVICETYPES then [LET (PROTOCOLTYPE RESULT ENTRY ADDRESS) (* try all the protocols but prefer  those that have already succeeded) (if [SETQ PROTOCOLTYPE (for PROTOCOLTYPE in [SORT (APPEND TALK.PROTOCOLTYPES) (FUNCTION (LAMBDA (PROTOCOLTYPE) (* DECLARATIONS%: (RECORD  DESTINATION (NAME . ENTRIES))) (with TALK.PROTOCOLTYPE PROTOCOLTYPE (with DESTINATION DESTINATION (ASSOC TALK.PROTOCOLNAME ENTRIES] when [with TALK.PROTOCOLTYPE PROTOCOLTYPE (AND [SETQ ADDRESS (with DESTINATION DESTINATION (if (SETQ ENTRY (ASSOC TALK.PROTOCOLNAME ENTRIES)) then (with ENTRY ENTRY ADDRESS) else (APPLY* TALK.HOSTNAMEFN NAME] (SETQ RESULT (APPLY* TALK.CONNECTFN ADDRESS TALK.SERVICETYPES] thereis (SELECTQ RESULT (ANSWER (RETURN)) (LISTP RESULT] then (with RESULT RESULT (TALK.PROCESS INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE 'CLIENT (with DESTINATION DESTINATION NAME) T)) else (SELECTQ RESULT (ANSWER "No answer from TALK service!") (LIST "Can't connect to host!" (with DESTINATION DESTINATION NAME] else "No services available!"]) (TALK.PROCESS [LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE MODE USER SPAWN?) (* ; "Edited 9-Jun-88 12:35 by cdl") (if (LITATOM SERVICETYPE) then (SETQ SERVICETYPE (ASSOC SERVICETYPE TALK.SERVICETYPES))) (if (LITATOM PROTOCOLTYPE) then (SETQ PROTOCOLTYPE (ASSOC PROTOCOLTYPE TALK.PROTOCOLTYPES))) (LET ((DISPLAYSTREAM (TALK.DISPLAY INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE MODE USER))) (if SPAWN? then [ADD.PROCESS `(TALK.LISTEN ,INPUTSTREAM ,OUTPUTSTREAM ,(KWOTE SERVICETYPE) ,(KWOTE PROTOCOLTYPE) ,DISPLAYSTREAM] else (TALK.LISTEN INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE DISPLAYSTREAM]) (TALK.DISPLAY [LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE MODE USER) (* ; "Edited 9-Jun-88 14:46 by cdl") (* DECLARATIONS%: (ASSOCRECORD  MESSAGES (GREETING))) (LET (MAINWINDOW WINDOW REGION GREETING) (DECLARE (SPECVARS GREETING)) (SETQ USER (with TALK.PROTOCOLTYPE PROTOCOLTYPE (APPLY* TALK.USERNAMEFN INPUTSTREAM OUTPUTSTREAM SERVICETYPE MODE USER))) (with REGION (SETQ REGION (if (REGIONP TALK.DEFAULT.REGION) then (with REGION TALK.DEFAULT.REGION (GETBOXREGION WIDTH HEIGHT)) else (GETREGION))) (SETQ HEIGHT (QUOTIENT HEIGHT 2))) (SETQ MAINWINDOW (CREATEW (with REGION REGION (create REGION BOTTOM _ (PLUS BOTTOM HEIGHT) using REGION)) (PACK* "TALK (" (with TALK.SERVICETYPE SERVICETYPE TALK.SERVICENAME) ")"))) (SETQ WINDOW (CREATEW REGION (CONCAT "(" (with TALK.PROTOCOLTYPE PROTOCOLTYPE TALK.PROTOCOLNAME) ") Talk from " USER))) (WINDOWPROP MAINWINDOW 'STREAMS (CONS INPUTSTREAM OUTPUTSTREAM)) (WINDOWADDPROP MAINWINDOW 'CLOSEFN (FUNCTION TALK.CLOSEFN)) (ATTACHWINDOW WINDOW MAINWINDOW 'BOTTOM) (ATTACHMENU (create MENU ITEMS _ TALK.MENU.ITEMS CENTERFLG _ T MENUBORDERSIZE _ 1 WHENSELECTEDFN _ (FUNCTION TALK.WHENSELECTEDFN)) WINDOW 'BOTTOM) (with TALK.SERVICETYPE SERVICETYPE (APPLY* TALK.DISPLAYFN MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOLTYPE USER)) (if (AND (SETQ GREETING (CAR (with MESSAGES TALK.USER.MESSAGES GREETING))) (SETQ GREETING (ERRORSET GREETING))) then (BKSYSBUF (CAR GREETING))) WINDOW]) (TALK.LISTEN [LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE PROTOCOLTYPE WINDOW) (* ; "Edited 7-Jun-88 08:42 by cdl") (PROG (ICON? (MAINWINDOW (MAINWINDOW WINDOW))) (with TALK.SERVICETYPE SERVICETYPE (APPLY* TALK.LISTENFN MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOLTYPE)) (TTY.PROCESS T) (CLOSEF? INPUTSTREAM) (if [OR (OPENWP WINDOW) (for PROP in '(ICON ICONWINDOW) thereis (SETQ ICON? (OPENWP (WINDOWPROP MAINWINDOW PROP] then (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) TALK.CLOSED.STRING)) (for WINDOW in (ATTACHEDWINDOWS WINDOW) when (WINDOWPROP WINDOW 'MENU) do (if (DETACHWINDOW WINDOW) then (CLOSEW WINDOW))) (if ICON? then (SHRINKW MAINWINDOW) else (FLASHWINDOW WINDOW]) (TALK.CLOSEFN [LAMBDA (WINDOW) (* ; "Edited 9-Jun-88 14:45 by cdl") (* DECLARATIONS%: (RECORD STREAMS  (INPUTSTREAM . OUTPUTSTREAM))) (LET ((STREAMS (WINDOWPROP WINDOW 'STREAMS NIL))) (if STREAMS then (with STREAMS STREAMS (CLOSEF? INPUTSTREAM) (CLOSEF? OUTPUTSTREAM]) (TALK.ANSWER [LAMBDA (USER SERVICE PROTOCOL ADDRESS) (* ; "Edited 9-Jun-88 09:20 by cdl") (LET [WINDOW REGION (EVENT (CREATE.EVENT)) (TIME (DATE '(DATEFORMAT NO.SECONDS] (DECLARE (GLOBALVARS \IDLING)) (PROGN (* Only really necessary if you're  talking to yourself) (SPAWN.MOUSE)) (WINDOWPROP (SETQ WINDOW (TALK.ANSWER.WINDOW USER)) 'EVENT EVENT) (BITBLT TALK.ICON.BITMAP NIL NIL WINDOW) [SETQ REGION (with REGION (DSPCLIPPINGREGION NIL WINDOW) (CREATEREGION LEFT BOTTOM WIDTH (QUOTIENT HEIGHT 3] (CENTERPRINTINREGION (CONCAT SERVICE "(" PROTOCOL ")") (with REGION REGION (CREATEREGION LEFT BOTTOM WIDTH (DIFFERENCE HEIGHT 7))) WINDOW) (DSPFONT (PROG1 (DSPFONT TALK.ICON.FONT WINDOW) (CENTERPRINTINREGION (CONCAT (SUBSTRING TIME 1 6) (SUBSTRING TIME 10 -1)) (with REGION REGION (add BOTTOM HEIGHT) (CREATEREGION LEFT BOTTOM WIDTH (DIFFERENCE HEIGHT 7))) WINDOW)) WINDOW) (if USER then (TALK.ADD.NAME USER ADDRESS PROTOCOL) (with REGION REGION (add BOTTOM HEIGHT) (TALK.ANSWER.USERNAME USER (CREATEREGION LEFT BOTTOM WIDTH (DIFFERENCE HEIGHT 7)) WINDOW))) (TALK.RINGBELLS WINDOW) (if (AND [STRINGP (AWAIT.EVENT EVENT (TIMES TALK.ANSWER.WAIT 1000 (if \IDLING then (* Provide extra time to login) 2 else 1] USER) then (* We timed out, leave the icon up  but change its functionality) (WINDOWPROP WINDOW 'TALK (LIST USER (CONS PROTOCOL ADDRESS))) (WINDOWPROP WINDOW 'EVENT NIL) (INVERTW WINDOW) else (WINDOWPROP WINDOW 'EVENT NIL) (CLOSEW WINDOW)) (WINDOWPROP WINDOW 'RESULT]) (TALK.ANSWER.WINDOW [LAMBDA (USER) (* ; "Edited 9-Jun-88 10:27 by cdl") (PROG (WINDOW REGION) [if TALK.ICON.WINDOWS then [if [AND USER (SETQ WINDOW (for WINDOW in TALK.ICON.WINDOWS thereis (EQUAL USER (CAR (WINDOWPROP WINDOW 'TALK] then (RETURN WINDOW) else (SETQ REGION (with REGION (WINDOWPROP (CAR TALK.ICON.WINDOWS) 'REGION) (if (LESSP (PLUS PRIGHT WIDTH) SCREENWIDTH) then (CREATEREGION PRIGHT BOTTOM WIDTH HEIGHT) else (CREATEREGION (OR (fetch (REGION LEFT) of (REGIONP TALK.DEFAULT.REGION) ) 0) (if (LESSP (PLUS PTOP HEIGHT) SCREENHEIGHT) then PTOP else (OR (fetch (REGION BOTTOM) of (REGIONP TALK.DEFAULT.REGION )) 0)) WIDTH HEIGHT] else (SETQ REGION (with BITMAP TALK.ICON.BITMAP (if (REGIONP TALK.DEFAULT.REGION) then (with REGION TALK.DEFAULT.REGION (CREATEREGION LEFT BOTTOM BITMAPWIDTH BITMAPHEIGHT)) else (CREATEREGION 0 0 BITMAPWIDTH BITMAPHEIGHT] (push TALK.ICON.WINDOWS (SETQ WINDOW (CREATEW REGION NIL 0 T))) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION TALK.ICON.BUTTONEVENTFN)) (WINDOWPROP WINDOW 'CLOSEFN (FUNCTION TALK.ICON.CLOSEFN)) (RETURN WINDOW]) (TALK.ANSWER.USERNAME [LAMBDA (USER REGION WINDOW) (* cdl "10-Jun-87 08:38") (LET (PTR FONTHEIGHT (FONT (DSPFONT NIL WINDOW))) (if (AND (GREATERP (NCHARS USER) (QUOTIENT (BITMAPWIDTH TALK.ICON.BITMAP) (CHARWIDTH (CHARCODE A) FONT))) (SETQ PTR (STRPOS (CONSTANT (CHARACTER (CHARCODE SPACE))) USER))) then (DSPFONT TALK.ICON.FONT WINDOW) (SETQ FONTHEIGHT (QUOTIENT (FONTPROP TALK.ICON.FONT 'HEIGHT) 2)) (CENTERPRINTINREGION (SUBSTRING USER 1 (SUB1 PTR)) (with REGION REGION (CREATEREGION LEFT (PLUS BOTTOM FONTHEIGHT) WIDTH HEIGHT)) WINDOW) (CENTERPRINTINREGION (SUBSTRING USER (ADD1 PTR) -1) (with REGION REGION (CREATEREGION LEFT (DIFFERENCE BOTTOM FONTHEIGHT) WIDTH HEIGHT)) WINDOW) (DSPFONT FONT WINDOW) else (CENTERPRINTINREGION USER REGION WINDOW]) (TALK.GET.NAME [LAMBDA NIL (* ; "Edited 16-Jun-88 09:24 by cdl") (* DECLARATIONS%: (RECORD ENTRY  (NAME . PAIRS)) (RECORD PAIR  (PROTOCOL . ADDRESS))) (LET [HOSTNAME HOSTNAMES MENU (ITEM '("" NIL ""] (if (SETQ HOSTNAMES (for ENTRY in TALK.HOSTNAMES collect (if (LISTP ENTRY) then [with ENTRY ENTRY `(,NAME ,(KWOTE ENTRY) NIL (SUBITEMS ,@(for PAIR in PAIRS collect (with PAIR PAIR `(,(CONCAT PROTOCOL " " ADDRESS) ,(KWOTE (LIST NAME PAIR] else ENTRY))) then (push HOSTNAMES ITEM)) [SETQ MENU (create MENU TITLE _ "TALK" ITEMS _ `(("Prompt for User/Host" 'PROMPT "Prompt for a new user or hostname." ) (,(if TALK.GAG then "Turn TALK On" else "Turn TALK Off") (PROGN (SETQ TALK.GAG (NOT TALK.GAG)) NIL) "Toggle TALK connection accept/refuse switch.") ,@HOSTNAMES] [if HOSTNAMES then (SHADEITEM ITEM MENU BLACKSHADE) (* Kludge to make entire line of  menu inverted, not just up to  subitem arrows) (with REGION (MENUITEMREGION ITEM MENU) (with MENU MENU (BLTSHADE BLACKSHADE (with WINDOW IMAGE SAVE) (PLUS LEFT MENUOUTLINESIZE) (PLUS BOTTOM MENUOUTLINESIZE) WIDTH HEIGHT] (SELECTQ (SETQ HOSTNAME (MENU MENU)) (PROMPT (SETQ HOSTNAME (MKATOM (PROMPTFORWORD "User or host?" NIL NIL PROMPTWINDOW))) (TERPRI PROMPTWINDOW)) NIL) HOSTNAME]) (TALK.ADD.NAME [LAMBDA (NAME ADDRESS PROTOCOL) (* ; "Edited 9-Jun-88 12:39 by cdl") (* DECLARATIONS%: (RECORD ENTRY  (NAME . PAIRS))) (LET (ENTRY) (if (NOT (EQUAL NAME ADDRESS)) then (if (SETQ ENTRY (bind HOSTNAME (NCHARS _ (NCHARS NAME)) for ENTRY in TALK.HOSTNAMES eachtime (SETQ HOSTNAME (if (LISTP ENTRY) then (with ENTRY ENTRY NAME) else ENTRY)) thereis (STRING-EQUAL HOSTNAME NAME))) then (if (NLISTP ENTRY) then (SETQ TALK.HOSTNAMES (DREMOVE ENTRY TALK.HOSTNAMES)) (push TALK.HOSTNAMES (LIST NAME (CONS PROTOCOL ADDRESS))) else (PUTASSOC PROTOCOL ADDRESS (with ENTRY ENTRY PAIRS) )) else (push TALK.HOSTNAMES (LIST NAME (CONS PROTOCOL ADDRESS]) (TALK.FLASH.CARET [LAMBDA (WINDOW POSITION FLG) (* ; "Edited 2-Jun-88 15:17 by cdl") (DECLARE (GLOBALVARS DEFAULTCARET)) (if (OPENWP WINDOW) then (SELECTQ FLG (OFF [with POSITION POSITION (if XCOORD then (with CURSOR DEFAULTCARET (BITBLT CUIMAGE NIL NIL WINDOW XCOORD YCOORD NIL NIL NIL 'INVERT]) (ON [with POSITION POSITION (with CURSOR DEFAULTCARET (BITBLT CUIMAGE NIL NIL WINDOW (SETQ XCOORD (DIFFERENCE (DSPXPOSITION NIL WINDOW) CUHOTSPOTX)) (SETQ YCOORD (DIFFERENCE (DSPYPOSITION NIL WINDOW) CUHOTSPOTY)) NIL NIL NIL 'INVERT]) NIL]) (TALK.WHENSELECTEDFN [LAMBDA (ITEM FROMMENU BUTTON) (* ; "Edited 9-Jun-88 14:50 by cdl") (* DECLARATIONS%: (RECORD STREAMS  (INPUTSTREAM . OUTPUTSTREAM))) (LET [MAINWINDOW TEXTSTREAM STREAMS (WINDOW (MAINWINDOW (WFROMMENU FROMMENU] (DECLARE (SPECVARS WINDOW MAINWINDOW TEXTSTREAM STREAMS)) (SETQ TEXTSTREAM (WINDOWPROP (SETQ MAINWINDOW (MAINWINDOW WINDOW)) 'TEXTSTREAM)) (if (AND (SETQ STREAMS (WINDOWPROP MAINWINDOW 'STREAMS)) (OPENP (with STREAMS STREAMS OUTPUTSTREAM))) then (ERRORSET (CADR ITEM]) (TALK.RINGBELLS [LAMBDA (WINDOW) (* cdl "16-Mar-87 08:01") (DECLARE (GLOBALVARS RINGBELLS.L1 RINGBELLS.L2)) (PLAYTUNE RINGBELLS.L1) (* Dorados and Dolphins can't do  PLAYTUNE but let BEEPON/BEEPOFF  handle that) (FLASHWINDOW WINDOW) (PLAYTUNE RINGBELLS.L2]) (TALK.START.SERVER [LAMBDA (PROTOCOL RESTART) (* ; "Edited 8-Jun-88 15:06 by cdl") (DECLARE (SPECVARS RESTART)) (if PROTOCOL then (LET ((PROTOCOLTYPE (ASSOC PROTOCOL TALK.PROTOCOLTYPES))) (DECLARE (SPECVARS PROTOCOLTYPE)) (if PROTOCOLTYPE then [with TALK.PROTOCOLTYPE PROTOCOLTYPE (if TALK.STARTSERVERFN then (CAR (NLSETQ (APPLY* TALK.STARTSERVERFN RESTART] else (ERROR PROTOCOL "Unknown protocol!"))) else (for PROTOCOLTYPE declare%: (SPECVARS PROTOCOLTYPE) in TALK.PROTOCOLTYPES do (with TALK.PROTOCOLTYPE PROTOCOLTYPE (if TALK.STARTSERVERFN then (NLSETQ (APPLY* TALK.STARTSERVERFN RESTART]) ) (DEFINEQ (TALK.ICON.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 9-Jun-88 10:02 by cdl") (* DECLARATIONS%: (RECORD  DESTINATION (NAME (PROTOCOL . ADDRESS)))) (RESETFORM (INVERTW WINDOW) (until (MOUSESTATE UP) do)) (ALLOW.BUTTON.EVENTS) (if (WINDOWPROP WINDOW 'EVENT) then (WINDOWPROP WINDOW 'RESULT T) (NOTIFY.EVENT (WINDOWPROP WINDOW 'EVENT NIL) T) else (LET ((DESTINATION (WINDOWPROP WINDOW 'TALK)) RESULT) (if (MOUSECONFIRM (CONCAT "(Re)Connect to " (with DESTINATION DESTINATION NAME) "?")) then (if (PROCESSP (SETQ RESULT (TALK.RECONNECT DESTINATION))) then (CLOSEW WINDOW) else (FLASHWINDOW WINDOW) (PROMPTPRINT RESULT]) (TALK.ICON.CLOSEFN [LAMBDA (WINDOW) (* cdl "10-May-87 10:07") (LET ((EVENT (WINDOWPROP WINDOW 'EVENT NIL))) (if EVENT then (NOTIFY.EVENT EVENT T))) (SETQ TALK.ICON.WINDOWS (DREMOVE WINDOW TALK.ICON.WINDOWS]) ) (* TALK data) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD TALK.SERVICETYPE (TALK.SERVICENAME TALK.DISPLAYFN TALK.LISTENFN)) (RECORD TALK.PROTOCOLTYPE (TALK.PROTOCOLNAME TALK.HOSTNAMEFN TALK.USERNAMEFN TALK.CONNECTFN TALK.EVENTFN TALK.STARTSERVERFN TALK.CASEARRAY)) ) ) (RPAQQ TALK.MENU.ITEMS ((Disconnect (TALK.CLOSEFN MAINWINDOW) "Close TALK connection and keep window open.") (RingBells (PROGN (PRINTCCODE (CHARCODE ^G) (CDR STREAMS)) (FORCEOUTPUT (CDR STREAMS)) (FLASHWINDOW MAINWINDOW)) "Execute a (RINGBELLS) on the remote machine.") (Message (LET [(MESSAGE (MENU (create MENU ITEMS _ TALK.USER.MESSAGES] (if [AND MESSAGE (TTY.PROCESSP (WINDOWPROP MAINWINDOW 'PROCESS] then (BKSYSBUF MESSAGE))) "Insert a generic message."))) (RPAQQ TALK.USER.MESSAGES (("One moment please" "One moment please..." NIL (SUBITEMS ( "the phone's ringing" "One moment please, the phone's ringing..." ) ( "there's someone at the door" "One moment please, there's someone at the door..." ) ( "someone is trying to TALK to me" "One moment please, someone is trying to TALK to me..." ))) (DATE (DATE) "The current date and time.") "Bye.")) (RPAQ? TALK.SERVICETYPES NIL) (RPAQ? TALK.PROTOCOLTYPES NIL) (RPAQ? TALK.GAG NIL) (RPAQ? TALK.HOSTNAMES NIL) (RPAQ? TALK.ICON.WINDOWS NIL) (RPAQ? TALK.ANSWER.WAIT 15) (RPAQ? TALK.READTABLE (COPYREADTABLE 'ORIG)) (RPAQ? TALK.DEFAULT.REGION (CREATEREGION 0 0 500 500)) (RPAQ? TALK.CLOSED.STRING " -- Connection Closed") (RPAQ? TALK.ICON.FONT LITTLEFONT) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.MENU.ITEMS TALK.USER.MESSAGES TALK.SERVICETYPES TALK.PROTOCOLTYPES TALK.GAG TALK.HOSTNAMES TALK.ICON.WINDOWS TALK.ANSWER.WAIT TALK.READTABLE TALK.DEFAULT.REGION TALK.CLOSED.STRING TALK.ICON.FONT) ) (ADDTOVAR BackgroundMenuCommands (Talk '(PRINTOUT PROMPTWINDOW T (TALK) T) "Start a TALK session with another user/host.")) (RPAQQ BackgroundMenu NIL) (APPENDTOVAR BACKGROUNDFNS TALK.START.SERVER) (APPENDTOVAR AFTERMAKESYSFORMS (TALK.START.SERVER NIL T)) (RPAQQ TALK.ICON.BITMAP #*(80 78)OOOOOOOOOOOOOOOOOOOOLAIKKGHHDBNOOOOOOOOOOGFKJOKKEJDMOOOOOOOOOG@KHOHHEJJOOOOOOOOOOGFKJOKJMJNMOOOOOOOOOGFHKGKKDBNOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOLAKGDGOOOOOOOOOOOOOOOGKBENOOOOOOOOOOOOOOOGKEDGOOOOOOOOOOOOOOOGKGENOOOOOOOOOOOOOOOGKGDGOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOMM@HLGOOOOOOOOOOOOOOLIFKENOOOOOOOOOOOOOOMEFKDGOOOOOOOOOOOOOOMMFKENOOOOOOOOOOOOOOMM@HLGOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOO ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.ICON.BITMAP) ) (SETSYNTAX (CHARCODE SPACE) (CHARCODE A) TALK.READTABLE) (PUTPROPS TALK COPYRIGHT ("Stanford University" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2377 6659 (TALK 2387 . 6657)) (6660 31221 (TALK.RECONNECT 6670 . 10485) (TALK.PROCESS 10487 . 11403) (TALK.DISPLAY 11405 . 14118) (TALK.LISTEN 14120 . 15633) (TALK.CLOSEFN 15635 . 16150) ( TALK.ANSWER 16152 . 18935) (TALK.ANSWER.WINDOW 18937 . 21688) (TALK.ANSWER.USERNAME 21690 . 23092) ( TALK.GET.NAME 23094 . 25712) (TALK.ADD.NAME 25714 . 27266) (TALK.FLASH.CARET 27268 . 28866) ( TALK.WHENSELECTEDFN 28868 . 29649) (TALK.RINGBELLS 29651 . 30143) (TALK.START.SERVER 30145 . 31219)) ( 31222 32752 (TALK.ICON.BUTTONEVENTFN 31232 . 32451) (TALK.ICON.CLOSEFN 32453 . 32750))))) STOP \ No newline at end of file diff --git a/lispusers/TALK.TEDIT b/lispusers/TALK.TEDIT new file mode 100644 index 00000000..0927c626 Binary files /dev/null and b/lispusers/TALK.TEDIT differ diff --git a/lispusers/TALKGAP b/lispusers/TALKGAP new file mode 100644 index 00000000..76c6a2f6 --- /dev/null +++ b/lispusers/TALKGAP @@ -0,0 +1 @@ +(FILECREATED "26-Mar-87 09:58:58" {MCS:MCS:STANFORD}TALKGAP.LSP;3 previous date: " 3-Mar-87 10:52:35" {MCS:MCS:STANFORD}TALKGAP.LSP;2) (PRETTYCOMPRINT TALKGAPCOMS) (RPAQQ TALKGAPCOMS ((COURIERPROGRAMS TALKGAP) (P (DEFINE.GAP.SERVER)))) (COURIERPROGRAM TALKGAP (3 3) TYPES [(WaitTime CARDINAL) (CharLength (ENUMERATION (five 0) (six 1) (seven 2) (eight 3))) (Parity (ENUMERATION (none 0) (odd 1) (even 2) (one 3) (zero 4))) (StopBits (ENUMERATION (one 0) (two 1))) (FlowControl (RECORD (type (ENUMERATION (none 0) (xOnXOff 1))) (xOn UNSPECIFIED) (xOff UNSPECIFIED))) (SessionHandle (ARRAY 2 UNSPECIFIED)) [SessionParameterObject (CHOICE (xerox800 0 NIL) (xerox850 1 UNSPECIFIED) (xerox860 2 UNSPECIFIED) (system6 3 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (cmcll 4 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm2770 5 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm2770Host 6 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm6670 7 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm6670Host 8 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm3270 9 NIL) (ibm3270Host 10 NIL) (OldTtyHost 11 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL))) (OldTty 12 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL))) (other 13 NIL) (unknown 14 NIL) (ibm2780 15 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm2780Host 16 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm3780 17 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (ibm3780Host 18 (RECORD (sendBlockSize CARDINAL) (receiveBlockSize CARDINAL))) (siemens9750 19 NIL) (siemens9750Host 20 NIL) (ttyHost 21 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL) (flowControl FlowControl))) (tty 22 (RECORD (charLength CharLength) (parity Parity) (stopBits StopBits) (frameTimeout CARDINAL) (flowControl FlowControl] [TransportObject (CHOICE [rs232c 0 (RECORD (CommParams CommParamObject) (preemptOthers ReserveType) (preemptMe ReserveType) (phoneNumber STRING) (line (CHOICE (alreadyReserved 0 (RECORD (resource Resource) )) (reserveNeeded 1 (RECORD (lineNumber CARDINAL] (bsc 1 (RECORD (localTerminalID STRING) (localSecurityID STRING) (lineControl LineControl) (authenticateProc UNSPECIFIED))) (teletype 2 NIL) (polledBSCController 3 (RECORD (hostControllerName STRING) (controllerAddress ControllerAddress) (portsOnController CARDINAL))) (sdlcController 4 (RECORD (hostControllerName STRING) (controllerAddress ControllerAddress) (portsOnController CARDINAL))) (polledBSCTerminal 5 (RECORD (hostControllerName STRING) (terminalAddress TerminalAddress))) (sdlcTerminal 6 (RECORD (hostControllerName STRING) (terminalAddress TerminalAddress))) (service 7 (RECORD (id LONGCARDINAL))) (unused 8 NIL) (polledBSCPrinter 9 (RECORD (hostControllerName STRING) (printerAddress TerminalAddress))) (sdlcPrinter 10 (RECORD (hostControllerName STRING) (printerAddress TerminalAddress] (Sequence.TransportObject (SEQUENCE TransportObject)) (BidReply (ENUMERATION (wack 0) (nack 1) (default 2))) (ExtendedBoolean (ENUMERATION (true 0) (false 1) (default 2))) (DeviceType (ENUMERATION (undefined 0) (terminal 1) (printer 2))) [AccessDetail (CHOICE (directConn 0 (RECORD (duplex (ENUMERATION (full 0) (half 1))) (lineType LineType) (lineSpeed LineSpeed))) (dialConn 1 (RECORD (duplex (ENUMERATION (full 0) (half 1))) (lineType LineType) (lineSpeed LineSpeed) (dialMode (ENUMERATION (manual 0) (auto 1))) (dialerNumber CARDINAL) (retryCount CARDINAL] (CommParamObject (RECORD (accessDetail AccessDetail))) (LineType (ENUMERATION (bitSynchronous 0) (byteSynchronous 1) (asynchronous 2) (autoRecognition 3))) (LineSpeed (ENUMERATION (bps50 0) (bps75 1) (bps110 2) (bps135p5 3) (bps150 4) (bps300 5) (bps600 6) (bps1200 7) (bps2400 8) (bps3600 9) (bps4800 10) (bps7200 11) (bps9600 12) (bps19200 13) (bps28800 14) (bps38400 15) (bps48000 16) (bps56000 17) (bps57600 18))) (LineControl (ENUMERATION (primary 0) (secondary 1))) (ControllerAddress CARDINAL) (TerminalAddress CARDINAL) (credentials (AUTHENTICATION . CREDENTIALS)) (verifier (AUTHENTICATION . VERIFIER)) (Duplexity (ENUMERATION (full 0) (half 1))) (PortClientType (ENUMERATION (unassigned 0) (outOfService 1) (its 2) (irs 3) (gws 4) (ibm3270Host 5) (ttyEmulation 6) (rbs 7) (fax 8) (mailGateway 9) (phototypesetter 10))) (PortDialerType (ENUMERATION (none 0) (vadic 1) (hayes 2) (ventel 3) (rs366 4))) (PortEchoingLocation (ENUMERATION (application 0) (ciu 1) (terminal 2))) (ReserveType (ENUMERATION (preemptNever 0) (preemptAlways 1) (preemptInactive 2))) (RS232CData (RECORD (cIUPort BOOLEAN) (owningClientType PortClientType) (preemptionAllowed BOOLEAN) (lineNumber CARDINAL) (dialerNumber CARDINAL) (duplexity Duplexity) (dialingHardware PortDialerType) (charLength CharLength) (echoing PortEchoingLocation) (flowControl FlowControl) (lineSpeed LineSpeed) (parity Parity) (stopBits StopBits) (portActsAsDCE BOOLEAN) (accessControl NSNAME) (validLineSpeeds (SEQUENCE LineSpeed] PROCEDURES ((Reset 0) (Create 2 (SessionParameterObject Sequence.TransportObject WaitTime credentials verifier) RETURNS (SessionHandle) REPORTS (badAddressFormat controllerAlreadyExists controllerDoesNotExist dialingHardwareProblem illegalTransport inconsistentParams mediumConnectFailed noCommunicationHardware noDialingHardware terminalAddressInUse terminalAddressInvalid tooManyGateStreams transmissionMediumUnavailable serviceTooBusy userNotAuthenticated userNotAuthorized serviceNotFound) IMPLEMENTEDBY GAP.SERVER)) ERRORS ((unimplemented 0) (noCommunicationHardware 1) (illegalTransport 2) (mediumConnectFailed 3) (badAddressFormat 4) (noDialingHardware 5) (dialingHardwareProblem 6) (transmissionMediumUnavailable 23) (inconsistentParams 8) (tooManyGateStreams 9) (bugInGAPCode 10) (gapNotExported 11) (gapCommunicationError 12) (controllerAlreadyExists 13) (controllerDoesNotExist 14) (terminalAddressInUse 15) (terminalAddressInvalid 16) (serviceTooBusy 17) (userNotAuthenticated 18) (userNotAuthorized 19) (serviceNotFound 20) (registeredTwice 21) (transmissionMediumHardwareProblem 22) (transmissionMediumNotReady 24) (noAnswerOrBusy 25) (noRouteToGAPService 26) (gapServiceNotResponding 27) (courierProtocolMismatch 28) (gapVersionMismatch 29))) (DEFINE.GAP.SERVER) STOP \ No newline at end of file diff --git a/lispusers/TCPTIME b/lispusers/TCPTIME new file mode 100644 index 00000000..eb2c8a73 --- /dev/null +++ b/lispusers/TCPTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Sep-87 11:28:32" |{MCS:MCS:STANFORD}TCPTIME.;22| 10709 changes to%: (VARS TCPTIMECOMS) previous date%: "14-Sep-87 08:59:11" |{MCS:MCS:STANFORD}TCPTIME.;21|) (* " Copyright (c) 1986, 1987 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT TCPTIMECOMS) (RPAQQ TCPTIMECOMS ((* * Common TCP and UDP Time Client and Server Functions) (FNS RFC868.SETTIME RFC868.START.SERVER RFC868.STOP.SERVER) (INITVARS (RFC868.TIME.PORT 37) (RFC868.DEFAULT.PROTOCOL 'TCP)) (ADDVARS (RFC868.ASCII.OSTYPES VMS)) (* Constant adjusts Jan 1, 1901 by one year (in seconds) since lisp will not accept Jan 1, 1900) [DECLARE%: DONTCOPY (CONSTANTS (RFC868.START.OF.TIME (DIFFERENCE (TIMES 365 24 60 60) (IDATE " 1-Jan-01 00:00:00 GMT" ] (GLOBALVARS RFC868.TIME.PORT RFC868.DEFAULT.PROTOCOL RFC868.ASCII.OSTYPES RFC868.PROTOCOLS) (FNS RFC868.IDATE RFC868.SETNEWTIME) (* * TCP Time Client and Server) (FNS TCP.SETTIME TCP.TIMESERVER) (ADDVARS (RFC868.PROTOCOLS (TCP TCP.SETTIME TCP.TIMESERVER))) (INITVARS TCP.TIME.HOSTS (TCP.TIME.PORT RFC868.TIME.PORT) (TCP.SETTIME.TIMEOUT 10000)) (GLOBALVARS TCP.TIME.HOSTS TCP.TIME.PORT TCP.SETTIME.TIMEOUT) (DECLARE%: DONTCOPY (MACROS READTIME WRITETIME)) (FILES TCP) (* * UDP Time Client and Server) (FNS UDP.SETTIME UDP.TIMESERVER) (ADDVARS (RFC868.PROTOCOLS (UDP UDP.SETTIME UDP.TIMESERVER))) (INITVARS UDP.TIME.HOSTS (UDP.TIME.PORT RFC868.TIME.PORT) (UDP.SETTIME.TIMEOUT 10000)) (GLOBALVARS UDP.TIME.HOSTS UDP.TIME.PORT UDP.SETTIME.TIMEOUT) (DECLARE%: DONTCOPY (MACROS UDP.APPEND.TIME GETBASETIME)) (FILES TCPUDP))) (* * Common TCP and UDP Time Client and Server Functions) (DEFINEQ (RFC868.SETTIME [LAMBDA (RETFLG PROTOCOL) (* ; "Edited 10-Sep-87 11:03 by cdl") (* DECLARATIONS%: (RECORD SERVICE  (PROTOCOL CLIENT SERVER))) (LET (SERVICE) (if (SETQ SERVICE (ASSOC (OR PROTOCOL RFC868.DEFAULT.PROTOCOL) RFC868.PROTOCOLS)) then (with SERVICE SERVICE (APPLY* CLIENT RETFLG]) (RFC868.START.SERVER [LAMBDA (PROTOCOL ASCIIFLG) (* ; "Edited 10-Sep-87 11:03 by cdl") (* DECLARATIONS%: (RECORD SERVICE  (PROTOCOL CLIENT SERVER))) (LET (SERVICE) (if [AND (SETQ SERVICE (ASSOC (OR PROTOCOL RFC868.DEFAULT.PROTOCOL) RFC868.PROTOCOLS)) (with SERVICE SERVICE (NOT (FIND.PROCESS SERVER] then (with SERVICE SERVICE (ADD.PROCESS `(,SERVER ,ASCIIFLG) 'RESTARTABLE T]) (RFC868.STOP.SERVER [LAMBDA (PROTOCOL) (* ; "Edited 10-Sep-87 11:03 by cdl") (* DECLARATIONS%: (RECORD SERVICE  (PROTOCOL CLIENT SERVER))) (LET (SERVICE PROCESS) (if [AND (SETQ SERVICE (ASSOC (OR PROTOCOL RFC868.DEFAULT.PROTOCOL) RFC868.PROTOCOLS)) (with SERVICE SERVICE (SETQ PROCESS (FIND.PROCESS SERVER] then (DEL.PROCESS PROCESS]) ) (RPAQ? RFC868.TIME.PORT 37) (RPAQ? RFC868.DEFAULT.PROTOCOL 'TCP) (ADDTOVAR RFC868.ASCII.OSTYPES VMS) (* Constant adjusts Jan 1, 1901 by one year (in seconds) since lisp will not accept Jan 1, 1900) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQ RFC868.START.OF.TIME (DIFFERENCE (TIMES 365 24 60 60) (IDATE " 1-Jan-01 00:00:00 GMT"))) [CONSTANTS (RFC868.START.OF.TIME (DIFFERENCE (TIMES 365 24 60 60) (IDATE " 1-Jan-01 00:00:00 GMT"] ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RFC868.TIME.PORT RFC868.DEFAULT.PROTOCOL RFC868.ASCII.OSTYPES RFC868.PROTOCOLS) ) (DEFINEQ (RFC868.IDATE [LAMBDA NIL (* ; "Edited 10-Sep-87 13:38 by cdl") (PLUS RFC868.START.OF.TIME (IDATE]) (RFC868.SETNEWTIME [LAMBDA (TIME RETFLG) (* ; "Edited 10-Sep-87 13:37 by cdl") (DECLARE (GLOBALVARS PROMPTWINDOW)) (SETQ TIME (DIFFERENCE TIME RFC868.START.OF.TIME)) (if RETFLG then TIME else (PRINTOUT PROMPTWINDOW T "[Time reset to " [SETTIME (GDATE TIME '(DATEFORMAT TIME.ZONE] "]") T]) ) (* * TCP Time Client and Server) (DEFINEQ (TCP.SETTIME [LAMBDA (RETFLG) (* ; "Edited 10-Sep-87 13:20 by cdl") (bind STREAM TIME RESULT declare%: (SPECVARS STREAM HOST) for HOST in TCP.TIME.HOSTS when (AND (SETQ STREAM (RESETVAR \TCP.DEFAULT.USER.TIMEOUT TCP.SETTIME.TIMEOUT (TCP.OPEN HOST TCP.TIME.PORT NIL 'ACTIVE 'INPUT T))) [SETQ TIME (RESETLST [RESETSAVE NIL `(CLOSEF? ,STREAM] (if (AND RFC868.ASCII.OSTYPES (MEMB (GETOSTYPE HOST) RFC868.ASCII.OSTYPES)) then (NLSETQ (READ STREAM)) else (NLSETQ (READTIME STREAM] (SETQ RESULT (RFC868.SETNEWTIME (CAR TIME) RETFLG))) do (RETURN RESULT]) (TCP.TIMESERVER [LAMBDA (ASCIIFLG) (* ; "Edited 14-Sep-87 08:58 by cdl") (DECLARE (SPECVARS ASCIIFLG)) (bind STREAM declare%: (SPECVARS STREAM) first (* Allow TCP to clean up old connection if this is a RESTART) (BLOCK) while T when (SETQ STREAM (TCP.OPEN NIL NIL TCP.TIME.PORT 'PASSIVE 'OUTPUT T)) do (RESETLST [RESETSAVE NIL `(CLOSEF? ,STREAM] (if ASCIIFLG then (PRINTOUT STREAM (RFC868.IDATE)) else (WRITETIME STREAM (RFC868.IDATE]) ) (ADDTOVAR RFC868.PROTOCOLS (TCP TCP.SETTIME TCP.TIMESERVER)) (RPAQ? TCP.TIME.HOSTS NIL) (RPAQ? TCP.TIME.PORT RFC868.TIME.PORT) (RPAQ? TCP.SETTIME.TIMEOUT 10000) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TCP.TIME.HOSTS TCP.TIME.PORT TCP.SETTIME.TIMEOUT) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS READTIME MACRO ((STREAM) (PLUS (LSH (BIN16 STREAM) 16) (BIN16 STREAM] [PUTPROPS WRITETIME MACRO ((STREAM TIME) (BOUT16 STREAM (RSH TIME 16)) (BOUT16 STREAM (LOGAND TIME (MASK.1'S 0 16] ) ) (FILESLOAD TCP) (* * UDP Time Client and Server) (DEFINEQ (UDP.SETTIME [LAMBDA (RETFLG) (* ; "Edited 10-Sep-87 13:20 by cdl") (DECLARE (SPECVARS RETFLG)) (LET (SOCKET) (DECLARE (SPECVARS SOCKET)) (RESETLST [RESETSAVE NIL `(UDP.CLOSE.SOCKET ,(SETQ SOCKET (UDP.OPEN.SOCKET] (bind UDP ADDRESS RESULT for HOST in UDP.TIME.HOSTS when (AND (SETQ ADDRESS (DODIP.HOSTP HOST)) (SETQ UDP (UDP.EXCHANGE SOCKET (UDP.SETUP (\ALLOCATE.ETHERPACKET) ADDRESS UDP.TIME.PORT 0 SOCKET 'FREE) UDP.SETTIME.TIMEOUT)) (SETQ RESULT (RFC868.SETNEWTIME (with UDP UDP (GETBASETIME UDPCONTENTS 0 )) RETFLG))) do (RETURN RESULT]) (UDP.TIMESERVER [LAMBDA NIL (* ; "Edited 10-Sep-87 13:04 by cdl") (LET (SOCKET) (DECLARE (SPECVARS SOCKET)) (RESETLST [RESETSAVE NIL `(UDP.CLOSE.SOCKET ,(SETQ SOCKET (UDP.OPEN.SOCKET UDP.TIME.PORT] (bind UDP while (SETQ UDP (UDP.GET SOCKET T)) do (UDP.SETUP UDP (with IP UDP IPSOURCEADDRESS) (with UDP UDP UDPSOURCEPORT) 0 SOCKET 'FREE) (UDP.APPEND.TIME UDP (RFC868.IDATE)) (UDP.SEND SOCKET UDP]) ) (ADDTOVAR RFC868.PROTOCOLS (UDP UDP.SETTIME UDP.TIMESERVER)) (RPAQ? UDP.TIME.HOSTS NIL) (RPAQ? UDP.TIME.PORT RFC868.TIME.PORT) (RPAQ? UDP.SETTIME.TIMEOUT 10000) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS UDP.TIME.HOSTS UDP.TIME.PORT UDP.SETTIME.TIMEOUT) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS UDP.APPEND.TIME MACRO (OPENLAMBDA (UDP TIME) (UDP.APPEND.WORD UDP (RSH TIME 16)) (UDP.APPEND.WORD UDP (LOGAND TIME (MASK.1'S 0 16] [PUTPROPS GETBASETIME MACRO ((OFFSET BASE) (PLUS (LSH (\GETBASE OFFSET BASE) 16) (\GETBASE OFFSET (ADD1 BASE] ) ) (FILESLOAD TCPUDP) (PUTPROPS TCPTIME COPYRIGHT ("Stanford University" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2617 4432 (RFC868.SETTIME 2627 . 3164) (RFC868.START.SERVER 3166 . 3816) ( RFC868.STOP.SERVER 3818 . 4430)) (5108 5698 (RFC868.IDATE 5118 . 5283) (RFC868.SETNEWTIME 5285 . 5696) ) (5738 7386 (TCP.SETTIME 5748 . 6687) (TCP.TIMESERVER 6689 . 7384)) (8117 9840 (UDP.SETTIME 8127 . 9191) (UDP.TIMESERVER 9193 . 9838))))) STOP \ No newline at end of file diff --git a/lispusers/TCPTIME.TEDIT b/lispusers/TCPTIME.TEDIT new file mode 100644 index 00000000..2ce59a70 Binary files /dev/null and b/lispusers/TCPTIME.TEDIT differ diff --git a/lispusers/TEDIT-CLOSE-ON-SHRINK b/lispusers/TEDIT-CLOSE-ON-SHRINK new file mode 100644 index 00000000..244aee6d --- /dev/null +++ b/lispusers/TEDIT-CLOSE-ON-SHRINK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "30-Nov-87 15:32:08" {ERINYES}LYRIC>TEDIT-CLOSE-ON-SHRINK.;3 2335 changes to%: (VARS TEDIT-CLOSE-ON-SHRINKCOMS) previous date%: "30-Nov-87 14:55:18" {ERINYES}LYRIC>TEDIT-CLOSE-ON-SHRINK.;2) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDIT-CLOSE-ON-SHRINKCOMS) (RPAQQ TEDIT-CLOSE-ON-SHRINKCOMS ((FNS \TEDIT-CLOSE-ON-SHRINK) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (UNADVISE \TEDIT.REOPEN.STREAM) (PUTPROP (QUOTE TEDIT.CREATEW) (QUOTE READVICE) (QUOTE (NIL (AFTER NIL (if (NOT (MEMB (QUOTE \TEDIT-CLOSE-ON-SHRINK) (WINDOWPROP !VALUE (QUOTE SHRINKFN)))) then (WINDOWADDPROP !VALUE (QUOTE SHRINKFN) (QUOTE \TEDIT-CLOSE-ON-SHRINK))))))) (PUTPROP (QUOTE \TEDIT.CREATEW.FROM.REGION) (QUOTE READVICE) (QUOTE (NIL (AFTER NIL (if (NOT (MEMB (QUOTE \TEDIT-CLOSE-ON-SHRINK) (WINDOWPROP !VALUE (QUOTE SHRINKFN)))) then (WINDOWADDPROP !VALUE (QUOTE SHRINKFN) (QUOTE \TEDIT-CLOSE-ON-SHRINK))))))) (READVISE TEDIT.CREATEW \TEDIT.CREATEW.FROM.REGION) (SETQ ADVISEDFNS (LDIFFERENCE ADVISEDFNS (QUOTE (TEDIT.CREATEW \TEDIT.CREATEW.FROM.REGION \TEDIT.REOPEN.STREAM))))))) ) (DEFINEQ (\TEDIT-CLOSE-ON-SHRINK (LAMBDA (teditWindow) (* N.H.Briggs " 3-Aug-87 17:24") (LET* ((textObj (TEXTOBJ teditWindow)) (backingStream (fetch (TEXTOBJ TXTFILE) of textObj))) (if (NOT (fetch (TEXTOBJ \DIRTY) of textObj)) then (AND backingStream (CLOSEF? backingStream)))) T) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (UNADVISE \TEDIT.REOPEN.STREAM) (PUTPROP (QUOTE TEDIT.CREATEW) (QUOTE READVICE) (QUOTE (NIL (AFTER NIL (if (NOT (MEMB (QUOTE \TEDIT-CLOSE-ON-SHRINK) (WINDOWPROP !VALUE (QUOTE SHRINKFN)))) then (WINDOWADDPROP !VALUE (QUOTE SHRINKFN) (QUOTE \TEDIT-CLOSE-ON-SHRINK))))))) (PUTPROP (QUOTE \TEDIT.CREATEW.FROM.REGION) (QUOTE READVICE) (QUOTE (NIL (AFTER NIL (if (NOT (MEMB (QUOTE \TEDIT-CLOSE-ON-SHRINK) (WINDOWPROP !VALUE (QUOTE SHRINKFN)))) then (WINDOWADDPROP !VALUE (QUOTE SHRINKFN) (QUOTE \TEDIT-CLOSE-ON-SHRINK))))))) (READVISE TEDIT.CREATEW \TEDIT.CREATEW.FROM.REGION) (SETQ ADVISEDFNS (LDIFFERENCE ADVISEDFNS (QUOTE (TEDIT.CREATEW \TEDIT.CREATEW.FROM.REGION \TEDIT.REOPEN.STREAM)))) ) (PUTPROPS TEDIT-CLOSE-ON-SHRINK COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1232 1521 (\TEDIT-CLOSE-ON-SHRINK 1242 . 1519))))) STOP \ No newline at end of file diff --git a/lispusers/TEDIT-CLOSE-ON-SHRINK.TEDIT b/lispusers/TEDIT-CLOSE-ON-SHRINK.TEDIT new file mode 100644 index 00000000..ba6432eb Binary files /dev/null and b/lispusers/TEDIT-CLOSE-ON-SHRINK.TEDIT differ diff --git a/lispusers/TEDIT-LINE-NUMBERING b/lispusers/TEDIT-LINE-NUMBERING new file mode 100644 index 00000000..6a28a5a1 --- /dev/null +++ b/lispusers/TEDIT-LINE-NUMBERING @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED " 9-May-88 11:50:18" {ERINYES}LYRIC>TEDIT-LINE-NUMBERING.;1 14383 changes to%: (VARS TEDIT-LINE-NUMBERINGCOMS) (FNS MAKE-LINE-BREAKS)) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDIT-LINE-NUMBERINGCOMS) (RPAQQ TEDIT-LINE-NUMBERINGCOMS ((DECLARE%: DONTCOPY (PROPS (TEDIT-LINE-NUMBERING MAKEFILE-ENVIRONMENT) (TEDIT-LINE-NUMBERING FILETYPE))) (* ;; "Hack for putting line breaks and line numbers into a transcript.") (FNS MAKE-LINE-BREAKS) (GLOBALVARS INTERPRESS-DSPSCALE PRESS-DSPSCALE DISPLAY-DSPSCALE END-MARKER-CHAR WHITE-SPACE-CHARS) [VARS (INTERPRESS-DSPSCALE 35.27778) (PRESS-DSPSCALE 35.27778) (DISPLAY-DSPSCALE 1) (END-MARKER-CHAR (CHARACTER 2)) (WHITE-SPACE-CHARS (LIST (CHARACTER 32) (CHARACTER 9] (* ;; "Internal functions") (FNS MAKE-LINE-PREFIX-STRING DEL-CHARS READ-AND-SUM-CHARWIDTHS SELECTION-WIDTH GET-NEXT-CHAR SKIP-CHAR WHITE-SPACE-P NONWHITE-SPACE-P))) (DECLARE%: DONTCOPY (PUTPROPS TEDIT-LINE-NUMBERING MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (PUTPROPS TEDIT-LINE-NUMBERING FILETYPE :TCOMPL) ) (* ;; "Hack for putting line breaks and line numbers into a transcript.") (DEFINEQ (MAKE-LINE-BREAKS [LAMBDA (TextStream WidthInInches Device StartLineNum LineNumDigits FirstLineParaLooks OtherLineParaLooks InsertExtraTabFlg InsertExtraCRFlg) (* ; "Edited 9-May-88 11:46 by Trigg") (* ;; "Adds line breaks and prefix line numbers to the current selection in TextStream. ") (DECLARE (GLOBALVARS INTERPRESS-DSPSCALE PRESS-DSPSCALE DISPLAY-DSPSCALE END-MARKER-CHAR)) (OR (NUMBERP LineNumDigits) (SETQ LineNumDigits 3)) (OR (NUMBERP StartLineNum) (SETQ StartLineNum 1)) (LET ((Selection (TEDIT.GETSEL TextStream)) (Scale (SELECTQ Device (DISPLAY DISPLAY-DSPSCALE) (PRESS PRESS-DSPSCALE) (INTERPRESS INTERPRESS-DSPSCALE) (HELP "Unknown device type " Device))) (LineNumTemplateString (CONCATLIST (for i from 1 to LineNumDigits collect 0))) WidthInDeviceUnits StartLoc EndLoc OrigParaLooks Tabs TabStops DefaultTabWidth) (SETQ WidthInDeviceUnits (FTIMES WidthInInches 72 Scale)) (SETQ StartLoc (fetch (SELECTION CH#) of Selection)) (SETQ EndLoc (SUB1 (fetch (SELECTION CHLIM) of Selection))) (if (LEQ EndLoc StartLoc) then (ERROR "*** Error in MAKE-LINE-BREAKS ***" "Current selection is empty.")) (* ;  "Stuff a marker into the text to mark the end of the selection.") (TEDIT.INSERT TextStream END-MARKER-CHAR EndLoc) (TEDIT.SETSEL TextStream StartLoc 0 'LEFT) (SETQ OrigParaLooks (TEDIT.GET.PARALOOKS TextStream Selection)) (SETQ Tabs (LISTGET OrigParaLooks 'TABS)) [SETQ TabStops (for Stop in (CDR Tabs) collect (if (EQ (CDR Stop) 'LEFT) then (FTIMES Scale (CAR Stop)) else (ERROR "Can't handle tabs not of type LEFT" ] (SETQ DefaultTabWidth (FTIMES Scale (OR (CAR Tabs) 36))) (* ;  "stuff a bunch of default tabs on the end of the list of real tabs.") [SETQ TabStops (NCONC TabStops (LET ((LastTab (OR (CAR (LAST TabStops)) 0))) (for TabStop from (PLUS LastTab DefaultTabWidth) by DefaultTabWidth as i from 1 to 10 collect TabStop] (for bind (LineNum _ StartLineNum) (CurLoc _ StartLoc) FirstLineFlg NewWidthOrChar do (* ; "Starting a new paragraph") (SETQ FirstLineFlg T) (TEDIT.INSERT TextStream (MAKE-LINE-PREFIX-STRING LineNum LineNumTemplateString)) (SETQ LineNum (ADD1 LineNum)) (for bind (CurWidth _ (CAR TabStops)) do (SETQ CurLoc (TEDIT.GETPOINT TextStream)) (if [AND (NUMBERP (SETQ NewWidthOrChar (READ-AND-SUM-CHARWIDTHS TextStream Device (FUNCTION WHITE-SPACE-P) TabStops DefaultTabWidth CurWidth))) (NUMBERP (SETQ NewWidthOrChar (READ-AND-SUM-CHARWIDTHS TextStream Device (FUNCTION NONWHITE-SPACE-P) TabStops DefaultTabWidth NewWidthOrChar] then (if (LEQ NewWidthOrChar WidthInDeviceUnits) then (SETQ CurWidth NewWidthOrChar) else (TEDIT.PARALOOKS TextStream (if FirstLineFlg then FirstLineParaLooks else OtherLineParaLooks)) (TEDIT.INSERT TextStream (CHARACTER 13) CurLoc) (TEDIT.INSERT TextStream (MAKE-LINE-PREFIX-STRING LineNum LineNumTemplateString)) (SETQ CurWidth (CAR TabStops)) (* ;  "Add extra tab on non-first lines if caller desired.") [if InsertExtraTabFlg then (TEDIT.INSERT TextStream (CHARACTER 9)) (SETQ CurWidth (OR (CADR TabStops) (PLUS CurWidth DefaultTabWidth] (DEL-CHARS TextStream (FUNCTION WHITE-SPACE-P)) (SETQ LineNum (ADD1 LineNum)) (SETQ FirstLineFlg NIL) (* ;  "The width of the prefix string is just the first tab stop.") ) else (RETURN))) (* ;; "We must be at the end of the paragraph.") (TEDIT.PARALOOKS TextStream (if FirstLineFlg then FirstLineParaLooks else OtherLineParaLooks)) (if (EQ NewWidthOrChar (CHARACTER 13)) then (DEL-CHARS TextStream (FUNCTION WHITE-SPACE-P)) (* ; "Skip past the CR") (SKIP-CHAR TextStream) (* ; "Add an extra CR if caller wants") (if InsertExtraCRFlg then (TEDIT.INSERT TextStream (CHARACTER 13))) else (if (EQ NewWidthOrChar END-MARKER-CHAR) then (* ; "Delete the end marker") (TEDIT.DELETE TextStream (TEDIT.GETPOINT TextStream) 1)) (RETURN]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS INTERPRESS-DSPSCALE PRESS-DSPSCALE DISPLAY-DSPSCALE END-MARKER-CHAR WHITE-SPACE-CHARS) ) (RPAQQ INTERPRESS-DSPSCALE 35.27778) (RPAQQ PRESS-DSPSCALE 35.27778) (RPAQQ DISPLAY-DSPSCALE 1) (RPAQ END-MARKER-CHAR (CHARACTER 2)) (RPAQ WHITE-SPACE-CHARS (LIST (CHARACTER 32) (CHARACTER 9))) (* ;; "Internal functions") (DEFINEQ (MAKE-LINE-PREFIX-STRING [LAMBDA (LineNum TemplateString) (* ; "Edited 21-Apr-88 16:23 by Trigg") (* ;; "The prefix consists of LineNum embedded in TemplateString followed by a tab.") (CONCAT (RPLSTRING TemplateString (MINUS (NCHARS LineNum)) (MKSTRING LineNum)) (CHARACTER 9]) (DEL-CHARS [LAMBDA (TextStream TestFn) (* ; "Edited 21-Apr-88 21:58 by Trigg") (* ;; "Keep deleting characters while TestFn is true.") (for while (APPLY* TestFn (GET-NEXT-CHAR TextStream)) do (TEDIT.DELETE TextStream (TEDIT.GETPOINT TextStream) 1]) (READ-AND-SUM-CHARWIDTHS [LAMBDA (TextStream Device TestFn TabStops DefaultTabWidth StartingWidth) (* ; "Edited 21-Apr-88 22:05 by Trigg") (* ;; "Read characters from TextStream as long as TestFn is true of the character. Return the sum of the stringwidths of the characters read. However, if very first char is CR or end-marker, bail out returning the character read.") (DECLARE (GLOBALVARS END-MARKER-CHAR)) (LET ((NextChar (GET-NEXT-CHAR TextStream)) (Width StartingWidth)) (if (OR (EQ NextChar (CHARACTER 13)) (EQ NextChar END-MARKER-CHAR)) then (* ;  "If we're looking at a CR or special end-marker, bail out.") NextChar else (* ;  "else keep summing stringwidths while TestFn is true.") (for while (APPLY* TestFn NextChar) do [SETQ Width (if (EQ NextChar (CHARACTER 9)) then (* ; "tabs have to be handled special") (if (for TabStop in TabStops thereis (GREATERP TabStop Width)) else (PLUS Width DefaultTabWidth)) else (PLUS Width (SELECTION-WIDTH TextStream Device] (SKIP-CHAR TextStream) (SETQ NextChar (GET-NEXT-CHAR TextStream))) Width]) (SELECTION-WIDTH [LAMBDA (TextStream Device) (* ; "Edited 21-Apr-88 21:11 by Trigg") (* ;;  "Return the stringwidth that the current selection has assuming it's printed to Device.") (LET ((Looks (TEDIT.GET.LOOKS TextStream))) (STRINGWIDTH (TEDIT.SEL.AS.STRING TextStream (TEDIT.GETSEL TextStream)) (FONTCREATE (LISTGET Looks 'FAMILY) (LISTGET Looks 'SIZE) [OR (LISTGET Looks 'FACE) (LIST (LISTGET Looks 'WEIGHT) (LISTGET Looks 'SLOPE) (LISTGET Looks 'EXPANSION] 0 Device]) (GET-NEXT-CHAR [LAMBDA (TextStream) (* ; "Edited 21-Apr-88 21:21 by Trigg") (* ;; "Return the next character in the textstream as an atom, i.e. the character just to the right of the current typein point.") (NTHCHAR (TEDIT.SEL.AS.STRING TextStream (TEDIT.SETSEL TextStream (TEDIT.GETPOINT TextStream) 1)) 1]) (SKIP-CHAR [LAMBDA (TextStream) (* ; "Edited 21-Apr-88 22:04 by Trigg") (TEDIT.SETSEL TextStream (ADD1 (TEDIT.GETPOINT TextStream)) 0]) (WHITE-SPACE-P [LAMBDA (Char) (DECLARE (GLOBALVARS WHITE-SPACE-CHARS)) (* ; "Edited 21-Apr-88 21:43 by Trigg") (FMEMB Char WHITE-SPACE-CHARS]) (NONWHITE-SPACE-P [LAMBDA (Char) (DECLARE (GLOBALVARS WHITE-SPACE-CHARS END-MARKER-CHAR)) (* ; "Edited 21-Apr-88 22:27 by Trigg") (AND (NOT (FMEMB Char WHITE-SPACE-CHARS)) (NEQ Char END-MARKER-CHAR) (NEQ Char (CHARACTER 13]) ) (PUTPROPS TEDIT-LINE-NUMBERING COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2030 9239 (MAKE-LINE-BREAKS 2040 . 9237)) (9662 14291 (MAKE-LINE-PREFIX-STRING 9672 . 10049) (DEL-CHARS 10051 . 10545) (READ-AND-SUM-CHARWIDTHS 10547 . 12421) (SELECTION-WIDTH 12423 . 13171) (GET-NEXT-CHAR 13173 . 13626) (SKIP-CHAR 13628 . 13831) (WHITE-SPACE-P 13833 . 14018) ( NONWHITE-SPACE-P 14020 . 14289))))) STOP \ No newline at end of file diff --git a/lispusers/TEDIT-LINE-NUMBERING.TEDIT b/lispusers/TEDIT-LINE-NUMBERING.TEDIT new file mode 100644 index 00000000..ec6221e3 Binary files /dev/null and b/lispusers/TEDIT-LINE-NUMBERING.TEDIT differ diff --git a/lispusers/TEDITDORADOKEYS b/lispusers/TEDITDORADOKEYS new file mode 100644 index 00000000..5516a9f2 --- /dev/null +++ b/lispusers/TEDITDORADOKEYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "19-Apr-2018 12:27:21"  |{DSK}kaplan>Local>medley3.5>lispcore>lispusers>TEDITDORADOKEYS.;2| 22264 |changes| |to:| (VARS TEDITDORADOKEYSCOMS) |previous| |date:| "28-Oct-87 19:53:12" |{DSK}kaplan>Local>medley3.5>lispcore>lispusers>TEDITDORADOKEYS.;1|) ; Copyright (c) 1987, 2018 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TEDITDORADOKEYSCOMS) (RPAQQ TEDITDORADOKEYSCOMS ((FILES TEDITDCL TEDITFNKEYS) (COMS (* |;;|  "These functions were fixed after Lyric went out so they'll ignore the meta key being down.") (FNS \\TEDIT.BOLD.SEL.OFF \\TEDIT.BOLD.SEL.ON \\TEDIT.CENTER.SEL \\TEDIT.CENTER.SEL.REV \\TEDIT.DEFAULTS.CARET \\TEDIT.DEFAULTSSEL \\TEDIT.SETDEFAULT.FROM.SEL \\TEDIT.FIND \\TEDIT.ITALIC.SEL.OFF \\TEDIT.ITALIC.SEL.ON \\TEDIT.LARGERSEL \\TEDIT.LCASE.SEL \\TEDIT.SHOWCARETLOOKS \\TEDIT.SMALLERSEL \\TEDIT.SUBSCRIPTSEL \\TEDIT.SUPERSCRIPTSEL \\TEDIT.UCASE.SEL \\TEDIT.UNDERLINE.SEL.OFF \\TEDIT.UNDERLINE.SEL.ON \\TEDIT.STRIKEOUT.SEL.ON \\TEDIT.STRIKEOUT.SEL.OFF)) (COMS (* |;;| "Specialized functions for this module") (FNS \\TEDIT.DK.ABORT \\TEDIT.DK.FIND \\TEDIT.DK.SUBSTITUTE \\TEDIT.DK.INSERT-PARENS \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)) (VARS (\\TEDIT.DORADO.KEYS '(("1,a" FN \\TEDIT.DK.ABORT) ("1,A" FN \\TEDIT.DK.ABORT) ("1,U" UNDO) ("1,u" UNDO) ("1,f" FN \\TEDIT.DK.FIND) ("1,F" FN \\TEDIT.DK.FIND) (ESC REDO) ("1,n" NEXT) ("1,N" NEXT) ("1,S" FN \\TEDIT.DK.SUBSTITUTE) ("1,s" FN \\TEDIT.DK.SUBSTITUTE) ("1,x" EXPAND) ("1,X" EXPAND) ("1,c" FN \\TEDIT.CENTER.SEL) ("1,C" FN \\TEDIT.CENTER.SEL.REV) ("1,b" FN \\TEDIT.BOLD.SEL.ON) ("1,B" FN \\TEDIT.BOLD.SEL.OFF) ("1,i" FN \\TEDIT.ITALIC.SEL.ON) ("1,I" FN \\TEDIT.ITALIC.SEL.OFF) ("1,=" FN \\TEDIT.STRIKEOUT.SEL.ON) ("1,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) ("1,-" FN \\TEDIT.UNDERLINE.SEL.ON) ("1,_" FN \\TEDIT.UNDERLINE.SEL.OFF) ("1,^" FN \\TEDIT.SUBSCRIPTSEL) ("1,|" FN \\TEDIT.SUPERSCRIPTSEL) ("1,SPACE" FN \\TEDIT.DEFAULTSSEL) ("1,?" FN \\TEDIT.SHOWCARETLOOKS) ("1,(" FN \\TEDIT.DK.INSERT-PARENS) ("1,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) ("1,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)))) (P (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))))) (FILESLOAD TEDITDCL TEDITFNKEYS) (* |;;| "These functions were fixed after Lyric went out so they'll ignore the meta key being down." ) (DEFINEQ (\\TEDIT.BOLD.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* \; "Edited 20-Oct-87 10:42 by jds") (\\TEDIT.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL))) (\\TEDIT.BOLD.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 10:42 by jds") (\\TEDIT.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL))) (\\TEDIT.CENTER.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 24-Sep-87 10:07 by jds") (* |;;| "makes the current paragraph centered") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (|fetch| CH# |of| SEL)) (SAVEDCH (|fetch| DCH |of| SEL))) (|for| PARA |in| (\\PARAS.IN.SEL SEL TEXTOBJ) |do| (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) (SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT))))) (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (|push| NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T)))))) (\\TEDIT.CENTER.SEL.REV (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 24-Sep-87 10:07 by jds") (* |;;| "acts like center.sel but cycles in the opposite direction") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (|fetch| CH# |of| SEL)) (SAVEDCH (|fetch| DCH |of| SEL))) (|for| PARA |in| (\\PARAS.IN.SEL SEL TEXTOBJ) |do| (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) (SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT))))) (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (|push| NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T)))))) (\\TEDIT.DEFAULTS.CARET (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 11:24") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (|create| CHARLOOKS |using| TEDIT.DEFAULT.CHARLOOKS)) (\\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)))) (\\TEDIT.DEFAULTSSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:12 by jds") (* |acts| |on| |the| |selection|) (TEDIT.LOOKS TEXTSTREAM (|create| CHARLOOKS |using| TEDIT.DEFAULT.CHARLOOKS) SEL))) (\\TEDIT.SETDEFAULT.FROM.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| " 8-Nov-85 15:22") (* |Set| |the| |defaults| |from| |the|  |current| |selection.|) (PROG ((LOOKS (TEDIT.GET.LOOKS TEXTSTREAM SEL))) (SETQ TEDIT.DEFAULT.CHARLOOKS (\\TEDIT.PARSE.CHARLOOKS.LIST LOOKS))))) (\\TEDIT.FIND (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 28-Oct-87 19:35 by jds") (* |;;| "ENCAPSULATION FOR FIND KEY") (* |;;| "just calls the normal tedit.find starting at the right of the current selection") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* \;  "Case sensitive search, with * and # wildcards") (SETQ W (CAR (|fetch| \\WINDOW |of| TEXTOBJ))) (SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING ) (CHARCODE (EOL LF ESC)))) (COND (TARGET (SETQ SEL (|fetch| SEL |of| TEXTOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* \; "We found the target text.") (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (|replace| CH# |of| SEL |with| (CAR CH)) (* \;  "Set up SELECTION to be the found text") (|replace| CHLIM |of| SEL |with| (ADD1 (CADR CH))) (|replace| DCH |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (|replace| POINT |of| SEL |with| 'RIGHT) (|replace| CARETLOOKS |of| TEXTOBJ |with| (\\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \; "And never pending a deletion.") (\\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* \; "And get it into the window") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\\SHOWSEL SEL NIL T))))) (|replace| \\INSERTNEXTCH |of| TEXTOBJ |with| -1)))) (\\TEDIT.ITALIC.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* \; "Edited 20-Oct-87 10:43 by jds") (\\TEDIT.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL))) (\\TEDIT.ITALIC.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 10:43 by jds") (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL))) (\\TEDIT.LARGERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\\TEDIT.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT 2) SEL))))) (\\TEDIT.LCASE.SEL (LAMBDA (STREAM TEXTOBJ SEL) (* \; "Edited 3-Sep-87 10:49 by jds") (* |;;| "LOWER-CASEs the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (|fetch| CH# |of| SEL)) (LEN (|fetch| DCH |of| SEL)) (POINT (|fetch| POINT |of| SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (|replace| (TEDITHISTORYEVENT THACTION) |of| (|fetch| (TEXTOBJ TXTHISTORY) |of| TEXTOBJ) |with| '|LowerCase|)))) (\\TEDIT.SHOWCARETLOOKS (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |gbn| "30-Jan-85 16:06") (* * |comment|) (PROG ((LOOKS (|fetch| CARETLOOKS |of| TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\\TK.DESCRIBEFONT (|fetch| CLFONT |of| LOOKS)) (COND ((AND (|fetch| CLOFFSET |of| LOOKS) (NEQ (|fetch| CLOFFSET |of| LOOKS) 0)) (CONCAT " offset " (|fetch| CLOFFSET |of| LOOKS))) (T "")) (COND ((|fetch| CLOLINE |of| LOOKS) " overlined") (T "")) (COND ((|fetch| CLULINE |of| LOOKS) " underlined") (T ""))) T) (RETURN)))) (\\TEDIT.SMALLERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\\TEDIT.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT -2) SEL))))) (\\TEDIT.SUBSCRIPTSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:12 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT -2) SEL))) (\\TEDIT.SUPERSCRIPTSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:13 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT 2) SEL))) (\\TEDIT.UCASE.SEL (LAMBDA (STREAM TEXTOBJ SEL) (* \; "Edited 3-Sep-87 10:53 by jds") (* \; "uppercasifies the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (|fetch| CH# |of| SEL)) (LEN (|fetch| DCH |of| SEL)) (POINT (|fetch| POINT |of| SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (|replace| (TEDITHISTORYEVENT THACTION) |of| (|fetch| (TEXTOBJ TXTHISTORY) |of| TEXTOBJ) |with| '|UpperCase|)))) (\\TEDIT.UNDERLINE.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:26 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL))) (\\TEDIT.UNDERLINE.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL))) (\\TEDIT.STRIKEOUT.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT ON) SEL))) (\\TEDIT.STRIKEOUT.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT OFF) SEL))) ) (* |;;| "Specialized functions for this module") (DEFINEQ (\\TEDIT.DK.ABORT (LAMBDA (TEXTOBJ) (TEDIT.GET TEXTOBJ))) (\\TEDIT.DK.FIND (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 28-Oct-87 18:25 by jds") (* |;;| "FIND command for TEDITDORADOKEYS: Offers you the current selected text if there is not any other cached text to offer. Otherwise, behaves just like the FIND button of the 1186.") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* |;;| "Case sensitive search, with * and # wildcards") (SETQ W (CAR (MKLIST (|fetch| \\WINDOW |of| TEXTOBJ)))) (SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (OR (WINDOWPROP W ' TEDIT.LAST.FIND.STRING) (TEDIT.SEL.AS.STRING TEXTSTREAM SEL)) (CHARCODE (EOL LF ESC)))) (COND (TARGET (SETQ SEL (|fetch| SEL |of| TEXTOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* \; "We found the target text.") (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (|replace| CH# |of| SEL |with| (CAR CH)) (* \;  "Set up SELECTION to be the found text") (|replace| CHLIM |of| SEL |with| (ADD1 (CADR CH))) (|replace| DCH |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (|replace| POINT |of| SEL |with| 'RIGHT) (|replace| CARETLOOKS |of| TEXTOBJ |with| (\\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \; "And never pending a deletion.") (\\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* \; "And get it into the window") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\\SHOWSEL SEL NIL T))))) (|replace| \\INSERTNEXTCH |of| TEXTOBJ |with| -1)))) (\\TEDIT.DK.SUBSTITUTE (LAMBDA (TEXTSTREAM) (* \; "Edited 28-Oct-87 19:35 by jds") (* |;;| "KEYBOARD SUBSTITUTE INTERFACE for TEDITDORADOKEYS") (TEDIT.SUBSTITUTE TEXTSTREAM))) (\\TEDIT.DK.INSERT-PARENS (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:42 by jds") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM ")" CHLIM) (TEDIT.INSERT TEXTSTREAM "(" CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) (\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:45 by jds") (* |;;| "Insert ASCII double-quotes (\") around the selection") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM "\"" CHLIM) (TEDIT.INSERT TEXTSTREAM "\"" CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:44 by jds") (* |;;| "Insert NS double quotes around the selection.") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,252) CHLIM) (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,272) CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) ) (RPAQQ \\TEDIT.DORADO.KEYS (("1,a" FN \\TEDIT.DK.ABORT) ("1,A" FN \\TEDIT.DK.ABORT) ("1,U" UNDO) ("1,u" UNDO) ("1,f" FN \\TEDIT.DK.FIND) ("1,F" FN \\TEDIT.DK.FIND) (ESC REDO) ("1,n" NEXT) ("1,N" NEXT) ("1,S" FN \\TEDIT.DK.SUBSTITUTE) ("1,s" FN \\TEDIT.DK.SUBSTITUTE) ("1,x" EXPAND) ("1,X" EXPAND) ("1,c" FN \\TEDIT.CENTER.SEL) ("1,C" FN \\TEDIT.CENTER.SEL.REV) ("1,b" FN \\TEDIT.BOLD.SEL.ON) ("1,B" FN \\TEDIT.BOLD.SEL.OFF) ("1,i" FN \\TEDIT.ITALIC.SEL.ON) ("1,I" FN \\TEDIT.ITALIC.SEL.OFF) ("1,=" FN \\TEDIT.STRIKEOUT.SEL.ON) ("1,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) ("1,-" FN \\TEDIT.UNDERLINE.SEL.ON) ("1,_" FN \\TEDIT.UNDERLINE.SEL.OFF) ("1,^" FN \\TEDIT.SUBSCRIPTSEL) ("1,|" FN \\TEDIT.SUPERSCRIPTSEL) ("1,SPACE" FN \\TEDIT.DEFAULTSSEL) ("1,?" FN \\TEDIT.SHOWCARETLOOKS) ("1,(" FN \\TEDIT.DK.INSERT-PARENS) ("1,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) ("1,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES))) (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY)))) (PUTPROPS TEDITDORADOKEYS COPYRIGHT ("Xerox Corporation" 1987 2018)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4082 15770 (\\TEDIT.BOLD.SEL.OFF 4092 . 4330) (\\TEDIT.BOLD.SEL.ON 4332 . 4566) ( \\TEDIT.CENTER.SEL 4568 . 5638) (\\TEDIT.CENTER.SEL.REV 5640 . 6735) (\\TEDIT.DEFAULTS.CARET 6737 . 7029) (\\TEDIT.DEFAULTSSEL 7031 . 7369) (\\TEDIT.SETDEFAULT.FROM.SEL 7371 . 7828) (\\TEDIT.FIND 7830 . 10691) (\\TEDIT.ITALIC.SEL.OFF 10693 . 10935) (\\TEDIT.ITALIC.SEL.ON 10937 . 11123) ( \\TEDIT.LARGERSEL 11125 . 11420) (\\TEDIT.LCASE.SEL 11422 . 12138) (\\TEDIT.SHOWCARETLOOKS 12140 . 13523) (\\TEDIT.SMALLERSEL 13525 . 13823) (\\TEDIT.SUBSCRIPTSEL 13825 . 14032) (\\TEDIT.SUPERSCRIPTSEL 14034 . 14242) (\\TEDIT.UCASE.SEL 14244 . 15000) (\\TEDIT.UNDERLINE.SEL.OFF 15002 . 15193) ( \\TEDIT.UNDERLINE.SEL.ON 15195 . 15384) (\\TEDIT.STRIKEOUT.SEL.ON 15386 . 15575) ( \\TEDIT.STRIKEOUT.SEL.OFF 15577 . 15768)) (15828 20622 (\\TEDIT.DK.ABORT 15838 . 15905) ( \\TEDIT.DK.FIND 15907 . 18936) (\\TEDIT.DK.SUBSTITUTE 18938 . 19195) (\\TEDIT.DK.INSERT-PARENS 19197 . 19584) (\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES 19586 . 20078) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES 20080 . 20620))))) STOP \ No newline at end of file diff --git a/lispusers/TEDITDORADOKEYS.DATABASE b/lispusers/TEDITDORADOKEYS.DATABASE new file mode 100644 index 00000000..ec2c42ca --- /dev/null +++ b/lispusers/TEDITDORADOKEYS.DATABASE @@ -0,0 +1 @@ +(PROGN (PRIN1 "Use LOADDB to load database files! " T) (ERROR!)) ("28-Oct-87 19:53:12" . {ERINYES}LYRIC>TEDITDORADOKEYS.;2) FNS (\TEDIT.BOLD.SEL.OFF \TEDIT.BOLD.SEL.ON \TEDIT.CENTER.SEL \TEDIT.CENTER.SEL.REV \TEDIT.DEFAULTS.CARET \TEDIT.DEFAULTSSEL \TEDIT.SETDEFAULT.FROM.SEL \TEDIT.FIND \TEDIT.ITALIC.SEL.OFF \TEDIT.ITALIC.SEL.ON \TEDIT.LARGERSEL \TEDIT.LCASE.SEL \TEDIT.SHOWCARETLOOKS \TEDIT.SMALLERSEL \TEDIT.SUBSCRIPTSEL \TEDIT.SUPERSCRIPTSEL \TEDIT.UCASE.SEL \TEDIT.UNDERLINE.SEL.OFF \TEDIT.UNDERLINE.SEL.ON \TEDIT.STRIKEOUT.SEL.ON \TEDIT.STRIKEOUT.SEL.OFF \TEDIT.DK.ABORT \TEDIT.DK.FIND \TEDIT.DK.SUBSTITUTE \TEDIT.DK.INSERT-PARENS \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES) (READATABASE) ( CALL \TEDIT.BOLD.SEL.OFF (TEDIT.LOOKS) \TEDIT.BOLD.SEL.ON (TEDIT.LOOKS) \TEDIT.CENTER.SEL (FETCHFIELD \PARAS.IN.SEL TEDIT.GET.PARALOOKS LISTGET MEMB CONSTANT TEDIT.SETSEL CONS DREVERSE) \TEDIT.CENTER.SEL.REV (FETCHFIELD \PARAS.IN.SEL TEDIT.GET.PARALOOKS LISTGET MEMB CONSTANT TEDIT.SETSEL CONS DREVERSE) \TEDIT.DEFAULTS.CARET (NCREATE \TEDIT.SHOWCARETLOOKS) \TEDIT.DEFAULTSSEL (TEDIT.LOOKS NCREATE) \TEDIT.SETDEFAULT.FROM.SEL (TEDIT.GET.LOOKS \TEDIT.PARSE.CHARLOOKS.LIST) \TEDIT.FIND (TEXTOBJ FETCHFIELD TEDIT.GETINPUT WINDOWPROP TEDIT.FIND MKSTRING ADD1 IDIFFERENCE \TEDIT.GET.INSERT.CHARLOOKS ) \TEDIT.ITALIC.SEL.OFF (TEDIT.LOOKS) \TEDIT.ITALIC.SEL.ON (TEDIT.LOOKS) \TEDIT.LARGERSEL ( \TEDIT.LARGER.CARET TEDIT.LOOKS LIST) \TEDIT.LCASE.SEL (TEDIT.SEL.AS.STRING FETCHFIELD L-CASE RPLACA) \TEDIT.SHOWCARETLOOKS (FETCHFIELD CONCAT \TK.DESCRIBEFONT) \TEDIT.SMALLERSEL (\TEDIT.SMALLER.CARET TEDIT.LOOKS LIST) \TEDIT.SUBSCRIPTSEL (TEDIT.LOOKS LIST) \TEDIT.SUPERSCRIPTSEL (TEDIT.LOOKS LIST) \TEDIT.UCASE.SEL (TEDIT.SEL.AS.STRING FETCHFIELD U-CASE RPLACA) \TEDIT.UNDERLINE.SEL.OFF (TEDIT.LOOKS) \TEDIT.UNDERLINE.SEL.ON (TEDIT.LOOKS) \TEDIT.STRIKEOUT.SEL.ON (TEDIT.LOOKS) \TEDIT.STRIKEOUT.SEL.OFF (TEDIT.LOOKS) \TEDIT.DK.ABORT (TEDIT.GET) \TEDIT.DK.FIND (TEXTOBJ MKLIST FETCHFIELD TEDIT.GETINPUT WINDOWPROP TEDIT.SEL.AS.STRING TEDIT.FIND MKSTRING ADD1 IDIFFERENCE \TEDIT.GET.INSERT.CHARLOOKS) \TEDIT.DK.SUBSTITUTE (TEDIT.SUBSTITUTE) \TEDIT.DK.INSERT-PARENS (FETCHFIELD TEDIT.SETSEL + -) \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (FETCHFIELD TEDIT.SETSEL + -) \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (FETCHFIELD TEDIT.SETSEL + -) NIL BIND \TEDIT.BOLD.SEL.OFF (CHARCODE) \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL (TEXTOBJ) \TEDIT.SETDEFAULT.FROM.SEL (TEXTOBJ) \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF (CHARCODE) \TEDIT.ITALIC.SEL.ON (TEXTOBJ) \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS (SEL) \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL (TEXTOBJ) \TEDIT.SUPERSCRIPTSEL (TEXTOBJ) \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF (TEXTOBJ) \TEDIT.UNDERLINE.SEL.ON (TEXTOBJ) \TEDIT.STRIKEOUT.SEL.ON (TEXTOBJ) \TEDIT.STRIKEOUT.SEL.OFF (TEXTOBJ) \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS (TEXTOBJ) \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (TEXTOBJ) \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (TEXTOBJ) NIL NLAMBDA \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (CHARCODE ) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND (CHARCODE) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (CHARCODE) NIL NOBIND \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL RECORD \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL ( TEDITHISTORYEVENT TEXTOBJ) \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL (TEDITHISTORYEVENT TEXTOBJ) \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL CREATE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET (CHARLOOKS) \TEDIT.DEFAULTSSEL (CHARLOOKS) \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL FETCH \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL (CH# DCH) \TEDIT.CENTER.SEL.REV (CH# DCH) \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (\WINDOW SEL) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL (CH# DCH POINT TXTHISTORY) \TEDIT.SHOWCARETLOOKS (CARETLOOKS CLFONT CLOFFSET CLOLINE CLULINE) \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL (CH# DCH POINT TXTHISTORY) \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND (\WINDOW SEL) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS (CH# CHLIM) \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (CH# CHLIM) \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (CH# CHLIM) NIL REPLACE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (CH# CHLIM DCH POINT CARETLOOKS \INSERTNEXTCH) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL (THACTION) \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL (THACTION) \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND (CH# CHLIM DCH POINT CARETLOOKS \INSERTNEXTCH) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL REFFREE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET (TEDIT.DEFAULT.CHARLOOKS) \TEDIT.DEFAULTSSEL (TEDIT.DEFAULT.CHARLOOKS) \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL REF \TEDIT.BOLD.SEL.OFF (TEXTSTREAM TEXTOBJ SEL) \TEDIT.BOLD.SEL.ON (TEXTSTREAM TEXTOBJ SEL) \TEDIT.CENTER.SEL (SEL TEXTOBJ TEXTSTREAM PARA SAVECH# SAVEDCH) \TEDIT.CENTER.SEL.REV (SEL TEXTOBJ TEXTSTREAM PARA SAVECH# SAVEDCH) \TEDIT.DEFAULTS.CARET (TEXTSTREAM TEXTOBJ SEL) \TEDIT.DEFAULTSSEL ( TEXTSTREAM SEL) \TEDIT.SETDEFAULT.FROM.SEL (TEXTSTREAM SEL LOOKS) \TEDIT.FIND (TEXTSTREAM) \TEDIT.ITALIC.SEL.OFF (TEXTSTREAM TEXTOBJ SEL) \TEDIT.ITALIC.SEL.ON (TEXTSTREAM SEL) \TEDIT.LARGERSEL (TEXTSTREAM TEXTOBJ SEL) \TEDIT.LCASE.SEL (STREAM SEL STR POS LEN POINT TEXTOBJ) \TEDIT.SHOWCARETLOOKS (TEXTOBJ TEXTSTREAM LOOKS) \TEDIT.SMALLERSEL (TEXTSTREAM TEXTOBJ SEL) \TEDIT.SUBSCRIPTSEL (TEXTSTREAM SEL) \TEDIT.SUPERSCRIPTSEL (TEXTSTREAM SEL) \TEDIT.UCASE.SEL (STREAM SEL STR POS LEN POINT TEXTOBJ) \TEDIT.UNDERLINE.SEL.OFF (TEXTSTREAM SEL) \TEDIT.UNDERLINE.SEL.ON (TEXTSTREAM SEL) \TEDIT.STRIKEOUT.SEL.ON (TEXTSTREAM SEL) \TEDIT.STRIKEOUT.SEL.OFF (TEXTSTREAM SEL) \TEDIT.DK.ABORT ( TEXTOBJ) \TEDIT.DK.FIND (TEXTSTREAM) \TEDIT.DK.SUBSTITUTE (TEXTSTREAM) \TEDIT.DK.INSERT-PARENS (SEL TEXTSTREAM CHLIM CH1) \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (SEL TEXTSTREAM CHLIM CH1) \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (SEL TEXTSTREAM CHLIM CH1) NIL SETFREE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL (TEDIT.DEFAULT.CHARLOOKS) \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL SET \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL (LOOKS OLDQUAD NEWQUAD PARASEL NEWQUADS) \TEDIT.CENTER.SEL.REV (LOOKS OLDQUAD NEWQUAD PARASEL NEWQUADS) \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (W TARGET SEL CH) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND (W TARGET SEL CH) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL SMASHFREE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL SMASH \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL (NEWQUADS) \TEDIT.CENTER.SEL.REV (NEWQUADS) \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (SEL TEXTOBJ) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND (SEL TEXTOBJ) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL PROP \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL (QUAD) \TEDIT.CENTER.SEL.REV ( QUAD) \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND ( TEDIT.LAST.FIND.STRING) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND ( TEDIT.LAST.FIND.STRING) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL TEST \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (TARGET CH ) \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND (TARGET CH) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL TESTFREE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL (TEDIT.FNKEY.VERBOSE) \TEDIT.CENTER.SEL.REV (TEDIT.FNKEY.VERBOSE) \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL PREDICATE \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL (SHIFTDOWNP) \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL (SHIFTDOWNP) \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL EFFECT \TEDIT.BOLD.SEL.OFF (\TEDIT.BOLD.CARET.OFF) \TEDIT.BOLD.SEL.ON (\TEDIT.BOLD.CARET.ON) \TEDIT.CENTER.SEL (MAPC LISTPUT TEDIT.PARALOOKS TEDIT.PROMPTPRINT) \TEDIT.CENTER.SEL.REV (MAPC LISTPUT TEDIT.PARALOOKS TEDIT.PROMPTPRINT) \TEDIT.DEFAULTS.CARET (TEDIT.CARETLOOKS) \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND (\SHOWSEL TEDIT.PROMPTPRINT REPLACEFIELD TEDIT.RESET.EXTEND.PENDING.DELETE \FIXSEL TEDIT.NORMALIZECARET) \TEDIT.ITALIC.SEL.OFF ( \TEDIT.ITALIC.CARET.OFF) \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL (TEDIT.DELETE TEDIT.INSERT TEDIT.SETSEL TEDIT.NORMALIZECARET) \TEDIT.SHOWCARETLOOKS (TEDIT.PROMPTPRINT) \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL (TEDIT.DELETE TEDIT.INSERT TEDIT.SETSEL TEDIT.NORMALIZECARET) \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND ( \SHOWSEL TEDIT.PROMPTPRINT REPLACEFIELD TEDIT.RESET.EXTEND.PENDING.DELETE \FIXSEL TEDIT.NORMALIZECARET ) \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS (TEDIT.INSERT) \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (TEDIT.INSERT) \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (TEDIT.INSERT) NIL CLISP \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL (for in do) \TEDIT.CENTER.SEL.REV (for in do) \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL SPECVARS \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL LOCALVARS \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL APPLY \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL ERROR \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL LOCALFREEVARS \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL ARGS \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL USERTEMPLATES SETQ.NOREF (CALL SET EVAL . PPE) WINDOWADDPROP (CALL EVAL PROP EVAL EVAL . PPE) SPREADAPPLY* (CALL FUNCTIONAL |..| EVAL) WINDOWPROP (CALL EVAL PROP EVAL . PPE) PERFORM (MACRO ARGS ( PERFORMTRAN ARGS T)) CATCH (CALL CALL CALL |..| EVAL) REF (CALL EVAL (IF (AND (CONSP EXPR) (EQ (CAR EXPR) (QUOTE QUOTE))) (NIL FETCH) EVAL)) DOVEIO.LOCKMEM (CALL |..| EVAL) \DoveIO.LockMem (CALL |..| EVAL) SCRATCHASH MACRO \\\\DoveIO.LockMem (CALL |..| EVAL) WINDOWDELPROP (CALL EVAL PROP EVAL . PPE) perform (MACRO ARGS (PERFORMTRAN ARGS T)) \\DoveIO.LockMem (CALL |..| EVAL) TESTRELQ MACRO GETRELQ MACRO SPREADAPPLY (CALL FUNCTIONAL EVAL . PPE) RUN-SUPER (CALL |..| EVAL) UNINTERRUPTABLY (CALL |..| EVAL) SHAZAM (CALL |..| NIL) OP# (CALL) NIL 0 \TEDIT.BOLD.SEL.OFF NIL \TEDIT.BOLD.SEL.ON NIL \TEDIT.CENTER.SEL NIL \TEDIT.CENTER.SEL.REV NIL \TEDIT.DEFAULTS.CARET NIL \TEDIT.DEFAULTSSEL NIL \TEDIT.SETDEFAULT.FROM.SEL NIL \TEDIT.FIND NIL \TEDIT.ITALIC.SEL.OFF NIL \TEDIT.ITALIC.SEL.ON NIL \TEDIT.LARGERSEL NIL \TEDIT.LCASE.SEL NIL \TEDIT.SHOWCARETLOOKS NIL \TEDIT.SMALLERSEL NIL \TEDIT.SUBSCRIPTSEL NIL \TEDIT.SUPERSCRIPTSEL NIL \TEDIT.UCASE.SEL NIL \TEDIT.UNDERLINE.SEL.OFF NIL \TEDIT.UNDERLINE.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.ON NIL \TEDIT.STRIKEOUT.SEL.OFF NIL \TEDIT.DK.ABORT NIL \TEDIT.DK.FIND NIL \TEDIT.DK.SUBSTITUTE NIL \TEDIT.DK.INSERT-PARENS NIL \TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES NIL \TEDIT.DK.INSERT-REAL-DOUBLEQUOTES NIL NIL ) \ No newline at end of file diff --git a/lispusers/TEDITKEY b/lispusers/TEDITKEY new file mode 100644 index 00000000..3c84e4d9 --- /dev/null +++ b/lispusers/TEDITKEY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Nov-87 14:55:24" {ERINYES}LISPCORE>TEDITKEY.;1 95396 changes to%: (VARS TEDITKEYCOMS) previous date%: " 1-Apr-86 22:36:26" {ERINYES}LYRIC>LISPUSERS>TEDITKEY.;1) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITKEYCOMS) (RPAQQ TEDITKEYCOMS [(COMS (* ;;; "This is the Lyric-and-later version of TEditKey") ) (COMS (* ;  "functions for affecting the selection") (FNS NTHCAR \TEXTOBJ.WINDEX \TK.PREVSCREEN \TK.UNDERLINE.SEL.ON \TK.UNDERLINE.SEL.OFF \TK.BOLD.SEL.ON \TK.BOLD.SEL.OFF \TK.ITALIC.SEL.ON \TK.ITALIC.SEL.OFF \TK.SMALLERSEL \TK.LARGERSEL \TK.SUPERSCRIPTSEL \TK.SUBSCRIPTSEL \TK.DEFAULTSSEL \TK.DEL.WORD.FORWARD \TK.UCASE.SEL \TK.CAPITALISE.SEL \CAPITALISE \TK.LCASE.SEL) (* ;  "functions for affecting the paralooks of the selection") (FNS \TK.CENTER.SEL \TK.CENTER.SEL.REV \TK.NEST \TK.UNNEST)) (COMS (* ;  "functions for affecting (and displaying) the caret character looks") (FNS \TK.SHOWCARETLOOKS \TK.BOLD.CARET.ON \TK.BOLD.CARET.OFF \TK.ITALIC.CARET.ON \TK.ITALIC.CARET.OFF \TK.UNDERLINE.CARET.ON \TK.UNDERLINE.CARET.OFF \TK.SUPERSCRIPT.CARET \TK.SUBSCRIPT.CARET \TK.SMALLER.CARET \TK.LARGER.CARET \TK.DEFAULTS.CARET \TK.FONT1 \TK.FONT2 \TK.FONT3 \TK.SETCARETFONT \TK.FONT4 \TK.FONT5 \TK.FONT6 \TK.FONT7 \TK.FONT8) (* ;  "the functions which aren't currently used, which toggle the caret looks") (FNS \TK.BOLDTOGGLE \TK.ITALICTOGGLE \TK.UNDERLINETOGGLE)) (COMS (* ;  "functions dealing with the default looks") (FNS \TK.SETDEFAULTLOOKS)) (COMS (* ;  "functions for positioning within a document") (FNS GOTONEXTTTYWINDOW \TK.NEXTLINE \TK.PREVLINE \TK.GOTODOCBEGIN \TK.GOTODOCEND \TK.GOTOLINEBEGIN \TK.GOTOLINEEND \TK.PREVCHAR \TK.NEXTCHAR \TK.FORWARD.WORD \TK.BACK.WORD \TK.SELECT.ALL)) (COMS (* ; "other utilities") (FNS \TK.FIND \TK.REDISPLAY \TK.DELLINEFORWARD \TK.OPENLINE \TK.DELCHARFORWARD \TK.TRANSPOSECHARS)) (COMS (* ;  "little selection utilities etc., for building hacks") (FNS \SEL.LIMIT \TK.SETFILEPTR.TO.CARET \SEL.LINEDESC) (MACROS \SEL.LIMIT.FORWARD \TK.ONOROFF \LINEDESC.LAST.REAL.CHAR)) (COMS (* ; "fns for the key interface itself") (FNS \SHIFTACTION \ACTION TEDITKEY.INSTALL TEDITKEY.DEINSTALL \TK.ACTIONTOCHARCODE \TK.BUILD.MENU \TK.HELP \TK.SETFONTINLOOKS WRITE.CHARDESC.AUX CHARDESC TEDITKEY.CONFIGURE \TK.ADDKEY \TK.CHANGEKEY \TK.APPLYPENDING \TK.NTHFONT) (* ; "redefinition of system junk") (FNS METASHIFT)) (* ;; "(\TK.BOLDTOGGLE (##H ##h) 'toggle Bold caret looks') (\TK.ITALICTOGGLE (##i ##I) 'toggle Italic caret looks') (\TK.SUPERSCRIPT.CARET (##^) 'Superscript the caret looks') (\TK.SUBSCRIPT.CARET (##_) 'Subscript the caret looks')") (FNS TEDIT.FULL.FIND) [VARS \TK.WHITESPACE (TEDIT.INTERRUPTS `((%, (CHARCODE ^G) ERROR) (%, (CHARCODE ^C) HELP] (CONSTANTS (\TK.WHITESPACE 22)) (INITVARS (TEDITKEY.VERBOSE T) (TEDITKEY.METAKEY 'TAB) (TEDITKEY.LOCKTOGGLEKEY NIL) (TEDITKEY.NESTWIDTH 36) (\TK.SIZEINCREMENT 2) (TEDITKEY.OFFSETINCREMENT 3) (TEDITKEY.FONTS '(TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL SYMBOL HIPPO)) (TEDITKEY.FNKEYFLG T)) (MACROS METACODE CONTROLCODE LCMETACODE) (INITVARS (\TK.SELKEY 'OPEN) (\TK.PENDING)) [INITVARS [TEDITKEY.KEYBINDINGS `((\TK.FONT1 (%##1) %, (CONCAT "change to font " (\TK.NTHFONT 1))) (\TK.FONT2 (%##2) %, (CONCAT "change to font " (\TK.NTHFONT 2))) (\TK.FONT3 (%##3) %, (CONCAT "change to font " (\TK.NTHFONT 3))) (\TK.FONT4 (%##4) %, (CONCAT "change to font " (\TK.NTHFONT 4))) (\TK.FONT5 (%##5) %, (CONCAT "change to font " (\TK.NTHFONT 5))) (\TK.FONT6 (%##6) %, (CONCAT "change to font " (\TK.NTHFONT 6))) (\TK.FONT7 (%##7) %, (CONCAT "change to font " (\TK.NTHFONT 7))) (\TK.FONT8 (%##8) %, (CONCAT "change to font " (\TK.NTHFONT 8))) NIL (\TK.DEFAULTS.CARET (%##/) "restore the default caret looks") (\TK.SMALLER.CARET (%##9) "decrease the caret font size") (\TK.LARGER.CARET (%##0) "increase the caret font size") (\TK.SHOWCARETLOOKS (%##=) "display the current caret looks") NIL (\TK.REDISPLAY (%##R %##r) "Restore the display") (\TK.HELP (%##?) "displays the current key bindings") NIL (\TK.PREVCHAR (^B ^b) "Back one character") (\TK.NEXTCHAR (^F ^f) "Forward one character") (\TK.FORWARD.WORD (%##F %##f) "Forward one word") (\TK.BACK.WORD (%##B %##b) "Back one word") (\TK.GOTOLINEBEGIN (^A ^a) "go to stArt of line") (\TK.GOTOLINEEND (^E ^e) "go to End of line") (\TK.PREVLINE (^P ^p) "go to Previous line") (\TK.NEXTLINE (^N ^n) "go to Next line") (\TK.GOTODOCBEGIN (%##<) "start of document") (\TK.GOTODOCEND (%##>) "end of document") (\TK.SELECT.ALL (%##S %##s) "Select whole document") NIL (\TK.DELLINEFORWARD (^K ^k) "Kill line") (\TK.OPENLINE (^O ^o) "Open up blank line") (\TK.DELCHARFORWARD (^D ^d) "Delete character forward") (\TK.DEL.WORD.FORWARD (%##D %##d) "Delete word forward") (\TK.TRANSPOSECHARS (^T ^t) "Transpose characters") NIL NIL (\TK.NEST (|##[|) "indents margins (nest)") (\TK.UNNEST (|##]|) "exdents margins (unnest)") (\TK.CENTER.SEL (%##J %##j) "alter Justification") (\TK.UCASE.SEL (%##U %##u) "Uppercasify selection") (\TK.CAPITALISE.SEL (%##C %##c) "Capitalize selection") (\TK.LCASE.SEL (%##L %##l) "Lowercasify selection") (GET.OBJ.FROM.USER (%##O %##o) "insert Object"] [TEDITKEY.DLION.KEYACTIONS `((STOP (%, (CHARCODE ^G) %, (CHARCODE ^C) NOLOCKSHIFT)) (OPEN (%, (CHARCODE 2,1) %, (CHARCODE 2,41) NOLOCKSHIFT)) (FONT FONTDOWN . FONTUP) (KEYBOARD USERMODE1DOWN . USERMODE1UP] (COMS (* ;; "(TEDITKEY.FNKEYACTIONS (BQUOTE ((CENTER (, (CHARCODE ##^B), (CHARCODE ##^C))) (BOLD (, (CHARCODE ##^D), (CHARCODE ##^E) NOLOCKSHIFT)) (ITALICS (, (CHARCODE ##^F), (CHARCODE ##^G) NOLOCKSHIFT)) (UNDERLINE (, (CHARCODE ##^H), (CHARCODE ##^I) NOLOCKSHIFT)) (SUPERSCRIPT (, (CHARCODE ##^J), (CHARCODE ##^K) NOLOCKSHIFT)) (SUBSCRIPT (, (CHARCODE ##^L), (CHARCODE ##^N) NOLOCKSHIFT)) (LARGER (, (CHARCODE ##^O), (CHARCODE ##^P) NOLOCKSHIFT)) (DEFAULTS (, (CHARCODE ##^Q), (CHARCODE ##^R) NOLOCKSHIFT)) (BS (, (CHARCODE ^H), (CHARCODE ^D) NOLOCKSHIFT)))))") ) [TEDITKEY.DLION.KEYBINDINGS '(((\ACTION 'OPEN) \TK.OPENLINE) ((\ACTION 'HELP) \TK.HELP) ((\ACTION 'MARGINS) \TK.NEST) ((\SHIFTACTION 'MARGINS) \TK.UNNEST) ((\SHIFTACTION 'NEXT) GOTONEXTTTYWINDOW] [TEDITKEY.FNKEYBINDINGS '(((\ACTION 'DEFAULTS) \TK.DEFAULTSSEL) ((\SHIFTACTION 'DEFAULTS) \TK.SETDEFAULTLOOKS] (COMS (* ;; "NOT NEEDED (TEDITKEY.DLION.KEYSYNTAX (QUOTE (((\ACTION (QUOTE NEXT)) NEXT) ((\ACTION (QUOTE UNDO)) UNDO) ((\ACTION (QUOTE BS)) CHARDELETE))))") ) [TEDITKEY.DORADO.KEYACTIONS `((BS (%, (CHARCODE ^H) %, (CHARCODE ^H))) (BLANK-BOTTOM (%, (CHARCODE %##^A) %, (CHARCODE %##^A))) (BLANK-TOP FONTDOWN . FONTUP) (BLANK-MIDDLE USERMODE1DOWN . USERMODE1UP) (CENTER (2,101 2,141 NOLOCKSHIFT)) (BOLD (2,102 2,142 NOLOCKSHIFT)) (ITALICS (2,103 2,143 NOLOCKSHIFT)) (UNDERLINE (2,106 2,146 NOLOCKSHIFT)) (SUPERSCRIPT (2,113 2,153 NOLOCKSHIFT)) (SUBSCRIPT (2,114 2,154 NOLOCKSHIFT)) (LARGER (2,110 2,150 NOLOCKSHIFT)) (DEFAULTS (2,115 2,155 NOLOCKSHIFT] (TEDITKEY.DORADO.KEYSYNTAX '(((CHARCODE %##N) NEXT) ((CHARCODE %##n) NEXT) ((\ACTION 'BLANK-BOTTOM) UNDO) ((\ACTION 'BS) CHARDELETE] (P (TEDITKEY.INSTALL)) (P (\TK.BUILD.MENU)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA METASHIFT]) (* ;;; "This is the Lyric-and-later version of TEditKey") (* ; "functions for affecting the selection") (DEFINEQ (NTHCAR [LAMBDA (LIST N) (* gbn "10-Oct-85 20:54") (CAR (NTH LIST N]) (\TEXTOBJ.WINDEX [LAMBDA (TEXTOBJ) (* gbn "10-Oct-85 20:51") (* * returns the number which is the position in the list textobj%:\window  indicating which window had the last selection in it.  This number is then an index into line descriptor lists etc.) (bind (CURW _ (fetch SELWINDOW of TEXTOBJ)) for J from 1 as W in (fetch \WINDOW of TEXTOBJ) until (EQ W CURW) do NIL finally (RETURN J]) (\TK.PREVSCREEN [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "10-Oct-85 00:10") (* moves the selection up one line) (PROG (THIS PREV) (* get the selection on the screen so that it has a line descriptor) (TEDIT.NORMALIZECARET STREAM SEL) (if [SETQ THIS (CAR (MKLIST (fetch L1 of SEL] then (* empty docs have no line descriptors) (SETQ PREV (fetch PREVLINE of THIS)) [if (ZEROP (fetch CHARLIM of PREV)) then (* we need to back format because this is a fake line descriptor) (\BACKFORMAT (CAR (fetch LINES of TEXTOBJ)) TEXTOBJ (fetch SELWINDOW of TEXTOBJ)) (SETQ PREV (fetch PREVLINE of THIS)) (* (SETQ PREV (replace PREVLINE of  THIS with (\FORMATLINE TEXTOBJ NIL  (ADD1 (fetch CHARLIM of THIS))))))] (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of PREV) (IDIFFERENCE (\SEL.LIMIT SEL) (fetch CHAR1 of THIS))) (fetch CHARLIM of PREV)) 0]) (\TK.UNDERLINE.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:01") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT4 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.UNDERLINE.CARET.ON TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.underlineon which happens when neither Keyboard  nor font is held) (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL]) (\TK.UNDERLINE.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:01") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT4 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.UNDERLINE.CARET.OFF TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.underlineon which happens when neither Keyboard  nor font is held) (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL]) (\TK.BOLD.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:01") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT2 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.boldon which happens when neither Keyboard nor  font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL]) (\TK.BOLD.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* gbn "19-Mar-85 12:02") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT2 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.boldon which happens when neither Keyboard nor  font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL]) (\TK.ITALIC.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:02") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT3 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.ITALIC.CARET.ON TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL]) (\TK.ITALIC.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* gbn "19-Mar-85 12:02") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT3 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL]) (\TK.SMALLERSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:47") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT7 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither  Keyboard nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT (IMINUS \TK.SIZEINCREMENT)) SEL]) (\TK.LARGERSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:47") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT7 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.LARGER.SEL which happens when neither Keyboard  nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT \TK.SIZEINCREMENT) SEL]) (\TK.SUPERSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:56") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT5 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither  Keyboard nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT TEDITKEY.OFFSETINCREMENT) SEL]) (\TK.SUBSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:42") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT6 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither  Keyboard nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT (MINUS TEDITKEY.OFFSETINCREMENT)) SEL]) (\TK.DEFAULTSSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:55") (* acts on the selection) (COND ((SHIFTDOWNP 'FONT) (\TK.FONT8 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* acts on the selection) (PROG ((LOOKS (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS))) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (TEDIT.LOOKS TEXTSTREAM LOOKS SEL]) (\TK.DEL.WORD.FORWARD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:45") (* * Deletes from here to the end of the first word Refers to the syntax  classes of the characters according to the TEDIT.WORDBOUND.READTABLE) (PROG (HERE) (* position the file ptr at the (character after the) caret of the selection) (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL) (* record this position as the beginning of the word  (to make the beginning of the selection)) (SETQ HERE (ADD1 (GETFILEPTR TEXTSTREAM))) (* skip the whitespace) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ \TK.WHITESPACE (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM)) (* find out what syntax class the first letter of the word has.  The end of the word is marked by a change of syntax classes) (if (NOT (EOFP TEXTSTREAM)) then (SETQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T))) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM))) (TEDIT.SETSEL TEXTSTREAM HERE (ADD1 (IDIFFERENCE (GETFILEPTR TEXTSTREAM) HERE)) 'RIGHT) (TEDIT.DELETE TEXTSTREAM) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.UCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:46") (* uppercasifies the selection) (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch CH# of SEL)) (LEN (fetch DCH of SEL)) (POINT (fetch POINT of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.CAPITALISE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "24-Feb-86 16:57") (* capitalises the selection) (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch (SELECTION CH#) of SEL)) (LEN (fetch (SELECTION DCH) of SEL)) (POINT (fetch (SELECTION POINT) of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (\CAPITALISE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\CAPITALISE [LAMBDA (STR) (* gbn "24-Feb-86 16:56") (* * capitalises a string) (SELECTQ (NCHARS STR) (0 STR) (1 (U-CASE STR)) (CONCAT (U-CASE (NTHCHAR STR 1)) (L-CASE (SUBSTRING STR 2]) (\TK.LCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:46") (* uppercasifies the selection) (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch CH# of SEL)) (LEN (fetch DCH of SEL)) (POINT (fetch POINT of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ]) ) (* ; "functions for affecting the paralooks of the selection") (DEFINEQ (\TK.CENTER.SEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Feb-85 18:17") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT1 TEXTSTREAM TEXTOBJ SEL)) (T (* makes the current paragraph  centered) (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) (\TK.CENTER.SEL.REV [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn " 7-Jun-85 21:34") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT1 TEXTSTREAM TEXTOBJ SEL)) (T (* * acts like center.sel but cycles in the opposite direction) (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) (\TK.NEST [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Feb-85 18:24") (PROG (LOOKS (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (LISTPUT LOOKS 'LEFTMARGIN (IPLUS (LISTGET LOOKS 'LEFTMARGIN) TEDITKEY.NESTWIDTH)) (LISTPUT LOOKS '1STLEFTMARGIN (IPLUS (LISTGET LOOKS '1STLEFTMARGIN) TEDITKEY.NESTWIDTH)) (LISTPUT LOOKS 'RIGHTMARGIN (IMAX 0 (IDIFFERENCE (LISTGET LOOKS 'RIGHTMARGIN) TEDITKEY.NESTWIDTH))) (TEDIT.SETSEL TEXTSTREAM PARA 1) (TEDIT.PARALOOKS TEXTOBJ LOOKS)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH]) (\TK.UNNEST [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Feb-85 18:26") (PROG (LOOKS RIGHT (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (LISTPUT LOOKS 'LEFTMARGIN (IMAX (IDIFFERENCE (LISTGET LOOKS 'LEFTMARGIN) TEDITKEY.NESTWIDTH) 0)) (LISTPUT LOOKS '1STLEFTMARGIN (IMAX (IDIFFERENCE (LISTGET LOOKS '1STLEFTMARGIN) TEDITKEY.NESTWIDTH) 0)) (SETQ RIGHT (LISTGET LOOKS 'RIGHTMARGIN)) (if (NOT (ZEROP RIGHT)) then (LISTPUT LOOKS 'RIGHTMARGIN (IPLUS (LISTGET LOOKS 'RIGHTMARGIN) TEDITKEY.NESTWIDTH))) (TEDIT.SETSEL TEXTSTREAM PARA 1) (TEDIT.PARALOOKS TEXTOBJ LOOKS)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH]) ) (* ; "functions for affecting (and displaying) the caret character looks") (DEFINEQ (\TK.SHOWCARETLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "30-Jan-85 16:06") (* * comment) (PROG ((LOOKS (fetch CARETLOOKS of TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\TK.DESCRIBEFONT (fetch CLFONT of LOOKS)) (if (AND (fetch CLOFFSET of LOOKS) (NEQ (fetch CLOFFSET of LOOKS) 0)) then (CONCAT " offset " (fetch CLOFFSET of LOOKS)) else "") (if (fetch CLOLINE of LOOKS) then " overlined" else "") (if (fetch CLULINE of LOOKS) then " underlined" else "")) T) (RETURN]) (\TK.BOLD.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 20:54") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLBOLD of LOOKS with T) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.BOLD.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 20:54") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLBOLD of LOOKS with NIL) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.ITALIC.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:20") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLITAL of LOOKS with T) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.ITALIC.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:19") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLITAL of LOOKS with NIL) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.UNDERLINE.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 17:59") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLULINE of LOOKS with T) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.UNDERLINE.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 18:01") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLULINE of LOOKS with NIL) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.SUPERSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:25") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (if (fetch CLOFFSET of LOOKS) then (add (fetch CLOFFSET of LOOKS) TEDITKEY.OFFSETINCREMENT) else (replace CLOFFSET of LOOKS with TEDITKEY.OFFSETINCREMENT)) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.SUBSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:26") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (if (fetch CLOFFSET of LOOKS) then (add (fetch CLOFFSET of LOOKS) (IMINUS TEDITKEY.OFFSETINCREMENT)) else (replace CLOFFSET of LOOKS with (IMINUS TEDITKEY.OFFSETINCREMENT))) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.SMALLER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:45") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLSIZE of LOOKS with (IMAX 4 (IDIFFERENCE (fetch CLSIZE of LOOKS) 2))) (if (NOT (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)) then (RETURN)) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.LARGER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:37") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLSIZE of LOOKS with (IPLUS \TK.SIZEINCREMENT (fetch CLSIZE of LOOKS))) (if (NOT (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)) then (RETURN)) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.DEFAULTS.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:54") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS)) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TK.FONT1 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:39") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 1]) (\TK.FONT2 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:43") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 2]) (\TK.FONT3 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:40") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 3]) (\TK.SETCARETFONT [LAMBDA (TEXTOBJ FONTNAME) (* gbn "19-Mar-85 12:02") (* temporary hack. If this function is called when the keyboard shift is down,  then it refers to the caret looks, otherwise the selection) (if (SHIFTDOWNP 'USERMODE1) then [PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLNAME of LOOKS with FONTNAME) (if (\TK.SETFONTINLOOKS TEXTOBJ LOOKS) then (* we found the font, install it as the caret font and tell the user) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTOBJ FONTNAME T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS] else (TEDIT.LOOKS TEXTSTREAM (LIST 'FAMILY FONTNAME) SEL]) (\TK.FONT4 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:40") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 4]) (\TK.FONT5 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:41") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 5]) (\TK.FONT6 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:41") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 6]) (\TK.FONT7 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:42") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 7]) (\TK.FONT8 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:43") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 8]) ) (* ; "the functions which aren't currently used, which toggle the caret looks") (DEFINEQ (\TK.BOLDTOGGLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 20:54") (* * toggles boldness in the caret looks) (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLBOLD of LOOKS with (NOT (fetch CLBOLD of LOOKS))) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "bold: " (\TK.ONOROFF (fetch CLBOLD of LOOKS))) T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)) else (RETURN]) (\TK.ITALICTOGGLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 19:23") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLITAL of LOOKS with (NOT (fetch CLITAL of LOOKS))) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "italic: " (\TK.ONOROFF (fetch CLITAL of LOOKS))) T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)) else (RETURN]) (\TK.UNDERLINETOGGLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 19:23") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLULINE of LOOKS with (NOT (fetch CLULINE of LOOKS))) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "underline: " (\TK.ONOROFF (fetch CLULINE of LOOKS))) T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS]) ) (* ; "functions dealing with the default looks") (DEFINEQ (\TK.SETDEFAULTLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 23:00") (* * sets TEDIT.DEFAULT.CHARLOOKS to have the looks of the current selection) (PROG NIL (SETQ TEDIT.DEFAULT.CHARLOOKS (COPY (fetch CARETLOOKS of TEXTOBJ))) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) ) (* ; "functions for positioning within a document") (DEFINEQ (GOTONEXTTTYWINDOW [LAMBDA NIL (* gbn " 7-May-85 16:19") (* * puts the tty in the next appropriate process in the chain) (PROG ((CURRENT (TTY.PROCESS))) (SETQ CANDIDATES (LIST NIL)) [MAP.PROCESSES (FUNCTION (LAMBDA (PROC) (PROG (W) (if (AND (SETQ W (PROCESSPROP PROC 'WINDOW)) (OPENWP W) (WINDOWPROP W 'PROCESS)) then (NCONC1 CANDIDATES PROC] (SETQ NEW (CDR (MEMBER CURRENT CANDIDATES))) (SETQ NEW (if NEW then (CAR NEW) else (CADR CANDIDATES))) (TTY.PROCESS NEW) (FLASHWINDOW (PROCESSPROP NEW 'WINDOW) 1 1 GRAYSHADE) (* for (PROC _ CURRENT) repeatwhile  (NEQ PROC CURRENT) do  (SETQ W (PROCESSPROP  (SETQ PROC (fetch NEXTPROCHANDLE of  PROC)) (QUOTE WINDOW)))  (PRINTOUT T (PROCESSPROP PROC  (QUOTE NAME))) (if (AND W  (OPENWP W) (WINDOWPROP W  (QUOTE PROCESS))) then  (* this window would probably be  willing to take the tty if clicked in,  so give the process the tty)  (TTY.PROCESS PROC) (FLASHWINDOW W 1  NIL GRAYSHADE) (RETURN))) ]) (\TK.NEXTLINE [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "10-Oct-85 22:47") (* moves the selection down one line) (PROG (THIS NEXT) (* get the selection on the screen so that it has a line descriptor) (TEDIT.NORMALIZECARET STREAM SEL) (SETQ THIS (\SEL.LINEDESC SEL)) (if THIS then (* an empty doc has no line descriptors, even after normalizing) (SETQ NEXT (fetch NEXTLINE of THIS)) [if (NOT NEXT) then (* there isn't already a descriptor  for this line) (SETQ NEXT (replace NEXTLINE of THIS with (\FORMATLINE TEXTOBJ NIL (ADD1 (fetch CHARLIM of THIS] (if NEXT then (* if there are no more characters, then there still may not be a descriptor  when we call \formatline) (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of NEXT) (IDIFFERENCE (\SEL.LIMIT SEL) (fetch CHAR1 of THIS))) (ADD1 (\LINEDESC.LAST.REAL.CHAR NEXT))) 0 'LEFT]) (\TK.PREVLINE [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "10-Oct-85 22:15") (* moves the selection up one line) (PROG (THIS PREV) (* get the selection on the screen so that it has a line descriptor) (TEDIT.NORMALIZECARET STREAM SEL) (if (SETQ THIS (\SEL.LINEDESC SEL)) then (* empty docs have no line descriptors) (SETQ PREV (fetch PREVLINE of THIS)) [if (ZEROP (fetch CHARLIM of PREV)) then (* we need to back format because this is a fake line descriptor) [\BACKFORMAT (NTHCAR (fetch LINES of TEXTOBJ) (\TEXTOBJ.WINDEX TEXTOBJ)) TEXTOBJ (fetch PTOP of (DSPCLIPPINGREGION NIL (fetch SELWINDOW of TEXTOBJ] (SETQ PREV (fetch PREVLINE of THIS)) (* (SETQ PREV (replace PREVLINE of  THIS with (\FORMATLINE TEXTOBJ NIL  (ADD1 (fetch CHARLIM of THIS))))))] (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of PREV) (IDIFFERENCE (\SEL.LIMIT SEL) (fetch CHAR1 of THIS))) (fetch CHARLIM of PREV)) 0]) (\TK.GOTODOCBEGIN [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "13-Dec-84 11:24") (* positions at the beginning of a  document) (TEDIT.SETSEL STREAM 0 0) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.GOTODOCEND [LAMBDA (STREAM TEXTOBJ SEL) (* gbn " 7-Jun-85 16:32") (* positions at the end of a document) (TEDIT.SETSEL STREAM (ADD1 (fetch TEXTLEN of TEXTOBJ)) 0 'LEFT) (TEDIT.NORMALIZECARET STREAM]) (\TK.GOTOLINEBEGIN [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "11-Mar-85 15:04") (* * positions the cursor at the beginning of line) (PROG (CH) (TEDIT.NORMALIZECARET TEXTOBJ SEL) (SETQ CH (fetch CHAR1 of (\SEL.LINEDESC SEL))) (* (if (fetch CR\END of  (fetch L1 of SEL)) then  (* there is a CR at the end of this  line, we want to position before it)  (SETQ CH (SUB1 CH)))) (TEDIT.SETSEL TEXTSTREAM CH 0 'LEFT]) (\TK.GOTOLINEEND [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn " 7-Jun-85 15:47") (* * positions the cursor at the end of line) (PROG ((POINT 'RIGHT) LN) (TEDIT.NORMALIZECARET TEXTOBJ SEL) (if (SETQ LN (\SEL.LINEDESC SEL)) then (* empty docs have no linedescriptors) (SETQ CH (fetch CHARLIM of LN)) (if (fetch CR\END of LN) then (* there is not a CR at the end of this line, we want to position to the right  of the last char) (SETQ POINT 'LEFT)) (TEDIT.SETSEL TEXTSTREAM CH 1 POINT]) (\TK.PREVCHAR [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:16") (* moves the selection back one char) (PROG NIL (TEDIT.SETSEL STREAM (IMAX 0 (SUB1 (\SEL.LIMIT.FORWARD SEL))) 0 'LEFT) (* I don't think this should be necessary, but there are cases where the caret  is not normalised) (TEDIT.NORMALIZECARET TEXTOBJ SEL]) (\TK.NEXTCHAR [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:48") (* moves the selection back one char) (PROG NIL (* Note%: addition. does *not* distribute with Min Do not pessimize this!) (TEDIT.SETSEL STREAM (IMIN (ADD1 (fetch TEXTLEN of TEXTOBJ)) (ADD1 (\SEL.LIMIT.FORWARD SEL))) 0 'LEFT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.FORWARD.WORD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:48") (* * moves the caret one word forward. Refers to the syntax classes of the  characters according to the TEDIT.WORDBOUND.READTABLE) (PROG (HERE) (* position the file ptr at the (character after the) caret of the selection) (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL) (* skip the whitespace) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ \TK.WHITESPACE (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM)) (* record this position as the beginning of the word  (to make the beginning of the selection)) (SETQ HERE (ADD1 (GETFILEPTR TEXTSTREAM))) (* find out what syntax class the first letter of the word has.  The end of the word is marked by a change of syntax classes) (if (NOT (EOFP TEXTSTREAM)) then (SETQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T))) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM))) (TEDIT.SETSEL TEXTSTREAM HERE (ADD1 (IDIFFERENCE (GETFILEPTR TEXTSTREAM) HERE)) 'RIGHT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.BACK.WORD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:49") (* * moves the caret one word back Refers to the syntax classes of the  characters according to the TEDIT.WORDBOUND.READTABLE) (PROG (HERE) (* position the file ptr at the (character after the) caret of the selection) (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL) (* skip the whitespace) (while [AND (NOT (ZEROP (GETFILEPTR TEXTSTREAM))) (EQ \TK.WHITESPACE (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T] do (\BACKBIN TEXTSTREAM)) (* record this position as the beginning of the word  (to make the beginning of the selection)) (SETQ HERE (GETFILEPTR TEXTSTREAM)) (* find out what syntax class the last letter of the word has.  The end of the word is marked by a change of syntax classes) (if (NOT (ZEROP (GETFILEPTR TEXTSTREAM))) then (SETQ CLASS (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T))) (while [AND (NOT (ZEROP (GETFILEPTR TEXTSTREAM))) (EQ CLASS (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T] do (\BACKBIN TEXTSTREAM))) (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETFILEPTR TEXTSTREAM)) (IDIFFERENCE HERE (GETFILEPTR TEXTSTREAM)) 'LEFT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.SELECT.ALL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "24-Feb-86 17:11") (* positions at the end of a document) (TEDIT.SETSEL STREAM 0 (ADD1 (fetch TEXTLEN of TEXTOBJ)) 'LEFT]) ) (* ; "other utilities") (DEFINEQ (\TK.FIND [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "10-Dec-84 12:38") (* just calls the normal tedit.find starting at the right of the current  selection) (TEDIT.FULL.FIND TEXTSTREAM]) (\TK.REDISPLAY [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "12-Mar-85 14:27") (* * simply redisplays the window in question.) (\TEDIT.REPAINTFN (CAR (MKATOM (fetch \WINDOW of TEXTOBJ]) (\TK.DELLINEFORWARD [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "13-Dec-84 11:56") (* deletes from the caret to the end of this line) (PROG (HERE DESC) (TEDIT.NORMALIZECARET TEXTOBJ) (SETQ HERE (\SEL.LIMIT.FORWARD SEL)) (SETQ DESC (\SEL.LINEDESC SEL)) (SETQ SEL (TEDIT.SETSEL STREAM HERE (IDIFFERENCE (fetch CHARLIM of DESC) HERE))) (TEDIT.DELETE STREAM SEL]) (\TK.OPENLINE [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "30-Jan-85 18:36") (TEDIT.INSERT STREAM (CONSTANT (CHARCODE EOL))) (\TK.PREVCHAR STREAM TEXTOBJ SEL]) (\TK.DELCHARFORWARD [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:50") (* * deletes one character forward from the caret) (PROG (HERE) (SETQ SEL (TEDIT.SETSEL STREAM (\SEL.LIMIT.FORWARD SEL) 1)) (TEDIT.DELETE STREAM SEL) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.TRANSPOSECHARS [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:51") (* * transposes the two characters on either side of the point, unless it is  the end of a line, in which case it transposes the two characters before the  point) (PROG ((KEEPCHARPOS (\SEL.LIMIT.FORWARD SEL)) KEEPCHAR LINEDESC) (TEDIT.NORMALIZECARET TEXTOBJ SEL) (* get the line that the point of the selection is on) (SETQ LINEDESC (\SEL.LINEDESC SEL)) (if (ILESSP (\LINEDESC.LAST.REAL.CHAR LINEDESC) KEEPCHARPOS) then (* the point is after the last real char on this line, so transpose the two  before the point.) (add KEEPCHARPOS -1)) (SETQ KEEPCHAR (TEDIT.SEL.AS.STRING STREAM (TEDIT.SETSEL STREAM KEEPCHARPOS 1))) (if (AND (IGREATERP KEEPCHARPOS 1) (IGEQ (fetch TEXTLEN of TEXTOBJ) KEEPCHARPOS)) then (TEDIT.DELETE STREAM) (TEDIT.INSERT STREAM KEEPCHAR (SUB1 KEEPCHARPOS)) (TEDIT.SETSEL STREAM KEEPCHARPOS 1 'RIGHT)) (TEDIT.NORMALIZECARET TEXTOBJ SEL]) ) (* ; "little selection utilities etc., for building hacks") (DEFINEQ (\SEL.LIMIT [LAMBDA (SEL) (* gbn " 8-Mar-85 12:58") (* returns the character that delimits this selection.  The first char if the point is left else the last) (if (EQ (fetch POINT of SEL) 'LEFT) then (fetch CH# of SEL) else (SUB1 (fetch CHLIM of SEL]) (\TK.SETFILEPTR.TO.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "23-Feb-85 15:24") (* * makes sure that the fileptr is positioned at character on the right of the  CARET of the selection) (* NOTE THAT FILEPTR's are one less than the corresponding char# in a sel) (SETFILEPTR TEXTSTREAM (SUB1 (\SEL.LIMIT.FORWARD SEL]) (\SEL.LINEDESC [LAMBDA (SEL) (* gbn "10-Oct-85 20:57") (* * Returns the line descriptor of the point of the selection in the last  selected window) (NTHCAR (if (EQ (fetch POINT of SEL) 'LEFT) then (fetch L1 of SEL) else (fetch LN of SEL)) (\TEXTOBJ.WINDEX (fetch \TEXTOBJ of SEL]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \SEL.LIMIT.FORWARD MACRO (LAMBDA (SEL) (* gbn "13-Dec-84 11:43") (* returns the character in front of the caret (ch# for left and chlim for right)) (if (EQ (fetch POINT of SEL) 'LEFT) then (fetch CH# of SEL) else (fetch CHLIM of SEL] [PUTPROPS \TK.ONOROFF MACRO (LAMBDA (FLG) (if FLG then "on" else "off"] [PUTPROPS \LINEDESC.LAST.REAL.CHAR MACRO (LAMBDA (LINEDESC) (if (fetch CR\END of LINEDESC) then (* there is a CR at the end so the last real char CHLIM-1) (SUB1 (fetch CHARLIM of LINEDESC)) else (fetch CHARLIM of LINEDESC] ) (* ; "fns for the key interface itself") (DEFINEQ (\SHIFTACTION [LAMBDA (KEYNAME) (* gbn "16-Feb-85 16:55") (* returns the character code generated by this keyname when typed shifted) (CADAR (KEYACTION KEYNAME]) (\ACTION [LAMBDA (KEYNAME) (* gbn "16-Feb-85 16:54") (* RETURNS THE CHARACTER CODE GENERATED BY THIS KEYNAME WHEN TYPED UNSHIFTED) (CAAR (KEYACTION KEYNAME]) (TEDITKEY.INSTALL [LAMBDA (READTABLE) (* gbn " 1-Apr-86 22:36") (* * installs the TEDITKEYBINDINGS on the readtable) (PROG [(READTABLE (OR READTABLE TEDIT.READTABLE)) INTERRUPT (FNKEYITEM '(Function% Keys 'BUILDFNKEYS "Bring up the DLion fn keys window"] (* I think that in Koto, all this is done by the system.  The times, they are a-changin'! (PROGN (* Tell everyone who cares to let ^h be  the backspace character) (if (SETQ INTERRUPT  (GETINTERRUPT (CHARCODE ^H))) then (printout T "Interrupt on ^H disabled")  (SETINTERRUPT (CHARCODE ^H) (QUOTE NIL)))  (SETSYNTAX 8 (QUOTE CHARDELETE) \PROMPTFORWORDTTBL)  (SETSYNTAX 8 (QUOTE CHARDELETE) ASKUSERTTBL)  (SETSYNTAX 8 (QUOTE CHARDELETE) \ORIGTERMTABLE)  (SETSYNTAX 8 (QUOTE CHARDELETE) \PRIMTERMTABLE)  (SETSYNTAX 8 (QUOTE CHARDELETE) DEDITTTBL)  (SETINTERRUPT (CHARCODE ^G) (QUOTE HELP)))) (METASHIFT T) (* TEditKey redefines METASHIFT to operate on TEDITKEY.METAKEY instead of the  swat (bottom-blank) key) (* install the functions on the main keyboard, that is, not the extra dlion  keys) [for TRIPLE in TEDITKEY.KEYBINDINGS do (COND (TRIPLE (* NILs in the list are for formatting  the menu) (for KEY in (CADR TRIPLE) do (APPLY* 'TEDIT.SETFUNCTION (EVAL `(CHARCODE %, KEY)) (CAR TRIPLE) READTABLE] (* the function keys are set up by  default (MODIFY.KEYACTIONS  TEDITKEY.FNKEYACTIONS)) (PROGN (* install the nextttywindow hack) (* INTERRUPTCHAR (\SHIFTACTION  (QUOTE NEXT)) (QUOTE  (GOTONEXTTTYWINDOW))) (* So that non-tedits know about the  game) ) (SELECTQ (MACHINETYPE) (DANDELION [if TEDITKEY.LOCKTOGGLEKEY then (KEYACTION TEDITKEY.LOCKTOGGLEKEY '(LOCKTOGGLE] (if (AND (BOUNDP 'DLIONFNKEYS) (OPENWP DLIONFNKEYS)) then (* this machine has real fn keys so close the fake ones) (CLOSEW DLIONFNKEYS)) (* adjust so that the dlion extra keys return meta control codes) (MODIFY.KEYACTIONS TEDITKEY.DLION.KEYACTIONS) (for PAIR in TEDITKEY.DLION.KEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (* hang functions off the dlion extra  keys (e.g. italics, bold)) (for PAIR in TEDITKEY.FNKEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (* set next to do next, undo to do undo etc) (* unnecessary in KOTO  (for PAIR in TEDITKEY.DLION.KEYSYNTAX  do (TEDIT.SETSYNTAX (EVAL  (CAR PAIR)) (CADR PAIR) READTABLE))) (* remove the menu item that may have already been installed) (* you can remove non-existent items  with impunity) (TEDIT.REMOVE.MENUITEM TEDIT.DEFAULT.MENU FNKEYITEM) (PROGN (* install the nextttywindow hack) (INTERRUPTCHAR (\SHIFTACTION 'NEXT) '(GOTONEXTTTYWINDOW)) (* So that non-tedits know about the  game) )) (PROGN (MODIFY.KEYACTIONS TEDITKEY.DORADO.KEYACTIONS) (for PAIR in TEDITKEY.DORADO.KEYSYNTAX do (TEDIT.SETSYNTAX (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (for PAIR in TEDITKEY.FNKEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU FNKEYITEM))) (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (* bring up the fake function keys) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) DLIONFNKEYS) (COND ([AND TEDITKEY.FNKEYFLG (NOT (AND (BOUNDP 'DLIONFNKEYS) (OPENWP DLIONFNKEYS] (* if he has the flag set to do so, then check if there is a fnkey window up  yet, and build one if there isn't) (BUILDFNKEYS)))) (PROGN NIL)) (* install the forms necessary to re-establish the correct bindings on a new  machine if this is sysout'ed) (* if (NOT (ASSOC (QUOTE  TEDITKEY.INSTALL) AFTERMAKESYSFORMS))  then (push AFTERMAKESYSFORMS  (QUOTE (TEDITKEY.INSTALL)))) [COND ((NOT (ASSOC 'TEDITKEY.INSTALL AFTERSYSOUTFORMS)) (push AFTERSYSOUTFORMS '(TEDITKEY.INSTALL] (RETURN (CONCAT TEDITKEY.METAKEY "'s action is now Meta. TEditKey actions and key bindings installed. Type #? or press the HELP key to see keybindings" ]) (TEDITKEY.DEINSTALL [LAMBDA (ARGS |...|) (* gbn "10-Oct-85 00:04") (MODIFY.KEYACTIONS \ORIGKEYACTIONS) (SELECTQ (MACHINETYPE) (DANDELION (MODIFY.KEYACTIONS \DLIONKEYACTIONS)) (PROGN NIL]) (\TK.ACTIONTOCHARCODE [LAMBDA (FN) (* gbn "23-Feb-85 17:17") (* takes the name of the function and looks in TEDITKEY.KEYBINDINGS to find out  which CHARCODE generates that behaviour) (PROG ((PAIR (ASSOC FN TEDITKEY.KEYBINDINGS))) (RETURN (if PAIR then [EVAL `(CHARCODE %, (CAADR PAIR] else NIL]) (\TK.BUILD.MENU [LAMBDA (KEYBINDINGS) (* gbn "23-Feb-85 17:17") (* builds a menu to display the key  bindings) (PROG (ITEMS) [for TRIPLE in TEDITKEY.KEYBINDINGS do (COND (TRIPLE (push ITEMS (LIST (CADDR TRIPLE) `(QUOTE %, TRIPLE) "Function which is performed by the key(s) to the right of the mouse" )) (push ITEMS (LIST (for DESC in (CADR TRIPLE) collect (CHARDESC DESC)) NIL))) (T (* insert a space since NIL marks logical divisions in the list) (push ITEMS '("" NIL "")) (push ITEMS '("" NIL ""] (SETQ \TK.MENU (create MENU ITEMS _ (DREVERSE ITEMS) MENUCOLUMNS _ 2 CENTERFLG _ T MENUFONT _ (FONTCREATE 'HELVETICA 10]) (\TK.HELP [LAMBDA (WHATEVER) (* gbn " 5-Nov-84 18:17") (* brings up a menu of the available  key bindings) (MENU \TK.MENU]) (\TK.SETFONTINLOOKS [LAMBDA (TEXTSTREAM LOOKS) (* gbn "11-Oct-85 07:12") (* * rebuilds the font field of looks according to the values in the fields) (PROG (NEWFONT) (SETQ NEWFONT (FONTCREATE (OR (fetch CLNAME of LOOKS) (FONTPROP (fetch CLFONT of LOOKS) 'FAMILY)) (fetch CLSIZE of LOOKS) (LIST (if (fetch CLBOLD of LOOKS) then 'BOLD else 'MEDIUM) (if (fetch CLITAL of LOOKS) then 'ITALIC else 'REGULAR) 'REGULAR) NIL NIL T)) (if (CAR NEWFONT) then (* we got the font, so now replace it) (RETURN (replace CLFONT of LOOKS with NEWFONT)) else (* we lost, print a msg and return NIL so that the caller knows.) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "Font not found: " (CONCAT [L-CASE (OR (fetch CLNAME of LOOKS) (FONTPROP (fetch CLFONT of LOOKS) 'FAMILY] " " (fetch CLSIZE of LOOKS) (if (fetch CLBOLD of LOOKS) then 'BOLD " bold" else "") (if (fetch CLITAL of LOOKS) then " italic" else ""))) T) (RETURN NIL]) (WRITE.CHARDESC.AUX [LAMBDA (TOKENS) (* gbn "10-Oct-85 00:20") (COND ((EQ (LENGTH TOKENS) 1) (CONS (CAR TOKENS) NIL)) (T (SELECTQ (CAR TOKENS) (%# [CONS "meta " (WRITE.CHARDESC.AUX (COND ((AND (CDR TOKENS) (EQ (CADR TOKENS) '%#)) (CDDR TOKENS]) (^ (CONS "control " (WRITE.CHARDESC.AUX (CDR TOKENS)))) (ERROR CHARDESC " is a misunderstood character descriptor"]) (CHARDESC [LAMBDA (CHARDESC) (* gbn " 7-Nov-84 14:21") (* takes a description in the form taken as input to charcode and writes out a  human readable form) (PACK (WRITE.CHARDESC.AUX (UNPACK CHARDESC]) (TEDITKEY.CONFIGURE [LAMBDA NIL (* gbn " 5-Nov-84 18:58") (PROMPTPRINT "not implemented"]) (\TK.ADDKEY [LAMBDA (TRIPLE) (* gbn " 5-Nov-84 18:41") (* dummy for now) ]) (\TK.CHANGEKEY [LAMBDA (THIS) (* gbn " 5-Nov-84 18:42") (* DUMMY) ]) (\TK.APPLYPENDING [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "10-Dec-84 15:58") (* * takes the entries on \TK.PENDING, reverses them and applies them as  incremental changes to the selection.) (PROG ((PENDING (DREVERSE \TK.PENDING)) (LOOKS (LIST NIL))) (for ENTRY in PENDING do (SELECTQ ENTRY (BOLDON (LISTPUT LOOKS 'WEIGHT 'BOLD)) (BOLDOFF (LISTPUT LOOKS 'WEIGHT 'MEDIUM)) (ITALICON (LISTPUT LOOKS 'SLOPE 'ITALIC)) (ITALICOFF (LISTPUT LOOKS 'SLOPE 'REGULAR)) (UNDERLINEON (LISTPUT LOOKS 'UNDERLINE 'ON)) (UNDERLINEOFF (LISTPUT LOOKS 'UNDERLINE 'OFF)) (SUPERSCRIPT (* nothing for the moment) NIL) (SUBSCRIPT (* nothing for the moment) NIL) (LARGER (* nothing for the moment) NIL) (SMALLER (* nothing for the moment) NIL) (DEFAULTS (SETQ LOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST TEDIT.DEFAULT.CHARLOOKS))) ((TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL HIPPO MATH) (LISTPUT LOOKS 'FAMILY ENTRY)) (\LISPERROR "Illegal pending operation in \TK.PENDING" ENTRY)) ) (SETQ \TK.PENDING NIL) (RETURN (TEDIT.LOOKS TEXTSTREAM LOOKS SEL]) (\TK.NTHFONT [LAMBDA (N) (* gbn "27-Jan-85 17:51") (* returns the name of the nth  teditkey font) (CAR (NTH TEDITKEY.FONTS N]) ) (* ; "redefinition of system junk") (DEFINEQ (METASHIFT [LAMBDA FLG (* gbn " 6-Mar-85 15:43") (* Sets interpretation of TEDITKEY.METAKEY key to first arg, where T means  meta-shift, NIL means original setting. Returns previous setting) (PROG ((METASTATUS '(METADOWN . METAUP)) OLDSETTING) [SETQ OLDSETTING (KEYACTION TEDITKEY.METAKEY (AND (IGREATERP FLG 0) (COND ((EQ (ARG FLG 1) T) METASTATUS) (T (OR (ARG FLG 1) (CDR (ASSOC TEDITKEY.METAKEY \ORIGKEYACTIONS] (RETURN (COND ((EQUAL OLDSETTING METASTATUS) T) (T OLDSETTING]) ) (* ;; "(\TK.BOLDTOGGLE (##H ##h) 'toggle Bold caret looks') (\TK.ITALICTOGGLE (##i ##I) 'toggle Italic caret looks') (\TK.SUPERSCRIPT.CARET (##^) 'Superscript the caret looks') (\TK.SUBSCRIPT.CARET (##_) 'Subscript the caret looks')" ) (DEFINEQ (TEDIT.FULL.FIND [LAMBDA (TEXTSTREAM SEARCHSTRING) (* gbn " 8-Mar-85 12:56") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* Case sensitive search, with * and  %# wildcards) [SETQ W (CAR (MKLIST (fetch \WINDOW of TEXTOBJ] [SETQ TARGET (OR SEARCHSTRING (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W ' TEDIT.LAST.FIND.STRING ) (CHARCODE (EOL LF ESC] [COND (TARGET (SETQ SEL (fetch SEL of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* We found the target text.) (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (replace CH# of SEL with (CAR CH))(* Set up SELECTION to be the found  text) (replace CHLIM of SEL with (ADD1 (CADR CH))) [replace DCH of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH] (replace POINT of SEL with 'RIGHT) (replace CARETLOOKS of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* And get it into the window) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\SHOWSEL SEL NIL T] (replace \INSERTNEXTCH of TEXTOBJ with -1]) ) (RPAQQ \TK.WHITESPACE 22) (RPAQ TEDIT.INTERRUPTS `((%, (CHARCODE ^G) ERROR) (%, (CHARCODE ^C) HELP))) (DECLARE%: EVAL@COMPILE (RPAQQ \TK.WHITESPACE 22) (CONSTANTS (\TK.WHITESPACE 22)) ) (RPAQ? TEDITKEY.VERBOSE T) (RPAQ? TEDITKEY.METAKEY 'TAB) (RPAQ? TEDITKEY.LOCKTOGGLEKEY NIL) (RPAQ? TEDITKEY.NESTWIDTH 36) (RPAQ? \TK.SIZEINCREMENT 2) (RPAQ? TEDITKEY.OFFSETINCREMENT 3) (RPAQ? TEDITKEY.FONTS '(TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL SYMBOL HIPPO)) (RPAQ? TEDITKEY.FNKEYFLG T) (DECLARE%: EVAL@COMPILE [PUTPROPS METACODE MACRO (LAMBDA (CHARCODE) (LOGOR CHARCODE 128] [PUTPROPS CONTROLCODE MACRO (LAMBDA (CHARCODE) (LOGAND CHARCODE 31] [PUTPROPS LCMETACODE MACRO (LAMBDA (CHARCODE) (LOGOR 160 CHARCODE] ) (RPAQ? \TK.SELKEY 'OPEN) (RPAQ? \TK.PENDING ) (RPAQ? TEDITKEY.KEYBINDINGS `((\TK.FONT1 (%##1) %, (CONCAT "change to font " (\TK.NTHFONT 1))) (\TK.FONT2 (%##2) %, (CONCAT "change to font " (\TK.NTHFONT 2))) (\TK.FONT3 (%##3) %, (CONCAT "change to font " (\TK.NTHFONT 3))) (\TK.FONT4 (%##4) %, (CONCAT "change to font " (\TK.NTHFONT 4))) (\TK.FONT5 (%##5) %, (CONCAT "change to font " (\TK.NTHFONT 5))) (\TK.FONT6 (%##6) %, (CONCAT "change to font " (\TK.NTHFONT 6))) (\TK.FONT7 (%##7) %, (CONCAT "change to font " (\TK.NTHFONT 7))) (\TK.FONT8 (%##8) %, (CONCAT "change to font " (\TK.NTHFONT 8))) NIL (\TK.DEFAULTS.CARET (%##/) "restore the default caret looks") (\TK.SMALLER.CARET (%##9) "decrease the caret font size") (\TK.LARGER.CARET (%##0) "increase the caret font size") (\TK.SHOWCARETLOOKS (%##=) "display the current caret looks") NIL (\TK.REDISPLAY (%##R %##r) "Restore the display") (\TK.HELP (%##?) "displays the current key bindings") NIL (\TK.PREVCHAR (^B ^b) "Back one character") (\TK.NEXTCHAR (^F ^f) "Forward one character") (\TK.FORWARD.WORD (%##F %##f) "Forward one word") (\TK.BACK.WORD (%##B %##b) "Back one word") (\TK.GOTOLINEBEGIN (^A ^a) "go to stArt of line") (\TK.GOTOLINEEND (^E ^e) "go to End of line") (\TK.PREVLINE (^P ^p) "go to Previous line") (\TK.NEXTLINE (^N ^n) "go to Next line") (\TK.GOTODOCBEGIN (%##<) "start of document") (\TK.GOTODOCEND (%##>) "end of document") (\TK.SELECT.ALL (%##S %##s) "Select whole document") NIL (\TK.DELLINEFORWARD (^K ^k) "Kill line") (\TK.OPENLINE (^O ^o) "Open up blank line") (\TK.DELCHARFORWARD (^D ^d) "Delete character forward") (\TK.DEL.WORD.FORWARD (%##D %##d) "Delete word forward") (\TK.TRANSPOSECHARS (^T ^t) "Transpose characters") NIL NIL (\TK.NEST (|##[|) "indents margins (nest)") (\TK.UNNEST (|##]|) "exdents margins (unnest)") (\TK.CENTER.SEL (%##J %##j) "alter Justification") (\TK.UCASE.SEL (%##U %##u) "Uppercasify selection") (\TK.CAPITALISE.SEL (%##C %##c) "Capitalize selection") (\TK.LCASE.SEL (%##L %##l) "Lowercasify selection") (GET.OBJ.FROM.USER (%##O %##o) "insert Object"))) (RPAQ? TEDITKEY.DLION.KEYACTIONS `((STOP (%, (CHARCODE ^G) %, (CHARCODE ^C) NOLOCKSHIFT)) (OPEN (%, (CHARCODE 2,1) %, (CHARCODE 2,41) NOLOCKSHIFT)) (FONT FONTDOWN . FONTUP) (KEYBOARD USERMODE1DOWN . USERMODE1UP))) (RPAQ? COMS (* ;; "(TEDITKEY.FNKEYACTIONS (BQUOTE ((CENTER (, (CHARCODE ##^B), (CHARCODE ##^C))) (BOLD (, (CHARCODE ##^D), (CHARCODE ##^E) NOLOCKSHIFT)) (ITALICS (, (CHARCODE ##^F), (CHARCODE ##^G) NOLOCKSHIFT)) (UNDERLINE (, (CHARCODE ##^H), (CHARCODE ##^I) NOLOCKSHIFT)) (SUPERSCRIPT (, (CHARCODE ##^J), (CHARCODE ##^K) NOLOCKSHIFT)) (SUBSCRIPT (, (CHARCODE ##^L), (CHARCODE ##^N) NOLOCKSHIFT)) (LARGER (, (CHARCODE ##^O), (CHARCODE ##^P) NOLOCKSHIFT)) (DEFAULTS (, (CHARCODE ##^Q), (CHARCODE ##^R) NOLOCKSHIFT)) (BS (, (CHARCODE ^H), (CHARCODE ^D) NOLOCKSHIFT)))))") ) (RPAQ? TEDITKEY.DLION.KEYBINDINGS '(((\ACTION 'OPEN) \TK.OPENLINE) ((\ACTION 'HELP) \TK.HELP) ((\ACTION 'MARGINS) \TK.NEST) ((\SHIFTACTION 'MARGINS) \TK.UNNEST) ((\SHIFTACTION 'NEXT) GOTONEXTTTYWINDOW))) (RPAQ? TEDITKEY.FNKEYBINDINGS '(((\ACTION 'DEFAULTS) \TK.DEFAULTSSEL) ((\SHIFTACTION 'DEFAULTS) \TK.SETDEFAULTLOOKS))) (RPAQ? COMS (* ;; "NOT NEEDED (TEDITKEY.DLION.KEYSYNTAX (QUOTE (((\ACTION (QUOTE NEXT)) NEXT) ((\ACTION (QUOTE UNDO)) UNDO) ((\ACTION (QUOTE BS)) CHARDELETE))))") ) (RPAQ? TEDITKEY.DORADO.KEYACTIONS `((BS (%, (CHARCODE ^H) %, (CHARCODE ^H))) (BLANK-BOTTOM (%, (CHARCODE %##^A) %, (CHARCODE %##^A))) (BLANK-TOP FONTDOWN . FONTUP) (BLANK-MIDDLE USERMODE1DOWN . USERMODE1UP) (CENTER (2,101 2,141 NOLOCKSHIFT)) (BOLD (2,102 2,142 NOLOCKSHIFT)) (ITALICS (2,103 2,143 NOLOCKSHIFT)) (UNDERLINE (2,106 2,146 NOLOCKSHIFT)) (SUPERSCRIPT (2,113 2,153 NOLOCKSHIFT)) (SUBSCRIPT (2,114 2,154 NOLOCKSHIFT)) (LARGER (2,110 2,150 NOLOCKSHIFT)) (DEFAULTS (2,115 2,155 NOLOCKSHIFT)))) (RPAQ? TEDITKEY.DORADO.KEYSYNTAX '(((CHARCODE %##N) NEXT) ((CHARCODE %##n) NEXT) ((\ACTION 'BLANK-BOTTOM) UNDO) ((\ACTION 'BS) CHARDELETE))) (TEDITKEY.INSTALL) (\TK.BUILD.MENU) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA METASHIFT) ) (PUTPROPS TEDITKEY COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (15418 27849 (NTHCAR 15428 . 15557) (\TEXTOBJ.WINDEX 15559 . 16116) (\TK.PREVSCREEN 16118 . 18028) (\TK.UNDERLINE.SEL.ON 18030 . 18510) (\TK.UNDERLINE.SEL.OFF 18512 . 18995) ( \TK.BOLD.SEL.ON 18997 . 19589) (\TK.BOLD.SEL.OFF 19591 . 20187) (\TK.ITALIC.SEL.ON 20189 . 20537) ( \TK.ITALIC.SEL.OFF 20539 . 20890) (\TK.SMALLERSEL 20892 . 21529) (\TK.LARGERSEL 21531 . 22162) ( \TK.SUPERSCRIPTSEL 22164 . 22809) (\TK.SUBSCRIPTSEL 22811 . 23460) (\TK.DEFAULTSSEL 23462 . 24181) ( \TK.DEL.WORD.FORWARD 24183 . 25779) (\TK.UCASE.SEL 25781 . 26347) (\TK.CAPITALISE.SEL 26349 . 26963) ( \CAPITALISE 26965 . 27279) (\TK.LCASE.SEL 27281 . 27847)) (27921 32598 (\TK.CENTER.SEL 27931 . 29199) (\TK.CENTER.SEL.REV 29201 . 30379) (\TK.NEST 30381 . 31361) (\TK.UNNEST 31363 . 32596)) (32682 42410 ( \TK.SHOWCARETLOOKS 32692 . 34003) (\TK.BOLD.CARET.ON 34005 . 34568) (\TK.BOLD.CARET.OFF 34570 . 35136) (\TK.ITALIC.CARET.ON 35138 . 35703) (\TK.ITALIC.CARET.OFF 35705 . 36273) (\TK.UNDERLINE.CARET.ON 36275 . 36714) (\TK.UNDERLINE.CARET.OFF 36716 . 37158) (\TK.SUPERSCRIPT.CARET 37160 . 37802) ( \TK.SUBSCRIPT.CARET 37804 . 38462) (\TK.SMALLER.CARET 38464 . 39106) (\TK.LARGER.CARET 39108 . 39695) (\TK.DEFAULTS.CARET 39697 . 40022) (\TK.FONT1 40024 . 40196) (\TK.FONT2 40198 . 40370) (\TK.FONT3 40372 . 40544) (\TK.SETCARETFONT 40546 . 41538) (\TK.FONT4 41540 . 41712) (\TK.FONT5 41714 . 41886) ( \TK.FONT6 41888 . 42060) (\TK.FONT7 42062 . 42234) (\TK.FONT8 42236 . 42408)) (42499 44831 ( \TK.BOLDTOGGLE 42509 . 43384) (\TK.ITALICTOGGLE 43386 . 44197) (\TK.UNDERLINETOGGLE 44199 . 44829)) ( 44889 45351 (\TK.SETDEFAULTLOOKS 44899 . 45349)) (45412 58534 (GOTONEXTTTYWINDOW 45422 . 47701) ( \TK.NEXTLINE 47703 . 49591) (\TK.PREVLINE 49593 . 51693) (\TK.GOTODOCBEGIN 51695 . 52053) ( \TK.GOTODOCEND 52055 . 52406) (\TK.GOTOLINEBEGIN 52408 . 53192) (\TK.GOTOLINEEND 53194 . 54018) ( \TK.PREVCHAR 54020 . 54549) (\TK.NEXTCHAR 54551 . 55115) (\TK.FORWARD.WORD 55117 . 56654) ( \TK.BACK.WORD 56656 . 58224) (\TK.SELECT.ALL 58226 . 58532)) (58567 61606 (\TK.FIND 58577 . 58848) ( \TK.REDISPLAY 58850 . 59108) (\TK.DELLINEFORWARD 59110 . 59650) (\TK.OPENLINE 59652 . 59859) ( \TK.DELCHARFORWARD 59861 . 60248) (\TK.TRANSPOSECHARS 60250 . 61604)) (61675 63029 (\SEL.LIMIT 61685 . 62100) (\TK.SETFILEPTR.TO.CARET 62102 . 62529) (\SEL.LINEDESC 62531 . 63027)) (64449 81285 ( \SHIFTACTION 64459 . 64705) (\ACTION 64707 . 64949) (TEDITKEY.INSTALL 64951 . 72392) ( TEDITKEY.DEINSTALL 72394 . 72657) (\TK.ACTIONTOCHARCODE 72659 . 73122) (\TK.BUILD.MENU 73124 . 74440) (\TK.HELP 74442 . 74753) (\TK.SETFONTINLOOKS 74755 . 77230) (WRITE.CHARDESC.AUX 77232 . 77988) ( CHARDESC 77990 . 78296) (TEDITKEY.CONFIGURE 78298 . 78453) (\TK.ADDKEY 78455 . 78655) (\TK.CHANGEKEY 78657 . 78852) (\TK.APPLYPENDING 78854 . 80960) (\TK.NTHFONT 80962 . 81283)) (81330 82491 (METASHIFT 81340 . 82489)) (82737 85563 (TEDIT.FULL.FIND 82747 . 85561))))) STOP \ No newline at end of file diff --git a/lispusers/TEDITKEY.TEDIT b/lispusers/TEDITKEY.TEDIT new file mode 100644 index 00000000..a7347104 --- /dev/null +++ b/lispusers/TEDITKEY.TEDIT @@ -0,0 +1,149 @@ +enˇvĹos TEDITKEY 2 4 1 TEDITKEY 1 4 By: Greg Nuyens Supported by: Jan Pedersen (Pedersen.pa@Xerox.com) Uses: KEYOBJ, DLIONFNKEYS TEditKey is a module that provides a keyboard interface to TEdit. On a Dandelion, the interface takes advantage of the special keys to the left, top, and right of the main keyboard. On a Dorado or Dolphin, a window mimicking the Dandelion function keys provides some of the same abilities. The abilities provided include allowing the user to alter the caret looks (the looks of characters typed in) or the selection looks. These commands are given using the Dandelion function keys and/or metacodes. (Metacodes are keys typed while a meta key is held down. The default meta key is the tab key; to alter this see "User Switches" below.) Other metacodes and control codes move the cursor within the document (beginning/end of line, back/forward a character, up/down a line, etc.). Thus, many of the special Dandelion keys are made to function in TEdit the way they are labeled. The following keys change their behavior once TEditKey is loaded. CENTER modifies the justification of the paragraph(s) containing the current selection. If the selection was left justified, then hitting the CENTER key makes it centered. Hitting it again produces right and left justification. BOLD boldfaces the selection. All other properties remain unchanged. Holding the shift key down while hitting BOLD will make the selection become un-bold. ITALICS italicizes the selection. Shift-ITALICS is the opposite. UNDERLINE underlines the selection. Shift-UNDERLINE is the opposite. SUPERSCRIPT superscripts the selection by a constant amount. Any relative superscripts (or subscripts) are maintained. Thus if "Xi" is selected in "the set Xi is empty" then pressing the SUPERSCRIPT button produces "the set Xi is empty." See "User Switches" below for how to set the increment. Shift-SUPERSCRIPT is the same as SUBSCRIPT. SUBSCRIPT is analogous to SUPERSCRIPT. SMALLER decreases the font size of the selection. All relative size differences are maintained. E.g.,"this is bigger than that" produces "this is bigger than that." Shift-SMALLER (labeled LARGER) does the opposite. DEFAULTS makes the selection have default looks. N.B.: The default looks can be set to the current caret looks by typing shift-DEFAULTS. The above keys all affect the caret looks if the keyboard key is held down when they are hit. Thus holding down KEYBOARD and then hitting UNDERLINE makes the caret looks be underlined. FONT changes the font of the selection or caret looks according to the following table (to alter this table see "User Switches" below): 1 Times Roman 2 Helvetica 3 Gacha 4 Modern 5 Classic 6 Terminal 7 Symbol 8 Hippo Thus, to change the font of the selection to Classic, hold down FONT and hit 5. To change the caret font to Classic, hold down FONT (to signal the font change) and KEYBOARD (to direct the change to the caret looks) then hit 5. Note that this table is part of the menu displayed when the HELP button is pressed. On a Dorado, middle-blank is the FONT key. KEYBOARD applies any changes that occur while this key is down to the caret looks instead of the selection. On a Dorado, bottom-blank is the KEYBOARD key. AGAIN invokes the redo facility in TEdit. A wide variety of operations can be repeated very simply by making a selection, performing an operation (for instance, an insertion), then picking a new selection and hitting the AGAIN key. The AGAIN key is an ESCape key, which acts as the TEdit REDO syntax class. (See page 20.22 of the Interlisp Reference Manual.) OPEN opens a blank line at the current cursor position. OPEN is also used to type a linefeed outside of TEdit (for example to the function FILES?). FIND prompts the user for a target string, then searches from the selection forward. NEXT acts as the TEdit NEXT syntax class. (It goes to the next field to be filled in. These fields are marked as follows: >>text to be substituted<< .) shift-NEXT transfers the TTY (which window will receive typed characters) to the next window which can accept typein. Thus one can cycle through the open text windows (mail windows, top level lisp windows, TEdit windows, etc.) without using the mouse. EXPAND expands TEdit abbreviations. (See page 20.31 of the Interlisp Reference Manual.) HELP displays a menu of the keybindings until a mouse key is clicked. UNDO acts as the TEdit UNDO syntax class. Note that it still retains its TELERAID function as does STOP. There are TEditKey operations (such as Transpose Characters) that are implemented with multiple TEdit operations. Since TEdit will UNDO only single operations, it does not fully UNDO these operations. RightArrow enters \, and | when shifted. (Recall that AGAIN is an escape key.) MARGINS indents the margins of the paragraph selected. Shift-MARGINS exdents the margins. If the right margin is a floating margin, it is left unchanged. To control the amount by which the margins are moved, see "User Switches." As well as the previous functions available on the Dandelion's special keys, the following functions are available on the standard keyboard (thus usable on the Dandelion, Dolphin, and Dorado). Each function is shown with the key that invokes it (in conjunction with the control (denoted ^) or meta (denoted #) key). Thus, for the sixth entry, holding down the metakey and hitting f (or "F") would move the caret one word forward. (To find out how to get a metakey see "User Switches" below.) #/ defaults the caret looks #= queries caret looks #9 smaller caret font #0 larger caret font ^b back character ^f forward character #b back word #f forward word ^p previous line ^n next line ^a beginning of line ^e end of line #< beginning of document #> end of document #s select whole document ^k kills line (delete from caret to end of line) ^o opens line ^d deletes character forward (also on shift backspace) #d deletes word forward (as always ^w deletes word backward) ^t transposes characters #[ indents paralooks. Also available on the MARGINS key #] exdents paralooks. Also available as shift-MARGINS #j justification change (same as CENTER key) #u uppercases selection #c capitalizes selection #l lowercases selection #o inserts object into document #? shows keybindings (same as HELP) #r restores the display Note that the positions of any of these functions can be individually changed using TEDIT.SETFUNCTION (see page 20.30 of the Interlisp Reference Manual). For wholesale customization see "User Switches" below. INTERRUPTS Any operation can be aborted by typing the STOP key. This can be used to abort font changes, GETs, PUTs, etc. A stronger form of interrupt is available as shift-STOP, which prompts the user for a menu of processes to interrupt. ^G is available as a synonym for hitting the STOP key within TEditKey. Outside of TEdit, however, ^G will continue to have the meaning specified in the user's init file. This is often the HELP interrupt, which acts as shift-STOP. Users who are accustomed to typing ^E as a soft interrupt should note that ^E moves to the end of the line. As discussed above, hitting the STOP key (or equivalently, typing ^G) accomplishes what ^E did. Since ^H is defined to be the Backspace action in TEditKey, users cannot type ^A to erase characters even outside of TEditKey (Interlisp-D currently does not allow multiple backspace characters). In addition to the changed functionality mentioned above (provided courtesy of TEditKey), the user should be aware of the following standard Interlisp-D/TEdit behavior: SAME operates as a LooksCopy mode key. First make a selection. Now to copy the looks from some other text simply hold down the SAME key, then select the source for the looks. (Paragraph looks can be copied the same way, but by making the final selection while in the left margin. This is the standard way to select a whole paragraph in TEdit.) MOVE and COPY act as mode keys for the selection mechanism. Thus the user can select the destination, then hold down the MOVE key and make a second selection. This selection will be moved (or COPY'd depending on the mode key used) to the (original) caret position. CONTROL operates as a mode key to signal deletion. This means that holding down the CONTROL key and selecting some text will delete that text when the CONTROL key is released. DELETE deletes the current selection when pressed. DORADO EQUIVALENTS Dandelion Key: Equivalent key on Dorado: OPEN ^o ( or ^O) SAME META FIND finds item in TEdit menu AGAIN ESC DELETE DEL COPY SHIFT MOVE CTRL-SHIFT PROP'S META or LOCK depending on switches NEXT #n ( or #N) EXPAND ^x (or ^X) HELP #? MARGINS #[ (unnest (which is shift-MARGINS on the Dandelion) is #] ) FONT top blank KEYBOARD middle blank UNDO bottom blank STOP ^G shift-STOP #^S (intentionally difficult to type accidentally) The function keys (CENTER, BOLD, etc.) are all available on the function key window brought up when TEditKey is loaded on a Dorado. Note that the function key window can be rebuilt on a Dorado by selecting "Function Keys" in the default TEdit menu (obtained by buttoning in the title bar of a TEdit window). USER SWITCHES TEDITKEY.METAKEY The user must choose a metakey to make use of TEditKey. The value of the variable TEDITKEY.METAKEY is the name of the key that will be your metakey. For instance to make TAB (the default) your metakey, (SETQ TEDITKEY 'TAB) before loading TEditKey. (Note that even in the standard system, TAB is available as Control-I). NOTE: METASHIFT (see page 18.9 of the Interlisp Reference Manual) is redefined to operate on TEDITKEY.METAKEY instead of on the bottom-blank key of the Dorado. The operation of TEditKey is controlled by the following (INITVARed) variables: TEDITKEY.LOCKTOGGLEKEY is the key that will be turned into a lock-toggle. If it is non-NIL, that key is set to act as a lock-toggle. Thus hitting this switches the case of the type-in. For those users who have removed the spring from their lock key, TEDITKEY.LOCKTOGGLEKEY is usually PROP'S. The action of LOCK is then made to be '(CTRLDOWN. CTRLUP) providing the user with a control key where LOCK is located and a lock toggle where PROP'S is located. TEDITKEY.FONTS is an eight-element list of the fonts that are invoked by meta-1 through meta-8. The defaults are listed above. TEDIT.DEFAULT.CHARLOOKS defines the looks that result when the DEFAULTS key is pressed or when default caret looks are requested. It is an instance of the CHARLOOKS datatype. To preset it, for instance, to TIMESROMAN 10 type the following to the Lisp top level. (SETQ TEDIT.DEFAULT.CHARLOOKS (CHARLOOKS.FROM.FONT (FONTCREATE 'TIMESROMAN 10))) However, a much simpler method is to select an instance of the desired looks and type shift-DEFAULTS. TEDITKEY.VERBOSE if T (the default), the functions that modify the caret looks print feedback in the (TEdit) prompt window. TEDITKEY.NESTWIDTH is the distance (in points) that the indent and exdent functions move the margins. Initially 36 points (0.5 inches). \TK.SIZEINCREMENT is the amount (in points) which the LARGER function increases the selection (and conversely for SMALLER). Initially 2 points. TEDITKEY.OFFSETINCREMENT is the amount (in points) which the SUBSCRIPT function raises the selection (and conversely for SUPERSCRIPT). Initially 3 points. TEDITKEY.KEYBINDINGS is the list that controls the mapping of keys to functions for the functions that are common to the Dandelion, Dorado, and Dolphin. It consists of triples of function name, list of CHARCODE-style character specifications, and a comment describing what the function does. (The comments are used by the automated menu-building tools and their inclusion is encouraged.) TEDITKEY.DLION.KEYACTIONS is the list that specifies the key actions of the non-Alto keys (to the left and right) on the Dandelion. It is the format acceptable to MODIFY.KEYACTIONS (see page 18.9 of the Interlisp Reference Manual). TEDITKEY.DLION.KEYBINDINGS is the list specifying the functions to be tied to the characters generated from above. The keynames in the CAR of each element are comments. Note that TEDIT.DLION.KEYACTIONS and TEDIT.DLION.KEYBINDINGS must be coordinated (similarly for TEDITKEY.FNKEYACTIONS and TEDITKEY.FNKEYBINDINGS). TEDIT.DLION.KEYSYNTAX is the list of syntax classes to be applied to the Dandelion keys. TEDITKEY.FNKEYACTIONS is the list that specifies the keyactions of the function keys (center, bold, etc.). TEDITKEY.FNKEYBINDINGS is analogous to TEDIT.DLION.KEYBINDINGS but for the function keys. TEDITKEY.DORADO.KEYACTIONS are the keyactions unique to the Dorado (and Dolphin). TEDITKEY.DORADO.KEYSYNTAX is analogous to TEDIT.DLION.KEYSYNTAX. The previous variables in conjunction with the following functions specify the effect of TEditKey. (TEDITKEY.INSTALL readtable) invokes the keyactions and bindings as specified by the above variables on readtable. (Readtable defaults to TEDIT.READTABLE). (\TK.BUILD.MENU) is a function that automagically builds the help menu from the values of the above variables. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 267) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) -ČT,Č2ČČ2Č02Čx,Č,Č ,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEADCLASSICCLASSICCLASSIC +TIMESROMAN +MODERNMODERN MODERN +˙üMODERN +˙ţMODERN +˙ţMODERN +MODERN +MODERN MODERNMODERN +    HRULE.GETFNMODERN +  + HRULE.GETFNMODERN +  + HRULE.GETFNMODERN +    HRULE.GETFNMODERN   + HRULE.GETFNMODERN   3   +& > #  +~ ˘  + +ß  + +–  + +9  + +  +0  + +x   B  C  ++  + +  + +a $ +5  + +‚ š  + +…      +    9 *  + +“  + +G   + +‘  + +P  + +”  + + +ń  +5   + +@  + +1  + + +E  + +ŕ đ       +           1  7 =  9 7 .    ! $  } :  + + + ç č Í Ć ¨  + +X  + +  +ţ  + +Ş  + +-  +(  + +  + +  + +  + +  + +  + +  + + +  + +#  + +  + +  + +  + +=  + +  + +  + +  + +   +4 „ Ż  + + +T  +á & ` O  + +˛  + +q  + +ń Q d  + +k  + +v  + +  + +ƒ  + +r  + +˛   + +#  + +C  + +U  + +C  + +7  + +' b  + + M    + +]  +3fłzş \ No newline at end of file diff --git a/lispusers/TEDITTALK b/lispusers/TEDITTALK new file mode 100644 index 00000000..21116569 --- /dev/null +++ b/lispusers/TEDITTALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Jul-88 15:38:03" |{MCS:MCS:STANFORD}TEDITTALK.;2| 24816 previous date%: "13-Jun-88 16:35:46" |{MCS:MCS:STANFORD}TEDITTALK.;1|) (PRETTYCOMPRINT TEDITTALKCOMS) (RPAQQ TEDITTALKCOMS [(* TALK TEdit Service) (LOCALVARS . T) (FNS TALK.TEDIT.DISPLAY TALK.TEDIT.LISTEN TALK.TEDIT.CHARFN) (* TALK TEdit hooks) (FNS TALK.TEDIT.USERFN TALK.TEDIT.INSERT TALK.SELFN TALK.SETSELFN TALK.IMAGEOBJFN TALK.LOOKSFN TALK.PARAFN TALK.INSERTFN TALK.INCLUDEFN TALK.DELETEFN TALK.GETFN) (FNS TALK.TEDIT.BACKSPACE TALK.TEDIT.INCLUDE TALK.TEDIT.DELETE.TEXT TALK.TEDIT.GET TALK.TEDIT.INSERT.TEXT TALK.TEDIT.SETSEL TALK.TEDIT.INSERT.OBJECT TALK.TEDIT.LOOKS TALK.TEDIT.PARALOOKS TALK.TEDIT.DELETE) (FNS TALK.ENCODE.SEL TALK.DECODE.SEL) (* TALK data) (VARS TALK.TEDIT.ACTIONS TALK.FROM.TEDIT.PROPS TALK.TO.TEDIT.PROPS) (GLOBALVARS TALK.TEDIT.ACTIONS TALK.TO.TEDIT.PROPS TALK.FROM.TEDIT.PROPS) (* etc) (FILES TALK TEDIT) (APPENDVARS (GAP.SERVICETYPES (6 TEdit TALK.NS.SERVER)) (TALK.SERVICETYPES (TEdit TALK.TEDIT.DISPLAY TALK.TEDIT.LISTEN))) (ADDVARS (TALK.TEDIT.ADVISEDFNS TEDIT.SETSEL TEDIT.INSERT TEDIT.DELETE TEDIT.INSERT.OBJECT TEDIT.LOOKS TEDIT.PARALOOKS OPENFILE-IN-TEDIT.INCLUDE)) (ADVISE * (PROGN TALK.TEDIT.ADVISEDFNS)) (GLOBALVARS TALK.TEDIT.ADVISEDFNS) (DECLARE%: DONTCOPY DOEVAL@COMPILE (ALISTS (CHARACTERNAMES UNDO REDO NEXT MARGINS FONT SHIFT.UNDO SHIFT.REDO SHIFT.NEXT SHIFT.MARGINS SHIFT.FONT SHIFT.DEL) (PRINTOUTMACROS .OP .FORCE))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TALK.TEDIT.USERFN]) (* TALK TEdit Service) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (TALK.TEDIT.DISPLAY [LAMBDA (MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOL USER) (* ; "Edited 2-Jun-88 16:25 by cdl") (LET (TEXTOBJ) (TEDIT NIL MAINWINDOW NIL TALK.TO.TEDIT.PROPS) (TEXTPROP (SETQ TEXTOBJ (WINDOWPROP MAINWINDOW 'TEXTOBJ)) 'TALK OUTPUTSTREAM) (with TEXTOBJ TEXTOBJ (SETQ TXTFILE (CONCAT "Talk with " USER))) (TEDIT.SETSEL (OPENTEXTSTREAM NIL WINDOW NIL NIL TALK.FROM.TEDIT.PROPS) 1 0 'LEFT) (WINDOWPROP WINDOW 'PROMPTWINDOW (WINDOWPROP MAINWINDOW 'PROMPTWINDOW]) (TALK.TEDIT.LISTEN [LAMBDA (MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOLTYPE) (* ; "Edited 7-Jun-88 08:45 by cdl") (* DECLARATIONS%: (RECORD ACTION  (CCODES ACTIONFN TEXTOBJP))) (DECLARE (SPECVARS INPUTSTREAM)) (PROG ((POSITION (create POSITION)) (TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ)) (TEXTSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM)) (SCRATCHPTR (ALLOCSTRING 0)) (STRING (ALLOCSTRING 128)) (EVENTFN (with TALK.PROTOCOLTYPE PROTOCOLTYPE TALK.EVENTFN)) STRINGSTREAM EOFPTR BYTE ACTION CCODE) [SETQ EOFPTR (GETEOFPTR (SETQ STRINGSTREAM (OPENSTRINGSTREAM STRING 'BOTH] (while (OPENP TEXTSTREAM) do (APPLY* EVENTFN INPUTSTREAM OUTPUTSTREAM) (if (NOT (AND (OPENP INPUTSTREAM) (OPENP OUTPUTSTREAM))) then (RETURN)) (TALK.FLASH.CARET WINDOW POSITION 'OFF) (while (AND (OPENP INPUTSTREAM) (READP INPUTSTREAM)) do (SELCHARQ (SETQ BYTE (LOGAND (SETQ CCODE (READCCODE INPUTSTREAM)) (MASK.1'S 0 8))) (BS (* Flush text buffer) (TALK.TEDIT.INSERT TEXTSTREAM STRING STRINGSTREAM SCRATCHPTR) (* the escape code) (SETQ CCODE (LOGAND (SETQ CCODE (READCCODE INPUTSTREAM)) (MASK.1'S 0 10))) (if [SETQ ACTION (for ACTION in TALK.TEDIT.ACTIONS thereis (with ACTION ACTION (EQMEMB CCODE CCODES ] then (with ACTION ACTION (APPLY* ACTIONFN (if TEXTOBJP then TEXTOBJ else TEXTSTREAM) INPUTSTREAM)))) (^G (* Flush text buffer) (TALK.TEDIT.INSERT TEXTSTREAM STRING STRINGSTREAM SCRATCHPTR) (TALK.RINGBELLS WINDOW)) (if (LESSP CCODE (MASK.1'S 0 8)) then (PRINTCCODE CCODE STRINGSTREAM) (if (LEQ EOFPTR (GETFILEPTR STRINGSTREAM)) then (TALK.TEDIT.INSERT TEXTSTREAM STRING STRINGSTREAM SCRATCHPTR)) else (TALK.TEDIT.INSERT TEXTSTREAM STRING STRINGSTREAM SCRATCHPTR) (* String streams don't handle NS  charaters so don't buffer) (TALK.TEDIT.INSERT TEXTSTREAM CCODE))) finally (TALK.TEDIT.INSERT TEXTSTREAM STRING STRINGSTREAM SCRATCHPTR)) (TALK.FLASH.CARET WINDOW POSITION 'ON)) (if (SETQ TEXTOBJ (WINDOWPROP MAINWINDOW 'TEXTOBJ)) then (with TEXTOBJ TEXTOBJ (SETQ TXTFILE (CONCAT TXTFILE TALK.CLOSED.STRING]) (TALK.TEDIT.CHARFN [LAMBDA (TEXTOBJ CCODE) (* ; "Edited 9-Jun-88 15:06 by cdl") (DECLARE (SPECVARS CCODE)) (PROG [(STREAM (TEXTPROP TEXTOBJ 'TALK] (if (OPENP STREAM) then (SELCHARQ CCODE ((BS ^W DEL UNDO REDO NEXT) (PRINTOUT STREAM .OP CCODE)) ((SHIFT.UNDO SHIFT.REDO SHIFT.NEXT) (PRINTOUT STREAM .OP (BITCLEAR CCODE (MASK.1'S 5 1)))) (^O (RETURN T)) (^A (RETURN)) ((SHIFT.DEL FONT SHIFT.FONT MARGINS SHIFT.MARGINS) (* Unimplemented function keys, pass  through) (PRINTCCODE CCODE STREAM)) (if (OR (LESSP CCODE (CHARCODE 2,0)) (GEQ CCODE (CHARCODE 3,0))) then (* Filter out function keys in the  2,0 range) (PRINTCCODE CCODE STREAM))) (if (NOT (READP)) then (FORCEOUTPUT STREAM))) (RETURN T]) ) (* TALK TEdit hooks) (DEFINEQ (TALK.TEDIT.USERFN [LAMBDA VAR (* cdl " 2-Mar-87 09:53") (LET [(USERFN (TEXTPROP (ARG VAR 2) (ARG VAR 1] (if USERFN then (APPLY USERFN (for M from 2 to VAR collect (ARG VAR M]) (TALK.TEDIT.INSERT [LAMBDA (TEXTSTREAM STRING.OR.CCODE STRINGSTREAM SCRATCHPTR) (* cdl "24-Mar-87 08:45") (if STRINGSTREAM then (LET ((FILEPTR (GETFILEPTR STRINGSTREAM))) (if (NOT (ZEROP FILEPTR)) then (TEDIT.INSERT TEXTSTREAM (SUBSTRING STRING.OR.CCODE 1 FILEPTR SCRATCHPTR)) (SETFILEPTR STRINGSTREAM 0))) else (TEDIT.INSERT TEXTSTREAM (MKSTRING (CHARACTER STRING.OR.CCODE]) (TALK.SELFN [LAMBDA (TEXTOBJ SELECTION SELECTMODE FINAL?) (* ; "Edited 9-Jun-88 15:06 by cdl") (DECLARE (SPECVARS SELECTION SELECTMODE)) (SELECTQ FINAL? (FINAL (SELECTQ SELECTMODE ((NORMAL PENDINGDEL DELETE) (PROG [(STREAM (TEXTPROP TEXTOBJ 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^S) |.P2| (LIST (TALK.ENCODE.SEL SELECTION) SELECTMODE) .FORCE)))) NIL)) NIL]) (TALK.SETSELFN [LAMBDA (TEXTSTREAM CH#ORSEL LEN POINT PENDINGDELFLG LEAVECARETLOOKS OPERATION) (* ; "Edited 9-Jun-88 15:09 by cdl") (DECLARE (SPECVARS CH#ORSEL LEN POINT OPERATION)) (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then [if (NULL OPERATION) then (SETQ OPERATION (if PENDINGDELFLG then 'PENDINGDEL else 'NORMAL] (PRINTOUT STREAM .OP (CHARCODE ^S) |.P2| (LIST (TALK.ENCODE.SEL CH#ORSEL LEN POINT) OPERATION) .FORCE]) (TALK.IMAGEOBJFN [LAMBDA (TEXTSTREAM OBJECT CH#ORSEL) (* ; "Edited 9-Jun-88 15:10 by cdl") (DECLARE (SPECVARS TEXTSTREAM CH#ORSEL)) (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^T)) (WRITEIMAGEOBJ OBJECT STREAM) (PRINTOUT STREAM |.P2| (with SELECTION (TEDIT.GETSEL TEXTSTREAM) (TALK.ENCODE.SEL CH#ORSEL DCH POINT)) .FORCE]) (TALK.LOOKSFN [LAMBDA (TEXTSTREAM NEWLOOKS CH#ORSEL LEN) (* ; "Edited 9-Jun-88 15:10 by cdl") (DECLARE (SPECVARS NEWLOOKS CH#ORSEL LEN)) (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^U) |.P2| (LIST NEWLOOKS (TALK.ENCODE.SEL CH#ORSEL LEN)) .FORCE]) (TALK.PARAFN [LAMBDA (TEXTOBJ NEWLOOKS CH#ORSEL LEN) (* ; "Edited 9-Jun-88 15:10 by cdl") (DECLARE (SPECVARS NEWLOOKS CH#ORSEL LEN)) (PROG [(STREAM (TEXTPROP TEXTOBJ 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^V) |.P2| (LIST NEWLOOKS (TALK.ENCODE.SEL CH#ORSEL LEN)) .FORCE]) (TALK.INSERTFN [LAMBDA (TEXTSTREAM TEXT CH#ORSEL LOOKS DONTSCROLL) (* ; "Edited 9-Jun-88 15:11 by cdl") (DECLARE (SPECVARS TEXT CH#ORSEL LOOKS DONTSCROLL)) (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^R) |.P2| (LIST TEXT (TALK.ENCODE.SEL CH#ORSEL) LOOKS DONTSCROLL) .FORCE]) (TALK.INCLUDEFN [LAMBDA (TEXTSTREAM FILE START END) (* ; "Edited 9-Jun-88 15:11 by cdl") (DECLARE (SPECVARS FILE START END)) (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^O) |.P2| (LIST FILE START END) .FORCE]) (TALK.DELETEFN [LAMBDA (TEXTSTREAM CH#ORSEL LEN) (* ; "Edited 9-Jun-88 15:12 by cdl") (DECLARE (SPECVARS TEXTSTREAM CH#ORSEL LEN)) (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^P) |.P2| (LIST (TALK.ENCODE.SEL (OR CH#ORSEL (TEDIT.GETSEL TEXTSTREAM)) LEN) LEN) .FORCE]) (TALK.GETFN [LAMBDA (TEXTSTREAM FULLFILENAME WHEN) (* ; "Edited 9-Jun-88 15:12 by cdl") (DECLARE (SPECVARS FULLFILENAME)) (SELECTQ WHEN (BEFORE (PROG [(STREAM (TEXTPROP TEXTSTREAM 'TALK] (if (OPENP STREAM) then (PRINTOUT STREAM .OP (CHARCODE ^Q) |.P2| (LIST FULLFILENAME) .FORCE)))) NIL]) ) (DEFINEQ (TALK.TEDIT.BACKSPACE [LAMBDA (TEXTSTREAM) (* cdl " 5-May-87 18:07") (with SELECTION (TEDIT.GETSEL TEXTSTREAM) (TEDIT.DELETE TEXTSTREAM (SUB1 (SELECTQ POINT (LEFT CH#) CHLIM)) 1]) (TALK.TEDIT.INCLUDE [LAMBDA (TEXTSTREAM STREAM) (* cdl "10-Mar-87 17:04") (* DECLARATIONS%: (RECORD DATA  (FILE START END))) (with DATA (READ STREAM) (TEDIT.INCLUDE TEXTSTREAM FILE START END]) (TALK.TEDIT.DELETE.TEXT [LAMBDA (TEXTSTREAM STREAM) (* cdl " 2-Mar-87 12:06") (* DECLARATIONS%: (RECORD DATA  (PLST LEN))) (with DATA (READ STREAM) (TEDIT.DELETE TEXTSTREAM (TALK.DECODE.SEL TEXTSTREAM PLST) LEN]) (TALK.TEDIT.GET [LAMBDA (TEXTOBJ STREAM) (* ; "Edited 3-Jun-88 09:54 by cdl") (* DECLARATIONS%: (RECORD DATA  (FULLFILENAME))) (with TEXTOBJ TEXTOBJ (SETQ \XDIRTY NIL)) (with DATA (READ STREAM) (TEDIT.GET TEXTOBJ FULLFILENAME]) (TALK.TEDIT.INSERT.TEXT [LAMBDA (TEXTSTREAM STREAM) (* cdl " 2-Mar-87 11:42") (* DECLARATIONS%: (RECORD DATA  (TEXT PLST LOOKS DONTSCROLL))) (with DATA (READ STREAM) (TEDIT.INSERT TEXTSTREAM TEXT (TALK.DECODE.SEL TEXTSTREAM PLST) LOOKS DONTSCROLL]) (TALK.TEDIT.SETSEL [LAMBDA (TEXTSTREAM STREAM) (* cdl " 1-Mar-87 10:33") (* DECLARATIONS%: (RECORD DATA  (PLST SELECTMODE))) (with DATA (READ STREAM) (TALK.DECODE.SEL TEXTSTREAM PLST SELECTMODE]) (TALK.TEDIT.INSERT.OBJECT [LAMBDA (TEXTSTREAM STREAM) (* cdl " 5-May-87 18:04") (LET (OBJECT) (if [SETQ OBJECT (RESETFORM (INPUT STREAM) (ERRORSET (READ] then (TEDIT.INSERT.OBJECT (CAR OBJECT) TEXTSTREAM (TALK.DECODE.SEL TEXTSTREAM (READ STREAM]) (TALK.TEDIT.LOOKS [LAMBDA (TEXTSTREAM STREAM) (* cdl " 1-Mar-87 12:19") (* DECLARATIONS%: (RECORD DATA  (NEWLOOKS PLST))) (with DATA (READ STREAM) (TEDIT.LOOKS TEXTSTREAM NEWLOOKS (TALK.DECODE.SEL TEXTSTREAM PLST]) (TALK.TEDIT.PARALOOKS [LAMBDA (TEXTSTREAM STREAM) (* cdl " 1-Mar-87 12:22") (* DECLARATIONS%: (RECORD DATA  (NEWLOOKS PLST))) (with DATA (READ STREAM) (TEDIT.PARALOOKS (TEXTOBJ TEXTSTREAM) NEWLOOKS (TALK.DECODE.SEL TEXTSTREAM PLST]) (TALK.TEDIT.DELETE [LAMBDA (TEXTSTREAM) (* cdl " 1-Mar-87 10:34") (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (TALK.ENCODE.SEL [LAMBDA (CH#ORSEL LEN POINT) (* cdl "16-Mar-87 08:18") (* DECLARATIONS%: (PROPRECORD PLST  (CH# DCH POINT))) (if (type? SELECTION CH#ORSEL) then [for FIELD in [CONSTANT (LDIFFERENCE (RECORDFIELDNAMES 'SELECTION) '(X0 Y0 XLIM YLIM L1 LN DX \TEXTOBJ SELOBJINFO] join (LIST FIELD (RECORDACCESS FIELD CH#ORSEL (CONSTANT (RECLOOK 'SELECTION)) 'FETCH] else (create PLST CH# _ CH#ORSEL DCH _ (OR LEN 0) POINT _ (OR POINT 'LEFT]) (TALK.DECODE.SEL [LAMBDA (TEXTSTREAM PLST SELECTMODE) (* cdl "16-Mar-87 08:12") (* DECLARATIONS%: (PROPRECORD PLST  (CH# DCH POINT))) (with PLST PLST (TEDIT.SETSEL TEXTSTREAM (OR CH# (fetch (SELECTION CH#) of (TEDIT.GETSEL TEXTSTREAM))) DCH POINT (EQ 'PENDINGDEL SELECTMODE) NIL SELECTMODE]) ) (* TALK data) (RPAQQ TALK.TEDIT.ACTIONS ((8 TALK.TEDIT.BACKSPACE) (15 TALK.TEDIT.INCLUDE) (16 TALK.TEDIT.DELETE.TEXT) (17 TALK.TEDIT.GET TEXTOBJ) (18 TALK.TEDIT.INSERT.TEXT) (19 TALK.TEDIT.SETSEL) (20 TALK.TEDIT.INSERT.OBJECT) (21 TALK.TEDIT.LOOKS) (22 TALK.TEDIT.PARALOOKS) (23 \TEDIT.WORDDELETE TEXTOBJ) (127 TALK.TEDIT.DELETE) (516 TEDIT.UNDO TEXTOBJ) (520 TEDIT.REDO TEXTOBJ) (530 TEDIT.NEXT))) (RPAQQ TALK.FROM.TEDIT.PROPS (PROMPTWINDOW DON'T NOTITLE T COPYBYBKSYSBUF T MENU ((Put 'Put NIL (SUBITEMS Plain-Text Old-Format)) Find Quit))) (RPAQQ TALK.TO.TEDIT.PROPS (CHARFN TALK.TEDIT.CHARFN SELFN TALK.SELFN GETFN TALK.GETFN IMAGEOBJFN TALK.IMAGEOBJFN LOOKSFN TALK.LOOKSFN PARAFN TALK.PARAFN INSERTFN TALK.INSERTFN SETSELFN TALK.SETSELFN DELETEFN TALK.DELETEFN INCLUDEFN TALK.INCLUDEFN NOTITLE T QUITFN TRUE COPYBYBKSYSBUF T)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.TEDIT.ACTIONS TALK.TO.TEDIT.PROPS TALK.FROM.TEDIT.PROPS) ) (* etc) (FILESLOAD TALK TEDIT) (APPENDTOVAR GAP.SERVICETYPES (6 TEdit TALK.NS.SERVER)) (APPENDTOVAR TALK.SERVICETYPES (TEdit TALK.TEDIT.DISPLAY TALK.TEDIT.LISTEN)) (ADDTOVAR TALK.TEDIT.ADVISEDFNS TEDIT.SETSEL TEDIT.INSERT TEDIT.DELETE TEDIT.INSERT.OBJECT TEDIT.LOOKS TEDIT.PARALOOKS OPENFILE-IN-TEDIT.INCLUDE) [XCL:REINSTALL-ADVICE 'TEDIT.SETSEL :BEFORE '((:LAST (TALK.TEDIT.USERFN 'SETSELFN STREAM CH# LEN POINT PENDINGDELFLG LEAVECARETLOOKS OPERATION] [XCL:REINSTALL-ADVICE 'TEDIT.INSERT :BEFORE '((:LAST (TALK.TEDIT.USERFN 'INSERTFN STREAM TEXT CH#ORSEL LOOKS DONTSCROLL] [XCL:REINSTALL-ADVICE 'TEDIT.DELETE :BEFORE '((:LAST (TALK.TEDIT.USERFN 'DELETEFN STREAM SEL LEN LEAVECARETLOOKS] [XCL:REINSTALL-ADVICE 'TEDIT.INSERT.OBJECT :BEFORE '((:LAST (TALK.TEDIT.USERFN 'IMAGEOBJFN STREAM OBJECT CH#] [XCL:REINSTALL-ADVICE 'TEDIT.LOOKS :BEFORE '((:LAST (TALK.TEDIT.USERFN 'LOOKSFN STREAM NEWLOOKS SELORCH# LEN] [XCL:REINSTALL-ADVICE 'TEDIT.PARALOOKS :BEFORE '((:LAST (TALK.TEDIT.USERFN 'PARAFN TEXTOBJ NEWLOOKS SEL LEN] [XCL:REINSTALL-ADVICE '(OPENFILE :IN TEDIT.INCLUDE) :BEFORE '((:LAST (TALK.TEDIT.USERFN 'INCLUDEFN STREAM FILE START END] (READVISE TEDIT.SETSEL TEDIT.INSERT TEDIT.DELETE TEDIT.INSERT.OBJECT TEDIT.LOOKS TEDIT.PARALOOKS (OPENFILE :IN TEDIT.INCLUDE)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.TEDIT.ADVISEDFNS) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (ADDTOVAR CHARACTERNAMES (UNDO 2,4) (REDO 2,10) (NEXT 2,22) (MARGINS 2,111) (FONT 2,112) (SHIFT.UNDO 2,44) (SHIFT.REDO 2,50) (SHIFT.NEXT 2,62) (SHIFT.MARGINS 2,151) (SHIFT.FONT 2,152) (SHIFT.DEL 2,27)) (ADDTOVAR PRINTOUTMACROS [.OP (LAMBDA (COMS) (CONS `(PROGN (PRINTCCODE (CHARCODE BS) NIL) (PRINTCCODE ,(CADR COMS) NIL)) (CDDR COMS] [.FORCE (LAMBDA (COMS) (CONS '(FORCEOUTPUT NIL) (CDR COMS]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TALK.TEDIT.USERFN) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (2190 8573 (TALK.TEDIT.DISPLAY 2200 . 2844) (TALK.TEDIT.LISTEN 2846 . 7122) ( TALK.TEDIT.CHARFN 7124 . 8571)) (8603 14772 (TALK.TEDIT.USERFN 8613 . 8921) (TALK.TEDIT.INSERT 8923 . 9559) (TALK.SELFN 9561 . 10339) (TALK.SETSELFN 10341 . 11199) (TALK.IMAGEOBJFN 11201 . 11779) ( TALK.LOOKSFN 11781 . 12246) (TALK.PARAFN 12248 . 12709) (TALK.INSERTFN 12711 . 13231) (TALK.INCLUDEFN 13233 . 13664) (TALK.DELETEFN 13666 . 14239) (TALK.GETFN 14241 . 14770)) (14773 18681 ( TALK.TEDIT.BACKSPACE 14783 . 15139) (TALK.TEDIT.INCLUDE 15141 . 15520) (TALK.TEDIT.DELETE.TEXT 15522 . 15943) (TALK.TEDIT.GET 15945 . 16371) (TALK.TEDIT.INSERT.TEXT 16373 . 16830) (TALK.TEDIT.SETSEL 16832 . 17218) (TALK.TEDIT.INSERT.OBJECT 17220 . 17640) (TALK.TEDIT.LOOKS 17642 . 18047) ( TALK.TEDIT.PARALOOKS 18049 . 18508) (TALK.TEDIT.DELETE 18510 . 18679)) (18682 20137 (TALK.ENCODE.SEL 18692 . 19545) (TALK.DECODE.SEL 19547 . 20135))))) STOP \ No newline at end of file diff --git a/lispusers/TEK4010 b/lispusers/TEK4010 new file mode 100644 index 00000000..4c03f454 --- /dev/null +++ b/lispusers/TEK4010 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 9-May-88 23:30:31" {ERINYES}MEDLEY>TEK4010.;1 6442 previous date%: " 8-May-85 12:20:13" {ERINYES}LYRIC>TEK4010.;1) (* " Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEK4010COMS) (RPAQQ TEK4010COMS ((FNS GLOMHI&LO TEK.DRAWTO TEK.MOVETO TEK4010.INTERP) (MACROS ->NEXTSTATE \BIN7BITS) (VARS TEKPTSPERPOINT))) (DEFINEQ (GLOMHI&LO [LAMBDA (HIBYTE LOBYTE) (* hdj "10-Sep-84 14:32") (IPLUS LOBYTE (LLSH HIBYTE 5]) (TEK.DRAWTO [LAMBDA (X Y WIDTH OPERATION STREAM) (* AJB "18-Mar-85 16:16") (DRAWTO (IQUOTIENT X TEKPTSPERPOINT) (IQUOTIENT Y TEKPTSPERPOINT) WIDTH OPERATION STREAM]) (TEK.MOVETO [LAMBDA (X Y STREAM) (* AJB "18-Mar-85 16:16") (MOVETO (IQUOTIENT X TEKPTSPERPOINT) (IQUOTIENT Y TEKPTSPERPOINT) STREAM]) (TEK4010.INTERP [LAMBDA (INSTREAM OUTSTREAM) (* AJB "27-Mar-85 12:55") (PROG (CURRSTATE PREVSTATE INBYTE HI2BITS LO5BITS HIX LOX HIY LOY DRAWP) (* start out by moving, not drawing) (SETQQ PREVSTATE @ALPHASTATE) (SETQQ CURRSTATE @ALPHASTATE) @ALPHASTATE (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (COND ((ZEROP HI2BITS) (->NEXTSTATE @ALPHA.CTRLSTATE)) (T (BOUT OUTSTREAM INBYTE) (->NEXTSTATE @ALPHASTATE))) @GRAPHICSSTATE (SETQ DRAWP NIL) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (SELECTQ HI2BITS (0 (->NEXTSTATE @GRAPHICS.CTRLSTATE)) (1 (->NEXTSTATE @HIYSTATE)) (2 (->NEXTSTATE @LOXSTATE)) (3 (->NEXTSTATE @LOYSTATE)) NIL) @HIYSTATE (SETQ HIY LO5BITS) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (SELECTQ HI2BITS (0 (->NEXTSTATE @GRAPHICS.CTRLSTATE)) (1 (->NEXTSTATE @HIYSTATE)) (2 (->NEXTSTATE @LOXSTATE)) (3 (->NEXTSTATE @LOYSTATE)) NIL) @LOYSTATE (SETQ LOY LO5BITS) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (SELECTQ HI2BITS (0 (->NEXTSTATE @GRAPHICS.CTRLSTATE)) (1 (->NEXTSTATE @HIXSTATE)) (2 (->NEXTSTATE @LOXSTATE)) (3 (->NEXTSTATE @LOYSTATE)) NIL) @HIXSTATE (SETQ HIX LO5BITS) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (SELECTQ HI2BITS (0 (->NEXTSTATE @GRAPHICS.CTRLSTATE)) (1 (->NEXTSTATE @HIYSTATE)) (2 (->NEXTSTATE @LOXSTATE)) (3 (->NEXTSTATE @LOYSTATE)) NIL) @LOXSTATE (SETQ LOX LO5BITS) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (COND (DRAWP (TEK.DRAWTO (GLOMHI&LO HIX LOX) (GLOMHI&LO HIY LOY) 1 NIL OUTSTREAM)) (T (TEK.MOVETO (GLOMHI&LO HIX LOX) (GLOMHI&LO HIY LOY) OUTSTREAM) (SETQ DRAWP T))) (SELECTQ HI2BITS (0 (->NEXTSTATE @GRAPHICS.CTRLSTATE)) (1 (->NEXTSTATE @HIYSTATE)) (2 (->NEXTSTATE @LOXSTATE)) (3 (->NEXTSTATE @LOYSTATE)) NIL) @ALPHA.CTRLSTATE (SELECTQ LO5BITS (7 (RINGBELLS 1)) (8 (RELMOVETO -14 0 OUTSTREAM)) (9 (RELMOVETO 14 0 OUTSTREAM)) (10 (RELMOVETO 0 -22 OUTSTREAM)) (11 (RELMOVETO 0 22 OUTSTREAM)) (27 (->NEXTSTATE @ESCSTATE)) (29 (->NEXTSTATE @GRAPHICSSTATE)) (13 (MOVETO 0 (DSPYPOSITION NIL OUTSTREAM) OUTSTREAM) (->NEXTSTATE @ALPHASTATE)) (31 (->NEXTSTATE @ALPHASTATE)) NIL) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (COND ((EQ HI2BITS 0) (->NEXTSTATE @ALPHA.CTRLSTATE)) (T (->NEXTSTATE @ALPHASTATE))) @GRAPHICS.CTRLSTATE (SELECTQ LO5BITS (4 (->NEXTSTATE @ALPHASTATE)) (7 (RINGBELLS 1)) (8 (RELMOVETO -14 0 OUTSTREAM)) (9 (RELMOVETO 14 0 OUTSTREAM)) (10 (RELMOVETO 0 -22 OUTSTREAM)) (11 (RELMOVETO 0 22 OUTSTREAM)) (27 (->NEXTSTATE @ESCSTATE)) (29 (->NEXTSTATE @GRAPHICSSTATE)) (13 (MOVETO 0 (DSPYPOSITION NIL OUTSTREAM) OUTSTREAM)) (31 (->NEXTSTATE @ALPHASTATE)) NIL) (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (SELECTQ HI2BITS (0 (->NEXTSTATE @GRAPHICS.CTRLSTATE)) (1 (COND ((EQUAL PREVSTATE '@LOYSTATE) (->NEXTSTATE @HIXSTATE)) (T (->NEXTSTATE @HIYSTATE)))) (2 (->NEXTSTATE @LOXSTATE)) (3 (->NEXTSTATE @LOYSTATE)) NIL) @ESCSTATE (\BIN7BITS INSTREAM INBYTE HI2BITS LO5BITS) (COND ((EQ LO5BITS 12) (DSPRESET OUTSTREAM))) (->NEXTSTATE @ALPHASTATE]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS ->NEXTSTATE MACRO ((STATE) (PROGN (SETQ PREVSTATE CURRSTATE) (SETQ CURRSTATE STATE) (GO STATE] [PUTPROPS \BIN7BITS MACRO (ARGS (LET ((INSTREAM (CAR ARGS)) (INBYTE (CADR ARGS)) (HI2BITS (CADDR ARGS)) (LO5BITS (CADDDR ARGS))) `(PROGN (SETQ %, INBYTE (LOGAND 127 (BIN %, INSTREAM))) (SETQ %, HI2BITS (LRSH %, INBYTE 5)) (SETQ %, LO5BITS (LOGAND %, INBYTE 31] ) (RPAQQ TEKPTSPERPOINT 2) (PUTPROPS TEK4010 COPYRIGHT ("Xerox Corporation" 1985 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (521 5591 (GLOMHI&LO 531 . 671) (TEK.DRAWTO 673 . 896) (TEK.MOVETO 898 . 1105) ( TEK4010.INTERP 1107 . 5589))))) STOP \ No newline at end of file diff --git a/lispusers/TEK4010CHAT b/lispusers/TEK4010CHAT new file mode 100644 index 00000000..b291673b --- /dev/null +++ b/lispusers/TEK4010CHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 9-May-88 23:30:55" {ERINYES}MEDLEY>TEK4010CHAT.;1 32912 previous date%: " 5-Sep-85 17:36:43" {ERINYES}LYRIC>TEK4010CHAT.;1) (* " Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEK4010CHATCOMS) (RPAQQ TEK4010CHATCOMS [(RECORDS TEK4010.STATE) (FNS TEK4010.ALPHASTATE TEK4010.CLEAR TEK4010.CLOSEFN TEK4010.CROSSHAIR TEK4010CHAT.INIT TEK4010.NEXTSTATE TEK4010.RELMOVETO TEK4010.SCALE TEK4010.SENDCOORD TEK4010CHAT.BUTTONFN TEK4010.RESHAPEFN TEK4010CHAT.HANDLECHAR TEK4010CHAT.MENUFN TEK4010.GRAPHICSSTATE TEK4010.CTRLCHAR TEK4010.ESCAPECHAR TEK4010.UNSCALE TEK4010.GLOMHI&LO TEK4010.MOVETO TEK4010.DRAWTO) (INITVARS (TEK4010CHAT.MENU NIL)) (VARS TEK4010CHAT.MENUITEMS) (ADDVARS (CHAT.DRIVERTYPES (TEK4010 TEK4010CHAT.HANDLECHAR TEK4010CHAT.INIT]) (DECLARE%: EVAL@COMPILE (DATATYPE TEK4010.STATE (CURRENTSTATE PREVSTATE (HIX INTEGER) (LOX INTEGER) (HIY INTEGER) (LOY INTEGER) (INBYTE BITS 8) (HI2BITS BITS 2) (LO5BITS BITS 5) BYTESTATE (DRAWP FLAG) (ROW INTEGER) (MARGIN INTEGER)) CURRENTSTATE _ 'TEK4010.ALPHASTATE HIX _ 0 LOX _ 0 HIY _ 0 LOY _ 0 INBYTE _ 0 HI2BITS _ 0 LO5BITS _ 0 ROW _ 1 MARGIN _ 0) ) (/DECLAREDATATYPE 'TEK4010.STATE '(POINTER POINTER FIXP FIXP FIXP FIXP (BITS 8) (BITS 2) (BITS 5) POINTER FLAG FIXP FIXP) '((TEK4010.STATE 0 POINTER) (TEK4010.STATE 2 POINTER) (TEK4010.STATE 4 FIXP) (TEK4010.STATE 6 FIXP) (TEK4010.STATE 8 FIXP) (TEK4010.STATE 10 FIXP) (TEK4010.STATE 2 (BITS . 7)) (TEK4010.STATE 0 (BITS . 1)) (TEK4010.STATE 0 (BITS . 36)) (TEK4010.STATE 12 POINTER) (TEK4010.STATE 12 (FLAGBITS . 0)) (TEK4010.STATE 14 FIXP) (TEK4010.STATE 16 FIXP)) '18) (DEFINEQ (TEK4010.ALPHASTATE [LAMBDA (CHAT.STATE STATE) (* jds " 5-Sep-85 11:41") (* This function resets the DRAWP and BYTESTATE fields to NIL such that the  next time GRAPHICSSTATE is entered, it will be clean, and then either outputs  the alpha character or calls the control char routine if the high 2 bits are  zero.) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL) (COND ((ZEROP (fetch (TEK4010.STATE HI2BITS) of STATE)) (TEK4010.CTRLCHAR CHAT.STATE STATE)) (T (BOUT (fetch (CHAT.STATE DSP) of CHAT.STATE) (fetch (TEK4010.STATE INBYTE) of STATE]) (TEK4010.CLEAR [LAMBDA (CHAT.STATE WINDOW) (* AJB " 5-Sep-85 17:36") (* This functions clears the screen  and resets the cursor to the top  left corner) (LET ((OUTSTREAM (fetch (CHAT.STATE DSP) of CHAT.STATE)) (STATE (fetch (CHAT.STATE TERM.STATE) of CHAT.STATE))) (CARET 'OFF) (DSPRESET OUTSTREAM) (CARET T) (replace (TEK4010.STATE ROW) of STATE with 1) (replace (TEK4010.STATE MARGIN) of STATE with 0) (TEK4010.NEXTSTATE STATE 'TEK4010.ALPHASTATE) (replace BYTESTATE of STATE with NIL) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (DSPLEFTMARGIN 0 OUTSTREAM) (* Set the right margin to the width  of the window) (DSPRIGHTMARGIN (FETCH WIDTH OF (DSPCLIPPINGREGION NIL OUTSTREAM)) OUTSTREAM]) (TEK4010.CLOSEFN [LAMBDA (WINDOW) (* AJB " 5-Sep-85 15:36") (* This function resets the window  back to a default state) (WINDOWDELPROP WINDOW 'RESHAPEFN (FUNCTION TEK4010.RESHAPEFN)) (* remove reshape function from  window prop) (WINDOWDELPROP WINDOW 'CLOSEFN (FUNCTION TEK4010.CLOSEFN)) (* Remove this close function so it  doesn't get called again) (DSPOPERATION 'REPLACE WINDOW) (* Restore REPLACE mode for BITBLT) (* Turn scrolling back on) (DSPSCROLL 'ON WINDOW]) (TEK4010.CROSSHAIR [LAMBDA (WINDOW) (* edited%: "26-Apr-85 16:14") (* Moves crosshair around screen  until anykey is struct and then  returns X Y location) (PROG [(WIDTH (WINDOWPROP WINDOW 'WIDTH)) (HEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (REGION (WINDOWPROP WINDOW 'REGION)) (OUTSTREAM (WINDOWPROP WINDOW 'DSP] (LET* [(LEFT 0) (RIGHT (PLUS LEFT WIDTH)) (BOTTOM 0) (TOP (PLUS BOTTOM HEIGHT)) (LASTY (LASTMOUSEY WINDOW)) (LASTX (LASTMOUSEX WINDOW)) (CROSSHAIRX (WINDOWPROP WINDOW 'CROSSHAIRX)) (CROSSHAIRY (WINDOWPROP WINDOW 'CROSSHAIRY] (COND [CROSSHAIRX (COND ((NEQ CROSSHAIRX LASTX) (BLTVLINE CROSSHAIRX 0 HEIGHT WINDOW GRAYSHADE) (BLTVLINE LASTX 0 HEIGHT WINDOW GRAYSHADE] (T (SETQ LASTX (COND ((LESSP LASTX LEFT) LEFT) ((GREATERP LASTX RIGHT) (DIFFERENCE RIGHT 2)) (T LASTX))) (BLTVLINE LASTX 0 HEIGHT WINDOW GRAYSHADE))) (WINDOWPROP WINDOW 'CROSSHAIRX LASTX) (COND [CROSSHAIRY (COND ((NEQ CROSSHAIRY LASTY) (BLTHLINE CROSSHAIRY 0 WIDTH WINDOW GRAYSHADE) (BLTHLINE LASTY 0 WIDTH WINDOW GRAYSHADE] (T (SETQ LASTY (COND ((LESSP LASTY BOTTOM) BOTTOM) ((GREATERP LASTY TOP) (DIFFERENCE TOP 2)) (T LASTY))) (BLTHLINE LASTY 0 WIDTH WINDOW GRAYSHADE))) (WINDOWPROP WINDOW 'CROSSHAIRY LASTY]) (TEK4010CHAT.INIT [LAMBDA (CHAT.STATE) (* AJB " 5-Sep-85 17:30") (* Initialize a CHAT connection  using the TEKtronix 4010 emulator  for display) (PROG* ((OUTSTREAM (fetch (CHAT.STATE DSP) of CHAT.STATE)) (WINDOW (WFROMDS OUTSTREAM)) (XSCALE (FQUOTIENT (fetch WIDTH of (DSPCLIPPINGREGION NIL OUTSTREAM)) 1024)) (YSCALE (FQUOTIENT (fetch HEIGHT of (DSPCLIPPINGREGION NIL OUTSTREAM)) 768))) (DSPFONT '(GACHA 10 MRR) OUTSTREAM) (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION TEK4010.RESHAPEFN)) (* Add reshape window function to  rescale X,Y coords to new window  size) (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION TEK4010.CLOSEFN) T) (* Add close function to restore  state back) (* NOTE%: CLOSE function must be put  at beginning of property list for  CLOSEFN WINDOWPROP) (WINDOWPROP WINDOW 'CURSORMOVEDFN NIL) (* Make sure crosshair function is  disabled) (WINDOWPROP WINDOW 'CROSSHAIRX NIL) (WINDOWPROP WINDOW 'CROSSHAIRY NIL) (DSPLEFTMARGIN 0 OUTSTREAM) (DSPRIGHTMARGIN (FETCH WIDTH OF (DSPCLIPPINGREGION NIL OUTSTREAM))) (* Set the right margin to the width  of the window) (DSPOPERATION 'PAINT OUTSTREAM) (* Set BITBLT to OR bits since this  is emulating a storage tube device) (STREAMPROP OUTSTREAM 'TEK4010.SCALE (MIN XSCALE YSCALE)) (* Set the scale on the output stream so that the entire screen image will fit  into the CHAT window) (SETQ CHAT.EMULATORTYPE 'TEK4010) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION TEK4010CHAT.BUTTONFN)) (RETURN (create TEK4010.STATE]) (TEK4010.NEXTSTATE [LAMBDA (STATE NEXTSTATE) (* jds " 5-Sep-85 11:38") (* This function replaces the state of the emulator which is either ALPHASTATE  or GRAPHICSSTATE in the STATE instance of the TEK4010.STATE datatype) (replace PREVSTATE of STATE with (fetch (TEK4010.STATE CURRENTSTATE) of STATE)) (replace (TEK4010.STATE CURRENTSTATE) of STATE with NEXTSTATE]) (TEK4010.RELMOVETO [LAMBDA (RELX RELY STREAM) (* jds " 5-Sep-85 11:23") (* Given RELX, RELY in TEK4010  units, move STREAM to the  corresponding relative location.) (RELMOVETO (TEK4010.SCALE RELX STREAM) (TEK4010.SCALE RELY STREAM) STREAM]) (TEK4010.SCALE [LAMBDA (COORD STREAM) (* jds " 5-Sep-85 11:20") (* Given an X or Y coordinate in TEK4010 units, scale it to fit inside STREAM's  clipping region. The TEK4010.SCALE STREAMPROP has to be set up by the  output-stream opener, usually TEK4010CHAT.INIT) (FIXR (FTIMES COORD (OR (STREAMPROP STREAM 'TEK4010.SCALE) 1.0]) (TEK4010.SENDCOORD [LAMBDA (STREAM COORD SENDINGY) (* jds " 5-Sep-85 11:36") (* Send X or Y crosshair coordinate  back to computer) (BOUT STREAM (IPLUS (LRSH (OR (NUMBERP COORD) 0) 5) 32)) (* Send the hi half of the  coordinate) (BOUT STREAM (IPLUS (LOGAND (OR (NUMBERP COORD) 0) 31) (COND (SENDINGY (* The low-Y coord gets bumped by 96) 96) (T (* The low-X coord gets bumped by 64) 64]) (TEK4010CHAT.BUTTONFN [LAMBDA (WINDOW) (* AJB "24-May-85 15:27") (COND ((LASTMOUSESTATE LEFT) (CHAT.HOLD WINDOW)) ((LASTMOUSESTATE MIDDLE) (TEK4010CHAT.MENUFN WINDOW]) (TEK4010.RESHAPEFN [LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* AJB " 5-Sep-85 15:51") (* * This reshape window function is necessary to rescale the TEK4010  coordinates to the new window size) (PROG* ((CHAT.STATE (WINDOWPROP WINDOW 'CHATSTATE)) (OUTSTREAM (fetch (CHAT.STATE DSP) of CHAT.STATE)) (XSCALE (FQUOTIENT (fetch WIDTH of (DSPCLIPPINGREGION NIL OUTSTREAM)) 1024)) (YSCALE (FQUOTIENT (fetch HEIGHT of (DSPCLIPPINGREGION NIL OUTSTREAM)) 768))) (STREAMPROP OUTSTREAM 'TEK4010.SCALE (MIN XSCALE YSCALE)) (* Set the scale on the output stream so that the entire screen image will fit  into the CHAT window) (WINDOWPROP WINDOW 'CROSSHAIRX NIL) (* Make sure crosshair function is  disabled) (WINDOWPROP WINDOW 'CROSSHAIRY NIL) (TEK4010.CLEAR CHAT.STATE WINDOW) (* Clear the window and reset  display stream coordinates) ]) (TEK4010CHAT.HANDLECHAR [LAMBDA (CH CHAT.STATE STATE) (* jds " 5-Sep-85 11:40") (* This function is called by CHAT to handle a single char from the input  stream ; stores the char in INBYTE, the high 2 bits in HI2BITS, and the lower 5  bits in LO5BITS in the instance of the TEK4010.STATE DATATYPE parameter called  STATE It then fetches the current state of the emulator  (GRAPHICSSTATE or ALPHASTATE) and executes the corresponding named function.  Currently the initialization is triggered from here, since CHAT has no  initialize hook for other emulators.) (replace (TEK4010.STATE INBYTE) of STATE with CH) (replace (TEK4010.STATE HI2BITS) of STATE with (LRSH (fetch (TEK4010.STATE INBYTE ) of STATE) 5)) (replace (TEK4010.STATE LO5BITS) of STATE with (LOGAND (fetch (TEK4010.STATE INBYTE) of STATE) 31)) (APPLY* (fetch (TEK4010.STATE CURRENTSTATE) of STATE) CHAT.STATE STATE]) (TEK4010CHAT.MENUFN [LAMBDA (WINDOW) (* AJB "24-May-85 15:33") (DECLARE (GLOBALVARS TEK4010CHAT.MENU) (SPECVARS WINDOW STATE)) (* Called by YELLOW) (PROG ((STATE (WINDOWPROP WINDOW 'CHATSTATE)) COMMAND) [COND ((NOT STATE) (* No Connection here;  try to reestablish) (RETURN (COND ((LASTMOUSESTATE MIDDLE) (CHAT.RECONNECT WINDOW)) (T (TOTOPW WINDOW] (replace (CHAT.STATE HELD) of STATE with T) (\CHECKCARET WINDOW) (SELECTQ [SETQ COMMAND (MENU (OR TEK4010CHAT.MENU (SETQ TEK4010CHAT.MENU (create MENU ITEMS _ TEK4010CHAT.MENUITEMS] (Close (replace (CHAT.STATE RUNNING?) of STATE with 'CLOSE) (* Ask CHAT.TYPEIN to shut things  down.) ) (New (replace (CHAT.STATE RUNNING?) of STATE with 'CLOSE) (WINDOWPROP WINDOW 'KEEPCHAT 'NEW)) (Suspend (replace (CHAT.STATE RUNNING?) of STATE with 'CLOSE) (WINDOWPROP WINDOW 'KEEPCHAT T)) (Freeze (* Leave in HELD state) (RETURN)) (NIL) (APPLY* COMMAND STATE WINDOW)) (replace (CHAT.STATE HELD) of STATE with NIL]) (TEK4010.GRAPHICSSTATE [LAMBDA (CHAT.STATE STATE) (* jds " 5-Sep-85 11:41") (* This function collects up to 4 bytes of XY position, ie, HIX, HIY, LOY, LOX  and does a MOVETO or DRAWTO when the last byte is received which is always LOX.  The previous values of HIX, HIY, & LOY may be used to move or draw, Only a new  LOX is required to evoke the operation.) (* The high 2 bits of the byte are used to indicate which byte is being  received, however if it is zero, then it is a control char and handled by the  CTRLCHAR routine. The other bytes are determined as follows%: 1 => HIY or HIX;  2 => LOX; 3 => LOY Notice there are 2 possibilities for the high 2 bits=1.  The proper byte is determined by which byte was collected the last time.  So to keep track of this a field called BYTESTATE is maintained in the STATE  record to remember the previous byte) (* When the state goes from ALPHAMODE to GRAPHICSMODE, the first set of bytes  are used to do a MOVETO, and subsequent sets of bytes are used to do DRAWTOs.  The only way to do a subsequent MOVETO is reenter GRAPHICSMODE using a control  character such as 29 which enters GRAPHICSMODE.  This is the way that positioning text must be done) (LET ((HI2BITS (fetch (TEK4010.STATE HI2BITS) of STATE)) (LO5BITS (fetch (TEK4010.STATE LO5BITS) of STATE)) (BYTESTATE (fetch BYTESTATE of STATE)) (INSTREAM (fetch (CHAT.STATE INSTREAM) of CHAT.STATE)) (OUTSTREAM (fetch (CHAT.STATE DSP) of CHAT.STATE))) (SELECTQ HI2BITS (0 (TEK4010.CTRLCHAR CHAT.STATE STATE)) (1 [COND ((EQUAL BYTESTATE 'LOY) (replace (TEK4010.STATE HIX) of STATE with LO5BITS) (replace BYTESTATE of STATE with 'HIX)) (T (replace (TEK4010.STATE HIY) of STATE with LO5BITS) (replace BYTESTATE of STATE with 'HIY]) (2 (replace (TEK4010.STATE LOX) of STATE with LO5BITS) (replace BYTESTATE of STATE with 'LOX) (COND ((fetch (TEK4010.STATE DRAWP) of STATE) (TEK4010.DRAWTO (TEK4010.GLOMHI&LO (fetch (TEK4010.STATE HIX) of STATE) (fetch (TEK4010.STATE LOX) of STATE)) (TEK4010.GLOMHI&LO (fetch (TEK4010.STATE HIY) of STATE) (fetch (TEK4010.STATE LOY) of STATE)) 1 NIL OUTSTREAM)) (T (TEK4010.MOVETO (TEK4010.GLOMHI&LO (fetch (TEK4010.STATE HIX) of STATE) (fetch (TEK4010.STATE LOX) of STATE)) (TEK4010.GLOMHI&LO (fetch (TEK4010.STATE HIY) of STATE) (fetch (TEK4010.STATE LOY) of STATE)) OUTSTREAM) (replace (TEK4010.STATE DRAWP) of STATE with T)))) (3 (replace (TEK4010.STATE LOY) of STATE with LO5BITS) (replace BYTESTATE of STATE with 'LOY)) (SHOULDNT]) (TEK4010.CTRLCHAR [LAMBDA (CHAT.STATE STATE) (* AJB " 5-Sep-85 15:13") (* This function performs various control char functions such as CR, LF, enter  GRAPHICSSTATE or ALPHASTATE, ring the bell, clear the screen, etc.) (LET* ((INSTREAM (fetch (CHAT.STATE INSTREAM) of CHAT.STATE)) (OUTSTREAM (fetch (CHAT.STATE DSP) of CHAT.STATE)) (LO5BITS (fetch (TEK4010.STATE LO5BITS) of STATE)) (HI2BITS (fetch (TEK4010.STATE HI2BITS) of STATE)) (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) OUTSTREAM)) (SPACEHEIGHT 22)) (SELCHARQ LO5BITS (^D (TEK4010.NEXTSTATE STATE (FUNCTION TEK4010.ALPHASTATE))) (^G (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL) (RINGBELLS 1)) (BS (RELMOVETO (IMINUS SPACEWIDTH) 0 OUTSTREAM) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL)) (TAB (RELMOVETO SPACEWIDTH 0 OUTSTREAM) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL)) (LF (RELMOVETO 0 (IMINUS SPACEHEIGHT) OUTSTREAM) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL) (add (fetch (TEK4010.STATE ROW) of STATE) 1) [COND ((GREATERP (fetch (TEK4010.STATE ROW) of STATE) (TEK4010.SCALE 35 OUTSTREAM)) (replace (TEK4010.STATE ROW) of STATE with 1) (* at bottom of screen, clear screen  and pos to top -  no scrolling) (* Determine whether to goto margin  1 (top/middle of screen) or margin 0  (top/left) of screen) (COND ((NEQ (fetch (TEK4010.STATE MARGIN) of STATE) 0) (replace (TEK4010.STATE MARGIN) of STATE with 0) (DSPLEFTMARGIN 0 OUTSTREAM) (MOVETO 0 (IDIFFERENCE (WINDOWPROP (WFROMDS OUTSTREAM) 'HEIGHT) (FONTPROP OUTSTREAM 'HEIGHT)) OUTSTREAM)) (T (replace (TEK4010.STATE MARGIN) of STATE with (  TEK4010.SCALE 512 OUTSTREAM )) (DSPXPOSITION (TEK4010.SCALE 512 OUTSTREAM) OUTSTREAM) (DSPLEFTMARGIN (TEK4010.SCALE 512 OUTSTREAM) OUTSTREAM) (DSPYPOSITION (WINDOWPROP (WFROMDS OUTSTREAM) 'HEIGHT) OUTSTREAM]) (^K (TEK4010.RELMOVETO 0 SPACEHEIGHT OUTSTREAM) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL)) (ESC (TEK4010.ESCAPECHAR CHAT.STATE STATE)) (^ (* 29) (replace (TEK4010.STATE DRAWP) of STATE with NIL) (replace BYTESTATE of STATE with NIL) (TEK4010.NEXTSTATE STATE (FUNCTION TEK4010.GRAPHICSSTATE))) (CR (MOVETO (fetch (TEK4010.STATE MARGIN) of STATE) (DSPYPOSITION NIL OUTSTREAM) OUTSTREAM) (TEK4010.NEXTSTATE STATE (FUNCTION TEK4010.ALPHASTATE))) (^_ (* 31) (TEK4010.NEXTSTATE STATE (FUNCTION TEK4010.ALPHASTATE))) NIL]) (TEK4010.ESCAPECHAR [LAMBDA (CHAT.STATE STATE) (* jds " 5-Sep-85 11:36") (* Handles ESCAPE sequences.) (LET* ((INSTREAM (fetch (CHAT.STATE INSTREAM) of CHAT.STATE)) (OUTSTREAM (fetch (CHAT.STATE DSP) of CHAT.STATE)) (CHAR (LOGAND (BIN INSTREAM) 127)) (WINDOW (WFROMDS OUTSTREAM)) (SSTREAM (fetch (CHAT.STATE OUTSTREAM) of CHAT.STATE)) (WIDTH (WINDOWPROP WINDOW 'WIDTH)) (HEIGHT (WINDOWPROP WINDOW 'HEIGHT)) PREVPROC PREVDS CROSSHAIRX CROSSHAIRY) (COND ((EQ CHAR (CHARCODE FF)) (* ESC FF clears screen and resets  cursor to top, and switches to  (if not already in) alphamode) (DSPRESET OUTSTREAM) (TEK4010.NEXTSTATE STATE (FUNCTION TEK4010.ALPHASTATE))) ((EQ CHAR (CHARCODE ^Z)) (* Go into Graphic Input Mode. Display crosshairs while tracking mouse, until  1st keyboard character is entered. Then send character plus location of  crosshair back to computer) (TEK4010.CROSSHAIR WINDOW) (* DISPLAY CROSSHAIR) (RESETLST (RESETSAVE (WINDOWPROP WINDOW 'CURSORMOVEDFN (FUNCTION TEK4010.CROSSHAIR)) (LIST (FUNCTION WINDOWPROP) WINDOW 'CURSORMOVEDFN NIL)) (* Setup TEK4010.CROSSHAIR routine to track mouse, and setup TTYPROCESS to come  to this process instead of the chat.input process.  RESETRESTORE will put everything back when character is struck from keyboard) (SETQ PREVPROC (WINDOWPROP WINDOW 'PROCESS)) (RESETSAVE (WINDOWPROP WINDOW 'PROCESS (THIS.PROCESS)) (LIST (FUNCTION WINDOWPROP) WINDOW 'PROCESS PREVPROC)) (RESETSAVE [COND ((TTY.PROCESSP PREVPROC) (TTY.PROCESS (THIS.PROCESS] (LIST (FUNCTION TTY.PROCESS) PREVPROC)) (SETQ PREVDS (TTYDISPLAYSTREAM)) (RESETSAVE (TTYDISPLAYSTREAM OUTSTREAM) (LIST (FUNCTION TTYDISPLAYSTREAM) PREVDS)) (PAGEHEIGHT 0) (* Prevent full page prompt hold up) (DSPSCROLL 'OFF OUTSTREAM) (* Turn off scrolling which  TTYDISPLAYSTREAM fn turns on) (SETQ CHAR (\GETKEY))) (* Wait for keyboard input) (SETQ CROSSHAIRX (WINDOWPROP WINDOW 'CROSSHAIRX)) (SETQ CROSSHAIRY (WINDOWPROP WINDOW 'CROSSHAIRY)) (BLTHLINE CROSSHAIRY 0 WIDTH WINDOW GRAYSHADE) (* Erase Crosshair) (BLTVLINE CROSSHAIRX 0 HEIGHT WINDOW GRAYSHADE) (BOUT SSTREAM CHAR) (* Send keyboard char first) (TEK4010.SENDCOORD SSTREAM (TEK4010.UNSCALE CROSSHAIRX OUTSTREAM)) (* send X coord) (TEK4010.SENDCOORD SSTREAM (TEK4010.UNSCALE CROSSHAIRY OUTSTREAM) T) (* Send Y coord) (BOUT SSTREAM (CHARCODE CR)) (WINDOWPROP WINDOW 'CROSSHAIRX NIL) (WINDOWPROP WINDOW 'CROSSHAIRY NIL]) (TEK4010.UNSCALE [LAMBDA (COORD STREAM) (* jds " 5-Sep-85 11:34") (* Given an X or Y coordinate in STREAM's units, scale it to TEK4010 units The  TEK4010.UNSCALE STREAMPROP has to be set up by the output-stream opener,  usually TEK4010CHAT.INIT) (FIXR (FQUOTIENT COORD (OR (STREAMPROP STREAM 'TEK4010.UNSCALE) 1.0]) (TEK4010.GLOMHI&LO [LAMBDA (HIBYTE LOBYTE) (* hdj "10-Sep-84 14:32") (IPLUS LOBYTE (LLSH HIBYTE 5]) (TEK4010.MOVETO [LAMBDA (X Y STREAM) (* jds " 5-Sep-85 11:21") (* Given an X,Y coordinate pair in TEK4010 units, move the output stream's  location to the equivalent stream point.) (MOVETO (TEK4010.SCALE X STREAM) (TEK4010.SCALE Y STREAM) STREAM]) (TEK4010.DRAWTO [LAMBDA (X Y WIDTH OPERATION STREAM) (* jds " 5-Sep-85 11:20") (* DRAWTO on the TEK4010 emulator display stream STREAM.  Scale the coordinates by the stream's TEK4010.SCALE, if any.) (DRAWTO (TEK4010.SCALE X STREAM) (TEK4010.SCALE Y STREAM) WIDTH OPERATION STREAM]) ) (RPAQ? TEK4010CHAT.MENU NIL) (RPAQQ TEK4010CHAT.MENUITEMS ((Close 'Close "Closes the connection and returns") (Suspend 'Suspend "Closes the connection but leaves window up") (New 'New "Closes this connection and prompts for a new host") (Freeze 'Freeze "Holds typeout in this window until you bug it again") ("Input" (FUNCTION CHAT.TAKE.INPUT) "Allows input from a file") ("Dribble" (FUNCTION CHAT.TYPESCRIPT) "Starts a typescript of window typeout") (Clear (FUNCTION TEK4010.CLEAR) "Clears window and resets to ALPHAMODE column 1, row 1"))) (ADDTOVAR CHAT.DRIVERTYPES (TEK4010 TEK4010CHAT.HANDLECHAR TEK4010CHAT.INIT)) (PUTPROPS TEK4010CHAT COPYRIGHT ("Xerox Corporation" 1985 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2284 31820 (TEK4010.ALPHASTATE 2294 . 3069) (TEK4010.CLEAR 3071 . 4287) ( TEK4010.CLOSEFN 4289 . 5305) (TEK4010.CROSSHAIR 5307 . 7666) (TEK4010CHAT.INIT 7668 . 10488) ( TEK4010.NEXTSTATE 10490 . 11052) (TEK4010.RELMOVETO 11054 . 11561) (TEK4010.SCALE 11563 . 12006) ( TEK4010.SENDCOORD 12008 . 13027) (TEK4010CHAT.BUTTONFN 13029 . 13286) (TEK4010.RESHAPEFN 13288 . 14525 ) (TEK4010CHAT.HANDLECHAR 14527 . 16085) (TEK4010CHAT.MENUFN 16087 . 17938) (TEK4010.GRAPHICSSTATE 17940 . 21631) (TEK4010.CTRLCHAR 21633 . 26584) (TEK4010.ESCAPECHAR 26586 . 30502) (TEK4010.UNSCALE 30504 . 30937) (TEK4010.GLOMHI&LO 30939 . 31087) (TEK4010.MOVETO 31089 . 31444) (TEK4010.DRAWTO 31446 . 31818))))) STOP \ No newline at end of file diff --git a/lispusers/TEXTMODULES b/lispusers/TEXTMODULES new file mode 100644 index 00000000..e5c41e1b --- /dev/null +++ b/lispusers/TEXTMODULES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE (DEFPACKAGE "TEXTMODULES" (USE "LISP" "XCL") (PREFIX-NAME "TM"))) (FILESLOAD EVAL-WHEN-PATCH) *PACKAGE*) BASE 10) (il:filecreated "24-Sep-87 18:50:13" il:{dsk}work>textmodules.\;14 28587 il:|changes| il:|to:| (il:functions read-hash-bar-comment read-prefix-quote translate-hash-comma translate-hash-dot read-read-time-conditional translate-read-time-conditional print-read-time-conditional make-lisp-file-readtable make-lisp-conditional-readtable read-disabled-hash untranslatable-presentation print-disabled-hash defpresentation translate-prefix-quote translate-form print-prefix-quote) (il:vars il:textmodulescoms) (il:structures read-time-conditional) (il:variables specifier-types *delete-form* comment-level-markers) (il:presentations disabled-hash hash-r hash-minus hash-plus hash-comma hash-dot) il:|previous| il:|date:| "11-Sep-87 16:38:00" il:{dsk}work>textmodules.\;1) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:textmodulescoms) (il:rpaqq il:textmodulescoms ((il:* il:|;;;| "TEXTMODULES, a text file to file manager conversion utility.") (il:* il:|;;| "Semicolon comments are special cased in this code, because rewriting the SEdit support for that presentation would be hard.") (il:functions add-form after-print-functions after-read-functions before-make-textmodule-functions defpresentation form-specifier-type install-form install-read-macro load-textmodule make-lisp-file-readtable make-textmodule name-of parse-environment-setup-specifiers print-and-eval print-comment-line print-environment-forms print-form print-prefix-quote print-read-time-conditional print-semicolon-comment read-hash-bar-comment read-prefix-quote read-read-time-conditional read-semicolon-comment remove-presentation semicolon-comment-p specifier-of specifier-type top-level-form-form top-level-form-p translate-form translate-hash-comma translate-hash-dot translate-prefix-quote translate-read-time-conditional) (il:structures presentation prefix-quote presentation-ops read-time-conditional semicolon-comment specifier-type unknown-form unknown-specifier) (il:variables *delete-form* comment-level-markers eof-marker specifier-types) (il:p (make-lisp-file-readtable)) (il:define-types il:presentations) (il:presentations hash-b hash-comma hash-dot hash-minus hash-o hash-plus hash-x) (il:advise remove-comments (il:eval :in il:\\do-define-file-info)) (il:prop (il:filetype il:makefile-environment) il:textmodules)) ) (il:* il:|;;;| "TEXTMODULES, a text file to file manager conversion utility.") (il:* il:|;;| "Semicolon comments are special cased in this code, because rewriting the SEdit support for that presentation would be hard." ) (defun add-form (form contents &optional (type (form-specifier-type form))) "Call appropriate functions to make definition editable, return new contents." (funcall (specifier-type-add type) form contents)) (defun after-print-functions (form) (if (eq (quote in-package) (first form)) (eval form)) form) (defun after-read-functions (form) "Performs any processing on the form needed after it has been read." (il:* il:|;;| "Eventually this will be used to smash together adjacent same level comments.") form) (defun before-make-textmodule-functions (module stream) "Things to do before the main body of the textmodule is printed." (print-comment-line (get module (quote il:makefile-environment)) stream) (print-environment-forms (get module (quote il:makefile-environment)) stream) (terpri stream)) (defdefiner defpresentation il:presentations (name &key fields include print-function (read-macro nil) (translator (function untranslatable-presentation))) "Define a presentation type." (il:bquote (progn (defstruct ((il:\\\, name) (:include (il:\\\,@ (if (null include) (list (quote presentation)) (etypecase include (symbol (list include)) (list include)))) (ops (make-presentation-ops :read-macro (quote (il:\\\, read-macro)) :translator (quote (il:\\\, translator))))) (:print-function (il:\\\, print-function))) (il:\\\,@ fields)) (il:\\\,@ (unless (null read-macro) (list (il:bquote (install-read-macro (quote (il:\\\, read-macro)) (il:find-readtable "LISP-FILE")))))) (quote (il:\\\, name))))) (defun form-specifier-type (form) "If the form has a specifier return the specifier's defining structure." (or (some (function (lambda (type) (and (funcall (specifier-type-identifier type) form) type))) specifier-types) (il:nill (warn (quote unknown-form) :form form)))) (defun install-form (form &optional (type (form-specifier-type form))) "Install a definition as current and executable." (when (not (member il:dfnflg (quote (il:prop il:allprop)))) (funcall (specifier-type-installer type) form))) (defun install-read-macro (read-macro table) (cond ((and (characterp (first read-macro)) (characterp (second read-macro))) (make-dispatch-macro-character (first read-macro) t table) (set-dispatch-macro-character (first read-macro) (second read-macro) (third read-macro) table)) ((characterp (first read-macro)) (set-macro-character (first read-macro) (second read-macro) t table)) (t (error "Bad read macro spec ~s" read-macro)))) (defun load-textmodule (pathname &key (module (pathname-name pathname)) (il:* il:\; "Name of module which has these contents.") (install t) (il:* il:\; "Install definitions as current?") (package (find-package "USER")) (il:* il:\; "Package to read file in.")) "Load a text file, creating a content description." (setq pathname (merge-pathnames pathname ".LISP")) (let ((il:dfnflg (if (null install) (quote il:prop) install)) (*package* (if (packagep package) package (find-package package))) (*readtable* (il:find-readtable "LISP-FILE")) (contents nil)) (with-open-file (stream pathname :direction :input) (let (form) (loop (setq form (read stream nil eof-marker)) (when (eq form eof-marker) (return nil)) (setq form (after-read-functions form)) (let ((type (form-specifier-type form))) (setq contents (add-form form contents type)) (install-form form type))))) (multiple-value-bind (contents environment) (parse-environment-setup-specifiers contents) (let* ((name (intern module "INTERLISP")) (filevar (il:filecoms name))) (setf (symbol-value filevar) contents) (il:addfile name) (setf (get name (quote il:filetype)) :compile-file) (il:addtofile (il:bquote ((il:\\\, name) il:filetype)) (quote il:props) name) (setf (get name (quote il:makefile-environment)) environment) (il:addtofile (il:bquote ((il:\\\, name) il:makefile-environment)) (quote il:props) name)))) module) (defun make-lisp-file-readtable nil "Build and name the LISP-FILE readtable." (let ((table (or (il:find-readtable "LISP-FILE") (copy-readtable (il:find-readtable "LISP"))))) (install-read-macro (quote (#\; read-semicolon-comment)) table) (install-read-macro (quote (#\# #\| read-hash-bar-comment)) table) (il:readtableprop table (quote il:name) "LISP-FILE") table)) (defun make-textmodule (module &key (type ".LISP") (pathname (merge-pathnames module (merge-pathnames type))) (contents (symbol-value (il:filecoms module))) (width 80)) "Writes out the contents of the named module." (setq module (find-symbol (symbol-name module) "INTERLISP")) (let ((*package* (find-package "USER")) (*readtable* (il:find-readtable "LISP-FILE")) (il:*print-semicolon-comments* t) (*print-pretty* t)) (declare (special il:*print-semicolon-comments*)) (with-open-file (stream pathname :direction :output) (il:linelength width stream) (il:* il:\; "For Interlisp prettyprinter.") (before-make-textmodule-functions module stream) (dolist (specifier contents) (let ((type (specifier-type specifier))) (when type (write (after-print-functions (print-form specifier type)) :stream stream)))) module))) (defun name-of (form) (funcall (get (car form) (quote il:definition-name)) (remove-comments form))) (defun parse-environment-setup-specifiers (contents) "Parse out any environment specifiers, returning the reduced contents list and an environment object." (il:* il:|;;| "If you change anything in here you must change the printer in print-environment-forms.") (when (and (semicolon-comment-p (first contents)) (eql 0 (search "-*-" (semicolon-comment-string (first contents))))) (il:* il:\; "Discard EMACS comment line") (pop contents)) (let ((package-form nil) (il:* il:\; "Collects the package setup forms.") (base 10) (il:* il:\; "Default.")) (il:* il:|;;| "Most of the mechanism below handles comments between the setup forms in the filecoms. CONTENTS names the last parsed position. NEXT-TOP-LEVEL-FORM slides NEXT-TAIL past the comments to the next top-level form. WHEN-RECOGNIZED checks the form and if recognized pops the in-between comments onto PACKAGE-FORM.") (let ((next-tail contents) (il:* il:\; "Contains tail at next top-level form.") form (il:* il:\; "Contains next top level form.")) (block parse-complete (flet ((next-top-level-form nil (il:* il:|;;| "Find tail containing the next top level form.") (loop (when (null next-tail) (return nil)) (let ((head (first next-tail))) (cond ((top-level-form-p head) (setq form (top-level-form-form head)) (return nil)) ((not (semicolon-comment-p head) (return-from parse-complete nil))))) (pop next-tail))) (pop-forms nil (il:* il:|;;| "Comments between CONTENTS and (not including) NEXT-TAIL are popped onto PACKAGE-FORMs. The form in NEXT-TAIL is discarded and CONTENTS is updated.") (loop (when (eq contents next-tail) (return nil)) (push (pop contents) package-form)))) (macrolet ((when-recognized (test &body forms) (il:* il:|;;| "Find the next top level form. Use TEST to recognize whether its an environment setup form. Then execute the body and discard the processed form.") (il:bquote (progn (next-top-level-form) (when (il:\\\, test) (pop-forms) (il:\\\,@ forms) (pop next-tail) (setq contents next-tail)))))) (il:* il:|;;| "package setup forms") (when-recognized (eq (first form) (quote provide)) (push form package-form)) (when-recognized (eq (first form) (quote in-package)) (push form package-form)) (when-recognized (eq (first form) (quote shadow)) (push form package-form)) (when-recognized (eq (first form) (quote export)) (push form package-form)) (when-recognized (member (first form) (quote (require il:filesload)) :test (function eq)) (push form package-form)) (when-recognized (eq (first form) (quote use-package)) (push form package-form)) (when-recognized (eq (first form) (quote import)) (push form package-form)) (when-recognized (eq (first form) (quote shadowing-import)) (push form package-form)) (il:* il:|;;| "read-base") (when-recognized (and (eq (first form) (quote setf)) (eq (second form) (quote *read-base*))) (setq base (third form))))))) (il:* il:|;;| "Return the new contents and a environment.") (values contents (il:bquote (:readtable "XCL" :package (il:\\\, (if package-form (il:bquote (let ((*package* *package*)) (il:\\\,@ (reverse package-form)) *package*)) "USER")) :base (il:\\\, base)))))) (defmacro print-and-eval (form stream) (il:bquote (let ((form (il:\\\, form))) (write form :stream (il:\\\, stream)) (terpri (il:\\\, stream)) (eval form)))) (defun print-comment-line (environment stream) "Prints a mode line onto the STREAM based on the ENVIRONMENT." (format stream ";;; -*- Mode: LISP") (do ((tail environment (cddr tail))) ((null tail)) (let ((name (first tail)) (value (second tail))) (case name (:readtable) (:package (cond ((stringp value) (format stream "; Package: ~a" value)) ((eq (first value) (quote defpackage)) (format stream "; Package: (~a (~{~a~}) 1000)" (string (second value)) (or (mapcar (function string) (cdr (assoc :use (cddr value)))) (list "LISP")))) ((eq (first value) (quote let)) (let ((form (assoc (quote in-package) (cddr value)))) (format stream "; Package: (~a (~{~a~}) 1000)" (string (second form)) (or (mapcar (function string) (cdr (getf form :use nil))) (list "LISP"))))) (t (error "Unknown package specifier in environment ~s" value)))) (:base (format stream "; Base: ~a" value))))) (format stream " -*-") (terpri stream)) (defun print-environment-forms (environment stream) "Print the environment initializing forms from ENVIRONMENT onto STREAM." (do ((tail environment (cddr tail))) ((null tail)) (let ((name (first tail)) (value (second tail))) (ecase name (:readtable) (:package (typecase value (null (error "NIL given as package name")) ((or symbol string) (print-and-eval (il:bquote (in-package (il:\\\, value))) stream)) (cons (case (first value) (defpackage (il:* il:\; "We only cover the portable options to defpackage. Note that they're converted once but not back.") (print-and-eval (il:bquote (in-package (il:\\\, (string (second value))) (il:\\\,@ (let ((nicknames (cdr (assoc :nicknames (cddr value))))) (when nicknames (il:bquote (:nicknames (il:\\\, nicknames)))))))) stream) (mapc (function (lambda (option function) (let ((value (cdr (assoc :use (cddr value))))) (when value (print-and-eval (il:bquote ((il:\\\, function) (quote (il:\\\, value)))) stream))))) (quote (:shadow :export :use :import :shadowing-import)) (quote (shadow export use-package import shadowing-import)))) (let (il:* il:\; "A fancy LET environment!") (mapcar (function (lambda (form) (print-and-eval form stream))) (butlast (cddr value)) (il:* il:\; "Avoid the LET, its bindings and the returned *package*."))))) (t (error "Unknown package specifier in environment ~s" value)))) (:base (print-and-eval (il:bquote (setf *read-base* (il:\\\, value))) stream)))))) (defun print-form (specifier &optional (type (specifier-type specifier))) "Get the print form of a specifier." (funcall (specifier-type-print-form type) specifier)) (defun print-prefix-quote (object stream depth) (if (eq *print-case* :downcase) (princ (prefix-quote-prefix object) stream) (princ (string-upcase (prefix-quote-prefix object)) stream)) (princ (prefix-quote-contents object) stream)) (defun print-read-time-conditional (object stream depth) (princ #\# stream) (etypecase object (hash-plus (princ #\+ stream)) (hash-minus (princ #\- stream))) (let ((*package* il:*keyword-package*)) (prin1 (read-time-conditional-feature object) stream)) (if (read-time-conditional-unread-p object) (princ (read-time-conditional-form object) stream) (prin1 (read-time-conditional-form object) stream))) (defun print-semicolon-comment (form stream) "Print a semicolon comment. Depends on IL:*PRINT-SEMICOLON-COMMENTS* being true." (write form :stream stream)) (defun read-hash-bar-comment (stream sub-char integer) "Read the characters of a hash bar comment, creating a comment object." (when integer (warn "Spurious integer argument to hash macro ignored.")) (let ((comment-buffer (make-array 1024 :element-type (quote character) :fill-pointer 0 :adjustable t))) (loop (setq sub-char (read-char stream nil eof-marker)) (when (eq sub-char eof-marker) (return (make-semicolon-comment :marker (quote il:\|) :string comment-buffer))) (when (eql sub-char #\|) (setq sub-char (read-char stream nil eof-marker)) (when (eql sub-char #\#) (return (make-semicolon-comment :marker (quote il:\|) :string comment-buffer))) (vector-push-extend #\| comment-buffer)) (vector-push-extend sub-char comment-buffer)))) (defun read-prefix-quote (stream sub-char integer) "Reads hash quoted forms." (when integer (warn "Spurious integer argument to hash macro ignored.")) (funcall (ecase sub-char (#\. (function make-hash-dot)) (#\, (function make-hash-comma)) ((#\O #\o) (function make-hash-o)) ((#\X #\x) (function make-hash-x)) ((#\B #\b) (function make-hash-b))) :contents (let ((*read-base* (ecase sub-char ((#\. #\,) *read-base*) ((#\B #\b) 2) ((#\O #\o) 8) ((#\X #\x) 16)))) (read stream nil t)))) (defun read-read-time-conditional (stream sub-char integer) (when integer (warn "Spurious integer argument to hash macro ignored.")) (let* ((feature (let ((*package* il:*keyword-package*)) (read stream))) (unread-p (ecase sub-char (#\- (il:cmlread.feature.parser feature)) (#\+ (not (il:cmlread.feature.parser feature))))) (form (cond (unread-p (let ((start (file-position stream))) (let ((*read-suppress* t)) (read stream)) (let ((length (- (file-position stream) start))) (file-position stream start) (let ((buffer (make-string length))) (dotimes (i length buffer) (setf (svref buffer i) (read-char stream))))))) (t (read stream))))) (funcall (case sub-char (#\+ (function make-hash-plus)) (#\- (function make-hash-minus))) :feature feature :unread-p unread-p :form form))) (defun read-semicolon-comment (stream disp-char &aux char (il:* il:\; "Current character.") (level 0) (il:* il:\; "Comment level.") (starting t) (il:* il:\; "In semicolons?") (comment-buffer (make-array 128 :element-type (quote character) :fill-pointer 0 :adjustable t))) "Reads the characters of a comment, building a Xerox Lisp style comment." (il:* il:|;;| "Adjacent comments of the same level are smashed together during an after-read pass over the structure.") (loop (setq char (read-char stream nil eof-marker)) (when (or (eql char eof-marker) (eql char #\Newline)) (return (make-semicolon-comment :marker (elt comment-level-markers (min level (1- (length comment-level-markers)))) :string comment-buffer))) (if starting (setq starting (if (eql char #\;) (incf level) nil)) (vector-push-extend char comment-buffer)))) (defun remove-presentation (sequence index) "Translates a presentation by removing it." (cond ((eql index 0) (subseq sequence 1)) ((eql index (1- (length sequence))) (subseq sequence 0 index)) (t (concatenate (if (listp sequence) (quote list) (type-of sequence)) (subseq sequence 0 index) (subseq sequence (1+ index)))))) (defun semicolon-comment-p (form) "Is FORM a semicolon comment?" (il:* il:|;;| "All info about the structure of semicolon comments is encapsulated in this function and the semicolon-comment structure.") (and (consp form) (eq (first form) (quote il:*)) (member (second form) comment-level-markers :test (function eq)) (stringp (third form)) (null (nthcdr 3 form)))) (defun specifier-of (form) "Examines a form and returns its specifier (file command)." (get (car form) (quote il:definer-for))) (defun specifier-type (specifier) "If the form has a specifier type return its defining structure." (or (some (function (lambda (type) (and (funcall (specifier-type-specifierp type) specifier) type))) specifier-types) (il:nill (warn (quote unknown-specifier) :specifier specifier)))) (defmacro top-level-form-form (place) "Return the form in the top-level form specifier." (il:bquote (second (second (il:\\\, place))))) (defun top-level-form-p (specifier) (eq (quote il:p) (first specifier))) (defun translate-form (sequence) "Create an evaluable form from one with presentations in it." (cond ((listp sequence) (setq sequence (copy-list sequence)) (il:* il:\; "An optimization for lists, since it would be terrible to ELT into them at each position.") (do ((tail sequence) (last nil)) ((not (consp tail)) sequence) (let ((head (first tail))) (cond ((semicolon-comment-p head) (il:* il:\; "Special case for old style comments.") (if (null last) (setq sequence (cdr tail)) (rplacd last (cdr tail))) (il:* il:\; "Last stays the same in either case.") (pop tail)) ((presentation-p head) (let* ((installer (presentation-ops-translator (presentation-ops head))) (result (if (eq installer :delete) *delete-form* (funcall installer head)))) (cond ((eq result *delete-form*) (if (null last) (setq sequence (cdr tail)) (rplacd last (cdr tail))) (il:* il:\; "Last stays the same in either case.") (pop tail)) (t (rplaca tail result) (setq last tail) (pop tail))))) ((typep head (quote sequence)) (rplaca tail (translate-form head)) (setq last tail) (pop tail)) (t (setq last tail) (pop tail)))))) ((and (not (stringp sequence)) (typep sequence (quote sequence))) (il:* il:\; "Optimization: avoid strings.") (setq sequence (copy-seq sequence)) (il:* il:\; "The general case of a sequence.") (do ((index 0) (length (length sequence))) ((eql index length) sequence) (let ((head (elt sequence index))) (cond ((presentation-p head) (let* ((installer (presentation-ops-translator (presentation-ops head))) (result (if (eq installer :delete) *delete-form* (funcall installer head)))) (cond ((eq result *delete-form*) (setq sequence (remove-presentation sequence index)) (decf length)) (t (setf (elt sequence index) result) (incf index))))) ((typep head (quote sequence)) (setf (elt sequence index) (translate-form head)) (incf index)) (t (incf index)))))) ((presentation-p sequence) (let* ((installer (presentation-ops-translator (presentation-ops sequence))) (result (if (eq installer :delete) *delete-form* (funcall installer sequence)))) (if (eq result *delete-form*) nil result))) (t sequence))) (defun translate-hash-comma (object) (cond (*read-suppress* nil) (compiler::*compiler-is-reading* (compiler::make-eval-when-load :form (prefix-quote-contents object))) ((il:fetch (readtablep il:commonlisp) il:of *readtable*) (eval (prefix-quote-contents object))) (t (il:eval (prefix-quote-contents object))))) (defun translate-hash-dot (object) (cond (*read-suppress* nil) ((il:fetch (readtablep il:commonlisp) il:of *readtable*) (eval (prefix-quote-contents object))) (t (il:eval (prefix-quote-contents object))))) (defun translate-prefix-quote (object) (il:* il:\; "This only has to handle numeric base types.") (prefix-quote-contents object)) (defun translate-read-time-conditional (object) (if (etypecase object (hash-minus (not (il:cmlread.feature.parser (read-time-conditional-feature object)))) (hash-plus (il:cmlread.feature.parser (read-time-conditional-feature object)))) (if (read-time-conditional-unread-p object) (with-input-from-string (input-string (read-time-conditional-form object)) (let ((*readtable* (il:find-readtable "LISP"))) (read input-string nil t))) (read-time-conditional-form object)) *delete-form*)) (defstruct presentation ops) (defstruct (prefix-quote (:include presentation) (:print-function print-prefix-quote)) type prefix contents) (defstruct (presentation-ops (:type list)) read-macro (il:* il:\; "A list with one or two characters followed by a read macro function. Installed in the text file readtable to read this presentation.") translator (il:* il:\; "Either a function on PRESENTATION which translates it, or :DELETE which always removes it (eg, comments).")) (defstruct (read-time-conditional (:include presentation) (:print-function print-read-time-conditional)) feature unread-p form) (defstruct (semicolon-comment (:type list) (:predicate nil) (il:* il:\; "The real one is SEMICOLON-COMMENT-P")) (tag (quote il:*)) (marker (quote il:\;)) (string "")) (defstruct (specifier-type (:type list)) name (il:* il:\; "A string naming the specifier.") specifierp (il:* il:\; "Predicate on FORM (a content specifier) which recognizes the specifier in the contents description of a file.") identifier (il:* il:\; "Predicate on FORM (a form from the text file), answers true if this is the specifier for the definition in FORM.") add (il:* il:\; "Function of FORM and CONTENTS which adds a specifier for FORM to the file CONTENTS description.") installer (il:* il:\; "Function of a FORM which installs the definition of FORM (may remove presentations). Should not actually install the definition if il:dfnflg is il:prop or il:allprop.") print-form (il:* il:\; "Function of SPECIFIER which returns the form to be printed.")) (define-condition unknown-form warning :report-function (lambda (condition stream) (format stream "Can't find specifier (filecom) for ~s" (unknown-form-form condition))) form) (define-condition unknown-specifier warning :report-function (lambda (condition stream) (format stream "Unknown specifier (filecom) ~s" (unknown-specifier-specifier condition))) specifier) (defvar *delete-form* "") (defconstant comment-level-markers (quote (il:\; il:|;;| il:|;;;| il:|;;;;| il:\|)) "Comment markers for availible levels.") (defconstant eof-marker "eof" "Unique object passed through read at EOF.") (defparameter specifier-types (list (make-specifier-type :name "Comment" :specifierp (function semicolon-comment-p) :identifier (function semicolon-comment-p) :add (function (lambda (form contents) (append contents (list form)))) :installer (function identity) :print-form (function identity)) (make-specifier-type :name "eval-when top level form" :specifierp (function (lambda (form) (eq (first form) (quote il:eval-when)))) :identifier (function (lambda (form) (and (listp form) (eq (first form) (quote eval-when))))) :add (function (lambda (form contents) (append contents (list (il:bquote (il:eval-when (il:\\\, (second form)) (il:\\\,@ (let ((contents nil)) (mapc (function (lambda (form) (setq contents (add-form form contents)))) (cddr form)) contents)))))))) :installer (function (lambda (form) (when (member (quote eval) (second form)) (dolist (form (cddr form)) (install-form form))))) :print-form (function (lambda (specifier) (il:bquote (eval-when (il:\\\, (second specifier)) (il:\\\,@ (mapcar (function (lambda (specifier) (print-form specifier))) (cddr specifier)))))))) (make-specifier-type :name "Definer" :specifierp (function (lambda (specifier) (get (first specifier) (quote il:defined-by)))) :identifier (function (lambda (form) (and (listp form) (get (car form) (quote il:definer-for))))) :add (function (lambda (form contents) (let ((il:dfnflg (quote il:prop))) (eval form)) (append contents (list (il:bquote ((il:\\\, (specifier-of form)) (il:\\\, (name-of form)))))))) :installer (function (lambda (form) (let ((il:dfnflg t)) (eval form)))) :print-form (function (lambda (specifier) (il:getdef (second specifier) (first specifier))))) (make-specifier-type :name "Top-level read-time conditional" :specifierp (function (lambda (form) nil)) :identifier (function read-time-conditional-p) :add (function (lambda (form contents) (append contents (list (il:bquote (il:p (translate-form (il:\\\, form)))))))) :installer (function (lambda (form) (eval (translate-form form)))) :print-form (function (lambda (specifier) (second (second specifier))))) (make-specifier-type :name "Top level form" :specifierp (function top-level-form-p) :identifier (function true) :add (function (lambda (form contents) (append contents (list (il:bquote (il:p (translate-form (il:\\\, form)))))))) :installer (function (lambda (form) (eval (translate-form form)))) :print-form (function (lambda (specifier) (top-level-form-form specifier))))) "A list of all content specifier types for text files.") (make-lisp-file-readtable) (def-define-type il:presentations "presentation types") (defpresentation hash-b :include (prefix-quote (type :hash-b) (prefix "#b")) :print-function print-prefix-quote :read-macro (#\# #\b read-prefix-quote) :translator translate-prefix-quote) (defpresentation hash-comma :include (prefix-quote (type :hash-comma) (prefix "#,")) :print-function print-prefix-quote :read-macro (#\# #\, read-prefix-quote) :translator translate-hash-comma) (defpresentation hash-dot :include (prefix-quote (type :hash-dot) (prefix "#.")) :print-function print-prefix-quote :read-macro (#\# #\. read-prefix-quote) :translator translate-hash-dot) (defpresentation hash-minus :include read-time-conditional :print-function print-read-time-conditional :read-macro (#\# #\+ read-read-time-conditional) :translator translate-read-time-conditional) (defpresentation hash-o :include (prefix-quote (type :hash-o) (prefix "#o")) :print-function print-prefix-quote :read-macro (#\# #\o read-prefix-quote) :translator translate-prefix-quote) (defpresentation hash-plus :include read-time-conditional :print-function print-read-time-conditional :read-macro (#\# #\+ read-read-time-conditional) :translator translate-read-time-conditional) (defpresentation hash-x :include (prefix-quote (type :hash-x) (prefix "#x")) :print-function print-prefix-quote :read-macro (#\# #\x read-prefix-quote) :translator translate-prefix-quote) (reinstall-advice (quote remove-comments) :around (quote ((:last (translate-form il:x))))) (reinstall-advice (quote (il:eval :in il:\\do-define-file-info)) :before (quote ((:last (setq il:u (translate-form il:u)))))) (il:readvise remove-comments (il:eval :in il:\\do-define-file-info)) (il:putprops il:textmodules il:filetype :compile-file) (il:putprops il:textmodules il:makefile-environment (:readtable "XCL" :package (let ((*package* *package*)) (in-package (defpackage "TEXTMODULES" (:use "LISP" "XCL") (:prefix-name "TM"))) (il:filesload il:eval-when-patch) *package*) :base 10) ) (il:putprops il:textmodules il:copyright ("Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/THINFILES b/lispusers/THINFILES new file mode 100644 index 00000000..c1465750 --- /dev/null +++ b/lispusers/THINFILES @@ -0,0 +1,143 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED " 1-May-92 16:49:39" {DSK}lfg>parser>THINFILES.;5 8005 + + changes to%: (FNS FB.THINP) + + previous date%: "28-Sep-89 16:38:11" {DSK}lfg>parser>THINFILES.;2) + + +(* ; " +Copyright (c) 1987, 1988, 1989, 1992 by Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT THINFILESCOMS) + +(RPAQQ THINFILESCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + FILEBROWSER)) + (FNS FB.THINCOMMAND FB.THINP) + (APPENDVARS (FB.MENU.ITEMS (Thin FB.THINCOMMAND + "Delvers non-source files and removes all but the last source file of each day." + ]) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + FILEBROWSER) +) +(DEFINEQ + +(FB.THINCOMMAND + [LAMBDA (FBROWSER) (* ; "Edited 10-Oct-88 10:06 by jtm:") + (* ; "Edited 10-Oct-88 10:05 by jtm:") + (* bvm%: "13-Oct-85 16:52") + + (* * FB.THINCOMMAND interfaces between the user and the file browser. + It calls FB.THINP on each file to determine if the file should be deleted. + Any changes to the heuristic should be made to FB.THINP.) + + (LET (TBROWSER NDELETED FILES NOW ONEDAY SORT#) + + (* * collect the files into a list.) + + (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (fetch (FILEBROWSER TABLEBROWSER) + of FBROWSER)) + (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) + + (* * sort the files in descending order.) + + [SETQ FILES (SELECTQ (fetch (FILEBROWSER SORTBY) of FBROWSER) + (FB.NAMES.DECREASING.VERSION (* Just right) + FILES) + (FB.NAMES.INCREASING.VERSION (* Close, but no cigar) + (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) + (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION] + + (* * delete the files that satisfy FB.THINP.) + + (SETQ NOW (IDATE (DATE))) + (SETQ ONEDAY (IDIFFERENCE (IDATE "31-Aug-87 09:06:06") + (IDATE "30-Aug-87 09:06:06"))) + + (* * get the position of CREATIONDATE. (code borrowed from FB.SORTCOMMAND)) + + [SETQ SORT# (OR (CL:POSITION 'CREATIONDATE (fetch (FILEBROWSER INFODISPLAYED) + of FBROWSER) + :KEY + (FUNCTION CAR)) + (HELP "Couldn't find sort attribute" 'CREATIONDATE] + (SETQ NDELETED (for TAIL FILE DATA on FILES bind (%#DELETED _ 0) + THISNAME LASTNAME CREATIONDATE + TIMESTAMP LASTTIMESTAMP + do (SETQ FILE (CAR TAIL)) + (SETQ DATA (fetch TIDATA of FILE)) + (SETQ TIMESTAMP (AND (SETQ CREATIONDATE (CL:NTH SORT# + (fetch + (FBFILEDATA FILEINFO + ) + of DATA))) + (IDATE CREATIONDATE))) + (OR TIMESTAMP (FB.PROMPTWPRINT FBROWSER T "No creation date for " + THISNAME)) + (SETQ THISNAME (fetch (FBFILEDATA VERSIONLESSNAME) of DATA)) + (COND + [(STRING-EQUAL THISNAME LASTNAME) + (COND + ((OR (NULL LASTTIMESTAMP) + (NULL TIMESTAMP)) + (* no creation date was given.) + NIL) + ((ILESSP LASTTIMESTAMP TIMESTAMP) + (HELP THISNAME "is out of order.")) + ((FB.THINP + THISNAME + (IDIFFERENCE NOW TIMESTAMP) + (IDIFFERENCE LASTTIMESTAMP TIMESTAMP) + [OR (NULL (CDR TAIL)) + (NOT (STRING-EQUAL THISNAME (fetch (FBFILEDATA + VERSIONLESSNAME + ) + of + (fetch TIDATA + of (CADR TAIL] + ONEDAY) (* FB.THINP determines whether or + not the file should be deleted.) + (COND + ((FB.DELETE.FILE TBROWSER FILE) + (add %#DELETED 1] + (T (SETQ LASTNAME THISNAME))) + (SETQ LASTTIMESTAMP TIMESTAMP) finally (RETURN %#DELETED))) + (FB.UPDATE.COUNTERS FBROWSER 'DELETED) + (FB.PROMPTWPRINT FBROWSER T "Done, " NDELETED " files marked for deletion."]) + +(FB.THINP + [LAMBDA (FILENAME AGE DELTATIMESTAMP OLDESTVERSION? ONEDAY) + (* ; "Edited 1-May-92 16:49 by rmk:") + (LET [(EXT (U-CASE (FILENAMEFIELD FILENAME 'EXTENSION] + (COND + ((OR (FMEMB EXT '(SYSOUT DCOM DATABASE LCOM DFASL MCOM MFASL)) + (FMEMB EXT *COMPILED-EXTENSIONS*)) (* ; + "always delver files that can be reconstructed from the source.") + T) + (OLDESTVERSION? (* ; + "don't delete the oldest version of source files.") + NIL) + ((ILESSP AGE ONEDAY) (* ; + "don't delete anything written within 24 hours.") + NIL) + ((ILESSP (ITIMES DELTATIMESTAMP 3) + ONEDAY) (* ; + "delete anything that occurs on the same day as something else (except for the first day)") + T) + ((ILESSP DELTATIMESTAMP (IQUOTIENT AGE 30)) + + (* ;; "after one month, delete things that are within a day of each other, after two months, within two days, etc.") + + T]) +) + +(APPENDTOVAR FB.MENU.ITEMS (Thin FB.THINCOMMAND + "Delvers non-source files and removes all but the last source file of each day." + )) +(PUTPROPS THINFILES COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1992)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (925 7713 (FB.THINCOMMAND 935 . 6343) (FB.THINP 6345 . 7711))))) +STOP diff --git a/lispusers/TILED-SEDIT b/lispusers/TILED-SEDIT new file mode 100644 index 00000000..731a5dce --- /dev/null +++ b/lispusers/TILED-SEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "24-Oct-89 13:33:24" {ICE}LISPUSERS>MEDLEY>TILED-SEDIT.;5 8741 changes to%: (FNS POST.TILED.SEDIT.SAVE.WINDOW.REGION TILED.SEDIT.RESET POST.TILED.SEDIT.GET.WINDOW.REGION) (VARS TILED-SEDITCOMS) previous date%: "18-Jan-88 14:40:28" {ICE}LISPUSERS>MEDLEY>TILED-SEDIT.;1) (* " Copyright (c) 1987, 1988, 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT TILED-SEDITCOMS) (RPAQQ TILED-SEDITCOMS ((* ;;; "Provides a similar facility for SEdit as the LispUsers package TILEDEDIT provides for DEdit, i.e., instead of prompting the user for regions, generates successive regions in a circular fashion, eachtime throught the full window loop offsetting the next window by 12,-12. Users can select their preference through the TILING-ORDER argument to the function TILED.SEDIT.RESET, which must be either NIL (no tiling), T (default tiling order) or a list of the symbols TL (top-left) TR (top-right) BL (bottom-left) and BR (bottom-right)") (* ;; "User Interface") (FNS TILED.SEDIT.RESET) (* ;; "Support ") (PROP MAKEFILE-ENVIRONMENT TILED-SEDIT) (INITVARS (*TiledSEditMargin* 25) (*TiledSEditXShift* 15) (*TiledSEditYShift* 15) (*TiledSEditRegions* NIL)) (RECORDS TILED.SEDIT.REGION) (FNS POST.TILED.SEDIT.GET.WINDOW.REGION POST.TILED.SEDIT.SAVE.WINDOW.REGION TILED.SEDIT.NEW.REGION TILED.SEDIT.SWITCHFN) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (P (OR (HASDEF (QUOTE SEDIT::EDIT-CONTEXT) (QUOTE RECORDS)) (EVAL (SYSRECLOOK1 (QUOTE SEDIT::EDIT-CONTEXT))))) (LOCALVARS . T) (GLOBALVARS *TiledSEditXShift* *TiledSEditYShift* *TiledSEditRegions* *TiledSEditRegionWidth* *TiledSEditRegionHeight* *TiledSEditKeepWhenShrunk* *TiledSEditCorners* *TiledSEditNextCornerPtr* *TiledSEditNextTopLeftRegion* *TiledSEditNextBottomLeftRegion* *TiledSEditNextTopRightRegion* *TiledSEditNextBottomRightRegion*)) (DECLARE%: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY (P (TILED.SEDIT.RESET T))))) (* ;;; "Provides a similar facility for SEdit as the LispUsers package TILEDEDIT provides for DEdit, i.e., instead of prompting the user for regions, generates successive regions in a circular fashion, eachtime throught the full window loop offsetting the next window by 12,-12. Users can select their preference through the TILING-ORDER argument to the function TILED.SEDIT.RESET, which must be either NIL (no tiling), T (default tiling order) or a list of the symbols TL (top-left) TR (top-right) BL (bottom-left) and BR (bottom-right)" ) (* ;; "User Interface") (DEFINEQ (TILED.SEDIT.RESET (LAMBDA (TILING-ORDER XSHIFT YSHIFT SCREEN) (* ; "Edited 24-Oct-89 12:09 by Koomen") (if (NULL TILING-ORDER) then (* ;; "Reset the world") (SETQ *TiledSEditRegions*) else (* ;; "Determine new order") (* ; "BEWARE!!! INFINITE LIST!!!") (LET ((ORDER (if (EQ TILING-ORDER T) then (LIST :TL :BL :TR :BR) else (for CORNER inside TILING-ORDER collect (SELECTQ CORNER ((:TL :TOPLEFT :TOP-LEFT :TOP.LEFT) :TL) ((:BL :BOTTOMLEFT :BOTTOM-LEFT :BOTTOM.LEFT) :BL) ((:TR :TOPRIGHT :TOP-RIGHT :TOP.RIGHT) :TR) ((:BR :BOTTOMRIGHT :BOTTOM-RIGHT :BOTTOM.RIGHT) :BR) (ERROR "Unsupported TILING-ORDER spec:" CORNER)))))) (SETQ TILING-ORDER (COPY ORDER)) (SETQ *TiledSEditNextCornerPtr* (SETQ *TiledSEditCorners* (NCONC ORDER ORDER)))) (* ;; "Determine starting placements") (SETQ *TiledSEditXShift* (OR (FIXP XSHIFT) 15)) (SETQ *TiledSEditYShift* (OR (FIXP YSHIFT) 15)) (if (NOT (REGIONP SCREEN)) then (SETQ SCREEN (LET ((MARGIN (OR (FIXP SCREEN) 25))) (CREATEREGION MARGIN MARGIN (IDIFFERENCE SCREENWIDTH MARGIN) (IDIFFERENCE SCREENHEIGHT MARGIN))))) (LET* ((WIDTH (LRSH (IDIFFERENCE (fetch (REGION WIDTH) of SCREEN) (LLSH *TiledSEditXShift* 2)) 1)) (HEIGHT (LRSH (IDIFFERENCE (fetch (REGION HEIGHT) of SCREEN) (LLSH *TiledSEditYShift* 2)) 1)) (TL-LEFT (fetch (REGION LEFT) of SCREEN)) (BL-LEFT TL-LEFT) (BL-BOTTOM (IPLUS *TiledSEditYShift* *TiledSEditYShift* (fetch (REGION BOTTOM) of SCREEN))) (BR-BOTTOM BL-BOTTOM) (TL-BOTTOM (IPLUS BL-BOTTOM HEIGHT *TiledSEditYShift* *TiledSEditYShift*)) (TR-BOTTOM TL-BOTTOM) (TR-LEFT (IPLUS TL-LEFT WIDTH *TiledSEditXShift* *TiledSEditXShift*)) (BR-LEFT TR-LEFT)) (SETQ *TiledSEditNextTopLeftRegion* (CREATEREGION TL-LEFT TL-BOTTOM WIDTH HEIGHT)) (SETQ *TiledSEditNextBottomLeftRegion* (CREATEREGION BL-LEFT BL-BOTTOM WIDTH HEIGHT)) (SETQ *TiledSEditNextTopRightRegion* (CREATEREGION TR-LEFT TR-BOTTOM WIDTH HEIGHT)) (SETQ *TiledSEditNextBottomRightRegion* (CREATEREGION BR-LEFT BR-BOTTOM WIDTH HEIGHT))) (* ;; "Move currently open SEdit windows (keep relative order), and recompute Tiled SEdit regions") (LET ((OLDREGIONS (CAR *TiledSEditRegions*)) CONTEXT OTHERS) (SETQ *TiledSEditRegions* (CONS)) (for W in (OPENWINDOWS) when (SETQ CONTEXT (WINDOWPROP W (QUOTE SEDIT::EDIT-CONTEXT))) do (for TSR in OLDREGIONS when (EQ (fetch TSR.CONTEXT of TSR) CONTEXT) do (replace TSR.REGION of TSR with W) (RETURN) finally (push OTHERS (CONS W CONTEXT)))) (for TSR in OLDREGIONS when (WINDOWP (fetch TSR.REGION of TSR)) do (SHAPEW (fetch TSR.REGION of TSR) (POST.TILED.SEDIT.GET.WINDOW.REGION (fetch TSR.CONTEXT of TSR) :CREATE))) (for PAIR in OTHERS do (SHAPEW (CAR PAIR) (POST.TILED.SEDIT.GET.WINDOW.REGION (CDR PAIR) :CREATE))))) (TILED.SEDIT.SWITCHFN (NULL TILING-ORDER) (QUOTE SEDIT:GET-WINDOW-REGION) (QUOTE PRE.TILED.SEDIT.GET.WINDOW.REGION) (QUOTE POST.TILED.SEDIT.GET.WINDOW.REGION)) (TILED.SEDIT.SWITCHFN (NULL TILING-ORDER) (QUOTE SEDIT:SAVE-WINDOW-REGION) (QUOTE PRE.TILED.SEDIT.SAVE.WINDOW.REGION) (QUOTE POST.TILED.SEDIT.SAVE.WINDOW.REGION)) TILING-ORDER) ) ) (* ;; "Support ") (PUTPROPS TILED-SEDIT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (RPAQ? *TiledSEditMargin* 25) (RPAQ? *TiledSEditXShift* 15) (RPAQ? *TiledSEditYShift* 15) (RPAQ? *TiledSEditRegions* NIL) (DECLARE%: EVAL@COMPILE (RECORD TILED.SEDIT.REGION (TSR.CONTEXT . TSR.REGION)) ) (DEFINEQ (POST.TILED.SEDIT.GET.WINDOW.REGION (LAMBDA (CONTEXT REASON) (* ; "Edited 24-Oct-89 12:17 by Koomen") (COPY (OR (if (AND SEDIT:KEEP-WINDOW-REGION (EQ REASON :EXPAND)) then (* ;; "Make sure it's there (wouldn't be if just enabled KeepWhenShrunk)") (for TSR in (CAR *TiledSEditRegions*) when (EQ (fetch TSR.CONTEXT of TSR) CONTEXT) do (* ;; "Don't return the tile, but the actual window region, in case of reshape") (RETURN (WINDOWREGION (fetch (SEDIT::EDIT-CONTEXT SEDIT::DISPLAY-WINDOW) of CONTEXT))))) (for TSR in (CAR *TiledSEditRegions*) unless (fetch TSR.CONTEXT of TSR) do (replace TSR.CONTEXT of TSR with CONTEXT) (RETURN (fetch TSR.REGION of TSR)) finally (SETQ TSR (TILED.SEDIT.NEW.REGION CONTEXT)) (TCONC *TiledSEditRegions* TSR) (RETURN (fetch TSR.REGION of TSR)))))) ) (POST.TILED.SEDIT.SAVE.WINDOW.REGION (LAMBDA (CONTEXT REASON) (* ; "Edited 24-Oct-89 13:32 by Koomen") (if (OR (NOT SEDIT:KEEP-WINDOW-REGION) (NEQ REASON :SHRINK)) then (for TSR in (CAR *TiledSEditRegions*) when (EQ (fetch TSR.CONTEXT of TSR) CONTEXT) do (RETURN (replace TSR.CONTEXT of TSR with NIL))))) ) (TILED.SEDIT.NEW.REGION (LAMBDA (CONTEXT) (* ; "Edited 17-Sep-87 12:51 by Koomen") (LET* ((NEXTREGION (SELECTQ (pop *TiledSEditNextCornerPtr*) (:TL *TiledSEditNextTopLeftRegion*) (:BL *TiledSEditNextBottomLeftRegion*) (:TR *TiledSEditNextTopRightRegion*) (:BR *TiledSEditNextBottomRightRegion*) (SHOULDNT "Bad corner spec!"))) (THISREGION (COPY NEXTREGION))) (replace (REGION LEFT) of NEXTREGION with (IPLUS (fetch (REGION LEFT) of NEXTREGION) *TiledSEditXShift*)) (replace (REGION BOTTOM) of NEXTREGION with (IDIFFERENCE (fetch (REGION BOTTOM) of NEXTREGION) *TiledSEditYShift*)) (create TILED.SEDIT.REGION TSR.CONTEXT _ CONTEXT TSR.REGION _ THISREGION))) ) (TILED.SEDIT.SWITCHFN (LAMBDA (RESTOREFLG FN SAVEFN REPLFN) (* ; "Edited 16-Sep-87 11:18 by Koomen") (if (NOT (DEFINEDP SAVEFN)) then (PUTD SAVEFN (GETD FN))) (PUTD FN (GETD (if (OR RESTOREFLG (NOT (DEFINEDP REPLFN))) then SAVEFN else REPLFN)))) ) ) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (OR (HASDEF (QUOTE SEDIT::EDIT-CONTEXT) (QUOTE RECORDS)) (EVAL (SYSRECLOOK1 (QUOTE SEDIT::EDIT-CONTEXT)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *TiledSEditXShift* *TiledSEditYShift* *TiledSEditRegions* *TiledSEditRegionWidth* *TiledSEditRegionHeight* *TiledSEditKeepWhenShrunk* *TiledSEditCorners* *TiledSEditNextCornerPtr* *TiledSEditNextTopLeftRegion* *TiledSEditNextBottomLeftRegion* *TiledSEditNextTopRightRegion* *TiledSEditNextBottomRightRegion*) ) ) (DECLARE%: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY (TILED.SEDIT.RESET T) ) (PUTPROPS TILED-SEDIT COPYRIGHT ("Johannes A. G. M. Koomen" 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2611 5630 (TILED.SEDIT.RESET 2621 . 5628)) (5969 7993 ( POST.TILED.SEDIT.GET.WINDOW.REGION 5979 . 6762) (POST.TILED.SEDIT.SAVE.WINDOW.REGION 6764 . 7074) ( TILED.SEDIT.NEW.REGION 7076 . 7738) (TILED.SEDIT.SWITCHFN 7740 . 7991))))) STOP \ No newline at end of file diff --git a/lispusers/TILED-SEDIT.TEDIT b/lispusers/TILED-SEDIT.TEDIT new file mode 100644 index 00000000..76f51d8a Binary files /dev/null and b/lispusers/TILED-SEDIT.TEDIT differ diff --git a/lispusers/TIMESROMAN.LC1-SF b/lispusers/TIMESROMAN.LC1-SF new file mode 100644 index 00000000..3746dd3c --- /dev/null +++ b/lispusers/TIMESROMAN.LC1-SF @@ -0,0 +1 @@ + ((FAMILY TIMESROMAND) (CHARACTER 141Q) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:35:46) (MADE-FROM NIL 121 130 62 40) (SPLINES ((2 ((200 153) (200 45)) NIL ((0 -108. 0 0 0 0 )) NATURAL) (4 ((200 45) (202 28) (214 23) (223 27)) NIL ((-0.866666079 -19.599998 0 0 17.1999969 15.6 ) (7.73333359 -11.799999 17.1999969 15.6 -25.999996 -6.0000019 ) (11.933332 0.800000430 -8.79999925 9.59999848 8.79999925 -9.59999848 )) NATURAL) (2 ((223 27) (227 20)) NIL ((4. -7. 0 0 0 0 )) NATURAL) (7 ((227 20) (216 9) (197 -1) (170 -6) (144 -2) (126 7) (117 23)) NIL ((-9.42051126 -11.0653839 0 0 -9.476923 0.392307758 ) (-14.1589737 -10.86923 -9.476923 0.392307758 -0.615383148 4.03846073 ) (-23.943588 -8.4576912 -10.092306 4.43076897 11.938459 7.45384408 ) (-28.066665 -0.299999237 1.84615373 11.884613 6.86153699 -9.8538437 ) (-22.789741 6.65769196 8.7076912 2.03076935 2.61538505 7.9615364 ) (-12.7743587 12.669231 11.323076 9.99230577 -11.323076 -9.99230577 )) NATURAL) (10 ((117 23) (89 4) (62 -3) (37 3) (18 25) (18 52) (32 77) (60 98) (92 113) (118 125)) NIL ((-28.156539 -21.562263 0 0 0.939252735 15.373584 ) (-27.686912 -13.875471 0.939252735 15.373584 1.30373621 -4.86792374 ) (-26.095794 -0.935848833 2.24298906 10.505661 -0.154199123 10.09811 ) (-23.9299 14.6188678 2.08878994 20.603771 23.313056 -17.524524 ) (-10.1845836 26.460376 25.401847 3.07924461 -15.098037 -5.99999905 ) (7.6682453 26.539619 10.30381 -2.92075443 7.07909394 -0.475471497 ) (21.511604 23.38113 17.382904 -3.39622593 -13.218345 -4.09811306 ) (32.285331 17.935848 4.16455746 -7.494339 -14.205694 4.86792374 ) (29.347045 12.875471 -10.0411377 -2.62641525 10.0411377 2.62641525 )) NATURAL) (2 ((118 125) (118 166)) NIL ((0 41. 0 0 0 0 )) NATURAL) (17 ((118 166) (110 187) (91 189) (88 171) (98 152) (85 130) (59 124) (32 132) (21 154) (31 182) (55 198) (86 205) (118 208) (148 205) (175 196) (195 177) (200 153)) NIL ((-4.25599289 24.640792 0 0 -22.464042 -21.844772 ) (-15.488014 13.718408 -22.464042 -21.844772 46.320213 -4.77613449 ) (-14.79195 -10.5144329 23.85617 -26.620906 -0.816810609 34.949317 ) (8.6558151 -19.660678 23.03936 8.328413 -61.05297 -21.02116 ) (1.16868734 -21.842845 -38.01361 -12.692747 29.028705 37.135314 ) (-22.330566 -15.967931 -8.98490335 24.442573 4.93813038 -13.52012 ) (-28.846405 1.71458101 -4.04677296 10.9224529 23.218769 4.94515419 ) (-21.283794 15.109611 19.171997 15.867607 4.1867752 -6.26049615 ) (-0.0184097290 27.846969 23.358772 9.60711099 -9.96585847 -27.90316 ) (18.357429 23.502498 13.3929138 -18.296051 -6.3233404 9.87314797 ) (28.588676 10.1430206 7.0695734 -8.42290307 -6.74077893 6.41057873 ) (32.287857 4.9254074 0.328793704 -2.01232386 -2.71354198 -5.5154743 ) (31.25988 0.155346542 -2.38474846 -7.52779866 -0.405051231 3.65131664 ) (28.672607 -5.54679394 -2.78979969 -3.876482 -1.66625213 -9.08978845 ) (25.049678 -13.96817 -4.45605183 -12.96627 -16.929931 8.70783807 ) (12.128662 -22.58052 -21.385986 -4.25843239 21.385986 4.25843239 )) NATURAL)) ((2 ((118 108) (118 58)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (9 ((118 58) (118 49) (111 38) (97 39) (90 49) (88 66) (93 83) (104 99) (118 108)) NIL ((1.25644326 -7.73932267 0 0 -7.53866006 -7.564064 ) (-2.51288652 -11.5213546 -7.53866006 -7.564064 -4.30669976 25.82032 ) (-12.2048969 -6.17525674 -11.8453598 18.256256 24.76546 -11.7172279 ) (-11.667524 6.2223854 12.920101 6.53902817 -10.7551517 3.04859924 ) (-4.12499905 14.285713 2.16494894 9.5876274 6.25515175 -12.477169 ) (1.16752624 17.634754 8.42010118 -2.88954306 -2.26546192 4.8600874 ) (8.4548969 17.175254 6.15463925 1.97054457 -3.19329929 -12.9631767 ) (13.012886 12.664211 2.96133995 -10.9926338 -2.96133995 10.9926338 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 142Q) (FACE M R R) (WIDTH 252 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:44:21) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 300) (112 183)) NIL ((0 -117. 0 0 0 0 )) NATURAL) (15 ((112 183) (138 201) (165 207) (195 200) (219 179) (232 150) (238 103) (232 67) (216 33) (186 8) (156 -2) (126 -3) (101 2) (84 11) (67 26)) NIL ((26.012008 20.539005 0 0 -0.0720686913 -15.234035 ) (25.975975 12.921987 -0.0720686913 -15.234035 6.36034299 4.17017746 ) (29.084079 -0.226958573 6.28827477 -11.063858 -13.3693046 -7.44667435 ) (28.687698 -15.014154 -7.08103085 -18.510532 -6.8831148 19.616527 ) (18.165111 -23.716423 -13.964145 1.10599708 10.901762 -35.019447 ) (9.6518459 -40.120147 -3.06238365 -33.913452 -12.723934 60.46128 ) (0.227496445 -43.802963 -15.7863178 26.547828 9.9939747 -32.82569 ) (-10.561834 -33.667976 -5.79234314 -6.2778654 -15.2519607 16.841495 ) (-23.980155 -31.525096 -21.044303 10.563631 27.013866 7.45970345 ) (-31.517528 -17.231613 5.96956349 18.023334 -8.80351258 -10.680305 ) (-29.949722 -4.5484333 -2.83395004 7.343029 8.20018579 -0.738483429 ) (-28.683578 2.42535353 5.36623669 6.6045456 6.0027647 -4.36575794 ) (-20.315956 6.84702016 11.369001 2.23878765 -14.211252 6.20151425 ) (-16.0525818 12.186565 -2.84225082 8.4403019 2.84225082 -8.4403019 )) NATURAL) (2 ((67 26) (36 -3)) NIL ((-31. -29. 0 0 0 0 )) NATURAL) (2 ((36 -3) (31 -3)) NIL ((-5. 0 0 0 0 0 )) NATURAL) (2 ((31 -3) (31 269)) NIL ((0 272. 0 0 0 0 )) NATURAL) (4 ((31 269) (29 283) (23 291) (12 295)) NIL ((-1.26666665 15.333332 0 0 -4.39999962 -8. ) (-3.4666667 11.333332 -4.39999962 -8. -2. 4. ) (-8.8666668 5.333333 -6.3999996 -4. 6.3999996 4. )) NATURAL) (2 ((12 295) (12 300)) NIL ((0 5. 0 0 0 0 )) NATURAL) (2 ((12 300) (112 300)) NIL ((100. 0 0 0 0 0 )) NATURAL)) ((2 ((112 44) (112 151)) NIL ((0 107. 0 0 0 0 )) NATURAL) (13 ((112 151) (119 172) (133 174) (144 161) (150 140) (152 115) (152 86) (150 56) (144 30) (134 16) (123 13) (114 24) (112 44)) NIL ((4.9868555 25.152385 0 0 12.078863 -24.914325 ) (11.026287 12.6952228 12.078863 -24.914325 -18.394321 10.57164 ) (13.907989 -6.9332838 -6.3154583 -14.3426857 1.4984293 6.62775994 ) (8.34174539 -17.962089 -4.817029 -7.71492577 0.400608063 4.91731739 ) (3.72502089 -23.218357 -4.41642094 -2.79760837 2.89913463 -2.29703045 ) (0.758167506 -27.164478 -1.51728606 -5.09463883 0.00285267830 4.2708044 ) (-0.757692457 -30.123714 -1.51443338 -0.823834062 -2.91054487 3.21380949 ) (-3.7273984 -29.340644 -4.42497826 2.38997555 -0.360672951 12.8739547 ) (-8.33271218 -20.51369 -4.7856512 15.263931 4.3532362 -6.70962716 ) (-10.9417457 -8.6045761 -0.432414532 8.5543041 0.947724820 7.9645443 ) (-10.900297 3.93200302 0.515310288 16.518848 9.85586167 -7.14856339 ) (-5.457057 16.876571 10.3711719 9.37028504 -10.3711719 -9.37028504 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 143Q) (FACE M R R) (WIDTH 211 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:50:06) (MADE-FROM NIL 118 130 57 78) (SPLINES ((2 ((181 46) (189 37)) NIL ((8. -9. 0 0 0 0 )) NATURAL) (32 ((189 37) (166 14) (135 -1) (92 -4) (59 7) (33 30) (16 66) (12 101) (17 136) (30 166) (51 189) (86 204) (125 206) (154 202) (180 189) (196 168) (196 143) (178 127) (155 124) (138 134) (130 155) (130 176) (124 189) (111 184) (96 160) (91 129) (93 95) (102 63) (117 42) (144 33) (167 39) (181 46)) NIL ((-21.882595 -24.507923 0 0 -6.704422 9.04754067 ) (-25.234806 -19.984149 -6.704422 9.04754067 -14.47789 2.76229286 ) (-39.178169 -9.5554638 -21.182312 11.809833 40.615982 3.90328407 ) (-40.05249 4.20601082 19.433673 15.713117 -15.986061 -6.37542153 ) (-28.611846 16.731418 3.4476118 9.33769609 5.32826138 9.5984001 ) (-22.500103 30.868312 8.77587319 18.936096 6.67301179 -26.01818 ) (-10.3877239 36.795318 15.4488849 -7.0820856 -8.02030374 10.4743309 ) (1.05100774 34.950393 7.42858029 3.39224672 1.40821170 -9.87914659 ) (9.18369485 33.403068 8.836792 -6.48690034 -3.61254501 -0.957740784 ) (16.214214 26.437301 5.22424698 -7.4446411 13.041965 1.71010685 ) (27.959445 19.847713 18.266212 -5.73453427 -12.5553169 -11.8826828 ) (39.947998 8.17183496 5.71089459 -17.617218 -22.820686 15.820638 ) (34.24855 -1.53506326 -17.109794 -1.79657936 19.838077 -9.39988137 ) (27.057792 -8.0315838 2.72828531 -11.1964607 -14.531629 3.77889252 ) (22.520263 -17.3386 -11.8033447 -7.4175682 -3.71155357 0.284306526 ) (8.8611412 -24.614013 -15.514898 -7.13326169 -6.62215615 19.083877 ) (-9.9648361 -22.205333 -22.137054 11.9506168 18.20018 1.38017273 ) (-23.0018 -9.5646324 -3.93687344 13.330789 11.821422 -0.604568482 ) (-21.027961 3.4638729 7.8845501 12.726221 0.514120102 1.03809929 ) (-12.8863506 16.709144 8.3986702 13.76432 4.1220932 -15.547828 ) (-2.42663336 22.699546 12.520763 -1.78350925 -23.002487 -4.8467741 ) (-1.40711474 18.492652 -10.4817257 -6.63028336 3.88786602 -13.0650749 ) (-9.9449062 5.32983113 -6.59385968 -19.695358 1.4510231 -2.89291382 ) (-15.813255 -15.811985 -5.14283657 -22.588272 20.30804 18.63673 ) (-10.8020706 -29.08189 15.1652069 -3.95154047 -10.683195 0.345976353 ) (-0.978460909 -32.860443 4.4820118 -3.60556412 4.4247303 3.979362 ) (5.71591568 -34.476326 8.9067421 0.373797953 -7.01572514 13.736572 ) (11.1147956 -27.234241 1.89101648 14.11037 17.638172 -4.92564965 ) (21.824897 -15.586696 19.52919 9.184721 -27.536972 11.96602 ) (27.585601 -0.418966293 -8.0077839 21.150741 -3.4902687 -24.938427 ) (17.832683 8.2625618 -11.4980526 -3.78768539 11.4980526 3.78768539 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 144Q) (FACE M R R) (WIDTH 250 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:56:16) (MADE-FROM NIL 103 130 57 78) (SPLINES ((2 ((136 269) (136 189)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (15 ((136 189) (114 204) (86 211) (57 203) (40 190) (25 168) (16 140) (12 110) (13 82) (20 51) (32 28) (52 8) (82 -2) (111 7) (136 25)) NIL ((-20.691444 16.123653 0 0 -7.8513279 -6.74192143 ) (-24.617107 12.752691 -7.8513279 -6.74192143 3.25663948 -14.2903919 ) (-30.840114 -1.13442683 -4.59468842 -21.032314 24.824771 21.903503 ) (-23.022419 -11.2149887 20.230083 0.871190191 -24.555728 -13.323631 ) (-15.0701999 -17.005615 -4.32564736 -12.452442 13.398151 7.39102364 ) (-12.6967716 -25.762546 9.07250405 -5.06141854 -5.0368824 1.75953817 ) (-6.14270783 -29.944194 4.03562165 -3.30188036 0.749382973 9.57081986 ) (-1.73239398 -28.460662 4.7850046 6.26894093 2.03935051 -16.0428238 ) (4.07228565 -30.213134 6.82435513 -9.7738838 -2.90677929 24.600475 ) (9.44325067 -27.686782 3.91757584 14.826591 3.58776283 -16.359073 ) (15.1547088 -21.039726 7.50533867 -1.53248405 6.5557308 10.8358268 ) (25.937912 -17.1542969 14.061069 9.3033428 -17.810688 15.015764 ) (31.093635 -0.343072712 -3.749619 24.319107 -1.31297540 -16.8988838 ) (26.68753 15.526592 -5.0625944 7.42022229 5.0625944 -7.42022229 )) NATURAL) (2 ((136 25) (136 -3)) NIL ((0 -28. 0 0 0 0 )) NATURAL) (2 ((136 -3) (241 10)) NIL ((105. 13. 0 0 0 0 )) NATURAL) (2 ((241 10) (241 15)) NIL ((0 5. 0 0 0 0 )) NATURAL) (5 ((241 15) (231 19) (222 26) (217 37) (217 50)) NIL ((-10.071428 3.4464283 0 0 0.428571463 3.32142878 ) (-9.8571415 5.10714245 0.428571463 3.32142878 3.85714245 1.39285612 ) (-7.5 9.125 4.28571415 4.7142849 2.14285755 -2.8928566 ) (-2.14285707 12.392856 6.4285717 1.8214283 -6.4285717 -1.8214283 )) NATURAL) (2 ((217 50) (217 300)) NIL ((0 250. 0 0 0 0 )) NATURAL) (2 ((217 300) (117 300)) NIL ((-100. 0 0 0 0 0 )) NATURAL) (2 ((117 300) (117 295)) NIL ((0 -5. 0 0 0 0 )) NATURAL) (4 ((117 295) (128 291) (134 283) (136 269)) NIL ((12.0666656 -3.33333302 0 0 -6.3999996 -4. ) (8.8666649 -5.333333 -6.3999996 -4. 2. -4. ) (3.46666622 -11.333332 -4.39999962 -8. 4.39999962 8. )) NATURAL)) ((2 ((136 159) (136 79)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (12 ((136 79) (133 52) (122 34) (108 40) (100 62) (96 88) (95 116) (97 143) (104 168) (117 179) (130 174) (136 159)) NIL ((-1.1699872 -27.978817 0 0 -10.9800758 5.87290669 ) (-6.6600256 -25.042362 -10.9800758 5.87290669 6.90038396 24.635463 ) (-14.189909 -6.85172368 -4.07969189 30.508373 13.378538 -14.4147758 ) (-11.5803318 16.44926 9.2988472 16.093597 -6.414546 -14.9763717 ) (-5.48875714 25.054672 2.88430118 1.11722469 0.279644012 2.32027578 ) (-2.46463442 27.332035 3.1639452 3.43750048 -0.704028130 -6.30472756 ) (0.347296834 27.617172 2.45991707 -2.86722755 2.53646755 4.89863777 ) (4.07544804 27.199264 4.99638462 2.03141022 2.55815506 -19.289821 ) (10.35091 19.585762 7.55453969 -17.258411 -6.76908303 0.260658264 ) (14.520908 2.45767784 0.785455943 -16.997753 -11.481819 6.24719239 ) (9.56545449 -11.416479 -10.696363 -10.7505607 10.696363 10.7505607 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 145Q) (FACE M R R) (WIDTH 211 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:02:38) (MADE-FROM NIL 118 130 57 78) (SPLINES ((19 ((200 104) (197 137) (186 166) (170 186) (148 200) (119 206) (86 205) (51 189) (30 166) (17 136) (12 101) (16 66) (32 30) (59 7) (92 -5) (123 -5) (153 7) (175 25) (195 50)) NIL ((-1.13248205 33.50447 0 0 -11.2051067 -3.02686691 ) (-6.73503495 31.991043 -11.2051067 -3.02686691 8.02553369 -8.86566545 ) (-13.9273739 24.531341 -3.1795721 -11.892532 -2.89703178 8.48953248 ) (-18.555461 16.883575 -6.0766039 -3.4029994 -2.43740368 -7.09246636 ) (-25.850769 9.93434335 -8.51400758 -10.495466 6.6466446 7.880332 ) (-31.041454 3.37904358 -1.86736274 -2.61513424 -6.14917756 -18.428859 ) (-35.983406 -8.45052148 -8.01654054 -21.043994 29.950065 17.835117 ) (-29.024913 -20.576957 21.933525 -3.20887518 -17.651088 -4.9116268 ) (-15.916933 -26.241645 4.28243447 -8.12050248 4.65429688 1.81138706 ) (-9.30734826 -33.45645 8.93673135 -6.3091154 -0.966098786 9.66608239 ) (-0.853666306 -34.932525 7.97063256 3.35696745 5.21010018 -10.475719 ) (9.72201539 -36.813415 13.1807327 -7.11875249 -1.8743 26.236793 ) (21.965599 -30.813774 11.3064327 19.118042 -3.71290112 -10.4714679 ) (31.41558 -16.931465 7.5935316 8.646574 -13.274093 3.64907837 ) (32.372062 -6.46035195 -5.68056298 12.295652 8.8092842 1.87515449 ) (31.096145 6.7728777 3.12872219 14.1708069 -15.963047 -11.1496887 ) (26.243343 15.368839 -12.8343258 3.02111721 13.0429058 6.72360325 ) (19.930469 21.751758 0.208581745 9.74472047 -0.208581745 -9.74472047 )) NATURAL) (2 ((195 50) (185 59)) NIL ((-10. 9. 0 0 0 0 )) NATURAL) (7 ((185 59) (165 43) (143 36) (114 46) (99 67) (94 87) (93 104)) NIL ((-20.189743 -17.4038429 0 0 1.13846111 8.42307664 ) (-19.62051 -13.192306 1.13846111 8.42307664 -17.692302 11.884613 ) (-27.328205 1.17307806 -16.553844 20.307689 39.63076 -7.9615383 ) (-24.066661 17.5 23.076919 12.346151 -14.830766 -16.0384559 ) (-8.40512658 21.826919 8.24615289 -3.692307 -4.30769062 0.115384102 ) (-2.31282043 18.192306 3.93846178 -3.57692289 -3.93846178 3.57692289 )) NATURAL) (2 ((93 104) (200 104)) NIL ((107. 0 0 0 0 0 )) NATURAL)) ((9 ((93 122) (92 141) (93 158) (97 178) (111 188) (125 178) (129 158) (130 141) (129 122)) NIL ((-1.5 19.855667 0 0 3. -5.13401985 ) (0 17.288658 3. -5.13401985 -3. 13.670101 ) (1.5 18.989688 0 8.5360813 15. -19.546386 ) (9. 17.7525749 15. -11.010307 -15. -13.484535 ) (16.5 -9.53674316E-7 0 -24.494842 -15. 13.484533 ) (8.9999981 -17.7525749 -15. -11.010309 15. 19.54639 ) (1.49999976 -18.989688 1.27768117E-7 8.5360813 -3. -13.670101 ) (0 -17.288658 -3. -5.13401985 3. 5.13401985 )) NATURAL) (2 ((129 122) (93 122)) NIL ((-36. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 146Q) (FACE M R R) (WIDTH 206 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:13:04) (MADE-FROM NIL 141 130 57 78) (SPLINES ((2 ((123 36) (123 182)) NIL ((0 146. 0 0 0 0 )) NATURAL) (2 ((123 182) (153 182)) NIL ((30. 0 0 0 0 0 )) NATURAL) (2 ((153 182) (153 200)) NIL ((0 18. 0 0 0 0 )) NATURAL) (2 ((153 200) (123 200)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (2 ((123 200) (123 240)) NIL ((0 40. 0 0 0 0 )) NATURAL) (17 ((123 240) (121 259) (120 275) (128 285) (134 278) (134 266) (148 248) (171 244) (191 257) (191 283) (174 298) (150 303) (125 303) (94 297) (69 286) (48 266) (41 240)) NIL ((-1.63036418 19.686523 0 0 -2.21781492 -4.11915779 ) (-2.73927164 17.626945 -2.21781492 -4.11915779 17.089073 2.59579229 ) (3.58745146 14.805685 14.871259 -1.52336526 -18.138488 -24.264011 ) (9.3894653 1.15031027 -3.26723003 -25.78738 -10.53511 28.460277 ) (0.854681612 -10.4069309 -13.802341 2.67289829 36.27893 -17.577106 ) (5.1918087 -16.5225868 22.476593 -14.904209 -14.580635 35.848144 ) (20.378082 -13.5027198 7.89595795 20.943939 -7.9563837 -5.81549454 ) (24.295848 4.53347206 -0.0604261532 15.128444 -25.593822 5.4138298 ) (11.4385109 22.368831 -25.65425 20.542274 8.3316803 -39.83982 ) (-10.0499019 22.991195 -17.32257 -19.297546 10.267128 9.9454651 ) (-22.238906 8.66637994 -7.05544186 -9.3520813 10.5997829 6.05795956 ) (-23.994457 2.34327888 3.54434252 -3.29412127 -16.666267 -4.17730904 ) (-28.783252 -3.03949785 -13.121927 -7.47143078 26.0653 4.65127945 ) (-28.872528 -8.18528939 12.9433727 -2.82015133 -15.594938 -8.42780686 ) (-23.726623 -15.219345 -2.65156555 -11.247959 24.314453 5.05994892 ) (-14.220962 -23.937328 21.662887 -6.1880102 -21.662887 6.1880102 )) NATURAL) (2 ((41 240) (41 200)) NIL ((0 -40. 0 0 0 0 )) NATURAL) (2 ((41 200) (11 200)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (2 ((11 200) (11 182)) NIL ((0 -18. 0 0 0 0 )) NATURAL) (2 ((11 182) (41 182)) NIL ((30. 0 0 0 0 0 )) NATURAL) (2 ((41 182) (41 36)) NIL ((0 -146. 0 0 0 0 )) NATURAL) (4 ((41 36) (38 19) (30 11) (18 8)) NIL ((-1.93333339 -19.066665 0 0 -6.3999996 12.3999996 ) (-5.1333332 -12.8666649 -6.3999996 12.3999996 2. -8. ) (-10.5333328 -4.46666622 -4.39999962 4.39999962 4.39999962 -4.39999962 )) NATURAL) (2 ((18 8) (18 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((18 0) (146 0)) NIL ((128. 0 0 0 0 0 )) NATURAL) (2 ((146 0) (146 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((146 8) (134 11) (126 19) (123 36)) NIL ((-12.7333316 2.26666641 0 0 4.39999962 4.39999962 ) (-10.5333328 4.46666622 4.39999962 4.39999962 2. 8. ) (-5.1333332 12.8666668 6.3999996 12.3999996 -6.3999996 -12.3999996 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 147Q) (FACE M R R) (WIDTH 243 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:37:45) (MADE-FROM NIL 114 130 44 38) (SPLINES ((2 ((228 196) (228 173)) NIL ((0 -23. 0 0 0 0 )) NATURAL) (2 ((228 173) (198 173)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (29 ((198 173) (209 151) (211 124) (201 98) (178 80) (151 70) (121 68) (95 64) (89 55) (101 47) (129 44) (161 43) (187 38) (209 28) (222 17) (229 3) (230 -24) (218 -47) (192 -64) (156 -74) (119 -76) (91 -75) (66 -72) (41 -66) (20 -53) (15 -37) (28 -25) (47 -19) (63 -14)) NIL ((12.78347 -20.712417 0 0 -10.7008228 -7.7254791 ) (7.43305874 -24.575157 -10.7008228 -7.7254791 -0.495885849 8.62739755 ) (-3.51570749 -27.986938 -11.1967086 0.901919008 -5.31562805 9.21588326 ) (-17.370227 -22.477077 -16.512336 10.1178035 15.758396 -3.49094486 ) (-26.003368 -14.1047439 -0.753939868 6.6268587 -3.71796274 4.74789715 ) (-28.61629 -5.1039362 -4.47190285 11.3747558 5.11345577 -15.500644 ) (-30.531463 -1.47950363 0.641553402 -4.12588978 25.264133 -2.74530792 ) (-17.257843 -6.97804738 25.905689 -6.8711977 -10.169996 8.48187829 ) (3.56284761 -9.60830499 15.7356929 1.61068225 3.41583443 4.81778527 ) (21.006458 -5.58872986 19.151527 6.42846776 -15.493345 -3.75302172 ) (32.411308 -1.03677320 3.65818119 2.67544603 -13.442436 -7.8056984 ) (29.348274 -2.26417684 -9.78425599 -5.13025284 9.2631035 -1.02417946 ) (24.195571 -7.90651894 -0.521150828 -6.1544323 -11.609985 5.90241528 ) (17.869426 -11.109743 -12.1311378 -0.252016604 7.17684079 1.41451549 ) (9.32670976 -10.6545028 -4.95429707 1.16249895 0.902627946 -23.560474 ) (4.82372666 -21.272243 -4.05166912 -22.397975 -10.787355 32.8274 ) (-4.62162113 -27.256519 -14.839025 10.429424 0.246803283 -5.7491474 ) (-19.3372459 -19.701667 -14.592222 4.68027687 3.80014229 2.1691885 ) (-32.029396 -13.936798 -10.7920799 6.84946538 8.55262567 3.07239437 ) (-38.545158 -5.5511341 -2.23945331 9.92185975 15.989345 -8.45877076 ) (-32.789939 0.141339540 13.749893 1.46308779 -12.5100116 0.762699366 ) (-25.295055 1.9857769 1.23988032 2.22578716 -1.94929528 -0.592023611 ) (-25.029823 3.91555214 -0.709414959 1.63376355 2.30719423 7.60539437 ) (-24.585639 9.35201264 1.59777927 9.2391586 16.720512 -5.8295555 ) (-14.627601 15.676393 18.318294 3.40960312 2.81072998 -8.2871742 ) (5.0960598 14.942409 21.129024 -4.87757206 -15.963432 -3.02174187 ) (18.243366 8.5539665 5.1655922 -7.8993139 -10.956989 8.3741417 ) (17.930465 4.84172344 -5.7913971 0.474828482 5.7913971 -0.474828482 )) NATURAL) (8 ((63 -14) (45 -8) (30 3) (22 20) (25 40) (40 55) (59 64) (81 71)) NIL ((-18.455513 5.01511479 0 0 2.73308134 5.90930939 ) (-17.08897 7.96976948 2.73308134 5.90930939 4.33459187 0.453452110 ) (-12.1885948 14.105804 7.06767369 6.3627615 3.92854786 -1.72311878 ) (-3.15664673 19.607006 10.9962215 4.6396427 3.95121765 -11.560976 ) (9.81518365 18.466159 14.947439 -6.9213333 -13.733423 -0.0329771042 ) (17.895908 11.528339 1.21401572 -6.9543104 2.98248005 5.69288826 ) (20.601165 7.42047406 4.196496 -1.26142215 -4.196496 1.26142215 )) NATURAL) (13 ((81 71) (49 84) (30 100) (17 122) (16 147) (23 169) (38 186) (57 197) (84 203) (112 205) (133 204) (160 199) (178 196)) NIL ((-35.25244 12.5588417 0 0 19.514675 2.64694261 ) (-25.495105 13.8823127 19.514675 2.64694261 -19.573375 4.76528645 ) (-15.76712 18.911899 -0.0587015748 7.41222954 16.778831 -3.70809364 ) (-7.43640328 24.470081 16.7201309 3.7041359 -11.541971 -7.93291188 ) (3.51274204 24.207763 5.17815876 -4.22877598 5.38906956 -0.560255051 ) (11.385435 19.69886 10.567228 -4.78903103 -10.014303 -1.82606792 ) (16.9455108 13.9967937 0.552924156 -6.61509896 10.668148 1.86452961 ) (22.832511 8.3139591 11.221073 -4.75056935 -8.6582985 0.367947578 ) (29.724433 3.74736357 2.5627737 -4.38262177 -18.034942 2.6636815 ) (23.269737 0.696582556 -15.4721698 -1.71894026 32.798072 -5.02267456 ) (24.196609 -3.53369522 17.325908 -6.7416153 -35.157379 11.427019 ) (23.943824 -4.56180096 -17.831474 4.68540383 17.831474 -4.68540383 )) NATURAL) (2 ((178 196) (228 196)) NIL ((50. 0 0 0 0 0 )) NATURAL)) ((11 ((122 -17) (160 -21) (170 -36) (153 -54) (124 -60) (99 -58) (82 -51) (73 -36) (80 -21) (99 -16) (122 -17)) NIL ((33.954147 -1.97819113 34.128494 1.78905892 -78.110366 -17.498027 ) (29.027458 -8.9381466 -43.981872 -15.708971 17.780868 10.755794 ) (-6.06398297 -19.269218 -26.201004 -4.95317555 12.9869098 22.474849 ) (-25.77153 -12.984966 -13.214094 17.521675 20.271484 -10.655218 ) (-28.849884 -0.790901423 7.05739117 6.86645699 1.92713833 -3.85396195 ) (-20.828922 4.14857388 8.9845295 3.01249504 -3.9800415 8.0710678 ) (-13.834413 11.1966037 5.00448799 11.0835628 13.9930248 -10.430311 ) (-1.83341241 17.06501 18.997512 0.653250337 -3.99206352 -14.349813 ) (15.1680698 10.543352 15.005449 -13.6965637 -22.024765 7.82957268 ) (19.161136 0.761575103 -7.01931763 -5.86699105 44.091133 7.0315218 )) PSEUDOCYCLIC)) ((17 ((113 84) (123 90) (128 103) (131 119) (131 137) (131 155) (128 171) (123 184) (113 190) (103 184) (98 171) (95 155) (95 137) (95 119) (98 103) (103 90) (113 84)) NIL ((11.253885 0.0487168580 0.0133232101 14.7384567 -7.56328488 -8.50767137 ) (7.48556615 10.5333366 -7.54996205 6.23078538 7.73648549 -3.89238644 ) (3.8038473 14.81793 0.186523854 2.33839893 -5.3826561 0.0772185326 ) (1.29904294 17.194938 -5.19613266 2.41561746 7.7941389 -2.41648722 ) (-1.98682137E-5 18.402309 2.59800672 -8.69973097E-4 -7.7939005 -2.41126728 ) (-1.29896378 17.195808 -5.19589424 -2.41213751 5.3814659 0.0615592003 ) (-3.80412483 14.814449 0.185572236 -2.35057831 -7.73196507 -3.83496952 ) (-7.4845352 10.5463867 -7.5463934 -6.18554783 7.5463934 -8.72167588 ) (-11.25773 -3.18512320E-7 2.55536235E-7 -14.907224 7.54639149 8.72167588 ) (-7.4845352 -10.5463867 7.54639245 -6.18554879 -7.7319641 3.83497095 ) (-3.80412483 -14.814449 -0.185571968 -2.35057783 5.3814659 -0.0615596771 ) (-1.29896354 -17.195808 5.19589424 -2.41213751 -7.7939005 2.41126728 ) (-1.97092667E-5 -18.402309 -2.59800672 -8.69973213E-4 7.79413796 2.41648722 ) (1.29904318 -17.194938 5.1961317 2.41561746 -5.38265515 -0.0772185326 ) (3.8038473 -14.81793 -0.186523586 2.33839893 7.73648549 3.89238644 ) (7.48556615 -10.5333366 7.54996205 6.23078538 -7.56328488 8.50767137 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 150Q) (FACE M R R) (WIDTH 259 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:58:05) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 300) (112 183)) NIL ((0 -117. 0 0 0 0 )) NATURAL) (8 ((112 183) (130 196) (152 207) (176 212) (198 208) (217 196) (231 169) (235 142)) NIL ((17.098247 13.2576427 0 0 5.41051197 -1.54586053 ) (19.803501 12.484712 5.41051197 -1.54586053 -3.05255985 -4.27069664 ) (23.687732 8.80350305 2.35795212 -5.81655789 -5.2002735 -5.37134838 ) (23.445549 0.301270485 -2.84232187 -11.187906 -0.146341800 7.75609589 ) (20.530056 -7.0085888 -2.98866367 -3.43181038 -0.214358806 -19.653034 ) (17.434211 -20.266918 -3.20302248 -23.084846 -10.9962196 28.856056 ) (8.7330799 -28.923736 -14.199243 5.77121258 14.199243 -5.77121258 )) NATURAL) (2 ((235 142) (235 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((235 42) (235 26) (239 13) (247 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((247 8) (247 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((247 0) (135 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((135 0) (135 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((135 8) (143 13) (147 26) (147 42)) NIL ((8.79999925 3.0666666 0 0 -4.80000019 11.599998 ) (6.3999996 8.8666668 -4.80000019 11.599998 9.53674316E-7 -9.9999981 ) (1.59999966 15.466665 -4.79999924 1.5999999 4.79999924 -1.5999999 )) NATURAL) (2 ((147 42) (147 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((147 142) (146 159) (139 170) (124 168) (115 157) (113 142)) NIL ((-0.0478469506 17.827751 0 0 -5.71291828 -4.9665079 ) (-2.90430641 15.3444957 -5.71291828 -4.9665079 -7.43540669 -11.167459 ) (-12.3349266 4.79425717 -13.1483249 -16.133968 23.454544 7.63636208 ) (-13.755979 -7.5215311 10.306219 -8.49760629 -2.38277435 4.62200833 ) (-4.6411476 -13.7081337 7.92344475 -3.87559795 -7.92344475 3.87559795 )) NATURAL) (2 ((113 142) (113 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((113 42) (113 26) (117 13) (125 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((125 8) (125 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((125 0) (17 0)) NIL ((-108. 0 0 0 0 0 )) NATURAL) (2 ((17 0) (17 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((17 8) (27 13) (31 26) (31 42)) NIL ((11.333332 3.0666666 0 0 -8. 11.599998 ) (7.333333 8.8666668 -8. 11.599998 4. -9.9999981 ) (1.33333325 15.466665 -4. 1.5999999 4. -1.5999999 )) NATURAL) (2 ((31 42) (31 269)) NIL ((0 227. 0 0 0 0 )) NATURAL) (4 ((31 269) (29 283) (23 291) (12 292)) NIL ((-1.26666665 15.133333 0 0 -4.39999962 -6.8000002 ) (-3.4666667 11.7333316 -4.39999962 -6.8000002 -2. -1.99999904 ) (-8.8666668 3.93333292 -6.3999996 -8.79999925 6.3999996 8.79999925 )) NATURAL) (2 ((12 292) (12 300)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 300) (112 300)) NIL ((100. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 151Q) (FACE M R R) (WIDTH 146 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:05:21) (MADE-FROM NIL 177 130 57 78) (SPLINES ((2 ((115 205) (13 205)) NIL ((-102. 0 0 0 0 0 )) NATURAL) (2 ((13 205) (13 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((13 197) (24 196) (30 188) (32 174)) NIL ((12.0666656 0.466666520 0 0 -6.3999996 -8.79999925 ) (8.8666649 -3.9333334 -6.3999996 -8.79999925 2. 2. ) (3.46666622 -11.7333335 -4.39999962 -6.79999924 4.39999962 6.79999924 )) NATURAL) (2 ((32 174) (32 34)) NIL ((0 -140. 0 0 0 0 )) NATURAL) (5 ((32 34) (31 25) (28 16) (22 11) (14 8)) NIL ((-0.642857075 -8.75 0 0 -2.14285707 -1.5 ) (-1.71428561 -9.5 -2.14285707 -1.5 -1.28571415 7.5 ) (-4.5 -7.24999905 -3.42857122 6. 1.28571415 -4.5 ) (-7.28571416 -3.49999952 -2.14285707 1.49999976 2.14285707 -1.49999976 )) NATURAL) (2 ((14 8) (14 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((14 0) (133 0)) NIL ((119. 0 0 0 0 0 )) NATURAL) (2 ((133 0) (133 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (5 ((133 8) (125 11) (119 16) (116 25) (115 34)) NIL ((-8.3571415 2.74999952 0 0 2.14285707 1.50000024 ) (-7.28571416 3.5 2.14285707 1.50000024 1.28571415 4.4999981 ) (-4.49999905 7.25 3.42857122 5.99999905 -1.28571415 -7.4999981 ) (-1.71428561 9.4999981 2.14285707 -1.49999976 -2.14285707 1.49999976 )) NATURAL) (2 ((115 34) (115 205)) NIL ((0 171. 0 0 0 0 )) NATURAL)) ((17 ((73 305) (91 302) (105 294) (113 282) (116 271) (113 260) (105 248) (91 240) (73 237) (55 240) (41 248) (33 260) (30 271) (33 282) (41 294) (55 302) (73 305)) NIL ((18.854923 -0.116663769 -0.497396290 -6.39998913 -3.63736725 1.89995003 ) (16.538845 -5.56667805 -4.13476372 -4.5000391 -2.82878303 -1.09981155 ) (10.9896888 -10.6166229 -6.96354676 -5.59985066 2.95249748 8.49929238 ) (5.5023918 -11.966827 -4.01104927 2.89944172 -2.98120499 -2.89735794 ) (7.40051269E-4 -10.5160637 -6.99225426 0.00208338676 2.97232246 -2.90985823 ) (-5.50535298 -11.96891 -4.0199318 -2.90777492 -2.90808678 8.53679086 ) (-10.979326 -10.6082897 -6.92801858 5.62901592 2.66002369 -1.23730755 ) (-16.577331 -5.59792614 -4.26799488 4.39170838 4.26799488 2.41243648 ) (-18.71133 3.18512320E-7 0 6.80414487 4.26799488 -2.41243648 ) (-16.577331 5.5979271 4.26799488 4.39170838 2.66002273 1.23730755 ) (-10.979326 10.6082897 6.9280176 5.62901592 -2.90808678 -8.53679086 ) (-5.50535202 11.96891 4.01993084 -2.90777492 2.97232437 2.90985775 ) (7.40210526E-4 10.5160637 6.9922552 0.00208325917 -2.98120689 2.89735842 ) (5.50239277 11.966827 4.01104832 2.89944172 2.95249843 -8.49929048 ) (10.9896888 10.6166229 6.96354676 -5.5998497 -2.82878303 1.09980964 ) (16.538845 5.56667805 4.13476372 -4.50004006 -3.63736725 -1.89994907 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 152Q) (FACE M R R) (WIDTH 162 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:08:40) (MADE-FROM NIL 146 130 57 78) (SPLINES ((2 ((146 205) (44 205)) NIL ((-102. 0 0 0 0 0 )) NATURAL) (2 ((44 205) (44 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((44 197) (55 196) (61 188) (63 174)) NIL ((12.0666656 0.466666520 0 0 -6.3999996 -8.79999925 ) (8.8666649 -3.9333334 -6.3999996 -8.79999925 2. 2. ) (3.46666622 -11.7333335 -4.39999962 -6.79999924 4.39999962 6.79999924 )) NATURAL) (2 ((63 174) (63 6)) NIL ((0 -168. 0 0 0 0 )) NATURAL) (16 ((63 6) (66 -15) (68 -40) (66 -55) (58 -54) (56 -33) (40 -18) (19 -20) (10 -35) (13 -56) (36 -71) (74 -76) (111 -68) (136 -46) (146 -18) (146 6)) NIL ((3.14361906 -19.411846 0 0 -0.861714364 -9.52890206 ) (2.71276188 -24.1763 -0.861714364 -9.52890206 -1.69142818 23.644516 ) (1.00533318 -21.882942 -2.55314255 14.1156139 -10.3725719 -1.04916954 ) (-6.73409558 -8.291914 -12.925714 13.066444 31.181716 16.552154 ) (-4.06895066 13.0506077 18.256004 29.618598 -42.354309 -41.159439 ) (-6.9900999 22.089481 -24.098304 -11.5408439 18.235511 -7.9143753 ) (-21.970645 6.5914507 -5.86279106 -19.455219 23.412258 6.81695367 ) (-16.127304 -9.45529176 17.549469 -12.638265 -9.88456727 4.64655018 ) (-3.52012062 -19.770282 7.66490174 -7.99171544 16.126018 16.596843 ) (12.207792 -19.463573 23.79092 8.60513116 -6.61951447 0.966056824 ) (32.688949 -10.3754139 17.171405 9.57118798 -19.647953 3.53892136 ) (40.036384 0.965236307 -2.47654915 13.110109 -10.78866 2.87825394 ) (32.165504 15.5144729 -13.265209 15.988363 -3.19739914 -9.05192758 ) (17.301593 26.976871 -16.462608 6.9364357 5.57826233 -14.670543 ) (3.62811518 26.578033 -10.884346 -7.7341089 10.884346 7.7341089 )) NATURAL) (2 ((146 6) (146 205)) NIL ((0 199. 0 0 0 0 )) NATURAL)) ((17 ((104 305) (122 302) (136 294) (144 282) (147 271) (144 260) (136 248) (122 240) (104 237) (86 240) (72 248) (64 260) (61 271) (64 282) (72 294) (86 302) (104 305)) NIL ((18.854923 -0.116663769 -0.497396290 -6.39998913 -3.63736725 1.89995003 ) (16.538845 -5.56667805 -4.13476372 -4.5000391 -2.82878303 -1.09981155 ) (10.9896888 -10.6166229 -6.96354676 -5.59985066 2.95249748 8.49929238 ) (5.5023918 -11.966827 -4.01104927 2.89944172 -2.98120499 -2.89735794 ) (7.40051269E-4 -10.5160637 -6.99225426 0.00208338676 2.97232246 -2.90985823 ) (-5.50535298 -11.96891 -4.0199318 -2.90777492 -2.90808678 8.53679086 ) (-10.979326 -10.6082897 -6.92801858 5.62901592 2.66002369 -1.23730755 ) (-16.577331 -5.59792614 -4.26799488 4.39170838 4.26799488 2.41243648 ) (-18.71133 3.18512320E-7 0 6.80414487 4.26799488 -2.41243648 ) (-16.577331 5.5979271 4.26799488 4.39170838 2.66002273 1.23730755 ) (-10.979326 10.6082897 6.9280176 5.62901592 -2.90808678 -8.53679086 ) (-5.50535202 11.96891 4.01993084 -2.90777492 2.97232437 2.90985775 ) (7.40210526E-4 10.5160637 6.9922552 0.00208325917 -2.98120689 2.89735842 ) (5.50239277 11.966827 4.01104832 2.89944172 2.95249843 -8.49929048 ) (10.9896888 10.6166229 6.96354676 -5.5998497 -2.82878303 1.09980964 ) (16.538845 5.56667805 4.13476372 -4.50004006 -3.63736725 -1.89994907 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 153Q) (FACE M R R) (WIDTH 259 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:19:29) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((114 300) (113 117)) NIL ((-1. -183. 0 0 0 0 )) NATURAL) (2 ((113 117) (142 155)) NIL ((29. 38. 0 0 0 0 )) NATURAL) (5 ((142 155) (150 170) (147 185) (138 193) (129 195)) NIL ((10.5178566 14.607141 0 0 -15.107141 2.35714245 ) (2.9642849 15.785713 -15.107141 2.35714245 9.5357132 -11.785711 ) (-7.375 12.249998 -5.5714283 -9.4285698 6.9642849 2.78571319 ) (-9.4642849 4.2142849 1.39285707 -6.6428566 -1.39285707 6.6428566 )) NATURAL) (3 ((129 195) (129 205) (129 205)) NIL ((0 12.5 0 0 0 -15. ) (0 5. 0 -15. 0 15. )) NATURAL) (2 ((129 205) (229 205)) NIL ((100. 0 0 0 0 0 )) NATURAL) (2 ((229 205) (229 195)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((229 195) (209 189) (192 178) (177 164) (165 150)) NIL ((-20.714283 -4.875 0 0 4.28571415 -6.75 ) (-18.571426 -8.25 4.28571415 -6.75 -3.42857122 3.75000048 ) (-15.999998 -13.125 0.857142807 -2.99999952 3.42857122 3.74999905 ) (-13.4285698 -14.249998 4.28571415 0.749999881 -4.28571415 -0.749999881 )) NATURAL) (2 ((165 150) (233 23)) NIL ((68. -127. 0 0 0 0 )) NATURAL) (3 ((233 23) (242 10) (247 8)) NIL ((10. -15.75 0 0 -6. 16.5 ) (7. -7.5 -6. 16.5 6. -16.5 )) NATURAL) (2 ((247 8) (247 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((247 0) (135 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((135 0) (135 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((135 8) (143 11) (146 18) (141 30)) NIL ((8.79999925 2.26666641 0 0 -4.80000019 4.39999962 ) (6.3999996 4.46666622 -4.80000019 4.39999962 -5.99999905 2. ) (-1.40000009 9.8666668 -10.799999 6.3999996 10.799999 -6.3999996 )) NATURAL) (2 ((141 30) (113 90)) NIL ((-28. 60. 0 0 0 0 )) NATURAL) (2 ((113 90) (113 39)) NIL ((0 -51. 0 0 0 0 )) NATURAL) (4 ((113 39) (115 24) (120 13) (125 8)) NIL ((1.20000004 -15.666666 0 0 4.79999924 4. ) (3.5999999 -13.666666 4.79999924 4. -5.99999905 4. ) (5.3999996 -7.66666604 -1.19999981 8. 1.19999981 -8. )) NATURAL) (2 ((125 8) (125 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((125 0) (13 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((13 0) (13 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((13 8) (23 13) (31 26) (31 42)) NIL ((10. 3.0666666 0 0 0 11.599998 ) (10. 8.8666668 0 11.599998 -12. -9.9999981 ) (4. 15.466665 -12. 1.5999999 12. -1.5999999 )) NATURAL) (2 ((31 42) (31 269)) NIL ((0 227. 0 0 0 0 )) NATURAL) (5 ((31 269) (30 276) (29 283) (23 290) (12 292)) NIL ((-1.26785707 7.0892849 0 0 1.60714268 -0.535714150 ) (-0.464285731 6.8214283 1.60714268 -0.535714150 -8.0357132 2.67857075 ) (-2.875 7.625 -6.42857075 2.1428566 0.535714150 -10.1785698 ) (-9.0357132 4.67857075 -5.8928566 -8.0357132 5.8928566 8.0357132 )) NATURAL) (2 ((12 292) (12 300)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 300) (114 300)) NIL ((102. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 154Q) (FACE M R R) (WIDTH 145 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:25:22) (MADE-FROM NIL 167 130 57 78) (SPLINES ((2 ((14 0) (14 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((14 8) (24 13) (32 26) (32 42)) NIL ((10. 3.0666666 0 0 0 11.599998 ) (10. 8.8666668 0 11.599998 -12. -9.9999981 ) (4. 15.466665 -12. 1.5999999 12. -1.5999999 )) NATURAL) (2 ((32 42) (32 269)) NIL ((0 227. 0 0 0 0 )) NATURAL) (5 ((32 269) (31 276) (29 283) (22 290) (9 292)) NIL ((-0.982142807 7.0892849 0 0 -0.107142925 -0.535714150 ) (-1.03571415 6.8214283 -0.107142925 -0.535714150 -5.4642849 2.67857075 ) (-3.875 7.625 -5.5714283 2.1428566 -2.03571415 -10.1785698 ) (-10.4642849 4.67857075 -7.60714245 -8.0357132 7.60714245 8.0357132 )) NATURAL) (2 ((9 292) (9 300)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((9 300) (114 300)) NIL ((105. 0 0 0 0 0 )) NATURAL) (2 ((114 300) (114 42)) NIL ((0 -258. 0 0 0 0 )) NATURAL) (4 ((114 42) (114 26) (122 13) (132 8)) NIL ((-2. -16.266666 0 0 12. 1.60000038 ) (4. -15.466665 12. 1.60000038 -12. 9.9999981 ) (10. -8.8666649 0 11.599998 0 -11.599998 )) NATURAL) (2 ((132 8) (132 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((132 0) (14 0)) NIL ((-118. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 155Q) (FACE M R R) (WIDTH 378 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:35:30) (MADE-FROM NIL 88 130 86 90) (SPLINES ((2 ((112 179) (112 205)) NIL ((0 26. 0 0 0 0 )) NATURAL) (2 ((112 205) (14 205)) NIL ((-98. 0 0 0 0 0 )) NATURAL) (3 ((14 205) (14 205) (14 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL) (4 ((14 197) (24 192) (30 179) (31 163)) NIL ((10.7333316 -3.0666666 0 0 -4.39999962 -11.599998 ) (8.5333328 -8.8666668 -4.39999962 -11.599998 -2. 9.9999981 ) (3.1333332 -15.466665 -6.3999996 -1.5999999 6.3999996 1.5999999 )) NATURAL) (2 ((31 163) (31 42)) NIL ((0 -121. 0 0 0 0 )) NATURAL) (4 ((31 42) (31 26) (27 13) (17 8)) NIL ((0.666666627 -16.266666 0 0 -4. 1.60000038 ) (-1.33333325 -15.466665 -4. 1.60000038 -4. 9.9999981 ) (-7.333333 -8.8666649 -8. 11.599998 8. -11.599998 )) NATURAL) (2 ((17 8) (17 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((17 0) (125 0)) NIL ((108. 0 0 0 0 0 )) NATURAL) (2 ((125 0) (125 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((125 8) (117 13) (113 26) (113 42)) NIL ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 ) (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 ) (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 )) NATURAL) (2 ((113 42) (113 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((113 142) (115 157) (124 168) (139 170) (146 159) (147 142)) NIL ((0.679425836 15.645931 0 0 7.92344475 -3.87559795 ) (4.64114857 13.7081337 7.92344475 -3.87559795 2.38277435 -4.62201023 ) (13.755979 7.52153016 10.306219 -8.49760819 -23.454544 -7.63636017 ) (12.3349266 -4.79425907 -13.1483249 -16.133968 7.43540669 11.167461 ) (2.90430593 -15.344497 -5.71291828 -4.96650696 5.71291828 4.96650696 )) NATURAL) (2 ((147 142) (147 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((147 42) (147 26) (143 13) (135 8)) NIL ((0.799999953 -16.266666 0 0 -4.80000019 1.60000038 ) (-1.5999999 -15.466665 -4.80000019 1.60000038 9.53674316E-7 9.9999981 ) (-6.3999996 -8.8666649 -4.79999924 11.599998 4.79999924 -11.599998 )) NATURAL) (2 ((135 8) (135 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((135 0) (241 0)) NIL ((106. 0 0 0 0 0 )) NATURAL) (2 ((241 0) (241 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((241 8) (233 13) (229 26) (229 42)) NIL ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 ) (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 ) (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 )) NATURAL) (2 ((229 42) (229 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((229 142) (231 157) (240 168) (255 170) (262 159) (263 142)) NIL ((0.679425836 15.645931 0 0 7.92344475 -3.87559795 ) (4.64114857 13.7081337 7.92344475 -3.87559795 2.38277435 -4.62201023 ) (13.755979 7.52153016 10.306219 -8.49760819 -23.454544 -7.63636017 ) (12.3349266 -4.79425907 -13.1483249 -16.133968 7.43540669 11.167461 ) (2.90430593 -15.344497 -5.71291828 -4.96650696 5.71291828 4.96650696 )) NATURAL) (2 ((263 142) (263 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((263 42) (263 26) (259 13) (251 8)) NIL ((0.799999953 -16.266666 0 0 -4.80000019 1.60000038 ) (-1.5999999 -15.466665 -4.80000019 1.60000038 9.53674316E-7 9.9999981 ) (-6.3999996 -8.8666649 -4.79999924 11.599998 4.79999924 -11.599998 )) NATURAL) (2 ((251 8) (251 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((251 0) (363 0)) NIL ((112. 0 0 0 0 0 )) NATURAL) (2 ((363 0) (363 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((363 8) (355 13) (351 26) (351 42)) NIL ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 ) (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 ) (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 )) NATURAL) (2 ((351 42) (351 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (9 ((351 142) (349 162) (343 179) (329 197) (308 208) (283 209) (261 202) (242 190) (225 175)) NIL ((-1.39175248 20.968242 0 0 -3.64948463 -5.8094616 ) (-3.21649456 18.0635109 -3.64948463 -5.8094616 -5.75257683 11.0473098 ) (-9.7422676 17.777706 -9.40206147 5.23784924 2.65979385 -14.379783 ) (-17.81443 15.82566 -6.7422676 -9.14193536 1.11340236 -1.52816772 ) (-24. 5.91964245 -5.62886524 -10.670103 10.8865966 2.49245453 ) (-24.185565 -3.50423479 5.25773144 -8.17764855 -2.6597929 3.55835629 ) (-20.257728 -9.90270616 2.59793854 -4.61929226 -0.247423649 1.27411556 ) (-17.783504 -13.884941 2.35051489 -3.3451767 -2.35051489 3.3451767 )) NATURAL) (6 ((225 175) (205 200) (179 209) (153 206) (129 194) (112 179)) NIL ((-18.397129 28.583728 0 0 -9.61722375 -21.502391 ) (-23.205741 17.832534 -9.61722375 -21.502391 12.086122 11.5119629 ) (-26.779903 2.08612347 2.46889925 -9.9904289 -2.72727251 -0.545455933 ) (-25.67464 -8.17703248 -0.258373320 -10.5358848 10.8229656 8.6698551 ) (-20.52153 -14.3779888 10.564592 -1.86602878 -10.564592 1.86602878 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/TIMESROMAN.LC2-SF b/lispusers/TIMESROMAN.LC2-SF new file mode 100644 index 00000000..1f75fd04 --- /dev/null +++ b/lispusers/TIMESROMAN.LC2-SF @@ -0,0 +1 @@ + ((FAMILY TIMESROMAND) (CHARACTER 156Q) (FACE M R R) (WIDTH 259 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:57:27) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 205) (112 183)) NIL ((0 -22. 0 0 0 0 )) NATURAL) (8 ((112 183) (130 196) (152 207) (176 212) (198 208) (217 196) (231 169) (235 142)) NIL ((17.098247 13.2576427 0 0 5.41051197 -1.54586053 ) (19.803501 12.484712 5.41051197 -1.54586053 -3.05255985 -4.27069664 ) (23.687732 8.80350305 2.35795212 -5.81655789 -5.2002735 -5.37134838 ) (23.445549 0.301270485 -2.84232187 -11.187906 -0.146341800 7.75609589 ) (20.530056 -7.0085888 -2.98866367 -3.43181038 -0.214358806 -19.653034 ) (17.434211 -20.266918 -3.20302248 -23.084846 -10.9962196 28.856056 ) (8.7330799 -28.923736 -14.199243 5.77121258 14.199243 -5.77121258 )) NATURAL) (2 ((235 142) (235 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((235 42) (235 26) (239 13) (247 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((247 8) (247 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((247 0) (135 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((135 0) (135 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((135 8) (143 13) (147 26) (147 42)) NIL ((8.79999925 3.0666666 0 0 -4.80000019 11.599998 ) (6.3999996 8.8666668 -4.80000019 11.599998 9.53674316E-7 -9.9999981 ) (1.59999966 15.466665 -4.79999924 1.5999999 4.79999924 -1.5999999 )) NATURAL) (2 ((147 42) (147 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((147 142) (146 159) (139 170) (124 168) (115 157) (113 142)) NIL ((-0.0478469506 17.827751 0 0 -5.71291828 -4.9665079 ) (-2.90430641 15.3444957 -5.71291828 -4.9665079 -7.43540669 -11.167459 ) (-12.3349266 4.79425717 -13.1483249 -16.133968 23.454544 7.63636208 ) (-13.755979 -7.5215311 10.306219 -8.49760629 -2.38277435 4.62200833 ) (-4.6411476 -13.7081337 7.92344475 -3.87559795 -7.92344475 3.87559795 )) NATURAL) (2 ((113 142) (113 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((113 42) (113 26) (117 13) (125 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((125 8) (125 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((125 0) (17 0)) NIL ((-108. 0 0 0 0 0 )) NATURAL) (2 ((17 0) (17 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((17 8) (27 13) (31 26) (31 42)) NIL ((11.333332 3.0666666 0 0 -8. 11.599998 ) (7.333333 8.8666668 -8. 11.599998 4. -9.9999981 ) (1.33333325 15.466665 -4. 1.5999999 4. -1.5999999 )) NATURAL) (2 ((31 42) (31 174)) NIL ((0 132. 0 0 0 0 )) NATURAL) (4 ((31 174) (29 188) (23 196) (12 197)) NIL ((-1.26666665 15.133333 0 0 -4.39999962 -6.8000002 ) (-3.4666667 11.7333316 -4.39999962 -6.8000002 -2. -1.99999904 ) (-8.8666668 3.93333292 -6.3999996 -8.79999925 6.3999996 8.79999925 )) NATURAL) (2 ((12 197) (12 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 205) (112 205)) NIL ((100. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 157Q) (FACE M R R) (WIDTH 235 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:02:40) (MADE-FROM NIL 109 130 57 78) (SPLINES ((21 ((118 187) (130 178) (136 158) (138 141) (139 122) (140 98) (139 74) (138 55) (136 38) (130 18) (118 9) (106 18) (100 38) (98 55) (97 74) (96 98) (97 122) (98 141) (100 158) (106 178) (118 187)) NIL ((13.420864 0.182411194 -0.271320581 -20.803161 -7.71122647 7.3150177 ) (9.29393006 -16.963241 -7.98254777 -13.4881439 4.184062 22.243881 ) (3.4034133 -19.329444 -3.79848528 8.7557373 2.97497558 -12.2905426 ) (1.09241581 -16.718975 -0.823509694 -3.5348053 1.91603374 -3.08171177 ) (1.22692299 -21.794639 1.09252405 -6.61651707 -4.63911057 6.61738969 ) (-1.08202453E-4 -25.102458 -3.54658651 8.72911885E-4 4.64040852 6.6121521 ) (-1.22649026 -21.795509 1.09382224 6.61302567 -1.92252469 -3.06600189 ) (-1.09393048 -16.715484 -0.828702450 3.54702377 -2.95030975 -12.348144 ) (-3.39778805 -19.342533 -3.7790122 -8.80112077 -4.27623368 22.45858 ) (-9.3149166 -16.9143638 -8.05524636 13.657459 8.05524636 6.5138092 ) (-13.3425407 3.20374965E-7 0 20.171268 8.05524636 -6.5138073 ) (-9.3149166 16.9143638 8.05524636 13.657461 -4.27623368 -22.45858 ) (-3.39778757 19.342533 3.77901268 -8.80112077 -2.95031023 12.3481426 ) (-1.09393024 16.715484 0.828702331 3.5470233 -1.92252445 3.06600237 ) (-1.22649026 21.795509 -1.09382224 6.61302567 4.64040852 -6.6121521 ) (-1.08162406E-4 25.102458 3.54658651 8.72911885E-4 -4.63911057 -6.61738969 ) (1.22692299 21.794639 -1.09252405 -6.61651707 1.91603374 3.08171272 ) (1.09241581 16.7189789 0.823509694 -3.53480434 2.97497558 12.2905388 ) (3.4034133 19.329444 3.79848528 8.7557354 4.18406296 -22.243877 ) (9.29393006 16.963237 7.9825487 -13.488142 -7.71122838 -7.3150158 )) PSEUDOCYCLIC)) ((25 ((118 205) (148 202) (173 194) (195 179) (213 155) (222 131) (225 98) (222 65) (213 41) (195 17) (173 2) (148 -6) (118 -9) (88 -6) (63 2) (41 17) (23 41) (14 65) (11 98) (14 131) (23 155) (41 179) (63 194) (88 202) (118 205)) NIL ((31.161361 -1.97820449 0 0 -6.9681711 -6.1307726 ) (27.677272 -5.04359055 -6.9681711 -6.1307726 4.8408575 0.653862953 ) (23.129531 -10.847431 -2.12731314 -5.47690964 -0.395261765 -8.48467637 ) (20.804588 -20.56668 -2.5225749 -13.961586 -9.2598076 21.284843 ) (13.652109 -23.885841 -11.7823829 7.32325936 7.434494 -22.654708 ) (5.58697129 -27.889938 -4.34788895 -15.331449 -2.47816563 15.333984 ) (-1.59256160E-7 -35.55439 -6.82605458 0.00253645284 2.47816467 15.318765 ) (-5.58697224 -27.892475 -4.3478899 15.321302 -7.43449307 -22.609054 ) (-13.652109 -23.875698 -11.7823829 -7.28775216 9.2598076 21.117458 ) (-20.804588 -20.604721 -2.52257538 13.829706 0.395262241 -7.86078168 ) (-23.129531 -10.705406 -2.12731314 5.96892452 -4.8408575 -1.67433166 ) (-27.677272 -5.5736475 -6.9681711 4.29459286 6.9681711 2.55811024 ) (-31.161361 1.59256160E-7 0 6.8527031 6.9681711 -2.55811024 ) (-27.677272 5.57364846 6.9681711 4.29459286 -4.84085846 1.67433071 ) (-23.129531 10.705406 2.12731266 5.96892357 0.395262718 7.8607826 ) (-20.804588 20.604721 2.52257538 13.829706 9.2598076 -21.117458 ) (-13.652109 23.875698 11.7823829 -7.28775216 -7.43449307 22.609054 ) (-5.58697224 27.892475 4.3478899 15.321304 2.47816467 -15.318767 ) (1.59256160E-7 35.55439 6.82605458 0.00253645284 -2.47816467 -15.333984 ) (5.58697224 27.889938 4.3478899 -15.331449 7.43449307 22.654708 ) (13.652109 23.885841 11.7823829 7.32325936 -9.2598076 -21.284847 ) (20.804588 20.56668 2.52257538 -13.9615879 -0.395262241 8.48467828 ) (23.129531 10.847431 2.12731314 -5.47690964 4.8408575 -0.653862000 ) (27.677272 5.04359055 6.9681711 -6.13077164 -6.9681711 6.13077164 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 160Q) (FACE M R R) (WIDTH 252 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:10:37) (MADE-FROM NIL 119 130 57 78) (SPLINES ((5 ((138 -62) (129 -60) (121 -55) (117 -45) (115 -28)) NIL ((-9.0178566 1.42857146 0 0 0.107142925 3.42857122 ) (-8.9642849 3.14285708 0.107142925 3.42857122 5.4642849 0.857142926 ) (-6.12499905 7. 5.5714283 4.28571415 -3.96428537 5.14285565 ) (-2.53571415 13.857143 1.60714292 9.4285698 -1.60714292 -9.4285698 )) NATURAL) (2 ((115 -28) (115 18)) NIL ((0 46. 0 0 0 0 )) NATURAL) (15 ((115 18) (141 2) (171 -5) (198 5) (220 25) (233 53) (239 89) (239 121) (233 152) (219 180) (202 199) (179 209) (155 208) (134 198) (115 180)) NIL ((24.77045 -17.354595 0 0 7.37729645 8.12758447 ) (28.459098 -13.2908039 7.37729645 8.12758447 -12.886484 13.3620777 ) (29.39315 1.51781845 -5.5091877 21.489662 2.16864204 -13.575897 ) (24.968284 16.219532 -3.34054565 7.913764 -7.7880821 -1.05849075 ) (17.733696 23.604049 -11.1286277 6.85527325 4.9836874 5.8098688 ) (9.0969143 33.364257 -6.14494038 12.665142 -0.146670341 -22.180988 ) (2.87863922 34.938903 -6.2916107 -9.51584817 1.60299492 10.9141025 ) (-2.61147404 30.880107 -4.6886158 1.39825439 -6.26530839 -3.47542334 ) (-10.4327449 30.540649 -10.953924 -2.07716894 11.458244 -9.0124092 ) (-15.657547 23.957275 0.504320979 -11.0895786 -9.56767846 3.52506352 ) (-19.937065 14.6302318 -9.0633583 -7.5645151 8.8124714 -5.0878458 ) (-24.594184 4.5217924 -0.250885904 -12.6523609 4.31778717 4.8263235 ) (-22.686176 -5.7174053 4.06690216 -7.8260374 -2.0836277 -2.21745205 ) (-19.66109 -14.65217 1.98327422 -10.043489 -1.98327422 10.043489 )) NATURAL) (2 ((115 180) (115 208)) NIL ((0 28. 0 0 0 0 )) NATURAL) (2 ((115 208) (12 195)) NIL ((-103. -13. 0 0 0 0 )) NATURAL) (2 ((12 195) (12 187)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (5 ((12 187) (22 182) (28 176) (32 166) (33 152)) NIL ((10.982141 -4.9464283 0 0 -5.8928566 -0.321428776 ) (8.0357132 -5.10714245 -5.8928566 -0.321428776 5.4642849 -4.39285565 ) (4.87499905 -7.625 -0.428571522 -4.7142849 -3.9642849 -0.107143402 ) (2.46428537 -12.392856 -4.3928566 -4.8214283 4.3928566 4.8214283 )) NATURAL) (3 ((33 152) (33 152) (33 -28)) NIL ((0 45. 0 0 0 -270. ) (0 -90. 0 -270. 0 270. )) NATURAL) (5 ((33 -28) (32 -42) (29 -54) (22 -60) (13 -62)) NIL ((-0.714285612 -14.1785698 0 0 -1.71428585 1.07142877 ) (-1.57142853 -13.642856 -1.71428585 1.07142877 -3.42857075 6.64285565 ) (-5. -9.2499981 -5.1428566 7.7142849 3.42857075 -3.6428566 ) (-8.4285698 -3.35714245 -1.71428561 4.0714283 1.71428561 -4.0714283 )) NATURAL) (2 ((13 -62) (13 -70)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((13 -70) (138 -70)) NIL ((125. 0 0 0 0 0 )) NATURAL) (2 ((138 -70) (138 -62)) NIL ((0 8. 0 0 0 0 )) NATURAL)) ((3 ((115 58) (115 58) (115 138)) NIL ((0 -20. 0 0 0 120. ) (0 40. 0 120. 0 -120. )) NATURAL) (12 ((115 138) (117 155) (124 168) (137 169) (148 150) (152 121) (153 86) (150 60) (144 38) (129 29) (117 43) (115 58)) NIL ((1.09614515 17.554847 0 0 5.42312908 -3.32910729 ) (3.80770969 15.8902969 5.42312908 -3.32910729 2.88435459 -7.35446358 ) (10.6730156 8.8839569 8.30748368 -10.6835708 -10.960546 -15.253032 ) (13.500225 -9.4261303 -2.65306425 -25.936603 -7.04216004 20.366596 ) (7.3260803 -25.179435 -9.69522477 -5.5700054 9.12919045 -6.21336556 ) (2.19545078 -33.856124 -0.566033244 -11.7833709 -5.4746065 28.486862 ) (-1.10788536 -31.39606 -6.04063988 16.703491 6.7692318 -17.7340889 ) (-3.76390886 -23.559616 0.728592634 -1.03060031 -15.602321 12.4495067 ) (-10.836477 -18.365459 -14.873729 11.418907 19.640056 21.93605 ) (-15.890178 4.02147007 4.76632786 33.354957 9.04208947 -40.193695 ) (-6.6028061 17.279579 13.808418 -6.8387394 -13.808418 6.8387394 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 161Q) (FACE M R R) (WIDTH 253 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:20:18) (MADE-FROM NIL 73 130 57 78) (SPLINES ((5 ((244 -62) (235 -60) (227 -55) (223 -45) (221 -28)) NIL ((-9.0178566 1.42857146 0 0 0.107142925 3.42857122 ) (-8.9642849 3.14285708 0.107142925 3.42857122 5.4642849 0.857142926 ) (-6.12499905 7. 5.5714283 4.28571415 -3.96428537 5.14285565 ) (-2.53571415 13.857143 1.60714292 9.4285698 -1.60714292 -9.4285698 )) NATURAL) (2 ((221 -28) (221 213)) NIL ((0 241. 0 0 0 0 )) NATURAL) (2 ((221 213) (214 213)) NIL ((-7. 0 0 0 0 0 )) NATURAL) (2 ((214 213) (184 184)) NIL ((-30. -29. 0 0 0 0 )) NATURAL) (16 ((184 184) (167 199) (140 211) (104 214) (65 204) (43 189) (27 168) (16 142) (11 101) (14 71) (24 40) (41 17) (61 4) (86 -1) (114 8) (139 30)) NIL ((-14.8281898 15.390228 0 0 -13.030853 -2.34137916 ) (-21.343616 14.219539 -13.030853 -2.34137916 5.15427208 -6.29310418 ) (-31.797332 8.73160745 -7.8765812 -8.63448335 -1.58623886 -8.48620225 ) (-40.467033 -4.14597798 -9.46282006 -17.120685 37.19068 16.237926 ) (-31.33451 -13.147699 27.727863 -0.882758380 -27.176502 -8.46551896 ) (-17.1949 -18.2632179 0.551357627 -9.34827806 5.5153446 11.624151 ) (-13.8858719 -21.799419 6.06670285 2.27587318 -0.884872437 -32.031082 ) (-8.2616043 -35.539085 5.1818304 -29.75521 4.02414227 56.500183 ) (-1.06770372 -37.044204 9.20597268 26.744976 -3.21169567 -37.969665 ) (6.5324211 -29.284065 5.994277 -11.224693 2.82264042 23.378486 ) (13.9380188 -28.819515 8.8169174 12.153795 -8.07886506 -1.54428863 ) (18.715499 -17.437862 0.738050580 10.6095066 5.4928274 -5.20133877 ) (22.199966 -9.42902566 6.23087884 5.40816784 -1.89244747 10.349649 ) (27.484622 1.15396976 4.33843136 15.757818 -9.92303849 -0.197273254 ) (26.861534 16.813148 -5.58460713 15.5605449 5.58460713 -15.5605449 )) NATURAL) (2 ((139 30) (139 -28)) NIL ((0 -58. 0 0 0 0 )) NATURAL) (5 ((139 -28) (138 -42) (135 -54) (128 -60) (119 -62)) NIL ((-0.714285612 -14.1785698 0 0 -1.71428585 1.07142877 ) (-1.57142853 -13.642856 -1.71428585 1.07142877 -3.42857075 6.64285565 ) (-5. -9.2499981 -5.1428566 7.7142849 3.42857075 -3.6428566 ) (-8.4285698 -3.35714245 -1.71428561 4.0714283 1.71428561 -4.0714283 )) NATURAL) (2 ((119 -62) (119 -70)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((119 -70) (244 -70)) NIL ((125. 0 0 0 0 0 )) NATURAL) (2 ((244 -70) (244 -62)) NIL ((0 8. 0 0 0 0 )) NATURAL)) ((14 ((137 120) (137 84) (133 49) (120 35) (109 38) (101 56) (97 87) (96 120) (98 156) (104 185) (118 195) (130 184) (136 154) (137 120)) NIL ((0.397950232 -35.027526 0 0 -2.38770151 -5.83479405 ) (-0.795900465 -37.94493 -2.38770151 -5.83479405 -12.061491 35.173965 ) (-9.21434785 -26.192737 -14.4491939 29.339176 20.63367 -14.861099 ) (-13.346704 -4.28410912 6.1844778 14.4780769 -4.47319508 0.270425796 ) (-9.3988247 10.3291797 1.71128201 14.7485027 3.25911093 1.77940941 ) (-6.0579872 25.967388 4.97039318 16.527912 -2.56325197 -19.388069 ) (-2.36922026 32.801261 2.40714121 -2.86015797 0.993899346 9.77287675 ) (0.534870506 34.827545 3.40104055 6.91271878 -1.41234493 -13.703434 ) (3.22973871 34.888542 1.98869562 -6.7907152 10.655479 -14.9591388 ) (10.546175 20.618259 12.644176 -21.749855 -17.209579 1.5399971 ) (14.5855598 -0.361596405 -4.56540394 -20.209857 -1.81715488 -3.20084763 ) (9.111578 -22.171875 -6.38255883 -23.410705 0.478199005 23.263381 ) (2.96811962 -33.950889 -5.9043598 -0.147323548 5.9043598 0.147323548 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 162Q) (FACE M R R) (WIDTH 200 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:25:39) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 205) (112 176)) NIL ((0 -29. 0 0 0 0 )) NATURAL) (10 ((112 176) (136 200) (161 210) (183 200) (188 180) (174 159) (147 157) (132 168) (117 158) (113 142)) NIL ((23.768428 26.483066 0 0 1.38941908 -14.8984089 ) (24.463138 19.033863 1.38941908 -14.8984089 -0.947096229 -9.50795175 ) (25.379009 -0.618523598 0.442322791 -24.40636 -21.601032 16.930221 ) (15.0208149 -16.559772 -21.15871 -7.47613717 3.35123825 1.78705024 ) (-4.46227646 -23.142383 -17.807472 -5.6890869 -3.80392075 29.921569 ) (-24.17171 -13.870685 -21.611393 24.232482 47.86444 -1.47332763 ) (-21.850879 9.6251316 26.253051 22.759155 -37.653862 -60.028259 ) (-14.4247627 2.37015486 -11.400814 -37.269104 30.751018 37.58638 ) (-10.4500675 -16.105758 19.350204 0.317277312 -19.350204 -0.317277312 )) NATURAL) (2 ((113 142) (113 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (5 ((113 42) (114 31) (117 19) (124 12) (133 8)) NIL ((0.714285612 -10.4285698 0 0 1.71428585 -3.42857122 ) (1.57142853 -12.1428566 1.71428585 -3.42857122 3.42857075 11.1428547 ) (5. -9.9999981 5.1428566 7.7142849 -3.42857075 -5.1428566 ) (8.4285698 -4.85714245 1.71428561 2.5714283 -1.71428561 -2.5714283 )) NATURAL) (2 ((133 8) (133 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((133 0) (12 0)) NIL ((-121. 0 0 0 0 0 )) NATURAL) (2 ((12 0) (12 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((12 8) (22 10) (29 17) (31 31)) NIL ((10.466665 1.13333320 0 0 -2.80000019 5.1999998 ) (9.06666566 3.73333359 -2.80000019 5.1999998 -3.99999905 3.99999905 ) (4.2666664 10.933332 -6.79999924 9.19999887 6.79999924 -9.19999887 )) NATURAL) (2 ((31 31) (31 174)) NIL ((0 143. 0 0 0 0 )) NATURAL) (4 ((31 174) (29 188) (23 195) (12 197)) NIL ((-1.26666665 15.5333328 0 0 -4.39999962 -9.19999887 ) (-3.4666667 10.933332 -4.39999962 -9.19999887 -2. 3.99999905 ) (-8.8666668 3.7333331 -6.3999996 -5.1999998 6.3999996 5.1999998 )) NATURAL) (2 ((12 197) (12 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 205) (112 205)) NIL ((100. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 163Q) (FACE M R R) (WIDTH 178 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:38:38) (MADE-FROM NIL 130 130 0 0) (SPLINES ((3 ((135 148) (135 148) (150 148)) NIL ((-3.75 0 0 0 22.5 0 ) (7.5 0 22.5 0 -22.5 0 )) NATURAL) (2 ((150 148) (150 206)) NIL ((0 58. 0 0 0 0 )) NATURAL) (2 ((150 206) (139 206)) NIL ((-11. 0 0 0 0 0 )) NATURAL) (2 ((139 206) (133 198)) NIL ((-6. -8. 0 0 0 0 )) NATURAL) (16 ((133 198) (116 204) (91 208) (62 206) (39 196) (24 178) (15 151) (19 126) (34 101) (55 84) (76 66) (91 43) (82 22) (59 24) (45 37) (32 62)) NIL ((-15.2221908 6.23116494 0 0 -10.666851 -1.38699484 ) (-20.555614 5.53766823 -10.666851 -1.38699484 5.3342552 -5.06502533 ) (-28.555339 1.61816025 -5.33259583 -6.45202065 13.329832 -2.35289955 ) (-27.223018 -6.01031018 7.99723626 -8.8049202 1.34641075 2.47662639 ) (-18.5525779 -13.576917 9.343647 -6.3282938 -6.71547127 -7.5536108 ) (-12.5666656 -23.682014 2.62817573 -13.881904 13.51547 21.737819 ) (-3.18075228 -26.69501 16.143646 7.855916 -5.3464241 -13.397676 ) (10.289682 -25.537933 10.797222 -5.54176045 -4.12976265 19.852882 ) (19.022022 -21.153247 6.66745949 14.3111248 -8.13452149 -18.013862 ) (21.622219 -15.849058 -1.46706223 -3.70274019 0.667852164 -1.79742288 ) (20.489082 -20.450508 -0.799210072 -5.50016308 -30.53688 1.20355701 ) (4.42143154 -25.348892 -31.336093 -4.29660607 13.47969 38.983184 ) (-20.174816 -10.1539 -17.856403 34.686584 36.618103 -31.13634 ) (-19.72216 8.96451188 18.761703 3.55024195 -21.952129 13.5621948 ) (-11.936523 19.295852 -3.19042635 17.112438 3.19042635 -17.112438 )) NATURAL) (2 ((32 62) (19 62)) NIL ((-13. 0 0 0 0 0 )) NATURAL) (3 ((19 62) (19 62) (19 -1)) NIL ((0 15.75 0 0 0 -94.5 ) (0 -31.5 0 -94.5 0 94.5 )) NATURAL) (2 ((19 -1) (29 -1)) NIL ((10. 0 0 0 0 0 )) NATURAL) (2 ((29 -1) (33 7)) NIL ((4. 8. 0 0 0 0 )) NATURAL) (15 ((33 7) (50 3) (76 -3) (106 -4) (138 7) (162 34) (166 68) (153 99) (127 124) (98 147) (85 166) (93 185) (114 184) (126 172) (135 148)) NIL ((14.8183899 -3.26369524 0 0 13.089653 -4.4178276 ) (21.363216 -5.47260952 13.089653 -4.4178276 -11.4482708 10.0891399 ) (28.728733 -4.84586716 1.64138222 5.67131233 2.70343399 6.06126595 ) (31.721836 3.8560791 4.3448162 11.732578 -11.365465 7.66579056 ) (30.383918 19.42155 -7.02064896 19.398368 -17.241565 -12.72442 ) (14.742483 32.45771 -24.262214 6.67394734 8.3317375 -10.768106 ) (-5.35386276 33.747596 -15.930477 -4.09416008 1.91460991 -4.20314217 ) (-20.327034 27.551868 -14.015867 -8.29730226 8.0098133 9.5806732 ) (-30.337993 24.044906 -6.00605298 1.2833724 26.04613 -10.119556 ) (-23.32098 20.268497 20.040081 -8.83618547 1.80563736 18.897556 ) (-2.37807894 20.881092 21.845718 10.0613708 -3.26868057 -41.470665 ) (17.833297 10.2071285 18.577037 -31.409294 -36.73091 26.985103 ) (18.0448799 -7.7096119 -18.153877 -4.42418766 18.192344 -12.4697628 ) (8.987175 -18.368682 0.0384698063 -16.893951 -0.0384698063 16.893951 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 164Q) (FACE M R R) (WIDTH 173 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:42:46) (MADE-FROM NIL 141 130 57 78) (SPLINES ((3 ((121 205) (121 205) (155 205)) NIL ((-8.5 0 0 0 51. 0 ) (17. 0 51. 0 -51. 0 )) NATURAL) (2 ((155 205) (155 181)) NIL ((0 -24. 0 0 0 0 )) NATURAL) (3 ((155 181) (121 181) (121 181)) NIL ((-42.5 0 0 0 51. 0 ) (-17. 0 51. 0 -51. 0 )) NATURAL) (2 ((121 181) (121 51)) NIL ((0 -130. 0 0 0 0 )) NATURAL) (5 ((121 51) (122 36) (130 28) (145 30) (153 38)) NIL ((-0.250000000 -16.267856 0 0 7.5 7.60714245 ) (3.5 -12.4642849 7.5 7.60714245 4.4999981 3.96428585 ) (13.25 -2.87499952 11.999998 11.571428 -25.499996 -5.46428585 ) (12.499998 5.96428585 -13.499998 6.10714245 13.499998 -6.10714245 )) NATURAL) (2 ((153 38) (162 25)) NIL ((9. -13. 0 0 0 0 )) NATURAL) (7 ((162 25) (147 10) (123 -2) (89 -5) (63 3) (44 24) (39 51)) NIL ((-13.442306 -15.310255 0 0 -9.34615327 1.86153841 ) (-18.115383 -14.379486 -9.34615327 1.86153841 -7.2692299 8.6923065 ) (-31.096153 -8.17179299 -16.615383 10.553846 32.423072 -0.630771637 ) (-31.499996 2.06666708 15.807689 9.9230747 -14.4230728 5.8307724 ) (-22.903842 14.905126 1.38461566 15.753847 19.269226 -10.692308 ) (-11.884613 25.31282 20.653842 5.06153775 -20.653842 -5.06153775 )) NATURAL) (2 ((39 51) (39 181)) NIL ((0 130. 0 0 0 0 )) NATURAL) (2 ((39 181) (20 181)) NIL ((-19. 0 0 0 0 0 )) NATURAL) (2 ((20 181) (20 196)) NIL ((0 15. 0 0 0 0 )) NATURAL) (5 ((20 196) (49 209) (71 227) (89 246) (106 272)) NIL ((30.607139 11.607141 0 0 -9.6428566 8.3571415 ) (25.785713 15.785713 -9.6428566 8.3571415 6.2142849 -11.785711 ) (19.249996 18.25 -3.42857122 -3.42857075 2.78571415 14.785711 ) (17.214283 22.214283 -0.642857075 11.357141 0.642857075 -11.357141 )) NATURAL) (2 ((106 272) (121 272)) NIL ((15. 0 0 0 0 0 )) NATURAL) (2 ((121 272) (121 205)) NIL ((0 -67. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 165Q) (FACE M R R) (WIDTH 249 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:49:10) (MADE-FROM NIL 94 130 57 78) (SPLINES ((3 ((124 205) (124 205) (222 205)) NIL ((-24.5 0 0 0 147. 0 ) (49. 0 147. 0 -147. 0 )) NATURAL) (2 ((222 205) (222 35)) NIL ((0 -170. 0 0 0 0 )) NATURAL) (5 ((222 35) (222 27) (226 16) (232 11) (238 8)) NIL ((-0.928571344 -6.80357075 0 0 5.5714283 -7.17857075 ) (1.85714292 -10.3928566 5.5714283 -7.17857075 -3.85714245 17.892852 ) (5.5 -8.6249981 1.71428561 10.7142849 -2.1428566 -10.3928547 ) (6.1428566 -3.10714245 -0.428571403 0.321428537 0.428571403 -0.321428537 )) NATURAL) (2 ((238 8) (238 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((238 0) (141 0)) NIL ((-97. 0 0 0 0 0 )) NATURAL) (2 ((141 0) (141 22)) NIL ((0 22. 0 0 0 0 )) NATURAL) (8 ((141 22) (129 10) (110 -3) (84 -8) (60 -3) (46 7) (35 25) (30 47)) NIL ((-10.615938 -11.333904 0 0 -8.30436326 -3.99656487 ) (-14.7681198 -13.3321876 -8.30436326 -3.99656487 -0.478183746 13.982824 ) (-23.311576 -10.337339 -8.782547 9.98625947 10.2171039 2.06526756 ) (-26.985569 0.681553364 1.43455767 12.051527 13.609756 -10.2439 ) (-18.746131 7.61112977 15.044315 1.80762577 -16.656131 8.91033937 ) (-12.029886 13.873926 -1.61181712 10.717966 11.0147686 -7.3974571 ) (-8.1343174 20.893161 9.4029522 3.32050848 -9.4029522 -3.32050848 )) NATURAL) (2 ((30 47) (30 167)) NIL ((0 120. 0 0 0 0 )) NATURAL) (5 ((30 167) (28 180) (25 189) (20 194) (13 197)) NIL ((-1.83928561 13.821428 0 0 -0.964285732 -4.92857075 ) (-2.3214283 11.357141 -0.964285732 -4.92857075 -1.17857122 0.642856598 ) (-3.875 6.74999905 -2.14285707 -4.28571415 -0.321428299 2.35714245 ) (-6.17857075 3.64285708 -2.46428537 -1.92857146 2.46428537 1.92857146 )) NATURAL) (2 ((13 197) (13 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((13 205) (109 205)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((109 205) (109 47)) NIL ((0 -158. 0 0 0 0 )) NATURAL) (7 ((109 47) (110 38) (116 30) (126 29) (135 37) (140 51) (141 67)) NIL ((-0.0487179756 -8.91025544 0 0 6.29230786 -0.538461209 ) (3.09743595 -9.1794853 6.29230786 -0.538461209 -1.46153927 8.6923046 ) (8.6589737 -5.37179375 4.83076859 8.15384484 -6.44615269 1.76923179 ) (10.266666 3.6666665 -1.61538458 9.9230766 -2.75384569 -3.76923084 ) (7.27435876 11.7051277 -4.36923027 6.15384579 -0.538461685 -4.69230747 ) (2.63589716 15.512819 -4.90769196 1.46153831 4.90769196 -1.46153831 )) NATURAL) (2 ((141 67) (141 167)) NIL ((0 100. 0 0 0 0 )) NATURAL) (5 ((141 167) (139 180) (136 189) (131 194) (124 197)) NIL ((-1.83928561 13.821428 0 0 -0.964285732 -4.92857075 ) (-2.3214283 11.357141 -0.964285732 -4.92857075 -1.17857122 0.642856598 ) (-3.875 6.74999905 -2.14285707 -4.28571415 -0.321428299 2.35714245 ) (-6.17857075 3.64285708 -2.46428537 -1.92857146 2.46428537 1.92857146 )) NATURAL) (2 ((124 197) (124 205)) NIL ((0 8. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 166Q) (FACE M R R) (WIDTH 215 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:54:35) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((138 205) (138 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((138 197) (147 192) (154 182) (157 168)) NIL ((9.2666664 -3.9333334 0 0 -1.60000014 -6.3999996 ) (8.46666528 -7.1333332 -1.60000014 -6.3999996 -3.99999905 2. ) (4.86666584 -12.5333328 -5.59999943 -4.39999962 5.59999943 4.39999962 )) NATURAL) (3 ((157 168) (154 154) (139 96)) NIL ((0 -3. 0 0 -18. -66. ) (-9. -36. -18. -66. 18. 66. )) NATURAL) (5 ((139 96) (118 163) (112 182) (115 192) (121 197)) NIL ((-24.428569 79.303558 0 0 20.571426 -73.821426 ) (-14.1428547 42.392852 20.571426 -73.821426 -12.857141 81.10713 ) (3.18512320E-7 9.125 7.7142849 7.2857132 -5.1428566 -16.607139 ) (5.1428566 8.1071415 2.5714283 -9.3214264 -2.5714283 9.3214264 )) NATURAL) (2 ((121 197) (121 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((121 205) (11 205)) NIL ((-110. 0 0 0 0 0 )) NATURAL) (3 ((11 205) (11 205) (11 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL) (4 ((11 197) (19 192) (26 182) (32 167)) NIL ((8.19999887 -4. 0 0 -1.20000004 -6. ) (7.59999943 -7. -1.20000004 -6. 2.38418579E-7 0 ) (6.3999996 -13. -1.19999981 -6. 1.19999981 6. )) NATURAL) (3 ((32 167) (32 167) (93 0)) NIL ((-15.25 41.75 0 0 91.5 -250.5 ) (30.5 -83.5 91.5 -250.5 -91.5 250.5 )) NATURAL) (2 ((93 0) (138 0)) NIL ((45. 0 0 0 0 0 )) NATURAL) (2 ((138 0) (181 155)) NIL ((43. 155. 0 0 0 0 )) NATURAL) (4 ((181 155) (187 176) (195 189) (202 197)) NIL ((5.3999996 22.799999 0 0 3.5999999 -10.799999 ) (7.1999998 17.399997 3.5999999 -10.799999 -5.99999905 6. ) (7.79999924 9.59999848 -2.39999962 -4.79999924 2.39999962 4.79999924 )) NATURAL) (2 ((202 197) (202 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((202 205) (138 205)) NIL ((-64. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 167Q) (FACE M R R) (WIDTH 335 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:00:50) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((93 0) (137 0)) NIL ((44. 0 0 0 0 0 )) NATURAL) (2 ((137 0) (170 113)) NIL ((33. 113. 0 0 0 0 )) NATURAL) (2 ((170 113) (213 2)) NIL ((43. -111. 0 0 0 0 )) NATURAL) (2 ((213 2) (255 2)) NIL ((42. 0 0 0 0 0 )) NATURAL) (6 ((255 2) (296 153) (299 167) (304 181) (310 190) (321 197)) NIL ((51.330139 187.7942 0 0 -61.980857 -220.7655 ) (20.33971 77.411468 -61.980857 -220.7655 81.904296 281.8276 ) (-0.688994527 -2.44018984 19.923442 61.062194 -25.63636 -84.54544 ) (6.4162674 16.349277 -5.71291828 -23.483249 14.641145 26.35406 ) (8.02392388 6.0430622 8.92822839 2.87081289 -8.92822839 -2.87081289 )) NATURAL) (2 ((321 197) (321 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((321 205) (249 205)) NIL ((-72. 0 0 0 0 0 )) NATURAL) (2 ((249 205) (249 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (5 ((249 197) (258 195) (266 187) (268 174) (267 166)) NIL ((8.8928566 -0.839285613 0 0 0.642857075 -6.96428586 ) (9.2142849 -4.3214283 0.642857075 -6.96428586 -9.2142849 -1.17857074 ) (5.24999905 -11.875 -8.5714283 -8.1428566 6.21428586 17.678569 ) (-0.214285850 -11.1785698 -2.35714245 9.5357132 2.35714245 -9.5357132 )) NATURAL) (2 ((267 166) (252 109)) NIL ((-15. -57. 0 0 0 0 )) NATURAL) (2 ((252 109) (230 176)) NIL ((-22. 67. 0 0 0 0 )) NATURAL) (4 ((230 176) (228 186) (231 196) (238 197)) NIL ((-3.0666666 9.3999996 0 0 6.3999996 3.5999999 ) (0.133333504 11.1999988 6.3999996 3.5999999 -2. -17.999996 ) (5.53333283 5.79999924 4.39999962 -14.399999 -4.39999962 14.399999 )) NATURAL) (2 ((238 197) (238 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((238 205) (132 205)) NIL ((-106. 0 0 0 0 0 )) NATURAL) (2 ((132 205) (132 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((132 197) (140 194) (144 182) (153 150)) NIL ((9.3999996 -1.93333316 0 0 -8.3999996 -6.40000058 ) (5.1999998 -5.1333332 -8.3999996 -6.40000058 17.999996 -21.999996 ) (5.80000019 -22.533332 9.59999848 -28.399997 -9.59999848 28.399997 )) NATURAL) (2 ((153 150) (139 96)) NIL ((-14. -54. 0 0 0 0 )) NATURAL) (5 ((139 96) (118 163) (112 182) (115 192) (121 197)) NIL ((-24.428569 79.303558 0 0 20.571426 -73.821426 ) (-14.1428547 42.392852 20.571426 -73.821426 -12.857141 81.10713 ) (3.18512320E-7 9.125 7.7142849 7.2857132 -5.1428566 -16.607139 ) (5.1428566 8.1071415 2.5714283 -9.3214264 -2.5714283 9.3214264 )) NATURAL) (2 ((121 197) (121 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((121 205) (11 205)) NIL ((-110. 0 0 0 0 0 )) NATURAL) (3 ((11 205) (11 205) (11 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL) (4 ((11 197) (19 192) (26 182) (32 167)) NIL ((8.19999887 -4. 0 0 -1.20000004 -6. ) (7.59999943 -7. -1.20000004 -6. 2.38418579E-7 0 ) (6.3999996 -13. -1.19999981 -6. 1.19999981 6. )) NATURAL) (3 ((32 167) (32 167) (93 0)) NIL ((-15.25 41.75 0 0 91.5 -250.5 ) (30.5 -83.5 91.5 -250.5 -91.5 250.5 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 170Q) (FACE M R R) (WIDTH 257 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:07:03) (MADE-FROM NIL 88 130 57 78) (SPLINES ((6 ((11 197) (23 187) (35 170) (51 147) (71 119) (90 90)) NIL ((12.2057399 -8.46411325 0 0 -1.23444962 -9.21531106 ) (11.588516 -13.0717697 -1.23444962 -9.21531106 6.17224789 4.07655525 ) (13.440191 -20.248802 4.9377985 -5.1387558 0.545454979 -1.09090805 ) (18.650714 -25.933013 5.48325348 -6.22966386 -8.35406686 6.2870798 ) (19.956935 -29.019138 -2.87081337 0.0574161485 2.87081337 -0.0574161485 )) NATURAL) (3 ((90 90) (90 90) (48 31)) NIL ((10.5 14.75 0 0 -63. -88.5 ) (-21. -29.5 -63. -88.5 63. 88.5 )) NATURAL) (4 ((48 31) (39 23) (29 14) (16 8)) NIL ((-8.93333245 -7.5333328 0 0 -0.400000095 -2.79999971 ) (-9.1333332 -8.93333245 -0.400000095 -2.79999971 -3.99999952 7.99999905 ) (-11.5333328 -7.73333264 -4.39999962 5.1999998 4.39999962 -5.1999998 )) NATURAL) (2 ((16 8) (16 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((16 0) (98 0)) NIL ((82. 0 0 0 0 0 )) NATURAL) (2 ((98 0) (98 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (5 ((98 8) (90 15) (87 25) (93 43) (106 67)) NIL ((-8.8214283 6.66071416 0 0 4.9285717 2.03571463 ) (-6.35714245 7.67857075 4.9285717 2.03571463 5.3571415 7.8214264 ) (1.25000047 13.625 10.285713 9.8571415 -2.35714245 -3.3214283 ) (10.357141 21.821426 7.92857075 6.5357132 -7.92857075 -6.5357132 )) NATURAL) (2 ((106 67) (128 37)) NIL ((22. -30. 0 0 0 0 )) NATURAL) (4 ((128 37) (136 26) (133 14) (121 8)) NIL ((10.333332 -10.333332 0 0 -14. -4. ) (3.33333302 -12.333332 -14. -4. 4. 14. ) (-8.66666604 -9.33333207 -10. 10. 10. -10. )) NATURAL) (2 ((121 8) (121 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((121 0) (244 0)) NIL ((123. 0 0 0 0 0 )) NATURAL) (2 ((244 0) (244 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((244 8) (230 23) (209 50) (159 122)) NIL ((-14.066665 14.799999 0 0 0.399999619 1.20000076 ) (-13.8666668 15.399999 0.399999619 1.20000076 -43.999992 65.999984 ) (-35.466667 49.599998 -43.599998 67.199997 43.599998 -67.199997 )) NATURAL) (5 ((159 122) (184 156) (201 178) (214 190) (229 197)) NIL ((26.821426 36.589279 0 0 -10.9285698 -15.535713 ) (21.357139 28.821426 -10.9285698 -15.535713 6.64285565 5.6785717 ) (13.75 16.124996 -4.28571415 -9.8571415 8.3571415 4.82142735 ) (13.642856 8.6785698 4.0714283 -5.03571415 -4.0714283 5.03571415 )) NATURAL) (2 ((229 197) (229 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((229 205) (145 205)) NIL ((-84. 0 0 0 0 0 )) NATURAL) (2 ((145 205) (145 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((145 197) (155 194) (163 184) (160 172)) NIL ((9.79999925 -1.26666665 0 0 1.19999981 -10.3999996 ) (10.3999996 -6.46666623 1.19999981 -10.3999996 -17.999996 9.9999981 ) (2.59999943 -11.8666649 -16.799999 -0.399999976 16.799999 0.399999976 )) NATURAL) (3 ((160 172) (144 144) (144 144)) NIL ((-20. -35. 0 0 24. 42. ) (-8. -14. 24. 42. -24. -42. )) NATURAL) (5 ((144 144) (126 170) (118 182) (119 192) (127 197)) NIL ((-20.160713 29.696426 0 0 12.9642849 -22.178569 ) (-13.6785698 18.607139 12.9642849 -22.178569 -4.8214283 26.892852 ) (-3.12499952 9.875 8.1428566 4.7142849 0.321428299 -13.3928547 ) (5.1785717 7.8928566 8.4642849 -8.6785698 -8.4642849 8.6785698 )) NATURAL) (2 ((127 197) (127 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((127 205) (11 205)) NIL ((-116. 0 0 0 0 0 )) NATURAL) (3 ((11 205) (11 205) (11 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 171Q) (FACE M R R) (WIDTH 242 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:27:56) (MADE-FROM NIL 106 130 52 37) (SPLINES ((2 ((10 205) (130 205)) NIL ((120. 0 0 0 0 0 )) NATURAL) (2 ((130 205) (130 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (5 ((130 197) (123 192) (120 180) (130 153) (148 97)) NIL ((-7.28571416 -3.67857122 0 0 1.71428585 -7.92857075 ) (-6.42857075 -7.6428566 1.71428585 -7.92857075 15.4285698 -2.35714435 ) (3. -16.75 17.142856 -10.285715 -9.4285698 -30.642849 ) (15.4285698 -42.357139 7.71428586 -40.928566 -7.71428586 40.928566 )) NATURAL) (2 ((148 97) (168 159)) NIL ((20. 62. 0 0 0 0 )) NATURAL) (5 ((168 159) (169 171) (166 183) (159 192) (147 197)) NIL ((1.875 11.857141 0 0 -5.25 0.857142807 ) (-0.750000001 12.285713 -5.25 0.857142807 2.25 -4.2857132 ) (-4.875 10.999998 -3. -3.42857122 -3.74999905 -1.71428537 ) (-9.75 6.7142849 -6.74999905 -5.1428566 6.74999905 5.1428566 )) NATURAL) (3 ((147 197) (147 205) (147 205)) NIL ((0 10. 0 0 0 -12. ) (0 4. 0 -12. 0 12. )) NATURAL) (2 ((147 205) (230 205)) NIL ((83. 0 0 0 0 0 )) NATURAL) (2 ((230 205) (230 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (6 ((230 197) (216 187) (203 163) (182 108) (155 34) (129 -33)) NIL ((-14.722486 -8.07655335 0 0 4.33492756 -11.54067 ) (-12.555023 -13.846889 4.33492756 -11.54067 -15.674638 -26.296646 ) (-16.057415 -38.53588 -11.339712 -37.837318 4.36363602 14.727272 ) (-25.215309 -69.009567 -6.97607613 -23.110046 10.2200946 39.387558 ) (-27.081337 -72.425827 3.24401903 16.277511 -3.24401903 -16.277511 )) NATURAL) (18 ((129 -33) (106 -65) (71 -78) (36 -70) (18 -52) (19 -28) (35 -12) (60 -11) (77 -29) (74 -50) (84 -54) (97 -42) (105 -12) (98 18) (71 88) (44 151) (27 185) (10 197)) NIL ((-20.030921 -35.737548 0 0 -17.814453 22.425304 ) (-28.938152 -24.524894 -17.814453 22.425304 17.072273 1.87346649 ) (-38.216468 -1.16285705 -0.742179275 24.29877 21.525348 -17.919166 ) (-28.195968 14.176328 20.783172 6.37960148 -1.17368698 3.80321789 ) (-7.99964047 22.457538 19.609485 10.182819 -4.83061028 -21.293701 ) (9.19454 21.993507 14.778875 -11.1108818 -3.5038681 -2.62841225 ) (22.221481 9.5684204 11.275007 -13.739294 -17.153915 -10.192644 ) (24.919528 -9.26719476 -5.87891007 -23.931938 -29.88045 19.39899 ) (4.1003933 -23.499637 -35.75936 -4.53294659 64.67572 28.596672 ) (0.678891659 -13.734245 28.916358 24.063728 -30.822425 -13.785705 ) (14.184036 3.43663216 -1.90606785 10.2780227 -1.38602018 20.546138 ) (11.584959 23.987724 -3.29208803 30.824161 -11.6334896 -56.398834 ) (2.47612381 26.612464 -14.925579 -25.574676 -12.0800056 97.049225 ) (-18.489456 49.5624 -27.005584 71.474548 29.953506 -91.79808 ) (-30.518287 75.137909 2.94792461 -20.323539 12.2659607 -11.8568496 ) (-21.437381 48.88594 15.213886 -32.180389 -19.017356 7.22549058 ) (-15.7321758 20.318298 -3.80347204 -24.954898 3.80347204 24.954898 )) NATURAL) (2 ((10 197) (10 205)) NIL ((0 8. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 172Q) (FACE M R R) (WIDTH 216 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:28:40) (MADE-FROM NIL 106 130 70 46) (SPLINES ((3 ((34 205) (34 205) (204 205)) NIL ((-42.5 0 0 0 255. 0 ) (85. 0 255. 0 -255. 0 )) NATURAL) (2 ((204 205) (204 195)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((204 195) (114 17)) NIL ((-90. -178. 0 0 0 0 )) NATURAL) (5 ((114 17) (138 19) (161 30) (173 45) (180 60)) NIL ((23.571426 -0.125000000 0 0 2.5714283 12.75 ) (24.857139 6.25 2.5714283 12.75 -18.857139 -9.75 ) (17.999996 14.125 -16.285713 2.99999952 12.857141 -3.74999905 ) (8.1428566 15.249998 -3.42857122 -0.749999881 3.42857122 0.749999881 )) NATURAL) (2 ((180 60) (198 60)) NIL ((18. 0 0 0 0 0 )) NATURAL) (2 ((198 60) (191 0)) NIL ((-7. -60. 0 0 0 0 )) NATURAL) (2 ((191 0) (9 0)) NIL ((-182. 0 0 0 0 0 )) NATURAL) (3 ((9 0) (107 189) (107 189)) NIL ((122.5 236.25 0 0 -147. -283.5 ) (49. 94.5 -147. -283.5 147. 283.5 )) NATURAL) (5 ((107 189) (88 188) (72 183) (59 171) (50 154)) NIL ((-19.660713 -0.339285672 0 0 3.96428537 -3.96428585 ) (-17.678569 -2.3214283 3.96428537 -3.96428585 -1.8214283 -4.17857075 ) (-14.624998 -8.375 2.14285707 -8.1428566 3.32142782 2.6785717 ) (-10.821428 -15.178571 5.4642849 -5.4642849 -5.4642849 5.4642849 )) NATURAL) (2 ((50 154) (30 154)) NIL ((-20. 0 0 0 0 0 )) NATURAL) (3 ((30 154) (34 205) (34 205)) NIL ((5. 63.75 0 0 -6. -76.5 ) (2. 25.5 -6. -76.5 6. 76.5 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/TIMESROMAN.NUM-SF b/lispusers/TIMESROMAN.NUM-SF new file mode 100644 index 00000000..c1ab00ca --- /dev/null +++ b/lispusers/TIMESROMAN.NUM-SF @@ -0,0 +1 @@ + ((FAMILY TIMESROMAND) (CHARACTER 61Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:40:26) (MADE-FROM NIL 118 130 43 65) (SPLINES ((2 ((49 0) (212 0)) NIL ((163. 0 0 0 0 0 )) NATURAL) (2 ((212 0) (212 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((212 10) (198 11) (185 15) (175 27) (173 52)) NIL ((-14.196428 0.535714269 0 0 1.17857146 2.78571415 ) (-13.607141 1.92857146 1.17857146 2.78571415 0.107142686 4.0714283 ) (-12.375 6.75 1.28571415 6.85714245 10.3928566 10.9285698 ) (-5.8928566 19.071426 11.6785717 17.785713 -11.6785717 -17.785713 )) NATURAL) (2 ((173 52) (173 294)) NIL ((0 242. 0 0 0 0 )) NATURAL) (2 ((173 294) (153 294)) NIL ((-20. 0 0 0 0 0 )) NATURAL) (2 ((153 294) (39 255)) NIL ((-114. -39. 0 0 0 0 )) NATURAL) (2 ((39 255) (39 245)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (6 ((39 245) (51 248) (65 250) (79 245) (84 233) (84 212)) NIL ((11.61244 2.85645914 0 0 2.32535887 0.861243725 ) (12.7751178 3.28708124 2.32535887 0.861243725 0.373205185 -10.306217 ) (15.2870807 -1.00478506 2.69856405 -9.4449749 -15.818178 4.36363602 ) (10.076553 -8.26794244 -13.119615 -5.08133888 8.89951898 -7.14832497 ) (1.40669846 -16.9234428 -4.22009564 -12.2296638 4.22009564 12.2296638 )) NATURAL) (2 ((84 212) (84 52)) NIL ((0 -160. 0 0 0 0 )) NATURAL) (5 ((84 52) (82 27) (72 15) (59 11) (49 10)) NIL ((-0.125000000 -27.964283 0 0 -11.25 17.785713 ) (-5.75 -19.071426 -11.25 17.785713 8.25 -10.9285698 ) (-12.875 -6.74999905 -2.99999952 6.85714245 8.2499981 -4.0714283 ) (-11.749998 -1.92857122 5.24999905 2.78571415 -5.24999905 -2.78571415 )) NATURAL) (2 ((49 10) (49 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 62Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:41:31) (MADE-FROM NIL 137 130 43 65) (SPLINES ((3 ((18 0) (18 0) (208 0)) NIL ((-47.5 0 0 0 285. 0 ) (95. 0 285. 0 -285. 0 )) NATURAL) (2 ((208 0) (235 85)) NIL ((27. 85. 0 0 0 0 )) NATURAL) (2 ((235 85) (223 88)) NIL ((-12. 3. 0 0 0 0 )) NATURAL) (4 ((223 88) (217 79) (207 74) (191 72)) NIL ((-5.333333 -9.8666649 0 0 -4. 5.1999998 ) (-7.333333 -7.2666664 -4. 5.1999998 -4. -2. ) (-13.333332 -3.0666666 -8. 3.1999998 8. -3.1999998 )) NATURAL) (2 ((191 72) (99 72)) NIL ((-92. 0 0 0 0 0 )) NATURAL) (13 ((99 72) (133 104) (159 131) (187 161) (207 195) (212 236) (195 269) (167 288) (134 296) (95 293) (64 278) (41 254) (26 224)) NIL ((36.390373 33.521003 0 0 -14.3422489 -9.1260376 ) (29.219245 28.957984 -14.3422489 -9.1260376 23.71125 15.630188 ) (26.732624 27.64704 9.3690014 6.5041504 -20.502761 -5.39471627 ) (25.850242 31.453834 -11.13376 1.10943412 -1.70019531 11.948675 ) (13.866386 38.537605 -12.8339557 13.058109 -14.696451 -24.399986 ) (-6.3157959 39.39572 -27.530406 -11.3418769 18.485996 -4.34872246 ) (-24.603202 25.879486 -9.0444107 -15.690599 6.75246525 5.7948761 ) (-30.27138 13.0863247 -2.29194546 -9.89572335 -9.49585725 -0.830780030 ) (-37.311256 2.77521038 -11.7878036 -10.726503 25.230964 -2.47175407 ) (-36.483573 -9.18717 13.443161 -13.198257 -7.4280052 4.71779442 ) (-26.754417 -20.026531 6.0151558 -8.48046304 4.4810543 1.60057926 ) (-18.498733 -27.706703 10.49621 -6.87988377 -10.49621 6.87988377 )) NATURAL) (2 ((26 224) (36 219)) NIL ((10. -5. 0 0 0 0 )) NATURAL) (11 ((36 219) (51 235) (73 245) (104 242) (124 216) (125 178) (114 142) (94 105) (70 68) (43 35) (18 10)) NIL ((13.8977489 17.051868 0 0 6.61349774 -6.3112297 ) (17.204498 13.896255 6.61349774 -6.3112297 8.93251039 -4.44385147 ) (28.284252 5.36310005 15.546009 -10.755081 -30.343544 -17.91336 ) (28.658485 -14.348661 -14.7975349 -28.668441 -7.5583267 16.0972938 ) (10.081787 -34.968452 -22.355861 -12.5711479 12.5768566 19.524185 ) (-5.98564625 -37.777504 -9.77900506 6.95303727 -0.749107361 -10.194042 ) (-16.139202 -35.921493 -10.528112 -3.24100542 8.4195709 3.25198889 ) (-22.45753 -37.536499 -2.10854101 0.0109835881 -2.92918157 3.18608713 ) (-26.030662 -35.932472 -5.03772259 3.19707108 9.29715158 8.0036602 ) (-26.419807 -28.733573 4.25942993 11.200731 -4.25942993 -11.200731 )) NATURAL) (2 ((18 10) (18 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 63Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:42:55) (MADE-FROM NIL 136 130 43 65) (SPLINES ((11 ((31 236) (47 258) (70 280) (99 294) (137 299) (174 293) (200 275) (212 244) (204 214) (181 192) (151 178)) NIL ((14.3884849 21.553886 0 0 9.66908837 2.67667627 ) (19.22303 22.892223 9.66908837 2.67667627 -6.34544755 -13.3833809 ) (25.719394 18.877208 3.32364082 -10.706705 9.7127056 2.85685539 ) (33.899383 9.59893037 13.036346 -7.8498497 -14.5053768 -4.04404068 ) (39.683044 -0.272939324 -1.46903157 -11.89389 -11.6911888 1.31930732 ) (32.368415 -11.507177 -13.160221 -10.574583 1.27013778 -7.2331829 ) (19.843265 -25.698352 -11.890083 -17.8077659 -11.389358 21.613414 ) (2.25850487 -32.699409 -23.279441 3.80565167 8.2872944 4.77950764 ) (-16.8772888 -26.504001 -14.992147 8.5851593 8.24018479 1.26855087 ) (-27.749343 -17.284568 -6.75196267 9.85371018 6.75196267 -9.85371018 )) NATURAL) (22 ((151 178) (181 171) (209 154) (229 119) (228 72) (208 38) (174 12) (127 -2) (78 -4) (40 4) (18 19) (18 44) (44 54) (77 43) (105 24) (136 20) (154 41) (157 76) (145 105) (126 126) (100 141) (75 149)) NIL ((30.282508 -5.32254124 0 0 -1.69506907 -10.0647506 ) (29.434974 -10.3549156 -1.69506907 -10.0647506 -3.52465439 -9.67624665 ) (25.977577 -25.257789 -5.2197237 -19.740997 -20.206306 0.769748688 ) (10.654701 -44.613914 -25.426033 -18.971248 6.34989167 42.597244 ) (-11.5963859 -42.286537 -19.076141 23.625999 6.80674554 -21.158752 ) (-27.269153 -29.239913 -12.2693958 2.4672451 -3.57687187 12.037767 ) (-41.326988 -20.753784 -15.846267 14.505012 13.50074 -2.99231338 ) (-50.42288 -7.74493027 -2.34552717 11.512699 15.573904 -0.0685119629 ) (-44.981452 3.7335124 13.228378 11.444187 2.20362282 -8.73363687 ) (-30.651268 10.8108806 15.432001 2.71054888 5.61161614 17.003063 ) (-12.4134578 22.02296 21.043617 19.713615 11.349899 -41.278625 ) (14.3051128 21.097263 32.393516 -21.56501 -27.011226 -1.88856125 ) (33.193016 -1.41202593 5.38228989 -23.453571 -17.304973 12.83287 ) (29.922817 -18.449161 -11.9226837 -10.6207008 24.231128 28.557079 ) (30.115699 -14.7913208 12.3084449 17.936378 -31.619537 10.938793 ) (26.614376 8.61445428 -19.311092 28.875171 6.2470169 -12.3122406 ) (10.42679 31.333507 -13.064075 16.562931 -5.368515 -27.689838 ) (-5.3215437 34.051513 -18.43259 -11.126909 15.227033 3.07161903 ) (-16.140617 24.460414 -3.20555592 -8.0552902 -7.53962804 3.40336895 ) (-23.115985 18.106807 -10.7451839 -4.65192127 14.931478 -4.6850977 ) (-26.395431 11.112339 4.1862955 -9.33701898 -4.1862955 9.33701898 )) NATURAL) (2 ((75 149) (75 158)) NIL ((0 9. 0 0 0 0 )) NATURAL) (9 ((75 158) (106 169) (126 188) (132 214) (125 241) (107 256) (79 257) (56 244) (41 229)) NIL ((33.150589 9.29224969 0 0 -12.9035339 10.2465019 ) (26.698818 14.4155 -12.9035339 10.2465019 -1.48232650 -3.23251152 ) (13.0541229 23.045745 -14.38586 7.0139904 0.832839966 -3.31645727 ) (-0.915316582 28.401508 -13.55302 3.69753313 4.15096092 -19.501655 ) (-12.392856 22.348213 -9.40205956 -15.8041229 -5.4366741 3.32308579 ) (-24.513252 8.20563127 -14.838733 -12.481037 23.595726 -5.79068375 ) (-27.554122 -7.17074776 8.75699426 -18.27172 1.05375671 19.839649 ) (-18.270248 -15.522642 9.81075097 1.56793022 -9.81075097 -1.56793022 )) NATURAL) (2 ((41 229) (31 236)) NIL ((-10. 7. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 64Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:43:50) (MADE-FROM NIL 106 130 43 65) (SPLINES ((3 ((117 0) (117 0) (210 0)) NIL ((-23.25 0 0 0 139.5 0 ) (46.5 0 139.5 0 -139.5 0 )) NATURAL) (2 ((210 0) (210 57)) NIL ((0 57. 0 0 0 0 )) NATURAL) (2 ((210 57) (232 57)) NIL ((22. 0 0 0 0 0 )) NATURAL) (2 ((232 57) (232 105)) NIL ((0 48. 0 0 0 0 )) NATURAL) (2 ((232 105) (210 105)) NIL ((-22. 0 0 0 0 0 )) NATURAL) (2 ((210 105) (210 294)) NIL ((0 189. 0 0 0 0 )) NATURAL) (2 ((210 294) (166 294)) NIL ((-44. 0 0 0 0 0 )) NATURAL) (2 ((166 294) (13 98)) NIL ((-153. -196. 0 0 0 0 )) NATURAL) (2 ((13 98) (13 57)) NIL ((0 -41. 0 0 0 0 )) NATURAL) (2 ((13 57) (117 57)) NIL ((104. 0 0 0 0 0 )) NATURAL) (2 ((117 57) (117 0)) NIL ((0 -57. 0 0 0 0 )) NATURAL)) ((2 ((117 105) (57 105)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((57 105) (117 182)) NIL ((60. 77. 0 0 0 0 )) NATURAL) (2 ((117 182) (117 105)) NIL ((0 -77. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 65Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:44:39) (MADE-FROM NIL 140 130 43 65) (SPLINES ((2 ((229 294) (81 294)) NIL ((-148. 0 0 0 0 0 )) NATURAL) (2 ((81 294) (27 138)) NIL ((-54. -156. 0 0 0 0 )) NATURAL) (22 ((27 138) (57 136) (92 131) (134 114) (159 75) (149 35) (115 22) (83 37) (55 51) (25 47) (15 23) (40 1) (88 -4) (144 5) (188 29) (218 63) (228 107) (214 149) (190 176) (158 193) (119 203) (78 207)) NIL ((29.342811 -1.66680526 0 0 3.9431281 -1.99916839 ) (31.314373 -2.66638946 3.9431281 -1.99916839 10.2843589 -8.004158 ) (40.39968 -8.66763688 14.227487 -10.003326 -33.080566 -19.984199 ) (38.086883 -28.663059 -18.85308 -29.987525 -21.962081 27.940948 ) (8.25275994 -44.680107 -40.815162 -2.04657411 12.9289207 34.22039 ) (-26.097942 -29.616481 -27.886241 32.17382 36.24639 3.1774292 ) (-35.860984 4.14605809 8.3601551 35.351249 -1.91453647 -40.930099 ) (-28.458099 19.032257 6.44561864 -5.57885075 -16.588245 -13.457002 ) (-30.306606 6.724905 -10.1426296 -19.035854 32.267524 -7.24187089 ) (-24.315467 -15.931886 22.1249 -26.277725 19.518119 30.424495 ) (7.5684929 -26.99736 41.64302 4.14677334 -20.340023 17.543861 ) (39.041503 -14.078657 21.302997 21.690635 -10.158018 -10.599956 ) (55.265487 2.31199884 11.144979 11.090679 -29.027896 6.85596848 ) (51.896514 16.830661 -17.882919 17.946647 6.2696266 -10.823919 ) (37.148414 29.365348 -11.6132927 7.1227274 -8.0506096 6.43971539 ) (21.509811 39.70793 -19.663902 13.5624428 -10.0671806 -14.934944 ) (-3.18767786 45.8029 -29.731082 -1.37250161 24.319316 -18.699932 ) (-20.759101 35.080429 -5.41176605 -20.072437 -3.210083 11.734699 ) (-27.775909 20.875343 -8.62184907 -8.33773805 0.521009445 1.7611351 ) (-36.137252 13.4181747 -8.1008396 -6.57660294 7.12604905 -0.779245377 ) (-40.675064 6.4519491 -0.974789858 -7.3558483 0.974789858 7.3558483 )) NATURAL) (2 ((78 207) (81 219)) NIL ((3. 12. 0 0 0 0 )) NATURAL) (2 ((81 219) (194 219)) NIL ((113. 0 0 0 0 0 )) NATURAL) (2 ((194 219) (229 294)) NIL ((35. 75. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 66Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:45:32) (MADE-FROM NIL 98 130 43 65) (SPLINES ((3 ((229 298) (229 298) (229 288)) NIL ((0 2.5 0 0 0 -15. ) (0 -5. 0 -15. 0 15. )) NATURAL) (7 ((229 288) (195 281) (165 267) (141 248) (124 227) (112 203) (106 181)) NIL ((-34.75769 -5.46282006 0 0 4.54615307 -9.22307588 ) (-32.48461 -10.074358 4.54615307 -9.22307588 1.26923179 4.1153841 ) (-27.303844 -17.239742 5.81538487 -5.10769177 2.37692165 4.76153755 ) (-20.299999 -19.966663 8.1923065 -0.346153617 -4.77692127 -5.16153813 ) (-14.4961528 -22.893589 3.41538477 -5.50769234 4.73076725 9.88461495 ) (-8.71538354 -23.458972 8.1461525 4.3769226 -8.1461525 -4.3769226 )) NATURAL) (24 ((106 181) (133 186) (161 186) (193 177) (222 151) (236 111) (234 68) (218 34) (189 9) (147 -4) (110 -3) (74 8) (44 29) (24 60) (13 100) (14 144) (24 187) (40 218) (60 243) (85 264) (120 281) (152 291) (191 297) (229 298)) NIL ((27.017456 5.9552679 0 0 -0.104736805 -5.7316103 ) (26.965084 3.08946276 -0.104736805 -5.7316103 6.52368355 -1.3419466 ) (30.122192 -3.31312084 6.4189472 -7.0735569 -7.99000168 -12.900602 ) (32.546135 -16.8369789 -1.57105517 -19.974159 -16.563671 4.94436646 ) (22.693244 -34.33895 -18.134727 -15.0297928 2.24469948 11.123121 ) (5.68086815 -43.807182 -15.890028 -3.90667152 1.58487129 16.563148 ) (-9.41672326 -39.43228 -14.3051567 12.6564789 3.41581917 -5.37572384 ) (-22.013973 -29.463665 -10.8893375 7.28075505 -9.24814797 4.9397459 ) (-37.527381 -19.713039 -20.137485 12.2205009 33.576767 3.61674309 ) (-40.87648 -5.6841688 13.439281 15.837244 -17.058918 -7.4067192 ) (-35.966659 6.44971657 -3.61963892 8.4305248 10.6589126 2.01012611 ) (-34.256843 15.885305 7.0392742 10.4406509 4.42326546 -0.633787155 ) (-25.005939 26.009063 11.4625396 9.80686379 -4.35197258 0.525022507 ) (-15.719387 36.078437 7.1105671 10.331886 6.98462487 -7.46629525 ) (-5.11650753 42.677177 14.0951919 2.86559057 -5.58652687 -0.659839154 ) (6.18542004 45.212844 8.50866509 2.20575142 -2.63851929 -19.894344 ) (13.374826 37.47142 5.8701458 -17.688594 -1.85939884 14.2372398 ) (18.315273 26.901447 4.01074696 -3.45135403 -1.92388344 -1.05462932 ) (21.364078 22.922779 2.08686352 -4.50598336 15.554931 1.98127079 ) (31.228408 19.407428 17.641796 -2.52471256 -30.295848 -6.87045193 ) (33.722274 13.4474907 -12.6540527 -9.3951645 27.628467 7.50054169 ) (34.88246 7.802598 14.9744148 -1.89462209 -20.218017 -5.1317215 ) (39.747863 3.34211445 -5.24360276 -7.0263443 5.24360276 7.0263443 )) NATURAL)) ((12 ((97 136) (105 160) (127 165) (146 144) (150 106) (151 61) (143 27) (121 14) (102 32) (96 66) (94 100) (97 136)) NIL ((4.31370259 27.50521 0 0 22.117782 -21.031272 ) (15.3725929 16.989574 22.117782 -21.031272 -26.588913 -8.84362794 ) (24.195919 -8.46351434 -4.47113037 -29.8749 -17.76213 14.40579 ) (10.843723 -31.135517 -22.233261 -15.46911 25.637439 5.22045326 ) (1.42918324 -43.9944 3.40418053 -10.248657 -12.787641 24.712398 ) (-1.56045842 -41.886856 -9.383461 14.463741 -10.486866 3.9299469 ) (-16.187351 -25.458145 -19.870327 18.393688 24.735099 19.567806 ) (-23.690128 2.71944952 4.86477566 37.961494 13.5464439 -22.201179 ) (-12.0521297 29.580352 18.41122 15.760313 -18.920879 -20.763061 ) (-3.10134888 34.959129 -0.509659410 -5.0027504 8.1370735 9.25343705 ) (0.457528412 34.583099 7.6274147 4.2506876 -7.6274147 -4.2506876 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 67Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:46:19) (MADE-FROM NIL 110 130 43 65) (SPLINES ((3 ((45 294) (45 294) (230 294)) NIL ((-46.25 0 0 0 277.5 0 ) (92.5 0 277.5 0 -277.5 0 )) NATURAL) (2 ((230 294) (119 0)) NIL ((-111. -294. 0 0 0 0 )) NATURAL) (2 ((119 0) (83 0)) NIL ((-36. 0 0 0 0 0 )) NATURAL) (2 ((83 0) (150 208)) NIL ((67. 208. 0 0 0 0 )) NATURAL) (2 ((150 208) (70 208)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (4 ((70 208) (55 207) (41 202) (34 194)) NIL ((-14.799999 -0.133333355 0 0 -1.19999981 -5.1999998 ) (-15.399999 -2.73333311 -1.19999981 -5.1999998 11.999998 2. ) (-10.599998 -6.9333334 10.799999 -3.1999998 -10.799999 3.1999998 )) NATURAL) (2 ((34 194) (24 197)) NIL ((-10. 3. 0 0 0 0 )) NATURAL) (2 ((24 197) (45 294)) NIL ((21. 97. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 70Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:47:01) (MADE-FROM NIL 110 130 43 65) (SPLINES ((11 ((143 187) (124 200) (109 218) (99 241) (100 264) (114 279) (135 278) (147 262) (152 235) (150 209) (143 187)) NIL ((-19.869873 11.9956379 0 0 5.21924973 6.02616978 ) (-17.26025 15.008722 5.21924973 6.02616978 -2.09624863 -0.130851745 ) (-13.0891247 20.969467 3.1230011 5.89531803 9.16574479 -5.50276184 ) (-5.38325024 24.113403 12.2887459 0.392555833 1.43326759 -7.85809708 ) (7.62212754 20.576908 13.722013 -7.46554185 -2.89880943 -11.064842 ) (19.894733 7.5789461 10.823204 -18.530384 -25.838031 4.1174755 ) (17.798923 -8.8927021 -15.014829 -14.412908 10.250944 0.594938278 ) (7.9095659 -23.00814 -4.76388455 -13.81797 -3.16574574 17.502761 ) (1.56280875 -28.074729 -7.92963029 3.68479157 2.41203785 1.39401054 ) (-5.16080189 -23.692932 -5.51759243 5.0788021 5.51759243 -5.0788021 )) NATURAL)) ((11 ((106 126) (98 109) (94 84) (93 54) (103 24) (129 12) (148 26) (153 57) (143 89) (126 112) (106 126)) NIL ((-8.9797363 -15.152502 0 0 5.8784256 -11.0849876 ) (-6.04052354 -20.694995 5.8784256 -11.0849876 -5.39213085 7.4249382 ) (-2.85816383 -28.067512 0.486294031 -3.66004896 9.6901016 -0.614766598 ) (2.47318268 -32.034942 10.176397 -4.27481556 14.6317119 25.034126 ) (19.965435 -23.792697 24.808109 20.759311 -38.216949 8.4782562 ) (25.665069 1.20574236 -13.40884 29.237567 0.236091614 -10.9471588 ) (12.374275 24.96973 -13.172748 18.290409 -4.72740555 -18.689624 ) (-3.16217756 33.915329 -17.900154 -0.399217188 12.6735286 -10.2943229 ) (-14.7255668 28.368946 -5.22662449 -10.6935405 2.03328085 -0.133073806 ) (-18.93555 17.608871 -3.19334364 -10.826614 3.19334364 10.826614 )) NATURAL)) ((16 ((161 178) (191 188) (216 206) (225 234) (214 267) (191 285) (159 295) (117 297) (83 292) (53 279) (31 254) (23 224) (32 192) (51 168) (70 150) (92 135)) NIL ((30.5219 8.40951158 0 0 -3.13142109 9.5429306 ) (28.956192 13.1809768 -3.13142109 9.5429306 -14.342893 0.285345077 ) (18.65332 22.866577 -17.474315 9.82827569 -5.496994 1.31568908 ) (-1.56949138 33.352699 -22.971309 11.1439647 12.330877 -35.548103 ) (-18.375362 26.72261 -10.640432 -24.40414 4.17348099 20.876743 ) (-26.929054 12.756843 -6.46695138 -3.5273943 -11.0248088 -5.95888233 ) (-38.908409 6.25000668 -17.49176 -9.4862766 33.925758 2.95878696 ) (-39.437286 -1.75687647 16.433998 -6.52748967 -16.67823 0.123727798 ) (-31.34241 -8.22250176 -0.244234919 -6.40376187 8.7871742 -9.4536953 ) (-27.193054 -19.353111 8.54294015 -15.857458 5.52952576 13.691059 ) (-15.885351 -28.365039 14.0724659 -2.16639852 5.09471703 -3.31054735 ) (0.734474182 -32.186714 19.167182 -5.47694588 -7.90839387 17.551128 ) (15.94746 -28.888095 11.258789 12.074182 -15.461132 -6.89396477 ) (19.475681 -20.260894 -4.20234394 5.18021775 9.7529297 -1.97527265 ) (20.149803 -16.068313 5.55058575 3.20494509 -5.55058575 -3.20494509 )) NATURAL) (18 ((92 135) (66 126) (40 113) (22 90) (18 58) (31 30) (53 11) (81 0) (112 -4) (151 -3) (187 6) (214 24) (231 50) (236 85) (223 121) (200 147) (180 164) (161 178)) NIL ((-25.61761 -8.46248437 0 0 -2.29432678 -3.22508955 ) (-26.764774 -10.075029 -2.29432678 -3.22508955 11.4716339 -7.87455178 ) (-23.323284 -17.237396 9.1773071 -11.0996418 4.40778733 -1.27669716 ) (-11.942083 -28.975387 13.585094 -12.3763389 6.8972168 18.981342 ) (5.0916214 -31.861053 20.482311 6.60500336 -13.996664 3.35132027 ) (18.575599 -23.58039 6.48564625 9.9563236 1.08945465 -2.38662529 ) (25.605972 -14.817379 7.5751009 7.56969834 -8.36115075 0.195180893 ) (29.000499 -7.15008927 -0.786051036 7.7648792 14.355152 -4.39409924 ) (35.39202 -1.58225989 13.569101 3.37077951 -19.059459 5.3812208 ) (39.431388 4.47912979 -5.4903612 8.7520008 -4.11729336 0.869216920 ) (31.882385 13.665739 -9.60765458 9.6212177 -0.471364975 -2.85809517 ) (22.039047 21.85791 -10.0790195 6.76312256 0.00275802612 4.56316757 ) (11.9614086 30.902614 -10.0762615 11.32629 -11.539667 -9.39457894 ) (-3.88468742 37.531616 -21.615928 1.93171096 10.15591 -14.984844 ) (-20.42266 31.970905 -11.460018 -13.0531349 18.916019 3.33397102 ) (-22.424667 20.584754 7.45600415 -9.7191639 -7.82000447 7.64895535 ) (-18.8786659 14.690069 -0.364001214 -2.07020855 0.364001214 2.07020855 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 71Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:48:02) (MADE-FROM NIL 122 130 43 65) (SPLINES ((7 ((140 116) (133 90) (113 55) (89 31) (63 17) (36 8) (13 5)) NIL ((-3.77564097 -22.973075 0 0 -19.346153 -18.161537 ) (-13.448717 -32.05384 -19.346153 -18.161537 18.730766 36.807685 ) (-23.429485 -31.811534 -0.615384579 18.646152 -1.57692289 -9.06923104 ) (-24.833332 -17.6999969 -2.19230747 9.57692147 -0.423077107 -6.53076649 ) (-27.237178 -11.38846 -2.61538458 3.0461545 9.2692299 5.19230557 ) (-25.217945 -5.74615288 6.65384579 8.23846055 -6.65384579 -8.23846055 )) NATURAL) (2 ((13 5) (13 -5)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (24 ((13 -5) (42 -6) (85 0) (129 13) (167 33) (198 61) (221 96) (235 133) (238 179) (231 223) (212 258) (180 283) (148 293) (114 296) (77 291) (48 276) (29 258) (13 224) (11 183) (21 149) (43 121) (74 108) (109 106) (140 116)) NIL ((25.408454 -2.4763155 0 0 21.549259 8.8578949 ) (36.183082 1.95263242 21.549259 8.8578949 -23.746303 -2.28948021 ) (45.85919 9.66578675 -2.19704437 6.56841469 -4.56403923 0.300027847 ) (41.380126 16.384216 -6.7610836 6.86844254 0.00246334076 1.08936882 ) (34.620277 23.797344 -6.75862027 7.95781136 -1.44581127 1.34249305 ) (27.138748 32.426399 -8.20443154 9.3003044 -0.219215393 -12.459333 ) (18.82471 35.497039 -8.4236469 -3.15902996 -3.67733002 18.494842 ) (8.5623989 41.585426 -12.1009769 15.335813 2.92853546 -19.520042 ) (-2.07431078 47.161224 -9.17244149 -4.18422985 -2.03680992 -6.41466618 ) (-12.2651577 39.76966 -11.209251 -10.598896 -6.7812996 3.17871285 ) (-26.865058 30.76012 -17.990551 -7.42018319 23.162006 -12.30018 ) (-33.274604 17.189842 5.17145634 -19.720363 -7.86673165 16.022014 ) (-32.036514 5.48048878 -2.6952753 -3.69834662 -3.69507694 -3.78789759 ) (-36.579322 -0.111806541 -6.39035226 -7.4862442 16.647037 -6.87042809 ) (-34.646156 -11.033264 10.256685 -14.356672 3.10692024 19.269603 ) (-22.836017 -15.755134 13.363605 4.91293335 -17.0747108 -28.207992 ) (-18.009765 -24.946197 -3.71110535 -23.295059 23.191921 15.562372 ) (-10.12491 -40.460067 19.480815 -7.732687 -9.6929836 19.958496 ) (4.50941372 -38.213508 9.78783227 12.225809 3.5800209 -11.39636 ) (16.087253 -31.685878 13.367853 0.829447270 -4.6271019 19.626949 ) (27.141559 -21.042957 8.74075128 20.456398 -3.07161903 -13.1114368 ) (34.346496 -7.14227963 5.66913224 7.34496117 -13.086414 8.81879617 ) (33.472427 4.61208058 -7.41728306 16.163757 7.41728306 -16.163757 )) NATURAL)) ((14 ((119 277) (102 266) (96 243) (94 215) (94 186) (99 153) (110 133) (128 128) (143 144) (147 175) (146 209) (143 240) (135 267) (119 277)) NIL ((-18.843631 -1.24039459 -2.892457 -23.967063 19.73917 13.343559 ) (-11.8665027 -18.535678 16.846714 -10.6235046 -15.3411178 5.08459187 ) (-2.69034862 -26.616886 1.50559568 -5.53891278 -0.374693632 8.31806947 ) (-1.37209987 -27.996765 1.13090205 2.77915716 4.83989334 -14.35687 ) (2.17874861 -32.396041 5.97079563 -11.5777149 -0.984880448 31.109413 ) (7.6571045 -28.419052 4.98591519 19.5317 5.0996275 -8.08078385 ) (15.1928329 -12.927742 10.0855426 11.450916 -13.413631 13.2137069 ) (18.5715599 5.13002777 -3.32808876 24.664623 -11.4450988 -8.7740402 ) (9.5209198 25.407627 -14.773187 15.890583 11.1940345 -14.1175327 ) (0.344750881 34.23944 -3.5791521 1.77304864 2.66895056 -6.755826 ) (-1.89992594 32.634574 -0.910201312 -4.9827776 -3.86983919 5.14084149 ) (-4.74504757 30.22222 -4.78004074 0.158064514 -5.18959046 -19.80754 ) (-12.119884 20.476512 -9.9696312 -19.649478 6.62820054 -3.91065979 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 60Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:49:21) (MADE-FROM NIL 112 130 43 65) (SPLINES ((29 ((125 302) (162 297) (194 281) (218 251) (229 228) (236 199) (240 165) (240 147) (240 129) (236 95) (229 66) (218 43) (194 13) (162 -3) (125 -8) (88 -3) (56 13) (32 43) (21 66) (14 95) (10 129) (10 147) (10 165) (14 199) (21 228) (32 251) (56 281) (88 297) (125 302)) NIL ((38.123054 -0.494537652 -0.435223341 -9.4098396 -5.4326887 1.19674492 ) (34.971489 -9.30600549 -5.86791229 -8.2130947 -0.225214004 -15.524675 ) (28.99097 -25.28144 -6.0931263 -23.73777 -11.6664486 42.901954 ) (17.064617 -27.568229 -17.7595749 19.164184 16.891006 -30.08316 ) (7.75054837 -23.445625 -0.868566871 -10.9189758 -1.89759016 -0.569307328 ) (5.93318558 -34.649253 -2.76615715 -11.488283 -3.30064392 38.360389 ) (1.51670646 -26.95734 -6.06680108 26.872112 9.1001644 -26.87228 ) (-1.25567112E-5 -13.5213699 3.03336334 -1.70698214E-4 -9.10001374 -26.871257 ) (-1.51665687 -26.957172 -6.06665135 -26.871429 3.29989529 38.35733 ) (-5.9333601 -34.649932 -2.76675606 11.4859066 1.90043187 -0.558097840 ) (-7.7499008 -23.443077 -0.866324187 10.9278087 -16.9016189 -30.12495 ) (-17.067035 -27.577743 -17.767944 -19.197143 11.706064 43.057907 ) (-28.981948 -25.245929 -6.0618801 23.860767 0.0773506165 -16.1067009 ) (-35.005149 -9.4385147 -5.9845295 7.7540655 5.9845295 3.36890125 ) (-37.99742 1.60187482E-7 0 11.1229667 5.9845295 -3.36890125 ) (-35.005149 9.4385166 5.9845295 7.7540655 0.0773506165 16.1067009 ) (-28.981948 25.245933 6.0618801 23.860767 11.706064 -43.057907 ) (-17.0670318 27.577743 17.767944 -19.197143 -16.9016189 30.12495 ) (-7.74989987 23.443077 0.866324187 10.9278087 1.90043092 0.558095932 ) (-5.9333601 34.649932 2.7667551 11.4859047 3.29989624 -38.357338 ) (-1.5166564 26.957172 6.06665135 -26.871433 -9.10001374 26.871261 ) (-1.23977661E-5 13.5213699 -3.03336334 -1.69676088E-4 9.1001644 26.87228 ) (1.51670670 26.95734 6.06680108 26.872112 -3.30064344 -38.360389 ) (5.93318558 34.649253 2.76615763 -11.488283 -1.89759087 0.569309235 ) (7.75054837 23.445625 0.868566752 -10.9189739 16.891006 30.083156 ) (17.064617 27.568233 17.7595749 19.164184 -11.6664467 -42.901954 ) (28.99097 25.281436 6.09312726 -23.73777 -0.225214958 15.524673 ) (34.971489 9.30600549 5.86791229 -8.2130966 -5.4326887 -1.19674301 )) PSEUDOCYCLIC)) ((25 ((125 10) (140 16) (149 39) (152 63) (153 89) (154 119) (155 147) (154 175) (153 205) (152 231) (149 255) (140 278) (125 284) (110 278) (101 255) (98 231) (97 205) (96 175) (95 147) (96 119) (97 89) (98 63) (101 39) (110 16) (125 10)) NIL ((16.35659 -0.115979194 -0.491682887 5.6023569 -6.66450596 19.888801 ) (12.5326557 15.43078 -7.15618897 25.491161 0.272627830 -31.058166 ) (5.51278019 25.392856 -6.88356114 -5.567008 5.57399655 8.3438816 ) (1.41621828 23.997787 -1.30956387 2.77687406 1.43138146 3.68263578 ) (0.822345257 28.615982 0.121817797 6.45950986 0.700474859 -11.0744228 ) (1.29440045 29.538276 0.822292686 -4.61491394 -4.23328018 4.61506176 ) (5.23924827E-5 27.230896 -3.41098833 1.48722116E-4 4.2326498 4.61417103 ) (-1.2946105 29.538127 0.821662307 4.6143198 -0.697323084 -11.0717468 ) (-0.821609855 28.616573 0.124339193 -6.45742798 -1.44335818 3.67282152 ) (-1.41894984 23.995555 -1.31901908 -2.78460646 -5.5292425 8.38046075 ) (-5.50259018 25.401184 -6.84826184 5.5958557 -0.439672470 -31.194671 ) (-12.570688 15.399702 -7.2879343 -25.598815 7.28793336 20.398223 ) (-16.214653 -9.53674316E-7 -2.55536235E-7 -5.20059109 7.28793526 -20.39822 ) (-12.570688 -15.3997039 7.28793526 -25.598812 -0.439674378 31.194664 ) (-5.50259018 -25.40118 6.84826089 5.59585476 -5.5292406 -8.38046075 ) (-1.41894984 -23.995559 1.31901955 -2.78460646 -1.44335866 -3.67282152 ) (-0.821609736 -28.616577 -0.124339282 -6.45742798 -0.697323084 11.0717468 ) (-1.2946105 -29.538127 -0.821662427 4.6143198 4.23265076 -4.61417008 ) (5.25317154E-5 -27.230896 3.4109888 1.48977647E-4 -4.23328114 -4.61506367 ) (1.29440045 -29.538276 -0.822292805 -4.6149149 0.700474978 11.0744247 ) (0.822345257 -28.615982 -0.121817782 6.45950986 1.43138146 -3.6826353 ) (1.41621852 -23.997787 1.30956387 2.77687454 5.57399655 -8.3438835 ) (5.51278115 -25.392856 6.88356114 -5.56700897 0.272626877 31.05817 ) (12.5326557 -15.430778 7.156188 25.491161 -6.66450406 -19.888805 )) PSEUDOCYCLIC)))) STOP \ No newline at end of file diff --git a/lispusers/TIMESROMAN.S1-SF b/lispusers/TIMESROMAN.S1-SF new file mode 100644 index 00000000..46103ff2 --- /dev/null +++ b/lispusers/TIMESROMAN.S1-SF @@ -0,0 +1 @@ + ((FAMILY TIMESROMAND) (CHARACTER 41Q) (FACE M R R) (WIDTH 159 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 13:54:31) (MADE-FROM NIL 117 130 35 72) (SPLINES ((9 ((80 299) (58 296) (41 286) (34 268) (37 240) (44 209) (52 176) (61 139) (66 97)) NIL ((-22.794181 -1.52006626 0 0 4.7650957 -8.87960244 ) (-20.411632 -5.95986748 4.7650957 -8.87960244 6.17451955 2.39801216 ) (-12.559276 -13.6404628 10.939615 -6.48159028 0.536821366 -6.7124443 ) (-1.35125184 -23.478275 11.4764366 -13.194034 -8.3217964 12.451765 ) (5.9642849 -30.446426 3.15463877 -0.742267847 -3.24963093 -1.09462428 ) (7.4941082 -31.736007 -0.0949926228 -1.83689213 3.32032347 -2.07326984 ) (9.05927659 -34.609535 3.2253313 -3.91016197 -10.0316639 -2.61229706 ) (7.2687769 -39.825843 -6.80633259 -6.52245904 6.80633259 6.52245904 )) NATURAL) (2 ((66 97) (94 97)) NIL ((28. 0 0 0 0 0 )) NATURAL) (9 ((94 97) (99 139) (108 176) (116 209) (123 240) (126 268) (119 286) (102 296) (80 299)) NIL ((3.86561108 43.087074 0 0 6.80633259 -6.52245904 ) (7.2687769 39.825843 6.80633259 -6.52245904 -10.0316639 2.61229706 ) (9.05927659 34.609535 -3.2253313 -3.91016197 3.32032394 2.07326984 ) (7.4941082 31.736007 0.0949927271 -1.83689213 -3.24963188 1.09462356 ) (5.96428585 30.446426 -3.15463924 -0.742268563 -8.3217964 -12.451763 ) (-1.35125184 23.478275 -11.4764366 -13.1940326 0.536821366 6.71244145 ) (-12.559278 13.6404628 -10.939615 -6.48159123 6.1745205 -2.3980093 ) (-20.411632 5.95986653 -4.76509476 -8.8796005 4.76509476 8.8796005 )) NATURAL)) ((17 ((80 -6) (99 -3) (114 4) (122 13) (125 27) (122 41) (114 50) (99 57) (80 60) (61 57) (46 50) (38 41) (35 27) (38 13) (46 4) (61 -3) (80 -6)) NIL ((19.639171 1.98203754 0 0 -3.83505154 6.10777474 ) (17.721649 5.0359249 -3.83505154 6.10777474 -4.82474232 -6.53887368 ) (11.474226 7.87426186 -8.65979386 -0.431099415 5.1340208 8.04772187 ) (5.38144303 11.4670238 -3.52577257 7.6166229 -3.71134043 -7.65201569 ) (-8.00937414E-8 15.2576389 -7.237113 -0.0353937074 3.71133947 -7.43965436 ) (-5.38144303 11.5024166 -3.52577353 -7.47504807 -5.13401795 7.41063786 ) (-11.474226 7.73268796 -8.65979196 -0.0644102097 4.8247404 -4.20289994 ) (-17.721649 5.5668268 -3.83505154 -4.26731014 3.83505106 -2.59903431 ) (-19.639171 0 -1.27768117E-7 -6.86634446 3.835052 2.59903335 ) (-17.721649 -5.56682778 3.835052 -4.2673111 4.82473946 4.20290089 ) (-11.474226 -7.73268796 8.65979196 -0.0644097030 -5.1340189 -7.4106388 ) (-5.38144303 -11.5024166 3.52577305 -7.475049 3.71133995 7.4396553 ) (1.59256160E-7 -15.2576389 7.237113 -0.0353935584 -3.71133995 7.65201569 ) (5.38144303 -11.4670238 3.52577305 7.6166229 5.1340208 -8.04772187 ) (11.474226 -7.87426186 8.65979386 -0.431099653 -4.82474232 6.53887368 ) (17.721649 -5.0359249 3.83505154 6.10777474 -3.83505154 -6.10777474 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 43Q) (FACE M R R) (WIDTH 378 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 13:59:09) (MADE-FROM NIL 88 130 95 75) (SPLINES ((2 ((73 221) (59 187)) NIL ((-14. -34. 0 0 0 0 )) NATURAL) (2 ((59 187) (109 187)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((109 187) (77 107)) NIL ((-32. -80. 0 0 0 0 )) NATURAL) (2 ((77 107) (27 107)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((27 107) (13 73)) NIL ((-14. -34. 0 0 0 0 )) NATURAL) (2 ((13 73) (63 73)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((63 73) (34 0)) NIL ((-29. -73. 0 0 0 0 )) NATURAL) (2 ((34 0) (94 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((94 0) (123 73)) NIL ((29. 73. 0 0 0 0 )) NATURAL) (2 ((123 73) (193 73)) NIL ((70. 0 0 0 0 0 )) NATURAL) (2 ((193 73) (164 0)) NIL ((-29. -73. 0 0 0 0 )) NATURAL) (2 ((164 0) (224 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((224 0) (253 73)) NIL ((29. 73. 0 0 0 0 )) NATURAL) (2 ((253 73) (303 73)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((303 73) (317 107)) NIL ((14. 34. 0 0 0 0 )) NATURAL) (2 ((317 107) (267 107)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((267 107) (299 187)) NIL ((32. 80. 0 0 0 0 )) NATURAL) (2 ((299 187) (349 187)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((349 187) (363 221)) NIL ((14. 34. 0 0 0 0 )) NATURAL) (2 ((363 221) (313 221)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((313 221) (343 294)) NIL ((30. 73. 0 0 0 0 )) NATURAL) (2 ((343 294) (283 294)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((283 294) (253 221)) NIL ((-30. -73. 0 0 0 0 )) NATURAL) (2 ((253 221) (183 221)) NIL ((-70. 0 0 0 0 0 )) NATURAL) (2 ((183 221) (213 294)) NIL ((30. 73. 0 0 0 0 )) NATURAL) (2 ((213 294) (153 294)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((153 294) (123 221)) NIL ((-30. -73. 0 0 0 0 )) NATURAL) (2 ((123 221) (73 221)) NIL ((-50. 0 0 0 0 0 )) NATURAL)) ((2 ((137 107) (169 187)) NIL ((32. 80. 0 0 0 0 )) NATURAL) (2 ((169 187) (239 187)) NIL ((70. 0 0 0 0 0 )) NATURAL) (2 ((239 187) (207 107)) NIL ((-32. -80. 0 0 0 0 )) NATURAL) (2 ((207 107) (137 107)) NIL ((-70. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 44Q) (FACE M R R) (WIDTH 295 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:21:22) (MADE-FROM NIL 111 130 82 78) (SPLINES ((3 ((256 294) (256 294) (256 204)) NIL ((0 22.5 0 0 0 -135. ) (0 -45. 0 -135. 0 135. )) NATURAL) (2 ((256 204) (246 204)) NIL ((-10. 0 0 0 0 0 )) NATURAL) (5 ((246 204) (223 240) (201 260) (173 274) (161 276)) NIL ((-23.982139 40.071426 0 0 5.8928566 -24.428569 ) (-21.035713 27.857139 5.8928566 -24.428569 -23.464283 26.142852 ) (-26.875 16.499996 -17.571426 1.71428418 45.964279 -20.142848 ) (-21.464283 8.1428547 28.392856 -18.428566 -28.392856 18.428566 )) NATURAL) (2 ((161 276) (161 191)) NIL ((0 -85. 0 0 0 0 )) NATURAL) (10 ((161 191) (179 183) (215 165) (253 139) (277 101) (276 56) (259 26) (219 1) (178 -7) (161 -8)) NIL ((13.47525 -5.72048283 0 0 27.148498 -13.677099 ) (27.049499 -12.559032 27.148498 -13.677099 -27.742504 8.38549806 ) (40.326744 -22.04338 -0.594006300 -5.29160118 -12.1784687 -7.86489106 ) (33.6435 -31.267429 -12.772476 -13.156492 -19.543609 -0.925933839 ) (11.09922 -44.886886 -32.316085 -14.082426 24.352932 41.568618 ) (-9.04039956 -38.184997 -7.96315194 27.486198 -23.868145 -33.348571 ) (-28.937622 -27.373088 -31.831298 -5.86237526 29.119644 31.825672 ) (-46.209098 -17.322628 -2.71165275 25.963298 39.389556 -21.954124 ) (-29.225967 -2.33639145 36.677909 4.00917435 -36.677909 -4.00917435 )) NATURAL) (2 ((161 -8) (161 -28)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (2 ((161 -28) (131 -28)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (2 ((131 -28) (131 -7)) NIL ((0 21. 0 0 0 0 )) NATURAL) (7 ((131 -7) (114 -5) (84 1) (62 10) (48 13) (39 9) (32 0)) NIL ((-13.073076 1.22948718 0 0 -23.561534 4.62307644 ) (-24.853843 3.54102564 -23.561534 4.62307644 39.807685 0.884614945 ) (-28.511535 8.60640908 16.2461509 5.50769139 -9.6692276 -14.161535 ) (-17.099998 7.03333283 6.57692338 -8.65384484 -1.13076973 1.7615366 ) (-11.0884609 -0.739743471 5.44615364 -6.89230824 -3.80769205 1.11538601 ) (-7.54615307 -7.07435895 1.63846135 -5.77692223 -1.63846135 5.77692223 )) NATURAL) (2 ((32 0) (22 0)) NIL ((-10. 0 0 0 0 0 )) NATURAL) (2 ((22 0) (22 100)) NIL ((0 100. 0 0 0 0 )) NATURAL) (2 ((22 100) (34 100)) NIL ((12. 0 0 0 0 0 )) NATURAL) (4 ((34 100) (50 63) (73 36) (108 17)) NIL ((14.933332 -39.13333 0 0 6.40000058 12.799999 ) (18.133331 -32.733329 6.40000058 12.799999 9.9999962 -4. ) (29.533332 -21.93333 16.399997 8.79999925 -16.399997 -8.79999925 )) NATURAL) (2 ((108 17) (131 12)) NIL ((23. -5. 0 0 0 0 )) NATURAL) (2 ((131 12) (131 100)) NIL ((0 88. 0 0 0 0 )) NATURAL) (11 ((131 100) (112 110) (74 132) (42 154) (20 185) (15 220) (23 250) (41 273) (67 288) (97 296) (131 300)) NIL ((-13.5979 6.63703728 0 0 -32.41259 20.177772 ) (-29.804195 16.725921 -32.41259 20.177772 48.062957 -28.888866 ) (-38.185302 22.459262 15.650373 -8.7110939 -9.83927728 23.377697 ) (-27.45457 25.437019 5.81109619 14.666603 15.2941398 -10.621927 ) (-13.9964027 34.792656 21.105236 4.04467488 -9.33728219 -10.889978 ) (2.44019174 33.39234 11.7679538 -6.8453045 -1.94501304 0.181846618 ) (13.2356376 26.637962 9.8229408 -6.66345788 -0.882658005 -1.83740043 ) (22.617248 19.055801 8.9402828 -8.5008583 -6.52435876 1.16775417 ) (28.295352 11.1388206 2.41592407 -7.33310414 2.98009395 3.16638088 ) (32.201324 5.38890744 5.39601803 -4.16672325 -5.39601803 4.16672325 )) NATURAL) (2 ((131 300) (131 316)) NIL ((0 16. 0 0 0 0 )) NATURAL) (2 ((131 316) (161 316)) NIL ((30. 0 0 0 0 0 )) NATURAL) (2 ((161 316) (161 298)) NIL ((0 -18. 0 0 0 0 )) NATURAL) (6 ((161 298) (173 296) (201 289) (223 282) (239 284) (244 294)) NIL ((7.34449769 -0.794258357 0 0 27.933013 -7.23444939 ) (21.311004 -4.4114828 27.933013 -7.23444939 -43.665069 6.17224789 ) (27.411479 -8.5598068 -15.732055 -1.06220078 14.72727 12.545454 ) (19.04306 -3.34928227 -1.00478506 11.483253 -15.244016 -2.35406685 ) (10.416267 6.9569378 -16.248802 9.1291866 16.248802 -9.1291866 )) NATURAL) (2 ((244 294) (256 294)) NIL ((12. 0 0 0 0 0 )) NATURAL)) ((6 ((161 14) (183 19) (201 34) (204 62) (187 79) (161 92)) NIL ((22.334926 3.44497585 0 0 -2.00956964 9.33014298 ) (21.330142 8.1100483 -2.00956964 9.33014298 -13.95215 13.349281 ) (12.3444957 24.11483 -15.961721 22.679424 -8.181818 -44.727264 ) (-7.7081337 24.430618 -24.143539 -22.047843 16.679424 21.559803 ) (-23.511959 13.1626777 -7.46411515 -0.488038778 7.46411515 0.488038778 )) NATURAL) (2 ((161 92) (161 14)) NIL ((0 -78. 0 0 0 0 )) NATURAL)) ((7 ((131 278) (111 274) (96 264) (88 248) (91 227) (111 210) (131 199)) NIL ((-20.961536 -2.71410227 0 0 5.76923085 -7.71538449 ) (-18.076919 -6.5717945 5.76923085 -7.71538449 1.15384578 2.57692337 ) (-11.730768 -12.998716 6.92307664 -5.1384611 1.61538315 -2.59230804 ) (-3.99999905 -19.43333 8.53845979 -7.73076916 16.3846168 13.7923069 ) (12.730768 -20.267948 24.923076 6.06153775 -31.153842 1.42307758 ) (22.076919 -13.494871 -6.2307682 7.4846153 6.2307682 -7.4846153 )) NATURAL) (2 ((131 199) (131 278)) NIL ((0 79. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 45Q) (FACE M R R) (WIDTH 334 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:31:37) (MADE-FROM NIL 40 130 25 71) (SPLINES ((3 ((271 294) (271 294) (94 0)) NIL ((44.25 73.5 0 0 -265.5 -441. ) (-88.5 -147. -265.5 -441. 265.5 441. )) NATURAL) (2 ((94 0) (62 0)) NIL ((-32. 0 0 0 0 0 )) NATURAL) (3 ((62 0) (239 294) (239 294)) NIL ((221.25 367.5 0 0 -265.5 -441. ) (88.5 147. -265.5 -441. 265.5 441. )) NATURAL) (2 ((239 294) (271 294)) NIL ((32. 0 0 0 0 0 )) NATURAL)) ((21 ((79 127) (105 133) (124 146) (136 164) (141 184) (144 214) (141 244) (136 264) (124 282) (105 295) (79 301) (53 295) (34 282) (22 264) (17 244) (14 214) (17 184) (22 164) (34 146) (53 133) (79 127)) NIL ((27.505523 4.49280548 0 0 -9.0331478 9.0431652 ) (22.988948 9.01438714 -9.0331478 9.0431652 3.16574478 -3.21582604 ) (15.538673 16.449638 -5.86740303 5.82733917 -3.62983322 -8.17986299 ) (7.8563528 18.187046 -9.49723626 -2.35252428 11.353588 17.935279 ) (4.0359106 24.802162 1.85635328 15.582756 -11.7845268 -15.561258 ) (-5.56930899E-7 32.604286 -9.92817498 0.0214966945 11.7845268 -15.6902389 ) (-4.03591156 24.780666 1.85635328 -15.668743 -11.353588 18.322219 ) (-7.85635377 18.273033 -9.49723626 2.65347767 3.62983227 -9.59864427 ) (-15.538673 16.127189 -5.86740399 -6.94516659 -3.16574383 2.07235908 ) (-22.988948 10.2182006 -9.0331478 -4.8728075 9.0331459 -10.690786 ) (-27.505523 -1.60187482E-7 -5.11072471E-7 -15.5635948 9.0331497 10.690784 ) (-22.988948 -10.2182006 9.0331497 -4.8728094 -3.16574574 -2.07235718 ) (-15.538673 -16.127189 5.86740399 -6.94516659 3.62983227 9.59864427 ) (-7.8563528 -18.273033 9.49723626 2.65347767 -11.353588 -18.322219 ) (-4.03591156 -24.780666 -1.85635352 -15.668743 11.7845287 15.6902389 ) (-3.91155481E-8 -32.604286 9.92817689 0.0214962214 -11.7845287 15.56126 ) (4.03591156 -24.802162 -1.85635352 15.5827579 11.353588 -17.935279 ) (7.85635377 -18.187046 9.49723626 -2.35252428 -3.62983227 8.17986299 ) (15.538673 -16.449638 5.86740399 5.82733917 3.16574383 3.21582604 ) (22.988948 -9.01438714 9.0331478 9.0431652 -9.0331478 -9.0431652 )) NATURAL)) ((17 ((79 141) (93 151) (96 172) (97 190) (96 214) (97 238) (96 256) (93 277) (79 287) (65 277) (62 256) (61 238) (62 214) (61 190) (62 172) (65 151) (79 141)) NIL ((16.803104 -0.223070144 0.182082086 24.092327 -17.364887 -10.93856 ) (8.302742 18.399978 -17.1828079 13.153766 19.73196 -23.861171 ) (0.985916854 19.623157 2.54915523 -10.707405 -7.5629673 22.383258 ) (-0.246411472 20.107383 -5.01381207 11.6758537 10.519905 -11.671869 ) (-2.70843506E-4 25.947299 5.50609303 0.00398380961 -10.516653 -11.695772 ) (0.247495413 20.103397 -5.01056099 -11.6917896 7.54671 22.454963 ) (-0.989710332 19.639091 2.5361495 10.763174 -19.670185 -24.12408 ) (-8.28865434 18.340225 -17.134037 -13.360906 17.134037 -9.9586353 ) (-16.8556709 -1.90734863E-6 0 -23.319541 17.134037 9.95863725 ) (-8.2886524 -18.340225 17.134037 -13.3609047 -19.670185 24.124076 ) (-0.989710093 -19.639091 -2.5361495 10.763174 7.54670907 -22.454959 ) (0.247495472 -20.103401 5.01056004 -11.6917877 -10.516653 11.69577 ) (-2.70843506E-4 -25.947299 -5.50609303 0.00398329925 10.519903 11.671871 ) (-0.246411145 -20.107383 5.0138111 11.6758556 -7.56296635 -22.383258 ) (0.985917092 -19.623157 -2.54915523 -10.707405 19.73196 23.861171 ) (8.3027439 -18.399974 17.1828079 13.153768 -17.364887 10.9385585 )) PSEUDOCYCLIC)) ((21 ((257 167) (283 161) (302 148) (314 130) (319 110) (322 80) (319 50) (314 30) (302 12) (283 -1) (257 -7) (231 -1) (212 12) (200 30) (195 50) (192 80) (195 110) (200 130) (212 148) (231 161) (257 167)) NIL ((27.627128 -0.143936932 -0.421261072 -15.064924 -8.49900819 10.058393 ) (22.956363 -10.1796646 -8.9202709 -5.0065298 3.0226221 -1.9024229 ) (15.547403 -16.137405 -5.8976488 -6.9089527 -3.59148312 9.5512943 ) (7.85401345 -18.27071 -9.4891319 2.64234209 11.343313 -18.302753 ) (4.03653813 -24.779747 1.85418176 -15.660413 -11.781774 15.659725 ) (-1.68442726E-4 -32.610298 -9.9275932 -6.87903608E-4 11.7837886 15.663852 ) (-4.03586579 -24.779056 1.85619712 15.663166 -11.3533897 -18.315147 ) (-7.85636616 -18.273464 -9.4971943 -2.65198326 3.62977982 9.59674836 ) (-15.538669 -16.127075 -5.86741448 6.9447651 -3.16573143 -2.07184219 ) (-22.988948 -10.218229 -9.0331459 4.8729229 9.0331459 10.6906147 ) (-27.505523 1.60187482E-7 0 15.563537 9.0331459 -10.6906128 ) (-22.988948 10.218231 9.0331459 4.87292385 -3.16573143 2.07184028 ) (-15.538669 16.127075 5.86741448 6.94476414 3.62977982 -9.59674645 ) (-7.85636426 18.273464 9.4971943 -2.65198326 -11.3533916 18.315151 ) (-4.03586579 24.779056 -1.85619783 15.6631679 11.783792 -15.663854 ) (-1.68045051E-4 32.610298 9.92759515 -6.88414671E-4 -11.781776 -15.659725 ) (4.03653813 24.779747 -1.854182 -15.660413 11.343313 18.302753 ) (7.8540144 18.27071 9.4891319 2.64234161 -3.59148312 -9.5512943 ) (15.547405 16.137405 5.8976488 -6.9089527 3.0226221 1.9024229 ) (22.956363 10.1796627 8.9202709 -5.0065298 -8.4990101 -10.058395 )) PSEUDOCYCLIC)) ((17 ((257 5) (271 15) (274 36) (275 54) (274 78) (275 102) (274 120) (271 141) (257 151) (243 141) (240 120) (239 102) (240 78) (239 54) (240 36) (243 15) (257 5)) NIL ((16.803104 -0.223070144 0.182082086 24.092327 -17.364887 -10.93856 ) (8.302742 18.399978 -17.1828079 13.153766 19.73196 -23.861171 ) (0.985916854 19.623157 2.54915523 -10.707405 -7.5629673 22.383258 ) (-0.246411472 20.107383 -5.01381207 11.6758537 10.519905 -11.671869 ) (-2.70843506E-4 25.947299 5.50609303 0.00398380961 -10.516653 -11.695772 ) (0.247495413 20.103397 -5.01056099 -11.6917896 7.54671 22.454963 ) (-0.989710332 19.639091 2.5361495 10.763174 -19.670185 -24.12408 ) (-8.28865434 18.340225 -17.134037 -13.360906 17.134037 -9.9586353 ) (-16.8556709 -1.90734863E-6 0 -23.319541 17.134037 9.95863725 ) (-8.2886524 -18.340225 17.134037 -13.3609047 -19.670185 24.124076 ) (-0.989710093 -19.639091 -2.5361495 10.763174 7.54670907 -22.454959 ) (0.247495472 -20.103401 5.01056004 -11.6917877 -10.516653 11.69577 ) (-2.70843506E-4 -25.947299 -5.50609303 0.00398329925 10.519903 11.671871 ) (-0.246411145 -20.107383 5.0138111 11.6758556 -7.56296635 -22.383258 ) (0.985917092 -19.623157 -2.54915523 -10.707405 19.73196 23.861171 ) (8.3027439 -18.399974 17.1828079 13.153768 -17.364887 10.9385585 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 46Q) (FACE M R R) (WIDTH 350 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:43:50) (MADE-FROM NIL 66 130 35 72) (SPLINES ((3 ((218 174) (218 174) (326 174)) NIL ((-27. 0 0 0 162. 0 ) (54. 0 162. 0 -162. 0 )) NATURAL) (2 ((326 174) (326 164)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((326 164) (307 154) (289 132) (271 108) (252 83)) NIL ((-19.25 -6.91071416 0 0 1.5 -18.535713 ) (-18.499996 -16.1785698 1.5 -18.535713 -1.5 20.678569 ) (-17.75 -24.375 -6.35782838E-8 2.14285707 -1.49999952 -4.17857075 ) (-18.5 -24.321426 -1.49999976 -2.03571415 1.49999976 2.03571415 )) NATURAL) (5 ((252 83) (270 64) (292 46) (315 38) (332 49)) NIL ((17.107139 -18.892856 0 0 5.35714245 -0.642857075 ) (19.785713 -19.214283 5.35714245 -0.642857075 -2.78571415 9.2142849 ) (23.75 -15.249998 2.5714283 8.5714283 -12.2142849 17.785709 ) (20.214283 2.2142868 -9.6428566 26.357139 9.6428566 -26.357139 )) NATURAL) (3 ((332 49) (332 49) (342 41)) NIL ((-2.5 2. 0 0 15. -12. ) (5. -4. 15. -12. -15. 12. )) NATURAL) (6 ((342 41) (323 17) (294 -4) (262 -11) (226 -3) (193 22)) NIL ((-16.444973 -24.004783 0 0 -15.3301429 0.0287084579 ) (-24.110046 -23.990428 -15.3301429 0.0287084579 16.6507149 17.856456 ) (-31.11483 -15.033491 1.32057380 17.885166 -9.27272607 -5.45454788 ) (-34.430618 0.124403000 -7.95215226 12.430618 14.440189 9.96172715 ) (-35.162674 17.5358848 6.48803807 22.392345 -6.48803807 -22.392345 )) NATURAL) (11 ((193 22) (161 3) (124 -7) (83 -6) (45 7) (22 29) (9 59) (12 94) (32 123) (62 143) (92 157)) NIL ((-30.93714 -20.81504 0 0 -6.37713147 10.8902549 ) (-34.125709 -15.369913 -6.37713147 10.8902549 1.88565731 -0.451280594 ) (-39.560012 -4.70529843 -4.49147415 10.438974 4.83450318 2.9148693 ) (-41.63423 7.19110966 0.343029499 13.3538437 20.776321 -5.2081909 ) (-30.903041 17.9408569 21.119354 8.14565278 -15.939798 -0.0821170807 ) (-17.753585 26.045452 5.1795559 8.0635357 12.9828586 -0.463335037 ) (-6.08260155 33.877319 18.162414 7.60020066 0.00836563111 -16.064537 ) (12.0839958 33.44525 18.17078 -8.4643383 -7.0163231 -1.27850341 ) (26.746616 24.341659 11.154457 -9.7428417 -13.943071 3.17855263 ) (30.929534 16.188095 -2.78861427 -6.5642891 2.78861427 6.5642891 )) NATURAL) (13 ((92 157) (78 188) (72 220) (75 249) (94 278) (126 295) (168 300) (205 296) (235 278) (247 246) (236 215) (209 192) (176 180)) NIL ((-15.753526 30.469062 0 0 10.521162 3.18560314 ) (-10.4929447 32.061866 10.521162 3.18560314 -4.60581589 -9.92801477 ) (-2.27469063 30.283462 5.91534615 -6.74241257 13.902105 12.5264606 ) (10.591711 29.804279 19.817451 5.78404808 -9.0026245 -22.177825 ) (25.907848 24.499412 10.8148269 -16.393779 4.10840798 4.18486214 ) (38.776878 10.198061 14.9232349 -12.2089176 -25.431003 5.43837738 ) (40.98461 0.708333016 -10.5077705 -6.77054024 7.6156225 -7.93837739 ) (34.284652 -10.0313968 -2.89214802 -14.708917 -17.031482 -3.68486214 ) (22.876762 -26.582744 -19.923633 -18.393779 -5.4896736 22.677825 ) (0.208288818 -33.63761 -25.413307 4.28404808 8.9901886 2.97353935 ) (-20.709922 -27.866794 -16.423118 7.25758744 11.528898 7.42801476 ) (-31.36859 -16.8951988 -4.8942194 14.685602 4.8942194 -14.685602 )) NATURAL) (3 ((176 180) (205 138) (236 100)) NIL ((28.5 -43. 0 0 3. 6. ) (30. -40. 3. 6. -3. -6. )) NATURAL) (6 ((236 100) (241 111) (244 131) (241 148) (230 159) (218 164)) NIL ((5.25358773 8.4593296 0 0 -1.52153110 15.244018 ) (4.49282265 16.081337 -1.52153110 15.244018 -4.39234448 -22.220092 ) (0.775119424 20.215309 -5.91387558 -6.97607613 -4.90909004 1.63636398 ) (-7.5933008 14.057415 -10.8229656 -5.33971215 12.0287056 -2.32535934 ) (-12.4019127 7.5550232 1.20574140 -7.66507149 -1.20574140 7.66507149 )) NATURAL) (2 ((218 164) (218 174)) NIL ((0 10. 0 0 0 0 )) NATURAL)) ((9 ((169 197) (179 218) (182 243) (176 269) (158 284) (144 271) (144 246) (155 217) (169 197)) NIL ((11.465389 20.08155 0 0 -8.79234124 5.51067734 ) (7.06921864 22.836891 -8.79234124 5.51067734 1.96170807 -3.55338669 ) (-0.742268205 26.570873 -6.83063317 1.95729065 -11.054491 -9.29713059 ) (-13.100147 23.8796 -17.885124 -7.33983994 24.256256 -31.25809 ) (-18.857139 0.910711766 6.3711338 -38.59793 10.029451 32.32952 ) (-7.4712801 -21.522457 16.400585 -6.26840878 -4.37407494 -2.06001568 ) (6.7422676 -28.820873 12.02651 -8.32842446 -10.533136 23.91053 ) (13.5022087 -25.194034 1.4933722 15.582105 -1.4933722 -15.582105 )) NATURAL)) ((4 ((100 141) (127 100) (150 68) (177 34)) NIL ((28.333332 -43.533332 0 0 -8. 15.1999988 ) (24.333332 -35.933326 -8. 15.1999988 16. -21.999996 ) (24.333332 -31.733333 8. -6.79999924 -8. 6.79999924 )) NATURAL) (7 ((177 34) (148 34) (121 43) (100 63) (88 91) (89 119) (100 141)) NIL ((-29.224357 -1.76794863 0 0 1.34615397 10.6076927 ) (-28.55128 3.53589726 1.34615397 10.6076927 5.26922989 0.961536408 ) (-24.57051 14.624359 6.6153841 11.569229 1.57692241 -2.45384407 ) (-17.166664 24.966663 8.1923065 9.11538507 6.42307854 -9.1461544 ) (-5.76282025 29.508972 14.615385 -0.0307693854 -3.2692337 -8.9615364 ) (7.2179489 24.997432 11.346151 -8.99230767 -11.346151 8.99230767 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 50Q) (FACE M R R) (WIDTH 162 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:49:11) (MADE-FROM NIL 142 130 35 72) (SPLINES ((2 ((152 300) (143 312)) NIL ((-9. 12. 0 0 0 0 )) NATURAL) (17 ((143 312) (122 303) (98 289) (74 268) (51 242) (33 213) (22 182) (14 144) (13 112) (14 80) (22 42) (33 11) (51 -18) (74 -44) (98 -65) (122 -79) (143 -88)) NIL ((-20.19886 -8.08247376 0 0 -4.80682278 -5.5051546 ) (-22.602272 -10.8350505 -4.80682278 -5.5051546 6.03411675 -2.47422695 ) (-24.392036 -17.577316 1.22729444 -7.97938157 -1.32964873 3.40206242 ) (-23.829566 -23.855667 -0.102354377 -4.57731915 5.28447628 0.865979195 ) (-21.289684 -28. 5.18212223 -3.71133995 4.19173908 5.13401985 ) (-14.01169 -29.144329 9.3738613 1.42268037 -10.051439 -15.402059 ) (-9.6635475 -35.422676 -0.677578807 -13.979379 12.014028 26.474224 ) (-4.33411217 -36.164947 11.3364505 12.494844 -14.0046749 -12.494842 ) (1.59256160E-7 -29.917522 -2.66822576 5.11072471E-7 14.0046749 -12.494846 ) (4.33411217 -36.164947 11.3364505 -12.494846 -12.014028 26.474227 ) (9.6635475 -35.422676 -0.677578926 13.979381 10.051441 -15.402061 ) (14.011692 -29.144329 9.3738632 -1.42268037 -4.19174195 5.13401985 ) (21.289684 -27.999996 5.18212128 3.71133947 -5.28447533 0.865979672 ) (23.829566 -23.855667 -0.102354094 4.57731915 1.32964825 3.40206146 ) (24.392036 -17.577316 1.22729420 7.9793806 -6.03411675 -2.474226 ) (22.602272 -10.8350505 -4.80682278 5.5051546 4.80682278 -5.5051546 )) NATURAL) (2 ((143 -88) (152 -76)) NIL ((9. 12. 0 0 0 0 )) NATURAL) (6 ((152 -76) (134 -59) (117 -33) (104 3) (97 45) (93 112)) NIL ((-18.081337 15.311004 0 0 0.488038302 10.13397 ) (-17.837318 20.37799 0.488038302 10.13397 3.55980825 3.33014298 ) (-15.5693779 32.177032 4.0478468 13.464113 3.27272701 -17.45454 ) (-9.88516618 36.91387 7.3205738 -3.99043036 -4.65071774 42.488029 ) (-4.8899517 54.167465 2.66985607 38.497604 -2.66985607 -38.497604 )) NATURAL) (6 ((93 112) (97 179) (104 221) (117 257) (134 283) (152 300)) NIL ((3.55502367 73.416259 0 0 2.66985655 -38.497604 ) (4.8899517 54.167457 2.66985655 -38.497604 4.65071678 42.488029 ) (9.88516618 36.91387 7.3205738 3.99042988 -3.27272797 -17.45454 ) (15.5693779 32.177032 4.04784584 -13.464113 -3.5598073 3.33014298 ) (17.837318 20.377986 0.488038302 -10.13397 -0.488038302 10.13397 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 51Q) (FACE M R R) (WIDTH 162 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:51:46) (MADE-FROM NIL 226 130 35 72) (SPLINES ((17 ((17 312) (38 303) (62 289) (86 268) (109 242) (127 213) (138 182) (146 144) (147 112) (146 80) (138 42) (127 11) (109 -18) (86 -44) (62 -65) (38 -79) (17 -88)) NIL ((20.19886 -8.08247376 0 0 4.80682278 -5.5051546 ) (22.602272 -10.8350505 4.80682278 -5.5051546 -6.03411675 -2.47422695 ) (24.392036 -17.577316 -1.22729444 -7.97938157 1.32964873 3.40206242 ) (23.829566 -23.855667 0.102354377 -4.57731915 -5.28447628 0.865979195 ) (21.289684 -28. -5.18212223 -3.71133995 -4.19173908 5.13401985 ) (14.01169 -29.144329 -9.3738613 1.42268037 10.051439 -15.402059 ) (9.6635475 -35.422676 0.677578807 -13.979379 -12.014028 26.474224 ) (4.33411217 -36.164947 -11.3364505 12.494844 14.0046749 -12.494842 ) (-1.59256160E-7 -29.917522 2.66822576 5.11072471E-7 -14.0046749 -12.494846 ) (-4.33411217 -36.164947 -11.3364505 -12.494846 12.014028 26.474227 ) (-9.6635475 -35.422676 0.677578926 13.979381 -10.051441 -15.402061 ) (-14.011692 -29.144329 -9.3738632 -1.42268037 4.19174195 5.13401985 ) (-21.289684 -27.999996 -5.18212128 3.71133947 5.28447533 0.865979672 ) (-23.829566 -23.855667 0.102354094 4.57731915 -1.32964825 3.40206146 ) (-24.392036 -17.577316 -1.22729420 7.9793806 6.03411675 -2.474226 ) (-22.602272 -10.8350505 4.80682278 5.5051546 -4.80682278 -5.5051546 )) NATURAL) (2 ((17 -88) (8 -76)) NIL ((-9. 12. 0 0 0 0 )) NATURAL) (11 ((8 -76) (26 -59) (43 -33) (56 3) (63 45) (67 112) (63 179) (56 221) (43 257) (26 283) (8 300)) NIL ((18.091159 15.311004 0 0 -0.546961427 10.13397 ) (17.817676 20.37799 -0.546961427 10.13397 -3.2651925 3.33014298 ) (15.63812 32.177032 -3.81215429 13.464113 -4.39226532 -17.45454 ) (9.6298332 36.91387 -8.2044201 -3.99043036 8.8342533 42.488029 ) (5.84254074 54.167465 0.629834295 38.497604 -12.9447498 -38.497604 ) (-1.99303030E-7 73.416259 -12.3149166 0 12.9447498 -38.497604 ) (-5.84254074 54.167457 0.629834414 -38.497604 -8.8342533 42.488029 ) (-9.6298332 36.91387 -8.2044201 3.99043083 4.39226532 -17.454544 ) (-15.63812 32.177032 -3.81215429 -13.464115 3.26519299 3.33014488 ) (-17.817676 20.377986 -0.546961308 -10.13397 0.546961308 10.13397 )) NATURAL) (2 ((8 300) (17 312)) NIL ((9. 12. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 52Q) (FACE M R R) (WIDTH 282 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:56:10) (MADE-FROM NIL 104 130 52 68) (SPLINES ((2 ((129 224) (114 288)) NIL ((-15. 64. 0 0 0 0 )) NATURAL) (2 ((114 288) (164 288)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((164 288) (149 224)) NIL ((-15. -64. 0 0 0 0 )) NATURAL) (2 ((149 224) (198 266)) NIL ((49. 42. 0 0 0 0 )) NATURAL) (2 ((198 266) (223 236)) NIL ((25. -30. 0 0 0 0 )) NATURAL) (2 ((223 236) (158 208)) NIL ((-65. -28. 0 0 0 0 )) NATURAL) (2 ((158 208) (223 180)) NIL ((65. -28. 0 0 0 0 )) NATURAL) (2 ((223 180) (198 150)) NIL ((-25. -30. 0 0 0 0 )) NATURAL) (2 ((198 150) (149 192)) NIL ((-49. 42. 0 0 0 0 )) NATURAL) (2 ((149 192) (164 128)) NIL ((15. -64. 0 0 0 0 )) NATURAL) (2 ((164 128) (114 128)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((114 128) (129 192)) NIL ((15. 64. 0 0 0 0 )) NATURAL) (2 ((129 192) (80 150)) NIL ((-49. -42. 0 0 0 0 )) NATURAL) (2 ((80 150) (55 180)) NIL ((-25. 30. 0 0 0 0 )) NATURAL) (2 ((55 180) (120 208)) NIL ((65. 28. 0 0 0 0 )) NATURAL) (2 ((120 208) (55 236)) NIL ((-65. 28. 0 0 0 0 )) NATURAL) (2 ((55 236) (80 266)) NIL ((25. 30. 0 0 0 0 )) NATURAL) (2 ((80 266) (129 224)) NIL ((49. -42. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 55Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:58:21) (MADE-FROM NIL 121 130 101 78) (SPLINES ((2 ((213 80) (53 80)) NIL ((-160. 0 0 0 0 0 )) NATURAL) (2 ((53 80) (53 140)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((53 140) (213 140)) NIL ((160. 0 0 0 0 0 )) NATURAL) (2 ((213 140) (213 80)) NIL ((0 -60. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 100Q) (FACE M R R) (WIDTH 241 0) (FIDUCIAL 275 275) (VERSION 0 3-OCT-77 15:01:19) (MADE-FROM NIL 136 116 118 52) (SPLINES ((12 ((158 121) (145 128) (128 130) (110 126) (92 113) (80 98) (72 82) (70 63) (74 45) (89 32) (112 29) (133 40)) NIL ((-11.972738 8.0720539 0 0 -6.16356755 -6.43233109 ) (-15.054521 4.85588837 -6.16356755 -6.43233109 6.8178396 2.16165829 ) (-17.809169 -0.495613098 0.654272318 -4.2706728 -3.10779333 -8.21430207 ) (-18.708793 -8.87343789 -2.45352125 -12.4849758 11.6133327 12.6955566 ) (-15.355648 -15.010633 9.1598129 0.210582316 -7.34554005 -0.567935109 ) (-9.86860658 -15.084018 1.81427216 -0.357352793 5.76882458 -4.42381764 ) (-5.16992092 -17.653282 7.58309746 -4.78117085 -3.72976494 6.26320649 ) (0.548294068 -19.302848 3.85333252 1.48203635 9.15023805 3.37098885 ) (8.9767456 -16.1353149 13.00357 4.85302544 -2.87118912 4.25283432 ) (20.544719 -9.15587426 10.132381 9.10585977 -15.6654758 9.61767388 ) (22.844364 4.75882149 -5.53309536 18.723533 5.53309536 -18.723533 )) NATURAL) (21 ((133 40) (140 32) (148 27) (164 25) (191 37) (208 57) (219 90) (215 123) (198 146) (174 160) (143 167) (108 164) (78 154) (51 134) (31 105) (23 71) (27 43) (43 17) (63 2) (88 -4) (112 -1)) NIL ((7.04713917 -8.83371926 0 0 -0.282836199 5.00231648 ) (6.9057207 -6.33256055 -0.282836199 5.00231648 7.41418076 -7.01158429 ) (10.329975 -4.83603668 7.1313448 -2.00926781 12.626108 23.044021 ) (23.774375 4.67670918 19.757453 21.034755 -39.918617 -19.16452 ) (23.572517 16.1292038 -20.161163 1.8702321 21.04837 17.614074 ) (13.935541 26.806472 0.887209058 19.48431 -20.274875 -21.291782 ) (4.68531037 35.644889 -19.387668 -1.8074727 6.05114175 -10.446945 ) (-11.676788 28.613945 -13.3365268 -12.254419 8.0703125 3.0795784 ) (-20.978157 17.8993149 -5.26621437 -9.1748409 -2.33239746 4.12862969 ) (-27.410572 10.7887878 -7.59861184 -5.04621125 1.25927829 -7.59409905 ) (-34.379539 1.94552779 -6.33933354 -12.64031 15.29528 8.24776269 ) (-33.071235 -6.5709009 8.95594789 -4.39254666 -8.4404068 -7.39695454 ) (-28.335495 -14.661924 0.515540362 -11.789501 6.46634865 3.34005737 ) (-24.586776 -24.781395 6.98188973 -8.4494438 6.57500649 0.0367221832 ) (-14.3173847 -33.212478 13.556896 -8.41272164 -2.76637268 20.51305 ) (-2.1436758 -31.368675 10.7905235 12.10033 4.49048424 -16.0889358 ) (10.8920898 -27.312812 15.2810077 -3.9886055 -15.195562 19.842693 ) (18.575313 -21.380069 0.0854441673 15.854089 8.29176904 -9.281847 ) (22.806644 -10.1669025 8.37721444 6.57224274 -11.971517 5.28469467 ) (25.1981 -0.952312470 -3.5943036 11.856937 3.5943036 -11.856937 )) NATURAL) (2 ((112 -1) (107 19)) NIL ((-5. 20. 0 0 0 0 )) NATURAL) (18 ((107 19) (86 18) (66 26) (50 47) (45 71) (49 95) (63 118) (83 134) (107 143) (136 146) (165 142) (186 130) (199 110) (200 86) (192 68) (184 59) (172 52) (162 56)) NIL ((-21.157852 -2.53653526 0 0 0.947122574 9.21921159 ) (-20.684291 2.07307052 0.947122574 9.21921159 1.26438713 7.9039421 ) (-19.104972 15.244255 2.2115097 17.123153 11.9953289 -16.834991 ) (-10.8958015 23.949909 14.206838 0.288160145 -7.24570466 -0.563958168 ) (-0.311814904 23.956092 6.96113396 -0.275798023 4.9874878 1.09082985 ) (9.1430626 24.225708 11.9486217 0.815032006 -6.70424843 -9.79936029 ) (17.739559 20.141059 5.24437332 -8.9843292 -2.17049026 2.10661602 ) (21.898689 12.210039 3.07388306 -6.8777132 3.38620949 1.37289524 ) (26.665676 6.01877404 6.46009255 -5.50481797 -5.37434674 -1.59819507 ) (30.438594 -0.285140633 1.08574557 -7.10301304 -11.8888187 -0.980116845 ) (25.579929 -7.87821198 -10.8030738 -8.08312989 4.92962837 -0.481334686 ) (17.241668 -16.202007 -5.8734455 -8.56446458 -7.82969475 2.90545654 ) (7.4533777 -23.313743 -13.70314 -5.65900803 2.38915062 12.859506 ) (-5.05518723 -22.542999 -11.3139896 7.20049954 16.273094 5.65650845 ) (-8.23262979 -12.514246 4.95910454 12.8570079 -13.481531 -17.485542 ) (-10.0142917 -8.40000917 -8.5224266 -4.62853527 13.653032 22.285663 ) (-11.710201 -1.88571024 5.13060665 17.657131 -5.13060665 -17.657131 )) NATURAL) (5 ((162 56) (178 116) (178 126) (168 126) (158 121)) NIL ((19.571426 72.76785 0 0 -21.428569 -76.60713 ) (8.8571415 34.464279 -21.428569 -76.60713 11.1428566 83.03569 ) (-7. -0.624999643 -10.285713 6.42857075 12.857141 -15.535713 ) (-10.857141 -1.96428537 2.5714283 -9.1071434 -2.5714283 9.1071434 )) NATURAL)) ((10 ((140 100) (136 107) (124 107) (108 95) (100 75) (104 56) (118 54) (128 64) (136 84) (140 100)) NIL ((-2.25083256 8.15301515 0 0 -10.4950046 -6.9180908 ) (-7.49833489 4.69396878 -10.4950046 -6.9180908 4.47502804 -7.409544 ) (-15.7558269 -5.92889405 -6.0199766 -14.3276348 16.59489 6.55626965 ) (-13.478355 -16.978393 10.5749149 -7.77136517 1.14539718 5.1844616 ) (-2.33074379 -22.157527 11.720312 -2.58690309 2.82352638 26.705879 ) (10.8013305 -11.391489 14.543838 24.118976 -24.439506 -16.007988 ) (13.1254139 4.72349262 -9.89566995 8.1109867 10.934515 7.32608224 ) (8.6970024 16.49752 1.03884577 15.4370689 -7.29855633 -25.296333 ) (6.08656979 19.286418 -6.25971127 -9.85926629 6.25971127 9.85926629 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 134Q) (FACE M R R) (WIDTH 312 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:06:12) (MADE-FROM NIL 60 130 27 74) (SPLINES ((2 ((241 0) (33 294)) NIL ((-208. 294. 0 0 0 0 )) NATURAL) (2 ((33 294) (65 294)) NIL ((32. 0 0 0 0 0 )) NATURAL) (2 ((65 294) (273 0)) NIL ((208. -294. 0 0 0 0 )) NATURAL) (2 ((273 0) (241 0)) NIL ((-32. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 176Q) (FACE M R R) (WIDTH 223 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:07:05) (MADE-FROM NIL 90 130 59 73) (SPLINES ((2 ((146 200) (186 200)) NIL ((40. 0 0 0 0 0 )) NATURAL) (12 ((186 200) (184 188) (181 173) (173 156) (162 146) (149 142) (133 141) (115 147) (101 154) (87 157) (77 151) (74 143)) NIL ((-2.0406394 -11.4451789 0 0 0.243838072 -3.3289156 ) (-1.91872048 -13.109638 0.243838072 -3.3289156 -7.21918965 -1.35542106 ) (-5.28447724 -17.116264 -6.97535229 -4.68433666 4.63292313 14.7505989 ) (-9.943367 -14.4253 -2.34242868 10.066263 0.687495947 -3.64697933 ) (-11.942049 -6.18252755 -1.65493273 6.41928387 -1.38290715 -6.1626854 ) (-14.288435 -2.84458589 -3.03783989 0.256598294 -1.15586662 10.2977218 ) (-17.904209 2.5608735 -4.1937065 10.554321 12.006374 -11.0282058 ) (-16.094726 7.60109139 7.81266785 -0.473885357 -10.8696327 -2.18489456 ) (-13.716875 6.03475857 -3.05696487 -2.6587801 7.47215558 -10.23221 ) (-13.037763 -1.74012756 4.4151907 -12.890991 4.98101139 13.113739 ) (-6.13206673 -8.07424928 9.3962021 0.222748071 -9.3962021 -0.222748071 )) NATURAL) (2 ((74 143) (34 143)) NIL ((-40. 0 0 0 0 0 )) NATURAL) (12 ((34 143) (36 155) (39 170) (47 187) (58 197) (71 201) (87 202) (105 196) (119 189) (133 186) (143 192) (146 200)) NIL ((2.0406394 11.4451789 0 0 -0.243838072 3.3289156 ) (1.91872048 13.109638 -0.243838072 3.3289156 7.21918965 1.35542106 ) (5.28447724 17.116264 6.97535229 4.68433666 -4.63292313 -14.7505989 ) (9.943367 14.4253 2.34242868 -10.066263 -0.687495947 3.64697933 ) (11.942049 6.18252755 1.65493273 -6.41928387 1.38290715 6.1626854 ) (14.288435 2.84458589 3.03783989 -0.256598294 1.15586662 -10.2977218 ) (17.904209 -2.5608735 4.1937065 -10.554321 -12.006374 11.0282058 ) (16.094726 -7.60109139 -7.81266785 0.473885357 10.8696327 2.18489456 ) (13.716875 -6.03475857 3.05696487 2.6587801 -7.47215558 10.23221 ) (13.037763 1.74012756 -4.4151907 12.890991 -4.98101139 -13.113739 ) (6.13206673 8.07424928 -9.3962021 -0.222748071 9.3962021 0.222748071 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 30Q) (FACE M R R) (WIDTH 490 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:10:26) (MADE-FROM NIL 13 131 0 0) (SPLINES ((2 ((0 -53) (489 -53)) NIL ((489. 0 0 0 0 0 )) NATURAL) (2 ((489 -53) (489 -93)) NIL ((0 -40. 0 0 0 0 )) NATURAL) (2 ((489 -93) (0 -93)) NIL ((-489. 0 0 0 0 0 )) NATURAL) (2 ((0 -93) (0 -53)) NIL ((0 40. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 40Q) (FACE M R R) (WIDTH 312 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:11:15) (MADE-FROM NIL 142 130 0 0) (SPLINES)) ((FAMILY TIMESROMAND) (CHARACTER 53Q) (FACE M R R) (WIDTH 327 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:36:02) (MADE-FROM NIL 122 130 68 75) (SPLINES ((2 ((132 0) (192 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((192 0) (192 80)) NIL ((0 80. 0 0 0 0 )) NATURAL) (2 ((192 80) (272 80)) NIL ((80. 0 0 0 0 0 )) NATURAL) (2 ((272 80) (272 140)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((272 140) (192 140)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (2 ((192 140) (192 220)) NIL ((0 80. 0 0 0 0 )) NATURAL) (2 ((192 220) (132 220)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((132 220) (132 140)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (2 ((132 140) (52 140)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (2 ((52 140) (52 80)) NIL ((0 -60. 0 0 0 0 )) NATURAL) (2 ((52 80) (132 80)) NIL ((80. 0 0 0 0 0 )) NATURAL) (2 ((132 80) (132 0)) NIL ((0 -80. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 75Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:36:52) (MADE-FROM NIL 120 130 84 94) (SPLINES ((2 ((214 40) (54 40)) NIL ((-160. 0 0 0 0 0 )) NATURAL) (2 ((54 40) (54 100)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((54 100) (214 100)) NIL ((160. 0 0 0 0 0 )) NATURAL) (2 ((214 100) (214 40)) NIL ((0 -60. 0 0 0 0 )) NATURAL)) ((2 ((54 140) (54 200)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((54 200) (214 200)) NIL ((160. 0 0 0 0 0 )) NATURAL) (2 ((214 200) (214 140)) NIL ((0 -60. 0 0 0 0 )) NATURAL) (2 ((214 140) (54 140)) NIL ((-160. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/TIMESROMAN.S3-SF b/lispusers/TIMESROMAN.S3-SF new file mode 100644 index 00000000..0185738c --- /dev/null +++ b/lispusers/TIMESROMAN.S3-SF @@ -0,0 +1 @@ + ((FAMILY TIMESROMAND) (CHARACTER 56Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:21:11) (MADE-FROM NIL 201 130 35 72) (SPLINES ((17 ((86 -6) (67 -3) (52 4) (44 13) (41 27) (44 41) (52 50) (67 57) (86 60) (105 57) (120 50) (128 41) (131 27) (128 13) (120 4) (105 -3) (86 -6)) NIL ((-19.639171 1.98203754 0 0 3.83505154 6.10777474 ) (-17.721649 5.0359249 3.83505154 6.10777474 4.82474232 -6.53887368 ) (-11.474226 7.87426186 8.65979386 -0.431099415 -5.1340208 8.04772187 ) (-5.38144303 11.4670238 3.52577257 7.6166229 3.71134043 -7.65201569 ) (8.00937414E-8 15.2576389 7.237113 -0.0353937074 -3.71133947 -7.43965436 ) (5.38144303 11.5024166 3.52577353 -7.47504807 5.13401795 7.41063786 ) (11.474226 7.73268796 8.65979196 -0.0644102097 -4.8247404 -4.20289994 ) (17.721649 5.5668268 3.83505154 -4.26731014 -3.83505106 -2.59903431 ) (19.639171 0 1.27768117E-7 -6.86634446 -3.835052 2.59903335 ) (17.721649 -5.56682778 -3.835052 -4.2673111 -4.82473946 4.20290089 ) (11.474226 -7.73268796 -8.65979196 -0.0644097030 5.1340189 -7.4106388 ) (5.38144303 -11.5024166 -3.52577305 -7.475049 -3.71133995 7.4396553 ) (-1.59256160E-7 -15.2576389 -7.237113 -0.0353935584 3.71133995 7.65201569 ) (-5.38144303 -11.4670238 -3.52577305 7.6166229 -5.1340208 -8.04772187 ) (-11.474226 -7.87426186 -8.65979386 -0.431099653 4.82474232 6.53887368 ) (-17.721649 -5.0359249 -3.83505154 6.10777474 3.83505154 -6.10777474 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 72Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:22:34) (MADE-FROM NIL 201 130 35 72) (SPLINES ((17 ((86 205) (67 202) (52 195) (44 186) (41 172) (44 158) (52 149) (67 142) (86 139) (105 142) (120 149) (128 158) (131 172) (128 186) (120 195) (105 202) (86 205)) NIL ((-19.818656 -0.00128221511 0.621745348 -6.86153794 3.04670906 2.59230709 ) (-17.673553 -5.5666666 3.66845465 -4.26923085 5.0359783 4.20769406 ) (-11.487112 -7.73204995 8.70443345 -0.0615364760 -5.19062138 -7.4230852 ) (-5.37798977 -11.5051288 3.51381207 -7.484622 3.72650528 7.48464394 ) (-9.24904831E-4 -15.2474289 7.24031735 2.27427262E-5 -3.7154026 7.48450757 ) (5.38169098 -11.5051517 3.52491474 7.48453046 5.13510609 -7.42267228 ) (11.474159 -7.7319584 8.6600208 0.0618574098 -4.8250265 4.20618153 ) (17.721668 -5.56700897 3.83499432 4.2680397 -3.83499432 2.59793949 ) (19.6391639 3.18512320E-7 0 6.8659792 -3.83499432 -2.59793949 ) (17.721668 5.56700993 -3.83499432 4.2680397 -4.82502842 -4.20618153 ) (11.474159 7.7319584 -8.66002275 0.0618574098 5.135108 7.4226713 ) (5.38169098 11.5051517 -3.52491427 7.4845295 -3.71540403 -7.4845066 ) (-9.25144181E-4 15.2474289 -7.2403183 2.27427262E-5 3.72650576 -7.48464299 ) (-5.37798977 11.5051288 -3.51381254 -7.48462105 -5.1906185 7.42308427 ) (-11.487112 7.73204995 -8.70443154 -0.0615367144 5.03597546 -4.20769406 ) (-17.673553 5.5666666 -3.6684556 -4.26923085 3.04671001 -2.59230709 )) PSEUDOCYCLIC)) ((17 ((86 -6) (67 -3) (52 4) (44 13) (41 27) (44 41) (52 50) (67 57) (86 60) (105 57) (120 50) (128 41) (131 27) (128 13) (120 4) (105 -3) (86 -6)) NIL ((-19.818656 0.00128221511 0.621745348 6.86153794 3.04670906 -2.59230709 ) (-17.673553 5.5666666 3.66845465 4.26923085 5.0359783 -4.20769406 ) (-11.487112 7.73204995 8.70443345 0.0615364760 -5.19062138 7.4230852 ) (-5.37798977 11.5051288 3.51381207 7.484622 3.72650528 -7.48464394 ) (-9.24904831E-4 15.2474289 7.24031735 -2.27427262E-5 -3.7154026 -7.48450757 ) (5.38169098 11.5051517 3.52491474 -7.48453046 5.13510609 7.42267228 ) (11.474159 7.7319584 8.6600208 -0.0618574098 -4.8250265 -4.20618153 ) (17.721668 5.56700897 3.83499432 -4.2680397 -3.83499432 -2.59793949 ) (19.6391639 -3.18512320E-7 0 -6.8659792 -3.83499432 2.59793949 ) (17.721668 -5.56700993 -3.83499432 -4.2680397 -4.82502842 4.20618153 ) (11.474159 -7.7319584 -8.66002275 -0.0618574098 5.135108 -7.4226713 ) (5.38169098 -11.5051517 -3.52491427 -7.4845295 -3.71540403 7.4845066 ) (-9.25144181E-4 -15.2474289 -7.2403183 -2.27427262E-5 3.72650576 7.48464299 ) (-5.37798977 -11.5051288 -3.51381254 7.48462105 -5.1906185 -7.42308427 ) (-11.487112 -7.73204995 -8.70443154 0.0615367144 5.03597546 4.20769406 ) (-17.673553 -5.5666666 -3.6684556 4.26923085 3.04671001 2.59230709 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 73Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:26:06) (MADE-FROM NIL 201 130 35 72) (SPLINES ((17 ((86 205) (67 202) (52 195) (44 186) (41 172) (44 158) (52 149) (67 142) (86 139) (105 142) (120 149) (128 158) (131 172) (128 186) (120 195) (105 202) (86 205)) NIL ((-19.818656 -0.00128221511 0.621745348 -6.86153794 3.04670906 2.59230709 ) (-17.673553 -5.5666666 3.66845465 -4.26923085 5.0359783 4.20769406 ) (-11.487112 -7.73204995 8.70443345 -0.0615364760 -5.19062138 -7.4230852 ) (-5.37798977 -11.5051288 3.51381207 -7.484622 3.72650528 7.48464394 ) (-9.24904831E-4 -15.2474289 7.24031735 2.27427262E-5 -3.7154026 7.48450757 ) (5.38169098 -11.5051517 3.52491474 7.48453046 5.13510609 -7.42267228 ) (11.474159 -7.7319584 8.6600208 0.0618574098 -4.8250265 4.20618153 ) (17.721668 -5.56700897 3.83499432 4.2680397 -3.83499432 2.59793949 ) (19.6391639 3.18512320E-7 0 6.8659792 -3.83499432 -2.59793949 ) (17.721668 5.56700993 -3.83499432 4.2680397 -4.82502842 -4.20618153 ) (11.474159 7.7319584 -8.66002275 0.0618574098 5.135108 7.4226713 ) (5.38169098 11.5051517 -3.52491427 7.4845295 -3.71540403 -7.4845066 ) (-9.25144181E-4 15.2474289 -7.2403183 2.27427262E-5 3.72650576 -7.48464299 ) (-5.37798977 11.5051288 -3.51381254 -7.48462105 -5.1906185 7.42308427 ) (-11.487112 7.73204995 -8.70443154 -0.0615367144 5.03597546 -4.20769406 ) (-17.673553 5.5666666 -3.6684556 -4.26923085 3.04671001 -2.59230709 )) PSEUDOCYCLIC)) ((24 ((92 -4) (78 -6) (59 -3) (44 4) (36 13) (33 27) (36 41) (44 50) (59 57) (78 60) (101 58) (121 49) (135 33) (140 6) (134 -19) (114 -44) (94 -58) (75 -66) (52 -73) (44 -70) (50 -63) (69 -50) (85 -29) (92 -4)) NIL ((-12.4890136 -3.06699467 0 0 -9.06590844 6.4019699 ) (-17.0219688 0.133990109 -9.06590844 6.4019699 15.3295459 -2.0098505 ) (-18.423103 5.53103447 6.26363755 4.3921194 1.74772072 -4.3625698 ) (-11.285606 7.74186898 8.01135827 0.0295492597 -4.3204298 7.4601326 ) (-5.4344635 11.5014858 3.69092798 7.4896822 3.53399801 -7.47796345 ) (0.0234638825 15.2521858 7.224926 0.0117186158 -3.8155613 -7.548275 ) (5.3406086 11.489765 3.4093647 -7.5365572 5.7282505 7.67106915 ) (11.614099 7.78874398 9.1376152 0.134512752 -7.0974474 -5.13600445 ) (17.202991 5.35525418 2.04016733 -5.0014925 4.6615448 0.872951508 ) (21.573928 0.790237070 6.7017126 -4.128541 -11.5487308 -4.35579968 ) (22.501277 -5.51620388 -4.8470192 -8.48434068 -0.466615677 4.55025006 ) (17.4209518 -11.72542 -5.31363487 -3.93409014 -4.58480644 -13.845201 ) (9.8149128 -22.582111 -9.8984413 -17.779293 0.805843354 26.830558 ) (0.319392502 -26.946125 -9.09259797 9.0512676 -10.638561 -15.4770488 ) (-14.092487 -25.63338 -19.731159 -6.4257822 23.748405 23.07764 ) (-21.94944 -20.520339 4.0172472 16.651859 -0.355079651 -10.8335209 ) (-18.109733 -9.28524209 3.66216755 5.81833744 -16.328083 -9.74355317 ) (-22.61161 -8.33868218 -12.665918 -3.9252162 35.667419 19.807739 ) (-17.443813 -2.36002731 23.001506 15.882526 -12.341625 -15.487413 ) (-0.613120318 5.77879143 10.6598816 0.395112217 7.6990776 6.14191056 ) (13.896299 9.2448597 18.358959 6.53702355 -24.454681 2.91976929 ) (20.027915 17.2417679 -6.09572316 9.4567928 -5.88034535 -5.8209915 ) (10.9920215 23.788063 -11.976068 3.63580132 11.976068 -3.63580132 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 54Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:27:04) (MADE-FROM NIL 201 130 35 72) (SPLINES ((24 ((92 -4) (78 -6) (59 -3) (44 4) (36 13) (33 27) (36 41) (44 50) (59 57) (78 60) (101 58) (121 49) (135 33) (140 6) (134 -19) (114 -44) (94 -58) (75 -66) (52 -73) (44 -70) (50 -63) (69 -50) (85 -29) (92 -4)) NIL ((-12.4890136 -3.06699467 0 0 -9.06590844 6.4019699 ) (-17.0219688 0.133990109 -9.06590844 6.4019699 15.3295459 -2.0098505 ) (-18.423103 5.53103447 6.26363755 4.3921194 1.74772072 -4.3625698 ) (-11.285606 7.74186898 8.01135827 0.0295492597 -4.3204298 7.4601326 ) (-5.4344635 11.5014858 3.69092798 7.4896822 3.53399801 -7.47796345 ) (0.0234638825 15.2521858 7.224926 0.0117186158 -3.8155613 -7.548275 ) (5.3406086 11.489765 3.4093647 -7.5365572 5.7282505 7.67106915 ) (11.614099 7.78874398 9.1376152 0.134512752 -7.0974474 -5.13600445 ) (17.202991 5.35525418 2.04016733 -5.0014925 4.6615448 0.872951508 ) (21.573928 0.790237070 6.7017126 -4.128541 -11.5487308 -4.35579968 ) (22.501277 -5.51620388 -4.8470192 -8.48434068 -0.466615677 4.55025006 ) (17.4209518 -11.72542 -5.31363487 -3.93409014 -4.58480644 -13.845201 ) (9.8149128 -22.582111 -9.8984413 -17.779293 0.805843354 26.830558 ) (0.319392502 -26.946125 -9.09259797 9.0512676 -10.638561 -15.4770488 ) (-14.092487 -25.63338 -19.731159 -6.4257822 23.748405 23.07764 ) (-21.94944 -20.520339 4.0172472 16.651859 -0.355079651 -10.8335209 ) (-18.109733 -9.28524209 3.66216755 5.81833744 -16.328083 -9.74355317 ) (-22.61161 -8.33868218 -12.665918 -3.9252162 35.667419 19.807739 ) (-17.443813 -2.36002731 23.001506 15.882526 -12.341625 -15.487413 ) (-0.613120318 5.77879143 10.6598816 0.395112217 7.6990776 6.14191056 ) (13.896299 9.2448597 18.358959 6.53702355 -24.454681 2.91976929 ) (20.027915 17.2417679 -6.09572316 9.4567928 -5.88034535 -5.8209915 ) (10.9920215 23.788063 -11.976068 3.63580132 11.976068 -3.63580132 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 7Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:31:50) (MADE-FROM NIL 142 130 35 72) (SPLINES ((24 ((80 228) (94 230) (113 227) (128 220) (136 211) (139 197) (136 183) (128 174) (113 167) (94 164) (71 166) (51 175) (37 191) (31 218) (38 243) (58 268) (78 282) (97 290) (120 297) (128 294) (122 287) (103 274) (87 253) (80 228)) NIL ((12.4890136 3.06699467 0 0 9.06591035 -6.4019699 ) (17.0219688 -0.133990109 9.06591035 -6.4019699 -15.329553 2.0098505 ) (18.423103 -5.53103447 -6.26364327 -4.3921194 -1.74769401 4.3625698 ) (11.285612 -7.74186898 -8.01133729 -0.0295492597 4.32033539 -7.4601326 ) (5.43444157 -11.5014858 -3.69100189 -7.4896822 -3.53364849 7.47796345 ) (-0.0233840942 -15.2521858 -7.22465039 -0.0117186158 3.81425572 7.548275 ) (-5.34090615 -11.489765 -3.41039467 7.5365572 -5.7233753 -7.67106915 ) (-11.612989 -7.78874398 -9.13377 -0.134512752 7.07924843 5.13600445 ) (-17.207134 -5.35525418 -2.05452156 5.0014925 -4.59362126 -0.872951508 ) (-21.558467 -0.790237070 -6.6481428 4.128541 11.2952366 4.35579968 ) (-22.55899 5.51620388 4.64709378 8.48434068 1.4126749 -4.55025006 ) (-17.205558 11.72542 6.05976868 3.93409014 1.05406284 13.845201 ) (-10.618759 22.582111 7.1138315 17.779293 6.3710699 -26.830558 ) (-0.319392502 26.946125 13.484901 -9.0512676 3.46165085 15.4770488 ) (14.896333 25.63338 16.946552 6.4257822 -20.217666 -23.07764 ) (21.73405 20.520339 -3.2711153 -16.651859 -0.590978146 10.8335209 ) (18.167446 9.28524209 -3.86209345 -5.81833744 16.581581 9.74355317 ) (22.596145 8.33868218 12.719488 3.9252162 -35.735343 -19.807739 ) (17.447956 2.36002731 -23.015861 -15.882526 12.359827 15.487413 ) (0.612009645 -5.77879143 -10.656034 -0.395112217 -7.7039547 -6.14191056 ) (-13.8960018 -9.2448597 -18.359989 -6.53702355 24.455986 -2.91976929 ) (-20.027996 -17.2417679 6.09599686 -9.4567928 5.88000298 5.8209915 ) (-10.9919986 -23.788063 11.9759998 -3.63580132 -11.9759998 3.63580132 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 47Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:37:31) (MADE-FROM NIL 201 130 35 72) (SPLINES ((24 ((92 236) (85 211) (69 190) (50 177) (44 170) (52 167) (75 174) (94 182) (114 196) (134 221) (140 246) (135 273) (121 289) (101 298) (78 300) (59 297) (44 290) (36 281) (33 267) (36 253) (44 244) (59 237) (78 234) (92 236)) NIL ((-5.00398827 -25.605964 0 0 -11.976068 3.63580179 ) (-10.992023 -23.788063 -11.976068 3.63580179 5.8803463 5.82099056 ) (-20.027915 -17.2417679 -6.0957222 9.4567928 24.454681 -2.91976929 ) (-13.896299 -9.2448597 18.358959 6.53702355 -7.6990757 -6.1419115 ) (0.613121629 -5.77879143 10.659883 0.395111680 12.341619 15.487413 ) (17.443817 2.36002684 23.001503 15.882526 -35.667419 -19.807739 ) (22.61161 8.33868218 -12.665918 -3.9252162 16.328083 9.74355508 ) (18.109733 9.28524209 3.66216755 5.81833935 0.355080604 10.8335189 ) (21.949443 20.520343 4.01724816 16.651859 -23.748405 -23.07764 ) (14.092485 25.63338 -19.731159 -6.4257822 10.638561 15.4770488 ) (-0.319393754 26.946125 -9.09259797 9.0512676 -0.805843354 -26.830555 ) (-9.8149128 22.582111 -9.8984413 -17.779289 4.58480644 13.8451976 ) (-17.4209518 11.72542 -5.31363487 -3.93409157 0.466615677 -4.5502491 ) (-22.501277 5.51620293 -4.8470192 -8.48434068 11.5487308 4.35579968 ) (-21.573928 -0.790237547 6.7017126 -4.128541 -4.6615448 -0.872951508 ) (-17.202991 -5.35525418 2.04016733 -5.0014925 7.0974493 5.1360054 ) (-11.614099 -7.78874398 9.1376171 0.134513020 -5.72825337 -7.67107106 ) (-5.3406086 -11.489765 3.40936375 -7.53655816 3.81556225 7.54827595 ) (-0.0234634876 -15.2521858 7.224926 0.0117186382 -3.53399706 7.4779644 ) (5.4344635 -11.5014858 3.69092894 7.48968316 4.32042694 -7.46013356 ) (11.285606 -7.74186898 8.01135636 0.0295491926 -1.74771785 4.3625698 ) (18.423103 -5.53103447 6.2636385 4.3921194 -15.3295479 2.0098505 ) (17.0219688 -0.133989960 -9.06591035 6.4019699 9.06591035 -6.4019699 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 42Q) (FACE M R R) (WIDTH 303 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:38:40) (MADE-FROM NIL 24 130 0 0) (SPLINES ((8 ((211 300) (191 297) (175 289) (168 275) (170 252) (180 223) (191 189) (198 168)) NIL ((-20.560287 -1.93747854 0 0 3.36173153 -6.37512875 ) (-18.879421 -5.1250429 3.36173153 -6.37512875 7.19134236 1.87564373 ) (-11.922018 -10.562349 10.5530738 -4.49948502 -2.1271038 -7.1274452 ) (-2.43249702 -18.6255569 8.42597009 -11.62693 1.31707191 8.63414384 ) (6.65200997 -25.935417 9.743042 -2.99278593 -9.14118577 -9.4091358 ) (11.824457 -33.632766 0.601855278 -12.401922 -6.75231934 35.002395 ) (9.05015374 -28.533493 -6.15046406 22.600479 6.15046406 -22.600479 )) NATURAL) (2 ((198 168) (224 168)) NIL ((26. 0 0 0 0 0 )) NATURAL) (8 ((224 168) (231 189) (242 223) (252 252) (254 275) (247 289) (231 297) (211 300)) NIL ((5.97492218 17.233253 0 0 6.1504631 22.600479 ) (9.05015374 28.533493 6.1504631 22.600479 -6.75231839 -35.002395 ) (11.824457 33.632766 -0.601855397 -12.401922 -9.14118577 9.4091358 ) (6.652009 25.935417 -9.743042 -2.99278593 1.31707191 -8.63414575 ) (-2.4324975 18.6255569 -8.42597009 -11.626932 -2.1271038 7.12744809 ) (-11.9220199 10.562349 -10.5530738 -4.49948406 7.19134236 -1.87564468 ) (-18.879421 5.1250429 -3.36173153 -6.37512875 3.36173153 6.37512875 )) NATURAL)) ((8 ((91 300) (71 297) (55 289) (48 275) (50 252) (60 223) (71 189) (78 168)) NIL ((-20.560287 -1.93747854 0 0 3.36173153 -6.37512875 ) (-18.879421 -5.1250429 3.36173153 -6.37512875 7.19134236 1.87564373 ) (-11.922018 -10.562349 10.5530738 -4.49948502 -2.1271038 -7.1274452 ) (-2.43249702 -18.6255569 8.42597009 -11.62693 1.31707191 8.63414384 ) (6.65200997 -25.935417 9.743042 -2.99278593 -9.14118577 -9.4091358 ) (11.824457 -33.632766 0.601855278 -12.401922 -6.75231934 35.002395 ) (9.05015374 -28.533493 -6.15046406 22.600479 6.15046406 -22.600479 )) NATURAL) (2 ((78 168) (104 168)) NIL ((26. 0 0 0 0 0 )) NATURAL) (8 ((104 168) (111 189) (122 223) (132 252) (134 275) (127 289) (111 297) (91 300)) NIL ((5.97492218 17.233253 0 0 6.1504631 22.600479 ) (9.05015374 28.533493 6.1504631 22.600479 -6.75231839 -35.002395 ) (11.824457 33.632766 -0.601855397 -12.401922 -9.14118577 9.4091358 ) (6.652009 25.935417 -9.743042 -2.99278593 1.31707191 -8.63414575 ) (-2.4324975 18.6255569 -8.42597009 -11.626932 -2.1271038 7.12744809 ) (-11.9220199 10.562349 -10.5530738 -4.49948406 7.19134236 -1.87564468 ) (-18.879421 5.1250429 -3.36173153 -6.37512875 3.36173153 6.37512875 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 57Q) (FACE M R R) (WIDTH 312 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:41:07) (MADE-FROM NIL 117 130 0 0) (SPLINES ((2 ((35 0) (67 0)) NIL ((32. 0 0 0 0 0 )) NATURAL) (2 ((67 0) (270 294)) NIL ((203. 294. 0 0 0 0 )) NATURAL) (2 ((270 294) (238 294)) NIL ((-32. 0 0 0 0 0 )) NATURAL) (2 ((238 294) (35 0)) NIL ((-203. -294. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 74Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:44:20) (MADE-FROM NIL 88 130 0 0) (SPLINES ((2 ((166 0) (38 147)) NIL ((-128. 147. 0 0 0 0 )) NATURAL) (2 ((38 147) (166 294)) NIL ((128. 147. 0 0 0 0 )) NATURAL) (2 ((166 294) (226 294)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((226 294) (98 147)) NIL ((-128. -147. 0 0 0 0 )) NATURAL) (2 ((98 147) (226 0)) NIL ((128. -147. 0 0 0 0 )) NATURAL) (2 ((226 0) (166 0)) NIL ((-60. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 76Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:46:22) (MADE-FROM NIL 155 130 0 0) (SPLINES ((2 ((39 0) (167 147)) NIL ((128. 147. 0 0 0 0 )) NATURAL) (2 ((167 147) (39 294)) NIL ((-128. 147. 0 0 0 0 )) NATURAL) (2 ((39 294) (99 294)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((99 294) (227 147)) NIL ((128. -147. 0 0 0 0 )) NATURAL) (2 ((227 147) (99 0)) NIL ((-128. -147. 0 0 0 0 )) NATURAL) (2 ((99 0) (39 0)) NIL ((-60. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 77Q) (FACE M R R) (WIDTH 243 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:48:44) (MADE-FROM NIL 166 130 35 72) (SPLINES ((17 ((121 -6) (140 -3) (155 4) (163 13) (166 27) (163 41) (155 50) (140 57) (121 60) (102 57) (87 50) (79 41) (76 27) (79 13) (87 4) (102 -3) (121 -6)) NIL ((19.639171 1.98203754 0 0 -3.83505154 6.10777474 ) (17.721649 5.0359249 -3.83505154 6.10777474 -4.82474232 -6.53887368 ) (11.474226 7.87426186 -8.65979386 -0.431099415 5.1340208 8.04772187 ) (5.38144303 11.4670238 -3.52577257 7.6166229 -3.71134043 -7.65201569 ) (-8.00937414E-8 15.2576389 -7.237113 -0.0353937074 3.71133947 -7.43965436 ) (-5.38144303 11.5024166 -3.52577353 -7.47504807 -5.13401795 7.41063786 ) (-11.474226 7.73268796 -8.65979196 -0.0644102097 4.8247404 -4.20289994 ) (-17.721649 5.5668268 -3.83505154 -4.26731014 3.83505106 -2.59903431 ) (-19.639171 0 -1.27768117E-7 -6.86634446 3.835052 2.59903335 ) (-17.721649 -5.56682778 3.835052 -4.2673111 4.82473946 4.20290089 ) (-11.474226 -7.73268796 8.65979196 -0.0644097030 -5.1340189 -7.4106388 ) (-5.38144303 -11.5024166 3.52577305 -7.475049 3.71133995 7.4396553 ) (1.59256160E-7 -15.2576389 7.237113 -0.0353935584 -3.71133995 7.65201569 ) (5.38144303 -11.4670238 3.52577305 7.6166229 5.1340208 -8.04772187 ) (11.474226 -7.87426186 8.65979386 -0.431099653 -4.82474232 6.53887368 ) (17.721649 -5.0359249 3.83505154 6.10777474 -3.83505154 -6.10777474 )) NATURAL)) ((2 ((100 93) (130 93)) NIL ((30. 0 0 0 0 0 )) NATURAL) (28 ((130 93) (133 114) (143 132) (169 148) (197 169) (216 197) (217 232) (205 259) (181 280) (149 292) (111 295) (72 290) (42 274) (25 246) (33 213) (61 203) (84 206) (101 224) (96 250) (87 265) (96 275) (112 267) (123 245) (127 215) (120 173) (105 141) (99 113) (100 93)) NIL ((2.20930052 21.587924 0 0 4.74419689 -3.52756643 ) (4.58139897 19.824142 4.74419689 -3.52756643 18.279014 -0.362166881 ) (18.465103 16.115493 23.023212 -3.88973332 -23.860263 10.976232 ) (29.558181 17.713874 -0.837053538 7.08650017 -6.83794499 -1.54276752 ) (25.302154 24.028991 -7.67499924 5.54373265 -14.787948 7.1948328 ) (10.233181 33.170143 -22.462947 12.738565 11.989748 -27.23656 ) (-6.2348919 32.29042 -10.4731998 -14.497997 -3.1710453 11.7514228 ) (-18.293613 23.66814 -13.644245 -2.74657297 6.69443608 -7.76913357 ) (-28.59064 17.036998 -6.94980908 -10.515707 0.393295288 1.32511329 ) (-35.343803 7.18384934 -6.55651379 -9.1905937 3.73237848 2.46868038 ) (-40.034126 -0.772403956 -2.8241353 -6.72191334 14.6771907 -5.19983578 ) (-35.519668 -10.094236 11.8530559 -11.921749 -2.44114303 0.330665588 ) (-24.887184 -21.85065 9.4119129 -11.591083 19.087368 -2.12282944 ) (-5.9315853 -34.50315 28.499282 -13.7139129 -1.90833282 50.16065 ) (21.613529 -23.136734 26.59095 36.446739 -41.45404 -30.519794 ) (27.477458 -1.94989419 -14.86309 5.92694378 17.724498 11.918533 ) (21.476619 9.93631745 2.86140919 17.845478 -35.443946 -5.15433884 ) (6.6160507 25.204624 -32.582542 12.691139 28.051315 -33.30117 ) (-11.940832 21.245174 -4.53122425 -20.610034 31.238666 24.359039 ) (-0.852723838 12.814661 26.707443 3.7490058 -21.005985 -28.13499 ) (15.351724 2.49617195 5.70145703 -24.385986 -13.214729 10.180927 ) (14.4458179 -16.79935 -7.51327229 -14.205059 1.86490535 11.411287 ) (7.8649988 -25.298767 -5.64836693 -2.79377174 -6.24489403 -19.826076 ) (-0.905814410 -38.005577 -11.8932609 -22.61985 -0.885330201 43.89302 ) (-13.241739 -38.678909 -12.778591 21.27317 27.786216 -23.746013 ) (-12.1272239 -29.27875 15.007625 -2.4728465 -8.259531 15.0910568 ) (-1.24936437 -24.206069 6.7480936 12.6182117 -6.7480936 -12.6182117 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 133Q) (FACE M R R) (WIDTH 210 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:51:16) (MADE-FROM NIL 147 130 0 0) (SPLINES ((2 ((183 294) (183 244)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((183 244) (133 244)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((133 244) (133 -32)) NIL ((0 -276. 0 0 0 0 )) NATURAL) (2 ((133 -32) (183 -32)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((183 -32) (183 -82)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((183 -82) (49 -82)) NIL ((-134. 0 0 0 0 0 )) NATURAL) (2 ((49 -82) (49 294)) NIL ((0 376. 0 0 0 0 )) NATURAL) (2 ((49 294) (183 294)) NIL ((134. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 135Q) (FACE M R R) (WIDTH 208 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:52:23) (MADE-FROM NIL 159 130 0 0) (SPLINES ((2 ((157 -82) (23 -82)) NIL ((-134. 0 0 0 0 0 )) NATURAL) (2 ((23 -82) (23 -32)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((23 -32) (73 -32)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((73 -32) (73 244)) NIL ((0 276. 0 0 0 0 )) NATURAL) (2 ((73 244) (23 244)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((23 244) (23 294)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((23 294) (157 294)) NIL ((134. 0 0 0 0 0 )) NATURAL) (3 ((157 294) (157 294) (157 -82)) NIL ((0 94. 0 0 0 -564. ) (0 -188. 0 -564. 0 564. )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 136Q) (FACE M R R) (WIDTH 223 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:53:31) (MADE-FROM NIL 118 130 0 0) (SPLINES ((2 ((142 15) (142 155)) NIL ((0 140. 0 0 0 0 )) NATURAL) (2 ((142 155) (192 155)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((192 155) (112 265)) NIL ((-80. 110. 0 0 0 0 )) NATURAL) (2 ((112 265) (32 155)) NIL ((-80. -110. 0 0 0 0 )) NATURAL) (2 ((32 155) (82 155)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((82 155) (82 15)) NIL ((0 -140. 0 0 0 0 )) NATURAL) (2 ((82 15) (142 15)) NIL ((60. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 137Q) (FACE M R R) (WIDTH 327 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:54:28) (MADE-FROM NIL 102 130 0 0) (SPLINES ((2 ((144 27) (144 77)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((144 77) (284 77)) NIL ((140. 0 0 0 0 0 )) NATURAL) (2 ((284 77) (284 137)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((284 137) (144 137)) NIL ((-140. 0 0 0 0 0 )) NATURAL) (2 ((144 137) (144 187)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((144 187) (34 107)) NIL ((-110. -80. 0 0 0 0 )) NATURAL) (2 ((34 107) (144 27)) NIL ((110. -80. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 174Q) (FACE M R R) (WIDTH 163 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:57:15) (MADE-FROM NIL 156 130 0 0) (SPLINES ((2 ((124 294) (40 294)) NIL ((-84. 0 0 0 0 0 )) NATURAL) (3 ((40 294) (40 294) (40 -82)) NIL ((0 94. 0 0 0 -564. ) (0 -188. 0 -564. 0 564. )) NATURAL) (2 ((40 -82) (124 -82)) NIL ((84. 0 0 0 0 0 )) NATURAL) (3 ((124 -82) (124 294) (124 294)) NIL ((0 470. 0 0 0 -564. ) (0 188. 0 -564. 0 564. )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 173Q) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:58:29) (MADE-FROM NIL 126 130 0 0) (SPLINES ((2 ((197 294) (154 294)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (6 ((154 294) (125 289) (105 279) (87 261) (75 236) (70 210)) NIL ((-31.34928 -4.10526276 0 0 14.095693 -5.3684206 ) (-24.301433 -6.78947354 14.095693 -5.3684206 -16.478466 -3.15789509 ) (-18.444973 -13.736841 -2.38277435 -8.5263157 9.81817819 1.90734863E-6 ) (-15.918659 -22.263156 7.43540478 -8.52631379 1.20574283 9.1578922 ) (-7.88038254 -26.210525 8.6411476 0.631578803 -8.6411476 -0.631578803 )) NATURAL) (2 ((70 210) (70 157)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (5 ((70 157) (66 139) (55 127) (40 122) (25 122)) NIL ((-2.41071415 -19.196426 0 0 -9.5357132 7.17857075 ) (-7.1785717 -15.607141 -9.5357132 7.17857075 5.67857075 0.107143402 ) (-13.875 -8.3749981 -3.85714245 7.28571416 4.82142735 -1.6071434 ) (-15.321428 -1.89285683 0.964285732 5.67857075 -0.964285732 -5.67857075 )) NATURAL) (2 ((25 122) (25 96)) NIL ((0 -26. 0 0 0 0 )) NATURAL) (5 ((25 96) (40 96) (55 91) (66 79) (70 61)) NIL ((14.8392849 0.946428419 0 0 0.964285732 -5.67857075 ) (15.321428 -1.89285731 0.964285732 -5.67857075 -4.8214283 -1.6071434 ) (13.874998 -8.375 -3.85714293 -7.28571416 -5.6785698 0.107143402 ) (7.17857075 -15.607141 -9.5357132 -7.17857075 9.5357132 7.17857075 )) NATURAL) (2 ((70 61) (70 8)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (6 ((70 8) (75 -18) (87 -43) (105 -61) (125 -71) (154 -76)) NIL ((3.55980873 -25.894733 0 0 8.6411476 -0.631578923 ) (7.88038254 -26.210525 8.6411476 -0.631578923 -1.20574188 9.15789414 ) (15.918659 -22.263156 7.43540574 8.5263157 -9.81818009 -1.90734863E-6 ) (18.444973 -13.736841 -2.38277483 8.52631379 16.478466 -3.15789318 ) (24.301433 -6.78947354 14.095693 5.3684206 -14.095693 -5.3684206 )) NATURAL) (2 ((154 -76) (197 -76)) NIL ((43. 0 0 0 0 0 )) NATURAL) (2 ((197 -76) (197 -51)) NIL ((0 25. 0 0 0 0 )) NATURAL) (7 ((197 -51) (183 -50) (171 -47) (164 -41) (158 -30) (156 -18) (154 -6)) NIL ((-14.17564 0.588461519 0 0 1.05384636 2.46923065 ) (-13.6487179 1.82307696 1.05384636 2.46923065 6.7307682 -0.346154213 ) (-9.22948648 4.11923027 7.78461457 2.12307644 -9.97692109 4.91538525 ) (-6.4333334 8.69999887 -2.19230747 7.03846169 9.17692185 -7.31538487 ) (-4.037179 12.0807686 6.98461533 -0.276923179 -8.7307682 0.346153974 ) (-1.41794872 11.976923 -1.74615383 0.0692307949 1.74615383 -0.0692307949 )) NATURAL) (2 ((154 -6) (154 57)) NIL ((0 63. 0 0 0 0 )) NATURAL) (5 ((154 57) (151 73) (143 89) (131 100) (114 109)) NIL ((-1.85714292 15.6785698 0 0 -6.85714245 1.92857122 ) (-5.28571415 16.642856 -6.85714245 1.92857122 4.28571415 -9.6428547 ) (-10. 13.749998 -2.5714283 -7.7142849 -4.28571415 6.64285565 ) (-14.7142849 9.3571415 -6.85714245 -1.07142853 6.85714245 1.07142853 )) NATURAL) (5 ((114 109) (131 118) (143 129) (151 145) (154 161)) NIL ((18.142856 8.8214283 0 0 -6.85714245 1.07142877 ) (14.7142849 9.3571415 -6.85714245 1.07142877 4.28571415 6.64285565 ) (9.9999981 13.75 -2.5714283 7.7142849 -4.28571415 -9.6428547 ) (5.28571415 16.642856 -6.85714245 -1.92857146 6.85714245 1.92857146 )) NATURAL) (2 ((154 161) (154 224)) NIL ((0 63. 0 0 0 0 )) NATURAL) (7 ((154 224) (156 236) (158 248) (164 259) (171 265) (183 268) (197 269)) NIL ((2.29102564 12.011537 0 0 -1.74615383 -0.0692307055 ) (1.41794872 11.976923 -1.74615383 -0.0692307055 8.7307682 0.346153498 ) (4.037179 12.0807686 6.98461533 0.276922822 -9.17692185 -7.31538296 ) (6.4333334 8.69999887 -2.19230747 -7.03846074 9.97692109 4.91538334 ) (9.22948648 4.11923027 7.78461457 -2.12307691 -6.7307682 -0.346153259 ) (13.6487179 1.82307672 1.05384612 -2.46923017 -1.05384612 2.46923017 )) NATURAL) (2 ((197 269) (197 294)) NIL ((0 25. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 175Q) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 17:00:08) (MADE-FROM NIL 147 130 0 0) (SPLINES ((2 ((42 294) (85 294)) NIL ((43. 0 0 0 0 0 )) NATURAL) (6 ((85 294) (114 289) (134 279) (152 261) (164 236) (169 210)) NIL ((31.34928 -4.10526276 0 0 -14.095693 -5.3684206 ) (24.301433 -6.78947354 -14.095693 -5.3684206 16.478466 -3.15789509 ) (18.444973 -13.736841 2.38277435 -8.5263157 -9.81817819 1.90734863E-6 ) (15.918659 -22.263156 -7.43540478 -8.52631379 -1.20574283 9.1578922 ) (7.88038254 -26.210525 -8.6411476 0.631578803 8.6411476 -0.631578803 )) NATURAL) (2 ((169 210) (169 157)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (5 ((169 157) (173 139) (184 127) (199 122) (214 122)) NIL ((2.41071415 -19.196426 0 0 9.5357132 7.17857075 ) (7.1785717 -15.607141 9.5357132 7.17857075 -5.67857075 0.107143402 ) (13.875 -8.3749981 3.85714245 7.28571416 -4.82142735 -1.6071434 ) (15.321428 -1.89285683 -0.964285732 5.67857075 0.964285732 -5.67857075 )) NATURAL) (2 ((214 122) (214 96)) NIL ((0 -26. 0 0 0 0 )) NATURAL) (5 ((214 96) (199 96) (184 91) (173 79) (169 61)) NIL ((-14.8392849 0.946428419 0 0 -0.964285732 -5.67857075 ) (-15.321428 -1.89285731 -0.964285732 -5.67857075 4.8214283 -1.6071434 ) (-13.874998 -8.375 3.85714293 -7.28571416 5.6785698 0.107143402 ) (-7.17857075 -15.607141 9.5357132 -7.17857075 -9.5357132 7.17857075 )) NATURAL) (2 ((169 61) (169 8)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (6 ((169 8) (164 -18) (152 -43) (134 -61) (114 -71) (85 -76)) NIL ((-3.55980873 -25.894733 0 0 -8.6411476 -0.631578923 ) (-7.88038254 -26.210525 -8.6411476 -0.631578923 1.20574188 9.15789414 ) (-15.918659 -22.263156 -7.43540574 8.5263157 9.81818009 -1.90734863E-6 ) (-18.444973 -13.736841 2.38277483 8.52631379 -16.478466 -3.15789318 ) (-24.301433 -6.78947354 -14.095693 5.3684206 14.095693 -5.3684206 )) NATURAL) (2 ((85 -76) (42 -76)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (2 ((42 -76) (42 -51)) NIL ((0 25. 0 0 0 0 )) NATURAL) (7 ((42 -51) (56 -50) (68 -47) (75 -41) (81 -30) (83 -18) (85 -6)) NIL ((14.17564 0.588461519 0 0 -1.05384636 2.46923065 ) (13.6487179 1.82307696 -1.05384636 2.46923065 -6.7307682 -0.346154213 ) (9.22948648 4.11923027 -7.78461457 2.12307644 9.97692109 4.91538525 ) (6.4333334 8.69999887 2.19230747 7.03846169 -9.17692185 -7.31538487 ) (4.037179 12.0807686 -6.98461533 -0.276923179 8.7307682 0.346153974 ) (1.41794872 11.976923 1.74615383 0.0692307949 -1.74615383 -0.0692307949 )) NATURAL) (2 ((85 -6) (85 57)) NIL ((0 63. 0 0 0 0 )) NATURAL) (5 ((85 57) (88 73) (96 89) (108 100) (125 109)) NIL ((1.85714292 15.6785698 0 0 6.85714245 1.92857122 ) (5.28571415 16.642856 6.85714245 1.92857122 -4.28571415 -9.6428547 ) (10. 13.749998 2.5714283 -7.7142849 4.28571415 6.64285565 ) (14.7142849 9.3571415 6.85714245 -1.07142853 -6.85714245 1.07142853 )) NATURAL) (5 ((125 109) (108 118) (96 129) (88 145) (85 161)) NIL ((-18.142856 8.8214283 0 0 6.85714245 1.07142877 ) (-14.7142849 9.3571415 6.85714245 1.07142877 -4.28571415 6.64285565 ) (-9.9999981 13.75 2.5714283 7.7142849 4.28571415 -9.6428547 ) (-5.28571415 16.642856 6.85714245 -1.92857146 -6.85714245 1.92857146 )) NATURAL) (2 ((85 161) (85 224)) NIL ((0 63. 0 0 0 0 )) NATURAL) (7 ((85 224) (83 236) (81 248) (75 259) (68 265) (56 268) (42 269)) NIL ((-2.29102564 12.011537 0 0 1.74615383 -0.0692307055 ) (-1.41794872 11.976923 1.74615383 -0.0692307055 -8.7307682 0.346153498 ) (-4.037179 12.0807686 -6.98461533 0.276922822 9.17692185 -7.31538296 ) (-6.4333334 8.69999887 2.19230747 -7.03846074 -9.97692109 4.91538334 ) (-9.22948648 4.11923027 -7.78461457 -2.12307691 6.7307682 -0.346153259 ) (-13.6487179 1.82307672 -1.05384612 -2.46923017 1.05384612 2.46923017 )) NATURAL) (2 ((42 269) (42 294)) NIL ((0 25. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/TIMESROMAN.UC1-SF b/lispusers/TIMESROMAN.UC1-SF new file mode 100644 index 00000000..e2745a27 --- /dev/null +++ b/lispusers/TIMESROMAN.UC1-SF @@ -0,0 +1 @@ + ((FAMILY TIMESROMAND) (CHARACTER 101Q) (FACE M R R) (WIDTH 344 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:54:14) (MADE-FROM NIL 89 130 69 77) (SPLINES ((2 ((191 0) (332 0)) NIL ((141. 0 0 0 0 0 )) NATURAL) (2 ((332 0) (332 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (3 ((332 10) (320 19) (313 29)) NIL ((-13.25 8.75 0 0 7.5 1.5 ) (-9.5 9.5 7.5 1.5 -7.5 -1.5 )) NATURAL) (2 ((313 29) (180 294)) NIL ((-133. 265. 0 0 0 0 )) NATURAL) (2 ((180 294) (146 294)) NIL ((-34. 0 0 0 0 0 )) NATURAL) (2 ((146 294) (50 54)) NIL ((-96. -240. 0 0 0 0 )) NATURAL) (4 ((50 54) (40 33) (28 18) (11 10)) NIL ((-9.79999925 -22.133331 0 0 -1.20000004 6.8000002 ) (-10.3999996 -18.733329 -1.20000004 6.8000002 -5.99999905 1.99999904 ) (-14.599998 -10.933332 -7.1999998 8.79999925 7.1999998 -8.79999925 )) NATURAL) (2 ((11 10) (11 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((11 0) (116 0)) NIL ((105. 0 0 0 0 0 )) NATURAL) (2 ((116 0) (116 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (7 ((116 10) (104 13) (89 19) (78 35) (80 58) (84 74) (91 96)) NIL ((-11.152563 2.73589706 0 0 -5.08461476 1.58461571 ) (-13.6948719 3.52820492 -5.08461476 1.58461571 7.42307664 10.076921 ) (-15.067947 10.151281 2.33846187 11.661537 17.392303 0.107692718 ) (-4.03333187 21.866664 19.730766 11.7692299 -22.992301 -28.50769 ) (4.20128155 19.382049 -3.26153803 -16.73846 8.57692147 29.923076 ) (5.22820473 17.605125 5.3153839 13.184616 -5.3153839 -13.184616 )) NATURAL) (3 ((91 96) (177 96) (177 96)) NIL ((107.5 0 0 0 -129. 0 ) (43. 0 -129. 0 129. 0 )) NATURAL) (2 ((177 96) (200 44)) NIL ((23. -52. 0 0 0 0 )) NATURAL) (4 ((200 44) (208 26) (202 13) (191 10)) NIL ((11.3999996 -18.666664 0 0 -20.399997 4. ) (1.19999909 -16.666664 -20.399997 4. 17.999996 10. ) (-10.1999988 -7.66666604 -2.39999962 14. 2.39999962 -14. )) NATURAL) (2 ((191 10) (191 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL)) ((2 ((97 113) (169 113)) NIL ((72. 0 0 0 0 0 )) NATURAL) (2 ((169 113) (129 195)) NIL ((-40. 82. 0 0 0 0 )) NATURAL) (2 ((129 195) (97 113)) NIL ((-32. -82. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 102Q) (FACE M R R) (WIDTH 340 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:56:46) (MADE-FROM NIL 91 130 82 78) (SPLINES ((2 ((16 0) (16 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((16 10) (27 11) (40 16) (46 27) (47 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((47 39) (47 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((47 255) (46 267) (40 278) (27 283) (16 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((16 284) (16 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((16 294) (191 294)) NIL ((175. 0 0 0 0 0 )) NATURAL) (10 ((191 294) (232 292) (264 284) (287 269) (304 246) (308 215) (297 189) (276 172) (246 160) (204 154)) NIL ((42.83139 -0.786138774 0 0 -10.988382 -7.28316689 ) (37.337204 -4.42772198 -10.988382 -7.28316689 0.941915513 0.415834427 ) (26.819778 -11.5029716 -10.0464668 -6.86733246 7.22071839 -0.380169869 ) (20.38367 -18.560386 -2.82574797 -7.24750233 -11.824789 -4.895154 ) (11.6455288 -28.255466 -14.650537 -12.142656 -1.92156791 19.960781 ) (-3.96579123 -30.417732 -16.572105 7.81812764 7.51106454 3.05201626 ) (-16.7823639 -21.073596 -9.06104089 10.8701439 1.87731838 -8.16884805 ) (-24.904747 -14.287876 -7.1837225 2.7012949 -9.02034379 5.6233797 ) (-36.59864 -8.7748909 -16.204067 8.3246746 16.204067 -8.3246746 )) NATURAL) (11 ((204 154) (236 149) (271 141) (299 127) (317 103) (324 73) (316 40) (295 19) (266 6) (243 2) (225 0)) NIL ((30.846077 -4.45746613 0 0 6.92353726 -3.25520086 ) (34.307838 -6.0850668 6.92353726 -3.25520086 -16.617683 -1.72399473 ) (32.922538 -10.2022647 -9.694149 -4.9791956 -0.452787399 -7.84881879 ) (23.001995 -19.105869 -10.146936 -12.828014 0.428838730 9.11927224 ) (13.069475 -27.374248 -9.7180977 -3.70874214 -7.2625656 -4.628273 ) (-0.279904365 -33.397125 -16.980663 -8.33701516 4.62141609 27.393817 ) (-14.949859 -28.037231 -12.359247 19.056804 0.776903153 -14.947021 ) (-26.920654 -16.453933 -11.582344 4.10978318 22.270965 8.39427377 ) (-27.367511 -8.1470165 10.688623 12.5040569 -5.86077976 -12.6300697 ) (-19.609279 -1.95799517 4.82784367 -0.126014232 -4.82784367 0.126014232 )) NATURAL) (2 ((225 0) (16 0)) NIL ((-209. 0 0 0 0 0 )) NATURAL)) ((3 ((147 161) (147 161) (147 278)) NIL ((0 -29.25 0 0 0 175.5 ) (0 58.5 0 175.5 0 -175.5 )) NATURAL) (9 ((147 278) (165 278) (186 272) (204 256) (214 230) (213 202) (200 175) (172 161) (147 161)) NIL ((17.0887298 1.07391381 0 0 5.4675989 -6.44348336 ) (19.822532 -2.14782762 5.4675989 -6.44348336 -9.3379955 -3.78258324 ) (20.621131 -10.482603 -3.87039757 -10.2260666 -4.11561108 -2.42617798 ) (14.69293 -21.921756 -7.98600865 -12.652244 -4.1995573 13.487295 ) (4.60714245 -27.830356 -12.1855659 0.835051299 2.91384315 -3.5230112 ) (-6.12150193 -28.756809 -9.2717228 -2.68796015 -13.455816 18.604747 ) (-22.121131 -22.142395 -22.727539 15.916788 32.909423 1.10401344 ) (-28.393959 -5.6736002 10.1818847 17.020801 -10.1818847 -17.020801 )) NATURAL)) ((2 ((147 144) (147 36)) NIL ((0 -108. 0 0 0 0 )) NATURAL) (13 ((147 36) (150 25) (161 16) (181 15) (199 22) (214 38) (221 57) (221 83) (215 111) (200 131) (184 141) (166 145) (147 144)) NIL ((1.53440761 -11.070934 0 0 8.7935543 0.425616741 ) (5.93118477 -10.8581276 8.7935543 0.425616741 4.03222656 9.8719158 ) (16.740852 -5.4965515 12.8257808 10.297533 -18.922458 -3.91328716 ) (20.1054 2.84433746 -6.09667969 6.38424588 5.65762043 5.7812376 ) (16.837532 12.1192016 -0.439059258 12.165483 -9.70802117 -13.211664 ) (11.544462 17.678852 -10.147081 -1.04618191 3.17446899 11.0654239 ) (2.98461485 22.165382 -6.97261239 10.019243 3.01014614 -7.0500412 ) (-2.48292446 28.659606 -3.96246624 2.96920204 -9.21505357 -12.865255 ) (-11.052917 25.196178 -13.1775207 -9.8960533 15.8500709 -1.48893165 ) (-16.3054008 14.555662 2.6725502 -11.3849849 -6.18523026 6.82098199 ) (-16.725467 6.5811672 -3.51268005 -4.56400299 2.89085007 -1.79499531 ) (-18.79272 1.1196661 -0.621829868 -6.3589983 0.621829868 6.3589983 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 103Q) (FACE M R R) (WIDTH 317 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:57:54) (MADE-FROM NIL 87 130 80 88) (SPLINES ((21 ((295 206) (283 206) (278 217) (269 237) (252 257) (231 271) (203 277) (168 268) (147 247) (135 223) (127 194) (124 157) (127 121) (135 86) (151 54) (176 34) (209 25) (243 31) (271 48) (286 63) (299 51)) NIL ((-14.023639 -2.3255701 0 0 12.1418419 13.95342 ) (-7.95271874 4.65114117 12.1418419 13.95342 -18.709209 -3.76710892 ) (-5.16548252 16.721004 -6.56736756 10.1863117 -3.30500221 -10.884983 ) (-13.385351 21.464824 -9.87236978 -0.698672533 7.92921925 -6.6929493 ) (-19.293109 17.419677 -1.94315004 -7.39162255 -4.41187954 1.65678596 ) (-23.442199 10.856449 -6.35503007 -5.73483658 -8.28169824 -11.9341926 ) (-33.938079 -0.845483781 -14.636728 -17.669029 37.538665 4.07999039 ) (-29.805473 -16.474514 22.901939 -13.5890388 -15.872972 13.614221 ) (-14.840019 -23.256443 7.02896596 0.0251838676 -4.0467739 -4.53687954 ) (-9.8344402 -25.499698 2.98219156 -4.51169586 2.06007337 -7.4667034 ) (-5.82221318 -33.744743 5.04226494 -11.978399 1.80648422 16.403694 ) (0.123294025 -37.521293 6.84874917 4.42529679 -3.2860117 -4.14808369 ) (5.3290367 -35.170044 3.56273747 0.277212322 5.3375635 0.188641011 ) (11.560556 -34.798507 8.90030099 0.465853334 -0.0642452240 15.393518 ) (20.428733 -26.635898 8.83605577 15.859373 0.919410706 -7.7627182 ) (29.724494 -14.657884 9.75546647 8.0966549 -9.61338998 9.65735055 ) (34.673263 -1.73255491 0.142075598 17.754005 -4.4658451 -6.86668587 ) (32.58242 12.588106 -4.32376957 10.8873195 -14.5232219 -6.1906042 ) (20.997036 20.380123 -18.846992 4.69671536 20.558738 -46.370887 ) (12.4294166 1.89139294 1.71174884 -41.674179 -1.71174884 41.674179 )) NATURAL) (26 ((299 51) (277 28) (249 10) (218 -1) (180 -5) (144 -2) (111 8) (82 23) (59 43) (39 69) (27 94) (20 123) (17 154) (21 184) (34 217) (52 244) (76 267) (104 284) (136 295) (172 300) (212 298) (241 293) (262 288) (280 285) (286 294) (296 294)) NIL ((-20.465946 -23.943889 0 0 -9.20431329 5.6633482 ) (-25.068103 -21.112216 -9.20431329 5.6633482 10.021566 1.68325901 ) (-29.26163 -14.6072387 0.817253590 7.3466072 -12.881954 -0.396385193 ) (-34.885353 -7.4588232 -12.064701 6.950222 17.506252 -0.0977230073 ) (-38.196929 -0.557461977 5.44155407 6.852499 -3.14307118 0.787275315 ) (-34.326911 6.68867398 2.29848289 7.6397743 1.06602907 -3.05137062 ) (-31.495414 12.802763 3.36451197 4.5884037 4.8789568 -0.581792832 ) (-25.691421 17.100269 8.24346925 4.00661087 -8.5818615 5.37854195 ) (-21.738884 23.79615 -0.338392854 9.3851528 11.448492 -14.9323749 ) (-16.353031 25.715114 11.1100998 -5.54722309 -7.21210194 12.3509617 ) (-8.84898377 26.343372 3.89799738 6.80373955 -0.600089073 -4.4714737 ) (-5.25102997 30.911376 3.2979083 2.33226585 3.61245775 -6.4650688 ) (-0.146893501 30.011108 6.91036606 -4.13280297 4.15026284 12.3317489 ) (8.83860398 32.044181 11.0606289 8.198946 -8.2135105 -18.861927 ) (15.792476 30.81216 2.84711695 -10.6629829 4.70378399 9.1159687 ) (20.991485 24.707164 7.5509014 -1.54701376 -4.60162544 -5.60194683 ) (26.241573 20.359176 2.94927549 -7.14896107 1.70271826 1.29182338 ) (30.042209 13.8561248 4.65199375 -5.85713768 -2.2092433 0.434653282 ) (33.589576 8.2163143 2.44275045 -5.4224844 7.13425065 -3.03043842 ) (39.599456 1.27861070 9.57700158 -8.4529228 -26.327758 5.68710327 ) (36.012573 -4.33076 -16.750759 -2.76581907 8.17679978 4.28201866 ) (23.350219 -4.95556927 -8.57395936 1.5162003 11.6205539 -4.81518173 ) (20.586536 -5.84696007 3.04659605 -3.29898214 -24.659015 26.978706 ) (11.303623 4.3434124 -21.612422 23.679725 33.015525 -43.099655 ) (6.19896508 6.4733095 11.4031047 -19.419929 -11.4031047 19.419929 )) NATURAL) (2 ((296 294) (295 206)) NIL ((-1. -88. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 104Q) (FACE M R R) (WIDTH 356 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:59:49) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((181 0) (14 0)) NIL ((-167. 0 0 0 0 0 )) NATURAL) (2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (181 294)) NIL ((167. 0 0 0 0 0 )) NATURAL) (19 ((181 294) (210 292) (236 288) (260 281) (284 269) (303 254) (321 234) (333 211) (342 176) (343 147) (342 118) (333 83) (321 60) (303 40) (284 25) (260 13) (236 6) (210 2) (181 0)) NIL ((29.633724 -1.5916388 0 0 -3.80235243 -2.45016622 ) (27.732547 -2.81672191 -3.80235243 -2.45016622 1.01176214 0.250832081 ) (24.436077 -5.14147187 -2.79059028 -2.19933414 5.75530434 -4.55316258 ) (24.523136 -9.61738778 2.96471405 -6.7524967 -12.0329799 5.9618187 ) (21.471363 -13.388975 -9.0682659 -0.790677190 12.3766117 -7.29411507 ) (18.5914039 -17.826709 3.30834723 -8.0847931 -13.4734687 11.214649 ) (15.163015 -20.30418 -10.1651229 3.1298561 11.517271 -25.564483 ) (10.7565269 -29.956565 1.35214877 -22.434627 -14.595617 37.04328 ) (4.81086636 -33.869545 -13.243469 14.6086578 16.8652038 -14.6086578 ) (-1.59256160E-7 -26.565223 3.6217351 -5.11072471E-7 -16.8652038 -14.608654 ) (-4.81086827 -33.869545 -13.243469 -14.6086559 14.595617 37.043273 ) (-10.7565288 -29.956562 1.35214853 22.434623 -11.517271 -25.564476 ) (-15.163015 -20.30418 -10.1651229 -3.12985516 13.4734687 11.214647 ) (-18.5914039 -17.826709 3.30834723 8.0847931 -12.3766098 -7.294116 ) (-21.471363 -13.388973 -9.068264 0.790676714 12.032978 5.96181965 ) (-24.523136 -9.61738778 2.96471405 6.7524967 -5.75530434 -4.55316258 ) (-24.436077 -5.14147187 -2.79059028 2.19933367 -1.01176166 0.250832558 ) (-27.732547 -2.81672191 -3.80235195 2.45016622 3.80235195 -2.45016622 )) NATURAL)) ((2 ((145 272) (145 272)) NIL ((0 0 0 0 0 0 )) NATURAL)) ((2 ((145 272) (145 36)) NIL ((0 -236. 0 0 0 0 )) NATURAL) (19 ((145 36) (147 28) (157 18) (182 16) (204 25) (221 41) (234 63) (242 90) (245 119) (246 147) (244 172) (240 198) (232 229) (218 253) (203 268) (184 277) (164 281) (148 280) (145 272)) NIL ((0.969433427 -7.07190228 0 0 6.1833992 -5.56858444 ) (4.06113243 -9.85619355 6.1833992 -5.56858444 17.083004 15.842924 ) (18.786033 -7.50331689 23.266403 10.2743396 -32.515426 2.19688225 ) (25.794723 3.8694644 -9.24902535 12.4712219 4.97872639 -6.63045407 ) (19.03506 13.025459 -4.27029896 5.84076786 0.600520611 0.324934006 ) (15.065023 19.028694 -3.66977835 6.16570187 -1.38080835 -0.669278145 ) (10.7048397 24.859756 -5.0505867 5.49642372 -1.07728576 -3.64782 ) (5.11561108 28.532268 -6.12787247 1.84860348 5.68994999 -2.73944139 ) (1.8327136 29.011154 -0.437921703 -0.890838028 -3.68251753 -3.39441252 ) (-0.446466982 26.423107 -4.12043953 -4.28525067 3.0401206 4.31709099 ) (-3.04684639 24.296402 -1.08031892 0.0318403318 -2.4779644 10.126047 ) (-5.36614704 29.391269 -3.55828333 10.157888 -5.12826252 -20.821285 ) (-11.4885616 29.138511 -8.6865463 -10.6633968 10.991018 1.15910148 ) (-14.6795997 19.054668 2.30447245 -9.50429536 -8.8358135 4.18487263 ) (-16.793033 11.6428089 -6.53134156 -5.31942272 6.3522358 0.101410865 ) (-20.148258 6.3740921 -0.179104834 -5.21801186 1.42686581 1.409482 ) (-19.613929 1.86082101 1.24776101 -3.80852985 17.940292 -5.73933697 ) (-9.39601899 -4.81737709 19.1880569 -9.5478668 -19.1880569 9.5478668 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 105Q) (FACE M R R) (WIDTH 302 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:01:30) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (257 294)) NIL ((243. 0 0 0 0 0 )) NATURAL) (2 ((257 294) (261 218)) NIL ((4. -76. 0 0 0 0 )) NATURAL) (2 ((261 218) (248 218)) NIL ((-13. 0 0 0 0 0 )) NATURAL) (9 ((248 218) (243 227) (237 242) (223 262) (206 274) (186 279) (164 281) (147 280) (145 272)) NIL ((-5.26095295 7.87279034 0 0 1.56572151 6.7632551 ) (-4.4780922 11.254417 1.56572151 6.7632551 -13.828607 2.1837244 ) (-9.8266754 19.109535 -12.262886 8.9469795 11.7487106 -21.498157 ) (-16.215206 17.307434 -0.514174938 -12.551178 -3.16623783 5.8089094 ) (-18.3125 7.66071416 -3.68041277 -6.74226857 0.916238309 4.26251889 ) (-21.534793 3.04970503 -2.76417446 -2.4797492 5.5012865 1.14101576 ) (-21.54832 1.14046359 2.73711204 -1.33873343 19.078605 -8.82658196 ) (-9.2719059 -4.61156082 21.815719 -10.1653156 -21.815719 10.1653156 )) NATURAL) (2 ((145 272) (145 158)) NIL ((0 -114. 0 0 0 0 )) NATURAL) (5 ((145 158) (163 162) (177 174) (186 191) (190 215)) NIL ((18.803569 2.08928585 0 0 -4.8214283 11.4642849 ) (16.392856 7.8214283 -4.8214283 11.4642849 0.107143402 -9.3214264 ) (11.624998 14.625 -4.7142849 2.14285707 -1.6071434 7.82142735 ) (6.10714245 20.678569 -6.3214283 9.9642849 6.3214283 -9.9642849 )) NATURAL) (2 ((190 215) (204 215)) NIL ((14. 0 0 0 0 0 )) NATURAL) (2 ((204 215) (204 89)) NIL ((0 -126. 0 0 0 0 )) NATURAL) (2 ((204 89) (190 89)) NIL ((-14. 0 0 0 0 0 )) NATURAL) (5 ((190 89) (186 109) (177 126) (163 138) (145 142)) NIL ((-2.9464283 20.589283 0 0 -6.3214283 -3.53571415 ) (-6.10714245 18.821426 -6.3214283 -3.53571415 1.6071434 -0.321428776 ) (-11.625 15.124998 -4.7142849 -3.85714293 -0.107143402 -7.1785698 ) (-16.392856 7.67857075 -4.8214283 -11.035713 4.8214283 11.035713 )) NATURAL) (2 ((145 142) (145 36)) NIL ((0 -106. 0 0 0 0 )) NATURAL) (9 ((145 36) (147 30) (156 20) (181 18) (211 21) (233 32) (250 47) (262 64) (271 84)) NIL ((1.14101600 -4.4138441 0 0 5.153903 -9.51693536 ) (3.7179675 -9.17231179 5.153903 -9.51693536 16.230484 23.584678 ) (16.98711 -6.8969059 21.384387 14.067745 -16.0758438 -12.821794 ) (30.333576 0.759941102 5.3085413 1.24594950 -17.927093 9.7025032 ) (26.678569 6.85714245 -12.618555 10.9484539 9.7842388 -7.9882183 ) (18.952133 13.811487 -2.8343153 2.96023512 -3.20986652 -1.7496314 ) (14.512886 15.8969059 -6.04418183 1.21060371 3.05522776 2.98674488 ) (9.9963169 18.600883 -2.98895407 4.1973486 2.98895407 -4.1973486 )) NATURAL) (2 ((271 84) (286 80)) NIL ((15. -4. 0 0 0 0 )) NATURAL) (2 ((286 80) (266 0)) NIL ((-20. -80. 0 0 0 0 )) NATURAL) (2 ((266 0) (14 0)) NIL ((-252. 0 0 0 0 0 )) NATURAL)) ((2 ((145 272) (145 272)) NIL ((0 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 106Q) (FACE M R R) (WIDTH 274 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:03:04) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (257 294)) NIL ((243. 0 0 0 0 0 )) NATURAL) (2 ((257 294) (261 228)) NIL ((4. -66. 0 0 0 0 )) NATURAL) (2 ((261 228) (245 228)) NIL ((-16. 0 0 0 0 0 )) NATURAL) (5 ((245 228) (237 248) (220 266) (199 277) (173 280)) NIL ((-5.78571415 20.178569 0 0 -13.285713 -1.07142877 ) (-12.4285717 19.642856 -13.285713 -1.07142877 12.4285698 -6.64285565 ) (-19.5 15.249998 -0.857143045 -7.7142849 -6.4285698 -2.3571434 ) (-23.571426 6.35714245 -7.2857132 -10.071428 7.2857132 10.071428 )) NATURAL) (2 ((173 280) (145 280)) NIL ((-28. 0 0 0 0 0 )) NATURAL) (2 ((145 280) (145 162)) NIL ((0 -118. 0 0 0 0 )) NATURAL) (5 ((145 162) (165 164) (180 171) (191 185) (196 214)) NIL ((21.160713 0.892857195 0 0 -6.9642849 6.6428566 ) (17.678569 4.2142849 -6.9642849 6.6428566 4.82142735 -3.21428442 ) (13.124998 9.25 -2.14285707 3.42857218 -6.32142735 18.214279 ) (7.8214283 21.785713 -8.4642849 21.642852 8.4642849 -21.642852 )) NATURAL) (2 ((196 214) (210 214)) NIL ((14. 0 0 0 0 0 )) NATURAL) (2 ((210 214) (210 89)) NIL ((0 -125. 0 0 0 0 )) NATURAL) (2 ((210 89) (196 89)) NIL ((-14. 0 0 0 0 0 )) NATURAL) (5 ((196 89) (191 118) (180 132) (165 139) (145 141)) NIL ((-3.58928585 32.607139 0 0 -8.4642849 -21.642856 ) (-7.8214283 21.785713 -8.4642849 -21.642856 6.32142735 18.214283 ) (-13.125 9.2499981 -2.14285707 -3.42857122 -4.8214283 -3.21428537 ) (-17.678569 4.2142849 -6.96428586 -6.6428566 6.96428586 6.6428566 )) NATURAL) (2 ((145 141) (145 39)) NIL ((0 -102. 0 0 0 0 )) NATURAL) (5 ((145 39) (146 27) (152 16) (165 11) (176 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((176 10) (176 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((176 0) (14 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 107Q) (FACE M R R) (WIDTH 350 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:04:05) (MADE-FROM NIL 93 130 82 78) (SPLINES ((25 ((298 296) (289 284) (268 287) (236 296) (200 301) (166 300) (130 295) (98 284) (70 267) (46 244) (28 217) (17 188) (12 154) (14 123) (21 94) (32 68) (52 42) (76 23) (105 8) (138 -2) (174 -6) (214 -6) (253 -1) (289 9) (315 20)) NIL ((-6.48319245 -15.5386657 0 0 -15.100845 21.231998 ) (-14.033615 -4.92266464 -15.100845 21.231998 3.5042324 -16.160003 ) (-27.382343 8.22933007 -11.5966129 5.07199288 7.08391667 -10.5919685 ) (-35.436996 8.00533868 -4.51269627 -5.5199766 10.160097 -1.47210884 ) (-34.869644 1.74930858 5.64740086 -6.99208546 -11.724308 4.48040486 ) (-35.084396 -3.00257444 -6.07690716 -2.5116806 12.7371368 -4.44951058 ) (-34.792739 -7.7390108 6.66022969 -6.96119118 -3.22424364 1.3176403 ) (-29.744628 -14.0413818 3.43598604 -5.64355088 0.159837722 -0.821053506 ) (-26.228725 -20.095459 3.59582377 -6.46460438 2.58489275 1.96657467 ) (-21.340454 -25.576774 6.1807165 -4.4980297 1.50059128 4.95475292 ) (-14.4094429 -27.597427 7.6813078 0.456723809 -2.58725929 -9.7855873 ) (-8.02176477 -32.0335 5.0940485 -9.32886506 2.8484478 16.1876068 ) (-1.50349259 -33.268562 7.9424963 6.85874367 -2.80653286 -6.96485234 ) (5.03573704 -29.892242 5.13596344 -0.106108874 -3.62231398 5.67179966 ) (8.3605423 -27.162452 1.51364922 5.565691 11.2957878 -9.72234918 ) (15.522087 -26.457935 12.8094387 -4.15665818 -11.560844 15.2176017 ) (22.551101 -23.005794 1.24859380 11.0609436 4.94758892 -9.14805795 ) (26.27349 -16.5188789 6.1961832 1.91288566 -2.22951364 3.37462616 ) (31.354919 -12.91868 3.96666956 5.28751183 -2.02953386 1.64955234 ) (34.306823 -6.80639268 1.93713569 6.93706418 4.34765053 -3.97283316 ) (38.417778 -1.85574507 6.28478623 2.96423101 -9.3610668 2.2417779 ) (40.022033 2.22937488 -3.07628202 5.2060089 3.0966239 1.00572204 ) (38.494064 7.9382448 0.0203422196 6.21173096 -15.0254268 -6.2646637 ) (31.001693 11.0176429 -15.005085 -0.0529328808 15.005085 0.0529328808 )) NATURAL) (2 ((315 20) (315 89)) NIL ((0 69. 0 0 0 0 )) NATURAL) (5 ((315 89) (316 108) (324 117) (331 120) (339 123)) NIL ((-0.964285494 21.25 0 0 11.785713 -13.5 ) (4.9285717 14.499998 11.785713 -13.5 -16.928569 7.50000096 ) (8.2499981 4.74999905 -5.1428566 -5.99999905 7.92857075 7.4999981 ) (7.0714283 2.5 2.78571415 1.49999976 -2.78571415 -1.49999976 )) NATURAL) (2 ((339 123) (339 133)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((339 133) (187 133)) NIL ((-152. 0 0 0 0 0 )) NATURAL) (2 ((187 133) (187 123)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((187 123) (199 122) (210 115) (215 102) (217 90)) NIL ((11.8928566 0.160714298 0 0 0.642857075 -6.96428586 ) (12.2142849 -3.3214283 0.642857075 -6.96428586 -9.2142849 -1.17857074 ) (8.2499981 -10.875 -8.5714283 -8.1428566 6.21428586 11.6785698 ) (2.78571415 -13.1785698 -2.35714245 3.53571415 2.35714245 -3.53571415 )) NATURAL) (2 ((217 90) (217 19)) NIL ((0 -71. 0 0 0 0 )) NATURAL) (16 ((217 19) (200 11) (172 13) (146 28) (128 56) (120 97) (118 141) (121 181) (130 223) (145 253) (170 274) (206 279) (240 266) (266 245) (282 224) (295 196)) NIL ((-14.0182419 -9.93531228 0 0 -17.890541 11.611883 ) (-22.963512 -4.12937165 -17.890541 11.611883 23.452705 1.94058037 ) (-29.1277 8.45280076 5.56216717 13.552463 2.07970333 -1.37420463 ) (-22.52568 21.31816 7.6418705 12.1782589 4.22847367 3.55624008 ) (-12.769571 35.274536 11.870344 15.7344989 -6.9935951 -12.8507557 ) (-4.39602566 44.583663 4.87674904 2.88374233 -0.254091263 -12.1532116 ) (0.353678048 41.390792 4.62265778 -9.2694702 2.00995827 19.463611 ) (5.98131466 41.853134 6.63261605 10.194141 -1.78574085 -29.70124 ) (11.7210598 37.196655 4.84687519 -19.507099 5.1330061 15.341362 ) (19.134437 25.360233 9.9798813 -4.1657362 5.2537136 -13.664211 ) (31.741176 14.362392 15.2335949 -17.829948 -20.147857 -2.68451309 ) (36.90084 -4.8098135 -4.91426468 -20.514461 -2.66227054 12.402265 ) (30.65544 -19.123142 -7.5765352 -8.11219598 -5.20305348 13.075447 ) (20.477378 -20.697612 -12.7795887 4.96325207 11.474485 -16.704063 ) (13.4350338 -24.086395 -1.30510235 -11.740812 1.30510235 11.740812 )) NATURAL) (2 ((295 196) (310 196)) NIL ((15. 0 0 0 0 0 )) NATURAL) (2 ((310 196) (308 296)) NIL ((-2. 100. 0 0 0 0 )) NATURAL) (2 ((308 296) (298 296)) NIL ((-10. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 110Q) (FACE M R R) (WIDTH 398 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:09:07) (MADE-FROM NIL 86 130 82 78) (SPLINES ((2 ((15 0) (15 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((15 10) (26 11) (39 16) (45 27) (46 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((46 39) (46 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((46 255) (45 267) (39 278) (26 283) (15 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((15 284) (15 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((15 294) (177 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((177 294) (177 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((177 284) (166 283) (153 278) (147 267) (146 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((146 255) (146 161)) NIL ((0 -94. 0 0 0 0 )) NATURAL) (2 ((146 161) (247 161)) NIL ((101. 0 0 0 0 0 )) NATURAL) (2 ((247 161) (247 255)) NIL ((0 94. 0 0 0 0 )) NATURAL) (5 ((247 255) (246 267) (240 278) (227 283) (216 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((216 284) (216 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((216 294) (378 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((378 294) (378 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((378 284) (367 283) (354 278) (348 267) (347 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((347 255) (347 39)) NIL ((0 -216. 0 0 0 0 )) NATURAL) (5 ((347 39) (348 27) (354 16) (367 11) (378 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((378 10) (378 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((378 0) (216 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL) (2 ((216 0) (216 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((216 10) (227 11) (240 16) (246 27) (247 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((247 39) (247 139)) NIL ((0 100. 0 0 0 0 )) NATURAL) (2 ((247 139) (146 139)) NIL ((-101. 0 0 0 0 0 )) NATURAL) (2 ((146 139) (146 39)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (5 ((146 39) (147 27) (153 16) (166 11) (177 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((177 10) (177 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((177 0) (15 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 111Q) (FACE M R R) (WIDTH 193 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:10:25) (MADE-FROM NIL 104 130 82 78) (SPLINES ((2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (176 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((176 294) (176 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((176 284) (165 283) (152 278) (146 267) (145 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((145 255) (144 39)) NIL ((-1. -216. 0 0 0 0 )) NATURAL) (5 ((144 39) (145 27) (151 16) (164 11) (175 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((175 10) (175 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((175 0) (14 0)) NIL ((-161. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 112Q) (FACE M R R) (WIDTH 271 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:11:38) (MADE-FROM NIL 115 130 82 78) (SPLINES ((2 ((124 59) (124 255)) NIL ((0 196. 0 0 0 0 )) NATURAL) (5 ((124 255) (123 267) (117 278) (104 283) (93 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((93 284) (93 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((93 294) (255 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((255 294) (255 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((255 284) (244 283) (231 278) (225 267) (224 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((224 255) (223 79)) NIL ((-1. -176. 0 0 0 0 )) NATURAL) (18 ((223 79) (217 45) (197 18) (164 1) (118 -5) (78 -3) (42 7) (21 25) (12 53) (26 81) (56 91) (86 81) (101 55) (92 33) (95 15) (111 16) (124 36) (124 59)) NIL ((-2.9017105 -35.337036 0 0 -18.5897369 8.0222225 ) (-12.1965789 -31.325923 -18.5897369 8.0222225 8.9486904 1.8888855 ) (-26.311969 -22.359256 -9.6410465 9.911108 -11.2050266 2.42223167 ) (-41.555526 -11.2370338 -20.846073 12.3333397 35.871421 -5.57781029 ) (-44.465889 -1.69259977 15.02535 6.7555294 -18.280677 1.88901138 ) (-38.580879 6.0074358 -3.25532723 8.6445408 25.251281 -1.97823906 ) (-29.210563 13.662857 21.995956 6.66630173 -16.724468 6.02394868 ) (-15.576843 23.341133 5.27148724 12.69025 23.646598 -10.1175556 ) (1.51794481 30.972602 28.918087 2.57269335 -11.8619308 -25.553714 ) (24.505065 20.768436 17.056156 -22.981021 -18.198871 4.3324356 ) (32.461784 -0.0463663712 -1.14271569 -18.648586 -11.342575 -3.77604294 ) (25.647781 -20.582973 -12.485292 -22.424629 -26.43082 34.771736 ) (-0.0529238358 -25.62173 -38.916114 12.3471107 63.065887 -15.310928 ) (-7.43609429 -20.930084 24.149772 -2.96381903 -9.8327484 26.47198 ) (11.797304 -10.657913 14.317024 23.508163 -17.734897 -0.577007294 ) (17.246875 12.5617447 -3.41787434 22.931156 -15.227651 -24.163944 ) (6.21517563 23.410926 -18.645526 -1.23278904 18.645526 1.23278904 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 113Q) (FACE M R R) (WIDTH 347 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:15:22) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((191 284) (191 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((191 294) (311 294)) NIL ((120. 0 0 0 0 0 )) NATURAL) (2 ((311 294) (311 286)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((311 286) (285 273) (255 248) (208 199)) NIL ((-26.066665 -11.3999996 0 0 0.399999619 -9.60000039 ) (-25.866664 -16.1999969 0.399999619 -9.60000039 -25.999996 -23.999996 ) (-38.466667 -37.799995 -25.599998 -33.599998 25.599998 33.599998 )) NATURAL) (4 ((208 199) (273 90) (311 30) (335 8)) NIL ((71.26666 -119.5333 0 0 -37.599998 63.199997 ) (52.466659 -87.933319 -37.599998 63.199997 26. -22. ) (27.866664 -35.733329 -11.599998 41.199996 11.599998 -41.199996 )) NATURAL) (2 ((335 8) (335 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((335 0) (192 0)) NIL ((-143. 0 0 0 0 0 )) NATURAL) (2 ((192 0) (192 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (3 ((192 10) (204 17) (204 28)) NIL ((15. 6. 0 0 -18. 6. ) (6. 9. -18. 6. 18. -6. )) NATURAL) (2 ((204 28) (145 137)) NIL ((-59. 109. 0 0 0 0 )) NATURAL) (2 ((145 137) (145 39)) NIL ((0 -98. 0 0 0 0 )) NATURAL) (4 ((145 39) (146 27) (152 16) (162 10)) NIL ((-0.0666666031 -11.933332 0 0 6.3999996 -0.399999857 ) (3.1333332 -12.133333 6.3999996 -0.399999857 -2. 7.99999905 ) (8.5333328 -8.5333328 4.39999962 7.59999943 -4.39999962 -7.59999943 )) NATURAL) (2 ((162 10) (162 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((162 0) (24 0)) NIL ((-138. 0 0 0 0 0 )) NATURAL) (2 ((24 0) (24 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (4 ((24 10) (38 16) (44 27) (45 39)) NIL ((15.799999 4.73333264 0 0 -10.799999 7.59999943 ) (10.3999996 8.5333328 -10.799999 7.59999943 6. -7.99999905 ) (2.59999943 12.133333 -4.79999924 -0.399999976 4.79999924 0.399999976 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (4 ((45 255) (44 267) (38 278) (24 284)) NIL ((-0.199999958 11.933332 0 0 -4.80000019 0.399999857 ) (-2.5999999 12.133333 -4.80000019 0.399999857 -5.99999905 -7.99999905 ) (-10.3999996 8.5333328 -10.799999 -7.59999943 10.799999 7.59999943 )) NATURAL) (2 ((24 284) (24 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((24 294) (162 294)) NIL ((138. 0 0 0 0 0 )) NATURAL) (2 ((162 294) (162 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (4 ((162 284) (152 278) (146 267) (145 255)) NIL ((-10.7333316 -4.73333264 0 0 4.39999962 -7.59999943 ) (-8.5333328 -8.5333328 4.39999962 -7.59999943 2. 7.99999905 ) (-3.1333332 -12.133333 6.3999996 0.399999976 -6.3999996 -0.399999976 )) NATURAL) (2 ((145 255) (145 163)) NIL ((0 -92. 0 0 0 0 )) NATURAL) (7 ((145 163) (174 190) (205 222) (221 247) (222 268) (206 280) (191 284)) NIL ((27.587177 25.198715 0 0 8.476923 10.8076915 ) (31.825637 30.602561 8.476923 10.8076915 -30.384613 -24.038459 ) (25.110256 29.391021 -21.907691 -13.230768 11.0615387 13.346151 ) (8.73333169 22.833332 -10.846153 0.115384549 -13.8615379 -11.346151 ) (-9.04358865 17.275638 -24.70769 -11.230768 32.384613 2.03846168 ) (-17.558971 7.06410218 7.6769228 -9.1923065 -7.6769228 9.1923065 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 114Q) (FACE M R R) (WIDTH 277 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:18:16) (MADE-FROM NIL 125 130 82 78) (SPLINES ((2 ((12 0) (12 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((12 10) (23 11) (36 16) (42 27) (43 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((43 39) (43 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((43 255) (42 267) (36 278) (23 283) (12 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((12 284) (12 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((12 294) (174 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((174 294) (174 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((174 284) (163 283) (150 278) (144 267) (143 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((143 255) (143 39)) NIL ((0 -216. 0 0 0 0 )) NATURAL) (8 ((143 39) (145 29) (154 19) (184 19) (214 31) (235 51) (247 71) (256 101)) NIL ((1.59704542 -9.46822358 0 0 2.41772652 -3.1906557 ) (2.80590868 -11.0635509 2.41772652 -3.1906557 29.911365 15.953277 ) (20.179317 -6.2775669 32.329093 12.7626228 -38.063201 -0.622465134 ) (33.476806 6.17382336 -5.73411179 12.1401577 -3.658535 -1.46341705 ) (25.913429 17.582271 -9.3926468 10.6767406 -1.30264663 -17.523868 ) (15.869459 19.497077 -10.695293 -6.84713078 8.86911584 23.55891 ) (9.6087246 24.429405 -1.8261764 16.71178 1.8261764 -16.71178 )) NATURAL) (2 ((256 101) (269 98)) NIL ((13. -3. 0 0 0 0 )) NATURAL) (2 ((269 98) (256 0)) NIL ((-13. -98. 0 0 0 0 )) NATURAL) (2 ((256 0) (12 0)) NIL ((-244. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 115Q) (FACE M R R) (WIDTH 452 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:20:58) (MADE-FROM NIL 35 130 82 78) (SPLINES ((2 ((12 0) (12 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((12 10) (23 11) (36 16) (42 27) (43 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((43 39) (43 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((43 255) (42 267) (36 278) (23 283) (12 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((12 284) (12 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((12 294) (148 294)) NIL ((136. 0 0 0 0 0 )) NATURAL) (2 ((148 294) (228 121)) NIL ((80. -173. 0 0 0 0 )) NATURAL) (2 ((228 121) (304 294)) NIL ((76. 173. 0 0 0 0 )) NATURAL) (2 ((304 294) (436 294)) NIL ((132. 0 0 0 0 0 )) NATURAL) (2 ((436 294) (436 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((436 284) (425 283) (412 278) (406 267) (405 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((405 255) (405 39)) NIL ((0 -216. 0 0 0 0 )) NATURAL) (5 ((405 39) (406 27) (412 16) (425 11) (436 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((436 10) (436 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((436 0) (274 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL) (2 ((274 0) (274 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((274 10) (285 11) (298 16) (304 27) (305 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((305 39) (305 231)) NIL ((0 192. 0 0 0 0 )) NATURAL) (2 ((305 231) (205 0)) NIL ((-100. -231. 0 0 0 0 )) NATURAL) (3 ((205 0) (180 0) (180 0)) NIL ((-31.25 0 0 0 37.5 0 ) (-12.5 0 37.5 0 -37.5 0 )) NATURAL) (2 ((180 0) (75 225)) NIL ((-105. 225. 0 0 0 0 )) NATURAL) (2 ((75 225) (75 39)) NIL ((0 -186. 0 0 0 0 )) NATURAL) (5 ((75 39) (76 27) (82 16) (95 11) (106 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((106 10) (106 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((106 0) (12 0)) NIL ((-94. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/lispusers/TMAX b/lispusers/TMAX new file mode 100644 index 00000000..656c1e26 --- /dev/null +++ b/lispusers/TMAX @@ -0,0 +1,242 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-May-99 08:41:45" {DSK}medley3.5>lispusers>TMAX.;5 28668 changes to%: (MACROS MAKE.XREFOBJ.IMAGEFNS) previous date%: "18-May-99 22:44:24" {DSK}medley3.5>lispusers>TMAX.;3) (* ; " Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT TMAXCOMS) (RPAQQ TMAXCOMS ( (* ;  "Developed under support from NIH grant RR-00785.") (* ;  "Written by Frank Gilmurray and Sami Shaio.") (FILES (COMPILED SYSLOAD) TEDIT FREEMENU) (VARS TMAX.FILE.LIST) [DECLARE%: DONTCOPY (P (DOFILESLOAD (LIST* '(SOURCE) TMAX.FILE.LIST))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (OR (GETPROP 'EXPORTS.ALL 'FILE) (LOAD 'EXPORTS.ALL] (P (DOFILESLOAD TMAX.FILE.LIST)) (* ;;; "Free Menu data structures") (VARS TSP.FM.DESC IMAGEOBJ.MENU.ITEMS) (* ;;; "Free Menu functions") (FNS TSP.DISPLAY.FMMENU TSP.SETUP.FILENAMES TSP.SETUP.FMMENU TSP.FMMENU TSP.FM.APPLY UPDATE.ALL DOWNDATE.ALL TSP.FUNCTION.HOOKS TSP.GETFN TSP.PUTFN) (* ;;; "Free Menu toggle functions") (FNS AutoUpdate.TOGGLE UPDATE? NGROUP.Menu.TOGGLE NGROUPMENU.ENABLED? NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE TEXTAFTER.ENABLED? Manual.Index.TOGGLE MANUALINDEX.ENABLED?) (* ;;; "TSP font stuff") (FNS GET.TSP.FONT GET.TSP.FONT.FAMILY GET.TSP.FONT.SIZE GET.TSP.FONT.FACE ABBREVIATE.FONT TMAX.SHADEOBJ) (* ;;; "Collect ImageObjects") (FNS TSP.LIST.OF.OBJECTS) (GLOBALVARS GP.DefaultFont GP.DefaultShade) (MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS MAKE.XREFOBJ.IMAGEFNS) (VARS (GP.DefaultFont (FONTCREATE 'GACHA 10)) (GP.DefaultShade 10260) (\NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (\DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (\REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (\XREFOBJ.IMAGEFNS (MAKE.XREFOBJ.IMAGEFNS))) (ADDVARS (IMAGEOBJGETFNS (DATE.GETFN) (NUMBER.GETFN) (REGMARK.GETFN) (XREF.GETFN))) (P [TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(TMAX% Menu (FUNCTION TSP.DISPLAY.FMMENU) NIL (SUBITEMS (Update [FUNCTION (LAMBDA (TEXTSTREAM) (UPDATE.ALL TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Updates all cross-references" ) (NGroup% Menu [FUNCTION (LAMBDA (TEXTSTREAM) (GRAPHMENU TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Displays number-group menu"] (TSP.FUNCTION.HOOKS)))) (* ; "Developed under support from NIH grant RR-00785.") (* ; "Written by Frank Gilmurray and Sami Shaio.") (FILESLOAD (COMPILED SYSLOAD) TEDIT FREEMENU) (RPAQQ TMAX.FILE.LIST (TMAX-DATE TMAX-ENDNOTE TMAX-INDEX TMAX-NUMBER TMAX-NGRAPH TMAX-NGROUP TMAX-XREF)) (DECLARE%: DONTCOPY (DOFILESLOAD (LIST* '(SOURCE) TMAX.FILE.LIST)) (DECLARE%: EVAL@COMPILE DONTCOPY (OR (GETPROP 'EXPORTS.ALL 'FILE) (LOAD 'EXPORTS.ALL)) ) ) (DOFILESLOAD TMAX.FILE.LIST) (* ;;; "Free Menu data structures") (RPAQQ TSP.FM.DESC [(PROPS FORMAT TABLE TYPE MOMENTARY FONT (HELVETICA 10 BRR)) ((LABEL "Miscellany:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Update" ID UPDATE SELECTEDFN TSP.FM.APPLY) (LABEL "Undo Update" ID UNDOUPDATE SELECTEDFN TSP.FM.APPLY) (LABEL "Set AutoUpdate" TYPE TOGGLE SELECTEDFN AutoUpdate.TOGGLE FONT (NIL NIL BIR)) (LABEL "Date/Time" ID DATE/TIME SELECTEDFN TSP.FM.APPLY)) ((LABEL "References:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Reference" ID REFERENCE SELECTEDFN TSP.FM.APPLY) (LABEL "Known References" ID KNOWNREF SELECTEDFN TSP.FM.APPLY) (LABEL "Reference By" TYPE STATE MENUITEMS (Ask Value Page) INITSTATE Value LINKS (DISPLAY DEFAULTREF)) (LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (GACHA 10 MRR))) ((LABEL "Endnotes:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Endnote" ID ENDNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Insert Endnotes" ID INSERTNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Delete Endnotes" ID DELETENOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Set Style" ID SETSTYLE SELECTEDFN TSP.FM.APPLY)) ((LABEL "Numbering:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "NGroup Menu" TYPE TOGGLE ID NGROUP.MENU SELECTEDFN NGROUP.Menu.TOGGLE FONT (NIL NIL BIR)) (LABEL "New Ngroup" ID NEWNGROUP SELECTEDFN TSP.FM.APPLY) (LABEL "Text Before" TYPE TOGGLE SELECTEDFN NGROUP.Text-Before.TOGGLE FONT (NIL NIL BIR)) (LABEL "Text After" TYPE TOGGLE SELECTEDFN NGROUP.Text-After.TOGGLE FONT (NIL NIL BIR))) ((LABEL "Contents File:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Create TOC" ID CREATETOC SELECTEDFN TSP.FM.APPLY) (LABEL "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY) (LABEL "TOC Filename:" TYPE EDITSTART LINKS (EDIT TOC.FILE)) (LABEL "" TYPE EDIT ID TOC.FILE FONT (GACHA 10 MRR))) ((LABEL "Indices:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Index" ID INDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Extended Index" ID XTNDINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Known Indices" ID KNOWNINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Manual Index" TYPE TOGGLE SELECTEDFN Manual.Index.TOGGLE FONT (NIL NIL BIR))) ((LABEL "Indices File:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Create Index" ID CREATEINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Index Filename:" TYPE EDITSTART LINKS (EDIT INDEX.FILE)) (LABEL "" TYPE EDIT ID INDEX.FILE FONT (GACHA 10 MRR]) (RPAQQ IMAGEOBJ.MENU.ITEMS ((UPDATE (UPDATE.ALL TSTREAM TWINDOW)) (UNDOUPDATE (DOWNDATE.ALL TSTREAM TWINDOW)) (DATE/TIME (TEDIT.INSERT.OBJECT (DATEOBJ) (TEXTOBJ TSTREAM))) (REFERENCE (INSERT.REF TSTREAM)) (KNOWNREF (INSERT.REF TSTREAM T)) (ENDNOTE (ADD.ENDNOTE TSTREAM TWINDOW)) (INSERTNOTE (INSERT.ENDNOTES TSTREAM TWINDOW)) (DELETENOTE (DELETE.ENDNOTES TSTREAM)) (SETSTYLE (SET.ENDNOTE.STYLE TSTREAM TWINDOW)) (NEWNGROUP (AND (ADD.NUMBER.GROUP TWINDOW TSTREAM) (GRAPHMENU TSTREAM TWINDOW))) (CREATETOC (CREATE.TOC.FILE TSTREAM TWINDOW)) (VIEWTOC (VIEW.TOC.FILE TSTREAM TWINDOW)) (INDEX (INSERT.INDEX TSTREAM TWINDOW)) (XTNDINDEX (INSERT.INDEXENTRY TSTREAM TWINDOW)) (KNOWNINDEX (INSERT.KNOWN.INDEX TSTREAM TWINDOW)) (CREATEINDEX (VIEW.INDEX.FILE TSTREAM TWINDOW T)) (VIEWINDEX (VIEW.INDEX.FILE TSTREAM TWINDOW)))) (* ;;; "Free Menu functions") (DEFINEQ (TSP.DISPLAY.FMMENU + [LAMBDA (STREAM) (* fsg "24-Aug-87 14:37") + (* * Here when user buttons TMAX Menu in the TEDIT.DEFAULT.MENU.) + + (LET ((WINDOW (\TEDIT.MAINW STREAM)) + (IMAGEOBJ.MENUW (TSP.FMMENU STREAM))) + (AND (NOT (OPENWP IMAGEOBJ.MENUW)) + (PROGN (TSP.SETUP.FILENAMES IMAGEOBJ.MENUW) + (ATTACHWINDOW IMAGEOBJ.MENUW WINDOW 'TOP 'JUSTIFY) + (WINDOWPROP IMAGEOBJ.MENUW 'PASSTOMAINCOMS '(MOVEW SHAPEW SHRINKW BURYW]) (TSP.SETUP.FILENAMES + [LAMBDA (OBJMENUW) (* ; "Edited 11-Nov-87 11:19 by drc:") + + (* * Here when displaying the TMAX menu. + Setup the TOC/INDEX filenames if they're not already specified.) + + (LET ((TEXT.FILE (with TEXTOBJ TEXTOBJ TXTFILE))) + (AND (STREAMP TEXT.FILE) + (LET* [(FILE.NAME (fetch (STREAM FULLNAME) of TEXT.FILE)) + (FILE.BASE (PACKFILENAME 'HOST (FILENAMEFIELD FILE.NAME 'HOST) + 'DIRECTORY + (FILENAMEFIELD FILE.NAME 'DIRECTORY) + 'NAME + (FILENAMEFIELD FILE.NAME 'NAME] + (for EXTENSION in '(TOC INDEX) + do (LET ((FM.ITEM (FM.GETITEM (MKATOM (CONCAT EXTENSION ".FILE")) + NIL OBJMENUW))) + (AND (STREQUAL (FM.ITEMPROP FM.ITEM 'LABEL) + "") + (FM.CHANGESTATE FM.ITEM (CONCAT FILE.BASE "." EXTENSION) + OBJMENUW]) (TSP.SETUP.FMMENU + [LAMBDA (WINDOW) (* fsg "24-Aug-87 16:04") + (* * Here to set up things like the FreeMenu, hasharrays, etc. + the first time through.) + + (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) + (TSP.FMMENU (OR (CAR (NLSETQ (TEXTSTREAM WINDOW))) + (with STREAM (with TEXTOBJ TEXTOBJ STREAMHINT) + FULLNAME]) (TSP.FMMENU [LAMBDA (STREAM) (* ; "Edited 2-May-97 17:02 by rmk:") (* ; "Edited 29-Sep-87 11:17 by fsg") (* ;; "Creates the TMAX ImageObj menu but doesn't attach itself to the main TEdit window.") (LET ((WINDOW (\TEDIT.MAINW STREAM)) IMAGEOBJ.MENUW) (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) (PROGN (CL:UNLESS (HASHARRAYP (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY)) (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY (HASHARRAY 100))) (CL:UNLESS (HASHARRAYP (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)) (WINDOWPROP WINDOW 'TSP.CODE.ARRAY (HASHARRAY 100))) (SETQ IMAGEOBJ.MENUW (FREEMENU TSP.FM.DESC "TMAX (Tedit Macros And eXtensions)")) (WINDOWPROP IMAGEOBJ.MENUW 'TSTREAM STREAM) (WINDOWADDPROP IMAGEOBJ.MENUW 'CLOSEFN (FUNCTION FREEATTACHEDWINDOW)) (WINDOWPROP IMAGEOBJ.MENUW 'TWINDOW WINDOW) (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW IMAGEOBJ.MENUW) IMAGEOBJ.MENUW]) (TSP.FM.APPLY + [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:17 by fsg") + + (LET [(LABEL (FM.ITEMPROP ITEM 'ID)) + (TSTREAM (WINDOWPROP WINDOW 'TSTREAM)) + (TWINDOW (WINDOWPROP WINDOW 'TWINDOW] + (EVAL (CADR (ASSOC LABEL IMAGEOBJ.MENU.ITEMS]) (UPDATE.ALL + [LAMBDA (STREAM WINDOW) (* fsg "24-Aug-87 11:40") + (* * Update the NGroup/Endnote numbers and any References to them.) + + (UPDATE.NUMBEROBJS WINDOW STREAM 'NUMBEROBJP) + (UPDATE.XREFS WINDOW) + (* * This should check if there is an Endnote section. + If there is one then we want to re-insert the Endnotes. + The test for REGMARKOBJs works because we are only using them for the purpose + of marking the Endnote section.) + + (AND (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) + 'REGMARKOBJP) + (INSERT.ENDNOTES STREAM WINDOW]) (DOWNDATE.ALL + [LAMBDA (STREAM WINDOW) (* fsg "24-Sep-87 16:16") + (* * Undo everything that UPDATE does.) + + (DOWNDATE.NUMBEROBJS WINDOW STREAM 'NUMBEROBJP) + (UPDATE.XREFS WINDOW T) + (AND (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) + 'REGMARKOBJP) + (INSERT.ENDNOTES STREAM WINDOW]) (TSP.FUNCTION.HOOKS + [LAMBDA NIL (* fsg " 3-Aug-87 15:33") + (* * Called during LOAD to set up any function hooks.) + + (LET (FUNCTION.HOOK) + (AND (SETQ FUNCTION.HOOK (LISTGET TEDIT.DEFAULT.PROPS 'GETFN)) + (NEQ FUNCTION.HOOK (FUNCTION TSP.GETFN)) + (PROGN (PRINTOUT PROMPTWINDOW T .CENTER 0 (CONCAT "TEdit GETFN hook " FUNCTION.HOOK + " replaced by TMAX GETFN hook.") + T) + (FLASHWINDOW PROMPTWINDOW 2))) + [COND + ((LISTP TEDIT.DEFAULT.PROPS) + (LISTPUT TEDIT.DEFAULT.PROPS 'GETFN (FUNCTION TSP.GETFN))) + (T (SETQ TEDIT.DEFAULT.PROPS (LIST 'GETFN (FUNCTION TSP.GETFN] + (AND (SETQ FUNCTION.HOOK (LISTGET TEDIT.DEFAULT.PROPS 'PUTFN)) + (NEQ FUNCTION.HOOK (FUNCTION TSP.PUTFN)) + (PROGN (PRINTOUT PROMPTWINDOW T .CENTER 0 (CONCAT "TEdit PUTFN hook " FUNCTION.HOOK + " replaced by TMAX PUTFN hook.") + T) + (FLASHWINDOW PROMPTWINDOW 2))) + (COND + ((LISTP TEDIT.DEFAULT.PROPS) + (LISTPUT TEDIT.DEFAULT.PROPS 'PUTFN (FUNCTION TSP.PUTFN))) + (T (SETQ TEDIT.DEFAULT.PROPS (LIST 'PUTFN (FUNCTION TSP.PUTFN]) (TSP.GETFN + [LAMBDA (STREAM FILENAME FLAVOR) (* fsg "24-Aug-87 14:27") + (* * Called both BEFORE and AFTER a TEdit GET. + Only interested in BEFORE call at which time we clear all the hash arrays in + case of multiple GETs.) + + (AND (EQ FLAVOR 'BEFORE) + (LET ((WINDOW (\TEDIT.MAINW STREAM))) + (CLRHASH (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)) + (CLRHASH (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) + (CLRHASH (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY]) (TSP.PUTFN + [LAMBDA (STREAM FILENAME FLAVOR) (* fsg " 3-Aug-87 11:05") + (* * Called both before and after a TEdit PUT.) + + (LET ((WINDOW (\TEDIT.MAINW STREAM))) + (COND + ((EQ FLAVOR 'BEFORE) + (WINDOWPROP WINDOW 'DUMPNGROUPGRAPH T)) + (T (WINDOWPROP WINDOW 'DUMPNGROUPGRAPH NIL]) ) (* ;;; "Free Menu toggle functions") (DEFINEQ (AutoUpdate.TOGGLE + [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:35 by fsg") + + (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) + 'AUTOUPDATE + (FM.ITEMPROP ITEM 'STATE]) (UPDATE? + [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:33") + (WINDOWPROP WINDOW 'AUTOUPDATE]) (NGROUP.Menu.TOGGLE + [LAMBDA (ITEM WINDOW BUTTON) (* ss%: "27-Jun-87 16:28") + (LET [(TWINDOW (WINDOWPROP WINDOW 'TWINDOW)) + (TSTREAM (WINDOWPROP WINDOW 'TSTREAM)) + (TOGGLE.STATE (FM.ITEMPROP ITEM 'STATE] + (COND + (TOGGLE.STATE (GRAPHMENU TSTREAM TWINDOW)) + (T (CLOSE.NGROUP.GRAPH TWINDOW]) (NGROUPMENU.ENABLED? + [LAMBDA (TWINDOW) (* ; "Edited 29-Sep-87 11:42 by fsg") + + (FM.ITEMPROP (FM.GETITEM 'NGROUP.MENU NIL (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) + 'STATE]) (NGROUP.Text-Before.TOGGLE + [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:45 by fsg") + + (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) + 'NGROUPTEXTBEFORE + (FM.ITEMPROP ITEM 'STATE]) (TEXTBEFORE.ENABLED? + [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:29") + (WINDOWPROP WINDOW 'NGROUPTEXTBEFORE]) (NGROUP.Text-After.TOGGLE + [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:46 by fsg") + + (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) + 'NGROUPTEXTAFTER + (FM.ITEMPROP ITEM 'STATE]) (TEXTAFTER.ENABLED? + [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:29") + (WINDOWPROP WINDOW 'NGROUPTEXTAFTER]) (Manual.Index.TOGGLE + [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:48 by fsg") + + (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) + 'MANUALINDEX + (FM.ITEMPROP ITEM 'STATE]) (MANUALINDEX.ENABLED? + [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:27") + (WINDOWPROP WINDOW 'MANUALINDEX]) ) (* ;;; "TSP font stuff") (DEFINEQ (GET.TSP.FONT + [LAMBDA (WINDOW DEFAULT.FONT FONT.FIELD) (* fsg " 8-Jul-87 10:08") + (* * Return the font descriptor list. If the FAMILY, SIZE, and/or FACE is not + specified, it defaults to the corresponding value in the DEFAULT.FONT + descriptor. If FONT.FIELD is non-NIL, it specifies which one of the three + fields to get.) + + (LET ([FAMILY (COND + ((AND FONT.FIELD (NEQ FONT.FIELD 'FAMILY)) + (FONTPROP DEFAULT.FONT 'FAMILY)) + (T (GET.TSP.FONT.FAMILY DEFAULT.FONT] + [SIZE (COND + ((AND FONT.FIELD (NEQ FONT.FIELD 'SIZE)) + (FONTPROP DEFAULT.FONT 'SIZE)) + (T (GET.TSP.FONT.SIZE DEFAULT.FONT] + [FACE (COND + ((AND FONT.FIELD (NEQ FONT.FIELD 'FACE)) + (FONTPROP DEFAULT.FONT 'FACE)) + (T (GET.TSP.FONT.FACE DEFAULT.FONT] + NEWENTRY.FONT) + (AND (SETQ NEWENTRY.FONT (FONTCREATE FAMILY SIZE FACE NIL NIL T)) + (LIST FAMILY SIZE (FONTPROP NEWENTRY.FONT 'FACE]) (GET.TSP.FONT.FAMILY + [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") + (* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.) + + (OR [MKATOM (MENU (create MENU + TITLE _ "Font Family" + CENTERFLG _ T + ITEMS _ '((Classic 'CLASSIC) + (Gacha 'GACHA) + (Helvetica 'HELVETICA) + (Modern 'MODERN) + (TimesRoman 'TIMESROMAN] + (FONTPROP DEFAULT.FONT 'FAMILY]) (GET.TSP.FONT.SIZE + [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 09:56") + (* * Get the font size from the menu or DEFAULT.FONT if the menu returns NIL.) + + (OR [MKATOM (MENU (create MENU + TITLE _ "Font Size" + CENTERFLG _ T + MENUCOLUMNS _ 2 + ITEMS _ '(6 8 10 12 14 18 24 36] + (FONTPROP DEFAULT.FONT 'SIZE]) (GET.TSP.FONT.FACE + [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") + (* * Get the font face from the menu or DEFAULT.FONT if the menu returns NIL.) + + (OR [MKATOM (MENU (create MENU + TITLE _ "Font Face" + CENTERFLG _ T + ITEMS _ '((Standard 'MRR "(MEDIUM REGULAR REGULAR)") + (Italic 'MIR "(MEDIUM ITALIC REGULAR)") + (Bold 'BRR "(BOLD REGULAR REGULAR)") + (BoldItalic 'BIR "(BOLD ITALIC REGULAR)"] + (FONTPROP DEFAULT.FONT 'FACE]) (ABBREVIATE.FONT + [LAMBDA (FONT) (* fsg " 8-Jul-87 15:57") + (* * Returns an abbreviated font description. + For example, if the font is (TIMESROMAN 12 + (BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.) + + (LET [(FONT.LIST (COND + [(FONTP FONT) + (LIST (FONTPROP FONT 'FAMILY) + (FONTPROP FONT 'SIZE) + (FONTPROP FONT 'FACE] + (T FONT] + (LIST (LET ((FONT.FAMILY (CAR FONT.LIST))) + (SELECTQ FONT.FAMILY + (CLASSIC 'Classic) + (GACHA 'Gacha) + (HELVETICA 'Helvetica) + (MODERN 'Modern) + (TIMESROMAN 'TimesRoman) + FONT.FAMILY)) + (CADR FONT.LIST) + (LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST) collect (GNC FIELD] + (SELECTQ (MKATOM FONT.FACE) + (MRR 'Standard) + (MIR 'Italic) + (BRR 'Bold) + (BIR 'BoldItalic) + FONT.FACE]) (TMAX.SHADEOBJ [LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:") (* fsg "17-Sep-87 11:25") (* ;; "Shade the ImageObject to distinguish it from normal text.") (AND (IMAGESTREAMTYPEP STREAM 'DISPLAY) (LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] (BLTSHADE (OR SHADE GP.DefaultShade) STREAM (DSPXPOSITION NIL STREAM) (IDIFFERENCE (DSPYPOSITION NIL STREAM) (FETCH YDESC OF BOUNDBOX)) (FETCH XSIZE OF BOUNDBOX) (FETCH YSIZE OF BOUNDBOX]) ) (* ;;; "Collect ImageObjects") (DEFINEQ (TSP.LIST.OF.OBJECTS + [LAMBDA (TEXTOBJ TESTFN TESTFNARG) (* ss%: "27-Jun-87 16:32") + (* * Loop through each PIECE of the TEdit document and call the user supplied + function on those PIECEs that are ImageObjects.) + + (AND TESTFN (LET ((OBJLIST (TCONC NIL))) + (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PIECE PC# OBL) + (AND (TYPENAMEP PIECE 'PIECE) + (IMAGEOBJP (fetch POBJ of PIECE)) + (APPLY* TESTFN (fetch POBJ + of PIECE) + TESTFNARG) + (TCONC OBL + (LIST (fetch POBJ of PIECE) + CH#] + OBJLIST) + (CDAR OBJLIST]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GP.DefaultFont GP.DefaultShade) ) (DECLARE%: EVAL@COMPILE (PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN) (FUNCTION DATE.IMAGEBOXFN) (FUNCTION DATE.PUTFN) (FUNCTION DATE.GETFN) (FUNCTION DATE.COPYFN) (FUNCTION DATE.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) (PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN) (FUNCTION NUMBER.IMAGEBOXFN) (FUNCTION NUMBER.PUTFN) (FUNCTION NUMBER.GETFN) (FUNCTION NUMBER.COPYFN) (FUNCTION NUMBER.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION XREF.WHENDELETEDFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NUMBER.PREPRINTFN]) (PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN) (FUNCTION REGMARK.IMAGEBOXFN) (FUNCTION REGMARK.PUTFN) (FUNCTION REGMARK.GETFN) (FUNCTION REGMARK.COPYFN) (FUNCTION REGMARK.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) (PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN) (FUNCTION XREF.IMAGEBOXFN) (FUNCTION XREF.PUTFN) (FUNCTION XREF.GETFN) (FUNCTION XREF.COPYFN) (FUNCTION XREF.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION XREF.GET.DISPLAY.TEXT]) ) (RPAQ GP.DefaultFont (FONTCREATE 'GACHA 10)) (RPAQQ GP.DefaultShade 10260) (RPAQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (RPAQ \DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (RPAQ \REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (RPAQ \XREFOBJ.IMAGEFNS (MAKE.XREFOBJ.IMAGEFNS)) (ADDTOVAR IMAGEOBJGETFNS (DATE.GETFN) (NUMBER.GETFN) (REGMARK.GETFN) (XREF.GETFN)) [TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(TMAX% Menu (FUNCTION TSP.DISPLAY.FMMENU) NIL (SUBITEMS (Update [FUNCTION (LAMBDA (TEXTSTREAM) (UPDATE.ALL TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Updates all cross-references") (NGroup% Menu [FUNCTION (LAMBDA (TEXTSTREAM) (GRAPHMENU TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Displays number-group menu"] (TSP.FUNCTION.HOOKS) (PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987 1997 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8744 15959 (TSP.DISPLAY.FMMENU 8754 . 9319) (TSP.SETUP.FILENAMES 9321 . 10572) ( TSP.SETUP.FMMENU 10574 . 11034) (TSP.FMMENU 11036 . 12222) (TSP.FM.APPLY 12224 . 12543) (UPDATE.ALL 12545 . 13217) (DOWNDATE.ALL 13219 . 13589) (TSP.FUNCTION.HOOKS 13591 . 15021) (TSP.GETFN 15023 . 15583) (TSP.PUTFN 15585 . 15957)) (16005 18254 (AutoUpdate.TOGGLE 16015 . 16251) (UPDATE? 16253 . 16398) (NGROUP.Menu.TOGGLE 16400 . 16782) (NGROUPMENU.ENABLED? 16784 . 17020) ( NGROUP.Text-Before.TOGGLE 17022 . 17272) (TEXTBEFORE.ENABLED? 17274 . 17437) (NGROUP.Text-After.TOGGLE 17439 . 17687) (TEXTAFTER.ENABLED? 17689 . 17850) (Manual.Index.TOGGLE 17852 . 18091) ( MANUALINDEX.ENABLED? 18093 . 18252)) (18288 23401 (GET.TSP.FONT 18298 . 19462) (GET.TSP.FONT.FAMILY 19464 . 20147) (GET.TSP.FONT.SIZE 20149 . 20637) (GET.TSP.FONT.FACE 20639 . 21338) (ABBREVIATE.FONT 21340 . 22649) (TMAX.SHADEOBJ 22651 . 23399)) (23441 24657 (TSP.LIST.OF.OBJECTS 23451 . 24655))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-DATE b/lispusers/TMAX-DATE new file mode 100644 index 00000000..c14464b2 --- /dev/null +++ b/lispusers/TMAX-DATE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "12-Mar-88 15:42:46" {erinyes}lyric>tmax-date.\;2 15254 |changes| |to:| (fns current.display.font) |previous| |date:| "30-Dec-87 11:39:18" {erinyes}lyric>tmax-date.\;1) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (prettycomprint tmax-datecoms) (rpaqq tmax-datecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * tmax-datenil |ImageObject| |functions|) (fns dateobj dateobjp date.displayfn date.imageboxfn date.putfn date.getfn date.copyfn date.buttoneventinfn) (* * |Date| |support| |functions|) (fns current.display.font change.date.format) (* * |Functions| |to| |change| |date| |format|) (fns findtime findhour ampm findday nump findmonth findyear) (vars date.format.items) (records daterecord))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * tmax-datenil |ImageObject| |functions|) (defineq (dateobj (lambda (date/time date.string template) (* |fsg| "13-Jul-87 11:51") (* * |Create| |an| |instance| |of| \a date |imageobj.|) (let* ((template.type (or template '(m d y f))) (dateandtime (or date/time (mkstring (date)))) (displaydate (or date.string (change.date.format dateandtime template.type))) (newobj (imageobjcreate (|create| daterecord datestring _ dateandtime display.date _ displaydate template.date _ template.type) \\dateobj.imagefns))) (imageobjprop newobj 'type 'dateobj) newobj))) (dateobjp (lambda (imobj) (* |ss:| "27-Jun-87 15:39") (* |Tests| |an| |imageobj| |to| |see| |if| |it| |is| \a |date| |imageobject.|  b\y |convention,| |testing| |functions| |for| |an| |imageobject| |will| |be|  |named| (concat || "P")) (and imobj (eq (imageobjprop imobj 'type) 'dateobj)))) (date.displayfn (lambda (obj stream streamtype hoststream) (* |fsg| "17-Sep-87 10:44") (* * |Display| |function| |for| |date| |imageobjs.|) (tmax.shadeobj obj stream) (prin1 (|fetch| display.date |of| (|fetch| objectdatum |of| obj)) stream))) (date.imageboxfn (lambda (obj stream currentx rightmargin) (* |ss:| "27-Jun-87 15:38") (* * |Return| |the| |ImageBox| |for| |the| |date| |string.|  |The| |size| |is| |determined| |by| |the| |stream's| |current| |font.|) (dspfont (current.display.font stream) stream) (|create| imagebox xsize _ (stringwidth (|fetch| display.date |of| (|fetch| objectdatum |of| obj)) stream) ysize _ (fontprop stream 'height) ydesc _ (fontprop stream 'descent) xkern _ 0))) (date.putfn (lambda (obj stream) (* |ss:| "27-Jun-87 15:38") (prin2 (list '|Date| (|fetch| objectdatum |of| obj)) stream))) (date.getfn (lambda (stream copy.object) (* |fsg| "20-Aug-87 14:56") (let ((window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window)) (apply (function dateobj) (or copy.object (cadr (read stream)))))) (date.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 11:34") (* * |Here| |to| copy \a |Date| |Image| |Object.|) (selectq (imagestreamtype target.stream) (text (let ((textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (|fetch| objectdatum |of| image.obj)))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (date.buttoneventinfn (lambda (obj windowstream selection relx rely window hoststream button) (* |fsg| "11-Aug-87 13:56") (and (mousestate middle) (let ((old.date (|fetch| objectdatum |of| obj)) (new.date (menu (|create| menu title _ '|Date/Time Menu| items _ date.format.items centerflg _ t)))) (and new.date (not (equal (|fetch| (daterecord template.date) |of| old.date) new.date)) (progn (|with| daterecord old.date (cond ((listp new.date) (setq display.date (change.date.format datestring new.date)) (setq template.date new.date)) (t (setq datestring (mkstring (date))) (setq display.date (change.date.format datestring template.date))))) 'changed)))))) ) (* * |Date| |support| |functions|) (defineq (current.display.font (lambda (stream) (* \; "Edited 12-Mar-88 15:28 by drc:") (* |;;;| "Return the current font. This function is here instead of TMAX because the DATE code is also used in the LetterHead code.") (let ((current.font (|fetch| clfont |of| (|with| textstream (textstream textobj) currentlooks)))) (cond ((typenamep current.font 'fontdescriptor) current.font) ((typenamep current.font 'fontclass) (|fetch| displayfd |of| current.font)) (t (shouldnt "Can't get current font")))))) (change.date.format (lambda (date template) (* |ss:| "27-Jun-87 15:36") (* * |Convert| |the| |string| date |to| |the| |format| |specified| |by|  template.) (cond (template (let ((version (|if| (equal (last template) '(a)) |then| 'abbrev |else| (|if| (equal (last template) '(f)) |then| 'full |else| 'euro))) (funclst '((d findday) (m findmonth) (y findyear)))) (cond ((eq (car template) t) (findtime date version)) (t (let ((ch (|if| (eq version 'abbrev) |then| "/" |else| " "))) (concat (apply (cadr (assoc (car template) funclst)) (list date version)) ch (apply (cadr (assoc (cadr template) funclst)) (list date version)) (|if| (equal ch " ") |then| ", " |else| ch) (apply (cadr (assoc (caddr template) funclst)) (list date version)))))))) (t (date))))) ) (* * |Functions| |to| |change| |date| |format|) (defineq (findtime (lambda (olddate version) (* |ss:| "27-Jun-87 15:40") (let ((hour (substring olddate 11 12)) (minutes (substring olddate 14 15))) (|if| (equal version 'abbrev) |then| (concat (findhour hour) ":" minutes " " (ampm hour)) |else| (|if| (equal version 'euro) |then| (substring olddate 11 15) |else| (concat (selectq (|if| (lessp (mkatom minutes) 46) |then| (mkatom (findhour hour)) |else| (plus 1 (mkatom (findhour hour)))) (1 "one") (2 "two") (3 "three") (4 "four") (5 "five") (6 "six") (7 "seven") (8 "eight") (9 "nine") (10 "ten") (11 "eleven") (12 "twelve") nil) " " (|if| (and (greaterp (mkatom minutes) 15) (lessp (mkatom minutes) 45)) |then| "thirty" |else| "o'clock") " " (|if| (and (greaterp (mkatom minutes) 44) (equal (findhour hour) "11")) |then| (|if| (equal (ampm hour) "a.m.") |then| "p.m." |else| "a.m.") |else| (ampm hour)))))))) (findhour (lambda (hour) (* |ss:| " 8-Feb-86 17:49") (cond ((lessp (mkatom hour) 13) (cond ((lessp (mkatom hour) 10) (mkstring (cadr (unpack hour)))) (t hour))) (t (mkstring (selectq (mkatom hour) (13 1) (14 2) (15 3) (16 4) (17 5) (18 6) (19 7) (20 8) (21 9) (22 10) (23 11) (24 12) nil)))))) (ampm (lambda (hour) (|if| (or (lessp (mkatom hour) 12) (equal (mkatom hour) 24)) |then| "a.m." |else| "p.m."))) (findday (lambda (olddate version) (* |shw:| " 1-Jul-85 11:28") (mkatom (|if| (nump (substring olddate 1 2)) |then| (substring olddate 1 2) |else| (substring olddate 2 2))))) (nump (lambda (n) (* |edited:| " 4-Apr-86 17:55") (* |changed|) (not (null (numberp (mkatom n)))))) (findmonth (lambda (olddate version) (* |ss:| "27-Jun-87 15:40") (prog ((dates '((|Jan| 1 |January|) (|Feb| 2 |February|) (|Mar| 3 |March|) (|Apr| 4 |April|) (|May| 5 |May|) (|Jun| 6 |June|) (|Jul| 7 |July|) (|Aug| 8 |August|) (|Sep| 9 |September|) (|Oct| 10 |October|) (|Nov| 11 |November|) (|Dec| 12 |December|))) (output nil)) (|if| (eq version 'abbrev) |then| (setq output (car (cdr (assoc (mkatom (substring olddate 4 6)) dates)))) |else| (setq output (car (cddr (assoc (mkatom (substring olddate 4 6)) dates))))) (return output)))) (findyear (lambda (olddate version) (* |ss:| "27-Jun-87 15:41") (|if| (eq version 'abbrev) |then| (mkatom (substring olddate 8 9)) |else| (mkatom (concat "19" (substring olddate 8 9)))))) ) (rpaqq date.format.items ((|Month Day, Year| '(m d y f) "Insert current date as \"March 8, 1952\"") (|Month/Day/Year| '(m d y a) "Insert current date as \"3/8/52\"") (|Day Month, Year| '(d m y f) "Insert current date as \"8 March, 1952\"") (|Day/Month/Year| '(d m y a) "Insert current date as \"8/3/52\"") (|Time| '(t f) "Insert current time as \"four thirty p.m.\"") (|Numbered Time| '(t a) "Insert current time as \"4:30 p.m.\"") (|Military Time| '(t e) "Insert current time as \"16:30\"") (|Update| t "Convert to current date/time"))) (declare\: eval@compile (record daterecord (datestring display.date template.date)) ) (putprops tmax-date copyright ("Xerox Corporation" 1987 1988)) (declare\: dontcopy (filemap (nil (1398 6132 (dateobj 1408 . 2175) (dateobjp 2177 . 2611) (date.displayfn 2613 . 2935) ( date.imageboxfn 2937 . 3564) (date.putfn 3566 . 3764) (date.getfn 3766 . 4060) (date.copyfn 4062 . 4594) (date.buttoneventinfn 4596 . 6130)) (6174 8957 (current.display.font 6184 . 6890) ( change.date.format 6892 . 8955)) (9012 14248 (findtime 9022 . 11531) (findhour 11533 . 12290) (ampm 12292 . 12496) (findday 12498 . 12769) (nump 12771 . 13000) (findmonth 13002 . 13980) (findyear 13982 . 14246))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-ENDNOTE b/lispusers/TMAX-ENDNOTE new file mode 100644 index 00000000..c848fa07 --- /dev/null +++ b/lispusers/TMAX-ENDNOTE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:38:37" |{POGO:AISNORTH:XEROX}TMAX>TMAX-ENDNOTE.;2| 22100 |previous| |date:| "11-Nov-87 11:49:07" |{POGO:AISNORTH:XEROX}TMAX>TMAX-ENDNOTE.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-endnotecoms) (rpaqq tmax-endnotecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (fns add.endnote insert.endnotes insert.endnotes.text delete.endnotes notesregionp set.endnote.style map.endnote.looks get.endnote.fonts) (fns endnotep note.putfn note.getfn note.buttoneventinfn note.whenselectedfn ) (vars endnote.notag.items endnote.tag.items) (records endnotefonts) (* * |Allow| |user| |to| |edit| |Endnote| |text| |in| |another| |TEdit| |window.|) (fns aux.tedit aux.tedit.afterquitfn aux.tedit.titlemenufn) (* * |Delimit| |text| |between| |two| |markers| |known| |as| region markers. ) (fns regmarkobj regmarkobjp regmark.displayfn regmark.imageboxfn regmark.putfn regmark.getfn regmark.copyfn regmark.buttoneventinfn) (records regmarkobj))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (defineq (add.endnote (lambda (stream window) (* |fsg| "13-Jul-87 10:44") (* * |Insert| |an| endnote |ImageObject| |as| \a |superscript.|  |Displayed| |as| \a |number| |when| |updated.|) (let ((noteobj (numberobj 'note))) (tedit.insert.object noteobj stream) (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| noteobj) |with| (or (tedit.getinput stream "Endnote text:") "")) (tedit.promptprint stream "" t) (and (update? window) (update.numberobjs window stream 'endnotep))))) (insert.endnotes (lambda (stream window) (* |fsg| "25-Sep-87 10:23") (* * |Inserts| |text| |of| |endnotes| |at| |the| |end| |of| |the| |TEdit|  |document.| |The| |text| |is| |inserted| |between| |two| |Region| |marking|  |imageobjs.|) (let ((textobj (textobj stream)) list.of.endnotes) (and (setq list.of.endnotes (tsp.list.of.objects textobj 'endnotep)) (let ((caretposition (|fetch| ch# |of| (tedit.getsel stream)))) (tedit.promptprint stream (concat (cond ((delete.endnotes stream) "Rei") (t "I")) "nserting Endnotes...") t) (tedit.insert.object (regmarkobj 'endnotes '|Endnotes-START|) stream (add1 (|fetch| textlen |of| textobj))) (tedit.looks stream '(protected on) (|fetch| textlen |of| textobj) 1) (tedit.insert stream (concat (character (charcode eol)) "Notes" (character (charcode eol))) (add1 (|fetch| textlen |of| textobj)) (|fetch| (endnotefonts title.font) |of| (get.endnote.fonts window)) t) (insert.endnotes.text stream window textobj list.of.endnotes) (tedit.insert.object (regmarkobj 'endnotes '|Endnotes-END|) stream (add1 (|fetch| textlen |of| textobj))) (tedit.looks stream '(protected on) (|fetch| textlen |of| textobj) 1) (tedit.promptprint stream "done") (tedit.normalizecaret textobj (tedit.setsel stream caretposition 1))))))) (insert.endnotes.text (lambda (stream window textobj list.of.endnotes) (* |fsg| "18-Jun-87 13:17") (* * |Here| |to| |print| |the| |text| |of| |each| |endnote.|) (let ((textlooks (|fetch| (endnotefonts text.font) |of| (get.endnote.fonts window))) (numblooks (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts window)))) (|for| endnoteobj |in| list.of.endnotes |do| (let ((numstring (mkstring (|fetch| (numberobj numstring) |of| (|fetch| objectdatum |of| (car endnoteobj ))))) (text (|fetch| (numberobj text.after#) |of| (|fetch| objectdatum |of| (car endnoteobj))))) (tedit.insert stream numstring (add1 (|fetch| textlen |of| textobj)) numblooks t) (tedit.insert stream (concat " " text (character (charcode eol))) (add1 (|fetch| textlen |of| textobj)) textlooks t)))))) (delete.endnotes (lambda (stream) (* |fsg| "25-Sep-87 10:12") (* * |Delete| |the| |Endnotes,| |i.e.| |delete| |the| |start/end| regmark  |ImageObjects| |and| |all| |the| |text| |between| |them.|) (let* ((textobj (textobj stream)) (notemarker.list (tsp.list.of.objects textobj 'notesregionp)) (notes.start (cadar notemarker.list)) (notes.end (cadadr notemarker.list))) (and notes.start notes.end (progn (tedit.promptprint stream "Deleting Endnotes..." t) (tedit.delete stream notes.start (idifference (add1 notes.end) notes.start)) (tedit.promptprint stream "done") t))))) (notesregionp (lambda (imobj) (* |ss:| "27-Jun-87 15:29") (and (regmarkobjp imobj) (eq (|fetch| region.use |of| (|fetch| objectdatum |of| imobj)) 'endnotes)))) (set.endnote.style (lambda (stream window) (* |fsg| "18-Aug-87 14:13") (* * |Set| |the| |font| |of| |the| endnote |number,| |title,| |or| |text.|) (let ((note.fonts (get.endnote.fonts window)) (note.type (menu (|create| menu title _ "Endnote Fonts" centerflg _ t items _ '(|Number| |Title| |Text|)))) old.font new.font) (and note.type (progn (setq old.font (selectq note.type (|Number| (|fetch| (endnotefonts number.font) |of| note.fonts)) (|Title| (|fetch| (endnotefonts title.font) |of| note.fonts)) (|Text| (|fetch| (endnotefonts text.font) |of| note.fonts)) nil)) (tedit.promptprint stream (concat "Change Endnote " note.type " font " (abbreviate.font old.font) " to...") t) (setq new.font (fontcreate (get.tsp.font window old.font))) (cond ((neq old.font new.font) (selectq note.type (|Number| (|replace| (endnotefonts number.font) |of| note.fonts |with| new.font)) (|Title| (|replace| (endnotefonts title.font) |of| note.fonts |with| new.font)) (|Text| (|replace| (endnotefonts text.font) |of| note.fonts |with| new.font)) nil) (and (eq note.type '|Number|) (map.endnote.looks stream new.font))) (t nil)) (tedit.promptprint stream "" t)))))) (map.endnote.looks (lambda (stream numberfont) (* |ss:| "27-Jun-87 15:26") (* * |Here| |to| |update| |the| endnote |looks.|  |Only| |the| endnote |superscript| |numbers| |are| |updated.|) (let ((list.of.notes (tsp.list.of.objects (textobj stream) 'endnotep))) (and list.of.notes (progn (tedit.promptprint stream "Updating ENDNOTE Number looks..." t) (|for| note/ch# |in| list.of.notes |do| (tedit.looks stream numberfont (cadr note/ch#) 1)) (tedit.promptprint stream "done")))))) (get.endnote.fonts (lambda (window) (* |ss:| "27-Jun-87 15:24") (* * |Setup| |the| |default| endnote |fonts| |for| |number,| |title,| |and|  |text.|) (or (windowprop window 'endnote.fonts) (progn (windowprop window 'endnote.fonts (|create| endnotefonts number.font _ |GP.DefaultFont| title.font _ |GP.DefaultFont| text.font _ |GP.DefaultFont|)) (windowprop window 'endnote.fonts))))) ) (defineq (endnotep (lambda (imobj) (* |ss:| "27-Jun-87 15:23") (* * |Like| numberobjp |but| |also| |checks| |for| note |ImageObject.|) (and (numberobjp imobj) (eq (|fetch| (numberobj use) |of| (|fetch| objectdatum |of| imobj)) 'note)))) (note.putfn (lambda (numberobj stream window) (* |fsg| "11-Aug-87 10:04") (* * |Used| |to| |put| \a |numberobj| |that| |is| |functioning| |as| |an|  |endnote.|) (|with| numberobj (|fetch| objectdatum |of| numberobj) (setq font (|for| notefont |in| (get.endnote.fonts window) |collect| (list.font.props notefont)))) (prin4 (list '|Endnote| nil (imageobjprop numberobj 'tag) (|fetch| objectdatum |of| numberobj)) stream))) (note.getfn (lambda (newobj note.datum window) (* |fsg| "16-Jul-87 10:49") (* * |Used| |to| |get| \a |numberobj| |that| |is| |functioning| |as| |an|  |endnote.|) (windowprop window 'endnote.fonts (|for| notefont |in| (|fetch| (numberobj font) |of| note.datum) |collect| (fontcreate notefont))) (|replace| (numberobj font) |of| note.datum |with| nil) (|replace| objectdatum |of| newobj |with| note.datum) newobj)) (note.buttoneventinfn (lambda (obj stream window) (* |fsg| " 5-Aug-87 09:31") (* * |Allow| |user| |to| |edit| |Endnote| |text,| |specify| \a tag\, |delete|  |the| tag\, |or| |change| |the| tag.) (let* ((tag (imageobjprop obj 'tag)) (nmenu (|create| menu title _ '|Endnote Menu| items _ (cond (tag endnote.tag.items) (t endnote.notag.items)) centerflg _ t whenselectedfn _ 'note.whenselectedfn))) (putmenuprop nmenu 'note.obj obj) (putmenuprop nmenu 'note.window window) (menu nmenu)))) (note.whenselectedfn (lambda (item menu mb) (* |fsg| "10-Aug-87 13:48") (let* ((window (getmenuprop menu 'note.window)) (obj (getmenuprop menu 'note.obj)) (tstream (textstream window))) (selectq (cadr item) ((|Change Tag| |Define Tag|) (let ((old.tag (imageobjprop obj 'tag)) (new.tag (tsp.get.incode tstream))) (and new.tag (neq new.tag old.tag) (progn (number.delete.tag window obj) (tsp.putcode new.tag obj window) (imageobjprop obj 'tag new.tag))))) (|Delete Tag| (number.delete.tag window obj)) (|Show Tag| (tedit.promptprint tstream (concat "EndNote Tag=\"" (imageobjprop obj 'tag) "\"") t)) (|Edit Text| (aux.tedit obj (concat "Endnote #" (|fetch| numstring |of| (|fetch| objectdatum |of| obj))) tstream)) (error "Undefined EndNote menu item" item)) nil))) ) (rpaqq endnote.notag.items ((|Edit Text| |Edit Text| "Edit the text associated with this EndNote.") (|Define Tag| |Define Tag| "Define a TAG for this EndNote."))) (rpaqq endnote.tag.items ((|Edit Text| |Edit Text| "Edit the text associated with this EndNote.") (|Change Tag| |Change Tag| "Change this EndNote's TAG.") (|Delete Tag| |Delete Tag| "Delete this EndNote's TAG.") (|Show Tag| |Show Tag| "Show this EndNote's TAG."))) (declare\: eval@compile (record endnotefonts (number.font title.font text.font)) ) (* * |Allow| |user| |to| |edit| |Endnote| |text| |in| |another| |TEdit| |window.|) (defineq (aux.tedit (lambda (imobj title stream) (* |ss:| "27-Jun-87 15:22") (* * |Open| \a |TEdit| |window| |where| |the| |user| |can| |view/edit| |the|  |text| |of| |the| |selected| |Endnote.|) (let* ((mainwindow (\\tedit.mainw stream)) (auxwindow (createw (windowprop mainwindow 'auxw.region) title))) (windowprop auxwindow 'main.window mainwindow) (windowprop auxwindow 'note.imageobj imobj) (tedit nil auxwindow nil '(afterquitfn aux.tedit.afterquitfn titlemenufn aux.tedit.titlemenufn)) (tedit.insert (textstream auxwindow) (mkstring (|fetch| (numberobj text.after#) |of| (|fetch| objectdatum |of| imobj))) nil (|fetch| (endnotefonts text.font) |of| (get.endnote.fonts mainwindow)))))) (aux.tedit.afterquitfn (lambda (auxwindow) (* |ss:| "27-Jun-87 15:22") (* * |Here| after |user| |finished| |with| |Endnote| |TEdit| |process.|) (let ((mainwindow (windowprop auxwindow 'main.window))) (windowprop mainwindow 'auxw.region (windowprop auxwindow 'region)) (give.tty.process mainwindow) (tedit.normalizecaret (textobj mainwindow))))) (aux.tedit.titlemenufn (lambda (auxwindow) (* |ss:| "27-Jun-87 15:23") (* * |Here| |when| |left| |or| |middle| |button| |hit| |in| |title| |bar.|) (let ((item (menu (|create| menu centerflg _ t items _ '(|Save Changes| |Abort Changes|))))) (and item (progn (selectq item (|Save Changes| (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| (windowprop auxwindow 'note.imageobj)) |with| (coercetextobj (textstream auxwindow) 'stringp))) nil) (tedit.quit (textstream auxwindow))))))) ) (* * |Delimit| |text| |between| |two| |markers| |known| |as| region markers.) (defineq (regmarkobj (lambda (use marking) (* |fsg| "10-Jul-87 15:58") (let ((newobj (imageobjcreate (|create| regmarkobj region.use _ use marking _ marking) \\regmarkobj.imagefns))) (imageobjprop newobj 'type 'regmarkobj) newobj))) (regmarkobjp (lambda (imobj) (* |ss:| "27-Jun-87 15:31") (and imobj (eq (imageobjprop imobj 'type) 'regmarkobj)))) (regmark.displayfn (lambda (obj stream) (* |fsg| "18-Feb-87 09:18") (* * regmark |is| |just| \a |marker,| |it| |doesn't| |actually| |display|  |anything.|) nil)) (regmark.imageboxfn (lambda (obj stream currentx rightmargin) (* |fsg| "17-Feb-87 10:22") (* * regmark |is| |just| \a |marker,| |it| |doesn't| |actually| |display|  |anything.|) (|create| imagebox xsize _ 0 ysize _ 0 ydesc _ 0 xkern _ 0))) (regmark.putfn (lambda (markobj stream) (* |fsg| "23-Jul-87 14:02") (prin2 (list '|Region| (|fetch| region.use |of| (|fetch| objectdatum |of| markobj)) (|fetch| marking |of| (|fetch| objectdatum |of| markobj))) stream))) (regmark.getfn (lambda (stream copy.object) (* |fsg| "20-Aug-87 14:58") (let ((window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window)) (apply (function regmarkobj) (or copy.object (cdr (read stream)))))) (regmark.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 14:09") (* * |Here| |to| copy \a |RegMark| |Image| |Object.|) (selectq (imagestreamtype target.stream) (text (let ((textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (|fetch| objectdatum |of| image.obj)))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (regmark.buttoneventinfn (lambda (markobj stream) (* |fsg| "18-Feb-87 10:07") (* * |This| |function| |is| |never| |called| |because| |the| regmark  |ImageObjects| |are| |protected| |after| |they| |are| |inserted| |and|  |anything| |protected| |can't| |be| |selected.|) (and (mousestate middle) (let ((markdatum (|fetch| objectdatum |of| markobj))) (tedit.promptprint stream (concat "Region used for " (|fetch| region.use |of| markdatum ) (cond ((|fetch| marking |of| markdatum) (concat ", Marker is " (|fetch| marking |of| markdatum))) (t ""))) t))))) ) (declare\: eval@compile (record regmarkobj (region.use marking)) ) (putprops tmax-endnote copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1726 11353 (add.endnote 1736 . 2404) (insert.endnotes 2406 . 4609) ( insert.endnotes.text 4611 . 6040) (delete.endnotes 6042 . 7033) (notesregionp 7035 . 7297) ( set.endnote.style 7299 . 9972) (map.endnote.looks 9974 . 10741) (get.endnote.fonts 10743 . 11351)) ( 11354 15269 (endnotep 11364 . 11705) (note.putfn 11707 . 12359) (note.getfn 12361 . 12941) ( note.buttoneventinfn 12943 . 13723) (note.whenselectedfn 13725 . 15267)) (15991 18395 (aux.tedit 16001 . 16963) (aux.tedit.afterquitfn 16965 . 17408) (aux.tedit.titlemenufn 17410 . 18393)) (18480 21944 ( regmarkobj 18490 . 18897) (regmarkobjp 18899 . 19093) (regmark.displayfn 19095 . 19341) ( regmark.imageboxfn 19343 . 19694) (regmark.putfn 19696 . 20028) (regmark.getfn 20030 . 20329) ( regmark.copyfn 20331 . 20869) (regmark.buttoneventinfn 20871 . 21942))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-INDEX b/lispusers/TMAX-INDEX new file mode 100644 index 00000000..afbee165 --- /dev/null +++ b/lispusers/TMAX-INDEX @@ -0,0 +1,186 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "20-Feb-97 17:58:09" |{DSK}medley2.0>lispusers>TMAX-INDEX.;38| 46100 |changes| |to:| (FNS WRITE.INDEX.FILE INDEX.BUTTONEVENTINFN) |previous| |date:| "19-Feb-97 21:51:43" |{DSK}medley2.0>lispusers>TMAX-INDEX.;36|) ; Copyright (c) 1987, 1997 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-INDEXCOMS) (RPAQQ TMAX-INDEXCOMS ( (* |;;| "Developed under support from NIH grant RR-00785.") (* |;;| "Written by Frank Gilmurray and Sami Shaio. Modified by Ron Kaplan") (* |;;| "INDEX objects are simply inserted into the text stream. Information about them is accumulated only when the displayfn is applied to a hardcopy imagestream, and it is accumulated as a property of the imagestream.") (* |;;;| "TMAX-INDEX ImageObject functions") (INITVARS (INDEXDISPLAYAPPEARANCE 'BOX)) (FNS INDEXOBJ INDEXOBJP INDEX.DISPLAYFN INDEX.IMAGEBOXFN INDEX.PUTFN INDEX.GETFN INDEX.COPYFN INDEX.BUTTONEVENTINFN) (* |;;;| "Inserting indices") (FNS INSERT.INDEX INSERT.INDEXENTRY INSERT.KNOWN.INDEX SUBITEM.SELECTFN ADD.NEW.INDEX) (* |;;;| "Functions to change the Index/Extended Index") (FNS CHANGE.INDEX CHANGE.INDEXENTRY CHANGE.XINDEX.KEY CHANGE.XINDEX.ENTRY CHANGE.XINDEX.FONT CHANGE.XINDEX.NUMBER) (* |;;;| "Other misc functions") (FNS GETHASH.INDEX INDEX.PAGE.NUMBER INDEX.MANUAL.DELIMITER INDEX.STRING GET.INDEXENTRY.NUMBER INDEX.LIST.REFS LIST.OF.INDEXENTRIES) (* |;;;| "Index file functions") (FNS CREATE.INDEX.FILE DUMP.INDEX VIEW.INDEX.FILE GET.INDEX.FILE WRITE.INDEX.FILE WRITE.INDEX.PAGENUMBERS RESET.INDEX.PAGENUMBERS) (RECORDS INDEX.ENTRY.RECORD) (* |;;;| "Convenient interface--depress the props key to index the current selection") (FNS SELECTION.TO.STRING SELECTION.TO.INDEX) (MACROS MAKE.INDEXOBJ.IMAGEFNS) (VARS (\\INDEXOBJ.IMAGEFNS (MAKE.INDEXOBJ.IMAGEFNS))) (ADDVARS (IMAGEOBJGETFNS (INDEX.GETFN))) (P (* \;  "533 is the PROPS key on Sun keyboards") (TEDIT.SETSYNTAX 533 'FN TEDIT.READTABLE) (TEDIT.SETFUNCTION 533 (FUNCTION SELECTION.TO.INDEX) TEDIT.READTABLE)) (* |;;;| "IMAGE OBJECT for causing the index to be written, without using the menu") )) (* |;;| "Developed under support from NIH grant RR-00785.") (* |;;| "Written by Frank Gilmurray and Sami Shaio. Modified by Ron Kaplan") (* |;;| "INDEX objects are simply inserted into the text stream. Information about them is accumulated only when the displayfn is applied to a hardcopy imagestream, and it is accumulated as a property of the imagestream." ) (* |;;;| "TMAX-INDEX ImageObject functions") (RPAQ? INDEXDISPLAYAPPEARANCE 'BOX) (DEFINEQ (indexobj + (lambda (key indexentry.parms) (* |fsg| "10-Jul-87 15:59") + (* * |Create| |an| |instance| |of| |an| |Index| |or| |Extended| |Index| + |imageobject.| |The| |difference| |between| |the| |two| |is| |the| objectdatum. + |For| \a |simple| |Index,| objectdatum |is| nil. + |For| |an| |Extended| |Index,| objectdatum |is| \a |record| |containing| |the| + |Entry,| |Entry's| |font,| |and| |Number| |option.| + i\n |either| |case,| |the| index.key |property| |is| |the| |hash| |key| |and| + |is| |also| |the| |text| |to| |index| |for| \a |simple| |Index.| + |NOTE...Extended| |Index| |used| |to| |be| |called| |IndexEntry| |after| |the| + |Scribe| |cmd| |of| |the| |same| |name.|) + + (let ((newobj (imageobjcreate indexentry.parms \\indexobj.imagefns))) + (imageobjprop newobj 'index.key key) + (imageobjprop newobj 'type 'indexobj) + newobj))) (indexobjp + (lambda (obj) (* |ss:| "27-Jun-87 15:53") + (* * |Tests| |an| |imageobject| |to| |see| |if| |it| |an| |Index| |or| + |Extended| |Index| |imageobject.| b\y |convention,| |testing| |functions| |for| + |an| |imageobject| |are| |named| .) + + (and obj (eq (imageobjprop obj 'type) + 'indexobj)))) (INDEX.DISPLAYFN (LAMBDA (OBJ IMAGESTREAM) (* \; "Edited 14-Feb-97 09:30 by rmk:") (* |fsg| "17-Sep-87 11:14") (* |;;| "Display an Index imageobject. If the stream-type is display, then just type Index or Extended Index followed by their args. Otherwise the stream-type is hardcopy. In this case, type nothing and replace the CAR of the hash array entry with a list of page numbers in which this index appears.") (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (CL:UNLESS (EQ 'INVISIBLE INDEXDISPLAYAPPEARANCE) (DSPFONT |GP.DefaultFont| IMAGESTREAM) (SELECTQ INDEXDISPLAYAPPEARANCE (BOX (TMAX.SHADEOBJ OBJ IMAGESTREAM GRAYSHADE)) (HIGHLIGHT (TMAX.SHADEOBJ OBJ IMAGESTREAM BLACKSHADE)) (PROGN (TMAX.SHADEOBJ OBJ IMAGESTREAM) (PRIN3 (INDEX.STRING OBJ) IMAGESTREAM))))) (LET ((PGS/IMOBJS (GETHASH.INDEX OBJ IMAGESTREAM)) (CURRENT.PAGE (INDEX.PAGE.NUMBER (WITH TEXTOBJ TEXTOBJ (CAR \\WINDOW))))) (COND ((LISTP (CAR PGS/IMOBJS)) (OR (MEMB CURRENT.PAGE (CAR PGS/IMOBJS)) (RPLACA PGS/IMOBJS (APPEND (CAR PGS/IMOBJS) (LIST CURRENT.PAGE))))) (T (RPLACA PGS/IMOBJS (LIST CURRENT.PAGE)))))))) (INDEX.IMAGEBOXFN (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* \; "Edited 14-Feb-97 09:23 by rmk:") (* |ss:| "27-Jun-87 15:50") (* |;;| "Return the ImageBox for an Index or Extended Index.") (SELECTQ (IMAGESTREAMTYPE STREAM) (DISPLAY (SELECTQ INDEXDISPLAYAPPEARANCE (INVISIBLE (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0)) ((BOX HIGHLIGHT) (CREATE IMAGEBOX XSIZE _ (CHARWIDTH (CHARCODE SPACE) STREAM) YSIZE _ (LRSH (FONTPROP STREAM 'HEIGHT) 1) YDESC _ 0 XKERN _ 0)) (CREATE IMAGEBOX XSIZE _ (STRINGWIDTH (INDEX.STRING OBJ) |GP.DefaultFont|) YSIZE _ (FONTPROP |GP.DefaultFont| 'HEIGHT) YDESC _ (FONTPROP |GP.DefaultFont| 'DESCENT) XKERN _ 0))) (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0)))) (index.putfn + (lambda (obj stream) (* |ss:| "27-Jun-87 15:51") + (* * |Puts| |the| |Index| |or| |Extended| |Index| |imageobject| |in| \a |file.|) + + (let ((datum (|fetch| objectdatum |of| obj)) + (index.put.arg (list '|Index| (imageobjprop obj 'index.key)))) + (and datum (nconc1 index.put.arg datum)) + (prin2 index.put.arg stream)))) (INDEX.GETFN (LAMBDA (STREAM COPY.OBJECT) (* \; "Edited 14-Feb-97 10:10 by rmk:") (* |fsg| "20-Aug-87 14:57") (* |;;| "Create the Index or Extended Index imageobject when it is read from file.") (APPLY (FUNCTION INDEXOBJ) (OR COPY.OBJECT (CDR (READ STREAM)))))) (index.copyfn + (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 12:01") + (* * |Here| |to| copy |an| |Index| |or| |Extended| |Index| |Image| |Object.|) + + (selectq (imagestreamtype target.stream) + (text (let ((textobj (textobj target.stream))) + (apply* (imageobjprop image.obj 'getfn) + target.stream + (list (imageobjprop image.obj 'index.key) + (|fetch| objectdatum |of| image.obj))))) + (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (INDEX.BUTTONEVENTINFN (LAMBDA (OBJ STREAM SEL RELX RELY WINDOW HOSTSTREAM BUTTON) (* \; "Edited 20-Feb-97 13:53 by rmk:") (* |fsg| "29-Jul-87 10:50") (* |;;| "Process the middle button pressed inside an Index or Extended Index imageobject. This means the user wants to Change this index.") (AND (MOUSESTATE MIDDLE) (LET* ((DATUM (FETCH OBJECTDATUM OF OBJ)) (NEW.INDEX (MENU (CREATE MENU TITLE _ (IMAGEOBJPROP OBJ 'INDEX.KEY) ITEMS _ (LIST (COND (DATUM '(|Change Extended Index| T "Change Extended Index")) (T '(|Change Index| T "Change Index")))) CENTERFLG _ T)))) (CL:WHEN (AND NEW.INDEX (CAR (SETQ NEW.INDEX (COND (DATUM (CHANGE.INDEXENTRY OBJ STREAM)) (T (CHANGE.INDEX OBJ STREAM)))))) (IMAGEOBJPROP OBJ 'INDEX.KEY (CAR NEW.INDEX)) (AND DATUM (REPLACE OBJECTDATUM OF OBJ WITH (CADR NEW.INDEX))) 'CHANGED))))) ) (* |;;;| "Inserting indices") (DEFINEQ (INSERT.INDEX (LAMBDA (STREAM) (* \; "Edited 14-Feb-97 09:15 by rmk:") (* |fsg| "10-Mar-87 14:02") (* |;;| "Process the 'Index' function in the ImageObjects menu.") (LET ((NEWINDEX.KEY (MKATOM (CONVERT.TABS.TO.SPACES (TEDIT.GETINPUT STREAM "Index Key:"))))) (AND NEWINDEX.KEY (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY))) (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))) (TEDIT.PROMPTPRINT STREAM "" T)))) (INSERT.INDEXENTRY (LAMBDA (STREAM WINDOW) (* \; "Edited 14-Feb-97 09:15 by rmk:") (* |fsg| "19-Mar-87 11:56") (* |;;| "Process the 'Extended Index' function in the ImageObjects menu. NOTE...Extended Index use to be called IndexEntry after the Scribe cmd of the same name.") (LET ((NEWINDEX.KEY (MKATOM (CONVERT.TABS.TO.SPACES (TEDIT.GETINPUT STREAM "Extended Index Key:") )))) (AND NEWINDEX.KEY (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY (CREATE INDEX.ENTRY.RECORD INDEX.ENTRY _ (OR (MKATOM (CONVERT.TABS.TO.SPACES (TEDIT.GETINPUT STREAM "Extended Index Entry:" (MKSTRING NEWINDEX.KEY)))) NEWINDEX.KEY) INDEX.ENTRYFONT _ (LET (NEWINDEX.FONT) (TEDIT.PROMPTPRINT STREAM "Extended Index Entry font..." T) (UNTIL (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW |GP.DefaultFont| )) DO (TEDIT.PROMPTPRINT STREAM "Invalid font specification...try again." T)) NEWINDEX.FONT) INDEX.NUMBER _ (PROGN (TEDIT.PROMPTPRINT STREAM "Extended Index Number option..." T) (GET.INDEXENTRY.NUMBER))))) ) (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))) (TEDIT.PROMPTPRINT STREAM "" T)))) (INSERT.KNOWN.INDEX (LAMBDA (STREAM WINDOW) (* \; "Edited 14-Feb-97 17:24 by rmk:") (* |fsg| "16-Sep-87 11:31") (* |;;| "Process the 'Known Indices' function in the ImageObjects menu. A menu of all the known Indices and Extended Indices pops up and the user may button one of these to insert the corrsponding Index or Extended Index.") (HELP "NEED TO DO TEDIT.MAPPIECES INSTEAD OF INDEX.LIST.REFS") (LET* ((PREVINDICES (INDEX.LIST.REFS STREAM)) (NEWINDEX.KEY (COND (PREVINDICES (LET ((MENU.SELECTION (MENU (|create| MENU TITLE _ "Index Keys" ITEMS _ PREVINDICES MENUCOLUMNS _ (FIX (SQRT (LENGTH PREVINDICES ))) CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION SUBITEM.SELECTFN))))) (AND MENU.SELECTION (OR (LISTP MENU.SELECTION) (LIST MENU.SELECTION))))) (T (TEDIT.PROMPTPRINT STREAM "There are no Indices/Extended Indices in this document." T) NIL)))) (AND NEWINDEX.KEY (LET ((NEWINDEX.OBJ (APPLY 'INDEXOBJ NEWINDEX.KEY))) (TEDIT.INSERT.OBJECT NEWINDEX.OBJ STREAM) (TEDIT.PROMPTPRINT STREAM "" T)))))) (subitem.selectfn + (lambda (item menu key) (* |fsg| "16-Sep-87 13:28") + (* * |Function| |to| |handle| |multiple| |column| |menu| |when| |some| |items| + |have| |subitems.|) + + (prog (submenu subitems (submenus (getmenuprop menu 'submenus))) + (|if| (and (listp item) + (setq subitems (cdr (assoc 'subitems (cdddr item))))) + |then| (|if| (setq submenu (cdr (sassoc subitems submenus))) + |else| (setq submenu (|create| menu + items _ subitems + centerflg _ t)) + (putmenuprop menu 'submenus (cons (cons subitems submenu) + submenus))) + (return (menu submenu)) + |else| (return (defaultwhenselectedfn item menu key)))))) (ADD.NEW.INDEX (LAMBDA (IMAGESTREAM INDEXKEY OBJ) (* \; "Edited 14-Feb-97 09:08 by rmk:") (* |ss:| "27-Jun-87 15:44") (* |;;| "Add an Index or Extended Index imageobject to our index array. If at least one already exists for this index key, then just append this imageobject to the list. Otherwise create a new array entry for this imageobject. The list contains three elements; a string, a list of Index imageobjects, and a list of Extended Index imageobjects.") (LET ((CODE.ARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)) HASH.VALUE INDEX.OBJS ENTRY.OBJS) (CL:UNLESS (HASHARRAYP CODE.ARRAY) (SETQ CODE.ARRAY (HASHARRAY 100)) (STREAMPROP IMAGESTREAM 'TSP.CODE.ARRAY CODE.ARRAY) (CL:UNLESS (HASHARRAYP (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)) (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY (HASHARRAY 100)))) (SETQ HASH.VALUE (GETHASH INDEXKEY CODE.ARRAY)) (SETQ INDEX.OBJS (CADR HASH.VALUE)) (SETQ ENTRY.OBJS (CADDR HASH.VALUE)) (COND ((FETCH OBJECTDATUM OF OBJ) (SETQ ENTRY.OBJS (APPEND ENTRY.OBJS (LIST OBJ)))) (T (SETQ INDEX.OBJS (APPEND INDEX.OBJS (LIST OBJ))))) (PUTHASH INDEXKEY (LIST NIL INDEX.OBJS ENTRY.OBJS) CODE.ARRAY)))) ) (* |;;;| "Functions to change the Index/Extended Index") (DEFINEQ (change.index + (lambda (obj stream) (* |ss:| "27-Jun-87 15:44") + (* * |Here| |when| change |buttoned| |inside| |an| |Index| |ImageObject.|) + + (list (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat "Change Index key \"" + (imageobjprop obj + 'index.key) + "\" to:"))))))) (change.indexentry + (lambda (obj stream) (* |fsg| "10-Mar-87 11:52") + (* * |Here| |when| change |buttoned| |inside| |an| |Extended| |Index| + |ImageObject.| |NOTE...Extended| |Index| |used| |to| |be| |called| |IndexEntry| + |after| |the| |Scribe| |cmd| |of| |the| |same| |name.|) + + (prog1 (list (change.xindex.key obj stream) + (|create| index.entry.record + index.entry _ (change.xindex.entry obj stream) + index.entryfont _ (change.xindex.font obj stream) + index.number _ (change.xindex.number obj stream))) + (tedit.promptprint stream "" t)))) (change.xindex.key + (lambda (obj stream) (* |ss:| "27-Jun-87 15:45") + (* * |Change| |the| |key| |of| |an| |Extended| |Index.|) + + (let ((oldindex.key (imageobjprop obj 'index.key))) + (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat + "Change Extended Index Key \"" + oldindex.key "\" to:")))) + oldindex.key)))) (change.xindex.entry + (lambda (obj stream) (* |fsg| "10-Mar-87 11:31") + (* * |Change| |the| |entry| |of| |an| |Extended| |Index.|) + + (let ((oldindex.entry (|fetch| index.entry |of| (|fetch| objectdatum |of| obj)))) + (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat + "Change Extended Index Entry \"" + oldindex.entry "\" to:"))) + ) + oldindex.entry)))) (change.xindex.font + (lambda (obj stream) (* |fsg| " 8-Jul-87 16:42") + (* * |Change| |the| |font| |of| |an| |Extended| |Index.|) + + (let ((oldindex.font (|fetch| index.entryfont |of| (|fetch| objectdatum |of| obj))) + newindex.font) + (tedit.promptprint stream (concat "Change Extended Index Entry's font " (abbreviate.font + oldindex.font) + " to...") + t) + (|until| (setq newindex.font (get.tsp.font (\\tedit.mainw stream) + (or oldindex.font |GP.DefaultFont|))) + |do| (tedit.promptprint stream "Invalid font specification...try again." t)) + newindex.font))) (change.xindex.number + (lambda (obj stream) (* |fsg| "19-Mar-87 11:51") + (* * |Change| |the| |number| |option| |of| |an| |Extended| |Index.|) + + (let ((oldindex.nbr (|fetch| index.number |of| (|fetch| objectdatum |of| obj)))) + (tedit.promptprint stream (concat "Change Extended Index Number option \"" oldindex.nbr + "\" to...") + t) + (get.indexentry.number oldindex.nbr)))) ) (* |;;;| "Other misc functions") (DEFINEQ (GETHASH.INDEX (LAMBDA (OBJ IMAGESTREAM) (* \; "Edited 14-Feb-97 09:28 by rmk:") (* |fsg| "13-Jul-87 11:09") (* |;;| "Get the hash array entry for this Index or Extended Index.") (LET ((HARRAY (HASHARRAYP (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)))) (CL:UNLESS HARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY (SETQ HARRAY (HASHARRAY 100)))) (OR (GETHASH (IMAGEOBJPROP OBJ 'INDEX.KEY) HARRAY) (ADD.NEW.INDEX IMAGESTREAM (IMAGEOBJPROP OBJ 'INDEX.KEY) OBJ))))) (INDEX.PAGE.NUMBER (LAMBDA (WINDOW) (* \; "Edited 14-Feb-97 09:58 by rmk:") (* |fsg| "16-Jul-87 10:08") (* |;;| "Return the index page number; either the page number or manual-style page number.") (MKATOM (COND ((MANUALINDEX.ENABLED? WINDOW) (LET ((INDEX.PAGE "") (TEMPLATE.LIST (APPEND (WINDOWPROP WINDOW 'MANUALTEMPLATES))) INDEX.TEMPLATE) (WHILE (SETQ INDEX.TEMPLATE (POP TEMPLATE.LIST)) DO (WITH NGTEMPLATE INDEX.TEMPLATE (SETQ INDEX.PAGE (CONCAT INDEX.PAGE (OR NG.TEXT-BEFORE "") (NGROUP.CHARTYPE.CONVERT NG.CHARTYPE NG.CURRENTVAL ) (INDEX.MANUAL.DELIMITER NG.TEXT-AFTER (CAR TEMPLATE.LIST)))))) (CONCAT INDEX.PAGE (CAR FORMATTINGSTATE)))) (T (CAR FORMATTINGSTATE)))))) (index.manual.delimiter + (lambda (after.delimiter next.template) (* |fsg| "16-Jul-87 10:00") + (* * |Return| |the| |delimiter| |between| |NGroups| |and| |the| |page| |number| + |for| \a |Manual| |Index| |page| |reference.|) + + (or (cond + (next.template (cond + ((|fetch| (ngtemplate ng.text-before) |of| next.template) + "") + (t nil))) + (t (cond + ((or (null after.delimiter) + (strequal after.delimiter "")) + ".") + (t nil)))) + after.delimiter))) (index.string + (lambda (index.obj) (* |ss:| "27-Jun-87 15:52") + (* * |Returns| |the| |display| |imagestream| |text| |for| |an| |Index| |or| + |Extended| |Index| |ImageObject.|) + + (let ((objdatum (|fetch| objectdatum |of| index.obj)) + (indexkey (mkatom (imageobjprop index.obj 'index.key)))) + (cond + (objdatum (|with| index.entry.record objdatum (concat "{Index Key=" indexkey ",Entry=" + index.entry + (selectq index.number + (yes ",Yes}") + (no ",No}") + (concat "," index.number "}")))) + ) + (t (concat "{Index " indexkey "}")))))) (get.indexentry.number + (lambda (defaultnumber) (* |ss:| "27-Jun-87 15:47") + (* * |Get| |the| number |argument| |for| |an| |IndexEntry| |ImageObject.| + |The| number |can| |be| "YES" \, "NO" \, |or| |an| |integer.|) + + (or (menu (|create| menu + title _ "Number?" + centerflg _ t + items _ '(yes no value) + whenselectedfn _ (function (lambda (item) + (cond + ((eq item 'value) + (numberpad.read (create.numberpad.reader + "NUMBER value?" nil nil + nil t))) + (t item)))))) + defaultnumber + 'yes))) (INDEX.LIST.REFS (LAMBDA (IMAGESTREAM) (* \; "Edited 14-Feb-97 09:09 by rmk:") (* |ss:| "27-Jun-87 15:51") (* |;;| "Return a sorted list of the Index and Extended Index keys. Simple Index keys are just added to the list. For an Extended Index key, there are SUBITEMS for each Extended Index for this key. This list can be used as the ITEMS field in the Known Indices menu or for creating the index file.") (LET ((INDEX.ARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)) (INDEX.KEYLIST NIL) (INDEX.ITEMS (CONS)) INDEX.VALUE) (MAPHASH INDEX.ARRAY (FUNCTION (LAMBDA (VAL KY) (SETQ INDEX.KEYLIST (CONS KY INDEX.KEYLIST))))) (FOR KEY IN (SORT INDEX.KEYLIST 'UALPHORDER) DO (SETQ INDEX.VALUE (GETHASH KEY INDEX.ARRAY)) (AND (CADR INDEX.VALUE) (NCONC INDEX.ITEMS (LIST KEY))) (AND (CADDR INDEX.VALUE) (NCONC INDEX.ITEMS (LIST (LIST KEY NIL "Select an Extended Index subitem." (CONS 'SUBITEMS (LIST.OF.INDEXENTRIES KEY (CADDR INDEX.VALUE)))))))) (CDR INDEX.ITEMS)))) (list.of.indexentries + (lambda (key objlist) (* |fsg| " 8-Jul-87 16:46") + (* * |Returns| \a |list| |of| |the| |Extended| |Indices| |of| |the| |given| + |key| |sorted| |by| |Entry.|) + + (let ((entry.list (cons)) + datum) + (|for| obj |in| objlist + |do| (setq datum (|fetch| objectdatum |of| obj)) + (nconc entry.list (list (list (concat (|fetch| index.entry |of| datum) + " " + (abbreviate.font (|fetch| index.entryfont + |of| datum)) + " " + (|fetch| index.number |of| datum)) + (kwote (list key datum)))))) + (sort (intersection (cdr entry.list) + (cdr entry.list)) + (function (lambda (a b) + (ualphorder (caadr (cadadr a)) + (caadr (cadadr b))))))))) ) (* |;;;| "Index file functions") (DEFINEQ (CREATE.INDEX.FILE (LAMBDA (TEXTSTREAM IMAGESTREAM INDEXFILE INDEX.FONT NOTITLE) (* \; "Edited 14-Feb-97 11:10 by rmk:") (* |fsg| "13-Aug-87 09:05") (* |;;| "Writes the indices and their corresponding page numbers to the index file. The indices are sorted alphabetically regardless of case.") (LET ((INDEX.ARRAY (IF IMAGESTREAM THEN (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY) ELSE (* |;;| "Menu call should do a hardcopy to a nodircore image stream, which can then be passed in for us to interrogate.") (* |;;| "(STREAMPROP WINDOW 'TSP.INDEX.ARRAY)") (HELP "Trying to write index when not hard-copying"))) (INDEX.LIST (INDEX.LIST.REFS IMAGESTREAM)) (INDEX.FILE (OUTFILEP INDEXFILE)) (INDEX.STREAM (OPENTEXTSTREAM))) (COND ((AND INDEX.LIST INDEX.FILE) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "Putting Indices into file " INDEX.FILE "... ") T) (CL:UNLESS NOTITLE (DSPFONT (FONTCREATE '(HELVETICA 14 BRR)) INDEX.STREAM) (PRINTOUT INDEX.STREAM "Index" T T)) (WRITE.INDEX.FILE INDEX.STREAM INDEX.LIST INDEX.ARRAY INDEX.FONT) (CLOSEF? (TEDIT.PUT INDEX.STREAM INDEX.FILE)) INDEX.FILE) (INDEX.LIST (TEDIT.PROMPTPRINT TEXTSTREAM "Specify a file name for the Indices first." T) NIL) (T (TEDIT.PROMPTPRINT TEXTSTREAM "There are no Indices/Extended Indices in this document." T) NIL))))) (DUMP.INDEX (LAMBDA (INDEXFILE) (* \; "Edited 14-Feb-97 11:12 by rmk:") (* |;;| "Dumps the current index to INDEXFILE without a title and in the font of the current image stream. Convenient to call in an EVALOBJect context. By default, indexfile will be placed on the same directory as the text file underlying the textstream") (DECLARE (USEDFREE TEXTSTREAM WINDOW IMAGESTREAM)) (LET ((TEXTFILE (FETCH (TEXTOBJ TXTFILE) OF (TEXTOBJ TEXTSTREAM)))) (IF TEXTFILE THEN (SETQ TEXTFILE (FULLNAME TEXTFILE))) (CREATE.INDEX.FILE TEXTSTREAM IMAGESTREAM (IF INDEXFILE THEN (PACKFILENAME 'VERSION NIL 'BODY INDEXFILE 'HOST (FILENAMEFIELD TEXTFILE 'HOST) 'DIRECTORY (FILENAMEFIELD TEXTFILE 'DIRECTORY)) ELSEIF TEXTFILE THEN (PACKFILENAME 'VERSION NIL 'EXTENSION 'INDEX 'BODY TEXTFILE) ELSEIF (GET.INDEX.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW)) ELSE (HELP "No file for index")) (DSPFONT NIL IMAGESTREAM) T)))) (VIEW.INDEX.FILE (LAMBDA (STREAM WINDOW DONTSHOW) (* \; "Edited 14-Feb-97 17:15 by rmk:") (* |fsg| "12-Aug-87 16:34") (* |;;| "Writes out the index file via CREATE.INDEX.FILE and then opens another TEdit window where this new file is displayed.") (* |;;| "First, do a dummy hardcopy to get the page numbers. Use the type of the current defaultprintinghost as the imagestream type") (LET* ((IMAGESTREAM (OPENIMAGESTREAM '{NULL})) (INDEX.FILE (CREATE.INDEX.FILE STREAM (PROGN (TEDIT.FORMAT.HARDCOPY STREAM IMAGESTREAM ) IMAGESTREAM) (GET.INDEX.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW))))) (AND INDEX.FILE (NOT DONTSHOW) (PROGN (OR (WINDOWPROP WINDOW 'INDEX.WINDOW) (WINDOWPROP WINDOW 'INDEX.WINDOW (CREATEW NIL (CONCAT "Viewing Index file " INDEX.FILE)))) (TEDIT INDEX.FILE (WINDOWPROP WINDOW 'INDEX.WINDOW))))))) (get.index.file + (lambda (menuw) (* \; "Edited 29-Sep-87 14:34 by fsg") + + (* * |Return| |the| |user| |specified| |index| |file| |name.|) + + (let ((filename (fm.itemprop (fm.getitem 'index.file nil menuw) + 'label))) + (and (not (strequal filename "")) + (mkatom filename))))) (WRITE.INDEX.FILE (LAMBDA (INDEX.STREAM INDEX.LIST INDEX.ARRAY INDEX.FONT PAGE.FONT) (* \; "Edited 20-Feb-97 17:58 by rmk:") (* |fsg| "13-Aug-87 10:43") (* |;;| "For each Index, the Key is printed followed by the list of page numbers in which this Index Key appears. Each Extended Index is printed on a separate line and the page number depends on the Extended Index Number option.") (CL:UNLESS INDEX.FONT (SETQ INDEX.FONT |GP.DefaultFont|)) (CL:UNLESS PAGE.FONT (SETQ PAGE.FONT INDEX.FONT)) (* |;;| "For some reason, the first line doesn't format properly after an Include object. Kludge to fix it here: put out a blank line. Perhaps a better thing would be to somehow fix the include object, or perhaps to have the DUMP.INDEX take a flag to control this.") (PRINTOUT INDEX.STREAM " " T) (FOR INDEX.ITEM IN INDEX.LIST DO (COND ((LISTP INDEX.ITEM) (* |;;| "Extended Index") (FOR INDEX.SUBITEM (PGS.AND.IMOBJS _ (GETHASH (CAR INDEX.ITEM) INDEX.ARRAY)) IN (CDR (CADDDR INDEX.ITEM)) DO (FOR INDEX.ENTRYARGS FONT IN (CDR (CADADR INDEX.SUBITEM)) DO (DSPFONT (SETQ FONT (FONTCREATE (CADR INDEX.ENTRYARGS))) INDEX.STREAM) (PRINTOUT INDEX.STREAM (MKSTRING (CAR INDEX.ENTRYARGS))) (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS (CADDR INDEX.ENTRYARGS) PAGE.FONT) (DSPFONT FONT INDEX.STREAM) (PRINTOUT INDEX.STREAM T)))) (T (* |;;| "Simple Index") (DSPFONT INDEX.FONT INDEX.STREAM) (PRINTOUT INDEX.STREAM (MKSTRING INDEX.ITEM)) (WRITE.INDEX.PAGENUMBERS INDEX.STREAM (GETHASH INDEX.ITEM INDEX.ARRAY) NIL PAGE.FONT) (PRINTOUT INDEX.STREAM T)))))) (WRITE.INDEX.PAGENUMBERS (LAMBDA (STREAM PAGES/IMOBJS NUMBER.OPTION PAGEFONT) (* \; "Edited 2-Feb-97 17:04 by rmk:") (* |fsg| "11-Mar-87 11:04") (* |;;| "Here to write the actual pages nubers that this Index or Extended Index appears in. NUMBER.OPTION is the Number field of an Extended Index.") (DSPFONT PAGEFONT STREAM) (LET ((PAGE.NBRS (COND (NUMBER.OPTION (SELECTQ NUMBER.OPTION (NO "") (YES (CAR PAGES/IMOBJS)) (MKSTRING NUMBER.OPTION))) (T (CAR PAGES/IMOBJS)))) (PAGE.STRING " ")) (COND ((LISTP PAGE.NBRS) (SETQ PAGE.STRING (CONCAT PAGE.STRING (CAR PAGE.NBRS))) (|for| PAGE |in| (CDR PAGE.NBRS) |do| (SETQ PAGE.STRING (CONCAT PAGE.STRING ", " PAGE)) |finally| (PRINTOUT STREAM PAGE.STRING))) (T (PRINTOUT STREAM (CONCAT PAGE.STRING PAGE.NBRS))))))) (RESET.INDEX.PAGENUMBERS (LAMBDA (IMAGESTREAM) (* \; "Edited 14-Feb-97 09:11 by rmk:") (* |fsg| "13-Aug-87 10:43") (* |;;| "Here before hardcopying the TMAX/TEdit window. Reset the page number list to NIL so the hardcopy DISPLAYFN will create a new list of index page numbers.") (LET ((INDEX.ARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY))) (AND INDEX.ARRAY (MAPHASH INDEX.ARRAY (FUNCTION (LAMBDA (VAL KEY) (RPLACA VAL NIL)))))))) ) (DECLARE\: EVAL@COMPILE (RECORD INDEX.ENTRY.RECORD (INDEX.ENTRY INDEX.ENTRYFONT INDEX.NUMBER)) ) (* |;;;| "Convenient interface--depress the props key to index the current selection") (DEFINEQ (SELECTION.TO.STRING (LAMBDA (TEXTSTREAM) (* \; "Edited 27-Jan-97 12:53 by rmk:") (LET (PREFIX ENDPOS NEXTESCAPE (SEL (TEDIT.GETSEL TEXTSTREAM)) (POINT (TEDIT.GETPOINT TEXTSTREAM)) STARTPOS ENDPOS) (SETQ STARTPOS (SUB1 (FETCH CH# OF SEL))) (SETQ ENDPOS (SUB1 (FETCH CHLIM OF SEL))) (IF (EQ 'CHAR (FETCH SELKIND OF SEL)) THEN (* |;;| "Stretch out to at least a word selection.") (* |;;|  "Look backwards, then forwards. 22 seems to be white-space, 21 is alphabetic, 20 is punctuation") (FOR OLD STARTPOS C BC FROM (SUB1 STARTPOS) BY -1 TO 0 WHILE (PROGN (SETFILEPTR TEXTSTREAM STARTPOS) (AND (SMALLP (SETQ C (BIN TEXTSTREAM))) (SELECTQ (TEDIT.WORDGET C) (22 NIL) (20 (* \; "Include hyphens as alphabetics") (EQ C (CHARCODE -))) T))) FINALLY (ADD STARTPOS 1) (* \; "Fileptr of first character") (SETFILEPTR TEXTSTREAM ENDPOS) (WHILE (PROGN (AND (NOT (EOFP TEXTSTREAM)) (SMALLP (SETQ C (BIN TEXTSTREAM))) (SELECTQ (TEDIT.WORDGET C) (22 NIL) (20 (* \; "Include hyphens as alphabetics") (EQ C (CHARCODE -))) T)))) (SETQ ENDPOS (GETFILEPTR TEXTSTREAM)) (CL:UNLESS (EOFP TEXTSTREAM) (* \;  "Have to back up over the ending space") (SETQ ENDPOS (SUB1 ENDPOS))))) (* |;;|  "Always move the point to the right, so that the insert happens after the selection") (SETQ STARTPOS (ADD1 STARTPOS)) (TEDIT.SETSEL TEXTSTREAM STARTPOS (- (ADD1 ENDPOS) STARTPOS) 'RIGHT NIL T 'NORMAL) (IF (CAR (NLSETQ (TEDIT.SEL.AS.STRING TEXTSTREAM))) ELSE (TEDIT.PROMPTPRINT TEXTSTREAM "Invalid index term--contains image object?" T) (ERROR!))))) (SELECTION.TO.INDEX (LAMBDA (STREAM) (* \; "Edited 14-Feb-97 09:56 by rmk:") (* |fsg| "10-Mar-87 14:02") (* |;;| "The index key has been depressed. Index on the current selection") (LET ((NEWINDEX.KEY (MKATOM (CL:STRING-TRIM '(#\Space) (CONVERT.TABS.TO.SPACES (SELECTION.TO.STRING STREAM))))) (TEXTOBJ (TEXTOBJ STREAM))) (IF (AND NEWINDEX.KEY (NEQ 0 (NCHARS NEWINDEX.KEY))) THEN (LET ((OBJ (INDEXOBJ NEWINDEX.KEY))) (REPLACE BLUEPENDINGDELETE OF TEXTOBJ WITH NIL) (TEDIT.INSERT.OBJECT OBJ STREAM (TEDIT.GETPOINT STREAM)) (TEDIT.SETSEL STREAM (ADD1 (TEDIT.GETPOINT STREAM)) 0 'RIGHT NIL T 'NORMAL) (TEDIT.PROMPTPRINT STREAM (CONCAT "Index term: " NEWINDEX.KEY) T)) ELSE (TEDIT.PROMPTPRINT STREAM "No index term selected" T) (ERROR!))))) ) (DECLARE\: EVAL@COMPILE (PUTPROPS MAKE.INDEXOBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION INDEX.DISPLAYFN) (FUNCTION INDEX.IMAGEBOXFN) (FUNCTION INDEX.PUTFN) (FUNCTION INDEX.GETFN) (FUNCTION INDEX.COPYFN) (FUNCTION INDEX.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) ) (RPAQ \\INDEXOBJ.IMAGEFNS (MAKE.INDEXOBJ.IMAGEFNS)) (ADDTOVAR IMAGEOBJGETFNS (INDEX.GETFN)) (* \;  "533 is the PROPS key on Sun keyboards") (TEDIT.SETSYNTAX 533 'FN TEDIT.READTABLE) (TEDIT.SETFUNCTION 533 (FUNCTION SELECTION.TO.INDEX) TEDIT.READTABLE) (* |;;;| "IMAGE OBJECT for causing the index to be written, without using the menu") (PUTPROPS TMAX-INDEX COPYRIGHT ("Xerox Corporation" 1987 1997)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3149 10825 (INDEXOBJ 3159 . 4182) (INDEXOBJP 4184 . 4632) (INDEX.DISPLAYFN 4634 . 6204) (INDEX.IMAGEBOXFN 6206 . 7752) (INDEX.PUTFN 7754 . 8184) (INDEX.GETFN 8186 . 8577) (INDEX.COPYFN 8579 . 9214) (INDEX.BUTTONEVENTINFN 9216 . 10823)) (10864 18737 (INSERT.INDEX 10874 . 11461) ( INSERT.INDEXENTRY 11463 . 14230) (INSERT.KNOWN.INDEX 14232 . 16309) (SUBITEM.SELECTFN 16311 . 17305) ( ADD.NEW.INDEX 17307 . 18735)) (18803 22734 (CHANGE.INDEX 18813 . 19381) (CHANGE.INDEXENTRY 19383 . 20133) (CHANGE.XINDEX.KEY 20135 . 20693) (CHANGE.XINDEX.ENTRY 20695 . 21328) (CHANGE.XINDEX.FONT 21330 . 22199) (CHANGE.XINDEX.NUMBER 22201 . 22732)) (22776 30497 (GETHASH.INDEX 22786 . 23453) ( INDEX.PAGE.NUMBER 23455 . 25034) (INDEX.MANUAL.DELIMITER 25036 . 25727) (INDEX.STRING 25729 . 26739) ( GET.INDEXENTRY.NUMBER 26741 . 27761) (INDEX.LIST.REFS 27763 . 29253) (LIST.OF.INDEXENTRIES 29255 . 30495)) (30539 40743 (CREATE.INDEX.FILE 30549 . 32428) (DUMP.INDEX 32430 . 34850) (VIEW.INDEX.FILE 34852 . 36116) (GET.INDEX.FILE 36118 . 36508) (WRITE.INDEX.FILE 36510 . 38911) ( WRITE.INDEX.PAGENUMBERS 38913 . 40113) (RESET.INDEX.PAGENUMBERS 40115 . 40741)) (40941 44995 ( SELECTION.TO.STRING 40951 . 43783) (SELECTION.TO.INDEX 43785 . 44993))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-INTRO.TXT b/lispusers/TMAX-INTRO.TXT new file mode 100644 index 00000000..f4012b1b --- /dev/null +++ b/lispusers/TMAX-INTRO.TXT @@ -0,0 +1,27 @@ + TMAX Introduction + + +TMAX (Tedit Macros And eXtensions) is a package that extends the +capabilities of TEdit by providing a menu of commands that allow the +user to do such things as indexing, writing a sorted index file, +arbitrary numbering, creating a list of notes, referencing numbered +objects by their numeric value, and writing a table-of-contents file. +There is also an extensive help file describing all the features of +TMAX. Rather than include examples of how to use these features, the +help file was written using these features and is both an example and +a description of using TMAX. + +Before you can read the help file, you must first load the TMAX.DCOM +file from the {CSLI} directory. Then copy +{CSLI}TMAX.TEDIT to your local disk. Open up a TEdit window +and do a TEdit Get on {DSK}TMAX.TEDIT. The reason for copying the file +to the local disk is that, due to problems with the leaf server on +csli, TMAX runs a lot smoother when the source files are on non-leaf +hosts. + +When you load the TMAX.TEDIT file, you will see the TMAX menu appended +to the top of your TEdit window. You invoke TMAX commands by buttoning +items in this menu. If you would like a hardcopy of the help file, +first button Update and then Insert Endnotes (both in the TMAX menu). +Then point the mouse at the black title bar at the top of the TEdit +window and select Hardcopy from the right button menu. diff --git a/lispusers/TMAX-NGRAPH b/lispusers/TMAX-NGRAPH new file mode 100644 index 00000000..d1df4519 --- /dev/null +++ b/lispusers/TMAX-NGRAPH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:35:45" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NGRAPH.;2| 25361 |previous| |date:| "11-Nov-87 11:56:01" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NGRAPH.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-ngraphcoms) (rpaqq tmax-ngraphcoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Number| |Group| graph |functions|) (fns graphmenu initial.ngroup.graph ngroup.make.rootnode tspgraphregion close.ngroup.graph ngroup.graph.closefn add.ngroup.to.mother.node add.node.to.graph collect.hasharray create.ngroup.node get.fromnodes get.tonodes find.node tsp.get.ngroup.array tsp.legalid list.ancestors toplevel.sisters get.ngroup.mother) (* * |Number| |counting| |functions|) (fns downdate.numberobjs update.numberobjs reset.dependent.classes reset.ncounter get.ncounter ncounter? flatten.tree.to.string ngroup.chartype ngroup.chartype.convert number.to.letter remove.all.counters))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Number| |Group| graph |functions|) (defineq (graphmenu (lambda (tstream twindow) (* |fsg| "11-Jul-87 12:17") (let* ((graph (or (and (not (windowprop twindow 'rebuild.graphflg)) (windowprop twindow 'ngroup.graph)) (initial.ngroup.graph twindow))) (region (tspgraphregion graph twindow t)) (graphw (createw region "Number Group Graph" nil t))) (and (ngroupmenu.enabled? twindow) (close.ngroup.graph twindow)) (windowprop graphw 'repaintfn nil) (attachwindow graphw twindow 'top 'justify 'localclose) (showgraph graph graphw (function insert.ngroup) (function change.ngroup)) (windowprop twindow 'rebuild.graphflg nil) (windowprop twindow 'ngroupw graphw) (windowprop twindow 'ngroup.graph graph) (windowprop graphw 'closefn (function ngroup.graph.closefn)) (windowprop graphw 'twindow twindow) (windowprop graphw 'tstream tstream)))) (initial.ngroup.graph (lambda (window) (* |ss:| "27-Jun-87 16:56") (let* ((rootnode (ngroup.make.rootnode)) (nodelst (|for| node |in| (collect.hasharray (tsp.get.ngroup.array window)) |collect| (cadr node)))) (or (find.node 'new.ngroup window) (progn (setq nodelst (cons rootnode nodelst)) (add.ngroup.to.dbase 'new.ngroup nil nil nil rootnode window))) (layoutgraph nodelst '(new.ngroup))))) (ngroup.make.rootnode (lambda nil (* |ss:| "27-Jun-87 16:14") (nodecreate 'new.ngroup '|NGroups| nil nil nil (fontcreate 'helvetica 10 'brr) 1))) (tspgraphregion (lambda (graph main.window titleflg border) (* |ss:| " 2-Apr-86 16:28") (let ((r (graphregion graph)) (main.r (windowregion main.window))) (|replace| (region width) |of| r |with| (widthifwindow (|fetch| (region width) |of| r))) (|replace| (region height) |of| r |with| (heightifwindow (|fetch| (region height) |of| r) titleflg border)) r))) (close.ngroup.graph (lambda (twindow) (* |fsg| "11-Jul-87 12:51") (* * |Program| |invoked| |close| |of| |the| |NGroup| |menu| |graph| |window.|  program.close |is| |used| |to| |distinguish| |between| |our| |closing| |the|  |window| |and| |the| |user| |buttoning| |the| |Window| |Menu| close |command.|) (let ((graph.window (windowprop twindow 'ngroupw))) (windowprop graph.window 'program.close t) (freeattachedwindow graph.window) (closew graph.window)))) (ngroup.graph.closefn (lambda (graph.window) (* \; "Edited 29-Sep-87 15:04 by fsg") (* * |Clean| |up| \a |few| |things| |when| |user| close\s |the| |NGroup| |menu|  |graph| |window.|) (or (windowprop graph.window 'program.close) (let ((twindow (windowprop graph.window 'twindow))) (fm.changestate (fm.getitem 'ngroup.menu nil (windowprop twindow 'imageobj.menuw)) nil (windowprop twindow 'imageobj.menuw)) (freeattachedwindow graph.window))))) (add.ngroup.to.mother.node (lambda (id motherid w) (* |ss:| " 3-Apr-86 17:50") (let* ((mother.node (find.node motherid w)) (tonodes (|fetch| (graphnode tonodes) |of| mother.node))) (or (member id tonodes) (|replace| (graphnode tonodes) |of| mother.node |with| (cons id tonodes)))))) (add.node.to.graph (lambda (node graph window) (* |ss:| "27-Jun-87 15:57") (let* ((parent.node (find.node (car (|fetch| (graphnode fromnodes) |of| node)) window)) (tonodes (|fetch| (graphnode tonodes) |of| node))) (or (member (|fetch| (graphnode nodeid) |of| node) tonodes) (progn (|replace| (graphnode tonodes) |of| parent.node |with| (cons (|fetch| (graphnode nodeid) |of| node) (|fetch| (graphnode tonodes) |of| parent.node))) (|replace| (graph graphnodes) |of| graph |with| (cons node (|fetch| (graph graphnodes) |of| graph))))) (layoutgraph (|fetch| (graph graphnodes) |of| graph) '(new.ngroup))))) (collect.hasharray (lambda (harray) (* |ss:| "27-Jun-87 16:03") (let ((result nil)) (maphash harray (function (lambda (val ky) (setq result (cons val result))))) result))) (create.ngroup.node (lambda (id mother userdata w) (* |fsg| "22-Jun-87 13:27") (let* ((ngroup.harray (tsp.get.ngroup.array w)) (node (gethash id ngroup.harray))) (or node (let ((new.node (selectq id (new.ngroup (ngroup.make.rootnode)) (nodecreate id id nil nil (list mother))))) (puthash id (list userdata new.node) (list ngroup.harray)) new.node)) (or (and node (car node)) (and userdata node (rplaca node userdata)))))) (get.fromnodes (lambda (ngid window) (* |ss:| " 3-Apr-86 16:00") (car (|fetch| (graphnode fromnodes) |of| (find.node ngid window))))) (get.tonodes (lambda (ngid window) (* |fsg| "28-Jul-87 10:54") (* * i\f ngid |has| |only| |one| |child| |then| |return| |that| |child's|  |name| |as| |an| |atom.| |Else| |return| |the| |list| |of| |NGID's| |children.|) (* * a\s |of| |the| |date| |above,| |this| |function| |is| not |called.|) (let ((tonodes (|fetch| (graphnode tonodes) |of| (find.node ngid window)))) (cond ((cdr tonodes) (reverse tonodes)) (t (car tonodes)))))) (find.node (lambda (ngid window) (* |fsg| " 4-Mar-87 10:22") (cadr (gethash ngid (tsp.get.ngroup.array window))))) (tsp.get.ngroup.array (lambda (window) (* |ss:| "27-Jun-87 16:21") (windowprop window 'tsp.ngroup.array))) (tsp.legalid (lambda (prev.ngroups stream) (* |fsg| " 3-Aug-87 17:04") (* * |Get| \a |new| |NGroup| id |and| |make| |sure| |it's| |not| |already|  |defined.|) (let ((ngroup.id (mkatom (tedit.getinput stream "Group name:")))) (|while| (member ngroup.id prev.ngroups) |do| (setq ngroup.id (mkatom (tedit.getinput stream (concat ngroup.id (cond ((eq ngroup.id 'new.ngroup) " is a reserved name...Group name:" ) (t " already exists...Group name:" ))))))) ngroup.id))) (list.ancestors (lambda (nid ancestors window) (* |ss:| "27-Jun-87 16:09") (* * |Return| \a |list| |of| |the| |parents| |of| |the| |given| |node.|) (let ((mother (get.fromnodes nid window))) (cond ((and mother (neq mother 'new.ngroup)) (list.ancestors mother (cons mother ancestors) window)) (t ancestors))))) (toplevel.sisters (lambda (window) (* |ss:| "27-Jun-87 16:21") (* * |Returns| \a |list| |of| |the| |top| |level| |NGroup| |nodes.|  a |top| |level| |node| |is| \a |node| |whose| |mother| |is| new.ngroup.) (reverse (|fetch| (graphnode tonodes) |of| (find.node 'new.ngroup window))))) (get.ngroup.mother (lambda (ngid window) (* |fsg| " 4-Mar-87 11:24") (* * |Return| |the| |top| |level| |mother| |of| \a |branch| |of| |the| |Ngroup|  |tree.|) (let ((ancestors (list.ancestors ngid nil window))) (cond (ancestors (car ancestors)) (t (cond ((find.node ngid window) ngid) (t nil))))))) ) (* * |Number| |counting| |functions|) (defineq (downdate.numberobjs (lambda (window stream objselectfn) (* |fsg| "25-Sep-87 09:45") (* * |Undoes| |what| update.numberobjs |does.|) (let ((nbrobj.list (tsp.list.of.objects (textobj window) objselectfn))) (and nbrobj.list (progn (tedit.promptprint stream (concat "Undoing Update of " (selectq objselectfn (ngroupp "Number Groups") (endnotep "Endnotes") "Number Groups and Endnotes" ) "...") t) (|for| nbrobj |in| nbrobj.list |do| (let ((datum (|fetch| objectdatum |of| (car nbrobj)))) (|with| numberobj datum (setq page.number nil) (and updated.obj (progn (setq updated.obj nil) (|replace| (ngtemplate ng.currentval) |of| template |with| nil) (setq numstring (selectq use (ngroup (concat "[" ref.type "]")) (note "Note#") nil)) (tedit.object.changed stream (car nbrobj))))))) (tedit.promptprint stream "done")))))) (update.numberobjs (lambda (window stream objselectfn) (* |fsg| "25-Sep-87 09:34") (* * |Convert| |the| |NGroup| |and| |Endnote| |markers| |to| |their|  |corresponding| |numeric| |values.|) (let ((nbrobj.list (tsp.list.of.objects (textobj window) objselectfn))) (and nbrobj.list (progn (tedit.promptprint stream (concat "Updating " (selectq objselectfn (ngroupp "Number Groups") (endnotep "Endnotes") "Number Groups and Endnotes" ) "...") t) (|for| nbrobj |in| nbrobj.list |do| (let ((datum (|fetch| objectdatum |of| (car nbrobj))) new.count) (|with| numberobj datum (reset.dependent.classes window use ref.type) (setq new.count (get.ncounter window use ref.type ngroup.mother template datum)) (and (neq new.count numstring) (progn (setq numstring new.count) (setq updated.obj t) (tedit.object.changed stream (car nbrobj)))))) |finally| (remove.all.counters window)) (tedit.promptprint stream "done")))))) (reset.dependent.classes (lambda (window use ref.type) (* |fsg| "12-Dec-86 10:50") (|for| dependent |in| (|fetch| (graphnode tonodes) |of| (find.node ref.type window)) |do| (progn (reset.ncounter window use dependent) (reset.dependent.classes window use dependent))))) (reset.ncounter (lambda (window use ref.type) (* |fsg| "12-Dec-86 11:07") (let* ((template (selectq use (ngroup (|fetch| (numberobj template) |of| (car (gethash ref.type (tsp.get.ngroup.array window))))) nil)) (counter (ncounter? window use ref.type template))) (|replace| ncount |of| counter |with| (cond (template (sub1 (|fetch| ng.start |of| template))) (t 0)))))) (get.ncounter (lambda (window use ref.type mother.class template nbr.datum) (* |fsg| "11-Aug-87 15:26") (let ((counter (ncounter? window use ref.type template))) (and counter (progn (|with| ngcounter counter (|add| ncount 1) (and (eq use 'ngroup) template (|replace| (ngtemplate ng.currentval) |of| template |with| ncount))) (cond (mother.class (flatten.tree.to.string window use ref.type nbr.datum)) (t (mkstring (|fetch| ncount |of| counter))))))))) (ncounter? (lambda (window use ref.type template) (* |fsg| "14-Jul-87 14:10") (* * |Return| |the| |record| |for| |this| |number| |counter.|  i\f |the| |record| |doesn't| |exist,| |we| |create| |one| |based| |on| |the|  use |value.|) (let ((counter.id (mkatom (concat (selectq use (ngroup (concat "NGROUP." ref.type ".")) (note "ENDNOTE.") (error "Unknown NUMBER type" use)) "COUNTER")))) (or (windowprop window counter.id) (progn (windowprop window counter.id (|create| ngcounter ncount _ (cond ((and (eq use 'ngroup) template) (sub1 (|fetch| ng.start |of| template))) (t 0)) ancestry _ (selectq use (ngroup (list.ancestors ref.type nil window)) nil))) (windowaddprop window 'counters counter.id) (windowprop window counter.id)))))) (flatten.tree.to.string (lambda (window use ref.type nbr.datum) (* |fsg| " 5-Aug-87 14:12") (let* ((ngroup.counter (ncounter? window use ref.type)) (ngroup.list (append (|fetch| (ngcounter ancestry) |of| ngroup.counter))) (abbrevval (|with| numberobj nbr.datum (and abbrev-val (list.ancestors abbrev-val nil window)))) (flat.tree "") ancestor) (and ngroup.list (|while| (setq ancestor (|pop| ngroup.list)) |do| (or (and abbrevval (memb ancestor abbrevval)) (setq flat.tree (concat flat.tree (ngroup.chartype window ancestor (|fetch| (ngcounter ncount) |of| (ncounter? window use ancestor)) (or (car ngroup.list) ref.type))))))) (setq flat.tree (concat flat.tree (ngroup.chartype window ref.type (|fetch| (ngcounter ncount) |of| ngroup.counter) nil)))))) (ngroup.chartype (lambda (window ref.type ncount next.ngroup) (* |fsg| "11-Aug-87 15:23") (* * |Convert| |the| |number| ncount |to| |the| |format| |specified| |in|  template. delimitflg |is| |the| |next| |NGroup's| |preceding| |delimiter| |or|  nil |if| |either| |the| |next| |NGroup| |has| |no| |preceding| |delimiter| |or|  |there| |is| |no| |next| |NGroup.|) (let ((delimitflg (and next.ngroup (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash next.ngroup (tsp.get.ngroup.array window)))) ng.text-before)))) (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash ref.type (  tsp.get.ngroup.array window)))) (concat (or ng.text-before "") (ngroup.chartype.convert ng.chartype ncount) (cond (delimitflg "") (t (or ng.text-after "")))))))) (ngroup.chartype.convert (lambda (chartype ncount) (* |fsg| "28-Jul-87 11:12") (* * |Convert| |the| |value| ncount |to| |the| |type| |specified| |by|  chartype. i\f ncount < 1 |and| chartype |is| |Letter/Roman| |then| |we|  |return| nil. |This| |anomaly| |is| |usually| |caused| |by| |out-of-order|  |NGroups.|) (cond ((fixp ncount) (cond ((or (igreaterp ncount 0) (eq chartype '|Number|) (eq chartype '|Null String|)) (selectq chartype (uppercase\ letter (number.to.letter ncount t)) (|lowercase letter| (number.to.letter ncount)) (uppercase\ roman (romannumerals ncount t)) (|lowercase roman| (romannumerals ncount)) (|Null String| "") (|Number| (mkstring ncount)) (error "Unknown display type" chartype))) (t (mkstring nil)))) (t (error "Invalid integer" ncount))))) (number.to.letter (lambda (number ucflg) (* |fsg| " 5-Dec-86 10:18") (* * |Convert| number |to| |equivalent| |letter| |code.|) (let ((ltrlst (mkstring (character (iplus (charcode a) (iremainder (sub1 number) 26))))) (ltrnbr (iquotient (sub1 number) 26))) (|until| (zerop ltrnbr) |do| (setq ltrlst (concat (character (sub1 (iplus (charcode a) (iremainder ltrnbr 26)))) ltrlst)) (setq ltrnbr (iquotient ltrnbr 26))) (cond (ucflg (u-case ltrlst)) (t (l-case ltrlst)))))) (remove.all.counters (lambda (window) (* |ss:| "30-Sep-85 09:38") (|for| counter |in| (windowprop window 'counters) |do| (windowprop window counter nil) |finally| (windowprop window 'counters nil)))) ) (putprops tmax-ngraph copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1425 11144 (graphmenu 1435 . 2488) (initial.ngroup.graph 2490 . 3059) ( ngroup.make.rootnode 3061 . 3282) (tspgraphregion 3284 . 3876) (close.ngroup.graph 3878 . 4462) ( ngroup.graph.closefn 4464 . 5065) (add.ngroup.to.mother.node 5067 . 5461) (add.node.to.graph 5463 . 6568) (collect.hasharray 6570 . 6856) (create.ngroup.node 6858 . 7535) (get.fromnodes 7537 . 7737) ( get.tonodes 7739 . 8326) (find.node 8328 . 8501) (tsp.get.ngroup.array 8503 . 8669) (tsp.legalid 8671 . 9832) (list.ancestors 9834 . 10278) (toplevel.sisters 10280 . 10662) (get.ngroup.mother 10664 . 11142)) (11189 25278 (downdate.numberobjs 11199 . 13348) (update.numberobjs 13350 . 15883) ( reset.dependent.classes 15885 . 16258) (reset.ncounter 16260 . 17044) (get.ncounter 17046 . 17876) ( ncounter? 17878 . 19663) (flatten.tree.to.string 19665 . 21370) (ngroup.chartype 21372 . 22825) ( ngroup.chartype.convert 22827 . 24000) (number.to.letter 24002 . 24992) (remove.all.counters 24994 . 25276))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-NGROUP b/lispusers/TMAX-NGROUP new file mode 100644 index 00000000..7a9c559e --- /dev/null +++ b/lispusers/TMAX-NGROUP @@ -0,0 +1,662 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "25-Jan-97 11:49:57" |{DSK}medley2.0>lispusers>TMAX-NGROUP.;2| 47901 |changes| |to:| (FNS CONVERT.TABS.TO.SPACES) |previous| |date:| "30-Dec-87 11:34:27" |{DSK}medley2.0>lispusers>TMAX-NGROUP.;1|) ; Copyright (c) 1987, 1997 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-NGROUPCOMS) (RPAQQ TMAX-NGROUPCOMS ((* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Other| |unsorted| |functions|) (FNS INSERT.NGROUP VERIFY.NGROUP.ORDER GET.PREVIOUS.NGROUPS ADD.NUMBER.GROUP ADD.NGROUP.TO.DBASE COLLECT.NGROUPS LIST.FONT.PROPS MAP.NGROUP.LOOKS NGROUP.GETFONT CHANGE.NGROUP CHANGE.NGROUP.FONT SHOW.NGROUP.FONT CHANGE.NGROUP.FORMAT SHOW.NGROUP.FORMAT CHANGE.NGROUP.FORMAT.TXTBEFORE CHANGE.NGROUP.FORMAT.DISPLAY CHANGE.NGROUP.FORMAT.TXTAFTER GET.NGROUP.DELIMITER CHANGE.NGROUP.FORMAT.ABBREV CHANGE.NGROUP.FORMAT.START GET.NGROUP.START CHANGE.NGROUP.FORMAT.TOC CHANGE.NGROUP.FORMAT.MANINDEX UPDATE.NGROUP.MANINDEX NGROUP.FIXUP.RECORDS) (* * |Table-of-Contents| |functions|) (FNS GET.NGROUP.TEXTSTRING CONVERT.TABS.TO.SPACES CREATE.TOC.FILE NGROUP.TOC.ENTRIES VIEW.TOC.FILE GET.TOC.FILE WRITE.TOC.FILE WRITE.TOC.ENTRY))) (* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Other| |unsorted| |functions|) (DEFINEQ (insert.ngroup + (lambda (node graphw) (* |fsg| "26-Aug-87 14:37") + (* * |Insert| \a |NGroup| |build| |from| |the| |prototype| |definition.|) + + (and node (let* ((twindow (windowprop graphw 'twindow)) + (tstream (windowprop graphw 'tstream)) + (label (|fetch| (graphnode nodeid) |of| node)) + (oldlooks (|fetch| caretlooks |of| (textobj tstream))) + (newlooks (ngroup.getfont label twindow))) + (|with| numberobj (car (gethash label (tsp.get.ngroup.array twindow))) + (selectq label + (new.ngroup nil) + (let ((newobj (numberobj 'ngroup template (concat "[" label "]") + label newlooks (get.fromnodes label twindow) + abbrev-val))) + (tedit.caretlooks tstream newlooks) + (get.ngroup.textstring newobj label tstream twindow) + (imageobjprop newobj 'twindow twindow) + (tedit.insert.object newobj tstream) + (tedit.caretlooks tstream oldlooks) + (and (update? twindow) + (update.numberobjs twindow tstream 'ngroupp)) + (verify.ngroup.order twindow newobj)))))))) (verify.ngroup.order + (lambda (window ngroup.obj) (* |fsg| "28-Jul-87 15:59") + (* * |Verify| |the| |NGroup| |order| |before| |inserting| \a |new| |NGroup.| + |The| |order| |is| |valid| |if| |the| |new| |NGroup| |is| \a |top| |level| + |node| |or| |its| |parent| |Ngroup| |has| |already| |been| |inserted.|) + + (let* ((mother (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) + ngroup.mother)) + (selection (tedit.getsel (textstream window))) + (ch# (and selection (|fetch| ch# |of| selection)))) + (cond + ((or (eq mother 'new.ngroup) + (and ch# (|for| prev.ngroup |in| (tsp.list.of.objects (textobj window) + (function get.previous.ngroups) + ch#) + |thereis| (eq mother (|with| numberobj (|fetch| objectdatum + |of| (car prev.ngroup)) + ref.type))))) + (tedit.promptprint (textstream window) + "" t)) + (t (tedit.promptprint (textstream window) + (concat "Warning...\"" (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) + ref.type) + "\" is not preceded by \"" mother "\" NGroup.") + t) + (flashwindow (|with| textobj (textobj window) + promptwindow) + 2)))))) (get.previous.ngroups + (lambda (ngroup.obj char.pos) (* |fsg| "28-Jul-87 14:01") + (* * |Called| |from| tsp.list.of.objects |to| |collect| |all| |the| |NGroup| + |ImageObjs| |that| |exist| |before| |the| |character| |position| char.pos.) + + (and (ngroupp ngroup.obj) + (ilessp ch# char.pos)))) (add.number.group + (lambda (twindow stream) (* \; "Edited 30-Sep-87 14:34 by fsg") + + (or (ngroupmenu.enabled? twindow) + (progn (fm.changestate (fm.getitem 'ngroup.menu nil (windowprop twindow 'imageobj.menuw)) + t + (windowprop twindow 'imageobj.menuw)) + (graphmenu stream twindow))) + (let* ((prev.items (collect.ngroups twindow)) + (new.groupid (mkatom (tsp.legalid (cons 'new.ngroup prev.items) + stream))) + template dependent.class new.node) + (prog1 (cond + (new.groupid (setq dependent.class + (or (mkatom (and prev.items + (menu (|create| menu + title _ "Parent Group?" + items _ (sort prev.items 'ualphorder) + )))) + 'new.ngroup)) + (or template + (setq template + (|create| ngtemplate + ng.chartype _ '|Number| + ng.text-before _ nil + ng.text-after _ "." + ng.start _ 1 + ng.addtotoc _ t + ng.currentval _ nil + ng.manualindex _ nil))) + (setq new.node (nodecreate new.groupid new.groupid nil nil (list + dependent.class + ))) + (add.ngroup.to.dbase new.groupid template dependent.class |GP.DefaultFont| + new.node twindow) + (add.node.to.graph new.node (windowprop twindow 'ngroup.graph) + twindow)) + (t nil)) + (tedit.promptprint stream "" t))))) (add.ngroup.to.dbase + (lambda (new.groupid template dependent.class font ngroup.node twindow) + (* |fsg| " 3-Aug-87 16:43") + (let ((ngroup.array (tsp.get.ngroup.array twindow))) + (or (gethash new.groupid ngroup.array) + (progn (windowprop twindow 'rebuild.graphflg t) + (puthash new.groupid + (list (|create| numberobj + ngroup.mother _ dependent.class + font _ font + ref.type _ new.groupid + template _ template) + ngroup.node) + (list ngroup.array))))))) (collect.ngroups + (lambda (twindow) (* |ss:| "31-Mar-86 13:53") + (let ((graph (windowprop twindow 'ngroup.graph))) + (|for| node |in| (|fetch| (graph graphnodes) |of| graph) |collect| (|fetch| (graphnode + nodeid) + |of| node) + |unless| (eq (|fetch| (graphnode nodeid) |of| node) + 'new.ngroup))))) (list.font.props + (lambda (fontdes) (* |fsg| " 3-Aug-87 10:03") + (and (fontp fontdes) + (list (fontprop fontdes 'family) + (fontprop fontdes 'size) + (fontprop fontdes 'face))))) (map.ngroup.looks + (lambda (label new.font twindow new.template) (* |fsg| " 5-Aug-87 13:40") + (* * |Here| |to| |change| |the| |font| |or| |format| |of| |an| |NGroup.| + i\f new.template |is| |non-NIL| |then| |we| |are| |changing| |the| |format,| + |else| |we| |are| |changing| |the| |font.|) + + (tedit.promptprint (textstream twindow) + (concat "Updating " (cond + (new.template "FORMAT") + (t "FONT")) + " for \"" label "\" Ngroups...") + t) + (|for| ngroup.obj |in| (tsp.list.of.objects (textobj twindow) + `(lambda (obj) + (and (ngroupp obj) + (eq (fetch ref.type of (fetch objectdatum of obj)) + \, + (kwote label))))) + |do| (|with| numberobj (|fetch| objectdatum |of| (car ngroup.obj)) + (cond + (new.template (setq template new.template)) + (t (tedit.looks (textstream twindow) + new.font + (cadr ngroup.obj) + 1) + (setq font new.font))))) + (tedit.promptprint (textstream twindow) + "Done."))) (ngroup.getfont + (lambda (ngroup.name window ngroup.obj) (* |fsg| " 4-Aug-87 15:00") + (* * |Get| |an| |NGroup's| |font.| i\f ngroup.obj |is| |non-NIL| |then| |we| + |get| |the| |font| |from| |this| |ImageObj's| objectdatum. + |Else| |we| |get| |the| |font| |from| |the| |NGroup| |graph| |prototype| + |NGroup.|) + + (|fetch| (numberobj font) |of| (cond + (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) + (t (car (gethash ngroup.name (tsp.get.ngroup.array window)))))) + )) (change.ngroup + (lambda (node graphw) (* |fsg| "30-Jul-87 13:52") + (* * |Here| |when| |number| |group| |node| |is| |middle| |buttoned.| + |Allow| |user| |to| |change| |the| |font| |and/or| |format| |of| |the| + |ngroup.|) + + (and node (let ((label (|fetch| (graphnode nodeid) |of| node))) + (selectq label + (new.ngroup nil) + (menu (|create| menu + title _ (mkstring label) + centerflg _ t + items _ (eval ngroup.graph.menu.items)))))))) (change.ngroup.font + (lambda (label graphw font.field ngroup.obj) (* |fsg| " 4-Aug-87 15:09") + (* * |Change| \a |NGroup| |font.| i\f |NGROUP.OBJis| |non-NIL| |then| |we| + |are| |working| |on| |an| |inserted| |NGroup.| + |Else| |we| |are| |working| |on| |the| |graph| |prototype| |NGroups.|) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + new.font) + (show.ngroup.font label graphw ngroup.obj) + (tedit.promptprint stream (selectq font.field + (family ", change Family to...") + (size ", change Size to...") + (face ", change Face to...") + ", change to...")) + (|with| numberobj (cond + (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) + (t (car (gethash label (tsp.get.ngroup.array window))))) + (setq new.font (fontcreate (get.tsp.font window font font.field))) + (tedit.promptprint stream "" t) + (and (neq font new.font) + (progn (setq font new.font) + (cond + (ngroup.obj new.font) + (t (map.ngroup.looks label new.font window))))))))) (show.ngroup.font + (lambda (label graphw ngroup.obj) (* |fsg| " 4-Aug-87 14:57") + (* * |Show| |this| |NGroup's| |font| |specification.|) + + (let* ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + (font.list (abbreviate.font (ngroup.getfont label window ngroup.obj)))) + (tedit.promptprint stream (concat label ": Family=" (|pop| font.list) + " Size=" + (|pop| font.list) + " Face=" + (|pop| font.list)) + t)))) (change.ngroup.format + (lambda (label graphw format.field) (* |fsg| " 1-Sep-87 15:39") + (* * |Change| |the| |entire| |format| |or| \a |selected| |field| |of| |an| + |NGroup.|) + + (let ((window (windowprop graphw 'twindow)) + (new.format (|for| field |in| (cond + (format.field (list format.field)) + (t '(txtbefore display txtafter abbrevval start toc + manindex))) + |collect| (selectq field + (txtbefore (change.ngroup.format.txtbefore label graphw)) + (display (change.ngroup.format.display label graphw)) + (txtafter (change.ngroup.format.txtafter label graphw)) + (abbrevval (change.ngroup.format.abbrev label graphw)) + (start (change.ngroup.format.start label graphw)) + (toc (change.ngroup.format.toc label graphw)) + (manindex (change.ngroup.format.manindex label graphw)) + (error "Unknown NGroup Format field" field))))) + (and (apply 'or new.format) + (let ((nbrobj (car (gethash label (tsp.get.ngroup.array window))))) + (map.ngroup.looks label (|fetch| (numberobj font) |of| nbrobj) + window + (|fetch| (numberobj template) |of| nbrobj))))))) (show.ngroup.format + (lambda (label graphw) (* |fsg| "26-Aug-87 12:02") + (* * |Show| |this| |NGroup's| |format| |specification.|) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow))) + (|with| numberobj (car (gethash label (tsp.get.ngroup.array window))) + (|with| ngtemplate template (tedit.promptprint stream + (concat label ": Display=" + (concat (cond + (ng.text-before (concat "\"" + ng.text-before + "\"")) + (t "\"\"")) + ng.chartype + (cond + (ng.text-after (concat "\"" + ng.text-after + "\"")) + (t "\"\""))) + " Abbrev=" + (or abbrev-val "None") + " Start=" ng.start " TOC=" (cond + (ng.addtotoc + "Yes") + (t "No")) + (cond + ((manualindex.enabled? window) + (cond + (ng.manualindex " ManIndex=Yes") + (t " ManIndex=No"))) + (t ""))) + t)))))) (change.ngroup.format.txtbefore + (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:11") + (* * |Show| |and| |possibly| |reset| |the| |delimiter| |preceding| |this| + |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| + |delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| + |an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| + |prototype.|) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + new.delimiter) + (|with| ngtemplate (|fetch| (numberobj template) |of| (cond + (ngroup.obj (|fetch| objectdatum + |of| ngroup.obj)) + (t (car (gethash label ( + tsp.get.ngroup.array + window))))) + ) + (and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-before + 'before)) + (not (strequal new.delimiter ng.text-before)) + (setq ng.text-before new.delimiter)))))) (change.ngroup.format.display + (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12") + (* * |Show| |and| |possibly| |reset| |how| |this| |NGroup| |is| |displayed.| + |Return| nil |if| |nothing| |changed| |else| |returm| |the| |new| |display| + |type.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| |an| + |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| |prototype.|) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + new.display) + (|with| ngtemplate (|fetch| (numberobj template) |of| (cond + (ngroup.obj (|fetch| objectdatum + |of| ngroup.obj)) + (t (car (gethash label ( + tsp.get.ngroup.array + window))))) + ) + (tedit.promptprint stream (concat "\"" label "\" displayed as " ng.chartype + ", change to...") + t) + (|until| (or (null (setq new.display + (menu (|create| menu + title _ "NGroup Displays" + centerflg _ t + items _ '(|Number| |Null String| uppercase\ letter + |lowercase letter| uppercase\ roman + |lowercase roman|))))) + (selectq new.display + ((|Number| |Null String|) + t) + (igreaterp ng.start 0))) + |do| (tedit.promptprint stream (concat "Starting value (=" ng.start + ") must be > 0 for \"" new.display + "\". Try again.") + t)) + (tedit.promptprint stream "" t) + (and new.display (neq new.display ng.chartype) + (kwote (setq ng.chartype new.display))))))) (change.ngroup.format.txtafter + (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12") + (* * |Show| |and| |possibly| |reset| |the| |delimiter| |following| |this| + |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| + |delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| + |an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| + |prototype.|) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + new.delimiter) + (|with| ngtemplate (|fetch| (numberobj template) |of| (cond + (ngroup.obj (|fetch| objectdatum + |of| ngroup.obj)) + (t (car (gethash label ( + tsp.get.ngroup.array + window))))) + ) + (and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-after + 'after)) + (not (strequal new.delimiter ng.text-after)) + (setq ng.text-after new.delimiter)))))) (get.ngroup.delimiter + (lambda (stream label delimiter before/after) (* |fsg| "17-Aug-87 15:12") + (* * |Show| |and| |possibly| |reset| |the| |delimiter| |before/after| |this| + |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| + |delimiter.|) + + (tedit.promptprint stream (concat "Delimiter " (selectq before/after + (before "preceding ") + "following ") + label "\" is " (cond + (delimiter (concat "\"" delimiter "\"")) + (t '|Unspecified|)) + ", change to...") + t) + (prog1 (menu (|create| menu + title _ "NGroup Delimiters" + centerflg _ t + items _ '((|Period| ".") + (|Colon| ":") + (|Dash| "-") + (|Null String| "") + (|Other| (tedit.getinput stream (concat "Specify delimiter " + (selectq before/after + (before "preceding ") + "following ") + label ":")))))) + (tedit.promptprint stream "" t)))) (change.ngroup.format.abbrev + (lambda (label graphw ngroup.obj) (* |fsg| "26-Aug-87 11:48") + (* * |Change| |the| |display| |level| |of| \a |NGroup.| + |Let| |the| |user| |decide| |how| |far| |up| |the| |parent| |tree| |to| |go| + |wrt| |printing| |values.| |This| |allows| |user| |to| |number| |things| |as| + |2.a,| |b,| |c,| |etc.| |Thanks| |to| |Michael| |Wescoat| |at| |Xerox| |for| + |suggesting| |this.|) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow))) + (|with| numberobj (cond + (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) + (t (car (gethash label (tsp.get.ngroup.array window))))) + (let ((parents (list.ancestors label nil window))) + (cond + (parents (tedit.promptprint stream (concat label (cond + (abbrev-val (concat + + " abbreviation starts at " + abbrev-val)) + (t " not abbreviated")) + ". Select starting level.") + t) + (let ((new.abrev (menu (|create| menu + title _ (concat label " Levels") + items _ (append parents (list label)) + centerflg _ t)))) + (and new.abrev (neq new.abrev abbrev-val) + (true (setq abbrev-val (cond + ((eq new.abrev (car parents)) + nil) + (t new.abrev))))))) + (t (tedit.promptprint stream (concat "Cannot abbreviate top level NGroup \"" + label "\"") + t)))))))) (change.ngroup.format.start + (lambda (label graphw) (* |fsg| " 9-Jul-87 15:45") + (* * |Show| |and| |possibly| |reset| |this| |NGroup's| |starting| |value.| + |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| |starting| + |value.|) + + (let ((window (windowprop graphw 'twindow)) + new.start) + (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( + tsp.get.ngroup.array + window)))) + (and (setq new.start (get.ngroup.start label ng.chartype ng.start (windowprop + graphw + 'tstream))) + (neq new.start ng.start) + (setq ng.start new.start)))))) (get.ngroup.start + (lambda (label display start stream) (* |fsg| "23-Jul-87 14:38") + (* * |Get| |the| |starting| |value| |for| |this| |NGroup.| + |Any| |value| |is| |ok| |for| \a |Number| |display| |but| |Letter/Roman| + |numeral| |values| |must| |be| |greater| |than| |zero.|) + + (let ((prompt.string (concat "Starting value of \"" label "\" is " start)) + new.start) + (|until| (or (null (setq new.start (mkatom (tedit.getinput stream (concat prompt.string + ". New starting value:" + ))))) + (cond + ((not (fixp new.start)) + (setq prompt.string (concat new.start " is not an integer")) + nil) + (t (selectq display + ((|Number| |Null String|) + t) + (cond + ((ileq new.start 0) + (setq prompt.string (concat "Start (=" new.start + ") must be > 0 for \"" display "\"")) + nil) + (t t))))))) + new.start))) (change.ngroup.format.toc + (lambda (label graphw) (* |fsg| " 7-Jul-87 09:12") + (* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included| + |in| |the| |Table-OfŹContents.| |Return| nil |if| |no| |change| |else| |return| + t.) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + new.addtotoc) + (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( + tsp.get.ngroup.array + window)))) + (tedit.promptprint stream (concat "\"" label "\" is " (cond + (ng.addtotoc "") + (t "NOT ")) + "included in the TOC. Do you want it included?") + t) + (setq new.addtotoc (menu (|create| menu + title _ "In TOC?" + centerflg _ t + items _ '((yes t) + (no nil)) + whenselectedfn _ (function (lambda (item) + item))))) + (tedit.promptprint stream "" t) + (and new.addtotoc (neq (cadr new.addtotoc) + ng.addtotoc) + (progn (setq ng.addtotoc (cadr new.addtotoc)) + t)))))) (change.ngroup.format.manindex + (lambda (label graphw) (* |fsg| " 1-Sep-87 15:39") + (* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included| + |in| |the| |manual| |index.| |Return| nil |if| |no| |change| |else| |return| t.) + + (let ((stream (windowprop graphw 'tstream)) + (window (windowprop graphw 'twindow)) + new.manualindex) + (and (manualindex.enabled? window) + (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( + tsp.get.ngroup.array + window)))) + (tedit.promptprint stream (concat "\"" label "\" is " (cond + (ng.manualindex "") + (t "NOT")) + + " included in the Manual Index. Do you want it included?" + ) + t) + (setq new.manualindex (menu (|create| menu + title _ "Manual Index?" + centerflg _ t + items _ '((yes t) + (no nil)) + whenselectedfn _ (function (lambda (item) + item))))) + (tedit.promptprint stream "" t) + (and new.manualindex (neq (cadr new.manualindex) + ng.manualindex) + (true (cond + ((setq ng.manualindex (cadr new.manualindex)) + (windowaddprop window 'manualgroups label)) + (t (windowdelprop window 'manualgroups label)))))))))) (update.ngroup.manindex + (lambda (template label window) (* |ss:| "27-Jun-87 16:22") + (* * |Update| |the| |NGroup| |template| |list| |wrt| |the| |current| |NGroup| + |level.| |Note| |that| |when| \a |new| |NGroup| |is| |seen,| |all| |it's| + |children| |become| |undefined.| |Furthermore| |we| |know| |the| |NGroups| + |are| |in| |order| |since| |the| |order| |is| |verified| |when| |the| |NGroup| + |is| |inserted.|) + + (and (manualindex.enabled? window) + (let* ((man.groups (windowprop window 'manualgroups)) + (label.groups (memb label man.groups))) + (and label.groups (let* ((label.offset (add1 (idifference (length man.groups) + (length label.groups)))) + (man.templates (windowprop window 'manualtemplates)) + (template.sublist (nth man.templates label.offset))) + (cond + (template.sublist (rplnode template.sublist template)) + (t (windowaddprop window 'manualtemplates template))))))))) (ngroup.fixup.records + (lambda (ngroup.record copyflg) (* |fsg| " 3-Sep-87 15:35") + (* * |Function| |to| "fix up" |the| |NGroup| |record.| + |This| |allows| |us| |to| |expand| |the| |NGroup| |record| |and| |still| + |maintain| |backwatd| |compatability.| i\f copyflg |is| |non-NIL,| |we| |are| + |doing| \a copy. i\n |this| |case| |un-update| |the| |record;| + |Copied| |NGroups| |are| |always| |unupdated.|) + + (let ((template (|fetch| (numberobj template) |of| ngroup.record))) + (|create| numberobj + ref.type _ (|fetch| (numberobj ref.type) |of| ngroup.record) + numstring _ (cond + (copyflg (selectq (|fetch| (numberobj use) |of| ngroup.record) + (ngroup (concat "[" (|fetch| (numberobj ref.type) + |of| ngroup.record) + "]")) + (note "Note#") + nil)) + (t (|fetch| (numberobj numstring) |of| ngroup.record))) + use _ (|fetch| (numberobj use) |of| ngroup.record) + ngroup.mother _ (|fetch| (numberobj ngroup.mother) |of| ngroup.record) + template _ (|create| ngtemplate + ng.chartype _ (|fetch| (ngtemplate ng.chartype) |of| template) + ng.text-before _ (|fetch| (ngtemplate ng.text-before) |of| template + ) + ng.text-after _ (|fetch| (ngtemplate ng.text-after) |of| template) + ng.start _ (|fetch| (ngtemplate ng.start) |of| template) + ng.addtotoc _ (|fetch| (ngtemplate ng.addtotoc) |of| template) + ng.currentval _ (cond + (copyflg nil) + (t (|fetch| (ngtemplate ng.currentval) + |of| template))) + ng.manualindex _ (|fetch| (ngtemplate ng.manualindex) |of| template + )) + updated.obj _ (cond + (copyflg nil) + (t (|fetch| (numberobj updated.obj) |of| ngroup.record))) + text.after# _ (|fetch| (numberobj text.after#) |of| ngroup.record) + page.number _ (|fetch| (numberobj page.number) |of| ngroup.record) + font _ (|fetch| (numberobj font) |of| ngroup.record) + text.before# _ (|fetch| (numberobj text.before#) |of| ngroup.record) + abbrev-val _ (|fetch| (numberobj abbrev-val) |of| ngroup.record))))) ) (* * |Table-of-Contents| |functions|) (DEFINEQ (get.ngroup.textstring + (lambda (nbrobj label stream window) (* |fsg| " 5-Aug-87 10:36") + (* * |Get| |the| |Table-Of-Contents| |before/after| |text| |string| |for| + |this| |NGroup.| |Because| |the| write.toc.file |function| |uses| \a |tab| |to| + |align| |the| |page| |numbers,| |any| |tabs| |in| |the| toc |strings| |are| + |converted| |to| |spaces.|) + + (and (textbefore.enabled? window) + (let ((toc.string (tedit.getinput stream (concat "Text before " label ":") + (mkstring label)))) + (and toc.string (|replace| (numberobj text.before#) |of| (|fetch| objectdatum + |of| nbrobj) + |with| (concat (convert.tabs.to.spaces toc.string) + " "))))) + (and (textafter.enabled? window) + (let ((toc.string (tedit.getinput stream (concat "Text after " label ":")))) + (and toc.string (|replace| (numberobj text.after#) |of| (|fetch| objectdatum + |of| nbrobj) + |with| (concat " " (convert.tabs.to.spaces toc.string)))))))) (CONVERT.TABS.TO.SPACES (LAMBDA (STRING) (* \; "Edited 25-Jan-97 11:49 by rmk:") (* |fsg| "10-Mar-87 11:01") (* |;;| "Returns a string with all tabs and CR's converted to spaces. We do this because some features like the Table-Of-Contents use a tab to align the page numbers.") (AND (STRINGP STRING) (CONCATLIST (FOR CHAR IN (CHCON STRING) COLLECT (CHARACTER (SELCHARQ CHAR ((CR TAB LF) (CHARCODE SPACE)) CHAR))))))) (create.toc.file + (lambda (stream window) (* |fsg| "16-Jul-87 11:46") + (* * |Here| |to| |print| |the| |Table| o\f |Contents.| + |Each| |Line| |of| |the| toc |consists| |of| |the| |NGroup,| |the| + |corresponding| |text,| |followed| |by| |the| |current| |listing| |page| + |number.|) + + (let ((toc.list (tsp.list.of.objects (textobj window) + (function ngroup.toc.entries))) + (toc.file (get.toc.file (windowprop window 'imageobj.menuw))) + (toc.tabstop (list 'paralooks (list 'tabs (list nil (cons (fixr (times 72.27 6.125)) + 'dottedleft))))) + toc.stream) + (cond + ((and toc.list toc.file) + (setq toc.stream (opentextstream nil nil nil nil toc.tabstop)) + (tedit.promptprint stream (concat "Putting Table-Of-Contents into file " toc.file "...") + t) + (write.toc.file toc.stream toc.list window) + (tedit.promptprint stream "done") + (tedit.put toc.stream toc.file) + (closef? toc.file) + toc.file) + (toc.list (tedit.promptprint stream + "Specify a file name for the Table-Of-Contents first." t) + nil) + (t (tedit.promptprint stream "There are no NGroups included in the Table-Of-Contents." t) + nil))))) (ngroup.toc.entries + (lambda (nbrobj) (* |fsg| "16-Jul-87 11:20") + (* * |Check| |if| nbrobj |is| \a |NGroup| |ImageObject| |and| |its| ng.addtotoc + |flag| |is| |on.|) + + (and (ngroupp nbrobj) + (|fetch| (ngtemplate ng.addtotoc) |of| (|fetch| (numberobj template) + |of| (|fetch| objectdatum |of| nbrobj)))))) (view.toc.file + (lambda (stream window) (* |fsg| "12-Aug-87 16:36") + (* * |Writes| |out| |the| toc |file| |via| create.toc.file |and| |then| |opens| + |another| |TEdit| |window| |where| |this| |new| |file| |is| |displayed.|) + + (let ((toc.file (create.toc.file stream window))) + (and toc.file (progn (or (windowprop window 'toc.window) + (windowprop window 'toc.window (createw nil (concat + "Viewing TOC file: " + toc.file)))) + (tedit toc.file (windowprop window 'toc.window))))))) (get.toc.file + (lambda (menuw) (* \; "Edited 29-Sep-87 15:17 by fsg") + + (* * |Return| |the| |user| |specified| |Table-Of-Contents| |file| |name.|) + + (let ((filename (fm.itemprop (fm.getitem 'toc.file nil menuw) + 'label))) + (and (not (strequal filename "")) + (mkatom filename))))) (write.toc.file + (lambda (toc.stream toc.list window) (* |fsg| "26-Aug-87 15:37") + (* * |Here| |to| |speficy| |the| |order| |of| |the| |Table-Of-Contents.| + |The| toc |is| |ordered| |by| |the| |top-level| |sister| |nodes.|) + + (dspfont (fontcreate '(helvetica 14 brr)) + toc.stream) + (printout toc.stream "Table of Contents" t) + (|for| toc.mother |in| (toplevel.sisters window) + |do| (dspfont |GP.DefaultFont| toc.stream) + (printout toc.stream t) + (|for| toc.item |in| toc.list |when| (|with| numberobj (|fetch| objectdatum + |of| (car toc.item)) + (eq (get.ngroup.mother ref.type window) + toc.mother)) + |do| (write.toc.entry toc.item toc.stream window))))) (write.toc.entry + (lambda (toc.item toc.stream window) (* |fsg| "27-Jul-87 14:55") + (* * |Write| |one| |line| |to| |the| |Table-Of-Contents| |file.|) + + (let* ((datum (|fetch| objectdatum |of| (car toc.item))) + (item.level (length (list.ancestors (|fetch| (numberobj ref.type) |of| datum) + nil window)))) + (dspfont |GP.DefaultFont| toc.stream) + (cond + ((zerop item.level) + (printout toc.stream t)) + (t (rptq item.level (printout toc.stream " ")))) + (dspfont (|fetch| (numberobj font) |of| datum) + toc.stream) + (printout toc.stream (concat (or (|fetch| (numberobj text.before#) |of| datum) + "") + (|fetch| (numberobj numstring) |of| datum) + (or (|fetch| (numberobj text.after#) |of| datum) + ""))) + (dspfont |GP.DefaultFont| toc.stream) + (printout toc.stream (character (charcode tab)) + (|fetch| (numberobj page.number) |of| datum) + t)))) ) (PUTPROPS TMAX-NGROUP COPYRIGHT ("Xerox Corporation" 1987 1997)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1660 40131 (INSERT.NGROUP 1670 . 3281) (VERIFY.NGROUP.ORDER 3283 . 5076) ( GET.PREVIOUS.NGROUPS 5078 . 5447) (ADD.NUMBER.GROUP 5449 . 7814) (ADD.NGROUP.TO.DBASE 7816 . 8622) ( COLLECT.NGROUPS 8624 . 9221) (LIST.FONT.PROPS 9223 . 9491) (MAP.NGROUP.LOOKS 9493 . 10982) ( NGROUP.GETFONT 10984 . 11634) (CHANGE.NGROUP 11636 . 12337) (CHANGE.NGROUP.FONT 12339 . 13797) ( SHOW.NGROUP.FONT 13799 . 14517) (CHANGE.NGROUP.FORMAT 14519 . 16245) (SHOW.NGROUP.FORMAT 16247 . 18824 ) (CHANGE.NGROUP.FORMAT.TXTBEFORE 18826 . 20365) (CHANGE.NGROUP.FORMAT.DISPLAY 20367 . 23015) ( CHANGE.NGROUP.FORMAT.TXTAFTER 23017 . 24551) (GET.NGROUP.DELIMITER 24553 . 26242) ( CHANGE.NGROUP.FORMAT.ABBREV 26244 . 28836) (CHANGE.NGROUP.FORMAT.START 28838 . 29916) ( GET.NGROUP.START 29918 . 31390) (CHANGE.NGROUP.FORMAT.TOC 31392 . 33276) ( CHANGE.NGROUP.FORMAT.MANINDEX 33278 . 35618) (UPDATE.NGROUP.MANINDEX 35620 . 36916) ( NGROUP.FIXUP.RECORDS 36918 . 40129)) (40176 47813 (GET.NGROUP.TEXTSTRING 40186 . 41565) ( CONVERT.TABS.TO.SPACES 41567 . 42322) (CREATE.TOC.FILE 42324 . 43848) (NGROUP.TOC.ENTRIES 43850 . 44322) (VIEW.TOC.FILE 44324 . 45119) (GET.TOC.FILE 45121 . 45519) (WRITE.TOC.FILE 45521 . 46523) ( WRITE.TOC.ENTRY 46525 . 47811))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-NUMBER b/lispusers/TMAX-NUMBER new file mode 100644 index 00000000..16b856a9 --- /dev/null +++ b/lispusers/TMAX-NUMBER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 6-May-2000 10:37:14" |{DSK}medley3.5>lispusers>TMAX-NUMBER.;4| 32399 |changes| |to:| (FNS NUMBEROBJ.TEDIT-TO-TEX-FN NUMBEROBJ) (VARS TMAX-NUMBERCOMS) |previous| |date:| "18-May-99 22:54:30" |{DSK}medley3.5>lispusers>TMAX-NUMBER.;2|) ; Copyright (c) 1987, 1999, 2000 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-NUMBERCOMS) (RPAQQ TMAX-NUMBERCOMS ((* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * TMAX-NUMBERNIL |ImageObject| |functions|) (FNS NUMBEROBJ NUMBEROBJP NGROUPP NUMBER.DISPLAYFN NUMBER.PREPRINTFN NUMBER.IMAGEBOXFN NUMBER.PUTFN NUMBER.GETFN NUMBER.COPYFN NUMBER.BUTTONEVENTINFN NUMBEROBJ.TEDIT-TO-TEX-FN ) (FNS COPY.NGROUP.BRANCH DUMP.NGROUP.GRAPH NGROUP.BUTTONEVENTINFN NGROUP.DEFINE.TAG NUMBER.DELETE.TAG NGROUP.SHOW.TAG CHANGE.INSERTED.NGROUP.FORMAT CHANGE.NGROUP.FORMAT.#TEXT SHOW.INSERTED.NGROUP.FORMAT) (* * |Variable| |and| |Record| |definitions|) (VARS NGROUP.GRAPH.MENU.ITEMS NGROUP.INSERTED.MENU.ITEMS NGROUP.INSERTED.NOTAG.ITEMS NGROUP.INSERTED.TAG.ITEMS) (RECORDS NGCOUNTER NGTEMPLATE NUMBEROBJ))) (* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * TMAX-NUMBERNIL |ImageObject| |functions|) (DEFINEQ (NUMBEROBJ (LAMBDA (USE TEMPLATE NUMSTRING REF.TYPE FONT MOTHER ABBREV.LEVEL) (* |fsg| "26-Aug-87 14:29") (LET ((NEWOBJ (IMAGEOBJCREATE (|create| NUMBEROBJ REF.TYPE _ REF.TYPE NUMSTRING _ (OR NUMSTRING "Note#") USE _ USE NGROUP.MOTHER _ MOTHER TEMPLATE _ TEMPLATE UPDATED.OBJ _ NIL TEXT.AFTER# _ NIL PAGE.NUMBER _ NIL FONT _ FONT TEXT.BEFORE# _ NIL ABBREV-VAL _ ABBREV.LEVEL) \\NUMBEROBJ.IMAGEFNS))) (IMAGEOBJPROP NEWOBJ 'TYPE 'NUMBEROBJ) (IMAGEOBJPROP NEWOBJ 'TEDIT-TO-TEX-FN (FUNCTION NUMBEROBJ.TEDIT-TO-TEX-FN)) NEWOBJ))) (numberobjp (lambda (imobj) (* |ss:| "27-Jun-87 16:21") (* * |Tests| |an| |imageobj| |to| |see| |if| |it| |is| \a |number|  |imageobject.| |The| |only| |number| |imageobjects| |so| |far| |are| |NGroups|  |and| |Endnotes.| b\y |convention,| |testing| |functions| |for| |an|  |imageobject| |will| |be| |named| (concat || "P")) (and imobj (eq (imageobjprop imobj 'type) 'numberobj)))) (ngroupp (lambda (imobj) (* |ss:| "27-Jun-87 16:15") (* * |Like| numberobjp |but| |also| |checks| |for| |NGroup| |ImageObject.|) (and (numberobjp imobj) (eq (|fetch| (numberobj use) |of| (|fetch| objectdatum |of| imobj)) 'ngroup)))) (number.displayfn (lambda (image.obj stream) (* |fsg| "24-Sep-87 14:56") (* |Display| |function| |for| |numberobjs.|  |Allows| |different| |formats| |for| |display| |according| |to| |the| |use|  |to| |which| |the| |numberobj| |is| |being| |put.|  i\f |no| |specific| |action| |is| |specified,| |displaying| |defaults| |to|  |printing| |out| |as| \a |plain| |number.*|) (|with| numberobj (|fetch| objectdatum |of| image.obj) (let* ((main.window (|with| textobj textobj (car \\window))) (image.tag (imageobjprop image.obj 'tag)) (old.font (dspfont nil stream)) (nbr.font (selectq use (note (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts main.window))) (ngroup font) (error "Undefined USE field" use)))) (and image.tag (or (tsp.getcodeval image.tag main.window) (tsp.putcode image.tag image.obj main.window))) (and (fontp nbr.font) (dspfont (fontcreate (fontprop nbr.font 'family) (fontprop nbr.font 'size) (fontprop nbr.font 'face)) stream)) (or (imagestreamtypep stream 'display) (setq page.number (car formattingstate))) (tmax.shadeobj image.obj stream) (selectq use (ngroup (prin1 (concat (or text.before# "") (mkstring numstring) (or text.after# "")) stream) (or (imagestreamtypep stream 'display) (update.ngroup.manindex template ref.type main.window))) (note (let ((current.ypos (dspyposition nil stream)) (imagebox (listget (|fetch| imageobjplist |of| image.obj) 'boundbox))) (dspyposition (iplus current.ypos (idifference (|fetch| ysize |of| imagebox) (fontprop stream 'height))) stream) (prin1 (mkstring numstring) stream) (dspyposition current.ypos stream))) nil) (dspfont old.font stream))))) (NUMBER.PREPRINTFN (LAMBDA (IMAGE.OBJ) (* \; "Edited 18-May-99 22:51 by rmk:") (* |fsg| "24-Sep-87 14:56") (* |;;| "Returns string that represents the number object, for plaintext put. If no specific action is specified, displaying defaults to printing out as a plain number.*") (WITH NUMBEROBJ (FETCH OBJECTDATUM OF IMAGE.OBJ) (LET* ((MAIN.WINDOW (WITH TEXTOBJ TEXTOBJ (CAR \\WINDOW))) (IMAGE.TAG (IMAGEOBJPROP IMAGE.OBJ 'TAG))) (AND IMAGE.TAG (OR (TSP.GETCODEVAL IMAGE.TAG MAIN.WINDOW) (TSP.PUTCODE IMAGE.TAG IMAGE.OBJ MAIN.WINDOW))) (SELECTQ USE (NGROUP (CONCAT (OR TEXT.BEFORE# "") (MKSTRING NUMSTRING) (OR TEXT.AFTER# ""))) (NOTE (MKSTRING NUMSTRING)) NIL))))) (number.imageboxfn (lambda (obj stream currentx rightmargin) (* |fsg| " 4-Aug-87 14:56") (* * |For| |Endnote| |numbers,| |the| |YSize| |is| |the| |current| |font|  |height| |plus| 0.25 |times| |the| |Endnote| |number| |font| |height.|  w\e |do| |this| |so| |the| |the| |Endnote| |number| |will| |be| |superscripted|  |but| |not| |too| |much.|) (* * |The| |YSize| |is| |computed| |as| |the| |current| |font| |height| |plus|  |half| |of| |the| note |or| |NGroup| |font.|  |The| |reason| |is| |weird.| |Ask| |Sami| |for| |more| |details.|) (|with| numberobj (|fetch| objectdatum |of| obj) (let* ((main.window (|with| textobj textobj (car \\window))) (imobj.string (mkstring numstring)) (nbr.font (selectq use (note (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts main.window))) (ngroup font) (error "Undefined USE field" use)))) (and (eq use 'ngroup) (progn (and (stringp text.before#) (setq imobj.string (concat text.before# imobj.string))) (and (stringp text.after#) (setq imobj.string (concat imobj.string text.after#))))) (and (fontp nbr.font) (dspfont (fontcreate (fontprop nbr.font 'family) (fontprop nbr.font 'size) (fontprop nbr.font 'face)) stream)) (|create| imagebox xsize _ (stringwidth imobj.string stream) ysize _ (selectq use (note (fix (plus (times (dspscale nil stream) (fontprop (current.display.font stream) 'height)) (times 0.25 (fontprop stream 'height))))) (fontprop stream 'height)) ydesc _ (fontprop stream 'descent) xkern _ 0))))) (number.putfn (lambda (obj stream) (* |fsg| " 5-Aug-87 08:24") (let ((window (|with| textobj textobj (car \\window))) (use (|with| numberobj (|fetch| objectdatum |of| obj) use)) (old.font (|with| numberobj (|fetch| objectdatum |of| obj) font))) (selectq use (note (note.putfn obj stream window)) (ngroup (let ((ngroup.rec (copy (|fetch| objectdatum |of| obj)))) (|with| numberobj ngroup.rec (setq font (list.font.props font)) (prin4 (list '|NGroup| (and (windowprop window 'dumpngroupgraph) (dump.ngroup.graph window)) (imageobjprop obj 'tag) ngroup.rec) stream)))) (error "Unknown NUMBER ImageObject type" use))))) (number.getfn (lambda (stream copy.object) (* |fsg| " 3-Sep-87 15:17") (* * i\f copy.object |is| |non-NIL| |then| |we| |are| |COPYing| |it| |to|  |this| |window.|) (let ((nbrobj.datum (or copy.object (cdr (read stream)))) (newobj (numberobj)) (window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window) (and (ilessp (length nbrobj.datum) 3) (setq nbrobj.datum (cons nil nbrobj.datum))) (and (car nbrobj.datum) (not (and (boundp 'tmax.prune.ngraph) tmax.prune.ngraph)) (copy.ngroup.branch (car nbrobj.datum) window)) (and (cadr nbrobj.datum) (not (gethash (cadr nbrobj.datum) (windowprop window 'tsp.code.array))) (progn (tsp.putcode (cadr nbrobj.datum) newobj window) (imageobjprop newobj 'tag (cadr nbrobj.datum)))) (|with| numberobj (setq nbrobj.datum (ngroup.fixup.records (caddr nbrobj.datum) copy.object)) (selectq use (note (note.getfn newobj nbrobj.datum window)) (ngroup (and (listp font) (setq font (fontcreate font))) (create.ngroup.node ref.type ngroup.mother nbrobj.datum window) (create.ngroup.node ngroup.mother nil nil window) (add.ngroup.to.mother.node ref.type ngroup.mother window) (windowprop window 'rebuild.graphflg t) (and (|fetch| (ngtemplate ng.manualindex) |of| template) (windowaddprop window 'manualgroups ref.type)) (|replace| objectdatum |of| newobj |with| nbrobj.datum)) (error "Unknown USE type in NUMBER.GETFN" use))) newobj))) (number.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| " 4-Aug-87 09:46") (* * |Here| |to| copy \a |Number| |Image| |Object.|  i\f |we| |are| |copying| |to| |our| |own| |window,| |we| |delete| |the| tag  |if| |any| |so| |we| |don't| |get| |two| |ImageObjs| |with| |the| |same| tag  |name.|) (selectq (imagestreamtype target.stream) (text (let ((source.window (|with| textobj textobj (car \\window))) (textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (list (|with| numberobj (|fetch| objectdatum |of| image.obj) (and (eq use 'ngroup) (neq source.stream target.stream) (|for| parent |in| (append (list.ancestors ref.type nil source.window) (list ref.type)) |collect| (car (gethash parent (tsp.get.ngroup.array source.window)))))) (and (neq source.stream target.stream) (imageobjprop image.obj 'tag)) (|fetch| objectdatum |of| image.obj))))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (number.buttoneventinfn (lambda (obj stream sel relx rely window hoststream button)(* |fsg| " 2-Sep-87 11:09") (* * |Here| |when| \a |NumberOBJ| |is| |left| |or| |middle| |buttoned.|  |Left| |just| |dislays| |the| |Tag| |if| |any| |in| |the| |prompt| |window.|  |Middle| |pops| |up| \a |menu| |allowing| |this| |user| |to| |do| |various|  |things.|) (and (mousestate left) (cond ((imageobjprop obj 'tag) (|with| numberobj (|fetch| objectdatum |of| obj) (tedit.promptprint stream (concat "Tag for this " (selectq use (note "Endnote") (ngroup ref.type) (error "Undefined USE code" use)) " is \"" (imageobjprop obj 'tag) "\"") t))) (t (tedit.promptprint stream "" t)))) (and (mousestate middle) (let* ((datum (|fetch| objectdatum |of| obj)) (use (|fetch| (numberobj use) |of| datum)) (ref.type (|fetch| (numberobj ref.type) |of| datum))) (and (selectq use (note (note.buttoneventinfn obj stream window)) (ngroup (ngroup.buttoneventinfn ref.type obj stream window)) (error "Undefined USE code" use)) (progn (tedit.promptprint stream "" t) 'changed)))))) (NUMBEROBJ.TEDIT-TO-TEX-FN (LAMBDA (OBJ STREAM) (PRIN3 "\\ex{" STREAM) (LET ((DATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM))) (PRIN3 (CAR DATUM) STREAM) (PRIN3 (CADR DATUM) STREAM)) (PRIN3 "}" STREAM) T)) ) (DEFINEQ (copy.ngroup.branch (lambda (ngroup.parents window) (* |fsg| "11-Aug-87 09:36") (* * |Build| |the| |NGroup| |database| |for| |the| |parents| |of| \a |copied|  |NGroup| |or| |the| |entire| |NGroup| |database| |on| \a get.) (|for| parent |in| ngroup.parents |do| (and parent (|with| numberobj parent (and (listp font) (setq font (fontcreate font))) (or ngroup.mother (setq ngroup.mother 'new.ngroup)) (create.ngroup.node ref.type ngroup.mother parent window) (create.ngroup.node ngroup.mother nil nil window) (add.ngroup.to.mother.node ref.type ngroup.mother window)))))) (dump.ngroup.graph (lambda (window) (* |fsg| " 3-Aug-87 16:03") (* * |Return| \a |list| |of| |the| |NGroup| |graph| |data| |that| |is| put  |along| |with| |the| |NGroup| |Imageobject.|  w\e |can| |then| |rebuild| |the| |entire| |NGroup| |graph| |on| \a get.) (let ((graph.list (tconc nil))) (maphash (tsp.get.ngroup.array window) (function (lambda (val key) (and (neq key 'new.ngroup) (let ((ngroup.rec (copy (car val)))) (|with| numberobj ngroup.rec (setq font (list.font.props font)) (tconc graph.list ngroup.rec))))))) (windowprop window 'dumpngroupgraph nil) (cdar graph.list)))) (ngroup.buttoneventinfn (lambda (ref.type ngroup.obj stream window) (* |fsg| " 5-Aug-87 08:31") (* * |Here| |when| |an| |inserted| |NGroup| |is| |middle| |buttoned.|) (let ((tag (imageobjprop ngroup.obj 'tag)) (graphw (windowprop window 'imageobj.menuw))) (menu (|create| menu title _ (concat ref.type " Menu") items _ (append (cond (tag ngroup.inserted.tag.items) (t ngroup.inserted.notag.items)) ngroup.inserted.menu.items) centerflg _ t))))) (ngroup.define.tag (lambda (ref.type window ngroup.obj) (* |fsg| " 5-Aug-87 09:26") (* * |Define| \a tag |for| |this| |NGroup| |or| |Change| |the| tag |if| |it|  |already| |exists.|) (let ((old.tag (imageobjprop ngroup.obj 'tag)) (new.tag (tsp.get.incode (textstream window)))) (and new.tag (neq new.tag old.tag) (progn (and old.tag (number.delete.tag window ngroup.obj)) (tsp.putcode new.tag ngroup.obj window) (imageobjprop ngroup.obj 'tag new.tag)))))) (number.delete.tag (lambda (window ngroup.obj) (* |fsg| " 5-Aug-87 09:27") (* * |Delete| |this| |Imageobj's| tag.) (tsp.putcode (imageobjprop ngroup.obj 'tag nil) nil window) nil)) (ngroup.show.tag (lambda (ref.type window ngroup.obj) (* |fsg| " 5-Aug-87 08:43") (* * |Show| |this| |NGroup's| tag.) (tedit.promptprint (textstream window) (concat ref.type ": Tag=\"" (imageobjprop ngroup.obj 'tag) "\"") t))) (change.inserted.ngroup.format (lambda (ref.type ngroup.obj stream window format.field) (* |fsg| " 1-Sep-87 15:33") (* * |Change| |an| |inserted| |NGroup's| |entire| |format| |or| \a |selected|  |field.|) (let ((graphw (windowprop window 'imageobj.menuw)) (new.format (|for| field |in| (cond (format.field (list format.field)) (t '(txtbefore display txtafter abbrevval before#txt after#txt))) |collect| (selectq field (txtbefore (change.ngroup.format.txtbefore ref.type graphw ngroup.obj)) (display (change.ngroup.format.display ref.type graphw ngroup.obj)) (txtafter (change.ngroup.format.txtafter ref.type graphw ngroup.obj)) (abbrevval (change.ngroup.format.abbrev ref.type graphw ngroup.obj)) (before#txt (change.ngroup.format.#text ref.type window ngroup.obj 'before)) (after#txt (change.ngroup.format.#text ref.type window ngroup.obj 'after)) (error "Unknown NGroup Format field" field))))) (apply 'or new.format)))) (change.ngroup.format.#text (lambda (ref.type window ngroup.obj flavor) (* |fsg| "25-Aug-87 14:48") (* * |Change| |the| |text| |before| |or| |after| |an| |inserted| |NGroup|  |regardless| |of| |the| |Text| |Before| |or| |Text| |After| |toggle|  |settings.|) (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) (let ((old.string (selectq flavor (before text.before#) text.after#)) (new.string (tedit.getinput (textstream window) (concat (selectq flavor (before "Text before ") "Text after ") ref.type ":")))) (and new.string (setq new.string (concat (selectq flavor (before "") " ") (convert.tabs.to.spaces new.string) (selectq flavor (before " ") "")))) (selectq flavor (before (setq text.before# new.string)) (setq text.after# new.string)) (not (strequal old.string new.string)))))) (show.inserted.ngroup.format (lambda (ref.type ngroup.obj stream window) (* |fsg| "26-Aug-87 12:05") (* * |Show| |the| |format| |of| |an| |inserted| |NGroup.|) (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) (|with| ngtemplate template (tedit.promptprint stream (concat ref.type ": Display=" (concat (cond (ng.text-before (concat "\"" ng.text-before "\"")) (t "\"\"")) ng.chartype (cond (ng.text-after (concat "\"" ng.text-after "\"")) (t "\"\""))) " Abbrev=" (or abbrev-val "None")) t))))) ) (* * |Variable| |and| |Record| |definitions|) (RPAQQ NGROUP.GRAPH.MENU.ITEMS `((|Change Font| (CHANGE.NGROUP.FONT LABEL GRAPHW) "Change this NGroup's entire FONT." (SUBITEMS (|Family| (CHANGE.NGROUP.FONT LABEL GRAPHW 'FAMILY) "Change this NGroup's font family.") (|Size| (CHANGE.NGROUP.FONT LABEL GRAPHW 'SIZE) "Change this NGroup's font size.") (|Face| (CHANGE.NGROUP.FONT LABEL GRAPHW 'FACE) "Change this NGroup's font face."))) (|Show Font| (SHOW.NGROUP.FONT LABEL GRAPHW) "Show this NGroup's FONT.") (|Change Format| (CHANGE.NGROUP.FORMAT LABEL GRAPHW) "Change this NGroup's entire FORMAT." (SUBITEMS (|Delimiter Before| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'TXTBEFORE) "Change the delimiter preceding this NGroup.") (|Display Type| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'DISPLAY) "Change how this NGroup is displayed.") (|Delimiter After| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'TXTAFTER) "Change the delimiter following this NGroup.") (|Abbreviate Level| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'ABBREVVAL) "Specify the starting level of this NGroup value.") (|Starting Value| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'START) "Change this NGroup's starting value.") (|Table-Of-Contents| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'TOC) "Include this NGroup in the Table-Of-Contents.") \,@ (AND (MANUALINDEX.ENABLED? (WINDOWPROP GRAPHW 'TWINDOW)) (LIST (LIST '|Manual Index| (FUNCTION (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'MANINDEX)) "Include this NGroup in the Manual Index page numbers."))))) (|Show Format| (SHOW.NGROUP.FORMAT LABEL GRAPHW) "Show this NGroup's FORMAT."))) (RPAQQ NGROUP.INSERTED.MENU.ITEMS ((|Change Font| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW NIL NGROUP.OBJ) "Change this NGroup's entire FONT." (SUBITEMS (|Family| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW 'FAMILY NGROUP.OBJ) "Change this NGroup's font family.") (|Size| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW 'SIZE NGROUP.OBJ) "Change this NGroup's font size.") (|Face| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW 'FACE NGROUP.OBJ) "Change this NGroup's font face."))) (|Show Font| (SHOW.NGROUP.FONT REF.TYPE GRAPHW NGROUP.OBJ) "Show this NGroup's FONT.") (|Change Format| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW) "Change this NGroup's entire FORMAT." (SUBITEMS (|Delimiter Before| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'TXTBEFORE) "Change the delimiter preceding this NGroup.") (|Display Type| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'DISPLAY) "Change how this NGroup is displayed.") (|Delimiter After| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'TXTAFTER) "Change the delimiter following this NGroup.") (|Abbreviate Level| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'ABBREVVAL) "Specify the starting level of this NGroup value.") (|Text Before| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'BEFORE#TXT) "Change the text preceding this NGroup.") (|Text After| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'AFTER#TXT) "Change the text following this NGroup."))) (|Show Format| (SHOW.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW) "Show this NGroup's FORMAT."))) (RPAQQ NGROUP.INSERTED.NOTAG.ITEMS ((|Define Tag| (NGROUP.DEFINE.TAG REF.TYPE WINDOW NGROUP.OBJ) "Define a TAG for this NGroup."))) (RPAQQ NGROUP.INSERTED.TAG.ITEMS ((|Change Tag| (NGROUP.DEFINE.TAG REF.TYPE WINDOW NGROUP.OBJ) "Change this NGroup's TAG.") (|Delete Tag| (NUMBER.DELETE.TAG WINDOW NGROUP.OBJ) "Delete this NGroup's TAG.") (|Show Tag| (NGROUP.SHOW.TAG REF.TYPE WINDOW NGROUP.OBJ) "Show this NGroup's TAG."))) (DECLARE\: EVAL@COMPILE (RECORD NGCOUNTER (NCOUNT . ANCESTRY)) (RECORD NGTEMPLATE (NG.CHARTYPE NG.TEXT-AFTER NG.START NG.ADDTOTOC NG.CURRENTVAL NG.MANUALINDEX NG.TEXT-BEFORE)) (RECORD NUMBEROBJ (REF.TYPE NUMSTRING USE NGROUP.MOTHER TEMPLATE UPDATED.OBJ TEXT.AFTER# PAGE.NUMBER FONT TEXT.BEFORE# ABBREV-VAL)) ) (PUTPROPS TMAX-NUMBER COPYRIGHT ("Xerox Corporation" 1987 1999 2000)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1599 17297 (NUMBEROBJ 1609 . 2715) (NUMBEROBJP 2717 . 3257) (NGROUPP 3259 . 3613) ( NUMBER.DISPLAYFN 3615 . 6654) (NUMBER.PREPRINTFN 6656 . 7700) (NUMBER.IMAGEBOXFN 7702 . 10195) ( NUMBER.PUTFN 10197 . 11281) (NUMBER.GETFN 11283 . 13419) (NUMBER.COPYFN 13421 . 15118) ( NUMBER.BUTTONEVENTINFN 15120 . 17025) (NUMBEROBJ.TEDIT-TO-TEX-FN 17027 . 17295)) (17298 26469 ( COPY.NGROUP.BRANCH 17308 . 18764) (DUMP.NGROUP.GRAPH 18766 . 19642) (NGROUP.BUTTONEVENTINFN 19644 . 20344) (NGROUP.DEFINE.TAG 20346 . 20949) (NUMBER.DELETE.TAG 20951 . 21210) (NGROUP.SHOW.TAG 21212 . 21534) (CHANGE.INSERTED.NGROUP.FORMAT 21536 . 23331) (CHANGE.NGROUP.FORMAT.#TEXT 23333 . 24919) ( SHOW.INSERTED.NGROUP.FORMAT 24921 . 26467))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-XREF b/lispusers/TMAX-XREF new file mode 100644 index 00000000..80b21664 --- /dev/null +++ b/lispusers/TMAX-XREF @@ -0,0 +1,236 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 6-May-2000 14:26:45" |{DSK}medley3.5>lispusers>TMAX-XREF.;3| 22168 |changes| |to:| (FNS XREF.TEDIT-TO-TEX-FN) |previous| |date:| " 6-May-2000 10:40:07" |{DSK}medley3.5>lispusers>TMAX-XREF.;2|) ; Copyright (c) 1987, 1997, 2000 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-XREFCOMS) (RPAQQ TMAX-XREFCOMS ( (* \;  "Developed under support from NIH grant RR-00785.") (* \;  "Written by Frank Gilmurray and Sami Shaio.") (* |;;| "An XREF is a general-purpose cross-referencing imageobject. In order to create an instance of an XREF one simply calls the function XREF with a TAG that is supposed to link it with some imageobject that it is referencing. In order to add to the class of imageobjects that can be referenced with XREF one uses the function XREF.ADD.DISPLAYFN with the type of the imageobject and a function that operates on it to return some string that XREF will then display in the document.") (* |;;;| "TMAX-XREFNIL Image Object functions") (FNS XREF XREFP XREF.DISPLAYFN XREF.IMAGEBOXFN XREF.PUTFN XREF.GETFN XREF.COPYFN XREF.BUTTONEVENTINFN XREF.WHENDELETEDFN XREF.TEDIT-TO-TEX-FN) (FNS XREF.GET.DISPLAY.TEXT XREF.GET.TOOBJ TSPOBJ.GETTYPE) (FNS UPDATE.XREFS INSERT.REF GET.REF GET.REFERENCE.BY TSP.LIST.REFS TSP.GET.INCODE TSP.GETCODEVAL TSP.PUTCODE) (* |;;;| "Functions for adding and retrieving the method for a gven imageobject.") (FNS XREF.ADD.DISPLAYFN XREF.GET.DISPLAYFN) (* |;;;| "Examples of some XREF display methods.") (FNS NGROUP.XREF.DISPLAYFN NGROUP.XREF.DISPLAY.TEXT NOTE.XREF.DISPLAYFN) (UGLYVARS XREF.DISPLAY.METHODS))) (* \; "Developed under support from NIH grant RR-00785.") (* \; "Written by Frank Gilmurray and Sami Shaio.") (* |;;| "An XREF is a general-purpose cross-referencing imageobject. In order to create an instance of an XREF one simply calls the function XREF with a TAG that is supposed to link it with some imageobject that it is referencing. In order to add to the class of imageobjects that can be referenced with XREF one uses the function XREF.ADD.DISPLAYFN with the type of the imageobject and a function that operates on it to return some string that XREF will then display in the document." ) (* |;;;| "TMAX-XREFNIL Image Object functions") (DEFINEQ (XREF (LAMBDA (TAG) (* |fsg| "23-Jul-87 13:33") (* |Returns| \a |new| XREF |imageobject.|  |The| TAG |argument| |is| |obligatory| |and| |should| |be| |the| |tag| |that|  |is| |used| |to| |reference| |the| |object| |that| |this| XREF |object| |is|  |referencing.|) (LET ((NEWOBJ (IMAGEOBJCREATE TAG \\XREFOBJ.IMAGEFNS))) (IMAGEOBJPROP NEWOBJ 'TYPE 'XREF) (IMAGEOBJPROP NEWOBJ 'TEDIT-TO-TEX-FN (FUNCTION XREF.TEDIT-TO-TEX-FN)) NEWOBJ))) (xrefp + (lambda (obj) (* |ss:| "27-Jun-87 16:39") + (* |Test| |whether| |something| |is| + |an| xref |imageobject.|) + (and (imageobjp obj) + (eq (imageobjprop obj 'type) + 'xref)))) (xref.displayfn + (lambda (obj stream) (* |fsg| "17-Sep-87 11:19") + (* * |General| |purpose| |display| |function| |for| |an| xref |imageobject.| + |Relies| |on| xref.get.display.text |to| |get| |the| |actual| |text| |that| + |must| |be| |displayed.|) + + (tmax.shadeobj obj stream) + (prin1 (xref.get.display.text obj) + stream))) (xref.imageboxfn + (lambda (obj stream) (* |ss:| "27-Jun-87 16:39") + (* |Returns| |the| |size| |of| |an| xref |imageobject| |based| |on| |the| + |string| |that| |will| |be| |used| |to| |display| |it| |which| |is| |found| + |using| xref.get.display.text.) + + (dspfont (current.display.font stream) + stream) + (|create| imagebox + xsize _ (tedit.stringwidth (xref.get.display.text obj) + stream) + ysize _ (fontprop stream 'height) + ydesc _ (fontprop stream 'descent) + xkern _ 0))) (xref.putfn + (lambda (obj stream) (* |fsg| "29-Jul-87 09:08") + (prin2 (list 'xref (|fetch| objectdatum |of| obj) + (imageobjprop obj 'reference.by)) + stream))) (xref.getfn + (lambda (stream copy.object) (* |fsg| "20-Aug-87 14:59") + (let ((window (|with| textobj textobj (car \\window)))) + (tsp.setup.fmmenu window)) + (let* ((xref.args (or copy.object (cdr (read stream)))) + (xref.obj (xref (car xref.args)))) + (imageobjprop xref.obj 'reference.by (or (cadr xref.args) + '|Value|)) + xref.obj))) (xref.copyfn + (lambda (image.obj source.stream target.stream) (* |fsg| "12-Aug-87 11:07") + (* * |Here| |to| copy |an| xref |Image| |Object.|) + + (selectq (imagestreamtype target.stream) + (text (let ((textobj (textobj target.stream))) + (apply* (imageobjprop image.obj 'getfn) + target.stream + (list (|fetch| objectdatum |of| image.obj) + (imageobjprop image.obj 'reference.by))))) + (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (XREF.BUTTONEVENTINFN (LAMBDA (XREFOBJ STREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* \; "Edited 9-Nov-97 08:09 by rmk:") (* |fsg| "29-Jul-87 16:43") (* * |Show| |what| TAG |is| |being| |referenced| |and| |how| |it| |is|  |referenced.|) (LET ((XREF.TAG (|fetch| OBJECTDATUM |of| XREFOBJ)) (XREF.DISPLAY (IMAGEOBJPROP XREFOBJ 'REFERENCE.BY))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Reference to \"" XREF.TAG "\" by " XREF.DISPLAY) T) (AND (MOUSESTATE MIDDLE) (SELECTQ (MENU (|create| MENU TITLE _ (CONCAT XREF.TAG " Menu") ITEMS _ '(|Find Definition| |Change Reference| |Change Display|) CENTERFLG _ T)) (|Find Definition| (LET ((DEF (TSP.LIST.OF.OBJECTS (TEXTOBJ HOSTSTREAM) (FUNCTION (LAMBDA (OBJ TAG) (AND (NUMBEROBJP OBJ) (EQ TAG (IMAGEOBJPROP OBJ 'TAG))))) (IMAGEOBJPROP XREFOBJ 'OBJECTDATUM)))) (IF DEF THEN (CL:WHEN (CDR DEF) (TEDIT.PROMPTPRINT STREAM "NOTE: Reference has multipled definitions!!" T)) (TEDIT.SETSEL HOSTSTREAM (CADR (CAR DEF)) 1 'RIGHT NIL T 'INVERTED) (AND NIL (TEDIT.SHOWSEL HOSTSTREAM T) (TEDIT.NORMALIZECARET HOSTSTREAM)) (RETFROM (FUNCTION TEDIT.SELECT.LINE.SCANNER) (TEDIT.GETSEL HOSTSTREAM)) ELSE (TEDIT.PROMPTPRINT STREAM "Reference has not definition!" T)) NIL)) (|Change Reference| (LET ((NEW.REFERENCE (GET.REF WINDOW STREAM))) (AND NEW.REFERENCE (PROGN (|replace| OBJECTDATUM |of| XREFOBJ |with| NEW.REFERENCE) 'CHANGED)))) (|Change Display| (PROGN (IMAGEOBJPROP XREFOBJ 'REFERENCE.BY (GET.REFERENCE.BY WINDOW T)) (TEDIT.PROMPTPRINT STREAM "" T) 'CHANGED)) NIL))))) (xref.whendeletedfn + (lambda (imobj targ.window.stream source.str targ.str) (* |fsg| "29-Jul-87 16:35") + (* * |Note| |that| |this| |function| |is| not |called| |when| \a |Reference| + |is| |deleted.| i\t |is| |called| |when| \a |NGroup| |or| |Endnote| |is| + |deleted.|) + + (tsp.putcode (imageobjprop imobj 'tag) + nil targ.window.stream) + (and (update? targ.window.stream) + (update.xrefs targ.window.stream)))) (XREF.TEDIT-TO-TEX-FN (LAMBDA (OBJ STREAM) (LET ((TOOBJ (XREF.GET.TOOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM))) DATUM) (CL:WHEN (AND (SETQ DATUM (IMAGEOBJPROP TOOBJ 'OBJECTDATUM)) TOOBJ) (PRIN3 "\\exref{" STREAM) (PRIN3 (CAR DATUM) STREAM) (PRIN3 (CADR DATUM) STREAM) (PRIN3 "}" STREAM) T)))) ) (DEFINEQ (xref.get.display.text + (lambda (obj) (* |fsg| "29-Jul-87 09:30") + (* |This| |function| |will| |first| |lookup| \a "TOOBJ" \, |in| |other| + |words,| |the| |imageobject| |that| |the| xref |object| obj |is| |referencing.| + |Then,| |if| |there| |is| |such| |an| |object,| \a |suitable| xref |display| + |method| |is| |found| |using| xref.get.displayfn. + i\f |such| \a |function| |is| |found,| |then| |it| |is| |applied| |to| toobj + |and| \a |string| |to| |be| |displayed| |is| |returned.|) + + (let ((toobj (xref.get.toobj (|fetch| objectdatum |of| obj))) + (reference.by (imageobjprop obj 'reference.by)) + specific.displayfn) + (cond + (toobj (cond + ((setq specific.displayfn (xref.get.displayfn toobj)) + (apply* specific.displayfn toobj reference.by)) + (t (ringbells) + (error "Unknown XREF display method" (tspobj.gettype toobj)) + ""))) + (t (concat "")))))) (xref.get.toobj + (lambda (tag) (* |fsg| "13-Jul-87 11:13") + (* |This| |function| |is| |called| |in| \a |specific| |context| |where| \a + |reference| |must| |be| |displayed.| i\t |is| |called| |by| |an| xref |object| + |and| |should| |return| |the| imageobject |that| |the| xref |object| |is| + |referencing.|) + + (gethash tag (windowprop (|with| textobj textobj (car \\window)) + 'tsp.code.array)))) (tspobj.gettype + (lambda (obj) (* |ss:| "27-Jun-87 16:36") + (imageobjprop obj 'type))) ) (DEFINEQ (update.xrefs + (lambda (window unupdating?) (* |fsg| "25-Sep-87 14:18") + (* * |Update| |all| |the| xref |objects| |in| |the| |window.|) + + (let ((stream (textstream window)) + (ref.list (tsp.list.of.objects (textobj window) + (function xrefp)))) + (and ref.list (let ((textobj (textobj window))) + (tedit.promptprint stream (concat (cond + (unupdating? "Undoing Update of") + (t "Updating")) + " References...") + t) + (|for| ref |in| ref.list + |do| (let ((ref.tag (|fetch| objectdatum |of| (car ref)))) + (cond + ((or unupdating? (xref.get.toobj ref.tag)) + (tedit.object.changed stream (car ref))) + (t (printout promptwindow t (concat + "Undefined Reference to \"" + ref.tag + "\", delete it or just continte?" + ) + t) + (flashwindow promptwindow) + (selectq (menu (|create| menu + title _ '|Undefined Ref| + items _ '(|Delete| |Continue|) + centerflg _ t)) + (|Delete| (tedit.delete stream (cadr ref) + 1)) + nil))))) + (tedit.promptprint stream "done")))))) (insert.ref + (lambda (stream display.prev) (* |fsg| "25-Sep-87 10:24") + (let* ((window (\\tedit.mainw stream)) + (code (get.ref window stream display.prev)) + (ref (and code (xref code)))) + (and ref (progn (imageobjprop ref 'reference.by (get.reference.by window)) + (tedit.insert.object ref stream)))))) (get.ref + (lambda (window stream display.prev) (* |fsg| " 2-Sep-87 11:24") + (* * i\f display.prev |is| |non-NIL| |then| |get| |the| |Reference| tag |from| + \a |menu.| |Else| |prompt| |the| |user| |for| |the| tag |name.|) + + (cond + (display.prev (let ((prevrefs (tsp.list.refs window))) + (cond + (prevrefs (tedit.promptprint stream "" t) + (menu (|create| menu + title _ '|Reference Tags| + items _ (sort prevrefs 'ualphorder) + menucolumns _ (fix (sqrt (length prevrefs))) + centerflg _ t))) + (t (tedit.promptprint stream "There are no References in this document." + t))))) + (t (mkatom (tedit.getinput stream "Reference to:")))))) (get.reference.by + (lambda (window ask?) (* \; "Edited 29-Sep-87 15:24 by fsg") + + (* * |Get| |the| "Reference By" |value| |from| |the| |FreeMenu.| + i\f ask? |is| t |or| |the| |FreeMenu| |value| |is| "Ask" |then| |pop| |up| \a + |menu| |to| |get| |Value| |or| |Number.|) + + (let ((reference.by (cond + (ask? '|Ask|) + (t (fm.itemprop (fm.getitem 'defaultref nil (windowprop window + 'imageobj.menuw)) + 'label))))) + (selectq reference.by + (|Ask| (or (menu (|create| menu + title _ '|Reference By| + centerflg _ t + items _ '(|Value| |Page|))) + '|Value|)) + reference.by)))) (tsp.list.refs + (lambda (window) (* |ss:| "27-Jun-87 16:36") + (* * |Used| |to| |collect| |index| |references| |here| |but| |now| |use| + index.list.refs |instead.|) + + (let ((reflist nil)) + (maphash (windowprop window 'tsp.code.array) + (function (lambda (val ky) + (setq reflist (cons ky reflist))))) + reflist))) (tsp.get.incode + (lambda (stream) (* |fsg| " 4-Aug-87 16:13") + (* * |Get| \a |new| |Tag| id |and| |make| |sure| |it's| |not| |already| + |defined.|) + + (let ((tag.id (mkatom (tedit.getinput stream "Tag name:")))) + (|while| (and tag.id (tsp.getcodeval tag.id (\\tedit.mainw stream))) + |do| (setq tag.id (mkatom (tedit.getinput stream (concat tag.id + " already exists...Tag name:")))) + ) + (or tag.id (tedit.promptprint stream "" t)) + tag.id))) (tsp.getcodeval + (lambda (code window) (* |ss:| "27-Jun-87 16:35") + (let ((tsp.code.array (windowprop window 'tsp.code.array))) + (gethash code tsp.code.array)))) (tsp.putcode + (lambda (code value window) (* |ss:| "27-Jun-87 16:36") + (puthash code value (list (windowprop window 'tsp.code.array))))) ) (* |;;;| "Functions for adding and retrieving the method for a gven imageobject.") (DEFINEQ (xref.add.displayfn + (lambda (objtype name.of.function) (* |edited:| "22-Jan-87 21:08") + (* |Adds| |an| xref |display| |method| |for| |an| |imageobject| |of| |the| + |given| |type.| |This| |means| |that| |the| |function| name.of.function |will| + |be| |used| |to| |display| |text| |when| |an| xref |object| |references| |an| + |imageobject| |of| |type| objtype.) + + (puthash objtype name.of.function xref.display.methods))) (xref.get.displayfn + (lambda (obj) (* |edited:| "22-Jan-87 21:11") + (* |Returns| |the| xref |display| + |method| |for| |an| |imageobject| obj.) + (gethash (|fetch| use |of| (|fetch| objectdatum |of| obj)) + xref.display.methods))) ) (* |;;;| "Examples of some XREF display methods.") (DEFINEQ (ngroup.xref.displayfn + (lambda (ngroup.obj reference.by) (* |fsg| "29-Jul-87 10:25") + (* * |The| xref |display| |method| |for| ngroup |objects.| + i\f |the| |NGroup| |has| |been| |updated| |and| |it| |has| \a |trailing| + |delimiter,| |the| |delimiter| |is| |stripped| |off.|) + + (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) + (cond + (updated.obj (cond + ((eq reference.by '|Page|) + (cond + (page.number (mkstring page.number)) + (t (concat "<" (ngroup.xref.display.text template numstring) + "/" reference.by ">")))) + (t (ngroup.xref.display.text template numstring)))) + (t (concat "<" ref.type "/" reference.by ">")))))) (ngroup.xref.display.text + (lambda (template numstring) (* |fsg| "29-Jul-87 10:24") + (* * |Return| |the| |display| |text| |value| |for| |an| |updated| |NGroup| + |reference.|) + + (|with| ngtemplate template (cond + (ng.text-after (substring numstring 1 (minus (add1 (nchars + ng.text-after + ))))) + (t numstring))))) (note.xref.displayfn + (lambda (note.obj reference.by) (* |fsg| "29-Jul-87 10:35") + (* * |The| xref |display| |method| |for| |Endnote| |objects.| + i\f |the| |ImageObj| |has| |not| |been| |updated| |yet,| |we| |enclose| |it| + |in| |angle| |brackets.|) + + (|with| numberobj (|fetch| objectdatum |of| note.obj) + (cond + ((and updated.obj (or (neq reference.by '|Page|) + page.number)) + (cond + ((eq reference.by '|Page|) + (mkstring page.number)) + (t (mkstring numstring)))) + (t (concat "<" numstring "/" reference.by ">")))))) ) (READVARS-FROM-STRINGS '(XREF.DISPLAY.METHODS) "({H(24 ERROR) 2 NOTE.XREF.DISPLAYFN NOTE NGROUP.XREF.DISPLAYFN NGROUP }) ") (PUTPROPS TMAX-XREF COPYRIGHT ("Xerox Corporation" 1987 1997 2000)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2764 10100 (XREF 2774 . 3341) (XREFP 3343 . 3730) (XREF.DISPLAYFN 3732 . 4166) ( XREF.IMAGEBOXFN 4168 . 4820) (XREF.PUTFN 4822 . 5068) (XREF.GETFN 5070 . 5544) (XREF.COPYFN 5546 . 6156) (XREF.BUTTONEVENTINFN 6158 . 9150) (XREF.WHENDELETEDFN 9152 . 9649) (XREF.TEDIT-TO-TEX-FN 9651 . 10098)) (10101 12085 (XREF.GET.DISPLAY.TEXT 10111 . 11395) (XREF.GET.TOOBJ 11397 . 11934) ( TSPOBJ.GETTYPE 11936 . 12083)) (12086 18460 (UPDATE.XREFS 12096 . 14479) (INSERT.REF 14481 . 14893) ( GET.REF 14895 . 15950) (GET.REFERENCE.BY 15952 . 16939) (TSP.LIST.REFS 16941 . 17393) (TSP.GET.INCODE 17395 . 18049) (TSP.GETCODEVAL 18051 . 18273) (TSP.PUTCODE 18275 . 18458)) (18552 19523 ( XREF.ADD.DISPLAYFN 18562 . 19076) (XREF.GET.DISPLAYFN 19078 . 19521)) (19583 21945 ( NGROUP.XREF.DISPLAYFN 19593 . 20553) (NGROUP.XREF.DISPLAY.TEXT 20555 . 21191) (NOTE.XREF.DISPLAYFN 21193 . 21943))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX.INDEX b/lispusers/TMAX.INDEX new file mode 100644 index 00000000..66265322 Binary files /dev/null and b/lispusers/TMAX.INDEX differ diff --git a/lispusers/TMAX.TEDIT b/lispusers/TMAX.TEDIT new file mode 100644 index 00000000..a6a43f53 Binary files /dev/null and b/lispusers/TMAX.TEDIT differ diff --git a/lispusers/TMAX.TOC b/lispusers/TMAX.TOC new file mode 100644 index 00000000..b605c055 Binary files /dev/null and b/lispusers/TMAX.TOC differ diff --git a/lispusers/TMENU.TEDIT b/lispusers/TMENU.TEDIT new file mode 100644 index 00000000..be8f57b0 Binary files /dev/null and b/lispusers/TMENU.TEDIT differ diff --git a/lispusers/TRAJECTORY-FOLLOWER b/lispusers/TRAJECTORY-FOLLOWER new file mode 100644 index 00000000..3e8225fb --- /dev/null +++ b/lispusers/TRAJECTORY-FOLLOWER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 4-Apr-88 11:51:42" {ERINYES}MEDLEY>TRAJECTORY-FOLLOWER.;1 9967 changes to%: (FNS TRAJECTORY.FOLLOW TRAJECTORY.FOLLOWER.POINT TRAJECTORY.FOLLOWER.PUT TRAJECTORY.FOLLOWER.SETUP TRAJECTORY.FOLLOWER.TEST TRAJECTORY.FOLLOWER.WRAPUP) (VARS TRAJECTORY-FOLLOWERCOMS) previous date%: " 4-Apr-88 11:43:37" {CORE}TRAJECTORY-FOLLOWER.;2) (* " Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TRAJECTORY-FOLLOWERCOMS) (RPAQQ TRAJECTORY-FOLLOWERCOMS ((FNS TRAJECTORY.FOLLOW TRAJECTORY.FOLLOWER.POINT TRAJECTORY.FOLLOWER.PUT TRAJECTORY.FOLLOWER.SETUP TRAJECTORY.FOLLOWER.TEST TRAJECTORY.FOLLOWER.WRAPUP) (VARS (TRAJECTORY.FOLLOWER.POINTS)) (GLOBALVARS TRAJECTORY.FOLLOWER.COUNT TRAJECTORY.FOLLOWER.LAST.TIME TRAJECTORY.FOLLOWER.POINTER TRAJECTORY.FOLLOWER.POINTS TRAJECTORY.FOLLOWER.DELAY TRAJECTORY.FOLLOWER.DSP TRAJECTORY.FOLLOWER.BITMAP TRAJECTORY.FOLLOWER.HALF.WIDTH TRAJECTORY.FOLLOWER.HALF.HEIGHT TRAJECTORY.FOLLOWER.WIDTH TRAJECTORY.FOLLOWER.HEIGHT) (BITMAPS TRAJECTORY.FOLLOWER.DEFAULT.BITMAP TRAJECTORY.FOLLOWER.BALL TRAJECTORY.FOLLOWER.HORIZONTAL TRAJECTORY.FOLLOWER.VERTICAL) (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) READNUMBER))) (DEFINEQ (TRAJECTORY.FOLLOW [LAMBDA (KNOTS CLOSED N DELAY BITMAP WINDOW) (* ;  "Edited 4-Apr-88 11:51 by Briggs") (* ;  "Edited 22-Apr-83 17:56 by DAHJr ") (PROG NIL (TRAJECTORY.FOLLOWER.SETUP (OR WINDOW (SCREENBITMAP)) N DELAY (OR BITMAP TRAJECTORY.FOLLOWER.BALL)) (DRAWCURVE KNOTS CLOSED (FUNCTION TRAJECTORY.FOLLOWER.POINT) NIL (OR WINDOW PROMPTWINDOW)) (TRAJECTORY.FOLLOWER.WRAPUP]) (TRAJECTORY.FOLLOWER.POINT [LAMBDA (X Y WINDOW) (* ;  "Edited 4-Apr-88 11:52 by Briggs") (* ; "Edited 19-APR-83 21:06 by DAHJr") (if (IGREATERP (SETQ TRAJECTORY.FOLLOWER.POINTER (IPLUS TRAJECTORY.FOLLOWER.POINTER 2)) TRAJECTORY.FOLLOWER.COUNT) then (SETQ TRAJECTORY.FOLLOWER.POINTER 1)) (TRAJECTORY.FOLLOWER.PUT TRAJECTORY.FOLLOWER.POINTER) (if TRAJECTORY.FOLLOWER.DELAY then (DISMISS (IDIFFERENCE TRAJECTORY.FOLLOWER.DELAY (CLOCKDIFFERENCE TRAJECTORY.FOLLOWER.LAST.TIME ))) (SETQ TRAJECTORY.FOLLOWER.LAST.TIME (CLOCK 0))) (if X then (SETA TRAJECTORY.FOLLOWER.POINTS TRAJECTORY.FOLLOWER.POINTER (FIXR X)) (SETA TRAJECTORY.FOLLOWER.POINTS (ADD1 TRAJECTORY.FOLLOWER.POINTER) (FIXR Y)) (TRAJECTORY.FOLLOWER.PUT TRAJECTORY.FOLLOWER.POINTER) else (SETA TRAJECTORY.FOLLOWER.POINTS TRAJECTORY.FOLLOWER.POINTER MAX.FIXP]) (TRAJECTORY.FOLLOWER.PUT [LAMBDA (POINTER) (* ;  "Edited 4-Apr-88 11:53 by Briggs") (* ; "Edited 19-APR-83 20:57 by DAHJr") (PROG (X Y) (if (NOT (IEQP (SETQ X (ELT TRAJECTORY.FOLLOWER.POINTS POINTER)) MAX.FIXP)) then (SETQ Y (ELT TRAJECTORY.FOLLOWER.POINTS (ADD1 POINTER))) (BITBLT TRAJECTORY.FOLLOWER.BITMAP 0 0 TRAJECTORY.FOLLOWER.DSP (IDIFFERENCE X TRAJECTORY.FOLLOWER.HALF.WIDTH ) (IDIFFERENCE Y TRAJECTORY.FOLLOWER.HALF.HEIGHT) TRAJECTORY.FOLLOWER.WIDTH TRAJECTORY.FOLLOWER.HEIGHT 'INPUT 'INVERT]) (TRAJECTORY.FOLLOWER.SETUP [LAMBDA (DSP N DELAY BITMAP) (* ;  "Edited 4-Apr-88 11:54 by Briggs") (* ; "Edited 19-APR-83 21:05 by DAHJr") (PROG ((REAL.N (OR N 100)) (REAL.BITMAP (OR BITMAP TRAJECTORY.FOLLOWER.DEFAULT.BITMAP))) (if (AND TRAJECTORY.FOLLOWER.POINTS (EQ (ITIMES REAL.N 2) (ARRAYSIZE TRAJECTORY.FOLLOWER.POINTS))) else (SETQ TRAJECTORY.FOLLOWER.POINTS (ARRAY (ITIMES REAL.N 2) 'FIXP MAX.FIXP))) (SETQ TRAJECTORY.FOLLOWER.POINTER 1) (SETQ TRAJECTORY.FOLLOWER.COUNT REAL.N) (SETQ TRAJECTORY.FOLLOWER.DSP DSP) (SETQ TRAJECTORY.FOLLOWER.DELAY DELAY) (if DELAY then (SETQ TRAJECTORY.FOLLOWER.LAST.TIME (CLOCK 0))) (SETQ TRAJECTORY.FOLLOWER.BITMAP REAL.BITMAP) (SETQ TRAJECTORY.FOLLOWER.WIDTH (fetch (BITMAP BITMAPWIDTH) of REAL.BITMAP)) (SETQ TRAJECTORY.FOLLOWER.HEIGHT (fetch (BITMAP BITMAPHEIGHT) of REAL.BITMAP)) (SETQ TRAJECTORY.FOLLOWER.HALF.WIDTH (IQUOTIENT TRAJECTORY.FOLLOWER.WIDTH 2)) (SETQ TRAJECTORY.FOLLOWER.HALF.HEIGHT (IQUOTIENT TRAJECTORY.FOLLOWER.HEIGHT 2]) (TRAJECTORY.FOLLOWER.TEST [LAMBDA NIL (* ;  "Edited 4-Apr-88 11:42 by Briggs") (* ; "Edited 22-APR-83 16:17 by DAHJr") (PROG (KNOTS N DELAY CLOSED BITMAP) (printout PROMPTWINDOW "Indicate knots on a trajectory; hold down left shift key on last point") [SETQ KNOTS (CONS (GETPOSITION) (collect (GETPOSITION) repeatuntil (KEYDOWNP 'LSHIFT] (SETQ N (RNUMBER "Indicate the number of points in the follower")) (SETQ DELAY (MAX 0 (RNUMBER "Indicate the delay per point (milliseconds)"))) (if (ZEROP DELAY) then (SETQ DELAY NIL)) [SETQ CLOSED (MENU (create MENU ITEMS _ '(OPEN CLOSED] [SETQ BITMAP (MENU (create MENU ITEMS _ '(("A single point" NIL) ("A horizontal line" TRAJECTORY.FOLLOWER.HORIZONTAL) ("A vertical line" TRAJECTORY.FOLLOWER.VERTICAL) ("A ball" TRAJECTORY.FOLLOWER.BALL] (TRAJECTORY.FOLLOWER.SETUP (SCREENBITMAP) N DELAY BITMAP) (if (EQ CLOSED 'CLOSED) then (until (KEYDOWNP 'LSHIFT) do (DRAWCURVE KNOTS T (FUNCTION TRAJECTORY.FOLLOWER.POINT ) NIL PROMPTWINDOW)) else (DRAWCURVE KNOTS NIL (FUNCTION TRAJECTORY.FOLLOWER.POINT) NIL PROMPTWINDOW)) (TRAJECTORY.FOLLOWER.WRAPUP]) (TRAJECTORY.FOLLOWER.WRAPUP [LAMBDA NIL (* ;  "Edited 4-Apr-88 11:42 by Briggs") (* ; "Edited 19-APR-83 17:29 by DAHJr") (for I to TRAJECTORY.FOLLOWER.COUNT do (TRAJECTORY.FOLLOWER.POINT]) ) (RPAQQ TRAJECTORY.FOLLOWER.POINTS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TRAJECTORY.FOLLOWER.COUNT TRAJECTORY.FOLLOWER.LAST.TIME TRAJECTORY.FOLLOWER.POINTER TRAJECTORY.FOLLOWER.POINTS TRAJECTORY.FOLLOWER.DELAY TRAJECTORY.FOLLOWER.DSP TRAJECTORY.FOLLOWER.BITMAP TRAJECTORY.FOLLOWER.HALF.WIDTH TRAJECTORY.FOLLOWER.HALF.HEIGHT TRAJECTORY.FOLLOWER.WIDTH TRAJECTORY.FOLLOWER.HEIGHT) ) (RPAQQ TRAJECTORY.FOLLOWER.DEFAULT.BITMAP #*(1 1)H@@@) (RPAQQ TRAJECTORY.FOLLOWER.BALL #*(21 21)@AOL@@@@@COO@@@@@OOOH@@@AOOOL@@@COOON@@@GOOOO@@@GOOOO@@@GOOOOH@@OOOOOH@@OOOOOH@@OOOOOH@@OOOOOH@@GOOOOH@@GOOOO@@@GOOOO@@@COOON@@@COOON@@@AOOOL@@@@OOOH@@@@GOO@@@@@AOL@@@@ ) (RPAQQ TRAJECTORY.FOLLOWER.HORIZONTAL #*(18 1)OOOOL@@@) (RPAQQ TRAJECTORY.FOLLOWER.VERTICAL #*(1 16)H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@H@@@) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) READNUMBER) (PUTPROPS TRAJECTORY-FOLLOWER COPYRIGHT ("Xerox Corporation" 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1992 8891 (TRAJECTORY.FOLLOW 2002 . 2689) (TRAJECTORY.FOLLOWER.POINT 2691 . 3989) ( TRAJECTORY.FOLLOWER.PUT 3991 . 5052) (TRAJECTORY.FOLLOWER.SETUP 5054 . 6500) (TRAJECTORY.FOLLOWER.TEST 6502 . 8493) (TRAJECTORY.FOLLOWER.WRAPUP 8495 . 8889))))) STOP \ No newline at end of file diff --git a/lispusers/TRAJECTORY-FOLLOWER.TEDIT b/lispusers/TRAJECTORY-FOLLOWER.TEDIT new file mode 100644 index 00000000..10fde8a4 Binary files /dev/null and b/lispusers/TRAJECTORY-FOLLOWER.TEDIT differ diff --git a/lispusers/TRANSOR b/lispusers/TRANSOR new file mode 100644 index 00000000..2f9ea07c --- /dev/null +++ b/lispusers/TRANSOR @@ -0,0 +1,985 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") +(FILECREATED "17-Mar-87 17:03:54" {DSK}TRANSOR.;16 44778 + + changes to%: (VARS TRANSORCOMS) + (FNS PRECH1 TRANSOUT) + + previous date%: "17-Mar-87 17:00:04" {DSK}TRANSOR.;15) + + +(PRETTYCOMPRINT TRANSORCOMS) + +(RPAQQ TRANSORCOMS + ((FNS TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM TRANSIT TRANXT TRANSEXIT + KEEPLIST TRANSERR TRANSOUT PPASS1 TRANSLIST TRANSLIST1 PREMTEXT WACHADOON PRECH PRECH1 + PRECH2 RETAIL LNC PRESCAN) + TRANSORMACROS TRANSOREMARKS TRANSORGLOBALS + (VARS (MAXLOOP 1530) + (TESTRAN) + (USERMACROS (APPEND TRANSORMACROS USERMACROS)) + (GLOBALVARS (APPEND TRANSORGLOBALS GLOBALVARS)) + (EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) EDITCOMSA)) + (EDITCOMSL (UNION '(REMARK) EDITCOMSL)) + (TRANSITCONSES '(ORR NIL XFORMER)) + (PRESCARRAY (ARRAY 127 127))) + (INITVARS (NLISTPCOMS) + (LAMBDACOMS) + (TRANSOUTREADTABLE FILERDTBL)) + (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY (PROP BLKLIBRARYDEF TAILP)) + (PROP FILEGROUP TRANSOR) + (BLOCKS (PRECHBLOCK PRECH PRECH1 PRECH2 RETAIL LNC (ENTRIES PRECH) + (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) + (TRANSITBLOCK TRANSIT WACHADOON (ENTRIES TRANSIT WACHADOON) + (GLOBALVARS WACHADID WHENTODOIT TRANSITCONSES LAMBDACOMS NLISTPCOMS) + (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) + (TRANXTBLOCK TRANXT (ENTRIES TRANXT) + (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) + (NIL PRESCAN (GLOBALVARS PRESCARRAY))) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML TRANSERR KEEPLIST + TRANSOR-PROCEED) + (LAMA))) + (EDITHIST TRANSOR))) +(DEFINEQ + +(TRANSOR + (LAMBDA (SOURCEFILE) (* ; "Edited 6-Mar-87 14:36 by DJVB") + (RESETFORM (SETREADTABLE FILERDTBL) + (PROG (INPUTFILE OUTPUTFILE LISTFILE LISTING NAMEFIELD EXPRESSION TMP) + (DECLARE%: (SPECVARS LISTFILE LISTING)) + (COND + ((NLISTP TRANSFORMATIONS) + (ERROR '"No transformations loaded." '"" T)) + ((NULL (SETQ INPUTFILE (INFILEP SOURCEFILE))) + (ERROR '"Cannot find file:" SOURCEFILE T))) + (SETQ NAMEFIELD (FILENAMEFIELD INPUTFILE 'NAME)) + (COND + ((NULL (SETQ OUTPUTFILE (OPENSTREAM (SETQ TMP (PACKFILENAME 'NAME NAMEFIELD + 'EXTENSION "TRAN")) + 'OUTPUT))) + (ERROR '"Cannot open file:" TMP T)) + ((NULL (SETQ LISTFILE (OPENSTREAM (SETQ TMP (PACKFILENAME 'NAME NAMEFIELD + 'EXTENSION + '"LSTRAN")) + 'OUTPUT))) + (ERROR '"Cannot open file." TMP T))) + + (* All the preliminary error checks ok. Open files, print headers.) + + (SETQ INPUTFILE (OPENSTREAM INPUTFILE 'INPUT)) + (PRIN1 '"(PRIN1(QUOTE %" +Transoring of" OUTPUTFILE) + (PRINT (FULLNAME INPUTFILE) + OUTPUTFILE) + (PRIN1 '" done on " OUTPUTFILE) + (PRIN1 (DATE) + OUTPUTFILE) + (PRIN1 '" %")T)" OUTPUTFILE) + (TERPRI OUTPUTFILE) + (TERPRI OUTPUTFILE) + (PRIN1 '" Listing from TRANSORing of file " LISTFILE) + (PRINT (FULLNAME INPUTFILE) + LISTFILE) + (PRIN1 '" done on " LISTFILE) + (PRIN1 (DATE) + LISTFILE) + (TERPRI LISTFILE) + (TERPRI LISTFILE) + LP (COND + ((NULL (NLSETQ (PROG NIL + + (* Rebind HELPCLOCK so that when over-read EOF no error message or BREAK will + occur.) + + (SETQ EXPRESSION (READ INPUTFILE))))) + (GO DONE))) + (SELECTQ EXPRESSION + (STOP + + (* Only check for STOP, no check for NIL. + Foreign files never have STOPs on them and rarely have extra parens or NIL's. + Extra NIL's on a file usually indicate that the reading machinery is screwed + up, probably because user forgot to perform + (ESCAPE)%, or, even worse, there is a different ESCAPE character. + I therefore must ERRORSET protect the READ above anyway, and try to keep + reading until can read no further.) + + (GO DONE)) + (COND + ((NLISTP EXPRESSION) + (TRANSERR NIL "NLISTP expression on file - expression discarded:" ( + EXPRESSION + )) + (GO LP)))) + (SETQ EXPRESSION (TRANSFORM EXPRESSION)) + (TRANSOUT EXPRESSION OUTPUTFILE) + (GO LP) + DONE + (AND (OPENP INPUTFILE) + (CLOSEF INPUTFILE)) + (ENDFILE OUTPUTFILE) + (TRANSLIST LISTING LISTFILE) + (CLOSEF LISTFILE) + (RETURN (LIST (FULLNAME OUTPUTFILE) + (FULLNAME LISTFILE))))))) + +(TRANSOR-PROCEED + (NLAMBDA (FLG) (* ; "Edited 6-Mar-87 14:37 by DJVB") + (PROG ((L L) + STOPPEDUP WHERETOGONEXT CONTINUEL CONTINUETAIL TRANSITL TRANSITAIL OLDLENGTH) + (DECLARE%: (SPECVARS L STOPPEDUP WHERETOGONEXT CONTINUEL CONTINUETAIL TRANSITL TRANSITAIL + OLDLENGTH)) + LP (COND + ((ERSETQ + (SETQ L + (EDITL L (SELECTQ FLG + (DOTHIS '((IF (TAILP (CAR L) + (CADR L)) + ((REMARK TAILP/DOTHIS) + 1) + NIL) + MARK + (ORR (NX UP (E (PROG (LISPXHIST) + (SETQ STOPPEDUP (%##))) + T)) + (!NX UP (E (PROG (LISPXHIST) + (SETQ STOPPEDUP (%##))) + T)) + NIL) + __ + (LPQ (COMS (TRANSIT) + (TRANXT))))) + (DOTHESE '(MARK (ORR ((IF (NOT (TAILP (CAR L) + (CADR L)))) + NX UP (E (PROG (LISPXHIST) + (SETQ STOPPEDUP (%##))) + T)) + (!NX UP (E (PROG (LISPXHIST) + (SETQ STOPPEDUP (%##))) + T)) + NIL) + __ 1 (LPQ (COMS (TRANSIT) + (TRANXT))))) + (TRANSFORM '((LPQ (COMS (TRANSIT) + (TRANXT))))) + (OKCOMS '((LPQ (COMS (TRANXT) + (TRANSIT))))) + (HELP))))) + (SETQ FLG 'OKCOMS) + (GO LP)) + (T (TRANSERR TRANSERROR "Fail return to TRANSOR from EDITOR. Show Jim Goodwin." + (CURRENTFORM CURRENTCOMS))))))) + +(TRANSORFORM + (LAMBDA (FORM) (* ; "Edited 6-Mar-87 14:36 by DJVB") + (PROG (LISTFILE LISTING) + (DECLARE%: (SPECVARS LISTFILE LISTING)) + (SETQ FORM (TRANSFORM FORM)) + (AND LISTING (ERSETQ (TRANSLIST LISTING))) + + (* ERRORSET so user can abort with ^E, especially when used in TXTEST.) + + (RETURN FORM)))) + +(TRANSORFNS + (LAMBDA (FNLIST) (* ; "Edited 6-Mar-87 14:36 by DJVB") + (PROG (LISTING LISTFILE DEF) + (DECLARE%: (SPECVARS LISTING LISTFILE)) + (MAPC FNLIST (FUNCTION (LAMBDA (FN) + (COND + ((AND (LITATOM FN) + (EXPRP (SETQ DEF (VIRGINFN FN)))) + (TRANSFORM DEF FN)) + (T (PRINT (CONS FN '(NOT FOUND)) + T T)))))) + (ERSETQ (TRANSLIST LISTING)) + (RETURN FNLIST)))) + +(TRANSFORM + (LAMBDA (SOURCEXPR FNAME) (* ; "Edited 6-Mar-87 14:37 by DJVB") + + (* TRANSFORM is the entry to the translator. + It returns the translated SOURCEXPR, and resets LISTING and uses LISTFILE + freely (see KEEPLIST)%. - + The source expression is embedded one level so that top-level embeds will work + (i.e. the case where the source expression is + (FOO --) and the transformation for FOO is MBD)%. + - + FNAME is provided only by TRANSORFNS. Thus if not provided, SOURCEXPR is a FORM + from TRANSORFORM or TRANSOR's file, and we begin translation at SOURCEXPR, but + if FNAME is given, SOURCEXPR is a LAMBDA expression and we do a 3 command + first, to get to a FORM. - + RETAIL also checks this top-level expression. + If the top level is (NIL &) it is of no interest to user. + But if FNAME was given, top level is (FNAME &) and should be printed, otherwise + user will see only a LAMBDA expression and not know where it came from.) + + (PROG (L PASS1 HELPCLOCK) + (DECLARE%: (SPECVARS L PASS1)) + (COND + (FNAME (SETQ L (LIST (CADDR SOURCEXPR) + SOURCEXPR + (LIST FNAME SOURCEXPR)))) + (T (SETQ L (LIST SOURCEXPR (LIST NIL SOURCEXPR))))) + (WACHADOON T) + (TRANSOR-PROCEED TRANSFORM) + (MAPC (DREVERSE PASS1) + (FUNCTION PPASS1)) + (RETURN (COND + (FNAME (CADR L)) + (T (CAR L))))))) + +(TRANSIT + (LAMBDA NIL (* DJVB " 3-Feb-87 13:21") + (PROG ((HERE (CAR L)) + TMP) + (WACHADOON) + (COND + ((TAILP HERE (CADR L)) + (TRANSERR TRANSERROR "The function TRANSIT reached a TAILP position; show Jim Goodwin." + (CURRENTFORM CURRENTCOMS)) + (SETQ L (CONS (SETQ HERE (CAR HERE)) + (CDR L))))) + (SETQ CURRENTFORM HERE) + (SETQ CONTINUEL) + (SETQ WHERETOGONEXT '(ORR 2 NX !NX ((E (TRANSEXIT))))) + + (* The call to TRANSEXIT above causes the exits from PROCEED which occur + because of dropoff.) + + (SETQ OLDLENGTH (LENGTH (CADR L))) + (SETQ TRANSITL L) + (COND + ((AND LASTAIL (EQ (CAR LASTAIL) + HERE)) + (SETQ TRANSITAIL LASTAIL)) + ((OR (NULL (SETQ TRANSITAIL (MEMB HERE (CADR L)))) + (MEMB HERE (CDR TRANSITAIL))) + (HELP '"The editor lost LASTAIL, and with it its sense of direction." ' + "Show Jim Goodwin."))) + (SETQ CURRENTCOMS (COND + ((AND STOPPEDUP (EQ HERE (CAR STOPPEDUP)) + (OR (LISTP HERE) + (EQ STOPPEDUP (%## UP)))) + (* Exit on match with STOPPEDUP.) + (RETFROM 'TRANSOR-PROCEED)) + ((NLISTP HERE) + NLISTPCOMS) + ((LITATOM (CAR HERE)) + + (* If user commands cause an error it will be trapped by the ORR and XFORMER + will be executed. XFORMER is a TRANSORMACRO which makes a remark on the error. + Don't make the list if no commands.) + + (GETP (CAR HERE) + 'XFORM)) + ((LISTP (CAR HERE)) + LAMBDACOMS) + (T '((COMSQ (REMARK ILLCAR) + DOTHESE))))) + (RETURN (COND + (CURRENTCOMS (FRPLACA (CDR TRANSITCONSES) + CURRENTCOMS) + + (* If CURRENTCOMS is NIL, return NIL; otherwise effectively embed CURRENTCOMS + in orr such that if CURRENTCOMS fail, xformer will be executed. + Xformer is a transormacro which calls TRANSERR appropriately for a faulty + transformation.) + + TRANSITCONSES)))))) + +(TRANXT + (LAMBDA NIL + (PROG (NEWFORM NEWLENGTH TMP NEWTAIL) + (COND + (CONTINUEL (SETQ L CONTINUEL) + (SETQ LASTAIL CONTINUETAIL) + (RETURN))) + (SETQ NEWFORM (CAR TRANSITAIL)) + (SETQ NEWLENGTH (LENGTH (CADR TRANSITL))) + (COND + ((NEQ NEWLENGTH OLDLENGTH) + (GO DELETED)) + ((OR (EQ NEWFORM CURRENTFORM) + (EQ WHERETOGONEXT 'NLAMIT)) + + (* If containing list still points at same EQ structure, or if he's declared + he's done with whatever is there, no problem.) + + ) + ((AND (LISTP NEWFORM) + (EDITFINDP NEWFORM (SETQ TMP (CONS '== CURRENTFORM)) + T)) + + (* Net effect was an MBD. If we went on from here in normal fashion, we would + embed it again and again. Find original expression and go on from there.) + + (SETQ WHERETOGONEXT (CONS TMP WHERETOGONEXT))) + ((AND (LISTP CURRENTFORM) + (EDITFINDP CURRENTFORM (CONS '== NEWFORM) + T)) + + (* Net effect was XTR. If we went on normally, we'd miss the form extracted. + Set continuation commands to NIL so we stay where we are) + + (SETQ WHERETOGONEXT)) + (T + + (* User did a %: or DELETE where effect was + (%: NIL)%. Assume the stuff he put in place of old does not need translation. + perform NLAM for him.) + + (SETQQ WHERETOGONEXT NLAM))) + + (* Ready to return. Fix up L, smashing CAR to point to right thing. + In normal case, (EQ CURRENTFORM NEWFORM)%, it already does and this FRPLACA is + a NOP.) + + ZIPPO + (SETQ L (FRPLACA TRANSITL NEWFORM)) + (SETQ LASTAIL TRANSITAIL) + + (* Finally, return the commands which will locate the next form to translate.) + + (RETURN WHERETOGONEXT) + DELETED + (COND + ((NEQ (SUB1 OLDLENGTH) + NEWLENGTH) + + (* This could happen if user cheated by doing a !0 and deleting several things + or inserting things.) + + (TRANSERR OUTOFBOUNDS + "Your transformations cheated and changed something out of bounds." (CURRENTFORM + CURRENTCOMS + ))) + ((NOT (TAILP TRANSITAIL (CADR L))) + + (* User deleted the form, but it was the last form on its containing list.) + + (RETURN '(ORR !NX ((E (TRANSEXIT)))))) + (T + + (* User deleted the form, but was not last thing, thus NEWFORM is already bound + to the NX thing after the one we just %'translated' by deleting it. + Set WHERETOGONEXT to NIL so we do not move at all.) + + (SETQ WHERETOGONEXT) + (GO ZIPPO)))))) + +(TRANSEXIT + (LAMBDA NIL (* DJVB " 3-Feb-87 13:22") + (COND + (STOPPEDUP (TRANSERR TRANSERROR "The function TRANSEXIT missed the exit. Show Jim Goodwin." + (CURRENTFORM CURRENTCOMS)))) + (RETFROM 'TRANSOR-PROCEED))) + +(KEEPLIST + (NLAMBDA (REMNAME) + (PROG (TMP) + (COND + ((NLISTP LISTING) (* Initialize if first remark in this + LISTING.) + (SETQ LISTING (LIST 1))) + (T (FRPLACA LISTING (ADD1 (CAR LISTING))))) + (SETQ PASS1 (CONS (CONS (CAR LISTING) + (CONS REMNAME L)) + PASS1)) (* Save pass2 stuff for TRANSLIST.) + (COND + (TESTRAN (* Skip pass2 if testing) + NIL) + ((NULL (SETQ TMP (FASSOC REMNAME (CDR LISTING)))) + (* First use of this remark.) + (NCONC1 LISTING (LIST REMNAME (CAR LISTING)))) + (T (NCONC1 TMP (CAR LISTING)))) + (RETURN)))) + +(TRANSERR + (NLAMBDA (REM MESS VARS) + (AND REM (APPLY (FUNCTION KEEPLIST) + (LIST REM))) + (AND MESS (NLSETQ (PROGN (TERPRI T) + (TERPRI T) + (PRIN1 '" +TRANSOR made a translation error: " T) + (PRIN1 MESS T) + (TERPRI T)))) + (AND VARS (NLSETQ (PROGN (PRINTLEVEL 3) + (MAPC VARS (FUNCTION (LAMBDA (X) + (PRIN2 X T T) + (PRIN1 '": " T) + (PRINT (EVALV X))))) + (PRINTLEVEL 1000) + (TERPRI T)))))) + +(TRANSOUT + [LAMBDA (XPR FILE) (* ; "Edited 17-Mar-87 16:37 by DJVB") + (RESETFORM (OUTPUT FILE) + (RESETFORM (SETREADTABLE TRANSOUTREADTABLE) + + (* XPR is a transored form which is to be put on the output file.) + + (COND + ((EQ FILE 'NIL%:)) + ((EQ 'DEFINEQ (CAR XPR)) (* Special formatting for function + lists.) + (PRIN1 '"(DEFINEQ") + (TERPRI) + [MAPC (CDR XPR) + (FUNCTION (LAMBDA (X) + (TERPRI) + (PRIN1 '%() + (PRINT (CAR X)) + (PRINTDEF (CADR X) + NIL T) + (PRIN1 '%)) + (TERPRI] + (PRIN1 '%)) + (TERPRI)) + [(AND (EQ 'PROGN (CAR XPR)) + (EQ 'DEFUN (CAADR XPR))) (* Special formatting for commonlisp + function lists.) + (MAPC (CDR XPR) + (FUNCTION (LAMBDA (X) + (TERPRI) + (COND + ((EQ (CAR X) + 'DEFUN) + (PRIN1 "(DEFUN ") + (AND LAMBDAFONT FONTCHANGEFLG (CHANGEFONT LAMBDAFONT)) + (PRIN2 (CADR X)) + (AND LAMBDAFONT FONTCHANGEFLG (CHANGEFONT DEFAULTFONT)) + (PRIN2 (CADDR X)) + (PRINTDEF (CDDDR X) + 6 T T) + (PRIN1 ")")) + (T (PRINTDEF XPR))) + (TERPRI] + (T (TERPRI) + (PRINTDEF XPR) + (TERPRI]) + +(PPASS1 + (LAMBDA (P1) + (PRIN1 (CAR P1) + LISTFILE) + (PRIN1 '". " LISTFILE) + (PRIN1 (CADR P1) + LISTFILE) + (PRIN1 '" at " LISTFILE) + (PRECH (CDDR P1) + NIL LISTFILE T) + (TERPRI LISTFILE))) + +(TRANSLIST + (LAMBDA (LISTING LISTFILE) + + (* TRANSLIST must dump the second half of the listing prettily.) + + (PROG (OLDO) + (COND + (TESTRAN (* See TXTEST.) + (RETURN)) + ((EQ LISTFILE 'NIL%:) + (RETURN))) + (SETQ OLDO (OUTPUT LISTFILE)) (* See KEEPLIST for discussion of + format of LISTING.) + (COND + ((NULL LISTING) + + (* User would like to know if this happens rather than just wondering where his + output went.) + + (PRIN1 '" + No REMARKS -- empty listing. +")) + (T (PRIN1 '" Index of Remarks + + + + + +") + (MAPC (SORT (CDR LISTING) + T) + (FUNCTION TRANSLIST1)))) + (TERPRI) + (OUTPUT OLDO) + (RETURN)))) + +(TRANSLIST1 + (LAMBDA (L1) + (PRIN1 (CAR L1)) (* Name of remark.) + (PRIN1 '" at ") + (MAPRINT (CDR L1) + NIL NIL '". +" '", ") + (PREMTEXT (CAR L1)) + (TERPRI))) + +(PREMTEXT + (LAMBDA (RNAM) + (PROG (TXT) + (COND + ((OR (SETQ TXT (ASSOC RNAM USERNOTES)) + (SETQ TXT (ASSOC RNAM TRANSOREMARKS))) + (SETQ TXT (CADR TXT))) + (T (SETQQ TXT + + (* The text of this remark was not defined in the TRANSFORMATIONS file.) +))) + (SPACES 5) + (COND + ((EQ (CADR TXT) + '%%) + + (* Lower-case the comment before using it, if he is testing and it hasn't been + dumped before.) + + (RPLACD TXT (COMMENT3 (CDDR TXT) + NIL T)))) + (MAPRINT (CDR TXT)) + (TERPRI)))) + +(WACHADOON + (LAMBDA (FLG) + (OR TESTRAN (PROG ((NOW (CLOCK))) + (COND + (FLG (SETQ WACHADID) + (SETQ WHENTODOIT NOW) + (RETURN)) + ((ILESSP NOW WHENTODOIT) + (RETURN))) + (PRECH L WACHADID T) + (SETQ WACHADID L) + (SETQ WHENTODOIT (IPLUS 180000 NOW)))))) + +(PRECH + (LAMBDA (ECH OLDECH FILE PRTYFLG) + + (* Function to Print a Reversed Edit CHain in my special format.) + + (PROG ((OLDO (OUTPUT FILE)) + X) + (SETQ X (PRECH1 (RETAIL (COND + (OLDECH (LNC ECH OLDECH)) + (T ECH))))) + (COND + (PRTYFLG (PRINTDEF X)) + (T (PRINT X))) + (TERPRI) + (OUTPUT OLDO) + (RETURN)))) + +(PRECH1 + [LAMBDA (RECH) (* ; "Edited 17-Mar-87 14:24 by DJVB") + (PROG (LASTALE (N -2) + LST) + [COND + ((NULL (CDR RECH)) + (RETURN (MKSTRING (PRECH2 (CAR RECH) + 4] + [SETQ LASTALE (SOME (CAR RECH) + (FUNCTION (LAMBDA (E) + (ADD1VAR N) + (EQ E (CADR RECH] + (AND (MINUSP N) + (GO OUT)) + (SETQ LST (CONS (COND + ((NLISTP (CAAR RECH)) + (CAAR RECH)) + (T (PRECH2 (CAAR RECH) + 3))) + LST)) + [SELECTQ N + (0) + (1 (SETQ LST (CONS (COND + ((NLISTP (CADAR RECH)) + (CADAR RECH)) + (T '&)) + LST))) + (COND + [(AND (EQ 'DEFUN (CAAR RECH)) + (LITATOM (CADAR RECH))) (* DJVB put in for TO-COMMONLISP to + identify DEFUNs) + (SETQ LST (CONS [COND + [(EQ N 2) + (COND + ((NLISTP (CADDAR RECH)) + (CADDAR RECH)) + (T '&] + (T (PACK* '|...| (SUB1 N) + '|...|] + (CONS (CADAR RECH) + LST] + (T (SETQ LST (CONS (PACK* '|...| N '|...|) + LST] + OUT (SETQ LST (CONS (PRECH1 (CDR RECH)) + LST)) + [COND + ((CDR LASTALE) + (SETQ LST (CONS '-- LST] + (RETURN (DREVERSE LST]) + +(PRECH2 + (LAMBDA (X LEVEL) + (COND + ((NLISTP X) + X) + ((EQ (CAR X) + COMMENTFLG) + '"**COMMENT**") + ((ILESSP LEVEL 1) + '&) + (T (MAPCAR X (FUNCTION (LAMBDA (XELT) + (SUB1VAR LEVEL) + (COND + ((MINUSP LEVEL) + '--) + (T (PRECH2 XELT LEVEL))))) + (FUNCTION (LAMBDA (TAIL) + + (* At last!!!! I get to use the second functional argument to a mapping + function. To implement a triangular PRINTLEVEL, step the LEVEL down in the + first function and select hyphens when it hits bottom; + cut off the rest of the MAP by checking for bottom here.) + + (AND (NULL (MINUSP LEVEL)) + (CDR TAIL))))))))) + +(RETAIL + (LAMBDA (L) (* ; "Edited 6-Mar-87 14:39 by DJVB") + (DECLARE%: (SPECVARS L)) + (PROG (RES) + (SETQ RES (LIST (COND + ((TAILP (CAR L) + (CADR L)) + (CAAR L)) + (T (CAR L))))) + (MAP (CDR L) + (FUNCTION (LAMBDA (TAIL) + (COND + ((NULL (CDR TAIL)) + + (* At end. If top-most expression is (NIL &) don't include it. + Otherwise is from TRANSORFNS, so include it. + See TRANSFORM.) + + (AND (CAAR TAIL) + (SETQ RES (CONS (CAR TAIL) + RES)))) + ((MEMB (CAR TAIL) + (CADR TAIL)) + + (* If not a TAIL, must be MEMB, otherwise edit chain screwed up. + We want every one that's MEMB.) + + (SETQ RES (CONS (CAR TAIL) + RES))))))) + (RETURN RES)))) + +(LNC + (LAMBDA (L1 L2) + + (* LNC is for Last New Cons. Returns last tail of L1 such that it is not common + with L2. L1 is the edit chain representing TRANSOR's current location; + L2 is the chain from the last call to WACHADOON. + Value is (LAST L1) if nothing in common, i.e. + we are transoring an entirely different source expression.) + + (PROG (X) + (COND + ((NLISTP L1) + (HELP)) + ((NEQ (SETQ X (LAST L1)) + (LAST L2)) + + (* Quick check for commonest case, we are in a totally different source + expression.) + + (RETURN X))) + LP (COND + ((TAILP (CDR L1) + L2) + (RETURN L1))) + (SETQ L1 (CDR L1)) + (GO LP)))) + +(PRESCAN + (LAMBDA (FILE CHARLST PRESCANFN) (* DJVB "22-NOV-83 21:41") + + (* FIX UP TO ALLOW NULL'S (ZERO'S) IN CHARLST. + AT PRESENT JUST FILTERS %'EM ALL OUT, IF YOU PUT 0 IN CHARLST GIVES ILLEGAL + SETA.) + + (* PRESCAN is for pre-digesting files from alien environments where special + characters, etc., are all different. - + FILE is input file; output goes to next higher version. + - + CHARLST is list of dot-pairs of character codes + (old . new)%, so that you can for example replace all tabs in a file with + spaces by including (9 . 32) on CHARLST. + - + PRESCANFN is function for user. If the new character code for any character is + NIL, then PRESCANFN is called giving the character code as its first argument. + PRESCANFN can then do what it needs to process the upcoming file information. + The second argument to PRESCANFN is the input file, and the third is the output + file. - + Original impetus for this was MIT Lisp's special recognition of semicolon%: any + line beginning with semicolon was comment, a la macro files. + With (59) on CHARLST, where 59 is character code for semicolon, PRESCANFN can + process those lines, making them into regular comments. + Note that no output is done for these special characters unless PRESCANFN does + it.) + + (PROG ((INF (INPUT (INFILE FILE))) + (OUTF (OUTPUT (OUTFILE (NAMEFIELD FILE T)))) + (I 127)) + TOP (COND + ((NOT (ZEROP I)) + (SETA PRESCARRAY I I) + (SUB1VAR I) + (GO TOP))) + (MAPC CHARLST (FUNCTION (LAMBDA (PR) + (SETA PRESCARRAY (CAR PR) + (OR (CDR PR) + 0))))) + (SELECTQ (SYSTEMTYPE) + ((TENEX TOPS-20) + (D-ASSEM::ASSEMBLE NIL (CQ INF) + (FASTCALL IFSET) + (HRRZI 1 %, FCHAR (FX)) + + (* Store ptr to single-character buffer for input file on -2.) + + (PUSHN) + (HRRZ 1 %, FILEN (FX)) (* Store input jfn on -1.) + (PUSHN) + (VARS (HRRZ 2 %, OUTF)) + (FASTCALL IFSET) + (HRRZ 1 %, FILEN (FX)) (* Store output jfn on 0.) + (PUSHN) + (CQ PRESCARRAY) + (SKIPA 4 (TIMES %, 1)) + (XWD 2 1) + (add 4 %, 1) + + (* Ac4 now has PRESCARRAY<2> i.e. indirect ref thru 4 will get Nth element of + PRESCARRAY, where N is in ac2. Note ac4 must be saved on CP since LH is bits, + RH is ptr.) + + LOOP + (NREF (MOVE 1 %, -1)) + (JSYS 40) (* BIN) + (JUMPE 2 %, DONE) + MIDDLE + (SKIPG 0 %, @ 4) + (JRST SPECIAL) + (MOVE 2 %, @ 4) + LOUT + (NREF (MOVE 1 %, 0)) + (JSYS 41) (* BOUT) + (JRST LOOP) + DONE + (JSYS 20) (* GTSTS) + (TLNE 2 %, 512) + (JRST DONE!) (* Filter NULL's.) + (JRST LOOP) + SPECIAL + (MOVE 1 %, 2) + (CLISP% (SETQ CP (CONS %, (CONS 4 CP))) + push CP %, 4) + (CQ (SETQ I (LOC (AC))) + (APPLY* PRESCANFN I INF OUTF)) + (CLISP% (PROG1 (CAR CP) + (SETQ CP (CDR CP))) + pop CP %, 4) + (NREF (HRRZ 2 %, @ -2)) (* If single-char buff. + empty,) + (JUMPE 2 %, LOOP) (* Then next char. must be read from + file,) + (NREF (HLRM 2 %, @ -2)) + + (* Else clear buff. to prevent next call to PRESCANFN from seeing it with READC + or whatever,) + + (JRST MIDDLE) + + (* And be sure the char from buff gets matched and output.) + + DONE! + (POPNN 3))) + (VAX (SETQ INF (\GETOFD INF 'INPUT)) + (SETQ OUTF (\GETOFD OUTF 'OUTPUT)) + (CLISP% (PROG ($$VAL AC AT) + $$LP + (COND + ((\EOFP INF) + (RETURN $$VAL)) + ((ZEROP (SETQ AC (BIN INF))) + (GO $$ITERATE))) + (COND + ((SETQ AT (ELT PRESCARRAY AC)) + (BOUT OUTF AT)) + (T (APPLY* PRESCANFN AC INF OUTF))) + $$ITERATE + (GO $$LP)) + until + (\EOFP INF) + bind AC AT unless (ZEROP (SETQ AC (BIN INF))) + do + (COND + ((SETQ AT (ELT PRESCARRAY AC)) + (BOUT OUTF AT)) + (T (APPLY* PRESCANFN AC INF OUTF))))) + (D (SETQ INF (GETSTREAM INF 'INPUT)) + (SETQ OUTF (GETSTREAM OUTF 'OUTPUT)) + (CLISP% (PROG ($$VAL AC AT) + $$LP + (COND + ((EOFP INF) + (RETURN $$VAL)) + ((ZEROP (SETQ AC (BIN INF))) + (GO $$ITERATE))) + (COND + ((SETQ AT (ELT PRESCARRAY AC)) + (BOUT OUTF AT)) + (T (APPLY* PRESCANFN AC INF OUTF))) + $$ITERATE + (GO $$LP)) + until + (EOFP INF) + bind AC AT unless (ZEROP (SETQ AC (BIN INF))) + do + (COND + ((SETQ AT (ELT PRESCARRAY AC)) + (BOUT OUTF AT)) + (T (APPLY* PRESCANFN AC INF OUTF))))) + (HELP)) + (CLOSEF INF) + (RETURN (CLOSEF OUTF))))) +) + +(RPAQQ TRANSORMACROS ((REMARK (TXT) + (E (KEEPLIST TXT) + T)) + (NLAM NIL (E (SETQQ WHERETOGONEXT NLAMIT) + T)) + [NLAMIT NIL (ORR NX !NX ((E (TRANSEXIT] + (DOTHESE NIL (E (TRANSOR-PROCEED DOTHESE) + T) + NLAM) + (DOTHIS NIL (E (TRANSOR-PROCEED DOTHIS) + T) + NLAM) + (XFORMER NIL (E (TRANSERR TRANSFORMATIONERROR "FAULTY TRANSFORMATION" + (CURRENTFORM CURRENTCOMS)) + T)))) + +(RPAQQ TRANSOREMARKS ((TRANSFORMATIONERROR (* The TRANSFORMATIONS specified for this form failed to + work properly. The TTY message %'FAULTY TRANSFORMATION' + was printed, any commands remaining in the + transformation after the erroneous one were skipped, + and translation continued as if the transformation had + been normally completed. The user should treat the + translated form with caution and amend his + transformation to avoid future problems.)) + (TRANSERROR (* TRANSOR got confused at this point. The TTY message %'SHOW JIM + GOODWIN' was printed and translation continued with the next + form, but the user should treat the compromised area of code + with caution.)) + (BLAMBDA1 (* Non-atomic CAR of form, but not an open lambda. Either a + parenthesis error or computed CAR of form. Computed CAR of form is + no longer legal in BBN-LISP; APPLY* is used instead. If computed + CAR of form was intended, the translation to APPLY* will run ok. + See manual for discussion of APPLY*.)) + (BLAMBDA2 (* Open LAMBDA with wrong number of args. What can it mean?)) + (BLAMBDA3 (* Lambda-expression without forms. What can it mean?)) + (ILLCAR (* Illegal data-type encountered as CAR of form Expression treated as + list of forms.)) + (TAILP/DOTHIS (* When the transormacro DOTHIS is executed at a TAILP position, + TRANSOR does a 1 command first, assuming that the current + position is a list of forms and CAR of it is the form + intended. The user should make sure that this is what was + intended by the TRANSFORMATIONS which called DOTHIS, i.e. the + TRANSFORMATIONS for the form containing this one.)))) + +(RPAQQ TRANSORGLOBALS (USERNOTES USERNOTES TESTFORM TESTFORM TRANSFORMATIONS TRANSFORMATIONS + XFORMSFNS XFORMSVARS XFORMSVARS DUMPFILE TRANSFORMATIONS TRANSFORMATIONS + TRANSFORMATIONS TRANSFORMATIONS)) + +(RPAQQ MAXLOOP 1530) + +(RPAQQ TESTRAN NIL) + +(RPAQ USERMACROS (APPEND TRANSORMACROS USERMACROS)) + +(RPAQ GLOBALVARS (APPEND TRANSORGLOBALS GLOBALVARS)) + +(RPAQ EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) EDITCOMSA)) + +(RPAQ EDITCOMSL (UNION '(REMARK) EDITCOMSL)) + +(RPAQQ TRANSITCONSES (ORR NIL XFORMER)) + +(RPAQ PRESCARRAY (ARRAY 127 127)) + +(RPAQ? NLISTPCOMS ) + +(RPAQ? LAMBDACOMS ) + +(RPAQ? TRANSOUTREADTABLE FILERDTBL) +(DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY + +(PUTPROPS TAILP BLKLIBRARYDEF [LAMBDA (.BLKVAR.X .BLKVAR.Y) + (* True if .BLKVAR.X is A tail of .BLKVAR.Y .BLKVAR.X and + .BLKVAR.Y non-null.) + (* Included with editor for block compilation purposes.) + (AND .BLKVAR.X (PROG NIL LP (COND ((NLISTP .BLKVAR.Y) + (RETURN NIL)) + ((EQ .BLKVAR.X .BLKVAR.Y) + (RETURN .BLKVAR.X))) + (SETQ .BLKVAR.Y (CDR .BLKVAR.Y)) + (GO LP]) +) + +(PUTPROPS TRANSOR FILEGROUP (TRANSOR TSET)) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY +(BLOCK%: PRECHBLOCK PRECH PRECH1 PRECH2 RETAIL LNC (ENTRIES PRECH) + (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) +(BLOCK%: TRANSITBLOCK TRANSIT WACHADOON (ENTRIES TRANSIT WACHADOON) + (GLOBALVARS WACHADID WHENTODOIT TRANSITCONSES LAMBDACOMS NLISTPCOMS) + (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) +(BLOCK%: TRANXTBLOCK TRANXT (ENTRIES TRANXT) + (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) +(BLOCK%: NIL PRESCAN (GLOBALVARS PRESCARRAY)) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML TRANSERR KEEPLIST TRANSOR-PROCEED) + +(ADDTOVAR LAMA ) +) +(DECLARE%: DONTCOPY + +(ADDTOVAR EDITHISTALIST (TRANSOR (" 5-Feb-87 16:18:06" DJVB {DSK}TRANSOR.;11 (TRANSOR) + (FIXED TO WORK WITH NEW FILE RULES IN LYRIC)) + (" 6-Feb-87 15:24:20" DJVB {DSK}TRANSOR.;12 (TRANSOR)) + (" 6-Mar-87 14:41:26" DJVB {DSK}TRANSOR.;13 + (TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM + RETAIL)) + ("17-Mar-87 17:01:53" DJVB {DSK}TRANSOR.;15 (PRECH1 TRANSOUT) + (ADDED SPLIT READ/WRITE READTABLES AND PP FOR DEFUN)))) +) +(PUTPROPS TRANSOR COPYRIGHT (NONE)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2231 38324 (TRANSOR 2241 . 6284) (TRANSOR-PROCEED 6286 . 9093) (TRANSORFORM 9095 . 9527 +) (TRANSORFNS 9529 . 10225) (TRANSFORM 10227 . 11965) (TRANSIT 11967 . 14735) (TRANXT 14737 . 17950) ( +TRANSEXIT 17952 . 18262) (KEEPLIST 18264 . 19224) (TRANSERR 19226 . 19990) (TRANSOUT 19992 . 22436) ( +PPASS1 22438 . 22679) (TRANSLIST 22681 . 23700) (TRANSLIST1 23702 . 23934) (PREMTEXT 23936 . 24641) ( +WACHADOON 24643 . 25114) (PRECH 25116 . 25609) (PRECH1 25611 . 27779) (PRECH2 27781 . 28727) (RETAIL +28729 . 29976) (LNC 29978 . 30841) (PRESCAN 30843 . 38322))))) +STOP diff --git a/lispusers/TRANSOR-LOADTRAN b/lispusers/TRANSOR-LOADTRAN new file mode 100644 index 00000000..f8a7ed9c --- /dev/null +++ b/lispusers/TRANSOR-LOADTRAN @@ -0,0 +1,58 @@ +(DEFINE-FILE-INFO §PACKAGE "XCL-USER" §READTABLE "XCL") +(IL:FILECREATED "13-Apr-87 17:38:17" IL:{DSK}LOADTRAN.\;9 2045 + + IL:|changes| IL:|to:| (IL:VARS IL:LOADTRANCOMS STOP) + (IL:FUNCTIONS MYLOAD I.S.OPR PRETTYCOMPRINT SETTEMPLATE DEFINE-FILE-INFO + ) + (IL:FNS PRETTYCOMPRINT SETTEMPLATE) + + IL:|previous| IL:|date:| " 6-Apr-87 16:57:48" IL:{DSK}LOADTRAN.\;1) + + +; Copyright (c) 1987 by System Development Corp.. All rights reserved. + +(IL:PRETTYCOMPRINT IL:LOADTRANCOMS) + +(IL:RPAQQ IL:LOADTRANCOMS ((IL:VARS STOP) + (IL:FNS PRETTYCOMPRINT SETTEMPLATE) + (IL:FUNCTIONS DEFINE-FILE-INFO I.S.OPR MYLOAD) + (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY + IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA PRETTYCOMPRINT) + (IL:NLAML) + (IL:LAMA SETTEMPLATE))))) + +(IL:RPAQQ STOP STOP) +(IL:DEFINEQ + +(PRETTYCOMPRINT + (IL:NLAMBDA X (IL:* IL:\; "Edited 6-Apr-87 15:47 by DJVB") + 0)) + +(SETTEMPLATE + (LAMBDA (X Y) + (BLOCK SETTEMPLATE (NILL)))) +) + +(DEFUN DEFINE-FILE-INFO (&REST ARGS) (NILL)) + + +(DEFUN I.S.OPR (X) (NILL)) + + +(DEFUN MYLOAD (FILE) (LET ((FILE (OPEN FILE :DIRECTION :INPUT))) + (UNWIND-PROTECT (IL:\\CML-LOAD FILE T *TERMINAL-IO* (FIND-PACKAGE + "XCL-USER")) + (CLOSE FILE)))) + +(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS + +(IL:ADDTOVAR IL:NLAMA PRETTYCOMPRINT) + +(IL:ADDTOVAR IL:NLAML ) + +(IL:ADDTOVAR IL:LAMA SETTEMPLATE) +) +(IL:PUTPROPS IL:LOADTRAN IL:COPYRIGHT ("System Development Corp." 1987)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL (1134 1357 (PRETTYCOMPRINT 1147 . 1283) (SETTEMPLATE 1285 . 1355))))) +IL:STOP diff --git a/lispusers/TRANSOR-TO-COMMONLISP.XFORMS b/lispusers/TRANSOR-TO-COMMONLISP.XFORMS new file mode 100644 index 00000000..2dc08d03 --- /dev/null +++ b/lispusers/TRANSOR-TO-COMMONLISP.XFORMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 5-Jan-88 12:45:55" {DSK}TO-COMMONLISP.XFORMS;11 143791 previous date%: "18-Nov-87 13:38:55" {DSK}TO-COMMONLISP.XFORMS;10) (* " Copyright (c) 1987, 1988 by System Development Corp.. All rights reserved. ") (PRETTYCOMPRINT XFORMSVARS) (RPAQQ XFORMSVARS ((* Transformations from Interlisp-D to Common Lisp. These transformations were developed by System Development Group of UNISYS Corp. There is no guarantee of correctness, completeness or support for these transformations. Copyright (C) by UNISYS Corp. 1986, 1987.0 All rights reserved. Please direct suggestions for improvements and extensions to Darrel J. Van Buer (darrelj@RDCF.SM.UNISYS.COM) or Richard Fritzson (fritzson@bigburd.PRC.Unisys.COM)) XFORMSFNS (USERMACROS TESTORVAL) (VARS XlatedRecords CommonLispComments DataTypeSpecialForms (CLISPARRAY NIL) (CLISPIFTRANFLG NIL) (NORMALCOMMENTSFLG T)) (P (SETQ TRANSOUTREADTABLE (COPYREADTABLE (FIND-READTABLE "XCL"))) (READTABLEPROP TRANSOUTREADTABLE 'CASEINSENSITIVE NIL)) (FNS COMPUTEFORMATS MAKELAMPROG DataTypeP STRINGIFY) (TRANSAVE) (PROP MAKEFILE-ENVIRONMENT TO-COMMONLISP TO-COMMONLISP.XFORMS))) (* Transformations from Interlisp-D to Common Lisp. These transformations were developed by System Development Group of UNISYS Corp. There is no guarantee of correctness, completeness or support for these transformations. Copyright (C) by UNISYS Corp. 1986, 1987.0 All rights reserved. Please direct suggestions for improvements and extensions to Darrel J. Van Buer (darrelj@RDCF.SM.UNISYS.COM) or Richard Fritzson (fritzson@bigburd.PRC.Unisys.COM)) (RPAQQ XFORMSFNS NIL) (ADDTOVAR USERMACROS (TESTORVAL NIL (E (SETQQ USAGE UNKNOWN) T) (ORR [(COMS (SELECTQ (%## !0 1) [(PROGN LAMBDA NLAMBDA AND SELECTQ) '(IF (EQ (%##) (%## !0 -1)) (!0 TESTORVAL -1) ((E (SETQQ USAGE TEST) T] (PROG %' (E (SETQQ USAGE TEST) T)) [PROG1 %' (IF (EQ (%##) (%## !0 2)) (!0 TESTORVAL 2) ((E (SETQQ USAGE TEST) T] (OR '(COMSQ MARK !0 TESTORVAL __)) (DO |'TTY:|) (RETURN %' (COMSQ MARK (BELOW PROG 0) TESTORVAL __)) (NIL NIL) (SELECTQ (%## !0 !0 1) [(SELECTQ COND) '(IF (EQ (%##) (%## !0 -1)) (MARK !0 !0 TESTORVAL __) ((E (SETQQ USAGE TEST) T] '(E (SETQQ USAGE VALUE) T] NIL))) (ADDTOVAR EDITCOMSA TESTORVAL) (RPAQQ XlatedRecords (assertedfacts agendaitem QUESTION FC-MENUITEM 2ndOrderOp AggForm BagForm Entailment QuantifiedFormula IMPlication RIMPlication BICONDitional BinaryOperation Negation AccessSpecification Computation RestrictionTest)) (RPAQQ CommonLispComments (CLISP FEATURES ARE PRIMARILY HANDLED BY DW COMMAND IN LAMBDA TRANSFORMATION. THIS WORKS FOR RECORD PACKAGE TOO, IF ANY DATATYPE OR ARRAYRECORD (AND SINCE GETHASH/PUTHASH ARE UNSUPPORTED, HASHRECORD) DECLARATIONS ARE MODIFIED TO SOME OTHER TYPE. NOTE THAT DECLARATION FORMS LIKE (BITS 5) HAVE TO BE REMOVED IN THIS REDECLARATION. IF ABILITY TO DETERMINE TYPE OF A RECORD IS IMPORTANT, TYPERECORD DECLARATIONS WILL DO. IF ACCESS TIME IS IMPORTANT, RECORDS WITH A BALANCED OR B-TREE LAYOUT MAY BE ADEQUATE)) (RPAQQ DataTypeSpecialForms (create fetch ffetch replace freplace)) (RPAQQ CLISPARRAY NIL) (RPAQQ CLISPIFTRANFLG NIL) (RPAQQ NORMALCOMMENTSFLG T) (SETQ TRANSOUTREADTABLE (COPYREADTABLE (FIND-READTABLE "XCL"))) (READTABLEPROP TRANSOUTREADTABLE 'CASEINSENSITIVE NIL) (DEFINEQ (COMPUTEFORMATS [LAMBDA (PRINTOUTARGS) (* ; "Edited 20-Oct-87 12:28 by DJVB") (* INPUT IS LIST OF ARGS TO PRINTOUT -- AFTER THE FILE ARG.  RESULT SHOULD BE THE LIST OF ARGS NEEDED BY FORMAT TO DO THE SAME THING) (PROG ((FMTSTR (CONCAT)) FMTARGS) LP [COND ((NULL PRINTOUTARGS) (RETURN (CONS FMTSTR FMTARGS] [SELECTQ (CAR PRINTOUTARGS) (.TAB [if (FIXP (CADR PRINTOUTARGS) then (SETQ FMTSTR (CONCAT FMTSTR "~" (CADR PRINTOUTARGS) "T")) else (SETQ FMTSTR (CONCAT FMTSTR "~VT")) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS] (pop PRINTOUTARGS)) (.TAB0 [if (FIXP (CADR PRINTOUTARGS) then (SETQ FMTSTR (CONCAT FMTSTR "~" (CADR PRINTOUTARGS) ",0T")) else (SETQ FMTSTR (CONCAT FMTSTR "~V,0T")) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS] (pop PRINTOUTARGS)) (%, (SETQ FMTSTR (CONCAT FMTSTR "~@T"))) (%,, (SETQ FMTSTR (CONCAT FMTSTR "~2@T"))) (%,,, (SETQ FMTSTR (CONCAT FMTSTR "~3@T"))) (.SP (SETQ FMTSTR (CONCAT FMTSTR "~V@T")) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS))) (pop PRINTOUTARGS)) ((T 0) (SETQ FMTSTR (CONCAT FMTSTR "~%%"))) (.SKIP [if (FIXP (CADR PRINTOUTARGS)) then (SETQ FMTSTR (CONCAT FMTSTR "~" (CADR PRINTOUTARGS) "%%")) else (SETQ FMTSTR (CONCAT FMTSTR "~V%%") (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS] (pop PRINTOUTARGS)) (.PAGE (SETQ FMTSTR (CONCAT FMTSTR "~|"))) (|.P2| (SETQ FMTSTR (CONCAT FMTSTR "~S")) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS))) (pop PRINTOUTARGS)) ((.SUP .SUB .BASE) (* DON'T KNOW HOW TO HANDLE THIS, SO DO A REMARK) (KEEPLIST PRINTOUTSUB%:)) ((.FONT %#) (* DON'T KNOW HOW TO HANDLE THIS, SO DO A REMARK) (KEEPLIST PRINTOUTFONT%:) (CLISP% (PROG1 (CAR PRINTOUTARGS) (SETQ PRINTOUTARGS (CDR PRINTOUTARGS))) pop PRINTOUTARGS)) ((.PPF .PPV .PPFTL .PPVTL) (* DON'T KNOW HOW TO HANDLE THIS, SO DO A REMARK) (KEEPLIST PRINTOUT%:) (SETQ FMTSTR (CONCAT FMTSTR "~A")) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS))) (pop PRINTOUTARGS)) ((.N .FR .FR2) (* DON'T KNOW HOW TO HANDLE THIS, SO DO A REMARK) (KEEPLIST PRINTOUT%:) (pop PRINTOUTARGS) (SETQ FMTSTR (CONCAT FMTSTR "~A")) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS))) (pop PRINTOUTARGS)) ((.PARA .PARA2) (* DON'T KNOW HOW TO HANDLE THIS, SO DO A REMARK) (KEEPLIST PRINTOUT%:) (SETQ FMTSTR (CONCAT FMTSTR "~A")) (pop PRINTOUTARGS) (pop PRINTOUTARGS) (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS))) (pop PRINTOUTARGS)) (COND [(FIXP (CAR PRINTOUTARGS)) (* TAB OR SPACES SHORTHAND) (COND ((MINUSP (CAR PRINTOUTARGS)) (* SPACES) (SETQ FMTSTR (CONCAT FMTSTR "~" (IMINUS (CAR PRINTOUTARGS)) "@T"))) (T (SETQ FMTSTR (CONCAT FMTSTR "~" (CAR PRINTOUTARGS) "T"] ((FASSOC (CAR PRINTOUTARGS) PRINTOUTMACROS) (* DON'T KNOW HOW TO HANDLE THIS, SO DO A REMARK) (KEEPLIST PRINTOUTMACROS%:)) ([AND (LITATOM (CAR PRINTOUTARGS)) (MEMB (SUBATOM (CAR PRINTOUTARGS) 1 2) '(.I .F] (* NUMERIC FORMAT REQUEST) [SETQ FMTSTR (CONCAT FMTSTR (CADDR (TRANSORFORM `(PRINTNUM ',[CONS (COND ((EQ (SUBATOM (CAR PRINTOUTARGS) 2 2) 'I) 'FIX) (T 'FLOAT)) (while POINT bind (POINT _ 2) collect (SUBATOM (CAR PRINTOUTARGS) (ADD1 POINT) (AND (SETQ POINT (STRPOS "." (CAR PRINTOUTARGS) (ADD1 POINT))) (SUB1 POINT] 0] (SETQ FMTARGS (NCONC1 FMTARGS (CADR PRINTOUTARGS))) (pop PRINTOUTARGS)) [[AND (STRINGP (CAR PRINTOUTARGS)) (NULL (STRPOS "~" (CAR PRINTOUTARGS] (SETQ FMTSTR (CONCAT FMTSTR (CAR PRINTOUTARGS] [[AND (EQ 'QUOTE (CAAR PRINTOUTARGS)) (LITATOM (CADAR PRINTOUTARGS)) (NULL (STRPOS "~" (CADAR PRINTOUTARGS] (SETQ FMTSTR (CONCAT FMTSTR (CADAR PRINTOUTARGS] (T (SETQ FMTSTR (CONCAT FMTSTR "~A") (SETQ FMTARGS (NCONC1 FMTARGS (CAR PRINTOUTARGS] (CLISP% (PROG1 (CAR PRINTOUTARGS) (SETQ PRINTOUTARGS (CDR PRINTOUTARGS))) pop PRINTOUTARGS) (GO LP]) (MAKELAMPROG [LAMBDA (PRG) (* ; "Edited 26-Mar-87 12:03 by DJVB") (PROG ([INITV (for X in (CADR PRG) collect (CAR X) when (is X (A LIST] [INITVAL (for X in (CADR PRG) when (is X (A LIST)) collect (COND ((EQLENGTH X 2) (CADR X)) (T (CDR X] (NONINITV (for X in (CADR PRG) unless (is X (A LIST)) collect X))) (RETURN (CONS [LIST 'LAMBDA INITV (CONS (CAR PRG) (CONS NONINITV (CDDR PRG] INITVAL]) (DataTypeP [LAMBDA (x) (* RichardFritzson " 5-Dec-86 06:46") (PROG [(Y (COND ((LITATOM x) x) (T (CADR x] (RETURN (OR (DATATYPEP x) (COND ((LITATOM x) (MEMB x XlatedRecords)) (T (MEMB (CAR x) XlatedRecords))) (EQ (CAAR (FIELDLOOK Y)) 'DATATYPE) (AND (EQ (CAAR (FIELDLOOK Y)) 'RECORD) (MEMB Y XlatedRecords]) (STRINGIFY [LAMBDA (STRLIST) (* ; "Edited 18-Nov-87 11:13 by DJVB") (LET ((PARTIAL "")) [CLISP% [MAP STRLIST (FUNCTION (LAMBDA (X) (COND ((CDR X) (SETQ PARTIAL (CONCAT PARTIAL (CAR X) " "))) (T (SETQ PARTIAL (CONCAT PARTIAL (CAR X] for X on STRLIST do (COND ((CDR X) (SETQ PARTIAL (CONCAT PARTIAL (CAR X) " "))) (T (SETQ PARTIAL (CONCAT PARTIAL (CAR X] PARTIAL]) ) (RPAQQ DUMPFILE TO-COMMONLISP.XFORMS) (RPAQQ USERNOTES ((/SETATOMVAL%: (* XFORM CORRECT ONLY FOR DEEP BOUND SYSTEM)) (ADDLAST%: (* CHANGETRAN FAILED TO DWIMIFY)) (APROPOS%: (* UNSUPPORTED FEATURE)) (ASSOC%: (* ASSOC NOT CHANGED, SO USES EQL NOT EQ)) (BLAMBDA1 (* NON-ATOMIC CAR OF FORM NOT AN INLINE LAMBDA. APPLY* INSERTED.)) (BLAMBDA2 (* DISAGREEMENT IN ARG COUNT BETWEEN LAMBDA LIST AND ARGS.)) (BLAMBDA3 (* LAMBDA EXPRESSION LACKS A BODY)) (BREAK%: (* UNRELATED TO CL%:BREAK)) (CHARCODE%: (* CHAR-INT CORRESPONDS TO CHARCODE BUT CHAR NAMES MAY NOT)) (CLOCK1%: (* CLOCK not translated)) (CLOCK%: (* CLOCK SEMANTICS PRESERVED BUT MAY BE SIMPLER IN CONTEXT)) (COMPILE%: (* IL%:COMPILE TAKES LIST OR SINGLE ITEM, CL%:COMPILE TAKES ONLY SINGLE ITEM. NOT CHANGABLE AUTOMATICALLY)) (CONSCOUNT%: (* CONSCOUNT NONOPERATIONAL)) (CONSTANTS%: (* DONT HAVE VALUE FOR CONSTANT, AND NO EASY WAY TO FIND IT AUTOMATICALLY, ALTHOUGH IT MAY HAVE APPEARED A FEW LINES BACK IN THE FILE. IN AT LEAST SOME CL %,THE EASY TRANSLATION OF WHAT A CONSTANTS FILECOM EXPANDS INTO IS (DEFPARAMETER VAR 'GLOBALVALUE) (DEFCONSTANT VAR) %,BUT THIS OFTEN LEAVES YOU WITH A CONSTANT SET TO NIL -- AND RESISTANT TO CORRECTION)) (COPYALL%: (* CommonLisp does not have a COPYALL. COPY-TREE was used.)) (COUNT%: (* TOTALLY UNRELATED TO CL%:COUNT, AND NO EQUIVALENT?)) (DATATYPES (* Record not a DATATYPE -- trying DWIM translation)) (DATE%: (* DATE FORMATTED TO INTERLISP DEFAULT. INLINE EXPANSION USED MAY BE UNDESIRABLE IF USED MUCH)) (DECLARE1%: (* SPECIAL DECLARATION MAY NEED TO BE MOVED TO RIGHT LEXICAL SCOPE)) (DECLARE%: (* MULTIPLE DECLARATION TOO COMPLEX)) (DEFPRINT%: (* DEFPRINT BECOMES A (%:PRINT-FUNCTION --) OPTION TO THE DEFSTRUCT FOR THE FIRST ARGUMENT, BUT THE CONVENTIONS ALSO DIFFER IN DEFINITION, SO YOU WILL HAVE TO MANUALLY EDIT THE SECOND ARGUMENT FUNCTION AS WELL)) (DIRECTORYNAME%: (* HARD CASE OF DIRECTORYNAME)) (DREMOVE%: (* DREMOVE/DELQ FOR EFFECT DIFFERS. IN COMMONLISP A SIDE EFFECT IS NOT GUARANTEED WHILE INTERLISP ONLY FAILS FOR EFFECT IF WHOLE LIST DELETED)) (DRIBBLE%: (* CANT DO APPEND/THAWWED IN CL)) (ERROR!%: (* ERROR! TRANSLATION USES "PROPOSED" CL ERROR SYSTEM STANDARD. YOUR MILAGE MAY VARY (TRY SOME KIND OF THROW REWRITE IF IT FAILS))) (ERRORSET%: (* ERRORSET not translated)) (ERSETQ%: (* ERSETQ not translated)) (EVERY%: (* EVERY not translated)) (FILENAMEFIELD%: (* CAN'T TRANSFORM FILENAMEFIELD WITH VARIABLE FIELD)) (FNTYP%: (* TRANSFORM ONLY CAPTURES USE AS PREDICATE TO TEST FOR DEFINITION)) (FORCEOUTPUT%: (* CAN'T TRANSLATE VARIABLE FOR WAITFLG)) (FUNCTION%: (* Transformation is mangling a FUNCTION expression)) (GETFILEINFO%: (* UNSUPPORTED OR VARIABLE ATTRIBUTE IN GETFILEINFO)) (IDATE%: (* ARG TO IDATE NEEDS WORK)) (INTERLISP-ATOM (* Interlisp ATOM is true of Literal Atoms and Numbers only. Common Lisp ATOM is true of anything which is not a CONS)) [KWOTE%: (* NEED (DEFUN KWOTE (X) (COND ((OR (NULL X) (EQL X T) (NUMBERP X)) X) (T (LIST 'QUOTE X] (LDIFF%: (* CommonLisp LDIFF does not produce an error when argument#2 is not a tail of argument#1.)) (LISPXUNREAD%: (* LISPXUNREAD not translated)) (LISTP1%: (* THIS IS A CONSERVATIVE CHANGE FOR LISTP. FOR SIMPLE EXPRESSIONS, TRANSLATION IS EXACT BUT MORE EXPENSIVE IF REALLY TEST ONLY. FOR COMPLEX EXPRESSIONS USED FOR VALUE, CHANGES ARE NEEDED)) (LISTP%: (* MESSY LISTP, VERIFY USE REALLY FOR VALUE)) (LOAD%: (* LOAD OPTIONS NOT IN CL)) (LOAD?%: (* NOW UNCONDITIONAL LOAD)) (LOGOUT%: (* LOGOUT/EXIT NOT IN CL STANDARD YET)) (MAP2C%: (* MAP2C WITH TAIL FN NOT DONE)) (MAPHASH%: (* CL%:MAPHASH APPLY FN HAS OPPOSITE ORDER FROM IL. LAMBDA LIST NOT LOCATED SO NOT TRANSFORMED)) (MKSTRING%: (* CANT SIMULATE MKSTRING VIA READTABLE)) (NLAMBDA%: (* NO NLAMBDA IN COMMON LISP -- TRY A MACRO -- IF ARGLIST IS LITATOM, A MACRO WITH (&REST ARG) FOR ARGLIST)) (NLEFT%: (* DID INLINE EXPANSION FOR NLEFT, MAY WANT TO DEFINE FUNCTION IF USED MUCH)) (NLSETQ%: (* ERSETQ AND NLSETQ HAVE BEEN TRANSLATED WITH PROPOSED ANSI CL ERROR HANDLING EXTENSIONS. MAY NOT WORK IN ALL LISPS.)) (NO-TRANSFORMATION-NEEDED (* THE FOLLOWING FUNCTIONS SEEM TO BE THE SAME (OF CL IS A SAFE SUPERSET) AND THUS HAVE NO TRANSFORMATIONS, OR HAVE TRANSFORMATIONS TO WARN OF ODD CASES WHICH DON'T MAP OR TO PROCESS THE CORRECT SYNTAX OF A SPECIAL FORM. (ABS AND APPLY BOUNDP BQUOTE BYTE CLRHASH COND DIRECTORY (IN SIMPLE CASES ANYWAY) DPB DRIBBLE EQ EQUAL EVAL EXPT FLOAT GCD GENSYM GETHASH GO INSPECT INTERSECTION LAST LDB LET LET* LIST LIST* LOG LOGAND LOGNOT LOGXOR MAX MIN MINUSP NCONC NOT NULL OR POP PROG PROG1 PROG2 PROGN QUOTE READ REMPROP RETURN REVERSE RPLACA RPLACD TRACE SET SETQ SUBST TAILP TERPRI UNION))) (NTHCHAR%: (* FLG & RDTBL ARGS NEED TO DO (ELT (PRIN1-TO-STRING ARG1) ARG2) TO GET IT RIGHT)) (NTYPX%: (* REWRITE INTO TYPEP SOMEHOW?)) (NUMBERP1%: (* MESSY NUMBERP, SHOULD VERIFY USE FOR VALUE)) (NUMBERP%: (* THIS IS A CONSERVATIVE CHANGE FOR NUMBERP/FIXP/... FOR SIMPLE EXPRESSIONS, TRANSLATION IS EXACT BUT MORE EXPENSIVE IF TEST ONLY. FOR COMPLEX EXPRESSIONS, WON'T WORK FOR VALUE)) (OPENFILE1%: (* NO PLACE IN CL OPEN FOR IL OPTIONS)) (OPENFILE2%: (* OLDEST RECOGNITION BELONG IN FILENAME AS %:VERSION %:OLDEST)) (OUTSIDE-CL%: (* FUNCTION IN AREA NOT ADDRESSED BY CL STANDARD (E.G. DISPLAY, PROCESSES, NETWORK))) (PACKFILENAME1%: (* COMPUTED COMPONENT NAMES NOT TRANSLATED)) (PACKFILENAME%: (* NOT POSITION SENSITIVE IN CL. MAY NEED CHANGES)) (POSITION%: (* NO SUCH OPERATION IN CL?)) (PRINT%: (* Ugly translation of PRINT)) (PRINTDEF%: (* LEFT MARGIN OR TAILFLG IGNORED)) (PRINTNUM%: (* IMPERFECT TRANSLATION OF PRINTNUM)) (PRINTOUT%: (* PRINTOUT SPECIAL FORMATTING (E.G. PRETTYPRINTING) IGNORED)) (PRINTOUTFONT%: (* .FONT IGNORED IN PRINTOUT)) (PRINTOUTMACROS%: (* PRINTOUT MACRO NOT EXPANDED/TRANSLATED)) (PRINTOUTSUB%: (* PRINTOUT SUB/SUPERSCRIPTING IGNORED)) (PROMPTPRINT%: (* LOSES SOME OF THE SPIRIT OF PROMPTPRINT)) [PUTASSOC%: (* NEED (DEFUN PUTASSOC (KEY VAL ALST) (LET ((POS (ASSOC KEY ALST))) (* THIS COULD HAVE BEEN WRITTEN AS AN UGLY PROG TO AVOID BOTH ASSOC AND NCONC HAVING TO SCAN THE LIST TO ADD A NEW ITEM) (COND (POS (RPLACD POS VAL)) [(CONSP ALST) (NCONC ALST (LIST (CONS KEY VAL] (T (CERROR "Arg not list ~A" ALST))) VAL] (PUTPROPS1%: (* WIERD MACRO CASE)) (PUTPROPS%: (* NLAMBDA MACRO NOT SUPPORTED)) (RAND%: (* RAND OF EXPRESSION DEPENDS OF TYPE OF VALUE, FOR INT USE (RANDOM (1+ EXP)) %, FOR FLOAT (RANDOM EXP))) (READVISE%: (* READVISE not translated)) (RECORD1%: (* RECORD declaration incorrectly translated.)) (RESET%: (* RESETLST AND RELATIVES SOMEWHAT LIKE UNWIND-PROTECT, BUT YOU'RE ON YOUR OWN)) [SELECTC2%: (* SELECTC REQUIRES YOU TO DO (DEFMACRO SELECTC (SELECTOR &REST CASES) `[CASE ,SELECTOR ,@(for CASE on CASES while (CDR CASE) collect (CONS (EVAL (CAAR CASE)) (CDAR CASE))) (OTHERWISE ,(LAST CASES]) ] (SETN%: (* TOTALLY UNPORTABLE. SETN ISN'T EVEN SAFE BETWEEN DIFFERENT INTERLISPS!)) (SETSYNTAX%: (* CL READTABLES ONLY VAGUELY LIKE INTERLISP)) (SMALLP%: (* NO CL TEST FOR SMALLP, AT LEAST FIXNUM BETTER THAN BIGNUM)) (SQRT%: (* IN IL, (SQRT -1) IS ERROR, IN CL IT'S %#C (0 1))) (STRINGP1%: (* MESSY STRINGP, VERIFY USE FOR VALUE)) (STRINGP%: (* CONSERVATIVE STRINGP. FOR SIMPLE ARG, LESS EFFICIENT IF PREDICATE ONLY. FOR COMPLEX ARG FOR VALUE, INCORRECT)) (STRPOS%: (* CAN'T TRANSLATE SKIP/ANCHOR/TAIL/CASEARRAY)) (SUBLIS%: (* INTERLISP (D) SUBLIS WITH FLG=T ALSO COPIES SUBSTITUTIONS WHICH ARE LISTS. TRANSFORMATION DOES NOT.)) (SUBPAIR%: (* SEE IF PAIRLIS CAN BE MOVED OUT)) (SYSTEMTYPE%: (* MANY USES OF SYSTEMTYPE ARE DONE AS SHARP+/- READ MACROS IN CL)) [TCONC%: (* NEED (DEFUN TCONC (PTR X) (LET ((L (LIST X))) [COND ((NULL PTR) (SETQ PTR (LIST NIL] (COND ((CAR PTR) (RPLACD (CDR PTR) L)) (T (RPLACA PTR L))) (RPLACD PTR L] (TIME%: (* TIMEN AND TIMETYP ARGS NOT SUPPORTED IN CL)) (TYPENAMEP%: (* TYPENAMEP DATATYPE NAMES NOT MAPPED)) (TYPEP%: (* TYPEP IS ANCIENT INTERLISP-10 TEST ON TYPENUMBER! YOUR PROBLEM IS TO MAP TYPENUMBER TO CL TYPENAME)) (UNDOABLE (* AN UNDOABLE /FN HAS BEEN TRANSFORMED TO ORDINARY COUNTERPART)) (UNPACK%: (* UNPACK/CHCON AND SURROUNDING TO SEQUENCE OPERATIONS?? THE TRANSLATION TO COERCE WILL WORK FOR SYMBOLS AND STRINGS, BUT PRINC-TO-STRING IS NEEDED FOR MOST OTHER KINDS OF ARGUMENTS)) (create%: (* This create can not be translated yet.)) (fetch1%: (* OUGHT TO BECOME (AREF DATUM INDEX) where INDEX depends on position of field in record and any skip counts before it in record)) (fetch%: (* OUGHT TO BECOME (AREF DATUM INDEX) where INDEX depends on position of field in record and any skip counts before it in record)) (push%: (* TRANSLATION OF MULTIPLE PUSH GIVES MULTIPLE EVALUATION OF PLACE)) (replace1%: (* OUGHT TO BECOME (AREF DATUM INDEX) where INDEX depends on position of field in record and any skip counts before it in record)) (replace%: (* OUGHT TO BECOME (SETF (AREF DATUM INDEX) NEWVALUE) where INDEX depends on position of field in record and any skip counts before it in record)))) (RPAQQ NLISTPCOMS NIL) (RPAQQ LAMBDACOMS [(COMS (SELECTQ (%## 1 1) ([LAMBDA NLAMBDA] '(COMSQ (IF (AND [NOT (EQLENGTH (%## (NTH 2)) (LENGTH (%## 1 2] (LISTP (%## 1 2))) ((REMARK BLAMBDA2)) NIL) MARK (ORR (1 (NTH 3) DOTHESE) ((REMARK BLAMBDA3))) __ (NTH 2) DOTHESE)) '(COMSQ (REMARK BLAMBDA1) (-1 APPLY*]) (RPAQQ TRANSFORMATIONS (* *CATCH *THROW /DECLAREDATATYPE /NCONC /NCONC1 /PUTPROP /RPLACA /SETATOMVAL ADD ADD.PROCESS ADD1 ADDLAST ADDMENU ADDPROP ADDTOVAR ADVISE ALPHORDER ANTILOG APPEND APPLY* APROPOS ARCCOS ARCSIN ARCTAN ARCTAN2 ARG ARRAY ARRAYP ASKUSER ASSOC ATOM ATOMRECORD ATTACH ATTACHMENU ATTACHWINDOW BIN BITBLT BLOCK BOUT BQUOTE BREAK BREAKDOWN BRKDWNRESULTS BYTEPOSITION BYTESIZE CCODEP CENTERPRINTINREGION CHANGE CHANGEFONT CHARACTER CHARCODE CHCON CHCON1 CHUNK.MENU.CREATE CLEARW CLISP% CLISPDEC CLOCK CLOSEF CLOSEF? CLOSEW CLRPROMPT CNDIR COMPILE CONCAT COND CONS CONSCOUNT CONSTANT CONSTANTS COPY COPYALL COPYBYTES COPYCHARS COPYREADTABLE COS COUNT CREATE.NUMBERPAD.READER CREATEREGION CREATEW DATATYPE DATE DECLARE DECLARE%: DEF DEFINE-FILE-INFO DEFINEQ DEFPRINT DEL.PROCESS DELETEMENU DELFILE DETACHALLWINDOWS DIFFERENCE DIRECTORYNAME DISMISS DO DREMOVE DREVERSE DRIBBLE DSPCLIPPINGREGION DSPCREATE DSPFILL DSPFONT DSPRESET DSPRIGHTMARGIN DSPSCROLL DSPXPOSITION DSPYPOSITION DSUBLIS DSUBST DV ECHOCONTROL EDITE EDITV ELT EOFP EQLENGTH EQP ERROR ERROR! ERRORSET ERSETQ EVENP EVERY EXPRP FASSOC FCHARACTER FETCH FIELDLOOK FILECOMS FILECOMSLST FILENAMEFIELD FILEPKGCHANGES FILESLOAD FINDFILE FIX FIXP FLASHWINDOW FLAST FLESSP FLOATP FMAX FMEMB FMIN FNTH FNTYP FONTCREATE FONTPROP FOR FORCEOUTPUT FQUOTIENT FRPLACA FRPLACD FTIMES FUNCTION GEQ GETBOXPOSITION GETD GETFILEINFO GETFILEPTR GETPROP GETPROPLIST GETPROPMPTWINDOW GETREGION GETRELATION GETTOPVAL GETWINDOWPROP GIVE.TTY.PROCESS GLOBALVARS GREATERP HARRAY HARRAYP HARRAYSIZE HASHARRAY HASHARRAYP HASHLINK HELP IDATE IDIFFERENCE IEQP IGEQ IGREATERP ILEQ ILESSP IMAX IMIN IMINUS IMOD INFILE INFILECOMTAIL INFILEP INPUT INTEGERLENGTH INTERRUPTCHAR IOFILE IPLUS IQUOTIENT IREMAINDER ITIMES KWOTE L-CASE LAMBDA LASTC LAYOUTGRAPH LAYOUTSEXPR LDIFF LDIFFERENCE LENGTH LEQ LESSP LET LET* LISPVERSION LISPX LISPXPRINT LISPXREAD LISPXREADP LISPXUNREAD LISTFILES1 LISTGET LISTP LISTPUT LITATOM LLSH LOAD LOAD? LOADFNS LOCALVARS LOGOR LOGOUT LRSH LSH LSUBST MACHINETYPE MAP MAP2C MAP2CAR MAPC MAPCAR MAPCON MAPCONC MAPHASH MAPLIST MARKASCHANGED MASTERSCOPE MEMB MEMBER MENU MERGE MINUS MISSPELLED? MKATOM MKSTRING MOUSECONFIRM MOVETO NCHARS NCONC1 NEQ NEWPRINTDEF NLAMBDA NLEFT NLISTP NLSETQ NOTANY NOTEVERY NTH NTHCHAR NTHCHARCODE NTYPX NUMBERP NUMBERPAD.READ ODDP OPENFILE OPENLAMBDA OPENSTREAM OPENW OPENWP OUTFILE OUTPUT PACK PACK* PACKC PACKFILENAME PEEKC PLUS POSITION PRETTYCOMPRINT PRIN1 PRIN2 PRIN3 PRINT PRINTBELLS PRINTDEF PRINTNUM PRINTOUT PROCESSP PROCESSPROP PROG PROGN PROMPTCHAR PROMPTPRINT PUSH PUSHLIST PUSHNEW PUTASSOC PUTD PUTHASH PUTPROP PUTPROPS QUOTE QUOTIENT RAND RANDSET RATOM READC READLINE READP READTABLEP READVISE RECLOOK RECORD REGIONP REMOVE REMPROPLIST REPLACE RESETFORM RESETLST RESETSAVE RESETVAR RESETVARS RESTART.PROCESS RETFROM RETTO RNUMBER RPAQ RPAQ? RPAQQ RPLNODE RPLNODE2 RPLSTRING RSH SASSOC SCROLLBYREPAINTFN SELECTC SELECTQ SETA SETFILEPTR SETMENU SETN SETPROPLIST SETQ SETQQ SETSYNTAX SETTOPVAL SHADEITEM SHOULDNT SHOWGRAPH SHOWZOOMGRAPH SIN SMALLP SOME SORT SPACES SPECVARS SQRT STKEVAL STKPOS STREQUAL STRINGP STRPOS SUB1 SUBATOM SUBLIS SUBPAIR SUBSET SUBSTRING SUSPEND.PROCESS SWAP SYSTEMTYPE TAB TAN TCONC TCP.CLOSE.SENDER TCP.OTHER.STREAM THIS.PROCESS TIME TIMES TOTOPW TTYDISPLAYSTREAM TTYIN TYPE? TYPENAMEP TYPEP TYPERECORD U-CASE UALPHORDER UNBREAK UNPACK USEREXEC WFROMMENU WHENCLOSE WHEREIS WHILE WINDOWADDPROP WINDOWP WINDOWPROP XNLSETQ ZEROP \ADDTOFILEBLOCK/ADDTOCOM1 add addlast change create do fetch ffetch for freplace pop printout push pushlist pushnew replace swap type? while)) (PUTPROPS * XFORM ((1 *COMMENT*) [IF (EQ (%## 2) '*) ((2 ;;)) ((IF (GREATERP (LENGTH (%##)) 10) ((-2 ;;)) ((-2 ;] [I 3 (STRINGIFY (CDDR (%##] (IF (%## (NTH 4)) ((DELETE (4 THRU))) NIL))) (PUTPROPS *CATCH XFORM ((1 CATCH))) (PUTPROPS *THROW XFORM ((1 THROW))) (PUTPROPS /DECLAREDATATYPE XFORM ((MBD *) DOTHIS)) (PUTPROPS /NCONC XFORM ((REMARK UNDOABLE) (1 NCONC))) (PUTPROPS /NCONC1 XFORM ((REMARK UNDOABLE) (1 NCONC) (-3 LIST) (LI 3))) (PUTPROPS /PUTPROP XFORM ((REMARK UNDOABLE) (1 SETF) (-2 GET) (BI 2 4))) (PUTPROPS /RPLACA XFORM ((1 RPLACA) (REMARK UNDOABLE))) (PUTPROPS /SETATOMVAL XFORM ((REMARK UNDOABLE) (REMARK /SETATOMVAL%:) (1 SETTOPVAL) DOTHIS)) (PUTPROPS ADD XFORM ((1 add) DOTHIS)) (PUTPROPS ADD.PROCESS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ADD1 XFORM ((1 1+))) (PUTPROPS ADDLAST XFORM [DW (IF (EQ (CAR (%##)) 'CLISP% ) (DOTHIS) ((REMARK ADDLAST%:]) (PUTPROPS ADDMENU XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ADDPROP XFORM ((1 PUSHNEW GETPROP) (BI 2 4) (SW 2 3))) (PUTPROPS ADDTOVAR XFORM [(IF (%## (NTH 4)) ((1 SETQ) (LI 3) (EMBED 3 IN (UNION '&)) 3 (I N (%## 0 2))) ((1 PUSHNEW) (SW 2 3) (EMBED 2 IN QUOTE]) (PUTPROPS ADVISE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ALPHORDER XFORM ((1 STRING<))) (PUTPROPS ANTILOG XFORM ((1 EXP))) (PUTPROPS APPEND XFORM [(ORR (3) ((N NIL]) (PUTPROPS APPLY* XFORM ((1 FUNCALL))) (PUTPROPS APROPOS XFORM ((IF (EQ (CADDDR (%##)) T) ((1 APROPOS-LIST) (4)) NIL) (IF (OR (CADDR (%##)) (CADDDR (%##))) ((REMARK APROPOS%:)) NIL))) (PUTPROPS ARCCOS XFORM [(1 ACOS) (IF (%## 3) ((3)) ((MBD (TIMES & (/ 180 (FLOAT PI &]) (PUTPROPS ARCSIN XFORM [(1 ASIN) (IF (%## 3) ((3)) ((MBD (TIMES & (/ 180 (FLOAT PI &]) (PUTPROPS ARCTAN XFORM [(1 ATAN) (IF (%## 3) ((3)) ((MBD (TIMES & (/ 180 (FLOAT PI &]) (PUTPROPS ARCTAN2 XFORM [(1 ATAN) (IF (%## 4) ((4)) ((MBD (TIMES & (/ 180 (FLOAT PI &]) (PUTPROPS ARG XFORM [(1 NTH) (IF (NUMBERP (%## 3)) [(I 3 (SUB1 (%## 3] ((EMBED 3 IN 1-]) (PUTPROPS ARRAY XFORM ((1 make-array) (EMBED 2 IN ADD1) (ORR ((5)) NIL) (ORR ((3)) NIL) (ORR (3 (B :initial-element)) NIL))) (PUTPROPS ARRAYP XFORM (TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2)) NLAM) ([1 FUNCALL (LAMBDA (X) (AND (ARRAYP X) X] 2 DOTHIS (REMARK NUMBERP1%:] [UNKNOWN '(COMSQ (REMARK NUMBERP1%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2)) NLAM] NIL)))) (PUTPROPS ASKUSER XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ASSOC XFORM ((REMARK ASSOC%:))) (PUTPROPS ATOM XFORM ((1 OR) (EMBED 2 IN (SYMBOLP &) (NUMBERP &)) (REMARK INTERLISP-ATOM))) (PUTPROPS ATOMRECORD XFORM ((MBD *) DOTHIS)) (PUTPROPS ATTACH XFORM [(1 (LAMBDA (X L) (RPLACD L (CONS (CAR L) (CDR L))) (RPLACA L X]) (PUTPROPS ATTACHMENU XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ATTACHWINDOW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS BIN XFORM ((1 READ-BYTE))) (PUTPROPS BITBLT XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS BLOCK XFORM [(1 SLEEP) (ORR ((EMBED 2 IN (/ & 1000)) 2 2 DOTHIS) ((N 0]) (PUTPROPS BOUT XFORM ((1 WRITE-BYTE) (SW 2 3))) (PUTPROPS BQUOTE XFORM ((LPQ (F \, N) 2 DOTHIS) NLAM)) (PUTPROPS BREAK XFORM ((REMARK BREAK%:))) (PUTPROPS BREAKDOWN XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS BRKDWNRESULTS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS BYTEPOSITION XFORM ((1 BYTE-POSITION))) (PUTPROPS BYTESIZE XFORM ((1 BYTE-SIZE))) (PUTPROPS CCODEP XFORM ((1 COMPILED-FUNCTION-P))) (PUTPROPS CENTERPRINTINREGION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CHANGE XFORM ((1 change) DOTHIS)) (PUTPROPS CHANGEFONT XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CHARACTER XFORM ((MBD INTERN) NLAM)) (PUTPROPS CHARCODE XFORM ([I 2 (CL:INT-CHAR (EVAL (%##] (1 CHAR-INT) (REMARK CHARCODE%:))) (PUTPROPS CHCON XFORM ((REMARK UNPACK%:) (1 STRING) (MBD (MAP 'LIST (FUNCTION CHAR-CODE) &)) 4 2 DOTHIS)) (PUTPROPS CHCON1 XFORM ((1 CHAR) (N 0) (EMBED 2 IN STRING) (MBD CHAR-CODE))) (PUTPROPS CHUNK.MENU.CREATE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CLEARW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CLISP% XFORM ((IF [OR (MEMB (L-CASE (%## 1)) '(while for push pop pushnew add swap)) (AND (MEMB (%## 1) DataTypeSpecialForms) (DataTypeP (%## 2] ((I %: (CDDR (%##))) 1 DOTHIS) ((I %: (CADR (%##))) 1 DOTHIS)))) (PUTPROPS CLISPDEC XFORM ((MBD *) DOTHIS)) (PUTPROPS CLOCK XFORM [(COMS (SELECTQ (CADR (%##)) [(0 NIL) '(COMSQ (1 *) [ORR (2 (/ 1000 INTERNAL-TIME-UNITS-PER-SECOND) (GET-INTERNAL-REAL-TIME)) ((N (/ 1000 INTERNAL-TIME-UNITS-PER-SECOND) (GET-INTERNAL-REAL-TIME] (REMARK CLOCK%:] [2 '(COMSQ (1 *) (2 (/ 1000 INTERNAL-TIME-UNITS-PER-SECOND) (GET-INTERNAL-RUN-TIME)) (REMARK CLOCK%:] '(REMARK CLOCK1%:]) (PUTPROPS CLOSEF XFORM ((1 CLOSE))) (PUTPROPS CLOSEF? XFORM ((1 CLOSE))) (PUTPROPS CLOSEW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CLRPROMPT XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CNDIR XFORM ((1 SETQ *DEFAULT-PATHNAME-DEFAULTS*) (EMBED 3 IN PARSE-NAMESTRING))) (PUTPROPS COMPILE XFORM ((REMARK COMPILE%:))) (PUTPROPS CONCAT XFORM ((1 CONCATENATE 'STRING) (NTH 3) DOTHESE 1 (LPQ (IF (STRINGP (%##)) NIL ((MBD STRING))) NX))) (PUTPROPS COND XFORM (1 (LPQ NX (ORR DOTHESE NIL)))) (PUTPROPS CONS XFORM [(ORR (3) ((ORR (2 (A NIL)) ((N NIL NIL]) (PUTPROPS CONSCOUNT XFORM ((1 QUOTE 0) (REMARK CONSCOUNT%:))) (PUTPROPS CONSTANT XFORM ((XTR 2) DOTHIS)) (PUTPROPS CONSTANTS XFORM ((1 PROGN) 2 (LPQ [ORR (2 DOTHIS 0 (-1 DEFCONSTANT)) ((IF (AND (GETTOPVAL (%##)) (NEQ (GETTOPVAL (%##)) 'NOBIND)) [(I MBD (LIST 'DEFCONSTANT '& (KWOTE (GETTOPVAL (%##] ((MBD DEFCONSTANT) (REMARK CONSTANTS%:] NX))) (PUTPROPS COPY XFORM ((1 COPY-TREE))) (PUTPROPS COPYALL XFORM ((1 COPY-TREE) (REMARK COPYALL%:))) (PUTPROPS COPYBYTES XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS COPYCHARS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS COPYREADTABLE XFORM ((1 COPY-READTABLE))) (PUTPROPS COS XFORM [(IF (%## 3) ((3)) ((EMBED 2 IN (TIMES & (/ (FLOAT PI &) 180]) (PUTPROPS COUNT XFORM ((REMARK COUNT%:))) (PUTPROPS CREATE.NUMBERPAD.READER XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CREATEREGION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS CREATEW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DATATYPE XFORM ((1 DEFSTRUCT) 3 1 (LPQ (ORR ((XTR 1)) NIL) NX) 0 0 (NTH 3) [LPQ (IF (%## 2) ((IF (EQ '_ (%## 3)) ((I EMBED 1 (LIST 'F (%## 2) NIL) 1 'IN (LIST '& (%## 4))) (BI 2 4) (2)) ((REMARK RECORD1%:] (BO 1))) (PUTPROPS DATE XFORM ((ORR (2) NIL) (1 MULTIPLE-VALUE-BIND (SEC MIN HR DA MO YR) (GET-DECODED-TIME) (CONCATENATE 'STRING DA "-" (CASE MO (1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun") (7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec")) "-" YR " " HR ":" MIN ":" SEC)) (REMARK DATE%:) NLAM)) (PUTPROPS DECLARE XFORM ((IF (EQ (%## 2 1) 'SPECVARS) [(IF (%## 3) ((REMARK DECLARE%:) (MBD *) DOTHIS) (2 (1 SPECIAL) (REMARK DECLARE1%:] ((MBD *) DOTHIS)))) (PUTPROPS DECLARE%: XFORM ((IF (EQ (%## 2) 'EVAL@COMPILE) ((1 PROGN) (2)) ((MBD *) DOTHIS)))) (PUTPROPS DEF XFORM ((1 DEFUN) 3 MARK DOTHIS __ UP (BO 1) (DELETE 1) NLAM)) (PUTPROPS DEFINE-FILE-INFO XFORM ((E (SETREADTABLE (FIND-READTABLE (LISTGET (%## (NTH 2)) :READTABLE))) T) (E (LISTPUT (%## (NTH 2)) :PACKAGE "XCL") T) (E (LISTPUT (%## (NTH 2)) :READTABLE "XCL") T))) (PUTPROPS DEFINEQ XFORM ((1 PROGN) 2 (LPQ (-1 DEF) NX))) (PUTPROPS DEFPRINT XFORM ((REMARK DEFPRINT%:) (MBD *) DOTHIS)) (PUTPROPS DEL.PROCESS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DELETEMENU XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DELFILE XFORM ((1 DELETE-FILE))) (PUTPROPS DETACHALLWINDOWS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DIFFERENCE XFORM ((1 -))) (PUTPROPS DIRECTORYNAME XFORM [(COMS (SELECTQ (CADR (%##)) [NIL '(%: (USER-HOMEDIR-PATHNAME] (T '(%: *DEFAULT-PATHNAME-DEFAULTS*)) '(REMARK DIRECTORYNAME%:]) (PUTPROPS DISMISS XFORM ((1 SLEEP) (EMBED 2 IN (/ & 1000)) 2 2 DOTHIS)) (PUTPROPS DO XFORM ((-1 for) DOTHIS)) (PUTPROPS DREMOVE XFORM [(1 DELETE) MARK 0 (IF (MEMB (%## 1) '(SETQ REPLACE RPLACA RPLACD replace change PUTPROP SET PUTASSOC SETPROPLIST SETTOPVAL)) NIL ((REMARK DREMOVE%:]) (PUTPROPS DREVERSE XFORM ((1 NREVERSE))) (PUTPROPS DRIBBLE XFORM ((IF (%## (NTH 3)) ((REMARK DRIBBLE%:)) NIL))) (PUTPROPS DSPCLIPPINGREGION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPCREATE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPFILL XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPFONT XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPRESET XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPRIGHTMARGIN XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPSCROLL XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPXPOSITION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSPYPOSITION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS DSUBLIS XFORM ((1 NSUBLIS) (ORR ((4) (REMARK SUBLIS%:)) NIL))) (PUTPROPS DSUBST XFORM ((1 NSUBST))) (PUTPROPS DV XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ECHOCONTROL XFORM ((1 NILL))) (PUTPROPS EDITE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS EDITV XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ELT XFORM ((1 AREF))) (PUTPROPS EOFP XFORM ((1 =) (EMBED 2 IN (FILE-POSITION &) (FILE-LENGTH &)))) (PUTPROPS EQLENGTH XFORM ((EMBED 2 IN LENGTH) (1 =))) (PUTPROPS EQP XFORM ((1 =))) (PUTPROPS ERROR XFORM ((ORR ((4)) NIL) (1 CERROR "~a~%%~a"))) (PUTPROPS ERROR! XFORM ((1 ABORT) (REMARK ERROR!%:))) (PUTPROPS ERRORSET XFORM ((REMARK ERRORSET%:))) (PUTPROPS ERSETQ XFORM ((1 CATCH-ABORT) (REMARK NLSETQ%:))) (PUTPROPS EVENP XFORM ((ORR (3 0 (1 IMOD) (MBD ZEROP)) NIL))) (PUTPROPS EVERY XFORM ([ORR ((IF (%## 4))) (4 'CDR) ((N 'CDR] (I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1))) ((NOT (CONSP $$TEM1)) T) (COND ((NOT (APPLY* %#F (CAR $$TEM1) $$TEM1)) (RETURN] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __)) (PUTPROPS EXPRP XFORM ((EMBED 2 IN (FUNCTIONP &) (NOT (COMPILED-FUNCTION-P &))) (1 AND))) (PUTPROPS FASSOC XFORM ((1 ASSOC))) (PUTPROPS FCHARACTER XFORM ((1 CHARACTER) (MBD INTERN) NLAM)) (PUTPROPS FETCH XFORM ((1 fetch) DOTHIS)) (PUTPROPS FIELDLOOK XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FILECOMS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FILECOMSLST XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FILENAMEFIELD XFORM [(IF (EQ (CAR (CADDR (%##))) 'QUOTE) [(COMS (SELECTQ (CADR (%## 3)) [HOST '(COMSQ (1 PATHNAME-HOST) (3] [DEVICE '(COMSQ (1 PATHNAME-DEVICE) (3] [DIRECTORY '(COMSQ (1 PATHNAME-DIRECTORY) (3] [NAME '(COMSQ (1 PATHNAME-NAME) (3] [EXTENSION '(COMSQ (1 PATHNAME-TYPE) (3] [VERSION '(COMSQ (1 PATHNAME-VERSION) (3] '(REMARK FILENAMEFIELD%:] ((REMARK FILENAMEFIELD%:]) (PUTPROPS FILEPKGCHANGES XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FILESLOAD XFORM ((-1 *) DOTHIS)) (PUTPROPS FINDFILE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FIX XFORM ((1 TRUNCATE))) (PUTPROPS FIXP XFORM ((1 INTEGERP) TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2)) NLAM) ([1 FUNCALL (LAMBDA (X) (AND (INTEGERP X) X] 2 DOTHIS (REMARK NUMBERP1%:] [UNKNOWN '(COMSQ (REMARK NUMBERP%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2)) NLAM] NIL)))) (PUTPROPS FLASHWINDOW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FLAST XFORM ((1 LAST))) (PUTPROPS FLESSP XFORM ((1 #:<))) (PUTPROPS FLOATP XFORM (TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2)) NLAM) ([1 FUNCALL (LAMBDA (X) (AND (FLOATP X) X] 2 DOTHIS (REMARK NUMBERP1%:] [UNKNOWN '(COMSQ (REMARK NUMBERP%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2)) NLAM] NIL)))) (PUTPROPS FMAX XFORM ((1 MAX))) (PUTPROPS FMEMB XFORM ((1 MEMBER))) (PUTPROPS FMIN XFORM ((1 MIN))) (PUTPROPS FNTH XFORM ((1 NTHCDR) (SW 2 3) (EMBED 2 IN 1-))) (PUTPROPS FNTYP XFORM ([EMBED 2 IN (AND (FBOUNDP &) (NOT (SPECIAL-FORM-P &)) (NOT (MACRO-FUNCTION &] (XTR 2) (REMARK FNTYP%:))) (PUTPROPS FONTCREATE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FONTPROP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS FOR XFORM ((1 for) DOTHIS)) (PUTPROPS FORCEOUTPUT XFORM [(COMS (SELECTQ (CADDR (%##)) [T '(COMSQ (1 FINISH-OUTPUT) (3] (NIL '(1 FORCE-OUTPUT)) '(COMSQ (REMARK FORCEOUTPUT%:) (1 FORCE-OUTPUT]) (PUTPROPS FQUOTIENT XFORM ((1 /) (EMBED 3 IN FLOAT))) (PUTPROPS FRPLACA XFORM ((1 RPLACA))) (PUTPROPS FRPLACD XFORM ((1 RPLACD))) (PUTPROPS FTIMES XFORM ((1 *))) (PUTPROPS FUNCTION XFORM ((IF (GETPROP (%## 2) 'XFORM) [(REMARK FUNCTION%:) (S ORIGFNNAME 2) (I EMBED 2 'IN (CONS '& (ARGLIST ORIGFNNAME))) MARK 2 DOTHIS __ 2 (IF (EQUAL (%## (NTH 2)) (ARGLIST ORIGFNNAME)) ((XTR 1)) ([MBD (LAMBDA NIL &] (I 2 (ARGLIST ORIGFNNAME] NIL))) (PUTPROPS GEQ XFORM ((1 >=))) (PUTPROPS GETBOXPOSITION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS GETD XFORM ((EMBED 2 IN (FBOUNDP &) (SYMBOL-FUNCTION &)) (1 AND))) (PUTPROPS GETFILEINFO XFORM [(IF (EQ (%## 3 1) 'QUOTE) [(COMS (SELECTQ (%## 3 2) [WRITEDATE '(COMSQ (1 FILE-WRITE-DATE) (3] [AUTHOR '(COMSQ (1 FILE-AUTHOR) (3] [LENGTH '(COMSQ (1 FILE-LENGTH) (3] '(REMARK GETFILEINFO%:] ((REMARK GETFILEINFO%:]) (PUTPROPS GETFILEPTR XFORM ((1 FILE-POSITION))) (PUTPROPS GETPROP XFORM ((1 GET))) (PUTPROPS GETPROPLIST XFORM ((1 SYMBOL-PLIST))) (PUTPROPS GETPROPMPTWINDOW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS GETREGION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS GETRELATION XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS GETTOPVAL XFORM ((1 SYMBOL-VALUE))) (PUTPROPS GETWINDOWPROP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS GIVE.TTY.PROCESS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS GLOBALVARS XFORM ((1 *) DOTHIS)) (PUTPROPS GREATERP XFORM ((1 >))) (PUTPROPS HARRAY XFORM ((1 MAKE-HASH-TABLE :SIZE))) (PUTPROPS HARRAYP XFORM ((1 HASH-TABLE-P))) (PUTPROPS HARRAYSIZE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS HASHARRAY XFORM ((1 MAKE-HASH-TABLE :SIZE) (ORR ((-4 :REHASH-SIZE)) NIL))) (PUTPROPS HASHARRAYP XFORM ((1 HASH-TABLE-P))) (PUTPROPS HASHLINK XFORM ((MBD *) DOTHIS)) (PUTPROPS HELP XFORM ((1 CERROR "Help ~a~%%~a"))) (PUTPROPS IDATE XFORM [(IF (%## 2) ((1 ENCODE-UNIVERSAL-TIME) (REMARK IDATE%:)) ((1 GET-UNIVERSAL-TIME]) (PUTPROPS IDIFFERENCE XFORM ((1 -))) (PUTPROPS IEQP XFORM ((1 =))) (PUTPROPS IGEQ XFORM ((1 >=))) (PUTPROPS IGREATERP XFORM ((1 >))) (PUTPROPS ILEQ XFORM ((1 <=))) (PUTPROPS ILESSP XFORM ((1 #:<))) (PUTPROPS IMAX XFORM ((1 MAX))) (PUTPROPS IMIN XFORM ((1 MIN))) (PUTPROPS IMINUS XFORM ((1 -))) (PUTPROPS IMOD XFORM ((1 MOD))) (PUTPROPS INFILE XFORM ((EMBED 2 IN (OPENSTREAM & 'INPUT)) (1 INPUT) DOTHIS)) (PUTPROPS INFILECOMTAIL XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS INFILEP XFORM ((1 PROBE-FILE))) (PUTPROPS INPUT XFORM [(IF (%## 2) ((1 PROG1 *STANDARD-INPUT*) (EMBED 3 IN (SETQ *STANDARD-INPUT* &))) ((%: *STANDARD-INPUT*]) (PUTPROPS INTEGERLENGTH XFORM ((1 INTEGER-LENGTH))) (PUTPROPS INTERRUPTCHAR XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS IOFILE XFORM ((1 OPENFILE) (N 'BOTH 'OLD) DOTHIS)) (PUTPROPS IPLUS XFORM ((1 +))) (PUTPROPS IQUOTIENT XFORM ((1 TRUNCATE))) (PUTPROPS IREMAINDER XFORM ((1 REMAINDER))) (PUTPROPS ITIMES XFORM ((1 *))) (PUTPROPS KWOTE XFORM ((REMARK KWOTE%:))) (PUTPROPS L-CASE XFORM [(IF (CADDR (%##)) ((1 STRING-CAPITALIZE) (3)) ((1 STRING-DOWNCASE]) (PUTPROPS LAMBDA XFORM ((IF (AND (%## 2) (LITATOM (%## 2))) ((EMBED 2 IN &REST) (NTH 3) (E (OR (BOUNDP 'LAMNS) (SETQ LAMNS)) T) MARK (E (SETQ UPFINDFLG) T) (E (SETQ LAMNS (CONS (%## 0 2 -1) LAMNS)) T) (LPQ (I F (CAR LAMNS) 'N) (IF (EQ (%## BK) 'ARG) NIL ((MBD LENGTH) -1))) (E (SETQ UPFINDFLG T) T) (E (SETQ LAMNS (CDR LAMNS)) T) __ DW DOTHESE) (DW (NTH 3) DOTHESE)))) (PUTPROPS LASTC XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS LAYOUTGRAPH XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS LAYOUTSEXPR XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS LDIFF XFORM ((ORR (4 0 (MBD NCONC) (MOVE 2 4 TO -2)) NIL) (REMARK LDIFF%:))) (PUTPROPS LDIFFERENCE XFORM ((1 SET-DIFFERENCE))) (PUTPROPS LENGTH XFORM ((1 LIST-LENGTH))) (PUTPROPS LEQ XFORM ((1 <=))) (PUTPROPS LESSP XFORM ((1 #:<))) (PUTPROPS LET XFORM (MARK 2 1 (LPQ (IF (OR (LITATOM (%##)) (EQ (%## 1) (%## 2))) NIL (2 DOTHIS 0)) NX) __ (NTH 3) DOTHESE)) (PUTPROPS LET* XFORM (MARK 2 1 (LPQ (IF (OR (LITATOM (%##)) (EQ (%## 1) (%## 2))) NIL (2 DOTHIS 0)) NX) __ (NTH 3) DOTHESE)) (PUTPROPS LISPVERSION XFORM ((1 LISP-IMPLEMENTATION-VERSION))) (PUTPROPS LISPX XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS LISPXPRINT XFORM ((1 PRINT) (ORR ((5)) NIL) DOTHIS)) (PUTPROPS LISPXREAD XFORM ((1 READ))) (PUTPROPS LISPXREADP XFORM ((1 READP) (REMARK READP%:))) (PUTPROPS LISPXUNREAD XFORM ((REMARK LISPXUNREAD%:) (%:))) (PUTPROPS LISTFILES1 XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS LISTGET XFORM ((1 GETF))) (PUTPROPS LISTP XFORM ((1 CONSP) TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2))) ([1 FUNCALL (LAMBDA (X) (AND (CONSP X) X] (REMARK LISTP%:] [UNKNOWN '(COMSQ (REMARK LISTP1%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2] NIL)))) (PUTPROPS LISTPUT XFORM ((1 SETF LISTGET) (BI 2 4))) (PUTPROPS LITATOM XFORM ((1 SYMBOLP))) (PUTPROPS LLSH XFORM ((1 *) (EMBED 3 IN (EXPT 2 &)))) (PUTPROPS LOAD XFORM ((ORR ((-4 :VERBOSE)) NIL) (ORR (3 (ORR ((IF (%##)) (REMARK LOAD%:)) NIL) (%:)) NIL))) (PUTPROPS LOAD? XFORM ((1 LOAD) DOTHIS (REMARK LOAD?%:))) (PUTPROPS LOADFNS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS LOCALVARS XFORM ((MBD *) DOTHIS)) (PUTPROPS LOGOR XFORM ((1 LOGIOR))) (PUTPROPS LOGOUT XFORM ((1 EXIT) (REMARK LOGOUT%:))) (PUTPROPS LRSH XFORM [(1 LDB) (SW 2 3) (I 2 (LIST 'BYTE [COND ((NUMBERP (%## 2)) (DIFFERENCE 32 (%## 2))) (T (LIST '- 32 (%## 2] (%## 2]) (PUTPROPS LSH XFORM ((1 ASH))) (PUTPROPS LSUBST XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS MACHINETYPE XFORM ((1 MACHINE-TYPE))) (PUTPROPS MAP XFORM [(1 MAPL) (IF (%## 4) ((I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '(DO (($$TEM1 %#L (APPLY* %#TL $$TEM1))) (NOT (CONSP $$TEM1)) (APPLY* %#F $$TEM1)) T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __) ((SW 2 3]) (PUTPROPS MAP2C XFORM [(IF (%## 5) ((REMARK MAP2C%:)) ((1 MAPC) (MOVE 4 TO B 2]) (PUTPROPS MAP2CAR XFORM [(IF (%## 5) ((REMARK MAP2C%:)) ((1 MAPCAR) (MOVE 4 TO B 2]) (PUTPROPS MAPC XFORM [(IF (%## 4) ((I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '(DO (($$TEM1 %#L (APPLY* %#TL $$TEM1))) (NOT (CONSP $$TEM1)) (APPLY* %#F (CAR $$TEM1))) T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __) ((SW 2 3]) (PUTPROPS MAPCAR XFORM [(IF (%## 4) ((I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1)) ($$VAL) ($$TEM3) ($$TEM2)) ((NOT (CONSP $$TEM1)) $$VAL) (SETQ $$TEM3 (APPLY* %#F (CAR $$TEM1))) (COND [$$TEM2 (RPLACD $$TEM2 (SETQ $$TEM2 (LIST $$TEM3] (T (SETQ $$VAL (SETQ $$TEM2 (LIST $$TEM3] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __) ((SW 2 3]) (PUTPROPS MAPCON XFORM [(IF (%## 4) ((I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1)) ($$VAL)) ((NOT (CONSP $$TEM1)) $$VAL) (SETQ $$VAL (NCONC $$VAL (APPLY* %#F $$TEM1] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __) ((SW 2 3]) (PUTPROPS MAPCONC XFORM [(IF (%## 4) ((I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1)) ($$VAL)) ((NOT (CONSP $$TEM1)) $$VAL) (SETQ $$VAL (NCONC $$VAL (APPLY* %#F (CAR $$TEM1] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __) ((SW 2 3) (1 MAPCAN]) (PUTPROPS MAPHASH XFORM ((SW 2 3) 2 [IF (%## 2 2) (2 2 (SW 1 2)) ((MBD (FUNCTION (LAMBDA (X Y) (APPLY* & Y X] 0)) (PUTPROPS MAPLIST XFORM [(IF (%## 4) ((I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1)) ($$VAL) ($$TEM3) ($$TEM2)) ((NOT (CONSP $$TEM1)) $$VAL) (SETQ $$TEM3 (APPLY* %#F $$TEM1)) (COND [$$TEM2 (RPLACD $$TEM2 (SETQ $$TEM2 (LIST $$TEM3] (T (SETQ $$VAL (SETQ $$TEM2 (LIST $$TEM3] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __) ((SW 2 3]) (PUTPROPS MARKASCHANGED XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS MASTERSCOPE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS MEMB XFORM ((1 MEMBER))) (PUTPROPS MEMBER XFORM ((N :TEST (FUNCTION EQUAL)))) (PUTPROPS MENU XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS MERGE XFORM [(-2 'LIST) (IF (%## 5) ((IF (EQ (%## 5) T) [(5 (FUNCTION (LAMBDA (A B) (STRING< (CAR A) (CAR B] NIL)) ((N 'STRING<]) (PUTPROPS MINUS XFORM ((1 -))) (PUTPROPS MISSPELLED? XFORM ((XTR 2))) (PUTPROPS MKATOM XFORM ((1 string) (MBD INTERN))) (PUTPROPS MKSTRING XFORM [(IF (%## (NTH 3)) ((1 PRIN1-TO-STRING) (3) (IF (%## 3) ((REMARK MKSTRING%:)) NIL)) ((1 PRINC-TO-STRING]) (PUTPROPS MOUSECONFIRM XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS MOVETO XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS NCHARS XFORM ((1 LENGTH) (EMBED 2 IN STRING))) (PUTPROPS NCONC1 XFORM ((1 NCONC) (-3 LIST) (LI 3))) (PUTPROPS NEQ XFORM ((1 EQ) (MBD NOT))) (PUTPROPS NEWPRINTDEF XFORM ((1 PRINTDEF) DOTHIS)) (PUTPROPS NLAMBDA XFORM ((REMARK NLAMBDA%:) (NTH 3) DW DOTHESE)) (PUTPROPS NLEFT XFORM (MARK (NTH 2) DOTHESE __ [I %: (SUBPAIR '(%#L %#N %#TAIL) (%## (NTH 2)) '(LET ((LTEMP %#L) (TAILTEMP %#TAIL)) (DO ((LTAIL LTEMP (CDR LTAIL)) (TAILTAIL (NTHCDR LTEMP N) (CDR TAILTAIL))) ((EQL TAILTAIL TAILTEMP) LTAIL] (REMARK NLEFT%:))) (PUTPROPS NLISTP XFORM ((1 ATOM))) (PUTPROPS NLSETQ XFORM ((1 CATCH-ABORT) (NTH 2) DOTHESE 0 (MBD (HANDLER-CASE & (ERROR NIL NIL))) (REMARK NLSETQ%:))) (PUTPROPS NOTANY XFORM [(IF (%## 4) ((1 SOME) (MBD NOT)) ((SW 2 3]) (PUTPROPS NOTEVERY XFORM ((1 EVERY) (MBD NOT))) (PUTPROPS NTH XFORM [(1 NTHCDR) (SW 2 3) (IF (NUMBERP (%## 2)) [(I 2 (SUB1 (%## 2] ((EMBED 2 IN 1-]) (PUTPROPS NTHCHAR XFORM ((1 AREF) (EMBED 2 IN STRING) (EMBED 3 IN 1-) (IF (%## (NTH 4)) ((REMARK NTHCHAR%:)) NIL))) (PUTPROPS NTHCHARCODE XFORM ((1 AREF) (EMBED 2 IN STRING) (EMBED 3 IN 1-) (IF (%## (NTH 4)) ((REMARK NTHCHAR%:)) NIL) (MBD CHAR-CODE))) (PUTPROPS NTYPX XFORM ((REMARK NTYPX%:))) (PUTPROPS NUMBERP XFORM (TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2)) NLAM) ([1 FUNCALL (LAMBDA (X) (AND (NUMBERP X) X] 2 DOTHIS (REMARK NUMBERP1%:] [UNKNOWN '(COMSQ (REMARK NUMBERP%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2)) NLAM] NIL)))) (PUTPROPS NUMBERPAD.READ XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ODDP XFORM ((ORR [3 0 (1 IMOD) (MBD (NOT (ZEROP &] NIL))) (PUTPROPS OPENFILE XFORM [(1 OPEN) (-3 :DIRECTION) (I 4 (SELECTQ (%## 4 2) (INPUT :INPUT) (OUTPUT :OUTPUT) (BOTH :IO) (APPEND :APPEND) (%## 4))) (ORR (6 (REMARK OPENFILE1%:) 0 (6)) NIL) (ORR (5 0) ((N NIL))) (IF (EQUAL (%## 5) ''OLDEST) ((REMARK OPENFILE2%:) (5 'OLD)) NIL) (IF (EQ (%## 4) :APPEND) ((N :IF-EXISTS :APPEND) (IF (EQUAL (%## 5) ''OLD) ((5)) ((5 :IF-DOES-NOT-EXIST :CREATE))) (4 :OUTPUT)) ((COMS (SELECTQ (%## 5) (NEW '(5 :IF-EXISTS :NEW-VERSION)) (OLD '(5 :IF-EXISTS :OVERWRITE)) (OLD/NEW '(5 :IF-EXISTS :OVERWRITE :IF-DOES-NOT-EXIST :CREATE)) '(COMS (SELECTQ (%## 4) (:OUTPUT '(5 :IF-EXISTS :NEW-VERSION)) (:INPUT '(5)) '(5 :IF-EXISTS :OVERWRITE :IF-DOES-NOT-EXIST :CREATE]) (PUTPROPS OPENLAMBDA XFORM (DW)) (PUTPROPS OPENSTREAM XFORM ((1 OPENFILE) DOTHIS)) (PUTPROPS OPENW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS OPENWP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS OUTFILE XFORM [(IF (%## 2) ((ORR [(EMBED 2 IN (OPENSTREAM & 'OUTPUT] NIL) (1 OUTPUT) DOTHIS) ((%: *STANDARD-OUTPUT*]) (PUTPROPS OUTPUT XFORM [(IF (%## 2) ((1 PROG1 *STANDARD-OUTPUT*) (EMBED 3 IN (SETQ *STANDARD-OUTPUT* &))) ((%: *STANDARD-OUTPUT*]) (PUTPROPS PACK XFORM (2 DOTHIS (MBD (APPLY (FUNCTION CONCATENATE) 'STRING (MAPCAR (FUNCTION STRING) &))) 0 (1 INTERN) (REMARK UNPACK%:))) (PUTPROPS PACK* XFORM ((1 CONCAT) (MBD INTERN))) (PUTPROPS PACKC XFORM ((1 CL:MAP 'STRING (FUNCTION CHARACTER)) (MBD INTERN) 2 4 DOTHIS)) (PUTPROPS PACKFILENAME XFORM ((1 MAKE-PATHNAME) (LPQ (IF (EQ (%## 2 1) 'QUOTE) ((COMS (SELECTQ (%## 2 2) (HOST '(2 :HOST)) (DEVICE '(2 :DEVICE)) (DIRECTORY '(2 :DIRECTORY)) (NAME '(2 :NAME)) (EXTENSION '(2 :TYPE)) (VERSION '(2 :VERSION)) [BODY '(COMSQ (2 :DEFAULTS) (REMARK PACKFILENAME%:] NIL))) ((ORR (2 (REMARK PACKFILENAME1%:) 0) NIL))) 3 UP))) (PUTPROPS PEEKC XFORM ((1 PEEK-CHAR) (ORR (2 (B NIL)) NIL))) (PUTPROPS PLUS XFORM ((1 +))) (PUTPROPS POSITION XFORM ((REMARK POSITION%:))) (PUTPROPS PRETTYCOMPRINT XFORM ((MBD *) DOTHIS)) (PUTPROPS PRIN1 XFORM ((1 PRINC))) (PUTPROPS PRIN2 XFORM ((1 PRIN1))) (PUTPROPS PRIN3 XFORM ((1 PRINC))) (PUTPROPS PRINT XFORM [P (IF (CDDR (%##)) [(IF (LITATOM (%## 3)) [(1 PRINC) (MBD PROGN) (I N (LIST 'TERPRI (%## 2 3] ([1 (LAMBDA (OBJ &OPTIONAL FILE) (PRIN1 OBJ FILE) (TERPRI FILE) OBJ] (NTH 2) DOTHESE (REMARK PRINT%:] ((1 PRINC) (MBD PROGN) (N (TERPRI]) (PUTPROPS PRINTBELLS XFORM ((1 PRINC ""))) (PUTPROPS PRINTDEF XFORM ((1 WRITE) (ORR (3 (IF (%##) ((REMARK PRINTDEF%:)) NIL) (%:) 0) NIL) (ORR ((3)) NIL) (ORR (3 (IF (%##) ((REMARK PRINTDEF%:)) NIL) (%:) 0) NIL) (ORR ((3)) NIL) (ORR (3 (B :STREAM) 0) NIL) (N :PRETTY T))) (PUTPROPS PRINTNUM XFORM [(IF (EQ (%## 2 1) 'QUOTE) [(COMS (SELECTQ (%## 2 2 1) [FIX '(COMSQ (I 2 (CONCAT "~" (COND ((MEMB (CADDR (%## 2 2)) '(10 8 2 16 NIL)) "") ((NUMBERP (%## 2 2 3)) (CONCAT (%## 2 2 3) ",")) (T (SHOULDNT))) (COND ((NUMBERP (CADR (%## 2 2))) (%## 2 2 2)) (T "")) (COND ((CADDDR (%## 2 2)) ",'0") (T "")) (SELECTQ (CADDR (%## 2 2)) ((NIL 10) "D") (8 "O") (2 "B") (16 "X") "R"))) (1 FORMAT) (IF (%## (NTH 4)) ((MOVE 4 TO B 2)) ((-2 NIL))) (COMS (SELECTQ (%## 2) (NIL '(2 T)) (T '(2 *TERMINAL-IO*)) NIL] [FLOAT '(COMSQ (I 2 (CONCAT "~" (COND ((CADR (%## 2 2)) (%## 2 2 2))) "," (COND ((CADDR (%## 2 2)) (%## 2 2 3)) (T "")) (SELECTQ (CADDDR (%## 2 2)) ((NIL 0) "") (CONCAT "," (%## 2 2 4))) (COND ((CAR (CDDDDR (%## 2 2))) ",,,'0") (T "")) (SELECTQ (CADDDR (%## 2 2)) ((NIL 0) "F") "E"))) (1 FORMAT) (IF (%## (NTH 4)) ((MOVE 4 TO B 2)) ((-2 NIL))) (COMS (SELECTQ (%## 2) (NIL '(2 T)) (T '(2 *TERMINAL-IO*)) NIL] '(COMSQ (1 PRINC) (2) (REMARK PRINTNUM%:] (((1 PRINC) (2) (REMARK PRINTNUM%:]) (PUTPROPS PRINTOUT XFORM ((1 printout) DOTHIS)) (PUTPROPS PROCESSP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS PROCESSPROP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS PROG XFORM (MARK 2 1 (LPQ (IF (OR (LITATOM (%##)) (EQ (%## 1) (%## 2))) NIL (2 DOTHIS 0)) NX) __ (NTH 3) DOTHESE)) (PUTPROPS PROGN XFORM ((ORR (3) ((XTR 2) DOTHIS) NIL))) (PUTPROPS PROMPTCHAR XFORM ((1 PRINC))) (PUTPROPS PROMPTPRINT XFORM ((1 PRINT) DOTHIS (REMARK PROMPTPRINT%:))) (PUTPROPS PUSH XFORM ((1 push) DOTHIS)) (PUTPROPS PUSHLIST XFORM ((1 pushlist) DOTHIS)) (PUTPROPS PUSHNEW XFORM ((1 pushnew) DOTHIS)) (PUTPROPS PUTASSOC XFORM ((REMARK PUTASSOC%:))) (PUTPROPS PUTD XFORM ((1 SETF) (EMBED 2 IN SYMBOL-FUNCTION))) (PUTPROPS PUTHASH XFORM ((1 SETF GETHASH) (SW 4 5) (BI 2 4))) (PUTPROPS PUTPROP XFORM ((1 SETF GET) (BI 2 4))) (PUTPROPS PUTPROPS XFORM ((IF (EQ 'MACRO (%## 3)) [(1 DEFMACRO) (3) (ORR [(BO 3) (NTH 4) DW DOTHESE !0 (COMS (SELECTQ (%## 3) [NIL '(COMSQ (ORR (5 0 (EMBED (4 THRU) IN PROGN)) NIL) (EMBED 4 IN QUOTE] [[LAMBDA OPENLAMBDA] '(COMSQ (-3 (&REST ACTUAL)) (IF (EQ (%## 4) 'OPENLAMBDA) ((4 LAMBDA)) NIL) (LI 4) (EMBED 4 IN `(& ,@ACTUAL] [NLAMBDA '(REMARK PUTPROPS%:] (COND [(LISTP (%## 3)) '(COMSQ (ORR (5 0 (EMBED (4 THRU) IN PROGN)) NIL) (EMBED 4 IN `&) (I 4 (SUBPAIR (%## 3) [MAPCAR (%## 3) (FUNCTION (LAMBDA (X) (LIST '\, X] (%## 4) T] ((LITATOM (%## 3)) '(EMBED 3 IN &REST)) (T '(REMARK PUTPROPS1%:] ((IF (EQ (%## 3 1) '=) [(I 3 '(&REST ACTUAL) (LIST 'BQUOTE (CDR (%## 3)) '%,@ACTUAL] NIL] ((1 PUTPROP) (EMBED 2 IN QUOTE) (EMBED 3 IN QUOTE) (EMBED 4 IN QUOTE) DOTHIS)))) (PUTPROPS QUOTE XFORM (NLAM)) (PUTPROPS QUOTIENT XFORM ((1 /))) (PUTPROPS RAND XFORM [(1 RANDOM) (IF (ZEROP (%## 2)) [(2) (IF (NUMBERP (%## 2)) ((IF (FIXP (%## 2)) [(I 2 (PLUS 1 (%## 2] NIL)) ((REMARK RAND%:] ((MBD +) (INSERT (%## 2 2) BEFORE 2) 3 (SW 2 3) (-2 -) (LI 2) 2 (IF (AND (NUMBERP (%## 2)) (NUMBERP (%## 3))) [(IF (AND (FIXP (%## 2)) (FIXP (%## 3))) [(I %: (PLUS 1 (DIFFERENCE (%## 2) (%## 3] ((I %: (DIFFERENCE (%## 2) (%## 3] ((IF (OR (FLOATP (%## 2)) (FLOATP (%## 3))) NIL ((REMARK RAND%:]) (PUTPROPS RANDSET XFORM [(1 MAKE-RANDOM-STATE) (MBD (PROG1 *RANDOM-STATE* (SETQ *RANDOM-STATE* &]) (PUTPROPS RATOM XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS READC XFORM ((1 READ-CHAR))) (PUTPROPS READLINE XFORM ((1 READ-LINE))) (PUTPROPS READP XFORM ((1 LISTEN))) (PUTPROPS READTABLEP XFORM (TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2)) NLAM) ([1 FUNCALL (LAMBDA (X) (AND (READTABLEP X) X] 2 DOTHIS (REMARK NUMBERP1%:] [UNKNOWN '(COMSQ (REMARK NUMBERP1%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2)) NLAM] NIL)))) (PUTPROPS READVISE XFORM ((REMARK READVISE%:))) (PUTPROPS RECLOOK XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS RECORD XFORM ((IF [NULL (CDR (LAST (%## 3] [(1 DEFSTRUCT) (NTH 3) [LPQ (IF (%## 2) ((IF (EQ '_ (%## 3)) ((I EMBED 1 (LIST 'F (%## 2) NIL) 1 'IN (LIST '& (%## 4))) (BI 2 4) (2)) ((REMARK RECORD1%:] (BO 1) 0 (E (CLISP% ([LAMBDA ($$1) (COND ((FMEMB $$1 XlatedRecords) XlatedRecords) (T (SETQ XlatedRecords (CONS $$1 XlatedRecords] (%## 2)) pushnew XlatedRecords (%## 2)) T) (EMBED 2 IN (& (:TYPE LIST] ((MBD *) DOTHIS)))) (PUTPROPS REGIONP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS REMOVE XFORM ((N :TEST (FUNCTION EQUAL)))) (PUTPROPS REMPROPLIST XFORM [(NTH 2) DOTHESE 0 (I %: (SUBPAIR '(ATM PROPS) (%## (NTH 2)) '(DO ((ATTM ATM) (PROPC PROPS (CDR PROPC))) ((NOT (CONSP PROPC))) (REMPROP ATTM (CAR (PROPC]) (PUTPROPS REPLACE XFORM ((1 replace) DOTHIS)) (PUTPROPS RESETFORM XFORM [(1 LET) (NTH 2) DOTHESE 0 (EMBED 2 IN ((OLD-VALUE &))) (IF (CDR (%## (NTH 3))) [(EMBED (3 THRU) IN (UNWIND-PROTECT (PROGN &] ((EMBED 3 IN UNWIND-PROTECT))) 3 (I N (LIST (%## 0 2 1 2 1) 'OLD-VALUE]) (PUTPROPS RESETLST XFORM [(NTH 2) DOTHESE 0 [EMBED (2 THRU) IN (UNWIND-PROTECT (PROGN &) (DO ((RESETZ *RESETFORMS* (CDR RESETZ)) OLDVALUE) ((NULL RESETZ)) (DECLARE (SPECIAL OLDVALUE)) (COND ((CONSP (CAAR RESETZ)) (SETQ OLDVALUE (IF (CDAR RESETZ) (CADAR RESETZ) (CADAAR RESETZ))) (APPLY (CAAAR RESETZ) (CDAAR RESETZ))) (T (SETF (SYMBOL-VALUE (CAAR RESETZ)) (CDAR RESETZ] (1 LET (*RESETFORMS*) (DECLARE (SPECIAL *RESETFORMS*]) (PUTPROPS RESETSAVE XFORM [(1 PUSH) (N *RESETFORMS*) (IF (LITATOM (%## 2)) (3 DOTHIS (MBD (SETF (SYMBOL-VALUE 'X) &)) 0 (INSERT (%## 2) FOR 3 2 2) [EMBED 2 IN (CONS '& (SYMBOL-VALUE '&] (EMBED (2 THRU 3) IN PROG1)) (2 DOTHIS 0 (IF (%## 4) ((SW 2 3) 2 DOTHIS 0 (EMBED (2 THRU 3) IN LIST)) ((EMBED 2 IN (LIST (LIST '& &))) 2 2 2 2 (IF (EQ (%## 1) 'SETQ) ((XTR 3 1)) ((XTR 1]) (PUTPROPS RESETVAR XFORM [(1 LET) (NTH 3) DOTHESE 0 (-2 PROGN SETQ) (BI 3 5) (LI 2) (EMBED 2 IN UNWIND-PROTECT) [I -2 (LIST (LIST 'OLD-VALUE (%## 2 2 2 2] 3 (I N (LIST 'SETQ (%## 2 2 2) 'OLD-VALUE]) (PUTPROPS RESETVARS XFORM ((1 LET) (NTH 3) DOTHESE 0 MARK 2 1 (LPQ (IF (OR (LITATOM (%##)) (EQ (%## 1) (%## 2))) NIL (2 DOTHIS 0)) NX) __ (-3 PROGN (PSETQ)) (LI 3) 3 2 [I N (CLISP% [MAPCONC (%## 0 0 2) (FUNCTION (LAMBDA (IV) (COND ((LISTP IV) (LIST (CAR IV) (CADR IV))) (T (LIST IV NIL] for IV in (%## 0 0 2) join (COND ((LISTP IV) (LIST (CAR IV) (CADR IV))) (T (LIST IV NIL] (BO -1) 0 0 [I N (CONS 'SETQ (CLISP% (PROG (($$LST1 (%## 2)) $$VAL IV (I 1)) $$LP [SETQ IV (CAR (OR (LISTP $$LST1) (GO $$OUT] [SETQ $$VAL (NCONC $$VAL (LIST (COND ((LISTP IV) (CAR IV)) (T IV)) (PACK* 'OLD-VALUE- I] $$ITERATE (SETQ $$LST1 (CDR $$LST1)) (SETQ I (PLUS I 1)) (GO $$LP) $$OUT (RETURN $$VAL)) for IV in (%## 2) as I from 1 join (LIST (COND ((LISTP IV) (CAR IV)) (T IV)) (PACK* 'OLD-VALUE- I] (EMBED (3 THRU) IN UNWIND-PROTECT) [I 2 (CLISP% (PROG (($$LST1 (%## 2)) $$VAL $$TEM2 $$TEM1 IV (I 1)) $$LP [SETQ IV (CAR (OR (LISTP $$LST1) (GO $$OUT] [SETQ $$TEM1 (LIST (PACK* 'OLD-VALUE- I) (COND ((LISTP IV) (CAR IV)) (T IV] [COND [$$TEM2 (FRPLACD $$TEM2 (SETQ $$TEM2 (LIST $$TEM1] (T (SETQ $$VAL (SETQ $$TEM2 (LIST $$TEM1] $$ITERATE (SETQ $$LST1 (CDR $$LST1)) (SETQ I (PLUS I 1)) (GO $$LP) $$OUT (RETURN $$VAL)) for IV in (%## 2) as I from 1 collect (LIST (PACK* 'OLD-VALUE- I) (COND ((LISTP IV) (CAR IV)) (T IV] NLAM)) (PUTPROPS RESTART.PROCESS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS RETFROM XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS RETTO XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS RNUMBER XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS RPAQ XFORM ((1 DEFPARAMETER))) (PUTPROPS RPAQ? XFORM [(1 DEFVAR) (ORR (3 DOTHIS) ((N NIL]) (PUTPROPS RPAQQ XFORM ((1 DEFPARAMETER) (EMBED 3 IN QUOTE) NLAM)) (PUTPROPS RPLNODE XFORM ((1 RPLACD RPLACA) (BI 2 4))) (PUTPROPS RPLNODE2 XFORM [(1 (LAMBDA (X Y) (RPLACA X (CAR Y)) (RPLACD X (CDR Y]) (PUTPROPS RPLSTRING XFORM ((1 REPLACE) (SW 3 4) (-4 :START1))) (PUTPROPS RSH XFORM ((1 ASH) (EMBED 3 IN -))) (PUTPROPS SASSOC XFORM ((1 ASSOC) (N %:TEST %#'EQUAL))) (PUTPROPS SCROLLBYREPAINTFN XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS SELECTC XFORM ((REMARK SELECTC2%:) 2 MARK DOTHIS __ (LPQ NX MARK (IF (%## NX UP) (DOTHESE) (DOTHIS)) __))) (PUTPROPS SELECTQ XFORM ((1 CASE) 2 MARK DOTHIS __ (LPQ NX MARK (IF (%## NX UP) ((IF (CDR (%##)) ((NTH 2) DOTHESE 0) NIL)) ((MBD OTHERWISE) 2 DOTHIS 0)) __))) (PUTPROPS SETA XFORM ((1 SETF AREF) (BI 2 4))) (PUTPROPS SETFILEPTR XFORM ((1 FILE-POSITION))) (PUTPROPS SETMENU XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS SETN XFORM ((1 SETQ) (REMARK SETN%:))) (PUTPROPS SETPROPLIST XFORM ((1 SETF) (EMBED 2 IN SYMBOL-PLIST))) (PUTPROPS SETQ XFORM [(ORR (3) ((N NIL]) (PUTPROPS SETQQ XFORM ((1 SETQ) (ORR ((EMBED 3 IN QUOTE)) ((N NIL))) NLAM)) (PUTPROPS SETSYNTAX XFORM ((REMARK SETSYNTAX%:))) (PUTPROPS SETTOPVAL XFORM ((1 SETF) (EMBED 2 IN SYMBOL-VALUE))) (PUTPROPS SHADEITEM XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS SHOULDNT XFORM ((1 CERROR "SHOULDN'T HAPPEN"))) (PUTPROPS SHOWGRAPH XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS SHOWZOOMGRAPH XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS SIN XFORM [(IF (%## 3) ((3)) ((EMBED 2 IN (TIMES & (/ (FLOAT PI &) 180]) (PUTPROPS SMALLP XFORM ((1 TYPEP) (N 'FIXNUM) (REMARK SMALLP%:))) (PUTPROPS SOME XFORM (TESTORVAL (IF (AND (NULL (CADDDR (%##))) (EQ USAGE 'TEST)) ((SW 2 3)) ([ORR ((IF (%## 4))) (4 'CDR) ((N 'CDR] (I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1))) ((NOT (CONSP $$TEM1)) NIL) (COND ((APPLY* %#F (CAR $$TEM1)) (RETURN $$TEM1] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __)))) (PUTPROPS SORT XFORM [(IF (%## 3) ((IF (EQ (%## 3) T) [(3 (FUNCTION (LAMBDA (A B) (STRING< (CAR A) (CAR B] NIL)) ((N (FUNCTION STRING<]) (PUTPROPS SPACES XFORM [(1 FORMAT) (IF (CDR (%##)) ((IF (NULL (%## 2)) ((2 1)) NIL) (ORR (3 0) ((N NIL))) (SW 2 3) (IF (NUMBERP (%## 3)) ((I 3 (CONCAT "~" (%## 3) "@T"))) ((-3 "~V@T"))) (COMS (SELECTQ (%## 2) (NIL '(2 T)) (T '(2 *TERMINAL-IO*)) NIL))) ((N T "~@T"]) (PUTPROPS SPECVARS XFORM ((1 PROCLAIM) (EMBED (2 THRU) IN '(SPECIAL &)) NLAM)) (PUTPROPS SQRT XFORM ((REMARK SQRT%:))) (PUTPROPS STKEVAL XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS STKPOS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS STREQUAL XFORM ((1 string=))) (PUTPROPS STRINGP XFORM (TESTORVAL (COMS (SELECTQ USAGE (TEST NIL) [VALUE '(IF (ATOM (%## 2)) ((MBD AND) (I N (%## 2 2)) NLAM) ([1 FUNCALL (LAMBDA (X) (AND (STRINGP X) X] 2 DOTHIS (REMARK STRINGP1%:] [UNKNOWN %' (COMSQ (REMARK STRINGP%:) (ORR (2 1) ((MBD AND) (I N (%## 2 2)) NLAM] NIL)))) (PUTPROPS STRPOS XFORM ((1 SEARCH) (IF (OR (%## 5) (%## 6) (%## 7) (%## 8)) ((REMARK STRPOS%:)) NIL) (ORR (9 (MBD 1-) (B :START2) 0 (DELETE (5 THRU 8))) NIL))) (PUTPROPS SUB1 XFORM ((1 1-))) (PUTPROPS SUBATOM XFORM ((1 SUBSTRING) DOTHIS (MBD INTERN))) (PUTPROPS SUBLIS XFORM ((ORR (4 (%:) 0 (EMBED 3 IN COPY) (REMARK SUBLIS%:)) NIL))) (PUTPROPS SUBPAIR XFORM ((1 SUBLIS) (-2 PAIRLIS) (BI 2 4) DOTHIS (REMARK SUBPAIR%:))) (PUTPROPS SUBSET XFORM ([ORR ((IF (%## 4))) (4 'CDR) ((N 'CDR] (I %: (SUBPAIR '(%#L %#F %#TL) (%## (NTH 2)) '[DO (($$TEM1 %#L (APPLY* %#TL $$TEM1)) ($$VAL) ($$TEM2)) ((NOT (CONSP $$TEM1)) $$VAL) (COND ((APPLY* %#F (CAR $$TEM1)) (COND [$$TEM2 (RPLACD $$TEM2 (SETQ $$TEM2 (LIST (CAR $$TEM1] (T (SETQ $$VAL (SETQ $$TEM2 (LIST (CAR $$TEM1] T)) MARK 1 2 1 3 (IF (MEMB (%## 2 1) '(FUNCTION QUOTE)) ((MOVE 2 2 TO %: 1) (2)) NIL) __)) (PUTPROPS SUBSTRING XFORM ((1 SUBSEQ) (EMBED 3 IN 1-) (ORR (4 (MBD 1-)) NIL))) (PUTPROPS SUSPEND.PROCESS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS SWAP XFORM ((1 swap) DOTHIS)) (PUTPROPS SYSTEMTYPE XFORM ((1 LISP-IMPLEMENTATION-TYPE) (REMARK SYSTEMTYPE%:))) (PUTPROPS TAB XFORM ((1 FORMAT) (ORR (4 0 (MOVE 4 TO B 2)) ((-2 NIL))) (ORR (4 0) ((N 1))) (COMS (SELECTQ (%## 2) (NIL '(2 T)) (T '(2 *TERMINAL-IO*)) NIL)) (I -3 (CONCAT "~" (OR (NUMBERP (%## 3)) "V") "," (OR (NUMBERP (OR (%## 4) 1)) "V") "T")) (IF (NUMBERP (OR (%## 5) 1)) ((5)) NIL) (IF (NUMBERP (%## 4)) ((4)) NIL))) (PUTPROPS TAN XFORM [(IF (%## 3) ((3)) ((EMBED 2 IN (TIMES & (/ (FLOAT PI &) 180]) (PUTPROPS TCONC XFORM ((REMARK TCONC%:))) (PUTPROPS TCP.CLOSE.SENDER XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS TCP.OTHER.STREAM XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS THIS.PROCESS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS TIME XFORM ((ORR (3 (REMARK TIME%:)) NIL))) (PUTPROPS TIMES XFORM ((1 *))) (PUTPROPS TOTOPW XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS TTYDISPLAYSTREAM XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS TTYIN XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS TYPE? XFORM ((1 type?) DOTHIS)) (PUTPROPS TYPENAMEP XFORM ((1 TYPEP))) (PUTPROPS TYPEP XFORM ((REMARK TYPEP%:))) (PUTPROPS TYPERECORD XFORM ((IF [NULL (CDR (LAST (%## 3] ((1 DEFSTRUCT) (NTH 3) [LPQ (IF (%## 2) ((IF (EQ '_ (%## 3)) ((I EMBED 1 (LIST 'F (%## 2) NIL) 1 'IN (LIST '& (%## 4))) (BI 2 4) (2)) ((REMARK RECORD1%:] (BO 1) 0 (E (pushnew XlatedRecords (%## 2)) T) (EMBED 2 IN (& (:TYPE LIST) :NAMED))) ((MBD *) DOTHIS)))) (PUTPROPS U-CASE XFORM ((1 STRING-UPCASE))) (PUTPROPS UALPHORDER XFORM ((1 STRING-LESSP))) (PUTPROPS UNBREAK XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS UNPACK XFORM ((1 STRING) (MBD (COERCE & 'LIST)) (REMARK UNPACK%:))) (PUTPROPS USEREXEC XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS WFROMMENU XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS WHENCLOSE XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS WHEREIS XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS WHILE XFORM ((1 while) DOTHIS)) (PUTPROPS WINDOWADDPROP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS WINDOWP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS WINDOWPROP XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS XNLSETQ XFORM ((REMARK OUTSIDE-CL%:))) (PUTPROPS ZEROP XFORM ((1 = 0))) (PUTPROPS \ADDTOFILEBLOCK/ADDTOCOM1 XFORM ((REMARK OUTSIDE-CL%:) DELETE \ADDTOFILEBLOLCK/ADDTOCOM1)) (PUTPROPS add XFORM [(IF (%## 4) ((EMBED (3 THRU) IN PLUS) (1 INCF)) ((IF (NUMBERP (%## 3)) [(IF (MINUSP (%## 3)) [(1 DECF) (I 3 (MINUS (%## 3] ((1 INCF] ((IF (AND (LISTP (%## 3)) (EQ (%## 3 1) 'MINUS)) ((1 DECF) 3 (XTR 2) 0) ((1 INCF]) (PUTPROPS addlast XFORM ((1 ADDLAST) DOTHIS)) (PUTPROPS change XFORM [DW (IF (EQ (CAR (%##)) 'CLISP% ) (DOTHIS) ((REMARK ADDLAST%:]) (PUTPROPS create XFORM [(IF (OR (MEMB 'using (%##)) (MEMB 'USING (%##))) [(COMS (SELECTQ (CAR (RECLOOK (%## 2))) [(RECORD TYPERECORD) (COND [(MEMB (%## 2) XlatedRecords) '(COMSQ (F (*ANY* using USING) NIL) (1 $$TEMP) (BI 1 2) 0 (MOVE ($$TEMP &) TO -1) (I EMBED 1 2 'IN (PACK* "COPY-" (%## 3))) MARK 1 2 DOTHIS __ (BI 1) (-1 LET) (3) (N $$TEMP) (NTH 3) [LPQ (IF (EQ '_ (%## 3)) ((I 2 (PACK* (%## 1) "-" (%## 2))) (3 $$TEMP) (BI 2 3) (-2 SETF) MARK 4 DOTHIS __ (BI 2 4) (MOVE 2 TO -1) (NTH 2)) ((NTH 3) (REMARK create%:] (1] (T '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] [DATATYPE '(COMSQ (F (*ANY* using USING) NIL) (1 $$TEMP) (BI 1 2) 0 (MOVE ($$TEMP &) TO -1) (I EMBED 1 2 'IN (PACK* "COPY-" (%## 3))) MARK 1 2 DOTHIS __ (BI 1) (-1 LET) (3) (N $$TEMP) (NTH 3) [LPQ (IF (EQ '_ (%## 3)) ((I 2 (PACK* (%## 1) "-" (%## 2))) (3 $$TEMP) (BI 2 3) (-2 SETF) MARK 4 DOTHIS __ (BI 2 4) (MOVE 2 TO -1) (NTH 2)) ((NTH 3) (REMARK create%:] (1] '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] ((COMS (SELECTQ (CAR (RECLOOK (%## 2))) [(RECORD TYPERECORD) (COND [(MEMB (%## 2) XlatedRecords) '(COMSQ (I 1 (PACK* "MAKE-" (%## 2))) (DELETE 2) (NTH 2) (LPQ (IF (EQ '_ (%## 2)) ((I 1 (CL:INTERN (CONCAT (%## 1)) (CL:FIND-PACKAGE "KEYWORD"))) (DELETE 2) (NTH 2) (IF (LISTP (%## 1)) (MARK 1 DOTHIS __) NIL) (NTH 2)) ((NTH 3) (REMARK create%:] (T '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] [DATATYPE '(COMSQ (I 1 (PACK* "MAKE-" (%## 2))) (DELETE 2) (NTH 2) (LPQ (IF (EQ '_ (%## 2)) ((I 1 (CL:INTERN (CONCAT (%## 1)) (CL:FIND-PACKAGE "KEYWORD"))) (DELETE 2) (NTH 2) (IF (LISTP (%## 1)) (MARK 1 DOTHIS __) NIL) (NTH 2)) ((NTH 3) (REMARK create%:] '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL]) (PUTPROPS do XFORM ((-1 for) DOTHIS)) (PUTPROPS fetch XFORM [(IF (LISTP (%## 2)) [(COMS (SELECTQ (CAR (RECLOOK (%## 2 1))) [(RECORD TYPERECORD) (COND [(MEMB (%## 2 1) XlatedRecords) '(COMSQ [I 1 (PACK* (CAR (%## 2)) "-" (CADR (%## 2] (3) (2] (T '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] [DATATYPE '(COMSQ [I 1 (PACK* (CAR (%## 2)) "-" (CADR (%## 2] (3) (2] [ASSOCRECORD '(COMSQ (1 ASSOC) (3) 2 (1 QUOTE] [ATOMRECORD '(COMSQ (1 GET) (3) (SW 2 3) 3 (1 QUOTE] (ARRAYRECORD '(REMARK fetch%:)) [HASHLINK '(COMSQ (1 GETHASH) (3) (SW 2 3) (I 3 (OR [CADADR (CDR (RECLOOK (%## 2 1] SYSHASHARRAY] [ACCESSFNS '(COMSQ [I 1 (CADR (ASSOC (%## 2 2) (CADDR (RECLOOK (%## 2 1] (3) (2] '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] ((COMS (SELECTQ (CAAR (FIELDLOOK (%## 2))) [(RECORD TYPERECORD) (COND [(MEMB (CADR (FIELDLOOK (%## 2))) XlatedRecords) '(COMSQ (I 1 (PACK* (CADAR (FIELDLOOK (%## 2))) "-" (%## 2))) (3) (2] (T '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] [DATATYPE '(COMSQ (I 1 (PACK* (CADAR (FIELDLOOK (%## 2))) "-" (%## 2))) (3) (2] [ASSOCRECORD '(COMSQ (1 ASSOC) (3) (EMBED 2 IN QUOTE] [ATOMRECORD '(COMSQ (1 GET) (3) (SW 2 3) (EMBED 3 IN QUOTE] (ARRAYRECORD '(REMARK fetch%:)) [HASHLINK '(COMSQ (1 GETHASH) (3) (SW 2 3) (I 3 (OR [CADADR (CDAR (FIELDLOOK (%## 2] SYSHASHARRAY] [ACCESSFNS '(COMSQ [I 1 (CADR (ASSOC (%## 2 2) (CADDAR (FIELDLOOK (%## 2] (3) (2] '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL]) (PUTPROPS ffetch XFORM ((1 fetch) DOTHIS)) (PUTPROPS for XFORM (MARK (NTH 2) DOTHESE __ (IF (OR (MEMB 'BIND (%##)) (MEMB 'bind (%##))) (MARK (F (*ANY* BIND bind) NIL) 2 [LPQ (IF [OR [AND (LITATOM (%##)) (NOT (EQ 'FORWORD (CAR (GETPROP (%##) 'CLISPWORD] (AND (LISTP (%##)) (EQ (%## 2) '_) (RPLACD (%##) (CDDR (%##] ((ORR (NX) (UP (N **BindMarker**) 2 NX] UP (IF (NOT (EQ (CADR (%##)) '**BindMarker**)) ((-1 **BindMarker**)) NIL) 0 (EMBED (((*ANY* BIND bind) NX) THRU **BindMarker**) IN) (F (*ANY* BIND bind) NIL) NX (DELETE -1) __) NIL))) (PUTPROPS freplace XFORM ((1 replace) DOTHIS)) (PUTPROPS pop XFORM ((1 POP))) (PUTPROPS printout XFORM ((1 FORMAT) (COMS (SELECTQ (%## 2) (NIL '(2 T)) (T '(2 *TERMINAL-IO*)) NIL)) (LI 3) (I 3 (COMPUTEFORMATS (%## 3))) (BO 3) (NTH 2) DOTHESE)) (PUTPROPS push XFORM [(IF (%## 4) ((IF (LITATOM (%## 2)) NIL ((REMARK push%:))) (-1 LET (($TEMP))) (MOVE 5 TO A 2 1 1) (LI 3) (N (push $TEMP)) (INSERT (%## 3 2) BEFORE 4 2) DOTHIS) ((1 PUSH) (SW 2 3]) (PUTPROPS pushlist XFORM [DW (IF (EQ (CAR (%##)) 'CLISP% ) (DOTHIS) ((REMARK ADDLAST%:]) (PUTPROPS pushnew XFORM ((1 PUSHNEW) (SW 2 3))) (PUTPROPS replace XFORM [(IF (LISTP (%## 2)) [(COMS (SELECTQ (CAR (RECLOOK (%## 2 1))) [(RECORD TYPERECORD) (if (MEMB (%## 2 1) XlatedRecords) then '(COMSQ (1 SETF) (I 2 (LIST (PACK* (CAR (%## 2)) "-" (CADR (%## 2))) (%## 4))) (DELETE (3 THRU 5))) else '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] [DATATYPE '(COMSQ (1 SETF) (I 2 (LIST (PACK* (CAR (%## 2)) "-" (CADR (%## 2))) (%## 4))) (DELETE (3 THRU 5] [ASSOCRECORD '(COMSQ (1 SETF ASSOC) (6) (4) (BI 2 4) 2 2 (1 QUOTE] [ATOMRECORD '(COMSQ (1 SETF GET) (6) (4) (SW 3 4) (BI 2 4) 2 3 (1 QUOTE] (ARRAYRECORD '(REMARK replace%:)) [HASHLINK '(COMSQ (1 SETF GETHASH) (6) (4) (SW 3 4) (I 4 (OR [CADADR (CDR (RECLOOK (%## 3 1] SYSHASHARRAY)) (BI 2 4] [ACCESSFNS '(COMSQ [I 1 (CADDR (ASSOC (%## 2 2) (CADDR (RECLOOK (%## 2 1] (5) (3) (2] '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] ((COMS (SELECTQ (CAAR (FIELDLOOK (%## 2))) [(RECORD TYPERECORD) (COND [(MEMB (CADR (FIELDLOOK (%## 2))) XlatedRecords) '(COMSQ (1 SETF) (I 2 (LIST (PACK* (CADAR (FIELDLOOK (%## 2))) "-" (%## 2)) (%## 4))) (DELETE (3 THRU 5] (T '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL] [DATATYPE '(COMSQ (1 SETF) (I 2 (LIST (PACK* (CADAR (FIELDLOOK (%## 2))) "-" (%## 2)) (%## 4))) (DELETE (3 THRU 5] [ASSOCRECORD '(COMSQ (1 SETF ASSOC) (6) (4) (EMBED 3 IN QUOTE) (BI 2 4] [ATOMRECORD '(COMSQ (1 SETF GET) (6) (4) (SW 3 4) (EMBED 4 IN QUOTE) (BI 2 4] (ARRAYRECORD '(REMARK replace%:)) [HASHLINK '(COMSQ (1 SETF GETHASH) (6) (4) (SW 3 4) (I 4 (OR [CADADR (CDAR (FIELDLOOK (%## 3] SYSHASHARRAY)) (BI 2 4] [ACCESSFNS '(COMSQ [I 1 (CADDR (ASSOC (%## 2 2) (CADDAR (FIELDLOOK (%## 2] (3) (2] '(COMSQ (REMARK DATATYPES) DW (IF (EQ 'CLISP% (CAR (%##))) ((I %: (CADR (%##))) 1 DOTHIS) NIL]) (PUTPROPS swap XFORM [(IF (AND (LITATOM (%## 1)) (LITATOM (%## 2))) ((1 PSETQ) (I N (%## 3) (%## 2))) (DW (IF (EQ (CAR (%##)) 'CLISP% ) ((I %: (CADR (%##))) 1 DOTHIS) ((REMARK ADDLAST%:]) (PUTPROPS type? XFORM ((SW 2 3) (EMBED 3 IN QUOTE) (1 TYPEP))) (PUTPROPS while XFORM ((-1 for) DOTHIS)) [COND [(EQ (EVALV 'MERGE) T) [RPAQ TRANSFORMATIONS (UNION TRANSFORMATIONS (LISTP (GETP 'TRANSFORMATIONS 'VALUE] (MAPC (GETP 'USERNOTES 'VALUE) (FUNCTION (LAMBDA (NOTE) (OR (ASSOC (CAR NOTE) USERNOTES) (SETQ USERNOTES (CONS NOTE USERNOTES] (T (MAPC (GETP 'TRANSFORMATIONS 'VALUE) (FUNCTION (LAMBDA (X) (AND (NOT (MEMB X TRANSFORMATONS)) (/REMPROP X 'XFORM] (PUTPROPS TO-COMMONLISP MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS TO-COMMONLISP.XFORMS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS TO-COMMONLISP.XFORMS COPYRIGHT ("System Development Corp." 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5216 14316 (COMPUTEFORMATS 5226 . 11896) (MAKELAMPROG 11898 . 12727) (DataTypeP 12729 . 13422) (STRINGIFY 13424 . 14314))))) STOP ˙ \ No newline at end of file diff --git a/lispusers/TRANSOR.BUGREPORTS b/lispusers/TRANSOR.BUGREPORTS new file mode 100644 index 00000000..f6f2af8b --- /dev/null +++ b/lispusers/TRANSOR.BUGREPORTS @@ -0,0 +1 @@ +*start* 00790 00024 US Date: 13 Apr 88 13:46 PDT Sender: Lanning.pa From: Stanley's Tool Works Subject: Re: [darrelj%sm.unisys:COM: Interlisp to Commonlisp conversion package] In-reply-to: masinter.pa's message of 12 Apr 88 11:22 PDT To: masinter.pa cc: LispUsers^.x Beware loading this utility. Here's one way to lose. A side effect of this utility is that the var CLISPARRAY is set to NIL. As a result, all CLISP translations are stored not in a hash array; instead the source form is smashed to some specially tagged list that contains the CLISP source and the translation. This construct is understood by the interpreter and the byte-compiler, but *not* the new compiler. As a result, compiling any code with, say, (fetch ...)'s in it produces garbage. ----- smL *start* 02329 00024 USa Return-Path: Received: from rdcf.sm.unisys.com (SM.UNISYS.COM) by Xerox.COM ; 02 MAY 88 15:55:29 PDT Received: by rdcf.sm.unisys.com (sdcrdcf) (5.51/Domain/jpb/2.9) id AA03568; Mon, 2 May 88 15:56:12 PDT Message-Id: <8805022256.AA03568@rdcf.sm.unisys.com> Received: from XERXES by sdcrdcf with PUP; Mon, 2 May 88 15:56 PDT From: darrelj@sm.unisys.com Date: 2 May 88 15:55 PDT (Monday) Subject: Re: comments on Transor In-Reply-To: Masinter.pa@Xerox.COM's message of 1 May 88 22:35 PDT To: Masinter.pa Cc: darrelj@sm.unisys.com, Lanning.pa Date: 1 May 88 22:35 PDT From: Masinter.pa@Xerox.COM Subject: comments on Transor To: darrelj@sm.unisys.COM Cc: Lanning.pa@Xerox.COM Message-Id: <880501-223544-2658@Xerox> Is it necessary to set CLISPARRAY to NIL? 00790 00024 US Date: 13 Apr 88 13:46 PDT Sender: Lanning.pa From: Stanley's Tool Works Subject: Re: [darrelj%sm.unisys:COM: Interlisp to Commonlisp conversion package] In-reply-to: masinter.pa's message of 12 Apr 88 11:22 PDT To: masinter.pa cc: LispUsers^.x Beware loading this utility. Here's one way to lose. A side effect of this utility is that the var CLISPARRAY is set to NIL. As a result, all CLISP translations are stored not in a hash array; instead the source form is smashed to some specially tagged list that contains the CLISP source and the translation. This construct is understood by the interpreter and the byte-compiler, but *not* the new compiler. As a result, compiling any code with, say, (fetch ...)'s in it produces garbage. ----- smL Its only necessary to set CLISPARRAY to NIL if you want translations of Clisp to common Lisp :-). The TRANSOR scan needs to have the stuff inline to traverse the clisp expansions of stuff like fetch and for (in some cases). I lived with this by a combination of using old compiler for the transformation code, and setting CLISPARRAY to a new hash array when done with a session of translation (if you hand set it to NIL, you can even save the old value for later). In principle I guess it could be made to not follow the hash pointers, but the use of the Teletype editor by Transor is messy and closely intertwined in ways I don't entirely understand. Darrel \ No newline at end of file diff --git a/lispusers/TRANSOR.TEDIT b/lispusers/TRANSOR.TEDIT new file mode 100644 index 00000000..307b8602 --- /dev/null +++ b/lispusers/TRANSOR.TEDIT @@ -0,0 +1 @@ +Sender: SenderNameTooLong%SUMEX-AIM.STANFORD:EDU:Xerox Date: 5 Jan 88 18:39:54 PST (Tuesday) Subject: Interlisp to Commonlisp conversion package From: darrelj%sm.unisys:COM To: info-1100%sumex-aim.stanford cc: darrelj%sm.unisys:COM Return-Path: <@SUMEX-AIM.Stanford.EDU:sdcrdcf!sm.unisys.com!darrelj@PRC.Unisys.COM> Redistributed: Info-1100-Redistribute^.X Received: from SUMEX-AIM.Stanford.EDU by Xerox.COM ; 05 JAN 88 18:38:18 PST Received: from burdvax.PRC.Unisys.COM (PRC-GW.PRC.UNISYS.COM) by SUMEX-AIM.Stanford.EDU with TCP; Tue, 5 Jan 88 17:44:10 PST Received: by burdvax.PRC.Unisys.COM (burdvax) [5.54/1.0] id AA15346; Tue, 5 Jan 88 20:44:28 EST Received: by rdcf.sm.unisys.com (sdcrdcf) (5.51/Domain/jpb/2.7) id AA28679; Tue, 5 Jan 88 16:35:37 PST Message-Id: <8801060035.AA28679@rdcf.sm.unisys.com> Received: from XAVIER by sdcrdcf with PUP; Tue, 5 Jan 88 16:35 PST Original-Date: 5 Jan 88 16:34 PST (Tuesday) Interlisp-D into Xerox Commonlisp, we developed a collection of tools to automate the conversion as much as possible. These have been placed in {parcvax.xerox.com}/lisp/exchange. While we at Unisys have reasonable confidence in these tools, they are being made available with no promises of accuracy, completeness or support (though we would appreciate feedback). The tools run in Xerox Lyric Common Lisp. The following files are parts of it: TRANSOR -- A slightly modified version of Transor, to fix a few Lyric-related problems and provide the ability to emit a DEFINE-FILE-INFO expression and to use the value of TRANSOUTREADTABLE as the output readtable. We used TRANSOR because we were familiar with it, and it handles a lot of details needed to safely and surely traverse the code to be translated. The biggest impediment to adding to the transforms is that they are specified as teletype editor commands, and only old-time Interlispers have much experience with those. TSET -- The same version dating back to 1979. This is the part of transor used for interactively developing and testing translation rules. TRANSOR.LCOM -- contains the compilation of BOTH the above files. TO-COMMONLISP.XFORMS -- translation rules for 428 functions, 98 remarks and 4 auxiliary functions. It covers are large portion of Interlisp, including most Clisp constructs, and specifically handles any function with the same name in both Interlisp and Commonlisp, so that holes in a translation should result in calls to undefined functions. In many cases, nice transformations are used for easy cases, and ugly ones only for hard cases. This file sets TRANSOUTREADTABLE to be a copy of the XCL readtable which is case SENSITIVE, MYLOAD below reads it case INsensitive, so the resulting file will ultimately lose most case distinctions on reloading into Xerox Lisp (or other common lisps). This was a much debated point internally, but this seemed the best of three bad possibilities (e.g. print one of Cased AS ORIGinal which becomes CASED AS ORIGINAL on load, |Cased| AS |ORIGinal|, or CASED AS ORIGINAL INTERLISP-COMMONLISP.TEDIT -- A document describing the transformations and formacro. LOADTRAN -- contains a few functions which prevent many breaks on loading the translated file. The function MYLOAD is intended to load a translated file. LOADTRAN.DFASL -- compiled version FORMACRO and FORMACRO.DFASL -- Still another portable iteration macro for commonlisp. Its main claims are almost 100% compatibility with the semantics of the Interlisp-Clisp FOR (especially when used the the XFORMS which fix a few incompatibilities); and user extensibility (unfortunately not compatible with IL:I.S.OPR). Embedded keywords (e.g. IN, COLLECT) may be in any package. COMMON-MAKE and COMMON-MAKE.LCOM -- still another version of code to generate a more "common" source file. It handles more filepkg command types than most. Also, when used with COMMENTHACKS will successfully print ALL comments in semicolon format. Call IL:COMMON-MAKEFILE(file). It checks the MAKEFILE-ENVIRONMENT property to select a package and base. COMMENTHACKS and COMMENTHACKS.LCOM -- patches to the prettyprinter and to the DEFUN editor. The prettyprinter patches will print Interlisp (* --) comments as semicolon comments when *PRINT-SEMICOLON-COMMENTS* is 'IL:ALL. This file also redefines the ED method for DEFUNs so that the initials and date of editing get updated for DEFUNs just as Interlisp has always done for FNS. Because of the way things developed, these tools are not as fully integrated as they could have been. If we were doing it over, the TRANSOR step could have more carefully coordinated the new COMS so that COMMON-MAKE would be able to do the right thing. As it stands, the COMS generally have to be edited to change FNS to FUNCTIONS, etc, but you tend to need a few iterations of editing things before the compiler is completely happy anyway. The steps needed to do translations are roughly as follows: (LOAD 'TRANSOR.LCOM) (LOAD 'TO-COMMONLISP.XFORMS) (SETQ FIXSPELLDEFAULT 'N) ;; Otherwise DWIM gets too clever (SETQ XlatedRecords NIL) ;; This is currently set to records specific to the system we translated. TRANSOR files containing record declarations. The records MUST be translated before any code containing create/fetch/replace since the translation depends on the type of records. Also, the record declarations should be LOADED. In a large translation effort, save a file containing all needed declarations and the value of XlatedRecords computed by translating them. (TRANSOR 'file1) ... ;; results in file1.TRAN and file1.LSTRAN, see TRANSOR documentation. To load translated files into a fresh xerox lisp system: >From an XCL exec: (IL:SETPROPLIST '*COMMENT* (IL:GETPROPLIST 'IL:*)) (IL:PUTASSOC '*COMMENT* 'IL:* IL:PRETTYEQUIVLST) (LOAD 'LOADTRAN) (SETQ IL:*DEFUALT-MAKEFILE-ENVIRONMENT* '(:READTABLE "XCL" :PACKAGE ???)) (SETQ IL:CMLRDTBL (IL:FIND-READTABLE "XCL")) (LOAD 'FORMACRO.DFASL) if used interlisp for's ;; may need to import USER:FOR depending on packages you've set up. (MYLOAD 'translated-records) (MYLOAD 'file1.tran) ... A little work with ED and FILES? and you should be able to save a commonlisp version of your files (well, OK, a lot of work). Suggestions and questions to one of: darrelj@RDCF.SM.UNISYS.COM or darrel@CAM.UNISYS.COM, or fritzson@bigburd.prc.UNISYS.COM ----- End Forwarded Messages ----- \ No newline at end of file diff --git a/lispusers/TRICKLE b/lispusers/TRICKLE new file mode 100644 index 00000000..e0934112 --- /dev/null +++ b/lispusers/TRICKLE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "15-Jun-90 15:57:17" {ERINYES}MEDLEY>LISPUSERS>TRICKLE.;3 7876 changes to%: (VARS TRICKLECOMS) previous date%: " 4-Jun-90 17:10:08" {ERINYES}MEDLEY>LISPUSERS>TRICKLE.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TRICKLECOMS) (RPAQQ TRICKLECOMS ((FILES (SYSLOAD) PROMPTREMINDERS COPYFILES) (FNS Trickle TrickleProcessLogfile))) (FILESLOAD (SYSLOAD) PROMPTREMINDERS COPYFILES) (DEFINEQ (Trickle [LAMBDA (Source Destination RootLogfileName MailAddress ScheduleAnotherOne DontReplaceOldVersions DontCopyExtensions) (* ; "Edited 4-Jun-90 16:05 by jds") (LET* [(DateString (DATE (DATEFORMAT SPACES NUMBER.OF.MONTH NO.TIME))) (LogfileName (PACK* (OR RootLogfileName '{qv}lispusers-) (SUBSTRING DateString 7 8) (SUBSTRING DateString 4 5) (SUBSTRING DateString 1 2) '.COPYLOG] (* ;; "fix up the file name for the case where the day is less than 10") [if (EQ '% (NTHCHAR LogfileName -10)) then (SETQ LogfileName (MKATOM (RPLSTRING LogfileName -10 "0"] (* ;; "ensure that the logfile has one line per file operated on") [RESETVAR FILELINELENGTH 1000 (COPYFILES Source Destination (APPEND (LIST '>A (LIST 'OUTPUT LogfileName)) (if (NULL DontReplaceOldVersions) then (LIST 'REPLACE)) (if DontCopyExtensions then `((DONTCOPY ,@DontCopyExtensions] (TrickleProcessLogfile LogfileName MailAddress Source Destination) (if (EQ ScheduleAnotherOne T) then (SETREMINDER (MKATOM (CONCAT "Trickle-" (GENSYM) "-" Source)) NIL `(Trickle ',Source ',Destination ,RootLogfileName ,MailAddress ,ScheduleAnotherOne ,DontReplaceOldVersions) (CONCAT (SUBSTRING [GDATE (PLUS (IDATE) (CONSTANT (TIMES 60 60 24] 1 10) (RAND 1 5) ":" (RAND 0 59))) elseif (AND ScheduleAnotherOne (IDATE (CONCAT "1-jan-87 " ScheduleAnotherOne))) then (SETREMINDER (MKATOM (CONCAT "Trickle-" (GENSYM) "-" Source)) NIL `(Trickle ',Source ',Destination ,RootLogfileName ,MailAddress ,ScheduleAnotherOne ,DontReplaceOldVersions) (CONCAT (SUBSTRING [GDATE (PLUS (IDATE) (CONSTANT (TIMES 60 60 24] 1 10) ScheduleAnotherOne]) (TrickleProcessLogfile [LAMBDA (LogfileName MailAddress Source Destination) (* N.H.Briggs " 1-Oct-87 11:29") (PROG (LogfileStream EndsOfLines (EOLCharacter (CHARACTER (CHARCODE EOL))) EndOfLine Deletions) (SETQ LogfileStream (OPENTEXTSTREAM LogfileName)) (if (ZEROP (GETEOFPTR LogfileStream)) then (* * probably errored -  people don't usually Trickle empty directories) (if MailAddress then (TEDIT.INSERT LogfileStream (PACK* "Subject: (Error?) Trickle:" Source " to " Destination EOLCharacter "To: " MailAddress EOLCharacter EOLCharacter) 1) (LAFITE.SENDMESSAGE LogfileStream) (CLOSEF LogfileStream) (RETURN))) (TEDIT.SETSEL LogfileStream 1 1 'LEFT) (SETQ EndsOfLines (CONS 0 (while (SETQ EndOfLine (TEDIT.FIND LogfileStream EOLCharacter)) collect (TEDIT.SETSEL LogfileStream EndOfLine 1 'RIGHT) EndOfLine))) (* * find lines with "skipped" and collect for deletion) (* * TEDIT.FIND is very poor on long files, see AR# 4220) [for EndOfPreviousLine on EndsOfLines bind StartOfLine EndOfLine eachtime [SETQ StartOfLine (AND EndOfPreviousLine (ADD1 (CAR EndOfPreviousLine] (SETQ EndOfLine (CADR EndOfPreviousLine)) when [AND EndOfLine (STRPOS "skipped" (TEDIT.SEL.AS.STRING LogfileStream (TEDIT.SETSEL LogfileStream StartOfLine (ADD1 (IDIFFERENCE EndOfLine StartOfLine] do (* * if this deletion is an extension of the previous one, then extend the  previous one, otherwise add this to the collection.  This collapsing makes the actual deletion much more efficient, since we expect  to have few of the lines kept.) (if (AND Deletions (EQUAL (PLUS (CAAR Deletions) (CDAR Deletions)) StartOfLine)) then [RPLACD (CAR Deletions) (PLUS (CDAR Deletions) (DIFFERENCE EndOfLine (CAR EndOfPreviousLine] else (push Deletions (CONS StartOfLine (DIFFERENCE EndOfLine (CAR EndOfPreviousLine ] (* * do collected deletions) (for Deletion in Deletions do (TEDIT.DELETE LogfileStream (CAR Deletion) (CDR Deletion))) (* * KLUDGE! TEDIT.PUT bombs after putting the file if the stream doesn't have  a window associated) (NLSETQ (TEDIT.PUT LogfileStream LogfileName T T)) (* * construct a mail message and send it) (if MailAddress then (TEDIT.INSERT LogfileStream (PACK* (if (NOT (ZEROP (GETEOFPTR LogfileStream))) then "Subject: Trickle: " else "Subject: (Empty) Trickle:") Source " to " Destination EOLCharacter "To: " MailAddress EOLCharacter EOLCharacter) 1) (LAFITE.SENDMESSAGE LogfileStream)) (CLOSEF LogfileStream]) ) (PUTPROPS TRICKLE COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (638 7777 (Trickle 648 . 3673) (TrickleProcessLogfile 3675 . 7775))))) STOP \ No newline at end of file diff --git a/lispusers/TRICKLE.TEDIT b/lispusers/TRICKLE.TEDIT new file mode 100644 index 00000000..ca932ca5 Binary files /dev/null and b/lispusers/TRICKLE.TEDIT differ diff --git a/lispusers/TSET b/lispusers/TSET new file mode 100644 index 00000000..9512d497 --- /dev/null +++ b/lispusers/TSET @@ -0,0 +1 @@ +(FILECREATED " 3-JUN-79 09:49:57" TSET.;2 18693 changes to: TRANSORSET LISPXUSERFN TSETCOMS TSETFNS TRANSORSETUSERFN previous date: " 8-Jul-76 23:22:21" TSET.;6) (PRETTYCOMPRINT TSETCOMS) (RPAQQ TSETCOMS [(FNS * TSETFNS) TSETMACROS (VARS (LISPXMACROS (UNION TSETMACROS LISPXMACROS))| (TESTFORM) [LISPXCOMS (UNION LISPXCOMS (MAPCAR TSETMACROS (FUNCTION CAR]| (MERGE) (PRETTYDEFMACROS (CONS [QUOTE (TRANSAVE NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS (PROP XFORM * TRANSFORMATIONS) (P (COND [(EQ (EVALV (QUOTE MERGE)) T) [RPAQ TRANSFORMATIONS (UNION TRANSFORMATIONS (LISTP (GETP (QUOTE TRANSFORMATIONS) (QUOTE VALUE] (MAPC (GETP (QUOTE USERNOTES) (QUOTE VALUE)) (FUNCTION (LAMBDA (NOTE) (OR (ASSOC (CAR NOTE) USERNOTES) (SETQ USERNOTES (CONS NOTE USERNOTES] (T (MAPC (GETP (QUOTE TRANSFORMATIONS) (QUOTE VALUE)) (FUNCTION (LAMBDA (X) (AND (NOT (MEMB X TRANSFORMATONS) ) (/REMPROP X (QUOTE XFORM] PRETTYDEFMACROS)) (LCASELST (APPEND (QUOTE (DO TRANSFORMATIONS)) LCASELST))) (PROP UCASE BBN LISP SRI MIT QA3 PLANNER UCI INTERLISP) (PROP FILEGROUP TSET) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML TRANSUNDER) (LAMA]) (RPAQQ TSETFNS (TRANSORSET TRANSORINPUTP TRANSORSETUSERFN RUMARK RUMARK1 TRANSUNDER TXFN TXFN1 TXDUMP  | TXERASE TXERASE1 TXTEST TXSHOW TXEDIT TXEXIT TXNOTE GENREMNAM TXDELNOTE)) (DEFINEQ (TRANSORSET [LAMBDA NIL (* wt: " 2-JUN-79 18:53") (PROG (CURRENTFN) (COND ((NOT (BOUNDP (QUOTE TRANSFORMATIONS)))| (RPAQ TRANSFORMATIONS NIL)| (RPAQ USERNOTES NIL)| (RPAQ UDRS))) (* CURRENTFN must be bound in the outer PROG so that errors don't change its setting to NIL. LISPXHIST must be bound in the inner PROG so that the initialization above will go on the history-list with the call to TRANSORSET, not with the first input to it. The normal return from TRANSORSET is via a RETFROM in TRANSEXIT. The ERSETQ returns only from a control E or error.) OUTER (USEREXEC (QUOTE +)| NIL| (QUOTE TRANSORSETUSERFN))| (CLEARBUF T) (GO OUTER]) (TRANSORINPUTP [LAMBDA (A B) (* TRANSORSET has a feature whereby any random edit commands typed to the + sign will be accepted as part of the transformation for CURRENTFN. See LISPXUSERFN. TRANSORINPUTP has to decide if the input looks like edit commands. If so, return T. A is the first thing on the input line, B is a list (possibly NULL) of all the other inputs on that line.) (PROG NIL (* The following test for edit input is more stringent than the DWIM test which causes LISPX to edit the nearest reasonable thing. Numbers, e.g., are not caught by DWIM because they do not cause errors. However, some mistakes will not be noticed by this test. Typing BO as if an atomic editcommand is not legal edit input but will pass this test if there is something else on the line. Hopefully that will not matter much.) (COND ((AND (NULL A) (NULL B)) (* True only for extra paren's and NIL's.) (RETURN)) ((EQ A (QUOTE PP)) (RETURN))) (RETURN (OR (SMALLP A) [AND (LITATOM A) (OR (FMEMB A EDITCOMSA) (AND B (FMEMB A EDITCOMSL] (AND (LISTP A) (OR (SMALLP (CAR A)) (AND (LITATOM (CAR A)) (FMEMB (CAR A) EDITCOMSL]) (TRANSORSETUSERFN [LAMBDA (A B) (* wt: " 2-JUN-79 19:06") (PROG (INLINE) (COND| ((NULL (TRANSORINPUTP A B))| | | (* Not random editcommands, so let LISPX handle it normally. All the other TRANSORSET stuff is implemented as | vanilla LISPXMACROS so don't have to worry about it here.)| | | (RETURN)))| (SETQ INLINE (CONS (COPY A) (COPY B))) (* Always copy the works, since it will be put onto the property list and will likely be edited and added to a lot during the next few history events and we don't want to show this on the history list. I.e. show input as typed in, so a REDO does what one expects.) (AND (LITATOM A) (NULL (FMEMB A EDITCOMSA)) (FMEMB A EDITCOMSL) (SETQ INLINE (LIST INLINE))) (* Convert an input line such as "BO 4 5 " to simply be (BO 4 5).) (COND ((NULL CURRENTFN) (ERROR (QUOTE "You must specify a function with the 'fn' command") (QUOTE "before transformations can be stored") T))) (RUMARK INLINE CURRENTFN) (/PUT CURRENTFN (QUOTE XFORM) (/NCONC (GETP CURRENTFN (QUOTE XFORM)) INLINE)) (LISPXSTOREVALUE LISPXHIST CURRENTFN)| (* I want to show where these TRANSFORMATIONS went on history list in case user gets confused; but I don't want to be printing it at him each time around the loop. The only way to avoid printing is to RETFROM  out of LISPX; but if I do that, I have to put the 'value' on the history myself.) (RETFROM (QUOTE LISPX]) (RUMARK [LAMBDA (XFORM FN) (AND (LISTP XFORM) (EDITFINDP XFORM (QUOTE (REMARK --)) T) (EDITE (LIST XFORM) (QUOTE ((LPQ F (REMARK --) (E (RUMARK1) T]) (RUMARK1 [LAMBDA NIL (* dcl: 7 Jul 76 15:57) (PROG ((CALL (CAR L)) RNAME TEXT) (COND ((NLISTP (CDR CALL)) (* Illegally formed; complain.) (PRIN1 (QUOTE " Warning - badly formed remark: ") T) (PRINT CALL T T)) ([AND (NULL (CDDR CALL)) (LITATOM (SETQ RNAME (CADR CALL] (* Standard use of named remark: (REMARK REMNAME) ) ) ([OR [LISTP (CDR (SETQ TEXT (CDR CALL] (LISTP (SETQ TEXT (CADR CALL] (* The user may type (REMARK RANDOM TEXT) or (REMARK (RANDOM TEXT)). Either way, we make it into a named remark and add star (COMMENTFLG) if necessary.) [/RPLACD CALL (LIST (SETQ RNAME (GENREMNAM FN] (* FN is picked up free from RUMARK.) (OR (EQ (CAR TEXT) COMMENTFLG) (SETQ TEXT (CONS COMMENTFLG TEXT))) (/SETATOMVAL (QUOTE USERNOTES) | (CONS (LIST RNAME TEXT) | USERNOTES]) (TRANSUNDER [NLAMBDA (TSETFN FLG) (* This function is used by the TRANSORSET commands implemented as LISPXMACROS, to do initial checks. Abort if not at + sign, and make sure that every element of the input line is atomic, unless FLG=T (for the TEST command, the only one at present which can legally take a non-atomic arg.)) (COND ((NEQ (EVALV (QUOTE LISPXID)) (QUOTE +)) (LISPXUNREAD (QUOTE (REDO -1))) (TRANSORSET)) (T [OR FLG (MAPC LISPXLINE (FUNCTION (LAMBDA (X) (COND ((NOT (LITATOM X)) (ERROR (QUOTE "Arg not litatom:") X T] (APPLY* TSETFN LISPXLINE]) (TXFN [LAMBDA (LIN) (COND ((NULL LIN) (* 'FN' followed by carriage return or NIL at + will just print current value of CURRENTFN without changing it.) CURRENTFN) (T [MAPC LIN (FUNCTION (LAMBDA (X) (TXFN1 X T] (CAR (LAST LIN]) (TXFN1 [LAMBDA (FN OLDMESS) (* dcl: 7 Jul 76 15:58) (* TXFN1 is used in several ways. TXFN uses it to reset CURRENTFN, but never to NIL. Other function use it to reset CURRENTFN to NIL, to their last arg, or for side effect of 'noticing' a FN name.) (AND CURRENTFN (NULL (GETP CURRENTFN (QUOTE XFORM))) (/SETATOMVAL (QUOTE TRANSFORMATIONS) | (/DREMOVE CURRENTFN TRANSFORMATIONS))) | (* It is desirable to avoid accumulating atoms on TRANSFORMATIONS which never got any entries. User probably mistyped the arg to a FN command, and should be able to just do FN again without having to ERASE the bad entry.) (AND OLDMESS FN (GETP FN (QUOTE XFORM)) (PRIN1 (QUOTE "You're adding to old xforms.") T)) (* If the new CURRENTFN already has some TRANSFORMATIONS, alert user.) (AND FN (NULL (FMEMB FN TRANSFORMATIONS)) (/SETATOMVAL (QUOTE TRANSFORMATIONS) | (CONS FN TRANSFORMATIONS))) | (* Put FN on TRANSFORMATIONS if necessary, and finally reset CURRENTFN. Value of TXFN1 is not used.) (SAVESETQ CURRENTFN FN) NIL]) (TXDUMP [LAMBDA (LIN) (* dcl: 8 Jul 76 23:22) (PROG ((FILE (CAR LIN)) F) (TXFN1) (SORT TRANSFORMATIONS) (SORT USERNOTES T) [COND (FILE (SETQ F FILE)) ((NEQ (QUOTE NOBIND) DUMPFILE) (SETQ F DUMPFILE)) (T (PRIN1 (QUOTE " File to dump on: ") T) (SETQ F (RATOM T T] (COND ((NULL (SETQ FILE (OUTFILEP F))) (ERROR (QUOTE "Cannot open file:") F T))) (/SETATOMVAL (QUOTE DUMPFILE) F) (SETQ F (NAMEFIELD F)) [COND ((NOT (ASSOC (QUOTE TRANSAVE) XFORMSVARS)) (* Initialize VARS if necessary; if some existing stuff just add TSET's command to it, otherwise initialize to ((transave))) (/SETATOMVAL (QUOTE XFORMSVARS) (CONS (LIST (QUOTE TRANSAVE)) (LISTP XFORMSVARS] (COND ((EQ XFORMSFNS (QUOTE NOBIND)) (* If we leave it nobind, PRETTYDEF won't write out an RPAQQ and therefore when FILE is loaded it won't clobber any possible previous settings of xformsfns.) (/SETATOMVAL (QUOTE XFORMSFNS) NIL))) (AND XFORMSFNS (NOT (MEMB (QUOTE XFORMSFNS) | XFORMSVARS)) | (/SETATOMVAL (QUOTE XFORMSVARS) | (CONS (QUOTE XFORMSFNS) | XFORMSVARS))) | (PRETTYDEF XFORMSFNS FILE (QUOTE XFORMSVARS)) | (RETURN FILE]) (TXERASE [LAMBDA (LIN) (* Forgets the TRANSFORMATIONS for functions. Undoable. Has to remove the property entry with REMPROP, and take them off the list TRANSFORMATIONS. Always resets CURRENTFN to NIL. ERASE followed by carriage return erases CURRENTFN.) (COND ((NLISTP LIN) (TXERASE1 CURRENTFN)) (T (TXFN1 (CAR (LAST LIN))) (MAPCAR LIN (FUNCTION TXERASE1]) (TXERASE1 [LAMBDA (FN) (* dcl: 7 Jul 76 16:00) (AND (FMEMB FN TRANSFORMATIONS) (/SETATOMVAL (QUOTE TRANSFORMATIONS) | (/DREMOVE FN TRANSFORMATIONS))) | (COND ((GETP FN (QUOTE XFORM)) (/REMPROP FN (QUOTE XFORM)) FN) (T (CONS FN (QUOTE (-- NOTHING FOUND.]) (TXTEST [LAMBDA (LIN) (* dcl: 7 Jul 76 16:00) (PROG ((TESTRAN T) (OLDO (OUTPUT T))) (* TESTRAN is a flag used by the listing machinery to suppress listing for the tests made my the TEST command.) (COND ((LISTP (CAR LIN)) (/SETATOMVAL (QUOTE TESTFORM) | (CAR LIN))) | ((NULL TESTFORM) (ERROR (QUOTE "Correct format is:") (QUOTE "+TEST (SAMPLE S-EXPRESSION TO BE TRANSOR'ED)") T))) (COND ((NULL (GETD (QUOTE TRANSORFORM))) (ERROR (QUOTE "You must load TRANSOR.COM before using the TEST command.") (QUOTE "") T))) (RETURN (PROG1 (TRANSORFORM (COPY TESTFORM)) (OUTPUT OLDO]) (TXSHOW [LAMBDA (LIN) (PROG [(OLDO (OUTPUT T)) (FLG (OR (NULL LIN) (CDR LIN] (OR LIN (SETQ LIN (LIST CURRENTFN))) [MAPC LIN (FUNCTION (LAMBDA (FN) (TXFN1 FN) (COND (FLG (* Print the name of each transformation being shown if more than one being done, or if doing the default) (PRINT FN NIL T))) [PRINTDEF (OR (GETP FN (QUOTE XFORM)) (QUOTE (No transformations] (TERPRI] (OUTPUT OLDO) (RETURN (CAR (LAST LIN]) (TXEDIT [LAMBDA (LIN) (OR LIN (SETQ LIN (LIST CURRENTFN))) [MAPC LIN (FUNCTION (LAMBDA (FN) (TXFN1 FN) (RUMARK (PUT FN (QUOTE XFORM) (EDITE (OR (GETP FN (QUOTE XFORM)) (ERROR FN (QUOTE "not editable.") T)) NIL FN)) FN] (CAR (LAST LIN]) (TXEXIT [LAMBDA NIL (* dcl: 7 Jul 76 16:01) (SETATOMVAL (QUOTE USERINPUTP)) | (RETFROM (QUOTE TRANSORSET]) (TXNOTE [LAMBDA (LIN) (* dcl: 7 Jul 76 16:01) (* Remark has a mandatory arg, the name of the remark. If old, edits it; if new, demands TEXT and enters it on USEREMARKS.) (PROG ((NAME (CAR LIN)) TEXT) (COND ((OR (NULL NAME) (NULL (LITATOM NAME))) (ERROR (QUOTE "Arg not litatom:") NAME T)) ((SETQ TEXT (CADR (FASSOC NAME USERNOTES))) [EDITE (COND ((EQ (CADR TEXT) (QUOTE %%)) (* Don't edit the star and per-cent sign we put in for him.) (CDDR TEXT)) (T (CDR TEXT] (* Old remark; EDIT it.) (RETURN NAME)) ((LISTP (SETQ TEXT (CDR LIN))) (* He should be able to type either "REMARK NAME RANDOM TEXT" ) [COND ((AND (LISTP (CAR TEXT)) (NULL (CDR TEXT))) (* or "REMARK NAME(RANDOM TEXT]" ) (SETQ TEXT (CAR TEXT] (GO CHECKTXT)) ((NOT (LISPXREADP)) (PRIN1 (QUOTE "Text: ") T))) (SETQ TEXT (READ T T)) [COND ((NLISTP TEXT) (SETQ TEXT (CONS TEXT (READLINE] (* Make sure it works whether he types in a list or a line.) CHECKTXT (OR (EQ (CAR TEXT) COMMENTFLG) (SETQ TEXT (CONS COMMENTFLG TEXT))) (* Make sure it has a star.) (/SETATOMVAL (QUOTE USERNOTES) | (CONS (LIST NAME TEXT) | USERNOTES)) (* Enter on list of | remarks he has defined.) (RETURN NAME]) (GENREMNAM [LAMBDA (FN) (* Generates a name for a remark which has been used in the transformation for FN.) (PROG [(N 0) (NAM (PACK (LIST FN (QUOTE :] CHECKIT (COND ((NULL (FASSOC NAM USERNOTES)) (* Name hasn't been used already so is ok.) (RETURN NAM))) [SETQ NAM (PACK (LIST FN (SETQ N (ADD1 N)) (QUOTE :] (* Otherwise try again, adding, or incrementing, a suffix of the FORM n:) (GO CHECKIT]) (TXDELNOTE [LAMBDA (LIN) (* dcl: 7 Jul 76 16:02) (MAPCAR LIN (FUNCTION (LAMBDA (R1 TMP) (SETQ TMP (FASSOC R1 USERNOTES)) (COND [(NULL TMP) (CONS R1 (QUOTE (NOT FOUND] (T (/SETATOMVAL (QUOTE USERNOTES) | (/DREMOVE TMP USERNOTES)) | R1]) ) (RPAQQ TSETMACROS ((SHOW (TRANSUNDER TXSHOW)) (EXIT (TRANSUNDER TXEXIT)) (NOTE (TRANSUNDER TXNOTE T)) (TEST (TRANSUNDER TXTEST T)) (ERASE (TRANSUNDER TXERASE)) (EDIT (TRANSUNDER TXEDIT)) (DUMP (TRANSUNDER TXDUMP)) (FN (TRANSUNDER TXFN)) (DELNOTE (TRANSUNDER TXDELNOTE)))) (RPAQ LISPXMACROS (UNION TSETMACROS LISPXMACROS)) (RPAQ TESTFORM NIL) (RPAQ LISPXCOMS (UNION LISPXCOMS (MAPCAR TSETMACROS (FUNCTION CAR)))) (RPAQ MERGE NIL) (RPAQ PRETTYDEFMACROS (CONS [QUOTE (TRANSAVE NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS (PROP XFORM * TRANSFORMATIONS) (P (COND [(EQ (EVALV (QUOTE MERGE)) T) [RPAQ TRANSFORMATIONS (UNION TRANSFORMATIONS (LISTP (GETP (QUOTE TRANSFORMATIONS) (QUOTE VALUE] (MAPC (GETP (QUOTE USERNOTES) (QUOTE VALUE)) (FUNCTION (LAMBDA (NOTE) (OR (ASSOC (CAR NOTE) USERNOTES) (SETQ USERNOTES (CONS NOTE USERNOTES] (T (MAPC (GETP (QUOTE TRANSFORMATIONS) (QUOTE VALUE)) (FUNCTION (LAMBDA (X) (AND (NOT (MEMB X TRANSFORMATONS)) (/REMPROP X (QUOTE XFORM] PRETTYDEFMACROS)) (RPAQ LCASELST (APPEND (QUOTE (DO TRANSFORMATIONS)) LCASELST)) (PUTPROPS BBN UCASE T) (PUTPROPS LISP UCASE T) (PUTPROPS SRI UCASE T) (PUTPROPS MIT UCASE T) (PUTPROPS QA3 UCASE T) (PUTPROPS PLANNER UCASE T) (PUTPROPS UCI UCASE T) (PUTPROPS INTERLISP UCASE T) (PUTPROPS TSET FILEGROUP (TRANSOR TSET)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML TRANSUNDER) (ADDTOVAR LAMA ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (1734 16815 (TRANSORSET 1746 . 2634) (TRANSORINPUTP 2636 . 4331) (TRANSORSETUSERFN 4335 . 6136) (RUMARK 6138 . 6408) (RUMARK1 6410 . 7506) (TRANSUNDER 7508 . 8312) (TXFN 8314 . 8628) (TXFN1 8630 . 9888) (TXDUMP 9890 . 11415) (TXERASE 11417 . 11863) (TXERASE1 11865 . 12214) (TXTEST 12216 . 12999) (TXSHOW 13001 . 13545) (TXEDIT 13547 . 13990) (TXEXIT 13992 . 14156) (TXNOTE 14158 . 15791) ( GENREMNAM 15793 . 16479) (TXDELNOTE 16481 . 16813))))) STOP P \ No newline at end of file diff --git a/lispusers/TTYTALK b/lispusers/TTYTALK new file mode 100644 index 00000000..9346f713 --- /dev/null +++ b/lispusers/TTYTALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Jul-88 15:35:50" |{MCS:MCS:STANFORD}TTYTALK.;2| 6354 previous date%: "13-Jun-88 16:35:13" |{MCS:MCS:STANFORD}TTYTALK.;1|) (PRETTYCOMPRINT TTYTALKCOMS) (RPAQQ TTYTALKCOMS ((* TALK TTY Service) (LOCALVARS . T) (FNS TALK.TTY.DISPLAY TALK.TTY.LISTEN TALK.TTY.CHARFN) [INITVARS (TALK.TTY.FONT DEFAULTFONT) (TALK.TTY.TERMTABLE (COPYTERMTABLE 'ORIG] (GLOBALVARS TALK.TTY.FONT TALK.TTY.TERMTABLE) (FILES TALK) (APPENDVARS (GAP.SERVICETYPES (5 TTY TALK.NS.SERVER)) (TALK.SERVICETYPES (TTY TALK.TTY.DISPLAY TALK.TTY.LISTEN))) (P (ECHOCHAR (CHARCODE BS) 'IGNORE TALK.TTY.TERMTABLE)))) (* TALK TTY Service) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DEFINEQ (TALK.TTY.DISPLAY [LAMBDA (MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOLTYPE USER) (* ; "Edited 8-Jun-88 12:21 by cdl") (LET (PROCESS) (DSPFONT TALK.TTY.FONT MAINWINDOW) (DSPFONT TALK.TTY.FONT WINDOW) (DSPSCROLL 'ON MAINWINDOW) (DSPSCROLL 'ON WINDOW) (if USER then (WINDOWPROP MAINWINDOW 'ICON (CONCAT "Talk with " USER))) [WINDOWPROP MAINWINDOW 'TALK.TTY.PROCESS (SETQ PROCESS (ADD.PROCESS `(TALK.TTY.CHARFN ,MAINWINDOW ,OUTPUTSTREAM ,(with TALK.PROTOCOLTYPE PROTOCOLTYPE TALK.CASEARRAY ] (TTY.PROCESS PROCESS]) (TALK.TTY.LISTEN [LAMBDA (MAINWINDOW WINDOW INPUTSTREAM OUTPUTSTREAM PROTOCOLTYPE) (* ; "Edited 8-Jun-88 12:21 by cdl") (DECLARE (SPECVARS INPUTSTREAM)) (PROG ((POSITION (create POSITION)) (CHARWIDTH (CHARWIDTH (CHARCODE A) TALK.TTY.FONT)) BYTE PROCESS EVENTFN CASEARRAY EOM?) [with TALK.PROTOCOLTYPE PROTOCOLTYPE (SETQ EVENTFN TALK.EVENTFN) (SETQ CASEARRAY TALK.CASEARRAY) (SETQ EOM? (EQ TALK.PROTOCOLNAME 'NS] (while (OPENWP WINDOW) do (APPLY* EVENTFN INPUTSTREAM OUTPUTSTREAM) (if (NOT (AND (OPENP INPUTSTREAM) (OPENP OUTPUTSTREAM))) then (RETURN)) (TALK.FLASH.CARET WINDOW POSITION 'OFF) (bind CCODE while (AND (OPENP INPUTSTREAM) (PROGN (if EOM? then (SPP.CLEAREOM INPUTSTREAM T)) (READP INPUTSTREAM))) do (SETQ BYTE (LOGAND (SETQ CCODE (READCCODE INPUTSTREAM)) (MASK.1'S 0 8))) [if CASEARRAY then (SETQ BYTE (SETQ CCODE (ELT CASEARRAY BYTE] (SELCHARQ BYTE (LF NIL) (^G (TALK.RINGBELLS WINDOW)) (BS (if (GEQ (DSPXPOSITION NIL WINDOW) CHARWIDTH) then (DSPBACKUP CHARWIDTH WINDOW))) (PRINTCCODE CCODE WINDOW))) (TALK.FLASH.CARET WINDOW POSITION 'ON)) (WINDOWPROP MAINWINDOW 'ICON (CONCAT (WINDOWPROP MAINWINDOW 'ICON) TALK.CLOSED.STRING)) (if (PROCESSP (SETQ PROCESS (WINDOWPROP MAINWINDOW 'TALK.TTY.PROCESS NIL))) then (DEL.PROCESS PROCESS]) (TALK.TTY.CHARFN [LAMBDA (DISPLAYSTREAM OUTPUTSTREAM CHARARRAY) (* ; "Edited 9-Jun-88 15:02 by cdl") (DECLARE (SPECVARS DISPLAYSTREAM OUTPUTSTREAM CHARARRAY)) [RESETFORM (TTYDISPLAYSTREAM DISPLAYSTREAM) (bind CCODE (STREAM _ (GETSTREAM NIL 'INPUT)) (CHARWIDTH _ (CHARWIDTH (CHARCODE A) TALK.TTY.FONT)) declare%: (SPECVARS STREAM) while (AND (OPENP OUTPUTSTREAM) (OPENWP DISPLAYSTREAM)) do (if (SETQ CCODE (RESETLST (RESETSAVE (SETTERMTABLE TALK.TTY.TERMTABLE)) (RESETSAVE (CONTROL T)) (READCCODE STREAM))) then (SELCHARQ CCODE (BS (if (GEQ (DSPXPOSITION NIL DISPLAYSTREAM) CHARWIDTH) then (DSPBACKUP CHARWIDTH DISPLAYSTREAM))) NIL) (if CHARARRAY then (SETQ CCODE (ELT CHARARRAY CCODE))) (PRINTCCODE CCODE OUTPUTSTREAM) (if (NOT (READP STREAM T)) then (FORCEOUTPUT OUTPUTSTREAM] (TTY.PROCESS T]) ) (RPAQ? TALK.TTY.FONT DEFAULTFONT) (RPAQ? TALK.TTY.TERMTABLE (COPYTERMTABLE 'ORIG)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TALK.TTY.FONT TALK.TTY.TERMTABLE) ) (FILESLOAD TALK) (APPENDTOVAR GAP.SERVICETYPES (5 TTY TALK.NS.SERVER)) (APPENDTOVAR TALK.SERVICETYPES (TTY TALK.TTY.DISPLAY TALK.TTY.LISTEN)) (ECHOCHAR (CHARCODE BS) 'IGNORE TALK.TTY.TERMTABLE) (DECLARE%: DONTCOPY (FILEMAP (NIL (1045 5941 (TALK.TTY.DISPLAY 1055 . 2143) (TALK.TTY.LISTEN 2145 . 4428) (TALK.TTY.CHARFN 4430 . 5939))))) STOP \ No newline at end of file diff --git a/lispusers/TURBO-WINDOWS b/lispusers/TURBO-WINDOWS new file mode 100644 index 00000000..ec63132e --- /dev/null +++ b/lispusers/TURBO-WINDOWS @@ -0,0 +1 @@ +(FILECREATED "19-Oct-87 03:24:45" {PHYLUM}LISP>TURBO-WINDOWS.;14 18744 changes to: (ADVICE \GETREGIONTRACKWITHBOX DOWINDOWCOM) (FNS TW.CHECK-DEFAULT-REGION-WANTED TW.CHECK-KEYCHORDS TW.HELP) (VARS TURBO-WINDOWSCOMS) (PROPS (TURBO-WINDOWS MAKEFILE-ENVIRONMENT)) previous date: "26-Aug-87 22:48:43" {PHYLUM}LISP>TURBO-WINDOWS.;12) (* " Copyright (c) 1987 by Andrew J Cameron, III and Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TURBO-WINDOWSCOMS) (RPAQQ TURBO-WINDOWSCOMS [ (* ;; "AUTHOR: Andrew J. Cameron, III") (* ;; "This file add advice to the function called when the right mouse button is pressed while in a window. It defines a set of accelerators based on other keys which might be depresed when the right mouse button was depressed.") (* ;; "Also, a default size for a window can be accessed by using the middle button when orignally sizing a window.") (* ;; " ") (PROP MAKEFILE-ENVIRONMENT TURBO-WINDOWS) (* ;; "Would like to know the number of pixels per inch here") (INITVARS (GETREGIONDEFAULT (CONS (ITIMES 7 72) (ITIMES 9 72))) (TW.NO-FLASH-CLOSE) (TW.DONT-GROW-SNAP-BORDER) (TW.SNAP-HERE)) (SPECVARS GETREGIONDEFAULT TW.NO-FLASH-CLOSE TW.DONT-GROW-SNAP-BORDER TW.SNAP-HERE) (* ;;  "Need access to source-code for WINDOWS because we need the definition of record SCREEN. ") (DECLARE: DONTEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) WINDOW)) (FNS TW.CHECK-DEFAULT-REGION-WANTED TW.HELP SNAPW-WINDOW TW.CHECK-KEYCHORDS ) (ADVISE DOWINDOWCOM \GETREGIONTRACKWITHBOX) (* ;; "This adds SNAP-WINDOW as a slide-out from SNAP on IL:WindowMenuCommands") (P (LET ((foo (SASSOC (QUOTE Snap) WindowMenuCommands))) (if foo then [NCONC foo (QUOTE ((SUBITEMS ("Snap Window" (QUOTE SNAPW-WINDOW) "Saves a snapshot of this window" )) (SUBITEMS ("Snap Window" (QUOTE SNAPW-WINDOW) "Saves a snapshot of this window" ] (SETQ WindowMenu]) (* ;; "AUTHOR: Andrew J. Cameron, III") (* ;; "This file add advice to the function called when the right mouse button is pressed while in a window. It defines a set of accelerators based on other keys which might be depresed when the right mouse button was depressed." ) (* ;; "Also, a default size for a window can be accessed by using the middle button when orignally sizing a window." ) (* ;; " ") (PUTPROPS TURBO-WINDOWS MAKEFILE-ENVIRONMENT (PACKAGE "INTERLISP" READTABLE "OLD-INTERLISP-FILE")) (* ;; "Would like to know the number of pixels per inch here") (RPAQ? GETREGIONDEFAULT (CONS (ITIMES 7 72) (ITIMES 9 72))) (RPAQ? TW.NO-FLASH-CLOSE ) (RPAQ? TW.DONT-GROW-SNAP-BORDER ) (RPAQ? TW.SNAP-HERE ) (DECLARE: DOEVAL@COMPILE DONTCOPY (SPECVARS GETREGIONDEFAULT TW.NO-FLASH-CLOSE TW.DONT-GROW-SNAP-BORDER TW.SNAP-HERE) ) (* ;; "Need access to source-code for WINDOWS because we need the definition of record SCREEN. ") (DECLARE: DONTEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) WINDOW) ) (DEFINEQ (TW.CHECK-DEFAULT-REGION-WANTED [LAMBDA NIL (* ; "Edited 19-Oct-87 03:21 by andyiii") (* ;;  "Provides a default region if the middle button is depressed during the initial sizing of a window.") (DECLARE (SPECVARS GETREGIONDEFAULT BASEX BASEY OPPX OPPY)) (if (AND (BOUNDP (QUOTE GETREGIONDEFAULT)) (POSITIONP GETREGIONDEFAULT) (MOUSESTATE MIDDLE)) then (LET* ((x (fetch XCOORD of GETREGIONDEFAULT)) (y (fetch YCOORD of GETREGIONDEFAULT)) (maxx (IPLUS BASEX x)) (miny (IDIFFERENCE BASEY y))) (if (GREATERP maxx SCREENWIDTH) then (SETQ BASEX SCREENWIDTH) (SETQ OPPX (IDIFFERENCE SCREENWIDTH x)) else (SETQ OPPX maxx)) (if (LESSP miny 0) then (SETQ BASEY 0) (SETQ OPPY y) else (SETQ OPPY miny]) (TW.HELP [LAMBDA NIL (* ; "Edited 19-Oct-87 02:17 by andyiii") (* ;; "Print out a cribsheet to remind users of what to do.") (PRINTOUT T "TurboWindow CribSheet [S=Shift C=Control M=Meta]" T T) (PRINTOUT T "-ACTION- -CHORD- -OTHER WAY- -BACKGROUND-" T) (PRINTOUT T " Copy S Snap" T) (PRINTOUT T " Delete C * SlamWindows" T) (PRINTOUT T " Move SC " T) (PRINTOUT T " Shape M * PSW" T) (PRINTOUT T " Shrink MC * Idle" T) (PRINTOUT T " Bury SMC *" T) (PRINTOUT T " Redisplay MS *" T) (PRINTOUT T " Clear * Idle" T) (PRINTOUT T " Hardcopy " T) (PRINTOUT T " Inspect * PSW" T) (PRINTOUT T " PopShape *" T) (PRINTOUT T " This Help Help" T) (PRINTOUT T "[* = Presssing this key may have side-effects]"]) (SNAPW-WINDOW [LAMBDA (WINDOW ANDATTATCHEDWINDOWSTOO?) (* ; "Edited 22-Aug-87 00:24 by andyiii") (* ;; "makes a new window which is a copy of the bits in the WINDOW passed in.") (PROG (SCREENREGION SCREEN REGION NEWWINDOW BorderGrowth) (SETQ BorderGrowth (if (AND (BOUNDP (QUOTE TW.DONT-GROW-SNAP-BORDER)) TW.DONT-GROW-SNAP-BORDER) then 0 else WBorder)) (TOTOPW WINDOW) (SETQ SCREEN (WINDOWPROP WINDOW (QUOTE SCREEN))) [SETQ REGION (if ANDATTATCHEDWINDOWSTOO? then (WINDOWREGION WINDOW) else (WINDOWPROP WINDOW (QUOTE REGION] (SETQ NEWWINDOW (CREATEW (create SCREENREGION SCREEN _ SCREEN REGION _ (GROW/REGION REGION BorderGrowth)) NIL NIL T)) (* ;  "keep it closed so it doesn't cover any of the bits it is to copy.") (* ;  "put existing screen bits from SAVE.") (BITBLT (fetch (SCREEN SCDESTINATION) of SCREEN) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (WINDOW SAVE) of NEWWINDOW) BorderGrowth BorderGrowth (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) (QUOTE INPUT) (QUOTE REPLACE)) (OPENW NEWWINDOW) (if (AND (BOUNDP (QUOTE TW.SNAP-HERE)) TW.SNAP-HERE) else (MOVEW NEWWINDOW)) (RETURN NEWWINDOW]) (TW.CHECK-KEYCHORDS [LAMBDA (WINDOW) (* ; "Edited 19-Oct-87 02:18 by andyiii") (LET [(THE-WINDOW (OR (AND (BOUNDP (QUOTE WINDOW)) WINDOW) (WHICHW] [SETQ THE-WINDOW (if THE-WINDOW then (if (KEYDOWNP (QUOTE SPACE)) then THE-WINDOW else (MAINWINDOW THE-WINDOW T] (* ;; "(printout t %"Window %" the-window t)") (* ;; "") (* ;; "I want to use (shiftdownp 'meta) but it seems I must use (keydownp 'keyboard)") (* ;; " This happens when the KEYBOARD key is not defined to be the META key.") (COND ((AND (SHIFTDOWNP (QUOTE 1SHIFT)) (SHIFTDOWNP (QUOTE 2SHIFT))) (PRINTOUT T "How did you do that?" t) [GREMLINS (AND (SHIFTDOWNP (QUOTE CTRL)) (SHIFTDOWNP (QUOTE META] "RETURN") ([OR (SHIFTDOWNP (QUOTE 2SHIFT)) (AND (KEYDOWNP (QUOTE AGAIN)) (SHIFTDOWNP (QUOTE META] (* ;;; "CLEAR (must come before tests for SHIFT") (if THE-WINDOW then (CLEARW THE-WINDOW) else (IDLE)) "RETURN") ((KEYDOWNP (QUOTE OPEN)) (* ; "the HELP key") (* ;;; "INSPECT") (if (SHIFTDOWNP (QUOTE META)) then (if THE-WINDOW then (INSPECT THE-WINDOW) else (PROCESS.STATUS.WINDOW)) else (TW.HELP)) "RETURN") ([OR (AND (KEYDOWNP (QUOTE SAME)) (NOT (SHIFTDOWNP (QUOTE SHIFT))) (NOT (SHIFTDOWNP (QUOTE CTRL))) (SHIFTDOWNP (QUOTE META))) (AND (NOT (KEYDOWNP (QUOTE SAME))) (NOT (SHIFTDOWNP (QUOTE SHIFT))) (SHIFTDOWNP (QUOTE CTRL)) (SHIFTDOWNP (QUOTE META] (* ;;; "SHRINK") (if THE-WINDOW then (SHRINKW THE-WINDOW) else (IDLE)) "RETURN") ([OR (KEYDOWNP (QUOTE MOVE)) (AND (SHIFTDOWNP (QUOTE SHIFT)) (SHIFTDOWNP (QUOTE CTRL)) (NOT (SHIFTDOWNP (QUOTE META] (* ;;; "MOVE") (MOVEW THE-WINDOW) "RETURN") ([OR [AND (KEYDOWNP (QUOTE SAME)) (NOT (SHIFTDOWNP (QUOTE SHIFT))) (NOT (SHIFTDOWNP (QUOTE CTRL))) (NOT (SHIFTDOWNP (QUOTE META] (AND (NOT (KEYDOWNP (QUOTE SAME))) (NOT (SHIFTDOWNP (QUOTE SHIFT))) (NOT (SHIFTDOWNP (QUOTE CTRL))) (SHIFTDOWNP (QUOTE META] (* ;;; "SHAPE") (if THE-WINDOW then (if (GETD (QUOTE SHAPEW.AND.SAVE)) then (SHAPEW.AND.SAVE THE-WINDOW) else (SHAPEW THE-WINDOW)) else (PROCESS.STATUS.WINDOW)) "RETURN") ([OR (KEYDOWNP (QUOTE COPY)) (AND (SHIFTDOWNP (QUOTE SHIFT)) (NOT (SHIFTDOWNP (QUOTE CTRL))) (NOT (SHIFTDOWNP (QUOTE META] (* ;;; "COPY (snap of hardcopy)") [if (AND (KEYDOWNP (QUOTE COPY)) (SHIFTDOWNP (QUOTE SHIFT))) then (LET [(FN (MENU (create MENU ITEMS _ (QUOTE (("To default printer" (QUOTE HARDCOPYIMAGEW ) "Prints a window using its HARDCOPYFN." ) ("To a file" (QUOTE HARDCOPYIMAGEW.TOFILE ) "Puts image on a file; prompts for filename and format" ) ("To another printer" (QUOTE HARDCOPYIMAGEW.TOPRINTER ) "Sends image to a printer of your choosing" ))) CHANGEOFFSETFLG _ (QUOTE Y) MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) WHENHELDFN _ (FUNCTION PPROMPT3) WHENUNHELDFN _ (FUNCTION CLRPROMPT) CENTERFLG _ T] (if FN then (APPLY* FN THE-WINDOW))) else (SNAPW-WINDOW (TOTOPW THE-WINDOW) (NOT (KEYDOWNP (QUOTE SPACE] "RETURN") ([OR (KEYDOWNP (QUOTE AGAIN)) (AND (SHIFTDOWNP (QUOTE SHIFT)) (NOT (SHIFTDOWNP (QUOTE CTRL))) (SHIFTDOWNP (QUOTE META] (* ;;; " REDISPLAY") (if THE-WINDOW then (REDISPLAYW THE-WINDOW)) "RETURN") ([OR (KEYDOWNP (QUOTE FIND)) (AND (SHIFTDOWNP (QUOTE SHIFT)) (SHIFTDOWNP (QUOTE CTRL)) (SHIFTDOWNP (QUOTE META] (* ;;; "BURY") (if THE-WINDOW then (BURYW THE-WINDOW)) "RETURN") ([OR (KEYDOWNP (QUOTE DELETE)) (AND (NOT (SHIFTDOWNP (QUOTE SHIFT))) (SHIFTDOWNP (QUOTE CTRL)) (NOT (SHIFTDOWNP (QUOTE META] (* ;;; "CLOSE") (if THE-WINDOW then (if (AND (BOUNDP (QUOTE TW.NO-FLASH-CLOSE)) TW.NO-FLASH-CLOSE) else (FLASHWINDOW THE-WINDOW)) (* ;  "show the user the window about to be closed") (while (KEYDOWNP (QUOTE RIGHT))) (GETMOUSESTATE) (* ;  "only close it if they have not release teh delete key nor moved out of the window") (if (AND (OR (SHIFTDOWNP (QUOTE CTRL)) (KEYDOWNP (QUOTE DELETE))) (INSIDEP (WINDOWPROP THE-WINDOW (QUOTE REGION)) LASTMOUSEX LASTMOUSEY)) then (CLOSEW THE-WINDOW) "RETURN") else (* ; "the background was selected") (if (GETD (QUOTE CLOSE.WINDOWS.IN.REGION)) then (PROMPTPRINT "Specify the Slamming region") (CLOSE.WINDOWS.IN.REGION) else (PROMPTPRINT "Window slamming is not available - You need to load WDHACKS" )) "RETURN")) ([OR (KEYDOWNP (QUOTE UNDO)) (AND (KEYDOWNP (QUOTE SAME)) (SHIFTDOWNP (QUOTE SHIFT] (* ;;; "POP-SHAPE") (if THE-WINDOW then (IF (GETD (QUOTE SHAPEW.POP)) THEN (SHAPEW.POP THE-WINDOW) ELSE (PROMPTPRINT "Window shape-popping is not available - You need to load WDHACKS" ))) "RETURN"]) ) [XCLREINSTALL-ADVICE (QUOTE DOWINDOWCOM) BEFORE (QUOTE ((FIRST (if (EQUAL (TW.CHECK-KEYCHORDS WINDOW) "RETURN") then (RETURN] [XCLREINSTALL-ADVICE (QUOTE \GETREGIONTRACKWITHBOX) AFTER (QUOTE ((FIRST (TW.CHECK-DEFAULT-REGION-WANTED] (READVISE DOWINDOWCOM \GETREGIONTRACKWITHBOX) (* ;; "This adds SNAP-WINDOW as a slide-out from SNAP on IL:WindowMenuCommands") (LET ((foo (SASSOC (QUOTE Snap) WindowMenuCommands))) (if foo then [NCONC foo (QUOTE ((SUBITEMS ("Snap Window" (QUOTE SNAPW-WINDOW) "Saves a snapshot of this window")) (SUBITEMS ("Snap Window" (QUOTE SNAPW-WINDOW) "Saves a snapshot of this window"] (SETQ WindowMenu))) (PUTPROPS TURBO-WINDOWS COPYRIGHT ("Andrew J Cameron, III and Xerox Corporation" 1987)) (DECLARE: DONTCOPY (FILEMAP (NIL (4679 17699 (TW.CHECK-DEFAULT-REGION-WANTED 4689 . 5806) (TW.HELP 5808 . 6790) ( SNAPW-WINDOW 6792 . 8789) (TW.CHECK-KEYCHORDS 8791 . 17697))))) STOP \ No newline at end of file diff --git a/lispusers/TURBO-WINDOWS.TEDIT b/lispusers/TURBO-WINDOWS.TEDIT new file mode 100644 index 00000000..109912a4 --- /dev/null +++ b/lispusers/TURBO-WINDOWS.TEDIT @@ -0,0 +1,12 @@ +enˇvĹos TURBO-WINDOWS 2 4 1 TURBO-WINDOWS 1 4 By: Andrew J. Cameron, III (Cameron.pa@Xerox.com or cameron@cs.wisc.edu) New Owner: Atty Mullins (Mullins.pa@Xerox.com) Uses: WDHACKS (LispUsers) [optional] This document last edited on Sept. 8, 1988. INTRODUCTION Turbo-Windows does not have anything to do with speeding up primitive window operations, but rather it helps speed up your use and manipulation of windows by providing most of the right button menu functions via shift keychords. In this way one can Move, Shape, Copy, Shrink, Close, etc., a window without having to wait for the right button menu to appear and then select from it. Also, when providing the INITIAL shape of a window, pressing the middle button yields a large default size suitable for TEdit, etc. (Recall that using the middle button during a RESIZING operation allows you to keep roughly the original window shape and then move the corner nearest the cursor when the middle button was pressed.) One can bring up a brief cribsheet for all the TurboWindow keychord commands by holding down the HELP key and RIGHT buttoning on the background (not in any window). This can also be produce by typing (TW.HELP) to an InterLisp EXEC. OPERATION Before discussing how to use this utility, a description of how the key-chords were chosen is in order. They are based loosely on the effect of the shift keys in TEdit. Recall that in TEdit, pressing and holding the Shift key Copies whatever is selected. Also, pressing and holding the Control key (sometimes labeled PROPS or EDIT) Deletes whatever is selected. Pressing both Shift and Control performs both a copy and a delete, which ends up Moving the selected item. The only additional piece of information that you need to know is that the Meta key (sometimes labeled KEYBOARD or ALT) modifies an operation or in some way makes it different. With this general interpretation, most of the key-chords are rather easy to remember. If the following keys are chorded (held down together) while the right mouse button is pressed in the region of a window which would normally bring up the right-button menu (by convention, at least the title bar should provide the right button menu), the listed operation will be invoked without actually bringing up the right button menu. SHIFT (using the LEFT SHIFT key or CAPS LOCK key) Makes a copy of a window by snapping it. CONTROL Closes (deletes) a window. (Since this is a destructive operation, a small safeguard is built into this operation. If one holds the CONTROL key and depresses the right mouse button and continues to hold them, the window to be operated on (closed) will blink. If this is not the window you want to close you can cancel the Turbo-Close by either moving outside the window (or by releasing the CONTROL key before releasing the right mouse button). If you abort the Turbo-Close in this manner, the normal right button menu will appear. Clicking outside of the menu will make it go away. Sometimes unexpected things occur when trying to Turbo-Close windows with attached windows, e.g. FileBrowsers, but hopefully this safeguard is conservative enough to avoid inadvertent closing of the wrong window.) [Holding down CONTROL while Right Buttoning on the background activates Window Slamming, if the LispUsers utility WDHACKS is loaded.) META Shape (makes different) a window. SHIFT-CONTROL Moves a window. (Due to the design of the InterLisp window system, this operation works in a rather strange way. You press and hold both CONTROL and SHIFT and then press the right mouse button while in the appropriate part (title bar) of the window you want to move. You then need to release the right button to be able to actually move the window. In order to "drop" the window (here is the strange part) you need to press the LEFT (or middle) button. Pressing the right button merely allows you to move to a different corner of the shadow box.) META-CONTROL Shrinks ("deletes" in a different way) a window. META-SHIFT Redisplays (copies in a different way) a window. META-SHIFT-CONTROL Buries (moves in a different way) a window. [You might also think of this as pushing the window down to the bottom, as you are pressing down all three shift keys.] RIGHT-SHIFT Clears a window. HELP Pressing the HELP key while the cursor is in the background (or typing (TW.HELP) to an InterLisp EXEC) displays a cribsheet for the Turbo-Window KeyChords. Some addition capabilities not listed here are given on that cribsheet. The "OTHER" keychords which are marked with an asterisk (*) indicate that some side-effect (potentially quite harmful) might occur depending on where the TTY is when those alternate access methods are used. You are warned! GETTING STARTED [If any of the operations described below do not perform properly, it might be the case that your keys are not defined in the way that this utility expects. See INTERNALS below for more information.] You might want to get familiar with Turbo-Windows by first bringing up the cribsheet by depressing the HELP key and right-buttoning on the background. Next, make a copy of the cribsheet by depressing SHIFT (the left shift key) and right-buttoning on the cribsheet. Drop the new copy of the cribsheet by releasing all keys and buttons and the pressing the left mouse button. [Note: The cribsheet is merely written to the TTY window, which happens to be sensitive to the right mouse button everywhere. Other windows may only be sensitive to the right button (for the purpose of bringing up the right button menu, in their title bar.] Now try moving the copied cribsheet by pressing both SHIFT and CONTROL (PROPS or EDIT) and right-buttoning on the copy of the cribsheet. Again, release everything (well, just releasing the mouse button will do) and press the left mouse button to drop it. Press and hold both META (KEYBOARD) and CONTROL while right buttoning in the copy of the cribsheet to shrink it to an icon. Release and click the left mouse button to drop the icon. Reopen (expand) the icon by middle buttoning on it. Reshape the copy of the cribsheet by pressing META and right buttoning on the copy's window. Release and rubberband the new shape with the left mouse button. (Do you know what would happen if you used the middle button after releasing instead? Try it.) Assuming the copy of the cribsheet is overlapping another window and some part of the background (if not, Turbo-Move it so it is), press and hold all three (META, SHIFT, and CONTROL) and right button in the cribsheet copy's window to bury it. Right button (holding no other keys) in the partially exposed area of the now buried cribsheet copy to bring it back to the top. Finally, close the copied cribsheet window by pressing CONTROL while right buttoning in the copy's window. [O.K. which shift key combination hasn't been used yet? Consult the original cribsheet (or produce it again), if necessary. Give that combination a try in the original cribsheet's window. [Did you notice the message in the prompt window?] And don't forget to give the Right Shift key (Clears a window) a try as well. [Remember, the cribsheet can be brought back at any time using HELP-RightButton on the background.] ) To see how to cancel a Turbo-Close, depress the CONTROL key and press AND HOLD the right mouse button while in the original cribsheet window. Notice that the window blinks. Before you release the right mouse button move the cursor outside the cribsheet's window and then release the right mouse button. The cribsheet's window is not closed because releasing outside the window that flashed cancels the Turbo-Close. The normal right button menu appears instead. Click outside it to get rid of it. Now, actually close the original cribsheet window. And with that, may I welcome you to the fast paced world of Turbo-Windows. INTERNALS The right button events are intercepted by a piece of advice placed on DOWINDOWCOM. The middle button sizing capability is provide by advice on \GETREGIONTRACKWITHBOX. The window snapping Turbo-Window feature (LeftShift-RightMouseButton) is also added as a submenu to the normal right button menu provided by the window system. A common problem is that the META key is not defined to be at the proper place (attached to the key named KEYBOARD). To remedy this, type: (KEYACTION 'KEYBOARD '(METADOWN . METAUP)) to an InterLisp EXEC. The following should also be the case: (KEYACTION 'EDIT '(CTRLDOWN . CTRLUP)) (KEYACTION 'LSHIFT '(1SHIFTDOWN . 1SHIFTUP)) (KEYACTION 'RSHIFT '(2SHIFTDOWN . 2SHIFTUP)) These can be verified by using, for example: (KEYACTION 'EDIT) TW.NO-FLASH-CLOSE [Variable] Initially NIL, if set to T, windows will not flash to indicate there impending closure. TW.DONT-GROW-SNAP-BORDER [Variable] Initially NIL, if set to T, windows will be copied without a small border. The small border is quite handy in telling the original window from its Turbo-Snapped copy. TW.SNAP-HERE [Variable] Initially NIL, if set to T, windows will be copied directly on top of the window they are duplicating. Normally (when NIL) the user must position the copy. GETREGIONDEFAULT [Variable] This variable can be bound dynamically by an application to provide the region afforded by middle buttoning when prompted for an initial region of a window. It is initially set to roughly 7x9 inches, and is useful for TEdit windows, FileBrowsers, etc. [See the LispUsers utility RESIZE-FILEBROWSER for an even better way of dealing with FileBrowsers.] ˙˙ďf˙ In order to edit/compile the source of this utility, the InterLisp Source file WINDOW must be loaded in order to provide the SCREEN record definition used by the window system internals. The loading of this source file occurs automatically when this utility's source file is loaded. ˙˙ďf˙ This utility interacts poorly with other utilities that redefine any of the shift keys. TEDITKEY and PC-Emulation (among others) are dubious in this regard. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 277) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) +2Č3ČČT-ČT-ČT,Č,Č,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD CLASSICCLASSICCLASSICTERMINAL + HELVETICA +MODERN +MODERN +MODERN MODERN +  + HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN + HRULE.GETFNMODERN   HRULE.GETFNMODERN z'+ ‚Lé +ăT4)Ť"* 1 1Ľ ĆË s Š Œ0>,22- X ¨  Ÿ b#Ą'X™zş \ No newline at end of file diff --git a/lispusers/TWODGRAPHICS b/lispusers/TWODGRAPHICS new file mode 100644 index 00000000..46fa9da9 --- /dev/null +++ b/lispusers/TWODGRAPHICS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-May-87 14:09:27" {QV}LISP>TWODGRAPHICS.;3 47028 changes to%: (VARS TWODGRAPHICSCOMS) (FNS CLIPPED.BITBLT CREATEVIEWPORT SETSTREAMSUBREGION SETWORLDREGION TWODGRAPHICS.BITBLT CLIPPED.BLTSHADE COMPUTETRANSFORM COMPUTEWORLDREGION STREAMREGIONTOWORLDREGION STREAMTOWORLD TWODGRAPHICS.CLOSEFN TWODGRAPHICS.DRAWTO TWODGRAPHICS.DRAWLINE TWODGRAPHICS.DRAWTOPT TWODGRAPHICS.DSPFILL TWODGRAPHICS.DSPRESET TWODGRAPHICS.MOVETO TWODGRAPHICS.MOVETOPT TWODGRAPHICS.PLOTAT TWODGRAPHICS.RELDRAWTO TWODGRAPHICS.RELDRAWTOPT TWODGRAPHICS.RELMOVETO TWODGRAPHICS.RESHAPEFN WORLDREGIONTOSTREAMREGION WORLDTOSTREAM CLIPCODE CLIPPED.DESTREGION CLIPPED.DRAWBETWEEN CLIPPED.DRAWLINE CLIPPED.DRAWTO CLIPPED.PLOTAT CLIPPED.PRIN1 CLIPPED.RELDRAWTO CLIPPED.SOURCEREGION REPLACE.REGION) previous date%: " 6-May-87 12:19:11" {QV}LISP>TWODGRAPHICS.;2) (* " Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TWODGRAPHICSCOMS) (RPAQQ TWODGRAPHICSCOMS ( (* ;; "World to window transforms") (FNS CREATEVIEWPORT COMPUTETRANSFORM COMPUTEWORLDREGION SETSTREAMSUBREGION SETWORLDREGION STREAMREGIONTOWORLDREGION STREAMTOWORLD TWODGRAPHICS.BITBLT TWODGRAPHICS.CLOSEFN TWODGRAPHICS.DRAWBETWEEN TWODGRAPHICS.DRAWLINE TWODGRAPHICS.DRAWTO TWODGRAPHICS.DRAWTOPT TWODGRAPHICS.DSPFILL TWODGRAPHICS.DSPRESET TWODGRAPHICS.INIT TWODGRAPHICS.MOVETO TWODGRAPHICS.MOVETOPT TWODGRAPHICS.PLOTAT TWODGRAPHICS.RELDRAWTO TWODGRAPHICS.RELDRAWTOPT TWODGRAPHICS.RELMOVETO TWODGRAPHICS.RELMOVETOPT TWODGRAPHICS.RESHAPEFN WORLDREGIONTOSTREAMREGION WORLDTOSTREAM) (MACROS STREAMTOWORLDX STREAMTOWORLDXLENGTH STREAMTOWORLDY STREAMTOWORLDYLENGTH WORLDTOSTREAMX WORLDTOSTREAMXLENGTH WORLDTOSTREAMY WORLDTOSTREAMYLENGTH) (RECORDS VIEWPORT) (* ;; "Primitive clipping FNS") (FNS CLIPCODE CLIPPED.BITBLT CLIPPED.BLTSHADE CLIPPED.DRAWBETWEEN CLIPPED.DRAWLINE CLIPPED.DRAWTO CLIPPED.PLOTAT CLIPPED.PRIN1 CLIPPED.RELDRAWTO) (MACROS SWAPARGS) (* ;; "For unboxed floating point games") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES UNBOXEDOPS)) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (* ;; "World to window transforms") (DEFINEQ (CREATEVIEWPORT [LAMBDA (STREAM STREAMSUBREGION SOURCE) (* ; "Edited 6-May-87 10:37 by jop") (* ;; "Create a viewport. If source is a region , then treat it as a region in world coorinates and set up the transformation to stream coorindates. If source is a Viewport, inherit the transformation and set up the world coordinates. If Source is NIL then supply a default WORLDREGION. In either case if STREAM is a STREAM then inter the viewport in the VIEWPORTS property of the window.") (PROG ((STREAMCLIPPINGREGION (DSPCLIPPINGREGION NIL STREAM)) VIEWPORT) [COND ((NULL STREAMSUBREGION) (SETQ STREAMSUBREGION (with REGION STREAMCLIPPINGREGION (CREATEREGION LEFT BOTTOM WIDTH HEIGHT] [COND ((NULL SOURCE) (SETQ SOURCE (CREATEREGION 0.0 0.0 1.0 1.0] (COND ((NOT (SUBREGIONP STREAMCLIPPINGREGION STREAMSUBREGION)) (CL:ERROR "~s not a subregion of ~s" STREAMSUBREGION STREAMCLIPPINGREGION))) [SETQ VIEWPORT (COND ((type? REGION SOURCE) (COMPUTETRANSFORM (create VIEWPORT PARENTSTREAM _ STREAM STREAMSUBREGION _ STREAMSUBREGION WORLDREGION _ SOURCE))) ((type? VIEWPORT SOURCE) (COMPUTEWORLDREGION (create VIEWPORT PARENTSTREAM _ STREAM STREAMSUBREGION _ STREAMSUBREGION using SOURCE))) (T (ERROR "Not region or viewort: ~S" SOURCE] (COND ((WINDOWP STREAM) (TWODGRAPHICS.INIT STREAM) (WINDOWADDPROP STREAM 'VIEWPORTS VIEWPORT))) (RETURN VIEWPORT]) (COMPUTETRANSFORM [LAMBDA (VIEWPORT) (* ; "Edited 5-May-87 16:32 by jop") (* ;;  "Computes the world to window transformation given a viewport's windowsubregion and worldregion") (PROG ((STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (WORLDREGION (fetch (VIEWPORT WORLDREGION) of VIEWPORT))) (* ;  "SUB1 since we are dealing width an integer grid") (replace WORLDTOSTREAMMX of VIEWPORT with (FQUOTIENT (SUB1 (fetch WIDTH of STREAMSUBREGION) ) (fetch WIDTH of WORLDREGION))) [replace WORLDTOSTREAMAX of VIEWPORT with (FDIFFERENCE (fetch LEFT of STREAMSUBREGION) (FTIMES (fetch WORLDTOSTREAMMX of VIEWPORT) (fetch LEFT of WORLDREGION] (* ; "Ditto") (replace WORLDTOSTREAMMY of VIEWPORT with (FQUOTIENT (SUB1 (fetch HEIGHT of STREAMSUBREGION )) (fetch HEIGHT of WORLDREGION))) [replace WORLDTOSTREAMAY of VIEWPORT with (FDIFFERENCE (fetch BOTTOM of STREAMSUBREGION) (FTIMES (fetch WORLDTOSTREAMMY of VIEWPORT) (fetch BOTTOM of WORLDREGION] (replace STREAMTOWORLDMX of VIEWPORT with (FQUOTIENT 1.0 (fetch WORLDTOSTREAMMX of VIEWPORT))) [replace STREAMTOWORLDAX of VIEWPORT with (UFMINUS (FQUOTIENT (fetch WORLDTOSTREAMAX of VIEWPORT) (fetch WORLDTOSTREAMMX of VIEWPORT] (replace STREAMTOWORLDMY of VIEWPORT with (FQUOTIENT 1.0 (fetch WORLDTOSTREAMMY of VIEWPORT))) [replace STREAMTOWORLDAY of VIEWPORT with (UFMINUS (FQUOTIENT (fetch WORLDTOSTREAMAY of VIEWPORT) (fetch WORLDTOSTREAMMY of VIEWPORT] (RETURN VIEWPORT]) (COMPUTEWORLDREGION [LAMBDA (VIEWPORT) (* ; "Edited 5-May-87 16:32 by jop") (* ;;  "Given a Viewport's World to Stream transformation computes the corresponding World region") (PROG ((STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (MX (fetch (VIEWPORT WORLDTOSTREAMMX) of VIEWPORT)) (AX (fetch (VIEWPORT WORLDTOSTREAMAX) of VIEWPORT)) (MY (fetch (VIEWPORT WORLDTOSTREAMMY) of VIEWPORT)) (AY (fetch (VIEWPORT WORLDTOSTREAMAY) of VIEWPORT)) WORREGION) [SETQ WORREGION (with REGION STREAMSUBREGION (CREATEREGION (FQUOTIENT (FDIFFERENCE LEFT AX) MX) (FQUOTIENT (FDIFFERENCE BOTTOM AY) MY) (FQUOTIENT WIDTH MX) (FQUOTIENT HEIGHT MY] (replace (VIEWPORT WORLDREGION) of VIEWPORT with WORREGION) (RETURN VIEWPORT]) (SETSTREAMSUBREGION [LAMBDA (REGION VIEWPORT) (* ; "Edited 6-May-87 10:38 by jop") (* ;; "Set the STREAMSUBREGION of a VIEWPORT") (if (NOT (type? VIEWPORT VIEWPORT)) then (CL:ERROR "Not a VIEWPORT: ~s" VIEWPORT)) (if (NOT (SUBREGIONP (WINDOWPROP (fetch PARENTSTREAM of VIEWPORT) 'WINCLIPPINGREGION) REGION)) then (CL:ERROR "Not a subregion of stream: ~s" REGION)) (replace (VIEWPORT STREAMSUBREGION) of VIEWPORT with REGION) (COMPUTETRANSFORM VIEWPORT]) (SETWORLDREGION [LAMBDA (REGION VIEWPORT) (* ; "Edited 6-May-87 10:38 by jop") (* ;; "Set the WORLDREGION of a VIEWPORT") (if (NOT (type? VIEWPORT VIEWPORT)) then (CL:ERROR "Not a viewport: ~s" VIEWPORT)) (replace (VIEWPORT WORLDREGION) of VIEWPORT with REGION) (COMPUTETRANSFORM VIEWPORT]) (STREAMREGIONTOWORLDREGION [LAMBDA (REGION VIEWPORT) (* ; "Edited 5-May-87 16:33 by jop") (CREATEREGION (STREAMTOWORLDX (fetch (REGION LEFT) of REGION) VIEWPORT) (STREAMTOWORLDY (fetch (REGION BOTTOM) of REGION) VIEWPORT) (STREAMTOWORLDXLENGTH (fetch (REGION WIDTH) of REGION) VIEWPORT) (STREAMTOWORLDYLENGTH (fetch (REGION HEIGHT) of REGION) VIEWPORT]) (STREAMTOWORLD [LAMBDA (PT VIEWPORT OLDPT) (* ; "Edited 5-May-87 16:33 by jop") (* ;; "smashes OLDPT if provided") (COND (OLDPT (create POSITION XCOORD _ (STREAMTOWORLDX (fetch (POSITION XCOORD) of PT) VIEWPORT) YCOORD _ (STREAMTOWORLDY (fetch (POSITION YCOORD) of PT) VIEWPORT) smashing OLDPT)) (T (create POSITION XCOORD _ (STREAMTOWORLDX (fetch (POSITION XCOORD) of PT) VIEWPORT) YCOORD _ (STREAMTOWORLDY (fetch (POSITION YCOORD) of PT) VIEWPORT]) (TWODGRAPHICS.BITBLT [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATIONVIEWPORT DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* ; "Edited 6-May-87 10:38 by jop") (* ;; "Destination MUST be a VIEWPORT. Source can be either a VIEWPORT or some other form of BITMAP (in which case no transformations are performed) or NIL") (if (NULL DESTINATIONVIEWPORT) then (SETQ DESTINATIONVIEWPORT TWODGRAPHICS.CURRENTVIEWPORT)) (if (NOT (type? VIEWPORT DESTINATIONVIEWPORT)) then (CL:ERROR "Destination not a viewport: ~s" DESTINATIONVIEWPORT)) (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of DESTINATIONVIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of DESTINATIONVIEWPORT)) (STREAMLEFT (if (NULL DESTINATIONLEFT) then (fetch (REGION LEFT) of STREAMSUBREGION) else (WORLDTOSTREAMX DESTINATIONLEFT DESTINATIONVIEWPORT))) (STREAMBOTTOM (if (NULL DESTINATIONBOTTOM) then (fetch (REGION BOTTOM) of STREAMSUBREGION) else (WORLDTOSTREAMY DESTINATIONBOTTOM DESTINATIONVIEWPORT))) [STREAMCLIPPINGREGION (if (NULL CLIPPINGREGION) then STREAMSUBREGION else (INTERSECTREGIONS STREAMSUBREGION (WORLDREGIONTOSTREAMREGION CLIPPINGREGION DESTINATIONVIEWPORT] (SOURCEBITMAP SOURCE) (SOURCEBITMAPLEFT SOURCELEFT) (SOURCEBITMAPBOTTOM SOURCEBOTTOM) (SOURCEWIDTH WIDTH) (SOURCEHEIGHT HEIGHT)) [if (type? VIEWPORT SOURCE) then (SETQ SOURCEBITMAP (fetch (VIEWPORT PARENTSTREAM) of SOURCE)) (LET ((SOURCESUBREGION (fetch (VIEWPORT STREAMSUBREGION) of SOURCE))) (SETQ SOURCEBITMAPLEFT (if (NULL SOURCELEFT) then (fetch (REGION LEFT) of SOURCESUBREGION) else (WORLDTOSTREAMX SOURCELEFT SOURCE))) (SETQ SOURCEBITMAPBOTTOM (if (NULL SOURCEBOTTOM) then (fetch (REGION BOTTOM) of SOURCESUBREGION) else (WORLDTOSTREAMY SOURCEBOTTOM SOURCE))) (SETQ SOURCEWIDTH (if (NULL WIDTH) then (fetch (REGION WIDTH) of SOURCESUBREGION) else (WORLDTOSTREAMXLENGTH WIDTH SOURCE))) (SETQ SOURCEHEIGHT (if (NULL HEIGHT) then (fetch (REGION HEIGHT) of SOURCESUBREGION) else (WORLDTOSTREAMYLENGTH HEIGHT SOURCE))) (SETQ STREAMCLIPPINGREGION (INTERSECTREGIONS STREAMCLIPPINGREGION SOURCESUBREGION] [if (EQ SOURCETYPE 'TEXTURE) then (SETQ SOURCEWIDTH (if (NULL WIDTH) then (fetch (REGION WIDTH) of STREAMSUBREGION) else (WORLDTOSTREAMXLENGTH WIDTH DESTINATIONVIEWPORT))) (SETQ SOURCEHEIGHT (if (NULL HEIGHT) then (fetch (REGION HEIGHT) of STREAMSUBREGION) else (WORLDTOSTREAMYLENGTH HEIGHT DESTINATIONVIEWPORT] (CLIPPED.BITBLT STREAMCLIPPINGREGION SOURCEBITMAP SOURCEBITMAPLEFT SOURCEBITMAPBOTTOM STREAM STREAMLEFT STREAMBOTTOM SOURCEWIDTH SOURCEHEIGHT SOURCETYPE OPERATION TEXTURE ]) (TWODGRAPHICS.CLOSEFN [LAMBDA (W) (* ; "Edited 5-May-87 16:34 by jop") (* ;; "Break circularities") (WINDOWPROP W 'TWODPROPS? NIL) (WINDOWPROP W 'VIEWPORTS NIL) (WINDOWPROP W 'WINCLIPPINGREGION NIL) (WINDOWDELPROP W 'CLOSEFN (FUNCTION TWODGRAPHICS.CLOSEFN)) (WINDOWDELPROP W 'RESHAPEFN (FUNCTION TWODGRAPHICS.RESHAPEFN]) (TWODGRAPHICS.DRAWBETWEEN [LAMBDA (PT1 PT2 WIDTH OPERATION VIEWPORT COLOR DASHING) (* jop%: " 4-Dec-85 15:38") (TWODGRAPHICS.DRAWLINE (fetch XCOORD of PT1) (fetch YCOORD of PT1) (fetch XCOORD of PT2) (fetch YCOORD of PT2) WIDTH OPERATION VIEWPORT COLOR DASHING]) (TWODGRAPHICS.DRAWLINE [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION VIEWPORT COLOR DASHING) (* ; "Edited 5-May-87 17:12 by jop") (LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (CLIPPINGREGION (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMX1 (WORLDTOSTREAMX X1 VIEWPORT)) (STREAMY1 (WORLDTOSTREAMY Y1 VIEWPORT)) (STREAMX2 (WORLDTOSTREAMX X2 VIEWPORT)) (STREAMY2 (WORLDTOSTREAMY Y2 VIEWPORT))) (CLIPPED.DRAWLINE CLIPPINGREGION STREAMX1 STREAMY1 STREAMX2 STREAMY2 WIDTH OPERATION STREAM COLOR DASHING]) (TWODGRAPHICS.DRAWTO [LAMBDA (X Y WIDTH OPERATION VIEWPORT COLOR DASHING) (* ; "Edited 5-May-87 16:34 by jop") (LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (CLIPPINGREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (STREAMX (WORLDTOSTREAMX X VIEWPORT)) (STREAMY (WORLDTOSTREAMY Y VIEWPORT))) (CLIPPED.DRAWTO CLIPPINGREGION STREAMX STREAMY WIDTH OPERATION STREAM COLOR DASHING]) (TWODGRAPHICS.DRAWTOPT [LAMBDA (PT WIDTH OPERATION VIEWPORT COLOR DASHING) (* ; "Edited 5-May-87 17:13 by jop") (TWODGRAPHICS.DRAWTO (fetch XCOORD of PT) (fetch YCOORD of PT) WIDTH OPERATION VIEWPORT COLOR DASHING]) (TWODGRAPHICS.DSPFILL [LAMBDA (REGION TEXTURE OPERATION VIEWPORT) (* ; "Edited 5-May-87 17:14 by jop") (LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))) (TWODGRAPHICS.BITBLT NIL NIL NIL VIEWPORT NIL NIL NIL NIL 'TEXTURE (OR OPERATION (DSPOPERATION NIL STREAM)) (OR TEXTURE (DSPTEXTURE NIL STREAM)) REGION]) (TWODGRAPHICS.DSPRESET [LAMBDA (VIEWPORT) (* ; "Edited 5-May-87 17:14 by jop") (* ;; "RESET a VIEWPORT") (LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT))) (DSPXPOSITION (DSPLEFTMARGIN NIL STREAM) STREAM) [DSPYPOSITION (DIFFERENCE (fetch (REGION TOP) of STREAMSUBREGION) (FONTPROP STREAM 'ASCENT] (TWODGRAPHICS.DSPFILL NIL NIL 'REPLACE VIEWPORT]) (TWODGRAPHICS.INIT [LAMBDA (W) (* jop%: "23-Feb-86 19:55") (COND ((NULL (WINDOWPROP W 'TWODPROPS?)) (WINDOWPROP W 'TWODPROPS? T) (WINDOWPROP W 'VIEWPORTS NIL) (WINDOWPROP W 'WINCLIPPINGREGION (DSPCLIPPINGREGION NIL W)) (WINDOWADDPROP W 'CLOSEFN (FUNCTION TWODGRAPHICS.CLOSEFN)) (WINDOWADDPROP W 'RESHAPEFN (FUNCTION TWODGRAPHICS.RESHAPEFN) T]) (TWODGRAPHICS.MOVETO [LAMBDA (X Y VIEWPORT) (* ; "Edited 5-May-87 17:16 by jop") (MOVETO (WORLDTOSTREAMX X VIEWPORT) (WORLDTOSTREAMY Y VIEWPORT) (fetch PARENTSTREAM of VIEWPORT]) (TWODGRAPHICS.MOVETOPT [LAMBDA (PT VIEWPORT) (* ; "Edited 5-May-87 17:16 by jop") (TWODGRAPHICS.MOVETO (fetch XCOORD of PT) (fetch YCOORD of PT) VIEWPORT]) (TWODGRAPHICS.PLOTAT [LAMBDA (PT GLYPH VIEWPORT OPERATION) (* ; "Edited 5-May-87 17:16 by jop") (PROG ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT))) (CLIPPED.PLOTAT STREAMSUBREGION (WORLDTOSTREAM PT VIEWPORT) GLYPH STREAM OPERATION]) (TWODGRAPHICS.RELDRAWTO [LAMBDA (DELTAX DELTAY WIDTH OPERATION VIEWPORT COLOR DASHING) (* ; "Edited 5-May-87 17:16 by jop") (LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (CLIPPINGREGION (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMDX (WORLDTOSTREAMXLENGTH DELTAX VIEWPORT)) (STREAMDY (WORLDTOSTREAMYLENGTH DELTAY VIEWPORT))) (CLIPPED.DRAWTO CLIPPINGREGION STREAMDX STREAMDY WIDTH OPERATION VIEWPORT COLOR DASHING]) (TWODGRAPHICS.RELDRAWTOPT [LAMBDA (DPT WIDTH OPERATION VIEWPORT COLOR DASHING) (* ; "Edited 5-May-87 17:16 by jop") (TWODGRAPHICS.RELDRAWTO (fetch XCOORD of DPT) (fetch YCOORD DPT) WIDTH OPERATION VIEWPORT COLOR DASHING]) (TWODGRAPHICS.RELMOVETO [LAMBDA (DX DY VIEWPORT) (* ; "Edited 5-May-87 17:17 by jop") (LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))) (RELMOVETO (WORLDTOSTREAMXLENGTH DX VIEWPORT) (WORLDTOSTREAMYLENGTH DY VIEWPORT) STREAM]) (TWODGRAPHICS.RELMOVETOPT [LAMBDA (DPT VIEWPORT) (* jop%: "23-Feb-86 19:29") (* *) (TWODGRAPHICS.RELMOVETO (fetch XCOORD of DPT) (fetch YCOORD of DPT) VIEWPORT]) (TWODGRAPHICS.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 5-May-87 17:17 by jop") (* ;; "updates all viewports associated with window") (PROG ((OLDCLIPPINGREGION (WINDOWPROP WINDOW 'WINCLIPPINGREGION)) (NEWCLIPPINGREGION (DSPCLIPPINGREGION NIL WINDOW)) WIDTHRATIO HEIGHTRATIO) (SETQ WIDTHRATIO (FQUOTIENT (fetch (REGION WIDTH) of NEWCLIPPINGREGION) (fetch (REGION WIDTH) of OLDCLIPPINGREGION))) (SETQ HEIGHTRATIO (FQUOTIENT (fetch (REGION HEIGHT) of NEWCLIPPINGREGION) (fetch (REGION HEIGHT) of OLDCLIPPINGREGION))) (bind REGION for V in (WINDOWPROP WINDOW 'VIEWPORTS) do (SETQ REGION (fetch (VIEWPORT STREAMSUBREGION) of V)) [replace (VIEWPORT STREAMSUBREGION) of V with (with REGION REGION (CREATEREGION (FIXR (FTIMES WIDTHRATIO LEFT)) (FIXR (FTIMES HEIGHTRATIO BOTTOM)) (FIXR (FTIMES WIDTHRATIO WIDTH)) (FIXR (FTIMES HEIGHTRATIO HEIGHT] (COMPUTETRANSFORM V)) (WINDOWPROP WINDOW 'WINCLIPPINGREGION NEWCLIPPINGREGION) (RETURN WINDOW]) (WORLDREGIONTOSTREAMREGION [LAMBDA (REGION VIEWPORT) (* ; "Edited 5-May-87 17:17 by jop") (CREATEREGION (WORLDTOSTREAMX (fetch (REGION LEFT) of REGION) VIEWPORT) (WORLDTOSTREAMY (fetch (REGION BOTTOM) of REGION) VIEWPORT) (WORLDTOSTREAMXLENGTH (fetch (REGION WIDTH) of REGION) VIEWPORT) (WORLDTOSTREAMYLENGTH (fetch (REGION HEIGHT) of REGION) VIEWPORT]) (WORLDTOSTREAM [LAMBDA (PT VIEWPORT OLDPT) (* ; "Edited 5-May-87 17:17 by jop") (COND (OLDPT (create POSITION XCOORD _ (WORLDTOSTREAMX (fetch (POSITION XCOORD) of PT) VIEWPORT) YCOORD _ (WORLDTOSTREAMY (fetch (POSITION YCOORD) of PT) VIEWPORT) smashing OLDPT)) (T (create POSITION XCOORD _ (WORLDTOSTREAMX (fetch (POSITION XCOORD) of PT) VIEWPORT) YCOORD _ (WORLDTOSTREAMY (fetch (POSITION YCOORD) of PT) VIEWPORT]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS STREAMTOWORLDX MACRO (OPENLAMBDA (X VIEWPORT) (PROG (RESULT) (DECLARE (TYPE FLOATP RESULT)) (RETURN (SETQ RESULT (FPLUS (fetch STREAMTOWORLDAX of VIEWPORT) (FTIMES (fetch STREAMTOWORLDMX of VIEWPORT) (FLOAT X] [PUTPROPS STREAMTOWORLDXLENGTH MACRO (OPENLAMBDA (DX VIEWPORT) (PROG (RESULT) (DECLARE (TYPE FLOATP RESULT)) (RETURN (SETQ RESULT (FTIMES (fetch STREAMTOWORLDMX of VIEWPORT) (FLOAT DX] [PUTPROPS STREAMTOWORLDY MACRO (OPENLAMBDA (Y VIEWPORT) (PROG (RESULT) (DECLARE (TYPE FLOATP RESULT)) (RETURN (SETQ RESULT (FPLUS (fetch STREAMTOWORLDAY of VIEWPORT) (FTIMES (fetch STREAMTOWORLDMY of VIEWPORT) (FLOAT Y] [PUTPROPS STREAMTOWORLDYLENGTH MACRO (OPENLAMBDA (DY VIEWPORT) (PROG (RESULT) (DECLARE (TYPE FLOATP RESULT)) (RETURN (SETQ RESULT (FTIMES (fetch STREAMTOWORLDMY of VIEWPORT) (FLOAT DY] [PUTPROPS WORLDTOSTREAMX MACRO (OPENLAMBDA (X VIEWPORT) (UFIX (FPLUS (fetch WORLDTOSTREAMAX of VIEWPORT) (FTIMES (fetch WORLDTOSTREAMMX of VIEWPORT) (FLOAT X] [PUTPROPS WORLDTOSTREAMXLENGTH MACRO (OPENLAMBDA (DX VIEWPORT) (UFIX (FTIMES (fetch WORLDTOSTREAMMX of VIEWPORT) (FLOAT DX] [PUTPROPS WORLDTOSTREAMY MACRO (OPENLAMBDA (Y VIEWPORT) (UFIX (FPLUS (fetch WORLDTOSTREAMAY of VIEWPORT) (FTIMES (fetch WORLDTOSTREAMMY of VIEWPORT) (FLOAT Y] [PUTPROPS WORLDTOSTREAMYLENGTH MACRO (OPENLAMBDA (DY VIEWPORT) (UFIX (FTIMES (fetch WORLDTOSTREAMMY of VIEWPORT) (FLOAT DY] ) (DECLARE%: EVAL@COMPILE (DATATYPE VIEWPORT (PARENTSTREAM STREAMSUBREGION WORLDREGION (WORLDTOSTREAMMX FLOATP) (WORLDTOSTREAMAX FLOATP) (WORLDTOSTREAMMY FLOATP) (WORLDTOSTREAMAY FLOATP) (STREAMTOWORLDMX FLOATP) (STREAMTOWORLDAX FLOATP) (STREAMTOWORLDMY FLOATP) (STREAMTOWORLDAY FLOATP))) ) (/DECLAREDATATYPE 'VIEWPORT '(POINTER POINTER POINTER FLOATP FLOATP FLOATP FLOATP FLOATP FLOATP FLOATP FLOATP) '((VIEWPORT 0 POINTER) (VIEWPORT 2 POINTER) (VIEWPORT 4 POINTER) (VIEWPORT 6 FLOATP) (VIEWPORT 8 FLOATP) (VIEWPORT 10 FLOATP) (VIEWPORT 12 FLOATP) (VIEWPORT 14 FLOATP) (VIEWPORT 16 FLOATP) (VIEWPORT 18 FLOATP) (VIEWPORT 20 FLOATP)) '22) (* ;; "Primitive clipping FNS") (DEFINEQ (CLIPCODE [LAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* ; "Edited 5-May-87 17:18 by jop") (* ;; "Cohen-Sutherland clip codes. Assumes integer args") (* ;; "RIGHT and TOP are one past the region.") (* ;; "RIGHT and TOP are one past the region.") (LET [(ABOVEBIT (COND ((GREATERP Y TOP) 8) (T 0))) (BELOWBIT (COND ((GREATERP BOTTOM Y) 4) (T 0))) (RIGHTBIT (COND ((GREATERP X RIGHT) 2) (T 0))) (LEFTBIT (COND ((GREATERP LEFT X) 1) (T 0] (LOGOR ABOVEBIT BELOWBIT RIGHTBIT LEFTBIT]) (CLIPPED.BITBLT [LAMBDA (CLIPPINGREGION SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE) (* ; "Edited 6-May-87 12:40 by jop") (* ; "Process defaults") (* ;; "It assumed that source must be a window or a bitmap -- and hence has scale 1") (if (EQ SOURCETYPE 'TEXTURE) then (CLIPPED.BLTSHADE CLIPPINGREGION TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION) else (COND ((NULL SOURCELEFT) (SETQ SOURCELEFT 0))) (COND ((NULL SOURCEBOTTOM) (SETQ SOURCEBOTTOM 0))) (COND ((NULL DESTINATIONLEFT) (SETQ DESTINATIONLEFT 0))) (COND ((NULL DESTINATIONBOTTOM) (SETQ DESTINATIONBOTTOM 0))) [COND ((NULL WIDTH) (SETQ WIDTH (COND ((WINDOWP SOURCEBITMAP) (WINDOWPROP SOURCEBITMAP 'WIDTH)) (T (BITMAPWIDTH SOURCEBITMAP] [COND ((NULL HEIGHT) (SETQ HEIGHT (COND ((WINDOWP SOURCEBITMAP) (WINDOWPROP SOURCEBITMAP 'HEIGHT)) (T (BITMAPHEIGHT SOURCEBITMAP] (LET* ((CLIP-LEFT (fetch (REGION LEFT) of CLIPPINGREGION)) (CLIP-BOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION)) (CLIP-WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION)) (CLIP-HEIGHT (fetch (REGION HEIGHT) of CLIPPINGREGION)) (SCALE (DSPSCALE NIL DESTINATION)) (NEW-LEFT DESTINATIONLEFT) (NEW-BOTTOM DESTINATIONBOTTOM) (NEW-WIDTH (TIMES SCALE WIDTH)) (NEW-HEIGHT (TIMES SCALE HEIGHT)) CLIPPED?) (COND ((GREATERP CLIP-LEFT NEW-LEFT) (SETQ CLIPPED? T) (SETQ NEW-WIDTH (DIFFERENCE NEW-WIDTH (DIFFERENCE CLIP-LEFT NEW-LEFT))) (SETQ NEW-LEFT CLIP-LEFT))) (COND ((GREATERP CLIP-BOTTOM NEW-BOTTOM) (SETQ CLIPPED? T) (SETQ NEW-HEIGHT (DIFFERENCE NEW-HEIGHT (DIFFERENCE CLIP-BOTTOM NEW-BOTTOM))) (SETQ NEW-BOTTOM CLIP-BOTTOM))) [COND ((GREATERP (PLUS NEW-LEFT NEW-WIDTH) (PLUS CLIP-LEFT CLIP-WIDTH)) (SETQ CLIPPED? T) (SETQ NEW-WIDTH (DIFFERENCE (PLUS CLIP-LEFT CLIP-WIDTH) NEW-LEFT] [COND ((GREATERP (PLUS NEW-BOTTOM NEW-HEIGHT) (PLUS CLIP-BOTTOM CLIP-HEIGHT)) (SETQ CLIPPED? T) (SETQ NEW-HEIGHT (DIFFERENCE (PLUS CLIP-BOTTOM CLIP-HEIGHT) NEW-BOTTOM] (COND ((NULL CLIPPED?) (* ; "No clipping") (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION)) ((OR (GEQ 0 NEW-WIDTH) (GEQ 0 NEW-HEIGHT)) (* ; "Gross clipping") NIL) (T (* ; "Adjusted bitblt") (BITBLT SOURCEBITMAP (PLUS SOURCELEFT (IQUOTIENT (DIFFERENCE NEW-LEFT DESTINATIONLEFT) SCALE)) (PLUS SOURCEBOTTOM (IQUOTIENT (DIFFERENCE NEW-BOTTOM DESTINATIONBOTTOM) SCALE)) DESTINATION NEW-LEFT NEW-BOTTOM (IQUOTIENT NEW-WIDTH SCALE) (IQUOTIENT NEW-HEIGHT SCALE) SOURCETYPE OPERATION]) (CLIPPED.BLTSHADE [LAMBDA (CLIPPINGREGION TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION) (* ; "Edited 6-May-87 12:14 by jop") (* ; "Process defaults") (COND ((NULL DESTINATIONLEFT) (SETQ DESTINATIONLEFT 0))) (COND ((NULL DESTINATIONBOTTOM) (SETQ DESTINATIONBOTTOM 0))) [COND ((NULL WIDTH) (SETQ WIDTH (COND ((WINDOWP DESTINATION) (WINDOWPROP DESTINATION 'WIDTH)) (T (BITMAPWIDTH DESTINATION] [COND ((NULL HEIGHT) (SETQ HEIGHT (COND ((WINDOWP DESTINATION) (WINDOWPROP DESTINATION 'HEIGHT)) (T (BITMAPHEIGHT DESTINATION] (LET ((CLIP-LEFT (fetch (REGION LEFT) of CLIPPINGREGION)) (CLIP-BOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION)) (CLIP-WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION)) (CLIP-HEIGHT (fetch (REGION HEIGHT) of CLIPPINGREGION)) (NEW-LEFT DESTINATIONLEFT) (NEW-BOTTOM DESTINATIONBOTTOM) (NEW-WIDTH WIDTH) (NEW-HEIGHT HEIGHT)) (COND ((GREATERP CLIP-LEFT NEW-LEFT) (SETQ NEW-WIDTH (DIFFERENCE NEW-WIDTH (DIFFERENCE CLIP-LEFT NEW-LEFT))) (SETQ NEW-LEFT CLIP-LEFT))) (COND ((GREATERP CLIP-BOTTOM NEW-BOTTOM) (SETQ NEW-HEIGHT (DIFFERENCE NEW-HEIGHT (DIFFERENCE CLIP-BOTTOM NEW-BOTTOM))) (SETQ NEW-BOTTOM CLIP-BOTTOM))) [COND ((GREATERP (PLUS NEW-LEFT NEW-WIDTH) (PLUS CLIP-LEFT CLIP-WIDTH)) (SETQ NEW-WIDTH (DIFFERENCE (PLUS CLIP-LEFT CLIP-WIDTH) NEW-LEFT] [COND ((GREATERP (PLUS NEW-BOTTOM NEW-HEIGHT) (PLUS CLIP-BOTTOM CLIP-HEIGHT)) (SETQ NEW-HEIGHT (DIFFERENCE (PLUS CLIP-BOTTOM CLIP-HEIGHT) NEW-BOTTOM] (COND ((OR (GEQ 0 NEW-WIDTH) (GEQ 0 NEW-HEIGHT)) (* ; "Gross clipping") NIL) (T (* ; "Adjusted bitblt") (BLTSHADE TEXTURE DESTINATION NEW-LEFT NEW-BOTTOM NEW-WIDTH NEW-HEIGHT OPERATION]) (CLIPPED.DRAWBETWEEN [LAMBDA (CLIPPINGREGION FIRSTPOSITION SECONDPOSITION WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 5-May-87 17:19 by jop") (CLIPPED.DRAWLINE CLIPPINGREGION (fetch (POSITION XCOORD) of FIRSTPOSITION) (fetch (POSITION YCOORD) of FIRSTPOSITION) (fetch (POSITION XCOORD) of SECONDPOSITION) (fetch (POSITION YCOORD) of SECONDPOSITION) WIDTH OPERATION STREAM COLOR DASHING]) (CLIPPED.DRAWLINE [LAMBDA (CLIPPINGREGION X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 5-May-87 17:19 by jop") (* ;; "Clip against CLIPPINGREGION and draw in STREAM. Implements Cohen-Sutherland clipping. From Foley and Van Dam, pg. 146") (PROG ((CLIPLEFT (fetch LEFT of CLIPPINGREGION)) (CLIPRIGHT (fetch RIGHT of CLIPPINGREGION)) (CLIPTOP (fetch TOP of CLIPPINGREGION)) (CLIPBOTTOM (fetch BOTTOM of CLIPPINGREGION)) (OLDX2 X2) (OLDY2 Y2) OUTCODE1 OUTCODE2 ACCEPT DONE) [repeatuntil DONE do (SETQ OUTCODE1 (CLIPCODE X1 Y1 CLIPLEFT CLIPRIGHT CLIPTOP CLIPBOTTOM)) (SETQ OUTCODE2 (CLIPCODE X2 Y2 CLIPLEFT CLIPRIGHT CLIPTOP CLIPBOTTOM)) (COND [(EQ 0 (LOGAND OUTCODE1 OUTCODE2)) (* ; "Possible accept") (COND ((SETQ ACCEPT (EQ 0 (LOGOR OUTCODE1 OUTCODE2))) (* ; "accept") (SETQ DONE T)) (T (* ; "Find intersections") [COND ((EQ 0 OUTCODE1) (* ;  "Swap points so (X1 . Y1) is guaranteed to be outside") (LET (TEMP) (SWAPARGS TEMP X1 X2) (SWAPARGS TEMP Y1 Y2) (SWAPARGS TEMP OUTCODE1 OUTCODE2] (COND ((NEQ 0 (LOGAND OUTCODE1 8)) (* ; "divide line at top") [SETQ X1 (PLUS X1 (QUOTIENT (TIMES (DIFFERENCE X2 X1) (DIFFERENCE CLIPTOP Y1)) (DIFFERENCE Y2 Y1] (SETQ Y1 CLIPTOP)) ((NEQ 0 (LOGAND OUTCODE1 4)) (* ; "divide line at bottom") [SETQ X1 (PLUS X1 (QUOTIENT (TIMES (DIFFERENCE X2 X1) (DIFFERENCE CLIPBOTTOM Y1)) (DIFFERENCE Y2 Y1] (SETQ Y1 CLIPBOTTOM)) ((NEQ 0 (LOGAND OUTCODE1 2)) (* ; "divide line at right") [SETQ Y1 (PLUS Y1 (QUOTIENT (TIMES (DIFFERENCE Y2 Y1) (DIFFERENCE CLIPRIGHT X1)) (DIFFERENCE X2 X1] (SETQ X1 CLIPRIGHT)) (T (* ; "divide line at left") [SETQ Y1 (PLUS Y1 (QUOTIENT (TIMES (DIFFERENCE Y2 Y1) (DIFFERENCE CLIPLEFT X1)) (DIFFERENCE X2 X1] (SETQ X1 CLIPLEFT] (T (* ; "Reject") (SETQ DONE T] (* ;  "actually draw a line if one accepted") (COND (ACCEPT (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING))) (* ;  "Correctly Update posistion in stream") (MOVETO OLDX2 OLDY2 STREAM]) (CLIPPED.DRAWTO [LAMBDA (CLIPPINGREGION X Y WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 5-May-87 17:19 by jop") (CLIPPED.DRAWLINE CLIPPINGREGION (DSPXPOSITION NIL STREAM) (DSPYPOSITION NIL STREAM) X Y WIDTH OPERATION STREAM COLOR DASHING]) (CLIPPED.PLOTAT [LAMBDA (CLIPPINGREGION PT GLYPH STREAM OPERATION) (* ; "Edited 5-May-87 17:19 by jop") (PROG ((WIDTHGLYPH (BITMAPWIDTH GLYPH)) (HEIGHTGLYPH (BITMAPHEIGHT GLYPH)) NEWX NEWY) [SETQ NEWX (DIFFERENCE (fetch XCOORD of PT) (TIMES (DSPSCALE NIL STREAM) (IQUOTIENT WIDTHGLYPH 2] [SETQ NEWY (DIFFERENCE (fetch YCOORD of PT) (TIMES (DSPSCALE NIL STREAM) (IQUOTIENT HEIGHTGLYPH 2] (CLIPPED.BITBLT CLIPPINGREGION GLYPH 0 0 STREAM NEWX NEWY WIDTHGLYPH HEIGHTGLYPH 'INPUT OPERATION]) (CLIPPED.PRIN1 [LAMBDA (CLIPPINGREGION EXPR STREAM) (* ; "Edited 5-May-87 17:19 by jop") (PROG ((STRINGREGION (STRINGREGION EXPR STREAM)) IREGION) (COND ((SUBREGIONP CLIPPINGREGION STRINGREGION) (* ; "No clipping") (PRIN1 EXPR STREAM)) (T (SETQ IREGION (INTERSECTREGIONS STRINGREGION CLIPPINGREGION)) (COND ((AND IREGION (IEQP (fetch (REGION HEIGHT) of IREGION) (fetch (REGION HEIGHT) of STRINGREGION))) (* ; "Some chars visible") (bind (MINX _ (fetch (REGION LEFT) of CLIPPINGREGION)) (MAXX _ (fetch (REGION RIGHT) of CLIPPINGREGION)) (X _ (DSPXPOSITION NIL STREAM)) (Y _ (DSPYPOSITION NIL STREAM)) NEXTX CHARWIDTH for I from 1 to (NCHARS EXPR) do (SETQ CHARWIDTH (CHARWIDTH (NTHCHARCODE EXPR I) STREAM)) (SETQ NEXTX (IPLUS X CHARWIDTH)) (COND ((NOT (OR (ILESSP X MINX) (IGREATERP NEXTX MAXX))) (PRIN1 (NTHCHAR EXPR I) STREAM)) (T (MOVETO NEXTX Y STREAM))) (SETQ X NEXTX]) (CLIPPED.RELDRAWTO [LAMBDA (CLIPPINGREGION DX DY WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 5-May-87 17:19 by jop") (PROG ((X (DSPXPOSITION NIL STREAM)) (Y (DSPYPOSITION NIL STREAM))) (CLIPPED.DRAWLINE CLIPPINGREGION X Y (PLUS X DX) (PLUS Y DY) WIDTH OPERATION STREAM COLOR DASHING]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS SWAPARGS MACRO ((TEMP FIRST SECOND) (SETQ TEMP FIRST) (SETQ FIRST SECOND) (SETQ SECOND TEMP))) ) (* ;; "For unboxed floating point games") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILESLOAD UNBOXEDOPS) ) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TWODGRAPHICS COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2764 25881 (CREATEVIEWPORT 2774 . 4956) (COMPUTETRANSFORM 4958 . 8232) ( COMPUTEWORLDREGION 8234 . 9528) (SETSTREAMSUBREGION 9530 . 10185) (SETWORLDREGION 10187 . 10599) ( STREAMREGIONTOWORLDREGION 10601 . 11151) (STREAMTOWORLD 11153 . 11953) (TWODGRAPHICS.BITBLT 11955 . 16228) (TWODGRAPHICS.CLOSEFN 16230 . 16658) (TWODGRAPHICS.DRAWBETWEEN 16660 . 17022) ( TWODGRAPHICS.DRAWLINE 17024 . 17710) (TWODGRAPHICS.DRAWTO 17712 . 18193) (TWODGRAPHICS.DRAWTOPT 18195 . 18479) (TWODGRAPHICS.DSPFILL 18481 . 19053) (TWODGRAPHICS.DSPRESET 19055 . 19671) ( TWODGRAPHICS.INIT 19673 . 20143) (TWODGRAPHICS.MOVETO 20145 . 20409) (TWODGRAPHICS.MOVETOPT 20411 . 20665) (TWODGRAPHICS.PLOTAT 20667 . 21076) (TWODGRAPHICS.RELDRAWTO 21078 . 21652) ( TWODGRAPHICS.RELDRAWTOPT 21654 . 21939) (TWODGRAPHICS.RELMOVETO 21941 . 22279) ( TWODGRAPHICS.RELMOVETOPT 22281 . 22564) (TWODGRAPHICS.RESHAPEFN 22566 . 24585) ( WORLDREGIONTOSTREAMREGION 24587 . 25137) (WORLDTOSTREAM 25139 . 25879)) (30894 46502 (CLIPCODE 30904 . 31809) (CLIPPED.BITBLT 31811 . 36318) (CLIPPED.BLTSHADE 36320 . 38843) (CLIPPED.DRAWBETWEEN 38845 . 39400) (CLIPPED.DRAWLINE 39402 . 43362) (CLIPPED.DRAWTO 43364 . 43717) (CLIPPED.PLOTAT 43719 . 44448) (CLIPPED.PRIN1 44450 . 46067) (CLIPPED.RELDRAWTO 46069 . 46500))))) STOP \ No newline at end of file diff --git a/lispusers/TWODGRAPHICS.TEDIT b/lispusers/TWODGRAPHICS.TEDIT new file mode 100644 index 00000000..26ec7688 Binary files /dev/null and b/lispusers/TWODGRAPHICS.TEDIT differ diff --git a/lispusers/Tek4010CHAT.TEdit b/lispusers/Tek4010CHAT.TEdit new file mode 100644 index 00000000..5a476c25 Binary files /dev/null and b/lispusers/Tek4010CHAT.TEdit differ diff --git a/lispusers/UNBOXEDOPS b/lispusers/UNBOXEDOPS new file mode 100644 index 00000000..0a1897ec --- /dev/null +++ b/lispusers/UNBOXEDOPS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED " 7-Dec-86 17:26:23" {ERIS}LISPCORE>UNBOXEDOPS.;7 12906 changes to%: (OPTIMIZERS UFREMAINDER2 UFREMAINDER) (FNS UFREMAINDER) (VARS UNBOXEDOPSCOMS) previous date%: " 3-Nov-86 20:30:24" {ERIS}LISPCORE>UNBOXEDOPS.;6) (* " Copyright (c) 1986 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNBOXEDOPSCOMS) (RPAQQ UNBOXEDOPSCOMS [(FNS UFABS UFEQP UFGEQ UFGREATERP UFIX UFLEQ UFLESSP UFMAX UFMIN UFMINUS UFREMAINDER) (OPTIMIZERS UFABS UFABS1 UFEQP UFEQP2 UFGEQ UFGEQ2 UFGREATERP UFGREATERP2 UFIX UFIX1 UFLEQ UFLEQ2 UFLESSP UFLESSP2 UFMAX UFMAX2 UFMIN UFMIN2 UFMINUS UFMINUS1 UFREMAINDER) (PROP FILETYPE UNBOXEDOPS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA UFMIN UFMAX]) (DEFINEQ (UFABS [LAMBDA (X) (* jop%: "30-Jan-86 15:10") (FABS X]) (UFEQP [LAMBDA (X Y) (* jop%: "31-Jan-86 12:35") (FEQP X Y]) (UFGEQ [LAMBDA (X Y) (* jop%: " 2-Feb-86 12:36") (GEQ X Y]) (UFGREATERP [LAMBDA (X Y) (* jop%: "30-Jan-86 15:11") (FGREATERP X Y]) (UFIX [LAMBDA (X) (* jop%: "30-Jan-86 15:11") (FIX X]) (UFLEQ [LAMBDA (X Y) (* jop%: " 2-Feb-86 12:37") (LEQ X Y]) (UFLESSP [LAMBDA (X Y) (* jop%: "31-Jan-86 12:20") (FLESSP X Y]) (UFMAX [LAMBDA ARGS (* jop%: "30-Jan-86 15:12") (bind (MAX _ MIN.FLOAT) for I from 1 to ARGS do (if (FGREATERP (ARG ARGS I) MAX) then (SETQ MAX (ARG ARGS I))) finally (RETURN MAX]) (UFMIN [LAMBDA ARGS (* jop%: "30-Jan-86 15:13") (bind (MIN _ MAX.FLOAT) for I from 1 to ARGS do (if (FLESSP (ARG ARGS I) MIN) then (SETQ MIN (ARG ARGS I))) finally (RETURN MIN]) (UFMINUS [LAMBDA (X) (* jop%: "30-Jan-86 15:14") (FMINUS X]) (UFREMAINDER [LAMBDA (X Y) (* ; "Edited 7-Dec-86 17:21 by jop:") (LET ((FX (FLOAT X)) (FY (FLOAT Y)) RESULT) (DECLARE (TYPE FLOATP FX FY RESULT)) (SETQ RESULT (FDIFFERENCE FX (FTIMES (FLOAT (UFIX (FQUOTIENT FX FY))) FY]) ) (DEFOPTIMIZER UFABS (&OPTIONAL (ARG1 NIL ARG1GIVEN) &REST RESTARGS &WHOLE ORIGINAL) (if (OR (NOT ARG1GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFABS" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFABS1 ARG1)) (DEFOPTIMIZER UFABS1 (X) `[\FLOATBOX ((OPCODES UBFLOAT1 2) (\FLOATUNBOX ,X]) (DEFOPTIMIZER UFEQP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) (NOT ARG2GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFEQP" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFEQP2 ARG1 ARG2)) (DEFOPTIMIZER UFEQP2 (X Y) `(EQ (\FLOATUNBOX (FDIFFERENCE ,X ,Y)) NIL)) (DEFOPTIMIZER UFGEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) (NOT ARG2GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFGEQ" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFGEQ2 ARG1 ARG2)) (DEFOPTIMIZER UFGEQ2 (X Y) `[NOT ((OPCODES SWAP UBFLOAT2 5) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y]) (DEFOPTIMIZER UFGREATERP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) (NOT ARG2GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFGREATERP" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFGREATERP2 ARG1 ARG2)) (DEFOPTIMIZER UFGREATERP2 (X Y) `((OPCODES UBFLOAT2 5) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y))) (DEFOPTIMIZER UFIX (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFIX" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFIX1 ARG1)) (DEFOPTIMIZER UFIX1 (X) `((OPCODES UBFLOAT1 4) (\FLOATUNBOX ,X))) (DEFOPTIMIZER UFLEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) (NOT ARG2GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFLEQ" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFLEQ2 ARG1 ARG2)) (DEFOPTIMIZER UFLEQ2 (X Y) `[NOT ((OPCODES UBFLOAT2 5) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y]) (DEFOPTIMIZER UFLESSP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) (NOT ARG2GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFLESSP" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFLESSP2 ARG1 ARG2)) (DEFOPTIMIZER UFLESSP2 (X Y) `((OPCODES SWAP UBFLOAT2 5) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y))) (DEFOPTIMIZER UFMAX (&OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (NOT ARG1GIVEN) then 'MIN.FLOAT elseif (NOT ARG2GIVEN) then `(FLOAT %, ARG1) elseif RESTARGS then `(UFMAX (UFMAX2 %, ARG1 %, ARG2) ., RESTARGS) else (LIST 'UFMAX2 ARG1 ARG2))) (DEFOPTIMIZER UFMAX2 (X Y) `[\FLOATBOX ((OPCODES UBFLOAT2 6) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y]) (DEFOPTIMIZER UFMIN (&OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (if (NOT ARG1GIVEN) then 'MAX.FLOAT elseif (NOT ARG2GIVEN) then `(FLOAT %, ARG1) elseif RESTARGS then `(UFMIN (UFMIN2 %, ARG1 %, ARG2) ., RESTARGS) else (LIST 'UFMIN2 ARG1 ARG2))) (DEFOPTIMIZER UFMIN2 (X Y) `[\FLOATBOX ((OPCODES UBFLOAT2 7) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y]) (DEFOPTIMIZER UFMINUS (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) &REST RESTARGS) (if (OR (NOT ARG1GIVEN) RESTARGS) then (PRINTOUT T "************" T) (PRINTOUT T "Illegal args to UFMINUS" %, %, ORIGINAL T) (PRINTOUT T "************" T)) (LIST 'UFMINUS1 ARG1)) (DEFOPTIMIZER UFMINUS1 (X) `[\FLOATBOX ((OPCODES UBFLOAT1 3) (\FLOATUNBOX ,X]) (DEFOPTIMIZER UFREMAINDER (X Y) (CL:IF (AND (OR (CL:CONSTANTP X) (CL:SYMBOLP X)) (OR (CL:CONSTANTP Y) (CL:SYMBOLP Y))) `(FDIFFERENCE ,X (FTIMES [FLOAT (UFIX (FQUOTIENT ,X ,Y] ,Y)) 'COMPILER:PASS)) (PUTPROPS UNBOXEDOPS FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA UFMIN UFMAX) ) (PUTPROPS UNBOXEDOPS COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1185 3385 (UFABS 1195 . 1316) (UFEQP 1318 . 1441) (UFGEQ 1443 . 1565) (UFGREATERP 1567 . 1700) (UFIX 1702 . 1821) (UFLEQ 1823 . 1945) (UFLESSP 1947 . 2074) (UFMAX 2076 . 2478) (UFMIN 2480 . 2879) (UFMINUS 2881 . 3006) (UFREMAINDER 3008 . 3383))))) STOP \ No newline at end of file diff --git a/lispusers/UNBOXEDOPS.TEDIT b/lispusers/UNBOXEDOPS.TEDIT new file mode 100644 index 00000000..a7cd46d0 Binary files /dev/null and b/lispusers/UNBOXEDOPS.TEDIT differ diff --git a/lispusers/UNDIGESTIFY b/lispusers/UNDIGESTIFY new file mode 100644 index 00000000..e4c81daa --- /dev/null +++ b/lispusers/UNDIGESTIFY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Jul-87 08:47:18" {PHYLUM}LYRIC>UNDIGESTIFY.;2 16839 changes to%: (FNS INSTALL-UNDIGESTIFY) previous date%: "16-May-86 10:55:33" {PHYLUM}LYRIC>UNDIGESTIFY.;1) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNDIGESTIFYCOMS) (RPAQQ UNDIGESTIFYCOMS ((INITVARS *DELETE-DIGEST-FLAG* *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* *DONT-UPDATE-HEADERS-FLAG* SEPARATOR1 SEPARATOR2) (FNS INSTALL-UNDIGESTIFY LAFITE-DISPLAY LAFITE-TRUNCATE-FILE LAFITE-UNDIGESTIFY MOVE-TO-EOL OPEN-SPACE-IN-FILE PARSE-AND-MAYBE-MERGE-HEADER SKIP-EOLS BACKUP-PTR TEDIT.FIND.NOT.CASELESS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES {ERIS}SOURCES>LAFITEDECLS)) (P (INSTALL-UNDIGESTIFY)))) (RPAQ? *DELETE-DIGEST-FLAG* NIL) (RPAQ? *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL) (RPAQ? *DONT-UPDATE-HEADERS-FLAG* NIL) (RPAQ? SEPARATOR1 NIL) (RPAQ? SEPARATOR2 NIL) (DEFINEQ (INSTALL-UNDIGESTIFY [LAMBDA NIL (* ; "Edited 29-Jul-87 08:44 by Rao") (* ;  "Put 'Undigest' on the browser menu after Display, if it isn't already there.") (if (NOT (SASSOC "Undigest" LAFITEBROWSERMENUITEMS)) then (* ;  "Copy the list because the menus will share its structure.") (SETQ LAFITEBROWSERMENUITEMS (COPY LAFITEBROWSERMENUITEMS)) (for ITEMS on LAFITEBROWSERMENUITEMS when (EQUAL "Forward" (CAAR ITEMS)) do (RPLACD ITEMS (CONS '("Undigest" 'LAFITE-UNDIGESTIFY "Unpacks network digest into separate messages.") (CDR ITEMS))) (RETURN T))) (* ;; "Update the width of the browser. Use the larger of the previous width and the minimum possible width, it case they like wide browsers.") [AND (REGIONP LAFITEBROWSERREGION) (replace (REGION WIDTH) of LAFITEBROWSERREGION with (IMAX (fetch (REGION WIDTH) of LAFITEBROWSERREGION) (fetch (REGION WIDTH) of (WINDOWPROP (MENUWINDOW (create MENU ITEMS _ LAFITEBROWSERMENUITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT)) 'REGION] (SETQ *DELETE-DIGEST-FLAG* T) (SETQ *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* NIL) (SETQ *DONT-UPDATE-HEADERS-FLAG* NIL) (SETQ SEPARATOR1 '"-----------------------------------------------------------------") (SETQ SEPARATOR2 '"--------"]) (LAFITE-DISPLAY [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB%: "26-Mar-86 10:44") (COND ((EQ KEY 'LEFT) (\LAFITE.DISPLAY WINDOW MAILFOLDER ITEM MENU KEY)) ((EQ KEY 'MIDDLE) (LAFITE-UNDIGESTIFY WINDOW MAILFOLDER ITEM MENU KEY]) (LAFITE-TRUNCATE-FILE [LAMBDA (FILE LENGTH) (* SCB%: "30-Apr-86 14:24") (* Truncate the folder. FILE is the filename, not a stream.  Returns T if we did the truncation.) (CLOSEF? FILE) (if (NEQ (GETFILEINFO FILE 'LENGTH) LENGTH) then (SETFILEINFO FILE 'LENGTH LENGTH) T]) (LAFITE-UNDIGESTIFY [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* SCB%: "30-Apr-86 14:51") (RESETLST (LA.RESETSHADE ITEM MENU) (PROG (REPORTWINDOW MSG1 MSGN MESSAGES DIGEST-MSG-DESC MESSAGE-STREAM MESSAGE-POSITIONS DIGEST-HEADER-PARSE DIGEST-TO) (SETQ REPORTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) (SETQ MSG1 (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) (SETQ MSGN (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (CLEARW REPORTWINDOW) (if (NOT (AND (NUMBERP MSG1) (NUMBERP MSGN) (IEQP MSG1 MSGN))) then (PRINTOUT REPORTWINDOW "Must select a single message.") else (PRINTOUT REPORTWINDOW "Parsing digest... ") (WITH.MONITOR (fetch FOLDERLOCK of MAILFOLDER) (SETQ DIGEST-MSG-DESC (NTHMESSAGE (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSG1)) (LA.COPY.MESSAGE.TEXT MAILFOLDER (SETQ MESSAGE-STREAM (OPENTEXTSTREAM)) DIGEST-MSG-DESC) (SETQ DIGEST-HEADER-PARSE (LAFITE.PARSE.HEADER MESSAGE-STREAM \LAPARSE.FULL 0 -1 NIL T) ) (SETQ DIGEST-TO (CADR (ASSOC 'To DIGEST-HEADER-PARSE))) (* Parse the digest, looking for the separators between each submessage.) (PROG (TEXTOBJ MSGS L1 L2 P1 P2 P3) (SETQ TEXTOBJ (TEXTOBJ MESSAGE-STREAM)) (SETQ MSGS NIL) (SETQ L1 (NCHARS SEPARATOR1)) (SETQ L2 (NCHARS SEPARATOR2)) (SETQ P1 (TEDIT.FIND.NOT.CASELESS TEXTOBJ SEPARATOR1 1)) (if (NULL P1) then (PRINTOUT REPORTWINDOW "Can't find first separator.") (GO ERROR)) [SETQ P1 (SKIP-EOLS MESSAGE-STREAM (MOVE-TO-EOL MESSAGE-STREAM (IPLUS P1 L1] (if (EQ 'ERROR (PARSE-AND-MAYBE-MERGE-HEADER MESSAGE-STREAM P1 (IPLUS P1 1000) DIGEST-TO)) then (PRINTOUT REPORTWINDOW "Can't parse header of digest message #1") (GO ERROR)) (SETQ P2 P1) (* P1 points to the beginning of the message.  P2 points to the separator that might end the message.  P3 points to the beginning of the next message's header.) (until (NULL (SETQ P2 (TEDIT.FIND.NOT.CASELESS TEXTOBJ SEPARATOR2 P2))) do [SETQ P3 (SKIP-EOLS MESSAGE-STREAM (MOVE-TO-EOL MESSAGE-STREAM (IPLUS P2 L2] (if (EQ 'ERROR (PARSE-AND-MAYBE-MERGE-HEADER MESSAGE-STREAM P3 (IPLUS P3 1000) DIGEST-TO)) then (SETQ P2 P3) (* Keep looking for end of message.) else (* Message ends at char just before P2 because of TEDIT.FIND.NOT.CASELESS) (push MSGS (LIST P1 (SUB1 P2))) (SETQ P1 P3) (SETQ P2 P3))) (* We're allowed to throw away up to 50 characters at the end of the message.) [if (IGEQ (IDIFFERENCE (GETEOFPTR MESSAGE-STREAM) P1) 50) then (push MSGS (LIST P1 (GETEOFPTR MESSAGE-STREAM] (SETQ MESSAGE-POSITIONS (DREVERSE MSGS)) (RETURN) ERROR (SETQ MESSAGE-POSITIONS 'ERROR) (RETURN)) (if (EQ 'ERROR MESSAGE-POSITIONS) then (PRINTOUT REPORTWINDOW " Aborted.") else (PROG (OUTSTREAM BEGIN MSG-DESC MSG-START MSG-END NEW-MESSAGE-DESCRIPTORS) (SETQ OUTSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'OUTPUT)) (* Protect against the user typing an interrupt char while we're writing to the  mailfolder.) [RESETSAVE NIL `(AND RESETSTATE (LAFITE-TRUNCATE-FILE ',(fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of MAILFOLDER) ',(fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER] (SETFILEPTR OUTSTREAM -1) [COND ((NOT (IEQP (SETQ BEGIN (GETFILEPTR OUTSTREAM)) (fetch FOLDEREOFPTR of MAILFOLDER))) (RETURN (HELP "Folder inconsistent with browser"] (SETQ NEW-MESSAGE-DESCRIPTORS NIL) (for MSG-POS in MESSAGE-POSITIONS do (SETQ MSG-START (CAR MSG-POS)) (SETQ MSG-END (CADR MSG-POS)) [SETQ MSG-DESC (create LAFITEMSG BEGIN _ BEGIN SEEN? _ NIL MARKCHAR _ UNSEENMARK STAMPLENGTH _ LAFITESTAMPLENGTH MESSAGELENGTH _ (SETQ LEN (IPLUS LAFITESTAMPLENGTH (IDIFFERENCE MSG-END MSG-START] (push NEW-MESSAGE-DESCRIPTORS MSG-DESC) (SETQ BEGIN (IPLUS BEGIN LEN)) (LA.PRINTSTAMP OUTSTREAM) (LA.PRINTCOUNT LEN OUTSTREAM) (LA.PRINTCOUNT LAFITESTAMPLENGTH OUTSTREAM) (BOUT OUTSTREAM UNDELETEDFLAG) (BOUT OUTSTREAM SEENFLAG) (BOUT OUTSTREAM SEENMARK) (BOUT OUTSTREAM (CHARCODE CR)) (COPYBYTES MESSAGE-STREAM OUTSTREAM MSG-START MSG-END)) (LAB.APPENDMESSAGES MAILFOLDER (SETQ NEW-MESSAGE-DESCRIPTORS (DREVERSE NEW-MESSAGE-DESCRIPTORS ))) (SEENMESSAGE DIGEST-MSG-DESC MAILFOLDER) (if *DELETE-DIGEST-FLAG* then (DELETEMESSAGE DIGEST-MSG-DESC MAILFOLDER)) [if *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* then (UNSELECTALLMESSAGES MAILFOLDER) (SELECTMESSAGE (CAR NEW-MESSAGE-DESCRIPTORS) MAILFOLDER) (LAB.EXPOSEMESSAGE MAILFOLDER (CAR NEW-MESSAGE-DESCRIPTORS)) else (* Treat digest message as if it had been displayed, and move to next undeleted  message.) (for N from (ADD1 MSG1) to (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) do (if [NOT (fetch (LAFITEMSG DELETED?) of (SETQ MSG-DESC (NTHMESSAGE MESSAGES N] then (LA.SHOW.SELECTION MAILFOLDER DIGEST-MSG-DESC 'ERASE) (LA.SHOW.SELECTION MAILFOLDER MSG-DESC 'REPLACE) (replace (LAFITEMSG SELECTED?) of DIGEST-MSG-DESC with NIL) (replace (LAFITEMSG SELECTED?) of MSG-DESC with T) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with N) (replace LASTSELECTEDMESSAGE of MAILFOLDER with N) (RETURN] (PRINTOUT REPORTWINDOW " done. "]) (MOVE-TO-EOL [LAMBDA (TEXTSTREAM POSITION) (* SCB%: "27-Mar-86 10:34") (* POSITION points into a line. Return the position immediately following the  CR at the end of this line, i.e., the first char on the next line.) (AND POSITION (SETFILEPTR TEXTSTREAM POSITION)) (until (IEQP (CHARCODE CR) (\BIN TEXTSTREAM)) do) (GETFILEPTR TEXTSTREAM]) (OPEN-SPACE-IN-FILE [LAMBDA (FILE POSITION NCHARS) (* SCB%: "25-Mar-86 12:52") (* Open a space in file starting at POSITION for length NCHARS by sliding the  rest of the file down.) (LET [(TEMP (OPENFILE '{NODIRCORE} 'BOTH] (COPYBYTES FILE TEMP POSITION (GETEOFPTR FILE)) (SETFILEPTR FILE (IPLUS POSITION NCHARS)) (SETFILEPTR TEMP 0) (COPYBYTES TEMP FILE) (CLOSEF? TEMP]) (PARSE-AND-MAYBE-MERGE-HEADER [LAMBDA (MESSAGE-STREAM P1 P2 DIGEST-TO) (* SCB%: "14-Apr-86 12:31") (PROG (MSG-HEADER-PARSE END-OF-HEADER STRING CR) (SETQ MSG-HEADER-PARSE (LAFITE.PARSE.HEADER MESSAGE-STREAM \LAPARSE.FULL P1 P2 NIL T)) (if (NULL (CDR MSG-HEADER-PARSE)) then (* Nothing in the header, probably not  a legal message.) (RETURN 'ERROR)) (if *DONT-UPDATE-HEADERS-FLAG* then (RETURN P2)) (SETQ END-OF-HEADER (CADR (ASSOC 'EOF MSG-HEADER-PARSE))) (if (NULL (ASSOC 'To MSG-HEADER-PARSE)) then (TEDIT.INSERT MESSAGE-STREAM (SETQ STRING (CONCAT (SETQ CR (CHARACTER (CHARCODE CR))) "To: " DIGEST-TO CR)) END-OF-HEADER) (add END-OF-HEADER (NCHARS STRING)) (add P2 (NCHARS STRING))) (RETURN P2]) (SKIP-EOLS [LAMBDA (TEXTSTREAM POSITION) (* SCB%: "27-Mar-86 10:35") (AND POSITION (SETFILEPTR TEXTSTREAM POSITION)) (until (NOT (IEQP (CHARCODE CR) (\BIN TEXTSTREAM))) do) (SETFILEPTR TEXTSTREAM (SUB1 (GETFILEPTR TEXTSTREAM]) (BACKUP-PTR [LAMBDA (STREAM) (* SCB%: "27-Mar-86 10:20") (SETFILEPTR STREAM (SUB1 (GETFILEPTR STREAM]) (TEDIT.FIND.NOT.CASELESS [LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* SCB%: " 9-Apr-86 13:53") (* This function exists because you might be using Shrager's caseless search in  TEdit.) (LET ((TEDIT%:*CASE-FOLD-SEARCH-P* NIL)) (TEDIT.FIND TEXTOBJ TARGETSTRING START# END# WILDCARDS?]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD {ERIS}SOURCES>LAFITEDECLS) ) (INSTALL-UNDIGESTIFY) (PUTPROPS UNDIGESTIFY COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1217 16647 (INSTALL-UNDIGESTIFY 1227 . 3240) (LAFITE-DISPLAY 3242 . 3541) ( LAFITE-TRUNCATE-FILE 3543 . 3954) (LAFITE-UNDIGESTIFY 3956 . 13612) (MOVE-TO-EOL 13614 . 14074) ( OPEN-SPACE-IN-FILE 14076 . 14578) (PARSE-AND-MAYBE-MERGE-HEADER 14580 . 15800) (SKIP-EOLS 15802 . 16113) (BACKUP-PTR 16115 . 16277) (TEDIT.FIND.NOT.CASELESS 16279 . 16645))))) STOP \ No newline at end of file diff --git a/lispusers/UNDIGESTIFY.TEDIT b/lispusers/UNDIGESTIFY.TEDIT new file mode 100644 index 00000000..283b5277 Binary files /dev/null and b/lispusers/UNDIGESTIFY.TEDIT differ diff --git a/lispusers/UNIFIER b/lispusers/UNIFIER new file mode 100644 index 00000000..db8a09d1 --- /dev/null +++ b/lispusers/UNIFIER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "USER" BASE 10) (IL:FILECREATED " 1-Aug-88 11:37:03" IL:{DSK}LOGIC>MEDLEY>UNIFIER.;1 7425 IL:previous IL:date%: "13-Jul-88 15:26:58" IL:{DSK}LOGIC>UNIFIER.;1) (IL:* " Copyright (c) 1987, 1988 by Roberto Ghislanzoni. All rights reserved. ") (IL:PRETTYCOMPRINT IL:UNIFIERCOMS) (IL:RPAQQ IL:UNIFIERCOMS ((IL:FUNCTIONS BINDING BUILD-NEW-ENV CREATE-NEW-VARIABLE CREATE-VARIABLES FIND-IF-MEMBER FIND-VALUES FIND-VARIABLE-VALUE LOOKUP NULLP RENAME RENAME-VARS UNIFY VARIABLEP))) (DEFUN BINDING (PREDICATE THEORY-NAME &OPTIONAL WINDOW) [COND [(EQ THEORY-NAME '*BACKGROUND-THEORY*) (COND [(EQ (CHAR-CODE (CHAR (SYMBOL-NAME PREDICATE) 0)) 33) (IL:* IL:;; "CUT is handled in a very particular way!! ") (GETHASH '! (GET 'THEORY '*BACKGROUND-THEORY*] (T (GETHASH PREDICATE (GET 'THEORY '*BACKGROUND-THEORY*] (T (GETHASH PREDICATE (GET-THEORY THEORY-NAME WINDOW]) (DEFUN BUILD-NEW-ENV (PAT DAT ENV) (IL:* IL:;; " It is better to make a distinction between the null value of a variable and the variables unbound") (COND ((NULL DAT) (ACONS PAT '*NULL* ENV)) (T (ACONS PAT DAT ENV)))) (DEFUN CREATE-NEW-VARIABLE () [PROGN (SETF *VARIABLES-COUNTER* (+ 1 *VARIABLES-COUNTER*)) (OR (GETHASH *VARIABLES-COUNTER* *VARIABLES-TABLE*) (SETF (GETHASH *VARIABLES-COUNTER* *VARIABLES-TABLE*) (MAKE-SYMBOL (FORMAT NIL "?~A" *VARIABLES-COUNTER*]) (DEFUN CREATE-VARIABLES () (DEFVAR *VARIABLES-TABLE* (MAKE-HASH-TABLE)) (IL:* IL:;; "all the variables used are cached in a hash-table: this is also for not generating a lot of symbols that will fill up the symbol table of the system ") (IL:* IL:;; "This function must be called before starting to work with Logic") (DO ((X 0 (+ X 1))) ((= X 4095) T) (SETF (GETHASH X *VARIABLES-TABLE*) (MAKE-SYMBOL (FORMAT NIL "?~A" X))))) (DEFUN FIND-IF-MEMBER (ELT LST) (COND ((NULL LST) NIL) [(LISTP LST) (OR (FIND-IF-MEMBER ELT (CAR LST)) (FIND-IF-MEMBER ELT (CDR LST] ((ATOM LST) (EQ LST ELT)) (T (MEMBER ELT LST)))) (DEFUN FIND-VALUES (ELT ENV) (COND ((NULL ELT) NIL) ((LISTP ELT) (CONS (FIND-VALUES (CAR ELT) ENV) (FIND-VALUES (CDR ELT) ENV))) ((VARIABLEP ELT) (FIND-VARIABLE-VALUE ELT ENV)) (T ELT))) (DEFUN FIND-VARIABLE-VALUE (VAR ENV) [LET [(VAL (CDR (ASSOC VAR ENV] (COND ((VARIABLEP VAL) (FIND-VARIABLE-VALUE VAL ENV)) ((NULL VAL) (IL:* IL:;; "The variable is unbound, so the variable itself is returned") VAR) ((NULLP VAL) (IL:* IL:;; "NULLP checks is the value is *NULL*") NIL) (T (IL:* IL:;; "This is the statement for a partial occur check") (OR (AND (NOT (FIND-IF-MEMBER VAR VAL)) (FIND-VALUES VAL ENV)) VAL]) (DEFUN LOOKUP (EXPR ENV) [COND ((NUMBERP EXPR) EXPR) ((SYMBOLP EXPR) (FIND-VALUES EXPR ENV)) (T (CONS (FIND-VALUES (CAR EXPR) ENV) (FIND-VALUES (CDR EXPR) ENV]) (DEFMACRO NULLP (ATOM) `(EQ ,ATOM '*NULL*)) (DEFUN RENAME (EXPR) (LET ((VARSTABLE (MAKE-HASH-TABLE))) (DECLARE (SPECIAL VARSTABLE)) (RENAME-VARS EXPR))) (DEFUN RENAME-VARS (EXPR) (COND ((NULL EXPR) NIL) [(LISTP EXPR) (CONS (RENAME-VARS (CAR EXPR)) (RENAME-VARS (CDR EXPR] [(VARIABLEP EXPR) (LET ((ALREADY-RENAMED (GETHASH EXPR VARSTABLE))) (COND (ALREADY-RENAMED ALREADY-RENAMED) (T (LET ((NEW (CREATE-NEW-VARIABLE))) (SETF (GETHASH EXPR VARSTABLE) NEW) NEW] (T EXPR))) (DEFUN UNIFY (PATT DAT ENV &OPTIONAL WINDOW) (IL:* IL:;; "This is a very fast implementation of unifier: no stack frames are generated. The tecnique used here is that of save-rest argument: the unifier is not a true-recursive procedure, in the sense that it does not require a full stack for its implementation: in fact, when failure occurs, the value FAILED must be immediately returned ") [PROG ([DEBUGFLG (AND WINDOW (TRACINGP WINDOW 'UNIFY] (REST-PAT) (REST-DAT) TEMP) HERE (AND DEBUGFLG (UNIFY-DEBUGGER PATT DAT ENV WINDOW)) (IL:* IL:; "debugging stuff") [COND [(AND (NULL PATT) (NULL DAT)) (COND ((AND (NULL REST-DAT) REST-PAT) (RETURN 'FAILED)) ((AND (NULL REST-PAT) REST-DAT) (RETURN 'FAILED)) ((AND (NULL REST-PAT) (NULL REST-DAT)) (RETURN ENV)) (T (SETF PATT (CAR REST-PAT)) (SETF DAT (CAR REST-DAT)) (SETF REST-PAT (CDR REST-PAT)) (SETF REST-DAT (CDR REST-DAT)) (GO HERE] ((EQ ENV 'FAILED) (RETURN 'FAILED)) ((EQ PATT DAT) (GO OUT)) [(VARIABLEP DAT) (SETF TEMP (CDR (ASSOC DAT ENV))) (COND ((NULL TEMP) (SETF ENV (BUILD-NEW-ENV DAT PATT ENV)) (GO OUT)) (T (SETF DAT TEMP) (GO HERE] [(VARIABLEP PATT) (SETF TEMP (CDR (ASSOC PATT ENV))) (COND ((NULL TEMP) (SETF ENV (BUILD-NEW-ENV PATT DAT ENV)) (GO OUT)) (T (SETF PATT TEMP) (GO HERE] [(NULL PATT) (COND ((NULLP DAT) (GO OUT)) (T (RETURN 'FAILED] [(NULL DAT) (COND ((NULLP PATT) (GO OUT)) (T (RETURN 'FAILED] [(LISTP PATT) (COND ((LISTP DAT) (SETF REST-PAT (CONS (REST PATT) REST-PAT)) (SETF REST-DAT (CONS (REST DAT) REST-DAT)) (SETF PATT (CAR PATT)) (SETF DAT (CAR DAT)) (GO HERE)) (T (RETURN 'FAILED] (T (RETURN 'FAILED] OUT (IL:* IL:;; "a check is made for the end of the procedure") (COND ((AND (NULL REST-PAT) (NULL REST-DAT)) (RETURN ENV)) (T (SETF DAT NIL) (SETF PATT NIL) (GO HERE]) (DEFMACRO VARIABLEP (ITEM) `(AND (SYMBOLP ,ITEM) (EQ (CHAR-CODE (CHAR (SYMBOL-NAME ,ITEM) 0)) 63))) (IL:PUTPROPS IL:UNIFIER IL:COPYRIGHT ("Roberto Ghislanzoni" 1987 1988)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/lispusers/UNIFIER.LISP b/lispusers/UNIFIER.LISP new file mode 100644 index 00000000..bd8cbb87 --- /dev/null +++ b/lispusers/UNIFIER.LISP @@ -0,0 +1 @@ +;;; -*- Package: User; Syntax: Common-Lisp; Mode: Lisp; Base: 10 -*- ;;; File converted on 28-Oct-87 14:27:32 from source UNIFIER ;;; Original source {DSK}LOGIC>MEDLEY>UNIFIER.;1 created 1-Aug-88 11:37:03 ; Copyright (c) 1987, 1988 by Roberto Ghislanzoni. All rights reserved. (DEFUN BINDING (PREDICATE THEORY-NAME &OPTIONAL WINDOW) (COND ((EQ THEORY-NAME '*BACKGROUND-THEORY*) (COND ((EQ (CHAR-CODE (CHAR (SYMBOL-NAME PREDICATE) 0)) 33) ;; CUT is handled in a very particular way!! (GETHASH '! (GET 'THEORY '*BACKGROUND-THEORY*))) (T (GETHASH PREDICATE (GET 'THEORY '*BACKGROUND-THEORY*)))) ) (T (GETHASH PREDICATE (GET-THEORY THEORY-NAME WINDOW))))) (DEFUN BUILD-NEW-ENV (PAT DAT ENV) ;; It is better to make a distinction between the null value ;; of a variable and the variables unbound (COND ((NULL DAT) (ACONS PAT '*NULL* ENV)) (T (ACONS PAT DAT ENV)))) (DEFUN CREATE-NEW-VARIABLE NIL (PROGN (SETF *VARIABLES-COUNTER* (+ 1 *VARIABLES-COUNTER*)) (OR (GETHASH *VARIABLES-COUNTER* *VARIABLES-TABLE*) (SETF (GETHASH *VARIABLES-COUNTER* *VARIABLES-TABLE*) (MAKE-SYMBOL (FORMAT NIL "?~A" *VARIABLES-COUNTER*)))))) (DEFUN CREATE-VARIABLES NIL (DEFVAR *VARIABLES-TABLE* (MAKE-HASH-TABLE) ) ;; all the variables used are cached in a hash-table: this is ;; also for not generating a lot of symbols that will fill up ;; the symbol table of the system ;; This function must be called before starting to work with ;; Logic (DO ((X 0 (+ X 1))) ((= X 4095) T) (SETF (GETHASH X *VARIABLES-TABLE*) (MAKE-SYMBOL (FORMAT NIL "?~A" X))))) (DEFUN FIND-IF-MEMBER (ELT LST) (COND ((NULL LST) NIL) ((LISTP LST) (OR (FIND-IF-MEMBER ELT (CAR LST)) (FIND-IF-MEMBER ELT (CDR LST)))) ((ATOM LST) (EQ LST ELT)) (T (MEMBER ELT LST)))) (DEFUN FIND-VALUES (ELT ENV) (COND ((NULL ELT) NIL) ((LISTP ELT) (CONS (FIND-VALUES (CAR ELT) ENV) (FIND-VALUES (CDR ELT) ENV))) ((VARIABLEP ELT) (FIND-VARIABLE-VALUE ELT ENV)) (T ELT))) (DEFUN FIND-VARIABLE-VALUE (VAR ENV) (LET ((VAL (CDR (ASSOC VAR ENV)))) (COND ((VARIABLEP VAL) (FIND-VARIABLE-VALUE VAL ENV)) ((NULL VAL) ;; The variable is unbound, so the variable itself ;; is returned VAR) ((NULLP VAL) ;; NULLP checks is the value is *NULL* NIL) (T ;; This is the statement for a partial occur ;; check (OR (AND (NOT (FIND-IF-MEMBER VAR VAL)) (FIND-VALUES VAL ENV)) VAL))))) (DEFUN LOOKUP (EXPR ENV) (COND ((NUMBERP EXPR) EXPR) ((SYMBOLP EXPR) (FIND-VALUES EXPR ENV)) (T (CONS (FIND-VALUES (CAR EXPR) ENV) (FIND-VALUES (CDR EXPR) ENV))))) (DEFMACRO NULLP (ATOM) `(EQ ,ATOM '*NULL*)) (DEFUN RENAME (EXPR) (LET ((VARSTABLE (MAKE-HASH-TABLE))) (DECLARE (SPECIAL VARSTABLE)) (RENAME-VARS EXPR))) (DEFUN RENAME-VARS (EXPR) (COND ((NULL EXPR) NIL) ((LISTP EXPR) (CONS (RENAME-VARS (CAR EXPR)) (RENAME-VARS (CDR EXPR)))) ((VARIABLEP EXPR) (LET ((ALREADY-RENAMED (GETHASH EXPR VARSTABLE))) (COND (ALREADY-RENAMED ALREADY-RENAMED) (T (LET ((NEW (CREATE-NEW-VARIABLE))) (SETF (GETHASH EXPR VARSTABLE) NEW) NEW))))) (T EXPR))) (DEFUN UNIFY (PATT DAT ENV &OPTIONAL WINDOW) ;; This is a very fast implementation of unifier: no stack ;; frames are generated. The tecnique used here is that of ;; save-rest argument: the unifier is not a true-recursive ;; procedure, in the sense that it does not require a full ;; stack for its implementation: in fact, when failure occurs, ;; the value FAILED must be immediately returned (PROG ((DEBUGFLG (AND WINDOW (TRACINGP WINDOW 'UNIFY))) (REST-PAT) (REST-DAT) TEMP) HERE (AND DEBUGFLG (UNIFY-DEBUGGER PATT DAT ENV WINDOW)) ; debugging stuff (COND ((AND (NULL PATT) (NULL DAT)) (COND ((AND (NULL REST-DAT) REST-PAT) (RETURN 'FAILED)) ((AND (NULL REST-PAT) REST-DAT) (RETURN 'FAILED)) ((AND (NULL REST-PAT) (NULL REST-DAT)) (RETURN ENV)) (T (SETF PATT (CAR REST-PAT)) (SETF DAT (CAR REST-DAT)) (SETF REST-PAT (CDR REST-PAT)) (SETF REST-DAT (CDR REST-DAT)) (GO HERE)))) ((EQ ENV 'FAILED) (RETURN 'FAILED)) ((EQ PATT DAT) (GO OUT)) ((VARIABLEP DAT) (SETF TEMP (CDR (ASSOC DAT ENV))) (COND ((NULL TEMP) (SETF ENV (BUILD-NEW-ENV DAT PATT ENV)) (GO OUT)) (T (SETF DAT TEMP) (GO HERE)))) ((VARIABLEP PATT) (SETF TEMP (CDR (ASSOC PATT ENV))) (COND ((NULL TEMP) (SETF ENV (BUILD-NEW-ENV PATT DAT ENV)) (GO OUT)) (T (SETF PATT TEMP) (GO HERE)))) ((NULL PATT) (COND ((NULLP DAT) (GO OUT)) (T (RETURN 'FAILED)))) ((NULL DAT) (COND ((NULLP PATT) (GO OUT)) (T (RETURN 'FAILED)))) ((LISTP PATT) (COND ((LISTP DAT) (SETF REST-PAT (CONS (REST PATT) REST-PAT)) (SETF REST-DAT (CONS (REST DAT) REST-DAT)) (SETF PATT (CAR PATT)) (SETF DAT (CAR DAT)) (GO HERE)) (T (RETURN 'FAILED)))) (T (RETURN 'FAILED))) OUT ;; a check is made for the end of the procedure (COND ((AND (NULL REST-PAT) (NULL REST-DAT)) (RETURN ENV)) (T (SETF DAT NIL) (SETF PATT NIL) (GO HERE))))) (DEFMACRO VARIABLEP (ITEM) `(AND (SYMBOLP ,ITEM) (EQ (CHAR-CODE (CHAR (SYMBOL-NAME ,ITEM) 0)) 63))) \ No newline at end of file diff --git a/lispusers/UPCSTATS b/lispusers/UPCSTATS new file mode 100644 index 00000000..e352fac3 --- /dev/null +++ b/lispusers/UPCSTATS @@ -0,0 +1 @@ +(FILECREATED "11-Oct-84 14:34:16" {ERIS}LIBRARY>UPCSTATS.;3 9157 changes to: (FNS UPCSTATS) previous date: "12-NOV-82 12:47:49" {ERIS}LIBRARY>UPCSTATS.;1) (* Copyright (c) by NIL. All rights reserved.) (PRETTYCOMPRINT UPCSTATSCOMS) (RPAQQ UPCSTATSCOMS ((VARS IMSIZE) (FNS GATHERUPCSTATS PRINTCUMULATIVEPERCENT PRINTUPC UPCSTATS) (FNS READMBFILE READNAME) (FNS PLOTPCS) (INITVARS (STATSBUFFER) (VIRTOREAL) (VIRTONAME)) (VARS (UPCTHRESHOLD 0 (* lower threshold for percentage to show up on Microcode PC Sample histogram))) (MACROS BIN2 UPCCOUNT))) (RPAQQ IMSIZE 4096) (DEFINEQ (GATHERUPCSTATS [LAMBDA (FORM) (* lmm "12-NOV-82 12:45") (DECLARE (GLOBALVARS STATSBUFFER)) (OR STATSBUFFER (SETQ STATSBUFFER (\ALLOCLOCKED IMSIZE))) [\ZEROWORDS STATSBUFFER (\ADDBASE STATSBUFFER (SUB1 (ITIMES IMSIZE (PROG1 2 (* words per fixp)] [RESETVARS ((STRF T) (LCFIL)) (COMPILE1 (QUOTE STATSDUMMYFUNCTION) (BQUOTE (LAMBDA NIL ((OPCODES UPCTRACE) STATSBUFFER) , FORM ((OPCODES UPCTRACE) NIL] (STATSDUMMYFUNCTION]) (PRINTCUMULATIVEPERCENT [LAMBDA NIL (* lmm "29-SEP-80 15:56") (PROGN (PRIN1 "(" NIL) (PRIN1 (FQUOTIENT (FPLUS (FTIMES 65536. CUHI) CULO) TOTAL) NIL) (PRIN1 ")" NIL]) (PRINTUPC [LAMBDA NIL (* lmm "12-NOV-82 11:40") (COND (UPCSEEN (do (PRIN1 "Use .MB file: " T) (SETQ MBFILE (READ T T)) repeatuntil (OR (EQ (NTHCHAR MBFILE 1) (QUOTE {)) (EQ MBFILE (QUOTE NIL:)) (INFILEP MBFILE))) (READMBFILE MBFILE) (PRIN1 "Microcode PC Sample: ") (PLOTPCS))) (STATSDUMMYFUNCTION]) (UPCSTATS [LAMBDA (FORM DOLISTFLG) (* gbn "11-Oct-84 14:33") (PROG ((STRF T) (LCFIL)) (DECLARE (SPECVARS STRF LCFIL)) (IF (NOT (EQ (MACHINETYPE) (QUOTE DORADO))) THEN (PRINTOUT T " UPCSTATS only runs on Dorados") (RETURN)) (GATHERUPCSTATS FORM) (READMBFILE) (PLOTPCS]) ) (DEFINEQ (READMBFILE [LAMBDA (MBFILE) (* lmm "12-NOV-82 12:31") (OR MBFILE (do (PRIN1 "Use .MB file: " T) (SETQ MBFILE (READ T T)) repeatuntil (INFILEP MBFILE))) (PROG ((INX (GETOFD (SETQ MBFILE (OPENFILE MBFILE (QUOTE INPUT) (QUOTE OLD) 8)) (QUOTE INPUT))) (CURMEMWIDTH 0) (CURMEM 0) (CURLOC 0) IM BLOCKTYPE) (SETQ MEMORIES) (OR VIRTOREAL (SETQ VIRTOREAL (ARRAY IMSIZE (QUOTE SMALLP) 0 0))) (OR VIRTONAME (SETQ VIRTONAME (ARRAY IMSIZE (QUOTE POINTER) NIL 0))) LP (SELECTQ (SETQ BLOCKTYPE (BIN2 INX)) (0 (RETURN)) [1 (COND ((EQ CURMEM IM) (BIN2 INX) (* source line #) (BIN2 INX) (* bits 0 to 15) (BIN2 INX) (* bits 16 to 31) (BIN2 INX) (* bits 32 to 47) (FASTSETAW VIRTOREAL (PROG1 CURLOC (add CURLOC 1)) (LOGAND (BIN2 INX) 4095)) (* bits 48 to 63) ) (T (BIN2 INX) (FRPTQ CURMEMWIDTH (BIN2 INX] (2 (SETQ CURMEM (BIN2 INX)) (SETQ CURLOC (BIN2 INX)) (SETQ CURMEMWIDTH (IQUOTIENT (IPLUS (CADR (OR (FASSOC CURMEM MEMORIES) (HELP))) 15) 16))) [3 (* FIXUP MEM# LOC FIRSTBIT,,LASTBIT VALUE) (COND ((EQ (BIN2 INX) IM) (HELP)) (T (BIN2 INX) (BIN2 INX) (BIN2 INX] [4 (push MEMORIES (LIST (BIN2 INX) (BIN2 INX) (READNAME INX))) (COND ((EQ (CADDR (CAR MEMORIES)) (QUOTE IM)) (SETQ IM (CAAR MEMORIES)) (OR (EQ (CADAR MEMORIES) 64) (HELP (QUOTE IM) "wrong # bits"] [5 (* symbol location) (COND ((EQ (BIN2 INX) IM) (FASTSETA VIRTONAME (BIN2 INX) (READNAME INX))) (T (BIN2 INX) (READNAME INX T] (6 (BIN2 INX) (BIN2 INX) (BIN2 INX) (READNAME INX T)) (HELP)) (GO LP)) (CLOSEF MBFILE]) (READNAME [LAMBDA (J FLG) (* lmm "16-MAY-81 16:51") (bind EVENBYTE CH CHARS do (COND [(ZEROP (SETQ CH (\BIN J))) (RETURN (PROG1 (OR FLG (PACKC (DREVERSE CHARS))) (COND ((NOT EVENBYTE) (\BIN J] (T (SETQ EVENBYTE (NOT EVENBYTE)) (push CHARS CH]) ) (DEFINEQ (PLOTPCS [LAMBDA (ALLFLG) (* lmm "12-NOV-82 12:29") (PROG (NAME (INC 0) LASTPRINTEDNAME V CNTPERSTAR (BIGGEST 0) (2NDBIGGEST 0) (3RDBIGGEST 0) (TOTHI 0) (TOTLO 0) CUM HALFSTAR MAXSTARS LASTSTARPOS NSTARS TABPOS THRESHOLD TOTAL (CUHI 0) (CULO 0)) (PRIN1 "Microcode PC Sample: ") [for I from 0 to (SUB1 IMSIZE) do (COND ((NEQ (SETQ V (UPCCOUNT I)) 0) (add TOTHI (LRSH V 16)) (add TOTLO (LOGAND V 65535)) (COND ((IGREATERP V 3RDBIGGEST) (COND [(IGREATERP V 2NDBIGGEST) (COND ((IGREATERP V BIGGEST) (SETQ BIGGEST V)) (T (SETQ 2NDBIGGEST V] (T (SETQ 3RDBIGGEST V] (* Each line has (NAME 14) (+nnn 4)  (%| 1) stars ((nn.nnnn%%) 10) + 2 for luck) (SETQ MAXSTARS (IDIFFERENCE [SETQ LASTSTARPOS (IDIFFERENCE (LINELENGTH) (COND (ALLFLG 20) (T 12] 20)) (SETQ CNTPERSTAR (IQUOTIENT 3RDBIGGEST MAXSTARS)) (SETQ HALFSTAR (IQUOTIENT CNTPERSTAR 2)) (SETQ TOTAL (FPLUS TOTLO (FTIMES TOTHI 65536.0))) [SETQ THRESHOLD (COND (ALLFLG 0) (T (IMAX HALFSTAR (FIX (QUOTIENT (TIMES UPCTHRESHOLD CNTPERSTAR) TOTAL] (SETQ TOTAL (FQUOTIENT TOTAL 100.0)) (printout NIL " Each * = " CNTPERSTAR " count, or " .F8.2 (FQUOTIENT CNTPERSTAR TOTAL) "%%") [for VPC from 0 to (SUB1 IMSIZE) do [COND ((SETQ V (FASTELT VIRTONAME VPC)) (SETQ NAME V) (SETQ INC 0)) (T (SETQ INC (ADD1 INC] (SETQ V (UPCCOUNT (FASTELTW VIRTOREAL VPC))) (COND (ALLFLG (COND [(NEQ NAME LASTPRINTEDNAME) (COND (LASTPRINTEDNAME (* don't do it the first time) (TAB LASTSTARPOS) (PRINTCUMULATIVEPERCENT))) (TERPRI) (PRIN1 (COND ((IGREATERP (SETQ TABPOS (NCHARS (SETQ LASTPRINTEDNAME NAME))) 14) (SUBSTRING NAME 1 (SETQ TABPOS 14))) (T NAME] (T (TERPRI) (SPACES TABPOS))) (add CUHI (LRSH V 16)) (add CULO (LOGAND V 65535)) (COND ((NEQ INC 0) (printout NIL "+" .I3...T INC))) (TAB 18) (printout NIL "#" .I8.4 (FASTELTW VIRTOREAL VPC) " " .I10 V)) ((IGREATERP V THRESHOLD) (COND [(NEQ NAME LASTPRINTEDNAME) (COND (LASTPRINTEDNAME (* don't do it the first time) (TAB LASTSTARPOS) (PRINTCUMULATIVEPERCENT))) (TERPRI) (PRIN1 (COND ((IGREATERP (SETQ TABPOS (NCHARS (SETQ LASTPRINTEDNAME NAME))) 14) (SUBSTRING NAME 1 (SETQ TABPOS 14))) (T NAME] (T (TERPRI) (SPACES TABPOS))) (add CUHI (LRSH V 16)) (add CULO (LOGAND V 65535)) (COND ((NEQ INC 0) (printout NIL "+" .I3...T INC))) (TAB 18) (PRIN1 "|") (FRPTQ (COND ((IGEQ (SETQ NSTARS (IQUOTIENT (IPLUS V HALFSTAR) CNTPERSTAR)) MAXSTARS) (printout NIL "(" .I4 NSTARS ")") (IDIFFERENCE MAXSTARS 6)) (T NSTARS)) (PRIN1 "*"] (TAB LASTSTARPOS) (PRINTCUMULATIVEPERCENT) (TERPRI) (SETQ CUHI (IDIFFERENCE TOTHI CUHI)) (SETQ CULO (IDIFFERENCE TOTLO CULO)) (printout NIL T T "Not shown: ") (PRINTCUMULATIVEPERCENT) (TERPRI]) ) (RPAQ? STATSBUFFER ) (RPAQ? VIRTOREAL ) (RPAQ? VIRTONAME ) (RPAQ UPCTHRESHOLD 0 (* lower threshold for percentage to show up on Microcode PC Sample histogram)) (DECLARE: EVAL@COMPILE (PUTPROPS BIN2 MACRO ((INX) (IPLUS (LLSH (\BIN INX) 8) (\BIN INX)))) (PUTPROPS UPCCOUNT MACRO [OPENLAMBDA (N) (\MAKENUMBER (\GETBASE STATSBUFFER (ADD1 (LLSH N 1))) (\GETBASE STATSBUFFER (LLSH N 1]) ) (DECLARE: DONTCOPY (FILEMAP (NIL (698 2431 (GATHERUPCSTATS 708 . 1305) (PRINTCUMULATIVEPERCENT 1307 . 1533) (PRINTUPC 1535 . 1979) (UPCSTATS 1981 . 2429)) (2432 4989 (READMBFILE 2442 . 4644) (READNAME 4646 . 4987)) (4990 8641 (PLOTPCS 5000 . 8639))))) STOP \ No newline at end of file diff --git a/lispusers/UPCSTATS.TEDIT b/lispusers/UPCSTATS.TEDIT new file mode 100644 index 00000000..f45c716c Binary files /dev/null and b/lispusers/UPCSTATS.TEDIT differ diff --git a/lispusers/UTILISOPRS b/lispusers/UTILISOPRS new file mode 100644 index 00000000..881e8904 --- /dev/null +++ b/lispusers/UTILISOPRS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "14-Apr-88 12:37:05" {ERINYES}LYRIC>UTILISOPRS.\;1 2918 |changes| |to:| (FNS |FIntersection| |FUnion|) |previous| |date:| "24-Mar-87 19:54:30" |{XDE:MCS:STANFORD}LYRIC>UTILISOPRS.;1|) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT UTILISOPRSCOMS) (RPAQQ UTILISOPRSCOMS ((I.S.OPRS COLLECTWHEN INTERSECT MAXIMIZE MINIMIZE REPEATEACHTIME UNION UNIQUE YIELD FIRSTTIME |fintersect| |funion|) (ADDVARS (LOCALVARS $$STATE $$TMP $$UIV $$UNQ $$FLTR) (SYSLOCALVARS $$STATE $$TMP $$UIV $$UNQ $$FLTR)) (FNS |FIntersection| |FUnion|))) (DECLARE\: EVAL@COMPILE (I.S.OPR 'COLLECTWHEN NIL '(|bind| $$FLTR |when| (SETQ $$FLTR BODY) |collect| $$FLTR)) (I.S.OPR 'INTERSECT '(PROGN (INTBOD _ BODY) (OR ($$VAL _ (COND ($$VAL (INTERSECTION $$VAL INTBOD)) (T INTBOD))) (GO $$OUT))) '(BIND INTBOD)) (I.S.OPR 'MAXIMIZE NIL '(|largest| BODY |yield| $$EXTREME)) (I.S.OPR 'MINIMIZE NIL '(|smallest| BODY |yield| $$EXTREME)) (I.S.OPR 'REPEATEACHTIME NIL '(|repeatuntil| (PROGN BODY NIL))) (I.S.OPR 'UNION '($$VAL _ (UNION $$VAL BODY))) (I.S.OPR 'UNIQUE '(|if| $$VAL |then| ($$VAL_ NIL) (GO $$OUT) |else| $$VAL _ $$UNQ $$UIV _ I.V.) '(|bind| ($$UNQ $$UIV) |when| $$UNQ _ BODY |finally| (I.V._ (AND $$VAL $$UIV)))) (I.S.OPR 'YIELD NIL '(FINALLY (RETURN BODY))) (I.S.OPR 'FIRSTTIME NIL '(|bind| ($$MEMO _ T) |unless| (AND $$MEMO (PROGN BODY T) (SETQ $$MEMO NIL)))) (I.S.OPR '|fintersect| '(PROGN (INTBOD _ BODY) (OR ($$VAL _ (COND ($$VAL (|FIntersection| $$VAL INTBOD)) (T INTBOD))) (GO $$OUT))) '(BIND INTBOD)) (I.S.OPR '|funion| '($$VAL _ (|FUnion| $$VAL BODY))) ) (ADDTOVAR LOCALVARS $$STATE $$TMP $$UIV $$UNQ $$FLTR) (ADDTOVAR SYSLOCALVARS $$STATE $$TMP $$UIV $$UNQ $$FLTR) (DEFINEQ (|FIntersection| (LAMBDA (X Y) (* TAL "27-OCT-82 17:54") (|for| |item| |in| X |when| (FMEMB |item| Y) |collect| |item|))) (|FUnion| (LAMBDA (X Y) (* TAL "28-OCT-82 12:00") (|bind| (|tmp| _ Y) |for| |item| |in| X |unless| (FMEMB |item| |tmp|) |do| (|push| |tmp| |item|) |finally| (RETURN |tmp|)))) ) (PUTPROPS UTILISOPRS COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2350 2836 (|FIntersection| 2360 . 2560) (|FUnion| 2562 . 2834))))) STOP \ No newline at end of file diff --git a/lispusers/UUENCODE b/lispusers/UUENCODE new file mode 100644 index 00000000..1b2f7266 --- /dev/null +++ b/lispusers/UUENCODE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Oct-87 18:15:20" |{POGO:AISNORTH:XEROX}LISP>UUENCODE.;4| 10562 changes to%: (VARS UUENCODECOMS) (FUNCTIONS UU.SIXBITS UU.LSH) (FNS UUDECODE-BEGIN-LINE-INTERNAL UUENCODE-INTERNAL UUDECODE-INTERNAL UUDECODE-BODY UUENCODE UUENCODE-ONE-FILE UUDECODE UUDECODE-BEGIN-LINE UU.TEDIT-INCLUDE-ENCODED UU.DECODE-FROM-TEDIT) previous date%: " 7-Oct-87 17:46:11" |{POGO:AISNORTH:XEROX}LISP>UUENCODE.;3|) (* " Copyright (c) 1987 by Douglass Read Cutting. All rights reserved. ") (PRETTYCOMPRINT UUENCODECOMS) (RPAQQ UUENCODECOMS ((* ;; "UNIX compatible uuencode & uudecode.") (COMS (* ;; "encoding") (FNS UUENCODE UUENCODE-ONE-FILE UUENCODE-INTERNAL) (INITVARS (UU.MODE-DEFAULT 420)) (GLOBALVARS UU.MODE-DEFAULT) (FUNCTIONS UU.BYTE) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (UU.CHARS-PER-LINE 45) (UU.LAST-TWO-BITS 3) (UU.LAST-FOUR-BITS 15) (UU.FIRST-TWO-BITS 192)))) (COMS (* ;; "decoding") (FNS UUDECODE UUDECODE-INTERNAL UUDECODE-BEGIN-LINE UUDECODE-BEGIN-LINE-INTERNAL UUDECODE-BODY) (FUNCTIONS UU.SIXBITS UU.LSH) (VARS (UU.READTABLE (COPYREADTABLE (QUOTE ORIG)))) (GLOBALVARS UU.READTABLE) (P (SETBRK NIL NIL UU.READTABLE) (SETSEPR (CHARCODE (SPACE CR LF)) NIL UU.READTABLE) (ESCAPE NIL UU.READTABLE))) (COMS (* ;; "TEdit interface") (FNS UU.TEDIT-INCLUDE-ENCODED UU.DECODE-FROM-TEDIT) (P (AND (FGETD (QUOTE TEDIT)) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU (QUOTE (UUEncode (FUNCTION UU.TEDIT-INCLUDE-ENCODED) "Encode & include a file" (SUBITEMS ("UUDecode" (FUNCTION UU.DECODE-FROM-TEDIT) "Decode the text in this window"))))))) (GLOBALVARS TEDIT.DEFAULT.MENU)) (PROP FILETYPE UUENCODE)) ) (* ;; "UNIX compatible uuencode & uudecode.") (* ;; "encoding") (DEFINEQ (UUENCODE (LAMBDA (FILES INTO-FILE) (* drc%: "16-Mar-87 15:37") (RESETLST (for FILE in (MKLIST FILES) bind INTO-STREAM first (SETQ INTO-STREAM (OPENSTREAM INTO-FILE (QUOTE OUTPUT))) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) INTO-STREAM)) do (UUENCODE-ONE-FILE FILE INTO-STREAM) finally (RETURN (CLOSEF INTO-STREAM))))) ) (UUENCODE-ONE-FILE (LAMBDA (IN-FILE OUT-FILE-OR-STREAM) (* drc%: "16-Mar-87 14:34") (* ;; "uuencode IN-FILE to OUT-FILE-OR-STREAM.") (RESETLST (LET ((INS (OPENSTREAM IN-FILE (QUOTE INPUT)))) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) INS)) (LET* ((ALREADY-OPEN? (OPENP OUT-FILE-OR-STREAM (QUOTE OUTPUT))) (OUTS (if ALREADY-OPEN? then (GETSTREAM OUT-FILE-OR-STREAM (QUOTE OUTPUT)) else (OPENSTREAM OUT-FILE-OR-STREAM (QUOTE OUTPUT))))) (if (NOT ALREADY-OPEN?) then (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) OUTS))) (UUENCODE-INTERNAL INS OUTS (NAMEFIELD IN-FILE T)) (CLOSEF INS) (if (NOT ALREADY-OPEN?) then (CLOSEF OUTS) else OUTS))))) ) (UUENCODE-INTERNAL (LAMBDA (INS OUTS DECODE-NAME FILE-MODE) (* ; "Edited 7-Oct-87 17:22 by drc:") (* ;; "encode text from INS to OUTS.") (* ;; "DECODE-NAME is what the file should be called when decoded") (* ;; "FILE-MODE is the UNIX file mode. The default is reasonable.") (LET* ((EOF (GETEOFPTR INS)) (PADDING (CL:MOD EOF 3)) (STOP (CL:IF (ZEROP PADDING) EOF (PLUS EOF (- 3 PADDING))))) (* ;; "Each 3 bytes are encoded in 4 six-bit chars.") (from 1 to STOP first (* ;; "Print header") (printout OUTS T "begin ") (RESETFORM (RADIX 8) (printout OUTS (OR FILE-MODE UU.MODE-DEFAULT))) (printout OUTS " " (OR DECODE-NAME (NAMEFIELD (FULLNAME INS) T))) bind (STATE _ 1) BYTE BITS (COLUMN _ 0) declare (LOCALVARS . T) do (if (ZEROP COLUMN) then (* ;; "time to start a new line") (TERPRI OUTS) (* ;; "first char represents how much cleartext will be on the line") (BOUT OUTS (UU.BYTE (IMIN UU.CHARS-PER-LINE (IDIFFERENCE EOF (GETFILEPTR INS)))))) (if (NOT (EOFP INS)) then (SETQ BYTE (BIN INS)) else 0) (SELECTQ STATE (1 (BOUT OUTS (UU.BYTE (RSH BYTE 2))) (SETQ BITS (LOGAND BYTE UU.LAST-TWO-BITS))) (2 (BOUT OUTS (UU.BYTE (LOGOR (LSH BITS 4) (RSH BYTE 4)))) (SETQ BITS (LOGAND BYTE UU.LAST-FOUR-BITS))) (3 (BOUT OUTS (UU.BYTE (LOGOR (LSH BITS 2) (RSH BYTE 6)))) (BOUT OUTS (UU.BYTE (BITCLEAR BYTE UU.FIRST-TWO-BITS)))) (SHOULDNT)) (SETQ STATE (ADD1 (CL:MOD STATE 3))) (SETQ COLUMN (CL:MOD (ADD1 COLUMN) UU.CHARS-PER-LINE)) finally (* ;; "print footer") (printout OUTS T " " T "end" T))) OUTS) ) ) (RPAQ? UU.MODE-DEFAULT 420) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS UU.MODE-DEFAULT) ) (DEFMACRO UU.BYTE (BYTE) (BQUOTE (IPLUS (\, BYTE) (CHARCODE SPACE)))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ UU.CHARS-PER-LINE 45) (RPAQQ UU.LAST-TWO-BITS 3) (RPAQQ UU.LAST-FOUR-BITS 15) (RPAQQ UU.FIRST-TWO-BITS 192) (CONSTANTS (UU.CHARS-PER-LINE 45) (UU.LAST-TWO-BITS 3) (UU.LAST-FOUR-BITS 15) (UU.FIRST-TWO-BITS 192)) ) ) (* ;; "decoding") (DEFINEQ (UUDECODE (LAMBDA (FILE-OR-STREAM ONLY-ONE-FILE?) (* drc%: "22-Mar-87 15:08") (* ;; "decode from FILE-OR-STREAM") (* ;; "if ONLY-ONE-FILE? is non-NIL then return name of file extracted.") (* ;; "if ONLY-ONE-FILE? is NIL then return list of files extracted.") (RESETLST (LET* ((ALREADY-OPEN? (OPENP FILE-OR-STREAM (QUOTE INPUT))) (INS (if ALREADY-OPEN? then (GETSTREAM FILE-OR-STREAM (QUOTE INPUT)) else (OPENSTREAM FILE-OR-STREAM (QUOTE INPUT))))) (if (NOT ALREADY-OPEN?) then (RESETSAVE NIL (LIST (FUNCTION CLOSEF) INS))) (if ONLY-ONE-FILE? then (LIST (UUDECODE-INTERNAL INS ONLY-ONE-FILE?)) else (bind OUT-FILE eachtime (SETQ OUT-FILE (UUDECODE-INTERNAL INS ONLY-ONE-FILE?)) while OUT-FILE collect OUT-FILE))))) ) (UUDECODE-INTERNAL (LAMBDA (INS ONLY-ONE-FILE?) (* drc%: "22-Mar-87 15:06") (LET ((OUT-FILE (UUDECODE-BEGIN-LINE INS (NOT ONLY-ONE-FILE?)))) (if OUT-FILE then (RESETLST (LET ((OUTS (OPENSTREAM OUT-FILE (QUOTE OUTPUT)))) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) OUTS)) (* ;; "decode the body") (UUDECODE-BODY INS OUTS) (* ;; "read the `end' line") (OR (for BYTE in (CONSTANT (CHCON "end")) always (EQ (BIN INS) BYTE)) (ERROR OUT-FILE "NO `end' LINE FOUND")) (* ;; "return the name of the decoded file") (CLOSEF OUTS)))))) ) (UUDECODE-BEGIN-LINE (LAMBDA (INS NO-ERROR) (* drc%: "16-Mar-87 15:09") (* ;; "Scans for the begin line in file.") (* ;; "Returns the name of the encoded file.") (* ;; "Returns NIL if end of file is reached and NO-ERROR is specified.") (if NO-ERROR then (RESETLST (RESETSAVE NIL (LIST (FUNCTION SETFILEINFO) INS (QUOTE ENDOFSTREAMOP) (GETFILEINFO INS (QUOTE ENDOFSTREAMOP)))) (SETFILEINFO INS (QUOTE ENDOFSTREAMOP) (FUNCTION (LAMBDA (S) (RETFROM (QUOTE UUDECODE-BEGIN-LINE) NIL)))) (* ;; "what? Interlisp? Cryptic? Never.") (UUDECODE-BEGIN-LINE-INTERNAL INS)) else (UUDECODE-BEGIN-LINE-INTERNAL INS))) ) (UUDECODE-BEGIN-LINE-INTERNAL (LAMBDA (INS) (* ; "Edited 7-Oct-87 17:45 by drc:") (until (for BYTE in (CONSTANT (CHCON "begin ")) always (AND (EQ (\PEEKBIN INS) BYTE) (BIN INS))) do (* ;; "skip to next line") (until (SELCHARQ (BIN INS) ((CR LF) T) NIL)) bind FILE-NAME finally (* ;; "read mode (ignored) ") (RESETFORM (RADIX 8) (OR (SMALLP (RATOM INS UU.READTABLE)) (ERROR (FULLNAME INS) "BAD `begin' LINE"))) (* ;; "read space") (OR (EQ (BIN INS) (CHARCODE SPACE)) (ERROR (FULLNAME INS) "BAD `begin' LINE")) (* ;; "read file name") (SETQ FILE-NAME (RSTRING INS UU.READTABLE)) (* ;; "read end of line") (SELCHARQ (BIN INS) ((LF CR)) (ERROR (FULLNAME INS) "BAD `begin' LINE")) (* ;; "return the file name") (RETURN FILE-NAME))) ) (UUDECODE-BODY (LAMBDA (INS OUTS) (* ; "Edited 7-Oct-87 17:06 by drc:") (* ;; "The inner decoding loop.") (bind LINE-LENGTH declare (LOCALVARS . T) eachtime (* ;; "read length of line") (SETQ LINE-LENGTH (UU.SIXBITS (BIN INS))) while (NOT (ZEROP LINE-LENGTH)) do (* ;; "read body of line, decoding to output as we go") (bind (N-CHARS-READ _ 0) (NIBBLE-N _ 0) NIBBLE-1 NIBBLE-2 NIBBLE-3 eachtime (SETQ NIBBLE-N (ADD1 (IMOD NIBBLE-N 4))) while (ILESSP N-CHARS-READ LINE-LENGTH) do (* ;; "nibbles here are six-bits") (SELECTQ NIBBLE-N (1 (SETQ NIBBLE-1 (UU.SIXBITS (BIN INS)))) (2 (SETQ NIBBLE-2 (UU.SIXBITS (BIN INS))) (BOUT OUTS (LOGOR (UU.LSH NIBBLE-1 2) (RSH NIBBLE-2 4))) (add N-CHARS-READ 1)) (3 (SETQ NIBBLE-3 (UU.SIXBITS (BIN INS))) (BOUT OUTS (LOGOR (UU.LSH NIBBLE-2 4) (RSH NIBBLE-3 2))) (add N-CHARS-READ 1)) (4 (BOUT OUTS (LOGOR (UU.LSH NIBBLE-3 6) (UU.SIXBITS (BIN INS)))) (add N-CHARS-READ 1)) (SHOULDNT)) finally (* ;; "read padding ") (OR (EQ NIBBLE-N 1) (from NIBBLE-N to 4 do (BIN INS))) (SELCHARQ (BIN INS) ((LF CR)) (ERROR (FULLNAME INS) "LINE TOO LONG - FILE BASHED?"))) finally (SELCHARQ (BIN INS) ((LF CR)) (ERROR (FULLNAME INS) "LINE TOO LONG - FILE BASHED?")))) ) ) (DEFMACRO UU.SIXBITS (CHAR) (BQUOTE (CL:MOD (IDIFFERENCE (\, CHAR) (CHARCODE SPACE)) 64))) (DEFMACRO UU.LSH (N BITS) (BQUOTE (LDB (BYTE 8 0) (LSH (\, N) (\, BITS))))) (RPAQ UU.READTABLE (COPYREADTABLE (QUOTE ORIG))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS UU.READTABLE) ) (SETBRK NIL NIL UU.READTABLE) (SETSEPR (CHARCODE (SPACE CR LF)) NIL UU.READTABLE) (ESCAPE NIL UU.READTABLE) (* ;; "TEdit interface") (DEFINEQ (UU.TEDIT-INCLUDE-ENCODED (LAMBDA (TEXTSTREAM) (* drc%: "16-Mar-87 19:28") (LET ((FILE (TEDIT.GETINPUT TEXTSTREAM "File to encode:"))) (if FILE then (RESETLST (LET* ((TEMP-STREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) TEMP-STREAM)) (UUENCODE-ONE-FILE FILE TEMP-STREAM) (SETFILEPTR TEMP-STREAM 0) (TEDIT.RAW.INCLUDE TEXTSTREAM (UUENCODE-ONE-FILE FILE TEMP-STREAM)))) else (TEDIT.PROMPTPRINT TEXTSTREAM " [aborted]")))) ) (UU.DECODE-FROM-TEDIT (LAMBDA (TEXTSTREAM) (* drc%: "22-Mar-87 15:02") (* ;; "decode from FILE-OR-STREAM") (* ;; "if ONLY-ONE-FILE? is non-NIL then return name of file extracted.") (* ;; "if ONLY-ONE-FILE? is NIL then return list of files extracted.") (bind OUT-FILE LAST-FILE first (SETFILEPTR TEXTSTREAM 0) (TEDIT.PROMPTPRINT TEXTSTREAM "Decoding ... " T) eachtime (SETQ LAST-FILE OUT-FILE) (SETQ OUT-FILE (UUDECODE-INTERNAL TEXTSTREAM)) while OUT-FILE do (AND LAST-FILE (TEDIT.PROMPTPRINT TEXTSTREAM ", ")) (TEDIT.PROMPTPRINT TEXTSTREAM OUT-FILE) finally (TEDIT.PROMPTPRINT TEXTSTREAM (if LAST-FILE then " done." else "nothing to decode!")))) ) ) (AND (FGETD (QUOTE TEDIT)) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU (QUOTE (UUEncode (FUNCTION UU.TEDIT-INCLUDE-ENCODED) "Encode & include a file" (SUBITEMS ("UUDecode" (FUNCTION UU.DECODE-FROM-TEDIT) "Decode the text in this window")))))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.DEFAULT.MENU) ) (PUTPROPS UUENCODE FILETYPE :COMPILE-FILE) (PUTPROPS UUENCODE COPYRIGHT ("Douglass Read Cutting" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1793 4262 (UUENCODE 1803 . 2125) (UUENCODE-ONE-FILE 2127 . 2763) (UUENCODE-INTERNAL 2765 . 4260)) (4761 8558 (UUDECODE 4771 . 5490) (UUDECODE-INTERNAL 5492 . 6017) (UUDECODE-BEGIN-LINE 6019 . 6629) (UUDECODE-BEGIN-LINE-INTERNAL 6631 . 7364) (UUDECODE-BODY 7366 . 8556)) (8985 10122 ( UU.TEDIT-INCLUDE-ENCODED 8995 . 9467) (UU.DECODE-FROM-TEDIT 9469 . 10120))))) STOP \ No newline at end of file diff --git a/lispusers/UUENCODE.TEDIT b/lispusers/UUENCODE.TEDIT new file mode 100644 index 00000000..c6f0f485 Binary files /dev/null and b/lispusers/UUENCODE.TEDIT differ diff --git a/lispusers/VANILLA-INIT b/lispusers/VANILLA-INIT new file mode 100644 index 00000000..5e618ec6 --- /dev/null +++ b/lispusers/VANILLA-INIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL" BASE 10) (filecreated "10-Mar-89 15:14:52" |{EG:PARC:XEROX}LISP>USERS>VANILLA-INIT.;16| 88924 |changes| |to:| (vars db-init-commands compute-directories-init-commands change-background-init-commands idle-init-commands programming-init-commands pcl-init-commands loops-init-commands mail-init-commands talk-init-commands demos-init-commands games-init-commands) |previous| |date:| " 2-Mar-89 15:30:16" |{EG:PARC:XEROX}LISP>USERS>VANILLA-INIT.;15| ) ; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved. (prettycomprint vanilla-initcoms) (rpaqq vanilla-initcoms ((* |;;| "Macro to avoid problems when trying to maintain file.") (coms (p (cl:proclaim (quote (global *vanilla-init-loaded*)))) (initvars (*vanilla-init-loaded* nil)) (functions eval-at-greet)) (* |;;| "Silent loads") (coms (p (cl:proclaim (quote (global *load-silent* prettyheader)))) (initvars (*load-silent* nil)) (vars (\\original-load-verbose *load-verbose*) (\\original-prettyheader prettyheader) (*load-verbose* (if *load-silent* then nil else *load-verbose*)) (prettyheader (if *load-silent* then nil else prettyheader)))) (* |;;| "Environment setup") (coms * compute-directories-init-commands) (coms * env-tailoring-init-commands) (coms * patch-init-commands) (coms * font-setup-init-commands) (declare\: eval@loadwhen (not *vanilla-init-loaded*) donteval@compile docopy (files (sysload from lispusers) loadmenuitems)) (* |;;| "Machine status") (coms * who-line-commands) (coms * vstats-init-commands) (* |;;| "Display control") (coms * screen-setup-init-commands) (coms * rooms-init-commands) (coms * change-background-init-commands) (coms * display-control-init-commands) (coms * idle-init-commands) (coms * clock-init-commands) (* |;;| "Programming stuff") (coms * programming-init-commands) (coms * old-utils-commands) (coms * wizard-init-commands) (coms * dinfo-init-commands) (coms * pcl-init-commands) (coms * loops-init-commands) (* |;;| "Documentation") (coms * tedit-init-commands) (coms * sketch-init-commands) (coms * notecards-init-commands) (* |;;| "Communication & Info") (coms * mail-init-commands) (coms * chat-init-commands) (coms * talk-init-commands) (coms * calendar-init-commands) (coms * printer-init-commands) (coms * db-init-commands) (coms * nfs-init-commands) (* |;;| "Files") (coms * file-watch-init-commands) (coms * file-server-init-commands) (coms * dirgrapher-init-commands) (coms * fb-init-commands) (coms * compare-files-init-commands) (* |;;| "Random stuff") (coms * unix-init-commands) (coms * demos-init-commands) (coms * games-init-commands) (* |;;| "Cleanup") (coms * background-menu-cleanup-init-commands) (coms * do-load-utilities-init-commands) (coms (* |;;| "Send the Tool Work's a message telling it about this user.") (functions log-vanilla-init-user) (initvars (\\cc-generic-init-msg t)) (p (eval-at-greet (cl:unless *vanilla-init-loaded* (log-vanilla-init-user))))) (vars (*load-verbose* \\original-load-verbose) (prettyheader \\original-prettyheader) (*vanilla-init-loaded* t)) (* |;;| "Make the FileManager happy") (declare\: dontcopy (prop makefile-environment vanilla-init)))) (* |;;| "Macro to avoid problems when trying to maintain file.") (cl:proclaim (quote (global *vanilla-init-loaded*))) (rpaq? *vanilla-init-loaded* nil) (defmacro eval-at-greet (&body forms) "Evaluate the forms only when loading the compiled file, and then only when greeting" (bquote (cl:eval-when (cl:load) (cl:unless (or *vanilla-init-loaded* (memb dfnflg (quote (prop allprop)))) (\\\,@ forms))))) (* |;;| "Silent loads") (cl:proclaim (quote (global *load-silent* prettyheader))) (rpaq? *load-silent* nil) (rpaq \\original-load-verbose *load-verbose*) (rpaq \\original-prettyheader prettyheader) (rpaq *load-verbose* (if *load-silent* then nil else *load-verbose*)) (rpaq prettyheader (if *load-silent* then nil else prettyheader)) (* |;;| "Environment setup") (rpaqq compute-directories-init-commands ((declare\: donteval@compile (vars (|\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name)))) (loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (let ((greetfile (greetfilename |\\BasicUserName|))) (if greetfile then (packfilename.string (quote host) (filenamefield greetfile (quote host)) (quote directory) (filenamefield greetfile (quote directory))) else loginhost/dir))) (t loginhost/dir))))) (initvars (|\\UserHomeDirectory| (u-case (let ((host (filenamefield loginhost/dir (quote host))) (dirs (cl:do* ((directory (filenamefield loginhost/dir (quote directory)) (substring directory (cl:1+ sepr-pos))) (sepr-table (makebittable (list "/" ">"))) (sepr-pos (strposl sepr-table directory) (strposl sepr-table directory)) (dirs (list))) ((null sepr-pos) (cl:reverse (cl:if (null directory) dirs (cons directory dirs)))) (cl:push (substring directory 1 (cl:1- sepr-pos)) dirs)))) (|if| (not (strpos "/n" host nil nil t nil uppercasearray t)) |then| (* |;;| "On everything but an NFS server, standard setup is {host}") (packfilename.string (quote host) host (quote directory) (cl:first dirs)) |elseif| (strpos "~" (cl:first dirs) 1 nil t) |then| (* |;;| "On an NFS server, with directory of the form <~Username>") (packfilename.string (quote host) host (quote directory) (cl:first dirs)) |else| (* |;;| "On an NFS server, the standard setup is {host/n}user>") (packfilename.string (quote host) host (quote directory) (concat (cl:first dirs) ">" (cl:second dirs))))))) (tempdir (concat |\\UserHomeDirectory| "TEMP>")) (home-machine-name "") (private-lispusersdirectories nil) (*cache-directories* nil)))) (declare\: donteval@compile (rpaq |\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name)))) (rpaq loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (let ((greetfile (greetfilename |\\BasicUserName|))) (if greetfile then (packfilename.string (quote host) (filenamefield greetfile (quote host)) (quote directory) (filenamefield greetfile (quote directory))) else loginhost/dir))) (t loginhost/dir))) ) (rpaq? |\\UserHomeDirectory| (u-case (let ((host (filenamefield loginhost/dir (quote host))) (dirs (cl:do* ((directory (filenamefield loginhost/dir (quote directory)) (substring directory (cl:1+ sepr-pos))) (sepr-table (makebittable (list "/" ">"))) (sepr-pos (strposl sepr-table directory) (strposl sepr-table directory)) (dirs (list))) ((null sepr-pos) (cl:reverse (cl:if (null directory) dirs (cons directory dirs)))) (cl:push (substring directory 1 (cl:1- sepr-pos)) dirs)))) (|if| (not (strpos "/n" host nil nil t nil uppercasearray t)) |then| (* |;;| "On everything but an NFS server, standard setup is {host}") (packfilename.string (quote host) host (quote directory) (cl:first dirs)) |elseif| (strpos "~" (cl:first dirs) 1 nil t) |then| (* |;;| "On an NFS server, with directory of the form <~Username>") (packfilename.string (quote host) host (quote directory) (cl:first dirs)) |else| (* |;;| "On an NFS server, the standard setup is {host/n}user>") (packfilename.string (quote host) host (quote directory) (concat (cl:first dirs) ">" (cl:second dirs))))))) (rpaq? tempdir (concat |\\UserHomeDirectory| "TEMP>")) (rpaq? home-machine-name "") (rpaq? private-lispusersdirectories nil) (rpaq? *cache-directories* nil) (rpaqq env-tailoring-init-commands ((declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) pagehold) (vars (|MaxValueLeftMargin| 512) (scrollbarwidth 20) (fixspelldefault (quote \n)) (\\ethertimeout 3000) (empress#sides 2) (*print-case* :downcase)) (vars (cleanupoptions (quote (rc st))) (copyrightflg (quote default)) (recompiledefault (quote exprs)) (*default-cleanup-compiler* (quote cl:compile-file)) (*default-makefile-environment* (quote (:package "XCL-USER" :readtable "XCL" :base 10)))) (vars (*original-give-and-take-directories* *give-and-take-directories*) (*give-and-take-directories* (if (boundp (quote *give-and-take-directories*)) then (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*) else nil))) (advise files?) (p (eval-at-greet (cl:when (and (eq (machinetype) (quote dorado)) (cl:fboundp (quote describe-virtual-memory))) (describe-virtual-memory)))) (addvars (afterlogoutforms (|for| greet-date |in| greetdates |bind| (today _ (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t))))))) (declare\: donteval@load donteval@compile (filesload (sysload noerror from lispusers) pagehold) (rpaqq |MaxValueLeftMargin| 512) (rpaqq scrollbarwidth 20) (rpaqq fixspelldefault \n) (rpaqq \\ethertimeout 3000) (rpaqq empress#sides 2) (rpaq *print-case* :downcase) (rpaqq cleanupoptions (rc st)) (rpaqq copyrightflg default) (rpaqq recompiledefault exprs) (rpaqq *default-cleanup-compiler* cl:compile-file) (rpaqq *default-makefile-environment* (:package "XCL-USER" :readtable "XCL" :base 10)) (rpaq *original-give-and-take-directories* *give-and-take-directories*) (rpaq *give-and-take-directories* (if (boundp (quote *give-and-take-directories*)) then (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*) else nil)) (xcl:reinstall-advice (quote files?) :before (quote ((:last (setq notlistedfiles nil))))) (readvise files?) (eval-at-greet (cl:when (and (eq (machinetype) (quote dorado)) (cl:fboundp (quote describe-virtual-memory))) (describe-virtual-memory))) (addtovar afterlogoutforms (|for| greet-date |in| greetdates |bind| (today _ (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t))) ) (rpaqq patch-init-commands nil) (rpaqq font-setup-init-commands ((alists (fontdefs generic-init)) (initvars (\\font-profile-name (quote generic-init))) (declare\: donteval@load donteval@compile (p (eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow))))))) (advise getpromptwindow)))) (addtovar fontdefs (generic-init (fontchangeflg . all) (filelinelength . 102) (commentlinelength 80 . 102) (lambdafontlinelength . 95) (firstcol . 60) (prettylcom . 25) (listfilestr . " ") (|ObjectDontPPFlag| . t) (sysprettyflg . t) (**comment**flg) (fontprofile (defaultfont 1 (gacha 10) (gacha 8) (terminal 8)) (boldfont 2 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (littlefont 3 (helvetica 8) (helvetica 6 mir) (modern 6 mir)) (bigfont 4 (helvetica 12 brr) (helvetica 10 brr) (modern 10 brr)) (userfont boldfont) (commentfont littlefont) (lambdafont bigfont) (systemfont) (clispfont boldfont) (changefont) (prettycomfont boldfont) (tinyfont littlefont) (font1 defaultfont) (font2 boldfont) (font3 littlefont) (font4 bigfont) (font5 5 (helvetica 10 bir) (helvetica 8 bir) (modern 8 bir)) (font6 6 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (font7 7 (gacha 12) (gacha 12) (terminal 12)) (font8 8 (modern 10 mir) (modern 10 mir) (modern 10 mir)) (font9 9 (modern 10 bir) (modern 10 bir) (modern 10 bir)) (font10 10 (modern 12 mir) (modern 12 mir) (modern 12 mir)) (font11 11 (timesroman 10) (timesroman 10) (classic 10)) (|\\WindowTitleFont| bigfont) (lafitetitlefont |\\WindowTitleFont|) (chat.font font7)))) (rpaq? \\font-profile-name (quote generic-init)) (declare\: donteval@load donteval@compile (eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow)))))) (xcl:reinstall-advice (quote getpromptwindow) :before (quote ((:last (cond ((and (null font) (boundp (quote promptfont))) (setq font promptfont))))))) (readvise getpromptwindow) ) (declare\: eval@loadwhen (not *vanilla-init-loaded*) donteval@compile docopy (filesload (sysload from lispusers) loadmenuitems) ) (* |;;| "Machine status") (rpaqq who-line-commands ((declare\: donteval@load donteval@compile (files (sysload from lispusers) who-line) (vars (*who-line-anchor* (quote (:justify :top))) (*who-line-display-names?* t) (*who-line-directories* (list |\\UserHomeDirectory|)) (*who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*))) (p (eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*)))))))))) (declare\: donteval@load donteval@compile (filesload (sysload from lispusers) who-line) (rpaqq *who-line-anchor* (:justify :top)) (rpaqq *who-line-display-names?* t) (rpaq *who-line-directories* (list |\\UserHomeDirectory|)) (rpaq *who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*)) (eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*)))))) ) (rpaqq vstats-init-commands ((initvars (vstats.clock.interval 0) (vstats.mutil.interval nil) (vstats.position (createposition (difference screenwidth 147) 0))) (declare\: donteval@load donteval@compile (loadmenuitems "System-Aids" (((sysload from lispusers) "VStats") (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|)))) (((sysload from lispusers) |Storage|) (showstorage (quote item))))))) (rpaq? vstats.clock.interval 0) (rpaq? vstats.mutil.interval nil) (rpaq? vstats.position (createposition (difference screenwidth 147) 0)) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) "VStats")) (quote (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|))))) (|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) |Storage|)) (quote (showstorage (quote item)))) ) (* |;;| "Display control") (rpaqq screen-setup-init-commands ((declare\: donteval@load donteval@compile (vars (windowtitleshade grayshade)) (files (sysload noerror from "{FS8:PARC:XEROX}Lisp>Users>") "BITMAP-GALLERY" "GRANITE") (initvars (\\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal))))) (p (eval-at-greet (cl:when \\rearrange-screen (cl:when (cl:fboundp (quote |GraniteBG|)) (|GraniteBG|)) (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height))))))) (initvars (\\load-grid-icons t) (enforce.icon.grid t)) (p (eval-at-greet (cl:when \\load-grid-icons (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100))))))) (declare\: donteval@load donteval@compile (rpaq windowtitleshade grayshade) (filesload (sysload noerror from "{FS8:PARC:XEROX}Lisp>Users>") "BITMAP-GALLERY" "GRANITE") (rpaq? \\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal)))) (eval-at-greet (cl:when \\rearrange-screen (cl:when (cl:fboundp (quote |GraniteBG|)) (|GraniteBG|)) (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height)))))) (rpaq? \\load-grid-icons t) (rpaq? enforce.icon.grid t) (eval-at-greet (cl:when \\load-grid-icons (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100))) ) (rpaqq rooms-init-commands ((declare\: donteval@load donteval@compile (initvars (user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>"))) (roomsdirectories (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{Pogo:AISNorth:XEROX}Medley>Sources>"))) (roomsusersdirectories (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Users>" "{NB:PARC:XEROX}Lyric>Users>" "{Pogo:AISNorth:XEROX}Medley>Users>" "{Pogo:AISNorth:XEROX}Lyric>Users>")))) (loadmenuitems "Screen-Maintanance" (((sysload from rooms) "ROOMS") (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" "WallPaper"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility))))))))))))) (declare\: donteval@load donteval@compile (rpaq? user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>"))) (rpaq? roomsdirectories (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{Pogo:AISNorth:XEROX}Medley>Sources>"))) (rpaq? roomsusersdirectories (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Users>" "{NB:PARC:XEROX}Lyric>Users>" "{Pogo:AISNorth:XEROX}Medley>Users>" "{Pogo:AISNorth:XEROX}Lyric>Users>"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from rooms) "ROOMS")) (quote (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" "WallPaper"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility)))))))))) ) (rpaqq change-background-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{piglet/n}colab>faces>") "Dead") (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (cl:mapcar (cl:function (cl:lambda (bm) (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) bitmaps)) (\\\,@ (cl:mapcar (cl:function car) menu-items)) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image))))))))))))))))))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{piglet/n}colab>faces>") "Dead")) (quote (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (cl:mapcar (cl:function (cl:lambda (bm) (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) bitmaps)) (\\\,@ (cl:mapcar (cl:function car) menu-items)) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image)))))))))))))))) ) (rpaqq display-control-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems "Screen-Maintanance" (((sysload from lispusers) "WDWHacks")) (((sysload from lispusers) "Turbo-Windows")) (((sysload from lispusers) "Solid-Movew")) (((sysload from lispusers) "NSDisplaySizes")) (((sysload from lispusers) "SNAPW-ICON")))))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "WDWHacks"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Turbo-Windows"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Solid-Movew"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "NSDisplaySizes"))) (|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "SNAPW-ICON"))) ) (rpaqq idle-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems "IdlePatterns" (((sysload from lispusers) "IdleHax")) (((sysload from lispusers) "IdleDrain") (/listput idle.profile (quote displayfn) (quote idle-drain))) (((sysload from lispusers) "ReadBrush")) (((sysload from "{nb:}Andes>Users>") "Bouncing-Face")) (((sysload from lispusers) "StarBG") (/listput idle.profile (quote displayfn) (quote |Cosmos|))) (((sysload from lispusers) "Pac-Man-Idle") (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|))) (((sysload from "{QV}Lisp>") "Idle-Cost")) (((sysload) "ScreenPaper") (/listput idle.profile (quote displayfn) (quote screenpaper))) (((sysload from private-lispusers) "Idle-Lyrics") (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics)))) (p (eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil)))))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleHax"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleDrain")) (quote (/listput idle.profile (quote displayfn) (quote idle-drain)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "ReadBrush"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{nb:}Andes>Users>") "Bouncing-Face"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "StarBG")) (quote (/listput idle.profile (quote displayfn) (quote |Cosmos|)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "Pac-Man-Idle")) (quote (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{QV}Lisp>") "Idle-Cost"))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload) "ScreenPaper")) (quote (/listput idle.profile (quote displayfn) (quote screenpaper)))) (|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from private-lispusers) "Idle-Lyrics")) (quote (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics)))) (eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil)) ) (rpaqq clock-init-commands ((initvars (biclockinitialprops (quote (horizontal left vertical bottom size 95)))) (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) biclock) (loadmenuitems nil (((sysload from lispusers) "Crock") (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow))))))) (rpaq? biclockinitialprops (quote (horizontal left vertical bottom size 95))) (declare\: donteval@load donteval@compile (filesload (sysload noerror from lispusers) biclock) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Crock")) (quote (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow)))) ) (* |;;| "Programming stuff") (rpaqq programming-init-commands ((functions notice) (functions make) (functions oam) (commands "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY") (declare\: donteval@load donteval@compile (p (eval-at-greet (selectq (machinetype) (dorado (metashift t)) nil) (sedit:reset) (filesload (sysload from lispusers) "sedit-profile"))) (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers"))) (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval"))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "CL-TTYEdit")))) (declare\: donteval@load donteval@compile (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "New-Where-Is"))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Checkpoint"))) (initvars (\spy.button.pos nil)) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) spy) (spy.button \spy.button.pos))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "GraphCalls"))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Manager"))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "PP-Code-File")) (((sysload from lispusers) "PrettyFileIndex"))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "TExec"))) (* |;;| "(loadmenuitems \"ProgrammingAids\" (((sysload from \"{Phylum}rcw>\") \"OSS\")))") (loadmenuitems nil (((sysload from lispusers) "Plot")))) (declare\: donteval@load donteval@compile (p (|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge"))))))))) (cl:defun notice (&rest files) (cl:labels ((canonocal-filemanager-name (path) "Return the canonical FileManager name of a file" (cl:intern (cl:string-upcase (cl:pathname-name path)) (cl:find-package "IL"))) (find-source-file (file-name &optional (search-path-list directories)) "Return the full pathname of the source file" (or (cl:probe-file file-name) (let ((original-source-file-name (cdr (cl:first (get (canonocal-filemanager-name (pathname file-name)) (quote filedates)))))) (cl:if original-source-file-name (cl:probe-file original-source-file-name) nil)) (cl:find-if (cl:function cl:probe-file) (cl:mapcar (cl:function (cl:lambda (dir) (cl:merge-pathnames file-name dir))) search-path-list)))) (file-noticed-p (path) "Has the file been noticed?" (cl:member (canonocal-filemanager-name path) filelst :test (quote eq))) (file-loaded-p (path) "Has the file been loaded?" (not (null (get (canonocal-filemanager-name path) (quote filedates))))) (notice-file (path) "Notice the file" (load path (quote prop)))) (let ((alread-noticed-files nil) (not-loaded-files nil) (noticed-files nil) (not-found-files nil)) (cl:mapc (cl:function (cl:lambda (file) (let ((pathname (find-source-file file))) (cond ((null pathname) (cl:push file not-found-files)) ((file-noticed-p pathname) (cl:push pathname alread-noticed-files)) ((file-loaded-p pathname) (loadfrom pathname nil (quote prop)) (cl:push pathname noticed-files)) (t (cl:push pathname not-loaded-files)))))) files) (cl:values noticed-files alread-noticed-files not-loaded-files not-found-files)))) (cl:defun make (files) (let ((files (or files (cl:remove-if-not (cl:function (cl:lambda (file-name) (cdr (get file-name (quote file))))) filelst))) (original-dir *default-pathname-defaults*) file-dir roopt-file) (cl:unwind-protect (cl:dolist (file files) (cl:setq roopt-file (cl:pathname-name file)) (cl:setq roopt-file (cl:typecase roopt-file (string (cl:intern (cl:string-upcase roopt-file) (cl:find-package "IL"))) (cl:symbol (cl:intern (cl:symbol-name roopt-file) (cl:find-package "IL"))))) (cndir (cl:if (get roopt-file (quote filedates)) (let ((file-dir (unpackfilename.string (cdr (cl:first (get roopt-file (quote filedates))))))) (packfilename.string (quote host) (cl:getf file-dir (quote host)) (quote device) (cl:getf file-dir (quote device)) (quote directory) (cl:getf file-dir (quote directory)))) original-dir)) (cl:when (cl:funcall (quote cleanup) roopt-file) (cl:load (packfilename.string (quote name) roopt-file (quote extension) "dfasl")))) (cndir original-dir)))) (cl:defun oam (form) (compiler:optimize-and-macroexpand-1 form (compiler:make-empty-env) (compiler:make-context))) (defcommand "BREAK" (&rest fns) "Set a breakpoint on the named functions." (eval (bquote (break (\\\,@ fns))))) (defcommand "UNBREAK" (&rest fns) "Remove a breakpoint from the named functions." (eval (bquote (unbreak (\\\,@ fns))))) (defcommand "CALLS" (fn) "Print out information about what the function calls." (cond ((not (cl:fboundp fn)) (cl:format t "~%~S has no function definition" fn)) ((cl:macro-function fn) (cl:format t "~%~S is a macro" fn)) ((cl:special-form-p fn) (cl:format t "~%~S is a special-form" fn)) (t (destructuring-bind (calls binds uses-free uses-global) (calls fn) (cl:format t "~%--- ~S ---" fn) (let ((format-string "~%~A:~{ ~S~}")) (cl:when (not (null calls)) (cl:format t format-string "CALLS" calls)) (cl:when (not (null binds)) (cl:format t format-string "BINDS" binds)) (cl:when (not (null uses-free)) (cl:format t format-string "SPECIALS USED" uses-free)) (cl:when (not (null uses-global)) (cl:format t format-string "GLOBALS USED" uses-global)))))) (cl:values)) (defcommand "DESCRIBE" (&rest objects) "Describe the named objects." (cl:mapc (cl:function (cl:lambda (x) (cl:format t "~&-- ~A --" x) (cl:describe x))) objects) (cl:values)) (defcommand "EC" (form) "Evaluate a compiled version of the form" (cl:funcall (prog2 (cl:format t "~%Compiling...") (cl:compile nil (bquote (cl:lambda nil (\\\, form)))) (cl:format t "done.~%")))) (defcommand "EFF" (&rest patterns-commands) "Edit any uses of any of the patterns on any noticed file. Args are ..patterns - ..edit comands." (let* ((position (cl:position "-" patterns-commands :key (cl:function (lambda (pattern) (if (cl:symbolp pattern) then (cl:symbol-name pattern) else ""))) :test (cl:function string-equal))) (patterns (if (null position) then patterns-commands else (cl:butlast patterns-commands (- (length patterns-commands) position)))) (edit-commands (if position then (cl:subseq patterns-commands (1+ position)) else nil))) (case (cl:length patterns) (0 nil) (1 (editfromfile nil nil (cl:first patterns) edit-commands)) (cl:otherwise (editfromfile nil nil (bquote (*any* (\\\,@ patterns))) edit-commands)))) (cl:values)) (defcommand "FILES?" nil "Tell you about what source files need to be dumped." (files?) (cl:values)) (defcommand "IC" (fn) "Inspect the code for the function." (inspectcode (if (cl:symbolp fn) then (if (ccodep (getd fn)) then fn else (cl:compile nil (getd fn))) else (cl:compile nil (if (cl:member (car fn) (quote (cl:lambda lambda)) :test (cl:function eq)) then fn else (bquote (cl:lambda nil (\\\, fn))))))) (cl:values)) (defcommand "NOTICE" (&rest files) "Notice a set of files, so things on them can be edited" (cl:flet ((tell-user (files msg) (cl:when files (cl:format t "~%~A" msg) (cl:mapcar (cl:function (cl:lambda (path) (cl:format t "~%~5T~A" (cl:pathname-name path)))) files)))) (cl:multiple-value-bind (just-noticed previously-noticed not-loaded not-found) (cl:apply (cl:function notice) files) (tell-user just-noticed "Noticed files") (tell-user previously-noticed "Previously noticed files") (tell-user not-loaded "Not loaded, so not noticed files") (tell-user not-found "Could not find files")) (cl:values))) (defcommand "MAKE" (&rest files) "Save, recompile, and reload the files." (make files) (cl:values)) (defcommand "SPY" (form) (cl:unwind-protect (progn (spy.start) (prog1 (cl:eval form) (spy.end))) (spy.end) (spy.tree))) (declare\: donteval@load donteval@compile (eval-at-greet (selectq (machinetype) (dorado (metashift t)) nil) (sedit:reset) (filesload (sysload from lispusers) "sedit-profile")) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "CL-TTYEdit"))) ) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "New-Where-Is"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Checkpoint"))) (rpaq? \spy.button.pos nil) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) spy)) (quote (spy.button \spy.button.pos))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "GraphCalls"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Manager"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PP-Code-File"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PrettyFileIndex"))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "TExec"))) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Plot"))) ) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge"))))) ) (rpaqq old-utils-commands ((fns |DebugMode|) (fns selectw) (functions de file) (usermacros de ee fv) (fns |PrintDocFile|) (fns |\\Pick-One-At-Random|) (functions |PickOneAtRandom|) (fns |GoodNight| |NewLisp|) (fns |RememberLastPartition| |RememberLispState|) (declare\: donteval@load donteval@compile (addvars (beforelogoutforms (|RememberLispState|) (|RememberLastPartition|)))))) (defineq (|DebugMode| (lambda (debug-on-p all-execs-p) (* \; "Edited 25-Jan-88 08:19 by smL") (|if| debug-on-p |then| (setq nlsetqgag nil) (setq helpflag break!) (|if| all-execs-p |then| (putassoc 'helpflag (list 'break!) *per-exec-variables*)) |else| (setq nlsetqgag t) (setq helpflag t) (|if| all-execs-p |then| (putassoc 'helpflag (list t) *per-exec-variables*))))) ) (defineq (selectw (lambda nil (* \; "Edited 15-Jan-88 09:17 by smL") (* |;;;| "Let the user select a window") (|first| (clrprompt) (|printout| promptwindow "Move mouse to desired window." t "Then press down the CTRL key or click mouse") |until| (or (keydownp 'ctrl) (not (mousestate up))) |do| nil |finally| (getmousestate) (clrprompt) (return (whichw))))) ) (defmacro de (|fn-name| |arg-list| &rest |body|) (* |;;;| "Shorthand for defineing functions") (bquote (defineq ((\\\, |fn-name|) (\\\, |arg-list|) (\\\,@ |body|))))) (defmacro file (|file-name| &rest |file-package-commands|) (* |;;;| "Allows one to create a file giving the commands explicitly e.g. - (FILE FOO (VARS * FUMVARS) (FNS * FNSLIST)) - will create FOOCOMS and make file FOO") (let ((|real-file-name| (u-case |file-name|))) (bquote (progn (\\\, (|if| (null |file-package-commands|) |then| nil |elseif| (and (litatom (car |file-package-commands|)) (null (cdr |file-package-commands|))) |then| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (getatomval (quote (\\\, (car |file-package-commands|)))))) |else| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (quote (\\\, |file-package-commands|)))))) (resetform (radix 10) (makefile (quote (\\\, |real-file-name|)))))))) (addtovar usermacros (de nil (comsq (bi 1 -1) (e (dedite (\## 1)) t) (bo 1))) (ee (dummy) (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (ee nil (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (fv nil (e (freevars (\## (orr (up 1) nil)) t)))) (addtovar editcomsa de ee) (addtovar editcomsl ee) (defineq (|PrintDocFile| (lambda (utility-name print-server) (* \; "Edited 17-Mar-88 16:24 by smL") (* |;;;| "Print out the documentation file for the named package") (setq print-server (or print-server (car defaultprintinghost))) (cl:flet ((find-doc-source-file nil (or (findfile (packfilename 'name utility-name 'extension 'tedit) nil directories) (findfile (packfilename 'name utility-name 'extension 'ted) nil directories) (findfile (packfilename 'name utility-name 'extension 'txt) nil directories) (findfile (packfilename 'name utility-name 'extension 'doc) nil directories)))) (|if| (eq print-server t) |then| (let ((doc-file (find-doc-source-file))) (|if| doc-file |then| (tedit doc-file) |else| "No doc file found")) |elseif| print-server |then| (let ((doc-file (or (findfile (packfilename 'name utility-name 'extension (selectq (printertype print-server) ((press fullpress) 'press) (interpress 'ip) (help "Unknown printer type!"))) nil directories) (find-doc-source-file)))) (|if| doc-file |then| (add.process `(empress ',doc-file nil ',print-server)) (concat "Printing file " doc-file " on printer " print-server) |else| "No doc file found")) |else| "No printer specified")))) ) (defineq (|\\Pick-One-At-Random| (lambda (|list|) (* \; "Edited 15-Jan-88 09:20 by smL") (* |;;;| "Return a random element of the list") (resetlst (resetsave (randset t) `(randset ,(randset))) (car (nth |list| (rand 1 (length |list|))))))) ) (defmacro |PickOneAtRandom| (&rest |elements|) (bquote (|\\Pick-One-At-Random| (quote (\\\, (mapcar |elements| (quote eval))))))) (defineq (|GoodNight| (lambda (|flag| |altoCommandString|) (* |smL| "20-Sep-85 14:43") (let ((|stream| (openstream '{dsk}rem.cm\;1 'output 'old/new))) (prin1 (or |altoCommandString| "Q") |stream|) (terpri |stream|) (closef |stream|)) (logout |flag|))) (|NewLisp| (lambda nil (* \; "Edited 15-Jan-88 09:20 by smL") (* |;;;| "Start up a new system, assuming that {DSK}KEY1.CM starts one up.") (|if| (mouseconfirm "Do you really want to start up a new system?") |then| (|GoodNight| t "@KEY1.CM")))) ) (defineq (|RememberLastPartition| (lambda nil (* \; "Edited 15-Jan-88 09:21 by smL") (* |;;;| "Sets up the KEY3 CM file in the last partition (19 or 5) to put you back in this partition.") (selectq (machinetype) (dorado (|for| |partitionNumber| |in| '(19 5) |bind| |stream| |key3File| |eachtime| (setq |key3File| (concat "{DSK" |partitionNumber| "}KEY3.CM;1")) (setq |stream| (car (nlsetq (getstream |key3File|)))) (and |stream| (closef? |stream|)) (setq |stream| (car (nlsetq (openstream |key3File| 'output 'old/new)))) |thereis| (streamp |stream|) |finally| (|if| (and (streamp |stream|) (openp |stream|)) |then| (|printout| |stream| "// " "This will set you back in your last used partition, " firstname t "// [last used " (date) "]" t "Par " (diskpartition) t) (closef |stream|)))) nil))) (|RememberLispState| (lambda nil (* \; "Edited 15-Jan-88 09:21 by smL") (* |;;;| "Make KEY2.CM restart this lisp if the logout was not FAST...") (nlsetq (|if| (and (stkpos 'logout) (eq (machinetype) 'dorado)) |then| (|if| (nlsetq (getstream '{dsk}key2.cm\;1)) |then| (closef? (getstream '{dsk}key2.cm\;1))) (resetlst (let ((logout-arg (stkarg 1 'logout)) (stream (openstream '{dsk}key2.cm\;1 'output 'old/new))) (resetsave nil (list (function closef?) stream)) (|printout| stream "// You did a (LOGOUT") (selectq logout-arg (nil nil) (|printout| stream " " logout-arg)) (|printout| stream ") last time [" (date) "], so this will ") (selectq logout-arg ((nil ?) (|printout| stream "restart your old")) (|printout| stream "start a new")) (|printout| stream " LISP, " firstname t) (selectq logout-arg ((nil ?) (|printout| stream "Lisp") (|if| (eqp (realmemorysize) 21845) |then| (|printout| stream " 52525/c"))) (|printout| stream "@KEY1.CM")) (|printout| stream t))))))) ) (declare\: donteval@load donteval@compile (addtovar beforelogoutforms (|RememberLispState|) (|RememberLastPartition|)) ) (rpaqq wizard-init-commands ((functions atom-neighbors))) (cl:defun atom-neighbors (cl:symbol &optional (xcl-user::number-of-neighbors 8)) (cl:if (cl:symbolp cl:symbol) (let ((xcl-user::atom-number (\\loloc cl:symbol)) (xcl-user::neighbors (list cl:symbol))) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (+ xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) (cl:setf xcl-user::neighbors (cl:nreverse xcl-user::neighbors)) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (- xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) xcl-user::neighbors) "Not a symbol")) (rpaqq dinfo-init-commands ((declare\: donteval@load donteval@compile (vars (irm.host&dir (cond ((infilep "{DSK}HELPSYS>IRMTOP.TEDIT") "{DSK}HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}Lyric>LispUsers>IRM>"))) (dinfomodes (quote (graph)))) (initvars (irm.font (fontcreate (quote (helvetica 10)))) (irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2))))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "DInfo" "Helpsys") (dinfo (irm.get.dinfograph t) irmwindowregion)) (((sysload from lispusers) "LispNerd")))))) (declare\: donteval@load donteval@compile (rpaq irm.host&dir (cond ((infilep "{DSK}HELPSYS>IRMTOP.TEDIT") "{DSK}HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}Lyric>LispUsers>IRM>"))) (rpaqq dinfomodes (graph)) (rpaq? irm.font (fontcreate (quote (helvetica 10)))) (rpaq? irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2)))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "DInfo" "Helpsys")) (quote (dinfo (irm.get.dinfograph t) irmwindowregion))) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "LispNerd"))) ) (rpaqq pcl-init-commands ((initvars (pcldirectories (bquote ((\\\,@ *cache-directories*) (\\\, (if (eq (machinetype) (quote maiko)) then "{dsk}pcl>medley>" else "{pooh/n}pcl>medley>")) "{NB:PARC:XEROX}MEDLEY>")))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL"))))))))) (rpaq? pcldirectories (bquote ((\\\,@ *cache-directories*) (\\\, (if (eq (machinetype) (quote maiko)) then "{dsk}pcl>medley>" else "{pooh/n}pcl>medley>")) "{NB:PARC:XEROX}MEDLEY>"))) (declare\: donteval@load donteval@compile (eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL"))))) ) (rpaqq loops-init-commands ((initvars (loopsdirectories (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{POGO:AISNorth:XEROX}SYSTEM>"))) (\\loops-init-form (quote (progn (filesload (noerror from "{EG:PARC:XEROX}Loops>") initloops))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form)))))))) (rpaq? loopsdirectories (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}Medley>Sources>" "{POGO:AISNorth:XEROX}SYSTEM>"))) (rpaq? \\loops-init-form (quote (progn (filesload (noerror from "{EG:PARC:XEROX}Loops>") initloops)))) (declare\: donteval@load donteval@compile (eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form)))) ) (* |;;| "Documentation") (rpaqq tedit-init-commands ((functions load-nova-fonts) (declare\: donteval@load donteval@compile (vars (tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t)) (tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A"))))))))) (p (eval-at-greet (cl:when (getd (quote tedit)) (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo))))) (loadmenuitems "WritingAids" (((sysload from lispusers) "ProofReader")) (((sysload from lispusers) "TMAX")) (((sysload from lispusers) "DictTool")) (((sysload from lispusers) "TEditDoradoKeys")) (((sysload from lispusers) "EditKeys")) (((sysload from lispusers) "VirtualKeyboards") (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file)))) (((sysload from lispusers) "KeyboardEditor")) (((sysload from lispusers) "Equations" "Sketch")) (((sysload from lispusers) "NovaFont") (load-nova-fonts))) (coms (initvars (docobjectsmenufont menufont)) (alists (imageobjgetfns docobj-filestamp-getfn docobj-timestamp-getfn docobj-include-getfn)) (loadmenuitems "WritingAids" (((sysload from lispusers) "Doc-Objects"))))))) (cl:defun load-nova-fonts nil (let ((nova-font-host "Starfile Public:Parc:Xerox") (nova-fonts-to-load (quote ("VP Optima XSG Fonts>OptimaItalic" "VP Optima XSG Fonts>OptimaMedium"))) (nova-fonts-to-notice (quote ("Xerox Logo Fonts>XeroxLogo" "Xerox VP Quartz Fonts!2>QuartzBIR" "Xerox VP Quartz Fonts!2>QuartzBRR" "Xerox VP Quartz Fonts!2>QuartzMIR" "Xerox VP Quartz Fonts!2>QuartzMRR")))) (cl:flet ((find-nova-font (font) "Find the Novafont file" (cl:probe-file (cl:make-pathname :host nova-font-host :type "NovaFont" :defaults font)))) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Loading Novafont ~A" (cl:pathname-name font-file)) (load-novafont-file font-file) (notice-novafont-file font-file))))) nova-fonts-to-load) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Noticing Novafont ~A" (cl:pathname-name font-file)) (notice-novafont-file font-file))))) nova-fonts-to-notice))) (cl:mapc (cl:function (cl:lambda (item) (cl:pushnew item tedit.known.fonts :test (quote cl:equal)))) (quote (("XeroxLogo" (quote xeroxlogo)) ("Quartz" (quote quartz)) ("Optima" (quote optima)))))) (declare\: donteval@load donteval@compile (rpaq tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t)) (rpaq tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A")))))))) (eval-at-greet (cl:when (getd (quote tedit)) (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "ProofReader"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TMAX"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "DictTool"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TEditDoradoKeys"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "EditKeys"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "VirtualKeyboards")) (quote (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file))))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "KeyboardEditor"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Equations" "Sketch"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "NovaFont")) (quote (load-nova-fonts))) (rpaq? docobjectsmenufont menufont) (addtovar imageobjgetfns (docobj-filestamp-getfn file doc-objects) (docobj-timestamp-getfn file doc-objects) (docobj-include-getfn file doc-objects)) (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Doc-Objects"))) ) (rpaqq sketch-init-commands ((alists (imageobjgetfns skio.getfn skio.getfn.2)) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from lispusers) "Sketch")))))) (addtovar imageobjgetfns (skio.getfn) (skio.getfn.2 file sketch)) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Sketch"))) ) (rpaqq notecards-init-commands ((initvars (|NC.NoteCardsIconPosition| (createposition 891 2)) (ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil))) (notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}1.3L>" "{NB:PARC:XEROX}1.3L>")))) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from notecards) "NoteCards") (|NoteCards| |NC.NoteCardsIconPosition|)))))) (rpaq? |NC.NoteCardsIconPosition| (createposition 891 2)) (rpaq? ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil))) (rpaq? notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}1.3L>" "{NB:PARC:XEROX}1.3L>"))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from notecards) "NoteCards")) (quote (|NoteCards| |NC.NoteCardsIconPosition|))) ) (* |;;| "Communication & Info") (rpaqq mail-init-commands ((vars (*new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder))))) (declare\: donteval@load donteval@compile (vars (defaultmailfoldername (quote active.mail)) (lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>")) (lafitehardcopybatchflg t) (lafitemovetoconfirmflg (quote left)) (lafiteshowmodeflg (quote always)) (lafitebrowserregion (createregion 360 5 650 165)) (lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175)))) (lafitestatuswindowposition (createposition 100 45)) (lafitemodedefault (or lafitemodedefault (quote gv)))) (vars (lafite.dont.display.headers (quote ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References" "GVGV"))) (lafite.dont.forward.headers lafite.dont.display.headers) (lafite.dont.hardcopy.headers lafite.dont.display.headers)) (loadmenuitems "MailTools" (((sysload from lispusers) "LafiteTimedDelete")) (((sysload from lispusers) "LafiteFind")) (((sysload from lispusers) "Maintain")) (((sysload from lispusers) "NSMaintain")) (((sysload from lispusers) "MailScavenge")) (((sysload from lispusers) "Undigestify")) (((from lispusers) "Lafite-Indent")) (((sysload from lispusers) "MailShare")) (((sysload from "{QV}Lisp>") "LafiteFolderIcon")) (((sysload from "{ERIS}Sources>") "AppendMail"))) (p (eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{fs8:}Lisp>") "Short-Lafite-Header"))))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (if *new-lafite-p* then (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg"))))) (initvars (lafitedldirectories nil)) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL"))))))) (p (eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{fs8:}Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv))))) (coms (initvars (\\use-lens? nil) (user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail"))))))) (vars (user::lens-loader-dir (if (or *new-lafite-p* (eq user::lens-loader-dir :next)) then "{NB:PARC:Xerox}Next>" else "{NB:PARC:Xerox}Current>"))) (p (eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (cl:load (cl:make-pathname :name "Common-Lens" :defaults user::lens-loader-dir))) (t (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "Common-Lens")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on))))))))) (initvars (\\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber)))) (p (eval-at-greet (cond ((not (getd (quote lafite))) nil) ((not \\turn-on-mailer) nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (lafite (quote on)))))))) (rpaq *new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder)))) (declare\: donteval@load donteval@compile (rpaqq defaultmailfoldername active.mail) (rpaq lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>")) (rpaqq lafitehardcopybatchflg t) (rpaqq lafitemovetoconfirmflg left) (rpaqq lafiteshowmodeflg always) (rpaq lafitebrowserregion (createregion 360 5 650 165)) (rpaq lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175)))) (rpaq lafitestatuswindowposition (createposition 100 45)) (rpaq lafitemodedefault (or lafitemodedefault (quote gv))) (rpaqq lafite.dont.display.headers ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References" "GVGV")) (rpaq lafite.dont.forward.headers lafite.dont.display.headers) (rpaq lafite.dont.hardcopy.headers lafite.dont.display.headers) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteTimedDelete"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteFind"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Maintain"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "NSMaintain"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailScavenge"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Undigestify"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((from lispusers) "Lafite-Indent"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailShare"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{QV}Lisp>") "LafiteFolderIcon"))) (|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{ERIS}Sources>") "AppendMail"))) (eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{fs8:}Lisp>") "Short-Lafite-Header"))))) ) (declare\: donteval@load donteval@compile (eval-at-greet (if *new-lafite-p* then (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg"))) ) (rpaq? lafitedldirectories nil) (declare\: donteval@load donteval@compile (eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL"))))) ) (eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{fs8:}Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv)))) (rpaq? \\use-lens? nil) (rpaq? user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail")))))) (rpaq user::lens-loader-dir (if (or *new-lafite-p* (eq user::lens-loader-dir :next)) then "{NB:PARC:Xerox}Next>" else "{NB:PARC:Xerox}Current>")) (eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (cl:load (cl:make-pathname :name "Common-Lens" :defaults user::lens-loader-dir))) (t (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "Common-Lens")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on))))))) (rpaq? \\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber))) (eval-at-greet (cond ((not (getd (quote lafite))) nil) ((not \\turn-on-mailer) nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (lafite (quote on))))) (rpaqq chat-init-commands ((declare\: donteval@load donteval@compile (alists (networkloginfo lily symbolics)) (vars (chat.allhosts (sort (cl:remove-duplicates (bquote ((\\\,@ chat.allhosts) |IBID FS:PARC:XEROX| |PARC CHS:PARC:XEROX| erinyes eris phylum qv (\\\,@ (|for| host |in| defaultprintinghost |when| (eq (printertype host) (quote interpress)) |collect| host)))) :test (cl:function string-equal)))) (closechatwindowflg t) (chat.window.size (let ((n-chars-wide 80) (n-chars-high 24)) (cons (min (quotient (times screenwidth 2) 3) (widthifwindow (times n-chars-wide (stringwidth "A" chat.font)))) (min (quotient (times screenheight 2) 3) (heightifwindow (times n-chars-high (fontprop chat.font (quote height))) t))))) (defaultchathost (filenamefield loginhost/dir (quote host)))) (loadmenuitems nil (((sysload from lispusers) "TCPChat")))))) (declare\: donteval@load donteval@compile (addtovar networkloginfo (lily (login "l" username cr password cr)) (symbolics (login))) (rpaq chat.allhosts (sort (cl:remove-duplicates (bquote ((\\\,@ chat.allhosts) |IBID FS:PARC:XEROX| |PARC CHS:PARC:XEROX| erinyes eris phylum qv (\\\,@ (|for| host |in| defaultprintinghost |when| (eq (printertype host) (quote interpress)) |collect| host)))) :test (cl:function string-equal)))) (rpaqq closechatwindowflg t) (rpaq chat.window.size (let ((n-chars-wide 80) (n-chars-high 24)) (cons (min (quotient (times screenwidth 2) 3) (widthifwindow (times n-chars-wide (stringwidth "A" chat.font)))) (min (quotient (times screenheight 2) 3) (heightifwindow (times n-chars-high (fontprop chat.font (quote height))) t))))) (rpaq defaultchathost (filenamefield loginhost/dir (quote host))) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "TCPChat"))) ) (rpaqq talk-init-commands ((initvars (talk.default.region (createregion 575 0 500 500))) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "Talk")))) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload compiled from lispusers) "Finger"))) (* |;;| "(loadmenuitems nil (((sysload compiled from \"{PHYLUM}Lisp>\") \"Fing\") (fingw)))")))) (rpaq? talk.default.region (createregion 575 0 500 500)) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Talk"))) ) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload compiled from lispusers) "Finger"))) ) (rpaqq calendar-init-commands ((initvars (caldaydefaultregion (createregion 32 200 375 100)) (caldefaultalertdelta -10) (caldefaulthost&dir (concat |\\UserHomeDirectory| "CALENDAR>")) (calfont (fontcreate (quote (helvetica 18)))) (calupdateonshrinkflg t) (calkeepexpiredrems t)) (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "Calendar") (progn (calloadfile "CalReminders") (let ((file (findfile "Calmanac88" t lispusersdirectories))) (cl:when file (calloadfile file))) (calendar (quote thisyear)))))))) (rpaq? caldaydefaultregion (createregion 32 200 375 100)) (rpaq? caldefaultalertdelta -10) (rpaq? caldefaulthost&dir (concat |\\UserHomeDirectory| "CALENDAR>")) (rpaq? calfont (fontcreate (quote (helvetica 18)))) (rpaq? calupdateonshrinkflg t) (rpaq? calkeepexpiredrems t) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Calendar")) (quote (progn (calloadfile "CalReminders") (let ((file (findfile "Calmanac88" t lispusersdirectories))) (cl:when file (calloadfile file))) (calendar (quote thisyear))))) ) (rpaqq printer-init-commands ((initvars (printermenu.position (createposition (difference screenwidth 125) 5))) (loadmenuitems nil (((sysload from lispusers) "PrinterMenu") (printermenu))) (loadmenuitems nil (((sysload from lispusers) "HGraph"))) (loadmenuitems nil (((sysload from lispusers) "Hardcopy-Tab-Patch"))))) (rpaq? printermenu.position (createposition (difference screenwidth 125) 5)) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "PrinterMenu")) (quote (printermenu))) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "HGraph"))) (|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Hardcopy-Tab-Patch"))) (rpaqq db-init-commands ((initvars (|*Address-Book-Pos*| (createposition 19 181)) (|*Phone-Directory-Pos*| (createposition 19 181))) (addvars (phonelistfiles "{PIGLET/N}KSA>ROLODEX.TEDIT")) (loadmenuitems nil (((from lispusers) "Phone-Directory")) (((from lispusers) "AddressBook"))) (loadmenuitems "WritingAids" (((from lispusers) "Find-Citation"))) (p (if (and (eq (machinetype) (quote maiko)) (null (cl:find-package "RPC2"))) then (|AddLoadMenuItem| nil (quote ((from "{hulk:}lisp>") "System33" "RPC"))))))) (rpaq? |*Address-Book-Pos*| (createposition 19 181)) (rpaq? |*Phone-Directory-Pos*| (createposition 19 181)) (addtovar phonelistfiles "{PIGLET/N}KSA>ROLODEX.TEDIT") (|AddLoadMenuItem| (quote nil) (quote ((from lispusers) "Phone-Directory"))) (|AddLoadMenuItem| (quote nil) (quote ((from lispusers) "AddressBook"))) (|AddLoadMenuItem| (quote "WritingAids") (quote ((from lispusers) "Find-Citation"))) (if (and (eq (machinetype) (quote maiko)) (null (cl:find-package "RPC2"))) then (|AddLoadMenuItem| nil (quote ((from "{hulk:}lisp>") "System33" "RPC")))) (rpaqq nfs-init-commands ((loadmenuitems "FileAids" (((sysload from "{NB:PARC:XEROX}") "PARC-NFS"))) (p (eval-at-greet (cl:push (quote ("Reset NFS" (quote (cl:funcall (cl:intern "RESET-NFS-CACHE-VARS" (cl:find-package "RPC2")))) "Clear all NFS cache variables")) |BackgroundMenuCommands|))))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from "{NB:PARC:XEROX}") "PARC-NFS"))) (eval-at-greet (cl:push (quote ("Reset NFS" (quote (cl:funcall (cl:intern "RESET-NFS-CACHE-VARS" (cl:find-package "RPC2")))) "Clear all NFS cache variables")) |BackgroundMenuCommands|)) (* |;;| "Files") (rpaqq file-watch-init-commands ((declare\: donteval@load donteval@compile (initvars (|FW-Properties| (bquote (font (gacha 8) all-files? nil position (\\\, (createposition screenwidth (cl:if (and (boundp (quote *who-line*)) (windowp *who-line*)) (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) screenheight))) anchor top-right shade (\\\, grayshade) interval 1000 filters ("{IE:PARC:XEROX}MEDLEY>SYSTEM.HASH" "{DSK1}SYSDIR" "{CORE}<*>ROLODEX.*" "{CORE}<*>*PHONE*.TXT"))))) (loadmenuitems "FileAids" (((sysload from lispusers) "FileWatch") (filewatch)))))) (declare\: donteval@load donteval@compile (rpaq? |FW-Properties| (bquote (font (gacha 8) all-files? nil position (\\\, (createposition screenwidth (cl:if (and (boundp (quote *who-line*)) (windowp *who-line*)) (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) screenheight))) anchor top-right shade (\\\, grayshade) interval 1000 filters ("{IE:PARC:XEROX}MEDLEY>SYSTEM.HASH" "{DSK1}SYSDIR" "{CORE}<*>ROLODEX.*" "{CORE}<*>*PHONE*.TXT")))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "FileWatch")) (quote (filewatch))) ) (rpaqq file-server-init-commands ((loadmenuitems "FileAids" (((sysload from lispusers) "NSProtection") (nsprotection))) (loadmenuitems "FileAids" (((sysload from lispusers) "ArchiveTool")) (((sysload from lispusers) "ArchiveBrowser")) (((sysload from lispusers) "NSAllocation"))))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "NSProtection")) (quote (nsprotection))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "ArchiveTool"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "ArchiveBrowser"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "NSAllocation"))) (rpaqq dirgrapher-init-commands ((initvars (dg.file-info-attributes fb.default.info) (dg.default-dir |\\UserHomeDirectory|) (dg.vertical-horizontal-option (quote horizontal)) (dg.background-directories (bquote ((\\\, dg.default-dir))))) (declare\: donteval@load donteval@compile (loadmenuitems "FileAids" (((sysload from lispusers) "DirGrapher")))))) (rpaq? dg.file-info-attributes fb.default.info) (rpaq? dg.default-dir |\\UserHomeDirectory|) (rpaq? dg.vertical-horizontal-option (quote horizontal)) (rpaq? dg.background-directories (bquote ((\\\, dg.default-dir)))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "DirGrapher"))) ) (rpaqq fb-init-commands ((declare\: donteval@load donteval@compile (vars (fb.default.info (quote (size creationdate)))) (loadmenuitems "FileAids" (((sysload from lispusers) "Resize-FileBrowser")))))) (declare\: donteval@load donteval@compile (rpaqq fb.default.info (size creationdate)) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "Resize-FileBrowser"))) ) (rpaqq compare-files-init-commands ((loadmenuitems "FileAids" (((sysload from lispusers) "CompareDirectories")) (((sysload from lispusers) "CompareText")) (((sysload from lispusers) "CompareSources"))))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareDirectories"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareText"))) (|AddLoadMenuItem| (quote "FileAids") (quote ((sysload from lispusers) "CompareSources"))) (* |;;| "Random stuff") (rpaqq unix-init-commands ((variables *unix-dir-stack*) (functions do-cd print-directory-stack) (commands "CD" "DIRS" "LS" "POPD" "PUSHD" "PWD") (p (if (eq (machinetype) (quote maiko)) then (|AddLoadMenuItem| nil "UnixChat"))) (loadmenuitems "FileAids" (((from "{fs8:}lisp>") "Grep"))))) (defglobalvar *unix-dir-stack* nil "The directory stack used in the exec commands PUSHD and friends.") (cl:defun do-cd (directory) (if (string-equal directory "..") then (let* ((current (directoryname t)) (parent (substring current 1 (strpos ">" current -2 nil nil nil nil t)))) (cndir parent)) else (cndir directory)) (directoryname t)) (cl:defun print-directory-stack nil (cl:format t "~%~A" (directoryname t)) (for dir in *unix-dir-stack* do (cl:format t " ~A" dir)) (cl:values)) (defcommand "CD" (&optional directory) "Connect to a directory" (do-cd directory) (setq *unix-dir-stack* nil) (cl:format t "~%~A" (directoryname t)) (cl:values)) (defcommand "DIRS" nil "Print out the directory stack used by PUSHD and friends." (print-directory-stack) (cl:values)) (defcommand "LS" (&optional (dirspec "*")) "List files matching the spec" (let ((filing.enumeration.depth 1)) (directory dirspec (quote (p)))) (cl:values)) (defcommand "POPD" (directory) "Connect to the previous directory" (if (null *unix-dir-stack*) then (cl:format t "~%popd: Directory stack empty.") else (do-cd (pop *unix-dir-stack*)) (print-directory-stack)) (cl:values)) (defcommand "PUSHD" (directory) "Connect to a directory, remember the current one on the directory stack." (cl:push (directoryname t) *unix-dir-stack*) (do-cd directory) (print-directory-stack) (cl:values)) (defcommand "PWD" nil "Print out the currently connected directory." (cl:format t "~%~A" (directoryname t)) (cl:values)) (if (eq (machinetype) (quote maiko)) then (|AddLoadMenuItem| nil "UnixChat")) (|AddLoadMenuItem| (quote "FileAids") (quote ((from "{fs8:}lisp>") "Grep"))) (rpaqq demos-init-commands ((initvars (|SlideFiles| (quote ("{piglet/n}ksa>Talks>*.Tedit;")))) (declare\: donteval@load donteval@compile (loadmenuitems "Demos" (((sysload from lispusers) "SlideProjector")) (((sysload from lispusers) "Magnifier")) (((sysload from lispusers) "Big")) (((load from "{piglet/n}ksa>") "Demo")))))) (rpaq? |SlideFiles| (quote ("{piglet/n}ksa>Talks>*.Tedit;"))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "SlideProjector"))) (|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "Magnifier"))) (|AddLoadMenuItem| (quote "Demos") (quote ((sysload from lispusers) "Big"))) (|AddLoadMenuItem| (quote "Demos") (quote ((load from "{piglet/n}ksa>") "Demo"))) ) (rpaqq games-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems "Games" (((from "{fs8:parc:xerox}Lisp>") "BlackBox")) (((from "{FS8:PARC:XEROX}Lisp>") "Go")) (((sysload from lispusers) "Qix") (add.process (quote (qix.grow)))) (((sysload from lispusers) "FaceInvader")) (((sysload from lispusers) "Donz")) (((sysload from lispusers) "Doctor")) (((sysload from lispusers) "Hanoi")) (((sysload from lispusers) "Life")) (((sysload from lispusers) "Solitare")) (((sysload from lispusers) "EyeCon") (eyecon.open)) (((sysload from "{FS8:PARC:XEROX}Lisp>") "RandomWord")))))) (declare\: donteval@load donteval@compile (|AddLoadMenuItem| (quote "Games") (quote ((from "{fs8:parc:xerox}Lisp>") "BlackBox"))) (|AddLoadMenuItem| (quote "Games") (quote ((from "{FS8:PARC:XEROX}Lisp>") "Go"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Qix")) (quote (add.process (quote (qix.grow))))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "FaceInvader"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Donz"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Doctor"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Hanoi"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Life"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "Solitare"))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from lispusers) "EyeCon")) (quote (eyecon.open))) (|AddLoadMenuItem| (quote "Games") (quote ((sysload from "{FS8:PARC:XEROX}Lisp>") "RandomWord"))) ) (* |;;| "Cleanup") (rpaqq background-menu-cleanup-init-commands ((functions move-background-item-under) (declare\: donteval@load donteval@compile (p (eval-at-greet (move-background-item-under "Hardcopy" "Snap") (move-background-item-under "ArchiveTool" "FileBrowser") (/nconc1 |BackgroundMenuCommands| (bquote ("LOGOUT & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT)?") (|GoodNight|))) "Logout of LISP" (subitems ("LOGOUT T & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT T)?") (|GoodNight| t))) "Logout without saving VMem") (\\\,@ (if (eq (machinetype) (quote maiko)) then (quote (("Suspend" (quote (suspend-lisp)) "Suspend the running lisp and return to UNIX"))))))))) (or (for item in |BackgroundMenuCommands| thereis (string-equal "System" (car item))) (/nconc1 |BackgroundMenuCommands| (list "System" nil nil (list (quote subitems))))) (for label in (quote ("SaveVM" "Idle" "AR Edit" "DumpCache" "Set Directories" "LOGOUT & Power-Off" "Reset NFS")) do (move-background-item-under label "System")))) (vars (|BackgroundMenu| nil))))) (cl:defun move-background-item-under (label-to-move parent-label) (let ((item-to-move (for item in |BackgroundMenuCommands| thereis (string-equal label-to-move (car item)))) (parent-item (for item in |BackgroundMenuCommands| thereis (string-equal parent-label (car item))))) (cond ((or (null parent-item) (null item-to-move)) nil) ((null (cdddr parent-item)) (* \; "No subitems yet") (/nconc1 parent-item (bquote (subitems (\\\, item-to-move)))) (/dremove item-to-move |BackgroundMenuCommands|)) (t (* \; "Already has subitems ") (/nconc1 (cadddr parent-item) item-to-move) (/dremove item-to-move |BackgroundMenuCommands|))))) (declare\: donteval@load donteval@compile (eval-at-greet (move-background-item-under "Hardcopy" "Snap") (move-background-item-under "ArchiveTool" "FileBrowser") (/nconc1 |BackgroundMenuCommands| (bquote ("LOGOUT & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT)?") (|GoodNight|))) "Logout of LISP" (subitems ("LOGOUT T & Power-Off" (quote (and (mouseconfirm "Really (LOGOUT T)?") (|GoodNight| t))) "Logout without saving VMem") (\\\,@ (if (eq (machinetype) (quote maiko)) then (quote (("Suspend" (quote (suspend-lisp)) "Suspend the running lisp and return to UNIX"))))))))) (or (for item in |BackgroundMenuCommands| thereis (string-equal "System" (car item))) (/nconc1 |BackgroundMenuCommands| (list "System" nil nil (list (quote subitems))))) (for label in (quote ("SaveVM" "Idle" "AR Edit" "DumpCache" "Set Directories" "LOGOUT & Power-Off" "Reset NFS")) do (move-background-item-under label "System"))) (rpaqq |BackgroundMenu| nil) ) (rpaqq do-load-utilities-init-commands ((initvars *load-utility-options* nil) (p (eval-at-greet (cl:unless *vanilla-init-loaded* (cl:mapc (cl:function (cl:lambda (utility) (|PickLoadUtilityItem| utility nil t))) *load-utility-options*)))))) (rpaq? *load-utility-options* nil) (rpaq? nil nil) (eval-at-greet (cl:unless *vanilla-init-loaded* (cl:mapc (cl:function (cl:lambda (utility) (|PickLoadUtilityItem| utility nil t))) *load-utility-options*))) (* |;;| "Send the Tool Work's a message telling it about this user.") (cl:defun log-vanilla-init-user nil (let ((me "Lanning") (user (cl:if \\cc-generic-init-msg (username) ""))) (cond ((string-equal user me) nil) ((not (cl:fboundp (quote lafite.sendmessage))) nil) (t (lafite.sendmessage (cl:format nil "Subject: ~A~%To: ~A.pa~%Cc: ~A~@{~%~%~A~}" "Vanilla-Init" me user "This is to let you know that I am using Vanilla-Init (again)." "Thanks for making it available.")))))) (rpaq? \\cc-generic-init-msg t) (eval-at-greet (cl:unless *vanilla-init-loaded* (log-vanilla-init-user))) (rpaq *load-verbose* \\original-load-verbose) (rpaq prettyheader \\original-prettyheader) (rpaqq *vanilla-init-loaded* t) (* |;;| "Make the FileManager happy") (declare\: dontcopy (putprops vanilla-init makefile-environment (:package "IL" :readtable "XCL" :base 10)) ) (putprops vanilla-init copyright ("Xerox Corporation" 1988 1989)) (declare\: dontcopy (filemap (nil (41150 41759 (|DebugMode| 41160 . 41757)) (41760 42392 (selectw 41770 . 42390)) (43764 46483 (|PrintDocFile| 43774 . 46481)) (46484 46819 (|\\Pick-One-At-Random| 46494 . 46817)) (46951 47620 (|GoodNight| 46961 . 47286) (|NewLisp| 47288 . 47618)) (47621 51024 (|RememberLastPartition| 47631 . 49007) (|RememberLispState| 49009 . 51022))))) stop \ No newline at end of file diff --git a/lispusers/VSTATS b/lispusers/VSTATS new file mode 100644 index 00000000..c8942763 --- /dev/null +++ b/lispusers/VSTATS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "13-Nov-87 01:45:11" "{FireFS:CS:Univ Rochester}LispUsers>Lyric>VSTATS.;12" 46865 changes to%: (FNS VSTATS) previous date%: "30-Oct-87 01:20:07" "{FireFS:CS:Univ Rochester}LispUsers>Lyric>VSTATS.;11") (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT VSTATSCOMS) (RPAQQ VSTATSCOMS ((* * User interface * *) (FNS VSTATS) (INITVARS (VSTATS.ALWAYS? NIL) (VSTATS.BLACK? NIL) (VSTATS.CLOCK.INTERVAL 1) (VSTATS.MUTIL.HYSTERESIS 20) (VSTATS.MUTIL.INTERVAL 1) (VSTATS.POSITION (create POSITION XCOORD _ SCREENWIDTH YCOORD _ SCREENHEIGHT)) (VSTATS.SPACE.INTERVAL 300) (VSTATS.SPACE.PANIC.LEVEL 95) (VSTATS.SPACE.SHOW.DISK? T)) (* * VSTATS support stuff * *) (LOCALVARS . T) (FILES (SYSLOAD FROM LISPUSERS) READNUMBER SYSTATS) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES) (CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4))))) (COMS (DECLARE%: DONTCOPY (RECORDS VSTATSPCTINFO VSTATSTIMERINFO SPACEDATA) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) VSTATS)) (INITRECORDS VSTATSPCTINFO VSTATSTIMERINFO SPACEDATA)) (INITVARS (VStatsOff? T) (VStatsWindow) (VStatsDsp) (VStatsCurrentTime (SETUPTIMER 0 NIL (QUOTE TICKS)))) (FNS VStats-CenterRegion VStats-CreatePCTs VStats-Display VStats-DisplayPct VStats-DrawLine VStats-GetPCTsRegion VStats-Init VStats-InitInterval VStats-MouseWait VStats-Percentage VStats-ReDisplay? VStats-SetDisplayColor VStats-SetUpTimer VStats-TimerExpired?) (* * option support stuff * *) (INITVARS (VStatsOptionsWindow)) (FNS VStatsOptions-Inspect VStatsOptions-FetchFn VStatsOptions-PropCommandFn VStatsOptions-PropPrintFn VStatsOptions-PropertiesFn VStatsOptions-RNumber VStatsOptions-SelectionFn VStatsOptions-StoreFn VStatsOptions-ValueCommandFn) (* * clock support stuff * *) (INITVARS (VStatsClockFont) (VStatsClockReset?) (VStatsClockTimer)) (FNS VStatsClock-Display VStatsClock-DisplayDigits VStatsClock-DisplayMonth VStatsClock-Init VStatsClock-ReDisplay VStatsClock-Read VStatsClock-Ticks? VStatsClock-UnpackDate) (* * space support stuff * *) (INITVARS (VStatsSpaceDiskPages) (VStatsSpaceFont) (VStatsSpacePCTs) (VStatsSpaceTimer)) (INITVARS (\LASTVMEMFILEPAGE 16383)) (FNS VStatsSpace-Display VStatsSpace-Init VStatsSpace-InitDisk VStatsSpace-InitPanicLevel VStatsSpace-ReDisplay VStatsSpace-Read VStatsSpace-ShrinkInterval VStatsSpace-Ticks?) (* * machine utilization support stuff * *) (INITVARS (VStatsMUtilFont) (VStatsMUtilOrigState) (VStatsMUtilPCTs) (VStatsMUtilTimer)) (FNS VStatsMUtil-Display VStatsMUtil-Init VStatsMUtil-InitState VStatsMUtil-ReDisplay VStatsMUtil-Read VStatsMUtil-Ticks?) (* * These ought to be system functions!!! * *) (FNS ALTOPARTITIONP ALTOPARTITIONS DISKUSEDPAGES DISKTOTALPAGES COVEREDWP) (* * Initialize on LOAD * *) (VARS (BackgroundMenu)) (ADDVARS (BackgroundMenuCommands ("VStats" (QUOTE (VSTATS (QUOTE On))) "Running display of clock and/or space utilization"))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (COND ((OR VSTATS.CLOCK.INTERVAL VSTATS.SPACE.INTERVAL VSTATS.MUTIL.INTERVAL) (VSTATS (QUOTE ON))))))) ) (* * User interface * *) (DEFINEQ (VSTATS (LAMBDA (on/off) (* ; "Edited 13-Nov-87 01:43 by Koomen") (DECLARE (GLOBALVARS VStatsDsp VStatsOff? VStatsOptionsWindow VStatsWindow)) (if (WINDOWP VStatsWindow) then (CLOSEW VStatsWindow)) (if (WINDOWP VStatsOptionsWindow) then (CLOSEW VStatsOptionsWindow)) (SETQ on/off (AND (LITATOM on/off) (U-CASE on/off))) (SETQ VStatsOff? (OR (NULL on/off) (EQ on/off (QUOTE OFF)) (EQ on/off (QUOTE SUSPEND)))) (if (NOT VStatsOff?) then (if (NOT (VStats-Init)) then (VStatsOptions-Inspect) (SETQ VStatsOff? T))) (LET ((ResetForms (QUOTE ((BEFORELOGOUTFORMS (VSTATS (QUOTE SUSPEND))) (BEFORESYSOUTFORMS (VSTATS (QUOTE SUSPEND))) (BEFOREMAKESYSFORMS (VSTATS (QUOTE SUSPEND))) (AFTERLOGOUTFORMS (VSTATS (QUOTE ON))) (AFTERSYSOUTFORMS (VSTATS (QUOTE ON))) (AFTERMAKESYSFORMS (VSTATS (QUOTE ON))) (BACKGROUNDFNS VStats-ReDisplay? T))))) (if VStatsOff? then (SETQ VStatsOptionsWindow) (SETQ VStatsWindow (SETQ VStatsDsp)) (for RF in ResetForms when (OR (CADDR RF) (NEQ on/off (QUOTE SUSPEND))) do (SETTOPVAL (CAR RF) (REMOVE (CADR RF) (GETTOPVAL (CAR RF))))) (QUOTE Off) else (VStats-Display) (for RF in ResetForms unless (MEMBER (CADR RF) (GETTOPVAL (CAR RF))) do (SETTOPVAL (CAR RF) (CONS (CADR RF) (GETTOPVAL (CAR RF))))) (QUOTE On)))) ) ) (RPAQ? VSTATS.ALWAYS? NIL) (RPAQ? VSTATS.BLACK? NIL) (RPAQ? VSTATS.CLOCK.INTERVAL 1) (RPAQ? VSTATS.MUTIL.HYSTERESIS 20) (RPAQ? VSTATS.MUTIL.INTERVAL 1) (RPAQ? VSTATS.POSITION (create POSITION XCOORD _ SCREENWIDTH YCOORD _ SCREENHEIGHT)) (RPAQ? VSTATS.SPACE.INTERVAL 300) (RPAQ? VSTATS.SPACE.PANIC.LEVEL 95) (RPAQ? VSTATS.SPACE.SHOW.DISK? T) (* * VSTATS support stuff * *) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (SYSLOAD FROM LISPUSERS) READNUMBER SYSTATS) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES) ) (DECLARE%: EVAL@COMPILE (RPAQ \4YearsDays (ADD1 (ITIMES 365 4))) (CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4)))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD VSTATSPCTINFO (NAME LABEL NEWPCT OLDPCT LBLREGION BARREGION MAXBARHEIGHT)) (RECORD VSTATSTIMERINFO (INTERVAL TIMER LASTSETUP) INTERVAL _ 0 TIMER _ (SETUPTIMER 0 NIL (QUOTE TICKS)) LASTSETUP _ (SETUPTIMER 0 NIL (QUOTE TICKS))) (RECORD SPACEDATA (MDSFREE MDSFRAC 8MBFRAC ATOMSFREE ATOMFRAC)) ) (PUTPROPS VSTATS FILETYPE :TCOMPL) (PUTPROPS VSTATS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) ) (RPAQ? VStatsOff? T) (RPAQ? VStatsWindow ) (RPAQ? VStatsDsp ) (RPAQ? VStatsCurrentTime (SETUPTIMER 0 NIL (QUOTE TICKS))) (DEFINEQ (VStats-CenterRegion (LAMBDA (region width bottom pctlist) (* Koomen "12-Jan-87 17:37") (PROG ((delta (HALF (IDIFFERENCE width (fetch (REGION WIDTH) of region))))) (replace (REGION LEFT) of region with delta) (replace (REGION BOTTOM) of region with bottom) (for pct in pctlist bind (r) do (SETQ r (fetch (VSTATSPCTINFO BARREGION) of pct)) (replace (REGION LEFT) of r with (IPLUS delta (fetch (REGION LEFT) of r))) (replace (REGION BOTTOM) of r with bottom) (SETQ r (fetch (VSTATSPCTINFO LBLREGION) of pct)) (replace (REGION LEFT) of r with (IPLUS delta (fetch (REGION LEFT) of r))) (replace (REGION BOTTOM) of r with bottom)))) ) (VStats-CreatePCTs (LAMBDA (font names&labels) (* Koomen "12-Jan-87 17:38") (PROG (pctlist (lblwidths 0) (lblheight (ITIMES 2 (FONTHEIGHT font))) (barwidth (STRINGWIDTH "A" font)) (barheight (IPLUS (FONTHEIGHT font) (FONTPROP font (QUOTE ASCENT))))) (SETQ pctlist (for name&lbl in names&labels bind (name lbl lblwidth) collect (SETQ name (CAR name&lbl)) (SETQ lbl (CDR name&lbl)) (SETQ lblwidth (STRINGWIDTH lbl font)) (SETQ lblwidths (IPLUS lblwidths lblwidth)) (create VSTATSPCTINFO NAME _ name LABEL _ lbl NEWPCT _ 0 OLDPCT _ 0 LBLREGION _ (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ lblwidth HEIGHT _ lblheight) BARREGION _ (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 0 HEIGHT _ barheight) MAXBARHEIGHT _ barheight))) (for pct in pctlist bind (r w x) first (SETQ w (HALF (ITIMES 3 barwidth))) (SETQ x (IDIFFERENCE w barwidth)) do (SETQ r (fetch (VSTATSPCTINFO BARREGION) of pct)) (replace (REGION LEFT) of r with x) (replace (REGION WIDTH) of r with barwidth) (SETQ r (fetch (VSTATSPCTINFO LBLREGION) of pct)) (replace (REGION LEFT) of r with (IPLUS x w)) (SETQ x (IPLUS w (fetch (REGION RIGHT) of r)))) (RETURN pctlist))) ) (VStats-Display (LAMBDA (ThruMouse?) (* ; "Edited 22-Sep-87 14:59 by Koomen") (DECLARE (GLOBALVARS VStatsClockRegion VStatsClockTimer VStatsDsp VStatsMUtilRegion VStatsMUtilTimer VStatsSpaceRegion VStatsSpaceTimer VStatsWindow)) (PROG (r1 r2 r3) (if ThruMouse? then (if (NOT (VStats-MouseWait VStatsWindow)) then (RETURN))) (DSPFILL NIL NIL NIL VStatsDsp) (if (SETQ r1 VStatsClockRegion) then (VStats-SetUpTimer VStatsClockTimer) (VStatsClock-Display)) (if (SETQ r2 VStatsSpaceRegion) then (VStats-SetUpTimer VStatsSpaceTimer) (VStatsSpace-Display)) (if (SETQ r3 VStatsMUtilRegion) then (VStats-SetUpTimer VStatsMUtilTimer) (VStatsMUtil-Display)) (if (AND r1 r2 r3) then (VStats-DrawLine r1 r2) (VStats-DrawLine r2 r3) elseif (AND r1 r2) then (VStats-DrawLine r1 r2) elseif (AND r1 r3) then (VStats-DrawLine r1 r3) elseif (AND r2 r3) then (VStats-DrawLine r2 r3)))) ) (VStats-DisplayPct (LAMBDA (PCT BOX.ALWAYS?) (* Koomen "12-Jan-87 17:24") (DECLARE (GLOBALVARS BLACKSHADE VSTATS.BLACK? VStatsDsp WHITESHADE)) (PROG ((shade (if VSTATS.BLACK? then WHITESHADE else BLACKSHADE)) (oldpct (fetch (VSTATSPCTINFO OLDPCT) of PCT)) (newpct (fetch (VSTATSPCTINFO NEWPCT) of PCT)) (lblregion (fetch (VSTATSPCTINFO LBLREGION) of PCT)) (barregion (fetch (VSTATSPCTINFO BARREGION) of PCT)) (maxbarheight (fetch (VSTATSPCTINFO MAXBARHEIGHT) of PCT))) (* * Print percentage as d.dd * *) (MOVETO (fetch (REGION LEFT) of lblregion) (fetch (REGION BOTTOM) of lblregion) VStatsDsp) (BOUT VStatsDsp (IPLUS (IQUOTIENT newpct 100) (CHARCODE "0"))) (BOUT VStatsDsp (CHARCODE ".")) (BOUT VStatsDsp (IPLUS (IQUOTIENT (IREMAINDER newpct 100) 10) (CHARCODE "0"))) (BOUT VStatsDsp (IPLUS (IREMAINDER newpct 10) (CHARCODE "0"))) (* * Display percentage graphically in box * *) (replace (REGION HEIGHT) of barregion with (IQUOTIENT (ITIMES newpct maxbarheight) 100)) (if (OR BOX.ALWAYS? (ILESSP newpct oldpct)) then (GRAYBOXAREA (fetch (REGION LEFT) of barregion) (fetch (REGION BOTTOM) of barregion) (fetch (REGION WIDTH) of barregion) maxbarheight 1 shade VStatsDsp)) (DSPFILL barregion shade NIL VStatsDsp))) ) (VStats-DrawLine (LAMBDA (hiregion loregion) (* Koomen "12-Jan-87 17:38") (DECLARE (GLOBALVARS VStatsDsp)) (PROG ((x1 (DSPLEFTMARGIN NIL VStatsDsp)) (x2 (DSPRIGHTMARGIN NIL VStatsDsp)) (y (SUB1 (HALF (IPLUS (fetch (REGION BOTTOM) of hiregion) (fetch (REGION TOP) of loregion)))))) (DRAWLINE x1 y x2 y 2 (QUOTE INVERT) VStatsDsp))) ) (VStats-GetPCTsRegion (LAMBDA (pctlist) (* Koomen "12-Jan-87 17:34") (DECLARE (GLOBALVARS SCREENWIDTH)) (for pct in pctlist bind barregion lblregion (minleft _ SCREENWIDTH) (maxright _ 0) (maxheight _ 0) do (SETQ barregion (fetch (VSTATSPCTINFO BARREGION) of pct)) (SETQ lblregion (fetch (VSTATSPCTINFO LBLREGION) of pct)) (SETQ minleft (IMIN minleft (IMIN (fetch (REGION LEFT) of barregion) (fetch (REGION LEFT) of lblregion)))) (SETQ maxright (IMAX maxright (IMAX (fetch (REGION RIGHT) of barregion) (fetch (REGION RIGHT) of lblregion)))) (SETQ maxheight (IMAX maxheight (IMAX (fetch (REGION HEIGHT) of barregion) (fetch (REGION HEIGHT) of lblregion)))) finally (RETURN (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (ADD1 (IDIFFERENCE maxright minleft)) HEIGHT _ maxheight)))) ) (VStats-Init (LAMBDA NIL (* Koomen "19-Jun-87 00:58") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS SCREENHEIGHT SCREENWIDTH VSTATS.POSITION VStatsClockRegion VStatsDsp VStatsMUtilPCTs VStatsMUtilRegion VStatsOff? VStatsSpacePCTs VStatsSpaceRegion VStatsWindow WBorder)) (PROG (clockwidth clockheight spacewidth spaceheight mutilwidth mutilheight wleft wbottom wwidth wheight wposition wregion (width 0) (height 0) (bottom 0) (border WBorder) (spacing (HALF (ITIMES 3 WBorder)))) (if (VStatsClock-Init) then (SETQ clockwidth (fetch (REGION WIDTH) of VStatsClockRegion)) (SETQ width (IMAX width clockwidth)) (SETQ clockheight (fetch (REGION HEIGHT) of VStatsClockRegion)) (SETQ height (IPLUS height clockheight spacing))) (if (VStatsSpace-Init) then (SETQ spacewidth (fetch (REGION WIDTH) of VStatsSpaceRegion)) (SETQ width (IMAX width spacewidth)) (SETQ spaceheight (fetch (REGION HEIGHT) of VStatsSpaceRegion)) (SETQ height (IPLUS height spaceheight spacing))) (if (VStatsMUtil-Init) then (SETQ mutilwidth (fetch (REGION WIDTH) of VStatsMUtilRegion)) (SETQ width (IMAX width mutilwidth)) (SETQ mutilheight (fetch (REGION HEIGHT) of VStatsMUtilRegion)) (SETQ height (IPLUS height mutilheight spacing))) (if (ZEROP width) then (RETURN)) (SETQ width (IPLUS width spacing)) (SETQ wwidth (WIDTHIFWINDOW width border)) (SETQ wheight (HEIGHTIFWINDOW height NIL border)) (SETQ wposition (OR (POSITIONP VSTATS.POSITION) (GETBOXPOSITION wwidth wheight NIL NIL NIL "Indicate placement of VSTATS window:"))) (SETQ wleft (IMAX 0 (IMIN (fetch (POSITION XCOORD) of wposition) (IDIFFERENCE SCREENWIDTH (ADD1 wwidth))))) (SETQ wbottom (IMAX 0 (IMIN (fetch (POSITION YCOORD) of wposition) (IDIFFERENCE SCREENHEIGHT (ADD1 wheight))))) (if (NOT (POSITIONP VSTATS.POSITION)) then (SETQ VSTATS.POSITION (create POSITION XCOORD _ wleft YCOORD _ wbottom))) (SETQ wregion (create REGION LEFT _ wleft BOTTOM _ wbottom WIDTH _ wwidth HEIGHT _ wheight)) (SETQ VStatsWindow (CREATEW wregion NIL border)) (SETQ VStatsDsp (WINDOWPROP VStatsWindow (QUOTE DSP))) (VStats-SetDisplayColor) (SETQ bottom (IQUOTIENT spacing 4)) (if VStatsMUtilRegion then (VStats-CenterRegion VStatsMUtilRegion width bottom VStatsMUtilPCTs) (SETQ bottom (IPLUS bottom mutilheight spacing))) (if VStatsSpaceRegion then (VStats-CenterRegion VStatsSpaceRegion width bottom VStatsSpacePCTs) (SETQ bottom (IPLUS bottom spaceheight spacing))) (if VStatsClockRegion then (VStats-CenterRegion VStatsClockRegion width bottom) (SETQ bottom (IPLUS bottom clockheight spacing))) (WINDOWPROP VStatsWindow (QUOTE REPAINTFN) (FUNCTION (LAMBDA (w) (VStats-Display)))) (WINDOWPROP VStatsWindow (QUOTE CLOSEFN) (FUNCTION (LAMBDA (w) (DECLARE (GLOBALVARS VStatsOff?)) (SETQ VStatsOff? T)))) (WINDOWPROP VStatsWindow (QUOTE AFTERMOVEFN) (FUNCTION (LAMBDA (w) (DECLARE (GLOBALVARS VSTATS.POSITION)) (PROG ((r (WINDOWREGION w))) (SETQ VSTATS.POSITION (create POSITION XCOORD _ (fetch (REGION LEFT) of r) YCOORD _ (fetch (REGION BOTTOM) of r))))))) (WINDOWPROP VStatsWindow (QUOTE BUTTONEVENTFN) (FUNCTION (LAMBDA (w) (if (LASTMOUSESTATE (ONLY LEFT)) then (VStats-Display T) elseif (LASTMOUSESTATE (ONLY MIDDLE)) then (VStatsOptions-Inspect T))))) (WINDOWPROP VStatsWindow (QUOTE SHRINKFN) (QUOTE DON'T)) (WINDOWPROP VStatsWindow (QUOTE RESHAPEFN) (QUOTE DON'T)) (RETURN T))) ) (VStats-InitInterval (LAMBDA (VSTATSTIMER INTERVAL MAXINTERVAL) (* HaKo "12-Jun-86 22:45") (* * If Interval is a positive number, initialize the timer with the corresponding number of clock ticks and return it, otherwise return NIL) (if (AND (NUMBERP INTERVAL) (GREATERP INTERVAL 0)) then (replace (VSTATSTIMERINFO INTERVAL) of VSTATSTIMER with (CLOCKTICKS (MAX 1 (MIN INTERVAL MAXINTERVAL)) (QUOTE SECONDS))))) ) (VStats-MouseWait (LAMBDA (WINDOW) (* Koomen "16-Apr-87 16:59") (* ;; "Wait until the mouse buttons are up or mouse out of the window. Return T if mouse is still in the window") (* ;; "DISABLED!!!") (OR T (bind (REGION _ (WINDOWREGION WINDOW)) do (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) then (RETURN) elseif (MOUSESTATE UP) then (RETURN T))))) ) (VStats-Percentage (LAMBDA (X Y) (* Koomen "24-Mar-87 15:45") (* ;; "Desperately tries to use SMALLP's and avoid doing IQUOTIENT's or creating FIXP's or FLOATP's.") (if (ILEQ X 0) then 0 elseif (IGEQ X Y) then 100 else (PROG (Z) (if (IGREATERP Y (CONSTANT (LRSH MAX.SMALLP 1))) then (SETQ Y (IQUOTIENT Y 100)) elseif (ILEQ X (CONSTANT (IQUOTIENT MAX.SMALLP 200))) then (RETURN (IQUOTIENT (IPLUS (ITIMES X 200) Y) (LLSH Y 1))) elseif (AND (IGREATERP X (LRSH Y 1)) (ILEQ (SETQ Z (IDIFFERENCE Y X)) (CONSTANT (IQUOTIENT MAX.SMALLP 200)))) then (RETURN (IDIFFERENCE 100 (IQUOTIENT (IPLUS (ITIMES Z 200) Y) (LLSH Y 1)))) else (SETQ Z (IQUOTIENT MAX.SMALLP Y)) (SETQ X (ITIMES Z X)) (SETQ Y (IQUOTIENT (ITIMES Z Y) 100))) (RETURN (IQUOTIENT (IPLUS X (LRSH Y 1)) Y))))) ) (VStats-ReDisplay? (LAMBDA NIL (* ; "Edited 18-Sep-87 00:56 by Koomen") (DECLARE (GLOBALVARS VSTATS.ALWAYS? VStatsClockRegion VStatsClockTimer VStatsMUtilRegion VStatsMUtilTimer VStatsOff? VStatsSpaceLevel VStatsSpacePanicLevel VStatsSpaceRegion VStatsSpaceTimer VStatsWindow)) (if VStatsOff? then (VSTATS (QUOTE Off)) else (LET ((DoDisp (OR VSTATS.ALWAYS? (AND VStatsSpaceRegion VStatsSpacePanicLevel (IGREATERP VStatsSpaceLevel VStatsSpacePanicLevel)) (NOT (COVEREDWP VStatsWindow))))) (if VStatsClockRegion then (if (VStats-TimerExpired? VStatsClockTimer) then (if DoDisp then (VStatsClock-ReDisplay)))) (if VStatsSpaceRegion then (if (VStats-TimerExpired? VStatsSpaceTimer) then (if DoDisp then (VStatsSpace-ReDisplay)))) (if VStatsMUtilRegion then (if (VStats-TimerExpired? VStatsMUtilTimer) then (if DoDisp then (VStatsMUtil-ReDisplay))))))) ) (VStats-SetDisplayColor (LAMBDA NIL (* HaKo " 2-Jul-86 16:01") (DECLARE (GLOBALVARS BLACKSHADE VSTATS.BLACK? VStatsDsp WHITESHADE)) (if VStatsDsp then (if VSTATS.BLACK? then (DSPTEXTURE BLACKSHADE VStatsDsp) (DSPSOURCETYPE (QUOTE INVERT) VStatsDsp) else (DSPTEXTURE WHITESHADE VStatsDsp) (DSPSOURCETYPE (QUOTE INPUT) VStatsDsp)))) ) (VStats-SetUpTimer (LAMBDA (TIMERINFO) (* ; "Edited 23-Sep-87 11:19 by Koomen") (PROG ((CLK (fetch (VSTATSTIMERINFO LASTSETUP) of TIMERINFO)) (INT (fetch (VSTATSTIMERINFO INTERVAL) of TIMERINFO)) REM) (\RCLK CLK) (SETQ REM (IREMAINDER CLK INT)) (RETURN (SETUPTIMER (if (ILESSP REM 0) then (IDIFFERENCE 0 REM) else (IDIFFERENCE INT REM)) (fetch (VSTATSTIMERINFO TIMER) of TIMERINFO) (QUOTE TICKS))))) ) (VStats-TimerExpired? (LAMBDA (TIMERINFO) (* ; "Edited 18-Sep-87 00:56 by Koomen") (* ;; "Knowing the last time the timer was set allows us to test for wrap around. Using the standard TIMEREXPIRED? the timer could be set at some big positive number (say MAX.FIXP --- 100), If we don't get to check the machine clock between the timer's value and the largest positive number the machine clock will wrap around to some big negative number (say MAX.FIXP + 100) and it will be quite a while before the machine clock is again GREATERP than our timer!") (DECLARE (GLOBALVARS VStatsCurrentTime)) (\RCLK VStatsCurrentTime) (if (OR (IGREATERP VStatsCurrentTime (fetch (VSTATSTIMERINFO TIMER) of TIMERINFO)) (ILESSP VStatsCurrentTime (fetch (VSTATSTIMERINFO LASTSETUP) of TIMERINFO))) then (VStats-SetUpTimer TIMERINFO))) ) ) (* * option support stuff * *) (RPAQ? VStatsOptionsWindow ) (DEFINEQ (VStatsOptions-Inspect (LAMBDA (ThruMouse?) (* Koomen " 2-Jul-87 00:43") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY VStatsOptionsWindow VStatsWindow)) (PROG ((OPTIONS (QUOTE (VSTATS.BLACK? VSTATS.ALWAYS? VSTATS.SPACE.SHOW.DISK? VSTATS.MUTIL.HYSTERESIS VSTATS.SPACE.PANIC.LEVEL VSTATS.CLOCK.INTERVAL VSTATS.SPACE.INTERVAL VSTATS.MUTIL.INTERVAL)))) (if ThruMouse? then (if (NOT (VStats-MouseWait VStatsWindow)) then (RETURN))) (if (WINDOWP VStatsOptionsWindow) then (MOVEW VStatsOptionsWindow LASTMOUSEX LASTMOUSEY) (MOVEW VStatsOptionsWindow) (INSPECTW.REDISPLAY VStatsOptionsWindow OPTIONS) else (SETQ VStatsOptionsWindow (INSPECTW.CREATE OPTIONS (FUNCTION VStatsOptions-PropertiesFn) (FUNCTION VStatsOptions-FetchFn) (FUNCTION VStatsOptions-StoreFn) (FUNCTION VStatsOptions-PropCommandFn) (FUNCTION VStatsOptions-ValueCommandFn) (AND NIL (FUNCTION TitleCommandFn)) "VStats Options" (FUNCTION VStatsOptions-SelectionFn) (AND NIL (QUOTE Where)) (FUNCTION VStatsOptions-PropPrintFn)))))) ) (VStatsOptions-FetchFn (LAMBDA (OPTIONS OPTION) (* ; "Edited 22-Sep-87 15:00 by Koomen") (DECLARE (GLOBALVARS VSTATS.ALWAYS? VSTATS.BLACK? VSTATS.CLOCK.INTERVAL VSTATS.MUTIL.HYSTERESIS VSTATS.MUTIL.INTERVAL VSTATS.SPACE.INTERVAL VSTATS.SPACE.SHOW.DISK? VStatsWindow)) (SELECTQ OPTION (VSTATS.POSITION (if (WINDOWP VStatsWindow) then (LET ((R (WINDOWREGION VStatsWindow))) (create POSITION XCOORD _ (fetch (REGION LEFT) of R) YCOORD _ (fetch (REGION BOTTOM) of R))))) (VSTATS.ALWAYS? (if VSTATS.ALWAYS? then (QUOTE Yes) else (QUOTE No))) (VSTATS.BLACK? (if VSTATS.BLACK? then (QUOTE Inverted) else (QUOTE Normal))) (VSTATS.CLOCK.INTERVAL (if (VStatsClock-Ticks?) then VSTATS.CLOCK.INTERVAL else (QUOTE Disabled))) (VSTATS.SPACE.INTERVAL (if (VStatsSpace-Ticks?) then VSTATS.SPACE.INTERVAL else (QUOTE Disabled))) (VSTATS.SPACE.SHOW.DISK? (if (NULL VStatsSpaceDisk) then (QUOTE Disabled) else (OR (FILENAMEFIELD VStatsSpaceDisk (QUOTE DIRECTORY)) (FILENAMEFIELD VStatsSpaceDisk (QUOTE HOST))))) (VSTATS.SPACE.PANIC.LEVEL (LET ((pct (VStatsSpace-InitPanicLevel))) (if pct then pct else (QUOTE Disabled)))) (VSTATS.MUTIL.INTERVAL (if (VStatsMUtil-Ticks?) then VSTATS.MUTIL.INTERVAL else (QUOTE Disabled))) (VSTATS.MUTIL.HYSTERESIS (if (AND (NUMBERP VSTATS.MUTIL.HYSTERESIS) (GREATERP VSTATS.MUTIL.HYSTERESIS 0)) then VSTATS.MUTIL.HYSTERESIS else (QUOTE Cumulative))) (ERROR "Unknown VStats option: " OPTION))) ) (VStatsOptions-PropCommandFn (LAMBDA (OPTION OPTIONS WINDOW) (* HaKo " 2-Jul-86 14:00") (PROMPTPRINT (SELECTQ OPTION (VSTATS.ALWAYS? "Update VStats window even if partially or completely occluded.") (VSTATS.BLACK? "Display VStats window in inverse video.") (VSTATS.CLOCK.INTERVAL "Number of seconds between clock updates. Disabled if <= 0.") (VSTATS.SPACE.INTERVAL "Number of seconds between space utilization updates. Disabled if <= 0.") (VSTATS.SPACE.SHOW.DISK? "Display percentage of local disk space used.") (VSTATS.SPACE.PANIC.LEVEL "Percentage at which VStats window will start flashing `out of space soon' warnings.") (VSTATS.MUTIL.INTERVAL "Number of seconds between machine utilization updates. Disabled if <= 0.") (VSTATS.MUTIL.HYSTERESIS "Number of intervals over which machine utilization will be averaged. Cumulative average used if <= 0.") (VSTATS.POSITION "Position of VStats window.") (ERROR "Unknown VStats option: " OPTION)))) ) (VStatsOptions-PropPrintFn (LAMBDA (OPTION OPTIONS) (* HaKo " 3-Jul-86 08:45") (SELECTQ OPTION (VSTATS.ALWAYS? (QUOTE Update.Always?)) (VSTATS.BLACK? (QUOTE Display.Color)) (VSTATS.CLOCK.INTERVAL (QUOTE Clock.Update.Interval)) (VSTATS.SPACE.INTERVAL (QUOTE Space.Update.Interval)) (VSTATS.SPACE.SHOW.DISK? (QUOTE Show.Disk.Space?)) (VSTATS.SPACE.PANIC.LEVEL (QUOTE Space.Panic.Level)) (VSTATS.MUTIL.INTERVAL (QUOTE MUtil.Update.Interval)) (VSTATS.MUTIL.HYSTERESIS (QUOTE MUtil.Hysteresis)) (VSTATS.POSITION (QUOTE Window.Position)) (ERROR "Unknown VSTATS option: " OPTION))) ) (VStatsOptions-PropertiesFn (LAMBDA (OPTIONS) (* HaKo "25-Jun-86 17:30") OPTIONS)) (VStatsOptions-RNumber (LAMBDA (LABEL FLOAT? NOTNUMVAL NOTPOSVAL) (* HaKo " 2-Jul-86 15:33") (LET ((N (RNUMBER LABEL NIL NIL NIL T FLOAT?))) (if (NOT (NUMBERP N)) then NOTNUMVAL elseif (GREATERP N 0) then N else NOTPOSVAL))) ) (VStatsOptions-SelectionFn (LAMBDA (OPTION VALUE? WINDOW) (* HaKo " 2-Jul-86 14:10") (if (NOT VALUE?) then (VStatsOptions-PropCommandFn OPTION NIL WINDOW))) ) (VStatsOptions-StoreFn (LAMBDA (OPTIONS OPTION NEWVALUE) (* Koomen "18-Jun-87 22:54") (DECLARE (GLOBALVARS VSTATS.ALWAYS? VSTATS.BLACK? VSTATS.CLOCK.INTERVAL VSTATS.MUTIL.HYSTERESIS VSTATS.MUTIL.INTERVAL VSTATS.POSITION VSTATS.SPACE.INTERVAL VSTATS.SPACE.PANIC.LEVEL VSTATS.SPACE.SHOW.DISK? VStatsWindow)) (LET (INIT?) (SELECTQ OPTION (VSTATS.ALWAYS? (SETQ VSTATS.ALWAYS? (EQ NEWVALUE (QUOTE Yes)))) (VSTATS.BLACK? (SETQ VSTATS.BLACK? (EQ NEWVALUE (QUOTE Inverted))) (if VStatsWindow then (VStats-SetDisplayColor) (VStats-Display))) (VSTATS.CLOCK.INTERVAL (LET ((OLDOFF (NULL (VStatsClock-Ticks?)))) (SETQ VSTATS.CLOCK.INTERVAL (NUMBERP NEWVALUE)) (SETQ INIT? (NEQ OLDOFF (NULL (VStatsClock-Ticks?)))))) (VSTATS.SPACE.INTERVAL (LET ((OLDOFF (NULL (VStatsSpace-Ticks?)))) (SETQ VSTATS.SPACE.INTERVAL (NUMBERP NEWVALUE)) (SETQ INIT? (NEQ OLDOFF (NULL (VStatsSpace-Ticks?)))))) (VSTATS.MUTIL.INTERVAL (LET ((OLDOFF (NULL (VStatsMUtil-Ticks?)))) (SETQ VSTATS.MUTIL.INTERVAL (NUMBERP NEWVALUE)) (SETQ INIT? (NEQ OLDOFF (NULL (VStatsMUtil-Ticks?)))))) (VSTATS.SPACE.PANIC.LEVEL (SETQ VSTATS.SPACE.PANIC.LEVEL NEWVALUE) (VStatsSpace-InitPanicLevel)) (VSTATS.SPACE.SHOW.DISK? (SETQ VSTATS.SPACE.SHOW.DISK? NEWVALUE) (SETQ INIT? T)) (VSTATS.MUTIL.HYSTERESIS (SETQ VSTATS.MUTIL.HYSTERESIS NEWVALUE) (SETQ INIT? T)) (VSTATS.POSITION (SETQ VSTATS.POSITION NEWVALUE) (if VStatsWindow then (MOVEW VStatsWindow NEWVALUE))) (ERROR "Unknown VSTATS option: " OPTION)) (if (AND VStatsWindow INIT?) then (VSTATS (QUOTE On))))) ) (VStatsOptions-ValueCommandFn (LAMBDA (OLDVALUE OPTION OPTIONS WINDOW) (* ; "Edited 27-Oct-87 16:18 by Koomen") (DECLARE (GLOBALVARS VStatsOptionsWindow VStatsWindow)) (PROG (NEWVALUE) (if (NOT (VStats-MouseWait VStatsOptionsWindow)) then (RETURN)) (SETQ NEWVALUE (SELECTQ OPTION (VSTATS.ALWAYS? (OR (MENU (create MENU ITEMS _ (QUOTE (Yes No)) CENTERFLG _ T)) OLDVALUE)) (VSTATS.BLACK? (OR (MENU (create MENU ITEMS _ (QUOTE (Normal Inverted)) CENTERFLG _ T)) OLDVALUE)) ((VSTATS.CLOCK.INTERVAL VSTATS.SPACE.INTERVAL VSTATS.MUTIL.INTERVAL) (VStatsOptions-RNumber "New interval: " T OLDVALUE (QUOTE Disabled))) (VSTATS.SPACE.SHOW.DISK? (SETQ OLDVALUE VStatsSpaceDisk) (VStatsSpace-InitDisk T)) (VSTATS.SPACE.PANIC.LEVEL (VStatsOptions-RNumber "New panic level: " NIL OLDVALUE (QUOTE Disabled))) (VSTATS.MUTIL.HYSTERESIS (VStatsOptions-RNumber "MUtil hysteresis: " NIL OLDVALUE (QUOTE Cumulative))) (VSTATS.POSITION (if VStatsWindow then (LET ((R (WINDOWREGION VStatsWindow))) (GETBOXPOSITION (fetch (REGION WIDTH) of R) (fetch (REGION HEIGHT) of R) (fetch (REGION LEFT) of R) (fetch (REGION BOTTOM) of R))) else (GETPOSITION))) (ERROR "Unknown VSTATS option: " OPTION))) (if (NOT (EQUAL NEWVALUE OLDVALUE)) then (INSPECTW.REPLACE WINDOW OPTION NEWVALUE)))) ) ) (* * clock support stuff * *) (RPAQ? VStatsClockFont ) (RPAQ? VStatsClockReset? ) (RPAQ? VStatsClockTimer ) (DEFINEQ (VStatsClock-Display (LAMBDA NIL (* Koomen "12-Jan-87 16:37") (DECLARE (GLOBALVARS VStatsClockDay VStatsClockDayPos VStatsClockDisplaySeconds? VStatsClockFont VStatsClockHr VStatsClockHrPos VStatsClockMin VStatsClockMinPos VStatsClockMon VStatsClockMonPos VStatsClockRegion VStatsClockSec VStatsClockSecPos VStatsClockXPos VStatsClockYPos VStatsClockYr VStatsClockYrPos VStatsDsp)) (VStatsClock-Read) (SETQ VStatsClockXPos (fetch (REGION LEFT) of VStatsClockRegion)) (SETQ VStatsClockYPos (IPLUS (fetch (REGION BOTTOM) of VStatsClockRegion) (FONTPROP VStatsClockFont (QUOTE DESCENT)))) (MOVETO VStatsClockXPos VStatsClockYPos VStatsDsp) (DSPFONT VStatsClockFont VStatsDsp) (SETQ VStatsClockDayPos (DSPXPOSITION NIL VStatsDsp)) (VStatsClock-DisplayDigits VStatsClockDayPos VStatsClockDay) (BOUT VStatsDsp (CHARCODE "-")) (SETQ VStatsClockMonPos (DSPXPOSITION NIL VStatsDsp)) (VStatsClock-DisplayMonth VStatsClockMonPos VStatsClockMon) (BOUT VStatsDsp (CHARCODE "-")) (SETQ VStatsClockYrPos (DSPXPOSITION NIL VStatsDsp)) (VStatsClock-DisplayDigits VStatsClockYrPos VStatsClockYr) (BOUT VStatsDsp (CHARCODE " ")) (SETQ VStatsClockHrPos (DSPXPOSITION NIL VStatsDsp)) (VStatsClock-DisplayDigits VStatsClockHrPos VStatsClockHr) (BOUT VStatsDsp (CHARCODE ":")) (SETQ VStatsClockMinPos (DSPXPOSITION NIL VStatsDsp)) (VStatsClock-DisplayDigits VStatsClockMinPos VStatsClockMin) (if VStatsClockDisplaySeconds? then (BOUT VStatsDsp (CHARCODE ":")) (SETQ VStatsClockSecPos (DSPXPOSITION NIL VStatsDsp)) (VStatsClock-DisplayDigits VStatsClockSecPos VStatsClockSec))) ) (VStatsClock-DisplayDigits (LAMBDA (dspxpos n) (* HaKo " 1-Aug-85 10:10") (DECLARE (GLOBALVARS VStatsDsp)) (DSPXPOSITION dspxpos VStatsDsp) (BOUT VStatsDsp (IPLUS (IQUOTIENT (IREMAINDER n 100) 10) (CHARCODE "0"))) (BOUT VStatsDsp (IPLUS (IREMAINDER n 10) (CHARCODE "0")))) ) (VStatsClock-DisplayMonth (LAMBDA (dspxpos m) (* HaKo " 1-Aug-85 10:13") (DECLARE (GLOBALVARS VStatsDsp)) (PROG ((i (ADD1 (ITIMES 3 m))) (lbl "JanFebMarAprMayJunJulAugSepOctNovDec")) (DSPXPOSITION dspxpos VStatsDsp) (BOUT VStatsDsp (OR (NTHCHARCODE lbl i) (CHARCODE "?"))) (BOUT VStatsDsp (OR (NTHCHARCODE lbl (IPLUS i 1)) (CHARCODE "?"))) (BOUT VStatsDsp (OR (NTHCHARCODE lbl (IPLUS i 2)) (CHARCODE "?"))))) ) (VStatsClock-Init (LAMBDA NIL (* HaKo "13-Jun-86 00:44") (* * If the clock interval is not a FIXP or not positive, the clock display is disabled. (MENU VStatsOptionsMenu)) (DECLARE (GLOBALVARS VStatsClockDisplaySeconds? VStatsClockFont VStatsClockRegion)) (if (VStatsClock-Ticks?) then (LET ((datestr (DATE))) (if (NOT (FONTP VStatsClockFont)) then (SETQ VStatsClockFont (FONTCREATE (QUOTE (GACHA 12 BOLD))))) (if (NOT VStatsClockDisplaySeconds?) then (SETQ datestr (SUBSTRING datestr 1 -4))) (SETQ VStatsClockRegion (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (STRINGWIDTH datestr VStatsClockFont) HEIGHT _ (FONTHEIGHT VStatsClockFont)))) else (SETQ VStatsClockRegion NIL))) ) (VStatsClock-ReDisplay (LAMBDA NIL (* ; "Edited 18-Sep-87 00:40 by Koomen") (DECLARE (GLOBALVARS VStatsClockDay VStatsClockDayPos VStatsClockDisplaySeconds? VStatsClockFont VStatsClockHr VStatsClockHrPos VStatsClockMin VStatsClockMinPos VStatsClockMon VStatsClockMonPos VStatsClockReset? VStatsClockSec VStatsClockSecPos VStatsClockYPos VStatsClockYr VStatsClockYrPos VStatsDsp)) (PROG ((oldday VStatsClockDay) (oldmon VStatsClockMon) (oldyr VStatsClockYr) (oldhr VStatsClockHr) (oldmin VStatsClockMin) (oldsec VStatsClockSec)) (DSPFONT VStatsClockFont VStatsDsp) (DSPYPOSITION VStatsClockYPos VStatsDsp) (VStatsClock-Read) (if (NEQ VStatsClockDay oldday) then (SETQ VStatsClockReset? T)) (if (AND VStatsClockReset? (NEQ VStatsClockHr oldhr) (\NET.SETTIME)) then (SETQ VStatsClockReset? NIL) (VStatsClock-Read)) (if (NEQ VStatsClockDay oldday) then (VStatsClock-DisplayDigits VStatsClockDayPos VStatsClockDay)) (if (NEQ VStatsClockMon oldmon) then (VStatsClock-DisplayMonth VStatsClockMonPos VStatsClockMon)) (if (NEQ VStatsClockYr oldyr) then (VStatsClock-DisplayDigits VStatsClockYrPos VStatsClockYr)) (if (NEQ VStatsClockHr oldhr) then (VStatsClock-DisplayDigits VStatsClockHrPos VStatsClockHr)) (if (NEQ VStatsClockMin oldmin) then (VStatsClock-DisplayDigits VStatsClockMinPos VStatsClockMin)) (if (AND VStatsClockDisplaySeconds? (NEQ VStatsClockSec oldsec)) then (VStatsClock-DisplayDigits VStatsClockSecPos VStatsClockSec)))) ) (VStatsClock-Read (LAMBDA NIL (* Koomen "26-Mar-87 15:13") (DECLARE (GLOBALVARS VStatsClockDay VStatsClockHr VStatsClockMin VStatsClockMon VStatsClockSec VStatsClockYr)) (* APPLY (FUNCTION (LAMBDA (yr mon day hr min sec dst) (SETQ VStatsClockDay day) (SETQ VStatsClockMon mon) (SETQ VStatsClockYr yr) (SETQ VStatsClockHr hr) (SETQ VStatsClockMin min) (SETQ VStatsClockSec sec))) (\UNPACKDATE)) (VStatsClock-UnpackDate)) ) (VStatsClock-Ticks? (LAMBDA NIL (* Koomen "12-Jan-87 17:20") (DECLARE (GLOBALVARS VSTATS.CLOCK.INTERVAL VStatsClockDisplaySeconds? VStatsClockTimer)) (LET ((NTICKS (VStats-InitInterval (OR VStatsClockTimer (SETQ VStatsClockTimer (create VSTATSTIMERINFO))) VSTATS.CLOCK.INTERVAL (CONSTANT (TIMES 5 60))))) (SETQ VStatsClockDisplaySeconds? (AND NTICKS (ILESSP NTICKS (CLOCKTICKS 1 (QUOTE MINUTE))))) NTICKS)) ) (VStatsClock-UnpackDate (LAMBDA (D) (* Koomen "26-Mar-87 15:11") (* Adapted from \UNPACKDATE on Koto>Sources>IOCHAR dated "28-Jun-85 18:07:58") (DECLARE (GLOBALVARS VStatsClockDay VStatsClockHr VStatsClockMin VStatsClockMon VStatsClockSec VStatsClockYr)) (* bvm%: "28-Jun-85 18:07") (* Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds daylightp DayOfWeek) %. D defaults to current date. - DayOfWeek is zero for Monday - - D is first converted to the alto standard, a 32-bit unsigned integer, representing the number of seconds since jan 1, 1901-Gmt. We have to be a little tricky in our computations to avoid the sign bit.) (SETQ D (OR D (DAYTIME))) (PROG ((CHECKDLS \DayLightSavings) (DQ (IQUOTIENT (LOGAND MAX.FIXP (LRSH (LISP.TO.ALTO.DATE D) 1)) 30)) MONTH SEC HR DAY4 YDAY WDAY YEAR4 TOTALDAYS MIN DLS) (* DQ is number of minutes since day 0, getting us past the sign bit problem.) (SETQ SEC (IMOD (IPLUS D (CONSTANT (IDIFFERENCE 60 (IMOD MIN.FIXP 60)))) 60)) (SETQ MIN (IREMAINDER DQ 60)) (* No we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897) (SETQ HR (IREMAINDER (SETQ DQ (IDIFFERENCE (IPLUS (IQUOTIENT DQ 60) (CONSTANT (ITIMES 24 \4YearsDays))) \TimeZoneComp)) 24)) (SETQ TOTALDAYS (IQUOTIENT DQ 24)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* DAY4 = number of days since last leap year day 0) (SETQ DAY4 (IPLUS DAY4 (CDR (\DTSCAN DAY4 (QUOTE ((789 . 3) (424 . 2) (59 . 1) (0 . 0))))))) (* pretend every year is a leap year, adding one for days after Feb 28) (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* YEAR4 = number of years til that last leap year / 4) (SETQ YDAY (IREMAINDER DAY4 366)) (* YDAY is the ordinal day in the year (jan 1 = zero)) (SETQ WDAY (IREMAINDER (IPLUS TOTALDAYS 3) 7)) (COND ((AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) (* This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3) %, but we're cheating--1900 was not a leap year) (COND ((IGREATERP (SETQ HR (ADD1 HR)) 23) (* overflowed into the next day. This case is too hard (we might have overflowed the month, for example) %, so just go back and recompute) (SETQ TOTALDAYS (ADD1 TOTALDAYS)) (SETQ HR 0) (SETQ CHECKDLS NIL) (GO DTLOOP))))) (SETQ MONTH (\DTSCAN YDAY (QUOTE ((335 . 11) (305 . 10) (274 . 9) (244 . 8) (213 . 7) (182 . 6) (152 . 5) (121 . 4) (91 . 3) (60 . 2) (31 . 1) (0 . 0))))) (* Now return year, month, day, hr, min, sec) (* RETURN (LIST (IPLUS 1897 (ITIMES YEAR4 4) (IQUOTIENT DAY4 366)) (CDR MONTH) (ADD1 (IDIFFERENCE YDAY (CAR MONTH))) HR MIN SEC DLS WDAY)) (SETQ VStatsClockYr (IPLUS 1897 (ITIMES YEAR4 4) (IQUOTIENT DAY4 366))) (SETQ VStatsClockMon (CDR MONTH)) (SETQ VStatsClockDay (ADD1 (IDIFFERENCE YDAY (CAR MONTH)))) (SETQ VStatsClockHr HR) (SETQ VStatsClockMin MIN) (SETQ VStatsClockSec SEC))) ) ) (* * space support stuff * *) (RPAQ? VStatsSpaceDiskPages ) (RPAQ? VStatsSpaceFont ) (RPAQ? VStatsSpacePCTs ) (RPAQ? VStatsSpaceTimer ) (RPAQ? \LASTVMEMFILEPAGE 16383) (DEFINEQ (VStatsSpace-Display (LAMBDA NIL (* Koomen "12-Jan-87 16:37") (DECLARE (GLOBALVARS VStatsDsp VStatsSpaceFont VStatsSpacePCTs VStatsSpaceRegion)) (PROG (x (xoffset (fetch (REGION LEFT) of VStatsSpaceRegion)) (yoffset (IPLUS (fetch (REGION BOTTOM) of VStatsSpaceRegion) (FONTPROP VStatsSpaceFont (QUOTE HEIGHT))))) (DSPFONT VStatsSpaceFont VStatsDsp) (MOVETO xoffset yoffset VStatsDsp) (for PCT in VStatsSpacePCTs do (DSPXPOSITION (fetch (REGION LEFT) of (fetch (VSTATSPCTINFO LBLREGION) of PCT)) VStatsDsp) (printout VStatsDsp (fetch (VSTATSPCTINFO LABEL) of PCT))) (TERPRI VStatsDsp) (SETQ yoffset (DSPYPOSITION NIL VStatsDsp)) (VStatsSpace-Read) (for PCT in VStatsSpacePCTs do (replace (REGION BOTTOM) of (fetch (VSTATSPCTINFO LBLREGION) of PCT) with yoffset) (replace (REGION BOTTOM) of (fetch (VSTATSPCTINFO BARREGION) of PCT) with yoffset) (VStats-DisplayPct PCT T)))) ) (VStatsSpace-Init (LAMBDA NIL (* ; "Edited 22-Sep-87 16:22 by Koomen") (* * If the space interval is not a FIXP or not positive, the space display is disabled, and this function returns NIL. Otherwise it returns the region required for the space display.) (DECLARE (GLOBALVARS VSTATS.SPACE.SHOW.DISK? VStatsSpaceDisk VStatsSpaceDiskPages VStatsSpaceFont VStatsSpaceLevel VStatsSpacePCTs VStatsSpaceRegion)) (SETQ VStatsSpaceLevel 0) (if (VStatsSpace-Ticks?) then (if (NOT (FONTP VStatsSpaceFont)) then (SETQ VStatsSpaceFont (FONTCREATE (QUOTE (GACHA 10))))) (VStatsSpace-InitDisk) (VStatsSpace-InitPanicLevel) (SETQ VStatsSpacePCTs (VStats-CreatePCTs VStatsSpaceFont (if VStatsSpaceDisk then (QUOTE ((DATA . "Data") (ATOM . "Atom") (VMEM . "VMem") (DISK . "Disk"))) else (QUOTE ((DATA . "Data") (ATOM . "Atom") (VMEM . "VMem")))))) (SETQ VStatsSpaceRegion (VStats-GetPCTsRegion VStatsSpacePCTs)) else (SETQ VStatsSpaceRegion NIL))) ) (VStatsSpace-InitDisk (LAMBDA (ASK?) (* ; "Edited 22-Sep-87 16:30 by Koomen") (DECLARE (GLOBALVARS VSTATS.SPACE.PANIC.LEVEL VSTATS.SPACE.SHOW.DISK? VStatsSpaceDisk VStatsSpaceDiskPages VStatsSpacePanicLevel)) (if ASK? then (LET ((DISK (MENU (create MENU ITEMS _ (APPEND (QUOTE (*OFF* *DEFAULT* (""))) (SELECTQ (MACHINETYPE) ((DANDELION DAYBREAK DOVE) (for V in (VOLUMES) when (LISPDIRECTORYP V) collect V)) (DORADO (PROMPTPRINT "This takes a little while; hang on...") (ALTOPARTITIONS)) NIL)) CENTERFLG _ T)))) (if DISK then (SETQ VSTATS.SPACE.SHOW.DISK? (if (EQ DISK (QUOTE *OFF*)) then NIL elseif (EQ DISK (QUOTE *DEFAULT*)) then T else (SELECTQ (MACHINETYPE) ((DANDELION DAYBREAK DOVE) (PACKFILENAME (QUOTE HOST) (QUOTE DSK) (QUOTE DIRECTORY) DISK)) (DORADO (PACKFILENAME (QUOTE HOST) DISK)) NIL)))))) (SETQ VStatsSpaceDisk (if VSTATS.SPACE.SHOW.DISK? then (CAR (NLSETQ (DIRECTORYNAME (if (EQ VSTATS.SPACE.SHOW.DISK? T) then "{DSK}" else VSTATS.SPACE.SHOW.DISK?)))))) (SETQ VStatsSpaceDiskPages (if VStatsSpaceDisk then (DISKTOTALPAGES VStatsSpaceDisk))) (if (FIXP VStatsSpaceDiskPages) then VStatsSpaceDisk else (SETQ VStatsSpaceDisk NIL))) ) (VStatsSpace-InitPanicLevel (LAMBDA (ASK?) (* Koomen "12-Jan-87 17:21") (DECLARE (GLOBALVARS VSTATS.SPACE.PANIC.LEVEL VStatsSpacePanicLevel)) (if ASK? then (SETQ VSTATS.SPACE.PANIC.LEVEL (RNUMBER "Panic level (): "))) (SETQ VStatsSpacePanicLevel (if (AND (BOUNDP (QUOTE VSTATS.SPACE.PANIC.LEVEL)) (NUMBERP VSTATS.SPACE.PANIC.LEVEL) (LESSP VSTATS.SPACE.PANIC.LEVEL 100) (GREATERP VSTATS.SPACE.PANIC.LEVEL 0)) then (FIX (if (LESSP VSTATS.SPACE.PANIC.LEVEL 1) then (TIMES VSTATS.SPACE.PANIC.LEVEL 100) else VSTATS.SPACE.PANIC.LEVEL))))) ) (VStatsSpace-ReDisplay (LAMBDA NIL (* ; "Edited 18-Sep-87 00:51 by Koomen") (DECLARE (GLOBALVARS VSTATS.ALWAYS? VStatsDsp VStatsSpaceFont VStatsSpacePCTs VStatsSpacePanicLevel VStatsWindow)) (for pct in VStatsSpacePCTs bind NEWPCT first (VStatsSpace-Read) (SETQ VStatsSpaceLevel 0) (DSPFONT VStatsSpaceFont VStatsDsp) eachtime (SETQ VStatsSpaceLevel (IMAX VStatsSpaceLevel (SETQ NEWPCT (fetch (VSTATSPCTINFO NEWPCT) of pct)))) when (NEQ NEWPCT (fetch (VSTATSPCTINFO OLDPCT) of pct)) do (VStats-DisplayPct pct) finally (if (AND VStatsSpacePanicLevel (ILESSP VStatsSpacePanicLevel VStatsSpaceLevel)) then (FLASHWINDOW VStatsWindow (IDIFFERENCE VStatsSpaceLevel VStatsSpacePanicLevel)) (VStatsSpace-ShrinkInterval 5)))) ) (VStatsSpace-Read (LAMBDA NIL (* ; "Edited 18-Sep-87 00:53 by Koomen") (DECLARE (GLOBALVARS VStatsSpaceDiskPages VStatsSpacePCTs \LASTVMEMFILEPAGE)) (for PCT in VStatsSpacePCTs bind (heap _ (STORAGE.LEFT)) do (replace (VSTATSPCTINFO OLDPCT) of PCT with (fetch (VSTATSPCTINFO NEWPCT) of PCT)) (replace (VSTATSPCTINFO NEWPCT) of PCT with (SELECTQ (fetch (VSTATSPCTINFO NAME) of PCT) (DATA (FIX (FDIFFERENCE 100.5 (FTIMES 100.0 (fetch (SPACEDATA MDSFRAC) of heap))))) (ATOM (FIX (FDIFFERENCE 100.5 (FTIMES 100.0 (fetch (SPACEDATA ATOMFRAC) of heap))))) (VMEM (VStats-Percentage (VMEMSIZE) \LASTVMEMFILEPAGE)) (DISK (VStats-Percentage (IDIFFERENCE VStatsSpaceDiskPages (DISKFREEPAGES VStatsSpaceDisk)) VStatsSpaceDiskPages)) (SHOULDNT))))) ) (VStatsSpace-ShrinkInterval (LAMBDA (shrinkpct) (* Koomen "12-Jan-87 17:25") (DECLARE (GLOBALVARS VStatsSpaceTimer)) (PROG ((delta (IMAX 50 (IDIFFERENCE 100 (OR shrinkpct 25)))) (oldint (fetch (VSTATSTIMERINFO INTERVAL) of VStatsSpaceTimer)) newint) (SETQ newint (IMAX (IQUOTIENT (ITIMES oldint delta) 100) (CLOCKTICKS 30 (QUOTE SECONDS)))) (if (ILESSP newint oldint) then (replace (VSTATSTIMERINFO INTERVAL) of VStatsSpaceTimer with newint) (VStats-SetUpTimer VStatsSpaceTimer)))) ) (VStatsSpace-Ticks? (LAMBDA NIL (* Koomen "12-Jan-87 15:49") (DECLARE (GLOBALVARS VSTATS.SPACE.INTERVAL VStatsSpaceTimer)) (VStats-InitInterval (OR VStatsSpaceTimer (SETQ VStatsSpaceTimer (create VSTATSTIMERINFO))) VSTATS.SPACE.INTERVAL (CONSTANT (TIMES 15 60)))) ) ) (* * machine utilization support stuff * *) (RPAQ? VStatsMUtilFont ) (RPAQ? VStatsMUtilOrigState ) (RPAQ? VStatsMUtilPCTs ) (RPAQ? VStatsMUtilTimer ) (DEFINEQ (VStatsMUtil-Display (LAMBDA NIL (* Koomen "12-Jan-87 16:46") (DECLARE (GLOBALVARS VStatsDsp VStatsMUtilFont VStatsMUtilPCTs VStatsMUtilRegion)) (PROG (x (xoffset (fetch (REGION LEFT) of VStatsMUtilRegion)) (yoffset (IPLUS (fetch (REGION BOTTOM) of VStatsMUtilRegion) (FONTPROP VStatsMUtilFont (QUOTE HEIGHT))))) (DSPFONT VStatsMUtilFont VStatsDsp) (MOVETO xoffset yoffset VStatsDsp) (for PCT in VStatsMUtilPCTs do (DSPXPOSITION (fetch (REGION LEFT) of (fetch (VSTATSPCTINFO LBLREGION) of PCT)) VStatsDsp) (printout VStatsDsp (fetch (VSTATSPCTINFO LABEL) of PCT))) (TERPRI VStatsDsp) (SETQ yoffset (DSPYPOSITION NIL VStatsDsp)) (VStatsMUtil-Read) (for PCT in VStatsMUtilPCTs do (replace (REGION BOTTOM) of (fetch (VSTATSPCTINFO LBLREGION) of PCT) with yoffset) (replace (REGION BOTTOM) of (fetch (VSTATSPCTINFO BARREGION) of PCT) with yoffset) (VStats-DisplayPct PCT T)))) ) (VStatsMUtil-Init (LAMBDA NIL (* ; "Edited 27-Oct-87 16:47 by Koomen") (* * If the machine utilization interval is not a FIXP or not positive, the machine utilization display is disabled, and this function returns NIL. Otherwise it returns the region required for the machine utilization display.) (DECLARE (GLOBALVARS VStatsMUtilFont VStatsMUtilPCTs VStatsMUtilRegion)) (if (VStatsMUtil-Ticks?) then (VStatsMUtil-InitState) (if (NOT (FONTP VStatsMUtilFont)) then (SETQ VStatsMUtilFont (FONTCREATE (QUOTE (GACHA 10))))) (SETQ VStatsMUtilPCTs (VStats-CreatePCTs VStatsMUtilFont (QUOTE ((CPU . " CPU") (IO . " I/O") (GC . " GC") (SWAP . "Swap"))))) (SETQ VStatsMUtilRegion (VStats-GetPCTsRegion VStatsMUtilPCTs)) else (SETQ VStatsMUtilRegion NIL))) ) (VStatsMUtil-InitState (LAMBDA (DONT.SET.ORIG?) (* ; "Edited 30-Oct-87 01:07 by Koomen") (DECLARE (GLOBALVARS VSTATS.MUTIL.HYSTERESIS VStatsMUtilDiffState VStatsMUtilNextState VStatsMUtilOrigState VStatsMUtilStateRing)) (if (NULL VStatsMUtilOrigState) then (SETQ VStatsMUtilOrigState (SYSTATSREAD)) (SETQ VStatsMUtilDiffState (SYSTATSREAD)) (SETQ VStatsMUtilNextState) (SETQ VStatsMUtilStateRing)) (if VStatsMUtilStateRing then (* Break the old ring so it can be GC'd) (RPLACD VStatsMUtilStateRing)) (OR DONT.SET.ORIG? (SYSTATSREAD VStatsMUtilOrigState)) (if (AND (NUMBERP VSTATS.MUTIL.HYSTERESIS) (GREATERP VSTATS.MUTIL.HYSTERESIS 0)) then (* Build a ring of SYSTATS records) (SETQ VStatsMUtilStateRing (for i from 0 to VSTATS.MUTIL.HYSTERESIS collect (SYSTATSREAD))) (* Complete the circle) (RPLACD (LAST VStatsMUtilStateRing) VStatsMUtilStateRing) (SETQ VStatsMUtilNextState) else (SETQ VStatsMUtilNextState (SYSTATSREAD)) (SETQ VStatsMUtilStateRing))) ) (VStatsMUtil-ReDisplay (LAMBDA NIL (* ; "Edited 18-Sep-87 00:50 by Koomen") (DECLARE (GLOBALVARS VSTATS.ALWAYS? VStatsDsp VStatsMUtilFont VStatsMUtilPCTs VStatsWindow)) (VStatsMUtil-Read) (DSPFONT VStatsMUtilFont VStatsDsp) (for pct in VStatsMUtilPCTs when (NEQ (fetch (VSTATSPCTINFO NEWPCT) of pct) (fetch (VSTATSPCTINFO OLDPCT) of pct)) do (VStats-DisplayPct pct))) ) (VStatsMUtil-Read (LAMBDA NIL (* ; "Edited 30-Oct-87 01:09 by Koomen") (* * (To reinitialize, execute (SETQ VStatsMUtilOrigState))) (DECLARE (GLOBALVARS VStatsMUtilDiffState VStatsMUtilNextState VStatsMUtilOrigState VStatsMUtilPCTs VStatsMUtilStateRing)) (PROG (oldstate newstate stats io gc swap elapsed cpu) (if VStatsMUtilStateRing then (SETQ newstate (pop VStatsMUtilStateRing)) (SETQ oldstate (CAR VStatsMUtilStateRing)) else (SETQ newstate VStatsMUtilNextState) (SETQ oldstate VStatsMUtilOrigState)) (SYSTATSREAD newstate) (SETQ stats (SYSTATSDIFF oldstate newstate VStatsMUtilDiffState)) (SETQ io (IPLUS (IMAX 0 (SYSTATSPROP (QUOTE NETIOTIME) stats)) (IMAX 0 (SYSTATSPROP (QUOTE DISKIOTIME) stats)))) (SETQ gc (IMAX 0 (SYSTATSPROP (QUOTE GCTIME) stats))) (SETQ swap (IMAX 0 (SYSTATSPROP (QUOTE SWAPWAITTIME) stats))) (SETQ elapsed (IMAX (SYSTATSPROP (QUOTE ELAPSEDTIME) stats) (IPLUS io gc swap))) (SETQ cpu (IMAX 0 (IDIFFERENCE 100 (IPLUS (SETQ io (VStats-Percentage io elapsed)) (SETQ gc (VStats-Percentage gc elapsed)) (SETQ swap (VStats-Percentage swap elapsed)))))) (for PCT in VStatsMUtilPCTs do (replace (VSTATSPCTINFO OLDPCT) of PCT with (fetch (VSTATSPCTINFO NEWPCT) of PCT)) (replace (VSTATSPCTINFO NEWPCT) of PCT with (SELECTQ (fetch (VSTATSPCTINFO NAME) of PCT) (CPU cpu) (IO io) (GC gc) (SWAP swap) (SHOULDNT)))))) ) (VStatsMUtil-Ticks? (LAMBDA NIL (* Koomen "12-Jan-87 15:49") (DECLARE (GLOBALVARS VSTATS.MUTIL.INTERVAL VStatsMUtilTimer)) (VStats-InitInterval (OR VStatsMUtilTimer (SETQ VStatsMUtilTimer (create VSTATSTIMERINFO))) VSTATS.MUTIL.INTERVAL (CONSTANT (TIMES 5 60)))) ) ) (* * These ought to be system functions!!! * *) (DEFINEQ (ALTOPARTITIONP (LAMBDA (I) (* ; "Edited 19-Oct-87 12:20 by Koomen") (CONDITION-CASE (if (INFILEP (PACK* "{DSK" I "}SYS.BOOT;1")) then I) ((XCL:DEVICE-ERROR XCL:PATHNAME-ERROR XCL:FS-ERROR) NIL (RETFROM (QUOTE ALTOPARTITIONP) NIL)))) ) (ALTOPARTITIONS (LAMBDA NIL (* ; "Edited 19-Oct-87 11:34 by Koomen") (* ;;; "NASTY!!! Bypassing partition passwords") (SELECTQ (MACHINETYPE) (DORADO (RESETLST (RESETSAVE NIL (BQUOTE (PUTD \M44CHECKPASSWORD (\, (GETD (QUOTE \M44CHECKPASSWORD)))))) (PUTD (QUOTE \M44CHECKPASSWORD) (GETD (QUOTE TRUE))) (for I from 1 while (\TESTPARTITION I) when (ALTOPARTITIONP I) collect (PACK* "DSK" I)))) NIL)) ) (DISKUSEDPAGES (LAMBDA (DSK RECOMPUTE) (* Koomen "19-Jun-87 01:46") (* ;; "Hard-wired constant for Dorado partition size. Probably wrong, but adding up file sizes is way too slow (~ 8 secs)") (SELECTQ (MACHINETYPE) ((DANDELION DAYBREAK DOVE) (if (EQ (QUOTE DSK) (FILENAMEFIELD (DIRECTORYNAME "{DSK}") (QUOTE HOST))) then (* ;; "Local disk directory has been created") (IDIFFERENCE (VOLUMESIZE DSK RECOMPUTE) (DISKFREEPAGES DSK RECOMPUTE)))) (DORADO (if (SETQ DSK (CAR (NLSETQ (DIRECTORYNAME (OR DSK "{DSK}"))))) then (if RECOMPUTE then (for F in (FILDIR DSK) sum (GETFILEINFO F (QUOTE SIZE))) else (IMAX 0 (IDIFFERENCE 22750 (DISKFREEPAGES DSK RECOMPUTE)))))) NIL)) ) (DISKTOTALPAGES (LAMBDA (DSK RECOMPUTE) (* Koomen "19-Jun-87 01:46") (SELECTQ (MACHINETYPE) ((DANDELION DAYBREAK DOVE) (if (EQ (QUOTE DSK) (FILENAMEFIELD (DIRECTORYNAME "{DSK}") (QUOTE HOST))) then (* ;; "Local disk directory has been created") (VOLUMESIZE DSK RECOMPUTE))) (DORADO (if (SETQ DSK (CAR (NLSETQ (DIRECTORYNAME (OR DSK "{DSK}"))))) then (IPLUS (DISKFREEPAGES DSK RECOMPUTE) (DISKUSEDPAGES DSK RECOMPUTE)))) NIL)) ) (COVEREDWP (LAMBDA (WINDOW) (* ; "Edited 18-Sep-87 00:54 by Koomen") (if (OPENWP WINDOW) then (PROG ((R (fetch (WINDOW REG) of WINDOW)) (W (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW)))) LP (COND ((EQ W WINDOW) (RETURN NIL)) ((REGIONSINTERSECTP R (fetch (WINDOW REG) of W)) (RETURN T)) ((SETQ W (fetch (WINDOW NEXTW) of W)) (GO LP)))))) ) ) (* * Initialize on LOAD * *) (RPAQQ BackgroundMenu NIL) (ADDTOVAR BackgroundMenuCommands ("VStats" (QUOTE (VSTATS (QUOTE On))) "Running display of clock and/or space utilization") ) (DECLARE%: DONTEVAL@LOAD DOCOPY (COND ((OR VSTATS.CLOCK.INTERVAL VSTATS.SPACE.INTERVAL VSTATS.MUTIL.INTERVAL) (VSTATS (QUOTE ON)))) ) (PUTPROPS VSTATS COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3227 4471 (VSTATS 3237 . 4469)) (5853 18059 (VStats-CenterRegion 5863 . 6492) ( VStats-CreatePCTs 6494 . 7620) (VStats-Display 7622 . 8489) (VStats-DisplayPct 8491 . 9706) ( VStats-DrawLine 9708 . 10040) (VStats-GetPCTsRegion 10042 . 10819) (VStats-Init 10821 . 14114) ( VStats-InitInterval 14116 . 14529) (VStats-MouseWait 14531 . 14886) (VStats-Percentage 14888 . 15652) (VStats-ReDisplay? 15654 . 16503) (VStats-SetDisplayColor 16505 . 16837) (VStats-SetUpTimer 16839 . 17240) (VStats-TimerExpired? 17242 . 18057)) (18123 25315 (VStatsOptions-Inspect 18133 . 19137) ( VStatsOptions-FetchFn 19139 . 20546) (VStatsOptions-PropCommandFn 20548 . 21495) ( VStatsOptions-PropPrintFn 21497 . 22073) (VStatsOptions-PropertiesFn 22075 . 22157) ( VStatsOptions-RNumber 22159 . 22385) (VStatsOptions-SelectionFn 22387 . 22545) (VStatsOptions-StoreFn 22547 . 24055) (VStatsOptions-ValueCommandFn 24057 . 25313)) (25429 33683 (VStatsClock-Display 25439 . 26994) (VStatsClock-DisplayDigits 26996 . 27270) (VStatsClock-DisplayMonth 27272 . 27682) ( VStatsClock-Init 27684 . 28360) (VStatsClock-ReDisplay 28362 . 29795) (VStatsClock-Read 29797 . 30218) (VStatsClock-Ticks? 30220 . 30628) (VStatsClock-UnpackDate 30630 . 33681)) (33859 39576 ( VStatsSpace-Display 33869 . 34743) (VStatsSpace-Init 34745 . 35678) (VStatsSpace-InitDisk 35680 . 36826) (VStatsSpace-InitPanicLevel 36828 . 37363) (VStatsSpace-ReDisplay 37365 . 38083) ( VStatsSpace-Read 38085 . 38822) (VStatsSpace-ShrinkInterval 38824 . 39307) (VStatsSpace-Ticks? 39309 . 39574)) (39733 44304 (VStatsMUtil-Display 39743 . 40617) (VStatsMUtil-Init 40619 . 41368) ( VStatsMUtil-InitState 41370 . 42327) (VStatsMUtil-ReDisplay 42329 . 42698) (VStatsMUtil-Read 42700 . 44036) (VStatsMUtil-Ticks? 44038 . 44302)) (44355 46456 (ALTOPARTITIONP 44365 . 44600) (ALTOPARTITIONS 44602 . 45000) (DISKUSEDPAGES 45002 . 45670) (DISKTOTALPAGES 45672 . 46099) (COVEREDWP 46101 . 46454) )))) STOP \ No newline at end of file diff --git a/lispusers/VSTATS.IP b/lispusers/VSTATS.IP new file mode 100644 index 00000000..0040e211 Binary files /dev/null and b/lispusers/VSTATS.IP differ diff --git a/lispusers/VSTATS.TEDIT b/lispusers/VSTATS.TEDIT new file mode 100644 index 00000000..83bae6bb Binary files /dev/null and b/lispusers/VSTATS.TEDIT differ diff --git a/lispusers/WALKFILES b/lispusers/WALKFILES new file mode 100644 index 00000000..8d2cd006 --- /dev/null +++ b/lispusers/WALKFILES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "27-Oct-89 15:35:24" {ICE}LISPUSERS>MEDLEY>WALKFILES.;1 3051 changes to%: (VARS WALKFILESCOMS) previous date%: "13-Oct-89 16:26:34" {ICE}LISPUSERS>KOTO>WALKFILES.;2) (* " Copyright (c) 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT WALKFILESCOMS) (RPAQQ WALKFILESCOMS ((FNS WALKDEFS WALKFILES) (PROP MAKEFILE-ENVIRONMENT (QUOTE WALKFILES)))) (DEFINEQ (WALKDEFS (LAMBDA (PATTERN NAMES TYPE EDITCOMMANDS CONFIRMFLG QUIETFLG RETFROMFN) (* Koomen "13-Oct-89 16:23") (* ;; "Searches the defs of each name on NAMES for PATTERN. When found, invokes editor on the object with EDITCOMMANDS. If CONFIRMFLG, prompts for confirmation first before invoking editor. If not QUIETFLG, provides feedback. If EDITCOMMANDS = NIL, uses `((LP (F ,PATTERN N) P)), i.e. prints each occurrance in the def. If EDITCOMMANDS = T, uses `((EXAM ,PATTERN)), i.e. let editor walk through each occurrance.") (for NAME inside NAMES bind EDITFPAT EDITCOMS PRETTYTYPE CONFIRMED DONE first (SETQ EDITFPAT (EDITFPAT (if (AND (LITATOM PATTERN) (NULL EDITCOMMANDS)) then (BQUOTE (-- (\, PATTERN) --)) else PATTERN))) (SETQ EDITCOMS (if (NULL EDITCOMMANDS) then (BQUOTE ((LP (F (\, EDITFPAT) N) P))) elseif (EQ EDITCOMMANDS T) then (BQUOTE ((EXAM (\, EDITFPAT)))) else EDITCOMMANDS)) (SETQ PRETTYTYPE QUIETFLG) (SETQ CONFIRMED (OR (NULL CONFIRMFLG) (NULL EDITCOMMANDS) (NEQ EDITCOMMANDS T))) when (if (NOT (FMEMB NAME DONE)) then (push DONE NAME) (if (OR (HASDEF NAME TYPE (QUOTE CURRENT)) (HASDEF NAME TYPE (QUOTE SAVED))) then (EDITFINDP (GETDEF NAME TYPE NIL (QUOTE DONTCOPY)) EDITFPAT T))) do (if (NOT PRETTYTYPE) then (SETQ PRETTYTYPE (OR (CADDR (SEARCHPRETTYTYPELST TYPE)) (L-CASE TYPE T))) (PRINTOUT NIL PRETTYTYPE ":" T)) (if (NOT QUIETFLG) then (PRINTOUT NIL "--> " NAME T)) (if (ARGTYPE EDITCOMS) then (APPLY* EDITCOMS NAME TYPE) elseif (OR CONFIRMED (MOUSECONFIRM "Edit? ")) then (EDITDEF NAME TYPE NIL EDITCOMS) elseif (NOT (MOUSECONFIRM "Continue?")) then (RETFROM (OR RETFROMFN (QUOTE WALKDEFS)))))) ) (WALKFILES (LAMBDA (PATTERN FILES EDITCOMMANDS CONFIRMFLG QUIETFLG FILEPACKAGETYPES) (* Koomen "13-Oct-89 16:24") (* ;; "If EDITCOMS=NIL, use `((LP (F ,PATTERN N) P))") (* ;; "If EDITCOMS=T, use `((EXAM ,PATTERN))") (* ;; "If EDITCOMS=atomic, APPLY it to appropriate objects") (* ;; "If FILES=NIL, use FILELST") (* ;; "If FILEPACKAGETYPES=NIL, use atomic entries on FILEPKGTYPES") (DECLARE (GLOBALVARS FILELST FILEPKGTYPES)) (for FILE inside (OR FILES FILELST) bind (TYPES _ (OR FILEPACKAGETYPES (for TYPE in FILEPKGTYPES when (SEARCHPRETTYTYPELST TYPE) collect TYPE))) do (if (NOT QUIETFLG) then (printout T "---- Searching file " FILE T)) (for TYPE in TYPES bind NAMES when (SETQ NAMES (FILECOMSLST FILE TYPE)) do (BLOCK) (WALKDEFS PATTERN NAMES TYPE EDITCOMMANDS CONFIRMFLG QUIETFLG (FUNCTION WALKFILES))))) ) ) (PUTPROPS WALKFILES COPYRIGHT ("Johannes A. G. M. Koomen" 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (499 2963 (WALKDEFS 509 . 2143) (WALKFILES 2145 . 2961))))) STOP \ No newline at end of file diff --git a/lispusers/WALKFILES.TEDIT b/lispusers/WALKFILES.TEDIT new file mode 100644 index 00000000..13aedbe9 Binary files /dev/null and b/lispusers/WALKFILES.TEDIT differ diff --git a/lispusers/WDWHACKS b/lispusers/WDWHACKS new file mode 100644 index 00000000..0e97cf4c --- /dev/null +++ b/lispusers/WDWHACKS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "18-Feb-88 10:06:18" |{EG:PARC:XEROX}LISP>USERS>WDWHACKS.;1| 3524 changes to%: (FNS Inspecticide) previous date%: "19-Mar-86 23:25:10" |{IE:PARC:XEROX}LYRIC>LISPUSERS>WDWHACKS.;1|) (PRETTYCOMPRINT WDWHACKSCOMS) (RPAQQ WDWHACKSCOMS ((FNS CLOSE.WINDOWS.IN.REGION SHAPEW.AND.SAVE SHAPEW.POP SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW Inspecticide) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (RPLACA (CDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (QUOTE (QUOTE SHAPEW.AND.SAVE))) (RPLACD (CDDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (COPY (QUOTE ((SUBITEMS ("PopShape" (QUOTE SHAPEW.POP) "Return a reshaped window to its original form.")))))) (SETQ WindowMenu NIL) (SETQ BackgroundMenuCommands (CONS (COPY (QUOTE ("SlamWs" (QUOTE (CLOSE.WINDOWS.IN.REGION)) "Close all the windows in a region of the screen." (SUBITEMS ("Inspectors" (QUOTE (Inspecticide)) "Close only inspector windows."))))) BackgroundMenuCommands)) (SETQ BackgroundMenu NIL) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW)))) ) (DEFINEQ (CLOSE.WINDOWS.IN.REGION (LAMBDA (R) (* edited%: "12-May-85 22:27") (OR R (SETQ R (GETREGION))) (for W in (OPENWINDOWS) do (COND ((INTERSECTREGIONS R (WINDOWPROP W (QUOTE REGION))) (CLOSEW W))))) ) (SHAPEW.AND.SAVE (LAMBDA (WINDOW NEWREGION) (* Jeff.Shrager "18-Mar-86 18:01") (WINDOWPROP WINDOW (QUOTE OLD.SHAPE) (WINDOWREGION WINDOW)) (SHAPEW WINDOW NEWREGION)) ) (SHAPEW.POP (LAMBDA (WINDOW) (* Jeff.Shrager "18-Mar-86 18:01") (COND ((WINDOWPROP WINDOW (QUOTE OLD.SHAPE)) (SHAPEW WINDOW (WINDOWPROP WINDOW (QUOTE OLD.SHAPE) (WINDOWREGION WINDOW)))))) ) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW (LAMBDA NIL (* Jeff.Shrager "18-Mar-86 18:48") (* * This is the universe's worst known hack. Whoever wrote ATTACHEDWINDOW put hard constants into the ATTACHWINDOW fn which get inserted into the PASSTOMAINCOMS prop of attached windows. This should be a var so that we can tell it what messages to pass or not in a general case. This function creates an attached window and (you'll love this) smashes the prop's value so that the const in the ATTACHWINDOW function is smashed so that everything works pretty generally. Yuko!!!) (LET ((TEMPWINDOW (CREATEW (QUOTE (0 0 10 10)))) MAINWINDOW) (ATTACHWINDOW TEMPWINDOW (SETQ MAINWINDOW (CREATEW (QUOTE (0 0 10 10)))) (QUOTE TOP)) (RPLACD (WINDOWPROP TEMPWINDOW (QUOTE PASSTOMAINCOMS)) (APPEND (COPY (QUOTE (SHAPEW.POP SHAPEW.AND.SAVE))) (CDR (WINDOWPROP TEMPWINDOW (QUOTE PASSTOMAINCOMS))))) (CLOSEW TEMPWINDOW) (CLOSEW MAINWINDOW))) ) (Inspecticide (LAMBDA NIL (* ; "Edited 18-Feb-88 09:48 by Rao") (for w in (OPENWINDOWS) when (AND (EQ (QUOTE INSPECTW.REPAINTFN) (WINDOWPROP w (QUOTE REPAINTFN))) (STRPOS "Inspect" (WINDOWPROP w (QUOTE TITLE)))) do (CLOSEW w))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPLACA (CDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (QUOTE (QUOTE SHAPEW.AND.SAVE))) (RPLACD (CDDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (COPY (QUOTE ((SUBITEMS ("PopShape" (QUOTE SHAPEW.POP) "Return a reshaped window to its original form.")))))) (SETQ WindowMenu NIL) (SETQ BackgroundMenuCommands (CONS (COPY (QUOTE ("SlamWs" (QUOTE (CLOSE.WINDOWS.IN.REGION)) "Close all the windows in a region of the screen." (SUBITEMS ("Inspectors" (QUOTE (Inspecticide)) "Close only inspector windows."))))) BackgroundMenuCommands)) (SETQ BackgroundMenu NIL) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW) ) (PUTPROPS WDWHACKS COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1094 2834 (CLOSE.WINDOWS.IN.REGION 1104 . 1305) (SHAPEW.AND.SAVE 1307 . 1478) ( SHAPEW.POP 1480 . 1673) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW 1675 . 2597) (Inspecticide 2599 . 2832 ))))) STOP \ No newline at end of file diff --git a/lispusers/WDWHACKS.TEDIT b/lispusers/WDWHACKS.TEDIT new file mode 100644 index 00000000..099b7151 Binary files /dev/null and b/lispusers/WDWHACKS.TEDIT differ diff --git a/lispusers/WHO-LINE b/lispusers/WHO-LINE new file mode 100644 index 00000000..60862b8a --- /dev/null +++ b/lispusers/WHO-LINE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Feb-89 15:13:40" |{EG:PARC:XEROX}LISP>USERS>WHO-LINE.;10| 65795 changes to%: (FNS WHO-LINE-CURRENT-DIRECTORY) previous date%: "30-Jun-88 15:41:39" |{EG:PARC:XEROX}LISP>USERS>WHO-LINE.;9|) (* " Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WHO-LINECOMS) (RPAQQ WHO-LINECOMS ((* ;;; "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (* ;; "") (* ;; "Public fn for manipulating the who-line") (FNS INSTALL-WHO-LINE-OPTIONS) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some fns that compute useful values for the who-line, and act as nice button event fns") (* ;; "") (* ;; "Showing / changing the current logged in user") (FNS WHO-LINE-USERNAME WHO-LINE-CHANGE-USER WHO-LINE-USER-AFTER-LOGIN) (VARIABLES *WHO-LINE-CURRENT-USER* *WHO-LINE-USER-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDVARS (\SYSTEMCACHEVARS *WHO-LINE-CURRENT-USER*) (\AFTERLOGINFNS WHO-LINE-USER-AFTER-LOGIN))) (* ;; "") (* ;; "Showing the current machine name") (FNS WHO-LINE-HOST-NAME) (VARIABLES *WHO-LINE-HOST-NAME* *WHO-LINE-HOST-NAME-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDVARS (\SYSTEMCACHEVARS *WHO-LINE-HOST-NAME*))) (* ;; "") (* ;; "Showing / changing the current tty process package") (FNS CURRENT-TTY-PACKAGE SET-PACKAGE-INTERACTIVELY SET-TTY-PACKAGE-INTERACTIVELY) (VARIABLES *WHO-LINE-PACKAGE-NAME-CACHE* *WHO-LINE-PACKAGE-ENTRY*) (* ;; "") (* ;; "Showing / changing the current tty process readtable") (FNS CURRENT-TTY-READTABLE-NAME SET-READTABLE-INTERACTIVELY SET-TTY-READTABLE-INTERACTIVELY) (VARIABLES *WHO-LINE-READTABLE-ENTRY*) (* ;; "") (* ;; "Showing / changing the current tty process") (FNS WHO-LINE-TTY-PROCESS CHANGE-TTY-PROCESS-INTERACTIVELY) (VARIABLES *WHO-LINE-TTY-PROC-ENTRY*) (* ;; "") (* ;; "Showing / changing the currently connected directory") (FNS WHO-LINE-CURRENT-DIRECTORY SET-CONNECTED-DIRECTORY-INTERACTIVELY) (VARIABLES *WHO-LINE-DIRECTORIES* *WHO-LINE-LAST-DIRECTORY* *WHO-LINE-DIRECTORY-ENTRY*) (* ;; "") (* ;; "Showing / changing the current VMem utilization") (FNS WHO-LINE-VMEM WHO-LINE-SAVE-VMEM) (VARIABLES *WHO-LINE-LAST-VMEM* *WHO-LINE-VMEM-ENTRY*) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILES (LOADCOMP) LLFAULT MODARITH) (P (CHECKIMPORTS (QUOTE (LLPARAMS)) T))) (* ;; "") (* ;; "Showing the percent of symbol-space currently used") (FUNCTIONS WHO-LINE-SYMBOL-SPACE) (VARIABLES *WHO-LINE-SYMBOL-SPACE* *WHO-LINE-SYMBOL-SPACE-ENTRY*) (* ;; "") (* ;; "Showing the current time") (FNS WHO-LINE-TIME WHO-LINE-SET-TIME) (VARIABLES *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME* *WHO-LINE-TIME-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-TIMER* SECONDS)))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some as yet un-debugged entries. Try at your own risk.") (* ;; "") (* ;; "Showing the machine-active entry") (FNS WHO-LINE-SHOW-ACTIVE \UPDATE-WHO-LINE-ACTIVE-FLAG \PERIODICALLY-WHO-LINE-SHOW-ACTIVE) (VARIABLES *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-SHOW-ACTIVE-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-ACTIVE-TIMER* MILLISECONDS)))) (* ;; "") (* ;; "Showing / changing the current reader profile") (FNS CURRENT-PROFILE SET-PROFILE-INTERACTIVELY SET-TTY-PROFILE-INTERACTIVELY) (VARIABLES *WHO-LINE-PROFILE-ENTRY*) (* ;; "") (* ;; "Showing the state of the current TTY process") (FNS WHO-LINE-TTY-STATE WHO-LINE-WHAT-IS-RUNNING) (VARIABLES *WHO-LINE-STATE* *WHO-LINE-STATE-UNINTERESTING-FNS* *WHO-LINE-TTY-STATE-ENTRY*) (PROP WHO-LINE-STATE AWAIT.EVENT BLOCK EXCHANGEPUPS GETPUP SENDPUP WAIT.FOR.TTY \TTYBACKGROUND \WAITFORSYSBUFP \\getkey \SENDLEAF PUTSEQUIN \LEAF.READPAGES) (* ;;; "----------------------------------------------------------------------") (* ;;; "Default options for the who-line") (VARIABLES *WHO-LINE-ENTRIES* *WHO-LINE-ENTRY-REGISTRY* *WHO-LINE-ANCHOR* *WHO-LINE-NAME-FONT* *WHO-LINE-VALUE-FONT* *WHO-LINE-DISPLAY-NAMES?* *WHO-LINE-COLOR* *WHO-LINE-TITLE* *WHO-LINE-BORDER* *WHO-LINE-UPDATE-INTERVAL*) (* ;;; "----------------------------------------------------------------------") (* ;;; "Internal fns") (FNS REDISPLAY-WHO-LINE PERIODICALLY-UPDATE-WHO-LINE SETUP-WHOLINE-TIMER UPDATE-WHO-LINE WHEN-WHO-LINE-SELECTED-FN WHO-LINE-CONTROL-SELECT WHO-LINE-COPY-INSERT) (FNS WHO-LINE-REDISPLAY-INTERRUPT) (VARIABLES *WHO-LINE* *WHO-LINE-UPDATE-TIMER*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-UPDATE-TIMER* TICKS)))) (FUNCTIONS INVERT-WHO-LINE-ENTRY) (DECLARE%: DONTCOPY (RECORDS WHO-LINE-ENTRY)) (* ; "Macros that lets us lock down the Who-Line while we evaluate some forms") (FUNCTIONS WITH-WHO-LINE WITH-AVAILABLE-WHO-LINE) (* ;;; "----------------------------------------------------------------------") (* ;;; "Initialize the who-line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (P (INSTALL-WHO-LINE-OPTIONS)) (ADDVARS (BACKGROUNDFNS PERIODICALLY-UPDATE-WHO-LINE))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT WHO-LINE) (PROP FILETYPE WHO-LINE)))) (* ;;; "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (* ;; "") (* ;; "Public fn for manipulating the who-line") (DEFINEQ (INSTALL-WHO-LINE-OPTIONS (LAMBDA NIL (* ; "Edited 16-May-88 14:19 by smL") (* ;;; "") (* ;;; "Install new descriptions of the values to be displayed in the who-line.") (* ;;; "Each description is a list of four items: then name of the value, a form that will compute the value, the maximum number of characters in the resulting value, and an optional function that will be FUNCALLed if/when that item is moused in the who-line.") (* ;;; "") (* ;; "") (* ;; "Create the who-line window if it isn't there already") (* ;; "") (if (NOT (AND (BOUNDP '*WHO-LINE*) (WINDOWP *WHO-LINE*))) then (SETQ *WHO-LINE* (CREATEW (CREATEREGION 0 0 100 20) NIL NIL T)) (WINDOWPROP *WHO-LINE* 'LOCK (CREATE.MONITORLOCK "WHO-LINE"))) (WITH-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'VALID NIL) (OPENW *WHO-LINE*) (LET ((CURRENT-LEFT 0) ENTRIES) (* ;; "") (* ;; "Make sure the who-line has all the correct window properties") (* ;; "") (WINDOWPROP *WHO-LINE* 'REPAINTFN 'REDISPLAY-WHO-LINE) (WINDOWPROP *WHO-LINE* 'BUTTONEVENTFN 'WHEN-WHO-LINE-SELECTED-FN) (WINDOWPROP *WHO-LINE* 'DISPLAY-NAMES? *WHO-LINE-DISPLAY-NAMES?*) (WINDOWPROP *WHO-LINE* 'ANCHOR *WHO-LINE-ANCHOR*) (WINDOWPROP *WHO-LINE* 'NAME-FONT *WHO-LINE-NAME-FONT*) (WINDOWPROP *WHO-LINE* 'VALUE-FONT *WHO-LINE-VALUE-FONT*) (WINDOWPROP *WHO-LINE* 'COLOR *WHO-LINE-COLOR*) (WINDOWPROP *WHO-LINE* 'TITLE *WHO-LINE-TITLE*) (WINDOWPROP *WHO-LINE* 'BORDER *WHO-LINE-BORDER*) (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL (FIX (TIMES *WHO-LINE-UPDATE-INTERVAL* \RCLKMILLISECOND))) (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*)) (* ;; "") (* ;; "Create and fill in the who-line entries that go on the window.") (* ;; "This entails computing the positions of the entries in the who-line") (* ;; "") (SETQ ENTRIES (for ITEM in *WHO-LINE-ENTRIES* bind (DISPLAY-NAMES? _ (WINDOWPROP *WHO-LINE* 'DISPLAY-NAMES?)) (VALUE-FONT _ (WINDOWPROP *WHO-LINE* 'VALUE-FONT)) (NAME-FONT _ (WINDOWPROP *WHO-LINE* 'NAME-FONT)) collect (LET ((ENTRY (create WHO-LINE-ENTRY NAME _ (CL:FIRST ITEM) FORM _ (CL:SECOND ITEM)))) (with WHO-LINE-ENTRY ENTRY (* ;; "") (* ;; "Leave a little space (the size of an %"A%") between the previous value and this name") (* ;; "") (SETQ NAME-START (PLUS (STRINGWIDTH "A" VALUE-FONT) CURRENT-LEFT)) (if DISPLAY-NAMES? then (SETQ CURRENT-LEFT (PLUS NAME-START (STRINGWIDTH NAME NAME-FONT)))) (* ;; "") (* ;; "The value is displayed after the name, with a little space between them") (* ;; "") (SETQ VALUE-START (PLUS CURRENT-LEFT (STRINGWIDTH "A" VALUE-FONT))) (SETQ VALUE-END (PLUS VALUE-START (TIMES (CL:THIRD ITEM) (STRINGWIDTH "A" VALUE-FONT))) ) (* ; "Leave a little extra space after each value") (SETQ CURRENT-LEFT (PLUS VALUE-END (STRINGWIDTH "A" VALUE-FONT))) (* ;; "") (* ;; "Set the when-selected-fn") (* ;; "") (SETQ WHEN-SELECTED-FN (CL:FOURTH ITEM)) (* ;; "") (* ;; "And the reset-form") (* ;; "") (SETQ RESET-FORM (CL:FIFTH ITEM)) (* ;; "") (* ;; "And return the filled in entry") (* ;; "") ENTRY)))) (* ;; "") (* ;; "Reshape the window to hold the new in info") (* ;; "") (LET ((HORIZ-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) then (fetch XCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) thereis (MEMB anchor '(:LEFT :CENTER :JUSTIFY :RIGHT))) (ERROR "No horizontal anchor specified" (WINDOWPROP *WHO-LINE* 'ANCHOR))))) (VERT-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) then (fetch YCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) thereis (MEMB anchor '(:TOP :BOTTOM))) (ERROR "No vertical anchor specified" (WINDOWPROP *WHO-LINE* 'ANCHOR))))) (WIDTH (WIDTHIFWINDOW CURRENT-LEFT (WINDOWPROP *WHO-LINE* 'BORDER))) (HEIGHT (HEIGHTIFWINDOW (MAX (FONTPROP (WINDOWPROP *WHO-LINE* 'NAME-FONT) 'HEIGHT) (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'HEIGHT)) (WINDOWPROP *WHO-LINE* 'TITLE) (WINDOWPROP *WHO-LINE* 'BORDER)))) (* ;; "") (* ;; "Make sure the window fits on the screen (i.e. doesn't run off the edge, and is justified against left and right sides if the user wants).") (* ;; "If the items don't fit, change the length of each item so they do.") (* ;; "Do this by distributing the %"pain%" among all the entries in the who-line.") (* ;; "") (if (OR (GREATERP WIDTH SCREENWIDTH) (EQ HORIZ-ANCHOR :JUSTIFY)) then (for ENTRY in ENTRIES bind (REMAINING-ADJUSTMENT _ (DIFFERENCE SCREENWIDTH WIDTH)) (REMAINING-VALUE-SIZE _ (for ENTRY in ENTRIES sum (with WHO-LINE-ENTRY ENTRY (DIFFERENCE VALUE-END VALUE-START)))) (RUNNING-ADJUSTMENT _ 0) ENTRY-ADJUSTMENT do (with WHO-LINE-ENTRY ENTRY (* ;; "") (* ;; "Figure out how much this entry value gets adjusted.") (* ;; "") (* ;; "Note that, by keeping track of the remaing adjustment needed, we avoid problems with round-off.") (* ;; "") (SETQ ENTRY-ADJUSTMENT (QUOTIENT (TIMES REMAINING-ADJUSTMENT (DIFFERENCE VALUE-END VALUE-START) ) REMAINING-VALUE-SIZE)) (* ;; "") (* ;; "Update this entry size & position") (* ;; "") (add NAME-START RUNNING-ADJUSTMENT) (add VALUE-START RUNNING-ADJUSTMENT) (add RUNNING-ADJUSTMENT ENTRY-ADJUSTMENT) (add VALUE-END RUNNING-ADJUSTMENT)) finally (SETQ WIDTH SCREENWIDTH))) (* ;; "") (* ;; "Set the who-line window size so it can't be reshaped") (* ;; "") (WINDOWPROP *WHO-LINE* 'MAXSIZE (CONS WIDTH HEIGHT)) (WINDOWPROP *WHO-LINE* 'MINSIZE (CONS WIDTH HEIGHT)) (* ;; "") (* ;; "The anchor-point decribes where on the screen the who-line should be placed.") (* ;; "The CAR should be one of :JUSTIFY, :LEFT, :RIGHT, or :CENTER.") (* ;; "The CADR should be one of :TOP, :BOTTOM, or :CENTER.") (* ;; "") (SHAPEW *WHO-LINE* (CREATEREGION (SELECTQ HORIZ-ANCHOR ((:JUSTIFY :LEFT) 0) (:RIGHT (DIFFERENCE SCREENWIDTH WIDTH)) (:CENTER (QUOTIENT (DIFFERENCE SCREENWIDTH WIDTH) 2)) HORIZ-ANCHOR) (SELECTQ VERT-ANCHOR (:TOP (DIFFERENCE SCREENHEIGHT HEIGHT)) (:BOTTOM 0) (:CENTER (QUOTIENT (DIFFERENCE SCREENHEIGHT HEIGHT ) 2)) VERT-ANCHOR) WIDTH HEIGHT))) (* ;; "") (* ;; "The values should be centered vertically between the top and the bottom of the window") (* ;; "") (WINDOWPROP *WHO-LINE* 'VALUE-BOTTOM (PLUS (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'DESCENT) (QUOTIENT (DIFFERENCE (WINDOWPROP *WHO-LINE* 'HEIGHT) (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'HEIGHT)) 2))) (* ;; "Cache a bitmap that is the same size as the inside of the who-line, and a display stream onto the bitmap.") (WINDOWPROP *WHO-LINE* 'TEMP-STREAM (DSPCREATE (BITMAPCREATE (WINDOWPROP *WHO-LINE* 'WIDTH) (WINDOWPROP *WHO-LINE* 'HEIGHT)))) (* ;; "") (* ;; "Install the entries") (* ;; "") (WINDOWPROP *WHO-LINE* 'ENTRIES ENTRIES) (* ;; "") (* ;; "Finally, update the window") (* ;; "") (REDISPLAY-WHO-LINE *WHO-LINE*) (WINDOWPROP *WHO-LINE* 'VALID T))))) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some fns that compute useful values for the who-line, and act as nice button event fns") (* ;; "") (* ;; "Showing / changing the current logged in user") (DEFINEQ (WHO-LINE-USERNAME (LAMBDA NIL (* ; "Edited 30-Jun-88 15:41 by smL") (* ;;; "") (* ;;; "Return the name of the currently logged in user. Avoid consing up a new string if possible.") (* ;;; "") (* ;; "The cached value in *WHO-LINE-CURRENT-USER* gets invalidated by an entry on the list of \SYSTEMCACHEVARS, and by a function on the list of \AFTERLOGINFNS") (* ;; "") (DECLARE (GLOBALVARS *WHO-LINE-CURRENT-USER*)) (if *WHO-LINE-CURRENT-USER* then *WHO-LINE-CURRENT-USER* else (SETQ *WHO-LINE-CURRENT-USER* (USERNAME NIL NIL T))))) (WHO-LINE-CHANGE-USER (LAMBDA NIL (* smL "17-Nov-86 11:19") (* ;;; "") (* ;;; "Change the currently logged in user") (* ;;; "") (if (MENU (create MENU TITLE _ "Change user?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T "Log in as a different user") ("No" NIL "Don't change the current user"))))) then (LOGIN))) ) (WHO-LINE-USER-AFTER-LOGIN (LAMBDA (HOST USER) (* ; "Edited 30-Jun-88 15:34 by smL") (CL:WHEN (NULL HOST) (SETQ *WHO-LINE-CURRENT-USER* NIL)))) ) (DEFGLOBALVAR *WHO-LINE-CURRENT-USER* NIL "Cached name of the current logged in user") (CL:DEFPARAMETER *WHO-LINE-USER-ENTRY* (QUOTE ("User" (WHO-LINE-USERNAME) 10 WHO-LINE-CHANGE-USER (SETQ *WHO-LINE-CURRENT-USER* NIL) "Name of the currently logged in user")) "Who-Line entry for displaying the name of the currently logged in user") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDTOVAR \SYSTEMCACHEVARS *WHO-LINE-CURRENT-USER*) (ADDTOVAR \AFTERLOGINFNS WHO-LINE-USER-AFTER-LOGIN) ) (* ;; "") (* ;; "Showing the current machine name") (DEFINEQ (WHO-LINE-HOST-NAME (LAMBDA NIL (* ; "Edited 14-Jan-87 12:46 by smL") (* ;;; "") (* ;;; "Return the name of the curren workstation. Avoid consing up a new string if possible.") (* ;;; "") (* ;; "") (* ;; "The cached value in *WHO-LINE-HOST-NAME* gets invalidated by an entry on the list of \SYSTEMCACHEVARS") (* ;; "") (DECLARE (GLOBALVARS *WHO-LINE-HOST-NAME*)) (if *WHO-LINE-HOST-NAME* then *WHO-LINE-HOST-NAME* else (SETQ *WHO-LINE-HOST-NAME* (ETHERHOSTNAME)))) ) ) (DEFGLOBALVAR *WHO-LINE-HOST-NAME* NIL "Cached name of the current machine, for the Who-Line") (CL:DEFPARAMETER *WHO-LINE-HOST-NAME-ENTRY* (QUOTE ("on" (WHO-LINE-HOST-NAME) 10 NIL (SETQ *WHO-LINE-HOST-NAME* NIL) "Name of the currently running machine")) "Who-Line entry for displaying the name of the current machine") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDTOVAR \SYSTEMCACHEVARS *WHO-LINE-HOST-NAME*) ) (* ;; "") (* ;; "Showing / changing the current tty process package") (DEFINEQ (CURRENT-TTY-PACKAGE (LAMBDA NIL (* ; "Edited 17-Mar-87 17:52 by smL") (* ;;; "") (* ;;; "Return the name of the current package of the current TTY process") (* ;;; "") (LET ((PACKAGE (PROCESS.EVALV (TTY.PROCESS) '*PACKAGE*))) (* ;; "") (* ;; "The *WHO-LINE-PACKAGE-NAME-CACHE* AList is used to cache computed package names with terminating %":%"'s.") (* ;; "This lets us display the name with a colon w/o having to allocate new strings all the time.") (* ;; "") (OR (CDR (ASSOC PACKAGE *WHO-LINE-PACKAGE-NAME-CACHE*)) (PUTASSOC PACKAGE (CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) (CL:PACKAGE-NAME PACKAGE)) ":") *WHO-LINE-PACKAGE-NAME-CACHE*))))) (SET-PACKAGE-INTERACTIVELY (LAMBDA NIL (* ; "Edited 18-Mar-87 13:13 by smL") (* ;; "") (* ;; "Let the user interactivly change the current package") (* ;; "") (LET ((PACKAGE (MENU (create MENU TITLE _ "Select package" ITEMS _ (SORT (for PACKAGE in (CL:LIST-ALL-PACKAGES) bind PACKAGE-NAME collect (SETQ PACKAGE-NAME (CL:PACKAGE-NAME PACKAGE)) `(,(CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) PACKAGE-NAME) ":") ',PACKAGE-NAME ,(CONCAT "Set the current package to " PACKAGE-NAME ":"))) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y))))) CENTERFLG _ T)))) (if PACKAGE then (if (SHIFTDOWNP 'SHIFT) then (WHO-LINE-COPY-INSERT (CONCAT PACKAGE ":")) else (CL:IN-PACKAGE PACKAGE)))))) (SET-TTY-PACKAGE-INTERACTIVELY (LAMBDA NIL (* smL "28-Oct-86 09:49") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PACKAGE-INTERACTIVELY)) T)) ) ) (DEFGLOBALVAR *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL) "An AList used to cache package names, together with their terminating ':'s") (CL:DEFPARAMETER *WHO-LINE-PACKAGE-ENTRY* (QUOTE ("Pkg" (CURRENT-TTY-PACKAGE) 10 SET-TTY-PACKAGE-INTERACTIVELY (SETQ *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL)) "Package of the current TTY process")) "Who-Line entry for displaying the package of the current TTY process") (* ;; "") (* ;; "Showing / changing the current tty process readtable") (DEFINEQ (CURRENT-TTY-READTABLE-NAME (LAMBDA NIL (* smL "28-Oct-86 19:13") (* ;;; "") (* ;;; "Return the name of the readtable of the current TTY process") (* ;;; "") (OR (READTABLEPROP (PROCESS.EVALV (TTY.PROCESS) (QUOTE *READTABLE*)) (QUOTE NAME)) "Unknown")) ) (SET-READTABLE-INTERACTIVELY (LAMBDA NIL (* smL "10-Nov-86 18:36") (* ;; "") (* ;; "Let the user interactivly change the current readtable") (* ;; "") (DECLARE (GLOBALVARS \READTABLEHASH)) (LET ((READTABLE (MENU (create MENU TITLE _ "Select readtable" ITEMS _ (LET ((READTABLES NIL)) (MAPHASH \READTABLEHASH (FUNCTION (LAMBDA (VALUE NAME) (push READTABLES (LIST NAME VALUE))))) (SORT READTABLES (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y)))))) CENTERFLG _ T)))) (if (READTABLEP READTABLE) then (SETQ *READTABLE* READTABLE)))) ) (SET-TTY-READTABLE-INTERACTIVELY (LAMBDA NIL (* smL "28-Oct-86 09:51") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY readtable") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-READTABLE-INTERACTIVELY)) T)) ) ) (CL:DEFPARAMETER *WHO-LINE-READTABLE-ENTRY* (QUOTE ("Rdtbl" (CURRENT-TTY-READTABLE-NAME) 10 SET-TTY-READTABLE-INTERACTIVELY NIL "Readtable of the current TTY process")) "Who-Line entry for displaying the name of the ReadTable of the current TTY process") (* ;; "") (* ;; "Showing / changing the current tty process") (DEFINEQ (WHO-LINE-TTY-PROCESS (LAMBDA NIL (* smL "28-Oct-86 09:54") (* ;;; "") (* ;;; "Return the name of the current TTY process") (* ;;; "") (PROCESSPROP (TTY.PROCESS) (QUOTE NAME))) ) (CHANGE-TTY-PROCESS-INTERACTIVELY (LAMBDA NIL (* smL "10-Nov-86 18:36") (DECLARE (GLOBALVARS \PROCESSES)) (LET ((NEW-PROC (MENU (create MENU TITLE _ "Give TTY to process" CENTERFLG _ T ITEMS _ (SORT (for PROC in \PROCESSES collect (LIST (PROCESSPROP PROC (QUOTE NAME)) PROC)) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y))))))))) (if NEW-PROC then (TTY.PROCESS NEW-PROC)))) ) ) (CL:DEFPARAMETER *WHO-LINE-TTY-PROC-ENTRY* (QUOTE ("Tty" (WHO-LINE-TTY-PROCESS) 15 CHANGE-TTY-PROCESS-INTERACTIVELY NIL "The current TTY process")) "Who-Line entry for displaying the name of the current TTY process") (* ;; "") (* ;; "Showing / changing the currently connected directory") (DEFINEQ (WHO-LINE-CURRENT-DIRECTORY (LAMBDA NIL (* ; "Edited 3-Feb-89 14:52 by smL") (* ;;; "Get the currently connected directory") (* ;; "First, update the cached directory / namestring pair to reflect the current TTY proc") (DECLARE (GLOBALVARS *WHO-LINE-LAST-DIRECTORY*)) (* ;; "The connected directory is looked up in the TTY process, in case one day it becomes a per-process var") (LET ((CONNECTED-DIRECTORY (PROCESS.EVALV (TTY.PROCESS) (QUOTE *DEFAULT-PATHNAME-DEFAULTS*)))) (* ; "The CAR contains the path, the CDR contains a string version of the path") (if (NEQ CONNECTED-DIRECTORY (CAR *WHO-LINE-LAST-DIRECTORY*)) then (* ; "The connected directory has changed") (change (CAR *WHO-LINE-LAST-DIRECTORY*) CONNECTED-DIRECTORY) (* ; "Put the host name last, since that is least important") (change (CDR *WHO-LINE-LAST-DIRECTORY*) (if (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) then (CONCAT (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) " on {" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}") else (CONCAT "{" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}"))) (* ; "Update the list of known directories") (LET ((DIR-NAME (CL:NAMESTRING CONNECTED-DIRECTORY))) (if (NOT (CL:MEMBER DIR-NAME *WHO-LINE-DIRECTORIES* :TEST (CL:FUNCTION STRING-EQUAL))) then (MERGEINSERT DIR-NAME (SORT *WHO-LINE-DIRECTORIES* (CL:FUNCTION UALPHORDER))))))) (* ;; "Return the namestring of the current dir") (CDR *WHO-LINE-LAST-DIRECTORY*)) ) (SET-CONNECTED-DIRECTORY-INTERACTIVELY (LAMBDA NIL (* ; "Edited 9-Jun-87 08:57 by smL") (* ;;; "Let the user interactivly change the current connected directory") (DECLARE (GLOBALVARS *WHO-LINE-DIRECTORIES*)) (* ;; "If the user selects an item while holding down a shift key, copy-insert the name of the directory instead of connecting to it") (if (SHIFTDOWNP 'SHIFT) then (LET ((NEW-DIRECTORY (MENU (create MENU TITLE _ "Type in directory name:" ITEMS _ *WHO-LINE-DIRECTORIES*)))) (if NEW-DIRECTORY then (WHO-LINE-COPY-INSERT NEW-DIRECTORY))) else (LET ((NEW-DIRECTORY (MENU (create MENU TITLE _ "Connect to:" ITEMS _ (CONS "* Other *" *WHO-LINE-DIRECTORIES*))))) (if NEW-DIRECTORY then (if (STRING-EQUAL NEW-DIRECTORY "* Other *") then (CLEARW PROMPTWINDOW) (SETQ NEW-DIRECTORY (PROMPTFORWORD "Connect to directory " (CL:NAMESTRING (PROCESS.EVALV (TTY.PROCESS) ' *DEFAULT-PATHNAME-DEFAULTS* )) NIL PROMPTWINDOW NIL 'TTY NIL))) (if NEW-DIRECTORY then (ALLOW.BUTTON.EVENTS) (* ; "Should do this in the current TTY process, in case the conntected directory is a per-process var") (CNDIR NEW-DIRECTORY))))))) ) (DEFGLOBALVAR *WHO-LINE-DIRECTORIES* (BQUOTE ((\, LOGINHOST/DIR))) "Cached list of known directories for the Who-Line Directory entry") (DEFGLOBALVAR *WHO-LINE-LAST-DIRECTORY* (LET ((NAMESTRING (CL:NAMESTRING *DEFAULT-PATHNAME-DEFAULTS*))) (CONS (PATHNAME NAMESTRING) (MKSTRING NAMESTRING))) "Cached name of the current connected directory for the Who-Line Directory entry") (CL:DEFPARAMETER *WHO-LINE-DIRECTORY-ENTRY* (QUOTE ("Dir" (WHO-LINE-CURRENT-DIRECTORY) 30 SET-CONNECTED-DIRECTORY-INTERACTIVELY (SETQ *WHO-LINE-LAST-DIRECTORY* (CONS NIL NIL)) "The currently connected directory")) "Who-Line entry for displaying the name of the currently connected directory") (* ;; "") (* ;; "Showing / changing the current VMem utilization") (DEFINEQ (WHO-LINE-VMEM (LAMBDA NIL (* ; "Edited 14-Jan-87 12:57 by smL") (* ;;; "") (* ;;; "Compute the percentage of vmem in use.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-LAST-VMEM* \LASTVMEMFILEPAGE \InterfacePage \IFPValidKey)) (* ;; "") (* ;; "Compute the percentage of vmem in use. The ratio is the amount in use (computed by (VMEMSIZE)) divided by the amount available (stored in \LASTVMEMFILEPAGE). We multiply by 100 to get a percentage, round to an integer, and do it all in such a way as to ensure we don't cons any FIXPs.") (* ;; "The basic code here is due to Mike Dixon.") (* ;; "") (LET* ((ONE-PERCENT-VMEM (IQUOTIENT (IPLUS \LASTVMEMFILEPAGE 50) 100)) (VMEM-PERCENT (IQUOTIENT (IPLUS (VMEMSIZE) (RSH ONE-PERCENT-VMEM 1)) ONE-PERCENT-VMEM)) (VMEM-CONSISTENT? (.VMEM.CONSISTENTP.))) (* ;; "") (* ;; "We cache the last VMem info and the string-translation of it in the var *WHO-LINE-LAST-VMEM*. That way, we don't have to alloc a new string all the time. We do, however, have to make sure the cached info in correct.") (* ;; "") (if (NOT (AND (EQ VMEM-CONSISTENT? (CADR *WHO-LINE-LAST-VMEM*)) (EQP VMEM-PERCENT (CAR *WHO-LINE-LAST-VMEM*)))) then (change (CAR *WHO-LINE-LAST-VMEM*) VMEM-PERCENT) (change (CADR *WHO-LINE-LAST-VMEM*) VMEM-CONSISTENT?) (change (CADDR *WHO-LINE-LAST-VMEM*) (CONCAT (if VMEM-CONSISTENT? then " " else "*") VMEM-PERCENT "%%"))) (* ;; "") (* ;; "Return the info string") (* ;; "") (CADDR *WHO-LINE-LAST-VMEM*)))) (WHO-LINE-SAVE-VMEM (LAMBDA NIL (* smL "29-Oct-86 11:22") (* ;;; "") (* ;;; "Save the VMem, if the user really wants to") (* ;;; "") (if (MENU (create MENU TITLE _ "Save VMem?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T) ("No" NIL))))) then (SAVEVM))) ) ) (DEFGLOBALVAR *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL) "Cached value for storing the last VMem information for the Who-Line VMem entry") (CL:DEFPARAMETER *WHO-LINE-VMEM-ENTRY* (QUOTE ("VMem" (WHO-LINE-VMEM) 5 WHO-LINE-SAVE-VMEM (SETQ *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL)) "Percentage of VMem currently in use")) "Who-Line entry for displaying the current VMem utilization") (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILESLOAD (LOADCOMP) LLFAULT MODARITH) (CHECKIMPORTS (QUOTE (LLPARAMS)) T) ) (* ;; "") (* ;; "Showing the percent of symbol-space currently used") (CL:DEFUN WHO-LINE-SYMBOL-SPACE NIL "Return a string describing the percentage of symbol space in use" (LET ((TOTAL-SYMBOL-SPACE (UNFOLD (CL:1+ \LastAtomPage) WORDSPERCELL)) (SYMBOL-SPACE-IN-USE (FOLDHI \AtomFrLst CELLSPERPAGE))) (* ;; "Only recompute the display string when the fraction of space has changed. This saves us the effort of CONSing up the string each time.") (CL:UNLESS (AND (EQL (CL:FIRST *WHO-LINE-SYMBOL-SPACE*) TOTAL-SYMBOL-SPACE) (EQL (CL:SECOND *WHO-LINE-SYMBOL-SPACE*) SYMBOL-SPACE-IN-USE)) (CL:SETF (CL:FIRST *WHO-LINE-SYMBOL-SPACE*) TOTAL-SYMBOL-SPACE (CL:SECOND *WHO-LINE-SYMBOL-SPACE*) SYMBOL-SPACE-IN-USE (CL:THIRD *WHO-LINE-SYMBOL-SPACE*) (CL:FORMAT NIL "~3D%%" (- 100 (ROUND (- 100 (/ (CL:* SYMBOL-SPACE-IN-USE 100) TOTAL-SYMBOL-SPACE))))))) (CL:THIRD *WHO-LINE-SYMBOL-SPACE*))) (DEFGLOBALVAR *WHO-LINE-SYMBOL-SPACE* (LIST NIL NIL NIL "Remembers the previous who-line symbol space")) (CL:DEFPARAMETER *WHO-LINE-SYMBOL-SPACE-ENTRY* (QUOTE ("Syms" (WHO-LINE-SYMBOL-SPACE) 4 NIL (SETQ *WHO-LINE-SYMBOL-SPACE* (LIST NIL NIL NIL)) "Percentage of symbol space currently in use")) "Who-line entry for displaying percent of symbol space in use") (* ;; "") (* ;; "Showing the current time") (DEFINEQ (WHO-LINE-TIME (LAMBDA NIL (* ; "Edited 14-Jan-87 12:48 by smL") (* ;;; "") (* ;;; "Return the current time as a string. Avoid CONSing as much as possible.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME*)) (if (TIMEREXPIRED? *WHO-LINE-TIMER* (QUOTE SECONDS)) then (* ;; "") (* ;; "Reset the timer, and return the new time") (* ;; "") (LET ((NOW (IDATE))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER NOW 60)) (CONSTANT (SETUPTIMER 0 NIL (QUOTE SECONDS))) (QUOTE SECONDS))) (SETQ *WHO-LINE-OLD-TIME* (GDATE NOW (CONSTANT (DATEFORMAT NO.SECONDS)) *WHO-LINE-OLD-TIME*)) *WHO-LINE-OLD-TIME*) else (* ;; "") (* ;; "The timer hasn't expired, so the old time is good enough") (* ;; "") *WHO-LINE-OLD-TIME*)) ) (WHO-LINE-SET-TIME (LAMBDA NIL (* ; "Edited 17-Mar-87 18:20 by smL") (* ;;; "") (* ;;; "Set the time from the network, if the user really wants to") (* ;;; "") (COND ((SHIFTDOWNP 'SHIFT) (* ;; "Selection with a shift key down causes the current time to be bksysbuf'ed") (WHO-LINE-COPY-INSERT *WHO-LINE-OLD-TIME*)) ((MENU (create MENU TITLE _ "Set time?" CENTERFLG _ T ITEMS _ '(("Yes" T) ("No" NIL)))) (* ;; "The user wants to reset the time") (SETTIME))))) ) (DEFGLOBALVAR *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) 60)) NIL (QUOTE SECONDS)) "Timer for controlling updates of the Who-Line Time entry") (DEFGLOBALVAR *WHO-LINE-OLD-TIME* (DATE (DATEFORMAT NO.SECONDS)) "Cached value for the Who-Line Time entry") (CL:DEFPARAMETER *WHO-LINE-TIME-ENTRY* (QUOTE ("Time" (WHO-LINE-TIME) 15 WHO-LINE-SET-TIME (PROGN (SETQ *WHO-LINE-OLD-TIME* (DATE (DATEFORMAT NO.SECONDS))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) 60)) NIL (QUOTE SECONDS)))) "Time of day")) "Who-Line entry for displaying the current time of day") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-TIMER* SECONDS)) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some as yet un-debugged entries. Try at your own risk.") (* ;; "") (* ;; "Showing the machine-active entry") (DEFINEQ (WHO-LINE-SHOW-ACTIVE (LAMBDA NIL (* ; "Edited 20-Apr-87 09:58 by smL") (* ;;; "Update the who-line active indicator, if it is time") (DECLARE (GLOBALVARS *WHO-LINE* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-ACTIVE-PERIOD*)) (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS) then (* ;; "A second has passed, so update the indicator if we can") (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*) (* ;; "Reset the timer") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS))) (* ;; "Always return the same thing") " ")) (\UPDATE-WHO-LINE-ACTIVE-FLAG (LAMBDA (WINDOW) (* ; "Edited 20-Apr-87 09:58 by smL") (* ;;; "Flip the active-indicator in the who-line") (for ENTRY in (WINDOWPROP WINDOW 'ENTRIES) thereis (with WHO-LINE-ENTRY ENTRY (AND (LISTP FORM) (EQ (CAR FORM) 'WHO-LINE-SHOW-ACTIVE))) finally (if $$VAL then (with WHO-LINE-ENTRY $$VAL (BLTSHADE BLACKSHADE WINDOW VALUE-START 2 (DIFFERENCE VALUE-END VALUE-START) (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) 4) 'INVERT)))))) (\PERIODICALLY-WHO-LINE-SHOW-ACTIVE (LAMBDA NIL (* ; "Edited 14-Jan-87 12:50 by smL") (* ;;; "") (* ;;; "Update the who-line active indicator, if it is time") (* ;;; "This is designed to be run on the \PERIODIC.INTERRUPT hook.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-ACTIVE-TIMER* *WHO-LINE* *WHO-LINE-ACTIVE-PERIOD*)) (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS)) then (* ;; "") (* ;; "A second has passed, so update the indicator if we can") (* ;; "") (* ;; "But only if the who-line is on the top") (* ;; "") (if (AND (OPENWP *WHO-LINE*) (TOPWP *WHO-LINE*)) then (* ;; "") (* ;; "The who-line is on the top, so we can update it") (* ;; "") (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*)) (* ;; "") (* ;; "Reset the timer") (* ;; "") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS))))) ) ) (DEFGLOBALVAR *WHO-LINE-ACTIVE-PERIOD* 500 "Interval between updating the Who-Line activity entry") (DEFGLOBALVAR *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* NIL (QUOTE MILLISECONDS)) "Timer for controlling updating of the Who-Line activity entry") (CL:DEFPARAMETER *WHO-LINE-SHOW-ACTIVE-ENTRY* (QUOTE ("" (WHO-LINE-SHOW-ACTIVE) 2 NIL (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* NIL (QUOTE MILLISECONDS))) "Indication of machine activity")) "Who-Line entry for displaying the activity of the machine") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-ACTIVE-TIMER* MILLISECONDS)) ) (* ;; "") (* ;; "Showing / changing the current reader profile") (DEFINEQ (CURRENT-PROFILE (LAMBDA NIL (* ; "Edited 12-Jan-87 14:36 by smL") (* ;;; "") (* ;;; "Return the name of the current reader profile of the current TTY process") (* ;;; "") (XCL:PROFILE-NAME (PROCESS.EVALV (TTY.PROCESS) (QUOTE XCL:*PROFILE*)))) ) (SET-PROFILE-INTERACTIVELY (LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;; "") (* ;; "Let the user interactivly change the current reader profile") (* ;; "") (LET ((PROFILE (MENU (create MENU TITLE _ "Select profile" ITEMS _ (SORT (for PROFILE in (XCL:LIST-ALL-PROFILES) bind PROFILE-NAME collect (XCL:PROFILE-NAME PROFILE))) CENTERFLG _ T)))) (if PROFILE then (XCL:RESTORE-PROFILE PROFILE)))) ) (SET-TTY-PROFILE-INTERACTIVELY (LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;;; "") (* ;;; "Interactivly let the user change the reader profile of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PROFILE-INTERACTIVELY)) T)) ) ) (CL:DEFPARAMETER *WHO-LINE-PROFILE-ENTRY* (QUOTE ("Profile" (CURRENT-PROFILE) 10 SET-TTY-PROFILE-INTERACTIVELY NIL "The read/write profile of the current TTY process")) "Who-Line entry for displaying the current read/write profile") (* ;; "") (* ;; "Showing the state of the current TTY process") (DEFINEQ (WHO-LINE-TTY-STATE (LAMBDA NIL (* ; "Edited 17-Apr-87 18:26 by smL") (* ;;; "Find out what state the current TTY process is in") (LET ((PROC (TTY.PROCESS))) (COND ((NULL PROC) (* ;; " No tty process? Never happens now, but maybe allowed in future.") "") ((EQ PROC (THIS.PROCESS)) (* ;; " Check explicitly for us being tty, since in that case PROC is not a valid stack pointer (we're running).") "Who-Line") ((PROCESS.EVALV PROC '*WHO-LINE-STATE*)) ((NOT (PROCESS.FINISHEDP PROC)) (for I from 0 by -1 bind FRAMENAME while (SETQ FRAMENAME (STKNTHNAME I PROC)) unless (MEMB FRAMENAME *WHO-LINE-STATE-UNINTERESTING-FNS*) do (* ;; " Walk back process looking for interesting frame name. This search is non-linear in that each iteration takes a little longer, but we expect it to terminate early.") (RETURN (OR (GETPROP FRAMENAME 'WHO-LINE-STATE) FRAMENAME)))))))) (WHO-LINE-WHAT-IS-RUNNING (LAMBDA NIL (* ; "Edited 14-Jan-87 12:51 by smL") (* ;;; "") (* ;;; "When run under a (PROCESS.EVAL '(WHO-LINE-WHAT-IS-RUNNING) T), returns the name of the current running frame in the process") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-STATE-UNINTERESTING-FNS*)) (PROG ((POS-HOLDER (CONSTANT (LIST NIL))) POS) (* ;; "") (* ;; "We use the POS-HOLDER to hold an old stack pointer, so that we don't have to alloc one") (* ;; "") (SETQ POS (STKPOS (QUOTE \PROCESS.EVAL1) NIL NIL (CAR POS-HOLDER))) (COND (POS (change (CAR POS-HOLDER) POS)) (T (RETURN NIL))) LP (SETQ POS (STKNTH 1 POS POS)) (COND ((NULL POS) (RETURN NIL)) ((MEMB (STKNAME POS) *WHO-LINE-STATE-UNINTERESTING-FNS*) (* ; "Ignore any uninteresting fns") (GO LP)) (T (RETURN (PROG1 (STKNAME POS) (RELSTK POS))))))) ) ) (CL:DEFVAR *WHO-LINE-STATE* NIL "Cached state shown in the Who-Line State entry") (DEFGLOBALVAR *WHO-LINE-STATE-UNINTERESTING-FNS* (QUOTE (BLOCK ERRORSET OBTAIN.MONITORLOCK MONITOR.AWAIT.EVENT AWAIT.EVENT SI::*UNWIND-PROTECT*)) "Uninteresting fns to skip over in the Who-Line State entry") (CL:DEFPARAMETER *WHO-LINE-TTY-STATE-ENTRY* (QUOTE ("State" (WHO-LINE-TTY-STATE) 15 NIL (SETQ *WHO-LINE-STATE* NIL) "Running state of the current TTY process")) "Who-Line entry for showing the running state of the current TTY process") (PUTPROPS AWAIT.EVENT WHO-LINE-STATE "Block") (PUTPROPS BLOCK WHO-LINE-STATE "Block") (PUTPROPS EXCHANGEPUPS WHO-LINE-STATE "Net I/O") (PUTPROPS GETPUP WHO-LINE-STATE "Net I/O") (PUTPROPS SENDPUP WHO-LINE-STATE "Net I/O") (PUTPROPS WAIT.FOR.TTY WHO-LINE-STATE "TTY wait") (PUTPROPS \TTYBACKGROUND WHO-LINE-STATE "TTY wait") (PUTPROPS \WAITFORSYSBUFP WHO-LINE-STATE "TTY wait") (PUTPROPS \\getkey WHO-LINE-STATE "TTY wait") (PUTPROPS \SENDLEAF WHO-LINE-STATE "Net I/O") (PUTPROPS PUTSEQUIN WHO-LINE-STATE "Net I/O") (PUTPROPS \LEAF.READPAGES WHO-LINE-STATE "Net I/O") (* ;;; "----------------------------------------------------------------------") (* ;;; "Default options for the who-line") (DEFGLOBALVAR *WHO-LINE-ENTRIES* (BQUOTE ((\, *WHO-LINE-USER-ENTRY*) (\, *WHO-LINE-PACKAGE-ENTRY*) (\, *WHO-LINE-READTABLE-ENTRY*) (\, *WHO-LINE-TTY-PROC-ENTRY*) (\, *WHO-LINE-DIRECTORY-ENTRY*) (\, *WHO-LINE-VMEM-ENTRY*) (\, *WHO-LINE-TIME-ENTRY*))) "List of all the entries to show in the Who-Line") (DEFGLOBALVAR *WHO-LINE-ENTRY-REGISTRY* (LIST *WHO-LINE-USER-ENTRY* *WHO-LINE-HOST-NAME-ENTRY* *WHO-LINE-PACKAGE-ENTRY* *WHO-LINE-READTABLE-ENTRY* *WHO-LINE-TTY-PROC-ENTRY* *WHO-LINE-DIRECTORY-ENTRY* *WHO-LINE-VMEM-ENTRY* *WHO-LINE-SYMBOL-SPACE-ENTRY* *WHO-LINE-TIME-ENTRY* *WHO-LINE-SHOW-ACTIVE-ENTRY* *WHO-LINE-PROFILE-ENTRY* *WHO-LINE-TTY-STATE-ENTRY*) "List of all known Who-Line entries.") (DEFGLOBALVAR *WHO-LINE-ANCHOR* (QUOTE (:CENTER :BOTTOM)) "Location to place the Who-Line") (DEFGLOBALVAR *WHO-LINE-NAME-FONT* (FONTCREATE (QUOTE (HELVETICA 8 BOLD))) "Font to use to show entry labels in the Who-Line") (DEFGLOBALVAR *WHO-LINE-VALUE-FONT* (FONTCREATE (QUOTE (GACHA 8))) "Font to use to show the entry values in the Who-Line") (DEFGLOBALVAR *WHO-LINE-DISPLAY-NAMES?* T "Flag for enabling or disabling the display of entry names in the Who-Line") (DEFGLOBALVAR *WHO-LINE-COLOR* :WHITE "Color of the Who-Line -- one of :WHITE or :BLACK") (DEFGLOBALVAR *WHO-LINE-TITLE* NIL "The window title of the Who-Line") (DEFGLOBALVAR *WHO-LINE-BORDER* 2 "The border width of the Who-Line window") (DEFGLOBALVAR *WHO-LINE-UPDATE-INTERVAL* 100 "Update interval for the Who-Line, in milliseconds") (* ;;; "----------------------------------------------------------------------") (* ;;; "Internal fns") (DEFINEQ (REDISPLAY-WHO-LINE (LAMBDA (WINDOW) (* ; "Edited 17-Apr-87 19:06 by smL") (* ;;; "Redisplay the entire who-line, including the names of the fields") (WITH-WHO-LINE WINDOW (* ;; "") (* ;; "Set the display characteristics of the window, according to its color") (DSPSOURCETYPE (SELECTQ (WINDOWPROP WINDOW 'COLOR) (:WHITE 'INPUT) (:BLACK 'INVERT) (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) WINDOW) (DSPTEXTURE (SELECTQ (WINDOWPROP WINDOW 'COLOR) (:WHITE WHITESHADE) (:BLACK BLACKSHADE) (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) WINDOW) (* ;; "") (* ;; "Clear the window") (CLEARW WINDOW) (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) do (replace (WHO-LINE-ENTRY INVERTED?) of ITEM with NIL)) (* ;; "") (* ;; "Display the labels if we should") (if (WINDOWPROP WINDOW 'DISPLAY-NAMES?) then (DSPFONT (WINDOWPROP WINDOW 'NAME-FONT) WINDOW) (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) bind (FONT _ (WINDOWPROP WINDOW 'NAME-FONT)) do (MOVETO (fetch (WHO-LINE-ENTRY NAME-START) of ITEM) (PLUS (FONTPROP FONT 'DESCENT) (QUOTIENT (DIFFERENCE (WINDOWPROP *WHO-LINE* 'HEIGHT) (FONTPROP FONT 'HEIGHT)) 2)) WINDOW) (PRIN1 (fetch (WHO-LINE-ENTRY NAME) of ITEM) WINDOW))) (* ;; "") (* ;; "Display the values") (DSPFONT (WINDOWPROP WINDOW 'VALUE-FONT) WINDOW) (UPDATE-WHO-LINE WINDOW (WINDOWPROP WINDOW 'ENTRIES) T) (* ;; "") (* ;; "Reset the timer for the next update") (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) (PERIODICALLY-UPDATE-WHO-LINE (LAMBDA NIL (* ; "Edited 27-Jan-88 10:11 by smL") (* ;;; "") (* ;;; "Update the current who-line window every so often. This is designed to be placed on the list of BACKBROUNDFNS.") (* ;;; "") (DECLARE (GLOBALVARS \IDLING)) (CL:WHEN (TIMEREXPIRED? *WHO-LINE-UPDATE-TIMER* 'TICKS) (CL:WHEN (AND (BOUNDP '*WHO-LINE*) (NOT \IDLING)) (* ; "Don't bother to wait and update if the window is owned by someone.") (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) (GETWINDOWPROP *WHO-LINE* 'VALID)) then (UPDATE-WHO-LINE *WHO-LINE* (GETWINDOWPROP *WHO-LINE* 'ENTRIES))))) (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) (SETUP-WHOLINE-TIMER (LAMBDA (OLD-TIMER) (* ; "Edited 18-Mar-87 11:14 by smL") (SETUPTIMER (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL) OLD-TIMER 'TICKS))) (UPDATE-WHO-LINE (LAMBDA (WINDOW WHO-LINE-ENTRIES ALWAYS?) (* ; "Edited 17-Apr-87 19:05 by smL") (* ;;; "Update the window to show the current who-line stats") (WITH-WHO-LINE WINDOW (* ;; "") (* ;; "Update all the entries that have changed") (for ENTRY in WHO-LINE-ENTRIES bind (VALUE-BOTTOM _ (GETWINDOWPROP WINDOW 'VALUE-BOTTOM)) (STREAM _ (GETWINDOWPROP WINDOW 'TEMP-STREAM)) (HEIGHT _ (GETWINDOWPROP WINDOW 'HEIGHT)) (BLACK-WINDOW-P _ (EQ (WINDOWPROP WINDOW 'COLOR) :BLACK)) do (with WHO-LINE-ENTRY ENTRY (* ; "If the node is inverted, the user is mousing it, so don't update it") (if (NOT INVERTED?) then (if ALWAYS? then (EVAL RESET-FORM)) (LET ((VALUE (EVAL FORM))) (* ;; "") (* ;; "Only update if the value has changed, or we are ordered to.") (if (OR ALWAYS? (NOT (EQUAL VALUE PREV-VALUE))) then (* ;; "") (* ;; "Print the new value") (MOVETO VALUE-START VALUE-BOTTOM STREAM) (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'ERASE) (DSPFONT (DSPFONT NIL WINDOW) STREAM) (PRIN1 VALUE STREAM) (if BLACK-WINDOW-P then (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'INVERT)) (BITBLT STREAM VALUE-START 0 WINDOW VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'PAINT) (* ;; "") (* ;; "Save the value.") (* ;; "We are worried that a form may be re-using a value (to minimize CONS-ing), so we store a copy of the value rather than the real value.") (SETQ PREV-VALUE (COPYALL VALUE)))))))))) (WHEN-WHO-LINE-SELECTED-FN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 09:54 by smL") (* ;;; "") (* ;;; "The button has gone down in the who-line window.") (* ;;; "If the control or edit key is down, allow the user to change the entries in the who-line.") (* ;;; "If the user selects an item, and it has a when-selected-fn, funcall that fn.") (* ;;; "") (WITH-WHO-LINE WINDOW (TOTOPW WINDOW) (GETMOUSESTATE) (if (OR (KEYDOWNP 'EDIT) (KEYDOWNP 'CTRL)) then (WHO-LINE-CONTROL-SELECT) else (bind (REGION _ (WINDOWPROP WINDOW 'REGION)) (ENTRIES _ (WINDOWPROP WINDOW 'ENTRIES)) INVERTED-ITEM CURRENT-ITEM while (MOUSESTATE (NOT UP)) do (* ;; "") (* ;; "If cursor has left the window, quit tracking") (* ;; "") (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) then (SETQ CURRENT-ITEM NIL) (GO $$OUT)) (* ;; "") (* ;; "Find out what item we are currently on") (* ;; "") (SETQ CURRENT-ITEM (for ENTRY in ENTRIES thereis (with WHO-LINE-ENTRY ENTRY (AND (GEQ (LASTMOUSEX WINDOW) NAME-START) (LEQ (LASTMOUSEX WINDOW) VALUE-END) (NOT (NULL WHEN-SELECTED-FN)))))) (* ;; "") (* ;; "Invert the current choice") (* ;; "") (if (NEQ INVERTED-ITEM CURRENT-ITEM) then (if INVERTED-ITEM then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) (if CURRENT-ITEM then (INVERT-WHO-LINE-ENTRY CURRENT-ITEM WINDOW)) (SETQ INVERTED-ITEM CURRENT-ITEM)) finally (* ;; "") (* ;; "The button went up. If we were on an item, let it know") (* ;; "") (if INVERTED-ITEM then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) (if CURRENT-ITEM then (with WHO-LINE-ENTRY CURRENT-ITEM (if WHEN-SELECTED-FN then (APPLY* WHEN-SELECTED-FN ) (EVAL RESET-FORM)))))) ))) (WHO-LINE-CONTROL-SELECT (LAMBDA NIL "Interactivly let the user add or delete an entry to the WHO-LINE." (CL:FLET ((ENTRY-DESCRIPTION (X) (OR (CL:SIXTH X) (CONCAT "Entry named: " (CL:FIRST X))))) (CASE (MENU (create MENU ITEMS _ '(("Add item" :ADD "Add a new entry to the who-line") ("Remove item" :REMOVE "Remove an existing entry from the who-line")) TITLE _ "Change WHO-LINE entries")) (:ADD (LET* ((ITEMS (for entry in *WHO-LINE-ENTRY-REGISTRY* unless (MEMBER entry *WHO-LINE-ENTRIES*) collect `(,(ENTRY-DESCRIPTION entry) ',entry))) (NEW-ENTRY (if ITEMS then (MENU (create MENU ITEMS _ ITEMS TITLE _ "Entry to add to WHO-LINE")) else nil))) (if NEW-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CONS NEW-ENTRY *WHO-LINE-ENTRIES*)) (INSTALL-WHO-LINE-OPTIONS)))) (:REMOVE (LET* ((ITEMS (for entry in *WHO-LINE-ENTRIES* collect `(,(ENTRY-DESCRIPTION entry) ',entry))) (BAD-ENTRY (if ITEMS then (MENU (create MENU ITEMS _ ITEMS TITLE _ "Entry to remove from WHO-LINE")) else nil))) (if BAD-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CL:REMOVE BAD-ENTRY *WHO-LINE-ENTRIES*)) (INSTALL-WHO-LINE-OPTIONS)))))))) (WHO-LINE-COPY-INSERT (LAMBDA (X) (* ; "Edited 18-Mar-87 13:11 by smL") (LET ((TTY-WINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS NIL))))) (if (OR (IMAGEOBJP X) (AND (WINDOWP TTY-WINDOW) (WINDOWPROP TTY-WINDOW 'COPYINSERTFN))) then (COPYINSERT X) else (BKSYSBUF X NIL))))) ) (DEFINEQ (WHO-LINE-REDISPLAY-INTERRUPT (LAMBDA NIL (* ; "Edited 20-Apr-87 11:32 by smL") (* ;;; "Update the current who-line window because the user has requested it via an interrupt.") (if (BOUNDP '*WHO-LINE*) then (* ;; "Update the Who-Line, if it is available") (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) (WINDOWPROP *WHO-LINE* 'VALID)) then (* ; "Flash the Who-line to let people know that it is being updated") (CLOSEW *WHO-LINE*) (OPENW *WHO-LINE*) (* ; "The update the entries") (UPDATE-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'ENTRIES))))) )) ) (DEFGLOBALVAR *WHO-LINE* NIL "The who-line window") (DEFGLOBALVAR *WHO-LINE-UPDATE-TIMER* NIL "Timer for controlling updating of the Who-Line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-UPDATE-TIMER* TICKS)) ) (DEFMACRO INVERT-WHO-LINE-ENTRY (ENTRY WINDOW) (BQUOTE (WITH WHO-LINE-ENTRY (\, ENTRY) (BLTSHADE BLACKSHADE (\, WINDOW) NAME-START 0 (DIFFERENCE VALUE-END NAME-START) NIL (QUOTE INVERT)) (CHANGE INVERTED? (NOT INVERTED?))))) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD WHO-LINE-ENTRY (NAME FORM NAME-START VALUE-START VALUE-END PREV-VALUE WHEN-SELECTED-FN INVERTED? RESET-FORM DESCRIPTION) ) ) ) (* ; "Macros that lets us lock down the Who-Line while we evaluate some forms") (DEFMACRO WITH-WHO-LINE (WHO-LINE &BODY FORMS) "Evaluate the forms with the who-line locked down" (BQUOTE (WITH.MONITOR (WINDOWPROP (\, WHO-LINE) (QUOTE LOCK)) (\,@ FORMS)))) (DEFMACRO WITH-AVAILABLE-WHO-LINE (WHO-LINE &BODY FORMS) "Evaluate the forms with the who-line locked down, if the who-line is available" (LET ((LOCK (CL:GENSYM))) (BQUOTE (LET (((\, LOCK) (OBTAIN.MONITORLOCK (WINDOWPROP (\, WHO-LINE) (QUOTE LOCK)) T))) (CL:UNWIND-PROTECT (* ; "Only eval the forms if we got the lock") (COND ((\, LOCK) (\,@ FORMS))) (* ;; "Now for the cleanup forms") (COND ((EQ (\, LOCK) T) (* ; "Had the lock before, so no need to release it") NIL) ((NULL (\, LOCK)) (* ; "Couldn't get the lock, so no need to release it") NIL) (T (* ; "We got the lock, and need to release it") (RELEASE.MONITORLOCK (\, LOCK))))))))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Initialize the who-line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (INSTALL-WHO-LINE-OPTIONS) (ADDTOVAR BACKGROUNDFNS PERIODICALLY-UPDATE-WHO-LINE) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PUTPROPS WHO-LINE MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) (PUTPROPS WHO-LINE FILETYPE :COMPILE-FILE) ) (PUTPROPS WHO-LINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5579 20958 (INSTALL-WHO-LINE-OPTIONS 5589 . 20956)) (21218 22387 (WHO-LINE-USERNAME 21228 . 21875) (WHO-LINE-CHANGE-USER 21877 . 22183) (WHO-LINE-USER-AFTER-LOGIN 22185 . 22385)) (22936 23415 (WHO-LINE-HOST-NAME 22946 . 23413)) (23910 26539 (CURRENT-TTY-PACKAGE 23920 . 24872) ( SET-PACKAGE-INTERACTIVELY 24874 . 26293) (SET-TTY-PACKAGE-INTERACTIVELY 26295 . 26537)) (27025 28077 ( CURRENT-TTY-READTABLE-NAME 27035 . 27289) (SET-READTABLE-INTERACTIVELY 27291 . 27825) ( SET-TTY-READTABLE-INTERACTIVELY 27827 . 28075)) (28404 28976 (WHO-LINE-TTY-PROCESS 28414 . 28592) ( CHANGE-TTY-PROCESS-INTERACTIVELY 28594 . 28974)) (29275 32746 (WHO-LINE-CURRENT-DIRECTORY 29285 . 30692) (SET-CONNECTED-DIRECTORY-INTERACTIVELY 30694 . 32744)) (33493 35893 (WHO-LINE-VMEM 33503 . 35640) (WHO-LINE-SAVE-VMEM 35642 . 35891)) (37698 39136 (WHO-LINE-TIME 37708 . 38450) ( WHO-LINE-SET-TIME 38452 . 39134)) (40057 42690 (WHO-LINE-SHOW-ACTIVE 40067 . 40845) ( \UPDATE-WHO-LINE-ACTIVE-FLAG 40847 . 41815) (\PERIODICALLY-WHO-LINE-SHOW-ACTIVE 41817 . 42688)) (43425 44350 (CURRENT-PROFILE 43435 . 43680) (SET-PROFILE-INTERACTIVELY 43682 . 44085) ( SET-TTY-PROFILE-INTERACTIVELY 44087 . 44348)) (44657 46640 (WHO-LINE-TTY-STATE 44667 . 45828) ( WHO-LINE-WHAT-IS-RUNNING 45830 . 46638)) (49496 62477 (REDISPLAY-WHO-LINE 49506 . 52066) ( PERIODICALLY-UPDATE-WHO-LINE 52068 . 53206) (SETUP-WHOLINE-TIMER 53208 . 53426) (UPDATE-WHO-LINE 53428 . 56496) (WHEN-WHO-LINE-SELECTED-FN 56498 . 59765) (WHO-LINE-CONTROL-SELECT 59767 . 62081) ( WHO-LINE-COPY-INSERT 62083 . 62475)) (62478 63612 (WHO-LINE-REDISPLAY-INTERRUPT 62488 . 63610))))) STOP \ No newline at end of file diff --git a/lispusers/WHO-LINE.TEDIT b/lispusers/WHO-LINE.TEDIT new file mode 100644 index 00000000..440431aa --- /dev/null +++ b/lispusers/WHO-LINE.TEDIT @@ -0,0 +1,16 @@ +enˇvĹos WHO-LINE 2 4 1 WHO-LINE 1 4 By: SML (Lanning.pa@Xerox.com) INTRODUCTION Need to know what package you're in? Don't know what your connected directory is? Fret not. The Who-Line is here. The Who-Line is a window that displays this information on your screen. It is continually updated to reflect the current state of the world (thanks to an entry on BACKGROUNDFNS). Additionally, items in the Who-Line can act as menu items, allowing you to change the state of the machine. Defining the information displayed in the Who-Line The values displayed in the Who-Line are determined by the setting of the variable *WHO-LINE-ENTRIES*. *WHO-LINE-ENTRIES* [Global Variable] *WHO-LINE-ENTRIES* is a list that describes the items that will be displayed in the who-line. Each item in the list should be a list of up to five things: the name of the item; a form that, when evaluated, will produce the value to display; the maximum number of characters in the value; an optional function to call if the item is selected (with the mouse) in the Who-Line; an optional form that will reset any internal state of the entry when evaluated; and an optional string that describes the value displayed by the entry. [[NOTE: Since the items on the Who-Line are evaluated rather often, it is best if they are fast and efficient (= don't CONS or allocate any space).]] The following are standard members of *WHO-LINE-ENTRIES*. *WHO-LINE-USER-ENTRY* [Variable] Displays the current user in the Who-Line. Selecting this item in the Who-Line will let you change the logged in user. *WHO-LINE-HOST-NAME-ENTRY* [Variable] Displays the (ETHERHOSTNAME) of the machine you are running on. *WHO-LINE-PACKAGE-ENTRY* [Variable] Displays the package of the current TTY process in the Who-Line. Selecting this item in the Who-Line will let you switch the package of the current TTY process. *WHO-LINE-READTABLE-ENTRY* [Variable] Displays the (name of the) readtable of the current TTY process in the Who-Line. Selecting this item in the Who-Line will let you switch the readtable of the current TTY process. *WHO-LINE-TTY-PROC-ENTRY* [Variable] Displays the name of the current TTY process in the Who-Line. Selecting this item in the Who-Line will let you give the TTY to a different process. *WHO-LINE-DIRECTORY-ENTRY* [Variable] Displays the current connected directory in the Who-Line; the directory is shown in the format "Dir>Subdir>...>Subdir on {Host}". Selecting this item in the Who-Line will let you connect to another directory: the variable *WHO-LINE-DIRECTORIES* (see below) is used to produce a menu of interesting directories. If you are holding down a SHIFT key when you select an item from this menu, the directory name will be COPYINSERTed into the current tty input stream, otherwise you will be connected to that directory. *WHO-LINE-VMEM-ENTRY* [Variable] Displays the percentage of the VMem file that is currently being used in the Who-Line. If the VMem file is inconsistant, the number will be preceeded by an asterik ("*"). Selecting this item in the Who-Line will let you do a (SAVEVM). *WHO-LINE-SYMBOL-SPACE-ENTRY* [Variable] Displays the percentage of symbol space that is currently in use. *WHO-LINE-TIME-ENTRY* [ Variable] Displays the current time in the Who-Line. Selecting this item in the Who-Line will let you do a (SETTIME). If you hold down a shift key when you select this item, the current time will be COPYINSERTed into the current tty input stream instead. The default value of *WHO-LINE-ENTRIES* contains all these items Other ways to tailor the Who-Line *WHO-LINE-ANCHOR* [Variable] *WHO-LINE-ANCHOR* describes where the who-line will be displayed. If *WHO-LINE-ANCHOR* contains the symbol :TOP, the Who-Line will be anchored at the top of the screen; if it contains the symbol :BOTTOM it will be anchored at the bottom of the screen. If *WHO-LINE-ANCHOR* contains the symbol :LEFT, it will be anchored to the left side of the display; if it contains the symbol :CENTER it will be centered on the screen; if it contains the symbol :JUSTIFY it will run the width of the screen; if it contains the symbol :RIGHT it will be anchored to the right side of the screen. Finally, if *WHO-LINE-ANCHOR* is a POSITION, it will be used as the lower left corner of the Who-Line. The default value is (:CENTER :BOTTOM). *WHO-LINE-NAME-FONT* [Variable] The font used to display the names of the items in the who-line. The default is HELVETICA 8 BOLD. *WHO-LINE-VALUE-FONT* [Variable] The font used to display the values in the who-line. The default is GACHA 8. *WHO-LINE-COLOR* [Variable] The color of the Who-Line. Legal values are the keywords :WHITE and :BLACK. The default is :WHITE. *WHO-LINE-BORDER* [Variable] The border width of the Who-Line window. The default is 2. *WHO-LINE-TITLE* [Variable] The title of the Who-Line window. The default is NIL. *WHO-LINE-DISPLAY-NAMES?* [Variable] If *WHO-LINE-DISPLAY-NAMES?* is true, the names of items in the who-line will be displayed; otherwise they will not be shown. The default value is T. *WHO-LINE-UPDATE-INTERVAL* [Variable] The number of milliseconds between updates of the who-line. The default is 100 milliseconds. Installing new Who-Line options Changing the above variables has no direct effect on the who-line. These values need to be installed in the Who-Line before they can take effect. (INSTALL-WHO-LINE-OPTIONS) [Function] INSTALL-WHO-LINE-OPTIONS installs the above options in the Who-Line, and updates the Who-Line accordingly. The Who-Line supports an easy way to interactivly add or remove entries. If you click on the Who-Line while holding down the EDIT or CONTROL key, you will be given a chance to add or remove items from the Who-Line. *WHO-LINE-ENTRY-REGISTRY* [Global Variable] A list of all known Who-Line entries. This is used to construct the menu of possible new entries for the Who-Line. Who-Line process state The who-line entry *WHO-LINE-TTY-STATE-ENTRY* tries to display the current state of the TTY process. *WHO-LINE-TTY-STATE-ENTRY* [Variable] A Who-Line entry that displays the "state" of the current TTY process in the Who-Line. The typical state of a process is the name of the function that is currently running in that process. This simple minded result can be altered by use of the following items. [[NOTE: Because of the nature of the Lisp scheduler, this information is almost always out of date.]] The Who-Line "state" can be explicitly controlled from code. If the special variable *WHO-LINE-STATE* is bound, its value is taken to be the state of that process. You can use this feature to provide visual indiation of the state of your code by using the programming idiom: (LET ((*WHO-LINE-STATE* indicator)) (BLOCK) ;Give the Who-line a chance to run ...your-code...) This will run the ...your-code... with the Who-Line state of the process set to (the value of) indicator. The call to BLOCK insures that the Who-Line has a chance to update before ...your-code... is run. *WHO-LINE-STATE-UNINTERESTING-FNS* [Global Variable] If there is no declared who-line state (via a WITH-WHO-LINE-STATE form), then the name of the function that is currently running is used as the who-line state. However, if the function is on the list *WHO-LINE-STATE-UNINTERESTING-FNS*, the function that called it is used instead. The default value of *WHO-LINE-STATE-UNINTERESTING-FNS* is (BLOCK AWAIT.EVENT). WHO-LINE-STATE [Property] If the function that is currently running has a WHO-LINE-STATE property, the value of that property is used as the who-line state. This is used to convert functions like \TTYBACKGROUND to meaningful values like "TTY wait". (WHO-LINE-REDISPLAY-INTERRUPT) [Function] Updates the Who-Line. It is intended that this function be installed on an interrupt character, so that the user can easily force an update of the Who-Line. For example, (ADVISE 'CONTROL-T 'BEFORE '(WHO-LINE-REDISPLAY-INTERRUPT)) will cause a ^T interrupt to update the Who-Line as well as its current behavior of printing state information in the Prompt window. Alternatly, you can define a new interrupt character that will force an update of the Who-Line; (INTERRUPTCHAR (CHARCODE ^U) '(WHO-LINE-REDISPLAY-INTERRUPT) 'MOUSE) will cause the Who-Line to be updated whenever the user hits a ^U. Other interesting things *WHO-LINE-DIRECTORIES* [Global Variable] A list of interesting directories used to generate a pop-up menu of directories to connect to when you select the DIRECTORY item in the Who-Line. The default value is a list containing just your LOGINHOST/DIR. When the Who-Line notices that you have changed your connected directory, it updates this list to contain the new directory. (CURRENT-TTY-PACKAGE) [Function] Returns the name of the package of the current TTY process. This function is used in the default value of *WHO-LINE-ENTRIES*. (CURRENT-TTY-READTABLE-NAME) [Function] Returns the name of the readtable of the current TTY process, or the string "Unknown" if it can't figure out the name. This function is used in the default value of *WHO-LINE-ENTRIES*. (SET-PACKAGE-INTERACTIVELY) [Function] Pops up a menu of currently defined packages. If the user selects one of them, the current package is changed to the selected package. (SET-READTABLE-INTERACTIVELY) [Function] Pops up a menu of currently known readtables. If the user selects one of them, the current readtable is changed to the selected readtable.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 294) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE NIL . LETTER) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO NIL) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 3$$¤ hT6ČČT5ČČ6ČČT-ČT,Č,Č,Č,ŠŠ8,ŠŠ8HČČ PAGEHEADING RUNNINGHEAD CLASSICCLASSICCLASSICTERMINAL +MODERN +MODERN  HELVETICA +MODERN +MODERN +MODERN MODERN    HRULE.GETFNMODERN +  + HRULE.GETFNMODERN +  + HRULE.GETFNMODERN +  +  HRULE.GETFNMODERN  + + HRULE.GETFNMODERN  +   v ! 3g    — : ! x   @   Ł   ´   •      í   B   ÷ A "  ×  c   N   e   <   7   —   ^ !“   k Ř   t e    e    "  > M  + "   c  ŕ * Ź >ç GC   Q      ş   ˆ   ‹ %űzş \ No newline at end of file diff --git a/lispusers/WHOCALLS b/lispusers/WHOCALLS new file mode 100644 index 00000000..7ab633e5 --- /dev/null +++ b/lispusers/WHOCALLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "XCL" §BASE 10) (filecreated "18-Dec-86 19:03:25" {eris}internal>library>whocalls.\;2 4500 |changes| |to:| (fns distribute.callinfo distribute-call-info-for-symbol) (vars whocallscoms) |previous| |date:| " 7-Nov-86 02:47:11" {eris}lispcore>whocalls.\;2) ; Copyright (c) 1986 by Xerox Corporation. All rights reserved. (prettycomprint whocallscoms) (rpaqq whocallscoms ((fns whocalls whocalls1 distribute.callinfo distribute-call-info-for-symbol) (prop proptype calledby usedfreeby usedglobalby boundby))) (defineq (WHOCALLS (LAMBDA (CALLEE USAGE) (DECLARE (SPECVARS CALLEE USAGE CALLTYPE VAL)) (* |bvm:| " 1-Oct-86 14:05") (PROG ((CALLTYPE (|if| (LISTP USAGE) |then| (* \;  "some subset of (BOUND USEDFREE GLOBALS)") (SETQ USAGE (|for| TYPE |in| USAGE |collect| (OR (MISSPELLED? TYPE 70 '(BOUND USEDFREE GLOBALS)) (\\ILLEGAL.ARG TYPE)))) 'VARAPPLY |else| (SELECTQ USAGE ((USES VAR VARS BOUND USEDFREE GLOBALS) (SETQ USAGE 'USES) 'VARAPPLY) ((BOUND USEDFREE GLOBALS) (SETQ USAGE (LIST USAGE)) 'VARAPPLY) ((NIL CALLS) 'FNAPPLY) (\\ILLEGAL.ARG USAGE)))) VAL) (MAPATOMS (FUNCTION WHOCALLS1)) (RETURN VAL)))) (WHOCALLS1 (LAMBDA (FN) (DECLARE (USEDFREE CALLEE USAGE CALLTYPE VAL)) (* |bvm:| " 1-Oct-86 14:05") (* |;;| "If FN uses CALLEE in the CALLTYPE manner, add FN to the list VAL. This is separate fn because of the RETFROM.") (COND ((CCODEP FN) (CALLSCCODE FN CALLTYPE (FUNCTION (LAMBDA (CALLED FLG) (COND ((AND (OR (NLISTP USAGE) (MEMB FLG USAGE)) (COND ((LISTP CALLEE) (MEMB CALLED CALLEE)) (T (EQ CALLED CALLEE)))) (|printout| T FN ", ") (|push| VAL FN) (RETFROM 'WHOCALLS1)))))) (BLOCK))))) (distribute.callinfo (lambda nil (* \; "Edited 18-Dec-86 19:03 by Pavel") (add.process '(mapatoms 'distribute-call-info-for-symbol) 'name 'distribute-call-info))) (distribute-call-info-for-symbol (lambda (x) (* \; "Edited 18-Dec-86 19:00 by Pavel") (block) (and (ccodep x) (prog ((y (callsccode x))) (|for| z |in| (cadr y) |do| (|pushnew| (getprop z 'calledby) x)) (|for| z |in| (caddr y) |do| (|pushnew| (getprop z 'boundby) x)) (|for| z |in| (cadddr y) |do| (|pushnew| (getprop z 'usedfreeby) x)) (|for| z |in| (car (cddddr y)) |do| (|pushnew| (getprop z 'usedglobalby) x)))))) ) (putprops calledby proptype ignore) (putprops usedfreeby proptype ignore) (putprops usedglobalby proptype ignore) (putprops boundby proptype ignore) (putprops whocalls copyright ("Xerox Corporation" 1986)) (declare\: dontcopy (filemap (nil (653 4251 (whocalls 663 . 2057) (whocalls1 2059 . 3191) (distribute.callinfo 3193 . 3419 ) (distribute-call-info-for-symbol 3421 . 4249))))) stop \ No newline at end of file diff --git a/lispusers/WHOCALLS.TEDIT b/lispusers/WHOCALLS.TEDIT new file mode 100644 index 00000000..e8abce29 Binary files /dev/null and b/lispusers/WHOCALLS.TEDIT differ diff --git a/lispusers/WINK b/lispusers/WINK new file mode 100644 index 00000000..0792d7eb --- /dev/null +++ b/lispusers/WINK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Jan-89 00:25:22" {ERINYES}MEDLEY>WINK.;1 64134 changes to%: (VARS WINKCOMS) (FNS MARILYN WINKW) previous date%: " 3-Dec-85 11:10:51" {ERINYES}KOTO>LISPUSERS>WINK.;1) (* " Copyright (c) 1982, 1985, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WINKCOMS) (RPAQQ WINKCOMS ((FNS MARILYN SHOWMOVIE WINKW) (VARS WINK (WINKWINDOW)) (BITMAPS MARILYN MARILYNMID MARILYNWINK) (BITMAPS EINSTEIN LINCOLN))) (DEFINEQ (MARILYN [LAMBDA NIL (* ; "Edited 27-Jan-89 00:22 by shih") (SHOWMOVIE WINK (OR (WINDOWP WINKWINDOW) (SETQ WINKWINDOW (WINKW MARILYN))) NIL 200]) (SHOWMOVIE [LAMBDA (BITMAPLST WIN NTIMES WAIT) (* lmm " 3-Dec-85 11:05") (* shows a list of bitmaps in a  window.) (PROG (FRAMEPTR [FRAMES (for X in BITMAPLST collect (COND ((OR (BITMAPP X) (FIXP X)) X) ((BITMAPP (EVALV X)) (EVALV X)) (T (ERROR X " movie frame is not a bitmap." ] (WAIT (OR (FIXP WAIT) 250))) (OR (SETQ FRAMEPTR FRAMES) (RETURN)) [COND ((WINDOWP WIN)) (T (SETQ WIN (WINDOWBM (CAR FRAMEPTR] NEXT (BITBLT (CAR FRAMEPTR) NIL NIL WIN) (DISMISS (COND [(FIXP (CADR FRAMEPTR)) (* if entry is a number, it is  dismiss time.) (CAR (SETQ FRAMEPTR (CDR FRAMEPTR] (T WAIT))) (COND ((SETQ FRAMEPTR (CDR FRAMEPTR)) (GO NEXT)) ((OR (NULL NTIMES) (IGREATERP (SETQ NTIMES (SUB1 NTIMES)) 0)) (* do another round.) (SETQ FRAMEPTR FRAMES) (GO NEXT)) (T (RETURN]) (WINKW [LAMBDA (BM) (CREATEW (GETREGION (BITMAPWIDTH BM) (BITMAPHEIGHT BM]) ) (RPAQQ WINK (MARILYN 2000 MARILYNMID 50 MARILYNWINK 150 MARILYNMID 10 MARILYN)) (RPAQQ WINKWINDOW NIL) (RPAQQ MARILYN #*(188 254)@B@@@@@DHDBA@HHJABJ@H@AD@@@@A@@@BH@@@@@B@@@@@@@@H@HBA@I@@BH@IA@@@@DDDJJ@@@A@D@@@@@B@@@@H@@@@@@@@@HA@HABAAAADD@JDJE@@@DIDH@@D@@@@@@DH@@B@@@@@@@@@B@@AA@H@@DHJBD@@@@DJJI@HBD@@@H@@@@B@@@@@@@A@@@I@@DH@DB@HEBE@HADIBD@@@BEA@@BA@@@@@@DH@@@@@@@@@@@@D@BB@HJ@@D@BBD@@DAEDDHHD@@@@BDB@@@B@@@@@@@@@@@@@A@HHJ@@ABIEDI@JHAD@@ABDHI@BD@@@@@AED@@@@@@@@@@@@H@B@ABJH@DHBDD@A@ABJHA@B@@@@DH@@@@AB@H@@@@AB@AB@@@HAD@@@JIBHHAE@DHD@BDE@@@BH@D@@@@DH@@@A@@@@@D@@@@@DBDHH@DABBH@A@@IE@@@HDI@@JH@@@@EB@@@@@@@@@AD@HDH@I@@ABADDHAE@@HB@@JJA@@@H@@@@@ABH@@@@@A@@@H@@@@AB@DDDADE@B@@HBBIDH@@H@ADB@H@B@HDH@@@AB@@H@D@@A@H@BAA@DA@JHBHA@@@@BJD@DHA@HBDH@AED@@@@@@@@@@D@@BBBA@@ABHJ@A@A@A@JH@AAD@@HDI@@@H@JH@@@@@H@@@@@@D@DHHDE@@DEEDJD@HD@DID@@HJB@@@@B@EFJ@@@@@@@@@@@@AB@@AA@DEABHH@@@@BJA@A@H@@HHD@B@@BFHH@@B@@D@@DB@@@JBDDD@@DHDAA@HB@ADDHD@JD@A@@@JAEMD@@@@@B@@@@@@@@A@A@A@EABI@D@@HID@@B@D@IBD@D@@@AFJ@@@@DH@@@@@@BA@BHBHA@DDDI@@@@@A@E@IAB@DH@@B@HKKDH@@D@@@@@@@@@@B@B@A@AABH@@HIADHHHHD@@IA@@@@B@EFJ@@H@IBD@@@@@I@HIAADHDDIAAB@@DBBBBAADHDD@D@@@BHM@H@@@@@AB@A@@@B@@DDBAAADHH@@@A@@@@H@@DHI@@D@H@EFJ@@@H@@@@@@@@@@BBAA@@DJB@AABBJB@HH@ADH@D@@@@@EBD@@@DADHB@@@@@DI@AD@JE@AEBDD@@@@@@DI@@@J@D@@B@@EED@@A@B@@H@@@@@@D@BJ@@EDHHA@HDJAADB@@JJ@J@@@@@B@J@@@DD@@B@@@@@BD@B@@D@@JD@@@A@@H@@HJJD@@@@A@@@AEED@@@@DB@B@@@@@@IABA@JDAB@H@@@@@B@B@@BBJ@@@ABBDBE@@ADD@H@H@@@@IB@@@DB@AD@@A@H@D@@DHJJID@@@@D@@@IDH@HAAB@@@@H@@@@EBI@H@IBIA@@@@@@BABD@JAA@@@AB@AEB@@@@@I@D@D@@@HB@@@@@@DH@@@@A@B@H@DAEADDA@E@@@DAD@B@A@@@@@@A@@B@IDEABAB@I@A@@@DBAEADBDB@@@@@@@@JHH@@@D@H@H@H@@@B@A@@@H@H@AD@HA@@@@DI@JHD@B@@@DJD@B@@AAD@@@@@@@I@@@DDI@HBDH@D@H@HB@JDEA@@A@@DA@ABH@B@@HB@B@@HD@@@BBB@@@E@A@D@@@@@@BA@@DA@@@J@@BJH@@@@JAADH@BA@@@@@@I@HB@@HAA@H@@@@HJED@@@@@@@BDEJ@DDI@IDH@B@@@@DB@JB@A@J@E@D@@@I@HB@@ADHHDDH@@INDB@@@BDJBA@@@@@@@BA@A@B@E@A@H@H@BB@IDD@B@@@@@ACE@@@@@DABH@@@D@@@@H@D@D@D@EDD@D@A@@DD@@J@B@@DHJOJJ@@@H@JJDJBI@D@D@@BA@HI@E@@AB@@@@@@@IB@IAED@@AEN@D@@@AAEDAB@@@@IBBADA@@E@JJD@@HDH@@J@AD@@@@IEGOOJ@@@@JJBJJHAD@@B@HDA@BI@BB@@A@@A@IBABD@DHJ@@BOONHH@@BABJDBDD@H@HBABJE@@EAEEEDDI@@@@@@AE@@@HKOOOFNJHA@DJIBIE@BA@DHD@A@JD@IDJ@@B@D@DHBD@@@HHBGOKNOEB@@@BIDHEE@@@@HBIEDD@AEDFIEEDIA@@@H@BD@@EDOMMBIGNJH@IFNKBJJIB@BJDBBBJDDBJDIBA@@@HH@H@HI@HBONJMEEKE@HACE@JJJD@@HAEDI@@AGOOJDIDDI@B@D@JBDECONMJB@KOOJCEEMNJEEEJ@AEDHDJJJEGNMBJB@@@H@IBA@A@KOOJJHEAONHDJJJJJKJHI@DBNEB@HAGOOOOJME@@AB@HHJHKONJD@@@@AONIEGOOMNMGE@AAEDIBDJOOOONKBBD@H@DDJDEGOMJH@@@BMOJEBMOOGGEEE@@DOEDABAGONIGOOJADA@BBBKEFOB@@D@B@@AOEMOOOMMEDM@EAEJBHHIGOMFMONIDA@DHHIEEGODDHA@@@AENMGGOMOGEEE@@BKEIBDDOOB@COOMBJEABDJL@KLH@@D@@@@BONMMOFKMJD@@@ACFDIBIGNIEEGNJJA@HIBDMFGM@HB@@@@BEFKGGOOEFJJJ@BDKEJDIBOID@@KONMJEEDIB@IJJDBH@@@@@@INMOFIEJHIB@@BEJJIDIGJA@EGOOFIDBBDIE@ODA@DDD@@@BEOGMOMDKDJB@@IBKEBEBODDB@IGMOJCDJH@HJ@KJOMKB@@@AEEKGEEFLJEA@B@IGEEDIFH@@JEMONIDIDEDEBJJEBNLIB@@DEOGMOJIEDI@@@DEEE@JKNABDEOOOOMEBBHA@HDKNOKONHDDABFIGEEEEDDD@BABKEEEEOD@AEOOOOEDHHB@JEBBKFOOMD@AAEFMKNJBKDB@@@BDE@HICN@DKOOEEGJJ@EDDABIEIABEEOD@@@JJMEJJDAAA@@HJJEBEINH@EGOOKMJIB@@@J@EFLJKKGEB@EFEBKNIEBHDD@B@@ABEDKN@EGOJ@DBODHJHBAEJ@@BOOHNHD@AEEJJD@HAB@@@BBJHHKENHBONMJAEEE@@A@HJEEEDONKEJ@EEBJKEFJD@HH@A@A@EBFINEEOOOOJABMEDDDEAH@IOOOOOIEB@HDHJH@A@D@@@@HJHIEENHKOOONIDJM@AAA@JMDDOOOOMDHIEBJJEEBHD@@@BBD@DDJKNKOOOOOOJDBEDD@JDBAOKOOOGONNJ@AEDJ@@H@@@@@HIBIFINMOOOOONIBI@@@BEBHBKGOOOOOJKHBEBE@@D@@B@HI@@HABKOGOOOONKNHEE@@HHHDHLKMGMGOONJ@IEEDAADEB@B@BBBHJEOOOOONNKNJHIDHBBE@EMBOOJOOOKHBDIDHDDH@J@H@@HHEBHOOOOOOJDGJED@@IEABKDEOOJAOONJ@BJJJ@@BMB@@@JBBIDEGOOOOOJIGKBBD@B@JBKIBOOHEOOOH@DJJD@EEEE@ABA@IDKEOOOLGOM@IMDIBIDNHHNDAONJBOJDDAABIEE@BIF@H@JBBBDINMONOOJ@EOAD@@BI@BO@DMGDEGOEB@AEED@EBEK@@BAAAEEGJGOIANHI@@HAEEDJEA@DBFJ@BL@@@@DEEEEBJMN@BHJDJBFIMAOHKOE@BJEB@@IDH@E@ICMAEOJDH@ABIBBBJJO@@@AAAEEGJJBOEBJ@HDHHJDDJ@B@@D@ADI@@@@BDJJIEEEOO@IBJDE@JKJ@JJJM@HBBBDABJIDHDA@JDBEFHH@@AEBDHJJKO@@@AABJFMLJKFJJJBHHIBJ@AD@@@@H@IDID@@B@DJIBEBEFO@IEDDHBJKJ@@IDHDH@BBD@EDBIAA@A@@@B@A@@AAEDI@IEOO@D@BBEDEGI@JEIBI@A@HHAABH@@@@D@@B@J@@A@ABJJDHJKO@@BHHHIBOJDA@@@@@HDB@HDIED@@@H@@@D@@@@@JJI@@JIEE@E@DBE@IGI@DEEADBB@HDBBD@A@A@@@D@AB@@@BAEDJHJEEE@@BBA@EENJA@@@D@@@@B@@HIED@@@@@@E@@@@@@DJJ@DEDJ@@J@IBE@CGH@@DA@@@@DI@HBBD@HH@@@B@@@@@@@BJIE@IBAD@ID@H@AENJ@A@@@@@J@BDA@IBD@A@J@@@A@@@@@AEE@@DJMB@@@JEE@INHHH@@@B@@@HH@BDI@H@@@D@@@@@@@@DJJHBBEBE@DD@@BEGNJ@@BB@HAB@B@B@JDB@@@@@@B@@@@@@BIDDIJJJH@@@BEDHMNDA@@@H@H@DIA@JBI@@D@@@@@@@@H@@HJJB@EEED@@@@@BEGOAD@@D@@@I@BD@ADDDH@@@HBHB@@@@@BEE@EEFHB@@@IBI@ONJ@@H@AB@@AA@BJBIA@@@@@@@@@@@@@AEDI@JKFH@BD@BDOGNH@H@@@@@DHJ@H@IDD@@@@@@@@@@@@@DJJH@JOJ@@@@@HIAONJ@A@I@@@@D@H@BDJ@@@@@@BDB@@@@@AEMBDEJKD@EBJBFOOO@IB@@@@@DADB@HJMDID@B@@@@@@@@@EEE@@JOM@@D@@ICKONJ@@B@@HAA@B@DBAD@D@@@@@@@@A@@@BGJH@BKEA@KDJEEGOOHHHHD@@@@DHHA@KEE@@@H@A@@@@@@@IEFA@IFMD@E@@HJOGNJBB@@@I@@@D@HBELH@A@@D@@@@@@@@EFJH@BKFH@OEEBKIKOI@HB@@@@DBB@@@JOBHH@A@@@@@@@@AEKJHD@@I@@KDHIFMENJ@DDD@@@A@HDA@EJIB@@D@@@@@@@@@EMEB@@DJD@FJEGKBEGIEA@AB@HD@E@@BKOE@@D@@@@@H@@DIBGJID@@A@@MEBBMABNJ@DDH@B@@DH@@HEKEDB@@@@@@@@@@@EEJD@@@@@@JHIEEDIGMAA@@H@@DBE@DEFMEA@@@@@@@@B@@DIOKKD@HE@@MEBJJDBEJH@EA@@@@DHBA@KEED@@@@@@@@@BAAEJLJH@BB@@E@HDIBHKJBI@@@A@AABHDEKMBI@@@@@@@@@@@DEGEJD@HH@@JJEBDHBEJH@ID@@@DDJDABOEED@@@@@@@@@@BBJMEFH@DJ@@DABIBB@IFDJ@@@H@@BM@JEODBM@D@@@@@@@D@ACJJJHBJA@@JHIDI@IBJH@EBHBDADNJDKOE@H@@@H@@@@@@IDINJMDADJ@@MBDBDJ@AFEA@@@@@DBOJOOOMBN@@@@@@@DDB@BJKEE@BH@@@DIBHI@JHJHDDD@J@AEOEJKOLJJ@@@@@@B@@@AEEMBJLBHI@@NDIBDD@BFEA@H@@HD@OOOOOOEMD@@@@@@B@HDBKFJM@D@E@@K@DIABJAE@H@@@D@@JOMOOONKD@@@@D@@H@AADMNKFH@@J@@MDIBDH@JEEBA@A@@@EOOKONOMJ@@@A@@@@@DBBJKEJI@@J@@M@DIBBJAAD@HD@@@DBOOOOOOFI@@D@@@@@BBHJJMEEDD@K@@NJJDHH@JDED@@H@A@HBMMM@IED@@@DDAA@@@BEEFJJI@JMD@GBBHDBHABIBA@A@@@BKOFMMEJ@@HA@@@@@DHIACJMJD@BJJ@MDJEBHEDDDJJA@B@@@@@I@@H@HHA@AADDJ@EBELMFJH@JJM@OECBDE@AABJHHH@@A@DJDDEBD@DHB@@@@@EADJGGKJL@IEK@ODIDI@EDBIDD@@AA@@A@A@H@A@@@@DDDDA@DBADJEF@@@EF@ODDBDJABDEFID@DDB@H@@@@JHBDB@@A@@HBIDJKEOJL@@JM@MJJIBADHABJDBI@@H@@@I@J@E@I@E@DBBB@@BEEJIJ@@@EE@NJABIDBBDENI@@B@@@J@@@@J@DD@@A@@@HHDEBJMFJ@@@JJ@OMDDDADH@BJDJI@AA@@I@H@@JH@@HDBDDDA@@IEGKD@@CEM@JHHBB@H@BIFJA@DD@@H@B@ID@@J@D@@@BBHBEEBMLH@@BJJ@OFBIDJD@HBJHJDA@I@DJ@@DBJJ@B@HBBADA@BBKFJJIEOOE@OIDDIABB@DNJDBH@@@B@I@@HBDJ@@A@@D@@IADIKEAEECEM@OECODDI@BBEA@H@@IBIE@EDEJHA@E@@HBD@@JBKMJMOOONJ@MLKEBABD@AFJA@BH@@DDA@BJEADD@@DB@BEEAAEFJGOOOGG@OOONMDIAEDNID@@ABJOKFOMMMDB@@DA@EA@@DEBOEMMMMKH@OMGKEBDH@AGEBBD@@EJJJIEFJBIB@@@@@D@@EAEJJGMOOME@OOOOJMBBJIFJIDHDEGOOOOOOOLHHIBDHA@@A@JJNKOEEDKM@OOONOEE@H@NJJB@@EGOOOOMOMEE@@@@D@HD@EBEFKOMOKGE@OMKOJJHIBJGEAA@BAGOOOONOOEDHD@A@@@@@DIEMENMEFKJ@GOOKOMEBEAEDLH@HMOOOKOKOOOKE@HDABBABBEJKOKOMJJM@NOOOMFBDJJNJBDHACOOOOOOOOOLHHD@H@H@@IEEMEOMNIED@OOOOOMJAEMEEJIADOOOMEDKOOOOMA@@@D@BDDJNOOOGE@BJ@KOOOOOIDGENJIB@BGOOOMOFOOOOD@@A@BHD@BFKEOOOLABH@OOOOOONBAEKADHIEOONH@@ABOOOMD@@B@@@BEBMOGOMFDAB@MOOKOOJHJKFMEB@IOONJE@JGOOONHH@@JHA@DIGEONOM@B@@OOOOOOOMEEJIDIEGOOM@@D@HCOOMB@AB@BDBAEEOOOOD@AD@OMOOOONJJENJJD@GOONEB@BAGOOND@@@BI@@HIKOOOMJ@BH@OOOKOOOOMDBHAAA@OOMDHHHJKOOE@D@D@@@DEFMKOFNH@JD@OOOOOOONNIEEDHHIGOMDB@EEKOOH@@A@BEB@BEKOGOED@ED@GMOOOOOOJJDIBB@@EOOMIECKMDIDI@@@H@@EDJMGOJOD@JJ@OGOOOKMONHIBI@@ECOEED@KFOMN@@H@H@J@BAEGOOOJIBEB@OOOGOOOOOEBDDHD@IEOMGFMODJEDH@B@@@DDDFMOOEED@@H@KOOOOOOOOHDIEA@@ENJLJIFKGGDHB@@@D@AABJOKONLH@BE@ONOOOEOMONHDHHBDEEOEA@AEMHI@HB@E@IDDDKEOOKE@@H@@OOOKGOOOOJBIEA@@COEDJDHJMFDDA@I@B@A@BEOFONH@@A@@KGOOOOOOOOHDDHDBHEKM@@GGEA@@D@@@@BDEENKOOJJ@ADB@OOOOOKOOOMEBJEBHBFNJJHIMMD@I@D@AA@IBIEOGONHH@HA@MOOOKOOKOOJIEDH@DHKMEFNLBAB@B@BD@@BDFKGOOJH@EOJ@OGONOOOOOOLDJJBHBEBNJJOFID@@@H@@BDDBJMOOONH@BDH@OOMOOOOKOOKKFID@@@JKOMJID@IBB@AD@@BIGGOOMJHEBKG@KNOKOOMOOONEJJB@DJEMGGGD@@@@ADBB@A@EEOOOOJHHBOJ@OKOOOOGOGOJHFJH@@A@BI@HEDDIAD@@IEDKKOOOOOJBCJJM@NONOOKOKOOMEFJDABDJHFMBHH@@BA@DD@BDJJOOOKJ@@JMF@KOOOMOKOOOGBEEBH@BABH@@BBHJ@D@@BJDIOOOGONJ@NKEK@OGOGGMMOOONIGDI@JDD@@HHID@@H@DA@DBEEGOOOKJBBJJN@ONOOOGGOOOKJKODH@IABDB@D@BDBI@@JBIENMFNNOH@JJJK@MKOOMNOOOKOIFJJBI@D@@H@BD@@H@@DADDKGGOGONLBEEEJ@OOOOOKOKOONNOOJH@BADB@DH@HJ@J@ADBJNMOMOOOJAFJJO@OGKONOONOOOKKMEEBHD@HD@A@D@@@DDHICGOFONOGJEEEEJ@MNOOOMOKOOONNOJ@H@@D@@IDB@IBJBIFFMNKOOOMOHBJJEE@GKOOKONOOGNOKFMEB@HHEB@@@B@@A@DEEFKNJMKONMAEEEK@OOOOOKOOOMOMOONH@BB@H@@JI@E@DJKJMOOGOOOKOJBM@JE@OGOOOOOMNOOOMOJE@H@@@HD@@D@D@IAGGFJOKGOOGJELBEB@OOGONOOOOOOKOGOHJ@@@J@ADD@I@JDMNMOOJMOOMOJJED@J@OMOKKOGKKMOOKMNJ@@HH@@@@AB@DEBGGOMJMOGOGOJJMA@E@OOOOOMONOONKNOOJJ@@@D@DB@@JA@MKNONOKKNOOMOGDHAE@OGOOOONOOKOMKGOJDH@H@@A@BJ@HJMGOOOEMMGMMOMKE@@J@OOGONJOMOONKOOOMHAB@HHHA@@JEGGOOOKOGGOOOGOOE@EG@OMNOKOGOKJOMMGONE@@@B@@DBHEBBNMOONKOKONOOMKD@@J@OGOOOMOMOOOOOKOOJEBD@DH@@EAEOOOOOOOOMEOMOGGEBNM@OMKOOGOOOKGOJNONI@@HB@BIB@JKGOOONOOOGOGGGMME@BJ@OOOOOOONOOONOKOONJDAAD@BDJENOOOOOOOOJCOMNNFLKKO@OKOOOKGKONOOJMOOMA@HJ@I@HICMOOOOOOOMMJNNOKEE@ME@OOOOKOOOOONNKGOOOLJEADBJJMOOOOOOOOKNJBGEEMEEFOK@OOGOOKOMOKOOJIOOOEBHJA@DJJKOOOOOOOOJHIOJOFJJJMN@OOOOGOOKOOOJJOOOOOMOMMGOOOOOOOOOOEJJ@DFJIJJEGOE@OOOOKENOGOOOJEKOOMFNOEEFNOOMOOOOGOOJICGJJNJJMON@OOOOOOOOOOONMKOOOOOOOOOOOOOOOOOOOJJH@AGIGEKGGGG@OOOOOOONOOOGJJMOOOOOOOOOOOOOOOOOOMMBBEGJMNMJMOM@OOOOOOOOOOONOGGOOOOOOOOOOOOOOOOOOJJH@AGJGEEGOOG@OGOGOMOOONMOJMOJMOOOOOOOOOOOOOOONNJ@@EGJKNJJKGN@OOOOOGOOOOOKOFJOOOOOOOOOOOOOOOOOGJH@A@OJMEEKOMO@OOKKOOOKOONOKKONEOOOOOOOOOOOOOOMNH@H@EGJKNMFJOJ@OGOOOEOOOOGOOMGKEGOOOOOOOOOOOOOOFJH@@EGIFKFKOEO@OOOOMOOOOOOJMGNNJJOOOOOOOOOOOOOKJ@@@AAGOKMKMEOE@OONOOMOOOOOOGJONHMOOOOOOOOOOOOONMD@@@DOMMFJFNKO@OOOOOOOMOONJNOGFJBOOOOOOOOOOOOKJB@@@AAEOFMMKGOM@OGOKKGOOOMKMKKMM@DOOOOOOOOOOOOOJH@@D@AEOKKFMJMO@OOOOOOGOOOOGNMGNMACOOOOOOOOOONMDH@@@E@KNNNMEGKE@OKGOOMOKOGNMGKOK@DKOOOOOOOOOOOOJ@@@@@DKOGGGFJOO@OOOOOOONONOOMEENL@EOOOOOOOOOOMH@@HJ@BBEOMKJMOMK@OGOGOOMOOONKFIOKBABOGOOOOOOOENNH@B@@@AEOGMOGEGM@OOKOOOOMMKOOOEFNH@DKOOOOOOOOOD@@A@@A@DCOMFJJKOG@OOOOOGOOOONMFKOMJ@INOOOOOKOOMJJ@@H@D@@IMGKMMFOM@OOOOOOONOOKONIGGHH@COOOONOOEDD@B@@@@DBKGNNNKKOO@OOOOOOOOMKOJJMMNJBDJOOONONONK@D@AB@@@AEOOOEEGMO@OOOOOOOKOOOONKGOH@@ACOEKEEJDDEADD@@@@HENKEOMJOM@KOOOOMONOONNKEOOEBJJKMNNMMGE@HD@A@@@BABOMNJJKOO@OOOOOGKOOOOONOOOHH@@@JJI@@H@BAA@@@D@@@EEEEDKGKG@OKOOOOOOOOOKOEGKJAE@JJIDJ@BH@DDDIB@@@BDKKKEEKOO@MOOOOOOMOOOOEKONHHDBAADB@JHBI@A@@HB@@@EFHJJKFKO@OMONOGMOOMOMNMOOJBBHDDBID@E@@@DBB@@@@HEEJJIEKOG@NOOOOOONMOOOOGONJ@HAA@HDAD@JJJ@D@@@@@@EFH@BJMGO@OOOOOKOKOOOMMKGKIBBJDDDABAB@@@A@IAB@@AAEBHHJKMM@OGOKOOOOOOOKOKOOJHH@@@ID@DAEEE@@B@@@@@EDH@@BKGG@MNOOKOOOOOOONMOOHBBJI@BEB@JD@@DA@@@@@AEBHBADKOO@OOOOOOOOGOOKGKKNJHHHDDI@DHAAEB@HDH@@@DEFJH@@JKM@OKOFONOOOOOOOEOOJDJ@A@DI@@HH@@@@BBD@HABJH@@@JNO@OOOOOKOKOOOMNNMJHBAEDBHDBJBDHHB@D@@@@@DIEB@@AGM@OOOOOOOOOMMOOKOOJHDB@@E@H@A@B@@@@@@@@ABJI@@@BKG@OOOOOOGNOOOOJJEJDAADDE@DBJD@HB@IA@@@@@JDDJ@@@DM@OOOOOKOGMOONOKKK@HB@@@DI@A@H@@D@@@B@D@EEBH@HABJ@OOKOOOOMOOOKJLNHH@HIEABDJH@@HD@B@H@@@A@HID@@@@K@OKOOOOMOGOONOGEJA@B@@@I@@DBD@@@@@B@@B@BEDJ@B@@J@ONOOOOGKNMMKJIJA@@IEDHDEE@H@D@A@@@@@@@DHA@D@@D@@OGOONMOMOKOMGEFHDHD@B@BI@JADAA@AA@@@@A@EDF@@@@@@MKKOOOOGEONMMJH@@AAE@HHDD@@@H@@H@@@@@@BDA@HDB@@@ONOOKOMMOOOKFIBAA@B@E@EBHI@@@D@@@@@@@@IBDJ@A@@H@OGNMOOGOOKJMJD@@@@HI@DHI@@A@@@BBB@@@@B@A@DHH@@@@MKGOOKOOFOOFMB@@HH@DDH@D@@@DB@@@@A@@@@BDED@@@D@@OOJKFONKONMJB@DABAE@HBJ@I@I@H@@H@@@B@@@A@BI@@@H@NKMOKNOOOOOEH@A@@@@@A@@J@@@DAB@@B@@@@@@@BJ@A@@D@GOFMOKKOFJJH@@@IDDHDHDJ@JD@@D@D@@@DDB@IB@H@@@@@@OOMOOFOGOOMD@@E@@AA@@@@JA@DH@A@B@@@@@@@@EBDH@HH@NMGFKKMMFMDAA@@BJ@@@HIB@HB@@HHA@B@@@@@DJ@D@@@@@@GOKKMFOOKNJH@@I@@@@H@DADDH@H@@@H@@A@B@@@ABHA@@H@OFNOGKOEMA@@HDBAEBD@D@DBH@HDI@@@@@@@@@ABHD@@@@B@OOOKMMKKFJE@@@DH@@@DA@A@E@A@@@@DHB@@@@@@BAD@@@H@OMNOGGMJI@@BAA@AE@H@H@HJHDD@D@@@B@@@@@DI@HA@@B@@OGOOMJNMDHH@@DED@HDHDHE@BA@D@@@@H@@@@@@@DE@@@@@@OOOMFDA@BABIEA@A@B@D@@@DHH@HID@D@@@@@@@EA@B@@@@@OOOOJJJDD@@@@DJJAADAE@E@DAD@@@A@@H@@D@A@HJ@HB@@@NNOGMADI@IEBJB@@HD@H@D@DHD@HHH@@D@@@@@@BA@B@@D@@OOON@@@@@@@HAABDBADBI@BB@HDDB@@@@@@@@@@A@@H@I@@@OOOODDI@DEDBDHHA@@B@@@@HD@ABHBA@B@@@B@DDHH@H@@@@OOOLI@@DA@BHBBA@JEADJDJEAB@@@@@@@@@@@@@@@B@@BDB@OOOM@@I@H@@BI@DA@@H@H@A@D@JHA@@@@@@@@@@@HHHBA@@@OOOJBA@@BEE@DJ@HJJEEADHHID@@HBI@@D@B@@DB@B@H@E@@OOOL@D@@H@@JB@HB@D@HB@E@@BDJ@@@D@@A@@@A@A@@@DHD@OOOMEADHAAB@HIA@IADEDJ@JE@@@DHD@D@H@@@D@@B@A@BI@OOOMB@@@DD@HE@DI@HBHA@J@@@I@HAA@@@@@@A@A@@@@@AD@OONDHAE@@@DA@B@@BBHEDD@HJJ@J@D@@@@@@D@DH@@@@@@@@OOOBBD@@BA@@B@HBHHE@@@DDA@J@I@B@@@@@@HB@@@A@@JJ@OOLHI@JI@HEDHHA@AB@IBH@@DD@J@@@@@B@HH@H@DDD@@@A@OOMB@B@@DA@@BBDADDHDDDJBA@@@@@@H@@@@@B@@@@@@@AD@OOLHE@DHA@BA@H@DA@B@I@A@HDEAB@B@@@B@@@DAA@@@@@C@OONA@DBADB@@JBIA@@IB@IDJ@A@@@@H@@D@@@HBD@BD@@HH@OOMDEA@H@@D@@HB@JJB@HDA@JHBD@B@@@@@@B@D@@A@H@@B@OOO@HDJA@H@IDA@D@@HJBABB@DH@A@H@@DDA@@@@@HH@@DH@OOMDB@@HBAD@BHEAEB@@HHDIEABI@@@@@A@@DABD@@@B@@A@OONA@BDB@@BHDA@D@@DJABBDBD@@@@A@@H@@B@@@H@@@@HD@OOMDB@A@IB@BADJAEEB@DDIBH@JDB@@@@B@@@@@BBBD@B@@@ ) (RPAQQ MARILYNMID #*(188 254)@B@@@@@DHDBA@HHJABJ@H@AD@@@@A@@@BH@@@@@B@@@@@@@@H@HBA@I@@BH@IA@@@@DDDJJ@@@A@D@@@@@B@@@@H@@@@@@@@@HA@HABAAAADD@JDJE@@@DIDH@@D@@@@@@DH@@B@@@@@@@@@B@@AA@H@@DHJBD@@@@DJJI@HBD@@@H@@@@B@@@@@@@A@@@I@@DH@DB@HEBE@HADIBD@@@BEA@@BA@@@@@@DH@@@@@@@@@@@@D@BB@HJ@@D@BBD@@DAEDDHHD@@@@BDB@@@B@@@@@@@@@@@@@A@HHJ@@ABIEDI@JHAD@@ABDHI@BD@@@@@AED@@@@@@@@@@@@H@B@ABJH@DHBDD@A@ABJHA@B@@@@DH@@@@AB@H@@@@AB@AB@@@HAD@@@JIBHHAE@DHD@BDE@@@BH@D@@@@DH@@@A@@@@@D@@@@@DBDHH@DABBH@A@@IE@@@HDI@@JH@@@@EB@@@@@@@@@AD@HDH@I@@ABADDHAE@@HB@@JJA@@@H@@@@@ABH@@@@@A@@@H@@@@AB@DDDADE@B@@HBBIDH@@H@ADB@H@B@HDH@@@AB@@H@D@@A@H@BAA@DA@JHBHA@@@@BJD@DHA@HBDH@AED@@@@@@@@@@D@@BBBA@@ABHJ@A@A@A@JH@AAD@@HDI@@@H@JH@@@@@H@@@@@@D@DHHDE@@DEEDJD@HD@DID@@HJB@@@@B@EFJ@@@@@@@@@@@@AB@@AA@DEABHH@@@@BJA@A@H@@HHD@B@@BFHH@@B@@D@@DB@@@JBDDD@@DHDAA@HB@ADDHD@JD@A@@@JAEMD@@@@@B@@@@@@@@A@A@A@EABI@D@@HID@@B@D@IBD@D@@@AFJ@@@@DH@@@@@@BA@BHBHA@DDDI@@@@@A@E@IAB@DH@@B@HKKDH@@D@@@@@@@@@@B@B@A@AABH@@HIADHHHHD@@IA@@@@B@EFJ@@H@IBD@@@@@I@HIAADHDDIAAB@@DBBBBAADHDD@D@@@BHM@H@@@@@AB@A@@@B@@DDBAAADHH@@@A@@@@H@@DHI@@D@H@EFJ@@@H@@@@@@@@@@BBAA@@DJB@AABBJB@HH@ADH@D@@@@@EBD@@@DADHB@@@@@DI@AD@JE@AEBDD@@@@@@DI@@@J@D@@B@@EED@@A@B@@H@@@@@@D@BJ@@EDHHA@HDJAADB@@JJ@J@@@@@B@J@@@DD@@B@@@@@BD@B@@D@@JD@@@A@@H@@HJJD@@@@A@@@AEED@@@@DB@B@@@@@@IABA@JDAB@H@@@@@B@B@@BBJ@@@ABBDBE@@ADD@H@H@@@@IB@@@DB@AD@@A@H@D@@DHJJID@@@@D@@@IDH@HAAB@@@@H@@@@EBI@H@IBIA@@@@@@BABD@JAA@@@AB@AEB@@@@@I@D@D@@@HB@@@@@@DH@@@@A@B@H@DAEADDA@E@@@DAD@B@A@@@@@@A@@B@IDEABAB@I@A@@@DBAEADBDB@@@@@@@@JHH@@@D@H@H@H@@@B@A@@@H@H@AD@HA@@@@DI@JHD@B@@@DJD@B@@AAD@@@@@@@I@@@DDI@HBDH@D@H@HB@JDEA@@A@@DA@ABH@B@@HB@B@@HD@@@BBB@@@E@A@D@@@@@@BA@@DA@@@J@@BJH@@@@JAADH@BA@@@@@@I@HB@@HAA@H@@@@HJED@@@@@@@BDEJ@DDI@IDH@B@@@@DB@JB@A@J@E@D@@@I@HB@@ADHHDDH@@INDB@@@BDJBA@@@@@@@BA@A@B@E@A@H@H@BB@IDD@B@@@@@ACE@@@@@DABH@@@D@@@@H@D@D@D@EDD@D@A@@DD@@J@B@@DHJOJJ@@@H@JJDJBI@D@D@@BA@HI@E@@AB@@@@@@@IB@IAED@@AEN@D@@@AAEDAB@@@@IBBADA@@E@JJD@@HDH@@J@AD@@@@IEGOOJ@@@@JJBJJHAD@@B@HDA@BI@BB@@A@@A@IBABD@DHJ@@BOONHH@@BABJDBDD@H@HBABJE@@EAEEEDDI@@@@@@AE@@@HKOOOFNJHA@DJIBIE@BA@DHD@A@JD@IDJ@@B@D@DHBD@@@HHBGOKNOEB@@@BIDHEE@@@@HBIEDD@AEDFIEEDIA@@@H@BD@@EDOMMBIGNJH@IFNKBJJIB@BJDBBBJDDBJDIBA@@@HH@H@HI@HBONJMEEKE@HACE@JJJD@@HAEDI@@AGOOJDIDDI@B@D@JBDECONMJB@KOOJCEEMNJEEEJ@AEDHDJJJEGNMBJB@@@H@IBA@A@KOOJJHEAONHDJJJJJKJHI@DBNEB@HAGOOOOJME@@AB@HHJHKONJD@@@@AONIEGOOMNMGE@AAEDIBDJOOOONKBBD@H@DDJDEGOMJH@@@BMOJEBMOOGGEEE@@DOEDABAGONIGOOJADA@BBBKEFOB@@D@B@@AOEMOOOMMEDM@EAEJBHHIGOMFMONIDA@DHHIEEGODDHA@@@AENMGGOMOGEEE@@BKEIBDDOOB@COOMBJEABDJL@KLH@@D@@@@BONMMOFKMJD@@@ACFDIBIGNIEEGNJJA@HIBDMFGM@HB@@@@BEFKGGOOEFJJJ@BDKEJDIBOID@@KONMJEEDIB@IJJDBH@@@@@@INMOFIEJHIB@@BEJJIDIGJA@EGOOFIDBBDIE@ODA@DDD@@@BEOGMOMDKDJB@@IBKEBEBODDB@IGMOJCDJH@HJ@KJOMKB@@@AEEKGEEFLJEA@B@IGEEDIFH@@JEMONIDIDEDEBJJEBNLIB@@DEOGMOJIEDI@@@DEEE@JKNABDEOOOOMEBBHA@HDKNOKONHDDABFIGEEEEDDD@BABKEEEEOD@AEOOOOEDHHB@JEBBKFOOMD@AAEFMKNJBKDB@@@BDE@HICN@DKOOEEGJJ@EDDABIEIA@AEMD@@@JJMEJJDAAA@@HJJEBEINH@EGOOKMJIB@@@J@EFLJIGGAB@EFEBKNIEBHDD@B@@ABEDKN@EGOJ@DBODHJHBAEJ@@BD@HNHD@AEEJJD@HAB@@@BBJHHKENHBONMJAEEE@@A@HJEEEEEFJEB@EEBJKEFJD@HH@A@A@EBFINEEOOOOJABMEDDDEAH@IHJEAKIEB@HDHJH@A@D@@@@HJHIEENHKOOONIDJM@AAA@JMEDAA@DDF@IEBJJEEBHD@@@BBD@DDJKNKOOOOOOJDBEDD@JDBDIHOOOAANBJ@AEDJ@@H@@@@@HIBIFINMOOOOONIBI@@@BEBHBHGOOOOFBH@BEBE@@D@@B@HI@@HABKOGOOOONKNHEE@@HHHDHOOOOOOMENB@IEEDAADEB@B@BBBHJEOOOOONNKNJHIDHBBE@EOOOOOOONIDBDIDHDDH@J@H@@HHEBHOOOOOOJDGJED@@IEABKGOOONOONFB@BJJJ@@BMB@@@JBBIDEGOOOOOJIGKBBD@B@JBKOOOONAJOID@DJJD@EEEE@ABA@IDKEOOOLGOM@IMDIBIDNHHONAONL@AJNLAABIEE@BIF@H@JBBBDINMONOOJ@EOAD@@BI@BO@DMGMEKIEJ@AEED@EBEK@@BAAAEEGJGOIANHI@@HAEEDJEA@DBFJHBDCJH@DEEEEBJMN@BHJDJBFIMAOHKOE@BJEB@@IDH@E@ICMAEJJEH@ABIBBBJJO@@@AAAEEGJJBOEBJ@HDHHJDDJ@B@@D@ADI@@@@BDJJIEEEOO@IBJDE@JKJ@JJJM@HBBBDABJIDHDA@JDBEFHH@@AEBDHJJKO@@@AABJFMLJKFJJJBHHIBJ@AD@@@@H@IDID@@B@DJIBEBEFO@IEDDHBJKJ@@IDHDH@BBD@EDBIAA@A@@@B@A@@AAEDI@IEOO@D@BBEDEGI@JEIBI@A@HHAABH@@@@D@@B@J@@A@ABJJDHJKO@@BHHHIBOJDA@@@@@HDB@HDIED@@@H@@@D@@@@@JJI@@JIEE@E@DBE@IGI@DEEADBB@HDBBD@A@A@@@D@AB@@@BAEDJHJEEE@@BBA@EENJA@@@D@@@@B@@HIED@@@@@@E@@@@@@DJJ@DEDJ@@J@IBE@CGH@@DA@@@@DI@HBBD@HH@@@B@@@@@@@BJIE@IBAD@ID@H@AENJ@A@@@@@J@BDA@IBD@A@J@@@A@@@@@AEE@@DJMB@@@JEE@INHHH@@@B@@@HH@BDI@H@@@D@@@@@@@@DJJHBBEBE@DD@@BEGNJ@@BB@HAB@B@B@JDB@@@@@@B@@@@@@BIDDIJJJH@@@BEDHMNDA@@@H@H@DIA@JBI@@D@@@@@@@@H@@HJJB@EEED@@@@@BEGOAD@@D@@@I@BD@ADDDH@@@HBHB@@@@@BEE@EEFHB@@@IBI@ONJ@@H@AB@@AA@BJBIA@@@@@@@@@@@@@AEDI@JKFH@BD@BDOGNH@H@@@@@DHJ@H@IDD@@@@@@@@@@@@@DJJH@JOJ@@@@@HIAONJ@A@I@@@@D@H@BDJ@@@@@@BDB@@@@@AEMBDEJKD@EBJBFOOO@IB@@@@@DADB@HJMDID@B@@@@@@@@@EEE@@JOM@@D@@ICKONJ@@B@@HAA@B@DBAD@D@@@@@@@@A@@@BGJH@BKEA@KDJEEGOOHHHHD@@@@DHHA@KEE@@@H@A@@@@@@@IEFA@IFMD@E@@HJOGNJBB@@@I@@@D@HBELH@A@@D@@@@@@@@EFJH@BKFH@OEEBKIKOI@HB@@@@DBB@@@JOBHH@A@@@@@@@@AEKJHD@@I@@KDHIFMENJ@DDD@@@A@HDA@EJIB@@D@@@@@@@@@EMEB@@DJD@FJEGKBEGIEA@AB@HD@E@@BKOE@@D@@@@@H@@DIBGJID@@A@@MEBBMABNJ@DDH@B@@DH@@HEKEDB@@@@@@@@@@@EEJD@@@@@@JHIEEDIGMAA@@H@@DBE@DEFMEA@@@@@@@@B@@DIOKKD@HE@@MEBJJDBEJH@EA@@@@DHBA@KEED@@@@@@@@@BAAEJLJH@BB@@E@HDIBHKJBI@@@A@AABHDEKMBI@@@@@@@@@@@DEGEJD@HH@@JJEBDHBEJH@ID@@@DDJDABOEED@@@@@@@@@@BBJMEFH@DJ@@DABIBB@IFDJ@@@H@@BM@JEODBM@D@@@@@@@D@ACJJJHBJA@@JHIDI@IBJH@EBHBDADNJDKOE@H@@@H@@@@@@IDINJMDADJ@@MBDBDJ@AFEA@@@@@DBOJOOOMBN@@@@@@@DDB@BJKEE@BH@@@DIBHI@JHJHDDD@J@AEOEJKOLJJ@@@@@@B@@@AEEMBJLBHI@@NDIBDD@BFEA@H@@HD@OOOOOOEMD@@@@@@B@HDBKFJM@D@E@@K@DIABJAE@H@@@D@@JOMOOONKD@@@@D@@H@AADMNKFH@@J@@MDIBDH@JEEBA@A@@@EOOKONOMJ@@@A@@@@@DBBJKEJI@@J@@M@DIBBJAAD@HD@@@DBOOOOOOFI@@D@@@@@BBHJJMEEDD@K@@NJJDHH@JDED@@H@A@HBMMM@IED@@@DDAA@@@BEEFJJI@JMD@GBBHDBHABIBA@A@@@BKOFMMEJ@@HA@@@@@DHIACJMJD@BJJ@MDJEBHEDDDJJA@B@@@@@I@@H@HHA@AADDJ@EBELMFJH@JJM@OECBDE@AABJHHH@@A@DJDDEBD@DHB@@@@@EADJGGKJL@IEK@ODIDI@EDBIDD@@AA@@A@A@H@A@@@@DDDDA@DBADJEF@@@EF@ODDBDJABDEFID@DDB@H@@@@JHBDB@@A@@HBIDJKEOJL@@JM@MJJIBADHABJDBI@@H@@@I@J@E@I@E@DBBB@@BEEJIJ@@@EE@NJABIDBBDENI@@B@@@J@@@@J@DD@@A@@@HHDEBJMFJ@@@JJ@OMDDDADH@BJDJI@AA@@I@H@@JH@@HDBDDDA@@IEGKD@@CEM@JHHBB@H@BIFJA@DD@@H@B@ID@@J@D@@@BBHBEEBMLH@@BJJ@OFBIDJD@HBJHJDA@I@DJ@@DBJJ@B@HBBADA@BBKFJJIEOOE@OIDDIABB@DNJDBH@@@B@I@@HBDJ@@A@@D@@IADIKEAEECEM@OECODDI@BBEA@H@@IBIE@EDEJHA@E@@HBD@@JBKMJMOOONJ@MLKEBABD@AFJA@BH@@DDA@BJEADD@@DB@BEEAAEFJGOOOGG@OOONMDIAEDNID@@ABJOKFOMMMDB@@DA@EA@@DEBOEMMMMKH@OMGKEBDH@AGEBBD@@EJJJIEFJBIB@@@@@D@@EAEJJGMOOME@OOOOJMBBJIFJIDHDEGOOOOOOOLHHIBDHA@@A@JJNKOEEDKM@OOONOEE@H@NJJB@@EGOOOOMOMEE@@@@D@HD@EBEFKOMOKGE@OMKOJJHIBJGEAA@BAGOOOONOOEDHD@A@@@@@DIEMENMEFKJ@GOOKOMEBEAEDLH@HMOOOKOKOOOKE@HDABBABBEJKOKOMJJM@NOOOMFBDJJNJBDHACOOOOOOOOOLHHD@H@H@@IEEMEOMNIED@OOOOOMJAEMEEJIADOOOMEDKOOOOMA@@@D@BDDJNOOOGE@BJ@KOOOOOIDGENJIB@BGOOOMOFOOOOD@@A@BHD@BFKEOOOLABH@OOOOOONBAEKADHIEOONH@@ABOOOMD@@B@@@BEBMOGOMFDAB@MOOKOOJHJKFMEB@IOONJE@JGOOONHH@@JHA@DIGEONOM@B@@OOOOOOOMEEJIDIEGOOM@@D@HCOOMB@AB@BDBAEEOOOOD@AD@OMOOOONJJENJJD@GOONEB@BAGOOND@@@BI@@HIKOOOMJ@BH@OOOKOOOOMDBHAAA@OOMDHHHJKOOE@D@D@@@DEFMKOFNH@JD@OOOOOOONNIEEDHHIGOMDB@EEKOOH@@A@BEB@BEKOGOED@ED@GMOOOOOOJJDIBB@@EOOMIECKMDIDI@@@H@@EDJMGOJOD@JJ@OGOOOKMONHIBI@@ECOEED@KFOMN@@H@H@J@BAEGOOOJIBEB@OOOGOOOOOEBDDHD@IEOMGFMODJEDH@B@@@DDDFMOOEED@@H@KOOOOOOOOHDIEA@@ENJLJIFKGGDHB@@@D@AABJOKONLH@BE@ONOOOEOMONHDHHBDEEOEA@AEMHI@HB@E@IDDDKEOOKE@@H@@OOOKGOOOOJBIEA@@COEDJDHJMFDDA@I@B@A@BEOFONH@@A@@KGOOOOOOOOHDDHDBHEKM@@GGEA@@D@@@@BDEENKOOJJ@ADB@OOOOOKOOOMEBJEBHBFNJJHIMMD@I@D@AA@IBIEOGONHH@HA@MOOOKOOKOOJIEDH@DHKMEFNLBAB@B@BD@@BDFKGOOJH@EOJ@OGONOOOOOOLDJJBHBEBNJJOFID@@@H@@BDDBJMOOONH@BDH@OOMOOOOKOOKKFID@@@JKOMJID@IBB@AD@@BIGGOOMJHEBKG@KNOKOOMOOONEJJB@DJEMGGGD@@@@ADBB@A@EEOOOOJHHBOJ@OKOOOOGOGOJHFJH@@A@BI@HEDDIAD@@IEDKKOOOOOJBCJJM@NONOOKOKOOMEFJDABDJHFMBHH@@BA@DD@BDJJOOOKJ@@JMF@KOOOMOKOOOGBEEBH@BABH@@BBHJ@D@@BJDIOOOGONJ@NKEK@OGOGGMMOOONIGDI@JDD@@HHID@@H@DA@DBEEGOOOKJBBJJN@ONOOOGGOOOKJKODH@IABDB@D@BDBI@@JBIENMFNNOH@JJJK@MKOOMNOOOKOIFJJBI@D@@H@BD@@H@@DADDKGGOGONLBEEEJ@OOOOOKOKOONNOOJH@BADB@DH@HJ@J@ADBJNMOMOOOJAFJJO@OGKONOONOOOKKMEEBHD@HD@A@D@@@DDHICGOFONOGJEEEEJ@MNOOOMOKOOONNOJ@H@@D@@IDB@IBJBIFFMNKOOOMOHBJJEE@GKOOKONOOGNOKFMEB@HHEB@@@B@@A@DEEFKNJMKONMAEEEK@OOOOOKOOOMOMOONH@BB@H@@JI@E@DJKJMOOGOOOKOJBM@JE@OGOOOOOMNOOOMOJE@H@@@HD@@D@D@IAGGFJOKGOOGJELBEB@OOGONOOOOOOKOGOHJ@@@J@ADD@I@JDMNMOOJMOOMOJJED@J@OMOKKOGKKMOOKMNJ@@HH@@@@AB@DEBGGOMJMOGOGOJJMA@E@OOOOOMONOONKNOOJJ@@@D@DB@@JA@MKNONOKKNOOMOGDHAE@OGOOOONOOKOMKGOJDH@H@@A@BJ@HJMGOOOEMMGMMOMKE@@J@OOGONJOMOONKOOOMHAB@HHHA@@JEGGOOOKOGGOOOGOOE@EG@OMNOKOGOKJOMMGONE@@@B@@DBHEBBNMOONKOKONOOMKD@@J@OGOOOMOMOOOOOKOOJEBD@DH@@EAEOOOOOOOOMEOMOGGEBNM@OMKOOGOOOKGOJNONI@@HB@BIB@JKGOOONOOOGOGGGMME@BJ@OOOOOOONOOONOKOONJDAAD@BDJENOOOOOOOOJCOMNNFLKKO@OKOOOKGKONOOJMOOMA@HJ@I@HICMOOOOOOOMMJNNOKEE@ME@OOOOKOOOOONNKGOOOLJEADBJJMOOOOOOOOKNJBGEEMEEFOK@OOGOOKOMOKOOJIOOOEBHJA@DJJKOOOOOOOOJHIOJOFJJJMN@OOOOGOOKOOOJJOOOOOMOMMGOOOOOOOOOOEJJ@DFJIJJEGOE@OOOOKENOGOOOJEKOOMFNOEEFNOOMOOOOGOOJICGJJNJJMON@OOOOOOOOOOONMKOOOOOOOOOOOOOOOOOOOJJH@AGIGEKGGGG@OOOOOOONOOOGJJMOOOOOOOOOOOOOOOOOOMMBBEGJMNMJMOM@OOOOOOOOOOONOGGOOOOOOOOOOOOOOOOOOJJH@AGJGEEGOOG@OGOGOMOOONMOJMOJMOOOOOOOOOOOOOOONNJ@@EGJKNJJKGN@OOOOOGOOOOOKOFJOOOOOOOOOOOOOOOOOGJH@A@OJMEEKOMO@OOKKOOOKOONOKKONEOOOOOOOOOOOOOOMNH@H@EGJKNMFJOJ@OGOOOEOOOOGOOMGKEGOOOOOOOOOOOOOOFJH@@EGIFKFKOEO@OOOOMOOOOOOJMGNNJJOOOOOOOOOOOOOKJ@@@AAGOKMKMEOE@OONOOMOOOOOOGJONHMOOOOOOOOOOOOONMD@@@DOMMFJFNKO@OOOOOOOMOONJNOGFJBOOOOOOOOOOOOKJB@@@AAEOFMMKGOM@OGOKKGOOOMKMKKMM@DOOOOOOOOOOOOOJH@@D@AEOKKFMJMO@OOOOOOGOOOOGNMGNMACOOOOOOOOOONMDH@@@E@KNNNMEGKE@OKGOOMOKOGNMGKOK@DKOOOOOOOOOOOOJ@@@@@DKOGGGFJOO@OOOOOOONONOOMEENL@EOOOOOOOOOOMH@@HJ@BBEOMKJMOMK@OGOGOOMOOONKFIOKBABOGOOOOOOOENNH@B@@@AEOGMOGEGM@OOKOOOOMMKOOOEFNH@DKOOOOOOOOOD@@A@@A@DCOMFJJKOG@OOOOOGOOOONMFKOMJ@INOOOOOKOOMJJ@@H@D@@IMGKMMFOM@OOOOOOONOOKONIGGHH@COOOONOOEDD@B@@@@DBKGNNNKKOO@OOOOOOOOMKOJJMMNJBDJOOONONONK@D@AB@@@AEOOOEEGMO@OOOOOOOKOOOONKGOH@@ACOEKEEJDDEADD@@@@HENKEOMJOM@KOOOOMONOONNKEOOEBJJKMNNMMGE@HD@A@@@BABOMNJJKOO@OOOOOGKOOOOONOOOHH@@@JJI@@H@BAA@@@D@@@EEEEDKGKG@OKOOOOOOOOOKOEGKJAE@JJIDJ@BH@DDDIB@@@BDKKKEEKOO@MOOOOOOMOOOOEKONHHDBAADB@JHBI@A@@HB@@@EFHJJKFKO@OMONOGMOOMOMNMOOJBBHDDBID@E@@@DBB@@@@HEEJJIEKOG@NOOOOOONMOOOOGONJ@HAA@HDAD@JJJ@D@@@@@@EFH@BJMGO@OOOOOKOKOOOMMKGKIBBJDDDABAB@@@A@IAB@@AAEBHHJKMM@OGOKOOOOOOOKOKOOJHH@@@ID@DAEEE@@B@@@@@EDH@@BKGG@MNOOKOOOOOOONMOOHBBJI@BEB@JD@@DA@@@@@AEBHBADKOO@OOOOOOOOGOOKGKKNJHHHDDI@DHAAEB@HDH@@@DEFJH@@JKM@OKOFONOOOOOOOEOOJDJ@A@DI@@HH@@@@BBD@HABJH@@@JNO@OOOOOKOKOOOMNNMJHBAEDBHDBJBDHHB@D@@@@@DIEB@@AGM@OOOOOOOOOMMOOKOOJHDB@@E@H@A@B@@@@@@@@ABJI@@@BKG@OOOOOOGNOOOOJJEJDAADDE@DBJD@HB@IA@@@@@JDDJ@@@DM@OOOOOKOGMOONOKKK@HB@@@DI@A@H@@D@@@B@D@EEBH@HABJ@OOKOOOOMOOOKJLNHH@HIEABDJH@@HD@B@H@@@A@HID@@@@K@OKOOOOMOGOONOGEJA@B@@@I@@DBD@@@@@B@@B@BEDJ@B@@J@ONOOOOGKNMMKJIJA@@IEDHDEE@H@D@A@@@@@@@DHA@D@@D@@OGOONMOMOKOMGEFHDHD@B@BI@JADAA@AA@@@@A@EDF@@@@@@MKKOOOOGEONMMJH@@AAE@HHDD@@@H@@H@@@@@@BDA@HDB@@@ONOOKOMMOOOKFIBAA@B@E@EBHI@@@D@@@@@@@@IBDJ@A@@H@OGNMOOGOOKJMJD@@@@HI@DHI@@A@@@BBB@@@@B@A@DHH@@@@MKGOOKOOFOOFMB@@HH@DDH@D@@@DB@@@@A@@@@BDED@@@D@@OOJKFONKONMJB@DABAE@HBJ@I@I@H@@H@@@B@@@A@BI@@@H@NKMOKNOOOOOEH@A@@@@@A@@J@@@DAB@@B@@@@@@@BJ@A@@D@GOFMOKKOFJJH@@@IDDHDHDJ@JD@@D@D@@@DDB@IB@H@@@@@@OOMOOFOGOOMD@@E@@AA@@@@JA@DH@A@B@@@@@@@@EBDH@HH@NMGFKKMMFMDAA@@BJ@@@HIB@HB@@HHA@B@@@@@DJ@D@@@@@@GOKKMFOOKNJH@@I@@@@H@DADDH@H@@@H@@A@B@@@ABHA@@H@OFNOGKOEMA@@HDBAEBD@D@DBH@HDI@@@@@@@@@ABHD@@@@B@OOOKMMKKFJE@@@DH@@@DA@A@E@A@@@@DHB@@@@@@BAD@@@H@OMNOGGMJI@@BAA@AE@H@H@HJHDD@D@@@B@@@@@DI@HA@@B@@OGOOMJNMDHH@@DED@HDHDHE@BA@D@@@@H@@@@@@@DE@@@@@@OOOMFDA@BABIEA@A@B@D@@@DHH@HID@D@@@@@@@EA@B@@@@@OOOOJJJDD@@@@DJJAADAE@E@DAD@@@A@@H@@D@A@HJ@HB@@@NNOGMADI@IEBJB@@HD@H@D@DHD@HHH@@D@@@@@@BA@B@@D@@OOON@@@@@@@HAABDBADBI@BB@HDDB@@@@@@@@@@A@@H@I@@@OOOODDI@DEDBDHHA@@B@@@@HD@ABHBA@B@@@B@DDHH@H@@@@OOOLI@@DA@BHBBA@JEADJDJEAB@@@@@@@@@@@@@@@B@@BDB@OOOM@@I@H@@BI@DA@@H@H@A@D@JHA@@@@@@@@@@@HHHBA@@@OOOJBA@@BEE@DJ@HJJEEADHHID@@HBI@@D@B@@DB@B@H@E@@OOOL@D@@H@@JB@HB@D@HB@E@@BDJ@@@D@@A@@@A@A@@@DHD@OOOMEADHAAB@HIA@IADEDJ@JE@@@DHD@D@H@@@D@@B@A@BI@OOOMB@@@DD@HE@DI@HBHA@J@@@I@HAA@@@@@@A@A@@@@@AD@OONDHAE@@@DA@B@@BBHEDD@HJJ@J@D@@@@@@D@DH@@@@@@@@OOOBBD@@BA@@B@HBHHE@@@DDA@J@I@B@@@@@@HB@@@A@@JJ@OOLHI@JI@HEDHHA@AB@IBH@@DD@J@@@@@B@HH@H@DDD@@@A@OOMB@B@@DA@@BBDADDHDDDJBA@@@@@@H@@@@@B@@@@@@@AD@OOLHE@DHA@BA@H@DA@B@I@A@HDEAB@B@@@B@@@DAA@@@@@C@OONA@DBADB@@JBIA@@IB@IDJ@A@@@@H@@D@@@HBD@BD@@HH@OOMDEA@H@@D@@HB@JJB@HDA@JHBD@B@@@@@@B@D@@A@H@@B@OOO@HDJA@H@IDA@D@@HJBABB@DH@A@H@@DDA@@@@@HH@@DH@OOMDB@@HBAD@BHEAEB@@HHDIEABI@@@@@A@@DABD@@@B@@A@OONA@BDB@@BHDA@D@@DJABBDBD@@@@A@@H@@B@@@H@@@@HD@OOMDB@A@IB@BADJAEEB@DDIBH@JDB@@@@B@@@@@BBBD@B@@@ ) (RPAQQ MARILYNWINK #*(188 254)@B@@@@@DHDBA@HHJABJ@H@AD@@@@A@@@BH@@@@@B@@@@@@@@H@HBA@I@@BH@IA@@@@DDDJJ@@@A@D@@@@@B@@@@H@@@@@@@@@HA@HABAAAADD@JDJE@@@DIDH@@D@@@@@@DH@@B@@@@@@@@@B@@AA@H@@DHJBD@@@@DJJI@HBD@@@H@@@@B@@@@@@@A@@@I@@DH@DB@HEBE@HADIBD@@@BEA@@BA@@@@@@DH@@@@@@@@@@@@D@BB@HJ@@D@BBD@@DAEDDHHD@@@@BDB@@@B@@@@@@@@@@@@@A@HHJ@@ABIEDI@JHAD@@ABDHI@BD@@@@@AED@@@@@@@@@@@@H@B@ABJH@DHBDD@A@ABJHA@B@@@@DH@@@@AB@H@@@@AB@AB@@@HAD@@@JIBHHAE@DHD@BDE@@@BH@D@@@@DH@@@A@@@@@D@@@@@DBDHH@DABBH@A@@IE@@@HDI@@JH@@@@EB@@@@@@@@@AD@HDH@I@@ABADDHAE@@HB@@JJA@@@H@@@@@ABH@@@@@A@@@H@@@@AB@DDDADE@B@@HBBIDH@@H@ADB@H@B@HDH@@@AB@@H@D@@A@H@BAA@DA@JHBHA@@@@BJD@DHA@HBDH@AED@@@@@@@@@@D@@BBBA@@ABHJ@A@A@A@JH@AAD@@HDI@@@H@JH@@@@@H@@@@@@D@DHHDE@@DEEDJD@HD@DID@@HJB@@@@B@EFJ@@@@@@@@@@@@AB@@AA@DEABHH@@@@BJA@A@H@@HHD@B@@BFHH@@B@@D@@DB@@@JBDDD@@DHDAA@HB@ADDHD@JD@A@@@JAEMD@@@@@B@@@@@@@@A@A@A@EABI@D@@HID@@B@D@IBD@D@@@AFJ@@@@DH@@@@@@BA@BHBHA@DDDI@@@@@A@E@IAB@DH@@B@HKKDH@@D@@@@@@@@@@B@B@A@AABH@@HIADHHHHD@@IA@@@@B@EFJ@@H@IBD@@@@@I@HIAADHDDIAAB@@DBBBBAADHDD@D@@@BHM@H@@@@@AB@A@@@B@@DDBAAADHH@@@A@@@@H@@DHI@@D@H@EFJ@@@H@@@@@@@@@@BBAA@@DJB@AABBJB@HH@ADH@D@@@@@EBD@@@DADHB@@@@@DI@AD@JE@AEBDD@@@@@@DI@@@J@D@@B@@EED@@A@B@@H@@@@@@D@BJ@@EDHHA@HDJAADB@@JJ@J@@@@@B@J@@@DD@@B@@@@@BD@B@@D@@JD@@@A@@H@@HJJD@@@@A@@@AEED@@@@DB@B@@@@@@IABA@JDAB@H@@@@@B@B@@BBJ@@@ABBDBE@@ADD@H@H@@@@IB@@@DB@AD@@A@H@D@@DHJJID@@@@D@@@IDH@HAAB@@@@H@@@@EBI@H@IBIA@@@@@@BABD@JAA@@@AB@AEB@@@@@I@D@D@@@HB@@@@@@DH@@@@A@B@H@DAEADDA@E@@@DAD@B@A@@@@@@A@@B@IDEABAB@I@A@@@DBAEADBDB@@@@@@@@JHH@@@D@H@H@H@@@B@A@@@H@H@AD@HA@@@@DI@JHD@B@@@DJD@B@@AAD@@@@@@@I@@@DDI@HBDH@D@H@HB@JDEA@@A@@DA@ABH@B@@HB@B@@HD@@@BBB@@@E@A@D@@@@@@BA@@DA@@@J@@BJH@@@@JAADH@BA@@@@@@I@HB@@HAA@H@@@@HJED@@@@@@@BDEJ@DDI@IDH@B@@@@DB@JB@A@J@E@D@@@I@HB@@ADHHDDH@@INDB@@@BDJBA@@@@@@@BA@A@B@E@A@H@H@BB@IDD@B@@@@@ACE@@@@@DABH@@@D@@@@H@D@D@D@EDD@D@A@@DD@@J@B@@DHJOJJ@@@H@JJDJBI@D@D@@BA@HI@E@@AB@@@@@@@IB@IAED@@AEN@D@@@AAEDAB@@@@IBBADA@@E@JJD@@HDH@@J@AD@@@@IEGOOJ@@@@JJBJJHAD@@B@HDA@BI@BB@@A@@A@IBABD@DHJ@@BOONHH@@BABJDBDD@H@HBABJE@@EAEEEDDI@@@@@@AE@@@HKOOOFNJHA@DJIBIE@BA@DHD@A@JD@IDJ@@B@D@DHBD@@@HHBGOKNOEB@@@BIDHEE@@@@HBIEDD@AEDFIEEDIA@@@H@BD@@EDOMMBIGNJH@IFNKBJJIB@BJDBBBJDDBJDIBA@@@HH@H@HI@HBONJMEEKE@HACE@JJJD@@HAEDI@@AGOOJDIDDI@B@D@JBDECONMJB@KOOBCEEMNJEEEJ@AEDHDJJJEGNMBJB@@@H@IBA@A@KOOJJHEAOOHDJJJJJKJHI@DBNEB@HAGOOOOJME@@AB@HHJHKONJD@@@@AONIEGOOMNMGE@AAEDIBDJOOOONKBBD@H@DDJDEGOMJH@@@BMOJEBMOOGGEEE@@DOEDABAGONIGOOJADA@BBBKEFOB@@D@B@@AOEMOOOMMEDM@EAEJBHHIGOMFMONIDA@DHHIEEGODDHA@@@AENMGGOMOGEEE@@BKEIBDDOOB@COOMBJEABDJL@KLH@@D@@@@BONMMOFKMJD@@@ACFDIBIGNIEEGNJJA@HIBDMFGM@HB@@@@BEFKGGOOEFJJJ@BDKEJDIBOID@@KONMJEEDIB@IJJDBH@@@@@@INMOFIEJHIB@@BEJJIDIGJA@EGOOFIDBBDIE@ODA@DDD@@@BEOGMOMDKDJB@@IBKEBEBODDB@IGMOJCDJH@HJ@KJOMKB@@@AEEKGEEFLJEA@B@IGEEDIFH@@JEMONIDIDEDEBJJEBNLIB@@DEOGMOJIEDI@@@DEEE@JKNABDEOOOOMEBBHA@HDKNOKONHDDABFIGEEEEDDD@BABKEEEEOD@AEOOOOEDHHB@JEBBKFOOOD@AAEFMKNJBKDB@@@BDE@HICN@DKOOEEGJJ@EDDABIEIABEGND@@@JJMEJJDAAA@@HJJEBEINH@EGOOKMJIB@@@J@EFLLDGGGB@EFEBKNIEBHDD@B@@ABEDKN@EGOJ@DBODHJHBAEJ@@@@@IOHD@AEEJJD@HAB@@@BBJHHKENHBONMJAEEE@@A@HJEEAAEA@FI@EEBJKEFJD@HH@A@A@EBFINEEOOOOJABMEDDDEAH@HDL@EAME@@HDHJH@A@D@@@@HJHIEENHKOOONIDJM@AAA@JMDEB@NHDJHDABJJEEBHD@@@BBD@DDJKNKOOOOOOJDBEDD@JDBAB@@ABICF@J@AEDJ@@H@@@@@HIBIFINMOOOOONIBI@@@BEBHB@KDDI@BLI@BEBE@@D@@B@HI@@HABKOGOOOONKNHEE@@HHHDID@A@@JHKDJ@IEEDAADEB@B@BBBHJEOOOOONNKNJHIDHBBE@D@DDDE@EBKEBDIDHDDH@J@H@@HHEBHOOOOOOJDGJED@@IEABAD@@@@A@OED@BJJJ@@BMB@@@JBBIDEGOOOOOJIGKBBD@B@JBHAAAAA@CGNH@DJJD@EEEE@ABA@IDKEOOOLGOM@IMDIBIDNHH@D@@@@@MOE@AABIEE@BIF@H@JBBBDINMONOOJ@EOAD@@BI@BK@DDDDDGOJJ@AEED@EBEK@@BAAAEEGJGOIANHI@@HAEEDJEB@DA@B@CODFBBDEEEEBJMN@BHJDJBFIMAOHKOE@BJEB@@IDHEE@HBIAENK@@@ABIBBBJJO@@@AAAEEGJJBOEBJ@HDHHJDDJ@BLHBDDDON@@@BDJJIEEEOO@IBJDE@JKJ@JJJM@HBBBDABJIDKGDHJJIGJHB@@AEBDHJJKO@@@AABJFMLJKFJJJBHHIBJ@AD@BOBBECGOLB@B@DJIBEBEFO@IEDDHBJKJ@@IDHDH@BBD@EDBIAAMLMKGOH@@@AAEDI@IEOO@D@BBEDEGI@JEIBI@A@HHAABH@@GGONNON@H@A@ABJJDHJKO@@BHHHIBOJDA@@@@@HDB@HDIED@IKKKKOLJ@@@@JJI@@JIEE@E@DBE@IGI@DEEADBB@HDBBD@A@DFOKOO@D@@@BAEDJHJEEE@@BBA@EENJA@@@D@@@@B@@HIED@AEGMMD@A@@@@DJJ@DEDJ@@J@IBE@CGH@@DA@@@@DI@HBBD@HHBJMBLA@@@@@BJIE@IBAD@ID@H@AENJ@A@@@@@J@BDA@IBD@AAB@@@@@@@@@AEE@@DJMB@@@JEE@INHHH@@@B@@@HH@BDI@H@@@D@@@@@@@@DJJHBBEBE@DD@@BEGNJ@@BB@HAB@B@B@JDB@@@@@@B@@@@@@BIDDIJJJH@@@BEDHMNDA@@@H@H@DIA@JBI@@D@@@@@@@@H@@HJJB@EEED@@@@@BEGOAD@@D@@@I@BD@ADDDH@@@HBHB@@@@@BEE@EEFHB@@@IBI@ONJ@@H@AB@@AA@BJBIA@@@@@@@@@@@@@AEDI@JKFH@BD@BDOGNH@H@@@@@DHJ@H@IDD@@@@@@@@@@@@@DJJH@JOJ@@@@@HIAONJ@A@I@@@@D@H@BDJ@@@@@@BDB@@@@@AEMBDEJKD@EBJBFOOO@IB@@@@@DADB@HJMDID@B@@@@@@@@@EEE@@JOM@@D@@ICKONJ@@B@@HAA@B@DBAD@D@@@@@@@@A@@@BGJH@BKEA@KDJEEGOOHHHHD@@@@DHHA@KEE@@@H@A@@@@@@@IEFA@IFMD@E@@HJOGNJBB@@@I@@@D@HBELH@A@@D@@@@@@@@EFJH@BKFH@OEEBKIKOI@HB@@@@DBB@@@JOBHH@A@@@@@@@@AEKJHD@@I@@KDHIFMENJ@DDD@@@A@HDA@EJIB@@D@@@@@@@@@EMEB@@DJD@FJEGKBEGIEA@AB@HD@E@@BKOE@@D@@@@@H@@DIBGJID@@A@@MEBBMABNJ@DDH@B@@DH@@HEKEDB@@@@@@@@@@@EEJD@@@@@@JHIEEDIGMAA@@H@@DBE@DEFMEA@@@@@@@@B@@DIOKKD@HE@@MEBJJDBEJH@EA@@@@DHBA@KEED@@@@@@@@@BAAEJLJH@BB@@E@HDIBHKJBI@@@A@AABHDEKMBI@@@@@@@@@@@DEGEJD@HH@@JJEBDHBEJH@ID@@@DDJDABOEED@@@@@@@@@@BBJMEFH@DJ@@DABIBB@IFDJ@@@H@@BM@JEODBM@D@@@@@@@D@ACJJJHBJA@@JHIDI@IBJH@EBHBDADNJDKOE@H@@@H@@@@@@IDINJMDADJ@@MBDBDJ@AFEA@@@@@DBOJOOOMBN@@@@@@@DDB@BJKEE@BH@@@DIBHI@JHJHDDD@J@AEOEJKOLJJ@@@@@@B@@@AEEMBJLBHI@@NDIBDD@BFEA@H@@HD@OOOOOOEMD@@@@@@B@HDBKFJM@D@E@@K@DIABJAE@H@@@D@@JOMOOONKD@@@@D@@H@AADMNKFH@@J@@MDIBDH@JEEBA@A@@@EOOKONOMJ@@@A@@@@@DBBJKEJI@@J@@M@DIBBJAAD@HD@@@DBOOOOOOFI@@D@@@@@BBHJJMEEDD@K@@NJJDHH@JDED@@H@A@HBMMM@IED@@@DDAA@@@BEEFJJI@JMD@GBBHDBHABIBA@A@@@BKOFMMEJ@@HA@@@@@DHIACJMJD@BJJ@MDJEBHEDDDJJA@B@@@@@I@@H@HHA@AADDJ@EBELMFJH@JJM@OECBDE@AABJHHH@@A@DJDDEBD@DHB@@@@@EADJGGKJL@IEK@ODIDI@EDBIDD@@AA@@A@A@H@A@@@@DDDDA@DBADJEF@@@EF@ODDBDJABDEFID@DDB@H@@@@JHBDB@@A@@HBIDJKEOJL@@JM@MJJIBADHABJDBI@@H@@@I@J@E@I@E@DBBB@@BEEJIJ@@@EE@NJABIDBBDENI@@B@@@J@@@@J@DD@@A@@@HHDEBJMFJ@@@JJ@OMDDDADH@BJDJI@AA@@I@H@@JH@@HDBDDDA@@IEGKD@@CEM@JHHBB@H@BIFJA@DD@@H@B@ID@@J@D@@@BBHBEEBMLH@@BJJ@OFBIDJD@HBJHJDA@I@DJ@@DBJJ@B@HBBADA@BBKFJJIEOOE@OIDDIABB@DNJDBH@@@B@I@@HBDJ@@A@@D@@IADIKEAEECEM@OECODDI@BBEA@H@@IBIE@EDEJHA@E@@HBD@@JBKMJMOOONJ@MLKEBABD@AFJA@BH@@DDA@BJEADD@@DB@BEEAAEFJGOOOGG@OOONMDIAEDNID@@ABJOKFOMMMDB@@DA@EA@@DEBOEMMMMKH@OMGKEBDH@AGEBBD@@EJJJIEFJBIB@@@@@D@@EAEJJGMOOME@OOOOJMBBJIFJIDHDEGOOOOOOOLHHIBDHA@@A@JJNKOEEDKM@OOONOEE@H@NJJB@@EGOOOOMOMEE@@@@D@HD@EBEFKOMOKGE@OMKOJJHIBJGEAA@BAGOOOONOOEDHD@A@@@@@DIEMENMEFKJ@GOOKOMEBEAEDLH@HMOOOKOKOOOKE@HDABBABBEJKOKOMJJM@NOOOMFBDJJNJBDHACOOOOOOOOOLHHD@H@H@@IEEMEOMNIED@OOOOOMJAEMEEJIADOOOMEDKOOOOMA@@@D@BDDJNOOOGE@BJ@KOOOOOIDGENJIB@BGOOOMOFOOOOD@@A@BHD@BFKEOOOLABH@OOOOOONBAEKADHIEOONH@@ABOOOMD@@B@@@BEBMOGOMFDAB@MOOKOOJHJKFMEB@IOONJE@JGOOONHH@@JHA@DIGEONOM@B@@OOOOOOOMEEJIDIEGOOM@@D@HCOOMB@AB@BDBAEEOOOOD@AD@OMOOOONJJENJJD@GOONEB@BAGOOND@@@BI@@HIKOOOMJ@BH@OOOKOOOOMDBHAAA@OOMDHHHJKOOE@D@D@@@DEFMKOFNH@JD@OOOOOOONNIEEDHHIGOMDB@EEKOOH@@A@BEB@BEKOGOED@ED@GMOOOOOOJJDIBB@@EOOMIECKMDIDI@@@H@@EDJMGOJOD@JJ@OGOOOKMONHIBI@@ECOEED@KFOMN@@H@H@J@BAEGOOOJIBEB@OOOGOOOOOEBDDHD@IEOMGFMODJEDH@B@@@DDDFMOOEED@@H@KOOOOOOOOHDIEA@@ENJLJIFKGGDHB@@@D@AABJOKONLH@BE@ONOOOEOMONHDHHBDEEOEA@AEMHI@HB@E@IDDDKEOOKE@@H@@OOOKGOOOOJBIEA@@COEDJDHJMFDDA@I@B@A@BEOFONH@@A@@KGOOOOOOOOHDDHDBHEKM@@GGEA@@D@@@@BDEENKOOJJ@ADB@OOOOOKOOOMEBJEBHBFNJJHIMMD@I@D@AA@IBIEOGONHH@HA@MOOOKOOKOOJIEDH@DHKMEFNLBAB@B@BD@@BDFKGOOJH@EOJ@OGONOOOOOOLDJJBHBEBNJJOFID@@@H@@BDDBJMOOONH@BDH@OOMOOOOKOOKKFID@@@JKOMJID@IBB@AD@@BIGGOOMJHEBKG@KNOKOOMOOONEJJB@DJEMGGGD@@@@ADBB@A@EEOOOOJHHBOJ@OKOOOOGOGOJHFJH@@A@BI@HEDDIAD@@IEDKKOOOOOJBCJJM@NONOOKOKOOMEFJDABDJHFMBHH@@BA@DD@BDJJOOOKJ@@JMF@KOOOMOKOOOGBEEBH@BABH@@BBHJ@D@@BJDIOOOGONJ@NKEK@OGOGGMMOOONIGDI@JDD@@HHID@@H@DA@DBEEGOOOKJBBJJN@ONOOOGGOOOKJKODH@IABDB@D@BDBI@@JBIENMFNNOH@JJJK@MKOOMNOOOKOIFJJBI@D@@H@BD@@H@@DADDKGGOGONLBEEEJ@OOOOOKOKOONNOOJH@BADB@DH@HJ@J@ADBJNMOMOOOJAFJJO@OGKONOONOOOKKMEEBHD@HD@A@D@@@DDHICGOFONOGJEEEEJ@MNOOOMOKOOONNOJ@H@@D@@IDB@IBJBIFFMNKOOOMOHBJJEE@GKOOKONOOGNOKFMEB@HHEB@@@B@@A@DEEFKNJMKONMAEEEK@OOOOOKOOOMOMOONH@BB@H@@JI@E@DJKJMOOGOOOKOJBM@JE@OGOOOOOMNOOOMOJE@H@@@HD@@D@D@IAGGFJOKGOOGJELBEB@OOGONOOOOOOKOGOHJ@@@J@ADD@I@JDMNMOOJMOOMOJJED@J@OMOKKOGKKMOOKMNJ@@HH@@@@AB@DEBGGOMJMOGOGOJJMA@E@OOOOOMONOONKNOOJJ@@@D@DB@@JA@MKNONOKKNOOMOGDHAE@OGOOOONOOKOMKGOJDH@H@@A@BJ@HJMGOOOEMMGMMOMKE@@J@OOGONJOMOONKOOOMHAB@HHHA@@JEGGOOOKOGGOOOGOOE@EG@OMNOKOGOKJOMMGONE@@@B@@DBHEBBNMOONKOKONOOMKD@@J@OGOOOMOMOOOOOKOOJEBD@DH@@EAEOOOOOOOOMEOMOGGEBNM@OMKOOGOOOKGOJNONI@@HB@BIB@JKGOOONOOOGOGGGMME@BJ@OOOOOOONOOONOKOONJDAAD@BDJENOOOOOOOOJCOMNNFLKKO@OKOOOKGKONOOJMOOMA@HJ@I@HICMOOOOOOOMMJNNOKEE@ME@OOOOKOOOOONNKGOOOLJEADBJJMOOOOOOOOKNJBGEEMEEFOK@OOGOOKOMOKOOJIOOOEBHJA@DJJKOOOOOOOOJHIOJOFJJJMN@OOOOGOOKOOOJJOOOOOMOMMGOOOOOOOOOOEJJ@DFJIJJEGOE@OOOOKENOGOOOJEKOOMFNOEEFNOOMOOOOGOOJICGJJNJJMON@OOOOOOOOOOONMKOOOOOOOOOOOOOOOOOOOJJH@AGIGEKGGGG@OOOOOOONOOOGJJMOOOOOOOOOOOOOOOOOOMMBBEGJMNMJMOM@OOOOOOOOOOONOGGOOOOOOOOOOOOOOOOOOJJH@AGJGEEGOOG@OGOGOMOOONMOJMOJMOOOOOOOOOOOOOOONNJ@@EGJKNJJKGN@OOOOOGOOOOOKOFJOOOOOOOOOOOOOOOOOGJH@A@OJMEEKOMO@OOKKOOOKOONOKKONEOOOOOOOOOOOOOOMNH@H@EGJKNMFJOJ@OGOOOEOOOOGOOMGKEGOOOOOOOOOOOOOOFJH@@EGIFKFKOEO@OOOOMOOOOOOJMGNNJJOOOOOOOOOOOOOKJ@@@AAGOKMKMEOE@OONOOMOOOOOOGJONHMOOOOOOOOOOOOONMD@@@DOMMFJFNKO@OOOOOOOMOONJNOGFJBOOOOOOOOOOOOKJB@@@AAEOFMMKGOM@OGOKKGOOOMKMKKMM@DOOOOOOOOOOOOOJH@@D@AEOKKFMJMO@OOOOOOGOOOOGNMGNMACOOOOOOOOOONMDH@@@E@KNNNMEGKE@OKGOOMOKOGNMGKOK@DKOOOOOOOOOOOOJ@@@@@DKOGGGFJOO@OOOOOOONONOOMEENL@EOOOOOOOOOOMH@@HJ@BBEOMKJMOMK@OGOGOOMOOONKFIOKBABOGOOOOOOOENNH@B@@@AEOGMOGEGM@OOKOOOOMMKOOOEFNH@DKOOOOOOOOOD@@A@@A@DCOMFJJKOG@OOOOOGOOOONMFKOMJ@INOOOOOKOOMJJ@@H@D@@IMGKMMFOM@OOOOOOONOOKONIGGHH@COOOONOOEDD@B@@@@DBKGNNNKKOO@OOOOOOOOMKOJJMMNJBDJOOONONONK@D@AB@@@AEOOOEEGMO@OOOOOOOKOOOONKGOH@@ACOEKEEJDDEADD@@@@HENKEOMJOM@KOOOOMONOONNKEOOEBJJKMNNMMGE@HD@A@@@BABOMNJJKOO@OOOOOGKOOOOONOOOHH@@@JJI@@H@BAA@@@D@@@EEEEDKGKG@OKOOOOOOOOOKOEGKJAE@JJIDJ@BH@DDDIB@@@BDKKKEEKOO@MOOOOOOMOOOOEKONHHDBAADB@JHBI@A@@HB@@@EFHJJKFKO@OMONOGMOOMOMNMOOJBBHDDBID@E@@@DBB@@@@HEEJJIEKOG@NOOOOOONMOOOOGONJ@HAA@HDAD@JJJ@D@@@@@@EFH@BJMGO@OOOOOKOKOOOMMKGKIBBJDDDABAB@@@A@IAB@@AAEBHHJKMM@OGOKOOOOOOOKOKOOJHH@@@ID@DAEEE@@B@@@@@EDH@@BKGG@MNOOKOOOOOOONMOOHBBJI@BEB@JD@@DA@@@@@AEBHBADKOO@OOOOOOOOGOOKGKKNJHHHDDI@DHAAEB@HDH@@@DEFJH@@JKM@OKOFONOOOOOOOEOOJDJ@A@DI@@HH@@@@BBD@HABJH@@@JNO@OOOOOKOKOOOMNNMJHBAEDBHDBJBDHHB@D@@@@@DIEB@@AGM@OOOOOOOOOMMOOKOOJHDB@@E@H@A@B@@@@@@@@ABJI@@@BKG@OOOOOOGNOOOOJJEJDAADDE@DBJD@HB@IA@@@@@JDDJ@@@DM@OOOOOKOGMOONOKKK@HB@@@DI@A@H@@D@@@B@D@EEBH@HABJ@OOKOOOOMOOOKJLNHH@HIEABDJH@@HD@B@H@@@A@HID@@@@K@OKOOOOMOGOONOGEJA@B@@@I@@DBD@@@@@B@@B@BEDJ@B@@J@ONOOOOGKNMMKJIJA@@IEDHDEE@H@D@A@@@@@@@DHA@D@@D@@OGOONMOMOKOMGEFHDHD@B@BI@JADAA@AA@@@@A@EDF@@@@@@MKKOOOOGEONMMJH@@AAE@HHDD@@@H@@H@@@@@@BDA@HDB@@@ONOOKOMMOOOKFIBAA@B@E@EBHI@@@D@@@@@@@@IBDJ@A@@H@OGNMOOGOOKJMJD@@@@HI@DHI@@A@@@BBB@@@@B@A@DHH@@@@MKGOOKOOFOOFMB@@HH@DDH@D@@@DB@@@@A@@@@BDED@@@D@@OOJKFONKONMJB@DABAE@HBJ@I@I@H@@H@@@B@@@A@BI@@@H@NKMOKNOOOOOEH@A@@@@@A@@J@@@DAB@@B@@@@@@@BJ@A@@D@GOFMOKKOFJJH@@@IDDHDHDJ@JD@@D@D@@@DDB@IB@H@@@@@@OOMOOFOGOOMD@@E@@AA@@@@JA@DH@A@B@@@@@@@@EBDH@HH@NMGFKKMMFMDAA@@BJ@@@HIB@HB@@HHA@B@@@@@DJ@D@@@@@@GOKKMFOOKNJH@@I@@@@H@DADDH@H@@@H@@A@B@@@ABHA@@H@OFNOGKOEMA@@HDBAEBD@D@DBH@HDI@@@@@@@@@ABHD@@@@B@OOOKMMKKFJE@@@DH@@@DA@A@E@A@@@@DHB@@@@@@BAD@@@H@OMNOGGMJI@@BAA@AE@H@H@HJHDD@D@@@B@@@@@DI@HA@@B@@OGOOMJNMDHH@@DED@HDHDHE@BA@D@@@@H@@@@@@@DE@@@@@@OOOMFDA@BABIEA@A@B@D@@@DHH@HID@D@@@@@@@EA@B@@@@@OOOOJJJDD@@@@DJJAADAE@E@DAD@@@A@@H@@D@A@HJ@HB@@@NNOGMADI@IEBJB@@HD@H@D@DHD@HHH@@D@@@@@@BA@B@@D@@OOON@@@@@@@HAABDBADBI@BB@HDDB@@@@@@@@@@A@@H@I@@@OOOODDI@DEDBDHHA@@B@@@@HD@ABHBA@B@@@B@DDHH@H@@@@OOOLI@@DA@BHBBA@JEADJDJEAB@@@@@@@@@@@@@@@B@@BDB@OOOM@@I@H@@BI@DA@@H@H@A@D@JHA@@@@@@@@@@@HHHBA@@@OOOJBA@@BEE@DJ@HJJEEADHHID@@HBI@@D@B@@DB@B@H@E@@OOOL@D@@H@@JB@HB@D@HB@E@@BDJ@@@D@@A@@@A@A@@@DHD@OOOMEADHAAB@HIA@IADEDJ@JE@@@DHD@D@H@@@D@@B@A@BI@OOOMB@@@DD@HE@DI@HBHA@J@@@I@HAA@@@@@@A@A@@@@@AD@OONDHAE@@@DA@B@@BBHEDD@HJJ@J@D@@@@@@D@DH@@@@@@@@OOOBBD@@BA@@B@HBHHE@@@DDA@J@I@B@@@@@@HB@@@A@@JJ@OOLHI@JI@HEDHHA@AB@IBH@@DD@J@@@@@B@HH@H@DDD@@@A@OOMB@B@@DA@@BBDADDHDDDJBA@@@@@@H@@@@@B@@@@@@@AD@OOLHE@DHA@BA@H@DA@B@I@A@HDEAB@B@@@B@@@DAA@@@@@C@OONA@DBADB@@JBIA@@IB@IDJ@A@@@@H@@D@@@HBD@BD@@HH@OOMDEA@H@@D@@HB@JJB@HDA@JHBD@B@@@@@@B@D@@A@H@@B@OOO@HDJA@H@IDA@D@@HJBABB@DH@A@H@@DDA@@@@@HH@@DH@OOMDB@@HBAD@BHEAEB@@HHDIEABI@@@@@A@@DABD@@@B@@A@OONA@BDB@@BHDA@D@@DJABBDBD@@@@A@@H@@B@@@H@@@@HD@OOMDB@A@IB@BADJAEEB@DDIBH@JDB@@@@B@@@@@BBBD@B@@@ ) (RPAQQ EINSTEIN #*(189 252)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOKFOGOOOMONMMEMOEBE@JOOOOOOOOONOOOOOOOOOOHONKEEEFOKJMEMGOGKNMFBBHD@B@EDJOOOOGMKMEEEFMEEEEHOOOOOOOEFOKOGKENNKMJJMDAB@AFKEEOOOOGNOOOOOOOOOOHOKKMEJJOKEFKMMOKOFJD@@@H@HHBH@OOEGONOKKFJKEKFJM@ONNOOOKEFNMNOOFOEMD@D@@@H@@D@DBJHMGOMNOMOOOGMOGHOKMJJJMMKEJOGJMJMBAB@B@B@@@@A@@D@EMOOGMGKMKMGKMHMOKOOOFJMNOEOOFOJID@@@@@BD@@@@I@@IONMOGMNONOMNNHONNMEEKGFJIOFJKEEE@DD@I@@@@@@H@@@AEOOKNNKKGJNKKHMKOGMNMIEEFEOMMMJHA@@D@BDB@@@@@@@AJOOOOKNONOKNMHOOMMFKOMGOMOFOGGFLHEB@@H@H@B@B@@@@@GOOOOGJONOGO@OONOKMEEEEEGOKMMJHBDD@D@B@@@A@@@@A@MOOKKMGKGKJKHOOGMMGKJOFOMFOKGMFHB@H@@@@@@@@@@@@BGOONOGMOMMOMHOKMFKEMFMKEGONM@EABIDBHA@@@@@@@@@@@AOOOONOJOGEG@KOGGFNKKFMOOEKBJID@D@@@H@@@D@@@@@@@@@OOOOKOJMOOHONMKKKFJMFKMNMI@EBEAED@@@@@@@@@@@@@@IOOONNNOOEEHOONNNMJMFMNOKEDIEABE@@HAB@@@@@A@@@@@@KOOOOOJJOO@OKOMKFOEKFOJIDIBEL@@ED@D@@@@HHHB@@@@BEKOOMJOMJKHGOFNMKJJMKJJJJDDJDE@@@I@A@@@@@@@@@@@@@AOOOOJOONHOOOKKJMGFMKEDIEBEH@AEB@@HB@D@BAA@@@@@@JOONNOKFKHOMJNNOFJKFMJJE@EBD@@@@DB@@@@@@@D@@@@@@@OOOOKOKO@OOOKEJMEJOFMEDJID@@DHH@@A@B@I@B@@@@@@@@AGOMNMOFHONKMOKMBKJJJAGOG@@HED@I@D@@@@@H@@@@@@@@@JOOGGKMHKONNJNJIEGMIBKEMM@@DEB@B@@@@@@@D@@@D@AA@COOMNNOHOJOKOELDKMBDJOOG@@DIDH@H@I@@@I@@@@@@B@@@AEOGGOK@OOJNMNJJMFIBOOOMJI@EEGD@D@@@@@BB@@@@@@@@@BOMMFNHEKOMKEJFOJHKGOOMJJ@BJI@A@@@@@@H@@@@@@@@@@AOGOKO@ONOGGNJKFMEEOOMFJDIBJJJDAB@DH@@H@@@@@@@@@@OOEOMHFMMMMEDGOJJGOOOOJJDJJLI@@@@@@DD@@@@@@@@@@AEOOFNHOOOFKHKKFJGOOOOMMAFJMBBE@EDHB@ADDHHB@@@@@@COMOOHKJKMEEFOMMKOOOEFKMEEGLEEFHAA@EDA@@@HA@@@@BEOOOKHNNMFNJGMGDOOOOOKMEEEEDIBI@DD@H@H@D@@@@@@@@AGOOO@GKGKEKNOMFOOOMDDKFMEEDJIDJ@BDBIE@HB@@@@@@@AMONOHOMMMEGOJJOOOOKAEEEGKOJHBFJIDH@DDH@@@H@@@@BDGOOJHMNKEJKMMEOOONMEBJJMNOFJIAEDIBABE@@@DB@@HB@@KOKOHGKMMEGONKOOOOMDIEBGEOKDDEDJDHDDJI@@A@@D@@@@GONOHOMFMEONJDOONJKBBJBOOEMEBDJABH@BE@J@@B@@@@@ACOOO@MOKDKOGICOOMMMHJHJMJNKHEBIDIBBH@D@@@@@@@@@@KOGOHOEELCOMFOOOGFODA@EOOKFJHHLBDHHBJA@@H@@@@@@HBONNHEMMEENNJOOOMKEDD@JJMEMEBAFHI@@I@DAB@@@A@@@AEOOOHOFKHKOEGOOEFOO@I@BOOOFJHIBDBE@@B@@@@@@@@@@@OOOOHKKMFGNNOEEMEOIBH@JOGEJJHDJBH@BA@@@@@@@@B@@AKOOMHNNKIOOKDHMBKKFMD@GGOOFLEBI@A@H@@@@@@@@@@@@@OOOOHOKFJONMKBEEFOME@@KOMEJK@IDDDB@D@@@@@@@@H@@AMOGMHEMNKOOMDDHBKNOMDBFJOOEIDNH@@@@@@@@@@B@@@H@@GOOOHOFJKONJBHBJOKKE@AEOOEFJJB@@B@@@@@@@@@@@@@@ABOONHJMMGOOEDA@BGMOMHBKOGNMEEDH@H@@@@@@@@@@@@@@@KOOOHMNJOOMHBHBEDFMM@EGGOEEJJHBB@HA@@@@@@@@@@@@HKOOGHGJJGONDH@D@JKOJ@BKOOOJJHBI@B@@@@@@@@@HH@@B@EKMNHNMEOODH@J@DAGGDKBNOMEFJE@J@@@@@@@@@@@@@@@@@@OOOHKMCONL@@@D@JOOI@IGOONME@JH@@@@@@@@@@@B@@@@@BBOOHGDJOMJH@EAEEKODJEJKJKFIFJE@@@B@D@@@@@@@@@DB@KOO@MJGOJH@EBJEOOMK@JNOOMJMJM@BH@H@@IB@@@@@@@@@@COMHFMONND@BMEJJMODDEEOFJIEFEJ@A@@@@@@JJI@@@@@HHHKO@KJGOJIABFMGGGGI@JNOOEDJME@HD@@@@@DDHD@@@@@@@AOMHNKONJDDIKEJOOMDJBEMMJMMEDJ@@@@@@@@@EEE@@@@@@@OG@KJOOJ@BFOFOKGFMEAFOFKFFIJ@A@@@@@@@@@@@I@@@@@HKOHNKONIBIJJMEOOMEDEEEOGJJ@KGEE@@@@@@@@@@@@@@@@@KNHMGOOLHEMMEFMMGJHBJOJMEMEDIEBDH@@@@@@@DD@D@HD@KO@FKONBACEBJKKGMEDEDKKNMEAGFHH@@@@@@@@B@@A@@@@@BOHOOOMIDNHHJOOMEBH@KNNKEEEIEB@@@@@@@@@@@@@@@@@HKO@EGOL@CBJBKFKFME@EEGGNMBMBHAB@@@@@@BI@@@@@@@@@EMHNOONJILHDEOOKJJ@@KEKKJHJIED@@@@@@@@@@@@@@D@DDKOHKOOHDNHBCOEEFLMBJKGFNMGDJDHJ@@@H@@@IB@@@@@D@@BMHJONJBDBAFJOOOEB@AFNOOEI@EBB@@@@@@@@@@JAB@@@@@BOHKONIEBEFOOEGOEHEDGMGEMFJHHIDH@@@@@@@@ADA@@@DIJA@MONHAHBBOJMNMEDDBEOONKJ@E@E@@@@B@@@@@DEDD@H@@EKHGOLJDEEOOGGGOJIADEJOGLMK@BJNH@@@@@@@@@@@B@@@ANEHKOKABKOOMJMNMMBJHDOEJKBHMFAABH@@@@@@@@@@@@ABDIE@OOJJMJMOFOOEOFIA@KEKGJJIEI@@@@BAB@@@@@@@@JD@BGOHGOJIEMOMMEMOGKDE@DNMMJJEFJB@@@@D@@@@@@@@@D@@ABJHMNJEGKKGKKGEMMEBHJGFGFJHK@@@@@@@@@@H@@@@@@@BDKOHKNICNOKNJNMOOGJHBBOJKKEAMDD@@@@@@@@@HB@D@@@H@KOHONJOGEGKGENJKOFM@EEMNMHJNA@B@A@@@@@D@@EB@@D@@@JHKNHGNNKMJNKONKK@@BOEGJMEE@@HDHD@@@A@H@@D@@@@DCGHGNEOOENMGEMKKOMMBEAMGOBIJEE@ID@@@@@@B@@BL@@@@@KHOMEMMEGKJOGONOOB@BMGNJMJHINOGFH@@@@H@@@@@@HB@HBHOLIOMGNMGKOOKOJIAEFMGMFKBNOEMJB@@@@@A@@@@J@@@AAHOMEOMKOMJMFOOOKDDBENONKEAEONONH@@@@@D@@@@@A@@@EHOJCOEGMFMOONOOMBAJNKOJMDIONOJKD@@@@@@@@@@DD@@BAHOIGGKONKGGMOOOEIBEMMGMEBEGOOONID@@@H@@@@@A@@@@@HOLKNEKEEJMOOOONDBKFKNOJMENOKOKDJ@@@@@@@@@@@@@@DHOIGNKOMJMNOOKOJJEEJNOJKDJKKNOME@@@@@@@@@@@HB@@@HGDKFOFJKGGNOOOMIBKGGFOEJJNFJJOBN@@@@@@AD@@@@@@E@OKOOGONKMMONOMFLJMEEMMKFHEEKAEIJI@@@@@@A@@@@@BAHOJNOOOKOOOOOKOKJJJJKGNOKEEENMNNJ@@@@@@@J@@DD@H@HGKOFMONOOMOMNMGDKJJKNOGMHJKKJEIMB@@@H@@HD@@@@@A@OKGOONKOOGMOOOMKFKEEGMOFDEGOOOGNH@@B@IBNH@@@@@@HGONOOOOOKOOOONOGMJJJOOOOCGOOOOOKC@@@@@IGFIB@@@@HOOOGOOOLOOOONOKONMJKONMEDMMFOOEODJBH@EFMN@@@@@@HOOMMKOOOGOOOOKNMKFJJOOONJKKKGOKOE@@@@@KOEE@@@@@@GONOOOOIBOOGMOKGOJJOGKFKENJDINMGJ@@HAEDJMB@H@@@@OOONOMOMEGONOOONKEEEOOONJKIBDKIOKDDBDEKOFMD@@@@@OOOGOKOOJKKOOOMGFMBNOEONFMOOOODMNH@IAEOOKM@@@@@@GOMOKOOMJNOKFOOJMJJKOGOGEKOOEGHOK@@D@JKEMFDA@@@@OOONOKOONONNOOJOFMBMMJMJGOOGOOJEOJ@BGONOGK@D@@@@KOOOFOOOOOOOOOMEJJJNNMOJMOOKOONOOD@@JJOOMMJ@@@@@GOOJOOOOOOOOOKMGMEEGGFMEOOOOIOKEEJ@EOOKJOGL@@@@@KOOOFOOOOOOOOOMMJDJMMEMEGOOOEMOGNH@@JMNOKOD@@@H@KOOMGGONOOOOOOJFMEEFJJJEOOOOHONMCD@GOKEDOOD@@@@@KOONJOOOOOOOOJMKJHJODBJOOKOO@KKNM@@EFOOFKOL@@@@@MOOJOOOMKOOOOOKOOFHEJJMKNEGJ@EMGE@@AOJMOEOD@@@@@GOONJOOOOOOOONMGEIEGHEGGKAOLAEEJGD@GMMOOGOL@@@@@EOOJOOOMOOOOOOKOOJHHMBJNOD@B@A@FE@@EGGKOJJ@DA@@@EOOJJOOGGOOOOOOMFNJH@DDKMBJ@DD@ME@@FOOOONND@@@@@MONMEGOOOOOOOMMOMKGO@HBLKOEA@@BKFH@AEOOJON@@D@@@EOOJGONMOOOOONONOEKDDBJKFMND@@HNKB@ENOOOJNA@@@@@KOOEDGOOGOOOOONOMNNMEJJLMOEJIB@JM@@@JKOJONDB@@@@EOOJMCNMOOOOOKKOOKKDBBJJBKKEE@BAFH@@EEOAON@@@@@@IONJDKOKOOMMONOMONOHHEENAMFJINIHGB@@D@J@KN@@I@@@KOOJLKNNOMOOOOOOGMOD@CFJDKKABEEAFH@@BJJAONDH@@H@GOOJDGOKOOOOOGOOOOODIEC@BDHHMHB@K@@@J@@@CJ@@@B@@OONMEGNMGOOGKNOKOOMJBHEJJBDEFJDHG@@@MNHDAN@DH@@@OOOJHGOKOOONOOONOGOI@JB@KMKMJ@@@MJ@@GCG@CLD@A@@@OMNLECNJOMOOOONOOOOE@HBJJKFKE@@@JJ@@MIDJCD@H@@@@OOKMDKOKOOMOOMOMOOGHE@IF@EEEB@DBJIBDGMJHALH@@BB@OOOJ@GNHGOGOOOFOKONLD@E@E@@@H@@AEB@@EF@@EJ@BD@@@OKOLHGOEGONOMOMOOOOEAB@BD@@@HAEDJHH@COD@ANB@@HJ@OOOLDCNHOOKOOMNOOMMJL@A@JH@@@@HBNDB@EJA@AD@@H@@@OKOJHKOJGONOMOGJOOOJ@D@BGB@B@@OECBJ@AOHA@M@JA@B@OOKL@GNIGOOKOGJOMOMMB@@E@@@@@HJIEE@@AOM@@@B@@D@HOKOJICOLAOOOGNOKGMOED@D@D@@@@BNDKDJ@DOOD@@@JKBB@OOOL@EOJJOMKOOJNOOGJH@@BAB@@@@KBIE@@AGK@@HIEDHHHOFOJHGOJEGOOMJOENMOFIB@HD@@@@EMDODJH@MONB@@JKBA@OOGHBCOMGKOFOOKKKKOMH@HA@D@@@@IAEE@@@GNBH@HJIEAHOJOL@COOKJOOOONNONMO@@@@BD@@@BHENJIB@JODD@@CEDD@OOGJDEOFOKOMOOOKOGOGH@@@DJ@@@IB@KE@@@CE@HBBJBJ@HOMGL@COKOHGOKFKGKMMNHHHI@@@@@@HKMJHH@@EJ@H@BJJDHOJOH@EONOKGOOOOMNOOGB@@@@@@@@BBOONB@@@A@@@HJJLH@ONGLBCOMNLKNOOFKGOJMH@H@@@@@@@KEON@@@@@J@@EBEDBHOEGD@GOOKJKOMMOMMGOM@D@@@@@@I@JOOJH@@@@I@B@JJJJ@OMCJ@GOOOIGOOOKGOOMFI@HB@@@D@AEMON@@@@@@@@JKEDI@ODOHICOOOJGOOGONKNOMJB@HB@@@@@KFMN@@@@@DBADJNHJ@ONGM@GOONMCOOOOOOOOGD@@@@@A@@EFJOJH@@@@A@AEEJJE@OEGJ@COOGIGOOONKOMMM@JD@@@@@@AEIGO@@@@@J@AEFLIA@OLFNHKOOOJKOOOONMNNKJD@@J@@@IGN@GN@@@@@E@AJKFEE@OKGFDGOOOJGOOOGKOKOLHJH@@@@@AMJBFO@@@@@ADEFMJKDHOMGFHCOOMJKOOONOKNMFIAAA@@@@JFM@GNH@@@@A@AJKFBJHOMFODGOOOJGOOGOMOOOEBJJ@B@BDIKN@EO@@B@@DHBMMMGBHOKNKHCOOOEBOONMGOKMMABHD@@@BHOOBGE@@@@@@DCNJDIE@MFJNLAOOOLJOOOONOOKJDKG@D@DJ@EO@EOJBDH@@@BJMBME@OOMGJEOOKECOOOOKOOMMBJJD@@@DIGNJEKHH@B@@@KFHIEE@MEJNMAGOOLBOOKKOGOMDAEMB@@ED@OOJNNJ@IH@@@AEFEEJHEGKGN@KOOOIOOONOOOFHDJK@IAC@AOOOKONMBJ@@@FIDADJHJJMOMJGOOMEOOOOOOKKDBOMJ@@DBDOOOONKJMHH@@IEEBJJHJKKFNDCOONJOOOOKONMHBME@@@O@AOOOOONNKD@@@CJHHJDHHOKOMIEOKOOOONNOMOMAAGMDDDHD@OOOOOOKOI@@@AEECEBHEGOKGDJOOOKOOGKOOME@BOOE@@JA@KOOOOOONEJ@@KJJDHI@HGMGOKGOOOOOOOONOOM@BOEDAD@D@EFOOOOOIOH@@IFMADD@EGOMNOENOMOOONMKNOEBBKMJ@A@@ABOOOOOOJGD@@EFLIBI@IONOGKOGOOOOOOOOOOM@BONHDHBD@ADKOOON@MN@ABJJEDDHCOOOOOMOOOOMOKOOOME@EOMB@B@HHH@MGOO@@CJHAEJIABI@KOOOOOOOOOOOOOOOOGJBFEGHJ@E@@HHGJNNB@@J@AEDDDHD@KOOOOKOOOOOOOOOOOOE@JOMBA@@BA@AEGOO@@BM@AEBBBEBHOOOOGONOOOOOOOOGGKM@EFOHD@EH@D@BIMD@@@I@EDI@IBI@OOOOOOOOOOOOOOKOONM@JKJBFBA@A@BAAAB@@@@HAB@BBHD@OOOOOOOMOOOKOOOOOGJHIFMMI@AJE@A@@H@@@@@ABD@HDEBHOOOOOOOOOOOOOOOOGMM@JKEEDJEDAA@DH@@@@@B@A@H@ABH@OOOOOOOOOONOOOOOOFJJJMDEE@II@HBH@@@@@@@DJ@A@I@DHOOOOOOOMOKGOKOGOMMNJMOIEIJJN@@A@@@@@@@@@HDDB@DI@OOOOGOOOOOMOOOOKGFKBKDHBJJFJAJE@A@@@@@@@JA@@D@D@OOOOOOOOOKOKKOOOOEMEGMDIEDKNH@A@@H@@@@@DJD@IAABHOOONMGOOOOOONNNOKOFJNKDGMJDJAJEBA@@@@@@@DHB@@@H@OOMKEKOOOOMOKOOOOCKEGM@EKFEGHIG@AJ@@H@@@BA@BDHB@OOGEFMGOOOGOOOKOKMEJONIFOOAKENMIED@D@@@@ADDH@DHHONJNKGOKOKOOOMOONKFKOMHEOJEFJJOHEJDAB@@@BB@@H@A@OOKKMIEOOOOOFOOMKMEBONHEOOJMMOEEJJ@DDB@AAABBADD@ONMNMDKOGOMGOOOOOGEBOODKOOOOOMOONMA@HH@@@H@HDAA@OOFKFJBKNOOOOOMFMMEEGMJGOOOOKOONKJHJE@@@BBJA@@@@OMJONAEOGOOOOMOOOFJJOOEEOONNOOOKOFAED@@@A@@H@DI@OOMEEJDGMOFOEOMKGMEEOMIGONOOOOOOOOEEEB@@@JJBD@D@OOMGOMEMOMOKOJOOOKEBOOMKOOOOMOOOOEJJJ@D@A@@HAA@@OOOJKFOGGGMNOONMONNMGOJMOOOOGGGKONJOFHAB@ED@HDA@OOJNOKEMOOOKOOKOGKEEGOJKOKKOOMOOOGEEF@D@B@BDB@@@KKOCFMNKGNMONMOGNOOEOOJMONONMGOOOMKOKE@@ADIAA@H@MOJMMGEEGKNNKOOOKNJJGOEGOOOOOMOEGOMEOJAA@B@@HDA@OJOJGKLKOOOKOJKNOMMOOOHEOKOGGKOOOKFOOO@DA@DDE@@@OOJMEFJEGOJOOONOOGFJOOLKOOOMONMOOONJOGA@@IAA@@@HOJNMFMMCGOONMGKKMOOOGODFNKNOFOOOOJJOON@A@D@@DDH@OOEFJKEEFOOOGOOOGMEEKOICEMKJOEOGEKGOOL@DA@HJ@@AHOKKCEENMGOOKONOEOGOFOGLEKFMGDOKMNKJKOJ@@D@@AB@@@OMFJMFKKGOKOGGKOKKEMEODEFKKJKEOGKEEOONAB@ABH@I@HOKMKEEFMKOOOOOOOMOOFOOIAEMMKFOOMOJNJOH@@@D@BJ@B@MMFJKJKMGOOMOKGKGEMKCOLFJBFIEKJKFKIGO@@@I@D@@@@@NKJMEEEFOMMOOOOOONOMNOKEEDI@@DEEBIDON@@D@A@DIDHHGNNMBMFKGOOOKEOJKKKNKOMGEBFIEEDIEEEEJ@@@DH@@D@@@JKKFKDIMKNOKONMOOMNKFOJIEA@@@@@@@@@ON@@B@BBBABA@OONMEEBGOGOOOKOMGFMOOMMFJDD@@@@@@@BK@@@@@H@@H@D@OMGFKJDKGOMOOOFOMOGMEONMIBA@@AB@@@@N@@@DH@DH@I@@OGKOEDICOKOKOOKJOJMGOOEFJHD@@@@D@@@J@@@@AA@AB@@@ONMMFJDJOOGOGMOOFOKKFOOKJJ@B@D@@@@@M@@@@@@@D@DDHOKOOKGDBOOOOOOJKKJNMOOFNOEE@@@B@@@BH@@@@@@B@@@@@JNJJMJJIOOOOOOONNOKOGMOGONE@D@HD@@E@@@@D@I@AAAB@OKOGNMHDKOOMONOKGKOGMOMONKBD@H@@@@EH@@@@@@@D@@@@NMJMEJMBOOOOOOMOJNKMGOOOOMEA@@A@@@K@@@@@@IA@DDHHGGMKNODICOOOOMOFOKNONMNOOOJJDEDBD@NED@@@@@@@@@@@KJKFKEGFJOOOOOOMJNKEKOKONNOEE@BHIEF@H@@@DBD@@@B@NOMMMKJKEOOONOOGMKNNOMNOKOEHHJHD@@NHB@@@@H@@@@@@OJKFJLOGDGOGOMONOFKGMOOMONOGE@JJMDJ@M@DH@@@BDI@@GOMJKEEJJKOOOOEKJMMMGEOGOOOOEFJMECM@N@@@@@H@@@@@OJJNJKJKFNOOOOONOOGGOOOOOKNONJMOJMDHE@@@@@@H@@@HMMMEJMEEKCOOOMMGMJMMEOOOOOOMKJKEFOJ@NH@@@@@@@@@@GFKFMKMFMMGGOOONOMJKONOOOOKOOOOOOJO@CD@@@@D@B@@@OOEKGEFJJJKOOGKGKGGNOOMGOOOOOOOOOOEBGJ@@@@@@@@@HKFHGMMKEEDKMOOONOJMGMMOONOOOOOOOOKOHENB@@@@@@@@@ONJJNJMJJJKOOKNOJOOJOONOOOOOOOOOOMFHGJ@H@@@@D@D@JKEGGOFMBEEOGNOMOJMGGOONOMOOOONIFOOBENI@@@@D@@@@OMKJJKKFJHEEOKOOGOOMMMJOOOOOONI@EOEIBNJB@@A@@D@@GONNJJMKJEBOGMFOMJJOOGOKOOOOO@J@EOODAODJ@@D@B@H@OMGEEKFMEDJEOKOMGOOGGONNOOOOOJJBCMGJEJJH@@@@H@@@NOMOMMMJMBEGFMFOOJMMMOKOOOOOJ@J@EGMNIOIGD@@@@DB@KKOEGGFJNIDHOOONNOOGOOOOOOOO@@GHAOOFAGJIB@@BB@H@ONMMGJJJKLHEGEKGONMNOOONOOO@DDMJEEGKEONFLA@H@@@@FKNKGMMEFJDIOMOMGKOOKOOOOOOJ@@GEAOONHMJJJDB@IBA@NOEMEKEDKEBBCNMGMOFJOKGKOOJ@@BEN@KFKBONEE@@B@@D@EEFMFOJJEKIAEGOMOMOOMOOOOM@A@@GJHGOOJOEANH@@B@@@OEKFCFNACEDJEOEOGOKGGOOOONHD@@JN@MOKJMNJKDDHHDH@EJMIEOEDKJJHEGNKMMNONOOOODA@@DEO@GKOMGJAOD@@@@@@MEDDCEJIEEMDJKOMOOMMKOOGOND@@@BMEFOGGMOJKM@BBB@HGMEEJJFJGEE@ADMOGOOOOOOOOJ@AB@AOJKOMNGJIMJ@@@HB@MFMDEEBDMJMEDEOMOOOFNOOOOJ@D@@EOJNNOKNODKN@AB@@@KKEBHHJIFMEDKBFOOOGOOMMOO@H@D@AGNKOMOEMJOFDD@@@@GMMDEBABCEEGADKOOMNMOOOOOJA@AA@OONNOMOOKEO@@@@@@ONJJJDJEJGEEFHKOOOOOOOOON@D@H@BOMGKNOMMMONH@@BD@KKJDDIABEEEEIBGNMOOOOOOOOEA@@@@KOMOGMOOGFODI@H@@OMEBIDJKBIEBJIDOOKGOGGOOH@JBBDHOONMMOKKMOML@D@@@KMJJIFDDMDJKFJKFKOOMOOOOOED@A@BEOKOOFNOOKOJ@@@@@FJDBDEABOEAEEMEGNKNOOOOODIE@HE@EOOEGOOOGOOLA@@I@OIEDJNIBJJBFNJJMONOOOOOOJAFDE@EEOGOMKEOOEMD@@B@@IE@IAEDBKDJIEOGCEKOGOOOGEDJHBEBAOMOGOOOOOOND@@@@MJMEFKB@HJHDHEMJOOKJMOOOJ@E@HJD@OOKNOMEOOON@D@@@NOEKGFHJJJJBGFKFOONJBAMMDA@@@I@IOFNOOGONNOOE@B@@KEMMJOEBJJAAAEMKGOMEDFOGHDB@@JJ@OOKKGOOOOOMD@@@@OOOGOMLIJOEDNJJMOOOD@@HHA@@BDDIAGJOOOGOGKOOED@B@GOMJLFKFKEKBMOGOGOGJJBB@D@I@@JDDMONMKNMMOOMNJH@HOMEEEAEEEOMGFEJMKONJA@@@@@HH@DNHOOOOOOGNKKGENDHHOOMAFJBJEKGEKJKGFOOIB@@A@@JBDJEBEOFOOKNKNOONKDA@KMFMJDDIBFMFMGMOJOMMA@H@ABA@@AFIGMONOOGOONNJMECHGOKDJHB@@JMOKEFKDGOME@@D@@D@BJEDMOKGKGMOEKOOOEE@OMMMEED@DDJOOMEODBOMJHD@@HIDH@JJNOONONOOOOONMNKHOOKEEHBH@BEONJKGIEONJI@@D@@@@DJEGNMKNOEKEONOOFOHONMNJMDA@IBGOMEMEBOOMDBI@AEBEBEJEOOOKMOOOOOOKKKHMOJKODIDEDHKOFNOL@OMGJHB@D@H@EBJOOEFOOFOGJMOOMOHGFNOJJBBIB@DGOGEFBGOMJBHA@HJD@JJEOOONMOMOOOONOGHMOKGOJIDJJIBKMEMJHOOOEIE@BBHABEJOKMKGOFOKOOOOKOHGMNJJL@BJJDHHOOFM@GNMNEF@@IF@@JJEOGOMKOOOMKOONOHOOOMNKEEEEFJBBOIFLGOOKJHI@E@HHEEBOOEKOOOGOOOOOKHOKMFJEDEEEEDHEFNKD@OMMDJ@E@JBBDBKOMONMGKMOOOMKO@NONKEEEBJJJE@BOKMHCGOGJID@BHHHIEEGGMKGNOGOGKONOHOJKMJBHEAADJEABMFM@KMMEDAA@DBEAFIONOOMOONOOOOGO@OJMEDJJDJDIA@JBOJJ@BOOJKD@IBHHDJEMKMJOEJKMMOMOO@NOEFJBHJABEDJ@JBOEHBNMKFIEBJ@JBEJOOGGKNOOOGNONO@ ) (RPAQQ LINCOLN #*(189 252)EEEBD@B@@B@HD@@@@@D@EBOGOMMKGOOOMEEDJJMFJJMEJKFHIDJIBHHDE@DEBEDE@B@EBMMNJOGGONOONJJJJKEEFMEEEEE@EBIB@BAA@BB@@D@@BAABOGGKOKMJMGOOOJBBJMEKEEEEEJJHJDJHJH@@@@HJEBJI@HAGEKMGKFNMOOKGKMIIEEFJJKDJJEE@DIEEAADHBD@@@@@@@@MKOMKOOOKFJJOOONJEBJJJMJKEEJJHEDIADDHB@AAEBIAA@EGMEGFJKENJJMOMOOMDJKEEEEEEJJJHEAEEBD@@A@@@@DDDECMGOMOONOEMMKEOOGOEEEFMEEEDKEE@DDEBIBJ@HDDIEA@A@MGNJOJKKMNJNMKKKOOJIEEEJJJJMEE@FI@IDI@D@@@@@DBIOGOGOJOMOOEGEFNOKOOMEEEFJMKEBJJHIEEEBDH@BA@JEB@DIKEKEOMGEGMEOOKNJKKOJJKEEEEEFJJHE@JJJJBBH@@@@HJKGOOMNJKMOMKOJNOGOOOOMEEEFJJJJME@BDIBJDH@@DDBBBAENKEGGONOFOOGOOMMCFOOOEEEBJJIEEE@DHDJJDABBA@HHJJKGOOKJJKKOKENMMKGOOMOOJMJMEEEEEE@DEBDIBH@H@@BBDEEMEEMOONNKOOKONMKKOONOJJIBJJIFJJHBHIBJHBH@DBDIBCGGONKEEKKOGGNJKFOOKOKOJIEKEEEEEE@HDEDDDHBA@H@DEEJMEEMOOOOMMMGOMKOMOKOOMEDIEEEEDI@BA@AA@A@H@ABIEBOOMNOFJJJONOKFOOMONOOONJEFJJJJJJHIDBJDED@@BD@BEJNJOEEMOOOKKKNMKEGFKNOOOEBIEEEEBDHH@@AB@H@@@@@JJMKOKNOGJJKNONKOMJMKOOOMOJJJJIEDJJHDHIDHJ@ABD@EEJKNJNKEMOONKMKOFNMKONOKOOMEBJEEEEE@BB@@D@@D@@BAFMNKGGMNKEEOOOOKOKOONKKOGOODJIEDJIBHHHBEBJH@@@HMKFKFMJOGMKOEOGFNKOKOGMOGOKOKEEBJIED@B@H@D@A@HD@EEGMKNNKEFNMOGOOKONOKOOOOOOKLIBIBJJC@DB@HHH@BBAAKGJJMEEKFKEKKNMKOMKOONOKKFOOODJEDJEDH@@B@@BH@ABBMJMOGOJMJHMGNOOMFOOMNKKNOOOONJJIBJIBHDI@DHH@@@@JJMJKJIFJHICJKKFOOKGGKOOGMOKKOEBJJJJI@ABA@B@@@ICEFKEJMNJH@@@MNOMKEOOOONMOOKOOKJJEBIBE@HDDE@AA@@EGKEJOFJH@@@DCEMKOOMMOOKOOGOOOOLIBJEEDHB@A@BH@BIEJJMGEKE@@@@@JKGOKKOONNOOKNOOOONJJIJJJHHBHBH@D@EFMEFMOEF@@A@@@EMKNOGOKOOOOKOKNONJIBIBDH@HBHDI@IEEENOGEM@@@@@@@EGNOONMOOOMOOOOKOODEEEEB@D@DA@@@@KENKEMOF@@@@@@@BNOKKOOOKKGMMMOOOOJIDJEE@AB@HDH@KEBKEEGKJ@@@@@@AAEKOOKOKOOOOOOOOOOIBBIBJHDHDB@@BEJGKJJJNJ@@@@@@@@CFNOOKOMODNOKOOOOLIEEJDH@AA@IAABJMEFJEKJ@@@@@@@@IGKKNONOGOKMOMOOOKE@JEDHBD@D@@BJJKJIEKNH@@@@A@@@@IGNONOOMKOOOOOOOMBJIABH@BE@H@EJKFMLOFJH@BA@H@@@BBJKKOOMOOOOOOKKOMDEDJI@JH@DAAFKEJNKEOK@@@@A@@H@@AEJMKKGKNNMKONOKNABEBDH@AA@HDEEFMEMOEE@@@@@@@@@HHHIFOOOOOKOOGOOOODIDIBHDDDJ@AFKKGKGEOJB@@@@@@@@@ABBCFOMKMOMMOGNONJBJJHH@AA@HAJJMEEJOED@@@A@@@@@B@@@HMMOOOOGOOOKOOEBEDJHJDDBBBMGFMNMJNL@@B@@@@@A@B@HEGKFOGGOGONOOOHIDJE@AA@H@CDJKFJKGK@@@@@@@@@@@HBA@AGKMOOOOMKMOOJJJAB@J@BDIEDMMEEFNJHDA@@@H@@B@@H@JJHOGOMKOOOKKOMAEJJH@I@B@GAFJNIOMM@@@@@@@@@@@@AB@ABAOOOOOOOMGONJJEE@J@EDEEJJKEEEGD@@@@@@@H@@@B@@IABJKOKOOOOEGOODIBDHDJ@ABKDBMJKOMJ@@@@@@@@@@A@DHDDHAGGOKOGOIGOOEEEBH@AEDIE@MJNMJNH@B@@@@@@HB@@@A@@BIAOKOOOOECOOIBEE@JDABEMIFOGFOK@@H@@@@HH@@@@B@DJHBGOOOKOKLJOOJJJI@ABJDJJAKEJKEMH@@@@BBB@@@@A@@@@AAANIKOOOJKOOMDIE@DAABCEEMMFMOF@@@DB@@@B@HHH@E@I@HKOEOKOONIOOMEEDHBDDIEBJKGKFKG@H@@@@@@@@@B@B@BBD@BMEEOOOJJKONJEBHIEBIEDCNJMEMJD@I@H@@@@@@@@@@HHABIFIGKMOMDOKNJJJHDHIEE@EEOEKFL@B@@@@@BABA@H@@@BDHAGDJOOOMBGOOEDJHIBDIEIFOMJOME@@@B@@HH@@@@ABDID@BDOJEOOOFJKONJEB@DJJBJHKOFKEG@@@@@@@@@@@AA@@@DABHBCJKOOKNJEOOJJJH@AAAF@FKKEGJLD@@@D@@@H@@@@@@H@HAAENJOOOJICOOJIE@JLHMGJKMNIMKA@@A@@@@B@@H@A@JABABDCOGOKMJJDOOJJJH@@EAJIEGEIFM@@D@@@EB@@@@BDD@BAD@ADOKGONJEBOOMEB@EB@JMEGJOEKED@@DBD@@H@@A@@@@HH@IDAEOONJJIBOOJDJHB@JEFMJOFJMJ@@@@@A@@@ABH@BAE@BJBBHGOOKEEEEOOMBI@DJBIJJGEKGEDIAA@@@@@@@@@A@@@BA@HHBHKMMDIADGOJJBHH@ADMDKNMIJM@@@A@D@@B@@@@@BEA@EBADBMGJJJIFKOMEDHADJEFMEEFBMDI@@@A@@DH@HAAB@@HE@ABIICKMBDDJKONDJHDBAEGJKOKMMH@HA@@@A@@B@@@@EBE@ID@@@@EEEEBJKOMEJHHHDENMFJMFJJDBDA@@@@@@@H@B@B@BBABJJIBJIBIECOODMHBBABKEGOGEG@A@@@@A@BBB@@I@A@JE@H@@HDIEEEEBIOMENHDHHJOJJJMKMHD@@BBD@H@@@@@A@@I@HBDJEA@BBJJJKOOGJH@ABCEEMKNJJH@DHH@@B@I@BBDHBBDEBH@A@HEAJDIEEOOOO@DHAANJKFKEGAB@B@@@H@@BHH@ADHH@IABHJB@JEBEEGONOJH@BHJJOMKEKJD@BHBBH@IB@ABBD@@BEB@@BAADHHJIBIMOOM@JDBEEEFMJME@ABA@@@@@@I@@@HJJHHHDJID@IBFIDJJOOOFHHHHEOOKFOEB@@ADB@BBAD@@AA@@@BBAB@B@I@BAEBIBOOOMHBBACEFMKEFM@JD@@@HHDBEBDB@HBH@B@I@H@IDJDIEENOOJHI@DEOMFMKKFA@EEA@@@A@@@@HBA@BDHH@HBDBIBJBJJOOOM@HI@EGGKFMJKADH@@ABA@B@ABA@@BA@BABBHIBBDADIBOONNHJ@@BOJMKFMMBHFDDD@@BDI@HHA@@H@HD@@B@HIBJBJJOOKJHHHBAJMFMKEEEADHA@@@@@@@@@BBEEBA@IBHBBDHIBJJOOONH@A@IOGKFMEDBHHJ@@BDIABI@BH@@B@B@@@@HJIBDJEEGOOKHE@BBMMFMMKFHADJDHH@@J@@A@@A@HI@HJBJAABJJKDJOOOM@@BHCOGKGFMJDBME@@@@A@A@@@@BBA@D@@H@HHIBJ@IEOONKHE@@JMJMJKEHFIDJB@@@@@H@I@BD@HI@BBBJBEDJEFEFOOOFH@@@ENOFOMFJJCDG@B@HBB@A@@H@@E@A@HH@HIBEBAACOOME@BDIGKKKEFKJEEJJ@@@@@@@@@B@@H@BHE@AEBDI@IDJIGOOE@H@@KMNMOKMLLFJMB@@@@HDHA@@HAB@J@BDHHJBIDB@JOOOI@@I@NNKGDMFJEEFK@A@A@@@@JNH@@HH@IABBBADDJIEAOOOM@B@@KKMJOFKMDKEEHD@@@I@ACJBBB@BHBDIADJIBBHHJOOONH@ECNNKGJMMEFMJJI@BH@@B@KOJLHA@A@BDJAABIIEBKOOOK@H@IGKNMGJOLHKEJH@@@@@HONMOKEDBHBHIABDHDDJJIGOOOHABCNNKKJOEFMFMED@H@EB@EKGOONKABHBBJ@JEEBOFMOOKOH@AEKOMFMEGJIKFLA@@@A@KOOOKOOOLAAADAEABIEKOFNNONH@@GOEFMGKJMMGEJD@@@BABKGKOKGNKDBDIJBBJJMOKKGOOMHD@JMNKFMEGFKMMDABBI@DIMMONOOONJHA@I@IEGEAOOOOGNH@DOOGMKFNMKMGFMB@@@@@GFKMKMKGOKADEBJEGMNOGOONKO@@EKELJJKEFMGKEH@DHHABAIFOOGOOOFHABDAEOOOKOOKNINHAGMOGEKKGKKMJOFA@@@@@ODCKGOEJOOBHHJJKOOOOOOONKK@AOGMLH@EJMNNOKM@BBDDABHOOMKOOMMJDBBIGOOOOOKONKO@EMNOD@@AEFKKJODH@@@@EMAEKGNKOOOEBHKGOOOKOOOOKEEHFOKMB@@@NMMMMGNBA@A@JKGOGOGNMOGMDBKKOONOOOOOMGK@EMOFHHH@KFKFNMJ@HA@AAEJMMKMKOKMFJHFOOOGONOKKNNJHKKKMKO@@EKNMKOMD@@@@MMGKFMGONOGKDBIOOOOOKOOOKMJHNOEFNMNHBMGKMFK@@H@EFJNOKGMKGMJD@HEOOKOOOOGOMJJHEMKKGKO@BFMFOMMHHA@@KGKJIJOOMOEHAAEKOOKOOOONKFI@KGJMMOEL@KFOFOFH@@@BKNNJ@JJMOKJHHAFOKOOOOOOKJJD@FNIGKEKN@AKKKMMD@@AAGKKDDAOOFNMDABMNOMGKOOOOEJBHKONNONJJ@@MMGGFJHA@BNOJAAFMKOODEBBEGOOOOKKKONJHHEGEKJKEO@AEOMMKF@@@COME@EOKOKE@DHAAGONFOOOOMEEBHEJOFOMAE@@FJONMA@DEEFMJMOKOFONMB@HHCOOOOOOOOMDJ@BOJOJKAJHAEOFOED@AAEKFJKJOGOJKD@HBEFOFOKOOGJJJE@AEOJMM@O@DFKKKJHH@@EKEEOOOJKMJJA@H@CMKEMGGONJIE@DODOFJA@AAEMNNLAA@HEFMFJKMONFJDDBBJIOEFKMOOJIEBH@JMJKD@DADJNMKFH@B@EKDIFJODODE@ADA@BMHIDKOKJEBJ@BGIMMD@@AJKEOMJHD@ABI@@ABJJJJBE@@HBIFOEKOOOJIEBH@JIEE@@@BJEGJKDAA@HEDA@@AEIGJH@EDA@BKEGFONKJJDJHIOLJJHD@KJIEMFI@@EEAAD@DHIGJJAB@A@IAEEJOEOMMBJI@AGDHKD@@EMAFOKD@@HB@@@@HBMJKE@HE@B@BBJEEFJJLIBJHIKHD@H@GOFHKJM@@@A@A@@@BIBIEEJB@E@JHKEBMMOEJJJD@@KMABJ@EOJIBONHAAA@@H@AADJDKJHH@@HA@EJJEJIJNIBJHJKDD@DACMM@BMF@@@DB@@@@@CEKDMBBBJBHBIFIEEDJJJJDHBEL@A@@FNK@EOK@H@@@@@@DBHJDJJ@HHADE@CNJKJJIFDEB@@BJ@D@@CKD@CDM@@@@@@BD@HA@JEEBB@J@HDHKOJJKDMEDJHJCMB@@@EM@@BOE@@@@@I@@B@@BABHHHB@J@@AGOKGMEFJJJ@@JFH@@AFJD@CEJ@@@@@@@@@@@IJJJB@HJ@HIBEONMMDKDJE@BCC@@@HEL@DBOGA@H@D@@@@BBBEEB@@@ID@@@BJOKEBFJIBH@BKLA@@KD@@AEI@@@H@@D@@HHAKDHDIBBBJIBIEIEBIGEEDHACELH@@OHB@@KNL@@@@A@@JB@EDHAB@@IAABAEDJBEENJDJH@AEF@@AJH@@DGOD@@@@@AB@@E@@BB@DH@J@@DEBIDIBKJJB@@GNN@@IG@@@@KEJB@@BDD@@@@BE@HB@BJABABIEDIBINJJI@IBOM@D@J@DA@EMDHBA@@HJBEA@@A@HIAADIDIEDBBEEGEDJH@GKOD@@J@@DDKOJH@@@@B@@@@AA@BBBBBEDBDBJIAEJKEBI@@JOKH@BDAB@@EFO@@@@H@BDI@HBBD@HA@HIAAEBDHJENJJE@DEMOJ@@B@@@@COKM@@@A@H@@@B@HABBJBBBDJIEABBJODEBHICFKLDHHHBAEEONJBBJ@@ABHA@H@H@H@IBHHABBDHIBME@J@@ACON@@B@@D@GEGM@@@@B@@A@@BBABBIB@EBJDIEBEEODMBHHALKMBB@@@@@BOMOLB@A@BBHAA@HD@ABEE@@HIEDBJEMBEE@BDEGO@HB@@@ICNNMDH@@@@@@@@@@HJHHIDJHBDJIIAGMEEBH@@DONH@@@DDDDKKOK@BBA@@BD@@B@AD@BH@AAAEBDMGMEBI@AABEODD@@@A@CGNKMB@@@@B@@D@HIGD@EEDBDJJIBEKJIDJHHDAGGHA@@DJOANKNOJH@@@@A@@J@AFIBHBA@I@JDJJOMEBDHDABMOJ@A@@ABEGNKJM@JDIA@B@@BJK@@A@HBBEFJBKODIEBHBHAGKL@@@@AIAEMNOJJAB@@@@BH@BMBD@BB@IBNJJGOEEBJHDA@JOJ@@BD@HEKGKFOEDH@IBA@@AEJ@HE@HHBDKEEGODIEB@A@DEKN@@@AB@@OMOMKMEBJ@HDB@BEDH@@HAADBOEEONJJDI@DEACGO@A@D@BDJKEFMFLJJDE@@I@KJIBDBJDBJOKEGNIEBJHI@DEKMH@@@@@BKOOKEMKEJI@AB@BNJHHIAEEJKOMEOMDIEBHDJHBMGH@@@DI@EEFMCGMJJJJB@@JMAEE@JKNOOOOKOJIEBI@BABIFOD@@A@A@KOOJENNMDK@HEBEM@BJMEOOOOONOOMBIDHHHJ@DKEJ@@D@BLEGEOBGKGJJL@@IGJEGOOOOOONOOMOJ@JJF@JAEBA@H@@@@CJBMOFIEOJNJIABEKD@KOOOOKNOKOKOEFIBA@DHDIBKG@H@@GLAGOMDKKMKEDB@KFIBBMOOOOONKNOOHAEEE@@BBDIEEH@@@GNBMKG@EFKEGJBIGNHDBOKGMOOOKGONJJEEDHEAEAEKJL@@@KFIGOOLBKMNMEJ@KJBA@JMOOMOOJOOODIDIB@@JBDFMGF@@AONBJKEEBKFKKJIJMJI@ABJKOOOOEOOMBDJIBHIADIEBIK@@BOKAKNNMEBJJNMDAGDBBDAEFNOOOMGGNIBJDHH@@JDHIEENDKJNDMKKFLKMKOFJDJHH@@DBKOKGGEEOMDIEEE@JJABED@KEKGOO@KJNKGEFLJI@AF@ABA@HIJOOOMGONIEBB@@HHJIDCBBKNNMJ@JMKEEEDIO@ABMBJ@JBBEOGOOKEOJDHJJE@DDAEAJHEEEOOMECFJJIBJ@JH@AD@AE@D@BJKONNJOMBJIABHABLHJEAEFOEGJJEEKDDBJEMBEGEDJ@A@IBMFOOKKOJJEEEDHIDBJEEEFKFONNDBMEBADJEF@KODA@I@H@IFKOGMJOJIABDI@DEJIDIECEKKKJGEEKJBJLHJ@FJH@B@DBBADEMOFOOJDJIBBHBHEEBDHMDENOJBMMDKBJIAFAEM@HHB@@@EEBOOOEOJA@JID@DEBEJJB@HFKMHEFJKEAAD@JBJB@BBJIBA@@IGOKOOJDIDIBHI@JJEADBFIOGLFJOEM@JBADBM@C@H@D@DBJBMOOKNMBEBJI@BABEDJ@@IEENHEOKFJDBI@JB@BJJEEAD@H@JNONOKM@IEABHDDKEEBJB@BKKLKEOKFDAD@JHI@KEI@HBOEBGKNOOOLJDHJH@@HIEDI@@DBMODEOMKI@@DDH@@EEJMGGOGJIGOOOMOMABJIC@BBEDH@AB@HGEMAENME@@A@KDDBKOFMMMNOEOOOOOOMBJJJHHHIEABJH@D@JOLFJKEDHH@@HHAEOJKFNOOOOOOOKOKLDIEAB@@BBD@@@B@EEKGEGMMBHABAEADFNJ@AA@EFOFOOOKONIEDJI@BHHHJDI@A@BKNMJKDED@@@J@AGJHHH@B@IEEKOONOJDBJHBH@BBD@@@A@B@JKFKFJKD@@AD@BOJ@B@I@HBHIGGNMOMBHJJJHD@ABJI@BE@BBOJJJMED@@@HAAJHB@@BBBHBEMOKOOJJJIEB@@IDD@DJA@@@EFNJKENJ@J@D@@O@EME@@@DHHKOOOKMBBEBI@HD@AB@@DBDIAKKBAFK@@@BKHEJHBOEIAABECGOOKONIDJIBHBBJHA@H@H@@HOOMMDJLB@@@EBJIAENNJNJKKOOOOOJEBJJJ@@@EDHDBD@JDIEOODIGD@@@IDKB@@GKOOOOOOOOMKKMDIEDE@DJHBDDHJD@ADKFKJBJHDB@BBM@HB@OMOOOOOOOOOONJJIBHHHAEHIBAAA@H@GONNMODB@@@KEB@@IAGOGGOOOOKOGJBAEDE@ADDEBIDDDDBJJKGKKEE@@@BEDHHHDEGGOOOOOONOMNIJICBHDAA@HEAAAA@AEGMMNJJHAA@JJ@A@A@CJJMFMONKMOMDEDIE@I@DJE@@DDDEDEMGGEMM@@@ABHJDBHEINMEKKJKKOKNJIEEB@@EBDHJJ@@ADJJKMMNJKJ@@@DA@A@EBBAABBFMONOOODJJJJHH@IB@DABDHIABMGOEMMD@HBAD@@EB@A@BDIABJKOOOBEDEE@BJ@IEBH@@DJDJJNMNKEJB@@BABI@HJH@HIBDKOOOOMJHKDI@DADDH@BJDB@JAEGOEMED@@IBJJDBDB@DB@IAEOOOGNJEDJJHBJBJDJH@ADJADJJKNKGJ@B@JMGKDADH@HJDMKOOOOOEBJBI@DADDB@BDH@IDBBMNKMMLDCEGOMNJMEABBBJOOONOOJHJEJDHBJBI@D@@ABD@HIEONFNK@AGNNONMENHHIIBKOOOOOOFIDEE@H@IBJAAB@IABABFKEKGMDBEGKNOJOKJNEEEGKOOGGNIBKBJHJEDH@DDADBH@JICGOMMEEDKMOGKMFOFJJJKOOOKKOMEEDJI@IABEEA@JADEDKLIMJKGNKAMOEMNKOGONJOOKKOOOONJDJJDHDEAD@DBADE@BEBDFOMJKFIGEOGGMGGKMMNKOKNOOONIEEEE@BHMBJ@HJJHIDKHACJNNMNIFOGOMFOFOONOGGOOOOOMEEEDJHIBBIAD@@@EA@NIDEGEKGGDOFMJKKOGOGKMOMOOOKOOBJJJJHLIIDJEEEBBJEE@BBMOKMMCKKOOOMGKOONOKKOMKOOMDIEBJHFJEEEA@BADAAG@AIGEFOKEGOFJJMNOOOOOOOOOOOKMBJJJE@IABJHJEBJEHJN@DJMOOENKMKOGOJOOOMOMONOGOOONJDJJJHJJJJEBHBEEEAOAAEGJKOGOGOENKFOOMONOOGMOOOOJIBJIE@JHBJIABI@J@IE@@JJOMEOEMGOOOMOOOOKOKOOOKKOMEEEEE@JNJDHEDBJEEBO@@CGEGGKOKMEKENMMKOOOOOOOOOKFBJJJJHJIEEE@IBBA@CNIBAJOJMMEOKOGOGOOOGOOOGGOOOOJIBKEBHBFJJDJDADJEEKH@DEEGKGNKNMNMKFOMNOOGOOKFONJDJMDJ@IADJJABJE@@BO@@BKKJMJKNKOGKOOFOOOOOKOOOOKEBJJKE@EDJEADIABEDKOH@@EEGGGMKOEMOKKOOGKKMONOOONJEEEDJHBJJJLIEFJJ@EMIB@BNMMMGOKOKFOOGMOOOOOOOOOKEBJMJJHIBIEBEBJIBEGOL@AAENKGMJOGOOJMOGNOOGOKOONMEEBJKE@EDJJMBIEFMAKFH@HAFKMMGOOMGKGOMOOOKOOOOKOMBJJKEE@DJJEBIEEJJJOKN@@@KMGGJKEONOOMOOKMOONONOKDJJJMFJHJJKEEEBJKEEFOO@B@AEKJOOOGKMKGONOOOOGOOOOEEEEEJM@EEEEEDJJIDIOMJDH@AFMOEJOMOGOOKOOOOKOOGONJJJIEEE@JJJJEGEEFJFMOOH@@@BNJOOKGKNJMOOOGFOOOONJIBJJJJJHJJEEIDIEJJKOEODDH@ACGEEONNKOOOOOOOOOOOMJJJEEEEE@JIEEEKBJJJJKNKH@@D@MJOOEKONOOOJMNOOOKGJJIEJJJJJHEDJJJJJMEEGEGNMB@@@BKEEOOFMKFMOOKOOGOMMBEDIEEEE@JJEEJJKEJIEOKGL@@@@AEGOEEMOOOOOGOOKNNJNIABJIFIBHEEBJMKEEEFNJOOG@@@D@@MKOOOEKGKKNOMOKMEODJJJJJMJHEDJMEEFJJJKOEENH@A@@@FMJMKOONOOKOONOFJOJABJJMEE@EFEFJKEFJKMCOOGDB@@@AAKGKNMEKOMOOOKOIAGMDIBKEEE@ECBJMJJKEDMMJKOL@@@@@BKKNKKOOKGOMKOMDJOMBEEEEJJHEHJJJJKEFKKFOMFL@@@@@@EFKNOFMOOFOOOGEBGOEDJJMEE@JNKEEEEEJMNOJOKO@@@@B@AKNKEMOFOOONMLIBKOJJJJJJJHEAEBMJMJKFKJOEOM@@@@@@@JKMNOGKMOKGOEBICOMBEEEEJHFMEJJJJMEGFMJNJOH@@@@@@BMFKEMOOKOOEDDDIOMEEEKEE@EBJJJJJKFJMFMGGFH@@@@@@AEKJNNKFNMKMAABEOODJJJKE@EEKEEEEEKKKKGJMON@@@@@@@BEGEKOOOONJDJIBOOJIEFME@JJJNMEEJMFNMMMNKD@@H@@@@@@IFNJJKGE@BDDIOOJJKJJJHJJKEEJJOFNKFKGGMN@@@@@@@@BBEEOOOMJAABIBKOMEDJKG@EEEKFJMEKEMMOKEGGH@@@@@@HH@@EAEDJHHHI@@OONJKEJIHJJJJJMGKFNKFJMOMMD@@@@A@@@@A@DDAB@IBBEEGOOEEFKFHJJMEMEJMKKGEOFJNOH@@@@@@@@@@EAA@@J@AABBKOOJJJMJHMJJMGFMFMFMNJMMKEL@@@@@@@JB@@@DBB@IDDIAGOOJEFJK@EEFJJMKKFMMEONKKKN@@A@@BOJHBDHH@HD@@IADKOOMDJJM@FKEFMKMFMKGKEEMMMK@@@@@AGOHH@A@DAADI@JBGOONJIFJHJMFKFMGKFOJMKKGFKO@@@@AGOOJ@DD@A@DB@EAECOOOBJKEHMEEJOGEFMJKFNOJKMFL@@@BOOKO@A@B@EBIEDJAEOOODJJJHFKFOKMKGFNMKEJOMGKJ@@@KOJOMM@A@IBOOJJEDKOKOJJKFHKEKENJMJKGKEKEJKJOH@@AFJOMGNM@EEKOOOKBECOOOMEEK@JNONKOFMMJNNNOGFMJN@@CKOEOOOMEEJEOOOOMDKOOONJME@KGMKNJKFMEKKKEKKFOG@AJNKNKKFOONIBOOOOOJEOOONJJJHFOGGFOMKFNMMFOMMKEKHBOENKNOOOKNIENOOOOMGOOOOJKG@KMOMKJKFKGFKMJKFMKFMEKKKNOMKKOKMGONOOOOKOOKOJMEHOOJNNKFMMKKMGOFKFMOJOMMMKJONOOOOOOKOOOOOOKOOMEE@MMMKKMKGNMMFMEKMKFJOKGFKNOGKOOOOOOONOOOOOOOONJK@KGGNNKFMENOGGNMFMJMJNMKFKMJOKGGOKMOOOOOOOOOOKKEHNMMEKMKKFKEJMGOKFKFMGJMKGGOMOONNOOKOOKKOOOOMONNHKOGOFKFMKENOKJJMKFKGJOKEMNKGKKOOOOOKOOOOKOOOOOMHOKMENMKFMOGJNOEGFMMJOJMJKKONNOGKOKOOOOOOOONOOOOHJNOOGFMKFKJOEJOKKFJMJMNOMNKGOONOOOOOKOOOONOOOOOHMKEEJOFMKEGKNNIEEKGFOGEJKGNOGGKOOOGGOOGMOKOOOOOHNMONOEKFMOJMGENOFMJOKKKGNMKMONOOFOOOOKOGMOOOOOOHGFKGENMKEEEKJNKKKFMJMENMEOGGMKOKOOOOOOOOOOOKOKOH ) (PUTPROPS WINK COPYRIGHT ("Xerox Corporation" 1982 1985 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (628 2989 (MARILYN 638 . 891) (SHOWMOVIE 893 . 2880) (WINKW 2882 . 2987))))) STOP \ No newline at end of file diff --git a/lispusers/WINK.TEDIT b/lispusers/WINK.TEDIT new file mode 100644 index 00000000..707d7782 Binary files /dev/null and b/lispusers/WINK.TEDIT differ diff --git a/lispusers/WORDNERD b/lispusers/WORDNERD new file mode 100644 index 00000000..aeafd88e --- /dev/null +++ b/lispusers/WORDNERD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "18-Nov-88 10:52:55" {ERINYES}MEDLEY>WORDNERD.;1 82616 changes to%: (FNS WordNerd.DefaultVennSearch WordNerd.DefaultWeightedSearch HashfileNerd.ExpandKeyPattern HashfileNerd.MapKeys HashfileNerd.Create) (VARS WORDNERDCOMS) (MACROS WordNerd.ExpandKeyPattern) (RECORDS WNKEYSETINFO WNKEYINFO) previous date%: "11-Nov-88 17:23:39" {QV}LISP>WORDNERD.;24) (* " Copyright (c) 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WORDNERDCOMS) (RPAQQ WORDNERDCOMS ((* * The following macros are the interface to three different search techniques using a WordNerd. The default implementations are given below.) (MACROS WordNerd.Open WordNerd.Close WordNerd.AddAssociation WordNerd.MapKeys WordNerd.ExpandKeyPattern WordNerd.VennSearch WordNerd.RelevanceSearch WordNerd.WeightedSearch) (FNS WordNerd.AddEntry WordNerd.AddDictionary WordNerd.AddStopWords WordNerd.SortByFrequency) (FNS WordNerd.DefaultVennSearch) (FNS WordNerd.DefaultWeightedSearch AddWeightsToArray FindTopElements AddToPriorityList) (FNS WordNerd.DefaultRelevanceSearch MergeKeywords) (FNS WORDNERD.PARSEINPUT) (RECORDS WNKEYINFO) (* * SimpleNerd is an in-core version of the WordNerd.) (COMS (FNS SimpleNerd.Create SimpleNerd.AddAssociation SimpleNerd.MapKeys SimpleNerd.GetEntry SimpleNerd.MaxEntry SimpleNerd.GetHeader SimpleNerd.ParseDictEntry SimpleNerd.Test )) (* * HashfileNerd stores its data structures in an InterLisp hashfile.) (COMS (FNS HashfileNerd.Create HashfileNerd.Test HashfileNerd.Open HashfileNerd.Close HashfileNerd.Write SIMPLETYPE HashfileNerd.AddAssociation HashfileNerd.GetEntry HashfileNerd.ExpandKeyPattern HashfileNerd.MapKeys) (FNS BIGHASH BIGGETHASH BIGHASHSIZE BIGMAPHASH BIGPUTHASH) (MACROS BIGHASHP) (RECORDS BIGHASH)) (* * the following should be merged into ANALYZER eventually.) (COMS (FNS FileDict.Create FileDict.AddFiles FileDict.PrintEntry FileDict.Write FileDict.Lookup FileDict.MapEntries FETCHSTRINGFROMFILE) (FNS SimpleAnalyzer.Create SimpleAnalyzer.Lookup) (FNS SimpleDict.Create SimpleDict.Open SimpleDict.Close SimpleDict.Write)) (VARS ENGLISHSTOPWORDS))) (* * The following macros are the interface to three different search techniques using a WordNerd. The default implementations are given below.) (DECLARE%: EVAL@COMPILE (PUTPROPS WordNerd.Open MACRO ((WORDNERD) (APPLY* (OR (InvertedDict.Prop WORDNERD 'OPENFN) (FUNCTION NILL)) WORDNERD))) (PUTPROPS WordNerd.Close MACRO ((WORDNERD) (APPLY* (OR (InvertedDict.Prop WORDNERD 'CLOSEFN) (FUNCTION NILL)) WORDNERD))) (PUTPROPS WordNerd.AddAssociation MACRO ((WORDNERD HEADER KEY) (APPLY* (InvertedDict.Prop WORDNERD 'ADDASSOCIATIONFN) WORDNERD HEADER KEY))) (PUTPROPS WordNerd.MapKeys MACRO ((WORDNERD MAPFN) (APPLY* (OR (InvertedDict.Prop WORDNERD 'MAPKEYSFN) (FUNCTION NILL)) WORDNERD MAPFN))) (PUTPROPS WordNerd.ExpandKeyPattern MACRO ((WORDNERD KEYPATTERN) (APPLY* (OR (InvertedDict.Prop WORDNERD 'EXPANDKEYPATTERNFN) (FUNCTION NILL)) WORDNERD KEYPATTERN))) (PUTPROPS WordNerd.VennSearch MACRO ((WORDNERD SYNONYMCLASSES MINKEYWORDS MINWORD MAXWORD DONTCONVERT) (APPLY* (InvertedDict.Prop WORDNERD 'VENNSEARCHFN) WORDNERD SYNONYMCLASSES MINKEYWORDS MINWORD MAXWORD DONTCONVERT))) (PUTPROPS WordNerd.RelevanceSearch MACRO ((WORDNERD HEADERS KEYSTOIGNORE MINWORD MAXWORD) (APPLY* (InvertedDict.Prop WORDNERD 'RELEVANCESEARCHFN) WORDNERD HEADERS KEYSTOIGNORE MINWORD MAXWORD))) (PUTPROPS WordNerd.WeightedSearch MACRO ((WORDNERD WEIGHTEDKEYS MINWORD MAXWORD USEFREQWEIGHTS) (APPLY* (InvertedDict.Prop WORDNERD 'WEIGHTEDSEARCHFN) WORDNERD WEIGHTEDKEYS MINWORD MAXWORD USEFREQWEIGHTS))) ) (DEFINEQ (WordNerd.AddEntry [LAMBDA (WORDNERD HEADER ENTRY ANALYZER) (* ; "Edited 14-Sep-88 09:25 by jtm:") (LET (ADDASSOCFN) [COND ((NULL ANALYZER) (SETQ ANALYZER (InvertedDict.Prop WORDNERD 'ANALYZER] (SETQ ADDASSOCFN (InvertedDict.Prop WORDNERD 'ADDASSOCIATIONFN)) (Analyzer.Analyze ANALYZER ENTRY NIL NIL (FUNCTION (LAMBDA (ANALYZER STREAM START LENGTH VAL ) (APPLY* ADDASSOCFN WORDNERD HEADER (OR VAL (STREAM.FETCHSTRING STREAM START LENGTH NIL T))) NIL]) (WordNerd.AddDictionary [LAMBDA (WORDNERD DICTIONARY ANALYZER) (* ; "Edited 14-Sep-88 10:11 by jtm:") [COND ((NULL ANALYZER) (SETQ ANALYZER (InvertedDict.Prop WORDNERD 'ANALYZER] (Dict.MapEntries DICTIONARY (COND [(EQ (FUNCTION SimpleDict.MapEntries) (fetch (Dict mapFn) of DICTIONARY)) (* this is a hack until we fix  SimpleDict.MapEntries) (FUNCTION (LAMBDA (DICT HEADER ENTRY) (WordNerd.AddEntry WORDNERD (CONCATLIST HEADER) ENTRY ANALYZER] (T (FUNCTION (LAMBDA (DICT HEADER ENTRY) (WordNerd.AddEntry WORDNERD HEADER ENTRY ANALYZER]) (WordNerd.AddStopWords [LAMBDA (WORDNERD STOPWORDS) (* ; "Edited 15-Sep-88 17:12 by jtm:") (for WORD inside STOPWORDS do (WordNerd.AddAssociation WORDNERD :STOPWORD WORD)) WORDNERD]) (WordNerd.SortByFrequency [LAMBDA (WORDNERD MINCOUNT) (* ; "Edited 25-Oct-88 13:34 by jtm:") (LET (ENTRIES) [WordNerd.MapKeys WORDNERD (FUNCTION (LAMBDA (NERD KEYWORD KEYID ASSOCS) (DECLARE (SPECVARS MINCOUNT)) (LET (FREQ) [SETQ FREQ (COND ((LISTP ASSOCS) (LENGTH ASSOCS] (COND ((AND FREQ (OR (NULL MINCOUNT) (ILEQ MINCOUNT FREQ))) (push ENTRIES (LIST FREQ KEYWORD] [SETQ ENTRIES (SORT ENTRIES (FUNCTION (LAMBDA (A B) (IGREATERP (CAR A) (CAR B] ENTRIES]) ) (DEFINEQ (WordNerd.DefaultVennSearch [LAMBDA (wordNerd synonymClasses minKeywords minWord maxWord dontConvert) (* ; "Edited 17-Nov-88 17:14 by jtm:") (LET (analyzer keys venn first keySet keySetWeight keySetInfo notFound priorSet headerIndex keyIndex indexFile GetKeyIDFn GetHeaderFn GetBufferFn GetEntryFn ExpandKeyPatternFn (n 0)) (* ;; "initialize the word nerd") [COND ((AND wordNerd (LITATOM wordNerd)) (SETQ wordNerd (InvertedDictFromName wordNerd] [COND ((NULL wordNerd) (SETQ wordNerd (CAR InvertedDict.List] (WordNerd.Open wordNerd) (* ;; "canonicalize the user input") [COND ((STRINGP synonymClasses) (SETQ synonymClasses (WORDNERD.PARSEINPUT wordNerd synonymClasses] (* ;; "cache the object-oriented fields and functions in local variables.") (SETQ headerIndex (fetch (INVERTEDDICT HEADERINDEX) of wordNerd)) (SETQ keyIndex (fetch (INVERTEDDICT KEYINDEX) of wordNerd)) (SETQ indexFile (fetch (INVERTEDDICT INDEXFILE) of wordNerd)) (SETQ GetKeyIDFn (InvertedDict.Prop wordNerd 'GETKEYIDFN)) (SETQ GetEntryFn (InvertedDict.Prop wordNerd 'GETENTRYFN)) (SETQ GetHeaderFn (InvertedDict.Prop wordNerd 'GETHEADERFN)) (SETQ GetBufferFn (InvertedDict.Prop wordNerd 'GETBUFFERFN)) (SETQ ExpandKeyPatternFn (InvertedDict.Prop wordNerd 'EXPANDKEYPATTERNFN)) (* ;;  "synonymClasses is a list of lists of words, where each sub-list represents a class of synonyms") [for synonymClass wordList inside synonymClasses do (SETQ wordList NIL) (* ;; "build wordlist, a concatenation of the entries in the synonym class") [for pattern inside synonymClass do (for word word# entry inside (OR (AND ExpandKeyPatternFn (STRPOS '* pattern) (APPLY* ExpandKeyPatternFn wordNerd pattern)) pattern) do (COND [[SETQ word# (COND ((OR (NUMBERP word) (NULL GetKeyIDFn)) word) (T (APPLY* GetKeyIDFn wordNerd word keyIndex ] (SETQ entry (APPLY* GetEntryFn wordNerd word# indexFile)) (COND ((OR (EQ entry :STOPWORD) (EQ -1 (CAR entry))) (SETQ entry NIL))) (SETQ wordList (COND ((LISTP synonymClass) (* ;  "NCONC would destructively modify the wordNerd's entry.") (APPEND entry wordList)) (T entry] (T (push notFound (create WNKEYINFO WNKEY _ (LIST (CONCAT word "?"] (SETQ wordList (SORT wordList (FUNCTION ILESSP))) (* ;  "SORT may modify the entry, but shouldn't be a problem.") (* ;; "add the word list to the list of key associations") (AND wordList (push keys (create WNKEYINFO WNKEY _ (COND [(LISTP synonymClass) (COND ((CDR synonymClass) (CONCAT (CAR synonymClass) "+")) (T (CAR synonymClass] (T synonymClass)) WNKEYWEIGHT _ (IQUOTIENT 10000 (LENGTH wordList )) WNKEYDATA _ wordList] (SETQ keys (DREVERSE keys)) (* ;; "determine the minimum number of keys for a word to be included in the result") (OR minKeywords (SETQ minKeywords 2)) (COND ((ILEQ minKeywords 0) (SETQ minKeywords (IPLUS (LENGTH keys) minKeywords))) ((ILESSP (LENGTH keys) minKeywords) (SETQ minKeywords 1))) (* ;; "set up minWord and maxWord") (COND ((NULL minWord) (SETQ minWord 0)) ((EQ minWord 1) (* ;  "minWord = 0 allows notFound to be returned.") (SETQ minWord 0))) (COND ((OR (NULL maxWord) (EQ maxWord 0)) (SETQ maxWord 65000))) (* ;; "now skim the classes off of the top of the lists in alphabetical order, putting them in a Venn diagram") [do (* ;  "find the lowest numbered entry in the word lists") (SETQ first NIL) [for keyInfo myFirst in keys do (SETQ myFirst (CAR (fetch WNKEYDATA of keyInfo ))) (COND ((OR (NULL first) (AND myFirst (ILESSP myFirst first ))) (SETQ first myFirst] (COND ((NULL first) (* ; "all of the word lists are empty") (RETURN)) (T (* ;; "make a list of all of the classes that have 'first' in their word list. Remove 'first' from the word lists") (SETQ keySet NIL) (SETQ keySetWeight 0) [for keyInfo myFirst myKey in keys do (SETQ myKey (fetch WNKEY of keyInfo)) (SETQ myFirst (CAR (fetch WNKEYDATA of keyInfo))) (COND ((AND myFirst (EQP first myFirst)) (COND ((NULL keySet) (push keySet myKey)) (T (NCONC1 keySet myKey))) (add keySetWeight (fetch WNKEYWEIGHT of keyInfo)) (* ;; "eliminate multiple entries") (while (AND (SETQ myFirst (CAR (fetch WNKEYDATA of keyInfo))) (EQP myFirst first)) do (pop (fetch WNKEYDATA of keyInfo] (* ;  "put 'first' in the appropriate venn diagram entry") (COND ((IGEQ (LENGTH keySet) minKeywords) (* ;  "skip single classes if we were given multiple key classes") (COND ([NOT (SETQ keySetInfo (for set in venn thereis (EQUAL keySet (fetch WNKEY of set] (SETQ keySetInfo (create WNKEYINFO WNKEY _ keySet WNKEYWEIGHT _ keySetWeight)) (push venn keySetInfo))) (push (fetch WNKEYDATA of keySetInfo) first] (* ;;; "sort the venn diagram so that the classes that are in the most overlaps come first") [SORT venn (FUNCTION (LAMBDA (A B) (LET [(ALEN (LENGTH (fetch WNKEY of A))) (BLEN (LENGTH (fetch WNKEY of B] (COND ((EQ ALEN BLEN) (IGREATERP (fetch WNKEYWEIGHT of A) (fetch WNKEYWEIGHT of B))) (T (IGREATERP ALEN BLEN] (* ;;; "extract words in the range '[minWord..maxWord].' Convert numbers into lemmas") (SETQ priorSet NIL) (SETQ venn (NCONC notFound venn)) [for tail keySet keySetLength overflow i (buffer _ (AND GetBufferFn (APPLY* GetBufferFn wordNerd headerIndex))) on venn do (SETQ overflow NIL) (SETQ keySet (CAR tail)) (SETQ keySetLength (LENGTH (fetch WNKEYDATA of keySet))) (COND [(IGEQ n maxWord) (* ;  "set is above maximum, remove from venn diagram") (COND [(EQ minWord 0) (replace WNKEYDATA of keySet with (LIST (CONCAT keySetLength " entries."] (T (COND (priorSet (RPLACD priorSet (CDR tail))) (T (SETQ venn (CDR tail] [(ILESSP (IPLUS n keySetLength) minWord) (* ;  "set is below minimum, remove from venn diagram") (add n keySetLength) (COND ((NULL (CDR tail)) (* ;; "if all of the sets are below minimum, leave the header for the last one so that the user knows what is going on.") (push (fetch WNKEY of keySet) ". . .") (replace WNKEYDATA of keySet with (LIST "no more words." ))) (T (SETQ venn (CDR tail] (T (* ;  "we want to include at least part of this set") (SETQ priorSet tail) (replace WNKEYDATA of keySet with (DREVERSE (fetch WNKEYDATA of keySet))) [for keyTail on (fetch WNKEYDATA of keySet) do (add n 1) (COND ((AND (IGEQ n minWord) (NOT dontConvert)) (* ; "convert the number into a word") (RPLACA keyTail (CONCAT (APPLY* GetHeaderFn wordNerd (CAR keyTail) headerIndex buffer))) (* ;  "CONCAT will copy the string out of the buffer.") (BLOCK))) (COND ((EQ n minWord) (* ;  "remove the numbers before this one") (replace WNKEYDATA of keySet with keyTail) (push (fetch WNKEY of keySet) ". . .")) ((AND (IGEQ n maxWord) (CDR keyTail)) (* ;  "remove the numbers after this one") (* ;  "add overflow (LENGTH (CDR lemma))") (SETQ overflow (LENGTH (CDR keyTail))) (RPLACD keyTail NIL) (RETURN] (replace WNKEYDATA of keySet with (SORT (fetch WNKEYDATA of keySet) (FUNCTION UALPHORDER))) [COND (overflow (NCONC1 (fetch WNKEYDATA of keySet) (CONCAT ". . .+" overflow " more."] (* ;; "finally, remove the WNKEYSETWEIGHT field") (RPLACD keySet (CDDR keySet] (* ;; "COND ((NEQ overflow 0) (* append the overflow information) (NCONC1 (CADAR (LAST venn)) (CONCAT '. . .+' overflow ' more.')))") venn]) ) (DEFINEQ (WordNerd.DefaultWeightedSearch [LAMBDA (wordNerd weightedKeys minWord maxWord useFreqWeights) (* ; "Edited 18-Nov-88 10:09 by jtm:") (* ;;; "performs a weighted search of wordNerd using the keys and weights in weightedKeys. minWord and maxWord gives the range of the result to be returned. useFreqWeights indicates that frequency should be taken into account. weightedKeys is either a string of keys from the user or a list of keys or a list of key-weight pairs (CAR, CADR).") (LET (headerIndex keyIndex indexFile array arrayMax entryCount priorityList weights minimumWeight shiftFactor maxKeys wordList keysLeft GetKeyFn GetEntryFn GetFreqFn GetHeaderFn GetBufferFn MaxHeaderFn) (* ;;; "the user may specify a database by name.") [COND ((AND wordNerd (LITATOM wordNerd)) (SETQ wordNerd (InvertedDictFromName wordNerd] (* ;;; "The INVERTEDDICT data structure simulates an object-oriented approach. Fetch all of the values once at the beginning to save the cost of multiple fetches.") (WordNerd.Open wordNerd) (OR minWord (SETQ minWord 0)) (OR maxWord (SETQ maxWord 50)) (SETQ minimumWeight (OR (InvertedDict.Prop wordNerd 'MINIMUMWEIGHT) 0)) (SETQ shiftFactor (OR (InvertedDict.Prop wordNerd 'SHIFTFACTOR) 0)) (SETQ maxKeys (OR (InvertedDict.Prop wordNerd 'MAXWEIGHTEDKEYS) 15)) (SETQ headerIndex (fetch (INVERTEDDICT HEADERINDEX) of wordNerd)) (SETQ keyIndex (fetch (INVERTEDDICT KEYINDEX) of wordNerd)) (SETQ indexFile (fetch (INVERTEDDICT INDEXFILE) of wordNerd)) (SETQ GetKeyFn (InvertedDict.Prop wordNerd 'GETKEYFN)) (SETQ GetEntryFn (InvertedDict.Prop wordNerd 'GETENTRYFN)) (SETQ GetFreqFn (InvertedDict.Prop wordNerd 'GETFREQFN)) (SETQ MaxHeaderFn (InvertedDict.Prop wordNerd 'MAXHEADERIDFN)) (SETQ GetHeaderFn (InvertedDict.Prop wordNerd 'GETHEADERFN)) (SETQ GetBufferFn (InvertedDict.Prop wordNerd 'GETBUFFERFN)) (SETQ entryCount (OR (APPLY* MaxHeaderFn wordNerd headerIndex) 10000)) (SETQ arrayMax (ADD1 (LRSH entryCount 8))) (* ;;; "Cache the array scratch pad on invertedDict.") (SETQ array (InvertedDict.Prop wordNerd 'Array)) (COND ((AND array (IGREATERP arrayMax (ARRAYSIZE array))) (* ;  "the data has grown since we last saw it.") (SETQ array NIL))) [COND ((NULL array) (InvertedDict.Prop wordNerd 'Array (SETQ array (ARRAY (ADD1 arrayMax) NIL NIL 0] (for I from 0 to arrayMax do (SETA array I NIL)) (* ;;; "parse the user's input.") (AND (STRINGP weightedKeys) (SETQ weightedKeys (WORDNERD.PARSEINPUT wordNerd weightedKeys T))) (* ;;; "process the keys.") [for word word# weight length freq factor inside weightedKeys do (SETQ wordList NIL) (COND ((LISTP word) (SETQ word (CAR word)) (SETQ factor (CADR word))) (T (SETQ factor 1))) (COND ([SETQ word# (COND ((OR (NULL GetKeyFn) (NUMBERP word)) word) (T (APPLY* GetKeyFn wordNerd word keyIndex] [SETQ freq (COND ((LISTP word#) (LENGTH word#)) ((NULL GetFreqFn) (SETQ word# (APPLY* GetEntryFn wordNerd word# indexFile)) (LENGTH word#)) (T (APPLY* GetFreqFn wordNerd word# indexFile] (COND ((NEQ freq 0) (SETQ weight (COND [useFreqWeights (ITIMES factor (IMAX 1 (LRSH (IQUOTIENT entryCount freq) shiftFactor] (T factor))) (COND ((IGEQ (ABS weight) minimumWeight) (push weights (LIST word# weight word wordList] (* ;;; "sort weights from greatest to least. We may not have to process all of the keys, so do the most significant ones first.") [SETQ weights (SORT weights (FUNCTION (LAMBDA (A B) (IGREATERP (CADR A) (CADR B] [SETQ keysLeft (COND (useFreqWeights maxKeys) (T (LENGTH weightedKeys] [for tail weightedKey priorTail word weight singleWeight ignoreSingletons (%#entries _ 0) on weights do (BLOCK) (SETQ weightedKey (CAR tail)) (SETQ weight (CADR weightedKey)) (SETQ word (CADDR weightedKey)) [SETQ wordList (COND ((LISTP (CAR weightedKey)) (CAR weightedKey)) (T (APPLY* GetEntryFn wordNerd (CAR weightedKey) indexFile] (RPLACA weightedKey word) (RPLACD (CDR weightedKey) NIL) (COND [(CDR wordList) (* ;  "ignore lists with less than 2 and more than 2000 entries.") (add keysLeft -1) (SETQ priorTail tail) [COND ((AND singleWeight (NOT ignoreSingletons)) (SETQ ignoreSingletons (IGEQ singleWeight (for remaining in tail as I from 1 to keysLeft sum (CADR remaining] (add %#entries (AddWeightsToArray array wordList weight word ignoreSingletons)) [COND ((AND maxWord (IGEQ %#entries maxWord)) (* ;  "keep track of the maximum weight of any key that could satisfy the query all by itself.") (COND ((OR (NULL singleWeight) (IGREATERP weight singleWeight)) (SETQ singleWeight weight] (COND ((EQ keysLeft 0) (RPLACD tail NIL) (RETURN] (priorTail (RPLACD priorTail (CDR tail))) (T (SETQ weights (CDR tail] (SETQ priorityList (CDR (FindTopElements array maxWord arrayMax))) (AND minWord (IGREATERP minWord 0) (SETQ priorityList (NTH priorityList minWord))) [SETQ priorityList (for lemma (buffer _ (AND GetBufferFn (APPLY* GetBufferFn wordNerd headerIndex))) in priorityList collect (* ;  "CONCAT will copy the string out of the buffer.") (CONS (CONCAT (APPLY* GetHeaderFn wordNerd (CADR lemma) headerIndex buffer)) (LIST (CAR lemma) (DREVERSE (CDDDR lemma] (LIST weights priorityList]) (AddWeightsToArray [LAMBDA (array wordList weight word ignoreSingletons) (* jtm%: "17-Nov-87 14:49") (for header index val elt (%#newEntries _ 0) in wordList do (SETQ index (LRSH header 8)) (SETQ elt (ELT array index)) (COND ((AND [NULL (SETQ val (for I in elt thereis (EQP header (CAR I] (NOT ignoreSingletons)) (SETQ val (LIST header 0)) (COND (elt (ATTACH val elt)) (T (push (ELT array index) val))) (add %#newEntries 1))) (COND (val (push (CDDR val) word) (add (CADR val) weight))) finally (RETURN %#newEntries]) (FindTopElements [LAMBDA (array maxWord arrayMax) (* jtm%: " 2-Aug-88 10:37") (LET (priorityList) (for I from 0 to arrayMax do (for arrayVal in (ELT array I) do (* RPLACA (CDR arrayVal)  (ITIMES (CADR arrayVal)  (IMIN 5 (LENGTH (CDDR arrayVal))))) (SETQ priorityList (  AddToPriorityList priorityList arrayVal (CADR arrayVal) maxWord))) (SETA array I NIL)) priorityList]) (AddToPriorityList [LAMBDA (priorityList I VAL MAX) (* jtm%: " 6-Nov-87 15:12") (LET (inserted) [COND [(NULL priorityList) (* include a count at the beginning.) (SETQ priorityList (CONS (CONS 0 1) (LIST (CONS VAL I] ((AND MAX (ILEQ MAX (CDAR priorityList)) (ILEQ VAL (CAAR priorityList))) (* its off the bottom) NIL) (T (for tail nextToLast last on priorityList as N from 0 do (COND ((OR (NULL (CDR tail)) (IGREATERP VAL (CAADR tail))) (COND ((EQ N MAX) NIL) ((AND [SETQ nextToLast (AND MAX (NTH tail (IDIFFERENCE MAX N] (SETQ last (CDR nextToLast))) (* re-use the nextToLast cell.) (RPLACA (CAR priorityList) (CAAR nextToLast)) (RPLACD nextToLast NIL) (* remove last from the list.) (RPLNODE (CAR last) VAL I) (* update its values.) (RPLACD last (CDR tail)) (* splice it into the list.) (RPLACD tail last)) (T (* (AND MAX (RPLACD  (NTH tail (IDIFFERENCE  (ADD1 MAX) N)) NIL))) (RPLACD tail (CONS (CONS VAL I) (CDR tail))) (add (CDAR priorityList) 1))) (RETURN] priorityList]) ) (DEFINEQ (WordNerd.DefaultRelevanceSearch [LAMBDA (wordNerd posWords negKeys minWord maxWord) (* jtm%: " 2-Aug-88 10:46") (* * extract keywords from the sample words given  (posWords) and do a weighted search.) (LET (posKeys dictionary analyzer GetEntryTokensFn) [COND ((AND wordNerd (LITATOM wordNerd)) (SETQ wordNerd (InvertedDictFromName wordNerd] [COND ((NULL wordNerd) (SETQ wordNerd (CAR InvertedDict.List] [COND ((STRINGP posWords) (SETQ posWords (PARSEBYCOLONS posWords] (SETQ analyzer (InvertedDict.Prop wordNerd 'ANALYZER)) (SETQ dictionary (InvertedDict.Prop wordNerd 'DICTIONARY)) (SETQ GetEntryTokensFn (InvertedDict.Prop wordNerd 'GETENTRYTOKENSFN)) (* * GetEntryTokensFn is in the wordNerd rather than its dictionary because  there may be more than one wordNerd for a particular dictionary  (as in the WordNerd and EtymologyNerd.)) (SETQ posKeys (MergeKeywords (for word in posWords collect (APPLY* GetEntryTokensFn wordNerd word dictionary analyzer)) negKeys)) (WordNerd.WeightedSearch wordNerd posKeys minWord maxWord T]) (MergeKeywords [LAMBDA (posWordLists negKeywords minimumMatches negWordLists) (* jtm%: " 1-Aug-88 15:11") (LET (intersection minimum n m order list) (OR minimumMatches (SETQ minimumMatches 2)) [while posWordLists do (SETQ n 0) (SETQ minimum NIL) [for tail on posWordLists when (CAR tail) do (COND ((OR (NULL minimum) (ALPHORDER (CAAR tail) minimum)) (SETQ minimum (CAAR tail] (OR minimum (RETURN)) [for tail on posWordLists when (CAR tail) do (while (EQUAL minimum (CAAR tail)) do (add n 1) (pop (CAR tail] (COND ([AND (NOT (MEMBER minimum negKeywords)) (OR (IGEQ n minimumMatches) (NULL (CDR posWordLists] (push intersection (LIST minimum n] intersection]) ) (DEFINEQ (WORDNERD.PARSEINPUT [LAMBDA (INVERTEDDICT STRING IGNOREPARENS) (* jtm%: "12-Aug-88 16:45") (LET (ANALYZER KEYS SUBKEYS ENDPOS SUBSTRING (STARTPOS 1) (NCHARS (NCHARS STRING))) (SETQ ANALYZER (InvertedDict.Prop INVERTEDDICT 'ANALYZER)) (COND ((NULL ANALYZER) (SETQ ANALYZER (create Morphalyzer)) (InvertedDict.Prop INVERTEDDICT 'ANALYZER ANALYZER))) [while STARTPOS do (OR IGNOREPARENS (SETQ ENDPOS (STRPOS "(" STRING STARTPOS))) [SETQ SUBSTRING (SUBSTRING STRING STARTPOS (SUB1 (OR ENDPOS (ADD1 NCHARS] [AND SUBSTRING (Analyzer.Analyze ANALYZER SUBSTRING NIL NIL (FUNCTION (LAMBDA (ANALYZER STREAM START LENGTH ENTRY) (push KEYS (OR ENTRY (STREAM.FETCHSTRING STREAM START LENGTH NIL T))) NIL] (COND [ENDPOS (SETQ STARTPOS (ADD1 ENDPOS)) (SETQ ENDPOS (STRPOS ")" STRING STARTPOS)) (SETQ SUBKEYS NIL) [Analyzer.Analyze ANALYZER [SUBSTRING STRING STARTPOS (SUB1 (OR ENDPOS (ADD1 NCHARS] NIL NIL (FUNCTION (LAMBDA (ANALYZER STREAM START LENGTH ENTRY) (push SUBKEYS (OR ENTRY (STREAM.FETCHSTRING STREAM START LENGTH NIL T))) NIL] (push KEYS (DREVERSE SUBKEYS)) (SETQ STARTPOS (ADD1 (OR ENDPOS NCHARS] (T (SETQ STARTPOS NIL] (SETQ KEYS (DREVERSE KEYS]) ) (DECLARE%: EVAL@COMPILE (RECORD WNKEYINFO (WNKEY WNKEYWEIGHT WNKEYDATA)) ) (* * SimpleNerd is an in-core version of the WordNerd.) (DEFINEQ (SimpleNerd.Create [LAMBDA (NAME DICTIONARY ANALYZER) (* ; "Edited 25-Oct-88 12:01 by jtm:") (LET (SIMPLENERD) (SETQ SIMPLENERD (create INVERTEDDICT INVERTEDDICTNAME _ NAME)) (AND DICTIONARY (InvertedDict.Prop SIMPLENERD 'DICTIONARY DICTIONARY)) (InvertedDict.Prop SIMPLENERD 'ANALYZER (OR ANALYZER (SimpleAnalyzer.Create NAME))) (InvertedDict.Prop SIMPLENERD 'ADDASSOCIATIONFN (FUNCTION SimpleNerd.AddAssociation)) (InvertedDict.Prop SIMPLENERD 'GETENTRYFN (FUNCTION SimpleNerd.GetEntry)) (InvertedDict.Prop SIMPLENERD 'MAXHEADERIDFN (FUNCTION SimpleNerd.MaxEntry)) (InvertedDict.Prop SIMPLENERD 'GETHEADERFN (FUNCTION SimpleNerd.GetHeader)) (InvertedDict.Prop SIMPLENERD 'GETENTRYTOKENSFN (FUNCTION SimpleNerd.ParseDictEntry)) (InvertedDict.Prop SIMPLENERD 'MAPKEYSFN (FUNCTION SimpleNerd.MapKeys)) (InvertedDict.Prop SIMPLENERD 'VENNSEARCHFN (FUNCTION WordNerd.DefaultVennSearch)) (InvertedDict.Prop SIMPLENERD 'WEIGHTEDSEARCHFN (FUNCTION WordNerd.DefaultWeightedSearch)) (InvertedDict.Prop SIMPLENERD 'RELEVANCESEARCHFN (FUNCTION WordNerd.DefaultRelevanceSearch)) (InvertedDict.Establish SIMPLENERD) SIMPLENERD]) (SimpleNerd.AddAssociation [LAMBDA (WORDNERD HEADER KEY) (* ; "Edited 21-Sep-88 14:37 by jtm:") (* * adds KEY to WORDNERD under HEADER.) (LET (LASTENTRY HEADERINDEX INDEXFILE HEADERSIZE ENTRYID ASSOCS) (* * initialize local variables and data structures.) (COND ((NULL (SETQ HEADERINDEX (fetch (INVERTEDDICT HEADERINDEX) of WORDNERD))) (SETQ HEADERINDEX (ARRAY 100)) (replace (INVERTEDDICT HEADERINDEX) of WORDNERD with HEADERINDEX))) (COND ((NULL (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of WORDNERD))) (SETQ INDEXFILE (SimpleDict.New (fetch (INVERTEDDICT INVERTEDDICTNAME) of WORDNERD ))) (replace (INVERTEDDICT INDEXFILE) of WORDNERD with INDEXFILE))) [COND ([NULL (SETQ LASTENTRY (InvertedDict.Prop WORDNERD 'LASTENTRY] (SETQ LASTENTRY (CONS NIL 0] (* * map HEADER to a unique ID using EQUAL.  We want ID numbers to make it easier to convert to external indices.) (COND ((EQ HEADER :STOPWORD) (* do nothing) NIL) ((EQUAL HEADER (CAR LASTENTRY)) (* this is optimized for multiple  additions to the same entry.) (SETQ ENTRYID (CDR LASTENTRY))) ([SETQ ENTRYID (for I from 1 to (SETQ HEADERSIZE (ARRAYSIZE HEADERINDEX)) thereis (EQUAL HEADER (ELT HEADERINDEX I] (* look for an existing entry.) (InvertedDict.Prop WORDNERD 'LASTENTRY (CONS HEADER ENTRYID))) (T (* add an HEADER to HEADERINDEX) (SETQ ENTRYID (ADD1 (OR (InvertedDict.Prop WORDNERD 'LASTINDEX) 0))) [COND ((IGREATERP ENTRYID HEADERSIZE) (LET (NEWHEADERINDEX) (* get a bigger array.) (SETQ NEWHEADERINDEX (ARRAY (ITIMES HEADERSIZE 2))) (for I from 1 to HEADERSIZE do (SETA NEWHEADERINDEX I (ELT HEADERINDEX I))) (replace (INVERTEDDICT HEADERINDEX) of WORDNERD with NEWHEADERINDEX) (SETQ HEADERINDEX NEWHEADERINDEX] (SETA HEADERINDEX ENTRYID HEADER) (InvertedDict.Prop WORDNERD 'LASTINDEX ENTRYID))) (* * push the HEADER onto INDEXFILE) (* used to  #.(SEDIT::MAKE-BROKEN-ATOM "be:")  (SimpleDict.PushEntry INDEXFILE KEY  ENTRYID (QUOTE NEWTOP))) (COND ((EQ HEADER :STOPWORD) (* mark as stop word) (SimpleDict.PutEntry INDEXFILE KEY :STOPWORD)) [(SETQ ASSOCS (SimpleDict.Lookup INDEXFILE KEY)) (COND ((EQ ASSOCS :STOPWORD) (* don't do anything) NIL) ((NEQ ENTRYID (CAR ASSOCS)) (ATTACH ENTRYID ASSOCS] (T (SimpleDict.PutEntry INDEXFILE KEY (LIST ENTRYID]) (SimpleNerd.MapKeys [LAMBDA (NERD MAPFN) (* ; "Edited 25-Oct-88 11:57 by jtm:") (* ;; "Map through all of the keys in the NERD") (Dict.MapEntries (fetch (INVERTEDDICT INDEXFILE) of NERD) (FUNCTION (LAMBDA (DICT PATH ENTRY) (DECLARE (SPECVARS MAPFN NERD)) (LET (HEADER) (SETQ HEADER (CONCATLIST PATH)) (* ; "PATH is a list of characters") (APPLY* MAPFN NERD HEADER HEADER ENTRY)) (* ;  "KEY and KEYID are the same. ENTRY may be :STOPWORD") ]) (SimpleNerd.GetEntry [LAMBDA (WORDNERD KEYID INDEXFILE) (* jtm%: " 2-Aug-88 10:13") (SimpleDict.Lookup INDEXFILE KEYID]) (SimpleNerd.MaxEntry [LAMBDA (WORDNERD HEADERINDEX) (* jtm%: " 1-Aug-88 16:44") (InvertedDict.Prop WORDNERD 'LASTINDEX]) (SimpleNerd.GetHeader [LAMBDA (WORDNERD HEADERID HEADERINDEX BUFFER) (* ; "Edited 11-Nov-88 14:30 by jtm:") (COND (HEADERINDEX (ELT HEADERINDEX HEADERID)) (T HEADERID]) (SimpleNerd.ParseDictEntry [LAMBDA (WORDNERD WORD DICTIONARY ANALYZER) (* ; "Edited 24-Oct-88 14:19 by jtm:") (* * return the list of tokens in the definition of WORD.) (LET (DICTENTRY TOKENS HARRAY) [OR DICTIONARY (SETQ DICTIONARY (InvertedDict.Prop WORDNERD 'DICTIONARY] [OR ANALYZER (SETQ ANALYZER (InvertedDict.Prop WORDNERD 'ANALYZER] (SETQ DICTENTRY (Dict.GetEntry DICTIONARY WORD)) [COND (DICTENTRY (SETQ HARRAY (HASHARRAY 100 NIL 'STRINGHASHBITS 'STREQUAL)) (Analyzer.Analyze ANALYZER DICTENTRY NIL NIL (FUNCTION (LAMBDA (ANALYZER STREAM START LENGTH ENTRY) (LET (TOKEN) (SETQ TOKEN (OR ENTRY (STREAM.FETCHSTRING STREAM START LENGTH NIL T))) (PUTHASH TOKEN T HARRAY) (* ;  "return NIL to keep iteration going") NIL] (COND ((STREAMP DICTENTRY) (CLOSEF DICTENTRY))) [MAPHASH HARRAY (FUNCTION (LAMBDA (VAL KEY) (push TOKENS KEY] TOKENS]) (SimpleNerd.Test [LAMBDA NIL (* jtm%: " 2-Aug-88 14:54") (LET (simpleNerd simpleDict analyzer GetEntryTokensFn) (SETQ simpleDict (SimpleDict.New 'TEST)) (Dict.PutEntry simpleDict "Paine" "Now is the time for all good men to come to the aid of their country.") (Dict.PutEntry simpleDict "Jefferson" "Now is the time for good men to help out.") (Dict.PutEntry simpleDict "King George" "Now wait a minute!") (Dict.PutEntry simpleDict "Kennedy" "Ask not what your country can do for you.") (replace (Dict printEntryFn) of simpleDict with (FUNCTION DictTool.PrintDefinition)) (Dict.Establish simpleDict) (SETQ simpleNerd (SimpleNerd.Create 'TEST)) (InvertedDict.Prop simpleNerd 'DICTIONARY simpleDict) (InvertedDict.Prop simpleNerd 'MINIMUMWEIGHT 0) (SETQ analyzer (InvertedDict.Prop simpleNerd 'ANALYZER)) (SETQ GetEntryTokensFn (InvertedDict.Prop simpleNerd 'GETENTRYTOKENSFN)) [Dict.MapEntries simpleDict (FUNCTION (LAMBDA (dict path value) (LET (string tokens) (SETQ string (CONCATLIST path)) (SETQ tokens (APPLY* GetEntryTokensFn simpleNerd string simpleDict analyzer)) (for token in tokens do (SimpleNerd.AddEntry simpleNerd string token] (SETQ TESTNERD simpleNerd]) ) (* * HashfileNerd stores its data structures in an InterLisp hashfile.) (DEFINEQ (HashfileNerd.Create [LAMBDA (NAME FILENAME DICTIONARY ANALYZER) (* ; "Edited 17-Nov-88 17:03 by jtm:") (LET (NERD) (SETQ NERD (create INVERTEDDICT INVERTEDDICTNAME _ NAME HEADERINDEX _ (ARRAY 100))) (* ;; "HashfileNerd.AddAssociation used to create the header array on demand, but now I want a NIL header index to indicate the identity mapping, so the array is created here and removed if the user wants an identity mapping.") (InvertedDict.Prop NERD 'FILENAME FILENAME) (InvertedDict.Prop NERD 'ANALYZER (OR ANALYZER (SimpleAnalyzer.Create NAME))) (COND (DICTIONARY (InvertedDict.Prop NERD 'DICTIONARY DICTIONARY))) (InvertedDict.Prop NERD 'OPENFN (FUNCTION HashfileNerd.Open)) (InvertedDict.Prop NERD 'CLOSEFN (FUNCTION HashfileNerd.Close)) (InvertedDict.Prop NERD 'RELEVANCESEARCHFN (FUNCTION WordNerd.DefaultRelevanceSearch)) (InvertedDict.Prop NERD 'WEIGHTEDSEARCHFN (FUNCTION WordNerd.DefaultWeightedSearch)) (InvertedDict.Prop NERD 'VENNSEARCHFN (FUNCTION WordNerd.DefaultVennSearch)) (InvertedDict.Prop NERD 'ADDASSOCIATIONFN (FUNCTION HashfileNerd.AddAssociation)) (InvertedDict.Prop NERD 'GETENTRYFN (FUNCTION HashfileNerd.GetEntry)) (InvertedDict.Prop NERD 'MAXHEADERIDFN (FUNCTION SimpleNerd.MaxEntry)) (InvertedDict.Prop NERD 'GETHEADERFN (FUNCTION SimpleNerd.GetHeader)) (InvertedDict.Prop NERD 'MAPKEYSFN (FUNCTION HashfileNerd.MapKeys)) (InvertedDict.Prop NERD 'EXPANDKEYPATTERNFN (FUNCTION HashfileNerd.ExpandKeyPattern)) (InvertedDict.Prop NERD 'GETENTRYTOKENSFN (FUNCTION SimpleNerd.ParseDictEntry)) (InvertedDict.Establish NERD) NERD]) (HashfileNerd.Test [LAMBDA (FILEPATTERN FILENAME) (* ; "Edited 26-Sep-88 13:30 by jtm:") (LET (NERD DICT) (SETQ DICT (FileDict.Create 'TEST)) (FileDict.AddFiles DICT FILEPATTERN) (SETQ NERD (HashfileNerd.Create 'TEST NIL DICT)) (WordNerd.AddDictionary NERD DICT) (HashfileNerd.Write NERD FILENAME) (HashfileNerd.Close NERD) (SETQ NERD (HashfileNerd.Create 'TEST NIL DICT)) (HashfileNerd.Open NERD FILENAME) NERD]) (HashfileNerd.Open [LAMBDA (WORDNERD FILENAME) (* ; "Edited 11-Nov-88 11:34 by jtm:") (* ;;; "Reads a hashfilenerd out of the hashfile stored in FILENAME") (LET (HASHFILE HEADERLIST HEADERINDEX DICTNAME ANALYZERNAME) (COND ([AND (NULL (fetch (INVERTEDDICT INDEXFILE) of WORDNERD)) (OR FILENAME (SETQ FILENAME (InvertedDict.Prop WORDNERD 'FILENAME] (SETQ HASHFILE (OPENHASHFILE FILENAME)) (* ;; "read out the name") (replace (INVERTEDDICT INVERTEDDICTNAME) of WORDNERD with (OR (GETHASHFILE '*NAME* HASHFILE) (fetch (INVERTEDDICT INVERTEDDICTNAME) of WORDNERD))) (* ;; "read out the HEADERINDEX") [COND ((SETQ HEADERLIST (GETHASHFILE '*HEADERINDEX* HASHFILE)) [SETQ HEADERINDEX (ARRAY (IPLUS 10 (LENGTH HEADERLIST] (for I in HEADERLIST do (SETA HEADERINDEX (CAR I) (CADR I] (* ;; "read out simple properties") (for PROP in (GETHASHFILE '*PROPS* HASHFILE) do (InvertedDict.Prop WORDNERD (CAR PROP) (CDR PROP))) (replace (INVERTEDDICT HEADERINDEX) of WORDNERD with HEADERINDEX) (* ;; "check the dictionary name") (COND ([AND (SETQ DICTNAME (GETHASHFILE '*DICTIONARY* HASHFILE)) (NEQ DICTNAME (Dict.Name (InvertedDict.Prop WORDNERD 'DICTIONARY] (ERROR "WORDNERD has wrong dictionary for this hash file."))) (* ;; " check the analyzer name ") (COND ([AND (SETQ ANALYZERNAME (GETHASHFILE '*ANALYZER* HASHFILE)) (NEQ ANALYZERNAME (Analyzer.Name (InvertedDict.Prop WORDNERD 'ANALYZER] (ERROR "WORDNERD has wrong analyzer for this hash file."))) (* ;; "finally replace INDEXFILE with HASHFILE atomically") (replace (INVERTEDDICT INDEXFILE) of WORDNERD with HASHFILE]) (HashfileNerd.Close [LAMBDA (WORDNERD) (* ; "Edited 15-Sep-88 10:04 by jtm:") (LET (INDEXFILE) (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of WORDNERD)) [COND ((OR (HARRAYP INDEXFILE) (LISTP INDEXFILE)) (HashfileNerd.Write WORDNERD) (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of WORDNERD] (COND ((HASHFILEP INDEXFILE) (CLOSEHASHFILE INDEXFILE) (replace (INVERTEDDICT INDEXFILE) of WORDNERD with NIL) (InvertedDict.Prop WORDNERD 'LASTINDEX NIL) (InvertedDict.Prop WORDNERD 'LASTENTRY NIL))) NIL]) (HashfileNerd.Write [LAMBDA (WORDNERD FILENAME) (* ; "Edited 11-Nov-88 11:32 by jtm:") (* ;;; "Write out WORDNERD onto a hashfile so that it can be read back in later.") (LET (INDEXFILE HEADERINDEX HASHFILE HASHARRAY PROPS DICT DICTNAME ANALYZER ANALYZERNAME NAME) (* ;; "defaults for FILENAME") (COND [(NULL FILENAME) (SETQ FILENAME (InvertedDict.Prop WORDNERD 'FILENAME] (T (InvertedDict.Prop WORDNERD 'FILENAME FILENAME))) (OR FILENAME (ERROR "Please specify a filename.")) (* ;; "set up HASHFILE and HASHARRAY") (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of WORDNERD)) (COND ((LISTP INDEXFILE) (* ;  "information was added to an existing hashfile") (SETQ HASHARRAY (CAR INDEXFILE)) (SETQ HASHFILE (CDR INDEXFILE))) ((HASHFILEP INDEXFILE) (SETQ HASHFILE INDEXFILE)) ((HARRAYP INDEXFILE) (SETQ HASHARRAY INDEXFILE)) ((BIGHASHP INDEXFILE) (SETQ HASHARRAY INDEXFILE))) [COND ((NULL HASHFILE) (* ; " create a new hashfile") (SETQ HASHFILE (CREATEHASHFILE FILENAME NIL NIL (BIGHASHSIZE HASHARRAY] [COND (HASHARRAY (* ; "write new entries out") (BIGMAPHASH HASHARRAY (FUNCTION (LAMBDA (VAL KEY) (PUTHASHFILE KEY VAL HASHFILE] (* ;; "store the name on the hashfile if it has changed.") (SETQ NAME (fetch (INVERTEDDICT INVERTEDDICTNAME) of WORDNERD)) (COND ((NEQ NAME (GETHASHFILE '*NAME* HASHFILE)) (PUTHASHFILE '*NAME* NAME HASHFILE))) (* ;; " store HEADERINDEX on the hashfile if it has changed.") (SETQ HEADERINDEX (fetch (INVERTEDDICT HEADERINDEX) of WORDNERD)) [SETQ HEADERLIST (AND HEADERINDEX (for I ENTRY from 1 while (SETQ ENTRY (ELT HEADERINDEX I)) collect (LIST I ENTRY] (COND ((NOT (EQUAL HEADERLIST (GETHASHFILE '*HEADERINDEX* HASHFILE))) (PUTHASHFILE '*HEADERINDEX* HEADERLIST HASHFILE))) (* ;; " store simple properties on the hashfile if they have changed.") (SETQ PROPS (for PROP in (fetch (INVERTEDDICT INVERTEDDICTPROPS) of WORDNERD ) when (SIMPLETYPE (CDR PROP)) collect PROP)) (COND ((NOT (EQUAL PROPS (GETHASHFILE '*PROPS* HASHFILE))) (PUTHASHFILE '*PROPS* PROPS HASHFILE))) (* ;; "store the name of the dictionary on the hashfile if it hash changed.") (SETQ DICTNAME (AND [type? Dict (SETQ DICT (InvertedDict.Prop WORDNERD 'DICTIONARY] (Dict.Name DICT))) (COND ((NEQ DICTNAME (GETHASHFILE '*DICTIONARY* HASHFILE)) (PUTHASHFILE '*DICTIONARY* DICTNAME HASHFILE))) (* ;; "store the name of the analyzer if it has changed.") (SETQ ANALYZERNAME (AND [type? Morphalyzer (SETQ ANALYZER (InvertedDict.Prop WORDNERD 'DICTIONARY] (Analyzer.Name ANALYZER))) (COND ((NEQ ANALYZERNAME (GETHASHFILE '*ANALYZER* HASHFILE)) (PUTHASHFILE '*ANALYZER* ANALYZERNAME HASHFILE))) (* ;; "remove the hash array from INDEXFILE") (replace (INVERTEDDICT INDEXFILE) of WORDNERD with HASHFILE) (* ;; " return the hash file") HASHFILE]) (SIMPLETYPE [LAMBDA (DATUM) (* ; "Edited 15-Sep-88 14:33 by jtm:") (COND ((NUMBERP DATUM) T) ((STRINGP DATUM) T) ((LITATOM DATUM) T) ((LISTP DATUM) (for I inside DATUM always (SIMPLETYPE I]) (HashfileNerd.AddAssociation [LAMBDA (WORDNERD HEADER KEY) (* ; "Edited 11-Nov-88 11:30 by jtm:") (* * adds KEY to WORDNERD under HEADER.) (LET (LASTENTRY HEADERINDEX INDEXFILE HEADERSIZE ENTRYID HASHARRAY HASHFILE ASSOCS) (* * initialize local variables and data structures.) (WordNerd.Open WORDNERD) (SETQ HEADERINDEX (fetch (INVERTEDDICT HEADERINDEX) of WORDNERD)) (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of WORDNERD)) [COND ((HARRAYP INDEXFILE) (SETQ HASHARRAY INDEXFILE)) ((BIGHASHP INDEXFILE) (* ;; "INDEXFILE is an array of hash arrays indexed by length of the key string.") (SETQ HASHARRAY INDEXFILE)) ((HASHFILEP INDEXFILE) (SETQ HASHFILE INDEXFILE) (* ;; "Create a hash array to handle the new associations.") (SETQ HASHARRAY (HASHARRAY 100 NIL (FUNCTION STRINGHASHBITS) (FUNCTION STREQUAL))) (SETQ INDEXFILE (CONS HASHARRAY HASHFILE)) (replace (INVERTEDDICT INDEXFILE) of WORDNERD with INDEXFILE)) ((NULL INDEXFILE) (SETQ HASHARRAY (HASHARRAY 100 NIL (FUNCTION STRINGHASHBITS) (FUNCTION STREQUAL))) (replace (INVERTEDDICT INDEXFILE) of WORDNERD with HASHARRAY)) ((LISTP INDEXFILE) (* ; "must follow (NULL INDEXFILE)") (SETQ HASHARRAY (CAR INDEXFILE)) (SETQ HASHFILE (CDR INDEXFILE] [COND ([NULL (SETQ LASTENTRY (InvertedDict.Prop WORDNERD 'LASTENTRY] (SETQ LASTENTRY (CONS NIL 0] (* * map HEADER to a unique ID using EQUAL.  We want ID numbers to make it easier to convert to external indices.) (COND ((EQ HEADER :STOPWORD) (* don't add header to header index.) NIL) ((NULL HEADERINDEX) (* Identity mapping) (SETQ ENTRYID HEADER)) ((EQUAL HEADER (CAR LASTENTRY)) (* this is optimized for multiple  additions to the same entry.) (SETQ ENTRYID (CDR LASTENTRY))) ([SETQ ENTRYID (for I from 1 to (SETQ HEADERSIZE (ARRAYSIZE HEADERINDEX)) thereis (EQUAL HEADER (ELT HEADERINDEX I] (* look for an existing entry.) (InvertedDict.Prop WORDNERD 'LASTENTRY (CONS HEADER ENTRYID))) (T (* add an HEADER to HEADERINDEX) (SETQ ENTRYID (ADD1 (OR (InvertedDict.Prop WORDNERD 'LASTINDEX) 0))) [COND ((IGREATERP ENTRYID HEADERSIZE) (LET (NEWHEADERINDEX) (* get a bigger array.) (SETQ NEWHEADERINDEX (ARRAY (ITIMES HEADERSIZE 2))) (for I from 1 to HEADERSIZE do (SETA NEWHEADERINDEX I (ELT HEADERINDEX I))) (replace (INVERTEDDICT HEADERINDEX) of WORDNERD with NEWHEADERINDEX) (SETQ HEADERINDEX NEWHEADERINDEX] (SETA HEADERINDEX ENTRYID HEADER) (InvertedDict.Prop WORDNERD 'LASTINDEX ENTRYID))) (* * push the HEADER onto INDEXFILE) (COND ((EQ HEADER :STOPWORD) (BIGPUTHASH KEY :STOPWORD HASHARRAY)) [(SETQ ASSOCS (BIGGETHASH KEY HASHARRAY)) (COND ((EQ ASSOCS :STOPWORD) (* don't do anything) NIL) ((NEQ ENTRYID (CAR ASSOCS)) (ATTACH ENTRYID ASSOCS] ((AND HASHFILE (SETQ ASSOCS (GETHASHFILE KEY HASHFILE)) (NEQ ASSOCS :STOPWORD) (NEQ ENTRYID (CAR ASSOCS))) (push ASSOCS ENTRYID) (BIGPUTHASH KEY ASSOCS HASHARRAY)) (T (BIGPUTHASH KEY (LIST ENTRYID) HASHARRAY]) (HashfileNerd.GetEntry [LAMBDA (WORDNERD KEYID INDEXFILE) (* ; "Edited 11-Nov-88 14:28 by jtm:") [COND ((NULL INDEXFILE) (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of WORDNERD] (COND ((BIGHASHP INDEXFILE) (BIGGETHASH KEYID INDEXFILE)) [(LISTP INDEXFILE) (* (CONS HASHARRAY HASHFILE)) (COND ((GETHASH KEYID (CAR INDEXFILE))) (T (GETHASHFILE KEYID (CDR INDEXFILE] ((HASHFILEP INDEXFILE) (GETHASHFILE KEYID INDEXFILE)) ((HARRAYP INDEXFILE) (GETHASH KEYID INDEXFILE]) (HashfileNerd.ExpandKeyPattern [LAMBDA (NERD KEYPATTERN) (* ; "Edited 17-Nov-88 16:58 by jtm:") (LET (PAT INDEXFILE KEYS HASHARRAY HASHFILE) (SETQ PAT (DIRECTORY.MATCH.SETUP KEYPATTERN)) (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of NERD)) [COND ((OR (BIGHASHP INDEXFILE) (HARRAYP INDEXFILE)) (SETQ HASHARRAY INDEXFILE)) ((HASHFILEP INDEXFILE) (SETQ HASHFILE INDEXFILE)) ((LISTP INDEXFILE) (SETQ HASHARRAY (CAR INDEXFILE)) (SETQ HASHFILE (CDR INDEXFILE] [if HASHARRAY then (BIGMAPHASH HASHARRAY (FUNCTION (LAMBDA (DATA KEY) (COND ((DIRECTORY.MATCH PAT KEY) (push KEYS KEY] [if HASHFILE then (MAPHASHFILE HASHFILE (FUNCTION (LAMBDA (DATA KEY) (COND ((DIRECTORY.MATCH PAT KEY) (push KEYS KEY] KEYS]) (HashfileNerd.MapKeys [LAMBDA (NERD KEYFN) (* ; "Edited 17-Nov-88 16:29 by jtm:") (* ;;; "maps through all of the keys in the hash array/ file") (LET (INDEXFILE HASHARRAY HASHFILE) (SETQ INDEXFILE (fetch (INVERTEDDICT INDEXFILE) of NERD)) [COND ((OR (BIGHASHP INDEXFILE) (HARRAYP INDEXFILE)) (SETQ HASHARRAY INDEXFILE)) ((HASHFILEP INDEXFILE) (SETQ HASHFILE INDEXFILE)) ((LISTP INDEXFILE) (SETQ HASHARRAY (CAR INDEXFILE)) (SETQ HASHFILE (CDR INDEXFILE] [if HASHARRAY then (BIGMAPHASH HASHARRAY (FUNCTION (LAMBDA (DATA KEY) (APPLY* KEYFN NERD KEY DATA] (if HASHFILE then (MAPHASHFILE HASHFILE (FUNCTION (LAMBDA (DATA KEY) (APPLY* KEYFN NERD KEY DATA]) ) (DEFINEQ (BIGHASH [LAMBDA (MAXKEYLENGTH MINKEYS OVERFLOW HASHBITSFN EQUIVFN) (* ; "Edited 11-Nov-88 11:19 by jtm:") (* ;; "A BIGHASH first hashes keys into an array by key length to get a hash array and then hashes the key in that hash array.") (create BIGHASH BIGHASHARRAY _ (ARRAY (ADD1 MAXKEYLENGTH) NIL NIL 0) BIGHASHMINKEYS _ MINKEYS BIGHASHOVERFLOW _ OVERFLOW BIGHASHBITSFN _ HASHBITSFN BIGHASHEQUIVFN _ EQUIVFN]) (BIGGETHASH [LAMBDA (KEY BIGHASH) (* ; "Edited 11-Nov-88 11:04 by jtm:") (* ;; "get the value from the hash array that has keys of KEY's length") (LET (HARRAY) (COND [(type? BIGHASH BIGHASH) (COND ((SETQ HARRAY (ELT (fetch BIGHASHARRAY of BIGHASH) (NCHARS KEY))) (GETHASH KEY HARRAY] (T (GETHASH KEY BIGHASH]) (BIGHASHSIZE [LAMBDA (BIGHASH) (* ; "Edited 11-Nov-88 11:28 by jtm:") (LET (ARRAY) (COND [(type? BIGHASH BIGHASH) (SETQ ARRAY (fetch BIGHASHARRAY of BIGHASH)) (for I HARRAY from 0 to (SUB1 (ARRAYSIZE ARRAY)) sum (COND ((SETQ HARRAY (ELT ARRAY I)) (HARRAYSIZE HARRAY)) (T 0] (T (HARRAYSIZE BIGHASH]) (BIGMAPHASH [LAMBDA (BIGHASH MAPBHFN) (* ; "Edited 11-Nov-88 11:10 by jtm:") (* ;; "map through all of the keys in the sub-hashes.") (LET (ARRAY) (COND [(type? BIGHASH BIGHASH) (SETQ ARRAY (fetch BIGHASHARRAY of BIGHASH)) (for I HARRAY from 0 to (SUB1 (ARRAYSIZE ARRAY)) do (COND ((SETQ HARRAY (ELT ARRAY I)) (MAPHASH HARRAY MAPBHFN] (T (MAPHASH BIGHASH MAPBHFN]) (BIGPUTHASH [LAMBDA (KEY VAL BIGHASH) (* ; "Edited 11-Nov-88 11:02 by jtm:") (* ;; "put all of the keys with the same lengths together.") (LET (HARRAY ARRAY NCHARS) (COND ((type? BIGHASH BIGHASH) (SETQ NCHARS (NCHARS KEY)) (SETQ ARRAY (fetch BIGHASHARRAY of BIGHASH)) (SETQ HARRAY (ELT ARRAY NCHARS)) (COND ((NULL HARRAY) (SETQ HARRAY (HASHARRAY (fetch BIGHASHMINKEYS of BIGHASH) (fetch BIGHASHOVERFLOW of BIGHASH) (fetch BIGHASHBITSFN of BIGHASH) (fetch BIGHASHEQUIVFN of BIGHASH))) (SETA ARRAY NCHARS HARRAY))) (PUTHASH KEY VAL HARRAY)) (T (PUTHASH KEY VAL BIGHASH]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BIGHASHP MACRO ((ARRAY) (type? BIGHASH ARRAY))) ) (DECLARE%: EVAL@COMPILE (TYPERECORD BIGHASH (BIGHASHARRAY BIGHASHMINKEYS BIGHASHOVERFLOW BIGHASHBITSFN BIGHASHEQUIVFN)) ) (* * the following should be merged into ANALYZER eventually.) (DEFINEQ (FileDict.Create [LAMBDA (NAME FILENAME) (* ; "Edited 15-Sep-88 14:02 by jtm:") (LET (DICT) (SETQ DICT (SimpleDict.Create NAME FILENAME)) (replace (Dict getEntryFn) of DICT with (FUNCTION FileDict.Lookup)) (replace (Dict mapFn) of DICT with (FUNCTION FileDict.MapEntries)) (replace (Dict printEntryFn) of DICT with (FUNCTION FileDict.PrintEntry)) (Dict.Establish DICT) DICT]) (FileDict.AddFiles [LAMBDA (DICT FILEPATTERN) (* ; "Edited 14-Sep-88 16:30 by jtm:") (for FULLNAME in (SORT (DIRECTORY FILEPATTERN)) do (Dict.PutEntry DICT (FILENAMEFIELD FULLNAME 'NAME) FULLNAME]) (FileDict.PrintEntry [LAMBDA (DICT KEY STREAM) (* ; "Edited 14-Sep-88 16:38 by jtm:") (LET (FILE) (COND ((SETQ FILE (SimpleDict.Lookup DICT KEY)) (TEDIT FILE) ""]) (FileDict.Write [LAMBDA (DICT FILENAME) (* ; "Edited 15-Sep-88 11:13 by jtm:") (LET (STREAM) (SETQ STREAM (OPENSTREAM FILENAME 'OUTPUT]) (FileDict.Lookup [LAMBDA (DICT KEY) (* ; "Edited 14-Sep-88 15:08 by jtm:") (LET (FILE) (COND ((SETQ FILE (SimpleDict.Lookup DICT KEY)) (FETCHSTRINGFROMFILE FILE]) (FileDict.MapEntries [LAMBDA (DICT FDMAPFN PROP) (* ; "Edited 14-Sep-88 15:26 by jtm:") (SimpleDict.MapEntries DICT (FUNCTION (LAMBDA (DICT KEY FILENAME) (LET (STREAM) (SETQ STREAM (OPENTEXTSTREAM FILENAME)) (APPLY* FDMAPFN DICT (CONCATLIST KEY) STREAM) (CLOSEF STREAM]) (FETCHSTRINGFROMFILE [LAMBDA (FILENAME) (* ; "Edited 15-Sep-88 11:01 by jtm:") (* LET (STREAM STRING)  (SETQ STREAM (OPENTEXTSTREAM  FILENAME)) (TEDIT.SETSEL STREAM 1  10000 (QUOTE LEFT))  (SETQ STRING (TEDIT.SEL.AS.STRING  STREAM)) (CLOSEF STREAM)) (COND ((LISTP FILENAME) (OPENTEXTSTREAM (CAR FILENAME) NIL (CADR FILENAME) (CADDR FILENAME))) (T (OPENTEXTSTREAM FILENAME]) ) (DEFINEQ (SimpleAnalyzer.Create [LAMBDA (NAME) (* ; "Edited 14-Sep-88 09:49 by jtm:") (LET (morphalyzer) (SETQ morphalyzer (create Morphalyzer analyzerName _ NAME lookupFn _ (FUNCTION SimpleAnalyzer.Lookup))) (Analyzer.Prop morphalyzer 'OPT-SEPR-CODES '(NIL)) (* * turn off the optional seperator codes) morphalyzer]) (SimpleAnalyzer.Lookup [LAMBDA (ANALYZER STREAM START LENGTH) (* ; "Edited 14-Sep-88 09:46 by jtm:") (L-CASE (COND ((STRINGP STREAM) (SUBSTRING STREAM (ADD1 START) (IPLUS START LENGTH))) (T (STREAM.FETCHSTRING STREAM START LENGTH NIL T]) ) (DEFINEQ (SimpleDict.Create [LAMBDA (name filename) (* ; "Edited 15-Sep-88 11:26 by jtm:") (LET (dict) (SETQ dict (create Dict dictName _ name openFn _ (FUNCTION SimpleDict.Open) closeFn _ (FUNCTION SimpleDict.Close) getEntryFn _ (FUNCTION SimpleDict.Lookup) putEntryFn _ (FUNCTION SimpleDict.PutEntry) mapFn _ (FUNCTION SimpleDict.MapEntries) contents _ (create SimpleDict.Node))) (Dict.Prop dict 'FILENAME filename) dict]) (SimpleDict.Open [LAMBDA (DICT) (* ; "Edited 15-Sep-88 11:38 by jtm:") (LET (FILENAME) (COND ([AND (NULL (fetch (SimpleDict.Node subnodes) of (fetch (Dict contents) of DICT))) (SETQ FILENAME (Dict.Prop DICT 'FILENAME] (SETQ DATALIST (CDR (READFILE FILENAME))) (for PAIR in DATALIST do (Dict.PutEntry DICT (CAR PAIR) (CADR PAIR]) (SimpleDict.Close [LAMBDA (DICT) (* ; "Edited 15-Sep-88 11:30 by jtm:") (LET (CONTENTS FILENAME) (COND ([AND (SETQ CONTENTS (fetch (Dict contents) of DICT)) (fetch (SimpleDict.Node subnodes) of CONTENTS) (SETQ FILENAME (Dict.Prop DICT 'FILENAME] (SimpleDict.Write DICT FILENAME) (replace (Dict contents) of DICT with (create SimpleDict.Node)) DICT]) (SimpleDict.Write [LAMBDA (DICT FILENAME) (* ; "Edited 15-Sep-88 11:21 by jtm:") (LET (DATALIST) (COND [(NULL FILENAME) (SETQ FILENAME (Dict.Prop DICT 'FILENAME] (T (Dict.Prop DICT 'FILENAME FILENAME))) [SimpleDict.MapEntries DICT (FUNCTION (LAMBDA (DICT PATH ENTRY) (push DATALIST (LIST (CONCATLIST PATH) ENTRY] (WRITEFILE (DREVERSE DATALIST) FILENAME) DICT]) ) (RPAQQ ENGLISHSTOPWORDS ("from" "to" "the" "of" "in" "a" "for" "on" "and" "that" "s" "is" "at" "it" "be" "by" "with" "but" "an" "not" "i" "was" "as" "t" "this" "they" "you" "he" "all" "if" "who" "may" "have" "out" "or" "when" "are" "so" "his" "can" "which" "about" "had" "been" "were" "do" "has" "other" "would" "we" "also" "some" "your" "my" "me" "their" "no" "could" "only" "more" "then" "him" "our" "any" "them" "her" "over" "its" "before" "between" "what" "after" "she" "most" "those" "than" "these" "does" "same" "into" "such" "while" "here" "how" "off" "will" "around" "there")) (PUTPROPS WORDNERD COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5746 9213 (WordNerd.AddEntry 5756 . 6713) (WordNerd.AddDictionary 6715 . 7805) ( WordNerd.AddStopWords 7807 . 8049) (WordNerd.SortByFrequency 8051 . 9211)) (9214 25478 ( WordNerd.DefaultVennSearch 9224 . 25476)) (25479 38724 (WordNerd.DefaultWeightedSearch 25489 . 34408) (AddWeightsToArray 34410 . 35287) (FindTopElements 35289 . 36530) (AddToPriorityList 36532 . 38722)) ( 38725 41776 (WordNerd.DefaultRelevanceSearch 38735 . 40149) (MergeKeywords 40151 . 41774)) (41777 44015 (WORDNERD.PARSEINPUT 41787 . 44013)) (44158 54130 (SimpleNerd.Create 44168 . 45489) ( SimpleNerd.AddAssociation 45491 . 49412) (SimpleNerd.MapKeys 49414 . 50186) (SimpleNerd.GetEntry 50188 . 50346) (SimpleNerd.MaxEntry 50348 . 50510) (SimpleNerd.GetHeader 50512 . 50720) ( SimpleNerd.ParseDictEntry 50722 . 52162) (SimpleNerd.Test 52164 . 54128)) (54209 71892 ( HashfileNerd.Create 54219 . 56055) (HashfileNerd.Test 56057 . 56625) (HashfileNerd.Open 56627 . 59055) (HashfileNerd.Close 59057 . 59802) (HashfileNerd.Write 59804 . 63978) (SIMPLETYPE 63980 . 64303) ( HashfileNerd.AddAssociation 64305 . 68875) (HashfileNerd.GetEntry 68877 . 69535) ( HashfileNerd.ExpandKeyPattern 69537 . 70869) (HashfileNerd.MapKeys 70871 . 71890)) (71893 75042 ( BIGHASH 71903 . 72494) (BIGGETHASH 72496 . 72992) (BIGHASHSIZE 72994 . 73532) (BIGMAPHASH 73534 . 74110) (BIGPUTHASH 74112 . 75040)) (75371 78536 (FileDict.Create 75381 . 75899) (FileDict.AddFiles 75901 . 76385) (FileDict.PrintEntry 76387 . 76644) (FileDict.Write 76646 . 76840) (FileDict.Lookup 76842 . 77096) (FileDict.MapEntries 77098 . 77660) (FETCHSTRINGFROMFILE 77662 . 78534)) (78537 79371 ( SimpleAnalyzer.Create 78547 . 79027) (SimpleAnalyzer.Lookup 79029 . 79369)) (79372 81850 ( SimpleDict.Create 79382 . 80070) (SimpleDict.Open 80072 . 80680) (SimpleDict.Close 80682 . 81221) ( SimpleDict.Write 81223 . 81848))))) STOP \ No newline at end of file diff --git a/lispusers/Wordfns.Tedit b/lispusers/Wordfns.Tedit new file mode 100644 index 00000000..674fe5dd --- /dev/null +++ b/lispusers/Wordfns.Tedit @@ -0,0 +1,14 @@ +XEROX WORDFNS 2 4 1 WORDFNS 1 4 By: Ron Kaplan (Kaplan.pa@Xerox.com) Becky Burwell (Burwell.pa@Xerox.com) Uses: SETSTRINGLENGTH This document last edited on August 19, 1988. INTRODUCTION WORDFNS is a set of functions for manipulating files of words. There are functions to do the following: sort files, manipulate sorted files, provide common i/o functions for word files, provide mapping and translation mechanisms, provide common translation functions, and provide packaged mapping utilities. The idea behind the mapping mechanism is that you can translate a file or list of files by specifying a read function to operate on each chunk of a file (the obvious two chunks are words and lines). You can specify file specific translation functions, default functions (when file specific functions are not provided) and common translation functions for all files. The input to the first translation function is the result of applying the read function to an input stream open on a file. The output of the first translation function is passed as input to the second translation function, etc. USE Note: for any file, if NIL or T is specified then the results are printed in the executive window. Sorting Files (SORTWORDFILE IFILES OFILE COMMONTRANSFNS DEFAULTTRANSFNS READFN COMMONCOMPAREFN KEEPDUPLICATES FIELDS SEPARATOR REVERSEORDERFLG FASTFLG) [Function] The functions sorts the words on IFILES and stores the result back on OFILE. Th duplicates are eliminated unless KEEPDUPLICATES is non-NIL. For a description of the function of the argumentsCOMMONTRANSFNS, DEFAULTTRANSFNS and READFN see the section entitled "Translation Mechanisms". The argument FIELDS is used to specify the sorting order. The separator of the fields is specified in SEPARATOR. If REVERSEORDERFLG is T the result of the sort is reversed. FASTFLG set T causes the sort to caches the fields by consing allowing for a quicker sort (but consumes memory). FIELDS is one of: NIL, a list of field numbers or else a list of one, two or three element lists of the form: FieldNumber Type CompareFn where type is either STRING (the default) or NUMBER. The default comparefn for STRING is ALPHORDER; for NUMBER is NUMORDER [Argument] SEPARATOR is one of the following: a character string, a bittable, a list of single character atoms or numbers or one of the special atoms WHITESPACE (indicating a space or tab) or the atom TAB. The default is WHITESPACE. [Argument] >> should I put NUMORDER and GetNthField here?<< Note: two related functions, NUMORDER and GetNthField, are described in the miscellaneous section. Functions for use with sorted files In each of the following functions: COMMENTFILE contains the details of the result of the function (for example, the number of strings that were read in from each file) [Argument] (COMMONSORTEDFILES file1 file2 ofile COMMENTFILE) [Function] Computes the intersection of two sorted files, file1 and file2 and the results are stored on ofile. The files are read a line at a time. The value is the full name of ofile. (COMPARESORTEDFILES file1 file2 ofile IMINUS2 2MINUS1 COMMENTFILE COMMENT) [Function] The two sorted files, file1 and file2, are compared a line at a time. The common lines are stored on ofile. The output is in two colums: the left column for those lines in file1 that do not exist in file2 and the right column for those lines in file2 that do not exist in file1. The two flags IMINUS2 and 2MINUS1 are used to determine how the the comparisons will be performed. If they are not specified they are both assumed to be T thus meaning that the comparison will be performed by subtracting file2 from file file1 and file2 with file1 substracted. If only one of IMINUS2 or 2MINUS1 is specified then only the specified one way comparison will be done. COMMENT is intended to be a string which, by default, is the string "Comparison". This string is inserted at the top of the file. The value is the full name of ofile. (DIFFSORTEDFILES FILE1 FILE2 OUTFILE COMMENTFILE) [Function] The result of subtracting FILE1 from FILE2 is stored on OUTFILE. The files are read a line at a time. The value is the full name of ofile. I/O Functions In the two major read functions, DREADLINE and DREADWORD, the SPACE, CR, LF and ^Z in any character set are interpreted to be the corresponding character in character set zero. (DREADLINE stream string skipsemicolons) [Function] Words are read from the word-stream stream, smashing them into string, which grows as needed. Returns NIL at EOF. Skips leading and trailing separators, and if skipsemicolons is non-NIL then sequences from ";" to EOL are treated as a composite separator or end-marker. Unlike DREADWORD (desribed later in this section), segments are separated only by EOL, so compounds are not split into components. Note that stream must have been set up so that BIN/READCCODE returns NULL on EOF. (DREADLINESKIPSC stream string skipsemicolons) [Function] Calls DREADLINE with skipsemicolons bound to T. (DREADWORD stream string) [Function] Words are read from the word-stream stream, smashing them into string, which grows as needed. Returns NIL at EOF. Skips leading and trailing separators, and treats sequences from ";" to EOL as a composite separator or end-marker. Unlike DREADLINE, segments are separated by space as well as EOL, so splits compounds into components. Note that stream must have been set up so that BIN/READCCODE returns NULL on EOF. (INPUTWORDSTREAM FILE NOPRINT) [Function] Returns a stream that is guaranteed to be open for word-reading (e.g. using DREADLINE or DREADWORD) at the beginning of FILE. If NOPRINT is NIL then the fullname of the file will be output. (OUTPUTWORDSTREAM FILE) [Function] Returns and opens a stream for the output of words (sequential text) guaranteed closed when reset context is exited and deleted if there is an error. Translation Mechanisms Translation mechanisms are supplied to allow great flexibility in translating one or more files which may be in different formats and have unique translations applied to them. To specify how a file is to be read a read function (READFN) can be specified. Two common read functions, described previously, are DREADLINE and DREADWORD. As mentioned earlier each file can have unique or common translation functions. A translation function is a function which takes two arguments: a string (the input to be translated) and an optional scratch string which can be destructively modified. The output of the translation function is one of the following: a string, the value T or the value NIL. Readers may wish to refer to the LispUsers module SETSTRINGLENGTH. The special value T denotes that the output is the same as the input. A value of NIL means that nothing will be kept. >> a better name for translation set << >> what is the syntax?<< IFILES is either a single file name, a single translation set, a list of file names or a list of translation sets. Translation sets have the form: (READFN READFN TRANFN1 TRANSFN2 ...). (Note the first element of the list is the actual atom READFN and the second element [Argument] READFN is the read function that is used for reading the files. It is passed a stream. Unless specified otherwise, the default read function is DREADWORD. [Argument] DEFAULTTRANSFNS is a single function or list of functions which is first applied to the first file. What is given to the translation function is determined by what the read function passed. Unless specified otherwise, the default read function is DREADWORD. The result of applying the first function in DEFAULTTRANSFNS is input to the second function in DEFAULTTRANSFNS. This result is then passed on for application to the functions in COMMONTRANSFNS. The special value T denotes that the output is the same as the input. [Argument] COMMONTRANSFNS [Argument] DONTPRINT is the argument which decides whether the details of the translation functions will be printed. By default it is NIL meaning that the details will be printed. [Argument] (TRANSLATEWORDFILE IFILES COMMONTRANSFNS DEFAULTTRANSFNS READFN DONTPRINT ) [Function] TRANSLATEWORDFILE produces an output file by translating each word in (possibly a list of) IFILES through a translation function. List elements of files are paired with their own idiosyncratic translation function. Otherwise the DEFAULTTRANSFNS is used. COMMONTRANSFNS are applied to the results of the default or file-specific translations to produce the translation string. If any translation function returns NIL, that string is skipped. A translation function is assumed to be an identity if it returns T, which makes simple predicates easy. (COLLECTWORDFILE IFILES COMMONTRANSFNS DEFAULTTRANSFNS READFN DONTPRINT) [Function] Returns the list of non-NIL values of functions applied to words in IFILES. (MAPWORDFILE IFILES COMMONTRANSFNS DEFAULTTRANSFNS MAPFN READFN DONTPRINT) [Function] Maps mapping function over words in IFILES. Nothing is setup for output. Packaged Mapping Utilities (LONGESTWORDS FILES COMMONTRANSFNS DEFAULTTRANSFNS READFN DONTPRINT) [Function] The list of longest translated words in FILES is returned. (SEXPRCOUNT FILE RDTBL ) [Function] Returns the number of s-expressions in FILE using RDTBL to read. (WORDCOUNT IFILES COMMONTRANSFNS DEFAULTTRANSFNS READFN DONTPRINT ) [Function] The total number of translated words in IFILES is returned. (FINDPREFIXES IFILES OFILE PREFIXES BUTNOT READFN ) [Function] FINDPREFIXES produces an output file OFILE of those strings read by READFN from IFILES which match at least one prefix in the list of prefix strings PREFIXES and do not match any prefixes in the list of prefixstrings BUTNOT. (FINDSUFFIXES IFILES OFILE SUFFIXES BUTNOT NOCAPS READFN ) [Function] FINDPREFIXES produces an output file OFILE of those strings read by READFN from IFILES which match at least one suffix in the list of suffix strings SUFFIXES and do not match any suffixes in the list of suffix strings BUTNOT. If NOCAPS is specified then the match succeeds if the string does not have the first letter capitalized. (FINDSUBSTRINGS IFILES OFILE SUBSTRINGS READFN ) [Function] FINDSUBSTRINGS produces an output file OFILE of those strings read by READFN from IFILES which match at least one substring in the list of substrings SUBSTRINGS. Translation Functions (MIXEDCASEP W ) [Function] Returns W if it contains mixtures of uppercase and lowercase characters after the initial character. (PROPERP W ) [Function] Returns T if the first characters of W is uppercase. (NOTPROPERP W ) [Function] Returns T if the first characters of W is not uppercase. (REVERSESTRING W STR ) [Function] Reverses W into STR and returns STR. Examples This example will printout all the lines that have either the prefix "re" or "no" but not the prefix "non". (FINDPREFIXES '{dsk}Myfile T '("re" "no") '("non") (FUNCTION DREADLINE)) This example will output to file {Phylum}Suffixes all the words in the files {dsk}File1 and {dsk}File2 that end in "ion" that do not have the first letter capitalized. (FINDSUFFIXES '({dsk}File1 {dsk}File2) '{Phylum}Suffixes "ion" NIL T (FUNCTION DREADWORD)) Miscellaneous Functions (GETNTHFIELD STRING N SEPARATOR FIELDTYPE ) [Function] The Nth field in STRING is returned using SEPARATOR as the field separator and the field type is coerced to type FIELDTYPE. N is a simple positive integer [Argument] SEPARATOR is the same as that for SORTWORDFILE [Argument] FIELDTYPE is either the atom NUMBER or the atom STRING and indicates how the type that the field should be coerced to. The default FIELDTYPE is STRING. Example (GETNTHFIELD "So long and thanks for all the fish" 4 'WHITESPACE 'STRING) returns the string "thanks". (GETNTHFIELD "Joe Smith/5551212/12 Pleasant Lane/" 2 "/" 'NUMBER) returns the integer 5551212. (DCOPYSTRING W STR ) [Function] Copies string W into string STR and returns STR. (NUMORDER NUMBER1 NUMBER2) [Function] Returns >>??<< Example (SETQ MyString (ALLOCSTRING 1)) (DCOPYSTRING "This is a much longer string" MyString) (LIST ((PAGE NIL (FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL)))))(Č1Č Č(ŠŠ8(Č (ŠŠ8DČČ PAGEHEADING RUNNINGHEAD MODERN +TERMINAL + HELVETICA +MODERN +MODERN +MODERN MODERNMODERN +LOGO  HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN  HRULE.GETFNMODERN L. 7Xez rŽT ,j + Ö 1d$$ … /I#M AC)ž I› Fą  $]îB     $D  x6 –R#(—i˘   Ž7 [† 6 D< $"5 (   ' + 7 ($ %?<+ %?=`  '> +  f + 5  9 & lJ˛e    * > ( 2 {  MF     !6/śzş \ No newline at end of file diff --git a/lispusers/XCL-BRIDGE b/lispusers/XCL-BRIDGE new file mode 100644 index 00000000..aee4f4e7 --- /dev/null +++ b/lispusers/XCL-BRIDGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (il:filecreated "15-Feb-89 15:42:25" il:|{DSK}/pooh/pedersen/lisp/XCL-BRIDGE.;2| 22921 il:|changes| il:|to:| (il:vars il:xcl-bridgecoms) (il:variables *bridging*) (il:functions managed-to-text-file text-to-managed-file) il:|previous| il:|date:| " 6-Dec-88 17:22:36" il:|{DSK}/pooh/pedersen/lisp/XCL-BRIDGE.;1|) ; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved. (il:prettycomprint il:xcl-bridgecoms) (il:rpaqq il:xcl-bridgecoms ((il:declare\: il:docopy il:donteval@load il:donteval@compile (il:p (export (quote (text-to-managed-file managed-to-text-file *bridging*)) (find-package "XCL")))) (il:coms (il:* il:|;;| " indicator free variable") (il:variables *bridging*)) (il:coms (il:* il:|;;| "From Text to manager format") (il:variables *eof-marker*) (il:functions text-to-managed-file) (il:functions construct-coms install-file) (il:functions read-semicolon-comment make-semicolon-comment probe-for-mode-line) (il:functions combine-comments comment-p comment-combineable-p do-combine-comments) (il:functions process-definitions definer-type find-definition)) (il:coms (il:* il:|;;| "From manager to text format ") (il:functions managed-to-text-file) (il:functions construct-mode-line get-coms-forms make-comment)) (file-environments "XCL-BRIDGE") (il:coms (il:* il:|;;| "comment identity preservation hack") (il:variables *preserve-comment-start-char* *preserve-comment-start-charcode*) (il:functions initial-comment-line-p fix-comment-?) (il:advice (il:concat :in il:prin2-long-string) (il:prin1 :in il:prin2-long-string))))) (il:declare\: il:docopy il:donteval@load il:donteval@compile (export (quote (text-to-managed-file managed-to-text-file *bridging*)) (find-package "XCL")) ) (il:* il:|;;| " indicator free variable") (defvar *bridging* nil "True while dynamically within the XCL-BRIDGE") (il:* il:|;;| "From Text to manager format") (defparameter *eof-marker* "eof") (defun text-to-managed-file (pathname filename &key (package "USER" package-p) (readtable "XCL" readtable-p) (read-base 10 read-base-p) (compiler :compile-file) (combine-comments-p t)) (prog ((rootname (intern (string filename) (find-package "INTERLISP"))) forms first-form coms) (with-open-file (stream pathname :direction :input) (multiple-value-setq (package readtable read-base first-form) (probe-for-mode-line stream package package-p readtable readtable-p read-base read-base-p)) (il:* il:|;;| "Declare read environment") (format t "Using the following read environment:~%Package: ~a Readtable: ~a Read-base: ~a~%" package readtable read-base) (unless (y-or-n-p "Do you wish to continue? ") (return nil)) (let ((*package* (find-package package)) (*readtable* (copy-readtable (il:find-readtable readtable))) (*read-base* read-base) (*bridging* t)) (il:* il:|;;| "Setup for reading comments properly") (set-macro-character #\; (quote read-semicolon-comment) nil *readtable*) (setq forms (with-collection (do ((form (read stream nil *eof-marker*) (read stream nil *eof-marker*))) ((eq form *eof-marker*)) (unless package-p (if (eq (car form) (quote in-package)) (let ((new-package-name (string (eval (second form))))) (when (not (string= new-package-name package)) (warn "*** Encountered in-package form: Changing to ~a package" new-package-name) (setq package (package-name (eval form))))))) (collect form)))) (if first-form (setq forms (cons first-form forms))) (when combine-comments-p (format t "Combining comments..~%") (setq forms (combine-comments forms))))) (when (y-or-n-p "Edit the forms read prior to constructing a coms list? ") (sedit:sedit forms) (unless (y-or-n-p "Do you wish to continue? ") (return nil))) (setq coms (construct-coms forms)) (when (y-or-n-p "Edit the coms prior to installing the file? ") (sedit:sedit coms) (unless (y-or-n-p "Do you wish to continue? ") (return nil))) (when (y-or-n-p "Install file? ") (return (install-file rootname coms forms :package package :readtable readtable :read-base read-base :compiler compiler))))) (defun construct-coms (forms) (il:* il:|;;| "Constructs a file coms expression for a list of top-level forms") (let ((coms nil) (current-definitions nil) (current-type :none) (definer-type nil)) (dolist (form forms) (setq definer-type (definer-type form)) (when (and (not (eq current-type definer-type)) current-definitions) (setq coms (process-definitions current-definitions current-type coms)) (setq current-definitions nil current-type :none)) (cond ((eq definer-type :eval-when) (setq coms (nconc coms (il:bquote ((eval-when (il:\\\, (cadr form)) (il:\\\,@ (construct-coms (cddr form))))))))) (t (setq current-type definer-type) (push form current-definitions)))) (when current-definitions (setq coms (process-definitions current-definitions current-type coms))) coms)) (defun install-file (name coms forms &key (package "USER") (readtable "XCL") (read-base 10) (compiler :compile-file)) (labels ((install-definitions (coms forms) (dolist (form forms) (let ((def-type (definer-type form)) name) (cond ((eq def-type :eval-when) (install-definitions coms (cddr form))) ((and def-type (not (eq def-type :comment))) (setq name (%definer-name (car form) (remove-comments form))) (when (find-definition name def-type coms) (il:* il:|;;| "Save Definition") (%define-type-save-defn name def-type form)))))))) (setq forms (nconc forms (il:bquote ((define-file-environment (il:\\\, (string name)) :package (il:\\\, package) :readtable (il:\\\, readtable) :base (il:\\\, read-base) :compiler (il:\\\, compiler)))))) (setq coms (nconc coms (il:bquote ((file-environments (il:\\\, (string name))))))) (install-definitions coms forms) (let ((root-name (intern (string name) (find-package "INTERLISP")))) (set (il:filecoms root-name) coms) (il:addfile name) (setf (get root-name (quote il:filetype)) compiler) (setf (get root-name (quote il:makefile-environment)) (il:bquote (:readtable (il:\\\, readtable) :package (il:\\\, package) :base (il:\\\, read-base)))) root-name))) (defun read-semicolon-comment (stream &optional disp-char) (il:* il:|;;| "Adjacent comments of the same level are smashed together during an after-read pass over the structure.") (declare (ignore disp-char)) (let ((level (let ((value 0) (ch nil)) (loop (when (not (eql (setq ch (read-char stream)) #\;)) (unread-char ch stream) (return value)) (incf value))))) (make-semicolon-comment (read-line stream) level))) (defun make-semicolon-comment (string level) (il:bquote (il:* (il:\\\, (cdr (assoc (mod level 3) (quote ((0 . il:\;) (1 . il:|;;|) (2 . il:|;;;|))) :test (function eq)))) (il:\\\, (string-trim (quote (#\Space #\Tab)) string))))) (defun probe-for-mode-line (stream package package-p readtable readtable-p read-base read-base-p) (il:* il:\; "Edited 4-Aug-88 15:13 by ht:") (let* ((mode-form (do ((ch (read-char stream) (read-char stream))) ((not (member ch (quote (#\Space #\Newline #\Tab)) :test (function eq))) (unread-char ch stream) (if (eq ch #\;) (read-semicolon-comment stream))))) (mode-string (and mode-form (string= (third mode-form) "-*-" :end1 3) (string-upcase (third mode-form) :start 3)))) (when mode-string (let ((package-marker "PACKAGE:") (syntax-marker "SYNTAX:") (base-marker "BASE:") mode-position mode-name) (when (and (null package-p) (setq mode-position (search package-marker mode-string))) (let* ((package-form (read-from-string mode-string nil nil :start (+ mode-position (length package-marker)))) (package-name (string (if (consp package-form) (car package-form) package-form)))) (setq package (if (find-package package-name) package-name (progn (cerror "Create it and carry on" "~&Non-existent package: ~S~%" package-name) (if (consp package-form) (let ((use-list (or (second (member :use package-form :test (function eq))) (second package-form))) (nicknames (second (member :nicknames package-form :test (function eq))))) (make-package package-name :use (or use-list "LISP") :nicknames nicknames)) (make-package package-name))))))) (when (packagep package) (setq package (string (package-name package)))) (when (and (null readtable-p) (setq mode-position (search syntax-marker mode-string))) (setq mode-name (string (read-from-string mode-string nil nil :start (+ mode-position (length syntax-marker))))) (if (or (string= mode-name "LISP") (string= mode-name "COMMON-LISP")) (setq mode-name "XCL")) (if (not (il:find-readtable mode-name)) (error "~&Non-existent readtable: ~A~%" mode-name)) (setq readtable mode-name)) (when (readtablep readtable) (let ((name (il:readtableprop readtable (quote il:name)))) (if (null name) (error "Readtable ~s has no name." readtable) (setq readtable name)))) (when (and (null read-base-p) (setq mode-position (search base-marker mode-string))) (setq mode-name (read-from-string mode-string nil nil :start (+ mode-position (length base-marker)))) (if (not (and (numberp mode-name) (> mode-name 0))) (error "~&Bad read base: ~A~%" mode-name)) (setq read-base mode-name)))) (values package readtable read-base (il:* il:|;;| "Return a non-mode line comment, if necessary") (and (null mode-string) mode-form)))) (defun combine-comments (x) (il:* il:\; "Edited 10-Aug-88 10:19 by ht:") (il:* il:|;;;| "Smash together adjacent sedit comments at the same level.") (cond ((not (consp x)) x) ((and (comment-p (car x)) (comment-p (cadr x)) (comment-combineable-p (car x) (cadr x))) (il:* il:|;;| "At least two adjacent comments at the same level ") (let ((tail (cddr x)) (matcher (cadr (car x))) (comments (list (car x) (cadr x)))) (nconc comments (with-collection (loop (if (not (and (comment-p (car tail)) (eq (cadr (car tail)) matcher) (not (initial-comment-line-p (caddr (car tail)))))) (return nil)) (collect (car tail)) (setq tail (cdr tail))))) (fix-comment-? (car comments)) (cons (do-combine-comments comments matcher) (combine-comments tail)))) (t (fix-comment-? x) (let ((a (combine-comments (car x))) (d (combine-comments (cdr x)))) (if (and (eq a (car x)) (eq d (cdr x))) x (cons a d)))))) (defun comment-p (form) (and (consp form) (eq (car form) (quote il:*)) (consp (cdr form)) (member (cadr form) (quote (il:\; il:|;;| il:|;;;|)) :test (function eq)) t)) (defun comment-combineable-p (c1 c2) (il:* il:\; "Edited 10-Aug-88 10:19 by ht:") (and (eq (cadr c1) (cadr c2)) (not (initial-comment-line-p (caddr c2))))) (defun do-combine-comments (comments level) (il:* il:|;;| "COMMENTS is a list of sedit like comments at the same level") (il:bquote (il:* (il:\\\, level) (il:\\\, (apply (quote concatenate) (quote string) (with-collection (dolist (comment comments) (let ((string (third comment))) (when (> (length string) 0) (collect string) (collect " ")))))))))) (defun process-definitions (definitions type coms) (case type (:comment (nconc coms (nreverse definitions))) ((nil) (il:* il:|;;| "Untyped forms ") (nconc coms (il:bquote ((il:p (il:\\\,. (nreverse definitions))))))) (otherwise (il:* il:|;;| "Typed definitions") (nconc coms (il:bquote (((il:\\\, type) (il:\\\,. (let ((names nil) def) (loop (if (null (setq def (pop definitions))) (return names)) (push (%definer-name (car def) (remove-comments def)) names))))))))))) (defun definer-type (form) (cond ((comment-p form) :comment) ((and (consp form) (symbolp (car form)) (or (if (eq (car form) (quote eval-when)) :eval-when) (get (car form) :definer-for)))))) (defun find-definition (name type coms) (dolist (expr coms nil) (let ((first (car expr))) (cond ((eq first type) (if (member name (cdr expr) :test (quote equal)) (return t))) ((eq first (quote eval-when)) (if (find-definition name type (cddr expr)) (return t))) ((eq first (quote il:coms)) (if (find-definition name type (cdr expr)) (return t))))))) (il:* il:|;;| "From manager to text format ") (defun managed-to-text-file (filename pathname &key (package "USER" package-p) (readtable "LISP" readtable-p) (print-base 10 print-base-p) (linelength 72) (comments :preserve)) (let ((root-name (intern (string filename) (find-package "INTERLISP"))) mode-line package-form) (multiple-value-setq (package readtable print-base mode-line package-form) (construct-mode-line root-name package package-p readtable readtable-p print-base print-base-p)) (let ((*bridging* t) (*package* (find-package package)) (*readtable* (il:find-readtable readtable)) (*print-base* print-base) (*print-case* :downcase) (*print-array* t) (*print-level* nil) (*print-length* nil) (*print-structure* t) (il:* il:|;;| "Interlisp gorp that controls pretty printing") (il:*print-semicolon-comments* (or comments t)) (il:fontchangeflg nil) (il:\#rpars nil) (il:**comment**flg nil)) (declare (global il:filelinelength il:prettyflg)) (declare (special il:fontchangeflg il:\#rpars il:**comment**flg il:*print-semicolon-comments*)) (with-open-file (stream (make-pathname :type "LISP" :version :newest :defaults pathname) :direction :output) (il:linelength linelength stream) (il:resetvars (il:* il:|;;| "Interlisp gorp that controls pretty printing") ((il:filelinelength linelength) (il:prettyflg t)) (il:* il:|;;| "First printout mode-line") (format stream "~A~%" mode-line) (il:* il:|;;| "Identifier") (format stream "~2%;;; File converted on ~A from source ~A" (il:date) root-name) (let ((dates (get root-name (quote il:filedates)))) (when dates (format stream "~&~%;;; Original source ~A created ~A" (cdar dates) (caar dates)))) (terpri stream) (terpri stream) (il:* il:|;;| "Copyright notice") (let ((owner (get root-name (quote il:copyright)))) (when (and owner (consp owner)) (format stream "~&~%;;; Copyright (c) ") (do ((tail (cdr owner) (cdr tail))) ((null tail)) (format stream "~4d" (car tail)) (if (cdr tail) (princ ", " stream))) (format stream " by ~a~%" (car owner)))) (terpri stream) (il:* il:|;;| "Provide form") (pprint (il:bquote (provide (il:\\\, (string filename)))) stream) (terpri stream) (il:* il:|;;| "In-package form ") (and package-form (pprint package-form stream)) (format stream "~2%;;; Shadow, Export, Require, Use-package, and Import forms should follow here~2%") (dolist (com (symbol-value (il:filecoms root-name))) (dolist (form (get-coms-forms com stream)) (pprint form stream) (terpri stream) (il:block)))) (namestring stream))))) (defun construct-mode-line (root-name package package-p readtable readtable-p print-base print-base-p) (let* ((define-file-environment-form (let ((name (car (il:filecomslst root-name (quote file-environments))))) (and name (remove-comments (il:getdef name (quote file-environments) (quote il:current)))))) (makefile-environment (get root-name (quote il:makefile-environment))) (package-form (second (or (member :package define-file-environment-form :test (function eq)) (member :package makefile-environment :test (function eq))))) (readtable-form (second (or (member :readtable define-file-environment-form :test (function eq)) (member :readtable makefile-environment :test (function eq))))) (base-form (second (or (member :base define-file-environment-form :test (function eq)) (member :base makefile-environment :test (function eq))))) set-package-form mode-line-package-form mode-string) (when (and (null package-p) package-form) (setq package package-form)) (if (packagep package) (setq package (package-name package))) (setq set-package-form (cond ((stringp package) (setq mode-line-package-form package) (il:bquote (in-package (il:\\\, package)))) ((and (consp package) (eq (car package) (quote defpackage))) (let ((name (string (second package))) (use-list (cdr (assoc :use package :test (function eq)))) (nicknames (cdr (assoc :nicknames package :test (function eq)))) (exports (cdr (assoc :export package :test (function eq)))) form) (setq form (il:bquote (in-package (il:\\\, name) (il:\\\,@ (if use-list (il:bquote (:use (quote (il:\\\, use-list)))))) (il:\\\,@ (if nicknames (il:bquote (:nicknames (quote (il:\\\, nicknames))))))))) (setq package name) (setq mode-line-package-form (il:bquote ((il:\\\, package) (il:\\\,@ (if use-list (il:bquote (":USE" (il:\\\, use-list))))) (il:\\\,@ (if nicknames (il:bquote (":NICKNAMES" (il:\\\, nicknames)))))))) (if exports (il:bquote (progn (il:\\\, form) (export (quote (il:\\\, exports))))) form))) ((and (consp package) (eq (car package) (quote in-package))) (let ((name (string (second package))) (use-list (eval (cadr (member :use package :test (function eq))))) (nicknames (eval (cadr (member :nicknames package :test (function eq))))) form) (setq form package) (setq package name) (setq mode-line-package-form (il:bquote ((il:\\\, package) (il:\\\,@ (if use-list (il:bquote (":USE" (il:\\\, use-list))))) (il:\\\,@ (if nicknames (il:bquote (":NICKNAMES" (il:\\\, nicknames)))))))) form)) (t (error "Can't parse package form: ~s" package)))) (when (and (null readtable-p) readtable-form) (setq readtable readtable-form)) (if (readtablep readtable) (setq readtable (il:readtableprop readtable (quote il:name)))) (if (string= readtable "XCL") (setq readtable "LISP")) (when (and (null print-base-p) base-form) (setq print-base base-form)) (if (not (typep print-base (quote (integer 0 *)))) (error "Incorrect print-base form: ~s" print-base)) (setq mode-string (concatenate (quote string) ";;;-*- Package: " (princ-to-string mode-line-package-form) "; Syntax: " (if (string= readtable "LISP") "Common-Lisp" readtable) "; Mode: Lisp; Base: " (princ-to-string print-base) " -*-")) (values package readtable print-base mode-string set-package-form))) (defun get-coms-forms (command stream) (il:* il:\; "Edited 2-Aug-88 15:37 by ht:") (let ((unsupported-types (quote (il:fns il:specvars il:globalvars il:localvars il:initvars il:alists il:defs il:initrecords il:lispxmacros il:macros il:props il:records il:sysrecords il:usermacros il:vars il:constants export il:resources il:initresources il:globalresources il:i.s.oprs il:horriblevars il:uglyvars il:bitmaps il:cursors il:advice il:advise il:courierprograms il:templates))) (filepkgtype (car command))) (if (member filepkgtype unsupported-types :test (function eq)) (list (make-comment "Filepkg type ~s not supported: ~s" filepkgtype command)) (case filepkgtype (il:p (cdr command)) (il:e (il:* il:|;;| "done this way so the comment doesn't get in the way of any tricky printing done under the E") (pprint (make-semicolon-comment (format nil "~S" command) 1) stream) (let ((*standard-output* stream)) (mapc (function eval) (cdr command))) nil) (il:coms (il:* il:|;;| "Recurse") (mapcan (function (lambda (x) (get-coms-forms x stream))) (cdr command))) ((eval-when il:eval-when) (il:bquote ((eval-when (il:\\\, (mapcar (function (lambda (sym) (intern (string sym) (find-package "LISP")))) (second command))) (il:\\\,@ (mapcan (function (lambda (x) (get-coms-forms x stream))) (cddr command))))))) (il:declare\: (with-collection (let ((context (quote (load eval)))) (dolist (token (cdr command)) (case token ((il:copy il:docopy) (pushnew (quote load) context)) ((il:doeval@compile il:eval@compile) (pushnew (quote compile) context)) ((il:doeval@load il:eval@load) (pushnew (quote eval) context)) ((il:dontcopy) (setq context (remove (quote load) context))) ((il:donteval@compile) (setq context (remove (quote compile) context))) ((il:donteval@load) (setq context (remove (quote eval) context))) ((il:first il:notfirst il:eval@loadwhen il:eval@compilewhen il:copywhen il:compilervars) (il:* il:|;;| "IGNORE") (warn "Ignoring ~s declaration" token)) (otherwise (collect (il:bquote (eval-when (il:\\\, context) (il:\\\,@ (get-coms-forms token stream))))))))))) ((il:*) (il:* il:|;;| "Comment ") (list command)) (il:files (let ((file-names (mapcan (function (lambda (token) (if (not (consp token)) (list token)))) (remove-comments (cdr command))))) (il:bquote ((il:\\\, (make-comment "Translated ~s to require forms" command)) (il:\\\,@ (with-collection (dolist (file file-names) (collect (il:bquote (require (il:\\\, (string file)))))))))))) (il:prop (il:* il:|;;| "Throw out makefile props") (let ((props (second (remove-comments command)))) (if (not (listp props)) (setq props (list props))) (if (set-difference props (quote (il:filetype il:makefile-environment))) (make-comment "Ignoring prop ~s coms: ~s" props command)))) (t (il:* il:|;;| "Should the filepkgtype of a definer") (let ((ignored-definers (quote (file-environments il:define-types optimizers il:sedit-formats advised-functions il:commands il:special-forms profiles walker-templates))) (definer-type (il:getfilepkgtype filepkgtype (quote il:commands) t))) (if (member definer-type ignored-definers :test (function eq)) (unless (eq definer-type (quote file-environments)) (list (make-comment "Ignoring definer coms: ~s" command))) (let* ((get-def-method (and definer-type (get definer-type :defined-by) (get definer-type (quote il:getdef)))) (defs (and get-def-method (mapcar (function (lambda (name) (if (comment-p name) name (funcall get-def-method name definer-type)))) (cdr command))))) (setq defs (case definer-type (il:functions (il:* il:|;;| "Transform defdefiners to defmacros") (mapcan (function (lambda (def) (if (and (not (comment-p def)) (eq (car def) (quote defdefiner))) (let* ((cleaned-form (remove-comments def)) (name (second cleaned-form)) (definer-for (third cleaned-form)) (body (cdr (member definer-for def)))) (list (make-comment "Transforming defdefiner (~s ~s ~s ... ) to defmacro" (first def) (second def) (third def)) (il:bquote (defmacro (il:\\\, (if (consp name) (car name) name)) (il:\\\,@ body))))) (list def)))) defs)) (otherwise defs))) (or defs (list (make-comment "Can't parse: ~s" command))))))))))) (defun make-comment (&rest args) (apply (function warn) args) (make-semicolon-comment (apply (function format) nil args) 1)) (define-file-environment "XCL-BRIDGE" :package "XCL" :readtable "XCL" :compiler :compile-file) (il:* il:|;;| "comment identity preservation hack") (defparameter *preserve-comment-start-char* #\.) (defparameter *preserve-comment-start-charcode* 46 "used at beginning of comments to preserve comment start info if IL:*PRINT-SEMICOLON-COMMENTS* is :PRESERVE") (defun initial-comment-line-p (string) (il:* il:\; "Edited 10-Aug-88 10:17 by ht:") (and (> (length string) 0) (eq (char string 0) *preserve-comment-start-char*))) (defun fix-comment-? (x) (il:* il:\; "Edited 10-Aug-88 10:23 by ht:") (when (and (comment-p x) (initial-comment-line-p (caddr x))) (il:* il:|;;| "remove the preserve key char and the following spaces, if any") (il:gnc (caddr x)) (loop (if (eq (il:nthcharcode (caddr x) 1) 32) (il:gnc (caddr x)) (return))))) (reinstall-advice (quote (il:concat :in il:prin2-long-string)) :after (quote ((:last (cond ((eq il:*print-semicolon-comments* (quote :preserve)) (il:rplcharcode il:!value -1 *preserve-comment-start-charcode*))))))) (reinstall-advice (quote (il:prin1 :in il:prin2-long-string)) :after (quote ((:last (cond ((eq il:x il:semistring) (il:rplcharcode il:x -1 32))))))) (il:putprops il:xcl-bridge il:copyright ("Xerox Corporation" 1988 1989)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/lispusers/XORCURSORPATCH b/lispusers/XORCURSORPATCH new file mode 100644 index 00000000..1174f12f --- /dev/null +++ b/lispusers/XORCURSORPATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "19-Jul-88 11:37:37" {ERINYES}LYRIC>XORCURSORPATCH.\;1 1455 |changes| |to:| (VARS XORCURSORPATCHCOMS) |previous| |date:| " 7-Oct-86 18:56:37" {PHYLUM}KOTO>XORCURSORPATCH.\;1) ; Copyright (c) 1988 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT XORCURSORPATCHCOMS) (RPAQQ XORCURSORPATCHCOMS ((FNS DOVE.XOR.CURSOR) (INITVARS (|\\DoveDisplay.VideoColor| 1)) (GLOBALVARS |\\DoveDisplay.VideoColor|) (ADVISE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)))) (DEFINEQ (DOVE.XOR.CURSOR (LAMBDA (FLG) (* |cdl| " 7-Oct-86 18:56") (SELECTQ (MACHINETYPE) (DOVE (|if| (EQP |\\DoveDisplay.VideoColor| 1) |then| (|if| FLG |then| (SETQ |\\DoveDisplay.VideoColor| (|if| (NUMBERP FLG) |then| FLG |else| 9))) |else| (|if| (NULL FLG) |then| (SETQ |\\DoveDisplay.VideoColor| 1))) (|\\DoveDisplay.SetCursorMix| |\\DoveDisplay.VideoColor|) T) NIL)) ) ) (RPAQ? |\\DoveDisplay.VideoColor| 1) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS |\\DoveDisplay.VideoColor|) ) (XCL:REINSTALL-ADVICE (QUOTE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)) :AFTER (QUOTE ((:LAST (SELECTQ (MACHINETYPE) (DOVE (|if| (NOT INVERSE?) |then| (|\\DoveDisplay.SetCursorMix| |\\DoveDisplay.VideoColor|))) NIL))))) (READVISE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)) (PUTPROPS XORCURSORPATCH COPYRIGHT ("Xerox Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (585 967 (DOVE.XOR.CURSOR 595 . 965))))) STOP \ No newline at end of file diff --git a/lispusers/XORCursorPatch.TEdit b/lispusers/XORCursorPatch.TEdit new file mode 100644 index 00000000..80acd855 Binary files /dev/null and b/lispusers/XORCursorPatch.TEdit differ diff --git a/lispusers/XREF b/lispusers/XREF new file mode 100644 index 00000000..8e7484aa --- /dev/null +++ b/lispusers/XREF @@ -0,0 +1 @@ +(FILECREATED "18-Feb-87 15:48:37" {SUMEX-AIM}PS:XREF.;6 12717 changes to: (VARS XREF.DISPLAY.METHODS) (FNS XREF.IMAGEBOXFN INSERT.REF) previous date: " 5-Feb-87 14:57:51" {SUMEX-AIM}PS:XREF.;5) (* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) (PRETTYCOMPRINT XREFCOMS) (RPAQQ XREFCOMS ((* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (* An XREF is a general-purpose cross-referencing imageobject. In order to create an instance of an XREF one simply calls the function XREF with a TAG that is supposed to link it with some imageobject that it is referencing. In order to add to the class of imageobjects that can be referenced with XREF one uses the function XREF.ADD.DISPLAYFN with the type of the imageobject and a function that operates on it to return some string that XREF will then display in the document.) (FNS XREF XREFP XREF.DISPLAYFN XREF.IMAGEBOXFN XREF.PUTFN XREF.GETFN XREF.BUTTONEVENTINFN XREF.WHENDELETEDFN) (FNS XREF.GET.DISPLAY.TEXT XREF.GET.TOOBJ TSPOBJ.GETTYPE) (FNS UPDATE.XREFS REBUILD.TAG.ARRAY INSERT.REF GET.REF TSP.LIST.REFS XREF.TAG.OBJECT TSP.GET.INCODE TSP.GETCODEVAL TSP.PUTCODE) (* Functions for adding and retrieving the method for a gven imageobject.) (FNS XREF.ADD.DISPLAYFN XREF.GET.DISPLAYFN) (* Examples of some XREF display methods.) (FNS NGROUP.XREF.DISPLAYFN NOTE.XREF.DISPLAYFN) (UGLYVARS XREF.DISPLAY.METHODS))) (* Developed under support from NIH grant RR-00785.) (* Written by Frank Gilmurray and Sami Shaio.) (* An XREF is a general-purpose cross-referencing imageobject. In order to create an instance of an XREF one simply calls the function XREF with a TAG that is supposed to link it with some imageobject that it is referencing. In order to add to the class of imageobjects that can be referenced with XREF one uses the function XREF.ADD.DISPLAYFN with the type of the imageobject and a function that operates on it to return some string that XREF will then display in the document.) (DEFINEQ (XREF (LAMBDA (TAG) (* edited: "28-Jan-87 12:53") (* Returns a new XREF imageobject. The TAG argument is obligatory and should be the tag that is used to reference  the object that this XREF object is referencing.) (LET ((NEWOBJ (IMAGEOBJCREATE TAG (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN) (FUNCTION XREF.IMAGEBOXFN) (FUNCTION XREF.PUTFN) (FUNCTION XREF.GETFN) (FUNCTION NILL) (FUNCTION XREF.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))))) (IMAGEOBJPROP NEWOBJ 'TYPE 'XREF) NEWOBJ))) (XREFP (LAMBDA (OBJ) (* edited: "22-Jan-87 21:20") (* Test whether something is an XREF imageobject.) (AND (IMAGEOBJP OBJ) (EQ (IMAGEOBJPROP OBJ 'TYPE) 'XREF)))) (XREF.DISPLAYFN (LAMBDA (OBJ STREAM) (* edited: "22-Jan-87 21:09") (* General purpose display function for an XREF  imageobject. Relies on XREF.GET.DISPLAY.TEXT to get  the actual text that must be displayed.) (LET* ((TEXT.TO.DISPLAY (XREF.GET.DISPLAY.TEXT OBJ))) (PRIN3 TEXT.TO.DISPLAY STREAM)))) (XREF.IMAGEBOXFN (LAMBDA (OBJ STREAM) (* fsg "18-Feb-87 15:35") (* Returns the size of an XREF imageobject based on  the string that will be used to display it which is  found using XREF.GET.DISPLAY.TEXT.) (DSPFONT (CURRENT.DISPLAY.FONT STREAM) STREAM) (create IMAGEBOX XSIZE _(TEDIT.STRINGWIDTH (XREF.GET.DISPLAY.TEXT OBJ) STREAM) YSIZE _(FONTPROP STREAM 'HEIGHT) YDESC _(FONTPROP STREAM 'DESCENT) XKERN _ 0))) (XREF.PUTFN (LAMBDA (OBJ STREAM) (* edited: "28-Jan-87 12:54") (PRIN1 (LIST 'XREF (fetch OBJECTDATUM of OBJ)) STREAM))) (XREF.GETFN (LAMBDA (STREAM) (* edited: "28-Jan-87 13:14") (XREF (CADR (READ STREAM))))) (XREF.BUTTONEVENTINFN (LAMBDA (OBJ STREAM) (* edited: "28-Jan-87 14:51") (* Bogus buttoneventinfn to tell you what the tag of  this XREF object is.) (TEDIT.PROMPTPRINT STREAM (CONCAT "Reference to: " (fetch OBJECTDATUM of OBJ)) T))) (XREF.WHENDELETEDFN (LAMBDA (IMOBJ TARG.WINDOW.STREAM SOURCE.STR TARG.STR) (* fsg " 4-Feb-87 13:26") (TSP.PUTCODE (IMAGEOBJPROP IMOBJ 'TAG) NIL TARG.WINDOW.STREAM) (AND (UPDATE? TARG.WINDOW.STREAM) (UPDATE.XREFS TARG.WINDOW.STREAM)))) ) (DEFINEQ (XREF.GET.DISPLAY.TEXT (LAMBDA (OBJ) (* edited: "22-Jan-87 21:11") (* This function will first lookup a "TOOBJ", in other words, the imageobject that the XREF object OBJ is  referencing. Then, if there is such an object, a suitable XREF display method is found using XREF.GET.DISPLAYFN. If such a function is found, then it is applied to TOOBJ and a string to be displayed is returned.) (LET ((TOOBJ (XREF.GET.TOOBJ (fetch OBJECTDATUM of OBJ))) SPECIFIC.DISPLAYFN) (COND (TOOBJ (COND ((SETQ SPECIFIC.DISPLAYFN (XREF.GET.DISPLAYFN TOOBJ)) (APPLY* SPECIFIC.DISPLAYFN TOOBJ)) (T (RINGBELLS) (CONCAT "??? Unknown XREF display method for " (TSPOBJ.GETTYPE TOOBJ) " ???")))) (T (CONCAT "")))))) (XREF.GET.TOOBJ (LAMBDA (TAG) (* edited: "22-Jan-87 19:41") (* This function is called in a specific context where a reference must be displayed. It is called by an XREF  object and should return the IMAGEOBJECT that the XREF object is referencing.) (LET ((WINDOW (CAR (fetch \WINDOW of TEXTOBJ)))) (GETHASH TAG (WINDOWPROP WINDOW 'TSP.CODE.ARRAY))))) (TSPOBJ.GETTYPE (LAMBDA (OBJ) (* edited: "22-Jan-87 20:16") (IMAGEOBJPROP OBJ 'TYPE))) ) (DEFINEQ (UPDATE.XREFS (LAMBDA (WINDOW) (* edited: "22-Jan-87 21:05") (* Update all the XREF objects in the window.) (LET* ((TEXTOBJ (TEXTOBJ WINDOW)) (STREAM (TEXTSTREAM WINDOW))) (TEDIT.PROMPTPRINT STREAM "Updating XRefs..." T) (for REF in (TSP.LIST.OF.OBJECTS TEXTOBJ (FUNCTION XREFP)) do (TEDIT.OBJECT.CHANGED STREAM (CAR REF))) (TEDIT.PROMPTPRINT STREAM "done.")))) (REBUILD.TAG.ARRAY (LAMBDA (WINDOW) (* edited: "28-Jan-87 13:24") (for TAG in (TSP.LIST.OF.OBJECTS (TEXTOBJ WINDOW) (FUNCTION (LAMBDA (OBJ) (AND (NUMBEROBJP OBJ) (OR (IMAGEOBJPROP OBJ 'TAG) (EQ (fetch USE of (fetch OBJECTDATUM of OBJ)) 'NGROUP)))))) do (PROGN (SETQ TAG (CAR TAG)) (TSP.PUTCODE (OR (IMAGEOBJPROP TAG 'TAG) (fetch LINK.TO of (fetch OBJECTDATUM of TAG))) TAG WINDOW))))) (INSERT.REF (LAMBDA (STREAM DISPLAY.PREV) (* edited: "22-Jan-87 21:01") (LET* ((WINDOW (\TEDIT.MAINW STREAM)) (CODE (GET.REF WINDOW STREAM "Reference to: " DISPLAY.PREV)) (REF (XREF CODE))) (AND CODE (TEDIT.INSERT.OBJECT REF STREAM)) (TEDIT.PROMPTPRINT STREAM "" T)))) (GET.REF (LAMBDA (WINDOW STREAM PROMPTSTR DISPLAY.PREV) (* ss: " 9-Aug-85 14:49") (LET ((PREVREFS (TSP.LIST.REFS WINDOW))) (COND ((AND PREVREFS DISPLAY.PREV) (LET ((NMENU (create MENU TITLE _ "Known Ref Codes" ITEMS _ PREVREFS))) (MENU NMENU))) (T (MKATOM (TEDIT.GETINPUT STREAM "Reference to: "))))))) (TSP.LIST.REFS (LAMBDA (WINDOW) (* fsg "15-Jan-87 14:08") (* * Don't collect the Index or IndexEntry references here. Use the INDEX.LIST.REFS function.) (LET ((REFLIST NIL)) (MAPHASH (WINDOWPROP WINDOW 'TSP.CODE.ARRAY) (FUNCTION (LAMBDA (VAL KY) (SETQ REFLIST (CONS KY REFLIST))))) REFLIST))) (XREF.TAG.OBJECT (LAMBDA (OBJ STREAM TAG) (* fsg " 4-Feb-87 16:35") (* TAG an arbitrary imageobject for later cross-referencing. given an imageobject OBJ, a textstream STREAM, and a  tag TAG. If TAG is nil then the user will be asked for a tag via TSP.GET.INCODE.) (OR TAG (SETQ TAG (TSP.GET.INCODE WINDOW))) (IMAGEOBJPROP OBJ 'TAG TAG) (TSP.PUTCODE TAG OBJ WINDOW))) (TSP.GET.INCODE (LAMBDA (STREAM) (* ss: "24-Apr-86 15:46") (LET ((CODE (MKATOM (TEDIT.GETINPUT STREAM "Codeword to use as a tag:")))) (COND (CODE (COND ((TSP.GETCODEVAL CODE (\TEDIT.MAINW STREAM)) (TEDIT.PROMPTPRINT STREAM "[Codeword already in use: Please try again]") (TSP.GET.INCODE STREAM)) (T (TEDIT.PROMPTPRINT STREAM "" T) CODE))) (T (TEDIT.PROMPTPRINT STREAM "" T)))))) (TSP.GETCODEVAL (LAMBDA (CODE WINDOW) (* fsg " 4-Feb-87 14:32") (LET ((TSP.CODE.ARRAY (WINDOWPROP WINDOW 'TSP.CODE.ARRAY))) (GETHASH CODE TSP.CODE.ARRAY)))) (TSP.PUTCODE (LAMBDA (CODE VALUE WINDOW) (* fsg " 4-Feb-87 14:34") (PUTHASH CODE VALUE (LIST (WINDOWPROP WINDOW 'TSP.CODE.ARRAY))))) ) (* Functions for adding and retrieving the method for a gven imageobject.) (DEFINEQ (XREF.ADD.DISPLAYFN (LAMBDA (OBJTYPE NAME.OF.FUNCTION) (* edited: "22-Jan-87 21:08") (* Adds an XREF display method for an imageobject of the given type. This means that the function NAME.OF.FUNCTION  will be used to display text when an XREF object references an imageobject of type OBJTYPE.) (PUTHASH OBJTYPE NAME.OF.FUNCTION XREF.DISPLAY.METHODS))) (XREF.GET.DISPLAYFN (LAMBDA (OBJ) (* edited: "22-Jan-87 21:11") (* Returns the XREF display method for an imageobject  OBJ.) (GETHASH (fetch USE of (fetch OBJECTDATUM of OBJ)) XREF.DISPLAY.METHODS))) ) (* Examples of some XREF display methods.) (DEFINEQ (NGROUP.XREF.DISPLAYFN (LAMBDA (NGROUP) (* edited: "29-Jan-87 16:07") (* A sample XREF display method for NGROUP objects.) (MKSTRING (fetch NUMSTRING of (fetch OBJECTDATUM of NGROUP))))) (NOTE.XREF.DISPLAYFN (LAMBDA (OBJ) (* edited: "29-Jan-87 16:07") (* A sample XREF display method for NOTE objects.) (MKSTRING (fetch NUMSTRING of (fetch OBJECTDATUM of OBJ))))) ) (READVARS XREF.DISPLAY.METHODS) ({H(20 ERROR) 2 NGROUP.XREF.DISPLAYFN NGROUP NOTE.XREF.DISPLAYFN NOTE }) (PUTPROPS XREF COPYRIGHT ("Leland Stanford Junior University" 1987)) (DECLARE: DONTCOPY (FILEMAP ((7675) (2226 5527 (XREF 2236 . 3078) (XREFP 3080 . 3388) (XREF.DISPLAYFN 3390 . 3854) ( XREF.IMAGEBOXFN 3856 . 4491) (XREF.PUTFN 4493 . 4693) (XREF.GETFN 4695 . 4851) (XREF.BUTTONEVENTINFN 4853 . 5238) (XREF.WHENDELETEDFN 5240 . 5525)) (5528 7093 (XREF.GET.DISPLAY.TEXT 5538 . 6475) ( XREF.GET.TOOBJ 6477 . 6940) (TSPOBJ.GETTYPE 6942 . 7091)) (7094 NIL (UPDATE.XREFS 7104 . 7674))))) STOP TAG.ARRAY 7854 . 8516) (INSERT.REF 8520 . 8889) (GET.REF 8893 . 9308) (TSP.LIST.REFS 9312 . 9730) (XREF.TAG.OBJECT 9734 . 10217) (TSP.GET.INCODE 10221 . 10753) (TSP.GETCODEVAL 10757 . 10984) ( TSP.PUTCODE 10988 . 11179)) (11272 12087 (XREF.ADD.DISPLAYFN 11284 . 11708) (XREF.GET.DISPLAYFN 11712 . 12084)) (12145 12817 (NGROUP.XREF.DISPLAYFN 12157 . 12487) (NOTE.XREF.DISPLAYFN 12491 . 12814))))) STOP \ No newline at end of file diff --git a/lispusers/bsearch b/lispusers/bsearch new file mode 100644 index 00000000..77837f9c --- /dev/null +++ b/lispusers/bsearch @@ -0,0 +1 @@ +(FILECREATED " 7-May-84 23:19:59" {PHYLUM}LIBRARY>BSEARCH.;2 3724 changes to: (VARS BSEARCHCOMS) previous date: "30-Apr-84 19:59:49" {PHYLUM}LIBRARY>BSEARCH.;1) (* Copyright (c) 1983, 1984 by Xerox Corporation) (PRETTYCOMPRINT BSEARCHCOMS) (RPAQQ BSEARCHCOMS ((FNS BFILEPOS) (VARS \BFILEPOS.SHORTPATTERNL))) (DEFINEQ (BFILEPOS (LAMBDA (PATTERN FILE LOWINDEX HIGHINDEX SKIP TAIL CASEARRAY) (* JonL " 1-Jan-84 02:34") (OR (STRINGP PATTERN) (LITATOM PATTERN) (SETQ PATTERN (MKSTRING PATTERN))) (RESETLST (PROG ((PLEN (NCHARS PATTERN)) (INCREMENT 128) (FF (FUNCTION FILEPOS)) (OFPOS 0) ORIGINALLYOPENP FLEN QUARTERFLEN STARTI NEXTI MAXI TEM STRM) (if (SETQ TEM (OPENP FILE)) then (SETQ ORIGINALLYOPENP T) (SETQ STRM (\GETSTREAM TEM)) else (RESETSAVE (SETQ STRM (OPENSTREAM FILE (QUOTE INPUT))) (QUOTE (PROGN (CLOSEF? OLDVALUE))))) (SETQ FLEN (GETFILEINFO STRM (QUOTE LENGTH))) (if (IGREATERP 0 (SETQ MAXI (IDIFFERENCE FLEN PLEN))) then (* Who's he kidding? The PATTERN length is greater than  the file length) (RETURN)) (SETQ QUARTERFLEN (IMAX 2 (LRSH FLEN 2))) (SETQ OFPOS (GETFILEPTR STRM)) (if (NULL LOWINDEX) then (SETQ LOWINDEX OFPOS) elseif (ILESSP LOWINDEX 0) then (add LOWINDEX (ADD1 MAXI)) (if (ILESSP LOWINDEX 0) then (SETQ LOWINDEX 0)) elseif (IGREATERP LOWINDEX MAXI) then (RETURN)) (* Note that LOWINDEX really means low-end limit for  search) (if (NULL HIGHINDEX) then (SETQ HIGHINDEX MAX.FIXP) elseif (ILESSP HIGHINDEX 0) then (add HIGHINDEX (ADD1 MAXI))) (SETQ HIGHINDEX (IMIN HIGHINDEX MAXI)) (if (ILESSP HIGHINDEX LOWINDEX) then (ERROR "High-end index less than low-end")) (if ORIGINALLYOPENP then (RESETSAVE (LIST STRM OFPOS) (QUOTE (AND RESETSTATE (APPLY (QUOTE SETFILEPTR) OLDVALUE))))) (SETQ NEXTI) (SETQ STARTI (ADD1 HIGHINDEX)) (SETQ TAIL (if TAIL then PLEN else 0)) FINDFIRST (if NEXTI then (SETQ STARTI NEXTI) elseif (ILEQ STARTI LOWINDEX) then (* Looks like we never found any instance of the  PATTERN) (RETURN) else (SETQ MAXI (SUB1 STARTI)) (SETQ STARTI (IMAX (PROG1 LOWINDEX (* Comment PPLossage)) (IDIFFERENCE STARTI (if (ILESSP INCREMENT QUARTERFLEN) then (PROG1 INCREMENT (SETQ INCREMENT (LLSH INCREMENT 1) )) else QUARTERFLEN)))) (SETQ NEXTI (FFILEPOS PATTERN STRM STARTI MAXI SKIP NIL CASEARRAY)) (GO FINDFIRST)) NARROWDOWN (* At this point, we have one instance found at STARTI  and certification that none occur at or beyond MAXI) (SETQ NEXTI (IPLUS STARTI (LRSH (IDIFFERENCE MAXI STARTI) 1))) (if (IEQP NEXTI STARTI) then (RETURN (IPLUS STARTI TAIL))) (if (SETQ TEM (FFILEPOS PATTERN STRM NEXTI MAXI SKIP NIL CASEARRAY)) then (SETQ STARTI TEM) else (SETQ MAXI NEXTI)) (GO NARROWDOWN))))) ) (RPAQQ \BFILEPOS.SHORTPATTERNL 16) (PUTPROPS BSEARCH COPYRIGHT ("Xerox Corporation" 1983 1984)) (DECLARE: DONTCOPY (FILEMAP (NIL (364 3601 (BFILEPOS 374 . 3599))))) STOP \ No newline at end of file diff --git a/lispusers/canvasconverter b/lispusers/canvasconverter new file mode 100644 index 00000000..80d2e472 --- /dev/null +++ b/lispusers/canvasconverter @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "13-Oct-87 16:32:42" |{ABLAGE2:49/89/636/13:SIEMENS AG}TOOLS>CANVASCONVERTER.;4| |previous| |date:| " 7-Sep-87 11:16:38" |{ABLAGE2:49/89/636/13:SIEMENS AG}TOOLS>CANVASCONVERTER.;2|) ; Copyright (c) 1987 by Steve Knowles. All rights reserved. (PRETTYCOMPRINT CANVASCONVERTERCOMS) (RPAQQ CANVASCONVERTERCOMS ((FNS FETCHCANVAS VECLENGTH CALCULATEBYTES CALCULATEWIDTHBYTES CANVAS-FROM-WINDOW CALCULATEHEIGHTFACTOR1 CALCULATEHEIGHTFACTOR2 CALCULATEWIDTHFACTOR1 CALCULATEWIDTHFACTOR2 WRITECANVAS SNAPBM) (VARS BYTESPERWORD) (FILES BITMAPFNS))) (DEFINEQ (FETCHCANVAS (LAMBDA (|file|) (* |edited:| " 9-Dec-86 17:59") (* |created| |by:| |Giselbert|  |Schramm|) (* |Departement:| ZT ZTI SOF 232) (* |Creation| |Date:| "20-Jun-86 20:16") (* * |Reads| |the| |width| |and| |heigth| |of| |the| |bitmap| |in| \a |given|  |Canvas-file,| |extracts| |the| |bitmap| |using| |the| READBINARYBITMAP  |function| |and| |returns| |the| |bitmap| |as| \a |result|) (PROG (|saveinput| |bmwidth| |bmhigth| |result|) (SETQ |saveinput| (INFILE |file|)) (SETFILEPTR |file| 56) (PRINT (CONCAT "FILEPTR > " (GETFILEPTR |file|)) PROMPTWINDOW) (SETQ |bmwidth| (IDIFFERENCE (IPLUS (ITIMES (BIN) 256) (BIN)) 4000)) (PRINT (CONCAT "FILEPTR > " (GETFILEPTR |file|)) PROMPTWINDOW) (SETQ |bmhigth| (IDIFFERENCE (IPLUS (ITIMES (BIN) 256) (BIN)) 4000)) (PRINT (CONCAT "FILEPTR > " (GETFILEPTR |file|)) PROMPTWINDOW) (PRINT (CONCAT "width: " |bmwidth| " heigth: " |bmhigth|) PROMPTWINDOW) (SETFILEPTR |file| (IPLUS (GETFILEPTR |file|) 32)) (PRINT (CONCAT "FILEPTR > " (GETFILEPTR |file|)) PROMPTWINDOW) (SETQ |result| (READBINARYBITMAP |bmwidth| |bmhigth|)) (INPUT |saveinput|) (CLOSEF |file|) (RETURN |result|)))) (VECLENGTH (LAMBDA (WIDTH HEIGHT) (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:38") (* (VECLENGTH 192 174) |edited:|  "13-Aug-87 14:28") (IPLUS 4 (IQUOTIENT (ITIMES HEIGHT (ITIMES (IQUOTIENT (IPLUS WIDTH 31) 32) 32)) 8)))) (CALCULATEBYTES (LAMBDA (N) (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:38") (SETQ FIRSTBYTE (IQUOTIENT N 65536)) (SETQ SECONDBYTE (IQUOTIENT (IMOD N 65536) 256)) (SETQ THIRDBYTE (IMOD N 256)))) (CALCULATEWIDTHBYTES (LAMBDA NIL (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:38") (SETQ FIRSTWIDTHBYTE (IQUOTIENT BMWIDTH 256)) (SETQ SECONDWIDTHBYTE (IMOD BMWIDTH 256)))) (CANVAS-FROM-WINDOW (LAMBDA (WINDOW FILE) (* |edited:| "26-Aug-87 12:02") (LET* ((WINDOWREGION (WINDOWPROP WINDOW 'REGION)) (HEIGHT (CADDDR WINDOWREGION)) (WIDTH (CADDR WINDOWREGION)) (COPYBITMAP (BITMAPCREATE WIDTH HEIGHT))) (BITBLT WINDOW 0 0 COPYBITMAP) (WRITECANVAS COPYBITMAP FILE)))) (CALCULATEHEIGHTFACTOR1 (LAMBDA NIL (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:37") (QUOTIENT (PLUS BMHEIGHT 4000) 256))) (CALCULATEHEIGHTFACTOR2 (LAMBDA NIL (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:37") (DIFFERENCE (PLUS BMHEIGHT 4000) (TIMES (QUOTIENT (PLUS BMHEIGHT 4000) 256) 256)))) (CALCULATEWIDTHFACTOR1 (LAMBDA NIL (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:37") (QUOTIENT (PLUS BMWIDTH 4000) 256))) (CALCULATEWIDTHFACTOR2 (LAMBDA NIL (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:37") (DIFFERENCE (PLUS BMWIDTH 4000) (TIMES (QUOTIENT (PLUS BMWIDTH 4000) 256) 256)))) (WRITECANVAS (LAMBDA (BITMAP FILE) (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 11:13") (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:35") (PROG (COPYBITMAP BMHEIGHT BMWIDTH HEIGHTFACTOR1 HEIGHTFACTOR2 WIDTHFACTOR1 WIDTHFACTOR2 OUTFILE FIRSTBYTE SECONDBYTE THIRDBYTE FIRSTWIDTHBYTE SECONDWIDTHBYTE) (SETQ BMHEIGHT (BITMAPHEIGHT BITMAP)) (SETQ BMWIDTH (BITMAPWIDTH BITMAP)) (SETQ COPYBITMAP (BITMAPCREATE (ITIMES (IQUOTIENT (IPLUS BMWIDTH 31) 32) 32) BMHEIGHT)) (BITBLT BITMAP 0 0 COPYBITMAP) (SETQ HEIGHTFACTOR1 (CALCULATEHEIGHTFACTOR1)) (SETQ HEIGHTFACTOR2 (CALCULATEHEIGHTFACTOR2)) (SETQ WIDTHFACTOR1 (CALCULATEWIDTHFACTOR1)) (SETQ WIDTHFACTOR2 (CALCULATEWIDTHFACTOR2)) (CALCULATEBYTES (VECLENGTH BMWIDTH BMHEIGHT)) (CALCULATEWIDTHBYTES) (SETQ OUTFILE (OPENSTREAM FILE 'OUTPUT)) (|for| I |in| '(73 110 116 101 114 112 114 101 115 115 47 88 101 114 111 120 47 50 46 49 47 82 97 115 116 101 114 69 110 99 111 100 105 110 103 47 49 46 48 32 160 102 196 6 0 0 254 10 252 128 160 181 15 162 161 27) |do| (BOUT OUTFILE I)) (BOUT OUTFILE WIDTHFACTOR1) (BOUT OUTFILE WIDTHFACTOR2) (BOUT OUTFILE HEIGHTFACTOR1) (BOUT OUTFILE HEIGHTFACTOR2) (BOUT OUTFILE 15) (BOUT OUTFILE 160) (BOUT OUTFILE HEIGHTFACTOR1) (BOUT OUTFILE HEIGHTFACTOR2) (BOUT OUTFILE WIDTHFACTOR1) (BOUT OUTFILE WIDTHFACTOR2) (|for| I |in| '(15 161 15 161 15 160 15 70 160 163 15 160) |do| (BOUT OUTFILE I)) (BOUT OUTFILE HEIGHTFACTOR1) (BOUT OUTFILE HEIGHTFACTOR2) (|for| I |in| '(160 162 160 165 233) |do| (BOUT OUTFILE I)) (BOUT OUTFILE FIRSTBYTE) (BOUT OUTFILE SECONDBYTE) (BOUT OUTFILE THIRDBYTE) (BOUT OUTFILE 0) (BOUT OUTFILE 1) (BOUT OUTFILE FIRSTWIDTHBYTE) (BOUT OUTFILE SECONDWIDTHBYTE) (WRITEBINARYBITMAP COPYBITMAP OUTFILE) (|for| I |in| '(161 194 15 160 15 161 15 160 15 163 161 27 197 5 120 101 114 111 120 197 10 71 114 97 121 76 105 110 101 97 114 15 162 161 27 161 166 160 231 197 4 110 97 109 101 193 10 66 105 103 65 80 83 73 99 111 110 197 12 99 114 101 97 116 105 111 110 84 105 109 101 193 25 49 57 56 55 32 48 56 32 48 51 32 49 53 58 52 55 58 50 51 45 48 53 58 48 48 15 164 161 27 66 190 160 103) |do| (BOUT OUTFILE I)) (CLOSEF OUTFILE) (SETFILEINFO FILE 'TYPE 4428) (RETURN "Canvas has been written.")))) (SNAPBM (LAMBDA NIL (*  "edited by Steve Knowles, Siemens AG:"  " 7-Sep-87 10:36") (PROG (BM REG) (SETQ REG (GETREGION)) (SETQ BM (BITMAPCREATE (|fetch| WIDTH |of| REG) (|fetch| HEIGHT |of| REG))) (BITBLT (SCREENBITMAP) (|fetch| LEFT |of| REG) (|fetch| BOTTOM |of| REG) BM) (RETURN BM)))) ) (RPAQQ BYTESPERWORD 2) (FILESLOAD BITMAPFNS) (PUTPROPS CANVASCONVERTER COPYRIGHT ("Steve Knowles" 1987)) STOP \ No newline at end of file diff --git a/lispusers/chatemacs.el b/lispusers/chatemacs.el new file mode 100644 index 00000000..2d5c4172 --- /dev/null +++ b/lispusers/chatemacs.el @@ -0,0 +1 @@ +;; GNU Emacs code for Interlisp-D mouse using CHATEMACS. ;; Copyright (C) Free Software Foundation March 1987. ;; This file is part of GNU Emacs. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. ;; Everyone is granted permission to copy, modify and redistribute ;; GNU Emacs, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. ;;; Original version by John Robinson (jr@bbn-unix.arpa, bbncca!jr), Oct 1985 ;;; Adapted from code for BBN Bitgraph by Randy Gobbel, March 1987 ;;; User customization option: (defconst shift 1) (defconst control 2) (defconst shift-control 3) (defconst meta 4) (defconst left 4) (defconst middle 1) (defconst right 2) (defvar il-mouse-kill-emacs (symbol-function 'kill-emacs)) (defvar il-mouse-fast-select-window t "*Non-nil for mouse hits to select new window, then execute; else just select.") (defvar scrollbar-enabled t "Non-nil to use last column as scrollbar") (defvar auto-switch-enabled nil "Non-nil to send init string to terminal") (defvar save-screen-width (screen-width)) (defvar save-screen-height (screen-height)) ;;; Defuns: (defun il-mouse-report () "Read Interlisp ChatEmacs mouse report, branch to appropriate sub-handler." (interactive) (let ((sub-char (read-char))) (cond ((= sub-char ?s) (il-set-screen-size)) ((= sub-char ?m) (il-mouse-command)))) ) (defun il-set-screen-size () (let ((cur-screen-width (il-get-tty-num ?\;)) (cur-screen-height (il-get-tty-num ?\;))) (or (= cur-screen-width save-screen-width) (progn (setq save-screen-width cur-screen-width) (set-screen-width cur-screen-width))) (or (= cur-screen-height save-screen-height) (progn (setq save-screen-height cur-screen-height) (set-screen-height cur-screen-height))) ) ) (defun il-mouse-command () "Read and parse Interlisp ChatEmacs mouse report, and do what it asks. L-- move point * |---- These apply for mouse click in a window. --R set mark * | If il-mouse-fast-select-window is nil, -C- depends on shift * | just selects that window. middle-button actions: shift: yank region to point control: kill region shift-control: copy region to killbuffer on modeline on \"scroll bar\" in minibuffer L-- split-vertical line to top execute-extended-command --R split-horizontal line to bottom eval-expression -C- delete-window goto-char proportional suspend-emacs Meta-mouse-button actions are same as scrollbar." (interactive) ;; (il-get-tty-num ?\;) (let* ((x (min (1- (screen-width)) (il-get-tty-num ?\;))) (y (min (1- (screen-height)) (il-get-tty-num ?\;))) (buttons (il-get-tty-num ?\;)) (bucky-bits (il-get-tty-num ?\;)) (window (il-pos-to-window x y)) (edges (window-edges window)) (old-window (selected-window)) (in-minibuf-p (eq y (1- (screen-height)))) (same-window-p (and (not in-minibuf-p) (eq window old-window))) (in-modeline-p (eq y (1- (nth 3 edges)))) (in-scrollbar-p (>= x (1- (nth 2 edges))))) (setq x (- x (nth 0 edges))) (setq y (- y (nth 1 edges))) (cond (in-modeline-p (select-window window) (cond ((= buttons left) (split-window-vertically)) ((= buttons right) (delete-window)) ((= buttons middle) (split-window-horizontally)))) ((or (and scrollbar-enabled in-scrollbar-p) (eq bucky-bits meta)) (select-window window) (cond ((= buttons left) (scroll-up y)) ((= buttons right) (scroll-down y)) ((= buttons middle) (goto-char (* y (/ (- (point-max) (point-min)) (1- (window-height))))) (beginning-of-line) (what-cursor-position))) (select-window old-window)) (same-window-p (il-button-command x y buttons bucky-bits)) (in-minibuf-p (cond ((= buttons middle) (call-interactively 'eval-expression)) ((= buttons left) (call-interactively 'execute-extended-command)) ((= buttons right) (suspend-emacs)) )) (t ;in another window (select-window window) (cond ((not il-mouse-fast-select-window)) (t (il-button-command x y buttons bucky-bits))) )))) (defun il-button-command (x y buttons bucky-bits) (cond ((= buttons left) (cond ((eq bucky-bits 0) (il-move-point-to-x-y x y)) ((eq bucky-bits control) (push-mark) (il-move-point-to-x-y x y) (kill-region (mark) (point))) ((eq bucky-bits shift) (copy-region-as-kill (mark) (point)) (il-move-point-to-x-y x y) (setq this-command 'yank) (yank)) ((eq bucky-bits shift-control) (kill-region (mark) (point)) (il-move-point-to-x-y x y) (setq this-command 'yank) (yank)) ) ) ; ((= buttons middle) ; (cond ((eq bucky-bits 0) ; (il-move-point-to-x-y x y) ; (il-balance-beam-word) ; (mark-word 1)) ; ((eq bucky-bits control) ; (il-balance-beam-word) ; (push-mark) ; (il-move-point-to-x-y x y) ; (mark-word 1) ; (kill-region (mark) (point))) ; ((eq bucky-bits shift) ; (il-move-point-to-x-y x y) ; (backward-word) ; (setq this-command 'yank) ; (yank)) ; ((eq bucky-bits shift-control) ; (push-mark) ; (il-move-point-to-x-y x y) ; (backward-word) ; (copy-region-as-kill (mark) (point))) ; ) ; ) ((= buttons right) (push-mark) (il-move-point-to-x-y x y) (if (eq bucky-bits control) (kill-region (mark) (point)) (progn (sit-for 1) (exchange-point-and-mark)) ) ) ) ) ;(defun il-balance-beam-word () ; (let (left-distance left-point right-point (start-point (point))) ; (save-excursion ; (backward-word 1) ; (setq left-point (point)) ; (setq left-distance (- start-point (point))) ; (forward-word 1) ; (setq right-point (point))) ; (if (<= left-distance (- (point) start-point)) left-point right-point) ; ) ; ) (defun il-get-tty-num (term-char) "Read from terminal until TERM-CHAR is read, and return intervening number. Upon non-numeric not matching TERM-CHAR, signal an error." (let ((num 0) (char (- (read-char) 48))) (while (and (>= char 0) (<= char 9)) (setq num (+ (* num 10) char)) (setq char (- (read-char) 48))) (or (eq term-char (+ char 48)) ; (progn ; (il-program-mouse) (error "Invalid data format in mouse command")) num)) ;(defun il-move-point-to-x-y (x y) ; "Position cursor in window coordinates. ;X and Y are 0-based character positions in the window." ; (move-to-window-line y) ; (move-to-column x) ; ) (defun il-move-point-to-x-y (x y) "Move cursor to window location X, Y. Handles wrapped and horizontally scrolled lines correctly." (move-to-window-line y) ;; window-line-end expects this to return the window column it moved to. (let ((cc (current-column)) (nc (move-to-column (if (zerop (window-hscroll)) (+ (current-column) (min (- (window-width) 2) ; To stay on the line. x)) (+ (window-hscroll) -1 (min (1- (window-width)) ; To stay on the line. x)))))) (- nc cc))) (defun il-pos-to-window (x y) "Find window corresponding to screen coordinates. X and Y are 0-based character positions on the screen." (let ((edges (window-edges)) (window nil)) (while (and (not (eq window (selected-window))) (or (< y (nth 1 edges)) (>= y (nth 3 edges)) (< x (nth 0 edges)) (>= x (nth 2 edges)))) (setq window (next-window window)) (setq edges (window-edges window)) ) (or window (selected-window)) ) ) (defun suspend-hook-fn () (interactive) (send-string-to-terminal "\e0") nil ) (defun suspend-resume-hook-fn () (interactive) (send-string-to-terminal "\e1") nil ) (global-set-key "\C-\\" 'il-mouse-report) (if auto-switch-enabled (progn (send-string-to-terminal "\e1") (defun kill-emacs () (interactive) (send-string-to-terminal "\e0") (funcall il-mouse-kill-emacs) ) (setq suspend-hook (symbol-function 'suspend-hook-fn)) (setq suspend-resume-hook (symbol-function 'suspend-resume-hook-fn)) ) ) \ No newline at end of file diff --git a/lispusers/chatemacs.elc b/lispusers/chatemacs.elc new file mode 100644 index 00000000..7cc7ce29 Binary files /dev/null and b/lispusers/chatemacs.elc differ diff --git a/lispusers/circlprint.tedit b/lispusers/circlprint.tedit new file mode 100644 index 00000000..a437edd1 --- /dev/null +++ b/lispusers/circlprint.tedit @@ -0,0 +1,20 @@ +1 LISP LIBRARY PACKAGES MANUAL 1 LISP LIBRARY PACKAGES MANUAL CIRCLPRINT 1 INPUT/OUTPUT 1 CIRCLPRINT 6 HPRINT is designed primarily for dumping circular or reentrant list structures (as well as other data structures for which READ is not an inverse of PRINT) so that they can be read back in by Interlisp. The CIRCLPRINT package is designed for printing circular or reentrant structures so that the user can look at them and understand them. A reentrant list structure is one that contains more than one occurrence of the same EQ structure. For example, TCONC makes use of reentrant list structure so that it does not have to search for the end of the list each time it is called. Thus, if X is a list of three elements, (A B C), being constructed by TCONC, the reentrant list structure used by TCONC for this purpose is: ((SKETCH NIL SKETCHCONTEXT ((ROUND 2 0) (MODERN 12 (BOLD REGULAR REGULAR)) (CENTER CENTER) ( CLOSEDLINE 10 12) NIL LAST (CENTER CENTER) (NIL NIL) T NIL NIL 1.0)) ((0.0 22.0 NIL) (WIRE (( 68.0 . 180.0) (68.0 . 136.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((0.0 12.0 NIL) (WIRE ((80.0 . 136.0) (80.0 . 112.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.024 24.0 NIL) (BOX (56.0 112.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((.05 14.0 NIL) (TEXT ( 68.0 . 124.0) ("A") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((63.5 117.0 9.0 14.0)) NIL)) ((0.0 30.0 NIL) (WIRE ((92.0 . 124.0) (152.0 . 124.0)) (ROUND 2.0 0) (NIL ( CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((0.0 12.0 NIL) (WIRE ((80.0 . 192.0) (80.0 . 168.0)) ( ROUND 1 0) NIL (6 3 1 3) 1.0)) ((0.0 84.0 NIL) (WIRE ((92.0 . 180.0) (260.0 . 180.0) (260.0 . 136.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((.024 24.0 NIL) (BOX ( 56.0 168.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((.024 24.0 NIL) (BOX (152.0 112.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((.05 14.0 NIL) (TEXT (164.0 . 124.0) ("B") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((160.5 117.0 7.0 14.0)) NIL)) ((0.0 12.0 NIL) (WIRE ((176.0 . 136.0) (176.0 . 112.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((0.0 30.0 NIL) (WIRE ((188.0 . 124.0) (248.0 . 124.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((.05 14.0 NIL) (TEXT (260.0 . 124.0) ("C") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((256.5 117.0 7.0 14.0)) NIL)) ((0.0 12.0 NIL) (WIRE ((272.0 . 136.0) ( 272.0 . 112.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.05 10.0 NIL) (TEXT (284.0 . 124.0) ("NIL" ) 1.0 (CENTER CENTER) (MODERN 6 (BOLD REGULAR REGULAR)) ((279.0 119.0 10.0 10.0)) NIL)) (( .024 24.0 NIL) (BOX (248.0 112.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL)))) (55.0 109.0 242.0 86.0) 1.0 4.0 This structure would be printed by PRINT as ((A B C) C). Note that PRINT would produce the same output for the nonreentrant structure: ((SKETCH NIL SKETCHCONTEXT ((ROUND 2 0) (MODERN 12 (BOLD REGULAR REGULAR)) (CENTER CENTER) ( CLOSEDLINE 10 12) NIL LAST (CENTER CENTER) (NIL NIL) T NIL NIL 1.0)) ((.024 24.0 NIL) (BOX ( 152.0 72.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((.05 10.0 NIL) (TEXT (188.0 . 84.0) ("NIL") 1.0 (CENTER CENTER) (MODERN 6 (BOLD REGULAR REGULAR)) ((183.0 79.0 10.0 10.0)) NIL)) ((0.0 12.0 NIL) (WIRE ((176.0 . 96.0) (176.0 . 72.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.05 14.0 NIL) (TEXT (164.0 . 84.0) ("C") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((160.5 77.0 7.0 14.0)) NIL)) ((0.0 30.0 NIL) (WIRE ((92.0 . 84.0) (152.0 . 84.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((.024 24.0 NIL) (BOX (56.0 72.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 12.0 NIL) (WIRE ((80.0 . 96.0) (80.0 . 72.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((0.0 22.0 NIL) (WIRE ((68.0 . 84.0) (68.0 . 40.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((0.0 12.0 NIL) (WIRE ((80.0 . 40.0) (80.0 . 16.0) ) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.024 24.0 NIL) (BOX (56.0 16.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 12.0 NIL) (WIRE ((176.0 . 40.0) (176.0 . 16.0)) (ROUND 1 0) NIL ( 6 3 1 3) 1.0)) ((.024 24.0 NIL) (BOX (152.0 16.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((.05 14.0 NIL) (TEXT (68.0 . 28.0) ("A") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((63.5 21.0 9.0 14.0)) NIL)) ((0.0 30.0 NIL) (WIRE ((92.0 . 28.0) (152.0 . 28.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((.05 14.0 NIL) (TEXT (164.0 . 28.0) ("B") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((160.5 21.0 7.0 14.0)) NIL)) ((0.0 30.0 NIL) (WIRE ((188.0 . 28.0) (248.0 . 28.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((.05 14.0 NIL) (TEXT (260.0 . 28.0) ("C") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((256.5 21.0 7.0 14.0)) NIL)) ((.024 24.0 NIL) (BOX (248.0 16.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 12.0 NIL) (WIRE ((272.0 . 40.0) (272.0 . 16.0) ) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.05 10.0 NIL) (TEXT (284.0 . 28.0) ("NIL") 1.0 (CENTER CENTER) (MODERN 6 (BOLD REGULAR REGULAR)) ((279.0 23.0 10.0 10.0)) NIL))) (55.0 13.0 242.0 86.0) 1.0 4.0 In other words, PRINT does not indicate the fact that portions of the structure in the first figure are identical. Similarly, if PRINT is applied to a circular list structure (a special type of reentrant structure) it will never terminate. For example, if PRINT is called on the structure: ((SKETCH NIL SKETCHCONTEXT ((ROUND 2 0) (MODERN 12 (BOLD REGULAR REGULAR)) (CENTER CENTER) ( CLOSEDLINE 10 12) NIL LAST (CENTER CENTER) (NIL NIL) T NIL NIL 1.0)) ((0.0 12.0 NIL) (WIRE (( 76.0 . -8.0) (76.0 . -32.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((0.0 14.0 NIL) (WIRE ((64.0 . -20.0) (64.0 . -48.0) (36.0 . -48.0) (36.0 . -20.0) (52.0 . -20.0)) (ROUND 2 0) (NIL ( CLOSEDLINE 10 12.0) T) NIL 1.0)) ((.05 10.0 NIL) (TEXT (88.0 . -20.0) ("NIL") 1.0 (CENTER CENTER) (MODERN 6 (BOLD REGULAR REGULAR)) ((83.0 -25.0 10.0 10.0)) NIL)) ((.024 24.0 NIL) ( BOX (52.0 -32.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL)))) (32.0 -52.0 69.0 47.0) 1.0 4.0 it will print an endless sequence of left parentheses, and if applied to: ((SKETCH NIL SKETCHCONTEXT ((ROUND 2 0) (MODERN 12 (BOLD REGULAR REGULAR)) (CENTER CENTER) ( CLOSEDLINE 10 12) NIL LAST (CENTER CENTER) (NIL NIL) T NIL NIL 1.0)) ((.05 14.0 NIL) (TEXT ( 156.0 . -20.0) ("A") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((151.5 -27.0 9.0 14.0)) NIL)) ((0.0 40.0 NIL) (WIRE ((180.0 . -20.0) (208.0 . -20.0) (208.0 . -44.0) (128.0 . -44.0) (128.0 . -20.0) (144.0 . -20.0)) (ROUND 2 0) (NIL (CLOSEDLINE 10 12.0) T) NIL 1.0) ) ((0.0 12.0 NIL) (WIRE ((168.0 . -8.0) (168.0 . -32.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) (( .024 24.0 NIL) (BOX (144.0 -32.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL)))) (124.0 -48.0 88.0 43.0) 1.0 4.0 will print a left parenthesis followed by an endless sequence of A's. The function CIRCLPRINT described below produces output that will exactly describe the structure of any circular or reentrant list structure. This output may be in either single- or double-line format. Below are a few examples of the expressions that CIRCLPRINT would produce to describe the structures discussed above. First figure, single-line: ((A B *1* C)1) First figure, double-line: ((A B C) 1) 1 Third figure, single-line: (*1* 1) Third figure, double-line: (1) 1 Fourth figure, single-line: (*1* A . 1) Fourth figure, double-line: (A . 1) 1 The more complex structure: ((SKETCH NIL SKETCHCONTEXT ((ROUND 2 0) (MODERN 12 (BOLD REGULAR REGULAR)) (CENTER CENTER) ( CLOSEDLINE 10 12) NIL LAST (CENTER CENTER) (NIL NIL) T NIL NIL 1.0)) ((.024 24.0 NIL) (BOX ( 60.0 -96.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 90.0 NIL) (WIRE ((96.0 . -84.0) (276.0 . -84.0) (276.0 . -128.0)) (ROUND 2 0) (NIL (CLOSEDLINE 10 12.0) T) NIL 1.0)) ((0.0 12.0 NIL) (WIRE ((84.0 . -72.0) (84.0 . -96.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((0.0 22.0 NIL) (WIRE ((72.0 . -84.0) (72.0 . -128.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((0.0 52.0 NIL) (WIRE ((140.0 . -140.0) (140.0 . -176.0) (36.0 . -176.0) (36.0 . -84.0) (60.0 . -84.0)) (ROUND 2 0) (NIL (CLOSEDLINE 10 12.0) T) NIL 1.0)) ((0.0 12.0 NIL) ( WIRE ((84.0 . -128.0) (84.0 . -152.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.024 24.0 NIL) (BOX (60.0 -152.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 14.0 NIL) (WIRE ((72.0 . -140.0) (72.0 . -168.0) (44.0 . -168.0) (44.0 . -140.0) (60.0 . -140.0)) (ROUND 2 0) (NIL ( CLOSEDLINE 10 12.0) T) NIL 1.0)) ((0.0 16.0 NIL) (WIRE ((96.0 . -140.0) (128.0 . -140.0)) ( ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((0.0 12.0 NIL) (WIRE ((152.0 . -128.0) (152.0 . -152.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((0.0 16.0 NIL) (WIRE ((164.0 . -140.0) (196.0 . -140.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) ((.024 24.0 NIL) ( BOX (128.0 -152.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 74.0 NIL) (WIRE ((300.0 . -140.0) (300.0 . -168.0) (152.0 . -168.0) (152.0 . -152.0)) (ROUND 2 0) (NIL (CLOSEDLINE 10 12.0) T) NIL 1.0)) ((0.0 12.0 NIL) (WIRE ((220.0 . -128.0) (220.0 . -152.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.05 14.0 NIL) (TEXT (208.0 . -140.0) ("A") 1.0 (CENTER CENTER) ( MODERN 12 (BOLD REGULAR REGULAR)) ((203.5 -147.0 9.0 14.0)) NIL)) ((0.0 16.0 NIL) (WIRE (( 232.0 . -140.0) (264.0 . -140.0)) (ROUND 2.0 0) (NIL (CLOSEDLINE 10.0 12.0)) NIL 1.0)) (( .024 24.0 NIL) (BOX (196.0 -152.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((0.0 12.0 NIL ) (WIRE ((288.0 . -128.0) (288.0 . -152.0)) (ROUND 1 0) NIL (6 3 1 3) 1.0)) ((.024 24.0 NIL) (BOX (264.0 -152.0 48.0 24.0) (ROUND 1 0) NIL 1.0 (NIL NIL))) ((.05 14.0 NIL) (TEXT ( 276.0 . -140.0) ("B") 1.0 (CENTER CENTER) (MODERN 12 (BOLD REGULAR REGULAR)) ((272.5 -147.0 7.0 14.0)) NIL))) (32.0 -180.0 281.0 111.0) 1.0 4.0 is printed as follows: Single-line: (*2* (*1* 1 *3* 2 A *4* B . 3) . 4) Double-line: (( 1 2 A B . 3) . 4) 21 3 4 In both formats, the reentrant nodes in the list structure are labeled by numbers. (A reentrant node is one that has two or more pointers coming into it.) In the single-line format, the label is printed between asterisks at the beginning of the node (list or tail) that it identifies. In the double-line format, the label is printed below the beginning of the node it identifies. An occurrence of a reentrant node that has already been identified is indicated by printing its label in brackets. (CIRCLPRINT LIST PRINTFLG RLKNT) [Function] Prints an expression describing LIST. If PRINTFLG=NIL, double-line format is used, otherwise single-line format. CIRCLPRINT first calls CIRCLMARK, and then calls either RLPRIN1 (if PRINTFLG=T) or RLPRIN2 (if PRINTFLG=NIL). Finally, RLRESTORE is called to restore LIST to its unmarked state. Returns LIST. (CIRCLMARK LIST RLKNT) [Function] Marks each reentrant node in LIST with a unique number, starting at RLKNT plus one (or one, if RLKNT is NIL). Value is RLKNT. Marking LIST physically alters it. However, the marking is performed undoably. In addition, LIST can always be restored by specifically calling RLRESTORE. (RLPRIN1 LIST) [Function] Prints an expression describing LIST in the single-line format. Does not restore LIST to its unCIRCLMARKed state. LIST must previously have been CIRCLMARKed, or an error is generated. (RLPRIN2 LIST) [Function] Same as RLPRIN1, except that the expression describing LIST is printed in the double-line format. (RLRESTORE LIST) [Function] Physically restores list to its original, unmarked state. Note that the user can mark and print several structures that together share common substructures, e.g., several property lists, by making several calls to CIRCLMARK, followed by calls to RLPRIN1 or RLPRIN2, and finally to RLRESTORE. (CIRCLMAKER LIST) [Function] LIST may contain labels and references following the convention used by CIRCLPRINT for printing reentrant structures in single-line format, e.g., (*1* . 1). CIRCLMAKER performs the necessary RPLACAs and RPLACDs to make LIST correspond to the indicated structure. Value is (altered) LIST. (CIRCLMAKER1 LIST) [Function] Does the work for CIRCLMAKER. Uses free variables LABELST and REFLST. LABELST is a list of dotted pairs of labels and corresponding nodes. REFLST is a list of nodes containing references to labels not yet seen. CIRCLMAKER operates by initializing LABELST and REFLST to NIL, and then calling CIRCLMAKER1. It generates an error if REFLST is not NIL when CIRCLMAKER1 returns. The user can call CIRCLMAKER1 directly to ŠŠconnect up'' several structures that share common substructures, e.g., several property lists.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC ) STARTINGPAGE# 241) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD RIGHT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC )) (270 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC )) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC )) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC )) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD RIGHT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC )) (270 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))))) +.ĚĚřř.œœřř.ĚĚřř.ĚĚř ř.ĚĚřřBřř PAGEHEADING VERSOHEADBřř PAGEHEADING RECTOHEADAřř PAGEHEADINGFOOTINGVAřř PAGEHEADINGFOOTINGR(MODERN +MODERNMODERN +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN +  HRULE.GETFNMODERN +Túƒů SKIO.GETFN.2MODERN +ˆ Ł SKIO.GETFN.2MODERN +ń + +2˝ SKIO.GETFN.2JŘ SKIO.GETFN.2MODERN +BB  +# SKIO.GETFN.2MODERN + %  ň   †  /!  + # +Q;   .B  7' + :ę  Ů:  4'Čzş \ No newline at end of file diff --git a/lispusers/classic10-c0.c150font b/lispusers/classic10-c0.c150font new file mode 100644 index 00000000..007e5c75 Binary files /dev/null and b/lispusers/classic10-c0.c150font differ diff --git a/lispusers/classic14-c0.c150font b/lispusers/classic14-c0.c150font new file mode 100644 index 00000000..1cb874ad Binary files /dev/null and b/lispusers/classic14-c0.c150font differ diff --git a/lispusers/classic18-c0.c150font b/lispusers/classic18-c0.c150font new file mode 100644 index 00000000..efe7862d Binary files /dev/null and b/lispusers/classic18-c0.c150font differ diff --git a/lispusers/dinfo.tedit b/lispusers/dinfo.tedit new file mode 100644 index 00000000..f07c5cc4 Binary files /dev/null and b/lispusers/dinfo.tedit differ diff --git a/lispusers/document b/lispusers/document new file mode 100644 index 00000000..974d3d71 --- /dev/null +++ b/lispusers/document @@ -0,0 +1 @@ +(FILECREATED "29-Aug-86 11:35:58" {DANTE}LISP>DOCUMENT.;8 16000 changes to: (FNS Document.Title Document.Format Document.Create Document.Begin Document.FileComments Document.Functions Document.Variables Document.Things Document.Information Document.SectionHead Document.FunctionCommentedP Document.Finish Document.RunningHead) (VARS DOCUMENTCOMS) previous date: "26-Aug-86 18:18:51" {DSK}DOCUMENT.;1 ) (PRETTYCOMPRINT DOCUMENTCOMS) (RPAQQ DOCUMENTCOMS ((* * This program creates documentation for any Lisp package in the style of the Lisp Users documentation. It requires that the code for the package be loaded. It does not completely format the document, but it minimizes the amount of work that the documenter must do. To make most effective use of these functions, each function in the package being documented must have a comment as the first expression in the function after the timestamp. Similarly, the COMS variable of the file should contain a comment (like this one) as the first item in the list. This package was documented using itself.) (FNS Document.Create Document.Begin Document.FileComments Document.Functions Document.Variables Document.Things Document.Finish Document.RunningHead Document.Title Document.Information Document.SectionHead Document.Format Document.FunctionCommentedP))) (* * This program creates documentation for any Lisp package in the style of the Lisp Users documentation. It requires that the code for the package be loaded. It does not completely format the document, but it minimizes the amount of work that the documenter must do. To make most effective use of these functions, each function in the package being documented must have a comment as the first expression in the function after the timestamp. Similarly, the COMS variable of the file should contain a comment (like this one) as the first item in the list. This package was documented using itself.) (DEFINEQ (Document.Create [LAMBDA (FileName) (* Newman "29-Aug-86 10:07") (* * This function builds a document for a loaded file. The document is in the style of the Lisp Library package  documentation. The function collects comments from the COMS variable of the file and from the functions in the  file. It also collects some information from the Interlisp-D file package. This is the top-level function in the  ODCUMENT package.) (if (MEMBER FileName FILELST) then (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (LET ((Stream (OPENTEXTSTREAM)) Pointer) (Document.Begin FileName Stream) (SETQ Pointer (ADD1 (GETEOFPTR Stream))) (Document.FileComments FileName Stream) (Document.Functions FileName Stream) (Document.Variables FileName Stream) (Document.Things FileName Stream (QUOTE MACROS) (QUOTE Macro)) (Document.Things FileName Stream (QUOTE RECORDS) (QUOTE Record)) (Document.Finish Stream Pointer))) else (ERROR FileName " not a loaded file."]) (Document.Begin [LAMBDA (FileName Stream) (* Newman "29-Aug-86 10:23") (* * This function initializes the begining of the document stream.) (Document.RunningHead FileName Stream) (Document.Title FileName Stream (ADD1 (GETEOFPTR Stream))) (Document.Information FileName Stream (ADD1 (GETEOFPTR Stream] ) (Document.FileComments [LAMBDA (FileName Stream) (* Newman "29-Aug-86 10:17") (* * This function places all comments found in the COMS variable of FileName into Stream. It is intended for use  in documenting a Lisp code file. Ideally, these commends would be distributed through the documentation as they are distributed through the COMS variable.) (Document.SectionHead Stream "INTRODUCTION") (PROMPTPRINT "Collecting File Comments ...") (for Descriptor in (FILECOMSLST FileName (QUOTE *)) do (printout Stream .PPFTL (REMOVE (QUOTE *) Descriptor) T]) (Document.Functions [LAMBDA (FileName Stream) (* Newman "29-Aug-86 10:25") (* * This function documents the Functions on FileName into Stream. It does this by obtaining the function names  from the file package, using the ARGLIST function to obtain the argument list, and obtainin the initial comment in  the function if it exists.) (Document.SectionHead Stream "FUNCTIONS") (PROMPTPRINT "Collecting Function Comments ... ") (for Function in (FILEFNSLST FileName) do (TEDIT.INSERT Stream (CONCAT "(" Function " ") (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 10 (QUOTE MRR))) (TEDIT.INSERT Stream (SUBSTRING (MKSTRING (ARGLIST Function)) 2 -2) (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 10 (QUOTE ITALIC))) (TEDIT.INSERT Stream (CONCAT ") [Function]" (CHARACTER 13)) (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 10 (QUOTE MRR))) (* * This SETFILEPTR is here because someone leaves the FILEPTR in the wrong place.) (SETFILEPTR Stream (GETEOFPTR Stream)) (if (Document.FunctionCommentedP Function) then (printout Stream .PPVTL [REMOVE (QUOTE *) (CADDDR (OR (GETPROP Function (QUOTE EXPR)) (GETD Function] T]) (Document.Variables [LAMBDA (FileName Stream) (* Newman "29-Aug-86 10:28") (* This function is intended for use while documenting Lisp code. It collects a list of the variables from  FileName, and places them in Stream in the format of the Lisp Library Documentation.) (Document.SectionHead Stream "VARIABLES") (PROMPTPRINT "Collecting Variables ...") (for Variable in (FILECOMSLST FileName (QUOTE VARS)) do (if (MEMBER Variable (FILECOMSLST FileName (QUOTE GLOBALVARS) )) then (printout Stream Variable , " [GlobalVar]" T) elseif (MEMBER Variable (FILECOMSLST FileName (QUOTE SPECVARS))) then (printout Stream Variable , " [SpecialVar]" T) else (printout Stream Variable , " [Variable]" T]) (Document.Things [LAMBDA (FileName Stream FilePkgType TypeName) (* Newman "29-Aug-86 10:32") (* This function is intended for use while documenting Lisp code. It collects a list of items of type TypeName,  that are written using the FilePkgType file package command, from FileName, and places them in Stream in the format of the Lisp Library Documentation.) (if (AND FilePkgType (MEMBER FilePkgType FILEPKGTYPES)) then (if (FILECOMSLST FileName FilePkgType) then (Document.SectionHead Stream (CONCAT (U-CASE (SETQ TypeName (OR TypeName FilePkgType))) "S")) (PROMPTPRINT (CONCAT "Collecting " TypeName " ...")) (for Thing in (FILECOMSLST FileName FilePkgType) do (printout Stream Thing , (CONCAT (CHARACTER 9) "[" TypeName "]") T))) else (ERROR FilePkgType "Bad file package type: "]) (Document.Finish [LAMBDA (Stream Pointer) (* Newman "28-Aug-86 15:22") (* * This function performs formatting and the like to make the document pretty, and to make the format correct as  specified.) (* * Set the selection to cover the non-header portions of the file.) (TEDIT.SETSEL Stream Pointer (DIFFERENCE (GETEOFPTR Stream) Pointer) (QUOTE LEFT)) (* * Eliminate extra spaces) (bind (Num _ 1) repeatuntil (ZEROP Num) do (SETQ Num (TEDIT.SUBSTITUTE Stream " " " "))) (* * Eliminate carriage returns that I think are introduced by printout) (TEDIT.SUBSTITUTE Stream (CONCAT (CHARACTER 13) " ") " ") (* * For some reason, the paragraph breaks don't work unless this line is here.) (TEDIT.SUBSTITUTE Stream (MKSTRING (CHARACTER 13)) (MKSTRING (CHARACTER 13))) (* * Set the page, paragraph, and character looks of the non-header portions of the document.) (Document.Format Stream) (* * TEdit the stream so the user can finish the job by hand.) (TEDIT Stream]) (Document.RunningHead [LAMBDA (FileName Stream) (* Newman "28-Aug-86 15:57") (* * This function creates the running header for the document.) (TEDIT.INSERT Stream "XEROX" 0 (FONTCREATE (QUOTE LOGO) 24)) (TEDIT.INSERT Stream (CONCAT " " (CHARACTER 9) FileName (CHARACTER 13) (CHARACTER 13)) NIL (FONTCREATE (QUOTE MODERN) 10)) (TEDIT.INSERT.OBJECT (HRULE.CREATE (QUOTE 2)) Stream (GETEOFPTR Stream)) (TEDIT.PARALOOKS (TEXTOBJ Stream) (QUOTE (TYPE PAGEHEADING SUBTYPE RUNNINGHEAD RIGHTMARGIN 456 LEFTMARGIN 0 TABS (NIL (456 . RIGHT)) QUAD JUSTIFIED)) 0 (ADD1 (GETEOFPTR Stream))) (* * we set the file ptr to be kind to others, as TEDIT.PARALOOKS moves it from the end of the file.) (SETFILEPTR Stream (GETFILEPTR Stream]) (Document.Title [LAMBDA (FileName Stream Pointer) (* Newman "29-Aug-86 11:35") (* * This function creates the title area of the document consisting of the name of the package being documented in between two lines.) (TERPRI Stream) (* This TERPRI is here because otherwise the first HRULE in the title becomes a part of the running header. This happens for no apparent reason, and is a mystery to me.) (TEDIT.INSERT.OBJECT (HRULE.CREATE (QUOTE (5 4 1))) Stream (ADD1 (GETEOFPTR Stream))) (TEDIT.INSERT Stream (CONCAT (CHARACTER 13) FileName (CHARACTER 13) (CHARACTER 13)) (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 12 (QUOTE BRR))) (TEDIT.INSERT.OBJECT (HRULE.CREATE (QUOTE (1 4 5))) Stream (GETEOFPTR Stream)) (TEDIT.PARALOOKS (TEXTOBJ Stream) (QUOTE (TYPE NIL PARALEADING 6 LINELEADING 4 RIGHTMARGIN 312 LEFTMARGIN 138 1STLEFTMARGIN 138 QUAD CENTERED)) Pointer (DIFFERENCE (ADD1 (GETEOFPTR Stream)) Pointer)) (* * This call to SETFILEPTR is here because I believe TEDIT.PARALOOKS does not leave the file pointer at the end  of the stream as the printout function requires. I believe that if I eliminate all calls to printout, I can  eliminate all calls to SETFILEPTR. I also believe that PRINTOUT can always be replaced by TEDIT.INSERT.) (SETFILEPTR Stream (GETEOFPTR Stream]) (Document.Information [LAMBDA (FileName Stream Pointer) (* Newman "29-Aug-86 10:37") (* * This function creates the information at the top of the document, including the form for the author's name and a list of other packages necessary to run this package.) (TEDIT.INSERT Stream (CONCAT " By: >>Author's Name<< (>>Net Address<<)" (CHARACTER 13) " " (SUBSTRING (DATE) 1 9) (CHARACTER 13)) (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 10) T) (if (FILECOMSLST FileName (QUOTE FILES)) then (TEDIT.INSERT Stream (CONCAT "The following packages are loaded by " FileName ": " (SUBSTRING (MKSTRING (FILECOMSLST FileName (QUOTE FILES))) 2 -2) (CHARACTER 13) " ") (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 10) T)) (TEDIT.PARALOOKS (TEXTOBJ Stream) (QUOTE (RIGHTMARGIN 456 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD CENTERED PARALEADING 17)) Pointer (ADD1 (GETEOFPTR Stream))) (* The following SETFILEPTR exists because TEDIT.PARALOOKS does not leave the file pointer at the end of the file.) (SETFILEPTR Stream (GETEOFPTR Stream]) (Document.SectionHead [LAMBDA (Stream String) (* Newman "29-Aug-86 10:39") (* * This function is intended to create the bold section headings in Stream that are needed for the Lisp Users  document style.) (TEDIT.INSERT Stream (CONCAT String (CHARACTER 13)) (ADD1 (GETEOFPTR Stream)) (FONTCREATE (QUOTE MODERN) 10 (QUOTE BRR))) (SETFILEPTR Stream (GETEOFPTR Stream)) (* * The following TEDIT.CARETLOOKS prevents the bolding from continuing past the section heading in some cases.) (TEDIT.CARETLOOKS Stream (FONTCREATE (QUOTE MODERN) 10 (QUOTE MRR]) (Document.Format [LAMBDA (Stream) (* Newman "29-Aug-86 10:54") (* * This function formats the document. It sets the page layout, font looks, and paragraph formatting for all  selected text.) (TEDIT.SUBLOOKS Stream (QUOTE (FAMILY GACHA)) (QUOTE (FAMILY MODERN SIZE 10))) (TEDIT.PARALOOKS (TEXTOBJ Stream) (QUOTE (TABS (NIL (0 . RIGHT) (456 . RIGHT)) LINELEADING 4 PARALEADING 11 RIGHTMARGIN 456 LEFTMARGIN 0 1STLEFTMARGIN 0 QUAD JUSTIFIED)) (TEDIT.GETSEL Stream)) (TEDIT.PAGEFORMAT Stream (TEDIT.COMPOUND.PAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT T 26.5 3.0 (QUOTE (MODERN 10)) (QUOTE CENTERED) 7.0 6.0 8.0 8.0 1 38.0 0 (QUOTE ((RUNNINGHEAD 7.0 62.0))) (QUOTE PICAS) (QUOTE (STARTINGPAGE# 1)) (QUOTE LETTER)) (TEDIT.SINGLE.PAGEFORMAT T 26.5 3.5 (QUOTE (MODERN 10)) (QUOTE CENTERED) 7.0 6.0 8.0 8.0 1 38.0 0 (QUOTE ((RUNNINGHEAD 7.0 62.0))) (QUOTE PICAS) (QUOTE (STARTINGPAGE# 1)) (QUOTE LETTER)) (TEDIT.SINGLE.PAGEFORMAT T 26.5 3.0 (QUOTE (MODERN 10)) (QUOTE CENTERED) 7.0 6.0 8.0 8.0 1 38.0 0 (QUOTE ((RUNNINGHEAD 7.0 62.0))) (QUOTE PICAS) (QUOTE (STARTINGPAGE# 1)) (QUOTE LETTER]) (Document.FunctionCommentedP [LAMBDA (Function) (* Newman "29-Aug-86 10:42") (* * This function is intended to tell if a function has an initial comment or not.) (EQUAL (QUOTE *) (CAR (CADDDR (OR (GETPROP Function (QUOTE EXPR)) (GETD Function) (ERROR Function "Not a function: "]) ) (DECLARE: DONTCOPY (FILEMAP (NIL (2105 15978 (Document.Create 2115 . 3381) (Document.Begin 3383 . 3767) (Document.FileComments 3769 . 4450) (Document.Functions 4452 . 6022) (Document.Variables 6024 . 6914) (Document.Things 6916 . 8000) (Document.Finish 8002 . 9249) (Document.RunningHead 9251 . 10257) (Document.Title 10259 . 11911) (Document.Information 11913 . 13348) ( Document.SectionHead 13350 . 14077) (Document.Format 14079 . 15572) ( Document.FunctionCommentedP 15574 . 15976))))) STOP \ No newline at end of file diff --git a/lispusers/eyecon.tedit b/lispusers/eyecon.tedit new file mode 100644 index 00000000..5fe29573 Binary files /dev/null and b/lispusers/eyecon.tedit differ diff --git a/lispusers/fm-creator-examples/BACH.FMC b/lispusers/fm-creator-examples/BACH.FMC new file mode 100644 index 00000000..2d42061b Binary files /dev/null and b/lispusers/fm-creator-examples/BACH.FMC differ diff --git a/lispusers/fm-creator-examples/DEMO.FMC b/lispusers/fm-creator-examples/DEMO.FMC new file mode 100644 index 00000000..ec65ba59 --- /dev/null +++ b/lispusers/fm-creator-examples/DEMO.FMC @@ -0,0 +1 @@ +FreeMenuCreator-ItemList (MOMENTARY "Example" (MODERN 10 BOLD) NIL NIL NIL "" NIL 1 65535 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (123 149 55 25) NIL 6 6 NIL NIL) (MOMENTARY "NORTH" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (6 115 34 12) NIL 0 0 NIL NIL) (MOMENTARY "SOUTH" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (72 115 33 12) NIL 0 0 NIL NIL) (MOMENTARY "EAST" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (204 115 24 12) NIL 0 0 NIL NIL) (MOMENTARY "WEST" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (270 114 27 12) NIL 0 0 NIL NIL) (GROUP **BITMAP** NIL NIL NIL NIL "" NIL 1 65535 NIL NIL 3 NIL NIL NIL NIL NIL NIL (4 88 233 16) NIL 2 2 NIL NIL) (MOMENTARY "ONE" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (6 90 21 12) NIL 0 0 NIL NIL) (MOMENTARY "TWO" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (72 90 24 12) NIL 0 0 NIL NIL) (MOMENTARY "THREE" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (204 90 31 12) NIL 0 0 NIL NIL) (MOMENTARY "ONE" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 NIL 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (6 6 21 12) NIL 0 0 NIL NIL) (GROUP **BITMAP** NIL NIL NIL NIL "" NIL 2 65535 43605 NIL 3 NIL NIL NIL NIL NIL NIL (75 9 107 70) NIL 5 5 NIL NIL) (GROUP **BITMAP** NIL NIL COL1 T "" NIL 1 43605 43605 NIL 3 NIL NIL NIL NIL NIL NIL (80 14 15 60) NIL 2 2 NIL NIL) (NWAY "A" (MODERN 10 REGULAR) NIL NIL NIL "" NIL 1 65535 0 NIL 0 (NIL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (82 56 11 16) NIL 2 2 NIL NIL) (NWAY "B" (MODERN 10 REGULAR) NIL NIL NIL "" NIL 1 65535 0 NIL 0 (NIL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (82 36 10 16) NIL 2 2 NIL NIL) (NWAY "C" (MODERN 10 REGULAR) NIL NIL NIL "" NIL 1 65535 0 NIL 0 (NIL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (82 16 10 16) NIL 2 2 NIL NIL) (STATE "Choose Me" (MODERN 10 REGULAR) NIL NIL NIL "" DELTA 1 65535 0 (DISPLAY ALPHA) 0 ((BRAVO DELTA) ) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (117 56 55 16) NIL 2 2 NIL NIL) (DISPLAY "*NOLABEL*" (MODERN 10 REGULAR) ALPHA NIL NIL "" DELTA 1 65535 0 NIL 0 (NIL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (117 36 60 16) NIL 2 2 NIL NIL) (MOMENTARY "THREE" (MODERN 10 REGULAR) NIL NIL NIL "" NIL NIL NIL 0 (NIL) 0 (NIL) (FUNCTION NILL) ( FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (204 6 31 12) NIL 0 0 NIL NIL) STOP \ No newline at end of file diff --git a/lispusers/formacro.tedit b/lispusers/formacro.tedit new file mode 100644 index 00000000..b06e8136 Binary files /dev/null and b/lispusers/formacro.tedit differ diff --git a/lispusers/iso8859io b/lispusers/iso8859io new file mode 100644 index 00000000..8fbe249f --- /dev/null +++ b/lispusers/iso8859io @@ -0,0 +1,362 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 9-Mar-99 18:20:26" {DSK}medley3.5>lispusers>iso8859io.;3 36139 changes to%: (FNS MAKEMACFORMAT) previous date%: " 9-Mar-99 17:35:17" {DSK}medley3.5>lispusers>iso8859io.;2) (* ; " Copyright (c) 1995, 1996, 1997, 1999 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ISO8859IOCOMS) (RPAQQ ISO8859IOCOMS ( (* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.") (COMS (* ; "ISO8859/1") (FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN) (GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*) (FNS MAKEISOFORMAT) (P (MAKEISOFORMAT))) (COMS (* ; "IBM-PC Extended Ascii") (FNS \IBMOUTCHARFN \IBMINCCODEFN \IBMPEEKCCODEFN) (GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*) (FNS MAKEIBMFORMAT) (P (MAKEIBMFORMAT))) (COMS (* ; "Macintosh") (FNS \MACOUTCHARFN \MACINCCODEFN \MACPEEKCCODEFN) (GLOBALVARS *XEROXTOMACMAP* *MACTOXEROXMAP*) (FNS MAKEMACFORMAT) (P (MAKEMACFORMAT))) (COMS (* ; "Independent of char encoding") (FNS \COMMONBACKCHARFN \MAKERECODEMAP \RECODECCODE)) (DECLARE%: EVAL@COMPILE DONTCOPY [P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT] (* ;; "From FILEIO") (CONSTANTS (\NORUNCODE 255)) (* ;; "From LLCHAR") (CONSTANTS (NSCHARSETSHIFT 255)) (* ;; "From LLREAD") (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR) (* ;; "From MODARITH") (MACROS UNFOLD)))) (* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding." ) (* ; "ISO8859/1") (DEFINEQ (\8859OUTCHARFN + [LAMBDA (STREAM CHARCODE) + (DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 7-Dec-95 14:34 by ") + (* ; "Edited 7-Dec-95 14:32 by ") + + (* ;; "Converts CHARCODE from internal Xerox-rendering to ISO8859 before printing. Unconverted codes are left unchanged (no error). If any remaining codes are out of charset 0, the Xerox run-encoding is used (which means that y-umlaut (code 255 in iso) will confuse any readers).") + + (\FILEOUTCHARFN STREAM (IF (IGREATERP CHARCODE 127) + THEN + + (* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128") + + (\RECODECCODE CHARCODE *XEROXTOISO8859MAP*) + ELSE CHARCODE]) (\8859INCCODEFN + [LAMBDA (STREAM COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 7-Dec-95 15:24 by ") + (* ; "Edited 7-Dec-95 15:19 by ") + (IF COUNTP + THEN + + (* ;; "This is a little goofy. \NSIN passes the COUNTP flag, not the variable. It then takes the COUNT result and subtracts it out. But \XCCSIN is already subtracting from 0, giving a negative count. So we have to reverse the value here. Sigh ") + + (LET ((COUNT 0)) + (CL:VALUES (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL COUNT) + *ISO8859TOXEROXMAP*) + (IMINUS COUNT))) + ELSE (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256)) + *ISO8859TOXEROXMAP*]) (\8859PEEKCCODEFN + [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 3-Jan-96 14:21 by ") + (* ; "Edited 7-Dec-95 15:51 by ") + + (* ;; "Uses \XCCSPEEK to handle Xerox run-coding") + (* ; "Edited 7-Dec-95 15:19 by ") + (LET (PCODE (COUNT 0)) + (SETQ PCODE (IF COUNTP + THEN (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL NOERROR COUNT) + ELSE (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL NOERROR))) + (IF COUNTP + THEN (CL:VALUES (AND PCODE (\RECODECCODE PCODE *ISO8859TOXEROXMAP*)) + COUNT) + ELSE (AND PCODE (\RECODECCODE PCODE *ISO8859TOXEROXMAP*]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*) ) (DEFINEQ (MAKEISOFORMAT + [LAMBDA NIL (* ; "Edited 9-Mar-99 17:19 by rmk:") + (* ; "Edited 7-Dec-95 16:24 by ") + (* ; "Edited 7-Dec-95 16:20 by ") + [LET ((XEROXTOISO '((61217 160) + (61291 166) + (8994 168) + (211 169) + (227 170) + (61290 172) + (61219 173) + (210 174) + (9086 175) + (8999 180) + (203 184) + (209 185) + (235 186) + (61729 192) + (61730 193) + (61731 194) + (61732 195) + (61735 196) + (61736 197) + (225 198) + (61741 199) + (61744 200) + (61745 201) + (61746 202) + (61749 203) + (61758 204) + (61759 205) + (61760 206) + (61764 207) + (226 208) + (61772 209) + (61775 210) + (61776 211) + (61777 212) + (61778 213) + (61780 214) + (180 215) + (233 216) + (61791 217) + (61792 218) + (61793 219) + (61797 220) + (61803 221) + (236 222) + (251 223) + (61857 224) + (61858 225) + (61859 226) + (61860 227) + (61863 228) + (61864 229) + (241 230) + (61869 231) + (61872 232) + (61873 233) + (61874 234) + (61877 235) + (61886 236) + (61887 237) + (61888 238) + (61892 239) + (243 240) + (61900 241) + (61903 242) + (61904 243) + (61905 244) + (61906 245) + (61908 246) + (184 247) + (249 248) + (61919 249) + (61920 250) + (61921 251) + (61925 252) + (61931 253) + (252 254) + (61933 255) + (61805 376] + (SETQ *XEROXTOISO8859MAP* (\MAKERECODEMAP XEROXTOISO)) + (SETQ *ISO8859TOXEROXMAP* (\MAKERECODEMAP + '#.(SEDIT::MAKE-GAP '(0 . #*(15 7)@@@@@DD@@BH@OICN@BH@@DD@@@@@)) + T)) + (\INSTALL.EXTERNALFORMAT :ISO8859/1 (CREATE EXTERNALFORMAT + INCCODEFN _ (FUNCTION \8859INCCODEFN) + PEEKCCODEFN _ (FUNCTION \8859PEEKCCODEFN) + BACKCHARFN _ (FUNCTION \COMMONBACKCHARFN) + FILEOUTCHARFN _ (FUNCTION \8859OUTCHARFN]) ) (MAKEISOFORMAT) (* ; "IBM-PC Extended Ascii") (DEFINEQ (\IBMOUTCHARFN + [LAMBDA (STREAM CHARCODE) (* ; "Edited 9-Mar-99 16:59 by rmk:") + + (* ;; "Converts CHARCODE from internal Xerox-rendering to IBM before printing. Unconverted codes are left unchanged (no error). If any remaining codes are out of charset 0, the Xerox run-encoding is used (which means that y-umlaut (code 255 in iso) will confuse any readers).") + + (\FILEOUTCHARFN STREAM (IF (IGREATERP CHARCODE 127) + THEN + + (* ;; "We know that IBM doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128") + + (\RECODECCODE CHARCODE *XEROXTOIBMMAP*) + ELSE CHARCODE]) (\IBMINCCODEFN + [LAMBDA (STREAM COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 8-Dec-95 13:23 by ") + + (* ;; "Uses \XCCSIN to handle Xerox run-coding") + (* ; "Edited 7-Dec-95 15:19 by ") + (IF COUNTP + THEN (LET ((COUNT 0)) + (CL:VALUES (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL COUNT) + *IBMTOXEROXMAP*) + (IMINUS COUNT))) + ELSE (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256)) + *IBMTOXEROXMAP*]) (\IBMPEEKCCODEFN + [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 3-Jan-96 14:23 by ") + (* ; "Edited 8-Dec-95 13:24 by ") + (* ; "Edited 7-Dec-95 15:51 by ") + + (* ;; "Uses \XCCSPEEK to handle Xerox run-coding") + (* ; "Edited 7-Dec-95 15:19 by ") + (LET (PCODE (COUNT 0)) + (SETQ PCODE (IF COUNTP + THEN (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL NOERROR COUNT) + ELSE (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL NOERROR))) + (IF COUNTP + THEN (CL:VALUES (AND PCODE (\RECODECCODE PCODE *IBMTOXEROXMAP*)) + COUNT) + ELSE (AND PCODE (\RECODECCODE PCODE *IBMTOXEROXMAP*]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*) ) (DEFINEQ (MAKEIBMFORMAT + [LAMBDA NIL (* ; "Edited 9-Mar-99 17:33 by rmk:") + (LET [(XEROXTOIBM '((61217 255) + (61291 166) + (8994 168) + (211 169) + (227 166) + (61290 170) + (61219 173) + (210 174) + (9086 175) + (8999 180) + (203 184) + (235 167) + (61729 183) + (61730 181) + (61731 182) + (61732 199) + (61735 142) + (61736 143) + (225 146) + (61741 128) + (61744 212) + (61745 144) + (61746 210) + (61749 211) + (61758 222) + (61759 214) + (61760 215) + (61764 216) + (61772 165) + (61775 227) + (61776 224) + (61777 226) + (61778 229) + (61780 153) + (233 157) + (61791 235) + (61792 233) + (61793 234) + (61797 154) + (61803 194) + (251 225) + (61857 133) + (61858 160) + (61859 131) + (61860 198) + (61863 132) + (61864 134) + (241 145) + (61869 135) + (61872 138) + (61873 130) + (61874 136) + (61877 137) + (61886 141) + (61887 161) + (61888 140) + (61892 139) + (61900 164) + (61903 149) + (61904 162) + (61905 147) + (61906 228) + (61908 148) + (249 155) + (61919 151) + (61920 163) + (61921 150) + (61925 129) + (61931 194) + (61933 152) + (61805 376) + (161 173) + (162 155) + (163 156) + (165 157) + (167 21) + (171 174) + (176 248) + (177 241) + (178 253) + (181 230) + (182 20) + (183 250) + (187 175) + (188 172) + (189 171) + (191 168] + (SETQ *XEROXTOIBMMAP* (\MAKERECODEMAP XEROXTOIBM)) + (SETQ *IBMTOXEROXMAP* (\MAKERECODEMAP XEROXTOIBM T)) + (\INSTALL.EXTERNALFORMAT :IBM (CREATE EXTERNALFORMAT + INCCODEFN _ (FUNCTION \IBMINCCODEFN) + PEEKCCODEFN _ (FUNCTION \IBMPEEKCCODEFN) + BACKCHARFN _ (FUNCTION \COMMONBACKCHARFN) + FILEOUTCHARFN _ (FUNCTION \IBMOUTCHARFN]) ) (MAKEIBMFORMAT) (* ; "Macintosh") (DEFINEQ (\MACOUTCHARFN + [LAMBDA (STREAM CHARCODE) (* ; "Edited 9-Mar-99 16:59 by rmk:") + + (* ;; "Converts CHARCODE from internal Xerox-rendering to MAC before printing. Unconverted codes are left unchanged (no error). If any remaining codes are out of charset 0, the Xerox run-encoding is used (which means that code 255 will confuse any readers).") + + (\FILEOUTCHARFN STREAM (IF (IGREATERP CHARCODE 127) + THEN + + (* ;; "We know that MAC doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128") + + (\RECODECCODE CHARCODE *XEROXTOMACMAP*) + ELSE CHARCODE]) (\MACINCCODEFN + [LAMBDA (STREAM COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 8-Dec-95 13:29 by ") + + (* ;; "Uses \XCCSIN to handle Xerox run-coding") + + (IF COUNTP + THEN (LET ((COUNT 0)) + (CL:VALUES (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL COUNT) + *MACTOXEROXMAP*) + (IMINUS COUNT))) + ELSE (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256)) + *MACTOXEROXMAP*]) (\MACPEEKCCODEFN + [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:") + (* ; "Edited 3-Jan-96 14:23 by ") + (* ; "Edited 8-Dec-95 13:29 by ") + + (* ;; "Uses \XCCSPEEK to handle Xerox run-coding") + + (LET (PCODE (COUNT 0)) + (SETQ PCODE (IF COUNTP + THEN (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL NOERROR COUNT) + ELSE (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) + 256) + NIL NOERROR))) + (IF COUNTP + THEN (CL:VALUES (AND PCODE (\RECODECCODE PCODE *MACTOXEROXMAP*)) + COUNT) + ELSE (AND PCODE (\RECODECCODE PCODE *MACTOXEROXMAP*]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *XEROXTOMACMAP* *MACTOXEROXMAP*) ) (DEFINEQ (MAKEMACFORMAT [LAMBDA NIL (* ; "Edited 9-Mar-99 17:32 by rmk:") (* ; "Edited 7-Dec-95 16:24 by ") (* ; "Edited 7-Dec-95 16:20 by ") (* ;; "Note: This maps some characters into sequences--only the first in the sequence will appear. Sigh.") (LET [(XEROXTOMAC '((211 212) (227 187) (61290 194) (210 168) (203 252) (209 213) (235 188) (61729 203) (61730 231) (61731 171) (61732 204) (61735 128) (61736 129) (225 174) (61741 130) (61744 172) (61745 131) (61746 230) (61749 232) (61758 237) (61759 234) (61760 235) (61764 236) (61772 132) (61775 241) (61776 238) (61777 170) (61778 205) (61780 133) (233 175) (61791 244) (61792 242) (61793 243) (61797 134) (61803 194 89) (251 167) (61857 136) (61858 135) (61859 137) (61860 139) (61863 138) (61864 140) (241 190) (61869 141) (61872 143) (61873 142) (61874 144) (61877 145) (61886 147) (61887 146) (61888 148) (61892 149) (61900 150) (61903 152) (61904 151) (61905 153) (61906 155) (61908 154) (184 214) (249 191) (61919 157) (61920 156) (61921 158) (61925 159) (61931 194 121) (61933 216) (61805 217) (61232 160) (176 161) (167 164) (61286 165) (182 166) (8546 173) (8551 176) (8549 178) (8550 179) (165 180) (61370 182) (61306 183) (61307 184) (9843 185) (61301 186) (191 192) (161 193) (61308 195) (61346 196) (61305 197) (9797 198) (171 199) (187 200) (8516 201) (32 202) (61220 208) (61221 209) (8574 215) (47 218) (164 219) (61226 220) (61227 221) (61476 222) (61477 223) (61233 224) (183 225) (9138 226) (61224 227) (61249 228] (SETQ *XEROXTOMACMAP* (\MAKERECODEMAP XEROXTOMAC)) (SETQ *MACTOXEROXMAP* (\MAKERECODEMAP XEROXTOMAC T)) (\INSTALL.EXTERNALFORMAT :MACINTOSH (CREATE EXTERNALFORMAT INCCODEFN _ (FUNCTION \MACINCCODEFN) PEEKCCODEFN _ (FUNCTION \MACPEEKCCODEFN) BACKCHARFN _ (FUNCTION \COMMONBACKCHARFN) FILEOUTCHARFN _ (FUNCTION \MACOUTCHARFN]) ) (MAKEMACFORMAT) (* ; "Independent of char encoding") (DEFINEQ (\COMMONBACKCHARFN + [LAMBDA (STREAM COUNTP) (* ; "Edited 29-Mar-96 10:55 by rmk") + (* ; "Edited 8-Dec-95 13:26 by ") + + (* ;; "Let \BACKXCCSCHAR handle the run-coding. The charset in the stream is the charset byte, unconverted to ISO. This is independent of the particular character translation.") + + (IF COUNTP + THEN (LET ((COUNT 0)) + (\BACKXCCSCHAR STREAM COUNT) + COUNT) + ELSE (\BACKXCCSCHAR STREAM NIL]) (\MAKERECODEMAP + [LAMBDA (CODEMAP INVERTED) (* ; "Edited 9-Mar-99 17:23 by rmk:") + + (* ;; "Produces a map array for use by \RECODECCODE. The map array is a 256-array of either NIL or 256-arrays, so that space isn't allocated for widely separated codes.") + + (DECLARE (USEDFREE FASTRECODEMAPCACHE)) + (CL:WHEN INVERTED + [SETQ CODEMAP (FOR C IN CODEMAP COLLECT (LIST (CADR C) + (CAR C]) + (FOR M (MAPARRAY _ (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) + CSMAP IN CODEMAP UNLESS (EQ (CAR M) + (CADR M)) + DO (CL:UNLESS (SETQ CSMAP (CL:SVREF MAPARRAY (LRSH (CAR M) + 8))) + (SETQ CSMAP (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) + (CL:SETF (CL:SVREF MAPARRAY (LRSH (CAR M) + 8)) + CSMAP)) + (CL:SETF (CL:SVREF CSMAP (LOGAND (CAR M) + 255)) + (CADR M)) FINALLY (RETURN MAPARRAY]) (\RECODECCODE + [LAMBDA (CODE MAPARRAY) (* ; "Edited 9-Mar-99 17:28 by rmk:") + (* ; "Edited 21-Jun-95 10:18 by rmk:") + + (* ;; "Recodes a singleton charcode. Leaves everything else unchanged.") + + (LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8] + (OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255))) + CODE]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (EVAL (SYSRECLOOK1 'EXTERNALFORMAT)) (DECLARE%: EVAL@COMPILE (RPAQQ \NORUNCODE 255) (CONSTANTS (\NORUNCODE 255)) ) (DECLARE%: EVAL@COMPILE (RPAQQ NSCHARSETSHIFT 255) (CONSTANTS (NSCHARSETSHIFT 255)) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \XCCSIN MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* ;;; "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.") (LET ((CHAR (\BIN STREAM)) SCSET) (COND [(EQ CHAR NSCHARSETSHIFT) (* ; "Shifting character sets") [ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\BIN STREAM))) (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2)) ) CHAR) ((PROGN (* ;  "2 shift-bytes means not run-encoded") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3) )) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM] (SETQ CHAR (\BIN STREAM)) (SETQ SCSET (COND ('SHIFTEDCSETVAR (* ; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256] (T (SETQ SCSET SHIFTEDCSET))) (COND ((EQ SCSET (UNFOLD \NORUNCODE 256)) (* ;  "just read two bytes and combine them to a 16 bit value") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) (LOGOR (UNFOLD CHAR 256) (\BIN STREAM))) (CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1))) (AND CHAR (LOGOR SCSET CHAR] [PUTPROPS \XCCSPEEK MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* ;; "Returns a 16 bit character code. Doesn't do EOL conversion--\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read") (PROG ((CHAR (\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) [(EQ CHAR NSCHARSETSHIFT)(* ; "CHARSETVAR=NIL means don't set") (\BIN STREAM) (* ; "Consume the char shift byte") [ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\BIN STREAM))) (* ;  "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* ;  "2 shift-bytes means not run-encoded") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM] [SETQ SCSET (COND ('SHIFTEDCSETVAR (* ; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256] (COND ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR))) (RETURN NIL] (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \NORUNCODE 256)) (* ;; "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character") (\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM))) (T (LOGOR SHIFTEDCSET CHAR] [PUTPROPS \BACKXCCSCHAR MACRO ((STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\BACKFILEPTR STREAM) (COND [[COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \NORUNCODE 256) )) (T (EQ \NORUNCODE (ACCESS-CHARSET STREAM] (COND ((\BACKFILEPTR STREAM) (AND 'COUNTERVAR (add COUNTERVAR 2)) T) ('COUNTERVAR (add COUNTERVAR 1] ('COUNTERVAR (add COUNTERVAR 1] ) (DECLARE%: EVAL@COMPILE [PUTPROPS UNFOLD MACRO (X (PROG [(FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X] (OR (AND DIVISOR (POWEROFTWOP DIVISOR)) (\ILLEGAL.ARG (CADR X))) (RETURN (LIST 'LLSH FORM (SUB1 (INTEGERLENGTH DIVISOR] ) ) (PUTPROPS ISO8859IO COPYRIGHT ("Xerox Corporation" 1995 1996 1997 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2796 6275 (\8859OUTCHARFN 2806 . 3876) (\8859INCCODEFN 3878 . 5078) (\8859PEEKCCODEFN 5080 . 6273)) (6367 10157 (MAKEISOFORMAT 6377 . 10155)) (10217 13320 (\IBMOUTCHARFN 10227 . 11052) ( \IBMINCCODEFN 11054 . 12028) (\IBMPEEKCCODEFN 12030 . 13318)) (13404 17155 (MAKEIBMFORMAT 13414 . 17153)) (17203 19986 (\MACOUTCHARFN 17213 . 18020) (\MACINCCODEFN 18022 . 18897) (\MACPEEKCCODEFN 18899 . 19984)) (20070 24867 (MAKEMACFORMAT 20080 . 24865)) (24934 27228 (\COMMONBACKCHARFN 24944 . 25549) (\MAKERECODEMAP 25551 . 26781) (\RECODECCODE 26783 . 27226))))) STOP \ No newline at end of file diff --git a/lispusers/lispusers-info-msg.tedit b/lispusers/lispusers-info-msg.tedit new file mode 100644 index 00000000..37884f54 Binary files /dev/null and b/lispusers/lispusers-info-msg.tedit differ diff --git a/lispusers/mathserverplot b/lispusers/mathserverplot new file mode 100644 index 00000000..2e623635 --- /dev/null +++ b/lispusers/mathserverplot @@ -0,0 +1 @@ +(FILECREATED "15-Dec-86 11:35:38" {INDIGO}KOTO>LIBRARY>MATHSERVERPLOT.;4 49010 changes to: (FNS MAPL.Simple.MakePlot MAPL.ExpandFilename MAPL.Meta.MakePlot MAPL.Gen.MakePlot) (VARS MATHSERVERPLOTCOMS) previous date: " 8-Dec-86 09:46:39" {INDIGO}KOTO>LIBRARY>MATHSERVERPLOT.;3) (* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT MATHSERVERPLOTCOMS) (RPAQQ MATHSERVERPLOTCOMS ((* * ALL PLOTS) (* Files for Log functions) (FILES plotexamples.dcom {INDIGO}IDLPLOT>FIXES>LOGPATCH.DCOM) (* Low-level I/0 functions) (FNS MAPL.TopLevel MAPL.MakeReadtable MAPL.ReadASCIILine MAPL.ExpandFilename) (* * METACODE PLOT STUFF) (* Menu and window functions) (FNS MAPL.Meta.TopLevel MAPL.Meta.FreeMenu MAPL.Meta.MakeIconWindow) (* Plot functions) (FNS MAPL.Meta.MakePlot MAPL.Meta.Plot MAPL.Meta.ASCIIToLisp) (* Metaplot functions) (FNS MAPL.Meta.NewPlotCom MAPL.Meta.MoveCom MAPL.Meta.DrawCom MAPL.Meta.EndPlotCom MAPL.Meta.NewPenCom) (* Icon bitmaps) (BITMAPS MAPL.Meta.Icon MAPL.Meta.IconMask) (* * SIMPLE PLOT STUFF) (* Menu and window functions) (FNS MAPL.Simple.TopLevel MAPL.Simple.FreeMenu MAPL.Simple.MakeIconWindow) (* Plot functions) (FNS MAPL.Simple.MakePlot MAPL.Simple.Plot) (* Icon bitmaps) (BITMAPS MAPL.Simple.Icon MAPL.Simple.IconMask) (* * GENERAL PLOT STUFF) (* Menu and window functions) (FNS MAPL.Gen.TopLevel MAPL.Gen.FreeMenu MAPL.Gen.MakeIconWindow) (* Plot functions) (FNS MAPL.Gen.MakePlot MAPL.Gen.Plot MAPL.Gen.ASCIIToLisp MAPL.Gen.NewPlot MAPL.Gen.PlotObject MAPL.Gen.EndPlot MAPL.Gen.NewPen MAPL.Gen.CollectData) (* Icon bitmaps) (BITMAPS MAPL.Gen.Icon MAPL.Gen.IconMask) (* vars) (P (MAPL.MakeReadtable)) (GLOBALVARS MAPL.ASCIIRDTBL) (ADDVARS (BackgroundMenuCommands (Plot% Menus (QUOTE (MAPL.TopLevel)) "Opens all Plot Menus" (SUBITEMS (General% PlotMenu (QUOTE (MAPL.Gen.TopLevel) ) "Open a General Plot Menu") (Simple% PlotMenu (QUOTE ( MAPL.Simple.TopLevel)) "Open a Simple Plot Menu") (Meta% PlotMenu (QUOTE (MAPL.Meta.TopLevel )) "Open a MetaCode Plot Menu"))))) (VARS (BackgroundMenu NIL)))) (* * ALL PLOTS) (* Files for Log functions) (FILESLOAD plotexamples.dcom {INDIGO}IDLPLOT>FIXES>LOGPATCH.DCOM) (* Low-level I/0 functions) (DEFINEQ (MAPL.TopLevel (LAMBDA NIL (* DSB " 5-Dec-86 11:39") (* opens all plot menus) (MAPL.Gen.TopLevel) (MAPL.Simple.TopLevel) (MAPL.Meta.TopLevel))) (MAPL.MakeReadtable (LAMBDA NIL (* DSB "24-Nov-86 09:53") (* * Makes a readtable that reads ASCII records which end in carriage returns as strings, recognizing only CR as a  separator character) (SETQ MAPL.ASCIIRDTBL (COPYREADTABLE FILERDTBL)) (SETSEPR (QUOTE (13)) NIL MAPL.ASCIIRDTBL))) (MAPL.ReadASCIILine (LAMBDA (fileStream) (* DSB "24-Nov-86 13:27") (* * reads one record from a free-form ASCII file and returns a list of the data items in that record) (LET ((stringstream (OPENSTRINGSTREAM (RSTRING fileStream MAPL.ASCIIRDTBL))) newChar) (READC fileStream) (while (NOT (EOFP stringstream)) collect (READ stringstream))))) (MAPL.ExpandFilename (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:21") (* if filename is fullFilename, expand it into the  separate slots) (PROG ((state (FM.READSTATE WINDOW)) filename host directory name extension version shortName) (SETQ filename (LISTGET state (QUOTE FILENAME))) (SETQ host (UNPACKFILENAME filename (QUOTE HOST))) (COND (host (SETQ directory (UNPACKFILENAME filename (QUOTE DIRECTORY))) (SETQ name (UNPACKFILENAME filename (QUOTE NAME))) (SETQ extension (UNPACKFILENAME filename (QUOTE EXTENSION))) (SETQ version (UNPACKFILENAME filename (QUOTE VERSION))) (SETQ shortName (PACKFILENAME (QUOTE NAME) name (QUOTE EXTENSION) extension (QUOTE VERSION) version)) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE FILENAME)) WINDOW shortName) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE DIRECTORY)) WINDOW directory) (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE HOST)) WINDOW host) (SETQ state (FM.READSTATE WINDOW)))) (RETURN state)))) ) (* * METACODE PLOT STUFF) (* Menu and window functions) (DEFINEQ (MAPL.Meta.TopLevel (LAMBDA NIL (* DSB " 5-Dec-86 11:49") (* Sets up the MetaCode Plot Free Menu) (PROG (menuWindow) (SETQ menuWindow (MAPL.Meta.FreeMenu)) (* initialize to PenFlag ON) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE PEN)) menuWindow) (* set up menu window) (WINDOWPROP menuWindow (QUOTE ICONFN) (FUNCTION MAPL.Meta.MakeIconWindow)) (SHAPEW menuWindow (QUOTE (200 420 271 127))) (OPENW menuWindow)))) (MAPL.Meta.FreeMenu (LAMBDA (LEFT BOTTOM) (* DSB " 3-Dec-86 12:33") (* returns a free menu window for MetaCode plots at  specified position) (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD)) (LABEL MakePlot SELECTEDFN MAPL.Meta.MakePlot)) ((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD))) ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) ITEMS (FILENAME)) (TYPE EDIT ID FILENAME LABEL "")) ((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD) ITEMS (DIRECTORY)) (TYPE EDIT ID DIRECTORY LABEL "")) ((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD) ITEMS (HOST)) (TYPE EDIT ID HOST LABEL "")) ((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD))) ((TYPE TITLE LABEL PenWidth: FONT (MODERN 12 BOLD)) (TYPE NWAY ID PEN LABEL ON) (TYPE NWAY ID PEN LABEL OFF)) (WINDOWPROPS TITLE "MetaCode Plot Menu" LEFT , LEFT BOTTOM , BOTTOM))) ))) (MAPL.Meta.MakeIconWindow (LAMBDA (WINDOW OLDICON) (* DSB " 5-Dec-86 18:01") (* * Creates a shrink window with an icon formed by two bit maps.) (OR OLDICON (ICONW MAPL.Meta.Icon MAPL.Meta.IconMask)))) ) (* Plot functions) (DEFINEQ (MAPL.Meta.MakePlot (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:32") (* checks that required data is specified and that the fullFilename is valid, and makes the MetaCode plot.) (PROG ((promptW (GETPROMPTWINDOW WINDOW)) state filename directory host penFlag fullFilename) (* * check that all required data is specified) (CLEARW promptW) (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PRIN1 "Unspecified file name." promptW) (RETURN))) (SETQ directory (LISTGET state (QUOTE DIRECTORY))) (COND ((EQUAL directory "") (PRIN1 "Unspecified directory." promptW) (RETURN))) (SETQ host (LISTGET state (QUOTE HOST))) (COND ((EQUAL host "") (PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW) (RETURN))) (SETQ penFlag (EQ (QUOTE ON) (LISTGET state (QUOTE PEN)))) (* * make fullFilename) (SETQ fullFilename (PACKFILENAME (QUOTE HOST) host (QUOTE DIRECTORY) directory (QUOTE BODY) filename)) (* * if fullFilename is valid, then make plot) (COND ((NOT (INFILEP fullFilename)) (PRIN1 "File not found" promptW) (RETURN)) (T (PRIN1 "Making plot ..." promptW) (MAPL.Meta.Plot fullFilename penFlag) (CLEARW promptW) (PRIN1 "Done" promptW) (RETURN)))))) (MAPL.Meta.Plot (LAMBDA (file penFlag) (* DSB " 3-Dec-86 13:14") (* * makes a PLOT of the metacode file) (PROG (dataList plot code newVal1 newVal2 curveList pen) (SETQ dataList (MAPL.Meta.ASCIIToLisp file)) (* (PRIN1 dataList PROMPTWINDOW)) (COND ((NOT dataList) (RETURN (PROMPTPRINT "There is no data")))) (for item in dataList do (SETQ code (CAR item)) (SETQ newVal1 (CADR item)) (SETQ newVal2 (CADDR item)) (SELECTQ code (1 (SETQ plot (MAPL.Meta.NewPlotCom)) (* New plot) ) (2 (SETQ curveList (MAPL.Meta.DrawCom curveList newVal1 newVal2))) (3 (SETQ curveList (MAPL.Meta.MoveCom plot curveList pen newVal1 newVal2))) (4 (MAPL.Meta.EndPlotCom plot curveList pen) (* End of plot) ) (5 (SETQ pen (MAPL.Meta.NewPenCom newVal1 penFlag)) (* New pen) ) NIL))))) (MAPL.Meta.ASCIIToLisp (LAMBDA (file) (* DSB "25-Nov-86 09:54") (* * returns ASCII data from a file in a list, with one sub-list per line. The file must end in a CR.) (PROG ((tempFile (QUOTE {core}tempplot.dat)) fileStream dataList) (COND ((NOT (INFILEP file)) (RETURN NIL))) (COPYFILE file tempFile) (* copy to {core} because reads from filestream to  {core} are much faster than reads from filestream to a VAX on the network.) (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT))) (SETQ dataList (while (NOT (EOFP tempFile)) collect (MAPL.ReadASCIILine fileStream))) (CLOSEF fileStream) (DELFILE tempFile) (RETURN dataList)))) ) (* Metaplot functions) (DEFINEQ (MAPL.Meta.NewPlotCom (LAMBDA NIL (* DSB " 5-Dec-86 11:51") (* * starts a new plot) (PROG NIL (SETQ curveList NIL) (RETURN (CREATEPLOT NIL (QUOTE (471 420 250 250)) "MetaCode Plot"))))) (MAPL.Meta.MoveCom (LAMBDA (plot curveList pen newVal1 newVal2) (* DSB "25-Nov-86 09:01") (* * Plots the previous curve, and moves to a new position, starting a new curve) (PROG NIL (COND ((AND curveList (GREATERP (LENGTH curveList) 1)) (PLOTCURVE plot curveList NIL pen NIL T))) (SETQ curveList (LIST (CONS newVal1 newVal2))) (RETURN curveList)))) (MAPL.Meta.DrawCom (LAMBDA (curveList newVal1 newVal2) (* DSB "24-Nov-86 13:31") (* * adds a new set of points to the curveList) (PROG NIL (SETQ curveList (CONS (CONS newVal1 newVal2) curveList)) (RETURN curveList)))) (MAPL.Meta.EndPlotCom (LAMBDA (plot curveList pen) (* DSB "25-Nov-86 09:01") (* * plots the last curve and opens the plot. It is expected that no more curves will be drawn to the plot) (PROG NIL (COND ((AND curveList (GREATERP (LENGTH curveList) 1)) (PLOTCURVE plot curveList NIL pen NIL T))) (OPENPLOTWINDOW plot)))) (MAPL.Meta.NewPenCom (LAMBDA (newVal1 penFlag) (* DSB " 3-Dec-86 15:25") (* * If penFlag is OFF, sets pen to 1) (* * if penFlag is ON, sets the pen to INT ((PEN + 1) /2)) (PROG (pen) (COND (penFlag (SETQ pen (IQUOTIENT (PLUS newVal1 1) 2))) (T (SETQ pen 1))) (RETURN pen)))) ) (* Icon bitmaps) (RPAQ MAPL.Meta.Icon (READBITMAP)) (70 70 "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "L@@@@@@@@@ON@@@@@L@@" "L@@@@@@@@@GO@@@@@L@@" "LGOH@COOOOOOOOOOLL@@" "LDLH@B@@@@AOH@@@DL@@" "LDLH@B@@@@@OL@@@DL@@" "LD@H@B@@@@@GN@@@DL@@" "LD@H@BB@@@@CO@@@DL@@" "LNAL@BB@@@@AOH@@DL@@" "L@@@@BF@@@@@OH@@DL@@" "L@@@@BB@@@@@GL@@DL@@" "L@A@@BB@@@@@CL@@DL@@" "LCO@@BB@@@@@AN@@DL@@" "LBA@@BF@@@@@@F@@DL@@" "LB@@@BB@@@@@@C@@DL@@" "LCH@@BB@@@@@@AH@DL@@" "LCH@@BB@@CL@@GH@DL@@" "LB@@@BF@@FF@AL@@DL@@" "LBAAOBB@@LC@C@@@DL@@" "LCOAOBB@AHAHN@@@DL@@" "L@A@@BB@C@@OH@@@DL@@" "L@@@@BF@F@@@@@@@DL@@" "L@@@@BB@L@@@@@@@DL@@" "LCO@@BB@H@@@@@@@DL@@" "L@L@@BBAH@@@@@@@DL@@" "L@L@@BFA@@@@@@@@DL@@" "L@L@@BBC@@@@@@@@DL@@" "L@L@@BBB@@@@@@@@DL@@" "L@L@@BBF@@@@@@@@DL@@" "L@@@@BFD@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@L@@BB@@@@@@@@@DL@@" "LAN@@BB@@@@@@@@@DL@@" "LAB@@BGOOOOOOOONDL@@" "LCO@@BBBBBBBBBBBDL@@" "LBA@@B@@@@@@@@@@DL@@" "LFAH@COOOOOOOOOOLL@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "LOOOOOH@@@@@@@@@@L@@" "L@LOLL@@@@@@@@@@@L@@" "LAHGHF@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@ON@OO@NALL@@" "LC@C@C@@NF@NG@FAHL@@" "LC@C@C@@LB@LC@FAHL@@" "LC@C@C@@H@@LC@FAHL@@" "LC@C@C@@LH@LC@FAHL@@" "LC@C@C@@OH@LC@FAHL@@" "LC@C@C@@LH@LC@FAHL@@" "LC@GHC@@H@@LC@FAHL@@" "LC@@@C@@LB@LC@FAHL@@" "LC@@@C@@NF@LC@GCHL@@" "LC@@@C@@ONALCHGOHL@@" "LC@@@C@@@@@@@@@@@L@@" "LOH@@GL@@@@@@@@@@L@@" "LOH@@GL@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@") (RPAQ MAPL.Meta.IconMask (READBITMAP)) (70 70 "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@") (* * SIMPLE PLOT STUFF) (* Menu and window functions) (DEFINEQ (MAPL.Simple.TopLevel (LAMBDA NIL (* DSB " 8-Dec-86 08:00") (* Sets up the Simple Plot Free Menu) (PROG (menuWindow) (SETQ menuWindow (MAPL.Simple.FreeMenu 200 250)) (* * initialize plot defaults) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE TYPE)) menuWindow) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE REP)) menuWindow) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE DEST)) menuWindow) (* * finish setup of free menu) (WINDOWPROP menuWindow (QUOTE ICONFN) (FUNCTION MAPL.Simple.MakeIconWindow)) (OPENW menuWindow)))) (MAPL.Simple.FreeMenu (LAMBDA (LEFT BOTTOM) (* DSB " 8-Dec-86 07:59") (* returns a free menu window for simple plots at  specified position) (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD)) (LABEL MakePlot SELECTEDFN MAPL.Simple.MakePlot)) ((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD))) ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) ITEMS (FILENAME)) (TYPE EDIT ID FILENAME LABEL "")) ((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD) ITEMS (DIRECTORY)) (TYPE EDIT ID DIRECTORY LABEL "")) ((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD) ITEMS (HOST)) (TYPE EDIT ID HOST LABEL "")) ((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD))) ((TYPE TITLE LABEL PlotType: FONT (MODERN 12 BOLD)) (TYPE NWAY ID TYPE LABEL X-Y CLASSNAME XY) (TYPE NWAY ID TYPE LABEL X-LogY CLASSNAME X-LogY) (TYPE NWAY ID TYPE LABEL LogX-Y CLASSNAME LogX-Y) (TYPE NWAY ID TYPE LABEL LogX-LogY CLASSNAME LogX-LogY)) ((TYPE TITLE LABEL Representation: FONT (MODERN 12 BOLD)) (TYPE NWAY ID REP LABEL Curve CLASSNAME Curve) (TYPE NWAY ID REP LABEL Points CLASSNAME Points) (TYPE NWAY ID REP LABEL Both CLASSNAME Both)) ((TYPE EDITSTART LABEL PenWidth: FONT (MODERN 12 BOLD) ITEMS (PEN)) (TYPE EDIT ID PEN LABEL "1")) ((TYPE TITLE LABEL Destination: FONT (MODERN 12 BOLD)) (TYPE NWAY ID DEST LABEL New CLASSNAME New) (TYPE NWAY ID DEST LABEL Previous CLASSNAME Previous)) (WINDOWPROPS TITLE "Simple Plot Menu" LEFT , LEFT BOTTOM , BOTTOM))))) ) (MAPL.Simple.MakeIconWindow (LAMBDA (WINDOW OLDICON) (* DSB " 5-Dec-86 18:00") (* * Creates a window with an icon formed by two bit maps.) (OR OLDICON (ICONW MAPL.Simple.Icon MAPL.Simple.IconMask)))) ) (* Plot functions) (DEFINEQ (MAPL.Simple.MakePlot (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:27") (* checks that required data is specified and that the fullFilename is valid, and makes the simple plot.) (PROG ((promptW (GETPROMPTWINDOW WINDOW)) state filename directory host type rep penWidth dest fullFilename) (* * check that all required data is specified) (CLEARW promptW) (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PRIN1 "Unspecified file name." promptW) (RETURN))) (SETQ directory (LISTGET state (QUOTE DIRECTORY))) (COND ((EQUAL directory "") (PRIN1 "Unspecified directory." promptW) (RETURN))) (SETQ host (LISTGET state (QUOTE HOST))) (COND ((EQUAL host "") (PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW) (RETURN))) (SETQ type (LISTGET state (QUOTE TYPE))) (COND ((NOT type) (PRIN1 "Unspecified plot type (XY, etc)." promptW) (RETURN))) (SETQ rep (LISTGET state (QUOTE REP))) (COND ((NOT rep) (PRIN1 "Unspecified represent. (Points,etc.)" promptW) (RETURN))) (SETQ penWidth (MKATOM (LISTGET state (QUOTE PEN)))) (COND ((AND (NUMBERP penWidth) (GREATERP penWidth 0)) (SETQ penWidth (FIX penWidth))) (T (PRIN1 "PenWidth must be integer > 0" promptW) (RETURN))) (SETQ dest (LISTGET state (QUOTE DEST))) (COND ((NOT dest) (PRIN1 "Unspecified destination (New, etc.)" promptW) (RETURN))) (* * make fullFilename) (SETQ fullFilename (PACKFILENAME (QUOTE HOST) host (QUOTE DIRECTORY) directory (QUOTE BODY) filename)) (* * if fullFilename is valid, then make plot) (COND ((NOT (INFILEP fullFilename)) (PRIN1 "File not found" promptW) (RETURN)) (T (PRIN1 "Making plot ..." promptW) (MAPL.Simple.Plot fullFilename promptW rep type penWidth dest) (CLEARW promptW) (PRIN1 "Done" promptW) (RETURN)))))) (MAPL.Simple.Plot (LAMBDA (filename promptW rep type penWidth dest) (* DSB " 8-Dec-86 08:53") (* Makes the plot and puts it into the appropriate  window) (* * takes an ASCII file of pairs of X-Y values, converts it into list format, and then converts it into a list of  dotted pairs of data for requested plot.) (PROG ((rightMenuItems (QUOTE ((Logscale SCAT.LOGSCALE "Toggle exponential tics" (SUBITEMS (X% axis (SCAT.LOGSCALE (QUOTE X)) "X axis only") (Y% axis (SCAT.LOGSCALE (QUOTE Y)) "Y axis only"))) (Coordinates SCAT.WORLDCOORD "Display world coordinates at cursor position")))) (pointMenuItems (QUOTE ((Coordinates SCAT.POINTCOORDS "Display point coordinates")))) (tempFile (QUOTE {core}tempplot.dat)) data first second mouseDown? fileStream dataList newPlot) (* * copy to {core} and read into a list, with each line in the original file becoming a sub-list) (COPYFILE filename tempFile) (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT))) (SETQ dataList (while (NOT (EOFP tempFile)) collect (MAPL.ReadASCIILine fileStream))) (CLOSEF fileStream) (DELFILE tempFile) (* * translate to list of dotted pairs, depending on type of plot to be made) (SETQ data NIL) (COND ((EQUAL type (QUOTE X-Y)) (for item in dataList do (SETQ first (CAR item)) (SETQ second (CADR item)) (COND ((AND (NUMBERP first) (NUMBERP second)) (SETQ data (CONS (CONS first second) data)))))) ((EQUAL type (QUOTE X-LogY)) (for item in dataList do (SETQ first (CAR item)) (SETQ second (CADR item)) (COND ((AND (NUMBERP first) (NUMBERP second) (GREATERP second 0)) (SETQ data (CONS (CONS first (PLOT.LOG10 second)) data)))))) ((EQUAL type (QUOTE LogX-Y)) (for item in dataList do (SETQ first (CAR item)) (SETQ second (CADR item)) (COND ((AND (NUMBERP first) (GREATERP first 0) (NUMBERP second)) (SETQ data (CONS (CONS (PLOT.LOG10 first) second) data)))))) ((EQUAL type (QUOTE LogX-LogY)) (for item in dataList do (SETQ first (CAR item)) (SETQ second (CADR item)) (COND ((AND (NUMBERP first) (GREATERP first 0) (NUMBERP second) (GREATERP second 0)) (SETQ data (CONS (CONS (PLOT.LOG10 first) (PLOT.LOG10 second)) data)))))) (T (CLEARW promptW) (PRIN1 "Error: Unknown plot type" promptW) (RETURN))) (CLEARW promptW) (* * If the new data is to be put on a previous plot, the user has 20 seconds to button in the desired plot window) (* * otherwise, the data goes into a new plot) (COND ((EQUAL dest (QUOTE Previous)) (PRIN1 "Button in desired plot window" promptW) (SETQ mouseDown? (UNTILMOUSESTATE LEFT 20000)) (COND (mouseDown? (COND ((EQUAL rep (QUOTE Points)) (PLOTPOINTS (WHICHPLOT) data) (RETURN)) ((EQUAL rep (QUOTE Curve)) (PLOTCURVE (WHICHPLOT) data NIL penWidth) (RETURN)) ((EQUAL rep (QUOTE Both)) (PLOTPOINTS (WHICHPLOT) data) (PLOTCURVE (WHICHPLOT) data NIL penWidth) (RETURN)) (T (PRIN1 "Error: Unknown represent." promptW) (RETURN)))) (T (PRIN1 "Making a new plot." promptW))))) (SETQ newPlot (CREATEPLOT NIL (QUOTE (471 250 250 250)) "Simple Plot")) (PLOTADDMENUITEMS newPlot (QUOTE RIGHT) rightMenuItems) (PLOTMENUITEMS newPlot (QUOTE POINTMENU) (APPEND (PLOTMENUITEMS newPlot (QUOTE MIDDLE)) pointMenuItems)) (COND ((EQUAL rep (QUOTE Curve)) (PLOTCURVE newPlot data NIL penWidth)) ((EQUAL rep (QUOTE Points)) (PLOTPOINTS newPlot data)) ((EQUAL rep (QUOTE Both)) (PLOTCURVE newPlot data NIL penWidth) (PLOTPOINTS newPlot data)) (T (PRIN1 "Error: Unknown represent." promptW) (RETURN))) (OPENPLOTWINDOW newPlot)))) ) (* Icon bitmaps) (RPAQ MAPL.Simple.Icon (READBITMAP)) (70 70 "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "L@@@@@@@@@ON@@@@@L@@" "L@@@@@@@@@GO@@@@@L@@" "L@@@@COOOOOOOOOOLL@@" "L@@@@B@@@@AOH@@@DL@@" "L@@@@B@@@@@OL@@@DL@@" "L@@@@B@@@@@GN@@@DL@@" "L@@@@BB@@@@CO@@@DL@@" "L@@@@BB@@@@AOH@@DL@@" "L@@@@BF@@@@@OH@@DL@@" "L@@@@BB@@@@@GL@@DL@@" "L@@@@BB@@@@@CL@@DL@@" "LOO@@BB@@@@@AN@@DL@@" "LLC@@BF@@@@@@F@@DL@@" "LLC@@BB@@@@@@C@@DL@@" "LL@@@BB@@@@@@AH@DL@@" "LL@@@BB@@CL@@GH@DL@@" "LL@@@BF@@FF@AL@@DL@@" "LL@CNBB@@LC@C@@@DL@@" "LOOCNBB@AHAHN@@@DL@@" "L@C@@BB@C@@OH@@@DL@@" "L@C@@BF@F@@@@@@@DL@@" "L@C@@BB@L@@@@@@@DL@@" "L@C@@BB@H@@@@@@@DL@@" "LLC@@BBAH@@@@@@@DL@@" "LLC@@BFA@@@@@@@@DL@@" "LOO@@BBC@@@@@@@@DL@@" "L@@@@BBB@@@@@@@@DL@@" "L@@@@BBF@@@@@@@@DL@@" "L@@@@BFD@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@@@@BGOOOOOOOONDL@@" "L@@@@BBBBBBBBBBBDL@@" "L@@@@B@@@@@@@@@@DL@@" "L@@@@COOOOOOOOOOLL@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "LOOOOOH@@@@@@@@@@L@@" "L@LOLL@@@@@@@@@@@L@@" "LAHGHF@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@ON@OO@NALL@@" "LC@C@C@@NF@NG@FAHL@@" "LC@C@C@@LB@LC@FAHL@@" "LC@C@C@@H@@LC@FAHL@@" "LC@C@C@@LH@LC@FAHL@@" "LC@C@C@@OH@LC@FAHL@@" "LC@C@C@@LH@LC@FAHL@@" "LC@GHC@@H@@LC@FAHL@@" "LC@@@C@@LB@LC@FAHL@@" "LC@@@C@@NF@LC@GCHL@@" "LC@@@C@@ONALCHGOHL@@" "LC@@@C@@@@@@@@@@@L@@" "LOH@@GL@@@@@@@@@@L@@" "LOH@@GL@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@") (RPAQ MAPL.Simple.IconMask (READBITMAP)) (70 70 "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@") (* * GENERAL PLOT STUFF) (* Menu and window functions) (DEFINEQ (MAPL.Gen.TopLevel (LAMBDA NIL (* DSB " 5-Dec-86 11:45") (* Sets up the General Plot Free Menu) (PROG (menuWindow) (SETQ menuWindow (MAPL.Gen.FreeMenu 200 50)) (* * initialize plot defaults) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE TYPE)) menuWindow) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE REP)) menuWindow) (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE PEN)) menuWindow) (* * finish setup of free menu) (WINDOWPROP menuWindow (QUOTE ICONFN) (FUNCTION MAPL.Gen.MakeIconWindow)) (OPENW menuWindow)))) (MAPL.Gen.FreeMenu (LAMBDA (LEFT BOTTOM) (* DSB " 4-Dec-86 13:09") (* returns a free menu window for simple plots at  specified position) (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD)) (LABEL MakePlot SELECTEDFN MAPL.Gen.MakePlot)) ((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD))) ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) ITEMS (FILENAME)) (TYPE EDIT ID FILENAME LABEL "")) ((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD) ITEMS (DIRECTORY)) (TYPE EDIT ID DIRECTORY LABEL "")) ((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD) ITEMS (HOST)) (TYPE EDIT ID HOST LABEL "")) ((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD))) ((TYPE EDITSTART LABEL X-Position: FONT (MODERN 12 BOLD) ITEMS (XPOS)) (TYPE EDIT ID XPOS LABEL "1")) ((TYPE EDITSTART LABEL Y-Position: FONT (MODERN 12 BOLD) ITEMS (YPOS)) (TYPE EDIT ID YPOS LABEL "2")) ((TYPE TITLE LABEL PlotType: FONT (MODERN 12 BOLD)) (TYPE NWAY ID TYPE LABEL X-Y CLASSNAME XY) (TYPE NWAY ID TYPE LABEL X-LogY CLASSNAME X-LogY) (TYPE NWAY ID TYPE LABEL LogX-Y CLASSNAME LogX-Y) (TYPE NWAY ID TYPE LABEL LogX-LogY CLASSNAME LogX-LogY)) ((TYPE TITLE LABEL Representation: FONT (MODERN 12 BOLD)) (TYPE NWAY ID REP LABEL Curve CLASSNAME Curve) (TYPE NWAY ID REP LABEL Points CLASSNAME Points) (TYPE NWAY ID REP LABEL Both CLASSNAME Both)) ((TYPE TITLE LABEL PenWidth: FONT (MODERN 12 BOLD)) (TYPE NWAY ID PEN LABEL ON) (TYPE NWAY ID PEN LABEL OFF)) (WINDOWPROPS TITLE "General Plot Menu" LEFT , LEFT BOTTOM , BOTTOM)))) )) (MAPL.Gen.MakeIconWindow (LAMBDA (WINDOW OLDICON) (* DSB " 5-Dec-86 17:42") (* * Creates a shrink window with an icon formed by two bit maps.) (OR OLDICON (ICONW MAPL.Gen.Icon MAPL.Gen.IconMask)))) ) (* Plot functions) (DEFINEQ (MAPL.Gen.MakePlot (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:30") (* checks that required data is specified and that the fullFilename is valid, and makes the simple plot.) (PROG ((promptW (GETPROMPTWINDOW WINDOW)) state filename directory host type rep xPos yPos penFlag fullFilename) (* * check that all required data is specified) (CLEARW promptW) (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS)) (SETQ filename (LISTGET state (QUOTE FILENAME))) (COND ((EQUAL filename "") (PRIN1 "Unspecified file name." promptW) (RETURN))) (SETQ directory (LISTGET state (QUOTE DIRECTORY))) (COND ((EQUAL directory "") (PRIN1 "Unspecified directory." promptW) (RETURN))) (SETQ host (LISTGET state (QUOTE HOST))) (COND ((EQUAL host "") (PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW) (RETURN))) (SETQ xPos (MKATOM (LISTGET state (QUOTE XPOS)))) (* if xPos is not a number, set it to NIL for a  Time-Series plot) (COND ((NOT (NUMBERP xPos)) (SETQ xPos (NUMBERP xPos)) (PRIN1 "Time-series plot..." promptW))) (SETQ yPos (MKATOM (LISTGET state (QUOTE YPOS)))) (COND ((NOT (NUMBERP yPos)) (PRIN1 "Unspecified position of 'Y' variable" promptW) (RETURN))) (SETQ type (LISTGET state (QUOTE TYPE))) (COND ((NOT type) (PRIN1 "Unspecified plot type (XY, etc)." promptW) (RETURN))) (* if xPos is NIL, do not allow Logs of the "time") (COND ((AND (NOT xPos) (OR (EQUAL type (QUOTE LogX-Y)) (EQUAL type (QUOTE LogX-LogY)))) (PRIN1 "Log of X (time) not permitted" promptW) (RETURN))) (SETQ rep (LISTGET state (QUOTE REP))) (COND ((NOT rep) (PRIN1 "Unspecified represent. (Points,etc.)" promptW) (RETURN))) (SETQ penFlag (EQ (QUOTE ON) (LISTGET state (QUOTE PEN)))) (* * make fullFilename) (SETQ fullFilename (PACKFILENAME (QUOTE HOST) host (QUOTE DIRECTORY) directory (QUOTE BODY) filename)) (* * if fullFilename is valid, then make plot) (COND ((NOT (INFILEP fullFilename)) (PRIN1 "File not found" promptW) (RETURN)) (T (PRIN1 "Making plot ..." promptW) (MAPL.Gen.Plot fullFilename promptW xPos yPos rep type penFlag) (CLEARW promptW) (PRIN1 "Done" promptW) (RETURN)))))) (MAPL.Gen.Plot (LAMBDA (file promptW xPos yPos rep type penFlag) (* DSB " 5-Dec-86 17:41") (* * makes a plot from the general plot input format) (PROG (dataList keyword plot objectList (pen 1) (plotNumber 1)) (* * get a data list of those pairs of data you want to plot) (SETQ dataList (MAPL.Gen.ASCIIToLisp file xPos yPos)) (* (PRIN1 dataList PROMPTWINDOW)) (* * parse and plot) (COND ((NOT dataList) (RETURN (PRIN1 "There is no data" promptW)))) (for item in dataList do (SETQ keyword (CAR item)) (SELECTQ keyword (NEWPLOT (SETQ plot (MAPL.Gen.NewPlot plotNumber)) (* New plot) ) (START (SETQ objectList NIL) (* Start new object) ) (END (SETQ objectList (MAPL.Gen.PlotObject plot objectList pen rep) ) (* Plot the object) ) (ENDPLOT (SETQ plotNumber (MAPL.Gen.EndPlot plot plotNumber)) (* End of plot) ) (NEWPEN (SETQ pen (MAPL.Gen.NewPen item penFlag)) (* New pen) ) (SETQ objectList (MAPL.Gen.CollectData objectList item type))))))) (MAPL.Gen.ASCIIToLisp (LAMBDA (file xPos yPos) (* DSB " 5-Dec-86 17:34") (* * returns ASCII data from a file in a list, with one sub-list per line. The file must end in a CR.) (PROG ((tempFile (QUOTE {core}tempplot.dat)) (keywordList (QUOTE (NEWPLOT ENDPLOT START END NEWPEN))) fileStream dataList lineList key shortList) (COND ((NOT (INFILEP file)) (RETURN NIL))) (COPYFILE file tempFile) (* * copy to {core} because reads from filestream to {core} are much faster than reads from filestream to a VAX on  the network.) (* * if Keyword, return the line as is; otherwise, only include the numbers in the positions requested.) (* * if xPos is NIL, put NIL in the first position of the short list) (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT))) (while (NOT (EOFP tempFile)) do (SETQ lineList (MAPL.ReadASCIILine fileStream)) (SETQ key (CAR lineList)) (COND ((MEMBER key keywordList) (SETQ shortList lineList)) ((NOT xPos) (SETQ shortList (LIST NIL (CAR (NTH lineList yPos))))) (T (SETQ shortList (LIST (CAR (NTH lineList xPos)) (CAR (NTH lineList yPos)))))) (SETQ dataList (CONS shortList dataList))) (CLOSEF fileStream) (DELFILE tempFile) (RETURN (REVERSE dataList))))) (MAPL.Gen.NewPlot (LAMBDA (plotNumber) (* DSB " 5-Dec-86 11:44") (* * starts a new plot with Log scaling) (PROG (newPlot (leftFirst 471) left (bottomFirst 50) bottom region (rightMenuItems (QUOTE ((Logscale SCAT.LOGSCALE "Toggle exponential tics" (SUBITEMS (X% axis (SCAT.LOGSCALE (QUOTE X)) "X axis only") (Y% axis (SCAT.LOGSCALE (QUOTE Y)) "Y axis only"))) (Coordinates SCAT.WORLDCOORD "Display world coordinates at cursor position")))) (pointMenuItems (QUOTE ((Coordinates SCAT.POINTCOORDS "Display point coordinates"))))) (SETQ left (PLUS leftFirst (TIMES 25 (DIFFERENCE plotNumber 1)))) (SETQ bottom (PLUS bottomFirst (TIMES 25 (DIFFERENCE plotNumber 1)))) (SETQ region (CREATEREGION left bottom 250 250)) (SETQ newPlot (CREATEPLOT NIL region "General Plot")) (PLOTADDMENUITEMS newPlot (QUOTE RIGHT) rightMenuItems) (PLOTMENUITEMS newPlot (QUOTE POINTMENU) (APPEND (PLOTMENUITEMS newPlot (QUOTE MIDDLE)) pointMenuItems)) (RETURN newPlot)))) (MAPL.Gen.PlotObject (LAMBDA (plot objectList pen rep) (* DSB " 8-Dec-86 07:28") (* * plots the objectList, with specified pen and according to the chosen representation (e.g., points, curve,  both)) (* * when plotting points, ignore the pen size) (PROG NIL (COND ((NOT plot) (RETURN (PRIN1 "ERROR: NEWPLOT command omitted. " PROMPTWINDOW)))) (COND ((AND objectList (GREATERP (LENGTH objectList) 0)) (COND ((EQUAL rep (QUOTE Curve)) (PLOTCURVE plot objectList NIL pen NIL T)) ((EQUAL rep (QUOTE Points)) (PLOTPOINTS plot objectList NIL NIL NIL T)) ((EQUAL rep (QUOTE Both)) (PLOTCURVE plot objectList NIL pen NIL T) (PLOTPOINTS plot objectList NIL NIL NIL T)))) (T (PROMPTPRINT "ERROR: PlotObject is NIL and not drawn"))) (RETURN NIL)))) (MAPL.Gen.EndPlot (LAMBDA (plot plotNumber) (* DSB " 4-Dec-86 14:17") (* * opens the plotwindow, and returns a new increment for the next plot position) (PROG NIL (OPENPLOTWINDOW plot) (RETURN (PLUS plotNumber 1))))) (MAPL.Gen.NewPen (LAMBDA (item penFlag) (* DSB " 8-Dec-86 07:30") (* * If penFlag is OFF, sets pen to 1; otherwise, sets pen width as instructed.) (PROG (pen) (COND (penFlag (SETQ pen (CADR item))) (T (SETQ pen 1))) (RETURN pen)))) (MAPL.Gen.CollectData (LAMBDA (objectList item type) (* DSB " 8-Dec-86 09:43") (* * adds the appropriate dotted pair (determined by dest and the input item) to the objectList.) (PROG ((xVal (CAR item)) (yVal (CADR item)) newItem) (* * not numbers; don't do anything) (COND ((NOT (NUMBERP yVal)) (RETURN objectList))) (* * if xVal is NIL (not a number) but yVal is a number, then assume the user is asking for a time sequence. However, LogX is not allowed. This will slip past MAPL.Gen.MakePlot if the X-position is given as a  (too large) number. We stop that here.) (COND ((AND (NOT (NUMBERP xVal)) (NUMBERP yVal)) (COND ((OR (EQUAL type (QUOTE LogX-Y)) (EQUAL type (QUOTE LogX-LogY))) (PROMPTPRINT "Log X for X=time-sequence not allowed") (RETURN objectList))) (COND ((NOT objectList) (SETQ xVal 0)) (T (SETQ xVal (PLUS 1 (CAAR objectList))))))) (* * non time-series plot) (COND ((EQUAL type (QUOTE X-Y)) (SETQ newItem (CONS xVal yVal))) ((EQUAL type (QUOTE X-LogY)) (COND ((GREATERP yVal 0) (SETQ newItem (CONS xVal (PLOT.LOG10 yVal)))) (T (PROMPTPRINT "ERROR: Attempt to take Log of negative number " yVal)))) ((EQUAL type (QUOTE LogX-Y)) (COND ((GREATERP xVal 0) (SETQ newItem (CONS (PLOT.LOG10 xVal) yVal))) (T (PROMPTPRINT "ERROR: Attempt to take Log of negative number " xVal)))) ((EQUAL type (QUOTE LogX-LogY)) (COND ((AND (GREATERP xVal 0) (GREATERP yVal 0)) (SETQ newItem (CONS (PLOT.LOG10 xVal) (PLOT.LOG10 yVal)))) (T (PROMPTPRINT "ERROR: Attempt to take Log of neg. number at point (" xVal "," yVal ")")))) (T (PRIN1 "ERROR: Unknown plot type requested" PROMPTWINDOW))) (COND (newItem (SETQ objectList (CONS newItem objectList)))) (RETURN objectList)))) ) (* Icon bitmaps) (RPAQ MAPL.Gen.Icon (READBITMAP)) (70 70 "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "L@@@@@@@@@ON@@@@@L@@" "L@@@@@@@@@GO@@@@@L@@" "L@@@@COOOOOOOOOOLL@@" "L@@@@B@@@@AOH@@@DL@@" "L@@@@B@@@@@OL@@@DL@@" "L@@@@B@@@@@GN@@@DL@@" "L@@@@BB@@@@CO@@@DL@@" "L@@@@BB@@@@AOH@@DL@@" "L@@@@BF@@@@@OH@@DL@@" "L@@@@BB@@@@@GL@@DL@@" "L@@@@BB@@@@@CL@@DL@@" "LOOH@BB@@@@@AN@@DL@@" "LLAH@BF@@@@@@F@@DL@@" "LLAH@BB@@@@@@C@@DL@@" "LL@@@BB@@@@@@AH@DL@@" "LL@@@BB@@CL@@GH@DL@@" "LL@@@BF@@FF@AL@@DL@@" "LL@AOBB@@LC@C@@@DL@@" "LLOIOBB@AHAHN@@@DL@@" "LLMH@BB@C@@OH@@@DL@@" "LLMH@BF@F@@@@@@@DL@@" "LLAH@BB@L@@@@@@@DL@@" "LLAH@BB@H@@@@@@@DL@@" "LLAH@BBAH@@@@@@@DL@@" "LLAH@BFA@@@@@@@@DL@@" "LOOH@BBC@@@@@@@@DL@@" "L@@@@BBB@@@@@@@@DL@@" "L@@@@BBF@@@@@@@@DL@@" "L@@@@BFD@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@@@@BB@@@@@@@@@DL@@" "L@@@@BGOOOOOOOONDL@@" "L@@@@BBBBBBBBBBBDL@@" "L@@@@B@@@@@@@@@@DL@@" "L@@@@COOOOOOOOOOLL@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "LOOOOOH@@@@@@@@@@L@@" "L@LOLL@@@@@@@@@@@L@@" "LAHGHF@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@@@@@@@@@@L@@" "LC@C@C@@ON@OO@NALL@@" "LC@C@C@@NF@NG@FAHL@@" "LC@C@C@@LB@LC@FAHL@@" "LC@C@C@@H@@LC@FAHL@@" "LC@C@C@@LH@LC@FAHL@@" "LC@C@C@@OH@LC@FAHL@@" "LC@C@C@@LH@LC@FAHL@@" "LC@GHC@@H@@LC@FAHL@@" "LC@@@C@@LB@LC@FAHL@@" "LC@@@C@@NF@LC@GCHL@@" "LC@@@C@@ONALCHGOHL@@" "LC@@@C@@@@@@@@@@@L@@" "LOH@@GL@@@@@@@@@@L@@" "LOH@@GL@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "L@@@@@@@@@@@@@@@@L@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@") (RPAQ MAPL.Gen.IconMask (READBITMAP)) (70 70 "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@" "OOOOOOOOOOOOOOOOOL@@") (* vars) (MAPL.MakeReadtable) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MAPL.ASCIIRDTBL) ) (ADDTOVAR BackgroundMenuCommands (Plot% Menus (QUOTE (MAPL.TopLevel)) "Opens all Plot Menus" (SUBITEMS (General% PlotMenu (QUOTE (MAPL.Gen.TopLevel )) "Open a General Plot Menu") (Simple% PlotMenu (QUOTE ( MAPL.Simple.TopLevel)) "Open a Simple Plot Menu") (Meta% PlotMenu (QUOTE (MAPL.Meta.TopLevel)) "Open a MetaCode Plot Menu") ))) (RPAQQ BackgroundMenu NIL) (PUTPROPS MATHSERVERPLOT COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (2744 5312 (MAPL.TopLevel 2754 . 3043) (MAPL.MakeReadtable 3045 . 3446) ( MAPL.ReadASCIILine 3448 . 3909) (MAPL.ExpandFilename 3911 . 5310)) (5383 7480 (MAPL.Meta.TopLevel 5393 . 6056) (MAPL.Meta.FreeMenu 6058 . 7203) (MAPL.Meta.MakeIconWindow 7205 . 7478)) (7508 11497 ( MAPL.Meta.MakePlot 7518 . 9264) (MAPL.Meta.Plot 9266 . 10593) (MAPL.Meta.ASCIIToLisp 10595 . 11495)) ( 11529 13474 (MAPL.Meta.NewPlotCom 11539 . 11840) (MAPL.Meta.MoveCom 11842 . 12308) (MAPL.Meta.DrawCom 12310 . 12621) (MAPL.Meta.EndPlotCom 12623 . 13057) (MAPL.Meta.NewPenCom 13059 . 13472)) (16880 19790 (MAPL.Simple.TopLevel 16890 . 17706) (MAPL.Simple.FreeMenu 17708 . 19514) (MAPL.Simple.MakeIconWindow 19516 . 19788)) (19818 27100 (MAPL.Simple.MakePlot 19828 . 22323) (MAPL.Simple.Plot 22325 . 27098)) ( 30511 33501 (MAPL.Gen.TopLevel 30521 . 31327) (MAPL.Gen.FreeMenu 31329 . 33227) ( MAPL.Gen.MakeIconWindow 33229 . 33499)) (33529 45006 (MAPL.Gen.MakePlot 33539 . 36529) (MAPL.Gen.Plot 36531 . 38142) (MAPL.Gen.ASCIIToLisp 38144 . 39718) (MAPL.Gen.NewPlot 39720 . 41084) ( MAPL.Gen.PlotObject 41086 . 42080) (MAPL.Gen.EndPlot 42082 . 42388) (MAPL.Gen.NewPen 42390 . 42736) ( MAPL.Gen.CollectData 42738 . 45004))))) STOP \ No newline at end of file diff --git a/lispusers/microtek.tedit b/lispusers/microtek.tedit new file mode 100644 index 00000000..579d1909 Binary files /dev/null and b/lispusers/microtek.tedit differ diff --git a/lispusers/oss.lisp b/lispusers/oss.lisp new file mode 100644 index 00000000..ac31ff1d --- /dev/null +++ b/lispusers/oss.lisp @@ -0,0 +1 @@ + ;-*- syntax:COMMON-LISP; Package: (OSS CL 1000) -*- ;;; DRC, March 30, 1988: Changed PROCESS-TOP to COPY-TREE ;;; the user's code so that its not bashed. This is particularly important ;;; in a resident-code environment (like XCL). ;;; AMD March 30, 1988: Changed Rlist to take advantage or RPLCONS instead of ;;; doing pushes follwed by NREVERSE. ;;; DRC, March 24, 1988: defstruct's for SYM & FRAG hacked to work in Lyric XCL ;;; patch some bugs in Lyric XCL #+Xerox (eval-when (compile load eval) (il:filesload "OSS-LYRIC-PATCHES.DFASL")) ;Anyone who wishes to, is free to use this software. However, such use ;is at the user's own risk. In particular, the system comes "as is" ;with no responsibility whatever on the part of the author or MIT. ;In addition, the following requirements must be met. ; First, the copyright notices must not be removed from this file. ; Second, if the software is redistributed to other people, proper ; credit must be given to the author. ; Third, adapting the file to run on a particular Common Lisp may ; require minor changes. However, the functionality must remain ; consistent with the documentation in MIT/AIM-958a and MIT/AIM-959a. ; (If you want a different functionality, write a new system and call ; it something else.) ;------------------------------------------------------------------------ ; ; Copyright (c) Richard C. Waters, 1988 ; ;------------------------------------------------------------------------ ; ;This file implements efficient computation with obviously synchronizable ;series expressions. All bug reports should be sent to DICK@AI.AI.MIT.EDU. ;At the author's sole descretion, bugs may or may not be fixed. ;Howevr, bug messages are very much appreciated. The functions ;in this file are documented fully in MIT/AIM-958a and MIT/AIM-959a. ;(Memo MIT/AIM-958a is an upwardly compatible, slightly revised version of ;MIT/AIM-958. The only important difference is that when an expression ;violates the restrictions, it is automatically fixed rather than just ;flagged as an error. Memo MIT/AIM-959a is identical to MIT/AIM-959 ;except for fixing a few minor errors in the document.) ;This file attempts to be as compatible with pure Common Lisp as possible. ;It has been tested on the following Common Lisps to date (3/23/88). ; Symbolics CL version 7 (does not work in version 6), ; FRANZ {Allegro} CL on a Sun, LUCID CL on a Sun, DEC CL on a VAX, ; Xerox CL, Golden CL on a PC, Coral Allegro CL on a Mac. ;The companion file OSSTST LISP contains a set of regression tests for OSS. ;You should run these tests after the first time you compile OSS on a ;new system. Time permitting, I will be glad to help with any ;transportabilty problems. #+lispm(use-package "CL") (in-package "OSS") (export '(letS letS* lambdaS funcallS prognS defunS valS pass-valS alterS mapS showS defun-primitiveS lambda-primitiveS terminateS next-inS next-outS prologS epilogS wrapS alterableS oss-tutorial-mode Eoss Eup Edown Esublists Elist Etree Efringe Evector Esequence Efile Ehash Ealist Eplist Esymbols EnumerateF Enumerate-inclusiveF Tprevious Tlatch Tuntil TuntilF Tcotruncate TmapF TscanF Tremove-duplicates Tchunk Twindow Tpositions Tselect TselectF Tlastp Texpand Tmask Tsubseries Tmerge Tconcatenate TconcatenateF Tsplit TsplitF Rlist Rbag Rappend Rnconc Rvector Rfile Ralist Rplist Rhash Rlast Rlength Rsum Rmax Rmin ReduceF Rfirst Rnth Rand Ror Rfirst-late Rnth-late Rand-late Ror-late *permit-non-terminating-oss-expressions* *last-oss-loop* *last-oss-error*)) (defvar *last-oss-loop* nil "loop most recently created by OSS") (defvar *last-oss-error* nil "info about error found most recently by OSS") (defparameter *permit-non-terminating-oss-expressions* nil "controls error reports for non-terminating OSS expressions") ;The key internal form is an entity called a frag (short for fragment). (defstruct (frag (:conc-name nil) (:type list) #+Xerox(:predicate frag-p-internal) :named) (code :?) ;the surface code corresponding to this (for error messages) (marks 0) ;mark bits used in sweeps over a graph (args nil) ;a list of sym structs for the args of the frag (rets nil) ;a list of sym structs for the return vals of the frag (aux nil) ;the auxiliary variables if any. (dcls nil) ;declarations associated with the frag. (alterable nil) ;specifications for alterable outputs (prolog nil) ;list of forms (without labels). (body nil) ;list of forms (possibly containing labels). (epilog nil) ;list of forms (without labels). (wrappers nil)) ;functions that wrap forms around the whole loop. ;;;; Hack to get around Lyric XCL bug where default FRAG-P of NIL gives error #+Xerox(xcl:definline frag-p (object) (and (consp object) (frag-p-internal object))) ;there cannot be any redundancy in or between the args and aux. Each ret ;variable must be either on the args list or the aux list. The args ;and ret have additional data as discussed below. The aux is just a list ;of symbols. Every symbol used in a frag which could possible clash ;with other frags (eg args, rets, aux, and also labels) must be ;gensyms and unique in the whole world. ;the order of the args is important when the frag is first ;instantiated and funcallSed. However, it does not matter after that. ;Similarly, the order of the rets also matters at the time it is ;instantiated, and at the time that a whole expression is turned into ;one frag, but it does not matter at other times. ;there are two basic kinds of frags, oss frags and non-oss frags. A non-oss ;frag is a frag which just has a simple computation which has to be performed ;only once. The rets and args must be non-oss values, and the body and epilog ;must be empty. (The code below maintains the invariant that if all ;the ports of a frag are non-oss then the body and epilog are empty.) ;a frag has three internal parts so that a wide variety of fragmentary ;oss functions can be compressed into a single frag. (This is what ;lambdaS does.) (Actually, any kind of fragmentary oss function can ;be represented. However, to compress a thing like (Elist (Rlist S)) ;(and other weird things) into a single frag, the input would have to ;be made off-line. This is not done automatically, because it is ;against the spirit of oss.) ;Inside frags there is a label which has a special meaning. ; END is used as the label after the end of the loop created. If the ; body of a fragment contains (go END) then the fragment is an ; active terminator. ;If a programmer uses this symbols in his program, very bad ;things could happen. However, it is in the oss package, so ;there should not be any conflict problems. ;the code in this file assumes in many places that no oss: symbol can ;possibly clash with a user symbol. (defun annotate (code frag) (setf (code frag) code) frag) ;Considerable effort is expended to see that the code field always ;contains code that makes sense to the user. Extensive testing ;indicates that it never ends up containing :?, and that the code it ;contains always is part of the code the user types except that an ;optional argument can end up having the default value which ends up ;in the annotation. ;Each arg and ret has the following parts. (defstruct (sym (:conc-name nil) (:type list) #+Xerox(:predicate sym-p-internal) :named) (back-ptrs (make-array 2 :initial-element nil)) (var nil) ;gensymed variable. (oss-var-p nil) ;T if holds a series. (off-line-spot nil) ;if off-line, place to insert the computation. (off-line-exit nil)) ;if non-passive input, label to catch exit. ;;;; Hack to get around Lyric XCL bug where default SYM-P of NIL gives error #+Xerox(xcl:definline sym-p (object) (and (consp object) (sym-p-internal object))) ;if there is an on-line-spot, it must appear in the frag code exactly ;once at top level. It cannot be nested in a form. Several args can ;have the same off-line-spot symbol. This indicates that they are all ;in phase with each other. ;a number of functions depend on the fact that frags and syms are list ;structures which can be traversed by functions like nsubst. The ;following three circular pointers are hidden in an array so they ;won't be followed. (Note that ins only have prv and rets only have ;nxts, as a result, they can both be stored in the same place. two ;names are used in order to enhance the readability of the program.) (eval-when (eval load compile) (defmacro fr (s) ;back pointer to containing frag. `(aref (back-ptrs ,s) 0)) (defmacro nxts (s) ;list of destinations of dflows starting here. `(aref (back-ptrs ,s) 1)) (defmacro prv (s) ;the single source of dflow to here. `(aref (back-ptrs ,s) 1)) ) ;The sym vars are symbols which appear in the body of the frag where they ;should. All of the symbols must be unique in all the world. Every instance ;of the symbol anywhere must be a use of the symbol. ; Output variables can be freely read and written. ;Input variables can be read freely, but cannot ever be written. ; These restrictions guarantee that when frags are combined, it is OK to ;rename the input var of one to be the output var of the other. In ;addition, the creator of an output can depend on the output variable ;being unchanged by the user(s). However, this is not the main point. ;More critical is the situation where two frags use the same value. ;The second frag can be sure that the first frag did not wreck the value. ;(Side-effects could still cause problems. The user must guard ;against destroying some other fragment's internal state.) ; In the interest of good output code, some work is done to simplify ;things when frags are merged. If an output is of the form (setq out c) ;where c is T, nil, or a number, then c is substituted directly for the ;input. Substitution is also applied if c is a variable which is not ;bound in the destination frag. In addition, other kinds of constants ;are substituted if they are only used in one place. A final pass ;gets rid of setqs to variables that are never used for anything. #+:GCLISP (eval-when (eval load compile) (defsetf fr set-fr) (defmacro set-fr (s value) `(setf (aref (back-ptrs ,s) 0) ,value)) (defsetf nxts set-nxts) (defmacro set-nxts (x value) `(setf (aref (back-ptrs ,s) 1) ,value)) (defsetf prv set-nxts) ) ;The third key internal form is a graph of frags. This is ;represented in an indirect way. The special variable *graph* ;contains a list of all of the frags in the oss expression currently ;being processed. The order of the frags in this list is vitally ;important. It corresponds to their lexical order in the input ;expression and controls the default way things with no data flow ;between them are ordered when combined. In addition, many of the ;algorithms depend on the fact that the order in *graph* is compatible ;with the data flow in that there can never be data flow from a frag ;to an earlier frag in the list. ;Subexpressions and regions within the expression as a whole are ;delineated by setting marking bits in the frags in the region. ;LambdaS makes special frags for arguments which are not in the list ;*graph*. They exist to record info about the arguments and to ;preserve an invariant that every input of every frag in *graph* must ;have data flow ending on it. A related invariant states that if a ;frag in *graph* has a ret then this ret must be used either by having ;dflow from it, or as an output of the expression as a whole. Unused ;rets are removed from frags when the frags are created. ;for the purposes of testing whether a subexpression is strongly ;connected to its outputs, a frag with no rets is considered to be an ;output of the subexpression. ;This has to be called to set things up right, before processing of a ;OSS expression can proceed. (defvar *oss-tutorial-mode* nil "controls tutorial mode") (defvar *in-oss-expr* nil "the topmost OSS expression") (proclaim '(special *graph* ;list of frags in expression *renames* ;alist of variable renamings *user-names* ;lets var names used by user *env*)) ;environment of containing series macro call ;*renames* has three kinds of entries on it. Each is a cons of a ;variable and something else: (type 1 cannot ever be setqed.) ; 1- a ret, var is a lets var or a lambdaS var. ; you can tell between the two because lambdaS var frags are not in *graph*. ; 2- a new var, var is an aux var. ; 3- nil, var is rebound and protected from renaming. ;should have some general error catching thing but common lisp has none. (eval-when (eval load compile) (defmacro top-starting-oss-expr (call &body body) `(catch :oss-error (starting-oss-expr ,call . ,body))) (defmacro starting-oss-expr (call &body body) `(let ((*renames* nil) (*user-names* nil) (*in-oss-expr* (iterative-copy-tree ,call))) ;avoids side-effects (setq *last-oss-loop* nil) . ,body)) ;This does two key things. First, it checks to see whether an oss ;expression is starting. As a result, defmacroS must be used to define ;every macro which can possibly start an OSS expression. Second, if ;and only if the body returns a frag which does not already have its ;code field filled in, the macro call is put in the code field of the ;frag. This provides a very useful default for the annotation. ;(Never let anything expand into a defmacroSed form, or the user can ;end up seeing something in an error message that he never wrote.) (defmacro defmacroS (name arglist &body body) `(defmacro ,name (&whole +call+ . ,arglist) ,@(if (stringp (car body)) (list (pop body))) ,@(if (eq (caar body) 'declare) (list (pop body))) (if (not *in-oss-expr*) (let ((result (macroexpand-1 (list 'process-top +call+)))) (if (not (consp result)) (setq result (list 'progn result))) (rplaca +call+ (car result)) ;avoids reexpansions (rplacd +call+ (cdr result)) result) (let* ((+call+ (iterative-copy-tree +call+)) ;avoids side-effects (result (progn . ,body))) (when (and (frag-p result) (eq (code result) :?)) (setf (code result) +call+)) result)))) (defmacro process-top ;this snarfs the env ptr. (call #-:GCLISP &environment #-:GCLISP *env*) ;; COPY-TREE so we don't smash user's code (top-starting-oss-expr (copy-tree call) (codify (mergify (graphify call))))) ) (defun ers (id msg &rest args) (setq *last-oss-error* (list* id msg (copy-list args))) (warn "Error ~A in OSS expression:~%~S~%~?" id *in-oss-expr* msg args) (throw :oss-error id)) (defun wrs (id msg &rest args) (setq *last-oss-error* (list* id msg (copy-list args))) (warn "~A in OSS expression:~%~S~%~?" id *in-oss-expr* msg args)) ;-------------------------------------------------- (defun non-oss-p (frag) (and (notany #'(lambda (x) (oss-var-p x)) (rets frag)) (notany #'(lambda (x) (oss-var-p x)) (args frag)))) (defun active-terminator-p (frag) (or (branches-to 'END (prolog frag)) (branches-to 'END (body frag)))) (defun off-line-p (frag) (or (some #'(lambda (a) (off-line-spot a)) (args frag)) (some #'(lambda (r) (off-line-spot r)) (rets frag)))) (defun on-line-p (frag) (not (off-line-p frag))) ;this assumes that every instance of one of OSSs funny labels is ;really an instance of that label made by the macros below. (defun branches-to (label tree) (cond ((and (eq-car tree 'tagbody) (member label tree)) nil) ((and (eq-car tree 'go) (eq-car (cdr tree) label)) T) (T (do ((tt tree (cdr tt))) ((not (consp tt)) nil) (if (branches-to label (car tt)) (return T)))))) ;hacking marks (defun reset-marks (&optional (value 0)) (dolist (f *graph*) (setf (marks f) value))) (defun mark (mask frag) ;sets bits on (setf (marks frag) (logior mask (marks frag)))) (defun marked-p (mask frag) ;checks that all bits are on (zerop (logandc2 mask (marks frag)))) (eval-when (eval load compile) (defmacro dofrags ((var . mask) &body body) ;mask should be a constant (when mask (setq body `((when (marked-p ,(car mask) ,var) . ,body)))) `(dolist (,var *graph*) . ,body)) ) ;many of the functions in this file depend on the fact that frags and ;syms are list structures. However, only the following functions (and defS) ;depend on the exact position of parts of these structures. Note that ;the CL manual guarantees that these positions are correct in all ;implementations. (defun merge-frags (frag1 frag2) (mapc #'(lambda (s) (setf (fr s) frag2)) (rets frag1)) (mapc #'(lambda (s) (setf (fr s) frag2)) (args frag1)) (mapl #'(lambda (f1 f2) (rplaca f2 (nconc (car f1) (car f2)))) (cdddr frag1) (cdddr frag2)) frag2) (defun copy-fragment (frag) (let* ((alist (mapcar #'(lambda (v) (cons v (gensym (root v)))) (find-gensyms frag))) (new-frag (list* 'frag (code frag) (nsublis alist (iterative-copy-tree (cddr frag)))))) (dolist (a (args new-frag)) (copy-ptrs a new-frag)) (dolist (r (rets new-frag)) (copy-ptrs r new-frag)) new-frag)) (defun copy-ptrs (sym frag) (setf (back-ptrs sym) (make-array 2)) (setf (nxts sym) nil) (setf (fr sym) frag)) (defun frag->list (frag) (setf (rets frag) (mapcar #'cddr (rets frag))) (setf (args frag) (mapcar #'cddr (args frag))) (let ((gensyms (find-gensyms frag))) (nsublis (mapcar #'(lambda (v) (cons v (gentemp (root v)))) gensyms) (cons gensyms (cdddr frag))))) (defun find-gensyms (tree &optional (found nil)) (do ((tt tree (cdr tt))) ((not (consp tt)) (if (and (symbolp tt) (null (symbol-package tt))) (adjoin tt found) found)) (setq found (find-gensyms (car tt) found)))) (defun root (symbol) (let* ((string (string symbol)) (pos (position #\- string :start (min (length string) 1)))) (if pos (subseq string 0 (1+ pos)) (concatenate 'string string "-")))) (defun list->frag (list) (let* ((alist (mapcar #'(lambda (v) (cons v (gensym (root v)))) (pop list))) (frag (list* 'frag :? 0 (nsublis alist (iterative-copy-tree list))))) (setf (args frag) (mapcar #'(lambda (s) (list->sym s frag)) (args frag))) (setf (rets frag) (mapcar #'(lambda (s) (list->sym s frag)) (rets frag))) (values frag alist))) (defun list->sym (list frag) (let ((s (make-sym :var (car list) :oss-var-p (cadr list) :off-line-spot (caddr list) :off-line-exit (cadddr list)))) (setf (fr s) frag) s)) ;some Common Lisps implement copy-tree tail recursively. (defun iterative-copy-tree (tree) (do ((tail tree (cdr tail)) (r nil (cons (iterative-copy-tree (car tail)) r))) ((not (consp tail)) (nreconc r tail)))) (defun literal-frag (stuff) ;(args rets aux dcls alt prolog body epilog wraprs) (let ((gensyms (nconc (mapcar #'car (nth 0 stuff)) (nth 2 stuff)))) (dolist (f (nth 6 stuff)) (if (symbolp f) (push f gensyms))) (list->frag (cons gensyms stuff)))) (eval-when (eval load compile) (defmacro delete1 (thing list) `(setf ,list (delete1a ,thing ,list))) ) (defun delete1a (item list) (if (eq item (car list)) (cdr list) (do ((l list (cdr l))) ((null (cdr list))) (when (eq item (cadr l)) (rplacd l (cddr l)) (return list))))) (defun +arg (arg frag) (setf (fr arg) frag) (setf (args frag) (nconc (args frag) (list arg)))) ;needed by Tcotruncate (defun -arg (arg) (delete1 arg (args (fr arg)))) (defun +ret (ret frag) (setf (fr ret) frag) (setf (rets frag) (nconc (rets frag) (list ret)))) ;needed by force-n-rets (defun -ret (ret) (delete1 ret (rets (fr ret)))) (defun +frag (frag) (setf *graph* (nconc *graph* (list frag))) ;needed to keep order right frag) (defun -frag (frag) (delete1 frag *graph*) (setf (marks frag) 0)) ;important so dofrags will notice deletions (defun +dflow (source dest) (push dest (nxts source)) (setf (prv dest) source)) (defun -dflow (source dest) (delete1 dest (nxts source)) (setf (prv dest) nil)) (defun all-nxts (frag) (apply #'append (mapcar #'(lambda (r) (nxts r)) (rets frag)))) (defun all-prvs (frag) (delete nil (mapcar #'(lambda (a) (prv a)) (args frag)))) ; TURNING AN EXPRESSION INTO A GRAPH ; This parses code down to fundamental chunks creating a graph of the ;expression. Note that macroexpanding and renaming is applied while ;this happens. (defun graphify (code) (let ((*graph* nil)) (fragify code) *graph*)) ;note have to be careful in the next two functions not to expand things twice. ;If you did, you could get two copies of some frags on *graph*. (defun retify (code &aux expansion ret) (setq expansion (my-macroexpand code)) (cond ((sym-p expansion) expansion) ((sym-p (setq ret (cdr (assoc expansion *renames*)))) ret) (T (if (not (frag-p expansion)) (setq expansion (isolate-non-oss code expansion))) (car (rets (force-n-rets 1 expansion)))))) (defun fragify (code &aux expansion) (setq expansion (my-macroexpand code)) (if (not (frag-p expansion)) (setq expansion (isolate-non-oss code expansion))) expansion) (defun force-n-rets (n frag) (let ((len (length (rets frag)))) (cond ((= n len)) ((> n len) (ers 8 "Only ~A return values present where ~A expected~%~A" len n (code frag))) (T (mapc #'kill-ret (nthcdr n (rets frag)))))) frag) (defun kill-ret (ret) (when (off-line-spot ret) (setf (body (fr ret)) (nsubst-inline nil (off-line-spot ret) (body (fr ret))))) (-ret ret)) ;This makes a non-oss frag to start with, mapping (if needed) happens later. ;Rationale: we always group the biggest chunk possible into one thing ;because if it doesn't get mapped it doesn't matter and if it does ;get mapped and you don't want it all to be mapped, you can easily ;fix the problem by inserting (Eoss :R ...). If we took a small piece when ;you wanted a large one, there would be no easy way for you to fix things. ;This also sets annotation on the frag produced. For this to work ;right, it is important that isolate-non-oss is never called on ;anything but user code. (defun isolate-non-oss (annotation code) (let* ((var (gensym "OUT-")) (frag (make-frag :code annotation :aux (list var))) (top-renames *renames*) (exp (m-&-r code #'(lambda (c) (if (not (or (frag-p c) (sym-p c))) c (let ((arg (make-sym :var (gensym "ARG-")))) (+arg arg frag) (if (frag-p c) (check-movability code c top-renames)) (+dflow (retify c) arg) (var arg))))))) (+ret (make-sym :var var) frag) (setf (prolog frag) `((setq ,var ,exp))) (+frag frag))) ;this should really check if any bound vars are referenced, and should ;look to see if any special variables are being bound. (We have to ;look at the code field, because the subexpr may have been turned into ;several frags). (defun check-movability (top-code frag top-renames) (if (contains-p (mapcar #'car (ldiff *renames* top-renames)) (code frag)) (wrs 13 "Decomposition moves:~%~S~%out of a binding scope:~%~S" (code frag) top-code))) (defun contains-p (items thing) (do ((tt thing (cdr tt))) ((not (consp tt)) (member tt items)) (if (contains-p items (car tt)) (return T)))) (defmacroS mapS (&body expr-list) "Causes EXPR-LIST to be mapped over the OSS variables in it." (setq expr-list (process-subforms expr-list)) (isolate-non-oss +call+ (if (null (cdr expr-list)) (car expr-list) `(progn . ,expr-list)))) ;This expands all of the OSS exprs in forms as if they were in ;isolation. You can process the result again, if you want it to be ;able to refer to OSS vars from outside. (defun process-subforms (forms) (let ((*in-oss-expr* nil) (*renames* nil) (*user-names* nil)) (mapcar #'m-&-r forms))) (defmacroS funcallS (function &rest expr-list) "Applies an OSS function to the results of the expressions." (annotate +call+ (if (frag-p function) (funcallS-frag0 function expr-list +call+) (case (quoted-function-p (setq function (my-macroexpand function))) (lambdaS (funcallS-frag0 (process-lambdas function (cadr function)) expr-list +call+)) (lambda-primitiveS (funcallS-frag0 (process-lambda-primitiveS function (cadr function)) expr-list +call+)) (symbol (let ((code (my-macroexpand (cons (cadr function) expr-list)))) (if (frag-p code) code (do-TmapF function expr-list)))) (otherwise (do-TmapF function expr-list)))))) (defun quoted-function-p (thing) (cond ((not (eq-car thing 'function)) nil) ((symbolp (cadr thing)) 'symbol) ((eq-car (cadr thing) 'lambda) 'lambda) ((eq-car (cadr thing) 'lambdaS) 'lambdaS) ((eq-car (cadr thing) 'lambda-primitiveS) 'lambda-primitiveS))) (defun funcallS-frag0 (frag values call) (when (not (= (length values) (length (args frag)))) (ers 7 "Wrong number of args to funcallS:~%~S" call)) (funcallS-frag frag values)) (defun funcallS-frag (frag values) (mapc #'(lambda (v a) (+dflow (retify v) a)) values (args frag)) (+frag frag)) (defmacroS prognS (&rest expr-list) "Delineates an OSS expression." (process-progns expr-list)) (defun process-progns (forms) (mapc #'(lambda (f) (force-n-rets 0 (fragify f))) (butlast forms)) (fragify (car (last forms)))) ;forces NIL if no forms. ;note that this forces the values to either be all non-oss or all oss ;and on-line with each other. If you want more complicated outputs, you ;have to use the primitive definition facilities. (defmacroS valS (&rest expr-list) "Returns multiple series values." (let ((frag (make-frag))) (dotimes (i (length expr-list) i) (let ((var (gensym "VAL-"))) (+arg (make-sym :var var) frag) (+ret (make-sym :var var) frag))) (funcalls-frag frag expr-list))) ;LetS assumes that pass-valS doesn't appear in annotation. (defmacroS pass-valS (n expr) "Used to pass multiple values from a non-OSS function into an OSS expression." (setq expr (my-macroexpand expr)) (cond ((frag-p expr) (force-n-rets n expr)) ((= n 1) (annotate expr (fragify expr))) (T (let ((vars nil) frag) ;note expr must be non-oss at top. (dotimes (x n) (push (gensym "VAL-") vars)) (setq frag (fragify `(multiple-value-setq ,vars ,expr))) (setf (rets frag) nil) (dolist (v vars) (push v (aux frag)) (+ret (make-sym :var v) frag)) (annotate expr frag))))) (defmacroS letS* (var-value-pair-list &body expr-list) "Binds OSS variables in parallel." (let ((*renames* *renames*) (old-top *renames*)) (dolist (p var-value-pair-list) (setq *renames* (process-lets-pair p *renames*))) (process-lets-body expr-list (ldiff *renames* old-top) +call+))) (defmacroS letS (var-value-pair-list &body expr-list) "Binds OSS variables sequentially." (let ((new-renames *renames*) (old-top *renames*)) (dolist (p var-value-pair-list) (setq new-renames (process-lets-pair p new-renames))) (let ((*renames* new-renames)) (process-lets-body expr-list (ldiff *renames* old-top) +call+)))) (defun process-lets-pair (p alist) (setq p (normalize-pair p)) (let* ((vars (car p)) (frag (fragify `(pass-valS ,(length vars) ,(cadr p))))) (mapc #'(lambda (v r) (cond (v (push (cons v r) alist) (push (cons (var r) v) *user-names*)) (T (kill-ret r)))) vars (copy-list (rets frag))) alist)) (defun normalize-pair (p) (cond ((and (consp p) (bind-var-p (car p)) (= (length p) 2)) (list (list (car p)) (cadr p))) ((and (consp p) (consp (car p)) (every #'bind-var-p (car p)) (= (length p) 2)) p) (T (ers 9 "Malformed letS{*} binding pair ~S." p)))) (defun bind-var-p (thing) (or (null thing) (lambda-variable-p thing))) (defun lambda-variable-p (thing) (and (variable-p thing))) (defun variable-p (thing) (and thing (symbolp thing) (not (eq thing T)) (not (keywordp thing)) (not (member thing lambda-list-keywords)))) (defun process-lets-body (forms alist call) (setq forms (normalize-dcls forms)) (when (cddadr (car forms)) (wrs 10 "The variable(s) ~S declared TYPE OSS in a letS{*}." (cddadr (car forms)))) (pop forms) (let ((dcls (process-subforms-&-rename (cdr (pop forms)))) (frag (process-progns forms))) (setf (dcls frag) (append dcls (dcls frag))) ;assumes outputs never renamed (dolist (entry alist) (when (null (nxts (cdr entry))) (wrs 11 "The letS variable ~A is unused in:~%~A" (car entry) call))) frag)) (defun process-subforms-&-rename (forms) (mapcar #'rename (process-subforms forms))) (defun rename (form) (m-&-r form #'(lambda (c) (if (sym-p c) (var c) c)))) (defmacroS lambdaS (var-list &body expr-list) "Form for specifying literal OSS functions." (declare (ignore var-list expr-list)) (ers 6 "LambdaS used in inappropriate context:~%~S" +call+)) (defun process-lambdas (call lambdas) (starting-oss-expr call (let* ((arglist (cadr lambdas)) (forms (normalize-dcls (cddr lambdas))) (oss-vars (cddadr (pop forms))) (dcl (pop forms)) (arg-frag-rets (mapcar #'(lambda (a) (when (not (lambda-variable-p a)) (ers 5 "Malformed lambdaS argument ~S." a)) (let* ((ret (make-sym :var (gensym "ARG-") :oss-var-p (not (null (member a oss-vars))))) (arg-frag (make-frag))) (+ret ret arg-frag) (push (cons a ret) *renames*) ret)) arglist)) (frag (mergify (graphify `(prognS . ,forms))))) (setf (args frag) ;get into the right order. (mapcar #'handle-arg arg-frag-rets)) (setf (dcls frag) (append (process-subforms-&-rename (cdr dcl)) (dcls frag))) frag))) (defun handle-arg (ret) (let ((arg (car (nxts ret)))) (when (null arg) (setq arg ret)) ;input never used (setf (prv arg) nil) (dolist (a (cdr (nxts ret))) ;input used more than once. (nsubst (var arg) (var a) (fr a))) arg)) (defun normalize-dcls (forms &optional (allow-doc nil)) (let ((doc nil) (oss-vars nil) (others nil)) (prog () L (when (and allow-doc (null doc) (stringp (car forms)) (cdr forms)) (setq doc (pop forms)) (go L)) (when (not (eq-car (car forms) 'declare)) (return nil)) (dolist (d (cdr (pop forms))) (if (and (eq-car d 'type) (listp (cdr d)) (symbolp (cadr d)) (string-equal (string (cadr d)) "OSS")) (setq oss-vars (append (cddr d) oss-vars)) (push d others))) (go L)) `(,@(if doc (list doc)) (declare (type oss . ,oss-vars)) (declare . ,others) . ,forms))) (defmacro defunS (name lambda-list #-:GCLISP &environment #-:GCLISP *env* &body expr-list) "Defines an OSS function, see LAMBDAS." (let ((call (list* 'defunS name lambda-list expr-list))) (top-starting-oss-expr call (dolist (v lambda-list) (when (and (member v lambda-list-keywords) (not (member v '(&optional &key)))) (ers 3 "Unsuported &-keyword ~S in defunS arglist." v))) (let ((vars nil) (rev-arglist nil)) (dolist (a lambda-list) (cond ((member a lambda-list-keywords) (push a rev-arglist)) (T (setq a (iterative-copy-tree a)) (setq vars (append vars (vars-of a))) (if (and (listp a) (listp (cdr a))) (setf (cadr a) `(copy-tree ',(cadr a)))) (push a rev-arglist)))) (setq expr-list (normalize-dcls expr-list T)) `(defmacroS ,name ,(reverse rev-arglist) ,@(if (stringp (car expr-list)) (list (pop expr-list))) (funcallS-frag (list->frag ',(frag->list (process-lambdas call `(lambdaS ,vars . ,expr-list)))) (list . ,vars))))))) (defun vars-of (arg) (cond ((member arg lambda-list-keywords) nil) ((not (consp arg)) (list arg)) (T (cons (if (consp (car arg)) (cadr arg) (car arg)) (copy-list (cddr arg)))))) ;note the following does not assume that old and new are series ;(implicit mapping will happen if they are). Also the alterS form found ;probably refers to vars which are not OLD itself. This is ok because outputs ;never get renamed. Also the input old to the frag most likely never ;gets used, but this makes sure that the dflow is logically correct. ;It is vital that this doesn't put the setf in the frag, because it is ;important that the setf get combined with any IF or other form it is ;nested in when implicit mapping happens. ;This makes the right annotation, because it does not expand into a ;frag. As a result, instantiate-non-oss always ends up getting called ;around it and makes the right annotation. (defmacroS alterS (destinations items) ;fix so can be top level "Alters the values in DESTINATIONS to be ITEMS." (let ((ret (retify destinations))) (let ((form (find-alter-form ret))) (when (null form) (ers 4 "AlterS applied to an unalterable form:~%~S" +call+)) `(setf ,form ,(annotate +call+ (funcallS-frag (literal-frag ;this gets the data flow dependencies right. `(((old) (items)) ((items)) () () () () () () ())) (list ret items))))))) (defun find-alter-form (ret) (let* ((v (var ret)) (form (cadr (assoc v (alterable (fr ret)))))) (if form form (dolist (a (args (fr ret))) (when (or (eq v (var a)) (equal (prolog (fr ret)) `((setq ,v ,(var a))))) (return (find-alter-form (prv a)))))))) ; MERGING A GRAPH ;this proceeds in three phases ; (1) Implicit mapping and the like to fix type conflicts. ; (a) find all non-series functions which must be mapped. ; (b) signal error if there is a non-fixable oss/non-oss type conflict. ; (c) Insert (Eoss :R ...) where needed to fix non-oss/oss type conflicts. ; (2) doing substitutions to get rid of trivial frags and improve the code. ; (3) the graph is scanned to find a dflow which should be isolated. ; when one is found, the graph is split at this point. The two ; subgraphs are merged separately and then combined. If the graph ; cannot be split, then it consists solely of on-line dflow and can be ; easily merged. (defun mergify (*graph*) (reset-marks) (do-coercion) (do-substitution) (eval (do-splitting *graph*))) ;takes advantage of the fact that frags are ordered consistently ;with the dflow so an implicit mapping of one fn cannot force earlier ;functions to be mapped. (defun do-coercion () (dofrags (f) (when (and (non-oss-p f) (some #'(lambda (r) (oss-var-p r)) (all-prvs f))) (implicit-map f)) (dolist (a (args f)) ;if map might have to map only some args. (let ((ret (prv a))) (cond ((and (not (oss-var-p ret)) (oss-var-p a)) (Eoss-coerce a)) ((and (oss-var-p ret) (not (oss-var-p a))) (ers 14 "OSS value carried to non-OSS input ~ by data flow from:~%~S~%to:~%~S" (code (fr ret)) (code f)))))) (maybe-de-oss f))) ;might have to if Eoss coerced all of the inputs (defun implicit-map (frag) (setf (body frag) (prolog frag)) (setf (prolog frag) nil) (dolist (a (args frag)) (setf (oss-var-p a) T)) (dolist (r (rets frag)) (setf (oss-var-p r) T)) frag) (defun Eoss-coerce (a) (when (off-line-spot a) (nsubst nil (off-line-spot a) (fr a))) (setf (oss-var-p a) nil)) ;choose not to automatically map subexprs because it helps detect bugs, ;and doesn't take away much you want to do. (defun do-substitution () (dofrags (f) (multiple-value-bind (subable code) (substitutable-source f) (when subable (let* ((ret (car (rets f))) (killable (not (null (nxts ret))))) (dolist (arg (nxts ret)) (cond ((substitutable-destination ret arg code) (nsubst code (var arg) (fr arg)) (-dflow ret arg) (-arg arg)) (T (setq killable nil)))) (if killable (-frag f))))))) (defun substitutable-source (f &aux code fn-type) (values (and (= (length (rets f)) 1) (not (off-line-spot (car (rets f)))) (null (args f)) (null (epilog f)) (= 1 (length (setq code (append (prolog f) (body f))))) (eq (var (car (rets f))) (setq-p (setq code (car code)))) ;;cheap check for free vars not bound in destination (or (constantp (setq code (caddr code))) (symbolp code) (and (setq fn-type (quoted-function-p code)) (or (eq fn-type 'symbol) (let ((free-var nil) (*renames* nil) (*in-oss-expr* nil)) (m-&-r (cadr code) #'(lambda (c) (when (and (variable-p c) (not (assoc c *renames*))) (push c free-var)) c)) (null free-var)))))) code)) (defun substitutable-destination (ret arg code) (not (or (off-line-spot arg) (contains-p (list (var arg)) (rets (fr arg))) ;;prevents weird declarations from appearing (contains-p (list (var arg)) (dcls (fr arg))) ;;cheap check for not binding (and (variable-p code) (contains-p (list code) (cddr (fr arg)))) (not (or (numberp code) (null code) (eq code T) (symbolp code) (and (null (cdr (nxts ret))) (not-contained-twice (list (var arg)) (list (prolog (fr arg)) (body (fr arg)) (epilog (fr arg)))))))))) ;Splitting cuts up the graph at all of the correct places, and creates a ;lisp expression which, when evaluated will merge everything together. ;Things area done this way so that all of the splitting will happen ;before any of the merging. This makes error messages better and allows ;all the right code motion to happen easily. ; A throw is used to start all over again when recovering from an ;error, because it can be essential to restart from the top so that ;disconnected splitting will happen soon enough (defun do-splitting (*graph*) (loop (reset-marks 0) (let ((result nil) (error nil)) (setq error (catch :split (setq result (non-oss-split *graph*)) nil)) (when (not error) (return result)) (case (car error) (:isolation (make-port-isolated (cadr error) (caddr error))) (:connection (make-disconnected (caddr error))))))) ;This takes a ret which is known not to be isolated and duplicates ;code in order to make the ret be isolated. In simple situations ;it does a pretty good job of duplicating minimum code. (defun make-port-isolated (ret args) (reset-marks 0) (let ((to-follow (list (fr ret)))) (mark 2 (fr ret)) (loop (if (null to-follow) (return nil)) (let ((frag (pop to-follow))) (dolist (a (args frag)) (let ((r (prv a))) (when (not (marked-p 2 (fr r))) (push (fr r) to-follow) (mark 2 (fr r)))))))) (let ((to-follow (mapcar #'(lambda (a) (fr a)) args)) (followers nil) (*copied* nil)) (declare (special *copied*)) (loop (if (null to-follow) (return nil)) (let ((frag (pop to-follow))) (when (not (marked-p 4 frag)) (mark 4 frag) (push frag followers)) (dolist (r (rets frag)) (dolist (a (nxts r)) (push (fr a) to-follow))))) (setq to-follow followers) (loop (if (null to-follow) (return nil)) (let ((frag (pop to-follow))) (dolist (a (args frag)) (when (and (oss-var-p a) (not (member a args))) (let ((r (prv a))) (when (not (marked-p 4 (fr r))) (when (marked-p 2 (fr r)) (setq r (duplicate-frag r a))) (push (fr r) to-follow) (mark 4 (fr r)))))))))) (defun duplicate-frag (ret arg) (declare (special *copied*)) (let* ((frag (fr ret)) new-frag new) (when (not (setq new-frag (cdr (assoc frag *copied*)))) (setq new-frag (copy-fragment frag)) (push (cons frag new-frag) *copied*) (let ((spot (member frag *graph*))) (rplacd spot (cons new-frag (cdr spot)))) (mapc #'(lambda (old-arg new-arg) (+dflow (prv old-arg) new-arg)) (args frag) (args new-frag))) (mapc #'(lambda (old-ret new-ret) (when (eq old-ret ret) (setq new new-ret) (dolist (a (nxts old-ret)) (when (eq a arg) (-dflow old-ret arg) (+dflow new-ret arg) (when (null (nxts old-ret)) (kill-ret old-ret)))))) (rets frag) (rets new-frag)) new)) ;This is prone to copying much too much. (defun make-disconnected (frag) (reset-marks 0) (let ((to-follow (list frag)) (preceders nil) (*copied* nil)) (declare (special *copied*)) (loop (if (null to-follow) (return nil)) (let ((frag (pop to-follow))) (dolist (a (args frag)) (when (oss-var-p a) (let ((r (prv a))) (when (not (marked-p 2 (fr r))) (push (fr r) to-follow) (mark 2 (fr r)))))))) ;;preceders ends up in reverse dflow order (dofrags (f 2) (push f preceders)) (mark 2 frag) (dolist (f preceders) (dolist (r (rets f)) (when (oss-var-p r) (dolist (a (nxts r)) (when (not (marked-p 2 (fr a))) (duplicate-frag r a)))))))) (eval-when (eval load compile) (defmacro doing-splitting (&body body) `(cond ((null (cdr *graph*)) (list 'quote (car *graph*))) (T (reset-marks 1) (prog1 (progn . ,body) (reset-marks 0))))) ) ;This breaks the expression up at points where there is no data flow ;between the subexpressions. Since the size of part1 is minimized it is ;known that it must be fully connected. ; This is called at several different points, in order to guaranttee that ;as much disconnected splitting as possible is always done before off line ;splitting is done. This also ensures that there cannot be any disconnected ;pieces when check-connected is called. ; This is called so often because it makes the eventual merging much ;better. In particular, the following expression cannot be merged ;correctly at all unless the off-line outputs are merge BEFORE the ;disconnected chuncks are merged. ;(lets* ((e1 (Elist '(1 -2 -4 3))) ; (e2 (Elist '(1 -2 -4 3))) ; (e3 (Elist '(1 -2 -4 3))) ; (w1 (TsplitF e2 #'plusp)) ; ((nil x2) (TsplitF e3 #'plusp))) ; (list (Rlist (list e1 w1)) (Rlist (list w1 x2)))) ;it is not at all easy to explain why this is the case. However, in ;this example the key problem is that an output ends up getting used two ;ways, once off-line and once not. Doing disconnected splitting early ;may not even fix the problem in general. However, it is just possible ;that the all termination points must connect to all outputs condition ;actually makes things work out ok. (defun disconnected-split (next *graph*) (doing-splitting (multiple-value-bind (part1 part2) (split-after (list (car *graph*)) #'(lambda (r a) (declare (ignore r a)) nil)) (cond ((null part2) (funcall next part1)) (T `(no-dflow-merge ,(funcall next part1) ,(disconnected-split next part2))))))) ;This finds internal non-oss dflows and splits the graph at that point. ;If *graph* is a complete expression, then the two subexpressions cannot ;have external series inputs or outputs. The size of part2 is minimized ;because it is felt that this will do a better job of equalizing the ;size of the two halves. However, this can cause part1 to have ;disconnected parts. Also, either half can contain more non-oss dflow. ;Therefore, both halves must be processed again by non-oss-split. (defun non-oss-split (*graph*) (doing-splitting (block top (dofrags (f) (dolist (ret (rets f)) (when (not (oss-var-p ret)) (dolist (arg (nxts ret)) (when (marked-p 1 (fr arg)) (return-from top (do-non-oss-split ret arg))))))) (disconnected-split #'off-line-input-split *graph*)))) (defun do-non-oss-split (ret arg) (let ((frag1 (fr ret)) (frag2 (fr arg))) (multiple-value-bind (part1 part2) (split-before (list frag2) #'(lambda (r a) (declare (ignore r)) (not (oss-var-p a)))) (when (member frag1 part2) (wrs 16 "Non-isolated non-oss data flow from:~%~S~%to:~%~S" (code frag1) (code frag2)) (throw :split `(:isolation ,ret ,(nxts ret)))) `(non-oss-merge ,(non-oss-split part1) ,(non-oss-split part2))))) ;This looks for data flows going to off-line input ports. When ;splitting, it minimizes part1 so that the stuff that gets substituted ;in line will be as small as possible. Either part can still have off-line ;inputs in it. (Part1 may have to include some frags not yet scanned.) ; Note that even if the whole does not have any external oss ports, the ;two pieces will. Part2 will have an external off-line input (the one ;split on) and part1 will have an oss output which may be on-line. ;(It is possible that this output is used by a second off-line input ; this forces complex merging cases ;to be handled.) ; Note dflow can fan out, but not fan in. For this reason, it is ;imperative that off-line inputs be split on before off-line outputs. ;Otherwise, one could fail to realize that an off-line input was not ;isolated. (It is very convenient the way that error checking works out.) ;Also note that since there is no fan in, input-splitting cannot cause ;either part to become disconnected. (defun off-line-input-split (*graph*) (doing-splitting (block top (dofrags (f) (dolist (ret (rets f)) (dolist (arg (nxts ret)) (when (and (marked-p 1 (fr arg)) (off-line-spot arg)) (return-from top (do-off-line-input-split ret arg)))))) (off-line-output-split *graph*)))) (defun do-off-line-input-split (ret arg) (let ((frag1 (fr ret)) (frag2 (fr arg))) (multiple-value-bind (part1 part2) (split-after (list frag1) #'(lambda (r a) (and (eq r ret) (eq a arg)))) (when (member frag2 part1) (wrs 17.1 "Non-isolated oss input at the end of the ~ data flow from:~%~S~%to:~%~S" (code frag1) (code frag2)) (throw :split `(:isolation ,ret ,(list arg)))) `(off-line-merge ,(off-line-input-split part1) ',ret ,(off-line-input-split part2) ',arg)))) ;This looks for data flows going from off-line output ports. When ;splitting, it minimizes part2 so that the stuff that gets substituted ;in line will be as small as possible. This insures that part2 will be ;a connected piece. However, part1 may not be. (This means that on ;calls of this function, it cannot be assumed that the whole expression ;is connected. This is a reason why it is vital to minimize part2.) ;Either half can have more off-line outputs in it. ; Note that even if the whole does not have any external oss ports, the ;two pieces will. Part1 will have an external off-line output (the one ;split on) and part2 will have an on-line oss input. (defun off-line-output-split (*graph*) (doing-splitting (block top (dofrags (f) (dolist (ret (rets f)) (when (off-line-spot ret) (let ((args nil)) (dolist (arg (nxts ret)) (when (marked-p 1 (fr arg)) (pushnew arg args))) (when args (return-from top (do-off-line-output-split ret args))))))) (check-connected *graph*)))) (defun do-off-line-output-split (ret args) (let ((frag1 (fr ret)) (frags2 (mapcar #'(lambda (a) (fr a)) args))) (multiple-value-bind (part1 part2) (split-before frags2 #'(lambda (r a) (declare (ignore a)) (eq r ret))) (when (member frag1 part2) (wrs 17.2 "Non-isolated oss output at the start of the ~ data flow from:~%~S~%to:~%~S" (code frag1) (code (car frags2))) (throw :split `(:isolation ,ret ,(nxts ret)))) `(off-line-merge ,(disconnected-split #'off-line-output-split part1) ',ret ,(disconnected-split #'off-line-output-split part2) ',(car args))))) ;This function checks that there is a dflow path from every termination ;point to every output of an on-line subexpression. It works by doing ;some fancy marker propagation. (defun check-connected (*graph*) (doing-splitting (let ((counter 8.) (all-counters 0) (outputs nil) (terminations nil)) (dofrags (f 1) (when (or (null (rets f)) (some #'(lambda (a) (not (marked-p 1 (fr a)))) (all-nxts f))) (push f outputs)) (when (or (active-terminator-p f) (some #'(lambda (r) (and (not (marked-p 1 (fr r))) (oss-var-p r))) (all-prvs f))) (push (cons counter f) terminations) (mark (+ 4 counter) f) (setq all-counters (+ all-counters counter)) (setq counter (* 2 counter)))) (dofrags (f 5) ; 5 = 1+4 (let ((current-marks (logand -4 (marks f)))) (dolist (a (all-nxts f)) (when (marked-p 1 (fr a)) (mark current-marks (fr a)))))) (dolist (output outputs) (when (not (marked-p all-counters output)) (dolist (entry terminations) (when (not (marked-p (car entry) output)) (wrs 18 "No data flow path from the termination point: ~%~S~%~ to the output:~%~S" (code (cdr entry)) (code output)) (throw :split `(:connection ,(cdr entry) ,output))))))) `(merge-on-line ',*graph*))) ;This splits the graph by dividing it into two parts (part1 and part2) ;so that to-follow is in part1, there is no data flow from part2 to ;part1 and all of the data flow from part1 to part2 satisfies the ;predicate CROSSABLE. ; The splitting is done by marker propogation (using the marker 2). ;The algorithm used has the effect of minimizing part1. (defun split-after (to-follow crossable) (dolist (f to-follow) (mark 2 f)) (loop (if (null to-follow) (return nil)) (let ((frag (pop to-follow))) (dolist (a (args frag)) (let ((r (prv a))) (when (= (marks (fr r)) 1) ;ie 1 but not 2 (push (fr r) to-follow) (mark 2 (fr r))))) (dolist (r (rets frag)) (dolist (a (nxts r)) (when (and (= (marks (fr a)) 1) ;ie 1 but not 2 (not (funcall crossable r a))) (push (fr a) to-follow) (mark 2 (fr a))))))) (let ((part1 nil) (part2 nil)) (dofrags (f 1) (if (marked-p 2 f) (push f part1) (push f part2))) (reset-marks 0) (values (nreverse part1) (nreverse part2)))) ;This is almost exactly the same except propogation starts in part2 and part2 ;is the part that is minimized. (defun split-before (to-follow crossable) (dolist (f to-follow) (mark 2 f)) (loop (if (null to-follow) (return nil)) (let ((frag (pop to-follow))) (dolist (a (args frag)) (let ((r (prv a))) (when (and (= (marks (fr r)) 1) ;ie 1 but not 2 (not (funcall crossable r a))) (push (fr r) to-follow) (mark 2 (fr r))))) (dolist (r (rets frag)) (dolist (a (nxts r)) (when (= (marks (fr a)) 1) ;ie 1 but not 2 (push (fr a) to-follow) (mark 2 (fr a))))))) (let ((part1 nil) (part2 nil)) (dofrags (f 1) (if (not (marked-p 2 f)) (push f part1) (push f part2))) (reset-marks 0) (values (nreverse part1) (nreverse part2)))) ; When it comes to merging a pair of fragments together, there are four ;basic situations based on the data flow between the frags chosen ; 1- non-oss 2- no data flow 3- off-line 4- on-line. ;In the first three cases, things are arranged so that there is never ;any data flow except between the two fragments in question. In the ;fifth case, there can be other data flow, but it must be on-line ;data flow. A problem stems from the fact that there can be ports on ;the segments to which no internal data flow is attached---i.e., ports which ;are inputs and outputs of the expression as a whole or ports which ;are inputs and outputs of subexpressions created in earlier splittings ;of the graph. Even worse, for outputs, there can be additional data ;flow which goes to a frag in a different subexpression even though ;the output is also used in this subexpression. (The way things are ;split this can only happen with oss outputs.) Combining the frags ;together can require exterenally used oss ports to be modified. ; Two cases are always simple. If an extraneous input or output ;carries a non-series value, then there is never a problem. If it is ;an input than it must be available from the very start of computation ;and therefore will always be readable no matter how the frags are ;combined. If the port is an output, then it does not need to be ;available until after everything is done, and the strongly connected ;check insures that it will be eventually computed. ; Things are also basically simple if an extraneous input or output is ;off-line. In this situation, a specific marker says exactly where ;connected computation should be put, and this marker will always end ;up in an appropriate place no matter how the fragments are combined. ;The only thing which requires care is making sure that these ;markers stay at top level. ; One problem case however, is that it is possible for an off-line ;output to be used by an off-line input. This can cause a splitting ;to happen that ends up in a situation where an off-line input is used ;both internally and externally. If so, the output has to be ;preserved the first time it is used so that it can be used again. ; On the other hand, if an extraneous input or output is on-line, ;significant complexities can arise. If an extraneous port is ;on-line then it may have to be changed into an off-line port. ;Fortunately, things are arranged so that a graph is never split by ;breaking an on-line to on-line data flow. However, an on-line port ;can be on one end of a broken data flow. Nevertheless, most ;instances of extranious on-line ports come from weird lambdaS bodies. ;Except in simple situations extranious on-line ports are not ;supported unless they come from complete expressions. ; A key goal of the above is that every situation which can arise in ;a complete oss expression is properly dealt with. Beyond this ;certain weird situations in lambdaSs are dealt with while others ;generate error messages. You have to use the primitive definition ;facilities in this situation. (It should be noted that basically all of ;the problem cases in question are really quite rare indeed.) ; Consider the various problematical situations in detail ; 1- the frags to be combined are connected by non-oss dflow. ;The way graph splitting works insures that in a complete expression, ;both frags must be non-oss. There is no problem as long as at least ;one of the frags is non-oss. If one has series ports, it can be left totally ;alone. The other can be placed entirely in the prolog or epilog. ;The case of one non-oss frag is handled because it comes up often in ;lambdaS's and is easy to handle. ; If both frags have series ports, then the ports on one of the frags would ;have to become off-line. (A problem here is that it is not obvious ;which frag to do this to.) An error message is issued rather than ;make the combination. (defun non-oss-merge (ret-frag arg-frag) (when (not (non-oss-p ret-frag)) (when (not (non-oss-p arg-frag)) (ers 19 "LambdaS body too complex to merge into a single unit:~%~S~%~S" (code ret-frag) (code arg-frag))) (implicit-epilog arg-frag)) (handle-dflow ret-frag #'(lambda (r a) (and (eq (fr r) ret-frag) (eq (fr a) arg-frag)))) (merge-frags ret-frag arg-frag)) (defun implicit-epilog (frag) (setf (epilog frag) (prolog frag)) (setf (prolog frag) nil) frag) ; 2- There is no data flow between the frags. ;The way graph splitting works insures that in a complete expression, ;both frags must be non-oss. As in the case above, there is no problem ;as long as at least one of the frags is non-oss. Beyond that, since ;there is no data flow between the frags, things are still fine. ;(Non-oss and off-line are never a problem, and on-line inputs and ;outputs will run along nicely in phase when the frags are merged side ;by side.) (defun no-dflow-merge (frag1 frag2) (merge-frags frag1 frag2)) ; 3- the frags to be combined are connected by an off-line dflow. ;(This may be from an on-line or off-line output to an on-line or ;off-line input.) Here things are quite complicated as indicated below. ; A- The ret is off-line and the arg is on-line ;There are two basic ways in which this can be handled. ; A1- The most straightforward way is to insert the arg frag into the ;off-line-spot in the ret-frag. This has the feature that it is very ;simple and allows on-line inputs and outputs of the ret-frag ;to remain unchanged. However, on-line inputs and outputs of the ;arg-frag are forced to become off-line. ; A2- The ret-frag is turned inside out and converted into an ;enumerator, which has on-line data flow to the arg-frag. This ;requires the use of a flag variable, and the makinf off-line of any ;on-line inputs or outputs of the ret-frag. However, it allows any ;extraneous inputs and outputs of the arg-frag to remain unchanged. ; If either of the two frags has no extraneous on-line ports, then the ;appropriate combination method above is used and everything works ;out great. If they both have extraneous on-line ports, then which ;every one has fewer of these ports has them changed to off-line ;ports and the appropriate process above is then applied. ; In either case, special care has to be taken to insure that the ;off-line output will still exist if it is used someplace other than ;in the arg-frag. (It is possible that it will exist, but will get ;changed to on-line. This does not cause confusion since the input it ;is connected to must be off-line, or the splitting which caused the ;difficultly in the first place would not have occured.) ; B- The ret is on-line and the arg is off-line. This case is ;closely analogous to the one above. Again, there are two basic ways ;to proceed. ; B1- The most straightforward way is to insert the ret frag into the ;off-line-spot in the arg-frag. This has the feature that it is very ;simple and allows all on-line inputs and outputs of the arg-frag ;to remain unchanged. However, on-line inputs and outputs of the ;ret-frag are forced to become off-line. ; B2- The arg-frag is turned inside out and converted into a ;reducer which receives on-line data flow from the ret-frag. This ;requires the use of a flag variable, and it forces off-line any ;extraneous on-line inputs or outputs of the arg-frag. However, it allows any ;extraneous inputs and outputs of the ret-frag to remain unchanged. ; If either of the two frags has no extraneous ports, then the ;appropriate combination method above is used and everything works ;out great. If the both have extraneous ports then which every has ;fewer has them changed to off-line and things proceed as above. ; C- the ret and arg are both off-line. Here it is ;not possible to simultaneously substitute the frags into each other. ;However, it is possible to combine them after A2 is applied to the ;ret-frag or B2 is applied to the arg-frag. Again this presents two ;options and it is possible to preserve either the extraneous ports of ;the ret-frag or the arg-frag, but not both. ; Note we have to be prepared for the general case more often than you might ;think, because the compination process can cause ports to become off-line (defun off-line-merge (ret-frag ret arg-frag arg) (handle-dflow (fr ret) #'(lambda (r a) (eq r ret) (eq (fr a) arg-frag))) (let* ((ret-rating (count-on-line ret-frag)) (arg-rating (count-on-line arg-frag))) (cond ((not (off-line-spot arg)) (if (> arg-rating ret-rating) (convert-to-enumerator ret nil) (substitute-in-output ret arg))) ((not (off-line-spot ret)) (if (and (> ret-rating arg-rating) (null (off-line-exit arg))) (convert-to-reducer arg) (substitute-in-input ret arg))) (T (cond ((and (> ret-rating arg-rating) (null (off-line-exit arg))) (convert-to-reducer arg) (substitute-in-output ret arg)) (T (convert-to-enumerator ret (off-line-exit arg)) (substitute-in-input ret arg)))))) (maybe-de-oss (merge-frags ret-frag arg-frag))) (defun find-on-line (syms) (do ((s syms (cdr s)) (r nil)) ((null s) (nreverse r)) (when (and (oss-var-p (car s)) (null (off-line-spot (car s)))) (push (car s) r)))) (defun count-on-line (frag) (+ (length (find-on-line (args frag))) (length (find-on-line (rets frag))))) (defun substitute-in-output (ret arg) (let ((ret-frag (fr ret)) (arg-frag (fr arg))) (make-ports-off-line arg-frag (off-line-exit arg)) (setf (body ret-frag) (nsubst-inline (body arg-frag) (off-line-spot ret) (body ret-frag) (nxts ret))) (setf (body arg-frag) nil))) (defun substitute-in-input (ret arg) (let ((ret-frag (fr ret)) (arg-frag (fr arg))) (make-ports-off-line ret-frag (off-line-exit arg)) (when (off-line-exit arg) (dolist (a (args (fr ret))) (if (and (oss-var-p a) (not (off-line-exit a))) (setf (off-line-exit a) (off-line-exit arg)))) (nsubst (off-line-exit arg) `END (body ret-frag))) (setf (body arg-frag) (nsubst-inline (body ret-frag) (off-line-spot arg) (body arg-frag))) (setf (body ret-frag) nil))) (defun nsubst-inline (new-list old list &optional (save-spot nil)) (let ((tail (member old list))) (cond (save-spot (rplacd tail (nconc new-list (cdr tail)))) (new-list (rplaca tail (car new-list)) (rplacd tail (nconc (cdr new-list) (cdr tail)))) ((cdr tail) (rplaca tail (cadr tail)) (rplacd tail (cddr tail))) (T (setq list (nbutlast list))))) list) (defun make-ports-off-line (frag off-line-exit) (make-inputs-off-line frag off-line-exit) (make-outputs-off-line frag)) (defun make-outputs-off-line (frag) (dolist (out (find-on-line (rets frag))) (let ((-X- (gensym "-X-"))) (setf (off-line-spot out) -X-) (setf (body frag) `(,@(body frag) ,-X-))))) (defun make-inputs-off-line (frag off-line-exit) (dolist (in (find-on-line (args frag))) (let ((-X- (gensym "-X-"))) (setf (off-line-spot in) -X-) (setf (off-line-exit in) off-line-exit) (setf (body frag) `(,-X- . ,(body frag)))))) (defun convert-to-enumerator (ret off-line-exit) (let ((frag (fr ret))) (make-ports-off-line frag off-line-exit) (let* ((tail (member (off-line-spot ret) (body frag))) (head (ldiff (body frag) tail)) (flag (gensym "FLAG-")) (E (gensym "E-"))) (setf (off-line-spot ret) nil) (cond ((null (cdr tail)) (setf (body frag) head)) (T (push flag (aux frag)) (push `(setq ,flag nil) (prolog frag)) (setf (body frag) `((when (null ,flag) (setq ,flag T) (go ,E)) ,@(cdr tail) ,E . ,head))))) frag)) (defun convert-to-reducer (arg) (let ((frag (fr arg))) (make-outputs-off-line frag) (let* ((tail (member (off-line-spot arg) (body frag))) (head (ldiff (body frag) tail)) (flag (gensym "FLAG-")) (M (gensym "M-")) (N (gensym "N-"))) (push flag (aux frag)) (push `(setq ,flag nil) (prolog frag)) (setf (body frag) `((if (null ,flag) (go ,M)) ,N ,@(cdr tail) ,M ,@head (when (null ,flag) (setq ,flag T) (go ,N))))) frag)) ; 4- The frags to be combined are connected by on-line data flow. ;here things are complicated because there can be a lot of frags. ;All of the internal data flow must be on-line. There may well be ;external on-line inputs and outputs. There may also be on-line ;outputs which are used both internally and externally. There may ;also be external off-line ports, but they cannot be used internaly. ;However, all of this is no problem. All of the on-line ports will ;stay on-line and the same for the off-line ones. The only which one ;has to be careful about is making sure that an on-line port which is ;used both internaly and externally does not go away. (defun merge-on-line (*graph*) ;merge everything, all dflow is on-line. (let ((frag nil)) (dofrags (f) (handle-dflow f #'(lambda (r a) (declare (ignore r)) (member (fr a) *graph*))) (if (not frag) (setq frag f) (setq frag (merge-frags frag f)))) (maybe-de-oss frag))) ;This is used for the variable renaming part of all kinds of dflow. ;rets must be saved either if they have no dflow from them (they are ;outputs of the whole top level expression) or if there is a dflow to ;a frag which is not currently being dealt with. (defun handle-dflow (source allowable-p) (dolist (ret (rets source)) (let ((ret-killable (not (null (nxts ret))))) (dolist (arg (nxts ret)) (cond ((not (funcall allowable-p ret arg)) (setq ret-killable nil)) (T (nsubst (var ret) (var arg) (fr arg)) (-dflow ret arg) (-arg arg)))) (if ret-killable (-ret ret))))) ; TURNING A FRAG INTO CODE ;this takes a non-oss frag and makes it into a garden variety chunk of code. ;It assumes that it will never be called on a frag with an oss input. (defun codify (frag) (if *oss-tutorial-mode* (allow-oss-outputs frag)) (dolist (r (rets frag)) (if (oss-var-p r) (-ret r))) (maybe-de-oss frag) (let ((rets (mapcar #'(lambda (r) (var r)) (rets frag))) (aux (aux frag)) (code (prolog frag))) (when (wrappers frag) (if (cdr code) (setq code (cons 'progn code)) (setq code (car code))) (dolist (wrp (wrappers frag)) (setq code (funcall (eval wrp) code))) (setq code (list code))) (if (and rets (null (cdr rets))) (setq rets (car rets)) (setq rets `(values . ,rets))) (setq code (nconc code (list rets))) (multiple-value-setq (aux code) (clean-code aux code)) (setq aux (sort aux #'(lambda (a b) (string-lessp (string a) (string b))))) (if (dcls frag) (push `(declare . ,(clean-dcls aux (dcls frag))) code)) (setq code `(let ,aux . ,code)) (use-user-names aux code) (setq *last-oss-loop* code))) (defun use-user-names (aux loop) (let ((alist nil)) (dolist (v aux) (let ((u (cdr (assoc v *user-names*)))) (if (and u (not (contains-p (list u) loop)) (not (rassoc u alist))) (push (cons v u) alist)))) (if alist (nsublis alist loop)))) ;this takes an oss frag all of whose inputs and outputs are non-oss ;things and makes it into a non-oss frag. (defun maybe-de-oss (frag) (when (and (non-oss-p frag) (or (body frag) (epilog frag))) (when (not (or *permit-non-terminating-oss-expressions* (active-terminator-p frag))) (wrs 15 "Non-terminating OSS expression:~%~S" (code frag))) (let ((lab (gensym "L-"))) (setf (prolog frag) `((tagbody ,@(prolog frag) ,lab ,@(body frag) (go ,lab) END ,@(epilog frag))))) (setf (body frag) nil) (setf (epilog frag) nil) (clean-labs frag (cdar (prolog frag)))) frag) ;This cleans out unneeded vars ;and turns (funcall #'name . args) into (name args). ;together with the in-line substitution which is performed when ;fragments are combined, this transformation allows macros to be used ;as the arguments of oss functions. (defun clean-code (aux code) (let* ((suspicious (not-contained-twice aux code)) (dead-aux (clean-code1 suspicious code))) (clean-code3 code) (values (set-difference aux dead-aux) code))) (defun not-contained-twice (items thing) (let ((found-once nil) (found-twice nil)) (labels ((look-at (tree) (cond ((symbolp tree) (let ((found (car (member tree items)))) (when found (if (member found found-once) (pushnew found found-twice) (push found found-once))))) (T (do ((tt tree (cdr tt))) ((not (consp tt)) nil) (look-at (car tt))))))) (look-at thing)) (set-difference items found-twice))) (defun clean-code1 (suspicious code) (let ((dead nil)) (labels ((clean-code2 (prev-parent parent code &aux var) (tagbody R (when (setq var (car (member (setq-p code) suspicious))) (push var dead) (rplaca parent (setq code (caddr code))) (when (or (symbolp code) (constantp code)) (cond ((consp (cdr parent)) (rplaca parent (cadr parent)) (rplacd parent (cddr parent)) (setq code (car parent)) (go R)) ;do would skip the next element (prev-parent (pop (cdr prev-parent))))))) (when (consp code) (clean-code2 nil code (car code)) (do ((tt code (cdr tt))) ((not (and (consp tt) (consp (cdr tt)))) nil) (clean-code2 tt (cdr tt) (cadr tt)))))) (clean-code2 nil nil code) ;depends on code not being setq at top. dead))) (defun clean-code3 (code) (cond ((not (consp code)) code) (T (when (and (eq (car code) 'funcall) (eq (quoted-function-p (cadr code)) 'symbol)) (rplaca code (cadadr code)) (rplacd code (cddr code))) (do ((tt code (cdr tt))) ((not (consp tt))) (clean-code3 (car tt)))))) ;this cleans up type dcls and leaves other ones alone. ;the key problem is that there can end up being several type decls for the ;same variable when fragments are combined. (proclaim '(special *type-info*)) (defun clean-dcls (aux dcls) (let ((*type-info* (mapcar #'list aux)) (new-dcls nil)) (dolist (dcl dcls) (let ((d (type-dcl-p dcl))) (if (null d) (push dcl new-dcls) (dolist (var (cdr d)) (when (variable-p var) (process-type-dcl (car d) var)))))) (nconc (make-type-dcls) (nreverse new-dcls)))) (defun type-dcl-p (dcl) (cond ((not (consp dcl)) nil) ((eq (car dcl) 'type) (cdr dcl)) ((subtypep (car dcl) 'common) dcl))) (defun process-type-dcl (type var) (let ((entry (assoc var *type-info*))) (when entry (setf (cdr entry) (best-type (cdr entry) type))))) (defun best-type (type1 type2) (cond ((null type1) type2) ((eq type1 :notype) type1) ((subtypep type1 type2) type1) ((subtypep type2 type1) type2) (T :notype))) (defun make-type-dcls () (let ((dcls-by-type nil)) (dolist (entry (nreverse *type-info*)) ;to get lexical order right at end (when (and (cdr entry) (not (eq (cdr entry) :notype))) (let ((new-entry (assoc (cdr entry) dcls-by-type :test #'equal))) (if (null new-entry) (push (list (cdr entry) (car entry)) dcls-by-type) (push (car entry) (cdr new-entry)))))) (mapcar #'(lambda (d) (cons 'type d)) dcls-by-type))) ;this gets rid of duplicate labs in a row. (defun clean-labs (frag stmtns) (let ((alist nil)) (do ((l stmtns (cdr l))) ((not (consp (cdr l)))) L (when (and (car l) (symbolp (car l)) (cadr l) (symbolp (cadr l))) (push (cons (pop (cdr l)) (car l)) alist) (go L))) (nsublis alist frag))) ;this stuff supports tutorial-mode (defvar *standard-readtable* nil) (defvar *tutorial-readtable* nil) (defun oss-tutorial-mode (&optional (T-or-nil T)) (when (null *tutorial-readtable*) (setq *standard-readtable* *readtable*) (setq *tutorial-readtable* (copy-readtable *readtable*)) (set-macro-character #\[ #'oss-reader nil *tutorial-readtable*) (set-macro-character #\] #'oss-end-reader nil *tutorial-readtable*)) (setq *oss-tutorial-mode* T-or-nil) (cond (*oss-tutorial-mode* (setq *readtable* *tutorial-readtable*) "TUTORIAL-MODE-ON") (T (setq *readtable* *standard-readtable*) "TUTORIAL-MODE-OFF"))) (defstruct (literal-oss (:print-function literal-oss-print)) contents) (defun literal-oss-print (literal-oss stream level &aux first) (declare (ignore level)) (setq first T) (princ "[" stream) (dolist (item (literal-oss-contents literal-oss)) (if first (setq first nil) (princ " " stream)) (if (eq item '|oss-elipsis|) (princ "..." stream) (prin1 item stream))) (princ "]" stream)) (defun oss-end-reader (stream char) (declare (ignore stream char)) '|end-of-literal-oss|) (defun oss-reader (stream char) (declare (ignore char)) (prog ((stuff nil) item) L (setq item (read stream)) (if (eq item '|end-of-literal-oss|) (return (make-literal-oss :contents (nreverse stuff)))) (push item stuff) (go L))) ;This stuff is called by my-macroexpand in tutorial mode (defun allow-literal-oss-inputs (thing) (cond ((literal-oss-p thing) (annotate thing (funcallS-frag (literal-frag `(() ((items T)) (items list-ptr) () () ((setq list-ptr ',(literal-oss-contents thing))) ((if (null list-ptr) (go END)) (setq items (pop list-ptr))) () ())) nil))) (T thing))) ;this stuff is called by codify in tutorial mode (defun allow-oss-outputs (frag) (dolist (r (rets frag)) (when (oss-var-p r) (convert-to-literal-oss r)))) (defun convert-to-literal-oss (ret) (let* ((frag (fr ret)) (var (gensym "O-")) (step `((push ,(var ret) ,var)))) (if (not (active-terminator-p frag)) (setq step (append step `((when (> (length ,var) 10) (push '|oss-elipsis| ,var) (go END)))))) (push var (aux frag)) (push `(setq ,var nil) (prolog frag)) (push `(setq ,var (make-literal-oss :contents (nreverse ,var))) (epilog frag)) (cond ((null (off-line-spot ret)) (setf (body frag) (append (body frag) step))) (T (nsubst-inline step (off-line-spot ret) (body frag)))) (setf (oss-var-p ret) nil) (setf (off-line-spot ret) nil) (setf (var ret) var) frag)) ; SUB-PRIMITIVES FOR DEFINING COMPLEX FRAGS (defmacro terminateS () ;important is not defmacroSed "Subprimitive that causes the containing OSS function to terminate." '(go END)) (defmacroS lambda-primitiveS (input-list output-list aux-list &body expr-list) "Subprimitive for specifying literal OSS functions." (declare (ignore input-list output-list aux-list expr-list)) (ers 21 "Lambda-primitiveS used in inappropriate context:~%~S" +call+)) (defmacroS prologS (&body expr-list) "Subprimitive for defining computations that occur before an OSS function starts." (declare (ignore expr-list)) (ers 22.1 "PrologS used in inappropriate context:~%~S" +call+)) (defmacroS epilogS (&body expr-list) "Subprimitive for defining computations that occur after an OSS function stops." (declare (ignore expr-list)) (ers 22.2 "EpilogS used in inappropriate context:~%~S" +call+)) (defmacroS next-inS (var &rest expr-list) "Subprimitive for defining off-line inputs." (declare (ignore var expr-list)) (ers 22.3 "Next-inS used in inappropriate context:~%~S" +call+)) (defmacroS next-outS (var) "Subprimitive for defining off-line outputs." (declare (ignore var)) (ers 22.4 "Next-outS used in inappropriate context:~%~S" +call+)) (defmacroS wrapS (function) "Subprimitive for defining wrapping functions." (declare (ignore function)) (ers 22.5 "WrapS used in inappropriate context:~%~S" +call+)) (defmacroS alterableS (var form) "Specifies how to alter the LAMBDA-PRIMITIVES output VAR." (declare (ignore var form)) (ers 22.6 "AlterableS used in inappropriate context:~%~S" +call+)) (defmacro defun-primitiveS (name input-list output-list aux-list #-:GCLISP &environment #-:GCLISP *env* &body expr-list) "Subprimitive that defines an OSS function." (let ((call (list* 'defun-primitiveS name input-list output-list aux-list expr-list))) (top-starting-oss-expr call (setq expr-list (normalize-dcls expr-list T)) `(defmacroS ,name ,input-list ,@(if (stringp (car expr-list)) (list (pop expr-list))) (funcallS-frag (list->frag ',(frag->list (process-lambda-primitiveS call `(lambda-primitiveS . ,(cddr call))))) (list . ,input-list)))))) (defun process-lambda-primitiveS (call lambda-primitiveS) (starting-oss-expr call (let* ((ins (cadr lambda-primitiveS)) (outs (caddr lambda-primitiveS)) (aux (cadddr lambda-primitiveS)) (forms (normalize-dcls (cddddr lambda-primitiveS))) (oss-vars (cddadr (pop forms))) (dcl (pop forms)) (frag (make-frag :code call))) (dolist (v ins) (when (not (lambda-variable-p v)) (ers 23.1 "Bad lambda-primitiveS input variable: ~S" v)) (let* ((var (gensym (root v))) (arg (make-sym :var var :oss-var-p (not (null (member v oss-vars)))))) (+arg arg frag) (push (cons v arg) *renames*))) (dolist (v aux) (when (or (not (lambda-variable-p v)) (member v ins)) (ers 23.3 "Bad lambda-primitiveS aux variable: ~S" v)) (let ((var (gensym (root v)))) (push var (aux frag)) (push (cons v var) *renames*))) (dolist (v outs) (when (not (or (member v ins) (member v aux))) (ers 23.2 "Bad lambda-primitiveS output variable: ~S" v)) (let* ((var (rename v)) (ret (make-sym :var var :oss-var-p (not (null (member v oss-vars)))))) (+ret ret frag))) (setf (dcls frag) (process-subforms-&-rename (cdr dcl))) (let* ((alist nil) (new-forms nil)) (dolist (f forms) (cond ((not (symbolp f)) (push f new-forms)) (T (let ((new (gensym (root f)))) (push (cons `(go ,f) `(go ,new)) alist) (push new new-forms))))) (when alist (setq forms (sublis alist (nreverse new-forms) :test #'equal)))) (dolist (form forms) (case (and (consp form) (car form)) (prologS (setf (prolog frag) (append (prolog frag) (process-subforms-&-rename (cdr form))))) (epilogS (setf (epilog frag) (append (epilog frag) (process-subforms-&-rename (cdr form))))) (wrapS (when (not (and (cdr form) (consp (cdr form)) (null (cddr form)) (quoted-function-p (cadr form)))) (ers 26 "Malformed wrapS call:~%~S" form)) (setf (wrappers frag) (append (wrappers frag) (cdr form)))) (next-inS (let ((arg (cdr (assoc (cadr form) *renames*))) (actions (process-subforms-&-rename (cddr form))) (E (gensym "E-")) (F (gensym "F-")) (-X- (gensym "-X-"))) (when (not (and (member arg (args frag)) (oss-var-p arg) (null (off-line-spot arg)))) (ers 24 "Malformed next-inS call:~%~S" form)) (setf (off-line-spot arg) -X-) (if actions (setf (off-line-exit arg) E)) (setf (body frag) (append (body frag) (if (null actions) (list -X-) `(,-X- (go ,F) ,E ,@actions ,F)))))) (next-outS (let* ((var (cdr (assoc (cadr form) *renames*))) (ret (find-if #'(lambda (r) (eq var (var r))) (rets frag))) (-X- (gensym "-X-"))) (when (not (and ret (oss-var-p ret) (null (off-line-spot ret)) (null (cddr form)))) (ers 25 "Malformed next-outS call:~%~S" form)) (setf (off-line-spot ret) -X-) (setf (body frag) (append (body frag) (list -X-))))) (alterableS (let ((var (cdr (assoc (cadr form) *renames*))) (setf-form (car (process-subforms-&-rename (cddr form))))) (when (not (and (null (cdddr form)) (member (cadr form) outs) (not (contains-p ins (caddr form))) (not (assoc var (alterable frag))))) (ers 27 "Malformed alterableS call:~%~S" form)) (setf (alterable frag) (append (alterable frag) `((,var ,setf-form)))))) (otherwise (setf (body frag) (append (body frag) (process-subforms-&-rename (list form))))))) frag))) ; FUNCTIONS FOR DEALING WITH FEXPRS ;M-&-R takes in a piece of code. It assumes CODE is a semantic whole. Ie, it ;is something which could be evaled (as opposed to a disembodied cond clause). ;It scans over CODE macroexpanding all of the parts of it, and performing ;renames as specified by *RENAMES*. M-&-R puts entries on the variable ;*RENAMES* which block the renaming of bound variables. ; M-&-R also calls FN (if any) on every subpart of CODE (including the whole ;thing) which could possibly be evaluated. The result of consing together all ;of the results of FN is returned. Ie, the result is isomorphic to the input ;with each part replaced with what FN returned. This is done totally by ;copying. The input is not altered. ; In addition, m-&-R checks to see that the code isn't setqing variables ;it shouldn't be. ;In order to do the above, M-&-R has to be able to understand fexprs. It ;understands fexprs by having a description of each of the standard ones (see ;below). It will not work on certain weird ones. ; fexprs are understood by means of templates which are (usually circular) ;lists of function names. These fns are called in order to processes the ;various fields of the fexpr. The template can be a single fn in which case ;this fn is called to process the fexpr as a whole. (eval-when (eval load compile) (defmacro make-template (head rest) `(let ((h (append ',head nil)) (r (append ',rest nil))) (nconc h r r))) (defmacro deft (name head rest) `(setf (get ',name 'scan-template) (make-template ,head ,rest))) ) (proclaim '(special *being-setqed* ;T if in the assignment part of a setq *fn*)) ;FN being scanned over code ;ugh an infinite loop ensues if you recompile these in symbolics ;version 6 when they are defconstants (defvar *expr-template* (make-template (Q) (E))) (defvar *eval-all-template* (make-template () (E))) (defvar *fexprs-not-handled* '(COMPILER-LET FLET LABELS MACROLET ;CL forms DEF DEFF DEFPROP DEFUN LETF LETF* MACRO)) ;Lispm forms (defun m-&-r (code &optional (*fn* nil)) (let ((*being-setqed* nil)) (m-&-r1 code))) ;on lispm '(lambda ...) macroexpands to (function (lambda ...)) ugh! (defun my-macroexpand (code &aux (flag T)) (if *oss-tutorial-mode* (setq code (allow-literal-oss-inputs code))) (loop (if (or (null flag) (frag-p code) (and (consp code) (symbolp (car code)) (get (car code) 'scan-template))) (return)) (multiple-value-setq (code flag) (macroexpand-1 code #-:GCLISP *env*))) code) (defun m-&-r1 (code) (let ((*renames* *renames*) new) (setq code (my-macroexpand code)) (when (and (symbolp code) (setq new (cdr (assoc code *renames*)))) (if (and *being-setqed* (sym-p new)) (ers 12 "The letS{*} variable ~S setqed." code)) (setq code new)) (if *fn* (setq code (funcall *fn* code))) (if (not (consp code)) code (m-&-r2 code (let ((head (car code))) (if (member head *fexprs-not-handled*) (ers 20 "The form ~S not allowed in OSS expressions." head)) (if (symbolp head) (or (get head 'scan-template) *expr-template*) *eval-all-template*)))))) (defun m-&-r2 (code template) (if (not (listp template)) (funcall template code) (mapcar #'(lambda (tm c) (funcall tm c)) template code))) ;the following are the fns allowed in templates. (defun Q (code) code) (defun E (code) (m-&-r1 code)) (defun S (code) (let ((*being-setqed* T)) (m-&-r1 code))) (defun L (code) (if (symbolp code) code (m-&-r1 code))) (defun B (code) (bind-list code nil)) (defun B* (code) (bind-list code T)) (defun A (code) (arg-list code)) ;This handles binding lists for PROG and LET. (defun bind-list (args sequential &aux (pending nil)) (prog1 (mapcar #'(lambda (arg) (let* ((val? (and (consp arg) (cdr arg))) (new-val (if val? (m-&-r1 (cadr arg)))) (var (if (consp arg) (car arg) arg))) (if sequential (push (list var) *renames*) (push (list var) pending)) (if val? (list (car arg) new-val) arg))) args) (setq *renames* (append pending *renames*)))) (defun arg-list (args) (mapcar #'(lambda (arg) (let* ((vars (vars-of arg)) (val? (and (consp arg) (cdr arg))) (new-val (if val? (m-&-r1 (cadr arg))))) (setq *renames* (append (mapcar #'list vars) *renames*)) (if val? (list* (car arg) new-val (cddr arg)) arg))) args)) ;templates for special forms. Note that the following are not handled ; COMPILER-LET FLET LABELS MACROLET but must not macroexpand (deft block (Q Q) (E)) (deft catch (Q) (E)) (deft function (Q Q) ()) (deft eval-when (Q Q) (E)) (deft go (Q Q) ()) (deft if (Q) (E)) (deft lambda (Q A) (E)) (deft let (Q B) (E)) (deft let* (Q B*) (E)) (deft multiple-value-call (Q) (E)) (deft multiple-value-prog1 (Q) (E)) (deft progn (Q) (E)) (deft progv (Q) (E)) (deft quote (Q Q) ()) (deft return-from (Q Q) (E)) (deft setq (Q) (S E)) (deft tagbody (Q) (L)) (deft the (Q Q) (E)) (deft throw (Q) (E)) (deft type (Q Q) (E)) (deft unwind-protect (Q) (E)) ;These fix problems in Lucid/Sun Common Lisp. ;FLET and DECLARE in particular are macros there and messed things up ;by expanding at the wrong time. (deft flet (Q) (E)) (deft declare (Q) (EX)) ;needed by Xerox CL (deft compiler-let (Q) (E)) (deft macrolet (Q) (E)) (deft labels (Q) (E)) ;this stuff is for the Lispm, it should not be needed for more real common ;lisps, but cannot hurt. (Many to many things are special forms on ;the lispm.) (defun EX (code) (m-&-r2 code *expr-template*)) (defun EA (code) (m-&-r2 code *eval-all-template*)) (defun SA (code) (let ((*being-setqed* T)) (m-&-r2 code *eval-all-template*))) (defun DOB (code) (do-bind code nil)) (defun DOB* (code) (do-bind code T)) (defun DO-bind (code sequential? &aux (pending nil)) (let* ((inits (mapcar #'(lambda (e) (cond ((and (consp e) (cdr e)) (prog1 (m-&-r1 (cadr e)) (if sequential? (push (list (car e)) *renames*) (push (list (car e)) pending)))) (T (if sequential? (push (list e) *renames*) (push (list e) pending))))) code))) (setq *renames* (append pending *renames*)) (let ((updates (mapcar #'(lambda (e) (if (and (consp e) (cddr e)) (m-&-r1 (caddr e)))) code))) (mapcar #'(lambda (e i u) (cond ((not (consp e)) e) ((cddr e) (list (car e) i u)) ((cdr e) (list (car e) i)) (T e))) code inits updates)))) (defun WSLB (list) (prog1 (EX list) (push (list (car list)) *renames*))) ;the following are just like exprs from the point of view of OSS. ; *CATCH AND INHIBIT-STYLE-WARNINGS MULTIPLE-VALUE-LIST ; MULTIPLE-VALUE-RETURN OR PROGW RETURN RETURN-LIST ; VARIABLE-BOUNDP VARIABLE-LOCATION VARIABLE-MAKUNBOUND ; AND and OR have to have templates because the lispm does something ; odd with the way it expands them. The value gets lost sometimes. (deft AND (Q) (E)) ;this fixes an old lispm bug (deft COMMENT () (Q)) (deft COND (Q) (EA)) (deft DO (Q DOB EA) (L)) ;no old DO (deft DO* (Q DOB* EA) (L)) (deft DO-NAMED (Q Q DOB EA) (L)) (deft DO*-NAMED (Q Q DOB* EA) (L)) (deft GRINDEF () (Q)) (deft LET-IF (Q E B) (E)) (deft MULTIPLE-VALUE (Q SA) (E)) (deft OR (Q) (E)) ;this fixes an old lispm bug (deft SETF (Q) (E)) ;fixes wierd interaction with lispm setf (deft SETQ-GLOBALLY (Q) (S E)) (deft SIGNP (Q Q) (E)) (deft SSTATUS () (Q)) (deft STATUS () (Q)) (deft TRACE () (Q)) (deft UNTRACE () (Q)) (deft WITH-STACK-LIST (Q WSLB) (E)) (deft WITH-STACK-LIST* (Q WSLB) (E)) (defun multiple-value-bind-scan (body) (let ((source (E (caddr body))) ;note order of eval (bind (B (cadr body))) (forms (EA (cdddr body)))) (list* (car body) bind source forms))) (setf (get 'multiple-value-bind 'scan-template) #'multiple-value-bind-scan) (defvar *prog-template* (make-template (Q B) (L))) (defvar *named-prog-template* (make-template (Q Q B) (L))) (defvar *prog*-template* (make-template (Q B*) (L))) (defvar *named-prog*-template* (make-template (Q Q B*) (L))) (defun prog-scan (body) (ps0 body *prog-template* *named-prog-template*)) (defun prog*-scan (body) (ps0 body *prog*-template* *named-prog*-template*)) (defun ps0 (body template named-template) (if (and (cdr body) (cadr body) (symbolp (cadr body))) (m-&-r2 body named-template) (m-&-r2 body template))) (setf (get 'prog 'scan-template) #'prog-scan) (setf (get 'prog* 'scan-template) #'prog*-scan) ; SERIES FUNCTION LIBRARY ;Special form for defining series functions directly in the internal form. ;The various variables and the exit label must be unique in the body. ;The exit label must be END. Also everything is arranged just as it is ;in an actual frag structure. (eval-when (eval load compile) (defmacro defS (name arglist doc args rets aux dcls alt prolog body epilog wrappers) (let* ((vals (mapcar #'car args)) (syms aux) (stuff (list args rets aux dcls alt prolog body epilog wrappers))) (dolist (a args) (push (car a) syms) (if (written-p (car a) stuff) (error "Malformed defS: Input written ~A" (car a)))) (dolist (r rets) (if (not (member (car r) syms)) (error "Malformed defS: Free ret ~A" (car r)))) (if (eq arglist T) (setq arglist vals)) `(defmacroS ,name ,arglist ,@(if doc (list doc)) (funcallS-frag (literal-frag ',stuff) (list . ,vals))))) (defun written-p (var thing) (if (eq var (setq-p thing)) T (do ((tt thing (cdr tt))) ((not (consp tt)) nil) (if (written-p var (car tt)) (return T))))) (defun setq-p (thing) (and (eq-car thing 'setq) (= (length thing) 3) (cadr thing))) (defun eq-car (thing item) (and (consp thing) (eq (car thing) item))) ) (defmacroS Eoss (&rest expr-list) "Creates a series of the results of the expressions." (let ((spot (member :R expr-list))) (when (and spot (null (cdr spot))) (setq expr-list (ldiff expr-list spot)) (setq spot nil)) (cond ((null spot) (let ((ins nil)) (dotimes (i (length expr-list) i) (push (gensym "IN-") ins)) (funcallS-frag (literal-frag `(,(mapcar #'list ins) ((items T)) (items list-ptr) () () ((setq list-ptr (list . ,ins))) ((if (null list-ptr) (go END)) (setq items (car list-ptr)) (setq list-ptr (cdr list-ptr))) () ())) expr-list))) ((and (eq expr-list spot) (null (cddr spot))) (funcallS-frag (literal-frag '(((expr)) ((expr T)) () () () () () () ())) (list (cadr spot)))) (T (let ((first-part (ldiff expr-list spot)) (second-part (cdr spot)) (ins1 nil) (ins2 nil)) (dotimes (i (length first-part) i) (push (gensym "IN-") ins1)) (dotimes (i (length second-part) i) (push (gensym "IN-") ins2)) (funcallS-frag (literal-frag `(,(mapcar #'list (append ins1 ins2)) ((items T)) (items list-ptr) () () ((setq list-ptr (let ((x (list . ,ins1)) (y (list . ,ins2))) (nconc x y y)))) ((setq items (pop list-ptr))) () ())) (append first-part second-part))))))) (defmacroS Eup (&rest args) "Creates a series of numbers by counting up from START by :BY." (let ((start 0) (by nil) (limit-type :none) (limit nil)) (when (and args (not (member (car args) '(:to :below :length :by)))) (setq start (pop args))) (prog () L (if (null args) (return nil)) (when (and (eq (car args) :by) (null by) (cdr args)) (pop args) (setq by (pop args)) (go L)) (when (and (member (car args) '(:to :below :length)) (eq limit-type :none) (cdr args)) (setq limit-type (pop args)) (setq limit (pop args)) (go L)) (ers 1.1 "Too many keywords specified in a call on Eup:~%~S" +call+)) (when (null by) (setq by 1)) (if (eq limit-type :none) (funcallS-frag (literal-frag '(((start) (by)) ((numbers T)) (numbers) () () ((setq numbers (- start by))) ((setq numbers (+ numbers by))) () ())) (list start by)) (funcallS-frag (literal-frag (case limit-type (:to '(((start) (to) (by)) ((numbers T)) (numbers) () () ((setq numbers (- start by))) ((setq numbers (+ numbers by)) (if (> numbers to) (go END))) () ())) (:below '(((start) (below) (by)) ((numbers T)) (numbers) () () ((setq numbers (- start by))) ((setq numbers (+ numbers by)) (if (not (< numbers below)) (go END))) () ())) (:length '(((start) (length) (by)) ((numbers T)) (numbers counter) () () ((setq numbers (- start by)) (setq counter length)) ((setq numbers (+ numbers by)) (if (not (plusp counter)) (go END)) (decf counter)) () ())))) (list start limit by))))) (defmacroS Edown (&rest args) "Creates a series of numbers by counting down from START by :BY." (let ((start 0) (by nil) (limit-type :none) (limit nil)) (when (and args (not (member (car args) '(:to :above :length :by)))) (setq start (pop args))) (prog () L (if (null args) (return nil)) (when (and (eq (car args) :by) (null by) (cdr args)) (pop args) (setq by (pop args)) (go L)) (when (and (member (car args) '(:to :above :length)) (eq limit-type :none) (cdr args)) (setq limit-type (pop args)) (setq limit (pop args)) (go L)) (ers 1.2 "Too many keywords specified in a call on Eup:~%~S" +call+)) (when (null by) (setq by 1)) (if (eq limit-type :none) (funcallS-frag (literal-frag '(((start) (by)) ((numbers T)) (numbers) () () ((setq numbers (+ start by))) ((setq numbers (- numbers by))) () ())) (list start by)) (funcallS-frag (literal-frag (case limit-type (:to '(((start) (to) (by)) ((numbers T)) (numbers) () () ((setq numbers (+ start by))) ((setq numbers (- numbers by)) (if (< numbers to) (go END))) () ())) (:above '(((start) (above) (by)) ((numbers T)) (numbers) () () ((setq numbers (+ start by))) ((setq numbers (- numbers by)) (if (not (> numbers above)) (go END))) () ())) (:length '(((start) (length) (by)) ((numbers T)) (numbers counter) () () ((setq numbers (+ start by)) (setq counter length)) ((setq numbers (- numbers by)) (if (not (plusp counter)) (go END)) (decf counter)) () ())))) (list start limit by))))) (defS Esublists (list &optional (end-test '#'endp)) "Creates a series of the sublists in a list." ((list) (end-test)) ((sublists T)) (sublists list-ptr) () () ((setq list-ptr list)) ((if (funcall end-test list-ptr) (go END)) (setq sublists list-ptr) (setq list-ptr (cdr list-ptr))) () ()) (defS Elist (list &optional (end-test '#'endp)) "Creates a series of the elements in a list." ((list) (end-test)) ((elements T)) (elements list-ptr parent) () ((elements (car parent))) ((setq list-ptr list)) ((if (funcall end-test list-ptr) (go END)) (setq parent list-ptr) (setq elements (car list-ptr)) (setq list-ptr (cdr list-ptr))) () ()) (defS Ealist (alist &optional (test '#'eql)) "Creates two series containing the keys and values in an alist." ((alist) (test)) ((keys T) (values T)) (alist-ptr keys values parent) () ((keys (car parent)) (values (cdr parent))) ((setq alist-ptr alist)) (L (if (null alist-ptr) (go END)) (setq parent (car alist-ptr)) (setq alist-ptr (cdr alist-ptr)) (if (or (null parent) (not (eq parent (assoc (car parent) alist :test test)))) (go L)) (setq keys (car parent)) (setq values (cdr parent))) () ()) (defS Eplist T "Creates two series containing the indicators and values in a plist." ((plist)) ((indicators T) (values T)) (indicators values plist-ptr parent) () ((indicators (car parent)) (values (cadr parent))) ((setq plist-ptr plist)) (L (if (null plist-ptr) (go END)) (setq parent plist-ptr) (setq indicators (car plist-ptr)) (setq plist-ptr (cdr plist-ptr)) (setq values (car plist-ptr)) (setq plist-ptr (cdr plist-ptr)) (do ((ptr plist (cddr ptr))) ((eq (car ptr) indicators) (if (not (eq ptr parent)) (go L))))) () ()) (defS Etree (tree &optional (leaf-test '#'atom)) "Creates a series of the nodes in a tree." ((tree) (leaf-test)) ((nodes T)) (nodes state) () () ((setq state (list tree))) ((if (null state) (go END)) (setq nodes (car state)) (setq state (cdr state)) (when (not (funcall leaf-test nodes)) (do ((ns nodes (cdr ns)) (r nil (cons (car ns) r))) ((not (consp ns)) (setq state (nreconc r state)))))) () ()) (defS Efringe (tree &optional (leaf-test '#'atom)) "Creates a series of the leaves of a tree." ((tree) (leaf-test)) ((leaves T)) (leaves parent state) () ((leaves (car parent))) ((setq state (list (list tree)))) (L (if (null state) (go END)) (setq leaves (car state)) (setq state (cdr state)) (setq parent leaves) (setq leaves (car leaves)) (when (not (funcall leaf-test leaves)) (do ((ns leaves (cdr ns)) (r nil (cons ns r))) ((not (consp ns)) (setq state (nreconc r state)))) (go L))) () ()) (defmacroS Evector (vector &optional (indices (list 'Eup))) "Creates a series of the elements in a vector." (if (equal indices '(Eup)) (funcallS-frag (literal-frag '(((vector)) ((elements T)) (elements last index vect) ((type integer last index)) ((elements (aref vect index))) ((setq index -1) (setq last (length vector)) (setq vect vector)) ((incf index) (if (not (< index last)) (go END)) (setq elements (aref vector index))) () ())) (list vector)) (funcallS-frag (literal-frag '(((vector) (indices T)) ((elements T)) (elements last vect index) ((type integer last index)) ((elements (aref vect index))) ((setq last (length vector)) (setq vect vector)) ((if (not (< indices last)) (go END)) (setq index indices) (setq elements (aref vector indices))) () ())) (list vector indices)))) (defS Esequence (sequence &optional (indices (list 'Eup))) "Creates a series of the elements in a sequence." ((sequence) (indices T)) ((elements T)) (elements last seq index) () ((elements (elt seq index))) ((setq last (length sequence)) (setq seq sequence)) ((if (not (< indices last)) (go END)) (setq index indices) (setq elements (elt sequence indices))) () ()) (defmacroS Efile (name) "Creates a series of the forms in the file named NAME." (let ((file (gensym "FILE-"))) (funcallS-frag (literal-frag `(() ((items T)) (items) () () () ((if (eq (setq items (read ,file nil ,file)) ,file) (go END))) () (#'(lambda (code) (list 'with-open-file '(,file ,name :direction :input) code))))) nil))) #-lispm (defS Ehash T "Creates two series containing the keys and values in a hash table." ((table)) ((keys T) (values T)) (keys values list-ptr) () () ((setq list-ptr nil) (maphash #'(lambda (key val) (push (cons key val) list-ptr)) table)) ((if (null list-ptr) (go END)) (setq keys (caar list-ptr)) (setq values (cdar list-ptr)) (setq list-ptr (cdr list-ptr))) () ()) #+lispm ;see hash-elements loop code (defS Ehash T "Creates two series containing the keys and values in a hash table." ((table)) ((keys T) (values T)) (state keys values) () () ((setq state nil)) ((if (not (multiple-value-setq (state keys values) (si:send table :next-element state))) (go END))) () (#'(lambda (c) `(si:inhibit-gc-flips ,c)))) #-lispm (defS Esymbols (&optional (package nil)) "Creates a series of the symbols in PACKAGE." ((package)) ((symbols T)) (symbols list-ptr) () () ((setq list-ptr nil) (do-symbols (s (or package *package*)) (push s list-ptr))) ((if (null list-ptr) (go END)) (setq symbols (car list-ptr)) (setq list-ptr (cdr list-ptr))) () ()) #+lispm ;see do-symbols (defS Esymbols (&optional (package nil)) "Creates a series of the symbols in PACKAGE." ((package)) ((symbols T)) (index state symbols) () () ((multiple-value-setq (index symbols state) (si:loop-initialize-mapatoms-state (or package *package*) nil))) ((if (multiple-value-setq (nil index symbols state) (si:loop-test-and-step-mapatoms index symbols state)) (go END))) () ()) (defmacroS EnumerateF (init step &optional (test nil test-p)) "Creates a series by applying STEP to INIT until TEST returns non-null." (if test-p (funcallS-frag (literal-frag '(((init) (step) (test)) ((items T)) (items state) () () ((setq state init)) ((cond ((funcall test state) (go END)) (T (setq items state) (setq state (funcall step state))))) () ())) (list init step test)) (funcallS-frag (literal-frag '(((init) (step)) ((items T)) (items state) () () ((setq state init)) ((setq items state state (funcall step state))) () ())) (list init step)))) (defS Enumerate-inclusiveF T "Creates a series containing one more element than EnumerateF." ((init) (step) (test)) ((items T)) (items state done) () () ((setq done nil) (setq state init)) ((if done (go END)) (setq done (funcall test state)) (setq items state) (if (not done) (setq state (funcall step state)))) () ()) (defmacroS Tprevious (items &optional (default nil) (amount 1)) "Shifts ITEMS to the right by AMOUNT inserting DEFAULT." (if (eql amount 1) (funcallS-frag (literal-frag '(((items T) (default)) ((shifted-items T)) (shifted-items state) () () ((setq state default)) ((setq shifted-items state) (setq state items)) () ())) (list items default)) (funcallS-frag (literal-frag '(((items T) (default) (amount)) ((shifted-items T)) (shifted-items ring) () () ((setq ring (make-list (1+ amount) :initial-element default)) (nconc ring ring)) ((setf (car ring) items) (setq ring (cdr ring)) (setq shifted-items (car ring))) () ())) (list items default amount)))) (defmacroS Tlatch (items &key (after nil) (before nil) (pre nil pre?) (post nil post?)) "Modifies a series before or after a latch point." (when (and after before) (ers 1.3 "Too many keywords specified in call on Tlatch:~%~S" +call+)) (if (not (or before after)) (setq after 1)) (if (null pre?) (setq post? T)) (funcallS-frag (literal-frag `(((items T) (for) ,@(if pre? '((pre T))) ,@(if post? '((post T)))) ((masked-items T)) (masked-items state) () () ((setq state for)) ((cond (,@(if before '((and (plusp state) (or (null items) (not (zerop (setq state (1- state))))))) '((plusp state) (if items (decf state)))) (setq masked-items ,(if pre? 'pre 'items))) (T (setq masked-items ,(if post? 'post 'items))))) () ())) `(,items ,(or before after) ,@(if pre? (list pre)) ,@(if post? (list post))))) (defS Tuntil T "Returns ITEMS up to, but not including, the first non-null element of BOOLS." ((bools T) (items T)) ((items T)) () () () () ((if bools (go END))) () ()) (defS TuntilF T "Returns ITEMS up to, but not including, the first element which satisfies PRED." ((pred T) (items T)) ((items T)) () () () () ((if (funcall pred items) (go END))) () ()) (defmacroS Tcotruncate (items &rest more-items) "Truncates all the inputs to the length of the shortest input." (let ((frag (make-frag)) (stuff (cons items more-items))) (dotimes (i (length stuff) i) (let ((var (gensym "CT-"))) (+arg (make-sym :var var :oss-var-p T) frag) (+ret (make-sym :var var :oss-var-p T) frag))) (funcalls-frag frag stuff))) (defmacroS TmapF (function &rest items-list) "Maps FUNCTION over the input series." (do-TmapF function items-list)) (defun do-TmapF (function items-list) (let ((frag (make-frag)) (params nil) (retvar (gensym "ITEMS-")) (fn (gensym "FUNCTION-"))) (+arg (make-sym :var fn) frag) (+ret (make-sym :var retvar :oss-var-p T) frag) (setf (aux frag) (list retvar)) (dotimes (i (length items-list) i) (let ((var (gensym "M-"))) (push var params) (+arg (make-sym :var var :oss-var-p T) frag))) (setf (body frag) `((setq ,retvar (funcall ,fn . ,(nreverse params))))) (funcalls-frag frag (cons function items-list)))) (defmacroS TscanF (&rest arg-list) "Computes cumulative values by applying FUNCTION to the elements of ITEMS." (if (= (length arg-list) 3) (funcallS-frag (literal-frag '(((init) (function) (items T)) ((results T)) (results) () () ((setq results init)) ((setq results (funcall function results items))) () ())) arg-list) (funcallS-frag (literal-frag '(((function) (items T)) ((results T)) (first results) () () ((setq first T)) ((if first (setq first nil results items) (setq results (funcall function results items)))) () ())) arg-list))) (defS Tremove-duplicates (Oitems &optional (comparitor '#'eql)) "Removes the duplicate elements from a series." ((Oitems T -X-) (comparitor)) ((Oitems T)) (seen) () () ((setq seen nil)) (L -X- (if (member Oitems seen :test comparitor) (go L)) (push Oitems seen)) () ()) (defS Tchunk T "Creates a series of lists of length AMOUNT of non-overlapping subseries of OITEMS." ((amount) (Oitems T -X-)) ((lists T)) (lists i state) () () ((setq state nil) (setq i amount)) (L -X- (decf i) (push Oitems state) (if (plusp i) (go L)) (setq lists (nreverse state)) (setq state nil) (setq i amount)) () ()) (defS Twindow T "Creates a series of lists of length AMOUNT of successive overlapping subseries." ((amount) (Oitems T -X-)) ((lists T)) (lists ring count) () () ((setq ring (make-list amount)) (setq count amount) (nconc ring ring)) (L -X- (decf count) (setq ring (cdr ring)) (setf (car ring) Oitems) (if (plusp count) (go L)) (let ((spot (cdr ring))) ;Avoids bug in Dec CL. (rplacd ring nil) (setq lists (copy-list spot)) (rplacd ring spot))) () ()) (defS Tpositions (Obools) "Returns a series of the positions of non-null elements in OBOOLS." ((Obools T -X-)) ((index T)) (index) () () ((setq index -1)) (L -X- (incf index) (if (not Obools) (go L))) () ()) (defS Tmask T "Creates a series continuing T in the indicated positions." ((Omonotonic-indices T -X- D)) ((bools T)) (bools index) () () ((setq index -1 bools T)) ( (if (not bools) (go F)) -X- (go F) D (setq index nil) F (setq bools (and index (= (progn (incf index) index) Omonotonic-indices)))) () ()) (defmacroS Tselect (bools &optional (items nil items-p)) "Selects the elements of ITEMS corresponding to non-null elements of BOOLS." (if items-p (funcallS-frag (literal-frag '(((bools T) (items T)) ((items T -X-)) () () () () ((if (not bools) (go F)) -X- F) () ())) (list bools items)) (funcallS-frag (literal-frag '(((bools T -X-)) ((bools T)) () () () () (L -X- (if (not bools) (go L))) () ())) (list bools)))) (defS TselectF T "Selects the elements of ITEMS for which PRED is non-null." ((pred) (Oitems T -X-)) ((Oitems T)) () () () () (L -X- (if (not (funcall pred Oitems)) (go L))) () ()) (defS Texpand (bools Oitems &optional (default nil)) "Spreads the elements of ITEMS out into the indicated positions." ((bools T) (Oitems T -X-) (default)) ((items T)) (items) () () () ((when (not bools) (setq items default) (go F)) -X- (setq items Oitems) F) () ()) (defmacroS Tsubseries (Oitems start &optional (below nil)) "Returns the elements of OITEMS from START up to, but not including, BELOW." (if below (funcallS-frag (literal-frag '(((items T -X-) (start) (below)) ((items T)) (index) () () ((setq index -1)) (LP -X- (incf index) (if (not (< index below)) (go END)) (if (< index start) (go LP))) () ())) (list Oitems start below)) (funcallS-frag (literal-frag '(((items T -X-) (start)) ((items T)) (index) () () ((setq index -1)) (LP -X- (incf index) (if (< index start) (go LP))) () ())) (list Oitems start)))) (defS Tmerge T "Merges two series into one." ((Oitems1 T -X1- F1) (Oitems2 T -X2- F2) (comparator)) ((items T)) (items need1 need2) () () ((setq need1 1 need2 1)) ( (if (not (plusp need1)) (go F1)) (setq need1 -1) -X1- (setq need1 0) F1 (if (not (plusp need2)) (go F2)) (setq need2 -1) -X2- (setq need2 0) F2 (cond ((and (minusp need1) (minusp need2)) (go END)) ((minusp need1) (setq items Oitems2) (setq need2 1)) ((minusp need2) (setq items Oitems1) (setq need1 1)) ((funcall comparator Oitems1 Oitems2) (setq items Oitems1) (setq need1 1)) (T (setq items Oitems2) (setq need2 1)))) () ()) (defS Tlastp T "Determines which element of the input is the last." ((Oitems T -X- F)) ((bools T) (items T)) (bools items started) () () ((setq started nil) (setq bools nil)) ( (if bools (go END)) L (setq items Oitems) -X- (when (not started) (setq started T) (go L)) (go D) F (if (not started) (go END)) (setq bools T) D) () ()) (defmacroS Tconcatenate (Oitems1 Oitems2 &rest more-Oitems) ;fix! "Concatenates two or more series end to end." (let (args body (len (+ 2 (length more-Oitems)))) (dotimes (i (1- len)) (let ((in (gensym "I-")) (spot (gensym "-X-")) (exit (gensym "E-")) (skip (gensym "F-"))) (push (list in T spot exit) args) (setq body (nconc body `((if (not (= state ,i)) (go ,skip)) ,spot (setq items ,in) (go D) ,exit (incf state) ,skip))))) (let ((in (gensym "I-")) (spot (gensym "-X-"))) (push (list in T spot) args) (setq body (nconc body `(,spot (setq items ,in) D)))) (funcallS-frag (literal-frag `(,(reverse args) ((items T)) (items state) () () ((setq state 0)) ,body () ())) (list* Oitems1 Oitems2 more-Oitems)))) (defmacroS Tsplit (items bools &rest more-bools) "Divides a series into multiple outputs based on BOOLS." (do-Tsplit items (cons bools more-bools) T)) (defmacroS TsplitF (items pred &rest more-pred) "Divides a series into multiple outputs based on PRED." (do-Tsplit items (cons pred more-pred) nil)) (defun do-Tsplit (items stuff bools-p) (let ((frag (make-frag)) (ivar (gensym "ITEMS-")) (D (gensym "D-"))) (+arg (make-sym :var ivar :oss-var-p T) frag) (dotimes (i (length stuff) i) (let ((var (gensym "B-")) (-X- (gensym "-X-")) (S (gensym "S-"))) (+arg (make-sym :var var :oss-var-p bools-p) frag) (+ret (make-sym :var ivar :oss-var-p T :off-line-spot -X-) frag) (setf (body frag) `(,@(body frag) (if (not ,(if bools-p var `(funcall ,var ,ivar))) (go ,S)) ,-X- (go ,D) ,S )))) (let ((-X- (gensym "-X-"))) (+ret (make-sym :var ivar :oss-var-p T :off-line-spot -X-) frag) (setf (body frag) `(,@(body frag) ,-X- ,D))) (funcalls-frag frag (cons items stuff)))) (defmacroS TconcatenateF (enumerator Oitems) "Concatenates the results of applying ENUMERATOR to the elements of OITEMS." (let* ((in (gensym "IN-")) (enum-form `(lambdaS (,in) (funcallS ,enumerator ,in))) (enum (process-lambdaS enum-form enum-form)) (flag (gensym "FLAG-")) (-X- (gensym "-X-")) (E (gensym "E-")) (C (gensym "C-"))) (when (or (non-oss-p enum) (not (active-terminator-p enum)) (not (rets enum)) (not (oss-var-p (car (rets enum)))) (epilog enum) (wrappers enum)) (ers 2 "Invalid enumerator arg to TconcatenateF:~%~S" enumerator)) (push flag (aux enum)) (setf (oss-var-p (car (args enum))) T) (setf (off-line-spot (car (args enum))) -X-) (nsubst E 'END enum) (setf (body enum) `( (if ,flag (go ,C) (setq ,flag T)) ,E ,-X- ,@(prolog enum) ,C ,@(body enum))) (setf (prolog enum) `((setq ,flag nil))) (annotate +call+ (funcallS-frag enum (list Oitems))))) (defS Rlist T "Combines the elements of ITEMS together into a list." ((items T)) ((the-list)) (the-list tail) () () ((setq the-list nil) (setq tail nil)) ((if (null the-list) (setq the-list (setq tail (list items))) (rplacd tail (setq tail (list items))))) () ()) (defS Rbag T "Combines the elements of ITEMS together into an unordered list." ((items T)) ((list)) (list) () () ((setq list nil)) ((setq list (cons items list))) () ()) (defS Rappend T "Appends the elements of LISTS together into a single list." ((lists T)) ((list)) (list end) () () ((setq end nil) (setq list nil)) ((when lists (let ((copy (copy-list lists))) (if end (setf (cdr (last end)) copy)) (setq end copy) (if (null list) (setq list copy))))) () ()) (defS Rnconc T "Destructively appends the elements of LISTS together into a single list." ((lists T)) ((list)) (list end) () () ((setq end nil) (setq list nil)) ((when lists (if end (setf (cdr (last end)) lists)) (setq end lists) (if (null list) (setq list lists)))) () ()) (defmacroS Rvector (items &rest option-plist &key (size nil) &allow-other-keys) "Combines the elements of ITEMS together into a vector." (cond (size (remf option-plist :size) (funcallS-frag (literal-frag `(((items T)) ((vector)) (vector index) () () ((setq vector (make-array ,size . ,option-plist)) (setq index 0)) ((setf (aref vector index) items) (incf index)) () ())) (list items))) (T (setf (getf option-plist :adjustable) T) (setf (getf option-plist :fill-pointer) 0) (funcallS-frag (literal-frag `(((items T)) ((vector)) (vector) () () ((setq vector (make-array 32 . ,option-plist))) ((vector-push-extend items vector)) () ())) (list items))))) (defmacroS Rhash (keys values &rest option-plist) "Combines a series of keys and a series of values together into a hash table." (funcallS-frag (literal-frag `(((keys T) (values T)) ((table)) (table) () () ((setq table (make-hash-table . ,option-plist))) ((setf (gethash keys table) values)) () ())) (list keys values))) (defmacroS Rfile (name items &rest option-plist) "Prints the elements of ITEMS into a file." (setf (getf option-plist :direction) :output) (funcallS-frag (literal-frag `(((items T)) ((out)) (out) () () ((setq out T)) ((print items file)) () (#'(lambda (c) (list 'with-open-file '(file ,name . ,option-plist) c))))) (list items))) (defS Ralist T "Combines a series of keys and a series of values together into an alist." ((keys T) (values T)) ((alist)) (alist) () () ((setq alist nil)) ((setq alist (cons (cons keys values) alist))) ((setq alist (nreverse alist))) ()) (defS Rplist T "Combines a series of indicators and a series of values together into a plist." ((indicators T) (values T)) ((plist)) (plist) () () ((setq plist nil)) ((setq plist (list* values indicators plist))) ((setq plist (nreverse plist))) ()) (defS Rfirst-late (items &optional (default nil)) "Returns the first element of ITEMS." ((items T) (default)) ((item)) (item found) () () ((setq item default) (setq found nil)) ((when (not found) (setq item items) (setq found T))) () ()) (defS Rlast (items &optional (default nil)) "Returns the last element of ITEMS." ((items T) (default)) ((item)) (item) () () ((setq item default)) ((setq item items)) () ()) (defS Rnth-late (n items &optional (default nil)) "Returns the nth element of ITEMS." ((n) (items T) (default)) ((item)) (item counter) () () ((setq item default) (setq counter n)) ((when (zerop counter) (setq item items)) (decf counter)) () ()) (defS Rlength T "Returns the number of elements in ITEMS." ((items T)) ((number)) (number) () () ((setq number 0)) ((incf number)) () ()) (defS Rand-late T "Computes the AND of the elements of BOOLS." ((bools T)) ((bool)) (bool) () () ((setq bool T)) ((setq bool (and bool bools))) () ()) (defS Ror-late T "Computes the OR of the elements of BOOLS." ((bools T)) ((bool)) (bool) () () ((setq bool nil)) ((setq bool (or bool bools))) () ()) (defS Rsum T "Computes the sum of the elements in NUMBERS." ((numbers T)) ((num)) (num) ((type number numbers num)) () ((setq num 0)) ((setq num (+ num numbers))) () ()) (defS Rmax T "Returns the maximum element of NUMBERS." ((numbers T)) ((number)) (number) () () ((setq number nil)) ((if (or (null number) (< number numbers)) (setq number numbers))) () ()) (defS Rmin T "Returns the minimum element of NUMBERS." ((numbers T)) ((number)) (number) () () ((setq number nil)) ((if (or (null number) (> number numbers)) (setq number numbers))) () ()) (defS ReduceF T "Computes a cumulative value by applying FUNCTION to the elements of ITEMS." ((init) (function) (items T)) ((result)) (result) () () ((setq result init)) ((setq result (funcall function result items))) () ()) (defS Rfirst (items &optional (default nil)) "Returns the first element of ITEMS, terminating early." ((items T) (default)) ((item)) (item) () () ((setq item default)) ((setq item items) (go END)) () ()) (defS Rnth (n items &optional (default nil)) "Returns the nth element of ITEMS, terminating early." ((n) (items T) (default)) ((item)) (counter item) () () ((setq item default) (setq counter n)) ((when (zerop counter) (setq item items) (go END)) (decf counter)) () ()) (defS Rand T "Computes the AND of the elements of BOOLS, terminating early." ((bools T)) ((bool)) (bool) () () ((setq bool T)) ((if (null (setq bool bools)) (go END))) () ()) (defS Ror T "Computes the OR of the elements of BOOLS, terminating early." ((bools T)) ((bool)) (bool) () () ((setq bool nil)) ((if (setq bool bools) (go END))) () ()) ;Has correct annotation, because is not a defmacroS thing. (defmacro showS (thing &optional (format "~%~S") (stream '*standard-output*)) "Displays THING for debugging purposes." (let ((var (gensym "SHOW-"))) `(let ((,var ,thing)) (format ,stream ,format ,var) ,var))) ;------------------------------------------------------------------------ ; ; Copyright (c) Richard C. Waters, 1988 ; ;------------------------------------------------------------------------ ; \ No newline at end of file diff --git a/lispusers/oss.txt b/lispusers/oss.txt new file mode 100644 index 00000000..bfcdfbc5 --- /dev/null +++ b/lispusers/oss.txt @@ -0,0 +1 @@ + [This file is an on-line textual version of MIT/AIM-958a. It is not as readable as the printed version of the document, but is more convenient in some ways. In order to locate the doumentation for a particular function or error message, search for two carriage returns followed by the name of the function or the number of the error. A printed copy of MIT/AIM-958a can easily be obtained from the MIT AI Lab publications office; 5454 Tech SQ Room 818; Cambridge MA 02139; (617)-253-6773.] MASSACHUSETTS INSTITUTE OF TECHNOLOGY ARTIFICIAL INTELLIGENCE LABORATORY A.I. Memo No. 958a March 1988 Obviously Synchronizable Series Expressions: Part I: User's Manual for the OSS Macro Package by Richard C. Waters Abstract The benefits of programming in a functional style are well known. In particular, algorithms that are expressed as compositions of functions operating on series/vectors/streams of data elements are much easier to understand and modify than equivalent algorithms expressed as loops. Unfortunately, many programmers hesitate to use series expressions, because they are typically implemented very inefficiently. A Common Lisp macro package (OSS) has been implemented which supports a restricted class of series expressions, obviously synchronizable series expressions, which can be evaluated very efficiently by automatically converting them into loops. Using this macro package, programmers can obtain the advantages of expressing computations as series expressions without incurring any run-time overhead. Copyright Massachusetts Institute of Technology, 1988 This report describes research done at the Artificial Intelligence Laboratory of the Massachusetts Institute of Technology. Support for the laboratory's artificial intelligence research has been provided in part by the National Science Foundation under grant IRI-8616644, in part by the IBM Corporation, in part by the NYNEX Corporation, and in part by the Advanced Research Projects Agency of the Department of Defense under Office of Naval Research contract N00014-85-K-0124. The views and conclusions contained in this document are those of the authors, and should not be interpreted as representing the policies, neither expressed nor implied, of the National Science Foundation, of the IBM Corporation, of the NYNEX Corporation, or of the Department of Defense. Acknowledgments. Both the OSS macro package and this report have benefited from the assistance of a number of people. In particular, C. Rich, A. Meyer, Y. Feldman, D. Chapman, and P. Anagnostopoulos made suggestions which led to a number of very significant improvements in the clarity and power of obviously synchronizable series expressions. 1. All You Need To Know to Get Started This first section describes everything you need to know to start using the OSS macro package. It then presents a detailed example. Section 2 is a comprehensive reference manual. It describes the functions supported by the OSS macro package in detail. Section 3 contains the bibliography. Section 4 explains the warning and error messages that can be produced by the OSS macro package. Section 5 is both an index into Section 2 and an abbreviated description of the OSS functions. [This section is omitted in the on-line version. Use searching to find individual function descriptions.] A companion paper [6] gives an overview of the theory underlying the OSS macro package. It explains why things are designed the way they are and compares the OSS macro package with other systems that support operations on series. In addition, the companion paper gives a brief description of the algorithms used to implement the OSS macro package. As part of this, it describes a number of subprimitive constructs which are provided for advanced users of the OSS macro package. The OSS data type. A series is an ordered linear sequence of elements. Vectors, lists, and streams are examples of series data types. The advantages (with respect to conciseness, understandability, and modifiability) of expressing algorithms as compositions of functions operating on series, rather than as loops, are well known. Unfortunately, as typically implemented, series expressions are very inefficient---so inefficient, that programmers are forced to use loops whenever efficiency matters. Obviously Synchronizable Series (OSS) is a special series data type that can be implemented extremely efficiently by automatically converting OSS expressions into loops. This allows programmers to gain the benefit of using series expressions without paying any price in efficiency. The OSS macro package adds support for the OSS data type to Common Lisp [4]. The macro package was originally developed under version 7 of the Symbolics Lisp Machine software [7]. However, it is written in standard Common Lisp and should be able to run in any implementation of Common Lisp. (It has been tested in DEC Common Lisp and Sun Common Lisp as well as Symbolics Common Lisp.) The basic functionality provided by the OSS macro package is similar to the functionality provided by the Common Lisp sequence functions. However, in addition to being much more efficient, the OSS macro package is more powerful than the sequence functions, because it includes almost all of the operations supported by APL [3] and by the Loop macro [2]. As a result, OSS expressions go much farther than the sequence functions towards the goal of eliminating the need for explicit loops. Predefined OSS functions. The heart of the OSS macro package is a set of several dozen functions which operate on OSS series. These functions divide naturally into three classes. Enumerators produce series without consuming any. Transducers compute series from series. Reducers consume series without producing any. As a mnemonic device, the name of each predefined OSS function begins with a letter code that indicates the type of operation. These letters are intended to be pronounced as separate syllables. Predefined enumerators include Elist which enumerates successive elements of a list, Evector which enumerates the elements of a vector, and Eup which enumerates the integers in a range. (The notation [...] is used to represent an OSS series.) (Elist '(a b c)) => [a b c] (Evector '#(a b c)) => [a b c] (Eup 1 :to 3) => [1 2 3] Predefined transducers include Tpositions which returns the positions of the non-null elements in a series and Tselect which selects the elements of its second argument which correspond to non-null elements of its first argument. (Tpositions [a nil b c nil nil]) => [0 2 3] (Tselect [nil T T nil] [1 2 3 4]) => [2 3] Predefined reducers include Rlist which combines the elements of a series into a list, Rsum which adds up the elements of a series, Rlength which computes the length of a series, and Rfirst which returns the first element of a series. (Rlist [a b c]) => (a b c) (Rsum [1 2 3]) => 6 (Rlength [a b c]) => 3 (Rfirst [a b c]) => a As simple illustrations of how OSS functions are used, consider the following. (Rsum (Evector '#(1 2 3))) => 6 (Rlist (Tpositions (Elist '(a nil b c nil)))) => (0 2 3) Higher-Order OSS functions. The OSS macro package provides a number of higher-order functions which support general classes of OSS operations. (Each of these functions end in the suffix "F", which is pronounced separately.) For example, enumeration is supported by (EnumerateF init step test). This enumerates an OSS series of elements starting with init by repeatedly applying step. The OSS series consists of the values up to, but not including, the first value for which test is true. Reduction is supported by (ReduceF init function items) which is analogous to the sequence function reduce. The elements of the OSS series items are combined together using function. The quantity init is used as an initial seed value for the accumulation. Mapping is supported by (TmapF function items) which is analogous to the sequence function map. A series is computed by applying function to each element of items. (EnumerateF 3 #'1- #'minusp) => [3 2 1 0] (ReduceF 0 #'+ [1 2 3]) => 6 (TmapF #'sqrt [4 9 16]) => [2 3 4] Implicit mapping. The OSS macro package contains a special mechanism that makes mapping particularly easy. Whenever an ordinary Lisp function is applied to an OSS series, it is automatically mapped over the elements of the OSS series. For example, in the expression below, the function sqrt is mapped over the OSS series of numbers created by Evector. (Rsum (sqrt (Evector '#(4 16)))) == (Rsum (TmapF #'sqrt (Evector '#(4 16)))) => 6 To a considerable extent, implicit mapping is a peripheral part of the OSS macro package---one can always use TmapF instead. However, due to the ubiquitous nature of mapping, implicit mapping is extremely convenient. As illustrated below, its key virtue is that it reduces the number of literal lambda expressions that have to be written. (Rsum (expt (abs (Evector '#(2 -2 3))) 3)) == (Rsum (TmapF #'(lambda (x) (expt (abs x) 3)) (Evector '#(2 -2 3)))) => 43 Creating OSS variables. The OSS macro package provides two forms (letS and letS*) which are analogous to let and let*, except that they make it possible to create variables that can hold OSS series. (The suffix "S", pronounced separately, is used to indicate primitive OSS forms.) As shown in the example below, letS can be used to bind both ordinary variables (e.g., n) and OSS variables (e.g., items). (defun average (v) (letS* ((items (Evector v)) (sum (Rsum items)) (n (Rlength items))) (/ sum n))) (average '#(1 2 3)) => 2 User-defined OSS functions. New OSS functions can be defined by using the form defunS which is analogous to defun. Explicit declarations are required inside defunS to indicate which arguments receive OSS series. The following example shows the definition of an OSS function which computes the product of the numbers in an OSS series. (defunS Rproduct (numbers) (declare (type oss numbers)) (ReduceF 1 #'* numbers)) (Rproduct [2 4 6]) => 48 Restrictions on OSS expressions. As illustrated by the examples above, OSS expressions are constructed in the same way as any other Lisp expression---i.e., OSS functions are composed together in any way desired. However, in order to guarantee that OSS expressions can always be converted into highly efficient loops, a few restrictions have to be followed. These restrictions are summarized in the beginning of Section 2 and discussed in detail in [6]. Here, it is sufficient to note that the OSS macro package is designed so that it is impossible to violate most of the restrictions. The remaining restrictions are checked by the macro package and any violations are automatically fixed. However, warning messages are issued whenever a violation is detected, because, as discussed in the beginning of Section 2, it is often possible for the user to fix a violation in a way which is much more efficient than the automatic fix supplied by the macro package. The best approach for programmers to take is to simply write OSS expressions without worrying about the restrictions. In this regard, it should be noted that simple OSS expressions are very unlikely to violate any of the restrictions. In particular, it is impossible for an OSS expression to violate any of the restrictions unless it contains a variable bound by letS or defunS. When violations do occur, they can either be ignored (since they cannot lead to incorrect results) or dealt with on an individual basis (which is advisable since violations can lead to significant inefficiencies). Benefits. The benefit of OSS expressions is that they retain most of the advantages of functional programming using series, while eliminating the costs. However, given the restrictions alluded to above, the question naturally arises as to whether OSS expressions are applicable in a wide enough range of situations to be of real pragmatic benefit. An informal study [5] was undertaken of the kinds of loops programmers actually write. This study suggests that approximately 80% of the loops programmers write are constructed by combining a few common kinds of looping algorithms. The OSS macro package is designed so that all of these algorithms can be represented as OSS functions. As a result, it appears that approximately 80% of loops can be trivially rewritten as OSS expressions. Many more can be converted to this form with only minor modification. Moreover, the benefits of using OSS expressions go beyond replacing individual loops. A major shift toward using OSS expressions would be a significant change in the way programming is done. At the current time, most programs contain one or more loops and most of the interesting computation in these programs occurs in these loops. This is quite unfortunate, since loops are generally acknowledged to be one of the hardest things to understand in any program. If OSS expressions were used whenever possible, most programs would not contain any loops. This would be a major step forward in conciseness, readability, verifiability, and maintainability. Example The following example shows what it is like to use OSS expressions in a realistic programming context. The example consists of two parts: a pair of functions which convert between sets represented as lists and sets represented as bits packed into an integer and a graph algorithm which uses the integer representation of sets. Bit sets. Small sets can be represented very efficiently as binary integers where each 1 bit in the integer represents an element in the set. Below, sets represented in this fashion are referred to as bit sets. Common Lisp provides a number of bitwise operations on integers which can be used to manipulate bit sets. In particular, logior computes the union of two bit sets while logand computes their intersection. The functions in Figure 1.1 convert between sets represented as lists and bit sets. In order to perform this conversion, a mapping has to be established between bit positions and potential set elements. This mapping is specified by a universe. A universe is a list of elements. If a bit set b is associated with a universe u, then the ith element in u is in the set represented by b iff the ith bit in b is 1. For example, given the universe (a b c d e), the integer #b01011 represents the set {a,b,d}. (By Common Lisp convention, the 0th bit in an integer is the rightmost bit.) Given a bit set and its associated universe, the function bset->list converts the bit set into a set represented as a list of its elements. It does this by enumerating the elements in the universe along with their positions and constructing a list of the elements which correspond to 1s in the integer representing the bit set. (When no :to argument is supplied, Eup counts up forever.) The function list->bset converts a set represented as a list of its elements into a bit set. Its second argument is the universe which is to be associated with the bit set created. For each element of the list, the function bit-position is called in order to determine which bit position should be set to 1. The function ash is used to create an integer with the correct bit set to 1. The function ReduceF is used to combine the integers corresponding to the individual elements together into a bit set corresponding to the list. The function bit-position takes an item and a universe and returns the bit position corresponding to the item. The function operates in one of two ways depending on whether or not the item is in the universe. The first line of the function contains an OSS expression which determines the position of the item in the universe. If the item is not in the universe, the expression returns nil. (The function Rfirst returns nil if it is passed a series of length zero.) If the item is not in the universe, the second line of the function adds the item onto the end of the universe and returns its position. The extension of the universe is done be side-effect so that it will be permanently recorded in the universe. (defun bset->list (bset universe) (Rlist (Tselect (logbitp (Eup 0) bset) (Elist universe)))) (defun list->bset (list universe) (ReduceF 0 #'logior (ash 1 (bit-position (Elist list) universe)))) (defun bit-position (item universe) (or (Rfirst (Tpositions (eq item (Elist universe)))) (1- (length (nconc universe (list item)))))) (Figure 1.1: Converting between lists and bit sets.) Figure 1.2 shows the definition of two OSS reducers which operate on OSS series of bit sets. The first function computes the union of a series of bit sets, while the second computes their intersection. (defunS Rlogior (bsets) (declare (type oss bsets)) (ReduceF 0 #'logior bsets)) (defunS Rlogand (bsets) (declare (type oss bsets)) (ReduceF -1 #'logand bsets)) (Figure 1.2: Operations on OSS series of bit sets.) Live variable analysis. As an illustration of the way bit sets might be used, consider the following. Suppose that in a compiler, program code is being represented as blocks of straight-line code connected by possibly cyclic control flow. The top part of Figure 1.3 shows the data structure which represents a block of code. Each block has several pieces of information associated with it. Two of these pieces of information are the blocks that can branch to the block in question and the blocks it can branch to. A program is represented as a list of blocks that point to each other through these fields. In addition to control flow information, each structure contains information about the way variables are accessed. In particular, it records the variables that are written by the block and the variables that are used by the block (i.e., either read without being written or read before they are written). An additional field (computed by the function determine-live discussed below) records the variables which are live at the end of the block. (A variable is live if it has to be saved, because it can potentially be used by a following block.) Finally, there is a temporary data field which is used by functions (such as determine-live) which perform computations involved with the blocks. The remainder of Figure 1.3 shows the function determine-live which, given a program represented as a list of blocks, determines the variables which are live in each block. To perform this computation efficiently, the function uses bit sets. The function operates in three steps. The first step (convert-to-bsets) looks at each block and sets up an auxiliary data structure containing bit set representations for the written variables, the used variables, and an initial guess that there are no live variables. This auxiliary structure is defined by the third form in Figure 1.3 and is stored in the temp field of the block. The integer 0 represents an empty bit set. The second step (perform-relaxation) determines which variables are live. This is done by relaxation. The initial guess that there are no live variables in any block is successively improved until the correct answer is obtained. The third step (convert-from-bsets) operates in the reverse of the first step. Each block is inspected and the bit set representation of the live variables is converted into a list which is stored in the live field of the block. (defstruct (block (:conc-name nil)) predecessors ;Blocks that can branch to this one. successors ;Blocks this one can branch to. written ;Variables written in the block. used ;Variables read before written in the block. live ;Variables that must be available at exit. temp) ;Temporary storage location. (defun determine-live (program-graph) (let ((universe (list nil))) (convert-to-bsets program-graph universe) (perform-relaxation program-graph) (convert-from-bsets program-graph universe)) program-graph) (defstruct (temp-bsets (:conc-name bset-)) used written live) (defun convert-to-bsets (program-graph universe) (letS ((block (Elist program-graph))) (setf (temp block) (make-temp-bsets :used (list->bset (used block) universe) :written (list->bset (written block) universe) :live 0)))) (defun perform-relaxation (program-graph) (let ((to-do program-graph)) (loop (when (null to-do) (return (values))) (let* ((block (pop to-do)) (estimate (live-estimate block))) (when (not (= estimate (bset-live (temp block)))) (setf (bset-live (temp block)) estimate) (letS ((prev (Elist (predecessors block)))) (pushnew prev to-do))))))) (defun live-estimate (block) (letS ((next (temp (Elist (successors block))))) (Rlogior (logior (bset-used next) (logandc2 (bset-live next) (bset-written next)))))) (defun convert-from-bsets (program-graph universe) (letS ((block (Elist program-graph))) (setf (live block) (bset->list (bset-live (temp block)) universe)) (setf (temp block) nil))) (Figure 1.3: Live variable analysis.) On each cycle of the loop in perform-relaxation, a block is examined to determine whether its live set has to be changed. To do this (see the function live-estimate), the successors of the block are inspected. Each successor needs to have available to it the variables it uses, plus the variables that are supposed to be live after it, minus the variables it writes. (The function logandc2 takes the difference of two bit sets.) A new estimate of the total set of variables needed by the successors as a group is computed by using Rlogior. If this new estimate is different from the current estimate of what variables are live, then the estimate is changed. In addition, if the estimate is changed, perform-relaxation has to make sure that all of the predecessors of the current block will be examined to see if the new estimate for the current block requires their live estimates to be changed. This is done by adding each predecessor onto the list to-do unless it is already there. As soon as the estimates of liveness stop changing, the computation can stop. Summary. The function determine-live is a particularly good example of the way OSS expressions are intended to be used in two ways. First, OSS expressions are used in a number of places to express computations which would otherwise be expressed less clearly as loops or less efficiently as sequence function expressions. Second, the main relaxation algorithm is expressed as a loop. This is done, because neither OSS expressions (nor Common Lisp sequence function expressions) lend themselves to expressing the relaxation algorithm. This highlights the fact that OSS expressions are not intended to render loops entirely obsolete, but rather to provide a greatly improved method for expressing the vast majority of loops. 2. Reference Manual This section is organized around descriptions of the various functions and forms supported by the OSS macro package. Each description begins with a header which shows the arguments and results of the function or form being described. For ease of reference, the headers are duplicated in Section 5. In Section 5, the headers are in alphabetical order and show the page where the function or form is described. In a reference manual like this one, it is advantageous to describe each construct separately and completely. However, this inevitably leads to presentation problems, because everything is related to everything else. Therefore, one cannot avoid referring to things which have not been discussed. The reader is encouraged to skip around in the document and to realize that more than one reading will probably be necessary in order to gain a complete understanding of the OSS macro package. Although the following list of OSS functions is large, it should not be taken as complete. Every effort has been made to provide a wide range of useful predefined functions. However, except for a few primitive forms, all of these functions could have been defined by the user. It is hoped that users will write many more such functions. A key reason for presenting a wide array of predefined functions is to inspire users with thoughts of the wide variety of functions they can write for themselves. Restrictions and Definitions of Terms. As alluded to in Section 1, there are a number of restrictions which OSS expressions have to obey. The OSS macro package is designed so that all but three of these restrictions are impossible to violate with the facilities provided. As a result, the programmer need not think about these restrictions at all. The OSS macro package checks to see that the remaining three restrictions are obeyed on an expression by expression basis and automatically fixes any violations which are detected. However, the automatic fixes are often not very efficient. As a result, it is advisable for the user to fix such violations explicitly. Given that simple OSS expressions are very unlikely to violate any of the restrictions, and any violations which do occur are automatically fixed, it is reasonable for the reader to skip this section when first reading this manual. However, it is useful to read this section before trying to write complex OSS expressions. The discussion below starts by defining two key terms (on-line functions and early termination) which are used to categorize the OSS functions described in the rest of this manual. The discussion then continues by briefly describing the three restrictions which can be violated. (See [6] for a complete discussion of all the restrictions.) On-line and off-line. Suppose that f is an OSS function which reads one or more series inputs and writes one or more series outputs. The function f is on-line [1] if it operates in the following fashion. First, f reads in the first element of each input series, then it writes out the first element of each output series, then it reads in the second element of each input series, then it writes out the second element of each output series, and so on. In addition, f must immediately terminate as soon as any input runs out of elements. If an f is not on-line, then it is off-line. In the context of OSS expressions, the term on-line is generalized so that it applies to individual OSS input and output ports in addition to whole functions. An OSS port is on-line iff the processing at that port always follows the rigidly synchronized pattern described above. Otherwise, it is off-line. From this point of view, a function is on-line iff all of its OSS ports are on-line. The prototypical example of an on-line OSS function is TmapF (which maps a function over a series). Each time it reads an input element it applies the mapped function to it and writes an output element. In contrast, the function Tremove-duplicates (which removes the duplicate elements from a series) is not on-line. Since some of the input elements do not become output elements, it is not possible for Tremove-duplicates to write an output element every time it reads an input element. For every OSS function, the documentation below specifies which ports are on-line and which are off-line. In this regard, it is interesting to note that every function which has only one OSS port (e.g., enumerators with only one output and reducers with only one input) are trivially on-line. The only OSS functions which have off-line ports are transducers. Early termination. An important feature of OSS functions is the situations under which they terminate. The definition of on-line above requires that on-line functions must terminate as soon as any series input runs out of elements. If an OSS function can terminate before any of its inputs are exhausted, then it is an early terminator. The degenerate case of functions which do not have any series inputs (i.e., enumerators) is categorized by saying that enumerators are early terminators iff they can terminate. As an example of an early terminator, consider the function TuntilF (which reads a series and returns all of the elements of that series up to, but not including, the first element which satisfies a given predicate). This function is an early terminator, because it can terminate before the input runs out of elements. The documentation below specifies which functions are early terminators. Besides enumerators, their are only 7 OSS functions which are early terminators. Isolation. A data flow arc delta in an OSS expression X is isolated iff it is possible to partition the functions in X into two parts Y and Y' in such a way that: delta goes from Y to Y', there is no OSS data flow from Y to Y', and there is no data flow from Y' to Y. For example, consider the OSS expression (letS ((x (f y))) (i (h x (g x)))) which corresponds to the graph in Figure 2.1. [Not shown in this textual version of the memo. See the printed version.] The data flow arc delta4 is isolated. To show this, one merely has to partition the expression so that f, g, and h are on one side and i is on the other. The question of whether or not the other data flow arcs are isolated is more complicated to answer. If delta3 crosses a partition, then delta1 must cross this partition as well. As a result, delta3 is isolated iff delta1 carries a non-OSS value. (This is true no matter what kind of value passes over delta3 itself.) In a related situation, delta2 is isolated iff (it and therefore delta1) carries a non-OSS value. Finally, consider the arc delta1. Here there are two potential partitions to consider: one which cuts delta2 and one which cuts delta3. The data flow arc delta1 is isolated iff either it (and therefore delta2) or delta3 carries a non-OSS value. The concept of isolation is extended to inputs and outputs as follows. An output p in an expression X is isolated iff X can be partitioned into two parts Y and Y' such that: every data flow originating on p goes from Y to Y', every other data flow from Y to Y' is a non-OSS data flow, and there is no data flow from Y' to Yf. An input q in an expression X is isolated iff X can be partitioned into two parts Y and Y' such that: the data flow terminating on q goes from Y to Y', every other data flow from Y to Y' is a non-OSS data flow, and there is no data flow from Y' to Y. For example, in Figure 2.1, the outputs of f and h are isolated as is the input of i. The input and output of g are isolated iff f computes a non-OSS value. The inputs of h are isolated iff the data flow arcs terminating on them are isolated. Non-OSS data flows must be isolated. In order for an OSS expression to be reliably converted into a highly efficient loop, every non-OSS data flow in it must be isolated. As an example of an expression where this is not true, consider the following. In this expression, the data flow implemented by the variable total is not isolated. (letS* ((nums (Evector '#(3 2 8))) ;Signals warning 16 (total (ReduceF 0 #'+ nums))) (Rvector (/ nums total))) => #(3/13 2/13 8/13) (The basic problem here is that while the elements created by Evector are being used to compute total, they all have to be saved so that they can be used again later in order to perform the indicated divisions. Eliminating the need for such storage is the key source of efficiency underlying OSS expressions.) Off-line OSS ports must be isolated. In order for an OSS expression to be reliably converted into a highly efficient loop, every off-line port must be isolated. As an example of an expression which has an off-line output which is not isolated, consider the following. In this expression, the data flow implemented by the variable positions is not isolated. (letS* ((keys (Elist list)) ;Signals warning 17.1 (positions (Tpositions keys))) (Rlist (list positions keys))) (The basic problem here is that since Tpositions skips null elements of the input, Tpositions sometimes has to read several input elements before it can produce the next output element. This forces an unpredictable number of elements of keys to be saved so that they can be used later when creating lists. As above, eliminating the need for such storage is the main goal of OSS expressions.) Code copying. If an OSS expression violates either of the above restrictions, the OSS macro packaged automatically fixes the problem by copying code until the data flow or port in question becomes isolated. For instance, the example above of an OSS expression in which a non-OSS data flow is not isolated is fixed as follows. (letS* ((nums (Evector '#(3 2 8))) (total (ReduceF 0 #'+ (Evector '#(3 2 8))))) (Rvector (/ nums total))) => #(3/13 2/13 8/13) Even though the problem has been automatically fixed, the OSS macro package issues a warning message. This is done for two reasons. First, if side-effects (e.g., input or output) are involved, the code copying that was performed may not be correctness preserving. Second, large amounts of code sometimes have to be copied and that can introduce large amounts of extra computation. A major goal of OSS expressions is ensuring that expressions which look simple to compute actually are simple to compute. Automatically introducing large amounts of additional computation without the programmer's knowledge would violate this goal. At the very least, issuing warning messages makes programmers aware of what is expensive to compute and what is not. Looked at from a more positive perspective, it encourages them to think of ways to compute what they want without code copying being required. For instance, consider the example above of an OSS expression in which an off-line port is not isolated. It might be the case that the programmer knows that list does not contain any null elements and that Tpositions is therefore merely being used to enumerate what the positions of the elements are. In this situation, the expression can be fixed as follows, which does not require any code copying. (The key insight here is that the positions do not actually depend on the values in the list.) (let ((list '(a b c))) (letS* ((keys (Elist list)) (positions (Eup 0))) (Rlist (list positions keys)))) => ((0 a) (1 b) (2 c)) (It is interesting to note that if an expression is a tree (as opposed to a graph as in Figure 2.1), then every data flow arc and every port is isolated. This is why OSS expressions which do not contain variables bound by letS, lambdaS, or defunS cannot violated either of the isolation restrictions. This is also why code copying can always fix any violation---code copying can convert any graph into a tree.) On-line subexpressions. The two isolation restrictions above permit a divide and conquer approach to the processing of OSS expressions. If an OSS expression obeys the isolation restrictions, then it can be repeatedly partitioned until all of the data flow in each subexpression goes from an on-line output to an on-line input. The subexpressions which remain after partitioning are referred to as on-line subexpressions. Termination points. The functions in each on-line subexpression can be divided into two classes: those which are termination points and those which are not. A function is a termination point if it can terminate before any other function in the subexpression terminates. There are two reasons for functions being termination points. Functions which are early terminators are always termination points. In addition, any function which reads an OSS series which comes from a different on-line subexpression is a termination point. Data flow paths between termination points and outputs. In order for an OSS expression to be reliably converted into a highly efficient loop, it must be the case that within each on-line subexpression, there is a data flow path from each termination point to each output. As an example of an OSS expression for which this property does not hold, consider the following. Partitioning divides this expression into two on-line subexpressions, one containing list and one containing everything else. In the large on-line subexpression, the two instances of Evector are termination points. The program violates the property above, because there is no data flow path from the termination point (Evector weight-vector) to the output of (Rvector squares). (defun weighted-squares (value-vector weight-vector) (letS* ((values (Evector value-vector)) ;Signals warning 18 (weights (Evector weight-vector)) (squares (* values values)) (weighted-squares (* squares weights))) (list (Rvector squares) (Rvector weighted-squares)))) (weighted-squares #(1 2 3) #(2 3 4)) => (#(1 4 9) #(2 12 36)) (weighted-squares #(1 2) #(2 3 4)) => (#(1 4) #(2 12)) (weighted-squares #(1 2 3) #(2 3)) => (#(1 4 9) #(2 12)) (The basic problem here is that if the number of elements in value-vector is greater than the number of elements in weight-vector, the computation of squares has to continue even after the computation of weighted-squares has been completed. This kind of partial continuing evaluation in a single on-line subexpression is not supported by the OSS macro package, because it was judged that it requires too much overhead in order to control what gets evaluated when.) When an OSS expression violates the restriction above, the violation is automatically fixed by applying code copying. It is impossible for an on-line subexpression to violate the restriction unless it computes two different outputs. Code copying can always be used to break the subexpression in question into two parts each of which computes one of the outputs. Unfortunately, this can require a great deal of code to be copied. There are two basic approaches which can be used to fix a violation much more efficiently: reducing the number of termination points and increasing the connectivity between termination points and outputs. The easiest way to decrease the number of termination points is to replace early terminators by equivalent operations which are not early terminators. If an early terminator is not an enumerator, then this can always be done without difficultly. (The documentation below describes a non-early variant for each early terminating transducer and reducer.) If multiple enumerators are the problem (as in the example above) decreasing the number of termination points is usually not practical. However, sometimes an enumerator which terminates can be replaced by an enumerator which never terminates. The connectivity between termination points and outputs can be increased by using the function Tcotruncate. This is the preferred way to fix the problem in the example above. General Information Before discussing the individual OSS functions in detail, a few general comments are in order. First, all of the OSS functions and forms are defined in the package OSS. To make these names easily accessible, use the package OSS (i.e., evaluate (use-package "OSS")). If this is not done, the names will have to be prefixed with "oss:" when they are used. Naming conventions. The names of the various OSS functions and forms follow a strict naming convention. The first letter of an OSS function name indicates the type of function as shown below. The letter codes are written in upper case in this document (case does not matter to Common Lisp) and each letter is intended to be pronounced as a separate syllable. E Enumerator. T Transducer. R Reducer. The last letter of each OSS special form is "S". In general, this indicates that the form is primitive in the sense that it could not be defined by the user. Some OSS functions end in the letter "F". This is used to indicate that the function is a higher-order function which takes functions as arguments. The naming convention has two advantages: one trivial but vital and the other more fundamentally useful. First, many of the OSS functions are very similar to standard Common Lisp sequence functions. As a result, it makes sense to give them similar names. However, it is not possible to give them exactly the same names without redefining the standard functions. The naming convention allows the names to be closely related in a predictable way without making the names unreasonably long. Second, the naming convention highlights several properties of OSS functions which make it easier to read and understand OSS expressions. In particular, the prefixes highlight the places where series are created and consumed. The names of arguments and results of OSS functions are also chosen following naming conventions. First, all of the names are chosen in an attempt to indicate type restrictions (e.g., number indicates that an argument must be a number; item indicates that there is no type restriction). Plural names are used iff the value in question is an OSS series (e.g., numbers indicates an OSS series of numbers; items indicates an OSS series of unrestricted values). The name of a series input or output begins with "O" iff it is off-line. OSS series. Two general points about OSS series are worthy of note. First, like Common Lisp sequences, OSS series use zero-based indexing (i.e., the first element is the 0th element). Second, unlike Common Lisp sequences, OSS series can be unbounded in length. Tutorial mode. A prominent feature of the various descriptions is that they contain many examples. These examples contain large numbers of OSS series as inputs and outputs. In the interest of brevity, the notation [...] is used to indicate a literal OSS series. If the last entry in a literal OSS series is an ellipsis, this indicates that the OSS series is unbounded in length. [1 2 3] [a b (c d)] [T nil T nil ...] The notation [...] is not supported by the OSS macro package. It would be straightforward to do so by using set-macro-character. Perhaps even better, one could use set-dispatch-macro-character to support a notation #[...] analogous to #(...). However, although literal series are very useful in the examples below, experience suggests that literal series are seldom useful when writing actual programs. Inasmuch as this is the case, it was decided that it was unwise to use up one of the small set of characters which are available for user-defined reader macros or user-defined # dispatch characters. Many of the examples show OSS expressions returning OSS series as their values. However, one should not take this literally. If these examples are typed to Common Lisp as isolated expressions, they will not return any values. This is so, because the OSS macro package does not allow complete OSS expressions to return OSS series. The examples are intended to show what would be returned if the example expressions were nested in larger expressions. oss-tutorial-mode &optional (T-or-nil T) => state-of-tutorial-mode The above not withstanding, the OSS macro package provides a special tutorial mode in which the notation [...] is supported and OSS expressions can return (potentially unbounded) OSS values. However, these values still cannot be stored in ordinary variables. This mode is entered by calling the function oss-tutorial-mode with an argument of T. Calling the function with an argument of nil turns tutorial mode off. Using tutorial mode, it is possible to directly duplicate the examples shown below. However, tutorial mode is very inefficient. What is worse, tutorial mode introduces non-correctness-preserving changes in OSS expressions. (For example, in order to correctly duplicate the examples that illustrate error messages about non-terminating expressions and the fact that OSS series are not actually returned by complete OSS expressions, tutorial mode must be turned off.) All in all, it is important that tutorial mode not be used as anything other than an educational aid. OSS functions are actually macros. Every OSS function is actually a macro. As a result, OSS functions cannot be funcall'ed, or apply'ed. When the user defines new OSS functions, they must be defined before the first time they are used. Also, when an OSS function takes keyword arguments, the keywords must be literals. They cannot be expressions which evaluate to keywords at run time. Finally, the macro expansion processing associated with OSS expressions is relatively time consuming. In order to avoid this overhead during the running of a user program, it is important that programs containing OSS expressions be compiled rather than run interpretively. A minor advantage of the fact that everything in the OSS macro package is a macro is that once a program which uses the macro package is compiled, the compiled program can subsequently be run without having to load the OSS macro package. A more important advantage of the fact that everything in the OSS macro package is a macro is that quoted macro names can be used as functional arguments to higher-order OSS functions. (In contrast, quoted macro names cannot be used as functional arguments to higher-order Common Lisp functions such as reduce.) Although this may appear to be a minor benefit, it is actually quite useful. Enumerators Enumerators create OSS outputs based on non-OSS inputs. There are two basic kinds of enumerators: ones that create an OSS series based on some formula (e.g., enumerating a sequence of integers) and ones that create an OSS series containing the elements of an aggregate data structure (e.g., enumerating the elements of a list). All the predefined enumerators are on-line. In general, they are all early terminators. However, as noted below, in some situations, some enumerators produce unbounded outputs and are not early terminators. Eoss &rest expr-list => items The expr-list consists of zero or more expressions. The function Eoss creates an OSS series containing the values of these expressions. Every expression in expr-list is evaluated before the first output element is returned. (Eoss 1 'a 'b) => [1 a b] (Eoss) => [] To get the effect of delaying the evaluation of individual elements until they are needed, it is necessary to define a special purpose enumerator which computes the individual items as needed. However, due to the control overhead required, this is seldom worthwhile. It is possible for the expr-list to contain an instance of :R. (This must be a literal instance of :R, not an expression which evaluates to :R.) If this is the case, then Eoss produces an unbounded OSS series analogous to a repeating decimal number. The output consists of the values of the expressions preceding the :R followed by an unbounded number of repetitions of the values following the :R, if there are any such values. (In this situation, Eoss is not an early terminator.) (Eoss 1 'a :R 'b 'c) => [1 a b c b c b c ...] (Eoss T :R nil) => [T nil nil nil ...] (Eoss 1 :R) => [1] (Eoss :R 1) => [1 1 1 ...] Eup &optional (start 0) &key (:by 1) :to :below :length => numbers This function is analogous to the Loop macro [2] numeric iteration clause. It creates an OSS series of numbers starting with start and counting up by :by. The argument start is optional and defaults to integer 0. The keyword argument :by must always be a positive number and defaults to integer 1. There are four kinds of end tests. If :to is specified, stepping stops at this number. The number :to will be included in the OSS series iff (- :to start) is a multiple of :by. If :below is specified, things operate exactly as if :to were specified except that the number :below is never included in the OSS series. If :length is specified, the OSS series has length :length. It must be the case that :length is a non-negative integer. If :length is positive, the last element of the OSS series will be (+ start (* :by (1- :length))). If none of the termination arguments are specified, the output has unbounded length. (In this situation, Eup is not an early terminator.) If more than one termination argument is specified, it is an error. (Eup :to 4) => [0 1 2 3 4] (Eup :to 4 :by 3) => [0 3] (Eup 1 :below 4) => [1 2 3] (Eup 4 :length 3) => [4 5 6] (Eup) => [0 1 2 3 4 ...] As shown in the following example, Eup does not assume that the numbers being enumerated are integers. (Eup 1.5 :by .1 :length 3) => [1.5 1.6 1.7] Edown &optional (start 0) &key (:by 1) :to :above :length => numbers The function Edown is analogous to Eup, except that it counts down instead of up and uses the keyword :above instead of :below. (Edown :to -4) => [0 -1 -2 -3 -4] (Edown :to -4 :by 3) => [0 -3] (Edown 1 :above -4) => [1 0 -1 -2 -3] (Edown 4 :length 3) => [4 3 2] (Edown) => [0 -1 -2 -3 -4 ...] (Edown -1.5 :by .1 :length 3) => [-1.5 -1.6 -1.7] Esublists list &optional (end-test #'endp) => sublists This function creates an OSS series containing the successive sublists of list. The end-test must be a function from objects to boolean values (i.e., to null/non-null). It is used to determine when to stop the enumeration. Successive cdrs are returned up to, but not including, the first one for which end-test returns non-null. (Esublists '(a b c)) => [(a b c) (b c) (c)] (Esublists '(a b . c) #'atom) => [(a b . c) (b . c)] The default end-test (#'endp) will cause Esublists to blow up if list contains a non-list cdr. More robust enumeration can be obtained by using the end-test #'atom as in the second example above. The assumption that list will end with nil is used as the default case, because the assumption sometimes allows programming errors to be detected closer to their sources. Elist list &optional (end-test #'endp) => elements This function creates an OSS series containing the successive elements of list. It is closely analogous to Esublists as shown below. In particular, end-test has the same meaning and the same caveats apply. (Elist '(a b c)) => [a b c] (Elist '()) => [] (Elist '(a b . c) #'atom) => [a b] (Elist list) == (car (Esublists list)) The value returned by Elist can be used as a destination for alterS. (let ((list '(a b c))) (alterS (Elist (cdr list)) (Eup)) list) => (a 0 1) Ealist alist &optional (test #'eql) => keys values This function returns two OSS series containing keys and their associated values. The first element of keys is the key in the first entry in alist, the first element of values is the value in the first entry, and so on. The alist must be a proper list ending in nil and each entry in alist must be a cons cell or nil. Like assoc, Ealist skips entries which are nil and entries which have the same key as an earlier entry. The test argument is used to determine when two keys are the same. (Ealist '((a . 1) () (a . 3) (b . 2))) => [a b] [1 2] (Ealist nil) => [] [] Both of the series returned by Ealist can be used as destinations for alterS. (In analogy with multiple-value-bind, letS can be used to bind both values returned by Ealist.) (let ((alist '((a . 1) (b . 2)))) (letS (((key val) (Ealist alist))) (alterS key (list key)) (alterS val (1+ val))) alist) => '(((a) . 2) ((b) . 3)) The OSS function Ealist is forced to perform a significant amount of computation in order to check that no duplicate keys or null entries are being enumerated. In a situation where it is known that no duplicate keys or null entries exist, it is much more efficient to use Elist as shown below. (letS* ((e (Elist '((a . 1) (b . 2)))) (keys (car e)) (values (cdr e))) (Rlist (list keys values))) => ((a 1) (b 2)) Eplist plist => indicators values This function returns two OSS series containing indicators and their associated values. The first element of indicators is the first indicator in the plist, the first element of values is the associated value, and so on. The plist argument must be a proper list of even length ending in nil. In analogy with the way get works, if an indicator appears more than once in plist, it (and its value) will only be enumerated the first time it appears. (Both of the OSS series returned by Eplist can be used as destinations for alterS.) (Eplist '(a 1 a 3 b 2)) => [a b] [1 2] (Eplist nil) => [] [] The OSS function Eplist has to perform a significant amount of computation in order to check that no duplicate indicators are being enumerated. In a situation where it is known that no duplicate indicators exist, it is much more efficient to use EnumerateF as shown below. (letS* ((e (EnumerateF '(a 1 b 2) #'cddr #'null)) (indicators (car e)) (values (cadr e))) (Rlist (list indicators values))) => ((a b) (1 2)) Etree tree &optional (leaf-test #'atom) => nodes This function creates an OSS series containing all of the nodes in tree. The function assumes that tree is a tree built of lists, where each node is a list and the elements in the list are the children of the node. The function Etree does not assume that the node lists end in nil; however, it ignores any non-list cdrs. (This behavior increases the utility of Etree when it is used to scan Lisp code.) The nodes in the tree are enumerated in preorder (i.e., first the root is output, then the nodes in the tree which is the first child of the root is enumerated in full, then the nodes in the tree which is the second child of the root is enumerated in full, etc.). The leaf-test is used to decide which elements of the tree are leaves as opposed to internal nodes. Failure of the test should guarantee that the element is a list. By default, leaf-test is #'atom. This choice of test categorizes nil as a leaf rather than as a node with no children. The function Etree assumes that tree is a tree as opposed to a graph. If tree is a graph instead of a tree (i.e. some node has more than one parent), then this node (and its descendants) will be enumerated more than once. If the tree is a cyclic graph, then the output series will be unbounded in length. (Etree 'd) => [d] (Etree '((c) d)) => [((c) d) (c) c d] (Etree '((c) d) #'(lambda (e) (or (atom e) (atom (car e))))) => [((c) d) (c) d] Efringe tree &optional (leaf-test #'atom) => leaves This enumerator is the same as Etree except that it only enumerates the leaves of the tree, skipping all internal nodes. The logical relationship between Efringe and Etree is shown in the first example below. However, Efringe is implemented more efficiently than this example would indicate. (Efringe tree) == (TselectF #'atom (Etree tree)) (Efringe 'd) => [d] (Efringe '((c) d)) => [c d] (Efringe '((c) d) #'(lambda (e) (or (atom e) (atom (car e))))) => [(c) d] The value returned by Efringe can be used as a destination for alterS. However, if the entire tree is a leaf and gets altered, this will have no side-effect on the tree as a whole. In addition, altering a leaf will have no effect on the leaves enumerated. In particular, if a leaf is altered into a subtree, the leaves of this subtree will not get enumerated. (let ((tree '((3) 4))) (letS ((leaf (Efringe tree))) (if (evenp leaf) (alterS leaf (- leaf)))) tree) => ((3) -4) Evector vector &optional (indices (Eup)) => elements This function creates an OSS series of the elements of a one-dimensional array. If indices assumes its default value, Evector enumerates all of the elements of vector in order. (Evector "BAR") => [#\B #\A #\R] (Evector "") => [] Looked at in greater detail, Evector enumerates the elements of vector which are indicated by the elements of the OSS series indices. The indices must be non-negative integers, however, they do not have to be in order. Enumeration stops when indices runs out, or an index greater than or equal to the length of vector is encountered. One can use Eup to create an index series which picks out a section of vector. (Since Evector takes in an OSS series it is technically a transducer, however, it is on-line and is an enumerator in spirit.) (Evector '#(b a r) (Eup 1 :to 2)) => [a r] (Evector "BAR" [0 2 1 1 4 1]) => [#\B #\R #\A #\A] The value returned by Evector can be used as a destination for alterS. (let ((v "FOOBAR")) (alterS (Evector v (Eup 2 :to 4)) #\-) v) => "FO---R" Esequence sequence &optional (indices (Eup)) => elements The function Esequence is the same as Evector except that it will work on any Common Lisp sequence. However, since it has to determine the type of sequence at run-time, it is much less efficient than either Elist or Evector. (The value returned by Esequence can be used as a destination for alterS.) (Esequence '(b a r)) => [b a r] (Esequence '#(b a r)) => [b a r] Ehash table => keys values This function returns two OSS series containing keys and their associated values. The first element of keys is the key of the first entry, the first element of values is the value in the first entry, and so on. (There are no guarantees as to the order in which entries will be enumerated.) (Ehash (let ((h (make-hash-table))) (setf (gethash 'color h) 'brown) (setf (gethash 'name h) 'fred) h)) => [color name] [brown fred] ;in some order In the pure Common Lisp version of the OSS macro package, Ehash is rather inefficient, because Common Lisp does not provide incremental support for scanning the elements of a hash table. However, in the Symbolics Common Lisp version of the OSS macro package, Ehash is quite efficient. Esymbols &optional (package *package*) => symbols This function creates an OSS series of the symbols in package (which defaults to the current package). (There are no guarantees as to the order in which symbols will be enumerated.) (Esymbols) => [foo bar baz ... zot] ;in some order In the pure Common Lisp version of the OSS macro package, Esymbols is rather inefficient, because Common Lisp does not provide incremental support for scanning the symbols in a package. However, in the Symbolics Common Lisp version of the OSS macro package, Esymbols is quite efficient. Efile name => items This function creates an OSS series of the items written in the file named name. The function combines the functionality of with-open-file with the action of reading from the file (using read). It is guaranteed that the file will be closed correctly, even if an error occurs. As an example of using Efile, assume that the forms (a), (1 2), and T have been written into the file "test.lisp". (Efile "test.lisp") => [(a) (1 2) T] EnumerateF init step &optional test => items The higher-order function EnumerateF is used to create new kinds of enumerators. The init must be a value of some type T1. The step argument must be a non-OSS function from T1 to T1. The test argument (if present) must be a non-OSS function from T1 to boolean. Suppose that the series returned by EnumerateF is S. The first output element S_0 has the value S_0=init. For subsequent elements, S_i=step(S_i-1). If the test is present, the output consists of elements up to, but not including, the first element for which test(S_i) is true. In addition, it is guaranteed that step will not be applied to the element for which test is true. If there is no test, then the output series will be of unbounded length. (In this situation, EnumerateF is not an early terminator.) (EnumerateF '(a b c d) #'cddr #'null) => [(a b c d) (c d)] (EnumerateF '(a b c d) #'cddr) => [(a b c d) (c d) nil nil ...] (EnumerateF list #'cdr #'null) == (Esublists list) If there is no test, then each time an element is output, the function step is applied to it. Therefore, it is important that other factors in an expression cause termination before EnumerateF computes an element which step cannot be applied to. In this regard, it is interesting that the following equivalence is almost, but not quite true. The difference is that including the test argument in the call on EnumerateF guarantees that step will not be applied to the element which fails test, while the expression using TuntilF guarantees that it will. (TuntilF test (EnumerateF init step)) not= (EnumerateF init step test) Enumerate-inclusiveF init step test => items The higher-order function Enumerate-inclusiveF is the same as EnumerateF except that the first element for which test is true is included in the output. As with EnumerateF, it is guaranteed that step will not be applied to the element for which test is true. (Enumerate-inclusiveF '(a b) #'cddr #'null) => [(a b) ()] On-Line Transducers Transducers compute OSS series from OSS series and form the heart of most OSS expressions. This section and the next one present the predefined transducers that are on-line (i.e., all of their inputs and outputs are on-line). These transducers are singled out because they can be used more flexibly than the transducers which are off-line. In particular, it is impossible to violate the off-line port isolation restriction without using an off-line transducer. Tprevious items &optional (default nil) (amount 1) => shifted-items This function creates a series which is shifted right amount elements. The input amount must be a positive integer. The shifting is done by inserting amount copies of default before items and discarding amount elements from the end of items. The output is always the same length as the input. (Tprevious [a b c]) => [nil a b] (Tprevious [a b c] 'z) => [z a b] (Tprevious [a b c] 'z 2) => [z z a] (Tprevious []) => [] The word previous is used as the root for the name of this function, because the function is typically used to access previous values of a series. An example of Tprevious used in this way is shown in conjunction with Tuntil below. To insert some amount of stuff in front of a series without losing any of the elements off the end, use Tconcatenate as shown below. (Tconcatenate [z z] [a b c]) => [z z a b c] Tlatch items &key :after :before :pre :post => masked-items This function acts like a latch electronic circuit component. Each input element causes the creation of a corresponding output element. After a specified number of non-null input elements have been encountered, the latch is triggered and the output mode is permanently changed. The :after and :before arguments specify the latch point. The latch point is just after the :after-th non-null element in items or just before the :before-th non-null element. If neither :after nor :before is specified, an :after of 1 is assumed. If both are specified, it is an error. If a :pre is specified, every element prior to the latch point is replaced by this value. If a :post is specified, this value is used to replace every element after the latch point. If neither is specified, a :post of nil is assumed. (Tlatch [nil c nil d e]) => [nil c nil nil nil] (Tlatch [nil c nil d e] :before 2 :post T) => [nil c nil T T] (Tlatch [nil c nil d e] :before 2 :pre 'z) => [z z z d e] As a more realistic example of using Tlatch, suppose that a programmer wants to write a program get-codes which takes in a list and returns a list of all of the numbers which appear in the list after the second number in the list. (defun get-codes (list) (letS ((elements (Elist list))) (Rlist (Tselect (Tlatch (numberp elements) :after 2 :pre nil) elements)))) (get-codes '(a b 3 4 c d 5 e 6 f)) => (5 6) Tuntil bools items => initial-items This function truncates an OSS series of elements based on an OSS series of boolean values. The output consists of all of the elements of items up to, but not including, the first element which corresponds to a non-null element of bools. That is to say, if the first non-null value in bools is the mth, the output will consist of all of the elements of items up to, but not including, the mth. (The effect of including the mth element in the output can be obtained by using Tprevious as shown in the last example below.) In addition, the output terminates as soon as either input runs out of elements even if a non-null element of bools has not been encountered. (Tuntil [nil nil T nil T] [1 2 -3 4 -5]) => [1 2] (Tuntil [nil nil T nil T] [1]) => [1] (Tuntil (Eoss :R nil) (Eup)) => [0 1 2 ...] (Tuntil [nil nil T nil T] (Eup)) => [0 1] (letS ((x [1 2 -3 4 -5])) (Tuntil (minusp x) x)) => [1 2] (letS ((x [1 2 -3 4 -5])) (Tuntil (Tprevious (minusp x)) x)) => [1 2 -3] If the items input of Tuntil is such that it can be used as a destination for alterS, then the output of Tuntil can be used as a destination for alterS. (letS* ((list '(a b 10 c)) (x (Elist list)) (y (Tuntil (numberp x) x))) (alterS y (list y)) list) => ((a) (b) 10 c) TuntilF pred items => initial-items This function is the same as Tuntil except that it takes a functional argument instead of an OSS series of boolean values. The non-OSS function pred is mapped over items in order to obtain a series of boolean values. (Like Tuntil, TuntilF is can be used as a destination of alterS if items can.) The basic relationship between TuntilF and Tuntil is shown in the last example below. (TuntilF #'minusp [1 2 -3 4 -5]) => [1 2] (TuntilF #'minusp [1]) => [1] (TuntilF #'minusp (Eup)) => [0 1 2 ...] (TuntilF pred items) == (letS ((var items)) (Tuntil (TmapF pred var) var)) The functions Tuntil and TuntilF are both early terminators. This can sometimes lead to conflicts with the restriction that within each on-line subexpression, there must be a data flow path from each termination point to each output. To get the same effect without using an early terminator use Tselect of Tlatch as shown below. (Tuntil bools items) == (Tselect (not (Tlatch bools :post T)) items) (TuntilF #'pred items) == (Tselect (not (Tlatch (pred items) :post T)) items) TmapF function &rest items-list => items The higher-order function TmapF is used to create simple kinds of on-line transducers. Its arguments are a single function and zero or more OSS series. The function argument must be a non-OSS function which is compatible with the number of input series and the types of their elements. A single OSS series is returned. Each element of this series is the result of applying function to the corresponding elements of the input series. (That is to say, if TmapF receives a single input series R it will return a single output S such that S_i=function(R_i).) The length of the output is the same as the length of the shortest input. If there are no bounded series inputs (e.g., if there are no series inputs), then TmapF will generate an unbounded OSS series. (TmapF #'+ [1 2 3] [4 5]) => [5 7] (TmapF #'sqrt []) => [] (TmapF #'gensym) => [#:G003 #:G004 #:G005 ...] TscanF {init} function items => results The higher-order function TscanF is used to create complex kinds of on-line transducers. (The name is borrowed from APL.) The init argument (if present) must be a non-OSS value of some type T1. The function argument must be a binary non-OSS function from T1 and some type T2 to T1. The items argument must be an OSS series whose elements are of type T2. If the init argument is not present than T1 must equal T2. The function argument is used to compute a series of accumulator values of type T1 which is returned as the output of TscanF. The output is the same length as the series input and consists of the successive accumulator values. Suppose that the series input to TscanF is R and the output is S. The basic relationship between the output and the input is that S_i=function(S_i-1,R_i). If the init argument is specified, it is used as an initial value of the accumulator and the first output element S_0 has the value S_0=function(init,R_0). Typically, but not necessarily, init is chosen so that it is a left identity of function. If that is the case, then S_0=R_0. It is important to remember that the elements of items are used as the second argument of function. The order of arguments is chosen to highlight this fact. (TscanF 0 #'+ [1 2 3]) => [1 3 6] (TscanF 10 #'+ [1 2 3]) => [11 13 16] (TscanF nil #'cons [a b]) => [(nil . a) ((nil . a) . b)] (TscanF nil #'(lambda (state x) (cons x state)) [a b]) => [(a) (b a)] If the init argument is not specified, then the first element of the output is computed differently from the succeeding elements and S_0=R_0. (If function is cheap to evaluate, TscanF runs more efficiently if it is provided with an init argument.) One situation where one typically has to leave out the init argument is when function does not have a left identity element as in the last example below. (TscanF #'+ [1 2 3]) => [1 3 6] (TscanF #'max [1 3 2]) => [1 3 3] An interesting example of a scanning process is the operation of proration. In this process, a total is divided up and allocated between a number of categories. The allocation is done based on percentages which are associated with the categories. (For example, some number of packages might be divided up between a number of people.) One might think that this could be done straightforwardly by multiplying the total by each of the percentages. Unfortunately, this mapping approach does not work. The proration problem is more complex than it first appears. Typically, there is a limit to the divisibility of the total (e.g., when a group of packages is divided up, the individual packages cannot be subdivided). This means that rounding must be performed each time the total is multiplied by a percentage. In addition, it is usually important that the total be allocated exactly---i.e., that the sum of the allocations be exactly equal to the total, rather than being one more or one less. Scanning is required in order to make sure that things come out exactly right. As a concrete example of proration, suppose that 99 packages need to be allocated among three people based on the percentages 35%, 45%, and 20%. Assuming that the percentages and the number of packages are all represented as integers, simple mapping would lead to the incorrect result below in which the allocations add up to 100 instead of 99. (prognS (round (/ (* 99 [35 45 20]) 100))) => [35 45 20] The transducer Tprorate below solves the proration problem by using TscanF. It takes in a total and an OSS series of percentages and returns an OSS series of allocations. The basic action of the program is to multiply each percentage by the total. However, it also keeps track of how much of the total has been allocated. When the last percentage is encountered, the allocation is set to be everything which remains to be allocated. (This can cause a significant distortion in the final allocation, but it guarantees that the allocations will always add up to the total no matter what has happened with rounding along the way.) In order to determine when the last percentage is being encountered, the program keeps track of how much percentage has been accounted for and assumes that the percentages always add up to 100. (defun prorate-step (state percent) (let* ((total (second state)) (unallocated (third state)) (unused-percent (fourth state)) (allocation (if (= percent unused-percent) unallocated (round (/ (* total percent) 100))))) (setf (first state) allocation) (setf (third state) (- unallocated allocation)) (setf (fourth state) (- unused-percent percent)) state)) (defunS Tprorate (total percents) (declare (type oss percents)) (car (TscanF (list 0 total total 100) #'prorate-step percents))) (Tprorate 99 [35 45 20]) => [35 45 19] An interesting aspect of the function Tprorate is that the state manipulated by the scanned function prorate-step has four parts: an allocation, the total, the unallocated portion of the total, and the remaining percentage not yet allocated. This illustrates the fact that TscanF can be used with complex state objects. (The same is true of EnumerateF and ReduceF.) However, it also illustrates that accessing the various parts of a complex state is awkward and inefficient. Fortunately, it is often possible to get around the need for a complex state object by using a compound OSS expression. For the example of proration, this can be done as shown below. Simple mapping is combined with two scans which keep track of cumulative values. An implicitly mapped test is used to make sure that things come out right on the last step. (The function Tprevious is used to access the previous value of the series unallocated.) (defunS Tprorate-multi-state (total percents) (declare (type oss percents)) (letS* ((allocation (round (/ (* percents total) 100))) (unallocated (TscanF total #'- allocation)) (unused-percent (TscanF 100 #'- percents))) (if (zerop unused-percent) (Tprevious unallocated total) allocation))) Cotruncation A key feature of every on-line transducer is that it terminates as soon as any input runs out of elements. Put another way, the output is never longer than the shortest input. (If the transducer is also an early terminator, then the output can be shorter than the shortest input, otherwise it must be the same length as the shortest input.) This effect is referred to as cotruncation, because it acts as if each input had been truncated to the length of the shortest input. If several enumerators and on-line transducers are combined together into an OSS expression, cotruncation will typically cause all of the series produced by the enumerators to be truncated to the same length. For example, in the expression below, all of the series (including the unbounded series produced by Eup) are truncated to a length of two. (Rlist (* (+ (Eup) [4 5]) [1 2 3])) => (4 12) Tcotruncate items &rest more-items => initial-items &rest more-initial-items It is occasionally important to specify cotruncation explicitly. This can be done with the function Tcotruncate whose only action is to force all of the outputs to be of the same length. (If any of the inputs of Tcotruncate are such that they can be used as destinations of alterS, then the corresponding outputs of Tcotruncate can be used as destinations of alterS.) (Tcotruncate [1 2 -3 4 -5] [10]) => [1] [10] (Tcotruncate (Eup) [a b]) => [0 1] [a b] (Tcotruncate [a b] []) => [] [] An important feature of Tcotruncate is that it has a powerful interaction with the requirement that within each on-line subexpression, there must be a data flow path from each termination point to each output. Consider the function weighted-squares below. This program is intended to take a vector of values and a vector of weights and return a list of two vectors: the squares of the values and the squares multiplied by the weights. The program violates the requirement above, because there is no data flow path from (Evector weight-vector) to (Rvector squares). (defun weighted-squares (value-vector weight-vector) (letS* ((values (Evector value-vector)) ;Signals warning 18 (weights (Evector weight-vector)) (squares (* values values)) (weighted-squares (* squares weights))) (list (Rvector squares) (Rvector weighted-squares)))) (weighted-squares #(1 2 3) #(2 3 4)) => (#(1 4 9) #(2 12 36)) (weighted-squares #(1 2) #(2 3 4)) => (#(1 4) #(2 12)) (weighted-squares #(1 2 3) #(2 3)) => (#(1 4 9) #(2 12)) It might be the case that the programmer knows that value-vector and weight-vector always have the same length. (Or it might be the case that he wants both output values to be no longer than the shortest input.) In either case, the function can be written as shown below which is much more efficient than the program above since there is no longer a restriction violation which triggers code copying. The key difference is that the use of Tcotruncate makes both outputs depend on both inputs. If the inputs are known to be the same length, the use of Tcotruncate can be thought of as a declaration. (defun weighted-squares* (value-vector weight-vector) (letS* (((values weights) (Tcotruncate (Evector value-vector) (Evector weight-vector))) (squares (* values values)) (weighted-squares (* squares weights))) (list (Rvector squares) (Rvector weighted-squares)))) (weighted-squares* #(1 2 3) #(2 3 4)) => (#(1 4 9) #(2 12 36)) (weighted-squares* #(1 2) #(2 3 4)) => (#(1 4) #(2 12)) (weighted-squares* #(1 2 3) #(2 3)) => (#(1 4) #(2 12)) Off-Line Transducers This section and the next two describe transducers that are not on-line. Most of these functions have some inputs or outputs which are on-line. The ports which are on-line can be used freely. However, the off-line ports have to be isolated when they are used. (For ease of reference, the off-line ports all begin with the letter code "O".) Tremove-duplicates Oitems &optional (comparator #'eql) => items This function is analogous to remove-duplicates. It creates an OSS series that has the same elements as the off-line input Oitems with all duplicates removed. The comparator is used to determine whether or not two items are duplicates. If two items are the same, then the item which is later in the series is discarded. (As in remove-duplicates the algorithm employed is not particularly efficient, being O(n^2).) (If the Oitems input of Tremove-duplicates is such that it can be used as a destination for alterS, then the output of Tremove-duplicates can be used as a destination for alterS.) (Tremove-duplicates [1 2 1 (a) (a)]) => [1 2 (a) (a)] (Tremove-duplicates [1 2 1 (a) (a)] #'equal) => [1 2 (a)] Tchunk amount Oitems => lists This function creates an OSS series of lists of length amount of successive subseries of the off-line input Oitems. If the length of Oitems is not a multiple of amount, then the last (mod (Rlength Oitems) amount) elements of Oitems will not appear in any output chunk. (Tchunk 2 [a b c d e]) => [(a b) (c d)] (Tchunk 6 [a b c d]) => [] Twindow amount Oitems => lists This function creates an OSS series of lists of length amount of subseries of the off-line input Oitems starting at each element position. If the length of Oitems is less than amount, the output will not contain any windows. The last example below shows Twindow being used to compute a moving average. (Twindow 2 [a b c d]) => [(a b) (b c) (c d)] (Twindow 4 [a b c d]) => [(a b c d)] (Twindow 6 [a b c d]) => [] (prognS (/ (apply #'+ (Twindow 2 [2 4 6 8])) 2)) => [3 5 7] Tconcatenate Oitems1 Oitems2 &rest more-Oitems => items This function creates an OSS series by concatenating together two or more off-line input OSS series. The length of the output is the sum of the lengths of the inputs. (The elements of the individual input series are not computed until they need to be.) (Tconcatenate [b c] [] [d]) => [b c d] (Tconcatenate [] []) => [] TconcatenateF Enumerator Oitems => items The Enumerator must be a quoted OSS function that is an enumerator. The function TconcatenateF applies Enumerator to each element of the off-line input Oitems and returns the series obtained by concatenating all of the results together. If Enumerator returns multiple values, then TconcatenateF will as well. (TconcatenateF #'Elist [(a b) () (c d)]) => [a b c d] (TconcatenateF #'Elist [() ()]) => [] (TconcatenateF #'Eplist [(a 1) (b 2 c 3)]) => [a b c] [1 2 3] Tsubseries Oitems start &optional below => items This function creates an OSS series containing a subseries of the elements of the off-line input Oitems from start up to, but not including, below. If below is greater than the length of Oitems, output nevertheless stops as soon as the input runs out of elements. If below is not specified, the output continues all the way to the end of Oitems. Both of the arguments start and below must be non-negative integers. (Tsubseries [a b c d] 1) => [b c d] (Tsubseries [a b c d] 1 3) => [b c] (Rlist (Tsubseries (Elist list) 1 2)) == (subseq list 1 2) If the Oitems input of Tsubseries is such that it can be used as a destination for alterS, then the output of Tsubseries can be used as a destination for alterS. (let ((list '(a b c d e))) (alterS (Tsubseries (Elist list) 1 3) (Eup)) list) => (a 0 1 d e) The function Tsubseries terminates as soon as it has written the last output element. As a result, it is an early terminator. This can sometimes lead to conflicts with the restriction that within each on-line subexpression, there must be a data flow path from each termination point to each output. To select a subseries without using an early terminator, use Tselect, Tmask, and Eup as shown below. (Tsubseries Oitems from below) == (Tselect (Tmask (Eup from :below below)) Oitems) Tpositions Obools => indices This function takes in an OSS series and returns an OSS series of the indexes of the non-null elements in the off-line input series. (Tpositions [T nil T 44]) => [0 2 3] (Tpositions [nil nil nil]) => [] Tmask Omonotonic-indices => bools This function is a quasi-inverse of Tpositions. The input Omonotonic-indices must be a strictly increasing OSS series of non-negative integers. The output, which is always unbounded, contains T in the positions specified by Omonotonic-indices and nil everywhere else. (Tmask [0 2 3]) => [T nil T T nil nil ...] (Tmask []) => [nil nil ...] (Tmask (Tpositions x)) == (Tconcatenate (not (null x)) (Eoss :R nil)) Tmerge Oitems1 Oitems2 comparator => items This function is analogous to merge. The output series contains the elements of the two off-line input series. The elements of Oitems1 appear in the same order that they are read in. Similarly, the elements of Oitems2 appear in the same order that they are read in. However the elements from the two inputs are intermixed under the control of the comparator. At each step, the comparator is used to compare the current elements in the two series. If the comparator returns non-null, the current element is removed from Oitems1 and transferred to the output. Otherwise, the next output comes from Oitems2. (If, as in the first example below, the elements of the individual input series are ordered with respect to comparator, then the result will also be ordered with respect to comparator. If, as in the second example below, either input is not ordered, the result will not be ordered.) (Tmerge [1 3 7 9] [4 5 8] #'<) => [1 3 4 5 7 8 9] (Tmerge [1 7 3 9] [4 5 8] #'<) => [1 4 5 7 3 8 9] (Tmerge x y #'(lambda (x y) T)) == (Tconcatenate x y) Tlastp Oitems => bools items This function takes in a series and returns a series of boolean values having the same length such that the last value is T and all of the other values are nil. If the input series is unbounded, then the output series will also be unbounded and every element of the output will be nil. It turns out that this output cannot be computed by an on-line OSS function. Therefore, if Tlastp returned only the boolean values described above, the isolation restrictions would make it impossible to use the input series and the output values together in the same computation. In order to get around this problem, Tlastp returns a second output which is identical to the input. This output can be used in lieu of the input in combination with the boolean values. (Tlastp [a b c d]) => [nil nil nil T] [a b c d] (Tlastp [a]) => [T] [a] (Tlastp []) => [] [] (Tlastp (Eup)) => [nil nil nil ...] [0 1 2 ...] As an example of using Tlastp, it is interesting to return to the example of proration discussed in conjunction with the function TscanF. Both of the proration functions presented earlier assume that the percentages always add up to 100. If this turns out not to be the case, then an exact allocation of the total is not guaranteed. The following program ensures that exact allocation will occur no matter what the percentages add up to. It does this by using Tlastp to detect which percentage is the last one. (defunS Tprorate-robust (total Opercents) (declare (type oss Opercents)) (letS* (((is-last percents) (Tlastp Opercents)) (allocation (round (/ (* percents total) 100))) (unallocated (TscanF total #'- allocation))) (if is-last (Tprevious unallocated total) allocation))) (Tprorate-robust 99 [35 45 20]) => [35 45 19] (Tprorate-robust 99 [35 45 21]) => [35 45 19] (Tprorate 99 [35 45 21]) => [35 45 21] Selection and Expansion Selection and its inverse are particularly important kinds of off-line transducers. Tselect bools &optional items => Oitems This function selects elements from a series based on a boolean series. The off-line output consists of the elements of items which correspond to non-null elements of bools. That is to say, the nth element of items is in the output iff the nth element of bools is non-null. The order of the elements in Oitems} is the same as the order of the elements in items. The output terminates as soon as either input runs out of elements. If no items input is specified, then the non-null elements of bools are themselves returned as the output of Tselect. (If the items input of Tselect is such that it can be used as a destination for alterS, then the output of Tselect can be used as a destination for alterS.) (Tselect [T nil T nil] [a b c d]) => [a c] (Tselect [a nil b nil]) => [a b] (Tselect [nil nil] [a b]) => [] An interesting aspect of Tselect is that the output series is off-line rather than having the two input series be off-line. This is done in recognition of the fact that the two input series are always in synchrony with each other. Having only one port which is off-line allows more flexibility then having two ports which are off-line. One might want to select elements out of a series based on their positions in the series rather than on boolean values. This can be done straightforwardly using Tmask as shown below. (Tselect (Tmask [0 2]) [a b c d]) => [a c] (Tselect (not (Tmask [0 2])) (Eup 10)) => [11 13 14 15 ...] A final feature of Tselect in particular, and off-line ports in general, is illustrated by the program below. In this program, the Tselect causes the first Elist to get out of phase with the second Elist. As a result, it is important to think of OSS expressions as passing around series objects rather than as merely being abbreviations for loops where things are always happening in lock step. The latter point of view might lead to the idea that the output of the program below would be ((a 1) (c 2) (d 4)). (letS ((tag (Elist '(a b c d e))) (x (Elist '(1 -2 2 4 -5)))) (Rlist (list tag (Tselect (plusp x) x)))) => ((a 1) (b 2) (c 4)) TselectF pred Oitems => items This function is the same as Tselect, except that it maps the non-OSS function pred over Oitems to obtain a series of boolean values with which to control the selection. In addition, TselectF has an off-line input rather than an off-line output (this is fractionally more efficient). The logical relationship between Tselect and TselectF is shown in the last example below. (TselectF #'identity [a nil nil b nil]) => [a b] (TselectF #'plusp [-1 2 -3 4]) => [2 4] (TselectF pred items) == (letS ((var items)) (Tselect (TmapF pred var) var)) Texpand bools Oitems &optional (default nil) => items This function is a quasi-inverse of Tselect. (The name is borrowed from APL.) The output contains the elements of Oitems spread out into the positions specified by the non-null elements in bools---i.e., the nth element of Oitems is in the position occupied by the nth non-null element in bools. The other positions in the output are occupied by default. The output stops as soon as bools runs out of elements, or a non-null element in bools is encountered for which there is no corresponding element in Oitems. (Texpand [nil T nil T T] [a b c]) => [nil a nil b c] (Texpand [nil T nil T T] [a]) => [nil a nil] (Texpand [nil T] [a b c] 'z) => [z a] (Texpand [nil T nil T T] []) => [nil] Splitting An operation which is closely related to selection, is splitting. In selection, specified elements are selected out of a series. It is not possible to apply further operations to the elements which are not selected, because they have been discarded. In contrast, splitting divides up a series into two or more parts which can be individually used. Both Tsplit and TsplitF have on-line inputs and off-line outputs. The outputs have to be off-line, because they are inherently non-synchronized with each other. Tsplit items bools &rest more-bools => Oitems1 Oitems2 &rest more-Oitems This function takes in a series of elements and partitions them between two or more outputs. If there are n boolean inputs then there are n+1 outputs. Each input element is placed in exactly one output series. Suppose that the nth element of bools is non-null. In this case, the nth element of items will be placed in Oitems1. On the other hand, if the nth element of bools is nil, the second boolean input (if any) is consulted in order to see whether the input element should be placed in the second output or in a later output. (As in a cond, each time a boolean element is nil, the next boolean series is consulted.) If the nth element of every boolean series is nil, then the nth element of items is placed in the last output. (Tsplit [-1 -2 3 4] [T T nil nil]) => [-1 -2] [3 4] (Tsplit [-1 -2 3 4] [T T nil nil] [nil T nil T]) => [-1 -2] [4] [3] (Tsplit [-1 -2 3 4] [T T T T]) => [-1 -2 3 4] [] If the items input of Tsplit is such that it can be used as a destination for alterS, then all of the outputs of Tsplit can be used as destinations for alterS. (letS* ((list '(-1 2 -3)) (x (Elist list)) ((x+ x-) (Tsplit x (plusp x)))) (alterS x+ (+ x+ 10)) (alterS x- (- x- 10)) list) => (-11 12 -13) TsplitF items pred &rest more-pred => Oitems1 Oitems2 &rest more-Oitems This function is the same as Tsplit, except that it takes predicates as arguments rather than boolean series. The predicates must be non-OSS functions and are applied to items in order to create boolean values. The relationship between TsplitF and Tsplit is almost but not exactly as shown below. (TsplitF items pred1 pred2) not= (letS ((var items)) (Tsplit var (TmapF pred1 var) (TmapF pred2 var))) The reason that the equivalence above does not quite hold is that, as in a cond, the predicates are not applied to individual elements of items unless the resulting value is needed in order to determine which output series the element should be placed in (e.g., if the first predicate returns non-null when given the nth element of items, the second predicate will not be called). This promotes efficiency and allows earlier predicates to act as guards for later predicates. (TsplitF [-1 -2 3 4] #'minusp) => [-1 -2] [3 4] (TsplitF [-1 -2 3 4] #'minusp #'evenp) => [-1 -2] [4] [3] Reducers Reducers produce non-OSS outputs based on OSS inputs. There are two basic kinds of reducers: ones that combine the elements of OSS series together into aggregate data structures (e.g., into a list) and ones that compute some summary value from these elements (e.g., the sum). All the predefined reducers are on-line. A few reducers are also early terminators. These reducers are described in the next section. Rlist items => list This function creates a list of the elements in items in order. (Rlist [a b c]) => (a b c) (Rlist []) => () (Rlist (fn (Elist x) (Elist y))) == (mapcar #'fn x y) (Rlist (fn (Esublists x) (Esublists y))) == (maplist #'fn x y) Rbag items => list This function creates a list of the elements in items with no guarantees as to the order of the elements. The function Rbag is more efficient than Rlist. (Rbag [a b c]) => (c a b) ;in some order (Rbag []) => () Rappend lists => list This function creates a list by appending the elements of lists together in order. (Rappend [(a b) nil (c d)]) => (a b c d) (Rappend []) => () Rnconc lists => list This function creates a list by nconcing the elements of lists together in order. The function Rnconc is faster than Rappend, but modifies the lists in the OSS series lists. (Rnconc [(a b) nil (c d)]) => (a b c d) (Rnconc []) => () (let ((x '(a b))) (Rnconc (Eoss x x))) => (a b a b a b ...) (Rnconc (fn (Elist x) (Elist y))) == (mapcan #'fn x y) (Rnconc (fn (Esublists x) (Esublists y))) == (mapcon #'fn x y) Ralist keys values => alist This function creates an alist containing keys and values. It terminates as soon as either of the inputs runs out of elements. If there are duplicate keys, they will be put on the alist, but order is preserved. (Ralist [a b] [1 2]) => ((a . 1) (b . 2)) (Ralist [a b] []) => () (Ralist keys values) == (Rlist (cons keys values)) Rplist indicators values => plist This function creates a plist containing keys and values. It terminates as soon as either of the inputs runs out of elements. If there are duplicate indicators, they will be put on the plist, but order is preserved. (Rplist [a b a] [1 2 3]) => (a 1 b 2 a 3) (Rplist [a b] []) => () (Rplist keys values) == (Rnconc (list keys values)) Rhash keys values &rest option-plist => table This function creates a hash table containing keys and values. It terminates as soon as either of the inputs runs out of elements. The option-plist can contain any options acceptable to make-hash-table. The option-plist cannot refer to variables bound by letS. (Rhash [color name] [brown fred]) => # ;;hash table containing color->brown, name->fred (Rhash [color name] []) => # ;;empty hash table Rvector items &key :size &rest option-plist => vector This function creates a vector containing the elements of items in order. The option-plist can contain any options acceptable to make-array. The option-plist cannot refer to variables bound by letS. The function Rvector operates in one of two ways. If the :size argument is supplied, then Rvector assumes that items will contain exactly :size elements. A vector is created of length :size with the options specified in option-plist and the elements of items are stored in it. (If items has fewer than :size elements, some of the slots in the vector will be left in their initial state. If items has more than :size elements, an error will ensue.) In this mode, Rvector is very efficient, but rather inflexible. (Rvector [1 2 3] :size 3) => #(1 2 3) (Rvector [#\B #\A #\R] :size 3 :element-type 'string-char) => "BAR" (Rvector [1] :size 4 :initial-element 0) => #(1 0 0 0) If the :size argument is not supplied, then Rvector allows for the creation of an arbitrarily large vector. It does this by using vector-push-extend. In order for this to work, it forces :adjustable to be T and :fill-pointer to be 0 no matter what is specified in the options-list. In this mode, an arbitrary number of input elements can be handled, however, things are much less efficient, since the vector created is not a simple vector. (Rvector [1 2 3]) => #(1 2 3) (Rvector []) => #() (Rvector [#\B #\A #\R] :element-type 'string-char) => "BAR" To store a series in a preexisting vector, use alterS of Evector. (let ((v '#(a b c))) (alterS (Evector v) (Eoss 1 2)) v) => #(1 2 c) Rfile name items &rest option-plist => T This function creates a file named name and writes the elements of items into it using print. The option-plist can contain any of the options accepted by open except :direction which is forced to be :output. All of the ordinary printer control variables are obeyed during the printout. The value T is always returned. The option-plist cannot refer to variables bound by letS. (Rfile "test.lisp" ['(a) '(1 2) T] :if-exists :append) => T ;;The output " ;;(a) ;;(1 2) ;;T " is printed into the file "test.lisp". Rlast items &optional (default nil) => item This function returns the last element of items. If items is of zero length, default is returned. (Rlast [a b c]) => c (Rlast [] 'z) => z Rlength items => number This function returns the number of elements in items. (Rlength [a b c]) => 3 (Rlength []) => 0 Rsum numbers => number This function computes the sum of the elements in numbers. These elements must be numbers, but they need not be integers. (Rsum [1 2 3]) => 6 (Rsum []) => 0 (Rsum [1.1 1.2 1.3]) => 3.6 Rmax numbers => number This function computes the maximum of the elements in numbers. These elements must be non-complex numbers, but they need not be integers. The value nil is returned if numbers has length zero. (Rmax [2 1 4 3]) => 4 (Rmax []) => nil (Rmax [1.2 1.1 1.4 1.3]) => 1.4 Rmin numbers => number This function computes the minimum of the elements in numbers. These elements must be non-complex numbers, but they need not be integers. The value nil is returned if numbers has length zero. (Rmin [2 1 4 3]) => 1 (Rmin []) => nil (Rmin [1.2 1.1 1.4 1.3]) => 1.1 ReduceF init function items => result This function is analogous to reduce. In addition, it is similar to TscanF except that init is not optional and the final value of the accumulator is the only value returned as shown in the last example below. If items is of length zero, init is returned. As with TscanF, function must be a non-OSS function and the value of init is typically chosen to be a left identity of function. It is important to remember that the elements of items are used as the second argument of function. The order of arguments is chosen to highlight this fact. (ReduceF 0 #'+ [1 2 3]) => 6 (ReduceF 0 #'+ []) => 0 (ReduceF 0 #'+ x) == (Rsum x) (ReduceF init function items) == (letS ((var init)) (Rlast (TscanF var function items) var)) In order to do reduction without an initial seed value, use Rlast of TscanF. Note that although a seed value does not have to be specified, a value to be returned if there are no elements in items still has to be specified. (Rlast (TscanF #'max x) nil) == (Rmax x) Early Reducers The following four reducers are early terminators. Each of these functions has a non-early variant denoted by the suffix "-late". The early variants are more efficient, because they terminate as soon as they have determined a result. This may be long before any of the input series run out of elements. However, as discussed at the end of this section, one has to be somewhat careful when using an early reducer in an OSS expression. Rfirst items &optional (default nil) => item Rfirst-late items &optional (default nil) => item Both of these functions return the first element of items. If items is of zero length, default is returned. The only difference between the functions is that Rfirst stops immediately after reading the first element of items, while Rfirst-late does not terminate until items runs out of elements. (Rfirst [a b c]) => a (Rfirst [] 'z) => z Rnth n items &optional (default nil) => item Rnth-late n items &optional (default nil) => item Both of these functions return the nth element of items. If n is greater than or equal to the length of items, default is returned. The only difference between the functions is that Rnth stops immediately after reading the nth element of items, while Rnth-late does not terminate until items runs out of elements. (Rnth 1 [a b c]) => b (Rnth 1 [] 'z) => z Rand bools => bool Rand-late bools => bool Both of these functions compute the and of the elements in bools. As with the function and, nil is returned if any element of bools is nil. Otherwise the last element of bools is returned. The value T is returned if bools has length zero. The only difference between the functions is that Rand terminates as soon as a nil is encountered in the input, while Rand-late does not terminate until bools runs out of elements. (Rand [a b c]) => c (Rand [a nil c]) => nil (Rand []) => T (Rand (pred (Esequence x) (Esequence y))) == (every #'pred x y) Ror bools => bool Ror-late bools => bool Both of these functions compute the or of the elements in bools. As with the function or, nil is returned if every element of bools is nil. Otherwise the first non-null element of bools is returned. The value nil is returned if bools has length zero. The only difference between the functions is that Ror terminates as soon as a non-null value is encountered in the input, while Ror-late does not terminate until bools runs out of elements. (Ror [a b c]) => a (Ror [a nil c]) => a (Ror []) => nil (Ror (pred (Esequence x) (Esequence y))) == (some #'pred x y) Care must be taken when using early reducers. As discussed in the section on restrictions, OSS expressions are required to obey the restriction that within each on-line subexpression, there must be a data flow path from each termination point to each output. Early reducers interact with this restriction since early reducers are termination points. As a result, there must be a data flow path from each early reducer to each output of the containing on-line subexpression. Since reducers compute non-OSS values, they directly compute outputs of on-line subexpressions. As a result, it is impossible for there to be a data flow path from a reducer to any output other than the output the reducer itself computes. Therefore, the use of an early reducer will trigger code copying unless that reducer computes the only output of the on-line subexpression. For example, consider the following four expressions. The first two expressions return the same result. However, the first is more efficient. This is a prototypical example of a situation where it is better to use an early reducer. In contrast, although the last two expressions also return the same results, the second of the expressions is more efficient. The problem is that in the first of these expressions, there is no data flow path from the use of Rfirst to the second output. In order to fix this problem the OSS macro package duplicates the list enumeration. It is more efficient to use a non-early reducer as in the last example. (letS ((x (Elist '(1 2 -3 4 5 -6 -7 8)))) (Rfirst (TselectF #'minusp x))) => -3 (letS ((x (Elist '(1 2 -3 4 5 -6 -7 8)))) (Rfirst-late (TselectF #'minusp x))) => -3 (letS ((x (Elist '(1 2 -3 4 5 -6 -7 8)))) ;Signals warning 18 (valS (Rfirst (TselectF #'minusp x)) (Rsum x))) => -3 4 (letS ((x (Elist '(1 2 -3 4 5 -6 -7 8)))) (valS (Rfirst-late (TselectF #'minusp x)) (Rsum x))) => -3 4 Series Variables The principal way to create OSS variables is to use the form letS. (These variables are also created by the forms lambdaS and defunS.) letS var-value-pair-list {decl}* &body expr-list => result The form letS is syntactically analogous to let. Just as in a let, the first subform is a list of variable-value pairs. The letS form defines the scope of these variables and gives them the indicated values. As in a let, one or more declarations can follow the variable-value pairs. These can be used to specify the types of the variables. The variables created by letS can be OSS variables or non-OSS variables. Which are which is determined by the type of the value that is bound to the variable. As in let, the variables are bound in parallel. In the example below, y is an OSS variable while x and z are non-OSS variables. (letS ((x '(1 2 3)) (y (Elist '(1 2 3))) (z (Rsum (Elist '(1 2 3))))) (list x (Rmax y) z)) => ((1 2 3) 3 6) Unlike let, letS does not support degenerate variable-value pairs which consist solely of a variable. (Since letS variables cannot be assigned to, see below, degenerate pairs would be of little value.) (letS (x) ...) ;Signals error 9 The following example illustrates the use of a declaration in a letS. Declarations are handled in the same way that they are handled in a let. (letS ((x (Elist '(1 2 3)))) (declare (type integer x)) (Rsum x)) => 6 The form letS goes beyond let to include the functionality of multiple-value-bind. A variable in a variable-value pair can be a list of variables instead of a single variable. When this is the case, the variables pick up the first, second, etc. results returned by the value expression. (If there is only one variable, it gets the first value. If nil is used in lieu of a variable, the corresponding value is ignored.) If there are fewer variables than values, the extra values are ignored. Unlike multiple-value-bind, letS signals an error if there are more variables than values. (Note that there is no form multiple-value-bindS and that the form multiple-value-bind cannot be used inside of an OSS expression to bind the results of an OSS function.) (letS (((key value) (Ealist '((a . 1) (b . 2))))) (Rlist (list key value))) => ((a 1) (b 2)) (letS ((key (Ealist '((a . 1) (b . 2))))) (Rlist key)) => (a b) (letS (((nil value) (Ealist '((a . 1) (b . 2))))) (Rlist value)) => (1 2) (letS (((key value x) (Ealist '((a . 1) (b . 2))))) (Rlist (list key value x))) ;Signals error 8 The expr-list of a letS has the effect of grouping several OSS expressions together. The value of the last form in the expr-list is returned as the value of the letS. This value may be an OSS value or a non-OSS value. In addition to placing all of the expressions in the same letS binding scope, the grouping imposed by the expr-list causes the entire body to become an OSS expression. This can alter the way implicit mapping is applied by including non-OSS functions in the OSS expression. The restricted nature of OSS variables. There are a number of ways in which the variables bound by letS (or lambdaS and defunS) are more restricted than the ones bound by let. For the most part, these restrictions stem from the fact that when the OSS macro package transforms an OSS expression into a loop, it rearranges the expressions extensively. This forces letS variable scopes to be supported by variable renaming rather than binding. One result of this is that it is not possible to declare (or proclaim) a letS variable to be special. (Standard Common Lisp does not provide any method for determining whether or not a variable has been proclaimed special. As a result, the OSS macro package is unable to issue an error message when a special letS variable is encountered. The Symbolics Common Lisp version of the OSS macro package does issue an error message.) (proclaim '(special z)) (letS ((z (Elist '(1 2 3)))) (Rsum z)) ;erroneous expression Another limitation is that programmers are not allowed to assign values to letS variables in the body of a letS. (This restriction applies whether or not the variables contain OSS values.) The only time letS variables can be given a value is the moment they are bound. (Although assignment could be supported easily enough, the rearrangements introduced by the OSS macro package would make it very confusing for a programmer to figure out exactly what would happen in a given situation. In particular, naively applying implicit mapping to setq would lead to peculiar results. In addition, outlawing assignments enhances the functional nature of the OSS macro package.) An error message is issued whenever such an assignment is attempted. (lets ((x (Elist '(1 2 3)))) (setq x (1+ x)) ;Signals error 12 (Rlist x)) Another aspect of letS variables is that their scope is somewhat limited. In particular, letS variables can be referenced in a letS or mapS which is inside the letS which binds them. However, they cannot be referenced in lambda or lambdaS. (As above, this limitation is imposed in order to avoid confusions due to rearrangements. Further, it is not obvious what it would mean to refer to an OSS variable in a lambda. Should some sort of implicit mapping be applied?) No attempt is made to issue error messages in this situation. Rather, the variable reference in question is merely treated as a free variable. (let ((x 4)) (letS ((x (Elist '(1 2 3)))) (Rlist (TmapF #'(lambda (y) (+ x y)) x)))) => (5 6 7) letS* var-value-pair-list {decl}* &body expr-list => result The form letS* is exactly the same as letS except that the variables are bound sequentially instead of in parallel. (letS* ((x '(1 2 3)) (y (Elist x)) (z (Rsum y))) (list x (Rmax y) z)) => ((1 2 3) 3 6) prognS &body expr-list => result As shown below, prognS is identical to letS except that it cannot contain any variable-value pairs or declarations. It is a degenerate form whose only function is to delineate an OSS expression. This can alter the way implicit mapping is applied by including non-OSS functions in the OSS expression. (prognS . expr-list) == (letS () . expr-list) Complete OSS expressions do not return OSS values. A key point relevant to the discussion above is that syntactically complete OSS expressions are not allowed to return OSS values. This is relevant, because letS and prognS are often used in such a way that an OSS series gratuitously ends up as the return value. For example, the main intent of the expression below is to print out the elements of the list. However, as written, the expression appears to return an OSS series of the values produced by prin1. Because expressions like the one below are relatively common, it was decided not to issue an error message in this situation. Rather, the OSS value is simply discarded and no value is returned. (prognS (prin1 (Elist '(1 2)))) => ;;The output "12" is printed. It might be the case that the programmer actually desires to have a physical series returned in the example above. This can be done by using a reducer such as Rlist or Rvector as shown below. (prognS (Rlist (prin1 (Elist '(1 2))))) => (1 2) ;;The output "12" is printed. Preventing complete OSS expressions from returning OSS values does not limit what can be written, because programmers can always return a non-OSS series. This can be a bit cumbersome at times, but it is highly preferable to the large inefficiencies which would be introduced by automatically constructing physical representations for OSS series in situations where the returned values are not used in further computation. Coercion of Non-Series to Series If an OSS input of an OSS function is applied to a non-series value, the type conflict is resolved by converting the non-OSS value into a series by inserting Eoss. That is to say, a non-OSS value acts the same as an unbounded OSS series of the value. (Ralist (Elist '(a b)) (* 2 3)) == (Ralist (Elist '(a b)) (Eoss :R (* 2 3))) => ((a . 6) (b . 6)) Using Eoss to coerce a non-OSS value to an OSS series has the effect of only evaluating the expression which computes the value once. This has many advantages with regard to efficiency, but may not always be what is desired. Multiple evaluation can be specified by using TmapF or mapS. (Ralist (Elist '(a b)) (gensym)) => ((a . #:G004) (b . #:G004)) (Ralist (Elist '(a b)) (TmapF #'gensym)) => ((a . #:G004) (b . #:G005)) Implicit Mapping Mapping operations can be created by using TmapF. However, in the interest of convenience, two other ways of creating mapping operations are supported. The most prominent of these is implicit mapping. If a non-OSS function appears in an OSS expression and is applied to one or more arguments which are OSS series, the type conflict is resolved by automatically mapping the function over these series. (Rsum (car (Elist '((1) (2))))) == (Rsum (TmapF #'car (Elist '((1) (2))))) => 3 (Rsum (* 2 (Elist '(1 2)))) == (Rsum (TmapF #'(lambda (x) (* 2 x)) (Elist '(1 2)))) => 6 As shown in the second example, implicit mapping actually applies to entire non-OSS subexpressions rather than merely to individual functions. This promotes efficiency and makes sure that related groups of functions are mapped together. However, it is not always what is desired. For instance, in the first example below, the call on gensym gets mapped in conjunction with the call on list. This causes each list to contain a separate gensym variable. It might be the case that the programmer wants to have the same gensym variable in each list. This can be achieved by inserting an Eoss as shown in the second example. (Inserting a Eoss here and there can promote efficiency by avoiding unnecessary recomputation.) (Rlist (list (Elist '(a b)) (gensym))) == (Rlist (TmapF #'(lambda (x) (list x (gensym))) (Elist '(a b)))) => ((a #:G002) (b #:G003)) (Rlist (list (Elist '(a b)) (Eoss :R (gensym)))) == (Rlist (TmapF #'list (Elist '(a b)) (Eoss :R (gensym)))) => ((a #:G002) (b #:G002)) In order to be implicitly mapped, a non-OSS function must appear inside of an OSS expression. For example, the instance of prin1 in the first example below does not get implicitly mapped, because it is not in an OSS expression. Implicit mapping of the prin1 can be forced by using prognS as shown in the second example above. (prin1 (Elist '(1 2))) => nil ;;The output "NIL" is printed. (prognS (prin1 (Elist '(1 2)))) => ;;The output "12" is printed. (The result of the first example above is that NIL gets printed. This happens because (Elist '(1 2 3)) is a syntactically complete OSS expression and is therefore not allowed to return a series. It returns no values instead. The function prin1 demands a value anyway, and gets nil.) Another aspect of implicit mapping is that a non-OSS function will not be mapped unless it is applied to a series. This is usually, but not always, what is desired. Consider the first expression below. The instance of prin1 is mapped over x. However, the instance of princ is not applied to a series and is therefore not mapped. If the programmer intends to print a dash after each number, he has to do something in order to get the princ to be mapped. This could be done using TmapF or mapS. However, the best thing to do is to group the two printing statements into a single subexpression as shown in either of the last two examples below. This grouping shows the relationship between the printing operations and causes them to be mapped together. (letS ((x (Elist '(1 2 3)))) (prin1 x) (princ "-")) => "-" ;;The output "123-" is printed. (letS ((x (Elist '(1 2 3)))) (progn (prin1 x) (princ "-"))) => ;;The output "1-2-3-" is printed. (letS ((x (Elist '(1 2 3)))) (format T "~A-" x)) => ;;The output "1-2-3-" is printed Ugly details. Implicit mapping is easy to understand when applied in simple situations such as the ones above. However, it can be applied to any Lisp form. Things become somewhat more complicated when control constructs (e.g., if) and binding constructs (e.g., let) are encountered. The example below shows the implicit mapping of an if. This creates a lambda expression containing a conditional which is mapped over a series. A key thing to notice in this example is that implicit mapping of if is very different from a use of Tselect. In particular, the mapped if returns a value corresponding to every input, while the Tselect does not. (Rlist (if (plusp (Elist '(10 -11 12))) (Eup))) == (Rlist (TmapF #'(lambda (x y) (if (plusp x) y)) (Elist '(10 -11 12)) (Eup))) => (0 nil 2) (Rlist (Tselect (plusp (Elist '(10 -11 12))) (Eup))) => (0 2) Another aspect of the way conditionals are handled inside of an OSS expression is illustrated below. When an OSS expression is being processed in order to determine what should be implicitly mapped, the expression is broken up into OSS pieces and non-OSS pieces. If the argument of a conditional is an OSS expression, this argument will end up in a separate piece from the conditional itself. One result of this is that the argument will always be evaluated and the conditional will therefore lose its power to control when the argument should be evaluated. This effect will happen even if, as in the example below, the conditional does not have to be mapped. The three examples below all produce the same value, but the first two always evaluate (Rlist (abs (Elist x))) while the last may not. (prognS (if (Ror (minusp (Elist x))) (Rlist (abs (Elist x))) x)) == (prognS (funcall #'(lambda (y z) (if y z x)) (Ror (minusp (Elist x))) (Rlist (abs (Elist x))))) not= (if (Ror (minusp (Elist x))) (Rlist (abs (Elist x))) x) The following example shows the implicit mapping of a let. (Among other things, this illustrates that such expressions are far from clear. In general it is better to use letS as in the second example.) (Rlist (let ((double (* 2 (Elist '(1 2))))) (* double double))) == (Rlist (TmapF #'(lambda (x) (let ((double (* 2 x))) (* double double))) (Elist '(1 2)))) => (4 16) (letS ((double (* 2 (Elist '(1 2))))) (Rlist (* double double))) => (4 16) A problem with the implicit mapping of a let (or other binding forms) is that the implicit mapping transformation potentially moves subexpressions out of the scope of the binding form in question. This can change the meaning of the expression if any of these subexpressions contain an instance of a variable bound by the binding form. For instance, in the example above, the transformation moves the subexpression (Elist '(1 2)) out of the scope of the let. This would cause a problem if this subexpression referred to the variable double. In recognition of this problem, a warning message is issued whenever implicit mapping of a binding form causes a variable reference to move out of a form that binds it. Whenever it occurs, this problem can be alleviated by using letS as shown above. A final complexity involves forms like return, return-from, throw, etc. These forms are implicitly mapped like any other non-OSS form. When they get evaluated, they will cause an exit. However, the loop produced by the OSS macro does not contain a boundary which is recognized by any of these forms (e.g., it does not create a prog or catch). As a result, such a boundary must be defined which will serve as the reference point. Needless to say, the final results of the OSS expression will not be computed if the expression is exited in this way. Nested loops. Implicit mapping is applied when non-OSS functions receive OSS values. However, implicit mapping is not applied when OSS functions receive OSS values, even if these values are passed to non-OSS inputs. As illustrated below, whenever this situation occurs, an error message is issued. (Elist (Elist '((1 2) (3 4)))) ;Signals error 14 There are situations corresponding to nested loops where it would be reasonable to implicitly map subexpressions containing OSS functions. For example, one might write the following expression in order to copy a list of lists. (Rlist (Rlist (Elist (Elist '((1 2) (3 4)))))) ;Signals error 14 (Rlist (TmapF #'(lambda (x) (Rlist (Elist x))) (Elist '((1 2) (3 4))))) => ((1 2) (3 4)) Nevertheless, expressions like the first one above are forbidden. This is done for two reasons. First, in more complex situations OSS expressions corresponding to nested loops become so confusing that such expressions are very hard to understand. As a result, they are not very useful. Second, experience suggests that a large proportion of situations where mapping of OSS functions might be done arise from programming errors rather than an intention to have a nested loop. Outlawing these expressions makes it possible to find these errors more quickly. (The following example shows that there is no problem with having one loop computation following another. There are no type conflicts in this situation and no implicit mapping is required.) (Rsum (Evector (Rvector (Elist '(1 2))))) => 3 Needless to say, it would be unreasonable if there were no way to write OSS expressions corresponding to nested loops. First of all, this can always be done using TmapF as shown above. However, this can be rather cumbersome. To alleviate this difficulty, an additional form (mapS) is introduced which facilitates the expression of nested computations. mapS &body expr-list => items The expr-list consists of one or more expressions. These expressions are treated as the body of a function and mapped over any free OSS variables which appear in them. That is to say, the first element of the output is computed by evaluating the expressions in an environment where each OSS variable is bound to the first element of the corresponding series. The second element of the output is computed by evaluating the expressions in an environment where each OSS variable is bound to the second element of the corresponding series, etc. The way mapS could be used to copy a list-of-lists is shown below. A letS has to be used, because mapS requires that the series being mapped over must be held in a variable. (letS ((z (Elist '((1 2) (3 4))))) (Rlist (mapS (Rlist (Elist z))))) == (letS ((z (Elist '((1 2) (3 4))))) (Rlist (TmapF #'(lambda (x) (Rlist (Elist x))) z))) => ((1 2) (3 4)) (Rlist (mapS (Rlist (Elist (Elist '((1 2) (3 4))))))) ;Signals error 14 Implicit mapping is very valuable. From the above, it can be seen that although implicit mapping is simple in simple situations, there are a number of situations where it becomes quite complex. There is no question that these complexities dilute the value of implicit mapping. Nevertheless, experience suggests that implicit mapping is so valuable that, warts and all, it is perhaps the most useful single feature of OSS expressions. Literal Series Functions Just as it is very convenient to be able to specify a literal non-OSS function using lambda, it is sometimes convenient to be able to specify a literal OSS function. lambdaS var-list {decl}* &body expr-list The form lambdaS is analogous to lambda except that some of the arguments can have OSS series passed to them and the return value can be an OSS series. The var-list is simpler than the lambda lists which are supported by lambda. In particular, the var-list must consist solely of variable names. It cannot contain any of the lambda list keywords such as &optional and &rest. As in a letS, the variables in the var-list cannot be assigned to in the expr-list or referenced inside of a nested lambda or lambdaS. As in a lambda, the body can begin with one or more declarations. All of the arguments which are to receive OSS values have to be declared inside the lambdaS using the declaration type oss (see below). All of the other arguments are assumed to correspond to non-OSS values. Just as in a letS, the declarations may contain other kinds of declarations besides type oss declarations. However, the variables in the var-list cannot be declared (or proclaimed) to be special. The expr-list is a list of expressions which are grouped together into an OSS expression as in a letS or prognS. The value of the function specified by a lambdaS is the value of the last form in the expr-list. This value may or may not be an OSS series. In many ways, lambdaS bears the same relationship to letS that lambda bears to let. However, there is one key difference. The expr-list in a lambdaS cannot refer to any free variables which are bound by a letS, defunS, or another lambdaS. Each lambdaS is processed in complete isolation from the OSS expression which surrounds it. The only values which can enter or leave a lambdaS are specified by the var-list and non-OSS variables which are bound outside of the entire containing OSS expression. Another key feature of lambdaS is that the only place where it can validly appear is as the quoted first argument of funcallS (see below), or as an argument to a macro which will eventually expand in such a way that the lambdaS will end up as the quoted first argument of a funcallS. The following example illustrates the use of lambdaS. It shows an anonymous OSS function identical to Rsum. (funcallS #'(lambdaS (x) (declare (type oss x)) (ReduceF 0 #'+ x)) (Elist '(1 2 3))) => 6 type oss &rest variable-list This type declaration can only be used inside of a declare inside of a lambdaS or a defunS. It specifies that the variables carry OSS values. funcallS function &rest expr-list => result This is analogous to funcall except that function can be an OSS function. In particular, it can be the quoted name of a series function, a quoted lambdaS, or a macro call which expands into either of the above. It is also possible for function to be a non-OSS function, in which case funcallS is identical to TmapF. If function is an expression which evaluates to a function (as opposed to a literal function), then it is assumed to be a non-OSS function. (funcallS #'Elist '(1 2)) == (Elist '(1 2)) => [1 2] (funcallS #'(lambdaS (y) (declare (type oss y)) (* 2 y)) (Elist '(1 2))) => [2 4] (funcallS #'car [(1) (2)]) => [1 2] (funcallS #'car '(1 2)) => [1 1 1 1 ...] The number of expressions in expr-list must be exactly the same as the number of arguments expected by function. If not, an error message is issued. In addition, the types of values (either OSS series or not) returned by the expressions should be the same as the types which are expected by function. If not, coercion of non-series to series will be applied if possible in order to resolve the conflict. Defining Series Functions An important aspect of the OSS macro package is that it makes it easy for programmers to define new OSS functions. Straightforward OSS functions can be defined using the facilities outlined below. More complex OSS functions can be defined using the subprimitive facilities described in [6]. defunS name lambda-list {doc} {decl}* &body expr-list This is analogous to defun, but for OSS functions. At a simple level, defunS is just syntactic sugar which defines a macro that creates a funcallS of a lambdaS. The lambda-list, declarations, and expression list are restricted in exactly the same way as in a lambdaS except that the standard lambda list keywords &optional and &key are allowed in the lambda-list. (defunS Rlast (items &optional (default nil)) "Returns the last element of an OSS series" (declare (type oss items)) (ReduceF default #'(lambda (state x) x) items)) == (defmacro Rlast (items &optional (default 'nil)) "Returns the last element of an OSS series" `(funcallS #'(lambdaS (items default) (declare (type oss items)) (ReduceF default #'(lambda (state x) x) items)) ,items ,default)) However, at a deeper level, there is a key additional aspect to defunS. Preprocessing and checking of the resulting lambdaS is performed when the defunS is evaluated (or compiled), rather than when the resulting OSS function is used. This saves time when the function is used. More importantly, it leads to better error messages because error messages can be issued when the defunS is initially encountered, rather than when the OSS function defined is used. Although the lambda list keywords &optional and &key are supported by defunS, it should be realized that they are supported in the way they are supported by macros, not the way they are supported by functions. In particular, when keywords are used in a call on the OSS function being defined, they have to be literal keywords rather than computed by an expression. In addition, initialization forms cannot refer to the run-time values of other arguments, because these are not available at macro-expansion-time. They are also not allowed to refer to the macro-expansion-time values of the other arguments. They must stand by themselves when computing a value. A quote is inserted so that this value will be computed at run-time rather than at macro-expansion-time. (In the example above, (default nil) becomes (default 'nil).) It may seem unduly restrictive that defunS does not support all of the standard keywords in lambda-list. However, this is not that much of a problem because defmacro can be used directly in situations where these capabilities are desired. For example, Tconcatenate is defined in terms of a more primitive OSS function Tconcatenate2 as follows. (defmacro Tconcatenate (Oitems1 Oitems2 &rest more-Oitems) (if (null more-Oitems) `(Tconcatenate2 ,Oitems1 ,Oitems2) `(Tconcatenate2 ,Oitems1 (Tconcatenate ,Oitems2 .,more-Oitems)))) Using defmacro directly also makes it possible to define new higher-order OSS functions. For example, an OSS function analogous to substitute-if could be defined as follows. (The Eoss ensures that newitem will only be evaluated once.) (defmacro Osubstitute-if (newitem test items) (let ((var (gensym))) `(letS ((,var ,items)) (if (funcall ,test ,var) (Eoss :R ,newitem) ,var)))) (Osubstitute-if 3 #'minusp [1 -1 2 -3]) => [1 3 2 3] Multiple Values The OSS macro package supports multiple values in a number of contexts. As discussed above, letS can be used to bind variables to multiple values returned by an OSS function. Faculties are also provided for defining OSS functions which return multiple values. The support for multiple values is complicated by the fact that the OSS macro package implements all communication of values by using variables. As a result, it is not possible to support the standard Common Lisp feature that multiple values can coexist with single values without the programmer having to pay much attention to what is going on. When using OSS expressions, the programmer has to be explicit about how many values are being passed around. valS &rest expr-list => &rest multiple-value-result This is analogous to values except that it can operate on OSS values. It takes in the values returned by n different expressions and returns them as n multiple values. It enforces the restriction that the values must either all be OSS values or all be non-OSS values. The following example shows how a simple version of Eplist could be defined. (defunS simple-Eplist (place) (letS ((plist (EnumerateF place #'cddr #'null))) (valS (car plist) (cadr plist)))) It is possible to use values in an OSS expression. However, the results will be very different from the results obtained from using valS. The values will be implicitly mapped like any other non-OSS form. The value ultimately returned will be the single value returned by TmapF. (prognS (valS (Elist '(1 2)) (Elist '(3 4)))) => [1 2] [3 4] (prognS (values (Elist '(1 2)) (Elist '(3 4)))) == (prognS (TmapF #'(lambda (x y) (values x y)) (Elist '(1 2)) (Elist '(3 4)))) => [1 2] pass-valS n expr => &rest multiple-value-result This function is used essentially as a declaration. It tells the OSS macro package that the form expr returns n multiple values which the programmer wishes to have preserved in the context of the OSS expression. (This is needed, because Common Lisp does not provide any compile-time way to determine the number of arguments that a function will return.) The first example below enumerates a list of symbols and returns a list of the internal symbols, if any, which correspond to them. The second example defines a two valued OSS function which locates symbols. (letS* ((names (Elist '(zots Elist zorch))) ((symbols statuses) (pass-valS 2 (find-symbol (string names)))) (internal-symbols (Tselect (eq statuses :internal) symbols))) (Rlist internal-symbols)) => (zots zorch) (defunS find-symbols (names) (declare (type oss names)) (pass-valS 2 (find-symbol (string names)))) (find-symbols [zots Elist zorch]) => [zots Elist zorch] [:internal :inherited :internal] The form pass-valS never has to be used in conjunction with an OSS function, because the OSS macro package knows how many values every OSS function returns. Similarly, pass-valS never has to be used when multiple values are being bound by letS, because the syntax of the letS indicates how many values are returned. (As a result, the pass-valS in the first example above is not necessary.) However, in situations such as the second example above, pass-valS must be used. Alteration of Values The transformations introduced by the OSS macro package are inherently antagonistic to the transformations introduced by the macro setf. In particular, OSS function calls cannot be used as the destination of a setf. In order to get around this problem, the OSS macro package supports a separate construct which is in fact more powerful than setf. alterS destinations items => items This form takes in a series of destinations and a series of items and stores the items in the destinations. It returns the series of items. Like setf, alterS cannot be applied to a destination unless there is an associated definition for what should be done (see the discussion of alterableS in [6]). The outputs of the predefined functions Elist, Ealist, Eplist, Efringe, Evector, and Esequence are alterable. The effects of this alteration are illustrated in conjunction with the descriptions of these functions. For example, the following sets all of the elements in a list to nil. (let ((list '((a . 1) (b . 2) (c . 3)))) (alterS (Elist list) nil) list) => (nil nil nil) As a related example, consider the following. Although setf cannot be applied to an OSS function, it can be applied to a non-OSS function in an OSS expression. In the example below, setf is used to set the cdr of each element of a list to nil. (let ((list '((a . 1) (b . 2) (c . 3)))) (prognS (setf (cdr (Elist list)) nil)) list) => ((a) (b) (c)) A key feature of alterS is that (in contrast to setf) a structure can be altered by applying alterS to a variable which contains enumerated elements of the structure. This is useful because the old value in a structure can be used to decide what new value should be put in the structure. (When alterS is applied to such a variable it modifies the structure being enumerated but does not change the value of the variable.) (letS* ((v '#(1 2 3)) (x (Evector v))) (alterS x (* x x)) (valS (Rlist x) v)) => (1 2 3) #(1 4 9) Another interesting aspect of alterS is that it can be applied to the outputs of a number of transducers. This is possible whenever a transducer passes through unchanged a series of values taken from an input which is itself alterable. This can happen with the transducers Tuntil, TuntilF, Tcotruncate, Tremove-duplicates, Tsubseries, Tselect, TselectF, Tsplit, and TsplitF. For example, the following takes the absolute value of the elements of a vector. (letS* ((v '#(1 -2 3)) (x (TselectF #'minusp (Evector v)))) (alterS x (- x)) v) => #(1 2 3) Debugging The OSS macro package supports a number of features which are intended to facilitate debugging. One example of this is the fact that the macro package tries to use the variable names which are bound by a letS in the code produced. Since the macro package is forced to use variable renaming in order to implement variable scoping, it cannot guarantee that these variable names will be used. However, there is a high probability that they will. If a break occurs in the middle of an OSS expression, these variables can be inspected in order to determine what is going on. If a letS variable holds an OSS series, then the variable will contain the current element of the series. For example, the OSS expression below is transformed into the loop shown. (For a discussion of how this transformation is performed see [6].) (letS* ((v (get-vector user)) (x (Evector v))) (Rsum x)) (let (#:index-9 #:last-8 #:sum-2 x v) (setq v (get-vector user)) (tagbody (setq #:index-9 -1) (setq #:last-8 (length v)) (setq #:sum-2 0) #:L-1 (incf #:index-9) (if (not (< #:index-9 #:last-8)) (go oss:END)) (setq x (aref v #:index-9)) (setq #:sum-2 (+ #:sum-2 x)) (go #:L-1) oss:END) #:sum-2) showS thing &optional (format "~%~S") (stream *standard-output*) => thing This function is convenient for printing out debugging information while an OSS expression is being evaluated. It can be wrapped around any expression no matter whether it produces an OSS value or a non-OSS value without disturbing the containing expression. The function prints out the value and then returns it. If the value is a non-OSS thing, it will be printed out once at the time it is created. If it is an OSS series thing, it will be printed out an element at a time. The format can be used to print a tag in order to identify the value being shown. (showS format stream) == (let ((x thing)) (format stream format x) x) (letS ((x (Elist '(1 2 3)))) (Rsum (showS x "Item: ~A, "))) => 6 ;;The output "Item: 1, Item: 2, Item: 3, " is printed. *permit-non-terminating-oss-expressions* On the theory that non-terminating loops are seldom desired, the OSS macro package checks each loop constructed to see if it can terminate. If this control variable is nil (which is the default), then a warning message is issued for each loop which the OSS macro package thinks has no possibility of terminating. This is useful in the first example below, but not in the second. The form compiler-let can be used to bind this control variable to T around such an expression. (Rlist 4) ;Signals warning 15 (block bar ;Signals warning 15 (letS ((x (Eup :by 10))) (if (> x 15) (return-from bar x)))) => 20 (compiler-let ((*permit-non-terminating-oss-expressions* T)) (block bar (letS ((x (Eup :by 10))) (if (> x 15) (return-from bar x))))) => 20 *last-oss-loop* This variable contains the loop most recently produced by the OSS macro package. After evaluating (or macro-expanding) an OSS expression, this variable can be inspected in order to see the code which was produced. *last-oss-error* This variable contains the most recently printed warning or error message produced by the OSS macro package. The information in this variable can be useful for tracking down errors. Side-Effects The OSS macro package works by converting each OSS expression into a loop. This allows the expressions to be evaluated very efficiently, but radically changes the order in which computations are performed. In addition, off-line ports are supported by code motion. Given all of these changes, it is not surprising that OSS expressions are primarily intended to be used in situations where there are no side-effects. Due to the change in computation order, it can be hard to figure out what the result of a side-effect will be. Nevertheless, since side-effects (particularly in the form of input and output) are an inevitable part of programming, several steps are taken in order to make the behavior of OSS expressions containing side-effect operations as easy to understand as possible. First, when implicit mapping is applied, it is applied to as large a subexpression as possible. This makes it straightforward to understand the interaction of the side-effects within a single mapped subexpression. Several examples of this are given in the section above which discusses implicit mapping. Second, wherever possible, the OSS macro package leaves the order of evaluation of the OSS functions in an expression unchanged. Each function is evaluated incrementally an element at a time, but on each cycle, the processing follows the syntactic ordering of the functions in the expression. The one place where order changes are required is when handling off-line ports. However, things are simplified here by ensuring that the evaluation order implied by the order of the inputs of an off-line function is preserved. Third, when determining whether or not each termination point is connected to every output in each on-line subexpression, functions whose outputs are not used for anything are considered to be outputs of the subexpression. The reasoning behind this is that if the outputs are not used for anything, then the function must be being used for side-effect and probably matters that the function get evaluated the full number of times it should be. For example, consider the expressions below. The first expression prints out the numbers in a list and returns the first negative number. The second expression signals a warning and the enumeration of the list is duplicated so that the princ will be applied to all of the elements of the list. (letS* ((x (Elist '(1 2 3 -4 5)))) (princ x) (Rfirst-passive (TselectF #'minusp x))) => -4 ;;The output "123-45" printed. (letS* ((x (Elist '(1 2 3 -4 5)))) ;Signals warning 18 (princ x) (Rfirst (TselectF #'minusp x))) => -4 ;;The output "123-45" printed. 3. Bibliography [1] A. Aho, J. Hopcraft, and J. Ullman, The Design and Analysis of Computer Algorithms, Addison-Wesley, Reading MA, 1974. [2] G. Burke and D. Moon, Loop Iteration Macro, MIT/LCS/TM-169, July 1980. [3] R. Polivka and S. Pakin, APL: The Language and Its Usage, Prentice-Hall, Englewood Cliffs NJ, 1975. [4] G. Steele Jr., Common Lisp: the Language, Digital Press, Maynard MA, 1984. [5] R. Waters, "A Method for Analyzing Loop Programs", IEEE Trans. on Software Engineering, 5(3):237--247, May 1979. [6] R. Waters, Synchronizable Series Expressions: Part II: Overview of the Theory and Implementation, MIT/AIM-959, November 1987 [7] Lisp Machine Documentation for Genera 7.0, Symbolics, Cambridge MA, 1986. 4. Warning and Error Messages In order to facilitate the debugging of OSS expressions, this section discusses the various warning and error messages which can be issued by the OSS macro package while processing the functions described in this document. Error messages describe problems in OSS expressions which make it impossible to process the expression correctly. Warning messages identify less serious situations which are worthy of programmer scrutiny, but which do not prevent the expression from being processed in a way which is, at least probably, correct. Warning and error messages are both printed out in the following format. Error messages (as opposed to warnings) can be identified by the fact that the word "Error" precedes the message number. (The format is shown as it appears on the Symbolics Lisp machine and may differ in minor ways in other systems.) Warning: {Error} message-number in OSS expression: containing OSS expression detailed message For example, the following error message might be printed. Warning: Error 1.1 in OSS expression: (LETS ((X (ELIST NUMBER-LIST)) (Y (EUP (CAR HEADER) :TO 4 :LENGTH 5))) (RLIST (LIST Y X))) Too many keywords specified in a call on Eup: (EUP (CAR HEADER) :TO 4 :LENGTH 5) The first line of each message specifies the number of the warning or error. This number is useful for looking up further information in the documentation below. The next part of the message shows the complete OSS expression which contains the problem. This makes it easier to locate the problem in a program. The remainder of the message describes the particular problem in detail. (The variable *last-oss-error* contains a list of the information which was used to print out the most recent warning or error message.) The OSS macro package reports problems using warn so that processing of other parts of a program can continue, potentially finding other problems. However, each time an OSS error (as opposed to a warning) is detected, the OSS macro package skips over the rest of the OSS expression without performing any additional checks. Therefore, even if there are several OSS errors in an OSS expression, only one OSS error will be reported. When an OSS error is found, a dummy value is inserted in place of the erroneous OSS expression. As a result, it is virtually impossible for the containing program to run correctly. The documentation below describes each of the messages which the OSS macro package can produce. Each description begins with a header line containing a schematic rendition of the message. Italics is used to indicate pieces of specific information which are inserted in the message. The number of the warning or error is shown in the left margin at the beginning of the header. For ease of reference, the messages are described in numerical order. Local errors concerning single OSS functions. The following error messages report errors which are local in that they stem purely from the improper use of a single OSS function. These errors cover only a few special situations. Many (if not most) local errors are reported directly by the standard Common Lisp processor rather than by the OSS macro package. For example, if an OSS function is used with the wrong number of arguments, an error message is issued by the standard macro expander. 1.1 Error: Too many keywords specified in call on Eup: call 1.2 Error: Too many keywords specified in call on Edown: call 1.3 Error: Too many keywords specified in call on Tlatch: call Each of these errors specifies that incompatible keywords have been provided for the indicated function. The entire function call is printed out as shown above. 2 Error: Invalid enumerator arg to TconcatenateF: enumerator This error is issued if the enumerator argument to TconcatenateF fails to be an enumerator---i.e., fails to be an OSS function that has no OSS inputs, at least one OSS output, and which can terminate. 3 Error: Unsupported &-keyword keyword in defunS arglist. This error is issued if an &-keyword other than &optional or &key appears in the argument list of defunS. Other keywords have to be supported by using defmacro directly. (See the discussion of defunS.) 4 Error: AlterS applied to an unalterable form: call This error is issued if alterS is applied to a value which is not alterable. Values are alterable only if they come directly from an enumerator which has an alterable value, or come indirectly from such an enumerator via one or more transducers which allow alterability to pass through. 5 Error: Malformed lambdaS argument arg. This error message is issued if an argument of a lambdaS fails to be a valid variable. In particular, it is issued if the argument, is not a symbol, is T or nil, is a symbol in the keyword package, or is an &-keyword. (It is also erroneous for such a variable to be declared special. However, this error is only reported on the Symbolics Lisp Machine.) 6 Error: LambdaS used in inappropriate context: call This error message is issued if a lambdaS ends up (after macro expansion of the surrounding code) being used in any context other than as the quoted first argument of a funcallS. 7 Error: Wrong number of args to funcallS: call This error message is issued if a use of funcallS does not contain a number of arguments which is compatible with the number of arguments expected by the OSS functional argument. 8 Error: Only n return values present where m expected: call This error message is issued if an OSS function is used in a situation where it is expected to return more values than it actually does---for example, if a letS tries to bind two values from an OSS function which only returns one, or pass-valS tries to obtain two values from an OSS function which only returns one. (Non-OSS functions return extra values of nil if they are requested to produce more values than they actually do.) Warnings and errors concerning OSS variables. The following warnings and errors concern the creation and use of letS and lambdaS variables. Like the errors above, they are quite local in nature and relatively easy to fix. 9 Error: Malformed letS{*} binding pair pair. This error message is issued if a letS or letS* binding pair fails to be either a list of a valid variable and a value, or a list of a list of valid variables and a value. The criterion for what makes a variable valid is the same as the one used in Error 5, except that a binding pair can contain nil instead of a variable. 10 Warning: The variable(s) vars declared TYPE OSS in a letS{*}. This warning message is issued if one or more variables in a letS are explicitly declared to be of type oss. The explicit declarations are ignored. 11 Warning: The letS{*} variable variable is unused in: call This warning message is issued if a variable in a letS is never referenced in the body of the letS. Note that these variables cannot be referenced inside a nested lambda or lambdaS. 12 Error: The letS{*} variable var setqed. This error message is issued if a letS variable (either OSS or non-OSS) is assigned to in the body of a letS. It is also issued if any of the variables bound by a lambdaS or defunS are assigned to. Non-local warnings and errors concerning complete OSS expressions. The following warnings and errors concern non-local problems in OSS expressions. The first two are discussed in further detail in the section on implicit mapping. 13 Warning: Decomposition moves: code out of a binding scope: surround This warning is issued if the processing preparatory to implicit mapping causes a subexpression to be moved out of the binding scope for one of the variables in it. The problem can be fixed by using letS to create the binding scope, or by moving the binding form so that it surrounds the entire OSS expression. (The testing for this problem is somewhat approximate in nature. It can miss some erroneous situations and can complain in some situations where there is no problem. Due to this latter difficulty, the OSS macro package merely issues a warning message rather than issuing an error message.) 14 Error: OSS value carried to non-OSS input by data flow from: call to: call As illustrated below, this error is issued whenever data flow connects an OSS output to a non-OSS input of an OSS function as in the example below. (If the expression in question is intended to contain a nested loop, the error can be fixed by wrapping the nested portion in a mapS.) Warning: Error 14 in OSS expression: (Rlist (Rlist (Elist (Elist '((1 2) (3 4)))))) OSS value carried to non-OSS input by data flow from: (Elist '((1 2) (3 4))) to: (Elist (Elist '((1 2) (3 4)))) The error message prints out two pieces of code in order to indicate the source and destination of the data flow in question. The outermost part of the first piece of code shows the function which creates the value in question. The outermost function in the second piece of code shows the function which receives the value. (Entire subexpressions are printed in order to make it easier to locate the functions in question within the OSS expression as a whole.) If nesting of expressions is used to implement the data flow, then the first piece of code will be nested in the second one. 15 Warning: Non-terminating OSS expression: expr This warning message is issued whenever a complete OSS expression appears incapable of terminating. The expression in question is printed. It may well be only a subexpression of the OSS expression being processed. A warning message is issued instead of an error message, because the expression may in fact be capable of terminating or the expression might not be intended to terminate. (This warning message can be turned off by using the variable *permit-non-terminating-oss-expressions*.) Warnings concerning the violation of restrictions. The following warnings are issued when an OSS expression violates one of the isolation restrictions or the requirement that within each on-line subexpression, there must be a data flow path from each termination point to each output. In each case, the violation is automatically fixed by the macro package. However, in order to achieve high efficiency, the user should fix the violation explicitly rather than relying on the automatic fix. 16 Warning: Non-isolated non-oss data flow from: call to: call This warning is issued if an OSS expression violates the non-OSS data flow isolation restriction. As shown below, the message prints out two pieces of code which indicate the data flow in question. Warning: 16 in OSS expression: (LETS* ((NUMS (EVECTOR '#(3 2 8))) (TOTAL (REDUCEF 0 #'+ NUMS))) (RVECTOR (/ NUMS TOTAL))) Non-isolated non-OSS data flow from: (REDUCEF 0 #'+ NUMS) to: (/ NUMS TOTAL) The OSS macro package automatically fixes the isolation restriction violation by duplicating subexpressions until the data flow in question becomes isolated. (In the example above, the vector enumeration gets copied.) However, the macro package is not guaranteed to minimize the amount of code copied. In addition, it is sometimes possible for a programmer to fix an expression much more efficiently without using any code copying. As a result, it is advisable for programmers to fix these violations explicitly, rather than relying on the automatic fixes provided by the OSS macro package. 17.1 Warning: Non-isolated oss input at the end of the data flow from: call to: call 17.2 Warning: Non-isolated oss output at the start of the data flow from: call to: call One of these warnings is issued if an OSS expression violates the off-line port isolation restriction. The warning message prints out two pieces of code which indicate a data flow which ends (or starts) on the port in question. Code copying is automatically applied in order to fix the violation. It is worthwhile to try and think of a more efficient way to fix the violation. As with Warning 16, even if code copying is the only thing which can be done, it is better for the programmer to do this explicitly. 18 Warning: No data flow path from the termination point: call to the output: call This warning is issued if a termination point in an on-line subexpression of an OSS expression is not connected by data flow to one of the outputs. Code copying is automatically applied in order to fix the violation. (However, the OSS macro package has a tendency to copy a good deal more code than necessary.) The violation can often be fixed much more efficiently by using non-early-terminating OSS functions instead of early-terminating functions or by using Tcotruncate to indicate relationships between inputs. Errors concerning implementation limitations. These errors reflect limitations of the way the OSS macro package is implemented rather than anything fundamental about OSS expressions. 19 Error: LambdaS body too complex to merge into a single unit: forms In general, the OSS macro package is capable of combining together any kind of permissible OSS expression. In particular, there is never a problem as long as the expression as a whole does not have any OSS inputs or OSS outputs. However, in the body of a lambdaS, it is possible to write OSS expressions which have both OSS inputs and OSS outputs. If such an expression has a data flow path from an OSS input to an OSS output which contains a non-OSS data flow arc, then this error message is issued. For example, the error would be issued in the situation below. (funcallS #'(lambdaS (items) ;Signals error 19 (declare (type oss items)) (Elist (Rlist items))) ...) An error message is issued in the situation above, because the situation is unlikely to occur and there is no way to support the situation without resorting to very peculiar code. In particular, the input items in the example above would have to be converted into an off-line input. 20 Error: The form function not allowed in OSS expressions. In general, the OSS macro package has a sufficient understanding of special forms to handle them correctly when they appear in an OSS expression. However, it does not handle the forms compiler-let, flet, labels, or macrolet. The forms compiler-let and macrolet would not be that hard to handle, however it does not seem worth the effort. The forms flet and labels would be hard to handle, because the OSS macro package does not preserve binding scopes and therefore does not have any obvious place to put them in the code it produces. All four forms can be used by simply wrapping them around entire OSS expressions rather than putting them in the expressions. 21--27 Documentation for these errors appears in [6]. 5. Index of Functions This section is an index and concise summary of the functions, variables, and special forms described in this document. Each entry shows the inputs and outputs of the function, the page where documentation can be found, and a one line description. The names of OSS functions often start with one of the following prefix letters. E Enumerator. T Transducer. R Reducer. Occasionally, a name will end with one of the following suffix letters. S Special form. F Function that takes functional arguments. In addition, the argument and result names indicate data type restrictions (e.g., number indicates that an argument must be a number, item indicates that there is no type restriction). Plural names are used iff the value in question is an OSS series (e.g., numbers indicates an OSS series of numbers; items indicates an OSS series of unrestricted values). The name of a series input or output begins with "O" iff it is off-line. alterS destinations items => items Alters the values in destinations to be items. defunS name lambda-list {doc} {decl}* &body expr-list Defines an OSS function, see lambdaS. Ealist alist &optional (test #'eql) => keys values Creates two series containing the keys and values in an alist. Edown &optional (start 0) &key (:by 1) :to :above :length => numbers Creates a series of numbers by counting down from start by :by. Efile name => items Creates a series of the forms in the file named name. Efringe tree &optional (leaf-test #'atom) => leaves Creates a series of the leaves of a tree. Ehash table => keys values Creates two series containing the keys and values in a hash table. Elist list &optional (end-test #'endp) => elements Creates a series of the elements in a list. EnumerateF init step &optional test => items Creates a series by applying step to init until test returns non-null. Enumerate-inclusiveF init step test => items Creates a series containing one more element than EnumerateF. Eoss &rest expr-list => items Creates a series of the results of the expressions. Eplist plist => indicators values Creates two series containing the indicators and values in a plist. Esequence sequence &optional (indices (Eup)) => elements Creates a series of the elements in a sequence. Esublists list &optional (end-test #'endp) => sublists Creates a series of the sublists in a list. Esymbols &optional (package *package*) => symbols Creates a series of the symbols in package. Etree tree &optional (leaf-test #'atom) => nodes Creates a series of the nodes in a tree. Eup &optional (start 0) &key (:by 1) :to :below :length => numbers Creates a series of numbers by counting up from start by :by. Evector vector &optional (indices (Eup)) => elements Creates a series of the elements in a vector. funcallS function &rest expr-list => result Applies an OSS function to the results of the expressions. lambdaS var-list {decl}* &body expr-list Form for specifying literal OSS functions. *last-oss-error* Variable containing a description of the last OSS warning or error. *last-oss-loop* Variable containing the loop the last OSS expression was converted into. letS var-value-pair-list {decl}* &body expr-list => result Binds OSS variables in parallel. letS* var-value-pair-list {decl}* &body expr-list => result Binds OSS variables sequentially. mapS &body expr-list => items Causes expr-list to be mapped over the OSS variables in it. oss-tutorial-mode &optional (T-or-nil T) => state-of-tutorial-mode If called with an argument of T, turns tutorial mode on. pass-valS n expr => &rest multiple-value-result Used to pass multiple values from a non-OSS function into an OSS expression. *permit-non-terminating-oss-expressions* When non-null, inhibits error messages about non-terminating OSS expressions. prognS &body expr-list => result Delineates an OSS expression. Ralist keys values => alist Combines a series of keys and a series of values together into an alist. Rand bools => bool Computes the and of the elements of bools, terminating early. Rand-late bools => bool Computes the and of the elements of bools. Rappend lists => list Appends the elements of lists together into a single list. Rbag items => list Combines the elements of items together into an unordered list. ReduceF init function items => result Computes a cumulative value by applying function to the elements of items. Rfile name items &rest option-plist => T Prints the elements of items into a file. Rfirst items &optional (default nil) => item Returns the first element of items, terminating early. Rfirst-late items &optional (default nil) => item Returns the first element of items. Rhash keys values &rest option-plist => table Combines a series of keys and a series of values together into a hash table. Rlast items &optional (default nil) => item Returns the last element of items. Rlength items => number Returns the number of elements in items. Rlist items => list Combines the elements of items together into a list. Rmax numbers => number Returns the maximum element of numbers. Rmin numbers => number Returns the minimum element of numbers. Rnconc lists => list Destructively appends the elements of lists together into a single list. Rnth n items &optional (default nil) => item Returns the nth element of items, terminating early. Rnth-late n items &optional (default nil) => item Returns the nth element of items. Ror bools => bool Computes the or of the elements of bools, terminating early. Ror-late bools => bool Computes the or of the elements of bools. Rplist indicators values => plist Combines a series of indicators and a series of values together into a plist.} Rsum numbers => number Computes the sum of the elements in numbers. Rvector items &key (:size 32) &rest option-plist => vector Combines the elements of items together into a vector. showS thing &optional (format "~%~S") (stream *standard-output*) => thing Displays thing for debugging purposes. Tchunk amount Oitems => lists Creates a series of lists of length amount of non-overlapping subseries of Oitems. Tconcatenate Oitems1 Oitems2 &rest more-Oitems => items Concatenates two or more series end to end. TconcatenateF Enumerator Oitems => items Concatenates the results of applying Enumerator to the elements of Oitems. Tcotruncate items &rest more-items => initial-items &rest more-initial-items Truncates all the inputs to the length of the shortest input. Texpand bools Oitems &optional (default nil) => items Spreads the elements of items out into the indicated positions. Tlastp Oitems => bools items Determines which element of the input is the last. Tlatch items &key :after :before :pre :post => masked-items Modifies a series before or after a latch point. TmapF function &rest items-list => items Maps function over the input series. Tmask Omonotonic-indices => bools Creates a series continuing T in the indicated positions. Tmerge Oitems1 Oitems2 comparator => items Merges two series into one. Tpositions Obools => indices Returns a series of the positions of non-null elements in Obools. Tprevious items &optional (default nil) (amount 1) => shifted-items Shifts items to the right by amount inserting default. Tremove-duplicates Oitems &optional (comparator #'eql) => items Removes the duplicate elements from a series. TscanF {init} function items => results Computes cumulative values by applying function to the elements of items. Tselect bools &optional items => Oitems Selects the elements of items corresponding to non-null elements of bools. TselectF pred Oitems => items Selects the elements of Oitems for which pred is non-null. Tsplit items bools &rest more-bools => Oitems1 Oitems2 &rest more-Oitems Divides a series into multiple outputs based on bools. TsplitF items pred &rest more-pred => Oitems1 Oitems2 &rest more-Oitems Divides a series into multiple outputs based on pred. Tsubseries Oitems start &optional below => items Returns the elements of Oitems from start up to, but not including, below. Tuntil bools items => initial-items Returns items up to, but not including, the first non-null element of bools. TuntilF pred items => initial-items Returns items up to, but not including, the first element which satisfies pred. Twindow amount Oitems => lists Creates a series of lists of length amount of successive overlapping subseries. type oss &rest variable-list Declaration used to specify that variables are OSS variables. valS &rest expr-list => &rest multiple-value-result Returns multiple series values. \ No newline at end of file diff --git a/lispusers/osstst.lisp b/lispusers/osstst.lisp new file mode 100644 index 00000000..7eb067f7 --- /dev/null +++ b/lispusers/osstst.lisp @@ -0,0 +1 @@ +;-*- Syntax:COMMON-LISP -*- ;------------------------------------------------------------------------ ; ; Copyright (c) Richard C. Waters, 1988 ; ;------------------------------------------------------------------------ ; ; This is a file of test cases to test OSS. Just load it and run the ;function (DO-TESTS). It prompts you for the name of a scratch file ;to use when testing. It then prints out identifying numbers of tests ;as it performs one test after another. When all of the tests have ;been run a summary line is printed saying how many tests failed. ; Whenever a test fails for any reason, an error is signalled. To continue ;testing call the function (MORE) either within the break, or at top ;level after aborting the execution of a test. (The latter is useful ;if a test leads to an infinite loop.) When all of the tests have ;been completed, the variable TESTS-FAILED contains a list of the ;numbers of the tests that failed. (You can look at the tests ;themselves by evaluating (NTH N TEST-LIST) for any test number.) ; After running the tests and fixing problems which arise you may wish ;to run some or all of the tests again. Calling (DO-TESTS) runs all ;of the tests again. Calling (DO-FAILED-TESTS) runs just the tests ;which failed the first time. (The variable TESTS-FAILED is updated ;to reflect the new state of affairs in either case.) Calling ;(DO-TEST n) runs just the test with the given number. (In some ;lisps, if you run the tests more than once without rstarting the ;lisp, you can get some warnings about redefining functions called ;FOOn. These do not indicate any problem.) ;THINGS TO DO BY HAND: Look at what Esymbols does in detail. (use-package "OSS") (proclaim '(special form test-list tests-failed)) (defvar in-tester nil) (defvar tests nil) (defvar test-file nil) (defun do-tests () (format T "~% Running the suit of ~S test cases~%" (length test-list)) (setq tests (do ((i (1- (length test-list)) (1- i)) (r nil (cons i r))) ((minusp i) r)) tests-failed nil) (do-many-tests)) (defun do-failed-tests () (format T "~% Running the ~S failed tests~%" (length tests-failed)) (setq tests tests-failed tests-failed nil) (do-many-tests)) (defun do-many-tests () (loop (when (null tests) (setq tests-failed (nreverse tests-failed)) (if (zerop (length tests-failed)) (format T "~2% OSS passed all tests.") (format T "~2% OSS failed ~A tests." (length tests-failed))) (return (values))) (format T " ~A" (car tests)) (do-test (pop tests)))) (defun more () (if in-tester (throw 'in-tester nil) (do-many-tests))) (defun do-test (n) (when (null test-file) (format T "~%Type a pathname of a scratch disk file ending in : ") (setq test-file (read-line))) (catch 'in-tester (let* ((info (nth n test-list)) (*break-on-warnings* T) (tester (if (symbolp (car info)) (pop info) 'test-ordinary)) (value (cadr info)) (pop-if-no-failure nil) (in-tester T)) (setq form (car info)) (when (not (member n tests-failed)) (push n tests-failed) (setq pop-if-no-failure T)) (let ((result (funcall tester (oss::iterative-copy-tree form)))) (when (not (equal result value)) (format t "~%form: ~S~% desired value ~S~% actual value ~S~%" form value result) (pprint *last-oss-loop*) (error "failed test")) (when pop-if-no-failure (pop tests-failed)))))) ;doesn't happen when abort out of test error ;This is useful for special test cases, and rerunning the last test case. (defmacro r (&optional (f nil)) (if f (setq form f)) (setq f (oss::iterative-copy-tree form)) (gensym 1) (setq f (macroexpand f)) (pprint f) (cond ((Y-or-N-p "continue") f))) ;Helper funtions for tests. (defun test-ordinary (form) (funcall (compile nil `(lambda () ,form)))) (defun test-def (form) (eval (car form)) (compile (cadar form)) (test-ordinary (cadr form))) (defun test-warn (form) (let (v (*break-on-warnings* nil)) (setq *last-oss-error* nil) (with-output-to-string (*error-output*) (setq v (test-ordinary form))) (list v (car *last-oss-error*)))) (defun test-tut (form) (unwind-protect (progn (oss-tutorial-mode T) (test-ordinary form)) (oss-tutorial-mode nil))) (defmacro dummy-mac (stuff) `(car ,stuff)) (defun decls (arg) (declare (ignore arg)) (decls0 *last-oss-loop*)) (defun decls0 (tree) (cond ((not (consp tree)) nil) ((eq (car tree) 'declare) tree) (T (do ((l tree (cdr l))) ((not (consp l)) nil) (let ((x (decls0 (car l)))) (if x (return x))))))) ;the first few pages of tests attempt to test each of the different ;series operations in the series function library. (setq test-list '( ((Rlist (Eoss 'a 'b 'c)) (a b c)) ((Rlist (Eoss 'a 'b 'c :R)) (a b c)) ((Rlist (list (Eoss 'a0 :R 'a1 'b1) (Elist '(z a b c)))) ((a0 z) (a1 a) (b1 b) (a1 c))) ((Rlist (list (Eoss :R 'a1 'b1) (Elist '(a b c)))) ((a1 a) (b1 b) (a1 c))) ((Rlist (list (Eoss :R 'a1) (Elist '(a b c)))) ((a1 a) (a1 b) (a1 c))) ((Rlist (Eoss)) ()) ((Rlist (list (Eup) (Elist '(a b c)))) ((0 a) (1 b) (2 c))) ((Rlist (list (Eup 4 :by 3) (Elist '(a b c)))) ((4 a) (7 b) (10 c))) ((Rlist (Eup 0 :to 3)) (0 1 2 3)) ((Rlist (Eup 0 :below 3)) (0 1 2)) ((Rlist (Eup 0 :length 3)) (0 1 2)) ((Rlist (Eup 2 :to 3)) (2 3)) ((Rlist (Eup 2 :below 3)) (2)) ((Rlist (Eup 2 :length 3)) (2 3 4)) ((Rlist (Eup 4 :to 3)) ()) ((Rlist (Eup 4 :below 3)) ()) ((Rlist (Eup 4 :length 3)) (4 5 6)) ((Rlist (Eup :to 3 :by 2)) (0 2)) ((Rlist (Eup :to 4 :by 2)) (0 2 4)) ((Rlist (Eup :below 3 :by 2)) (0 2)) ((Rlist (Eup :below 4 :by 2)) (0 2)) ((Rlist (Eup :length 3 :by 2)) (0 2 4)) ((Rlist (round (* 10. (Eup 1.5 :by .2 :below 2.0)))) (15 17 19)) ((Rlist (list (Edown) (Elist '(a b c)))) ((0 a) (-1 b) (-2 c))) ((Rlist (list (Edown 4 :by 3) (Elist '(a b c)))) ((4 a) (1 b) (-2 c))) ((Rlist (Edown 0 :to -3)) (0 -1 -2 -3)) ((Rlist (Edown 0 :above -3)) (0 -1 -2)) ((Rlist (Edown 0 :length 3)) (0 -1 -2)) ((Rlist (Edown 4 :to 3)) (4 3)) ((Rlist (Edown 4 :above 3)) (4)) ((Rlist (Edown 4 :length 3)) (4 3 2)) ((Rlist (Edown :to -3 :by 2)) (0 -2)) ((Rlist (Edown :to -4 :by 2)) (0 -2 -4)) ((Rlist (Edown :above -3 :by 2)) (0 -2)) ((Rlist (Edown :above -4 :by 2)) (0 -2)) ((Rlist (Edown :length 3 :by 2)) (0 -2 -4)) ((Rlist (Esublists '(a b c))) ((a b c) (b c) (c))) ((Rlist (Esublists '(a b . c) #'atom)) ((a b . c) (b . c))) ((Rlist (Esublists ())) ()) ((Rlist (Elist '(a b c))) (a b c)) ((Rlist (Elist '(a b . c) #'atom)) (a b)) ((Rlist (Elist ())) ()) ((letS ((x '(a b c))) (alterS (Elist x) (Eup)) x) (0 1 2)) ((Rlist (Ealist '((1 . a) () (2) (1 . c)))) (1 2)) ((Rlist (Ealist ())) ()) ((letS (((key value) (Ealist '((1 . a) () (2) (1 . c))))) (Rlist (list key value))) ((1 a) (2 nil))) ((let ((alist '((a . 1) (b . 2)))) (letS (((key val) (Ealist alist))) (alterS key (list key)) (alterS val (list val))) alist) (((a) . (1)) ((b) . (2)))) ((Rlist (Eplist '(P1 1 P2 2 P1 3 P3 4))) (P1 P2 P3)) ((Rlist (Eplist ())) ()) ((letS (((key value) (Eplist '(P1 1 P2 2 P1 3)))) (Rlist (list key value))) ((P1 1) (P2 2))) ((let ((plist '(a 1 b 2))) (letS (((key val) (Eplist plist))) (alterS key (list key)) (alterS val (list val))) plist) ((a) (1) (b) (2))) ((Rlist (Etree '(1 (2 3) 4))) ((1 (2 3) 4) 1 (2 3) 2 3 4)) ((Rlist (Etree '(1 (2 3) 4) #'atom)) ((1 (2 3) 4) 1 (2 3) 2 3 4)) ((Rlist (Etree '(1 (2 3) 4) #'(lambda (n) (not (and (consp n) (cddr n)))))) ((1 (2 3) 4) 1 (2 3) 4)) ((Rlist (Etree nil)) (nil)) ((let ((tree '((3) 4))) (letS ((leaf (Efringe tree))) (if (evenp leaf) (alterS leaf (- leaf)))) tree) ((3) -4)) ((Rlist (Efringe '((1 2 ((3 . 4) 4) (5) () (((6))))))) (1 2 3 4 5 nil 6)) ((Rlist (Efringe '(1 2 ((3 . 4) 4) (5) () (((6)))) #'(lambda (n) (not (and (consp n) (cdr n)))))) (1 2 3 4 (5) nil (((6))))) ((Rlist (Efringe ())) (nil)) ((letS ((z '(a b (3 . e) d))) (letS* ((x (Efringe z))) (alterS x (list x))) z) ((a) (b) ((3) . e) (d))) ((Rlist (Evector '#(1 2 3))) (1 2 3)) ((Rlist (Evector '#())) ()) ((Rlist (Evector '#(1 2 3) (Eup 1 :to 2))) (2 3)) ((Rlist (Evector '#(1 2 3) (Eoss 2 0 1 9 0))) (3 1 2)) ((letS ((v "FOOBAR")) (alterS (Evector v (Eoss 2 3 4)) #\-) v) "FO---R") ((letS ((v "FOOBAR")) (alterS (Evector v) #\-) v) "------") ((Rlist (Esequence '#(1 2 3))) (1 2 3)) ((Rlist (Esequence '#(1 2 3) (Eup 1 :to 2))) (2 3)) ((Rlist (Esequence '#(1 2 3) (Eoss 2 0 1 9 0))) (3 1 2)) ((letS ((v "FOOBAR")) (alterS (Esequence v (Eoss 2 3 4)) #\-) v) "FO---R") ((Rlist (Esequence '(1 2 3))) (1 2 3)) ((Rlist (Esequence '(1 2 3) (Eup 1 :to 2))) (2 3)) ((Rlist (Esequence '(1 2 3) (Eoss 2 0 1 9 0))) (3 1 2)) ((letS ((y '(F O O B A R))) (alterS (Esequence y (Eoss 2 3 4)) '-) y) (F O - - - R)) ((letS (((key val) (Ehash (let ((x (make-hash-table))) (setf (gethash 'color x) 'brown) (setf (gethash 'name x) 'fred) x)))) (sort (Rlist (cons key val)) #'(lambda (x y) (string-lessp (string (car x)) (string (car y)))))) ((color . brown) (name . fred))) ((progn (Rfirst (Esymbols)) nil) nil) ;grotesquely weak tests ((progn (Rfirst (Esymbols (find-package "OSS"))) nil) nil) ((Rlist (car (EnumerateF '(a b c) #'cdr #'null))) (a b c)) ((Rlist (list (Elist '(a b c)) (car (EnumerateF '(1 2) #'cdr)))) ((a 1) (b 2) (c nil))) ((Rlist (car (Enumerate-inclusiveF '(a b c) #'cdr #'null))) (a b c nil)) ((Rlist (car (Enumerate-inclusiveF () #'cdr #'null))) (nil)) ((Rlist (Tprevious (Elist '(a b c)))) (nil a b)) ((Rlist (Tprevious (Elist '(a b c)) 'fill 2)) (fill fill a)) ((Rlist (Tprevious (Elist '(a b c)) 0)) (0 a b)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)))) (nil 3 nil nil nil)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2)) (nil 3 nil 4 nil)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 0)) (nil nil nil nil nil)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2 :pre 'a)) (A A A A 5)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2 :pre 'a :post 'b)) (A A A A B)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2 :post 'b)) (nil 3 nil 4 B)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2)) (nil 3 nil nil nil)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 0)) (nil nil nil nil nil)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2 :pre 'a)) (A A A 4 5)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2 :pre 'a :post 'b)) (A A A B B)) ((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2 :post 'b)) (nil 3 nil B B)) ((Rlist (Tuntil (Eoss nil nil T nil T) (Eoss 1 2 3))) (1 2)) ((Rlist (Tuntil (Eoss) (Eoss 1 2 3))) ()) ((letS ((x (Eoss 1 2 3 nil nil))) (Rlist (Tuntil (Tprevious (null x)) x))) (1 2 3 nil)) ((Rlist (TuntilF #'null (Eoss 1 2 3 nil nil))) (1 2 3)) ((letS ((fn #'null)) (Rlist (TuntilF fn (Eoss 1 2 3 nil nil)))) (1 2 3)) ((let ((v '(1 -2 3))) (letS ((x (TuntilF #'minusp (Elist v)))) (alterS x (- x))) v) (-1 -2 3)) ((let ((c 1)) (Rlist (cons (Elist '(a b c)) (TmapF #'(lambda () (incf c)))))) ((a . 2) (b . 3) (c . 4))) ((letS* ((tt '((1 2) (3 4))) (e (Elist tt))) (Rlist (TmapF #'(lambda (e f) (list (Rbag (Elist e)) e)) e e))) (((2 1) (1 2)) ((4 3) (3 4)))) ((lets ((e (Elist '((1 2) (3 4))))) (Rlist (TmapF #'(lambda (e) (Rsum (Elist e))) e))) (3 7)) ((Rlist (TmapF #'dummy-mac (Elist '((1) (2))))) (1 2)) ((Rlist (TscanF 0 #'+ (Elist '(1 2 3)))) (1 3 6)) ((Rlist (TscanF 0 #'- (Elist '(1 2 3)))) (-1 -3 -6)) ((Rlist (TscanF #'+ (Elist '(1 2 3)))) (1 3 6)) ((Rlist (TscanF #'- (Elist '(1 2 3)))) (1 -1 -4)) ((letS (((x y) (Tcotruncate (Eoss 1 2 3) (Eoss 4 5)))) (list (Rsum x) (Rsum y))) (3 9)) ((letS (((x y) (Tcotruncate (Eoss) (Eoss 4 5)))) (list (Rsum x) (Rsum y))) (0 0)) ((letS (((x) (Tcotruncate (Eoss 4 5)))) (list (Rsum x))) (9)) ((letS (((x y) (Tcotruncate (Eoss 1 2 3) (Eoss 4 5)))) (list (Rsum (+ x y)) (Rsum y))) (12 9)) ((Rlist (Tremove-duplicates (Eoss 1 2 1 2 3))) (1 2 3)) ((Rlist (Tremove-duplicates (Elist '((1 a) (1 b) (2 c) (1 d) (3 e) (2 f))) #'(lambda (x y) (eql (car x) (car y))))) ((1 a) (2 c) (3 e))) ((Rlist (Tchunk 0 (Elist '(a b c)))) ((a) (b) (c))) ((Rlist (Tchunk 1 (Elist '(a b c)))) ((a) (b) (c))) ((Rlist (Tchunk 2 (Elist '(a b c)))) ((a b))) ((Rlist (Tchunk 3 (Elist '(a b c)))) ((a b c))) ((Rlist (Tchunk 4 (Elist '(a b c)))) ()) ((Rlist (Twindow 1 (Elist '(a b c)))) ((a) (b) (c))) ((Rlist (Twindow 2 (Elist '(a b c)))) ((a b) (b c))) ((Rlist (Twindow 4 (Elist '(a b c)))) ()) ((Rlist (Tconcatenate (Elist '(a b c)) (Elist '(1 2 3)))) (a b c 1 2 3)) ((Rlist (Tconcatenate (Eoss) (Elist '(a b c)) (Eoss) (Elist '(a b c)))) (a b c a b c)) ((LetS ((x (Eoss 1 2)) (y (Eoss 3 4))) (Rlist (Tconcatenate x y))) (1 2 3 4)) ((Rlist (TconcatenateF #'Elist (Elist '((1 2) (3) () (4 5))))) (1 2 3 4 5)) ((Rlist (TconcatenateF #'Elist (Elist ()))) ()) ((lets (((p v) (TconcatenateF #'Eplist (Elist '((a 1) (b 2 c 3)))))) (Rlist (list p v))) ((a 1) (b 2) (c 3))) ((Rlist (Tsubseries (Elist '(a b c)) 1 2)) (b)) ((Rlist (Tsubseries (Elist '(a b c)) 1)) (b c)) ((let ((v '(1 -2 3))) (letS ((x (Tsubseries (Elist v) 1))) (alterS x (- x))) v) (1 2 -3)) ((Rlist (Tpositions (Elist '(a nil 3 nil T nil)))) (0 2 4)) ((Rlist (Tpositions (Elist '(nil 3 T nil)))) (1 2)) ((Rlist (Tpositions (Elist '(nil nil)))) ()) ((Rlist (Tsubseries (Tmask (Elist '())) 0 6)) (nil nil nil nil nil nil)) ((Rlist (Tsubseries (Tmask (Elist '(0 2 4))) 0 6)) (T nil T nil T nil)) ((Rlist (Tmerge (Eoss 1 3 7 9) (Eoss 4 5 8) #'<)) (1 3 4 5 7 8 9)) ((Rlist (Tmerge (Eoss 4 5 8) (Eoss 1 3 7 9) #'<)) (1 3 4 5 7 8 9)) ((letS (((lp a) (Tlastp (Elist '(a b c d))))) (list (Rlist lp) (Rlist a))) ((nil nil nil T) (a b c d))) ((letS (((lp a) (Tlastp (Elist '(a))))) (list (Rlist lp) (Rlist a))) ((T) (a))) ((letS (((lp a) (Tlastp (Elist nil)))) (list (Rlist lp) (Rlist a))) (nil nil)) ((Rlist (Tselect (Eoss t t nil nil t) (Elist '(1 2 nil nil -4)))) (1 2 -4)) ((Rlist (Tselect (Elist '(1 2 nil nil -4)))) (1 2 -4)) ((letS ((x (Elist '(1 -1 2 -2)))) (Rlist (Tselect (plusp x) x))) (1 2)) ((letS ((x (Elist '(1 -1 2 -2)))) (Rlist (if (plusp x) x))) (1 nil 2 nil)) ((letS ((x (Elist '(1 -1 2 -2)))) (Rlist (if (plusp x) x (- x)))) (1 1 2 2)) ((letS ((x (Elist '(0 1 -1 2 -2)))) (Rlist (list (Tselect (plusp x) x) (Eup)))) ((1 0) (2 1))) ((letS ((x (Elist '(0 1 -1 2 -2))) (tag (Eup))) (Rlist (list (Tselect (plusp x) x) tag))) ((1 0) (2 1))) ((Rlist (TselectF #'minusp (Elist '(1 2 -2 3 -4)))) (-2 -4)) ((letS ((fn #'minusp)) (Rlist (TselectF fn (Elist '(1 2 -2 3 -4))))) (-2 -4)) ((let ((v '(1 -2 3))) (letS ((x (TselectF #'minusp (Elist v)))) (alterS x (- x))) v) (1 2 3)) ((Rlist (Texpand (Eoss nil T nil T nil) (Elist '(a b c)))) (nil a nil b nil)) ((Rlist (Texpand (Eoss nil T nil T) (Elist '(a b c)) T)) (T a T b)) ((letS* ((x (Elist '(1 -1 2 -2))) ((y+ y-) (Tsplit x (Eoss :R t nil t nil)))) (list (Rlist x) (Rlist y+) (Rlist y-))) ((1 -1 2 -2) (1 2) (-1 -2))) ((letS* ((x (Elist '(1 0 -1 2 0 -2))) ((y+ y- y0) (Tsplit x (Eoss :R t nil nil t nil nil) (Eoss :R nil nil t nil nil t)))) (list (Rlist y+) (Rlist y-) (Rlist y0) (Rlist x))) ((1 2) (-1 -2) (0 0) (1 0 -1 2 0 -2))) ((letS* ((x (Elist '(1 -1 2 -2))) ((y+ y-) (TsplitF x #'plusp))) (list (Rlist x) (Rlist y+) (Rlist y-))) ((1 -1 2 -2) (1 2) (-1 -2))) ((letS* ((x (Elist '(1 -1 2 -2))) (y+ (TsplitF x #'plusp))) (Rlist (+ y+ y+))) (2 4)) ((letS* ((x (Elist '(1 -1 2 -2))) (y+ (TsplitF x #'plusp))) (list (Rlist y+) (Rsum y+))) ((1 2) 3)) ((letS* ((x (Elist '(1 -1 2 -2))) (y+ (TsplitF x #'plusp))) (Rlist (Tconcatenate y+ (Eoss 5 6)))) (1 2 5 6)) ((letS* ((x (Elist '(1 0 -1 2 0 -2))) ((y+ y- y0) (TsplitF x #'plusp #'minusp))) (list (Rlist y+) (Rlist y-) (Rlist y0) (Rlist x))) ((1 2) (-1 -2) (0 0) (1 0 -1 2 0 -2))) ((letS* ((x (Elist '(1 (nil) (3)))) ((y+ y- y0) (TsplitF x #'numberp #'car))) (list (Rlist y+) (Rlist y-) (Rlist y0))) ((1) ((3)) ((nil)))) ((Rlist (Elist '(a b c))) (a b c)) ((Rbag (Elist '(a b c))) (c b a)) ((Rbag (Tremove-duplicates (Elist '(a (a) a (a) b a)) #'equal)) (b (a) a)) ((list (Rappend (Eoss '(a b c) '(a b c))) '(a b c)) ((a b c a b c) (a b c))) ((Rappend (Eoss)) ()) ((letS ((a (list 1 2)) (b '(3 4))) (Rappend (Eoss a b)) a) (1 2)) ((Rnconc (Elist '(() (a b) () (c d) (e) ()))) (a b c d e)) ((Rnconc (Eoss)) ()) ((letS ((a (list 1 2)) (b '(3 4))) (Rnconc (Eoss a b)) a) (1 2 3 4)) ((Ralist (Elist '(d e d)) (Elist '(a b c))) ((d . a) (e . b) (d . c))) ((Ralist (Elist '(d e d)) (Elist '())) ()) ((Rplist (Elist '(d e d)) (Elist '(a b c))) (d a e b d c)) ((Rplist (Elist '(d e d)) (Elist '())) ()) ((let ((h (Rhash (Elist '(color name)) (Elist '(brown fred))))) (letS (((key val) (Ehash h))) (sort (Rlist (cons key val)) #'(lambda (x y) (string-lessp (string (car x)) (string (car y))))))) ((color . brown) (name . fred))) #-:GCLISP((concatenate 'list (Rvector (Elist '(a b c)))) (a b c)) #-:GCLISP((concatenate 'list (Rvector (Eoss))) ()) #-:GCLISP((Rvector (Eoss #\B #\A #\R) :element-type 'string-char) "BAR") ((concatenate 'list (Rvector (Elist '(a b c)) :size 3)) (a b c)) ((concatenate 'list (Rvector (Elist '(a b c)) :size 4 :initial-element 0)) (a b c 0)) ((progn (if (probe-file test-file) (delete-file test-file)) (Rfile test-file (Elist '(a b c))) (Rlist (Efile test-file))) (a b c)) ((Rfirst-late (Elist '(a b c))) a) ((Rfirst-late (Eoss)) nil) ((Rfirst-late (Eoss) 'fill) fill) ((Rlast (Elist '(a b c))) c) ((Rlast (Eoss)) nil) ((Rlast (Eoss) 'fill) fill) ((Rnth-late 1 (Elist '(a b c))) b) ((Rnth-late 1 (Eoss)) nil) ((Rnth-late 1 (Eoss) 'fill) fill) ((Rlength (Elist '(a b c))) 3) ((Rlength (Eoss)) 0) ((Rlength (Tselect (plusp (Eoss 1 -1 2 -2)))) 2) ((Rsum (Elist '(1 2 3))) 6) ((Rsum (Elist nil)) 0) ((Rmin (Elist '(1 2 3))) 1) ((Rmin (Elist nil)) nil) ((Rmax (Elist '(1 2 3))) 3) ((Rmax (Elist nil)) nil) ((Rand-late (Eoss 1 2)) 2) ((Rand-late (Eoss)) T) ((Ror-late (Eoss 1 2)) 1) ((Ror-late (Eoss nil)) nil) ((Ror-late (Eoss)) nil) ((ReduceF 0 #'+ (Elist '(1 2 3))) 6) ((ReduceF 0 #'- (Eoss 1 2 3)) -6) ((ReduceF 0 #'+ (Elist nil)) 0) ((ReduceF T #'+ (Elist nil)) T) ((Rfirst (Elist '(a b c))) a) ((Rfirst (Eoss)) nil) ((Rfirst (Eoss) 'T) T) ((Rfirst (car (Elist '((T) (nil) 4)))) T) ((Rfirst (Tpositions (plusp (Eoss -3 1 -1 3 -2)))) 1) ((Rfirst (Tselect (Eoss nil t nil) (Eoss 0 1 -1 3 -2))) 1) ((Rnth 1 (Elist '(a b c))) b) ((Rnth 1 (Eoss)) nil) ((Rnth 1 (Eoss) 'T) T) ((Rnth 1 (car (Elist '((T) (nil) 4)))) nil) ((Rand (Eoss 1 2)) 2) ((Rand (car (Elist '((T) (nil) 4)))) nil) ((Rand (Eoss)) T) ((Ror (Eoss nil)) nil) ((Ror (car (Elist '((T) (nil) 4)))) T) ((Ror (Eoss)) nil) ;this contains tests of the various special forms supported. ((lets* ((x (Elist '(a b c))) (xx (list x))) (Rlist (list x xx))) ((a (a)) (b (b)) (c (c)))) ((lets* ((x (Elist '(a b c))) (x (list x))) (Rlist x)) ((a) (b) (c))) ((let ((x 9)) (lets ((x (Elist '(a b c))) (xx (list x))) (Rlist (list x xx)))) ((a (9)) (b (9)) (c (9)))) ((lets () (Rlist (Elist '(a b c)))) (a b c)) ((lets* ((e 3) (f (Elist '(a b c))) (g (Rlist f)) (h (Rlist (Elist '(a b c))))) (list e g h)) (3 (a b c) (a b c))) ((letS ((x (Rlist (Elist '(1 2 3))))) (list x) x) (1 2 3)) ((not (null (member '(type integer x) (decls (letS ((x (Elist '(1 2 3)))) (declare (type integer x)) (Rsum x))) :test #'equal))) T) ((letS ()) nil) ((letS (((key value) (Ealist '((a . 1) (b . 2))))) (Rlist (list key value))) ((a 1) (b 2))) ((letS ((key (Ealist '((a . 1) (b . 2))))) (Rlist key)) (a b)) ((let ((x 4)) (letS ((x (Elist '(1 2 3)))) (Rlist (TmapF #'(lambda (y) (+ x y)) x)))) (5 6 7)) ((prognS) nil) ((prognS (Elist '(a b c)) (prognS)) nil) ((prognS (Elist '(a b c)) (funcallS #'(lambdaS ()))) nil) ((multiple-value-list (prognS (TmapF #'sqrt (Elist '(1 2))))) nil) ((Ralist (Elist '(a b)) (* 2 3)) ((a . 6) (b . 6))) ((let ((x 1)) (Ralist (Elist '(a b)) (setq x (1+ x)))) ((a . 2) (b . 2))) ((Rsum (car (Elist '((1) (2))))) 3) ((Rsum (* 2 (Elist '(1 2)))) 6) ((let ((x 1)) (Rlist (list (Elist '(a b)) (setq x (1+ x))))) ((a 2) (b 3))) ((let ((x 1)) (Rlist (list (Elist '(a b)) (Eoss :R (setq x (1+ x)))))) ((a 2) (b 2))) ((Rlist (if (plusp (Elist '(10 -11 12))) (Eup))) (0 nil 2)) ((Rlist (Tselect (plusp (Elist '(10 -11 12))) (Eup))) (0 2)) ((letS ((z (Elist '(1 2)))) (Rlist (list z (mapS 2)))) ((1 2) (2 2))) ((letS ((z (Elist '(1 2)))) (Rlist (list z (mapS)))) ((1 nil) (2 nil))) ((letS ((z (Elist '(1 2)))) (Rlist (mapS (1+ z)))) (2 3)) ((letS ((z (Elist '(1 2)))) (Rlist (mapS (do ((x 1 (1+ x)) (sum 0 (+ sum x))) ((> x z) sum))))) (1 3)) ((letS ((z (Elist '((1 2) (3 4))))) (Rlist (mapS (Rlist (Elist z))))) ((1 2) (3 4))) ((funcalls #'Rlist (Elist '(a b c))) (a b c)) ((Rlist (funcalls #'list (Elist '(a b c)))) ((a) (b) (c))) ((letS ((fn #'list)) (Rlist (funcalls fn (Elist '(a b c))))) ((a) (b) (c))) ((funcalls #'(lambdaS (x) (declare (type oss x)) (Rlist x)) (Elist '(a b c))) (a b c)) (test-def ((defunS foo (list) "doc" (car (Elist list))) (list #+lispm(documentation 'foo 'function) (Rlist (foo '((a) (b) (c)))))) (#+lispm"doc" (a b c))) (test-def ((defunS foo1 (list &optional (plus 1)) (+ (Elist list) plus)) (list (Rlist (foo1 '(1 2 3) 3)) (Rlist (foo1 '(1 2 3))))) ((4 5 6) (2 3 4))) (test-def ((defunS foo2 (list &optional (plus 1 p?)) (list (Elist list) p?)) (list (Rlist (foo2 '(1 2 3) 3)) (Rlist (foo2 '(1 2 3))))) (((1 T) (2 T) (3 T)) ((1 nil) (2 nil) (3 nil)))) (test-def ((defunS foo3 (list &key (plus 1)) (+ (Elist list) plus)) (list (Rlist (foo3 '(1 2 3) :plus 3)) (Rlist (foo3 '(1 2 3))))) ((4 5 6) (2 3 4))) (test-def ((defunS foo4 (list &key (plus #'1+)) (funcall plus (Elist list))) (list (Rlist (foo4 '(1 2 3) :plus #'1-)) (Rlist (foo4 '(1 2 3))))) ((0 1 2) (2 3 4))) (test-def ((defunS foo5 (list &key (k 'list)) (list (Elist list) k)) (list (Rlist (foo5 '(1 2 3) :k 'a)) (Rlist (foo5 '(1 2 3))))) (((1 a) (2 a) (3 a)) ((1 list) (2 list) (3 list)))) ((multiple-value-list (lets ((x (Elist '(a b)))) (valS (Rlist x) (Rbag x)))) ((a b) (b a))) ((Rlist (funcallS #'(lambdaS (pairs) (letS ((p (Elist pairs))) (valS (car p) (cdr p)))) '((a . 1)(b . 2)))) (a b)) ((letS (((x y) (funcallS #'(lambdaS (pairs) (letS ((p (Elist pairs))) (valS (car p) (cdr p)))) '((a . 1)(b . 2))))) (list (Rlist x) (Rlist y))) ((a b) (1 2))) ((letS (((nil y) (funcallS #'(lambdaS (pairs) (letS ((p (Elist pairs))) (valS (car p) (cdr p)))) '((a . 1)(b . 2))))) (Rlist y)) (1 2)) ((letS (((a b) (pass-valS 2 (intern (string (Elist '(x y))))))) (Rlist (list a b))) ((x :internal) (y :internal))) ((letS (((a b) (intern (string (Elist '(x y)))))) (Rlist (list a b))) ((x :internal) (y :internal))) ((let ((v '(1 -2 3))) (letS ((x (TselectF #'minusp (Elist v)))) (alterS x (- x))) v) (1 2 3)) ((letS ((x '(a b c))) (alterS (Elist x) (Eup)) x) (0 1 2)) ((letS ((x '((a) (b) (c)))) (setf (car (Elist x)) (Eup)) x) ((0) (1) (2))) ((lets ((e (Elist (list 1 2)))) (alters e (1+ e)) (rlist e)) (1 2)) ((let ((*print-case* :upcase)) (with-output-to-string (f) (Rbag (Elist (showS '(a b c) " ~S" f))) f)) " (A B C)") ((let ((*print-case* :upcase)) (with-output-to-string (f) (Rbag (showS (Elist '(a b c)) " ~S" f)) f)) " A B C") ((let ((*print-case* :upcase)) (with-output-to-string (f) (showS (Rbag (Elist '(a b c))) " ~S" f) f)) " (C B A)") ((Rlist (funcallS #'(lambda-primitiveS (x) (y) (y) (declare (type oss x y) (type integer y)) (setq y (car x))) (Elist '((1) (2))))) (1 2)) ((funcallS #'(lambda-primitiveS (numbers) (number) (number) (declare (type oss numbers)) (prologS (setq number 0)) (setq number (+ number numbers))) (Elist '(1 2))) 3) ((funcallS #'(lambda-primitiveS (items) (list) (list) (declare (type oss items)) (prologS (setq list nil)) (setq list (cons items list)) (epilogS (setq list (nreverse list)))) (Elist '(1 2))) (1 2)) ((Rlist (funcallS #'(lambda-primitiveS (list) (items) (state items) (declare (type oss items)) (prologS (setq state list)) (if (null state) (terminateS)) (setq items (car state)) (setq state (cdr state))) '(1 2))) (1 2)) ((Rlist (funcallS #'(lambda-primitiveS (Nitems1 Nitems2) (items) (items done) (declare (type oss Nitems1 Nitems2 items)) (prologS (setq done nil)) (if done (go D)) (next-inS Nitems1 (setq done T) (go D)) (setq items Nitems1) (go F) D (next-inS Nitems2) (setq items Nitems2) F) (Elist '(1 2)) (Elist '(3 4)))) (1 2 3 4)) ((letS (((x+ x-) (funcallS #'(lambda-primitiveS (items pred) (Nitems1 Nitems2) (Nitems1 Nitems2) (declare (type oss items Nitems1 Nitems2)) (if (not (funcall pred items)) (go D)) (setq Nitems1 items) (next-outS Nitems1) (go F) D (setq Nitems2 items) (next-outS Nitems2) F) (Elist '(1 -2 3 -4)) #'plusp))) (list (Rsum x+) (Rsum x-))) (4 -6)) (test-def ((defmacro Rcount (items) (let ((counter (gensym))) `(funcallS #'(lambda-primitiveS (items) (result) (result) (declare (type oss items)) (wrapS #'(lambda (body) (list 'let '((,counter 0)) body))) (incf ,counter) (epilogS (setq result ,counter))) ,items))) (Rcount (Elist '(1 2 3)))) 3) ((let ((l (list 1 2))) (letS ((e (funcallS #'(lambda-primitiveS (list) (items) (state parent items) (declare (type oss items)) (prologS (setq state list)) (if (null state) (terminateS)) (setq parent state) (setq items (car state)) (setq state (cdr state)) (alterableS items (car parent))) l))) (alterS e (1+ e)) l)) (2 3)) ((lets ((e (Elist '(1 -2 3)))) (Rlist (funcallS #'(lambda-primitiveS (Nitems) (Nitems) () (declare (type oss Nitems) (type number Nitems)) L (next-inS Nitems) (if (not (plusp Nitems)) (go L))) e))) (1 3)) ((not (null (member '(type number e) (decls (lets ((e (Elist '(1 -2 3)))) (Rlist (funcallS #'(lambda-primitiveS (Nitems) (Nitems) () (declare (type oss Nitems) (type number Nitems)) L (next-inS Nitems) (if (not (plusp Nitems)) (go L))) e)))) :test #'equal))) T) ((letS ((x (Eoss 1 2 3)) (y (Eoss 4 5))) (list (Rsum x) (Rsum y))) (6 9)) ((list (Rsum (Eoss 1 2 3)) (Rsum (Eoss 4 5))) (6 9)) ;the following uses lambdaS to test all kinds of wierd combinations ;mg1 ((funcalls #'(lambdaS (x) (lets ((z (list x))) (list z))) 4) ((4))) ((funcalls #'(lambdaS (x) (declare (type oss x)) (nreverse (Rbag x))) (Elist '(a b c))) (a b c)) ((funcalls #'(lambdaS (x) (declare (type oss x)) (Rlist (list x))) (Elist '(a b c))) ((a) (b) (c))) ;mg2 ((funcalls #'(lambdaS (x y) (declare (type oss x y)) (list (Rlist x) (Rlist (Tselect (plusp y) y)))) (Elist '(a b c)) (Elist '(1 -2 3))) ((a b c) (1 3))) ((funcalls #'(lambdaS (x y) (declare (type oss x y)) (list (Rlist (Tselect (plusp y) y)) (Rlist x))) (Elist '(a b c)) (Elist '(1 -2 3))) ((1 3) (a b c))) ;mg3 ((Rlist (funcallS #'(lambdaS (x y z) (declare (type oss x y z)) (Tconcatenate (Tmerge x y #'<) z)) (Eoss 1 2 4) (Eoss 1 3 3) (Eoss 0))) (1 1 2 3 3 4 0)) ((letS (((a b) (Eplist '(k1 2 k2 4)))) (list (Rlist b) (Rlist (Texpand (Eoss :R nil nil T nil T nil nil nil T) a nil)))) ((2 4) (nil nil k1 nil k2 nil nil nil))) ((Rlist (funcallS #'(lambdaS (x) (letS (((a b) (Eplist x))) (Texpand (Eoss nil nil T nil T nil nil nil T) a nil) b)) '(k1 2 k2 4))) (2 4)) ((Rlist (funcallS #'(lambdaS (x) (declare (type oss x)) (Tconcatenate (list x) (Eoss 5 6))) (Elist '(1 2 3)))) ((1) (2) (3) 5 6)) ((Rlist (funcallS #'(lambdaS (x) (declare (type oss x)) (Tconcatenate (Tselect (plusp x) x) (Eoss 5 6))) (Elist '(1 -2 3)))) (1 3 5 6)) ((Rlist (funcalls #'(lambdaS (x) (declare (type oss x)) (TselectF #'evenp (TsplitF x #'plusp))) (Elist '(1 2 -2 3 4)))) (2 4)) ((Rlist (funcalls #'(lambdaS (x) (declare (type oss x)) (List (TsplitF x #'plusp))) (Elist '(1 2 -2 3 4)))) ((1) (2) (3) (4))) ;mg4 ((letS (((a b) (Eplist '(k1 1 k2 -2)))) (list (Rlist a) (Rlist (Tselectf #'plusp b)))) ((k1 k2) (1))) ((Rlist (funcallS #'(lambdaS (x) (letS (((a b) (Eplist x))) (Rlist (Tselectf #'plusp b)) a)) '(k1 1 k2 -2))) (k1 k2)) ((let (z) (list (Rlist (funcallS #'(lambdaS (x) (letS (((a b) (Eplist x))) (setq z (Rbag (Tselectf #'plusp b))) (list a))) '(k1 1 k2 -2))) z)) (((k1) (k2)) (1))) ;mg5 ((LetS (((A B) (funcalls #'(lambdaS (x y) (declare (type oss x)) (valS (Tselect (plusp x) x) (Elist y))) (Elist '(1 -2 3)) '(a b c)))) (list (Rlist a) (Rlist b))) ((1 3) (a b))) ;these are weird tests checking for particular bugs in old versions ((let ((x (list 1 2 3))) (prognS (list (setf (car (Esublists x)) (Elist '(a b c d))))) x) (a b c)) ;don't want to have any complaints from setf here. ((let ((x (list 1 2 3))) (prognS (setf (car (Esublists x)) (Elist '(a b c d)))) x) (a b c)) ;don't want to have any complaints from setf here. ((Rfirst (TselectF #'(lambda (x) (and (car x) (cdr x))) (Elist '((a) (nil . b) (a . b) (c))))) (a . b)) ((letS ((l (car '((1 2 3 4))))) (Rlist (list (Elist l) (Elist l)))) ((1 1) (2 2) (3 3) (4 4))) ((let ((x nil)) (TmapF #'(lambda (e) (push e x)) (Elist '(1 2))) x) (2 1)) ((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*) (oss::m-&-r '(prog (x) (list x y)))) (prog (x) (list x 3))) ((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*) (oss::m-&-r '(prog a (x) (list x y)))) (prog a (x) (list x 3))) ((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*) (oss::m-&-r '(prog* (x) (list x y)))) (prog* (x) (list x 3))) ((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*) (oss::m-&-r '(prog* a (x) (list x y)))) (prog* a (x) (list x 3))) ((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*) (oss::m-&-r '(multiple-value-bind (x) (list x y) (list x y)))) (multiple-value-bind (x) (list 2 3) (list x 3))) ((letS ((x (Elist '(2 -1 0 1 -2)))) (list (Rsum (Tselectf #'plusp x)) (Rsum (Tselectf #'minusp x)))) (3 -3)) ((letS ((x (Elist '(2 -1 0 1 -2)))) (list (Rsum (Tselectf #'plusp x)) (Rsum (Tselect (minusp x) x)))) (3 -3)) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum x) (Rsum (Tselectf #'minusp x)))) (0 -3)) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum x) (Rbag (Tselectf #'plusp x)))) (0 (1 2))) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum x) (Rbag (Tselectf #'plusp x)) (Rmax (Tselectf #'plusp x)))) (0 (1 2) 2)) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum (Tselectf #'plusp x)) (Rsum (Tselectf #'minusp x)))) (3 -3)) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum (Tselectf #'plusp x)) (Rsum (Tselect (minusp x) x)))) (3 -3)) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum (Tselectf #'plusp x)) (Rbag (Tselectf #'plusp x)))) (3 (1 2))) ((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp))) (list (Rsum (Tselectf #'plusp x)) (Rbag (Tselectf #'plusp x)) (Rmax (Tselectf #'plusp x)))) (3 (1 2) 2)) ((lets* ((e1 (Elist '(1 -2 -4 3))) (e2 (Elist '(1 -2 -4 3))) (e3 (Elist '(1 -2 -4 3))) (w1 (TsplitF e2 #'plusp)) ((nil x2) (TsplitF e3 #'plusp))) (list (Rlist (list e1 w1)) (Rlist (list w1 x2)))) (((1 1) (-2 3)) ((1 -2) (3 -4)))) ((let ((v '(1 -2 3))) (letS* ((e (Elist v)) (x (TuntilF #'minusp e))) (alterS x (- x))) v) (-1 -2 3)) ((Rlist (Tsubseries (Tmask (Tpositions (Eoss t nil t nil))) 0 5)) (t nil t nil nil)) ((oss::nsubst-inline nil 1 '(3 1 2)) (3 2)) ((Let ((X '(1 2 3))) (macrolet ((bab (z) `(list ,z))) (rlist (bab (elist x))))) ((1) (2) (3))) ;the following test error checking. (test-warn (Rlist (Eup 0 :to 5 :below 6)) (1.1 1.1)) (test-warn (Rlist (Edown 0 :to 5 :length 6)) (1.2 1.2)) (test-warn (Rlist (Tlatch (Elist '(1 2)) :after 2 :before 3)) (1.3 1.3)) (test-warn (TconcatenateF #'car (Elist x)) (2 2)) (test-warn (TconcatenateF #'Efile (Elist x)) (2 2)) (test-warn (TconcatenateF #'Tpositions (Elist x)) (2 2)) (test-warn (defunS ff (a &rest b) (car a)) (3 3)) (test-warn (defunS ff (a &allow-other-keys b) (car a)) (3 3)) (test-warn (alterS (Eup :to 4) 5) (4 4)) (test-warn (alterS (car (Elist x)) 5) (4 4)) (test-warn (alterS (Tpositions (Elist x)) 5) (4 4)) (test-warn (funcalls #'(lambdaS ((A)) nil) 2) (5 5)) (test-warn (funcalls #'(lambdaS (T) nil) 2) (5 5)) (test-warn (funcalls #'(lambdaS (nil) nil) 2) (5 5)) (test-warn (funcalls #'(lambdaS (3) nil) 2) (5 5)) (test-warn (funcalls #'(lambdaS (&aux a) nil) 2) (5 5)) (test-warn (lambdaS (arg) arg) (6 6)) (test-warn (funcallS (lambdaS (arg) arg) (Elist x)) (6 6)) (test-warn (funcallS #'(lambdaS (a) (car a))) (7 7)) (test-warn (funcallS #'(lambdaS (a) (car a)) x y) (7 7)) (test-warn (letS (((a b) (Elist x))) x) (8 8)) (test-warn (letS (a) a) (9 9)) (test-warn (letS ((a)) a) (9 9)) (test-warn (letS (((a b))) a) (9 9)) (test-warn (letS ((t 3)) a) (9 9)) (test-warn (letS ((((a)) 3)) a) (9 9)) (test-warn (letS (((t b) 3)) a) (9 9)) (test-warn (letS ((2 nil)) nil) (9 9)) (test-warn (letS ((a nil nil)) nil) (9 9)) (test-warn (letS ((a (Elist '(1 2)))) (declare (type oss a)) (Rlist a)) ((1 2) 10)) (test-warn (letS ((e (Elist '(1 2 3)))) (Rlist (Elist '(1 2)))) ((1 2) 11)) (test-warn (lets ((a nil) (z (Elist x)) (b (Rlist (elist x)))) (setq a nil)) (12 12)) (test-warn (lets ((a nil) (z (Elist x)) (b (Rlist (elist x)))) (setq z nil)) (12 12)) (test-warn (lets ((a nil) (z (Elist x)) (b (Rlist (elist x)))) (setq b nil)) (12 12)) (test-warn (prognS (let ((z 2)) (Rlist (Elist '(a b z))))) ((a b z) 13)) (test-warn (Elist (Elist x)) (14 14)) (test-warn (letS ((e (Elist x))) (Elist e)) (14 14)) (test-warn (block bar (letS ((x (Eoss :R -1 2 3))) (if (plusp x) (return-from bar x)))) (2 15)) (test-warn (compiler-let ((*permit-non-terminating-oss-expressions* T)) (block bar (letS ((x (Eoss :R -1 2 3))) (if (plusp x) (return-from bar x))))) (2 nil)) (test-warn (letS* ((e (Elist '(1 2))) (w (Rlist e))) (Rlist (cons e w))) (((1 1 2) (2 1 2)) 16)) (test-warn (letS* ((e (Elist '((1) (2)))) (w (Rlist e))) (Rlist (cons (car e) w))) (((1 (1) (2)) (2 (1) (2))) 16)) (test-warn (letS* ((e (Elist '(1 2))) (w (Rlist e)) (x (Rsum e))) (list (Rlist (list e x)) (Rlist (list* e w)))) ((((1 3) (2 3)) ((1 1 2) (2 1 2))) 16)) (test-warn (lets* ((e (Elist '(1 -2 -4 3))) (w (TselectF #'plusp e))) (Rlist (list e w))) (((1 1) (-2 3)) 17.1)) (test-warn (lets* ((e (Elist '(1 -2 -4 3))) (w (TselectF #'plusp e))) (Rlist (list e e w))) (((1 1 1) (-2 -2 3)) 17.1)) (test-warn (lets* ((e (Elist '(1 2)))) (Rlist (Tconcatenate e e))) ((1 2 1 2) 17.1)) (test-warn (lets* ((e (Elist '(1 2)))) (Rlist (list e (Tconcatenate e e)))) (((1 1) (2 2)) 17.1)) (test-warn (lets* ((e (Elist '(1 -2 -3 4)))) (Rlist (list e (Tconcatenate (TselectF #'plusp e) (TselectF #'minusp e))))) (((1 1) (-2 4) (-3 -2) (4 -3)) 17.1)) (test-warn (lets* ((e (Elist '(1 -2 -3 4))) ((w x) (TsplitF e #'plusp))) (Rlist (list e (Tconcatenate w x)))) (((1 1) (-2 4) (-3 -2) (4 -3)) 17.1)) (test-warn (lets* ((e (Elist '(1 -2 3))) (w (TsplitF e #'plusp))) (Rlist (list e w))) (((1 1) (-2 3)) 17.2)) (test-warn (lets* ((e (Elist '(1 -2 3))) (w (TsplitF e #'plusp))) (Rlist (list e e w))) (((1 1 1) (-2 -2 3)) 17.2)) (test-warn (lets* ((e (Elist '(1 -2 -4 3))) ((w x) (TsplitF e #'plusp))) (Rlist (list w x))) (((1 -2) (3 -4)) 17.2)) (test-warn (letS ((x (Elist '(1 2 3))) (y (Elist '(4 5)))) (list (Rsum (+ x y)) (Rsum y))) ((12 9) 18)) (test-warn (letS ((x (Elist '(1 2 3))) (y (Elist '(4 5)))) (list (Rsum (+ x y)) (Rsum y) (Rsum y))) ((12 9 9) 18)) (test-warn (lets* ((e (Elist '(1 -2 -4 3))) ((w x) (TsplitF e #'plusp))) (list (Rlist (list e w)) (Rlist (list w x)))) ((((1 1) (-2 3)) ((1 -2) (3 -4))) 18)) (test-warn (defunS gack (e) (declare (type oss e)) (Elist (Rlist e))) (19 19)) (test-warn (prognS (flet ((a (b) (car b))) (a (elist x)))) (20 20)) (test-warn (lambda-primitiveS (arg) () () arg) (21 21)) (test-warn (funcallS (lambda-primitiveS (arg) () () arg) (Elist x)) (21 21)) (test-warn (prologS) (22.1 22.1)) (test-warn (progns (prologS (setq f 1)) (Rlist (Elist x))) (22.1 22.1)) (test-warn (epilogS) (22.2 22.2)) (test-warn (next-inS x) (22.3 22.3)) (test-warn (next-outS x) (22.4 22.4)) (test-warn (wrapS #'foo) (22.5 22.5)) (test-warn (alterableS x (car y)) (22.6 22.6)) (test-warn (funcallS #'(lambda-primitiveS ((a)) (b) (b) nil) 2) (23.1 23.1)) (test-warn (funcallS #'(lambda-primitiveS (a) (c) (b) nil) 2) (23.2 23.2)) (test-warn (funcallS #'(lambda-primitiveS (a) (3) (b) nil) 2) (23.2 23.2)) (test-warn (funcallS #'(lambda-primitiveS (a) (b) (t) nil) 2) (23.3 23.3)) (test-warn (funcallS #'(lambda-primitiveS (a) (b) (a) nil) 2) (23.3 23.3)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (next-inS b)) 2) (24 24)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (next-inS a)) 2) (24 24)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (declare (type oss a)) (next-inS a) (next-inS a)) 2) (24 24)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (next-outS b)) 2) (25 25)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (next-outS a)) 2) (25 25)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (declare (type oss a)) (next-outS a) (next-outS a)) 2) (25 25)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (declare (type oss a)) (next-outS a (go f))) 2) (25 25)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (wrapS foo)) 2) (26 26)) (test-warn (funcallS #'(lambda-primitiveS (a) (a) () (alterableS b (car b))) 2) (27 27)) (test-warn (funcallS #'(lambda-primitiveS (c) (a) (a) (alterableS a (car c))) 2) (27 27)) (test-warn (funcallS #'(lambda-primitiveS (c) (a) (a) (alterableS a (car a) 3)) 2) (27 27)) ;the following test tutorial mode (test-tut (eval (read-from-string "(Rsum [1 2 3])")) 6) (test-tut (not (null (string-equal (let ((*print-case* :downcase)) (with-output-to-string (f) (prin1 (Elist '(a b c)) f))) "[a b c]"))) T) (test-tut (not (null (string-equal (let ((*print-case* :downcase)) (with-output-to-string (f) (prin1 (Eup) f))) "[0 1 2 3 4 5 6 7 8 9 10 ...]"))) T) ) test-failed nil) ;------------------------------------------------------------------------ ; ; Copyright (c) Richard C. Waters, 1988 ; ;------------------------------------------------------------------------ ; \ No newline at end of file diff --git a/lispusers/simplechat.tedit b/lispusers/simplechat.tedit new file mode 100644 index 00000000..9a633d74 Binary files /dev/null and b/lispusers/simplechat.tedit differ diff --git a/lispusers/sourcecompare.txt b/lispusers/sourcecompare.txt new file mode 100644 index 00000000..e69de29b diff --git a/lispusers/tedit-process-killer b/lispusers/tedit-process-killer new file mode 100644 index 00000000..f2ed6380 --- /dev/null +++ b/lispusers/tedit-process-killer @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Mar-89 15:01:15" {ERINYES}MEDLEY>TEDIT-PROCESS-KILLER.;2 16040 changes to%: (FNS MAKE-NEW-TEDIT-PROCESS) previous date%: " 2-Feb-88 14:21:07" {ERINYES}MEDLEY>TEDIT-PROCESS-KILLER.;1) (* " Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDIT-PROCESS-KILLERCOMS) (RPAQQ TEDIT-PROCESS-KILLERCOMS [ (* ;; "This package provides various ways to kill tedit processes. Using START-TEDIT-KILLER, one can keep the total number of tedit processes under the threshold TEDIT-PROCESS-LIMIT. One can also call KILL-PROCESS-OF-TEDIT-WINDOW to kill the Tedit processes for a given window and its attached windows.") (GLOBALVARS TEDIT-PROCESS-LIMIT TEDIT-KILLER-WAIT-TIME TEDIT-PROCESSES TEDIT-CREATION-TIME) (* ;;; "These two vars are advertised.") (INITVARS (TEDIT-PROCESS-LIMIT 5) (TEDIT-KILLER-WAIT-TIME 10000)) (VARS (TEDIT-PROCESSES NIL) (TEDIT-CREATION-TIME NIL)) (* ;;; "Here are the advertised functions.") (FNS START-TEDIT-KILLER STOP-TEDIT-KILLER KILL-PROCESS-OF-TEDIT-WINDOW RESTART-PROCESS-OF-TEDIT-WINDOW WITHOUT-TEDIT-PROCESS) (* ;;; "The rest of these are internal.") (FNS TEDIT-KILLER \TEDIT.BUTTONEVENTFN-BEFORE-ADVICE) (FNS MARK-AS-WITHOUT-PROCESS UNMARK-AS-WITHOUT-PROCESS WITHOUT-PROCESS) (FNS ALL-TEDIT-PROCESSES TEDIT-PROCESS-P KILL-PROCESS-OF-TEDIT-WINDOW1 KILL-TEDIT-PROCESS MAKE-NEW-TEDIT-PROCESS RESTART-PROCESS-OF-TEDIT-WINDOW1 TEDIT-KILLER-CLEANUP) (* ;;; "NOTE: this advising smashes whatever advice was previously on these functions!") (DECLARE%: DONTEVAL@LOAD DOCOPY (ADVISE \TEDIT.QUIT TEDIT \TEDIT.BUTTONEVENTFN (* ;; "PROCESS.APPLY advice is mainly for NoteCards - fixes a misuse of this function that makes it impossible to use monitors inside a TEdit menu fn.") (PROCESS.APPLY :IN \TEDIT.BUTTONEVENTFN) (PROCESSP :IN TEDIT.DEACTIVATE.WINDOW) (PROCESSP :IN \TEDIT.ACTIVE.WINDOWP)) (P (START-TEDIT-KILLER]) (* ;; "This package provides various ways to kill tedit processes. Using START-TEDIT-KILLER, one can keep the total number of tedit processes under the threshold TEDIT-PROCESS-LIMIT. One can also call KILL-PROCESS-OF-TEDIT-WINDOW to kill the Tedit processes for a given window and its attached windows." ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT-PROCESS-LIMIT TEDIT-KILLER-WAIT-TIME TEDIT-PROCESSES TEDIT-CREATION-TIME) ) (* ;;; "These two vars are advertised.") (RPAQ? TEDIT-PROCESS-LIMIT 5) (RPAQ? TEDIT-KILLER-WAIT-TIME 10000) (RPAQQ TEDIT-PROCESSES NIL) (RPAQQ TEDIT-CREATION-TIME NIL) (* ;;; "Here are the advertised functions.") (DEFINEQ (START-TEDIT-KILLER [LAMBDA NIL (* ; "Edited 11-Dec-87 19:43 by Randy.Gobbel") (DECLARE (GLOBALVARS TEDIT-CREATION-TIME TEDIT-PROCESSES)) (* ;; "Kill off old killers.") (STOP-TEDIT-KILLER) (* ;; "Reset stuff and start er up.") (SETQ TEDIT-CREATION-TIME (CLOCK 0)) (SETQ TEDIT-PROCESSES (ALL-TEDIT-PROCESSES)) (ADD.PROCESS '(TEDIT-KILLER) 'RESTARTABLE 'HARDRESET]) (STOP-TEDIT-KILLER [LAMBDA NIL (* ; "Edited 2-Feb-88 14:08 by Randy.Gobbel") (* ;; "Kill off old killers.") (DECLARE (GLOBALVARS \PROCESSES)) (for P in \PROCESSES when [EQ 'TEDIT-KILLER (CAR (PROCESSPROP P 'FORM] do (DEL.PROCESS P) (until (NOT (PROCESSP P)) do (BLOCK]) (KILL-PROCESS-OF-TEDIT-WINDOW [LAMBDA (WINDOW) (* ; "Edited 11-Dec-87 19:17 by Randy.Gobbel") (* ;; "Kill the process of this window, and anybody who is attached to me (recursively).") (KILL-PROCESS-OF-TEDIT-WINDOW1 (MAINWINDOW WINDOW]) (RESTART-PROCESS-OF-TEDIT-WINDOW [LAMBDA (WINDOW) (* SCB%: " 2-May-86 10:41") (* Move down the attached windows tree from the mainwindow, firing up a new process for each TEdit.) (RESTART-PROCESS-OF-TEDIT-WINDOW1 (MAINWINDOW WINDOW)) (TTY.PROCESS (WINDOWPROP (MAINWINDOW WINDOW) 'PROCESS]) (WITHOUT-TEDIT-PROCESS [LAMBDA (WINDOW) (* SCB%: " 2-May-86 16:08") (EQ 'TEDIT (WITHOUT-PROCESS WINDOW]) ) (* ;;; "The rest of these are internal.") (DEFINEQ (TEDIT-KILLER [LAMBDA NIL (* ; "Edited 11-Dec-87 20:53 by Randy.Gobbel") (DECLARE (GLOBALVARS TEDIT-PROCESSES TEDIT-KILLER-WAIT-TIME TEDIT-CREATION-TIME TEDIT-PROCESS-LIMIT)) (while T bind (TO-KILL _ 0) do (DISMISS TEDIT-KILLER-WAIT-TIME) (if (AND TEDIT-PROCESSES (ILESSP TEDIT-KILLER-WAIT-TIME (IDIFFERENCE (CLOCK 0) TEDIT-CREATION-TIME))) then (SETQ TEDIT-PROCESSES (for P in TEDIT-PROCESSES when (TEDIT-PROCESS-P P) collect P)) (SETQ TO-KILL (IDIFFERENCE (LENGTH TEDIT-PROCESSES) TEDIT-PROCESS-LIMIT)) (* ;; "Kill processes, starting from the least recently used.") (until (ILEQ TO-KILL 0) for P in (REVERSE TEDIT-PROCESSES ) do (COND ((AND (NEQ (TTY.PROCESS) P) (PROCESSP P)) (KILL-TEDIT-PROCESS P) (SETQ TO-KILL (SUB1 TO-KILL]) (\TEDIT.BUTTONEVENTFN-BEFORE-ADVICE [LAMBDA (W) (* ; "Edited 11-Dec-87 19:45 by Randy.Gobbel") (DECLARE (GLOBALVARS TEDIT-PROCESSES)) (LET [(TEXTOBJ (TEXTOBJ W)) (PROCESS (WINDOWPROP W 'PROCESS] (COND ([AND TEXTOBJ (NOT (PROCESSP PROCESS)) (MOUSESTATE (OR LEFT MIDDLE)) (NOT (TEXTPROP TEXTOBJ 'READONLY)) (NOT (SHIFTDOWNP 'SHIFT)) (NOT (SHIFTDOWNP 'CTRL)) (NOT (SHIFTDOWNP 'META)) (NOT (KEYDOWNP 'MOVE)) (NOT (KEYDOWNP 'COPY] (SETQ PROCESS (MAKE-NEW-TEDIT-PROCESS W)) (SETQ TEDIT-PROCESSES (CONS PROCESS TEDIT-PROCESSES)) (TTY.PROCESS PROCESS)) ([AND (PROCESSP PROCESS) (NOT (EQ PROCESS (CAR TEDIT-PROCESSES] (* ; "We're using the process, so move it to the front of the list.") (SETQ TEDIT-PROCESSES (CONS PROCESS (DREMOVE PROCESS TEDIT-PROCESSES]) ) (DEFINEQ (MARK-AS-WITHOUT-PROCESS [LAMBDA (WINDOW PROCESS-TYPE) (* SCB%: " 2-May-86 15:44") (WINDOWPROP WINDOW 'WITHOUT-PROCESS PROCESS-TYPE]) (UNMARK-AS-WITHOUT-PROCESS [LAMBDA (WINDOW) (* SCB%: " 2-May-86 15:44") (WINDOWPROP WINDOW 'WITHOUT-PROCESS NIL]) (WITHOUT-PROCESS [LAMBDA (WINDOW) (* SCB%: " 2-May-86 15:43") (WINDOWPROP WINDOW 'WITHOUT-PROCESS]) ) (DEFINEQ (ALL-TEDIT-PROCESSES [LAMBDA NIL (* rht%: "30-Jan-87 18:54") (* * Gather all the extant tedit processes.) (DECLARE (GLOBALVARS \PROCESSES)) (for P in \PROCESSES when (TEDIT-PROCESS-P P) collect P]) (TEDIT-PROCESS-P [LAMBDA (PROCESS) (* ; "Edited 2-Feb-88 14:15 by Randy.Gobbel") (* ;; "rg 2/2/88: Now looks at process name instead of checking TTYENTRYFN = \TEDIT.PROCENTRYFN, which failed for TEdits that had never been given the TTY (look at \TEDIT.COMMAND.LOOP code). This will miss processes that have been given another name, but works in practice for all cases that I know of.") (AND (PROCESSP PROCESS) (EQ (STRPOS "TEdit" (PROCESSPROP PROCESS 'NAME)) 1) (EQ (CAR (PROCESSPROP PROCESS 'FORM)) '\TEDIT2]) (KILL-PROCESS-OF-TEDIT-WINDOW1 [LAMBDA (WINDOW) (* SCB%: " 1-May-86 17:37") (LET [(PROCESS (WINDOWPROP WINDOW 'PROCESS] (AND (TEDIT-PROCESS-P PROCESS) (KILL-TEDIT-PROCESS PROCESS)) (for W in (ATTACHEDWINDOWS WINDOW) do (KILL-PROCESS-OF-TEDIT-WINDOW1 W]) (KILL-TEDIT-PROCESS [LAMBDA (PROCESS) (* ; "Edited 11-Dec-87 20:06 by Randy.Gobbel") (* ;; "Save the state that TEdit bashes, and then kill the process. Only TEdits have TEXTOBJs, so this won't go killing other kinds of processes. Won't kill if the TEdit is in the middle of an operation.") (* ;; "rrp 10/19/87: Now also saves TXTFILE property.") (LET* [(WINDOW (PROCESSPROP PROCESS 'WINDOW)) (TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ] (COND ((AND (WINDOWP WINDOW) TEXTOBJ (NOT (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ))) (WINDOWPROP WINDOW 'TXTHISTORY (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) (WINDOWPROP WINDOW 'TXTFILE (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) (WINDOWPROP WINDOW 'SELWINDOW (fetch (TEXTOBJ SELWINDOW) of TEXTOBJ)) (WINDOWPROP WINDOW 'SAVEDPROCFORM (PROCESSPROP PROCESS 'FORM)) (WINDOWPROP WINDOW 'SAVEDRESTARTFORM (PROCESSPROP PROCESS 'RESTARTFORM)) (WINDOWPROP WINDOW 'SAVEDRESTARTABLE (PROCESSPROP PROCESS 'RESTARTABLE)) (WINDOWPROP WINDOW 'SAVEDPROCNAME (PROCESSPROP PROCESS 'NAME)) (* ;; "Mark the window so we know we can restart the process. Atomic action to turn off the process.") (UNINTERRUPTABLY (MARK-AS-WITHOUT-PROCESS WINDOW 'TEDIT) (DEL.PROCESS PROCESS))]) (MAKE-NEW-TEDIT-PROCESS [LAMBDA (WINDOW) (* ; "Edited 9-Mar-89 14:58 by Randy.Gobbel") (* ;; "This assumes that WINDOW really is the window of a restartable TEdit.") (* ;; "Build a new TEdit process recovering saved PROCESSPROPs from the window.") (* ;; "rht 2/9/87: Added a check that SAVEDPROCFORM of WINDOW is non-nil in case WINDOW just got smashed.") (* ;; "rht&sb 4/24/87: Now smashes windowprops after reading them by calling TEDIT-KILLER-CLEANUP.") (* ;; "rrp 10/19/87: Now restores TXTFILE property as well.") (LET ((TEXTOBJ (TEXTOBJ WINDOW)) (TXTFILE (WINDOWPROP WINDOW 'TXTFILE)) PROCESS SAVEDPROCFORM) (replace (TEXTOBJ TXTHISTORY) of TEXTOBJ with (WINDOWPROP WINDOW 'TXTHISTORY)) (replace (TEXTOBJ SELWINDOW) of TEXTOBJ with (WINDOWPROP WINDOW 'SELWINDOW)) [if (AND TXTFILE (NOT (STREQUAL TXTFILE ""))) then (replace (TEXTOBJ TXTFILE) of TEXTOBJ with (OPENSTREAM (FULLNAME TXTFILE) 'INPUT 'OLD] (* ;; "Atomic action to restore the process.") (if (SETQ SAVEDPROCFORM (WINDOWPROP WINDOW 'SAVEDPROCFORM)) then (UNINTERRUPTABLY [SETQ PROCESS (ADD.PROCESS SAVEDPROCFORM 'NAME (LET* ((PROCNAME (WINDOWPROP WINDOW 'SAVEDPROCNAME)) (POS (STRPOS "#" PROCNAME))) (OR (SUBSTRING PROCNAME 1 (AND POS (SUB1 POS))) PROCNAME)) 'RESTARTABLE (WINDOWPROP WINDOW 'SAVEDRESTARTABLE) 'RESTARTFORM (WINDOWPROP WINDOW 'SAVEDRESTARTFORM] (TEDIT-KILLER-CLEANUP WINDOW) (PROCESSPROP PROCESS 'WINDOW WINDOW) (WINDOWPROP WINDOW 'PROCESS PROCESS))) PROCESS]) (RESTART-PROCESS-OF-TEDIT-WINDOW1 [LAMBDA (WINDOW) (* SCB%: " 2-May-86 16:09") (* Only restart this guy if he used to have a TEdit process.) (AND (WITHOUT-TEDIT-PROCESS WINDOW) (MAKE-NEW-TEDIT-PROCESS WINDOW)) (for W in (ATTACHEDWINDOWS WINDOW) do (RESTART-PROCESS-OF-TEDIT-WINDOW1 W]) (TEDIT-KILLER-CLEANUP [LAMBDA (WINDOW) (* ; "Edited 11-Dec-87 20:13 by Randy.Gobbel") (* ;; "This unmarks the window and also throws away any cruft we left on windowprops.") (* ;; "rrp 10/19/87: Now trashes TXTFILE property as well.") (WINDOWPROP WINDOW 'TXTHISTORY NIL) (WINDOWPROP WINDOW 'TXTFILE NIL) (WINDOWPROP WINDOW 'SELWINDOW NIL) (WINDOWPROP WINDOW 'SAVEDPROCFORM NIL) (WINDOWPROP WINDOW 'SAVEDPROCNAME NIL) (WINDOWPROP WINDOW 'SAVEDRESTARTABLE NIL) (WINDOWPROP WINDOW 'SAVEDRESTARTFORM NIL) (UNMARK-AS-WITHOUT-PROCESS WINDOW]) ) (* ;;; "NOTE: this advising smashes whatever advice was previously on these functions!") (DECLARE%: DONTEVAL@LOAD DOCOPY [XCL:REINSTALL-ADVICE '\TEDIT.QUIT :AFTER '((:LAST (UNMARK-AS-WITHOUT-PROCESS W] [XCL:REINSTALL-ADVICE 'TEDIT :BEFORE '[(:LAST (SETQ TEDIT-CREATION-TIME (CLOCK 0] :AFTER '((:LAST (SETQ TEDIT-PROCESSES (CONS !VALUE TEDIT-PROCESSES] [XCL:REINSTALL-ADVICE '\TEDIT.BUTTONEVENTFN :BEFORE '((:LAST (\TEDIT.BUTTONEVENTFN-BEFORE-ADVICE W] [XCL:REINSTALL-ADVICE '(PROCESS.APPLY :IN \TEDIT.BUTTONEVENTFN) :AROUND '((:LAST (ADD.PROCESS (LIST USERFN (KWOTE W] [XCL:REINSTALL-ADVICE '(PROCESSP :IN TEDIT.DEACTIVATE.WINDOW) :AFTER '((:LAST (RETURN (OR !VALUE (WITHOUT-TEDIT-PROCESS (STKARG 'W 'TEDIT.DEACTIVATE.WINDOW] [XCL:REINSTALL-ADVICE '(PROCESSP :IN \TEDIT.ACTIVE.WINDOWP) :AFTER '((:LAST (RETURN (OR !VALUE (WITHOUT-TEDIT-PROCESS (STKARG 'W '\TEDIT.ACTIVE.WINDOWP] (READVISE \TEDIT.QUIT TEDIT \TEDIT.BUTTONEVENTFN (PROCESS.APPLY :IN \TEDIT.BUTTONEVENTFN) (PROCESSP :IN TEDIT.DEACTIVATE.WINDOW) (PROCESSP :IN \TEDIT.ACTIVE.WINDOWP)) (START-TEDIT-KILLER) ) (PUTPROPS TEDIT-PROCESS-KILLER COPYRIGHT ("Xerox Corporation" 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3085 4859 (START-TEDIT-KILLER 3095 . 3585) (STOP-TEDIT-KILLER 3587 . 3978) ( KILL-PROCESS-OF-TEDIT-WINDOW 3980 . 4287) (RESTART-PROCESS-OF-TEDIT-WINDOW 4289 . 4695) ( WITHOUT-TEDIT-PROCESS 4697 . 4857)) (4910 7835 (TEDIT-KILLER 4920 . 6736) ( \TEDIT.BUTTONEVENTFN-BEFORE-ADVICE 6738 . 7833)) (7836 8340 (MARK-AS-WITHOUT-PROCESS 7846 . 8018) ( UNMARK-AS-WITHOUT-PROCESS 8020 . 8185) (WITHOUT-PROCESS 8187 . 8338)) (8341 14699 (ALL-TEDIT-PROCESSES 8351 . 8655) (TEDIT-PROCESS-P 8657 . 9279) (KILL-PROCESS-OF-TEDIT-WINDOW1 9281 . 9642) ( KILL-TEDIT-PROCESS 9644 . 11199) (MAKE-NEW-TEDIT-PROCESS 11201 . 13641) ( RESTART-PROCESS-OF-TEDIT-WINDOW1 13643 . 14039) (TEDIT-KILLER-CLEANUP 14041 . 14697))))) STOP \ No newline at end of file diff --git a/lispusers/tedit-process-killer.tedit b/lispusers/tedit-process-killer.tedit new file mode 100644 index 00000000..4425e407 Binary files /dev/null and b/lispusers/tedit-process-killer.tedit differ diff --git a/lispusers/teditdoradokeys.tedit b/lispusers/teditdoradokeys.tedit new file mode 100644 index 00000000..3399430c Binary files /dev/null and b/lispusers/teditdoradokeys.tedit differ diff --git a/lispusers/timesroman10-c0.c150font b/lispusers/timesroman10-c0.c150font new file mode 100644 index 00000000..5ec6b0a0 Binary files /dev/null and b/lispusers/timesroman10-c0.c150font differ diff --git a/lispusers/timesroman12-c0.c150font b/lispusers/timesroman12-c0.c150font new file mode 100644 index 00000000..06761504 Binary files /dev/null and b/lispusers/timesroman12-c0.c150font differ diff --git a/lispusers/timesroman14-c0.c150font b/lispusers/timesroman14-c0.c150font new file mode 100644 index 00000000..06917afa Binary files /dev/null and b/lispusers/timesroman14-c0.c150font differ diff --git a/lispusers/tkdorado b/lispusers/tkdorado new file mode 100644 index 00000000..47f3aaf0 --- /dev/null +++ b/lispusers/tkdorado @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED "16-Apr-87 17:28:48" {ERIS}LYRIC>TKDORADO.;5 14764 changes to%: (VARS TKDORADOCOMS) (FNS \TKD.SETLOOKS) previous date%: "14-Apr-87 17:10:44" {ERIS}LYRIC>TKDORADO.;4) (* " Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TKDORADOCOMS) (RPAQQ TKDORADOCOMS [(FILES TEDITKEY) (FNS \TKD.SETLOOKS) (P [SETQ TEDITKEY.KEYBINDINGS (UNION (APPEND TEDITKEY.KEYBINDINGS '(NIL)) '(([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (if (ZEROP (fetch DCH of SEL)) then (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.DEFAULTSSEL TEXTSTREAM TEXTOBJ SEL] (%##^V) "default looks") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE ON] (%##^D) "overbar on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE OFF] (%##^F) "overbar off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT ON] (%##^G) "strikethru on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT OFF] (%##^H) "strikethru off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE ON] (%##^J) "underlining on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE OFF] (%##^K) "underlining off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT BOLD] (%##^B) "bold on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT MEDIUM] (%##^N) "bold off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE ITALIC] (%##^I) "italics on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE REGULAR] (%##^O) "italics off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.SMALLERSEL TEXTSTREAM TEXTOBJ SEL] (|##^[|) "smaller font") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.LARGERSEL TEXTSTREAM TEXTOBJ SEL] (|##^]|) "larger font") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.SUPERSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] (%##^^) "superscript") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.SUBSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] (%##^_) "subscript") (\TK.CENTER.SEL (%##^C) "center, justify, ... "] (\TK.BUILD.MENU) (TEDITKEY.INSTALL) (AND (BOUNDP 'DLIONFNKEYS) (OPENWP DLIONFNKEYS) (CLOSEW DLIONFNKEYS)) (TEDIT.SETSYNTAX (CHARCODE ESC) 'REDO]) (FILESLOAD TEDITKEY) (DEFINEQ (\TKD.SETLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL LOOKS) (* ; "Edited 16-Apr-87 17:26 by mdd") (if (ZEROP (fetch DCH of SEL)) then [LET [(charlooks (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] [REPLACEFIELD (LISTGET [CONSTANT (LIST 'UNDERLINE (CADADR (RECORDACCESSFORM 'CLULINE)) 'OVERLINE (CADADR (RECORDACCESSFORM 'CLOLINE)) 'STRIKEOUT (CADADR (RECORDACCESSFORM 'CLSTRIKE)) 'SLOPE (CADADR (RECORDACCESSFORM 'CLITAL)) 'WEIGHT (CADADR (RECORDACCESSFORM 'CLBOLD] (CAR LOOKS)) charlooks (FMEMB (CADR LOOKS) '(ITALIC BOLD ON] (if (OR (AND (NEQ (CAR LOOKS) 'SLOPE) (NEQ (CAR LOOKS) 'WEIGHT)) (\TK.SETFONTINLOOKS TEXTSTREAM charlooks)) then (TEDIT.CARETLOOKS TEXTSTREAM charlooks) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL] else (TEDIT.LOOKS TEXTSTREAM LOOKS SEL]) ) [SETQ TEDITKEY.KEYBINDINGS (UNION (APPEND TEDITKEY.KEYBINDINGS '(NIL)) '(([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (if (ZEROP (fetch DCH of SEL)) then (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.DEFAULTSSEL TEXTSTREAM TEXTOBJ SEL] (%##^V) "default looks") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE ON] (%##^D) "overbar on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE OFF] (%##^F) "overbar off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT ON] (%##^G) "strikethru on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT OFF] (%##^H) "strikethru off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE ON] (%##^J) "underlining on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE OFF] (%##^K) "underlining off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT BOLD] (%##^B) "bold on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT MEDIUM] (%##^N) "bold off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE ITALIC] (%##^I) "italics on") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE REGULAR] (%##^O) "italics off") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.SMALLERSEL TEXTSTREAM TEXTOBJ SEL] (|##^[|) "smaller font") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.LARGERSEL TEXTSTREAM TEXTOBJ SEL] (|##^]|) "larger font") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.SUPERSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] (%##^^) "superscript") ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) (IF (ZEROP (FETCH DCH OF SEL)) then (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) else (\TK.SUBSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] (%##^_) "subscript") (\TK.CENTER.SEL (%##^C) "center, justify, ... "] (\TK.BUILD.MENU) (TEDITKEY.INSTALL) (AND (BOUNDP 'DLIONFNKEYS) (OPENWP DLIONFNKEYS) (CLOSEW DLIONFNKEYS)) (TEDIT.SETSYNTAX (CHARCODE ESC) 'REDO) (PUTPROPS TKDORADO COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7206 9013 (\TKD.SETLOOKS 7216 . 9011))))) STOP \ No newline at end of file diff --git a/lispusers/tkdorado.tedit b/lispusers/tkdorado.tedit new file mode 100644 index 00000000..a667eec2 Binary files /dev/null and b/lispusers/tkdorado.tedit differ diff --git a/lispusers/tmenu b/lispusers/tmenu new file mode 100644 index 00000000..b74389a1 --- /dev/null +++ b/lispusers/tmenu @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Nov-88 17:04:43" {ERINYES}MEDLEY>TMENU.;2 31829 changes to%: (FNS ReShapeMenu) previous date%: "16-Feb-87 16:33:23" {ERINYES}MEDLEY>TMENU.;1) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TMENUCOMS) (RPAQQ TMENUCOMS [(* Copyright (c) 1982 by Xerox Corporation.) (* * Functions to support editable menus that insert items into the TTY stream. Written in 1981 by Mark Stefik, Danny Bobrow, and Christopher Tong.) (FNS * TMENUFNS) (* * Fns to support WindowShade feature.) (FNS * WINDOWSHADEFNS) (* * These fns would probably not be called by a user.) (FNS * InternalTMENUFNS) (VARS YellowButtonItems (YellowButtonMenu NIL) (firstCallFlgTmenu T) (lastDeletedItem NIL) (menuedFiles NIL)) (* Display Utility Functions) (FNS SELECTW FLIPREGION) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CPROMPT PROMPT]) (* Copyright (c) 1982 by Xerox Corporation.) (* * Functions to support editable menus that insert items into the TTY stream. Written in 1981 by Mark Stefik, Danny Bobrow, and Christopher Tong.) (RPAQQ TMENUFNS (MakeFileMenus TMenu PROMPT CPROMPT CloseFileMenus)) (DEFINEQ (MakeFileMenus [LAMBDA (fileName) (* cht%: " 8-SEP-82 23:58") (* * Make menus for the FNS and CLASSES in file.) (PROG (title (coms (PACK* fileName 'COMS)) comsList relevantComs relevantComsName windows) (* * Make menus for the FNS and CLASSES in the file.) (SETQ comsList (EVAL coms)) (for com in comsList do (SELECTQ (CAR com) (VARS [COND ((EQ (CADR com) '*) (SETQ title (CONCAT (CAR com) '% (CADDR com))) (SETQ windows (CONS (TMenu (LIST 'FetchNames (CADDR com)) title T 'WindowShade) windows)) (SETQ relevantComs (CONS (CADDR com) relevantComs]) ((FNS CLASSES) [COND ((EQ (CADR com) '*) (SETQ title (CONCAT (CAR com) '% (CADDR com))) (SETQ windows (CONS (TMenu (CADDR com) title T 'WindowShade) windows)) (SETQ relevantComs (CONS (CADDR com) relevantComs))) (T (SETQ title (CONCAT (CAR com) '% fileName)) (SETQ windows (CONS (TMenu (LIST 'QUOTE (CDR com)) title T 'WindowShade) windows]) NIL)) (* * Make menu of the coms for which menus were just created.) [SETQ relevantComs (SORT (CONS fileName (CONS coms relevantComs] (SETQ relevantComsName (PACK* 'RELEVANT% coms)) (SET relevantComsName relevantComs) (SETQ windows (CONS (TMenu relevantComsName relevantComsName T 'WindowShade) windows)) (SETQ menuedFiles (CONS (LIST fileName windows) menuedFiles]) (TMenu [LAMBDA (itemExpr title displaySpec windowShadeFlg buttonFn defaultTrailerString) (* mjs%: " 7-DEC-82 13:17") (* * Creates a menu of items. Buttons work as follows -  LEFT. When items are selected using the LEFT mouse button, they are placed in  the terminal input buffer. RIGHT. The RIGHT button gives the usual window  commands, including a SHAPE command tailored for these menus.  MIDDLE. The MIDDLE button gives menu commands for adding or deleting an item,  or for sorting the list of items. -  The optional argument displaySpec has the following interpretations -  REGION. The menu window is placed in that region.  -  NUMBER. The number is used as the number of columns in the menu.  A window is allocated of the minimal sufficient size.  The user gets to place the window. -  T. The number of columns is computed by assuming a maximum of 15 rows per  column. Otherwise like previous case. NIL.  The user is prompted for a bounding box for a window.  -  -  The optinal argument buttonFn is the name of the function to be used as the  BUTTONEVENTFN for the window; it defaults to MenuButtonFn.  -  -  The optional argument defaultTrailerString is the string to be inserted after  the item in the TTY buffer. If not specified, then a space is used.) (PROG (window menu items dsp (font (FONTCREATE 'GACHA 10))) [COND ((NLISTP itemExpr) (SETQ items (EVAL itemExpr))) ((FGETD (CAR itemExpr)) (SETQ items (EVAL itemExpr))) (T (SETQ items itemExpr) (SETQ itemExpr (KWOTE itemExpr] [COND ((EQ T displaySpec) (* Here if Caller wants standard  shape.) (SETQ displaySpec (CEILING (FQUOTIENT (LENGTH items) 15] [SETQ window (COND ((NUMBERP displaySpec) (* Here if Caller specifies number of  menu columns.) (SETQ menu (create MENU ITEMS _ items WHENSELECTEDFN _ (FUNCTION UnreadExpr) MENUFONT _ font MENUCOLUMNS _ displaySpec CENTERFLG _ T MENUOUTLINESIZE _ 0)) (SETQ dsp (DSPCREATE)) (DSPCLIPPINGREGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch IMAGEWIDTH of menu) HEIGHT _ (fetch IMAGEHEIGHT of menu)) dsp) (SETQ window (CREATEW dsp title)) (ADDMENU menu window (create POSITION XCOORD _ 0 YCOORD _ 0)) (MOVEW window) window) (T (ReShapeMenu (CREATEW displaySpec title) NIL NIL (SETQ menu (create MENU ITEMS _ items WHENSELECTEDFN _ (FUNCTION UnreadExpr) MENUFONT _ font MENUCOLUMNS _ 1 CENTERFLG _ T] (WINDOWPROP window 'MENUEXPR itemExpr) (WINDOWPROP window 'RESHAPEFN (FUNCTION ReShapeMenu)) [WINDOWPROP window 'BUTTONEVENTFN (APPLY 'FUNCTION (LIST (OR buttonFn 'MenuButtonFn] (COND (defaultTrailerString (WINDOWPROP window 'DEFAULTTRAILERSTRING defaultTrailerString))) (COND (windowShadeFlg (MakeWindowShade window))) (RETURN window]) (PROMPT [LAMBDA nargs (* ct%: " 8-DEC-81 14:14") (* Print an arbitrary number of arguments in the prompt window, after first  clearing the window.) (DSPFILL NIL BLACKSHADE 'INPUT PROMPTWINDOW) (DSPRESET PROMPTWINDOW) (PROG ((I 0)) (while (ILESSP I nargs) do (PRIN1 (ARG nargs (SETQ I (ADD1 I))) PROMPTWINDOW]) (CPROMPT [LAMBDA nargs (* ct%: " 8-DEC-81 14:14") (* Print an arbitrary number of arguments centered in the prompt window, after  first clearing the window. A call with no arguments simply clears the window.) (PROG (MSG (I 0)) (DSPFILL NIL BLACKSHADE 'INPUT PROMPTWINDOW) (DSPRESET PROMPTWINDOW) [SETQ MSG (while (ILESSP I nargs) collect (ARG nargs (SETQ I (ADD1 I] (COND (MSG (CENTERPRINTINREGION MSG (DSPCLIPPINGREGION NIL PROMPTWINDOW) PROMPTWINDOW]) (CloseFileMenus [LAMBDA (fileName) (* cht%: " 8-SEP-82 23:53") (* * Closes all windows used for displaying the COMS of fileName.) (PROG (fileInfo) (SETQ fileInfo (for fileInfo in menuedFiles thereis (EQ (CAR fileInfo) fileName))) (for window in (CADR fileInfo) do (CLOSEW window)) (SETQ menuedFiles (REMOVE fileInfo menuedFiles]) ) (* * Fns to support WindowShade feature.) (RPAQQ WINDOWSHADEFNS (MakeWindowShade MoveShadeFn ReshapeShadeFn UnMakeWindowShade WindowShadeButtonFn)) (DEFINEQ (MakeWindowShade [LAMBDA (window) (* dgb%: "11-AUG-82 11:24") (* Create an special window with only a title --  taken from the main window. When this small window is buttoned, it opens the  main window and runs its BUTTONFN. The region for the small window contains the  title of the given window plus a small white space below.) [COND ((NULL window) (* If window not given, use the one at the cursor) (SETQ window (WHICHW))) ((EQ window T) (SETQ window (SELECTW] (COND ((NOT (WINDOWP window)) (ERROR window "Not a window"))) (PROG [iconWindow (wregion (WINDOWPROP window 'REGION)) (title (WINDOWPROP window 'TITLE] (SETQ iconWindow (CREATEW (create REGION LEFT _ (fetch LEFT of wregion) BOTTOM _ (IPLUS (fetch BOTTOM of wregion) (fetch HEIGHT of wregion) -20) HEIGHT _ 20 WIDTH _ (fetch WIDTH of wregion)) title)) (WINDOWPROP window 'IconWindow iconWindow) (WINDOWPROP iconWindow 'IconFor window) (WINDOWPROP iconWindow 'BUTTONEVENTFN 'WindowShadeButtonFn) (WINDOWPROP iconWindow 'MOVEFN 'MoveShadeFn) (WINDOWPROP iconWindow 'RESHAPEFN 'ReshapeShadeFn) (WINDOWPROP iconWindow 'CLOSEFN 'UnMakeWindowShade) (CLOSEW window]) (MoveShadeFn [LAMBDA (iconWindow pos) (* dgb%: " 5-JUN-83 22:06") (* Makes sure that mainWindow moves  right along with windowShade) (PROG [mainR (wr (WINDOWPROP iconWindow 'REGION)) (mainW (WINDOWPROP iconWindow 'IconFor] (SETQ mainR (WINDOWPROP mainW 'REGION)) (MOVEW mainW (IPLUS (fetch LEFT of mainR) (IDIFFERENCE (fetch XCOORD of pos) (fetch LEFT of wr))) (IPLUS (fetch BOTTOM of mainR) (IDIFFERENCE (fetch YCOORD of pos) (fetch BOTTOM of wr]) (ReshapeShadeFn [LAMBDA (shadeWindow bitMap region) (* dgb%: " 2-AUG-82 00:32") (* Makes sure that mainWindow is reshaped insead of the windowShade) (PROG [(r (WINDOWPROP shadeWindow 'REGION)) (w (WINDOWPROP shadeWindow 'IconFor] (* Open code of close of IconWindow to  avoid interactions) (CLOSEW shadeWindow) (SHAPEW w r) (MakeWindowShade w]) (UnMakeWindowShade [LAMBDA (shade) (* dgb%: " 2-AUG-82 02:05") (* Closefn for MenuShades) (OR shade (SETQ shade (WHICHW))) (PROG [(w (WINDOWPROP shade 'IconFor] (OPENW w) (WINDOWPROP w 'CLOSEFN NIL) (WINDOWPROP w 'IconWindow NIL) (* Open window. Break forward link,  and back link) (WINDOWPROP shade 'IconFor NIL) (RETURN w]) (WindowShadeButtonFn [LAMBDA (windowShade) (* dgb%: " 4-JUN-82 07:14") (* Open the main window, run its button fn, close it and return) (PROG [(mainWindow (OPENW (WINDOWPROP windowShade 'IconFor] (ADJUSTCURSORPOSITION 0 -20) (* Move cursor down so it is sure to be in the mainWindow) (APPLY* (WINDOWPROP mainWindow 'BUTTONEVENTFN) mainWindow) (CLOSEW mainWindow]) ) (* * These fns would probably not be called by a user.) (RPAQQ InternalTMENUFNS (AddItem CEILING ComputeMenuItems DInsert DeleteItem FetchNames InsertItem MenuButtonFn NewMenuExpr PrintMenuExpr ReShapeMenu SetUpDeleteItem SetUpInsertItem SortItems UnreadExpr)) (DEFINEQ (AddItem [LAMBDA (window menu) (* ct%: "14-JUN-82 07:22") (* * Adds an item from the terminal stream to the menu in the window.) (PROG (item) (CLEARBUF) (PROMPT "Please type in new menu item." "(Either an atom or a list of form: (printThis evalThis comment trailerStr))") (SETQ item (OR (READ) lastDeletedItem)) (CLEARBUF) (CPROMPT) (replace ITEMS of menu with (NCONC1 (fetch ITEMS of menu) item)) (ReShapeMenu window]) (CEILING [LAMBDA (fnum) (* ct%: " 8-DEC-81 14:15") (* * Returns the minimum integer greater or equal to a number.) (PROG (num) (SETQ num (FIX fnum)) (RETURN (COND ((LESSP num fnum) (ADD1 num)) (T num]) (ComputeMenuItems [LAMBDA (window menu) (* ct%: "13-JUN-82 00:36") (* * Use the expression associated with a menu to recompute the list of items.) (PROG (expr items) (SETQ expr (WINDOWPROP window 'MENUEXPR)) (COND [expr (SETQ items (EVAL expr)) (COND ((OR (LISTP items) (NULL items)) (replace ITEMS of menu with items) (ReShapeMenu window NIL NIL menu)) (T (CPROMPT "Menu expression returns non-list."] (T (CPROMPT "No expression for this menu."]) (DInsert [LAMBDA (newItem oldItem List) (* ct%: " 8-DEC-81 14:15") (* * Destructively inserts newItem before alloccurences of oldItem in List.) (PROG (TempList) (SETQ TempList (LSUBST (LIST newItem oldItem) oldItem List)) (RPLACA List (CAR TempList)) (RPLACD List (CDR TempList)) (RETURN List]) (DeleteItem [LAMBDA (item menu button) (* mjs%: "11-FEB-82 17:33") (* * Used to delete an item from a menu.) (PROG (items itemExpr) (SETQ lastDeletedItem item) (replace ITEMS of menu with (DREMOVE item (fetch ITEMS of menu))) (CPROMPT) (ReShapeMenu (WFROMMENU menu) NIL NIL menu) (replace WHENSELECTEDFN of menu with (FUNCTION UnreadExpr]) (FetchNames [LAMBDA (lst) (* hgb%: " 4-JUN-82 13:22") (for x in lst collect (COND ((LISTP x) (CAR x)) (T x]) (InsertItem [LAMBDA (listItem menu button) (* ct%: "14-JUN-82 07:24") (* * Inserts a newItem from the terminal stream to the menu just before the  selected listItem. Assumes list has no duplicates.) (PROG (newItem newList) (CLEARBUF) (PROMPT "Please type in new item." "(Either an atom, or a list of form: (printThis evalThis comment trailerStr))") (SETQ newItem (OR (READ) lastDeletedItem)) (CLEARBUF) (CPROMPT) (replace ITEMS of menu with (DInsert newItem listItem (fetch ITEMS of menu))) (ReShapeMenu (WFROMMENU menu) NIL NIL menu) (replace WHENSELECTEDFN of menu with (FUNCTION UnreadExpr]) (MenuButtonFn [LAMBDA (window) (* mjs%: " 7-DEC-82 13:26") (* * Called when LEFT or MIDDLE button depressed inside a window.  Routes action to MENU.HANDLER for LEFT and to MenuActionFn if MIDDLE.) (PROG (menu selection) [SETQ menu (CAR (WINDOWPROP window 'MENU] (TOTOPW window) (COND [(LASTMOUSESTATE LEFT) (* Here to select item.  Use standard menu package functions.) (COND ([SETQ selection (MENU.HANDLER menu (WINDOWPROP window 'DSP] (DOSELECTEDITEM menu (CAR selection) (CDR selection] ((LASTMOUSESTATE MIDDLE) (* Here to process AddItem or  DeleteItem action.) (SELECTQ (MENU (SETQ YellowButtonMenu (create MENU ITEMS _ YellowButtonItems))) (AddItem (AddItem window menu)) (DeleteItem (SetUpDeleteItem window menu)) (SortItems (SortItems window menu)) (InsertItem (SetUpInsertItem window menu)) (UseExpr (ComputeMenuItems window menu)) (NewExpr (NewMenuExpr window menu)) (PrintExpr (PrintMenuExpr window menu)) NIL]) (NewMenuExpr [LAMBDA (window menu) (* ct%: " 8-DEC-81 14:15") (* * Set a new expression for computing the menu items.) (PROG (EXPR) (CPROMPT "Enter New Expression for computing Menu items.") (SETQ EXPR (READ)) (WINDOWPROP window 'MENUEXPR EXPR) (CPROMPT) (ComputeMenuItems window menu]) (PrintMenuExpr [LAMBDA (window menu) (* ct%: " 8-DEC-81 14:15") (* * Print the expression for computing the items of this menu.) (PROG (EXPR) (SETQ EXPR (WINDOWPROP window 'MENUEXPR)) (COND (EXPR (PRINT EXPR)) (T (CPROMPT "No Expression Set for this Menu"))) (CLEARBUF]) (ReShapeMenu [LAMBDA (window oldImageBm oldRegion menu) (* ; "Edited 8-Nov-88 17:04 by jtm:") (* * Used to reshape menus created by TMenu.  Tries to choose menuRows and menuColumns appropriately, and to adjust  itemHeight and itemWidth so that the menu fits nicely in the window.) (PROG (menuColumns menuRows width height items itemWidth itemHeight font numItems clipRegion oldButtonEventFn) [COND ((NULL menu) (SETQ menu (CAR (WINDOWPROP window 'MENU] (SETQ clipRegion (DSPCLIPPINGREGION NIL window)) (SETQ width (fetch WIDTH of clipRegion)) (SETQ height (fetch HEIGHT of clipRegion)) (* * Compute itemWidth to be the widest printing item in the menu.  Allow 2 points extra spacing.) (SETQ font (fetch (MENU MENUFONT) of menu)) [SETQ items (for item in (fetch ITEMS of menu) collect (COND ((NLISTP item) item) (T (CAR item] (SETQ itemWidth (IPLUS (MAXSTRINGWIDTH items font) 2)) (* * Compute menuColumns to be the ratio of the window WIDTH to the itemWidth,  but no more than the number of items in the menu and at least one.) (SETQ numItems (FLENGTH items)) (SETQ menuColumns (MAX (MIN (IQUOTIENT width itemWidth) numItems) 1)) (* * Given menuColumns, adjust itemWidth so that the items will exactly fill  the window.) (SETQ itemWidth (IQUOTIENT width menuColumns)) (SETQ menuRows (CEILING (FQUOTIENT numItems menuColumns))) (* * Compute itemHeight to be the ratio of the window height to the number of  rows, but at least the height of the font.) [SETQ itemHeight (IMAX (IQUOTIENT height menuRows) (FONTPROP font 'HEIGHT] (* Recompute menuRows in case they  won't fit.) (SETQ menuRows (CEILING (FQUOTIENT height itemHeight))) (COND ((AND (EQP menuRows 2) (IGREATERP numItems 3) (IGREATERP (IQUOTIENT numItems 2) (IDIFFERENCE numItems menuColumns))) (* * Bias row and column configuration to prevent widow rows.  Only for 2 row menus having fewer than half the items in the second row.) (SETQ menuColumns (CEILING (FQUOTIENT numItems 2))) (SETQ itemWidth (IQUOTIENT width menuColumns))) ((AND [IGREATERP height (ITIMES numItems (FONTPROP font 'HEIGHT] (OR (GREATERP (QUOTIENT itemHeight itemWidth) numItems) (EQ menuRows 1))) (* * Bias choice to vertical column menu if it is feasible.) (SETQ menuColumns 1) (SETQ menuRows numItems) (SETQ itemHeight (IQUOTIENT height numItems)) (SETQ itemWidth width))) (* * Smash values in the menu record.) (replace MENUCOLUMNS of menu with menuColumns) (replace ITEMHEIGHT of menu with itemHeight) (replace ITEMWIDTH of menu with itemWidth) (replace MENUROWS of menu with NIL) (replace MENUOUTLINESIZE of menu with 0) (* * This hack forces the menu package to remove the window, observe the  changed parameters in the menu record, and re-display the menu.  It also compensates for some window properties smashed by ADDMENU%: RESHAPEFN  and BUTTONEVENTFN.) (SETQ oldButtonEventFn (WINDOWPROP window 'BUTTONEVENTFN)) (DELETEMENU menu) (UPDATE/MENU/IMAGE menu) (* Make menu scrollable if needed.) (WINDOWPROP window 'SCROLLFN NIL) (ADDMENU menu window (create POSITION XCOORD _ 0 YCOORD _ 0) (IGREATERP numItems (ITIMES menuRows menuColumns))) (WINDOWPROP window 'RESHAPEFN (FUNCTION ReShapeMenu)) (WINDOWPROP window 'BUTTONEVENTFN (APPLY 'FUNCTION (LIST oldButtonEventFn))) (RETURN window]) (SetUpDeleteItem [LAMBDA (window menu) (* ct%: " 8-DEC-81 14:15") (* * Temporarily replaces WHENSELECTEDFN so that selection causes deletion of  item from menu.) (replace WHENSELECTEDFN of menu with (FUNCTION DeleteItem)) (CPROMPT "Please select menu item to be deleted."]) (SetUpInsertItem [LAMBDA (window menu) (* ct%: " 8-DEC-81 14:15") (* * Temporarily replaces WHENSELECTEDFN so that selection causes insertion of  new item just before selected item.) (replace WHENSELECTEDFN of menu with (FUNCTION InsertItem)) (CPROMPT "Select item to insert new item before."]) (SortItems [LAMBDA (window menu) (* ct%: " 8-DEC-81 14:15") (* Sort the items in the menu.) (replace ITEMS of menu with (SORT (fetch ITEMS of menu))) (ReShapeMenu window NIL NIL menu]) (UnreadExpr [LAMBDA (exp menu) (* mjs%: " 7-DEC-82 13:36") (* * Items have the following fields%: (printx evalx commentx trailx) where -  printx is what appears in the menu. -  evalx is an expression to be evaluated if item is selected.  -  commentx appears if item is red buttoned for a minimum time.  -  trailx is the character printed after the item in the print stream.  -  every field except print is optional. Default trail the defaultTrailingString  argument specified when the TMenu was created if specified.  Otherwise it is a space if print is atom, and the empty string otherwise.) (PROG (printx evalx trailx) (SETQ trailx (WINDOWPROP (WFROMMENU menu) 'DEFAULTTRAILERSTRING)) [COND ((NLISTP exp) (* Here item is just an atom.) (SETQ printx exp) (SETQ trailx (OR trailx " "))) (T (* Here when item is a list.) (SETQ printx (CAR exp)) [COND ((SETQ evalx (CADR exp)) (SETQ printx (EVAL evalx] (COND ((CADDDR exp) (SETQ trailx (CADDDR exp))) ((NLISTP printx) (SETQ trailx (OR trailx " "] (BKSYSBUF printx) (COND (trailx (BKSYSBUF trailx]) ) (RPAQQ YellowButtonItems ((AddItem 'AddItem "Add item to menu") (DeleteItem 'DeleteItem "Delete item from menu") (InsertItem 'InsertItem "Insert item in menu") (SortItems 'SortItems "Sort items in menu") (UseExpr 'UseExpr "Use itemExpr to recompute item list for menu") (NewExpr 'NewExpr "Used to enter a new expression for computing items on menu") (PrintExpr 'PrintExpr "Prints the current itemExpr"))) (RPAQQ YellowButtonMenu NIL) (RPAQQ firstCallFlgTmenu T) (RPAQQ lastDeletedItem NIL) (RPAQQ menuedFiles NIL) (* Display Utility Functions) (DEFINEQ (SELECTW [LAMBDA NIL (* dgb%: " 7-FEB-83 14:17") (PROG NIL (PROMPT "Move mouse to desired window. then press down the CTRL key or click mouse") LP [COND ((OR (KEYDOWNP 'CTRL) (NOT (MOUSESTATE UP))) (GETMOUSESTATE) (PROMPT) (RETURN (WHICHW] (GO LP]) (FLIPREGION [LAMBDA (DSP REGION) (* dgb%: "24-JUN-82 00:01") (* Complement bits in region in DSP. If only DSP is given, complement the  window or the DSP) [COND ((NULL REGION) (SETQ REGION (DSPCLIPPINGREGION NIL DSP] (BITBLT NIL NIL NIL DSP (fetch LEFT of REGION) (fetch BOTTOM of REGION) (fetch WIDTH of REGION) (fetch HEIGHT of REGION) 'TEXTURE 'INVERT BLACKSHADE]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CPROMPT PROMPT) ) (PUTPROPS TMENU COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1618 11313 (MakeFileMenus 1628 . 4927) (TMenu 4929 . 9648) (PROMPT 9650 . 10132) ( CPROMPT 10134 . 10776) (CloseFileMenus 10778 . 11311)) (11507 15819 (MakeWindowShade 11517 . 13306) ( MoveShadeFn 13308 . 14162) (ReshapeShadeFn 14164 . 14702) (UnMakeWindowShade 14704 . 15298) ( WindowShadeButtonFn 15300 . 15817)) (16164 29963 (AddItem 16174 . 16864) (CEILING 16866 . 17239) ( ComputeMenuItems 17241 . 17975) (DInsert 17977 . 18415) (DeleteItem 18417 . 18939) (FetchNames 18941 . 19212) (InsertItem 19214 . 20085) (MenuButtonFn 20087 . 21672) (NewMenuExpr 21674 . 22103) ( PrintMenuExpr 22105 . 22516) (ReShapeMenu 22518 . 27175) (SetUpDeleteItem 27177 . 27565) ( SetUpInsertItem 27567 . 27976) (SortItems 27978 . 28310) (UnreadExpr 28312 . 29961)) (30596 31600 ( SELECTW 30606 . 31027) (FLIPREGION 31029 . 31598))))) STOP \ No newline at end of file diff --git a/lispusers/xcl-bridge.tedit b/lispusers/xcl-bridge.tedit new file mode 100644 index 00000000..fb44f407 Binary files /dev/null and b/lispusers/xcl-bridge.tedit differ diff --git a/lispusers/xerox-to-xbm.lisp b/lispusers/xerox-to-xbm.lisp new file mode 100644 index 00000000..54f8abe8 --- /dev/null +++ b/lispusers/xerox-to-xbm.lisp @@ -0,0 +1 @@ +;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*- ;;; ;;; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved. ;;; (in-package 'xcl-user) (defun xerox-to-xbm(path bitmap &optional name) (let* ((base (il:|fetch| il:bitmapbase il:|of| bitmap)) (height (il:|fetch| il:bitmapheight il:|of| bitmap)) (width (il:|fetch| il:bitmapwidth il:|of| bitmap)) (depth 1) (w (il:|fetch| il:bitmaprasterwidth il:|of| bitmap)) (il-line-size (ceiling (* width depth) 8)) (line-width (* 4 (ceiling (* width depth) 32))) (line-waste (- line-width il-line-size)) (data (make-array (* height line-width) :element-type '(unsigned-byte 8) :initial-element 0)) (i -1) (byte-width (ceiling (* width depth) 8)) (line 0) (byte-number 0) (count 0)) (unless name (setq name (pathname-name path))) (when (and (probe-file path) (y-or-n-p "Delete the old version of bitmap?")) (delete-file path)) (dotimes (j height) (dotimes (k (floor il-line-size 2)) (setf (aref data (incf i)) (il:\\getbasebyte base 0)) (setf (aref data (incf i)) (il:\\getbasebyte base 1)) (setq base (il:\\addbase base 1))) (dotimes (k (second (multiple-value-list (floor il-line-size 2)))) (setf (aref data (incf i)) (il:\\getbasebyte base 0)) (setq base (il:\\addbase base 1))) (incf i line-waste)) ;; The following code is a modified version of code chunk from the CLX file ;; image.lisp. The significant difference is that I had to reverse the bit ;; order of each byte of data by reflecting the nibbles, then reversing ;; them. ;; Writes an image to a C include file in standard X11 format ;; NAME argument used for variable prefixes. Defaults to "image" (setq name (string-downcase (string name))) (with-open-file (fstream path :direction :output) (format fstream "#define ~a_width ~d~%" name width) (format fstream "#define ~a_height ~d~%" name height) (unless (= depth 1) (format fstream "#define ~a_depth ~d~%" name depth)) (format fstream "static char ~a_bits[] = {" name) (dotimes (i height) (dotimes (j byte-width) (when (zerop (mod count 12)) (format fstream "~% ")) (write-string " 0x" fstream) ;; Faster than (format fstream "0x~2,'0x," byte) (let ((byte (aref data (+ line byte-number))) ;; Reflect nibbles. (translate "084c2a6e195d3b7f")) ;"0123456789abcdef" ;; Reverse nibbles. (write-char (aref translate (ldb (byte 4 0) byte)) fstream) (write-char (aref translate (ldb (byte 4 4) byte)) fstream) (incf byte-number) (incf count) (unless (and (= (1+ i) height) (= (1+ j) byte-width)) (write-char #\, fstream)))) (setq byte-number 0 line (+ line line-width))) (format fstream "};~%" fstream)))) \ No newline at end of file diff --git a/lispusers/xerox-to-xbm.txt b/lispusers/xerox-to-xbm.txt new file mode 100644 index 00000000..3ddf3242 Binary files /dev/null and b/lispusers/xerox-to-xbm.txt differ